diff --git a/.gitignore b/.gitignore index da3bde283..108c09465 100644 --- a/.gitignore +++ b/.gitignore @@ -93,3 +93,5 @@ examples/*/input*~ !examples/compressible_taylor_green/dns.tke !examples/compressible_taylor_green/plot.me !examples/amrcomp_drop/scripts +nga2_key +nga2_key.pub \ No newline at end of file diff --git a/examples/NOSB/GNUmakefile b/examples/NOSB/GNUmakefile new file mode 100644 index 000000000..23c4d3dba --- /dev/null +++ b/examples/NOSB/GNUmakefile @@ -0,0 +1,49 @@ +# NGA location if not yet defined +NGA_HOME ?= ~/nga2/Repositories/nga2 + +# Compilation parameters +PRECISION = DOUBLE +USE_MPI = TRUE +USE_HYPRE = TRUE +USE_LAPACK= TRUE +USE_FFTW = TRUE +USE_IRL = FALSE +PROFILE = FALSE +DEBUG = FALSE +COMP = gnu +EXEBASE = nga + +# Directories that contain user-defined code +Udirs := src + +# Include user-defined sources +Upack += $(foreach dir, $(Udirs), $(wildcard $(dir)/Make.package)) +Ulocs += $(foreach dir, $(Udirs), $(wildcard $(dir))) +include $(Upack) +INCLUDE_LOCATIONS += $(Ulocs) +VPATH_LOCATIONS += $(Ulocs) + +# External libraries are defined in .profile/.bashrc/.zshrc, but could be defined here as well +HYPRE_DIR=/Users/imauser/nga2/Repositories/hypre/src/hypre +FFTW_DIR=/opt/homebrew/Cellar/fftw/3.3.10_2 + +# NGA compilation definitions +include $(NGA_HOME)/tools/GNUMake/Make.defs + +# Include NGA base code +Bdirs := constant_density particles core data transform solver config grid libraries +Bpack += $(foreach dir, $(Bdirs), $(NGA_HOME)/src/$(dir)/Make.package) +include $(Bpack) + +# Inform user of Make.packages used +ifdef Ulocs + $(info Taking user code from: $(Ulocs)) +endif +$(info Taking base code from: $(Bdirs)) + +# Target definition +all: $(executable) + @echo COMPILATION SUCCESSFUL + +# NGA compilation rules +include $(NGA_HOME)/tools/GNUMake/Make.rules diff --git a/examples/NOSB/input b/examples/NOSB/input new file mode 100644 index 000000000..e74be0075 --- /dev/null +++ b/examples/NOSB/input @@ -0,0 +1,30 @@ +# Parallelization +Partition : 9 1 1 + + +# Beam Shape +Lz : 0.01 +Ly : 0.01 +Lx : .1 +R : 0.000 +Particle file: element_data.bin + +# Solid properties +Subdivisions : 33 +Elastic Modulus : 200e9 +Poisson Ratio : 0.30 +Solid density : 7850 +Critical Energy Release Rate : 100000 +Horizon Ratio : 3.015 +N Across : 9 +Mean Particle Spacing : 0.00125 +Solid Load : 1e3 +Solid Damping Constant : 0.015 + +# Time integration +Max timestep size : 3.0e-7 +Max cfl number : 1.3 +Max time : 10 + +# Ensight output +Ensight output period : 1e-5 diff --git a/examples/NOSB/src/Make.package b/examples/NOSB/src/Make.package new file mode 100644 index 000000000..ddc060c7d --- /dev/null +++ b/examples/NOSB/src/Make.package @@ -0,0 +1,2 @@ +# List here the extra files here +f90EXE_sources += simulation.f90 geometry.f90 lss_class.f90 spcomp_class.f90 diff --git a/examples/NOSB/src/geometry.f90 b/examples/NOSB/src/geometry.f90 new file mode 100644 index 000000000..6bd8805f9 --- /dev/null +++ b/examples/NOSB/src/geometry.f90 @@ -0,0 +1,138 @@ +!> Various definitions and tools for initializing NGA2 config +module geometry + use config_class, only: config + use precision, only: WP + implicit none + private + + !> Single config + type(config), public :: cfg + + public :: geometry_init + +contains + + + !> Initialization of problem geometry + subroutine geometry_init + use sgrid_class, only: sgrid + use param, only: param_read + implicit none + type(sgrid) :: grid + + + ! Create a grid from input params + create_grid: block + use sgrid_class, only: cartesian + integer :: i,j,k,nx,ny,nz,N + real(WP) :: Lx,Ly,Lz,dist,dx,R + real(WP), dimension(:), allocatable :: x,y,z + + call param_read('Lx',Lx) + call param_read('Ly',Ly) + call param_read('Lz',Lz) + call param_read('R',R) + call param_read('N Across',N) + + ! Lx = 1.0_WP ! beam length + ! Ly = 1.0_WP ! beam length + + ! dist = 0.01_WP ! Space between particles + dist = Ly/N + Lx = Lx + 3.0_WP*(3.015_WP) * dist ! total length of the beam + ! Ly = Ly + 3.0_WP * dist ! total length of the beam + + dx = 3.015_WP*dist ! grid spacing + ! print*, "Grid Spacing : ", dx + + nx = ceiling(Lx/dx)+2 ! number of division in x + ny = ceiling(Ly/dx)+2 + nz = ceiling(Lz/dx)+2 + + allocate(x(nx+1)) + allocate(y(ny+1)) + allocate(z(nz+1)) + + ! Create simple rectilinear grid + do i=1,nx+1 + x(i)=real(i-2,WP)*dx - Lx/2.0_WP - 1.5_WP*dist + end do + do j=1,ny+1 + y(j)=real(j-2,WP)*dx - Ly/2.0_WP - 1.5_WP*dist + end do + do k=1,nz+1 + z(k)=real(k-2,WP)*dx - Lz/2.0_WP - 1.5_WP*dist + end do + ! General serial grid object (no=3 needed to support ghost/image point interpolation/extrapolation) + grid=sgrid(coord=cartesian,no=3,x=x,y=y,z=z,xper=.false.,yper=.false.,zper=.false.,name='box') + + end block create_grid + + ! create_grid: block + ! use sgrid_class, only: cartesian + ! integer :: i,j,k,nx,ny,nz + ! real(WP) :: Lx,Ly,Lz,dist + ! real(WP), dimension(:), allocatable :: x,y,z + + ! ! Read in grid definition + ! call param_read('Lx',Lx); Lx=Lx + ! call param_read('Ly',Ly); Ly=Ly + ! call param_read('Lz',Lz); Lz=Lz + ! call param_read('Subdivisions',ny) + ! dist = 3.0_WP * Ly / real(ny,WP) + ! Lx = Lx + 3.0_WP * dist + ! nx = ceiling(Lx / dist) + 4 + ! ny = ceiling(Ly / dist) + 2 + ! nz = ceiling(Lz / dist) + 2 + + ! Lx = real(nx,WP) * dist + ! Ly = real(ny,WP) * dist + ! Lz = real(nz,WP) * dist + + + ! allocate(x(nx)) + ! allocate(y(ny+1)) + ! allocate(z(nz+1)) + + + ! ! Create simple rectilinear grid + ! do i=1,nx + ! x(i)=real(i-2,WP)*dist + ! end do + ! do j=1,ny+1 + ! y(j)=real(j-1,WP)*dist-0.5_WP*Ly + ! end do + ! do k=1,nz+1 + ! z(k)=real(k-1,WP)*dist-0.5_WP*Lz + ! end do + + + + + ! ! General serial grid object (no=3 needed to support ghost/image point interpolation/extrapolation) + ! grid=sgrid(coord=cartesian,no=2,x=x,y=y,z=z,xper=.false.,yper=.false.,zper=.false.,name='box') + + ! end block create_grid + + + ! Create a config from that grid on our entire group + create_cfg: block + use parallel, only: group + integer, dimension(3) :: partition + ! Read in partition + call param_read('Partition',partition,short='p') + ! Create partitioned grid + cfg=config(grp=group,decomp=partition,grid=grid) + end block create_cfg + + + ! Create walls for this config + create_walls: block + cfg%VF=1.0_WP + end block create_walls + + + end subroutine geometry_init + + +end module geometry diff --git a/examples/NOSB/src/lss_class.f90 b/examples/NOSB/src/lss_class.f90 new file mode 100644 index 000000000..64a5ac46f --- /dev/null +++ b/examples/NOSB/src/lss_class.f90 @@ -0,0 +1,1595 @@ +!> Lagrangian solid solver object +!> Implements peridynamics equations +module lss_class + use precision, only: WP + use string, only: str_medium + use config_class, only: config + use mpi_f08, only: MPI_Datatype,MPI_INTEGER8,MPI_INTEGER,MPI_DOUBLE_PRECISION + implicit none + private + + + ! Expose type/constructor/methods + public :: lss + + + !> Memory adaptation parameter + real(WP), parameter :: coeff_up=1.3_WP !< Particle array size increase factor + real(WP), parameter :: coeff_dn=0.7_WP !< Particle array size decrease factor + + + !> I/O chunk size to read at a time + integer, parameter :: part_chunk_size=1000 !< Read 1000 particles at a time before redistributing + + + !> Maximum number of bonds per particle + integer, parameter, public :: max_bond=400 !< Assumes something like a 7x7x7 stencil in 3D + + + !> Bonded solid particle definition + type :: part + !> MPI_DOUBLE_PRECISION data + real(WP) :: vonMises !< Element dilatation + real(WP) :: vol !< Particle volume + real(WP) :: quadCheck + real(WP), dimension(max_bond) :: dbond !< Length of initial bonds + real(WP), dimension(3) :: pos !< Particle center coordinates + real(WP), dimension(3) :: vel !< Velocity of particle + real(WP), dimension(3) :: Abond !< Bond acceleration for particle + real(WP), dimension(3) :: Afluid !< Fluid acceleration for particle + real(WP), dimension(3) :: ipos !< Initial position + real(WP), dimension(3) :: displacement !< Displacement + real(WP), dimension(3,3) :: F !< Deformation gradient tensor + real(WP), dimension(3,3) :: PK_inv !< First Piola-Kirchoff tensor times shape tensor inverse + !> MPI_INTEGER data + integer :: id !< ID the object is associated with + integer :: i !< Unique index of particle (assumed >0) + integer :: nbond !< Number of initial bonds + integer, dimension(max_bond) :: ibond !< Indices of initially bonded particles (0 values ignored) + integer , dimension(3) :: ind !< Index of cell containing particle center + integer :: flag !< Control parameter (0=normal, 1=done->will be removed) + end type part + !> Number of blocks, block length, and block types in a particle + integer, parameter :: part_nblock=2 + integer , dimension(part_nblock) :: part_lblock=[39+max_bond,7+max_bond] + type(MPI_Datatype), dimension(part_nblock) :: part_tblock=[MPI_DOUBLE_PRECISION,MPI_INTEGER] + !> MPI_PART derived datatype and size + type(MPI_Datatype) :: MPI_PART + integer :: MPI_PART_SIZE + + + !> Lagrangian solid solver object definition + type :: lss + + ! This config is used for parallelization and for calculating bond/collision forces + class(config), pointer :: cfg + + ! This is the name of the solver + character(len=str_medium) :: name='UNNAMED_LSS' + + ! Solid material properties + real(WP) :: elastic_modulus !< Elastic modulus of the material + real(WP) :: poisson_ratio !< Poisson's ratio of the material + real(WP) :: rho !< Density of the material + real(WP) :: crit_energy !< Critical energy release + real(WP) :: beta !< Damping constant + + ! Bonding parameters + real(WP) :: delta !< Bonding horizon (distance) + real(WP) :: min_dist !< Minimum bonding distance + integer :: nb !< Cell-based horizon + + ! Global and local particle data + integer :: np !< Global number of particles + integer :: np_ !< Local number of particles + integer, dimension(:), allocatable :: np_proc !< Number of particles on each processor + type(part), dimension(:), allocatable :: p !< Array of particles of type part + + ! Overlap particle (i.e., ghost) data + integer :: ng_ !< Local number of ghosts + type(part), dimension(:), allocatable :: g !< Array of ghosts of type part + + ! Gravitational acceleration + real(WP), dimension(3) :: gravity=[0.0_WP,0.0_WP,0.0_WP] + + ! Solid volume fraction and momentum + real(WP), dimension(:,:,:), allocatable :: VF !< Volume fraction, cell-centered + real(WP), dimension(:,:,:), allocatable :: VFU !< Solid velocity, U-face + real(WP), dimension(:,:,:), allocatable :: VFV !< Solid velocity, V-face + real(WP), dimension(:,:,:), allocatable :: VFW !< Solid velocity, W-face + + ! CFL numbers + real(WP) :: CFLp_x,CFLp_y,CFLp_z,CFLp_a + + ! Number of substeps for time integrator + real(WP) :: nstep=1 + + ! Monitoring info + real(WP) :: Umin,Umax,Umean !< U velocity info + real(WP) :: Vmin,Vmax,Vmean !< V velocity info + real(WP) :: Wmin,Wmax,Wmean !< W velocity info + real(WP) :: VFmax !< Volume fraction info + real(WP), dimension(3) :: ibmForce !< Total force due to IBM + integer :: np_out !< Number of particles leaving the domain + + contains + procedure :: bond_init !< Setup initial interparticle bonds + procedure :: get_bond_force !< Compute interparticle bond force + procedure :: advance !< Step forward the particle ODEs + procedure :: get_cfl !< Calculate maximum CFL + procedure :: get_max !< Extract various monitoring data + procedure :: update_partmesh !< Update a partmesh object using current particles + procedure :: share !< Share particles across interprocessor boundaries + procedure :: sync !< Synchronize particles across interprocessor boundaries + procedure :: resize !< Resize particle array to given size + procedure :: resize_ghost !< Resize ghost array to given size + procedure :: recycle !< Recycle particle array by removing flagged particles + procedure :: write !< Parallel write particles to file + procedure :: read !< Parallel read particles from file + procedure :: update_VF !< Compute volume fraction + procedure :: get_delta !< Compute regularized delta function + procedure :: interpolate !< Interpolation routine from mesh=>marker + procedure :: extrapolate !< Extrapolation routine from marker=>mesh + ! procedure :: stretch + end type lss + + + !> Declare lss constructor + interface lss + procedure constructor + end interface lss + +contains + + + ! Quasi-Gaussian weighting function - h is the cut-off + real(WP) function wgauss(d,h) + implicit none + real(WP), intent(in) :: d,h + real(WP), parameter :: coeff=2.6_WP + real(WP) :: hh + ! hh=coeff*h + hh=h + if (d.ge.hh) then + wgauss=0.0_WP + else + ! wgauss=(1.0_WP+4.0_WP*d/hh)*(1.0_WP-d/hh)**4 + wgauss=(1.0_WP-d/h)**3 + end if + end function wgauss + + + !> Default constructor for Lagrangian solid solver + function constructor(cfg,name) result(self) + implicit none + type(lss) :: self + class(config), target, intent(in) :: cfg + character(len=*), optional :: name + integer :: i,j,k + + ! Set the name for the solver + if (present(name)) self%name=trim(adjustl(name)) + + ! Point to pgrid object + self%cfg=>cfg + + ! Set default bonding horizon based on underlying mesh + self%delta=self%cfg%min_meshsize + self%nb=1 + self%min_dist=huge(1.0_WP) + + ! Allocate variables + allocate(self%np_proc(1:self%cfg%nproc)); self%np_proc=0 + self%np_=0; self%np=0 + call self%resize(0) + + ! Initialize MPI derived datatype for a particle + call prepare_mpi_part() + + ! Allocate VF array on cfg mesh + allocate(self%VF(self%cfg%imino_:self%cfg%imaxo_,self%cfg%jmino_:self%cfg%jmaxo_,self%cfg%kmino_:self%cfg%kmaxo_)); self%VF=0.0_WP + allocate(self%VFU(self%cfg%imino_:self%cfg%imaxo_,self%cfg%jmino_:self%cfg%jmaxo_,self%cfg%kmino_:self%cfg%kmaxo_)); self%VFU=0.0_WP + allocate(self%VFV(self%cfg%imino_:self%cfg%imaxo_,self%cfg%jmino_:self%cfg%jmaxo_,self%cfg%kmino_:self%cfg%kmaxo_)); self%VFV=0.0_WP + allocate(self%VFW(self%cfg%imino_:self%cfg%imaxo_,self%cfg%jmino_:self%cfg%jmaxo_,self%cfg%kmino_:self%cfg%kmaxo_)); self%VFW=0.0_WP + + ! Log/screen output + logging: block + use, intrinsic :: iso_fortran_env, only: output_unit + use param, only: verbose + use messager, only: log + use string, only: str_long + character(len=str_long) :: message + if (self%cfg%amRoot) then + write(message,'("LSS object [",a,"] on partitioned grid [",a,"]")') trim(self%name),trim(self%cfg%name) + if (verbose.gt.1) write(output_unit,'(a)') trim(message) + if (verbose.gt.0) call log(message) + end if + end block logging + + end function constructor + + + !> Initialize bond force between particles + subroutine bond_init(this) + use messager, only: die + implicit none + class(lss), intent(inout) :: this + integer, dimension(:,:,:), allocatable :: npic !< Number of particle in cell + integer, dimension(:,:,:,:), allocatable :: ipic !< Index of particle in cell + + ! Communicate particles in ghost cells + call this%share() + + ! We can now assemble particle-in-cell information + pic_prep: block + use mpi_f08 + integer :: i,ip,jp,kp,ierr + integer :: mymax_npic,max_npic + + ! Allocate number of particle in cell + allocate(npic(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)); npic=0 + + ! Count particles and ghosts per cell + do i=1,this%np_ + ip=this%p(i)%ind(1); jp=this%p(i)%ind(2); kp=this%p(i)%ind(3) + npic(ip,jp,kp)=npic(ip,jp,kp)+1 + end do + do i=1,this%ng_ + ip=this%g(i)%ind(1); jp=this%g(i)%ind(2); kp=this%g(i)%ind(3) + npic(ip,jp,kp)=npic(ip,jp,kp)+1 + end do + + ! Get maximum number of particle in cell + mymax_npic=maxval(npic); call MPI_ALLREDUCE(mymax_npic,max_npic,1,MPI_INTEGER,MPI_MAX,this%cfg%comm,ierr) + + ! Allocate pic map + allocate(ipic(1:max_npic,this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)); ipic=0 + + ! Assemble pic map + npic=0 + do i=1,this%np_ + ip=this%p(i)%ind(1); jp=this%p(i)%ind(2); kp=this%p(i)%ind(3) + npic(ip,jp,kp)=npic(ip,jp,kp)+1 + ipic(npic(ip,jp,kp),ip,jp,kp)=+i + end do + do i=1,this%ng_ + ip=this%g(i)%ind(1); jp=this%g(i)%ind(2); kp=this%g(i)%ind(3) + npic(ip,jp,kp)=npic(ip,jp,kp)+1 + ipic(npic(ip,jp,kp),ip,jp,kp)=-i + end do + + end block pic_prep + + ! Establish initial bonds + create_bonds: block + use mpi_f08, only: MPI_ALLREDUCE,MPI_MIN,MPI_IN_PLACE + use parallel, only: MPI_REAL_WP + use mathtools, only: Pi + integer :: i,j,k,n1,nn,n2,ierr + type(part) :: p1,p2 + real(WP), dimension(3) :: rpos + real(WP) :: dist + ! Reset minimum bond distance + this%min_dist=huge(1.0_WP) + ! Loop over particles + do n1=1,this%np_ + ! Create copy of our particle + p1=this%p(n1) + ! Zero out bonds + p1%ibond=0 + p1%nbond=0 + ! Loop over neighbor cells + do k=p1%ind(3)-this%nb,p1%ind(3)+this%nb + do j=p1%ind(2)-this%nb,p1%ind(2)+this%nb + do i=p1%ind(1)-this%nb,p1%ind(1)+this%nb + ! Loop over particles in that cell + do nn=1,npic(i,j,k) + ! Create copy of our neighbor + n2=ipic(nn,i,j,k) + if (n2.gt.0) then + p2=this%p(+n2) + else if (n2.lt.0) then + p2=this%g(-n2) + end if + ! Cannot self-bond + if (p1%i.eq.p2%i) cycle + ! Cannot bond with different id except <=0 (<=0 bonds with everyone) + if (p1%id.ne.p2%id.and.p1%id.ge.0.and.p2%id.ge.0) cycle + ! Check interparticle distance + rpos=p2%pos-p1%pos + dist=sqrt(dot_product(rpos,rpos)) + if (dist.lt.this%delta) then + ! This particle is in horizon, create a bond + p1%nbond=p1%nbond+1 + if (p1%nbond.gt.max_bond) call die('[lss_class bond_init] Number of detected bonds is larger than max allowed') + p1%ibond(p1%nbond)=p2%i + p1%dbond(p1%nbond)=dist + ! Determine minimum bond distance + this%min_dist=min(this%min_dist,dist) + end if + end do + end do + end do + end do + ! Copy back the particle + this%p(n1)=p1 + end do + ! Get global minimum + call MPI_ALLREDUCE(MPI_IN_PLACE,this%min_dist,1,MPI_REAL_WP,MPI_MIN,this%cfg%comm,ierr) + end block create_bonds + + ! Clean up + if (allocated(npic)) deallocate(npic) + if (allocated(ipic)) deallocate(ipic) + + + end subroutine bond_init + + + !> Calculate bond force between particles + subroutine get_bond_force(this) + implicit none + class(lss), intent(inout) :: this + integer, dimension(:,:,:), allocatable :: npic !< Number of particle in cell + integer, dimension(:,:,:,:), allocatable :: ipic !< Index of particle in cell + logical :: is2D + + ! Need to modify parameters in 2D + is2D=this%cfg%nx.eq.1.or.this%cfg%ny.eq.1.or.this%cfg%nz.eq.1 + + ! Communicate particles in ghost cells + call this%share() + + ! We can now assemble particle-in-cell information + pic_prep: block + use mpi_f08 + integer :: i,ip,jp,kp,ierr + integer :: mymax_npic,max_npic + + ! Allocate number of particle in cell + allocate(npic(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)); npic=0 + + ! Count particles and ghosts per cell + do i=1,this%np_ + ip=this%p(i)%ind(1); jp=this%p(i)%ind(2); kp=this%p(i)%ind(3) + npic(ip,jp,kp)=npic(ip,jp,kp)+1 + end do + do i=1,this%ng_ + ip=this%g(i)%ind(1); jp=this%g(i)%ind(2); kp=this%g(i)%ind(3) + npic(ip,jp,kp)=npic(ip,jp,kp)+1 + end do + + ! Get maximum number of particle in cell + mymax_npic=maxval(npic); call MPI_ALLREDUCE(mymax_npic,max_npic,1,MPI_INTEGER,MPI_MAX,this%cfg%comm,ierr) + + ! Allocate pic map + allocate(ipic(1:max_npic,this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)); ipic=0 + + ! Assemble pic map + npic=0 + do i=1,this%np_ + ip=this%p(i)%ind(1); jp=this%p(i)%ind(2); kp=this%p(i)%ind(3) + npic(ip,jp,kp)=npic(ip,jp,kp)+1 + ipic(npic(ip,jp,kp),ip,jp,kp)=+i + end do + do i=1,this%ng_ + ip=this%g(i)%ind(1); jp=this%g(i)%ind(2); kp=this%g(i)%ind(3) + npic(ip,jp,kp)=npic(ip,jp,kp)+1 + ipic(npic(ip,jp,kp),ip,jp,kp)=-i + end do + + end block pic_prep + + ! Update shape and deformation gradient tensor + update_tensors: block + use mathtools + integer :: i,j,k,n1,nn,n2 + type(part) :: p1,p2 + integer :: nb,nbond + real(WP), dimension(3) :: rpos, xi + real(WP) :: dist,w,mu,kk,detK,traceE + real(WP), dimension(3,3) :: K_mat,E_mat,I_mat,S_mat,K_inv + + mu=this%elastic_modulus/(2.0_WP+2.0_WP*this%poisson_ratio) ! shear modulus + kk=this%elastic_modulus/(3.0_WP-6.0_WP*this%poisson_ratio) ! bulk moduls + I_mat = 0.0_WP + S_mat = 0.0_WP + traceE = 0.0_WP + E_mat = 0.0_WP + K_inv = 0.0_WP + I_mat(1,1) = 1.0_WP + I_mat(2,2) = 1.0_WP + I_mat(3,3) = 1.0_WP + + ! Loop over particles + do n1=1,this%np_ + ! Create copy of our particle + p1=this%p(n1) + ! Zero out weighted volume and dilatation + K_mat=0.0_WP + K_inv = 0.0_WP + p1%F=0.0_WP + p1%quadCheck=0.0_WP + ! Loop over neighbor cells + do k=p1%ind(3)-this%nb,p1%ind(3)+this%nb + do j=p1%ind(2)-this%nb,p1%ind(2)+this%nb + do i=p1%ind(1)-this%nb,p1%ind(1)+this%nb + ! Loop over particles in that cell + do nn=1,npic(i,j,k) + ! Create copy of our neighbor + n2=ipic(nn,i,j,k) + if (n2.gt.0) then + p2=this%p(+n2) + else if (n2.lt.0) then + p2=this%g(-n2) + end if + ! Check if a bond exists + do nb=1,max_bond + if (p1%ibond(nb).eq.p2%i) then + ! Get current distance + rpos=p2%pos-p1%pos + !print *, rpos + ! Compute summation of K + xi = p2%ipos-p1%ipos + w = wgauss(p1%dbond(nb),this%delta) + K_mat(1,1)=K_mat(1,1)+xi(1)*xi(1)*w*p2%vol; K_mat(1,2)=K_mat(1,2)+xi(1)*xi(2)*w*p2%vol; K_mat(1,3)=K_mat(1,3)+xi(1)*xi(3)*w*p2%vol; + K_mat(2,1)=K_mat(2,1)+xi(2)*xi(1)*w*p2%vol; K_mat(2,2)=K_mat(2,2)+xi(2)*xi(2)*w*p2%vol; K_mat(2,3)=K_mat(2,3)+xi(2)*xi(3)*w*p2%vol; + K_mat(3,1)=K_mat(3,1)+xi(3)*xi(1)*w*p2%vol; K_mat(3,2)=K_mat(3,2)+xi(3)*xi(2)*w*p2%vol; K_mat(3,3)=K_mat(3,3)+xi(3)*xi(3)*w*p2%vol; + + ! Compute interior summation of F + p1%F(1,1)=p1%F(1,1)+rpos(1)*xi(1)*w*p2%vol; p1%F(1,2)=p1%F(1,2)+rpos(1)*xi(2)*w*p2%vol; p1%F(1,3)=p1%F(1,3)+rpos(1)*xi(3)*w*p2%vol; + p1%F(2,1)=p1%F(2,1)+rpos(2)*xi(1)*w*p2%vol; p1%F(2,2)=p1%F(2,2)+rpos(2)*xi(2)*w*p2%vol; p1%F(2,3)=p1%F(2,3)+rpos(2)*xi(3)*w*p2%vol; + p1%F(3,1)=p1%F(3,1)+rpos(3)*xi(1)*w*p2%vol; p1%F(3,2)=p1%F(3,2)+rpos(3)*xi(2)*w*p2%vol; p1%F(3,3)=p1%F(3,3)+rpos(3)*xi(3)*w*p2%vol; + p1%quadCheck = p1%quadCheck + w*p2%vol + end if + end do + end do + end do + end do + end do + ! Apply inverse of K to get F = F*K^-1 + detK = K_mat(1,1)*(K_mat(2,2)*K_mat(3,3)-K_mat(2,3)*K_mat(3,2)) & + -K_mat(1,2)*(K_mat(2,1)*K_mat(3,3)-K_mat(2,3)*K_mat(3,1)) & + +K_mat(1,3)*(K_mat(2,1)*K_mat(3,2)-K_mat(2,2)*K_mat(3,1)) + K_inv(1,1) = (K_mat(2,2)*K_mat(3,3) - K_mat(2,3)*K_mat(3,2))/detK + K_inv(2,1) = -(K_mat(2,1)*K_mat(3,3) - K_mat(2,3)*K_mat(3,1))/detK + K_inv(3,1) = (K_mat(2,1)*K_mat(3,2) - K_mat(2,2)*K_mat(3,1))/detK + K_inv(1,2) = -(K_mat(1,2)*K_mat(3,3) - K_mat(1,3)*K_mat(3,2))/detK + K_inv(2,2) = (K_mat(1,1)*K_mat(3,3) - K_mat(1,3)*K_mat(3,1))/detK + K_inv(3,2) = -(K_mat(1,1)*K_mat(3,2) - K_mat(1,2)*K_mat(3,1))/detK + K_inv(1,3) = (K_mat(1,2)*K_mat(2,3) - K_mat(1,3)*K_mat(2,2))/detK + K_inv(2,3) = -(K_mat(1,1)*K_mat(2,3) - K_mat(1,3)*K_mat(2,1))/detK + K_inv(3,3) = (K_mat(1,1)*K_mat(2,2) - K_mat(1,2)*K_mat(2,1))/detK + + + p1%F = MATMUL(p1%F,K_inv) + + ! Compute first Piola-Kirchoff stress tensor - constitutive model dependent + E_mat = 0.5_WP * (MATMUL(TRANSPOSE(p1%F),p1%F)-I_mat) + traceE = E_mat(1,1) + E_mat(2,2) + E_mat(3,3) + S_mat = (kk-2.0_WP/3.0_WP*mu)*traceE*I_mat + 2.0_WP*mu*E_mat + p1%PK_inv = MATMUL(MATMUL(p1%F,S_mat),K_inv) + + ! Copy back the particle + this%p(n1)=p1 + end do + end block update_tensors + + ! Re-communicate particles in ghost cells to update dil and mw + call this%share() + + ! Update bond force, including collision force, and SED + update_bond_force: block + use mpi_f08, only: MPI_ALLREDUCE,MPI_MIN,MPI_IN_PLACE + use parallel, only: MPI_REAL_WP + use mathtools, only: Pi + integer :: i,j,k,n1,nn,n2,ierr + type(part) :: p1,p2 + real(WP), dimension(3) :: rpos,t1,t2,tc,xi,z + real(WP), dimension(3,3) :: PK_inv + real(WP) :: dist,t,w + real(WP) :: stretch,max_stretch,mu,kk + real(WP) :: nc,rc,kc + integer :: nb,nbond + logical :: found_bond + ! Recompute a few physical parameters + mu=this%elastic_modulus/(2.0_WP+2.0_WP*this%poisson_ratio) + kk=this%elastic_modulus/(3.0_WP-6.0_WP*this%poisson_ratio) + + if (is2D) then + if (this%cfg%nx.eq.1) t=this%cfg%xL + if (this%cfg%ny.eq.1) t=this%cfg%yL + if (this%cfg%nz.eq.1) t=this%cfg%zL + max_stretch=sqrt(this%crit_energy/((6.0_WP*mu/Pi+16.0_WP/(9.0_WP*Pi**2)*(kk-2.0_WP*mu))*this%delta)) + kc=15.0_WP*48.0_WP*this%elastic_modulus/(Pi*5.0_WP*t*this%delta**3) + else + max_stretch=sqrt(this%crit_energy/((3.0_WP*mu+(kk-5.0_WP*mu/3.0_WP)*0.75_WP**4)*this%delta)) + kc=15.0_WP*12.0_WP*this%elastic_modulus/(Pi*this%delta**4) + end if + nc=1.0_WP + this%min_dist=huge(1.0_WP) + ! Loop over particles + do n1=1,this%np_ + ! Particles marked 0 do not update their forces + if (this%p(n1)%id.eq.0) cycle + ! Create copy of our particle + p1=this%p(n1) + ! Zero out bond force + p1%Abond=0.0_WP + ! Zero out PK_inv + PK_inv=0.0_WP + ! Loop over neighbor cells + do k=p1%ind(3)-this%nb,p1%ind(3)+this%nb + do j=p1%ind(2)-this%nb,p1%ind(2)+this%nb + do i=p1%ind(1)-this%nb,p1%ind(1)+this%nb + ! Loop over particles in that cell + do nn=1,npic(i,j,k) + ! Create copy of our neighbor + n2=ipic(nn,i,j,k) + if (n2.gt.0) then + p2=this%p(+n2) + else if (n2.lt.0) then + p2=this%g(-n2) + end if + ! Current distance + rpos=p2%pos-p1%pos + dist=sqrt(dot_product(rpos,rpos)) + ! Check if a bond exists + found_bond=.false. + do nb=1,max_bond + if (p1%ibond(nb).eq.p2%i) then + ! Check for breakage first + stretch=(dist-p1%dbond(nb))/p1%dbond(nb) + if (stretch.gt.max_stretch) then + ! Remove the bond and flag as surface particle + p1%ibond(nb)=0 + p1%dbond(nb)=0.0_WP + cycle + end if + w = wgauss(p1%dbond(nb),this%delta) + xi = p2%ipos-p1%ipos + ! Force density 1->2 + t1 = w*MATMUL(p1%PK_inv,xi) + ! Force density 2->1 + t2 = w*MATMUL(p2%PK_inv,xi) + ! Force correction term + z = rpos-MATMUL(p1%F,xi) + tc = w*(9.0_WP*kk/(Pi * this%delta**4))*(dot_product(xi,z)/(sqrt(dot_product(xi,xi)))**3)*xi + ! Compute bond acceleration + p1%Abond=p1%Abond+(t1+t2+tc)*p2%vol/this%rho + ! If still here, we have an active bond + found_bond=.true. + ! Determine minimum bond distance + this%min_dist=min(this%min_dist,dist) + cycle + end if + end do + ! Add collision force now + ! if (is2D) then + ! rc=p1%vol**(1.0_WP/2.0_WP) + ! else + ! rc=p1%vol**(1.0_WP/3.0_WP) + ! end if + ! if (.not.found_bond.and.p1%i.ne.p2%i.and.dist.lt.rc) then + ! p1%Abond=p1%Abond-max(kc*((rc/dist)**nc-1.0_WP),0.0_WP)*(rpos/dist)*p1%vol/this%rho + ! p1%flag = -2 + ! end if + end do + end do + end do + end do + ! Deal with dimensionality + if (this%cfg%nx.eq.1) p1%Abond(1)=0.0_WP + if (this%cfg%ny.eq.1) p1%Abond(2)=0.0_WP + if (this%cfg%nz.eq.1) p1%Abond(3)=0.0_WP + ! Copy back the particle + this%p(n1)=p1 + end do + ! Get global minimum + call MPI_ALLREDUCE(MPI_IN_PLACE,this%min_dist,1,MPI_REAL_WP,MPI_MIN,this%cfg%comm,ierr) + end block update_bond_force + + ! Clean up + if (allocated(npic)) deallocate(npic) + if (allocated(ipic)) deallocate(ipic) + + end subroutine get_bond_force + + + !> Advance the particle equations by a specified time step dt + !> p%id=-2 => do not solve for position nor velocity + !> p%id=-1 => do not solve for velocity + !> p%id= 0 => do not update force + + subroutine advance(this,dt)!,stress_x,stress_y,stress_z) + use mpi_f08, only : MPI_SUM,MPI_INTEGER,MPI_IN_PLACE + use mathtools, only: Pi + implicit none + class(lss), intent(inout) :: this + real(WP), intent(inout) :: dt !< Timestep size over which to advance + ! real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(inout) :: stress_x !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + ! real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(inout) :: stress_y !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + ! real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(inout) :: stress_z !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + integer :: n,ierr + ! real(WP), dimension(3) :: stress + + ! Zero out number of particles removed + this%np_out=0 + + ! Advance velocity based on old force and position based on mid-velocity + do n=1,this%np_ + ! Advance with Verlet scheme + if (this%p(n)%id.gt.-1) this%p(n)%vel=(1-this%beta)*this%p(n)%vel+0.5_WP*dt*(this%gravity+this%p(n)%Abond+this%p(n)%Afluid) + if (this%p(n)%id.gt.-2) this%p(n)%pos=this%p(n)%pos+dt*this%p(n)%vel + this%p(n)%displacement=this%p(n)%pos-this%p(n)%ipos + ! Relocalize + this%p(n)%ind=this%cfg%get_ijk_global(this%p(n)%pos,this%p(n)%ind) + ! Correct the position to take into account periodicity + if (this%cfg%xper) this%p(n)%pos(1)=this%cfg%x(this%cfg%imin)+modulo(this%p(n)%pos(1)-this%cfg%x(this%cfg%imin),this%cfg%xL) + if (this%cfg%yper) this%p(n)%pos(2)=this%cfg%y(this%cfg%jmin)+modulo(this%p(n)%pos(2)-this%cfg%y(this%cfg%jmin),this%cfg%yL) + if (this%cfg%zper) this%p(n)%pos(3)=this%cfg%z(this%cfg%kmin)+modulo(this%p(n)%pos(3)-this%cfg%z(this%cfg%kmin),this%cfg%zL) + ! Handle particles that have left the domain + if (this%p(n)%pos(1).lt.this%cfg%x(this%cfg%imin).or.this%p(n)%pos(1).gt.this%cfg%x(this%cfg%imax+1)) this%p(n)%flag=1 + if (this%p(n)%pos(2).lt.this%cfg%y(this%cfg%jmin).or.this%p(n)%pos(2).gt.this%cfg%y(this%cfg%jmax+1)) this%p(n)%flag=1 + if (this%p(n)%pos(3).lt.this%cfg%z(this%cfg%kmin).or.this%p(n)%pos(3).gt.this%cfg%z(this%cfg%kmax+1)) this%p(n)%flag=1 + ! Relocalize the particle + this%p(n)%ind=this%cfg%get_ijk_global(this%p(n)%pos,this%p(n)%ind) + ! Count number of particles removed + if (this%p(n)%flag.eq.1) this%np_out=this%np_out+1 + end do + + ! Communicate particles + call this%sync() + + ! Sum up particles removed + call MPI_ALLREDUCE(this%np_out,n,1,MPI_INTEGER,MPI_SUM,this%cfg%comm,ierr); this%np_out=n + + ! Calculate bond force + call this%get_bond_force() + + ! Advance velocity only based on new force + do n=1,this%np_ + ! Advance with Verlet scheme + if (this%p(n)%id.le.-1) cycle + ! stress=this%cfg%get_velocity(pos=this%p(n)%pos,i0=this%p(n)%ind(1),j0=this%p(n)%ind(2),k0=this%p(n)%ind(3),U=stress_x,V=stress_y,W=stress_z) + ! this%p(n)%Afluid=stress/this%rho + ! this%p(n)%Afluid=0.0_WP + ! A Fluid is zero in the init, but is non-zero for pulling elements if specified + this%p(n)%vel=this%p(n)%vel*(1-this%beta)+0.5_WP*dt*(this%gravity+this%p(n)%Abond+this%p(n)%Afluid) + end do + + ! Recompute volume fraction + ! call this%update_VF() + + ! Log/screen output + logging: block + use, intrinsic :: iso_fortran_env, only: output_unit + use param, only: verbose + use messager, only: log + use string, only: str_long + character(len=str_long) :: message + if (this%cfg%amRoot) then + write(message,'("Particle solver [",a,"] on partitioned grid [",a,"]: ",i0," particles were advanced")') trim(this%name),trim(this%cfg%name),this%np + if (verbose.gt.1) write(output_unit,'(a)') trim(message) + if (verbose.gt.0) call log(message) + end if + end block logging + + end subroutine advance + + ! subroutine stretch(this,dt)!,stress_x,stress_y,stress_z) + ! use mpi_f08, only : MPI_SUM,MPI_INTEGER,MPI_IN_PLACE + ! use mathtools, only: Pi + ! implicit none + ! class(lss), intent(inout) :: this + ! real(WP), intent(inout) :: dt !< Timestep size over which to advance + ! real(WP) :: mu + ! integer :: n,ierr + ! real(WP), dimension(:,:), allocatable :: temp_gd + + ! allocate(temp_gd(this%np_, 3)) + ! !======================================================================================== + ! ! X-Axis Stretch: + ! ! Zero out number of particles removed + ! this%np_out=0 + ! do n=1,this%np_ + ! ! Stretch the beam along the x axis with a uniform strain-rate of 0.001 + ! this%p(n)%pos(1)=this%p(n)%pos(1)*1.001_WP + ! end do + + ! ! Communicate particles + ! call this%sync() + + ! ! Calculate bond force + ! call this%get_bond_force() + + ! mu=this%elastic_modulus/(2.0_WP+2.0_WP*this%poisson_ratio) + + ! do n=1,this%np_ + ! temp_gd(n,1)=0.001_WP/this%p(n)%dil + ! end do + + ! !======================================================================================== + ! ! Y-Axis Stretch: + ! ! Zero out number of particles removed + ! this%np_out=0 + ! do n=1,this%np_ + ! ! Stretch the beam along the x axis with a uniform strain-rate of 0.001 + ! this%p(n)%pos(1)=this%p(n)%pos(1)/1.001_WP + ! this%p(n)%pos(2)=this%p(n)%pos(2)*1.001_WP + ! end do + + ! ! Communicate particles + ! call this%sync() + + ! ! Calculate bond force + ! call this%get_bond_force() + + ! mu=this%elastic_modulus/(2.0_WP+2.0_WP*this%poisson_ratio) + + ! do n=1,this%np_ + ! temp_gd(n,2)=0.001_WP/this%p(n)%dil + ! end do + + ! !======================================================================================== + ! ! Z-Axis Stretch: + ! ! Zero out number of particles removed + ! this%np_out=0 + ! do n=1,this%np_ + ! ! Stretch the beam along the x axis with a uniform strain-rate of 0.001 + ! this%p(n)%pos(2)=this%p(n)%pos(2)/1.001_WP + ! this%p(n)%pos(3)=this%p(n)%pos(3)*1.001_WP + ! end do + + ! ! Communicate particles + ! call this%sync() + + ! ! Calculate bond force + ! call this%get_bond_force() + + ! mu=this%elastic_modulus/(2.0_WP+2.0_WP*this%poisson_ratio) + + ! do n=1,this%np_ + ! temp_gd(n,3)=0.001_WP/this%p(n)%dil + ! end do + + ! ! Put the particle back where it was + ! do n=1,this%np_ + ! this%p(n)%pos(3)=this%p(n)%pos(3)/1.001_WP + ! end do + + ! !====================================================================================== + + ! ! Now stretch particle for the first time step + + ! do n=1,this%np_ + ! ! Stretch the beam along the x axis with a uniform strain-rate of 0.001 + ! this%p(n)%gd=temp_gd(n,:) + ! end do + + ! do n=1,this%np_ + ! ! Stretch the beam along the x axis with a uniform strain-rate of 0.001 + ! this%p(n)%pos=this%p(n)%pos*1.001_WP + ! this%p(n)%displacement=this%p(n)%pos-this%p(n)%ipos + ! end do + + ! ! Communicate particles + ! call this%sync() + + ! ! Calculate bond force + ! call this%get_bond_force() + + ! deallocate(temp_gd) + + + ! end subroutine stretch + + !> Update particle volume fraction using our current particles + subroutine update_VF(this) + implicit none + class(lss), intent(inout) :: this + integer :: i + ! Reset volume fraction and momentum + this%VF=0.0_WP; this%VFU=0.0_WP; this%VFV=0.0_WP; this%VFW=0.0_WP + ! Transfer particle volume + do i=1,this%np_ + ! Skip inactive particle + if (this%p(i)%flag.eq.1) cycle + ! Transfer volume to mesh + call this%extrapolate(Ap=this%p(i)%vol,xp=this%p(i)%pos(1),yp=this%p(i)%pos(2),zp=this%p(i)%pos(3),ip=this%p(i)%ind(1),jp=this%p(i)%ind(2),kp=this%p(i)%ind(3),A=this%VF,dir='SC') + call this%extrapolate(Ap=this%p(i)%vol*this%p(i)%vel(1),xp=this%p(i)%pos(1),yp=this%p(i)%pos(2),zp=this%p(i)%pos(3),ip=this%p(i)%ind(1),jp=this%p(i)%ind(2),kp=this%p(i)%ind(3),A=this%VFU,dir='U') + call this%extrapolate(Ap=this%p(i)%vol*this%p(i)%vel(2),xp=this%p(i)%pos(1),yp=this%p(i)%pos(2),zp=this%p(i)%pos(3),ip=this%p(i)%ind(1),jp=this%p(i)%ind(2),kp=this%p(i)%ind(3),A=this%VFV,dir='V') + call this%extrapolate(Ap=this%p(i)%vol*this%p(i)%vel(3),xp=this%p(i)%pos(1),yp=this%p(i)%pos(2),zp=this%p(i)%pos(3),ip=this%p(i)%ind(1),jp=this%p(i)%ind(2),kp=this%p(i)%ind(3),A=this%VFW,dir='W') + end do + ! Sum at boundaries + call this%cfg%syncsum(this%VF) + call this%cfg%syncsum(this%VFU) + call this%cfg%syncsum(this%VFV) + call this%cfg%syncsum(this%VFW) + ! Clip + where (this%VF.gt.1.0_WP) this%VF=1.0_WP + where (this%VF.lt.0.0_WP) this%VF=0.0_WP + end subroutine update_VF + + + !> Compute regularized delta function + subroutine get_delta(this,delta,ic,jc,kc,xp,yp,zp,dir) + implicit none + class(lss), intent(inout) :: this + real(WP), intent(out) :: delta !< Return delta function + integer, intent(in) :: ic,jc,kc !< Cell index + real(WP), intent(in) :: xp,yp,zp !< Position of marker + character(len=*) :: dir + real(WP) :: deltax,deltay,deltaz,r + + ! Compute in X + if (trim(adjustl(dir)).eq.'U') then + r=(xp-this%cfg%x(ic))*this%cfg%dxmi(ic) + deltax=roma_kernel(r)*this%cfg%dxmi(ic) + else + r=(xp-this%cfg%xm(ic))*this%cfg%dxi(ic) + deltax=roma_kernel(r)*this%cfg%dxi(ic) + end if + + ! Compute in Y + if (trim(adjustl(dir)).eq.'V') then + r=(yp-this%cfg%y(jc))*this%cfg%dymi(jc) + deltay=roma_kernel(r)*this%cfg%dymi(jc) + else + r=(yp-this%cfg%ym(jc))*this%cfg%dyi(jc) + deltay=roma_kernel(r)*this%cfg%dyi(jc) + end if + + ! Compute in Z + if (trim(adjustl(dir)).eq.'W') then + r=(zp-this%cfg%z(kc))*this%cfg%dzmi(kc) + deltaz=roma_kernel(r)*this%cfg%dzmi(kc) + else + r=(zp-this%cfg%zm(kc))*this%cfg%dzi(kc) + deltaz=roma_kernel(r)*this%cfg%dzi(kc) + end if + !else + + ! Put it all together + delta=deltax*deltay*deltaz + + contains + ! Mollification kernel + ! Roma A, Peskin C and Berger M 1999 J. Comput. Phys. 153 509–534 + function roma_kernel(r) result(phi) + implicit none + real(WP), intent(in) :: r + real(WP) :: phi + if (abs(r).le.0.5_WP) then + phi=1.0_WP/3.0_WP*(1.0_WP+sqrt(-3.0_WP*r**2+1.0_WP)) + else if (abs(r).gt.0.5_WP .and. abs(r).le.1.5_WP) then + phi=1.0_WP/6.0_WP*(5.0_WP-3.0_WP*abs(r)-sqrt(-3.0_WP*(1.0_WP-abs(r))**2+1.0_WP)) + else + phi=0.0_WP + end if + end function roma_kernel + + end subroutine get_delta + + + !> Interpolation routine + function interpolate(this,A,xp,yp,zp,ip,jp,kp,dir) result(Ap) + implicit none + class(lss), intent(inout) :: this + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(in) :: A !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + real(WP), intent(in) :: xp,yp,zp + integer, intent(in) :: ip,jp,kp + character(len=*) :: dir + real(WP) :: Ap + integer :: di,dj,dk + integer :: i1,i2,j1,j2,k1,k2 + real(WP), dimension(-2:+2,-2:+2,-2:+2) :: delta + ! Get the interpolation points + i1=ip-2; i2=ip+2 + j1=jp-2; j2=jp+2 + k1=kp-2; k2=kp+2 + ! Loop over neighboring cells and compute regularized delta function + do dk=-2,+2 + do dj=-2,+2 + do di=-2,+2 + call this%get_delta(delta=delta(di,dj,dk),ic=ip+di,jc=jp+dj,kc=kp+dk,xp=xp,yp=yp,zp=zp,dir=trim(dir)) + end do + end do + end do + ! Perform the actual interpolation on Ap + Ap = sum(delta*A(i1:i2,j1:j2,k1:k2))*this%cfg%vol(ip,jp,kp) + end function interpolate + + + !> Extrapolation routine + subroutine extrapolate(this,Ap,xp,yp,zp,ip,jp,kp,A,dir) + use messager, only: die + implicit none + class(lss), intent(inout) :: this + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:) :: A !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + real(WP), intent(in) :: xp,yp,zp + integer, intent(in) :: ip,jp,kp + real(WP), intent(in) :: Ap + character(len=*) :: dir + real(WP), dimension(-2:+2,-2:+2,-2:+2) :: delta + integer :: di,dj,dk + ! If particle has left processor domain or reached last ghost cell, kill job + if ( ip.lt.this%cfg%imin_-1.or.ip.gt.this%cfg%imax_+1.or.& + & jp.lt.this%cfg%jmin_-1.or.jp.gt.this%cfg%jmax_+1.or.& + & kp.lt.this%cfg%kmin_-1.or.kp.gt.this%cfg%kmax_+1) then + write(*,*) ip,jp,kp,xp,yp,zp + call die('[df extrapolate] Particle has left the domain') + end if + ! Loop over neighboring cells and compute regularized delta function + do dk=-2,+2 + do dj=-2,+2 + do di=-2,+2 + call this%get_delta(delta=delta(di,dj,dk),ic=ip+di,jc=jp+dj,kc=kp+dk,xp=xp,yp=yp,zp=zp,dir=trim(dir)) + end do + end do + end do + ! Perform the actual extrapolation on A + A(ip-2:ip+2,jp-2:jp+2,kp-2:kp+2)=A(ip-2:ip+2,jp-2:jp+2,kp-2:kp+2)+delta*Ap + end subroutine extrapolate + + + !> Calculate the CFL + subroutine get_cfl(this,dt,cfl) + use mpi_f08, only: MPI_ALLREDUCE,MPI_MAX + use parallel, only: MPI_REAL_WP + implicit none + class(lss), intent(inout) :: this + real(WP), intent(in) :: dt + real(WP), intent(out) :: cfl + integer :: i,ierr + real(WP) :: my_CFLp_x,my_CFLp_y,my_CFLp_z,kk,mu,a + + ! Set the CFLs to zero + my_CFLp_x=0.0_WP; my_CFLp_y=0.0_WP; my_CFLp_z=0.0_WP + do i=1,this%np_ + my_CFLp_x=max(my_CFLp_x,abs(this%p(i)%vel(1))*this%cfg%dxi(this%p(i)%ind(1))) + my_CFLp_y=max(my_CFLp_y,abs(this%p(i)%vel(2))*this%cfg%dyi(this%p(i)%ind(2))) + my_CFLp_z=max(my_CFLp_z,abs(this%p(i)%vel(3))*this%cfg%dzi(this%p(i)%ind(3))) + end do + my_CFLp_x=my_CFLp_x*dt; my_CFLp_y=my_CFLp_y*dt; my_CFLp_z=my_CFLp_z*dt + + ! Get the parallel max + call MPI_ALLREDUCE(my_CFLp_x,this%CFLp_x,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + call MPI_ALLREDUCE(my_CFLp_y,this%CFLp_y,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + call MPI_ALLREDUCE(my_CFLp_z,this%CFLp_z,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + + ! CFL based on elastic wave speed in material + kk=this%elastic_modulus/(3.0_WP-6.0_WP*this%poisson_ratio) + mu=this%elastic_modulus/(2.0_WP+2.0_WP*this%poisson_ratio) + a=sqrt((kk+4.0_WP*mu/3.0_WP)/this%rho) + this%CFLp_a=dt*a*3/this%delta + + ! Return the maximum CFL + cfl=max(this%CFLp_x,this%CFLp_y,this%CFLp_z,this%CFLp_a) + + end subroutine get_cfl + + + !> Extract various monitoring data from particle field + subroutine get_max(this) + use mpi_f08, only: MPI_ALLREDUCE,MPI_MAX,MPI_MIN,MPI_SUM + use parallel, only: MPI_REAL_WP + implicit none + class(lss), intent(inout) :: this + real(WP) :: buf,safe_np + real(WP), dimension(3) :: buf3D + integer :: i,j,k,ierr + + ! Create safe np + safe_np=real(max(this%np,1),WP) + + ! Velocity min/max/mean + this%Umin=huge(1.0_WP); this%Umax=-huge(1.0_WP); this%Umean=0.0_WP + this%Vmin=huge(1.0_WP); this%Vmax=-huge(1.0_WP); this%Vmean=0.0_WP + this%Wmin=huge(1.0_WP); this%Wmax=-huge(1.0_WP); this%Wmean=0.0_WP + this%ibmForce=0.0_WP + do i=1,this%np_ + this%Umin=min(this%Umin,this%p(i)%vel(1)); this%Umax=max(this%Umax,this%p(i)%vel(1)); this%Umean=this%Umean+this%p(i)%vel(1) + this%Vmin=min(this%Vmin,this%p(i)%vel(2)); this%Vmax=max(this%Vmax,this%p(i)%vel(2)); this%Vmean=this%Vmean+this%p(i)%vel(2) + this%Wmin=min(this%Wmin,this%p(i)%vel(3)); this%Wmax=max(this%Wmax,this%p(i)%vel(3)); this%Wmean=this%Wmean+this%p(i)%vel(3) + this%ibmForce=this%ibmForce+this%p(i)%Afluid*this%p(i)%vol*this%rho + end do + call MPI_ALLREDUCE(this%Umin ,buf,1,MPI_REAL_WP,MPI_MIN,this%cfg%comm,ierr); this%Umin =buf + call MPI_ALLREDUCE(this%Umax ,buf,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr); this%Umax =buf + call MPI_ALLREDUCE(this%Umean,buf,1,MPI_REAL_WP,MPI_SUM,this%cfg%comm,ierr); this%Umean=buf/safe_np + call MPI_ALLREDUCE(this%Vmin ,buf,1,MPI_REAL_WP,MPI_MIN,this%cfg%comm,ierr); this%Vmin =buf + call MPI_ALLREDUCE(this%Vmax ,buf,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr); this%Vmax =buf + call MPI_ALLREDUCE(this%Vmean,buf,1,MPI_REAL_WP,MPI_SUM,this%cfg%comm,ierr); this%Vmean=buf/safe_np + call MPI_ALLREDUCE(this%Wmin ,buf,1,MPI_REAL_WP,MPI_MIN,this%cfg%comm,ierr); this%Wmin =buf + call MPI_ALLREDUCE(this%Wmax ,buf,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr); this%Wmax =buf + call MPI_ALLREDUCE(this%Wmean,buf,1,MPI_REAL_WP,MPI_SUM,this%cfg%comm,ierr); this%Wmean=buf/safe_np + call MPI_ALLREDUCE(this%ibmForce,buf3D,3,MPI_REAL_WP,MPI_SUM,this%cfg%comm,ierr); this%ibmForce=buf3D + + ! Get max volume fraction + this%VFmax =-huge(1.0_WP) + do k=this%cfg%kmin_,this%cfg%kmax_ + do j=this%cfg%jmin_,this%cfg%jmax_ + do i=this%cfg%imin_,this%cfg%imax_ + this%VFmax=max(this%VFmax,this%VF(i,j,k)) + end do + end do + end do + call MPI_ALLREDUCE(this%VFmax,buf,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr); this%VFmax=buf + + end subroutine get_max + + + !> Update particle mesh using our current particles + subroutine update_partmesh(this,pmesh) + use partmesh_class, only: partmesh + implicit none + class(lss), intent(inout) :: this + class(partmesh), intent(inout) :: pmesh + integer :: i + ! Reset particle mesh storage + call pmesh%reset() + ! Nothing else to do if no particle is present + if (this%np_.eq.0) return + ! Copy particle info + call pmesh%set_size(this%np_) + do i=1,this%np_ + pmesh%pos(:,i)=this%p(i)%pos + end do + end subroutine update_partmesh + + + !> Creation of the MPI datatype for particle + subroutine prepare_mpi_part() + use mpi_f08 + use messager, only: die + implicit none + integer(MPI_ADDRESS_KIND), dimension(part_nblock) :: disp + integer(MPI_ADDRESS_KIND) :: lb,extent + type(MPI_Datatype) :: MPI_PART_TMP + integer :: i,mysize,ierr + ! Prepare the displacement array + disp(1)=0 + do i=2,part_nblock + call MPI_Type_size(part_tblock(i-1),mysize,ierr) + disp(i)=disp(i-1)+int(mysize,MPI_ADDRESS_KIND)*int(part_lblock(i-1),MPI_ADDRESS_KIND) + end do + ! Create and commit the new type + call MPI_Type_create_struct(part_nblock,part_lblock,disp,part_tblock,MPI_PART_TMP,ierr) + call MPI_Type_get_extent(MPI_PART_TMP,lb,extent,ierr) + call MPI_Type_create_resized(MPI_PART_TMP,lb,extent,MPI_PART,ierr) + call MPI_Type_commit(MPI_PART,ierr) + ! If a problem was encountered, say it + if (ierr.ne.0) call die('[lss prepare_mpi_part] MPI Particle type creation failed') + ! Get the size of this type + call MPI_type_size(MPI_PART,MPI_PART_SIZE,ierr) + end subroutine prepare_mpi_part + + + !> Share particles across processor boundaries + subroutine share(this,nover) + use mpi_f08 + use messager, only: warn,die + implicit none + class(lss), intent(inout) :: this + integer, optional :: nover + type(part), dimension(:), allocatable :: tosend + type(part), dimension(:), allocatable :: torecv + integer :: no,nsend,nrecv + type(MPI_Status) :: status + integer :: icnt,isrc,idst,ierr + integer :: i,n + + ! Check overlap size + if (present(nover)) then + no=nover + if (no.gt.this%cfg%no) then + call warn('[lss share] Specified overlap is larger than that of cfg - reducing no') + no=this%cfg%no + else if (no.le.0) then + call die('[lss share] Specified overlap cannot be less or equal to zero') + end if + else + no=1 + end if + + ! Clean up ghost array + call this%resize_ghost(n=0); this%ng_=0 + + ! Share ghost particles in -x (no ghosts are sent here) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(1).lt.this%cfg%imin_+no) nsend=nsend+1 + end do + allocate(tosend(nsend)) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(1).lt.this%cfg%imin_+no) then + nsend=nsend+1 + tosend(nsend)=this%p(n) + if (this%cfg%xper.and.tosend(nsend)%ind(1).lt.this%cfg%imin+no) then + tosend(nsend)%pos(1)=tosend(nsend)%pos(1)+this%cfg%xL + tosend(nsend)%ind(1)=tosend(nsend)%ind(1)+this%cfg%nx + end if + end if + end do + nrecv=0 + call MPI_CART_SHIFT(this%cfg%comm,0,-1,isrc,idst,ierr) + call MPI_SENDRECV(nsend,1,MPI_INTEGER,idst,0,nrecv,1,MPI_INTEGER,isrc,0,this%cfg%comm,status,ierr) + allocate(torecv(nrecv)) + call MPI_SENDRECV(tosend,nsend,MPI_PART,idst,0,torecv,nrecv,MPI_PART,isrc,0,this%cfg%comm,status,ierr) + call this%resize_ghost(this%ng_+nrecv) + this%g(this%ng_+1:this%ng_+nrecv)=torecv + this%ng_=this%ng_+nrecv + if (allocated(tosend)) deallocate(tosend) + if (allocated(torecv)) deallocate(torecv) + + ! Share ghost particles in +x (no ghosts are sent here) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(1).gt.this%cfg%imax_-no) nsend=nsend+1 + end do + allocate(tosend(nsend)) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(1).gt.this%cfg%imax_-no) then + nsend=nsend+1 + tosend(nsend)=this%p(n) + if (this%cfg%xper.and.tosend(nsend)%ind(1).gt.this%cfg%imax-no) then + tosend(nsend)%pos(1)=tosend(nsend)%pos(1)-this%cfg%xL + tosend(nsend)%ind(1)=tosend(nsend)%ind(1)-this%cfg%nx + end if + end if + end do + nrecv=0 + call MPI_CART_SHIFT(this%cfg%comm,0,+1,isrc,idst,ierr) + call MPI_SENDRECV(nsend,1,MPI_INTEGER,idst,0,nrecv,1,MPI_INTEGER,isrc,0,this%cfg%comm,status,ierr) + allocate(torecv(nrecv)) + call MPI_SENDRECV(tosend,nsend,MPI_PART,idst,0,torecv,nrecv,MPI_PART,isrc,0,this%cfg%comm,status,ierr) + call this%resize_ghost(this%ng_+nrecv) + this%g(this%ng_+1:this%ng_+nrecv)=torecv + this%ng_=this%ng_+nrecv + if (allocated(tosend)) deallocate(tosend) + if (allocated(torecv)) deallocate(torecv) + + ! Share ghost particles in -y (ghosts need to be sent now) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(2).lt.this%cfg%jmin_+no) nsend=nsend+1 + end do + do n=1,this%ng_ + if (this%g(n)%ind(2).lt.this%cfg%jmin_+no) nsend=nsend+1 + end do + allocate(tosend(nsend)) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(2).lt.this%cfg%jmin_+no) then + nsend=nsend+1 + tosend(nsend)=this%p(n) + if (this%cfg%yper.and.tosend(nsend)%ind(2).lt.this%cfg%jmin+no) then + tosend(nsend)%pos(2)=tosend(nsend)%pos(2)+this%cfg%yL + tosend(nsend)%ind(2)=tosend(nsend)%ind(2)+this%cfg%ny + end if + end if + end do + do n=1,this%ng_ + if (this%g(n)%ind(2).lt.this%cfg%jmin_+no) then + nsend=nsend+1 + tosend(nsend)=this%g(n) + if (this%cfg%yper.and.tosend(nsend)%ind(2).lt.this%cfg%jmin+no) then + tosend(nsend)%pos(2)=tosend(nsend)%pos(2)+this%cfg%yL + tosend(nsend)%ind(2)=tosend(nsend)%ind(2)+this%cfg%ny + end if + end if + end do + nrecv=0 + call MPI_CART_SHIFT(this%cfg%comm,1,-1,isrc,idst,ierr) + call MPI_SENDRECV(nsend,1,MPI_INTEGER,idst,0,nrecv,1,MPI_INTEGER,isrc,0,this%cfg%comm,status,ierr) + allocate(torecv(nrecv)) + call MPI_SENDRECV(tosend,nsend,MPI_PART,idst,0,torecv,nrecv,MPI_PART,isrc,0,this%cfg%comm,status,ierr) + call this%resize_ghost(this%ng_+nrecv) + this%g(this%ng_+1:this%ng_+nrecv)=torecv + this%ng_=this%ng_+nrecv + if (allocated(tosend)) deallocate(tosend) + if (allocated(torecv)) deallocate(torecv) + + ! Share ghost particles in +y (ghosts need to be sent now - but not newly received ghosts!) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(2).gt.this%cfg%jmax_-no) nsend=nsend+1 + end do + do n=1,this%ng_-nrecv + if (this%g(n)%ind(2).gt.this%cfg%jmax_-no) nsend=nsend+1 + end do + allocate(tosend(nsend)) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(2).gt.this%cfg%jmax_-no) then + nsend=nsend+1 + tosend(nsend)=this%p(n) + if (this%cfg%yper.and.tosend(nsend)%ind(2).gt.this%cfg%jmax-no) then + tosend(nsend)%pos(2)=tosend(nsend)%pos(2)-this%cfg%yL + tosend(nsend)%ind(2)=tosend(nsend)%ind(2)-this%cfg%ny + end if + end if + end do + do n=1,this%ng_-nrecv + if (this%g(n)%ind(2).gt.this%cfg%jmax_-no) then + nsend=nsend+1 + tosend(nsend)=this%g(n) + if (this%cfg%yper.and.tosend(nsend)%ind(2).gt.this%cfg%jmax-no) then + tosend(nsend)%pos(2)=tosend(nsend)%pos(2)-this%cfg%yL + tosend(nsend)%ind(2)=tosend(nsend)%ind(2)-this%cfg%ny + end if + end if + end do + nrecv=0 + call MPI_CART_SHIFT(this%cfg%comm,1,+1,isrc,idst,ierr) + call MPI_SENDRECV(nsend,1,MPI_INTEGER,idst,0,nrecv,1,MPI_INTEGER,isrc,0,this%cfg%comm,status,ierr) + allocate(torecv(nrecv)) + call MPI_SENDRECV(tosend,nsend,MPI_PART,idst,0,torecv,nrecv,MPI_PART,isrc,0,this%cfg%comm,status,ierr) + call this%resize_ghost(this%ng_+nrecv) + this%g(this%ng_+1:this%ng_+nrecv)=torecv + this%ng_=this%ng_+nrecv + if (allocated(tosend)) deallocate(tosend) + if (allocated(torecv)) deallocate(torecv) + + ! Share ghost particles in -z (ghosts need to be sent now) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(3).lt.this%cfg%kmin_+no) nsend=nsend+1 + end do + do n=1,this%ng_ + if (this%g(n)%ind(3).lt.this%cfg%kmin_+no) nsend=nsend+1 + end do + allocate(tosend(nsend)) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(3).lt.this%cfg%kmin_+no) then + nsend=nsend+1 + tosend(nsend)=this%p(n) + if (this%cfg%zper.and.tosend(nsend)%ind(3).lt.this%cfg%kmin+no) then + tosend(nsend)%pos(3)=tosend(nsend)%pos(3)+this%cfg%zL + tosend(nsend)%ind(3)=tosend(nsend)%ind(3)+this%cfg%nz + end if + end if + end do + do n=1,this%ng_ + if (this%g(n)%ind(3).lt.this%cfg%kmin_+no) then + nsend=nsend+1 + tosend(nsend)=this%g(n) + if (this%cfg%zper.and.tosend(nsend)%ind(3).lt.this%cfg%kmin+no) then + tosend(nsend)%pos(3)=tosend(nsend)%pos(3)+this%cfg%zL + tosend(nsend)%ind(3)=tosend(nsend)%ind(3)+this%cfg%nz + end if + end if + end do + nrecv=0 + call MPI_CART_SHIFT(this%cfg%comm,2,-1,isrc,idst,ierr) + call MPI_SENDRECV(nsend,1,MPI_INTEGER,idst,0,nrecv,1,MPI_INTEGER,isrc,0,this%cfg%comm,status,ierr) + allocate(torecv(nrecv)) + call MPI_SENDRECV(tosend,nsend,MPI_PART,idst,0,torecv,nrecv,MPI_PART,isrc,0,this%cfg%comm,status,ierr) + call this%resize_ghost(this%ng_+nrecv) + this%g(this%ng_+1:this%ng_+nrecv)=torecv + this%ng_=this%ng_+nrecv + if (allocated(tosend)) deallocate(tosend) + if (allocated(torecv)) deallocate(torecv) + + ! Share ghost particles in +z (ghosts need to be sent now - but not newly received ghosts!) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(3).gt.this%cfg%kmax_-no) nsend=nsend+1 + end do + do n=1,this%ng_-nrecv + if (this%g(n)%ind(3).gt.this%cfg%kmax_-no) nsend=nsend+1 + end do + allocate(tosend(nsend)) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(3).gt.this%cfg%kmax_-no) then + nsend=nsend+1 + tosend(nsend)=this%p(n) + if (this%cfg%zper.and.tosend(nsend)%ind(3).gt.this%cfg%kmax-no) then + tosend(nsend)%pos(3)=tosend(nsend)%pos(3)-this%cfg%zL + tosend(nsend)%ind(3)=tosend(nsend)%ind(3)-this%cfg%nz + end if + end if + end do + do n=1,this%ng_-nrecv + if (this%g(n)%ind(3).gt.this%cfg%kmax_-no) then + nsend=nsend+1 + tosend(nsend)=this%g(n) + if (this%cfg%zper.and.tosend(nsend)%ind(3).gt.this%cfg%kmax-no) then + tosend(nsend)%pos(3)=tosend(nsend)%pos(3)-this%cfg%zL + tosend(nsend)%ind(3)=tosend(nsend)%ind(3)-this%cfg%nz + end if + end if + end do + nrecv=0 + call MPI_CART_SHIFT(this%cfg%comm,2,+1,isrc,idst,ierr) + call MPI_SENDRECV(nsend,1,MPI_INTEGER,idst,0,nrecv,1,MPI_INTEGER,isrc,0,this%cfg%comm,status,ierr) + allocate(torecv(nrecv)) + call MPI_SENDRECV(tosend,nsend,MPI_PART,idst,0,torecv,nrecv,MPI_PART,isrc,0,this%cfg%comm,status,ierr) + call this%resize_ghost(this%ng_+nrecv) + this%g(this%ng_+1:this%ng_+nrecv)=torecv + this%ng_=this%ng_+nrecv + if (allocated(tosend)) deallocate(tosend) + if (allocated(torecv)) deallocate(torecv) + + end subroutine share + + + !> Synchronize particle arrays across processors + subroutine sync(this) + use mpi_f08 + implicit none + class(lss), intent(inout) :: this + integer, dimension(0:this%cfg%nproc-1) :: nsend_proc,nrecv_proc + integer, dimension(0:this%cfg%nproc-1) :: nsend_disp,nrecv_disp + integer :: n,prank,ierr + type(part), dimension(:), allocatable :: buf_send + ! Recycle first to minimize communication load + call this%recycle() + ! Prepare information about what to send + nsend_proc=0 + do n=1,this%np_ + prank=this%cfg%get_rank(this%p(n)%ind) + nsend_proc(prank)=nsend_proc(prank)+1 + end do + nsend_proc(this%cfg%rank)=0 + ! Inform processors of what they will receive + call MPI_ALLtoALL(nsend_proc,1,MPI_INTEGER,nrecv_proc,1,MPI_INTEGER,this%cfg%comm,ierr) + ! Prepare displacements for all-to-all + nsend_disp(0)=0 + nrecv_disp(0)=this%np_ !< Directly add particles at the end of main array + do n=1,this%cfg%nproc-1 + nsend_disp(n)=nsend_disp(n-1)+nsend_proc(n-1) + nrecv_disp(n)=nrecv_disp(n-1)+nrecv_proc(n-1) + end do + ! Allocate buffer to send particles + allocate(buf_send(sum(nsend_proc))) + ! Pack the particles in the send buffer + nsend_proc=0 + do n=1,this%np_ + ! Get the rank + prank=this%cfg%get_rank(this%p(n)%ind) + ! Skip particles still inside + if (prank.eq.this%cfg%rank) cycle + ! Pack up for sending + nsend_proc(prank)=nsend_proc(prank)+1 + buf_send(nsend_disp(prank)+nsend_proc(prank))=this%p(n) + ! Flag particle for removal + this%p(n)%flag=1 + end do + ! Allocate buffer for receiving particles + call this%resize(this%np_+sum(nrecv_proc)) + ! Perform communication + call MPI_ALLtoALLv(buf_send,nsend_proc,nsend_disp,MPI_PART,this%p,nrecv_proc,nrecv_disp,MPI_PART,this%cfg%comm,ierr) + ! Deallocate buffer + deallocate(buf_send) + ! Recycle to remove duplicate particles + call this%recycle() + end subroutine sync + + + !> Adaptation of particle array size + subroutine resize(this,n) + implicit none + class(lss), intent(inout) :: this + integer, intent(in) :: n + type(part), dimension(:), allocatable :: tmp + integer :: size_now,size_new + ! Resize particle array to size n + if (.not.allocated(this%p)) then + ! Allocate directly to size n + allocate(this%p(n)) + this%p(1:n)%flag=1 + else + ! Update from a non-zero size to another non-zero size + size_now=size(this%p,dim=1) + if (n.gt.size_now) then + size_new=max(n,int(real(size_now,WP)*coeff_up)) + allocate(tmp(size_new)) + tmp(1:size_now)=this%p + tmp(size_now+1:)%flag=1 + call move_alloc(tmp,this%p) + else if (n.lt.int(real(size_now,WP)*coeff_dn)) then + allocate(tmp(n)) + tmp(1:n)=this%p(1:n) + call move_alloc(tmp,this%p) + end if + end if + end subroutine resize + + + !> Adaptation of ghost array size + subroutine resize_ghost(this,n) + implicit none + class(lss), intent(inout) :: this + integer, intent(in) :: n + type(part), dimension(:), allocatable :: tmp + integer :: size_now,size_new + ! Resize ghost array to size n + if (.not.allocated(this%g)) then + ! Allocate directly to size n + allocate(this%g(n)) + this%g(1:n)%flag=1 + else + ! Update from a non-zero size to another non-zero size + size_now=size(this%g,dim=1) + if (n.gt.size_now) then + size_new=max(n,int(real(size_now,WP)*coeff_up)) + allocate(tmp(size_new)) + tmp(1:size_now)=this%g + tmp(size_now+1:)%flag=1 + call move_alloc(tmp,this%g) + else if (n.lt.int(real(size_now,WP)*coeff_dn)) then + allocate(tmp(n)) + tmp(1:n)=this%g(1:n) + call move_alloc(tmp,this%g) + end if + end if + end subroutine resize_ghost + + + !> Clean-up of particle array by removing flag=1 particles + subroutine recycle(this) + implicit none + class(lss), intent(inout) :: this + integer :: new_size,i,ierr + ! Compact all active particles at the beginning of the array + new_size=0 + if (allocated(this%p)) then + do i=1,size(this%p,dim=1) + if (this%p(i)%flag.ne.1) then + new_size=new_size+1 + if (i.ne.new_size) then + this%p(new_size)=this%p(i) + this%p(i)%flag=1 + end if + end if + end do + end if + ! Resize to new size + call this%resize(new_size) + ! Update number of particles + this%np_=new_size + call MPI_ALLGATHER(this%np_,1,MPI_INTEGER,this%np_proc,1,MPI_INTEGER,this%cfg%comm,ierr) + this%np=sum(this%np_proc) + end subroutine recycle + + + !> Parallel write particles to file + subroutine write(this,filename) + use mpi_f08 + use messager, only: die + use parallel, only: info_mpiio + implicit none + class(lss), intent(inout) :: this + character(len=*), intent(in) :: filename + type(MPI_File) :: ifile + type(MPI_Status):: status + integer(kind=MPI_OFFSET_KIND) :: offset + integer :: i,ierr,iunit + + ! Root serial-writes the file header + if (this%cfg%amRoot) then + ! Open the file + open(newunit=iunit,file=trim(filename),form='unformatted',status='replace',access='stream',iostat=ierr) + if (ierr.ne.0) call die('[lss write] Problem encountered while serial-opening data file: '//trim(filename)) + ! Number of particles and particle object size + write(iunit) this%np,MPI_PART_SIZE + ! Done with the header + close(iunit) + end if + + ! The rest is done in parallel + call MPI_FILE_OPEN(this%cfg%comm,trim(filename),IOR(MPI_MODE_WRONLY,MPI_MODE_APPEND),info_mpiio,ifile,ierr) + if (ierr.ne.0) call die('[lss write] Problem encountered while parallel-opening data file: '//trim(filename)) + + ! Get current position + call MPI_FILE_GET_POSITION(ifile,offset,ierr) + + ! Compute the offset and write + do i=1,this%cfg%rank + offset=offset+int(this%np_proc(i),MPI_OFFSET_KIND)*int(MPI_PART_SIZE,MPI_OFFSET_KIND) + end do + if (this%np_.gt.0) call MPI_FILE_WRITE_AT(ifile,offset,this%p,this%np_,MPI_PART,status,ierr) + + ! Close the file + call MPI_FILE_CLOSE(ifile,ierr) + + ! Log/screen output + logging: block + use, intrinsic :: iso_fortran_env, only: output_unit + use param, only: verbose + use messager, only: log + use string, only: str_long + character(len=str_long) :: message + if (this%cfg%amRoot) then + write(message,'("[lss write] Wrote ",i0," particles to file [",a,"] on partitioned grid [",a,"]")') this%np,trim(filename),trim(this%cfg%name) + if (verbose.gt.2) write(output_unit,'(a)') trim(message) + if (verbose.gt.1) call log(message) + end if + end block logging + + end subroutine write + + + !> Parallel read particles to file + subroutine read(this,filename) + use mpi_f08 + use messager, only: die + use parallel, only: info_mpiio + implicit none + class(lss), intent(inout) :: this + character(len=*), intent(in) :: filename + type(MPI_File) :: ifile + type(MPI_Status):: status + integer(kind=MPI_OFFSET_KIND) :: offset,header_offset + integer :: i,j,ierr,npadd,psize,nchunk,cnt + integer, dimension(:,:), allocatable :: ppp + + ! First open the file in parallel + call MPI_FILE_OPEN(this%cfg%comm,trim(filename),MPI_MODE_RDONLY,info_mpiio,ifile,ierr) + if (ierr.ne.0) call die('[lss read] Problem encountered while reading data file: '//trim(filename)) + + ! Read file header first + call MPI_FILE_READ_ALL(ifile,npadd,1,MPI_INTEGER,status,ierr) + call MPI_FILE_READ_ALL(ifile,psize,1,MPI_INTEGER,status,ierr) + + ! Remember current position + call MPI_FILE_GET_POSITION(ifile,header_offset,ierr) + + ! Check compatibility of particle type + if (psize.ne.MPI_PART_SIZE) call die('[lss read] Particle type unreadable') + + ! Naively share reading task among all processors + nchunk=int(npadd/(this%cfg%nproc*part_chunk_size))+1 + allocate(ppp(this%cfg%nproc,nchunk)) + ppp=int(npadd/(this%cfg%nproc*nchunk)) + cnt=0 + out:do j=1,nchunk + do i=1,this%cfg%nproc + cnt=cnt+1 + if (cnt.gt.mod(npadd,this%cfg%nproc*nchunk)) exit out + ppp(i,j)=ppp(i,j)+1 + end do + end do out + + ! Read by chunk + do j=1,nchunk + ! Find offset + offset=header_offset+int(MPI_PART_SIZE,MPI_OFFSET_KIND)*int(sum(ppp(1:this%cfg%rank,:))+sum(ppp(this%cfg%rank+1,1:j-1)),MPI_OFFSET_KIND) + ! Resize particle array + call this%resize(this%np_+ppp(this%cfg%rank+1,j)) + ! Read this file + call MPI_FILE_READ_AT(ifile,offset,this%p(this%np_+1:this%np_+ppp(this%cfg%rank+1,j)),ppp(this%cfg%rank+1,j),MPI_PART,status,ierr) + ! Most general case: relocate every droplet + do i=this%np_+1,this%np_+ppp(this%cfg%rank+1,j) + this%p(i)%ind=this%cfg%get_ijk_global(this%p(i)%pos,this%p(i)%ind) + end do + ! Exchange all that + call this%sync() + end do + + ! Close the file + call MPI_FILE_CLOSE(ifile,ierr) + + ! Log/screen output + logging: block + use, intrinsic :: iso_fortran_env, only: output_unit + use param, only: verbose + use messager, only: log + use string, only: str_long + character(len=str_long) :: message + if (this%cfg%amRoot) then + write(message,'("[lss read] Read ",i0," particles from file [",a,"] on partitioned grid [",a,"]")') npadd,trim(filename),trim(this%cfg%name) + if (verbose.gt.2) write(output_unit,'(a)') trim(message) + if (verbose.gt.1) call log(message) + end if + end block logging + + end subroutine read + + +end module lss_class diff --git a/examples/NOSB/src/simulation.f90 b/examples/NOSB/src/simulation.f90 new file mode 100644 index 000000000..ce3eef99b --- /dev/null +++ b/examples/NOSB/src/simulation.f90 @@ -0,0 +1,779 @@ +!> Various definitions and tools for running an NGA2 simulation +module simulation + use precision, only: WP,SP + use geometry, only: cfg + use spcomp_class, only: spcomp + use lss_class, only: lss + use timetracker_class, only: timetracker + use ensight_class, only: ensight + use partmesh_class, only: partmesh + use event_class, only: event + use monitor_class, only: monitor + implicit none + private + + !> Get a couple linear solvers, an incompressible flow solver and corresponding time tracker + type(spcomp), public :: fs + type(lss), public :: ls + type(timetracker), public :: time + + !> Ensight postprocessing + type(partmesh) :: pmesh + type(ensight) :: ens_out + type(event) :: ens_evt + + !> Simulation monitor file + type(monitor) :: mfile,cflfile,consfile,sfile,dispfile + + public :: simulation_init,simulation_run,simulation_final + + !> Private work arrays + real(WP), dimension(:,:,:,:,:), allocatable :: dQdt + real(WP), dimension(:,:,:) , allocatable :: Ui,Vi,Wi,Ma,beta,visc,visc_t,div + !> Post-shock viscosity and temperature + real(WP) :: visc0,T0 + + !> Equations of state + real(WP) :: Pinf,Gamma,Cv,Prandtl + + !> Flow parameters + real(WP) :: Ms,Xs,Rcyl + real(WP) :: rho1,p1,u1,M1 + real(WP) :: rho2,p2,u2,M2 + real(WP) :: Re + + !> Max timestep size for solid solver + real(WP) :: ls_dt,ls_dt_max + + integer :: target_index + real(WP), dimension(3) :: target_position + + + contains + + + !> Function that returns a smooth Heaviside of thickness delta + real(WP) function Hshock(x,delta) + real(WP), intent(in) :: x,delta + ! Goes from 0 to 1 as x goes from begative to positive + Hshock=1.0_WP/(1.0_WP+exp(-x/delta)) + end function Hshock + + !> P=EOS(RHO,I) + pure real(WP) function get_P(RHO,I) + implicit none + real(WP), intent(in) :: RHO,I + get_P=RHO*I*(Gamma-1.0_WP)-Gamma*Pinf + end function get_P + !> T=f(RHO,P) + pure real(WP) function get_T(RHO,P) + implicit none + real(WP), intent(in) :: RHO,P + get_T=(P+Pinf)/(Cv*RHO*(Gamma-1.0_WP)) + end function get_T + !> RHO=f(T,P) + pure real(WP) function get_RHO(T,P) + implicit none + real(WP), intent(in) :: T,P + get_RHO=(P+Pinf)/(Cv*T*(Gamma-1.0_WP)) + end function get_RHO + !> I=EOS(RHO,P) + pure real(WP) function get_I(RHO,P) + implicit none + real(WP), intent(in) :: RHO,P + get_I=(P+Gamma*Pinf)/(RHO*(Gamma-1.0_WP)) + end function get_I + !> C=f(RHO,P) + pure real(WP) function get_C(RHO,P) + implicit none + real(WP), intent(in) :: RHO,P + get_C=sqrt(Gamma*(P+Pinf)/RHO) + end function get_C + !> S=f(RHO,P) + pure real(WP) function get_S(RHO,P) + implicit none + real(WP), intent(in) :: RHO,P + get_S=Cv*log((P+Pinf)/RHO**Gamma) + end function get_S + + subroutine get_tracked_particle() + use mpi_f08 + implicit none + integer :: i, ierr + real(WP) :: local_pos(3), global_pos(3) + + local_pos = 0.0_WP + + do i=1,ls%np_ + if (ls%p(i)%i.eq.target_index) then + local_pos = ls%p(i)%pos + end if + end do + call MPI_ALLREDUCE(local_pos, global_pos, 3, MPI_DOUBLE_PRECISION, MPI_SUM, ls%cfg%comm, ierr) + + target_position = global_pos + end subroutine + + !> Calculate viscosities + subroutine prepare_viscosities() + implicit none + integer :: i,j,k + real(WP) :: S + ! Get viscosity from Sutherland's law + S=110.4_WP/273.15_WP*T0 + do k=fs%cfg%kmino_,fs%cfg%kmaxo_ + do j=fs%cfg%jmino_,fs%cfg%jmaxo_ + do i=fs%cfg%imino_,fs%cfg%imaxo_ + visc(i,j,k)=visc0*(T0+S)/(fs%T(i,j,k)+S)*(fs%T(i,j,k)/T0)**1.5_WP + end do + end do + end do + ! Get LAD + call fs%get_viscartif(dt=time%dt,beta=beta); fs%BETA=fs%Q(:,:,:,1)*beta + ! Get eddy viscosity + call fs%get_vreman (dt=time%dt,visc=visc_t); fs%VISC=fs%Q(:,:,:,1)*visc_t+visc + ! Recompute thermal conductivity + fs%diff=Gamma*Cv*fs%visc/Prandtl + ! Add LAD + fs%VISC=fs%VISC+0.002_WP*fs%BETA + end subroutine prepare_viscosities + + + !> Calculate velocity divergence + subroutine get_div() + implicit none + integer :: i,j,k + do k=fs%cfg%kmino_,fs%cfg%kmaxo_-1; do j=fs%cfg%jmino_,fs%cfg%jmaxo_-1; do i=fs%cfg%imino_,fs%cfg%imaxo_-1 + div(i,j,k)=fs%dxi*(fs%U(i+1,j,k)-fs%U(i,j,k))+fs%dyi*(fs%V(i,j+1,k)-fs%V(i,j,k))+fs%dzi*(fs%W(i,j,k+1)-fs%W(i,j,k)) + end do; end do; end do + call fs%cfg%sync(div) + if (.not.fs%cfg%xper.and.fs%cfg%iproc.eq.fs%cfg%npx) div(fs%cfg%imaxo,:,:)=div(fs%cfg%imaxo-1,:,:) + if (.not.fs%cfg%yper.and.fs%cfg%jproc.eq.fs%cfg%npy) div(:,fs%cfg%jmaxo,:)=div(:,fs%cfg%jmaxo-1,:) + if (.not.fs%cfg%zper.and.fs%cfg%kproc.eq.fs%cfg%npz) div(:,:,fs%cfg%kmaxo)=div(:,:,fs%cfg%kmaxo-1) + end subroutine get_div + + + !> Overwrite cosnerved variables using volume-of-solid IBM + subroutine apply_ibm() + implicit none + integer :: i,j,k,ii,jj,kk + real(WP) :: sum_VF,sum_VFQ1,sum_VFQ2 + do k=cfg%kmin_,cfg%kmax_ + do j=cfg%jmin_,cfg%jmax_ + do i=cfg%imin_,cfg%imax_ + if (ls%VF(i,j,k).eq.0.0_WP) cycle + ! Neumann: VF-weighted neighbor average for Q(1) and Q(2) + sum_VF=0.0_WP; sum_VFQ1=0.0_WP; sum_VFQ2=0.0_WP + do kk=-1,1; do jj=-1,1; do ii=-1,1 + if (ii.eq.0.and.jj.eq.0.and.kk.eq.0) cycle + sum_VF =sum_VF +(1.0_WP-ls%VF(i+ii,j+jj,k+kk)) + sum_VFQ1=sum_VFQ1+(1.0_WP-ls%VF(i+ii,j+jj,k+kk))*fs%Q(i+ii,j+jj,k+kk,1) + sum_VFQ2=sum_VFQ2+(1.0_WP-ls%VF(i+ii,j+jj,k+kk))*fs%Q(i+ii,j+jj,k+kk,2) + end do; end do; end do + if (sum_VF.gt.0.0_WP) then + fs%Q(i,j,k,1)=(1.0_WP-ls%VF(i,j,k))*fs%Q(i,j,k,1)+ls%VF(i,j,k)*sum_VFQ1/sum_VF + fs%Q(i,j,k,2)=(1.0_WP-ls%VF(i,j,k))*fs%Q(i,j,k,2)+ls%VF(i,j,k)*sum_VFQ2/sum_VF + end if + ! No-slip now that density is determined + fs%Q(i,j,k,3)=(1.0_WP-0.5_WP*(ls%VF(i-1,j,k)+ls%VF(i,j,k)))*fs%Q(i,j,k,3)+0.5_WP*(fs%Q(i-1,j,k,1)+fs%Q(i,j,k,1))*ls%VFU(i,j,k) + fs%Q(i,j,k,4)=(1.0_WP-0.5_WP*(ls%VF(i,j-1,k)+ls%VF(i,j,k)))*fs%Q(i,j,k,4)+0.5_WP*(fs%Q(i,j-1,k,1)+fs%Q(i,j,k,1))*ls%VFV(i,j,k) + fs%Q(i,j,k,5)=(1.0_WP-0.5_WP*(ls%VF(i,j,k-1)+ls%VF(i,j,k)))*fs%Q(i,j,k,5)+0.5_WP*(fs%Q(i,j,k-1,1)+fs%Q(i,j,k,1))*ls%VFW(i,j,k) + end do + end do + end do + ! Communicate + call fs%cfg%sync(fs%Q(:,:,:,1)) + call fs%cfg%sync(fs%Q(:,:,:,2)) + call fs%cfg%sync(fs%Q(:,:,:,3)) + call fs%cfg%sync(fs%Q(:,:,:,4)) + call fs%cfg%sync(fs%Q(:,:,:,5)) + ! Rebuild primitive variables + call fs%get_primitive() + end subroutine apply_ibm + + + !> Apply boundary conditions + subroutine apply_bconds() + implicit none + integer :: i,j,k + + ! Apply clipped Neumann on primitive variables in x+ + if (.not.fs%cfg%xper.and.fs%cfg%iproc.eq.fs%cfg%npx) then + do k=fs%cfg%kmino_,fs%cfg%kmaxo_; do j=fs%cfg%jmino_,fs%cfg%jmaxo_ + ! Copy over from imax to imax+1 and above + do i=fs%cfg%imax+1,fs%cfg%imaxo + ! Copy primitive variables + ls%VF(i,j,k)=ls%VF(fs%cfg%imax,j,k) + fs%Q(i,j,k,1)=fs%Q(fs%cfg%imax,j,k,1) + fs%P(i,j,k)=fs%P(fs%cfg%imax,j,k) + fs%I(i,j,k)=fs%I(fs%cfg%imax,j,k) + fs%U(i,j,k)=max(fs%U(fs%cfg%imax,j,k),0.0_WP) + fs%V(i,j,k)=fs%V(fs%cfg%imax,j,k) + fs%W(i,j,k)=fs%W(fs%cfg%imax,j,k) + end do + end do; end do + end if + + ! Apply clipped Neumann on primitive variables in y+ + if (.not.fs%cfg%yper.and.fs%cfg%jproc.eq.fs%cfg%npy) then + do k=fs%cfg%kmino_,fs%cfg%kmaxo_; do i=fs%cfg%imino_,fs%cfg%imaxo_ + ! Copy over from jmax to jmax+1 and above + do j=fs%cfg%jmax+1,fs%cfg%jmaxo + ! Copy primitive variables + ls%VF(i,j,k)=ls%VF(i,fs%cfg%jmax,k) + fs%Q(i,j,k,1)=fs%Q(i,fs%cfg%jmax,k,1) + fs%P(i,j,k)=fs%P(i,fs%cfg%jmax,k) + fs%I(i,j,k)=fs%I(i,fs%cfg%jmax,k) + fs%U(i,j,k)=fs%U(i,fs%cfg%jmax,k) + fs%V(i,j,k)=max(fs%V(i,fs%cfg%jmax,k),0.0_WP) + fs%W(i,j,k)=fs%W(i,fs%cfg%jmax,k) + end do + end do; end do + end if + + ! Apply clipped Neumann on primitive variables in y- + if (.not.fs%cfg%yper.and.fs%cfg%jproc.eq.1) then + do k=fs%cfg%kmino_,fs%cfg%kmaxo_; do i=fs%cfg%imino_,fs%cfg%imaxo_ + ! First copy over V from jmin+1 to jmin + fs%V(i,fs%cfg%jmin,k)=min(fs%V(i,fs%cfg%jmin+1,k),0.0_WP) + ! Then copy over from jmin to jmin-1 and below + do j=fs%cfg%jmino,fs%cfg%jmin-1 + ! Copy primitive variables + ls%VF(i,j,k)=ls%VF(i,fs%cfg%jmin,k) + fs%Q(i,j,k,1)=fs%Q(i,fs%cfg%jmin,k,1) + fs%P(i,j,k)=fs%P(i,fs%cfg%jmin,k) + fs%I(i,j,k)=fs%I(i,fs%cfg%jmin,k) + fs%U(i,j,k)=fs%U(i,fs%cfg%jmin,k) + fs%V(i,j,k)=min(fs%V(i,fs%cfg%jmin,k),0.0_WP) + fs%W(i,j,k)=fs%W(i,fs%cfg%jmin,k) + end do + end do; end do + end if + + ! Apply clipped Neumann on primitive variables in z+ + if (.not.fs%cfg%zper.and.fs%cfg%kproc.eq.fs%cfg%npz) then + do j=fs%cfg%jmino_,fs%cfg%jmaxo_; do i=fs%cfg%imino_,fs%cfg%imaxo_ + ! Copy over from kmax to kmax+1 and above + do k=fs%cfg%kmax+1,fs%cfg%kmaxo + ! Copy primitive variables + ls%VF(i,j,k)=ls%VF(i,j,fs%cfg%kmax) + fs%Q(i,j,k,1)=fs%Q(i,j,fs%cfg%kmax,1) + fs%P(i,j,k)=fs%P(i,j,fs%cfg%kmax) + fs%I(i,j,k)=fs%I(i,j,fs%cfg%kmax) + fs%U(i,j,k)=fs%U(i,j,fs%cfg%kmax) + fs%V(i,j,k)=fs%V(i,j,fs%cfg%kmax) + fs%W(i,j,k)=max(fs%W(i,j,fs%cfg%kmax),0.0_WP) + end do + end do; end do + end if + + ! Apply clipped Neumann on primitive variables in z- + if (.not.fs%cfg%zper.and.fs%cfg%kproc.eq.1) then + do j=fs%cfg%jmino_,fs%cfg%jmaxo_; do i=fs%cfg%imino_,fs%cfg%imaxo_ + ! First copy over W from kmin+1 to kmin + fs%W(i,j,fs%cfg%kmin)=min(fs%W(i,j,fs%cfg%kmin+1),0.0_WP) + ! Then copy over from kmin to kmin-1 and below + do k=fs%cfg%kmino,fs%cfg%kmin-1 + ! Copy primitive variables + ls%VF(i,j,k)=ls%VF(i,j,fs%cfg%kmin) + fs%Q(i,j,k,1)=fs%Q(i,j,fs%cfg%kmin,1) + fs%P(i,j,k)=fs%P(i,j,fs%cfg%kmin) + fs%I(i,j,k)=fs%I(i,j,fs%cfg%kmin) + fs%U(i,j,k)=fs%U(i,j,fs%cfg%kmin) + fs%V(i,j,k)=fs%V(i,j,fs%cfg%kmin) + fs%W(i,j,k)=min(fs%W(i,j,fs%cfg%kmin),0.0_WP) + end do + end do; end do + end if + + ! Rebuild conserved quantities + fs%Q(:,:,:,2)=fs%Q(:,:,:,1)*fs%I + call fs%get_momentum() + + end subroutine apply_bconds + + + !> Initialization of problem solver + subroutine simulation_init + + use param, only: param_read,param_exists + implicit none + + ! Allocate work arrays + allocate_work_arrays: block + allocate(dQdt (cfg%imino_:cfg%imaxo_,cfg%jmino_:cfg%jmaxo_,cfg%kmino_:cfg%kmaxo_,1:5,1:4)) + end block allocate_work_arrays + + ! Initialize time tracker with 2 subiterations + initialize_timetracker: block + time=timetracker(amRoot=cfg%amRoot) + call param_read('Max timestep size',time%dtmax) + call param_read('Max cfl number',time%cflmax) + call param_read('Max time',time%tmax) + time%dt=time%dtmax + time%itmax=2 + end block initialize_timetracker + + + + ! ! Initialize Lagrangian solid solver + ! initialize_lss: block + ! use mpi_f08, only: MPI_ALLREDUCE,MPI_MAX,MPI_INTEGER + ! real(WP) :: dx,mu,kk,max_stretch,Lx,Ly,Lz + ! real(WP) :: xmin,xmax,ymin,ymax,zmin,zmax,ratio,P_load + ! integer :: np,nt,nx,ny,nz,ierr,global_index + ! type triangle_type + ! real(WP), dimension(3) :: norm + ! real(WP), dimension(3) :: v1 + ! real(WP), dimension(3) :: v2 + ! real(WP), dimension(3) :: v3 + ! end type triangle_type + ! type(triangle_type), dimension(:), allocatable :: t + + + ! ! Create solver + ! ls=lss(cfg=cfg,name='solid') + ! !call fs%initialize(cfg=cfg,name='Compressible NS') + + + ! ! Set material properties + ! call param_read('Elastic Modulus',ls%elastic_modulus) + ! call param_read('Poisson Ratio',ls%poisson_ratio) + ! call param_read('Solid density',ls%rho) + ! call param_read('Critical Energy Release Rate',ls%crit_energy) + + ! ! Maximum timestep size used for particles + ! call param_read('Particle timestep size',ls_dt_max,default=huge(1.0_WP)) + ! ls_dt=min(ls_dt_max,time%dtmax) + + ! ! Discretization + ! ! ls%delta=fs%cfg%min_meshsize*1.01 + ! ! Load',P_load) + ! call param_read('Lx',Lx) + ! call param_read('Ly',Ly) + ! call param_read('Lz',Lz) + ! call param_read('Subdivisions',ny) + ! nz = ny + ! nx = NINT(Lx/Lz)*ny + ! call param_read('Horizon Ratio',ratio) + ! ls%delta = Ly/real(ny,WP)*ratio + ! ! Output some info on stretch + ! mu=ls%elastic_modulus/(2.0_WP+2.0_WP*ls%poisson_ratio) + ! kk=ls%elastic_modulus/(3.0_WP-6.0_WP*ls%poisson_ratio) + ! max_stretch=sqrt(ls%crit_energy/((3.0_WP*mu+(kk-5.0_WP*mu/3.0_WP)*0.75_WP**4)*ls%delta)) + + ! ! Only root process initializes solid particles + ! if (ls%cfg%amRoot) then + ! ! Read the STL file and get domain extents and levelset + ! print*, Lx * Ly * Lz / real(ny*nz*nx,WP) + ! read_bin: block + + ! use messager, only: die + ! integer :: p,iunit,ierr, wall_np, i, j, k + ! global_index = 0 + ! target_index = 0 + + ! ! Read in grid definition + ! wall_np = ny*nz*(nx+3) + ! ! call ls%resize(np+wall_np) + ! call ls%resize(wall_np) + ! p=0 + ! do i=1,nx+3 + ! do j=1,ny + ! do k=1,nz + ! p = p+1 + ! ls%p(p)%pos(1) = (i-1) * (Lx/real(nx,WP)) + ! ls%p(p)%pos(2) = (j) * (Ly/real(ny,WP)) - Ly/2.0_WP + ! ls%p(p)%pos(3) = (k) * (Lz/real(nz,WP)) - Lz/2.0_WP + ! ls%p(p)%vol = Lx * Ly * Lz / real(ny*nz*nx,WP) + ! ls%p(p)%id=1 + ! if(i.le.3) ls%p(p)%id=-2 + + ! ls%p(p)%vel=[0.0_WP,0.0_WP,0.0_WP] + ! ! Zero out force + ! ls%p(p)%Abond=0.0_WP + ! ! Zero out fluid unless end, using this for the load + ! ls%p(p)%Afluid=0.0_WP + ! !if(i.eq.nx+3) ls%p(p)%Afluid=[(P_load*Ly*Lz)/(ls%rho*ls%p(p)%vol),0.0_WP,0.0_WP] + ! ! Locate the particle on the mesh + ! ls%p(p)%ind=ls%cfg%get_ijk_global(ls%p(p)%pos,[ls%cfg%imin,ls%cfg%jmin,ls%cfg%kmin]) + ! ! Assign a unique integer to particle + ! ls%p(p)%i=p + ! ! Activate the particle + ! ls%p(p)%flag=0 + ! if(i.eq.(nx/2+1).and.j.eq.(ny/2+1).and.k.eq.(nz/2+1)) target_index = p + ! end do + ! end do + ! end do + + ! np = wall_np + ! end block read_bin + ! end if + + ! ! Allreduce with MPI_MAX ensures the nonzero index propagates to all + ! call MPI_ALLREDUCE(target_index, global_index, 1, MPI_INTEGER, MPI_MAX, ls%cfg%comm, ierr) + + ! ! Update target_index globally + ! target_index = global_index + + + ! ! Communicate particles + ! call ls%sync() + + ! call get_tracked_particle() + + ! ! Get initial volume fraction + ! ! call ls%update_VF() + + ! ! Initalize bonds + ! call ls%bond_init() + + ! if (ls%cfg%amRoot) then + ! print*,"===== Solid Setup Description =====" + ! print*,'Number of particles', np + ! print*,'Maximum stretching =',max_stretch + ! end if + + ! end block initialize_lss + + initialize_lss: block + use mpi_f08, only: MPI_ALLREDUCE,MPI_MAX,MPI_INTEGER + real(WP) :: dx,mu,kk,max_stretch,Lx,Ly,Lz,R,x,y,z,P_load + real(WP) :: xmin,xmax,ymin,ymax,zmin,zmax,ratio,dist + integer :: np,nt,nx,ny,nz,ierr,global_index,N + type triangle_type + real(WP), dimension(3) :: norm + real(WP), dimension(3) :: v1 + real(WP), dimension(3) :: v2 + real(WP), dimension(3) :: v3 + end type triangle_type + type(triangle_type), dimension(:), allocatable :: t + + + + + ! Create solver + ls=lss(cfg=cfg,name='solid') + !call fs%initialize(cfg=cfg,name='Compressible NS') + + + ! Set material properties + call param_read('Elastic Modulus',ls%elastic_modulus) + call param_read('Poisson Ratio',ls%poisson_ratio) + call param_read('Solid density',ls%rho) + call param_read('Critical Energy Release Rate',ls%crit_energy) + call param_read('Solid Damping Constant',ls%beta) + + ! Maximum timestep size used for particles + call param_read('Particle timestep size',ls_dt_max,default=huge(1.0_WP)) + ls_dt=min(ls_dt_max,time%dtmax) + + ! Discretization + ! ls%delta=fs%cfg%min_meshsize*1.01 + ! Load',P_load) + call param_read('Lx',Lx) + call param_read('Ly',Ly) + call param_read('Lz',Lz) + call param_read('R',R) + ! call param_read('Solid Spacing',dist) + call param_read('N Across',N) + call param_read('Solid Load',P_load) + ! Lx = 1.0_WP + ! Ly = 1.0_WP + ! dist = 0.01_WP ! Space between particles + ! Lx = Lx + 6.0_WP * dist + ! Ly = Ly + 3.0_WP * dist + dist = Ly/N + ny = N + nz = N + nx = floor(Lx/Ly)*N+6 + call param_read('Horizon Ratio',ratio) + ls%delta = dist*ratio + + ! Output some info on stretch + mu=ls%elastic_modulus/(2.0_WP+2.0_WP*ls%poisson_ratio) + kk=ls%elastic_modulus/(3.0_WP-6.0_WP*ls%poisson_ratio) + max_stretch=sqrt(ls%crit_energy/((3.0_WP*mu+(kk-5.0_WP*mu/3.0_WP)*0.75_WP**4)*ls%delta)) + + ! Only root process initializes solid particles + if (ls%cfg%amRoot) then + read_bin: block + + use messager, only: die + integer :: p,iunit,ierr, wall_np, i, j, k + real(WP) :: net_vol + net_vol = 0.0_WP + global_index = 0 + target_index = 0 + ! Read in grid definition + wall_np = (ny)*(nz)*(nx) + ! call ls%resize(np+wall_np) + call ls%resize(wall_np) + p=0 + do i=1,nx + do j=1,ny + do k=1,nz + x = (i-6) * dist - Lx/2.0_WP; + y = (j-1) * dist - (Ly/2.0_WP - dist/2.0_WP); + z = (k-1) * dist - (Lz/2.0_WP - dist/2.0_WP); + !if ((x*x + y*y).gt.R*R) cycle; + !if (((x)*(x) + y*y + z*z).lt.R*R) cycle; + p = p+1 + ls%p(p)%pos(1) = x + ls%p(p)%pos(2) = y + ls%p(p)%pos(3) = z + ls%p(p)%ipos=ls%p(p)%pos + ls%p(p)%displacement=0.0_WP + ls%p(p)%vol = dist*dist*dist + ls%p(p)%id=1 + if(i.le.6) ls%p(p)%id=-1 + ls%p(p)%vel=[0.0_WP,0.0_WP,0.0_WP] + if(i.ge.nx) net_vol=net_vol+ls%p(p)%vol + ! Zero out force + ls%p(p)%Abond=0.0_WP + ! Zero out fluid unless end, using this for the load + ls%p(p)%Afluid=0.0_WP + if(i.ge.nx) ls%p(p)%Afluid=[(P_load/(dist**3 * ny * nz * 1))/(ls%rho),0.0_WP,0.0_WP] + ! Locate the particle on the mesh + ls%p(p)%ind=ls%cfg%get_ijk_global(ls%p(p)%pos,[ls%cfg%imin,ls%cfg%jmin,ls%cfg%kmin]) + ! Assign a unique integer to particle + ls%p(p)%i=p + ! Activate the particle + ls%p(p)%flag=0 + if(i.eq.(nx/2+3).and.j.eq.(ny/2+1).and.k.eq.(nz/2+1)) target_index = p + end do + end do + end do + + np = wall_np + print*, "Nx: ", nx + print*, "Ny: ", ny + print*, "Nz: ", nz + print*, "Net Force Volume", net_vol + print*, "Used Volume", (dist**3 * ny * nz * 1) + end block read_bin + end if + + ! Allreduce with MPI_MAX ensures the nonzero index propagates to all + call MPI_ALLREDUCE(target_index, global_index, 1, MPI_INTEGER, MPI_MAX, ls%cfg%comm, ierr) + + ! Update target_index globally + target_index = global_index + + + ! Communicate particles + call ls%sync() + + call get_tracked_particle() + + ! Get initial volume fraction + ! call ls%update_VF() + + ! Initalize bonds + call ls%bond_init() + call ls%get_bond_force() + call ls%sync() + + if (ls%cfg%amRoot) then + print*,"===== Solid Setup Description =====" + print*,'Number of particles', np + print*,'Maximum stretching =',max_stretch + end if + + end block initialize_lss + + + ! Create partmesh object for visualizing Lagrangian particles + create_pmesh: block + use lss_class, only: max_bond + integer :: i,n,nbond + pmesh=partmesh(nvar=5,nvec=3,name='solid') + pmesh%varname(1)='failfrac' + pmesh%varname(2)='id' + pmesh%varname(3)='nbond' + pmesh%varname(4)='von-Mises' + pmesh%varname(5)='quadCheck' + + + pmesh%vecname(1)='velocity' + pmesh%vecname(2)='bond_force' + pmesh%vecname(3)='disp' + call ls%update_partmesh(pmesh) + do i=1,ls%np_ + pmesh%var(1,i)=0.0_WP + nbond=0 + do n=1,max_bond + if (ls%p(i)%ibond(n).gt.0) nbond=nbond+1 + end do + if (ls%p(i)%nbond.gt.0) then + pmesh%var(1,i)=1.0_WP-real(nbond,WP)/real(ls%p(i)%nbond,WP) + else + pmesh%var(1,i)=0.0_WP + end if + pmesh%var(2,i) =ls%p(i)%id + pmesh%vec(:,1,i)=ls%p(i)%vel + pmesh%vec(:,2,i)=ls%p(i)%Abond + pmesh%var(3,i) =ls%p(i)%nbond + pmesh%var(4,i) =ls%p(i)%vonMises + pmesh%var(5,i) =ls%p(i)%quadCheck + pmesh%vec(:,3,i) =ls%p(i)%displacement + + end do + end block create_pmesh + + ! Add Ensight output + create_ensight: block + ! Create Ensight output from cfg + ens_out=ensight(cfg=cfg,name='shock') + ! Create event for Ensight output + ens_evt=event(time=time,name='Ensight output') + call param_read('Ensight output period',ens_evt%tper) + ! Add variables to output + call ens_out%add_particle('particles',pmesh) + ! Output to ensight + if (ens_evt%occurs()) call ens_out%write_data(time%t) + end block create_ensight + + + ! Create monitor files + create_monitor: block + real(WP) :: cfl + ! Prepare some info about fields + call ls%get_cfl(time%dt,time%cfl) + call ls%get_max() + ! Create solid monitor + sfile=monitor(ls%cfg%amRoot,'solid') + call sfile%add_column(time%n,'Timestep number') + call sfile%add_column(time%t,'Time') + call sfile%add_column(ls_dt,'Particle dt') + call sfile%add_column(time%cfl,'Maximum CFL') + call sfile%add_column(ls%np,'Particle number') + call sfile%add_column(ls%VFmax,'VFmax') + call sfile%add_column(ls%Umin,'Particle Umin') + call sfile%add_column(ls%Umax,'Particle Umax') + call sfile%add_column(ls%Vmin,'Particle Vmin') + call sfile%add_column(ls%Vmax,'Particle Vmax') + call sfile%add_column(ls%Wmin,'Particle Wmin') + call sfile%add_column(ls%Wmax,'Particle Wmax') + call sfile%add_column(ls%ibmForce(1),'Particle Fx') + call sfile%add_column(ls%ibmForce(2),'Particle Fy') + call sfile%add_column(ls%ibmForce(3),'Particle Fz') + call sfile%write() + dispfile=monitor(ls%cfg%amRoot,'displacement') + call dispfile%add_column(time%n,'Timestep number') + call dispfile%add_column(time%t,'Time') + call dispfile%add_column(ls_dt,'Particle dt') + call dispfile%add_column(target_position(1),'X') + call dispfile%add_column(target_position(2),'Y') + call dispfile%add_column(target_position(3),'Z') + call dispfile%write() + end block create_monitor + + end subroutine simulation_init + + + !> Perform an NGA2 simulation + subroutine simulation_run + implicit none + real(WP) :: cfl + logical :: first_time + + first_time = .true. + ! Perform time integration + do while (.not.time%done()) + + ! Increment time + call ls%get_cfl(time%dt,time%cfl) + ! call fs%get_cfl(time%dt,cfl); time%cfl=max(time%cfl,cfl) + call time%adjust_dt() + call time%increment() + + ! Advance solid solver + solid: block + real(WP) :: dt_done,mydt + ! Sub-iteratore + call ls%get_cfl(ls_dt,cfl=cfl) + if (cfl.gt.0.0_WP) ls_dt=min(ls_dt*time%cflmax/cfl,ls_dt_max) + dt_done=0.0_WP + do while (dt_done.lt.time%dtmid) + ! Decide the timestep size + if(first_time) then + ! call ls%stretch(dt =mydt) + first_time=.false. + dt_done=dt_done+mydt + else + mydt=min(ls_dt,time%dtmid-dt_done) + ! ! Advance particles + call ls%advance(dt =mydt) + ! ! Increment + dt_done=dt_done+mydt + end if + + + ! mydt=min(ls_dt,time%dtmid-dt_done) + ! ! Advance particles + ! call ls%advance(dt =mydt) + ! ! ! Increment + ! dt_done=dt_done+mydt + + end do + end block solid + + !> Perform and output monitoring + call ls%get_max() + call get_tracked_particle() + call sfile%write() + call dispfile%write() + + + ! Output to ensight + if (ens_evt%occurs()) then + update_pmesh: block + use lss_class, only: max_bond + integer :: i,n,nbond + call ls%update_partmesh(pmesh) + do i=1,ls%np_ + nbond=0 + do n=1,max_bond + if (ls%p(i)%ibond(n).gt.0) nbond=nbond+1 + end do + if (ls%p(i)%nbond.gt.0) then + pmesh%var(1,i)=1.0_WP-real(nbond,WP)/real(ls%p(i)%nbond,WP) + else + pmesh%var(1,i)=0.0_WP + end if + pmesh%var(2,i) =ls%p(i)%id + pmesh%vec(:,1,i)=ls%p(i)%vel + pmesh%vec(:,2,i)=ls%p(i)%Abond + pmesh%var(3,i) =ls%p(i)%nbond + pmesh%var(4,i) =ls%p(i)%vonMises + pmesh%var(5,i) =ls%p(i)%quadCheck + pmesh%vec(:,3,i) =ls%p(i)%displacement + + + end do + end block update_pmesh + call ens_out%write_data(time%t) + end if + + end do + + end subroutine simulation_run + + + !> Finalize the NGA2 simulation + subroutine simulation_final + implicit none + + ! Get rid of all objects - need destructors + ! monitor + ! ensight + ! bcond + ! timetracker + + ! Deallocate work arrays + deallocate(dQdt) + end subroutine simulation_final + + +end module simulation diff --git a/examples/NOSB/src/spcomp_class.f90 b/examples/NOSB/src/spcomp_class.f90 new file mode 100644 index 000000000..00ec1fe25 --- /dev/null +++ b/examples/NOSB/src/spcomp_class.f90 @@ -0,0 +1,942 @@ +!> Single phase compressible flow solver class: +!> Provides support for RHS calculation only +module spcomp_class + use precision, only: WP + use string, only: str_medium + use config_class, only: config + use timer_class, only: timer + implicit none + private + + ! Expose type + public :: spcomp + + !> Single phase compressible solver object definition + type :: spcomp + + ! This is the config around which solver is built + class(config), pointer :: cfg + + ! Solver name + character(len=str_medium) :: name='UNNAMED_SPCOMP' + + ! Pointers to functions to evaluate P(RHO,E), T(RHO,P), and C(RHO,P) + procedure(Pfunc_type), pointer, nopass :: getP=>NULL() + procedure(Tfunc_type), pointer, nopass :: getT=>NULL() + procedure(Cfunc_type), pointer, nopass :: getC=>NULL() + procedure(Sfunc_type), pointer, nopass :: getS=>NULL() + + ! Conserved variables: 1=RHO, 2=RHO*I, 3=RHO*U, 4=RHO*V, 5=RHO*W + integer :: nQ + real(WP), dimension(:,:,:,:), allocatable :: Q,Qold + + ! Flow velocity + real(WP), dimension(:,:,:), allocatable :: U,V,W + + ! Internal energy + real(WP), dimension(:,:,:), allocatable :: I + + ! Pressure + real(WP), dimension(:,:,:), allocatable :: P + + ! Temperature + real(WP), dimension(:,:,:), allocatable :: T + + ! Speed of sound + real(WP), dimension(:,:,:), allocatable :: C + + ! Viscosities and heat diffusivity + real(WP), dimension(:,:,:), allocatable :: VISC,BETA,DIFF + + ! Gravitational acceleration + real(WP), dimension(3) :: gravity=0.0_WP + + ! Store mesh info + real(WP) :: dx,dy,dz,dxi,dyi,dzi,vol + + ! CFL numbers + real(WP) :: CFLc_x,CFLc_y,CFLc_z !< Convective CFL numbers + real(WP) :: CFLa_x,CFLa_y,CFLa_z !< Acoustic CFL numbers + real(WP) :: CFLv_x,CFLv_y,CFLv_z !< Viscous CFL numbers + + ! Monitoring quantities for conserved variables + real(WP), dimension(:), allocatable :: Qmin,Qmax,Qint + real(WP) :: RHOKint + real(WP) :: RHOSint + + ! Monitoring quantities for primitive variables + real(WP) :: Umax,Vmax,Wmax !< Velocity stats + real(WP) :: RHOmin,RHOmax !< Density stats + real(WP) :: Imin,Imax !< Internal energy stats + real(WP) :: Pmin,Pmax !< Pressure stats + real(WP) :: Tmin,Tmax !< Temperature stats + + ! Timer + type(timer) :: trhs !< Timer for RHS calculation + + contains + procedure :: print=>spcomp_print !< Output solver to the screen + procedure :: initialize !< Initialize the flow solver + procedure :: finalize !< Finalize the flow solver + procedure :: get_div_stress !< Compute divergence of stress for LSS solver + procedure :: rhs !< Compute rhs of our equations using standard fluxes + procedure :: get_primitive !< Calculate primitive variables from conserved variables + procedure :: get_viscartif !< Calculate artifical bulk kinematic viscosity + procedure :: get_vreman !< Get kinematic eddy viscosity using Vreman's model + procedure :: get_velocity !< Calculate velocity from momentum + procedure :: get_ke !< Calculate kinetic energy per unit mass from velocity + procedure :: get_momentum !< Calculate momentum from velocity + procedure :: interp_vel !< Calculate interpolated velocity + procedure :: get_cfl !< Calculate maximum CFL + procedure :: get_info !< Calculate maximum field values + end type spcomp + + !> Interfaces for user-defined function + abstract interface + !> P=P(RHO,I) + pure real(WP) function Pfunc_type(RHO,I) + import :: WP + implicit none + real(WP), intent(in) :: RHO + real(WP), intent(in) :: I + end function Pfunc_type + !> T=T(RHO,P) + pure real(WP) function Tfunc_type(RHO,P) + import :: WP + implicit none + real(WP), intent(in) :: RHO + real(WP), intent(in) :: P + end function Tfunc_type + !> C=C(RHO,P) + pure real(WP) function Cfunc_type(RHO,P) + import :: WP + implicit none + real(WP), intent(in) :: RHO + real(WP), intent(in) :: P + end function Cfunc_type + !> S=S(RHO,P) + pure real(WP) function Sfunc_type(RHO,P) + import :: WP + implicit none + real(WP), intent(in) :: RHO + real(WP), intent(in) :: P + end function Sfunc_type + end interface + +contains + + + !> Initialization for compressible flow solver + subroutine initialize(this,cfg,name) + use messager, only: die + implicit none + class(spcomp) :: this + class(config), target, intent(in) :: cfg + character(len=*), optional :: name + + ! Set the name for the solver + if (present(name)) this%name=trim(adjustl(name)) + + ! Point to config object + this%cfg=>cfg + + ! Check that config is uniform with at least 2 cells of overlap + if (this%cfg%no.lt.2) call die('[spcomp initialize] spcomp solver requires at least 2 cells of overlap') + if (.not.all([this%cfg%uniform_x,this%cfg%uniform_y,this%cfg%uniform_z])) call die('[spcomp initialize] spcomp solver requires a uniform mesh') + + ! Store constant cell size and its inverse, handle 2D conditions, store cell volume + this%dx=this%cfg%dx(this%cfg%imin_); this%dxi=1.0_WP/this%dx; if (this%cfg%nx.eq.1) this%dxi=0.0_WP + this%dy=this%cfg%dy(this%cfg%jmin_); this%dyi=1.0_WP/this%dy; if (this%cfg%ny.eq.1) this%dyi=0.0_WP + this%dz=this%cfg%dz(this%cfg%kmin_); this%dzi=1.0_WP/this%dz; if (this%cfg%nz.eq.1) this%dzi=0.0_WP + this%vol=this%dx*this%dy*this%dz + + ! Allocate and zero out conserved variables + this%nQ=5 + allocate(this%Q (this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_,1:this%nQ)); this%Q =0.0_WP + allocate(this%Qold(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_,1:this%nQ)); this%Qold=0.0_WP + + ! Conserved variables monitoring + allocate(this%Qmin(1:this%nQ),this%Qmax(1:this%nQ),this%Qint(1:this%nQ)) + + ! Flow velocity + allocate(this%U(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)); this%U=0.0_WP + allocate(this%V(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)); this%V=0.0_WP + allocate(this%W(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)); this%W=0.0_WP + + ! Internal energy + allocate(this%I(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)); this%I=0.0_WP + + ! Pressure + allocate(this%P(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)); this%P=0.0_WP + + ! Temperature + allocate(this%T(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)); this%T=0.0_WP + + ! Speed of sound + allocate(this%C(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)); this%C=0.0_WP + + ! Viscosities and heat diffusivity + allocate(this%VISC(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)); this%VISC=0.0_WP + allocate(this%BETA(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)); this%BETA=0.0_WP + allocate(this%DIFF(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)); this%DIFF=0.0_WP + + ! Create timers + this%trhs=timer(comm=this%cfg%comm,name='RHS') + + end subroutine initialize + + + !> Obtain RHS for all equations + subroutine rhs(this,dQdt) + implicit none + class(spcomp), intent(inout) :: this + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:,1:), intent(out) :: dQdt !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_,1:nVAR) + real(WP), dimension(:,:,:,:), allocatable :: FQx,FQy,FQz + integer :: i,j,k,n + real(WP) :: w,div + real(WP), parameter :: eps=1.0e-15_WP + real(WP), dimension(-2: 0) :: wenop + real(WP), dimension(-1:+1) :: wenom + + ! Start rhs timer + call this%trhs%start() + + ! Zero out RHS + dQdt=0.0_WP + + ! ================================================================ ! + ! ======================== INVISID FLUXES ======================== ! + ! ================================================================ ! + + ! Allocate fluxes of conserved variables + allocate(FQx(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_,1:this%nQ)); FQx=0.0_WP + allocate(FQy(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_,1:this%nQ)); FQy=0.0_WP + allocate(FQz(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_,1:this%nQ)); FQz=0.0_WP + + ! Calculate standard fluxes + do k=this%cfg%kmin_,this%cfg%kmax_+1 + do j=this%cfg%jmin_,this%cfg%jmax_+1 + do i=this%cfg%imin_,this%cfg%imax_+1 + ! X fluxes + ! WENO mass flux + w=weno_weight((abs(this%Q(i-1,j,k,1)-this%Q(i-2,j,k,1))+eps)/(abs(this%Q(i,j,k,1)-this%Q(i-1,j,k,1))+eps)); wenop=0.5_WP*[ -w,1.0_WP+2.0_WP*w,1.0_WP-w] + w=weno_weight((abs(this%Q(i+1,j,k,1)-this%Q(i ,j,k,1))+eps)/(abs(this%Q(i,j,k,1)-this%Q(i-1,j,k,1))+eps)); wenom=0.5_WP*[1.0_WP-w,1.0_WP+2.0_WP*w, -w] + FQx(i,j,k,1)=-0.5_WP*(this%U(i,j,k)+abs(this%U(i,j,k)))*sum(wenop*this%Q(i-2:i ,j,k,1))& + & -0.5_WP*(this%U(i,j,k)-abs(this%U(i,j,k)))*sum(wenom*this%Q(i-1:i+1,j,k,1)) + ! Centered mass flux + !FQx(i,j,k,1)=-this%U(i,j,k)*0.5_WP*sum(this%Q(i-1:i,j,k,1)) + ! WENO internal energy flux + w=weno_weight((abs(this%I(i-1,j,k)-this%I(i-2,j,k))+eps)/(abs(this%I(i,j,k)-this%I(i-1,j,k))+eps)); wenop=0.5_WP*[ -w,1.0_WP+2.0_WP*w,1.0_WP-w] + w=weno_weight((abs(this%I(i+1,j,k)-this%I(i ,j,k))+eps)/(abs(this%I(i,j,k)-this%I(i-1,j,k))+eps)); wenom=0.5_WP*[1.0_WP-w,1.0_WP+2.0_WP*w, -w] + FQx(i,j,k,2)=0.5_WP*(FQx(i,j,k,1)-abs(-FQx(i,j,k,1)))*sum(wenop*this%I(i-2:i ,j,k))& + & +0.5_WP*(FQx(i,j,k,1)+abs(-FQx(i,j,k,1)))*sum(wenom*this%I(i-1:i+1,j,k)) + ! Centered internal energy flux + !FQx(i,j,k,2)=FQx(i,j,k,1)*0.5_WP*sum(this%I(i-1:i,j,k)) + ! Heat flux + FQx(i,j,k,2)=FQx(i,j,k,2)+0.5_WP*(this%DIFF(i-1,j,k)+this%DIFF(i,j,k))*this%dxi*(this%T(i,j,k)-this%T(i-1,j,k)) + ! Y fluxes + ! WENO mass flux + w=weno_weight((abs(this%Q(i,j-1,k,1)-this%Q(i,j-2,k,1))+eps)/(abs(this%Q(i,j,k,1)-this%Q(i,j-1,k,1))+eps)); wenop=0.5_WP*[ -w,1.0_WP+2.0_WP*w,1.0_WP-w] + w=weno_weight((abs(this%Q(i,j+1,k,1)-this%Q(i,j ,k,1))+eps)/(abs(this%Q(i,j,k,1)-this%Q(i,j-1,k,1))+eps)); wenom=0.5_WP*[1.0_WP-w,1.0_WP+2.0_WP*w, -w] + FQy(i,j,k,1)=-0.5_WP*(this%V(i,j,k)+abs(this%V(i,j,k)))*sum(wenop*this%Q(i,j-2:j ,k,1))& + & -0.5_WP*(this%V(i,j,k)-abs(this%V(i,j,k)))*sum(wenom*this%Q(i,j-1:j+1,k,1)) + ! Centered mass flux + !FQy(i,j,k,1)=-this%V(i,j,k)*0.5_WP*sum(this%Q(i,j-1:j,k,1)) + ! WENO internal energy flux + w=weno_weight((abs(this%I(i,j-1,k)-this%I(i,j-2,k))+eps)/(abs(this%I(i,j,k)-this%I(i,j-1,k))+eps)); wenop=0.5_WP*[ -w,1.0_WP+2.0_WP*w,1.0_WP-w] + w=weno_weight((abs(this%I(i,j+1,k)-this%I(i,j ,k))+eps)/(abs(this%I(i,j,k)-this%I(i,j-1,k))+eps)); wenom=0.5_WP*[1.0_WP-w,1.0_WP+2.0_WP*w, -w] + FQy(i,j,k,2)=0.5_WP*(FQy(i,j,k,1)-abs(-FQy(i,j,k,1)))*sum(wenop*this%I(i,j-2:j ,k))& + & +0.5_WP*(FQy(i,j,k,1)+abs(-FQy(i,j,k,1)))*sum(wenom*this%I(i,j-1:j+1,k)) + ! Centered internal energy flux + !FQy(i,j,k,2)=FQy(i,j,k,1)*0.5_WP*sum(this%I(i,j-1:j,k)) + ! Heat flux + FQy(i,j,k,2)=FQy(i,j,k,2)+0.5_WP*(this%DIFF(i,j-1,k)+this%DIFF(i,j,k))*this%dyi*(this%T(i,j,k)-this%T(i,j-1,k)) + ! Z fluxes + ! WENO mass flux + w=weno_weight((abs(this%Q(i,j,k-1,1)-this%Q(i,j,k-2,1))+eps)/(abs(this%Q(i,j,k,1)-this%Q(i,j,k-1,1))+eps)); wenop=0.5_WP*[ -w,1.0_WP+2.0_WP*w,1.0_WP-w] + w=weno_weight((abs(this%Q(i,j,k+1,1)-this%Q(i,j,k ,1))+eps)/(abs(this%Q(i,j,k,1)-this%Q(i,j,k-1,1))+eps)); wenom=0.5_WP*[1.0_WP-w,1.0_WP+2.0_WP*w, -w] + FQz(i,j,k,1)=-0.5_WP*(this%W(i,j,k)+abs(this%W(i,j,k)))*sum(wenop*this%Q(i,j,k-2:k ,1))& + & -0.5_WP*(this%W(i,j,k)-abs(this%W(i,j,k)))*sum(wenom*this%Q(i,j,k-1:k+1,1)) + ! Centered mass flux + !FQz(i,j,k,1)=-this%W(i,j,k)*0.5_WP*sum(this%Q(i,j,k-1:k,1)) + ! WENO internal energy flux + w=weno_weight((abs(this%I(i,j,k-1)-this%I(i,j,k-2))+eps)/(abs(this%I(i,j,k)-this%I(i,j,k-1))+eps)); wenop=0.5_WP*[ -w,1.0_WP+2.0_WP*w,1.0_WP-w] + w=weno_weight((abs(this%I(i,j,k+1)-this%I(i,j,k ))+eps)/(abs(this%I(i,j,k)-this%I(i,j,k-1))+eps)); wenom=0.5_WP*[1.0_WP-w,1.0_WP+2.0_WP*w, -w] + FQz(i,j,k,2)=0.5_WP*(FQz(i,j,k,1)-abs(-FQz(i,j,k,1)))*sum(wenop*this%I(i,j,k-2:k ))& + & +0.5_WP*(FQz(i,j,k,1)+abs(-FQz(i,j,k,1)))*sum(wenom*this%I(i,j,k-1:k+1)) + ! Centered internal energy flux + !FQz(i,j,k,2)=FQz(i,j,k,1)*0.5_WP*sum(this%I(i,j,k-1:k)) + ! Heat flux + FQz(i,j,k,2)=FQz(i,j,k,2)+0.5_WP*(this%DIFF(i,j,k-1)+this%DIFF(i,j,k))*this%dzi*(this%T(i,j,k)-this%T(i,j,k-1)) + end do + end do + end do + + ! Mass fluxes will be used to build momentum fluxes, they need to be extended by one cell on the left because of staggering + call this%cfg%sync(FQx(:,:,:,1)); if (.not.this%cfg%xper.and.this%cfg%iproc.eq.1) FQx(this%cfg%imin-1,:,:,1)=FQx(this%cfg%imin,:,:,1) + call this%cfg%sync(FQy(:,:,:,1)); if (.not.this%cfg%yper.and.this%cfg%jproc.eq.1) FQy(:,this%cfg%jmin-1,:,1)=FQy(:,this%cfg%jmin,:,1) + call this%cfg%sync(FQz(:,:,:,1)); if (.not.this%cfg%zper.and.this%cfg%kproc.eq.1) FQz(:,:,this%cfg%kmin-1,1)=FQz(:,:,this%cfg%kmin,1) + + ! Calculate cell-centered momentum fluxes with extra cell on the left due to staggering + do k=this%cfg%kmin_-1,this%cfg%kmax_ + do j=this%cfg%jmin_-1,this%cfg%jmax_ + do i=this%cfg%imin_-1,this%cfg%imax_ + FQx(i,j,k,3)=0.25_WP*sum(FQx(i:i+1,j,k,1))*sum(this%U(i:i+1,j,k))-this%P(i,j,k) + FQy(i,j,k,4)=0.25_WP*sum(FQy(i,j:j+1,k,1))*sum(this%V(i,j:j+1,k))-this%P(i,j,k) + FQz(i,j,k,5)=0.25_WP*sum(FQz(i,j,k:k+1,1))*sum(this%W(i,j,k:k+1))-this%P(i,j,k) + end do + end do + end do + + ! Calculate edge-centered momentum fluxes + do k=this%cfg%kmin_,this%cfg%kmax_+1 + do j=this%cfg%jmin_,this%cfg%jmax_+1 + do i=this%cfg%imin_,this%cfg%imax_+1 + FQy(i,j,k,3)=0.25_WP*sum(FQy(i-1:i,j,k,1))*sum(this%U(i,j-1:j,k)) + FQz(i,j,k,3)=0.25_WP*sum(FQz(i-1:i,j,k,1))*sum(this%U(i,j,k-1:k)) + FQx(i,j,k,4)=0.25_WP*sum(FQx(i,j-1:j,k,1))*sum(this%V(i-1:i,j,k)) + FQz(i,j,k,4)=0.25_WP*sum(FQz(i,j-1:j,k,1))*sum(this%V(i,j,k-1:k)) + FQx(i,j,k,5)=0.25_WP*sum(FQx(i,j,k-1:k,1))*sum(this%W(i-1:i,j,k)) + FQy(i,j,k,5)=0.25_WP*sum(FQy(i,j,k-1:k,1))*sum(this%W(i,j-1:j,k)) + end do + end do + end do + + ! Assemble time derivative for conserved variables + do k=this%cfg%kmin_,this%cfg%kmax_ + do j=this%cfg%jmin_,this%cfg%jmax_ + do i=this%cfg%imin_,this%cfg%imax_ + ! Mass and internal energy advection + dQdt(i,j,k,1)=this%dxi*(FQx(i+1,j,k,1)-FQx(i,j,k,1))+this%dyi*(FQy(i,j+1,k,1)-FQy(i,j,k,1))+this%dzi*(FQz(i,j,k+1,1)-FQz(i,j,k,1)) + dQdt(i,j,k,2)=this%dxi*(FQx(i+1,j,k,2)-FQx(i,j,k,2))+this%dyi*(FQy(i,j+1,k,2)-FQy(i,j,k,2))+this%dzi*(FQz(i,j,k+1,2)-FQz(i,j,k,2)) + ! Momentum advection and pressure stress + dQdt(i,j,k,3)=this%dxi*(FQx(i ,j,k,3)-FQx(i-1,j,k,3))+this%dyi*(FQy(i,j+1,k,3)-FQy(i,j ,k,3))+this%dzi*(FQz(i,j,k+1,3)-FQz(i,j,k ,3)) + dQdt(i,j,k,4)=this%dxi*(FQx(i+1,j,k,4)-FQx(i ,j,k,4))+this%dyi*(FQy(i,j ,k,4)-FQy(i,j-1,k,4))+this%dzi*(FQz(i,j,k+1,4)-FQz(i,j,k ,4)) + dQdt(i,j,k,5)=this%dxi*(FQx(i+1,j,k,5)-FQx(i ,j,k,5))+this%dyi*(FQy(i,j+1,k,5)-FQy(i,j ,k,5))+this%dzi*(FQz(i,j,k ,5)-FQz(i,j,k-1,5)) + ! Pressure dilatation term + dQdt(i,j,k,2)=dQdt(i,j,k,2)-this%P(i,j,k)*(this%dxi*(this%U(i+1,j,k)-this%U(i,j,k))+this%dyi*(this%V(i,j+1,k)-this%V(i,j,k))+this%dzi*(this%W(i,j,k+1)-this%W(i,j,k))) + end do + end do + end do + + ! ================================================================ ! + ! ======================== VISCOUS FLUXES ======================= ! + ! ================================================================ ! + + ! Zero out fluxes + FQx=0.0_WP; FQy=0.0_WP; FQz=0.0_WP + + ! Compute cell-centered momentum viscous fluxes + do k=this%cfg%kmin_-1,this%cfg%kmax_ + do j=this%cfg%jmin_-1,this%cfg%jmax_ + do i=this%cfg%imin_-1,this%cfg%imax_ + div=this%dxi*(this%U(i+1,j,k)-this%U(i,j,k))+this%dyi*(this%V(i,j+1,k)-this%V(i,j,k))+this%dzi*(this%W(i,j,k+1)-this%W(i,j,k)) + FQx(i,j,k,3)=2.0_WP*this%VISC(i,j,k)*this%dxi*(this%U(i+1,j,k)-this%U(i,j,k))+(this%BETA(i,j,k)-2.0_WP*this%VISC(i,j,k)/3.0_WP)*div + FQy(i,j,k,4)=2.0_WP*this%VISC(i,j,k)*this%dyi*(this%V(i,j+1,k)-this%V(i,j,k))+(this%BETA(i,j,k)-2.0_WP*this%VISC(i,j,k)/3.0_WP)*div + FQz(i,j,k,5)=2.0_WP*this%VISC(i,j,k)*this%dzi*(this%W(i,j,k+1)-this%W(i,j,k))+(this%BETA(i,j,k)-2.0_WP*this%VISC(i,j,k)/3.0_WP)*div + end do + end do + end do + + ! Compute edge-centered momentum viscous fluxes and corresponding viscous heating + do k=this%cfg%kmin_,this%cfg%kmax_+1 + do j=this%cfg%jmin_,this%cfg%jmax_+1 + do i=this%cfg%imin_,this%cfg%imax_+1 + FQy(i,j,k,3)=0.25_WP*sum(this%VISC(i-1:i,j-1:j,k))*(this%dyi*(this%U(i,j,k)-this%U(i,j-1,k))+this%dxi*(this%V(i,j,k)-this%V(i-1,j,k))); FQx(i,j,k,4)=FQy(i,j,k,3) + FQz(i,j,k,2)=FQy(i,j,k,3)*(this%dyi*(this%U(i,j,k)-this%U(i,j-1,k))+this%dxi*(this%V(i,j,k)-this%V(i-1,j,k))) + FQz(i,j,k,4)=0.25_WP*sum(this%VISC(i,j-1:j,k-1:k))*(this%dzi*(this%V(i,j,k)-this%V(i,j,k-1))+this%dyi*(this%W(i,j,k)-this%W(i,j-1,k))); FQy(i,j,k,5)=FQz(i,j,k,4) + FQx(i,j,k,2)=FQz(i,j,k,4)*(this%dzi*(this%V(i,j,k)-this%V(i,j,k-1))+this%dyi*(this%W(i,j,k)-this%W(i,j-1,k))) + FQx(i,j,k,5)=0.25_WP*sum(this%VISC(i-1:i,j,k-1:k))*(this%dxi*(this%W(i,j,k)-this%W(i-1,j,k))+this%dzi*(this%U(i,j,k)-this%U(i,j,k-1))); FQz(i,j,k,3)=FQx(i,j,k,5) + FQy(i,j,k,2)=FQx(i,j,k,5)*(this%dxi*(this%W(i,j,k)-this%W(i-1,j,k))+this%dzi*(this%U(i,j,k)-this%U(i,j,k-1))) + end do + end do + end do + + ! Assemble time derivative for conserved variables + do k=this%cfg%kmin_,this%cfg%kmax_ + do j=this%cfg%jmin_,this%cfg%jmax_ + do i=this%cfg%imin_,this%cfg%imax_ + ! Viscous momentum transport + dQdt(i,j,k,3)=dQdt(i,j,k,3)+this%dxi*(FQx(i ,j,k,3)-FQx(i-1,j,k,3))+this%dyi*(FQy(i,j+1,k,3)-FQy(i,j ,k,3))+this%dzi*(FQz(i,j,k+1,3)-FQz(i,j,k ,3)) + dQdt(i,j,k,4)=dQdt(i,j,k,4)+this%dxi*(FQx(i+1,j,k,4)-FQx(i ,j,k,4))+this%dyi*(FQy(i,j ,k,4)-FQy(i,j-1,k,4))+this%dzi*(FQz(i,j,k+1,4)-FQz(i,j,k ,4)) + dQdt(i,j,k,5)=dQdt(i,j,k,5)+this%dxi*(FQx(i+1,j,k,5)-FQx(i ,j,k,5))+this%dyi*(FQy(i,j+1,k,5)-FQy(i,j ,k,5))+this%dzi*(FQz(i,j,k ,5)-FQz(i,j,k-1,5)) + ! Viscous heating term + dQdt(i,j,k,2)=dQdt(i,j,k,2)+FQx(i,j,k,3)*this%dxi*(this%U(i+1,j,k)-this%U(i,j,k))+FQy(i,j,k,4)*this%dyi*(this%V(i,j+1,k)-this%V(i,j,k))+FQz(i,j,k,5)*this%dzi*(this%W(i,j,k+1)-this%W(i,j,k))+0.25_WP*sum(FQz(i:i+1,j:j+1,k,2))+0.25_WP*sum(FQx(i,j:j+1,k:k+1,2))+0.25_WP*sum(FQy(i:i+1,j,k:k+1,2)) + end do + end do + end do + + ! Deallocate flux arrays + deallocate(FQx,FQy,FQz) + + ! Synchronize all dQdt fields + do n=1,this%nQ; call this%cfg%sync(dQdt(:,:,:,n)); end do + + ! Stop rhs timer + call this%trhs%stop() + + contains + !> WENO switch function + real(WP) function weno_weight(ratio) + implicit none + real(WP), intent(in) :: ratio + real(WP), parameter :: lambda=0.13_WP ! Switching parameter + real(WP), parameter :: delta=0.01_WP ! Switching thickness + weno_weight=(1.0_WP-tanh((ratio-lambda)/delta))/3.0_WP+(1.0_WP-tanh((ratio-1.0_WP/lambda)/delta))/6.0_WP + end function weno_weight + end subroutine rhs + + + !> Calculate divergence of stress for LPT solver + subroutine get_div_stress(this,divx,divy,divz) + implicit none + class(spcomp), intent(inout) :: this + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(out) :: divx !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(out) :: divy !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(out) :: divz !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + real(WP), dimension(:,:,:,:), allocatable :: FQx,FQy,FQz + integer :: i,j,k + real(WP) :: div + + ! Zero out divergence of stresses + divx=0.0_WP + divy=0.0_WP + divz=0.0_WP + + ! Allocate fluxes of conserved variables + allocate(FQx(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_,1:3)); FQx=0.0_WP + allocate(FQy(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_,1:3)); FQy=0.0_WP + allocate(FQz(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_,1:3)); FQz=0.0_WP + + ! Compute cell-centered momentum fluxes + do k=this%cfg%kmin_-1,this%cfg%kmax_ + do j=this%cfg%jmin_-1,this%cfg%jmax_ + do i=this%cfg%imin_-1,this%cfg%imax_ + div=this%dxi*(this%U(i+1,j,k)-this%U(i,j,k))+this%dyi*(this%V(i,j+1,k)-this%V(i,j,k))+this%dzi*(this%W(i,j,k+1)-this%W(i,j,k)) + FQx(i,j,k,1)=2.0_WP*this%VISC(i,j,k)*this%dxi*(this%U(i+1,j,k)-this%U(i,j,k))+(this%BETA(i,j,k)-2.0_WP*this%VISC(i,j,k)/3.0_WP)*div-this%P(i,j,k) + FQy(i,j,k,2)=2.0_WP*this%VISC(i,j,k)*this%dyi*(this%V(i,j+1,k)-this%V(i,j,k))+(this%BETA(i,j,k)-2.0_WP*this%VISC(i,j,k)/3.0_WP)*div-this%P(i,j,k) + FQz(i,j,k,3)=2.0_WP*this%VISC(i,j,k)*this%dzi*(this%W(i,j,k+1)-this%W(i,j,k))+(this%BETA(i,j,k)-2.0_WP*this%VISC(i,j,k)/3.0_WP)*div-this%P(i,j,k) + end do + end do + end do + + ! Compute edge-centered momentum viscous fluxes and corresponding viscous heating + do k=this%cfg%kmin_,this%cfg%kmax_+1 + do j=this%cfg%jmin_,this%cfg%jmax_+1 + do i=this%cfg%imin_,this%cfg%imax_+1 + ! Momentum fluxes + FQy(i,j,k,1)=0.25_WP*sum(this%VISC(i-1:i,j-1:j,k))*(this%dyi*(this%U(i,j,k)-this%U(i,j-1,k))+this%dxi*(this%V(i,j,k)-this%V(i-1,j,k))); FQx(i,j,k,2)=FQy(i,j,k,1) + FQz(i,j,k,2)=0.25_WP*sum(this%VISC(i,j-1:j,k-1:k))*(this%dzi*(this%V(i,j,k)-this%V(i,j,k-1))+this%dyi*(this%W(i,j,k)-this%W(i,j-1,k))); FQy(i,j,k,3)=FQz(i,j,k,2) + FQx(i,j,k,3)=0.25_WP*sum(this%VISC(i-1:i,j,k-1:k))*(this%dxi*(this%W(i,j,k)-this%W(i-1,j,k))+this%dzi*(this%U(i,j,k)-this%U(i,j,k-1))); FQz(i,j,k,1)=FQx(i,j,k,3) + end do + end do + end do + + do i=1,3 + call this%cfg%sync(FQx(:,:,:,i)) + call this%cfg%sync(FQy(:,:,:,i)) + call this%cfg%sync(FQz(:,:,:,i)) + end do + + ! Assemble time derivative for conserved variables + do k=this%cfg%kmin_,this%cfg%kmax_ + do j=this%cfg%jmin_,this%cfg%jmax_ + do i=this%cfg%imin_,this%cfg%imax_ + ! Viscous momentum transport + divx(i,j,k)=this%dxi*(FQx(i ,j,k,1)-FQx(i-1,j,k,1))+this%dyi*(FQy(i,j+1,k,1)-FQy(i,j ,k,1))+this%dzi*(FQz(i,j,k+1,1)-FQz(i,j,k ,1)) + divy(i,j,k)=this%dxi*(FQx(i+1,j,k,2)-FQx(i ,j,k,2))+this%dyi*(FQy(i,j ,k,2)-FQy(i,j-1,k,2))+this%dzi*(FQz(i,j,k+1,2)-FQz(i,j,k ,2)) + divz(i,j,k)=this%dxi*(FQx(i+1,j,k,3)-FQx(i ,j,k,3))+this%dyi*(FQy(i,j+1,k,3)-FQy(i,j ,k,3))+this%dzi*(FQz(i,j,k ,3)-FQz(i,j,k-1,3)) + end do + end do + end do + + ! Deallocate flux arrays + deallocate(FQx,FQy,FQz) + + ! Synchronize + call this%cfg%sync(divx) + call this%cfg%sync(divy) + call this%cfg%sync(divz) + + end subroutine get_div_stress + + + !> Calculate all primitive variables from updated conserved variables + subroutine get_primitive(this) + implicit none + class(spcomp), intent(inout) :: this + integer :: i,j,k + ! Get velocity + call this%get_velocity() + ! Get primitive variables + do k=this%cfg%kmino_,this%cfg%kmaxo_; do j=this%cfg%jmino_,this%cfg%jmaxo_; do i=this%cfg%imino_,this%cfg%imaxo_ + this%I(i,j,k)=this%Q(i,j,k,2)/this%Q(i,j,k,1) + this%P(i,j,k)=this%getP(this%Q(i,j,k,1),this%I(i,j,k)) + this%C(i,j,k)=this%getC(this%Q(i,j,k,1),this%P(i,j,k)) + end do; end do; end do + ! Get temperature + if (associated(this%getT)) then + do k=this%cfg%kmino_,this%cfg%kmaxo_; do j=this%cfg%jmino_,this%cfg%jmaxo_; do i=this%cfg%imino_,this%cfg%imaxo_ + this%T(i,j,k)=this%getT(this%Q(i,j,k,1),this%P(i,j,k)) + end do; end do; end do + end if + end subroutine get_primitive + + + !> Calculate velocity from momentum and density + subroutine get_velocity(this) + implicit none + class(spcomp), intent(inout) :: this + integer :: i,j,k + ! Calculate velocity as far as possible + do k=this%cfg%kmino_+1,this%cfg%kmaxo_ + do j=this%cfg%jmino_+1,this%cfg%jmaxo_ + do i=this%cfg%imino_+1,this%cfg%imaxo_ + this%U(i,j,k)=2.0_WP*this%Q(i,j,k,3)/sum(this%Q(i-1:i,j,k,1)) + this%V(i,j,k)=2.0_WP*this%Q(i,j,k,4)/sum(this%Q(i,j-1:j,k,1)) + this%W(i,j,k)=2.0_WP*this%Q(i,j,k,5)/sum(this%Q(i,j,k-1:k,1)) + end do + end do + end do + ! Sync velocity + call this%cfg%sync(this%U) + call this%cfg%sync(this%V) + call this%cfg%sync(this%W) + ! Add last layer in each direction + if (.not.this%cfg%xper.and.this%cfg%iproc.eq.1) then + this%U(this%cfg%imino,:,:)=this%Q(this%cfg%imino,:,:,3)/(this%Q(this%cfg%imino,:,:,1)) + this%V(this%cfg%imino,:,:)=this%Q(this%cfg%imino,:,:,4)/(this%Q(this%cfg%imino,:,:,1)) + this%W(this%cfg%imino,:,:)=this%Q(this%cfg%imino,:,:,5)/(this%Q(this%cfg%imino,:,:,1)) + end if + if (.not.this%cfg%yper.and.this%cfg%jproc.eq.1) then + this%U(:,this%cfg%jmino,:)=this%Q(:,this%cfg%jmino,:,3)/(this%Q(:,this%cfg%jmino,:,1)) + this%V(:,this%cfg%jmino,:)=this%Q(:,this%cfg%jmino,:,4)/(this%Q(:,this%cfg%jmino,:,1)) + this%W(:,this%cfg%jmino,:)=this%Q(:,this%cfg%jmino,:,5)/(this%Q(:,this%cfg%jmino,:,1)) + end if + if (.not.this%cfg%zper.and.this%cfg%kproc.eq.1) then + this%U(:,:,this%cfg%kmino)=this%Q(:,:,this%cfg%kmino,3)/(this%Q(:,:,this%cfg%kmino,1)) + this%V(:,:,this%cfg%kmino)=this%Q(:,:,this%cfg%kmino,4)/(this%Q(:,:,this%cfg%kmino,1)) + this%W(:,:,this%cfg%kmino)=this%Q(:,:,this%cfg%kmino,5)/(this%Q(:,:,this%cfg%kmino,1)) + end if + end subroutine get_velocity + + + !> Calculate kinetic energy per unit mass from pre-calculated velocity + !> Need to redo this better + subroutine get_ke(this,KE) + implicit none + class(spcomp), intent(inout) :: this + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(out) :: KE !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + integer :: i,j,k + do k=this%cfg%kmino_,this%cfg%kmaxo_-1 + do j=this%cfg%jmino_,this%cfg%jmaxo_-1 + do i=this%cfg%imino_,this%cfg%imaxo_-1 + KE(i,j,k)=0.5_WP*sum(this%U(i:i+1,j,k)**2+this%V(i,j:j+1,k)**2+this%W(i,j,k:k+1)**2) + end do + end do + end do + call this%cfg%sync(KE) + if (.not.this%cfg%xper.and.this%cfg%iproc.eq.this%cfg%npx) KE(this%cfg%imaxo,:,:)=KE(this%cfg%imaxo-1,:,:) + if (.not.this%cfg%yper.and.this%cfg%jproc.eq.this%cfg%npy) KE(:,this%cfg%jmaxo,:)=KE(:,this%cfg%jmaxo-1,:) + if (.not.this%cfg%zper.and.this%cfg%kproc.eq.this%cfg%npz) KE(:,:,this%cfg%kmaxo)=KE(:,:,this%cfg%kmaxo-1) + end subroutine get_ke + + + !> Calculate momentum from velocity and density + subroutine get_momentum(this) + implicit none + class(spcomp), intent(inout) :: this + integer :: i,j,k + ! Calculate momentum as far as possible + do k=this%cfg%kmino_+1,this%cfg%kmaxo_ + do j=this%cfg%jmino_+1,this%cfg%jmaxo_ + do i=this%cfg%imino_+1,this%cfg%imaxo_ + this%Q(i,j,k,3)=0.5_WP*sum(this%Q(i-1:i,j,k,1))*this%U(i,j,k) + this%Q(i,j,k,4)=0.5_WP*sum(this%Q(i,j-1:j,k,1))*this%V(i,j,k) + this%Q(i,j,k,5)=0.5_WP*sum(this%Q(i,j,k-1:k,1))*this%W(i,j,k) + end do + end do + end do + ! Sync momentum + call this%cfg%sync(this%Q(:,:,:,3)) + call this%cfg%sync(this%Q(:,:,:,4)) + call this%cfg%sync(this%Q(:,:,:,5)) + ! Add last layer in each direction + if (.not.this%cfg%xper.and.this%cfg%iproc.eq.1) then + this%Q(this%cfg%imino,:,:,3)=this%Q(this%cfg%imino,:,:,1)*this%U(this%cfg%imino,:,:) + this%Q(this%cfg%imino,:,:,4)=this%Q(this%cfg%imino,:,:,1)*this%V(this%cfg%imino,:,:) + this%Q(this%cfg%imino,:,:,5)=this%Q(this%cfg%imino,:,:,1)*this%W(this%cfg%imino,:,:) + end if + if (.not.this%cfg%yper.and.this%cfg%jproc.eq.1) then + this%Q(:,this%cfg%jmino,:,3)=this%Q(:,this%cfg%jmino,:,1)*this%U(:,this%cfg%jmino,:) + this%Q(:,this%cfg%jmino,:,4)=this%Q(:,this%cfg%jmino,:,1)*this%V(:,this%cfg%jmino,:) + this%Q(:,this%cfg%jmino,:,5)=this%Q(:,this%cfg%jmino,:,1)*this%W(:,this%cfg%jmino,:) + end if + if (.not.this%cfg%zper.and.this%cfg%kproc.eq.1) then + this%Q(:,:,this%cfg%kmino,3)=this%Q(:,:,this%cfg%kmino,1)*this%U(:,:,this%cfg%kmino) + this%Q(:,:,this%cfg%kmino,4)=this%Q(:,:,this%cfg%kmino,1)*this%V(:,:,this%cfg%kmino) + this%Q(:,:,this%cfg%kmino,5)=this%Q(:,:,this%cfg%kmino,1)*this%W(:,:,this%cfg%kmino) + end if + end subroutine get_momentum + + + !> Interpolate velocity to cell-center, including overlap and ghosts + subroutine interp_vel(this,Ui,Vi,Wi) + implicit none + class(spcomp), intent(inout) :: this + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(out) :: Ui !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(out) :: Vi !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(out) :: Wi !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + integer :: i,j,k + ! Calculate interpolated velocity as far as possible + do k=this%cfg%kmino_,this%cfg%kmaxo_-1 + do j=this%cfg%jmino_,this%cfg%jmaxo_-1 + do i=this%cfg%imino_,this%cfg%imaxo_-1 + Ui(i,j,k)=0.5_WP*sum(this%U(i:i+1,j,k)) + Vi(i,j,k)=0.5_WP*sum(this%V(i,j:j+1,k)) + Wi(i,j,k)=0.5_WP*sum(this%W(i,j,k:k+1)) + end do + end do + end do + ! Sync interpolated velocity + call this%cfg%sync(Ui) + call this%cfg%sync(Vi) + call this%cfg%sync(Wi) + ! Add last layer in each direction + if (.not.this%cfg%xper.and.this%cfg%iproc.eq.this%cfg%npx) then + Ui(this%cfg%imaxo,:,:)=this%U(this%cfg%imaxo,:,:) + Vi(this%cfg%imaxo,:,:)=this%V(this%cfg%imaxo,:,:) + Wi(this%cfg%imaxo,:,:)=this%W(this%cfg%imaxo,:,:) + end if + if (.not.this%cfg%yper.and.this%cfg%jproc.eq.this%cfg%npy) then + Ui(:,this%cfg%jmaxo,:)=this%U(:,this%cfg%jmaxo,:) + Vi(:,this%cfg%jmaxo,:)=this%V(:,this%cfg%jmaxo,:) + Wi(:,this%cfg%jmaxo,:)=this%W(:,this%cfg%jmaxo,:) + end if + if (.not.this%cfg%zper.and.this%cfg%kproc.eq.this%cfg%npz) then + Ui(:,:,this%cfg%kmaxo)=this%U(:,:,this%cfg%kmaxo) + Vi(:,:,this%cfg%kmaxo)=this%V(:,:,this%cfg%kmaxo) + Wi(:,:,this%cfg%kmaxo)=this%W(:,:,this%cfg%kmaxo) + end if + end subroutine interp_vel + + + !> Get artifical bulk kinematic viscosity + subroutine get_viscartif(this,dt,beta) + implicit none + class(spcomp), intent(inout) :: this + real(WP), intent(in) :: dt + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(out) :: beta + integer :: i,j,k,si,sj,sk,n + integer, parameter :: nfilter=1 + real(WP) :: max_beta,dudy,dudz,dvdx,dvdz,dwdx,dwdy,vort,grad_div,H + real(WP), parameter :: max_cfl=0.5_WP + real(WP), parameter :: Cartif=2.0_WP + real(WP), parameter :: Cartif_vort=100.0_WP + real(WP), dimension(:,:,:), allocatable :: div + real(WP), dimension(-1:+1), parameter :: filter=[1.0_WP/6.0_WP,2.0_WP/3.0_WP,1.0_WP/6.0_WP] + ! Calculate max beta permissible + max_beta=max_cfl*min(this%dx**2,this%dy**2,this%dz**2)/(4.0_WP*dt) + ! Zero out array + beta=0.0_WP + ! Compute velocity divergence + allocate(div(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + do k=this%cfg%kmino_,this%cfg%kmaxo_-1; do j=this%cfg%jmino_,this%cfg%jmaxo_-1; do i=this%cfg%imino_,this%cfg%imaxo_-1 + div(i,j,k)=this%dxi*(this%U(i+1,j,k)-this%U(i,j,k))+this%dyi*(this%V(i,j+1,k)-this%V(i,j,k))+this%dzi*(this%W(i,j,k+1)-this%W(i,j,k)) + end do; end do; end do + call this%cfg%sync(div) + if (.not.this%cfg%xper.and.this%cfg%iproc.eq.this%cfg%npx) div(this%cfg%imaxo,:,:)=div(this%cfg%imaxo-1,:,:) + if (.not.this%cfg%yper.and.this%cfg%jproc.eq.this%cfg%npy) div(:,this%cfg%jmaxo,:)=div(:,this%cfg%jmaxo-1,:) + if (.not.this%cfg%zper.and.this%cfg%kproc.eq.this%cfg%npz) div(:,:,this%cfg%kmaxo)=div(:,:,this%cfg%kmaxo-1) + ! Compute artificial bulk viscosity based on gradU provided + do k=this%cfg%kmin_,this%cfg%kmax_; do j=this%cfg%jmin_,this%cfg%jmax_; do i=this%cfg%imin_,this%cfg%imax_ + ! Only work in compression regions + if (div(i,j,k).ge.0.0_WP) cycle + ! Compute local vorticity + dudy=0.25_WP*this%dyi*sum(this%U(i:i+1,j:j+1,k)-this%U(i:i+1,j-1:j,k)) + dudz=0.25_WP*this%dzi*sum(this%U(i:i+1,j,k:k+1)-this%U(i:i+1,j,k-1:k)) + dvdx=0.25_WP*this%dxi*sum(this%V(i:i+1,j:j+1,k)-this%V(i-1:i,j:j+1,k)) + dvdz=0.25_WP*this%dzi*sum(this%V(i,j:j+1,k:k+1)-this%V(i,j:j+1,k-1:k)) + dwdx=0.25_WP*this%dxi*sum(this%W(i:i+1,j,k:k+1)-this%W(i-1:i,j,k:k+1)) + dwdy=0.25_WP*this%dyi*sum(this%W(i,j:j+1,k:k+1)-this%W(i,j-1:j,k:k+1)) + vort=(dwdy-dvdz)**2+(dudz-dwdx)**2+(dvdx-dudy)**2 + ! Compute |grad(div)| + grad_div=max(abs(div(i+1,j,k)-div(i,j,k)),abs(div(i,j,k)-div(i-1,j,k)))*this%dx**2& + & +max(abs(div(i,j+1,k)-div(i,j,k)),abs(div(i,j,k)-div(i,j-1,k)))*this%dy**2& + & +max(abs(div(i,j,k+1)-div(i,j,k)),abs(div(i,j,k)-div(i,j,k-1)))*this%dz**2 + ! Estimate artificial kinematic viscosity using grad(div) + !beta(i,j,k)=Cartif*grad_div*div(i,j,k)**2/(div(i,j,k)**2+Cartif_vort*vort+1.0e-15_WP) + + ! Sensor originally proposed by Ducros et al. (1999) and later improved by + ! Hendrickson, T. R., Kartha, A., & Candler, G. V. (2018) + vort=max(vort,(0.05_WP*this%C(i,j,k)/min(this%dx,this%dy))**2) + beta(i,j,k)=Cartif*grad_div*min(4.0_WP/3.0_WP*div(i,j,k)**2/(div(i,j,k)**2+vort+epsilon(1.0_WP)),1.0_WP) + ! Clip it so CFL Get kinematic eddy viscosity using Vreman's model + subroutine get_vreman(this,dt,visc) + implicit none + class(spcomp), intent(inout) :: this + real(WP), intent(in) :: dt + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(out) :: visc + real(WP), parameter :: Cs_ref=0.17_WP + real(WP), parameter :: max_cfl=0.5_WP + real(WP) :: max_visc,A,B,C + real(WP), dimension(1:3,1:3) :: beta,gradU + real(WP), dimension(:,:,:), allocatable :: tmp + real(WP), dimension(-1:+1), parameter :: filter=[1.0_WP/6.0_WP,2.0_WP/3.0_WP,1.0_WP/6.0_WP] + integer :: i,j,k,si,sj,sk,n + integer, parameter :: nfilter=1 + ! Model constant is c=2.5*Cs_ref**2 - Vreman uses c=0.07 which corresponds to Cs_ref=0.17 + C=2.5_WP*Cs_ref**2 + ! Calculate max visc permissible + max_visc=max_cfl*min(this%dx**2,this%dy**2,this%dz**2)/(4.0_WP*dt) + ! Zero out array + visc=0.0_WP + ! Compute the eddy viscosity + do k=this%cfg%kmin_,this%cfg%kmax_; do j=this%cfg%jmin_,this%cfg%jmax_; do i=this%cfg%imin_,this%cfg%imax_ + ! Compute velocity gradient tensor + gradU(1,1)=this%dxi*(this%U(i+1,j,k)-this%U(i,j,k)) + gradU(2,1)=0.25_WP*this%dyi*sum(this%U(i:i+1,j:j+1,k)-this%U(i:i+1,j-1:j,k)) + gradU(3,1)=0.25_WP*this%dzi*sum(this%U(i:i+1,j,k:k+1)-this%U(i:i+1,j,k-1:k)) + gradU(1,2)=0.25_WP*this%dxi*sum(this%V(i:i+1,j:j+1,k)-this%V(i-1:i,j:j+1,k)) + gradU(2,2)=this%dyi*(this%V(i,j+1,k)-this%V(i,j,k)) + gradU(3,2)=0.25_WP*this%dzi*sum(this%V(i,j:j+1,k:k+1)-this%V(i,j:j+1,k-1:k)) + gradU(1,3)=0.25_WP*this%dxi*sum(this%W(i:i+1,j,k:k+1)-this%W(i-1:i,j,k:k+1)) + gradU(2,3)=0.25_WP*this%dyi*sum(this%W(i,j:j+1,k:k+1)-this%W(i,j-1:j,k:k+1)) + gradU(3,3)=this%dzi*(this%W(i,j,k+1)-this%W(i,j,k)) + ! Compute A=gradu_ij*gradu_ij invariant + A=sum(gradU**2) + ! Compute beta_ij=dx_m*dx_m*gradu_mi*gradu_mj + do sj=1,3; do si=1,3; beta(si,sj)=this%dx**2*gradU(1,si)*gradU(1,sj)+this%dy**2*gradU(2,si)*gradU(2,sj)+this%dz**2*gradU(3,si)*gradU(3,sj); end do; end do + ! Compute B invariant + B=beta(1,1)*beta(2,2)-beta(1,2)**2+beta(1,1)*beta(3,3)-beta(1,3)**2+beta(2,2)*beta(3,3)-beta(2,3)**2 + ! Assemble algebraic eddy viscosity model + if (B.lt.1.0e-8_WP) then + visc(i,j,k)=0.0_WP + else + visc(i,j,k)=C*sqrt(B/A) + end if + ! Clip it so CFL Calculate the CFL + subroutine get_cfl(this,dt,cfl) + use mpi_f08, only: MPI_ALLREDUCE,MPI_MAX,MPI_IN_PLACE + use parallel, only: MPI_REAL_WP + implicit none + class(spcomp), intent(inout) :: this + real(WP), intent(in) :: dt + real(WP), intent(out) :: cfl + integer :: ierr + real(WP) :: maxvisc,maxC + ! Compute convective+acoustic CFLs + this%CFLc_x=maxval(abs(this%U)+abs(this%C))*dt*this%dxi; call MPI_ALLREDUCE(MPI_IN_PLACE,this%CFLc_x,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + this%CFLc_y=maxval(abs(this%V)+abs(this%C))*dt*this%dyi; call MPI_ALLREDUCE(MPI_IN_PLACE,this%CFLc_y,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + this%CFLc_z=maxval(abs(this%W)+abs(this%C))*dt*this%dzi; call MPI_ALLREDUCE(MPI_IN_PLACE,this%CFLc_z,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + ! Compute acoustic CFLs + maxC=maxval(this%C); call MPI_ALLREDUCE(MPI_IN_PLACE,maxC,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + this%CFLa_x=maxC*dt*this%dxi + this%CFLa_y=maxC*dt*this%dyi + this%CFLa_z=maxC*dt*this%dzi + ! Compute viscous CFLs + maxvisc=maxval((this%VISC+this%BETA)/this%Q(:,:,:,1)); call MPI_ALLREDUCE(MPI_IN_PLACE,maxvisc,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + this%CFLv_x=4.0_WP*maxvisc*dt*this%dxi**2 + this%CFLv_y=4.0_WP*maxvisc*dt*this%dyi**2 + this%CFLv_z=4.0_WP*maxvisc*dt*this%dzi**2 + ! Return the maximum overall CFL + cfl=max(this%CFLc_x,this%CFLc_y,this%CFLc_z,& + & this%CFLa_x,this%CFLa_y,this%CFLa_z,& + & this%CFLv_x,this%CFLv_y,this%CFLv_z) + end subroutine get_cfl + + + !> Calculate info about our fields + subroutine get_info(this) + use mpi_f08, only: MPI_ALLREDUCE,MPI_MIN,MPI_MAX,MPI_IN_PLACE + use parallel, only: MPI_REAL_WP + implicit none + class(spcomp), intent(inout) :: this + integer :: n,i,j,k,ierr + real(WP), dimension(:,:,:), allocatable :: tmp + + ! Compute integrals and extrema of conserved variables + do n=1,this%nQ + call this%cfg%integrate(this%Q(:,:,:,n),integral=this%Qint(n)) + end do + this%Qmin=+huge(1.0_WP) + this%Qmax=-huge(1.0_WP) + do k=this%cfg%kmin_,this%cfg%kmax_; do j=this%cfg%jmin_,this%cfg%jmax_; do i=this%cfg%imin_,this%cfg%imax_ + do n=1,this%nQ + this%Qmin(n)=min(this%Qmin(n),this%Q(i,j,k,n)) + this%Qmax(n)=max(this%Qmax(n),this%Q(i,j,k,n)) + end do + end do; end do; end do + call MPI_ALLREDUCE(MPI_IN_PLACE,this%Qmin,this%nQ,MPI_REAL_WP,MPI_MIN,this%cfg%comm,ierr) + call MPI_ALLREDUCE(MPI_IN_PLACE,this%Qmax,this%nQ,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + + ! Also compute integral of KE and entropy + allocate(tmp(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + call this%get_ke(tmp); tmp=this%Q(:,:,:,1)*tmp; call this%cfg%integrate(tmp,integral=this%RHOKint) + this%RHOSint=0.0_WP + if (associated(this%getS)) then + do k=this%cfg%kmin_,this%cfg%kmax_; do j=this%cfg%jmin_,this%cfg%jmax_; do i=this%cfg%imin_,this%cfg%imax_ + tmp(i,j,k)=this%Q(i,j,k,1)*this%getS(this%Q(i,j,k,1),this%P(i,j,k)) + end do; end do; end do + call this%cfg%integrate(tmp,integral=this%RHOSint) + end if + deallocate(tmp) + + ! Calculate extrema of primitive fields + this%RHOmin=+huge(1.0_WP); this%RHOmax=-huge(1.0_WP) + this%Imin =+huge(1.0_WP); this%Imax =-huge(1.0_WP) + this%Pmin =+huge(1.0_WP); this%Pmax =-huge(1.0_WP) + this%Tmin =+huge(1.0_WP); this%Tmax =-huge(1.0_WP) + this%Umax=0.0_WP; this%Vmax=0.0_WP; this%Wmax=0.0_WP + do k=this%cfg%kmin_,this%cfg%kmax_; do j=this%cfg%jmin_,this%cfg%jmax_; do i=this%cfg%imin_,this%cfg%imax_ + this%RHOmin=min(this%RHOmin,this%Q(i,j,k,1)); this%RHOmax=max(this%RHOmax,this%Q(i,j,k,1)) + this%Imin =min(this%Imin ,this%I (i,j,k)); this%Imax =max(this%Imax ,this%I (i,j,k)) + this%Pmin =min(this%Pmin ,this%P (i,j,k)); this%Pmax =max(this%Pmax ,this%P (i,j,k)) + this%Tmin =min(this%Tmin ,this%T (i,j,k)); this%Tmax =max(this%Tmax ,this%T (i,j,k)) + this%Umax=max(this%Umax,abs(this%U(i,j,k))) + this%Vmax=max(this%Vmax,abs(this%V(i,j,k))) + this%Wmax=max(this%Wmax,abs(this%W(i,j,k))) + end do; end do; end do + call MPI_ALLREDUCE(MPI_IN_PLACE,this%RHOmin,1,MPI_REAL_WP,MPI_MIN,this%cfg%comm,ierr) + call MPI_ALLREDUCE(MPI_IN_PLACE,this%RHOmax,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + call MPI_ALLREDUCE(MPI_IN_PLACE,this%Imin ,1,MPI_REAL_WP,MPI_MIN,this%cfg%comm,ierr) + call MPI_ALLREDUCE(MPI_IN_PLACE,this%Imax ,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + call MPI_ALLREDUCE(MPI_IN_PLACE,this%Pmin ,1,MPI_REAL_WP,MPI_MIN,this%cfg%comm,ierr) + call MPI_ALLREDUCE(MPI_IN_PLACE,this%Pmax ,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + call MPI_ALLREDUCE(MPI_IN_PLACE,this%Tmin ,1,MPI_REAL_WP,MPI_MIN,this%cfg%comm,ierr) + call MPI_ALLREDUCE(MPI_IN_PLACE,this%Tmax ,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + call MPI_ALLREDUCE(MPI_IN_PLACE,this%Umax ,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + call MPI_ALLREDUCE(MPI_IN_PLACE,this%Vmax ,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + call MPI_ALLREDUCE(MPI_IN_PLACE,this%Wmax ,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + + end subroutine get_info + + + !> Print out info for spcomp flow solver + subroutine spcomp_print(this) + use, intrinsic :: iso_fortran_env, only: output_unit + implicit none + class(spcomp), intent(in) :: this + if (this%cfg%amRoot) write(output_unit,'("spcomp solver [",a,"] for config [",a,"]")') trim(this%name),trim(this%cfg%name) + end subroutine spcomp_print + + + !> Finalize spcomp flow solver + subroutine finalize(this) + implicit none + class(spcomp), intent(inout) :: this + nullify(this%cfg) + this%name='UNNAMED_SPCOMP' + nullify(this%getP) + nullify(this%getT) + nullify(this%getC) + nullify(this%getS) + this%nQ=0 + if (allocated(this%Q)) deallocate(this%Q) + if (allocated(this%Qold)) deallocate(this%Qold) + if (allocated(this%U)) deallocate(this%U) + if (allocated(this%V)) deallocate(this%V) + if (allocated(this%W)) deallocate(this%W) + if (allocated(this%I)) deallocate(this%I) + if (allocated(this%P)) deallocate(this%P) + if (allocated(this%T)) deallocate(this%T) + if (allocated(this%C)) deallocate(this%C) + if (allocated(this%VISC)) deallocate(this%VISC) + if (allocated(this%BETA)) deallocate(this%BETA) + if (allocated(this%DIFF)) deallocate(this%DIFF) + if (allocated(this%Qmin)) deallocate(this%Qmin) + if (allocated(this%Qmax)) deallocate(this%Qmax) + if (allocated(this%Qint)) deallocate(this%Qint) + call this%trhs%finalize() + end subroutine finalize + + +end module spcomp_class diff --git a/examples/NOSB_cylinder_peridigm/GNUmakefile b/examples/NOSB_cylinder_peridigm/GNUmakefile new file mode 100644 index 000000000..23c4d3dba --- /dev/null +++ b/examples/NOSB_cylinder_peridigm/GNUmakefile @@ -0,0 +1,49 @@ +# NGA location if not yet defined +NGA_HOME ?= ~/nga2/Repositories/nga2 + +# Compilation parameters +PRECISION = DOUBLE +USE_MPI = TRUE +USE_HYPRE = TRUE +USE_LAPACK= TRUE +USE_FFTW = TRUE +USE_IRL = FALSE +PROFILE = FALSE +DEBUG = FALSE +COMP = gnu +EXEBASE = nga + +# Directories that contain user-defined code +Udirs := src + +# Include user-defined sources +Upack += $(foreach dir, $(Udirs), $(wildcard $(dir)/Make.package)) +Ulocs += $(foreach dir, $(Udirs), $(wildcard $(dir))) +include $(Upack) +INCLUDE_LOCATIONS += $(Ulocs) +VPATH_LOCATIONS += $(Ulocs) + +# External libraries are defined in .profile/.bashrc/.zshrc, but could be defined here as well +HYPRE_DIR=/Users/imauser/nga2/Repositories/hypre/src/hypre +FFTW_DIR=/opt/homebrew/Cellar/fftw/3.3.10_2 + +# NGA compilation definitions +include $(NGA_HOME)/tools/GNUMake/Make.defs + +# Include NGA base code +Bdirs := constant_density particles core data transform solver config grid libraries +Bpack += $(foreach dir, $(Bdirs), $(NGA_HOME)/src/$(dir)/Make.package) +include $(Bpack) + +# Inform user of Make.packages used +ifdef Ulocs + $(info Taking user code from: $(Ulocs)) +endif +$(info Taking base code from: $(Bdirs)) + +# Target definition +all: $(executable) + @echo COMPILATION SUCCESSFUL + +# NGA compilation rules +include $(NGA_HOME)/tools/GNUMake/Make.rules diff --git a/examples/NOSB_cylinder_peridigm/README b/examples/NOSB_cylinder_peridigm/README new file mode 100644 index 000000000..a82a2a789 --- /dev/null +++ b/examples/NOSB_cylinder_peridigm/README @@ -0,0 +1,3 @@ +(6/30/26 8:09 PM: +Switched it over to RK4, was RK2. +Have previously run with element.bin files, probably should change this over to be using a uniform grid. diff --git a/examples/NOSB_cylinder_peridigm/input b/examples/NOSB_cylinder_peridigm/input new file mode 100644 index 000000000..c66086596 --- /dev/null +++ b/examples/NOSB_cylinder_peridigm/input @@ -0,0 +1,40 @@ +# Parallelization +Partition : 8 1 1 + +# Mesh definition +R : 0.5 +N_r : 20 +X- ratio : 4 +X+ ratio : 10 +Y ratio : 4 +Z ratio : 0 +# Case definition + +Bar length : 0.35 +Bar width : 0.02 +Inlet velocity : 1.0 + +# Solid properties +# Solid Spacing = 0.00165 +Elastic modulus : 1e9 +# Poisson Ratio : 0.4 +Material density : 1 +Critical Energy Release Rate : 1000000 +# Solid Damping Constant : 0.05 +# Tau : 5.0e-4 +# Fluid properties +Dynamic viscosity : 0.001 +Density : 1 + +# Time integration +Max timestep size : 5e-7 +Max cfl number : 0.9 +Max time : 100 +# Unfreeze time: 5.0e-3 + +# Pressure solver +Pressure tolerance : 1e-8 +Pressure iteration : 100 + +# Ensight output +Ensight output period : 1e-6 diff --git a/examples/NOSB_cylinder_peridigm/src/Make.package b/examples/NOSB_cylinder_peridigm/src/Make.package new file mode 100644 index 000000000..b2eadf90c --- /dev/null +++ b/examples/NOSB_cylinder_peridigm/src/Make.package @@ -0,0 +1,2 @@ +# List here the extra files here +f90EXE_sources += NOSB_class.f90 OSB_class.f90 pdsolver_class.f90 pdhalo_class.f90 pdhash_class.f90 lsspd_class.f90 simulation.f90 geometry.f90 incomp_class.f90 diff --git a/examples/NOSB_cylinder_peridigm/src/NOSB_class.f90 b/examples/NOSB_cylinder_peridigm/src/NOSB_class.f90 new file mode 100644 index 000000000..382b04908 --- /dev/null +++ b/examples/NOSB_cylinder_peridigm/src/NOSB_class.f90 @@ -0,0 +1,2231 @@ +!> Peridynamics solver: node-centered, CSR-based solid dynamics on flat +!> per-field arrays with persistent graph-halo communication. GRID-FREE: +!> no AMReX anywhere -- ownership follows the reference configuration +!> (Morton partition, motion-invariant), neighborhoods and communication +!> plans are built once and reused every substep. +!> +!> Physics: linear peridynamic solid (LPS, dimension-aware coefficients, +!> influence function hard-coded in omega() with derived quantities +!> generalized through its moments), brittle stretch damage, per-side +!> viscoelastic/viscoplastic flow with J2 (Mitchell OSB) yield, soft-sphere +!> contact (walls + particle-particle via a displacement-triggered spatial +!> service), velocity-Verlet integration. +!> Checkpoint/restart is gid-space and rank-count portable, including all +!> bond damage and plastic history. +!> +!> Usage tiers (amrpd EXTENDS pdsolver -- see amrpd_class): +!> 1. pdsolver alone -- standalone solid dynamics (this module only) +!> 2. amrpd -- adds viz, mesh VF, AMR refinement, seeding +!> 3. ... + a flow solver -- two-way FSI via amrpd%exchange_solid +!> +!> Configuration style: assign the public fields (material, damage, contact), +!> then build the network (detect_families/connect/read_state) -- derived +!> quantities resolve there via derive_config, uniformly for fresh and restart. +!> +!> Layout: owned nodes 1..nown; halo slots nown+1..ntot, keyed (gid, periodic +!> image offset) with shifts applied at exchange time. Each physical bond is +!> two CSR half-entries (one per endpoint row, Peridigm convention): kernels +!> compute each row's own force state -- ghost dilatation is never +!> communicated -- and a single halo reduce assembles cross-rank pairs. +!> Kernels are pure loops over owned nodes with no mutable module-level +!> state (OpenMP-ready by construction; threads deferred). +module NOSB_class + use precision, only: WP,I8 + use string, only: str_medium + use pdhalo_class, only: pddir,pdhalo,sort3_perm,PDHALO_KEY0 + use pdhash_class, only: gid_hash + implicit none + private + + public :: pdsolver,pd_partition + public :: PDC_IS_DEAD,PDC_MOVES,PDC_INTEGRATES,PDC_BONDS + public :: PD_OPEN,PD_WALL + + ! Motion-control bit flags -- values MUST match amrpd's PART_* constants + ! (handoff copies amrpd flags verbatim) + integer, parameter :: PDC_IS_DEAD =0 + integer, parameter :: PDC_MOVES =1 + integer, parameter :: PDC_INTEGRATES=2 + integer, parameter :: PDC_BONDS =4 + + ! Domain-face BC values for lo_bc/hi_bc + integer, parameter :: PD_OPEN=0 + integer, parameter :: PD_WALL=1 + + !> Graph-core PD solver + type :: pdsolver + character(len=str_medium) :: name='UNNAMED_PDSOLVER' + + ! Sizes + integer :: nown=0 !< owned nodes on this rank + integer :: nhalo=0 !< halo slots + integer :: ntot=0 !< nown+nhalo + integer(I8) :: np=0 !< global node count (get_info) + integer(I8) :: nbond=0 !< global bond count (half-entries/2, get_info) + + ! Material / discretization + real(WP) :: rho =0.0_WP !< density + real(WP) :: elastic_modulus=0.0_WP !< Young's modulus + real(WP) :: poisson_ratio =0.0_WP !< Poisson's ratio + real(WP) :: delta =0.0_WP !< horizon + real(WP) :: dV =0.0_WP !< nominal element volume (CFL length scale; kernels use per-node V) + real(WP) :: s0 =huge(1.0_WP) !< critical bond stretch (huge = no damage) + real(WP) :: fail_stretch =huge(1.0_WP) !< direct s0 override (takes precedence over crit_energy) + real(WP) :: crit_energy =huge(1.0_WP) !< critical energy release rate G_c (-> s0 when fail_stretch unset) + real(WP) :: dtcrit =0.0_WP !< Silling-Askari critical dt (diagnostic, stamped at connect) + ! Viscoelastic / viscoplastic flow (PER-SIDE form: each half-entry evolves + ! its own e_v with its own endpoint's dilatation and yield factor -- + ! exactly Peridigm's elastic_plastic.cxx, verified term-by-term against + ! amrpd's J2 2026-07-14. This is the one INTENDED delta from amrpd, which + ! averages the endpoints into a single per-bond e_v.) + real(WP) :: tau =huge(1.0_WP) !< Maxwell deviatoric relaxation time (huge = purely elastic) + real(WP) :: visc_lambda =1.0_WP !< SLS relaxing fraction [0,1] + real(WP) :: yield_stretch =0.0_WP !< legacy per-bond Perzyna yield strain (0 = pure Maxwell) + real(WP) :: sigma_yield =0.0_WP !< J2 yield stress (Mitchell OSB family norm; overrides yield_stretch) + real(WP) :: hard_mod =0.0_WP !< linear isotropic hardening modulus H: flow stress = sigma_yield + H*lam_p (0 = perfectly plastic) + real(WP), dimension(3) :: gravity=0.0_WP !< body acceleration + logical, dimension(3) :: collapsed=.false. !< collapsed (n==1) directions: velocity locked + real(WP), dimension(3) :: Ldom=0.0_WP !< domain lengths (image shifts) + logical, dimension(3) :: per=.false. !< periodicity per direction + real(WP), dimension(3) :: dom_lo=0.0_WP !< domain lower bounds (wall contact) + real(WP), dimension(3) :: dom_hi=0.0_WP !< domain upper bounds (wall contact) + + ! Short-range soft-sphere contact (soft-sphere penalty + damping). + ! Contact is a pure SPATIAL service, fully separate from the bond graph: + ! candidates are (owned nodes + contact-halo slots) discovered by a + ! displacement-triggered broad phase; the graph halo is never binned, so + ! bonded remote partners arrive as contact slots when in range and + ! double-counting is structurally impossible. The narrow phase is + ! gather-only (each owned node accumulates from its candidates -- the + ! partner gets its share from its own row), so no force reduction. + logical :: use_contact =.false. + real(WP) :: contact_dist =0.0_WP !< d_c (p-p d_eff; wall d_eff = 0.5*d_c) + real(WP) :: tau_col =0.0_WP !< collision duration (<=0 -> auto 5*dt) + real(WP) :: e_n=0.7_WP,e_w=0.7_WP !< restitution (p-p, wall) + real(WP) :: clip_col =0.2_WP !< overlap clip fraction + integer, dimension(3) :: lo_bc=PD_OPEN,hi_bc=PD_OPEN !< per-face: PD_OPEN or PD_WALL + real(WP) :: cskin =0.0_WP !< broad-phase skin (<=0 -> auto 0.5*contact_dist) + type(pdhalo) :: chalo !< contact halo (rebuilt at trigger cadence; nown=ntot) + integer :: nchalo=0 !< contact slots (y/v extended to ntot+nchalo) + integer, allocatable :: cptr(:),clst(:) !< candidate CSR (owned rows; entries index owned+contact slots) + real(WP), allocatable :: ylast(:,:) !< (3,nown) positions at last broad-phase build + + ! Node state -- flat per-field arrays; owned first, halo slots appended. + ! (3,:) fields are xyz-interleaved per node (Fortran-natural gather layout). + integer(I8), allocatable :: gid(:) !< (ntot) global id (halo slots carry partner gid) + real(WP), allocatable :: x0(:,:) !< (3,ntot) reference position; halo PRE-SHIFTED + real(WP), allocatable :: y(:,:) !< (3,ntot) current position; halo shifted at update + real(WP), allocatable :: v(:,:) !< (3,nown) velocity + real(WP), allocatable :: f(:,:) !< (3,ntot) bond force density (halo = scatter buffer) + real(WP), allocatable :: ff(:,:) !< (3,nown) external (fluid) force density + real(WP), allocatable :: vol(:) !< (ntot) per-node volume (reference; halo slots filled at connect) + real(WP), allocatable :: mw(:) !< (nown) weighted volume (reference, set at connect) + real(WP), allocatable :: theta(:) !< (nown) dilatation (recomputed each substep) + real(WP), allocatable :: damage(:) !< (nown) accumulated damage fraction (broken/reference bonds) + real(WP), allocatable :: lam_p(:) !< (nown) accumulated equivalent plastic strain (J2 path; drives hardening, free diagnostic when hard_mod=0) + real(WP), allocatable :: alive(:) !< (ntot) 1=alive, 0=dead (exit through open face); halo-exchanged on death events only + integer, allocatable :: flag(:) !< (nown) motion-control flags + logical :: watch_exit=.false. !< exit detection active (set at connect: domain set + any open non-periodic face) + + ! CSR families (built once at connect) + integer, allocatable :: ptr(:) !< (nown+1) row offsets + integer, allocatable :: lst(:) !< neighbor index (1..ntot) per half-entry + integer(1), allocatable :: dmg(:) !< per half-entry: 0 intact, 1 broken (irreversible) + real(WP), allocatable :: e_v(:) !< per half-entry: inelastic deviatoric stretch (per-side history) + real(WP), allocatable :: td2(:),td2a(:) !< (nown) J2 family deviatoric norm^2: previous substep / accumulator. + !< Node-centered => pure own-row gather, NO communication (amrpd + !< needed sum_ghosts_td2 + ghost refresh for the same quantity). + + ! Parallel machinery + type(gid_hash) :: ohash !< gid -> owned index (built at set_nodes) + type(pddir) :: dir !< persistent gid directory (owner lookups; registered at connect/read_state) + type(pdhalo) :: halo !< persistent halo plan + real(WP), allocatable :: rextra_tmp(:,:) !< read_state scratch (restart-field overlay across assemble) + + ! Monitoring + real(WP) :: Umin=0.0_WP,Umax=0.0_WP !< signed per-component velocity extrema + real(WP) :: Vmin=0.0_WP,Vmax=0.0_WP !< over live nodes (get_info) + real(WP) :: Wmin=0.0_WP,Wmax=0.0_WP + real(WP) :: EPmax=0.0_WP !< max accumulated equivalent plastic strain (get_info) + real(WP) :: CFLe=0.0_WP,CFLp=0.0_WP !< elastic-wave / convective CFL (get_cfl) + integer(I8) :: nbroken=0 !< global broken half-entry count (internal) + integer(I8) :: nb_broken=0 !< global broken BOND count (exact census, get_info) + integer(I8) :: nb=0 !< global bond count (exact census, stamped at assemble) + integer(I8) :: nrebuild=0 !< broad-phase rebuild count (cumulative) + integer(I8) :: nchalo_glob=0 !< global contact-slot count (get_info) + integer(I8) :: ncand_glob=0 !< global contact-candidate count (get_info) + + ! Per-rank phase timers (accumulated in advance; reduced+reset in get_info) + real(WP) :: wt_kick=0.0_WP,wt_halo=0.0_WP,wt_dil=0.0_WP,wt_force=0.0_WP,wt_reduce=0.0_WP + real(WP) :: wt_contact=0.0_WP,wt_broad=0.0_WP + real(WP) :: wtmax_kick=0.0_WP,wtmax_halo=0.0_WP,wtmax_dil=0.0_WP,wtmax_force=0.0_WP,wtmax_reduce=0.0_WP + real(WP) :: wtmax_contact=0.0_WP,wtmax_broad=0.0_WP + real(WP) :: wtmin_dil=0.0_WP,wtmin_force=0.0_WP + real(WP) :: tot_time=0.0_WP,maxtot_time=0.0_WP + + ! Damping rate for steady state + real(WP) :: damping_rate=0.0_WP + + ! NOSB Tracked parameters + real(WP), allocatable :: F_mat(:,:,:) !< F matrix (:,:,nown) I don't think this needs the halo + real(WP), allocatable :: PK_inv(:,:,:) !< P*K^-1 matrix (:,:,ntot) This needs to have gthe halo + + + contains + procedure :: set_nodes + procedure :: connect + procedure :: detect_families + procedure :: pd_advance + procedure :: query_owners + procedure :: write_state + procedure :: read_state + procedure :: get_cfl + procedure :: get_info + procedure :: finalize + procedure, private :: derive_config + procedure, private :: lps_coefs + procedure, private :: compute_mw + procedure, private :: contact_broadphase + procedure, private :: contact_narrow + procedure, private :: assemble + + end type pdsolver + +contains + + + !> Resolve derived configuration: s0 from fail_stretch/crit_energy, contact + !> reach default. Called by every network-building entry point (connect, + !> detect_families, read_state) so fresh init and restart share one path. + subroutine derive_config(this) + use messager, only: die + implicit none + class(pdsolver), intent(inout) :: this + real(WP) :: K_bulk + if (this%rho.le.0.0_WP.or.this%elastic_modulus.le.0.0_WP.or. & + & this%delta.le.0.0_WP.or.this%dV.le.0.0_WP) & + & call die('[pdsolver] material/discretization not configured (need rho, elastic_modulus, delta, dV > 0)') + if (this%fail_stretch.lt.huge(1.0_WP)) then + this%s0=this%fail_stretch + else if (this%crit_energy.gt.0.0_WP.and.this%crit_energy.lt.huge(1.0_WP)) then + ! Silling-Askari bond-energy argument, generalized to the active + ! influence function: G_c = (9/4)*K*s0^2*Iw4/Iw3 (w=1 recovers the + ! classical s0 = sqrt(5*G_c/(9*K*delta))) + K_bulk=this%elastic_modulus/(3.0_WP*(1.0_WP-2.0_WP*this%poisson_ratio)) + this%s0=sqrt(4.0_WP*this%crit_energy*wmoment(this%delta,3,1)/(9.0_WP*K_bulk*wmoment(this%delta,4,1))) + end if + if (this%use_contact.and.this%contact_dist.le.0.0_WP) this%contact_dist=0.9_WP*this%dV**(1.0_WP/3.0_WP) + end subroutine derive_config + + !> Load this rank's owned nodes (any distribution; it becomes the static + !> partition). Builds the gid->index hash used by connect and the halo plan. + !> vol is the per-node volume (pass a constant-filled array for a uniform + !> lattice; kernels use it per neighbor, Peridigm-style). + subroutine set_nodes(this,n,gids,pos,vel,flags,vol) + implicit none + class(pdsolver), intent(inout) :: this + integer, intent(in) :: n + integer(I8), intent(in) :: gids(:) + real(WP), intent(in) :: pos(:,:),vel(:,:) + integer, intent(in) :: flags(:) + real(WP), intent(in) :: vol(:) + integer :: i + this%nown=n + this%nhalo=0 + this%ntot=n + allocate(this%gid(max(n,1)),this%x0(3,max(n,1)),this%y(3,max(n,1))) + allocate(this%v(3,max(n,1)),this%f(3,max(n,1)),this%ff(3,max(n,1))) + allocate(this%mw(max(n,1)),this%theta(max(n,1)),this%flag(max(n,1))) + allocate(this%vol(max(n,1)),this%damage(max(n,1)),this%lam_p(max(n,1))) + allocate(this%PK_inv(3,3,max(n,1)),this%F_mat(3,3,max(n,1))) + do i=1,n + this%gid(i) =gids(i) + this%x0(:,i)=pos(:,i) + this%y(:,i) =pos(:,i) + this%v(:,i) =vel(:,i) + this%flag(i)=flags(i) + this%vol(i) =vol(i) + end do + this%f=0.0_WP; this%ff=0.0_WP; this%mw=0.0_WP; this%theta=0.0_WP; this%damage=0.0_WP; this%lam_p=0.0_WP + this%F_mat=0.0_WP; this%PK_inv=0.0_WP + call this%ohash%build(n,gids(1:n)) + end subroutine set_nodes + + !> Build the static CSR families and the halo plan from a distributed bond + !> list (this rank passes the bonds it holds; any distribution is fine -- + !> half-entries are routed to their node's owner through the gid directory). + !> Collective. bkey packs the periodic image offset of the HI endpoint in + !> amrpd's hist1 convention. Self-image bonds (gid_lo==gid_hi) yield ONE + !> half-entry (the opposite-image bond exists separately in the input, exactly + !> as amrpd stores them). + subroutine connect(this,nb,bgid_lo,bgid_hi,bkey) + use parallel, only: comm,nproc + use messager, only: die + use mpi_f08 + implicit none + class(pdsolver), intent(inout) :: this + integer, intent(in) :: nb + integer(I8), intent(in) :: bgid_lo(:),bgid_hi(:) + integer, intent(in) :: bkey(:) + integer(I8), allocatable :: hnode(:),hnbr(:),rnode(:),rnbr(:) + integer, allocatable :: hkey(:),howner(:),rkey(:) + real(WP), allocatable :: rev(:) + integer(1), allocatable :: rdmg(:) + integer :: nhe,rn,i,ib,ierr + + ! Resolve derived configuration (restart-safe shared path) + call this%derive_config() + + ! Distributed gid directory over the node partition (persistent: also + ! serves owner queries for face-tag restamping after restart) + call this%dir%finalize() + call this%dir%register(this%nown,this%gid(1:this%nown)) + + ! Expand bonds into half-entries (one per endpoint row; one total for + ! self-image bonds -- see header) + nhe=0 + do ib=1,nb + nhe=nhe+1 + if (bgid_lo(ib).ne.bgid_hi(ib)) nhe=nhe+1 + end do + allocate(hnode(max(nhe,1)),hnbr(max(nhe,1)),hkey(max(nhe,1)),howner(max(nhe,1))) + nhe=0 + do ib=1,nb + nhe=nhe+1 + hnode(nhe)=bgid_lo(ib); hnbr(nhe)=bgid_hi(ib); hkey(nhe)=bkey(ib) + if (bgid_lo(ib).ne.bgid_hi(ib)) then + nhe=nhe+1 + hnode(nhe)=bgid_hi(ib); hnbr(nhe)=bgid_lo(ib); hkey(nhe)=negkey(bkey(ib)) + end if + end do + + ! Route each half-entry to the rank owning its node + call this%dir%query(nhe,hnode,howner) + route_entries: block + integer, dimension(0:nproc-1) :: sc,rc,sd,rd + integer, allocatable :: pos(:) + integer(I8), allocatable :: s8(:) + integer, allocatable :: s4(:) + integer :: r,h + sc=0 + do i=1,nhe + sc(howner(i))=sc(howner(i))+1 + end do + call MPI_ALLTOALL(sc,1,MPI_INTEGER,rc,1,MPI_INTEGER,comm,ierr) + sd(0)=0; rd(0)=0 + do r=1,nproc-1 + sd(r)=sd(r-1)+sc(r-1); rd(r)=rd(r-1)+rc(r-1) + end do + rn=sum(rc) + allocate(rnode(max(rn,1)),rnbr(max(rn,1)),rkey(max(rn,1))) + allocate(pos(0:nproc-1),s8(max(nhe,1)),s4(max(nhe,1))) + ! node gids + pos=sd + do i=1,nhe + h=howner(i); pos(h)=pos(h)+1; s8(pos(h))=hnode(i) + end do + call MPI_ALLTOALLV(s8,sc,sd,MPI_INTEGER8,rnode,rc,rd,MPI_INTEGER8,comm,ierr) + ! neighbor gids + pos=sd + do i=1,nhe + h=howner(i); pos(h)=pos(h)+1; s8(pos(h))=hnbr(i) + end do + call MPI_ALLTOALLV(s8,sc,sd,MPI_INTEGER8,rnbr,rc,rd,MPI_INTEGER8,comm,ierr) + ! image keys + pos=sd + do i=1,nhe + h=howner(i); pos(h)=pos(h)+1; s4(pos(h))=hkey(i) + end do + call MPI_ALLTOALLV(s4,sc,sd,MPI_INTEGER,rkey,rc,rd,MPI_INTEGER,comm,ierr) + deallocate(pos,s8,s4) + end block route_entries + deallocate(hnode,hnbr,hkey,howner) + + ! Fresh bonds carry zero inelastic state + allocate(rev(max(rn,1)),rdmg(max(rn,1))) + rev=0.0_WP; rdmg=0_1 + call this%assemble(rn,rnode,rnbr,rkey,rev,rdmg) + deallocate(rnode,rnbr,rkey,rev,rdmg) + end subroutine connect + + + !> Build the bond families directly from the REFERENCE configuration -- no + !> amrpd bond container, no bond expansion: distributed neighbor discovery + !> at radius delta (bounds allgather + per-(rank,image-offset) offers of + !> shifted x0, contact-broadphase pattern), then each owned row's + !> half-entries are generated straight from the binned candidates and fed + !> to assemble with zero inelastic state. Acceptance test r2 <= delta^2 + !> matches amrpd bond_init exactly. Collective; call after set_nodes. + subroutine detect_families(this) + use parallel, only: comm,rank,nproc,amRoot,MPI_REAL_WP + use messager, only: log,die + use string, only: str_long + use mpi_f08 + implicit none + class(pdsolver), intent(inout) :: this + real(WP), dimension(3) :: bl,bh,shift,pos_s,gl,hcell + real(WP), allocatable :: allb(:,:),opos(:,:),rpos(:,:),cpos(:,:) + integer(I8), allocatable :: ogid(:),rgid(:),cgid(:),hnode(:),hnbr(:) + integer, allocatable :: okey(:),rkey(:),ckey(:),hkey(:),head(:),nxt(:) + real(WP), allocatable :: rev(:) + integer(1), allocatable :: rdmg(:) + integer, dimension(0:nproc-1) :: sc,rc,sd,rd,sc3,rc3,sd3,rd3 + integer, dimension(3) :: nmax,nc + integer :: d,r,n1,n2,n3,i,k,m,noff,nrecv,ncand,nhe,pass,ic,jc,kc,c1,c2,c3,ierr + character(len=str_long) :: message + + ! Resolve derived configuration (restart-safe shared path) + call this%derive_config() + + ! Directory over the node partition (persistent) + call this%dir%finalize() + call this%dir%register(this%nown,this%gid(1:this%nown)) + + ! Owned reference bounds, exchanged globally + bl=huge(1.0_WP); bh=-huge(1.0_WP) + do i=1,this%nown + bl=min(bl,this%x0(:,i)); bh=max(bh,this%x0(:,i)) + end do + allocate(allb(6,0:nproc-1)) + call MPI_ALLGATHER([bl,bh],6,MPI_REAL_WP,allb,6,MPI_REAL_WP,comm,ierr) + do d=1,3 + nmax(d)=0 + if (this%per(d).and.this%Ldom(d).gt.0.0_WP) nmax(d)=min(4,int(this%delta/this%Ldom(d))+1) + end do + + ! Offers of shifted reference positions (two passes: count, fill) + do pass=1,2 + sc=0 + do r=0,nproc-1 + do n3=-nmax(3),nmax(3); do n2=-nmax(2),nmax(2); do n1=-nmax(1),nmax(1) + if (r.eq.rank.and.n1.eq.0.and.n2.eq.0.and.n3.eq.0) cycle + shift=[real(n1,WP)*this%Ldom(1),real(n2,WP)*this%Ldom(2),real(n3,WP)*this%Ldom(3)] + if (any(bl+shift-this%delta.gt.allb(4:6,r)).or.any(bh+shift+this%delta.lt.allb(1:3,r))) cycle + do i=1,this%nown + pos_s=this%x0(:,i)+shift + if (any(pos_s.lt.allb(1:3,r)-this%delta).or.any(pos_s.gt.allb(4:6,r)+this%delta)) cycle + sc(r)=sc(r)+1 + if (pass.eq.2) then + ogid(sd(r)+sc(r))=this%gid(i) + okey(sd(r)+sc(r))=(n1+128)+(n2+128)*256+(n3+128)*65536 + opos(:,sd(r)+sc(r))=pos_s + end if + end do + end do; end do; end do + end do + if (pass.eq.1) then + sd(0)=0 + do r=1,nproc-1 + sd(r)=sd(r-1)+sc(r-1) + end do + noff=sum(sc) + allocate(ogid(max(noff,1)),okey(max(noff,1)),opos(3,max(noff,1))) + end if + end do + call MPI_ALLTOALL(sc,1,MPI_INTEGER,rc,1,MPI_INTEGER,comm,ierr) + rd(0)=0 + do r=1,nproc-1 + rd(r)=rd(r-1)+rc(r-1) + end do + nrecv=sum(rc) + allocate(rgid(max(nrecv,1)),rkey(max(nrecv,1)),rpos(3,max(nrecv,1))) + call MPI_ALLTOALLV(ogid,sc,sd,MPI_INTEGER8,rgid,rc,rd,MPI_INTEGER8,comm,ierr) + call MPI_ALLTOALLV(okey,sc,sd,MPI_INTEGER, rkey,rc,rd,MPI_INTEGER, comm,ierr) + sc3=3*sc; sd3=3*sd; rc3=3*rc; rd3=3*rd + call MPI_ALLTOALLV(opos,sc3,sd3,MPI_REAL_WP,rpos,rc3,rd3,MPI_REAL_WP,comm,ierr) + deallocate(ogid,okey,opos) + + ! Candidate set = owned nodes (zero offset) + received offers + ncand=this%nown+nrecv + allocate(cgid(max(ncand,1)),ckey(max(ncand,1)),cpos(3,max(ncand,1))) + do i=1,this%nown + cgid(i)=this%gid(i); ckey(i)=PDHALO_KEY0; cpos(:,i)=this%x0(:,i) + end do + do i=1,nrecv + cgid(this%nown+i)=rgid(i); ckey(this%nown+i)=rkey(i); cpos(:,this%nown+i)=rpos(:,i) + end do + deallocate(rgid,rkey,rpos) + + ! Bin candidates; generate each owned row directly (two passes) + bl=huge(1.0_WP); bh=-huge(1.0_WP) + do m=1,ncand + bl=min(bl,cpos(:,m)); bh=max(bh,cpos(:,m)) + end do + call setup_bins(bl,bh,this%delta,gl,hcell,nc) + allocate(head(nc(1)*nc(2)*nc(3)),nxt(max(ncand,1))) + head=0 + do m=1,ncand + k=cell_of(cpos(:,m),gl,hcell,nc) + nxt(m)=head(k); head(k)=m + end do + do pass=1,2 + nhe=0 + do i=1,this%nown + ic=min(nc(1),max(1,int((this%x0(1,i)-gl(1))/hcell(1))+1)) + jc=min(nc(2),max(1,int((this%x0(2,i)-gl(2))/hcell(2))+1)) + kc=min(nc(3),max(1,int((this%x0(3,i)-gl(3))/hcell(3))+1)) + do c3=max(1,kc-1),min(nc(3),kc+1); do c2=max(1,jc-1),min(nc(2),jc+1); do c1=max(1,ic-1),min(nc(1),ic+1) + m=head(c1+nc(1)*(c2-1)+nc(1)*nc(2)*(c3-1)) + do while (m.gt.0) + if (m.ne.i) then + if (sum((cpos(:,m)-this%x0(:,i))**2).le.this%delta**2) then + nhe=nhe+1 + if (pass.eq.2) then + hnode(nhe)=this%gid(i) + hnbr(nhe) =cgid(m) + hkey(nhe) =ckey(m) + end if + end if + end if + m=nxt(m) + end do + end do; end do; end do + end do + if (pass.eq.1) allocate(hnode(max(nhe,1)),hnbr(max(nhe,1)),hkey(max(nhe,1))) + end do + deallocate(cgid,ckey,cpos,head,nxt,allb) + + ! Assemble with zero inelastic state (entries are already local rows) + allocate(rev(max(nhe,1)),rdmg(max(nhe,1))) + rev=0.0_WP; rdmg=0_1 + call this%assemble(nhe,hnode,hnbr,hkey,rev,rdmg) + deallocate(hnode,hnbr,hkey,rev,rdmg) + if (amRoot) then + write(message,'("[",a,"] detect_families: ",i0," half-entries (~2x bonds)")') trim(this%name),this%nbond + call log(message) + end if + end subroutine detect_families + + !> Assemble the CSR families, halo plan, and reference state from LOCAL + !> half-entry arrays (already routed to this rank: every entry's node gid is + !> owned here). Per-entry inelastic state (dmg, e_v) travels with the + !> entries -- zeros for a fresh connect, loaded values on restart. Shared by + !> connect and read_state; collective. + subroutine assemble(this,rn,rnode,rnbr,rkey,rev,rdmg) + use parallel, only: comm,nproc + use messager, only: die + use mpi_f08 + implicit none + class(pdsolver), intent(inout) :: this + integer, intent(in) :: rn + integer(I8), intent(in) :: rnode(:),rnbr(:) + integer, intent(in) :: rkey(:) + real(WP), intent(in) :: rev(:) + integer(1), intent(in) :: rdmg(:) + integer, allocatable :: ridx(:),perm(:) + integer :: i,s,ierr + + if (allocated(this%ptr)) deallocate(this%ptr) + if (allocated(this%lst)) deallocate(this%lst) + if (allocated(this%dmg)) deallocate(this%dmg) + if (allocated(this%e_v)) deallocate(this%e_v) + if (allocated(this%td2)) deallocate(this%td2) + if (allocated(this%td2a)) deallocate(this%td2a) + + ! Resolve each received entry's node to an owned index + allocate(ridx(max(rn,1)),perm(max(rn,1))) + do i=1,rn + ridx(i)=this%ohash%lookup(rnode(i)) + if (ridx(i).lt.1) call die('[pdsolver assemble] half-entry routed to a rank that does not own its node') + perm(i)=i + end do + + ! Deterministic CSR order: sort by (node index, neighbor gid, image key) + if (rn.gt.1) call sort3_perm(ridx,rnbr,rkey,perm,1,rn) + + ! Row pointers + allocate(this%ptr(this%nown+1)) + row_pointers: block + integer, allocatable :: cnt(:) + allocate(cnt(this%nown)); cnt=0 + do i=1,rn + cnt(ridx(i))=cnt(ridx(i))+1 + end do + this%ptr(1)=1 + do i=1,this%nown + this%ptr(i+1)=this%ptr(i)+cnt(i) + end do + deallocate(cnt) + end block row_pointers + + ! Classify entries (owned direct vs halo reference), dedupe references, + ! build the halo plan, and finalize the CSR neighbor indices + build_refs_and_halo: block + integer(I8), allocatable :: refgid(:),ugid(:) + integer, allocatable :: refkey(:),refpos(:),rperm(:),zeros(:) + integer, allocatable :: ukey(:),uowner(:),uslot(:) + integer :: nref,nuniq,lid,u + allocate(this%lst(max(rn,1))) + allocate(this%dmg(max(rn,1))); this%dmg=0_1 + allocate(this%e_v(max(rn,1))); this%e_v=0.0_WP + ! Per-entry inelastic state follows the deterministic CSR order + do s=1,rn + this%dmg(s)=rdmg(perm(s)) + this%e_v(s)=rev(perm(s)) + end do + allocate(this%td2(max(this%nown,1)),this%td2a(max(this%nown,1))) + this%td2=0.0_WP; this%td2a=0.0_WP + allocate(refgid(max(rn,1)),refkey(max(rn,1)),refpos(max(rn,1))) + nref=0 + do s=1,rn + i=perm(s) + if (rkey(i).eq.PDHALO_KEY0) then + lid=this%ohash%lookup(rnbr(i)) + if (lid.ge.1) then + this%lst(s)=lid ! owned, zero image offset: direct index + cycle + end if + end if + nref=nref+1 + refgid(nref)=rnbr(i); refkey(nref)=rkey(i); refpos(nref)=s + end do + ! Unique (gid,key) references, deterministic order + allocate(rperm(max(nref,1)),zeros(max(nref,1))) + zeros=0 + do i=1,nref + rperm(i)=i + end do + if (nref.gt.1) call sort3_perm(zeros,refgid,refkey,rperm,1,nref) + allocate(ugid(max(nref,1)),ukey(max(nref,1))) + nuniq=0 + do s=1,nref + i=rperm(s) + if (s.eq.1) then + nuniq=1; ugid(1)=refgid(i); ukey(1)=refkey(i) + else if (refgid(i).ne.refgid(rperm(s-1)).or.refkey(i).ne.refkey(rperm(s-1))) then + nuniq=nuniq+1; ugid(nuniq)=refgid(i); ukey(nuniq)=refkey(i) + end if + this%lst(refpos(i))=-nuniq ! provisional: -(unique ref id) + end do + ! Owners of the unique references, then the persistent halo plan + allocate(uowner(max(nuniq,1)),uslot(max(nuniq,1))) + call this%dir%query(nuniq,ugid,uowner) + call this%halo%build(this%nown,this%ohash,nuniq,ugid,ukey,uowner,this%Ldom,this%per,uslot) + this%nhalo=this%halo%nhalo + this%ntot=this%nown+this%nhalo + ! Finalize CSR: provisional negatives -> halo slot indices + do s=1,rn + if (this%lst(s).lt.0) this%lst(s)=this%nown+uslot(-this%lst(s)) + end do + ! Extend node arrays to include halo slots; stamp halo gids + extend_arrays: block + integer(I8), allocatable :: g2(:) + real(WP), allocatable :: a2(:,:) + allocate(g2(max(this%ntot,1))); g2(1:this%nown)=this%gid(1:this%nown) + do u=1,nuniq + g2(this%nown+uslot(u))=ugid(u) + end do + call move_alloc(g2,this%gid) + allocate(a2(3,max(this%ntot,1))); a2=0.0_WP; a2(:,1:this%nown)=this%x0(:,1:this%nown) + call move_alloc(a2,this%x0) + allocate(a2(3,max(this%ntot,1))); a2=0.0_WP; a2(:,1:this%nown)=this%y(:,1:this%nown) + call move_alloc(a2,this%y) + allocate(a2(3,max(this%ntot,1))); a2=0.0_WP; a2(:,1:this%nown)=this%f(:,1:this%nown) + call move_alloc(a2,this%f) + extend_tensors: block ! I am copying the patterm but I think this will correctly extend things to include halos + real(WP), allocatable :: t2(:,:,:) + allocate(t2(3,3,max(this%ntot,1))); t2=0.0_WP; t2(:,:,1:this%nown)=this%PK_inv(:,:,1:this%nown) + call move_alloc(t2,this%PK_inv) + end block extend_tensors + extend_volume: block + real(WP), allocatable :: v2(:) + allocate(v2(max(this%ntot,1))); v2=0.0_WP; v2(1:this%nown)=this%vol(1:this%nown) + call move_alloc(v2,this%vol) + end block extend_volume + end block extend_arrays + deallocate(refgid,refkey,refpos,rperm,zeros,ugid,ukey,uowner,uslot) + end block build_refs_and_halo + deallocate(ridx,perm) + + ! Fill halo reference positions ONCE, pre-shifted by the image offsets + ! (x0 is static; this is the only x0 exchange of the entire run), and + ! the halo per-node volumes (also static) + call this%halo%update(this%x0,3,shifted=.true.) + call this%halo%update1(this%vol) + this%y(:,this%nown+1:this%ntot)=this%x0(:,this%nown+1:this%ntot) + + ! Life status (exit-through-open-face handling). Exchanged over the halo + ! ONLY on substeps where a death occurs somewhere; steady state is free. + if (allocated(this%alive)) deallocate(this%alive) + allocate(this%alive(max(this%ntot,1))); this%alive=1.0_WP + this%watch_exit=(this%dom_hi(1).gt.this%dom_lo(1)).and. & + & any((.not.this%per).and.(this%lo_bc.eq.0.or.this%hi_bc.eq.0)) + + ! Stamp the reference weighted volume + call this%compute_mw() + + ! Silling-Askari critical time step (Peridigm form, 3D bond-based + ! micromodulus c(z) = c0*w(z), c0 = 9K/(2*pi*Iw3); w=1 recovers the + ! classical 18K/(pi*delta^4)): + ! dt_crit_i = sqrt(2*rho / sum_family(V_j * c(zeta) / zeta)), global min. + ! DIAGNOSTIC only for now -- reported at init, does not bind dt. The + ! micromodulus constant is 3D-based; in quasi-2D slabs treat it as + ! indicative. + critical_dt: block + use mathtools, only: Pi + use messager, only: log + use string, only: str_long + use parallel, only: amRoot,MPI_REAL_WP + real(WP) :: K_bulk,c0,denom,zeta,dtc + character(len=str_long) :: message + integer :: i,e,j + K_bulk=this%elastic_modulus/(3.0_WP*(1.0_WP-2.0_WP*this%poisson_ratio)) + c0=9.0_WP*K_bulk/(2.0_WP*Pi*wmoment(this%delta,3,1)) + dtc=huge(1.0_WP) + do i=1,this%nown + denom=0.0_WP + do e=this%ptr(i),this%ptr(i+1)-1 + j=this%lst(e) + zeta=sqrt(sum((this%x0(:,j)-this%x0(:,i))**2)) + if (zeta.gt.0.0_WP) denom=denom+this%vol(j)*c0*omega(zeta,this%delta)/zeta + end do + if (denom.gt.0.0_WP) dtc=min(dtc,sqrt(2.0_WP*this%rho/denom)) + end do + call MPI_ALLREDUCE(MPI_IN_PLACE,dtc,1,MPI_REAL_WP,MPI_MIN,comm,ierr) + this%dtcrit=dtc + if (amRoot) then + write(message,'("[",a,"] Silling-Askari critical dt = ",es12.5," (diagnostic)")') trim(this%name),this%dtcrit + call log(message) + end if + end block critical_dt + + ! Global half-entry count for logging (= 2*bonds - self-image bonds) + count_bonds: block + use parallel, only: comm + integer(I8) :: nhe8 + nhe8=int(rn,I8) + call MPI_ALLREDUCE(MPI_IN_PLACE,nhe8,1,MPI_INTEGER8,MPI_SUM,comm,ierr) + this%nbond=nhe8 ! total half-entries; = 2*bonds - self-image bonds + ! Exact bond census (lower-gid rule; positive-offset self-images) + count_nb: block + integer :: i2,e2,j2 + this%nb=0_I8 + do i2=1,this%nown + do e2=this%ptr(i2),this%ptr(i2+1)-1 + j2=this%lst(e2) + if (this%gid(i2).lt.this%gid(j2)) then + this%nb=this%nb+1_I8 + else if (this%gid(i2).eq.this%gid(j2).and.j2.gt.this%nown) then + if (shift_positive(this%halo%shift(:,j2-this%nown))) this%nb=this%nb+1_I8 + end if + end do + end do + call MPI_ALLREDUCE(MPI_IN_PLACE,this%nb,1,MPI_INTEGER8,MPI_SUM,comm,ierr) + end block count_nb + end block count_bonds + end subroutine assemble + + !> Weighted volume: mw_i = sum_family w(zeta)*zeta^2*V_j (reference state; + !> never updated by damage) + subroutine compute_mw(this) + implicit none + class(pdsolver), intent(inout) :: this + integer :: i,e,j + real(WP) :: zeta + do i=1,this%nown + this%mw(i)=0.0_WP + do e=this%ptr(i),this%ptr(i+1)-1 + j=this%lst(e) + zeta=sqrt(sum((this%x0(:,j)-this%x0(:,i))**2)) + this%mw(i)=this%mw(i)+omega(zeta,this%delta)*zeta**2*this%vol(j) + end do + end do + end subroutine compute_mw + + !> Dimension-aware LPS constitutive coefficients (omega-independent: mw + !> absorbs the influence function). psi_fac sets the J2 yield threshold on + !> the family deviatoric force-state norm -- yield when + !> ||t_dev||^2 > psi_fac*sigma_yield^2/mw (Mitchell OSB) -- and DOES depend + !> on omega: since td ~ w, the norm scales by the w^2/w moment ratio + !> (int w^2 z^p / int w z^p, p=4 in 3D, 3 in 2D; ratio = 1 for w=1). + subroutine lps_coefs(this,fdim,coef_vol,coef_dev,psi_fac) + implicit none + class(pdsolver), intent(in) :: this + real(WP), intent(out) :: fdim,coef_vol,coef_dev + real(WP), intent(out), optional :: psi_fac + real(WP) :: K_bulk,mu_shear + integer :: ndim + ndim=3-count(this%collapsed) + K_bulk =this%elastic_modulus/(3.0_WP*(1.0_WP-2.0_WP*this%poisson_ratio)) + mu_shear=this%elastic_modulus/(2.0_WP*(1.0_WP+this%poisson_ratio)) + select case (ndim) + case (3) + fdim=3.0_WP; coef_vol=3.0_WP*K_bulk; coef_dev=15.0_WP*mu_shear + if (present(psi_fac)) psi_fac=5.0_WP*wmoment(this%delta,4,2)/wmoment(this%delta,4,1) + case (2) + fdim=2.0_WP; coef_vol=2.0_WP*(K_bulk+mu_shear/3.0_WP); coef_dev= 8.0_WP*mu_shear + if (present(psi_fac)) psi_fac=8.0_WP/3.0_WP*wmoment(this%delta,3,2)/wmoment(this%delta,3,1) + case default + fdim=1.0_WP; coef_vol=this%elastic_modulus; coef_dev= 0.0_WP + if (present(psi_fac)) psi_fac=0.0_WP + end select + end subroutine lps_coefs + + !> Velocity-Verlet step: half-kick + drift, halo position update, + !> dilatation gather, node-centered force sweep, halo force reduce, + !> contact, second half-kick. + subroutine pd_advance(this,dt) + use parallel, only: parallel_time + use mathtools, only: Pi + implicit none + class(pdsolver), intent(inout) :: this + real(WP), intent(in) :: dt + real(WP) :: rho_inv,fdim,cvol,cdev,t0 + real(WP) :: zeta,dY,e_b,t,w + real(WP) :: psi_fac,decay,e_d,td,beta,e_e,over + real(WP) :: sYe2,strial,mu3i + logical :: plastic,do_j2 + real(WP), dimension(3) :: acc,dxv,fx + real(WP), dimension(3,3) :: K_mat,E_mat,I_mat,S_mat,K_inv,sigma, s_dev + real(WP) :: detK_inv,traceE + real(WP) :: kk,mu + real(WP), dimension(3) :: xi,rpos,z,t1,t2,tc + integer :: i,e,j + + real(WP) :: t_full + t_full=parallel_time() + + rho_inv=1.0_WP/this%rho + mu=this%elastic_modulus/(2.0_WP+2.0_WP*this%poisson_ratio) + kk=this%elastic_modulus/(3.0_WP-6.0_WP*this%poisson_ratio) + call this%lps_coefs(fdim,cvol,cdev,psi_fac) + ! ! Viscoplastic setup: decay is loop-invariant (exact exponential update, + ! ! unconditionally stable -- no viscous CFL) + ! plastic=(this%tau.gt.0.0_WP.and.this%tau.lt.huge(1.0_WP)) + ! do_j2=(this%sigma_yield.gt.0.0_WP) + ! decay=0.0_WP + ! if (plastic) decay=exp(-dt/this%tau) + ! mu3i=2.0_WP*(1.0_WP+this%poisson_ratio)/(3.0_WP*this%elastic_modulus) ! 1/(3*mu_shear) + + ! First half-kick and drift (owned nodes) + t0=parallel_time() + do i=1,this%nown + if (this%flag(i).eq.PDC_IS_DEAD) cycle + acc=this%gravity+(this%f(:,i)+this%ff(:,i))*rho_inv + if (iand(this%flag(i),PDC_INTEGRATES).ne.0) this%v(:,i)=(1.0_WP-this%damping_rate)*this%v(:,i)+0.5_WP*dt*acc + if (this%collapsed(1)) this%v(1,i)=0.0_WP + if (this%collapsed(2)) this%v(2,i)=0.0_WP + if (this%collapsed(3)) this%v(3,i)=0.0_WP + if (iand(this%flag(i),PDC_MOVES).ne.0) this%y(:,i)=this%y(:,i)+dt*this%v(:,i) + end do + this%wt_kick=this%wt_kick+(parallel_time()-t0) + + ! Exit handling: nodes drifting out through an OPEN non-periodic face die + ! (amrpd drops them at Redistribute; here they are flagged and muted). + ! The death-count allreduce runs only when exits are possible at all, and + ! the mute propagation only on substeps where a death actually occurred. + if (this%watch_exit) then + death_watch: block + use parallel, only: comm + use mpi_f08, only: MPI_ALLREDUCE,MPI_IN_PLACE,MPI_SUM,MPI_INTEGER + integer :: nd,d,e,ierr + logical :: out + nd=0 + do i=1,this%nown + if (this%flag(i).eq.PDC_IS_DEAD) cycle + out=.false. + do d=1,3 + if (this%per(d)) cycle + if (this%lo_bc(d).eq.0.and.this%y(d,i).lt.this%dom_lo(d)) out=.true. + if (this%hi_bc(d).eq.0.and.this%y(d,i).gt.this%dom_hi(d)) out=.true. + end do + if (out) then + this%flag(i)=PDC_IS_DEAD + this%v(:,i)=0.0_WP + this%alive(i)=0.0_WP + nd=nd+1 + end if + end do + call MPI_ALLREDUCE(MPI_IN_PLACE,nd,1,MPI_INTEGER,MPI_SUM,comm,ierr) + if (nd.gt.0) then + ! Propagate life status to halo slots, then permanently mute + ! every entry touching a dead node (dmg=2: distinct from broken, + ! so damage statistics stay honest -- amrpd does not count + ! dropped-particle bonds as damage either) + call this%halo%update1(this%alive) + do i=1,this%nown + if (this%flag(i).eq.PDC_IS_DEAD) then + do e=this%ptr(i),this%ptr(i+1)-1 + if (this%dmg(e).eq.0_1) this%dmg(e)=2_1 + end do + else + do e=this%ptr(i),this%ptr(i+1)-1 + if (this%dmg(e).eq.0_1.and.this%alive(this%lst(e)).lt.0.5_WP) this%dmg(e)=2_1 + end do + end if + end do + ! Force a contact broad-phase rebuild so no candidate list + ! references a corpse (dead nodes are excluded from offers/bins) + if (this%use_contact.and.allocated(this%ylast)) deallocate(this%ylast) + end if + end block death_watch + end if + + ! Refresh halo positions (owner y -> slots, with image shifts) + t0=parallel_time() + call this%halo%update(this%y,3,shifted=.true.) + this%wt_halo=this%wt_halo+(parallel_time()-t0) + + ! Contact service: displacement-triggered broad phase (rebuilds contact + ! halo + candidate list when cumulative drift exhausts the skin), then + ! per-substep refresh of contact-slot positions AND velocities (the only + ! place velocity crosses ranks; the graph halo never carries it) + if (this%use_contact) then + t0=parallel_time() + call this%contact_broadphase() + this%wt_broad=this%wt_broad+(parallel_time()-t0) + t0=parallel_time() + call this%chalo%update(this%y,3,shifted=.true.) + call this%chalo%update(this%v,3,shifted=.false.) + this%wt_halo=this%wt_halo+(parallel_time()-t0) + end if + t0=parallel_time() + ! Equivalent to the dilatation sweep from before, I think that each one needs to sweep over + ! and compute the tensors K_mat and F + I_mat = 0.0_WP + I_mat(1,1) = 1.0_WP + I_mat(2,2) = 1.0_WP + I_mat(3,3) = 1.0_WP + do i=1,this%nown + K_mat=0.0_WP + K_inv = 0.0_WP + S_mat = 0.0_WP + traceE = 0.0_WP + E_mat = 0.0_WP + this%F_mat(:,:,i)=0.0_WP + this%PK_inv(:,:,i)=0.0_WP + do e=this%ptr(i),this%ptr(i+1)-1 + if (this%dmg(e).ne.0_1) cycle + j=this%lst(e) + xi=this%x0(:,j)-this%x0(:,i) + rpos=this%y(:,j) -this%y(:,i) + zeta=sqrt(sum(xi**2)) + w = omega(zeta,this%delta) + K_mat(1,1)=K_mat(1,1)+xi(1)*xi(1)*w*this%vol(j); K_mat(1,2)=K_mat(1,2)+xi(1)*xi(2)*w*this%vol(j); K_mat(1,3)=K_mat(1,3)+xi(1)*xi(3)*w*this%vol(j); + K_mat(2,1)=K_mat(2,1)+xi(2)*xi(1)*w*this%vol(j); K_mat(2,2)=K_mat(2,2)+xi(2)*xi(2)*w*this%vol(j); K_mat(2,3)=K_mat(2,3)+xi(2)*xi(3)*w*this%vol(j); + K_mat(3,1)=K_mat(3,1)+xi(3)*xi(1)*w*this%vol(j); K_mat(3,2)=K_mat(3,2)+xi(3)*xi(2)*w*this%vol(j); K_mat(3,3)=K_mat(3,3)+xi(3)*xi(3)*w*this%vol(j); + + this%F_mat(1,1,i)=this%F_mat(1,1,i)+rpos(1)*xi(1)*w*this%vol(j); this%F_mat(1,2,i)=this%F_mat(1,2,i)+rpos(1)*xi(2)*w*this%vol(j); this%F_mat(1,3,i)=this%F_mat(1,3,i)+rpos(1)*xi(3)*w*this%vol(j); + this%F_mat(2,1,i)=this%F_mat(2,1,i)+rpos(2)*xi(1)*w*this%vol(j); this%F_mat(2,2,i)=this%F_mat(2,2,i)+rpos(2)*xi(2)*w*this%vol(j); this%F_mat(2,3,i)=this%F_mat(2,3,i)+rpos(2)*xi(3)*w*this%vol(j); + this%F_mat(3,1,i)=this%F_mat(3,1,i)+rpos(3)*xi(1)*w*this%vol(j); this%F_mat(3,2,i)=this%F_mat(3,2,i)+rpos(3)*xi(2)*w*this%vol(j); this%F_mat(3,3,i)=this%F_mat(3,3,i)+rpos(3)*xi(3)*w*this%vol(j); + end do + + detK_inv = 1.0_WP/(K_mat(1,1)*(K_mat(2,2)*K_mat(3,3)-K_mat(2,3)*K_mat(3,2)) & + -K_mat(1,2)*(K_mat(2,1)*K_mat(3,3)-K_mat(2,3)*K_mat(3,1)) & + +K_mat(1,3)*(K_mat(2,1)*K_mat(3,2)-K_mat(2,2)*K_mat(3,1))) + K_inv(1,1) = (K_mat(2,2)*K_mat(3,3) - K_mat(2,3)*K_mat(3,2))*detK_inv + K_inv(2,1) = -(K_mat(2,1)*K_mat(3,3) - K_mat(2,3)*K_mat(3,1))*detK_inv + K_inv(3,1) = (K_mat(2,1)*K_mat(3,2) - K_mat(2,2)*K_mat(3,1))*detK_inv + K_inv(1,2) = -(K_mat(1,2)*K_mat(3,3) - K_mat(1,3)*K_mat(3,2))*detK_inv + K_inv(2,2) = (K_mat(1,1)*K_mat(3,3) - K_mat(1,3)*K_mat(3,1))*detK_inv + K_inv(3,2) = -(K_mat(1,1)*K_mat(3,2) - K_mat(1,2)*K_mat(3,1))*detK_inv + K_inv(1,3) = (K_mat(1,2)*K_mat(2,3) - K_mat(1,3)*K_mat(2,2))*detK_inv + K_inv(2,3) = -(K_mat(1,1)*K_mat(2,3) - K_mat(1,3)*K_mat(2,1))*detK_inv + K_inv(3,3) = (K_mat(1,1)*K_mat(2,2) - K_mat(1,2)*K_mat(2,1))*detK_inv + + this%F_mat(:,:,i) = MATMUL(this%F_mat(:,:,i),K_inv) + E_mat = 0.5_WP * (MATMUL(TRANSPOSE(this%F_mat(:,:,i)),this%F_mat(:,:,i))-I_mat) + traceE = E_mat(1,1) + E_mat(2,2) + E_mat(3,3) + S_mat = (kk-2.0_WP/3.0_WP*mu)*traceE*I_mat + 2.0_WP*mu*E_mat + this%PK_inv(:,:,i) = MATMUL(MATMUL(this%F_mat(:,:,i),S_mat),K_inv) + end do + this%wt_dil=this%wt_dil+(parallel_time()-t0) + ! I think here we just need to communicate PK_inv and F_mat, everything else can stay local + t0=parallel_time() + do e=1,3 + call this%halo%update(this%PK_inv(:,e,:),3,shifted=.false.) + end do + this%wt_halo=this%wt_halo+(parallel_time()-t0) + + ! Node-centered force sweep: each row computes its OWN force state t + ! (own theta, own mw) and scatters +t/-t; the neighbor's t arrives from + ! the neighbor's own row (locally or via the halo reduce below). + t0=parallel_time() + this%f=0.0_WP + do i=1,this%nown + ! ! Per-node J2 return factor from the LAGGED family norm. With + ! ! hardening (hard_mod>0) the surface radius grows with the node's + ! ! accumulated equivalent plastic strain lam_p (surface lagged one + ! ! substep like the norm: exact to O(H/3mu) per substep, and H<<3mu + ! ! for metals; stress-space equivalent of Peridigm's + ! ! elastic_plastic_hardening). The increment uses (1-beta)*strial = + ! ! the trial-stress excess, so the rate-independent limit matches the + ! ! classical radial return; (1-decay) is the Perzyna-realized + ! ! fraction. lam_p accumulates even at hard_mod=0 (free plastic- + ! ! strain diagnostic; forces unchanged there, bit-exact w/ flat yield). + ! beta=1.0_WP + ! if (plastic.and.do_j2) then + ! sYe2=(this%sigma_yield+this%hard_mod*this%lam_p(i))**2 + ! if (this%td2(i)*this%mw(i).gt.psi_fac*sYe2) then + ! beta=sqrt(psi_fac*sYe2/(this%td2(i)*this%mw(i))) + ! strial=sqrt(this%td2(i)*this%mw(i)/psi_fac) + ! this%lam_p(i)=this%lam_p(i)+(1.0_WP-beta)*(1.0_WP-decay)*strial*mu3i + ! end if + ! end if + + ! We are not currently doing the plastic behavior, so we can skip this + do e=this%ptr(i),this%ptr(i+1)-1 + if (this%dmg(e).ne.0_1) cycle + j=this%lst(e) + xi=this%x0(:,j)-this%x0(:,i) + rpos=this%y(:,j) -this%y(:,i) + zeta=sqrt(sum(xi**2)) + dY = sqrt(sum(rpos**2)) + if (dY.le.0.0_WP) cycle + e_b=dY-zeta + ! Brittle break on total stretch (e > s0*zeta), irreversible. + ! Each row breaks its OWN half-entry and increments its OWN node's + ! damage by 1/nb0 (nb0 = reference row length); the counterpart row + ! breaks its half independently -- the criterion is symmetric in + ! the endpoints, so both halves break in the same substep (for + ! image bonds, up to shift-association roundoff: a 1-ulp-marginal + ! bond may break one substep apart, a benign local transient -- + ! the intact half still applies its +/- pair, conserving momentum). + if (e_b.gt.this%s0*zeta) then + this%dmg(e)=1_1 + this%damage(i)=this%damage(i)+1.0_WP/real(this%ptr(i+1)-this%ptr(i),WP) + cycle + end if + w=omega(zeta,this%delta) + ! Now we compute forces, similar to before, but we only plus up the one particle instead of being slick with both + t1 = w*MATMUL(this%PK_inv(:,:,i),xi) + ! Force density 2->1 + t2 = w*MATMUL(this%PK_inv(:,:,j),xi) + ! Force correction term + z = rpos-MATMUL(this%F_mat(:,:,i),xi) + tc = w*(9.0_WP*kk/((Pi) * this%delta**4))*(dot_product(xi,z)/(sqrt(dot_product(xi,xi)))**3)*xi + ! Compute bond acceleration + this%f(:,i)=this%f(:,i)+(t1+t2+tc)*this%vol(j) + + end do + ! Remove forces acting in axes we dont have (for 2d cases) + end do + + this%wt_force=this%wt_force+(parallel_time()-t0) + + ! Assemble cross-rank pair forces (halo slots -> owners, add) + t0=parallel_time() + call this%halo%reduce(this%f,3) + this%wt_reduce=this%wt_reduce+(parallel_time()-t0) + + ! Short-range contact (walls + particle-particle), gather-only: adds + ! into owned f, no reduction (amrpd ordering: after the bond force) + if (this%use_contact) then + t0=parallel_time() + call this%contact_narrow(dt) + this%wt_contact=this%wt_contact+(parallel_time()-t0) + end if + + ! Second half-kick with the fresh force + t0=parallel_time() + do i=1,this%nown + if (this%flag(i).eq.PDC_IS_DEAD) cycle + if (iand(this%flag(i),PDC_INTEGRATES).ne.0) then + acc=this%gravity+(this%f(:,i)+this%ff(:,i))*rho_inv + this%v(:,i)=(1.0_WP-this%damping_rate)*this%v(:,i)+0.5_WP*dt*acc + end if + if (this%collapsed(1)) this%v(1,i)=0.0_WP + if (this%collapsed(2)) this%v(2,i)=0.0_WP + if (this%collapsed(3)) this%v(3,i)=0.0_WP + end do + this%wt_kick=this%wt_kick+(parallel_time()-t0) + + this%tot_time=this%tot_time+(parallel_time()-t_full) + end subroutine pd_advance + + !> Contact broad phase: displacement-triggered rebuild of the contact halo + !> and the candidate CSR. The trigger is one scalar allreduce per substep so + !> the (collective) rebuild decision is rank-consistent. rbuild = + !> 1.2*contact_dist + 2*cskin: engagement reach is bounded by d_eff*(1+0.2) + !> (the r_influ clip) and two nodes drifting cskin each can close 2*cskin + !> between rebuilds, so the candidate set provably contains every pair that + !> can produce force before the next rebuild. + !> + !> Discovery: allgather of per-rank owned-node bounds; for each (rank, + !> periodic-image offset) whose shifted bounds approach mine within rbuild, + !> OFFER my owned nodes in range as (gid, image key, shifted position). The + !> receiver keeps offers with an owned node within rbuild (binned test) and + !> builds the contact halo from the kept references via the standard pdhalo + !> protocol (chalo%nown = ntot, so contact slots append after graph slots). + !> Candidates are then binned over OWNED + CONTACT slots only -- the graph + !> halo is never binned, so bonded remote partners arrive as contact slots + !> when in range and double-counting is structurally impossible. + subroutine contact_broadphase(this) + use parallel, only: comm,rank,nproc,MPI_REAL_WP + use mpi_f08 + use messager, only: die + implicit none + class(pdsolver), intent(inout) :: this + real(WP) :: rbuild,drift + integer :: i,ierr + + if (this%contact_dist.le.0.0_WP) call die('[pdsolver contact] use_contact requires contact_dist > 0') + if (this%cskin.le.0.0_WP) this%cskin=0.5_WP*this%contact_dist + rbuild=1.2_WP*this%contact_dist+2.0_WP*this%cskin + + ! Displacement trigger (collective decision) + if (allocated(this%ylast)) then + drift=0.0_WP + do i=1,this%nown + drift=max(drift,sum((this%y(:,i)-this%ylast(:,i))**2)) + end do + drift=sqrt(drift) + else + drift=huge(1.0_WP) + end if + call MPI_ALLREDUCE(MPI_IN_PLACE,drift,1,MPI_REAL_WP,MPI_MAX,comm,ierr) + if (drift.le.this%cskin) return + this%nrebuild=this%nrebuild+1_I8 + + rebuild: block + real(WP), dimension(3) :: bl,bh,shift,pos_s + real(WP), allocatable :: allb(:,:),opos(:,:),rpos(:,:),kpos(:,:) + integer(I8), allocatable :: ogid(:),rgid(:),kgid(:) + integer, allocatable :: okey(:),rkey(:),kkey(:),kowner(:),slot(:) + integer, dimension(0:nproc-1) :: sc,rc,sd,rd + integer, dimension(0:nproc-1) :: sc3,rc3,sd3,rd3 + integer :: nmax(3),d,r,n1,n2,n3,noff,nrecv,nkeep,k,pass + ! Binning workspace (owned nodes for offer filtering, then combined + ! set for the candidate CSR) + real(WP), dimension(3) :: gl,hcell + integer, dimension(3) :: nc + integer, allocatable :: head(:),nxt(:) + + ! Owned bounds and their global exchange + bl=huge(1.0_WP); bh=-huge(1.0_WP) + do i=1,this%nown + bl=min(bl,this%y(:,i)); bh=max(bh,this%y(:,i)) + end do + allocate(allb(6,0:nproc-1)) + call MPI_ALLGATHER([bl,bh],6,MPI_REAL_WP,allb,6,MPI_REAL_WP,comm,ierr) + + ! Admissible periodic-image offsets for contact range + do d=1,3 + nmax(d)=0 + if (this%per(d).and.this%Ldom(d).gt.0.0_WP) nmax(d)=min(4,int(rbuild/this%Ldom(d))+1) + end do + + ! Offers: two passes (count, then fill), grouped by destination rank + do pass=1,2 + sc=0 + do r=0,nproc-1 + do n3=-nmax(3),nmax(3); do n2=-nmax(2),nmax(2); do n1=-nmax(1),nmax(1) + if (r.eq.rank.and.n1.eq.0.and.n2.eq.0.and.n3.eq.0) cycle + shift=[real(n1,WP)*this%Ldom(1),real(n2,WP)*this%Ldom(2),real(n3,WP)*this%Ldom(3)] + ! Shifted-bounds proximity prefilter + if (any(bl+shift-rbuild.gt.allb(4:6,r)).or.any(bh+shift+rbuild.lt.allb(1:3,r))) cycle + do i=1,this%nown + if (this%flag(i).eq.PDC_IS_DEAD) cycle + pos_s=this%y(:,i)+shift + if (any(pos_s.lt.allb(1:3,r)-rbuild).or.any(pos_s.gt.allb(4:6,r)+rbuild)) cycle + sc(r)=sc(r)+1 + if (pass.eq.2) then + ogid(sd(r)+sc(r))=this%gid(i) + okey(sd(r)+sc(r))=(n1+128)+(n2+128)*256+(n3+128)*65536 + opos(:,sd(r)+sc(r))=pos_s + end if + end do + end do; end do; end do + end do + if (pass.eq.1) then + sd(0)=0 + do r=1,nproc-1 + sd(r)=sd(r-1)+sc(r-1) + end do + noff=sum(sc) + allocate(ogid(max(noff,1)),okey(max(noff,1)),opos(3,max(noff,1))) + end if + end do + + ! Exchange offers (gid, key, shifted position) + call MPI_ALLTOALL(sc,1,MPI_INTEGER,rc,1,MPI_INTEGER,comm,ierr) + rd(0)=0 + do r=1,nproc-1 + rd(r)=rd(r-1)+rc(r-1) + end do + nrecv=sum(rc) + allocate(rgid(max(nrecv,1)),rkey(max(nrecv,1)),rpos(3,max(nrecv,1))) + call MPI_ALLTOALLV(ogid,sc,sd,MPI_INTEGER8,rgid,rc,rd,MPI_INTEGER8,comm,ierr) + call MPI_ALLTOALLV(okey,sc,sd,MPI_INTEGER, rkey,rc,rd,MPI_INTEGER, comm,ierr) + sc3=3*sc; sd3=3*sd; rc3=3*rc; rd3=3*rd + call MPI_ALLTOALLV(opos,sc3,sd3,MPI_REAL_WP,rpos,rc3,rd3,MPI_REAL_WP,comm,ierr) + deallocate(ogid,okey,opos) + + ! Filter offers: keep those with an owned node within rbuild. + ! Bin owned nodes (cell size >= rbuild so a +/-1 cell sweep suffices; + ! dims clamped so degenerate/huge extents stay bounded). + call setup_bins(bl,bh,rbuild,gl,hcell,nc) + allocate(head(nc(1)*nc(2)*nc(3)),nxt(max(this%nown,1))) + head=0 + do i=1,this%nown + if (this%flag(i).eq.PDC_IS_DEAD) cycle + k=cell_of(this%y(:,i),gl,hcell,nc) + nxt(i)=head(k); head(k)=i + end do + allocate(kgid(max(nrecv,1)),kkey(max(nrecv,1)),kowner(max(nrecv,1)),kpos(3,max(nrecv,1))) + nkeep=0 + do r=0,nproc-1 + do i=rd(r)+1,rd(r)+rc(r) + if (near_owned(rpos(:,i),rbuild,gl,hcell,nc,head,nxt)) then + nkeep=nkeep+1 + kgid(nkeep)=rgid(i); kkey(nkeep)=rkey(i); kowner(nkeep)=r; kpos(:,nkeep)=rpos(:,i) + end if + end do + end do + deallocate(rgid,rkey,rpos,head,nxt) + + ! Rebuild the contact halo (slots append after graph slots: nown=ntot) + call this%chalo%finalize() + allocate(slot(max(nkeep,1))) + call this%chalo%build(this%ntot,this%ohash,nkeep,kgid,kkey,kowner,this%Ldom,this%per,slot) + this%nchalo=this%chalo%nhalo + + ! Extend y and v to cover contact slots; stamp slot positions from the + ! kept offers (current values -- chalo%update refreshes each substep) + resize_state: block + real(WP), allocatable :: a2(:,:) + integer :: ntc + ntc=this%ntot+this%nchalo + allocate(a2(3,max(ntc,1))); a2=0.0_WP + a2(:,1:this%ntot)=this%y(:,1:this%ntot) + call move_alloc(a2,this%y) + allocate(a2(3,max(ntc,1))); a2=0.0_WP + a2(:,1:this%nown)=this%v(:,1:this%nown) + call move_alloc(a2,this%v) + do k=1,nkeep + this%y(:,this%ntot+slot(k))=kpos(:,k) + end do + end block resize_state + deallocate(kgid,kkey,kowner,kpos,slot) + + ! Candidate CSR over the contact-visible set: owned nodes (indices + ! 1..nown) + contact slots (ntot+1..ntot+nchalo). Two passes. + candidates: block + integer :: ns,m,jj,cnt,ic,jc,kc,c1,c2,c3 + integer, allocatable :: midx(:) + real(WP), dimension(3) :: blc,bhc + ns=this%nown+this%nchalo + allocate(midx(max(ns,1))) + do m=1,this%nown + midx(m)=m + end do + do m=1,this%nchalo + midx(this%nown+m)=this%ntot+m + end do + blc=bl; bhc=bh + do m=this%nown+1,ns + blc=min(blc,this%y(:,midx(m))); bhc=max(bhc,this%y(:,midx(m))) + end do + call setup_bins(blc,bhc,rbuild,gl,hcell,nc) + allocate(head(nc(1)*nc(2)*nc(3)),nxt(max(ns,1))) + head=0 + do m=1,ns + if (m.le.this%nown) then + if (this%flag(m).eq.PDC_IS_DEAD) cycle + end if + k=cell_of(this%y(:,midx(m)),gl,hcell,nc) + nxt(m)=head(k); head(k)=m + end do + if (allocated(this%cptr)) deallocate(this%cptr) + if (allocated(this%clst)) deallocate(this%clst) + allocate(this%cptr(this%nown+1)) + do pass=1,2 + do i=1,this%nown + cnt=0 + if (this%flag(i).eq.PDC_IS_DEAD) then + if (pass.eq.1) this%cptr(i+1)=0 + cycle + end if + ic=min(nc(1),max(1,int((this%y(1,i)-gl(1))/hcell(1))+1)) + jc=min(nc(2),max(1,int((this%y(2,i)-gl(2))/hcell(2))+1)) + kc=min(nc(3),max(1,int((this%y(3,i)-gl(3))/hcell(3))+1)) + do c3=max(1,kc-1),min(nc(3),kc+1); do c2=max(1,jc-1),min(nc(2),jc+1); do c1=max(1,ic-1),min(nc(1),ic+1) + m=head(c1+nc(1)*(c2-1)+nc(1)*nc(2)*(c3-1)) + do while (m.gt.0) + jj=midx(m) + if (jj.ne.i) then + if (sum((this%y(:,jj)-this%y(:,i))**2).le.rbuild**2) then + cnt=cnt+1 + if (pass.eq.2) this%clst(this%cptr(i)+cnt-1)=jj + end if + end if + m=nxt(m) + end do + end do; end do; end do + if (pass.eq.1) this%cptr(i+1)=cnt ! provisional count + end do + if (pass.eq.1) then + this%cptr(1)=1 + do i=1,this%nown + this%cptr(i+1)=this%cptr(i)+this%cptr(i+1) + end do + allocate(this%clst(max(this%cptr(this%nown+1)-1,1))) + end if + end do + deallocate(midx,head,nxt) + end block candidates + + ! Snapshot positions for the drift trigger + if (allocated(this%ylast)) deallocate(this%ylast) + allocate(this%ylast(3,max(this%nown,1))) + this%ylast(:,1:this%nown)=this%y(:,1:this%nown) + deallocate(allb) + end block rebuild + + contains + + !> Any owned node within r of position p? (binned +/-1 cell sweep) + function near_owned(p,r,gl,h,nc,head,nxt) result(hit) + real(WP), dimension(3), intent(in) :: p,gl,h + real(WP), intent(in) :: r + integer, dimension(3), intent(in) :: nc + integer, intent(in) :: head(:),nxt(:) + logical :: hit + integer :: c(3),d,c1,c2,c3,m + hit=.false. + do d=1,3 + c(d)=min(nc(d),max(1,int((p(d)-gl(d))/h(d))+1)) + end do + do c3=max(1,c(3)-1),min(nc(3),c(3)+1); do c2=max(1,c(2)-1),min(nc(2),c(2)+1); do c1=max(1,c(1)-1),min(nc(1),c(1)+1) + m=head(c1+nc(1)*(c2-1)+nc(1)*nc(2)*(c3-1)) + do while (m.gt.0) + if (sum((this%y(:,m)-p)**2).le.r**2) then + hit=.true. + return + end if + m=nxt(m) + end do + end do; end do; end do + end function near_owned + + end subroutine contact_broadphase + + !> Contact narrow phase: soft-sphere walls + particle-particle over the + !> candidate CSR, gather-only (soft-sphere penalty ported from amrlpt's collision model; + !> IB contact arrives with the coupling layer). Adds force/volume into owned + !> f. Walls use e_w with d_eff = 0.5*contact_dist and m_eff = m1; pairs use + !> e_n with d_eff = contact_dist and m_eff = 0.5*m1 (m1 = rho*vol(i), + !> matching amrpd's uniform rho*dV on a uniform lattice). + subroutine contact_narrow(this,dt) + use mathtools, only: Pi + implicit none + class(pdsolver), intent(inout) :: this + real(WP), intent(in) :: dt + real(WP) :: tau,k_n,eta_n,k_w,eta_w,d_eff_w,m1 + real(WP), dimension(3) :: r1,v1,floc,r2 + real(WP), dimension(3), parameter :: vzero=[0.0_WP,0.0_WP,0.0_WP] + integer :: i,k,j + if (this%contact_dist.le.0.0_WP.or.dt.le.0.0_WP) return + if (this%e_n.le.0.0_WP.or.this%e_w.le.0.0_WP) return + if (this%tau_col.gt.0.0_WP) then + tau=this%tau_col + else + tau=5.0_WP*dt + end if + k_n =(Pi**2+log(this%e_n)**2)/tau**2 + eta_n=-2.0_WP*log(this%e_n)/tau + k_w =(Pi**2+log(this%e_w)**2)/tau**2 + eta_w=-2.0_WP*log(this%e_w)/tau + d_eff_w=0.5_WP*this%contact_dist + do i=1,this%nown + if (this%flag(i).eq.PDC_IS_DEAD) cycle + m1=this%rho*this%vol(i) + r1=this%y(:,i); v1=this%v(:,i) + floc=0.0_WP + ! Wall collisions on faces flagged as walls (virtual partner on the + ! wall directly normal to the node) + if (this%lo_bc(1).eq.1) then; r2=[this%dom_lo(1),r1(2),r1(3)]; call apply_col(k_w,eta_w,d_eff_w,m1,r2,vzero); end if + if (this%hi_bc(1).eq.1) then; r2=[this%dom_hi(1),r1(2),r1(3)]; call apply_col(k_w,eta_w,d_eff_w,m1,r2,vzero); end if + if (this%lo_bc(2).eq.1) then; r2=[r1(1),this%dom_lo(2),r1(3)]; call apply_col(k_w,eta_w,d_eff_w,m1,r2,vzero); end if + if (this%hi_bc(2).eq.1) then; r2=[r1(1),this%dom_hi(2),r1(3)]; call apply_col(k_w,eta_w,d_eff_w,m1,r2,vzero); end if + if (this%lo_bc(3).eq.1) then; r2=[r1(1),r1(2),this%dom_lo(3)]; call apply_col(k_w,eta_w,d_eff_w,m1,r2,vzero); end if + if (this%hi_bc(3).eq.1) then; r2=[r1(1),r1(2),this%dom_hi(3)]; call apply_col(k_w,eta_w,d_eff_w,m1,r2,vzero); end if + ! Particle-particle via the candidate CSR + do k=this%cptr(i),this%cptr(i+1)-1 + j=this%clst(k) + call apply_col(k_n,eta_n,this%contact_dist,0.5_WP*m1,this%y(:,j),this%v(:,j)) + end do + ! Accumulate as force/volume (matches bond force units) + this%f(:,i)=this%f(:,i)+floc/this%vol(i) + end do + + contains + + !> Soft-sphere normal force from virtual partner (r2_in, v2_in) onto i. + !> Host-associated r1, v1, dt, floc. + subroutine apply_col(kk,ee,d_eff,m_eff,r2_in,v2_in) + real(WP), intent(in) :: kk,ee,d_eff,m_eff + real(WP), dimension(3), intent(in) :: r2_in,v2_in + real(WP) :: d12,rnv,r_influ,delta_n + real(WP), dimension(3) :: n12,v12,f_n + d12=norm2(r2_in-r1) + if (d12.lt.10.0_WP*epsilon(d12)) return ! self-overlap guard + n12=(r2_in-r1)/d12 + v12=v1-v2_in + rnv=dot_product(v12,n12) + r_influ=min(abs(rnv)*dt,0.2_WP*d_eff) + delta_n=min(d_eff+r_influ-d12,this%clip_col*d_eff) + if (delta_n.le.0.0_WP) return + f_n=(-m_eff*kk*delta_n-m_eff*ee*rnv)*n12 + floc=floc+f_n + end subroutine apply_col + + end subroutine contact_narrow + + !> Binding CFL: elastic wave + scaled convective (limits 0.5 / 0.1) + subroutine get_cfl(this,dt,cfl) + use parallel, only: comm,MPI_REAL_WP + use mpi_f08, only: MPI_ALLREDUCE,MPI_MAX,MPI_IN_PLACE + implicit none + class(pdsolver), intent(inout) :: this + real(WP), intent(in) :: dt + real(WP), intent(out) :: cfl + real(WP), parameter :: CFL_scale_conv=5.0_WP + real(WP) :: K_bulk,mu_shear,c_p,dp_inv,vmax + integer :: i,ierr + K_bulk =this%elastic_modulus/(3.0_WP*(1.0_WP-2.0_WP*this%poisson_ratio)) + mu_shear=this%elastic_modulus/(2.0_WP*(1.0_WP+this%poisson_ratio)) + c_p =sqrt((K_bulk+4.0_WP*mu_shear/3.0_WP)/this%rho) + dp_inv =1.0_WP/this%dV**(1.0_WP/3.0_WP) + this%CFLe=c_p*dp_inv*dt + this%CFLp=0.0_WP + do i=1,this%nown + if (this%flag(i).eq.PDC_IS_DEAD) cycle + vmax=max(abs(this%v(1,i)),abs(this%v(2,i)),abs(this%v(3,i))) + this%CFLp=max(this%CFLp,vmax*dp_inv) + end do + call MPI_ALLREDUCE(MPI_IN_PLACE,this%CFLp,1,MPI_REAL_WP,MPI_MAX,comm,ierr) + this%CFLp=this%CFLp*dt + cfl=max(CFL_scale_conv*this%CFLp,this%CFLe) + end subroutine get_cfl + + !> Global counts, velocity max, and timer reduction (+reset). Collective. + subroutine get_info(this) + use parallel, only: comm,MPI_REAL_WP + use mpi_f08, only: MPI_ALLREDUCE,MPI_MAX,MPI_MIN,MPI_SUM,MPI_IN_PLACE,MPI_INTEGER8 + implicit none + class(pdsolver), intent(inout) :: this + integer :: i,ierr + integer(I8) :: np_loc + real(WP), dimension(3) :: vmin,vmax + np_loc=0_I8 + vmin=huge(1.0_WP); vmax=-huge(1.0_WP) + this%EPmax=0.0_WP + do i=1,this%nown + if (this%flag(i).eq.PDC_IS_DEAD) cycle + np_loc=np_loc+1_I8 + vmin=min(vmin,this%v(:,i)); vmax=max(vmax,this%v(:,i)) + this%EPmax=max(this%EPmax,this%lam_p(i)) + end do + this%np=np_loc + call MPI_ALLREDUCE(MPI_IN_PLACE,this%np,1,MPI_INTEGER8,MPI_SUM,comm,ierr) + call MPI_ALLREDUCE(MPI_IN_PLACE,this%EPmax,1,MPI_REAL_WP,MPI_MAX,comm,ierr) + call MPI_ALLREDUCE(MPI_IN_PLACE,vmin,3,MPI_REAL_WP,MPI_MIN,comm,ierr) + call MPI_ALLREDUCE(MPI_IN_PLACE,vmax,3,MPI_REAL_WP,MPI_MAX,comm,ierr) + if (this%np.eq.0_I8) then + vmin=0.0_WP; vmax=0.0_WP + end if + this%Umin=vmin(1); this%Umax=vmax(1) + this%Vmin=vmin(2); this%Vmax=vmax(2) + this%Wmin=vmin(3); this%Wmax=vmax(3) + ! Broken half-entry census (each broken bond counts twice, except + ! self-image bonds which have a single half-entry) + count_broken: block + integer(I8) :: nb_loc + integer :: e,i2,j2 + ! Half-entry count (internal) and EXACT broken-bond census: each bond + ! is counted at exactly one of its two half-entries -- the one whose + ! node gid is lower (ties = self-image bonds, counted at the + ! positive-offset image so each appears once) + nb_loc=0_I8; this%nb_broken=0_I8 + do i2=1,this%nown + do e=this%ptr(i2),this%ptr(i2+1)-1 + if (this%dmg(e).eq.0_1) cycle + nb_loc=nb_loc+1_I8 + j2=this%lst(e) + if (this%gid(i2).lt.this%gid(j2)) then + this%nb_broken=this%nb_broken+1_I8 + else if (this%gid(i2).eq.this%gid(j2)) then + if (j2.gt.this%nown) then + if (shift_positive(this%halo%shift(:,j2-this%nown))) this%nb_broken=this%nb_broken+1_I8 + end if + end if + end do + end do + this%nbroken=nb_loc + call MPI_ALLREDUCE(MPI_IN_PLACE,this%nbroken,1,MPI_INTEGER8,MPI_SUM,comm,ierr) + call MPI_ALLREDUCE(MPI_IN_PLACE,this%nb_broken,1,MPI_INTEGER8,MPI_SUM,comm,ierr) + end block count_broken + ! Timers: max (and min for the compute-heavy phases) across ranks, then reset + call MPI_ALLREDUCE(this%wt_kick, this%wtmax_kick, 1,MPI_REAL_WP,MPI_MAX,comm,ierr) + call MPI_ALLREDUCE(this%wt_halo, this%wtmax_halo, 1,MPI_REAL_WP,MPI_MAX,comm,ierr) + call MPI_ALLREDUCE(this%wt_dil, this%wtmax_dil, 1,MPI_REAL_WP,MPI_MAX,comm,ierr) + call MPI_ALLREDUCE(this%wt_dil, this%wtmin_dil, 1,MPI_REAL_WP,MPI_MIN,comm,ierr) + call MPI_ALLREDUCE(this%wt_force, this%wtmax_force, 1,MPI_REAL_WP,MPI_MAX,comm,ierr) + call MPI_ALLREDUCE(this%wt_force, this%wtmin_force, 1,MPI_REAL_WP,MPI_MIN,comm,ierr) + call MPI_ALLREDUCE(this%wt_reduce,this%wtmax_reduce,1,MPI_REAL_WP,MPI_MAX,comm,ierr) + call MPI_ALLREDUCE(this%wt_contact,this%wtmax_contact,1,MPI_REAL_WP,MPI_MAX,comm,ierr) + call MPI_ALLREDUCE(this%wt_broad, this%wtmax_broad, 1,MPI_REAL_WP,MPI_MAX,comm,ierr) + call MPI_ALLREDUCE(this%tot_time, this%maxtot_time, 1,MPI_REAL_WP,MPI_MAX,comm,ierr) + + this%wt_kick=0.0_WP; this%wt_halo=0.0_WP; this%wt_dil=0.0_WP; this%wt_force=0.0_WP; this%wt_reduce=0.0_WP + this%wt_contact=0.0_WP; this%wt_broad=0.0_WP; this%tot_time=0.0_WP + ! Contact-service size census (visibility into the fragmentation-driven + ! degradation mode of the static graph partition) + contact_census: block + integer(I8) :: tmp + this%nchalo_glob=int(this%nchalo,I8) + call MPI_ALLREDUCE(MPI_IN_PLACE,this%nchalo_glob,1,MPI_INTEGER8,MPI_SUM,comm,ierr) + tmp=0_I8 + if (allocated(this%cptr)) tmp=int(this%cptr(this%nown+1)-1,I8) + this%ncand_glob=tmp + call MPI_ALLREDUCE(MPI_IN_PLACE,this%ncand_glob,1,MPI_INTEGER8,MPI_SUM,comm,ierr) + end block contact_census + end subroutine get_info + + !> Release all storage + subroutine finalize(this) + implicit none + class(pdsolver), intent(inout) :: this + if (allocated(this%gid)) deallocate(this%gid) + if (allocated(this%x0)) deallocate(this%x0) + if (allocated(this%y)) deallocate(this%y) + if (allocated(this%v)) deallocate(this%v) + if (allocated(this%f)) deallocate(this%f) + if (allocated(this%ff)) deallocate(this%ff) + if (allocated(this%vol)) deallocate(this%vol) + if (allocated(this%mw)) deallocate(this%mw) + if (allocated(this%theta)) deallocate(this%theta) + if (allocated(this%damage))deallocate(this%damage) + if (allocated(this%lam_p)) deallocate(this%lam_p) + if (allocated(this%alive)) deallocate(this%alive) + if (allocated(this%flag)) deallocate(this%flag) + if (allocated(this%ptr)) deallocate(this%ptr) + if (allocated(this%lst)) deallocate(this%lst) + if (allocated(this%dmg)) deallocate(this%dmg) + if (allocated(this%e_v)) deallocate(this%e_v) + if (allocated(this%td2)) deallocate(this%td2) + if (allocated(this%td2a)) deallocate(this%td2a) + if (allocated(this%cptr)) deallocate(this%cptr) + if (allocated(this%clst)) deallocate(this%clst) + if (allocated(this%ylast)) deallocate(this%ylast) + if (allocated(this%rextra_tmp)) deallocate(this%rextra_tmp) + call this%ohash%finalize() + call this%dir%finalize() + call this%halo%finalize() + call this%chalo%finalize() + this%nown=0; this%nhalo=0; this%ntot=0; this%nchalo=0 + end subroutine finalize + + + !> Mirror synchronization (the coupling bridge). Collective, once per FLUID + !> step. The caller walks its face particles (AMReX container on the + !> fluid decomposition) and passes per particle: gid, core owner rank (read + !> from the face particle's repurposed flag tag), and the F_fluid it interpolated + !> from the grid. This routine routes F_fluid to the owning nodes (held in + !> ff across the subsequent PD subcycles) and replies with each node's + !> current (pos, vel, damage, alive), returned aligned with the caller's + !> input order for direct write-back into the face particles. + subroutine exchange(this,nm,mgid,mowner,mff,mpos,mvel,mdmg,malive) + use parallel, only: comm,nproc,MPI_REAL_WP + use messager, only: die + use mpi_f08 + implicit none + class(pdsolver), intent(inout) :: this + integer, intent(in) :: nm + integer(I8), intent(in) :: mgid(:) + integer, intent(in) :: mowner(:) + real(WP), intent(in) :: mff(:,:) + real(WP), intent(out) :: mpos(:,:),mvel(:,:) + real(WP), intent(out) :: mdmg(:),malive(:) + integer, dimension(0:nproc-1) :: sc,rc,sd,rd + integer, dimension(0:nproc-1) :: scw,rcw,sdw,rdw + integer, allocatable :: pos(:),qpos(:) + integer(I8), allocatable :: sg(:),rg(:) + real(WP), allocatable :: sff(:,:),rff(:,:),srep(:,:),rrep(:,:) + integer :: i,r,nr,idx,ierr + + ! Count and pack by owner, remembering each entry's packed slot + sc=0 + do i=1,nm + sc(mowner(i))=sc(mowner(i))+1 + end do + call MPI_ALLTOALL(sc,1,MPI_INTEGER,rc,1,MPI_INTEGER,comm,ierr) + sd(0)=0; rd(0)=0 + do r=1,nproc-1 + sd(r)=sd(r-1)+sc(r-1); rd(r)=rd(r-1)+rc(r-1) + end do + allocate(pos(0:nproc-1),qpos(max(nm,1))) + allocate(sg(max(nm,1)),sff(3,max(nm,1))) + pos=sd + do i=1,nm + r=mowner(i); pos(r)=pos(r)+1 + sg(pos(r))=mgid(i); sff(:,pos(r))=mff(:,i); qpos(i)=pos(r) + end do + nr=sum(rc) + allocate(rg(max(nr,1)),rff(3,max(nr,1))) + call MPI_ALLTOALLV(sg,sc,sd,MPI_INTEGER8,rg,rc,rd,MPI_INTEGER8,comm,ierr) + scw=3*sc; sdw=3*sd; rcw=3*rc; rdw=3*rd + call MPI_ALLTOALLV(sff,scw,sdw,MPI_REAL_WP,rff,rcw,rdw,MPI_REAL_WP,comm,ierr) + + ! Owner side: ingest F_fluid, build the state reply in arrival order + allocate(rrep(8,max(nr,1))) + do i=1,nr + idx=this%ohash%lookup(rg(i)) + if (idx.lt.1) call die('[pdsolver exchange] face gid not owned by tagged rank') + this%ff(:,idx)=rff(:,i) + rrep(1:3,i)=this%y(:,idx) + rrep(4:6,i)=this%v(:,idx) + rrep(7,i) =this%damage(idx) + rrep(8,i) =this%alive(idx) + end do + + ! Reply along the reverse route; unpack to the caller's original order + allocate(srep(8,max(nm,1))) + scw=8*rc; sdw=8*rd; rcw=8*sc; rdw=8*sd + call MPI_ALLTOALLV(rrep,scw,sdw,MPI_REAL_WP,srep,rcw,rdw,MPI_REAL_WP,comm,ierr) + do i=1,nm + mpos(:,i) =srep(1:3,qpos(i)) + mvel(:,i) =srep(4:6,qpos(i)) + mdmg(i) =srep(7,qpos(i)) + malive(i) =srep(8,qpos(i)) + end do + deallocate(pos,qpos,sg,sff,rg,rff,rrep,srep) + end subroutine exchange + + + !> Owner-rank lookup for arbitrary node gids via the persistent directory. + !> Collective. Drivers use it to re-stamp face routing tags after restart. + subroutine query_owners(this,n,gids,owners) + implicit none + class(pdsolver), intent(inout) :: this + integer, intent(in) :: n + integer(I8), intent(in) :: gids(:) + integer, intent(out) :: owners(:) + call this%dir%query(n,gids,owners) + end subroutine query_owners + + !> Checkpoint the core under /: per-rank stream files + root + !> header. Records are GID-SPACE (no local indices, no partition info) -- + !> nodes: (gid, flag, x0, y, v, f, vol, damage, td2, lam_p); half-entries: + !> (node_gid, nbr_gid, image_key, dmg, e_v), the image key reconstructed + !> from the halo slot's shift. Rank-count portable on read. Format v2 + !> (v1 = pre-hardening, no lam_p record; read_state accepts both). + subroutine write_state(this,dirname) + use parallel, only: rank,nproc,amRoot + use messager, only: die + use string, only: str_medium + implicit none + class(pdsolver), intent(inout) :: this + character(len=*), intent(in) :: dirname + character(len=str_medium) :: fname + integer :: iunit,ios,i,e,j,nhe + integer, allocatable :: hkey(:) + integer(I8), allocatable :: hnode(:),hnbr(:) + ! Half-entries in gid space + nhe=this%ptr(this%nown+1)-1 + allocate(hnode(max(nhe,1)),hnbr(max(nhe,1)),hkey(max(nhe,1))) + do i=1,this%nown + do e=this%ptr(i),this%ptr(i+1)-1 + j=this%lst(e) + hnode(e)=this%gid(i) + hnbr(e) =this%gid(j) + if (j.le.this%nown) then + hkey(e)=PDHALO_KEY0 + else + hkey(e)=key_of_shift(this%halo%shift(:,j-this%nown),this%Ldom) + end if + end do + end do + ! Per-rank stream file + ! All solid state lives under /pd/ (root creates it) + make_dir: block + use parallel, only: comm + use mpi_f08, only: MPI_BARRIER + integer :: ierr2 + if (amRoot) call execute_command_line('mkdir -p '//trim(dirname)//'/pd') + call MPI_BARRIER(comm,ierr2) + end block make_dir + write(fname,'(a,"/pd/pd_",i7.7,".bin")') trim(dirname),rank + open(newunit=iunit,file=trim(fname),form='unformatted',access='stream',status='replace',iostat=ios) + if (ios.ne.0) call die('[pdsolver write_state] cannot open '//trim(fname)) + write(iunit) this%nown,nhe + write(iunit) this%gid(1:this%nown) + write(iunit) this%flag(1:this%nown) + write(iunit) this%x0(:,1:this%nown) + write(iunit) this%y(:,1:this%nown) + write(iunit) this%v(:,1:this%nown) + write(iunit) this%f(:,1:this%nown) + write(iunit) this%vol(1:this%nown) + write(iunit) this%damage(1:this%nown) + write(iunit) this%td2(1:this%nown) + write(iunit) this%lam_p(1:this%nown) + write(iunit) hnode(1:nhe) + write(iunit) hnbr(1:nhe) + write(iunit) hkey(1:nhe) + write(iunit) this%dmg(1:nhe) + write(iunit) this%e_v(1:nhe) + close(iunit) + deallocate(hnode,hnbr,hkey) + ! Root header (file count for portable round-robin reads) + if (amRoot) then + open(newunit=iunit,file=trim(dirname)//'/pd/header',form='formatted',status='replace',iostat=ios) + if (ios.ne.0) call die('[pdsolver write_state] cannot open header') + write(iunit,'(a)') 'pdsolver checkpoint v2' + write(iunit,'(i0)') nproc + close(iunit) + end if + contains + !> Reconstruct the packed image key from a slot shift vector + pure function key_of_shift(s,L) result(k) + implicit none + real(WP), dimension(3), intent(in) :: s,L + integer :: k,n1,n2,n3 + n1=0; n2=0; n3=0 + if (L(1).gt.0.0_WP) n1=nint(s(1)/L(1)) + if (L(2).gt.0.0_WP) n2=nint(s(2)/L(2)) + if (L(3).gt.0.0_WP) n3=nint(s(3)/L(3)) + k=(n1+128)+(n2+128)*256+(n3+128)*65536 + end function key_of_shift + end subroutine write_state + + !> Restore the core from a checkpoint written by write_state. Collective; + !> rank-count portable: files read round-robin, nodes re-partitioned by + !> Morton order of the reference configuration, half-entries routed to + !> their owners, CSR/halo rebuilt via assemble with the loaded per-entry + !> state. The caller must configure the solver (initialize + material/ + !> contact/plastic component assignments) BEFORE calling this. + subroutine read_state(this,dirname) + use parallel, only: comm,rank,nproc,MPI_REAL_WP + use messager, only: die + use string, only: str_medium + use mpi_f08 + implicit none + class(pdsolver), intent(inout) :: this + character(len=*), intent(in) :: dirname + character(len=str_medium) :: fname,line + integer :: nfiles,iunit,ios,f,i,r,ierr,iver + integer :: nn,nhe,nf,nhf + integer(I8), allocatable :: gid(:),hnode(:),hnbr(:) + integer, allocatable :: flag(:),hkey(:),owner(:) + real(WP), allocatable :: x0(:,:),yy(:,:),vv(:,:),ffb(:,:),vol(:),dmgn(:),td2n(:),lamn(:) + real(WP), allocatable :: hev(:) + integer(1), allocatable :: hdmg(:) + + ! Resolve derived configuration (restart-safe shared path) + call this%derive_config() + + ! Header: number of files written + format version (v1 = no lam_p record) + nfiles=0; iver=1 + if (rank.eq.0) then + open(newunit=iunit,file=trim(dirname)//'/pd/header',form='formatted',status='old',iostat=ios) + if (ios.ne.0) call die('[pdsolver read_state] no pd/header under '//trim(dirname)) + read(iunit,'(a)') line + if (index(line,'v2').gt.0) iver=2 + read(iunit,*) nfiles + close(iunit) + end if + call MPI_BCAST(nfiles,1,MPI_INTEGER,0,comm,ierr) + call MPI_BCAST(iver,1,MPI_INTEGER,0,comm,ierr) + + ! Read my round-robin share of the files, concatenating records + nn=0; nhe=0 + do f=rank,nfiles-1,nproc + write(fname,'(a,"/pd/pd_",i7.7,".bin")') trim(dirname),f + open(newunit=iunit,file=trim(fname),form='unformatted',access='stream',status='old',iostat=ios) + if (ios.ne.0) call die('[pdsolver read_state] cannot open '//trim(fname)) + read(iunit) nf,nhf + call grow_i8(gid,nn,nf); call grow_i4(flag,nn,nf) + call grow_r2(x0,nn,nf); call grow_r2(yy,nn,nf) + call grow_r2(vv,nn,nf); call grow_r2(ffb,nn,nf) + call grow_r1(vol,nn,nf); call grow_r1(dmgn,nn,nf); call grow_r1(td2n,nn,nf) + call grow_r1(lamn,nn,nf) + read(iunit) gid(nn+1:nn+nf) + read(iunit) flag(nn+1:nn+nf) + read(iunit) x0(:,nn+1:nn+nf) + read(iunit) yy(:,nn+1:nn+nf) + read(iunit) vv(:,nn+1:nn+nf) + read(iunit) ffb(:,nn+1:nn+nf) + read(iunit) vol(nn+1:nn+nf) + read(iunit) dmgn(nn+1:nn+nf) + read(iunit) td2n(nn+1:nn+nf) + if (iver.ge.2) then + read(iunit) lamn(nn+1:nn+nf) + else + lamn(nn+1:nn+nf)=0.0_WP + end if + call grow_i8(hnode,nhe,nhf); call grow_i8(hnbr,nhe,nhf) + call grow_i4(hkey,nhe,nhf); call grow_i1(hdmg,nhe,nhf); call grow_r1(hev,nhe,nhf) + read(iunit) hnode(nhe+1:nhe+nhf) + read(iunit) hnbr(nhe+1:nhe+nhf) + read(iunit) hkey(nhe+1:nhe+nhf) + read(iunit) hdmg(nhe+1:nhe+nhf) + read(iunit) hev(nhe+1:nhe+nhf) + close(iunit) + nn=nn+nf; nhe=nhe+nhf + end do + if (.not.allocated(gid)) then ! ranks with no files still join collectives + allocate(gid(1),flag(1),x0(3,1),yy(3,1),vv(3,1),ffb(3,1),vol(1),dmgn(1),td2n(1),lamn(1)) + allocate(hnode(1),hnbr(1),hkey(1),hdmg(1),hev(1)) + end if + + ! Re-partition nodes by Morton order of the REFERENCE configuration and + ! route the full records (pd_partition routes the set_nodes payload; the + ! remaining fields ride a second, identically-ordered exchange) + repartition: block + integer(I8), allocatable :: rgid(:) + real(WP), allocatable :: rx0(:,:),rvv(:,:),rvol(:),extra(:,:) + integer, allocatable :: rflag(:) + integer, dimension(0:nproc-1) :: sc,rc,sd,rd,scw,rcw,sdw,rdw + integer, allocatable :: pos(:) + integer :: nr + allocate(owner(max(nn,1))) + call pd_partition(nn,gid,x0,vv,flag,vol,owner,nr,rgid,rx0,rvv,rflag,rvol) + ! Second exchange: (y, f, damage, td2) = 8 reals, packed in the same + ! per-destination input order as pd_partition's own packing + sc=0 + do i=1,nn + sc(owner(i))=sc(owner(i))+1 + end do + call MPI_ALLTOALL(sc,1,MPI_INTEGER,rc,1,MPI_INTEGER,comm,ierr) + sd(0)=0; rd(0)=0 + do r=1,nproc-1 + sd(r)=sd(r-1)+sc(r-1); rd(r)=rd(r-1)+rc(r-1) + end do + allocate(pos(0:nproc-1),extra(9,max(nn,1)),this%rextra_tmp(9,max(nr,1))) + pos=sd + do i=1,nn + r=owner(i); pos(r)=pos(r)+1 + extra(1:3,pos(r))=yy(:,i) + extra(4:6,pos(r))=ffb(:,i) + extra(7,pos(r)) =dmgn(i) + extra(8,pos(r)) =td2n(i) + extra(9,pos(r)) =lamn(i) + end do + scw=9*sc; sdw=9*sd; rcw=9*rc; rdw=9*rd + call MPI_ALLTOALLV(extra,scw,sdw,MPI_REAL_WP,this%rextra_tmp,rcw,rdw,MPI_REAL_WP,comm,ierr) + ! Load the routed nodes, then overlay the restart-only fields + call this%set_nodes(nr,rgid,rx0,rvv,rflag,rvol) + do i=1,nr + this%y(:,i) =this%rextra_tmp(1:3,i) + this%f(:,i) =this%rextra_tmp(4:6,i) + this%damage(i)=this%rextra_tmp(7,i) + end do + deallocate(pos,extra,rgid,rx0,rvv,rflag,rvol) + end block repartition + + ! Register the directory over the new partition, route half-entries to + ! their owners (state travels along), and rebuild CSR/halo/reference + route_and_assemble: block + integer(I8), allocatable :: rnode(:),rnbr(:) + integer, allocatable :: rkey(:),howner(:) + real(WP), allocatable :: rev(:) + integer(1), allocatable :: rdmg(:) + integer, dimension(0:nproc-1) :: sc,rc,sd,rd + integer, allocatable :: pos(:) + integer(I8), allocatable :: s8(:) + integer, allocatable :: s4(:) + real(WP), allocatable :: sr(:) + integer(1), allocatable :: s1(:) + integer :: rn,h + call this%dir%finalize() + call this%dir%register(this%nown,this%gid(1:this%nown)) + allocate(howner(max(nhe,1))) + call this%dir%query(nhe,hnode,howner) + sc=0 + do i=1,nhe + sc(howner(i))=sc(howner(i))+1 + end do + call MPI_ALLTOALL(sc,1,MPI_INTEGER,rc,1,MPI_INTEGER,comm,ierr) + sd(0)=0; rd(0)=0 + do r=1,nproc-1 + sd(r)=sd(r-1)+sc(r-1); rd(r)=rd(r-1)+rc(r-1) + end do + rn=sum(rc) + allocate(rnode(max(rn,1)),rnbr(max(rn,1)),rkey(max(rn,1)),rev(max(rn,1)),rdmg(max(rn,1))) + allocate(pos(0:nproc-1),s8(max(nhe,1)),s4(max(nhe,1)),sr(max(nhe,1)),s1(max(nhe,1))) + pos=sd + do i=1,nhe + h=howner(i); pos(h)=pos(h)+1; s8(pos(h))=hnode(i) + end do + call MPI_ALLTOALLV(s8,sc,sd,MPI_INTEGER8,rnode,rc,rd,MPI_INTEGER8,comm,ierr) + pos=sd + do i=1,nhe + h=howner(i); pos(h)=pos(h)+1; s8(pos(h))=hnbr(i) + end do + call MPI_ALLTOALLV(s8,sc,sd,MPI_INTEGER8,rnbr,rc,rd,MPI_INTEGER8,comm,ierr) + pos=sd + do i=1,nhe + h=howner(i); pos(h)=pos(h)+1; s4(pos(h))=hkey(i) + end do + call MPI_ALLTOALLV(s4,sc,sd,MPI_INTEGER,rkey,rc,rd,MPI_INTEGER,comm,ierr) + pos=sd + do i=1,nhe + h=howner(i); pos(h)=pos(h)+1; sr(pos(h))=hev(i) + end do + call MPI_ALLTOALLV(sr,sc,sd,MPI_REAL_WP,rev,rc,rd,MPI_REAL_WP,comm,ierr) + pos=sd + do i=1,nhe + h=howner(i); pos(h)=pos(h)+1; s1(pos(h))=hdmg(i) + end do + call MPI_ALLTOALLV(s1,sc,sd,MPI_INTEGER1,rdmg,rc,rd,MPI_INTEGER1,comm,ierr) + call this%assemble(rn,rnode,rnbr,rkey,rev,rdmg) + deallocate(rnode,rnbr,rkey,rev,rdmg,pos,s8,s4,sr,s1,howner) + end block route_and_assemble + + ! Overlay td2/lam_p (assemble/set_nodes zero them) and life status + do i=1,this%nown + this%td2(i) =this%rextra_tmp(8,i) + this%lam_p(i)=this%rextra_tmp(9,i) + if (this%flag(i).eq.PDC_IS_DEAD) this%alive(i)=0.0_WP + end do + deallocate(this%rextra_tmp) + call this%halo%update1(this%alive) + deallocate(gid,flag,x0,yy,vv,ffb,vol,dmgn,td2n,lamn,hnode,hnbr,hkey,hdmg,hev,owner) + + contains + + subroutine grow_i8(a,n,add) + integer(I8), allocatable, intent(inout) :: a(:) + integer, intent(in) :: n,add + integer(I8), allocatable :: t(:) + allocate(t(n+add)); if (n.gt.0) t(1:n)=a(1:n) + call move_alloc(t,a) + end subroutine grow_i8 + subroutine grow_i4(a,n,add) + integer, allocatable, intent(inout) :: a(:) + integer, intent(in) :: n,add + integer, allocatable :: t(:) + allocate(t(n+add)); if (n.gt.0) t(1:n)=a(1:n) + call move_alloc(t,a) + end subroutine grow_i4 + subroutine grow_i1(a,n,add) + integer(1), allocatable, intent(inout) :: a(:) + integer, intent(in) :: n,add + integer(1), allocatable :: t(:) + allocate(t(n+add)); if (n.gt.0) t(1:n)=a(1:n) + call move_alloc(t,a) + end subroutine grow_i1 + subroutine grow_r1(a,n,add) + real(WP), allocatable, intent(inout) :: a(:) + integer, intent(in) :: n,add + real(WP), allocatable :: t(:) + allocate(t(n+add)); if (n.gt.0) t(1:n)=a(1:n) + call move_alloc(t,a) + end subroutine grow_r1 + subroutine grow_r2(a,n,add) + real(WP), allocatable, intent(inout) :: a(:,:) + integer, intent(in) :: n,add + real(WP), allocatable :: t(:,:) + allocate(t(3,n+add)); if (n.gt.0) t(:,1:n)=a(:,1:n) + call move_alloc(t,a) + end subroutine grow_r2 + + end subroutine read_state + + + !> Static load-balancing partition of the reference configuration. + !> Collective; called once at handoff, BEFORE set_nodes. Nodes are ordered + !> by the Morton key of their reference position and split into equal-count + !> contiguous ranges: on a uniform lattice family size is ~constant, so node + !> count ~ bond work (a family-weighted split can substitute later), and + !> bond work is motion-invariant -- this balance holds for the entire run + !> regardless of deformation or flight, using ALL ranks even when the solid + !> occupies a corner of the fluid domain. + !> Inputs: this rank's extracted nodes (any distribution). Outputs: the + !> nodes assigned to this rank, plus each INPUT node's assigned owner (for + !> stamping the face particles' routing tags). + subroutine pd_partition(n_in,gid_in,pos_in,vel_in,flag_in,vol_in,owner_out, & + & n_out,gid_out,pos_out,vel_out,flag_out,vol_out) + use parallel, only: comm,rank,nproc,amRoot,MPI_REAL_WP + use pdhalo_class, only: sort3_perm + use mpi_f08 + implicit none + integer, intent(in) :: n_in + integer(I8), intent(in) :: gid_in(:) + real(WP), intent(in) :: pos_in(:,:),vel_in(:,:) + integer, intent(in) :: flag_in(:) + real(WP), intent(in) :: vol_in(:) + integer, intent(out) :: owner_out(:) + integer, intent(out) :: n_out + integer(I8), allocatable, intent(out) :: gid_out(:) + real(WP), allocatable, intent(out) :: pos_out(:,:),vel_out(:,:),vol_out(:) + integer, allocatable, intent(out) :: flag_out(:) + real(WP), dimension(3) :: blo,bhi,inv + integer(I8), allocatable :: keys(:),splitters(:) + integer :: i,r,d,ierr + + ! Global reference bounds + blo=huge(1.0_WP); bhi=-huge(1.0_WP) + do i=1,n_in + blo=min(blo,pos_in(:,i)); bhi=max(bhi,pos_in(:,i)) + end do + call MPI_ALLREDUCE(MPI_IN_PLACE,blo,3,MPI_REAL_WP,MPI_MIN,comm,ierr) + call MPI_ALLREDUCE(MPI_IN_PLACE,bhi,3,MPI_REAL_WP,MPI_MAX,comm,ierr) + do d=1,3 + inv(d)=0.0_WP + if (bhi(d).gt.blo(d)) inv(d)=2097151.0_WP/(bhi(d)-blo(d)) + end do + + ! Morton keys of this rank's nodes + allocate(keys(max(n_in,1))) + do i=1,n_in + keys(i)=morton(pos_in(:,i),blo,inv) + end do + + ! Equal-weight splitters by SAMPLE SORT: each rank contributes a few + ! evenly-spaced samples of its locally sorted keys, weighted by its node + ! count -- root memory is O(nproc*S), not O(N_global), so this scales to + ! very large rank counts (the old gather-all-keys approach walled at + ! root memory and int32 N_global). + allocate(splitters(max(nproc-1,1))) + sample_splitters: block + integer, parameter :: S=16 + integer(I8), allocatable :: lsamp(:),gsamp(:),gw(:) + real(WP), allocatable :: w(:) + integer, allocatable :: perm(:),zk(:),scnt(:),sdis(:) + integer(I8) :: wtot,wcum,wtarg + integer :: ns,j,r2,gtot + ! Locally sort keys (permutation) and draw samples + allocate(perm(max(n_in,1)),zk(max(n_in,1))) + do i=1,n_in + perm(i)=i + end do + zk=0 + if (n_in.gt.1) call sort3_perm(zk,keys(1:n_in),zk,perm,1,n_in) + ns=min(S,n_in) + allocate(lsamp(max(ns,1))) + do j=1,ns + lsamp(j)=keys(perm(min(n_in,int((real(j,WP)-0.5_WP)*real(n_in,WP)/real(ns,WP))+1))) + end do + deallocate(perm,zk) + ! Gather samples (+ per-rank sample counts and node counts) on root + allocate(scnt(nproc),sdis(nproc)) + call MPI_GATHER(ns,1,MPI_INTEGER,scnt,1,MPI_INTEGER,0,comm,ierr) + gtot=0 + if (amRoot) then + sdis(1)=0 + do r2=2,nproc + sdis(r2)=sdis(r2-1)+scnt(r2-1) + end do + gtot=sum(scnt) + end if + allocate(gsamp(max(gtot,1)),gw(nproc)) + call MPI_GATHERV(lsamp,ns,MPI_INTEGER8,gsamp,scnt,sdis,MPI_INTEGER8,0,comm,ierr) + call MPI_GATHER(int(n_in,I8),1,MPI_INTEGER8,gw,1,MPI_INTEGER8,0,comm,ierr) + if (amRoot.and.gtot.gt.0) then + root_split: block + integer, allocatable :: p2(:),z2(:) + real(WP), allocatable :: sw(:) + ! Weight each sample by (its rank's node count)/(its rank's samples) + allocate(sw(gtot),p2(gtot),z2(gtot)) + do r2=1,nproc + do j=sdis(r2)+1,sdis(r2)+scnt(r2) + sw(j)=real(gw(r2),WP)/real(max(scnt(r2),1),WP) + end do + end do + do j=1,gtot + p2(j)=j + end do + z2=0 + call sort3_perm(z2,gsamp(1:gtot),z2,p2,1,gtot) + ! Single cumulative-weight pass placing all nproc-1 splitters + wtot=sum(gw) + wcum=0_I8; r2=1 + do j=1,gtot + if (r2.gt.nproc-1) exit + wcum=wcum+int(sw(p2(j)),I8) + do while (r2.le.nproc-1.and.wcum.ge.(int(r2,I8)*wtot)/int(nproc,I8)) + splitters(r2)=gsamp(p2(j)) + r2=r2+1 + end do + end do + do while (r2.le.nproc-1) + splitters(r2)=huge(1_I8) ! degenerate tail: empty upper buckets + r2=r2+1 + end do + deallocate(sw,p2,z2) + end block root_split + end if + deallocate(lsamp,gsamp,gw,scnt,sdis) + end block sample_splitters + if (nproc.gt.1) call MPI_BCAST(splitters,nproc-1,MPI_INTEGER8,0,comm,ierr) + + ! Assign owners: bucket = number of splitters <= key + do i=1,n_in + owner_out(i)=0 + do r=1,nproc-1 + if (keys(i).ge.splitters(r)) owner_out(i)=r + end do + end do + deallocate(keys,splitters) + + ! Route node payloads to their owners + route_nodes: block + integer, dimension(0:nproc-1) :: sc,rc,sd,rd,scw,rcw,sdw,rdw + integer, allocatable :: pos(:),sflag(:) + integer(I8), allocatable :: sgid(:) + real(WP), allocatable :: sdat(:,:),rdat(:,:) + sc=0 + do i=1,n_in + sc(owner_out(i))=sc(owner_out(i))+1 + end do + call MPI_ALLTOALL(sc,1,MPI_INTEGER,rc,1,MPI_INTEGER,comm,ierr) + sd(0)=0; rd(0)=0 + do r=1,nproc-1 + sd(r)=sd(r-1)+sc(r-1); rd(r)=rd(r-1)+rc(r-1) + end do + n_out=sum(rc) + allocate(pos(0:nproc-1),sgid(max(n_in,1)),sflag(max(n_in,1)),sdat(7,max(n_in,1))) + pos=sd + do i=1,n_in + r=owner_out(i); pos(r)=pos(r)+1 + sgid(pos(r))=gid_in(i) + sflag(pos(r))=flag_in(i) + sdat(1:3,pos(r))=pos_in(:,i) + sdat(4:6,pos(r))=vel_in(:,i) + sdat(7,pos(r)) =vol_in(i) + end do + allocate(gid_out(max(n_out,1)),flag_out(max(n_out,1)),rdat(7,max(n_out,1))) + allocate(pos_out(3,max(n_out,1)),vel_out(3,max(n_out,1)),vol_out(max(n_out,1))) + call MPI_ALLTOALLV(sgid,sc,sd,MPI_INTEGER8,gid_out,rc,rd,MPI_INTEGER8,comm,ierr) + call MPI_ALLTOALLV(sflag,sc,sd,MPI_INTEGER,flag_out,rc,rd,MPI_INTEGER,comm,ierr) + scw=7*sc; sdw=7*sd; rcw=7*rc; rdw=7*rd + call MPI_ALLTOALLV(sdat,scw,sdw,MPI_REAL_WP,rdat,rcw,rdw,MPI_REAL_WP,comm,ierr) + do i=1,n_out + pos_out(:,i)=rdat(1:3,i) + vel_out(:,i)=rdat(4:6,i) + vol_out(i) =rdat(7,i) + end do + deallocate(pos,sgid,sflag,sdat,rdat) + end block route_nodes + + contains + + !> 63-bit Morton key: 21 bits per dimension, bit-interleaved + pure function morton(p,lo,inv) result(key) + implicit none + real(WP), dimension(3), intent(in) :: p,lo,inv + integer(I8) :: key + integer(I8), dimension(3) :: ix + integer :: b,d + do d=1,3 + ix(d)=int(min(max((p(d)-lo(d))*inv(d),0.0_WP),2097151.0_WP),I8) + end do + key=0_I8 + do b=0,20 + do d=1,3 + if (btest(ix(d),b)) key=ibset(key,3*b+d-1) + end do + end do + end function morton + + end subroutine pd_partition + + + !> Bin geometry: cell size >= the search radius (so +/-1 cell sweeps are complete), + !> dims clamped to keep total cell count bounded on huge/degenerate extents + subroutine setup_bins(lo,hi,r,gl,h,nc) + real(WP), dimension(3), intent(in) :: lo,hi + real(WP), intent(in) :: r + real(WP), dimension(3), intent(out) :: gl,h + integer, dimension(3), intent(out) :: nc + integer :: d + do d=1,3 + gl(d)=lo(d)-0.5_WP*r + nc(d)=max(1,min(256,int((hi(d)-lo(d)+r)/r))) + h(d)=max((hi(d)+0.5_WP*r-gl(d))/real(nc(d),WP),r) + end do + end subroutine setup_bins + + !> Flattened cell index of a position (clamped into the grid) + pure function cell_of(p,gl,h,nc) result(k) + real(WP), dimension(3), intent(in) :: p,gl,h + integer, dimension(3), intent(in) :: nc + integer :: k,c(3),d + do d=1,3 + c(d)=min(nc(d),max(1,int((p(d)-gl(d))/h(d))+1)) + end do + k=c(1)+nc(1)*(c(2)-1)+nc(1)*nc(2)*(c(3)-1) + end function cell_of + + + !> Influence function w(zeta) (Peridigm forms). ONE form active, hard-coded; + !> flip by (un)commenting -- s0-from-G_c, psi_fac, and the critical-dt + !> diagnostic all generalize through wmoment(), so nothing else changes. + pure function omega(d,h) result(w) + ! implicit none + ! real(WP), intent(in) :: d,h + ! real(WP) :: w + ! real(WP) :: s + ! ! Parabolic decay (ACTIVE): 1 in the core, C1 taper to 0 at the horizon + ! s=d/h + ! if (s.lt.0.5_WP) then + ! w=1.0_WP + ! else + ! w=max(4.0_WP*s*(1.0_WP-s),0.0_WP) + ! end if + ! ! Constant (Peridigm default; pre-2026-07-16 behavior) + ! !w=1.0_WP + ! ! Gaussian + ! !w=exp(-(d/(0.4_WP*h))**2) + implicit none + real(WP), intent(in) :: d,h + real(WP), parameter :: coeff=2.6_WP + real(WP) :: hh, w + ! hh=coeff*h + hh=h + if (d.ge.hh) then + w=0.0_WP + else + ! wgauss=(1.0_WP+4.0_WP*d/hh)*(1.0_WP-d/hh)**4 + w=(1.0_WP-d/h)**3 + end if + end function omega + + !> Moment of the influence function: int_0^delta w(z)^wpow * z^zpow dz + !> (midpoint quadrature through omega(), so any form change propagates) + pure function wmoment(delta,zpow,wpow) result(m) + implicit none + real(WP), intent(in) :: delta + integer, intent(in) :: zpow,wpow + real(WP) :: m + integer, parameter :: NQ=2048 + integer :: i + real(WP) :: z,dz + dz=delta/real(NQ,WP) + m=0.0_WP + do i=1,NQ + z=(real(i,WP)-0.5_WP)*dz + m=m+omega(z,delta)**wpow*z**zpow + end do + m=m*dz + end function wmoment + + !> Lexicographic sign of an image shift: .true. for the "positive" member + !> of a self-image pair (first nonzero component positive), so each + !> self-image bond is census-counted exactly once. + pure function shift_positive(s) result(p) + implicit none + real(WP), dimension(3), intent(in) :: s + logical :: p + integer :: d + p=.false. + do d=1,3 + if (abs(s(d)).gt.0.0_WP) then + p=(s(d).gt.0.0_WP) + return + end if + end do + end function shift_positive + + !> Negate a packed periodic image offset (amrpd hist1 convention) + pure function negkey(key) result(nk) + implicit none + integer, intent(in) :: key + integer :: nk,n1,n2,n3 + n1=mod(key,256)-128; n2=mod(key/256,256)-128; n3=key/65536-128 + nk=(-n1+128)+(-n2+128)*256+(-n3+128)*65536 + end function negkey + +end module NOSB_class diff --git a/examples/NOSB_cylinder_peridigm/src/OSB_class.f90 b/examples/NOSB_cylinder_peridigm/src/OSB_class.f90 new file mode 100644 index 000000000..c2ec838fd --- /dev/null +++ b/examples/NOSB_cylinder_peridigm/src/OSB_class.f90 @@ -0,0 +1,2184 @@ +!> Peridynamics solver: node-centered, CSR-based solid dynamics on flat +!> per-field arrays with persistent graph-halo communication. GRID-FREE: +!> no AMReX anywhere -- ownership follows the reference configuration +!> (Morton partition, motion-invariant), neighborhoods and communication +!> plans are built once and reused every substep. +!> +!> Physics: linear peridynamic solid (LPS, dimension-aware coefficients, +!> influence function hard-coded in omega() with derived quantities +!> generalized through its moments), brittle stretch damage, per-side +!> viscoelastic/viscoplastic flow with J2 (Mitchell OSB) yield, soft-sphere +!> contact (walls + particle-particle via a displacement-triggered spatial +!> service), velocity-Verlet integration. +!> Checkpoint/restart is gid-space and rank-count portable, including all +!> bond damage and plastic history. +!> +!> Usage tiers (amrpd EXTENDS pdsolver -- see amrpd_class): +!> 1. pdsolver alone -- standalone solid dynamics (this module only) +!> 2. amrpd -- adds viz, mesh VF, AMR refinement, seeding +!> 3. ... + a flow solver -- two-way FSI via amrpd%exchange_solid +!> +!> Configuration style: assign the public fields (material, damage, contact), +!> then build the network (detect_families/connect/read_state) -- derived +!> quantities resolve there via derive_config, uniformly for fresh and restart. +!> +!> Layout: owned nodes 1..nown; halo slots nown+1..ntot, keyed (gid, periodic +!> image offset) with shifts applied at exchange time. Each physical bond is +!> two CSR half-entries (one per endpoint row, Peridigm convention): kernels +!> compute each row's own force state -- ghost dilatation is never +!> communicated -- and a single halo reduce assembles cross-rank pairs. +!> Kernels are pure loops over owned nodes with no mutable module-level +!> state (OpenMP-ready by construction; threads deferred). +module OSB_class + use precision, only: WP,I8 + use string, only: str_medium + use pdhalo_class, only: pddir,pdhalo,sort3_perm,PDHALO_KEY0 + use pdhash_class, only: gid_hash + implicit none + private + + public :: pdsolver,pd_partition + public :: PDC_IS_DEAD,PDC_MOVES,PDC_INTEGRATES,PDC_BONDS + public :: PD_OPEN,PD_WALL + + ! Motion-control bit flags -- values MUST match amrpd's PART_* constants + ! (handoff copies amrpd flags verbatim) + integer, parameter :: PDC_IS_DEAD =0 + integer, parameter :: PDC_MOVES =1 + integer, parameter :: PDC_INTEGRATES=2 + integer, parameter :: PDC_BONDS =4 + + ! Domain-face BC values for lo_bc/hi_bc + integer, parameter :: PD_OPEN=0 + integer, parameter :: PD_WALL=1 + + !> Graph-core PD solver + type :: pdsolver + character(len=str_medium) :: name='UNNAMED_PDSOLVER' + + ! Sizes + integer :: nown=0 !< owned nodes on this rank + integer :: nhalo=0 !< halo slots + integer :: ntot=0 !< nown+nhalo + integer(I8) :: np=0 !< global node count (get_info) + integer(I8) :: nbond=0 !< global bond count (half-entries/2, get_info) + + ! Material / discretization + real(WP) :: rho =0.0_WP !< density + real(WP) :: elastic_modulus=0.0_WP !< Young's modulus + real(WP) :: poisson_ratio =0.0_WP !< Poisson's ratio + real(WP) :: delta =0.0_WP !< horizon + real(WP) :: dV =0.0_WP !< nominal element volume (CFL length scale; kernels use per-node V) + real(WP) :: s0 =huge(1.0_WP) !< critical bond stretch (huge = no damage) + real(WP) :: fail_stretch =huge(1.0_WP) !< direct s0 override (takes precedence over crit_energy) + real(WP) :: crit_energy =huge(1.0_WP) !< critical energy release rate G_c (-> s0 when fail_stretch unset) + real(WP) :: dtcrit =0.0_WP !< Silling-Askari critical dt (diagnostic, stamped at connect) + ! Viscoelastic / viscoplastic flow (PER-SIDE form: each half-entry evolves + ! its own e_v with its own endpoint's dilatation and yield factor -- + ! exactly Peridigm's elastic_plastic.cxx, verified term-by-term against + ! amrpd's J2 2026-07-14. This is the one INTENDED delta from amrpd, which + ! averages the endpoints into a single per-bond e_v.) + real(WP) :: tau =huge(1.0_WP) !< Maxwell deviatoric relaxation time (huge = purely elastic) + real(WP) :: visc_lambda =1.0_WP !< SLS relaxing fraction [0,1] + real(WP) :: yield_stretch =0.0_WP !< legacy per-bond Perzyna yield strain (0 = pure Maxwell) + real(WP) :: sigma_yield =0.0_WP !< J2 yield stress (Mitchell OSB family norm; overrides yield_stretch) + real(WP) :: hard_mod =0.0_WP !< linear isotropic hardening modulus H: flow stress = sigma_yield + H*lam_p (0 = perfectly plastic) + real(WP), dimension(3) :: gravity=0.0_WP !< body acceleration + logical, dimension(3) :: collapsed=.false. !< collapsed (n==1) directions: velocity locked + real(WP), dimension(3) :: Ldom=0.0_WP !< domain lengths (image shifts) + logical, dimension(3) :: per=.false. !< periodicity per direction + real(WP), dimension(3) :: dom_lo=0.0_WP !< domain lower bounds (wall contact) + real(WP), dimension(3) :: dom_hi=0.0_WP !< domain upper bounds (wall contact) + + ! Short-range soft-sphere contact (soft-sphere penalty + damping). + ! Contact is a pure SPATIAL service, fully separate from the bond graph: + ! candidates are (owned nodes + contact-halo slots) discovered by a + ! displacement-triggered broad phase; the graph halo is never binned, so + ! bonded remote partners arrive as contact slots when in range and + ! double-counting is structurally impossible. The narrow phase is + ! gather-only (each owned node accumulates from its candidates -- the + ! partner gets its share from its own row), so no force reduction. + logical :: use_contact =.false. + real(WP) :: contact_dist =0.0_WP !< d_c (p-p d_eff; wall d_eff = 0.5*d_c) + real(WP) :: tau_col =0.0_WP !< collision duration (<=0 -> auto 5*dt) + real(WP) :: e_n=0.7_WP,e_w=0.7_WP !< restitution (p-p, wall) + real(WP) :: clip_col =0.2_WP !< overlap clip fraction + integer, dimension(3) :: lo_bc=PD_OPEN,hi_bc=PD_OPEN !< per-face: PD_OPEN or PD_WALL + real(WP) :: cskin =0.0_WP !< broad-phase skin (<=0 -> auto 0.5*contact_dist) + type(pdhalo) :: chalo !< contact halo (rebuilt at trigger cadence; nown=ntot) + integer :: nchalo=0 !< contact slots (y/v extended to ntot+nchalo) + integer, allocatable :: cptr(:),clst(:) !< candidate CSR (owned rows; entries index owned+contact slots) + real(WP), allocatable :: ylast(:,:) !< (3,nown) positions at last broad-phase build + + ! Node state -- flat per-field arrays; owned first, halo slots appended. + ! (3,:) fields are xyz-interleaved per node (Fortran-natural gather layout). + integer(I8), allocatable :: gid(:) !< (ntot) global id (halo slots carry partner gid) + real(WP), allocatable :: x0(:,:) !< (3,ntot) reference position; halo PRE-SHIFTED + real(WP), allocatable :: y(:,:) !< (3,ntot) current position; halo shifted at update + real(WP), allocatable :: v(:,:) !< (3,nown) velocity + real(WP), allocatable :: f(:,:) !< (3,ntot) bond force density (halo = scatter buffer) + real(WP), allocatable :: ff(:,:) !< (3,nown) external (fluid) force density + real(WP), allocatable :: vol(:) !< (ntot) per-node volume (reference; halo slots filled at connect) + real(WP), allocatable :: mw(:) !< (nown) weighted volume (reference, set at connect) + real(WP), allocatable :: theta(:) !< (nown) dilatation (recomputed each substep) + real(WP), allocatable :: damage(:) !< (nown) accumulated damage fraction (broken/reference bonds) + real(WP), allocatable :: lam_p(:) !< (nown) accumulated equivalent plastic strain (J2 path; drives hardening, free diagnostic when hard_mod=0) + real(WP), allocatable :: alive(:) !< (ntot) 1=alive, 0=dead (exit through open face); halo-exchanged on death events only + integer, allocatable :: flag(:) !< (nown) motion-control flags + logical :: watch_exit=.false. !< exit detection active (set at connect: domain set + any open non-periodic face) + + ! CSR families (built once at connect) + integer, allocatable :: ptr(:) !< (nown+1) row offsets + integer, allocatable :: lst(:) !< neighbor index (1..ntot) per half-entry + integer(1), allocatable :: dmg(:) !< per half-entry: 0 intact, 1 broken (irreversible) + real(WP), allocatable :: e_v(:) !< per half-entry: inelastic deviatoric stretch (per-side history) + real(WP), allocatable :: td2(:),td2a(:) !< (nown) J2 family deviatoric norm^2: previous substep / accumulator. + !< Node-centered => pure own-row gather, NO communication (amrpd + !< needed sum_ghosts_td2 + ghost refresh for the same quantity). + + ! Parallel machinery + type(gid_hash) :: ohash !< gid -> owned index (built at set_nodes) + type(pddir) :: dir !< persistent gid directory (owner lookups; registered at connect/read_state) + type(pdhalo) :: halo !< persistent halo plan + real(WP), allocatable :: rextra_tmp(:,:) !< read_state scratch (restart-field overlay across assemble) + + ! Monitoring + real(WP) :: Umin=0.0_WP,Umax=0.0_WP !< signed per-component velocity extrema + real(WP) :: Vmin=0.0_WP,Vmax=0.0_WP !< over live nodes (get_info) + real(WP) :: Wmin=0.0_WP,Wmax=0.0_WP + real(WP) :: EPmax=0.0_WP !< max accumulated equivalent plastic strain (get_info) + real(WP) :: CFLe=0.0_WP,CFLp=0.0_WP !< elastic-wave / convective CFL (get_cfl) + integer(I8) :: nbroken=0 !< global broken half-entry count (internal) + integer(I8) :: nb_broken=0 !< global broken BOND count (exact census, get_info) + integer(I8) :: nb=0 !< global bond count (exact census, stamped at assemble) + integer(I8) :: nrebuild=0 !< broad-phase rebuild count (cumulative) + integer(I8) :: nchalo_glob=0 !< global contact-slot count (get_info) + integer(I8) :: ncand_glob=0 !< global contact-candidate count (get_info) + + ! Per-rank phase timers (accumulated in advance; reduced+reset in get_info) + real(WP) :: wt_kick=0.0_WP,wt_halo=0.0_WP,wt_dil=0.0_WP,wt_force=0.0_WP,wt_reduce=0.0_WP + real(WP) :: wt_contact=0.0_WP,wt_broad=0.0_WP + real(WP) :: wtmax_kick=0.0_WP,wtmax_halo=0.0_WP,wtmax_dil=0.0_WP,wtmax_force=0.0_WP,wtmax_reduce=0.0_WP + real(WP) :: wtmax_contact=0.0_WP,wtmax_broad=0.0_WP + real(WP) :: wtmin_dil=0.0_WP,wtmin_force=0.0_WP + real(WP) :: tot_time=0.0_WP,maxtot_time=0.0_WP + + ! Damping rate for steady state + real(WP) :: damping_rate=0.0_WP + + contains + procedure :: set_nodes + procedure :: connect + procedure :: detect_families + procedure :: pd_advance + procedure :: exchange + procedure :: query_owners + procedure :: write_state + procedure :: read_state + procedure :: get_cfl + procedure :: get_info + procedure :: finalize + procedure, private :: derive_config + procedure, private :: lps_coefs + procedure, private :: compute_mw + procedure, private :: contact_broadphase + procedure, private :: contact_narrow + procedure, private :: assemble + end type pdsolver + +contains + + + !> Resolve derived configuration: s0 from fail_stretch/crit_energy, contact + !> reach default. Called by every network-building entry point (connect, + !> detect_families, read_state) so fresh init and restart share one path. + subroutine derive_config(this) + use messager, only: die + implicit none + class(pdsolver), intent(inout) :: this + real(WP) :: K_bulk + if (this%rho.le.0.0_WP.or.this%elastic_modulus.le.0.0_WP.or. & + & this%delta.le.0.0_WP.or.this%dV.le.0.0_WP) & + & call die('[pdsolver] material/discretization not configured (need rho, elastic_modulus, delta, dV > 0)') + if (this%fail_stretch.lt.huge(1.0_WP)) then + this%s0=this%fail_stretch + else if (this%crit_energy.gt.0.0_WP.and.this%crit_energy.lt.huge(1.0_WP)) then + ! Silling-Askari bond-energy argument, generalized to the active + ! influence function: G_c = (9/4)*K*s0^2*Iw4/Iw3 (w=1 recovers the + ! classical s0 = sqrt(5*G_c/(9*K*delta))) + K_bulk=this%elastic_modulus/(3.0_WP*(1.0_WP-2.0_WP*this%poisson_ratio)) + this%s0=sqrt(4.0_WP*this%crit_energy*wmoment(this%delta,3,1)/(9.0_WP*K_bulk*wmoment(this%delta,4,1))) + end if + if (this%use_contact.and.this%contact_dist.le.0.0_WP) this%contact_dist=0.9_WP*this%dV**(1.0_WP/3.0_WP) + end subroutine derive_config + + !> Load this rank's owned nodes (any distribution; it becomes the static + !> partition). Builds the gid->index hash used by connect and the halo plan. + !> vol is the per-node volume (pass a constant-filled array for a uniform + !> lattice; kernels use it per neighbor, Peridigm-style). + subroutine set_nodes(this,n,gids,pos,vel,flags,vol) + implicit none + class(pdsolver), intent(inout) :: this + integer, intent(in) :: n + integer(I8), intent(in) :: gids(:) + real(WP), intent(in) :: pos(:,:),vel(:,:) + integer, intent(in) :: flags(:) + real(WP), intent(in) :: vol(:) + integer :: i + this%nown=n + this%nhalo=0 + this%ntot=n + allocate(this%gid(max(n,1)),this%x0(3,max(n,1)),this%y(3,max(n,1))) + allocate(this%v(3,max(n,1)),this%f(3,max(n,1)),this%ff(3,max(n,1))) + allocate(this%mw(max(n,1)),this%theta(max(n,1)),this%flag(max(n,1))) + allocate(this%vol(max(n,1)),this%damage(max(n,1)),this%lam_p(max(n,1))) + do i=1,n + this%gid(i) =gids(i) + this%x0(:,i)=pos(:,i) + this%y(:,i) =pos(:,i) + this%v(:,i) =vel(:,i) + this%flag(i)=flags(i) + this%vol(i) =vol(i) + end do + this%f=0.0_WP; this%ff=0.0_WP; this%mw=0.0_WP; this%theta=0.0_WP; this%damage=0.0_WP; this%lam_p=0.0_WP + call this%ohash%build(n,gids(1:n)) + end subroutine set_nodes + + !> Build the static CSR families and the halo plan from a distributed bond + !> list (this rank passes the bonds it holds; any distribution is fine -- + !> half-entries are routed to their node's owner through the gid directory). + !> Collective. bkey packs the periodic image offset of the HI endpoint in + !> amrpd's hist1 convention. Self-image bonds (gid_lo==gid_hi) yield ONE + !> half-entry (the opposite-image bond exists separately in the input, exactly + !> as amrpd stores them). + subroutine connect(this,nb,bgid_lo,bgid_hi,bkey) + use parallel, only: comm,nproc + use messager, only: die + use mpi_f08 + implicit none + class(pdsolver), intent(inout) :: this + integer, intent(in) :: nb + integer(I8), intent(in) :: bgid_lo(:),bgid_hi(:) + integer, intent(in) :: bkey(:) + integer(I8), allocatable :: hnode(:),hnbr(:),rnode(:),rnbr(:) + integer, allocatable :: hkey(:),howner(:),rkey(:) + real(WP), allocatable :: rev(:) + integer(1), allocatable :: rdmg(:) + integer :: nhe,rn,i,ib,ierr + + ! Resolve derived configuration (restart-safe shared path) + call this%derive_config() + + ! Distributed gid directory over the node partition (persistent: also + ! serves owner queries for face-tag restamping after restart) + call this%dir%finalize() + call this%dir%register(this%nown,this%gid(1:this%nown)) + + ! Expand bonds into half-entries (one per endpoint row; one total for + ! self-image bonds -- see header) + nhe=0 + do ib=1,nb + nhe=nhe+1 + if (bgid_lo(ib).ne.bgid_hi(ib)) nhe=nhe+1 + end do + allocate(hnode(max(nhe,1)),hnbr(max(nhe,1)),hkey(max(nhe,1)),howner(max(nhe,1))) + nhe=0 + do ib=1,nb + nhe=nhe+1 + hnode(nhe)=bgid_lo(ib); hnbr(nhe)=bgid_hi(ib); hkey(nhe)=bkey(ib) + if (bgid_lo(ib).ne.bgid_hi(ib)) then + nhe=nhe+1 + hnode(nhe)=bgid_hi(ib); hnbr(nhe)=bgid_lo(ib); hkey(nhe)=negkey(bkey(ib)) + end if + end do + + ! Route each half-entry to the rank owning its node + call this%dir%query(nhe,hnode,howner) + route_entries: block + integer, dimension(0:nproc-1) :: sc,rc,sd,rd + integer, allocatable :: pos(:) + integer(I8), allocatable :: s8(:) + integer, allocatable :: s4(:) + integer :: r,h + sc=0 + do i=1,nhe + sc(howner(i))=sc(howner(i))+1 + end do + call MPI_ALLTOALL(sc,1,MPI_INTEGER,rc,1,MPI_INTEGER,comm,ierr) + sd(0)=0; rd(0)=0 + do r=1,nproc-1 + sd(r)=sd(r-1)+sc(r-1); rd(r)=rd(r-1)+rc(r-1) + end do + rn=sum(rc) + allocate(rnode(max(rn,1)),rnbr(max(rn,1)),rkey(max(rn,1))) + allocate(pos(0:nproc-1),s8(max(nhe,1)),s4(max(nhe,1))) + ! node gids + pos=sd + do i=1,nhe + h=howner(i); pos(h)=pos(h)+1; s8(pos(h))=hnode(i) + end do + call MPI_ALLTOALLV(s8,sc,sd,MPI_INTEGER8,rnode,rc,rd,MPI_INTEGER8,comm,ierr) + ! neighbor gids + pos=sd + do i=1,nhe + h=howner(i); pos(h)=pos(h)+1; s8(pos(h))=hnbr(i) + end do + call MPI_ALLTOALLV(s8,sc,sd,MPI_INTEGER8,rnbr,rc,rd,MPI_INTEGER8,comm,ierr) + ! image keys + pos=sd + do i=1,nhe + h=howner(i); pos(h)=pos(h)+1; s4(pos(h))=hkey(i) + end do + call MPI_ALLTOALLV(s4,sc,sd,MPI_INTEGER,rkey,rc,rd,MPI_INTEGER,comm,ierr) + deallocate(pos,s8,s4) + end block route_entries + deallocate(hnode,hnbr,hkey,howner) + + ! Fresh bonds carry zero inelastic state + allocate(rev(max(rn,1)),rdmg(max(rn,1))) + rev=0.0_WP; rdmg=0_1 + call this%assemble(rn,rnode,rnbr,rkey,rev,rdmg) + deallocate(rnode,rnbr,rkey,rev,rdmg) + end subroutine connect + + + !> Build the bond families directly from the REFERENCE configuration -- no + !> amrpd bond container, no bond expansion: distributed neighbor discovery + !> at radius delta (bounds allgather + per-(rank,image-offset) offers of + !> shifted x0, contact-broadphase pattern), then each owned row's + !> half-entries are generated straight from the binned candidates and fed + !> to assemble with zero inelastic state. Acceptance test r2 <= delta^2 + !> matches amrpd bond_init exactly. Collective; call after set_nodes. + subroutine detect_families(this) + use parallel, only: comm,rank,nproc,amRoot,MPI_REAL_WP + use messager, only: log,die + use string, only: str_long + use mpi_f08 + implicit none + class(pdsolver), intent(inout) :: this + real(WP), dimension(3) :: bl,bh,shift,pos_s,gl,hcell + real(WP), allocatable :: allb(:,:),opos(:,:),rpos(:,:),cpos(:,:) + integer(I8), allocatable :: ogid(:),rgid(:),cgid(:),hnode(:),hnbr(:) + integer, allocatable :: okey(:),rkey(:),ckey(:),hkey(:),head(:),nxt(:) + real(WP), allocatable :: rev(:) + integer(1), allocatable :: rdmg(:) + integer, dimension(0:nproc-1) :: sc,rc,sd,rd,sc3,rc3,sd3,rd3 + integer, dimension(3) :: nmax,nc + integer :: d,r,n1,n2,n3,i,k,m,noff,nrecv,ncand,nhe,pass,ic,jc,kc,c1,c2,c3,ierr + character(len=str_long) :: message + + ! Resolve derived configuration (restart-safe shared path) + call this%derive_config() + + ! Directory over the node partition (persistent) + call this%dir%finalize() + call this%dir%register(this%nown,this%gid(1:this%nown)) + + ! Owned reference bounds, exchanged globally + bl=huge(1.0_WP); bh=-huge(1.0_WP) + do i=1,this%nown + bl=min(bl,this%x0(:,i)); bh=max(bh,this%x0(:,i)) + end do + allocate(allb(6,0:nproc-1)) + call MPI_ALLGATHER([bl,bh],6,MPI_REAL_WP,allb,6,MPI_REAL_WP,comm,ierr) + do d=1,3 + nmax(d)=0 + if (this%per(d).and.this%Ldom(d).gt.0.0_WP) nmax(d)=min(4,int(this%delta/this%Ldom(d))+1) + end do + + ! Offers of shifted reference positions (two passes: count, fill) + do pass=1,2 + sc=0 + do r=0,nproc-1 + do n3=-nmax(3),nmax(3); do n2=-nmax(2),nmax(2); do n1=-nmax(1),nmax(1) + if (r.eq.rank.and.n1.eq.0.and.n2.eq.0.and.n3.eq.0) cycle + shift=[real(n1,WP)*this%Ldom(1),real(n2,WP)*this%Ldom(2),real(n3,WP)*this%Ldom(3)] + if (any(bl+shift-this%delta.gt.allb(4:6,r)).or.any(bh+shift+this%delta.lt.allb(1:3,r))) cycle + do i=1,this%nown + pos_s=this%x0(:,i)+shift + if (any(pos_s.lt.allb(1:3,r)-this%delta).or.any(pos_s.gt.allb(4:6,r)+this%delta)) cycle + sc(r)=sc(r)+1 + if (pass.eq.2) then + ogid(sd(r)+sc(r))=this%gid(i) + okey(sd(r)+sc(r))=(n1+128)+(n2+128)*256+(n3+128)*65536 + opos(:,sd(r)+sc(r))=pos_s + end if + end do + end do; end do; end do + end do + if (pass.eq.1) then + sd(0)=0 + do r=1,nproc-1 + sd(r)=sd(r-1)+sc(r-1) + end do + noff=sum(sc) + allocate(ogid(max(noff,1)),okey(max(noff,1)),opos(3,max(noff,1))) + end if + end do + call MPI_ALLTOALL(sc,1,MPI_INTEGER,rc,1,MPI_INTEGER,comm,ierr) + rd(0)=0 + do r=1,nproc-1 + rd(r)=rd(r-1)+rc(r-1) + end do + nrecv=sum(rc) + allocate(rgid(max(nrecv,1)),rkey(max(nrecv,1)),rpos(3,max(nrecv,1))) + call MPI_ALLTOALLV(ogid,sc,sd,MPI_INTEGER8,rgid,rc,rd,MPI_INTEGER8,comm,ierr) + call MPI_ALLTOALLV(okey,sc,sd,MPI_INTEGER, rkey,rc,rd,MPI_INTEGER, comm,ierr) + sc3=3*sc; sd3=3*sd; rc3=3*rc; rd3=3*rd + call MPI_ALLTOALLV(opos,sc3,sd3,MPI_REAL_WP,rpos,rc3,rd3,MPI_REAL_WP,comm,ierr) + deallocate(ogid,okey,opos) + + ! Candidate set = owned nodes (zero offset) + received offers + ncand=this%nown+nrecv + allocate(cgid(max(ncand,1)),ckey(max(ncand,1)),cpos(3,max(ncand,1))) + do i=1,this%nown + cgid(i)=this%gid(i); ckey(i)=PDHALO_KEY0; cpos(:,i)=this%x0(:,i) + end do + do i=1,nrecv + cgid(this%nown+i)=rgid(i); ckey(this%nown+i)=rkey(i); cpos(:,this%nown+i)=rpos(:,i) + end do + deallocate(rgid,rkey,rpos) + + ! Bin candidates; generate each owned row directly (two passes) + bl=huge(1.0_WP); bh=-huge(1.0_WP) + do m=1,ncand + bl=min(bl,cpos(:,m)); bh=max(bh,cpos(:,m)) + end do + call setup_bins(bl,bh,this%delta,gl,hcell,nc) + allocate(head(nc(1)*nc(2)*nc(3)),nxt(max(ncand,1))) + head=0 + do m=1,ncand + k=cell_of(cpos(:,m),gl,hcell,nc) + nxt(m)=head(k); head(k)=m + end do + do pass=1,2 + nhe=0 + do i=1,this%nown + ic=min(nc(1),max(1,int((this%x0(1,i)-gl(1))/hcell(1))+1)) + jc=min(nc(2),max(1,int((this%x0(2,i)-gl(2))/hcell(2))+1)) + kc=min(nc(3),max(1,int((this%x0(3,i)-gl(3))/hcell(3))+1)) + do c3=max(1,kc-1),min(nc(3),kc+1); do c2=max(1,jc-1),min(nc(2),jc+1); do c1=max(1,ic-1),min(nc(1),ic+1) + m=head(c1+nc(1)*(c2-1)+nc(1)*nc(2)*(c3-1)) + do while (m.gt.0) + if (m.ne.i) then + if (sum((cpos(:,m)-this%x0(:,i))**2).le.this%delta**2) then + nhe=nhe+1 + if (pass.eq.2) then + hnode(nhe)=this%gid(i) + hnbr(nhe) =cgid(m) + hkey(nhe) =ckey(m) + end if + end if + end if + m=nxt(m) + end do + end do; end do; end do + end do + if (pass.eq.1) allocate(hnode(max(nhe,1)),hnbr(max(nhe,1)),hkey(max(nhe,1))) + end do + deallocate(cgid,ckey,cpos,head,nxt,allb) + + ! Assemble with zero inelastic state (entries are already local rows) + allocate(rev(max(nhe,1)),rdmg(max(nhe,1))) + rev=0.0_WP; rdmg=0_1 + call this%assemble(nhe,hnode,hnbr,hkey,rev,rdmg) + deallocate(hnode,hnbr,hkey,rev,rdmg) + if (amRoot) then + write(message,'("[",a,"] detect_families: ",i0," half-entries (~2x bonds)")') trim(this%name),this%nbond + call log(message) + end if + end subroutine detect_families + + !> Assemble the CSR families, halo plan, and reference state from LOCAL + !> half-entry arrays (already routed to this rank: every entry's node gid is + !> owned here). Per-entry inelastic state (dmg, e_v) travels with the + !> entries -- zeros for a fresh connect, loaded values on restart. Shared by + !> connect and read_state; collective. + subroutine assemble(this,rn,rnode,rnbr,rkey,rev,rdmg) + use parallel, only: comm,nproc + use messager, only: die + use mpi_f08 + implicit none + class(pdsolver), intent(inout) :: this + integer, intent(in) :: rn + integer(I8), intent(in) :: rnode(:),rnbr(:) + integer, intent(in) :: rkey(:) + real(WP), intent(in) :: rev(:) + integer(1), intent(in) :: rdmg(:) + integer, allocatable :: ridx(:),perm(:) + integer :: i,s,ierr + + if (allocated(this%ptr)) deallocate(this%ptr) + if (allocated(this%lst)) deallocate(this%lst) + if (allocated(this%dmg)) deallocate(this%dmg) + if (allocated(this%e_v)) deallocate(this%e_v) + if (allocated(this%td2)) deallocate(this%td2) + if (allocated(this%td2a)) deallocate(this%td2a) + + ! Resolve each received entry's node to an owned index + allocate(ridx(max(rn,1)),perm(max(rn,1))) + do i=1,rn + ridx(i)=this%ohash%lookup(rnode(i)) + if (ridx(i).lt.1) call die('[pdsolver assemble] half-entry routed to a rank that does not own its node') + perm(i)=i + end do + + ! Deterministic CSR order: sort by (node index, neighbor gid, image key) + if (rn.gt.1) call sort3_perm(ridx,rnbr,rkey,perm,1,rn) + + ! Row pointers + allocate(this%ptr(this%nown+1)) + row_pointers: block + integer, allocatable :: cnt(:) + allocate(cnt(this%nown)); cnt=0 + do i=1,rn + cnt(ridx(i))=cnt(ridx(i))+1 + end do + this%ptr(1)=1 + do i=1,this%nown + this%ptr(i+1)=this%ptr(i)+cnt(i) + end do + deallocate(cnt) + end block row_pointers + + ! Classify entries (owned direct vs halo reference), dedupe references, + ! build the halo plan, and finalize the CSR neighbor indices + build_refs_and_halo: block + integer(I8), allocatable :: refgid(:),ugid(:) + integer, allocatable :: refkey(:),refpos(:),rperm(:),zeros(:) + integer, allocatable :: ukey(:),uowner(:),uslot(:) + integer :: nref,nuniq,lid,u + allocate(this%lst(max(rn,1))) + allocate(this%dmg(max(rn,1))); this%dmg=0_1 + allocate(this%e_v(max(rn,1))); this%e_v=0.0_WP + ! Per-entry inelastic state follows the deterministic CSR order + do s=1,rn + this%dmg(s)=rdmg(perm(s)) + this%e_v(s)=rev(perm(s)) + end do + allocate(this%td2(max(this%nown,1)),this%td2a(max(this%nown,1))) + this%td2=0.0_WP; this%td2a=0.0_WP + allocate(refgid(max(rn,1)),refkey(max(rn,1)),refpos(max(rn,1))) + nref=0 + do s=1,rn + i=perm(s) + if (rkey(i).eq.PDHALO_KEY0) then + lid=this%ohash%lookup(rnbr(i)) + if (lid.ge.1) then + this%lst(s)=lid ! owned, zero image offset: direct index + cycle + end if + end if + nref=nref+1 + refgid(nref)=rnbr(i); refkey(nref)=rkey(i); refpos(nref)=s + end do + ! Unique (gid,key) references, deterministic order + allocate(rperm(max(nref,1)),zeros(max(nref,1))) + zeros=0 + do i=1,nref + rperm(i)=i + end do + if (nref.gt.1) call sort3_perm(zeros,refgid,refkey,rperm,1,nref) + allocate(ugid(max(nref,1)),ukey(max(nref,1))) + nuniq=0 + do s=1,nref + i=rperm(s) + if (s.eq.1) then + nuniq=1; ugid(1)=refgid(i); ukey(1)=refkey(i) + else if (refgid(i).ne.refgid(rperm(s-1)).or.refkey(i).ne.refkey(rperm(s-1))) then + nuniq=nuniq+1; ugid(nuniq)=refgid(i); ukey(nuniq)=refkey(i) + end if + this%lst(refpos(i))=-nuniq ! provisional: -(unique ref id) + end do + ! Owners of the unique references, then the persistent halo plan + allocate(uowner(max(nuniq,1)),uslot(max(nuniq,1))) + call this%dir%query(nuniq,ugid,uowner) + call this%halo%build(this%nown,this%ohash,nuniq,ugid,ukey,uowner,this%Ldom,this%per,uslot) + this%nhalo=this%halo%nhalo + this%ntot=this%nown+this%nhalo + ! Finalize CSR: provisional negatives -> halo slot indices + do s=1,rn + if (this%lst(s).lt.0) this%lst(s)=this%nown+uslot(-this%lst(s)) + end do + ! Extend node arrays to include halo slots; stamp halo gids + extend_arrays: block + integer(I8), allocatable :: g2(:) + real(WP), allocatable :: a2(:,:) + allocate(g2(max(this%ntot,1))); g2(1:this%nown)=this%gid(1:this%nown) + do u=1,nuniq + g2(this%nown+uslot(u))=ugid(u) + end do + call move_alloc(g2,this%gid) + allocate(a2(3,max(this%ntot,1))); a2=0.0_WP; a2(:,1:this%nown)=this%x0(:,1:this%nown) + call move_alloc(a2,this%x0) + allocate(a2(3,max(this%ntot,1))); a2=0.0_WP; a2(:,1:this%nown)=this%y(:,1:this%nown) + call move_alloc(a2,this%y) + allocate(a2(3,max(this%ntot,1))); a2=0.0_WP; a2(:,1:this%nown)=this%f(:,1:this%nown) + call move_alloc(a2,this%f) + extend_volume: block + real(WP), allocatable :: v2(:) + allocate(v2(max(this%ntot,1))); v2=0.0_WP; v2(1:this%nown)=this%vol(1:this%nown) + call move_alloc(v2,this%vol) + end block extend_volume + end block extend_arrays + deallocate(refgid,refkey,refpos,rperm,zeros,ugid,ukey,uowner,uslot) + end block build_refs_and_halo + deallocate(ridx,perm) + + ! Fill halo reference positions ONCE, pre-shifted by the image offsets + ! (x0 is static; this is the only x0 exchange of the entire run), and + ! the halo per-node volumes (also static) + call this%halo%update(this%x0,3,shifted=.true.) + call this%halo%update1(this%vol) + this%y(:,this%nown+1:this%ntot)=this%x0(:,this%nown+1:this%ntot) + + ! Life status (exit-through-open-face handling). Exchanged over the halo + ! ONLY on substeps where a death occurs somewhere; steady state is free. + if (allocated(this%alive)) deallocate(this%alive) + allocate(this%alive(max(this%ntot,1))); this%alive=1.0_WP + this%watch_exit=(this%dom_hi(1).gt.this%dom_lo(1)).and. & + & any((.not.this%per).and.(this%lo_bc.eq.0.or.this%hi_bc.eq.0)) + + ! Stamp the reference weighted volume + call this%compute_mw() + + ! Silling-Askari critical time step (Peridigm form, 3D bond-based + ! micromodulus c(z) = c0*w(z), c0 = 9K/(2*pi*Iw3); w=1 recovers the + ! classical 18K/(pi*delta^4)): + ! dt_crit_i = sqrt(2*rho / sum_family(V_j * c(zeta) / zeta)), global min. + ! DIAGNOSTIC only for now -- reported at init, does not bind dt. The + ! micromodulus constant is 3D-based; in quasi-2D slabs treat it as + ! indicative. + critical_dt: block + use mathtools, only: Pi + use messager, only: log + use string, only: str_long + use parallel, only: amRoot,MPI_REAL_WP + real(WP) :: K_bulk,c0,denom,zeta,dtc + character(len=str_long) :: message + integer :: i,e,j + K_bulk=this%elastic_modulus/(3.0_WP*(1.0_WP-2.0_WP*this%poisson_ratio)) + c0=9.0_WP*K_bulk/(2.0_WP*Pi*wmoment(this%delta,3,1)) + dtc=huge(1.0_WP) + do i=1,this%nown + denom=0.0_WP + do e=this%ptr(i),this%ptr(i+1)-1 + j=this%lst(e) + zeta=sqrt(sum((this%x0(:,j)-this%x0(:,i))**2)) + if (zeta.gt.0.0_WP) denom=denom+this%vol(j)*c0*omega(zeta,this%delta)/zeta + end do + if (denom.gt.0.0_WP) dtc=min(dtc,sqrt(2.0_WP*this%rho/denom)) + end do + call MPI_ALLREDUCE(MPI_IN_PLACE,dtc,1,MPI_REAL_WP,MPI_MIN,comm,ierr) + this%dtcrit=dtc + if (amRoot) then + write(message,'("[",a,"] Silling-Askari critical dt = ",es12.5," (diagnostic)")') trim(this%name),this%dtcrit + call log(message) + end if + end block critical_dt + + ! Global half-entry count for logging (= 2*bonds - self-image bonds) + count_bonds: block + use parallel, only: comm + integer(I8) :: nhe8 + nhe8=int(rn,I8) + call MPI_ALLREDUCE(MPI_IN_PLACE,nhe8,1,MPI_INTEGER8,MPI_SUM,comm,ierr) + this%nbond=nhe8 ! total half-entries; = 2*bonds - self-image bonds + ! Exact bond census (lower-gid rule; positive-offset self-images) + count_nb: block + integer :: i2,e2,j2 + this%nb=0_I8 + do i2=1,this%nown + do e2=this%ptr(i2),this%ptr(i2+1)-1 + j2=this%lst(e2) + if (this%gid(i2).lt.this%gid(j2)) then + this%nb=this%nb+1_I8 + else if (this%gid(i2).eq.this%gid(j2).and.j2.gt.this%nown) then + if (shift_positive(this%halo%shift(:,j2-this%nown))) this%nb=this%nb+1_I8 + end if + end do + end do + call MPI_ALLREDUCE(MPI_IN_PLACE,this%nb,1,MPI_INTEGER8,MPI_SUM,comm,ierr) + end block count_nb + end block count_bonds + end subroutine assemble + + !> Weighted volume: mw_i = sum_family w(zeta)*zeta^2*V_j (reference state; + !> never updated by damage) + subroutine compute_mw(this) + implicit none + class(pdsolver), intent(inout) :: this + integer :: i,e,j + real(WP) :: zeta + do i=1,this%nown + this%mw(i)=0.0_WP + do e=this%ptr(i),this%ptr(i+1)-1 + j=this%lst(e) + zeta=sqrt(sum((this%x0(:,j)-this%x0(:,i))**2)) + this%mw(i)=this%mw(i)+omega(zeta,this%delta)*zeta**2*this%vol(j) + end do + end do + end subroutine compute_mw + + !> Dimension-aware LPS constitutive coefficients (omega-independent: mw + !> absorbs the influence function). psi_fac sets the J2 yield threshold on + !> the family deviatoric force-state norm -- yield when + !> ||t_dev||^2 > psi_fac*sigma_yield^2/mw (Mitchell OSB) -- and DOES depend + !> on omega: since td ~ w, the norm scales by the w^2/w moment ratio + !> (int w^2 z^p / int w z^p, p=4 in 3D, 3 in 2D; ratio = 1 for w=1). + subroutine lps_coefs(this,fdim,coef_vol,coef_dev,psi_fac) + implicit none + class(pdsolver), intent(in) :: this + real(WP), intent(out) :: fdim,coef_vol,coef_dev + real(WP), intent(out), optional :: psi_fac + real(WP) :: K_bulk,mu_shear + integer :: ndim + ndim=3-count(this%collapsed) + K_bulk =this%elastic_modulus/(3.0_WP*(1.0_WP-2.0_WP*this%poisson_ratio)) + mu_shear=this%elastic_modulus/(2.0_WP*(1.0_WP+this%poisson_ratio)) + select case (ndim) + case (3) + fdim=3.0_WP; coef_vol=3.0_WP*K_bulk; coef_dev=15.0_WP*mu_shear + if (present(psi_fac)) psi_fac=5.0_WP*wmoment(this%delta,4,2)/wmoment(this%delta,4,1) + case (2) + fdim=2.0_WP; coef_vol=2.0_WP*(K_bulk+mu_shear/3.0_WP); coef_dev= 8.0_WP*mu_shear + if (present(psi_fac)) psi_fac=8.0_WP/3.0_WP*wmoment(this%delta,3,2)/wmoment(this%delta,3,1) + case default + fdim=1.0_WP; coef_vol=this%elastic_modulus; coef_dev= 0.0_WP + if (present(psi_fac)) psi_fac=0.0_WP + end select + end subroutine lps_coefs + + !> Velocity-Verlet step: half-kick + drift, halo position update, + !> dilatation gather, node-centered force sweep, halo force reduce, + !> contact, second half-kick. + subroutine pd_advance(this,dt) + use parallel, only: parallel_time + implicit none + class(pdsolver), intent(inout) :: this + real(WP), intent(in) :: dt + real(WP) :: rho_inv,fdim,cvol,cdev,t0 + real(WP) :: zeta,dY,e_b,t,w + real(WP) :: psi_fac,decay,e_d,td,beta,e_e,over + real(WP) :: sYe2,strial,mu3i + logical :: plastic,do_j2 + real(WP), dimension(3) :: acc,dxv,fx + integer :: i,e,j + + real(WP) :: t_full + t_full=parallel_time() + + rho_inv=1.0_WP/this%rho + call this%lps_coefs(fdim,cvol,cdev,psi_fac) + ! Viscoplastic setup: decay is loop-invariant (exact exponential update, + ! unconditionally stable -- no viscous CFL) + plastic=(this%tau.gt.0.0_WP.and.this%tau.lt.huge(1.0_WP)) + do_j2=(this%sigma_yield.gt.0.0_WP) + decay=0.0_WP + if (plastic) decay=exp(-dt/this%tau) + mu3i=2.0_WP*(1.0_WP+this%poisson_ratio)/(3.0_WP*this%elastic_modulus) ! 1/(3*mu_shear) + + ! First half-kick and drift (owned nodes) + t0=parallel_time() + do i=1,this%nown + if (this%flag(i).eq.PDC_IS_DEAD) cycle + acc=this%gravity+(this%f(:,i)+this%ff(:,i))*rho_inv + if (iand(this%flag(i),PDC_INTEGRATES).ne.0) this%v(:,i)=(1.0_WP-this%damping_rate)*this%v(:,i)+0.5_WP*dt*acc + if (this%collapsed(1)) this%v(1,i)=0.0_WP + if (this%collapsed(2)) this%v(2,i)=0.0_WP + if (this%collapsed(3)) this%v(3,i)=0.0_WP + if (iand(this%flag(i),PDC_MOVES).ne.0) this%y(:,i)=this%y(:,i)+dt*this%v(:,i) + end do + this%wt_kick=this%wt_kick+(parallel_time()-t0) + + ! Exit handling: nodes drifting out through an OPEN non-periodic face die + ! (amrpd drops them at Redistribute; here they are flagged and muted). + ! The death-count allreduce runs only when exits are possible at all, and + ! the mute propagation only on substeps where a death actually occurred. + if (this%watch_exit) then + death_watch: block + use parallel, only: comm + use mpi_f08, only: MPI_ALLREDUCE,MPI_IN_PLACE,MPI_SUM,MPI_INTEGER + integer :: nd,d,e,ierr + logical :: out + nd=0 + do i=1,this%nown + if (this%flag(i).eq.PDC_IS_DEAD) cycle + out=.false. + do d=1,3 + if (this%per(d)) cycle + if (this%lo_bc(d).eq.0.and.this%y(d,i).lt.this%dom_lo(d)) out=.true. + if (this%hi_bc(d).eq.0.and.this%y(d,i).gt.this%dom_hi(d)) out=.true. + end do + if (out) then + this%flag(i)=PDC_IS_DEAD + this%v(:,i)=0.0_WP + this%alive(i)=0.0_WP + nd=nd+1 + end if + end do + call MPI_ALLREDUCE(MPI_IN_PLACE,nd,1,MPI_INTEGER,MPI_SUM,comm,ierr) + if (nd.gt.0) then + ! Propagate life status to halo slots, then permanently mute + ! every entry touching a dead node (dmg=2: distinct from broken, + ! so damage statistics stay honest -- amrpd does not count + ! dropped-particle bonds as damage either) + call this%halo%update1(this%alive) + do i=1,this%nown + if (this%flag(i).eq.PDC_IS_DEAD) then + do e=this%ptr(i),this%ptr(i+1)-1 + if (this%dmg(e).eq.0_1) this%dmg(e)=2_1 + end do + else + do e=this%ptr(i),this%ptr(i+1)-1 + if (this%dmg(e).eq.0_1.and.this%alive(this%lst(e)).lt.0.5_WP) this%dmg(e)=2_1 + end do + end if + end do + ! Force a contact broad-phase rebuild so no candidate list + ! references a corpse (dead nodes are excluded from offers/bins) + if (this%use_contact.and.allocated(this%ylast)) deallocate(this%ylast) + end if + end block death_watch + end if + + ! Refresh halo positions (owner y -> slots, with image shifts) + t0=parallel_time() + call this%halo%update(this%y,3,shifted=.true.) + this%wt_halo=this%wt_halo+(parallel_time()-t0) + + ! Contact service: displacement-triggered broad phase (rebuilds contact + ! halo + candidate list when cumulative drift exhausts the skin), then + ! per-substep refresh of contact-slot positions AND velocities (the only + ! place velocity crosses ranks; the graph halo never carries it) + if (this%use_contact) then + t0=parallel_time() + call this%contact_broadphase() + this%wt_broad=this%wt_broad+(parallel_time()-t0) + t0=parallel_time() + call this%chalo%update(this%y,3,shifted=.true.) + call this%chalo%update(this%v,3,shifted=.false.) + this%wt_halo=this%wt_halo+(parallel_time()-t0) + end if + + ! Dilatation (pure gather; own family only; broken entries excluded -- + ! breaks happen in the force sweep AFTER this, matching amrpd's ordering) + t0=parallel_time() + do i=1,this%nown + this%theta(i)=0.0_WP + do e=this%ptr(i),this%ptr(i+1)-1 + if (this%dmg(e).ne.0_1) cycle + j=this%lst(e) + zeta=sqrt(sum((this%x0(:,j)-this%x0(:,i))**2)) + dY =sqrt(sum((this%y(:,j) -this%y(:,i) )**2)) + e_b=dY-zeta + this%theta(i)=this%theta(i)+omega(zeta,this%delta)*zeta*e_b*this%vol(j) + end do + if (this%mw(i).gt.0.0_WP) then + this%theta(i)=fdim*this%theta(i)/this%mw(i) + else + this%theta(i)=0.0_WP + end if + end do + this%wt_dil=this%wt_dil+(parallel_time()-t0) + + ! Node-centered force sweep: each row computes its OWN force state t + ! (own theta, own mw) and scatters +t/-t; the neighbor's t arrives from + ! the neighbor's own row (locally or via the halo reduce below). + t0=parallel_time() + this%f=0.0_WP + do i=1,this%nown + if (this%mw(i).le.0.0_WP) cycle + ! Per-node J2 return factor from the LAGGED family norm. With + ! hardening (hard_mod>0) the surface radius grows with the node's + ! accumulated equivalent plastic strain lam_p (surface lagged one + ! substep like the norm: exact to O(H/3mu) per substep, and H<<3mu + ! for metals; stress-space equivalent of Peridigm's + ! elastic_plastic_hardening). The increment uses (1-beta)*strial = + ! the trial-stress excess, so the rate-independent limit matches the + ! classical radial return; (1-decay) is the Perzyna-realized + ! fraction. lam_p accumulates even at hard_mod=0 (free plastic- + ! strain diagnostic; forces unchanged there, bit-exact w/ flat yield). + beta=1.0_WP + if (plastic.and.do_j2) then + sYe2=(this%sigma_yield+this%hard_mod*this%lam_p(i))**2 + if (this%td2(i)*this%mw(i).gt.psi_fac*sYe2) then + beta=sqrt(psi_fac*sYe2/(this%td2(i)*this%mw(i))) + strial=sqrt(this%td2(i)*this%mw(i)/psi_fac) + this%lam_p(i)=this%lam_p(i)+(1.0_WP-beta)*(1.0_WP-decay)*strial*mu3i + end if + end if + do e=this%ptr(i),this%ptr(i+1)-1 + if (this%dmg(e).ne.0_1) cycle + j=this%lst(e) + zeta=sqrt(sum((this%x0(:,j)-this%x0(:,i))**2)) + dxv=this%y(:,j)-this%y(:,i) + dY=sqrt(sum(dxv**2)) + if (dY.le.0.0_WP) cycle + e_b=dY-zeta + ! Brittle break on total stretch (e > s0*zeta), irreversible. + ! Each row breaks its OWN half-entry and increments its OWN node's + ! damage by 1/nb0 (nb0 = reference row length); the counterpart row + ! breaks its half independently -- the criterion is symmetric in + ! the endpoints, so both halves break in the same substep (for + ! image bonds, up to shift-association roundoff: a 1-ulp-marginal + ! bond may break one substep apart, a benign local transient -- + ! the intact half still applies its +/- pair, conserving momentum). + if (e_b.gt.this%s0*zeta) then + this%dmg(e)=1_1 + this%damage(i)=this%damage(i)+1.0_WP/real(this%ptr(i+1)-this%ptr(i),WP) + cycle + end if + w=omega(zeta,this%delta) + ! Deviatoric split: e_d carries this HALF-ENTRY's inelastic stretch + ! e_v (per-side history: own theta, own mw -- Peridigm form; e_v=0 + ! recovers canonical elastic LPS bit-for-bit) + e_d=e_b-this%theta(i)*zeta/fdim + td=w/this%mw(i)*cdev*(e_d-this%visc_lambda*this%e_v(e)) + t =w/this%mw(i)*cvol*this%theta(i)*zeta+td + ! J2 family norm: pure own-row gather (no communication) + if (do_j2) this%td2a(i)=this%td2a(i)+td*td*this%vol(j) + ! Pair contribution from THIS row's force state (Peridigm volumes: + ! +t*V_j to self, -t*V_i to the neighbor) + fx=t*dxv/dY + this%f(:,i)=this%f(:,i)+fx*this%vol(j) + this%f(:,j)=this%f(:,j)-fx*this%vol(i) + ! Per-side viscoplastic flow of e_v (exact exponential). Two yield + ! criteria, as in amrpd: + ! sigma_yield>0: J2 radial return (per-node beta computed at the + ! row head above, incl. isotropic hardening), Perzyna- + ! regularized by (1-decay); tau->0 recovers Peridigm's + ! rate-independent return. + ! else: per-bond overstress (yield_stretch=0 -> pure Maxwell). + if (plastic) then + if (do_j2) then + this%e_v(e)=this%e_v(e)+(1.0_WP-beta)*(e_d-this%e_v(e))*(1.0_WP-decay) + else + e_e=e_d-this%e_v(e) + over=abs(e_e)-this%yield_stretch*zeta + if (over.gt.0.0_WP) this%e_v(e)=this%e_v(e)+sign(over*(1.0_WP-decay),e_e) + end if + end if + end do + end do + ! Publish this substep's J2 norm (read by the NEXT substep's return) + if (do_j2) then + this%td2(1:this%nown)=this%td2a(1:this%nown) + this%td2a(1:this%nown)=0.0_WP + end if + this%wt_force=this%wt_force+(parallel_time()-t0) + + ! Assemble cross-rank pair forces (halo slots -> owners, add) + t0=parallel_time() + call this%halo%reduce(this%f,3) + this%wt_reduce=this%wt_reduce+(parallel_time()-t0) + + ! Short-range contact (walls + particle-particle), gather-only: adds + ! into owned f, no reduction (amrpd ordering: after the bond force) + if (this%use_contact) then + t0=parallel_time() + call this%contact_narrow(dt) + this%wt_contact=this%wt_contact+(parallel_time()-t0) + end if + + ! Second half-kick with the fresh force + t0=parallel_time() + do i=1,this%nown + if (this%flag(i).eq.PDC_IS_DEAD) cycle + if (iand(this%flag(i),PDC_INTEGRATES).ne.0) then + acc=this%gravity+(this%f(:,i)+this%ff(:,i))*rho_inv + this%v(:,i)=(1.0_WP-this%damping_rate)*this%v(:,i)+0.5_WP*dt*acc + end if + if (this%collapsed(1)) this%v(1,i)=0.0_WP + if (this%collapsed(2)) this%v(2,i)=0.0_WP + if (this%collapsed(3)) this%v(3,i)=0.0_WP + end do + this%wt_kick=this%wt_kick+(parallel_time()-t0) + + this%tot_time=this%tot_time+(parallel_time()-t_full) + end subroutine pd_advance + + !> Contact broad phase: displacement-triggered rebuild of the contact halo + !> and the candidate CSR. The trigger is one scalar allreduce per substep so + !> the (collective) rebuild decision is rank-consistent. rbuild = + !> 1.2*contact_dist + 2*cskin: engagement reach is bounded by d_eff*(1+0.2) + !> (the r_influ clip) and two nodes drifting cskin each can close 2*cskin + !> between rebuilds, so the candidate set provably contains every pair that + !> can produce force before the next rebuild. + !> + !> Discovery: allgather of per-rank owned-node bounds; for each (rank, + !> periodic-image offset) whose shifted bounds approach mine within rbuild, + !> OFFER my owned nodes in range as (gid, image key, shifted position). The + !> receiver keeps offers with an owned node within rbuild (binned test) and + !> builds the contact halo from the kept references via the standard pdhalo + !> protocol (chalo%nown = ntot, so contact slots append after graph slots). + !> Candidates are then binned over OWNED + CONTACT slots only -- the graph + !> halo is never binned, so bonded remote partners arrive as contact slots + !> when in range and double-counting is structurally impossible. + subroutine contact_broadphase(this) + use parallel, only: comm,rank,nproc,MPI_REAL_WP + use mpi_f08 + use messager, only: die + implicit none + class(pdsolver), intent(inout) :: this + real(WP) :: rbuild,drift + integer :: i,ierr + + if (this%contact_dist.le.0.0_WP) call die('[pdsolver contact] use_contact requires contact_dist > 0') + if (this%cskin.le.0.0_WP) this%cskin=0.5_WP*this%contact_dist + rbuild=1.2_WP*this%contact_dist+2.0_WP*this%cskin + + ! Displacement trigger (collective decision) + if (allocated(this%ylast)) then + drift=0.0_WP + do i=1,this%nown + drift=max(drift,sum((this%y(:,i)-this%ylast(:,i))**2)) + end do + drift=sqrt(drift) + else + drift=huge(1.0_WP) + end if + call MPI_ALLREDUCE(MPI_IN_PLACE,drift,1,MPI_REAL_WP,MPI_MAX,comm,ierr) + if (drift.le.this%cskin) return + this%nrebuild=this%nrebuild+1_I8 + + rebuild: block + real(WP), dimension(3) :: bl,bh,shift,pos_s + real(WP), allocatable :: allb(:,:),opos(:,:),rpos(:,:),kpos(:,:) + integer(I8), allocatable :: ogid(:),rgid(:),kgid(:) + integer, allocatable :: okey(:),rkey(:),kkey(:),kowner(:),slot(:) + integer, dimension(0:nproc-1) :: sc,rc,sd,rd + integer, dimension(0:nproc-1) :: sc3,rc3,sd3,rd3 + integer :: nmax(3),d,r,n1,n2,n3,noff,nrecv,nkeep,k,pass + ! Binning workspace (owned nodes for offer filtering, then combined + ! set for the candidate CSR) + real(WP), dimension(3) :: gl,hcell + integer, dimension(3) :: nc + integer, allocatable :: head(:),nxt(:) + + ! Owned bounds and their global exchange + bl=huge(1.0_WP); bh=-huge(1.0_WP) + do i=1,this%nown + bl=min(bl,this%y(:,i)); bh=max(bh,this%y(:,i)) + end do + allocate(allb(6,0:nproc-1)) + call MPI_ALLGATHER([bl,bh],6,MPI_REAL_WP,allb,6,MPI_REAL_WP,comm,ierr) + + ! Admissible periodic-image offsets for contact range + do d=1,3 + nmax(d)=0 + if (this%per(d).and.this%Ldom(d).gt.0.0_WP) nmax(d)=min(4,int(rbuild/this%Ldom(d))+1) + end do + + ! Offers: two passes (count, then fill), grouped by destination rank + do pass=1,2 + sc=0 + do r=0,nproc-1 + do n3=-nmax(3),nmax(3); do n2=-nmax(2),nmax(2); do n1=-nmax(1),nmax(1) + if (r.eq.rank.and.n1.eq.0.and.n2.eq.0.and.n3.eq.0) cycle + shift=[real(n1,WP)*this%Ldom(1),real(n2,WP)*this%Ldom(2),real(n3,WP)*this%Ldom(3)] + ! Shifted-bounds proximity prefilter + if (any(bl+shift-rbuild.gt.allb(4:6,r)).or.any(bh+shift+rbuild.lt.allb(1:3,r))) cycle + do i=1,this%nown + if (this%flag(i).eq.PDC_IS_DEAD) cycle + pos_s=this%y(:,i)+shift + if (any(pos_s.lt.allb(1:3,r)-rbuild).or.any(pos_s.gt.allb(4:6,r)+rbuild)) cycle + sc(r)=sc(r)+1 + if (pass.eq.2) then + ogid(sd(r)+sc(r))=this%gid(i) + okey(sd(r)+sc(r))=(n1+128)+(n2+128)*256+(n3+128)*65536 + opos(:,sd(r)+sc(r))=pos_s + end if + end do + end do; end do; end do + end do + if (pass.eq.1) then + sd(0)=0 + do r=1,nproc-1 + sd(r)=sd(r-1)+sc(r-1) + end do + noff=sum(sc) + allocate(ogid(max(noff,1)),okey(max(noff,1)),opos(3,max(noff,1))) + end if + end do + + ! Exchange offers (gid, key, shifted position) + call MPI_ALLTOALL(sc,1,MPI_INTEGER,rc,1,MPI_INTEGER,comm,ierr) + rd(0)=0 + do r=1,nproc-1 + rd(r)=rd(r-1)+rc(r-1) + end do + nrecv=sum(rc) + allocate(rgid(max(nrecv,1)),rkey(max(nrecv,1)),rpos(3,max(nrecv,1))) + call MPI_ALLTOALLV(ogid,sc,sd,MPI_INTEGER8,rgid,rc,rd,MPI_INTEGER8,comm,ierr) + call MPI_ALLTOALLV(okey,sc,sd,MPI_INTEGER, rkey,rc,rd,MPI_INTEGER, comm,ierr) + sc3=3*sc; sd3=3*sd; rc3=3*rc; rd3=3*rd + call MPI_ALLTOALLV(opos,sc3,sd3,MPI_REAL_WP,rpos,rc3,rd3,MPI_REAL_WP,comm,ierr) + deallocate(ogid,okey,opos) + + ! Filter offers: keep those with an owned node within rbuild. + ! Bin owned nodes (cell size >= rbuild so a +/-1 cell sweep suffices; + ! dims clamped so degenerate/huge extents stay bounded). + call setup_bins(bl,bh,rbuild,gl,hcell,nc) + allocate(head(nc(1)*nc(2)*nc(3)),nxt(max(this%nown,1))) + head=0 + do i=1,this%nown + if (this%flag(i).eq.PDC_IS_DEAD) cycle + k=cell_of(this%y(:,i),gl,hcell,nc) + nxt(i)=head(k); head(k)=i + end do + allocate(kgid(max(nrecv,1)),kkey(max(nrecv,1)),kowner(max(nrecv,1)),kpos(3,max(nrecv,1))) + nkeep=0 + do r=0,nproc-1 + do i=rd(r)+1,rd(r)+rc(r) + if (near_owned(rpos(:,i),rbuild,gl,hcell,nc,head,nxt)) then + nkeep=nkeep+1 + kgid(nkeep)=rgid(i); kkey(nkeep)=rkey(i); kowner(nkeep)=r; kpos(:,nkeep)=rpos(:,i) + end if + end do + end do + deallocate(rgid,rkey,rpos,head,nxt) + + ! Rebuild the contact halo (slots append after graph slots: nown=ntot) + call this%chalo%finalize() + allocate(slot(max(nkeep,1))) + call this%chalo%build(this%ntot,this%ohash,nkeep,kgid,kkey,kowner,this%Ldom,this%per,slot) + this%nchalo=this%chalo%nhalo + + ! Extend y and v to cover contact slots; stamp slot positions from the + ! kept offers (current values -- chalo%update refreshes each substep) + resize_state: block + real(WP), allocatable :: a2(:,:) + integer :: ntc + ntc=this%ntot+this%nchalo + allocate(a2(3,max(ntc,1))); a2=0.0_WP + a2(:,1:this%ntot)=this%y(:,1:this%ntot) + call move_alloc(a2,this%y) + allocate(a2(3,max(ntc,1))); a2=0.0_WP + a2(:,1:this%nown)=this%v(:,1:this%nown) + call move_alloc(a2,this%v) + do k=1,nkeep + this%y(:,this%ntot+slot(k))=kpos(:,k) + end do + end block resize_state + deallocate(kgid,kkey,kowner,kpos,slot) + + ! Candidate CSR over the contact-visible set: owned nodes (indices + ! 1..nown) + contact slots (ntot+1..ntot+nchalo). Two passes. + candidates: block + integer :: ns,m,jj,cnt,ic,jc,kc,c1,c2,c3 + integer, allocatable :: midx(:) + real(WP), dimension(3) :: blc,bhc + ns=this%nown+this%nchalo + allocate(midx(max(ns,1))) + do m=1,this%nown + midx(m)=m + end do + do m=1,this%nchalo + midx(this%nown+m)=this%ntot+m + end do + blc=bl; bhc=bh + do m=this%nown+1,ns + blc=min(blc,this%y(:,midx(m))); bhc=max(bhc,this%y(:,midx(m))) + end do + call setup_bins(blc,bhc,rbuild,gl,hcell,nc) + allocate(head(nc(1)*nc(2)*nc(3)),nxt(max(ns,1))) + head=0 + do m=1,ns + if (m.le.this%nown) then + if (this%flag(m).eq.PDC_IS_DEAD) cycle + end if + k=cell_of(this%y(:,midx(m)),gl,hcell,nc) + nxt(m)=head(k); head(k)=m + end do + if (allocated(this%cptr)) deallocate(this%cptr) + if (allocated(this%clst)) deallocate(this%clst) + allocate(this%cptr(this%nown+1)) + do pass=1,2 + do i=1,this%nown + cnt=0 + if (this%flag(i).eq.PDC_IS_DEAD) then + if (pass.eq.1) this%cptr(i+1)=0 + cycle + end if + ic=min(nc(1),max(1,int((this%y(1,i)-gl(1))/hcell(1))+1)) + jc=min(nc(2),max(1,int((this%y(2,i)-gl(2))/hcell(2))+1)) + kc=min(nc(3),max(1,int((this%y(3,i)-gl(3))/hcell(3))+1)) + do c3=max(1,kc-1),min(nc(3),kc+1); do c2=max(1,jc-1),min(nc(2),jc+1); do c1=max(1,ic-1),min(nc(1),ic+1) + m=head(c1+nc(1)*(c2-1)+nc(1)*nc(2)*(c3-1)) + do while (m.gt.0) + jj=midx(m) + if (jj.ne.i) then + if (sum((this%y(:,jj)-this%y(:,i))**2).le.rbuild**2) then + cnt=cnt+1 + if (pass.eq.2) this%clst(this%cptr(i)+cnt-1)=jj + end if + end if + m=nxt(m) + end do + end do; end do; end do + if (pass.eq.1) this%cptr(i+1)=cnt ! provisional count + end do + if (pass.eq.1) then + this%cptr(1)=1 + do i=1,this%nown + this%cptr(i+1)=this%cptr(i)+this%cptr(i+1) + end do + allocate(this%clst(max(this%cptr(this%nown+1)-1,1))) + end if + end do + deallocate(midx,head,nxt) + end block candidates + + ! Snapshot positions for the drift trigger + if (allocated(this%ylast)) deallocate(this%ylast) + allocate(this%ylast(3,max(this%nown,1))) + this%ylast(:,1:this%nown)=this%y(:,1:this%nown) + deallocate(allb) + end block rebuild + + contains + + !> Any owned node within r of position p? (binned +/-1 cell sweep) + function near_owned(p,r,gl,h,nc,head,nxt) result(hit) + real(WP), dimension(3), intent(in) :: p,gl,h + real(WP), intent(in) :: r + integer, dimension(3), intent(in) :: nc + integer, intent(in) :: head(:),nxt(:) + logical :: hit + integer :: c(3),d,c1,c2,c3,m + hit=.false. + do d=1,3 + c(d)=min(nc(d),max(1,int((p(d)-gl(d))/h(d))+1)) + end do + do c3=max(1,c(3)-1),min(nc(3),c(3)+1); do c2=max(1,c(2)-1),min(nc(2),c(2)+1); do c1=max(1,c(1)-1),min(nc(1),c(1)+1) + m=head(c1+nc(1)*(c2-1)+nc(1)*nc(2)*(c3-1)) + do while (m.gt.0) + if (sum((this%y(:,m)-p)**2).le.r**2) then + hit=.true. + return + end if + m=nxt(m) + end do + end do; end do; end do + end function near_owned + + end subroutine contact_broadphase + + !> Contact narrow phase: soft-sphere walls + particle-particle over the + !> candidate CSR, gather-only (soft-sphere penalty ported from amrlpt's collision model; + !> IB contact arrives with the coupling layer). Adds force/volume into owned + !> f. Walls use e_w with d_eff = 0.5*contact_dist and m_eff = m1; pairs use + !> e_n with d_eff = contact_dist and m_eff = 0.5*m1 (m1 = rho*vol(i), + !> matching amrpd's uniform rho*dV on a uniform lattice). + subroutine contact_narrow(this,dt) + use mathtools, only: Pi + implicit none + class(pdsolver), intent(inout) :: this + real(WP), intent(in) :: dt + real(WP) :: tau,k_n,eta_n,k_w,eta_w,d_eff_w,m1 + real(WP), dimension(3) :: r1,v1,floc,r2 + real(WP), dimension(3), parameter :: vzero=[0.0_WP,0.0_WP,0.0_WP] + integer :: i,k,j + if (this%contact_dist.le.0.0_WP.or.dt.le.0.0_WP) return + if (this%e_n.le.0.0_WP.or.this%e_w.le.0.0_WP) return + if (this%tau_col.gt.0.0_WP) then + tau=this%tau_col + else + tau=5.0_WP*dt + end if + k_n =(Pi**2+log(this%e_n)**2)/tau**2 + eta_n=-2.0_WP*log(this%e_n)/tau + k_w =(Pi**2+log(this%e_w)**2)/tau**2 + eta_w=-2.0_WP*log(this%e_w)/tau + d_eff_w=0.5_WP*this%contact_dist + do i=1,this%nown + if (this%flag(i).eq.PDC_IS_DEAD) cycle + m1=this%rho*this%vol(i) + r1=this%y(:,i); v1=this%v(:,i) + floc=0.0_WP + ! Wall collisions on faces flagged as walls (virtual partner on the + ! wall directly normal to the node) + if (this%lo_bc(1).eq.1) then; r2=[this%dom_lo(1),r1(2),r1(3)]; call apply_col(k_w,eta_w,d_eff_w,m1,r2,vzero); end if + if (this%hi_bc(1).eq.1) then; r2=[this%dom_hi(1),r1(2),r1(3)]; call apply_col(k_w,eta_w,d_eff_w,m1,r2,vzero); end if + if (this%lo_bc(2).eq.1) then; r2=[r1(1),this%dom_lo(2),r1(3)]; call apply_col(k_w,eta_w,d_eff_w,m1,r2,vzero); end if + if (this%hi_bc(2).eq.1) then; r2=[r1(1),this%dom_hi(2),r1(3)]; call apply_col(k_w,eta_w,d_eff_w,m1,r2,vzero); end if + if (this%lo_bc(3).eq.1) then; r2=[r1(1),r1(2),this%dom_lo(3)]; call apply_col(k_w,eta_w,d_eff_w,m1,r2,vzero); end if + if (this%hi_bc(3).eq.1) then; r2=[r1(1),r1(2),this%dom_hi(3)]; call apply_col(k_w,eta_w,d_eff_w,m1,r2,vzero); end if + ! Particle-particle via the candidate CSR + do k=this%cptr(i),this%cptr(i+1)-1 + j=this%clst(k) + call apply_col(k_n,eta_n,this%contact_dist,0.5_WP*m1,this%y(:,j),this%v(:,j)) + end do + ! Accumulate as force/volume (matches bond force units) + this%f(:,i)=this%f(:,i)+floc/this%vol(i) + end do + + contains + + !> Soft-sphere normal force from virtual partner (r2_in, v2_in) onto i. + !> Host-associated r1, v1, dt, floc. + subroutine apply_col(kk,ee,d_eff,m_eff,r2_in,v2_in) + real(WP), intent(in) :: kk,ee,d_eff,m_eff + real(WP), dimension(3), intent(in) :: r2_in,v2_in + real(WP) :: d12,rnv,r_influ,delta_n + real(WP), dimension(3) :: n12,v12,f_n + d12=norm2(r2_in-r1) + if (d12.lt.10.0_WP*epsilon(d12)) return ! self-overlap guard + n12=(r2_in-r1)/d12 + v12=v1-v2_in + rnv=dot_product(v12,n12) + r_influ=min(abs(rnv)*dt,0.2_WP*d_eff) + delta_n=min(d_eff+r_influ-d12,this%clip_col*d_eff) + if (delta_n.le.0.0_WP) return + f_n=(-m_eff*kk*delta_n-m_eff*ee*rnv)*n12 + floc=floc+f_n + end subroutine apply_col + + end subroutine contact_narrow + + !> Binding CFL: elastic wave + scaled convective (limits 0.5 / 0.1) + subroutine get_cfl(this,dt,cfl) + use parallel, only: comm,MPI_REAL_WP + use mpi_f08, only: MPI_ALLREDUCE,MPI_MAX,MPI_IN_PLACE + implicit none + class(pdsolver), intent(inout) :: this + real(WP), intent(in) :: dt + real(WP), intent(out) :: cfl + real(WP), parameter :: CFL_scale_conv=5.0_WP + real(WP) :: K_bulk,mu_shear,c_p,dp_inv,vmax + integer :: i,ierr + K_bulk =this%elastic_modulus/(3.0_WP*(1.0_WP-2.0_WP*this%poisson_ratio)) + mu_shear=this%elastic_modulus/(2.0_WP*(1.0_WP+this%poisson_ratio)) + c_p =sqrt((K_bulk+4.0_WP*mu_shear/3.0_WP)/this%rho) + dp_inv =1.0_WP/this%dV**(1.0_WP/3.0_WP) + this%CFLe=c_p*dp_inv*dt + this%CFLp=0.0_WP + do i=1,this%nown + if (this%flag(i).eq.PDC_IS_DEAD) cycle + vmax=max(abs(this%v(1,i)),abs(this%v(2,i)),abs(this%v(3,i))) + this%CFLp=max(this%CFLp,vmax*dp_inv) + end do + call MPI_ALLREDUCE(MPI_IN_PLACE,this%CFLp,1,MPI_REAL_WP,MPI_MAX,comm,ierr) + this%CFLp=this%CFLp*dt + cfl=max(CFL_scale_conv*this%CFLp,this%CFLe) + end subroutine get_cfl + + !> Global counts, velocity max, and timer reduction (+reset). Collective. + subroutine get_info(this) + use parallel, only: comm,MPI_REAL_WP + use mpi_f08, only: MPI_ALLREDUCE,MPI_MAX,MPI_MIN,MPI_SUM,MPI_IN_PLACE,MPI_INTEGER8 + implicit none + class(pdsolver), intent(inout) :: this + integer :: i,ierr + integer(I8) :: np_loc + real(WP), dimension(3) :: vmin,vmax + np_loc=0_I8 + vmin=huge(1.0_WP); vmax=-huge(1.0_WP) + this%EPmax=0.0_WP + do i=1,this%nown + if (this%flag(i).eq.PDC_IS_DEAD) cycle + np_loc=np_loc+1_I8 + vmin=min(vmin,this%v(:,i)); vmax=max(vmax,this%v(:,i)) + this%EPmax=max(this%EPmax,this%lam_p(i)) + end do + this%np=np_loc + call MPI_ALLREDUCE(MPI_IN_PLACE,this%np,1,MPI_INTEGER8,MPI_SUM,comm,ierr) + call MPI_ALLREDUCE(MPI_IN_PLACE,this%EPmax,1,MPI_REAL_WP,MPI_MAX,comm,ierr) + call MPI_ALLREDUCE(MPI_IN_PLACE,vmin,3,MPI_REAL_WP,MPI_MIN,comm,ierr) + call MPI_ALLREDUCE(MPI_IN_PLACE,vmax,3,MPI_REAL_WP,MPI_MAX,comm,ierr) + if (this%np.eq.0_I8) then + vmin=0.0_WP; vmax=0.0_WP + end if + this%Umin=vmin(1); this%Umax=vmax(1) + this%Vmin=vmin(2); this%Vmax=vmax(2) + this%Wmin=vmin(3); this%Wmax=vmax(3) + ! Broken half-entry census (each broken bond counts twice, except + ! self-image bonds which have a single half-entry) + count_broken: block + integer(I8) :: nb_loc + integer :: e,i2,j2 + ! Half-entry count (internal) and EXACT broken-bond census: each bond + ! is counted at exactly one of its two half-entries -- the one whose + ! node gid is lower (ties = self-image bonds, counted at the + ! positive-offset image so each appears once) + nb_loc=0_I8; this%nb_broken=0_I8 + do i2=1,this%nown + do e=this%ptr(i2),this%ptr(i2+1)-1 + if (this%dmg(e).eq.0_1) cycle + nb_loc=nb_loc+1_I8 + j2=this%lst(e) + if (this%gid(i2).lt.this%gid(j2)) then + this%nb_broken=this%nb_broken+1_I8 + else if (this%gid(i2).eq.this%gid(j2)) then + if (j2.gt.this%nown) then + if (shift_positive(this%halo%shift(:,j2-this%nown))) this%nb_broken=this%nb_broken+1_I8 + end if + end if + end do + end do + this%nbroken=nb_loc + call MPI_ALLREDUCE(MPI_IN_PLACE,this%nbroken,1,MPI_INTEGER8,MPI_SUM,comm,ierr) + call MPI_ALLREDUCE(MPI_IN_PLACE,this%nb_broken,1,MPI_INTEGER8,MPI_SUM,comm,ierr) + end block count_broken + ! Timers: max (and min for the compute-heavy phases) across ranks, then reset + call MPI_ALLREDUCE(this%wt_kick, this%wtmax_kick, 1,MPI_REAL_WP,MPI_MAX,comm,ierr) + call MPI_ALLREDUCE(this%wt_halo, this%wtmax_halo, 1,MPI_REAL_WP,MPI_MAX,comm,ierr) + call MPI_ALLREDUCE(this%wt_dil, this%wtmax_dil, 1,MPI_REAL_WP,MPI_MAX,comm,ierr) + call MPI_ALLREDUCE(this%wt_dil, this%wtmin_dil, 1,MPI_REAL_WP,MPI_MIN,comm,ierr) + call MPI_ALLREDUCE(this%wt_force, this%wtmax_force, 1,MPI_REAL_WP,MPI_MAX,comm,ierr) + call MPI_ALLREDUCE(this%wt_force, this%wtmin_force, 1,MPI_REAL_WP,MPI_MIN,comm,ierr) + call MPI_ALLREDUCE(this%wt_reduce,this%wtmax_reduce,1,MPI_REAL_WP,MPI_MAX,comm,ierr) + call MPI_ALLREDUCE(this%wt_contact,this%wtmax_contact,1,MPI_REAL_WP,MPI_MAX,comm,ierr) + call MPI_ALLREDUCE(this%wt_broad, this%wtmax_broad, 1,MPI_REAL_WP,MPI_MAX,comm,ierr) + call MPI_ALLREDUCE(this%tot_time, this%maxtot_time, 1,MPI_REAL_WP,MPI_MAX,comm,ierr) + + this%wt_kick=0.0_WP; this%wt_halo=0.0_WP; this%wt_dil=0.0_WP; this%wt_force=0.0_WP; this%wt_reduce=0.0_WP + this%wt_contact=0.0_WP; this%wt_broad=0.0_WP; this%tot_time=0.0_WP + ! Contact-service size census (visibility into the fragmentation-driven + ! degradation mode of the static graph partition) + contact_census: block + integer(I8) :: tmp + this%nchalo_glob=int(this%nchalo,I8) + call MPI_ALLREDUCE(MPI_IN_PLACE,this%nchalo_glob,1,MPI_INTEGER8,MPI_SUM,comm,ierr) + tmp=0_I8 + if (allocated(this%cptr)) tmp=int(this%cptr(this%nown+1)-1,I8) + this%ncand_glob=tmp + call MPI_ALLREDUCE(MPI_IN_PLACE,this%ncand_glob,1,MPI_INTEGER8,MPI_SUM,comm,ierr) + end block contact_census + end subroutine get_info + + !> Release all storage + subroutine finalize(this) + implicit none + class(pdsolver), intent(inout) :: this + if (allocated(this%gid)) deallocate(this%gid) + if (allocated(this%x0)) deallocate(this%x0) + if (allocated(this%y)) deallocate(this%y) + if (allocated(this%v)) deallocate(this%v) + if (allocated(this%f)) deallocate(this%f) + if (allocated(this%ff)) deallocate(this%ff) + if (allocated(this%vol)) deallocate(this%vol) + if (allocated(this%mw)) deallocate(this%mw) + if (allocated(this%theta)) deallocate(this%theta) + if (allocated(this%damage))deallocate(this%damage) + if (allocated(this%lam_p)) deallocate(this%lam_p) + if (allocated(this%alive)) deallocate(this%alive) + if (allocated(this%flag)) deallocate(this%flag) + if (allocated(this%ptr)) deallocate(this%ptr) + if (allocated(this%lst)) deallocate(this%lst) + if (allocated(this%dmg)) deallocate(this%dmg) + if (allocated(this%e_v)) deallocate(this%e_v) + if (allocated(this%td2)) deallocate(this%td2) + if (allocated(this%td2a)) deallocate(this%td2a) + if (allocated(this%cptr)) deallocate(this%cptr) + if (allocated(this%clst)) deallocate(this%clst) + if (allocated(this%ylast)) deallocate(this%ylast) + if (allocated(this%rextra_tmp)) deallocate(this%rextra_tmp) + call this%ohash%finalize() + call this%dir%finalize() + call this%halo%finalize() + call this%chalo%finalize() + this%nown=0; this%nhalo=0; this%ntot=0; this%nchalo=0 + end subroutine finalize + + + !> Mirror synchronization (the coupling bridge). Collective, once per FLUID + !> step. The caller walks its face particles (AMReX container on the + !> fluid decomposition) and passes per particle: gid, core owner rank (read + !> from the face particle's repurposed flag tag), and the F_fluid it interpolated + !> from the grid. This routine routes F_fluid to the owning nodes (held in + !> ff across the subsequent PD subcycles) and replies with each node's + !> current (pos, vel, damage, alive), returned aligned with the caller's + !> input order for direct write-back into the face particles. + subroutine exchange(this,nm,mgid,mowner,mff,mpos,mvel,mdmg,malive) + use parallel, only: comm,nproc,MPI_REAL_WP + use messager, only: die + use mpi_f08 + implicit none + class(pdsolver), intent(inout) :: this + integer, intent(in) :: nm + integer(I8), intent(in) :: mgid(:) + integer, intent(in) :: mowner(:) + real(WP), intent(in) :: mff(:,:) + real(WP), intent(out) :: mpos(:,:),mvel(:,:) + real(WP), intent(out) :: mdmg(:),malive(:) + integer, dimension(0:nproc-1) :: sc,rc,sd,rd + integer, dimension(0:nproc-1) :: scw,rcw,sdw,rdw + integer, allocatable :: pos(:),qpos(:) + integer(I8), allocatable :: sg(:),rg(:) + real(WP), allocatable :: sff(:,:),rff(:,:),srep(:,:),rrep(:,:) + integer :: i,r,nr,idx,ierr + + ! Count and pack by owner, remembering each entry's packed slot + sc=0 + do i=1,nm + sc(mowner(i))=sc(mowner(i))+1 + end do + call MPI_ALLTOALL(sc,1,MPI_INTEGER,rc,1,MPI_INTEGER,comm,ierr) + sd(0)=0; rd(0)=0 + do r=1,nproc-1 + sd(r)=sd(r-1)+sc(r-1); rd(r)=rd(r-1)+rc(r-1) + end do + allocate(pos(0:nproc-1),qpos(max(nm,1))) + allocate(sg(max(nm,1)),sff(3,max(nm,1))) + pos=sd + do i=1,nm + r=mowner(i); pos(r)=pos(r)+1 + sg(pos(r))=mgid(i); sff(:,pos(r))=mff(:,i); qpos(i)=pos(r) + end do + nr=sum(rc) + allocate(rg(max(nr,1)),rff(3,max(nr,1))) + call MPI_ALLTOALLV(sg,sc,sd,MPI_INTEGER8,rg,rc,rd,MPI_INTEGER8,comm,ierr) + scw=3*sc; sdw=3*sd; rcw=3*rc; rdw=3*rd + call MPI_ALLTOALLV(sff,scw,sdw,MPI_REAL_WP,rff,rcw,rdw,MPI_REAL_WP,comm,ierr) + + ! Owner side: ingest F_fluid, build the state reply in arrival order + allocate(rrep(8,max(nr,1))) + do i=1,nr + idx=this%ohash%lookup(rg(i)) + if (idx.lt.1) call die('[pdsolver exchange] face gid not owned by tagged rank') + this%ff(:,idx)=rff(:,i) + rrep(1:3,i)=this%y(:,idx) + rrep(4:6,i)=this%v(:,idx) + rrep(7,i) =this%damage(idx) + rrep(8,i) =this%alive(idx) + end do + + ! Reply along the reverse route; unpack to the caller's original order + allocate(srep(8,max(nm,1))) + scw=8*rc; sdw=8*rd; rcw=8*sc; rdw=8*sd + call MPI_ALLTOALLV(rrep,scw,sdw,MPI_REAL_WP,srep,rcw,rdw,MPI_REAL_WP,comm,ierr) + do i=1,nm + mpos(:,i) =srep(1:3,qpos(i)) + mvel(:,i) =srep(4:6,qpos(i)) + mdmg(i) =srep(7,qpos(i)) + malive(i) =srep(8,qpos(i)) + end do + deallocate(pos,qpos,sg,sff,rg,rff,rrep,srep) + end subroutine exchange + + + !> Owner-rank lookup for arbitrary node gids via the persistent directory. + !> Collective. Drivers use it to re-stamp face routing tags after restart. + subroutine query_owners(this,n,gids,owners) + implicit none + class(pdsolver), intent(inout) :: this + integer, intent(in) :: n + integer(I8), intent(in) :: gids(:) + integer, intent(out) :: owners(:) + call this%dir%query(n,gids,owners) + end subroutine query_owners + + !> Checkpoint the core under /: per-rank stream files + root + !> header. Records are GID-SPACE (no local indices, no partition info) -- + !> nodes: (gid, flag, x0, y, v, f, vol, damage, td2, lam_p); half-entries: + !> (node_gid, nbr_gid, image_key, dmg, e_v), the image key reconstructed + !> from the halo slot's shift. Rank-count portable on read. Format v2 + !> (v1 = pre-hardening, no lam_p record; read_state accepts both). + subroutine write_state(this,dirname) + use parallel, only: rank,nproc,amRoot + use messager, only: die + use string, only: str_medium + implicit none + class(pdsolver), intent(inout) :: this + character(len=*), intent(in) :: dirname + character(len=str_medium) :: fname + integer :: iunit,ios,i,e,j,nhe + integer, allocatable :: hkey(:) + integer(I8), allocatable :: hnode(:),hnbr(:) + ! Half-entries in gid space + nhe=this%ptr(this%nown+1)-1 + allocate(hnode(max(nhe,1)),hnbr(max(nhe,1)),hkey(max(nhe,1))) + do i=1,this%nown + do e=this%ptr(i),this%ptr(i+1)-1 + j=this%lst(e) + hnode(e)=this%gid(i) + hnbr(e) =this%gid(j) + if (j.le.this%nown) then + hkey(e)=PDHALO_KEY0 + else + hkey(e)=key_of_shift(this%halo%shift(:,j-this%nown),this%Ldom) + end if + end do + end do + ! Per-rank stream file + ! All solid state lives under /pd/ (root creates it) + make_dir: block + use parallel, only: comm + use mpi_f08, only: MPI_BARRIER + integer :: ierr2 + if (amRoot) call execute_command_line('mkdir -p '//trim(dirname)//'/pd') + call MPI_BARRIER(comm,ierr2) + end block make_dir + write(fname,'(a,"/pd/pd_",i7.7,".bin")') trim(dirname),rank + open(newunit=iunit,file=trim(fname),form='unformatted',access='stream',status='replace',iostat=ios) + if (ios.ne.0) call die('[pdsolver write_state] cannot open '//trim(fname)) + write(iunit) this%nown,nhe + write(iunit) this%gid(1:this%nown) + write(iunit) this%flag(1:this%nown) + write(iunit) this%x0(:,1:this%nown) + write(iunit) this%y(:,1:this%nown) + write(iunit) this%v(:,1:this%nown) + write(iunit) this%f(:,1:this%nown) + write(iunit) this%vol(1:this%nown) + write(iunit) this%damage(1:this%nown) + write(iunit) this%td2(1:this%nown) + write(iunit) this%lam_p(1:this%nown) + write(iunit) hnode(1:nhe) + write(iunit) hnbr(1:nhe) + write(iunit) hkey(1:nhe) + write(iunit) this%dmg(1:nhe) + write(iunit) this%e_v(1:nhe) + close(iunit) + deallocate(hnode,hnbr,hkey) + ! Root header (file count for portable round-robin reads) + if (amRoot) then + open(newunit=iunit,file=trim(dirname)//'/pd/header',form='formatted',status='replace',iostat=ios) + if (ios.ne.0) call die('[pdsolver write_state] cannot open header') + write(iunit,'(a)') 'pdsolver checkpoint v2' + write(iunit,'(i0)') nproc + close(iunit) + end if + contains + !> Reconstruct the packed image key from a slot shift vector + pure function key_of_shift(s,L) result(k) + implicit none + real(WP), dimension(3), intent(in) :: s,L + integer :: k,n1,n2,n3 + n1=0; n2=0; n3=0 + if (L(1).gt.0.0_WP) n1=nint(s(1)/L(1)) + if (L(2).gt.0.0_WP) n2=nint(s(2)/L(2)) + if (L(3).gt.0.0_WP) n3=nint(s(3)/L(3)) + k=(n1+128)+(n2+128)*256+(n3+128)*65536 + end function key_of_shift + end subroutine write_state + + !> Restore the core from a checkpoint written by write_state. Collective; + !> rank-count portable: files read round-robin, nodes re-partitioned by + !> Morton order of the reference configuration, half-entries routed to + !> their owners, CSR/halo rebuilt via assemble with the loaded per-entry + !> state. The caller must configure the solver (initialize + material/ + !> contact/plastic component assignments) BEFORE calling this. + subroutine read_state(this,dirname) + use parallel, only: comm,rank,nproc,MPI_REAL_WP + use messager, only: die + use string, only: str_medium + use mpi_f08 + implicit none + class(pdsolver), intent(inout) :: this + character(len=*), intent(in) :: dirname + character(len=str_medium) :: fname,line + integer :: nfiles,iunit,ios,f,i,r,ierr,iver + integer :: nn,nhe,nf,nhf + integer(I8), allocatable :: gid(:),hnode(:),hnbr(:) + integer, allocatable :: flag(:),hkey(:),owner(:) + real(WP), allocatable :: x0(:,:),yy(:,:),vv(:,:),ffb(:,:),vol(:),dmgn(:),td2n(:),lamn(:) + real(WP), allocatable :: hev(:) + integer(1), allocatable :: hdmg(:) + + ! Resolve derived configuration (restart-safe shared path) + call this%derive_config() + + ! Header: number of files written + format version (v1 = no lam_p record) + nfiles=0; iver=1 + if (rank.eq.0) then + open(newunit=iunit,file=trim(dirname)//'/pd/header',form='formatted',status='old',iostat=ios) + if (ios.ne.0) call die('[pdsolver read_state] no pd/header under '//trim(dirname)) + read(iunit,'(a)') line + if (index(line,'v2').gt.0) iver=2 + read(iunit,*) nfiles + close(iunit) + end if + call MPI_BCAST(nfiles,1,MPI_INTEGER,0,comm,ierr) + call MPI_BCAST(iver,1,MPI_INTEGER,0,comm,ierr) + + ! Read my round-robin share of the files, concatenating records + nn=0; nhe=0 + do f=rank,nfiles-1,nproc + write(fname,'(a,"/pd/pd_",i7.7,".bin")') trim(dirname),f + open(newunit=iunit,file=trim(fname),form='unformatted',access='stream',status='old',iostat=ios) + if (ios.ne.0) call die('[pdsolver read_state] cannot open '//trim(fname)) + read(iunit) nf,nhf + call grow_i8(gid,nn,nf); call grow_i4(flag,nn,nf) + call grow_r2(x0,nn,nf); call grow_r2(yy,nn,nf) + call grow_r2(vv,nn,nf); call grow_r2(ffb,nn,nf) + call grow_r1(vol,nn,nf); call grow_r1(dmgn,nn,nf); call grow_r1(td2n,nn,nf) + call grow_r1(lamn,nn,nf) + read(iunit) gid(nn+1:nn+nf) + read(iunit) flag(nn+1:nn+nf) + read(iunit) x0(:,nn+1:nn+nf) + read(iunit) yy(:,nn+1:nn+nf) + read(iunit) vv(:,nn+1:nn+nf) + read(iunit) ffb(:,nn+1:nn+nf) + read(iunit) vol(nn+1:nn+nf) + read(iunit) dmgn(nn+1:nn+nf) + read(iunit) td2n(nn+1:nn+nf) + if (iver.ge.2) then + read(iunit) lamn(nn+1:nn+nf) + else + lamn(nn+1:nn+nf)=0.0_WP + end if + call grow_i8(hnode,nhe,nhf); call grow_i8(hnbr,nhe,nhf) + call grow_i4(hkey,nhe,nhf); call grow_i1(hdmg,nhe,nhf); call grow_r1(hev,nhe,nhf) + read(iunit) hnode(nhe+1:nhe+nhf) + read(iunit) hnbr(nhe+1:nhe+nhf) + read(iunit) hkey(nhe+1:nhe+nhf) + read(iunit) hdmg(nhe+1:nhe+nhf) + read(iunit) hev(nhe+1:nhe+nhf) + close(iunit) + nn=nn+nf; nhe=nhe+nhf + end do + if (.not.allocated(gid)) then ! ranks with no files still join collectives + allocate(gid(1),flag(1),x0(3,1),yy(3,1),vv(3,1),ffb(3,1),vol(1),dmgn(1),td2n(1),lamn(1)) + allocate(hnode(1),hnbr(1),hkey(1),hdmg(1),hev(1)) + end if + + ! Re-partition nodes by Morton order of the REFERENCE configuration and + ! route the full records (pd_partition routes the set_nodes payload; the + ! remaining fields ride a second, identically-ordered exchange) + repartition: block + integer(I8), allocatable :: rgid(:) + real(WP), allocatable :: rx0(:,:),rvv(:,:),rvol(:),extra(:,:) + integer, allocatable :: rflag(:) + integer, dimension(0:nproc-1) :: sc,rc,sd,rd,scw,rcw,sdw,rdw + integer, allocatable :: pos(:) + integer :: nr + allocate(owner(max(nn,1))) + call pd_partition(nn,gid,x0,vv,flag,vol,owner,nr,rgid,rx0,rvv,rflag,rvol) + ! Second exchange: (y, f, damage, td2) = 8 reals, packed in the same + ! per-destination input order as pd_partition's own packing + sc=0 + do i=1,nn + sc(owner(i))=sc(owner(i))+1 + end do + call MPI_ALLTOALL(sc,1,MPI_INTEGER,rc,1,MPI_INTEGER,comm,ierr) + sd(0)=0; rd(0)=0 + do r=1,nproc-1 + sd(r)=sd(r-1)+sc(r-1); rd(r)=rd(r-1)+rc(r-1) + end do + allocate(pos(0:nproc-1),extra(9,max(nn,1)),this%rextra_tmp(9,max(nr,1))) + pos=sd + do i=1,nn + r=owner(i); pos(r)=pos(r)+1 + extra(1:3,pos(r))=yy(:,i) + extra(4:6,pos(r))=ffb(:,i) + extra(7,pos(r)) =dmgn(i) + extra(8,pos(r)) =td2n(i) + extra(9,pos(r)) =lamn(i) + end do + scw=9*sc; sdw=9*sd; rcw=9*rc; rdw=9*rd + call MPI_ALLTOALLV(extra,scw,sdw,MPI_REAL_WP,this%rextra_tmp,rcw,rdw,MPI_REAL_WP,comm,ierr) + ! Load the routed nodes, then overlay the restart-only fields + call this%set_nodes(nr,rgid,rx0,rvv,rflag,rvol) + do i=1,nr + this%y(:,i) =this%rextra_tmp(1:3,i) + this%f(:,i) =this%rextra_tmp(4:6,i) + this%damage(i)=this%rextra_tmp(7,i) + end do + deallocate(pos,extra,rgid,rx0,rvv,rflag,rvol) + end block repartition + + ! Register the directory over the new partition, route half-entries to + ! their owners (state travels along), and rebuild CSR/halo/reference + route_and_assemble: block + integer(I8), allocatable :: rnode(:),rnbr(:) + integer, allocatable :: rkey(:),howner(:) + real(WP), allocatable :: rev(:) + integer(1), allocatable :: rdmg(:) + integer, dimension(0:nproc-1) :: sc,rc,sd,rd + integer, allocatable :: pos(:) + integer(I8), allocatable :: s8(:) + integer, allocatable :: s4(:) + real(WP), allocatable :: sr(:) + integer(1), allocatable :: s1(:) + integer :: rn,h + call this%dir%finalize() + call this%dir%register(this%nown,this%gid(1:this%nown)) + allocate(howner(max(nhe,1))) + call this%dir%query(nhe,hnode,howner) + sc=0 + do i=1,nhe + sc(howner(i))=sc(howner(i))+1 + end do + call MPI_ALLTOALL(sc,1,MPI_INTEGER,rc,1,MPI_INTEGER,comm,ierr) + sd(0)=0; rd(0)=0 + do r=1,nproc-1 + sd(r)=sd(r-1)+sc(r-1); rd(r)=rd(r-1)+rc(r-1) + end do + rn=sum(rc) + allocate(rnode(max(rn,1)),rnbr(max(rn,1)),rkey(max(rn,1)),rev(max(rn,1)),rdmg(max(rn,1))) + allocate(pos(0:nproc-1),s8(max(nhe,1)),s4(max(nhe,1)),sr(max(nhe,1)),s1(max(nhe,1))) + pos=sd + do i=1,nhe + h=howner(i); pos(h)=pos(h)+1; s8(pos(h))=hnode(i) + end do + call MPI_ALLTOALLV(s8,sc,sd,MPI_INTEGER8,rnode,rc,rd,MPI_INTEGER8,comm,ierr) + pos=sd + do i=1,nhe + h=howner(i); pos(h)=pos(h)+1; s8(pos(h))=hnbr(i) + end do + call MPI_ALLTOALLV(s8,sc,sd,MPI_INTEGER8,rnbr,rc,rd,MPI_INTEGER8,comm,ierr) + pos=sd + do i=1,nhe + h=howner(i); pos(h)=pos(h)+1; s4(pos(h))=hkey(i) + end do + call MPI_ALLTOALLV(s4,sc,sd,MPI_INTEGER,rkey,rc,rd,MPI_INTEGER,comm,ierr) + pos=sd + do i=1,nhe + h=howner(i); pos(h)=pos(h)+1; sr(pos(h))=hev(i) + end do + call MPI_ALLTOALLV(sr,sc,sd,MPI_REAL_WP,rev,rc,rd,MPI_REAL_WP,comm,ierr) + pos=sd + do i=1,nhe + h=howner(i); pos(h)=pos(h)+1; s1(pos(h))=hdmg(i) + end do + call MPI_ALLTOALLV(s1,sc,sd,MPI_INTEGER1,rdmg,rc,rd,MPI_INTEGER1,comm,ierr) + call this%assemble(rn,rnode,rnbr,rkey,rev,rdmg) + deallocate(rnode,rnbr,rkey,rev,rdmg,pos,s8,s4,sr,s1,howner) + end block route_and_assemble + + ! Overlay td2/lam_p (assemble/set_nodes zero them) and life status + do i=1,this%nown + this%td2(i) =this%rextra_tmp(8,i) + this%lam_p(i)=this%rextra_tmp(9,i) + if (this%flag(i).eq.PDC_IS_DEAD) this%alive(i)=0.0_WP + end do + deallocate(this%rextra_tmp) + call this%halo%update1(this%alive) + deallocate(gid,flag,x0,yy,vv,ffb,vol,dmgn,td2n,lamn,hnode,hnbr,hkey,hdmg,hev,owner) + + contains + + subroutine grow_i8(a,n,add) + integer(I8), allocatable, intent(inout) :: a(:) + integer, intent(in) :: n,add + integer(I8), allocatable :: t(:) + allocate(t(n+add)); if (n.gt.0) t(1:n)=a(1:n) + call move_alloc(t,a) + end subroutine grow_i8 + subroutine grow_i4(a,n,add) + integer, allocatable, intent(inout) :: a(:) + integer, intent(in) :: n,add + integer, allocatable :: t(:) + allocate(t(n+add)); if (n.gt.0) t(1:n)=a(1:n) + call move_alloc(t,a) + end subroutine grow_i4 + subroutine grow_i1(a,n,add) + integer(1), allocatable, intent(inout) :: a(:) + integer, intent(in) :: n,add + integer(1), allocatable :: t(:) + allocate(t(n+add)); if (n.gt.0) t(1:n)=a(1:n) + call move_alloc(t,a) + end subroutine grow_i1 + subroutine grow_r1(a,n,add) + real(WP), allocatable, intent(inout) :: a(:) + integer, intent(in) :: n,add + real(WP), allocatable :: t(:) + allocate(t(n+add)); if (n.gt.0) t(1:n)=a(1:n) + call move_alloc(t,a) + end subroutine grow_r1 + subroutine grow_r2(a,n,add) + real(WP), allocatable, intent(inout) :: a(:,:) + integer, intent(in) :: n,add + real(WP), allocatable :: t(:,:) + allocate(t(3,n+add)); if (n.gt.0) t(:,1:n)=a(:,1:n) + call move_alloc(t,a) + end subroutine grow_r2 + + end subroutine read_state + + + !> Static load-balancing partition of the reference configuration. + !> Collective; called once at handoff, BEFORE set_nodes. Nodes are ordered + !> by the Morton key of their reference position and split into equal-count + !> contiguous ranges: on a uniform lattice family size is ~constant, so node + !> count ~ bond work (a family-weighted split can substitute later), and + !> bond work is motion-invariant -- this balance holds for the entire run + !> regardless of deformation or flight, using ALL ranks even when the solid + !> occupies a corner of the fluid domain. + !> Inputs: this rank's extracted nodes (any distribution). Outputs: the + !> nodes assigned to this rank, plus each INPUT node's assigned owner (for + !> stamping the face particles' routing tags). + subroutine pd_partition(n_in,gid_in,pos_in,vel_in,flag_in,vol_in,owner_out, & + & n_out,gid_out,pos_out,vel_out,flag_out,vol_out) + use parallel, only: comm,rank,nproc,amRoot,MPI_REAL_WP + use pdhalo_class, only: sort3_perm + use mpi_f08 + implicit none + integer, intent(in) :: n_in + integer(I8), intent(in) :: gid_in(:) + real(WP), intent(in) :: pos_in(:,:),vel_in(:,:) + integer, intent(in) :: flag_in(:) + real(WP), intent(in) :: vol_in(:) + integer, intent(out) :: owner_out(:) + integer, intent(out) :: n_out + integer(I8), allocatable, intent(out) :: gid_out(:) + real(WP), allocatable, intent(out) :: pos_out(:,:),vel_out(:,:),vol_out(:) + integer, allocatable, intent(out) :: flag_out(:) + real(WP), dimension(3) :: blo,bhi,inv + integer(I8), allocatable :: keys(:),splitters(:) + integer :: i,r,d,ierr + + ! Global reference bounds + blo=huge(1.0_WP); bhi=-huge(1.0_WP) + do i=1,n_in + blo=min(blo,pos_in(:,i)); bhi=max(bhi,pos_in(:,i)) + end do + call MPI_ALLREDUCE(MPI_IN_PLACE,blo,3,MPI_REAL_WP,MPI_MIN,comm,ierr) + call MPI_ALLREDUCE(MPI_IN_PLACE,bhi,3,MPI_REAL_WP,MPI_MAX,comm,ierr) + do d=1,3 + inv(d)=0.0_WP + if (bhi(d).gt.blo(d)) inv(d)=2097151.0_WP/(bhi(d)-blo(d)) + end do + + ! Morton keys of this rank's nodes + allocate(keys(max(n_in,1))) + do i=1,n_in + keys(i)=morton(pos_in(:,i),blo,inv) + end do + + ! Equal-weight splitters by SAMPLE SORT: each rank contributes a few + ! evenly-spaced samples of its locally sorted keys, weighted by its node + ! count -- root memory is O(nproc*S), not O(N_global), so this scales to + ! very large rank counts (the old gather-all-keys approach walled at + ! root memory and int32 N_global). + allocate(splitters(max(nproc-1,1))) + sample_splitters: block + integer, parameter :: S=16 + integer(I8), allocatable :: lsamp(:),gsamp(:),gw(:) + real(WP), allocatable :: w(:) + integer, allocatable :: perm(:),zk(:),scnt(:),sdis(:) + integer(I8) :: wtot,wcum,wtarg + integer :: ns,j,r2,gtot + ! Locally sort keys (permutation) and draw samples + allocate(perm(max(n_in,1)),zk(max(n_in,1))) + do i=1,n_in + perm(i)=i + end do + zk=0 + if (n_in.gt.1) call sort3_perm(zk,keys(1:n_in),zk,perm,1,n_in) + ns=min(S,n_in) + allocate(lsamp(max(ns,1))) + do j=1,ns + lsamp(j)=keys(perm(min(n_in,int((real(j,WP)-0.5_WP)*real(n_in,WP)/real(ns,WP))+1))) + end do + deallocate(perm,zk) + ! Gather samples (+ per-rank sample counts and node counts) on root + allocate(scnt(nproc),sdis(nproc)) + call MPI_GATHER(ns,1,MPI_INTEGER,scnt,1,MPI_INTEGER,0,comm,ierr) + gtot=0 + if (amRoot) then + sdis(1)=0 + do r2=2,nproc + sdis(r2)=sdis(r2-1)+scnt(r2-1) + end do + gtot=sum(scnt) + end if + allocate(gsamp(max(gtot,1)),gw(nproc)) + call MPI_GATHERV(lsamp,ns,MPI_INTEGER8,gsamp,scnt,sdis,MPI_INTEGER8,0,comm,ierr) + call MPI_GATHER(int(n_in,I8),1,MPI_INTEGER8,gw,1,MPI_INTEGER8,0,comm,ierr) + if (amRoot.and.gtot.gt.0) then + root_split: block + integer, allocatable :: p2(:),z2(:) + real(WP), allocatable :: sw(:) + ! Weight each sample by (its rank's node count)/(its rank's samples) + allocate(sw(gtot),p2(gtot),z2(gtot)) + do r2=1,nproc + do j=sdis(r2)+1,sdis(r2)+scnt(r2) + sw(j)=real(gw(r2),WP)/real(max(scnt(r2),1),WP) + end do + end do + do j=1,gtot + p2(j)=j + end do + z2=0 + call sort3_perm(z2,gsamp(1:gtot),z2,p2,1,gtot) + ! Single cumulative-weight pass placing all nproc-1 splitters + wtot=sum(gw) + wcum=0_I8; r2=1 + do j=1,gtot + if (r2.gt.nproc-1) exit + wcum=wcum+int(sw(p2(j)),I8) + do while (r2.le.nproc-1.and.wcum.ge.(int(r2,I8)*wtot)/int(nproc,I8)) + splitters(r2)=gsamp(p2(j)) + r2=r2+1 + end do + end do + do while (r2.le.nproc-1) + splitters(r2)=huge(1_I8) ! degenerate tail: empty upper buckets + r2=r2+1 + end do + deallocate(sw,p2,z2) + end block root_split + end if + deallocate(lsamp,gsamp,gw,scnt,sdis) + end block sample_splitters + if (nproc.gt.1) call MPI_BCAST(splitters,nproc-1,MPI_INTEGER8,0,comm,ierr) + + ! Assign owners: bucket = number of splitters <= key + do i=1,n_in + owner_out(i)=0 + do r=1,nproc-1 + if (keys(i).ge.splitters(r)) owner_out(i)=r + end do + end do + deallocate(keys,splitters) + + ! Route node payloads to their owners + route_nodes: block + integer, dimension(0:nproc-1) :: sc,rc,sd,rd,scw,rcw,sdw,rdw + integer, allocatable :: pos(:),sflag(:) + integer(I8), allocatable :: sgid(:) + real(WP), allocatable :: sdat(:,:),rdat(:,:) + sc=0 + do i=1,n_in + sc(owner_out(i))=sc(owner_out(i))+1 + end do + call MPI_ALLTOALL(sc,1,MPI_INTEGER,rc,1,MPI_INTEGER,comm,ierr) + sd(0)=0; rd(0)=0 + do r=1,nproc-1 + sd(r)=sd(r-1)+sc(r-1); rd(r)=rd(r-1)+rc(r-1) + end do + n_out=sum(rc) + allocate(pos(0:nproc-1),sgid(max(n_in,1)),sflag(max(n_in,1)),sdat(7,max(n_in,1))) + pos=sd + do i=1,n_in + r=owner_out(i); pos(r)=pos(r)+1 + sgid(pos(r))=gid_in(i) + sflag(pos(r))=flag_in(i) + sdat(1:3,pos(r))=pos_in(:,i) + sdat(4:6,pos(r))=vel_in(:,i) + sdat(7,pos(r)) =vol_in(i) + end do + allocate(gid_out(max(n_out,1)),flag_out(max(n_out,1)),rdat(7,max(n_out,1))) + allocate(pos_out(3,max(n_out,1)),vel_out(3,max(n_out,1)),vol_out(max(n_out,1))) + call MPI_ALLTOALLV(sgid,sc,sd,MPI_INTEGER8,gid_out,rc,rd,MPI_INTEGER8,comm,ierr) + call MPI_ALLTOALLV(sflag,sc,sd,MPI_INTEGER,flag_out,rc,rd,MPI_INTEGER,comm,ierr) + scw=7*sc; sdw=7*sd; rcw=7*rc; rdw=7*rd + call MPI_ALLTOALLV(sdat,scw,sdw,MPI_REAL_WP,rdat,rcw,rdw,MPI_REAL_WP,comm,ierr) + do i=1,n_out + pos_out(:,i)=rdat(1:3,i) + vel_out(:,i)=rdat(4:6,i) + vol_out(i) =rdat(7,i) + end do + deallocate(pos,sgid,sflag,sdat,rdat) + end block route_nodes + + contains + + !> 63-bit Morton key: 21 bits per dimension, bit-interleaved + pure function morton(p,lo,inv) result(key) + implicit none + real(WP), dimension(3), intent(in) :: p,lo,inv + integer(I8) :: key + integer(I8), dimension(3) :: ix + integer :: b,d + do d=1,3 + ix(d)=int(min(max((p(d)-lo(d))*inv(d),0.0_WP),2097151.0_WP),I8) + end do + key=0_I8 + do b=0,20 + do d=1,3 + if (btest(ix(d),b)) key=ibset(key,3*b+d-1) + end do + end do + end function morton + + end subroutine pd_partition + + + !> Bin geometry: cell size >= the search radius (so +/-1 cell sweeps are complete), + !> dims clamped to keep total cell count bounded on huge/degenerate extents + subroutine setup_bins(lo,hi,r,gl,h,nc) + real(WP), dimension(3), intent(in) :: lo,hi + real(WP), intent(in) :: r + real(WP), dimension(3), intent(out) :: gl,h + integer, dimension(3), intent(out) :: nc + integer :: d + do d=1,3 + gl(d)=lo(d)-0.5_WP*r + nc(d)=max(1,min(256,int((hi(d)-lo(d)+r)/r))) + h(d)=max((hi(d)+0.5_WP*r-gl(d))/real(nc(d),WP),r) + end do + end subroutine setup_bins + + !> Flattened cell index of a position (clamped into the grid) + pure function cell_of(p,gl,h,nc) result(k) + real(WP), dimension(3), intent(in) :: p,gl,h + integer, dimension(3), intent(in) :: nc + integer :: k,c(3),d + do d=1,3 + c(d)=min(nc(d),max(1,int((p(d)-gl(d))/h(d))+1)) + end do + k=c(1)+nc(1)*(c(2)-1)+nc(1)*nc(2)*(c(3)-1) + end function cell_of + + + !> Influence function w(zeta) (Peridigm forms). ONE form active, hard-coded; + !> flip by (un)commenting -- s0-from-G_c, psi_fac, and the critical-dt + !> diagnostic all generalize through wmoment(), so nothing else changes. + pure function omega(d,h) result(w) + implicit none + real(WP), intent(in) :: d,h + real(WP) :: w + real(WP) :: s + ! Parabolic decay (ACTIVE): 1 in the core, C1 taper to 0 at the horizon + s=d/h + if (s.lt.0.5_WP) then + w=1.0_WP + else + w=max(4.0_WP*s*(1.0_WP-s),0.0_WP) + end if + ! Constant (Peridigm default; pre-2026-07-16 behavior) + !w=1.0_WP + ! Gaussian + !w=exp(-(d/(0.4_WP*h))**2) + end function omega + + !> Moment of the influence function: int_0^delta w(z)^wpow * z^zpow dz + !> (midpoint quadrature through omega(), so any form change propagates) + pure function wmoment(delta,zpow,wpow) result(m) + implicit none + real(WP), intent(in) :: delta + integer, intent(in) :: zpow,wpow + real(WP) :: m + integer, parameter :: NQ=2048 + integer :: i + real(WP) :: z,dz + dz=delta/real(NQ,WP) + m=0.0_WP + do i=1,NQ + z=(real(i,WP)-0.5_WP)*dz + m=m+omega(z,delta)**wpow*z**zpow + end do + m=m*dz + end function wmoment + + !> Lexicographic sign of an image shift: .true. for the "positive" member + !> of a self-image pair (first nonzero component positive), so each + !> self-image bond is census-counted exactly once. + pure function shift_positive(s) result(p) + implicit none + real(WP), dimension(3), intent(in) :: s + logical :: p + integer :: d + p=.false. + do d=1,3 + if (abs(s(d)).gt.0.0_WP) then + p=(s(d).gt.0.0_WP) + return + end if + end do + end function shift_positive + + !> Negate a packed periodic image offset (amrpd hist1 convention) + pure function negkey(key) result(nk) + implicit none + integer, intent(in) :: key + integer :: nk,n1,n2,n3 + n1=mod(key,256)-128; n2=mod(key/256,256)-128; n3=key/65536-128 + nk=(-n1+128)+(-n2+128)*256+(-n3+128)*65536 + end function negkey + +end module OSB_class diff --git a/examples/NOSB_cylinder_peridigm/src/amrpd_class.f90 b/examples/NOSB_cylinder_peridigm/src/amrpd_class.f90 new file mode 100644 index 000000000..31adb0a5b --- /dev/null +++ b/examples/NOSB_cylinder_peridigm/src/amrpd_class.f90 @@ -0,0 +1,1141 @@ +!> Grid-side extension of the PD solver: an amrpd IS a pdsolver (extends it) +!> plus an AMReX particle mirror of its nodes (the "face"), distributed by +!> position over the fluid grid's boxes so every grid-facing operation runs +!> where the cells live: volume-fraction and velocity deposits, field +!> interpolation at particle positions (F_fluid), VF-driven AMR tagging, +!> and plotfile visualization. +!> +!> Usage tiers (amrpd EXTENDS pdsolver: one object is the solid solver AND +!> its grid face -- assign material/damage/contact fields, then call handoff): +!> 1. pdsolver alone -- grid-free solid dynamics (no visualization) +!> 2. amrpd -- adds viz, solid VF on the mesh, AMR refinement, +!> seeding, and the face<->solver exchange +!> 3. ... + a flow solver -- two-way FSI (driver deposits IB forcing; the +!> fluid load returns via exchange_solid) +module amrpd_class + use precision, only: WP,I8 + use string, only: str_medium + use amrgrid_class, only: amrgrid + use amrdata_class, only: amrdata + use pdsolver_class, only: pdsolver,pd_partition,PD_WALL,PDC_IS_DEAD + use iso_c_binding + implicit none + private + + ! Public exports + public :: amrpd,part,part_gid + + ! Particle motion-control bit flags (composed by bit-OR into idata[0]) + ! Standard cases: + ! Free particle = PART_MOVES + PART_INTEGRATES + PART_BONDS (= 7) + ! Clamped fixed = PART_BONDS (= 4) + ! Velocity-prescribed = PART_MOVES + PART_BONDS (= 5) + ! Witness/probe = PART_MOVES (= 1) + ! Inactive (recycled) = PART_IS_DEAD (= 0) + integer(c_int), parameter, public :: PART_IS_DEAD = 0 !< Inactive; recycled out by AMReX + integer(c_int), parameter, public :: PART_MOVES = 1 !< pos += dt*vel during advance + integer(c_int), parameter, public :: PART_INTEGRATES = 2 !< vel += (dt/2)*acc during Verlet half-kick + integer(c_int), parameter, public :: PART_BONDS = 4 !< Eligible for bond-network participation + + ! Struct layout constants -- MUST match #defines in amrpd_wrapper.cpp + integer, parameter, public :: AMRPD_NREAL_PART = 15 + integer, parameter, public :: AMRPD_NINT_PART = 1 + integer, parameter, public :: AMRPD_NREAL_BOND = 4 + integer, parameter, public :: AMRPD_NINT_BOND = 5 + + !> Solid particle struct -- must match C++ Particle<15,1> memory layout: + !> pos[3], rdata[15], idcpu, idata[1]. Physics lives in pdsolver; only + !> pos/vel/F_fluid/damage are meaningful here (rest is legacy layout). + type, bind(C), public :: part + real(c_double) :: pos(3) !< AMReX-managed position + real(c_double) :: vel(3) !< rdata[0..2] + real(c_double) :: F_bond(3) !< rdata[3..5] (unused) + real(c_double) :: F_fluid(3) !< rdata[6..8] fluid load interpolated by the driver + real(c_double) :: mw !< rdata[9] (unused) + real(c_double) :: dil !< rdata[10] (unused) + real(c_double) :: damage !< rdata[11] broken-bond fraction in [0,1] + real(c_double) :: nb0 !< rdata[12] (unused) + real(c_double) :: td2 !< rdata[13] (unused) + real(c_double) :: td2a !< rdata[14] (unused) + integer(c_int64_t), private :: idcpu !< AMReX packed id+cpu + integer(c_int) :: flag !< idata[0]: PART_* flags at seeding; owner routing tag (7+8*owner) after handoff + end type part + + + + !> C interface bindings to amrpd_wrapper.cpp + interface + + ! Lifecycle + subroutine amrpd_new_pcp(pc,amrcore) bind(c) + import :: c_ptr + type(c_ptr) :: pc + type(c_ptr), value :: amrcore + end subroutine + subroutine amrpd_delete_pcp(pc) bind(c) + import :: c_ptr + type(c_ptr), value :: pc + end subroutine + + ! Redistribute + subroutine amrpd_redistribute_p(pc,lev_min,lev_max,ng) bind(c) + import :: c_ptr,c_int + type(c_ptr), value :: pc + integer(c_int), value :: lev_min,lev_max,ng + end subroutine + + + ! MFIter accessors -- particles + subroutine amrpd_get_particles_mfi(pc,lev,mfi,dp,np) bind(c) + import :: c_ptr,c_int,c_int64_t + type(c_ptr), value :: pc,mfi + integer(c_int), value :: lev + type(c_ptr) :: dp + integer(c_int64_t) :: np + end subroutine + + + ! Single-element insertion (initialization) + subroutine amrpd_add_particle_i(pc,lev,grid,tile,p) bind(c) + import :: c_ptr,c_int + type(c_ptr), value :: pc,p + integer(c_int), value :: lev,grid,tile + end subroutine + + ! Bulk append at level 0 (collective; ranks with n=0 pass raw=NULL) + subroutine amrpd_append_particles(pc,raw,n) bind(c) + import :: c_ptr,c_int64_t + type(c_ptr), value :: pc + type(c_ptr), value :: raw + integer(c_int64_t), value :: n + end subroutine + subroutine amrpd_append_particles_gid(pc,raw,n,gids) bind(c) + import :: c_ptr,c_int64_t + type(c_ptr), value :: pc + type(c_ptr), value :: raw + integer(c_int64_t), value :: n + type(c_ptr), value :: gids + end subroutine + + ! BoxArray / DistributionMap accessors + subroutine amrpd_get_particle_boxarray_p(pc,lev,ba) bind(c) + import :: c_ptr,c_int + type(c_ptr), value :: pc + integer(c_int), value :: lev + type(c_ptr) :: ba + end subroutine + subroutine amrpd_get_particle_distromap_p(pc,lev,dm) bind(c) + import :: c_ptr,c_int + type(c_ptr), value :: pc + integer(c_int), value :: lev + type(c_ptr) :: dm + end subroutine + subroutine amrpd_set_particle_boxarray_p(pc,lev,ba) bind(c) + import :: c_ptr,c_int + type(c_ptr), value :: pc + integer(c_int), value :: lev + type(c_ptr), value :: ba + end subroutine + subroutine amrpd_set_particle_distromap_p(pc,lev,dm) bind(c) + import :: c_ptr,c_int + type(c_ptr), value :: pc + integer(c_int), value :: lev + type(c_ptr), value :: dm + end subroutine + + ! ID/CPU counters and accessors + subroutine amrpd_get_next_id_p(id) bind(c) + import :: c_int64_t + integer(c_int64_t) :: id + end subroutine + subroutine amrpd_set_next_id_p(id) bind(c) + import :: c_int64_t + integer(c_int64_t), value :: id + end subroutine + subroutine amrpd_get_cpu(cpu) bind(c) + import :: c_int + integer(c_int) :: cpu + end subroutine + subroutine amrpd_get_particle_id(id,p) bind(c) + import :: c_int64_t,c_ptr + integer(c_int64_t) :: id + type(c_ptr), value :: p + end subroutine + subroutine amrpd_set_particle_id(id,p) bind(c) + import :: c_int64_t,c_ptr + integer(c_int64_t), value :: id + type(c_ptr), value :: p + end subroutine + subroutine amrpd_get_particle_cpu(cpu,p) bind(c) + import :: c_int,c_ptr + integer(c_int) :: cpu + type(c_ptr), value :: p + end subroutine + subroutine amrpd_set_particle_cpu(cpu,p) bind(c) + import :: c_int,c_ptr + integer(c_int), value :: cpu + type(c_ptr), value :: p + end subroutine + + + ! Global counts + subroutine amrpd_total_np(pc,np) bind(c) + import :: c_ptr,c_int64_t + type(c_ptr), value :: pc + integer(c_int64_t) :: np + end subroutine + + ! Checkpoint I/O: caller composes fullpath (e.g. /particles) + subroutine amrpd_checkpoint_p(pc,path) bind(c) + import :: c_ptr,c_char + type(c_ptr), value :: pc + character(kind=c_char) :: path(*) + end subroutine + subroutine amrpd_restart_p(pc,path) bind(c) + import :: c_ptr,c_char + type(c_ptr), value :: pc + character(kind=c_char) :: path(*) + end subroutine + + end interface + + + !> Grid-side extension of the PD solver: an amrpd IS a pdsolver, plus an + !> AMReX particle mirror of its nodes (the "face") distributed by position + !> over the fluid grid's boxes for deposits, interpolation, tagging, and viz + type, extends(pdsolver) :: amrpd + + !> Associated AMR grid + class(amrgrid), pointer :: amr => null() + + !> Opaque AMReX container handle + type(c_ptr) :: pcp = c_null_ptr !< Particle container + + !> Face load-balance metrics across ranks (grid decomposition; the + !> solver's own Morton partition is balanced by construction) + integer(I8) :: np_loc = 0 !< This rank's face particle count + integer(I8) :: np_min = 0 !< Min across ranks + integer(I8) :: np_max = 0 !< Max across ranks + real(WP) :: np_eff = 0.0_WP !< Load efficiency = mean/max + + !> Maximum AMR level particles are allowed on (cap passed to AMReX + !> Redistribute as lev_max). Particles span levels [0, maxlvl] and + !> AMReX places each at the finest level covering its position. + !> Defaults to amr%maxlvl in initialize. + integer :: maxlvl = 0 + + !> Overlap (ghost cell) width. Must be a multiple of the AMR refinement + !> ratio (2 in standard AMReX setups) because amrdata's process_deposit + !> uses sum_fine_to_coarse, which asserts nGrow % ratio == 0. Matches + !> amrlpt's default. + integer :: nover = 2 + + + !> Particle volume fraction on the Eulerian AMR mesh. Cell-centered scalar + !> (one component), one ghost layer. Updated each advance step by + !> update_VF: trilinear deposition of each particle's volume dV onto the + !> 8 surrounding cell centers, then average-down + optional smoothing. + !> Drives the AMR tagging callback when VF_tag > 0. + type(amrdata) :: VF + real(WP) :: VF_tag = -1.0_WP !< Refinement threshold (<=0 disables VF-driven tagging) + real(WP) :: filter_width = 0.0_WP !< Gaussian-equivalent filter width for VF; 0 disables + real(WP) :: VF_snap = 0.1_WP !< Deposit-moire amplitude: VF is rescaled by 1/(1-VF_snap) and clipped, + !< so a fully packed interior reads exactly 1. 0 disables. + real(WP) :: VFmin=0.0_WP,VFmax=0.0_WP,VFmean=0.0_WP !< VF statistics + + !> Optional user-supplied tagging callback. Called AFTER the built-in VF + !> tagging. Use to add custom refinement criteria (e.g., damage > 0.3). + procedure(pd_tagging_iface), pointer, pass :: user_pd_tagging => null() + + contains + ! Lifecycle + procedure :: initialize + procedure :: finalize + ! Container utilities + procedure :: redistribute + procedure :: get_info !< Global counts + min/max/mean velocities + load-balance metrics + procedure :: set_particle_ba_p + procedure :: set_particle_dm_p + ! Particle population + procedure :: append + procedure :: append_with_gids + ! Solver coupling (grid face <-> contained pdsolver) + procedure :: handoff + procedure :: exchange_solid + procedure :: rebuild_face + ! MFIter helpers (particle container's BA/DM) + procedure :: mfiter_build + procedure :: mfiter_destroy + procedure :: get_particles + ! AMR callbacks + procedure :: post_regrid + procedure :: tagging + ! Particle volume fraction + AMR tagging + procedure :: update_VF !< Compute VF from particle positions (trilinear deposit) + procedure :: process_deposit !< Post-process a deposited field (extensive -> intensive + C/F transfers; public: also used on driver-deposited fields) + procedure :: filter !< Explicit-diffusion smoothing of a cell-centered amrdata (public: also used on driver-deposited fields) + ! Physics -- STUBBED in skeleton + procedure :: interp !< Trilinear cell-centered interpolation (used by compute_contact for IB) + ! Checkpoint I/O + procedure :: write + procedure :: read + ! Diagnostics + procedure :: print + end type amrpd + + + !> Abstract interface for user-overridable tagging callback. Invoked AFTER + !> the built-in VF-based tagging by the registered AMReX tagging dispatch. + abstract interface + subroutine pd_tagging_iface(solver,lvl,time,tags) + import :: amrpd,c_ptr,WP + class(amrpd), intent(inout) :: solver + integer, intent(in) :: lvl + real(WP), intent(in) :: time + type(c_ptr), intent(in) :: tags + end subroutine pd_tagging_iface + end interface + + +contains + + + !> Public accessor for a particle's unique 64-bit GID key (its AMReX idcpu). + !> The idcpu component is private to protect the AMReX layout; the graph-core + !> handoff and parity tooling need the key for gid-matched state exchange. + function part_gid(p) result(gid) + implicit none + type(part), intent(in) :: p + integer(I8) :: gid + gid=p%idcpu + end function part_gid + + + ! ============================================================================ + ! DISPATCHERS (module-level) -- recover concrete amrpd type from c_ptr ctx + ! ============================================================================ + + !> Dispatch post_regrid: calls type-bound method + subroutine amrpd_postregrid_dispatch(ctx,lbase,time) + use iso_c_binding, only: c_ptr,c_f_pointer + implicit none + type(c_ptr), intent(in) :: ctx + integer, intent(in) :: lbase + real(WP), intent(in) :: time + type(amrpd), pointer :: this + call c_f_pointer(ctx,this) + call this%post_regrid(lbase,time) + end subroutine amrpd_postregrid_dispatch + + !> Dispatch tagging: calls type-bound method, then user override (if any) + subroutine amrpd_tagging_dispatch(ctx,lvl,time,tags) + use iso_c_binding, only: c_ptr,c_f_pointer + implicit none + type(c_ptr), intent(in) :: ctx + integer, intent(in) :: lvl + real(WP), intent(in) :: time + type(c_ptr), intent(in) :: tags + type(amrpd), pointer :: this + call c_f_pointer(ctx,this) + call this%tagging(lvl,time,tags) + if (associated(this%user_pd_tagging)) call this%user_pd_tagging(lvl,time,tags) + end subroutine amrpd_tagging_dispatch + + + ! ============================================================================ + ! LIFECYCLE + ! ============================================================================ + + !> Initialize amrpd solver: create particle container, register AMR callbacks + subroutine initialize(this,amr,name) + use amrex_amr_module, only: amrex_bc_foextrap + implicit none + class(amrpd), intent(inout) :: this + class(amrgrid), target, intent(in) :: amr + character(len=*), optional :: name + ! Set solver name + if (present(name)) this%name = trim(adjustl(name)) + ! Point to associated AMR grid + this%amr => amr + ! Default level cap: allow particles up to the AMR grid's max refinement + this%maxlvl = amr%maxlvl + ! Default deposit-smoothing width + this%filter_width = 2.0_WP*this%amr%min_meshsize(this%amr%maxlvl) + ! Create AMReX particle container + call amrpd_new_pcp(this%pcp,this%amr%amrcore) + ! Stamp the solver's domain geometry from the grid (material, damage, + ! and contact fields are driver-assigned) + this%Ldom=[amr%xhi-amr%xlo,amr%yhi-amr%ylo,amr%zhi-amr%zlo] + this%per=[amr%xper,amr%yper,amr%zper] + this%collapsed=[amr%nx.eq.1,amr%ny.eq.1,amr%nz.eq.1] + this%dom_lo=[amr%xlo,amr%ylo,amr%zlo] + this%dom_hi=[amr%xhi,amr%yhi,amr%zhi] + ! Particle volume fraction field (cell-centered, 1 ghost layer; foextrap + ! on non-periodic faces matches amrlpt's convention) + call this%VF%initialize(amr=amr,name='VF',ncomp=1,ng=this%nover); call this%VF%register() + if (.not.this%amr%xper) then; this%VF%lo_bc(1,1)=amrex_bc_foextrap; this%VF%hi_bc(1,1)=amrex_bc_foextrap; end if + if (.not.this%amr%yper) then; this%VF%lo_bc(2,1)=amrex_bc_foextrap; this%VF%hi_bc(2,1)=amrex_bc_foextrap; end if + if (.not.this%amr%zper) then; this%VF%lo_bc(3,1)=amrex_bc_foextrap; this%VF%hi_bc(3,1)=amrex_bc_foextrap; end if + ! Register AMR callbacks (post_regrid + tagging) so containers stay in sync + select type (this) + type is (amrpd) + call this%amr%add_postregrid(amrpd_postregrid_dispatch,c_loc(this)) + call this%amr%add_tagging (amrpd_tagging_dispatch, c_loc(this)) + end select + ! Print solver info + call this%print() + end subroutine initialize + + !> Finalize: destroy face and container, then the parent solver + subroutine finalize(this) + implicit none + class(amrpd), intent(inout) :: this + ! Drop user tagging hook + nullify(this%user_pd_tagging) + ! Tear down the volume-fraction field + call this%VF%finalize() + if (c_associated(this%pcp)) then + call amrpd_delete_pcp(this%pcp); this%pcp = c_null_ptr + end if + nullify(this%amr) + ! Tear down the solver state + call this%pdsolver%finalize() + end subroutine finalize + + + ! ============================================================================ + ! CONTAINER UTILITIES + ! ============================================================================ + + !> Redistribute the particle container across ranks (finest covering level + !> per position; lev_max=-1 avoids the lev_max>finestLevel() assert before + !> all levels exist). Matches amrlpt's default. + subroutine redistribute(this) + implicit none + class(amrpd), intent(inout) :: this + call amrpd_redistribute_p(this%pcp,0,-1,0) + end subroutine redistribute + + + + + + + + + + + + + !> Collective info: runs the solver's get_info (np, velocity extrema, bond + !> censuses, timers), then adds the FACE load-balance metrics -- particles + !> per rank across the grid decomposition (the solver's own partition is + !> balanced by construction; this measures the position-based mirror). + subroutine get_info(this) + implicit none + class(amrpd), intent(inout) :: this + integer(I8) :: np_sum + + ! Solver-side info + call this%pdsolver%get_info() + + ! Face census: live particles owned by this rank across all levels + local_pass: block + use amrex_amr_module, only: amrex_mfiter + type(amrex_mfiter) :: mfi + type(part), dimension(:), pointer :: p + integer(I8) :: np_,n + integer :: lvl + this%np_loc=0_I8 + do lvl=0,this%amr%clvl() + call this%mfiter_build(lvl,mfi) + do while (mfi%next()) + call this%get_particles(lvl,mfi,p,np_) + do n=1,np_ + if (p(n)%flag.eq.PART_IS_DEAD) cycle + this%np_loc=this%np_loc+1_I8 + end do + end do + call this%mfiter_destroy(mfi) + end do + end block local_pass + + ! Load-balance reductions + global_reduce: block + use mpi_f08, only: MPI_ALLREDUCE,MPI_SUM,MPI_MIN,MPI_MAX,MPI_IN_PLACE,MPI_INTEGER8 + integer :: ierr + this%np_min=this%np_loc; this%np_max=this%np_loc; np_sum=this%np_loc; this%np_eff=0.0_WP + call MPI_ALLREDUCE(MPI_IN_PLACE,this%np_min,1,MPI_INTEGER8,MPI_MIN,this%amr%comm,ierr) + call MPI_ALLREDUCE(MPI_IN_PLACE,this%np_max,1,MPI_INTEGER8,MPI_MAX,this%amr%comm,ierr) + call MPI_ALLREDUCE(MPI_IN_PLACE,np_sum, 1,MPI_INTEGER8,MPI_SUM,this%amr%comm,ierr) + if (this%np_max.gt.0_I8) this%np_eff=real(np_sum,WP)/real(this%np_max,WP)/real(this%amr%nproc,WP) + end block global_reduce + + end subroutine get_info + + + !> Set particle-container BoxArray for a given level + subroutine set_particle_ba_p(this,lvl,ba) + use amrex_amr_module, only: amrex_boxarray + implicit none + class(amrpd), intent(inout) :: this + integer, intent(in) :: lvl + type(amrex_boxarray), intent(in) :: ba + call amrpd_set_particle_boxarray_p(this%pcp,lvl,ba%p) + end subroutine set_particle_ba_p + + !> Set particle-container DistributionMapping for a given level + subroutine set_particle_dm_p(this,lvl,dm) + use amrex_amr_module, only: amrex_distromap + implicit none + class(amrpd), intent(inout) :: this + integer, intent(in) :: lvl + type(amrex_distromap), intent(in) :: dm + call amrpd_set_particle_distromap_p(this%pcp,lvl,dm%p) + end subroutine set_particle_dm_p + + + + !> Build an MFIter over the particle container's BA/DM at level lvl. + subroutine mfiter_build(this,lvl,mfi,tiling) + use amrex_amr_module, only: amrex_boxarray,amrex_distromap,amrex_mfiter,amrex_mfiter_build + implicit none + class(amrpd), intent(inout) :: this + integer, intent(in) :: lvl + type(amrex_mfiter), intent(out) :: mfi + logical, intent(in), optional :: tiling + type(amrex_boxarray) :: ba + type(amrex_distromap) :: dm + logical :: use_tiling + use_tiling=.false.; if (present(tiling)) use_tiling=tiling + call amrpd_get_particle_boxarray_p (this%pcp,lvl,ba%p) + call amrpd_get_particle_distromap_p(this%pcp,lvl,dm%p) + call amrex_mfiter_build(mfi,ba,dm,tiling=use_tiling) + end subroutine mfiter_build + + !> Destroy an MFIter built via mfiter_build. + subroutine mfiter_destroy(this,mfi) + use amrex_amr_module, only: amrex_mfiter,amrex_mfiter_destroy + implicit none + class(amrpd), intent(inout) :: this + type(amrex_mfiter), intent(inout) :: mfi + call amrex_mfiter_destroy(mfi) + end subroutine mfiter_destroy + + !> Return a Fortran pointer to the valid particle array on the current tile + !> (ghost particles excluded). np is the number of valid particles. + subroutine get_particles(this,lvl,mfi,p,np) + use amrex_amr_module, only: amrex_mfiter + implicit none + class(amrpd), intent(inout) :: this + integer, intent(in) :: lvl + type(amrex_mfiter), intent(in) :: mfi + type(part), dimension(:), pointer, intent(out) :: p + integer(I8), intent(out) :: np + type(c_ptr) :: dp + integer(c_int64_t) :: np_c + call amrpd_get_particles_mfi(this%pcp,lvl,mfi%p,dp,np_c) + np=int(np_c,I8) + if (np.gt.0_I8) then + call c_f_pointer(dp,p,[np]) + else + nullify(p) + end if + end subroutine get_particles + + + + + !> Bulk-append Fortran particle array into the container at level 0. + !> Collective: every rank must call; ranks with nothing to add pass n=0. + !> AMReX assigns unique (id,cpu) to each appended particle and + !> AddParticlesAtLevel internally redistributes by position. + subroutine append(this,plist,n) + use messager, only: die + implicit none + class(amrpd), intent(inout) :: this + type(part), dimension(:), allocatable, target, intent(in) :: plist + integer(I8), intent(in) :: n + type(c_ptr) :: raw + raw=c_null_ptr + if (n.gt.0_I8.and.allocated(plist)) then + if (int(size(plist),I8).lt.n) call die('[amrpd append] plist array smaller than n') + raw=c_loc(plist(1)) + end if + call amrpd_append_particles(this%pcp,raw,int(n,c_int64_t)) + end subroutine append + + !> Bulk-append with PRESERVED identities: each particle takes the (id,cpu) + !> packed in gids (the part_gid key). Used to rebuild the grid-side face + !> from a pdsolver checkpoint so identities match the solver's node gids. + !> Collective; AddParticlesAtLevel redistributes by position. + subroutine append_with_gids(this,plist,n,gids) + use messager, only: die + implicit none + class(amrpd), intent(inout) :: this + type(part), dimension(:), allocatable, target, intent(in) :: plist + integer(I8), intent(in) :: n + integer(I8), dimension(:), target, intent(in) :: gids + type(c_ptr) :: raw,graw + raw=c_null_ptr; graw=c_null_ptr + if (n.gt.0_I8.and.allocated(plist)) then + if (int(size(plist),I8).lt.n) call die('[amrpd append_with_gids] plist smaller than n') + raw=c_loc(plist(1)); graw=c_loc(gids(1)) + end if + call amrpd_append_particles_gid(this%pcp,raw,int(n,c_int64_t),graw) + end subroutine append_with_gids + + + ! ============================================================================ + ! SOLVER COUPLING (grid face <-> contained pdsolver) + ! ============================================================================ + + !> Hand the seeded face population to the solver: extract nodes, Morton- + !> partition them (balanced, motion-invariant), detect families, and stamp + !> each face particle's flag with its solver owner rank (flag = 7+8*owner). + !> The driver must have assigned the material/damage/contact fields first. + subroutine handoff(this) + use amrex_amr_module, only: amrex_mfiter + implicit none + class(amrpd), intent(inout) :: this + type(amrex_mfiter) :: mfi + type(part), dimension(:), pointer :: p + integer(I8), allocatable :: gids(:),rgid(:) + real(WP), allocatable :: pos(:,:),vel(:,:),voll(:),rpos(:,:),rvel(:,:),rvol(:) + integer, allocatable :: flags(:),owner(:),rflag(:) + integer(I8) :: np_,n + integer :: lvl,nn,i,nr + ! Extract this rank's owned particles + nn=0 + do lvl=0,this%amr%clvl() + call this%mfiter_build(lvl,mfi) + do while (mfi%next()) + call this%get_particles(lvl,mfi,p,np_) + nn=nn+int(np_) + end do + call this%mfiter_destroy(mfi) + end do + allocate(gids(max(nn,1)),pos(3,max(nn,1)),vel(3,max(nn,1)),flags(max(nn,1)),voll(max(nn,1)),owner(max(nn,1))) + i=0 + do lvl=0,this%amr%clvl() + call this%mfiter_build(lvl,mfi) + do while (mfi%next()) + call this%get_particles(lvl,mfi,p,np_) + do n=1_I8,np_ + i=i+1 + gids(i) =part_gid(p(n)) + pos(:,i)=p(n)%pos + vel(:,i)=p(n)%vel + flags(i)=p(n)%flag + voll(i) =this%dV + end do + end do + call this%mfiter_destroy(mfi) + end do + ! Balanced static partition of the reference configuration + call pd_partition(nn,gids,pos,vel,flags,voll,owner,nr,rgid,rpos,rvel,rflag,rvol) + call this%set_nodes(nr,rgid,rpos,rvel,rflag,rvol) + call this%detect_families() + ! Stamp owner routing tags on the grid face (same walk order as the + ! extraction above, so owner(i) lines up) + i=0 + do lvl=0,this%amr%clvl() + call this%mfiter_build(lvl,mfi) + do while (mfi%next()) + call this%get_particles(lvl,mfi,p,np_) + do n=1_I8,np_ + i=i+1 + p(n)%flag=7+8*owner(i) + end do + end do + call this%mfiter_destroy(mfi) + end do + deallocate(gids,pos,vel,flags,voll,owner,rgid,rpos,rvel,rflag,rvol) + end subroutine handoff + + !> Face <-> solver exchange (collective; call once per coupling step): push + !> each face particle's interpolated F_fluid to its solver owner; pull back + !> the owner's current (pos, vel, damage, alive). Dead solver nodes (exited + !> an open face) get an outside-domain position written back, so the next + !> redistribute drops the tombstone. + subroutine exchange_solid(this) + use amrex_amr_module, only: amrex_mfiter + implicit none + class(amrpd), intent(inout) :: this + type(amrex_mfiter) :: mfi + type(part), dimension(:), pointer :: p + integer(I8), allocatable :: mgid(:) + integer, allocatable :: mown(:) + real(WP), allocatable :: mff(:,:),mpos(:,:),mvel(:,:),mdmg(:),malive(:) + integer(I8) :: np_,n + integer :: lvl,nm,i + ! Count live face particles + nm=0 + do lvl=0,this%amr%clvl() + call this%mfiter_build(lvl,mfi) + do while (mfi%next()) + call this%get_particles(lvl,mfi,p,np_) + do n=1_I8,np_ + if (p(n)%flag.eq.PART_IS_DEAD) cycle + nm=nm+1 + end do + end do + call this%mfiter_destroy(mfi) + end do + allocate(mgid(max(nm,1)),mown(max(nm,1)),mff(3,max(nm,1))) + allocate(mpos(3,max(nm,1)),mvel(3,max(nm,1)),mdmg(max(nm,1)),malive(max(nm,1))) + ! Pack (gid, owner tag, F_fluid) + i=0 + do lvl=0,this%amr%clvl() + call this%mfiter_build(lvl,mfi) + do while (mfi%next()) + call this%get_particles(lvl,mfi,p,np_) + do n=1_I8,np_ + if (p(n)%flag.eq.PART_IS_DEAD) cycle + i=i+1 + mgid(i)=part_gid(p(n)) + mown(i)=p(n)%flag/8 + mff(:,i)=p(n)%F_fluid + end do + end do + call this%mfiter_destroy(mfi) + end do + ! Collective round-trip with the solver + call this%exchange(nm,mgid,mown,mff,mpos,mvel,mdmg,malive) + ! Write the solver state back onto the grid face (same walk order) + i=0 + do lvl=0,this%amr%clvl() + call this%mfiter_build(lvl,mfi) + do while (mfi%next()) + call this%get_particles(lvl,mfi,p,np_) + do n=1_I8,np_ + if (p(n)%flag.eq.PART_IS_DEAD) cycle + i=i+1 + p(n)%pos=mpos(:,i) + p(n)%vel=mvel(:,i) + p(n)%damage=mdmg(i) + if (malive(i).lt.0.5_WP) p(n)%flag=PART_IS_DEAD + end do + end do + call this%mfiter_destroy(mfi) + end do + deallocate(mgid,mown,mff,mpos,mvel,mdmg,malive) + end subroutine exchange_solid + + !> Rebuild the grid face from the (restored) solver state: one particle per + !> owned live node with PRESERVED identity (gid -> id,cpu), current + !> position/velocity/damage, and the owner routing tag = this rank. + subroutine rebuild_face(this) + use parallel, only: rank + implicit none + class(amrpd), intent(inout) :: this + type(part), dimension(:), allocatable, target :: plist + integer(I8), dimension(:), allocatable, target :: gl + integer(I8) :: n + integer :: i,m + allocate(plist(max(this%nown,1)),gl(max(this%nown,1))) + m=0 + do i=1,this%nown + if (this%flag(i).eq.PDC_IS_DEAD) cycle ! exited nodes stay dead + m=m+1 + plist(m)%pos =this%y(:,i) + plist(m)%vel =this%v(:,i) + plist(m)%F_bond =0.0_WP + plist(m)%F_fluid=0.0_WP + plist(m)%mw =0.0_WP + plist(m)%dil =0.0_WP + plist(m)%damage =this%damage(i) + plist(m)%nb0 =0.0_WP + plist(m)%td2 =0.0_WP + plist(m)%td2a =0.0_WP + plist(m)%flag =7+8*rank + gl(m)=this%gid(i) + end do + n=int(m,I8) + call this%append_with_gids(plist,n,gl) + call this%redistribute() + deallocate(plist,gl) + end subroutine rebuild_face + + + ! ============================================================================ + ! AMR CALLBACKS + ! ============================================================================ + + !> Post-regrid: re-sync particle and bond containers' BA/DM, redistribute. + !> Particles span levels + !> [0, maxlvl] and the BA/DM sync walks all current levels so the containers + !> track AMR. + subroutine post_regrid(this,lbase,time) + implicit none + class(amrpd), intent(inout) :: this + integer, intent(in) :: lbase + real(WP), intent(in) :: time + integer :: lvl + + ! Re-sync both containers to the fluid grid's BA/DM. This sets the + ! AmrParGDB's per-level particle BA/DM caches. Keeping these in sync + ! and matches the pattern used in amrlpt. + sync_to_amrgrid: block + do lvl=0,this%amr%clvl() + call this%set_particle_ba_p(lvl,this%amr%get_boxarray(lvl)) + call this%set_particle_dm_p(lvl,this%amr%get_distromap(lvl)) + end do + end block sync_to_amrgrid + + ! First settle particles onto the freshly-synced BA/DM before we can + ! count them per box for the knapsack weighting below + call this%redistribute() + + ! Recompute particle VF on the (new) mesh. AMReX fills new fine cells via + ! amrdata's coarse-to-fine interpolation during regrid, but that's a + ! guess; a fresh deposit from the redistributed particles is the truth. + ! Matches amrlpt%post_regrid. + call this%update_VF() + end subroutine post_regrid + + !> Tag cells for refinement where particle VF exceeds VF_tag. Disabled if + !> VF_tag <= 0. Mirrors amrlpt%tagging. + subroutine tagging(this,lvl,time,tags) + use amrex_amr_module, only: amrex_tagboxarray,amrex_box,amrex_mfiter,amrex_mfiter_build,amrex_mfiter_destroy + use amrgrid_class, only: SETtag + implicit none + class(amrpd), intent(inout) :: this + integer, intent(in) :: lvl + real(WP), intent(in) :: time + type(c_ptr), intent(in) :: tags + type(amrex_tagboxarray) :: tba + type(amrex_mfiter) :: mfi + type(amrex_box) :: bx + character(kind=c_char), dimension(:,:,:,:), contiguous, pointer :: tagarr + real(WP), dimension(:,:,:,:), contiguous, pointer :: pVF + integer :: i,j,k + ! Skip if VF tagging is disabled + if (this%VF_tag.le.0.0_WP) return + ! Resolve tagboxarray pointer + tba=tags + ! Loop over tiles and tag + call amrex_mfiter_build(mfi,this%VF%mf(lvl)) + do while (mfi%next()) + tagarr=>tba%dataPtr(mfi) + pVF=>this%VF%mf(lvl)%dataptr(mfi) + bx=mfi%tilebox() + do k=bx%lo(3),bx%hi(3); do j=bx%lo(2),bx%hi(2); do i=bx%lo(1),bx%hi(1) + if (pVF(i,j,k,1).gt.this%VF_tag) tagarr(i,j,k,1)=SETtag + end do; end do; end do + end do + call amrex_mfiter_destroy(mfi) + end subroutine tagging + + !> Compute particle volume fraction on the Eulerian AMR mesh: trilinear + !> deposit of each particle's volume dV onto the 8 surrounding cell centers, + !> then convert extensive->intensive (divide by cell_vol), propagate across + !> C/F boundaries, average down, fill ghosts, and optionally smooth. + subroutine update_VF(this) + use amrex_amr_module, only: amrex_mfiter,amrex_multifab,amrex_multifab_build,amrex_multifab_destroy + use amrex_distromap_module, only: operator(.eq.) + implicit none + class(amrpd), intent(inout) :: this + type(amrex_mfiter) :: mfi + type(part), dimension(:), pointer :: p + real(WP), dimension(:,:,:,:), contiguous, pointer :: pVF + integer(I8) :: np_,i + integer :: lvl,ii,jj,kk + real(WP) :: dxi,dyi,dzi,wx,wy,wz,Vp + type(amrex_multifab) :: tmpVF + logical :: dual_dm + + ! Zero VF on all levels + call this%VF%setval(0.0_WP) + Vp=this%dV + + do lvl=0,this%amr%clvl() + dxi=1.0_WP/this%amr%dx(lvl) + dyi=1.0_WP/this%amr%dy(lvl) + dzi=1.0_WP/this%amr%dz(lvl) + + ! Particles may live on a different DM than VF -- deposit on the + ! particle DM into a scratch mfab, then parallel_copy to VF + dual_dm=(.not.(this%VF%mf(lvl)%dm.eq.get_pdm())) + if (dual_dm) then + call amrex_multifab_build(mf=tmpVF,ba=this%amr%ba(lvl),dm=get_pdm(),nc=this%VF%mf(lvl)%ncomp(),ng=this%VF%mf(lvl)%nghost(),nodal=this%VF%nodal) + call tmpVF%setval(0.0_WP) + end if + + call this%mfiter_build(lvl,mfi) + do while (mfi%next()) + if (dual_dm) then + pVF=>tmpVF%dataptr(mfi) + else + pVF=>this%VF%mf(lvl)%dataptr(mfi) + end if + call this%get_particles(lvl,mfi,p,np_) + do i=1_I8,np_ + if (p(i)%flag.eq.PART_IS_DEAD) cycle + ii=floor((p(i)%pos(1)-this%amr%xlo)*dxi-0.5_WP); wx=(p(i)%pos(1)-this%amr%xlo)*dxi-0.5_WP-real(ii,WP) + jj=floor((p(i)%pos(2)-this%amr%ylo)*dyi-0.5_WP); wy=(p(i)%pos(2)-this%amr%ylo)*dyi-0.5_WP-real(jj,WP) + kk=floor((p(i)%pos(3)-this%amr%zlo)*dzi-0.5_WP); wz=(p(i)%pos(3)-this%amr%zlo)*dzi-0.5_WP-real(kk,WP) + ! Clamp 8-cell stencil at WALL faces (mirrors amrlpt) + if (this%lo_bc(1).eq.PD_WALL.and.ii .lt.this%amr%geom(lvl)%domain%lo(1)) then; ii=this%amr%geom(lvl)%domain%lo(1) ; wx=0.0_WP; end if + if (this%hi_bc(1).eq.PD_WALL.and.ii+1.gt.this%amr%geom(lvl)%domain%hi(1)) then; ii=this%amr%geom(lvl)%domain%hi(1)-1; wx=1.0_WP; end if + if (this%lo_bc(2).eq.PD_WALL.and.jj .lt.this%amr%geom(lvl)%domain%lo(2)) then; jj=this%amr%geom(lvl)%domain%lo(2) ; wy=0.0_WP; end if + if (this%hi_bc(2).eq.PD_WALL.and.jj+1.gt.this%amr%geom(lvl)%domain%hi(2)) then; jj=this%amr%geom(lvl)%domain%hi(2)-1; wy=1.0_WP; end if + if (this%lo_bc(3).eq.PD_WALL.and.kk .lt.this%amr%geom(lvl)%domain%lo(3)) then; kk=this%amr%geom(lvl)%domain%lo(3) ; wz=0.0_WP; end if + if (this%hi_bc(3).eq.PD_WALL.and.kk+1.gt.this%amr%geom(lvl)%domain%hi(3)) then; kk=this%amr%geom(lvl)%domain%hi(3)-1; wz=1.0_WP; end if + pVF(ii:ii+1,jj:jj+1,kk:kk+1,1)=pVF(ii:ii+1,jj:jj+1,kk:kk+1,1)+Vp*reshape([(1.0_WP-wx)*(1.0_WP-wy)*(1.0_WP-wz),wx*(1.0_WP-wy)*(1.0_WP-wz),(1.0_WP-wx)*wy*(1.0_WP-wz),wx*wy*(1.0_WP-wz),(1.0_WP-wx)*(1.0_WP-wy)*wz,wx*(1.0_WP-wy)*wz,(1.0_WP-wx)*wy*wz,wx*wy*wz],[2,2,2]) + end do + end do + call this%mfiter_destroy(mfi) + + if (dual_dm) then + call this%VF%mf(lvl)%parallel_copy(tmpVF,1,1,this%VF%mf(lvl)%ncomp(),this%VF%mf(lvl)%nghost(),this%VF%mf(lvl)%nghost(),this%amr%geom(lvl)) + call amrex_multifab_destroy(tmpVF) + end if + end do + + ! Convert extensive -> intensive (VF) and reconcile across C/F + call this%process_deposit(this%VF) + ! Fill ghost cells via amrdata's standard machinery + call this%VF%fill(time=0.0_WP) + ! Optional smoothing (zero filter_width disables) + call this%filter(this%VF) + ! Snap out the deposit moire: the particle lattice is incommensurate with the + ! grid (and moves), so a fully packed interior deposits VF slightly below 1. + ! Rescale+clip so it reads exactly 1; continuous, so no jump is introduced. + if (this%VF_snap.gt.0.0_WP) then + do lvl=0,this%amr%clvl() + call this%VF%mf(lvl)%mult(1.0_WP/(1.0_WP-this%VF_snap),1,1,this%VF%ng) + end do + call this%VF%clip(0.0_WP,1.0_WP) + call this%VF%fill(time=0.0_WP) + end if + + contains + + !> Helper: get the particle distribution map for this level. Returns the + !> DM that the particle container is currently using (which may differ + !> from the Eulerian DM). + function get_pdm() result(dm) + use amrex_distromap_module, only: amrex_distromap + type(amrex_distromap) :: dm + call amrpd_get_particle_distromap_p(this%pcp,lvl,dm%p) + dm%owner=.false. + end function get_pdm + end subroutine update_VF + + !> Post-process an extensive deposit (sum of particle volumes per cell) into + !> an intensive field (VF = sum/cell_vol), with cross-level transfers to + !> avoid double-counting on covered cells. Verbatim port of amrlpt's + !> process_deposit. + subroutine process_deposit(this,A) + use amrex_amr_module, only: amrex_multifab,amrex_multifab_destroy + use amrex_interface, only: amrmfab_sum_downto,amrmfab_interp_from_coarse + implicit none + class(amrpd), intent(inout) :: this + type(amrdata), intent(inout) :: A + type(amrex_multifab), dimension(:), allocatable :: tmp + integer :: lvl + ! Convert extensive deposits to intensive + do lvl=0,this%amr%clvl() + call A%mf(lvl)%mult(1.0_WP/this%amr%cell_vol(lvl),1,A%ncomp,A%ng) + end do + ! Scratch mfabs for coarse->fine interpolation + allocate(tmp(0:this%amr%clvl())) + do lvl=0,this%amr%clvl() + call this%amr%mfab_build(lvl,tmp(lvl),ncomp=A%ncomp,nover=0); call tmp(lvl)%setval(0.0_WP) + end do + ! Forward pass (coarse to fine) + do lvl=0,this%amr%clvl() + call A%syncsum_lvl(lvl) + if (lvl.lt.this%amr%clvl()) then + call amrmfab_interp_from_coarse(tmp(lvl+1),A%mf(lvl),[this%amr%rrefx(lvl),this%amr%rrefy(lvl),this%amr%rrefz(lvl)],cgeom=this%amr%geom(lvl),fgeom=this%amr%geom(lvl+1),scomp=1,ncomp=A%ncomp) + end if + if (lvl.gt.0) then + call amrmfab_sum_downto(A%mf(lvl),A%mf(lvl-1),[this%amr%rrefx(lvl-1),this%amr%rrefy(lvl-1),this%amr%rrefz(lvl-1)],cgeom=this%amr%geom(lvl-1),fgeom=this%amr%geom(lvl)) + end if + call A%mf(lvl)%add(tmp(lvl),1,1,A%ncomp,0) + end do + ! Backward pass: average down to fix double-counted covered cells + do lvl=this%amr%clvl()-1,0,-1 + call A%average_downto(lvl) + end do + do lvl=0,this%amr%clvl() + call amrex_multifab_destroy(tmp(lvl)) + end do + deallocate(tmp) + end subroutine process_deposit + + !> Explicit-diffusion (Gaussian-equivalent) smoothing of a cell-centered + !> amrdata field. Skips if filter_width<=mesh-size. Verbatim port of amrlpt. + subroutine filter(this,A) + use amrex_amr_module, only: amrex_box,amrex_mfiter,amrex_mfiter_build,amrex_mfiter_destroy,amrex_multifab,amrex_multifab_destroy + use amrex_interface, only: amrmfab_average_down_face + implicit none + class(amrpd), intent(inout) :: this + type(amrdata), intent(inout) :: A + real(WP) :: alpha,alpha_step,dxi,dyi,dzi + integer :: nstep,n,nc,lvl,i,j,k + type(amrex_mfiter) :: mfi + type(amrex_box) :: bx + type(amrex_multifab), dimension(:), allocatable :: Fx,Fy,Fz + real(WP), dimension(:,:,:,:), contiguous, pointer :: pA,pFx,pFy,pFz + + alpha=max(this%filter_width**2-this%amr%min_meshsize(this%amr%clvl())**2,0.0_WP)/(16.0_WP*log(2.0_WP)) + if (alpha.le.0.0_WP) return + + nstep=ceiling(6.0_WP*alpha/this%amr%min_meshsize(this%amr%clvl())**2) + alpha_step=alpha/real(nstep,WP) + + allocate(Fx(0:this%amr%maxlvl),Fy(0:this%amr%maxlvl),Fz(0:this%amr%maxlvl)) + do lvl=0,this%amr%clvl() + call this%amr%mfab_build(lvl,Fx(lvl),ncomp=A%ncomp,nover=0,atface=[.true., .false.,.false.]); call Fx(lvl)%setval(0.0_WP) + call this%amr%mfab_build(lvl,Fy(lvl),ncomp=A%ncomp,nover=0,atface=[.false.,.true., .false.]); call Fy(lvl)%setval(0.0_WP) + call this%amr%mfab_build(lvl,Fz(lvl),ncomp=A%ncomp,nover=0,atface=[.false.,.false.,.true. ]); call Fz(lvl)%setval(0.0_WP) + end do + + do n=1,nstep + do lvl=0,this%amr%clvl() + dxi=1.0_WP/this%amr%dx(lvl) + dyi=1.0_WP/this%amr%dy(lvl) + dzi=1.0_WP/this%amr%dz(lvl) + call amrex_mfiter_build(mfi,A%mf(lvl),tiling=.false.) + do while (mfi%next()) + pA =>A%mf(lvl)%dataptr(mfi) + pFx=>Fx(lvl)%dataptr(mfi); pFy=>Fy(lvl)%dataptr(mfi); pFz=>Fz(lvl)%dataptr(mfi) + bx=mfi%nodaltilebox(1) + do nc=1,A%ncomp; do k=bx%lo(3),bx%hi(3); do j=bx%lo(2),bx%hi(2); do i=bx%lo(1),bx%hi(1) + pFx(i,j,k,nc)=alpha_step*(pA(i,j,k,nc)-pA(i-1,j,k,nc))*dxi + end do; end do; end do; end do + bx=mfi%nodaltilebox(2) + do nc=1,A%ncomp; do k=bx%lo(3),bx%hi(3); do j=bx%lo(2),bx%hi(2); do i=bx%lo(1),bx%hi(1) + pFy(i,j,k,nc)=alpha_step*(pA(i,j,k,nc)-pA(i,j-1,k,nc))*dyi + end do; end do; end do; end do + bx=mfi%nodaltilebox(3) + do nc=1,A%ncomp; do k=bx%lo(3),bx%hi(3); do j=bx%lo(2),bx%hi(2); do i=bx%lo(1),bx%hi(1) + pFz(i,j,k,nc)=alpha_step*(pA(i,j,k,nc)-pA(i,j,k-1,nc))*dzi + end do; end do; end do; end do + end do + call amrex_mfiter_destroy(mfi) + end do + do lvl=this%amr%clvl(),1,-1 + call amrmfab_average_down_face(fmf=Fx(lvl),cmf=Fx(lvl-1),rr=[this%amr%rrefx(lvl-1),this%amr%rrefy(lvl-1),this%amr%rrefz(lvl-1)],cgeom=this%amr%geom(lvl-1)) + call amrmfab_average_down_face(fmf=Fy(lvl),cmf=Fy(lvl-1),rr=[this%amr%rrefx(lvl-1),this%amr%rrefy(lvl-1),this%amr%rrefz(lvl-1)],cgeom=this%amr%geom(lvl-1)) + call amrmfab_average_down_face(fmf=Fz(lvl),cmf=Fz(lvl-1),rr=[this%amr%rrefx(lvl-1),this%amr%rrefy(lvl-1),this%amr%rrefz(lvl-1)],cgeom=this%amr%geom(lvl-1)) + end do + do lvl=0,this%amr%clvl() + dxi=1.0_WP/this%amr%dx(lvl) + dyi=1.0_WP/this%amr%dy(lvl) + dzi=1.0_WP/this%amr%dz(lvl) + call amrex_mfiter_build(mfi,A%mf(lvl),tiling=.false.) + do while (mfi%next()) + pA =>A%mf(lvl)%dataptr(mfi) + pFx=>Fx(lvl)%dataptr(mfi); pFy=>Fy(lvl)%dataptr(mfi); pFz=>Fz(lvl)%dataptr(mfi) + bx=mfi%tilebox() + do nc=1,A%ncomp; do k=bx%lo(3),bx%hi(3); do j=bx%lo(2),bx%hi(2); do i=bx%lo(1),bx%hi(1) + pA(i,j,k,nc)=pA(i,j,k,nc)+dxi*(pFx(i+1,j,k,nc)-pFx(i,j,k,nc))+dyi*(pFy(i,j+1,k,nc)-pFy(i,j,k,nc))+dzi*(pFz(i,j,k+1,nc)-pFz(i,j,k,nc)) + end do; end do; end do; end do + end do + call amrex_mfiter_destroy(mfi) + end do + call A%average_down() + call A%fill(time=0.0_WP) + end do + + do lvl=0,this%amr%clvl() + call amrex_multifab_destroy(Fx(lvl)) + call amrex_multifab_destroy(Fy(lvl)) + call amrex_multifab_destroy(Fz(lvl)) + end do + deallocate(Fx,Fy,Fz) + end subroutine filter + + + ! ============================================================================ + ! FIELD INTERPOLATION + ! ============================================================================ + + + + !> Trilinear cell-centered interpolation of a multifab data array at a 3D + !> position (drivers use it to sample fields at particle positions). + function interp(this,lvl,pos,arr,comp) result(val) + implicit none + class(amrpd), intent(in) :: this + integer, intent(in) :: lvl + real(WP), dimension(3), intent(in) :: pos + real(WP), dimension(:,:,:,:), contiguous, pointer, intent(in) :: arr + integer, intent(in) :: comp + real(WP) :: val,wx,wy,wz + integer :: ii,jj,kk + ii=floor((pos(1)-this%amr%xlo)/this%amr%dx(lvl)-0.5_WP); wx=(pos(1)-this%amr%xlo)/this%amr%dx(lvl)-0.5_WP-real(ii,WP) + jj=floor((pos(2)-this%amr%ylo)/this%amr%dy(lvl)-0.5_WP); wy=(pos(2)-this%amr%ylo)/this%amr%dy(lvl)-0.5_WP-real(jj,WP) + kk=floor((pos(3)-this%amr%zlo)/this%amr%dz(lvl)-0.5_WP); wz=(pos(3)-this%amr%zlo)/this%amr%dz(lvl)-0.5_WP-real(kk,WP) + val=(1.0_WP-wx)*(1.0_WP-wy)*(1.0_WP-wz)*arr(ii ,jj ,kk ,comp) & + & + wx *(1.0_WP-wy)*(1.0_WP-wz)*arr(ii+1,jj ,kk ,comp) & + & +(1.0_WP-wx)* wy *(1.0_WP-wz)*arr(ii ,jj+1,kk ,comp) & + & + wx * wy *(1.0_WP-wz)*arr(ii+1,jj+1,kk ,comp) & + & +(1.0_WP-wx)*(1.0_WP-wy)* wz *arr(ii ,jj ,kk+1,comp) & + & + wx *(1.0_WP-wy)* wz *arr(ii+1,jj ,kk+1,comp) & + & +(1.0_WP-wx)* wy * wz *arr(ii ,jj+1,kk+1,comp) & + & + wx * wy * wz *arr(ii+1,jj+1,kk+1,comp) + end function interp + + + + + + ! ============================================================================ + ! CHECKPOINT I/O + ! ============================================================================ + + !> Write the particle-container checkpoint under /particles. + !> Caller is responsible for creating . + subroutine write(this,dirname) + implicit none + class(amrpd), intent(inout) :: this + character(len=*), intent(in) :: dirname + call amrpd_checkpoint_p(this%pcp,trim(dirname)//'/particles'//c_null_char) + end subroutine write + + !> Restore the particle container from a checkpoint written by write. The + !> amrgrid must already be rebuilt; syncs BA/DM, restarts, redistributes. + subroutine read(this,dirname) + implicit none + class(amrpd), intent(inout) :: this + character(len=*), intent(in) :: dirname + integer :: lvl + ! Sync the container to the restored grid's BA/DM + do lvl=0,this%amr%clvl() + call this%set_particle_ba_p(lvl,this%amr%get_boxarray(lvl)) + call this%set_particle_dm_p(lvl,this%amr%get_distromap(lvl)) + end do + ! AMReX Restart + call amrpd_restart_p(this%pcp,trim(dirname)//'/particles'//c_null_char) + ! Settle and refresh + call this%redistribute() + call this%get_info() + end subroutine read + + + ! ============================================================================ + ! DIAGNOSTICS + ! ============================================================================ + + !> Log solver info on root + subroutine print(this) + use, intrinsic :: iso_fortran_env, only: output_unit + use param, only: verbose + use messager, only: log + use string, only: str_long + implicit none + class(amrpd), intent(inout) :: this + character(len=str_long) :: message + if (this%amr%amRoot) then + write(message,'("AMRPD solver [",a,"] on AMR grid [",a,"]")') trim(this%name),trim(this%amr%name) + if (verbose .gt. 1) write(output_unit,'(a)') trim(message) + if (verbose .gt. 0) call log(message) + end if + end subroutine print + + +end module amrpd_class diff --git a/examples/NOSB_cylinder_peridigm/src/geometry.f90 b/examples/NOSB_cylinder_peridigm/src/geometry.f90 new file mode 100644 index 000000000..c9f73adc2 --- /dev/null +++ b/examples/NOSB_cylinder_peridigm/src/geometry.f90 @@ -0,0 +1,100 @@ +!> Various definitions and tools for initializing NGA2 config +module geometry + use config_class, only: config + use precision, only: WP + implicit none + private + + !> Single config + type(config), public :: cfg + + public :: geometry_init + +contains + + + !> Initialization of problem geometry + subroutine geometry_init + use sgrid_class, only: sgrid + use param, only: param_read + implicit none + type(sgrid) :: grid + + + ! Create a grid from input params + create_grid: block + use sgrid_class, only: cartesian + integer :: i,j,k,nx,ny,nz,N_r,N_xp,N_xm,N_y,N_z + real(WP) :: R,elem,Lx,Ly,Lz + real(WP), dimension(:), allocatable :: x,y,z + + ! Read in grid definition + call param_read('R',R,default=0.5_WP) + call param_read('N_r',N_r,default=10) + call param_read('X+ ratio',N_xp,default=6) + call param_read('X- ratio',N_xm,default=6) + call param_read('Y ratio',N_y,default=6) + call param_read('Z ratio',N_z,default=6) + + ! Use the same spacing in every direction. The cylinder center is + ! located at x=0, with N_xm radii upstream and N_xp radii downstream. + elem=R/real(N_r,WP) + Lx=real(N_xm+N_xp,WP)*R + Ly=real(N_y,WP)*R + + + nx = N_r*(N_xp + N_xm); allocate(x(nx+1)) + ny = N_r*N_y; allocate(y(ny+1)) + + ! Option to make 2D in the z direction + if (N_z.eq.0) then + Lz = elem/3.0_WP; nz = 1; allocate(z(nz+1)) + else + Lz=real(N_z,WP)*R; nz = N_r*N_z; allocate(z(nz+1)) + end if + + ! Create simple rectilinear grid + do i=1,nx+1 + x(i)=-real(N_xm,WP)*R+real(i-1,WP)*elem + end do + do j=1,ny+1 + y(j)=-0.5_WP*Ly+real(j-1,WP)*elem + end do + if (N_z.eq.0) then + do k=1,nz+1 + z(k)=-0.5_WP*Lz+real(k-1,WP)*elem/3.0_WP + end do + else + do k=1,nz+1 + z(k)=-0.5_WP*Lz+real(k-1,WP)*elem + end do + end if + + + ! General serial grid object (no=3 needed to support ghost/image point interpolation/extrapolation) + grid=sgrid(coord=cartesian,no=2,x=x,y=y,z=z,xper=.false.,yper=.true.,zper=.true.,name='box') + + end block create_grid + + + ! Create a config from that grid on our entire group + create_cfg: block + use parallel, only: group + integer, dimension(3) :: partition + ! Read in partition + call param_read('Partition',partition,short='p') + ! Create partitioned grid + cfg=config(grp=group,decomp=partition,grid=grid) + end block create_cfg + + + ! Create walls for this config + create_walls: block + cfg%VF=1.0_WP + end block create_walls + + + end subroutine geometry_init + + +end module geometry diff --git a/examples/NOSB_cylinder_peridigm/src/incomp_class.f90 b/examples/NOSB_cylinder_peridigm/src/incomp_class.f90 new file mode 100644 index 000000000..17d5fc3b2 --- /dev/null +++ b/examples/NOSB_cylinder_peridigm/src/incomp_class.f90 @@ -0,0 +1,2129 @@ +!> Incompressible flow solver class: +!> Provides support for various BC, RHS calculation, +!> implicit solver, and pressure solution +!> Assumes constant viscosity and density. +module incomp_class + use precision, only: WP + use string, only: str_medium + use config_class, only: config + use linsol_class, only: linsol + use iterator_class, only: iterator + implicit none + private + + ! Expose type/constructor/methods + public :: incomp,bcond + + ! List of known available bcond types for this solver + integer, parameter, public :: wall=1 !< Dirichlet at zero condition + integer, parameter, public :: dirichlet=2 !< Dirichlet condition + integer, parameter, public :: neumann=3 !< Zero normal gradient + integer, parameter, public :: convective=4 !< Convective outflow condition + integer, parameter, public :: clipped_neumann=5 !< Clipped Neumann condition (outflow only) + integer, parameter, public :: slip=6 !< Free-slip condition + + !> Boundary conditions for the incompressible solver + type :: bcond + type(bcond), pointer :: next !< Linked list of bconds + character(len=str_medium) :: name='UNNAMED_BCOND' !< Bcond name (default=UNNAMED_BCOND) + integer :: type !< Bcond type + type(iterator) :: itr !< This is the iterator for the bcond - this identifies the (i,j,k) + character(len=1) :: face !< Bcond face (x/y/z) + integer :: dir !< Bcond direction (+1,-1,0 for interior) + real(WP) :: rdir !< Bcond direction (real variable) + logical :: canCorrect !< Can this bcond be corrected for global conservation? + end type bcond + + !> Incompressible solver object definition + type :: incomp + + ! This is our config + class(config), pointer :: cfg !< This is the config the solver is build for + + ! This is the name of the solver + character(len=str_medium) :: name='UNNAMED_INCOMP' !< Solver name (default=UNNAMED_INCOMP) + + ! Constant property fluid + real(WP) :: rho !< This is our constant fluid density + real(WP), dimension(:,:,:), allocatable :: visc !< These is our constant+SGS dynamic viscosity + + ! Gravitational acceleration + real(WP), dimension(3) :: gravity=0.0_WP !< Acceleration of gravity + + ! Boundary condition list + integer :: nbc !< Number of bcond for our solver + real(WP), dimension(:), allocatable :: mfr !< MFR through each bcond + real(WP), dimension(:), allocatable :: area !< Area for each bcond + real(WP) :: correctable_area !< Area of bcond that can be corrected + type(bcond), pointer :: first_bc !< List of bcond for our solver + + ! Flow variables + real(WP), dimension(:,:,:), allocatable :: U !< U velocity array + real(WP), dimension(:,:,:), allocatable :: V !< V velocity array + real(WP), dimension(:,:,:), allocatable :: W !< W velocity array + real(WP), dimension(:,:,:), allocatable :: P !< Pressure array + + ! Old flow variables + real(WP), dimension(:,:,:), allocatable :: Uold !< Uold velocity array + real(WP), dimension(:,:,:), allocatable :: Vold !< Vold velocity array + real(WP), dimension(:,:,:), allocatable :: Wold !< Wold velocity array + + ! Flow divergence + real(WP), dimension(:,:,:), allocatable :: div !< Divergence array + + ! Pressure solver + class(linsol), pointer :: psolv !< Iterative linear solver object for the pressure Poisson equation + + ! Implicit velocity solver + class(linsol), pointer :: implicit !< Iterative linear solver object for an implicit prediction of the NS residual + + ! Metrics + real(WP), dimension(:,:,:,:,:), allocatable :: itp_xy,itp_yz,itp_xz !< Interpolation for viscosity + real(WP), dimension(:,:,:,:), allocatable :: itpr_x,itpr_y,itpr_z !< Interpolation for density + real(WP), dimension(:,:,:,:), allocatable :: itpu_x,itpu_y,itpu_z !< Interpolation for U + real(WP), dimension(:,:,:,:), allocatable :: itpv_x,itpv_y,itpv_z !< Interpolation for V + real(WP), dimension(:,:,:,:), allocatable :: itpw_x,itpw_y,itpw_z !< Interpolation for W + real(WP), dimension(:,:,:,:), allocatable :: divp_x,divp_y,divp_z !< Divergence for P-cell + real(WP), dimension(:,:,:,:), allocatable :: divu_x,divu_y,divu_z !< Divergence for U-cell + real(WP), dimension(:,:,:,:), allocatable :: divv_x,divv_y,divv_z !< Divergence for V-cell + real(WP), dimension(:,:,:,:), allocatable :: divw_x,divw_y,divw_z !< Divergence for W-cell + real(WP), dimension(:,:,:,:), allocatable :: grdu_x,grdu_y,grdu_z !< Velocity gradient for U + real(WP), dimension(:,:,:,:), allocatable :: grdv_x,grdv_y,grdv_z !< Velocity gradient for V + real(WP), dimension(:,:,:,:), allocatable :: grdw_x,grdw_y,grdw_z !< Velocity gradient for W + + ! Masking info for metric modification + integer, dimension(:,:,:), allocatable :: mask !< Integer array used for modifying P metrics + integer, dimension(:,:,:), allocatable :: umask !< Integer array used for modifying U metrics + integer, dimension(:,:,:), allocatable :: vmask !< Integer array used for modifying V metrics + integer, dimension(:,:,:), allocatable :: wmask !< Integer array used for modifying W metrics + + ! CFL numbers + real(WP) :: CFLc_x,CFLc_y,CFLc_z !< Convective CFL numbers + real(WP) :: CFLv_x,CFLv_y,CFLv_z !< Viscous CFL numbers + + ! Monitoring quantities + real(WP) :: Umax,Vmax,Wmax,Pmax,divmax !< Maximum velocity, pressure, divergence + + contains + procedure :: print=>incomp_print !< Output solver to the screen + procedure :: setup !< Finish configuring the flow solver + procedure :: add_bcond !< Add a boundary condition + procedure :: get_bcond !< Get a boundary condition + procedure :: apply_bcond !< Apply all boundary conditions + procedure :: init_metrics !< Initialize metrics + procedure :: adjust_metrics !< Adjust metrics + procedure :: get_dmomdt !< Calculate dmom/dt + procedure :: get_div_stress !< Calculate div(stress) + procedure :: get_div !< Calculate velocity divergence + procedure :: get_pgrad !< Calculate pressure gradient + procedure :: get_cfl !< Calculate maximum CFL + procedure :: get_max !< Calculate maximum field values + procedure :: interp_vel !< Calculate interpolated velocity + procedure :: get_strainrate !< Calculate deviatoric part of strain rate tensor + procedure :: get_gradu !< Calculate velocity gradient tensor + procedure :: get_vorticity !< Calculate vorticity tensor + procedure :: get_mfr !< Calculate outgoing MFR through each bcond + procedure :: correct_mfr !< Correct for mfr mismatch to ensure global conservation + procedure :: shift_p !< Shift pressure to have zero average + procedure :: solve_implicit !< Solve for the velocity residuals implicitly + procedure :: addsrc_gravity !< Gravitational body force + end type incomp + + + !> Declare incompressible solver constructor + interface incomp + procedure constructor + end interface incomp + +contains + + + !> Default constructor for incompressible flow solver + function constructor(cfg,name) result(self) + implicit none + type(incomp) :: self + class(config), target, intent(in) :: cfg + character(len=*), optional :: name + integer :: i,j,k + + ! Set the name for the solver + if (present(name)) self%name=trim(adjustl(name)) + + ! Point to pgrid object + self%cfg=>cfg + + ! Nullify bcond list + self%nbc=0 + self%first_bc=>NULL() + + ! Allocate flow variables + allocate(self%U(self%cfg%imino_:self%cfg%imaxo_,self%cfg%jmino_:self%cfg%jmaxo_,self%cfg%kmino_:self%cfg%kmaxo_)); self%U=0.0_WP + allocate(self%V(self%cfg%imino_:self%cfg%imaxo_,self%cfg%jmino_:self%cfg%jmaxo_,self%cfg%kmino_:self%cfg%kmaxo_)); self%V=0.0_WP + allocate(self%W(self%cfg%imino_:self%cfg%imaxo_,self%cfg%jmino_:self%cfg%jmaxo_,self%cfg%kmino_:self%cfg%kmaxo_)); self%W=0.0_WP + allocate(self%P(self%cfg%imino_:self%cfg%imaxo_,self%cfg%jmino_:self%cfg%jmaxo_,self%cfg%kmino_:self%cfg%kmaxo_)); self%P=0.0_WP + + ! Allocate flow divergence + allocate(self%div(self%cfg%imino_:self%cfg%imaxo_,self%cfg%jmino_:self%cfg%jmaxo_,self%cfg%kmino_:self%cfg%kmaxo_)); self%div=0.0_WP + + ! Allocate fluid viscosity + allocate(self%visc(self%cfg%imino_:self%cfg%imaxo_,self%cfg%jmino_:self%cfg%jmaxo_,self%cfg%kmino_:self%cfg%kmaxo_)); self%visc=0.0_WP + + ! Allocate old flow variables + allocate(self%Uold(self%cfg%imino_:self%cfg%imaxo_,self%cfg%jmino_:self%cfg%jmaxo_,self%cfg%kmino_:self%cfg%kmaxo_)); self%Uold=0.0_WP + allocate(self%Vold(self%cfg%imino_:self%cfg%imaxo_,self%cfg%jmino_:self%cfg%jmaxo_,self%cfg%kmino_:self%cfg%kmaxo_)); self%Vold=0.0_WP + allocate(self%Wold(self%cfg%imino_:self%cfg%imaxo_,self%cfg%jmino_:self%cfg%jmaxo_,self%cfg%kmino_:self%cfg%kmaxo_)); self%Wold=0.0_WP + + ! Prepare default metrics + call self%init_metrics() + + ! Prepare P-cell masks + allocate(self%mask(self%cfg%imino_:self%cfg%imaxo_,self%cfg%jmino_:self%cfg%jmaxo_,self%cfg%kmino_:self%cfg%kmaxo_)); self%mask=0 + if (.not.self%cfg%xper) then + if (self%cfg%iproc.eq. 1) self%mask(:self%cfg%imin-1,:,:)=2 + if (self%cfg%iproc.eq.self%cfg%npx) self%mask(self%cfg%imax+1:,:,:)=2 + end if + if (.not.self%cfg%yper) then + if (self%cfg%jproc.eq. 1) self%mask(:,:self%cfg%jmin-1,:)=2 + if (self%cfg%jproc.eq.self%cfg%npy) self%mask(:,self%cfg%jmax+1:,:)=2 + end if + if (.not.self%cfg%zper) then + if (self%cfg%kproc.eq. 1) self%mask(:,:,:self%cfg%kmin-1)=2 + if (self%cfg%kproc.eq.self%cfg%npz) self%mask(:,:,self%cfg%kmax+1:)=2 + end if + do k=self%cfg%kmino_,self%cfg%kmaxo_ + do j=self%cfg%jmino_,self%cfg%jmaxo_ + do i=self%cfg%imino_,self%cfg%imaxo_ + if (self%cfg%VF(i,j,k).eq.0.0_WP) self%mask(i,j,k)=1 + end do + end do + end do + call self%cfg%sync(self%mask) + + ! Prepare face mask for U + allocate(self%umask(self%cfg%imino_:self%cfg%imaxo_,self%cfg%jmino_:self%cfg%jmaxo_,self%cfg%kmino_:self%cfg%kmaxo_)); self%umask=0 + if (.not.self%cfg%xper) then + if (self%cfg%iproc.eq. 1) self%umask(self%cfg%imin ,:,:)=2 + if (self%cfg%iproc.eq.self%cfg%npx) self%umask(self%cfg%imax+1,:,:)=2 + end if + do k=self%cfg%kmino_ ,self%cfg%kmaxo_ + do j=self%cfg%jmino_ ,self%cfg%jmaxo_ + do i=self%cfg%imino_+1,self%cfg%imaxo_ + if (minval(self%cfg%VF(i-1:i,j,k)).eq.0.0_WP) self%umask(i,j,k)=1 + end do + end do + end do + call self%cfg%sync(self%umask) + if (.not.self%cfg%xper.and.self%cfg%iproc.eq.1) self%umask(self%cfg%imino,:,:)=self%umask(self%cfg%imino+1,:,:) + + ! Prepare face mask for V + allocate(self%vmask(self%cfg%imino_:self%cfg%imaxo_,self%cfg%jmino_:self%cfg%jmaxo_,self%cfg%kmino_:self%cfg%kmaxo_)); self%vmask=0 + if (.not.self%cfg%yper) then + if (self%cfg%jproc.eq. 1) self%vmask(:,self%cfg%jmin ,:)=2 + if (self%cfg%jproc.eq.self%cfg%npy) self%vmask(:,self%cfg%jmax+1,:)=2 + end if + do k=self%cfg%kmino_ ,self%cfg%kmaxo_ + do j=self%cfg%jmino_+1,self%cfg%jmaxo_ + do i=self%cfg%imino_ ,self%cfg%imaxo_ + if (minval(self%cfg%VF(i,j-1:j,k)).eq.0.0_WP) self%vmask(i,j,k)=1 + end do + end do + end do + call self%cfg%sync(self%vmask) + if (.not.self%cfg%yper.and.self%cfg%jproc.eq.1) self%vmask(:,self%cfg%jmino,:)=self%vmask(:,self%cfg%jmino+1,:) + + ! Prepare face mask for W + allocate(self%wmask(self%cfg%imino_:self%cfg%imaxo_,self%cfg%jmino_:self%cfg%jmaxo_,self%cfg%kmino_:self%cfg%kmaxo_)); self%wmask=0 + if (.not.self%cfg%zper) then + if (self%cfg%kproc.eq. 1) self%wmask(:,:,self%cfg%kmin )=2 + if (self%cfg%kproc.eq.self%cfg%npz) self%wmask(:,:,self%cfg%kmax+1)=2 + end if + do k=self%cfg%kmino_+1,self%cfg%kmaxo_ + do j=self%cfg%jmino_ ,self%cfg%jmaxo_ + do i=self%cfg%imino_ ,self%cfg%imaxo_ + if (minval(self%cfg%VF(i,j,k-1:k)).eq.0.0_WP) self%wmask(i,j,k)=1 + end do + end do + end do + call self%cfg%sync(self%wmask) + if (.not.self%cfg%zper.and.self%cfg%kproc.eq.1) self%wmask(:,:,self%cfg%kmino)=self%wmask(:,:,self%cfg%kmino+1) + + end function constructor + + + !> Metric initialization with no awareness of walls nor bcond + subroutine init_metrics(this) + implicit none + class(incomp), intent(inout) :: this + integer :: i,j,k,st1,st2 + real(WP), dimension(-1:0) :: itpx,itpy,itpz + + ! Allocate finite difference density (or other things) interpolation coefficients + allocate(this%itpr_x(-1:0,this%cfg%imin_:this%cfg%imax_+1,this%cfg%jmin_:this%cfg%jmax_+1,this%cfg%kmin_:this%cfg%kmax_+1)) !< X-face-centered + allocate(this%itpr_y(-1:0,this%cfg%imin_:this%cfg%imax_+1,this%cfg%jmin_:this%cfg%jmax_+1,this%cfg%kmin_:this%cfg%kmax_+1)) !< Y-face-centered + allocate(this%itpr_z(-1:0,this%cfg%imin_:this%cfg%imax_+1,this%cfg%jmin_:this%cfg%jmax_+1,this%cfg%kmin_:this%cfg%kmax_+1)) !< Z-face-centered + ! Create density (or other things) interpolation coefficients to cell face + do k=this%cfg%kmin_,this%cfg%kmax_+1 + do j=this%cfg%jmin_,this%cfg%jmax_+1 + do i=this%cfg%imin_,this%cfg%imax_+1 + this%itpr_x(:,i,j,k)=this%cfg%dxmi(i)*[this%cfg%xm(i)-this%cfg%x(i),this%cfg%x(i)-this%cfg%xm(i-1)] !< Linear interpolation in x from [xm,ym,zm] to [x,ym,zm] + this%itpr_y(:,i,j,k)=this%cfg%dymi(j)*[this%cfg%ym(j)-this%cfg%y(j),this%cfg%y(j)-this%cfg%ym(j-1)] !< Linear interpolation in y from [xm,ym,zm] to [xm,y,zm] + this%itpr_z(:,i,j,k)=this%cfg%dzmi(k)*[this%cfg%zm(k)-this%cfg%z(k),this%cfg%z(k)-this%cfg%zm(k-1)] !< Linear interpolation in z from [xm,ym,zm] to [xm,ym,z] + end do + end do + end do + + ! Allocate finite difference viscosity interpolation coefficients + allocate(this%itp_xy(-1:0,-1:0,this%cfg%imino_+1:this%cfg%imaxo_,this%cfg%jmino_+1:this%cfg%jmaxo_,this%cfg%kmino_+1:this%cfg%kmaxo_)) !< Edge-centered (xy) + allocate(this%itp_yz(-1:0,-1:0,this%cfg%imino_+1:this%cfg%imaxo_,this%cfg%jmino_+1:this%cfg%jmaxo_,this%cfg%kmino_+1:this%cfg%kmaxo_)) !< Edge-centered (yz) + allocate(this%itp_xz(-1:0,-1:0,this%cfg%imino_+1:this%cfg%imaxo_,this%cfg%jmino_+1:this%cfg%jmaxo_,this%cfg%kmino_+1:this%cfg%kmaxo_)) !< Edge-centered (zx) + ! Create viscosity interpolation coefficients to cell edge + do k=this%cfg%kmino_+1,this%cfg%kmaxo_ + do j=this%cfg%jmino_+1,this%cfg%jmaxo_ + do i=this%cfg%imino_+1,this%cfg%imaxo_ + ! Prepare local 1D metrics + itpx=this%cfg%dxmi(i)*[this%cfg%xm(i)-this%cfg%x(i),this%cfg%x(i)-this%cfg%xm(i-1)] + itpy=this%cfg%dymi(j)*[this%cfg%ym(j)-this%cfg%y(j),this%cfg%y(j)-this%cfg%ym(j-1)] + itpz=this%cfg%dzmi(k)*[this%cfg%zm(k)-this%cfg%z(k),this%cfg%z(k)-this%cfg%zm(k-1)] + ! Combine for 2D interpolations + do st1=-1,0 + do st2=-1,0 + this%itp_xy(st1,st2,i,j,k)=itpx(st1)*itpy(st2) + this%itp_yz(st1,st2,i,j,k)=itpy(st1)*itpz(st2) + this%itp_xz(st1,st2,i,j,k)=itpx(st1)*itpz(st2) + end do + end do + end do + end do + end do + + ! Allocate finite difference velocity interpolation coefficients + allocate(this%itpu_x( 0:+1,this%cfg%imino_ :this%cfg%imaxo_,this%cfg%jmino_ :this%cfg%jmaxo_,this%cfg%kmino_ :this%cfg%kmaxo_)) !< Cell-centered + allocate(this%itpv_y( 0:+1,this%cfg%imino_ :this%cfg%imaxo_,this%cfg%jmino_ :this%cfg%jmaxo_,this%cfg%kmino_ :this%cfg%kmaxo_)) !< Cell-centered + allocate(this%itpw_z( 0:+1,this%cfg%imino_ :this%cfg%imaxo_,this%cfg%jmino_ :this%cfg%jmaxo_,this%cfg%kmino_ :this%cfg%kmaxo_)) !< Cell-centered + allocate(this%itpv_x(-1: 0,this%cfg%imino_+1:this%cfg%imaxo_,this%cfg%jmino_ :this%cfg%jmaxo_,this%cfg%kmino_ :this%cfg%kmaxo_)) !< Edge-centered (xy) + allocate(this%itpw_x(-1: 0,this%cfg%imino_+1:this%cfg%imaxo_,this%cfg%jmino_ :this%cfg%jmaxo_,this%cfg%kmino_ :this%cfg%kmaxo_)) !< Edge-centered (zx) + allocate(this%itpu_y(-1: 0,this%cfg%imino_ :this%cfg%imaxo_,this%cfg%jmino_+1:this%cfg%jmaxo_,this%cfg%kmino_ :this%cfg%kmaxo_)) !< Edge-centered (xy) + allocate(this%itpw_y(-1: 0,this%cfg%imino_ :this%cfg%imaxo_,this%cfg%jmino_+1:this%cfg%jmaxo_,this%cfg%kmino_ :this%cfg%kmaxo_)) !< Edge-centered (yz) + allocate(this%itpu_z(-1: 0,this%cfg%imino_ :this%cfg%imaxo_,this%cfg%jmino_ :this%cfg%jmaxo_,this%cfg%kmino_+1:this%cfg%kmaxo_)) !< Edge-centered (zx) + allocate(this%itpv_z(-1: 0,this%cfg%imino_ :this%cfg%imaxo_,this%cfg%jmino_ :this%cfg%jmaxo_,this%cfg%kmino_+1:this%cfg%kmaxo_)) !< Edge-centered (yz) + ! Create velocity interpolation coefficients to cell center [xm,ym,zm] + do k=this%cfg%kmino_,this%cfg%kmaxo_ + do j=this%cfg%jmino_,this%cfg%jmaxo_ + do i=this%cfg%imino_,this%cfg%imaxo_ + this%itpu_x(:,i,j,k)=[+0.5_WP,+0.5_WP] !< Linear interpolation in x of U from [x ,ym,zm] + this%itpv_y(:,i,j,k)=[+0.5_WP,+0.5_WP] !< Linear interpolation in y of V from [xm,y ,zm] + this%itpw_z(:,i,j,k)=[+0.5_WP,+0.5_WP] !< Linear interpolation in z of W from [xm,ym,z ] + end do + end do + end do + ! Create velocity interpolation coefficients to cell edge in x + do k=this%cfg%kmino_ ,this%cfg%kmaxo_ + do j=this%cfg%jmino_ ,this%cfg%jmaxo_ + do i=this%cfg%imino_+1,this%cfg%imaxo_ + this%itpv_x(:,i,j,k)=this%cfg%dxmi(i)*[this%cfg%xm(i)-this%cfg%x(i),this%cfg%x(i)-this%cfg%xm(i-1)] !< Linear interpolation in x of V from [xm,y ,zm] + this%itpw_x(:,i,j,k)=this%cfg%dxmi(i)*[this%cfg%xm(i)-this%cfg%x(i),this%cfg%x(i)-this%cfg%xm(i-1)] !< Linear interpolation in x of W from [xm,ym,z ] + end do + end do + end do + ! Create velocity interpolation coefficients to cell edge in y + do k=this%cfg%kmino_ ,this%cfg%kmaxo_ + do j=this%cfg%jmino_+1,this%cfg%jmaxo_ + do i=this%cfg%imino_ ,this%cfg%imaxo_ + this%itpu_y(:,i,j,k)=this%cfg%dymi(j)*[this%cfg%ym(j)-this%cfg%y(j),this%cfg%y(j)-this%cfg%ym(j-1)] !< Linear interpolation in y of U from [x ,ym,zm] + this%itpw_y(:,i,j,k)=this%cfg%dymi(j)*[this%cfg%ym(j)-this%cfg%y(j),this%cfg%y(j)-this%cfg%ym(j-1)] !< Linear interpolation in y of W from [xm,ym,z ] + end do + end do + end do + ! Create velocity interpolation coefficients to cell edge in z + do k=this%cfg%kmino_+1,this%cfg%kmaxo_ + do j=this%cfg%jmino_ ,this%cfg%jmaxo_ + do i=this%cfg%imino_ ,this%cfg%imaxo_ + this%itpu_z(:,i,j,k)=this%cfg%dzmi(k)*[this%cfg%zm(k)-this%cfg%z(k),this%cfg%z(k)-this%cfg%zm(k-1)] !< Linear interpolation in z of U from [x ,ym,zm] + this%itpv_z(:,i,j,k)=this%cfg%dzmi(k)*[this%cfg%zm(k)-this%cfg%z(k),this%cfg%z(k)-this%cfg%zm(k-1)] !< Linear interpolation in z of V from [xm,y ,zm] + end do + end do + end do + + ! Allocate finite volume divergence operators + allocate(this%divp_x( 0:+1,this%cfg%imino_ :this%cfg%imaxo_,this%cfg%jmino_ :this%cfg%jmaxo_,this%cfg%kmino_ :this%cfg%kmaxo_)) !< Cell-centered + allocate(this%divp_y( 0:+1,this%cfg%imino_ :this%cfg%imaxo_,this%cfg%jmino_ :this%cfg%jmaxo_,this%cfg%kmino_ :this%cfg%kmaxo_)) !< Cell-centered + allocate(this%divp_z( 0:+1,this%cfg%imino_ :this%cfg%imaxo_,this%cfg%jmino_ :this%cfg%jmaxo_,this%cfg%kmino_ :this%cfg%kmaxo_)) !< Cell-centered + allocate(this%divu_x(-1: 0,this%cfg%imino_+1:this%cfg%imaxo_,this%cfg%jmino_ :this%cfg%jmaxo_,this%cfg%kmino_ :this%cfg%kmaxo_)) !< Face-centered (x) + allocate(this%divu_y( 0:+1,this%cfg%imino_ :this%cfg%imaxo_,this%cfg%jmino_ :this%cfg%jmaxo_,this%cfg%kmino_ :this%cfg%kmaxo_)) !< Face-centered (x) + allocate(this%divu_z( 0:+1,this%cfg%imino_ :this%cfg%imaxo_,this%cfg%jmino_ :this%cfg%jmaxo_,this%cfg%kmino_ :this%cfg%kmaxo_)) !< Face-centered (x) + allocate(this%divv_x( 0:+1,this%cfg%imino_ :this%cfg%imaxo_,this%cfg%jmino_ :this%cfg%jmaxo_,this%cfg%kmino_ :this%cfg%kmaxo_)) !< Face-centered (y) + allocate(this%divv_y(-1: 0,this%cfg%imino_ :this%cfg%imaxo_,this%cfg%jmino_+1:this%cfg%jmaxo_,this%cfg%kmino_ :this%cfg%kmaxo_)) !< Face-centered (y) + allocate(this%divv_z( 0:+1,this%cfg%imino_ :this%cfg%imaxo_,this%cfg%jmino_ :this%cfg%jmaxo_,this%cfg%kmino_ :this%cfg%kmaxo_)) !< Face-centered (y) + allocate(this%divw_x( 0:+1,this%cfg%imino_ :this%cfg%imaxo_,this%cfg%jmino_ :this%cfg%jmaxo_,this%cfg%kmino_ :this%cfg%kmaxo_)) !< Face-centered (z) + allocate(this%divw_y( 0:+1,this%cfg%imino_ :this%cfg%imaxo_,this%cfg%jmino_ :this%cfg%jmaxo_,this%cfg%kmino_ :this%cfg%kmaxo_)) !< Face-centered (z) + allocate(this%divw_z(-1: 0,this%cfg%imino_ :this%cfg%imaxo_,this%cfg%jmino_ :this%cfg%jmaxo_,this%cfg%kmino_+1:this%cfg%kmaxo_)) !< Face-centered (z) + ! Create divergence operator to cell center [xm,ym,zm] or tangent to cell face + do k=this%cfg%kmino_,this%cfg%kmaxo_ + do j=this%cfg%jmino_,this%cfg%jmaxo_ + do i=this%cfg%imino_,this%cfg%imaxo_ + this%divp_x(:,i,j,k)=this%cfg%dxi(i)*[-1.0_WP,+1.0_WP] !< FV divergence from [x ,ym,zm] + this%divp_y(:,i,j,k)=this%cfg%dyi(j)*[-1.0_WP,+1.0_WP] !< FV divergence from [xm,y ,zm] + this%divp_z(:,i,j,k)=this%cfg%dzi(k)*[-1.0_WP,+1.0_WP] !< FV divergence from [xm,ym,z ] + + this%divu_y(:,i,j,k)=this%cfg%dyi(j)*[-1.0_WP,+1.0_WP] !< FV divergence from [x ,y ,zm] + this%divu_z(:,i,j,k)=this%cfg%dzi(k)*[-1.0_WP,+1.0_WP] !< FV divergence from [x ,ym,z ] + + this%divv_x(:,i,j,k)=this%cfg%dxi(i)*[-1.0_WP,+1.0_WP] !< FV divergence from [x ,y ,zm] + this%divv_z(:,i,j,k)=this%cfg%dzi(k)*[-1.0_WP,+1.0_WP] !< FV divergence from [xm,y ,z ] + + this%divw_x(:,i,j,k)=this%cfg%dxi(i)*[-1.0_WP,+1.0_WP] !< FV divergence from [x ,ym,z ] + this%divw_y(:,i,j,k)=this%cfg%dyi(j)*[-1.0_WP,+1.0_WP] !< FV divergence from [xm,y ,z ] + end do + end do + end do + ! Create divergence operator perpendicular to cell face [x ,ym,zm] + do k=this%cfg%kmino_ ,this%cfg%kmaxo_ + do j=this%cfg%jmino_ ,this%cfg%jmaxo_ + do i=this%cfg%imino_+1,this%cfg%imaxo_ + this%divu_x(:,i,j,k)=this%cfg%dxmi(i)*[-1.0_WP,+1.0_WP] !< FV divergence from [xm,ym,zm] + end do + end do + end do + ! Create divergence operator perpendicular to cell face [xm,y ,zm] + do k=this%cfg%kmino_ ,this%cfg%kmaxo_ + do j=this%cfg%jmino_+1,this%cfg%jmaxo_ + do i=this%cfg%imino_ ,this%cfg%imaxo_ + this%divv_y(:,i,j,k)=this%cfg%dymi(j)*[-1.0_WP,+1.0_WP] !< FV divergence from [xm,ym,zm] + end do + end do + end do + ! Create divergence operator perpendicular to cell face [xm,ym,z ] + do k=this%cfg%kmino_+1,this%cfg%kmaxo_ + do j=this%cfg%jmino_ ,this%cfg%jmaxo_ + do i=this%cfg%imino_ ,this%cfg%imaxo_ + this%divw_z(:,i,j,k)=this%cfg%dzmi(k)*[-1.0_WP,+1.0_WP] !< FV divergence from [xm,ym,zm] + end do + end do + end do + + ! Allocate finite difference velocity gradient operators + allocate(this%grdu_x( 0:+1,this%cfg%imino_ :this%cfg%imaxo_,this%cfg%jmino_ :this%cfg%jmaxo_,this%cfg%kmino_ :this%cfg%kmaxo_)) !< Cell-centered + allocate(this%grdv_y( 0:+1,this%cfg%imino_ :this%cfg%imaxo_,this%cfg%jmino_ :this%cfg%jmaxo_,this%cfg%kmino_ :this%cfg%kmaxo_)) !< Cell-centered + allocate(this%grdw_z( 0:+1,this%cfg%imino_ :this%cfg%imaxo_,this%cfg%jmino_ :this%cfg%jmaxo_,this%cfg%kmino_ :this%cfg%kmaxo_)) !< Cell-centered + allocate(this%grdv_x(-1: 0,this%cfg%imino_+1:this%cfg%imaxo_,this%cfg%jmino_ :this%cfg%jmaxo_,this%cfg%kmino_ :this%cfg%kmaxo_)) !< Edge-centered (xy) + allocate(this%grdw_x(-1: 0,this%cfg%imino_+1:this%cfg%imaxo_,this%cfg%jmino_ :this%cfg%jmaxo_,this%cfg%kmino_ :this%cfg%kmaxo_)) !< Edge-centered (zx) + allocate(this%grdu_y(-1: 0,this%cfg%imino_ :this%cfg%imaxo_,this%cfg%jmino_+1:this%cfg%jmaxo_,this%cfg%kmino_ :this%cfg%kmaxo_)) !< Edge-centered (xy) + allocate(this%grdw_y(-1: 0,this%cfg%imino_ :this%cfg%imaxo_,this%cfg%jmino_+1:this%cfg%jmaxo_,this%cfg%kmino_ :this%cfg%kmaxo_)) !< Edge-centered (yz) + allocate(this%grdu_z(-1: 0,this%cfg%imino_ :this%cfg%imaxo_,this%cfg%jmino_ :this%cfg%jmaxo_,this%cfg%kmino_+1:this%cfg%kmaxo_)) !< Edge-centered (zx) + allocate(this%grdv_z(-1: 0,this%cfg%imino_ :this%cfg%imaxo_,this%cfg%jmino_ :this%cfg%jmaxo_,this%cfg%kmino_+1:this%cfg%kmaxo_)) !< Edge-centered (yz) + ! Create gradient coefficients to cell center [xm,ym,zm] + do k=this%cfg%kmino_,this%cfg%kmaxo_ + do j=this%cfg%jmino_,this%cfg%jmaxo_ + do i=this%cfg%imino_,this%cfg%imaxo_ + this%grdu_x(:,i,j,k)=this%cfg%dxi(i)*[-1.0_WP,+1.0_WP] !< FD gradient in x of U from [x ,ym,zm] + this%grdv_y(:,i,j,k)=this%cfg%dyi(j)*[-1.0_WP,+1.0_WP] !< FD gradient in y of V from [xm,y ,zm] + this%grdw_z(:,i,j,k)=this%cfg%dzi(k)*[-1.0_WP,+1.0_WP] !< FD gradient in z of W from [xm,ym,z ] + end do + end do + end do + ! Create gradient coefficients to cell edge in x + do k=this%cfg%kmino_ ,this%cfg%kmaxo_ + do j=this%cfg%jmino_ ,this%cfg%jmaxo_ + do i=this%cfg%imino_+1,this%cfg%imaxo_ + this%grdv_x(:,i,j,k)=this%cfg%dxmi(i)*[-1.0_WP,+1.0_WP] !< FD gradient in x of V from [xm,y ,zm] + this%grdw_x(:,i,j,k)=this%cfg%dxmi(i)*[-1.0_WP,+1.0_WP] !< FD gradient in x of W from [xm,ym,z ] + end do + end do + end do + ! Create gradient coefficients to cell edge in y + do k=this%cfg%kmino_ ,this%cfg%kmaxo_ + do j=this%cfg%jmino_+1,this%cfg%jmaxo_ + do i=this%cfg%imino_ ,this%cfg%imaxo_ + this%grdu_y(:,i,j,k)=this%cfg%dymi(j)*[-1.0_WP,+1.0_WP] !< FD gradient in y of U from [x ,ym,zm] + this%grdw_y(:,i,j,k)=this%cfg%dymi(j)*[-1.0_WP,+1.0_WP] !< FD gradient in y of W from [xm,ym,z ] + end do + end do + end do + ! Create gradient coefficients to cell edge in z + do k=this%cfg%kmino_+1,this%cfg%kmaxo_ + do j=this%cfg%jmino_ ,this%cfg%jmaxo_ + do i=this%cfg%imino_ ,this%cfg%imaxo_ + this%grdu_z(:,i,j,k)=this%cfg%dzmi(k)*[-1.0_WP,+1.0_WP] !< FD gradient in z of U from [x ,ym,zm] + this%grdv_z(:,i,j,k)=this%cfg%dzmi(k)*[-1.0_WP,+1.0_WP] !< FD gradient in z of V from [xm,y ,zm] + end do + end do + end do + + end subroutine init_metrics + + + !> Metric adjustment accounting for bconds and walls + subroutine adjust_metrics(this) + implicit none + class(incomp), intent(inout) :: this + integer :: i,j,k,st1,st2 + real(WP) :: delta,mysum + + ! Sync up u/v/wmasks + call this%cfg%sync(this%umask) + call this%cfg%sync(this%vmask) + call this%cfg%sync(this%wmask) + if (.not.this%cfg%xper.and.this%cfg%iproc.eq.1) this%umask(this%cfg%imino,:,:)=this%umask(this%cfg%imino+1,:,:) + if (.not.this%cfg%yper.and.this%cfg%jproc.eq.1) this%vmask(:,this%cfg%jmino,:)=this%vmask(:,this%cfg%jmino+1,:) + if (.not.this%cfg%zper.and.this%cfg%kproc.eq.1) this%wmask(:,:,this%cfg%kmino)=this%wmask(:,:,this%cfg%kmino+1) + + ! I am assuming here that we do not really need to zero out wall cells + ! as they could be used for Dirichlet (then the density needs to be available! could be problematic if we do not have an explicit BC for scalars, e.g. for a Couette flow) + ! or outflow condition (then the density needs to be available but it should be directly calculated) + ! or used for a real no-slip wall (then density is always multiplied by zero) + ! Adjust density interpolation coefficients to cell faces in the presence of walls (only walls!) + !do k=this%cfg%kmin_,this%cfg%kmax_+1 + ! do j=this%cfg%jmin_,this%cfg%jmax_+1 + ! do i=this%cfg%imin_,this%cfg%imax_+1 + ! ! Linear interpolation in x + ! if (this%cfg%VF(i,j,k).eq.0.0_WP.and.this%cfg%VF(i-1,j,k).gt.0.0_WP) this%itpr_x(:,i,j,k)=[1.0_WP,0.0_WP] + ! if (this%cfg%VF(i,j,k).gt.0.0_WP.and.this%cfg%VF(i-1,j,k).eq.0.0_WP) this%itpr_x(:,i,j,k)=[0.0_WP,1.0_WP] + ! ! Linear interpolation in y + ! if (this%cfg%VF(i,j,k).eq.0.0_WP.and.this%cfg%VF(i,j-1,k).gt.0.0_WP) this%itpr_y(:,i,j,k)=[1.0_WP,0.0_WP] + ! if (this%cfg%VF(i,j,k).gt.0.0_WP.and.this%cfg%VF(i,j-1,k).eq.0.0_WP) this%itpr_y(:,i,j,k)=[0.0_WP,1.0_WP] + ! ! Linear interpolation in z + ! if (this%cfg%VF(i,j,k).eq.0.0_WP.and.this%cfg%VF(i,j,k-1).gt.0.0_WP) this%itpr_z(:,i,j,k)=[1.0_WP,0.0_WP] + ! if (this%cfg%VF(i,j,k).gt.0.0_WP.and.this%cfg%VF(i,j,k-1).eq.0.0_WP) this%itpr_z(:,i,j,k)=[0.0_WP,1.0_WP] + ! end do + ! end do + !end do + + ! Adjust interpolation coefficients to cell centers in the presence of walls (only walls!) + do k=this%cfg%kmino_,this%cfg%kmaxo_ + do j=this%cfg%jmino_,this%cfg%jmaxo_ + do i=this%cfg%imino_,this%cfg%imaxo_ + if (this%mask(i,j,k).eq.1) this%itpu_x(:,i,j,k)=0.0_WP + if (this%mask(i,j,k).eq.1) this%itpv_y(:,i,j,k)=0.0_WP + if (this%mask(i,j,k).eq.1) this%itpw_z(:,i,j,k)=0.0_WP + end do + end do + end do + + ! Adjust viscosity interpolation coefficients to cell edge in the presence of walls (only walls) + do k=this%cfg%kmino_+1,this%cfg%kmaxo_ + do j=this%cfg%jmino_+1,this%cfg%jmaxo_ + do i=this%cfg%imino_+1,this%cfg%imaxo_ + ! Zero out interpolation coefficients reaching in the walls + do st1=-1,0 + do st2=-1,0 + if (this%mask(i+st1,j+st2,k).eq.1) this%itp_xy(st1,st2,i,j,k)=0.0_WP + if (this%mask(i,j+st1,k+st2).eq.1) this%itp_yz(st1,st2,i,j,k)=0.0_WP + if (this%mask(i+st1,j,k+st2).eq.1) this%itp_xz(st1,st2,i,j,k)=0.0_WP + end do + end do + ! Rescale to ensure sum(itp)=1 + mysum=sum(this%itp_xy(:,:,i,j,k)); if (mysum.gt.0.0_WP) this%itp_xy(:,:,i,j,k)=this%itp_xy(:,:,i,j,k)/mysum + mysum=sum(this%itp_yz(:,:,i,j,k)); if (mysum.gt.0.0_WP) this%itp_yz(:,:,i,j,k)=this%itp_yz(:,:,i,j,k)/mysum + mysum=sum(this%itp_xz(:,:,i,j,k)); if (mysum.gt.0.0_WP) this%itp_xz(:,:,i,j,k)=this%itp_xz(:,:,i,j,k)/mysum + end do + end do + end do + + ! Loop over the domain and adjust divergence for P cell + do k=this%cfg%kmino_,this%cfg%kmaxo_ + do j=this%cfg%jmino_,this%cfg%jmaxo_ + do i=this%cfg%imino_,this%cfg%imaxo_ + if (this%mask(i,j,k).gt.0) then + this%divp_x(:,i,j,k)=0.0_WP + this%divp_y(:,i,j,k)=0.0_WP + this%divp_z(:,i,j,k)=0.0_WP + end if + end do + end do + end do + + ! Loop over the domain and apply masked conditions to U metrics + do k=this%cfg%kmino_ ,this%cfg%kmaxo_ + do j=this%cfg%jmino_ ,this%cfg%jmaxo_ + do i=this%cfg%imino_+1,this%cfg%imaxo_ + if (this%umask(i,j,k).gt.0) then + this%divu_x(:,i,j,k)=0.0_WP + this%divu_y(:,i,j,k)=0.0_WP + this%divu_z(:,i,j,k)=0.0_WP + end if + end do + end do + end do + + ! Loop over the domain and apply masked conditions to V metrics + do k=this%cfg%kmino_ ,this%cfg%kmaxo_ + do j=this%cfg%jmino_+1,this%cfg%jmaxo_ + do i=this%cfg%imino_ ,this%cfg%imaxo_ + if (this%vmask(i,j,k).gt.0) then + this%divv_x(:,i,j,k)=0.0_WP + this%divv_y(:,i,j,k)=0.0_WP + this%divv_z(:,i,j,k)=0.0_WP + end if + end do + end do + end do + + ! Loop over the domain and apply masked conditions to W metrics + do k=this%cfg%kmino_+1,this%cfg%kmaxo_ + do j=this%cfg%jmino_ ,this%cfg%jmaxo_ + do i=this%cfg%imino_ ,this%cfg%imaxo_ + if (this%wmask(i,j,k).gt.0) then + this%divw_x(:,i,j,k)=0.0_WP + this%divw_y(:,i,j,k)=0.0_WP + this%divw_z(:,i,j,k)=0.0_WP + end if + end do + end do + end do + + ! Adjust gradient coefficients to cell edge in x + do k=this%cfg%kmino_ ,this%cfg%kmaxo_ + do j=this%cfg%jmino_ ,this%cfg%jmaxo_ + do i=this%cfg%imino_+1,this%cfg%imaxo_ + ! FD gradient in x of V from [xm,y ,zm] + if (maxval(this%vmask(i-1:i,j,k)).gt.0) then + delta=0.0_WP + if (this%vmask(i ,j,k).eq.0) delta=delta+(this%cfg%xm(i)-this%cfg%x (i )) + if (this%vmask(i-1,j,k).eq.0) delta=delta+(this%cfg%x (i)-this%cfg%xm(i-1)) + if (delta.gt.0.0_WP) then + this%grdv_x(:,i,j,k)=[-1.0_WP,+1.0_WP]/delta + else + this%grdv_x(:,i,j,k)=0.0_WP + end if + end if + ! FD gradient in x of W from [xm,ym,z ] + if (maxval(this%wmask(i-1:i,j,k)).gt.0) then + delta=0.0_WP + if (this%wmask(i ,j,k).eq.0) delta=delta+(this%cfg%xm(i)-this%cfg%x (i )) + if (this%wmask(i-1,j,k).eq.0) delta=delta+(this%cfg%x (i)-this%cfg%xm(i-1)) + if (delta.gt.0.0_WP) then + this%grdw_x(:,i,j,k)=[-1.0_WP,+1.0_WP]/delta + else + this%grdw_x(:,i,j,k)=0.0_WP + end if + end if + end do + end do + end do + + ! Adjust gradient coefficients to cell edge in y + do k=this%cfg%kmino_ ,this%cfg%kmaxo_ + do j=this%cfg%jmino_+1,this%cfg%jmaxo_ + do i=this%cfg%imino_ ,this%cfg%imaxo_ + ! FD gradient in y of U from [x ,ym,zm] + if (maxval(this%umask(i,j-1:j,k)).gt.0) then + delta=0.0_WP + if (this%umask(i,j ,k).eq.0) delta=delta+(this%cfg%ym(j)-this%cfg%y (j )) + if (this%umask(i,j-1,k).eq.0) delta=delta+(this%cfg%y (j)-this%cfg%ym(j-1)) + if (delta.gt.0.0_WP) then + this%grdu_y(:,i,j,k)=[-1.0_WP,+1.0_WP]/delta + else + this%grdu_y(:,i,j,k)=0.0_WP + end if + end if + ! FD gradient in y of W from [xm,ym,z ] + if (maxval(this%wmask(i,j-1:j,k)).gt.0) then + delta=0.0_WP + if (this%wmask(i,j ,k).eq.0) delta=delta+(this%cfg%ym(j)-this%cfg%y (j )) + if (this%wmask(i,j-1,k).eq.0) delta=delta+(this%cfg%y (j)-this%cfg%ym(j-1)) + if (delta.gt.0.0_WP) then + this%grdw_y(:,i,j,k)=[-1.0_WP,+1.0_WP]/delta + else + this%grdw_y(:,i,j,k)=0.0_WP + end if + end if + end do + end do + end do + + ! Adjust gradient coefficients to cell edge in z + do k=this%cfg%kmino_+1,this%cfg%kmaxo_ + do j=this%cfg%jmino_ ,this%cfg%jmaxo_ + do i=this%cfg%imino_ ,this%cfg%imaxo_ + ! FD gradient in z of U from [x ,ym,zm] + if (maxval(this%umask(i,j,k-1:k)).gt.0) then + delta=0.0_WP + if (this%umask(i,j,k ).eq.0) delta=delta+(this%cfg%zm(k)-this%cfg%z (k )) + if (this%umask(i,j,k-1).eq.0) delta=delta+(this%cfg%z (k)-this%cfg%zm(k-1)) + if (delta.gt.0.0_WP) then + this%grdu_z(:,i,j,k)=[-1.0_WP,+1.0_WP]/delta + else + this%grdu_z(:,i,j,k)=0.0_WP + end if + end if + ! FD gradient in z of V from [xm,y ,zm] + if (maxval(this%vmask(i,j,k-1:k)).gt.0) then + delta=0.0_WP + if (this%vmask(i,j,k ).eq.0) delta=delta+(this%cfg%zm(k)-this%cfg%z (k )) + if (this%vmask(i,j,k-1).eq.0) delta=delta+(this%cfg%z (k)-this%cfg%zm(k-1)) + if (delta.gt.0.0_WP) then + this%grdv_z(:,i,j,k)=[-1.0_WP,+1.0_WP]/delta + else + this%grdv_z(:,i,j,k)=0.0_WP + end if + end if + end do + end do + end do + + ! Adjust interpolation coefficients to cell centers in the presence of walls (only walls!) + do k=this%cfg%kmino_,this%cfg%kmaxo_ + do j=this%cfg%jmino_,this%cfg%jmaxo_ + do i=this%cfg%imino_,this%cfg%imaxo_ + if (this%mask(i,j,k).eq.1) this%itpu_x(:,i,j,k)=0.0_WP + if (this%mask(i,j,k).eq.1) this%itpv_y(:,i,j,k)=0.0_WP + if (this%mask(i,j,k).eq.1) this%itpw_z(:,i,j,k)=0.0_WP + end do + end do + end do + + ! Adjust interpolation coefficients to cell edge in x + do k=this%cfg%kmino_ ,this%cfg%kmaxo_ + do j=this%cfg%jmino_ ,this%cfg%jmaxo_ + do i=this%cfg%imino_+1,this%cfg%imaxo_ + ! Linear interpolation in x of V from [xm,y ,zm] + if (this%vmask(i,j,k).eq.0.and.this%vmask(i-1,j,k).gt.0) this%itpv_x(:,i,j,k)=[1.0_WP,0.0_WP] + if (this%vmask(i,j,k).gt.0.and.this%vmask(i-1,j,k).eq.0) this%itpv_x(:,i,j,k)=[0.0_WP,1.0_WP] + ! Linear interpolation in x of W from [xm,ym,z ] + if (this%wmask(i,j,k).eq.0.and.this%wmask(i-1,j,k).gt.0) this%itpw_x(:,i,j,k)=[1.0_WP,0.0_WP] + if (this%wmask(i,j,k).gt.0.and.this%wmask(i-1,j,k).eq.0) this%itpw_x(:,i,j,k)=[0.0_WP,1.0_WP] + end do + end do + end do + + ! Adjust interpolation coefficients to cell edge in y + do k=this%cfg%kmino_ ,this%cfg%kmaxo_ + do j=this%cfg%jmino_+1,this%cfg%jmaxo_ + do i=this%cfg%imino_ ,this%cfg%imaxo_ + ! Linear interpolation in y of U from [x ,ym,zm] + if (this%umask(i,j,k).eq.0.and.this%umask(i,j-1,k).gt.0) this%itpu_y(:,i,j,k)=[1.0_WP,0.0_WP] + if (this%umask(i,j,k).gt.0.and.this%umask(i,j-1,k).eq.0) this%itpu_y(:,i,j,k)=[0.0_WP,1.0_WP] + ! Linear interpolation in y of W from [xm,ym,z ] + if (this%wmask(i,j,k).eq.0.and.this%wmask(i,j-1,k).gt.0) this%itpw_y(:,i,j,k)=[1.0_WP,0.0_WP] + if (this%wmask(i,j,k).gt.0.and.this%wmask(i,j-1,k).eq.0) this%itpw_y(:,i,j,k)=[0.0_WP,1.0_WP] + end do + end do + end do + + ! Adjust interpolation coefficients to cell edge in z + do k=this%cfg%kmino_+1,this%cfg%kmaxo_ + do j=this%cfg%jmino_ ,this%cfg%jmaxo_ + do i=this%cfg%imino_ ,this%cfg%imaxo_ + ! Linear interpolation in z of U from [x ,ym,zm] + if (this%umask(i,j,k).eq.0.and.this%umask(i,j,k-1).gt.0) this%itpu_z(:,i,j,k)=[1.0_WP,0.0_WP] + if (this%umask(i,j,k).gt.0.and.this%umask(i,j,k-1).eq.0) this%itpu_z(:,i,j,k)=[0.0_WP,1.0_WP] + ! Linear interpolation in z of V from [xm,y ,zm] + if (this%vmask(i,j,k).eq.0.and.this%vmask(i,j,k-1).gt.0) this%itpv_z(:,i,j,k)=[1.0_WP,0.0_WP] + if (this%vmask(i,j,k).gt.0.and.this%vmask(i,j,k-1).eq.0) this%itpv_z(:,i,j,k)=[0.0_WP,1.0_WP] + end do + end do + end do + + ! Adjust metrics to account for lower dimensionality + if (this%cfg%nx.eq.1) then + this%divp_x=0.0_WP + this%divu_x=0.0_WP + this%divv_x=0.0_WP + this%divw_x=0.0_WP + this%grdu_x=0.0_WP + this%grdv_x=0.0_WP + this%grdw_x=0.0_WP + end if + if (this%cfg%ny.eq.1) then + this%divp_y=0.0_WP + this%divu_y=0.0_WP + this%divv_y=0.0_WP + this%divw_y=0.0_WP + this%grdu_y=0.0_WP + this%grdv_y=0.0_WP + this%grdw_y=0.0_WP + end if + if (this%cfg%nz.eq.1) then + this%divp_z=0.0_WP + this%divu_z=0.0_WP + this%divv_z=0.0_WP + this%divw_z=0.0_WP + this%grdu_z=0.0_WP + this%grdv_z=0.0_WP + this%grdw_z=0.0_WP + end if + + end subroutine adjust_metrics + + + !> Finish setting up the flow solver now that bconds have been defined + subroutine setup(this,pressure_solver,implicit_solver) + implicit none + class(incomp), intent(inout) :: this + class(linsol), target, intent(in) :: pressure_solver !< A pressure solver is required + class(linsol), target, intent(in), optional :: implicit_solver !< An implicit solver can be provided + integer :: i,j,k + + ! Adjust metrics based on bcflag array + call this%adjust_metrics() + + ! Point to pressure solver linsol object + this%psolv=>pressure_solver + + ! Set 7-pt stencil map for the pressure solver + this%psolv%stc(1,:)=[ 0, 0, 0] + this%psolv%stc(2,:)=[+1, 0, 0] + this%psolv%stc(3,:)=[-1, 0, 0] + this%psolv%stc(4,:)=[ 0,+1, 0] + this%psolv%stc(5,:)=[ 0,-1, 0] + this%psolv%stc(6,:)=[ 0, 0,+1] + this%psolv%stc(7,:)=[ 0, 0,-1] + + ! Setup the scaled Laplacian operator from incomp metrics: lap(*)=-vol*div(grad(*)) + do k=this%cfg%kmin_,this%cfg%kmax_ + do j=this%cfg%jmin_,this%cfg%jmax_ + do i=this%cfg%imin_,this%cfg%imax_ + ! Set Laplacian + this%psolv%opr(1,i,j,k)=this%divp_x(1,i,j,k)*this%divu_x(-1,i+1,j,k)+& + & this%divp_x(0,i,j,k)*this%divu_x( 0,i ,j,k)+& + & this%divp_y(1,i,j,k)*this%divv_y(-1,i,j+1,k)+& + & this%divp_y(0,i,j,k)*this%divv_y( 0,i,j ,k)+& + & this%divp_z(1,i,j,k)*this%divw_z(-1,i,j,k+1)+& + & this%divp_z(0,i,j,k)*this%divw_z( 0,i,j,k ) + this%psolv%opr(2,i,j,k)=this%divp_x(1,i,j,k)*this%divu_x( 0,i+1,j,k) + this%psolv%opr(3,i,j,k)=this%divp_x(0,i,j,k)*this%divu_x(-1,i ,j,k) + this%psolv%opr(4,i,j,k)=this%divp_y(1,i,j,k)*this%divv_y( 0,i,j+1,k) + this%psolv%opr(5,i,j,k)=this%divp_y(0,i,j,k)*this%divv_y(-1,i,j ,k) + this%psolv%opr(6,i,j,k)=this%divp_z(1,i,j,k)*this%divw_z( 0,i,j,k+1) + this%psolv%opr(7,i,j,k)=this%divp_z(0,i,j,k)*this%divw_z(-1,i,j,k ) + ! Scale it by the cell volume + this%psolv%opr(:,i,j,k)=-this%psolv%opr(:,i,j,k)*this%cfg%vol(i,j,k) + end do + end do + end do + + ! Initialize the pressure Poisson solver + call this%psolv%init() + call this%psolv%setup() + + ! Prepare implicit solver if it had been provided + if (present(implicit_solver)) then + + ! Point to implicit solver linsol object + this%implicit=>implicit_solver + + ! Set 7-pt stencil map for the velocity solver + this%implicit%stc(1,:)=[ 0, 0, 0] + this%implicit%stc(2,:)=[+1, 0, 0] + this%implicit%stc(3,:)=[-1, 0, 0] + this%implicit%stc(4,:)=[ 0,+1, 0] + this%implicit%stc(5,:)=[ 0,-1, 0] + this%implicit%stc(6,:)=[ 0, 0,+1] + this%implicit%stc(7,:)=[ 0, 0,-1] + + ! Set the diagonal to 1 to make sure all cells participate in solver + this%implicit%opr(1,:,:,:)=1.0_WP + + ! Initialize the implicit velocity solver + call this%implicit%init() + + else + + ! Point to implicit solver linsol object + this%implicit=>NULL() + + end if + + end subroutine setup + + + !> Add a boundary condition + subroutine add_bcond(this,name,type,locator,face,dir,canCorrect) + use string, only: lowercase + use messager, only: die + use iterator_class, only: locator_ftype + implicit none + class(incomp), intent(inout) :: this + character(len=*), intent(in) :: name + integer, intent(in) :: type + procedure(locator_ftype) :: locator + character(len=1), intent(in) :: face + integer, intent(in) :: dir + logical, intent(in) :: canCorrect + type(bcond), pointer :: new_bc + integer :: i,j,k,n + + ! Prepare new bcond + allocate(new_bc) + new_bc%name=trim(adjustl(name)) + new_bc%type=type + select case (lowercase(face)) + case ('x'); new_bc%face='x' + case ('y'); new_bc%face='y' + case ('z'); new_bc%face='z' + case default; call die('[incomp add_bcond] Unknown bcond face - expecting x, y, or z') + end select + new_bc%itr=iterator(pg=this%cfg,name=new_bc%name,locator=locator,face=new_bc%face) + select case (dir) ! Outward-oriented + case (+1); new_bc%dir=+1 + case (-1); new_bc%dir=-1 + case ( 0); new_bc%dir= 0 + case default; call die('[incomp add_bcond] Unknown bcond dir - expecting -1, +1, or 0') + end select + new_bc%rdir=real(new_bc%dir,WP) + new_bc%canCorrect=canCorrect + + ! Insert it up front + new_bc%next=>this%first_bc + this%first_bc=>new_bc + + ! Increment bcond counter + this%nbc=this%nbc+1 + + ! Now adjust the metrics accordingly + select case (new_bc%type) + case (dirichlet) !< Dirichlet is set one face (i.e., velocit component) at the time + select case (new_bc%face) + case ('x') + do n=1,new_bc%itr%n_ + i=new_bc%itr%map(1,n); j=new_bc%itr%map(2,n); k=new_bc%itr%map(3,n) + this%umask(i,j,k)=2 + end do + case ('y') + do n=1,new_bc%itr%n_ + i=new_bc%itr%map(1,n); j=new_bc%itr%map(2,n); k=new_bc%itr%map(3,n) + this%vmask(i,j,k)=2 + end do + case ('z') + do n=1,new_bc%itr%n_ + i=new_bc%itr%map(1,n); j=new_bc%itr%map(2,n); k=new_bc%itr%map(3,n) + this%wmask(i,j,k)=2 + end do + end select + + case (neumann) !< Neumann has to be at existing wall or at domain boundary! + case (clipped_neumann) + case (convective) + case (slip) + case default + call die('[incomp apply_bcond] Unknown bcond type') + end select + + end subroutine add_bcond + + + !> Get a boundary condition + subroutine get_bcond(this,name,my_bc) + use messager, only: die + implicit none + class(incomp), intent(inout) :: this + character(len=*), intent(in) :: name + type(bcond), pointer, intent(out) :: my_bc + my_bc=>this%first_bc + search: do while (associated(my_bc)) + if (trim(my_bc%name).eq.trim(name)) exit search + my_bc=>my_bc%next + end do search + if (.not.associated(my_bc)) call die('[incomp get_bcond] Boundary condition was not found') + end subroutine get_bcond + + + !> Enforce boundary condition + subroutine apply_bcond(this,t,dt) + use messager, only: die + implicit none + class(incomp), intent(inout) :: this + real(WP), intent(in) :: t,dt + integer :: i,j,k,n,stag + type(bcond), pointer :: my_bc + + ! ! First enfore zero velocity at walls + ! do k=this%cfg%kmin_,this%cfg%kmax_ + ! do j=this%cfg%jmin_,this%cfg%jmax_ + ! do i=this%cfg%imin_,this%cfg%imax_ + ! if (minval(this%cfg%VF(i-1:i,j,k)).lt.10.0_WP*epsilon(1.0_WP)) this%U(i,j,k)=0.0_WP + ! if (minval(this%cfg%VF(i,j-1:j,k)).lt.10.0_WP*epsilon(1.0_WP)) this%V(i,j,k)=0.0_WP + ! if (minval(this%cfg%VF(i,j,k-1:k)).lt.10.0_WP*epsilon(1.0_WP)) this%W(i,j,k)=0.0_WP + ! end do + ! end do + ! end do + ! ! Sync fields + ! call this%cfg%sync(this%U) + ! call this%cfg%sync(this%V) + ! call this%cfg%sync(this%W) + + ! Traverse bcond list + my_bc=>this%first_bc + do while (associated(my_bc)) + + ! Only processes inside the bcond work here + if (my_bc%itr%amIn) then + + ! Select appropriate action based on the bcond type + select case (my_bc%type) + + case (dirichlet) !< Apply Dirichlet conditions + + ! This is done by the user directly + ! Unclear whether we want to do this within the solver... + + case (neumann,clipped_neumann,slip) !< Apply Neumann condition to all 3 components + ! Handle index shift due to staggering + stag=min(my_bc%dir,0) + ! Implement based on bcond direction + select case (my_bc%face) + case ('x') + stag=min(my_bc%dir,0) + do n=1,my_bc%itr%n_ + i=my_bc%itr%map(1,n); j=my_bc%itr%map(2,n); k=my_bc%itr%map(3,n) + this%U(i ,j ,k )=this%U(i-my_bc%dir ,j ,k ) + this%V(i+stag,j:j+1,k )=this%V(i-my_bc%dir+stag,j:j+1,k ) + this%W(i+stag,j ,k:k+1)=this%W(i-my_bc%dir+stag,j ,k:k+1) + end do + case ('y') + stag=min(my_bc%dir,0) + do n=1,my_bc%itr%n_ + i=my_bc%itr%map(1,n); j=my_bc%itr%map(2,n); k=my_bc%itr%map(3,n) + this%U(i:i+1,j+stag,k )=this%U(i:i+1,j-my_bc%dir+stag,k ) + this%V(i ,j ,k )=this%V(i ,j-my_bc%dir ,k ) + this%W(i ,j+stag,k:k+1)=this%W(i ,j-my_bc%dir+stag,k:k+1) + end do + case ('z') + stag=min(my_bc%dir,0) + do n=1,my_bc%itr%n_ + i=my_bc%itr%map(1,n); j=my_bc%itr%map(2,n); k=my_bc%itr%map(3,n) + this%U(i:i+1,j ,k+stag)=this%U(i:i+1,j ,k-my_bc%dir+stag) + this%V(i ,j:j+1,k+stag)=this%V(i ,j:j+1,k-my_bc%dir+stag) + this%W(i ,j ,k )=this%W(i ,j ,k-my_bc%dir ) + end do + end select + ! If needed, clip + if (my_bc%type.eq.clipped_neumann) then + select case (my_bc%face) + case ('x') + do n=1,my_bc%itr%n_ + i=my_bc%itr%map(1,n); j=my_bc%itr%map(2,n); k=my_bc%itr%map(3,n) + if (this%U(i,j,k)*my_bc%rdir.lt.0.0_WP) this%U(i,j,k)=0.0_WP + end do + case ('y') + do n=1,my_bc%itr%n_ + i=my_bc%itr%map(1,n); j=my_bc%itr%map(2,n); k=my_bc%itr%map(3,n) + if (this%V(i,j,k)*my_bc%rdir.lt.0.0_WP) this%V(i,j,k)=0.0_WP + end do + case ('z') + do n=1,my_bc%itr%n_ + i=my_bc%itr%map(1,n); j=my_bc%itr%map(2,n); k=my_bc%itr%map(3,n) + if (this%W(i,j,k)*my_bc%rdir.lt.0.0_WP) this%W(i,j,k)=0.0_WP + end do + end select + end if + ! If needed, no penetration + if (my_bc%type.eq.slip) then + select case (my_bc%face) + case ('x') + do n=1,my_bc%itr%n_ + i=my_bc%itr%map(1,n); j=my_bc%itr%map(2,n); k=my_bc%itr%map(3,n) + this%U(i,j,k)=0.0_WP + end do + case ('y') + do n=1,my_bc%itr%n_ + i=my_bc%itr%map(1,n); j=my_bc%itr%map(2,n); k=my_bc%itr%map(3,n) + this%V(i,j,k)=0.0_WP + end do + case ('z') + do n=1,my_bc%itr%n_ + i=my_bc%itr%map(1,n); j=my_bc%itr%map(2,n); k=my_bc%itr%map(3,n) + this%W(i,j,k)=0.0_WP + end do + end select + end if + + case (convective) ! Not implemented yet! + + case default + call die('[incomp apply_bcond] Unknown bcond type') + end select + + end if + + ! Move on to the next bcond + my_bc=>my_bc%next + + end do + + ! Sync full fields after all bcond + call this%cfg%sync(this%U) + call this%cfg%sync(this%V) + call this%cfg%sync(this%W) + + end subroutine apply_bcond + + + !> Calculate the explicit momentum time derivative based on U/V/W/P + subroutine get_dmomdt(this,drhoUdt,drhoVdt,drhoWdt) + implicit none + class(incomp), intent(inout) :: this + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(out) :: drhoUdt !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(out) :: drhoVdt !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(out) :: drhoWdt !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + integer :: i,j,k,ii,jj,kk + real(WP), dimension(:,:,:), allocatable :: FX,FY,FZ + + ! Zero out drhoUVW/dt arrays + drhoUdt=0.0_WP; drhoVdt=0.0_WP; drhoWdt=0.0_WP + + ! Allocate flux arrays + allocate(FX(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + allocate(FY(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + allocate(FZ(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + + ! Flux of rhoU + do kk=this%cfg%kmin_,this%cfg%kmax_+1 + do jj=this%cfg%jmin_,this%cfg%jmax_+1 + do ii=this%cfg%imin_,this%cfg%imax_+1 + ! Fluxes on x-face + i=ii-1; j=jj-1; k=kk-1 + FX(i,j,k)=-this%rho*sum(this%itpu_x(:,i,j,k)*this%U(i:i+1,j,k))*sum(this%itpu_x(:,i,j,k)*this%U(i:i+1,j,k)) & + & +this%visc(i,j,k)*(sum(this%grdu_x(:,i,j,k)*this%U(i:i+1,j,k))+sum(this%grdu_x(:,i,j,k)*this%U(i:i+1,j,k)) & + & -2.0_WP/3.0_WP*(sum(this%divp_x(:,i,j,k)*this%U(i:i+1,j,k))+sum(this%divp_y(:,i,j,k)*this%V(i,j:j+1,k))+sum(this%divp_z(:,i,j,k)*this%W(i,j,k:k+1)))) & + & -this%P(i,j,k) + ! Fluxes on y-face + i=ii; j=jj; k=kk + FY(i,j,k)=-this%rho*sum(this%itpu_y(:,i,j,k)*this%U(i,j-1:j,k))*sum(this%itpv_x(:,i,j,k)*this%V(i-1:i,j,k)) & + & +sum(this%itp_xy(:,:,i,j,k)*this%visc(i-1:i,j-1:j,k))*(sum(this%grdu_y(:,i,j,k)*this%U(i,j-1:j,k))+sum(this%grdv_x(:,i,j,k)*this%V(i-1:i,j,k))) + ! Fluxes on z-face + i=ii; j=jj; k=kk + FZ(i,j,k)=-this%rho*sum(this%itpu_z(:,i,j,k)*this%U(i,j,k-1:k))*sum(this%itpw_x(:,i,j,k)*this%W(i-1:i,j,k)) & + & +sum(this%itp_xz(:,:,i,j,k)*this%visc(i-1:i,j,k-1:k))*(sum(this%grdu_z(:,i,j,k)*this%U(i,j,k-1:k))+sum(this%grdw_x(:,i,j,k)*this%W(i-1:i,j,k))) + end do + end do + end do + ! Time derivative of rhoU + do k=this%cfg%kmin_,this%cfg%kmax_ + do j=this%cfg%jmin_,this%cfg%jmax_ + do i=this%cfg%imin_,this%cfg%imax_ + drhoUdt(i,j,k)=sum(this%divu_x(:,i,j,k)*FX(i-1:i,j,k))+& + & sum(this%divu_y(:,i,j,k)*FY(i,j:j+1,k))+& + & sum(this%divu_z(:,i,j,k)*FZ(i,j,k:k+1)) + end do + end do + end do + ! Sync it + call this%cfg%sync(drhoUdt) + + ! Flux of rhoV + do kk=this%cfg%kmin_,this%cfg%kmax_+1 + do jj=this%cfg%jmin_,this%cfg%jmax_+1 + do ii=this%cfg%imin_,this%cfg%imax_+1 + ! Fluxes on x-face + i=ii; j=jj; k=kk + FX(i,j,k)=-this%rho*sum(this%itpv_x(:,i,j,k)*this%V(i-1:i,j,k))*sum(this%itpu_y(:,i,j,k)*this%U(i,j-1:j,k)) & + & +sum(this%itp_xy(:,:,i,j,k)*this%visc(i-1:i,j-1:j,k))*(sum(this%grdv_x(:,i,j,k)*this%V(i-1:i,j,k))+sum(this%grdu_y(:,i,j,k)*this%U(i,j-1:j,k))) + ! Fluxes on y-face + i=ii-1; j=jj-1; k=kk-1 + FY(i,j,k)=-this%rho*sum(this%itpv_y(:,i,j,k)*this%V(i,j:j+1,k))*sum(this%itpv_y(:,i,j,k)*this%V(i,j:j+1,k)) & + & +this%visc(i,j,k)*(sum(this%grdv_y(:,i,j,k)*this%V(i,j:j+1,k))+sum(this%grdv_y(:,i,j,k)*this%V(i,j:j+1,k)) & + & -2.0_WP/3.0_WP*(sum(this%divp_x(:,i,j,k)*this%U(i:i+1,j,k))+sum(this%divp_y(:,i,j,k)*this%V(i,j:j+1,k))+sum(this%divp_z(:,i,j,k)*this%W(i,j,k:k+1)))) & + & -this%P(i,j,k) + ! Fluxes on z-face + i=ii; j=jj; k=kk + FZ(i,j,k)=-this%rho*sum(this%itpv_z(:,i,j,k)*this%V(i,j,k-1:k))*sum(this%itpw_y(:,i,j,k)*this%W(i,j-1:j,k)) & + & +sum(this%itp_yz(:,:,i,j,k)*this%visc(i,j-1:j,k-1:k))*(sum(this%grdv_z(:,i,j,k)*this%V(i,j,k-1:k))+sum(this%grdw_y(:,i,j,k)*this%W(i,j-1:j,k))) + end do + end do + end do + ! Time derivative of rhoV + do k=this%cfg%kmin_,this%cfg%kmax_ + do j=this%cfg%jmin_,this%cfg%jmax_ + do i=this%cfg%imin_,this%cfg%imax_ + drhoVdt(i,j,k)=sum(this%divv_x(:,i,j,k)*FX(i:i+1,j,k))+& + & sum(this%divv_y(:,i,j,k)*FY(i,j-1:j,k))+& + & sum(this%divv_z(:,i,j,k)*FZ(i,j,k:k+1)) + end do + end do + end do + ! Sync it + call this%cfg%sync(drhoVdt) + + ! Flux of rhoW + do kk=this%cfg%kmin_,this%cfg%kmax_+1 + do jj=this%cfg%jmin_,this%cfg%jmax_+1 + do ii=this%cfg%imin_,this%cfg%imax_+1 + ! Fluxes on x-face + i=ii; j=jj; k=kk + FX(i,j,k)=-this%rho*sum(this%itpw_x(:,i,j,k)*this%W(i-1:i,j,k))*sum(this%itpu_z(:,i,j,k)*this%U(i,j,k-1:k)) & + & +sum(this%itp_xz(:,:,i,j,k)*this%visc(i-1:i,j,k-1:k))*(sum(this%grdw_x(:,i,j,k)*this%W(i-1:i,j,k))+sum(this%grdu_z(:,i,j,k)*this%U(i,j,k-1:k))) + ! Fluxes on y-face + i=ii; j=jj; k=kk + FY(i,j,k)=-this%rho*sum(this%itpw_y(:,i,j,k)*this%W(i,j-1:j,k))*sum(this%itpv_z(:,i,j,k)*this%V(i,j,k-1:k)) & + & +sum(this%itp_yz(:,:,i,j,k)*this%visc(i,j-1:j,k-1:k))*(sum(this%grdw_y(:,i,j,k)*this%W(i,j-1:j,k))+sum(this%grdv_z(:,i,j,k)*this%V(i,j,k-1:k))) + ! Fluxes on z-face + i=ii-1; j=jj-1; k=kk-1 + FZ(i,j,k)=-this%rho*sum(this%itpw_z(:,i,j,k)*this%W(i,j,k:k+1))*sum(this%itpw_z(:,i,j,k)*this%W(i,j,k:k+1)) & + & +this%visc(i,j,k)*(sum(this%grdw_z(:,i,j,k)*this%W(i,j,k:k+1))+sum(this%grdw_z(:,i,j,k)*this%W(i,j,k:k+1)) & + & -2.0_WP/3.0_WP*(sum(this%divp_x(:,i,j,k)*this%U(i:i+1,j,k))+sum(this%divp_y(:,i,j,k)*this%V(i,j:j+1,k))+sum(this%divp_z(:,i,j,k)*this%W(i,j,k:k+1)))) & + & -this%P(i,j,k) + end do + end do + end do + ! Time derivative of rhoW + do k=this%cfg%kmin_,this%cfg%kmax_ + do j=this%cfg%jmin_,this%cfg%jmax_ + do i=this%cfg%imin_,this%cfg%imax_ + drhoWdt(i,j,k)=sum(this%divw_x(:,i,j,k)*FX(i:i+1,j,k))+& + & sum(this%divw_y(:,i,j,k)*FY(i,j:j+1,k))+& + & sum(this%divw_z(:,i,j,k)*FZ(i,j,k-1:k)) + end do + end do + end do + ! Sync it + call this%cfg%sync(drhoWdt) + + ! Deallocate flux arrays + deallocate(FX,FY,FZ) + + end subroutine get_dmomdt + + + !> Calculate the divergence of fluid stress + subroutine get_div_stress(this,divx,divy,divz) + implicit none + class(incomp), intent(inout) :: this + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(out) :: divx !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(out) :: divy !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(out) :: divz !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + integer :: i,j,k,ii,jj,kk + real(WP), dimension(:,:,:), allocatable :: FX,FY,FZ + + ! Zero out drhoUVW/dt arrays + divx=0.0_WP; divy=0.0_WP; divz=0.0_WP + + ! Allocate flux arrays + allocate(FX(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + allocate(FY(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + allocate(FZ(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + + ! Flux of rhoU + do kk=this%cfg%kmin_,this%cfg%kmax_+1 + do jj=this%cfg%jmin_,this%cfg%jmax_+1 + do ii=this%cfg%imin_,this%cfg%imax_+1 + ! Fluxes on x-face + i=ii-1; j=jj-1; k=kk-1 + FX(i,j,k)=+this%visc(i,j,k)*(sum(this%grdu_x(:,i,j,k)*this%U(i:i+1,j,k))+sum(this%grdu_x(:,i,j,k)*this%U(i:i+1,j,k)) & + & -2.0_WP/3.0_WP*(sum(this%divp_x(:,i,j,k)*this%U(i:i+1,j,k))+sum(this%divp_y(:,i,j,k)*this%V(i,j:j+1,k))+sum(this%divp_z(:,i,j,k)*this%W(i,j,k:k+1)))) & + & -this%P(i,j,k) + ! Fluxes on y-face + i=ii; j=jj; k=kk + FY(i,j,k)=+sum(this%itp_xy(:,:,i,j,k)*this%visc(i-1:i,j-1:j,k))*(sum(this%grdu_y(:,i,j,k)*this%U(i,j-1:j,k))+sum(this%grdv_x(:,i,j,k)*this%V(i-1:i,j,k))) + ! Fluxes on z-face + i=ii; j=jj; k=kk + FZ(i,j,k)=+sum(this%itp_xz(:,:,i,j,k)*this%visc(i-1:i,j,k-1:k))*(sum(this%grdu_z(:,i,j,k)*this%U(i,j,k-1:k))+sum(this%grdw_x(:,i,j,k)*this%W(i-1:i,j,k))) + end do + end do + end do + ! Time derivative of rhoU + do k=this%cfg%kmin_,this%cfg%kmax_ + do j=this%cfg%jmin_,this%cfg%jmax_ + do i=this%cfg%imin_,this%cfg%imax_ + divx(i,j,k)=sum(this%divu_x(:,i,j,k)*FX(i-1:i,j,k))+& + & sum(this%divu_y(:,i,j,k)*FY(i,j:j+1,k))+& + & sum(this%divu_z(:,i,j,k)*FZ(i,j,k:k+1)) + end do + end do + end do + ! Sync it + call this%cfg%sync(divx) + + ! Flux of rhoV + do kk=this%cfg%kmin_,this%cfg%kmax_+1 + do jj=this%cfg%jmin_,this%cfg%jmax_+1 + do ii=this%cfg%imin_,this%cfg%imax_+1 + ! Fluxes on x-face + i=ii; j=jj; k=kk + FX(i,j,k)=+sum(this%itp_xy(:,:,i,j,k)*this%visc(i-1:i,j-1:j,k))*(sum(this%grdv_x(:,i,j,k)*this%V(i-1:i,j,k))+sum(this%grdu_y(:,i,j,k)*this%U(i,j-1:j,k))) + ! Fluxes on y-face + i=ii-1; j=jj-1; k=kk-1 + FY(i,j,k)=+this%visc(i,j,k)*(sum(this%grdv_y(:,i,j,k)*this%V(i,j:j+1,k))+sum(this%grdv_y(:,i,j,k)*this%V(i,j:j+1,k)) & + & -2.0_WP/3.0_WP*(sum(this%divp_x(:,i,j,k)*this%U(i:i+1,j,k))+sum(this%divp_y(:,i,j,k)*this%V(i,j:j+1,k))+sum(this%divp_z(:,i,j,k)*this%W(i,j,k:k+1)))) & + & -this%P(i,j,k) + ! Fluxes on z-face + i=ii; j=jj; k=kk + FZ(i,j,k)=+sum(this%itp_yz(:,:,i,j,k)*this%visc(i,j-1:j,k-1:k))*(sum(this%grdv_z(:,i,j,k)*this%V(i,j,k-1:k))+sum(this%grdw_y(:,i,j,k)*this%W(i,j-1:j,k))) + end do + end do + end do + ! Time derivative of rhoV + do k=this%cfg%kmin_,this%cfg%kmax_ + do j=this%cfg%jmin_,this%cfg%jmax_ + do i=this%cfg%imin_,this%cfg%imax_ + divy(i,j,k)=sum(this%divv_x(:,i,j,k)*FX(i:i+1,j,k))+& + & sum(this%divv_y(:,i,j,k)*FY(i,j-1:j,k))+& + & sum(this%divv_z(:,i,j,k)*FZ(i,j,k:k+1)) + end do + end do + end do + ! Sync it + call this%cfg%sync(divy) + + ! Flux of rhoW + do kk=this%cfg%kmin_,this%cfg%kmax_+1 + do jj=this%cfg%jmin_,this%cfg%jmax_+1 + do ii=this%cfg%imin_,this%cfg%imax_+1 + ! Fluxes on x-face + i=ii; j=jj; k=kk + FX(i,j,k)=+sum(this%itp_xz(:,:,i,j,k)*this%visc(i-1:i,j,k-1:k))*(sum(this%grdw_x(:,i,j,k)*this%W(i-1:i,j,k))+sum(this%grdu_z(:,i,j,k)*this%U(i,j,k-1:k))) + ! Fluxes on y-face + i=ii; j=jj; k=kk + FY(i,j,k)=+sum(this%itp_yz(:,:,i,j,k)*this%visc(i,j-1:j,k-1:k))*(sum(this%grdw_y(:,i,j,k)*this%W(i,j-1:j,k))+sum(this%grdv_z(:,i,j,k)*this%V(i,j,k-1:k))) + ! Fluxes on z-face + i=ii-1; j=jj-1; k=kk-1 + FZ(i,j,k)=+this%visc(i,j,k)*(sum(this%grdw_z(:,i,j,k)*this%W(i,j,k:k+1))+sum(this%grdw_z(:,i,j,k)*this%W(i,j,k:k+1)) & + & -2.0_WP/3.0_WP*(sum(this%divp_x(:,i,j,k)*this%U(i:i+1,j,k))+sum(this%divp_y(:,i,j,k)*this%V(i,j:j+1,k))+sum(this%divp_z(:,i,j,k)*this%W(i,j,k:k+1)))) & + & -this%P(i,j,k) + end do + end do + end do + ! Time derivative of rhoW + do k=this%cfg%kmin_,this%cfg%kmax_ + do j=this%cfg%jmin_,this%cfg%jmax_ + do i=this%cfg%imin_,this%cfg%imax_ + divz(i,j,k)=sum(this%divw_x(:,i,j,k)*FX(i:i+1,j,k))+& + & sum(this%divw_y(:,i,j,k)*FY(i,j:j+1,k))+& + & sum(this%divw_z(:,i,j,k)*FZ(i,j,k-1:k)) + end do + end do + end do + ! Sync it + call this%cfg%sync(divz) + + ! Deallocate flux arrays + deallocate(FX,FY,FZ) + + end subroutine get_div_stress + + + !> Calculate the velocity divergence based on U/V/W + subroutine get_div(this,src) + implicit none + class(incomp), intent(inout) :: this + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), optional :: src !< Mass source term + integer :: i,j,k + ! Calculate divergence of velocity + do k=this%cfg%kmin_,this%cfg%kmax_ + do j=this%cfg%jmin_,this%cfg%jmax_ + do i=this%cfg%imin_,this%cfg%imax_ + this%div(i,j,k)=sum(this%divp_x(:,i,j,k)*this%U(i:i+1,j,k))+& + & sum(this%divp_y(:,i,j,k)*this%V(i,j:j+1,k))+& + & sum(this%divp_z(:,i,j,k)*this%W(i,j,k:k+1)) + end do + end do + end do + ! If present, account for mass source + if (present(src)) then + do k=this%cfg%kmin_,this%cfg%kmax_ + do j=this%cfg%jmin_,this%cfg%jmax_ + do i=this%cfg%imin_,this%cfg%imax_ + this%div(i,j,k)=this%div(i,j,k)-src(i,j,k) + end do + end do + end do + end if + ! Sync it + call this%cfg%sync(this%div) + end subroutine get_div + + + !> Calculate the pressure gradient based on P + subroutine get_pgrad(this,P,Pgradx,Pgrady,Pgradz) + implicit none + class(incomp), intent(inout) :: this + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(in) :: P !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(out) :: Pgradx !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(out) :: Pgrady !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(out) :: Pgradz !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + integer :: i,j,k + Pgradx=0.0_WP; Pgrady=0.0_WP; Pgradz=0.0_WP + do k=this%cfg%kmin_,this%cfg%kmax_ + do j=this%cfg%jmin_,this%cfg%jmax_ + do i=this%cfg%imin_,this%cfg%imax_ + Pgradx(i,j,k)=sum(this%divu_x(:,i,j,k)*P(i-1:i,j,k)) + Pgrady(i,j,k)=sum(this%divv_y(:,i,j,k)*P(i,j-1:j,k)) + Pgradz(i,j,k)=sum(this%divw_z(:,i,j,k)*P(i,j,k-1:k)) + end do + end do + end do + ! Sync it + call this%cfg%sync(Pgradx) + call this%cfg%sync(Pgrady) + call this%cfg%sync(Pgradz) + end subroutine get_pgrad + + + !> Calculate the interpolated velocity, including overlap and ghosts + subroutine interp_vel(this,Ui,Vi,Wi) + implicit none + class(incomp), intent(inout) :: this + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(out) :: Ui !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(out) :: Vi !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(out) :: Wi !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + integer :: i,j,k + ! Calculate as far as possible each component + do k=this%cfg%kmino_,this%cfg%kmaxo_ + do j=this%cfg%jmino_,this%cfg%jmaxo_ + do i=this%cfg%imino_,this%cfg%imaxo_-1 + Ui(i,j,k)=sum(this%itpu_x(:,i,j,k)*this%U(i:i+1,j,k)) + end do + end do + end do + do k=this%cfg%kmino_,this%cfg%kmaxo_ + do j=this%cfg%jmino_,this%cfg%jmaxo_-1 + do i=this%cfg%imino_,this%cfg%imaxo_ + Vi(i,j,k)=sum(this%itpv_y(:,i,j,k)*this%V(i,j:j+1,k)) + end do + end do + end do + do k=this%cfg%kmino_,this%cfg%kmaxo_-1 + do j=this%cfg%jmino_,this%cfg%jmaxo_ + do i=this%cfg%imino_,this%cfg%imaxo_ + Wi(i,j,k)=sum(this%itpw_z(:,i,j,k)*this%W(i,j,k:k+1)) + end do + end do + end do + ! Add last layer in each direction + if (.not.this%cfg%xper.and.this%cfg%iproc.eq.this%cfg%npx) Ui(this%cfg%imaxo,:,:)=this%U(this%cfg%imaxo,:,:) + if (.not.this%cfg%yper.and.this%cfg%jproc.eq.this%cfg%npy) Vi(:,this%cfg%jmaxo,:)=this%V(:,this%cfg%jmaxo,:) + if (.not.this%cfg%zper.and.this%cfg%kproc.eq.this%cfg%npz) Wi(:,:,this%cfg%kmaxo)=this%W(:,:,this%cfg%kmaxo) + ! Sync it + call this%cfg%sync(Ui) + call this%cfg%sync(Vi) + call this%cfg%sync(Wi) + end subroutine interp_vel + + + !> Calculate the deviatoric part of the strain rate tensor from U/V/W + !> 1: du/dx-div/3 + !> 2: dv/dy-div/3 + !> 3: dw/dz-div/3 + !> 4: (du/dy+dv/dx)/2 + !> 5: (dv/dz+dw/dy)/2 + !> 6: (dw/dx+du/dz)/2 + subroutine get_strainrate(this,SR) + use messager, only: die + implicit none + class(incomp), intent(inout) :: this + real(WP), dimension(1:,this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(out) :: SR !< Needs to be (1:6,imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + real(WP), dimension(:,:,:), allocatable :: dudy,dudz,dvdx,dvdz,dwdx,dwdy + real(WP) :: div + integer :: i,j,k + + ! Check SR's first dimension + if (size(SR,dim=1).ne.6) call die('[incomp get_strainrate] SR should be of size (1:6,imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_)') + + ! Compute dudx, dvdy, and dwdz first + do k=this%cfg%kmin_,this%cfg%kmax_ + do j=this%cfg%jmin_,this%cfg%jmax_ + do i=this%cfg%imin_,this%cfg%imax_ + SR(1,i,j,k)=sum(this%grdu_x(:,i,j,k)*this%U(i:i+1,j,k)) + SR(2,i,j,k)=sum(this%grdv_y(:,i,j,k)*this%V(i,j:j+1,k)) + SR(3,i,j,k)=sum(this%grdw_z(:,i,j,k)*this%W(i,j,k:k+1)) + div=sum(SR(1:3,i,j,k))/3.0_WP + SR(1,i,j,k)=SR(1,i,j,k)-div + SR(2,i,j,k)=SR(2,i,j,k)-div + SR(3,i,j,k)=SR(3,i,j,k)-div + end do + end do + end do + + ! Allocate velocity gradient components + allocate(dudy(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + allocate(dudz(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + allocate(dvdx(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + allocate(dvdz(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + allocate(dwdx(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + allocate(dwdy(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + + ! Calculate components of the velocity gradient at their natural locations with an extra cell for interpolation + do k=this%cfg%kmin_,this%cfg%kmax_+1 + do j=this%cfg%jmin_,this%cfg%jmax_+1 + do i=this%cfg%imin_,this%cfg%imax_+1 + dudy(i,j,k)=sum(this%grdu_y(:,i,j,k)*this%U(i,j-1:j,k)) + dudz(i,j,k)=sum(this%grdu_z(:,i,j,k)*this%U(i,j,k-1:k)) + dvdx(i,j,k)=sum(this%grdv_x(:,i,j,k)*this%V(i-1:i,j,k)) + dvdz(i,j,k)=sum(this%grdv_z(:,i,j,k)*this%V(i,j,k-1:k)) + dwdx(i,j,k)=sum(this%grdw_x(:,i,j,k)*this%W(i-1:i,j,k)) + dwdy(i,j,k)=sum(this%grdw_y(:,i,j,k)*this%W(i,j-1:j,k)) + end do + end do + end do + + ! Interpolate off-diagonal components of the velocity gradient to the cell center and store strain rate + do k=this%cfg%kmin_,this%cfg%kmax_ + do j=this%cfg%jmin_,this%cfg%jmax_ + do i=this%cfg%imin_,this%cfg%imax_ + SR(4,i,j,k)=0.125_WP*(sum(dudy(i:i+1,j:j+1,k ))+sum(dvdx(i:i+1,j:j+1,k ))) + SR(5,i,j,k)=0.125_WP*(sum(dvdz(i ,j:j+1,k:k+1))+sum(dwdy(i ,j:j+1,k:k+1))) + SR(6,i,j,k)=0.125_WP*(sum(dwdx(i:i+1,j ,k:k+1))+sum(dudz(i:i+1,j ,k:k+1))) + end do + end do + end do + + ! Apply a Neumann condition in non-periodic directions + if (.not.this%cfg%xper) then + if (this%cfg%iproc.eq.1) SR(:,this%cfg%imin-1,:,:)=SR(:,this%cfg%imin,:,:) + if (this%cfg%iproc.eq.this%cfg%npx) SR(:,this%cfg%imax+1,:,:)=SR(:,this%cfg%imax,:,:) + end if + if (.not.this%cfg%yper) then + if (this%cfg%jproc.eq.1) SR(:,:,this%cfg%jmin-1,:)=SR(:,:,this%cfg%jmin,:) + if (this%cfg%jproc.eq.this%cfg%npy) SR(:,:,this%cfg%jmax+1,:)=SR(:,:,this%cfg%jmax,:) + end if + if (.not.this%cfg%zper) then + if (this%cfg%kproc.eq.1) SR(:,:,:,this%cfg%kmin-1)=SR(:,:,:,this%cfg%kmin) + if (this%cfg%kproc.eq.this%cfg%npz) SR(:,:,:,this%cfg%kmax+1)=SR(:,:,:,this%cfg%kmax) + end if + + ! Ensure zero in walls + do k=this%cfg%kmino_,this%cfg%kmaxo_ + do j=this%cfg%jmino_,this%cfg%jmaxo_ + do i=this%cfg%imino_,this%cfg%imaxo_ + if (this%mask(i,j,k).eq.1) SR(:,i,j,k)=0.0_WP + end do + end do + end do + + ! Sync it + call this%cfg%sync(SR) + + ! Deallocate velocity gradient storage + deallocate(dudy,dudz,dvdx,dvdz,dwdx,dwdy) + + end subroutine get_strainrate + + + !> Calculate the velocity gradient tensor from U/V/W + !> Note that gradu(i,j)=duj/dxi + subroutine get_gradu(this,gradu) + use messager, only: die + implicit none + class(incomp), intent(inout) :: this + real(WP), dimension(1:,1:,this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(out) :: gradu !< Needs to be (1:3,1:3,imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + integer :: i,j,k + real(WP), dimension(:,:,:), allocatable :: dudy,dudz,dvdx,dvdz,dwdx,dwdy + + ! Check gradu's first two dimensions + if (size(gradu,dim=1).ne.3.or.size(gradu,dim=2).ne.3) call die('[incomp get_gradu] gradu should be of size (1:3,1:3,imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_)') + + ! Compute dudx, dvdy, and dwdz first + do k=this%cfg%kmin_,this%cfg%kmax_ + do j=this%cfg%jmin_,this%cfg%jmax_ + do i=this%cfg%imin_,this%cfg%imax_ + gradu(1,1,i,j,k)=sum(this%grdu_x(:,i,j,k)*this%U(i:i+1,j,k)) + gradu(2,2,i,j,k)=sum(this%grdv_y(:,i,j,k)*this%V(i,j:j+1,k)) + gradu(3,3,i,j,k)=sum(this%grdw_z(:,i,j,k)*this%W(i,j,k:k+1)) + end do + end do + end do + + ! Allocate velocity gradient components + allocate(dudy(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + allocate(dudz(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + allocate(dvdx(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + allocate(dvdz(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + allocate(dwdx(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + allocate(dwdy(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + + ! Calculate components of the velocity gradient at their natural locations with an extra cell for interpolation + do k=this%cfg%kmin_,this%cfg%kmax_+1 + do j=this%cfg%jmin_,this%cfg%jmax_+1 + do i=this%cfg%imin_,this%cfg%imax_+1 + dudy(i,j,k)=sum(this%grdu_y(:,i,j,k)*this%U(i,j-1:j,k)) + dudz(i,j,k)=sum(this%grdu_z(:,i,j,k)*this%U(i,j,k-1:k)) + dvdx(i,j,k)=sum(this%grdv_x(:,i,j,k)*this%V(i-1:i,j,k)) + dvdz(i,j,k)=sum(this%grdv_z(:,i,j,k)*this%V(i,j,k-1:k)) + dwdx(i,j,k)=sum(this%grdw_x(:,i,j,k)*this%W(i-1:i,j,k)) + dwdy(i,j,k)=sum(this%grdw_y(:,i,j,k)*this%W(i,j-1:j,k)) + end do + end do + end do + + ! Interpolate off-diagonal components of the velocity gradient to the cell center + do k=this%cfg%kmin_,this%cfg%kmax_ + do j=this%cfg%jmin_,this%cfg%jmax_ + do i=this%cfg%imin_,this%cfg%imax_ + gradu(2,1,i,j,k)=0.25_WP*sum(dudy(i:i+1,j:j+1,k)) + gradu(3,1,i,j,k)=0.25_WP*sum(dudz(i:i+1,j,k:k+1)) + gradu(1,2,i,j,k)=0.25_WP*sum(dvdx(i:i+1,j:j+1,k)) + gradu(3,2,i,j,k)=0.25_WP*sum(dvdz(i,j:j+1,k:k+1)) + gradu(1,3,i,j,k)=0.25_WP*sum(dwdx(i:i+1,j,k:k+1)) + gradu(2,3,i,j,k)=0.25_WP*sum(dwdy(i,j:j+1,k:k+1)) + end do + end do + end do + + ! Apply a Neumann condition in non-periodic directions + if (.not.this%cfg%xper) then + if (this%cfg%iproc.eq.1) gradu(:,:,this%cfg%imin-1,:,:)=gradu(:,:,this%cfg%imin,:,:) + if (this%cfg%iproc.eq.this%cfg%npx) gradu(:,:,this%cfg%imax+1,:,:)=gradu(:,:,this%cfg%imax,:,:) + end if + if (.not.this%cfg%yper) then + if (this%cfg%jproc.eq.1) gradu(:,:,:,this%cfg%jmin-1,:)=gradu(:,:,:,this%cfg%jmin,:) + if (this%cfg%jproc.eq.this%cfg%npy) gradu(:,:,:,this%cfg%jmax+1,:)=gradu(:,:,:,this%cfg%jmax,:) + end if + if (.not.this%cfg%zper) then + if (this%cfg%kproc.eq.1) gradu(:,:,:,:,this%cfg%kmin-1)=gradu(:,:,:,:,this%cfg%kmin) + if (this%cfg%kproc.eq.this%cfg%npz) gradu(:,:,:,:,this%cfg%kmax+1)=gradu(:,:,:,:,this%cfg%kmax) + end if + + ! Ensure zero in walls + do k=this%cfg%kmino_,this%cfg%kmaxo_ + do j=this%cfg%jmino_,this%cfg%jmaxo_ + do i=this%cfg%imino_,this%cfg%imaxo_ + if (this%mask(i,j,k).eq.1) gradu(:,:,i,j,k)=0.0_WP + end do + end do + end do + + ! Sync it + call this%cfg%sync(gradu) + + ! Deallocate velocity gradient storage + deallocate(dudy,dudz,dvdx,dvdz,dwdx,dwdy) + + end subroutine get_gradu + + + !> Calculate vorticity vector + subroutine get_vorticity(this,vort) + use messager, only: die + implicit none + class(incomp), intent(inout) :: this + real(WP), dimension(1:,this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(out) :: vort !< Needs to be (1:3,imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + integer :: i,j,k + real(WP), dimension(:,:,:), allocatable :: dudy,dudz,dvdx,dvdz,dwdx,dwdy + + ! Check vort's first two dimensions + if (size(vort,dim=1).ne.3) call die('[incomp get_vorticity] vort should be of size (1:3,imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_)') + + ! Allocate velocity gradient components + allocate(dudy(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + allocate(dudz(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + allocate(dvdx(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + allocate(dvdz(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + allocate(dwdx(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + allocate(dwdy(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + + ! Calculate components of the velocity gradient at their natural locations with an extra cell for interpolation + do k=this%cfg%kmin_,this%cfg%kmax_+1 + do j=this%cfg%jmin_,this%cfg%jmax_+1 + do i=this%cfg%imin_,this%cfg%imax_+1 + dudy(i,j,k)=sum(this%grdu_y(:,i,j,k)*this%U(i,j-1:j,k)) + dudz(i,j,k)=sum(this%grdu_z(:,i,j,k)*this%U(i,j,k-1:k)) + dvdx(i,j,k)=sum(this%grdv_x(:,i,j,k)*this%V(i-1:i,j,k)) + dvdz(i,j,k)=sum(this%grdv_z(:,i,j,k)*this%V(i,j,k-1:k)) + dwdx(i,j,k)=sum(this%grdw_x(:,i,j,k)*this%W(i-1:i,j,k)) + dwdy(i,j,k)=sum(this%grdw_y(:,i,j,k)*this%W(i,j-1:j,k)) + end do + end do + end do + + ! Interpolate off-diagonal components of the velocity gradient to the cell center + do k=this%cfg%kmin_,this%cfg%kmax_ + do j=this%cfg%jmin_,this%cfg%jmax_ + do i=this%cfg%imin_,this%cfg%imax_ + vort(1,i,j,k)=0.25_WP*(sum(dwdy(i,j:j+1,k:k+1))-sum(dvdz(i,j:j+1,k:k+1))) + vort(2,i,j,k)=0.25_WP*(sum(dudz(i:i+1,j,k:k+1))-sum(dwdx(i:i+1,j,k:k+1))) + vort(3,i,j,k)=0.25_WP*(sum(dvdx(i:i+1,j:j+1,k))-sum(dudy(i:i+1,j:j+1,k))) + end do + end do + end do + + ! Apply a Neumann condition in non-periodic directions + if (.not.this%cfg%xper) then + if (this%cfg%iproc.eq.1) vort(:,this%cfg%imin-1,:,:)=vort(:,this%cfg%imin,:,:) + if (this%cfg%iproc.eq.this%cfg%npx) vort(:,this%cfg%imax+1,:,:)=vort(:,this%cfg%imax,:,:) + end if + if (.not.this%cfg%yper) then + if (this%cfg%jproc.eq.1) vort(:,:,this%cfg%jmin-1,:)=vort(:,:,this%cfg%jmin,:) + if (this%cfg%jproc.eq.this%cfg%npy) vort(:,:,this%cfg%jmax+1,:)=vort(:,:,this%cfg%jmax,:) + end if + if (.not.this%cfg%zper) then + if (this%cfg%kproc.eq.1) vort(:,:,:,this%cfg%kmin-1)=vort(:,:,:,this%cfg%kmin) + if (this%cfg%kproc.eq.this%cfg%npz) vort(:,:,:,this%cfg%kmax+1)=vort(:,:,:,this%cfg%kmax) + end if + + ! Ensure zero in walls + do k=this%cfg%kmino_,this%cfg%kmaxo_ + do j=this%cfg%jmino_,this%cfg%jmaxo_ + do i=this%cfg%imino_,this%cfg%imaxo_ + if (this%mask(i,j,k).eq.1) vort(:,i,j,k)=0.0_WP + end do + end do + end do + + ! Sync it + call this%cfg%sync(vort) + + ! Deallocate velocity gradient storage + deallocate(dudy,dudz,dvdx,dvdz,dwdx,dwdy) + + end subroutine get_vorticity + + + !> Calculate the CFL + subroutine get_cfl(this,dt,cflc,cfl) + use mpi_f08, only: MPI_ALLREDUCE,MPI_MAX + use parallel, only: MPI_REAL_WP + implicit none + class(incomp), intent(inout) :: this + real(WP), intent(in) :: dt + real(WP), intent(out) :: cflc + real(WP), optional :: cfl + integer :: i,j,k,ierr + real(WP) :: my_CFLc_x,my_CFLc_y,my_CFLc_z,my_CFLv_x,my_CFLv_y,my_CFLv_z + + ! Set the CFLs to zero + my_CFLc_x=0.0_WP; my_CFLc_y=0.0_WP; my_CFLc_z=0.0_WP + my_CFLv_x=0.0_WP; my_CFLv_y=0.0_WP; my_CFLv_z=0.0_WP + do k=this%cfg%kmin_,this%cfg%kmax_ + do j=this%cfg%jmin_,this%cfg%jmax_ + do i=this%cfg%imin_,this%cfg%imax_ + my_CFLc_x=max(my_CFLc_x,abs(this%U(i,j,k))*this%cfg%dxmi(i)) + my_CFLc_y=max(my_CFLc_y,abs(this%V(i,j,k))*this%cfg%dymi(j)) + my_CFLc_z=max(my_CFLc_z,abs(this%W(i,j,k))*this%cfg%dzmi(k)) + my_CFLv_x=max(my_CFLv_x,4.0_WP*this%visc(i,j,k)*this%cfg%dxi(i)**2/this%rho) + my_CFLv_y=max(my_CFLv_y,4.0_WP*this%visc(i,j,k)*this%cfg%dyi(j)**2/this%rho) + my_CFLv_z=max(my_CFLv_z,4.0_WP*this%visc(i,j,k)*this%cfg%dzi(k)**2/this%rho) + end do + end do + end do + my_CFLc_x=my_CFLc_x*dt; my_CFLc_y=my_CFLc_y*dt; my_CFLc_z=my_CFLc_z*dt + my_CFLv_x=my_CFLv_x*dt; my_CFLv_y=my_CFLv_y*dt; my_CFLv_z=my_CFLv_z*dt + + ! Get the parallel max + call MPI_ALLREDUCE(my_CFLc_x,this%CFLc_x,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + call MPI_ALLREDUCE(my_CFLc_y,this%CFLc_y,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + call MPI_ALLREDUCE(my_CFLc_z,this%CFLc_z,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + call MPI_ALLREDUCE(my_CFLv_x,this%CFLv_x,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + call MPI_ALLREDUCE(my_CFLv_y,this%CFLv_y,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + call MPI_ALLREDUCE(my_CFLv_z,this%CFLv_z,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + + ! Return the maximum convective CFL + cflc=max(this%CFLc_x,this%CFLc_y,this%CFLc_z) + + ! If asked for, also return the maximum overall CFL + if (present(CFL)) cfl=max(this%CFLc_x,this%CFLc_y,this%CFLc_z,this%CFLv_x,this%CFLv_y,this%CFLv_z) + + end subroutine get_cfl + + + !> Calculate the max of our fields + subroutine get_max(this) + use mpi_f08, only: MPI_ALLREDUCE,MPI_MAX + use parallel, only: MPI_REAL_WP + implicit none + class(incomp), intent(inout) :: this + integer :: i,j,k,ierr + real(WP) :: my_Umax,my_Vmax,my_Wmax,my_Pmax,my_divmax + + ! Set all to zero + my_Umax=0.0_WP; my_Vmax=0.0_WP; my_Wmax=0.0_WP; my_Pmax=0.0_WP; my_divmax=0.0_WP + do k=this%cfg%kmin_,this%cfg%kmax_ + do j=this%cfg%jmin_,this%cfg%jmax_ + do i=this%cfg%imin_,this%cfg%imax_ + my_Umax =max(my_Umax ,abs(this%U(i,j,k) )) + my_Vmax =max(my_Vmax ,abs(this%V(i,j,k) )) + my_Wmax =max(my_Wmax ,abs(this%W(i,j,k) )) + if (this%cfg%VF(i,j,k).gt.0.0_WP) my_Pmax =max(my_Pmax ,abs(this%P(i,j,k) )) + if (this%cfg%VF(i,j,k).gt.0.0_WP) my_divmax=max(my_divmax,abs(this%div(i,j,k))) + end do + end do + end do + + ! Get the parallel max + call MPI_ALLREDUCE(my_Umax ,this%Umax ,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + call MPI_ALLREDUCE(my_Vmax ,this%Vmax ,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + call MPI_ALLREDUCE(my_Wmax ,this%Wmax ,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + call MPI_ALLREDUCE(my_Pmax ,this%Pmax ,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + call MPI_ALLREDUCE(my_divmax,this%divmax,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + + end subroutine get_max + + + !> Compute MFR through all bcs + subroutine get_mfr(this) + use mpi_f08, only: MPI_SUM,MPI_ALLREDUCE + use parallel, only: MPI_REAL_WP + implicit none + class(incomp), intent(inout) :: this + integer :: i,j,k,n,ibc,ierr + type(bcond), pointer :: my_bc + real(WP), dimension(:), allocatable :: my_mfr,my_area + real(WP), dimension(:), allocatable :: canCorrect + + ! Ensure this%mfr is of proper size + if (.not.allocated(this%mfr)) then + allocate(this%mfr(this%nbc)) + else + if (size(this%mfr).ne.this%nbc) then + deallocate(this%mfr); allocate(this%mfr(this%nbc)) + end if + end if + + ! Ensure this%area is of proper size + if (.not.allocated(this%area)) then + allocate(this%area(this%nbc)) + else + if (size(this%area).ne.this%nbc) then + deallocate(this%area); allocate(this%area(this%nbc)) + end if + end if + + ! Allocate temp array for communication + allocate(my_mfr(this%nbc)) + allocate(my_area(this%nbc)) + allocate(canCorrect(this%nbc)) + + ! Traverse bcond list and integrate local outgoing MFR + my_bc=>this%first_bc; ibc=1 + do while (associated(my_bc)) + + ! Set zero local MFR and area + my_mfr(ibc)=0.0_WP + my_area(ibc)=0.0_WP + if (my_bc%canCorrect) then + canCorrect(ibc)=1.0_WP + else + canCorrect(ibc)=0.0_WP + end if + + ! Only processes inside the bcond have a non-zero MFR + if (my_bc%itr%amIn) then + + ! Implement based on bcond face and dir, loop over interior only + select case (my_bc%face) + case ('x') + do n=1,my_bc%itr%n_ + i=my_bc%itr%map(1,n); j=my_bc%itr%map(2,n); k=my_bc%itr%map(3,n) + my_mfr(ibc)=my_mfr(ibc)+my_bc%rdir*this%rho*this%U(i,j,k)*this%cfg%dy(j)*this%cfg%dz(k) + my_area(ibc)=my_area(ibc)+this%cfg%dy(j)*this%cfg%dz(k) + end do + case ('y') + do n=1,my_bc%itr%n_ + i=my_bc%itr%map(1,n); j=my_bc%itr%map(2,n); k=my_bc%itr%map(3,n) + my_mfr(ibc)=my_mfr(ibc)+my_bc%rdir*this%rho*this%V(i,j,k)*this%cfg%dz(k)*this%cfg%dx(i) + my_area(ibc)=my_area(ibc)+this%cfg%dz(k)*this%cfg%dx(i) + end do + case ('z') + do n=1,my_bc%itr%n_ + i=my_bc%itr%map(1,n); j=my_bc%itr%map(2,n); k=my_bc%itr%map(3,n) + my_mfr(ibc)=my_mfr(ibc)+my_bc%rdir*this%rho*this%W(i,j,k)*this%cfg%dx(i)*this%cfg%dy(j) + my_area(ibc)=my_area(ibc)+this%cfg%dx(i)*this%cfg%dy(j) + end do + end select + + end if + + ! Move on to the next bcond + my_bc=>my_bc%next; ibc=ibc+1 + + end do + + ! Sum up all values + call MPI_ALLREDUCE(my_mfr ,this%mfr ,this%nbc,MPI_REAL_WP,MPI_SUM,this%cfg%comm,ierr) + call MPI_ALLREDUCE(my_area,this%area,this%nbc,MPI_REAL_WP,MPI_SUM,this%cfg%comm,ierr) + + ! Compute the correctable area + this%correctable_area=sum(this%area*canCorrect) + + ! Deallocate temp array + deallocate(my_mfr,my_area,canCorrect) + + end subroutine get_mfr + + + !> Correct MFR through correctable bconds + subroutine correct_mfr(this,src) + use mpi_f08, only: MPI_SUM + implicit none + class(incomp), intent(inout) :: this + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), optional :: src !< Mass source term + real(WP) :: mfr_error,vel_correction,int + integer :: i,j,k,n + type(bcond), pointer :: my_bc + + ! Evaluate MFR mismatch and velocity correction + call this%get_mfr() + mfr_error=sum(this%mfr) + if (present(src)) then + ! Also account for provided source term + call this%cfg%integrate_without_VF(src,int) + mfr_error=mfr_error-int + end if + if (abs(mfr_error).lt.10.0_WP*epsilon(1.0_WP).or.abs(this%correctable_area).lt.10.0_WP*epsilon(1.0_WP)) return + vel_correction=-mfr_error/(this%rho*this%correctable_area) + + ! Traverse bcond list and correct bcond MFR + my_bc=>this%first_bc + do while (associated(my_bc)) + + ! Only processes inside correctable bcond need to work + if (my_bc%itr%amIn.and.my_bc%canCorrect) then + + ! Implement based on bcond direction, loop over all cell + select case (my_bc%face) + case ('x') + do n=1,my_bc%itr%n_ + i=my_bc%itr%map(1,n); j=my_bc%itr%map(2,n); k=my_bc%itr%map(3,n) + this%U(i,j,k)=this%U(i,j,k)+my_bc%rdir*vel_correction + end do + case ('y') + do n=1,my_bc%itr%n_ + i=my_bc%itr%map(1,n); j=my_bc%itr%map(2,n); k=my_bc%itr%map(3,n) + this%V(i,j,k)=this%V(i,j,k)+my_bc%rdir*vel_correction + end do + case ('z') + do n=1,my_bc%itr%n_ + i=my_bc%itr%map(1,n); j=my_bc%itr%map(2,n); k=my_bc%itr%map(3,n) + this%W(i,j,k)=this%W(i,j,k)+my_bc%rdir*vel_correction + end do + end select + + end if + + ! Move on to the next bcond + my_bc=>my_bc%next + + end do + + ! Sync full fields + call this%cfg%sync(this%U) + call this%cfg%sync(this%V) + call this%cfg%sync(this%W) + + end subroutine correct_mfr + + + !> Shift pressure to ensure zero average + subroutine shift_p(this,pressure) + implicit none + class(incomp), intent(in) :: this + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(inout) :: pressure !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + real(WP) :: pressure_tot + integer :: i,j,k + + ! Compute volume-averaged pressure + call this%cfg%integrate(A=pressure,integral=pressure_tot); pressure_tot=pressure_tot/this%cfg%fluid_vol + + ! Shift the pressure + do k=this%cfg%kmin_,this%cfg%kmax_ + do j=this%cfg%jmin_,this%cfg%jmax_ + do i=this%cfg%imin_,this%cfg%imax_ + if (this%cfg%VF(i,j,k).gt.0.0_WP) pressure(i,j,k)=pressure(i,j,k)-pressure_tot + end do + end do + end do + call this%cfg%sync(pressure) + + end subroutine shift_p + + + !> Solve for implicit velocity residual + subroutine solve_implicit(this,dt,resU,resV,resW) + implicit none + class(incomp), intent(inout) :: this + real(WP), intent(in) :: dt + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(inout) :: resU !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(inout) :: resV !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(inout) :: resW !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + integer :: i,j,k + real(WP) :: rhoUp,rhoUm,rhoVp,rhoVm,rhoWp,rhoWm + + ! If no implicit solver available, just divide by density and return + if (.not.associated(this%implicit)) then + resU=resU/this%rho + resV=resV/this%rho + resW=resW/this%rho + call this%cfg%sync(resU) + call this%cfg%sync(resV) + call this%cfg%sync(resW) + return + end if + + ! Solve implicit U problem + this%implicit%opr(1,:,:,:)=this%rho; this%implicit%opr(2:,:,:,:)=0.0_WP + do k=this%cfg%kmin_,this%cfg%kmax_ + do j=this%cfg%jmin_,this%cfg%jmax_ + do i=this%cfg%imin_,this%cfg%imax_ + rhoUp=this%rho*sum(this%itpu_x(:,i ,j,k)*this%U(i :i+1,j,k))*2.0_WP + rhoUm=this%rho*sum(this%itpu_x(:,i-1,j,k)*this%U(i-1:i ,j,k))*2.0_WP + rhoVp=this%rho*sum(this%itpv_x(:,i,j+1,k)*this%V(i-1:i,j+1,k)) + rhoVm=this%rho*sum(this%itpv_x(:,i,j ,k)*this%V(i-1:i,j ,k)) + rhoWp=this%rho*sum(this%itpw_x(:,i,j,k+1)*this%W(i-1:i,j,k+1)) + rhoWm=this%rho*sum(this%itpw_x(:,i,j,k )*this%W(i-1:i,j,k )) + this%implicit%opr(1,i,j,k)=this%implicit%opr(1,i,j,k)+0.5_WP*dt*(this%divu_x( 0,i,j,k)*this%itpu_x( 0,i ,j,k)*rhoUp+& + & this%divu_x(-1,i,j,k)*this%itpu_x(+1,i-1,j,k)*rhoUm+& + & this%divu_y(+1,i,j,k)*this%itpu_y(-1,i,j+1,k)*rhoVp+& + & this%divu_y( 0,i,j,k)*this%itpu_y( 0,i,j ,k)*rhoVm+& + & this%divu_z(+1,i,j,k)*this%itpu_z(-1,i,j,k+1)*rhoWp+& + & this%divu_z( 0,i,j,k)*this%itpu_z( 0,i,j,k )*rhoWm) + this%implicit%opr(2,i,j,k)=this%implicit%opr(2,i,j,k)+0.5_WP*dt*(this%divu_x( 0,i,j,k)*this%itpu_x(+1,i ,j,k)*rhoUp) + this%implicit%opr(3,i,j,k)=this%implicit%opr(3,i,j,k)+0.5_WP*dt*(this%divu_x(-1,i,j,k)*this%itpu_x( 0,i-1,j,k)*rhoUm) + this%implicit%opr(4,i,j,k)=this%implicit%opr(4,i,j,k)+0.5_WP*dt*(this%divu_y(+1,i,j,k)*this%itpu_y( 0,i,j+1,k)*rhoVp) + this%implicit%opr(5,i,j,k)=this%implicit%opr(5,i,j,k)+0.5_WP*dt*(this%divu_y( 0,i,j,k)*this%itpu_y(-1,i,j ,k)*rhoVm) + this%implicit%opr(6,i,j,k)=this%implicit%opr(6,i,j,k)+0.5_WP*dt*(this%divu_z(+1,i,j,k)*this%itpu_z( 0,i,j,k+1)*rhoWp) + this%implicit%opr(7,i,j,k)=this%implicit%opr(7,i,j,k)+0.5_WP*dt*(this%divu_z( 0,i,j,k)*this%itpu_z(-1,i,j,k )*rhoWm) + end do + end do + end do + do k=this%cfg%kmin_,this%cfg%kmax_ + do j=this%cfg%jmin_,this%cfg%jmax_ + do i=this%cfg%imin_,this%cfg%imax_ + this%implicit%opr(1,i,j,k)=this%implicit%opr(1,i,j,k)-0.5_WP*dt*(this%divu_x( 0,i,j,k)*4.0_WP/3.0_WP* this%visc(i ,j,k) *this%grdu_x( 0,i ,j,k)+& + & this%divu_x(-1,i,j,k)*4.0_WP/3.0_WP* this%visc(i-1,j,k) *this%grdu_x(+1,i-1,j,k)+& + & this%divu_y(+1,i,j,k)*sum(this%itp_xy(:,:,i,j+1,k)*this%visc(i-1:i,j:j+1,k))*this%grdu_y(-1,i,j+1,k)+& + & this%divu_y( 0,i,j,k)*sum(this%itp_xy(:,:,i,j ,k)*this%visc(i-1:i,j-1:j,k))*this%grdu_y( 0,i,j ,k)+& + & this%divu_z(+1,i,j,k)*sum(this%itp_xz(:,:,i,j,k+1)*this%visc(i-1:i,j,k:k+1))*this%grdu_z(-1,i,j,k+1)+& + & this%divu_z( 0,i,j,k)*sum(this%itp_xz(:,:,i,j,k )*this%visc(i-1:i,j,k-1:k))*this%grdu_z( 0,i,j,k )) + this%implicit%opr(2,i,j,k)=this%implicit%opr(2,i,j,k)-0.5_WP*dt*(this%divu_x( 0,i,j,k)*4.0_WP/3.0_WP* this%visc(i ,j,k) *this%grdu_x(+1,i ,j,k)) + this%implicit%opr(3,i,j,k)=this%implicit%opr(3,i,j,k)-0.5_WP*dt*(this%divu_x(-1,i,j,k)*4.0_WP/3.0_WP* this%visc(i-1,j,k) *this%grdu_x( 0,i-1,j,k)) + this%implicit%opr(4,i,j,k)=this%implicit%opr(4,i,j,k)-0.5_WP*dt*(this%divu_y(+1,i,j,k)*sum(this%itp_xy(:,:,i,j+1,k)*this%visc(i-1:i,j:j+1,k))*this%grdu_y( 0,i,j+1,k)) + this%implicit%opr(5,i,j,k)=this%implicit%opr(5,i,j,k)-0.5_WP*dt*(this%divu_y( 0,i,j,k)*sum(this%itp_xy(:,:,i,j ,k)*this%visc(i-1:i,j-1:j,k))*this%grdu_y(-1,i,j ,k)) + this%implicit%opr(6,i,j,k)=this%implicit%opr(6,i,j,k)-0.5_WP*dt*(this%divu_z(+1,i,j,k)*sum(this%itp_xz(:,:,i,j,k+1)*this%visc(i-1:i,j,k:k+1))*this%grdu_z( 0,i,j,k+1)) + this%implicit%opr(7,i,j,k)=this%implicit%opr(7,i,j,k)-0.5_WP*dt*(this%divu_z( 0,i,j,k)*sum(this%itp_xz(:,:,i,j,k )*this%visc(i-1:i,j,k-1:k))*this%grdu_z(-1,i,j,k )) + end do + end do + end do + call this%implicit%setup() + this%implicit%rhs=resU + this%implicit%sol=0.0_WP + call this%implicit%solve() + resU=this%implicit%sol + + ! Solve implicit V problem + this%implicit%opr(1,:,:,:)=this%rho; this%implicit%opr(2:,:,:,:)=0.0_WP + do k=this%cfg%kmin_,this%cfg%kmax_ + do j=this%cfg%jmin_,this%cfg%jmax_ + do i=this%cfg%imin_,this%cfg%imax_ + rhoUp=this%rho*sum(this%itpu_y(:,i+1,j,k)*this%U(i+1,j-1:j,k)) + rhoUm=this%rho*sum(this%itpu_y(:,i ,j,k)*this%U(i ,j-1:j,k)) + rhoVp=this%rho*sum(this%itpv_y(:,i,j ,k)*this%V(i,j :j+1,k))*2.0_WP + rhoVm=this%rho*sum(this%itpv_y(:,i,j-1,k)*this%V(i,j-1:j ,k))*2.0_WP + rhoWp=this%rho*sum(this%itpw_y(:,i,j,k+1)*this%W(i,j-1:j,k+1)) + rhoWm=this%rho*sum(this%itpw_y(:,i,j,k )*this%W(i,j-1:j,k )) + this%implicit%opr(1,i,j,k)=this%implicit%opr(1,i,j,k)+0.5_WP*dt*(this%divv_x(+1,i,j,k)*this%itpv_x(-1,i+1,j,k)*rhoUp+& + & this%divv_x( 0,i,j,k)*this%itpv_x( 0,i ,j,k)*rhoUm+& + & this%divv_y( 0,i,j,k)*this%itpv_y( 0,i,j ,k)*rhoVp+& + & this%divv_y(-1,i,j,k)*this%itpv_y(+1,i,j-1,k)*rhoVm+& + & this%divv_z(+1,i,j,k)*this%itpv_z(-1,i,j,k+1)*rhoWp+& + & this%divv_z( 0,i,j,k)*this%itpv_z( 0,i,j,k )*rhoWm) + this%implicit%opr(2,i,j,k)=this%implicit%opr(2,i,j,k)+0.5_WP*dt*(this%divv_x(+1,i,j,k)*this%itpv_x( 0,i+1,j,k)*rhoUp) + this%implicit%opr(3,i,j,k)=this%implicit%opr(3,i,j,k)+0.5_WP*dt*(this%divv_x( 0,i,j,k)*this%itpv_x(-1,i ,j,k)*rhoUm) + this%implicit%opr(4,i,j,k)=this%implicit%opr(4,i,j,k)+0.5_WP*dt*(this%divv_y( 0,i,j,k)*this%itpv_y(+1,i,j ,k)*rhoVp) + this%implicit%opr(5,i,j,k)=this%implicit%opr(5,i,j,k)+0.5_WP*dt*(this%divv_y(-1,i,j,k)*this%itpv_y( 0,i,j-1,k)*rhoVm) + this%implicit%opr(6,i,j,k)=this%implicit%opr(6,i,j,k)+0.5_WP*dt*(this%divv_z(+1,i,j,k)*this%itpv_z( 0,i,j,k+1)*rhoWp) + this%implicit%opr(7,i,j,k)=this%implicit%opr(7,i,j,k)+0.5_WP*dt*(this%divv_z( 0,i,j,k)*this%itpv_z(-1,i,j,k )*rhoWm) + end do + end do + end do + do k=this%cfg%kmin_,this%cfg%kmax_ + do j=this%cfg%jmin_,this%cfg%jmax_ + do i=this%cfg%imin_,this%cfg%imax_ + this%implicit%opr(1,i,j,k)=this%implicit%opr(1,i,j,k)-0.5_WP*dt*(this%divv_x(+1,i,j,k)*sum(this%itp_xy(:,:,i+1,j,k)*this%visc(i:i+1,j-1:j,k))*this%grdv_x(-1,i+1,j,k)+& + & this%divv_x( 0,i,j,k)*sum(this%itp_xy(:,:,i ,j,k)*this%visc(i-1:i,j-1:j,k))*this%grdv_x( 0,i ,j,k)+& + & this%divv_y( 0,i,j,k)*4.0_WP/3.0_WP* this%visc(i,j ,k) *this%grdv_y( 0,i,j ,k)+& + & this%divv_y(-1,i,j,k)*4.0_WP/3.0_WP* this%visc(i,j-1,k) *this%grdv_y(+1,i,j-1,k)+& + & this%divv_z(+1,i,j,k)*sum(this%itp_yz(:,:,i,j,k+1)*this%visc(i,j-1:j,k:k+1))*this%grdv_z(-1,i,j,k+1)+& + & this%divv_z( 0,i,j,k)*sum(this%itp_yz(:,:,i,j,k )*this%visc(i,j-1:j,k-1:k))*this%grdv_z( 0,i,j,k )) + this%implicit%opr(2,i,j,k)=this%implicit%opr(2,i,j,k)-0.5_WP*dt*(this%divv_x(+1,i,j,k)*sum(this%itp_xy(:,:,i+1,j,k)*this%visc(i:i+1,j-1:j,k))*this%grdv_x( 0,i+1,j,k)) + this%implicit%opr(3,i,j,k)=this%implicit%opr(3,i,j,k)-0.5_WP*dt*(this%divv_x( 0,i,j,k)*sum(this%itp_xy(:,:,i ,j,k)*this%visc(i-1:i,j-1:j,k))*this%grdv_x(-1,i ,j,k)) + this%implicit%opr(4,i,j,k)=this%implicit%opr(4,i,j,k)-0.5_WP*dt*(this%divv_y( 0,i,j,k)*4.0_WP/3.0_WP* this%visc(i,j ,k) *this%grdv_y(+1,i,j ,k)) + this%implicit%opr(5,i,j,k)=this%implicit%opr(5,i,j,k)-0.5_WP*dt*(this%divv_y(-1,i,j,k)*4.0_WP/3.0_WP* this%visc(i,j-1,k) *this%grdv_y( 0,i,j-1,k)) + this%implicit%opr(6,i,j,k)=this%implicit%opr(6,i,j,k)-0.5_WP*dt*(this%divv_z(+1,i,j,k)*sum(this%itp_yz(:,:,i,j,k+1)*this%visc(i,j-1:j,k:k+1))*this%grdv_z( 0,i,j,k+1)) + this%implicit%opr(7,i,j,k)=this%implicit%opr(7,i,j,k)-0.5_WP*dt*(this%divv_z( 0,i,j,k)*sum(this%itp_yz(:,:,i,j,k )*this%visc(i,j-1:j,k-1:k))*this%grdv_z(-1,i,j,k )) + end do + end do + end do + call this%implicit%setup() + this%implicit%rhs=resV + this%implicit%sol=0.0_WP + call this%implicit%solve() + resV=this%implicit%sol + + ! Solve implicit W problem + this%implicit%opr(1,:,:,:)=this%rho; this%implicit%opr(2:,:,:,:)=0.0_WP + do k=this%cfg%kmin_,this%cfg%kmax_ + do j=this%cfg%jmin_,this%cfg%jmax_ + do i=this%cfg%imin_,this%cfg%imax_ + rhoUp=this%rho*sum(this%itpu_z(:,i+1,j,k)*this%U(i+1,j,k-1:k)) + rhoUm=this%rho*sum(this%itpu_z(:,i ,j,k)*this%U(i ,j,k-1:k)) + rhoVp=this%rho*sum(this%itpv_z(:,i,j+1,k)*this%V(i,j+1,k-1:k)) + rhoVm=this%rho*sum(this%itpv_z(:,i,j ,k)*this%V(i,j ,k-1:k)) + rhoWp=this%rho*sum(this%itpw_z(:,i,j,k )*this%W(i,j,k :k+1))*2.0_WP + rhoWm=this%rho*sum(this%itpw_z(:,i,j,k-1)*this%W(i,j,k-1:k ))*2.0_WP + this%implicit%opr(1,i,j,k)=this%implicit%opr(1,i,j,k)+0.5_WP*dt*(this%divw_x(+1,i,j,k)*this%itpw_x(-1,i+1,j,k)*rhoUp+& + & this%divw_x( 0,i,j,k)*this%itpw_x( 0,i ,j,k)*rhoUm+& + & this%divw_y(+1,i,j,k)*this%itpw_y(-1,i,j+1,k)*rhoVp+& + & this%divw_y( 0,i,j,k)*this%itpw_y( 0,i,j ,k)*rhoVm+& + & this%divw_z( 0,i,j,k)*this%itpw_z( 0,i,j,k )*rhoWp+& + & this%divw_z(-1,i,j,k)*this%itpw_z(+1,i,j,k-1)*rhoWm) + this%implicit%opr(2,i,j,k)=this%implicit%opr(2,i,j,k)+0.5_WP*dt*(this%divw_x(+1,i,j,k)*this%itpw_x( 0,i+1,j,k)*rhoUp) + this%implicit%opr(3,i,j,k)=this%implicit%opr(3,i,j,k)+0.5_WP*dt*(this%divw_x( 0,i,j,k)*this%itpw_x(-1,i ,j,k)*rhoUm) + this%implicit%opr(4,i,j,k)=this%implicit%opr(4,i,j,k)+0.5_WP*dt*(this%divw_y(+1,i,j,k)*this%itpw_y( 0,i,j+1,k)*rhoVp) + this%implicit%opr(5,i,j,k)=this%implicit%opr(5,i,j,k)+0.5_WP*dt*(this%divw_y( 0,i,j,k)*this%itpw_y(-1,i,j ,k)*rhoVm) + this%implicit%opr(6,i,j,k)=this%implicit%opr(6,i,j,k)+0.5_WP*dt*(this%divw_z( 0,i,j,k)*this%itpw_z(+1,i,j,k )*rhoWp) + this%implicit%opr(7,i,j,k)=this%implicit%opr(7,i,j,k)+0.5_WP*dt*(this%divw_z(-1,i,j,k)*this%itpw_z( 0,i,j,k-1)*rhoWm) + end do + end do + end do + do k=this%cfg%kmin_,this%cfg%kmax_ + do j=this%cfg%jmin_,this%cfg%jmax_ + do i=this%cfg%imin_,this%cfg%imax_ + this%implicit%opr(1,i,j,k)=this%implicit%opr(1,i,j,k)-0.5_WP*dt*(this%divw_x(+1,i,j,k)*sum(this%itp_xz(:,:,i+1,j,k)*this%visc(i:i+1,j,k-1:k))*this%grdw_x(-1,i+1,j,k)+& + & this%divw_x( 0,i,j,k)*sum(this%itp_xz(:,:,i ,j,k)*this%visc(i-1:i,j,k-1:k))*this%grdw_x( 0,i ,j,k)+& + & this%divw_y(+1,i,j,k)*sum(this%itp_yz(:,:,i,j+1,k)*this%visc(i,j:j+1,k-1:k))*this%grdw_y(-1,i,j+1,k)+& + & this%divw_y( 0,i,j,k)*sum(this%itp_yz(:,:,i,j ,k)*this%visc(i,j-1:j,k-1:k))*this%grdw_y( 0,i,j ,k)+& + & this%divw_z( 0,i,j,k)*4.0_WP/3.0_WP* this%visc(i,j,k ) *this%grdw_z( 0,i,j,k )+& + & this%divw_z(-1,i,j,k)*4.0_WP/3.0_WP* this%visc(i,j,k-1) *this%grdw_z(+1,i,j,k-1)) + this%implicit%opr(2,i,j,k)=this%implicit%opr(2,i,j,k)-0.5_WP*dt*(this%divw_x(+1,i,j,k)*sum(this%itp_xz(:,:,i+1,j,k)*this%visc(i:i+1,j,k-1:k))*this%grdw_x( 0,i+1,j,k)) + this%implicit%opr(3,i,j,k)=this%implicit%opr(3,i,j,k)-0.5_WP*dt*(this%divw_x( 0,i,j,k)*sum(this%itp_xz(:,:,i ,j,k)*this%visc(i-1:i,j,k-1:k))*this%grdw_x(-1,i ,j,k)) + this%implicit%opr(4,i,j,k)=this%implicit%opr(4,i,j,k)-0.5_WP*dt*(this%divw_y(+1,i,j,k)*sum(this%itp_yz(:,:,i,j+1,k)*this%visc(i,j:j+1,k-1:k))*this%grdw_y( 0,i,j+1,k)) + this%implicit%opr(5,i,j,k)=this%implicit%opr(5,i,j,k)-0.5_WP*dt*(this%divw_y( 0,i,j,k)*sum(this%itp_yz(:,:,i,j ,k)*this%visc(i,j-1:j,k-1:k))*this%grdw_y(-1,i,j ,k)) + this%implicit%opr(6,i,j,k)=this%implicit%opr(6,i,j,k)-0.5_WP*dt*(this%divw_z( 0,i,j,k)*4.0_WP/3.0_WP* this%visc(i,j,k ) *this%grdw_z(+1,i,j,k )) + this%implicit%opr(7,i,j,k)=this%implicit%opr(7,i,j,k)-0.5_WP*dt*(this%divw_z(-1,i,j,k)*4.0_WP/3.0_WP* this%visc(i,j,k-1) *this%grdw_z( 0,i,j,k-1)) + end do + end do + end do + call this%implicit%setup() + this%implicit%rhs=resW + this%implicit%sol=0.0_WP + call this%implicit%solve() + resW=this%implicit%sol + + end subroutine solve_implicit + + + !> Add gravity source term + subroutine addsrc_gravity(this,resU,resV,resW) + implicit none + class(incomp), intent(inout) :: this + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(inout) :: resU !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(inout) :: resV !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(inout) :: resW !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + integer :: i,j,k + do k=this%cfg%kmin_,this%cfg%kmax_ + do j=this%cfg%jmin_,this%cfg%jmax_ + do i=this%cfg%imin_,this%cfg%imax_ + if (this%umask(i,j,k).eq.0) resU(i,j,k)=resU(i,j,k)+this%rho*this%gravity(1) + if (this%vmask(i,j,k).eq.0) resV(i,j,k)=resV(i,j,k)+this%rho*this%gravity(2) + if (this%wmask(i,j,k).eq.0) resW(i,j,k)=resW(i,j,k)+this%rho*this%gravity(3) + end do + end do + end do + end subroutine addsrc_gravity + + + !> Print out info for incompressible flow solver + subroutine incomp_print(this) + use, intrinsic :: iso_fortran_env, only: output_unit + implicit none + class(incomp), intent(in) :: this + + ! Output + if (this%cfg%amRoot) then + write(output_unit,'("Incompressible solver [",a,"] for config [",a,"]")') trim(this%name),trim(this%cfg%name) + write(output_unit,'(" > density = ",es12.5)') this%rho + end if + + end subroutine incomp_print + + +end module incomp_class diff --git a/examples/NOSB_cylinder_peridigm/src/incomp_class_old.f90 b/examples/NOSB_cylinder_peridigm/src/incomp_class_old.f90 new file mode 100644 index 000000000..c8e6f79b7 --- /dev/null +++ b/examples/NOSB_cylinder_peridigm/src/incomp_class_old.f90 @@ -0,0 +1,2128 @@ +!> Incompressible flow solver class: +!> Provides support for various BC, RHS calculation, +!> implicit solver, and pressure solution +!> Assumes constant viscosity and density. +module incomp_class + use precision, only: WP + use string, only: str_medium + use config_class, only: config + use linsol_class, only: linsol + use iterator_class, only: iterator + implicit none + private + + ! Expose type/constructor/methods + public :: incomp,bcond + + ! List of known available bcond types for this solver + integer, parameter, public :: wall=1 !< Dirichlet at zero condition + integer, parameter, public :: dirichlet=2 !< Dirichlet condition + integer, parameter, public :: neumann=3 !< Zero normal gradient + integer, parameter, public :: convective=4 !< Convective outflow condition + integer, parameter, public :: clipped_neumann=5 !< Clipped Neumann condition (outflow only) + integer, parameter, public :: slip=6 !< Free-slip condition + + !> Boundary conditions for the incompressible solver + type :: bcond + type(bcond), pointer :: next !< Linked list of bconds + character(len=str_medium) :: name='UNNAMED_BCOND' !< Bcond name (default=UNNAMED_BCOND) + integer :: type !< Bcond type + type(iterator) :: itr !< This is the iterator for the bcond - this identifies the (i,j,k) + character(len=1) :: face !< Bcond face (x/y/z) + integer :: dir !< Bcond direction (+1,-1,0 for interior) + real(WP) :: rdir !< Bcond direction (real variable) + logical :: canCorrect !< Can this bcond be corrected for global conservation? + end type bcond + + !> Incompressible solver object definition + type :: incomp + + ! This is our config + class(config), pointer :: cfg !< This is the config the solver is build for + + ! This is the name of the solver + character(len=str_medium) :: name='UNNAMED_INCOMP' !< Solver name (default=UNNAMED_INCOMP) + + ! Constant property fluid + real(WP) :: rho !< This is our constant fluid density + real(WP), dimension(:,:,:), allocatable :: visc !< These is our constant+SGS dynamic viscosity + + ! Gravitational acceleration + real(WP), dimension(3) :: gravity=0.0_WP !< Acceleration of gravity + + ! Boundary condition list + integer :: nbc !< Number of bcond for our solver + real(WP), dimension(:), allocatable :: mfr !< MFR through each bcond + real(WP), dimension(:), allocatable :: area !< Area for each bcond + real(WP) :: correctable_area !< Area of bcond that can be corrected + type(bcond), pointer :: first_bc !< List of bcond for our solver + + ! Flow variables + real(WP), dimension(:,:,:), allocatable :: U !< U velocity array + real(WP), dimension(:,:,:), allocatable :: V !< V velocity array + real(WP), dimension(:,:,:), allocatable :: W !< W velocity array + real(WP), dimension(:,:,:), allocatable :: P !< Pressure array + + ! Old flow variables + real(WP), dimension(:,:,:), allocatable :: Uold !< Uold velocity array + real(WP), dimension(:,:,:), allocatable :: Vold !< Vold velocity array + real(WP), dimension(:,:,:), allocatable :: Wold !< Wold velocity array + + ! Flow divergence + real(WP), dimension(:,:,:), allocatable :: div !< Divergence array + + ! Pressure solver + class(linsol), pointer :: psolv !< Iterative linear solver object for the pressure Poisson equation + + ! Implicit velocity solver + class(linsol), pointer :: implicit !< Iterative linear solver object for an implicit prediction of the NS residual + + ! Metrics + real(WP), dimension(:,:,:,:,:), allocatable :: itp_xy,itp_yz,itp_xz !< Interpolation for viscosity + real(WP), dimension(:,:,:,:), allocatable :: itpr_x,itpr_y,itpr_z !< Interpolation for density + real(WP), dimension(:,:,:,:), allocatable :: itpu_x,itpu_y,itpu_z !< Interpolation for U + real(WP), dimension(:,:,:,:), allocatable :: itpv_x,itpv_y,itpv_z !< Interpolation for V + real(WP), dimension(:,:,:,:), allocatable :: itpw_x,itpw_y,itpw_z !< Interpolation for W + real(WP), dimension(:,:,:,:), allocatable :: divp_x,divp_y,divp_z !< Divergence for P-cell + real(WP), dimension(:,:,:,:), allocatable :: divu_x,divu_y,divu_z !< Divergence for U-cell + real(WP), dimension(:,:,:,:), allocatable :: divv_x,divv_y,divv_z !< Divergence for V-cell + real(WP), dimension(:,:,:,:), allocatable :: divw_x,divw_y,divw_z !< Divergence for W-cell + real(WP), dimension(:,:,:,:), allocatable :: grdu_x,grdu_y,grdu_z !< Velocity gradient for U + real(WP), dimension(:,:,:,:), allocatable :: grdv_x,grdv_y,grdv_z !< Velocity gradient for V + real(WP), dimension(:,:,:,:), allocatable :: grdw_x,grdw_y,grdw_z !< Velocity gradient for W + + ! Masking info for metric modification + integer, dimension(:,:,:), allocatable :: mask !< Integer array used for modifying P metrics + integer, dimension(:,:,:), allocatable :: umask !< Integer array used for modifying U metrics + integer, dimension(:,:,:), allocatable :: vmask !< Integer array used for modifying V metrics + integer, dimension(:,:,:), allocatable :: wmask !< Integer array used for modifying W metrics + + ! CFL numbers + real(WP) :: CFLc_x,CFLc_y,CFLc_z !< Convective CFL numbers + real(WP) :: CFLv_x,CFLv_y,CFLv_z !< Viscous CFL numbers + + ! Monitoring quantities + real(WP) :: Umax,Vmax,Wmax,Pmax,divmax !< Maximum velocity, pressure, divergence + + contains + procedure :: print=>incomp_print !< Output solver to the screen + procedure :: setup !< Finish configuring the flow solver + procedure :: add_bcond !< Add a boundary condition + procedure :: get_bcond !< Get a boundary condition + procedure :: apply_bcond !< Apply all boundary conditions + procedure :: init_metrics !< Initialize metrics + procedure :: adjust_metrics !< Adjust metrics + procedure :: get_dmomdt !< Calculate dmom/dt + procedure :: get_div !< Calculate velocity divergence + procedure :: get_div_stress !< Calculate divergence of stresses for LPT solver + procedure :: get_pgrad !< Calculate pressure gradient + procedure :: get_cfl !< Calculate maximum CFL + procedure :: get_max !< Calculate maximum field values + procedure :: interp_vel !< Calculate interpolated velocity + procedure :: get_strainrate !< Calculate deviatoric part of strain rate tensor + procedure :: get_gradu !< Calculate velocity gradient tensor + procedure :: get_vorticity !< Calculate vorticity tensor + procedure :: get_mfr !< Calculate outgoing MFR through each bcond + procedure :: correct_mfr !< Correct for mfr mismatch to ensure global conservation + procedure :: shift_p !< Shift pressure to have zero average + procedure :: solve_implicit !< Solve for the velocity residuals implicitly + procedure :: addsrc_gravity !< Gravitational body force + end type incomp + + + !> Declare incompressible solver constructor + interface incomp + procedure constructor + end interface incomp + +contains + + + !> Default constructor for incompressible flow solver + function constructor(cfg,name) result(self) + implicit none + type(incomp) :: self + class(config), target, intent(in) :: cfg + character(len=*), optional :: name + integer :: i,j,k + + ! Set the name for the solver + if (present(name)) self%name=trim(adjustl(name)) + + ! Point to pgrid object + self%cfg=>cfg + + ! Nullify bcond list + self%nbc=0 + self%first_bc=>NULL() + + ! Allocate flow variables + allocate(self%U(self%cfg%imino_:self%cfg%imaxo_,self%cfg%jmino_:self%cfg%jmaxo_,self%cfg%kmino_:self%cfg%kmaxo_)); self%U=0.0_WP + allocate(self%V(self%cfg%imino_:self%cfg%imaxo_,self%cfg%jmino_:self%cfg%jmaxo_,self%cfg%kmino_:self%cfg%kmaxo_)); self%V=0.0_WP + allocate(self%W(self%cfg%imino_:self%cfg%imaxo_,self%cfg%jmino_:self%cfg%jmaxo_,self%cfg%kmino_:self%cfg%kmaxo_)); self%W=0.0_WP + allocate(self%P(self%cfg%imino_:self%cfg%imaxo_,self%cfg%jmino_:self%cfg%jmaxo_,self%cfg%kmino_:self%cfg%kmaxo_)); self%P=0.0_WP + + ! Allocate flow divergence + allocate(self%div(self%cfg%imino_:self%cfg%imaxo_,self%cfg%jmino_:self%cfg%jmaxo_,self%cfg%kmino_:self%cfg%kmaxo_)); self%div=0.0_WP + + ! Allocate fluid viscosity + allocate(self%visc(self%cfg%imino_:self%cfg%imaxo_,self%cfg%jmino_:self%cfg%jmaxo_,self%cfg%kmino_:self%cfg%kmaxo_)); self%visc=0.0_WP + + ! Allocate old flow variables + allocate(self%Uold(self%cfg%imino_:self%cfg%imaxo_,self%cfg%jmino_:self%cfg%jmaxo_,self%cfg%kmino_:self%cfg%kmaxo_)); self%Uold=0.0_WP + allocate(self%Vold(self%cfg%imino_:self%cfg%imaxo_,self%cfg%jmino_:self%cfg%jmaxo_,self%cfg%kmino_:self%cfg%kmaxo_)); self%Vold=0.0_WP + allocate(self%Wold(self%cfg%imino_:self%cfg%imaxo_,self%cfg%jmino_:self%cfg%jmaxo_,self%cfg%kmino_:self%cfg%kmaxo_)); self%Wold=0.0_WP + + ! Prepare default metrics + call self%init_metrics() + + ! Prepare P-cell masks + allocate(self%mask(self%cfg%imino_:self%cfg%imaxo_,self%cfg%jmino_:self%cfg%jmaxo_,self%cfg%kmino_:self%cfg%kmaxo_)); self%mask=0 + if (.not.self%cfg%xper) then + if (self%cfg%iproc.eq. 1) self%mask(:self%cfg%imin-1,:,:)=2 + if (self%cfg%iproc.eq.self%cfg%npx) self%mask(self%cfg%imax+1:,:,:)=2 + end if + if (.not.self%cfg%yper) then + if (self%cfg%jproc.eq. 1) self%mask(:,:self%cfg%jmin-1,:)=2 + if (self%cfg%jproc.eq.self%cfg%npy) self%mask(:,self%cfg%jmax+1:,:)=2 + end if + if (.not.self%cfg%zper) then + if (self%cfg%kproc.eq. 1) self%mask(:,:,:self%cfg%kmin-1)=2 + if (self%cfg%kproc.eq.self%cfg%npz) self%mask(:,:,self%cfg%kmax+1:)=2 + end if + do k=self%cfg%kmino_,self%cfg%kmaxo_ + do j=self%cfg%jmino_,self%cfg%jmaxo_ + do i=self%cfg%imino_,self%cfg%imaxo_ + if (self%cfg%VF(i,j,k).eq.0.0_WP) self%mask(i,j,k)=1 + end do + end do + end do + call self%cfg%sync(self%mask) + + ! Prepare face mask for U + allocate(self%umask(self%cfg%imino_:self%cfg%imaxo_,self%cfg%jmino_:self%cfg%jmaxo_,self%cfg%kmino_:self%cfg%kmaxo_)); self%umask=0 + if (.not.self%cfg%xper) then + if (self%cfg%iproc.eq. 1) self%umask(self%cfg%imin ,:,:)=2 + if (self%cfg%iproc.eq.self%cfg%npx) self%umask(self%cfg%imax+1,:,:)=2 + end if + do k=self%cfg%kmino_ ,self%cfg%kmaxo_ + do j=self%cfg%jmino_ ,self%cfg%jmaxo_ + do i=self%cfg%imino_+1,self%cfg%imaxo_ + if (minval(self%cfg%VF(i-1:i,j,k)).eq.0.0_WP) self%umask(i,j,k)=1 + end do + end do + end do + call self%cfg%sync(self%umask) + if (.not.self%cfg%xper.and.self%cfg%iproc.eq.1) self%umask(self%cfg%imino,:,:)=self%umask(self%cfg%imino+1,:,:) + + ! Prepare face mask for V + allocate(self%vmask(self%cfg%imino_:self%cfg%imaxo_,self%cfg%jmino_:self%cfg%jmaxo_,self%cfg%kmino_:self%cfg%kmaxo_)); self%vmask=0 + if (.not.self%cfg%yper) then + if (self%cfg%jproc.eq. 1) self%vmask(:,self%cfg%jmin ,:)=2 + if (self%cfg%jproc.eq.self%cfg%npy) self%vmask(:,self%cfg%jmax+1,:)=2 + end if + do k=self%cfg%kmino_ ,self%cfg%kmaxo_ + do j=self%cfg%jmino_+1,self%cfg%jmaxo_ + do i=self%cfg%imino_ ,self%cfg%imaxo_ + if (minval(self%cfg%VF(i,j-1:j,k)).eq.0.0_WP) self%vmask(i,j,k)=1 + end do + end do + end do + call self%cfg%sync(self%vmask) + if (.not.self%cfg%yper.and.self%cfg%jproc.eq.1) self%vmask(:,self%cfg%jmino,:)=self%vmask(:,self%cfg%jmino+1,:) + + ! Prepare face mask for W + allocate(self%wmask(self%cfg%imino_:self%cfg%imaxo_,self%cfg%jmino_:self%cfg%jmaxo_,self%cfg%kmino_:self%cfg%kmaxo_)); self%wmask=0 + if (.not.self%cfg%zper) then + if (self%cfg%kproc.eq. 1) self%wmask(:,:,self%cfg%kmin )=2 + if (self%cfg%kproc.eq.self%cfg%npz) self%wmask(:,:,self%cfg%kmax+1)=2 + end if + do k=self%cfg%kmino_+1,self%cfg%kmaxo_ + do j=self%cfg%jmino_ ,self%cfg%jmaxo_ + do i=self%cfg%imino_ ,self%cfg%imaxo_ + if (minval(self%cfg%VF(i,j,k-1:k)).eq.0.0_WP) self%wmask(i,j,k)=1 + end do + end do + end do + call self%cfg%sync(self%wmask) + if (.not.self%cfg%zper.and.self%cfg%kproc.eq.1) self%wmask(:,:,self%cfg%kmino)=self%wmask(:,:,self%cfg%kmino+1) + + end function constructor + + + !> Metric initialization with no awareness of walls nor bcond + subroutine init_metrics(this) + implicit none + class(incomp), intent(inout) :: this + integer :: i,j,k,st1,st2 + real(WP), dimension(-1:0) :: itpx,itpy,itpz + + ! Allocate finite difference density (or other things) interpolation coefficients + allocate(this%itpr_x(-1:0,this%cfg%imin_:this%cfg%imax_+1,this%cfg%jmin_:this%cfg%jmax_+1,this%cfg%kmin_:this%cfg%kmax_+1)) !< X-face-centered + allocate(this%itpr_y(-1:0,this%cfg%imin_:this%cfg%imax_+1,this%cfg%jmin_:this%cfg%jmax_+1,this%cfg%kmin_:this%cfg%kmax_+1)) !< Y-face-centered + allocate(this%itpr_z(-1:0,this%cfg%imin_:this%cfg%imax_+1,this%cfg%jmin_:this%cfg%jmax_+1,this%cfg%kmin_:this%cfg%kmax_+1)) !< Z-face-centered + ! Create density (or other things) interpolation coefficients to cell face + do k=this%cfg%kmin_,this%cfg%kmax_+1 + do j=this%cfg%jmin_,this%cfg%jmax_+1 + do i=this%cfg%imin_,this%cfg%imax_+1 + this%itpr_x(:,i,j,k)=this%cfg%dxmi(i)*[this%cfg%xm(i)-this%cfg%x(i),this%cfg%x(i)-this%cfg%xm(i-1)] !< Linear interpolation in x from [xm,ym,zm] to [x,ym,zm] + this%itpr_y(:,i,j,k)=this%cfg%dymi(j)*[this%cfg%ym(j)-this%cfg%y(j),this%cfg%y(j)-this%cfg%ym(j-1)] !< Linear interpolation in y from [xm,ym,zm] to [xm,y,zm] + this%itpr_z(:,i,j,k)=this%cfg%dzmi(k)*[this%cfg%zm(k)-this%cfg%z(k),this%cfg%z(k)-this%cfg%zm(k-1)] !< Linear interpolation in z from [xm,ym,zm] to [xm,ym,z] + end do + end do + end do + + ! Allocate finite difference viscosity interpolation coefficients + allocate(this%itp_xy(-1:0,-1:0,this%cfg%imino_+1:this%cfg%imaxo_,this%cfg%jmino_+1:this%cfg%jmaxo_,this%cfg%kmino_+1:this%cfg%kmaxo_)) !< Edge-centered (xy) + allocate(this%itp_yz(-1:0,-1:0,this%cfg%imino_+1:this%cfg%imaxo_,this%cfg%jmino_+1:this%cfg%jmaxo_,this%cfg%kmino_+1:this%cfg%kmaxo_)) !< Edge-centered (yz) + allocate(this%itp_xz(-1:0,-1:0,this%cfg%imino_+1:this%cfg%imaxo_,this%cfg%jmino_+1:this%cfg%jmaxo_,this%cfg%kmino_+1:this%cfg%kmaxo_)) !< Edge-centered (zx) + ! Create viscosity interpolation coefficients to cell edge + do k=this%cfg%kmino_+1,this%cfg%kmaxo_ + do j=this%cfg%jmino_+1,this%cfg%jmaxo_ + do i=this%cfg%imino_+1,this%cfg%imaxo_ + ! Prepare local 1D metrics + itpx=this%cfg%dxmi(i)*[this%cfg%xm(i)-this%cfg%x(i),this%cfg%x(i)-this%cfg%xm(i-1)] + itpy=this%cfg%dymi(j)*[this%cfg%ym(j)-this%cfg%y(j),this%cfg%y(j)-this%cfg%ym(j-1)] + itpz=this%cfg%dzmi(k)*[this%cfg%zm(k)-this%cfg%z(k),this%cfg%z(k)-this%cfg%zm(k-1)] + ! Combine for 2D interpolations + do st1=-1,0 + do st2=-1,0 + this%itp_xy(st1,st2,i,j,k)=itpx(st1)*itpy(st2) + this%itp_yz(st1,st2,i,j,k)=itpy(st1)*itpz(st2) + this%itp_xz(st1,st2,i,j,k)=itpx(st1)*itpz(st2) + end do + end do + end do + end do + end do + + ! Allocate finite difference velocity interpolation coefficients + allocate(this%itpu_x( 0:+1,this%cfg%imino_ :this%cfg%imaxo_,this%cfg%jmino_ :this%cfg%jmaxo_,this%cfg%kmino_ :this%cfg%kmaxo_)) !< Cell-centered + allocate(this%itpv_y( 0:+1,this%cfg%imino_ :this%cfg%imaxo_,this%cfg%jmino_ :this%cfg%jmaxo_,this%cfg%kmino_ :this%cfg%kmaxo_)) !< Cell-centered + allocate(this%itpw_z( 0:+1,this%cfg%imino_ :this%cfg%imaxo_,this%cfg%jmino_ :this%cfg%jmaxo_,this%cfg%kmino_ :this%cfg%kmaxo_)) !< Cell-centered + allocate(this%itpv_x(-1: 0,this%cfg%imino_+1:this%cfg%imaxo_,this%cfg%jmino_ :this%cfg%jmaxo_,this%cfg%kmino_ :this%cfg%kmaxo_)) !< Edge-centered (xy) + allocate(this%itpw_x(-1: 0,this%cfg%imino_+1:this%cfg%imaxo_,this%cfg%jmino_ :this%cfg%jmaxo_,this%cfg%kmino_ :this%cfg%kmaxo_)) !< Edge-centered (zx) + allocate(this%itpu_y(-1: 0,this%cfg%imino_ :this%cfg%imaxo_,this%cfg%jmino_+1:this%cfg%jmaxo_,this%cfg%kmino_ :this%cfg%kmaxo_)) !< Edge-centered (xy) + allocate(this%itpw_y(-1: 0,this%cfg%imino_ :this%cfg%imaxo_,this%cfg%jmino_+1:this%cfg%jmaxo_,this%cfg%kmino_ :this%cfg%kmaxo_)) !< Edge-centered (yz) + allocate(this%itpu_z(-1: 0,this%cfg%imino_ :this%cfg%imaxo_,this%cfg%jmino_ :this%cfg%jmaxo_,this%cfg%kmino_+1:this%cfg%kmaxo_)) !< Edge-centered (zx) + allocate(this%itpv_z(-1: 0,this%cfg%imino_ :this%cfg%imaxo_,this%cfg%jmino_ :this%cfg%jmaxo_,this%cfg%kmino_+1:this%cfg%kmaxo_)) !< Edge-centered (yz) + ! Create velocity interpolation coefficients to cell center [xm,ym,zm] + do k=this%cfg%kmino_,this%cfg%kmaxo_ + do j=this%cfg%jmino_,this%cfg%jmaxo_ + do i=this%cfg%imino_,this%cfg%imaxo_ + this%itpu_x(:,i,j,k)=[+0.5_WP,+0.5_WP] !< Linear interpolation in x of U from [x ,ym,zm] + this%itpv_y(:,i,j,k)=[+0.5_WP,+0.5_WP] !< Linear interpolation in y of V from [xm,y ,zm] + this%itpw_z(:,i,j,k)=[+0.5_WP,+0.5_WP] !< Linear interpolation in z of W from [xm,ym,z ] + end do + end do + end do + ! Create velocity interpolation coefficients to cell edge in x + do k=this%cfg%kmino_ ,this%cfg%kmaxo_ + do j=this%cfg%jmino_ ,this%cfg%jmaxo_ + do i=this%cfg%imino_+1,this%cfg%imaxo_ + this%itpv_x(:,i,j,k)=this%cfg%dxmi(i)*[this%cfg%xm(i)-this%cfg%x(i),this%cfg%x(i)-this%cfg%xm(i-1)] !< Linear interpolation in x of V from [xm,y ,zm] + this%itpw_x(:,i,j,k)=this%cfg%dxmi(i)*[this%cfg%xm(i)-this%cfg%x(i),this%cfg%x(i)-this%cfg%xm(i-1)] !< Linear interpolation in x of W from [xm,ym,z ] + end do + end do + end do + ! Create velocity interpolation coefficients to cell edge in y + do k=this%cfg%kmino_ ,this%cfg%kmaxo_ + do j=this%cfg%jmino_+1,this%cfg%jmaxo_ + do i=this%cfg%imino_ ,this%cfg%imaxo_ + this%itpu_y(:,i,j,k)=this%cfg%dymi(j)*[this%cfg%ym(j)-this%cfg%y(j),this%cfg%y(j)-this%cfg%ym(j-1)] !< Linear interpolation in y of U from [x ,ym,zm] + this%itpw_y(:,i,j,k)=this%cfg%dymi(j)*[this%cfg%ym(j)-this%cfg%y(j),this%cfg%y(j)-this%cfg%ym(j-1)] !< Linear interpolation in y of W from [xm,ym,z ] + end do + end do + end do + ! Create velocity interpolation coefficients to cell edge in z + do k=this%cfg%kmino_+1,this%cfg%kmaxo_ + do j=this%cfg%jmino_ ,this%cfg%jmaxo_ + do i=this%cfg%imino_ ,this%cfg%imaxo_ + this%itpu_z(:,i,j,k)=this%cfg%dzmi(k)*[this%cfg%zm(k)-this%cfg%z(k),this%cfg%z(k)-this%cfg%zm(k-1)] !< Linear interpolation in z of U from [x ,ym,zm] + this%itpv_z(:,i,j,k)=this%cfg%dzmi(k)*[this%cfg%zm(k)-this%cfg%z(k),this%cfg%z(k)-this%cfg%zm(k-1)] !< Linear interpolation in z of V from [xm,y ,zm] + end do + end do + end do + + ! Allocate finite volume divergence operators + allocate(this%divp_x( 0:+1,this%cfg%imino_ :this%cfg%imaxo_,this%cfg%jmino_ :this%cfg%jmaxo_,this%cfg%kmino_ :this%cfg%kmaxo_)) !< Cell-centered + allocate(this%divp_y( 0:+1,this%cfg%imino_ :this%cfg%imaxo_,this%cfg%jmino_ :this%cfg%jmaxo_,this%cfg%kmino_ :this%cfg%kmaxo_)) !< Cell-centered + allocate(this%divp_z( 0:+1,this%cfg%imino_ :this%cfg%imaxo_,this%cfg%jmino_ :this%cfg%jmaxo_,this%cfg%kmino_ :this%cfg%kmaxo_)) !< Cell-centered + allocate(this%divu_x(-1: 0,this%cfg%imino_+1:this%cfg%imaxo_,this%cfg%jmino_ :this%cfg%jmaxo_,this%cfg%kmino_ :this%cfg%kmaxo_)) !< Face-centered (x) + allocate(this%divu_y( 0:+1,this%cfg%imino_ :this%cfg%imaxo_,this%cfg%jmino_ :this%cfg%jmaxo_,this%cfg%kmino_ :this%cfg%kmaxo_)) !< Face-centered (x) + allocate(this%divu_z( 0:+1,this%cfg%imino_ :this%cfg%imaxo_,this%cfg%jmino_ :this%cfg%jmaxo_,this%cfg%kmino_ :this%cfg%kmaxo_)) !< Face-centered (x) + allocate(this%divv_x( 0:+1,this%cfg%imino_ :this%cfg%imaxo_,this%cfg%jmino_ :this%cfg%jmaxo_,this%cfg%kmino_ :this%cfg%kmaxo_)) !< Face-centered (y) + allocate(this%divv_y(-1: 0,this%cfg%imino_ :this%cfg%imaxo_,this%cfg%jmino_+1:this%cfg%jmaxo_,this%cfg%kmino_ :this%cfg%kmaxo_)) !< Face-centered (y) + allocate(this%divv_z( 0:+1,this%cfg%imino_ :this%cfg%imaxo_,this%cfg%jmino_ :this%cfg%jmaxo_,this%cfg%kmino_ :this%cfg%kmaxo_)) !< Face-centered (y) + allocate(this%divw_x( 0:+1,this%cfg%imino_ :this%cfg%imaxo_,this%cfg%jmino_ :this%cfg%jmaxo_,this%cfg%kmino_ :this%cfg%kmaxo_)) !< Face-centered (z) + allocate(this%divw_y( 0:+1,this%cfg%imino_ :this%cfg%imaxo_,this%cfg%jmino_ :this%cfg%jmaxo_,this%cfg%kmino_ :this%cfg%kmaxo_)) !< Face-centered (z) + allocate(this%divw_z(-1: 0,this%cfg%imino_ :this%cfg%imaxo_,this%cfg%jmino_ :this%cfg%jmaxo_,this%cfg%kmino_+1:this%cfg%kmaxo_)) !< Face-centered (z) + ! Create divergence operator to cell center [xm,ym,zm] or tangent to cell face + do k=this%cfg%kmino_,this%cfg%kmaxo_ + do j=this%cfg%jmino_,this%cfg%jmaxo_ + do i=this%cfg%imino_,this%cfg%imaxo_ + this%divp_x(:,i,j,k)=this%cfg%dxi(i)*[-1.0_WP,+1.0_WP] !< FV divergence from [x ,ym,zm] + this%divp_y(:,i,j,k)=this%cfg%dyi(j)*[-1.0_WP,+1.0_WP] !< FV divergence from [xm,y ,zm] + this%divp_z(:,i,j,k)=this%cfg%dzi(k)*[-1.0_WP,+1.0_WP] !< FV divergence from [xm,ym,z ] + + this%divu_y(:,i,j,k)=this%cfg%dyi(j)*[-1.0_WP,+1.0_WP] !< FV divergence from [x ,y ,zm] + this%divu_z(:,i,j,k)=this%cfg%dzi(k)*[-1.0_WP,+1.0_WP] !< FV divergence from [x ,ym,z ] + + this%divv_x(:,i,j,k)=this%cfg%dxi(i)*[-1.0_WP,+1.0_WP] !< FV divergence from [x ,y ,zm] + this%divv_z(:,i,j,k)=this%cfg%dzi(k)*[-1.0_WP,+1.0_WP] !< FV divergence from [xm,y ,z ] + + this%divw_x(:,i,j,k)=this%cfg%dxi(i)*[-1.0_WP,+1.0_WP] !< FV divergence from [x ,ym,z ] + this%divw_y(:,i,j,k)=this%cfg%dyi(j)*[-1.0_WP,+1.0_WP] !< FV divergence from [xm,y ,z ] + end do + end do + end do + ! Create divergence operator perpendicular to cell face [x ,ym,zm] + do k=this%cfg%kmino_ ,this%cfg%kmaxo_ + do j=this%cfg%jmino_ ,this%cfg%jmaxo_ + do i=this%cfg%imino_+1,this%cfg%imaxo_ + this%divu_x(:,i,j,k)=this%cfg%dxmi(i)*[-1.0_WP,+1.0_WP] !< FV divergence from [xm,ym,zm] + end do + end do + end do + ! Create divergence operator perpendicular to cell face [xm,y ,zm] + do k=this%cfg%kmino_ ,this%cfg%kmaxo_ + do j=this%cfg%jmino_+1,this%cfg%jmaxo_ + do i=this%cfg%imino_ ,this%cfg%imaxo_ + this%divv_y(:,i,j,k)=this%cfg%dymi(j)*[-1.0_WP,+1.0_WP] !< FV divergence from [xm,ym,zm] + end do + end do + end do + ! Create divergence operator perpendicular to cell face [xm,ym,z ] + do k=this%cfg%kmino_+1,this%cfg%kmaxo_ + do j=this%cfg%jmino_ ,this%cfg%jmaxo_ + do i=this%cfg%imino_ ,this%cfg%imaxo_ + this%divw_z(:,i,j,k)=this%cfg%dzmi(k)*[-1.0_WP,+1.0_WP] !< FV divergence from [xm,ym,zm] + end do + end do + end do + + ! Allocate finite difference velocity gradient operators + allocate(this%grdu_x( 0:+1,this%cfg%imino_ :this%cfg%imaxo_,this%cfg%jmino_ :this%cfg%jmaxo_,this%cfg%kmino_ :this%cfg%kmaxo_)) !< Cell-centered + allocate(this%grdv_y( 0:+1,this%cfg%imino_ :this%cfg%imaxo_,this%cfg%jmino_ :this%cfg%jmaxo_,this%cfg%kmino_ :this%cfg%kmaxo_)) !< Cell-centered + allocate(this%grdw_z( 0:+1,this%cfg%imino_ :this%cfg%imaxo_,this%cfg%jmino_ :this%cfg%jmaxo_,this%cfg%kmino_ :this%cfg%kmaxo_)) !< Cell-centered + allocate(this%grdv_x(-1: 0,this%cfg%imino_+1:this%cfg%imaxo_,this%cfg%jmino_ :this%cfg%jmaxo_,this%cfg%kmino_ :this%cfg%kmaxo_)) !< Edge-centered (xy) + allocate(this%grdw_x(-1: 0,this%cfg%imino_+1:this%cfg%imaxo_,this%cfg%jmino_ :this%cfg%jmaxo_,this%cfg%kmino_ :this%cfg%kmaxo_)) !< Edge-centered (zx) + allocate(this%grdu_y(-1: 0,this%cfg%imino_ :this%cfg%imaxo_,this%cfg%jmino_+1:this%cfg%jmaxo_,this%cfg%kmino_ :this%cfg%kmaxo_)) !< Edge-centered (xy) + allocate(this%grdw_y(-1: 0,this%cfg%imino_ :this%cfg%imaxo_,this%cfg%jmino_+1:this%cfg%jmaxo_,this%cfg%kmino_ :this%cfg%kmaxo_)) !< Edge-centered (yz) + allocate(this%grdu_z(-1: 0,this%cfg%imino_ :this%cfg%imaxo_,this%cfg%jmino_ :this%cfg%jmaxo_,this%cfg%kmino_+1:this%cfg%kmaxo_)) !< Edge-centered (zx) + allocate(this%grdv_z(-1: 0,this%cfg%imino_ :this%cfg%imaxo_,this%cfg%jmino_ :this%cfg%jmaxo_,this%cfg%kmino_+1:this%cfg%kmaxo_)) !< Edge-centered (yz) + ! Create gradient coefficients to cell center [xm,ym,zm] + do k=this%cfg%kmino_,this%cfg%kmaxo_ + do j=this%cfg%jmino_,this%cfg%jmaxo_ + do i=this%cfg%imino_,this%cfg%imaxo_ + this%grdu_x(:,i,j,k)=this%cfg%dxi(i)*[-1.0_WP,+1.0_WP] !< FD gradient in x of U from [x ,ym,zm] + this%grdv_y(:,i,j,k)=this%cfg%dyi(j)*[-1.0_WP,+1.0_WP] !< FD gradient in y of V from [xm,y ,zm] + this%grdw_z(:,i,j,k)=this%cfg%dzi(k)*[-1.0_WP,+1.0_WP] !< FD gradient in z of W from [xm,ym,z ] + end do + end do + end do + ! Create gradient coefficients to cell edge in x + do k=this%cfg%kmino_ ,this%cfg%kmaxo_ + do j=this%cfg%jmino_ ,this%cfg%jmaxo_ + do i=this%cfg%imino_+1,this%cfg%imaxo_ + this%grdv_x(:,i,j,k)=this%cfg%dxmi(i)*[-1.0_WP,+1.0_WP] !< FD gradient in x of V from [xm,y ,zm] + this%grdw_x(:,i,j,k)=this%cfg%dxmi(i)*[-1.0_WP,+1.0_WP] !< FD gradient in x of W from [xm,ym,z ] + end do + end do + end do + ! Create gradient coefficients to cell edge in y + do k=this%cfg%kmino_ ,this%cfg%kmaxo_ + do j=this%cfg%jmino_+1,this%cfg%jmaxo_ + do i=this%cfg%imino_ ,this%cfg%imaxo_ + this%grdu_y(:,i,j,k)=this%cfg%dymi(j)*[-1.0_WP,+1.0_WP] !< FD gradient in y of U from [x ,ym,zm] + this%grdw_y(:,i,j,k)=this%cfg%dymi(j)*[-1.0_WP,+1.0_WP] !< FD gradient in y of W from [xm,ym,z ] + end do + end do + end do + ! Create gradient coefficients to cell edge in z + do k=this%cfg%kmino_+1,this%cfg%kmaxo_ + do j=this%cfg%jmino_ ,this%cfg%jmaxo_ + do i=this%cfg%imino_ ,this%cfg%imaxo_ + this%grdu_z(:,i,j,k)=this%cfg%dzmi(k)*[-1.0_WP,+1.0_WP] !< FD gradient in z of U from [x ,ym,zm] + this%grdv_z(:,i,j,k)=this%cfg%dzmi(k)*[-1.0_WP,+1.0_WP] !< FD gradient in z of V from [xm,y ,zm] + end do + end do + end do + + end subroutine init_metrics + + + !> Metric adjustment accounting for bconds and walls + subroutine adjust_metrics(this) + implicit none + class(incomp), intent(inout) :: this + integer :: i,j,k,st1,st2 + real(WP) :: delta,mysum + + ! Sync up u/v/wmasks + call this%cfg%sync(this%umask) + call this%cfg%sync(this%vmask) + call this%cfg%sync(this%wmask) + if (.not.this%cfg%xper.and.this%cfg%iproc.eq.1) this%umask(this%cfg%imino,:,:)=this%umask(this%cfg%imino+1,:,:) + if (.not.this%cfg%yper.and.this%cfg%jproc.eq.1) this%vmask(:,this%cfg%jmino,:)=this%vmask(:,this%cfg%jmino+1,:) + if (.not.this%cfg%zper.and.this%cfg%kproc.eq.1) this%wmask(:,:,this%cfg%kmino)=this%wmask(:,:,this%cfg%kmino+1) + + ! I am assuming here that we do not really need to zero out wall cells + ! as they could be used for Dirichlet (then the density needs to be available! could be problematic if we do not have an explicit BC for scalars, e.g. for a Couette flow) + ! or outflow condition (then the density needs to be available but it should be directly calculated) + ! or used for a real no-slip wall (then density is always multiplied by zero) + ! Adjust density interpolation coefficients to cell faces in the presence of walls (only walls!) + !do k=this%cfg%kmin_,this%cfg%kmax_+1 + ! do j=this%cfg%jmin_,this%cfg%jmax_+1 + ! do i=this%cfg%imin_,this%cfg%imax_+1 + ! ! Linear interpolation in x + ! if (this%cfg%VF(i,j,k).eq.0.0_WP.and.this%cfg%VF(i-1,j,k).gt.0.0_WP) this%itpr_x(:,i,j,k)=[1.0_WP,0.0_WP] + ! if (this%cfg%VF(i,j,k).gt.0.0_WP.and.this%cfg%VF(i-1,j,k).eq.0.0_WP) this%itpr_x(:,i,j,k)=[0.0_WP,1.0_WP] + ! ! Linear interpolation in y + ! if (this%cfg%VF(i,j,k).eq.0.0_WP.and.this%cfg%VF(i,j-1,k).gt.0.0_WP) this%itpr_y(:,i,j,k)=[1.0_WP,0.0_WP] + ! if (this%cfg%VF(i,j,k).gt.0.0_WP.and.this%cfg%VF(i,j-1,k).eq.0.0_WP) this%itpr_y(:,i,j,k)=[0.0_WP,1.0_WP] + ! ! Linear interpolation in z + ! if (this%cfg%VF(i,j,k).eq.0.0_WP.and.this%cfg%VF(i,j,k-1).gt.0.0_WP) this%itpr_z(:,i,j,k)=[1.0_WP,0.0_WP] + ! if (this%cfg%VF(i,j,k).gt.0.0_WP.and.this%cfg%VF(i,j,k-1).eq.0.0_WP) this%itpr_z(:,i,j,k)=[0.0_WP,1.0_WP] + ! end do + ! end do + !end do + + ! Adjust interpolation coefficients to cell centers in the presence of walls (only walls!) + do k=this%cfg%kmino_,this%cfg%kmaxo_ + do j=this%cfg%jmino_,this%cfg%jmaxo_ + do i=this%cfg%imino_,this%cfg%imaxo_ + if (this%mask(i,j,k).eq.1) this%itpu_x(:,i,j,k)=0.0_WP + if (this%mask(i,j,k).eq.1) this%itpv_y(:,i,j,k)=0.0_WP + if (this%mask(i,j,k).eq.1) this%itpw_z(:,i,j,k)=0.0_WP + end do + end do + end do + + ! Adjust viscosity interpolation coefficients to cell edge in the presence of walls (only walls) + do k=this%cfg%kmino_+1,this%cfg%kmaxo_ + do j=this%cfg%jmino_+1,this%cfg%jmaxo_ + do i=this%cfg%imino_+1,this%cfg%imaxo_ + ! Zero out interpolation coefficients reaching in the walls + do st1=-1,0 + do st2=-1,0 + if (this%mask(i+st1,j+st2,k).eq.1) this%itp_xy(st1,st2,i,j,k)=0.0_WP + if (this%mask(i,j+st1,k+st2).eq.1) this%itp_yz(st1,st2,i,j,k)=0.0_WP + if (this%mask(i+st1,j,k+st2).eq.1) this%itp_xz(st1,st2,i,j,k)=0.0_WP + end do + end do + ! Rescale to ensure sum(itp)=1 + mysum=sum(this%itp_xy(:,:,i,j,k)); if (mysum.gt.0.0_WP) this%itp_xy(:,:,i,j,k)=this%itp_xy(:,:,i,j,k)/mysum + mysum=sum(this%itp_yz(:,:,i,j,k)); if (mysum.gt.0.0_WP) this%itp_yz(:,:,i,j,k)=this%itp_yz(:,:,i,j,k)/mysum + mysum=sum(this%itp_xz(:,:,i,j,k)); if (mysum.gt.0.0_WP) this%itp_xz(:,:,i,j,k)=this%itp_xz(:,:,i,j,k)/mysum + end do + end do + end do + + ! Loop over the domain and adjust divergence for P cell + do k=this%cfg%kmino_,this%cfg%kmaxo_ + do j=this%cfg%jmino_,this%cfg%jmaxo_ + do i=this%cfg%imino_,this%cfg%imaxo_ + if (this%mask(i,j,k).gt.0) then + this%divp_x(:,i,j,k)=0.0_WP + this%divp_y(:,i,j,k)=0.0_WP + this%divp_z(:,i,j,k)=0.0_WP + end if + end do + end do + end do + + ! Loop over the domain and apply masked conditions to U metrics + do k=this%cfg%kmino_ ,this%cfg%kmaxo_ + do j=this%cfg%jmino_ ,this%cfg%jmaxo_ + do i=this%cfg%imino_+1,this%cfg%imaxo_ + if (this%umask(i,j,k).gt.0) then + this%divu_x(:,i,j,k)=0.0_WP + this%divu_y(:,i,j,k)=0.0_WP + this%divu_z(:,i,j,k)=0.0_WP + end if + end do + end do + end do + + ! Loop over the domain and apply masked conditions to V metrics + do k=this%cfg%kmino_ ,this%cfg%kmaxo_ + do j=this%cfg%jmino_+1,this%cfg%jmaxo_ + do i=this%cfg%imino_ ,this%cfg%imaxo_ + if (this%vmask(i,j,k).gt.0) then + this%divv_x(:,i,j,k)=0.0_WP + this%divv_y(:,i,j,k)=0.0_WP + this%divv_z(:,i,j,k)=0.0_WP + end if + end do + end do + end do + + ! Loop over the domain and apply masked conditions to W metrics + do k=this%cfg%kmino_+1,this%cfg%kmaxo_ + do j=this%cfg%jmino_ ,this%cfg%jmaxo_ + do i=this%cfg%imino_ ,this%cfg%imaxo_ + if (this%wmask(i,j,k).gt.0) then + this%divw_x(:,i,j,k)=0.0_WP + this%divw_y(:,i,j,k)=0.0_WP + this%divw_z(:,i,j,k)=0.0_WP + end if + end do + end do + end do + + ! Adjust gradient coefficients to cell edge in x + do k=this%cfg%kmino_ ,this%cfg%kmaxo_ + do j=this%cfg%jmino_ ,this%cfg%jmaxo_ + do i=this%cfg%imino_+1,this%cfg%imaxo_ + ! FD gradient in x of V from [xm,y ,zm] + if (maxval(this%vmask(i-1:i,j,k)).gt.0) then + delta=0.0_WP + if (this%vmask(i ,j,k).eq.0) delta=delta+(this%cfg%xm(i)-this%cfg%x (i )) + if (this%vmask(i-1,j,k).eq.0) delta=delta+(this%cfg%x (i)-this%cfg%xm(i-1)) + if (delta.gt.0.0_WP) then + this%grdv_x(:,i,j,k)=[-1.0_WP,+1.0_WP]/delta + else + this%grdv_x(:,i,j,k)=0.0_WP + end if + end if + ! FD gradient in x of W from [xm,ym,z ] + if (maxval(this%wmask(i-1:i,j,k)).gt.0) then + delta=0.0_WP + if (this%wmask(i ,j,k).eq.0) delta=delta+(this%cfg%xm(i)-this%cfg%x (i )) + if (this%wmask(i-1,j,k).eq.0) delta=delta+(this%cfg%x (i)-this%cfg%xm(i-1)) + if (delta.gt.0.0_WP) then + this%grdw_x(:,i,j,k)=[-1.0_WP,+1.0_WP]/delta + else + this%grdw_x(:,i,j,k)=0.0_WP + end if + end if + end do + end do + end do + + ! Adjust gradient coefficients to cell edge in y + do k=this%cfg%kmino_ ,this%cfg%kmaxo_ + do j=this%cfg%jmino_+1,this%cfg%jmaxo_ + do i=this%cfg%imino_ ,this%cfg%imaxo_ + ! FD gradient in y of U from [x ,ym,zm] + if (maxval(this%umask(i,j-1:j,k)).gt.0) then + delta=0.0_WP + if (this%umask(i,j ,k).eq.0) delta=delta+(this%cfg%ym(j)-this%cfg%y (j )) + if (this%umask(i,j-1,k).eq.0) delta=delta+(this%cfg%y (j)-this%cfg%ym(j-1)) + if (delta.gt.0.0_WP) then + this%grdu_y(:,i,j,k)=[-1.0_WP,+1.0_WP]/delta + else + this%grdu_y(:,i,j,k)=0.0_WP + end if + end if + ! FD gradient in y of W from [xm,ym,z ] + if (maxval(this%wmask(i,j-1:j,k)).gt.0) then + delta=0.0_WP + if (this%wmask(i,j ,k).eq.0) delta=delta+(this%cfg%ym(j)-this%cfg%y (j )) + if (this%wmask(i,j-1,k).eq.0) delta=delta+(this%cfg%y (j)-this%cfg%ym(j-1)) + if (delta.gt.0.0_WP) then + this%grdw_y(:,i,j,k)=[-1.0_WP,+1.0_WP]/delta + else + this%grdw_y(:,i,j,k)=0.0_WP + end if + end if + end do + end do + end do + + ! Adjust gradient coefficients to cell edge in z + do k=this%cfg%kmino_+1,this%cfg%kmaxo_ + do j=this%cfg%jmino_ ,this%cfg%jmaxo_ + do i=this%cfg%imino_ ,this%cfg%imaxo_ + ! FD gradient in z of U from [x ,ym,zm] + if (maxval(this%umask(i,j,k-1:k)).gt.0) then + delta=0.0_WP + if (this%umask(i,j,k ).eq.0) delta=delta+(this%cfg%zm(k)-this%cfg%z (k )) + if (this%umask(i,j,k-1).eq.0) delta=delta+(this%cfg%z (k)-this%cfg%zm(k-1)) + if (delta.gt.0.0_WP) then + this%grdu_z(:,i,j,k)=[-1.0_WP,+1.0_WP]/delta + else + this%grdu_z(:,i,j,k)=0.0_WP + end if + end if + ! FD gradient in z of V from [xm,y ,zm] + if (maxval(this%vmask(i,j,k-1:k)).gt.0) then + delta=0.0_WP + if (this%vmask(i,j,k ).eq.0) delta=delta+(this%cfg%zm(k)-this%cfg%z (k )) + if (this%vmask(i,j,k-1).eq.0) delta=delta+(this%cfg%z (k)-this%cfg%zm(k-1)) + if (delta.gt.0.0_WP) then + this%grdv_z(:,i,j,k)=[-1.0_WP,+1.0_WP]/delta + else + this%grdv_z(:,i,j,k)=0.0_WP + end if + end if + end do + end do + end do + + ! Adjust interpolation coefficients to cell centers in the presence of walls (only walls!) + do k=this%cfg%kmino_,this%cfg%kmaxo_ + do j=this%cfg%jmino_,this%cfg%jmaxo_ + do i=this%cfg%imino_,this%cfg%imaxo_ + if (this%mask(i,j,k).eq.1) this%itpu_x(:,i,j,k)=0.0_WP + if (this%mask(i,j,k).eq.1) this%itpv_y(:,i,j,k)=0.0_WP + if (this%mask(i,j,k).eq.1) this%itpw_z(:,i,j,k)=0.0_WP + end do + end do + end do + + ! Adjust interpolation coefficients to cell edge in x + do k=this%cfg%kmino_ ,this%cfg%kmaxo_ + do j=this%cfg%jmino_ ,this%cfg%jmaxo_ + do i=this%cfg%imino_+1,this%cfg%imaxo_ + ! Linear interpolation in x of V from [xm,y ,zm] + if (this%vmask(i,j,k).eq.0.and.this%vmask(i-1,j,k).gt.0) this%itpv_x(:,i,j,k)=[1.0_WP,0.0_WP] + if (this%vmask(i,j,k).gt.0.and.this%vmask(i-1,j,k).eq.0) this%itpv_x(:,i,j,k)=[0.0_WP,1.0_WP] + ! Linear interpolation in x of W from [xm,ym,z ] + if (this%wmask(i,j,k).eq.0.and.this%wmask(i-1,j,k).gt.0) this%itpw_x(:,i,j,k)=[1.0_WP,0.0_WP] + if (this%wmask(i,j,k).gt.0.and.this%wmask(i-1,j,k).eq.0) this%itpw_x(:,i,j,k)=[0.0_WP,1.0_WP] + end do + end do + end do + + ! Adjust interpolation coefficients to cell edge in y + do k=this%cfg%kmino_ ,this%cfg%kmaxo_ + do j=this%cfg%jmino_+1,this%cfg%jmaxo_ + do i=this%cfg%imino_ ,this%cfg%imaxo_ + ! Linear interpolation in y of U from [x ,ym,zm] + if (this%umask(i,j,k).eq.0.and.this%umask(i,j-1,k).gt.0) this%itpu_y(:,i,j,k)=[1.0_WP,0.0_WP] + if (this%umask(i,j,k).gt.0.and.this%umask(i,j-1,k).eq.0) this%itpu_y(:,i,j,k)=[0.0_WP,1.0_WP] + ! Linear interpolation in y of W from [xm,ym,z ] + if (this%wmask(i,j,k).eq.0.and.this%wmask(i,j-1,k).gt.0) this%itpw_y(:,i,j,k)=[1.0_WP,0.0_WP] + if (this%wmask(i,j,k).gt.0.and.this%wmask(i,j-1,k).eq.0) this%itpw_y(:,i,j,k)=[0.0_WP,1.0_WP] + end do + end do + end do + + ! Adjust interpolation coefficients to cell edge in z + do k=this%cfg%kmino_+1,this%cfg%kmaxo_ + do j=this%cfg%jmino_ ,this%cfg%jmaxo_ + do i=this%cfg%imino_ ,this%cfg%imaxo_ + ! Linear interpolation in z of U from [x ,ym,zm] + if (this%umask(i,j,k).eq.0.and.this%umask(i,j,k-1).gt.0) this%itpu_z(:,i,j,k)=[1.0_WP,0.0_WP] + if (this%umask(i,j,k).gt.0.and.this%umask(i,j,k-1).eq.0) this%itpu_z(:,i,j,k)=[0.0_WP,1.0_WP] + ! Linear interpolation in z of V from [xm,y ,zm] + if (this%vmask(i,j,k).eq.0.and.this%vmask(i,j,k-1).gt.0) this%itpv_z(:,i,j,k)=[1.0_WP,0.0_WP] + if (this%vmask(i,j,k).gt.0.and.this%vmask(i,j,k-1).eq.0) this%itpv_z(:,i,j,k)=[0.0_WP,1.0_WP] + end do + end do + end do + + ! Adjust metrics to account for lower dimensionality + if (this%cfg%nx.eq.1) then + this%divp_x=0.0_WP + this%divu_x=0.0_WP + this%divv_x=0.0_WP + this%divw_x=0.0_WP + this%grdu_x=0.0_WP + this%grdv_x=0.0_WP + this%grdw_x=0.0_WP + end if + if (this%cfg%ny.eq.1) then + this%divp_y=0.0_WP + this%divu_y=0.0_WP + this%divv_y=0.0_WP + this%divw_y=0.0_WP + this%grdu_y=0.0_WP + this%grdv_y=0.0_WP + this%grdw_y=0.0_WP + end if + if (this%cfg%nz.eq.1) then + this%divp_z=0.0_WP + this%divu_z=0.0_WP + this%divv_z=0.0_WP + this%divw_z=0.0_WP + this%grdu_z=0.0_WP + this%grdv_z=0.0_WP + this%grdw_z=0.0_WP + end if + + end subroutine adjust_metrics + + + !> Finish setting up the flow solver now that bconds have been defined + subroutine setup(this,pressure_solver,implicit_solver) + implicit none + class(incomp), intent(inout) :: this + class(linsol), target, intent(in) :: pressure_solver !< A pressure solver is required + class(linsol), target, intent(in), optional :: implicit_solver !< An implicit solver can be provided + integer :: i,j,k + + ! Adjust metrics based on bcflag array + call this%adjust_metrics() + + ! Point to pressure solver linsol object + this%psolv=>pressure_solver + + ! Set 7-pt stencil map for the pressure solver + this%psolv%stc(1,:)=[ 0, 0, 0] + this%psolv%stc(2,:)=[+1, 0, 0] + this%psolv%stc(3,:)=[-1, 0, 0] + this%psolv%stc(4,:)=[ 0,+1, 0] + this%psolv%stc(5,:)=[ 0,-1, 0] + this%psolv%stc(6,:)=[ 0, 0,+1] + this%psolv%stc(7,:)=[ 0, 0,-1] + + ! Setup the scaled Laplacian operator from incomp metrics: lap(*)=-vol*div(grad(*)) + do k=this%cfg%kmin_,this%cfg%kmax_ + do j=this%cfg%jmin_,this%cfg%jmax_ + do i=this%cfg%imin_,this%cfg%imax_ + ! Set Laplacian + this%psolv%opr(1,i,j,k)=this%divp_x(1,i,j,k)*this%divu_x(-1,i+1,j,k)+& + & this%divp_x(0,i,j,k)*this%divu_x( 0,i ,j,k)+& + & this%divp_y(1,i,j,k)*this%divv_y(-1,i,j+1,k)+& + & this%divp_y(0,i,j,k)*this%divv_y( 0,i,j ,k)+& + & this%divp_z(1,i,j,k)*this%divw_z(-1,i,j,k+1)+& + & this%divp_z(0,i,j,k)*this%divw_z( 0,i,j,k ) + this%psolv%opr(2,i,j,k)=this%divp_x(1,i,j,k)*this%divu_x( 0,i+1,j,k) + this%psolv%opr(3,i,j,k)=this%divp_x(0,i,j,k)*this%divu_x(-1,i ,j,k) + this%psolv%opr(4,i,j,k)=this%divp_y(1,i,j,k)*this%divv_y( 0,i,j+1,k) + this%psolv%opr(5,i,j,k)=this%divp_y(0,i,j,k)*this%divv_y(-1,i,j ,k) + this%psolv%opr(6,i,j,k)=this%divp_z(1,i,j,k)*this%divw_z( 0,i,j,k+1) + this%psolv%opr(7,i,j,k)=this%divp_z(0,i,j,k)*this%divw_z(-1,i,j,k ) + ! Scale it by the cell volume + this%psolv%opr(:,i,j,k)=-this%psolv%opr(:,i,j,k)*this%cfg%vol(i,j,k) + end do + end do + end do + + ! Initialize the pressure Poisson solver + call this%psolv%init() + call this%psolv%setup() + + ! Prepare implicit solver if it had been provided + if (present(implicit_solver)) then + + ! Point to implicit solver linsol object + this%implicit=>implicit_solver + + ! Set 7-pt stencil map for the velocity solver + this%implicit%stc(1,:)=[ 0, 0, 0] + this%implicit%stc(2,:)=[+1, 0, 0] + this%implicit%stc(3,:)=[-1, 0, 0] + this%implicit%stc(4,:)=[ 0,+1, 0] + this%implicit%stc(5,:)=[ 0,-1, 0] + this%implicit%stc(6,:)=[ 0, 0,+1] + this%implicit%stc(7,:)=[ 0, 0,-1] + + ! Set the diagonal to 1 to make sure all cells participate in solver + this%implicit%opr(1,:,:,:)=1.0_WP + + ! Initialize the implicit velocity solver + call this%implicit%init() + + else + + ! Point to implicit solver linsol object + this%implicit=>NULL() + + end if + + end subroutine setup + + + !> Add a boundary condition + subroutine add_bcond(this,name,type,locator,face,dir,canCorrect) + use string, only: lowercase + use messager, only: die + use iterator_class, only: locator_ftype + implicit none + class(incomp), intent(inout) :: this + character(len=*), intent(in) :: name + integer, intent(in) :: type + procedure(locator_ftype) :: locator + character(len=1), intent(in) :: face + integer, intent(in) :: dir + logical, intent(in) :: canCorrect + type(bcond), pointer :: new_bc + integer :: i,j,k,n + + ! Prepare new bcond + allocate(new_bc) + new_bc%name=trim(adjustl(name)) + new_bc%type=type + select case (lowercase(face)) + case ('x'); new_bc%face='x' + case ('y'); new_bc%face='y' + case ('z'); new_bc%face='z' + case default; call die('[incomp add_bcond] Unknown bcond face - expecting x, y, or z') + end select + new_bc%itr=iterator(pg=this%cfg,name=new_bc%name,locator=locator,face=new_bc%face) + select case (dir) ! Outward-oriented + case (+1); new_bc%dir=+1 + case (-1); new_bc%dir=-1 + case ( 0); new_bc%dir= 0 + case default; call die('[incomp add_bcond] Unknown bcond dir - expecting -1, +1, or 0') + end select + new_bc%rdir=real(new_bc%dir,WP) + new_bc%canCorrect=canCorrect + + ! Insert it up front + new_bc%next=>this%first_bc + this%first_bc=>new_bc + + ! Increment bcond counter + this%nbc=this%nbc+1 + + ! Now adjust the metrics accordingly + select case (new_bc%type) + case (dirichlet) !< Dirichlet is set one face (i.e., velocit component) at the time + select case (new_bc%face) + case ('x') + do n=1,new_bc%itr%n_ + i=new_bc%itr%map(1,n); j=new_bc%itr%map(2,n); k=new_bc%itr%map(3,n) + this%umask(i,j,k)=2 + end do + case ('y') + do n=1,new_bc%itr%n_ + i=new_bc%itr%map(1,n); j=new_bc%itr%map(2,n); k=new_bc%itr%map(3,n) + this%vmask(i,j,k)=2 + end do + case ('z') + do n=1,new_bc%itr%n_ + i=new_bc%itr%map(1,n); j=new_bc%itr%map(2,n); k=new_bc%itr%map(3,n) + this%wmask(i,j,k)=2 + end do + end select + + case (neumann) !< Neumann has to be at existing wall or at domain boundary! + case (clipped_neumann) + case (convective) + case (slip) + case default + call die('[incomp apply_bcond] Unknown bcond type') + end select + + end subroutine add_bcond + + + !> Get a boundary condition + subroutine get_bcond(this,name,my_bc) + use messager, only: die + implicit none + class(incomp), intent(inout) :: this + character(len=*), intent(in) :: name + type(bcond), pointer, intent(out) :: my_bc + my_bc=>this%first_bc + search: do while (associated(my_bc)) + if (trim(my_bc%name).eq.trim(name)) exit search + my_bc=>my_bc%next + end do search + if (.not.associated(my_bc)) call die('[incomp get_bcond] Boundary condition was not found') + end subroutine get_bcond + + + !> Enforce boundary condition + subroutine apply_bcond(this,t,dt) + use messager, only: die + implicit none + class(incomp), intent(inout) :: this + real(WP), intent(in) :: t,dt + integer :: i,j,k,n,stag + type(bcond), pointer :: my_bc + + ! ! First enfore zero velocity at walls + ! do k=this%cfg%kmin_,this%cfg%kmax_ + ! do j=this%cfg%jmin_,this%cfg%jmax_ + ! do i=this%cfg%imin_,this%cfg%imax_ + ! if (minval(this%cfg%VF(i-1:i,j,k)).lt.10.0_WP*epsilon(1.0_WP)) this%U(i,j,k)=0.0_WP + ! if (minval(this%cfg%VF(i,j-1:j,k)).lt.10.0_WP*epsilon(1.0_WP)) this%V(i,j,k)=0.0_WP + ! if (minval(this%cfg%VF(i,j,k-1:k)).lt.10.0_WP*epsilon(1.0_WP)) this%W(i,j,k)=0.0_WP + ! end do + ! end do + ! end do + ! ! Sync fields + ! call this%cfg%sync(this%U) + ! call this%cfg%sync(this%V) + ! call this%cfg%sync(this%W) + + ! Traverse bcond list + my_bc=>this%first_bc + do while (associated(my_bc)) + + ! Only processes inside the bcond work here + if (my_bc%itr%amIn) then + + ! Select appropriate action based on the bcond type + select case (my_bc%type) + + case (dirichlet) !< Apply Dirichlet conditions + + ! This is done by the user directly + ! Unclear whether we want to do this within the solver... + + case (neumann,clipped_neumann,slip) !< Apply Neumann condition to all 3 components + ! Handle index shift due to staggering + stag=min(my_bc%dir,0) + ! Implement based on bcond direction + select case (my_bc%face) + case ('x') + stag=min(my_bc%dir,0) + do n=1,my_bc%itr%n_ + i=my_bc%itr%map(1,n); j=my_bc%itr%map(2,n); k=my_bc%itr%map(3,n) + this%U(i ,j ,k )=this%U(i-my_bc%dir ,j ,k ) + this%V(i+stag,j:j+1,k )=this%V(i-my_bc%dir+stag,j:j+1,k ) + this%W(i+stag,j ,k:k+1)=this%W(i-my_bc%dir+stag,j ,k:k+1) + end do + case ('y') + stag=min(my_bc%dir,0) + do n=1,my_bc%itr%n_ + i=my_bc%itr%map(1,n); j=my_bc%itr%map(2,n); k=my_bc%itr%map(3,n) + this%U(i:i+1,j+stag,k )=this%U(i:i+1,j-my_bc%dir+stag,k ) + this%V(i ,j ,k )=this%V(i ,j-my_bc%dir ,k ) + this%W(i ,j+stag,k:k+1)=this%W(i ,j-my_bc%dir+stag,k:k+1) + end do + case ('z') + stag=min(my_bc%dir,0) + do n=1,my_bc%itr%n_ + i=my_bc%itr%map(1,n); j=my_bc%itr%map(2,n); k=my_bc%itr%map(3,n) + this%U(i:i+1,j ,k+stag)=this%U(i:i+1,j ,k-my_bc%dir+stag) + this%V(i ,j:j+1,k+stag)=this%V(i ,j:j+1,k-my_bc%dir+stag) + this%W(i ,j ,k )=this%W(i ,j ,k-my_bc%dir ) + end do + end select + ! If needed, clip + if (my_bc%type.eq.clipped_neumann) then + select case (my_bc%face) + case ('x') + do n=1,my_bc%itr%n_ + i=my_bc%itr%map(1,n); j=my_bc%itr%map(2,n); k=my_bc%itr%map(3,n) + if (this%U(i,j,k)*my_bc%rdir.lt.0.0_WP) this%U(i,j,k)=0.0_WP + end do + case ('y') + do n=1,my_bc%itr%n_ + i=my_bc%itr%map(1,n); j=my_bc%itr%map(2,n); k=my_bc%itr%map(3,n) + if (this%V(i,j,k)*my_bc%rdir.lt.0.0_WP) this%V(i,j,k)=0.0_WP + end do + case ('z') + do n=1,my_bc%itr%n_ + i=my_bc%itr%map(1,n); j=my_bc%itr%map(2,n); k=my_bc%itr%map(3,n) + if (this%W(i,j,k)*my_bc%rdir.lt.0.0_WP) this%W(i,j,k)=0.0_WP + end do + end select + end if + ! If needed, no penetration + if (my_bc%type.eq.slip) then + select case (my_bc%face) + case ('x') + do n=1,my_bc%itr%n_ + i=my_bc%itr%map(1,n); j=my_bc%itr%map(2,n); k=my_bc%itr%map(3,n) + this%U(i,j,k)=0.0_WP + end do + case ('y') + do n=1,my_bc%itr%n_ + i=my_bc%itr%map(1,n); j=my_bc%itr%map(2,n); k=my_bc%itr%map(3,n) + this%V(i,j,k)=0.0_WP + end do + case ('z') + do n=1,my_bc%itr%n_ + i=my_bc%itr%map(1,n); j=my_bc%itr%map(2,n); k=my_bc%itr%map(3,n) + this%W(i,j,k)=0.0_WP + end do + end select + end if + + case (convective) ! Not implemented yet! + + case default + call die('[incomp apply_bcond] Unknown bcond type') + end select + + end if + + ! Move on to the next bcond + my_bc=>my_bc%next + + end do + + ! Sync full fields after all bcond + call this%cfg%sync(this%U) + call this%cfg%sync(this%V) + call this%cfg%sync(this%W) + + end subroutine apply_bcond + + + !> Calculate the explicit momentum time derivative based on U/V/W/P + subroutine get_dmomdt(this,drhoUdt,drhoVdt,drhoWdt) + implicit none + class(incomp), intent(inout) :: this + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(out) :: drhoUdt !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(out) :: drhoVdt !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(out) :: drhoWdt !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + integer :: i,j,k,ii,jj,kk + real(WP), dimension(:,:,:), allocatable :: FX,FY,FZ + + ! Zero out drhoUVW/dt arrays + drhoUdt=0.0_WP; drhoVdt=0.0_WP; drhoWdt=0.0_WP + + ! Allocate flux arrays + allocate(FX(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + allocate(FY(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + allocate(FZ(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + + ! Flux of rhoU + do kk=this%cfg%kmin_,this%cfg%kmax_+1 + do jj=this%cfg%jmin_,this%cfg%jmax_+1 + do ii=this%cfg%imin_,this%cfg%imax_+1 + ! Fluxes on x-face + i=ii-1; j=jj-1; k=kk-1 + FX(i,j,k)=-this%rho*sum(this%itpu_x(:,i,j,k)*this%U(i:i+1,j,k))*sum(this%itpu_x(:,i,j,k)*this%U(i:i+1,j,k)) & + & +this%visc(i,j,k)*(sum(this%grdu_x(:,i,j,k)*this%U(i:i+1,j,k))+sum(this%grdu_x(:,i,j,k)*this%U(i:i+1,j,k)) & + & -2.0_WP/3.0_WP*(sum(this%divp_x(:,i,j,k)*this%U(i:i+1,j,k))+sum(this%divp_y(:,i,j,k)*this%V(i,j:j+1,k))+sum(this%divp_z(:,i,j,k)*this%W(i,j,k:k+1)))) & + & -this%P(i,j,k) + ! Fluxes on y-face + i=ii; j=jj; k=kk + FY(i,j,k)=-this%rho*sum(this%itpu_y(:,i,j,k)*this%U(i,j-1:j,k))*sum(this%itpv_x(:,i,j,k)*this%V(i-1:i,j,k)) & + & +sum(this%itp_xy(:,:,i,j,k)*this%visc(i-1:i,j-1:j,k))*(sum(this%grdu_y(:,i,j,k)*this%U(i,j-1:j,k))+sum(this%grdv_x(:,i,j,k)*this%V(i-1:i,j,k))) + ! Fluxes on z-face + i=ii; j=jj; k=kk + FZ(i,j,k)=-this%rho*sum(this%itpu_z(:,i,j,k)*this%U(i,j,k-1:k))*sum(this%itpw_x(:,i,j,k)*this%W(i-1:i,j,k)) & + & +sum(this%itp_xz(:,:,i,j,k)*this%visc(i-1:i,j,k-1:k))*(sum(this%grdu_z(:,i,j,k)*this%U(i,j,k-1:k))+sum(this%grdw_x(:,i,j,k)*this%W(i-1:i,j,k))) + end do + end do + end do + ! Time derivative of rhoU + do k=this%cfg%kmin_,this%cfg%kmax_ + do j=this%cfg%jmin_,this%cfg%jmax_ + do i=this%cfg%imin_,this%cfg%imax_ + drhoUdt(i,j,k)=sum(this%divu_x(:,i,j,k)*FX(i-1:i,j,k))+& + & sum(this%divu_y(:,i,j,k)*FY(i,j:j+1,k))+& + & sum(this%divu_z(:,i,j,k)*FZ(i,j,k:k+1)) + end do + end do + end do + ! Sync it + call this%cfg%sync(drhoUdt) + + ! Flux of rhoV + do kk=this%cfg%kmin_,this%cfg%kmax_+1 + do jj=this%cfg%jmin_,this%cfg%jmax_+1 + do ii=this%cfg%imin_,this%cfg%imax_+1 + ! Fluxes on x-face + i=ii; j=jj; k=kk + FX(i,j,k)=-this%rho*sum(this%itpv_x(:,i,j,k)*this%V(i-1:i,j,k))*sum(this%itpu_y(:,i,j,k)*this%U(i,j-1:j,k)) & + & +sum(this%itp_xy(:,:,i,j,k)*this%visc(i-1:i,j-1:j,k))*(sum(this%grdv_x(:,i,j,k)*this%V(i-1:i,j,k))+sum(this%grdu_y(:,i,j,k)*this%U(i,j-1:j,k))) + ! Fluxes on y-face + i=ii-1; j=jj-1; k=kk-1 + FY(i,j,k)=-this%rho*sum(this%itpv_y(:,i,j,k)*this%V(i,j:j+1,k))*sum(this%itpv_y(:,i,j,k)*this%V(i,j:j+1,k)) & + & +this%visc(i,j,k)*(sum(this%grdv_y(:,i,j,k)*this%V(i,j:j+1,k))+sum(this%grdv_y(:,i,j,k)*this%V(i,j:j+1,k)) & + & -2.0_WP/3.0_WP*(sum(this%divp_x(:,i,j,k)*this%U(i:i+1,j,k))+sum(this%divp_y(:,i,j,k)*this%V(i,j:j+1,k))+sum(this%divp_z(:,i,j,k)*this%W(i,j,k:k+1)))) & + & -this%P(i,j,k) + ! Fluxes on z-face + i=ii; j=jj; k=kk + FZ(i,j,k)=-this%rho*sum(this%itpv_z(:,i,j,k)*this%V(i,j,k-1:k))*sum(this%itpw_y(:,i,j,k)*this%W(i,j-1:j,k)) & + & +sum(this%itp_yz(:,:,i,j,k)*this%visc(i,j-1:j,k-1:k))*(sum(this%grdv_z(:,i,j,k)*this%V(i,j,k-1:k))+sum(this%grdw_y(:,i,j,k)*this%W(i,j-1:j,k))) + end do + end do + end do + ! Time derivative of rhoV + do k=this%cfg%kmin_,this%cfg%kmax_ + do j=this%cfg%jmin_,this%cfg%jmax_ + do i=this%cfg%imin_,this%cfg%imax_ + drhoVdt(i,j,k)=sum(this%divv_x(:,i,j,k)*FX(i:i+1,j,k))+& + & sum(this%divv_y(:,i,j,k)*FY(i,j-1:j,k))+& + & sum(this%divv_z(:,i,j,k)*FZ(i,j,k:k+1)) + end do + end do + end do + ! Sync it + call this%cfg%sync(drhoVdt) + + ! Flux of rhoW + do kk=this%cfg%kmin_,this%cfg%kmax_+1 + do jj=this%cfg%jmin_,this%cfg%jmax_+1 + do ii=this%cfg%imin_,this%cfg%imax_+1 + ! Fluxes on x-face + i=ii; j=jj; k=kk + FX(i,j,k)=-this%rho*sum(this%itpw_x(:,i,j,k)*this%W(i-1:i,j,k))*sum(this%itpu_z(:,i,j,k)*this%U(i,j,k-1:k)) & + & +sum(this%itp_xz(:,:,i,j,k)*this%visc(i-1:i,j,k-1:k))*(sum(this%grdw_x(:,i,j,k)*this%W(i-1:i,j,k))+sum(this%grdu_z(:,i,j,k)*this%U(i,j,k-1:k))) + ! Fluxes on y-face + i=ii; j=jj; k=kk + FY(i,j,k)=-this%rho*sum(this%itpw_y(:,i,j,k)*this%W(i,j-1:j,k))*sum(this%itpv_z(:,i,j,k)*this%V(i,j,k-1:k)) & + & +sum(this%itp_yz(:,:,i,j,k)*this%visc(i,j-1:j,k-1:k))*(sum(this%grdw_y(:,i,j,k)*this%W(i,j-1:j,k))+sum(this%grdv_z(:,i,j,k)*this%V(i,j,k-1:k))) + ! Fluxes on z-face + i=ii-1; j=jj-1; k=kk-1 + FZ(i,j,k)=-this%rho*sum(this%itpw_z(:,i,j,k)*this%W(i,j,k:k+1))*sum(this%itpw_z(:,i,j,k)*this%W(i,j,k:k+1)) & + & +this%visc(i,j,k)*(sum(this%grdw_z(:,i,j,k)*this%W(i,j,k:k+1))+sum(this%grdw_z(:,i,j,k)*this%W(i,j,k:k+1)) & + & -2.0_WP/3.0_WP*(sum(this%divp_x(:,i,j,k)*this%U(i:i+1,j,k))+sum(this%divp_y(:,i,j,k)*this%V(i,j:j+1,k))+sum(this%divp_z(:,i,j,k)*this%W(i,j,k:k+1)))) & + & -this%P(i,j,k) + end do + end do + end do + ! Time derivative of rhoW + do k=this%cfg%kmin_,this%cfg%kmax_ + do j=this%cfg%jmin_,this%cfg%jmax_ + do i=this%cfg%imin_,this%cfg%imax_ + drhoWdt(i,j,k)=sum(this%divw_x(:,i,j,k)*FX(i:i+1,j,k))+& + & sum(this%divw_y(:,i,j,k)*FY(i,j:j+1,k))+& + & sum(this%divw_z(:,i,j,k)*FZ(i,j,k-1:k)) + end do + end do + end do + ! Sync it + call this%cfg%sync(drhoWdt) + + ! Deallocate flux arrays + deallocate(FX,FY,FZ) + + end subroutine get_dmomdt + + !> Calculate divergence of stress for LPT solver + subroutine get_div_stress(this,divx,divy,divz) + implicit none + class(incomp), intent(inout) :: this + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(out) :: divx !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(out) :: divy !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(out) :: divz !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + integer :: i,j,k,ii,jj,kk + real(WP), dimension(:,:,:), allocatable :: FX,FY,FZ + + ! Zero out drhoUVW/dt arrays + divx=0.0_WP; divy=0.0_WP; divz=0.0_WP + + ! Allocate flux arrays + allocate(FX(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + allocate(FY(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + allocate(FZ(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + + ! Flux of rhoU + do kk=this%cfg%kmin_,this%cfg%kmax_+1 + do jj=this%cfg%jmin_,this%cfg%jmax_+1 + do ii=this%cfg%imin_,this%cfg%imax_+1 + ! Fluxes on x-face + i=ii-1; j=jj-1; k=kk-1 + FX(i,j,k)=this%visc(i,j,k)*(sum(this%grdu_x(:,i,j,k)*this%U(i:i+1,j,k))+sum(this%grdu_x(:,i,j,k)*this%U(i:i+1,j,k))) & + ! & -2.0_WP/3.0_WP*(sum(this%divp_x(:,i,j,k)*this%U(i:i+1,j,k))+sum(this%divp_y(:,i,j,k)*this%V(i,j:j+1,k))+sum(this%divp_z(:,i,j,k)*this%W(i,j,k:k+1)))) & + & -this%P(i,j,k) + ! Fluxes on y-face + i=ii; j=jj; k=kk + FY(i,j,k)=sum(this%itp_xy(:,:,i,j,k)*this%visc(i-1:i,j-1:j,k))*(sum(this%grdu_y(:,i,j,k)*this%U(i,j-1:j,k))+sum(this%grdv_x(:,i,j,k)*this%V(i-1:i,j,k))) + ! Fluxes on z-face + i=ii; j=jj; k=kk + FZ(i,j,k)=sum(this%itp_xz(:,:,i,j,k)*this%visc(i-1:i,j,k-1:k))*(sum(this%grdu_z(:,i,j,k)*this%U(i,j,k-1:k))+sum(this%grdw_x(:,i,j,k)*this%W(i-1:i,j,k))) + end do + end do + end do + ! Divergence of stresses + do k=this%cfg%kmin_,this%cfg%kmax_ + do j=this%cfg%jmin_,this%cfg%jmax_ + do i=this%cfg%imin_,this%cfg%imax_ + divx(i,j,k)=sum(this%divu_x(:,i,j,k)*FX(i-1:i,j,k))+& + & sum(this%divu_y(:,i,j,k)*FY(i,j:j+1,k))+& + & sum(this%divu_z(:,i,j,k)*FZ(i,j,k:k+1)) + end do + end do + end do + ! Sync it + call this%cfg%sync(divx) + + ! Flux of rhoV + do kk=this%cfg%kmin_,this%cfg%kmax_+1 + do jj=this%cfg%jmin_,this%cfg%jmax_+1 + do ii=this%cfg%imin_,this%cfg%imax_+1 + ! Fluxes on x-face + i=ii; j=jj; k=kk + FX(i,j,k)=sum(this%itp_xy(:,:,i,j,k)*this%visc(i-1:i,j-1:j,k))*(sum(this%grdv_x(:,i,j,k)*this%V(i-1:i,j,k))+sum(this%grdu_y(:,i,j,k)*this%U(i,j-1:j,k))) + ! Fluxes on y-face + i=ii-1; j=jj-1; k=kk-1 + FY(i,j,k)=this%visc(i,j,k)*(sum(this%grdv_y(:,i,j,k)*this%V(i,j:j+1,k))+sum(this%grdv_y(:,i,j,k)*this%V(i,j:j+1,k))) & + ! & -2.0_WP/3.0_WP*(sum(this%divp_x(:,i,j,k)*this%U(i:i+1,j,k))+sum(this%divp_y(:,i,j,k)*this%V(i,j:j+1,k))+sum(this%divp_z(:,i,j,k)*this%W(i,j,k:k+1)))) & + & -this%P(i,j,k) + ! Fluxes on z-face + i=ii; j=jj; k=kk + FZ(i,j,k)=sum(this%itp_yz(:,:,i,j,k)*this%visc(i,j-1:j,k-1:k))*(sum(this%grdv_z(:,i,j,k)*this%V(i,j,k-1:k))+sum(this%grdw_y(:,i,j,k)*this%W(i,j-1:j,k))) + end do + end do + end do + ! Divergence of stresses + do k=this%cfg%kmin_,this%cfg%kmax_ + do j=this%cfg%jmin_,this%cfg%jmax_ + do i=this%cfg%imin_,this%cfg%imax_ + divy(i,j,k)=sum(this%divv_x(:,i,j,k)*FX(i:i+1,j,k))+& + & sum(this%divv_y(:,i,j,k)*FY(i,j-1:j,k))+& + & sum(this%divv_z(:,i,j,k)*FZ(i,j,k:k+1)) + end do + end do + end do + ! Sync it + call this%cfg%sync(divy) + + ! Flux of rhoW + do kk=this%cfg%kmin_,this%cfg%kmax_+1 + do jj=this%cfg%jmin_,this%cfg%jmax_+1 + do ii=this%cfg%imin_,this%cfg%imax_+1 + ! Fluxes on x-face + i=ii; j=jj; k=kk + FX(i,j,k)=sum(this%itp_xz(:,:,i,j,k)*this%visc(i-1:i,j,k-1:k))*(sum(this%grdw_x(:,i,j,k)*this%W(i-1:i,j,k))+sum(this%grdu_z(:,i,j,k)*this%U(i,j,k-1:k))) + ! Fluxes on y-face + i=ii; j=jj; k=kk + FY(i,j,k)=sum(this%itp_yz(:,:,i,j,k)*this%visc(i,j-1:j,k-1:k))*(sum(this%grdw_y(:,i,j,k)*this%W(i,j-1:j,k))+sum(this%grdv_z(:,i,j,k)*this%V(i,j,k-1:k))) + ! Fluxes on z-face + i=ii-1; j=jj-1; k=kk-1 + FZ(i,j,k)=this%visc(i,j,k)*(sum(this%grdw_z(:,i,j,k)*this%W(i,j,k:k+1))+sum(this%grdw_z(:,i,j,k)*this%W(i,j,k:k+1))) & + ! & -2.0_WP/3.0_WP*(sum(this%divp_x(:,i,j,k)*this%U(i:i+1,j,k))+sum(this%divp_y(:,i,j,k)*this%V(i,j:j+1,k))+sum(this%divp_z(:,i,j,k)*this%W(i,j,k:k+1)))) & + & -this%P(i,j,k) + end do + end do + end do + ! Divergence of stresses + do k=this%cfg%kmin_,this%cfg%kmax_ + do j=this%cfg%jmin_,this%cfg%jmax_ + do i=this%cfg%imin_,this%cfg%imax_ + divz(i,j,k)=sum(this%divw_x(:,i,j,k)*FX(i:i+1,j,k))+& + & sum(this%divw_y(:,i,j,k)*FY(i,j:j+1,k))+& + & sum(this%divw_z(:,i,j,k)*FZ(i,j,k-1:k)) + end do + end do + end do + ! Sync it + call this%cfg%sync(divz) + + ! Deallocate flux arrays + deallocate(FX,FY,FZ) + + end subroutine get_div_stress + + + !> Calculate the velocity divergence based on U/V/W + subroutine get_div(this,src) + implicit none + class(incomp), intent(inout) :: this + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), optional :: src !< Mass source term + integer :: i,j,k + ! Calculate divergence of velocity + do k=this%cfg%kmin_,this%cfg%kmax_ + do j=this%cfg%jmin_,this%cfg%jmax_ + do i=this%cfg%imin_,this%cfg%imax_ + this%div(i,j,k)=sum(this%divp_x(:,i,j,k)*this%U(i:i+1,j,k))+& + & sum(this%divp_y(:,i,j,k)*this%V(i,j:j+1,k))+& + & sum(this%divp_z(:,i,j,k)*this%W(i,j,k:k+1)) + end do + end do + end do + ! If present, account for mass source + if (present(src)) then + do k=this%cfg%kmin_,this%cfg%kmax_ + do j=this%cfg%jmin_,this%cfg%jmax_ + do i=this%cfg%imin_,this%cfg%imax_ + this%div(i,j,k)=this%div(i,j,k)-src(i,j,k) + end do + end do + end do + end if + ! Sync it + call this%cfg%sync(this%div) + end subroutine get_div + + + !> Calculate the pressure gradient based on P + subroutine get_pgrad(this,P,Pgradx,Pgrady,Pgradz) + implicit none + class(incomp), intent(inout) :: this + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(in) :: P !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(out) :: Pgradx !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(out) :: Pgrady !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(out) :: Pgradz !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + integer :: i,j,k + Pgradx=0.0_WP; Pgrady=0.0_WP; Pgradz=0.0_WP + do k=this%cfg%kmin_,this%cfg%kmax_ + do j=this%cfg%jmin_,this%cfg%jmax_ + do i=this%cfg%imin_,this%cfg%imax_ + Pgradx(i,j,k)=sum(this%divu_x(:,i,j,k)*P(i-1:i,j,k)) + Pgrady(i,j,k)=sum(this%divv_y(:,i,j,k)*P(i,j-1:j,k)) + Pgradz(i,j,k)=sum(this%divw_z(:,i,j,k)*P(i,j,k-1:k)) + end do + end do + end do + ! Sync it + call this%cfg%sync(Pgradx) + call this%cfg%sync(Pgrady) + call this%cfg%sync(Pgradz) + end subroutine get_pgrad + + + !> Calculate the interpolated velocity, including overlap and ghosts + subroutine interp_vel(this,Ui,Vi,Wi) + implicit none + class(incomp), intent(inout) :: this + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(out) :: Ui !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(out) :: Vi !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(out) :: Wi !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + integer :: i,j,k + ! Calculate as far as possible each component + do k=this%cfg%kmino_,this%cfg%kmaxo_ + do j=this%cfg%jmino_,this%cfg%jmaxo_ + do i=this%cfg%imino_,this%cfg%imaxo_-1 + Ui(i,j,k)=sum(this%itpu_x(:,i,j,k)*this%U(i:i+1,j,k)) + end do + end do + end do + do k=this%cfg%kmino_,this%cfg%kmaxo_ + do j=this%cfg%jmino_,this%cfg%jmaxo_-1 + do i=this%cfg%imino_,this%cfg%imaxo_ + Vi(i,j,k)=sum(this%itpv_y(:,i,j,k)*this%V(i,j:j+1,k)) + end do + end do + end do + do k=this%cfg%kmino_,this%cfg%kmaxo_-1 + do j=this%cfg%jmino_,this%cfg%jmaxo_ + do i=this%cfg%imino_,this%cfg%imaxo_ + Wi(i,j,k)=sum(this%itpw_z(:,i,j,k)*this%W(i,j,k:k+1)) + end do + end do + end do + ! Add last layer in each direction + if (.not.this%cfg%xper.and.this%cfg%iproc.eq.this%cfg%npx) Ui(this%cfg%imaxo,:,:)=this%U(this%cfg%imaxo,:,:) + if (.not.this%cfg%yper.and.this%cfg%jproc.eq.this%cfg%npy) Vi(:,this%cfg%jmaxo,:)=this%V(:,this%cfg%jmaxo,:) + if (.not.this%cfg%zper.and.this%cfg%kproc.eq.this%cfg%npz) Wi(:,:,this%cfg%kmaxo)=this%W(:,:,this%cfg%kmaxo) + ! Sync it + call this%cfg%sync(Ui) + call this%cfg%sync(Vi) + call this%cfg%sync(Wi) + end subroutine interp_vel + + + !> Calculate the deviatoric part of the strain rate tensor from U/V/W + !> 1: du/dx-div/3 + !> 2: dv/dy-div/3 + !> 3: dw/dz-div/3 + !> 4: (du/dy+dv/dx)/2 + !> 5: (dv/dz+dw/dy)/2 + !> 6: (dw/dx+du/dz)/2 + subroutine get_strainrate(this,SR) + use messager, only: die + implicit none + class(incomp), intent(inout) :: this + real(WP), dimension(1:,this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(out) :: SR !< Needs to be (1:6,imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + real(WP), dimension(:,:,:), allocatable :: dudy,dudz,dvdx,dvdz,dwdx,dwdy + real(WP) :: div + integer :: i,j,k + + ! Check SR's first dimension + if (size(SR,dim=1).ne.6) call die('[incomp get_strainrate] SR should be of size (1:6,imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_)') + + ! Compute dudx, dvdy, and dwdz first + do k=this%cfg%kmin_,this%cfg%kmax_ + do j=this%cfg%jmin_,this%cfg%jmax_ + do i=this%cfg%imin_,this%cfg%imax_ + SR(1,i,j,k)=sum(this%grdu_x(:,i,j,k)*this%U(i:i+1,j,k)) + SR(2,i,j,k)=sum(this%grdv_y(:,i,j,k)*this%V(i,j:j+1,k)) + SR(3,i,j,k)=sum(this%grdw_z(:,i,j,k)*this%W(i,j,k:k+1)) + div=sum(SR(1:3,i,j,k))/3.0_WP + SR(1,i,j,k)=SR(1,i,j,k)-div + SR(2,i,j,k)=SR(2,i,j,k)-div + SR(3,i,j,k)=SR(3,i,j,k)-div + end do + end do + end do + + ! Allocate velocity gradient components + allocate(dudy(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + allocate(dudz(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + allocate(dvdx(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + allocate(dvdz(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + allocate(dwdx(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + allocate(dwdy(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + + ! Calculate components of the velocity gradient at their natural locations with an extra cell for interpolation + do k=this%cfg%kmin_,this%cfg%kmax_+1 + do j=this%cfg%jmin_,this%cfg%jmax_+1 + do i=this%cfg%imin_,this%cfg%imax_+1 + dudy(i,j,k)=sum(this%grdu_y(:,i,j,k)*this%U(i,j-1:j,k)) + dudz(i,j,k)=sum(this%grdu_z(:,i,j,k)*this%U(i,j,k-1:k)) + dvdx(i,j,k)=sum(this%grdv_x(:,i,j,k)*this%V(i-1:i,j,k)) + dvdz(i,j,k)=sum(this%grdv_z(:,i,j,k)*this%V(i,j,k-1:k)) + dwdx(i,j,k)=sum(this%grdw_x(:,i,j,k)*this%W(i-1:i,j,k)) + dwdy(i,j,k)=sum(this%grdw_y(:,i,j,k)*this%W(i,j-1:j,k)) + end do + end do + end do + + ! Interpolate off-diagonal components of the velocity gradient to the cell center and store strain rate + do k=this%cfg%kmin_,this%cfg%kmax_ + do j=this%cfg%jmin_,this%cfg%jmax_ + do i=this%cfg%imin_,this%cfg%imax_ + SR(4,i,j,k)=0.125_WP*(sum(dudy(i:i+1,j:j+1,k ))+sum(dvdx(i:i+1,j:j+1,k ))) + SR(5,i,j,k)=0.125_WP*(sum(dvdz(i ,j:j+1,k:k+1))+sum(dwdy(i ,j:j+1,k:k+1))) + SR(6,i,j,k)=0.125_WP*(sum(dwdx(i:i+1,j ,k:k+1))+sum(dudz(i:i+1,j ,k:k+1))) + end do + end do + end do + + ! Apply a Neumann condition in non-periodic directions + if (.not.this%cfg%xper) then + if (this%cfg%iproc.eq.1) SR(:,this%cfg%imin-1,:,:)=SR(:,this%cfg%imin,:,:) + if (this%cfg%iproc.eq.this%cfg%npx) SR(:,this%cfg%imax+1,:,:)=SR(:,this%cfg%imax,:,:) + end if + if (.not.this%cfg%yper) then + if (this%cfg%jproc.eq.1) SR(:,:,this%cfg%jmin-1,:)=SR(:,:,this%cfg%jmin,:) + if (this%cfg%jproc.eq.this%cfg%npy) SR(:,:,this%cfg%jmax+1,:)=SR(:,:,this%cfg%jmax,:) + end if + if (.not.this%cfg%zper) then + if (this%cfg%kproc.eq.1) SR(:,:,:,this%cfg%kmin-1)=SR(:,:,:,this%cfg%kmin) + if (this%cfg%kproc.eq.this%cfg%npz) SR(:,:,:,this%cfg%kmax+1)=SR(:,:,:,this%cfg%kmax) + end if + + ! Ensure zero in walls + do k=this%cfg%kmino_,this%cfg%kmaxo_ + do j=this%cfg%jmino_,this%cfg%jmaxo_ + do i=this%cfg%imino_,this%cfg%imaxo_ + if (this%mask(i,j,k).eq.1) SR(:,i,j,k)=0.0_WP + end do + end do + end do + + ! Sync it + call this%cfg%sync(SR) + + ! Deallocate velocity gradient storage + deallocate(dudy,dudz,dvdx,dvdz,dwdx,dwdy) + + end subroutine get_strainrate + + + !> Calculate the velocity gradient tensor from U/V/W + !> Note that gradu(i,j)=duj/dxi + subroutine get_gradu(this,gradu) + use messager, only: die + implicit none + class(incomp), intent(inout) :: this + real(WP), dimension(1:,1:,this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(out) :: gradu !< Needs to be (1:3,1:3,imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + integer :: i,j,k + real(WP), dimension(:,:,:), allocatable :: dudy,dudz,dvdx,dvdz,dwdx,dwdy + + ! Check gradu's first two dimensions + if (size(gradu,dim=1).ne.3.or.size(gradu,dim=2).ne.3) call die('[incomp get_gradu] gradu should be of size (1:3,1:3,imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_)') + + ! Compute dudx, dvdy, and dwdz first + do k=this%cfg%kmin_,this%cfg%kmax_ + do j=this%cfg%jmin_,this%cfg%jmax_ + do i=this%cfg%imin_,this%cfg%imax_ + gradu(1,1,i,j,k)=sum(this%grdu_x(:,i,j,k)*this%U(i:i+1,j,k)) + gradu(2,2,i,j,k)=sum(this%grdv_y(:,i,j,k)*this%V(i,j:j+1,k)) + gradu(3,3,i,j,k)=sum(this%grdw_z(:,i,j,k)*this%W(i,j,k:k+1)) + end do + end do + end do + + ! Allocate velocity gradient components + allocate(dudy(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + allocate(dudz(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + allocate(dvdx(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + allocate(dvdz(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + allocate(dwdx(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + allocate(dwdy(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + + ! Calculate components of the velocity gradient at their natural locations with an extra cell for interpolation + do k=this%cfg%kmin_,this%cfg%kmax_+1 + do j=this%cfg%jmin_,this%cfg%jmax_+1 + do i=this%cfg%imin_,this%cfg%imax_+1 + dudy(i,j,k)=sum(this%grdu_y(:,i,j,k)*this%U(i,j-1:j,k)) + dudz(i,j,k)=sum(this%grdu_z(:,i,j,k)*this%U(i,j,k-1:k)) + dvdx(i,j,k)=sum(this%grdv_x(:,i,j,k)*this%V(i-1:i,j,k)) + dvdz(i,j,k)=sum(this%grdv_z(:,i,j,k)*this%V(i,j,k-1:k)) + dwdx(i,j,k)=sum(this%grdw_x(:,i,j,k)*this%W(i-1:i,j,k)) + dwdy(i,j,k)=sum(this%grdw_y(:,i,j,k)*this%W(i,j-1:j,k)) + end do + end do + end do + + ! Interpolate off-diagonal components of the velocity gradient to the cell center + do k=this%cfg%kmin_,this%cfg%kmax_ + do j=this%cfg%jmin_,this%cfg%jmax_ + do i=this%cfg%imin_,this%cfg%imax_ + gradu(2,1,i,j,k)=0.25_WP*sum(dudy(i:i+1,j:j+1,k)) + gradu(3,1,i,j,k)=0.25_WP*sum(dudz(i:i+1,j,k:k+1)) + gradu(1,2,i,j,k)=0.25_WP*sum(dvdx(i:i+1,j:j+1,k)) + gradu(3,2,i,j,k)=0.25_WP*sum(dvdz(i,j:j+1,k:k+1)) + gradu(1,3,i,j,k)=0.25_WP*sum(dwdx(i:i+1,j,k:k+1)) + gradu(2,3,i,j,k)=0.25_WP*sum(dwdy(i,j:j+1,k:k+1)) + end do + end do + end do + + ! Apply a Neumann condition in non-periodic directions + if (.not.this%cfg%xper) then + if (this%cfg%iproc.eq.1) gradu(:,:,this%cfg%imin-1,:,:)=gradu(:,:,this%cfg%imin,:,:) + if (this%cfg%iproc.eq.this%cfg%npx) gradu(:,:,this%cfg%imax+1,:,:)=gradu(:,:,this%cfg%imax,:,:) + end if + if (.not.this%cfg%yper) then + if (this%cfg%jproc.eq.1) gradu(:,:,:,this%cfg%jmin-1,:)=gradu(:,:,:,this%cfg%jmin,:) + if (this%cfg%jproc.eq.this%cfg%npy) gradu(:,:,:,this%cfg%jmax+1,:)=gradu(:,:,:,this%cfg%jmax,:) + end if + if (.not.this%cfg%zper) then + if (this%cfg%kproc.eq.1) gradu(:,:,:,:,this%cfg%kmin-1)=gradu(:,:,:,:,this%cfg%kmin) + if (this%cfg%kproc.eq.this%cfg%npz) gradu(:,:,:,:,this%cfg%kmax+1)=gradu(:,:,:,:,this%cfg%kmax) + end if + + ! Ensure zero in walls + do k=this%cfg%kmino_,this%cfg%kmaxo_ + do j=this%cfg%jmino_,this%cfg%jmaxo_ + do i=this%cfg%imino_,this%cfg%imaxo_ + if (this%mask(i,j,k).eq.1) gradu(:,:,i,j,k)=0.0_WP + end do + end do + end do + + ! Sync it + call this%cfg%sync(gradu) + + ! Deallocate velocity gradient storage + deallocate(dudy,dudz,dvdx,dvdz,dwdx,dwdy) + + end subroutine get_gradu + + + !> Calculate vorticity vector + subroutine get_vorticity(this,vort) + use messager, only: die + implicit none + class(incomp), intent(inout) :: this + real(WP), dimension(1:,this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(out) :: vort !< Needs to be (1:3,imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + integer :: i,j,k + real(WP), dimension(:,:,:), allocatable :: dudy,dudz,dvdx,dvdz,dwdx,dwdy + + ! Check vort's first two dimensions + if (size(vort,dim=1).ne.3) call die('[incomp get_vorticity] vort should be of size (1:3,imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_)') + + ! Allocate velocity gradient components + allocate(dudy(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + allocate(dudz(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + allocate(dvdx(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + allocate(dvdz(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + allocate(dwdx(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + allocate(dwdy(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + + ! Calculate components of the velocity gradient at their natural locations with an extra cell for interpolation + do k=this%cfg%kmin_,this%cfg%kmax_+1 + do j=this%cfg%jmin_,this%cfg%jmax_+1 + do i=this%cfg%imin_,this%cfg%imax_+1 + dudy(i,j,k)=sum(this%grdu_y(:,i,j,k)*this%U(i,j-1:j,k)) + dudz(i,j,k)=sum(this%grdu_z(:,i,j,k)*this%U(i,j,k-1:k)) + dvdx(i,j,k)=sum(this%grdv_x(:,i,j,k)*this%V(i-1:i,j,k)) + dvdz(i,j,k)=sum(this%grdv_z(:,i,j,k)*this%V(i,j,k-1:k)) + dwdx(i,j,k)=sum(this%grdw_x(:,i,j,k)*this%W(i-1:i,j,k)) + dwdy(i,j,k)=sum(this%grdw_y(:,i,j,k)*this%W(i,j-1:j,k)) + end do + end do + end do + + ! Interpolate off-diagonal components of the velocity gradient to the cell center + do k=this%cfg%kmin_,this%cfg%kmax_ + do j=this%cfg%jmin_,this%cfg%jmax_ + do i=this%cfg%imin_,this%cfg%imax_ + vort(1,i,j,k)=0.25_WP*(sum(dwdy(i,j:j+1,k:k+1))-sum(dvdz(i,j:j+1,k:k+1))) + vort(2,i,j,k)=0.25_WP*(sum(dudz(i:i+1,j,k:k+1))-sum(dwdx(i:i+1,j,k:k+1))) + vort(3,i,j,k)=0.25_WP*(sum(dvdx(i:i+1,j:j+1,k))-sum(dudy(i:i+1,j:j+1,k))) + end do + end do + end do + + ! Apply a Neumann condition in non-periodic directions + if (.not.this%cfg%xper) then + if (this%cfg%iproc.eq.1) vort(:,this%cfg%imin-1,:,:)=vort(:,this%cfg%imin,:,:) + if (this%cfg%iproc.eq.this%cfg%npx) vort(:,this%cfg%imax+1,:,:)=vort(:,this%cfg%imax,:,:) + end if + if (.not.this%cfg%yper) then + if (this%cfg%jproc.eq.1) vort(:,:,this%cfg%jmin-1,:)=vort(:,:,this%cfg%jmin,:) + if (this%cfg%jproc.eq.this%cfg%npy) vort(:,:,this%cfg%jmax+1,:)=vort(:,:,this%cfg%jmax,:) + end if + if (.not.this%cfg%zper) then + if (this%cfg%kproc.eq.1) vort(:,:,:,this%cfg%kmin-1)=vort(:,:,:,this%cfg%kmin) + if (this%cfg%kproc.eq.this%cfg%npz) vort(:,:,:,this%cfg%kmax+1)=vort(:,:,:,this%cfg%kmax) + end if + + ! Ensure zero in walls + do k=this%cfg%kmino_,this%cfg%kmaxo_ + do j=this%cfg%jmino_,this%cfg%jmaxo_ + do i=this%cfg%imino_,this%cfg%imaxo_ + if (this%mask(i,j,k).eq.1) vort(:,i,j,k)=0.0_WP + end do + end do + end do + + ! Sync it + call this%cfg%sync(vort) + + ! Deallocate velocity gradient storage + deallocate(dudy,dudz,dvdx,dvdz,dwdx,dwdy) + + end subroutine get_vorticity + + + !> Calculate the CFL + subroutine get_cfl(this,dt,cflc,cfl) + use mpi_f08, only: MPI_ALLREDUCE,MPI_MAX + use parallel, only: MPI_REAL_WP + implicit none + class(incomp), intent(inout) :: this + real(WP), intent(in) :: dt + real(WP), intent(out) :: cflc + real(WP), optional :: cfl + integer :: i,j,k,ierr + real(WP) :: my_CFLc_x,my_CFLc_y,my_CFLc_z,my_CFLv_x,my_CFLv_y,my_CFLv_z + + ! Set the CFLs to zero + my_CFLc_x=0.0_WP; my_CFLc_y=0.0_WP; my_CFLc_z=0.0_WP + my_CFLv_x=0.0_WP; my_CFLv_y=0.0_WP; my_CFLv_z=0.0_WP + do k=this%cfg%kmin_,this%cfg%kmax_ + do j=this%cfg%jmin_,this%cfg%jmax_ + do i=this%cfg%imin_,this%cfg%imax_ + my_CFLc_x=max(my_CFLc_x,abs(this%U(i,j,k))*this%cfg%dxmi(i)) + my_CFLc_y=max(my_CFLc_y,abs(this%V(i,j,k))*this%cfg%dymi(j)) + my_CFLc_z=max(my_CFLc_z,abs(this%W(i,j,k))*this%cfg%dzmi(k)) + my_CFLv_x=max(my_CFLv_x,4.0_WP*this%visc(i,j,k)*this%cfg%dxi(i)**2/this%rho) + my_CFLv_y=max(my_CFLv_y,4.0_WP*this%visc(i,j,k)*this%cfg%dyi(j)**2/this%rho) + my_CFLv_z=max(my_CFLv_z,4.0_WP*this%visc(i,j,k)*this%cfg%dzi(k)**2/this%rho) + end do + end do + end do + my_CFLc_x=my_CFLc_x*dt; my_CFLc_y=my_CFLc_y*dt; my_CFLc_z=my_CFLc_z*dt + my_CFLv_x=my_CFLv_x*dt; my_CFLv_y=my_CFLv_y*dt; my_CFLv_z=my_CFLv_z*dt + + ! Get the parallel max + call MPI_ALLREDUCE(my_CFLc_x,this%CFLc_x,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + call MPI_ALLREDUCE(my_CFLc_y,this%CFLc_y,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + call MPI_ALLREDUCE(my_CFLc_z,this%CFLc_z,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + call MPI_ALLREDUCE(my_CFLv_x,this%CFLv_x,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + call MPI_ALLREDUCE(my_CFLv_y,this%CFLv_y,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + call MPI_ALLREDUCE(my_CFLv_z,this%CFLv_z,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + + ! Return the maximum convective CFL + cflc=max(this%CFLc_x,this%CFLc_y,this%CFLc_z) + + ! If asked for, also return the maximum overall CFL + if (present(CFL)) cfl=max(this%CFLc_x,this%CFLc_y,this%CFLc_z,this%CFLv_x,this%CFLv_y,this%CFLv_z) + + end subroutine get_cfl + + + !> Calculate the max of our fields + subroutine get_max(this) + use mpi_f08, only: MPI_ALLREDUCE,MPI_MAX + use parallel, only: MPI_REAL_WP + implicit none + class(incomp), intent(inout) :: this + integer :: i,j,k,ierr + real(WP) :: my_Umax,my_Vmax,my_Wmax,my_Pmax,my_divmax + + ! Set all to zero + my_Umax=0.0_WP; my_Vmax=0.0_WP; my_Wmax=0.0_WP; my_Pmax=0.0_WP; my_divmax=0.0_WP + do k=this%cfg%kmin_,this%cfg%kmax_ + do j=this%cfg%jmin_,this%cfg%jmax_ + do i=this%cfg%imin_,this%cfg%imax_ + my_Umax =max(my_Umax ,abs(this%U(i,j,k) )) + my_Vmax =max(my_Vmax ,abs(this%V(i,j,k) )) + my_Wmax =max(my_Wmax ,abs(this%W(i,j,k) )) + if (this%cfg%VF(i,j,k).gt.0.0_WP) my_Pmax =max(my_Pmax ,abs(this%P(i,j,k) )) + if (this%cfg%VF(i,j,k).gt.0.0_WP) my_divmax=max(my_divmax,abs(this%div(i,j,k))) + end do + end do + end do + + ! Get the parallel max + call MPI_ALLREDUCE(my_Umax ,this%Umax ,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + call MPI_ALLREDUCE(my_Vmax ,this%Vmax ,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + call MPI_ALLREDUCE(my_Wmax ,this%Wmax ,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + call MPI_ALLREDUCE(my_Pmax ,this%Pmax ,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + call MPI_ALLREDUCE(my_divmax,this%divmax,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + + end subroutine get_max + + + !> Compute MFR through all bcs + subroutine get_mfr(this) + use mpi_f08, only: MPI_SUM,MPI_ALLREDUCE + use parallel, only: MPI_REAL_WP + implicit none + class(incomp), intent(inout) :: this + integer :: i,j,k,n,ibc,ierr + type(bcond), pointer :: my_bc + real(WP), dimension(:), allocatable :: my_mfr,my_area + real(WP), dimension(:), allocatable :: canCorrect + + ! Ensure this%mfr is of proper size + if (.not.allocated(this%mfr)) then + allocate(this%mfr(this%nbc)) + else + if (size(this%mfr).ne.this%nbc) then + deallocate(this%mfr); allocate(this%mfr(this%nbc)) + end if + end if + + ! Ensure this%area is of proper size + if (.not.allocated(this%area)) then + allocate(this%area(this%nbc)) + else + if (size(this%area).ne.this%nbc) then + deallocate(this%area); allocate(this%area(this%nbc)) + end if + end if + + ! Allocate temp array for communication + allocate(my_mfr(this%nbc)) + allocate(my_area(this%nbc)) + allocate(canCorrect(this%nbc)) + + ! Traverse bcond list and integrate local outgoing MFR + my_bc=>this%first_bc; ibc=1 + do while (associated(my_bc)) + + ! Set zero local MFR and area + my_mfr(ibc)=0.0_WP + my_area(ibc)=0.0_WP + if (my_bc%canCorrect) then + canCorrect(ibc)=1.0_WP + else + canCorrect(ibc)=0.0_WP + end if + + ! Only processes inside the bcond have a non-zero MFR + if (my_bc%itr%amIn) then + + ! Implement based on bcond face and dir, loop over interior only + select case (my_bc%face) + case ('x') + do n=1,my_bc%itr%n_ + i=my_bc%itr%map(1,n); j=my_bc%itr%map(2,n); k=my_bc%itr%map(3,n) + my_mfr(ibc)=my_mfr(ibc)+my_bc%rdir*this%rho*this%U(i,j,k)*this%cfg%dy(j)*this%cfg%dz(k) + my_area(ibc)=my_area(ibc)+this%cfg%dy(j)*this%cfg%dz(k) + end do + case ('y') + do n=1,my_bc%itr%n_ + i=my_bc%itr%map(1,n); j=my_bc%itr%map(2,n); k=my_bc%itr%map(3,n) + my_mfr(ibc)=my_mfr(ibc)+my_bc%rdir*this%rho*this%V(i,j,k)*this%cfg%dz(k)*this%cfg%dx(i) + my_area(ibc)=my_area(ibc)+this%cfg%dz(k)*this%cfg%dx(i) + end do + case ('z') + do n=1,my_bc%itr%n_ + i=my_bc%itr%map(1,n); j=my_bc%itr%map(2,n); k=my_bc%itr%map(3,n) + my_mfr(ibc)=my_mfr(ibc)+my_bc%rdir*this%rho*this%W(i,j,k)*this%cfg%dx(i)*this%cfg%dy(j) + my_area(ibc)=my_area(ibc)+this%cfg%dx(i)*this%cfg%dy(j) + end do + end select + + end if + + ! Move on to the next bcond + my_bc=>my_bc%next; ibc=ibc+1 + + end do + + ! Sum up all values + call MPI_ALLREDUCE(my_mfr ,this%mfr ,this%nbc,MPI_REAL_WP,MPI_SUM,this%cfg%comm,ierr) + call MPI_ALLREDUCE(my_area,this%area,this%nbc,MPI_REAL_WP,MPI_SUM,this%cfg%comm,ierr) + + ! Compute the correctable area + this%correctable_area=sum(this%area*canCorrect) + + ! Deallocate temp array + deallocate(my_mfr,my_area,canCorrect) + + end subroutine get_mfr + + + !> Correct MFR through correctable bconds + subroutine correct_mfr(this,src) + use mpi_f08, only: MPI_SUM + implicit none + class(incomp), intent(inout) :: this + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), optional :: src !< Mass source term + real(WP) :: mfr_error,vel_correction,int + integer :: i,j,k,n + type(bcond), pointer :: my_bc + + ! Evaluate MFR mismatch and velocity correction + call this%get_mfr() + mfr_error=sum(this%mfr) + if (present(src)) then + ! Also account for provided source term + call this%cfg%integrate_without_VF(src,int) + mfr_error=mfr_error-int + end if + if (abs(mfr_error).lt.10.0_WP*epsilon(1.0_WP).or.abs(this%correctable_area).lt.10.0_WP*epsilon(1.0_WP)) return + vel_correction=-mfr_error/(this%rho*this%correctable_area) + + ! Traverse bcond list and correct bcond MFR + my_bc=>this%first_bc + do while (associated(my_bc)) + + ! Only processes inside correctable bcond need to work + if (my_bc%itr%amIn.and.my_bc%canCorrect) then + + ! Implement based on bcond direction, loop over all cell + select case (my_bc%face) + case ('x') + do n=1,my_bc%itr%n_ + i=my_bc%itr%map(1,n); j=my_bc%itr%map(2,n); k=my_bc%itr%map(3,n) + this%U(i,j,k)=this%U(i,j,k)+my_bc%rdir*vel_correction + end do + case ('y') + do n=1,my_bc%itr%n_ + i=my_bc%itr%map(1,n); j=my_bc%itr%map(2,n); k=my_bc%itr%map(3,n) + this%V(i,j,k)=this%V(i,j,k)+my_bc%rdir*vel_correction + end do + case ('z') + do n=1,my_bc%itr%n_ + i=my_bc%itr%map(1,n); j=my_bc%itr%map(2,n); k=my_bc%itr%map(3,n) + this%W(i,j,k)=this%W(i,j,k)+my_bc%rdir*vel_correction + end do + end select + + end if + + ! Move on to the next bcond + my_bc=>my_bc%next + + end do + + ! Sync full fields + call this%cfg%sync(this%U) + call this%cfg%sync(this%V) + call this%cfg%sync(this%W) + + end subroutine correct_mfr + + + !> Shift pressure to ensure zero average + subroutine shift_p(this,pressure) + implicit none + class(incomp), intent(in) :: this + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(inout) :: pressure !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + real(WP) :: pressure_tot + integer :: i,j,k + + ! Compute volume-averaged pressure + call this%cfg%integrate(A=pressure,integral=pressure_tot); pressure_tot=pressure_tot/this%cfg%fluid_vol + + ! Shift the pressure + do k=this%cfg%kmin_,this%cfg%kmax_ + do j=this%cfg%jmin_,this%cfg%jmax_ + do i=this%cfg%imin_,this%cfg%imax_ + if (this%cfg%VF(i,j,k).gt.0.0_WP) pressure(i,j,k)=pressure(i,j,k)-pressure_tot + end do + end do + end do + call this%cfg%sync(pressure) + + end subroutine shift_p + + + !> Solve for implicit velocity residual + subroutine solve_implicit(this,dt,resU,resV,resW) + implicit none + class(incomp), intent(inout) :: this + real(WP), intent(in) :: dt + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(inout) :: resU !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(inout) :: resV !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(inout) :: resW !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + integer :: i,j,k + real(WP) :: rhoUp,rhoUm,rhoVp,rhoVm,rhoWp,rhoWm + + ! If no implicit solver available, just divide by density and return + if (.not.associated(this%implicit)) then + resU=resU/this%rho + resV=resV/this%rho + resW=resW/this%rho + call this%cfg%sync(resU) + call this%cfg%sync(resV) + call this%cfg%sync(resW) + return + end if + + ! Solve implicit U problem + this%implicit%opr(1,:,:,:)=this%rho; this%implicit%opr(2:,:,:,:)=0.0_WP + do k=this%cfg%kmin_,this%cfg%kmax_ + do j=this%cfg%jmin_,this%cfg%jmax_ + do i=this%cfg%imin_,this%cfg%imax_ + rhoUp=this%rho*sum(this%itpu_x(:,i ,j,k)*this%U(i :i+1,j,k))*2.0_WP + rhoUm=this%rho*sum(this%itpu_x(:,i-1,j,k)*this%U(i-1:i ,j,k))*2.0_WP + rhoVp=this%rho*sum(this%itpv_x(:,i,j+1,k)*this%V(i-1:i,j+1,k)) + rhoVm=this%rho*sum(this%itpv_x(:,i,j ,k)*this%V(i-1:i,j ,k)) + rhoWp=this%rho*sum(this%itpw_x(:,i,j,k+1)*this%W(i-1:i,j,k+1)) + rhoWm=this%rho*sum(this%itpw_x(:,i,j,k )*this%W(i-1:i,j,k )) + this%implicit%opr(1,i,j,k)=this%implicit%opr(1,i,j,k)+0.5_WP*dt*(this%divu_x( 0,i,j,k)*this%itpu_x( 0,i ,j,k)*rhoUp+& + & this%divu_x(-1,i,j,k)*this%itpu_x(+1,i-1,j,k)*rhoUm+& + & this%divu_y(+1,i,j,k)*this%itpu_y(-1,i,j+1,k)*rhoVp+& + & this%divu_y( 0,i,j,k)*this%itpu_y( 0,i,j ,k)*rhoVm+& + & this%divu_z(+1,i,j,k)*this%itpu_z(-1,i,j,k+1)*rhoWp+& + & this%divu_z( 0,i,j,k)*this%itpu_z( 0,i,j,k )*rhoWm) + this%implicit%opr(2,i,j,k)=this%implicit%opr(2,i,j,k)+0.5_WP*dt*(this%divu_x( 0,i,j,k)*this%itpu_x(+1,i ,j,k)*rhoUp) + this%implicit%opr(3,i,j,k)=this%implicit%opr(3,i,j,k)+0.5_WP*dt*(this%divu_x(-1,i,j,k)*this%itpu_x( 0,i-1,j,k)*rhoUm) + this%implicit%opr(4,i,j,k)=this%implicit%opr(4,i,j,k)+0.5_WP*dt*(this%divu_y(+1,i,j,k)*this%itpu_y( 0,i,j+1,k)*rhoVp) + this%implicit%opr(5,i,j,k)=this%implicit%opr(5,i,j,k)+0.5_WP*dt*(this%divu_y( 0,i,j,k)*this%itpu_y(-1,i,j ,k)*rhoVm) + this%implicit%opr(6,i,j,k)=this%implicit%opr(6,i,j,k)+0.5_WP*dt*(this%divu_z(+1,i,j,k)*this%itpu_z( 0,i,j,k+1)*rhoWp) + this%implicit%opr(7,i,j,k)=this%implicit%opr(7,i,j,k)+0.5_WP*dt*(this%divu_z( 0,i,j,k)*this%itpu_z(-1,i,j,k )*rhoWm) + end do + end do + end do + do k=this%cfg%kmin_,this%cfg%kmax_ + do j=this%cfg%jmin_,this%cfg%jmax_ + do i=this%cfg%imin_,this%cfg%imax_ + this%implicit%opr(1,i,j,k)=this%implicit%opr(1,i,j,k)-0.5_WP*dt*(this%divu_x( 0,i,j,k)*4.0_WP/3.0_WP* this%visc(i ,j,k) *this%grdu_x( 0,i ,j,k)+& + & this%divu_x(-1,i,j,k)*4.0_WP/3.0_WP* this%visc(i-1,j,k) *this%grdu_x(+1,i-1,j,k)+& + & this%divu_y(+1,i,j,k)*sum(this%itp_xy(:,:,i,j+1,k)*this%visc(i-1:i,j:j+1,k))*this%grdu_y(-1,i,j+1,k)+& + & this%divu_y( 0,i,j,k)*sum(this%itp_xy(:,:,i,j ,k)*this%visc(i-1:i,j-1:j,k))*this%grdu_y( 0,i,j ,k)+& + & this%divu_z(+1,i,j,k)*sum(this%itp_xz(:,:,i,j,k+1)*this%visc(i-1:i,j,k:k+1))*this%grdu_z(-1,i,j,k+1)+& + & this%divu_z( 0,i,j,k)*sum(this%itp_xz(:,:,i,j,k )*this%visc(i-1:i,j,k-1:k))*this%grdu_z( 0,i,j,k )) + this%implicit%opr(2,i,j,k)=this%implicit%opr(2,i,j,k)-0.5_WP*dt*(this%divu_x( 0,i,j,k)*4.0_WP/3.0_WP* this%visc(i ,j,k) *this%grdu_x(+1,i ,j,k)) + this%implicit%opr(3,i,j,k)=this%implicit%opr(3,i,j,k)-0.5_WP*dt*(this%divu_x(-1,i,j,k)*4.0_WP/3.0_WP* this%visc(i-1,j,k) *this%grdu_x( 0,i-1,j,k)) + this%implicit%opr(4,i,j,k)=this%implicit%opr(4,i,j,k)-0.5_WP*dt*(this%divu_y(+1,i,j,k)*sum(this%itp_xy(:,:,i,j+1,k)*this%visc(i-1:i,j:j+1,k))*this%grdu_y( 0,i,j+1,k)) + this%implicit%opr(5,i,j,k)=this%implicit%opr(5,i,j,k)-0.5_WP*dt*(this%divu_y( 0,i,j,k)*sum(this%itp_xy(:,:,i,j ,k)*this%visc(i-1:i,j-1:j,k))*this%grdu_y(-1,i,j ,k)) + this%implicit%opr(6,i,j,k)=this%implicit%opr(6,i,j,k)-0.5_WP*dt*(this%divu_z(+1,i,j,k)*sum(this%itp_xz(:,:,i,j,k+1)*this%visc(i-1:i,j,k:k+1))*this%grdu_z( 0,i,j,k+1)) + this%implicit%opr(7,i,j,k)=this%implicit%opr(7,i,j,k)-0.5_WP*dt*(this%divu_z( 0,i,j,k)*sum(this%itp_xz(:,:,i,j,k )*this%visc(i-1:i,j,k-1:k))*this%grdu_z(-1,i,j,k )) + end do + end do + end do + call this%implicit%setup() + this%implicit%rhs=resU + this%implicit%sol=0.0_WP + call this%implicit%solve() + resU=this%implicit%sol + + ! Solve implicit V problem + this%implicit%opr(1,:,:,:)=this%rho; this%implicit%opr(2:,:,:,:)=0.0_WP + do k=this%cfg%kmin_,this%cfg%kmax_ + do j=this%cfg%jmin_,this%cfg%jmax_ + do i=this%cfg%imin_,this%cfg%imax_ + rhoUp=this%rho*sum(this%itpu_y(:,i+1,j,k)*this%U(i+1,j-1:j,k)) + rhoUm=this%rho*sum(this%itpu_y(:,i ,j,k)*this%U(i ,j-1:j,k)) + rhoVp=this%rho*sum(this%itpv_y(:,i,j ,k)*this%V(i,j :j+1,k))*2.0_WP + rhoVm=this%rho*sum(this%itpv_y(:,i,j-1,k)*this%V(i,j-1:j ,k))*2.0_WP + rhoWp=this%rho*sum(this%itpw_y(:,i,j,k+1)*this%W(i,j-1:j,k+1)) + rhoWm=this%rho*sum(this%itpw_y(:,i,j,k )*this%W(i,j-1:j,k )) + this%implicit%opr(1,i,j,k)=this%implicit%opr(1,i,j,k)+0.5_WP*dt*(this%divv_x(+1,i,j,k)*this%itpv_x(-1,i+1,j,k)*rhoUp+& + & this%divv_x( 0,i,j,k)*this%itpv_x( 0,i ,j,k)*rhoUm+& + & this%divv_y( 0,i,j,k)*this%itpv_y( 0,i,j ,k)*rhoVp+& + & this%divv_y(-1,i,j,k)*this%itpv_y(+1,i,j-1,k)*rhoVm+& + & this%divv_z(+1,i,j,k)*this%itpv_z(-1,i,j,k+1)*rhoWp+& + & this%divv_z( 0,i,j,k)*this%itpv_z( 0,i,j,k )*rhoWm) + this%implicit%opr(2,i,j,k)=this%implicit%opr(2,i,j,k)+0.5_WP*dt*(this%divv_x(+1,i,j,k)*this%itpv_x( 0,i+1,j,k)*rhoUp) + this%implicit%opr(3,i,j,k)=this%implicit%opr(3,i,j,k)+0.5_WP*dt*(this%divv_x( 0,i,j,k)*this%itpv_x(-1,i ,j,k)*rhoUm) + this%implicit%opr(4,i,j,k)=this%implicit%opr(4,i,j,k)+0.5_WP*dt*(this%divv_y( 0,i,j,k)*this%itpv_y(+1,i,j ,k)*rhoVp) + this%implicit%opr(5,i,j,k)=this%implicit%opr(5,i,j,k)+0.5_WP*dt*(this%divv_y(-1,i,j,k)*this%itpv_y( 0,i,j-1,k)*rhoVm) + this%implicit%opr(6,i,j,k)=this%implicit%opr(6,i,j,k)+0.5_WP*dt*(this%divv_z(+1,i,j,k)*this%itpv_z( 0,i,j,k+1)*rhoWp) + this%implicit%opr(7,i,j,k)=this%implicit%opr(7,i,j,k)+0.5_WP*dt*(this%divv_z( 0,i,j,k)*this%itpv_z(-1,i,j,k )*rhoWm) + end do + end do + end do + do k=this%cfg%kmin_,this%cfg%kmax_ + do j=this%cfg%jmin_,this%cfg%jmax_ + do i=this%cfg%imin_,this%cfg%imax_ + this%implicit%opr(1,i,j,k)=this%implicit%opr(1,i,j,k)-0.5_WP*dt*(this%divv_x(+1,i,j,k)*sum(this%itp_xy(:,:,i+1,j,k)*this%visc(i:i+1,j-1:j,k))*this%grdv_x(-1,i+1,j,k)+& + & this%divv_x( 0,i,j,k)*sum(this%itp_xy(:,:,i ,j,k)*this%visc(i-1:i,j-1:j,k))*this%grdv_x( 0,i ,j,k)+& + & this%divv_y( 0,i,j,k)*4.0_WP/3.0_WP* this%visc(i,j ,k) *this%grdv_y( 0,i,j ,k)+& + & this%divv_y(-1,i,j,k)*4.0_WP/3.0_WP* this%visc(i,j-1,k) *this%grdv_y(+1,i,j-1,k)+& + & this%divv_z(+1,i,j,k)*sum(this%itp_yz(:,:,i,j,k+1)*this%visc(i,j-1:j,k:k+1))*this%grdv_z(-1,i,j,k+1)+& + & this%divv_z( 0,i,j,k)*sum(this%itp_yz(:,:,i,j,k )*this%visc(i,j-1:j,k-1:k))*this%grdv_z( 0,i,j,k )) + this%implicit%opr(2,i,j,k)=this%implicit%opr(2,i,j,k)-0.5_WP*dt*(this%divv_x(+1,i,j,k)*sum(this%itp_xy(:,:,i+1,j,k)*this%visc(i:i+1,j-1:j,k))*this%grdv_x( 0,i+1,j,k)) + this%implicit%opr(3,i,j,k)=this%implicit%opr(3,i,j,k)-0.5_WP*dt*(this%divv_x( 0,i,j,k)*sum(this%itp_xy(:,:,i ,j,k)*this%visc(i-1:i,j-1:j,k))*this%grdv_x(-1,i ,j,k)) + this%implicit%opr(4,i,j,k)=this%implicit%opr(4,i,j,k)-0.5_WP*dt*(this%divv_y( 0,i,j,k)*4.0_WP/3.0_WP* this%visc(i,j ,k) *this%grdv_y(+1,i,j ,k)) + this%implicit%opr(5,i,j,k)=this%implicit%opr(5,i,j,k)-0.5_WP*dt*(this%divv_y(-1,i,j,k)*4.0_WP/3.0_WP* this%visc(i,j-1,k) *this%grdv_y( 0,i,j-1,k)) + this%implicit%opr(6,i,j,k)=this%implicit%opr(6,i,j,k)-0.5_WP*dt*(this%divv_z(+1,i,j,k)*sum(this%itp_yz(:,:,i,j,k+1)*this%visc(i,j-1:j,k:k+1))*this%grdv_z( 0,i,j,k+1)) + this%implicit%opr(7,i,j,k)=this%implicit%opr(7,i,j,k)-0.5_WP*dt*(this%divv_z( 0,i,j,k)*sum(this%itp_yz(:,:,i,j,k )*this%visc(i,j-1:j,k-1:k))*this%grdv_z(-1,i,j,k )) + end do + end do + end do + call this%implicit%setup() + this%implicit%rhs=resV + this%implicit%sol=0.0_WP + call this%implicit%solve() + resV=this%implicit%sol + + ! Solve implicit W problem + this%implicit%opr(1,:,:,:)=this%rho; this%implicit%opr(2:,:,:,:)=0.0_WP + do k=this%cfg%kmin_,this%cfg%kmax_ + do j=this%cfg%jmin_,this%cfg%jmax_ + do i=this%cfg%imin_,this%cfg%imax_ + rhoUp=this%rho*sum(this%itpu_z(:,i+1,j,k)*this%U(i+1,j,k-1:k)) + rhoUm=this%rho*sum(this%itpu_z(:,i ,j,k)*this%U(i ,j,k-1:k)) + rhoVp=this%rho*sum(this%itpv_z(:,i,j+1,k)*this%V(i,j+1,k-1:k)) + rhoVm=this%rho*sum(this%itpv_z(:,i,j ,k)*this%V(i,j ,k-1:k)) + rhoWp=this%rho*sum(this%itpw_z(:,i,j,k )*this%W(i,j,k :k+1))*2.0_WP + rhoWm=this%rho*sum(this%itpw_z(:,i,j,k-1)*this%W(i,j,k-1:k ))*2.0_WP + this%implicit%opr(1,i,j,k)=this%implicit%opr(1,i,j,k)+0.5_WP*dt*(this%divw_x(+1,i,j,k)*this%itpw_x(-1,i+1,j,k)*rhoUp+& + & this%divw_x( 0,i,j,k)*this%itpw_x( 0,i ,j,k)*rhoUm+& + & this%divw_y(+1,i,j,k)*this%itpw_y(-1,i,j+1,k)*rhoVp+& + & this%divw_y( 0,i,j,k)*this%itpw_y( 0,i,j ,k)*rhoVm+& + & this%divw_z( 0,i,j,k)*this%itpw_z( 0,i,j,k )*rhoWp+& + & this%divw_z(-1,i,j,k)*this%itpw_z(+1,i,j,k-1)*rhoWm) + this%implicit%opr(2,i,j,k)=this%implicit%opr(2,i,j,k)+0.5_WP*dt*(this%divw_x(+1,i,j,k)*this%itpw_x( 0,i+1,j,k)*rhoUp) + this%implicit%opr(3,i,j,k)=this%implicit%opr(3,i,j,k)+0.5_WP*dt*(this%divw_x( 0,i,j,k)*this%itpw_x(-1,i ,j,k)*rhoUm) + this%implicit%opr(4,i,j,k)=this%implicit%opr(4,i,j,k)+0.5_WP*dt*(this%divw_y(+1,i,j,k)*this%itpw_y( 0,i,j+1,k)*rhoVp) + this%implicit%opr(5,i,j,k)=this%implicit%opr(5,i,j,k)+0.5_WP*dt*(this%divw_y( 0,i,j,k)*this%itpw_y(-1,i,j ,k)*rhoVm) + this%implicit%opr(6,i,j,k)=this%implicit%opr(6,i,j,k)+0.5_WP*dt*(this%divw_z( 0,i,j,k)*this%itpw_z(+1,i,j,k )*rhoWp) + this%implicit%opr(7,i,j,k)=this%implicit%opr(7,i,j,k)+0.5_WP*dt*(this%divw_z(-1,i,j,k)*this%itpw_z( 0,i,j,k-1)*rhoWm) + end do + end do + end do + do k=this%cfg%kmin_,this%cfg%kmax_ + do j=this%cfg%jmin_,this%cfg%jmax_ + do i=this%cfg%imin_,this%cfg%imax_ + this%implicit%opr(1,i,j,k)=this%implicit%opr(1,i,j,k)-0.5_WP*dt*(this%divw_x(+1,i,j,k)*sum(this%itp_xz(:,:,i+1,j,k)*this%visc(i:i+1,j,k-1:k))*this%grdw_x(-1,i+1,j,k)+& + & this%divw_x( 0,i,j,k)*sum(this%itp_xz(:,:,i ,j,k)*this%visc(i-1:i,j,k-1:k))*this%grdw_x( 0,i ,j,k)+& + & this%divw_y(+1,i,j,k)*sum(this%itp_yz(:,:,i,j+1,k)*this%visc(i,j:j+1,k-1:k))*this%grdw_y(-1,i,j+1,k)+& + & this%divw_y( 0,i,j,k)*sum(this%itp_yz(:,:,i,j ,k)*this%visc(i,j-1:j,k-1:k))*this%grdw_y( 0,i,j ,k)+& + & this%divw_z( 0,i,j,k)*4.0_WP/3.0_WP* this%visc(i,j,k ) *this%grdw_z( 0,i,j,k )+& + & this%divw_z(-1,i,j,k)*4.0_WP/3.0_WP* this%visc(i,j,k-1) *this%grdw_z(+1,i,j,k-1)) + this%implicit%opr(2,i,j,k)=this%implicit%opr(2,i,j,k)-0.5_WP*dt*(this%divw_x(+1,i,j,k)*sum(this%itp_xz(:,:,i+1,j,k)*this%visc(i:i+1,j,k-1:k))*this%grdw_x( 0,i+1,j,k)) + this%implicit%opr(3,i,j,k)=this%implicit%opr(3,i,j,k)-0.5_WP*dt*(this%divw_x( 0,i,j,k)*sum(this%itp_xz(:,:,i ,j,k)*this%visc(i-1:i,j,k-1:k))*this%grdw_x(-1,i ,j,k)) + this%implicit%opr(4,i,j,k)=this%implicit%opr(4,i,j,k)-0.5_WP*dt*(this%divw_y(+1,i,j,k)*sum(this%itp_yz(:,:,i,j+1,k)*this%visc(i,j:j+1,k-1:k))*this%grdw_y( 0,i,j+1,k)) + this%implicit%opr(5,i,j,k)=this%implicit%opr(5,i,j,k)-0.5_WP*dt*(this%divw_y( 0,i,j,k)*sum(this%itp_yz(:,:,i,j ,k)*this%visc(i,j-1:j,k-1:k))*this%grdw_y(-1,i,j ,k)) + this%implicit%opr(6,i,j,k)=this%implicit%opr(6,i,j,k)-0.5_WP*dt*(this%divw_z( 0,i,j,k)*4.0_WP/3.0_WP* this%visc(i,j,k ) *this%grdw_z(+1,i,j,k )) + this%implicit%opr(7,i,j,k)=this%implicit%opr(7,i,j,k)-0.5_WP*dt*(this%divw_z(-1,i,j,k)*4.0_WP/3.0_WP* this%visc(i,j,k-1) *this%grdw_z( 0,i,j,k-1)) + end do + end do + end do + call this%implicit%setup() + this%implicit%rhs=resW + this%implicit%sol=0.0_WP + call this%implicit%solve() + resW=this%implicit%sol + + end subroutine solve_implicit + + + !> Add gravity source term + subroutine addsrc_gravity(this,resU,resV,resW) + implicit none + class(incomp), intent(inout) :: this + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(inout) :: resU !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(inout) :: resV !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(inout) :: resW !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + integer :: i,j,k + do k=this%cfg%kmin_,this%cfg%kmax_ + do j=this%cfg%jmin_,this%cfg%jmax_ + do i=this%cfg%imin_,this%cfg%imax_ + if (this%umask(i,j,k).eq.0) resU(i,j,k)=resU(i,j,k)+this%rho*this%gravity(1) + if (this%vmask(i,j,k).eq.0) resV(i,j,k)=resV(i,j,k)+this%rho*this%gravity(2) + if (this%wmask(i,j,k).eq.0) resW(i,j,k)=resW(i,j,k)+this%rho*this%gravity(3) + end do + end do + end do + end subroutine addsrc_gravity + + + !> Print out info for incompressible flow solver + subroutine incomp_print(this) + use, intrinsic :: iso_fortran_env, only: output_unit + implicit none + class(incomp), intent(in) :: this + + ! Output + if (this%cfg%amRoot) then + write(output_unit,'("Incompressible solver [",a,"] for config [",a,"]")') trim(this%name),trim(this%cfg%name) + write(output_unit,'(" > density = ",es12.5)') this%rho + end if + + end subroutine incomp_print + + +end module incomp_class diff --git a/examples/NOSB_cylinder_peridigm/src/lss_class.f90 b/examples/NOSB_cylinder_peridigm/src/lss_class.f90 new file mode 100644 index 000000000..6ec20724b --- /dev/null +++ b/examples/NOSB_cylinder_peridigm/src/lss_class.f90 @@ -0,0 +1,1585 @@ +!> Lagrangian solid solver object +!> Implements peridynamics equations +module lss_class + use precision, only: WP + use string, only: str_medium + use config_class, only: config + use ddadi_class, only: ddadi + use mpi_f08, only: MPI_Datatype,MPI_INTEGER8,MPI_INTEGER,MPI_DOUBLE_PRECISION + implicit none + private + + + ! Expose type/constructor/methods + public :: lss + + + !> Memory adaptation parameter + real(WP), parameter :: coeff_up=1.3_WP !< Particle array size increase factor + real(WP), parameter :: coeff_dn=0.7_WP !< Particle array size decrease factor + + + !> I/O chunk size to read at a time + integer, parameter :: part_chunk_size=1000 !< Read 1000 particles at a time before redistributing + + + !> Maximum number of bonds per particle + integer, parameter, public :: max_bond=200 !< Assumes something like a 7x7x7 stencil in 3D + + + !> Bonded solid particle definition + type :: part + !> MPI_DOUBLE_PRECISION data + real(WP) :: vonMises !< Element dilatation + real(WP) :: vol !< Particle volume + real(WP), dimension(max_bond) :: dbond !< Length of initial bonds + real(WP), dimension(3) :: pos !< Particle center coordinates + real(WP), dimension(3) :: vel !< Velocity of particle + real(WP), dimension(3) :: Abond !< Bond acceleration for particle + real(WP), dimension(3) :: Afluid !< Fluid acceleration for particle + real(WP), dimension(3) :: ipos !< Initial position + real(WP), dimension(3) :: displacement !< Displacement + real(WP), dimension(3,3) :: F !< Deformation gradient tensor + real(WP), dimension(3,3) :: PK_inv !< First Piola-Kirchoff tensor times shape tensor inverse + !> MPI_INTEGER data + integer :: id !< ID the object is associated with + integer :: i !< Unique index of particle (assumed >0) + integer :: nbond !< Number of initial bonds + integer, dimension(max_bond) :: ibond !< Indices of initially bonded particles (0 values ignored) + integer , dimension(3) :: ind !< Index of cell containing particle center + integer :: flag !< Control parameter (0=normal, 1=done->will be removed) + end type part + !> Number of blocks, block length, and block types in a particle + integer, parameter :: part_nblock=2 + integer , dimension(part_nblock) :: part_lblock=[38+max_bond,7+max_bond] + type(MPI_Datatype), dimension(part_nblock) :: part_tblock=[MPI_DOUBLE_PRECISION,MPI_INTEGER] + !> MPI_PART derived datatype and size + type(MPI_Datatype) :: MPI_PART + integer :: MPI_PART_SIZE + + + !> Lagrangian solid solver object definition + type :: lss + + ! This config is used for parallelization and for calculating bond/collision forces + class(config), pointer :: cfg + + type(ddadi) :: implicit !< Implicit solver for filtering + + ! This is the name of the solver + character(len=str_medium) :: name='UNNAMED_LSS' + + ! Solid material properties + real(WP) :: elastic_modulus !< Elastic modulus of the material + real(WP) :: poisson_ratio !< Poisson's ratio of the material + real(WP) :: rho !< Density of the material + real(WP) :: crit_energy !< Critical energy release + real(WP) :: beta + + ! Bonding parameters + real(WP) :: delta !< Bonding horizon (distance) + real(WP) :: min_dist !< Minimum bonding distance + integer :: nb !< Cell-based horizon + + ! Global and local particle data + integer :: np !< Global number of particles + integer :: np_ !< Local number of particles + integer, dimension(:), allocatable :: np_proc !< Number of particles on each processor + type(part), dimension(:), allocatable :: p !< Array of particles of type part + + ! Overlap particle (i.e., ghost) data + integer :: ng_ !< Local number of ghosts + type(part), dimension(:), allocatable :: g !< Array of ghosts of type part + + ! Gravitational acceleration + real(WP), dimension(3) :: gravity=0.0_WP + + ! Solid volume fraction and momentum + real(WP), dimension(:,:,:), allocatable :: VF !< Volume fraction, cell-centered + real(WP), dimension(:,:,:), allocatable :: VFU !< Solid velocity, U-face + real(WP), dimension(:,:,:), allocatable :: VFV !< Solid velocity, V-face + real(WP), dimension(:,:,:), allocatable :: VFW !< Solid velocity, W-face + + ! CFL numbers + real(WP) :: CFLp_x,CFLp_y,CFLp_z,CFLp_a + + ! Number of substeps for time integrator + real(WP) :: nstep=1 + + ! Monitoring info + real(WP) :: Umin,Umax,Umean !< U velocity info + real(WP) :: Vmin,Vmax,Vmean !< V velocity info + real(WP) :: Wmin,Wmax,Wmean !< W velocity info + real(WP) :: VFmax !< Volume fraction info + real(WP), dimension(3) :: ibmForce !< Total force due to IBM + integer :: np_out !< Number of particles leaving the domain + + ! Filtering operation + real(WP) :: filter_width !< Characteristic filter width + real(WP), dimension(:,:,:,:), allocatable :: div_x,div_y,div_z !< Divergence operator + real(WP), dimension(:,:,:,:), allocatable :: grd_x,grd_y,grd_z !< Gradient operator + + contains + procedure :: bond_init !< Setup initial interparticle bonds + procedure :: get_bond_force !< Compute interparticle bond force + procedure :: advance !< Step forward the particle ODEs + procedure :: get_cfl !< Calculate maximum CFL + procedure :: get_max !< Extract various monitoring data + procedure :: update_partmesh !< Update a partmesh object using current particles + procedure :: share !< Share particles across interprocessor boundaries + procedure :: sync !< Synchronize particles across interprocessor boundaries + procedure :: resize !< Resize particle array to given size + procedure :: resize_ghost !< Resize ghost array to given size + procedure :: recycle !< Recycle particle array by removing flagged particles + procedure :: write !< Parallel write particles to file + procedure :: read !< Parallel read particles from file + procedure :: update_VF !< Compute volume fraction + procedure :: filter !< Apply volume filtering to field + end type lss + + + !> Declare lss constructor + interface lss + procedure constructor + end interface lss + +contains + + + ! Quasi-Gaussian weighting function - h is the cut-off + real(WP) function wgauss(d,h) + implicit none + real(WP), intent(in) :: d,h + real(WP), parameter :: coeff=2.6_WP + real(WP) :: hh + hh=coeff*h + if (d.ge.hh) then + wgauss=0.0_WP + else + wgauss=(1.0_WP+4.0_WP*d/hh)*(1.0_WP-d/hh)**4 + end if + end function wgauss + + + !> Default constructor for Lagrangian solid solver + function constructor(cfg,name) result(self) + implicit none + type(lss) :: self + class(config), target, intent(in) :: cfg + character(len=*), optional :: name + integer :: i,j,k + + ! Set the name for the solver + if (present(name)) self%name=trim(adjustl(name)) + + ! Point to pgrid object + self%cfg=>cfg + + ! Set default bonding horizon based on underlying mesh + self%delta=self%cfg%min_meshsize + self%nb=1 + self%min_dist=huge(1.0_WP) + + ! Allocate variables + allocate(self%np_proc(1:self%cfg%nproc)); self%np_proc=0 + self%np_=0; self%np=0 + call self%resize(0) + + ! Initialize MPI derived datatype for a particle + call prepare_mpi_part() + + ! Allocate VF array on cfg mesh + allocate(self%VF(self%cfg%imino_:self%cfg%imaxo_,self%cfg%jmino_:self%cfg%jmaxo_,self%cfg%kmino_:self%cfg%kmaxo_)); self%VF=0.0_WP + allocate(self%VFU(self%cfg%imino_:self%cfg%imaxo_,self%cfg%jmino_:self%cfg%jmaxo_,self%cfg%kmino_:self%cfg%kmaxo_)); self%VFU=0.0_WP + allocate(self%VFV(self%cfg%imino_:self%cfg%imaxo_,self%cfg%jmino_:self%cfg%jmaxo_,self%cfg%kmino_:self%cfg%kmaxo_)); self%VFV=0.0_WP + allocate(self%VFW(self%cfg%imino_:self%cfg%imaxo_,self%cfg%jmino_:self%cfg%jmaxo_,self%cfg%kmino_:self%cfg%kmaxo_)); self%VFW=0.0_WP + + ! Allocate finite volume divergence operators + allocate(self%div_x(0:+1,self%cfg%imin_:self%cfg%imax_,self%cfg%jmin_:self%cfg%jmax_,self%cfg%kmin_:self%cfg%kmax_)) !< Cell-centered + allocate(self%div_y(0:+1,self%cfg%imin_:self%cfg%imax_,self%cfg%jmin_:self%cfg%jmax_,self%cfg%kmin_:self%cfg%kmax_)) !< Cell-centered + allocate(self%div_z(0:+1,self%cfg%imin_:self%cfg%imax_,self%cfg%jmin_:self%cfg%jmax_,self%cfg%kmin_:self%cfg%kmax_)) !< Cell-centered + ! Create divergence operator to cell center [xm,ym,zm] + do k=self%cfg%kmin_,self%cfg%kmax_ + do j=self%cfg%jmin_,self%cfg%jmax_ + do i=self%cfg%imin_,self%cfg%imax_ + self%div_x(:,i,j,k)=self%cfg%dxi(i)*[-1.0_WP,+1.0_WP] !< Divergence from [x ,ym,zm] + self%div_y(:,i,j,k)=self%cfg%dyi(j)*[-1.0_WP,+1.0_WP] !< Divergence from [xm,y ,zm] + self%div_z(:,i,j,k)=self%cfg%dzi(k)*[-1.0_WP,+1.0_WP] !< Divergence from [xm,ym,z ] + end do + end do + end do + + ! Allocate finite difference velocity gradient operators + allocate(self%grd_x(-1:0,self%cfg%imin_:self%cfg%imax_+1,self%cfg%jmin_:self%cfg%jmax_+1,self%cfg%kmin_:self%cfg%kmax_+1)) !< X-face-centered + allocate(self%grd_y(-1:0,self%cfg%imin_:self%cfg%imax_+1,self%cfg%jmin_:self%cfg%jmax_+1,self%cfg%kmin_:self%cfg%kmax_+1)) !< Y-face-centered + allocate(self%grd_z(-1:0,self%cfg%imin_:self%cfg%imax_+1,self%cfg%jmin_:self%cfg%jmax_+1,self%cfg%kmin_:self%cfg%kmax_+1)) !< Z-face-centered + ! Create gradient coefficients to cell faces + do k=self%cfg%kmin_,self%cfg%kmax_+1 + do j=self%cfg%jmin_,self%cfg%jmax_+1 + do i=self%cfg%imin_,self%cfg%imax_+1 + self%grd_x(:,i,j,k)=self%cfg%dxmi(i)*[-1.0_WP,+1.0_WP] !< Gradient in x from [xm,ym,zm] to [x,ym,zm] + self%grd_y(:,i,j,k)=self%cfg%dymi(j)*[-1.0_WP,+1.0_WP] !< Gradient in y from [xm,ym,zm] to [xm,y,zm] + self%grd_z(:,i,j,k)=self%cfg%dzmi(k)*[-1.0_WP,+1.0_WP] !< Gradient in z from [xm,ym,zm] to [xm,ym,z] + end do + end do + end do + + ! Loop over the domain and zero divergence in walls + do k=self%cfg%kmin_,self%cfg%kmax_ + do j=self%cfg%jmin_,self%cfg%jmax_ + do i=self%cfg%imin_,self%cfg%imax_ + if (self%cfg%VF(i,j,k).eq.0.0_WP) then + self%div_x(:,i,j,k)=0.0_WP + self%div_y(:,i,j,k)=0.0_WP + self%div_z(:,i,j,k)=0.0_WP + end if + end do + end do + end do + + ! Zero out gradient to wall faces + do k=self%cfg%kmin_,self%cfg%kmax_+1 + do j=self%cfg%jmin_,self%cfg%jmax_+1 + do i=self%cfg%imin_,self%cfg%imax_+1 + if (self%cfg%VF(i,j,k).eq.0.0_WP.or.self%cfg%VF(i-1,j,k).eq.0.0_WP) self%grd_x(:,i,j,k)=0.0_WP + if (self%cfg%VF(i,j,k).eq.0.0_WP.or.self%cfg%VF(i,j-1,k).eq.0.0_WP) self%grd_y(:,i,j,k)=0.0_WP + if (self%cfg%VF(i,j,k).eq.0.0_WP.or.self%cfg%VF(i,j,k-1).eq.0.0_WP) self%grd_z(:,i,j,k)=0.0_WP + end do + end do + end do + + ! Adjust metrics to account for lower dimensionality + if (self%cfg%nx.eq.1) then + self%div_x=0.0_WP + self%grd_x=0.0_WP + end if + if (self%cfg%ny.eq.1) then + self%div_y=0.0_WP + self%grd_y=0.0_WP + end if + if (self%cfg%nz.eq.1) then + self%div_z=0.0_WP + self%grd_z=0.0_WP + end if + + ! Create implicit solver object for filtering + self%implicit=ddadi(cfg=self%cfg,name='Filter',nst=7) + self%implicit%stc(1,:)=[ 0, 0, 0] + self%implicit%stc(2,:)=[+1, 0, 0] + self%implicit%stc(3,:)=[-1, 0, 0] + self%implicit%stc(4,:)=[ 0,+1, 0] + self%implicit%stc(5,:)=[ 0,-1, 0] + self%implicit%stc(6,:)=[ 0, 0,+1] + self%implicit%stc(7,:)=[ 0, 0,-1] + call self%implicit%init() + + ! Set default filter width + self%filter_width=1.0_WP*self%cfg%min_meshsize + + ! Log/screen output + logging: block + use, intrinsic :: iso_fortran_env, only: output_unit + use param, only: verbose + use messager, only: log + use string, only: str_long + character(len=str_long) :: message + if (self%cfg%amRoot) then + write(message,'("LSS object [",a,"] on partitioned grid [",a,"]")') trim(self%name),trim(self%cfg%name) + if (verbose.gt.1) write(output_unit,'(a)') trim(message) + if (verbose.gt.0) call log(message) + end if + end block logging + + end function constructor + + + !> Initialize bond force between particles + subroutine bond_init(this) + use messager, only: die + implicit none + class(lss), intent(inout) :: this + integer, dimension(:,:,:), allocatable :: npic !< Number of particle in cell + integer, dimension(:,:,:,:), allocatable :: ipic !< Index of particle in cell + + ! Communicate particles in ghost cells + call this%share() + + ! We can now assemble particle-in-cell information + pic_prep: block + use mpi_f08 + integer :: i,ip,jp,kp,ierr + integer :: mymax_npic,max_npic + + ! Allocate number of particle in cell + allocate(npic(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)); npic=0 + + ! Count particles and ghosts per cell + do i=1,this%np_ + ip=this%p(i)%ind(1); jp=this%p(i)%ind(2); kp=this%p(i)%ind(3) + npic(ip,jp,kp)=npic(ip,jp,kp)+1 + end do + do i=1,this%ng_ + ip=this%g(i)%ind(1); jp=this%g(i)%ind(2); kp=this%g(i)%ind(3) + npic(ip,jp,kp)=npic(ip,jp,kp)+1 + end do + + ! Get maximum number of particle in cell + mymax_npic=maxval(npic); call MPI_ALLREDUCE(mymax_npic,max_npic,1,MPI_INTEGER,MPI_MAX,this%cfg%comm,ierr) + + ! Allocate pic map + allocate(ipic(1:max_npic,this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)); ipic=0 + + ! Assemble pic map + npic=0 + do i=1,this%np_ + ip=this%p(i)%ind(1); jp=this%p(i)%ind(2); kp=this%p(i)%ind(3) + npic(ip,jp,kp)=npic(ip,jp,kp)+1 + ipic(npic(ip,jp,kp),ip,jp,kp)=+i + end do + do i=1,this%ng_ + ip=this%g(i)%ind(1); jp=this%g(i)%ind(2); kp=this%g(i)%ind(3) + npic(ip,jp,kp)=npic(ip,jp,kp)+1 + ipic(npic(ip,jp,kp),ip,jp,kp)=-i + end do + + end block pic_prep + + ! Establish initial bonds + create_bonds: block + use mpi_f08, only: MPI_ALLREDUCE,MPI_MIN,MPI_IN_PLACE + use parallel, only: MPI_REAL_WP + use mathtools, only: Pi + integer :: i,j,k,n1,nn,n2,ierr + type(part) :: p1,p2 + real(WP), dimension(3) :: rpos + real(WP) :: dist + ! Reset minimum bond distance + this%min_dist=huge(1.0_WP) + ! Loop over particles + do n1=1,this%np_ + ! Create copy of our particle + p1=this%p(n1) + ! Zero out bonds + p1%ibond=0 + p1%nbond=0 + ! Loop over neighbor cells + do k=p1%ind(3)-this%nb,p1%ind(3)+this%nb + do j=p1%ind(2)-this%nb,p1%ind(2)+this%nb + do i=p1%ind(1)-this%nb,p1%ind(1)+this%nb + ! Loop over particles in that cell + do nn=1,npic(i,j,k) + ! Create copy of our neighbor + n2=ipic(nn,i,j,k) + if (n2.gt.0) then + p2=this%p(+n2) + else if (n2.lt.0) then + p2=this%g(-n2) + end if + ! Cannot self-bond + if (p1%i.eq.p2%i) cycle + ! Cannot bond with different id except <=0 (<=0 bonds with everyone) + if (p1%id.ne.p2%id.and.p1%id.ge.0.and.p2%id.ge.0) cycle + ! Check interparticle distance + rpos=p2%pos-p1%pos + dist=sqrt(dot_product(rpos,rpos)) + if (dist.lt.this%delta) then + ! This particle is in horizon, create a bond + p1%nbond=p1%nbond+1 + if (p1%nbond.gt.max_bond) call die('[lss_class bond_init] Number of detected bonds is larger than max allowed') + p1%ibond(p1%nbond)=p2%i + p1%dbond(p1%nbond)=dist + ! Determine minimum bond distance + this%min_dist=min(this%min_dist,dist) + end if + end do + end do + end do + end do + ! Copy back the particle + this%p(n1)=p1 + end do + ! Get global minimum + call MPI_ALLREDUCE(MPI_IN_PLACE,this%min_dist,1,MPI_REAL_WP,MPI_MIN,this%cfg%comm,ierr) + end block create_bonds + + ! Clean up + if (allocated(npic)) deallocate(npic) + if (allocated(ipic)) deallocate(ipic) + + end subroutine bond_init + + + !> Calculate bond force between particles + subroutine get_bond_force(this) + implicit none + class(lss), intent(inout) :: this + integer, dimension(:,:,:), allocatable :: npic !< Number of particle in cell + integer, dimension(:,:,:,:), allocatable :: ipic !< Index of particle in cell + integer :: dim2d + logical :: is2D + + ! Need to modify parameters in 2D + is2D=this%cfg%nx.eq.1.or.this%cfg%ny.eq.1.or.this%cfg%nz.eq.1 + dim2d = 0 + if (this%cfg%nx.eq.1) dim2d = 1 + if (this%cfg%ny.eq.1) dim2d = 2 + if (this%cfg%nz.eq.1) dim2d = 3 + + ! Communicate particles in ghost cells + call this%share() + + ! We can now assemble particle-in-cell information + pic_prep: block + use mpi_f08 + integer :: i,ip,jp,kp,ierr + integer :: mymax_npic,max_npic + + ! Allocate number of particle in cell + allocate(npic(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)); npic=0 + + ! Count particles and ghosts per cell + do i=1,this%np_ + ip=this%p(i)%ind(1); jp=this%p(i)%ind(2); kp=this%p(i)%ind(3) + npic(ip,jp,kp)=npic(ip,jp,kp)+1 + end do + do i=1,this%ng_ + ip=this%g(i)%ind(1); jp=this%g(i)%ind(2); kp=this%g(i)%ind(3) + npic(ip,jp,kp)=npic(ip,jp,kp)+1 + end do + + ! Get maximum number of particle in cell + mymax_npic=maxval(npic); call MPI_ALLREDUCE(mymax_npic,max_npic,1,MPI_INTEGER,MPI_MAX,this%cfg%comm,ierr) + + ! Allocate pic map + allocate(ipic(1:max_npic,this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)); ipic=0 + + ! Assemble pic map + npic=0 + do i=1,this%np_ + ip=this%p(i)%ind(1); jp=this%p(i)%ind(2); kp=this%p(i)%ind(3) + npic(ip,jp,kp)=npic(ip,jp,kp)+1 + ipic(npic(ip,jp,kp),ip,jp,kp)=+i + end do + do i=1,this%ng_ + ip=this%g(i)%ind(1); jp=this%g(i)%ind(2); kp=this%g(i)%ind(3) + npic(ip,jp,kp)=npic(ip,jp,kp)+1 + ipic(npic(ip,jp,kp),ip,jp,kp)=-i + end do + + end block pic_prep + + ! Update shape and deformation gradient tensor + update_tensors: block + use mathtools + integer :: i,j,k,n1,nn,n2 + type(part) :: p1,p2 + integer :: nb,nbond + real(WP), dimension(3) :: rpos, xi + real(WP) :: dist,w,mu,kk,detK,traceE,J_F,sigma_vm, traceS + real(WP), dimension(3,3) :: K_mat,E_mat,I_mat,S_mat,K_inv,sigma, s_dev + + mu=this%elastic_modulus/(2.0_WP+2.0_WP*this%poisson_ratio) ! shear modulus + kk=this%elastic_modulus/(3.0_WP-6.0_WP*this%poisson_ratio) ! bulk moduls + I_mat = 0.0_WP + S_mat = 0.0_WP + traceE = 0.0_WP + E_mat = 0.0_WP + K_inv = 0.0_WP + I_mat(1,1) = 1.0_WP + I_mat(2,2) = 1.0_WP + I_mat(3,3) = 1.0_WP + + ! Loop over particles + do n1=1,this%np_ + ! Create copy of our particle + p1=this%p(n1) + ! Zero out weighted volume and dilatation + K_mat=0.0_WP + K_inv = 0.0_WP + p1%F=0.0_WP + ! Loop over neighbor cells + do k=p1%ind(3)-this%nb,p1%ind(3)+this%nb + do j=p1%ind(2)-this%nb,p1%ind(2)+this%nb + do i=p1%ind(1)-this%nb,p1%ind(1)+this%nb + ! Loop over particles in that cell + do nn=1,npic(i,j,k) + ! Create copy of our neighbor + n2=ipic(nn,i,j,k) + if (n2.gt.0) then + p2=this%p(+n2) + else if (n2.lt.0) then + p2=this%g(-n2) + end if + ! Check if a bond exists + do nb=1,max_bond + if (p1%ibond(nb).eq.p2%i) then + ! Get current distance + rpos=p2%pos-p1%pos + !print *, rpos + ! Compute summation of K + xi = p2%ipos-p1%ipos + w = wgauss(p1%dbond(nb),this%delta) + K_mat(1,1)=K_mat(1,1)+xi(1)*xi(1)*w*p2%vol; K_mat(1,2)=K_mat(1,2)+xi(1)*xi(2)*w*p2%vol; K_mat(1,3)=K_mat(1,3)+xi(1)*xi(3)*w*p2%vol; + K_mat(2,1)=K_mat(2,1)+xi(2)*xi(1)*w*p2%vol; K_mat(2,2)=K_mat(2,2)+xi(2)*xi(2)*w*p2%vol; K_mat(2,3)=K_mat(2,3)+xi(2)*xi(3)*w*p2%vol; + K_mat(3,1)=K_mat(3,1)+xi(3)*xi(1)*w*p2%vol; K_mat(3,2)=K_mat(3,2)+xi(3)*xi(2)*w*p2%vol; K_mat(3,3)=K_mat(3,3)+xi(3)*xi(3)*w*p2%vol; + + ! Compute interior summation of F + p1%F(1,1)=p1%F(1,1)+rpos(1)*xi(1)*w*p2%vol; p1%F(1,2)=p1%F(1,2)+rpos(1)*xi(2)*w*p2%vol; p1%F(1,3)=p1%F(1,3)+rpos(1)*xi(3)*w*p2%vol; + p1%F(2,1)=p1%F(2,1)+rpos(2)*xi(1)*w*p2%vol; p1%F(2,2)=p1%F(2,2)+rpos(2)*xi(2)*w*p2%vol; p1%F(2,3)=p1%F(2,3)+rpos(2)*xi(3)*w*p2%vol; + p1%F(3,1)=p1%F(3,1)+rpos(3)*xi(1)*w*p2%vol; p1%F(3,2)=p1%F(3,2)+rpos(3)*xi(2)*w*p2%vol; p1%F(3,3)=p1%F(3,3)+rpos(3)*xi(3)*w*p2%vol; + end if + end do + end do + end do + end do + end do + ! Apply inverse of K to get F = F*K^-1 + if (is2D) then + ! The row/column of K_mat associated with the degenerate + ! direction is ~zero (particles don't vary in that + ! direction), so the full 3x3 K is singular. Invert + ! only the active in-plane 2x2 block, and set the + ! out-of-plane row/column of K_inv to identity. + select case (dim2d) + case (1) ! x degenerate, active plane is (y,z) + detK = K_mat(2,2)*K_mat(3,3) - K_mat(2,3)*K_mat(3,2) + K_inv(1,1) = 1.0_WP + K_inv(2,2) = K_mat(3,3)/detK + K_inv(2,3) = -K_mat(2,3)/detK + K_inv(3,2) = -K_mat(3,2)/detK + K_inv(3,3) = K_mat(2,2)/detK + case (2) ! y degenerate, active plane is (x,z) + detK = K_mat(1,1)*K_mat(3,3) - K_mat(1,3)*K_mat(3,1) + K_inv(2,2) = 1.0_WP + K_inv(1,1) = K_mat(3,3)/detK + K_inv(1,3) = -K_mat(1,3)/detK + K_inv(3,1) = -K_mat(3,1)/detK + K_inv(3,3) = K_mat(1,1)/detK + case (3) ! z degenerate, active plane is (x,y) + detK = K_mat(1,1)*K_mat(2,2) - K_mat(1,2)*K_mat(2,1) + K_inv(3,3) = 1.0_WP + K_inv(1,1) = K_mat(2,2)/detK + K_inv(1,2) = -K_mat(1,2)/detK + K_inv(2,1) = -K_mat(2,1)/detK + K_inv(2,2) = K_mat(1,1)/detK + end select + else + detK = K_mat(1,1)*(K_mat(2,2)*K_mat(3,3)-K_mat(2,3)*K_mat(3,2)) & + -K_mat(1,2)*(K_mat(2,1)*K_mat(3,3)-K_mat(2,3)*K_mat(3,1)) & + +K_mat(1,3)*(K_mat(2,1)*K_mat(3,2)-K_mat(2,2)*K_mat(3,1)) + K_inv(1,1) = (K_mat(2,2)*K_mat(3,3) - K_mat(2,3)*K_mat(3,2))/detK + K_inv(2,1) = -(K_mat(2,1)*K_mat(3,3) - K_mat(2,3)*K_mat(3,1))/detK + K_inv(3,1) = (K_mat(2,1)*K_mat(3,2) - K_mat(2,2)*K_mat(3,1))/detK + K_inv(1,2) = -(K_mat(1,2)*K_mat(3,3) - K_mat(1,3)*K_mat(3,2))/detK + K_inv(2,2) = (K_mat(1,1)*K_mat(3,3) - K_mat(1,3)*K_mat(3,1))/detK + K_inv(3,2) = -(K_mat(1,1)*K_mat(3,2) - K_mat(1,2)*K_mat(3,1))/detK + K_inv(1,3) = (K_mat(1,2)*K_mat(2,3) - K_mat(1,3)*K_mat(2,2))/detK + K_inv(2,3) = -(K_mat(1,1)*K_mat(2,3) - K_mat(1,3)*K_mat(2,1))/detK + K_inv(3,3) = (K_mat(1,1)*K_mat(2,2) - K_mat(1,2)*K_mat(2,1))/detK + end if + + + !if(detK.lt.1e-16_WP) K_inv = I_mat ! is this valid? What to do when this is small, + ! and is this the source of spurious movement? Very small when no displacement has occured + + + p1%F = MATMUL(p1%F,K_inv) + if (is2D) p1%F(dim2d,dim2d) = 1.0_WP + + ! Compute first Piola-Kirchoff stress tensor - constitutive model dependent + E_mat = 0.5_WP * (MATMUL(TRANSPOSE(p1%F),p1%F)-I_mat) + traceE = E_mat(1,1) + E_mat(2,2) + E_mat(3,3) + S_mat = (kk-2.0_WP/3.0_WP*mu)*traceE*I_mat + 2.0_WP*mu*E_mat + p1%PK_inv = MATMUL(MATMUL(p1%F,S_mat),K_inv) + + J_F = p1%F(1,1)*(p1%F(2,2)*p1%F(3,3)-p1%F(2,3)*p1%F(3,2)) & + -p1%F(1,2)*(p1%F(2,1)*p1%F(3,3)-p1%F(2,3)*p1%F(3,1)) & + +p1%F(1,3)*(p1%F(2,1)*p1%F(3,2)-p1%F(2,2)*p1%F(3,1)) + + sigma = MATMUL(MATMUL(p1%F, S_mat), TRANSPOSE(p1%F)) / J_F + + ! Deviatoric part + + traceS = sigma(1,1) + sigma(2,2) + sigma(3,3) + s_dev = sigma - (traceS/3.0_WP)*I_mat + + ! Von Mises + p1%vonMises = sqrt(1.5_WP * (s_dev(1,1)**2 + s_dev(2,2)**2 + s_dev(3,3)**2 & + + 2.0_WP*s_dev(1,2)**2 + 2.0_WP*s_dev(1,3)**2 & + + 2.0_WP*s_dev(2,3)**2)) + + ! Copy back the particle + this%p(n1)=p1 + end do + end block update_tensors + + ! Re-communicate particles in ghost cells to update dil and mw + call this%share() + + ! Update bond force, including collision force + update_bond_force: block + use mpi_f08, only: MPI_ALLREDUCE,MPI_MIN,MPI_IN_PLACE + use parallel, only: MPI_REAL_WP + use mathtools, only: Pi + integer :: i,j,k,n1,nn,n2,ierr + type(part) :: p1,p2 + real(WP), dimension(3) :: rpos,t1,t2,tc1,tc2,xi,z + real(WP), dimension(3,3) :: PK_inv + real(WP) :: dist,t,w + real(WP) :: stretch,max_stretch,mu,kk + real(WP) :: nc,rc,kc + integer :: nb,nbond + logical :: found_bond + ! Recompute a few physical parameters + mu=this%elastic_modulus/(2.0_WP+2.0_WP*this%poisson_ratio) + kk=this%elastic_modulus/(3.0_WP-6.0_WP*this%poisson_ratio) + if (is2D) then + if (this%cfg%nx.eq.1) t=this%cfg%xL + if (this%cfg%ny.eq.1) t=this%cfg%yL + if (this%cfg%nz.eq.1) t=this%cfg%zL + max_stretch=sqrt(this%crit_energy/((6.0_WP*mu/Pi+16.0_WP/(9.0_WP*Pi**2)*(kk-2.0_WP*mu))*this%delta)) + kc=15.0_WP*48.0_WP*this%elastic_modulus/(Pi*5.0_WP*t*this%delta**3) + else + max_stretch=sqrt(this%crit_energy/((3.0_WP*mu+(kk-5.0_WP*mu/3.0_WP)*0.75_WP**4)*this%delta)) + kc=15.0_WP*12.0_WP*this%elastic_modulus/(Pi*this%delta**4) + end if + nc=1.0_WP + this%min_dist=huge(1.0_WP) + ! Loop over particles + do n1=1,this%np_ + ! Particles marked 0 do not update their forces + if (this%p(n1)%id.eq.0) cycle + ! Create copy of our particle + p1=this%p(n1) + ! Zero out bond force + p1%Abond=0.0_WP + ! Zero out PK_inv + PK_inv=0.0_WP + ! Loop over neighbor cells + do k=p1%ind(3)-this%nb,p1%ind(3)+this%nb + do j=p1%ind(2)-this%nb,p1%ind(2)+this%nb + do i=p1%ind(1)-this%nb,p1%ind(1)+this%nb + ! Loop over particles in that cell + do nn=1,npic(i,j,k) + ! Create copy of our neighbor + n2=ipic(nn,i,j,k) + if (n2.gt.0) then + p2=this%p(+n2) + else if (n2.lt.0) then + p2=this%g(-n2) + end if + ! Current distance + rpos=p2%pos-p1%pos + dist=sqrt(dot_product(rpos,rpos)) + ! Check if a bond exists + found_bond=.false. + do nb=1,max_bond + if (p1%ibond(nb).eq.p2%i) then + ! Check for breakage first + stretch=(dist-p1%dbond(nb))/p1%dbond(nb) + if (stretch.gt.max_stretch) then + ! Remove the bond and flag as surface particle + p1%ibond(nb)=0 + p1%dbond(nb)=0.0_WP + cycle + end if + w = wgauss(p1%dbond(nb),this%delta) + xi = p2%ipos-p1%ipos + ! Force density 1->2 + t1 = w*MATMUL(p1%PK_inv,xi) + ! Force density 2->1 + t2 = w*MATMUL(p2%PK_inv,xi) + ! Force correction term (not formulated for 2D?) + ! z = rpos-MATMUL(p1%F,xi) + ! tc1 = w*(9.0_WP*kk/(Pi * this%delta**4))*(dot_product(xi,z)/(sqrt(dot_product(xi,xi)))**3)*xi + ! z = rpos-MATMUL(p2%F,xi) + ! tc2 = w*(9.0_WP*kk/(Pi * this%delta**4))*(dot_product(xi,z)/(sqrt(dot_product(xi,xi)))**3)*xi + ! Compute bond acceleration + !p1%Abond=p1%Abond+(t1+t2+tc1+tc2)*p2%vol/this%rho + p1%Abond=p1%Abond+(t1+t2)*p2%vol/this%rho + ! If still here, we have an active bond + found_bond=.true. + ! Determine minimum bond distance + this%min_dist=min(this%min_dist,dist) + cycle + end if + end do + ! Add collision force now + ! if (is2D) then + ! rc=p1%vol**(1.0_WP/2.0_WP) + ! else + ! rc=p1%vol**(1.0_WP/3.0_WP) + ! end if + ! if (.not.found_bond.and.p1%i.ne.p2%i.and.dist.lt.rc) then + ! p1%Abond=p1%Abond-max(kc*((rc/dist)**nc-1.0_WP),0.0_WP)*(rpos/dist)*p1%vol/this%rho + ! p1%flag = -2 + ! end if + end do + end do + end do + end do + ! Deal with dimensionality + if (this%cfg%nx.eq.1) p1%Abond(1)=0.0_WP + if (this%cfg%ny.eq.1) p1%Abond(2)=0.0_WP + if (this%cfg%nz.eq.1) p1%Abond(3)=0.0_WP + ! Copy back the particle + this%p(n1)=p1 + end do + ! Get global minimum + call MPI_ALLREDUCE(MPI_IN_PLACE,this%min_dist,1,MPI_REAL_WP,MPI_MIN,this%cfg%comm,ierr) + end block update_bond_force + + ! Clean up + if (allocated(npic)) deallocate(npic) + if (allocated(ipic)) deallocate(ipic) + + end subroutine get_bond_force + + + !> Advance the particle equations by a specified time step dt + !> p%id=-2 => do not solve for position nor velocity + !> p%id=-1 => do not solve for velocity + !> p%id= 0 => do not update force + subroutine advance(this,dt,stress_x,stress_y,stress_z) + use mpi_f08, only : MPI_SUM,MPI_INTEGER,MPI_IN_PLACE + use mathtools, only: Pi + implicit none + class(lss), intent(inout) :: this + real(WP), intent(inout) :: dt !< Timestep size over which to advance + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(inout) :: stress_x !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(inout) :: stress_y !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(inout) :: stress_z !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + integer :: n,ierr + real(WP), dimension(3) :: stress + + ! Zero out number of particles removed + this%np_out=0 + + ! Advance velocity based on old force and position based on mid-velocity + do n=1,this%np_ + ! Advance with Verlet scheme + ! Damping is put here, was in the thrombosis paper, unsure if should be + if (this%p(n)%id.gt.-1) this%p(n)%vel=(1.0_WP-(this%beta*dt/2))*this%p(n)%vel+0.5_WP*dt*(this%gravity+this%p(n)%Abond+this%p(n)%Afluid) + if (this%p(n)%id.gt.-2) this%p(n)%pos=this%p(n)%pos+dt*this%p(n)%vel + ! Relocalize + this%p(n)%ind=this%cfg%get_ijk_global(this%p(n)%pos,this%p(n)%ind) + ! Correct the position to take into account periodicity + if (this%cfg%xper) this%p(n)%pos(1)=this%cfg%x(this%cfg%imin)+modulo(this%p(n)%pos(1)-this%cfg%x(this%cfg%imin),this%cfg%xL) + if (this%cfg%yper) this%p(n)%pos(2)=this%cfg%y(this%cfg%jmin)+modulo(this%p(n)%pos(2)-this%cfg%y(this%cfg%jmin),this%cfg%yL) + if (this%cfg%zper) this%p(n)%pos(3)=this%cfg%z(this%cfg%kmin)+modulo(this%p(n)%pos(3)-this%cfg%z(this%cfg%kmin),this%cfg%zL) + ! Handle particles that have left the domain + if (this%p(n)%pos(1).lt.this%cfg%x(this%cfg%imin).or.this%p(n)%pos(1).gt.this%cfg%x(this%cfg%imax+1)) this%p(n)%flag=1 + if (this%p(n)%pos(2).lt.this%cfg%y(this%cfg%jmin).or.this%p(n)%pos(2).gt.this%cfg%y(this%cfg%jmax+1)) this%p(n)%flag=1 + if (this%p(n)%pos(3).lt.this%cfg%z(this%cfg%kmin).or.this%p(n)%pos(3).gt.this%cfg%z(this%cfg%kmax+1)) this%p(n)%flag=1 + ! Relocalize the particle + this%p(n)%ind=this%cfg%get_ijk_global(this%p(n)%pos,this%p(n)%ind) + ! Count number of particles removed + if (this%p(n)%flag.eq.1) this%np_out=this%np_out+1 + end do + + ! Communicate particles + call this%sync() + + ! Sum up particles removed + call MPI_ALLREDUCE(this%np_out,n,1,MPI_INTEGER,MPI_SUM,this%cfg%comm,ierr); this%np_out=n + + ! Calculate bond force + call this%get_bond_force() + + ! Advance velocity only based on new force + do n=1,this%np_ + ! Advance with Verlet scheme + stress=this%cfg%get_velocity(pos=this%p(n)%pos,i0=this%p(n)%ind(1),j0=this%p(n)%ind(2),k0=this%p(n)%ind(3),U=stress_x,V=stress_y,W=stress_z) + this%p(n)%Afluid=stress/this%rho + if (this%p(n)%id.le.-1) cycle + ! Damping is put here, was in the thrombosis paper, unsure if should be + this%p(n)%vel=this%p(n)%vel*(1.0_WP-(this%beta*dt/2))+0.5_WP*dt*(this%gravity+this%p(n)%Abond+this%p(n)%Afluid) + end do + + ! Recompute volume fraction + call this%update_VF() + + ! Log/screen output + logging: block + use, intrinsic :: iso_fortran_env, only: output_unit + use param, only: verbose + use messager, only: log + use string, only: str_long + character(len=str_long) :: message + if (this%cfg%amRoot) then + write(message,'("Particle solver [",a,"] on partitioned grid [",a,"]: ",i0," particles were advanced")') trim(this%name),trim(this%cfg%name),this%np + if (verbose.gt.1) write(output_unit,'(a)') trim(message) + if (verbose.gt.0) call log(message) + end if + end block logging + + end subroutine advance + + + !> Update particle volume fraction using our current particles + subroutine update_VF(this) + implicit none + class(lss), intent(inout) :: this + integer :: i + ! Reset volume fraction and momentum + this%VF=0.0_WP; this%VFU=0.0_WP; this%VFV=0.0_WP; this%VFW=0.0_WP + ! Transfer particle volume + do i=1,this%np_ + ! Skip inactive particle + if (this%p(i)%flag.eq.1) cycle + ! Transfer volume to mesh + call this%cfg%set_scalar(Sp=this%p(i)%vol, pos=this%p(i)%pos,i0=this%p(i)%ind(1),j0=this%p(i)%ind(2),k0=this%p(i)%ind(3),S=this%VF ,bc='n') + call this%cfg%set_scalar(Sp=this%p(i)%vol*this%p(i)%vel(1),pos=this%p(i)%pos,i0=this%p(i)%ind(1),j0=this%p(i)%ind(2),k0=this%p(i)%ind(3),S=this%VFU,bc='n') + call this%cfg%set_scalar(Sp=this%p(i)%vol*this%p(i)%vel(2),pos=this%p(i)%pos,i0=this%p(i)%ind(1),j0=this%p(i)%ind(2),k0=this%p(i)%ind(3),S=this%VFV,bc='n') + call this%cfg%set_scalar(Sp=this%p(i)%vol*this%p(i)%vel(3),pos=this%p(i)%pos,i0=this%p(i)%ind(1),j0=this%p(i)%ind(2),k0=this%p(i)%ind(3),S=this%VFW,bc='n') + end do + this%VF =this%VF /this%cfg%vol + this%VFU=this%VFU/this%cfg%vol + this%VFV=this%VFV/this%cfg%vol + this%VFW=this%VFW/this%cfg%vol + ! Sum at boundaries + call this%cfg%syncsum(this%VF ) + call this%cfg%syncsum(this%VFU) + call this%cfg%syncsum(this%VFV) + call this%cfg%syncsum(this%VFW) + ! Apply volume filter + call this%filter(this%VF ) + call this%filter(this%VFU) + call this%filter(this%VFV) + call this%filter(this%VFW) + ! Clip + where (this%VF.lt.0.0_WP) this%VF=0.0_WP + this%VF=min(this%VF,1.0_WP-epsilon(1.0_WP)) + + end subroutine update_VF + + + !> Laplacian filtering operation + subroutine filter(this,A) + implicit none + class(lss), intent(inout) :: this + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(inout) :: A !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + real(WP) :: filter_coeff + integer :: i,j,k,n,nstep + real(WP), dimension(:,:,:), allocatable :: FX,FY,FZ + + ! Recompute filter coefficient + filter_coeff=max(this%filter_width**2-this%cfg%min_meshsize**2,0.0_WP)/(16.0_WP*log(2.0_WP)) + if (filter_coeff.le.0.0_WP) return + + ! Allocate flux arrays + allocate(FX(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + allocate(FY(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + allocate(FZ(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + + if (.not.this%implicit%setup_done) then + ! Prepare diffusive operator (only need to do this once) + do k=this%cfg%kmin_,this%cfg%kmax_ + do j=this%cfg%jmin_,this%cfg%jmax_ + do i=this%cfg%imin_,this%cfg%imax_ + this%implicit%opr(1,i,j,k)=1.0_WP-(this%div_x(+1,i,j,k)*filter_coeff*this%grd_x(-1,i+1,j,k)+& + & this%div_x( 0,i,j,k)*filter_coeff*this%grd_x( 0,i ,j,k)+& + & this%div_y(+1,i,j,k)*filter_coeff*this%grd_y(-1,i,j+1,k)+& + & this%div_y( 0,i,j,k)*filter_coeff*this%grd_y( 0,i,j ,k)+& + & this%div_z(+1,i,j,k)*filter_coeff*this%grd_z(-1,i,j,k+1)+& + & this%div_z( 0,i,j,k)*filter_coeff*this%grd_z( 0,i,j,k )) + this%implicit%opr(2,i,j,k)= -(this%div_x(+1,i,j,k)*filter_coeff*this%grd_x( 0,i+1,j,k)) + this%implicit%opr(3,i,j,k)= -(this%div_x( 0,i,j,k)*filter_coeff*this%grd_x(-1,i ,j,k)) + this%implicit%opr(4,i,j,k)= -(this%div_y(+1,i,j,k)*filter_coeff*this%grd_y( 0,i,j+1,k)) + this%implicit%opr(5,i,j,k)= -(this%div_y( 0,i,j,k)*filter_coeff*this%grd_y(-1,i,j ,k)) + this%implicit%opr(6,i,j,k)= -(this%div_z(+1,i,j,k)*filter_coeff*this%grd_z( 0,i,j,k+1)) + this%implicit%opr(7,i,j,k)= -(this%div_z( 0,i,j,k)*filter_coeff*this%grd_z(-1,i,j,k )) + end do + end do + end do + end if + ! Explicit step + do k=this%cfg%kmin_,this%cfg%kmax_+1 + do j=this%cfg%jmin_,this%cfg%jmax_+1 + do i=this%cfg%imin_,this%cfg%imax_+1 + FX(i,j,k)=filter_coeff*sum(this%grd_x(:,i,j,k)*A(i-1:i,j,k)) + FY(i,j,k)=filter_coeff*sum(this%grd_y(:,i,j,k)*A(i,j-1:j,k)) + FZ(i,j,k)=filter_coeff*sum(this%grd_z(:,i,j,k)*A(i,j,k-1:k)) + end do + end do + end do + do k=this%cfg%kmin_,this%cfg%kmax_ + do j=this%cfg%jmin_,this%cfg%jmax_ + do i=this%cfg%imin_,this%cfg%imax_ + this%implicit%rhs(i,j,k)=sum(this%div_x(:,i,j,k)*FX(i:i+1,j,k))+sum(this%div_y(:,i,j,k)*FY(i,j:j+1,k))+sum(this%div_z(:,i,j,k)*FZ(i,j,k:k+1)) + end do + end do + end do + ! Implicit step + call this%implicit%setup() + this%implicit%sol=0.0_WP + call this%implicit%solve() + A=A+this%implicit%sol + call this%cfg%sync(A) + + ! Deallocate flux arrays + deallocate(FX,FY,FZ) + + end subroutine filter + + + !> Calculate the CFL + subroutine get_cfl(this,dt,cfl) + use mpi_f08, only: MPI_ALLREDUCE,MPI_MAX + use parallel, only: MPI_REAL_WP + implicit none + class(lss), intent(inout) :: this + real(WP), intent(in) :: dt + real(WP), intent(out) :: cfl + integer :: i,ierr + real(WP) :: my_CFLp_x,my_CFLp_y,my_CFLp_z,kk,mu,a + + ! Set the CFLs to zero + my_CFLp_x=0.0_WP; my_CFLp_y=0.0_WP; my_CFLp_z=0.0_WP + do i=1,this%np_ + my_CFLp_x=max(my_CFLp_x,abs(this%p(i)%vel(1))*this%cfg%dxi(this%p(i)%ind(1))) + my_CFLp_y=max(my_CFLp_y,abs(this%p(i)%vel(2))*this%cfg%dyi(this%p(i)%ind(2))) + my_CFLp_z=max(my_CFLp_z,abs(this%p(i)%vel(3))*this%cfg%dzi(this%p(i)%ind(3))) + end do + my_CFLp_x=my_CFLp_x*dt; my_CFLp_y=my_CFLp_y*dt; my_CFLp_z=my_CFLp_z*dt + + ! Get the parallel max + call MPI_ALLREDUCE(my_CFLp_x,this%CFLp_x,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + call MPI_ALLREDUCE(my_CFLp_y,this%CFLp_y,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + call MPI_ALLREDUCE(my_CFLp_z,this%CFLp_z,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + + ! CFL based on elastic wave speed in material + kk=this%elastic_modulus/(3.0_WP-6.0_WP*this%poisson_ratio) + mu=this%elastic_modulus/(2.0_WP+2.0_WP*this%poisson_ratio) + a=sqrt((kk+4.0_WP*mu/3.0_WP)/this%rho) + this%CFLp_a=dt*a/this%delta + + ! Return the maximum CFL + cfl=max(this%CFLp_x,this%CFLp_y,this%CFLp_z,this%CFLp_a) + + end subroutine get_cfl + + + !> Extract various monitoring data from particle field + subroutine get_max(this) + use mpi_f08, only: MPI_ALLREDUCE,MPI_MAX,MPI_MIN,MPI_SUM + use parallel, only: MPI_REAL_WP + implicit none + class(lss), intent(inout) :: this + real(WP) :: buf,safe_np + real(WP), dimension(3) :: buf3D + integer :: i,j,k,ierr + + ! Create safe np + safe_np=real(max(this%np,1),WP) + + ! Velocity min/max/mean + this%Umin=huge(1.0_WP); this%Umax=-huge(1.0_WP); this%Umean=0.0_WP + this%Vmin=huge(1.0_WP); this%Vmax=-huge(1.0_WP); this%Vmean=0.0_WP + this%Wmin=huge(1.0_WP); this%Wmax=-huge(1.0_WP); this%Wmean=0.0_WP + this%ibmForce=0.0_WP + do i=1,this%np_ + this%Umin=min(this%Umin,this%p(i)%vel(1)); this%Umax=max(this%Umax,this%p(i)%vel(1)); this%Umean=this%Umean+this%p(i)%vel(1) + this%Vmin=min(this%Vmin,this%p(i)%vel(2)); this%Vmax=max(this%Vmax,this%p(i)%vel(2)); this%Vmean=this%Vmean+this%p(i)%vel(2) + this%Wmin=min(this%Wmin,this%p(i)%vel(3)); this%Wmax=max(this%Wmax,this%p(i)%vel(3)); this%Wmean=this%Wmean+this%p(i)%vel(3) + this%ibmForce=this%ibmForce+this%p(i)%Afluid*this%p(i)%vol*this%rho + end do + call MPI_ALLREDUCE(this%Umin ,buf,1,MPI_REAL_WP,MPI_MIN,this%cfg%comm,ierr); this%Umin =buf + call MPI_ALLREDUCE(this%Umax ,buf,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr); this%Umax =buf + call MPI_ALLREDUCE(this%Umean,buf,1,MPI_REAL_WP,MPI_SUM,this%cfg%comm,ierr); this%Umean=buf/safe_np + call MPI_ALLREDUCE(this%Vmin ,buf,1,MPI_REAL_WP,MPI_MIN,this%cfg%comm,ierr); this%Vmin =buf + call MPI_ALLREDUCE(this%Vmax ,buf,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr); this%Vmax =buf + call MPI_ALLREDUCE(this%Vmean,buf,1,MPI_REAL_WP,MPI_SUM,this%cfg%comm,ierr); this%Vmean=buf/safe_np + call MPI_ALLREDUCE(this%Wmin ,buf,1,MPI_REAL_WP,MPI_MIN,this%cfg%comm,ierr); this%Wmin =buf + call MPI_ALLREDUCE(this%Wmax ,buf,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr); this%Wmax =buf + call MPI_ALLREDUCE(this%Wmean,buf,1,MPI_REAL_WP,MPI_SUM,this%cfg%comm,ierr); this%Wmean=buf/safe_np + call MPI_ALLREDUCE(this%ibmForce,buf3D,3,MPI_REAL_WP,MPI_SUM,this%cfg%comm,ierr); this%ibmForce=buf3D + + ! Get max volume fraction + this%VFmax =-huge(1.0_WP) + do k=this%cfg%kmin_,this%cfg%kmax_ + do j=this%cfg%jmin_,this%cfg%jmax_ + do i=this%cfg%imin_,this%cfg%imax_ + this%VFmax=max(this%VFmax,this%VF(i,j,k)) + end do + end do + end do + call MPI_ALLREDUCE(this%VFmax,buf,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr); this%VFmax=buf + + end subroutine get_max + + + !> Update particle mesh using our current particles + subroutine update_partmesh(this,pmesh) + use partmesh_class, only: partmesh + implicit none + class(lss), intent(inout) :: this + class(partmesh), intent(inout) :: pmesh + integer :: i + ! Reset particle mesh storage + call pmesh%reset() + ! Nothing else to do if no particle is present + if (this%np_.eq.0) return + ! Copy particle info + call pmesh%set_size(this%np_) + do i=1,this%np_ + pmesh%pos(:,i)=this%p(i)%pos + end do + end subroutine update_partmesh + + + !> Creation of the MPI datatype for particle + subroutine prepare_mpi_part() + use mpi_f08 + use messager, only: die + implicit none + integer(MPI_ADDRESS_KIND), dimension(part_nblock) :: disp + integer(MPI_ADDRESS_KIND) :: lb,extent + type(MPI_Datatype) :: MPI_PART_TMP + integer :: i,mysize,ierr + ! Prepare the displacement array + disp(1)=0 + do i=2,part_nblock + call MPI_Type_size(part_tblock(i-1),mysize,ierr) + disp(i)=disp(i-1)+int(mysize,MPI_ADDRESS_KIND)*int(part_lblock(i-1),MPI_ADDRESS_KIND) + end do + ! Create and commit the new type + call MPI_Type_create_struct(part_nblock,part_lblock,disp,part_tblock,MPI_PART_TMP,ierr) + call MPI_Type_get_extent(MPI_PART_TMP,lb,extent,ierr) + call MPI_Type_create_resized(MPI_PART_TMP,lb,extent,MPI_PART,ierr) + call MPI_Type_commit(MPI_PART,ierr) + ! If a problem was encountered, say it + if (ierr.ne.0) call die('[lss prepare_mpi_part] MPI Particle type creation failed') + ! Get the size of this type + call MPI_type_size(MPI_PART,MPI_PART_SIZE,ierr) + end subroutine prepare_mpi_part + + + !> Share particles across processor boundaries + subroutine share(this,nover) + use mpi_f08 + use messager, only: warn,die + implicit none + class(lss), intent(inout) :: this + integer, optional :: nover + type(part), dimension(:), allocatable :: tosend + type(part), dimension(:), allocatable :: torecv + integer :: no,nsend,nrecv + type(MPI_Status) :: status + integer :: icnt,isrc,idst,ierr + integer :: i,n + + ! Check overlap size + if (present(nover)) then + no=nover + if (no.gt.this%cfg%no) then + call warn('[lss share] Specified overlap is larger than that of cfg - reducing no') + no=this%cfg%no + else if (no.le.0) then + call die('[lss share] Specified overlap cannot be less or equal to zero') + end if + else + no=1 + end if + + ! Clean up ghost array + call this%resize_ghost(n=0); this%ng_=0 + + ! Share ghost particles in -x (no ghosts are sent here) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(1).lt.this%cfg%imin_+no) nsend=nsend+1 + end do + allocate(tosend(nsend)) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(1).lt.this%cfg%imin_+no) then + nsend=nsend+1 + tosend(nsend)=this%p(n) + if (this%cfg%xper.and.tosend(nsend)%ind(1).lt.this%cfg%imin+no) then + tosend(nsend)%pos(1)=tosend(nsend)%pos(1)+this%cfg%xL + tosend(nsend)%ind(1)=tosend(nsend)%ind(1)+this%cfg%nx + end if + end if + end do + nrecv=0 + call MPI_CART_SHIFT(this%cfg%comm,0,-1,isrc,idst,ierr) + call MPI_SENDRECV(nsend,1,MPI_INTEGER,idst,0,nrecv,1,MPI_INTEGER,isrc,0,this%cfg%comm,status,ierr) + allocate(torecv(nrecv)) + call MPI_SENDRECV(tosend,nsend,MPI_PART,idst,0,torecv,nrecv,MPI_PART,isrc,0,this%cfg%comm,status,ierr) + call this%resize_ghost(this%ng_+nrecv) + this%g(this%ng_+1:this%ng_+nrecv)=torecv + this%ng_=this%ng_+nrecv + if (allocated(tosend)) deallocate(tosend) + if (allocated(torecv)) deallocate(torecv) + + ! Share ghost particles in +x (no ghosts are sent here) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(1).gt.this%cfg%imax_-no) nsend=nsend+1 + end do + allocate(tosend(nsend)) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(1).gt.this%cfg%imax_-no) then + nsend=nsend+1 + tosend(nsend)=this%p(n) + if (this%cfg%xper.and.tosend(nsend)%ind(1).gt.this%cfg%imax-no) then + tosend(nsend)%pos(1)=tosend(nsend)%pos(1)-this%cfg%xL + tosend(nsend)%ind(1)=tosend(nsend)%ind(1)-this%cfg%nx + end if + end if + end do + nrecv=0 + call MPI_CART_SHIFT(this%cfg%comm,0,+1,isrc,idst,ierr) + call MPI_SENDRECV(nsend,1,MPI_INTEGER,idst,0,nrecv,1,MPI_INTEGER,isrc,0,this%cfg%comm,status,ierr) + allocate(torecv(nrecv)) + call MPI_SENDRECV(tosend,nsend,MPI_PART,idst,0,torecv,nrecv,MPI_PART,isrc,0,this%cfg%comm,status,ierr) + call this%resize_ghost(this%ng_+nrecv) + this%g(this%ng_+1:this%ng_+nrecv)=torecv + this%ng_=this%ng_+nrecv + if (allocated(tosend)) deallocate(tosend) + if (allocated(torecv)) deallocate(torecv) + + ! Share ghost particles in -y (ghosts need to be sent now) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(2).lt.this%cfg%jmin_+no) nsend=nsend+1 + end do + do n=1,this%ng_ + if (this%g(n)%ind(2).lt.this%cfg%jmin_+no) nsend=nsend+1 + end do + allocate(tosend(nsend)) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(2).lt.this%cfg%jmin_+no) then + nsend=nsend+1 + tosend(nsend)=this%p(n) + if (this%cfg%yper.and.tosend(nsend)%ind(2).lt.this%cfg%jmin+no) then + tosend(nsend)%pos(2)=tosend(nsend)%pos(2)+this%cfg%yL + tosend(nsend)%ind(2)=tosend(nsend)%ind(2)+this%cfg%ny + end if + end if + end do + do n=1,this%ng_ + if (this%g(n)%ind(2).lt.this%cfg%jmin_+no) then + nsend=nsend+1 + tosend(nsend)=this%g(n) + if (this%cfg%yper.and.tosend(nsend)%ind(2).lt.this%cfg%jmin+no) then + tosend(nsend)%pos(2)=tosend(nsend)%pos(2)+this%cfg%yL + tosend(nsend)%ind(2)=tosend(nsend)%ind(2)+this%cfg%ny + end if + end if + end do + nrecv=0 + call MPI_CART_SHIFT(this%cfg%comm,1,-1,isrc,idst,ierr) + call MPI_SENDRECV(nsend,1,MPI_INTEGER,idst,0,nrecv,1,MPI_INTEGER,isrc,0,this%cfg%comm,status,ierr) + allocate(torecv(nrecv)) + call MPI_SENDRECV(tosend,nsend,MPI_PART,idst,0,torecv,nrecv,MPI_PART,isrc,0,this%cfg%comm,status,ierr) + call this%resize_ghost(this%ng_+nrecv) + this%g(this%ng_+1:this%ng_+nrecv)=torecv + this%ng_=this%ng_+nrecv + if (allocated(tosend)) deallocate(tosend) + if (allocated(torecv)) deallocate(torecv) + + ! Share ghost particles in +y (ghosts need to be sent now - but not newly received ghosts!) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(2).gt.this%cfg%jmax_-no) nsend=nsend+1 + end do + do n=1,this%ng_-nrecv + if (this%g(n)%ind(2).gt.this%cfg%jmax_-no) nsend=nsend+1 + end do + allocate(tosend(nsend)) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(2).gt.this%cfg%jmax_-no) then + nsend=nsend+1 + tosend(nsend)=this%p(n) + if (this%cfg%yper.and.tosend(nsend)%ind(2).gt.this%cfg%jmax-no) then + tosend(nsend)%pos(2)=tosend(nsend)%pos(2)-this%cfg%yL + tosend(nsend)%ind(2)=tosend(nsend)%ind(2)-this%cfg%ny + end if + end if + end do + do n=1,this%ng_-nrecv + if (this%g(n)%ind(2).gt.this%cfg%jmax_-no) then + nsend=nsend+1 + tosend(nsend)=this%g(n) + if (this%cfg%yper.and.tosend(nsend)%ind(2).gt.this%cfg%jmax-no) then + tosend(nsend)%pos(2)=tosend(nsend)%pos(2)-this%cfg%yL + tosend(nsend)%ind(2)=tosend(nsend)%ind(2)-this%cfg%ny + end if + end if + end do + nrecv=0 + call MPI_CART_SHIFT(this%cfg%comm,1,+1,isrc,idst,ierr) + call MPI_SENDRECV(nsend,1,MPI_INTEGER,idst,0,nrecv,1,MPI_INTEGER,isrc,0,this%cfg%comm,status,ierr) + allocate(torecv(nrecv)) + call MPI_SENDRECV(tosend,nsend,MPI_PART,idst,0,torecv,nrecv,MPI_PART,isrc,0,this%cfg%comm,status,ierr) + call this%resize_ghost(this%ng_+nrecv) + this%g(this%ng_+1:this%ng_+nrecv)=torecv + this%ng_=this%ng_+nrecv + if (allocated(tosend)) deallocate(tosend) + if (allocated(torecv)) deallocate(torecv) + + ! Share ghost particles in -z (ghosts need to be sent now) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(3).lt.this%cfg%kmin_+no) nsend=nsend+1 + end do + do n=1,this%ng_ + if (this%g(n)%ind(3).lt.this%cfg%kmin_+no) nsend=nsend+1 + end do + allocate(tosend(nsend)) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(3).lt.this%cfg%kmin_+no) then + nsend=nsend+1 + tosend(nsend)=this%p(n) + if (this%cfg%zper.and.tosend(nsend)%ind(3).lt.this%cfg%kmin+no) then + tosend(nsend)%pos(3)=tosend(nsend)%pos(3)+this%cfg%zL + tosend(nsend)%ind(3)=tosend(nsend)%ind(3)+this%cfg%nz + end if + end if + end do + do n=1,this%ng_ + if (this%g(n)%ind(3).lt.this%cfg%kmin_+no) then + nsend=nsend+1 + tosend(nsend)=this%g(n) + if (this%cfg%zper.and.tosend(nsend)%ind(3).lt.this%cfg%kmin+no) then + tosend(nsend)%pos(3)=tosend(nsend)%pos(3)+this%cfg%zL + tosend(nsend)%ind(3)=tosend(nsend)%ind(3)+this%cfg%nz + end if + end if + end do + nrecv=0 + call MPI_CART_SHIFT(this%cfg%comm,2,-1,isrc,idst,ierr) + call MPI_SENDRECV(nsend,1,MPI_INTEGER,idst,0,nrecv,1,MPI_INTEGER,isrc,0,this%cfg%comm,status,ierr) + allocate(torecv(nrecv)) + call MPI_SENDRECV(tosend,nsend,MPI_PART,idst,0,torecv,nrecv,MPI_PART,isrc,0,this%cfg%comm,status,ierr) + call this%resize_ghost(this%ng_+nrecv) + this%g(this%ng_+1:this%ng_+nrecv)=torecv + this%ng_=this%ng_+nrecv + if (allocated(tosend)) deallocate(tosend) + if (allocated(torecv)) deallocate(torecv) + + ! Share ghost particles in +z (ghosts need to be sent now - but not newly received ghosts!) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(3).gt.this%cfg%kmax_-no) nsend=nsend+1 + end do + do n=1,this%ng_-nrecv + if (this%g(n)%ind(3).gt.this%cfg%kmax_-no) nsend=nsend+1 + end do + allocate(tosend(nsend)) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(3).gt.this%cfg%kmax_-no) then + nsend=nsend+1 + tosend(nsend)=this%p(n) + if (this%cfg%zper.and.tosend(nsend)%ind(3).gt.this%cfg%kmax-no) then + tosend(nsend)%pos(3)=tosend(nsend)%pos(3)-this%cfg%zL + tosend(nsend)%ind(3)=tosend(nsend)%ind(3)-this%cfg%nz + end if + end if + end do + do n=1,this%ng_-nrecv + if (this%g(n)%ind(3).gt.this%cfg%kmax_-no) then + nsend=nsend+1 + tosend(nsend)=this%g(n) + if (this%cfg%zper.and.tosend(nsend)%ind(3).gt.this%cfg%kmax-no) then + tosend(nsend)%pos(3)=tosend(nsend)%pos(3)-this%cfg%zL + tosend(nsend)%ind(3)=tosend(nsend)%ind(3)-this%cfg%nz + end if + end if + end do + nrecv=0 + call MPI_CART_SHIFT(this%cfg%comm,2,+1,isrc,idst,ierr) + call MPI_SENDRECV(nsend,1,MPI_INTEGER,idst,0,nrecv,1,MPI_INTEGER,isrc,0,this%cfg%comm,status,ierr) + allocate(torecv(nrecv)) + call MPI_SENDRECV(tosend,nsend,MPI_PART,idst,0,torecv,nrecv,MPI_PART,isrc,0,this%cfg%comm,status,ierr) + call this%resize_ghost(this%ng_+nrecv) + this%g(this%ng_+1:this%ng_+nrecv)=torecv + this%ng_=this%ng_+nrecv + if (allocated(tosend)) deallocate(tosend) + if (allocated(torecv)) deallocate(torecv) + + end subroutine share + + + !> Synchronize particle arrays across processors + subroutine sync(this) + use mpi_f08 + implicit none + class(lss), intent(inout) :: this + integer, dimension(0:this%cfg%nproc-1) :: nsend_proc,nrecv_proc + integer, dimension(0:this%cfg%nproc-1) :: nsend_disp,nrecv_disp + integer :: n,prank,ierr + type(part), dimension(:), allocatable :: buf_send + ! Recycle first to minimize communication load + call this%recycle() + ! Prepare information about what to send + nsend_proc=0 + do n=1,this%np_ + prank=this%cfg%get_rank(this%p(n)%ind) + nsend_proc(prank)=nsend_proc(prank)+1 + end do + nsend_proc(this%cfg%rank)=0 + ! Inform processors of what they will receive + call MPI_ALLtoALL(nsend_proc,1,MPI_INTEGER,nrecv_proc,1,MPI_INTEGER,this%cfg%comm,ierr) + ! Prepare displacements for all-to-all + nsend_disp(0)=0 + nrecv_disp(0)=this%np_ !< Directly add particles at the end of main array + do n=1,this%cfg%nproc-1 + nsend_disp(n)=nsend_disp(n-1)+nsend_proc(n-1) + nrecv_disp(n)=nrecv_disp(n-1)+nrecv_proc(n-1) + end do + ! Allocate buffer to send particles + allocate(buf_send(sum(nsend_proc))) + ! Pack the particles in the send buffer + nsend_proc=0 + do n=1,this%np_ + ! Get the rank + prank=this%cfg%get_rank(this%p(n)%ind) + ! Skip particles still inside + if (prank.eq.this%cfg%rank) cycle + ! Pack up for sending + nsend_proc(prank)=nsend_proc(prank)+1 + buf_send(nsend_disp(prank)+nsend_proc(prank))=this%p(n) + ! Flag particle for removal + this%p(n)%flag=1 + end do + ! Allocate buffer for receiving particles + call this%resize(this%np_+sum(nrecv_proc)) + ! Perform communication + call MPI_ALLtoALLv(buf_send,nsend_proc,nsend_disp,MPI_PART,this%p,nrecv_proc,nrecv_disp,MPI_PART,this%cfg%comm,ierr) + ! Deallocate buffer + deallocate(buf_send) + ! Recycle to remove duplicate particles + call this%recycle() + end subroutine sync + + + !> Adaptation of particle array size + subroutine resize(this,n) + implicit none + class(lss), intent(inout) :: this + integer, intent(in) :: n + type(part), dimension(:), allocatable :: tmp + integer :: size_now,size_new + ! Resize particle array to size n + if (.not.allocated(this%p)) then + ! Allocate directly to size n + allocate(this%p(n)) + this%p(1:n)%flag=1 + else + ! Update from a non-zero size to another non-zero size + size_now=size(this%p,dim=1) + if (n.gt.size_now) then + size_new=max(n,int(real(size_now,WP)*coeff_up)) + allocate(tmp(size_new)) + tmp(1:size_now)=this%p + tmp(size_now+1:)%flag=1 + call move_alloc(tmp,this%p) + else if (n.lt.int(real(size_now,WP)*coeff_dn)) then + allocate(tmp(n)) + tmp(1:n)=this%p(1:n) + call move_alloc(tmp,this%p) + end if + end if + end subroutine resize + + + !> Adaptation of ghost array size + subroutine resize_ghost(this,n) + implicit none + class(lss), intent(inout) :: this + integer, intent(in) :: n + type(part), dimension(:), allocatable :: tmp + integer :: size_now,size_new + ! Resize ghost array to size n + if (.not.allocated(this%g)) then + ! Allocate directly to size n + allocate(this%g(n)) + this%g(1:n)%flag=1 + else + ! Update from a non-zero size to another non-zero size + size_now=size(this%g,dim=1) + if (n.gt.size_now) then + size_new=max(n,int(real(size_now,WP)*coeff_up)) + allocate(tmp(size_new)) + tmp(1:size_now)=this%g + tmp(size_now+1:)%flag=1 + call move_alloc(tmp,this%g) + else if (n.lt.int(real(size_now,WP)*coeff_dn)) then + allocate(tmp(n)) + tmp(1:n)=this%g(1:n) + call move_alloc(tmp,this%g) + end if + end if + end subroutine resize_ghost + + + !> Clean-up of particle array by removing flag=1 particles + subroutine recycle(this) + implicit none + class(lss), intent(inout) :: this + integer :: new_size,i,ierr + ! Compact all active particles at the beginning of the array + new_size=0 + if (allocated(this%p)) then + do i=1,size(this%p,dim=1) + if (this%p(i)%flag.ne.1) then + new_size=new_size+1 + if (i.ne.new_size) then + this%p(new_size)=this%p(i) + this%p(i)%flag=1 + end if + end if + end do + end if + ! Resize to new size + call this%resize(new_size) + ! Update number of particles + this%np_=new_size + call MPI_ALLGATHER(this%np_,1,MPI_INTEGER,this%np_proc,1,MPI_INTEGER,this%cfg%comm,ierr) + this%np=sum(this%np_proc) + end subroutine recycle + + + !> Parallel write particles to file + subroutine write(this,filename) + use mpi_f08 + use messager, only: die + use parallel, only: info_mpiio + implicit none + class(lss), intent(inout) :: this + character(len=*), intent(in) :: filename + type(MPI_File) :: ifile + type(MPI_Status):: status + integer(kind=MPI_OFFSET_KIND) :: offset + integer :: i,ierr,iunit + + ! Root serial-writes the file header + if (this%cfg%amRoot) then + ! Open the file + open(newunit=iunit,file=trim(filename),form='unformatted',status='replace',access='stream',iostat=ierr) + if (ierr.ne.0) call die('[lss write] Problem encountered while serial-opening data file: '//trim(filename)) + ! Number of particles and particle object size + write(iunit) this%np,MPI_PART_SIZE + ! Done with the header + close(iunit) + end if + + ! The rest is done in parallel + call MPI_FILE_OPEN(this%cfg%comm,trim(filename),IOR(MPI_MODE_WRONLY,MPI_MODE_APPEND),info_mpiio,ifile,ierr) + if (ierr.ne.0) call die('[lss write] Problem encountered while parallel-opening data file: '//trim(filename)) + + ! Get current position + call MPI_FILE_GET_POSITION(ifile,offset,ierr) + + ! Compute the offset and write + do i=1,this%cfg%rank + offset=offset+int(this%np_proc(i),MPI_OFFSET_KIND)*int(MPI_PART_SIZE,MPI_OFFSET_KIND) + end do + if (this%np_.gt.0) call MPI_FILE_WRITE_AT(ifile,offset,this%p,this%np_,MPI_PART,status,ierr) + + ! Close the file + call MPI_FILE_CLOSE(ifile,ierr) + + ! Log/screen output + logging: block + use, intrinsic :: iso_fortran_env, only: output_unit + use param, only: verbose + use messager, only: log + use string, only: str_long + character(len=str_long) :: message + if (this%cfg%amRoot) then + write(message,'("[lss write] Wrote ",i0," particles to file [",a,"] on partitioned grid [",a,"]")') this%np,trim(filename),trim(this%cfg%name) + if (verbose.gt.2) write(output_unit,'(a)') trim(message) + if (verbose.gt.1) call log(message) + end if + end block logging + + end subroutine write + + + !> Parallel read particles to file + subroutine read(this,filename) + use mpi_f08 + use messager, only: die + use parallel, only: info_mpiio + implicit none + class(lss), intent(inout) :: this + character(len=*), intent(in) :: filename + type(MPI_File) :: ifile + type(MPI_Status):: status + integer(kind=MPI_OFFSET_KIND) :: offset,header_offset + integer :: i,j,ierr,npadd,psize,nchunk,cnt + integer, dimension(:,:), allocatable :: ppp + + ! First open the file in parallel + call MPI_FILE_OPEN(this%cfg%comm,trim(filename),MPI_MODE_RDONLY,info_mpiio,ifile,ierr) + if (ierr.ne.0) call die('[lss read] Problem encountered while reading data file: '//trim(filename)) + + ! Read file header first + call MPI_FILE_READ_ALL(ifile,npadd,1,MPI_INTEGER,status,ierr) + call MPI_FILE_READ_ALL(ifile,psize,1,MPI_INTEGER,status,ierr) + + ! Remember current position + call MPI_FILE_GET_POSITION(ifile,header_offset,ierr) + + ! Check compatibility of particle type + if (psize.ne.MPI_PART_SIZE) call die('[lss read] Particle type unreadable') + + ! Naively share reading task among all processors + nchunk=int(npadd/(this%cfg%nproc*part_chunk_size))+1 + allocate(ppp(this%cfg%nproc,nchunk)) + ppp=int(npadd/(this%cfg%nproc*nchunk)) + cnt=0 + out:do j=1,nchunk + do i=1,this%cfg%nproc + cnt=cnt+1 + if (cnt.gt.mod(npadd,this%cfg%nproc*nchunk)) exit out + ppp(i,j)=ppp(i,j)+1 + end do + end do out + + ! Read by chunk + do j=1,nchunk + ! Find offset + offset=header_offset+int(MPI_PART_SIZE,MPI_OFFSET_KIND)*int(sum(ppp(1:this%cfg%rank,:))+sum(ppp(this%cfg%rank+1,1:j-1)),MPI_OFFSET_KIND) + ! Resize particle array + call this%resize(this%np_+ppp(this%cfg%rank+1,j)) + ! Read this file + call MPI_FILE_READ_AT(ifile,offset,this%p(this%np_+1:this%np_+ppp(this%cfg%rank+1,j)),ppp(this%cfg%rank+1,j),MPI_PART,status,ierr) + ! Most general case: relocate every droplet + do i=this%np_+1,this%np_+ppp(this%cfg%rank+1,j) + this%p(i)%ind=this%cfg%get_ijk_global(this%p(i)%pos,this%p(i)%ind) + end do + ! Exchange all that + call this%sync() + end do + + ! Close the file + call MPI_FILE_CLOSE(ifile,ierr) + + ! Log/screen output + logging: block + use, intrinsic :: iso_fortran_env, only: output_unit + use param, only: verbose + use messager, only: log + use string, only: str_long + character(len=str_long) :: message + if (this%cfg%amRoot) then + write(message,'("[lss read] Read ",i0," particles from file [",a,"] on partitioned grid [",a,"]")') npadd,trim(filename),trim(this%cfg%name) + if (verbose.gt.2) write(output_unit,'(a)') trim(message) + if (verbose.gt.1) call log(message) + end if + end block logging + + end subroutine read + + +end module lss_class diff --git a/examples/NOSB_cylinder_peridigm/src/lsspd_class.f90 b/examples/NOSB_cylinder_peridigm/src/lsspd_class.f90 new file mode 100644 index 000000000..df2dfa3c1 --- /dev/null +++ b/examples/NOSB_cylinder_peridigm/src/lsspd_class.f90 @@ -0,0 +1,842 @@ +!> Lagrangian solid solver object +!> Attempt at integrating the pdsolver_class without AMR +module lsspd_class + use precision, only: WP, I8 + use string, only: str_medium + use config_class, only: config + use ddadi_class, only: ddadi + use mpi_f08, only: MPI_Datatype,MPI_INTEGER8,MPI_INTEGER,MPI_DOUBLE_PRECISION + use NOSB_class, only: pdsolver, PDC_IS_DEAD, PDC_BONDS, PDC_INTEGRATES, PDC_MOVES, pd_partition + implicit none + private + + + ! Expose type/constructor/methods + public :: lss, PDC_MOVES, PDC_IS_DEAD, PDC_BONDS, PDC_INTEGRATES, pd_partition + + + !> Memory adaptation parameter + real(WP), parameter :: coeff_up=1.3_WP !< Particle array size increase factor + real(WP), parameter :: coeff_dn=0.7_WP !< Particle array size decrease factor + + + !> I/O chunk size to read at a time + integer, parameter :: part_chunk_size=1000 !< Read 1000 particles at a time before redistributing + + ! MPI message tags for the NOSB <-> fluid particle bridge. + integer, parameter :: TAG_PARTICLE_COUNT = 1001 + integer, parameter :: TAG_PARTICLE_GID = 1002 + integer, parameter :: TAG_PARTICLE_Y = 1003 + integer, parameter :: TAG_PARTICLE_V = 1004 + integer, parameter :: TAG_PARTICLE_TEST = 1005 + + integer, parameter :: TAG_FORCE_COUNT = 1011 + integer, parameter :: TAG_FORCE_GID = 1012 + integer, parameter :: TAG_FORCE_FF = 1013 + + ! We will use this copy for giving and recieving fluid solver information, since we don't want to pass the entire lss object + type :: pd_copy + integer :: nown=0 !< Number of particles in this copy + real(WP), allocatable :: y(:,:) !< position, (3,nown) + real(WP), allocatable :: v(:,:) !< velocity, (3,nown) + real(WP), allocatable :: ff(:,:) !< filled locally by fluid, (3,nown) + end type pd_copy + + !> Lagrangian solid solver object definition + !> Extends the existing pdsolver_class, incorporating the coupling functions + type, extends(pdsolver) :: lss + + ! This config is used for parallelization and for calculating bond/collision forces + class(config), pointer :: cfg + + type(ddadi) :: implicit !< Implicit solver for filtering + type(pd_copy) :: fluid_copy !< Copy of the particle data to send to the fluid solver + ! Solid volume fraction and momentum + real(WP), dimension(:,:,:), allocatable :: VF !< Volume fraction, cell-centered + real(WP), dimension(:,:,:), allocatable :: VFU !< Solid velocity, U-face + real(WP), dimension(:,:,:), allocatable :: VFV !< Solid velocity, V-face + real(WP), dimension(:,:,:), allocatable :: VFW !< Solid velocity, W-face + + ! CFL numbers + real(WP) :: CFLp_x,CFLp_y,CFLp_z,CFLp_a + + real(WP) :: VFmax !< Volume fraction info + real(WP), dimension(3) :: ibmForce !< Total force due to IBM + + ! Filtering operation + real(WP) :: filter_width !< Characteristic filter width + real(WP), dimension(:,:,:,:), allocatable :: div_x,div_y,div_z !< Divergence operator + real(WP), dimension(:,:,:,:), allocatable :: grd_x,grd_y,grd_z !< Gradient operator + + ! Compatibility with the old non-amr version + integer, dimension(:,:), allocatable :: icell !< Index of cell containing the particle + !< (this might be unnecessary or already exist somewhere, + !< but not in the pdsolver alone I think) + + ! Moving or not (allow flow to setup) + real(WP) :: unfreeze_time + + ! Communcation related fields for handling the fluid solver + integer, allocatable :: fluid_rank(:) !< Fluid rank associated with the particle + + ! Communication testing + integer, allocatable :: which_rank(:) !< Which rank owns me (for debugging, comment for runs) + contains + procedure :: advance !< Step forward the particle ODEs + procedure :: update_partmesh !< Update a partmesh object using current particles + procedure :: update_VF !< Compute volume fraction + procedure :: filter !< Apply volume filtering to field + ! procedure :: get_cfl + procedure :: update_fluid_location !< Update the fluid rank and index for each particle + procedure :: fluid_sync + procedure :: compute_fluid_forces + end type lss + + + + + !> Declare lss constructor + interface lss + procedure constructor + end interface lss + +contains + + + !> Default constructor for Lagrangian solid solver + function constructor(cfg,name) result(self) + implicit none + type(lss) :: self + class(config), target, intent(in) :: cfg + character(len=*), optional :: name + integer :: i,j,k + + ! Set the name for the solver + if (present(name)) self%name=trim(adjustl(name)) + + ! Point to pgrid object + self%cfg=>cfg + + self%Ldom = [self%cfg%xL, self%cfg%yL, self%cfg%zL] + + self%per = [self%cfg%xper, & + self%cfg%yper, & + self%cfg%zper] + + self%collapsed = [self%cfg%nx.eq.1, & + self%cfg%ny.eq.1, & + self%cfg%nz.eq.1] + + self%dom_lo = [self%cfg%x(self%cfg%imin), & + self%cfg%y(self%cfg%jmin), & + self%cfg%z(self%cfg%kmin)] + + self%dom_hi = [self%cfg%x(self%cfg%imax+1), & + self%cfg%y(self%cfg%jmax+1), & + self%cfg%z(self%cfg%kmax+1)] + + ! ! Initialize MPI derived datatype for a particle + ! call prepare_mpi_part() ! IVM, do we need this still? I think that pdsolver handles communication... + + + ! Allocate VF array on cfg mesh + allocate(self%VF(self%cfg%imino_:self%cfg%imaxo_,self%cfg%jmino_:self%cfg%jmaxo_,self%cfg%kmino_:self%cfg%kmaxo_)); self%VF=0.0_WP + allocate(self%VFU(self%cfg%imino_:self%cfg%imaxo_,self%cfg%jmino_:self%cfg%jmaxo_,self%cfg%kmino_:self%cfg%kmaxo_)); self%VFU=0.0_WP + allocate(self%VFV(self%cfg%imino_:self%cfg%imaxo_,self%cfg%jmino_:self%cfg%jmaxo_,self%cfg%kmino_:self%cfg%kmaxo_)); self%VFV=0.0_WP + allocate(self%VFW(self%cfg%imino_:self%cfg%imaxo_,self%cfg%jmino_:self%cfg%jmaxo_,self%cfg%kmino_:self%cfg%kmaxo_)); self%VFW=0.0_WP + + ! Allocate finite volume divergence operators + allocate(self%div_x(0:+1,self%cfg%imin_:self%cfg%imax_,self%cfg%jmin_:self%cfg%jmax_,self%cfg%kmin_:self%cfg%kmax_)) !< Cell-centered + allocate(self%div_y(0:+1,self%cfg%imin_:self%cfg%imax_,self%cfg%jmin_:self%cfg%jmax_,self%cfg%kmin_:self%cfg%kmax_)) !< Cell-centered + allocate(self%div_z(0:+1,self%cfg%imin_:self%cfg%imax_,self%cfg%jmin_:self%cfg%jmax_,self%cfg%kmin_:self%cfg%kmax_)) !< Cell-centered + ! Create divergence operator to cell center [xm,ym,zm] + do k=self%cfg%kmin_,self%cfg%kmax_ + do j=self%cfg%jmin_,self%cfg%jmax_ + do i=self%cfg%imin_,self%cfg%imax_ + self%div_x(:,i,j,k)=self%cfg%dxi(i)*[-1.0_WP,+1.0_WP] !< Divergence from [x ,ym,zm] + self%div_y(:,i,j,k)=self%cfg%dyi(j)*[-1.0_WP,+1.0_WP] !< Divergence from [xm,y ,zm] + self%div_z(:,i,j,k)=self%cfg%dzi(k)*[-1.0_WP,+1.0_WP] !< Divergence from [xm,ym,z ] + end do + end do + end do + + ! Allocate finite difference velocity gradient operators + allocate(self%grd_x(-1:0,self%cfg%imin_:self%cfg%imax_+1,self%cfg%jmin_:self%cfg%jmax_+1,self%cfg%kmin_:self%cfg%kmax_+1)) !< X-face-centered + allocate(self%grd_y(-1:0,self%cfg%imin_:self%cfg%imax_+1,self%cfg%jmin_:self%cfg%jmax_+1,self%cfg%kmin_:self%cfg%kmax_+1)) !< Y-face-centered + allocate(self%grd_z(-1:0,self%cfg%imin_:self%cfg%imax_+1,self%cfg%jmin_:self%cfg%jmax_+1,self%cfg%kmin_:self%cfg%kmax_+1)) !< Z-face-centered + ! Create gradient coefficients to cell faces + do k=self%cfg%kmin_,self%cfg%kmax_+1 + do j=self%cfg%jmin_,self%cfg%jmax_+1 + do i=self%cfg%imin_,self%cfg%imax_+1 + self%grd_x(:,i,j,k)=self%cfg%dxmi(i)*[-1.0_WP,+1.0_WP] !< Gradient in x from [xm,ym,zm] to [x,ym,zm] + self%grd_y(:,i,j,k)=self%cfg%dymi(j)*[-1.0_WP,+1.0_WP] !< Gradient in y from [xm,ym,zm] to [xm,y,zm] + self%grd_z(:,i,j,k)=self%cfg%dzmi(k)*[-1.0_WP,+1.0_WP] !< Gradient in z from [xm,ym,zm] to [xm,ym,z] + end do + end do + end do + + ! Loop over the domain and zero divergence in walls + do k=self%cfg%kmin_,self%cfg%kmax_ + do j=self%cfg%jmin_,self%cfg%jmax_ + do i=self%cfg%imin_,self%cfg%imax_ + if (self%cfg%VF(i,j,k).eq.0.0_WP) then + self%div_x(:,i,j,k)=0.0_WP + self%div_y(:,i,j,k)=0.0_WP + self%div_z(:,i,j,k)=0.0_WP + end if + end do + end do + end do + + ! Zero out gradient to wall faces + do k=self%cfg%kmin_,self%cfg%kmax_+1 + do j=self%cfg%jmin_,self%cfg%jmax_+1 + do i=self%cfg%imin_,self%cfg%imax_+1 + if (self%cfg%VF(i,j,k).eq.0.0_WP.or.self%cfg%VF(i-1,j,k).eq.0.0_WP) self%grd_x(:,i,j,k)=0.0_WP + if (self%cfg%VF(i,j,k).eq.0.0_WP.or.self%cfg%VF(i,j-1,k).eq.0.0_WP) self%grd_y(:,i,j,k)=0.0_WP + if (self%cfg%VF(i,j,k).eq.0.0_WP.or.self%cfg%VF(i,j,k-1).eq.0.0_WP) self%grd_z(:,i,j,k)=0.0_WP + end do + end do + end do + + ! Adjust metrics to account for lower dimensionality + if (self%cfg%nx.eq.1) then + self%div_x=0.0_WP + self%grd_x=0.0_WP + end if + if (self%cfg%ny.eq.1) then + self%div_y=0.0_WP + self%grd_y=0.0_WP + end if + if (self%cfg%nz.eq.1) then + self%div_z=0.0_WP + self%grd_z=0.0_WP + end if + + ! Create implicit solver object for filtering + self%implicit=ddadi(cfg=self%cfg,name='Filter',nst=7) + self%implicit%stc(1,:)=[ 0, 0, 0] + self%implicit%stc(2,:)=[+1, 0, 0] + self%implicit%stc(3,:)=[-1, 0, 0] + self%implicit%stc(4,:)=[ 0,+1, 0] + self%implicit%stc(5,:)=[ 0,-1, 0] + self%implicit%stc(6,:)=[ 0, 0,+1] + self%implicit%stc(7,:)=[ 0, 0,-1] + call self%implicit%init() + + ! Set default filter width + self%filter_width=1.0_WP*self%cfg%min_meshsize + + ! Log/screen output + logging: block + use, intrinsic :: iso_fortran_env, only: output_unit + use param, only: verbose + use messager, only: log + use string, only: str_long + character(len=str_long) :: message + if (self%cfg%amRoot) then + write(message,'("LSS object [",a,"] on partitioned grid [",a,"]")') trim(self%name),trim(self%cfg%name) + if (verbose.gt.1) write(output_unit,'(a)') trim(message) + if (verbose.gt.0) call log(message) + end if + end block logging + + end function constructor + + + + !> Advance the particle equations by a specified time step dt + subroutine advance(this,dt,unfreeze,div_stress_x,div_stress_y,div_stress_z) + implicit none + class(lss), intent(inout) :: this + real(WP), intent(inout) :: dt !< Timestep size over which to advance + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(inout) :: div_stress_x !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(inout) :: div_stress_y !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(inout) :: div_stress_z !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + integer :: n,i + logical, intent(in) :: unfreeze + ! updates particle positions, shares particles to fluid-cell rank-owners, compute fluid force, and return ff (fluid force) + call this%fluid_sync(d_stress_x=div_stress_x,d_stress_y=div_stress_y,d_stress_z=div_stress_z) + ! now the particles are communicated down to get their fluid forces + call this%pd_advance(dt) ! use fluid forces and compute bond forces, and update position due to verlet scheme + call this%update_VF() + if (unfreeze) then + do i = 1,this%nown + this%damping_rate = 0.0005_WP + if (this%flag(i).eq.(PDC_MOVES+PDC_BONDS)) this%v(:,i)= 0.0_WP + end do + end if + + + + ! call this%update_VF() ! now we update the volume fraction + + + ! Log/screen output (do we need to do this still?) + ! logging: block + ! use, intrinsic :: iso_fortran_env, only: output_unit + ! use param, only: verbose + ! use messager, only: log + ! use string, only: str_long + ! character(len=str_long) :: message + ! if (this%cfg%amRoot) then + ! write(message,'("Particle solver [",a,"] on partitioned grid [",a,"]: ",i0," particles were advanced")') trim(this%name),trim(this%cfg%name),this%np + ! if (verbose.gt.1) write(output_unit,'(a)') trim(message) + ! if (verbose.gt.0) call log(message) + ! end if + ! end block logging + + end subroutine advance + + + !> Update particle volume fraction using our current particles + subroutine update_VF(this) + implicit none + class(lss), intent(inout) :: this + integer :: i + integer, dimension(3) :: idx + ! Reset volume fraction and momentum + this%VF=0.0_WP; this%VFU=0.0_WP; this%VFV=0.0_WP; this%VFW=0.0_WP + ! Transfer particle volume + idx = 0 + do i=1,this%fluid_copy%nown ! we only do the particles that we actually physically have + ! Transfer volume to mesh + idx = this%cfg%get_ijk_global(this%fluid_copy%y(:,i),idx) + call this%cfg%set_scalar(Sp=this%dV, pos=this%fluid_copy%y(:,i),i0=idx(1),j0=idx(2),k0=idx(3),S=this%VF ,bc='n') + call this%cfg%set_scalar(Sp=this%dV*this%fluid_copy%v(1,i), pos=this%fluid_copy%y(:,i),i0=idx(1),j0=idx(2),k0=idx(3),S=this%VFU,bc='n') + call this%cfg%set_scalar(Sp=this%dV*this%fluid_copy%v(2,i), pos=this%fluid_copy%y(:,i),i0=idx(1),j0=idx(2),k0=idx(3),S=this%VFV,bc='n') + call this%cfg%set_scalar(Sp=this%dV*this%fluid_copy%v(3,i), pos=this%fluid_copy%y(:,i),i0=idx(1),j0=idx(2),k0=idx(3),S=this%VFW,bc='n') + end do + this%VF =this%VF /this%cfg%vol + this%VFU=this%VFU/this%cfg%vol + this%VFV=this%VFV/this%cfg%vol + this%VFW=this%VFW/this%cfg%vol + ! Sum at boundaries + call this%cfg%syncsum(this%VF ) + call this%cfg%syncsum(this%VFU) + call this%cfg%syncsum(this%VFV) + call this%cfg%syncsum(this%VFW) + ! Apply volume filter + call this%filter(this%VF ) + call this%filter(this%VFU) + call this%filter(this%VFV) + call this%filter(this%VFW) + ! Clip + where (this%VF.lt.0.0_WP) this%VF=0.0_WP + this%VF=min(this%VF,1.0_WP-epsilon(1.0_WP)) + + end subroutine update_VF + + ! subroutine get_cfl(this,dt,cfl) + ! use mpi_f08, only: MPI_ALLREDUCE,MPI_MAX + ! use parallel, only: MPI_REAL_WP + ! implicit none + ! class(lss), intent(inout) :: this + ! real(WP), intent(in) :: dt + ! real(WP), intent(out) :: cfl + ! integer :: i,ierr + ! real(WP) :: my_CFLp_x,my_CFLp_y,my_CFLp_z,kk,mu,a + + ! ! Set the CFLs to zero + ! my_CFLp_x=0.0_WP; my_CFLp_y=0.0_WP; my_CFLp_z=0.0_WP + ! do i=1,this%nown + ! my_CFLp_x=max(my_CFLp_x,abs(this%v(1,i))*this%cfg%dxi(this%icell(1,i))) + ! my_CFLp_y=max(my_CFLp_y,abs(this%v(2,i))*this%cfg%dyi(this%icell(2,i))) + ! my_CFLp_z=max(my_CFLp_z,abs(this%v(3,i))*this%cfg%dzi(this%icell(3,i))) + ! end do + ! my_CFLp_x=my_CFLp_x*dt; my_CFLp_y=my_CFLp_y*dt; my_CFLp_z=my_CFLp_z*dt + + ! ! Get the parallel max + ! call MPI_ALLREDUCE(my_CFLp_x,this%CFLp_x,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + ! call MPI_ALLREDUCE(my_CFLp_y,this%CFLp_y,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + ! call MPI_ALLREDUCE(my_CFLp_z,this%CFLp_z,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + + ! ! CFL based on elastic wave speed in material + ! kk=this%elastic_modulus/(3.0_WP-6.0_WP*this%poisson_ratio) + ! mu=this%elastic_modulus/(2.0_WP+2.0_WP*this%poisson_ratio) + ! a=sqrt((kk+4.0_WP*mu/3.0_WP)/this%rho) + ! this%CFLp_a=dt*a/this%delta + + ! ! Return the maximum CFL + ! cfl=max(this%CFLp_x,this%CFLp_y,this%CFLp_z,this%CFLp_a) + + ! end subroutine get_cfl + + + !> Laplacian filtering operation + subroutine filter(this,A) + implicit none + class(lss), intent(inout) :: this + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(inout) :: A !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + real(WP) :: filter_coeff + integer :: i,j,k,n,nstep + real(WP), dimension(:,:,:), allocatable :: FX,FY,FZ + + ! Recompute filter coefficient + filter_coeff=max(this%filter_width**2-this%cfg%min_meshsize**2,0.0_WP)/(16.0_WP*log(2.0_WP)) + if (filter_coeff.le.0.0_WP) return + + ! Allocate flux arrays + allocate(FX(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + allocate(FY(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + allocate(FZ(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + + if (.not.this%implicit%setup_done) then + ! Prepare diffusive operator (only need to do this once) + do k=this%cfg%kmin_,this%cfg%kmax_ + do j=this%cfg%jmin_,this%cfg%jmax_ + do i=this%cfg%imin_,this%cfg%imax_ + this%implicit%opr(1,i,j,k)=1.0_WP-(this%div_x(+1,i,j,k)*filter_coeff*this%grd_x(-1,i+1,j,k)+& + & this%div_x( 0,i,j,k)*filter_coeff*this%grd_x( 0,i ,j,k)+& + & this%div_y(+1,i,j,k)*filter_coeff*this%grd_y(-1,i,j+1,k)+& + & this%div_y( 0,i,j,k)*filter_coeff*this%grd_y( 0,i,j ,k)+& + & this%div_z(+1,i,j,k)*filter_coeff*this%grd_z(-1,i,j,k+1)+& + & this%div_z( 0,i,j,k)*filter_coeff*this%grd_z( 0,i,j,k )) + this%implicit%opr(2,i,j,k)= -(this%div_x(+1,i,j,k)*filter_coeff*this%grd_x( 0,i+1,j,k)) + this%implicit%opr(3,i,j,k)= -(this%div_x( 0,i,j,k)*filter_coeff*this%grd_x(-1,i ,j,k)) + this%implicit%opr(4,i,j,k)= -(this%div_y(+1,i,j,k)*filter_coeff*this%grd_y( 0,i,j+1,k)) + this%implicit%opr(5,i,j,k)= -(this%div_y( 0,i,j,k)*filter_coeff*this%grd_y(-1,i,j ,k)) + this%implicit%opr(6,i,j,k)= -(this%div_z(+1,i,j,k)*filter_coeff*this%grd_z( 0,i,j,k+1)) + this%implicit%opr(7,i,j,k)= -(this%div_z( 0,i,j,k)*filter_coeff*this%grd_z(-1,i,j,k )) + end do + end do + end do + end if + ! Explicit step + do k=this%cfg%kmin_,this%cfg%kmax_+1 + do j=this%cfg%jmin_,this%cfg%jmax_+1 + do i=this%cfg%imin_,this%cfg%imax_+1 + FX(i,j,k)=filter_coeff*sum(this%grd_x(:,i,j,k)*A(i-1:i,j,k)) + FY(i,j,k)=filter_coeff*sum(this%grd_y(:,i,j,k)*A(i,j-1:j,k)) + FZ(i,j,k)=filter_coeff*sum(this%grd_z(:,i,j,k)*A(i,j,k-1:k)) + end do + end do + end do + do k=this%cfg%kmin_,this%cfg%kmax_ + do j=this%cfg%jmin_,this%cfg%jmax_ + do i=this%cfg%imin_,this%cfg%imax_ + this%implicit%rhs(i,j,k)=sum(this%div_x(:,i,j,k)*FX(i:i+1,j,k))+sum(this%div_y(:,i,j,k)*FY(i,j:j+1,k))+sum(this%div_z(:,i,j,k)*FZ(i,j,k:k+1)) + end do + end do + end do + ! Implicit step + call this%implicit%setup() + this%implicit%sol=0.0_WP + call this%implicit%solve() + A=A+this%implicit%sol + call this%cfg%sync(A) + + ! Deallocate flux arrays + deallocate(FX,FY,FZ) + + end subroutine filter + + !> Update particle mesh using our current particles + subroutine update_partmesh(this,pmesh) + use partmesh_class, only: partmesh + implicit none + class(lss), intent(inout) :: this + class(partmesh), intent(inout) :: pmesh + integer :: i + ! Reset particle mesh storage + call pmesh%reset() + ! Nothing else to do if no particle is present + if (this%nown.eq.0) return + ! Copy particle info + call pmesh%set_size(this%nown) + do i=1,this%nown !< IVM, this might not be good, I think we will get duplicates this way + pmesh%pos(:,i)=this%y(:,i) + end do + end subroutine update_partmesh + + + ! !> Creation of the MPI datatype for particle ! IVM, Maybe we dont need this, since comm is handled by pdsolver? + ! subroutine prepare_mpi_part() + ! use mpi_f08 + ! use messager, only: die + ! implicit none + ! integer(MPI_ADDRESS_KIND), dimension(part_nblock) :: disp + ! integer(MPI_ADDRESS_KIND) :: lb,extent + ! type(MPI_Datatype) :: MPI_PART_TMP + ! integer :: i,mysize,ierr + ! ! Prepare the displacement array + ! disp(1)=0 + ! do i=2,part_nblock + ! call MPI_Type_size(part_tblock(i-1),mysize,ierr) + ! disp(i)=disp(i-1)+int(mysize,MPI_ADDRESS_KIND)*int(part_lblock(i-1),MPI_ADDRESS_KIND) + ! end do + ! ! Create and commit the new type + ! call MPI_Type_create_struct(part_nblock,part_lblock,disp,part_tblock,MPI_PART_TMP,ierr) + ! call MPI_Type_get_extent(MPI_PART_TMP,lb,extent,ierr) + ! call MPI_Type_create_resized(MPI_PART_TMP,lb,extent,MPI_PART,ierr) + ! call MPI_Type_commit(MPI_PART,ierr) + ! ! If a problem was encountered, say it + ! if (ierr.ne.0) call die('[lss prepare_mpi_part] MPI Particle type creation failed') + ! ! Get the size of this type + ! call MPI_type_size(MPI_PART,MPI_PART_SIZE,ierr) + ! end subroutine prepare_mpi_part + + subroutine update_fluid_location(this) + implicit none + class(lss), intent(inout) :: this + integer :: i + ! Ensure that we have allocated the fluid_rank array + if (allocated(this%fluid_rank)) then + if (size(this%fluid_rank).lt.max(this%nown,1)) then + deallocate(this%fluid_rank) + end if + end if + if (.not.allocated(this%fluid_rank)) then + allocate(this%fluid_rank(max(this%nown,1))) + end if + + if (allocated(this%icell)) then + if (size(this%icell,dim=2).lt.max(this%nown,1)) then + deallocate(this%icell) + end if + end if + if (.not.allocated(this%icell)) then + allocate(this%icell(3,max(this%nown,1))) + this%icell=0 + end if + + ! Update the fluid_rank and icell for each particle + do i=1,this%nown + if (this%flag(i).eq.PDC_IS_DEAD) cycle + ! Get the cell index for the particle + this%icell(:,i) = this%cfg%get_ijk_global(this%y(:,i), this%icell(:,i)) + ! Get the fluid rank for the particle + this%fluid_rank(i) = this%cfg%get_rank(this%icell(:,i)) + end do + + end subroutine update_fluid_location + + ! subroutine share_particles(this) + ! use parallel, only: MPI_REAL_WP + ! use mpi_f08 + ! implicit none + + ! class(lss), intent(inout) :: this + ! integer :: i, ierr, nranks, r + ! integer, allocatable :: send_count(:) ! List (nproc) of how many particles we should send + ! integer, allocatable :: recv_count(:) ! List (nproc) of how many particles we should recieve + ! integer, allocatable :: send_disp(:) ! Displacement for sending particles + ! integer, allocatable :: recv_disp(:) ! Displacement for recieving particles + ! integer :: nsend, nrecv ! Total number of particles to send and recieve + ! integer :: nreq ! Number of required messages + ! integer :: first ! first index of the recieve buffer for a given rank, and which message we are on + ! integer :: q ! which message we are on + ! integer :: slot ! index for where the rank information starta + ! real(WP), allocatable :: sy(:,:), sv(:,:) ! Send buffers for position, velocity + ! real(WP), allocatable :: ry(:,:), rv(:,:) ! Recieve buffers for position, velocity + ! integer, allocatable :: stest(:), rtest(:) ! Send and recieve buffers for testing + ! integer, allocatable :: next(:) ! Next index for sending particles to a given rank + ! type(MPI_Request), allocatable :: req(:) ! MPI requests for non-blocking communication + ! type(MPI_Status), allocatable :: stat(:) ! Status for the MPI requests + ! ! First we figure out which ranks we need to communicate with + ! call this%update_fluid_location() ! We update the fluid location and rank information for each particle nown + + ! nranks=this%cfg%nproc + ! allocate(send_count(0:nranks-1), recv_count(0:nranks-1)) + ! send_count=0 + ! recv_count=0 + ! do i = 1,this%nown + ! if (this%flag(i).eq.PDC_IS_DEAD) cycle + ! send_count(this%fluid_rank(i)) = send_count(this%fluid_rank(i)) + 1 ! count up how many particles need to get passed along + ! end do + + ! ! Now we populate the recv_count array by doing an all-to-all communication (only 1) + + ! call MPI_ALLTOALL(send_count,1,MPI_INTEGER, & + ! & recv_count,1,MPI_INTEGER, & + ! & this%cfg%comm,ierr) + + ! ! now everyone knows who they are recieving from and how many particles to get + ! ! now we size the recieve buffers to fit the amount of information and number of particles + + ! ! Total number of particle to send and recieve on this rank + ! nsend = sum(send_count) + ! nrecv = sum(recv_count) + + ! ! track the displacement needed for each rank for sending and recieving + ! allocate(send_disp(0:nranks-1), recv_disp(0:nranks-1)) + ! send_disp(0)=0; recv_disp(0)=0 + ! do r=1,nranks-1 + ! ! displacement for the contigous send and recieve buffers + ! ! we start at 0 on the 0th index, then add the number of particles to send + ! ! we then start the nexxt rank at the previous displacement plus the number of particles to send from that rank + ! ! e.g. if rank 0 is sending 3 particles, then rank 1 will start at index 3 in the send buffer, + ! ! and if rank 1 is sending 5 particles, then rank 2 will start at index 8 in the send buffer + ! send_disp(r) = send_disp(r-1) + send_count(r-1) + ! ! Same process for the recieve buffer + ! recv_disp(r) = recv_disp(r-1) + recv_count(r-1) + ! end do + + ! ! since we have different data types we are communicating, we need to allocate buffers for each tyep' + ! allocate(stest(max(nsend,1)),rtest(max(nrecv,1))) ! Global id buffers + ! allocate(sy(3,max(nsend,1)),ry(3,max(nrecv,1))) ! position buffers + ! allocate(sv(3,max(nsend,1)),rv(3,max(nrecv,1))) ! velocity buffers + + ! nreq=3*(count(recv_count.gt.0) + count(send_count.gt.0)) ! number of required messages + + ! if(nreq.gt.0) then + ! allocate(req(nreq),stat(nreq)) ! allocating status and request arrays for the number of messages + ! q=0 ! which message we are on + + ! do r=0,nranks-1 + ! if (recv_count(r).eq.0) cycle + + ! first=recv_disp(r)+1 ! first index of the recieve buffer for a given rank + + ! ! Setup recieve buffer for position + ! q=q+1 + ! call MPI_IRECV(ry(1,first),3*recv_count(r),MPI_REAL_WP, & ! multiply by three since vector + ! & r,TAG_PARTICLE_Y,this%cfg%comm,req(q),ierr) + + ! ! Setup recieve buffer for velocity + ! q=q+1 + ! call MPI_IRECV(rv(1,first),3*recv_count(r),MPI_REAL_WP, & ! mutliply by three since vector + ! & r,TAG_PARTICLE_V,this%cfg%comm,req(q),ierr) + + ! ! Setup test buffer for comms testing + ! q=q+1 + ! call MPI_IRECV(rtest(first),recv_count(r),MPI_INTEGER, & ! mutliply by three since vector + ! & r,TAG_PARTICLE_TEST,this%cfg%comm,req(q),ierr) + ! end do + ! end if + + ! ! Now we pack the message + ! allocate(next(0:nranks-1)) + ! next=send_disp + ! do i = 1,this%nown + ! if (this%flag(i).eq.PDC_IS_DEAD) cycle + ! r=this%fluid_rank(i) !which rank are we sending to + + ! next(r)=next(r)+1 ! we +1 this to put the particles one after + ! ! the next for this rank (if we didn't we would + ! ! overwrite the previous particle for this rank in the send buffer) + ! slot = next(r) ! we 1 index for the this% but 0 index for the send_disp + ! sy(:,slot)=this%y(:,i) + ! sv(:,slot)=this%v(:,i) + ! stest(slot)=this%which_rank(i) + ! end do + ! deallocate(next) + + ! if(nreq.gt.0) then + ! ! Now we send the messages + ! do r=0,nranks-1 + ! if (send_count(r).eq.0) cycle + + ! first=send_disp(r)+1 ! first index of the send buffer for a given rank + + ! ! Setup send buffer for position + ! q=q+1 + ! call MPI_ISEND(sy(1,first),3*send_count(r),MPI_REAL_WP, & + ! & r,TAG_PARTICLE_Y,this%cfg%comm,req(q),ierr) + + ! ! Setup send buffer for velocity + ! q=q+1 + ! call MPI_ISEND(sv(1,first),3*send_count(r),MPI_REAL_WP, & + ! & r,TAG_PARTICLE_V,this%cfg%comm,req(q),ierr) + + ! q=q+1 + ! call MPI_ISEND(stest(first),send_count(r),MPI_INTEGER, & + ! & r,TAG_PARTICLE_TEST,this%cfg%comm,req(q),ierr) + ! end do + + + ! end if + + ! if (nreq.gt.0) then + ! if (q.ne.nreq) then + ! error stop '[share_particles] MPI request count mismatch' + ! end if + + ! call MPI_WAITALL(nreq,req,stat,ierr) ! make sure everyone has done their sending and recieving + + ! deallocate(req,stat) + ! end if + + ! do r=0,nranks-1 + ! if (recv_count(r).eq.0) cycle + + ! first=recv_disp(r)+1 + + ! ! The block came from rank r, so every value should equal r. + ! if (any(rtest(first:first+recv_count(r)-1).ne.r)) then + ! write(*,*) 'Rank ',this%cfg%rank, & + ! & ' received incorrect test data from rank ',r + ! error stop '[share_particles] which_rank test failed' + ! end if + ! end do + + ! write(*,*) 'Rank ',this%cfg%rank, & + ! & ': particle communication test passed; received ',nrecv + + + + ! end subroutine share_particles + + ! Sends out particles accross ranks to those who own them for computing fluid forces on the particles + ! Also needed to update volume fractions + subroutine fluid_sync(this,d_stress_x,d_stress_y,d_stress_z) + use parallel, only: MPI_REAL_WP + use mpi_f08 + implicit none + + class(lss), intent(inout) :: this + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(inout) :: d_stress_x !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(inout) :: d_stress_y !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(inout) :: d_stress_z !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + + integer :: i, ierr, nranks, r, nsend, nrecv, rank, column + integer, allocatable :: send_count(:), recv_count(:) + integer, allocatable :: send_disp(:), recv_disp(:) + integer, allocatable :: next(:) + integer, allocatable :: send_lid(:) ! local id of the send (needed for the return trip) + real(WP), allocatable :: send_yv(:,:), recv_yv(:,:), recv_ff(:,:) + ! Maybe we do this seperatately instead of tying it in? + call this%update_fluid_location() ! We update the fluid location and rank information for each particle nown + + nranks=this%cfg%nproc + allocate(send_count(0:nranks-1), recv_count(0:nranks-1)) + send_count=0 + recv_count=0 + do i = 1,this%nown + if (this%flag(i).eq.PDC_IS_DEAD) cycle + send_count(this%fluid_rank(i)) = send_count(this%fluid_rank(i)) + 1 ! count up how many particles need to get passed along + end do + ! Now we populate the recv_count array by doing an all-to-all communication (only 1) + call MPI_ALLTOALL(send_count,1,MPI_INTEGER, & + & recv_count,1,MPI_INTEGER, & + & this%cfg%comm,ierr) + nsend = sum(send_count) ! total number of particles that are being send + nrecv = sum(recv_count) ! total number of particles we expect to recieve + ! Set up the displacement counts based on number of particles + allocate(send_disp(0:nranks-1), recv_disp(0:nranks-1)) + send_disp(0) = 0 + recv_disp(0) = 0 + do rank=1,nranks-1 + send_disp(rank) = send_disp(rank-1) + send_count(rank-1) + recv_disp(rank) = recv_disp(rank-1) + recv_count(rank-1) + end do + ! Pack message + allocate(send_yv(6,max(nsend,1))) + allocate(recv_yv(6,max(nrecv,1))) + send_yv=0.0_WP + recv_yv=0.0_WP + allocate(next(0:nranks-1)) + next=send_disp ! cursor + ! setup local map + allocate(send_lid(max(nsend,1))) + send_lid=0 + ! pack up the send buffer + do i = 1,this%nown + if (this%flag(i).eq.PDC_IS_DEAD) cycle + rank = this%fluid_rank(i) + next(rank) = next(rank) + 1 ! plus up for each particle that we are including starting at the rank displacement +1, (this will + ! not overwrite because the next(:) is based on the displacments and ensures the column mappings keeps + ! same-rank particles in blocks of adjacent columns) + column = next(rank) ! this is the index for the start of the information for that particle + ! The way that fortran stores information is column major so we associate each particle with a particular column + ! that way when we send it, it sends all in order the information for a particle, and we can unwrap + ! the send information in the same way if we construct the recieve buffer the same + send_yv(1:3,column) = this%y(:,i) + send_yv(4:6,column) = this%v(:,i) + ! save the local id for the way back + send_lid(column)=i + end do + ! MPI_Alltoallv( + ! sendbuf, Starting address of the send buffer in memory + ! sendcounts, Counts for the number of elements to send to each rank + ! sdispls, Displacements for the starting address of each rank's data in the send buffer, relative to sendbuf + ! sendtype, Data type of the send buffer elements + ! recvbuf, Starting address of the receive buffer in memory + ! recvcounts[], Counts for the number of elements to receive from each rank + ! rdispls[], Displacements for the starting address of each rank's data in the receive buffer, relative to recvbuf + ! recvtype, Data type of the receive buffer elements + ! comm Communicator handle + ! ) + ! each entry of send_counts is just 6 times the number of particles we are sending to that rank + + call MPI_ALLTOALLV(send_yv,send_count*6,send_disp*6,MPI_REAL_WP, & + recv_yv,recv_count*6,recv_disp*6,MPI_REAL_WP, & + this%cfg%comm,ierr) + + ! now recv_yv has all the particles that this processor needed, which we need to reconstruct + ! clear out the existing copies + if (allocated(this%fluid_copy%y)) then + deallocate(this%fluid_copy%y) + end if + + if (allocated(this%fluid_copy%v)) then + deallocate(this%fluid_copy%v) + end if + this%fluid_copy%nown=nrecv + allocate(this%fluid_copy%y(3,max(nrecv,1))) + allocate(this%fluid_copy%v(3,max(nrecv,1))) + this%fluid_copy%y=0.0_WP + this%fluid_copy%v=0.0_WP + + if (nrecv.gt.0) then + this%fluid_copy%y(:,1:nrecv)=recv_yv(1:3,1:nrecv) + this%fluid_copy%v(:,1:nrecv)=recv_yv(4:6,1:nrecv) + end if + + ! I think if we are careful about the order of nown we send and recieve, and keep it identically the same + ! we can get away without having to send the particle global id + + if (allocated(this%fluid_copy%ff)) then + deallocate(this%fluid_copy%ff) + end if + allocate(this%fluid_copy%ff(3,max(nrecv,1))) + this%fluid_copy%ff=0.0_WP + call this%update_VF() + call this%compute_fluid_forces(stress_x=d_stress_x,stress_y=d_stress_y,stress_z=d_stress_z) + + ! Back the way we came + allocate(recv_ff(3,max(nsend,1))) + recv_ff=0.0_WP + ! swap send and recieve since we are getting things back (should be the same order?) + call MPI_ALLTOALLV(this%fluid_copy%ff,recv_count*3,recv_disp*3,MPI_REAL_WP, & + & recv_ff,send_count*3,send_disp*3,MPI_REAL_WP, & + & this%cfg%comm,ierr) + do column=1,nsend + i=send_lid(column) + if (i.lt.1 .or. i.gt.this%nown) then + error stop '[sync] Invalid returned-force mapping' + end if + this%ff(:,i)=recv_ff(:,column) + end do + deallocate(next) + deallocate(send_yv,recv_yv) + deallocate(send_count,recv_count) + deallocate(recv_ff,send_lid) + + end subroutine fluid_sync + + ! Compute fluid forces acting on fluid_copy particles on each rank + subroutine compute_fluid_forces(this,stress_x,stress_y,stress_z) + implicit none + class(lss), intent(inout) :: this + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(inout) :: stress_x !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(inout) :: stress_y !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(inout) :: stress_z !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + integer :: n,ierr + real(WP), dimension(3) :: stress + integer, dimension(3) :: idx + ! Assumes that we have already shared copies and particle locations with ranks + idx = 0 + ! Compute the fluid forces on each particle using the copied particles we have + do n=1,this%fluid_copy%nown + ! Advance with Verlet scheme + + idx = this%cfg%get_ijk_global(this%fluid_copy%y(:,n),idx) ! is this slow? should we store it? + this%fluid_copy%ff(:,n)=this%cfg%get_velocity(pos=this%fluid_copy%y(:,n),i0=idx(1),j0=idx(2),k0=idx(3),U=stress_x,V=stress_y,W=stress_z) + ! we will divide by rho later + + end do + + end subroutine compute_fluid_forces + +end module lsspd_class diff --git a/examples/NOSB_cylinder_peridigm/src/pdhalo_class.f90 b/examples/NOSB_cylinder_peridigm/src/pdhalo_class.f90 new file mode 100644 index 000000000..7a8b88239 --- /dev/null +++ b/examples/NOSB_cylinder_peridigm/src/pdhalo_class.f90 @@ -0,0 +1,555 @@ +!> Persistent graph-halo communication for the peridynamics solver (pdsolver). +!> +!> Two objects: +!> pddir -- distributed GID directory. Owner-rank resolution for arbitrary +!> global ids via a hashed home-rank protocol (Fibonacci-mixed: +!> raw mod collapses on structured idcpu keys). +!> Built once at init, used during plan construction, then discarded. +!> pdhalo -- persistent halo exchange plan. A halo SLOT is a (gid, image-offset) +!> pair: a node bonded to two periodic images of the same partner +!> gets two slots with different shifts. Shifts are applied at +!> unpack time on the receiver, so send buffers are pure copies and +!> the same owned node can serve any number of slots/images. +!> Two operations per substep: +!> update(field) -- owner values -> halo slots (positions get +shift) +!> reduce(field) -- halo-slot accumulations -> add back into owners +!> Both are nonblocking isend/irecv with fixed, deterministic +!> pack/unpack order (neighbor rank ascending, slot order within). +!> +!> Self-rank "neighbors" (periodic self-images or same-rank image bonds) are +!> handled uniformly through MPI self-messages -- no special-case code path. +module pdhalo_class + use precision, only: WP,I8 + use mpi_f08 + implicit none + private + + public :: pddir,pdhalo,sort3_perm,PDHALO_KEY0 + + !> Packed zero image offset ((0+128) + (0+128)*256 + (0+128)*65536), + !> matching amrpd's hist1 convention. + integer, parameter :: PDHALO_KEY0=8421504 + + !> Distributed GID directory (hashed home-rank protocol) + type :: pddir + integer :: n=0 !< number of gids homed on this rank + integer(I8), allocatable :: keys(:) !< gids homed on this rank (sorted) + integer, allocatable :: owner(:) !< owner rank per homed gid (aligned with keys) + contains + procedure :: register + procedure :: query + procedure :: finalize => dir_finalize + end type pddir + + !> Persistent halo plan + exchange buffers + type :: pdhalo + integer :: nown=0 !< owned nodes (halo slots are indexed nown+1..nown+nhalo) + integer :: nhalo=0 !< halo slot count + ! Receive side: whom I receive halo data from (= owners of my slots) + integer :: nrecv=0 + integer, allocatable :: nbr_recv(:) !< source ranks, ascending + integer, allocatable :: recv_ptr(:) !< (nrecv+1) slot group offsets + ! Send side: whom I send owned data to (= ranks holding slots of my nodes) + integer :: nsend=0 + integer, allocatable :: nbr_send(:) !< destination ranks, ascending + integer, allocatable :: send_ptr(:) !< (nsend+1) entry group offsets + integer, allocatable :: send_idx(:) !< owned node index per send entry (duplicates allowed: one per remote slot) + ! Per-slot image shift (added to position components at unpack) + real(WP), allocatable :: shift(:,:) !< (3,nhalo) + ! Persistent message buffers (grown on demand) + real(WP), allocatable :: sbuf(:),rbuf(:) + contains + procedure :: build + procedure :: update + procedure :: update1 + procedure :: reduce + procedure :: finalize => halo_finalize + end type pdhalo + +contains + + + ! =========================================================================== + ! Sorting utility: recursive quicksort of a permutation over a triple key + ! (a int, g int64, k int), ordered lexicographically. Used for deterministic + ! halo-slot and CSR ordering. a is typically an owner rank or a node index. + ! =========================================================================== + recursive subroutine sort3_perm(a,g,k,perm,lo,hi) + implicit none + integer, intent(in) :: a(:) + integer(I8), intent(in) :: g(:) + integer, intent(in) :: k(:) + integer, intent(inout) :: perm(:) + integer, intent(in) :: lo,hi + integer :: i,j,tp,pv + if (lo.ge.hi) return + pv=perm((lo+hi)/2) + i=lo; j=hi + do + do while (less3(perm(i),pv)); i=i+1; end do + do while (less3(pv,perm(j))); j=j-1; end do + if (i.le.j) then + tp=perm(i); perm(i)=perm(j); perm(j)=tp + i=i+1; j=j-1 + end if + if (i.gt.j) exit + end do + call sort3_perm(a,g,k,perm,lo,j) + call sort3_perm(a,g,k,perm,i,hi) + contains + logical function less3(p,q) + integer, intent(in) :: p,q + if (a(p).ne.a(q)) then + less3=a(p).lt.a(q) + else if (g(p).ne.g(q)) then + less3=g(p).lt.g(q) + else + less3=k(p).lt.k(q) + end if + end function less3 + end subroutine sort3_perm + + + ! =========================================================================== + ! PDDIR -- distributed GID directory + ! =========================================================================== + + !> Register this rank's owned gids with their home ranks. Collective. + subroutine register(this,n,gids) + use parallel, only: comm,rank,nproc + use pdhash_class, only: gid_hash + implicit none + class(pddir), intent(inout) :: this + integer, intent(in) :: n + integer(I8), intent(in) :: gids(:) + integer, dimension(0:nproc-1) :: sc,rc,sd,rd + integer(I8), allocatable :: sg(:),rg(:) + integer, allocatable :: pos(:) + integer :: i,h,nr,r,ierr + ! Count per home rank + sc=0 + do i=1,n + h=home(gids(i)); sc(h)=sc(h)+1 + end do + call MPI_ALLTOALL(sc,1,MPI_INTEGER,rc,1,MPI_INTEGER,comm,ierr) + sd(0)=0; rd(0)=0 + do r=1,nproc-1 + sd(r)=sd(r-1)+sc(r-1); rd(r)=rd(r-1)+rc(r-1) + end do + ! Pack and exchange gids + allocate(sg(max(n,1)),pos(0:nproc-1)) + pos=sd + do i=1,n + h=home(gids(i)); pos(h)=pos(h)+1; sg(pos(h))=gids(i) + end do + nr=sum(rc) + allocate(rg(max(nr,1))) + call MPI_ALLTOALLV(sg,sc,sd,MPI_INTEGER8,rg,rc,rd,MPI_INTEGER8,comm,ierr) + deallocate(sg,pos) + ! Store: owner of each received gid = the rank it arrived from + this%n=nr + allocate(this%keys(max(nr,1)),this%owner(max(nr,1))) + this%keys(1:nr)=rg(1:nr) + do r=0,nproc-1 + do i=rd(r)+1,rd(r)+rc(r) + this%owner(i)=r + end do + end do + ! Sort keys with the owner array following (simple perm sort) + sort_dir: block + integer, allocatable :: perm(:),zk(:),ow(:) + integer(I8), allocatable :: kk(:) + integer :: m + m=nr + if (m.gt.0) then + allocate(perm(m),zk(m),ow(m),kk(m)) + do i=1,m + perm(i)=i + end do + zk=0 + call sort3_perm(zk,this%keys(1:m),zk,perm,1,m) + kk=this%keys(1:m); ow=this%owner(1:m) + do i=1,m + this%keys(i) =kk(perm(i)) + this%owner(i)=ow(perm(i)) + end do + deallocate(perm,zk,ow,kk) + end if + end block sort_dir + deallocate(rg) + end subroutine register + + !> Resolve owner ranks for m gids. Collective. Dies on unknown gid. + subroutine query(this,m,gids,owners) + use parallel, only: comm,nproc + use messager, only: die + implicit none + class(pddir), intent(in) :: this + integer, intent(in) :: m + integer(I8), intent(in) :: gids(:) + integer, intent(out) :: owners(:) + integer, dimension(0:nproc-1) :: sc,rc,sd,rd + integer(I8), allocatable :: sg(:),rg(:) + integer, allocatable :: pos(:),qpos(:),rans(:),reply(:) + integer :: i,h,nr,r,idx,ierr + ! Count and pack queries by home rank; remember each query's packed slot + sc=0 + do i=1,m + h=home(gids(i)); sc(h)=sc(h)+1 + end do + call MPI_ALLTOALL(sc,1,MPI_INTEGER,rc,1,MPI_INTEGER,comm,ierr) + sd(0)=0; rd(0)=0 + do r=1,nproc-1 + sd(r)=sd(r-1)+sc(r-1); rd(r)=rd(r-1)+rc(r-1) + end do + allocate(sg(max(m,1)),pos(0:nproc-1),qpos(max(m,1))) + pos=sd + do i=1,m + h=home(gids(i)); pos(h)=pos(h)+1; sg(pos(h))=gids(i); qpos(i)=pos(h) + end do + nr=sum(rc) + allocate(rg(max(nr,1))) + call MPI_ALLTOALLV(sg,sc,sd,MPI_INTEGER8,rg,rc,rd,MPI_INTEGER8,comm,ierr) + ! Answer each received query by binary search of the sorted directory + allocate(rans(max(nr,1))) + do i=1,nr + idx=dir_lookup(this,rg(i)) + if (idx.lt.1) call die('[pddir query] gid not found in directory') + rans(i)=this%owner(idx) + end do + ! Send answers back along the reverse route (counts swapped) + allocate(reply(max(m,1))) + call MPI_ALLTOALLV(rans,rc,rd,MPI_INTEGER,reply,sc,sd,MPI_INTEGER,comm,ierr) + do i=1,m + owners(i)=reply(qpos(i)) + end do + deallocate(sg,rg,pos,qpos,rans,reply) + end subroutine query + + !> Binary search of the sorted directory keys. Returns index or -1. + pure function dir_lookup(this,key) result(idx) + implicit none + class(pddir), intent(in) :: this + integer(I8), intent(in) :: key + integer :: idx,lo,hi,mid + idx=-1 + if (.not.allocated(this%keys).or.this%n.eq.0) return + lo=1; hi=this%n + do while (lo.le.hi) + mid=(lo+hi)/2 + if (this%keys(mid).lt.key) then + lo=mid+1 + else if (this%keys(mid).gt.key) then + hi=mid-1 + else + idx=mid + return + end if + end do + end function dir_lookup + + !> Release directory storage + subroutine dir_finalize(this) + implicit none + class(pddir), intent(inout) :: this + if (allocated(this%keys)) deallocate(this%keys) + if (allocated(this%owner)) deallocate(this%owner) + this%n=0 + end subroutine dir_finalize + + !> Home rank of a gid. Keys are STRUCTURED (AMReX idcpu = id<<24|cpu: raw + !> mod collapses onto few ranks -- all of them rank 0 for power-of-two + !> nproc when cpu=0), so mix the bits first (Fibonacci hash; the multiply + !> wraps by design, and the logical shift keeps the result nonnegative). + pure function home(gid) result(h) + use parallel, only: nproc + implicit none + integer(I8), intent(in) :: gid + integer :: h + integer(I8) :: k + k=gid*(-7046029254386353131_I8) + h=int(mod(ishft(k,-40),int(nproc,I8))) + end function home + + + ! =========================================================================== + ! PDHALO -- persistent halo plan + ! =========================================================================== + + !> Build the halo plan. Collective. + !> nown : owned node count (slots index from nown+1) + !> ohash : gid->owned-index hash over this rank's owned gids + !> nreq : number of UNIQUE remote references (gid, image-key) pairs + !> rgid/rkey: the references (key packs the image offset, amrpd hist1 style) + !> rowner : owner rank of each reference's gid (from pddir%query) + !> Ldom/per : domain lengths and periodicity (for shift vectors) + !> slot : OUT -- final halo slot (1..nhalo) of each input reference + subroutine build(this,nown,ohash,nreq,rgid,rkey,rowner,Ldom,per,slot) + use parallel, only: comm,nproc + use messager, only: die + use pdhash_class, only: gid_hash + implicit none + class(pdhalo), intent(inout) :: this + integer, intent(in) :: nown,nreq + type(gid_hash), intent(in) :: ohash + integer(I8), intent(in) :: rgid(:) + integer, intent(in) :: rkey(:),rowner(:) + real(WP), intent(in) :: Ldom(3) + logical, intent(in) :: per(3) + integer, intent(out) :: slot(:) + integer, allocatable :: perm(:) + integer, dimension(0:nproc-1) :: sc,rc,sd,rd + integer :: i,s,r,n1,n2,n3,ierr,nr,lid + integer(I8), allocatable :: sg(:),rg(:) + + this%nown=nown + this%nhalo=nreq + + ! Deterministic slot order: sort references by (owner, gid, key) + allocate(perm(max(nreq,1))) + do i=1,nreq + perm(i)=i + end do + if (nreq.gt.1) call sort3_perm(rowner,rgid,rkey,perm,1,nreq) + do s=1,nreq + slot(perm(s))=s + end do + + ! Receive groups (one per distinct owner, ascending by construction) + count_recv: block + integer :: prev + this%nrecv=0; prev=-1 + do s=1,nreq + if (rowner(perm(s)).ne.prev) then + this%nrecv=this%nrecv+1; prev=rowner(perm(s)) + end if + end do + allocate(this%nbr_recv(max(this%nrecv,1)),this%recv_ptr(this%nrecv+1)) + this%nrecv=0; prev=-1 + do s=1,nreq + if (rowner(perm(s)).ne.prev) then + this%nrecv=this%nrecv+1; prev=rowner(perm(s)) + this%nbr_recv(this%nrecv)=prev + this%recv_ptr(this%nrecv)=s + end if + end do + this%recv_ptr(this%nrecv+1)=nreq+1 + end block count_recv + + ! Per-slot shift vectors from the packed image key + allocate(this%shift(3,max(nreq,1))) + do s=1,nreq + i=perm(s) + n1=mod(rkey(i),256)-128; n2=mod(rkey(i)/256,256)-128; n3=rkey(i)/65536-128 + if ((n1.ne.0.and..not.per(1)).or.(n2.ne.0.and..not.per(2)).or.(n3.ne.0.and..not.per(3))) & + & call die('[pdhalo build] nonzero image offset along a non-periodic direction') + this%shift(1,s)=real(n1,WP)*Ldom(1) + this%shift(2,s)=real(n2,WP)*Ldom(2) + this%shift(3,s)=real(n3,WP)*Ldom(3) + end do + + ! Tell every owner which of its nodes we need (gids in slot order). + ! Payload order within each destination = our slot order, and MPI + ! preserves per-pair message order, so the owner's send list built in + ! arrival order matches our slot order exactly. + sc=0 + do s=1,nreq + sc(rowner(perm(s)))=sc(rowner(perm(s)))+1 + end do + call MPI_ALLTOALL(sc,1,MPI_INTEGER,rc,1,MPI_INTEGER,comm,ierr) + sd(0)=0; rd(0)=0 + do r=1,nproc-1 + sd(r)=sd(r-1)+sc(r-1); rd(r)=rd(r-1)+rc(r-1) + end do + allocate(sg(max(nreq,1))) + do s=1,nreq + sg(s)=rgid(perm(s)) ! grouped by owner because slots are owner-sorted + end do + nr=sum(rc) + allocate(rg(max(nr,1))) + call MPI_ALLTOALLV(sg,sc,sd,MPI_INTEGER8,rg,rc,rd,MPI_INTEGER8,comm,ierr) + + ! Send groups: ranks that requested nodes from me + count_send: block + integer :: g + this%nsend=count(rc.gt.0) + allocate(this%nbr_send(max(this%nsend,1)),this%send_ptr(this%nsend+1)) + allocate(this%send_idx(max(nr,1))) + g=0; this%send_ptr(1)=1 + do r=0,nproc-1 + if (rc(r).gt.0) then + g=g+1 + this%nbr_send(g)=r + this%send_ptr(g+1)=this%send_ptr(g)+rc(r) + do i=rd(r)+1,rd(r)+rc(r) + lid=ohash%lookup(rg(i)) + if (lid.lt.1) call die('[pdhalo build] halo request for a gid this rank does not own') + this%send_idx(this%send_ptr(g)+(i-rd(r)-1))=lid + end do + end if + end do + end block count_send + + deallocate(perm,sg,rg) + end subroutine build + + !> Refresh halo slots with current owner values: field(:,1:nown) -> slots. + !> field is (ncomp, nown+nhalo). If shifted, per-slot image shifts are added + !> to components 1:3 (positions). Deterministic unpack order. + subroutine update(this,field,ncomp,shifted) + use parallel, only: comm,MPI_REAL_WP + use messager, only: die + implicit none + class(pdhalo), intent(inout) :: this + real(WP), intent(inout) :: field(:,:) + integer, intent(in) :: ncomp + logical, intent(in) :: shifted + type(MPI_Request), allocatable :: reqs(:) + integer :: i,g,s,off,cnt,nrq,ierr + integer :: nsend_tot + if (shifted.and.ncomp.lt.3) call die('[pdhalo update] shifted update requires ncomp>=3') + nsend_tot=this%send_ptr(this%nsend+1)-1 + call ensure_buffers(this,ncomp*max(nsend_tot,1),ncomp*max(this%nhalo,1)) + allocate(reqs(this%nrecv+this%nsend)) + nrq=0 + ! Post receives (one message per source rank) + do g=1,this%nrecv + off=ncomp*(this%recv_ptr(g)-1) + cnt=ncomp*(this%recv_ptr(g+1)-this%recv_ptr(g)) + nrq=nrq+1 + call MPI_IRECV(this%rbuf(off+1:off+cnt),cnt,MPI_REAL_WP,this%nbr_recv(g),101,comm,reqs(nrq),ierr) + end do + ! Pack and send (one message per destination rank) + do g=1,this%nsend + off=ncomp*(this%send_ptr(g)-1) + do i=this%send_ptr(g),this%send_ptr(g+1)-1 + this%sbuf(off+ncomp*(i-this%send_ptr(g))+1:off+ncomp*(i-this%send_ptr(g))+ncomp)=field(1:ncomp,this%send_idx(i)) + end do + cnt=ncomp*(this%send_ptr(g+1)-this%send_ptr(g)) + nrq=nrq+1 + call MPI_ISEND(this%sbuf(off+1:off+cnt),cnt,MPI_REAL_WP,this%nbr_send(g),101,comm,reqs(nrq),ierr) + end do + call MPI_WAITALL(nrq,reqs,MPI_STATUSES_IGNORE,ierr) + ! Unpack into halo slots (slot s lives at field index nown+s) + do s=1,this%nhalo + field(1:ncomp,this%nown+s)=this%rbuf(ncomp*(s-1)+1:ncomp*(s-1)+ncomp) + end do + if (shifted) then + do s=1,this%nhalo + field(1:3,this%nown+s)=field(1:3,this%nown+s)+this%shift(1:3,s) + end do + end if + deallocate(reqs) + end subroutine update + + !> Scalar-field variant of update (no shift): owner values -> halo slots. + !> Used for static per-node scalars (e.g., nodal volume) filled once at init. + subroutine update1(this,field) + use parallel, only: comm,MPI_REAL_WP + implicit none + class(pdhalo), intent(inout) :: this + real(WP), intent(inout) :: field(:) + type(MPI_Request), allocatable :: reqs(:) + integer :: i,g,s,off,cnt,nrq,ierr + integer :: nsend_tot + nsend_tot=this%send_ptr(this%nsend+1)-1 + call ensure_buffers(this,max(nsend_tot,1),max(this%nhalo,1)) + allocate(reqs(this%nrecv+this%nsend)) + nrq=0 + do g=1,this%nrecv + off=this%recv_ptr(g)-1 + cnt=this%recv_ptr(g+1)-this%recv_ptr(g) + nrq=nrq+1 + call MPI_IRECV(this%rbuf(off+1:off+cnt),cnt,MPI_REAL_WP,this%nbr_recv(g),103,comm,reqs(nrq),ierr) + end do + do g=1,this%nsend + off=this%send_ptr(g)-1 + do i=this%send_ptr(g),this%send_ptr(g+1)-1 + this%sbuf(i)=field(this%send_idx(i)) + end do + cnt=this%send_ptr(g+1)-this%send_ptr(g) + nrq=nrq+1 + call MPI_ISEND(this%sbuf(off+1:off+cnt),cnt,MPI_REAL_WP,this%nbr_send(g),103,comm,reqs(nrq),ierr) + end do + call MPI_WAITALL(nrq,reqs,MPI_STATUSES_IGNORE,ierr) + do s=1,this%nhalo + field(this%nown+s)=this%rbuf(s) + end do + deallocate(reqs) + end subroutine update1 + + !> Add halo-slot accumulations back into their owners: slots -> field(:,1:nown). + !> Reverse of update: slot data flows to the owner, which adds it into the + !> owned entries listed in send_idx. Deterministic add order (group order, + !> then entry order within group). + subroutine reduce(this,field,ncomp) + use parallel, only: comm,MPI_REAL_WP + implicit none + class(pdhalo), intent(inout) :: this + real(WP), intent(inout) :: field(:,:) + integer, intent(in) :: ncomp + type(MPI_Request), allocatable :: reqs(:) + integer :: i,g,s,off,cnt,nrq,ierr + integer :: nsend_tot + nsend_tot=this%send_ptr(this%nsend+1)-1 + ! Buffers: sending nhalo slots, receiving nsend_tot contributions + call ensure_buffers(this,ncomp*max(this%nhalo,1),ncomp*max(nsend_tot,1)) + allocate(reqs(this%nrecv+this%nsend)) + nrq=0 + ! Post receives along the send-plan links (contributions to my owned nodes) + do g=1,this%nsend + off=ncomp*(this%send_ptr(g)-1) + cnt=ncomp*(this%send_ptr(g+1)-this%send_ptr(g)) + nrq=nrq+1 + call MPI_IRECV(this%rbuf(off+1:off+cnt),cnt,MPI_REAL_WP,this%nbr_send(g),102,comm,reqs(nrq),ierr) + end do + ! Pack halo slots and send to their owners along the recv-plan links + do g=1,this%nrecv + off=ncomp*(this%recv_ptr(g)-1) + do s=this%recv_ptr(g),this%recv_ptr(g+1)-1 + this%sbuf(off+ncomp*(s-this%recv_ptr(g))+1:off+ncomp*(s-this%recv_ptr(g))+ncomp)=field(1:ncomp,this%nown+s) + end do + cnt=ncomp*(this%recv_ptr(g+1)-this%recv_ptr(g)) + nrq=nrq+1 + call MPI_ISEND(this%sbuf(off+1:off+cnt),cnt,MPI_REAL_WP,this%nbr_recv(g),102,comm,reqs(nrq),ierr) + end do + call MPI_WAITALL(nrq,reqs,MPI_STATUSES_IGNORE,ierr) + ! Accumulate received contributions into owned nodes + do i=1,nsend_tot + field(1:ncomp,this%send_idx(i))=field(1:ncomp,this%send_idx(i))+this%rbuf(ncomp*(i-1)+1:ncomp*(i-1)+ncomp) + end do + deallocate(reqs) + end subroutine reduce + + !> Grow persistent buffers on demand + subroutine ensure_buffers(this,ns,nr) + implicit none + class(pdhalo), intent(inout) :: this + integer, intent(in) :: ns,nr + if (allocated(this%sbuf)) then + if (size(this%sbuf).lt.ns) deallocate(this%sbuf) + end if + if (.not.allocated(this%sbuf)) allocate(this%sbuf(ns)) + if (allocated(this%rbuf)) then + if (size(this%rbuf).lt.nr) deallocate(this%rbuf) + end if + if (.not.allocated(this%rbuf)) allocate(this%rbuf(nr)) + end subroutine ensure_buffers + + !> Release plan storage + subroutine halo_finalize(this) + implicit none + class(pdhalo), intent(inout) :: this + if (allocated(this%nbr_recv)) deallocate(this%nbr_recv) + if (allocated(this%recv_ptr)) deallocate(this%recv_ptr) + if (allocated(this%nbr_send)) deallocate(this%nbr_send) + if (allocated(this%send_ptr)) deallocate(this%send_ptr) + if (allocated(this%send_idx)) deallocate(this%send_idx) + if (allocated(this%shift)) deallocate(this%shift) + if (allocated(this%sbuf)) deallocate(this%sbuf) + if (allocated(this%rbuf)) deallocate(this%rbuf) + this%nown=0; this%nhalo=0; this%nrecv=0; this%nsend=0 + end subroutine halo_finalize + + +end module pdhalo_class diff --git a/examples/NOSB_cylinder_peridigm/src/pdhash_class.f90 b/examples/NOSB_cylinder_peridigm/src/pdhash_class.f90 new file mode 100644 index 000000000..7d7e4d197 --- /dev/null +++ b/examples/NOSB_cylinder_peridigm/src/pdhash_class.f90 @@ -0,0 +1,155 @@ +!> GID -> LID hash (sorted array + binary search; build O(N log N), lookup +!> O(log N)). Used by pdsolver for owned-node gid resolution and halo-plan +!> construction. +module pdhash_class + use iso_c_binding, only: c_int64_t + implicit none + private + + public :: gid_hash + + !> Sorted (key, val) pairs. Key is a unique int64 GID; val is the 1-based + !> local index into the source particle array. + type :: gid_hash + integer(c_int64_t), allocatable :: keys(:) + integer, allocatable :: vals(:) + integer :: n = 0 + contains + procedure :: build + procedure :: lookup + procedure :: lookup_range !< For periodic-image disambiguation: returns ALL duplicates of a key + procedure :: finalize + end type gid_hash + +contains + + !> Build a sorted hash from an array of keys. Values are assigned 1..n + !> (the LIDs in the source array). Caller supplies the key array; this + !> routine copies and sorts. + subroutine build(this,n,keys) + implicit none + class(gid_hash), intent(inout) :: this + integer, intent(in) :: n + integer(c_int64_t), intent(in) :: keys(n) + integer :: i + call this%finalize() + this%n = n + if (n.gt.0) then + allocate(this%keys(n),this%vals(n)) + this%keys = keys + do i = 1, n + this%vals(i) = i + end do + call quicksort_pair(this%keys,this%vals,1,n) + end if + end subroutine build + + !> Look up a key. Returns the 1-based LID on hit, -1 on miss. + pure function lookup(this,key) result(lid) + implicit none + class(gid_hash), intent(in) :: this + integer(c_int64_t), intent(in) :: key + integer :: lid + integer :: lo,hi,mid + lid = -1 + if (this%n.eq.0) return + lo = 1; hi = this%n + do while (lo.le.hi) + mid = (lo + hi) / 2 + if (this%keys(mid).lt.key) then + lo = mid + 1 + else if (this%keys(mid).gt.key) then + hi = mid - 1 + else + lid = this%vals(mid) + return + end if + end do + end function lookup + + !> Find the contiguous bracket of duplicates for a given key in the sorted + !> array. Returns first_idx (1-based) and n_dup. On miss, n_dup = 0. + !> + !> Use case: periodic-image disambiguation. When the hash is built from a + !> particle array that contains both an owned particle and its periodic- + !> image ghost copy (which share the same idcpu = key), multiple entries + !> exist. The caller walks the bracket [first_idx .. first_idx+n_dup-1] + !> in self%vals to get all candidate LIDs, then picks the right image by + !> minimum-image distance to an anchor position. + !> + !> Common case (no duplicates): n_dup = 1, self%vals(first_idx) is the LID. + pure subroutine lookup_range(this,key,first_idx,n_dup) + implicit none + class(gid_hash), intent(in) :: this + integer(c_int64_t), intent(in) :: key + integer, intent(out) :: first_idx,n_dup + integer :: lo,hi,mid,i,j + first_idx = -1; n_dup = 0 + if (this%n.eq.0) return + ! Binary search for any matching index + lo = 1; hi = this%n + mid = -1 + do while (lo.le.hi) + mid = (lo + hi) / 2 + if (this%keys(mid).lt.key) then + lo = mid + 1 + else if (this%keys(mid).gt.key) then + hi = mid - 1 + else + exit + end if + end do + if (mid.lt.1.or.mid.gt.this%n) return + if (this%keys(mid).ne.key) return + ! Scan left and right for duplicates (sorted -> contiguous) + i = mid + do while (i.gt.1) + if (this%keys(i-1).ne.key) exit + i = i - 1 + end do + j = mid + do while (j.lt.this%n) + if (this%keys(j+1).ne.key) exit + j = j + 1 + end do + first_idx = i + n_dup = j - i + 1 + end subroutine lookup_range + + !> Release allocated storage. + subroutine finalize(this) + implicit none + class(gid_hash), intent(inout) :: this + if (allocated(this%keys)) deallocate(this%keys) + if (allocated(this%vals)) deallocate(this%vals) + this%n = 0 + end subroutine finalize + + + !> Recursive Hoare-partition quicksort on (key, val) pairs, sorted by key. + !> Private module helper. + recursive subroutine quicksort_pair(keys,vals,lo,hi) + implicit none + integer(c_int64_t), intent(inout) :: keys(:) + integer, intent(inout) :: vals(:) + integer, intent(in) :: lo,hi + integer :: i,j,tv + integer(c_int64_t) :: pivot,tk + if (lo.ge.hi) return + pivot = keys((lo + hi) / 2) + i = lo; j = hi + do + do while (keys(i).lt.pivot); i = i + 1; end do + do while (keys(j).gt.pivot); j = j - 1; end do + if (i.le.j) then + tk = keys(i); keys(i) = keys(j); keys(j) = tk + tv = vals(i); vals(i) = vals(j); vals(j) = tv + i = i + 1; j = j - 1 + end if + if (i.gt.j) exit + end do + call quicksort_pair(keys,vals,lo,j) + call quicksort_pair(keys,vals,i,hi) + end subroutine quicksort_pair + +end module pdhash_class diff --git a/examples/NOSB_cylinder_peridigm/src/pdsolver_class.f90 b/examples/NOSB_cylinder_peridigm/src/pdsolver_class.f90 new file mode 100644 index 000000000..ea5d6ff70 --- /dev/null +++ b/examples/NOSB_cylinder_peridigm/src/pdsolver_class.f90 @@ -0,0 +1,2281 @@ +!> Peridynamics solver: node-centered, CSR-based solid dynamics on flat +!> per-field arrays with persistent graph-halo communication. GRID-FREE: +!> no AMReX anywhere -- ownership follows the reference configuration +!> (Morton partition, motion-invariant), neighborhoods and communication +!> plans are built once and reused every substep. +!> +!> Physics: linear peridynamic solid (LPS, dimension-aware coefficients, +!> influence function hard-coded in omega() with derived quantities +!> generalized through its moments), brittle stretch damage, per-side +!> viscoelastic/viscoplastic flow with J2 (Mitchell OSB) yield, soft-sphere +!> contact (walls + particle-particle via a displacement-triggered spatial +!> service), velocity-Verlet integration. +!> Checkpoint/restart is gid-space and rank-count portable, including all +!> bond damage and plastic history. +!> +!> Usage tiers (amrpd EXTENDS pdsolver -- see amrpd_class): +!> 1. pdsolver alone -- standalone solid dynamics (this module only) +!> 2. amrpd -- adds viz, mesh VF, AMR refinement, seeding +!> 3. ... + a flow solver -- two-way FSI via amrpd%exchange_solid +!> +!> Configuration style: assign the public fields (material, damage, contact), +!> then build the network (detect_families/connect/read_state) -- derived +!> quantities resolve there via derive_config, uniformly for fresh and restart. +!> +!> Layout: owned nodes 1..nown; halo slots nown+1..ntot, keyed (gid, periodic +!> image offset) with shifts applied at exchange time. Each physical bond is +!> two CSR half-entries (one per endpoint row, Peridigm convention): kernels +!> compute each row's own force state -- ghost dilatation is never +!> communicated -- and a single halo reduce assembles cross-rank pairs. +!> Kernels are pure loops over owned nodes with no mutable module-level +!> state (OpenMP-ready by construction; threads deferred). +module pdsolver_class + use precision, only: WP,I8 + use string, only: str_medium + use pdhalo_class, only: pddir,pdhalo,sort3_perm,PDHALO_KEY0 + use pdhash_class, only: gid_hash + implicit none + private + + public :: pdsolver,pd_partition + public :: PDC_IS_DEAD,PDC_MOVES,PDC_INTEGRATES,PDC_BONDS + public :: PD_OPEN,PD_WALL + + ! Motion-control bit flags -- values MUST match amrpd's PART_* constants + ! (handoff copies amrpd flags verbatim) + integer, parameter :: PDC_IS_DEAD =0 + integer, parameter :: PDC_MOVES =1 + integer, parameter :: PDC_INTEGRATES=2 + integer, parameter :: PDC_BONDS =4 + + ! Domain-face BC values for lo_bc/hi_bc + integer, parameter :: PD_OPEN=0 + integer, parameter :: PD_WALL=1 + + !> Graph-core PD solver + type :: pdsolver + character(len=str_medium) :: name='UNNAMED_PDSOLVER' + + ! Sizes + integer :: nown=0 !< owned nodes on this rank + integer :: nhalo=0 !< halo slots + integer :: ntot=0 !< nown+nhalo + integer(I8) :: np=0 !< global node count (get_info) + integer(I8) :: nbond=0 !< global bond count (half-entries/2, get_info) + + ! Material / discretization + real(WP) :: rho =0.0_WP !< density + real(WP) :: elastic_modulus=0.0_WP !< Young's modulus + real(WP) :: poisson_ratio =0.0_WP !< Poisson's ratio + real(WP) :: delta =0.0_WP !< horizon + real(WP) :: dV =0.0_WP !< nominal element volume (CFL length scale; kernels use per-node V) + real(WP) :: s0 =huge(1.0_WP) !< critical bond stretch (huge = no damage) + real(WP) :: fail_stretch =huge(1.0_WP) !< direct s0 override (takes precedence over crit_energy) + real(WP) :: crit_energy =huge(1.0_WP) !< critical energy release rate G_c (-> s0 when fail_stretch unset) + real(WP) :: dtcrit =0.0_WP !< Silling-Askari critical dt (diagnostic, stamped at connect) + ! Viscoelastic / viscoplastic flow (PER-SIDE form: each half-entry evolves + ! its own e_v with its own endpoint's dilatation and yield factor -- + ! exactly Peridigm's elastic_plastic.cxx, verified term-by-term against + ! amrpd's J2 2026-07-14. This is the one INTENDED delta from amrpd, which + ! averages the endpoints into a single per-bond e_v.) + real(WP) :: tau =huge(1.0_WP) !< Maxwell deviatoric relaxation time (huge = purely elastic) + real(WP) :: visc_lambda =1.0_WP !< SLS relaxing fraction [0,1] + real(WP) :: yield_stretch =0.0_WP !< legacy per-bond Perzyna yield strain (0 = pure Maxwell) + real(WP) :: sigma_yield =0.0_WP !< J2 yield stress (Mitchell OSB family norm; overrides yield_stretch) + real(WP) :: hard_mod =0.0_WP !< linear isotropic hardening modulus H: flow stress = sigma_yield + H*lam_p (0 = perfectly plastic) + real(WP), dimension(3) :: gravity=0.0_WP !< body acceleration + logical, dimension(3) :: collapsed=.false. !< collapsed (n==1) directions: velocity locked + real(WP), dimension(3) :: Ldom=0.0_WP !< domain lengths (image shifts) + logical, dimension(3) :: per=.false. !< periodicity per direction + real(WP), dimension(3) :: dom_lo=0.0_WP !< domain lower bounds (wall contact) + real(WP), dimension(3) :: dom_hi=0.0_WP !< domain upper bounds (wall contact) + + ! Short-range soft-sphere contact (soft-sphere penalty + damping). + ! Contact is a pure SPATIAL service, fully separate from the bond graph: + ! candidates are (owned nodes + contact-halo slots) discovered by a + ! displacement-triggered broad phase; the graph halo is never binned, so + ! bonded remote partners arrive as contact slots when in range and + ! double-counting is structurally impossible. The narrow phase is + ! gather-only (each owned node accumulates from its candidates -- the + ! partner gets its share from its own row), so no force reduction. + logical :: use_contact =.false. + real(WP) :: contact_dist =0.0_WP !< d_c (p-p d_eff; wall d_eff = 0.5*d_c) + real(WP) :: tau_col =0.0_WP !< collision duration (<=0 -> auto 5*dt) + real(WP) :: e_n=0.7_WP,e_w=0.7_WP !< restitution (p-p, wall) + real(WP) :: clip_col =0.2_WP !< overlap clip fraction + integer, dimension(3) :: lo_bc=PD_OPEN,hi_bc=PD_OPEN !< per-face: PD_OPEN or PD_WALL + real(WP) :: cskin =0.0_WP !< broad-phase skin (<=0 -> auto 0.5*contact_dist) + type(pdhalo) :: chalo !< contact halo (rebuilt at trigger cadence; nown=ntot) + integer :: nchalo=0 !< contact slots (y/v extended to ntot+nchalo) + integer, allocatable :: cptr(:),clst(:) !< candidate CSR (owned rows; entries index owned+contact slots) + real(WP), allocatable :: ylast(:,:) !< (3,nown) positions at last broad-phase build + + ! Node state -- flat per-field arrays; owned first, halo slots appended. + ! (3,:) fields are xyz-interleaved per node (Fortran-natural gather layout). + integer(I8), allocatable :: gid(:) !< (ntot) global id (halo slots carry partner gid) + real(WP), allocatable :: x0(:,:) !< (3,ntot) reference position; halo PRE-SHIFTED + real(WP), allocatable :: y(:,:) !< (3,ntot) current position; halo shifted at update + real(WP), allocatable :: v(:,:) !< (3,nown) velocity + real(WP), allocatable :: f(:,:) !< (3,ntot) bond force density (halo = scatter buffer) + real(WP), allocatable :: ff(:,:) !< (3,nown) external (fluid) force density + real(WP), allocatable :: vol(:) !< (ntot) per-node volume (reference; halo slots filled at connect) + real(WP), allocatable :: mw(:) !< (nown) weighted volume (reference, set at connect) + real(WP), allocatable :: theta(:) !< (nown) dilatation (recomputed each substep) + real(WP), allocatable :: damage(:) !< (nown) accumulated damage fraction (broken/reference bonds) + real(WP), allocatable :: lam_p(:) !< (nown) accumulated equivalent plastic strain (J2 path; drives hardening, free diagnostic when hard_mod=0) + real(WP), allocatable :: alive(:) !< (ntot) 1=alive, 0=dead (exit through open face); halo-exchanged on death events only + integer, allocatable :: flag(:) !< (nown) motion-control flags + logical :: watch_exit=.false. !< exit detection active (set at connect: domain set + any open non-periodic face) + + ! CSR families (built once at connect) + integer, allocatable :: ptr(:) !< (nown+1) row offsets + integer, allocatable :: lst(:) !< neighbor index (1..ntot) per half-entry + integer(1), allocatable :: dmg(:) !< per half-entry: 0 intact, 1 broken (irreversible) + real(WP), allocatable :: e_v(:) !< per half-entry: inelastic deviatoric stretch (per-side history) + real(WP), allocatable :: td2(:),td2a(:) !< (nown) J2 family deviatoric norm^2: previous substep / accumulator. + !< Node-centered => pure own-row gather, NO communication (amrpd + !< needed sum_ghosts_td2 + ghost refresh for the same quantity). + + ! Parallel machinery + type(gid_hash) :: ohash !< gid -> owned index (built at set_nodes) + type(pddir) :: dir !< persistent gid directory (owner lookups; registered at connect/read_state) + type(pdhalo) :: halo !< persistent halo plan + real(WP), allocatable :: rextra_tmp(:,:) !< read_state scratch (restart-field overlay across assemble) + + ! Monitoring + real(WP) :: Umin=0.0_WP,Umax=0.0_WP !< signed per-component velocity extrema + real(WP) :: Vmin=0.0_WP,Vmax=0.0_WP !< over live nodes (get_info) + real(WP) :: Wmin=0.0_WP,Wmax=0.0_WP + real(WP) :: EPmax=0.0_WP !< max accumulated equivalent plastic strain (get_info) + real(WP) :: CFLe=0.0_WP,CFLp=0.0_WP !< elastic-wave / convective CFL (get_cfl) + integer(I8) :: nbroken=0 !< global broken half-entry count (internal) + integer(I8) :: nb_broken=0 !< global broken BOND count (exact census, get_info) + integer(I8) :: nb=0 !< global bond count (exact census, stamped at assemble) + integer(I8) :: nrebuild=0 !< broad-phase rebuild count (cumulative) + integer(I8) :: nchalo_glob=0 !< global contact-slot count (get_info) + integer(I8) :: ncand_glob=0 !< global contact-candidate count (get_info) + + ! Per-rank phase timers (accumulated in advance; reduced+reset in get_info) + real(WP) :: wt_kick=0.0_WP,wt_halo=0.0_WP,wt_dil=0.0_WP,wt_force=0.0_WP,wt_reduce=0.0_WP + real(WP) :: wt_contact=0.0_WP,wt_broad=0.0_WP + real(WP) :: wtmax_kick=0.0_WP,wtmax_halo=0.0_WP,wtmax_dil=0.0_WP,wtmax_force=0.0_WP,wtmax_reduce=0.0_WP + real(WP) :: wtmax_contact=0.0_WP,wtmax_broad=0.0_WP + real(WP) :: wtmin_dil=0.0_WP,wtmin_force=0.0_WP + + ! Damping rate for steady state + real(WP) :: damping_rate=0.0_WP + + ! NOSB Tracked parameters + real(WP), allocatable :: F_mat(:,:,:) !< F matrix (:,:,nown) I don't think this needs the halo + real(WP), allocatable :: PK_inv(:,:,:) !< P*K^-1 matrix (:,:,ntot) This needs to have gthe halo + + + + + contains + procedure :: set_nodes + procedure :: connect + procedure :: detect_families + procedure :: pd_advance + procedure :: query_owners + procedure :: write_state + procedure :: read_state + procedure :: get_cfl + procedure :: get_info + procedure :: finalize + procedure, private :: derive_config + procedure, private :: lps_coefs + procedure, private :: compute_mw + procedure, private :: contact_broadphase + procedure, private :: contact_narrow + procedure, private :: assemble + + end type pdsolver + +contains + + + !> Resolve derived configuration: s0 from fail_stretch/crit_energy, contact + !> reach default. Called by every network-building entry point (connect, + !> detect_families, read_state) so fresh init and restart share one path. + subroutine derive_config(this) + use messager, only: die + implicit none + class(pdsolver), intent(inout) :: this + real(WP) :: K_bulk + if (this%rho.le.0.0_WP.or.this%elastic_modulus.le.0.0_WP.or. & + & this%delta.le.0.0_WP.or.this%dV.le.0.0_WP) & + & call die('[pdsolver] material/discretization not configured (need rho, elastic_modulus, delta, dV > 0)') + if (this%fail_stretch.lt.huge(1.0_WP)) then + this%s0=this%fail_stretch + else if (this%crit_energy.gt.0.0_WP.and.this%crit_energy.lt.huge(1.0_WP)) then + ! Silling-Askari bond-energy argument, generalized to the active + ! influence function: G_c = (9/4)*K*s0^2*Iw4/Iw3 (w=1 recovers the + ! classical s0 = sqrt(5*G_c/(9*K*delta))) + K_bulk=this%elastic_modulus/(3.0_WP*(1.0_WP-2.0_WP*this%poisson_ratio)) + this%s0=sqrt(4.0_WP*this%crit_energy*wmoment(this%delta,3,1)/(9.0_WP*K_bulk*wmoment(this%delta,4,1))) + end if + if (this%use_contact.and.this%contact_dist.le.0.0_WP) this%contact_dist=0.9_WP*this%dV**(1.0_WP/3.0_WP) + end subroutine derive_config + + !> Load this rank's owned nodes (any distribution; it becomes the static + !> partition). Builds the gid->index hash used by connect and the halo plan. + !> vol is the per-node volume (pass a constant-filled array for a uniform + !> lattice; kernels use it per neighbor, Peridigm-style). + subroutine set_nodes(this,n,gids,pos,vel,flags,vol) + implicit none + class(pdsolver), intent(inout) :: this + integer, intent(in) :: n + integer(I8), intent(in) :: gids(:) + real(WP), intent(in) :: pos(:,:),vel(:,:) + integer, intent(in) :: flags(:) + real(WP), intent(in) :: vol(:) + integer :: i + this%nown=n + this%nhalo=0 + this%ntot=n + allocate(this%gid(max(n,1)),this%x0(3,max(n,1)),this%y(3,max(n,1))) + allocate(this%v(3,max(n,1)),this%f(3,max(n,1)),this%ff(3,max(n,1))) + allocate(this%mw(max(n,1)),this%theta(max(n,1)),this%flag(max(n,1))) + allocate(this%vol(max(n,1)),this%damage(max(n,1)),this%lam_p(max(n,1))) + allocate(this%PK_inv(3,3,max(n,1)),this%F_mat(3,3,max(n,1))) + do i=1,n + this%gid(i) =gids(i) + this%x0(:,i)=pos(:,i) + this%y(:,i) =pos(:,i) + this%v(:,i) =vel(:,i) + this%flag(i)=flags(i) + this%vol(i) =vol(i) + end do + this%f=0.0_WP; this%ff=0.0_WP; this%mw=0.0_WP; this%theta=0.0_WP; this%damage=0.0_WP; this%lam_p=0.0_WP + this%F_mat=0.0_WP; this%PK_inv=0.0_WP + call this%ohash%build(n,gids(1:n)) + end subroutine set_nodes + + !> Build the static CSR families and the halo plan from a distributed bond + !> list (this rank passes the bonds it holds; any distribution is fine -- + !> half-entries are routed to their node's owner through the gid directory). + !> Collective. bkey packs the periodic image offset of the HI endpoint in + !> amrpd's hist1 convention. Self-image bonds (gid_lo==gid_hi) yield ONE + !> half-entry (the opposite-image bond exists separately in the input, exactly + !> as amrpd stores them). + subroutine connect(this,nb,bgid_lo,bgid_hi,bkey) + use parallel, only: comm,nproc + use messager, only: die + use mpi_f08 + implicit none + class(pdsolver), intent(inout) :: this + integer, intent(in) :: nb + integer(I8), intent(in) :: bgid_lo(:),bgid_hi(:) + integer, intent(in) :: bkey(:) + integer(I8), allocatable :: hnode(:),hnbr(:),rnode(:),rnbr(:) + integer, allocatable :: hkey(:),howner(:),rkey(:) + real(WP), allocatable :: rev(:) + integer(1), allocatable :: rdmg(:) + integer :: nhe,rn,i,ib,ierr + + ! Resolve derived configuration (restart-safe shared path) + call this%derive_config() + + ! Distributed gid directory over the node partition (persistent: also + ! serves owner queries for face-tag restamping after restart) + call this%dir%finalize() + call this%dir%register(this%nown,this%gid(1:this%nown)) + + ! Expand bonds into half-entries (one per endpoint row; one total for + ! self-image bonds -- see header) + nhe=0 + do ib=1,nb + nhe=nhe+1 + if (bgid_lo(ib).ne.bgid_hi(ib)) nhe=nhe+1 + end do + allocate(hnode(max(nhe,1)),hnbr(max(nhe,1)),hkey(max(nhe,1)),howner(max(nhe,1))) + nhe=0 + do ib=1,nb + nhe=nhe+1 + hnode(nhe)=bgid_lo(ib); hnbr(nhe)=bgid_hi(ib); hkey(nhe)=bkey(ib) + if (bgid_lo(ib).ne.bgid_hi(ib)) then + nhe=nhe+1 + hnode(nhe)=bgid_hi(ib); hnbr(nhe)=bgid_lo(ib); hkey(nhe)=negkey(bkey(ib)) + end if + end do + + ! Route each half-entry to the rank owning its node + call this%dir%query(nhe,hnode,howner) + route_entries: block + integer, dimension(0:nproc-1) :: sc,rc,sd,rd + integer, allocatable :: pos(:) + integer(I8), allocatable :: s8(:) + integer, allocatable :: s4(:) + integer :: r,h + sc=0 + do i=1,nhe + sc(howner(i))=sc(howner(i))+1 + end do + call MPI_ALLTOALL(sc,1,MPI_INTEGER,rc,1,MPI_INTEGER,comm,ierr) + sd(0)=0; rd(0)=0 + do r=1,nproc-1 + sd(r)=sd(r-1)+sc(r-1); rd(r)=rd(r-1)+rc(r-1) + end do + rn=sum(rc) + allocate(rnode(max(rn,1)),rnbr(max(rn,1)),rkey(max(rn,1))) + allocate(pos(0:nproc-1),s8(max(nhe,1)),s4(max(nhe,1))) + ! node gids + pos=sd + do i=1,nhe + h=howner(i); pos(h)=pos(h)+1; s8(pos(h))=hnode(i) + end do + call MPI_ALLTOALLV(s8,sc,sd,MPI_INTEGER8,rnode,rc,rd,MPI_INTEGER8,comm,ierr) + ! neighbor gids + pos=sd + do i=1,nhe + h=howner(i); pos(h)=pos(h)+1; s8(pos(h))=hnbr(i) + end do + call MPI_ALLTOALLV(s8,sc,sd,MPI_INTEGER8,rnbr,rc,rd,MPI_INTEGER8,comm,ierr) + ! image keys + pos=sd + do i=1,nhe + h=howner(i); pos(h)=pos(h)+1; s4(pos(h))=hkey(i) + end do + call MPI_ALLTOALLV(s4,sc,sd,MPI_INTEGER,rkey,rc,rd,MPI_INTEGER,comm,ierr) + deallocate(pos,s8,s4) + end block route_entries + deallocate(hnode,hnbr,hkey,howner) + + ! Fresh bonds carry zero inelastic state + allocate(rev(max(rn,1)),rdmg(max(rn,1))) + rev=0.0_WP; rdmg=0_1 + call this%assemble(rn,rnode,rnbr,rkey,rev,rdmg) + deallocate(rnode,rnbr,rkey,rev,rdmg) + end subroutine connect + + + !> Build the bond families directly from the REFERENCE configuration -- no + !> amrpd bond container, no bond expansion: distributed neighbor discovery + !> at radius delta (bounds allgather + per-(rank,image-offset) offers of + !> shifted x0, contact-broadphase pattern), then each owned row's + !> half-entries are generated straight from the binned candidates and fed + !> to assemble with zero inelastic state. Acceptance test r2 <= delta^2 + !> matches amrpd bond_init exactly. Collective; call after set_nodes. + subroutine detect_families(this) + use parallel, only: comm,rank,nproc,amRoot,MPI_REAL_WP + use messager, only: log,die + use string, only: str_long + use mpi_f08 + implicit none + class(pdsolver), intent(inout) :: this + real(WP), dimension(3) :: bl,bh,shift,pos_s,gl,hcell + real(WP), allocatable :: allb(:,:),opos(:,:),rpos(:,:),cpos(:,:) + integer(I8), allocatable :: ogid(:),rgid(:),cgid(:),hnode(:),hnbr(:) + integer, allocatable :: okey(:),rkey(:),ckey(:),hkey(:),head(:),nxt(:) + real(WP), allocatable :: rev(:) + integer(1), allocatable :: rdmg(:) + integer, dimension(0:nproc-1) :: sc,rc,sd,rd,sc3,rc3,sd3,rd3 + integer, dimension(3) :: nmax,nc + integer :: d,r,n1,n2,n3,i,k,m,noff,nrecv,ncand,nhe,pass,ic,jc,kc,c1,c2,c3,ierr + character(len=str_long) :: message + + ! Resolve derived configuration (restart-safe shared path) + call this%derive_config() + + ! Directory over the node partition (persistent) + call this%dir%finalize() + call this%dir%register(this%nown,this%gid(1:this%nown)) + + ! Owned reference bounds, exchanged globally + bl=huge(1.0_WP); bh=-huge(1.0_WP) + do i=1,this%nown + bl=min(bl,this%x0(:,i)); bh=max(bh,this%x0(:,i)) + end do + allocate(allb(6,0:nproc-1)) + call MPI_ALLGATHER([bl,bh],6,MPI_REAL_WP,allb,6,MPI_REAL_WP,comm,ierr) + do d=1,3 + nmax(d)=0 + if (this%per(d).and.this%Ldom(d).gt.0.0_WP) nmax(d)=min(4,int(this%delta/this%Ldom(d))+1) + end do + + ! Offers of shifted reference positions (two passes: count, fill) + do pass=1,2 + sc=0 + do r=0,nproc-1 + do n3=-nmax(3),nmax(3); do n2=-nmax(2),nmax(2); do n1=-nmax(1),nmax(1) + if (r.eq.rank.and.n1.eq.0.and.n2.eq.0.and.n3.eq.0) cycle + shift=[real(n1,WP)*this%Ldom(1),real(n2,WP)*this%Ldom(2),real(n3,WP)*this%Ldom(3)] + if (any(bl+shift-this%delta.gt.allb(4:6,r)).or.any(bh+shift+this%delta.lt.allb(1:3,r))) cycle + do i=1,this%nown + pos_s=this%x0(:,i)+shift + if (any(pos_s.lt.allb(1:3,r)-this%delta).or.any(pos_s.gt.allb(4:6,r)+this%delta)) cycle + sc(r)=sc(r)+1 + if (pass.eq.2) then + ogid(sd(r)+sc(r))=this%gid(i) + okey(sd(r)+sc(r))=(n1+128)+(n2+128)*256+(n3+128)*65536 + opos(:,sd(r)+sc(r))=pos_s + end if + end do + end do; end do; end do + end do + if (pass.eq.1) then + sd(0)=0 + do r=1,nproc-1 + sd(r)=sd(r-1)+sc(r-1) + end do + noff=sum(sc) + allocate(ogid(max(noff,1)),okey(max(noff,1)),opos(3,max(noff,1))) + end if + end do + call MPI_ALLTOALL(sc,1,MPI_INTEGER,rc,1,MPI_INTEGER,comm,ierr) + rd(0)=0 + do r=1,nproc-1 + rd(r)=rd(r-1)+rc(r-1) + end do + nrecv=sum(rc) + allocate(rgid(max(nrecv,1)),rkey(max(nrecv,1)),rpos(3,max(nrecv,1))) + call MPI_ALLTOALLV(ogid,sc,sd,MPI_INTEGER8,rgid,rc,rd,MPI_INTEGER8,comm,ierr) + call MPI_ALLTOALLV(okey,sc,sd,MPI_INTEGER, rkey,rc,rd,MPI_INTEGER, comm,ierr) + sc3=3*sc; sd3=3*sd; rc3=3*rc; rd3=3*rd + call MPI_ALLTOALLV(opos,sc3,sd3,MPI_REAL_WP,rpos,rc3,rd3,MPI_REAL_WP,comm,ierr) + deallocate(ogid,okey,opos) + + ! Candidate set = owned nodes (zero offset) + received offers + ncand=this%nown+nrecv + allocate(cgid(max(ncand,1)),ckey(max(ncand,1)),cpos(3,max(ncand,1))) + do i=1,this%nown + cgid(i)=this%gid(i); ckey(i)=PDHALO_KEY0; cpos(:,i)=this%x0(:,i) + end do + do i=1,nrecv + cgid(this%nown+i)=rgid(i); ckey(this%nown+i)=rkey(i); cpos(:,this%nown+i)=rpos(:,i) + end do + deallocate(rgid,rkey,rpos) + + ! Bin candidates; generate each owned row directly (two passes) + bl=huge(1.0_WP); bh=-huge(1.0_WP) + do m=1,ncand + bl=min(bl,cpos(:,m)); bh=max(bh,cpos(:,m)) + end do + call setup_bins(bl,bh,this%delta,gl,hcell,nc) + allocate(head(nc(1)*nc(2)*nc(3)),nxt(max(ncand,1))) + head=0 + do m=1,ncand + k=cell_of(cpos(:,m),gl,hcell,nc) + nxt(m)=head(k); head(k)=m + end do + do pass=1,2 + nhe=0 + do i=1,this%nown + ic=min(nc(1),max(1,int((this%x0(1,i)-gl(1))/hcell(1))+1)) + jc=min(nc(2),max(1,int((this%x0(2,i)-gl(2))/hcell(2))+1)) + kc=min(nc(3),max(1,int((this%x0(3,i)-gl(3))/hcell(3))+1)) + do c3=max(1,kc-1),min(nc(3),kc+1); do c2=max(1,jc-1),min(nc(2),jc+1); do c1=max(1,ic-1),min(nc(1),ic+1) + m=head(c1+nc(1)*(c2-1)+nc(1)*nc(2)*(c3-1)) + do while (m.gt.0) + if (m.ne.i) then + if (sum((cpos(:,m)-this%x0(:,i))**2).le.this%delta**2) then + nhe=nhe+1 + if (pass.eq.2) then + hnode(nhe)=this%gid(i) + hnbr(nhe) =cgid(m) + hkey(nhe) =ckey(m) + end if + end if + end if + m=nxt(m) + end do + end do; end do; end do + end do + if (pass.eq.1) allocate(hnode(max(nhe,1)),hnbr(max(nhe,1)),hkey(max(nhe,1))) + end do + deallocate(cgid,ckey,cpos,head,nxt,allb) + + ! Assemble with zero inelastic state (entries are already local rows) + allocate(rev(max(nhe,1)),rdmg(max(nhe,1))) + rev=0.0_WP; rdmg=0_1 + call this%assemble(nhe,hnode,hnbr,hkey,rev,rdmg) + deallocate(hnode,hnbr,hkey,rev,rdmg) + if (amRoot) then + write(message,'("[",a,"] detect_families: ",i0," half-entries (~2x bonds)")') trim(this%name),this%nbond + call log(message) + end if + end subroutine detect_families + + !> Assemble the CSR families, halo plan, and reference state from LOCAL + !> half-entry arrays (already routed to this rank: every entry's node gid is + !> owned here). Per-entry inelastic state (dmg, e_v) travels with the + !> entries -- zeros for a fresh connect, loaded values on restart. Shared by + !> connect and read_state; collective. + subroutine assemble(this,rn,rnode,rnbr,rkey,rev,rdmg) + use parallel, only: comm,nproc + use messager, only: die + use mpi_f08 + implicit none + class(pdsolver), intent(inout) :: this + integer, intent(in) :: rn + integer(I8), intent(in) :: rnode(:),rnbr(:) + integer, intent(in) :: rkey(:) + real(WP), intent(in) :: rev(:) + integer(1), intent(in) :: rdmg(:) + integer, allocatable :: ridx(:),perm(:) + integer :: i,s,ierr + + if (allocated(this%ptr)) deallocate(this%ptr) + if (allocated(this%lst)) deallocate(this%lst) + if (allocated(this%dmg)) deallocate(this%dmg) + if (allocated(this%e_v)) deallocate(this%e_v) + if (allocated(this%td2)) deallocate(this%td2) + if (allocated(this%td2a)) deallocate(this%td2a) + + ! Resolve each received entry's node to an owned index + allocate(ridx(max(rn,1)),perm(max(rn,1))) + do i=1,rn + ridx(i)=this%ohash%lookup(rnode(i)) + if (ridx(i).lt.1) call die('[pdsolver assemble] half-entry routed to a rank that does not own its node') + perm(i)=i + end do + + ! Deterministic CSR order: sort by (node index, neighbor gid, image key) + if (rn.gt.1) call sort3_perm(ridx,rnbr,rkey,perm,1,rn) + + ! Row pointers + allocate(this%ptr(this%nown+1)) + row_pointers: block + integer, allocatable :: cnt(:) + allocate(cnt(this%nown)); cnt=0 + do i=1,rn + cnt(ridx(i))=cnt(ridx(i))+1 + end do + this%ptr(1)=1 + do i=1,this%nown + this%ptr(i+1)=this%ptr(i)+cnt(i) + end do + deallocate(cnt) + end block row_pointers + + ! Classify entries (owned direct vs halo reference), dedupe references, + ! build the halo plan, and finalize the CSR neighbor indices + build_refs_and_halo: block + integer(I8), allocatable :: refgid(:),ugid(:) + integer, allocatable :: refkey(:),refpos(:),rperm(:),zeros(:) + integer, allocatable :: ukey(:),uowner(:),uslot(:) + integer :: nref,nuniq,lid,u + allocate(this%lst(max(rn,1))) + allocate(this%dmg(max(rn,1))); this%dmg=0_1 + allocate(this%e_v(max(rn,1))); this%e_v=0.0_WP + ! Per-entry inelastic state follows the deterministic CSR order + do s=1,rn + this%dmg(s)=rdmg(perm(s)) + this%e_v(s)=rev(perm(s)) + end do + allocate(this%td2(max(this%nown,1)),this%td2a(max(this%nown,1))) + this%td2=0.0_WP; this%td2a=0.0_WP + allocate(refgid(max(rn,1)),refkey(max(rn,1)),refpos(max(rn,1))) + nref=0 + do s=1,rn + i=perm(s) + if (rkey(i).eq.PDHALO_KEY0) then + lid=this%ohash%lookup(rnbr(i)) + if (lid.ge.1) then + this%lst(s)=lid ! owned, zero image offset: direct index + cycle + end if + end if + nref=nref+1 + refgid(nref)=rnbr(i); refkey(nref)=rkey(i); refpos(nref)=s + end do + ! Unique (gid,key) references, deterministic order + allocate(rperm(max(nref,1)),zeros(max(nref,1))) + zeros=0 + do i=1,nref + rperm(i)=i + end do + if (nref.gt.1) call sort3_perm(zeros,refgid,refkey,rperm,1,nref) + allocate(ugid(max(nref,1)),ukey(max(nref,1))) + nuniq=0 + do s=1,nref + i=rperm(s) + if (s.eq.1) then + nuniq=1; ugid(1)=refgid(i); ukey(1)=refkey(i) + else if (refgid(i).ne.refgid(rperm(s-1)).or.refkey(i).ne.refkey(rperm(s-1))) then + nuniq=nuniq+1; ugid(nuniq)=refgid(i); ukey(nuniq)=refkey(i) + end if + this%lst(refpos(i))=-nuniq ! provisional: -(unique ref id) + end do + ! Owners of the unique references, then the persistent halo plan + allocate(uowner(max(nuniq,1)),uslot(max(nuniq,1))) + call this%dir%query(nuniq,ugid,uowner) + call this%halo%build(this%nown,this%ohash,nuniq,ugid,ukey,uowner,this%Ldom,this%per,uslot) + this%nhalo=this%halo%nhalo + this%ntot=this%nown+this%nhalo + ! Finalize CSR: provisional negatives -> halo slot indices + do s=1,rn + if (this%lst(s).lt.0) this%lst(s)=this%nown+uslot(-this%lst(s)) + end do + ! Extend node arrays to include halo slots; stamp halo gids + extend_arrays: block + integer(I8), allocatable :: g2(:) + real(WP), allocatable :: a2(:,:) + allocate(g2(max(this%ntot,1))); g2(1:this%nown)=this%gid(1:this%nown) + do u=1,nuniq + g2(this%nown+uslot(u))=ugid(u) + end do + call move_alloc(g2,this%gid) + allocate(a2(3,max(this%ntot,1))); a2=0.0_WP; a2(:,1:this%nown)=this%x0(:,1:this%nown) + call move_alloc(a2,this%x0) + allocate(a2(3,max(this%ntot,1))); a2=0.0_WP; a2(:,1:this%nown)=this%y(:,1:this%nown) + call move_alloc(a2,this%y) + allocate(a2(3,max(this%ntot,1))); a2=0.0_WP; a2(:,1:this%nown)=this%f(:,1:this%nown) + call move_alloc(a2,this%f) + extend_tensors: block ! I am copying the patterm but I think this will correctly extend things to include halos + real(WP), allocatable :: t2(:,:,:) + allocate(t2(3,3,max(this%ntot,1))); t2=0.0_WP; t2(:,:,1:this%nown)=this%PK_inv(:,:,1:this%nown) + call move_alloc(t2,this%PK_inv) + end block extend_tensors + extend_volume: block + real(WP), allocatable :: v2(:) + allocate(v2(max(this%ntot,1))); v2=0.0_WP; v2(1:this%nown)=this%vol(1:this%nown) + call move_alloc(v2,this%vol) + end block extend_volume + end block extend_arrays + deallocate(refgid,refkey,refpos,rperm,zeros,ugid,ukey,uowner,uslot) + end block build_refs_and_halo + deallocate(ridx,perm) + + ! Fill halo reference positions ONCE, pre-shifted by the image offsets + ! (x0 is static; this is the only x0 exchange of the entire run), and + ! the halo per-node volumes (also static) + call this%halo%update(this%x0,3,shifted=.true.) + call this%halo%update1(this%vol) + this%y(:,this%nown+1:this%ntot)=this%x0(:,this%nown+1:this%ntot) + + ! Life status (exit-through-open-face handling). Exchanged over the halo + ! ONLY on substeps where a death occurs somewhere; steady state is free. + if (allocated(this%alive)) deallocate(this%alive) + allocate(this%alive(max(this%ntot,1))); this%alive=1.0_WP + this%watch_exit=(this%dom_hi(1).gt.this%dom_lo(1)).and. & + & any((.not.this%per).and.(this%lo_bc.eq.0.or.this%hi_bc.eq.0)) + + ! Stamp the reference weighted volume + call this%compute_mw() + + ! Silling-Askari critical time step (Peridigm form, 3D bond-based + ! micromodulus c(z) = c0*w(z), c0 = 9K/(2*pi*Iw3); w=1 recovers the + ! classical 18K/(pi*delta^4)): + ! dt_crit_i = sqrt(2*rho / sum_family(V_j * c(zeta) / zeta)), global min. + ! DIAGNOSTIC only for now -- reported at init, does not bind dt. The + ! micromodulus constant is 3D-based; in quasi-2D slabs treat it as + ! indicative. + critical_dt: block + use mathtools, only: Pi + use messager, only: log + use string, only: str_long + use parallel, only: amRoot,MPI_REAL_WP + real(WP) :: K_bulk,c0,denom,zeta,dtc + character(len=str_long) :: message + integer :: i,e,j + K_bulk=this%elastic_modulus/(3.0_WP*(1.0_WP-2.0_WP*this%poisson_ratio)) + c0=9.0_WP*K_bulk/(2.0_WP*Pi*wmoment(this%delta,3,1)) + dtc=huge(1.0_WP) + do i=1,this%nown + denom=0.0_WP + do e=this%ptr(i),this%ptr(i+1)-1 + j=this%lst(e) + zeta=sqrt(sum((this%x0(:,j)-this%x0(:,i))**2)) + if (zeta.gt.0.0_WP) denom=denom+this%vol(j)*c0*omega(zeta,this%delta)/zeta + end do + if (denom.gt.0.0_WP) dtc=min(dtc,sqrt(2.0_WP*this%rho/denom)) + end do + call MPI_ALLREDUCE(MPI_IN_PLACE,dtc,1,MPI_REAL_WP,MPI_MIN,comm,ierr) + this%dtcrit=dtc + if (amRoot) then + write(message,'("[",a,"] Silling-Askari critical dt = ",es12.5," (diagnostic)")') trim(this%name),this%dtcrit + call log(message) + end if + end block critical_dt + + ! Global half-entry count for logging (= 2*bonds - self-image bonds) + count_bonds: block + use parallel, only: comm + integer(I8) :: nhe8 + nhe8=int(rn,I8) + call MPI_ALLREDUCE(MPI_IN_PLACE,nhe8,1,MPI_INTEGER8,MPI_SUM,comm,ierr) + this%nbond=nhe8 ! total half-entries; = 2*bonds - self-image bonds + ! Exact bond census (lower-gid rule; positive-offset self-images) + count_nb: block + integer :: i2,e2,j2 + this%nb=0_I8 + do i2=1,this%nown + do e2=this%ptr(i2),this%ptr(i2+1)-1 + j2=this%lst(e2) + if (this%gid(i2).lt.this%gid(j2)) then + this%nb=this%nb+1_I8 + else if (this%gid(i2).eq.this%gid(j2).and.j2.gt.this%nown) then + if (shift_positive(this%halo%shift(:,j2-this%nown))) this%nb=this%nb+1_I8 + end if + end do + end do + call MPI_ALLREDUCE(MPI_IN_PLACE,this%nb,1,MPI_INTEGER8,MPI_SUM,comm,ierr) + end block count_nb + end block count_bonds + end subroutine assemble + + !> Weighted volume: mw_i = sum_family w(zeta)*zeta^2*V_j (reference state; + !> never updated by damage) + subroutine compute_mw(this) + implicit none + class(pdsolver), intent(inout) :: this + integer :: i,e,j + real(WP) :: zeta + do i=1,this%nown + this%mw(i)=0.0_WP + do e=this%ptr(i),this%ptr(i+1)-1 + j=this%lst(e) + zeta=sqrt(sum((this%x0(:,j)-this%x0(:,i))**2)) + this%mw(i)=this%mw(i)+omega(zeta,this%delta)*zeta**2*this%vol(j) + end do + end do + end subroutine compute_mw + + !> Dimension-aware LPS constitutive coefficients (omega-independent: mw + !> absorbs the influence function). psi_fac sets the J2 yield threshold on + !> the family deviatoric force-state norm -- yield when + !> ||t_dev||^2 > psi_fac*sigma_yield^2/mw (Mitchell OSB) -- and DOES depend + !> on omega: since td ~ w, the norm scales by the w^2/w moment ratio + !> (int w^2 z^p / int w z^p, p=4 in 3D, 3 in 2D; ratio = 1 for w=1). + subroutine lps_coefs(this,fdim,coef_vol,coef_dev,psi_fac) + implicit none + class(pdsolver), intent(in) :: this + real(WP), intent(out) :: fdim,coef_vol,coef_dev + real(WP), intent(out), optional :: psi_fac + real(WP) :: K_bulk,mu_shear + integer :: ndim + ndim=3-count(this%collapsed) + K_bulk =this%elastic_modulus/(3.0_WP*(1.0_WP-2.0_WP*this%poisson_ratio)) + mu_shear=this%elastic_modulus/(2.0_WP*(1.0_WP+this%poisson_ratio)) + select case (ndim) + case (3) + fdim=3.0_WP; coef_vol=3.0_WP*K_bulk; coef_dev=15.0_WP*mu_shear + if (present(psi_fac)) psi_fac=5.0_WP*wmoment(this%delta,4,2)/wmoment(this%delta,4,1) + case (2) + fdim=2.0_WP; coef_vol=2.0_WP*(K_bulk+mu_shear/3.0_WP); coef_dev= 8.0_WP*mu_shear + if (present(psi_fac)) psi_fac=8.0_WP/3.0_WP*wmoment(this%delta,3,2)/wmoment(this%delta,3,1) + case default + fdim=1.0_WP; coef_vol=this%elastic_modulus; coef_dev= 0.0_WP + if (present(psi_fac)) psi_fac=0.0_WP + end select + end subroutine lps_coefs + + !> Velocity-Verlet step: half-kick + drift, halo position update, + !> dilatation gather, node-centered force sweep, halo force reduce, + !> contact, second half-kick. + subroutine pd_advance(this,dt) + use parallel, only: parallel_time + implicit none + class(pdsolver), intent(inout) :: this + real(WP), intent(in) :: dt + real(WP) :: rho_inv,fdim,cvol,cdev,t0 + real(WP) :: zeta,dY,e_b,t,w + real(WP) :: psi_fac,decay,e_d,td,beta,e_e,over + real(WP) :: sYe2,strial,mu3i + logical :: plastic,do_j2 + real(WP), dimension(3) :: acc,dxv,fx + real(WP), dimension(3,3) :: K_mat,E_mat,I_mat,S_mat,K_inv,sigma, s_dev + real(WP) :: detK,traceE + real(WP) :: kk,mu + real(WP), dimension(3) :: xi,rpos,z,t1,t2,tc + integer :: i,e,j + + rho_inv=1.0_WP/this%rho + mu=this%elastic_modulus/(2.0_WP+2.0_WP*this%poisson_ratio) + kk=this%elastic_modulus/(3.0_WP-6.0_WP*this%poisson_ratio) + call this%lps_coefs(fdim,cvol,cdev,psi_fac) + ! ! Viscoplastic setup: decay is loop-invariant (exact exponential update, + ! ! unconditionally stable -- no viscous CFL) + ! plastic=(this%tau.gt.0.0_WP.and.this%tau.lt.huge(1.0_WP)) + ! do_j2=(this%sigma_yield.gt.0.0_WP) + ! decay=0.0_WP + ! if (plastic) decay=exp(-dt/this%tau) + ! mu3i=2.0_WP*(1.0_WP+this%poisson_ratio)/(3.0_WP*this%elastic_modulus) ! 1/(3*mu_shear) + + ! First half-kick and drift (owned nodes) + t0=parallel_time() + do i=1,this%nown + if (this%flag(i).eq.PDC_IS_DEAD) cycle + acc=this%gravity+(this%f(:,i)+this%ff(:,i))*rho_inv + if (iand(this%flag(i),PDC_INTEGRATES).ne.0) this%v(:,i)=(1.0_WP-this%damping_rate)*this%v(:,i)+0.5_WP*dt*acc + if (this%collapsed(1)) this%v(1,i)=0.0_WP + if (this%collapsed(2)) this%v(2,i)=0.0_WP + if (this%collapsed(3)) this%v(3,i)=0.0_WP + if (iand(this%flag(i),PDC_MOVES).ne.0) this%y(:,i)=this%y(:,i)+dt*this%v(:,i) + end do + this%wt_kick=this%wt_kick+(parallel_time()-t0) + + ! Exit handling: nodes drifting out through an OPEN non-periodic face die + ! (amrpd drops them at Redistribute; here they are flagged and muted). + ! The death-count allreduce runs only when exits are possible at all, and + ! the mute propagation only on substeps where a death actually occurred. + if (this%watch_exit) then + death_watch: block + use parallel, only: comm + use mpi_f08, only: MPI_ALLREDUCE,MPI_IN_PLACE,MPI_SUM,MPI_INTEGER + integer :: nd,d,e,ierr + logical :: out + nd=0 + do i=1,this%nown + if (this%flag(i).eq.PDC_IS_DEAD) cycle + out=.false. + do d=1,3 + if (this%per(d)) cycle + if (this%lo_bc(d).eq.0.and.this%y(d,i).lt.this%dom_lo(d)) out=.true. + if (this%hi_bc(d).eq.0.and.this%y(d,i).gt.this%dom_hi(d)) out=.true. + end do + if (out) then + this%flag(i)=PDC_IS_DEAD + this%v(:,i)=0.0_WP + this%alive(i)=0.0_WP + nd=nd+1 + end if + end do + call MPI_ALLREDUCE(MPI_IN_PLACE,nd,1,MPI_INTEGER,MPI_SUM,comm,ierr) + if (nd.gt.0) then + ! Propagate life status to halo slots, then permanently mute + ! every entry touching a dead node (dmg=2: distinct from broken, + ! so damage statistics stay honest -- amrpd does not count + ! dropped-particle bonds as damage either) + call this%halo%update1(this%alive) + do i=1,this%nown + if (this%flag(i).eq.PDC_IS_DEAD) then + do e=this%ptr(i),this%ptr(i+1)-1 + if (this%dmg(e).eq.0_1) this%dmg(e)=2_1 + end do + else + do e=this%ptr(i),this%ptr(i+1)-1 + if (this%dmg(e).eq.0_1.and.this%alive(this%lst(e)).lt.0.5_WP) this%dmg(e)=2_1 + end do + end if + end do + ! Force a contact broad-phase rebuild so no candidate list + ! references a corpse (dead nodes are excluded from offers/bins) + if (this%use_contact.and.allocated(this%ylast)) deallocate(this%ylast) + end if + end block death_watch + end if + + ! Refresh halo positions (owner y -> slots, with image shifts) + t0=parallel_time() + call this%halo%update(this%y,3,shifted=.true.) + this%wt_halo=this%wt_halo+(parallel_time()-t0) + + ! Contact service: displacement-triggered broad phase (rebuilds contact + ! halo + candidate list when cumulative drift exhausts the skin), then + ! per-substep refresh of contact-slot positions AND velocities (the only + ! place velocity crosses ranks; the graph halo never carries it) + if (this%use_contact) then + t0=parallel_time() + call this%contact_broadphase() + this%wt_broad=this%wt_broad+(parallel_time()-t0) + t0=parallel_time() + call this%chalo%update(this%y,3,shifted=.true.) + call this%chalo%update(this%v,3,shifted=.false.) + this%wt_halo=this%wt_halo+(parallel_time()-t0) + end if + + ! ! Dilatation (pure gather; own family only; broken entries excluded -- + ! ! breaks happen in the force sweep AFTER this, matching amrpd's ordering) + ! t0=parallel_time() + ! do i=1,this%nown + ! this%theta(i)=0.0_WP + ! do e=this%ptr(i),this%ptr(i+1)-1 + ! if (this%dmg(e).ne.0_1) cycle + ! j=this%lst(e) + ! zeta=sqrt(sum((this%x0(:,j)-this%x0(:,i))**2)) + ! dY =sqrt(sum((this%y(:,j) -this%y(:,i) )**2)) + ! e_b=dY-zeta + ! this%theta(i)=this%theta(i)+omega(zeta,this%delta)*zeta*e_b*this%vol(j) + ! end do + ! if (this%mw(i).gt.0.0_WP) then + ! this%theta(i)=fdim*this%theta(i)/this%mw(i) + ! else + ! this%theta(i)=0.0_WP + ! end if + ! end do + ! this%wt_dil=this%wt_dil+(parallel_time()-t0) + + ! Equivalent to the dilatation sweep from before, I think that each one needs to sweep over + ! and compute the tensors K_mat and F + I_mat = 0.0_WP + I_mat(1,1) = 1.0_WP + I_mat(2,2) = 1.0_WP + I_mat(3,3) = 1.0_WP + do i=1,this%nown + K_mat=0.0_WP + K_inv = 0.0_WP + S_mat = 0.0_WP + traceE = 0.0_WP + E_mat = 0.0_WP + this%F_mat(:,:,i)=0.0_WP + this%PK_inv(:,:,i)=0.0_WP + do e=this%ptr(i),this%ptr(i+1)-1 + if (this%dmg(e).ne.0_1) cycle + j=this%lst(e) + xi=this%x0(:,j)-this%x0(:,i) + rpos=this%y(:,j) -this%y(:,i) + zeta=sqrt(sum(xi**2)) + w = omega(zeta,this%delta) + K_mat(1,1)=K_mat(1,1)+xi(1)*xi(1)*w*this%vol(j); K_mat(1,2)=K_mat(1,2)+xi(1)*xi(2)*w*this%vol(j); K_mat(1,3)=K_mat(1,3)+xi(1)*xi(3)*w*this%vol(j); + K_mat(2,1)=K_mat(2,1)+xi(2)*xi(1)*w*this%vol(j); K_mat(2,2)=K_mat(2,2)+xi(2)*xi(2)*w*this%vol(j); K_mat(2,3)=K_mat(2,3)+xi(2)*xi(3)*w*this%vol(j); + K_mat(3,1)=K_mat(3,1)+xi(3)*xi(1)*w*this%vol(j); K_mat(3,2)=K_mat(3,2)+xi(3)*xi(2)*w*this%vol(j); K_mat(3,3)=K_mat(3,3)+xi(3)*xi(3)*w*this%vol(j); + + this%F_mat(1,1,i)=this%F_mat(1,1,i)+rpos(1)*xi(1)*w*this%vol(j); this%F_mat(1,2,i)=this%F_mat(1,2,i)+rpos(1)*xi(2)*w*this%vol(j); this%F_mat(1,3,i)=this%F_mat(1,3,i)+rpos(1)*xi(3)*w*this%vol(j); + this%F_mat(2,1,i)=this%F_mat(2,1,i)+rpos(2)*xi(1)*w*this%vol(j); this%F_mat(2,2,i)=this%F_mat(2,2,i)+rpos(2)*xi(2)*w*this%vol(j); this%F_mat(2,3,i)=this%F_mat(2,3,i)+rpos(2)*xi(3)*w*this%vol(j); + this%F_mat(3,1,i)=this%F_mat(3,1,i)+rpos(3)*xi(1)*w*this%vol(j); this%F_mat(3,2,i)=this%F_mat(3,2,i)+rpos(3)*xi(2)*w*this%vol(j); this%F_mat(3,3,i)=this%F_mat(3,3,i)+rpos(3)*xi(3)*w*this%vol(j); + end do + + detK = K_mat(1,1)*(K_mat(2,2)*K_mat(3,3)-K_mat(2,3)*K_mat(3,2)) & + -K_mat(1,2)*(K_mat(2,1)*K_mat(3,3)-K_mat(2,3)*K_mat(3,1)) & + +K_mat(1,3)*(K_mat(2,1)*K_mat(3,2)-K_mat(2,2)*K_mat(3,1)) + K_inv(1,1) = (K_mat(2,2)*K_mat(3,3) - K_mat(2,3)*K_mat(3,2))/detK + K_inv(2,1) = -(K_mat(2,1)*K_mat(3,3) - K_mat(2,3)*K_mat(3,1))/detK + K_inv(3,1) = (K_mat(2,1)*K_mat(3,2) - K_mat(2,2)*K_mat(3,1))/detK + K_inv(1,2) = -(K_mat(1,2)*K_mat(3,3) - K_mat(1,3)*K_mat(3,2))/detK + K_inv(2,2) = (K_mat(1,1)*K_mat(3,3) - K_mat(1,3)*K_mat(3,1))/detK + K_inv(3,2) = -(K_mat(1,1)*K_mat(3,2) - K_mat(1,2)*K_mat(3,1))/detK + K_inv(1,3) = (K_mat(1,2)*K_mat(2,3) - K_mat(1,3)*K_mat(2,2))/detK + K_inv(2,3) = -(K_mat(1,1)*K_mat(2,3) - K_mat(1,3)*K_mat(2,1))/detK + K_inv(3,3) = (K_mat(1,1)*K_mat(2,2) - K_mat(1,2)*K_mat(2,1))/detK + + this%F_mat(:,:,i) = MATMUL(this%F_mat(:,:,i),K_inv) + E_mat = 0.5_WP * (MATMUL(TRANSPOSE(this%F_mat(:,:,i)),this%F_mat(:,:,i))-I_mat) + traceE = E_mat(1,1) + E_mat(2,2) + E_mat(3,3) + S_mat = (kk-2.0_WP/3.0_WP*mu)*traceE*I_mat + 2.0_WP*mu*E_mat + this%PK_inv(:,:,i) = MATMUL(MATMUL(this%F_mat(:,:,i),S_mat),K_inv) + end do + + ! I think here we just need to communicate PK_inv and F_mat, everything else can stay local + ! t0=parallel_time() + do e=1,3 + call this%halo%update(this%PK_inv(:,e,:),3,shifted=.false.) + end do + ! this%wt_halo=this%wt_halo+(parallel_time()-t0) + + ! Node-centered force sweep: each row computes its OWN force state t + ! (own theta, own mw) and scatters +t/-t; the neighbor's t arrives from + ! the neighbor's own row (locally or via the halo reduce below). + t0=parallel_time() + this%f=0.0_WP + do i=1,this%nown + ! if (this%mw(i).le.0.0_WP) cycle + ! ! Per-node J2 return factor from the LAGGED family norm. With + ! ! hardening (hard_mod>0) the surface radius grows with the node's + ! ! accumulated equivalent plastic strain lam_p (surface lagged one + ! ! substep like the norm: exact to O(H/3mu) per substep, and H<<3mu + ! ! for metals; stress-space equivalent of Peridigm's + ! ! elastic_plastic_hardening). The increment uses (1-beta)*strial = + ! ! the trial-stress excess, so the rate-independent limit matches the + ! ! classical radial return; (1-decay) is the Perzyna-realized + ! ! fraction. lam_p accumulates even at hard_mod=0 (free plastic- + ! ! strain diagnostic; forces unchanged there, bit-exact w/ flat yield). + ! beta=1.0_WP + ! if (plastic.and.do_j2) then + ! sYe2=(this%sigma_yield+this%hard_mod*this%lam_p(i))**2 + ! if (this%td2(i)*this%mw(i).gt.psi_fac*sYe2) then + ! beta=sqrt(psi_fac*sYe2/(this%td2(i)*this%mw(i))) + ! strial=sqrt(this%td2(i)*this%mw(i)/psi_fac) + ! this%lam_p(i)=this%lam_p(i)+(1.0_WP-beta)*(1.0_WP-decay)*strial*mu3i + ! end if + ! end if + + ! We are not currently doing the plastic behavior, so we can skip this + do e=this%ptr(i),this%ptr(i+1)-1 !IVM, does this work out so that each point is visited at the main, or do we only end up visiting half?? + if (this%dmg(e).ne.0_1) cycle + j=this%lst(e) + ! zeta=sqrt(sum((this%x0(:,j)-this%x0(:,i))**2)) + ! dxv=this%y(:,j)-this%y(:,i) + ! dY=sqrt(sum(dxv**2)) + xi=this%x0(:,j)-this%x0(:,i) + rpos=this%y(:,j) -this%y(:,i) + zeta=sqrt(sum(xi**2)) + dY = sqrt(sum(rpos**2)) + if (dY.le.0.0_WP) cycle + e_b=dY-zeta + ! Brittle break on total stretch (e > s0*zeta), irreversible. + ! Each row breaks its OWN half-entry and increments its OWN node's + ! damage by 1/nb0 (nb0 = reference row length); the counterpart row + ! breaks its half independently -- the criterion is symmetric in + ! the endpoints, so both halves break in the same substep (for + ! image bonds, up to shift-association roundoff: a 1-ulp-marginal + ! bond may break one substep apart, a benign local transient -- + ! the intact half still applies its +/- pair, conserving momentum). + if (e_b.gt.this%s0*zeta) then + this%dmg(e)=1_1 + this%damage(i)=this%damage(i)+1.0_WP/real(this%ptr(i+1)-this%ptr(i),WP) + cycle + end if + w=omega(zeta,this%delta) + ! ! Deviatoric split: e_d carries this HALF-ENTRY's inelastic stretch + ! ! e_v (per-side history: own theta, own mw -- Peridigm form; e_v=0 + ! ! recovers canonical elastic LPS bit-for-bit) + ! e_d=e_b-this%theta(i)*zeta/fdim + ! td=w/this%mw(i)*cdev*(e_d-this%visc_lambda*this%e_v(e)) + ! t =w/this%mw(i)*cvol*this%theta(i)*zeta+td + ! ! J2 family norm: pure own-row gather (no communication) + ! if (do_j2) this%td2a(i)=this%td2a(i)+td*td*this%vol(j) + ! ! Pair contribution from THIS row's force state (Peridigm volumes: + ! ! +t*V_j to self, -t*V_i to the neighbor) + ! fx=t*dxv/dY + ! this%f(:,i)=this%f(:,i)+fx*this%vol(j) + ! this%f(:,j)=this%f(:,j)-fx*this%vol(i) + ! ! Per-side viscoplastic flow of e_v (exact exponential). Two yield + ! ! criteria, as in amrpd: + ! ! sigma_yield>0: J2 radial return (per-node beta computed at the + ! ! row head above, incl. isotropic hardening), Perzyna- + ! ! regularized by (1-decay); tau->0 recovers Peridigm's + ! ! rate-independent return. + ! ! else: per-bond overstress (yield_stretch=0 -> pure Maxwell). + ! if (plastic) then + ! if (do_j2) then + ! this%e_v(e)=this%e_v(e)+(1.0_WP-beta)*(e_d-this%e_v(e))*(1.0_WP-decay) + ! else + ! e_e=e_d-this%e_v(e) + ! over=abs(e_e)-this%yield_stretch*zeta + ! if (over.gt.0.0_WP) this%e_v(e)=this%e_v(e)+sign(over*(1.0_WP-decay),e_e) + ! end if + ! end if + + ! Now we compute forces, similar to before, but we only plus up the one particle instead of being slick with both + t1 = w*MATMUL(this%PK_inv(:,:,i),xi) + ! Force density 2->1 + t2 = w*MATMUL(this%PK_inv(:,:,j),xi) + ! Force correction term + z = rpos-MATMUL(this%F_mat(:,:,i),xi) + tc = w*(9.0_WP*kk/((3.14159265_WP) * this%delta**4))*(dot_product(xi,z)/(sqrt(dot_product(xi,xi)))**3)*xi + ! Compute bond acceleration + this%f(:,i)=this%f(:,i)+(t1+t2+tc)*this%vol(j) + end do + end do + ! ! Publish this substep's J2 norm (read by the NEXT substep's return) + ! if (do_j2) then + ! this%td2(1:this%nown)=this%td2a(1:this%nown) + ! this%td2a(1:this%nown)=0.0_WP + ! end if + this%wt_force=this%wt_force+(parallel_time()-t0) + + ! Assemble cross-rank pair forces (halo slots -> owners, add) + t0=parallel_time() + call this%halo%reduce(this%f,3) + this%wt_reduce=this%wt_reduce+(parallel_time()-t0) + + ! Short-range contact (walls + particle-particle), gather-only: adds + ! into owned f, no reduction (amrpd ordering: after the bond force) + if (this%use_contact) then + t0=parallel_time() + call this%contact_narrow(dt) + this%wt_contact=this%wt_contact+(parallel_time()-t0) + end if + + ! Second half-kick with the fresh force + t0=parallel_time() + do i=1,this%nown + if (this%flag(i).eq.PDC_IS_DEAD) cycle + if (iand(this%flag(i),PDC_INTEGRATES).ne.0) then + acc=this%gravity+(this%f(:,i)+this%ff(:,i))*rho_inv + this%v(:,i)=(1.0_WP-this%damping_rate)*this%v(:,i)+0.5_WP*dt*acc + end if + if (this%collapsed(1)) this%v(1,i)=0.0_WP + if (this%collapsed(2)) this%v(2,i)=0.0_WP + if (this%collapsed(3)) this%v(3,i)=0.0_WP + end do + this%wt_kick=this%wt_kick+(parallel_time()-t0) + end subroutine pd_advance + + !> Contact broad phase: displacement-triggered rebuild of the contact halo + !> and the candidate CSR. The trigger is one scalar allreduce per substep so + !> the (collective) rebuild decision is rank-consistent. rbuild = + !> 1.2*contact_dist + 2*cskin: engagement reach is bounded by d_eff*(1+0.2) + !> (the r_influ clip) and two nodes drifting cskin each can close 2*cskin + !> between rebuilds, so the candidate set provably contains every pair that + !> can produce force before the next rebuild. + !> + !> Discovery: allgather of per-rank owned-node bounds; for each (rank, + !> periodic-image offset) whose shifted bounds approach mine within rbuild, + !> OFFER my owned nodes in range as (gid, image key, shifted position). The + !> receiver keeps offers with an owned node within rbuild (binned test) and + !> builds the contact halo from the kept references via the standard pdhalo + !> protocol (chalo%nown = ntot, so contact slots append after graph slots). + !> Candidates are then binned over OWNED + CONTACT slots only -- the graph + !> halo is never binned, so bonded remote partners arrive as contact slots + !> when in range and double-counting is structurally impossible. + subroutine contact_broadphase(this) + use parallel, only: comm,rank,nproc,MPI_REAL_WP + use mpi_f08 + use messager, only: die + implicit none + class(pdsolver), intent(inout) :: this + real(WP) :: rbuild,drift + integer :: i,ierr + + if (this%contact_dist.le.0.0_WP) call die('[pdsolver contact] use_contact requires contact_dist > 0') + if (this%cskin.le.0.0_WP) this%cskin=0.5_WP*this%contact_dist + rbuild=1.2_WP*this%contact_dist+2.0_WP*this%cskin + + ! Displacement trigger (collective decision) + if (allocated(this%ylast)) then + drift=0.0_WP + do i=1,this%nown + drift=max(drift,sum((this%y(:,i)-this%ylast(:,i))**2)) + end do + drift=sqrt(drift) + else + drift=huge(1.0_WP) + end if + call MPI_ALLREDUCE(MPI_IN_PLACE,drift,1,MPI_REAL_WP,MPI_MAX,comm,ierr) + if (drift.le.this%cskin) return + this%nrebuild=this%nrebuild+1_I8 + + rebuild: block + real(WP), dimension(3) :: bl,bh,shift,pos_s + real(WP), allocatable :: allb(:,:),opos(:,:),rpos(:,:),kpos(:,:) + integer(I8), allocatable :: ogid(:),rgid(:),kgid(:) + integer, allocatable :: okey(:),rkey(:),kkey(:),kowner(:),slot(:) + integer, dimension(0:nproc-1) :: sc,rc,sd,rd + integer, dimension(0:nproc-1) :: sc3,rc3,sd3,rd3 + integer :: nmax(3),d,r,n1,n2,n3,noff,nrecv,nkeep,k,pass + ! Binning workspace (owned nodes for offer filtering, then combined + ! set for the candidate CSR) + real(WP), dimension(3) :: gl,hcell + integer, dimension(3) :: nc + integer, allocatable :: head(:),nxt(:) + + ! Owned bounds and their global exchange + bl=huge(1.0_WP); bh=-huge(1.0_WP) + do i=1,this%nown + bl=min(bl,this%y(:,i)); bh=max(bh,this%y(:,i)) + end do + allocate(allb(6,0:nproc-1)) + call MPI_ALLGATHER([bl,bh],6,MPI_REAL_WP,allb,6,MPI_REAL_WP,comm,ierr) + + ! Admissible periodic-image offsets for contact range + do d=1,3 + nmax(d)=0 + if (this%per(d).and.this%Ldom(d).gt.0.0_WP) nmax(d)=min(4,int(rbuild/this%Ldom(d))+1) + end do + + ! Offers: two passes (count, then fill), grouped by destination rank + do pass=1,2 + sc=0 + do r=0,nproc-1 + do n3=-nmax(3),nmax(3); do n2=-nmax(2),nmax(2); do n1=-nmax(1),nmax(1) + if (r.eq.rank.and.n1.eq.0.and.n2.eq.0.and.n3.eq.0) cycle + shift=[real(n1,WP)*this%Ldom(1),real(n2,WP)*this%Ldom(2),real(n3,WP)*this%Ldom(3)] + ! Shifted-bounds proximity prefilter + if (any(bl+shift-rbuild.gt.allb(4:6,r)).or.any(bh+shift+rbuild.lt.allb(1:3,r))) cycle + do i=1,this%nown + if (this%flag(i).eq.PDC_IS_DEAD) cycle + pos_s=this%y(:,i)+shift + if (any(pos_s.lt.allb(1:3,r)-rbuild).or.any(pos_s.gt.allb(4:6,r)+rbuild)) cycle + sc(r)=sc(r)+1 + if (pass.eq.2) then + ogid(sd(r)+sc(r))=this%gid(i) + okey(sd(r)+sc(r))=(n1+128)+(n2+128)*256+(n3+128)*65536 + opos(:,sd(r)+sc(r))=pos_s + end if + end do + end do; end do; end do + end do + if (pass.eq.1) then + sd(0)=0 + do r=1,nproc-1 + sd(r)=sd(r-1)+sc(r-1) + end do + noff=sum(sc) + allocate(ogid(max(noff,1)),okey(max(noff,1)),opos(3,max(noff,1))) + end if + end do + + ! Exchange offers (gid, key, shifted position) + call MPI_ALLTOALL(sc,1,MPI_INTEGER,rc,1,MPI_INTEGER,comm,ierr) + rd(0)=0 + do r=1,nproc-1 + rd(r)=rd(r-1)+rc(r-1) + end do + nrecv=sum(rc) + allocate(rgid(max(nrecv,1)),rkey(max(nrecv,1)),rpos(3,max(nrecv,1))) + call MPI_ALLTOALLV(ogid,sc,sd,MPI_INTEGER8,rgid,rc,rd,MPI_INTEGER8,comm,ierr) + call MPI_ALLTOALLV(okey,sc,sd,MPI_INTEGER, rkey,rc,rd,MPI_INTEGER, comm,ierr) + sc3=3*sc; sd3=3*sd; rc3=3*rc; rd3=3*rd + call MPI_ALLTOALLV(opos,sc3,sd3,MPI_REAL_WP,rpos,rc3,rd3,MPI_REAL_WP,comm,ierr) + deallocate(ogid,okey,opos) + + ! Filter offers: keep those with an owned node within rbuild. + ! Bin owned nodes (cell size >= rbuild so a +/-1 cell sweep suffices; + ! dims clamped so degenerate/huge extents stay bounded). + call setup_bins(bl,bh,rbuild,gl,hcell,nc) + allocate(head(nc(1)*nc(2)*nc(3)),nxt(max(this%nown,1))) + head=0 + do i=1,this%nown + if (this%flag(i).eq.PDC_IS_DEAD) cycle + k=cell_of(this%y(:,i),gl,hcell,nc) + nxt(i)=head(k); head(k)=i + end do + allocate(kgid(max(nrecv,1)),kkey(max(nrecv,1)),kowner(max(nrecv,1)),kpos(3,max(nrecv,1))) + nkeep=0 + do r=0,nproc-1 + do i=rd(r)+1,rd(r)+rc(r) + if (near_owned(rpos(:,i),rbuild,gl,hcell,nc,head,nxt)) then + nkeep=nkeep+1 + kgid(nkeep)=rgid(i); kkey(nkeep)=rkey(i); kowner(nkeep)=r; kpos(:,nkeep)=rpos(:,i) + end if + end do + end do + deallocate(rgid,rkey,rpos,head,nxt) + + ! Rebuild the contact halo (slots append after graph slots: nown=ntot) + call this%chalo%finalize() + allocate(slot(max(nkeep,1))) + call this%chalo%build(this%ntot,this%ohash,nkeep,kgid,kkey,kowner,this%Ldom,this%per,slot) + this%nchalo=this%chalo%nhalo + + ! Extend y and v to cover contact slots; stamp slot positions from the + ! kept offers (current values -- chalo%update refreshes each substep) + resize_state: block + real(WP), allocatable :: a2(:,:) + integer :: ntc + ntc=this%ntot+this%nchalo + allocate(a2(3,max(ntc,1))); a2=0.0_WP + a2(:,1:this%ntot)=this%y(:,1:this%ntot) + call move_alloc(a2,this%y) + allocate(a2(3,max(ntc,1))); a2=0.0_WP + a2(:,1:this%nown)=this%v(:,1:this%nown) + call move_alloc(a2,this%v) + do k=1,nkeep + this%y(:,this%ntot+slot(k))=kpos(:,k) + end do + end block resize_state + deallocate(kgid,kkey,kowner,kpos,slot) + + ! Candidate CSR over the contact-visible set: owned nodes (indices + ! 1..nown) + contact slots (ntot+1..ntot+nchalo). Two passes. + candidates: block + integer :: ns,m,jj,cnt,ic,jc,kc,c1,c2,c3 + integer, allocatable :: midx(:) + real(WP), dimension(3) :: blc,bhc + ns=this%nown+this%nchalo + allocate(midx(max(ns,1))) + do m=1,this%nown + midx(m)=m + end do + do m=1,this%nchalo + midx(this%nown+m)=this%ntot+m + end do + blc=bl; bhc=bh + do m=this%nown+1,ns + blc=min(blc,this%y(:,midx(m))); bhc=max(bhc,this%y(:,midx(m))) + end do + call setup_bins(blc,bhc,rbuild,gl,hcell,nc) + allocate(head(nc(1)*nc(2)*nc(3)),nxt(max(ns,1))) + head=0 + do m=1,ns + if (m.le.this%nown) then + if (this%flag(m).eq.PDC_IS_DEAD) cycle + end if + k=cell_of(this%y(:,midx(m)),gl,hcell,nc) + nxt(m)=head(k); head(k)=m + end do + if (allocated(this%cptr)) deallocate(this%cptr) + if (allocated(this%clst)) deallocate(this%clst) + allocate(this%cptr(this%nown+1)) + do pass=1,2 + do i=1,this%nown + cnt=0 + if (this%flag(i).eq.PDC_IS_DEAD) then + if (pass.eq.1) this%cptr(i+1)=0 + cycle + end if + ic=min(nc(1),max(1,int((this%y(1,i)-gl(1))/hcell(1))+1)) + jc=min(nc(2),max(1,int((this%y(2,i)-gl(2))/hcell(2))+1)) + kc=min(nc(3),max(1,int((this%y(3,i)-gl(3))/hcell(3))+1)) + do c3=max(1,kc-1),min(nc(3),kc+1); do c2=max(1,jc-1),min(nc(2),jc+1); do c1=max(1,ic-1),min(nc(1),ic+1) + m=head(c1+nc(1)*(c2-1)+nc(1)*nc(2)*(c3-1)) + do while (m.gt.0) + jj=midx(m) + if (jj.ne.i) then + if (sum((this%y(:,jj)-this%y(:,i))**2).le.rbuild**2) then + cnt=cnt+1 + if (pass.eq.2) this%clst(this%cptr(i)+cnt-1)=jj + end if + end if + m=nxt(m) + end do + end do; end do; end do + if (pass.eq.1) this%cptr(i+1)=cnt ! provisional count + end do + if (pass.eq.1) then + this%cptr(1)=1 + do i=1,this%nown + this%cptr(i+1)=this%cptr(i)+this%cptr(i+1) + end do + allocate(this%clst(max(this%cptr(this%nown+1)-1,1))) + end if + end do + deallocate(midx,head,nxt) + end block candidates + + ! Snapshot positions for the drift trigger + if (allocated(this%ylast)) deallocate(this%ylast) + allocate(this%ylast(3,max(this%nown,1))) + this%ylast(:,1:this%nown)=this%y(:,1:this%nown) + deallocate(allb) + end block rebuild + + contains + + !> Any owned node within r of position p? (binned +/-1 cell sweep) + function near_owned(p,r,gl,h,nc,head,nxt) result(hit) + real(WP), dimension(3), intent(in) :: p,gl,h + real(WP), intent(in) :: r + integer, dimension(3), intent(in) :: nc + integer, intent(in) :: head(:),nxt(:) + logical :: hit + integer :: c(3),d,c1,c2,c3,m + hit=.false. + do d=1,3 + c(d)=min(nc(d),max(1,int((p(d)-gl(d))/h(d))+1)) + end do + do c3=max(1,c(3)-1),min(nc(3),c(3)+1); do c2=max(1,c(2)-1),min(nc(2),c(2)+1); do c1=max(1,c(1)-1),min(nc(1),c(1)+1) + m=head(c1+nc(1)*(c2-1)+nc(1)*nc(2)*(c3-1)) + do while (m.gt.0) + if (sum((this%y(:,m)-p)**2).le.r**2) then + hit=.true. + return + end if + m=nxt(m) + end do + end do; end do; end do + end function near_owned + + end subroutine contact_broadphase + + !> Contact narrow phase: soft-sphere walls + particle-particle over the + !> candidate CSR, gather-only (soft-sphere penalty ported from amrlpt's collision model; + !> IB contact arrives with the coupling layer). Adds force/volume into owned + !> f. Walls use e_w with d_eff = 0.5*contact_dist and m_eff = m1; pairs use + !> e_n with d_eff = contact_dist and m_eff = 0.5*m1 (m1 = rho*vol(i), + !> matching amrpd's uniform rho*dV on a uniform lattice). + subroutine contact_narrow(this,dt) + use mathtools, only: Pi + implicit none + class(pdsolver), intent(inout) :: this + real(WP), intent(in) :: dt + real(WP) :: tau,k_n,eta_n,k_w,eta_w,d_eff_w,m1 + real(WP), dimension(3) :: r1,v1,floc,r2 + real(WP), dimension(3), parameter :: vzero=[0.0_WP,0.0_WP,0.0_WP] + integer :: i,k,j + if (this%contact_dist.le.0.0_WP.or.dt.le.0.0_WP) return + if (this%e_n.le.0.0_WP.or.this%e_w.le.0.0_WP) return + if (this%tau_col.gt.0.0_WP) then + tau=this%tau_col + else + tau=5.0_WP*dt + end if + k_n =(Pi**2+log(this%e_n)**2)/tau**2 + eta_n=-2.0_WP*log(this%e_n)/tau + k_w =(Pi**2+log(this%e_w)**2)/tau**2 + eta_w=-2.0_WP*log(this%e_w)/tau + d_eff_w=0.5_WP*this%contact_dist + do i=1,this%nown + if (this%flag(i).eq.PDC_IS_DEAD) cycle + m1=this%rho*this%vol(i) + r1=this%y(:,i); v1=this%v(:,i) + floc=0.0_WP + ! Wall collisions on faces flagged as walls (virtual partner on the + ! wall directly normal to the node) + if (this%lo_bc(1).eq.1) then; r2=[this%dom_lo(1),r1(2),r1(3)]; call apply_col(k_w,eta_w,d_eff_w,m1,r2,vzero); end if + if (this%hi_bc(1).eq.1) then; r2=[this%dom_hi(1),r1(2),r1(3)]; call apply_col(k_w,eta_w,d_eff_w,m1,r2,vzero); end if + if (this%lo_bc(2).eq.1) then; r2=[r1(1),this%dom_lo(2),r1(3)]; call apply_col(k_w,eta_w,d_eff_w,m1,r2,vzero); end if + if (this%hi_bc(2).eq.1) then; r2=[r1(1),this%dom_hi(2),r1(3)]; call apply_col(k_w,eta_w,d_eff_w,m1,r2,vzero); end if + if (this%lo_bc(3).eq.1) then; r2=[r1(1),r1(2),this%dom_lo(3)]; call apply_col(k_w,eta_w,d_eff_w,m1,r2,vzero); end if + if (this%hi_bc(3).eq.1) then; r2=[r1(1),r1(2),this%dom_hi(3)]; call apply_col(k_w,eta_w,d_eff_w,m1,r2,vzero); end if + ! Particle-particle via the candidate CSR + do k=this%cptr(i),this%cptr(i+1)-1 + j=this%clst(k) + call apply_col(k_n,eta_n,this%contact_dist,0.5_WP*m1,this%y(:,j),this%v(:,j)) + end do + ! Accumulate as force/volume (matches bond force units) + this%f(:,i)=this%f(:,i)+floc/this%vol(i) + end do + + contains + + !> Soft-sphere normal force from virtual partner (r2_in, v2_in) onto i. + !> Host-associated r1, v1, dt, floc. + subroutine apply_col(kk,ee,d_eff,m_eff,r2_in,v2_in) + real(WP), intent(in) :: kk,ee,d_eff,m_eff + real(WP), dimension(3), intent(in) :: r2_in,v2_in + real(WP) :: d12,rnv,r_influ,delta_n + real(WP), dimension(3) :: n12,v12,f_n + d12=norm2(r2_in-r1) + if (d12.lt.10.0_WP*epsilon(d12)) return ! self-overlap guard + n12=(r2_in-r1)/d12 + v12=v1-v2_in + rnv=dot_product(v12,n12) + r_influ=min(abs(rnv)*dt,0.2_WP*d_eff) + delta_n=min(d_eff+r_influ-d12,this%clip_col*d_eff) + if (delta_n.le.0.0_WP) return + f_n=(-m_eff*kk*delta_n-m_eff*ee*rnv)*n12 + floc=floc+f_n + end subroutine apply_col + + end subroutine contact_narrow + + !> Binding CFL: elastic wave + scaled convective (limits 0.5 / 0.1) + subroutine get_cfl(this,dt,cfl) + use parallel, only: comm,MPI_REAL_WP + use mpi_f08, only: MPI_ALLREDUCE,MPI_MAX,MPI_IN_PLACE + implicit none + class(pdsolver), intent(inout) :: this + real(WP), intent(in) :: dt + real(WP), intent(out) :: cfl + real(WP), parameter :: CFL_scale_conv=5.0_WP + real(WP) :: K_bulk,mu_shear,c_p,dp_inv,vmax + integer :: i,ierr + K_bulk =this%elastic_modulus/(3.0_WP*(1.0_WP-2.0_WP*this%poisson_ratio)) + mu_shear=this%elastic_modulus/(2.0_WP*(1.0_WP+this%poisson_ratio)) + c_p =sqrt((K_bulk+4.0_WP*mu_shear/3.0_WP)/this%rho) + dp_inv =1.0_WP/this%dV**(1.0_WP/3.0_WP) + this%CFLe=c_p*dp_inv*dt + this%CFLp=0.0_WP + do i=1,this%nown + if (this%flag(i).eq.PDC_IS_DEAD) cycle + vmax=max(abs(this%v(1,i)),abs(this%v(2,i)),abs(this%v(3,i))) + this%CFLp=max(this%CFLp,vmax*dp_inv) + end do + call MPI_ALLREDUCE(MPI_IN_PLACE,this%CFLp,1,MPI_REAL_WP,MPI_MAX,comm,ierr) + this%CFLp=this%CFLp*dt + cfl=max(CFL_scale_conv*this%CFLp,this%CFLe) + end subroutine get_cfl + + !> Global counts, velocity max, and timer reduction (+reset). Collective. + subroutine get_info(this) + use parallel, only: comm,MPI_REAL_WP + use mpi_f08, only: MPI_ALLREDUCE,MPI_MAX,MPI_MIN,MPI_SUM,MPI_IN_PLACE,MPI_INTEGER8 + implicit none + class(pdsolver), intent(inout) :: this + integer :: i,ierr + integer(I8) :: np_loc + real(WP), dimension(3) :: vmin,vmax + np_loc=0_I8 + vmin=huge(1.0_WP); vmax=-huge(1.0_WP) + this%EPmax=0.0_WP + do i=1,this%nown + if (this%flag(i).eq.PDC_IS_DEAD) cycle + np_loc=np_loc+1_I8 + vmin=min(vmin,this%v(:,i)); vmax=max(vmax,this%v(:,i)) + this%EPmax=max(this%EPmax,this%lam_p(i)) + end do + this%np=np_loc + call MPI_ALLREDUCE(MPI_IN_PLACE,this%np,1,MPI_INTEGER8,MPI_SUM,comm,ierr) + call MPI_ALLREDUCE(MPI_IN_PLACE,this%EPmax,1,MPI_REAL_WP,MPI_MAX,comm,ierr) + call MPI_ALLREDUCE(MPI_IN_PLACE,vmin,3,MPI_REAL_WP,MPI_MIN,comm,ierr) + call MPI_ALLREDUCE(MPI_IN_PLACE,vmax,3,MPI_REAL_WP,MPI_MAX,comm,ierr) + if (this%np.eq.0_I8) then + vmin=0.0_WP; vmax=0.0_WP + end if + this%Umin=vmin(1); this%Umax=vmax(1) + this%Vmin=vmin(2); this%Vmax=vmax(2) + this%Wmin=vmin(3); this%Wmax=vmax(3) + ! Broken half-entry census (each broken bond counts twice, except + ! self-image bonds which have a single half-entry) + count_broken: block + integer(I8) :: nb_loc + integer :: e,i2,j2 + ! Half-entry count (internal) and EXACT broken-bond census: each bond + ! is counted at exactly one of its two half-entries -- the one whose + ! node gid is lower (ties = self-image bonds, counted at the + ! positive-offset image so each appears once) + nb_loc=0_I8; this%nb_broken=0_I8 + do i2=1,this%nown + do e=this%ptr(i2),this%ptr(i2+1)-1 + if (this%dmg(e).eq.0_1) cycle + nb_loc=nb_loc+1_I8 + j2=this%lst(e) + if (this%gid(i2).lt.this%gid(j2)) then + this%nb_broken=this%nb_broken+1_I8 + else if (this%gid(i2).eq.this%gid(j2)) then + if (j2.gt.this%nown) then + if (shift_positive(this%halo%shift(:,j2-this%nown))) this%nb_broken=this%nb_broken+1_I8 + end if + end if + end do + end do + this%nbroken=nb_loc + call MPI_ALLREDUCE(MPI_IN_PLACE,this%nbroken,1,MPI_INTEGER8,MPI_SUM,comm,ierr) + call MPI_ALLREDUCE(MPI_IN_PLACE,this%nb_broken,1,MPI_INTEGER8,MPI_SUM,comm,ierr) + end block count_broken + ! Timers: max (and min for the compute-heavy phases) across ranks, then reset + call MPI_ALLREDUCE(this%wt_kick, this%wtmax_kick, 1,MPI_REAL_WP,MPI_MAX,comm,ierr) + call MPI_ALLREDUCE(this%wt_halo, this%wtmax_halo, 1,MPI_REAL_WP,MPI_MAX,comm,ierr) + call MPI_ALLREDUCE(this%wt_dil, this%wtmax_dil, 1,MPI_REAL_WP,MPI_MAX,comm,ierr) + call MPI_ALLREDUCE(this%wt_dil, this%wtmin_dil, 1,MPI_REAL_WP,MPI_MIN,comm,ierr) + call MPI_ALLREDUCE(this%wt_force, this%wtmax_force, 1,MPI_REAL_WP,MPI_MAX,comm,ierr) + call MPI_ALLREDUCE(this%wt_force, this%wtmin_force, 1,MPI_REAL_WP,MPI_MIN,comm,ierr) + call MPI_ALLREDUCE(this%wt_reduce,this%wtmax_reduce,1,MPI_REAL_WP,MPI_MAX,comm,ierr) + call MPI_ALLREDUCE(this%wt_contact,this%wtmax_contact,1,MPI_REAL_WP,MPI_MAX,comm,ierr) + call MPI_ALLREDUCE(this%wt_broad, this%wtmax_broad, 1,MPI_REAL_WP,MPI_MAX,comm,ierr) + this%wt_kick=0.0_WP; this%wt_halo=0.0_WP; this%wt_dil=0.0_WP; this%wt_force=0.0_WP; this%wt_reduce=0.0_WP + this%wt_contact=0.0_WP; this%wt_broad=0.0_WP + ! Contact-service size census (visibility into the fragmentation-driven + ! degradation mode of the static graph partition) + contact_census: block + integer(I8) :: tmp + this%nchalo_glob=int(this%nchalo,I8) + call MPI_ALLREDUCE(MPI_IN_PLACE,this%nchalo_glob,1,MPI_INTEGER8,MPI_SUM,comm,ierr) + tmp=0_I8 + if (allocated(this%cptr)) tmp=int(this%cptr(this%nown+1)-1,I8) + this%ncand_glob=tmp + call MPI_ALLREDUCE(MPI_IN_PLACE,this%ncand_glob,1,MPI_INTEGER8,MPI_SUM,comm,ierr) + end block contact_census + end subroutine get_info + + !> Release all storage + subroutine finalize(this) + implicit none + class(pdsolver), intent(inout) :: this + if (allocated(this%gid)) deallocate(this%gid) + if (allocated(this%x0)) deallocate(this%x0) + if (allocated(this%y)) deallocate(this%y) + if (allocated(this%v)) deallocate(this%v) + if (allocated(this%f)) deallocate(this%f) + if (allocated(this%ff)) deallocate(this%ff) + if (allocated(this%vol)) deallocate(this%vol) + if (allocated(this%mw)) deallocate(this%mw) + if (allocated(this%theta)) deallocate(this%theta) + if (allocated(this%damage))deallocate(this%damage) + if (allocated(this%lam_p)) deallocate(this%lam_p) + if (allocated(this%alive)) deallocate(this%alive) + if (allocated(this%flag)) deallocate(this%flag) + if (allocated(this%ptr)) deallocate(this%ptr) + if (allocated(this%lst)) deallocate(this%lst) + if (allocated(this%dmg)) deallocate(this%dmg) + if (allocated(this%e_v)) deallocate(this%e_v) + if (allocated(this%td2)) deallocate(this%td2) + if (allocated(this%td2a)) deallocate(this%td2a) + if (allocated(this%cptr)) deallocate(this%cptr) + if (allocated(this%clst)) deallocate(this%clst) + if (allocated(this%ylast)) deallocate(this%ylast) + if (allocated(this%rextra_tmp)) deallocate(this%rextra_tmp) + call this%ohash%finalize() + call this%dir%finalize() + call this%halo%finalize() + call this%chalo%finalize() + this%nown=0; this%nhalo=0; this%ntot=0; this%nchalo=0 + end subroutine finalize + + + !> Mirror synchronization (the coupling bridge). Collective, once per FLUID + !> step. The caller walks its face particles (AMReX container on the + !> fluid decomposition) and passes per particle: gid, core owner rank (read + !> from the face particle's repurposed flag tag), and the F_fluid it interpolated + !> from the grid. This routine routes F_fluid to the owning nodes (held in + !> ff across the subsequent PD subcycles) and replies with each node's + !> current (pos, vel, damage, alive), returned aligned with the caller's + !> input order for direct write-back into the face particles. + subroutine exchange(this,nm,mgid,mowner,mff,mpos,mvel,mdmg,malive) + use parallel, only: comm,nproc,MPI_REAL_WP + use messager, only: die + use mpi_f08 + implicit none + class(pdsolver), intent(inout) :: this + integer, intent(in) :: nm + integer(I8), intent(in) :: mgid(:) + integer, intent(in) :: mowner(:) + real(WP), intent(in) :: mff(:,:) + real(WP), intent(out) :: mpos(:,:),mvel(:,:) + real(WP), intent(out) :: mdmg(:),malive(:) + integer, dimension(0:nproc-1) :: sc,rc,sd,rd + integer, dimension(0:nproc-1) :: scw,rcw,sdw,rdw + integer, allocatable :: pos(:),qpos(:) + integer(I8), allocatable :: sg(:),rg(:) + real(WP), allocatable :: sff(:,:),rff(:,:),srep(:,:),rrep(:,:) + integer :: i,r,nr,idx,ierr + + ! Count and pack by owner, remembering each entry's packed slot + sc=0 + do i=1,nm + sc(mowner(i))=sc(mowner(i))+1 + end do + call MPI_ALLTOALL(sc,1,MPI_INTEGER,rc,1,MPI_INTEGER,comm,ierr) + sd(0)=0; rd(0)=0 + do r=1,nproc-1 + sd(r)=sd(r-1)+sc(r-1); rd(r)=rd(r-1)+rc(r-1) + end do + allocate(pos(0:nproc-1),qpos(max(nm,1))) + allocate(sg(max(nm,1)),sff(3,max(nm,1))) + pos=sd + do i=1,nm + r=mowner(i); pos(r)=pos(r)+1 + sg(pos(r))=mgid(i); sff(:,pos(r))=mff(:,i); qpos(i)=pos(r) + end do + nr=sum(rc) + allocate(rg(max(nr,1)),rff(3,max(nr,1))) + call MPI_ALLTOALLV(sg,sc,sd,MPI_INTEGER8,rg,rc,rd,MPI_INTEGER8,comm,ierr) + scw=3*sc; sdw=3*sd; rcw=3*rc; rdw=3*rd + call MPI_ALLTOALLV(sff,scw,sdw,MPI_REAL_WP,rff,rcw,rdw,MPI_REAL_WP,comm,ierr) + + ! Owner side: ingest F_fluid, build the state reply in arrival order + allocate(rrep(8,max(nr,1))) + do i=1,nr + idx=this%ohash%lookup(rg(i)) + if (idx.lt.1) call die('[pdsolver exchange] face gid not owned by tagged rank') + this%ff(:,idx)=rff(:,i) + rrep(1:3,i)=this%y(:,idx) + rrep(4:6,i)=this%v(:,idx) + rrep(7,i) =this%damage(idx) + rrep(8,i) =this%alive(idx) + end do + + ! Reply along the reverse route; unpack to the caller's original order + allocate(srep(8,max(nm,1))) + scw=8*rc; sdw=8*rd; rcw=8*sc; rdw=8*sd + call MPI_ALLTOALLV(rrep,scw,sdw,MPI_REAL_WP,srep,rcw,rdw,MPI_REAL_WP,comm,ierr) + do i=1,nm + mpos(:,i) =srep(1:3,qpos(i)) + mvel(:,i) =srep(4:6,qpos(i)) + mdmg(i) =srep(7,qpos(i)) + malive(i) =srep(8,qpos(i)) + end do + deallocate(pos,qpos,sg,sff,rg,rff,rrep,srep) + end subroutine exchange + + + !> Owner-rank lookup for arbitrary node gids via the persistent directory. + !> Collective. Drivers use it to re-stamp face routing tags after restart. + subroutine query_owners(this,n,gids,owners) + implicit none + class(pdsolver), intent(inout) :: this + integer, intent(in) :: n + integer(I8), intent(in) :: gids(:) + integer, intent(out) :: owners(:) + call this%dir%query(n,gids,owners) + end subroutine query_owners + + !> Checkpoint the core under /: per-rank stream files + root + !> header. Records are GID-SPACE (no local indices, no partition info) -- + !> nodes: (gid, flag, x0, y, v, f, vol, damage, td2, lam_p); half-entries: + !> (node_gid, nbr_gid, image_key, dmg, e_v), the image key reconstructed + !> from the halo slot's shift. Rank-count portable on read. Format v2 + !> (v1 = pre-hardening, no lam_p record; read_state accepts both). + subroutine write_state(this,dirname) + use parallel, only: rank,nproc,amRoot + use messager, only: die + use string, only: str_medium + implicit none + class(pdsolver), intent(inout) :: this + character(len=*), intent(in) :: dirname + character(len=str_medium) :: fname + integer :: iunit,ios,i,e,j,nhe + integer, allocatable :: hkey(:) + integer(I8), allocatable :: hnode(:),hnbr(:) + ! Half-entries in gid space + nhe=this%ptr(this%nown+1)-1 + allocate(hnode(max(nhe,1)),hnbr(max(nhe,1)),hkey(max(nhe,1))) + do i=1,this%nown + do e=this%ptr(i),this%ptr(i+1)-1 + j=this%lst(e) + hnode(e)=this%gid(i) + hnbr(e) =this%gid(j) + if (j.le.this%nown) then + hkey(e)=PDHALO_KEY0 + else + hkey(e)=key_of_shift(this%halo%shift(:,j-this%nown),this%Ldom) + end if + end do + end do + ! Per-rank stream file + ! All solid state lives under /pd/ (root creates it) + make_dir: block + use parallel, only: comm + use mpi_f08, only: MPI_BARRIER + integer :: ierr2 + if (amRoot) call execute_command_line('mkdir -p '//trim(dirname)//'/pd') + call MPI_BARRIER(comm,ierr2) + end block make_dir + write(fname,'(a,"/pd/pd_",i7.7,".bin")') trim(dirname),rank + open(newunit=iunit,file=trim(fname),form='unformatted',access='stream',status='replace',iostat=ios) + if (ios.ne.0) call die('[pdsolver write_state] cannot open '//trim(fname)) + write(iunit) this%nown,nhe + write(iunit) this%gid(1:this%nown) + write(iunit) this%flag(1:this%nown) + write(iunit) this%x0(:,1:this%nown) + write(iunit) this%y(:,1:this%nown) + write(iunit) this%v(:,1:this%nown) + write(iunit) this%f(:,1:this%nown) + write(iunit) this%vol(1:this%nown) + write(iunit) this%damage(1:this%nown) + write(iunit) this%td2(1:this%nown) + write(iunit) this%lam_p(1:this%nown) + write(iunit) hnode(1:nhe) + write(iunit) hnbr(1:nhe) + write(iunit) hkey(1:nhe) + write(iunit) this%dmg(1:nhe) + write(iunit) this%e_v(1:nhe) + close(iunit) + deallocate(hnode,hnbr,hkey) + ! Root header (file count for portable round-robin reads) + if (amRoot) then + open(newunit=iunit,file=trim(dirname)//'/pd/header',form='formatted',status='replace',iostat=ios) + if (ios.ne.0) call die('[pdsolver write_state] cannot open header') + write(iunit,'(a)') 'pdsolver checkpoint v2' + write(iunit,'(i0)') nproc + close(iunit) + end if + contains + !> Reconstruct the packed image key from a slot shift vector + pure function key_of_shift(s,L) result(k) + implicit none + real(WP), dimension(3), intent(in) :: s,L + integer :: k,n1,n2,n3 + n1=0; n2=0; n3=0 + if (L(1).gt.0.0_WP) n1=nint(s(1)/L(1)) + if (L(2).gt.0.0_WP) n2=nint(s(2)/L(2)) + if (L(3).gt.0.0_WP) n3=nint(s(3)/L(3)) + k=(n1+128)+(n2+128)*256+(n3+128)*65536 + end function key_of_shift + end subroutine write_state + + !> Restore the core from a checkpoint written by write_state. Collective; + !> rank-count portable: files read round-robin, nodes re-partitioned by + !> Morton order of the reference configuration, half-entries routed to + !> their owners, CSR/halo rebuilt via assemble with the loaded per-entry + !> state. The caller must configure the solver (initialize + material/ + !> contact/plastic component assignments) BEFORE calling this. + subroutine read_state(this,dirname) + use parallel, only: comm,rank,nproc,MPI_REAL_WP + use messager, only: die + use string, only: str_medium + use mpi_f08 + implicit none + class(pdsolver), intent(inout) :: this + character(len=*), intent(in) :: dirname + character(len=str_medium) :: fname,line + integer :: nfiles,iunit,ios,f,i,r,ierr,iver + integer :: nn,nhe,nf,nhf + integer(I8), allocatable :: gid(:),hnode(:),hnbr(:) + integer, allocatable :: flag(:),hkey(:),owner(:) + real(WP), allocatable :: x0(:,:),yy(:,:),vv(:,:),ffb(:,:),vol(:),dmgn(:),td2n(:),lamn(:) + real(WP), allocatable :: hev(:) + integer(1), allocatable :: hdmg(:) + + ! Resolve derived configuration (restart-safe shared path) + call this%derive_config() + + ! Header: number of files written + format version (v1 = no lam_p record) + nfiles=0; iver=1 + if (rank.eq.0) then + open(newunit=iunit,file=trim(dirname)//'/pd/header',form='formatted',status='old',iostat=ios) + if (ios.ne.0) call die('[pdsolver read_state] no pd/header under '//trim(dirname)) + read(iunit,'(a)') line + if (index(line,'v2').gt.0) iver=2 + read(iunit,*) nfiles + close(iunit) + end if + call MPI_BCAST(nfiles,1,MPI_INTEGER,0,comm,ierr) + call MPI_BCAST(iver,1,MPI_INTEGER,0,comm,ierr) + + ! Read my round-robin share of the files, concatenating records + nn=0; nhe=0 + do f=rank,nfiles-1,nproc + write(fname,'(a,"/pd/pd_",i7.7,".bin")') trim(dirname),f + open(newunit=iunit,file=trim(fname),form='unformatted',access='stream',status='old',iostat=ios) + if (ios.ne.0) call die('[pdsolver read_state] cannot open '//trim(fname)) + read(iunit) nf,nhf + call grow_i8(gid,nn,nf); call grow_i4(flag,nn,nf) + call grow_r2(x0,nn,nf); call grow_r2(yy,nn,nf) + call grow_r2(vv,nn,nf); call grow_r2(ffb,nn,nf) + call grow_r1(vol,nn,nf); call grow_r1(dmgn,nn,nf); call grow_r1(td2n,nn,nf) + call grow_r1(lamn,nn,nf) + read(iunit) gid(nn+1:nn+nf) + read(iunit) flag(nn+1:nn+nf) + read(iunit) x0(:,nn+1:nn+nf) + read(iunit) yy(:,nn+1:nn+nf) + read(iunit) vv(:,nn+1:nn+nf) + read(iunit) ffb(:,nn+1:nn+nf) + read(iunit) vol(nn+1:nn+nf) + read(iunit) dmgn(nn+1:nn+nf) + read(iunit) td2n(nn+1:nn+nf) + if (iver.ge.2) then + read(iunit) lamn(nn+1:nn+nf) + else + lamn(nn+1:nn+nf)=0.0_WP + end if + call grow_i8(hnode,nhe,nhf); call grow_i8(hnbr,nhe,nhf) + call grow_i4(hkey,nhe,nhf); call grow_i1(hdmg,nhe,nhf); call grow_r1(hev,nhe,nhf) + read(iunit) hnode(nhe+1:nhe+nhf) + read(iunit) hnbr(nhe+1:nhe+nhf) + read(iunit) hkey(nhe+1:nhe+nhf) + read(iunit) hdmg(nhe+1:nhe+nhf) + read(iunit) hev(nhe+1:nhe+nhf) + close(iunit) + nn=nn+nf; nhe=nhe+nhf + end do + if (.not.allocated(gid)) then ! ranks with no files still join collectives + allocate(gid(1),flag(1),x0(3,1),yy(3,1),vv(3,1),ffb(3,1),vol(1),dmgn(1),td2n(1),lamn(1)) + allocate(hnode(1),hnbr(1),hkey(1),hdmg(1),hev(1)) + end if + + ! Re-partition nodes by Morton order of the REFERENCE configuration and + ! route the full records (pd_partition routes the set_nodes payload; the + ! remaining fields ride a second, identically-ordered exchange) + repartition: block + integer(I8), allocatable :: rgid(:) + real(WP), allocatable :: rx0(:,:),rvv(:,:),rvol(:),extra(:,:) + integer, allocatable :: rflag(:) + integer, dimension(0:nproc-1) :: sc,rc,sd,rd,scw,rcw,sdw,rdw + integer, allocatable :: pos(:) + integer :: nr + allocate(owner(max(nn,1))) + call pd_partition(nn,gid,x0,vv,flag,vol,owner,nr,rgid,rx0,rvv,rflag,rvol) + ! Second exchange: (y, f, damage, td2) = 8 reals, packed in the same + ! per-destination input order as pd_partition's own packing + sc=0 + do i=1,nn + sc(owner(i))=sc(owner(i))+1 + end do + call MPI_ALLTOALL(sc,1,MPI_INTEGER,rc,1,MPI_INTEGER,comm,ierr) + sd(0)=0; rd(0)=0 + do r=1,nproc-1 + sd(r)=sd(r-1)+sc(r-1); rd(r)=rd(r-1)+rc(r-1) + end do + allocate(pos(0:nproc-1),extra(9,max(nn,1)),this%rextra_tmp(9,max(nr,1))) + pos=sd + do i=1,nn + r=owner(i); pos(r)=pos(r)+1 + extra(1:3,pos(r))=yy(:,i) + extra(4:6,pos(r))=ffb(:,i) + extra(7,pos(r)) =dmgn(i) + extra(8,pos(r)) =td2n(i) + extra(9,pos(r)) =lamn(i) + end do + scw=9*sc; sdw=9*sd; rcw=9*rc; rdw=9*rd + call MPI_ALLTOALLV(extra,scw,sdw,MPI_REAL_WP,this%rextra_tmp,rcw,rdw,MPI_REAL_WP,comm,ierr) + ! Load the routed nodes, then overlay the restart-only fields + call this%set_nodes(nr,rgid,rx0,rvv,rflag,rvol) + do i=1,nr + this%y(:,i) =this%rextra_tmp(1:3,i) + this%f(:,i) =this%rextra_tmp(4:6,i) + this%damage(i)=this%rextra_tmp(7,i) + end do + deallocate(pos,extra,rgid,rx0,rvv,rflag,rvol) + end block repartition + + ! Register the directory over the new partition, route half-entries to + ! their owners (state travels along), and rebuild CSR/halo/reference + route_and_assemble: block + integer(I8), allocatable :: rnode(:),rnbr(:) + integer, allocatable :: rkey(:),howner(:) + real(WP), allocatable :: rev(:) + integer(1), allocatable :: rdmg(:) + integer, dimension(0:nproc-1) :: sc,rc,sd,rd + integer, allocatable :: pos(:) + integer(I8), allocatable :: s8(:) + integer, allocatable :: s4(:) + real(WP), allocatable :: sr(:) + integer(1), allocatable :: s1(:) + integer :: rn,h + call this%dir%finalize() + call this%dir%register(this%nown,this%gid(1:this%nown)) + allocate(howner(max(nhe,1))) + call this%dir%query(nhe,hnode,howner) + sc=0 + do i=1,nhe + sc(howner(i))=sc(howner(i))+1 + end do + call MPI_ALLTOALL(sc,1,MPI_INTEGER,rc,1,MPI_INTEGER,comm,ierr) + sd(0)=0; rd(0)=0 + do r=1,nproc-1 + sd(r)=sd(r-1)+sc(r-1); rd(r)=rd(r-1)+rc(r-1) + end do + rn=sum(rc) + allocate(rnode(max(rn,1)),rnbr(max(rn,1)),rkey(max(rn,1)),rev(max(rn,1)),rdmg(max(rn,1))) + allocate(pos(0:nproc-1),s8(max(nhe,1)),s4(max(nhe,1)),sr(max(nhe,1)),s1(max(nhe,1))) + pos=sd + do i=1,nhe + h=howner(i); pos(h)=pos(h)+1; s8(pos(h))=hnode(i) + end do + call MPI_ALLTOALLV(s8,sc,sd,MPI_INTEGER8,rnode,rc,rd,MPI_INTEGER8,comm,ierr) + pos=sd + do i=1,nhe + h=howner(i); pos(h)=pos(h)+1; s8(pos(h))=hnbr(i) + end do + call MPI_ALLTOALLV(s8,sc,sd,MPI_INTEGER8,rnbr,rc,rd,MPI_INTEGER8,comm,ierr) + pos=sd + do i=1,nhe + h=howner(i); pos(h)=pos(h)+1; s4(pos(h))=hkey(i) + end do + call MPI_ALLTOALLV(s4,sc,sd,MPI_INTEGER,rkey,rc,rd,MPI_INTEGER,comm,ierr) + pos=sd + do i=1,nhe + h=howner(i); pos(h)=pos(h)+1; sr(pos(h))=hev(i) + end do + call MPI_ALLTOALLV(sr,sc,sd,MPI_REAL_WP,rev,rc,rd,MPI_REAL_WP,comm,ierr) + pos=sd + do i=1,nhe + h=howner(i); pos(h)=pos(h)+1; s1(pos(h))=hdmg(i) + end do + call MPI_ALLTOALLV(s1,sc,sd,MPI_INTEGER1,rdmg,rc,rd,MPI_INTEGER1,comm,ierr) + call this%assemble(rn,rnode,rnbr,rkey,rev,rdmg) + deallocate(rnode,rnbr,rkey,rev,rdmg,pos,s8,s4,sr,s1,howner) + end block route_and_assemble + + ! Overlay td2/lam_p (assemble/set_nodes zero them) and life status + do i=1,this%nown + this%td2(i) =this%rextra_tmp(8,i) + this%lam_p(i)=this%rextra_tmp(9,i) + if (this%flag(i).eq.PDC_IS_DEAD) this%alive(i)=0.0_WP + end do + deallocate(this%rextra_tmp) + call this%halo%update1(this%alive) + deallocate(gid,flag,x0,yy,vv,ffb,vol,dmgn,td2n,lamn,hnode,hnbr,hkey,hdmg,hev,owner) + + contains + + subroutine grow_i8(a,n,add) + integer(I8), allocatable, intent(inout) :: a(:) + integer, intent(in) :: n,add + integer(I8), allocatable :: t(:) + allocate(t(n+add)); if (n.gt.0) t(1:n)=a(1:n) + call move_alloc(t,a) + end subroutine grow_i8 + subroutine grow_i4(a,n,add) + integer, allocatable, intent(inout) :: a(:) + integer, intent(in) :: n,add + integer, allocatable :: t(:) + allocate(t(n+add)); if (n.gt.0) t(1:n)=a(1:n) + call move_alloc(t,a) + end subroutine grow_i4 + subroutine grow_i1(a,n,add) + integer(1), allocatable, intent(inout) :: a(:) + integer, intent(in) :: n,add + integer(1), allocatable :: t(:) + allocate(t(n+add)); if (n.gt.0) t(1:n)=a(1:n) + call move_alloc(t,a) + end subroutine grow_i1 + subroutine grow_r1(a,n,add) + real(WP), allocatable, intent(inout) :: a(:) + integer, intent(in) :: n,add + real(WP), allocatable :: t(:) + allocate(t(n+add)); if (n.gt.0) t(1:n)=a(1:n) + call move_alloc(t,a) + end subroutine grow_r1 + subroutine grow_r2(a,n,add) + real(WP), allocatable, intent(inout) :: a(:,:) + integer, intent(in) :: n,add + real(WP), allocatable :: t(:,:) + allocate(t(3,n+add)); if (n.gt.0) t(:,1:n)=a(:,1:n) + call move_alloc(t,a) + end subroutine grow_r2 + + end subroutine read_state + + + !> Static load-balancing partition of the reference configuration. + !> Collective; called once at handoff, BEFORE set_nodes. Nodes are ordered + !> by the Morton key of their reference position and split into equal-count + !> contiguous ranges: on a uniform lattice family size is ~constant, so node + !> count ~ bond work (a family-weighted split can substitute later), and + !> bond work is motion-invariant -- this balance holds for the entire run + !> regardless of deformation or flight, using ALL ranks even when the solid + !> occupies a corner of the fluid domain. + !> Inputs: this rank's extracted nodes (any distribution). Outputs: the + !> nodes assigned to this rank, plus each INPUT node's assigned owner (for + !> stamping the face particles' routing tags). + subroutine pd_partition(n_in,gid_in,pos_in,vel_in,flag_in,vol_in,owner_out, & + & n_out,gid_out,pos_out,vel_out,flag_out,vol_out) + use parallel, only: comm,rank,nproc,amRoot,MPI_REAL_WP + use pdhalo_class, only: sort3_perm + use mpi_f08 + implicit none + integer, intent(in) :: n_in + integer(I8), intent(in) :: gid_in(:) + real(WP), intent(in) :: pos_in(:,:),vel_in(:,:) + integer, intent(in) :: flag_in(:) + real(WP), intent(in) :: vol_in(:) + integer, intent(out) :: owner_out(:) + integer, intent(out) :: n_out + integer(I8), allocatable, intent(out) :: gid_out(:) + real(WP), allocatable, intent(out) :: pos_out(:,:),vel_out(:,:),vol_out(:) + integer, allocatable, intent(out) :: flag_out(:) + real(WP), dimension(3) :: blo,bhi,inv + integer(I8), allocatable :: keys(:),splitters(:) + integer :: i,r,d,ierr + + ! Global reference bounds + blo=huge(1.0_WP); bhi=-huge(1.0_WP) + do i=1,n_in + blo=min(blo,pos_in(:,i)); bhi=max(bhi,pos_in(:,i)) + end do + call MPI_ALLREDUCE(MPI_IN_PLACE,blo,3,MPI_REAL_WP,MPI_MIN,comm,ierr) + call MPI_ALLREDUCE(MPI_IN_PLACE,bhi,3,MPI_REAL_WP,MPI_MAX,comm,ierr) + do d=1,3 + inv(d)=0.0_WP + if (bhi(d).gt.blo(d)) inv(d)=2097151.0_WP/(bhi(d)-blo(d)) + end do + + ! Morton keys of this rank's nodes + allocate(keys(max(n_in,1))) + do i=1,n_in + keys(i)=morton(pos_in(:,i),blo,inv) + end do + + ! Equal-weight splitters by SAMPLE SORT: each rank contributes a few + ! evenly-spaced samples of its locally sorted keys, weighted by its node + ! count -- root memory is O(nproc*S), not O(N_global), so this scales to + ! very large rank counts (the old gather-all-keys approach walled at + ! root memory and int32 N_global). + allocate(splitters(max(nproc-1,1))) + sample_splitters: block + integer, parameter :: S=16 + integer(I8), allocatable :: lsamp(:),gsamp(:),gw(:) + real(WP), allocatable :: w(:) + integer, allocatable :: perm(:),zk(:),scnt(:),sdis(:) + integer(I8) :: wtot,wcum,wtarg + integer :: ns,j,r2,gtot + ! Locally sort keys (permutation) and draw samples + allocate(perm(max(n_in,1)),zk(max(n_in,1))) + do i=1,n_in + perm(i)=i + end do + zk=0 + if (n_in.gt.1) call sort3_perm(zk,keys(1:n_in),zk,perm,1,n_in) + ns=min(S,n_in) + allocate(lsamp(max(ns,1))) + do j=1,ns + lsamp(j)=keys(perm(min(n_in,int((real(j,WP)-0.5_WP)*real(n_in,WP)/real(ns,WP))+1))) + end do + deallocate(perm,zk) + ! Gather samples (+ per-rank sample counts and node counts) on root + allocate(scnt(nproc),sdis(nproc)) + call MPI_GATHER(ns,1,MPI_INTEGER,scnt,1,MPI_INTEGER,0,comm,ierr) + gtot=0 + if (amRoot) then + sdis(1)=0 + do r2=2,nproc + sdis(r2)=sdis(r2-1)+scnt(r2-1) + end do + gtot=sum(scnt) + end if + allocate(gsamp(max(gtot,1)),gw(nproc)) + call MPI_GATHERV(lsamp,ns,MPI_INTEGER8,gsamp,scnt,sdis,MPI_INTEGER8,0,comm,ierr) + call MPI_GATHER(int(n_in,I8),1,MPI_INTEGER8,gw,1,MPI_INTEGER8,0,comm,ierr) + if (amRoot.and.gtot.gt.0) then + root_split: block + integer, allocatable :: p2(:),z2(:) + real(WP), allocatable :: sw(:) + ! Weight each sample by (its rank's node count)/(its rank's samples) + allocate(sw(gtot),p2(gtot),z2(gtot)) + do r2=1,nproc + do j=sdis(r2)+1,sdis(r2)+scnt(r2) + sw(j)=real(gw(r2),WP)/real(max(scnt(r2),1),WP) + end do + end do + do j=1,gtot + p2(j)=j + end do + z2=0 + call sort3_perm(z2,gsamp(1:gtot),z2,p2,1,gtot) + ! Single cumulative-weight pass placing all nproc-1 splitters + wtot=sum(gw) + wcum=0_I8; r2=1 + do j=1,gtot + if (r2.gt.nproc-1) exit + wcum=wcum+int(sw(p2(j)),I8) + do while (r2.le.nproc-1.and.wcum.ge.(int(r2,I8)*wtot)/int(nproc,I8)) + splitters(r2)=gsamp(p2(j)) + r2=r2+1 + end do + end do + do while (r2.le.nproc-1) + splitters(r2)=huge(1_I8) ! degenerate tail: empty upper buckets + r2=r2+1 + end do + deallocate(sw,p2,z2) + end block root_split + end if + deallocate(lsamp,gsamp,gw,scnt,sdis) + end block sample_splitters + if (nproc.gt.1) call MPI_BCAST(splitters,nproc-1,MPI_INTEGER8,0,comm,ierr) + + ! Assign owners: bucket = number of splitters <= key + do i=1,n_in + owner_out(i)=0 + do r=1,nproc-1 + if (keys(i).ge.splitters(r)) owner_out(i)=r + end do + end do + deallocate(keys,splitters) + + ! Route node payloads to their owners + route_nodes: block + integer, dimension(0:nproc-1) :: sc,rc,sd,rd,scw,rcw,sdw,rdw + integer, allocatable :: pos(:),sflag(:) + integer(I8), allocatable :: sgid(:) + real(WP), allocatable :: sdat(:,:),rdat(:,:) + sc=0 + do i=1,n_in + sc(owner_out(i))=sc(owner_out(i))+1 + end do + call MPI_ALLTOALL(sc,1,MPI_INTEGER,rc,1,MPI_INTEGER,comm,ierr) + sd(0)=0; rd(0)=0 + do r=1,nproc-1 + sd(r)=sd(r-1)+sc(r-1); rd(r)=rd(r-1)+rc(r-1) + end do + n_out=sum(rc) + allocate(pos(0:nproc-1),sgid(max(n_in,1)),sflag(max(n_in,1)),sdat(7,max(n_in,1))) + pos=sd + do i=1,n_in + r=owner_out(i); pos(r)=pos(r)+1 + sgid(pos(r))=gid_in(i) + sflag(pos(r))=flag_in(i) + sdat(1:3,pos(r))=pos_in(:,i) + sdat(4:6,pos(r))=vel_in(:,i) + sdat(7,pos(r)) =vol_in(i) + end do + allocate(gid_out(max(n_out,1)),flag_out(max(n_out,1)),rdat(7,max(n_out,1))) + allocate(pos_out(3,max(n_out,1)),vel_out(3,max(n_out,1)),vol_out(max(n_out,1))) + call MPI_ALLTOALLV(sgid,sc,sd,MPI_INTEGER8,gid_out,rc,rd,MPI_INTEGER8,comm,ierr) + call MPI_ALLTOALLV(sflag,sc,sd,MPI_INTEGER,flag_out,rc,rd,MPI_INTEGER,comm,ierr) + scw=7*sc; sdw=7*sd; rcw=7*rc; rdw=7*rd + call MPI_ALLTOALLV(sdat,scw,sdw,MPI_REAL_WP,rdat,rcw,rdw,MPI_REAL_WP,comm,ierr) + do i=1,n_out + pos_out(:,i)=rdat(1:3,i) + vel_out(:,i)=rdat(4:6,i) + vol_out(i) =rdat(7,i) + end do + deallocate(pos,sgid,sflag,sdat,rdat) + end block route_nodes + + contains + + !> 63-bit Morton key: 21 bits per dimension, bit-interleaved + pure function morton(p,lo,inv) result(key) + implicit none + real(WP), dimension(3), intent(in) :: p,lo,inv + integer(I8) :: key + integer(I8), dimension(3) :: ix + integer :: b,d + do d=1,3 + ix(d)=int(min(max((p(d)-lo(d))*inv(d),0.0_WP),2097151.0_WP),I8) + end do + key=0_I8 + do b=0,20 + do d=1,3 + if (btest(ix(d),b)) key=ibset(key,3*b+d-1) + end do + end do + end function morton + + end subroutine pd_partition + + + !> Bin geometry: cell size >= the search radius (so +/-1 cell sweeps are complete), + !> dims clamped to keep total cell count bounded on huge/degenerate extents + subroutine setup_bins(lo,hi,r,gl,h,nc) + real(WP), dimension(3), intent(in) :: lo,hi + real(WP), intent(in) :: r + real(WP), dimension(3), intent(out) :: gl,h + integer, dimension(3), intent(out) :: nc + integer :: d + do d=1,3 + gl(d)=lo(d)-0.5_WP*r + nc(d)=max(1,min(256,int((hi(d)-lo(d)+r)/r))) + h(d)=max((hi(d)+0.5_WP*r-gl(d))/real(nc(d),WP),r) + end do + end subroutine setup_bins + + !> Flattened cell index of a position (clamped into the grid) + pure function cell_of(p,gl,h,nc) result(k) + real(WP), dimension(3), intent(in) :: p,gl,h + integer, dimension(3), intent(in) :: nc + integer :: k,c(3),d + do d=1,3 + c(d)=min(nc(d),max(1,int((p(d)-gl(d))/h(d))+1)) + end do + k=c(1)+nc(1)*(c(2)-1)+nc(1)*nc(2)*(c(3)-1) + end function cell_of + + + !> Influence function w(zeta) (Peridigm forms). ONE form active, hard-coded; + !> flip by (un)commenting -- s0-from-G_c, psi_fac, and the critical-dt + !> diagnostic all generalize through wmoment(), so nothing else changes. + pure function omega(d,h) result(w) + ! implicit none + ! real(WP), intent(in) :: d,h + ! real(WP) :: w + ! real(WP) :: s + ! ! Parabolic decay (ACTIVE): 1 in the core, C1 taper to 0 at the horizon + ! s=d/h + ! if (s.lt.0.5_WP) then + ! w=1.0_WP + ! else + ! w=max(4.0_WP*s*(1.0_WP-s),0.0_WP) + ! end if + ! ! Constant (Peridigm default; pre-2026-07-16 behavior) + ! !w=1.0_WP + ! ! Gaussian + ! !w=exp(-(d/(0.4_WP*h))**2) + implicit none + real(WP), intent(in) :: d,h + real(WP), parameter :: coeff=2.6_WP + real(WP) :: hh, w + ! hh=coeff*h + hh=h + if (d.ge.hh) then + w=0.0_WP + else + ! wgauss=(1.0_WP+4.0_WP*d/hh)*(1.0_WP-d/hh)**4 + w=(1.0_WP-d/h)**3 + end if + end function omega + + !> Moment of the influence function: int_0^delta w(z)^wpow * z^zpow dz + !> (midpoint quadrature through omega(), so any form change propagates) + pure function wmoment(delta,zpow,wpow) result(m) + implicit none + real(WP), intent(in) :: delta + integer, intent(in) :: zpow,wpow + real(WP) :: m + integer, parameter :: NQ=2048 + integer :: i + real(WP) :: z,dz + dz=delta/real(NQ,WP) + m=0.0_WP + do i=1,NQ + z=(real(i,WP)-0.5_WP)*dz + m=m+omega(z,delta)**wpow*z**zpow + end do + m=m*dz + end function wmoment + + !> Lexicographic sign of an image shift: .true. for the "positive" member + !> of a self-image pair (first nonzero component positive), so each + !> self-image bond is census-counted exactly once. + pure function shift_positive(s) result(p) + implicit none + real(WP), dimension(3), intent(in) :: s + logical :: p + integer :: d + p=.false. + do d=1,3 + if (abs(s(d)).gt.0.0_WP) then + p=(s(d).gt.0.0_WP) + return + end if + end do + end function shift_positive + + !> Negate a packed periodic image offset (amrpd hist1 convention) + pure function negkey(key) result(nk) + implicit none + integer, intent(in) :: key + integer :: nk,n1,n2,n3 + n1=mod(key,256)-128; n2=mod(key/256,256)-128; n3=key/65536-128 + nk=(-n1+128)+(-n2+128)*256+(-n3+128)*65536 + end function negkey + +end module pdsolver_class diff --git a/examples/NOSB_cylinder_peridigm/src/simulation.f90 b/examples/NOSB_cylinder_peridigm/src/simulation.f90 new file mode 100644 index 000000000..9f7efc770 --- /dev/null +++ b/examples/NOSB_cylinder_peridigm/src/simulation.f90 @@ -0,0 +1,584 @@ +!> Various definitions and tools for running an NGA2 simulation +module simulation + use precision, only: WP, I8 + use geometry, only: cfg + use fft2d_class, only: fft2d + use ddadi_class, only: ddadi + use incomp_class, only: incomp + use lsspd_class, only: lss, pd_partition, PDC_MOVES,PDC_INTEGRATES,PDC_BONDS + use timetracker_class, only: timetracker + use ensight_class, only: ensight + use partmesh_class, only: partmesh + use event_class, only: event + use monitor_class, only: monitor + implicit none + private + + !> Get a couple linear solvers, an incompressible flow solver and corresponding time tracker + type(fft2d), public :: ps + type(ddadi), public :: vs + type(incomp), public :: fs + type(lss), public :: ls + type(timetracker), public :: time + + !> Ensight postprocessing + + type(ensight) :: ens_out + type(event) :: ens_evt + type(partmesh), public :: pmesh + !> Simulation monitor file + type(monitor) :: mfile,cflfile,sfile + + public :: simulation_init,simulation_run,simulation_final + + !> Private work arrays + real(WP), dimension(:,:,:), allocatable :: div_x,div_y,div_z + real(WP), dimension(:,:,:), allocatable :: resU,resV,resW + real(WP), dimension(:,:,:), allocatable :: Ui,Vi,Wi + real(WP), dimension(:,:,:), allocatable :: Uib,Vib,Wib,srcM + real(WP), dimension(:,:,:,:,:), allocatable :: gradU + + !> Max timestep size for solid solver + real(WP) :: ls_dt,ls_dt_max + + contains + + + !> Function that localizes the left (x-) of the domain + function left_of_domain(pg,i,j,k) result(isIn) + use pgrid_class, only: pgrid + implicit none + class(pgrid), intent(in) :: pg + integer, intent(in) :: i,j,k + logical :: isIn + isIn=.false. + if (i.eq.pg%imin) isIn=.true. + end function left_of_domain + + + !> Function that localizes the right (x+) of the domain + function right_of_domain(pg,i,j,k) result(isIn) + use pgrid_class, only: pgrid + implicit none + class(pgrid), intent(in) :: pg + integer, intent(in) :: i,j,k + logical :: isIn + isIn=.false. + if (i.eq.pg%imax+1) isIn=.true. + end function right_of_domain + + + !> Initialization of problem solver + subroutine simulation_init + use param, only: param_read,param_exists + use parallel, only: amRoot + implicit none + + + ! Allocate work arrays + allocate_work_arrays: block + allocate(div_x(cfg%imino_:cfg%imaxo_,cfg%jmino_:cfg%jmaxo_,cfg%kmino_:cfg%kmaxo_)) + allocate(div_y(cfg%imino_:cfg%imaxo_,cfg%jmino_:cfg%jmaxo_,cfg%kmino_:cfg%kmaxo_)) + allocate(div_z(cfg%imino_:cfg%imaxo_,cfg%jmino_:cfg%jmaxo_,cfg%kmino_:cfg%kmaxo_)) + allocate(resU(cfg%imino_:cfg%imaxo_,cfg%jmino_:cfg%jmaxo_,cfg%kmino_:cfg%kmaxo_)) + allocate(resV(cfg%imino_:cfg%imaxo_,cfg%jmino_:cfg%jmaxo_,cfg%kmino_:cfg%kmaxo_)) + allocate(resW(cfg%imino_:cfg%imaxo_,cfg%jmino_:cfg%jmaxo_,cfg%kmino_:cfg%kmaxo_)) + allocate(Ui (cfg%imino_:cfg%imaxo_,cfg%jmino_:cfg%jmaxo_,cfg%kmino_:cfg%kmaxo_)) + allocate(Vi (cfg%imino_:cfg%imaxo_,cfg%jmino_:cfg%jmaxo_,cfg%kmino_:cfg%kmaxo_)) + allocate(Wi (cfg%imino_:cfg%imaxo_,cfg%jmino_:cfg%jmaxo_,cfg%kmino_:cfg%kmaxo_)) + allocate(Uib (cfg%imino_:cfg%imaxo_,cfg%jmino_:cfg%jmaxo_,cfg%kmino_:cfg%kmaxo_)) + allocate(Vib (cfg%imino_:cfg%imaxo_,cfg%jmino_:cfg%jmaxo_,cfg%kmino_:cfg%kmaxo_)) + allocate(Wib (cfg%imino_:cfg%imaxo_,cfg%jmino_:cfg%jmaxo_,cfg%kmino_:cfg%kmaxo_)) + allocate(srcM(cfg%imino_:cfg%imaxo_,cfg%jmino_:cfg%jmaxo_,cfg%kmino_:cfg%kmaxo_)) + allocate(gradU(1:3,1:3,cfg%imino_:cfg%imaxo_,cfg%jmino_:cfg%jmaxo_,cfg%kmino_:cfg%kmaxo_)) + end block allocate_work_arrays + + + ! Initialize time tracker with 2 subiterations + initialize_timetracker: block + time=timetracker(amRoot=cfg%amRoot) + call param_read('Max timestep size',time%dtmax) + call param_read('Max cfl number',time%cflmax) + call param_read('Max time',time%tmax) + time%dt=time%dtmax + time%itmax=2 + end block initialize_timetracker + + ! Initialize Lagrangian solid solver + initialize_lss: block + use mathtools, only: Pi + + integer(I8), allocatable :: gids(:),rgid(:) + real(WP), allocatable :: pos(:,:),vel(:,:),voll(:),rpos(:,:),rvel(:,:),rvol(:) + integer, allocatable :: flags(:),owner(:),rflag(:) + integer :: i,j,k,n,nn,nr,nx,ny,nz,N_r,N_z + real(WP) :: dx,x0,y0,z0 + real(WP) :: R + real(WP) :: rho,E,nu,elem,delta + + ls=lss(cfg=cfg,name='solid') + + call param_read('R',R,default=0.5_WP) + call param_read('N_r',N_r,default=10) + call param_read('Z ratio',N_z,default=6) + ! need to define an elem value + elem=R/(3.0_WP*real(N_r,WP)) + ls%delta=elem*3.01_WP ! 3 times the elem value should be the grid spacing + call param_read('Material density',ls%rho,default=10.0_WP) + call param_read('Elastic modulus', ls%elastic_modulus,default=2.0e11_WP) + call param_read('Poisson ratio', ls%poisson_ratio,default=0.3_WP) + call param_read('Tau', ls%tau, default=huge(1.0_WP)) + call param_read('Particle timestep size',ls_dt_max,default=huge(1.0_WP)) + call param_read('Unfreeze time', ls%unfreeze_time,default=huge(1.0_WP)) + ls%damping_rate=0.0_WP + ls_dt=min(ls_dt_max,time%dtmax) + ! Configure by field assignment (grid-free: no domain, no periodicity) + ls%dV=elem**3 ! we treat everybody as a cube + ! Root builds the whole lattice; pd_partition routes it (gids are + ! simply 1..n -- any unique positive keys work) + ! Check dimensionality + if(cfg%nx.eq.1) ls%collapsed(1)=.true. + if(cfg%ny.eq.2) ls%collapsed(2)=.true. + if(cfg%nz.eq.3) ls%collapsed(3)=.true. + nx = 2*N_r*3 + ny = 2*N_r*3 + ! Z is special for a cylinder, needs to match width of the domain + if (N_z.eq.0) then + nz = 1 + else + nz = N_r*N_z*3 + end if + nn=0 + if(amRoot) then + + do k=1,nz; do j=1,ny; do i=1,nx + + x0 = (real(i,WP) - 0.5_WP*real(nx+1,WP))*elem + y0 = (real(j,WP) - 0.5_WP*real(ny+1,WP))*elem + z0 = (real(k,WP) - 0.5_WP*real(nz+1,WP))*elem + if (((x0)*(x0) + y0*y0).ge.R*R) cycle; + nn=nn+1 + end do; end do; end do + end if + + + + + allocate(gids(max(nn,1)),pos(3,max(nn,1)),vel(3,max(nn,1)),flags(max(nn,1)),voll(max(nn,1)),owner(max(nn,1))) + ! allocate(ls%icell(3,max(nn,1))) + n=0 + do k=1,nz; do j=1,ny; do i=1,nx + if (.not.amRoot) exit + x0 = (real(i,WP) - 0.5_WP*real(nx+1,WP))*elem + y0 = (real(j,WP) - 0.5_WP*real(ny+1,WP))*elem + z0 = (real(k,WP) - 0.5_WP*real(nz+1,WP))*elem + if (((x0)*(x0) + y0*y0).ge.R*R) cycle; + n=n+1 + pos(:,n)=[x0, y0, z0] + vel(:,n)=[0.0_WP, 0.0_WP, 0.0_WP] + flags(n)= PDC_MOVES+PDC_INTEGRATES+PDC_BONDS !< IVM, bitwise, this should keep it still? + gids(n)=int(n,I8) + voll(n)=elem**3 + ! if (i.lt.7) then; flags(n)=PDC_MOVES+PDC_BONDS; vel(:,n)=[-1.0e-3_WP, 0.0_WP, 0.0_WP]; end if + ! if (i.gt.nx-6) then; flags(n)=PDC_MOVES+PDC_BONDS; vel(:,n)=[1.0e-3_WP, 0.0_WP, 0.0_WP]; end if + end do; end do; end do + call pd_partition(nn,gids,pos,vel,flags,voll,owner,nr,rgid,rpos,rvel,rflag,rvol) + call ls%set_nodes(nr,rgid,rpos,rvel,rflag,rvol) + + call ls%detect_families() + ! call ls%update_VF() + + ! COMMS TEST + allocate(ls%which_rank(ls%nown)) + ls%which_rank = ls%cfg%rank + + end block initialize_lss + + + + ! Create partmesh object for visualizing Lagrangian particles + create_pmesh: block + use lss_class, only: max_bond + integer :: i,n,nbond + pmesh=partmesh(nvar=3,nvec=3,name='solid') + pmesh%varname(1)='damage' + pmesh%varname(2)='flag' + pmesh%varname(3)='which_rank' + ! pmesh%varname(3)='nbond' ! IVM, seems like we don't currently track this? + ! mesh%varname(4)='von-Mises' + + + pmesh%vecname(1)='velocity' + ! pmesh%vecname(2)='bond_force' + pmesh%vecname(2)='fluid_force' + pmesh%vecname(3) = 'displacement' + call ls%update_partmesh(pmesh) + + do i=1,ls%nown ! IVM, probably not the right thing + + pmesh%vec(:,1,i)=ls%v(:,i) + pmesh%vec(:,2,i)=ls%ff(:,i) + pmesh%vec(:,3,i)=ls%y(:,i)-ls%x0(:,i) + pmesh%var(2,i)=ls%flag(i) + pmesh%var(3,i)=ls%which_rank(i) + + + end do + end block create_pmesh + + + + ! Create a flow solver with inflow-outflow + create_flow_solver: block + use incomp_class, only: dirichlet,clipped_neumann + real(WP) :: visc + ! Create flow solver + fs=incomp(cfg=cfg,name='Incompressible NS') + ! Set the flow properties + call param_read('Density',fs%rho) + call param_read('Dynamic viscosity',visc); fs%visc=visc + ! Define boundary conditions + call fs%add_bcond(name='inflow', type=dirichlet ,locator=left_of_domain ,face='x',dir=-1,canCorrect=.false.) + call fs%add_bcond(name='outflow',type=clipped_neumann,locator=right_of_domain,face='x',dir=+1,canCorrect=.true. ) + ! Configure pressure solver + ps=fft2d(cfg=cfg,name='Pressure',nst=7) + ! Configure implicit velocity solver + vs=ddadi(cfg=cfg,name='Velocity',nst=7) + ! Setup the solver + call fs%setup(pressure_solver=ps,implicit_solver=vs) + end block create_flow_solver + + + ! Initialize our velocity field + initialize_velocity: block + use random, only: random_normal + use incomp_class, only: bcond + type(bcond), pointer :: mybc + integer :: n,i,j,k + real(WP) :: Uin + ! Read inflow velocity + call param_read('Inlet velocity',Uin) + ! IB arrays + Uib=0.0_WP; Vib=0.0_WP; Wib=0.0_WP; srcM=0.0_WP + ! Make initial velocity field random to trigger transition + do k=fs%cfg%kmin_,fs%cfg%kmax_ + do j=fs%cfg%jmin_,fs%cfg%jmax_ + do i=fs%cfg%imin_,fs%cfg%imax_ + fs%U(i,j,k)=0.0_WP + fs%V(i,j,k)=0.0_WP + fs%W(i,j,k)=0.0_WP + end do + end do + end do + call fs%cfg%sync(fs%U) + call fs%cfg%sync(fs%V) + call fs%cfg%sync(fs%W) + ! Set inflow velocity + call fs%get_bcond('inflow',mybc) + do n=1,mybc%itr%no_ + i=mybc%itr%map(1,n); j=mybc%itr%map(2,n); k=mybc%itr%map(3,n) + fs%U(i,j,k)=Uin + end do + ! Compute MFR through all boundary conditions + call fs%get_mfr() + ! Adjust MFR for global mass balance + call fs%correct_mfr(src=srcM) + ! Compute cell-centered velocity + call fs%interp_vel(Ui,Vi,Wi) + ! Compute divergence + resU=srcM/fs%rho !< Careful, we need to provide + call fs%get_div(src=resU) !< a volume source term to div + + end block initialize_velocity + + + ! Add Ensight output + create_ensight: block + ! Create Ensight output from cfg + ens_out=ensight(cfg=cfg,name='cylinder') + ! Create event for Ensight output + ens_evt=event(time=time,name='Ensight output') + call param_read('Ensight output period',ens_evt%tper) + ! Add variables to output + call ens_out%add_particle('particles',pmesh) + call ens_out%add_scalar('divergence',fs%div) + call ens_out%add_vector('velocity',Ui,Vi,Wi) + call ens_out%add_vector('velocity_s',Uib,Vib,Wib) + call ens_out%add_scalar('pressure',fs%P) + call ens_out%add_scalar('VFs',ls%VF) + call ens_out%add_scalar('SRCM',srcM) + ! Output to ensight + if (ens_evt%occurs()) call ens_out%write_data(time%t) + end block create_ensight + + + + ! Create monitor files + create_monitor: block + real(WP) :: cfl + ! Prepare some info about fields + call fs%get_cfl(time%dt,time%cfl) + call fs%get_max() + ! Create simulation monitor + mfile=monitor(fs%cfg%amRoot,'simulation') + call mfile%add_column(time%n,'Timestep number') + call mfile%add_column(time%t,'Time') + call mfile%add_column(time%dt,'Timestep size') + call mfile%add_column(time%cfl,'Maximum CFL') + call mfile%add_column(fs%Umax,'Umax') + call mfile%add_column(fs%Vmax,'Vmax') + call mfile%add_column(fs%Wmax,'Wmax') + call mfile%add_column(fs%Pmax,'Pmax') + call mfile%add_column(fs%divmax,'Maximum divergence') + call mfile%add_column(fs%psolv%it,'Pressure iteration') + call mfile%add_column(fs%psolv%rerr,'Pressure error') + call mfile%write() + ! Create CFL monitor + cflfile=monitor(fs%cfg%amRoot,'cfl') + call cflfile%add_column(time%n,'Timestep number') + call cflfile%add_column(time%t,'Time') + call cflfile%add_column(fs%CFLc_x,'Convective xCFL') + call cflfile%add_column(fs%CFLc_y,'Convective yCFL') + call cflfile%add_column(fs%CFLc_z,'Convective zCFL') + call cflfile%add_column(fs%CFLv_x,'Viscous xCFL') + call cflfile%add_column(fs%CFLv_y,'Viscous yCFL') + call cflfile%add_column(fs%CFLv_z,'Viscous zCFL') + call cflfile%write() + + ! Create solid monitor + sfile=monitor(fs%cfg%amRoot,'solid') + call sfile%add_column(time%n,'Timestep number') + call sfile%add_column(time%t,'Time') + call sfile%add_column(ls_dt,'Particle dt') + call sfile%add_column(time%cfl,'Maximum CFL') + ! call sfile%add_column(ls%np,'Particle number') + call sfile%add_column(ls%VFmax,'VFmax') + call sfile%add_column(ls%Umin,'Particle Umin') + call sfile%add_column(ls%Umax,'Particle Umax') + call sfile%add_column(ls%Vmin,'Particle Vmin') + call sfile%add_column(ls%Vmax,'Particle Vmax') + call sfile%add_column(ls%Wmin,'Particle Wmin') + call sfile%add_column(ls%Wmax,'Particle Wmax') + + call sfile%add_column(ls%ibmForce(1),'Particle Fx') + call sfile%add_column(ls%ibmForce(2),'Particle Fy') + call sfile%add_column(ls%ibmForce(3),'Particle Fz') + call sfile%write() + + call ls%get_info() + mfile=monitor(amRoot=amRoot,name='simulation') + call mfile%add_column(time%n,'Timestep') + call mfile%add_column(time%t,'Time') + call mfile%add_column(ls%np,'Nodes') + call mfile%add_column(ls%nb,'Bonds') + call mfile%add_column(ls%wtmax_kick, 'kick_max') + call mfile%add_column(ls%wtmax_halo, 'halo_max') + call mfile%add_column(ls%wtmax_dil, 'dil_max') + call mfile%add_column(ls%wtmin_dil, 'dil_min') + call mfile%add_column(ls%wtmax_force, 'force_max') + call mfile%add_column(ls%wtmin_force, 'force_min') + call mfile%add_column(ls%wtmax_reduce, 'reduce_max') + call mfile%add_column(ls%wtmax_contact,'contact_max') + call mfile%add_column(ls%wtmax_broad, 'broad_max') + call mfile%add_column(ls%maxtot_time, 'total_max') + call mfile%write() + end block create_monitor + + print *, '================== simulation_init COMPLETE ==================' + + end subroutine simulation_init + + + !> Perform an NGA2 simulation - this mimicks NGA's old time integration for multiphase + subroutine simulation_run + implicit none + real(WP) :: cfl + logical :: freeze_particles + + freeze_particles = .false. + + ! Perform time integration + do while (.not.time%done()) + ! Increment time + call ls%get_cfl(time%dt,time%cfl) + ! call fs%get_cfl(time%dt,cfl); + time%cfl=max(time%cfl,cfl) + call time%adjust_dt() + call time%increment() + + ! Advance solid solver + solid: block + real(WP) :: dt_done,mydt + ! Compute divergence of fluid stress + call fs%get_div_stress(divx=div_x(:,:,:),divy=div_y(:,:,:),divz=div_z(:,:,:)) + ! Sub-iteratore + call ls%get_cfl(ls_dt,cfl=cfl) + if (cfl.gt.0.0_WP) ls_dt=min(ls_dt*time%cflmax/cfl,ls_dt_max) + dt_done=0.0_WP + do while (dt_done.lt.time%dtmid) + ! Decide the timestep size + + mydt=min(ls_dt,time%dtmid-dt_done) + ! Advance particles + if (time%t.gt.ls%unfreeze_time) freeze_particles=.true. + call ls%advance(dt =mydt, & + & unfreeze = freeze_particles, & + & div_stress_x=div_x(:,:,:),& + & div_stress_y=div_y(:,:,:),& + & div_stress_z=div_z(:,:,:)) + ! Increment + + dt_done=dt_done+mydt + end do + + end block solid + + ! Evaluate IB velocity and mass source + calc_ib_velocity: block + integer :: i,j,k + do k=fs%cfg%kmin_,fs%cfg%kmax_ + do j=fs%cfg%jmin_,fs%cfg%jmax_ + do i=fs%cfg%imin_,fs%cfg%imax_ + ! VF based velocity + Uib(i,j,k)=0.5_WP*(ls%VFU(i-1,j,k)+ls%VFU(i,j,k))/(sum(fs%itpr_x(:,i,j,k)*ls%VF(i-1:i,j,k))+epsilon(1.0_WP)) + Vib(i,j,k)=0.5_WP*(ls%VFV(i,j-1,k)+ls%VFV(i,j,k))/(sum(fs%itpr_y(:,i,j,k)*ls%VF(i,j-1:j,k))+epsilon(1.0_WP)) + Wib(i,j,k)=0.5_WP*(ls%VFW(i,j,k-1)+ls%VFW(i,j,k))/(sum(fs%itpr_z(:,i,j,k)*ls%VF(i,j,k-1:k))+epsilon(1.0_WP)) + end do + end do + end do + call cfg%sync(Uib) + call cfg%sync(Vib) + call cfg%sync(Wib) + ! Compute IB mass source + do k=fs%cfg%kmin_,fs%cfg%kmax_ + do j=fs%cfg%jmin_,fs%cfg%jmax_ + do i=fs%cfg%imin_,fs%cfg%imax_ + srcM(i,j,k)=fs%rho*(ls%VF(i,j,k)*(sum(fs%divp_x(:,i,j,k)*Uib(i:i+1,j,k))+& + & sum(fs%divp_y(:,i,j,k)*Vib(i,j:j+1,k))+& + & sum(fs%divp_z(:,i,j,k)*Wib(i,j,k:k+1)))) + + end do + end do + end do + call cfg%sync(srcM) + end block calc_ib_velocity + + + ! Remember old velocity + fs%Uold=fs%U + fs%Vold=fs%V + fs%Wold=fs%W + + ! Perform sub-iterations + do while (time%it.le.time%itmax) + + ! Build mid-time velocity + fs%U=0.5_WP*(fs%U+fs%Uold) + fs%V=0.5_WP*(fs%V+fs%Vold) + fs%W=0.5_WP*(fs%W+fs%Wold) + + ! Explicit calculation of drho*u/dt from NS + call fs%get_dmomdt(resU,resV,resW) + + ! Assemble explicit residual + resU=-2.0_WP*(fs%rho*fs%U-fs%rho*fs%Uold)+time%dtmid*resU + resV=-2.0_WP*(fs%rho*fs%V-fs%rho*fs%Vold)+time%dtmid*resV + resW=-2.0_WP*(fs%rho*fs%W-fs%rho*fs%Wold)+time%dtmid*resW + + ! Form implicit residuals + call fs%solve_implicit(time%dtmid,resU,resV,resW) + + ! Apply these residuals + fs%U=2.0_WP*fs%U-fs%Uold+resU + fs%V=2.0_WP*fs%V-fs%Vold+resV + fs%W=2.0_WP*fs%W-fs%Wold+resW + + ! Apply direct IB forcing + ibforcing: block + integer :: i,j,k + do k=fs%cfg%kmin_,fs%cfg%kmax_; do j=fs%cfg%jmin_,fs%cfg%jmax_; do i=fs%cfg%imin_,fs%cfg%imax_ + fs%U(i,j,k)=(1.0_WP-sum(fs%itpr_x(:,i,j,k)*ls%VF(i-1:i,j,k)))*fs%U(i,j,k)+0.5_WP*(ls%VFU(i-1,j,k)+ls%VFU(i,j,k)) + fs%V(i,j,k)=(1.0_WP-sum(fs%itpr_y(:,i,j,k)*ls%VF(i,j-1:j,k)))*fs%V(i,j,k)+0.5_WP*(ls%VFV(i,j-1,k)+ls%VFV(i,j,k)) + fs%W(i,j,k)=(1.0_WP-sum(fs%itpr_z(:,i,j,k)*ls%VF(i,j,k-1:k)))*fs%W(i,j,k)+0.5_WP*(ls%VFW(i,j,k-1)+ls%VFW(i,j,k)) + end do; end do; end do + call fs%cfg%sync(fs%U) + call fs%cfg%sync(fs%V) + call fs%cfg%sync(fs%W) + end block ibforcing + + ! Apply other boundary conditions + call fs%apply_bcond(time%t,time%dtmid) + + ! Solve Poisson equation + call fs%correct_mfr(src=srcM) + resU=srcM/fs%rho !< Careful, we need to provide + call fs%get_div(src=resU) !< a volume source term to div + fs%psolv%rhs=-fs%cfg%vol*fs%div*fs%rho/time%dtmid + fs%psolv%sol=0.0_WP + call fs%psolv%solve() + call fs%shift_p(fs%psolv%sol) + + ! Correct velocity + call fs%get_pgrad(fs%psolv%sol,resU,resV,resW) + fs%P=fs%P+fs%psolv%sol + fs%U=fs%U-time%dtmid*resU/fs%rho + fs%V=fs%V-time%dtmid*resV/fs%rho + fs%W=fs%W-time%dtmid*resW/fs%rho + + ! Increment sub-iteration counter + time%it=time%it+1 + + end do + + ! Recompute interpolated velocity and divergence + call fs%interp_vel(Ui,Vi,Wi) + resU=srcM/fs%rho !< Careful, we need to provide + call fs%get_div(src=resU) !< a volume source term to div + + ! Output to ensight + if (ens_evt%occurs()) then + update_pmesh: block + use lss_class, only: max_bond + integer :: i,n,nbond + call ls%update_partmesh(pmesh) + do i=1,ls%nown ! IVM, probably not the right thing + pmesh%vec(:,1,i)=ls%v(:,i) + pmesh%vec(:,2,i)=ls%ff(:,i) + pmesh%vec(:,3,i)=ls%y(:,i)-ls%x0(:,i) + pmesh%var(2,i)=ls%flag(i) + pmesh%var(3,i)=ls%which_rank(i) + end do + end block update_pmesh + call ens_out%write_data(time%t) + end if + + ! ! Perform and output monitoring + call ls%get_info() + call fs%get_max() + ! call ls%get_max() ! IVM, i need a replacement for this guy + call mfile%write() + call cflfile%write() + call sfile%write() + + end do + + end subroutine simulation_run + + + !> Finalize the NGA2 simulation + subroutine simulation_final + implicit none + + ! Get rid of all objects - need destructors + ! monitor + ! ensight + ! bcond + ! timetracker + + ! Deallocate work arrays + deallocate(div_x,div_y,div_z,resU,resV,resW,Ui,Vi,Wi,Uib,Vib,Wib,srcM,gradU) + + end subroutine simulation_final + + +end module simulation diff --git a/examples/NOSB_plate_with_hole/GNUmakefile b/examples/NOSB_plate_with_hole/GNUmakefile new file mode 100644 index 000000000..23c4d3dba --- /dev/null +++ b/examples/NOSB_plate_with_hole/GNUmakefile @@ -0,0 +1,49 @@ +# NGA location if not yet defined +NGA_HOME ?= ~/nga2/Repositories/nga2 + +# Compilation parameters +PRECISION = DOUBLE +USE_MPI = TRUE +USE_HYPRE = TRUE +USE_LAPACK= TRUE +USE_FFTW = TRUE +USE_IRL = FALSE +PROFILE = FALSE +DEBUG = FALSE +COMP = gnu +EXEBASE = nga + +# Directories that contain user-defined code +Udirs := src + +# Include user-defined sources +Upack += $(foreach dir, $(Udirs), $(wildcard $(dir)/Make.package)) +Ulocs += $(foreach dir, $(Udirs), $(wildcard $(dir))) +include $(Upack) +INCLUDE_LOCATIONS += $(Ulocs) +VPATH_LOCATIONS += $(Ulocs) + +# External libraries are defined in .profile/.bashrc/.zshrc, but could be defined here as well +HYPRE_DIR=/Users/imauser/nga2/Repositories/hypre/src/hypre +FFTW_DIR=/opt/homebrew/Cellar/fftw/3.3.10_2 + +# NGA compilation definitions +include $(NGA_HOME)/tools/GNUMake/Make.defs + +# Include NGA base code +Bdirs := constant_density particles core data transform solver config grid libraries +Bpack += $(foreach dir, $(Bdirs), $(NGA_HOME)/src/$(dir)/Make.package) +include $(Bpack) + +# Inform user of Make.packages used +ifdef Ulocs + $(info Taking user code from: $(Ulocs)) +endif +$(info Taking base code from: $(Bdirs)) + +# Target definition +all: $(executable) + @echo COMPILATION SUCCESSFUL + +# NGA compilation rules +include $(NGA_HOME)/tools/GNUMake/Make.rules diff --git a/examples/NOSB_plate_with_hole/input b/examples/NOSB_plate_with_hole/input new file mode 100644 index 000000000..3db2409be --- /dev/null +++ b/examples/NOSB_plate_with_hole/input @@ -0,0 +1,31 @@ +Parallelization +Partition : 3 3 1 + + +# Beam Shape +Lz : 0.02 +Ly : 0.1 +Lx : 0.1 +R : 0.015 +Particle file: element_data.bin + +# Solid properties +Subdivisions : 33 +Elastic Modulus : 200e9 +Poisson Ratio : 0.30 +Solid density : 7850 +Critical Energy Release Rate : 100000 +Horizon Ratio : 3.015 +N Across : 5 +Mean Particle Spacing : 0.00125 +Load Rate : 0.01 +Solid Damping Constant : 0.02 + +# Time integration +Max timestep size : 1e-5 +Max cfl number : 1.0 +Max time : 0.2 +Damping time : 0.1 + +# Ensight output +Ensight output period : 1e-5 diff --git a/examples/NOSB_plate_with_hole/src/Make.package b/examples/NOSB_plate_with_hole/src/Make.package new file mode 100644 index 000000000..ddc060c7d --- /dev/null +++ b/examples/NOSB_plate_with_hole/src/Make.package @@ -0,0 +1,2 @@ +# List here the extra files here +f90EXE_sources += simulation.f90 geometry.f90 lss_class.f90 spcomp_class.f90 diff --git a/examples/NOSB_plate_with_hole/src/geometry.f90 b/examples/NOSB_plate_with_hole/src/geometry.f90 new file mode 100644 index 000000000..228d58abd --- /dev/null +++ b/examples/NOSB_plate_with_hole/src/geometry.f90 @@ -0,0 +1,138 @@ +!> Various definitions and tools for initializing NGA2 config +module geometry + use config_class, only: config + use precision, only: WP + implicit none + private + + !> Single config + type(config), public :: cfg + + public :: geometry_init + +contains + + + !> Initialization of problem geometry + subroutine geometry_init + use sgrid_class, only: sgrid + use param, only: param_read + implicit none + type(sgrid) :: grid + + + ! Create a grid from input params + create_grid: block + use sgrid_class, only: cartesian + integer :: i,j,k,nx,ny,nz,N + real(WP) :: Lx,Ly,Lz,dist,dx,R + real(WP), dimension(:), allocatable :: x,y,z + + call param_read('Lx',Lx) + call param_read('Ly',Ly) + call param_read('Lz',Lz) + call param_read('R',R) + call param_read('N Across',N) + + ! Lx = 1.0_WP ! beam length + ! Ly = 1.0_WP ! beam length + + ! dist = 0.01_WP ! Space between particles + dist = Lz/N + Lx = Lx + (3.015_WP)*4.0_WP * dist ! total length of the beam + ! Ly = Ly + 3.0_WP * dist ! total length of the beam + + dx = 3.015_WP*dist ! grid spacing + ! print*, "Grid Spacing : ", dx + + nx = ceiling(Lx/dx)+2 ! number of division in x + ny = ceiling(Ly/dx)+2 + nz = ceiling(Lz/dx)+2 + + allocate(x(nx+1)) + allocate(y(ny+1)) + allocate(z(nz+1)) + + ! Create simple rectilinear grid + do i=1,nx+1 + x(i)=real(i-2,WP)*dx - Lx/2.0_WP! - 1.5_WP*dist + end do + do j=1,ny+1 + y(j)=real(j-2,WP)*dx - Ly/2.0_WP! - 1.5_WP*dist + end do + do k=1,nz+1 + z(k)=real(k-2,WP)*dx - Lz/2.0_WP! - 1.5_WP*dist + end do + ! General serial grid object (no=3 needed to support ghost/image point interpolation/extrapolation) + grid=sgrid(coord=cartesian,no=3,x=x,y=y,z=z,xper=.false.,yper=.false.,zper=.false.,name='box') + + end block create_grid + + ! create_grid: block + ! use sgrid_class, only: cartesian + ! integer :: i,j,k,nx,ny,nz + ! real(WP) :: Lx,Ly,Lz,dist + ! real(WP), dimension(:), allocatable :: x,y,z + + ! ! Read in grid definition + ! call param_read('Lx',Lx); Lx=Lx + ! call param_read('Ly',Ly); Ly=Ly + ! call param_read('Lz',Lz); Lz=Lz + ! call param_read('Subdivisions',ny) + ! dist = 3.0_WP * Ly / real(ny,WP) + ! Lx = Lx + 3.0_WP * dist + ! nx = ceiling(Lx / dist) + 4 + ! ny = ceiling(Ly / dist) + 2 + ! nz = ceiling(Lz / dist) + 2 + + ! Lx = real(nx,WP) * dist + ! Ly = real(ny,WP) * dist + ! Lz = real(nz,WP) * dist + + + ! allocate(x(nx)) + ! allocate(y(ny+1)) + ! allocate(z(nz+1)) + + + ! ! Create simple rectilinear grid + ! do i=1,nx + ! x(i)=real(i-2,WP)*dist + ! end do + ! do j=1,ny+1 + ! y(j)=real(j-1,WP)*dist-0.5_WP*Ly + ! end do + ! do k=1,nz+1 + ! z(k)=real(k-1,WP)*dist-0.5_WP*Lz + ! end do + + + + + ! ! General serial grid object (no=3 needed to support ghost/image point interpolation/extrapolation) + ! grid=sgrid(coord=cartesian,no=2,x=x,y=y,z=z,xper=.false.,yper=.false.,zper=.false.,name='box') + + ! end block create_grid + + + ! Create a config from that grid on our entire group + create_cfg: block + use parallel, only: group + integer, dimension(3) :: partition + ! Read in partition + call param_read('Partition',partition,short='p') + ! Create partitioned grid + cfg=config(grp=group,decomp=partition,grid=grid) + end block create_cfg + + + ! Create walls for this config + create_walls: block + cfg%VF=1.0_WP + end block create_walls + + + end subroutine geometry_init + + +end module geometry diff --git a/examples/NOSB_plate_with_hole/src/lss_class.f90 b/examples/NOSB_plate_with_hole/src/lss_class.f90 new file mode 100644 index 000000000..a797e419f --- /dev/null +++ b/examples/NOSB_plate_with_hole/src/lss_class.f90 @@ -0,0 +1,1625 @@ +!> Lagrangian solid solver object +!> Implements peridynamics equations +module lss_class + use precision, only: WP + use string, only: str_medium + use config_class, only: config + use mpi_f08, only: MPI_Datatype,MPI_INTEGER8,MPI_INTEGER,MPI_DOUBLE_PRECISION + implicit none + private + + + ! Expose type/constructor/methods + public :: lss + + + !> Memory adaptation parameter + real(WP), parameter :: coeff_up=1.3_WP !< Particle array size increase factor + real(WP), parameter :: coeff_dn=0.7_WP !< Particle array size decrease factor + + + !> I/O chunk size to read at a time + integer, parameter :: part_chunk_size=1000 !< Read 1000 particles at a time before redistributing + + + !> Maximum number of bonds per particle + integer, parameter, public :: max_bond=400 !< Assumes something like a 7x7x7 stencil in 3D + + + !> Bonded solid particle definition + type :: part + !> MPI_DOUBLE_PRECISION data + real(WP) :: vonMises !< Element dilatation + real(WP) :: vol !< Particle volume + real(WP) :: correcMag + real(WP), dimension(max_bond) :: dbond !< Length of initial bonds + real(WP), dimension(3) :: pos !< Particle center coordinates + real(WP), dimension(3) :: vel !< Velocity of particle + real(WP), dimension(3) :: Abond !< Bond acceleration for particle + real(WP), dimension(3) :: Afluid !< Fluid acceleration for particle + real(WP), dimension(3) :: ipos !< Initial position + real(WP), dimension(3) :: displacement !< Displacement + real(WP), dimension(3,3) :: F !< Deformation gradient tensor + real(WP), dimension(3,3) :: PK_inv !< First Piola-Kirchoff tensor times shape tensor inverse + !> MPI_INTEGER data + integer :: id !< ID the object is associated with + integer :: i !< Unique index of particle (assumed >0) + integer :: nbond !< Number of initial bonds + integer, dimension(max_bond) :: ibond !< Indices of initially bonded particles (0 values ignored) + integer , dimension(3) :: ind !< Index of cell containing particle center + integer :: flag !< Control parameter (0=normal, 1=done->will be removed) + end type part + !> Number of blocks, block length, and block types in a particle + integer, parameter :: part_nblock=2 + integer , dimension(part_nblock) :: part_lblock=[39+max_bond,7+max_bond] + type(MPI_Datatype), dimension(part_nblock) :: part_tblock=[MPI_DOUBLE_PRECISION,MPI_INTEGER] + !> MPI_PART derived datatype and size + type(MPI_Datatype) :: MPI_PART + integer :: MPI_PART_SIZE + + + !> Lagrangian solid solver object definition + type :: lss + + ! This config is used for parallelization and for calculating bond/collision forces + class(config), pointer :: cfg + + ! This is the name of the solver + character(len=str_medium) :: name='UNNAMED_LSS' + + ! Solid material properties + real(WP) :: elastic_modulus !< Elastic modulus of the material + real(WP) :: poisson_ratio !< Poisson's ratio of the material + real(WP) :: rho !< Density of the material + real(WP) :: crit_energy !< Critical energy release + real(WP) :: beta !< Damping constant + real(WP) :: cool_down_time + logical :: continuous_damping !< True if you want damping on the whole time + + ! Bonding parameters + real(WP) :: delta !< Bonding horizon (distance) + real(WP) :: min_dist !< Minimum bonding distance + integer :: nb !< Cell-based horizon + + ! Global and local particle data + integer :: np !< Global number of particles + integer :: np_ !< Local number of particles + integer, dimension(:), allocatable :: np_proc !< Number of particles on each processor + type(part), dimension(:), allocatable :: p !< Array of particles of type part + + ! Overlap particle (i.e., ghost) data + integer :: ng_ !< Local number of ghosts + type(part), dimension(:), allocatable :: g !< Array of ghosts of type part + + ! Gravitational acceleration + real(WP), dimension(3) :: gravity=[0.0_WP,0.0_WP,0.0_WP] + + ! Solid volume fraction and momentum + real(WP), dimension(:,:,:), allocatable :: VF !< Volume fraction, cell-centered + real(WP), dimension(:,:,:), allocatable :: VFU !< Solid velocity, U-face + real(WP), dimension(:,:,:), allocatable :: VFV !< Solid velocity, V-face + real(WP), dimension(:,:,:), allocatable :: VFW !< Solid velocity, W-face + + ! CFL numbers + real(WP) :: CFLp_x,CFLp_y,CFLp_z,CFLp_a + + ! Number of substeps for time integrator + real(WP) :: nstep=1 + + ! Monitoring info + real(WP) :: Umin,Umax,Umean !< U velocity info + real(WP) :: Vmin,Vmax,Vmean !< V velocity info + real(WP) :: Wmin,Wmax,Wmean !< W velocity info + real(WP) :: VFmax !< Volume fraction info + real(WP), dimension(3) :: ibmForce !< Total force due to IBM + integer :: np_out !< Number of particles leaving the domain + + contains + procedure :: bond_init !< Setup initial interparticle bonds + procedure :: get_bond_force !< Compute interparticle bond force + procedure :: advance !< Step forward the particle ODEs + procedure :: get_cfl !< Calculate maximum CFL + procedure :: get_max !< Extract various monitoring data + procedure :: update_partmesh !< Update a partmesh object using current particles + procedure :: share !< Share particles across interprocessor boundaries + procedure :: sync !< Synchronize particles across interprocessor boundaries + procedure :: resize !< Resize particle array to given size + procedure :: resize_ghost !< Resize ghost array to given size + procedure :: recycle !< Recycle particle array by removing flagged particles + procedure :: write !< Parallel write particles to file + procedure :: read !< Parallel read particles from file + procedure :: update_VF !< Compute volume fraction + procedure :: get_delta !< Compute regularized delta function + procedure :: interpolate !< Interpolation routine from mesh=>marker + procedure :: extrapolate !< Extrapolation routine from marker=>mesh + ! procedure :: stretch + end type lss + + + !> Declare lss constructor + interface lss + procedure constructor + end interface lss + +contains + + + ! Quasi-Gaussian weighting function - h is the cut-off + real(WP) function wgauss(d,h) + implicit none + real(WP), intent(in) :: d,h + real(WP), parameter :: coeff=2.6_WP + real(WP) :: hh + ! hh=coeff*h + hh=h + if (d.ge.hh) then + wgauss=0.0_WP + else + ! wgauss=(1.0_WP+4.0_WP*d/hh)*(1.0_WP-d/hh)**4 + wgauss=(1.0_WP-d/h)**3 + end if + end function wgauss + + + !> Default constructor for Lagrangian solid solver + function constructor(cfg,name) result(self) + implicit none + type(lss) :: self + class(config), target, intent(in) :: cfg + character(len=*), optional :: name + integer :: i,j,k + + ! Set the name for the solver + if (present(name)) self%name=trim(adjustl(name)) + + ! Point to pgrid object + self%cfg=>cfg + + ! Set default bonding horizon based on underlying mesh + self%delta=self%cfg%min_meshsize + self%nb=1 + self%min_dist=huge(1.0_WP) + + ! Allocate variables + allocate(self%np_proc(1:self%cfg%nproc)); self%np_proc=0 + self%np_=0; self%np=0 + call self%resize(0) + + ! Initialize MPI derived datatype for a particle + call prepare_mpi_part() + + ! Allocate VF array on cfg mesh + allocate(self%VF(self%cfg%imino_:self%cfg%imaxo_,self%cfg%jmino_:self%cfg%jmaxo_,self%cfg%kmino_:self%cfg%kmaxo_)); self%VF=0.0_WP + allocate(self%VFU(self%cfg%imino_:self%cfg%imaxo_,self%cfg%jmino_:self%cfg%jmaxo_,self%cfg%kmino_:self%cfg%kmaxo_)); self%VFU=0.0_WP + allocate(self%VFV(self%cfg%imino_:self%cfg%imaxo_,self%cfg%jmino_:self%cfg%jmaxo_,self%cfg%kmino_:self%cfg%kmaxo_)); self%VFV=0.0_WP + allocate(self%VFW(self%cfg%imino_:self%cfg%imaxo_,self%cfg%jmino_:self%cfg%jmaxo_,self%cfg%kmino_:self%cfg%kmaxo_)); self%VFW=0.0_WP + + ! Log/screen output + logging: block + use, intrinsic :: iso_fortran_env, only: output_unit + use param, only: verbose + use messager, only: log + use string, only: str_long + character(len=str_long) :: message + if (self%cfg%amRoot) then + write(message,'("LSS object [",a,"] on partitioned grid [",a,"]")') trim(self%name),trim(self%cfg%name) + if (verbose.gt.1) write(output_unit,'(a)') trim(message) + if (verbose.gt.0) call log(message) + end if + end block logging + + end function constructor + + + !> Initialize bond force between particles + subroutine bond_init(this) + use messager, only: die + implicit none + class(lss), intent(inout) :: this + integer, dimension(:,:,:), allocatable :: npic !< Number of particle in cell + integer, dimension(:,:,:,:), allocatable :: ipic !< Index of particle in cell + + ! Communicate particles in ghost cells + call this%share() + + ! We can now assemble particle-in-cell information + pic_prep: block + use mpi_f08 + integer :: i,ip,jp,kp,ierr + integer :: mymax_npic,max_npic + + ! Allocate number of particle in cell + allocate(npic(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)); npic=0 + + ! Count particles and ghosts per cell + do i=1,this%np_ + ip=this%p(i)%ind(1); jp=this%p(i)%ind(2); kp=this%p(i)%ind(3) + npic(ip,jp,kp)=npic(ip,jp,kp)+1 + end do + do i=1,this%ng_ + ip=this%g(i)%ind(1); jp=this%g(i)%ind(2); kp=this%g(i)%ind(3) + npic(ip,jp,kp)=npic(ip,jp,kp)+1 + end do + + ! Get maximum number of particle in cell + mymax_npic=maxval(npic); call MPI_ALLREDUCE(mymax_npic,max_npic,1,MPI_INTEGER,MPI_MAX,this%cfg%comm,ierr) + + ! Allocate pic map + allocate(ipic(1:max_npic,this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)); ipic=0 + + ! Assemble pic map + npic=0 + do i=1,this%np_ + ip=this%p(i)%ind(1); jp=this%p(i)%ind(2); kp=this%p(i)%ind(3) + npic(ip,jp,kp)=npic(ip,jp,kp)+1 + ipic(npic(ip,jp,kp),ip,jp,kp)=+i + end do + do i=1,this%ng_ + ip=this%g(i)%ind(1); jp=this%g(i)%ind(2); kp=this%g(i)%ind(3) + npic(ip,jp,kp)=npic(ip,jp,kp)+1 + ipic(npic(ip,jp,kp),ip,jp,kp)=-i + end do + + end block pic_prep + + ! Establish initial bonds + create_bonds: block + use mpi_f08, only: MPI_ALLREDUCE,MPI_MIN,MPI_IN_PLACE + use parallel, only: MPI_REAL_WP + use mathtools, only: Pi + integer :: i,j,k,n1,nn,n2,ierr + type(part) :: p1,p2 + real(WP), dimension(3) :: rpos + real(WP) :: dist + ! Reset minimum bond distance + this%min_dist=huge(1.0_WP) + ! Loop over particles + do n1=1,this%np_ + ! Create copy of our particle + p1=this%p(n1) + ! Zero out bonds + p1%ibond=0 + p1%nbond=0 + ! Loop over neighbor cells + do k=p1%ind(3)-this%nb,p1%ind(3)+this%nb + do j=p1%ind(2)-this%nb,p1%ind(2)+this%nb + do i=p1%ind(1)-this%nb,p1%ind(1)+this%nb + ! Loop over particles in that cell + do nn=1,npic(i,j,k) + ! Create copy of our neighbor + n2=ipic(nn,i,j,k) + if (n2.gt.0) then + p2=this%p(+n2) + else if (n2.lt.0) then + p2=this%g(-n2) + end if + ! Cannot self-bond + if (p1%i.eq.p2%i) cycle + ! Cannot bond with different id except <=0 (<=0 bonds with everyone) + if (p1%id.ne.p2%id.and.p1%id.ge.0.and.p2%id.ge.0) cycle + ! Check interparticle distance + rpos=p2%pos-p1%pos + dist=sqrt(dot_product(rpos,rpos)) + if (dist.lt.this%delta) then + ! This particle is in horizon, create a bond + p1%nbond=p1%nbond+1 + if (p1%nbond.gt.max_bond) call die('[lss_class bond_init] Number of detected bonds is larger than max allowed') + p1%ibond(p1%nbond)=p2%i + p1%dbond(p1%nbond)=dist + ! Determine minimum bond distance + this%min_dist=min(this%min_dist,dist) + end if + end do + end do + end do + end do + ! Copy back the particle + this%p(n1)=p1 + end do + ! Get global minimum + call MPI_ALLREDUCE(MPI_IN_PLACE,this%min_dist,1,MPI_REAL_WP,MPI_MIN,this%cfg%comm,ierr) + end block create_bonds + + ! Clean up + if (allocated(npic)) deallocate(npic) + if (allocated(ipic)) deallocate(ipic) + + + end subroutine bond_init + + + !> Calculate bond force between particles + subroutine get_bond_force(this) + implicit none + class(lss), intent(inout) :: this + integer, dimension(:,:,:), allocatable :: npic !< Number of particle in cell + integer, dimension(:,:,:,:), allocatable :: ipic !< Index of particle in cell + logical :: is2D + + ! Need to modify parameters in 2D + is2D=this%cfg%nx.eq.1.or.this%cfg%ny.eq.1.or.this%cfg%nz.eq.1 + + ! Communicate particles in ghost cells + call this%share() + + ! We can now assemble particle-in-cell information + pic_prep: block + use mpi_f08 + integer :: i,ip,jp,kp,ierr + integer :: mymax_npic,max_npic + + ! Allocate number of particle in cell + allocate(npic(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)); npic=0 + + ! Count particles and ghosts per cell + do i=1,this%np_ + ip=this%p(i)%ind(1); jp=this%p(i)%ind(2); kp=this%p(i)%ind(3) + npic(ip,jp,kp)=npic(ip,jp,kp)+1 + end do + do i=1,this%ng_ + ip=this%g(i)%ind(1); jp=this%g(i)%ind(2); kp=this%g(i)%ind(3) + npic(ip,jp,kp)=npic(ip,jp,kp)+1 + end do + + ! Get maximum number of particle in cell + mymax_npic=maxval(npic); call MPI_ALLREDUCE(mymax_npic,max_npic,1,MPI_INTEGER,MPI_MAX,this%cfg%comm,ierr) + + ! Allocate pic map + allocate(ipic(1:max_npic,this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)); ipic=0 + + ! Assemble pic map + npic=0 + do i=1,this%np_ + ip=this%p(i)%ind(1); jp=this%p(i)%ind(2); kp=this%p(i)%ind(3) + npic(ip,jp,kp)=npic(ip,jp,kp)+1 + ipic(npic(ip,jp,kp),ip,jp,kp)=+i + end do + do i=1,this%ng_ + ip=this%g(i)%ind(1); jp=this%g(i)%ind(2); kp=this%g(i)%ind(3) + npic(ip,jp,kp)=npic(ip,jp,kp)+1 + ipic(npic(ip,jp,kp),ip,jp,kp)=-i + end do + + end block pic_prep + + ! Update shape and deformation gradient tensor + update_tensors: block + use mathtools + integer :: i,j,k,n1,nn,n2 + type(part) :: p1,p2 + integer :: nb,nbond + real(WP), dimension(3) :: rpos, xi + real(WP) :: dist,w,mu,kk,detK,traceE,J_F,sigma_vm, traceS + real(WP), dimension(3,3) :: K_mat,E_mat,I_mat,S_mat,K_inv,sigma, s_dev + + mu=this%elastic_modulus/(2.0_WP+2.0_WP*this%poisson_ratio) ! shear modulus + kk=this%elastic_modulus/(3.0_WP-6.0_WP*this%poisson_ratio) ! bulk moduls + I_mat = 0.0_WP + S_mat = 0.0_WP + traceE = 0.0_WP + E_mat = 0.0_WP + K_inv = 0.0_WP + I_mat(1,1) = 1.0_WP + I_mat(2,2) = 1.0_WP + I_mat(3,3) = 1.0_WP + + ! Loop over particles + do n1=1,this%np_ + ! Create copy of our particle + p1=this%p(n1) + ! Zero out weighted volume and dilatation + K_mat=0.0_WP + K_inv = 0.0_WP + p1%F=0.0_WP + ! Loop over neighbor cells + do k=p1%ind(3)-this%nb,p1%ind(3)+this%nb + do j=p1%ind(2)-this%nb,p1%ind(2)+this%nb + do i=p1%ind(1)-this%nb,p1%ind(1)+this%nb + ! Loop over particles in that cell + do nn=1,npic(i,j,k) + ! Create copy of our neighbor + n2=ipic(nn,i,j,k) + if (n2.gt.0) then + p2=this%p(+n2) + else if (n2.lt.0) then + p2=this%g(-n2) + end if + ! Check if a bond exists + do nb=1,max_bond + if (p1%ibond(nb).eq.p2%i) then + ! Get current distance + rpos=p2%pos-p1%pos + !print *, rpos + ! Compute summation of K + xi = p2%ipos-p1%ipos + w = wgauss(p1%dbond(nb),this%delta) + K_mat(1,1)=K_mat(1,1)+xi(1)*xi(1)*w*p2%vol; K_mat(1,2)=K_mat(1,2)+xi(1)*xi(2)*w*p2%vol; K_mat(1,3)=K_mat(1,3)+xi(1)*xi(3)*w*p2%vol; + K_mat(2,1)=K_mat(2,1)+xi(2)*xi(1)*w*p2%vol; K_mat(2,2)=K_mat(2,2)+xi(2)*xi(2)*w*p2%vol; K_mat(2,3)=K_mat(2,3)+xi(2)*xi(3)*w*p2%vol; + K_mat(3,1)=K_mat(3,1)+xi(3)*xi(1)*w*p2%vol; K_mat(3,2)=K_mat(3,2)+xi(3)*xi(2)*w*p2%vol; K_mat(3,3)=K_mat(3,3)+xi(3)*xi(3)*w*p2%vol; + + ! Compute interior summation of F + p1%F(1,1)=p1%F(1,1)+rpos(1)*xi(1)*w*p2%vol; p1%F(1,2)=p1%F(1,2)+rpos(1)*xi(2)*w*p2%vol; p1%F(1,3)=p1%F(1,3)+rpos(1)*xi(3)*w*p2%vol; + p1%F(2,1)=p1%F(2,1)+rpos(2)*xi(1)*w*p2%vol; p1%F(2,2)=p1%F(2,2)+rpos(2)*xi(2)*w*p2%vol; p1%F(2,3)=p1%F(2,3)+rpos(2)*xi(3)*w*p2%vol; + p1%F(3,1)=p1%F(3,1)+rpos(3)*xi(1)*w*p2%vol; p1%F(3,2)=p1%F(3,2)+rpos(3)*xi(2)*w*p2%vol; p1%F(3,3)=p1%F(3,3)+rpos(3)*xi(3)*w*p2%vol; + end if + end do + end do + end do + end do + end do + ! Apply inverse of K to get F = F*K^-1 + detK = K_mat(1,1)*(K_mat(2,2)*K_mat(3,3)-K_mat(2,3)*K_mat(3,2)) & + -K_mat(1,2)*(K_mat(2,1)*K_mat(3,3)-K_mat(2,3)*K_mat(3,1)) & + +K_mat(1,3)*(K_mat(2,1)*K_mat(3,2)-K_mat(2,2)*K_mat(3,1)) + K_inv(1,1) = (K_mat(2,2)*K_mat(3,3) - K_mat(2,3)*K_mat(3,2))/detK + K_inv(2,1) = -(K_mat(2,1)*K_mat(3,3) - K_mat(2,3)*K_mat(3,1))/detK + K_inv(3,1) = (K_mat(2,1)*K_mat(3,2) - K_mat(2,2)*K_mat(3,1))/detK + K_inv(1,2) = -(K_mat(1,2)*K_mat(3,3) - K_mat(1,3)*K_mat(3,2))/detK + K_inv(2,2) = (K_mat(1,1)*K_mat(3,3) - K_mat(1,3)*K_mat(3,1))/detK + K_inv(3,2) = -(K_mat(1,1)*K_mat(3,2) - K_mat(1,2)*K_mat(3,1))/detK + K_inv(1,3) = (K_mat(1,2)*K_mat(2,3) - K_mat(1,3)*K_mat(2,2))/detK + K_inv(2,3) = -(K_mat(1,1)*K_mat(2,3) - K_mat(1,3)*K_mat(2,1))/detK + K_inv(3,3) = (K_mat(1,1)*K_mat(2,2) - K_mat(1,2)*K_mat(2,1))/detK + + + p1%F = MATMUL(p1%F,K_inv) + + ! Compute first Piola-Kirchoff stress tensor - constitutive model dependent + E_mat = 0.5_WP * (MATMUL(TRANSPOSE(p1%F),p1%F)-I_mat) + traceE = E_mat(1,1) + E_mat(2,2) + E_mat(3,3) + S_mat = (kk-2.0_WP/3.0_WP*mu)*traceE*I_mat + 2.0_WP*mu*E_mat + p1%PK_inv = MATMUL(MATMUL(p1%F,S_mat),K_inv) + + J_F = p1%F(1,1)*(p1%F(2,2)*p1%F(3,3)-p1%F(2,3)*p1%F(3,2)) & + -p1%F(1,2)*(p1%F(2,1)*p1%F(3,3)-p1%F(2,3)*p1%F(3,1)) & + +p1%F(1,3)*(p1%F(2,1)*p1%F(3,2)-p1%F(2,2)*p1%F(3,1)) + + sigma = MATMUL(MATMUL(p1%F, S_mat), TRANSPOSE(p1%F)) / J_F + + ! Deviatoric part + traceS = sigma(1,1) + sigma(2,2) + sigma(3,3) + s_dev = sigma - (traceS/3.0_WP)*I_mat + + ! Von Mises + p1%vonMises = sqrt(1.5_WP * (s_dev(1,1)**2 + s_dev(2,2)**2 + s_dev(3,3)**2 & + + 2.0_WP*s_dev(1,2)**2 + 2.0_WP*s_dev(1,3)**2 & + + 2.0_WP*s_dev(2,3)**2)) + + ! Copy back the particle + this%p(n1)=p1 + end do + end block update_tensors + + ! Re-communicate particles in ghost cells to update dil and mw + call this%share() + + ! Update bond force, including collision force, and SED + update_bond_force: block + use mpi_f08, only: MPI_ALLREDUCE,MPI_MIN,MPI_IN_PLACE + use parallel, only: MPI_REAL_WP + use mathtools, only: Pi + integer :: i,j,k,n1,nn,n2,ierr + type(part) :: p1,p2 + real(WP), dimension(3) :: rpos,t1,t2,tc,xi,z + real(WP), dimension(3,3) :: PK_inv + real(WP) :: dist,t,w + real(WP) :: stretch,max_stretch,mu,kk, correcMagNum, correcMagDenom + real(WP) :: nc,rc,kc + integer :: nb,nbond + logical :: found_bond + ! Recompute a few physical parameters + mu=this%elastic_modulus/(2.0_WP+2.0_WP*this%poisson_ratio) + kk=this%elastic_modulus/(3.0_WP-6.0_WP*this%poisson_ratio) + + if (is2D) then + if (this%cfg%nx.eq.1) t=this%cfg%xL + if (this%cfg%ny.eq.1) t=this%cfg%yL + if (this%cfg%nz.eq.1) t=this%cfg%zL + max_stretch=sqrt(this%crit_energy/((6.0_WP*mu/Pi+16.0_WP/(9.0_WP*Pi**2)*(kk-2.0_WP*mu))*this%delta)) + kc=15.0_WP*48.0_WP*this%elastic_modulus/(Pi*5.0_WP*t*this%delta**3) + else + max_stretch=sqrt(this%crit_energy/((3.0_WP*mu+(kk-5.0_WP*mu/3.0_WP)*0.75_WP**4)*this%delta)) + kc=15.0_WP*12.0_WP*this%elastic_modulus/(Pi*this%delta**4) + end if + nc=1.0_WP + this%min_dist=huge(1.0_WP) + ! Loop over particles + do n1=1,this%np_ + ! Particles marked 0 do not update their forces + if (this%p(n1)%id.eq.0) cycle + ! Create copy of our particle + p1=this%p(n1) + ! Zero out bond force + p1%Abond=0.0_WP + ! Zero out PK_inv + PK_inv=0.0_WP + ! Zero out correcmag num and denom + correcMagNum = 0.0_WP + correcMagDenom = 0.0_WP + ! Loop over neighbor cells + do k=p1%ind(3)-this%nb,p1%ind(3)+this%nb + do j=p1%ind(2)-this%nb,p1%ind(2)+this%nb + do i=p1%ind(1)-this%nb,p1%ind(1)+this%nb + ! Loop over particles in that cell + do nn=1,npic(i,j,k) + ! Create copy of our neighbor + n2=ipic(nn,i,j,k) + if (n2.gt.0) then + p2=this%p(+n2) + else if (n2.lt.0) then + p2=this%g(-n2) + end if + ! Current distance + rpos=p2%pos-p1%pos + dist=sqrt(dot_product(rpos,rpos)) + ! Check if a bond exists + found_bond=.false. + do nb=1,max_bond + if (p1%ibond(nb).eq.p2%i) then + ! Check for breakage first + stretch=(dist-p1%dbond(nb))/p1%dbond(nb) + if (stretch.gt.max_stretch) then + ! Remove the bond and flag as surface particle + p1%ibond(nb)=0 + p1%dbond(nb)=0.0_WP + cycle + end if + w = wgauss(p1%dbond(nb),this%delta) + xi = p2%ipos-p1%ipos + ! Force density 1->2 + t1 = w*MATMUL(p1%PK_inv,xi) + ! Force density 2->1 + t2 = w*MATMUL(p2%PK_inv,xi) + ! Force correction term + z = rpos-MATMUL(p1%F,xi) + tc = w*(9.0_WP*kk/(Pi * this%delta**4))*(dot_product(xi,z)/(sqrt(dot_product(xi,xi)))**3)*xi + ! Compute bond acceleration + p1%Abond=p1%Abond+(t1+t2+tc)*p2%vol/this%rho + correcMagNum = correcMagNum + sqrt(sum(tc**2)) + correcMagDenom = correcMagDenom + max((sqrt(sum(t1**2)) + sqrt(sum(t2**2)) + sqrt(sum(tc**2))),epsilon(1.0_WP)) + ! If still here, we have an active bond + found_bond=.true. + ! Determine minimum bond distance + this%min_dist=min(this%min_dist,dist) + cycle + end if + end do + ! Add collision force now + ! if (is2D) then + ! rc=p1%vol**(1.0_WP/2.0_WP) + ! else + ! rc=p1%vol**(1.0_WP/3.0_WP) + ! end if + ! if (.not.found_bond.and.p1%i.ne.p2%i.and.dist.lt.rc) then + ! p1%Abond=p1%Abond-max(kc*((rc/dist)**nc-1.0_WP),0.0_WP)*(rpos/dist)*p1%vol/this%rho + ! p1%flag = -2 + ! end if + end do + end do + end do + end do + ! Sum up contribution + p1%correcMag = correcMagNum/correcMagDenom + ! Deal with dimensionality + if (this%cfg%nx.eq.1) p1%Abond(1)=0.0_WP + if (this%cfg%ny.eq.1) p1%Abond(2)=0.0_WP + if (this%cfg%nz.eq.1) p1%Abond(3)=0.0_WP + ! Copy back the particle + this%p(n1)=p1 + end do + ! Get global minimum + call MPI_ALLREDUCE(MPI_IN_PLACE,this%min_dist,1,MPI_REAL_WP,MPI_MIN,this%cfg%comm,ierr) + end block update_bond_force + + ! Clean up + if (allocated(npic)) deallocate(npic) + if (allocated(ipic)) deallocate(ipic) + + end subroutine get_bond_force + + + !> Advance the particle equations by a specified time step dt + !> p%id=-2 => do not solve for position nor velocity + !> p%id=-1 => do not solve for velocity + !> p%id= 0 => do not update force + + subroutine advance(this,dt,cool_down,continuous)!,stress_x,stress_y,stress_z) + use mpi_f08, only : MPI_SUM,MPI_INTEGER,MPI_IN_PLACE + use mathtools, only: Pi + implicit none + class(lss), intent(inout) :: this + real(WP), intent(inout) :: dt !< Timestep size over which to advance + logical, intent(in) :: cool_down,continuous + ! real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(inout) :: stress_x !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + ! real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(inout) :: stress_y !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + ! real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(inout) :: stress_z !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + integer :: n,ierr + real(WP) :: beta + ! real(WP), dimension(3) :: stress + + ! Zero out number of particles removed + this%np_out=0 + if(cool_down.or.continuous) then + beta = this%beta + else + beta = 0.0_WP + end if + ! Advance velocity based on old force and position based on mid-velocity + ! print*, beta + do n=1,this%np_ + if(cool_down.and.this%p(n)%id.eq.-1) this%p(n)%vel = 0.0_WP + ! Advance with Verlet scheme + if (this%p(n)%id.gt.-1) this%p(n)%vel=(1.0_WP-beta)*this%p(n)%vel+0.5_WP*dt*(this%gravity+this%p(n)%Abond+this%p(n)%Afluid) + if (this%p(n)%id.gt.-2) this%p(n)%pos=this%p(n)%pos+dt*this%p(n)%vel + this%p(n)%displacement=this%p(n)%pos-this%p(n)%ipos + ! Relocalize + this%p(n)%ind=this%cfg%get_ijk_global(this%p(n)%pos,this%p(n)%ind) + ! Correct the position to take into account periodicity + if (this%cfg%xper) this%p(n)%pos(1)=this%cfg%x(this%cfg%imin)+modulo(this%p(n)%pos(1)-this%cfg%x(this%cfg%imin),this%cfg%xL) + if (this%cfg%yper) this%p(n)%pos(2)=this%cfg%y(this%cfg%jmin)+modulo(this%p(n)%pos(2)-this%cfg%y(this%cfg%jmin),this%cfg%yL) + if (this%cfg%zper) this%p(n)%pos(3)=this%cfg%z(this%cfg%kmin)+modulo(this%p(n)%pos(3)-this%cfg%z(this%cfg%kmin),this%cfg%zL) + ! Handle particles that have left the domain + if (this%p(n)%pos(1).lt.this%cfg%x(this%cfg%imin).or.this%p(n)%pos(1).gt.this%cfg%x(this%cfg%imax+1)) this%p(n)%flag=1 + if (this%p(n)%pos(2).lt.this%cfg%y(this%cfg%jmin).or.this%p(n)%pos(2).gt.this%cfg%y(this%cfg%jmax+1)) this%p(n)%flag=1 + if (this%p(n)%pos(3).lt.this%cfg%z(this%cfg%kmin).or.this%p(n)%pos(3).gt.this%cfg%z(this%cfg%kmax+1)) this%p(n)%flag=1 + ! Relocalize the particle + this%p(n)%ind=this%cfg%get_ijk_global(this%p(n)%pos,this%p(n)%ind) + ! Count number of particles removed + if (this%p(n)%flag.eq.1) this%np_out=this%np_out+1 + end do + + ! Communicate particles + call this%sync() + + ! Sum up particles removed + call MPI_ALLREDUCE(this%np_out,n,1,MPI_INTEGER,MPI_SUM,this%cfg%comm,ierr); this%np_out=n + + ! Calculate bond force + call this%get_bond_force() + + ! Advance velocity only based on new force + do n=1,this%np_ + ! Advance with Verlet scheme + if (this%p(n)%id.le.-1) cycle + ! stress=this%cfg%get_velocity(pos=this%p(n)%pos,i0=this%p(n)%ind(1),j0=this%p(n)%ind(2),k0=this%p(n)%ind(3),U=stress_x,V=stress_y,W=stress_z) + ! this%p(n)%Afluid=stress/this%rho + ! this%p(n)%Afluid=0.0_WP + ! A Fluid is zero in the init, but is non-zero for pulling elements if specified + this%p(n)%vel=this%p(n)%vel*(1.0_WP-beta)+0.5_WP*dt*(this%gravity+this%p(n)%Abond+this%p(n)%Afluid) + end do + + ! Recompute volume fraction + ! call this%update_VF() + + ! Log/screen output + logging: block + use, intrinsic :: iso_fortran_env, only: output_unit + use param, only: verbose + use messager, only: log + use string, only: str_long + character(len=str_long) :: message + if (this%cfg%amRoot) then + write(message,'("Particle solver [",a,"] on partitioned grid [",a,"]: ",i0," particles were advanced")') trim(this%name),trim(this%cfg%name),this%np + if (verbose.gt.1) write(output_unit,'(a)') trim(message) + if (verbose.gt.0) call log(message) + end if + end block logging + + end subroutine advance + + ! subroutine stretch(this,dt)!,stress_x,stress_y,stress_z) + ! use mpi_f08, only : MPI_SUM,MPI_INTEGER,MPI_IN_PLACE + ! use mathtools, only: Pi + ! implicit none + ! class(lss), intent(inout) :: this + ! real(WP), intent(inout) :: dt !< Timestep size over which to advance + ! real(WP) :: mu + ! integer :: n,ierr + ! real(WP), dimension(:,:), allocatable :: temp_gd + + ! allocate(temp_gd(this%np_, 3)) + ! !======================================================================================== + ! ! X-Axis Stretch: + ! ! Zero out number of particles removed + ! this%np_out=0 + ! do n=1,this%np_ + ! ! Stretch the beam along the x axis with a uniform strain-rate of 0.001 + ! this%p(n)%pos(1)=this%p(n)%pos(1)*1.001_WP + ! end do + + ! ! Communicate particles + ! call this%sync() + + ! ! Calculate bond force + ! call this%get_bond_force() + + ! mu=this%elastic_modulus/(2.0_WP+2.0_WP*this%poisson_ratio) + + ! do n=1,this%np_ + ! temp_gd(n,1)=0.001_WP/this%p(n)%dil + ! end do + + ! !======================================================================================== + ! ! Y-Axis Stretch: + ! ! Zero out number of particles removed + ! this%np_out=0 + ! do n=1,this%np_ + ! ! Stretch the beam along the x axis with a uniform strain-rate of 0.001 + ! this%p(n)%pos(1)=this%p(n)%pos(1)/1.001_WP + ! this%p(n)%pos(2)=this%p(n)%pos(2)*1.001_WP + ! end do + + ! ! Communicate particles + ! call this%sync() + + ! ! Calculate bond force + ! call this%get_bond_force() + + ! mu=this%elastic_modulus/(2.0_WP+2.0_WP*this%poisson_ratio) + + ! do n=1,this%np_ + ! temp_gd(n,2)=0.001_WP/this%p(n)%dil + ! end do + + ! !======================================================================================== + ! ! Z-Axis Stretch: + ! ! Zero out number of particles removed + ! this%np_out=0 + ! do n=1,this%np_ + ! ! Stretch the beam along the x axis with a uniform strain-rate of 0.001 + ! this%p(n)%pos(2)=this%p(n)%pos(2)/1.001_WP + ! this%p(n)%pos(3)=this%p(n)%pos(3)*1.001_WP + ! end do + + ! ! Communicate particles + ! call this%sync() + + ! ! Calculate bond force + ! call this%get_bond_force() + + ! mu=this%elastic_modulus/(2.0_WP+2.0_WP*this%poisson_ratio) + + ! do n=1,this%np_ + ! temp_gd(n,3)=0.001_WP/this%p(n)%dil + ! end do + + ! ! Put the particle back where it was + ! do n=1,this%np_ + ! this%p(n)%pos(3)=this%p(n)%pos(3)/1.001_WP + ! end do + + ! !====================================================================================== + + ! ! Now stretch particle for the first time step + + ! do n=1,this%np_ + ! ! Stretch the beam along the x axis with a uniform strain-rate of 0.001 + ! this%p(n)%gd=temp_gd(n,:) + ! end do + + ! do n=1,this%np_ + ! ! Stretch the beam along the x axis with a uniform strain-rate of 0.001 + ! this%p(n)%pos=this%p(n)%pos*1.001_WP + ! this%p(n)%displacement=this%p(n)%pos-this%p(n)%ipos + ! end do + + ! ! Communicate particles + ! call this%sync() + + ! ! Calculate bond force + ! call this%get_bond_force() + + ! deallocate(temp_gd) + + + ! end subroutine stretch + + !> Update particle volume fraction using our current particles + subroutine update_VF(this) + implicit none + class(lss), intent(inout) :: this + integer :: i + ! Reset volume fraction and momentum + this%VF=0.0_WP; this%VFU=0.0_WP; this%VFV=0.0_WP; this%VFW=0.0_WP + ! Transfer particle volume + do i=1,this%np_ + ! Skip inactive particle + if (this%p(i)%flag.eq.1) cycle + ! Transfer volume to mesh + call this%extrapolate(Ap=this%p(i)%vol,xp=this%p(i)%pos(1),yp=this%p(i)%pos(2),zp=this%p(i)%pos(3),ip=this%p(i)%ind(1),jp=this%p(i)%ind(2),kp=this%p(i)%ind(3),A=this%VF,dir='SC') + call this%extrapolate(Ap=this%p(i)%vol*this%p(i)%vel(1),xp=this%p(i)%pos(1),yp=this%p(i)%pos(2),zp=this%p(i)%pos(3),ip=this%p(i)%ind(1),jp=this%p(i)%ind(2),kp=this%p(i)%ind(3),A=this%VFU,dir='U') + call this%extrapolate(Ap=this%p(i)%vol*this%p(i)%vel(2),xp=this%p(i)%pos(1),yp=this%p(i)%pos(2),zp=this%p(i)%pos(3),ip=this%p(i)%ind(1),jp=this%p(i)%ind(2),kp=this%p(i)%ind(3),A=this%VFV,dir='V') + call this%extrapolate(Ap=this%p(i)%vol*this%p(i)%vel(3),xp=this%p(i)%pos(1),yp=this%p(i)%pos(2),zp=this%p(i)%pos(3),ip=this%p(i)%ind(1),jp=this%p(i)%ind(2),kp=this%p(i)%ind(3),A=this%VFW,dir='W') + end do + ! Sum at boundaries + call this%cfg%syncsum(this%VF) + call this%cfg%syncsum(this%VFU) + call this%cfg%syncsum(this%VFV) + call this%cfg%syncsum(this%VFW) + ! Clip + where (this%VF.gt.1.0_WP) this%VF=1.0_WP + where (this%VF.lt.0.0_WP) this%VF=0.0_WP + end subroutine update_VF + + + !> Compute regularized delta function + subroutine get_delta(this,delta,ic,jc,kc,xp,yp,zp,dir) + implicit none + class(lss), intent(inout) :: this + real(WP), intent(out) :: delta !< Return delta function + integer, intent(in) :: ic,jc,kc !< Cell index + real(WP), intent(in) :: xp,yp,zp !< Position of marker + character(len=*) :: dir + real(WP) :: deltax,deltay,deltaz,r + + ! Compute in X + if (trim(adjustl(dir)).eq.'U') then + r=(xp-this%cfg%x(ic))*this%cfg%dxmi(ic) + deltax=roma_kernel(r)*this%cfg%dxmi(ic) + else + r=(xp-this%cfg%xm(ic))*this%cfg%dxi(ic) + deltax=roma_kernel(r)*this%cfg%dxi(ic) + end if + + ! Compute in Y + if (trim(adjustl(dir)).eq.'V') then + r=(yp-this%cfg%y(jc))*this%cfg%dymi(jc) + deltay=roma_kernel(r)*this%cfg%dymi(jc) + else + r=(yp-this%cfg%ym(jc))*this%cfg%dyi(jc) + deltay=roma_kernel(r)*this%cfg%dyi(jc) + end if + + ! Compute in Z + if (trim(adjustl(dir)).eq.'W') then + r=(zp-this%cfg%z(kc))*this%cfg%dzmi(kc) + deltaz=roma_kernel(r)*this%cfg%dzmi(kc) + else + r=(zp-this%cfg%zm(kc))*this%cfg%dzi(kc) + deltaz=roma_kernel(r)*this%cfg%dzi(kc) + end if + !else + + ! Put it all together + delta=deltax*deltay*deltaz + + contains + ! Mollification kernel + ! Roma A, Peskin C and Berger M 1999 J. Comput. Phys. 153 509–534 + function roma_kernel(r) result(phi) + implicit none + real(WP), intent(in) :: r + real(WP) :: phi + if (abs(r).le.0.5_WP) then + phi=1.0_WP/3.0_WP*(1.0_WP+sqrt(-3.0_WP*r**2+1.0_WP)) + else if (abs(r).gt.0.5_WP .and. abs(r).le.1.5_WP) then + phi=1.0_WP/6.0_WP*(5.0_WP-3.0_WP*abs(r)-sqrt(-3.0_WP*(1.0_WP-abs(r))**2+1.0_WP)) + else + phi=0.0_WP + end if + end function roma_kernel + + end subroutine get_delta + + + !> Interpolation routine + function interpolate(this,A,xp,yp,zp,ip,jp,kp,dir) result(Ap) + implicit none + class(lss), intent(inout) :: this + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(in) :: A !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + real(WP), intent(in) :: xp,yp,zp + integer, intent(in) :: ip,jp,kp + character(len=*) :: dir + real(WP) :: Ap + integer :: di,dj,dk + integer :: i1,i2,j1,j2,k1,k2 + real(WP), dimension(-2:+2,-2:+2,-2:+2) :: delta + ! Get the interpolation points + i1=ip-2; i2=ip+2 + j1=jp-2; j2=jp+2 + k1=kp-2; k2=kp+2 + ! Loop over neighboring cells and compute regularized delta function + do dk=-2,+2 + do dj=-2,+2 + do di=-2,+2 + call this%get_delta(delta=delta(di,dj,dk),ic=ip+di,jc=jp+dj,kc=kp+dk,xp=xp,yp=yp,zp=zp,dir=trim(dir)) + end do + end do + end do + ! Perform the actual interpolation on Ap + Ap = sum(delta*A(i1:i2,j1:j2,k1:k2))*this%cfg%vol(ip,jp,kp) + end function interpolate + + + !> Extrapolation routine + subroutine extrapolate(this,Ap,xp,yp,zp,ip,jp,kp,A,dir) + use messager, only: die + implicit none + class(lss), intent(inout) :: this + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:) :: A !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + real(WP), intent(in) :: xp,yp,zp + integer, intent(in) :: ip,jp,kp + real(WP), intent(in) :: Ap + character(len=*) :: dir + real(WP), dimension(-2:+2,-2:+2,-2:+2) :: delta + integer :: di,dj,dk + ! If particle has left processor domain or reached last ghost cell, kill job + if ( ip.lt.this%cfg%imin_-1.or.ip.gt.this%cfg%imax_+1.or.& + & jp.lt.this%cfg%jmin_-1.or.jp.gt.this%cfg%jmax_+1.or.& + & kp.lt.this%cfg%kmin_-1.or.kp.gt.this%cfg%kmax_+1) then + write(*,*) ip,jp,kp,xp,yp,zp + call die('[df extrapolate] Particle has left the domain') + end if + ! Loop over neighboring cells and compute regularized delta function + do dk=-2,+2 + do dj=-2,+2 + do di=-2,+2 + call this%get_delta(delta=delta(di,dj,dk),ic=ip+di,jc=jp+dj,kc=kp+dk,xp=xp,yp=yp,zp=zp,dir=trim(dir)) + end do + end do + end do + ! Perform the actual extrapolation on A + A(ip-2:ip+2,jp-2:jp+2,kp-2:kp+2)=A(ip-2:ip+2,jp-2:jp+2,kp-2:kp+2)+delta*Ap + end subroutine extrapolate + + + !> Calculate the CFL + subroutine get_cfl(this,dt,cfl) + use mpi_f08, only: MPI_ALLREDUCE,MPI_MAX + use parallel, only: MPI_REAL_WP + implicit none + class(lss), intent(inout) :: this + real(WP), intent(in) :: dt + real(WP), intent(out) :: cfl + integer :: i,ierr + real(WP) :: my_CFLp_x,my_CFLp_y,my_CFLp_z,kk,mu,a + + ! Set the CFLs to zero + my_CFLp_x=0.0_WP; my_CFLp_y=0.0_WP; my_CFLp_z=0.0_WP + do i=1,this%np_ + my_CFLp_x=max(my_CFLp_x,abs(this%p(i)%vel(1))*this%cfg%dxi(this%p(i)%ind(1))) + my_CFLp_y=max(my_CFLp_y,abs(this%p(i)%vel(2))*this%cfg%dyi(this%p(i)%ind(2))) + my_CFLp_z=max(my_CFLp_z,abs(this%p(i)%vel(3))*this%cfg%dzi(this%p(i)%ind(3))) + end do + my_CFLp_x=my_CFLp_x*dt; my_CFLp_y=my_CFLp_y*dt; my_CFLp_z=my_CFLp_z*dt + + ! Get the parallel max + call MPI_ALLREDUCE(my_CFLp_x,this%CFLp_x,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + call MPI_ALLREDUCE(my_CFLp_y,this%CFLp_y,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + call MPI_ALLREDUCE(my_CFLp_z,this%CFLp_z,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + + ! CFL based on elastic wave speed in material + kk=this%elastic_modulus/(3.0_WP-6.0_WP*this%poisson_ratio) + mu=this%elastic_modulus/(2.0_WP+2.0_WP*this%poisson_ratio) + a=sqrt((kk+4.0_WP*mu/3.0_WP)/this%rho) + this%CFLp_a=dt*a*3/this%delta + + ! Return the maximum CFL + cfl=max(this%CFLp_x,this%CFLp_y,this%CFLp_z,this%CFLp_a) + + end subroutine get_cfl + + + !> Extract various monitoring data from particle field + subroutine get_max(this) + use mpi_f08, only: MPI_ALLREDUCE,MPI_MAX,MPI_MIN,MPI_SUM + use parallel, only: MPI_REAL_WP + implicit none + class(lss), intent(inout) :: this + real(WP) :: buf,safe_np + real(WP), dimension(3) :: buf3D + integer :: i,j,k,ierr + + ! Create safe np + safe_np=real(max(this%np,1),WP) + + ! Velocity min/max/mean + this%Umin=huge(1.0_WP); this%Umax=-huge(1.0_WP); this%Umean=0.0_WP + this%Vmin=huge(1.0_WP); this%Vmax=-huge(1.0_WP); this%Vmean=0.0_WP + this%Wmin=huge(1.0_WP); this%Wmax=-huge(1.0_WP); this%Wmean=0.0_WP + this%ibmForce=0.0_WP + do i=1,this%np_ + this%Umin=min(this%Umin,this%p(i)%vel(1)); this%Umax=max(this%Umax,this%p(i)%vel(1)); this%Umean=this%Umean+this%p(i)%vel(1) + this%Vmin=min(this%Vmin,this%p(i)%vel(2)); this%Vmax=max(this%Vmax,this%p(i)%vel(2)); this%Vmean=this%Vmean+this%p(i)%vel(2) + this%Wmin=min(this%Wmin,this%p(i)%vel(3)); this%Wmax=max(this%Wmax,this%p(i)%vel(3)); this%Wmean=this%Wmean+this%p(i)%vel(3) + this%ibmForce=this%ibmForce+this%p(i)%Afluid*this%p(i)%vol*this%rho + end do + call MPI_ALLREDUCE(this%Umin ,buf,1,MPI_REAL_WP,MPI_MIN,this%cfg%comm,ierr); this%Umin =buf + call MPI_ALLREDUCE(this%Umax ,buf,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr); this%Umax =buf + call MPI_ALLREDUCE(this%Umean,buf,1,MPI_REAL_WP,MPI_SUM,this%cfg%comm,ierr); this%Umean=buf/safe_np + call MPI_ALLREDUCE(this%Vmin ,buf,1,MPI_REAL_WP,MPI_MIN,this%cfg%comm,ierr); this%Vmin =buf + call MPI_ALLREDUCE(this%Vmax ,buf,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr); this%Vmax =buf + call MPI_ALLREDUCE(this%Vmean,buf,1,MPI_REAL_WP,MPI_SUM,this%cfg%comm,ierr); this%Vmean=buf/safe_np + call MPI_ALLREDUCE(this%Wmin ,buf,1,MPI_REAL_WP,MPI_MIN,this%cfg%comm,ierr); this%Wmin =buf + call MPI_ALLREDUCE(this%Wmax ,buf,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr); this%Wmax =buf + call MPI_ALLREDUCE(this%Wmean,buf,1,MPI_REAL_WP,MPI_SUM,this%cfg%comm,ierr); this%Wmean=buf/safe_np + call MPI_ALLREDUCE(this%ibmForce,buf3D,3,MPI_REAL_WP,MPI_SUM,this%cfg%comm,ierr); this%ibmForce=buf3D + + ! Get max volume fraction + this%VFmax =-huge(1.0_WP) + do k=this%cfg%kmin_,this%cfg%kmax_ + do j=this%cfg%jmin_,this%cfg%jmax_ + do i=this%cfg%imin_,this%cfg%imax_ + this%VFmax=max(this%VFmax,this%VF(i,j,k)) + end do + end do + end do + call MPI_ALLREDUCE(this%VFmax,buf,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr); this%VFmax=buf + + end subroutine get_max + + + !> Update particle mesh using our current particles + subroutine update_partmesh(this,pmesh) + use partmesh_class, only: partmesh + implicit none + class(lss), intent(inout) :: this + class(partmesh), intent(inout) :: pmesh + integer :: i + ! Reset particle mesh storage + call pmesh%reset() + ! Nothing else to do if no particle is present + if (this%np_.eq.0) return + ! Copy particle info + call pmesh%set_size(this%np_) + do i=1,this%np_ + pmesh%pos(:,i)=this%p(i)%pos + end do + end subroutine update_partmesh + + + !> Creation of the MPI datatype for particle + subroutine prepare_mpi_part() + use mpi_f08 + use messager, only: die + implicit none + integer(MPI_ADDRESS_KIND), dimension(part_nblock) :: disp + integer(MPI_ADDRESS_KIND) :: lb,extent + type(MPI_Datatype) :: MPI_PART_TMP + integer :: i,mysize,ierr + ! Prepare the displacement array + disp(1)=0 + do i=2,part_nblock + call MPI_Type_size(part_tblock(i-1),mysize,ierr) + disp(i)=disp(i-1)+int(mysize,MPI_ADDRESS_KIND)*int(part_lblock(i-1),MPI_ADDRESS_KIND) + end do + ! Create and commit the new type + call MPI_Type_create_struct(part_nblock,part_lblock,disp,part_tblock,MPI_PART_TMP,ierr) + call MPI_Type_get_extent(MPI_PART_TMP,lb,extent,ierr) + call MPI_Type_create_resized(MPI_PART_TMP,lb,extent,MPI_PART,ierr) + call MPI_Type_commit(MPI_PART,ierr) + ! If a problem was encountered, say it + if (ierr.ne.0) call die('[lss prepare_mpi_part] MPI Particle type creation failed') + ! Get the size of this type + call MPI_type_size(MPI_PART,MPI_PART_SIZE,ierr) + end subroutine prepare_mpi_part + + + !> Share particles across processor boundaries + subroutine share(this,nover) + use mpi_f08 + use messager, only: warn,die + implicit none + class(lss), intent(inout) :: this + integer, optional :: nover + type(part), dimension(:), allocatable :: tosend + type(part), dimension(:), allocatable :: torecv + integer :: no,nsend,nrecv + type(MPI_Status) :: status + integer :: icnt,isrc,idst,ierr + integer :: i,n + + ! Check overlap size + if (present(nover)) then + no=nover + if (no.gt.this%cfg%no) then + call warn('[lss share] Specified overlap is larger than that of cfg - reducing no') + no=this%cfg%no + else if (no.le.0) then + call die('[lss share] Specified overlap cannot be less or equal to zero') + end if + else + no=1 + end if + + ! Clean up ghost array + call this%resize_ghost(n=0); this%ng_=0 + + ! Share ghost particles in -x (no ghosts are sent here) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(1).lt.this%cfg%imin_+no) nsend=nsend+1 + end do + allocate(tosend(nsend)) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(1).lt.this%cfg%imin_+no) then + nsend=nsend+1 + tosend(nsend)=this%p(n) + if (this%cfg%xper.and.tosend(nsend)%ind(1).lt.this%cfg%imin+no) then + tosend(nsend)%pos(1)=tosend(nsend)%pos(1)+this%cfg%xL + tosend(nsend)%ind(1)=tosend(nsend)%ind(1)+this%cfg%nx + end if + end if + end do + nrecv=0 + call MPI_CART_SHIFT(this%cfg%comm,0,-1,isrc,idst,ierr) + call MPI_SENDRECV(nsend,1,MPI_INTEGER,idst,0,nrecv,1,MPI_INTEGER,isrc,0,this%cfg%comm,status,ierr) + allocate(torecv(nrecv)) + call MPI_SENDRECV(tosend,nsend,MPI_PART,idst,0,torecv,nrecv,MPI_PART,isrc,0,this%cfg%comm,status,ierr) + call this%resize_ghost(this%ng_+nrecv) + this%g(this%ng_+1:this%ng_+nrecv)=torecv + this%ng_=this%ng_+nrecv + if (allocated(tosend)) deallocate(tosend) + if (allocated(torecv)) deallocate(torecv) + + ! Share ghost particles in +x (no ghosts are sent here) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(1).gt.this%cfg%imax_-no) nsend=nsend+1 + end do + allocate(tosend(nsend)) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(1).gt.this%cfg%imax_-no) then + nsend=nsend+1 + tosend(nsend)=this%p(n) + if (this%cfg%xper.and.tosend(nsend)%ind(1).gt.this%cfg%imax-no) then + tosend(nsend)%pos(1)=tosend(nsend)%pos(1)-this%cfg%xL + tosend(nsend)%ind(1)=tosend(nsend)%ind(1)-this%cfg%nx + end if + end if + end do + nrecv=0 + call MPI_CART_SHIFT(this%cfg%comm,0,+1,isrc,idst,ierr) + call MPI_SENDRECV(nsend,1,MPI_INTEGER,idst,0,nrecv,1,MPI_INTEGER,isrc,0,this%cfg%comm,status,ierr) + allocate(torecv(nrecv)) + call MPI_SENDRECV(tosend,nsend,MPI_PART,idst,0,torecv,nrecv,MPI_PART,isrc,0,this%cfg%comm,status,ierr) + call this%resize_ghost(this%ng_+nrecv) + this%g(this%ng_+1:this%ng_+nrecv)=torecv + this%ng_=this%ng_+nrecv + if (allocated(tosend)) deallocate(tosend) + if (allocated(torecv)) deallocate(torecv) + + ! Share ghost particles in -y (ghosts need to be sent now) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(2).lt.this%cfg%jmin_+no) nsend=nsend+1 + end do + do n=1,this%ng_ + if (this%g(n)%ind(2).lt.this%cfg%jmin_+no) nsend=nsend+1 + end do + allocate(tosend(nsend)) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(2).lt.this%cfg%jmin_+no) then + nsend=nsend+1 + tosend(nsend)=this%p(n) + if (this%cfg%yper.and.tosend(nsend)%ind(2).lt.this%cfg%jmin+no) then + tosend(nsend)%pos(2)=tosend(nsend)%pos(2)+this%cfg%yL + tosend(nsend)%ind(2)=tosend(nsend)%ind(2)+this%cfg%ny + end if + end if + end do + do n=1,this%ng_ + if (this%g(n)%ind(2).lt.this%cfg%jmin_+no) then + nsend=nsend+1 + tosend(nsend)=this%g(n) + if (this%cfg%yper.and.tosend(nsend)%ind(2).lt.this%cfg%jmin+no) then + tosend(nsend)%pos(2)=tosend(nsend)%pos(2)+this%cfg%yL + tosend(nsend)%ind(2)=tosend(nsend)%ind(2)+this%cfg%ny + end if + end if + end do + nrecv=0 + call MPI_CART_SHIFT(this%cfg%comm,1,-1,isrc,idst,ierr) + call MPI_SENDRECV(nsend,1,MPI_INTEGER,idst,0,nrecv,1,MPI_INTEGER,isrc,0,this%cfg%comm,status,ierr) + allocate(torecv(nrecv)) + call MPI_SENDRECV(tosend,nsend,MPI_PART,idst,0,torecv,nrecv,MPI_PART,isrc,0,this%cfg%comm,status,ierr) + call this%resize_ghost(this%ng_+nrecv) + this%g(this%ng_+1:this%ng_+nrecv)=torecv + this%ng_=this%ng_+nrecv + if (allocated(tosend)) deallocate(tosend) + if (allocated(torecv)) deallocate(torecv) + + ! Share ghost particles in +y (ghosts need to be sent now - but not newly received ghosts!) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(2).gt.this%cfg%jmax_-no) nsend=nsend+1 + end do + do n=1,this%ng_-nrecv + if (this%g(n)%ind(2).gt.this%cfg%jmax_-no) nsend=nsend+1 + end do + allocate(tosend(nsend)) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(2).gt.this%cfg%jmax_-no) then + nsend=nsend+1 + tosend(nsend)=this%p(n) + if (this%cfg%yper.and.tosend(nsend)%ind(2).gt.this%cfg%jmax-no) then + tosend(nsend)%pos(2)=tosend(nsend)%pos(2)-this%cfg%yL + tosend(nsend)%ind(2)=tosend(nsend)%ind(2)-this%cfg%ny + end if + end if + end do + do n=1,this%ng_-nrecv + if (this%g(n)%ind(2).gt.this%cfg%jmax_-no) then + nsend=nsend+1 + tosend(nsend)=this%g(n) + if (this%cfg%yper.and.tosend(nsend)%ind(2).gt.this%cfg%jmax-no) then + tosend(nsend)%pos(2)=tosend(nsend)%pos(2)-this%cfg%yL + tosend(nsend)%ind(2)=tosend(nsend)%ind(2)-this%cfg%ny + end if + end if + end do + nrecv=0 + call MPI_CART_SHIFT(this%cfg%comm,1,+1,isrc,idst,ierr) + call MPI_SENDRECV(nsend,1,MPI_INTEGER,idst,0,nrecv,1,MPI_INTEGER,isrc,0,this%cfg%comm,status,ierr) + allocate(torecv(nrecv)) + call MPI_SENDRECV(tosend,nsend,MPI_PART,idst,0,torecv,nrecv,MPI_PART,isrc,0,this%cfg%comm,status,ierr) + call this%resize_ghost(this%ng_+nrecv) + this%g(this%ng_+1:this%ng_+nrecv)=torecv + this%ng_=this%ng_+nrecv + if (allocated(tosend)) deallocate(tosend) + if (allocated(torecv)) deallocate(torecv) + + ! Share ghost particles in -z (ghosts need to be sent now) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(3).lt.this%cfg%kmin_+no) nsend=nsend+1 + end do + do n=1,this%ng_ + if (this%g(n)%ind(3).lt.this%cfg%kmin_+no) nsend=nsend+1 + end do + allocate(tosend(nsend)) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(3).lt.this%cfg%kmin_+no) then + nsend=nsend+1 + tosend(nsend)=this%p(n) + if (this%cfg%zper.and.tosend(nsend)%ind(3).lt.this%cfg%kmin+no) then + tosend(nsend)%pos(3)=tosend(nsend)%pos(3)+this%cfg%zL + tosend(nsend)%ind(3)=tosend(nsend)%ind(3)+this%cfg%nz + end if + end if + end do + do n=1,this%ng_ + if (this%g(n)%ind(3).lt.this%cfg%kmin_+no) then + nsend=nsend+1 + tosend(nsend)=this%g(n) + if (this%cfg%zper.and.tosend(nsend)%ind(3).lt.this%cfg%kmin+no) then + tosend(nsend)%pos(3)=tosend(nsend)%pos(3)+this%cfg%zL + tosend(nsend)%ind(3)=tosend(nsend)%ind(3)+this%cfg%nz + end if + end if + end do + nrecv=0 + call MPI_CART_SHIFT(this%cfg%comm,2,-1,isrc,idst,ierr) + call MPI_SENDRECV(nsend,1,MPI_INTEGER,idst,0,nrecv,1,MPI_INTEGER,isrc,0,this%cfg%comm,status,ierr) + allocate(torecv(nrecv)) + call MPI_SENDRECV(tosend,nsend,MPI_PART,idst,0,torecv,nrecv,MPI_PART,isrc,0,this%cfg%comm,status,ierr) + call this%resize_ghost(this%ng_+nrecv) + this%g(this%ng_+1:this%ng_+nrecv)=torecv + this%ng_=this%ng_+nrecv + if (allocated(tosend)) deallocate(tosend) + if (allocated(torecv)) deallocate(torecv) + + ! Share ghost particles in +z (ghosts need to be sent now - but not newly received ghosts!) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(3).gt.this%cfg%kmax_-no) nsend=nsend+1 + end do + do n=1,this%ng_-nrecv + if (this%g(n)%ind(3).gt.this%cfg%kmax_-no) nsend=nsend+1 + end do + allocate(tosend(nsend)) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(3).gt.this%cfg%kmax_-no) then + nsend=nsend+1 + tosend(nsend)=this%p(n) + if (this%cfg%zper.and.tosend(nsend)%ind(3).gt.this%cfg%kmax-no) then + tosend(nsend)%pos(3)=tosend(nsend)%pos(3)-this%cfg%zL + tosend(nsend)%ind(3)=tosend(nsend)%ind(3)-this%cfg%nz + end if + end if + end do + do n=1,this%ng_-nrecv + if (this%g(n)%ind(3).gt.this%cfg%kmax_-no) then + nsend=nsend+1 + tosend(nsend)=this%g(n) + if (this%cfg%zper.and.tosend(nsend)%ind(3).gt.this%cfg%kmax-no) then + tosend(nsend)%pos(3)=tosend(nsend)%pos(3)-this%cfg%zL + tosend(nsend)%ind(3)=tosend(nsend)%ind(3)-this%cfg%nz + end if + end if + end do + nrecv=0 + call MPI_CART_SHIFT(this%cfg%comm,2,+1,isrc,idst,ierr) + call MPI_SENDRECV(nsend,1,MPI_INTEGER,idst,0,nrecv,1,MPI_INTEGER,isrc,0,this%cfg%comm,status,ierr) + allocate(torecv(nrecv)) + call MPI_SENDRECV(tosend,nsend,MPI_PART,idst,0,torecv,nrecv,MPI_PART,isrc,0,this%cfg%comm,status,ierr) + call this%resize_ghost(this%ng_+nrecv) + this%g(this%ng_+1:this%ng_+nrecv)=torecv + this%ng_=this%ng_+nrecv + if (allocated(tosend)) deallocate(tosend) + if (allocated(torecv)) deallocate(torecv) + + end subroutine share + + + !> Synchronize particle arrays across processors + subroutine sync(this) + use mpi_f08 + implicit none + class(lss), intent(inout) :: this + integer, dimension(0:this%cfg%nproc-1) :: nsend_proc,nrecv_proc + integer, dimension(0:this%cfg%nproc-1) :: nsend_disp,nrecv_disp + integer :: n,prank,ierr + type(part), dimension(:), allocatable :: buf_send + ! Recycle first to minimize communication load + call this%recycle() + ! Prepare information about what to send + nsend_proc=0 + do n=1,this%np_ + prank=this%cfg%get_rank(this%p(n)%ind) + nsend_proc(prank)=nsend_proc(prank)+1 + end do + nsend_proc(this%cfg%rank)=0 + ! Inform processors of what they will receive + call MPI_ALLtoALL(nsend_proc,1,MPI_INTEGER,nrecv_proc,1,MPI_INTEGER,this%cfg%comm,ierr) + ! Prepare displacements for all-to-all + nsend_disp(0)=0 + nrecv_disp(0)=this%np_ !< Directly add particles at the end of main array + do n=1,this%cfg%nproc-1 + nsend_disp(n)=nsend_disp(n-1)+nsend_proc(n-1) + nrecv_disp(n)=nrecv_disp(n-1)+nrecv_proc(n-1) + end do + ! Allocate buffer to send particles + allocate(buf_send(sum(nsend_proc))) + ! Pack the particles in the send buffer + nsend_proc=0 + do n=1,this%np_ + ! Get the rank + prank=this%cfg%get_rank(this%p(n)%ind) + ! Skip particles still inside + if (prank.eq.this%cfg%rank) cycle + ! Pack up for sending + nsend_proc(prank)=nsend_proc(prank)+1 + buf_send(nsend_disp(prank)+nsend_proc(prank))=this%p(n) + ! Flag particle for removal + this%p(n)%flag=1 + end do + ! Allocate buffer for receiving particles + call this%resize(this%np_+sum(nrecv_proc)) + ! Perform communication + call MPI_ALLtoALLv(buf_send,nsend_proc,nsend_disp,MPI_PART,this%p,nrecv_proc,nrecv_disp,MPI_PART,this%cfg%comm,ierr) + ! Deallocate buffer + deallocate(buf_send) + ! Recycle to remove duplicate particles + call this%recycle() + end subroutine sync + + + !> Adaptation of particle array size + subroutine resize(this,n) + implicit none + class(lss), intent(inout) :: this + integer, intent(in) :: n + type(part), dimension(:), allocatable :: tmp + integer :: size_now,size_new + ! Resize particle array to size n + if (.not.allocated(this%p)) then + ! Allocate directly to size n + allocate(this%p(n)) + this%p(1:n)%flag=1 + else + ! Update from a non-zero size to another non-zero size + size_now=size(this%p,dim=1) + if (n.gt.size_now) then + size_new=max(n,int(real(size_now,WP)*coeff_up)) + allocate(tmp(size_new)) + tmp(1:size_now)=this%p + tmp(size_now+1:)%flag=1 + call move_alloc(tmp,this%p) + else if (n.lt.int(real(size_now,WP)*coeff_dn)) then + allocate(tmp(n)) + tmp(1:n)=this%p(1:n) + call move_alloc(tmp,this%p) + end if + end if + end subroutine resize + + + !> Adaptation of ghost array size + subroutine resize_ghost(this,n) + implicit none + class(lss), intent(inout) :: this + integer, intent(in) :: n + type(part), dimension(:), allocatable :: tmp + integer :: size_now,size_new + ! Resize ghost array to size n + if (.not.allocated(this%g)) then + ! Allocate directly to size n + allocate(this%g(n)) + this%g(1:n)%flag=1 + else + ! Update from a non-zero size to another non-zero size + size_now=size(this%g,dim=1) + if (n.gt.size_now) then + size_new=max(n,int(real(size_now,WP)*coeff_up)) + allocate(tmp(size_new)) + tmp(1:size_now)=this%g + tmp(size_now+1:)%flag=1 + call move_alloc(tmp,this%g) + else if (n.lt.int(real(size_now,WP)*coeff_dn)) then + allocate(tmp(n)) + tmp(1:n)=this%g(1:n) + call move_alloc(tmp,this%g) + end if + end if + end subroutine resize_ghost + + + !> Clean-up of particle array by removing flag=1 particles + subroutine recycle(this) + implicit none + class(lss), intent(inout) :: this + integer :: new_size,i,ierr + ! Compact all active particles at the beginning of the array + new_size=0 + if (allocated(this%p)) then + do i=1,size(this%p,dim=1) + if (this%p(i)%flag.ne.1) then + new_size=new_size+1 + if (i.ne.new_size) then + this%p(new_size)=this%p(i) + this%p(i)%flag=1 + end if + end if + end do + end if + ! Resize to new size + call this%resize(new_size) + ! Update number of particles + this%np_=new_size + call MPI_ALLGATHER(this%np_,1,MPI_INTEGER,this%np_proc,1,MPI_INTEGER,this%cfg%comm,ierr) + this%np=sum(this%np_proc) + end subroutine recycle + + + !> Parallel write particles to file + subroutine write(this,filename) + use mpi_f08 + use messager, only: die + use parallel, only: info_mpiio + implicit none + class(lss), intent(inout) :: this + character(len=*), intent(in) :: filename + type(MPI_File) :: ifile + type(MPI_Status):: status + integer(kind=MPI_OFFSET_KIND) :: offset + integer :: i,ierr,iunit + + ! Root serial-writes the file header + if (this%cfg%amRoot) then + ! Open the file + open(newunit=iunit,file=trim(filename),form='unformatted',status='replace',access='stream',iostat=ierr) + if (ierr.ne.0) call die('[lss write] Problem encountered while serial-opening data file: '//trim(filename)) + ! Number of particles and particle object size + write(iunit) this%np,MPI_PART_SIZE + ! Done with the header + close(iunit) + end if + + ! The rest is done in parallel + call MPI_FILE_OPEN(this%cfg%comm,trim(filename),IOR(MPI_MODE_WRONLY,MPI_MODE_APPEND),info_mpiio,ifile,ierr) + if (ierr.ne.0) call die('[lss write] Problem encountered while parallel-opening data file: '//trim(filename)) + + ! Get current position + call MPI_FILE_GET_POSITION(ifile,offset,ierr) + + ! Compute the offset and write + do i=1,this%cfg%rank + offset=offset+int(this%np_proc(i),MPI_OFFSET_KIND)*int(MPI_PART_SIZE,MPI_OFFSET_KIND) + end do + if (this%np_.gt.0) call MPI_FILE_WRITE_AT(ifile,offset,this%p,this%np_,MPI_PART,status,ierr) + + ! Close the file + call MPI_FILE_CLOSE(ifile,ierr) + + ! Log/screen output + logging: block + use, intrinsic :: iso_fortran_env, only: output_unit + use param, only: verbose + use messager, only: log + use string, only: str_long + character(len=str_long) :: message + if (this%cfg%amRoot) then + write(message,'("[lss write] Wrote ",i0," particles to file [",a,"] on partitioned grid [",a,"]")') this%np,trim(filename),trim(this%cfg%name) + if (verbose.gt.2) write(output_unit,'(a)') trim(message) + if (verbose.gt.1) call log(message) + end if + end block logging + + end subroutine write + + + !> Parallel read particles to file + subroutine read(this,filename) + use mpi_f08 + use messager, only: die + use parallel, only: info_mpiio + implicit none + class(lss), intent(inout) :: this + character(len=*), intent(in) :: filename + type(MPI_File) :: ifile + type(MPI_Status):: status + integer(kind=MPI_OFFSET_KIND) :: offset,header_offset + integer :: i,j,ierr,npadd,psize,nchunk,cnt + integer, dimension(:,:), allocatable :: ppp + + ! First open the file in parallel + call MPI_FILE_OPEN(this%cfg%comm,trim(filename),MPI_MODE_RDONLY,info_mpiio,ifile,ierr) + if (ierr.ne.0) call die('[lss read] Problem encountered while reading data file: '//trim(filename)) + + ! Read file header first + call MPI_FILE_READ_ALL(ifile,npadd,1,MPI_INTEGER,status,ierr) + call MPI_FILE_READ_ALL(ifile,psize,1,MPI_INTEGER,status,ierr) + + ! Remember current position + call MPI_FILE_GET_POSITION(ifile,header_offset,ierr) + + ! Check compatibility of particle type + if (psize.ne.MPI_PART_SIZE) call die('[lss read] Particle type unreadable') + + ! Naively share reading task among all processors + nchunk=int(npadd/(this%cfg%nproc*part_chunk_size))+1 + allocate(ppp(this%cfg%nproc,nchunk)) + ppp=int(npadd/(this%cfg%nproc*nchunk)) + cnt=0 + out:do j=1,nchunk + do i=1,this%cfg%nproc + cnt=cnt+1 + if (cnt.gt.mod(npadd,this%cfg%nproc*nchunk)) exit out + ppp(i,j)=ppp(i,j)+1 + end do + end do out + + ! Read by chunk + do j=1,nchunk + ! Find offset + offset=header_offset+int(MPI_PART_SIZE,MPI_OFFSET_KIND)*int(sum(ppp(1:this%cfg%rank,:))+sum(ppp(this%cfg%rank+1,1:j-1)),MPI_OFFSET_KIND) + ! Resize particle array + call this%resize(this%np_+ppp(this%cfg%rank+1,j)) + ! Read this file + call MPI_FILE_READ_AT(ifile,offset,this%p(this%np_+1:this%np_+ppp(this%cfg%rank+1,j)),ppp(this%cfg%rank+1,j),MPI_PART,status,ierr) + ! Most general case: relocate every droplet + do i=this%np_+1,this%np_+ppp(this%cfg%rank+1,j) + this%p(i)%ind=this%cfg%get_ijk_global(this%p(i)%pos,this%p(i)%ind) + end do + ! Exchange all that + call this%sync() + end do + + ! Close the file + call MPI_FILE_CLOSE(ifile,ierr) + + ! Log/screen output + logging: block + use, intrinsic :: iso_fortran_env, only: output_unit + use param, only: verbose + use messager, only: log + use string, only: str_long + character(len=str_long) :: message + if (this%cfg%amRoot) then + write(message,'("[lss read] Read ",i0," particles from file [",a,"] on partitioned grid [",a,"]")') npadd,trim(filename),trim(this%cfg%name) + if (verbose.gt.2) write(output_unit,'(a)') trim(message) + if (verbose.gt.1) call log(message) + end if + end block logging + + end subroutine read + + +end module lss_class diff --git a/examples/NOSB_plate_with_hole/src/simulation.f90 b/examples/NOSB_plate_with_hole/src/simulation.f90 new file mode 100644 index 000000000..b293134fb --- /dev/null +++ b/examples/NOSB_plate_with_hole/src/simulation.f90 @@ -0,0 +1,780 @@ +!> Various definitions and tools for running an NGA2 simulation +module simulation + use precision, only: WP,SP + use geometry, only: cfg + use spcomp_class, only: spcomp + use lss_class, only: lss + use timetracker_class, only: timetracker + use ensight_class, only: ensight + use partmesh_class, only: partmesh + use event_class, only: event + use monitor_class, only: monitor + implicit none + private + + !> Get a couple linear solvers, an incompressible flow solver and corresponding time tracker + type(spcomp), public :: fs + type(lss), public :: ls + type(timetracker), public :: time + + !> Ensight postprocessing + type(partmesh) :: pmesh + type(ensight) :: ens_out + type(event) :: ens_evt + + !> Simulation monitor file + type(monitor) :: mfile,cflfile,consfile,sfile,dispfile + + public :: simulation_init,simulation_run,simulation_final + + !> Private work arrays + real(WP), dimension(:,:,:,:,:), allocatable :: dQdt + real(WP), dimension(:,:,:) , allocatable :: Ui,Vi,Wi,Ma,beta,visc,visc_t,div + !> Post-shock viscosity and temperature + real(WP) :: visc0,T0 + + !> Equations of state + real(WP) :: Pinf,Gamma,Cv,Prandtl + + !> Flow parameters + real(WP) :: Ms,Xs,Rcyl + real(WP) :: rho1,p1,u1,M1 + real(WP) :: rho2,p2,u2,M2 + real(WP) :: Re + + !> Max timestep size for solid solver + real(WP) :: ls_dt,ls_dt_max + + integer :: target_index + real(WP), dimension(3) :: target_position + + + contains + + + !> Function that returns a smooth Heaviside of thickness delta + real(WP) function Hshock(x,delta) + real(WP), intent(in) :: x,delta + ! Goes from 0 to 1 as x goes from begative to positive + Hshock=1.0_WP/(1.0_WP+exp(-x/delta)) + end function Hshock + + !> P=EOS(RHO,I) + pure real(WP) function get_P(RHO,I) + implicit none + real(WP), intent(in) :: RHO,I + get_P=RHO*I*(Gamma-1.0_WP)-Gamma*Pinf + end function get_P + !> T=f(RHO,P) + pure real(WP) function get_T(RHO,P) + implicit none + real(WP), intent(in) :: RHO,P + get_T=(P+Pinf)/(Cv*RHO*(Gamma-1.0_WP)) + end function get_T + !> RHO=f(T,P) + pure real(WP) function get_RHO(T,P) + implicit none + real(WP), intent(in) :: T,P + get_RHO=(P+Pinf)/(Cv*T*(Gamma-1.0_WP)) + end function get_RHO + !> I=EOS(RHO,P) + pure real(WP) function get_I(RHO,P) + implicit none + real(WP), intent(in) :: RHO,P + get_I=(P+Gamma*Pinf)/(RHO*(Gamma-1.0_WP)) + end function get_I + !> C=f(RHO,P) + pure real(WP) function get_C(RHO,P) + implicit none + real(WP), intent(in) :: RHO,P + get_C=sqrt(Gamma*(P+Pinf)/RHO) + end function get_C + !> S=f(RHO,P) + pure real(WP) function get_S(RHO,P) + implicit none + real(WP), intent(in) :: RHO,P + get_S=Cv*log((P+Pinf)/RHO**Gamma) + end function get_S + + subroutine get_tracked_particle() + use mpi_f08 + implicit none + integer :: i, ierr + real(WP) :: local_pos(3), global_pos(3) + + local_pos = 0.0_WP + + do i=1,ls%np_ + if (ls%p(i)%i.eq.target_index) then + local_pos = ls%p(i)%pos + end if + end do + call MPI_ALLREDUCE(local_pos, global_pos, 3, MPI_DOUBLE_PRECISION, MPI_SUM, ls%cfg%comm, ierr) + + target_position = global_pos + end subroutine + + !> Calculate viscosities + subroutine prepare_viscosities() + implicit none + integer :: i,j,k + real(WP) :: S + ! Get viscosity from Sutherland's law + S=110.4_WP/273.15_WP*T0 + do k=fs%cfg%kmino_,fs%cfg%kmaxo_ + do j=fs%cfg%jmino_,fs%cfg%jmaxo_ + do i=fs%cfg%imino_,fs%cfg%imaxo_ + visc(i,j,k)=visc0*(T0+S)/(fs%T(i,j,k)+S)*(fs%T(i,j,k)/T0)**1.5_WP + end do + end do + end do + ! Get LAD + call fs%get_viscartif(dt=time%dt,beta=beta); fs%BETA=fs%Q(:,:,:,1)*beta + ! Get eddy viscosity + call fs%get_vreman (dt=time%dt,visc=visc_t); fs%VISC=fs%Q(:,:,:,1)*visc_t+visc + ! Recompute thermal conductivity + fs%diff=Gamma*Cv*fs%visc/Prandtl + ! Add LAD + fs%VISC=fs%VISC+0.002_WP*fs%BETA + end subroutine prepare_viscosities + + + !> Calculate velocity divergence + subroutine get_div() + implicit none + integer :: i,j,k + do k=fs%cfg%kmino_,fs%cfg%kmaxo_-1; do j=fs%cfg%jmino_,fs%cfg%jmaxo_-1; do i=fs%cfg%imino_,fs%cfg%imaxo_-1 + div(i,j,k)=fs%dxi*(fs%U(i+1,j,k)-fs%U(i,j,k))+fs%dyi*(fs%V(i,j+1,k)-fs%V(i,j,k))+fs%dzi*(fs%W(i,j,k+1)-fs%W(i,j,k)) + end do; end do; end do + call fs%cfg%sync(div) + if (.not.fs%cfg%xper.and.fs%cfg%iproc.eq.fs%cfg%npx) div(fs%cfg%imaxo,:,:)=div(fs%cfg%imaxo-1,:,:) + if (.not.fs%cfg%yper.and.fs%cfg%jproc.eq.fs%cfg%npy) div(:,fs%cfg%jmaxo,:)=div(:,fs%cfg%jmaxo-1,:) + if (.not.fs%cfg%zper.and.fs%cfg%kproc.eq.fs%cfg%npz) div(:,:,fs%cfg%kmaxo)=div(:,:,fs%cfg%kmaxo-1) + end subroutine get_div + + + !> Overwrite cosnerved variables using volume-of-solid IBM + subroutine apply_ibm() + implicit none + integer :: i,j,k,ii,jj,kk + real(WP) :: sum_VF,sum_VFQ1,sum_VFQ2 + do k=cfg%kmin_,cfg%kmax_ + do j=cfg%jmin_,cfg%jmax_ + do i=cfg%imin_,cfg%imax_ + if (ls%VF(i,j,k).eq.0.0_WP) cycle + ! Neumann: VF-weighted neighbor average for Q(1) and Q(2) + sum_VF=0.0_WP; sum_VFQ1=0.0_WP; sum_VFQ2=0.0_WP + do kk=-1,1; do jj=-1,1; do ii=-1,1 + if (ii.eq.0.and.jj.eq.0.and.kk.eq.0) cycle + sum_VF =sum_VF +(1.0_WP-ls%VF(i+ii,j+jj,k+kk)) + sum_VFQ1=sum_VFQ1+(1.0_WP-ls%VF(i+ii,j+jj,k+kk))*fs%Q(i+ii,j+jj,k+kk,1) + sum_VFQ2=sum_VFQ2+(1.0_WP-ls%VF(i+ii,j+jj,k+kk))*fs%Q(i+ii,j+jj,k+kk,2) + end do; end do; end do + if (sum_VF.gt.0.0_WP) then + fs%Q(i,j,k,1)=(1.0_WP-ls%VF(i,j,k))*fs%Q(i,j,k,1)+ls%VF(i,j,k)*sum_VFQ1/sum_VF + fs%Q(i,j,k,2)=(1.0_WP-ls%VF(i,j,k))*fs%Q(i,j,k,2)+ls%VF(i,j,k)*sum_VFQ2/sum_VF + end if + ! No-slip now that density is determined + fs%Q(i,j,k,3)=(1.0_WP-0.5_WP*(ls%VF(i-1,j,k)+ls%VF(i,j,k)))*fs%Q(i,j,k,3)+0.5_WP*(fs%Q(i-1,j,k,1)+fs%Q(i,j,k,1))*ls%VFU(i,j,k) + fs%Q(i,j,k,4)=(1.0_WP-0.5_WP*(ls%VF(i,j-1,k)+ls%VF(i,j,k)))*fs%Q(i,j,k,4)+0.5_WP*(fs%Q(i,j-1,k,1)+fs%Q(i,j,k,1))*ls%VFV(i,j,k) + fs%Q(i,j,k,5)=(1.0_WP-0.5_WP*(ls%VF(i,j,k-1)+ls%VF(i,j,k)))*fs%Q(i,j,k,5)+0.5_WP*(fs%Q(i,j,k-1,1)+fs%Q(i,j,k,1))*ls%VFW(i,j,k) + end do + end do + end do + ! Communicate + call fs%cfg%sync(fs%Q(:,:,:,1)) + call fs%cfg%sync(fs%Q(:,:,:,2)) + call fs%cfg%sync(fs%Q(:,:,:,3)) + call fs%cfg%sync(fs%Q(:,:,:,4)) + call fs%cfg%sync(fs%Q(:,:,:,5)) + ! Rebuild primitive variables + call fs%get_primitive() + end subroutine apply_ibm + + + !> Apply boundary conditions + subroutine apply_bconds() + implicit none + integer :: i,j,k + + ! Apply clipped Neumann on primitive variables in x+ + if (.not.fs%cfg%xper.and.fs%cfg%iproc.eq.fs%cfg%npx) then + do k=fs%cfg%kmino_,fs%cfg%kmaxo_; do j=fs%cfg%jmino_,fs%cfg%jmaxo_ + ! Copy over from imax to imax+1 and above + do i=fs%cfg%imax+1,fs%cfg%imaxo + ! Copy primitive variables + ls%VF(i,j,k)=ls%VF(fs%cfg%imax,j,k) + fs%Q(i,j,k,1)=fs%Q(fs%cfg%imax,j,k,1) + fs%P(i,j,k)=fs%P(fs%cfg%imax,j,k) + fs%I(i,j,k)=fs%I(fs%cfg%imax,j,k) + fs%U(i,j,k)=max(fs%U(fs%cfg%imax,j,k),0.0_WP) + fs%V(i,j,k)=fs%V(fs%cfg%imax,j,k) + fs%W(i,j,k)=fs%W(fs%cfg%imax,j,k) + end do + end do; end do + end if + + ! Apply clipped Neumann on primitive variables in y+ + if (.not.fs%cfg%yper.and.fs%cfg%jproc.eq.fs%cfg%npy) then + do k=fs%cfg%kmino_,fs%cfg%kmaxo_; do i=fs%cfg%imino_,fs%cfg%imaxo_ + ! Copy over from jmax to jmax+1 and above + do j=fs%cfg%jmax+1,fs%cfg%jmaxo + ! Copy primitive variables + ls%VF(i,j,k)=ls%VF(i,fs%cfg%jmax,k) + fs%Q(i,j,k,1)=fs%Q(i,fs%cfg%jmax,k,1) + fs%P(i,j,k)=fs%P(i,fs%cfg%jmax,k) + fs%I(i,j,k)=fs%I(i,fs%cfg%jmax,k) + fs%U(i,j,k)=fs%U(i,fs%cfg%jmax,k) + fs%V(i,j,k)=max(fs%V(i,fs%cfg%jmax,k),0.0_WP) + fs%W(i,j,k)=fs%W(i,fs%cfg%jmax,k) + end do + end do; end do + end if + + ! Apply clipped Neumann on primitive variables in y- + if (.not.fs%cfg%yper.and.fs%cfg%jproc.eq.1) then + do k=fs%cfg%kmino_,fs%cfg%kmaxo_; do i=fs%cfg%imino_,fs%cfg%imaxo_ + ! First copy over V from jmin+1 to jmin + fs%V(i,fs%cfg%jmin,k)=min(fs%V(i,fs%cfg%jmin+1,k),0.0_WP) + ! Then copy over from jmin to jmin-1 and below + do j=fs%cfg%jmino,fs%cfg%jmin-1 + ! Copy primitive variables + ls%VF(i,j,k)=ls%VF(i,fs%cfg%jmin,k) + fs%Q(i,j,k,1)=fs%Q(i,fs%cfg%jmin,k,1) + fs%P(i,j,k)=fs%P(i,fs%cfg%jmin,k) + fs%I(i,j,k)=fs%I(i,fs%cfg%jmin,k) + fs%U(i,j,k)=fs%U(i,fs%cfg%jmin,k) + fs%V(i,j,k)=min(fs%V(i,fs%cfg%jmin,k),0.0_WP) + fs%W(i,j,k)=fs%W(i,fs%cfg%jmin,k) + end do + end do; end do + end if + + ! Apply clipped Neumann on primitive variables in z+ + if (.not.fs%cfg%zper.and.fs%cfg%kproc.eq.fs%cfg%npz) then + do j=fs%cfg%jmino_,fs%cfg%jmaxo_; do i=fs%cfg%imino_,fs%cfg%imaxo_ + ! Copy over from kmax to kmax+1 and above + do k=fs%cfg%kmax+1,fs%cfg%kmaxo + ! Copy primitive variables + ls%VF(i,j,k)=ls%VF(i,j,fs%cfg%kmax) + fs%Q(i,j,k,1)=fs%Q(i,j,fs%cfg%kmax,1) + fs%P(i,j,k)=fs%P(i,j,fs%cfg%kmax) + fs%I(i,j,k)=fs%I(i,j,fs%cfg%kmax) + fs%U(i,j,k)=fs%U(i,j,fs%cfg%kmax) + fs%V(i,j,k)=fs%V(i,j,fs%cfg%kmax) + fs%W(i,j,k)=max(fs%W(i,j,fs%cfg%kmax),0.0_WP) + end do + end do; end do + end if + + ! Apply clipped Neumann on primitive variables in z- + if (.not.fs%cfg%zper.and.fs%cfg%kproc.eq.1) then + do j=fs%cfg%jmino_,fs%cfg%jmaxo_; do i=fs%cfg%imino_,fs%cfg%imaxo_ + ! First copy over W from kmin+1 to kmin + fs%W(i,j,fs%cfg%kmin)=min(fs%W(i,j,fs%cfg%kmin+1),0.0_WP) + ! Then copy over from kmin to kmin-1 and below + do k=fs%cfg%kmino,fs%cfg%kmin-1 + ! Copy primitive variables + ls%VF(i,j,k)=ls%VF(i,j,fs%cfg%kmin) + fs%Q(i,j,k,1)=fs%Q(i,j,fs%cfg%kmin,1) + fs%P(i,j,k)=fs%P(i,j,fs%cfg%kmin) + fs%I(i,j,k)=fs%I(i,j,fs%cfg%kmin) + fs%U(i,j,k)=fs%U(i,j,fs%cfg%kmin) + fs%V(i,j,k)=fs%V(i,j,fs%cfg%kmin) + fs%W(i,j,k)=min(fs%W(i,j,fs%cfg%kmin),0.0_WP) + end do + end do; end do + end if + + ! Rebuild conserved quantities + fs%Q(:,:,:,2)=fs%Q(:,:,:,1)*fs%I + call fs%get_momentum() + + end subroutine apply_bconds + + + !> Initialization of problem solver + subroutine simulation_init + + use param, only: param_read,param_exists + implicit none + + ! Allocate work arrays + allocate_work_arrays: block + allocate(dQdt (cfg%imino_:cfg%imaxo_,cfg%jmino_:cfg%jmaxo_,cfg%kmino_:cfg%kmaxo_,1:5,1:4)) + end block allocate_work_arrays + + ! Initialize time tracker with 2 subiterations + initialize_timetracker: block + time=timetracker(amRoot=cfg%amRoot) + call param_read('Max timestep size',time%dtmax) + call param_read('Max cfl number',time%cflmax) + call param_read('Max time',time%tmax) + time%dt=time%dtmax + time%itmax=2 + end block initialize_timetracker + + + + ! ! Initialize Lagrangian solid solver + ! initialize_lss: block + ! use mpi_f08, only: MPI_ALLREDUCE,MPI_MAX,MPI_INTEGER + ! real(WP) :: dx,mu,kk,max_stretch,Lx,Ly,Lz + ! real(WP) :: xmin,xmax,ymin,ymax,zmin,zmax,ratio,P_load + ! integer :: np,nt,nx,ny,nz,ierr,global_index + ! type triangle_type + ! real(WP), dimension(3) :: norm + ! real(WP), dimension(3) :: v1 + ! real(WP), dimension(3) :: v2 + ! real(WP), dimension(3) :: v3 + ! end type triangle_type + ! type(triangle_type), dimension(:), allocatable :: t + + + ! ! Create solver + ! ls=lss(cfg=cfg,name='solid') + ! !call fs%initialize(cfg=cfg,name='Compressible NS') + + + ! ! Set material properties + ! call param_read('Elastic Modulus',ls%elastic_modulus) + ! call param_read('Poisson Ratio',ls%poisson_ratio) + ! call param_read('Solid density',ls%rho) + ! call param_read('Critical Energy Release Rate',ls%crit_energy) + + ! ! Maximum timestep size used for particles + ! call param_read('Particle timestep size',ls_dt_max,default=huge(1.0_WP)) + ! ls_dt=min(ls_dt_max,time%dtmax) + + ! ! Discretization + ! ! ls%delta=fs%cfg%min_meshsize*1.01 + ! ! Load',P_load) + ! call param_read('Lx',Lx) + ! call param_read('Ly',Ly) + ! call param_read('Lz',Lz) + ! call param_read('Subdivisions',ny) + ! nz = ny + ! nx = NINT(Lx/Lz)*ny + ! call param_read('Horizon Ratio',ratio) + ! ls%delta = Ly/real(ny,WP)*ratio + ! ! Output some info on stretch + ! mu=ls%elastic_modulus/(2.0_WP+2.0_WP*ls%poisson_ratio) + ! kk=ls%elastic_modulus/(3.0_WP-6.0_WP*ls%poisson_ratio) + ! max_stretch=sqrt(ls%crit_energy/((3.0_WP*mu+(kk-5.0_WP*mu/3.0_WP)*0.75_WP**4)*ls%delta)) + + ! ! Only root process initializes solid particles + ! if (ls%cfg%amRoot) then + ! ! Read the STL file and get domain extents and levelset + ! print*, Lx * Ly * Lz / real(ny*nz*nx,WP) + ! read_bin: block + + ! use messager, only: die + ! integer :: p,iunit,ierr, wall_np, i, j, k + ! global_index = 0 + ! target_index = 0 + + ! ! Read in grid definition + ! wall_np = ny*nz*(nx+3) + ! ! call ls%resize(np+wall_np) + ! call ls%resize(wall_np) + ! p=0 + ! do i=1,nx+3 + ! do j=1,ny + ! do k=1,nz + ! p = p+1 + ! ls%p(p)%pos(1) = (i-1) * (Lx/real(nx,WP)) + ! ls%p(p)%pos(2) = (j) * (Ly/real(ny,WP)) - Ly/2.0_WP + ! ls%p(p)%pos(3) = (k) * (Lz/real(nz,WP)) - Lz/2.0_WP + ! ls%p(p)%vol = Lx * Ly * Lz / real(ny*nz*nx,WP) + ! ls%p(p)%id=1 + ! if(i.le.3) ls%p(p)%id=-2 + + ! ls%p(p)%vel=[0.0_WP,0.0_WP,0.0_WP] + ! ! Zero out force + ! ls%p(p)%Abond=0.0_WP + ! ! Zero out fluid unless end, using this for the load + ! ls%p(p)%Afluid=0.0_WP + ! !if(i.eq.nx+3) ls%p(p)%Afluid=[(P_load*Ly*Lz)/(ls%rho*ls%p(p)%vol),0.0_WP,0.0_WP] + ! ! Locate the particle on the mesh + ! ls%p(p)%ind=ls%cfg%get_ijk_global(ls%p(p)%pos,[ls%cfg%imin,ls%cfg%jmin,ls%cfg%kmin]) + ! ! Assign a unique integer to particle + ! ls%p(p)%i=p + ! ! Activate the particle + ! ls%p(p)%flag=0 + ! if(i.eq.(nx/2+1).and.j.eq.(ny/2+1).and.k.eq.(nz/2+1)) target_index = p + ! end do + ! end do + ! end do + + ! np = wall_np + ! end block read_bin + ! end if + + ! ! Allreduce with MPI_MAX ensures the nonzero index propagates to all + ! call MPI_ALLREDUCE(target_index, global_index, 1, MPI_INTEGER, MPI_MAX, ls%cfg%comm, ierr) + + ! ! Update target_index globally + ! target_index = global_index + + + ! ! Communicate particles + ! call ls%sync() + + ! call get_tracked_particle() + + ! ! Get initial volume fraction + ! ! call ls%update_VF() + + ! ! Initalize bonds + ! call ls%bond_init() + + ! if (ls%cfg%amRoot) then + ! print*,"===== Solid Setup Description =====" + ! print*,'Number of particles', np + ! print*,'Maximum stretching =',max_stretch + ! end if + + ! end block initialize_lss + + initialize_lss: block + use mpi_f08, only: MPI_ALLREDUCE,MPI_MAX,MPI_INTEGER + real(WP) :: dx,mu,kk,max_stretch,Lx,Ly,Lz,R,x,y,z,load_rate + real(WP) :: xmin,xmax,ymin,ymax,zmin,zmax,ratio,dist + integer :: np,nt,nx,ny,nz,ierr,global_index,N + type triangle_type + real(WP), dimension(3) :: norm + real(WP), dimension(3) :: v1 + real(WP), dimension(3) :: v2 + real(WP), dimension(3) :: v3 + end type triangle_type + type(triangle_type), dimension(:), allocatable :: t + + + + + ! Create solver + ls=lss(cfg=cfg,name='solid') + !call fs%initialize(cfg=cfg,name='Compressible NS') + + + ! Set material properties + call param_read('Elastic Modulus',ls%elastic_modulus) + call param_read('Poisson Ratio',ls%poisson_ratio) + call param_read('Solid density',ls%rho) + call param_read('Critical Energy Release Rate',ls%crit_energy) + call param_read('Solid Damping Constant',ls%beta) + call param_read('Cool down time',ls%cool_down_time) + call param_read('Continuous damping',ls%continuous_damping) + + ! Maximum timestep size used for particles + call param_read('Particle timestep size',ls_dt_max,default=huge(1.0_WP)) + ls_dt=min(ls_dt_max,time%dtmax) + + ! Discretization + ! ls%delta=fs%cfg%min_meshsize*1.01 + ! Load',P_load) + call param_read('Lx',Lx) + call param_read('Ly',Ly) + call param_read('Lz',Lz) + call param_read('R',R) + ! call param_read('Solid Spacing',dist) + call param_read('N Across',N) + call param_read('Load Rate',load_rate) + ! Lx = 1.0_WP + ! Ly = 1.0_WP + ! dist = 0.01_WP ! Space between particles + ! Lx = Lx + 6.0_WP * dist + ! Ly = Ly + 3.0_WP * dist + dist = Lz/N + + nz = N + nx = ceiling(Lx/Lz)*N + 12 + ny = ceiling(Ly/Lz)*N + call param_read('Horizon Ratio',ratio) + ls%delta = dist*ratio + + ! Output some info on stretch + mu=ls%elastic_modulus/(2.0_WP+2.0_WP*ls%poisson_ratio) + kk=ls%elastic_modulus/(3.0_WP-6.0_WP*ls%poisson_ratio) + max_stretch=sqrt(ls%crit_energy/((3.0_WP*mu+(kk-5.0_WP*mu/3.0_WP)*0.75_WP**4)*ls%delta)) + + ! Only root process initializes solid particles + if (ls%cfg%amRoot) then + read_bin: block + + use messager, only: die + integer :: p,iunit,ierr, wall_np, i, j, k + real(WP) :: net_vol + net_vol = 0.0_WP + global_index = 0 + target_index = 0 + ! Read in grid definition + wall_np = (ny)*(nz)*(nx) + ! call ls%resize(np+wall_np) + call ls%resize(wall_np) + p=0 + do i=1,nx + do j=1,ny + do k=1,nz + x = (i-7) * dist - (Lx/2.0_WP - dist/2.0_WP); + y = (j-1) * dist - (Ly/2.0_WP - dist/2.0_WP); + z = (k-1) * dist - (Lz/2.0_WP - dist/2.0_WP); + !if ((x*x + y*y).gt.R*R) cycle; + if (((x)*(x) + y*y).lt.R*R) cycle; + p = p+1 + ls%p(p)%pos(1) = x + ls%p(p)%pos(2) = y + ls%p(p)%pos(3) = z + ls%p(p)%ipos=ls%p(p)%pos + ls%p(p)%displacement=0.0_WP + ls%p(p)%vol = dist*dist*dist + ls%p(p)%id=1 + if(i.le.6) ls%p(p)%id=-1 + if(i.ge.nx-5) ls%p(p)%id=-1 + ls%p(p)%vel=[0.0_WP,0.0_WP,0.0_WP] + if(i.le.6) ls%p(p)%vel=[-load_rate/2.0_WP,0.0_WP,0.0_WP] + if(i.ge.nx-5) ls%p(p)%vel=[load_rate/2.0_WP,0.0_WP,0.0_WP] + ! if(i.ge.nx-5) net_vol=net_vol+ls%p(p)%vol + ! Zero out force + ls%p(p)%Abond=0.0_WP + ! Zero out fluid unless end, using this for the load + ls%p(p)%Afluid=0.0_WP + ! Locate the particle on the mesh + ls%p(p)%ind=ls%cfg%get_ijk_global(ls%p(p)%pos,[ls%cfg%imin,ls%cfg%jmin,ls%cfg%kmin]) + ! Assign a unique integer to particle + ls%p(p)%i=p + ! Activate the particle + ls%p(p)%flag=0 + if(i.eq.(nx/2+2).and.j.eq.(ny/2+1).and.k.eq.(nz/2+1)) target_index = p + end do + end do + end do + + np = wall_np + print*, "Nx: ", nx + print*, "Ny: ", ny + print*, "Nz: ", nz + print*, "Net Force Volume", net_vol + print*, "Used Volume", (dist**3 * ny * nz * 6) + end block read_bin + end if + + ! Allreduce with MPI_MAX ensures the nonzero index propagates to all + call MPI_ALLREDUCE(target_index, global_index, 1, MPI_INTEGER, MPI_MAX, ls%cfg%comm, ierr) + + ! Update target_index globally + target_index = global_index + + + ! Communicate particles + call ls%sync() + + call get_tracked_particle() + + ! Get initial volume fraction + ! call ls%update_VF() + + ! Initalize bonds + call ls%bond_init() + call ls%get_bond_force() + call ls%sync() + + if (ls%cfg%amRoot) then + print*,"===== Solid Setup Description =====" + print*,'Number of particles', np + print*,'Maximum stretching =',max_stretch + end if + + end block initialize_lss + + + ! Create partmesh object for visualizing Lagrangian particles + create_pmesh: block + use lss_class, only: max_bond + integer :: i,n,nbond + pmesh=partmesh(nvar=5,nvec=3,name='solid') + pmesh%varname(1)='failfrac' + pmesh%varname(2)='id' + pmesh%varname(3)='nbond' + pmesh%varname(4)='von-Mises' + pmesh%varname(5)='correcMag' + + + pmesh%vecname(1)='velocity' + pmesh%vecname(2)='bond_force' + pmesh%vecname(3)='disp' + call ls%update_partmesh(pmesh) + do i=1,ls%np_ + pmesh%var(1,i)=0.0_WP + nbond=0 + do n=1,max_bond + if (ls%p(i)%ibond(n).gt.0) nbond=nbond+1 + end do + if (ls%p(i)%nbond.gt.0) then + pmesh%var(1,i)=1.0_WP-real(nbond,WP)/real(ls%p(i)%nbond,WP) + else + pmesh%var(1,i)=0.0_WP + end if + pmesh%var(2,i) =ls%p(i)%id + pmesh%vec(:,1,i)=ls%p(i)%vel + pmesh%vec(:,2,i)=ls%p(i)%Abond*ls%rho*ls%p(i)%vol + pmesh%var(3,i) =ls%p(i)%nbond + pmesh%var(4,i) =ls%p(i)%vonMises + pmesh%var(5,i) =ls%p(i)%correcMag + pmesh%vec(:,3,i) =ls%p(i)%displacement + + end do + end block create_pmesh + + ! Add Ensight output + create_ensight: block + ! Create Ensight output from cfg + ens_out=ensight(cfg=cfg,name='shock') + ! Create event for Ensight output + ens_evt=event(time=time,name='Ensight output') + call param_read('Ensight output period',ens_evt%tper) + ! Add variables to output + call ens_out%add_particle('particles',pmesh) + ! Output to ensight + if (ens_evt%occurs()) call ens_out%write_data(time%t) + end block create_ensight + + + ! Create monitor files + create_monitor: block + real(WP) :: cfl + ! Prepare some info about fields + call ls%get_cfl(time%dt,time%cfl) + call ls%get_max() + ! Create solid monitor + sfile=monitor(ls%cfg%amRoot,'solid') + call sfile%add_column(time%n,'Timestep number') + call sfile%add_column(time%t,'Time') + call sfile%add_column(ls_dt,'Particle dt') + call sfile%add_column(time%cfl,'Maximum CFL') + call sfile%add_column(ls%np,'Particle number') + call sfile%add_column(ls%VFmax,'VFmax') + call sfile%add_column(ls%Umin,'Particle Umin') + call sfile%add_column(ls%Umax,'Particle Umax') + call sfile%add_column(ls%Vmin,'Particle Vmin') + call sfile%add_column(ls%Vmax,'Particle Vmax') + call sfile%add_column(ls%Wmin,'Particle Wmin') + call sfile%add_column(ls%Wmax,'Particle Wmax') + call sfile%add_column(ls%ibmForce(1),'Particle Fx') + call sfile%add_column(ls%ibmForce(2),'Particle Fy') + call sfile%add_column(ls%ibmForce(3),'Particle Fz') + call sfile%write() + dispfile=monitor(ls%cfg%amRoot,'displacement') + call dispfile%add_column(time%n,'Timestep number') + call dispfile%add_column(time%t,'Time') + call dispfile%add_column(ls_dt,'Particle dt') + call dispfile%add_column(target_position(1),'X') + call dispfile%add_column(target_position(2),'Y') + call dispfile%add_column(target_position(3),'Z') + call dispfile%write() + end block create_monitor + + end subroutine simulation_init + + + !> Perform an NGA2 simulation + subroutine simulation_run + implicit none + real(WP) :: cfl + logical :: cool_down_time + + cool_down_time = .false. + ! Perform time integration + do while (.not.time%done()) + + ! Increment time + call ls%get_cfl(time%dt,time%cfl) + ! call fs%get_cfl(time%dt,cfl); time%cfl=max(time%cfl,cfl) + call time%adjust_dt() + call time%increment() + + ! Advance solid solver + solid: block + real(WP) :: dt_done,mydt + ! Sub-iteratore + call ls%get_cfl(ls_dt,cfl=cfl) + if (cfl.gt.0.0_WP) ls_dt=min(ls_dt*time%cflmax/cfl,ls_dt_max) + dt_done=0.0_WP + do while (dt_done.lt.time%dtmid) + ! Decide the timestep size + if (time%t.gt.ls%cool_down_time) cool_down_time = .true. + mydt=min(ls_dt,time%dtmid-dt_done) + ! ! Advance particles + call ls%advance(dt =mydt,cool_down = cool_down_time, continuous = ls%continuous_damping) + ! ! Increment + dt_done=dt_done+mydt + + + + ! mydt=min(ls_dt,time%dtmid-dt_done) + ! ! Advance particles + ! call ls%advance(dt =mydt) + ! ! ! Increment + ! dt_done=dt_done+mydt + + end do + end block solid + + !> Perform and output monitoring + call ls%get_max() + call get_tracked_particle() + call sfile%write() + call dispfile%write() + + + ! Output to ensight + if (ens_evt%occurs()) then + update_pmesh: block + use lss_class, only: max_bond + integer :: i,n,nbond + call ls%update_partmesh(pmesh) + do i=1,ls%np_ + nbond=0 + do n=1,max_bond + if (ls%p(i)%ibond(n).gt.0) nbond=nbond+1 + end do + if (ls%p(i)%nbond.gt.0) then + pmesh%var(1,i)=1.0_WP-real(nbond,WP)/real(ls%p(i)%nbond,WP) + else + pmesh%var(1,i)=0.0_WP + end if + pmesh%var(2,i) =ls%p(i)%id + pmesh%vec(:,1,i)=ls%p(i)%vel + pmesh%vec(:,2,i)=ls%p(i)%Abond*ls%rho*ls%p(i)%vol + pmesh%var(3,i) =ls%p(i)%nbond + pmesh%var(4,i) =ls%p(i)%vonMises + pmesh%var(5,i) =ls%p(i)%correcMag + pmesh%vec(:,3,i) =ls%p(i)%displacement + + + end do + end block update_pmesh + call ens_out%write_data(time%t) + end if + + end do + + end subroutine simulation_run + + + !> Finalize the NGA2 simulation + subroutine simulation_final + implicit none + + ! Get rid of all objects - need destructors + ! monitor + ! ensight + ! bcond + ! timetracker + + ! Deallocate work arrays + deallocate(dQdt) + end subroutine simulation_final + + +end module simulation diff --git a/examples/NOSB_plate_with_hole/src/spcomp_class.f90 b/examples/NOSB_plate_with_hole/src/spcomp_class.f90 new file mode 100644 index 000000000..00ec1fe25 --- /dev/null +++ b/examples/NOSB_plate_with_hole/src/spcomp_class.f90 @@ -0,0 +1,942 @@ +!> Single phase compressible flow solver class: +!> Provides support for RHS calculation only +module spcomp_class + use precision, only: WP + use string, only: str_medium + use config_class, only: config + use timer_class, only: timer + implicit none + private + + ! Expose type + public :: spcomp + + !> Single phase compressible solver object definition + type :: spcomp + + ! This is the config around which solver is built + class(config), pointer :: cfg + + ! Solver name + character(len=str_medium) :: name='UNNAMED_SPCOMP' + + ! Pointers to functions to evaluate P(RHO,E), T(RHO,P), and C(RHO,P) + procedure(Pfunc_type), pointer, nopass :: getP=>NULL() + procedure(Tfunc_type), pointer, nopass :: getT=>NULL() + procedure(Cfunc_type), pointer, nopass :: getC=>NULL() + procedure(Sfunc_type), pointer, nopass :: getS=>NULL() + + ! Conserved variables: 1=RHO, 2=RHO*I, 3=RHO*U, 4=RHO*V, 5=RHO*W + integer :: nQ + real(WP), dimension(:,:,:,:), allocatable :: Q,Qold + + ! Flow velocity + real(WP), dimension(:,:,:), allocatable :: U,V,W + + ! Internal energy + real(WP), dimension(:,:,:), allocatable :: I + + ! Pressure + real(WP), dimension(:,:,:), allocatable :: P + + ! Temperature + real(WP), dimension(:,:,:), allocatable :: T + + ! Speed of sound + real(WP), dimension(:,:,:), allocatable :: C + + ! Viscosities and heat diffusivity + real(WP), dimension(:,:,:), allocatable :: VISC,BETA,DIFF + + ! Gravitational acceleration + real(WP), dimension(3) :: gravity=0.0_WP + + ! Store mesh info + real(WP) :: dx,dy,dz,dxi,dyi,dzi,vol + + ! CFL numbers + real(WP) :: CFLc_x,CFLc_y,CFLc_z !< Convective CFL numbers + real(WP) :: CFLa_x,CFLa_y,CFLa_z !< Acoustic CFL numbers + real(WP) :: CFLv_x,CFLv_y,CFLv_z !< Viscous CFL numbers + + ! Monitoring quantities for conserved variables + real(WP), dimension(:), allocatable :: Qmin,Qmax,Qint + real(WP) :: RHOKint + real(WP) :: RHOSint + + ! Monitoring quantities for primitive variables + real(WP) :: Umax,Vmax,Wmax !< Velocity stats + real(WP) :: RHOmin,RHOmax !< Density stats + real(WP) :: Imin,Imax !< Internal energy stats + real(WP) :: Pmin,Pmax !< Pressure stats + real(WP) :: Tmin,Tmax !< Temperature stats + + ! Timer + type(timer) :: trhs !< Timer for RHS calculation + + contains + procedure :: print=>spcomp_print !< Output solver to the screen + procedure :: initialize !< Initialize the flow solver + procedure :: finalize !< Finalize the flow solver + procedure :: get_div_stress !< Compute divergence of stress for LSS solver + procedure :: rhs !< Compute rhs of our equations using standard fluxes + procedure :: get_primitive !< Calculate primitive variables from conserved variables + procedure :: get_viscartif !< Calculate artifical bulk kinematic viscosity + procedure :: get_vreman !< Get kinematic eddy viscosity using Vreman's model + procedure :: get_velocity !< Calculate velocity from momentum + procedure :: get_ke !< Calculate kinetic energy per unit mass from velocity + procedure :: get_momentum !< Calculate momentum from velocity + procedure :: interp_vel !< Calculate interpolated velocity + procedure :: get_cfl !< Calculate maximum CFL + procedure :: get_info !< Calculate maximum field values + end type spcomp + + !> Interfaces for user-defined function + abstract interface + !> P=P(RHO,I) + pure real(WP) function Pfunc_type(RHO,I) + import :: WP + implicit none + real(WP), intent(in) :: RHO + real(WP), intent(in) :: I + end function Pfunc_type + !> T=T(RHO,P) + pure real(WP) function Tfunc_type(RHO,P) + import :: WP + implicit none + real(WP), intent(in) :: RHO + real(WP), intent(in) :: P + end function Tfunc_type + !> C=C(RHO,P) + pure real(WP) function Cfunc_type(RHO,P) + import :: WP + implicit none + real(WP), intent(in) :: RHO + real(WP), intent(in) :: P + end function Cfunc_type + !> S=S(RHO,P) + pure real(WP) function Sfunc_type(RHO,P) + import :: WP + implicit none + real(WP), intent(in) :: RHO + real(WP), intent(in) :: P + end function Sfunc_type + end interface + +contains + + + !> Initialization for compressible flow solver + subroutine initialize(this,cfg,name) + use messager, only: die + implicit none + class(spcomp) :: this + class(config), target, intent(in) :: cfg + character(len=*), optional :: name + + ! Set the name for the solver + if (present(name)) this%name=trim(adjustl(name)) + + ! Point to config object + this%cfg=>cfg + + ! Check that config is uniform with at least 2 cells of overlap + if (this%cfg%no.lt.2) call die('[spcomp initialize] spcomp solver requires at least 2 cells of overlap') + if (.not.all([this%cfg%uniform_x,this%cfg%uniform_y,this%cfg%uniform_z])) call die('[spcomp initialize] spcomp solver requires a uniform mesh') + + ! Store constant cell size and its inverse, handle 2D conditions, store cell volume + this%dx=this%cfg%dx(this%cfg%imin_); this%dxi=1.0_WP/this%dx; if (this%cfg%nx.eq.1) this%dxi=0.0_WP + this%dy=this%cfg%dy(this%cfg%jmin_); this%dyi=1.0_WP/this%dy; if (this%cfg%ny.eq.1) this%dyi=0.0_WP + this%dz=this%cfg%dz(this%cfg%kmin_); this%dzi=1.0_WP/this%dz; if (this%cfg%nz.eq.1) this%dzi=0.0_WP + this%vol=this%dx*this%dy*this%dz + + ! Allocate and zero out conserved variables + this%nQ=5 + allocate(this%Q (this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_,1:this%nQ)); this%Q =0.0_WP + allocate(this%Qold(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_,1:this%nQ)); this%Qold=0.0_WP + + ! Conserved variables monitoring + allocate(this%Qmin(1:this%nQ),this%Qmax(1:this%nQ),this%Qint(1:this%nQ)) + + ! Flow velocity + allocate(this%U(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)); this%U=0.0_WP + allocate(this%V(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)); this%V=0.0_WP + allocate(this%W(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)); this%W=0.0_WP + + ! Internal energy + allocate(this%I(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)); this%I=0.0_WP + + ! Pressure + allocate(this%P(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)); this%P=0.0_WP + + ! Temperature + allocate(this%T(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)); this%T=0.0_WP + + ! Speed of sound + allocate(this%C(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)); this%C=0.0_WP + + ! Viscosities and heat diffusivity + allocate(this%VISC(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)); this%VISC=0.0_WP + allocate(this%BETA(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)); this%BETA=0.0_WP + allocate(this%DIFF(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)); this%DIFF=0.0_WP + + ! Create timers + this%trhs=timer(comm=this%cfg%comm,name='RHS') + + end subroutine initialize + + + !> Obtain RHS for all equations + subroutine rhs(this,dQdt) + implicit none + class(spcomp), intent(inout) :: this + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:,1:), intent(out) :: dQdt !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_,1:nVAR) + real(WP), dimension(:,:,:,:), allocatable :: FQx,FQy,FQz + integer :: i,j,k,n + real(WP) :: w,div + real(WP), parameter :: eps=1.0e-15_WP + real(WP), dimension(-2: 0) :: wenop + real(WP), dimension(-1:+1) :: wenom + + ! Start rhs timer + call this%trhs%start() + + ! Zero out RHS + dQdt=0.0_WP + + ! ================================================================ ! + ! ======================== INVISID FLUXES ======================== ! + ! ================================================================ ! + + ! Allocate fluxes of conserved variables + allocate(FQx(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_,1:this%nQ)); FQx=0.0_WP + allocate(FQy(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_,1:this%nQ)); FQy=0.0_WP + allocate(FQz(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_,1:this%nQ)); FQz=0.0_WP + + ! Calculate standard fluxes + do k=this%cfg%kmin_,this%cfg%kmax_+1 + do j=this%cfg%jmin_,this%cfg%jmax_+1 + do i=this%cfg%imin_,this%cfg%imax_+1 + ! X fluxes + ! WENO mass flux + w=weno_weight((abs(this%Q(i-1,j,k,1)-this%Q(i-2,j,k,1))+eps)/(abs(this%Q(i,j,k,1)-this%Q(i-1,j,k,1))+eps)); wenop=0.5_WP*[ -w,1.0_WP+2.0_WP*w,1.0_WP-w] + w=weno_weight((abs(this%Q(i+1,j,k,1)-this%Q(i ,j,k,1))+eps)/(abs(this%Q(i,j,k,1)-this%Q(i-1,j,k,1))+eps)); wenom=0.5_WP*[1.0_WP-w,1.0_WP+2.0_WP*w, -w] + FQx(i,j,k,1)=-0.5_WP*(this%U(i,j,k)+abs(this%U(i,j,k)))*sum(wenop*this%Q(i-2:i ,j,k,1))& + & -0.5_WP*(this%U(i,j,k)-abs(this%U(i,j,k)))*sum(wenom*this%Q(i-1:i+1,j,k,1)) + ! Centered mass flux + !FQx(i,j,k,1)=-this%U(i,j,k)*0.5_WP*sum(this%Q(i-1:i,j,k,1)) + ! WENO internal energy flux + w=weno_weight((abs(this%I(i-1,j,k)-this%I(i-2,j,k))+eps)/(abs(this%I(i,j,k)-this%I(i-1,j,k))+eps)); wenop=0.5_WP*[ -w,1.0_WP+2.0_WP*w,1.0_WP-w] + w=weno_weight((abs(this%I(i+1,j,k)-this%I(i ,j,k))+eps)/(abs(this%I(i,j,k)-this%I(i-1,j,k))+eps)); wenom=0.5_WP*[1.0_WP-w,1.0_WP+2.0_WP*w, -w] + FQx(i,j,k,2)=0.5_WP*(FQx(i,j,k,1)-abs(-FQx(i,j,k,1)))*sum(wenop*this%I(i-2:i ,j,k))& + & +0.5_WP*(FQx(i,j,k,1)+abs(-FQx(i,j,k,1)))*sum(wenom*this%I(i-1:i+1,j,k)) + ! Centered internal energy flux + !FQx(i,j,k,2)=FQx(i,j,k,1)*0.5_WP*sum(this%I(i-1:i,j,k)) + ! Heat flux + FQx(i,j,k,2)=FQx(i,j,k,2)+0.5_WP*(this%DIFF(i-1,j,k)+this%DIFF(i,j,k))*this%dxi*(this%T(i,j,k)-this%T(i-1,j,k)) + ! Y fluxes + ! WENO mass flux + w=weno_weight((abs(this%Q(i,j-1,k,1)-this%Q(i,j-2,k,1))+eps)/(abs(this%Q(i,j,k,1)-this%Q(i,j-1,k,1))+eps)); wenop=0.5_WP*[ -w,1.0_WP+2.0_WP*w,1.0_WP-w] + w=weno_weight((abs(this%Q(i,j+1,k,1)-this%Q(i,j ,k,1))+eps)/(abs(this%Q(i,j,k,1)-this%Q(i,j-1,k,1))+eps)); wenom=0.5_WP*[1.0_WP-w,1.0_WP+2.0_WP*w, -w] + FQy(i,j,k,1)=-0.5_WP*(this%V(i,j,k)+abs(this%V(i,j,k)))*sum(wenop*this%Q(i,j-2:j ,k,1))& + & -0.5_WP*(this%V(i,j,k)-abs(this%V(i,j,k)))*sum(wenom*this%Q(i,j-1:j+1,k,1)) + ! Centered mass flux + !FQy(i,j,k,1)=-this%V(i,j,k)*0.5_WP*sum(this%Q(i,j-1:j,k,1)) + ! WENO internal energy flux + w=weno_weight((abs(this%I(i,j-1,k)-this%I(i,j-2,k))+eps)/(abs(this%I(i,j,k)-this%I(i,j-1,k))+eps)); wenop=0.5_WP*[ -w,1.0_WP+2.0_WP*w,1.0_WP-w] + w=weno_weight((abs(this%I(i,j+1,k)-this%I(i,j ,k))+eps)/(abs(this%I(i,j,k)-this%I(i,j-1,k))+eps)); wenom=0.5_WP*[1.0_WP-w,1.0_WP+2.0_WP*w, -w] + FQy(i,j,k,2)=0.5_WP*(FQy(i,j,k,1)-abs(-FQy(i,j,k,1)))*sum(wenop*this%I(i,j-2:j ,k))& + & +0.5_WP*(FQy(i,j,k,1)+abs(-FQy(i,j,k,1)))*sum(wenom*this%I(i,j-1:j+1,k)) + ! Centered internal energy flux + !FQy(i,j,k,2)=FQy(i,j,k,1)*0.5_WP*sum(this%I(i,j-1:j,k)) + ! Heat flux + FQy(i,j,k,2)=FQy(i,j,k,2)+0.5_WP*(this%DIFF(i,j-1,k)+this%DIFF(i,j,k))*this%dyi*(this%T(i,j,k)-this%T(i,j-1,k)) + ! Z fluxes + ! WENO mass flux + w=weno_weight((abs(this%Q(i,j,k-1,1)-this%Q(i,j,k-2,1))+eps)/(abs(this%Q(i,j,k,1)-this%Q(i,j,k-1,1))+eps)); wenop=0.5_WP*[ -w,1.0_WP+2.0_WP*w,1.0_WP-w] + w=weno_weight((abs(this%Q(i,j,k+1,1)-this%Q(i,j,k ,1))+eps)/(abs(this%Q(i,j,k,1)-this%Q(i,j,k-1,1))+eps)); wenom=0.5_WP*[1.0_WP-w,1.0_WP+2.0_WP*w, -w] + FQz(i,j,k,1)=-0.5_WP*(this%W(i,j,k)+abs(this%W(i,j,k)))*sum(wenop*this%Q(i,j,k-2:k ,1))& + & -0.5_WP*(this%W(i,j,k)-abs(this%W(i,j,k)))*sum(wenom*this%Q(i,j,k-1:k+1,1)) + ! Centered mass flux + !FQz(i,j,k,1)=-this%W(i,j,k)*0.5_WP*sum(this%Q(i,j,k-1:k,1)) + ! WENO internal energy flux + w=weno_weight((abs(this%I(i,j,k-1)-this%I(i,j,k-2))+eps)/(abs(this%I(i,j,k)-this%I(i,j,k-1))+eps)); wenop=0.5_WP*[ -w,1.0_WP+2.0_WP*w,1.0_WP-w] + w=weno_weight((abs(this%I(i,j,k+1)-this%I(i,j,k ))+eps)/(abs(this%I(i,j,k)-this%I(i,j,k-1))+eps)); wenom=0.5_WP*[1.0_WP-w,1.0_WP+2.0_WP*w, -w] + FQz(i,j,k,2)=0.5_WP*(FQz(i,j,k,1)-abs(-FQz(i,j,k,1)))*sum(wenop*this%I(i,j,k-2:k ))& + & +0.5_WP*(FQz(i,j,k,1)+abs(-FQz(i,j,k,1)))*sum(wenom*this%I(i,j,k-1:k+1)) + ! Centered internal energy flux + !FQz(i,j,k,2)=FQz(i,j,k,1)*0.5_WP*sum(this%I(i,j,k-1:k)) + ! Heat flux + FQz(i,j,k,2)=FQz(i,j,k,2)+0.5_WP*(this%DIFF(i,j,k-1)+this%DIFF(i,j,k))*this%dzi*(this%T(i,j,k)-this%T(i,j,k-1)) + end do + end do + end do + + ! Mass fluxes will be used to build momentum fluxes, they need to be extended by one cell on the left because of staggering + call this%cfg%sync(FQx(:,:,:,1)); if (.not.this%cfg%xper.and.this%cfg%iproc.eq.1) FQx(this%cfg%imin-1,:,:,1)=FQx(this%cfg%imin,:,:,1) + call this%cfg%sync(FQy(:,:,:,1)); if (.not.this%cfg%yper.and.this%cfg%jproc.eq.1) FQy(:,this%cfg%jmin-1,:,1)=FQy(:,this%cfg%jmin,:,1) + call this%cfg%sync(FQz(:,:,:,1)); if (.not.this%cfg%zper.and.this%cfg%kproc.eq.1) FQz(:,:,this%cfg%kmin-1,1)=FQz(:,:,this%cfg%kmin,1) + + ! Calculate cell-centered momentum fluxes with extra cell on the left due to staggering + do k=this%cfg%kmin_-1,this%cfg%kmax_ + do j=this%cfg%jmin_-1,this%cfg%jmax_ + do i=this%cfg%imin_-1,this%cfg%imax_ + FQx(i,j,k,3)=0.25_WP*sum(FQx(i:i+1,j,k,1))*sum(this%U(i:i+1,j,k))-this%P(i,j,k) + FQy(i,j,k,4)=0.25_WP*sum(FQy(i,j:j+1,k,1))*sum(this%V(i,j:j+1,k))-this%P(i,j,k) + FQz(i,j,k,5)=0.25_WP*sum(FQz(i,j,k:k+1,1))*sum(this%W(i,j,k:k+1))-this%P(i,j,k) + end do + end do + end do + + ! Calculate edge-centered momentum fluxes + do k=this%cfg%kmin_,this%cfg%kmax_+1 + do j=this%cfg%jmin_,this%cfg%jmax_+1 + do i=this%cfg%imin_,this%cfg%imax_+1 + FQy(i,j,k,3)=0.25_WP*sum(FQy(i-1:i,j,k,1))*sum(this%U(i,j-1:j,k)) + FQz(i,j,k,3)=0.25_WP*sum(FQz(i-1:i,j,k,1))*sum(this%U(i,j,k-1:k)) + FQx(i,j,k,4)=0.25_WP*sum(FQx(i,j-1:j,k,1))*sum(this%V(i-1:i,j,k)) + FQz(i,j,k,4)=0.25_WP*sum(FQz(i,j-1:j,k,1))*sum(this%V(i,j,k-1:k)) + FQx(i,j,k,5)=0.25_WP*sum(FQx(i,j,k-1:k,1))*sum(this%W(i-1:i,j,k)) + FQy(i,j,k,5)=0.25_WP*sum(FQy(i,j,k-1:k,1))*sum(this%W(i,j-1:j,k)) + end do + end do + end do + + ! Assemble time derivative for conserved variables + do k=this%cfg%kmin_,this%cfg%kmax_ + do j=this%cfg%jmin_,this%cfg%jmax_ + do i=this%cfg%imin_,this%cfg%imax_ + ! Mass and internal energy advection + dQdt(i,j,k,1)=this%dxi*(FQx(i+1,j,k,1)-FQx(i,j,k,1))+this%dyi*(FQy(i,j+1,k,1)-FQy(i,j,k,1))+this%dzi*(FQz(i,j,k+1,1)-FQz(i,j,k,1)) + dQdt(i,j,k,2)=this%dxi*(FQx(i+1,j,k,2)-FQx(i,j,k,2))+this%dyi*(FQy(i,j+1,k,2)-FQy(i,j,k,2))+this%dzi*(FQz(i,j,k+1,2)-FQz(i,j,k,2)) + ! Momentum advection and pressure stress + dQdt(i,j,k,3)=this%dxi*(FQx(i ,j,k,3)-FQx(i-1,j,k,3))+this%dyi*(FQy(i,j+1,k,3)-FQy(i,j ,k,3))+this%dzi*(FQz(i,j,k+1,3)-FQz(i,j,k ,3)) + dQdt(i,j,k,4)=this%dxi*(FQx(i+1,j,k,4)-FQx(i ,j,k,4))+this%dyi*(FQy(i,j ,k,4)-FQy(i,j-1,k,4))+this%dzi*(FQz(i,j,k+1,4)-FQz(i,j,k ,4)) + dQdt(i,j,k,5)=this%dxi*(FQx(i+1,j,k,5)-FQx(i ,j,k,5))+this%dyi*(FQy(i,j+1,k,5)-FQy(i,j ,k,5))+this%dzi*(FQz(i,j,k ,5)-FQz(i,j,k-1,5)) + ! Pressure dilatation term + dQdt(i,j,k,2)=dQdt(i,j,k,2)-this%P(i,j,k)*(this%dxi*(this%U(i+1,j,k)-this%U(i,j,k))+this%dyi*(this%V(i,j+1,k)-this%V(i,j,k))+this%dzi*(this%W(i,j,k+1)-this%W(i,j,k))) + end do + end do + end do + + ! ================================================================ ! + ! ======================== VISCOUS FLUXES ======================= ! + ! ================================================================ ! + + ! Zero out fluxes + FQx=0.0_WP; FQy=0.0_WP; FQz=0.0_WP + + ! Compute cell-centered momentum viscous fluxes + do k=this%cfg%kmin_-1,this%cfg%kmax_ + do j=this%cfg%jmin_-1,this%cfg%jmax_ + do i=this%cfg%imin_-1,this%cfg%imax_ + div=this%dxi*(this%U(i+1,j,k)-this%U(i,j,k))+this%dyi*(this%V(i,j+1,k)-this%V(i,j,k))+this%dzi*(this%W(i,j,k+1)-this%W(i,j,k)) + FQx(i,j,k,3)=2.0_WP*this%VISC(i,j,k)*this%dxi*(this%U(i+1,j,k)-this%U(i,j,k))+(this%BETA(i,j,k)-2.0_WP*this%VISC(i,j,k)/3.0_WP)*div + FQy(i,j,k,4)=2.0_WP*this%VISC(i,j,k)*this%dyi*(this%V(i,j+1,k)-this%V(i,j,k))+(this%BETA(i,j,k)-2.0_WP*this%VISC(i,j,k)/3.0_WP)*div + FQz(i,j,k,5)=2.0_WP*this%VISC(i,j,k)*this%dzi*(this%W(i,j,k+1)-this%W(i,j,k))+(this%BETA(i,j,k)-2.0_WP*this%VISC(i,j,k)/3.0_WP)*div + end do + end do + end do + + ! Compute edge-centered momentum viscous fluxes and corresponding viscous heating + do k=this%cfg%kmin_,this%cfg%kmax_+1 + do j=this%cfg%jmin_,this%cfg%jmax_+1 + do i=this%cfg%imin_,this%cfg%imax_+1 + FQy(i,j,k,3)=0.25_WP*sum(this%VISC(i-1:i,j-1:j,k))*(this%dyi*(this%U(i,j,k)-this%U(i,j-1,k))+this%dxi*(this%V(i,j,k)-this%V(i-1,j,k))); FQx(i,j,k,4)=FQy(i,j,k,3) + FQz(i,j,k,2)=FQy(i,j,k,3)*(this%dyi*(this%U(i,j,k)-this%U(i,j-1,k))+this%dxi*(this%V(i,j,k)-this%V(i-1,j,k))) + FQz(i,j,k,4)=0.25_WP*sum(this%VISC(i,j-1:j,k-1:k))*(this%dzi*(this%V(i,j,k)-this%V(i,j,k-1))+this%dyi*(this%W(i,j,k)-this%W(i,j-1,k))); FQy(i,j,k,5)=FQz(i,j,k,4) + FQx(i,j,k,2)=FQz(i,j,k,4)*(this%dzi*(this%V(i,j,k)-this%V(i,j,k-1))+this%dyi*(this%W(i,j,k)-this%W(i,j-1,k))) + FQx(i,j,k,5)=0.25_WP*sum(this%VISC(i-1:i,j,k-1:k))*(this%dxi*(this%W(i,j,k)-this%W(i-1,j,k))+this%dzi*(this%U(i,j,k)-this%U(i,j,k-1))); FQz(i,j,k,3)=FQx(i,j,k,5) + FQy(i,j,k,2)=FQx(i,j,k,5)*(this%dxi*(this%W(i,j,k)-this%W(i-1,j,k))+this%dzi*(this%U(i,j,k)-this%U(i,j,k-1))) + end do + end do + end do + + ! Assemble time derivative for conserved variables + do k=this%cfg%kmin_,this%cfg%kmax_ + do j=this%cfg%jmin_,this%cfg%jmax_ + do i=this%cfg%imin_,this%cfg%imax_ + ! Viscous momentum transport + dQdt(i,j,k,3)=dQdt(i,j,k,3)+this%dxi*(FQx(i ,j,k,3)-FQx(i-1,j,k,3))+this%dyi*(FQy(i,j+1,k,3)-FQy(i,j ,k,3))+this%dzi*(FQz(i,j,k+1,3)-FQz(i,j,k ,3)) + dQdt(i,j,k,4)=dQdt(i,j,k,4)+this%dxi*(FQx(i+1,j,k,4)-FQx(i ,j,k,4))+this%dyi*(FQy(i,j ,k,4)-FQy(i,j-1,k,4))+this%dzi*(FQz(i,j,k+1,4)-FQz(i,j,k ,4)) + dQdt(i,j,k,5)=dQdt(i,j,k,5)+this%dxi*(FQx(i+1,j,k,5)-FQx(i ,j,k,5))+this%dyi*(FQy(i,j+1,k,5)-FQy(i,j ,k,5))+this%dzi*(FQz(i,j,k ,5)-FQz(i,j,k-1,5)) + ! Viscous heating term + dQdt(i,j,k,2)=dQdt(i,j,k,2)+FQx(i,j,k,3)*this%dxi*(this%U(i+1,j,k)-this%U(i,j,k))+FQy(i,j,k,4)*this%dyi*(this%V(i,j+1,k)-this%V(i,j,k))+FQz(i,j,k,5)*this%dzi*(this%W(i,j,k+1)-this%W(i,j,k))+0.25_WP*sum(FQz(i:i+1,j:j+1,k,2))+0.25_WP*sum(FQx(i,j:j+1,k:k+1,2))+0.25_WP*sum(FQy(i:i+1,j,k:k+1,2)) + end do + end do + end do + + ! Deallocate flux arrays + deallocate(FQx,FQy,FQz) + + ! Synchronize all dQdt fields + do n=1,this%nQ; call this%cfg%sync(dQdt(:,:,:,n)); end do + + ! Stop rhs timer + call this%trhs%stop() + + contains + !> WENO switch function + real(WP) function weno_weight(ratio) + implicit none + real(WP), intent(in) :: ratio + real(WP), parameter :: lambda=0.13_WP ! Switching parameter + real(WP), parameter :: delta=0.01_WP ! Switching thickness + weno_weight=(1.0_WP-tanh((ratio-lambda)/delta))/3.0_WP+(1.0_WP-tanh((ratio-1.0_WP/lambda)/delta))/6.0_WP + end function weno_weight + end subroutine rhs + + + !> Calculate divergence of stress for LPT solver + subroutine get_div_stress(this,divx,divy,divz) + implicit none + class(spcomp), intent(inout) :: this + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(out) :: divx !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(out) :: divy !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(out) :: divz !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + real(WP), dimension(:,:,:,:), allocatable :: FQx,FQy,FQz + integer :: i,j,k + real(WP) :: div + + ! Zero out divergence of stresses + divx=0.0_WP + divy=0.0_WP + divz=0.0_WP + + ! Allocate fluxes of conserved variables + allocate(FQx(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_,1:3)); FQx=0.0_WP + allocate(FQy(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_,1:3)); FQy=0.0_WP + allocate(FQz(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_,1:3)); FQz=0.0_WP + + ! Compute cell-centered momentum fluxes + do k=this%cfg%kmin_-1,this%cfg%kmax_ + do j=this%cfg%jmin_-1,this%cfg%jmax_ + do i=this%cfg%imin_-1,this%cfg%imax_ + div=this%dxi*(this%U(i+1,j,k)-this%U(i,j,k))+this%dyi*(this%V(i,j+1,k)-this%V(i,j,k))+this%dzi*(this%W(i,j,k+1)-this%W(i,j,k)) + FQx(i,j,k,1)=2.0_WP*this%VISC(i,j,k)*this%dxi*(this%U(i+1,j,k)-this%U(i,j,k))+(this%BETA(i,j,k)-2.0_WP*this%VISC(i,j,k)/3.0_WP)*div-this%P(i,j,k) + FQy(i,j,k,2)=2.0_WP*this%VISC(i,j,k)*this%dyi*(this%V(i,j+1,k)-this%V(i,j,k))+(this%BETA(i,j,k)-2.0_WP*this%VISC(i,j,k)/3.0_WP)*div-this%P(i,j,k) + FQz(i,j,k,3)=2.0_WP*this%VISC(i,j,k)*this%dzi*(this%W(i,j,k+1)-this%W(i,j,k))+(this%BETA(i,j,k)-2.0_WP*this%VISC(i,j,k)/3.0_WP)*div-this%P(i,j,k) + end do + end do + end do + + ! Compute edge-centered momentum viscous fluxes and corresponding viscous heating + do k=this%cfg%kmin_,this%cfg%kmax_+1 + do j=this%cfg%jmin_,this%cfg%jmax_+1 + do i=this%cfg%imin_,this%cfg%imax_+1 + ! Momentum fluxes + FQy(i,j,k,1)=0.25_WP*sum(this%VISC(i-1:i,j-1:j,k))*(this%dyi*(this%U(i,j,k)-this%U(i,j-1,k))+this%dxi*(this%V(i,j,k)-this%V(i-1,j,k))); FQx(i,j,k,2)=FQy(i,j,k,1) + FQz(i,j,k,2)=0.25_WP*sum(this%VISC(i,j-1:j,k-1:k))*(this%dzi*(this%V(i,j,k)-this%V(i,j,k-1))+this%dyi*(this%W(i,j,k)-this%W(i,j-1,k))); FQy(i,j,k,3)=FQz(i,j,k,2) + FQx(i,j,k,3)=0.25_WP*sum(this%VISC(i-1:i,j,k-1:k))*(this%dxi*(this%W(i,j,k)-this%W(i-1,j,k))+this%dzi*(this%U(i,j,k)-this%U(i,j,k-1))); FQz(i,j,k,1)=FQx(i,j,k,3) + end do + end do + end do + + do i=1,3 + call this%cfg%sync(FQx(:,:,:,i)) + call this%cfg%sync(FQy(:,:,:,i)) + call this%cfg%sync(FQz(:,:,:,i)) + end do + + ! Assemble time derivative for conserved variables + do k=this%cfg%kmin_,this%cfg%kmax_ + do j=this%cfg%jmin_,this%cfg%jmax_ + do i=this%cfg%imin_,this%cfg%imax_ + ! Viscous momentum transport + divx(i,j,k)=this%dxi*(FQx(i ,j,k,1)-FQx(i-1,j,k,1))+this%dyi*(FQy(i,j+1,k,1)-FQy(i,j ,k,1))+this%dzi*(FQz(i,j,k+1,1)-FQz(i,j,k ,1)) + divy(i,j,k)=this%dxi*(FQx(i+1,j,k,2)-FQx(i ,j,k,2))+this%dyi*(FQy(i,j ,k,2)-FQy(i,j-1,k,2))+this%dzi*(FQz(i,j,k+1,2)-FQz(i,j,k ,2)) + divz(i,j,k)=this%dxi*(FQx(i+1,j,k,3)-FQx(i ,j,k,3))+this%dyi*(FQy(i,j+1,k,3)-FQy(i,j ,k,3))+this%dzi*(FQz(i,j,k ,3)-FQz(i,j,k-1,3)) + end do + end do + end do + + ! Deallocate flux arrays + deallocate(FQx,FQy,FQz) + + ! Synchronize + call this%cfg%sync(divx) + call this%cfg%sync(divy) + call this%cfg%sync(divz) + + end subroutine get_div_stress + + + !> Calculate all primitive variables from updated conserved variables + subroutine get_primitive(this) + implicit none + class(spcomp), intent(inout) :: this + integer :: i,j,k + ! Get velocity + call this%get_velocity() + ! Get primitive variables + do k=this%cfg%kmino_,this%cfg%kmaxo_; do j=this%cfg%jmino_,this%cfg%jmaxo_; do i=this%cfg%imino_,this%cfg%imaxo_ + this%I(i,j,k)=this%Q(i,j,k,2)/this%Q(i,j,k,1) + this%P(i,j,k)=this%getP(this%Q(i,j,k,1),this%I(i,j,k)) + this%C(i,j,k)=this%getC(this%Q(i,j,k,1),this%P(i,j,k)) + end do; end do; end do + ! Get temperature + if (associated(this%getT)) then + do k=this%cfg%kmino_,this%cfg%kmaxo_; do j=this%cfg%jmino_,this%cfg%jmaxo_; do i=this%cfg%imino_,this%cfg%imaxo_ + this%T(i,j,k)=this%getT(this%Q(i,j,k,1),this%P(i,j,k)) + end do; end do; end do + end if + end subroutine get_primitive + + + !> Calculate velocity from momentum and density + subroutine get_velocity(this) + implicit none + class(spcomp), intent(inout) :: this + integer :: i,j,k + ! Calculate velocity as far as possible + do k=this%cfg%kmino_+1,this%cfg%kmaxo_ + do j=this%cfg%jmino_+1,this%cfg%jmaxo_ + do i=this%cfg%imino_+1,this%cfg%imaxo_ + this%U(i,j,k)=2.0_WP*this%Q(i,j,k,3)/sum(this%Q(i-1:i,j,k,1)) + this%V(i,j,k)=2.0_WP*this%Q(i,j,k,4)/sum(this%Q(i,j-1:j,k,1)) + this%W(i,j,k)=2.0_WP*this%Q(i,j,k,5)/sum(this%Q(i,j,k-1:k,1)) + end do + end do + end do + ! Sync velocity + call this%cfg%sync(this%U) + call this%cfg%sync(this%V) + call this%cfg%sync(this%W) + ! Add last layer in each direction + if (.not.this%cfg%xper.and.this%cfg%iproc.eq.1) then + this%U(this%cfg%imino,:,:)=this%Q(this%cfg%imino,:,:,3)/(this%Q(this%cfg%imino,:,:,1)) + this%V(this%cfg%imino,:,:)=this%Q(this%cfg%imino,:,:,4)/(this%Q(this%cfg%imino,:,:,1)) + this%W(this%cfg%imino,:,:)=this%Q(this%cfg%imino,:,:,5)/(this%Q(this%cfg%imino,:,:,1)) + end if + if (.not.this%cfg%yper.and.this%cfg%jproc.eq.1) then + this%U(:,this%cfg%jmino,:)=this%Q(:,this%cfg%jmino,:,3)/(this%Q(:,this%cfg%jmino,:,1)) + this%V(:,this%cfg%jmino,:)=this%Q(:,this%cfg%jmino,:,4)/(this%Q(:,this%cfg%jmino,:,1)) + this%W(:,this%cfg%jmino,:)=this%Q(:,this%cfg%jmino,:,5)/(this%Q(:,this%cfg%jmino,:,1)) + end if + if (.not.this%cfg%zper.and.this%cfg%kproc.eq.1) then + this%U(:,:,this%cfg%kmino)=this%Q(:,:,this%cfg%kmino,3)/(this%Q(:,:,this%cfg%kmino,1)) + this%V(:,:,this%cfg%kmino)=this%Q(:,:,this%cfg%kmino,4)/(this%Q(:,:,this%cfg%kmino,1)) + this%W(:,:,this%cfg%kmino)=this%Q(:,:,this%cfg%kmino,5)/(this%Q(:,:,this%cfg%kmino,1)) + end if + end subroutine get_velocity + + + !> Calculate kinetic energy per unit mass from pre-calculated velocity + !> Need to redo this better + subroutine get_ke(this,KE) + implicit none + class(spcomp), intent(inout) :: this + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(out) :: KE !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + integer :: i,j,k + do k=this%cfg%kmino_,this%cfg%kmaxo_-1 + do j=this%cfg%jmino_,this%cfg%jmaxo_-1 + do i=this%cfg%imino_,this%cfg%imaxo_-1 + KE(i,j,k)=0.5_WP*sum(this%U(i:i+1,j,k)**2+this%V(i,j:j+1,k)**2+this%W(i,j,k:k+1)**2) + end do + end do + end do + call this%cfg%sync(KE) + if (.not.this%cfg%xper.and.this%cfg%iproc.eq.this%cfg%npx) KE(this%cfg%imaxo,:,:)=KE(this%cfg%imaxo-1,:,:) + if (.not.this%cfg%yper.and.this%cfg%jproc.eq.this%cfg%npy) KE(:,this%cfg%jmaxo,:)=KE(:,this%cfg%jmaxo-1,:) + if (.not.this%cfg%zper.and.this%cfg%kproc.eq.this%cfg%npz) KE(:,:,this%cfg%kmaxo)=KE(:,:,this%cfg%kmaxo-1) + end subroutine get_ke + + + !> Calculate momentum from velocity and density + subroutine get_momentum(this) + implicit none + class(spcomp), intent(inout) :: this + integer :: i,j,k + ! Calculate momentum as far as possible + do k=this%cfg%kmino_+1,this%cfg%kmaxo_ + do j=this%cfg%jmino_+1,this%cfg%jmaxo_ + do i=this%cfg%imino_+1,this%cfg%imaxo_ + this%Q(i,j,k,3)=0.5_WP*sum(this%Q(i-1:i,j,k,1))*this%U(i,j,k) + this%Q(i,j,k,4)=0.5_WP*sum(this%Q(i,j-1:j,k,1))*this%V(i,j,k) + this%Q(i,j,k,5)=0.5_WP*sum(this%Q(i,j,k-1:k,1))*this%W(i,j,k) + end do + end do + end do + ! Sync momentum + call this%cfg%sync(this%Q(:,:,:,3)) + call this%cfg%sync(this%Q(:,:,:,4)) + call this%cfg%sync(this%Q(:,:,:,5)) + ! Add last layer in each direction + if (.not.this%cfg%xper.and.this%cfg%iproc.eq.1) then + this%Q(this%cfg%imino,:,:,3)=this%Q(this%cfg%imino,:,:,1)*this%U(this%cfg%imino,:,:) + this%Q(this%cfg%imino,:,:,4)=this%Q(this%cfg%imino,:,:,1)*this%V(this%cfg%imino,:,:) + this%Q(this%cfg%imino,:,:,5)=this%Q(this%cfg%imino,:,:,1)*this%W(this%cfg%imino,:,:) + end if + if (.not.this%cfg%yper.and.this%cfg%jproc.eq.1) then + this%Q(:,this%cfg%jmino,:,3)=this%Q(:,this%cfg%jmino,:,1)*this%U(:,this%cfg%jmino,:) + this%Q(:,this%cfg%jmino,:,4)=this%Q(:,this%cfg%jmino,:,1)*this%V(:,this%cfg%jmino,:) + this%Q(:,this%cfg%jmino,:,5)=this%Q(:,this%cfg%jmino,:,1)*this%W(:,this%cfg%jmino,:) + end if + if (.not.this%cfg%zper.and.this%cfg%kproc.eq.1) then + this%Q(:,:,this%cfg%kmino,3)=this%Q(:,:,this%cfg%kmino,1)*this%U(:,:,this%cfg%kmino) + this%Q(:,:,this%cfg%kmino,4)=this%Q(:,:,this%cfg%kmino,1)*this%V(:,:,this%cfg%kmino) + this%Q(:,:,this%cfg%kmino,5)=this%Q(:,:,this%cfg%kmino,1)*this%W(:,:,this%cfg%kmino) + end if + end subroutine get_momentum + + + !> Interpolate velocity to cell-center, including overlap and ghosts + subroutine interp_vel(this,Ui,Vi,Wi) + implicit none + class(spcomp), intent(inout) :: this + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(out) :: Ui !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(out) :: Vi !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(out) :: Wi !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + integer :: i,j,k + ! Calculate interpolated velocity as far as possible + do k=this%cfg%kmino_,this%cfg%kmaxo_-1 + do j=this%cfg%jmino_,this%cfg%jmaxo_-1 + do i=this%cfg%imino_,this%cfg%imaxo_-1 + Ui(i,j,k)=0.5_WP*sum(this%U(i:i+1,j,k)) + Vi(i,j,k)=0.5_WP*sum(this%V(i,j:j+1,k)) + Wi(i,j,k)=0.5_WP*sum(this%W(i,j,k:k+1)) + end do + end do + end do + ! Sync interpolated velocity + call this%cfg%sync(Ui) + call this%cfg%sync(Vi) + call this%cfg%sync(Wi) + ! Add last layer in each direction + if (.not.this%cfg%xper.and.this%cfg%iproc.eq.this%cfg%npx) then + Ui(this%cfg%imaxo,:,:)=this%U(this%cfg%imaxo,:,:) + Vi(this%cfg%imaxo,:,:)=this%V(this%cfg%imaxo,:,:) + Wi(this%cfg%imaxo,:,:)=this%W(this%cfg%imaxo,:,:) + end if + if (.not.this%cfg%yper.and.this%cfg%jproc.eq.this%cfg%npy) then + Ui(:,this%cfg%jmaxo,:)=this%U(:,this%cfg%jmaxo,:) + Vi(:,this%cfg%jmaxo,:)=this%V(:,this%cfg%jmaxo,:) + Wi(:,this%cfg%jmaxo,:)=this%W(:,this%cfg%jmaxo,:) + end if + if (.not.this%cfg%zper.and.this%cfg%kproc.eq.this%cfg%npz) then + Ui(:,:,this%cfg%kmaxo)=this%U(:,:,this%cfg%kmaxo) + Vi(:,:,this%cfg%kmaxo)=this%V(:,:,this%cfg%kmaxo) + Wi(:,:,this%cfg%kmaxo)=this%W(:,:,this%cfg%kmaxo) + end if + end subroutine interp_vel + + + !> Get artifical bulk kinematic viscosity + subroutine get_viscartif(this,dt,beta) + implicit none + class(spcomp), intent(inout) :: this + real(WP), intent(in) :: dt + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(out) :: beta + integer :: i,j,k,si,sj,sk,n + integer, parameter :: nfilter=1 + real(WP) :: max_beta,dudy,dudz,dvdx,dvdz,dwdx,dwdy,vort,grad_div,H + real(WP), parameter :: max_cfl=0.5_WP + real(WP), parameter :: Cartif=2.0_WP + real(WP), parameter :: Cartif_vort=100.0_WP + real(WP), dimension(:,:,:), allocatable :: div + real(WP), dimension(-1:+1), parameter :: filter=[1.0_WP/6.0_WP,2.0_WP/3.0_WP,1.0_WP/6.0_WP] + ! Calculate max beta permissible + max_beta=max_cfl*min(this%dx**2,this%dy**2,this%dz**2)/(4.0_WP*dt) + ! Zero out array + beta=0.0_WP + ! Compute velocity divergence + allocate(div(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + do k=this%cfg%kmino_,this%cfg%kmaxo_-1; do j=this%cfg%jmino_,this%cfg%jmaxo_-1; do i=this%cfg%imino_,this%cfg%imaxo_-1 + div(i,j,k)=this%dxi*(this%U(i+1,j,k)-this%U(i,j,k))+this%dyi*(this%V(i,j+1,k)-this%V(i,j,k))+this%dzi*(this%W(i,j,k+1)-this%W(i,j,k)) + end do; end do; end do + call this%cfg%sync(div) + if (.not.this%cfg%xper.and.this%cfg%iproc.eq.this%cfg%npx) div(this%cfg%imaxo,:,:)=div(this%cfg%imaxo-1,:,:) + if (.not.this%cfg%yper.and.this%cfg%jproc.eq.this%cfg%npy) div(:,this%cfg%jmaxo,:)=div(:,this%cfg%jmaxo-1,:) + if (.not.this%cfg%zper.and.this%cfg%kproc.eq.this%cfg%npz) div(:,:,this%cfg%kmaxo)=div(:,:,this%cfg%kmaxo-1) + ! Compute artificial bulk viscosity based on gradU provided + do k=this%cfg%kmin_,this%cfg%kmax_; do j=this%cfg%jmin_,this%cfg%jmax_; do i=this%cfg%imin_,this%cfg%imax_ + ! Only work in compression regions + if (div(i,j,k).ge.0.0_WP) cycle + ! Compute local vorticity + dudy=0.25_WP*this%dyi*sum(this%U(i:i+1,j:j+1,k)-this%U(i:i+1,j-1:j,k)) + dudz=0.25_WP*this%dzi*sum(this%U(i:i+1,j,k:k+1)-this%U(i:i+1,j,k-1:k)) + dvdx=0.25_WP*this%dxi*sum(this%V(i:i+1,j:j+1,k)-this%V(i-1:i,j:j+1,k)) + dvdz=0.25_WP*this%dzi*sum(this%V(i,j:j+1,k:k+1)-this%V(i,j:j+1,k-1:k)) + dwdx=0.25_WP*this%dxi*sum(this%W(i:i+1,j,k:k+1)-this%W(i-1:i,j,k:k+1)) + dwdy=0.25_WP*this%dyi*sum(this%W(i,j:j+1,k:k+1)-this%W(i,j-1:j,k:k+1)) + vort=(dwdy-dvdz)**2+(dudz-dwdx)**2+(dvdx-dudy)**2 + ! Compute |grad(div)| + grad_div=max(abs(div(i+1,j,k)-div(i,j,k)),abs(div(i,j,k)-div(i-1,j,k)))*this%dx**2& + & +max(abs(div(i,j+1,k)-div(i,j,k)),abs(div(i,j,k)-div(i,j-1,k)))*this%dy**2& + & +max(abs(div(i,j,k+1)-div(i,j,k)),abs(div(i,j,k)-div(i,j,k-1)))*this%dz**2 + ! Estimate artificial kinematic viscosity using grad(div) + !beta(i,j,k)=Cartif*grad_div*div(i,j,k)**2/(div(i,j,k)**2+Cartif_vort*vort+1.0e-15_WP) + + ! Sensor originally proposed by Ducros et al. (1999) and later improved by + ! Hendrickson, T. R., Kartha, A., & Candler, G. V. (2018) + vort=max(vort,(0.05_WP*this%C(i,j,k)/min(this%dx,this%dy))**2) + beta(i,j,k)=Cartif*grad_div*min(4.0_WP/3.0_WP*div(i,j,k)**2/(div(i,j,k)**2+vort+epsilon(1.0_WP)),1.0_WP) + ! Clip it so CFL Get kinematic eddy viscosity using Vreman's model + subroutine get_vreman(this,dt,visc) + implicit none + class(spcomp), intent(inout) :: this + real(WP), intent(in) :: dt + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(out) :: visc + real(WP), parameter :: Cs_ref=0.17_WP + real(WP), parameter :: max_cfl=0.5_WP + real(WP) :: max_visc,A,B,C + real(WP), dimension(1:3,1:3) :: beta,gradU + real(WP), dimension(:,:,:), allocatable :: tmp + real(WP), dimension(-1:+1), parameter :: filter=[1.0_WP/6.0_WP,2.0_WP/3.0_WP,1.0_WP/6.0_WP] + integer :: i,j,k,si,sj,sk,n + integer, parameter :: nfilter=1 + ! Model constant is c=2.5*Cs_ref**2 - Vreman uses c=0.07 which corresponds to Cs_ref=0.17 + C=2.5_WP*Cs_ref**2 + ! Calculate max visc permissible + max_visc=max_cfl*min(this%dx**2,this%dy**2,this%dz**2)/(4.0_WP*dt) + ! Zero out array + visc=0.0_WP + ! Compute the eddy viscosity + do k=this%cfg%kmin_,this%cfg%kmax_; do j=this%cfg%jmin_,this%cfg%jmax_; do i=this%cfg%imin_,this%cfg%imax_ + ! Compute velocity gradient tensor + gradU(1,1)=this%dxi*(this%U(i+1,j,k)-this%U(i,j,k)) + gradU(2,1)=0.25_WP*this%dyi*sum(this%U(i:i+1,j:j+1,k)-this%U(i:i+1,j-1:j,k)) + gradU(3,1)=0.25_WP*this%dzi*sum(this%U(i:i+1,j,k:k+1)-this%U(i:i+1,j,k-1:k)) + gradU(1,2)=0.25_WP*this%dxi*sum(this%V(i:i+1,j:j+1,k)-this%V(i-1:i,j:j+1,k)) + gradU(2,2)=this%dyi*(this%V(i,j+1,k)-this%V(i,j,k)) + gradU(3,2)=0.25_WP*this%dzi*sum(this%V(i,j:j+1,k:k+1)-this%V(i,j:j+1,k-1:k)) + gradU(1,3)=0.25_WP*this%dxi*sum(this%W(i:i+1,j,k:k+1)-this%W(i-1:i,j,k:k+1)) + gradU(2,3)=0.25_WP*this%dyi*sum(this%W(i,j:j+1,k:k+1)-this%W(i,j-1:j,k:k+1)) + gradU(3,3)=this%dzi*(this%W(i,j,k+1)-this%W(i,j,k)) + ! Compute A=gradu_ij*gradu_ij invariant + A=sum(gradU**2) + ! Compute beta_ij=dx_m*dx_m*gradu_mi*gradu_mj + do sj=1,3; do si=1,3; beta(si,sj)=this%dx**2*gradU(1,si)*gradU(1,sj)+this%dy**2*gradU(2,si)*gradU(2,sj)+this%dz**2*gradU(3,si)*gradU(3,sj); end do; end do + ! Compute B invariant + B=beta(1,1)*beta(2,2)-beta(1,2)**2+beta(1,1)*beta(3,3)-beta(1,3)**2+beta(2,2)*beta(3,3)-beta(2,3)**2 + ! Assemble algebraic eddy viscosity model + if (B.lt.1.0e-8_WP) then + visc(i,j,k)=0.0_WP + else + visc(i,j,k)=C*sqrt(B/A) + end if + ! Clip it so CFL Calculate the CFL + subroutine get_cfl(this,dt,cfl) + use mpi_f08, only: MPI_ALLREDUCE,MPI_MAX,MPI_IN_PLACE + use parallel, only: MPI_REAL_WP + implicit none + class(spcomp), intent(inout) :: this + real(WP), intent(in) :: dt + real(WP), intent(out) :: cfl + integer :: ierr + real(WP) :: maxvisc,maxC + ! Compute convective+acoustic CFLs + this%CFLc_x=maxval(abs(this%U)+abs(this%C))*dt*this%dxi; call MPI_ALLREDUCE(MPI_IN_PLACE,this%CFLc_x,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + this%CFLc_y=maxval(abs(this%V)+abs(this%C))*dt*this%dyi; call MPI_ALLREDUCE(MPI_IN_PLACE,this%CFLc_y,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + this%CFLc_z=maxval(abs(this%W)+abs(this%C))*dt*this%dzi; call MPI_ALLREDUCE(MPI_IN_PLACE,this%CFLc_z,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + ! Compute acoustic CFLs + maxC=maxval(this%C); call MPI_ALLREDUCE(MPI_IN_PLACE,maxC,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + this%CFLa_x=maxC*dt*this%dxi + this%CFLa_y=maxC*dt*this%dyi + this%CFLa_z=maxC*dt*this%dzi + ! Compute viscous CFLs + maxvisc=maxval((this%VISC+this%BETA)/this%Q(:,:,:,1)); call MPI_ALLREDUCE(MPI_IN_PLACE,maxvisc,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + this%CFLv_x=4.0_WP*maxvisc*dt*this%dxi**2 + this%CFLv_y=4.0_WP*maxvisc*dt*this%dyi**2 + this%CFLv_z=4.0_WP*maxvisc*dt*this%dzi**2 + ! Return the maximum overall CFL + cfl=max(this%CFLc_x,this%CFLc_y,this%CFLc_z,& + & this%CFLa_x,this%CFLa_y,this%CFLa_z,& + & this%CFLv_x,this%CFLv_y,this%CFLv_z) + end subroutine get_cfl + + + !> Calculate info about our fields + subroutine get_info(this) + use mpi_f08, only: MPI_ALLREDUCE,MPI_MIN,MPI_MAX,MPI_IN_PLACE + use parallel, only: MPI_REAL_WP + implicit none + class(spcomp), intent(inout) :: this + integer :: n,i,j,k,ierr + real(WP), dimension(:,:,:), allocatable :: tmp + + ! Compute integrals and extrema of conserved variables + do n=1,this%nQ + call this%cfg%integrate(this%Q(:,:,:,n),integral=this%Qint(n)) + end do + this%Qmin=+huge(1.0_WP) + this%Qmax=-huge(1.0_WP) + do k=this%cfg%kmin_,this%cfg%kmax_; do j=this%cfg%jmin_,this%cfg%jmax_; do i=this%cfg%imin_,this%cfg%imax_ + do n=1,this%nQ + this%Qmin(n)=min(this%Qmin(n),this%Q(i,j,k,n)) + this%Qmax(n)=max(this%Qmax(n),this%Q(i,j,k,n)) + end do + end do; end do; end do + call MPI_ALLREDUCE(MPI_IN_PLACE,this%Qmin,this%nQ,MPI_REAL_WP,MPI_MIN,this%cfg%comm,ierr) + call MPI_ALLREDUCE(MPI_IN_PLACE,this%Qmax,this%nQ,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + + ! Also compute integral of KE and entropy + allocate(tmp(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + call this%get_ke(tmp); tmp=this%Q(:,:,:,1)*tmp; call this%cfg%integrate(tmp,integral=this%RHOKint) + this%RHOSint=0.0_WP + if (associated(this%getS)) then + do k=this%cfg%kmin_,this%cfg%kmax_; do j=this%cfg%jmin_,this%cfg%jmax_; do i=this%cfg%imin_,this%cfg%imax_ + tmp(i,j,k)=this%Q(i,j,k,1)*this%getS(this%Q(i,j,k,1),this%P(i,j,k)) + end do; end do; end do + call this%cfg%integrate(tmp,integral=this%RHOSint) + end if + deallocate(tmp) + + ! Calculate extrema of primitive fields + this%RHOmin=+huge(1.0_WP); this%RHOmax=-huge(1.0_WP) + this%Imin =+huge(1.0_WP); this%Imax =-huge(1.0_WP) + this%Pmin =+huge(1.0_WP); this%Pmax =-huge(1.0_WP) + this%Tmin =+huge(1.0_WP); this%Tmax =-huge(1.0_WP) + this%Umax=0.0_WP; this%Vmax=0.0_WP; this%Wmax=0.0_WP + do k=this%cfg%kmin_,this%cfg%kmax_; do j=this%cfg%jmin_,this%cfg%jmax_; do i=this%cfg%imin_,this%cfg%imax_ + this%RHOmin=min(this%RHOmin,this%Q(i,j,k,1)); this%RHOmax=max(this%RHOmax,this%Q(i,j,k,1)) + this%Imin =min(this%Imin ,this%I (i,j,k)); this%Imax =max(this%Imax ,this%I (i,j,k)) + this%Pmin =min(this%Pmin ,this%P (i,j,k)); this%Pmax =max(this%Pmax ,this%P (i,j,k)) + this%Tmin =min(this%Tmin ,this%T (i,j,k)); this%Tmax =max(this%Tmax ,this%T (i,j,k)) + this%Umax=max(this%Umax,abs(this%U(i,j,k))) + this%Vmax=max(this%Vmax,abs(this%V(i,j,k))) + this%Wmax=max(this%Wmax,abs(this%W(i,j,k))) + end do; end do; end do + call MPI_ALLREDUCE(MPI_IN_PLACE,this%RHOmin,1,MPI_REAL_WP,MPI_MIN,this%cfg%comm,ierr) + call MPI_ALLREDUCE(MPI_IN_PLACE,this%RHOmax,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + call MPI_ALLREDUCE(MPI_IN_PLACE,this%Imin ,1,MPI_REAL_WP,MPI_MIN,this%cfg%comm,ierr) + call MPI_ALLREDUCE(MPI_IN_PLACE,this%Imax ,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + call MPI_ALLREDUCE(MPI_IN_PLACE,this%Pmin ,1,MPI_REAL_WP,MPI_MIN,this%cfg%comm,ierr) + call MPI_ALLREDUCE(MPI_IN_PLACE,this%Pmax ,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + call MPI_ALLREDUCE(MPI_IN_PLACE,this%Tmin ,1,MPI_REAL_WP,MPI_MIN,this%cfg%comm,ierr) + call MPI_ALLREDUCE(MPI_IN_PLACE,this%Tmax ,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + call MPI_ALLREDUCE(MPI_IN_PLACE,this%Umax ,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + call MPI_ALLREDUCE(MPI_IN_PLACE,this%Vmax ,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + call MPI_ALLREDUCE(MPI_IN_PLACE,this%Wmax ,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + + end subroutine get_info + + + !> Print out info for spcomp flow solver + subroutine spcomp_print(this) + use, intrinsic :: iso_fortran_env, only: output_unit + implicit none + class(spcomp), intent(in) :: this + if (this%cfg%amRoot) write(output_unit,'("spcomp solver [",a,"] for config [",a,"]")') trim(this%name),trim(this%cfg%name) + end subroutine spcomp_print + + + !> Finalize spcomp flow solver + subroutine finalize(this) + implicit none + class(spcomp), intent(inout) :: this + nullify(this%cfg) + this%name='UNNAMED_SPCOMP' + nullify(this%getP) + nullify(this%getT) + nullify(this%getC) + nullify(this%getS) + this%nQ=0 + if (allocated(this%Q)) deallocate(this%Q) + if (allocated(this%Qold)) deallocate(this%Qold) + if (allocated(this%U)) deallocate(this%U) + if (allocated(this%V)) deallocate(this%V) + if (allocated(this%W)) deallocate(this%W) + if (allocated(this%I)) deallocate(this%I) + if (allocated(this%P)) deallocate(this%P) + if (allocated(this%T)) deallocate(this%T) + if (allocated(this%C)) deallocate(this%C) + if (allocated(this%VISC)) deallocate(this%VISC) + if (allocated(this%BETA)) deallocate(this%BETA) + if (allocated(this%DIFF)) deallocate(this%DIFF) + if (allocated(this%Qmin)) deallocate(this%Qmin) + if (allocated(this%Qmax)) deallocate(this%Qmax) + if (allocated(this%Qint)) deallocate(this%Qint) + call this%trhs%finalize() + end subroutine finalize + + +end module spcomp_class diff --git a/examples/NOSB_plate_with_hole_peridigm/GNUmakefile b/examples/NOSB_plate_with_hole_peridigm/GNUmakefile new file mode 100644 index 000000000..10108d4dd --- /dev/null +++ b/examples/NOSB_plate_with_hole_peridigm/GNUmakefile @@ -0,0 +1,49 @@ +# NGA location if not yet defined +NGA_HOME ?= + +# Compilation parameters +PRECISION = DOUBLE +USE_MPI = TRUE +USE_HYPRE = TRUE +USE_LAPACK= TRUE +USE_FFTW = TRUE +USE_IRL = FALSE +PROFILE = FALSE +DEBUG = FALSE +COMP = gnu +EXEBASE = nga + +# Directories that contain user-defined code +Udirs := src + +# Include user-defined sources +Upack += $(foreach dir, $(Udirs), $(wildcard $(dir)/Make.package)) +Ulocs += $(foreach dir, $(Udirs), $(wildcard $(dir))) +include $(Upack) +INCLUDE_LOCATIONS += $(Ulocs) +VPATH_LOCATIONS += $(Ulocs) + +# External libraries are defined in .profile/.bashrc/.zshrc, but could be defined here as well +HYPRE_DIR=/Users/imauser/nga2/Repositories/hypre/src/hypre +FFTW_DIR=/opt/homebrew/Cellar/fftw/3.3.10_2 + +# NGA compilation definitions +include $(NGA_HOME)/tools/GNUMake/Make.defs + +# Include NGA base code +Bdirs := constant_density particles core data transform solver config grid libraries +Bpack += $(foreach dir, $(Bdirs), $(NGA_HOME)/src/$(dir)/Make.package) +include $(Bpack) + +# Inform user of Make.packages used +ifdef Ulocs + $(info Taking user code from: $(Ulocs)) +endif +$(info Taking base code from: $(Bdirs)) + +# Target definition +all: $(executable) + @echo COMPILATION SUCCESSFUL + +# NGA compilation rules +include $(NGA_HOME)/tools/GNUMake/Make.rules diff --git a/examples/NOSB_plate_with_hole_peridigm/README b/examples/NOSB_plate_with_hole_peridigm/README new file mode 100644 index 000000000..a82a2a789 --- /dev/null +++ b/examples/NOSB_plate_with_hole_peridigm/README @@ -0,0 +1,3 @@ +(6/30/26 8:09 PM: +Switched it over to RK4, was RK2. +Have previously run with element.bin files, probably should change this over to be using a uniform grid. diff --git a/examples/NOSB_plate_with_hole_peridigm/input b/examples/NOSB_plate_with_hole_peridigm/input new file mode 100644 index 000000000..37e3cc697 --- /dev/null +++ b/examples/NOSB_plate_with_hole_peridigm/input @@ -0,0 +1,42 @@ +# Parallelization +Partition : 8 1 1 + +# Mesh definition +Lx : 1.0 +Ly : .5 +Lz : 0.00165 +nx : 200 +ny : 100 +nz : 1 # 50 + +# Case definition + +Bar length : 0.35 +Bar width : 0.02 +Inlet velocity : 0.0 + +# Solid properties +# Solid Spacing = 0.00165 +# Elastic Modulus : 1.46e6 +# Poisson Ratio : 0.4 +# Material density : 10000 +Critical Energy Release Rate : 1000000 +Horizon Ratio : 3.015 +# Solid Damping Constant : 0.05 +# Tau : 5.0e-4 +# Fluid properties +Dynamic viscosity : 0.001 +Density : 1000 + +# Time integration +Max timestep size : 6e-6 +Max cfl number : 0.9 +Max time : 25.0e-3 +Unfreeze time: 5.0e-3 + +# Pressure solver +Pressure tolerance : 1e-8 +Pressure iteration : 100 + +# Ensight output +Ensight output period : 5e-4 diff --git a/examples/NOSB_plate_with_hole_peridigm/src/Make.package b/examples/NOSB_plate_with_hole_peridigm/src/Make.package new file mode 100644 index 000000000..b2eadf90c --- /dev/null +++ b/examples/NOSB_plate_with_hole_peridigm/src/Make.package @@ -0,0 +1,2 @@ +# List here the extra files here +f90EXE_sources += NOSB_class.f90 OSB_class.f90 pdsolver_class.f90 pdhalo_class.f90 pdhash_class.f90 lsspd_class.f90 simulation.f90 geometry.f90 incomp_class.f90 diff --git a/examples/NOSB_plate_with_hole_peridigm/src/NOSB_class.f90 b/examples/NOSB_plate_with_hole_peridigm/src/NOSB_class.f90 new file mode 100644 index 000000000..4466e7f76 --- /dev/null +++ b/examples/NOSB_plate_with_hole_peridigm/src/NOSB_class.f90 @@ -0,0 +1,2231 @@ +!> Peridynamics solver: node-centered, CSR-based solid dynamics on flat +!> per-field arrays with persistent graph-halo communication. GRID-FREE: +!> no AMReX anywhere -- ownership follows the reference configuration +!> (Morton partition, motion-invariant), neighborhoods and communication +!> plans are built once and reused every substep. +!> +!> Physics: linear peridynamic solid (LPS, dimension-aware coefficients, +!> influence function hard-coded in omega() with derived quantities +!> generalized through its moments), brittle stretch damage, per-side +!> viscoelastic/viscoplastic flow with J2 (Mitchell OSB) yield, soft-sphere +!> contact (walls + particle-particle via a displacement-triggered spatial +!> service), velocity-Verlet integration. +!> Checkpoint/restart is gid-space and rank-count portable, including all +!> bond damage and plastic history. +!> +!> Usage tiers (amrpd EXTENDS pdsolver -- see amrpd_class): +!> 1. pdsolver alone -- standalone solid dynamics (this module only) +!> 2. amrpd -- adds viz, mesh VF, AMR refinement, seeding +!> 3. ... + a flow solver -- two-way FSI via amrpd%exchange_solid +!> +!> Configuration style: assign the public fields (material, damage, contact), +!> then build the network (detect_families/connect/read_state) -- derived +!> quantities resolve there via derive_config, uniformly for fresh and restart. +!> +!> Layout: owned nodes 1..nown; halo slots nown+1..ntot, keyed (gid, periodic +!> image offset) with shifts applied at exchange time. Each physical bond is +!> two CSR half-entries (one per endpoint row, Peridigm convention): kernels +!> compute each row's own force state -- ghost dilatation is never +!> communicated -- and a single halo reduce assembles cross-rank pairs. +!> Kernels are pure loops over owned nodes with no mutable module-level +!> state (OpenMP-ready by construction; threads deferred). +module NOSB_class + use precision, only: WP,I8 + use string, only: str_medium + use pdhalo_class, only: pddir,pdhalo,sort3_perm,PDHALO_KEY0 + use pdhash_class, only: gid_hash + implicit none + private + + public :: pdsolver,pd_partition + public :: PDC_IS_DEAD,PDC_MOVES,PDC_INTEGRATES,PDC_BONDS + public :: PD_OPEN,PD_WALL + + ! Motion-control bit flags -- values MUST match amrpd's PART_* constants + ! (handoff copies amrpd flags verbatim) + integer, parameter :: PDC_IS_DEAD =0 + integer, parameter :: PDC_MOVES =1 + integer, parameter :: PDC_INTEGRATES=2 + integer, parameter :: PDC_BONDS =4 + + ! Domain-face BC values for lo_bc/hi_bc + integer, parameter :: PD_OPEN=0 + integer, parameter :: PD_WALL=1 + + !> Graph-core PD solver + type :: pdsolver + character(len=str_medium) :: name='UNNAMED_PDSOLVER' + + ! Sizes + integer :: nown=0 !< owned nodes on this rank + integer :: nhalo=0 !< halo slots + integer :: ntot=0 !< nown+nhalo + integer(I8) :: np=0 !< global node count (get_info) + integer(I8) :: nbond=0 !< global bond count (half-entries/2, get_info) + + ! Material / discretization + real(WP) :: rho =0.0_WP !< density + real(WP) :: elastic_modulus=0.0_WP !< Young's modulus + real(WP) :: poisson_ratio =0.0_WP !< Poisson's ratio + real(WP) :: delta =0.0_WP !< horizon + real(WP) :: dV =0.0_WP !< nominal element volume (CFL length scale; kernels use per-node V) + real(WP) :: s0 =huge(1.0_WP) !< critical bond stretch (huge = no damage) + real(WP) :: fail_stretch =huge(1.0_WP) !< direct s0 override (takes precedence over crit_energy) + real(WP) :: crit_energy =huge(1.0_WP) !< critical energy release rate G_c (-> s0 when fail_stretch unset) + real(WP) :: dtcrit =0.0_WP !< Silling-Askari critical dt (diagnostic, stamped at connect) + ! Viscoelastic / viscoplastic flow (PER-SIDE form: each half-entry evolves + ! its own e_v with its own endpoint's dilatation and yield factor -- + ! exactly Peridigm's elastic_plastic.cxx, verified term-by-term against + ! amrpd's J2 2026-07-14. This is the one INTENDED delta from amrpd, which + ! averages the endpoints into a single per-bond e_v.) + real(WP) :: tau =huge(1.0_WP) !< Maxwell deviatoric relaxation time (huge = purely elastic) + real(WP) :: visc_lambda =1.0_WP !< SLS relaxing fraction [0,1] + real(WP) :: yield_stretch =0.0_WP !< legacy per-bond Perzyna yield strain (0 = pure Maxwell) + real(WP) :: sigma_yield =0.0_WP !< J2 yield stress (Mitchell OSB family norm; overrides yield_stretch) + real(WP) :: hard_mod =0.0_WP !< linear isotropic hardening modulus H: flow stress = sigma_yield + H*lam_p (0 = perfectly plastic) + real(WP), dimension(3) :: gravity=0.0_WP !< body acceleration + logical, dimension(3) :: collapsed=.false. !< collapsed (n==1) directions: velocity locked + real(WP), dimension(3) :: Ldom=0.0_WP !< domain lengths (image shifts) + logical, dimension(3) :: per=.false. !< periodicity per direction + real(WP), dimension(3) :: dom_lo=0.0_WP !< domain lower bounds (wall contact) + real(WP), dimension(3) :: dom_hi=0.0_WP !< domain upper bounds (wall contact) + + ! Short-range soft-sphere contact (soft-sphere penalty + damping). + ! Contact is a pure SPATIAL service, fully separate from the bond graph: + ! candidates are (owned nodes + contact-halo slots) discovered by a + ! displacement-triggered broad phase; the graph halo is never binned, so + ! bonded remote partners arrive as contact slots when in range and + ! double-counting is structurally impossible. The narrow phase is + ! gather-only (each owned node accumulates from its candidates -- the + ! partner gets its share from its own row), so no force reduction. + logical :: use_contact =.false. + real(WP) :: contact_dist =0.0_WP !< d_c (p-p d_eff; wall d_eff = 0.5*d_c) + real(WP) :: tau_col =0.0_WP !< collision duration (<=0 -> auto 5*dt) + real(WP) :: e_n=0.7_WP,e_w=0.7_WP !< restitution (p-p, wall) + real(WP) :: clip_col =0.2_WP !< overlap clip fraction + integer, dimension(3) :: lo_bc=PD_OPEN,hi_bc=PD_OPEN !< per-face: PD_OPEN or PD_WALL + real(WP) :: cskin =0.0_WP !< broad-phase skin (<=0 -> auto 0.5*contact_dist) + type(pdhalo) :: chalo !< contact halo (rebuilt at trigger cadence; nown=ntot) + integer :: nchalo=0 !< contact slots (y/v extended to ntot+nchalo) + integer, allocatable :: cptr(:),clst(:) !< candidate CSR (owned rows; entries index owned+contact slots) + real(WP), allocatable :: ylast(:,:) !< (3,nown) positions at last broad-phase build + + ! Node state -- flat per-field arrays; owned first, halo slots appended. + ! (3,:) fields are xyz-interleaved per node (Fortran-natural gather layout). + integer(I8), allocatable :: gid(:) !< (ntot) global id (halo slots carry partner gid) + real(WP), allocatable :: x0(:,:) !< (3,ntot) reference position; halo PRE-SHIFTED + real(WP), allocatable :: y(:,:) !< (3,ntot) current position; halo shifted at update + real(WP), allocatable :: v(:,:) !< (3,nown) velocity + real(WP), allocatable :: f(:,:) !< (3,ntot) bond force density (halo = scatter buffer) + real(WP), allocatable :: ff(:,:) !< (3,nown) external (fluid) force density + real(WP), allocatable :: vol(:) !< (ntot) per-node volume (reference; halo slots filled at connect) + real(WP), allocatable :: mw(:) !< (nown) weighted volume (reference, set at connect) + real(WP), allocatable :: theta(:) !< (nown) dilatation (recomputed each substep) + real(WP), allocatable :: damage(:) !< (nown) accumulated damage fraction (broken/reference bonds) + real(WP), allocatable :: lam_p(:) !< (nown) accumulated equivalent plastic strain (J2 path; drives hardening, free diagnostic when hard_mod=0) + real(WP), allocatable :: alive(:) !< (ntot) 1=alive, 0=dead (exit through open face); halo-exchanged on death events only + integer, allocatable :: flag(:) !< (nown) motion-control flags + logical :: watch_exit=.false. !< exit detection active (set at connect: domain set + any open non-periodic face) + + ! CSR families (built once at connect) + integer, allocatable :: ptr(:) !< (nown+1) row offsets + integer, allocatable :: lst(:) !< neighbor index (1..ntot) per half-entry + integer(1), allocatable :: dmg(:) !< per half-entry: 0 intact, 1 broken (irreversible) + real(WP), allocatable :: e_v(:) !< per half-entry: inelastic deviatoric stretch (per-side history) + real(WP), allocatable :: td2(:),td2a(:) !< (nown) J2 family deviatoric norm^2: previous substep / accumulator. + !< Node-centered => pure own-row gather, NO communication (amrpd + !< needed sum_ghosts_td2 + ghost refresh for the same quantity). + + ! Parallel machinery + type(gid_hash) :: ohash !< gid -> owned index (built at set_nodes) + type(pddir) :: dir !< persistent gid directory (owner lookups; registered at connect/read_state) + type(pdhalo) :: halo !< persistent halo plan + real(WP), allocatable :: rextra_tmp(:,:) !< read_state scratch (restart-field overlay across assemble) + + ! Monitoring + real(WP) :: Umin=0.0_WP,Umax=0.0_WP !< signed per-component velocity extrema + real(WP) :: Vmin=0.0_WP,Vmax=0.0_WP !< over live nodes (get_info) + real(WP) :: Wmin=0.0_WP,Wmax=0.0_WP + real(WP) :: EPmax=0.0_WP !< max accumulated equivalent plastic strain (get_info) + real(WP) :: CFLe=0.0_WP,CFLp=0.0_WP !< elastic-wave / convective CFL (get_cfl) + integer(I8) :: nbroken=0 !< global broken half-entry count (internal) + integer(I8) :: nb_broken=0 !< global broken BOND count (exact census, get_info) + integer(I8) :: nb=0 !< global bond count (exact census, stamped at assemble) + integer(I8) :: nrebuild=0 !< broad-phase rebuild count (cumulative) + integer(I8) :: nchalo_glob=0 !< global contact-slot count (get_info) + integer(I8) :: ncand_glob=0 !< global contact-candidate count (get_info) + + ! Per-rank phase timers (accumulated in advance; reduced+reset in get_info) + real(WP) :: wt_kick=0.0_WP,wt_halo=0.0_WP,wt_dil=0.0_WP,wt_force=0.0_WP,wt_reduce=0.0_WP + real(WP) :: wt_contact=0.0_WP,wt_broad=0.0_WP + real(WP) :: wtmax_kick=0.0_WP,wtmax_halo=0.0_WP,wtmax_dil=0.0_WP,wtmax_force=0.0_WP,wtmax_reduce=0.0_WP + real(WP) :: wtmax_contact=0.0_WP,wtmax_broad=0.0_WP + real(WP) :: wtmin_dil=0.0_WP,wtmin_force=0.0_WP + real(WP) :: tot_time=0.0_WP,maxtot_time=0.0_WP + + ! Damping rate for steady state + real(WP) :: damping_rate=0.0_WP + + ! NOSB Tracked parameters + real(WP), allocatable :: F_mat(:,:,:) !< F matrix (:,:,nown) I don't think this needs the halo + real(WP), allocatable :: PK_inv(:,:,:) !< P*K^-1 matrix (:,:,ntot) This needs to have gthe halo + + + + + contains + procedure :: set_nodes + procedure :: connect + procedure :: detect_families + procedure :: pd_advance + procedure :: query_owners + procedure :: write_state + procedure :: read_state + procedure :: get_cfl + procedure :: get_info + procedure :: finalize + procedure, private :: derive_config + procedure, private :: lps_coefs + procedure, private :: compute_mw + procedure, private :: contact_broadphase + procedure, private :: contact_narrow + procedure, private :: assemble + + end type pdsolver + +contains + + + !> Resolve derived configuration: s0 from fail_stretch/crit_energy, contact + !> reach default. Called by every network-building entry point (connect, + !> detect_families, read_state) so fresh init and restart share one path. + subroutine derive_config(this) + use messager, only: die + implicit none + class(pdsolver), intent(inout) :: this + real(WP) :: K_bulk + if (this%rho.le.0.0_WP.or.this%elastic_modulus.le.0.0_WP.or. & + & this%delta.le.0.0_WP.or.this%dV.le.0.0_WP) & + & call die('[pdsolver] material/discretization not configured (need rho, elastic_modulus, delta, dV > 0)') + if (this%fail_stretch.lt.huge(1.0_WP)) then + this%s0=this%fail_stretch + else if (this%crit_energy.gt.0.0_WP.and.this%crit_energy.lt.huge(1.0_WP)) then + ! Silling-Askari bond-energy argument, generalized to the active + ! influence function: G_c = (9/4)*K*s0^2*Iw4/Iw3 (w=1 recovers the + ! classical s0 = sqrt(5*G_c/(9*K*delta))) + K_bulk=this%elastic_modulus/(3.0_WP*(1.0_WP-2.0_WP*this%poisson_ratio)) + this%s0=sqrt(4.0_WP*this%crit_energy*wmoment(this%delta,3,1)/(9.0_WP*K_bulk*wmoment(this%delta,4,1))) + end if + if (this%use_contact.and.this%contact_dist.le.0.0_WP) this%contact_dist=0.9_WP*this%dV**(1.0_WP/3.0_WP) + end subroutine derive_config + + !> Load this rank's owned nodes (any distribution; it becomes the static + !> partition). Builds the gid->index hash used by connect and the halo plan. + !> vol is the per-node volume (pass a constant-filled array for a uniform + !> lattice; kernels use it per neighbor, Peridigm-style). + subroutine set_nodes(this,n,gids,pos,vel,flags,vol) + implicit none + class(pdsolver), intent(inout) :: this + integer, intent(in) :: n + integer(I8), intent(in) :: gids(:) + real(WP), intent(in) :: pos(:,:),vel(:,:) + integer, intent(in) :: flags(:) + real(WP), intent(in) :: vol(:) + integer :: i + this%nown=n + this%nhalo=0 + this%ntot=n + allocate(this%gid(max(n,1)),this%x0(3,max(n,1)),this%y(3,max(n,1))) + allocate(this%v(3,max(n,1)),this%f(3,max(n,1)),this%ff(3,max(n,1))) + allocate(this%mw(max(n,1)),this%theta(max(n,1)),this%flag(max(n,1))) + allocate(this%vol(max(n,1)),this%damage(max(n,1)),this%lam_p(max(n,1))) + allocate(this%PK_inv(3,3,max(n,1)),this%F_mat(3,3,max(n,1))) + do i=1,n + this%gid(i) =gids(i) + this%x0(:,i)=pos(:,i) + this%y(:,i) =pos(:,i) + this%v(:,i) =vel(:,i) + this%flag(i)=flags(i) + this%vol(i) =vol(i) + end do + this%f=0.0_WP; this%ff=0.0_WP; this%mw=0.0_WP; this%theta=0.0_WP; this%damage=0.0_WP; this%lam_p=0.0_WP + this%F_mat=0.0_WP; this%PK_inv=0.0_WP + call this%ohash%build(n,gids(1:n)) + end subroutine set_nodes + + !> Build the static CSR families and the halo plan from a distributed bond + !> list (this rank passes the bonds it holds; any distribution is fine -- + !> half-entries are routed to their node's owner through the gid directory). + !> Collective. bkey packs the periodic image offset of the HI endpoint in + !> amrpd's hist1 convention. Self-image bonds (gid_lo==gid_hi) yield ONE + !> half-entry (the opposite-image bond exists separately in the input, exactly + !> as amrpd stores them). + subroutine connect(this,nb,bgid_lo,bgid_hi,bkey) + use parallel, only: comm,nproc + use messager, only: die + use mpi_f08 + implicit none + class(pdsolver), intent(inout) :: this + integer, intent(in) :: nb + integer(I8), intent(in) :: bgid_lo(:),bgid_hi(:) + integer, intent(in) :: bkey(:) + integer(I8), allocatable :: hnode(:),hnbr(:),rnode(:),rnbr(:) + integer, allocatable :: hkey(:),howner(:),rkey(:) + real(WP), allocatable :: rev(:) + integer(1), allocatable :: rdmg(:) + integer :: nhe,rn,i,ib,ierr + + ! Resolve derived configuration (restart-safe shared path) + call this%derive_config() + + ! Distributed gid directory over the node partition (persistent: also + ! serves owner queries for face-tag restamping after restart) + call this%dir%finalize() + call this%dir%register(this%nown,this%gid(1:this%nown)) + + ! Expand bonds into half-entries (one per endpoint row; one total for + ! self-image bonds -- see header) + nhe=0 + do ib=1,nb + nhe=nhe+1 + if (bgid_lo(ib).ne.bgid_hi(ib)) nhe=nhe+1 + end do + allocate(hnode(max(nhe,1)),hnbr(max(nhe,1)),hkey(max(nhe,1)),howner(max(nhe,1))) + nhe=0 + do ib=1,nb + nhe=nhe+1 + hnode(nhe)=bgid_lo(ib); hnbr(nhe)=bgid_hi(ib); hkey(nhe)=bkey(ib) + if (bgid_lo(ib).ne.bgid_hi(ib)) then + nhe=nhe+1 + hnode(nhe)=bgid_hi(ib); hnbr(nhe)=bgid_lo(ib); hkey(nhe)=negkey(bkey(ib)) + end if + end do + + ! Route each half-entry to the rank owning its node + call this%dir%query(nhe,hnode,howner) + route_entries: block + integer, dimension(0:nproc-1) :: sc,rc,sd,rd + integer, allocatable :: pos(:) + integer(I8), allocatable :: s8(:) + integer, allocatable :: s4(:) + integer :: r,h + sc=0 + do i=1,nhe + sc(howner(i))=sc(howner(i))+1 + end do + call MPI_ALLTOALL(sc,1,MPI_INTEGER,rc,1,MPI_INTEGER,comm,ierr) + sd(0)=0; rd(0)=0 + do r=1,nproc-1 + sd(r)=sd(r-1)+sc(r-1); rd(r)=rd(r-1)+rc(r-1) + end do + rn=sum(rc) + allocate(rnode(max(rn,1)),rnbr(max(rn,1)),rkey(max(rn,1))) + allocate(pos(0:nproc-1),s8(max(nhe,1)),s4(max(nhe,1))) + ! node gids + pos=sd + do i=1,nhe + h=howner(i); pos(h)=pos(h)+1; s8(pos(h))=hnode(i) + end do + call MPI_ALLTOALLV(s8,sc,sd,MPI_INTEGER8,rnode,rc,rd,MPI_INTEGER8,comm,ierr) + ! neighbor gids + pos=sd + do i=1,nhe + h=howner(i); pos(h)=pos(h)+1; s8(pos(h))=hnbr(i) + end do + call MPI_ALLTOALLV(s8,sc,sd,MPI_INTEGER8,rnbr,rc,rd,MPI_INTEGER8,comm,ierr) + ! image keys + pos=sd + do i=1,nhe + h=howner(i); pos(h)=pos(h)+1; s4(pos(h))=hkey(i) + end do + call MPI_ALLTOALLV(s4,sc,sd,MPI_INTEGER,rkey,rc,rd,MPI_INTEGER,comm,ierr) + deallocate(pos,s8,s4) + end block route_entries + deallocate(hnode,hnbr,hkey,howner) + + ! Fresh bonds carry zero inelastic state + allocate(rev(max(rn,1)),rdmg(max(rn,1))) + rev=0.0_WP; rdmg=0_1 + call this%assemble(rn,rnode,rnbr,rkey,rev,rdmg) + deallocate(rnode,rnbr,rkey,rev,rdmg) + end subroutine connect + + + !> Build the bond families directly from the REFERENCE configuration -- no + !> amrpd bond container, no bond expansion: distributed neighbor discovery + !> at radius delta (bounds allgather + per-(rank,image-offset) offers of + !> shifted x0, contact-broadphase pattern), then each owned row's + !> half-entries are generated straight from the binned candidates and fed + !> to assemble with zero inelastic state. Acceptance test r2 <= delta^2 + !> matches amrpd bond_init exactly. Collective; call after set_nodes. + subroutine detect_families(this) + use parallel, only: comm,rank,nproc,amRoot,MPI_REAL_WP + use messager, only: log,die + use string, only: str_long + use mpi_f08 + implicit none + class(pdsolver), intent(inout) :: this + real(WP), dimension(3) :: bl,bh,shift,pos_s,gl,hcell + real(WP), allocatable :: allb(:,:),opos(:,:),rpos(:,:),cpos(:,:) + integer(I8), allocatable :: ogid(:),rgid(:),cgid(:),hnode(:),hnbr(:) + integer, allocatable :: okey(:),rkey(:),ckey(:),hkey(:),head(:),nxt(:) + real(WP), allocatable :: rev(:) + integer(1), allocatable :: rdmg(:) + integer, dimension(0:nproc-1) :: sc,rc,sd,rd,sc3,rc3,sd3,rd3 + integer, dimension(3) :: nmax,nc + integer :: d,r,n1,n2,n3,i,k,m,noff,nrecv,ncand,nhe,pass,ic,jc,kc,c1,c2,c3,ierr + character(len=str_long) :: message + + ! Resolve derived configuration (restart-safe shared path) + call this%derive_config() + + ! Directory over the node partition (persistent) + call this%dir%finalize() + call this%dir%register(this%nown,this%gid(1:this%nown)) + + ! Owned reference bounds, exchanged globally + bl=huge(1.0_WP); bh=-huge(1.0_WP) + do i=1,this%nown + bl=min(bl,this%x0(:,i)); bh=max(bh,this%x0(:,i)) + end do + allocate(allb(6,0:nproc-1)) + call MPI_ALLGATHER([bl,bh],6,MPI_REAL_WP,allb,6,MPI_REAL_WP,comm,ierr) + do d=1,3 + nmax(d)=0 + if (this%per(d).and.this%Ldom(d).gt.0.0_WP) nmax(d)=min(4,int(this%delta/this%Ldom(d))+1) + end do + + ! Offers of shifted reference positions (two passes: count, fill) + do pass=1,2 + sc=0 + do r=0,nproc-1 + do n3=-nmax(3),nmax(3); do n2=-nmax(2),nmax(2); do n1=-nmax(1),nmax(1) + if (r.eq.rank.and.n1.eq.0.and.n2.eq.0.and.n3.eq.0) cycle + shift=[real(n1,WP)*this%Ldom(1),real(n2,WP)*this%Ldom(2),real(n3,WP)*this%Ldom(3)] + if (any(bl+shift-this%delta.gt.allb(4:6,r)).or.any(bh+shift+this%delta.lt.allb(1:3,r))) cycle + do i=1,this%nown + pos_s=this%x0(:,i)+shift + if (any(pos_s.lt.allb(1:3,r)-this%delta).or.any(pos_s.gt.allb(4:6,r)+this%delta)) cycle + sc(r)=sc(r)+1 + if (pass.eq.2) then + ogid(sd(r)+sc(r))=this%gid(i) + okey(sd(r)+sc(r))=(n1+128)+(n2+128)*256+(n3+128)*65536 + opos(:,sd(r)+sc(r))=pos_s + end if + end do + end do; end do; end do + end do + if (pass.eq.1) then + sd(0)=0 + do r=1,nproc-1 + sd(r)=sd(r-1)+sc(r-1) + end do + noff=sum(sc) + allocate(ogid(max(noff,1)),okey(max(noff,1)),opos(3,max(noff,1))) + end if + end do + call MPI_ALLTOALL(sc,1,MPI_INTEGER,rc,1,MPI_INTEGER,comm,ierr) + rd(0)=0 + do r=1,nproc-1 + rd(r)=rd(r-1)+rc(r-1) + end do + nrecv=sum(rc) + allocate(rgid(max(nrecv,1)),rkey(max(nrecv,1)),rpos(3,max(nrecv,1))) + call MPI_ALLTOALLV(ogid,sc,sd,MPI_INTEGER8,rgid,rc,rd,MPI_INTEGER8,comm,ierr) + call MPI_ALLTOALLV(okey,sc,sd,MPI_INTEGER, rkey,rc,rd,MPI_INTEGER, comm,ierr) + sc3=3*sc; sd3=3*sd; rc3=3*rc; rd3=3*rd + call MPI_ALLTOALLV(opos,sc3,sd3,MPI_REAL_WP,rpos,rc3,rd3,MPI_REAL_WP,comm,ierr) + deallocate(ogid,okey,opos) + + ! Candidate set = owned nodes (zero offset) + received offers + ncand=this%nown+nrecv + allocate(cgid(max(ncand,1)),ckey(max(ncand,1)),cpos(3,max(ncand,1))) + do i=1,this%nown + cgid(i)=this%gid(i); ckey(i)=PDHALO_KEY0; cpos(:,i)=this%x0(:,i) + end do + do i=1,nrecv + cgid(this%nown+i)=rgid(i); ckey(this%nown+i)=rkey(i); cpos(:,this%nown+i)=rpos(:,i) + end do + deallocate(rgid,rkey,rpos) + + ! Bin candidates; generate each owned row directly (two passes) + bl=huge(1.0_WP); bh=-huge(1.0_WP) + do m=1,ncand + bl=min(bl,cpos(:,m)); bh=max(bh,cpos(:,m)) + end do + call setup_bins(bl,bh,this%delta,gl,hcell,nc) + allocate(head(nc(1)*nc(2)*nc(3)),nxt(max(ncand,1))) + head=0 + do m=1,ncand + k=cell_of(cpos(:,m),gl,hcell,nc) + nxt(m)=head(k); head(k)=m + end do + do pass=1,2 + nhe=0 + do i=1,this%nown + ic=min(nc(1),max(1,int((this%x0(1,i)-gl(1))/hcell(1))+1)) + jc=min(nc(2),max(1,int((this%x0(2,i)-gl(2))/hcell(2))+1)) + kc=min(nc(3),max(1,int((this%x0(3,i)-gl(3))/hcell(3))+1)) + do c3=max(1,kc-1),min(nc(3),kc+1); do c2=max(1,jc-1),min(nc(2),jc+1); do c1=max(1,ic-1),min(nc(1),ic+1) + m=head(c1+nc(1)*(c2-1)+nc(1)*nc(2)*(c3-1)) + do while (m.gt.0) + if (m.ne.i) then + if (sum((cpos(:,m)-this%x0(:,i))**2).le.this%delta**2) then + nhe=nhe+1 + if (pass.eq.2) then + hnode(nhe)=this%gid(i) + hnbr(nhe) =cgid(m) + hkey(nhe) =ckey(m) + end if + end if + end if + m=nxt(m) + end do + end do; end do; end do + end do + if (pass.eq.1) allocate(hnode(max(nhe,1)),hnbr(max(nhe,1)),hkey(max(nhe,1))) + end do + deallocate(cgid,ckey,cpos,head,nxt,allb) + + ! Assemble with zero inelastic state (entries are already local rows) + allocate(rev(max(nhe,1)),rdmg(max(nhe,1))) + rev=0.0_WP; rdmg=0_1 + call this%assemble(nhe,hnode,hnbr,hkey,rev,rdmg) + deallocate(hnode,hnbr,hkey,rev,rdmg) + if (amRoot) then + write(message,'("[",a,"] detect_families: ",i0," half-entries (~2x bonds)")') trim(this%name),this%nbond + call log(message) + end if + end subroutine detect_families + + !> Assemble the CSR families, halo plan, and reference state from LOCAL + !> half-entry arrays (already routed to this rank: every entry's node gid is + !> owned here). Per-entry inelastic state (dmg, e_v) travels with the + !> entries -- zeros for a fresh connect, loaded values on restart. Shared by + !> connect and read_state; collective. + subroutine assemble(this,rn,rnode,rnbr,rkey,rev,rdmg) + use parallel, only: comm,nproc + use messager, only: die + use mpi_f08 + implicit none + class(pdsolver), intent(inout) :: this + integer, intent(in) :: rn + integer(I8), intent(in) :: rnode(:),rnbr(:) + integer, intent(in) :: rkey(:) + real(WP), intent(in) :: rev(:) + integer(1), intent(in) :: rdmg(:) + integer, allocatable :: ridx(:),perm(:) + integer :: i,s,ierr + + if (allocated(this%ptr)) deallocate(this%ptr) + if (allocated(this%lst)) deallocate(this%lst) + if (allocated(this%dmg)) deallocate(this%dmg) + if (allocated(this%e_v)) deallocate(this%e_v) + if (allocated(this%td2)) deallocate(this%td2) + if (allocated(this%td2a)) deallocate(this%td2a) + + ! Resolve each received entry's node to an owned index + allocate(ridx(max(rn,1)),perm(max(rn,1))) + do i=1,rn + ridx(i)=this%ohash%lookup(rnode(i)) + if (ridx(i).lt.1) call die('[pdsolver assemble] half-entry routed to a rank that does not own its node') + perm(i)=i + end do + + ! Deterministic CSR order: sort by (node index, neighbor gid, image key) + if (rn.gt.1) call sort3_perm(ridx,rnbr,rkey,perm,1,rn) + + ! Row pointers + allocate(this%ptr(this%nown+1)) + row_pointers: block + integer, allocatable :: cnt(:) + allocate(cnt(this%nown)); cnt=0 + do i=1,rn + cnt(ridx(i))=cnt(ridx(i))+1 + end do + this%ptr(1)=1 + do i=1,this%nown + this%ptr(i+1)=this%ptr(i)+cnt(i) + end do + deallocate(cnt) + end block row_pointers + + ! Classify entries (owned direct vs halo reference), dedupe references, + ! build the halo plan, and finalize the CSR neighbor indices + build_refs_and_halo: block + integer(I8), allocatable :: refgid(:),ugid(:) + integer, allocatable :: refkey(:),refpos(:),rperm(:),zeros(:) + integer, allocatable :: ukey(:),uowner(:),uslot(:) + integer :: nref,nuniq,lid,u + allocate(this%lst(max(rn,1))) + allocate(this%dmg(max(rn,1))); this%dmg=0_1 + allocate(this%e_v(max(rn,1))); this%e_v=0.0_WP + ! Per-entry inelastic state follows the deterministic CSR order + do s=1,rn + this%dmg(s)=rdmg(perm(s)) + this%e_v(s)=rev(perm(s)) + end do + allocate(this%td2(max(this%nown,1)),this%td2a(max(this%nown,1))) + this%td2=0.0_WP; this%td2a=0.0_WP + allocate(refgid(max(rn,1)),refkey(max(rn,1)),refpos(max(rn,1))) + nref=0 + do s=1,rn + i=perm(s) + if (rkey(i).eq.PDHALO_KEY0) then + lid=this%ohash%lookup(rnbr(i)) + if (lid.ge.1) then + this%lst(s)=lid ! owned, zero image offset: direct index + cycle + end if + end if + nref=nref+1 + refgid(nref)=rnbr(i); refkey(nref)=rkey(i); refpos(nref)=s + end do + ! Unique (gid,key) references, deterministic order + allocate(rperm(max(nref,1)),zeros(max(nref,1))) + zeros=0 + do i=1,nref + rperm(i)=i + end do + if (nref.gt.1) call sort3_perm(zeros,refgid,refkey,rperm,1,nref) + allocate(ugid(max(nref,1)),ukey(max(nref,1))) + nuniq=0 + do s=1,nref + i=rperm(s) + if (s.eq.1) then + nuniq=1; ugid(1)=refgid(i); ukey(1)=refkey(i) + else if (refgid(i).ne.refgid(rperm(s-1)).or.refkey(i).ne.refkey(rperm(s-1))) then + nuniq=nuniq+1; ugid(nuniq)=refgid(i); ukey(nuniq)=refkey(i) + end if + this%lst(refpos(i))=-nuniq ! provisional: -(unique ref id) + end do + ! Owners of the unique references, then the persistent halo plan + allocate(uowner(max(nuniq,1)),uslot(max(nuniq,1))) + call this%dir%query(nuniq,ugid,uowner) + call this%halo%build(this%nown,this%ohash,nuniq,ugid,ukey,uowner,this%Ldom,this%per,uslot) + this%nhalo=this%halo%nhalo + this%ntot=this%nown+this%nhalo + ! Finalize CSR: provisional negatives -> halo slot indices + do s=1,rn + if (this%lst(s).lt.0) this%lst(s)=this%nown+uslot(-this%lst(s)) + end do + ! Extend node arrays to include halo slots; stamp halo gids + extend_arrays: block + integer(I8), allocatable :: g2(:) + real(WP), allocatable :: a2(:,:) + allocate(g2(max(this%ntot,1))); g2(1:this%nown)=this%gid(1:this%nown) + do u=1,nuniq + g2(this%nown+uslot(u))=ugid(u) + end do + call move_alloc(g2,this%gid) + allocate(a2(3,max(this%ntot,1))); a2=0.0_WP; a2(:,1:this%nown)=this%x0(:,1:this%nown) + call move_alloc(a2,this%x0) + allocate(a2(3,max(this%ntot,1))); a2=0.0_WP; a2(:,1:this%nown)=this%y(:,1:this%nown) + call move_alloc(a2,this%y) + allocate(a2(3,max(this%ntot,1))); a2=0.0_WP; a2(:,1:this%nown)=this%f(:,1:this%nown) + call move_alloc(a2,this%f) + extend_tensors: block ! I am copying the patterm but I think this will correctly extend things to include halos + real(WP), allocatable :: t2(:,:,:) + allocate(t2(3,3,max(this%ntot,1))); t2=0.0_WP; t2(:,:,1:this%nown)=this%PK_inv(:,:,1:this%nown) + call move_alloc(t2,this%PK_inv) + end block extend_tensors + extend_volume: block + real(WP), allocatable :: v2(:) + allocate(v2(max(this%ntot,1))); v2=0.0_WP; v2(1:this%nown)=this%vol(1:this%nown) + call move_alloc(v2,this%vol) + end block extend_volume + end block extend_arrays + deallocate(refgid,refkey,refpos,rperm,zeros,ugid,ukey,uowner,uslot) + end block build_refs_and_halo + deallocate(ridx,perm) + + ! Fill halo reference positions ONCE, pre-shifted by the image offsets + ! (x0 is static; this is the only x0 exchange of the entire run), and + ! the halo per-node volumes (also static) + call this%halo%update(this%x0,3,shifted=.true.) + call this%halo%update1(this%vol) + this%y(:,this%nown+1:this%ntot)=this%x0(:,this%nown+1:this%ntot) + + ! Life status (exit-through-open-face handling). Exchanged over the halo + ! ONLY on substeps where a death occurs somewhere; steady state is free. + if (allocated(this%alive)) deallocate(this%alive) + allocate(this%alive(max(this%ntot,1))); this%alive=1.0_WP + this%watch_exit=(this%dom_hi(1).gt.this%dom_lo(1)).and. & + & any((.not.this%per).and.(this%lo_bc.eq.0.or.this%hi_bc.eq.0)) + + ! Stamp the reference weighted volume + call this%compute_mw() + + ! Silling-Askari critical time step (Peridigm form, 3D bond-based + ! micromodulus c(z) = c0*w(z), c0 = 9K/(2*pi*Iw3); w=1 recovers the + ! classical 18K/(pi*delta^4)): + ! dt_crit_i = sqrt(2*rho / sum_family(V_j * c(zeta) / zeta)), global min. + ! DIAGNOSTIC only for now -- reported at init, does not bind dt. The + ! micromodulus constant is 3D-based; in quasi-2D slabs treat it as + ! indicative. + critical_dt: block + use mathtools, only: Pi + use messager, only: log + use string, only: str_long + use parallel, only: amRoot,MPI_REAL_WP + real(WP) :: K_bulk,c0,denom,zeta,dtc + character(len=str_long) :: message + integer :: i,e,j + K_bulk=this%elastic_modulus/(3.0_WP*(1.0_WP-2.0_WP*this%poisson_ratio)) + c0=9.0_WP*K_bulk/(2.0_WP*Pi*wmoment(this%delta,3,1)) + dtc=huge(1.0_WP) + do i=1,this%nown + denom=0.0_WP + do e=this%ptr(i),this%ptr(i+1)-1 + j=this%lst(e) + zeta=sqrt(sum((this%x0(:,j)-this%x0(:,i))**2)) + if (zeta.gt.0.0_WP) denom=denom+this%vol(j)*c0*omega(zeta,this%delta)/zeta + end do + if (denom.gt.0.0_WP) dtc=min(dtc,sqrt(2.0_WP*this%rho/denom)) + end do + call MPI_ALLREDUCE(MPI_IN_PLACE,dtc,1,MPI_REAL_WP,MPI_MIN,comm,ierr) + this%dtcrit=dtc + if (amRoot) then + write(message,'("[",a,"] Silling-Askari critical dt = ",es12.5," (diagnostic)")') trim(this%name),this%dtcrit + call log(message) + end if + end block critical_dt + + ! Global half-entry count for logging (= 2*bonds - self-image bonds) + count_bonds: block + use parallel, only: comm + integer(I8) :: nhe8 + nhe8=int(rn,I8) + call MPI_ALLREDUCE(MPI_IN_PLACE,nhe8,1,MPI_INTEGER8,MPI_SUM,comm,ierr) + this%nbond=nhe8 ! total half-entries; = 2*bonds - self-image bonds + ! Exact bond census (lower-gid rule; positive-offset self-images) + count_nb: block + integer :: i2,e2,j2 + this%nb=0_I8 + do i2=1,this%nown + do e2=this%ptr(i2),this%ptr(i2+1)-1 + j2=this%lst(e2) + if (this%gid(i2).lt.this%gid(j2)) then + this%nb=this%nb+1_I8 + else if (this%gid(i2).eq.this%gid(j2).and.j2.gt.this%nown) then + if (shift_positive(this%halo%shift(:,j2-this%nown))) this%nb=this%nb+1_I8 + end if + end do + end do + call MPI_ALLREDUCE(MPI_IN_PLACE,this%nb,1,MPI_INTEGER8,MPI_SUM,comm,ierr) + end block count_nb + end block count_bonds + end subroutine assemble + + !> Weighted volume: mw_i = sum_family w(zeta)*zeta^2*V_j (reference state; + !> never updated by damage) + subroutine compute_mw(this) + implicit none + class(pdsolver), intent(inout) :: this + integer :: i,e,j + real(WP) :: zeta + do i=1,this%nown + this%mw(i)=0.0_WP + do e=this%ptr(i),this%ptr(i+1)-1 + j=this%lst(e) + zeta=sqrt(sum((this%x0(:,j)-this%x0(:,i))**2)) + this%mw(i)=this%mw(i)+omega(zeta,this%delta)*zeta**2*this%vol(j) + end do + end do + end subroutine compute_mw + + !> Dimension-aware LPS constitutive coefficients (omega-independent: mw + !> absorbs the influence function). psi_fac sets the J2 yield threshold on + !> the family deviatoric force-state norm -- yield when + !> ||t_dev||^2 > psi_fac*sigma_yield^2/mw (Mitchell OSB) -- and DOES depend + !> on omega: since td ~ w, the norm scales by the w^2/w moment ratio + !> (int w^2 z^p / int w z^p, p=4 in 3D, 3 in 2D; ratio = 1 for w=1). + subroutine lps_coefs(this,fdim,coef_vol,coef_dev,psi_fac) + implicit none + class(pdsolver), intent(in) :: this + real(WP), intent(out) :: fdim,coef_vol,coef_dev + real(WP), intent(out), optional :: psi_fac + real(WP) :: K_bulk,mu_shear + integer :: ndim + ndim=3-count(this%collapsed) + K_bulk =this%elastic_modulus/(3.0_WP*(1.0_WP-2.0_WP*this%poisson_ratio)) + mu_shear=this%elastic_modulus/(2.0_WP*(1.0_WP+this%poisson_ratio)) + select case (ndim) + case (3) + fdim=3.0_WP; coef_vol=3.0_WP*K_bulk; coef_dev=15.0_WP*mu_shear + if (present(psi_fac)) psi_fac=5.0_WP*wmoment(this%delta,4,2)/wmoment(this%delta,4,1) + case (2) + fdim=2.0_WP; coef_vol=2.0_WP*(K_bulk+mu_shear/3.0_WP); coef_dev= 8.0_WP*mu_shear + if (present(psi_fac)) psi_fac=8.0_WP/3.0_WP*wmoment(this%delta,3,2)/wmoment(this%delta,3,1) + case default + fdim=1.0_WP; coef_vol=this%elastic_modulus; coef_dev= 0.0_WP + if (present(psi_fac)) psi_fac=0.0_WP + end select + end subroutine lps_coefs + + !> Velocity-Verlet step: half-kick + drift, halo position update, + !> dilatation gather, node-centered force sweep, halo force reduce, + !> contact, second half-kick. + subroutine pd_advance(this,dt) + use parallel, only: parallel_time + use mathtools, only: Pi + implicit none + class(pdsolver), intent(inout) :: this + real(WP), intent(in) :: dt + real(WP) :: rho_inv,fdim,cvol,cdev,t0 + real(WP) :: zeta,dY,e_b,t,w + real(WP) :: psi_fac,decay,e_d,td,beta,e_e,over + real(WP) :: sYe2,strial,mu3i + logical :: plastic,do_j2 + real(WP), dimension(3) :: acc,dxv,fx + real(WP), dimension(3,3) :: K_mat,E_mat,I_mat,S_mat,K_inv,sigma, s_dev + real(WP) :: detK_inv,traceE + real(WP) :: kk,mu + real(WP), dimension(3) :: xi,rpos,z,t1,t2,tc + integer :: i,e,j + + real(WP) :: t_full + t_full=parallel_time() + + rho_inv=1.0_WP/this%rho + mu=this%elastic_modulus/(2.0_WP+2.0_WP*this%poisson_ratio) + kk=this%elastic_modulus/(3.0_WP-6.0_WP*this%poisson_ratio) + call this%lps_coefs(fdim,cvol,cdev,psi_fac) + ! ! Viscoplastic setup: decay is loop-invariant (exact exponential update, + ! ! unconditionally stable -- no viscous CFL) + ! plastic=(this%tau.gt.0.0_WP.and.this%tau.lt.huge(1.0_WP)) + ! do_j2=(this%sigma_yield.gt.0.0_WP) + ! decay=0.0_WP + ! if (plastic) decay=exp(-dt/this%tau) + ! mu3i=2.0_WP*(1.0_WP+this%poisson_ratio)/(3.0_WP*this%elastic_modulus) ! 1/(3*mu_shear) + + ! First half-kick and drift (owned nodes) + t0=parallel_time() + do i=1,this%nown + if (this%flag(i).eq.PDC_IS_DEAD) cycle + acc=this%gravity+(this%f(:,i)+this%ff(:,i))*rho_inv + if (iand(this%flag(i),PDC_INTEGRATES).ne.0) this%v(:,i)=(1.0_WP-this%damping_rate)*this%v(:,i)+0.5_WP*dt*acc + if (this%collapsed(1)) this%v(1,i)=0.0_WP + if (this%collapsed(2)) this%v(2,i)=0.0_WP + if (this%collapsed(3)) this%v(3,i)=0.0_WP + if (iand(this%flag(i),PDC_MOVES).ne.0) this%y(:,i)=this%y(:,i)+dt*this%v(:,i) + end do + this%wt_kick=this%wt_kick+(parallel_time()-t0) + + ! Exit handling: nodes drifting out through an OPEN non-periodic face die + ! (amrpd drops them at Redistribute; here they are flagged and muted). + ! The death-count allreduce runs only when exits are possible at all, and + ! the mute propagation only on substeps where a death actually occurred. + if (this%watch_exit) then + death_watch: block + use parallel, only: comm + use mpi_f08, only: MPI_ALLREDUCE,MPI_IN_PLACE,MPI_SUM,MPI_INTEGER + integer :: nd,d,e,ierr + logical :: out + nd=0 + do i=1,this%nown + if (this%flag(i).eq.PDC_IS_DEAD) cycle + out=.false. + do d=1,3 + if (this%per(d)) cycle + if (this%lo_bc(d).eq.0.and.this%y(d,i).lt.this%dom_lo(d)) out=.true. + if (this%hi_bc(d).eq.0.and.this%y(d,i).gt.this%dom_hi(d)) out=.true. + end do + if (out) then + this%flag(i)=PDC_IS_DEAD + this%v(:,i)=0.0_WP + this%alive(i)=0.0_WP + nd=nd+1 + end if + end do + call MPI_ALLREDUCE(MPI_IN_PLACE,nd,1,MPI_INTEGER,MPI_SUM,comm,ierr) + if (nd.gt.0) then + ! Propagate life status to halo slots, then permanently mute + ! every entry touching a dead node (dmg=2: distinct from broken, + ! so damage statistics stay honest -- amrpd does not count + ! dropped-particle bonds as damage either) + call this%halo%update1(this%alive) + do i=1,this%nown + if (this%flag(i).eq.PDC_IS_DEAD) then + do e=this%ptr(i),this%ptr(i+1)-1 + if (this%dmg(e).eq.0_1) this%dmg(e)=2_1 + end do + else + do e=this%ptr(i),this%ptr(i+1)-1 + if (this%dmg(e).eq.0_1.and.this%alive(this%lst(e)).lt.0.5_WP) this%dmg(e)=2_1 + end do + end if + end do + ! Force a contact broad-phase rebuild so no candidate list + ! references a corpse (dead nodes are excluded from offers/bins) + if (this%use_contact.and.allocated(this%ylast)) deallocate(this%ylast) + end if + end block death_watch + end if + + ! Refresh halo positions (owner y -> slots, with image shifts) + t0=parallel_time() + call this%halo%update(this%y,3,shifted=.true.) + this%wt_halo=this%wt_halo+(parallel_time()-t0) + + ! Contact service: displacement-triggered broad phase (rebuilds contact + ! halo + candidate list when cumulative drift exhausts the skin), then + ! per-substep refresh of contact-slot positions AND velocities (the only + ! place velocity crosses ranks; the graph halo never carries it) + if (this%use_contact) then + t0=parallel_time() + call this%contact_broadphase() + this%wt_broad=this%wt_broad+(parallel_time()-t0) + t0=parallel_time() + call this%chalo%update(this%y,3,shifted=.true.) + call this%chalo%update(this%v,3,shifted=.false.) + this%wt_halo=this%wt_halo+(parallel_time()-t0) + end if + t0=parallel_time() + ! Equivalent to the dilatation sweep from before, I think that each one needs to sweep over + ! and compute the tensors K_mat and F + I_mat = 0.0_WP + I_mat(1,1) = 1.0_WP + I_mat(2,2) = 1.0_WP + I_mat(3,3) = 1.0_WP + do i=1,this%nown + K_mat=0.0_WP + K_inv = 0.0_WP + S_mat = 0.0_WP + traceE = 0.0_WP + E_mat = 0.0_WP + this%F_mat(:,:,i)=0.0_WP + this%PK_inv(:,:,i)=0.0_WP + do e=this%ptr(i),this%ptr(i+1)-1 + if (this%dmg(e).ne.0_1) cycle + j=this%lst(e) + xi=this%x0(:,j)-this%x0(:,i) + rpos=this%y(:,j) -this%y(:,i) + zeta=sqrt(sum(xi**2)) + w = omega(zeta,this%delta) + K_mat(1,1)=K_mat(1,1)+xi(1)*xi(1)*w*this%vol(j); K_mat(1,2)=K_mat(1,2)+xi(1)*xi(2)*w*this%vol(j); K_mat(1,3)=K_mat(1,3)+xi(1)*xi(3)*w*this%vol(j); + K_mat(2,1)=K_mat(2,1)+xi(2)*xi(1)*w*this%vol(j); K_mat(2,2)=K_mat(2,2)+xi(2)*xi(2)*w*this%vol(j); K_mat(2,3)=K_mat(2,3)+xi(2)*xi(3)*w*this%vol(j); + K_mat(3,1)=K_mat(3,1)+xi(3)*xi(1)*w*this%vol(j); K_mat(3,2)=K_mat(3,2)+xi(3)*xi(2)*w*this%vol(j); K_mat(3,3)=K_mat(3,3)+xi(3)*xi(3)*w*this%vol(j); + + this%F_mat(1,1,i)=this%F_mat(1,1,i)+rpos(1)*xi(1)*w*this%vol(j); this%F_mat(1,2,i)=this%F_mat(1,2,i)+rpos(1)*xi(2)*w*this%vol(j); this%F_mat(1,3,i)=this%F_mat(1,3,i)+rpos(1)*xi(3)*w*this%vol(j); + this%F_mat(2,1,i)=this%F_mat(2,1,i)+rpos(2)*xi(1)*w*this%vol(j); this%F_mat(2,2,i)=this%F_mat(2,2,i)+rpos(2)*xi(2)*w*this%vol(j); this%F_mat(2,3,i)=this%F_mat(2,3,i)+rpos(2)*xi(3)*w*this%vol(j); + this%F_mat(3,1,i)=this%F_mat(3,1,i)+rpos(3)*xi(1)*w*this%vol(j); this%F_mat(3,2,i)=this%F_mat(3,2,i)+rpos(3)*xi(2)*w*this%vol(j); this%F_mat(3,3,i)=this%F_mat(3,3,i)+rpos(3)*xi(3)*w*this%vol(j); + end do + + detK_inv = 1.0_WP/(K_mat(1,1)*(K_mat(2,2)*K_mat(3,3)-K_mat(2,3)*K_mat(3,2)) & + -K_mat(1,2)*(K_mat(2,1)*K_mat(3,3)-K_mat(2,3)*K_mat(3,1)) & + +K_mat(1,3)*(K_mat(2,1)*K_mat(3,2)-K_mat(2,2)*K_mat(3,1))) + K_inv(1,1) = (K_mat(2,2)*K_mat(3,3) - K_mat(2,3)*K_mat(3,2))*detK_inv + K_inv(2,1) = -(K_mat(2,1)*K_mat(3,3) - K_mat(2,3)*K_mat(3,1))*detK_inv + K_inv(3,1) = (K_mat(2,1)*K_mat(3,2) - K_mat(2,2)*K_mat(3,1))*detK_inv + K_inv(1,2) = -(K_mat(1,2)*K_mat(3,3) - K_mat(1,3)*K_mat(3,2))*detK_inv + K_inv(2,2) = (K_mat(1,1)*K_mat(3,3) - K_mat(1,3)*K_mat(3,1))*detK_inv + K_inv(3,2) = -(K_mat(1,1)*K_mat(3,2) - K_mat(1,2)*K_mat(3,1))*detK_inv + K_inv(1,3) = (K_mat(1,2)*K_mat(2,3) - K_mat(1,3)*K_mat(2,2))*detK_inv + K_inv(2,3) = -(K_mat(1,1)*K_mat(2,3) - K_mat(1,3)*K_mat(2,1))*detK_inv + K_inv(3,3) = (K_mat(1,1)*K_mat(2,2) - K_mat(1,2)*K_mat(2,1))*detK_inv + + this%F_mat(:,:,i) = MATMUL(this%F_mat(:,:,i),K_inv) + E_mat = 0.5_WP * (MATMUL(TRANSPOSE(this%F_mat(:,:,i)),this%F_mat(:,:,i))-I_mat) + traceE = E_mat(1,1) + E_mat(2,2) + E_mat(3,3) + S_mat = (kk-2.0_WP/3.0_WP*mu)*traceE*I_mat + 2.0_WP*mu*E_mat + this%PK_inv(:,:,i) = MATMUL(MATMUL(this%F_mat(:,:,i),S_mat),K_inv) + end do + this%wt_dil=this%wt_dil+(parallel_time()-t0) + ! I think here we just need to communicate PK_inv and F_mat, everything else can stay local + t0=parallel_time() + do e=1,3 + call this%halo%update(this%PK_inv(:,e,:),3,shifted=.false.) + end do + this%wt_halo=this%wt_halo+(parallel_time()-t0) + + ! Node-centered force sweep: each row computes its OWN force state t + ! (own theta, own mw) and scatters +t/-t; the neighbor's t arrives from + ! the neighbor's own row (locally or via the halo reduce below). + t0=parallel_time() + this%f=0.0_WP + do i=1,this%nown + ! ! Per-node J2 return factor from the LAGGED family norm. With + ! ! hardening (hard_mod>0) the surface radius grows with the node's + ! ! accumulated equivalent plastic strain lam_p (surface lagged one + ! ! substep like the norm: exact to O(H/3mu) per substep, and H<<3mu + ! ! for metals; stress-space equivalent of Peridigm's + ! ! elastic_plastic_hardening). The increment uses (1-beta)*strial = + ! ! the trial-stress excess, so the rate-independent limit matches the + ! ! classical radial return; (1-decay) is the Perzyna-realized + ! ! fraction. lam_p accumulates even at hard_mod=0 (free plastic- + ! ! strain diagnostic; forces unchanged there, bit-exact w/ flat yield). + ! beta=1.0_WP + ! if (plastic.and.do_j2) then + ! sYe2=(this%sigma_yield+this%hard_mod*this%lam_p(i))**2 + ! if (this%td2(i)*this%mw(i).gt.psi_fac*sYe2) then + ! beta=sqrt(psi_fac*sYe2/(this%td2(i)*this%mw(i))) + ! strial=sqrt(this%td2(i)*this%mw(i)/psi_fac) + ! this%lam_p(i)=this%lam_p(i)+(1.0_WP-beta)*(1.0_WP-decay)*strial*mu3i + ! end if + ! end if + + ! We are not currently doing the plastic behavior, so we can skip this + do e=this%ptr(i),this%ptr(i+1)-1 !IVM, does this work out so that each point is visited at the main, or do we only end up visiting half?? + if (this%dmg(e).ne.0_1) cycle + j=this%lst(e) + xi=this%x0(:,j)-this%x0(:,i) + rpos=this%y(:,j) -this%y(:,i) + zeta=sqrt(sum(xi**2)) + dY = sqrt(sum(rpos**2)) + if (dY.le.0.0_WP) cycle + e_b=dY-zeta + ! Brittle break on total stretch (e > s0*zeta), irreversible. + ! Each row breaks its OWN half-entry and increments its OWN node's + ! damage by 1/nb0 (nb0 = reference row length); the counterpart row + ! breaks its half independently -- the criterion is symmetric in + ! the endpoints, so both halves break in the same substep (for + ! image bonds, up to shift-association roundoff: a 1-ulp-marginal + ! bond may break one substep apart, a benign local transient -- + ! the intact half still applies its +/- pair, conserving momentum). + if (e_b.gt.this%s0*zeta) then + this%dmg(e)=1_1 + this%damage(i)=this%damage(i)+1.0_WP/real(this%ptr(i+1)-this%ptr(i),WP) + cycle + end if + w=omega(zeta,this%delta) + ! Now we compute forces, similar to before, but we only plus up the one particle instead of being slick with both + t1 = w*MATMUL(this%PK_inv(:,:,i),xi) + ! Force density 2->1 + t2 = w*MATMUL(this%PK_inv(:,:,j),xi) + ! Force correction term + z = rpos-MATMUL(this%F_mat(:,:,i),xi) + tc = w*(9.0_WP*kk/((Pi) * this%delta**4))*(dot_product(xi,z)/(sqrt(dot_product(xi,xi)))**3)*xi + ! Compute bond acceleration + this%f(:,i)=this%f(:,i)+(t1+t2+tc)*this%vol(j) + end do + end do + + this%wt_force=this%wt_force+(parallel_time()-t0) + + ! Assemble cross-rank pair forces (halo slots -> owners, add) + t0=parallel_time() + call this%halo%reduce(this%f,3) + this%wt_reduce=this%wt_reduce+(parallel_time()-t0) + + ! Short-range contact (walls + particle-particle), gather-only: adds + ! into owned f, no reduction (amrpd ordering: after the bond force) + if (this%use_contact) then + t0=parallel_time() + call this%contact_narrow(dt) + this%wt_contact=this%wt_contact+(parallel_time()-t0) + end if + + ! Second half-kick with the fresh force + t0=parallel_time() + do i=1,this%nown + if (this%flag(i).eq.PDC_IS_DEAD) cycle + if (iand(this%flag(i),PDC_INTEGRATES).ne.0) then + acc=this%gravity+(this%f(:,i)+this%ff(:,i))*rho_inv + this%v(:,i)=(1.0_WP-this%damping_rate)*this%v(:,i)+0.5_WP*dt*acc + end if + if (this%collapsed(1)) this%v(1,i)=0.0_WP + if (this%collapsed(2)) this%v(2,i)=0.0_WP + if (this%collapsed(3)) this%v(3,i)=0.0_WP + end do + this%wt_kick=this%wt_kick+(parallel_time()-t0) + + this%tot_time=this%tot_time+(parallel_time()-t_full) + end subroutine pd_advance + + !> Contact broad phase: displacement-triggered rebuild of the contact halo + !> and the candidate CSR. The trigger is one scalar allreduce per substep so + !> the (collective) rebuild decision is rank-consistent. rbuild = + !> 1.2*contact_dist + 2*cskin: engagement reach is bounded by d_eff*(1+0.2) + !> (the r_influ clip) and two nodes drifting cskin each can close 2*cskin + !> between rebuilds, so the candidate set provably contains every pair that + !> can produce force before the next rebuild. + !> + !> Discovery: allgather of per-rank owned-node bounds; for each (rank, + !> periodic-image offset) whose shifted bounds approach mine within rbuild, + !> OFFER my owned nodes in range as (gid, image key, shifted position). The + !> receiver keeps offers with an owned node within rbuild (binned test) and + !> builds the contact halo from the kept references via the standard pdhalo + !> protocol (chalo%nown = ntot, so contact slots append after graph slots). + !> Candidates are then binned over OWNED + CONTACT slots only -- the graph + !> halo is never binned, so bonded remote partners arrive as contact slots + !> when in range and double-counting is structurally impossible. + subroutine contact_broadphase(this) + use parallel, only: comm,rank,nproc,MPI_REAL_WP + use mpi_f08 + use messager, only: die + implicit none + class(pdsolver), intent(inout) :: this + real(WP) :: rbuild,drift + integer :: i,ierr + + if (this%contact_dist.le.0.0_WP) call die('[pdsolver contact] use_contact requires contact_dist > 0') + if (this%cskin.le.0.0_WP) this%cskin=0.5_WP*this%contact_dist + rbuild=1.2_WP*this%contact_dist+2.0_WP*this%cskin + + ! Displacement trigger (collective decision) + if (allocated(this%ylast)) then + drift=0.0_WP + do i=1,this%nown + drift=max(drift,sum((this%y(:,i)-this%ylast(:,i))**2)) + end do + drift=sqrt(drift) + else + drift=huge(1.0_WP) + end if + call MPI_ALLREDUCE(MPI_IN_PLACE,drift,1,MPI_REAL_WP,MPI_MAX,comm,ierr) + if (drift.le.this%cskin) return + this%nrebuild=this%nrebuild+1_I8 + + rebuild: block + real(WP), dimension(3) :: bl,bh,shift,pos_s + real(WP), allocatable :: allb(:,:),opos(:,:),rpos(:,:),kpos(:,:) + integer(I8), allocatable :: ogid(:),rgid(:),kgid(:) + integer, allocatable :: okey(:),rkey(:),kkey(:),kowner(:),slot(:) + integer, dimension(0:nproc-1) :: sc,rc,sd,rd + integer, dimension(0:nproc-1) :: sc3,rc3,sd3,rd3 + integer :: nmax(3),d,r,n1,n2,n3,noff,nrecv,nkeep,k,pass + ! Binning workspace (owned nodes for offer filtering, then combined + ! set for the candidate CSR) + real(WP), dimension(3) :: gl,hcell + integer, dimension(3) :: nc + integer, allocatable :: head(:),nxt(:) + + ! Owned bounds and their global exchange + bl=huge(1.0_WP); bh=-huge(1.0_WP) + do i=1,this%nown + bl=min(bl,this%y(:,i)); bh=max(bh,this%y(:,i)) + end do + allocate(allb(6,0:nproc-1)) + call MPI_ALLGATHER([bl,bh],6,MPI_REAL_WP,allb,6,MPI_REAL_WP,comm,ierr) + + ! Admissible periodic-image offsets for contact range + do d=1,3 + nmax(d)=0 + if (this%per(d).and.this%Ldom(d).gt.0.0_WP) nmax(d)=min(4,int(rbuild/this%Ldom(d))+1) + end do + + ! Offers: two passes (count, then fill), grouped by destination rank + do pass=1,2 + sc=0 + do r=0,nproc-1 + do n3=-nmax(3),nmax(3); do n2=-nmax(2),nmax(2); do n1=-nmax(1),nmax(1) + if (r.eq.rank.and.n1.eq.0.and.n2.eq.0.and.n3.eq.0) cycle + shift=[real(n1,WP)*this%Ldom(1),real(n2,WP)*this%Ldom(2),real(n3,WP)*this%Ldom(3)] + ! Shifted-bounds proximity prefilter + if (any(bl+shift-rbuild.gt.allb(4:6,r)).or.any(bh+shift+rbuild.lt.allb(1:3,r))) cycle + do i=1,this%nown + if (this%flag(i).eq.PDC_IS_DEAD) cycle + pos_s=this%y(:,i)+shift + if (any(pos_s.lt.allb(1:3,r)-rbuild).or.any(pos_s.gt.allb(4:6,r)+rbuild)) cycle + sc(r)=sc(r)+1 + if (pass.eq.2) then + ogid(sd(r)+sc(r))=this%gid(i) + okey(sd(r)+sc(r))=(n1+128)+(n2+128)*256+(n3+128)*65536 + opos(:,sd(r)+sc(r))=pos_s + end if + end do + end do; end do; end do + end do + if (pass.eq.1) then + sd(0)=0 + do r=1,nproc-1 + sd(r)=sd(r-1)+sc(r-1) + end do + noff=sum(sc) + allocate(ogid(max(noff,1)),okey(max(noff,1)),opos(3,max(noff,1))) + end if + end do + + ! Exchange offers (gid, key, shifted position) + call MPI_ALLTOALL(sc,1,MPI_INTEGER,rc,1,MPI_INTEGER,comm,ierr) + rd(0)=0 + do r=1,nproc-1 + rd(r)=rd(r-1)+rc(r-1) + end do + nrecv=sum(rc) + allocate(rgid(max(nrecv,1)),rkey(max(nrecv,1)),rpos(3,max(nrecv,1))) + call MPI_ALLTOALLV(ogid,sc,sd,MPI_INTEGER8,rgid,rc,rd,MPI_INTEGER8,comm,ierr) + call MPI_ALLTOALLV(okey,sc,sd,MPI_INTEGER, rkey,rc,rd,MPI_INTEGER, comm,ierr) + sc3=3*sc; sd3=3*sd; rc3=3*rc; rd3=3*rd + call MPI_ALLTOALLV(opos,sc3,sd3,MPI_REAL_WP,rpos,rc3,rd3,MPI_REAL_WP,comm,ierr) + deallocate(ogid,okey,opos) + + ! Filter offers: keep those with an owned node within rbuild. + ! Bin owned nodes (cell size >= rbuild so a +/-1 cell sweep suffices; + ! dims clamped so degenerate/huge extents stay bounded). + call setup_bins(bl,bh,rbuild,gl,hcell,nc) + allocate(head(nc(1)*nc(2)*nc(3)),nxt(max(this%nown,1))) + head=0 + do i=1,this%nown + if (this%flag(i).eq.PDC_IS_DEAD) cycle + k=cell_of(this%y(:,i),gl,hcell,nc) + nxt(i)=head(k); head(k)=i + end do + allocate(kgid(max(nrecv,1)),kkey(max(nrecv,1)),kowner(max(nrecv,1)),kpos(3,max(nrecv,1))) + nkeep=0 + do r=0,nproc-1 + do i=rd(r)+1,rd(r)+rc(r) + if (near_owned(rpos(:,i),rbuild,gl,hcell,nc,head,nxt)) then + nkeep=nkeep+1 + kgid(nkeep)=rgid(i); kkey(nkeep)=rkey(i); kowner(nkeep)=r; kpos(:,nkeep)=rpos(:,i) + end if + end do + end do + deallocate(rgid,rkey,rpos,head,nxt) + + ! Rebuild the contact halo (slots append after graph slots: nown=ntot) + call this%chalo%finalize() + allocate(slot(max(nkeep,1))) + call this%chalo%build(this%ntot,this%ohash,nkeep,kgid,kkey,kowner,this%Ldom,this%per,slot) + this%nchalo=this%chalo%nhalo + + ! Extend y and v to cover contact slots; stamp slot positions from the + ! kept offers (current values -- chalo%update refreshes each substep) + resize_state: block + real(WP), allocatable :: a2(:,:) + integer :: ntc + ntc=this%ntot+this%nchalo + allocate(a2(3,max(ntc,1))); a2=0.0_WP + a2(:,1:this%ntot)=this%y(:,1:this%ntot) + call move_alloc(a2,this%y) + allocate(a2(3,max(ntc,1))); a2=0.0_WP + a2(:,1:this%nown)=this%v(:,1:this%nown) + call move_alloc(a2,this%v) + do k=1,nkeep + this%y(:,this%ntot+slot(k))=kpos(:,k) + end do + end block resize_state + deallocate(kgid,kkey,kowner,kpos,slot) + + ! Candidate CSR over the contact-visible set: owned nodes (indices + ! 1..nown) + contact slots (ntot+1..ntot+nchalo). Two passes. + candidates: block + integer :: ns,m,jj,cnt,ic,jc,kc,c1,c2,c3 + integer, allocatable :: midx(:) + real(WP), dimension(3) :: blc,bhc + ns=this%nown+this%nchalo + allocate(midx(max(ns,1))) + do m=1,this%nown + midx(m)=m + end do + do m=1,this%nchalo + midx(this%nown+m)=this%ntot+m + end do + blc=bl; bhc=bh + do m=this%nown+1,ns + blc=min(blc,this%y(:,midx(m))); bhc=max(bhc,this%y(:,midx(m))) + end do + call setup_bins(blc,bhc,rbuild,gl,hcell,nc) + allocate(head(nc(1)*nc(2)*nc(3)),nxt(max(ns,1))) + head=0 + do m=1,ns + if (m.le.this%nown) then + if (this%flag(m).eq.PDC_IS_DEAD) cycle + end if + k=cell_of(this%y(:,midx(m)),gl,hcell,nc) + nxt(m)=head(k); head(k)=m + end do + if (allocated(this%cptr)) deallocate(this%cptr) + if (allocated(this%clst)) deallocate(this%clst) + allocate(this%cptr(this%nown+1)) + do pass=1,2 + do i=1,this%nown + cnt=0 + if (this%flag(i).eq.PDC_IS_DEAD) then + if (pass.eq.1) this%cptr(i+1)=0 + cycle + end if + ic=min(nc(1),max(1,int((this%y(1,i)-gl(1))/hcell(1))+1)) + jc=min(nc(2),max(1,int((this%y(2,i)-gl(2))/hcell(2))+1)) + kc=min(nc(3),max(1,int((this%y(3,i)-gl(3))/hcell(3))+1)) + do c3=max(1,kc-1),min(nc(3),kc+1); do c2=max(1,jc-1),min(nc(2),jc+1); do c1=max(1,ic-1),min(nc(1),ic+1) + m=head(c1+nc(1)*(c2-1)+nc(1)*nc(2)*(c3-1)) + do while (m.gt.0) + jj=midx(m) + if (jj.ne.i) then + if (sum((this%y(:,jj)-this%y(:,i))**2).le.rbuild**2) then + cnt=cnt+1 + if (pass.eq.2) this%clst(this%cptr(i)+cnt-1)=jj + end if + end if + m=nxt(m) + end do + end do; end do; end do + if (pass.eq.1) this%cptr(i+1)=cnt ! provisional count + end do + if (pass.eq.1) then + this%cptr(1)=1 + do i=1,this%nown + this%cptr(i+1)=this%cptr(i)+this%cptr(i+1) + end do + allocate(this%clst(max(this%cptr(this%nown+1)-1,1))) + end if + end do + deallocate(midx,head,nxt) + end block candidates + + ! Snapshot positions for the drift trigger + if (allocated(this%ylast)) deallocate(this%ylast) + allocate(this%ylast(3,max(this%nown,1))) + this%ylast(:,1:this%nown)=this%y(:,1:this%nown) + deallocate(allb) + end block rebuild + + contains + + !> Any owned node within r of position p? (binned +/-1 cell sweep) + function near_owned(p,r,gl,h,nc,head,nxt) result(hit) + real(WP), dimension(3), intent(in) :: p,gl,h + real(WP), intent(in) :: r + integer, dimension(3), intent(in) :: nc + integer, intent(in) :: head(:),nxt(:) + logical :: hit + integer :: c(3),d,c1,c2,c3,m + hit=.false. + do d=1,3 + c(d)=min(nc(d),max(1,int((p(d)-gl(d))/h(d))+1)) + end do + do c3=max(1,c(3)-1),min(nc(3),c(3)+1); do c2=max(1,c(2)-1),min(nc(2),c(2)+1); do c1=max(1,c(1)-1),min(nc(1),c(1)+1) + m=head(c1+nc(1)*(c2-1)+nc(1)*nc(2)*(c3-1)) + do while (m.gt.0) + if (sum((this%y(:,m)-p)**2).le.r**2) then + hit=.true. + return + end if + m=nxt(m) + end do + end do; end do; end do + end function near_owned + + end subroutine contact_broadphase + + !> Contact narrow phase: soft-sphere walls + particle-particle over the + !> candidate CSR, gather-only (soft-sphere penalty ported from amrlpt's collision model; + !> IB contact arrives with the coupling layer). Adds force/volume into owned + !> f. Walls use e_w with d_eff = 0.5*contact_dist and m_eff = m1; pairs use + !> e_n with d_eff = contact_dist and m_eff = 0.5*m1 (m1 = rho*vol(i), + !> matching amrpd's uniform rho*dV on a uniform lattice). + subroutine contact_narrow(this,dt) + use mathtools, only: Pi + implicit none + class(pdsolver), intent(inout) :: this + real(WP), intent(in) :: dt + real(WP) :: tau,k_n,eta_n,k_w,eta_w,d_eff_w,m1 + real(WP), dimension(3) :: r1,v1,floc,r2 + real(WP), dimension(3), parameter :: vzero=[0.0_WP,0.0_WP,0.0_WP] + integer :: i,k,j + if (this%contact_dist.le.0.0_WP.or.dt.le.0.0_WP) return + if (this%e_n.le.0.0_WP.or.this%e_w.le.0.0_WP) return + if (this%tau_col.gt.0.0_WP) then + tau=this%tau_col + else + tau=5.0_WP*dt + end if + k_n =(Pi**2+log(this%e_n)**2)/tau**2 + eta_n=-2.0_WP*log(this%e_n)/tau + k_w =(Pi**2+log(this%e_w)**2)/tau**2 + eta_w=-2.0_WP*log(this%e_w)/tau + d_eff_w=0.5_WP*this%contact_dist + do i=1,this%nown + if (this%flag(i).eq.PDC_IS_DEAD) cycle + m1=this%rho*this%vol(i) + r1=this%y(:,i); v1=this%v(:,i) + floc=0.0_WP + ! Wall collisions on faces flagged as walls (virtual partner on the + ! wall directly normal to the node) + if (this%lo_bc(1).eq.1) then; r2=[this%dom_lo(1),r1(2),r1(3)]; call apply_col(k_w,eta_w,d_eff_w,m1,r2,vzero); end if + if (this%hi_bc(1).eq.1) then; r2=[this%dom_hi(1),r1(2),r1(3)]; call apply_col(k_w,eta_w,d_eff_w,m1,r2,vzero); end if + if (this%lo_bc(2).eq.1) then; r2=[r1(1),this%dom_lo(2),r1(3)]; call apply_col(k_w,eta_w,d_eff_w,m1,r2,vzero); end if + if (this%hi_bc(2).eq.1) then; r2=[r1(1),this%dom_hi(2),r1(3)]; call apply_col(k_w,eta_w,d_eff_w,m1,r2,vzero); end if + if (this%lo_bc(3).eq.1) then; r2=[r1(1),r1(2),this%dom_lo(3)]; call apply_col(k_w,eta_w,d_eff_w,m1,r2,vzero); end if + if (this%hi_bc(3).eq.1) then; r2=[r1(1),r1(2),this%dom_hi(3)]; call apply_col(k_w,eta_w,d_eff_w,m1,r2,vzero); end if + ! Particle-particle via the candidate CSR + do k=this%cptr(i),this%cptr(i+1)-1 + j=this%clst(k) + call apply_col(k_n,eta_n,this%contact_dist,0.5_WP*m1,this%y(:,j),this%v(:,j)) + end do + ! Accumulate as force/volume (matches bond force units) + this%f(:,i)=this%f(:,i)+floc/this%vol(i) + end do + + contains + + !> Soft-sphere normal force from virtual partner (r2_in, v2_in) onto i. + !> Host-associated r1, v1, dt, floc. + subroutine apply_col(kk,ee,d_eff,m_eff,r2_in,v2_in) + real(WP), intent(in) :: kk,ee,d_eff,m_eff + real(WP), dimension(3), intent(in) :: r2_in,v2_in + real(WP) :: d12,rnv,r_influ,delta_n + real(WP), dimension(3) :: n12,v12,f_n + d12=norm2(r2_in-r1) + if (d12.lt.10.0_WP*epsilon(d12)) return ! self-overlap guard + n12=(r2_in-r1)/d12 + v12=v1-v2_in + rnv=dot_product(v12,n12) + r_influ=min(abs(rnv)*dt,0.2_WP*d_eff) + delta_n=min(d_eff+r_influ-d12,this%clip_col*d_eff) + if (delta_n.le.0.0_WP) return + f_n=(-m_eff*kk*delta_n-m_eff*ee*rnv)*n12 + floc=floc+f_n + end subroutine apply_col + + end subroutine contact_narrow + + !> Binding CFL: elastic wave + scaled convective (limits 0.5 / 0.1) + subroutine get_cfl(this,dt,cfl) + use parallel, only: comm,MPI_REAL_WP + use mpi_f08, only: MPI_ALLREDUCE,MPI_MAX,MPI_IN_PLACE + implicit none + class(pdsolver), intent(inout) :: this + real(WP), intent(in) :: dt + real(WP), intent(out) :: cfl + real(WP), parameter :: CFL_scale_conv=5.0_WP + real(WP) :: K_bulk,mu_shear,c_p,dp_inv,vmax + integer :: i,ierr + K_bulk =this%elastic_modulus/(3.0_WP*(1.0_WP-2.0_WP*this%poisson_ratio)) + mu_shear=this%elastic_modulus/(2.0_WP*(1.0_WP+this%poisson_ratio)) + c_p =sqrt((K_bulk+4.0_WP*mu_shear/3.0_WP)/this%rho) + dp_inv =1.0_WP/this%dV**(1.0_WP/3.0_WP) + this%CFLe=c_p*dp_inv*dt + this%CFLp=0.0_WP + do i=1,this%nown + if (this%flag(i).eq.PDC_IS_DEAD) cycle + vmax=max(abs(this%v(1,i)),abs(this%v(2,i)),abs(this%v(3,i))) + this%CFLp=max(this%CFLp,vmax*dp_inv) + end do + call MPI_ALLREDUCE(MPI_IN_PLACE,this%CFLp,1,MPI_REAL_WP,MPI_MAX,comm,ierr) + this%CFLp=this%CFLp*dt + cfl=max(CFL_scale_conv*this%CFLp,this%CFLe) + end subroutine get_cfl + + !> Global counts, velocity max, and timer reduction (+reset). Collective. + subroutine get_info(this) + use parallel, only: comm,MPI_REAL_WP + use mpi_f08, only: MPI_ALLREDUCE,MPI_MAX,MPI_MIN,MPI_SUM,MPI_IN_PLACE,MPI_INTEGER8 + implicit none + class(pdsolver), intent(inout) :: this + integer :: i,ierr + integer(I8) :: np_loc + real(WP), dimension(3) :: vmin,vmax + np_loc=0_I8 + vmin=huge(1.0_WP); vmax=-huge(1.0_WP) + this%EPmax=0.0_WP + do i=1,this%nown + if (this%flag(i).eq.PDC_IS_DEAD) cycle + np_loc=np_loc+1_I8 + vmin=min(vmin,this%v(:,i)); vmax=max(vmax,this%v(:,i)) + this%EPmax=max(this%EPmax,this%lam_p(i)) + end do + this%np=np_loc + call MPI_ALLREDUCE(MPI_IN_PLACE,this%np,1,MPI_INTEGER8,MPI_SUM,comm,ierr) + call MPI_ALLREDUCE(MPI_IN_PLACE,this%EPmax,1,MPI_REAL_WP,MPI_MAX,comm,ierr) + call MPI_ALLREDUCE(MPI_IN_PLACE,vmin,3,MPI_REAL_WP,MPI_MIN,comm,ierr) + call MPI_ALLREDUCE(MPI_IN_PLACE,vmax,3,MPI_REAL_WP,MPI_MAX,comm,ierr) + if (this%np.eq.0_I8) then + vmin=0.0_WP; vmax=0.0_WP + end if + this%Umin=vmin(1); this%Umax=vmax(1) + this%Vmin=vmin(2); this%Vmax=vmax(2) + this%Wmin=vmin(3); this%Wmax=vmax(3) + ! Broken half-entry census (each broken bond counts twice, except + ! self-image bonds which have a single half-entry) + count_broken: block + integer(I8) :: nb_loc + integer :: e,i2,j2 + ! Half-entry count (internal) and EXACT broken-bond census: each bond + ! is counted at exactly one of its two half-entries -- the one whose + ! node gid is lower (ties = self-image bonds, counted at the + ! positive-offset image so each appears once) + nb_loc=0_I8; this%nb_broken=0_I8 + do i2=1,this%nown + do e=this%ptr(i2),this%ptr(i2+1)-1 + if (this%dmg(e).eq.0_1) cycle + nb_loc=nb_loc+1_I8 + j2=this%lst(e) + if (this%gid(i2).lt.this%gid(j2)) then + this%nb_broken=this%nb_broken+1_I8 + else if (this%gid(i2).eq.this%gid(j2)) then + if (j2.gt.this%nown) then + if (shift_positive(this%halo%shift(:,j2-this%nown))) this%nb_broken=this%nb_broken+1_I8 + end if + end if + end do + end do + this%nbroken=nb_loc + call MPI_ALLREDUCE(MPI_IN_PLACE,this%nbroken,1,MPI_INTEGER8,MPI_SUM,comm,ierr) + call MPI_ALLREDUCE(MPI_IN_PLACE,this%nb_broken,1,MPI_INTEGER8,MPI_SUM,comm,ierr) + end block count_broken + ! Timers: max (and min for the compute-heavy phases) across ranks, then reset + call MPI_ALLREDUCE(this%wt_kick, this%wtmax_kick, 1,MPI_REAL_WP,MPI_MAX,comm,ierr) + call MPI_ALLREDUCE(this%wt_halo, this%wtmax_halo, 1,MPI_REAL_WP,MPI_MAX,comm,ierr) + call MPI_ALLREDUCE(this%wt_dil, this%wtmax_dil, 1,MPI_REAL_WP,MPI_MAX,comm,ierr) + call MPI_ALLREDUCE(this%wt_dil, this%wtmin_dil, 1,MPI_REAL_WP,MPI_MIN,comm,ierr) + call MPI_ALLREDUCE(this%wt_force, this%wtmax_force, 1,MPI_REAL_WP,MPI_MAX,comm,ierr) + call MPI_ALLREDUCE(this%wt_force, this%wtmin_force, 1,MPI_REAL_WP,MPI_MIN,comm,ierr) + call MPI_ALLREDUCE(this%wt_reduce,this%wtmax_reduce,1,MPI_REAL_WP,MPI_MAX,comm,ierr) + call MPI_ALLREDUCE(this%wt_contact,this%wtmax_contact,1,MPI_REAL_WP,MPI_MAX,comm,ierr) + call MPI_ALLREDUCE(this%wt_broad, this%wtmax_broad, 1,MPI_REAL_WP,MPI_MAX,comm,ierr) + call MPI_ALLREDUCE(this%tot_time, this%maxtot_time, 1,MPI_REAL_WP,MPI_MAX,comm,ierr) + + this%wt_kick=0.0_WP; this%wt_halo=0.0_WP; this%wt_dil=0.0_WP; this%wt_force=0.0_WP; this%wt_reduce=0.0_WP + this%wt_contact=0.0_WP; this%wt_broad=0.0_WP; this%tot_time=0.0_WP + ! Contact-service size census (visibility into the fragmentation-driven + ! degradation mode of the static graph partition) + contact_census: block + integer(I8) :: tmp + this%nchalo_glob=int(this%nchalo,I8) + call MPI_ALLREDUCE(MPI_IN_PLACE,this%nchalo_glob,1,MPI_INTEGER8,MPI_SUM,comm,ierr) + tmp=0_I8 + if (allocated(this%cptr)) tmp=int(this%cptr(this%nown+1)-1,I8) + this%ncand_glob=tmp + call MPI_ALLREDUCE(MPI_IN_PLACE,this%ncand_glob,1,MPI_INTEGER8,MPI_SUM,comm,ierr) + end block contact_census + end subroutine get_info + + !> Release all storage + subroutine finalize(this) + implicit none + class(pdsolver), intent(inout) :: this + if (allocated(this%gid)) deallocate(this%gid) + if (allocated(this%x0)) deallocate(this%x0) + if (allocated(this%y)) deallocate(this%y) + if (allocated(this%v)) deallocate(this%v) + if (allocated(this%f)) deallocate(this%f) + if (allocated(this%ff)) deallocate(this%ff) + if (allocated(this%vol)) deallocate(this%vol) + if (allocated(this%mw)) deallocate(this%mw) + if (allocated(this%theta)) deallocate(this%theta) + if (allocated(this%damage))deallocate(this%damage) + if (allocated(this%lam_p)) deallocate(this%lam_p) + if (allocated(this%alive)) deallocate(this%alive) + if (allocated(this%flag)) deallocate(this%flag) + if (allocated(this%ptr)) deallocate(this%ptr) + if (allocated(this%lst)) deallocate(this%lst) + if (allocated(this%dmg)) deallocate(this%dmg) + if (allocated(this%e_v)) deallocate(this%e_v) + if (allocated(this%td2)) deallocate(this%td2) + if (allocated(this%td2a)) deallocate(this%td2a) + if (allocated(this%cptr)) deallocate(this%cptr) + if (allocated(this%clst)) deallocate(this%clst) + if (allocated(this%ylast)) deallocate(this%ylast) + if (allocated(this%rextra_tmp)) deallocate(this%rextra_tmp) + call this%ohash%finalize() + call this%dir%finalize() + call this%halo%finalize() + call this%chalo%finalize() + this%nown=0; this%nhalo=0; this%ntot=0; this%nchalo=0 + end subroutine finalize + + + !> Mirror synchronization (the coupling bridge). Collective, once per FLUID + !> step. The caller walks its face particles (AMReX container on the + !> fluid decomposition) and passes per particle: gid, core owner rank (read + !> from the face particle's repurposed flag tag), and the F_fluid it interpolated + !> from the grid. This routine routes F_fluid to the owning nodes (held in + !> ff across the subsequent PD subcycles) and replies with each node's + !> current (pos, vel, damage, alive), returned aligned with the caller's + !> input order for direct write-back into the face particles. + subroutine exchange(this,nm,mgid,mowner,mff,mpos,mvel,mdmg,malive) + use parallel, only: comm,nproc,MPI_REAL_WP + use messager, only: die + use mpi_f08 + implicit none + class(pdsolver), intent(inout) :: this + integer, intent(in) :: nm + integer(I8), intent(in) :: mgid(:) + integer, intent(in) :: mowner(:) + real(WP), intent(in) :: mff(:,:) + real(WP), intent(out) :: mpos(:,:),mvel(:,:) + real(WP), intent(out) :: mdmg(:),malive(:) + integer, dimension(0:nproc-1) :: sc,rc,sd,rd + integer, dimension(0:nproc-1) :: scw,rcw,sdw,rdw + integer, allocatable :: pos(:),qpos(:) + integer(I8), allocatable :: sg(:),rg(:) + real(WP), allocatable :: sff(:,:),rff(:,:),srep(:,:),rrep(:,:) + integer :: i,r,nr,idx,ierr + + ! Count and pack by owner, remembering each entry's packed slot + sc=0 + do i=1,nm + sc(mowner(i))=sc(mowner(i))+1 + end do + call MPI_ALLTOALL(sc,1,MPI_INTEGER,rc,1,MPI_INTEGER,comm,ierr) + sd(0)=0; rd(0)=0 + do r=1,nproc-1 + sd(r)=sd(r-1)+sc(r-1); rd(r)=rd(r-1)+rc(r-1) + end do + allocate(pos(0:nproc-1),qpos(max(nm,1))) + allocate(sg(max(nm,1)),sff(3,max(nm,1))) + pos=sd + do i=1,nm + r=mowner(i); pos(r)=pos(r)+1 + sg(pos(r))=mgid(i); sff(:,pos(r))=mff(:,i); qpos(i)=pos(r) + end do + nr=sum(rc) + allocate(rg(max(nr,1)),rff(3,max(nr,1))) + call MPI_ALLTOALLV(sg,sc,sd,MPI_INTEGER8,rg,rc,rd,MPI_INTEGER8,comm,ierr) + scw=3*sc; sdw=3*sd; rcw=3*rc; rdw=3*rd + call MPI_ALLTOALLV(sff,scw,sdw,MPI_REAL_WP,rff,rcw,rdw,MPI_REAL_WP,comm,ierr) + + ! Owner side: ingest F_fluid, build the state reply in arrival order + allocate(rrep(8,max(nr,1))) + do i=1,nr + idx=this%ohash%lookup(rg(i)) + if (idx.lt.1) call die('[pdsolver exchange] face gid not owned by tagged rank') + this%ff(:,idx)=rff(:,i) + rrep(1:3,i)=this%y(:,idx) + rrep(4:6,i)=this%v(:,idx) + rrep(7,i) =this%damage(idx) + rrep(8,i) =this%alive(idx) + end do + + ! Reply along the reverse route; unpack to the caller's original order + allocate(srep(8,max(nm,1))) + scw=8*rc; sdw=8*rd; rcw=8*sc; rdw=8*sd + call MPI_ALLTOALLV(rrep,scw,sdw,MPI_REAL_WP,srep,rcw,rdw,MPI_REAL_WP,comm,ierr) + do i=1,nm + mpos(:,i) =srep(1:3,qpos(i)) + mvel(:,i) =srep(4:6,qpos(i)) + mdmg(i) =srep(7,qpos(i)) + malive(i) =srep(8,qpos(i)) + end do + deallocate(pos,qpos,sg,sff,rg,rff,rrep,srep) + end subroutine exchange + + + !> Owner-rank lookup for arbitrary node gids via the persistent directory. + !> Collective. Drivers use it to re-stamp face routing tags after restart. + subroutine query_owners(this,n,gids,owners) + implicit none + class(pdsolver), intent(inout) :: this + integer, intent(in) :: n + integer(I8), intent(in) :: gids(:) + integer, intent(out) :: owners(:) + call this%dir%query(n,gids,owners) + end subroutine query_owners + + !> Checkpoint the core under /: per-rank stream files + root + !> header. Records are GID-SPACE (no local indices, no partition info) -- + !> nodes: (gid, flag, x0, y, v, f, vol, damage, td2, lam_p); half-entries: + !> (node_gid, nbr_gid, image_key, dmg, e_v), the image key reconstructed + !> from the halo slot's shift. Rank-count portable on read. Format v2 + !> (v1 = pre-hardening, no lam_p record; read_state accepts both). + subroutine write_state(this,dirname) + use parallel, only: rank,nproc,amRoot + use messager, only: die + use string, only: str_medium + implicit none + class(pdsolver), intent(inout) :: this + character(len=*), intent(in) :: dirname + character(len=str_medium) :: fname + integer :: iunit,ios,i,e,j,nhe + integer, allocatable :: hkey(:) + integer(I8), allocatable :: hnode(:),hnbr(:) + ! Half-entries in gid space + nhe=this%ptr(this%nown+1)-1 + allocate(hnode(max(nhe,1)),hnbr(max(nhe,1)),hkey(max(nhe,1))) + do i=1,this%nown + do e=this%ptr(i),this%ptr(i+1)-1 + j=this%lst(e) + hnode(e)=this%gid(i) + hnbr(e) =this%gid(j) + if (j.le.this%nown) then + hkey(e)=PDHALO_KEY0 + else + hkey(e)=key_of_shift(this%halo%shift(:,j-this%nown),this%Ldom) + end if + end do + end do + ! Per-rank stream file + ! All solid state lives under /pd/ (root creates it) + make_dir: block + use parallel, only: comm + use mpi_f08, only: MPI_BARRIER + integer :: ierr2 + if (amRoot) call execute_command_line('mkdir -p '//trim(dirname)//'/pd') + call MPI_BARRIER(comm,ierr2) + end block make_dir + write(fname,'(a,"/pd/pd_",i7.7,".bin")') trim(dirname),rank + open(newunit=iunit,file=trim(fname),form='unformatted',access='stream',status='replace',iostat=ios) + if (ios.ne.0) call die('[pdsolver write_state] cannot open '//trim(fname)) + write(iunit) this%nown,nhe + write(iunit) this%gid(1:this%nown) + write(iunit) this%flag(1:this%nown) + write(iunit) this%x0(:,1:this%nown) + write(iunit) this%y(:,1:this%nown) + write(iunit) this%v(:,1:this%nown) + write(iunit) this%f(:,1:this%nown) + write(iunit) this%vol(1:this%nown) + write(iunit) this%damage(1:this%nown) + write(iunit) this%td2(1:this%nown) + write(iunit) this%lam_p(1:this%nown) + write(iunit) hnode(1:nhe) + write(iunit) hnbr(1:nhe) + write(iunit) hkey(1:nhe) + write(iunit) this%dmg(1:nhe) + write(iunit) this%e_v(1:nhe) + close(iunit) + deallocate(hnode,hnbr,hkey) + ! Root header (file count for portable round-robin reads) + if (amRoot) then + open(newunit=iunit,file=trim(dirname)//'/pd/header',form='formatted',status='replace',iostat=ios) + if (ios.ne.0) call die('[pdsolver write_state] cannot open header') + write(iunit,'(a)') 'pdsolver checkpoint v2' + write(iunit,'(i0)') nproc + close(iunit) + end if + contains + !> Reconstruct the packed image key from a slot shift vector + pure function key_of_shift(s,L) result(k) + implicit none + real(WP), dimension(3), intent(in) :: s,L + integer :: k,n1,n2,n3 + n1=0; n2=0; n3=0 + if (L(1).gt.0.0_WP) n1=nint(s(1)/L(1)) + if (L(2).gt.0.0_WP) n2=nint(s(2)/L(2)) + if (L(3).gt.0.0_WP) n3=nint(s(3)/L(3)) + k=(n1+128)+(n2+128)*256+(n3+128)*65536 + end function key_of_shift + end subroutine write_state + + !> Restore the core from a checkpoint written by write_state. Collective; + !> rank-count portable: files read round-robin, nodes re-partitioned by + !> Morton order of the reference configuration, half-entries routed to + !> their owners, CSR/halo rebuilt via assemble with the loaded per-entry + !> state. The caller must configure the solver (initialize + material/ + !> contact/plastic component assignments) BEFORE calling this. + subroutine read_state(this,dirname) + use parallel, only: comm,rank,nproc,MPI_REAL_WP + use messager, only: die + use string, only: str_medium + use mpi_f08 + implicit none + class(pdsolver), intent(inout) :: this + character(len=*), intent(in) :: dirname + character(len=str_medium) :: fname,line + integer :: nfiles,iunit,ios,f,i,r,ierr,iver + integer :: nn,nhe,nf,nhf + integer(I8), allocatable :: gid(:),hnode(:),hnbr(:) + integer, allocatable :: flag(:),hkey(:),owner(:) + real(WP), allocatable :: x0(:,:),yy(:,:),vv(:,:),ffb(:,:),vol(:),dmgn(:),td2n(:),lamn(:) + real(WP), allocatable :: hev(:) + integer(1), allocatable :: hdmg(:) + + ! Resolve derived configuration (restart-safe shared path) + call this%derive_config() + + ! Header: number of files written + format version (v1 = no lam_p record) + nfiles=0; iver=1 + if (rank.eq.0) then + open(newunit=iunit,file=trim(dirname)//'/pd/header',form='formatted',status='old',iostat=ios) + if (ios.ne.0) call die('[pdsolver read_state] no pd/header under '//trim(dirname)) + read(iunit,'(a)') line + if (index(line,'v2').gt.0) iver=2 + read(iunit,*) nfiles + close(iunit) + end if + call MPI_BCAST(nfiles,1,MPI_INTEGER,0,comm,ierr) + call MPI_BCAST(iver,1,MPI_INTEGER,0,comm,ierr) + + ! Read my round-robin share of the files, concatenating records + nn=0; nhe=0 + do f=rank,nfiles-1,nproc + write(fname,'(a,"/pd/pd_",i7.7,".bin")') trim(dirname),f + open(newunit=iunit,file=trim(fname),form='unformatted',access='stream',status='old',iostat=ios) + if (ios.ne.0) call die('[pdsolver read_state] cannot open '//trim(fname)) + read(iunit) nf,nhf + call grow_i8(gid,nn,nf); call grow_i4(flag,nn,nf) + call grow_r2(x0,nn,nf); call grow_r2(yy,nn,nf) + call grow_r2(vv,nn,nf); call grow_r2(ffb,nn,nf) + call grow_r1(vol,nn,nf); call grow_r1(dmgn,nn,nf); call grow_r1(td2n,nn,nf) + call grow_r1(lamn,nn,nf) + read(iunit) gid(nn+1:nn+nf) + read(iunit) flag(nn+1:nn+nf) + read(iunit) x0(:,nn+1:nn+nf) + read(iunit) yy(:,nn+1:nn+nf) + read(iunit) vv(:,nn+1:nn+nf) + read(iunit) ffb(:,nn+1:nn+nf) + read(iunit) vol(nn+1:nn+nf) + read(iunit) dmgn(nn+1:nn+nf) + read(iunit) td2n(nn+1:nn+nf) + if (iver.ge.2) then + read(iunit) lamn(nn+1:nn+nf) + else + lamn(nn+1:nn+nf)=0.0_WP + end if + call grow_i8(hnode,nhe,nhf); call grow_i8(hnbr,nhe,nhf) + call grow_i4(hkey,nhe,nhf); call grow_i1(hdmg,nhe,nhf); call grow_r1(hev,nhe,nhf) + read(iunit) hnode(nhe+1:nhe+nhf) + read(iunit) hnbr(nhe+1:nhe+nhf) + read(iunit) hkey(nhe+1:nhe+nhf) + read(iunit) hdmg(nhe+1:nhe+nhf) + read(iunit) hev(nhe+1:nhe+nhf) + close(iunit) + nn=nn+nf; nhe=nhe+nhf + end do + if (.not.allocated(gid)) then ! ranks with no files still join collectives + allocate(gid(1),flag(1),x0(3,1),yy(3,1),vv(3,1),ffb(3,1),vol(1),dmgn(1),td2n(1),lamn(1)) + allocate(hnode(1),hnbr(1),hkey(1),hdmg(1),hev(1)) + end if + + ! Re-partition nodes by Morton order of the REFERENCE configuration and + ! route the full records (pd_partition routes the set_nodes payload; the + ! remaining fields ride a second, identically-ordered exchange) + repartition: block + integer(I8), allocatable :: rgid(:) + real(WP), allocatable :: rx0(:,:),rvv(:,:),rvol(:),extra(:,:) + integer, allocatable :: rflag(:) + integer, dimension(0:nproc-1) :: sc,rc,sd,rd,scw,rcw,sdw,rdw + integer, allocatable :: pos(:) + integer :: nr + allocate(owner(max(nn,1))) + call pd_partition(nn,gid,x0,vv,flag,vol,owner,nr,rgid,rx0,rvv,rflag,rvol) + ! Second exchange: (y, f, damage, td2) = 8 reals, packed in the same + ! per-destination input order as pd_partition's own packing + sc=0 + do i=1,nn + sc(owner(i))=sc(owner(i))+1 + end do + call MPI_ALLTOALL(sc,1,MPI_INTEGER,rc,1,MPI_INTEGER,comm,ierr) + sd(0)=0; rd(0)=0 + do r=1,nproc-1 + sd(r)=sd(r-1)+sc(r-1); rd(r)=rd(r-1)+rc(r-1) + end do + allocate(pos(0:nproc-1),extra(9,max(nn,1)),this%rextra_tmp(9,max(nr,1))) + pos=sd + do i=1,nn + r=owner(i); pos(r)=pos(r)+1 + extra(1:3,pos(r))=yy(:,i) + extra(4:6,pos(r))=ffb(:,i) + extra(7,pos(r)) =dmgn(i) + extra(8,pos(r)) =td2n(i) + extra(9,pos(r)) =lamn(i) + end do + scw=9*sc; sdw=9*sd; rcw=9*rc; rdw=9*rd + call MPI_ALLTOALLV(extra,scw,sdw,MPI_REAL_WP,this%rextra_tmp,rcw,rdw,MPI_REAL_WP,comm,ierr) + ! Load the routed nodes, then overlay the restart-only fields + call this%set_nodes(nr,rgid,rx0,rvv,rflag,rvol) + do i=1,nr + this%y(:,i) =this%rextra_tmp(1:3,i) + this%f(:,i) =this%rextra_tmp(4:6,i) + this%damage(i)=this%rextra_tmp(7,i) + end do + deallocate(pos,extra,rgid,rx0,rvv,rflag,rvol) + end block repartition + + ! Register the directory over the new partition, route half-entries to + ! their owners (state travels along), and rebuild CSR/halo/reference + route_and_assemble: block + integer(I8), allocatable :: rnode(:),rnbr(:) + integer, allocatable :: rkey(:),howner(:) + real(WP), allocatable :: rev(:) + integer(1), allocatable :: rdmg(:) + integer, dimension(0:nproc-1) :: sc,rc,sd,rd + integer, allocatable :: pos(:) + integer(I8), allocatable :: s8(:) + integer, allocatable :: s4(:) + real(WP), allocatable :: sr(:) + integer(1), allocatable :: s1(:) + integer :: rn,h + call this%dir%finalize() + call this%dir%register(this%nown,this%gid(1:this%nown)) + allocate(howner(max(nhe,1))) + call this%dir%query(nhe,hnode,howner) + sc=0 + do i=1,nhe + sc(howner(i))=sc(howner(i))+1 + end do + call MPI_ALLTOALL(sc,1,MPI_INTEGER,rc,1,MPI_INTEGER,comm,ierr) + sd(0)=0; rd(0)=0 + do r=1,nproc-1 + sd(r)=sd(r-1)+sc(r-1); rd(r)=rd(r-1)+rc(r-1) + end do + rn=sum(rc) + allocate(rnode(max(rn,1)),rnbr(max(rn,1)),rkey(max(rn,1)),rev(max(rn,1)),rdmg(max(rn,1))) + allocate(pos(0:nproc-1),s8(max(nhe,1)),s4(max(nhe,1)),sr(max(nhe,1)),s1(max(nhe,1))) + pos=sd + do i=1,nhe + h=howner(i); pos(h)=pos(h)+1; s8(pos(h))=hnode(i) + end do + call MPI_ALLTOALLV(s8,sc,sd,MPI_INTEGER8,rnode,rc,rd,MPI_INTEGER8,comm,ierr) + pos=sd + do i=1,nhe + h=howner(i); pos(h)=pos(h)+1; s8(pos(h))=hnbr(i) + end do + call MPI_ALLTOALLV(s8,sc,sd,MPI_INTEGER8,rnbr,rc,rd,MPI_INTEGER8,comm,ierr) + pos=sd + do i=1,nhe + h=howner(i); pos(h)=pos(h)+1; s4(pos(h))=hkey(i) + end do + call MPI_ALLTOALLV(s4,sc,sd,MPI_INTEGER,rkey,rc,rd,MPI_INTEGER,comm,ierr) + pos=sd + do i=1,nhe + h=howner(i); pos(h)=pos(h)+1; sr(pos(h))=hev(i) + end do + call MPI_ALLTOALLV(sr,sc,sd,MPI_REAL_WP,rev,rc,rd,MPI_REAL_WP,comm,ierr) + pos=sd + do i=1,nhe + h=howner(i); pos(h)=pos(h)+1; s1(pos(h))=hdmg(i) + end do + call MPI_ALLTOALLV(s1,sc,sd,MPI_INTEGER1,rdmg,rc,rd,MPI_INTEGER1,comm,ierr) + call this%assemble(rn,rnode,rnbr,rkey,rev,rdmg) + deallocate(rnode,rnbr,rkey,rev,rdmg,pos,s8,s4,sr,s1,howner) + end block route_and_assemble + + ! Overlay td2/lam_p (assemble/set_nodes zero them) and life status + do i=1,this%nown + this%td2(i) =this%rextra_tmp(8,i) + this%lam_p(i)=this%rextra_tmp(9,i) + if (this%flag(i).eq.PDC_IS_DEAD) this%alive(i)=0.0_WP + end do + deallocate(this%rextra_tmp) + call this%halo%update1(this%alive) + deallocate(gid,flag,x0,yy,vv,ffb,vol,dmgn,td2n,lamn,hnode,hnbr,hkey,hdmg,hev,owner) + + contains + + subroutine grow_i8(a,n,add) + integer(I8), allocatable, intent(inout) :: a(:) + integer, intent(in) :: n,add + integer(I8), allocatable :: t(:) + allocate(t(n+add)); if (n.gt.0) t(1:n)=a(1:n) + call move_alloc(t,a) + end subroutine grow_i8 + subroutine grow_i4(a,n,add) + integer, allocatable, intent(inout) :: a(:) + integer, intent(in) :: n,add + integer, allocatable :: t(:) + allocate(t(n+add)); if (n.gt.0) t(1:n)=a(1:n) + call move_alloc(t,a) + end subroutine grow_i4 + subroutine grow_i1(a,n,add) + integer(1), allocatable, intent(inout) :: a(:) + integer, intent(in) :: n,add + integer(1), allocatable :: t(:) + allocate(t(n+add)); if (n.gt.0) t(1:n)=a(1:n) + call move_alloc(t,a) + end subroutine grow_i1 + subroutine grow_r1(a,n,add) + real(WP), allocatable, intent(inout) :: a(:) + integer, intent(in) :: n,add + real(WP), allocatable :: t(:) + allocate(t(n+add)); if (n.gt.0) t(1:n)=a(1:n) + call move_alloc(t,a) + end subroutine grow_r1 + subroutine grow_r2(a,n,add) + real(WP), allocatable, intent(inout) :: a(:,:) + integer, intent(in) :: n,add + real(WP), allocatable :: t(:,:) + allocate(t(3,n+add)); if (n.gt.0) t(:,1:n)=a(:,1:n) + call move_alloc(t,a) + end subroutine grow_r2 + + end subroutine read_state + + + !> Static load-balancing partition of the reference configuration. + !> Collective; called once at handoff, BEFORE set_nodes. Nodes are ordered + !> by the Morton key of their reference position and split into equal-count + !> contiguous ranges: on a uniform lattice family size is ~constant, so node + !> count ~ bond work (a family-weighted split can substitute later), and + !> bond work is motion-invariant -- this balance holds for the entire run + !> regardless of deformation or flight, using ALL ranks even when the solid + !> occupies a corner of the fluid domain. + !> Inputs: this rank's extracted nodes (any distribution). Outputs: the + !> nodes assigned to this rank, plus each INPUT node's assigned owner (for + !> stamping the face particles' routing tags). + subroutine pd_partition(n_in,gid_in,pos_in,vel_in,flag_in,vol_in,owner_out, & + & n_out,gid_out,pos_out,vel_out,flag_out,vol_out) + use parallel, only: comm,rank,nproc,amRoot,MPI_REAL_WP + use pdhalo_class, only: sort3_perm + use mpi_f08 + implicit none + integer, intent(in) :: n_in + integer(I8), intent(in) :: gid_in(:) + real(WP), intent(in) :: pos_in(:,:),vel_in(:,:) + integer, intent(in) :: flag_in(:) + real(WP), intent(in) :: vol_in(:) + integer, intent(out) :: owner_out(:) + integer, intent(out) :: n_out + integer(I8), allocatable, intent(out) :: gid_out(:) + real(WP), allocatable, intent(out) :: pos_out(:,:),vel_out(:,:),vol_out(:) + integer, allocatable, intent(out) :: flag_out(:) + real(WP), dimension(3) :: blo,bhi,inv + integer(I8), allocatable :: keys(:),splitters(:) + integer :: i,r,d,ierr + + ! Global reference bounds + blo=huge(1.0_WP); bhi=-huge(1.0_WP) + do i=1,n_in + blo=min(blo,pos_in(:,i)); bhi=max(bhi,pos_in(:,i)) + end do + call MPI_ALLREDUCE(MPI_IN_PLACE,blo,3,MPI_REAL_WP,MPI_MIN,comm,ierr) + call MPI_ALLREDUCE(MPI_IN_PLACE,bhi,3,MPI_REAL_WP,MPI_MAX,comm,ierr) + do d=1,3 + inv(d)=0.0_WP + if (bhi(d).gt.blo(d)) inv(d)=2097151.0_WP/(bhi(d)-blo(d)) + end do + + ! Morton keys of this rank's nodes + allocate(keys(max(n_in,1))) + do i=1,n_in + keys(i)=morton(pos_in(:,i),blo,inv) + end do + + ! Equal-weight splitters by SAMPLE SORT: each rank contributes a few + ! evenly-spaced samples of its locally sorted keys, weighted by its node + ! count -- root memory is O(nproc*S), not O(N_global), so this scales to + ! very large rank counts (the old gather-all-keys approach walled at + ! root memory and int32 N_global). + allocate(splitters(max(nproc-1,1))) + sample_splitters: block + integer, parameter :: S=16 + integer(I8), allocatable :: lsamp(:),gsamp(:),gw(:) + real(WP), allocatable :: w(:) + integer, allocatable :: perm(:),zk(:),scnt(:),sdis(:) + integer(I8) :: wtot,wcum,wtarg + integer :: ns,j,r2,gtot + ! Locally sort keys (permutation) and draw samples + allocate(perm(max(n_in,1)),zk(max(n_in,1))) + do i=1,n_in + perm(i)=i + end do + zk=0 + if (n_in.gt.1) call sort3_perm(zk,keys(1:n_in),zk,perm,1,n_in) + ns=min(S,n_in) + allocate(lsamp(max(ns,1))) + do j=1,ns + lsamp(j)=keys(perm(min(n_in,int((real(j,WP)-0.5_WP)*real(n_in,WP)/real(ns,WP))+1))) + end do + deallocate(perm,zk) + ! Gather samples (+ per-rank sample counts and node counts) on root + allocate(scnt(nproc),sdis(nproc)) + call MPI_GATHER(ns,1,MPI_INTEGER,scnt,1,MPI_INTEGER,0,comm,ierr) + gtot=0 + if (amRoot) then + sdis(1)=0 + do r2=2,nproc + sdis(r2)=sdis(r2-1)+scnt(r2-1) + end do + gtot=sum(scnt) + end if + allocate(gsamp(max(gtot,1)),gw(nproc)) + call MPI_GATHERV(lsamp,ns,MPI_INTEGER8,gsamp,scnt,sdis,MPI_INTEGER8,0,comm,ierr) + call MPI_GATHER(int(n_in,I8),1,MPI_INTEGER8,gw,1,MPI_INTEGER8,0,comm,ierr) + if (amRoot.and.gtot.gt.0) then + root_split: block + integer, allocatable :: p2(:),z2(:) + real(WP), allocatable :: sw(:) + ! Weight each sample by (its rank's node count)/(its rank's samples) + allocate(sw(gtot),p2(gtot),z2(gtot)) + do r2=1,nproc + do j=sdis(r2)+1,sdis(r2)+scnt(r2) + sw(j)=real(gw(r2),WP)/real(max(scnt(r2),1),WP) + end do + end do + do j=1,gtot + p2(j)=j + end do + z2=0 + call sort3_perm(z2,gsamp(1:gtot),z2,p2,1,gtot) + ! Single cumulative-weight pass placing all nproc-1 splitters + wtot=sum(gw) + wcum=0_I8; r2=1 + do j=1,gtot + if (r2.gt.nproc-1) exit + wcum=wcum+int(sw(p2(j)),I8) + do while (r2.le.nproc-1.and.wcum.ge.(int(r2,I8)*wtot)/int(nproc,I8)) + splitters(r2)=gsamp(p2(j)) + r2=r2+1 + end do + end do + do while (r2.le.nproc-1) + splitters(r2)=huge(1_I8) ! degenerate tail: empty upper buckets + r2=r2+1 + end do + deallocate(sw,p2,z2) + end block root_split + end if + deallocate(lsamp,gsamp,gw,scnt,sdis) + end block sample_splitters + if (nproc.gt.1) call MPI_BCAST(splitters,nproc-1,MPI_INTEGER8,0,comm,ierr) + + ! Assign owners: bucket = number of splitters <= key + do i=1,n_in + owner_out(i)=0 + do r=1,nproc-1 + if (keys(i).ge.splitters(r)) owner_out(i)=r + end do + end do + deallocate(keys,splitters) + + ! Route node payloads to their owners + route_nodes: block + integer, dimension(0:nproc-1) :: sc,rc,sd,rd,scw,rcw,sdw,rdw + integer, allocatable :: pos(:),sflag(:) + integer(I8), allocatable :: sgid(:) + real(WP), allocatable :: sdat(:,:),rdat(:,:) + sc=0 + do i=1,n_in + sc(owner_out(i))=sc(owner_out(i))+1 + end do + call MPI_ALLTOALL(sc,1,MPI_INTEGER,rc,1,MPI_INTEGER,comm,ierr) + sd(0)=0; rd(0)=0 + do r=1,nproc-1 + sd(r)=sd(r-1)+sc(r-1); rd(r)=rd(r-1)+rc(r-1) + end do + n_out=sum(rc) + allocate(pos(0:nproc-1),sgid(max(n_in,1)),sflag(max(n_in,1)),sdat(7,max(n_in,1))) + pos=sd + do i=1,n_in + r=owner_out(i); pos(r)=pos(r)+1 + sgid(pos(r))=gid_in(i) + sflag(pos(r))=flag_in(i) + sdat(1:3,pos(r))=pos_in(:,i) + sdat(4:6,pos(r))=vel_in(:,i) + sdat(7,pos(r)) =vol_in(i) + end do + allocate(gid_out(max(n_out,1)),flag_out(max(n_out,1)),rdat(7,max(n_out,1))) + allocate(pos_out(3,max(n_out,1)),vel_out(3,max(n_out,1)),vol_out(max(n_out,1))) + call MPI_ALLTOALLV(sgid,sc,sd,MPI_INTEGER8,gid_out,rc,rd,MPI_INTEGER8,comm,ierr) + call MPI_ALLTOALLV(sflag,sc,sd,MPI_INTEGER,flag_out,rc,rd,MPI_INTEGER,comm,ierr) + scw=7*sc; sdw=7*sd; rcw=7*rc; rdw=7*rd + call MPI_ALLTOALLV(sdat,scw,sdw,MPI_REAL_WP,rdat,rcw,rdw,MPI_REAL_WP,comm,ierr) + do i=1,n_out + pos_out(:,i)=rdat(1:3,i) + vel_out(:,i)=rdat(4:6,i) + vol_out(i) =rdat(7,i) + end do + deallocate(pos,sgid,sflag,sdat,rdat) + end block route_nodes + + contains + + !> 63-bit Morton key: 21 bits per dimension, bit-interleaved + pure function morton(p,lo,inv) result(key) + implicit none + real(WP), dimension(3), intent(in) :: p,lo,inv + integer(I8) :: key + integer(I8), dimension(3) :: ix + integer :: b,d + do d=1,3 + ix(d)=int(min(max((p(d)-lo(d))*inv(d),0.0_WP),2097151.0_WP),I8) + end do + key=0_I8 + do b=0,20 + do d=1,3 + if (btest(ix(d),b)) key=ibset(key,3*b+d-1) + end do + end do + end function morton + + end subroutine pd_partition + + + !> Bin geometry: cell size >= the search radius (so +/-1 cell sweeps are complete), + !> dims clamped to keep total cell count bounded on huge/degenerate extents + subroutine setup_bins(lo,hi,r,gl,h,nc) + real(WP), dimension(3), intent(in) :: lo,hi + real(WP), intent(in) :: r + real(WP), dimension(3), intent(out) :: gl,h + integer, dimension(3), intent(out) :: nc + integer :: d + do d=1,3 + gl(d)=lo(d)-0.5_WP*r + nc(d)=max(1,min(256,int((hi(d)-lo(d)+r)/r))) + h(d)=max((hi(d)+0.5_WP*r-gl(d))/real(nc(d),WP),r) + end do + end subroutine setup_bins + + !> Flattened cell index of a position (clamped into the grid) + pure function cell_of(p,gl,h,nc) result(k) + real(WP), dimension(3), intent(in) :: p,gl,h + integer, dimension(3), intent(in) :: nc + integer :: k,c(3),d + do d=1,3 + c(d)=min(nc(d),max(1,int((p(d)-gl(d))/h(d))+1)) + end do + k=c(1)+nc(1)*(c(2)-1)+nc(1)*nc(2)*(c(3)-1) + end function cell_of + + + !> Influence function w(zeta) (Peridigm forms). ONE form active, hard-coded; + !> flip by (un)commenting -- s0-from-G_c, psi_fac, and the critical-dt + !> diagnostic all generalize through wmoment(), so nothing else changes. + pure function omega(d,h) result(w) + ! implicit none + ! real(WP), intent(in) :: d,h + ! real(WP) :: w + ! real(WP) :: s + ! ! Parabolic decay (ACTIVE): 1 in the core, C1 taper to 0 at the horizon + ! s=d/h + ! if (s.lt.0.5_WP) then + ! w=1.0_WP + ! else + ! w=max(4.0_WP*s*(1.0_WP-s),0.0_WP) + ! end if + ! ! Constant (Peridigm default; pre-2026-07-16 behavior) + ! !w=1.0_WP + ! ! Gaussian + ! !w=exp(-(d/(0.4_WP*h))**2) + implicit none + real(WP), intent(in) :: d,h + real(WP), parameter :: coeff=2.6_WP + real(WP) :: hh, w + ! hh=coeff*h + hh=h + if (d.ge.hh) then + w=0.0_WP + else + ! wgauss=(1.0_WP+4.0_WP*d/hh)*(1.0_WP-d/hh)**4 + w=(1.0_WP-d/h)**3 + end if + end function omega + + !> Moment of the influence function: int_0^delta w(z)^wpow * z^zpow dz + !> (midpoint quadrature through omega(), so any form change propagates) + pure function wmoment(delta,zpow,wpow) result(m) + implicit none + real(WP), intent(in) :: delta + integer, intent(in) :: zpow,wpow + real(WP) :: m + integer, parameter :: NQ=2048 + integer :: i + real(WP) :: z,dz + dz=delta/real(NQ,WP) + m=0.0_WP + do i=1,NQ + z=(real(i,WP)-0.5_WP)*dz + m=m+omega(z,delta)**wpow*z**zpow + end do + m=m*dz + end function wmoment + + !> Lexicographic sign of an image shift: .true. for the "positive" member + !> of a self-image pair (first nonzero component positive), so each + !> self-image bond is census-counted exactly once. + pure function shift_positive(s) result(p) + implicit none + real(WP), dimension(3), intent(in) :: s + logical :: p + integer :: d + p=.false. + do d=1,3 + if (abs(s(d)).gt.0.0_WP) then + p=(s(d).gt.0.0_WP) + return + end if + end do + end function shift_positive + + !> Negate a packed periodic image offset (amrpd hist1 convention) + pure function negkey(key) result(nk) + implicit none + integer, intent(in) :: key + integer :: nk,n1,n2,n3 + n1=mod(key,256)-128; n2=mod(key/256,256)-128; n3=key/65536-128 + nk=(-n1+128)+(-n2+128)*256+(-n3+128)*65536 + end function negkey + +end module NOSB_class diff --git a/examples/NOSB_plate_with_hole_peridigm/src/OSB_class.f90 b/examples/NOSB_plate_with_hole_peridigm/src/OSB_class.f90 new file mode 100644 index 000000000..c2ec838fd --- /dev/null +++ b/examples/NOSB_plate_with_hole_peridigm/src/OSB_class.f90 @@ -0,0 +1,2184 @@ +!> Peridynamics solver: node-centered, CSR-based solid dynamics on flat +!> per-field arrays with persistent graph-halo communication. GRID-FREE: +!> no AMReX anywhere -- ownership follows the reference configuration +!> (Morton partition, motion-invariant), neighborhoods and communication +!> plans are built once and reused every substep. +!> +!> Physics: linear peridynamic solid (LPS, dimension-aware coefficients, +!> influence function hard-coded in omega() with derived quantities +!> generalized through its moments), brittle stretch damage, per-side +!> viscoelastic/viscoplastic flow with J2 (Mitchell OSB) yield, soft-sphere +!> contact (walls + particle-particle via a displacement-triggered spatial +!> service), velocity-Verlet integration. +!> Checkpoint/restart is gid-space and rank-count portable, including all +!> bond damage and plastic history. +!> +!> Usage tiers (amrpd EXTENDS pdsolver -- see amrpd_class): +!> 1. pdsolver alone -- standalone solid dynamics (this module only) +!> 2. amrpd -- adds viz, mesh VF, AMR refinement, seeding +!> 3. ... + a flow solver -- two-way FSI via amrpd%exchange_solid +!> +!> Configuration style: assign the public fields (material, damage, contact), +!> then build the network (detect_families/connect/read_state) -- derived +!> quantities resolve there via derive_config, uniformly for fresh and restart. +!> +!> Layout: owned nodes 1..nown; halo slots nown+1..ntot, keyed (gid, periodic +!> image offset) with shifts applied at exchange time. Each physical bond is +!> two CSR half-entries (one per endpoint row, Peridigm convention): kernels +!> compute each row's own force state -- ghost dilatation is never +!> communicated -- and a single halo reduce assembles cross-rank pairs. +!> Kernels are pure loops over owned nodes with no mutable module-level +!> state (OpenMP-ready by construction; threads deferred). +module OSB_class + use precision, only: WP,I8 + use string, only: str_medium + use pdhalo_class, only: pddir,pdhalo,sort3_perm,PDHALO_KEY0 + use pdhash_class, only: gid_hash + implicit none + private + + public :: pdsolver,pd_partition + public :: PDC_IS_DEAD,PDC_MOVES,PDC_INTEGRATES,PDC_BONDS + public :: PD_OPEN,PD_WALL + + ! Motion-control bit flags -- values MUST match amrpd's PART_* constants + ! (handoff copies amrpd flags verbatim) + integer, parameter :: PDC_IS_DEAD =0 + integer, parameter :: PDC_MOVES =1 + integer, parameter :: PDC_INTEGRATES=2 + integer, parameter :: PDC_BONDS =4 + + ! Domain-face BC values for lo_bc/hi_bc + integer, parameter :: PD_OPEN=0 + integer, parameter :: PD_WALL=1 + + !> Graph-core PD solver + type :: pdsolver + character(len=str_medium) :: name='UNNAMED_PDSOLVER' + + ! Sizes + integer :: nown=0 !< owned nodes on this rank + integer :: nhalo=0 !< halo slots + integer :: ntot=0 !< nown+nhalo + integer(I8) :: np=0 !< global node count (get_info) + integer(I8) :: nbond=0 !< global bond count (half-entries/2, get_info) + + ! Material / discretization + real(WP) :: rho =0.0_WP !< density + real(WP) :: elastic_modulus=0.0_WP !< Young's modulus + real(WP) :: poisson_ratio =0.0_WP !< Poisson's ratio + real(WP) :: delta =0.0_WP !< horizon + real(WP) :: dV =0.0_WP !< nominal element volume (CFL length scale; kernels use per-node V) + real(WP) :: s0 =huge(1.0_WP) !< critical bond stretch (huge = no damage) + real(WP) :: fail_stretch =huge(1.0_WP) !< direct s0 override (takes precedence over crit_energy) + real(WP) :: crit_energy =huge(1.0_WP) !< critical energy release rate G_c (-> s0 when fail_stretch unset) + real(WP) :: dtcrit =0.0_WP !< Silling-Askari critical dt (diagnostic, stamped at connect) + ! Viscoelastic / viscoplastic flow (PER-SIDE form: each half-entry evolves + ! its own e_v with its own endpoint's dilatation and yield factor -- + ! exactly Peridigm's elastic_plastic.cxx, verified term-by-term against + ! amrpd's J2 2026-07-14. This is the one INTENDED delta from amrpd, which + ! averages the endpoints into a single per-bond e_v.) + real(WP) :: tau =huge(1.0_WP) !< Maxwell deviatoric relaxation time (huge = purely elastic) + real(WP) :: visc_lambda =1.0_WP !< SLS relaxing fraction [0,1] + real(WP) :: yield_stretch =0.0_WP !< legacy per-bond Perzyna yield strain (0 = pure Maxwell) + real(WP) :: sigma_yield =0.0_WP !< J2 yield stress (Mitchell OSB family norm; overrides yield_stretch) + real(WP) :: hard_mod =0.0_WP !< linear isotropic hardening modulus H: flow stress = sigma_yield + H*lam_p (0 = perfectly plastic) + real(WP), dimension(3) :: gravity=0.0_WP !< body acceleration + logical, dimension(3) :: collapsed=.false. !< collapsed (n==1) directions: velocity locked + real(WP), dimension(3) :: Ldom=0.0_WP !< domain lengths (image shifts) + logical, dimension(3) :: per=.false. !< periodicity per direction + real(WP), dimension(3) :: dom_lo=0.0_WP !< domain lower bounds (wall contact) + real(WP), dimension(3) :: dom_hi=0.0_WP !< domain upper bounds (wall contact) + + ! Short-range soft-sphere contact (soft-sphere penalty + damping). + ! Contact is a pure SPATIAL service, fully separate from the bond graph: + ! candidates are (owned nodes + contact-halo slots) discovered by a + ! displacement-triggered broad phase; the graph halo is never binned, so + ! bonded remote partners arrive as contact slots when in range and + ! double-counting is structurally impossible. The narrow phase is + ! gather-only (each owned node accumulates from its candidates -- the + ! partner gets its share from its own row), so no force reduction. + logical :: use_contact =.false. + real(WP) :: contact_dist =0.0_WP !< d_c (p-p d_eff; wall d_eff = 0.5*d_c) + real(WP) :: tau_col =0.0_WP !< collision duration (<=0 -> auto 5*dt) + real(WP) :: e_n=0.7_WP,e_w=0.7_WP !< restitution (p-p, wall) + real(WP) :: clip_col =0.2_WP !< overlap clip fraction + integer, dimension(3) :: lo_bc=PD_OPEN,hi_bc=PD_OPEN !< per-face: PD_OPEN or PD_WALL + real(WP) :: cskin =0.0_WP !< broad-phase skin (<=0 -> auto 0.5*contact_dist) + type(pdhalo) :: chalo !< contact halo (rebuilt at trigger cadence; nown=ntot) + integer :: nchalo=0 !< contact slots (y/v extended to ntot+nchalo) + integer, allocatable :: cptr(:),clst(:) !< candidate CSR (owned rows; entries index owned+contact slots) + real(WP), allocatable :: ylast(:,:) !< (3,nown) positions at last broad-phase build + + ! Node state -- flat per-field arrays; owned first, halo slots appended. + ! (3,:) fields are xyz-interleaved per node (Fortran-natural gather layout). + integer(I8), allocatable :: gid(:) !< (ntot) global id (halo slots carry partner gid) + real(WP), allocatable :: x0(:,:) !< (3,ntot) reference position; halo PRE-SHIFTED + real(WP), allocatable :: y(:,:) !< (3,ntot) current position; halo shifted at update + real(WP), allocatable :: v(:,:) !< (3,nown) velocity + real(WP), allocatable :: f(:,:) !< (3,ntot) bond force density (halo = scatter buffer) + real(WP), allocatable :: ff(:,:) !< (3,nown) external (fluid) force density + real(WP), allocatable :: vol(:) !< (ntot) per-node volume (reference; halo slots filled at connect) + real(WP), allocatable :: mw(:) !< (nown) weighted volume (reference, set at connect) + real(WP), allocatable :: theta(:) !< (nown) dilatation (recomputed each substep) + real(WP), allocatable :: damage(:) !< (nown) accumulated damage fraction (broken/reference bonds) + real(WP), allocatable :: lam_p(:) !< (nown) accumulated equivalent plastic strain (J2 path; drives hardening, free diagnostic when hard_mod=0) + real(WP), allocatable :: alive(:) !< (ntot) 1=alive, 0=dead (exit through open face); halo-exchanged on death events only + integer, allocatable :: flag(:) !< (nown) motion-control flags + logical :: watch_exit=.false. !< exit detection active (set at connect: domain set + any open non-periodic face) + + ! CSR families (built once at connect) + integer, allocatable :: ptr(:) !< (nown+1) row offsets + integer, allocatable :: lst(:) !< neighbor index (1..ntot) per half-entry + integer(1), allocatable :: dmg(:) !< per half-entry: 0 intact, 1 broken (irreversible) + real(WP), allocatable :: e_v(:) !< per half-entry: inelastic deviatoric stretch (per-side history) + real(WP), allocatable :: td2(:),td2a(:) !< (nown) J2 family deviatoric norm^2: previous substep / accumulator. + !< Node-centered => pure own-row gather, NO communication (amrpd + !< needed sum_ghosts_td2 + ghost refresh for the same quantity). + + ! Parallel machinery + type(gid_hash) :: ohash !< gid -> owned index (built at set_nodes) + type(pddir) :: dir !< persistent gid directory (owner lookups; registered at connect/read_state) + type(pdhalo) :: halo !< persistent halo plan + real(WP), allocatable :: rextra_tmp(:,:) !< read_state scratch (restart-field overlay across assemble) + + ! Monitoring + real(WP) :: Umin=0.0_WP,Umax=0.0_WP !< signed per-component velocity extrema + real(WP) :: Vmin=0.0_WP,Vmax=0.0_WP !< over live nodes (get_info) + real(WP) :: Wmin=0.0_WP,Wmax=0.0_WP + real(WP) :: EPmax=0.0_WP !< max accumulated equivalent plastic strain (get_info) + real(WP) :: CFLe=0.0_WP,CFLp=0.0_WP !< elastic-wave / convective CFL (get_cfl) + integer(I8) :: nbroken=0 !< global broken half-entry count (internal) + integer(I8) :: nb_broken=0 !< global broken BOND count (exact census, get_info) + integer(I8) :: nb=0 !< global bond count (exact census, stamped at assemble) + integer(I8) :: nrebuild=0 !< broad-phase rebuild count (cumulative) + integer(I8) :: nchalo_glob=0 !< global contact-slot count (get_info) + integer(I8) :: ncand_glob=0 !< global contact-candidate count (get_info) + + ! Per-rank phase timers (accumulated in advance; reduced+reset in get_info) + real(WP) :: wt_kick=0.0_WP,wt_halo=0.0_WP,wt_dil=0.0_WP,wt_force=0.0_WP,wt_reduce=0.0_WP + real(WP) :: wt_contact=0.0_WP,wt_broad=0.0_WP + real(WP) :: wtmax_kick=0.0_WP,wtmax_halo=0.0_WP,wtmax_dil=0.0_WP,wtmax_force=0.0_WP,wtmax_reduce=0.0_WP + real(WP) :: wtmax_contact=0.0_WP,wtmax_broad=0.0_WP + real(WP) :: wtmin_dil=0.0_WP,wtmin_force=0.0_WP + real(WP) :: tot_time=0.0_WP,maxtot_time=0.0_WP + + ! Damping rate for steady state + real(WP) :: damping_rate=0.0_WP + + contains + procedure :: set_nodes + procedure :: connect + procedure :: detect_families + procedure :: pd_advance + procedure :: exchange + procedure :: query_owners + procedure :: write_state + procedure :: read_state + procedure :: get_cfl + procedure :: get_info + procedure :: finalize + procedure, private :: derive_config + procedure, private :: lps_coefs + procedure, private :: compute_mw + procedure, private :: contact_broadphase + procedure, private :: contact_narrow + procedure, private :: assemble + end type pdsolver + +contains + + + !> Resolve derived configuration: s0 from fail_stretch/crit_energy, contact + !> reach default. Called by every network-building entry point (connect, + !> detect_families, read_state) so fresh init and restart share one path. + subroutine derive_config(this) + use messager, only: die + implicit none + class(pdsolver), intent(inout) :: this + real(WP) :: K_bulk + if (this%rho.le.0.0_WP.or.this%elastic_modulus.le.0.0_WP.or. & + & this%delta.le.0.0_WP.or.this%dV.le.0.0_WP) & + & call die('[pdsolver] material/discretization not configured (need rho, elastic_modulus, delta, dV > 0)') + if (this%fail_stretch.lt.huge(1.0_WP)) then + this%s0=this%fail_stretch + else if (this%crit_energy.gt.0.0_WP.and.this%crit_energy.lt.huge(1.0_WP)) then + ! Silling-Askari bond-energy argument, generalized to the active + ! influence function: G_c = (9/4)*K*s0^2*Iw4/Iw3 (w=1 recovers the + ! classical s0 = sqrt(5*G_c/(9*K*delta))) + K_bulk=this%elastic_modulus/(3.0_WP*(1.0_WP-2.0_WP*this%poisson_ratio)) + this%s0=sqrt(4.0_WP*this%crit_energy*wmoment(this%delta,3,1)/(9.0_WP*K_bulk*wmoment(this%delta,4,1))) + end if + if (this%use_contact.and.this%contact_dist.le.0.0_WP) this%contact_dist=0.9_WP*this%dV**(1.0_WP/3.0_WP) + end subroutine derive_config + + !> Load this rank's owned nodes (any distribution; it becomes the static + !> partition). Builds the gid->index hash used by connect and the halo plan. + !> vol is the per-node volume (pass a constant-filled array for a uniform + !> lattice; kernels use it per neighbor, Peridigm-style). + subroutine set_nodes(this,n,gids,pos,vel,flags,vol) + implicit none + class(pdsolver), intent(inout) :: this + integer, intent(in) :: n + integer(I8), intent(in) :: gids(:) + real(WP), intent(in) :: pos(:,:),vel(:,:) + integer, intent(in) :: flags(:) + real(WP), intent(in) :: vol(:) + integer :: i + this%nown=n + this%nhalo=0 + this%ntot=n + allocate(this%gid(max(n,1)),this%x0(3,max(n,1)),this%y(3,max(n,1))) + allocate(this%v(3,max(n,1)),this%f(3,max(n,1)),this%ff(3,max(n,1))) + allocate(this%mw(max(n,1)),this%theta(max(n,1)),this%flag(max(n,1))) + allocate(this%vol(max(n,1)),this%damage(max(n,1)),this%lam_p(max(n,1))) + do i=1,n + this%gid(i) =gids(i) + this%x0(:,i)=pos(:,i) + this%y(:,i) =pos(:,i) + this%v(:,i) =vel(:,i) + this%flag(i)=flags(i) + this%vol(i) =vol(i) + end do + this%f=0.0_WP; this%ff=0.0_WP; this%mw=0.0_WP; this%theta=0.0_WP; this%damage=0.0_WP; this%lam_p=0.0_WP + call this%ohash%build(n,gids(1:n)) + end subroutine set_nodes + + !> Build the static CSR families and the halo plan from a distributed bond + !> list (this rank passes the bonds it holds; any distribution is fine -- + !> half-entries are routed to their node's owner through the gid directory). + !> Collective. bkey packs the periodic image offset of the HI endpoint in + !> amrpd's hist1 convention. Self-image bonds (gid_lo==gid_hi) yield ONE + !> half-entry (the opposite-image bond exists separately in the input, exactly + !> as amrpd stores them). + subroutine connect(this,nb,bgid_lo,bgid_hi,bkey) + use parallel, only: comm,nproc + use messager, only: die + use mpi_f08 + implicit none + class(pdsolver), intent(inout) :: this + integer, intent(in) :: nb + integer(I8), intent(in) :: bgid_lo(:),bgid_hi(:) + integer, intent(in) :: bkey(:) + integer(I8), allocatable :: hnode(:),hnbr(:),rnode(:),rnbr(:) + integer, allocatable :: hkey(:),howner(:),rkey(:) + real(WP), allocatable :: rev(:) + integer(1), allocatable :: rdmg(:) + integer :: nhe,rn,i,ib,ierr + + ! Resolve derived configuration (restart-safe shared path) + call this%derive_config() + + ! Distributed gid directory over the node partition (persistent: also + ! serves owner queries for face-tag restamping after restart) + call this%dir%finalize() + call this%dir%register(this%nown,this%gid(1:this%nown)) + + ! Expand bonds into half-entries (one per endpoint row; one total for + ! self-image bonds -- see header) + nhe=0 + do ib=1,nb + nhe=nhe+1 + if (bgid_lo(ib).ne.bgid_hi(ib)) nhe=nhe+1 + end do + allocate(hnode(max(nhe,1)),hnbr(max(nhe,1)),hkey(max(nhe,1)),howner(max(nhe,1))) + nhe=0 + do ib=1,nb + nhe=nhe+1 + hnode(nhe)=bgid_lo(ib); hnbr(nhe)=bgid_hi(ib); hkey(nhe)=bkey(ib) + if (bgid_lo(ib).ne.bgid_hi(ib)) then + nhe=nhe+1 + hnode(nhe)=bgid_hi(ib); hnbr(nhe)=bgid_lo(ib); hkey(nhe)=negkey(bkey(ib)) + end if + end do + + ! Route each half-entry to the rank owning its node + call this%dir%query(nhe,hnode,howner) + route_entries: block + integer, dimension(0:nproc-1) :: sc,rc,sd,rd + integer, allocatable :: pos(:) + integer(I8), allocatable :: s8(:) + integer, allocatable :: s4(:) + integer :: r,h + sc=0 + do i=1,nhe + sc(howner(i))=sc(howner(i))+1 + end do + call MPI_ALLTOALL(sc,1,MPI_INTEGER,rc,1,MPI_INTEGER,comm,ierr) + sd(0)=0; rd(0)=0 + do r=1,nproc-1 + sd(r)=sd(r-1)+sc(r-1); rd(r)=rd(r-1)+rc(r-1) + end do + rn=sum(rc) + allocate(rnode(max(rn,1)),rnbr(max(rn,1)),rkey(max(rn,1))) + allocate(pos(0:nproc-1),s8(max(nhe,1)),s4(max(nhe,1))) + ! node gids + pos=sd + do i=1,nhe + h=howner(i); pos(h)=pos(h)+1; s8(pos(h))=hnode(i) + end do + call MPI_ALLTOALLV(s8,sc,sd,MPI_INTEGER8,rnode,rc,rd,MPI_INTEGER8,comm,ierr) + ! neighbor gids + pos=sd + do i=1,nhe + h=howner(i); pos(h)=pos(h)+1; s8(pos(h))=hnbr(i) + end do + call MPI_ALLTOALLV(s8,sc,sd,MPI_INTEGER8,rnbr,rc,rd,MPI_INTEGER8,comm,ierr) + ! image keys + pos=sd + do i=1,nhe + h=howner(i); pos(h)=pos(h)+1; s4(pos(h))=hkey(i) + end do + call MPI_ALLTOALLV(s4,sc,sd,MPI_INTEGER,rkey,rc,rd,MPI_INTEGER,comm,ierr) + deallocate(pos,s8,s4) + end block route_entries + deallocate(hnode,hnbr,hkey,howner) + + ! Fresh bonds carry zero inelastic state + allocate(rev(max(rn,1)),rdmg(max(rn,1))) + rev=0.0_WP; rdmg=0_1 + call this%assemble(rn,rnode,rnbr,rkey,rev,rdmg) + deallocate(rnode,rnbr,rkey,rev,rdmg) + end subroutine connect + + + !> Build the bond families directly from the REFERENCE configuration -- no + !> amrpd bond container, no bond expansion: distributed neighbor discovery + !> at radius delta (bounds allgather + per-(rank,image-offset) offers of + !> shifted x0, contact-broadphase pattern), then each owned row's + !> half-entries are generated straight from the binned candidates and fed + !> to assemble with zero inelastic state. Acceptance test r2 <= delta^2 + !> matches amrpd bond_init exactly. Collective; call after set_nodes. + subroutine detect_families(this) + use parallel, only: comm,rank,nproc,amRoot,MPI_REAL_WP + use messager, only: log,die + use string, only: str_long + use mpi_f08 + implicit none + class(pdsolver), intent(inout) :: this + real(WP), dimension(3) :: bl,bh,shift,pos_s,gl,hcell + real(WP), allocatable :: allb(:,:),opos(:,:),rpos(:,:),cpos(:,:) + integer(I8), allocatable :: ogid(:),rgid(:),cgid(:),hnode(:),hnbr(:) + integer, allocatable :: okey(:),rkey(:),ckey(:),hkey(:),head(:),nxt(:) + real(WP), allocatable :: rev(:) + integer(1), allocatable :: rdmg(:) + integer, dimension(0:nproc-1) :: sc,rc,sd,rd,sc3,rc3,sd3,rd3 + integer, dimension(3) :: nmax,nc + integer :: d,r,n1,n2,n3,i,k,m,noff,nrecv,ncand,nhe,pass,ic,jc,kc,c1,c2,c3,ierr + character(len=str_long) :: message + + ! Resolve derived configuration (restart-safe shared path) + call this%derive_config() + + ! Directory over the node partition (persistent) + call this%dir%finalize() + call this%dir%register(this%nown,this%gid(1:this%nown)) + + ! Owned reference bounds, exchanged globally + bl=huge(1.0_WP); bh=-huge(1.0_WP) + do i=1,this%nown + bl=min(bl,this%x0(:,i)); bh=max(bh,this%x0(:,i)) + end do + allocate(allb(6,0:nproc-1)) + call MPI_ALLGATHER([bl,bh],6,MPI_REAL_WP,allb,6,MPI_REAL_WP,comm,ierr) + do d=1,3 + nmax(d)=0 + if (this%per(d).and.this%Ldom(d).gt.0.0_WP) nmax(d)=min(4,int(this%delta/this%Ldom(d))+1) + end do + + ! Offers of shifted reference positions (two passes: count, fill) + do pass=1,2 + sc=0 + do r=0,nproc-1 + do n3=-nmax(3),nmax(3); do n2=-nmax(2),nmax(2); do n1=-nmax(1),nmax(1) + if (r.eq.rank.and.n1.eq.0.and.n2.eq.0.and.n3.eq.0) cycle + shift=[real(n1,WP)*this%Ldom(1),real(n2,WP)*this%Ldom(2),real(n3,WP)*this%Ldom(3)] + if (any(bl+shift-this%delta.gt.allb(4:6,r)).or.any(bh+shift+this%delta.lt.allb(1:3,r))) cycle + do i=1,this%nown + pos_s=this%x0(:,i)+shift + if (any(pos_s.lt.allb(1:3,r)-this%delta).or.any(pos_s.gt.allb(4:6,r)+this%delta)) cycle + sc(r)=sc(r)+1 + if (pass.eq.2) then + ogid(sd(r)+sc(r))=this%gid(i) + okey(sd(r)+sc(r))=(n1+128)+(n2+128)*256+(n3+128)*65536 + opos(:,sd(r)+sc(r))=pos_s + end if + end do + end do; end do; end do + end do + if (pass.eq.1) then + sd(0)=0 + do r=1,nproc-1 + sd(r)=sd(r-1)+sc(r-1) + end do + noff=sum(sc) + allocate(ogid(max(noff,1)),okey(max(noff,1)),opos(3,max(noff,1))) + end if + end do + call MPI_ALLTOALL(sc,1,MPI_INTEGER,rc,1,MPI_INTEGER,comm,ierr) + rd(0)=0 + do r=1,nproc-1 + rd(r)=rd(r-1)+rc(r-1) + end do + nrecv=sum(rc) + allocate(rgid(max(nrecv,1)),rkey(max(nrecv,1)),rpos(3,max(nrecv,1))) + call MPI_ALLTOALLV(ogid,sc,sd,MPI_INTEGER8,rgid,rc,rd,MPI_INTEGER8,comm,ierr) + call MPI_ALLTOALLV(okey,sc,sd,MPI_INTEGER, rkey,rc,rd,MPI_INTEGER, comm,ierr) + sc3=3*sc; sd3=3*sd; rc3=3*rc; rd3=3*rd + call MPI_ALLTOALLV(opos,sc3,sd3,MPI_REAL_WP,rpos,rc3,rd3,MPI_REAL_WP,comm,ierr) + deallocate(ogid,okey,opos) + + ! Candidate set = owned nodes (zero offset) + received offers + ncand=this%nown+nrecv + allocate(cgid(max(ncand,1)),ckey(max(ncand,1)),cpos(3,max(ncand,1))) + do i=1,this%nown + cgid(i)=this%gid(i); ckey(i)=PDHALO_KEY0; cpos(:,i)=this%x0(:,i) + end do + do i=1,nrecv + cgid(this%nown+i)=rgid(i); ckey(this%nown+i)=rkey(i); cpos(:,this%nown+i)=rpos(:,i) + end do + deallocate(rgid,rkey,rpos) + + ! Bin candidates; generate each owned row directly (two passes) + bl=huge(1.0_WP); bh=-huge(1.0_WP) + do m=1,ncand + bl=min(bl,cpos(:,m)); bh=max(bh,cpos(:,m)) + end do + call setup_bins(bl,bh,this%delta,gl,hcell,nc) + allocate(head(nc(1)*nc(2)*nc(3)),nxt(max(ncand,1))) + head=0 + do m=1,ncand + k=cell_of(cpos(:,m),gl,hcell,nc) + nxt(m)=head(k); head(k)=m + end do + do pass=1,2 + nhe=0 + do i=1,this%nown + ic=min(nc(1),max(1,int((this%x0(1,i)-gl(1))/hcell(1))+1)) + jc=min(nc(2),max(1,int((this%x0(2,i)-gl(2))/hcell(2))+1)) + kc=min(nc(3),max(1,int((this%x0(3,i)-gl(3))/hcell(3))+1)) + do c3=max(1,kc-1),min(nc(3),kc+1); do c2=max(1,jc-1),min(nc(2),jc+1); do c1=max(1,ic-1),min(nc(1),ic+1) + m=head(c1+nc(1)*(c2-1)+nc(1)*nc(2)*(c3-1)) + do while (m.gt.0) + if (m.ne.i) then + if (sum((cpos(:,m)-this%x0(:,i))**2).le.this%delta**2) then + nhe=nhe+1 + if (pass.eq.2) then + hnode(nhe)=this%gid(i) + hnbr(nhe) =cgid(m) + hkey(nhe) =ckey(m) + end if + end if + end if + m=nxt(m) + end do + end do; end do; end do + end do + if (pass.eq.1) allocate(hnode(max(nhe,1)),hnbr(max(nhe,1)),hkey(max(nhe,1))) + end do + deallocate(cgid,ckey,cpos,head,nxt,allb) + + ! Assemble with zero inelastic state (entries are already local rows) + allocate(rev(max(nhe,1)),rdmg(max(nhe,1))) + rev=0.0_WP; rdmg=0_1 + call this%assemble(nhe,hnode,hnbr,hkey,rev,rdmg) + deallocate(hnode,hnbr,hkey,rev,rdmg) + if (amRoot) then + write(message,'("[",a,"] detect_families: ",i0," half-entries (~2x bonds)")') trim(this%name),this%nbond + call log(message) + end if + end subroutine detect_families + + !> Assemble the CSR families, halo plan, and reference state from LOCAL + !> half-entry arrays (already routed to this rank: every entry's node gid is + !> owned here). Per-entry inelastic state (dmg, e_v) travels with the + !> entries -- zeros for a fresh connect, loaded values on restart. Shared by + !> connect and read_state; collective. + subroutine assemble(this,rn,rnode,rnbr,rkey,rev,rdmg) + use parallel, only: comm,nproc + use messager, only: die + use mpi_f08 + implicit none + class(pdsolver), intent(inout) :: this + integer, intent(in) :: rn + integer(I8), intent(in) :: rnode(:),rnbr(:) + integer, intent(in) :: rkey(:) + real(WP), intent(in) :: rev(:) + integer(1), intent(in) :: rdmg(:) + integer, allocatable :: ridx(:),perm(:) + integer :: i,s,ierr + + if (allocated(this%ptr)) deallocate(this%ptr) + if (allocated(this%lst)) deallocate(this%lst) + if (allocated(this%dmg)) deallocate(this%dmg) + if (allocated(this%e_v)) deallocate(this%e_v) + if (allocated(this%td2)) deallocate(this%td2) + if (allocated(this%td2a)) deallocate(this%td2a) + + ! Resolve each received entry's node to an owned index + allocate(ridx(max(rn,1)),perm(max(rn,1))) + do i=1,rn + ridx(i)=this%ohash%lookup(rnode(i)) + if (ridx(i).lt.1) call die('[pdsolver assemble] half-entry routed to a rank that does not own its node') + perm(i)=i + end do + + ! Deterministic CSR order: sort by (node index, neighbor gid, image key) + if (rn.gt.1) call sort3_perm(ridx,rnbr,rkey,perm,1,rn) + + ! Row pointers + allocate(this%ptr(this%nown+1)) + row_pointers: block + integer, allocatable :: cnt(:) + allocate(cnt(this%nown)); cnt=0 + do i=1,rn + cnt(ridx(i))=cnt(ridx(i))+1 + end do + this%ptr(1)=1 + do i=1,this%nown + this%ptr(i+1)=this%ptr(i)+cnt(i) + end do + deallocate(cnt) + end block row_pointers + + ! Classify entries (owned direct vs halo reference), dedupe references, + ! build the halo plan, and finalize the CSR neighbor indices + build_refs_and_halo: block + integer(I8), allocatable :: refgid(:),ugid(:) + integer, allocatable :: refkey(:),refpos(:),rperm(:),zeros(:) + integer, allocatable :: ukey(:),uowner(:),uslot(:) + integer :: nref,nuniq,lid,u + allocate(this%lst(max(rn,1))) + allocate(this%dmg(max(rn,1))); this%dmg=0_1 + allocate(this%e_v(max(rn,1))); this%e_v=0.0_WP + ! Per-entry inelastic state follows the deterministic CSR order + do s=1,rn + this%dmg(s)=rdmg(perm(s)) + this%e_v(s)=rev(perm(s)) + end do + allocate(this%td2(max(this%nown,1)),this%td2a(max(this%nown,1))) + this%td2=0.0_WP; this%td2a=0.0_WP + allocate(refgid(max(rn,1)),refkey(max(rn,1)),refpos(max(rn,1))) + nref=0 + do s=1,rn + i=perm(s) + if (rkey(i).eq.PDHALO_KEY0) then + lid=this%ohash%lookup(rnbr(i)) + if (lid.ge.1) then + this%lst(s)=lid ! owned, zero image offset: direct index + cycle + end if + end if + nref=nref+1 + refgid(nref)=rnbr(i); refkey(nref)=rkey(i); refpos(nref)=s + end do + ! Unique (gid,key) references, deterministic order + allocate(rperm(max(nref,1)),zeros(max(nref,1))) + zeros=0 + do i=1,nref + rperm(i)=i + end do + if (nref.gt.1) call sort3_perm(zeros,refgid,refkey,rperm,1,nref) + allocate(ugid(max(nref,1)),ukey(max(nref,1))) + nuniq=0 + do s=1,nref + i=rperm(s) + if (s.eq.1) then + nuniq=1; ugid(1)=refgid(i); ukey(1)=refkey(i) + else if (refgid(i).ne.refgid(rperm(s-1)).or.refkey(i).ne.refkey(rperm(s-1))) then + nuniq=nuniq+1; ugid(nuniq)=refgid(i); ukey(nuniq)=refkey(i) + end if + this%lst(refpos(i))=-nuniq ! provisional: -(unique ref id) + end do + ! Owners of the unique references, then the persistent halo plan + allocate(uowner(max(nuniq,1)),uslot(max(nuniq,1))) + call this%dir%query(nuniq,ugid,uowner) + call this%halo%build(this%nown,this%ohash,nuniq,ugid,ukey,uowner,this%Ldom,this%per,uslot) + this%nhalo=this%halo%nhalo + this%ntot=this%nown+this%nhalo + ! Finalize CSR: provisional negatives -> halo slot indices + do s=1,rn + if (this%lst(s).lt.0) this%lst(s)=this%nown+uslot(-this%lst(s)) + end do + ! Extend node arrays to include halo slots; stamp halo gids + extend_arrays: block + integer(I8), allocatable :: g2(:) + real(WP), allocatable :: a2(:,:) + allocate(g2(max(this%ntot,1))); g2(1:this%nown)=this%gid(1:this%nown) + do u=1,nuniq + g2(this%nown+uslot(u))=ugid(u) + end do + call move_alloc(g2,this%gid) + allocate(a2(3,max(this%ntot,1))); a2=0.0_WP; a2(:,1:this%nown)=this%x0(:,1:this%nown) + call move_alloc(a2,this%x0) + allocate(a2(3,max(this%ntot,1))); a2=0.0_WP; a2(:,1:this%nown)=this%y(:,1:this%nown) + call move_alloc(a2,this%y) + allocate(a2(3,max(this%ntot,1))); a2=0.0_WP; a2(:,1:this%nown)=this%f(:,1:this%nown) + call move_alloc(a2,this%f) + extend_volume: block + real(WP), allocatable :: v2(:) + allocate(v2(max(this%ntot,1))); v2=0.0_WP; v2(1:this%nown)=this%vol(1:this%nown) + call move_alloc(v2,this%vol) + end block extend_volume + end block extend_arrays + deallocate(refgid,refkey,refpos,rperm,zeros,ugid,ukey,uowner,uslot) + end block build_refs_and_halo + deallocate(ridx,perm) + + ! Fill halo reference positions ONCE, pre-shifted by the image offsets + ! (x0 is static; this is the only x0 exchange of the entire run), and + ! the halo per-node volumes (also static) + call this%halo%update(this%x0,3,shifted=.true.) + call this%halo%update1(this%vol) + this%y(:,this%nown+1:this%ntot)=this%x0(:,this%nown+1:this%ntot) + + ! Life status (exit-through-open-face handling). Exchanged over the halo + ! ONLY on substeps where a death occurs somewhere; steady state is free. + if (allocated(this%alive)) deallocate(this%alive) + allocate(this%alive(max(this%ntot,1))); this%alive=1.0_WP + this%watch_exit=(this%dom_hi(1).gt.this%dom_lo(1)).and. & + & any((.not.this%per).and.(this%lo_bc.eq.0.or.this%hi_bc.eq.0)) + + ! Stamp the reference weighted volume + call this%compute_mw() + + ! Silling-Askari critical time step (Peridigm form, 3D bond-based + ! micromodulus c(z) = c0*w(z), c0 = 9K/(2*pi*Iw3); w=1 recovers the + ! classical 18K/(pi*delta^4)): + ! dt_crit_i = sqrt(2*rho / sum_family(V_j * c(zeta) / zeta)), global min. + ! DIAGNOSTIC only for now -- reported at init, does not bind dt. The + ! micromodulus constant is 3D-based; in quasi-2D slabs treat it as + ! indicative. + critical_dt: block + use mathtools, only: Pi + use messager, only: log + use string, only: str_long + use parallel, only: amRoot,MPI_REAL_WP + real(WP) :: K_bulk,c0,denom,zeta,dtc + character(len=str_long) :: message + integer :: i,e,j + K_bulk=this%elastic_modulus/(3.0_WP*(1.0_WP-2.0_WP*this%poisson_ratio)) + c0=9.0_WP*K_bulk/(2.0_WP*Pi*wmoment(this%delta,3,1)) + dtc=huge(1.0_WP) + do i=1,this%nown + denom=0.0_WP + do e=this%ptr(i),this%ptr(i+1)-1 + j=this%lst(e) + zeta=sqrt(sum((this%x0(:,j)-this%x0(:,i))**2)) + if (zeta.gt.0.0_WP) denom=denom+this%vol(j)*c0*omega(zeta,this%delta)/zeta + end do + if (denom.gt.0.0_WP) dtc=min(dtc,sqrt(2.0_WP*this%rho/denom)) + end do + call MPI_ALLREDUCE(MPI_IN_PLACE,dtc,1,MPI_REAL_WP,MPI_MIN,comm,ierr) + this%dtcrit=dtc + if (amRoot) then + write(message,'("[",a,"] Silling-Askari critical dt = ",es12.5," (diagnostic)")') trim(this%name),this%dtcrit + call log(message) + end if + end block critical_dt + + ! Global half-entry count for logging (= 2*bonds - self-image bonds) + count_bonds: block + use parallel, only: comm + integer(I8) :: nhe8 + nhe8=int(rn,I8) + call MPI_ALLREDUCE(MPI_IN_PLACE,nhe8,1,MPI_INTEGER8,MPI_SUM,comm,ierr) + this%nbond=nhe8 ! total half-entries; = 2*bonds - self-image bonds + ! Exact bond census (lower-gid rule; positive-offset self-images) + count_nb: block + integer :: i2,e2,j2 + this%nb=0_I8 + do i2=1,this%nown + do e2=this%ptr(i2),this%ptr(i2+1)-1 + j2=this%lst(e2) + if (this%gid(i2).lt.this%gid(j2)) then + this%nb=this%nb+1_I8 + else if (this%gid(i2).eq.this%gid(j2).and.j2.gt.this%nown) then + if (shift_positive(this%halo%shift(:,j2-this%nown))) this%nb=this%nb+1_I8 + end if + end do + end do + call MPI_ALLREDUCE(MPI_IN_PLACE,this%nb,1,MPI_INTEGER8,MPI_SUM,comm,ierr) + end block count_nb + end block count_bonds + end subroutine assemble + + !> Weighted volume: mw_i = sum_family w(zeta)*zeta^2*V_j (reference state; + !> never updated by damage) + subroutine compute_mw(this) + implicit none + class(pdsolver), intent(inout) :: this + integer :: i,e,j + real(WP) :: zeta + do i=1,this%nown + this%mw(i)=0.0_WP + do e=this%ptr(i),this%ptr(i+1)-1 + j=this%lst(e) + zeta=sqrt(sum((this%x0(:,j)-this%x0(:,i))**2)) + this%mw(i)=this%mw(i)+omega(zeta,this%delta)*zeta**2*this%vol(j) + end do + end do + end subroutine compute_mw + + !> Dimension-aware LPS constitutive coefficients (omega-independent: mw + !> absorbs the influence function). psi_fac sets the J2 yield threshold on + !> the family deviatoric force-state norm -- yield when + !> ||t_dev||^2 > psi_fac*sigma_yield^2/mw (Mitchell OSB) -- and DOES depend + !> on omega: since td ~ w, the norm scales by the w^2/w moment ratio + !> (int w^2 z^p / int w z^p, p=4 in 3D, 3 in 2D; ratio = 1 for w=1). + subroutine lps_coefs(this,fdim,coef_vol,coef_dev,psi_fac) + implicit none + class(pdsolver), intent(in) :: this + real(WP), intent(out) :: fdim,coef_vol,coef_dev + real(WP), intent(out), optional :: psi_fac + real(WP) :: K_bulk,mu_shear + integer :: ndim + ndim=3-count(this%collapsed) + K_bulk =this%elastic_modulus/(3.0_WP*(1.0_WP-2.0_WP*this%poisson_ratio)) + mu_shear=this%elastic_modulus/(2.0_WP*(1.0_WP+this%poisson_ratio)) + select case (ndim) + case (3) + fdim=3.0_WP; coef_vol=3.0_WP*K_bulk; coef_dev=15.0_WP*mu_shear + if (present(psi_fac)) psi_fac=5.0_WP*wmoment(this%delta,4,2)/wmoment(this%delta,4,1) + case (2) + fdim=2.0_WP; coef_vol=2.0_WP*(K_bulk+mu_shear/3.0_WP); coef_dev= 8.0_WP*mu_shear + if (present(psi_fac)) psi_fac=8.0_WP/3.0_WP*wmoment(this%delta,3,2)/wmoment(this%delta,3,1) + case default + fdim=1.0_WP; coef_vol=this%elastic_modulus; coef_dev= 0.0_WP + if (present(psi_fac)) psi_fac=0.0_WP + end select + end subroutine lps_coefs + + !> Velocity-Verlet step: half-kick + drift, halo position update, + !> dilatation gather, node-centered force sweep, halo force reduce, + !> contact, second half-kick. + subroutine pd_advance(this,dt) + use parallel, only: parallel_time + implicit none + class(pdsolver), intent(inout) :: this + real(WP), intent(in) :: dt + real(WP) :: rho_inv,fdim,cvol,cdev,t0 + real(WP) :: zeta,dY,e_b,t,w + real(WP) :: psi_fac,decay,e_d,td,beta,e_e,over + real(WP) :: sYe2,strial,mu3i + logical :: plastic,do_j2 + real(WP), dimension(3) :: acc,dxv,fx + integer :: i,e,j + + real(WP) :: t_full + t_full=parallel_time() + + rho_inv=1.0_WP/this%rho + call this%lps_coefs(fdim,cvol,cdev,psi_fac) + ! Viscoplastic setup: decay is loop-invariant (exact exponential update, + ! unconditionally stable -- no viscous CFL) + plastic=(this%tau.gt.0.0_WP.and.this%tau.lt.huge(1.0_WP)) + do_j2=(this%sigma_yield.gt.0.0_WP) + decay=0.0_WP + if (plastic) decay=exp(-dt/this%tau) + mu3i=2.0_WP*(1.0_WP+this%poisson_ratio)/(3.0_WP*this%elastic_modulus) ! 1/(3*mu_shear) + + ! First half-kick and drift (owned nodes) + t0=parallel_time() + do i=1,this%nown + if (this%flag(i).eq.PDC_IS_DEAD) cycle + acc=this%gravity+(this%f(:,i)+this%ff(:,i))*rho_inv + if (iand(this%flag(i),PDC_INTEGRATES).ne.0) this%v(:,i)=(1.0_WP-this%damping_rate)*this%v(:,i)+0.5_WP*dt*acc + if (this%collapsed(1)) this%v(1,i)=0.0_WP + if (this%collapsed(2)) this%v(2,i)=0.0_WP + if (this%collapsed(3)) this%v(3,i)=0.0_WP + if (iand(this%flag(i),PDC_MOVES).ne.0) this%y(:,i)=this%y(:,i)+dt*this%v(:,i) + end do + this%wt_kick=this%wt_kick+(parallel_time()-t0) + + ! Exit handling: nodes drifting out through an OPEN non-periodic face die + ! (amrpd drops them at Redistribute; here they are flagged and muted). + ! The death-count allreduce runs only when exits are possible at all, and + ! the mute propagation only on substeps where a death actually occurred. + if (this%watch_exit) then + death_watch: block + use parallel, only: comm + use mpi_f08, only: MPI_ALLREDUCE,MPI_IN_PLACE,MPI_SUM,MPI_INTEGER + integer :: nd,d,e,ierr + logical :: out + nd=0 + do i=1,this%nown + if (this%flag(i).eq.PDC_IS_DEAD) cycle + out=.false. + do d=1,3 + if (this%per(d)) cycle + if (this%lo_bc(d).eq.0.and.this%y(d,i).lt.this%dom_lo(d)) out=.true. + if (this%hi_bc(d).eq.0.and.this%y(d,i).gt.this%dom_hi(d)) out=.true. + end do + if (out) then + this%flag(i)=PDC_IS_DEAD + this%v(:,i)=0.0_WP + this%alive(i)=0.0_WP + nd=nd+1 + end if + end do + call MPI_ALLREDUCE(MPI_IN_PLACE,nd,1,MPI_INTEGER,MPI_SUM,comm,ierr) + if (nd.gt.0) then + ! Propagate life status to halo slots, then permanently mute + ! every entry touching a dead node (dmg=2: distinct from broken, + ! so damage statistics stay honest -- amrpd does not count + ! dropped-particle bonds as damage either) + call this%halo%update1(this%alive) + do i=1,this%nown + if (this%flag(i).eq.PDC_IS_DEAD) then + do e=this%ptr(i),this%ptr(i+1)-1 + if (this%dmg(e).eq.0_1) this%dmg(e)=2_1 + end do + else + do e=this%ptr(i),this%ptr(i+1)-1 + if (this%dmg(e).eq.0_1.and.this%alive(this%lst(e)).lt.0.5_WP) this%dmg(e)=2_1 + end do + end if + end do + ! Force a contact broad-phase rebuild so no candidate list + ! references a corpse (dead nodes are excluded from offers/bins) + if (this%use_contact.and.allocated(this%ylast)) deallocate(this%ylast) + end if + end block death_watch + end if + + ! Refresh halo positions (owner y -> slots, with image shifts) + t0=parallel_time() + call this%halo%update(this%y,3,shifted=.true.) + this%wt_halo=this%wt_halo+(parallel_time()-t0) + + ! Contact service: displacement-triggered broad phase (rebuilds contact + ! halo + candidate list when cumulative drift exhausts the skin), then + ! per-substep refresh of contact-slot positions AND velocities (the only + ! place velocity crosses ranks; the graph halo never carries it) + if (this%use_contact) then + t0=parallel_time() + call this%contact_broadphase() + this%wt_broad=this%wt_broad+(parallel_time()-t0) + t0=parallel_time() + call this%chalo%update(this%y,3,shifted=.true.) + call this%chalo%update(this%v,3,shifted=.false.) + this%wt_halo=this%wt_halo+(parallel_time()-t0) + end if + + ! Dilatation (pure gather; own family only; broken entries excluded -- + ! breaks happen in the force sweep AFTER this, matching amrpd's ordering) + t0=parallel_time() + do i=1,this%nown + this%theta(i)=0.0_WP + do e=this%ptr(i),this%ptr(i+1)-1 + if (this%dmg(e).ne.0_1) cycle + j=this%lst(e) + zeta=sqrt(sum((this%x0(:,j)-this%x0(:,i))**2)) + dY =sqrt(sum((this%y(:,j) -this%y(:,i) )**2)) + e_b=dY-zeta + this%theta(i)=this%theta(i)+omega(zeta,this%delta)*zeta*e_b*this%vol(j) + end do + if (this%mw(i).gt.0.0_WP) then + this%theta(i)=fdim*this%theta(i)/this%mw(i) + else + this%theta(i)=0.0_WP + end if + end do + this%wt_dil=this%wt_dil+(parallel_time()-t0) + + ! Node-centered force sweep: each row computes its OWN force state t + ! (own theta, own mw) and scatters +t/-t; the neighbor's t arrives from + ! the neighbor's own row (locally or via the halo reduce below). + t0=parallel_time() + this%f=0.0_WP + do i=1,this%nown + if (this%mw(i).le.0.0_WP) cycle + ! Per-node J2 return factor from the LAGGED family norm. With + ! hardening (hard_mod>0) the surface radius grows with the node's + ! accumulated equivalent plastic strain lam_p (surface lagged one + ! substep like the norm: exact to O(H/3mu) per substep, and H<<3mu + ! for metals; stress-space equivalent of Peridigm's + ! elastic_plastic_hardening). The increment uses (1-beta)*strial = + ! the trial-stress excess, so the rate-independent limit matches the + ! classical radial return; (1-decay) is the Perzyna-realized + ! fraction. lam_p accumulates even at hard_mod=0 (free plastic- + ! strain diagnostic; forces unchanged there, bit-exact w/ flat yield). + beta=1.0_WP + if (plastic.and.do_j2) then + sYe2=(this%sigma_yield+this%hard_mod*this%lam_p(i))**2 + if (this%td2(i)*this%mw(i).gt.psi_fac*sYe2) then + beta=sqrt(psi_fac*sYe2/(this%td2(i)*this%mw(i))) + strial=sqrt(this%td2(i)*this%mw(i)/psi_fac) + this%lam_p(i)=this%lam_p(i)+(1.0_WP-beta)*(1.0_WP-decay)*strial*mu3i + end if + end if + do e=this%ptr(i),this%ptr(i+1)-1 + if (this%dmg(e).ne.0_1) cycle + j=this%lst(e) + zeta=sqrt(sum((this%x0(:,j)-this%x0(:,i))**2)) + dxv=this%y(:,j)-this%y(:,i) + dY=sqrt(sum(dxv**2)) + if (dY.le.0.0_WP) cycle + e_b=dY-zeta + ! Brittle break on total stretch (e > s0*zeta), irreversible. + ! Each row breaks its OWN half-entry and increments its OWN node's + ! damage by 1/nb0 (nb0 = reference row length); the counterpart row + ! breaks its half independently -- the criterion is symmetric in + ! the endpoints, so both halves break in the same substep (for + ! image bonds, up to shift-association roundoff: a 1-ulp-marginal + ! bond may break one substep apart, a benign local transient -- + ! the intact half still applies its +/- pair, conserving momentum). + if (e_b.gt.this%s0*zeta) then + this%dmg(e)=1_1 + this%damage(i)=this%damage(i)+1.0_WP/real(this%ptr(i+1)-this%ptr(i),WP) + cycle + end if + w=omega(zeta,this%delta) + ! Deviatoric split: e_d carries this HALF-ENTRY's inelastic stretch + ! e_v (per-side history: own theta, own mw -- Peridigm form; e_v=0 + ! recovers canonical elastic LPS bit-for-bit) + e_d=e_b-this%theta(i)*zeta/fdim + td=w/this%mw(i)*cdev*(e_d-this%visc_lambda*this%e_v(e)) + t =w/this%mw(i)*cvol*this%theta(i)*zeta+td + ! J2 family norm: pure own-row gather (no communication) + if (do_j2) this%td2a(i)=this%td2a(i)+td*td*this%vol(j) + ! Pair contribution from THIS row's force state (Peridigm volumes: + ! +t*V_j to self, -t*V_i to the neighbor) + fx=t*dxv/dY + this%f(:,i)=this%f(:,i)+fx*this%vol(j) + this%f(:,j)=this%f(:,j)-fx*this%vol(i) + ! Per-side viscoplastic flow of e_v (exact exponential). Two yield + ! criteria, as in amrpd: + ! sigma_yield>0: J2 radial return (per-node beta computed at the + ! row head above, incl. isotropic hardening), Perzyna- + ! regularized by (1-decay); tau->0 recovers Peridigm's + ! rate-independent return. + ! else: per-bond overstress (yield_stretch=0 -> pure Maxwell). + if (plastic) then + if (do_j2) then + this%e_v(e)=this%e_v(e)+(1.0_WP-beta)*(e_d-this%e_v(e))*(1.0_WP-decay) + else + e_e=e_d-this%e_v(e) + over=abs(e_e)-this%yield_stretch*zeta + if (over.gt.0.0_WP) this%e_v(e)=this%e_v(e)+sign(over*(1.0_WP-decay),e_e) + end if + end if + end do + end do + ! Publish this substep's J2 norm (read by the NEXT substep's return) + if (do_j2) then + this%td2(1:this%nown)=this%td2a(1:this%nown) + this%td2a(1:this%nown)=0.0_WP + end if + this%wt_force=this%wt_force+(parallel_time()-t0) + + ! Assemble cross-rank pair forces (halo slots -> owners, add) + t0=parallel_time() + call this%halo%reduce(this%f,3) + this%wt_reduce=this%wt_reduce+(parallel_time()-t0) + + ! Short-range contact (walls + particle-particle), gather-only: adds + ! into owned f, no reduction (amrpd ordering: after the bond force) + if (this%use_contact) then + t0=parallel_time() + call this%contact_narrow(dt) + this%wt_contact=this%wt_contact+(parallel_time()-t0) + end if + + ! Second half-kick with the fresh force + t0=parallel_time() + do i=1,this%nown + if (this%flag(i).eq.PDC_IS_DEAD) cycle + if (iand(this%flag(i),PDC_INTEGRATES).ne.0) then + acc=this%gravity+(this%f(:,i)+this%ff(:,i))*rho_inv + this%v(:,i)=(1.0_WP-this%damping_rate)*this%v(:,i)+0.5_WP*dt*acc + end if + if (this%collapsed(1)) this%v(1,i)=0.0_WP + if (this%collapsed(2)) this%v(2,i)=0.0_WP + if (this%collapsed(3)) this%v(3,i)=0.0_WP + end do + this%wt_kick=this%wt_kick+(parallel_time()-t0) + + this%tot_time=this%tot_time+(parallel_time()-t_full) + end subroutine pd_advance + + !> Contact broad phase: displacement-triggered rebuild of the contact halo + !> and the candidate CSR. The trigger is one scalar allreduce per substep so + !> the (collective) rebuild decision is rank-consistent. rbuild = + !> 1.2*contact_dist + 2*cskin: engagement reach is bounded by d_eff*(1+0.2) + !> (the r_influ clip) and two nodes drifting cskin each can close 2*cskin + !> between rebuilds, so the candidate set provably contains every pair that + !> can produce force before the next rebuild. + !> + !> Discovery: allgather of per-rank owned-node bounds; for each (rank, + !> periodic-image offset) whose shifted bounds approach mine within rbuild, + !> OFFER my owned nodes in range as (gid, image key, shifted position). The + !> receiver keeps offers with an owned node within rbuild (binned test) and + !> builds the contact halo from the kept references via the standard pdhalo + !> protocol (chalo%nown = ntot, so contact slots append after graph slots). + !> Candidates are then binned over OWNED + CONTACT slots only -- the graph + !> halo is never binned, so bonded remote partners arrive as contact slots + !> when in range and double-counting is structurally impossible. + subroutine contact_broadphase(this) + use parallel, only: comm,rank,nproc,MPI_REAL_WP + use mpi_f08 + use messager, only: die + implicit none + class(pdsolver), intent(inout) :: this + real(WP) :: rbuild,drift + integer :: i,ierr + + if (this%contact_dist.le.0.0_WP) call die('[pdsolver contact] use_contact requires contact_dist > 0') + if (this%cskin.le.0.0_WP) this%cskin=0.5_WP*this%contact_dist + rbuild=1.2_WP*this%contact_dist+2.0_WP*this%cskin + + ! Displacement trigger (collective decision) + if (allocated(this%ylast)) then + drift=0.0_WP + do i=1,this%nown + drift=max(drift,sum((this%y(:,i)-this%ylast(:,i))**2)) + end do + drift=sqrt(drift) + else + drift=huge(1.0_WP) + end if + call MPI_ALLREDUCE(MPI_IN_PLACE,drift,1,MPI_REAL_WP,MPI_MAX,comm,ierr) + if (drift.le.this%cskin) return + this%nrebuild=this%nrebuild+1_I8 + + rebuild: block + real(WP), dimension(3) :: bl,bh,shift,pos_s + real(WP), allocatable :: allb(:,:),opos(:,:),rpos(:,:),kpos(:,:) + integer(I8), allocatable :: ogid(:),rgid(:),kgid(:) + integer, allocatable :: okey(:),rkey(:),kkey(:),kowner(:),slot(:) + integer, dimension(0:nproc-1) :: sc,rc,sd,rd + integer, dimension(0:nproc-1) :: sc3,rc3,sd3,rd3 + integer :: nmax(3),d,r,n1,n2,n3,noff,nrecv,nkeep,k,pass + ! Binning workspace (owned nodes for offer filtering, then combined + ! set for the candidate CSR) + real(WP), dimension(3) :: gl,hcell + integer, dimension(3) :: nc + integer, allocatable :: head(:),nxt(:) + + ! Owned bounds and their global exchange + bl=huge(1.0_WP); bh=-huge(1.0_WP) + do i=1,this%nown + bl=min(bl,this%y(:,i)); bh=max(bh,this%y(:,i)) + end do + allocate(allb(6,0:nproc-1)) + call MPI_ALLGATHER([bl,bh],6,MPI_REAL_WP,allb,6,MPI_REAL_WP,comm,ierr) + + ! Admissible periodic-image offsets for contact range + do d=1,3 + nmax(d)=0 + if (this%per(d).and.this%Ldom(d).gt.0.0_WP) nmax(d)=min(4,int(rbuild/this%Ldom(d))+1) + end do + + ! Offers: two passes (count, then fill), grouped by destination rank + do pass=1,2 + sc=0 + do r=0,nproc-1 + do n3=-nmax(3),nmax(3); do n2=-nmax(2),nmax(2); do n1=-nmax(1),nmax(1) + if (r.eq.rank.and.n1.eq.0.and.n2.eq.0.and.n3.eq.0) cycle + shift=[real(n1,WP)*this%Ldom(1),real(n2,WP)*this%Ldom(2),real(n3,WP)*this%Ldom(3)] + ! Shifted-bounds proximity prefilter + if (any(bl+shift-rbuild.gt.allb(4:6,r)).or.any(bh+shift+rbuild.lt.allb(1:3,r))) cycle + do i=1,this%nown + if (this%flag(i).eq.PDC_IS_DEAD) cycle + pos_s=this%y(:,i)+shift + if (any(pos_s.lt.allb(1:3,r)-rbuild).or.any(pos_s.gt.allb(4:6,r)+rbuild)) cycle + sc(r)=sc(r)+1 + if (pass.eq.2) then + ogid(sd(r)+sc(r))=this%gid(i) + okey(sd(r)+sc(r))=(n1+128)+(n2+128)*256+(n3+128)*65536 + opos(:,sd(r)+sc(r))=pos_s + end if + end do + end do; end do; end do + end do + if (pass.eq.1) then + sd(0)=0 + do r=1,nproc-1 + sd(r)=sd(r-1)+sc(r-1) + end do + noff=sum(sc) + allocate(ogid(max(noff,1)),okey(max(noff,1)),opos(3,max(noff,1))) + end if + end do + + ! Exchange offers (gid, key, shifted position) + call MPI_ALLTOALL(sc,1,MPI_INTEGER,rc,1,MPI_INTEGER,comm,ierr) + rd(0)=0 + do r=1,nproc-1 + rd(r)=rd(r-1)+rc(r-1) + end do + nrecv=sum(rc) + allocate(rgid(max(nrecv,1)),rkey(max(nrecv,1)),rpos(3,max(nrecv,1))) + call MPI_ALLTOALLV(ogid,sc,sd,MPI_INTEGER8,rgid,rc,rd,MPI_INTEGER8,comm,ierr) + call MPI_ALLTOALLV(okey,sc,sd,MPI_INTEGER, rkey,rc,rd,MPI_INTEGER, comm,ierr) + sc3=3*sc; sd3=3*sd; rc3=3*rc; rd3=3*rd + call MPI_ALLTOALLV(opos,sc3,sd3,MPI_REAL_WP,rpos,rc3,rd3,MPI_REAL_WP,comm,ierr) + deallocate(ogid,okey,opos) + + ! Filter offers: keep those with an owned node within rbuild. + ! Bin owned nodes (cell size >= rbuild so a +/-1 cell sweep suffices; + ! dims clamped so degenerate/huge extents stay bounded). + call setup_bins(bl,bh,rbuild,gl,hcell,nc) + allocate(head(nc(1)*nc(2)*nc(3)),nxt(max(this%nown,1))) + head=0 + do i=1,this%nown + if (this%flag(i).eq.PDC_IS_DEAD) cycle + k=cell_of(this%y(:,i),gl,hcell,nc) + nxt(i)=head(k); head(k)=i + end do + allocate(kgid(max(nrecv,1)),kkey(max(nrecv,1)),kowner(max(nrecv,1)),kpos(3,max(nrecv,1))) + nkeep=0 + do r=0,nproc-1 + do i=rd(r)+1,rd(r)+rc(r) + if (near_owned(rpos(:,i),rbuild,gl,hcell,nc,head,nxt)) then + nkeep=nkeep+1 + kgid(nkeep)=rgid(i); kkey(nkeep)=rkey(i); kowner(nkeep)=r; kpos(:,nkeep)=rpos(:,i) + end if + end do + end do + deallocate(rgid,rkey,rpos,head,nxt) + + ! Rebuild the contact halo (slots append after graph slots: nown=ntot) + call this%chalo%finalize() + allocate(slot(max(nkeep,1))) + call this%chalo%build(this%ntot,this%ohash,nkeep,kgid,kkey,kowner,this%Ldom,this%per,slot) + this%nchalo=this%chalo%nhalo + + ! Extend y and v to cover contact slots; stamp slot positions from the + ! kept offers (current values -- chalo%update refreshes each substep) + resize_state: block + real(WP), allocatable :: a2(:,:) + integer :: ntc + ntc=this%ntot+this%nchalo + allocate(a2(3,max(ntc,1))); a2=0.0_WP + a2(:,1:this%ntot)=this%y(:,1:this%ntot) + call move_alloc(a2,this%y) + allocate(a2(3,max(ntc,1))); a2=0.0_WP + a2(:,1:this%nown)=this%v(:,1:this%nown) + call move_alloc(a2,this%v) + do k=1,nkeep + this%y(:,this%ntot+slot(k))=kpos(:,k) + end do + end block resize_state + deallocate(kgid,kkey,kowner,kpos,slot) + + ! Candidate CSR over the contact-visible set: owned nodes (indices + ! 1..nown) + contact slots (ntot+1..ntot+nchalo). Two passes. + candidates: block + integer :: ns,m,jj,cnt,ic,jc,kc,c1,c2,c3 + integer, allocatable :: midx(:) + real(WP), dimension(3) :: blc,bhc + ns=this%nown+this%nchalo + allocate(midx(max(ns,1))) + do m=1,this%nown + midx(m)=m + end do + do m=1,this%nchalo + midx(this%nown+m)=this%ntot+m + end do + blc=bl; bhc=bh + do m=this%nown+1,ns + blc=min(blc,this%y(:,midx(m))); bhc=max(bhc,this%y(:,midx(m))) + end do + call setup_bins(blc,bhc,rbuild,gl,hcell,nc) + allocate(head(nc(1)*nc(2)*nc(3)),nxt(max(ns,1))) + head=0 + do m=1,ns + if (m.le.this%nown) then + if (this%flag(m).eq.PDC_IS_DEAD) cycle + end if + k=cell_of(this%y(:,midx(m)),gl,hcell,nc) + nxt(m)=head(k); head(k)=m + end do + if (allocated(this%cptr)) deallocate(this%cptr) + if (allocated(this%clst)) deallocate(this%clst) + allocate(this%cptr(this%nown+1)) + do pass=1,2 + do i=1,this%nown + cnt=0 + if (this%flag(i).eq.PDC_IS_DEAD) then + if (pass.eq.1) this%cptr(i+1)=0 + cycle + end if + ic=min(nc(1),max(1,int((this%y(1,i)-gl(1))/hcell(1))+1)) + jc=min(nc(2),max(1,int((this%y(2,i)-gl(2))/hcell(2))+1)) + kc=min(nc(3),max(1,int((this%y(3,i)-gl(3))/hcell(3))+1)) + do c3=max(1,kc-1),min(nc(3),kc+1); do c2=max(1,jc-1),min(nc(2),jc+1); do c1=max(1,ic-1),min(nc(1),ic+1) + m=head(c1+nc(1)*(c2-1)+nc(1)*nc(2)*(c3-1)) + do while (m.gt.0) + jj=midx(m) + if (jj.ne.i) then + if (sum((this%y(:,jj)-this%y(:,i))**2).le.rbuild**2) then + cnt=cnt+1 + if (pass.eq.2) this%clst(this%cptr(i)+cnt-1)=jj + end if + end if + m=nxt(m) + end do + end do; end do; end do + if (pass.eq.1) this%cptr(i+1)=cnt ! provisional count + end do + if (pass.eq.1) then + this%cptr(1)=1 + do i=1,this%nown + this%cptr(i+1)=this%cptr(i)+this%cptr(i+1) + end do + allocate(this%clst(max(this%cptr(this%nown+1)-1,1))) + end if + end do + deallocate(midx,head,nxt) + end block candidates + + ! Snapshot positions for the drift trigger + if (allocated(this%ylast)) deallocate(this%ylast) + allocate(this%ylast(3,max(this%nown,1))) + this%ylast(:,1:this%nown)=this%y(:,1:this%nown) + deallocate(allb) + end block rebuild + + contains + + !> Any owned node within r of position p? (binned +/-1 cell sweep) + function near_owned(p,r,gl,h,nc,head,nxt) result(hit) + real(WP), dimension(3), intent(in) :: p,gl,h + real(WP), intent(in) :: r + integer, dimension(3), intent(in) :: nc + integer, intent(in) :: head(:),nxt(:) + logical :: hit + integer :: c(3),d,c1,c2,c3,m + hit=.false. + do d=1,3 + c(d)=min(nc(d),max(1,int((p(d)-gl(d))/h(d))+1)) + end do + do c3=max(1,c(3)-1),min(nc(3),c(3)+1); do c2=max(1,c(2)-1),min(nc(2),c(2)+1); do c1=max(1,c(1)-1),min(nc(1),c(1)+1) + m=head(c1+nc(1)*(c2-1)+nc(1)*nc(2)*(c3-1)) + do while (m.gt.0) + if (sum((this%y(:,m)-p)**2).le.r**2) then + hit=.true. + return + end if + m=nxt(m) + end do + end do; end do; end do + end function near_owned + + end subroutine contact_broadphase + + !> Contact narrow phase: soft-sphere walls + particle-particle over the + !> candidate CSR, gather-only (soft-sphere penalty ported from amrlpt's collision model; + !> IB contact arrives with the coupling layer). Adds force/volume into owned + !> f. Walls use e_w with d_eff = 0.5*contact_dist and m_eff = m1; pairs use + !> e_n with d_eff = contact_dist and m_eff = 0.5*m1 (m1 = rho*vol(i), + !> matching amrpd's uniform rho*dV on a uniform lattice). + subroutine contact_narrow(this,dt) + use mathtools, only: Pi + implicit none + class(pdsolver), intent(inout) :: this + real(WP), intent(in) :: dt + real(WP) :: tau,k_n,eta_n,k_w,eta_w,d_eff_w,m1 + real(WP), dimension(3) :: r1,v1,floc,r2 + real(WP), dimension(3), parameter :: vzero=[0.0_WP,0.0_WP,0.0_WP] + integer :: i,k,j + if (this%contact_dist.le.0.0_WP.or.dt.le.0.0_WP) return + if (this%e_n.le.0.0_WP.or.this%e_w.le.0.0_WP) return + if (this%tau_col.gt.0.0_WP) then + tau=this%tau_col + else + tau=5.0_WP*dt + end if + k_n =(Pi**2+log(this%e_n)**2)/tau**2 + eta_n=-2.0_WP*log(this%e_n)/tau + k_w =(Pi**2+log(this%e_w)**2)/tau**2 + eta_w=-2.0_WP*log(this%e_w)/tau + d_eff_w=0.5_WP*this%contact_dist + do i=1,this%nown + if (this%flag(i).eq.PDC_IS_DEAD) cycle + m1=this%rho*this%vol(i) + r1=this%y(:,i); v1=this%v(:,i) + floc=0.0_WP + ! Wall collisions on faces flagged as walls (virtual partner on the + ! wall directly normal to the node) + if (this%lo_bc(1).eq.1) then; r2=[this%dom_lo(1),r1(2),r1(3)]; call apply_col(k_w,eta_w,d_eff_w,m1,r2,vzero); end if + if (this%hi_bc(1).eq.1) then; r2=[this%dom_hi(1),r1(2),r1(3)]; call apply_col(k_w,eta_w,d_eff_w,m1,r2,vzero); end if + if (this%lo_bc(2).eq.1) then; r2=[r1(1),this%dom_lo(2),r1(3)]; call apply_col(k_w,eta_w,d_eff_w,m1,r2,vzero); end if + if (this%hi_bc(2).eq.1) then; r2=[r1(1),this%dom_hi(2),r1(3)]; call apply_col(k_w,eta_w,d_eff_w,m1,r2,vzero); end if + if (this%lo_bc(3).eq.1) then; r2=[r1(1),r1(2),this%dom_lo(3)]; call apply_col(k_w,eta_w,d_eff_w,m1,r2,vzero); end if + if (this%hi_bc(3).eq.1) then; r2=[r1(1),r1(2),this%dom_hi(3)]; call apply_col(k_w,eta_w,d_eff_w,m1,r2,vzero); end if + ! Particle-particle via the candidate CSR + do k=this%cptr(i),this%cptr(i+1)-1 + j=this%clst(k) + call apply_col(k_n,eta_n,this%contact_dist,0.5_WP*m1,this%y(:,j),this%v(:,j)) + end do + ! Accumulate as force/volume (matches bond force units) + this%f(:,i)=this%f(:,i)+floc/this%vol(i) + end do + + contains + + !> Soft-sphere normal force from virtual partner (r2_in, v2_in) onto i. + !> Host-associated r1, v1, dt, floc. + subroutine apply_col(kk,ee,d_eff,m_eff,r2_in,v2_in) + real(WP), intent(in) :: kk,ee,d_eff,m_eff + real(WP), dimension(3), intent(in) :: r2_in,v2_in + real(WP) :: d12,rnv,r_influ,delta_n + real(WP), dimension(3) :: n12,v12,f_n + d12=norm2(r2_in-r1) + if (d12.lt.10.0_WP*epsilon(d12)) return ! self-overlap guard + n12=(r2_in-r1)/d12 + v12=v1-v2_in + rnv=dot_product(v12,n12) + r_influ=min(abs(rnv)*dt,0.2_WP*d_eff) + delta_n=min(d_eff+r_influ-d12,this%clip_col*d_eff) + if (delta_n.le.0.0_WP) return + f_n=(-m_eff*kk*delta_n-m_eff*ee*rnv)*n12 + floc=floc+f_n + end subroutine apply_col + + end subroutine contact_narrow + + !> Binding CFL: elastic wave + scaled convective (limits 0.5 / 0.1) + subroutine get_cfl(this,dt,cfl) + use parallel, only: comm,MPI_REAL_WP + use mpi_f08, only: MPI_ALLREDUCE,MPI_MAX,MPI_IN_PLACE + implicit none + class(pdsolver), intent(inout) :: this + real(WP), intent(in) :: dt + real(WP), intent(out) :: cfl + real(WP), parameter :: CFL_scale_conv=5.0_WP + real(WP) :: K_bulk,mu_shear,c_p,dp_inv,vmax + integer :: i,ierr + K_bulk =this%elastic_modulus/(3.0_WP*(1.0_WP-2.0_WP*this%poisson_ratio)) + mu_shear=this%elastic_modulus/(2.0_WP*(1.0_WP+this%poisson_ratio)) + c_p =sqrt((K_bulk+4.0_WP*mu_shear/3.0_WP)/this%rho) + dp_inv =1.0_WP/this%dV**(1.0_WP/3.0_WP) + this%CFLe=c_p*dp_inv*dt + this%CFLp=0.0_WP + do i=1,this%nown + if (this%flag(i).eq.PDC_IS_DEAD) cycle + vmax=max(abs(this%v(1,i)),abs(this%v(2,i)),abs(this%v(3,i))) + this%CFLp=max(this%CFLp,vmax*dp_inv) + end do + call MPI_ALLREDUCE(MPI_IN_PLACE,this%CFLp,1,MPI_REAL_WP,MPI_MAX,comm,ierr) + this%CFLp=this%CFLp*dt + cfl=max(CFL_scale_conv*this%CFLp,this%CFLe) + end subroutine get_cfl + + !> Global counts, velocity max, and timer reduction (+reset). Collective. + subroutine get_info(this) + use parallel, only: comm,MPI_REAL_WP + use mpi_f08, only: MPI_ALLREDUCE,MPI_MAX,MPI_MIN,MPI_SUM,MPI_IN_PLACE,MPI_INTEGER8 + implicit none + class(pdsolver), intent(inout) :: this + integer :: i,ierr + integer(I8) :: np_loc + real(WP), dimension(3) :: vmin,vmax + np_loc=0_I8 + vmin=huge(1.0_WP); vmax=-huge(1.0_WP) + this%EPmax=0.0_WP + do i=1,this%nown + if (this%flag(i).eq.PDC_IS_DEAD) cycle + np_loc=np_loc+1_I8 + vmin=min(vmin,this%v(:,i)); vmax=max(vmax,this%v(:,i)) + this%EPmax=max(this%EPmax,this%lam_p(i)) + end do + this%np=np_loc + call MPI_ALLREDUCE(MPI_IN_PLACE,this%np,1,MPI_INTEGER8,MPI_SUM,comm,ierr) + call MPI_ALLREDUCE(MPI_IN_PLACE,this%EPmax,1,MPI_REAL_WP,MPI_MAX,comm,ierr) + call MPI_ALLREDUCE(MPI_IN_PLACE,vmin,3,MPI_REAL_WP,MPI_MIN,comm,ierr) + call MPI_ALLREDUCE(MPI_IN_PLACE,vmax,3,MPI_REAL_WP,MPI_MAX,comm,ierr) + if (this%np.eq.0_I8) then + vmin=0.0_WP; vmax=0.0_WP + end if + this%Umin=vmin(1); this%Umax=vmax(1) + this%Vmin=vmin(2); this%Vmax=vmax(2) + this%Wmin=vmin(3); this%Wmax=vmax(3) + ! Broken half-entry census (each broken bond counts twice, except + ! self-image bonds which have a single half-entry) + count_broken: block + integer(I8) :: nb_loc + integer :: e,i2,j2 + ! Half-entry count (internal) and EXACT broken-bond census: each bond + ! is counted at exactly one of its two half-entries -- the one whose + ! node gid is lower (ties = self-image bonds, counted at the + ! positive-offset image so each appears once) + nb_loc=0_I8; this%nb_broken=0_I8 + do i2=1,this%nown + do e=this%ptr(i2),this%ptr(i2+1)-1 + if (this%dmg(e).eq.0_1) cycle + nb_loc=nb_loc+1_I8 + j2=this%lst(e) + if (this%gid(i2).lt.this%gid(j2)) then + this%nb_broken=this%nb_broken+1_I8 + else if (this%gid(i2).eq.this%gid(j2)) then + if (j2.gt.this%nown) then + if (shift_positive(this%halo%shift(:,j2-this%nown))) this%nb_broken=this%nb_broken+1_I8 + end if + end if + end do + end do + this%nbroken=nb_loc + call MPI_ALLREDUCE(MPI_IN_PLACE,this%nbroken,1,MPI_INTEGER8,MPI_SUM,comm,ierr) + call MPI_ALLREDUCE(MPI_IN_PLACE,this%nb_broken,1,MPI_INTEGER8,MPI_SUM,comm,ierr) + end block count_broken + ! Timers: max (and min for the compute-heavy phases) across ranks, then reset + call MPI_ALLREDUCE(this%wt_kick, this%wtmax_kick, 1,MPI_REAL_WP,MPI_MAX,comm,ierr) + call MPI_ALLREDUCE(this%wt_halo, this%wtmax_halo, 1,MPI_REAL_WP,MPI_MAX,comm,ierr) + call MPI_ALLREDUCE(this%wt_dil, this%wtmax_dil, 1,MPI_REAL_WP,MPI_MAX,comm,ierr) + call MPI_ALLREDUCE(this%wt_dil, this%wtmin_dil, 1,MPI_REAL_WP,MPI_MIN,comm,ierr) + call MPI_ALLREDUCE(this%wt_force, this%wtmax_force, 1,MPI_REAL_WP,MPI_MAX,comm,ierr) + call MPI_ALLREDUCE(this%wt_force, this%wtmin_force, 1,MPI_REAL_WP,MPI_MIN,comm,ierr) + call MPI_ALLREDUCE(this%wt_reduce,this%wtmax_reduce,1,MPI_REAL_WP,MPI_MAX,comm,ierr) + call MPI_ALLREDUCE(this%wt_contact,this%wtmax_contact,1,MPI_REAL_WP,MPI_MAX,comm,ierr) + call MPI_ALLREDUCE(this%wt_broad, this%wtmax_broad, 1,MPI_REAL_WP,MPI_MAX,comm,ierr) + call MPI_ALLREDUCE(this%tot_time, this%maxtot_time, 1,MPI_REAL_WP,MPI_MAX,comm,ierr) + + this%wt_kick=0.0_WP; this%wt_halo=0.0_WP; this%wt_dil=0.0_WP; this%wt_force=0.0_WP; this%wt_reduce=0.0_WP + this%wt_contact=0.0_WP; this%wt_broad=0.0_WP; this%tot_time=0.0_WP + ! Contact-service size census (visibility into the fragmentation-driven + ! degradation mode of the static graph partition) + contact_census: block + integer(I8) :: tmp + this%nchalo_glob=int(this%nchalo,I8) + call MPI_ALLREDUCE(MPI_IN_PLACE,this%nchalo_glob,1,MPI_INTEGER8,MPI_SUM,comm,ierr) + tmp=0_I8 + if (allocated(this%cptr)) tmp=int(this%cptr(this%nown+1)-1,I8) + this%ncand_glob=tmp + call MPI_ALLREDUCE(MPI_IN_PLACE,this%ncand_glob,1,MPI_INTEGER8,MPI_SUM,comm,ierr) + end block contact_census + end subroutine get_info + + !> Release all storage + subroutine finalize(this) + implicit none + class(pdsolver), intent(inout) :: this + if (allocated(this%gid)) deallocate(this%gid) + if (allocated(this%x0)) deallocate(this%x0) + if (allocated(this%y)) deallocate(this%y) + if (allocated(this%v)) deallocate(this%v) + if (allocated(this%f)) deallocate(this%f) + if (allocated(this%ff)) deallocate(this%ff) + if (allocated(this%vol)) deallocate(this%vol) + if (allocated(this%mw)) deallocate(this%mw) + if (allocated(this%theta)) deallocate(this%theta) + if (allocated(this%damage))deallocate(this%damage) + if (allocated(this%lam_p)) deallocate(this%lam_p) + if (allocated(this%alive)) deallocate(this%alive) + if (allocated(this%flag)) deallocate(this%flag) + if (allocated(this%ptr)) deallocate(this%ptr) + if (allocated(this%lst)) deallocate(this%lst) + if (allocated(this%dmg)) deallocate(this%dmg) + if (allocated(this%e_v)) deallocate(this%e_v) + if (allocated(this%td2)) deallocate(this%td2) + if (allocated(this%td2a)) deallocate(this%td2a) + if (allocated(this%cptr)) deallocate(this%cptr) + if (allocated(this%clst)) deallocate(this%clst) + if (allocated(this%ylast)) deallocate(this%ylast) + if (allocated(this%rextra_tmp)) deallocate(this%rextra_tmp) + call this%ohash%finalize() + call this%dir%finalize() + call this%halo%finalize() + call this%chalo%finalize() + this%nown=0; this%nhalo=0; this%ntot=0; this%nchalo=0 + end subroutine finalize + + + !> Mirror synchronization (the coupling bridge). Collective, once per FLUID + !> step. The caller walks its face particles (AMReX container on the + !> fluid decomposition) and passes per particle: gid, core owner rank (read + !> from the face particle's repurposed flag tag), and the F_fluid it interpolated + !> from the grid. This routine routes F_fluid to the owning nodes (held in + !> ff across the subsequent PD subcycles) and replies with each node's + !> current (pos, vel, damage, alive), returned aligned with the caller's + !> input order for direct write-back into the face particles. + subroutine exchange(this,nm,mgid,mowner,mff,mpos,mvel,mdmg,malive) + use parallel, only: comm,nproc,MPI_REAL_WP + use messager, only: die + use mpi_f08 + implicit none + class(pdsolver), intent(inout) :: this + integer, intent(in) :: nm + integer(I8), intent(in) :: mgid(:) + integer, intent(in) :: mowner(:) + real(WP), intent(in) :: mff(:,:) + real(WP), intent(out) :: mpos(:,:),mvel(:,:) + real(WP), intent(out) :: mdmg(:),malive(:) + integer, dimension(0:nproc-1) :: sc,rc,sd,rd + integer, dimension(0:nproc-1) :: scw,rcw,sdw,rdw + integer, allocatable :: pos(:),qpos(:) + integer(I8), allocatable :: sg(:),rg(:) + real(WP), allocatable :: sff(:,:),rff(:,:),srep(:,:),rrep(:,:) + integer :: i,r,nr,idx,ierr + + ! Count and pack by owner, remembering each entry's packed slot + sc=0 + do i=1,nm + sc(mowner(i))=sc(mowner(i))+1 + end do + call MPI_ALLTOALL(sc,1,MPI_INTEGER,rc,1,MPI_INTEGER,comm,ierr) + sd(0)=0; rd(0)=0 + do r=1,nproc-1 + sd(r)=sd(r-1)+sc(r-1); rd(r)=rd(r-1)+rc(r-1) + end do + allocate(pos(0:nproc-1),qpos(max(nm,1))) + allocate(sg(max(nm,1)),sff(3,max(nm,1))) + pos=sd + do i=1,nm + r=mowner(i); pos(r)=pos(r)+1 + sg(pos(r))=mgid(i); sff(:,pos(r))=mff(:,i); qpos(i)=pos(r) + end do + nr=sum(rc) + allocate(rg(max(nr,1)),rff(3,max(nr,1))) + call MPI_ALLTOALLV(sg,sc,sd,MPI_INTEGER8,rg,rc,rd,MPI_INTEGER8,comm,ierr) + scw=3*sc; sdw=3*sd; rcw=3*rc; rdw=3*rd + call MPI_ALLTOALLV(sff,scw,sdw,MPI_REAL_WP,rff,rcw,rdw,MPI_REAL_WP,comm,ierr) + + ! Owner side: ingest F_fluid, build the state reply in arrival order + allocate(rrep(8,max(nr,1))) + do i=1,nr + idx=this%ohash%lookup(rg(i)) + if (idx.lt.1) call die('[pdsolver exchange] face gid not owned by tagged rank') + this%ff(:,idx)=rff(:,i) + rrep(1:3,i)=this%y(:,idx) + rrep(4:6,i)=this%v(:,idx) + rrep(7,i) =this%damage(idx) + rrep(8,i) =this%alive(idx) + end do + + ! Reply along the reverse route; unpack to the caller's original order + allocate(srep(8,max(nm,1))) + scw=8*rc; sdw=8*rd; rcw=8*sc; rdw=8*sd + call MPI_ALLTOALLV(rrep,scw,sdw,MPI_REAL_WP,srep,rcw,rdw,MPI_REAL_WP,comm,ierr) + do i=1,nm + mpos(:,i) =srep(1:3,qpos(i)) + mvel(:,i) =srep(4:6,qpos(i)) + mdmg(i) =srep(7,qpos(i)) + malive(i) =srep(8,qpos(i)) + end do + deallocate(pos,qpos,sg,sff,rg,rff,rrep,srep) + end subroutine exchange + + + !> Owner-rank lookup for arbitrary node gids via the persistent directory. + !> Collective. Drivers use it to re-stamp face routing tags after restart. + subroutine query_owners(this,n,gids,owners) + implicit none + class(pdsolver), intent(inout) :: this + integer, intent(in) :: n + integer(I8), intent(in) :: gids(:) + integer, intent(out) :: owners(:) + call this%dir%query(n,gids,owners) + end subroutine query_owners + + !> Checkpoint the core under /: per-rank stream files + root + !> header. Records are GID-SPACE (no local indices, no partition info) -- + !> nodes: (gid, flag, x0, y, v, f, vol, damage, td2, lam_p); half-entries: + !> (node_gid, nbr_gid, image_key, dmg, e_v), the image key reconstructed + !> from the halo slot's shift. Rank-count portable on read. Format v2 + !> (v1 = pre-hardening, no lam_p record; read_state accepts both). + subroutine write_state(this,dirname) + use parallel, only: rank,nproc,amRoot + use messager, only: die + use string, only: str_medium + implicit none + class(pdsolver), intent(inout) :: this + character(len=*), intent(in) :: dirname + character(len=str_medium) :: fname + integer :: iunit,ios,i,e,j,nhe + integer, allocatable :: hkey(:) + integer(I8), allocatable :: hnode(:),hnbr(:) + ! Half-entries in gid space + nhe=this%ptr(this%nown+1)-1 + allocate(hnode(max(nhe,1)),hnbr(max(nhe,1)),hkey(max(nhe,1))) + do i=1,this%nown + do e=this%ptr(i),this%ptr(i+1)-1 + j=this%lst(e) + hnode(e)=this%gid(i) + hnbr(e) =this%gid(j) + if (j.le.this%nown) then + hkey(e)=PDHALO_KEY0 + else + hkey(e)=key_of_shift(this%halo%shift(:,j-this%nown),this%Ldom) + end if + end do + end do + ! Per-rank stream file + ! All solid state lives under /pd/ (root creates it) + make_dir: block + use parallel, only: comm + use mpi_f08, only: MPI_BARRIER + integer :: ierr2 + if (amRoot) call execute_command_line('mkdir -p '//trim(dirname)//'/pd') + call MPI_BARRIER(comm,ierr2) + end block make_dir + write(fname,'(a,"/pd/pd_",i7.7,".bin")') trim(dirname),rank + open(newunit=iunit,file=trim(fname),form='unformatted',access='stream',status='replace',iostat=ios) + if (ios.ne.0) call die('[pdsolver write_state] cannot open '//trim(fname)) + write(iunit) this%nown,nhe + write(iunit) this%gid(1:this%nown) + write(iunit) this%flag(1:this%nown) + write(iunit) this%x0(:,1:this%nown) + write(iunit) this%y(:,1:this%nown) + write(iunit) this%v(:,1:this%nown) + write(iunit) this%f(:,1:this%nown) + write(iunit) this%vol(1:this%nown) + write(iunit) this%damage(1:this%nown) + write(iunit) this%td2(1:this%nown) + write(iunit) this%lam_p(1:this%nown) + write(iunit) hnode(1:nhe) + write(iunit) hnbr(1:nhe) + write(iunit) hkey(1:nhe) + write(iunit) this%dmg(1:nhe) + write(iunit) this%e_v(1:nhe) + close(iunit) + deallocate(hnode,hnbr,hkey) + ! Root header (file count for portable round-robin reads) + if (amRoot) then + open(newunit=iunit,file=trim(dirname)//'/pd/header',form='formatted',status='replace',iostat=ios) + if (ios.ne.0) call die('[pdsolver write_state] cannot open header') + write(iunit,'(a)') 'pdsolver checkpoint v2' + write(iunit,'(i0)') nproc + close(iunit) + end if + contains + !> Reconstruct the packed image key from a slot shift vector + pure function key_of_shift(s,L) result(k) + implicit none + real(WP), dimension(3), intent(in) :: s,L + integer :: k,n1,n2,n3 + n1=0; n2=0; n3=0 + if (L(1).gt.0.0_WP) n1=nint(s(1)/L(1)) + if (L(2).gt.0.0_WP) n2=nint(s(2)/L(2)) + if (L(3).gt.0.0_WP) n3=nint(s(3)/L(3)) + k=(n1+128)+(n2+128)*256+(n3+128)*65536 + end function key_of_shift + end subroutine write_state + + !> Restore the core from a checkpoint written by write_state. Collective; + !> rank-count portable: files read round-robin, nodes re-partitioned by + !> Morton order of the reference configuration, half-entries routed to + !> their owners, CSR/halo rebuilt via assemble with the loaded per-entry + !> state. The caller must configure the solver (initialize + material/ + !> contact/plastic component assignments) BEFORE calling this. + subroutine read_state(this,dirname) + use parallel, only: comm,rank,nproc,MPI_REAL_WP + use messager, only: die + use string, only: str_medium + use mpi_f08 + implicit none + class(pdsolver), intent(inout) :: this + character(len=*), intent(in) :: dirname + character(len=str_medium) :: fname,line + integer :: nfiles,iunit,ios,f,i,r,ierr,iver + integer :: nn,nhe,nf,nhf + integer(I8), allocatable :: gid(:),hnode(:),hnbr(:) + integer, allocatable :: flag(:),hkey(:),owner(:) + real(WP), allocatable :: x0(:,:),yy(:,:),vv(:,:),ffb(:,:),vol(:),dmgn(:),td2n(:),lamn(:) + real(WP), allocatable :: hev(:) + integer(1), allocatable :: hdmg(:) + + ! Resolve derived configuration (restart-safe shared path) + call this%derive_config() + + ! Header: number of files written + format version (v1 = no lam_p record) + nfiles=0; iver=1 + if (rank.eq.0) then + open(newunit=iunit,file=trim(dirname)//'/pd/header',form='formatted',status='old',iostat=ios) + if (ios.ne.0) call die('[pdsolver read_state] no pd/header under '//trim(dirname)) + read(iunit,'(a)') line + if (index(line,'v2').gt.0) iver=2 + read(iunit,*) nfiles + close(iunit) + end if + call MPI_BCAST(nfiles,1,MPI_INTEGER,0,comm,ierr) + call MPI_BCAST(iver,1,MPI_INTEGER,0,comm,ierr) + + ! Read my round-robin share of the files, concatenating records + nn=0; nhe=0 + do f=rank,nfiles-1,nproc + write(fname,'(a,"/pd/pd_",i7.7,".bin")') trim(dirname),f + open(newunit=iunit,file=trim(fname),form='unformatted',access='stream',status='old',iostat=ios) + if (ios.ne.0) call die('[pdsolver read_state] cannot open '//trim(fname)) + read(iunit) nf,nhf + call grow_i8(gid,nn,nf); call grow_i4(flag,nn,nf) + call grow_r2(x0,nn,nf); call grow_r2(yy,nn,nf) + call grow_r2(vv,nn,nf); call grow_r2(ffb,nn,nf) + call grow_r1(vol,nn,nf); call grow_r1(dmgn,nn,nf); call grow_r1(td2n,nn,nf) + call grow_r1(lamn,nn,nf) + read(iunit) gid(nn+1:nn+nf) + read(iunit) flag(nn+1:nn+nf) + read(iunit) x0(:,nn+1:nn+nf) + read(iunit) yy(:,nn+1:nn+nf) + read(iunit) vv(:,nn+1:nn+nf) + read(iunit) ffb(:,nn+1:nn+nf) + read(iunit) vol(nn+1:nn+nf) + read(iunit) dmgn(nn+1:nn+nf) + read(iunit) td2n(nn+1:nn+nf) + if (iver.ge.2) then + read(iunit) lamn(nn+1:nn+nf) + else + lamn(nn+1:nn+nf)=0.0_WP + end if + call grow_i8(hnode,nhe,nhf); call grow_i8(hnbr,nhe,nhf) + call grow_i4(hkey,nhe,nhf); call grow_i1(hdmg,nhe,nhf); call grow_r1(hev,nhe,nhf) + read(iunit) hnode(nhe+1:nhe+nhf) + read(iunit) hnbr(nhe+1:nhe+nhf) + read(iunit) hkey(nhe+1:nhe+nhf) + read(iunit) hdmg(nhe+1:nhe+nhf) + read(iunit) hev(nhe+1:nhe+nhf) + close(iunit) + nn=nn+nf; nhe=nhe+nhf + end do + if (.not.allocated(gid)) then ! ranks with no files still join collectives + allocate(gid(1),flag(1),x0(3,1),yy(3,1),vv(3,1),ffb(3,1),vol(1),dmgn(1),td2n(1),lamn(1)) + allocate(hnode(1),hnbr(1),hkey(1),hdmg(1),hev(1)) + end if + + ! Re-partition nodes by Morton order of the REFERENCE configuration and + ! route the full records (pd_partition routes the set_nodes payload; the + ! remaining fields ride a second, identically-ordered exchange) + repartition: block + integer(I8), allocatable :: rgid(:) + real(WP), allocatable :: rx0(:,:),rvv(:,:),rvol(:),extra(:,:) + integer, allocatable :: rflag(:) + integer, dimension(0:nproc-1) :: sc,rc,sd,rd,scw,rcw,sdw,rdw + integer, allocatable :: pos(:) + integer :: nr + allocate(owner(max(nn,1))) + call pd_partition(nn,gid,x0,vv,flag,vol,owner,nr,rgid,rx0,rvv,rflag,rvol) + ! Second exchange: (y, f, damage, td2) = 8 reals, packed in the same + ! per-destination input order as pd_partition's own packing + sc=0 + do i=1,nn + sc(owner(i))=sc(owner(i))+1 + end do + call MPI_ALLTOALL(sc,1,MPI_INTEGER,rc,1,MPI_INTEGER,comm,ierr) + sd(0)=0; rd(0)=0 + do r=1,nproc-1 + sd(r)=sd(r-1)+sc(r-1); rd(r)=rd(r-1)+rc(r-1) + end do + allocate(pos(0:nproc-1),extra(9,max(nn,1)),this%rextra_tmp(9,max(nr,1))) + pos=sd + do i=1,nn + r=owner(i); pos(r)=pos(r)+1 + extra(1:3,pos(r))=yy(:,i) + extra(4:6,pos(r))=ffb(:,i) + extra(7,pos(r)) =dmgn(i) + extra(8,pos(r)) =td2n(i) + extra(9,pos(r)) =lamn(i) + end do + scw=9*sc; sdw=9*sd; rcw=9*rc; rdw=9*rd + call MPI_ALLTOALLV(extra,scw,sdw,MPI_REAL_WP,this%rextra_tmp,rcw,rdw,MPI_REAL_WP,comm,ierr) + ! Load the routed nodes, then overlay the restart-only fields + call this%set_nodes(nr,rgid,rx0,rvv,rflag,rvol) + do i=1,nr + this%y(:,i) =this%rextra_tmp(1:3,i) + this%f(:,i) =this%rextra_tmp(4:6,i) + this%damage(i)=this%rextra_tmp(7,i) + end do + deallocate(pos,extra,rgid,rx0,rvv,rflag,rvol) + end block repartition + + ! Register the directory over the new partition, route half-entries to + ! their owners (state travels along), and rebuild CSR/halo/reference + route_and_assemble: block + integer(I8), allocatable :: rnode(:),rnbr(:) + integer, allocatable :: rkey(:),howner(:) + real(WP), allocatable :: rev(:) + integer(1), allocatable :: rdmg(:) + integer, dimension(0:nproc-1) :: sc,rc,sd,rd + integer, allocatable :: pos(:) + integer(I8), allocatable :: s8(:) + integer, allocatable :: s4(:) + real(WP), allocatable :: sr(:) + integer(1), allocatable :: s1(:) + integer :: rn,h + call this%dir%finalize() + call this%dir%register(this%nown,this%gid(1:this%nown)) + allocate(howner(max(nhe,1))) + call this%dir%query(nhe,hnode,howner) + sc=0 + do i=1,nhe + sc(howner(i))=sc(howner(i))+1 + end do + call MPI_ALLTOALL(sc,1,MPI_INTEGER,rc,1,MPI_INTEGER,comm,ierr) + sd(0)=0; rd(0)=0 + do r=1,nproc-1 + sd(r)=sd(r-1)+sc(r-1); rd(r)=rd(r-1)+rc(r-1) + end do + rn=sum(rc) + allocate(rnode(max(rn,1)),rnbr(max(rn,1)),rkey(max(rn,1)),rev(max(rn,1)),rdmg(max(rn,1))) + allocate(pos(0:nproc-1),s8(max(nhe,1)),s4(max(nhe,1)),sr(max(nhe,1)),s1(max(nhe,1))) + pos=sd + do i=1,nhe + h=howner(i); pos(h)=pos(h)+1; s8(pos(h))=hnode(i) + end do + call MPI_ALLTOALLV(s8,sc,sd,MPI_INTEGER8,rnode,rc,rd,MPI_INTEGER8,comm,ierr) + pos=sd + do i=1,nhe + h=howner(i); pos(h)=pos(h)+1; s8(pos(h))=hnbr(i) + end do + call MPI_ALLTOALLV(s8,sc,sd,MPI_INTEGER8,rnbr,rc,rd,MPI_INTEGER8,comm,ierr) + pos=sd + do i=1,nhe + h=howner(i); pos(h)=pos(h)+1; s4(pos(h))=hkey(i) + end do + call MPI_ALLTOALLV(s4,sc,sd,MPI_INTEGER,rkey,rc,rd,MPI_INTEGER,comm,ierr) + pos=sd + do i=1,nhe + h=howner(i); pos(h)=pos(h)+1; sr(pos(h))=hev(i) + end do + call MPI_ALLTOALLV(sr,sc,sd,MPI_REAL_WP,rev,rc,rd,MPI_REAL_WP,comm,ierr) + pos=sd + do i=1,nhe + h=howner(i); pos(h)=pos(h)+1; s1(pos(h))=hdmg(i) + end do + call MPI_ALLTOALLV(s1,sc,sd,MPI_INTEGER1,rdmg,rc,rd,MPI_INTEGER1,comm,ierr) + call this%assemble(rn,rnode,rnbr,rkey,rev,rdmg) + deallocate(rnode,rnbr,rkey,rev,rdmg,pos,s8,s4,sr,s1,howner) + end block route_and_assemble + + ! Overlay td2/lam_p (assemble/set_nodes zero them) and life status + do i=1,this%nown + this%td2(i) =this%rextra_tmp(8,i) + this%lam_p(i)=this%rextra_tmp(9,i) + if (this%flag(i).eq.PDC_IS_DEAD) this%alive(i)=0.0_WP + end do + deallocate(this%rextra_tmp) + call this%halo%update1(this%alive) + deallocate(gid,flag,x0,yy,vv,ffb,vol,dmgn,td2n,lamn,hnode,hnbr,hkey,hdmg,hev,owner) + + contains + + subroutine grow_i8(a,n,add) + integer(I8), allocatable, intent(inout) :: a(:) + integer, intent(in) :: n,add + integer(I8), allocatable :: t(:) + allocate(t(n+add)); if (n.gt.0) t(1:n)=a(1:n) + call move_alloc(t,a) + end subroutine grow_i8 + subroutine grow_i4(a,n,add) + integer, allocatable, intent(inout) :: a(:) + integer, intent(in) :: n,add + integer, allocatable :: t(:) + allocate(t(n+add)); if (n.gt.0) t(1:n)=a(1:n) + call move_alloc(t,a) + end subroutine grow_i4 + subroutine grow_i1(a,n,add) + integer(1), allocatable, intent(inout) :: a(:) + integer, intent(in) :: n,add + integer(1), allocatable :: t(:) + allocate(t(n+add)); if (n.gt.0) t(1:n)=a(1:n) + call move_alloc(t,a) + end subroutine grow_i1 + subroutine grow_r1(a,n,add) + real(WP), allocatable, intent(inout) :: a(:) + integer, intent(in) :: n,add + real(WP), allocatable :: t(:) + allocate(t(n+add)); if (n.gt.0) t(1:n)=a(1:n) + call move_alloc(t,a) + end subroutine grow_r1 + subroutine grow_r2(a,n,add) + real(WP), allocatable, intent(inout) :: a(:,:) + integer, intent(in) :: n,add + real(WP), allocatable :: t(:,:) + allocate(t(3,n+add)); if (n.gt.0) t(:,1:n)=a(:,1:n) + call move_alloc(t,a) + end subroutine grow_r2 + + end subroutine read_state + + + !> Static load-balancing partition of the reference configuration. + !> Collective; called once at handoff, BEFORE set_nodes. Nodes are ordered + !> by the Morton key of their reference position and split into equal-count + !> contiguous ranges: on a uniform lattice family size is ~constant, so node + !> count ~ bond work (a family-weighted split can substitute later), and + !> bond work is motion-invariant -- this balance holds for the entire run + !> regardless of deformation or flight, using ALL ranks even when the solid + !> occupies a corner of the fluid domain. + !> Inputs: this rank's extracted nodes (any distribution). Outputs: the + !> nodes assigned to this rank, plus each INPUT node's assigned owner (for + !> stamping the face particles' routing tags). + subroutine pd_partition(n_in,gid_in,pos_in,vel_in,flag_in,vol_in,owner_out, & + & n_out,gid_out,pos_out,vel_out,flag_out,vol_out) + use parallel, only: comm,rank,nproc,amRoot,MPI_REAL_WP + use pdhalo_class, only: sort3_perm + use mpi_f08 + implicit none + integer, intent(in) :: n_in + integer(I8), intent(in) :: gid_in(:) + real(WP), intent(in) :: pos_in(:,:),vel_in(:,:) + integer, intent(in) :: flag_in(:) + real(WP), intent(in) :: vol_in(:) + integer, intent(out) :: owner_out(:) + integer, intent(out) :: n_out + integer(I8), allocatable, intent(out) :: gid_out(:) + real(WP), allocatable, intent(out) :: pos_out(:,:),vel_out(:,:),vol_out(:) + integer, allocatable, intent(out) :: flag_out(:) + real(WP), dimension(3) :: blo,bhi,inv + integer(I8), allocatable :: keys(:),splitters(:) + integer :: i,r,d,ierr + + ! Global reference bounds + blo=huge(1.0_WP); bhi=-huge(1.0_WP) + do i=1,n_in + blo=min(blo,pos_in(:,i)); bhi=max(bhi,pos_in(:,i)) + end do + call MPI_ALLREDUCE(MPI_IN_PLACE,blo,3,MPI_REAL_WP,MPI_MIN,comm,ierr) + call MPI_ALLREDUCE(MPI_IN_PLACE,bhi,3,MPI_REAL_WP,MPI_MAX,comm,ierr) + do d=1,3 + inv(d)=0.0_WP + if (bhi(d).gt.blo(d)) inv(d)=2097151.0_WP/(bhi(d)-blo(d)) + end do + + ! Morton keys of this rank's nodes + allocate(keys(max(n_in,1))) + do i=1,n_in + keys(i)=morton(pos_in(:,i),blo,inv) + end do + + ! Equal-weight splitters by SAMPLE SORT: each rank contributes a few + ! evenly-spaced samples of its locally sorted keys, weighted by its node + ! count -- root memory is O(nproc*S), not O(N_global), so this scales to + ! very large rank counts (the old gather-all-keys approach walled at + ! root memory and int32 N_global). + allocate(splitters(max(nproc-1,1))) + sample_splitters: block + integer, parameter :: S=16 + integer(I8), allocatable :: lsamp(:),gsamp(:),gw(:) + real(WP), allocatable :: w(:) + integer, allocatable :: perm(:),zk(:),scnt(:),sdis(:) + integer(I8) :: wtot,wcum,wtarg + integer :: ns,j,r2,gtot + ! Locally sort keys (permutation) and draw samples + allocate(perm(max(n_in,1)),zk(max(n_in,1))) + do i=1,n_in + perm(i)=i + end do + zk=0 + if (n_in.gt.1) call sort3_perm(zk,keys(1:n_in),zk,perm,1,n_in) + ns=min(S,n_in) + allocate(lsamp(max(ns,1))) + do j=1,ns + lsamp(j)=keys(perm(min(n_in,int((real(j,WP)-0.5_WP)*real(n_in,WP)/real(ns,WP))+1))) + end do + deallocate(perm,zk) + ! Gather samples (+ per-rank sample counts and node counts) on root + allocate(scnt(nproc),sdis(nproc)) + call MPI_GATHER(ns,1,MPI_INTEGER,scnt,1,MPI_INTEGER,0,comm,ierr) + gtot=0 + if (amRoot) then + sdis(1)=0 + do r2=2,nproc + sdis(r2)=sdis(r2-1)+scnt(r2-1) + end do + gtot=sum(scnt) + end if + allocate(gsamp(max(gtot,1)),gw(nproc)) + call MPI_GATHERV(lsamp,ns,MPI_INTEGER8,gsamp,scnt,sdis,MPI_INTEGER8,0,comm,ierr) + call MPI_GATHER(int(n_in,I8),1,MPI_INTEGER8,gw,1,MPI_INTEGER8,0,comm,ierr) + if (amRoot.and.gtot.gt.0) then + root_split: block + integer, allocatable :: p2(:),z2(:) + real(WP), allocatable :: sw(:) + ! Weight each sample by (its rank's node count)/(its rank's samples) + allocate(sw(gtot),p2(gtot),z2(gtot)) + do r2=1,nproc + do j=sdis(r2)+1,sdis(r2)+scnt(r2) + sw(j)=real(gw(r2),WP)/real(max(scnt(r2),1),WP) + end do + end do + do j=1,gtot + p2(j)=j + end do + z2=0 + call sort3_perm(z2,gsamp(1:gtot),z2,p2,1,gtot) + ! Single cumulative-weight pass placing all nproc-1 splitters + wtot=sum(gw) + wcum=0_I8; r2=1 + do j=1,gtot + if (r2.gt.nproc-1) exit + wcum=wcum+int(sw(p2(j)),I8) + do while (r2.le.nproc-1.and.wcum.ge.(int(r2,I8)*wtot)/int(nproc,I8)) + splitters(r2)=gsamp(p2(j)) + r2=r2+1 + end do + end do + do while (r2.le.nproc-1) + splitters(r2)=huge(1_I8) ! degenerate tail: empty upper buckets + r2=r2+1 + end do + deallocate(sw,p2,z2) + end block root_split + end if + deallocate(lsamp,gsamp,gw,scnt,sdis) + end block sample_splitters + if (nproc.gt.1) call MPI_BCAST(splitters,nproc-1,MPI_INTEGER8,0,comm,ierr) + + ! Assign owners: bucket = number of splitters <= key + do i=1,n_in + owner_out(i)=0 + do r=1,nproc-1 + if (keys(i).ge.splitters(r)) owner_out(i)=r + end do + end do + deallocate(keys,splitters) + + ! Route node payloads to their owners + route_nodes: block + integer, dimension(0:nproc-1) :: sc,rc,sd,rd,scw,rcw,sdw,rdw + integer, allocatable :: pos(:),sflag(:) + integer(I8), allocatable :: sgid(:) + real(WP), allocatable :: sdat(:,:),rdat(:,:) + sc=0 + do i=1,n_in + sc(owner_out(i))=sc(owner_out(i))+1 + end do + call MPI_ALLTOALL(sc,1,MPI_INTEGER,rc,1,MPI_INTEGER,comm,ierr) + sd(0)=0; rd(0)=0 + do r=1,nproc-1 + sd(r)=sd(r-1)+sc(r-1); rd(r)=rd(r-1)+rc(r-1) + end do + n_out=sum(rc) + allocate(pos(0:nproc-1),sgid(max(n_in,1)),sflag(max(n_in,1)),sdat(7,max(n_in,1))) + pos=sd + do i=1,n_in + r=owner_out(i); pos(r)=pos(r)+1 + sgid(pos(r))=gid_in(i) + sflag(pos(r))=flag_in(i) + sdat(1:3,pos(r))=pos_in(:,i) + sdat(4:6,pos(r))=vel_in(:,i) + sdat(7,pos(r)) =vol_in(i) + end do + allocate(gid_out(max(n_out,1)),flag_out(max(n_out,1)),rdat(7,max(n_out,1))) + allocate(pos_out(3,max(n_out,1)),vel_out(3,max(n_out,1)),vol_out(max(n_out,1))) + call MPI_ALLTOALLV(sgid,sc,sd,MPI_INTEGER8,gid_out,rc,rd,MPI_INTEGER8,comm,ierr) + call MPI_ALLTOALLV(sflag,sc,sd,MPI_INTEGER,flag_out,rc,rd,MPI_INTEGER,comm,ierr) + scw=7*sc; sdw=7*sd; rcw=7*rc; rdw=7*rd + call MPI_ALLTOALLV(sdat,scw,sdw,MPI_REAL_WP,rdat,rcw,rdw,MPI_REAL_WP,comm,ierr) + do i=1,n_out + pos_out(:,i)=rdat(1:3,i) + vel_out(:,i)=rdat(4:6,i) + vol_out(i) =rdat(7,i) + end do + deallocate(pos,sgid,sflag,sdat,rdat) + end block route_nodes + + contains + + !> 63-bit Morton key: 21 bits per dimension, bit-interleaved + pure function morton(p,lo,inv) result(key) + implicit none + real(WP), dimension(3), intent(in) :: p,lo,inv + integer(I8) :: key + integer(I8), dimension(3) :: ix + integer :: b,d + do d=1,3 + ix(d)=int(min(max((p(d)-lo(d))*inv(d),0.0_WP),2097151.0_WP),I8) + end do + key=0_I8 + do b=0,20 + do d=1,3 + if (btest(ix(d),b)) key=ibset(key,3*b+d-1) + end do + end do + end function morton + + end subroutine pd_partition + + + !> Bin geometry: cell size >= the search radius (so +/-1 cell sweeps are complete), + !> dims clamped to keep total cell count bounded on huge/degenerate extents + subroutine setup_bins(lo,hi,r,gl,h,nc) + real(WP), dimension(3), intent(in) :: lo,hi + real(WP), intent(in) :: r + real(WP), dimension(3), intent(out) :: gl,h + integer, dimension(3), intent(out) :: nc + integer :: d + do d=1,3 + gl(d)=lo(d)-0.5_WP*r + nc(d)=max(1,min(256,int((hi(d)-lo(d)+r)/r))) + h(d)=max((hi(d)+0.5_WP*r-gl(d))/real(nc(d),WP),r) + end do + end subroutine setup_bins + + !> Flattened cell index of a position (clamped into the grid) + pure function cell_of(p,gl,h,nc) result(k) + real(WP), dimension(3), intent(in) :: p,gl,h + integer, dimension(3), intent(in) :: nc + integer :: k,c(3),d + do d=1,3 + c(d)=min(nc(d),max(1,int((p(d)-gl(d))/h(d))+1)) + end do + k=c(1)+nc(1)*(c(2)-1)+nc(1)*nc(2)*(c(3)-1) + end function cell_of + + + !> Influence function w(zeta) (Peridigm forms). ONE form active, hard-coded; + !> flip by (un)commenting -- s0-from-G_c, psi_fac, and the critical-dt + !> diagnostic all generalize through wmoment(), so nothing else changes. + pure function omega(d,h) result(w) + implicit none + real(WP), intent(in) :: d,h + real(WP) :: w + real(WP) :: s + ! Parabolic decay (ACTIVE): 1 in the core, C1 taper to 0 at the horizon + s=d/h + if (s.lt.0.5_WP) then + w=1.0_WP + else + w=max(4.0_WP*s*(1.0_WP-s),0.0_WP) + end if + ! Constant (Peridigm default; pre-2026-07-16 behavior) + !w=1.0_WP + ! Gaussian + !w=exp(-(d/(0.4_WP*h))**2) + end function omega + + !> Moment of the influence function: int_0^delta w(z)^wpow * z^zpow dz + !> (midpoint quadrature through omega(), so any form change propagates) + pure function wmoment(delta,zpow,wpow) result(m) + implicit none + real(WP), intent(in) :: delta + integer, intent(in) :: zpow,wpow + real(WP) :: m + integer, parameter :: NQ=2048 + integer :: i + real(WP) :: z,dz + dz=delta/real(NQ,WP) + m=0.0_WP + do i=1,NQ + z=(real(i,WP)-0.5_WP)*dz + m=m+omega(z,delta)**wpow*z**zpow + end do + m=m*dz + end function wmoment + + !> Lexicographic sign of an image shift: .true. for the "positive" member + !> of a self-image pair (first nonzero component positive), so each + !> self-image bond is census-counted exactly once. + pure function shift_positive(s) result(p) + implicit none + real(WP), dimension(3), intent(in) :: s + logical :: p + integer :: d + p=.false. + do d=1,3 + if (abs(s(d)).gt.0.0_WP) then + p=(s(d).gt.0.0_WP) + return + end if + end do + end function shift_positive + + !> Negate a packed periodic image offset (amrpd hist1 convention) + pure function negkey(key) result(nk) + implicit none + integer, intent(in) :: key + integer :: nk,n1,n2,n3 + n1=mod(key,256)-128; n2=mod(key/256,256)-128; n3=key/65536-128 + nk=(-n1+128)+(-n2+128)*256+(-n3+128)*65536 + end function negkey + +end module OSB_class diff --git a/examples/NOSB_plate_with_hole_peridigm/src/amrpd_class.f90 b/examples/NOSB_plate_with_hole_peridigm/src/amrpd_class.f90 new file mode 100644 index 000000000..31adb0a5b --- /dev/null +++ b/examples/NOSB_plate_with_hole_peridigm/src/amrpd_class.f90 @@ -0,0 +1,1141 @@ +!> Grid-side extension of the PD solver: an amrpd IS a pdsolver (extends it) +!> plus an AMReX particle mirror of its nodes (the "face"), distributed by +!> position over the fluid grid's boxes so every grid-facing operation runs +!> where the cells live: volume-fraction and velocity deposits, field +!> interpolation at particle positions (F_fluid), VF-driven AMR tagging, +!> and plotfile visualization. +!> +!> Usage tiers (amrpd EXTENDS pdsolver: one object is the solid solver AND +!> its grid face -- assign material/damage/contact fields, then call handoff): +!> 1. pdsolver alone -- grid-free solid dynamics (no visualization) +!> 2. amrpd -- adds viz, solid VF on the mesh, AMR refinement, +!> seeding, and the face<->solver exchange +!> 3. ... + a flow solver -- two-way FSI (driver deposits IB forcing; the +!> fluid load returns via exchange_solid) +module amrpd_class + use precision, only: WP,I8 + use string, only: str_medium + use amrgrid_class, only: amrgrid + use amrdata_class, only: amrdata + use pdsolver_class, only: pdsolver,pd_partition,PD_WALL,PDC_IS_DEAD + use iso_c_binding + implicit none + private + + ! Public exports + public :: amrpd,part,part_gid + + ! Particle motion-control bit flags (composed by bit-OR into idata[0]) + ! Standard cases: + ! Free particle = PART_MOVES + PART_INTEGRATES + PART_BONDS (= 7) + ! Clamped fixed = PART_BONDS (= 4) + ! Velocity-prescribed = PART_MOVES + PART_BONDS (= 5) + ! Witness/probe = PART_MOVES (= 1) + ! Inactive (recycled) = PART_IS_DEAD (= 0) + integer(c_int), parameter, public :: PART_IS_DEAD = 0 !< Inactive; recycled out by AMReX + integer(c_int), parameter, public :: PART_MOVES = 1 !< pos += dt*vel during advance + integer(c_int), parameter, public :: PART_INTEGRATES = 2 !< vel += (dt/2)*acc during Verlet half-kick + integer(c_int), parameter, public :: PART_BONDS = 4 !< Eligible for bond-network participation + + ! Struct layout constants -- MUST match #defines in amrpd_wrapper.cpp + integer, parameter, public :: AMRPD_NREAL_PART = 15 + integer, parameter, public :: AMRPD_NINT_PART = 1 + integer, parameter, public :: AMRPD_NREAL_BOND = 4 + integer, parameter, public :: AMRPD_NINT_BOND = 5 + + !> Solid particle struct -- must match C++ Particle<15,1> memory layout: + !> pos[3], rdata[15], idcpu, idata[1]. Physics lives in pdsolver; only + !> pos/vel/F_fluid/damage are meaningful here (rest is legacy layout). + type, bind(C), public :: part + real(c_double) :: pos(3) !< AMReX-managed position + real(c_double) :: vel(3) !< rdata[0..2] + real(c_double) :: F_bond(3) !< rdata[3..5] (unused) + real(c_double) :: F_fluid(3) !< rdata[6..8] fluid load interpolated by the driver + real(c_double) :: mw !< rdata[9] (unused) + real(c_double) :: dil !< rdata[10] (unused) + real(c_double) :: damage !< rdata[11] broken-bond fraction in [0,1] + real(c_double) :: nb0 !< rdata[12] (unused) + real(c_double) :: td2 !< rdata[13] (unused) + real(c_double) :: td2a !< rdata[14] (unused) + integer(c_int64_t), private :: idcpu !< AMReX packed id+cpu + integer(c_int) :: flag !< idata[0]: PART_* flags at seeding; owner routing tag (7+8*owner) after handoff + end type part + + + + !> C interface bindings to amrpd_wrapper.cpp + interface + + ! Lifecycle + subroutine amrpd_new_pcp(pc,amrcore) bind(c) + import :: c_ptr + type(c_ptr) :: pc + type(c_ptr), value :: amrcore + end subroutine + subroutine amrpd_delete_pcp(pc) bind(c) + import :: c_ptr + type(c_ptr), value :: pc + end subroutine + + ! Redistribute + subroutine amrpd_redistribute_p(pc,lev_min,lev_max,ng) bind(c) + import :: c_ptr,c_int + type(c_ptr), value :: pc + integer(c_int), value :: lev_min,lev_max,ng + end subroutine + + + ! MFIter accessors -- particles + subroutine amrpd_get_particles_mfi(pc,lev,mfi,dp,np) bind(c) + import :: c_ptr,c_int,c_int64_t + type(c_ptr), value :: pc,mfi + integer(c_int), value :: lev + type(c_ptr) :: dp + integer(c_int64_t) :: np + end subroutine + + + ! Single-element insertion (initialization) + subroutine amrpd_add_particle_i(pc,lev,grid,tile,p) bind(c) + import :: c_ptr,c_int + type(c_ptr), value :: pc,p + integer(c_int), value :: lev,grid,tile + end subroutine + + ! Bulk append at level 0 (collective; ranks with n=0 pass raw=NULL) + subroutine amrpd_append_particles(pc,raw,n) bind(c) + import :: c_ptr,c_int64_t + type(c_ptr), value :: pc + type(c_ptr), value :: raw + integer(c_int64_t), value :: n + end subroutine + subroutine amrpd_append_particles_gid(pc,raw,n,gids) bind(c) + import :: c_ptr,c_int64_t + type(c_ptr), value :: pc + type(c_ptr), value :: raw + integer(c_int64_t), value :: n + type(c_ptr), value :: gids + end subroutine + + ! BoxArray / DistributionMap accessors + subroutine amrpd_get_particle_boxarray_p(pc,lev,ba) bind(c) + import :: c_ptr,c_int + type(c_ptr), value :: pc + integer(c_int), value :: lev + type(c_ptr) :: ba + end subroutine + subroutine amrpd_get_particle_distromap_p(pc,lev,dm) bind(c) + import :: c_ptr,c_int + type(c_ptr), value :: pc + integer(c_int), value :: lev + type(c_ptr) :: dm + end subroutine + subroutine amrpd_set_particle_boxarray_p(pc,lev,ba) bind(c) + import :: c_ptr,c_int + type(c_ptr), value :: pc + integer(c_int), value :: lev + type(c_ptr), value :: ba + end subroutine + subroutine amrpd_set_particle_distromap_p(pc,lev,dm) bind(c) + import :: c_ptr,c_int + type(c_ptr), value :: pc + integer(c_int), value :: lev + type(c_ptr), value :: dm + end subroutine + + ! ID/CPU counters and accessors + subroutine amrpd_get_next_id_p(id) bind(c) + import :: c_int64_t + integer(c_int64_t) :: id + end subroutine + subroutine amrpd_set_next_id_p(id) bind(c) + import :: c_int64_t + integer(c_int64_t), value :: id + end subroutine + subroutine amrpd_get_cpu(cpu) bind(c) + import :: c_int + integer(c_int) :: cpu + end subroutine + subroutine amrpd_get_particle_id(id,p) bind(c) + import :: c_int64_t,c_ptr + integer(c_int64_t) :: id + type(c_ptr), value :: p + end subroutine + subroutine amrpd_set_particle_id(id,p) bind(c) + import :: c_int64_t,c_ptr + integer(c_int64_t), value :: id + type(c_ptr), value :: p + end subroutine + subroutine amrpd_get_particle_cpu(cpu,p) bind(c) + import :: c_int,c_ptr + integer(c_int) :: cpu + type(c_ptr), value :: p + end subroutine + subroutine amrpd_set_particle_cpu(cpu,p) bind(c) + import :: c_int,c_ptr + integer(c_int), value :: cpu + type(c_ptr), value :: p + end subroutine + + + ! Global counts + subroutine amrpd_total_np(pc,np) bind(c) + import :: c_ptr,c_int64_t + type(c_ptr), value :: pc + integer(c_int64_t) :: np + end subroutine + + ! Checkpoint I/O: caller composes fullpath (e.g. /particles) + subroutine amrpd_checkpoint_p(pc,path) bind(c) + import :: c_ptr,c_char + type(c_ptr), value :: pc + character(kind=c_char) :: path(*) + end subroutine + subroutine amrpd_restart_p(pc,path) bind(c) + import :: c_ptr,c_char + type(c_ptr), value :: pc + character(kind=c_char) :: path(*) + end subroutine + + end interface + + + !> Grid-side extension of the PD solver: an amrpd IS a pdsolver, plus an + !> AMReX particle mirror of its nodes (the "face") distributed by position + !> over the fluid grid's boxes for deposits, interpolation, tagging, and viz + type, extends(pdsolver) :: amrpd + + !> Associated AMR grid + class(amrgrid), pointer :: amr => null() + + !> Opaque AMReX container handle + type(c_ptr) :: pcp = c_null_ptr !< Particle container + + !> Face load-balance metrics across ranks (grid decomposition; the + !> solver's own Morton partition is balanced by construction) + integer(I8) :: np_loc = 0 !< This rank's face particle count + integer(I8) :: np_min = 0 !< Min across ranks + integer(I8) :: np_max = 0 !< Max across ranks + real(WP) :: np_eff = 0.0_WP !< Load efficiency = mean/max + + !> Maximum AMR level particles are allowed on (cap passed to AMReX + !> Redistribute as lev_max). Particles span levels [0, maxlvl] and + !> AMReX places each at the finest level covering its position. + !> Defaults to amr%maxlvl in initialize. + integer :: maxlvl = 0 + + !> Overlap (ghost cell) width. Must be a multiple of the AMR refinement + !> ratio (2 in standard AMReX setups) because amrdata's process_deposit + !> uses sum_fine_to_coarse, which asserts nGrow % ratio == 0. Matches + !> amrlpt's default. + integer :: nover = 2 + + + !> Particle volume fraction on the Eulerian AMR mesh. Cell-centered scalar + !> (one component), one ghost layer. Updated each advance step by + !> update_VF: trilinear deposition of each particle's volume dV onto the + !> 8 surrounding cell centers, then average-down + optional smoothing. + !> Drives the AMR tagging callback when VF_tag > 0. + type(amrdata) :: VF + real(WP) :: VF_tag = -1.0_WP !< Refinement threshold (<=0 disables VF-driven tagging) + real(WP) :: filter_width = 0.0_WP !< Gaussian-equivalent filter width for VF; 0 disables + real(WP) :: VF_snap = 0.1_WP !< Deposit-moire amplitude: VF is rescaled by 1/(1-VF_snap) and clipped, + !< so a fully packed interior reads exactly 1. 0 disables. + real(WP) :: VFmin=0.0_WP,VFmax=0.0_WP,VFmean=0.0_WP !< VF statistics + + !> Optional user-supplied tagging callback. Called AFTER the built-in VF + !> tagging. Use to add custom refinement criteria (e.g., damage > 0.3). + procedure(pd_tagging_iface), pointer, pass :: user_pd_tagging => null() + + contains + ! Lifecycle + procedure :: initialize + procedure :: finalize + ! Container utilities + procedure :: redistribute + procedure :: get_info !< Global counts + min/max/mean velocities + load-balance metrics + procedure :: set_particle_ba_p + procedure :: set_particle_dm_p + ! Particle population + procedure :: append + procedure :: append_with_gids + ! Solver coupling (grid face <-> contained pdsolver) + procedure :: handoff + procedure :: exchange_solid + procedure :: rebuild_face + ! MFIter helpers (particle container's BA/DM) + procedure :: mfiter_build + procedure :: mfiter_destroy + procedure :: get_particles + ! AMR callbacks + procedure :: post_regrid + procedure :: tagging + ! Particle volume fraction + AMR tagging + procedure :: update_VF !< Compute VF from particle positions (trilinear deposit) + procedure :: process_deposit !< Post-process a deposited field (extensive -> intensive + C/F transfers; public: also used on driver-deposited fields) + procedure :: filter !< Explicit-diffusion smoothing of a cell-centered amrdata (public: also used on driver-deposited fields) + ! Physics -- STUBBED in skeleton + procedure :: interp !< Trilinear cell-centered interpolation (used by compute_contact for IB) + ! Checkpoint I/O + procedure :: write + procedure :: read + ! Diagnostics + procedure :: print + end type amrpd + + + !> Abstract interface for user-overridable tagging callback. Invoked AFTER + !> the built-in VF-based tagging by the registered AMReX tagging dispatch. + abstract interface + subroutine pd_tagging_iface(solver,lvl,time,tags) + import :: amrpd,c_ptr,WP + class(amrpd), intent(inout) :: solver + integer, intent(in) :: lvl + real(WP), intent(in) :: time + type(c_ptr), intent(in) :: tags + end subroutine pd_tagging_iface + end interface + + +contains + + + !> Public accessor for a particle's unique 64-bit GID key (its AMReX idcpu). + !> The idcpu component is private to protect the AMReX layout; the graph-core + !> handoff and parity tooling need the key for gid-matched state exchange. + function part_gid(p) result(gid) + implicit none + type(part), intent(in) :: p + integer(I8) :: gid + gid=p%idcpu + end function part_gid + + + ! ============================================================================ + ! DISPATCHERS (module-level) -- recover concrete amrpd type from c_ptr ctx + ! ============================================================================ + + !> Dispatch post_regrid: calls type-bound method + subroutine amrpd_postregrid_dispatch(ctx,lbase,time) + use iso_c_binding, only: c_ptr,c_f_pointer + implicit none + type(c_ptr), intent(in) :: ctx + integer, intent(in) :: lbase + real(WP), intent(in) :: time + type(amrpd), pointer :: this + call c_f_pointer(ctx,this) + call this%post_regrid(lbase,time) + end subroutine amrpd_postregrid_dispatch + + !> Dispatch tagging: calls type-bound method, then user override (if any) + subroutine amrpd_tagging_dispatch(ctx,lvl,time,tags) + use iso_c_binding, only: c_ptr,c_f_pointer + implicit none + type(c_ptr), intent(in) :: ctx + integer, intent(in) :: lvl + real(WP), intent(in) :: time + type(c_ptr), intent(in) :: tags + type(amrpd), pointer :: this + call c_f_pointer(ctx,this) + call this%tagging(lvl,time,tags) + if (associated(this%user_pd_tagging)) call this%user_pd_tagging(lvl,time,tags) + end subroutine amrpd_tagging_dispatch + + + ! ============================================================================ + ! LIFECYCLE + ! ============================================================================ + + !> Initialize amrpd solver: create particle container, register AMR callbacks + subroutine initialize(this,amr,name) + use amrex_amr_module, only: amrex_bc_foextrap + implicit none + class(amrpd), intent(inout) :: this + class(amrgrid), target, intent(in) :: amr + character(len=*), optional :: name + ! Set solver name + if (present(name)) this%name = trim(adjustl(name)) + ! Point to associated AMR grid + this%amr => amr + ! Default level cap: allow particles up to the AMR grid's max refinement + this%maxlvl = amr%maxlvl + ! Default deposit-smoothing width + this%filter_width = 2.0_WP*this%amr%min_meshsize(this%amr%maxlvl) + ! Create AMReX particle container + call amrpd_new_pcp(this%pcp,this%amr%amrcore) + ! Stamp the solver's domain geometry from the grid (material, damage, + ! and contact fields are driver-assigned) + this%Ldom=[amr%xhi-amr%xlo,amr%yhi-amr%ylo,amr%zhi-amr%zlo] + this%per=[amr%xper,amr%yper,amr%zper] + this%collapsed=[amr%nx.eq.1,amr%ny.eq.1,amr%nz.eq.1] + this%dom_lo=[amr%xlo,amr%ylo,amr%zlo] + this%dom_hi=[amr%xhi,amr%yhi,amr%zhi] + ! Particle volume fraction field (cell-centered, 1 ghost layer; foextrap + ! on non-periodic faces matches amrlpt's convention) + call this%VF%initialize(amr=amr,name='VF',ncomp=1,ng=this%nover); call this%VF%register() + if (.not.this%amr%xper) then; this%VF%lo_bc(1,1)=amrex_bc_foextrap; this%VF%hi_bc(1,1)=amrex_bc_foextrap; end if + if (.not.this%amr%yper) then; this%VF%lo_bc(2,1)=amrex_bc_foextrap; this%VF%hi_bc(2,1)=amrex_bc_foextrap; end if + if (.not.this%amr%zper) then; this%VF%lo_bc(3,1)=amrex_bc_foextrap; this%VF%hi_bc(3,1)=amrex_bc_foextrap; end if + ! Register AMR callbacks (post_regrid + tagging) so containers stay in sync + select type (this) + type is (amrpd) + call this%amr%add_postregrid(amrpd_postregrid_dispatch,c_loc(this)) + call this%amr%add_tagging (amrpd_tagging_dispatch, c_loc(this)) + end select + ! Print solver info + call this%print() + end subroutine initialize + + !> Finalize: destroy face and container, then the parent solver + subroutine finalize(this) + implicit none + class(amrpd), intent(inout) :: this + ! Drop user tagging hook + nullify(this%user_pd_tagging) + ! Tear down the volume-fraction field + call this%VF%finalize() + if (c_associated(this%pcp)) then + call amrpd_delete_pcp(this%pcp); this%pcp = c_null_ptr + end if + nullify(this%amr) + ! Tear down the solver state + call this%pdsolver%finalize() + end subroutine finalize + + + ! ============================================================================ + ! CONTAINER UTILITIES + ! ============================================================================ + + !> Redistribute the particle container across ranks (finest covering level + !> per position; lev_max=-1 avoids the lev_max>finestLevel() assert before + !> all levels exist). Matches amrlpt's default. + subroutine redistribute(this) + implicit none + class(amrpd), intent(inout) :: this + call amrpd_redistribute_p(this%pcp,0,-1,0) + end subroutine redistribute + + + + + + + + + + + + + !> Collective info: runs the solver's get_info (np, velocity extrema, bond + !> censuses, timers), then adds the FACE load-balance metrics -- particles + !> per rank across the grid decomposition (the solver's own partition is + !> balanced by construction; this measures the position-based mirror). + subroutine get_info(this) + implicit none + class(amrpd), intent(inout) :: this + integer(I8) :: np_sum + + ! Solver-side info + call this%pdsolver%get_info() + + ! Face census: live particles owned by this rank across all levels + local_pass: block + use amrex_amr_module, only: amrex_mfiter + type(amrex_mfiter) :: mfi + type(part), dimension(:), pointer :: p + integer(I8) :: np_,n + integer :: lvl + this%np_loc=0_I8 + do lvl=0,this%amr%clvl() + call this%mfiter_build(lvl,mfi) + do while (mfi%next()) + call this%get_particles(lvl,mfi,p,np_) + do n=1,np_ + if (p(n)%flag.eq.PART_IS_DEAD) cycle + this%np_loc=this%np_loc+1_I8 + end do + end do + call this%mfiter_destroy(mfi) + end do + end block local_pass + + ! Load-balance reductions + global_reduce: block + use mpi_f08, only: MPI_ALLREDUCE,MPI_SUM,MPI_MIN,MPI_MAX,MPI_IN_PLACE,MPI_INTEGER8 + integer :: ierr + this%np_min=this%np_loc; this%np_max=this%np_loc; np_sum=this%np_loc; this%np_eff=0.0_WP + call MPI_ALLREDUCE(MPI_IN_PLACE,this%np_min,1,MPI_INTEGER8,MPI_MIN,this%amr%comm,ierr) + call MPI_ALLREDUCE(MPI_IN_PLACE,this%np_max,1,MPI_INTEGER8,MPI_MAX,this%amr%comm,ierr) + call MPI_ALLREDUCE(MPI_IN_PLACE,np_sum, 1,MPI_INTEGER8,MPI_SUM,this%amr%comm,ierr) + if (this%np_max.gt.0_I8) this%np_eff=real(np_sum,WP)/real(this%np_max,WP)/real(this%amr%nproc,WP) + end block global_reduce + + end subroutine get_info + + + !> Set particle-container BoxArray for a given level + subroutine set_particle_ba_p(this,lvl,ba) + use amrex_amr_module, only: amrex_boxarray + implicit none + class(amrpd), intent(inout) :: this + integer, intent(in) :: lvl + type(amrex_boxarray), intent(in) :: ba + call amrpd_set_particle_boxarray_p(this%pcp,lvl,ba%p) + end subroutine set_particle_ba_p + + !> Set particle-container DistributionMapping for a given level + subroutine set_particle_dm_p(this,lvl,dm) + use amrex_amr_module, only: amrex_distromap + implicit none + class(amrpd), intent(inout) :: this + integer, intent(in) :: lvl + type(amrex_distromap), intent(in) :: dm + call amrpd_set_particle_distromap_p(this%pcp,lvl,dm%p) + end subroutine set_particle_dm_p + + + + !> Build an MFIter over the particle container's BA/DM at level lvl. + subroutine mfiter_build(this,lvl,mfi,tiling) + use amrex_amr_module, only: amrex_boxarray,amrex_distromap,amrex_mfiter,amrex_mfiter_build + implicit none + class(amrpd), intent(inout) :: this + integer, intent(in) :: lvl + type(amrex_mfiter), intent(out) :: mfi + logical, intent(in), optional :: tiling + type(amrex_boxarray) :: ba + type(amrex_distromap) :: dm + logical :: use_tiling + use_tiling=.false.; if (present(tiling)) use_tiling=tiling + call amrpd_get_particle_boxarray_p (this%pcp,lvl,ba%p) + call amrpd_get_particle_distromap_p(this%pcp,lvl,dm%p) + call amrex_mfiter_build(mfi,ba,dm,tiling=use_tiling) + end subroutine mfiter_build + + !> Destroy an MFIter built via mfiter_build. + subroutine mfiter_destroy(this,mfi) + use amrex_amr_module, only: amrex_mfiter,amrex_mfiter_destroy + implicit none + class(amrpd), intent(inout) :: this + type(amrex_mfiter), intent(inout) :: mfi + call amrex_mfiter_destroy(mfi) + end subroutine mfiter_destroy + + !> Return a Fortran pointer to the valid particle array on the current tile + !> (ghost particles excluded). np is the number of valid particles. + subroutine get_particles(this,lvl,mfi,p,np) + use amrex_amr_module, only: amrex_mfiter + implicit none + class(amrpd), intent(inout) :: this + integer, intent(in) :: lvl + type(amrex_mfiter), intent(in) :: mfi + type(part), dimension(:), pointer, intent(out) :: p + integer(I8), intent(out) :: np + type(c_ptr) :: dp + integer(c_int64_t) :: np_c + call amrpd_get_particles_mfi(this%pcp,lvl,mfi%p,dp,np_c) + np=int(np_c,I8) + if (np.gt.0_I8) then + call c_f_pointer(dp,p,[np]) + else + nullify(p) + end if + end subroutine get_particles + + + + + !> Bulk-append Fortran particle array into the container at level 0. + !> Collective: every rank must call; ranks with nothing to add pass n=0. + !> AMReX assigns unique (id,cpu) to each appended particle and + !> AddParticlesAtLevel internally redistributes by position. + subroutine append(this,plist,n) + use messager, only: die + implicit none + class(amrpd), intent(inout) :: this + type(part), dimension(:), allocatable, target, intent(in) :: plist + integer(I8), intent(in) :: n + type(c_ptr) :: raw + raw=c_null_ptr + if (n.gt.0_I8.and.allocated(plist)) then + if (int(size(plist),I8).lt.n) call die('[amrpd append] plist array smaller than n') + raw=c_loc(plist(1)) + end if + call amrpd_append_particles(this%pcp,raw,int(n,c_int64_t)) + end subroutine append + + !> Bulk-append with PRESERVED identities: each particle takes the (id,cpu) + !> packed in gids (the part_gid key). Used to rebuild the grid-side face + !> from a pdsolver checkpoint so identities match the solver's node gids. + !> Collective; AddParticlesAtLevel redistributes by position. + subroutine append_with_gids(this,plist,n,gids) + use messager, only: die + implicit none + class(amrpd), intent(inout) :: this + type(part), dimension(:), allocatable, target, intent(in) :: plist + integer(I8), intent(in) :: n + integer(I8), dimension(:), target, intent(in) :: gids + type(c_ptr) :: raw,graw + raw=c_null_ptr; graw=c_null_ptr + if (n.gt.0_I8.and.allocated(plist)) then + if (int(size(plist),I8).lt.n) call die('[amrpd append_with_gids] plist smaller than n') + raw=c_loc(plist(1)); graw=c_loc(gids(1)) + end if + call amrpd_append_particles_gid(this%pcp,raw,int(n,c_int64_t),graw) + end subroutine append_with_gids + + + ! ============================================================================ + ! SOLVER COUPLING (grid face <-> contained pdsolver) + ! ============================================================================ + + !> Hand the seeded face population to the solver: extract nodes, Morton- + !> partition them (balanced, motion-invariant), detect families, and stamp + !> each face particle's flag with its solver owner rank (flag = 7+8*owner). + !> The driver must have assigned the material/damage/contact fields first. + subroutine handoff(this) + use amrex_amr_module, only: amrex_mfiter + implicit none + class(amrpd), intent(inout) :: this + type(amrex_mfiter) :: mfi + type(part), dimension(:), pointer :: p + integer(I8), allocatable :: gids(:),rgid(:) + real(WP), allocatable :: pos(:,:),vel(:,:),voll(:),rpos(:,:),rvel(:,:),rvol(:) + integer, allocatable :: flags(:),owner(:),rflag(:) + integer(I8) :: np_,n + integer :: lvl,nn,i,nr + ! Extract this rank's owned particles + nn=0 + do lvl=0,this%amr%clvl() + call this%mfiter_build(lvl,mfi) + do while (mfi%next()) + call this%get_particles(lvl,mfi,p,np_) + nn=nn+int(np_) + end do + call this%mfiter_destroy(mfi) + end do + allocate(gids(max(nn,1)),pos(3,max(nn,1)),vel(3,max(nn,1)),flags(max(nn,1)),voll(max(nn,1)),owner(max(nn,1))) + i=0 + do lvl=0,this%amr%clvl() + call this%mfiter_build(lvl,mfi) + do while (mfi%next()) + call this%get_particles(lvl,mfi,p,np_) + do n=1_I8,np_ + i=i+1 + gids(i) =part_gid(p(n)) + pos(:,i)=p(n)%pos + vel(:,i)=p(n)%vel + flags(i)=p(n)%flag + voll(i) =this%dV + end do + end do + call this%mfiter_destroy(mfi) + end do + ! Balanced static partition of the reference configuration + call pd_partition(nn,gids,pos,vel,flags,voll,owner,nr,rgid,rpos,rvel,rflag,rvol) + call this%set_nodes(nr,rgid,rpos,rvel,rflag,rvol) + call this%detect_families() + ! Stamp owner routing tags on the grid face (same walk order as the + ! extraction above, so owner(i) lines up) + i=0 + do lvl=0,this%amr%clvl() + call this%mfiter_build(lvl,mfi) + do while (mfi%next()) + call this%get_particles(lvl,mfi,p,np_) + do n=1_I8,np_ + i=i+1 + p(n)%flag=7+8*owner(i) + end do + end do + call this%mfiter_destroy(mfi) + end do + deallocate(gids,pos,vel,flags,voll,owner,rgid,rpos,rvel,rflag,rvol) + end subroutine handoff + + !> Face <-> solver exchange (collective; call once per coupling step): push + !> each face particle's interpolated F_fluid to its solver owner; pull back + !> the owner's current (pos, vel, damage, alive). Dead solver nodes (exited + !> an open face) get an outside-domain position written back, so the next + !> redistribute drops the tombstone. + subroutine exchange_solid(this) + use amrex_amr_module, only: amrex_mfiter + implicit none + class(amrpd), intent(inout) :: this + type(amrex_mfiter) :: mfi + type(part), dimension(:), pointer :: p + integer(I8), allocatable :: mgid(:) + integer, allocatable :: mown(:) + real(WP), allocatable :: mff(:,:),mpos(:,:),mvel(:,:),mdmg(:),malive(:) + integer(I8) :: np_,n + integer :: lvl,nm,i + ! Count live face particles + nm=0 + do lvl=0,this%amr%clvl() + call this%mfiter_build(lvl,mfi) + do while (mfi%next()) + call this%get_particles(lvl,mfi,p,np_) + do n=1_I8,np_ + if (p(n)%flag.eq.PART_IS_DEAD) cycle + nm=nm+1 + end do + end do + call this%mfiter_destroy(mfi) + end do + allocate(mgid(max(nm,1)),mown(max(nm,1)),mff(3,max(nm,1))) + allocate(mpos(3,max(nm,1)),mvel(3,max(nm,1)),mdmg(max(nm,1)),malive(max(nm,1))) + ! Pack (gid, owner tag, F_fluid) + i=0 + do lvl=0,this%amr%clvl() + call this%mfiter_build(lvl,mfi) + do while (mfi%next()) + call this%get_particles(lvl,mfi,p,np_) + do n=1_I8,np_ + if (p(n)%flag.eq.PART_IS_DEAD) cycle + i=i+1 + mgid(i)=part_gid(p(n)) + mown(i)=p(n)%flag/8 + mff(:,i)=p(n)%F_fluid + end do + end do + call this%mfiter_destroy(mfi) + end do + ! Collective round-trip with the solver + call this%exchange(nm,mgid,mown,mff,mpos,mvel,mdmg,malive) + ! Write the solver state back onto the grid face (same walk order) + i=0 + do lvl=0,this%amr%clvl() + call this%mfiter_build(lvl,mfi) + do while (mfi%next()) + call this%get_particles(lvl,mfi,p,np_) + do n=1_I8,np_ + if (p(n)%flag.eq.PART_IS_DEAD) cycle + i=i+1 + p(n)%pos=mpos(:,i) + p(n)%vel=mvel(:,i) + p(n)%damage=mdmg(i) + if (malive(i).lt.0.5_WP) p(n)%flag=PART_IS_DEAD + end do + end do + call this%mfiter_destroy(mfi) + end do + deallocate(mgid,mown,mff,mpos,mvel,mdmg,malive) + end subroutine exchange_solid + + !> Rebuild the grid face from the (restored) solver state: one particle per + !> owned live node with PRESERVED identity (gid -> id,cpu), current + !> position/velocity/damage, and the owner routing tag = this rank. + subroutine rebuild_face(this) + use parallel, only: rank + implicit none + class(amrpd), intent(inout) :: this + type(part), dimension(:), allocatable, target :: plist + integer(I8), dimension(:), allocatable, target :: gl + integer(I8) :: n + integer :: i,m + allocate(plist(max(this%nown,1)),gl(max(this%nown,1))) + m=0 + do i=1,this%nown + if (this%flag(i).eq.PDC_IS_DEAD) cycle ! exited nodes stay dead + m=m+1 + plist(m)%pos =this%y(:,i) + plist(m)%vel =this%v(:,i) + plist(m)%F_bond =0.0_WP + plist(m)%F_fluid=0.0_WP + plist(m)%mw =0.0_WP + plist(m)%dil =0.0_WP + plist(m)%damage =this%damage(i) + plist(m)%nb0 =0.0_WP + plist(m)%td2 =0.0_WP + plist(m)%td2a =0.0_WP + plist(m)%flag =7+8*rank + gl(m)=this%gid(i) + end do + n=int(m,I8) + call this%append_with_gids(plist,n,gl) + call this%redistribute() + deallocate(plist,gl) + end subroutine rebuild_face + + + ! ============================================================================ + ! AMR CALLBACKS + ! ============================================================================ + + !> Post-regrid: re-sync particle and bond containers' BA/DM, redistribute. + !> Particles span levels + !> [0, maxlvl] and the BA/DM sync walks all current levels so the containers + !> track AMR. + subroutine post_regrid(this,lbase,time) + implicit none + class(amrpd), intent(inout) :: this + integer, intent(in) :: lbase + real(WP), intent(in) :: time + integer :: lvl + + ! Re-sync both containers to the fluid grid's BA/DM. This sets the + ! AmrParGDB's per-level particle BA/DM caches. Keeping these in sync + ! and matches the pattern used in amrlpt. + sync_to_amrgrid: block + do lvl=0,this%amr%clvl() + call this%set_particle_ba_p(lvl,this%amr%get_boxarray(lvl)) + call this%set_particle_dm_p(lvl,this%amr%get_distromap(lvl)) + end do + end block sync_to_amrgrid + + ! First settle particles onto the freshly-synced BA/DM before we can + ! count them per box for the knapsack weighting below + call this%redistribute() + + ! Recompute particle VF on the (new) mesh. AMReX fills new fine cells via + ! amrdata's coarse-to-fine interpolation during regrid, but that's a + ! guess; a fresh deposit from the redistributed particles is the truth. + ! Matches amrlpt%post_regrid. + call this%update_VF() + end subroutine post_regrid + + !> Tag cells for refinement where particle VF exceeds VF_tag. Disabled if + !> VF_tag <= 0. Mirrors amrlpt%tagging. + subroutine tagging(this,lvl,time,tags) + use amrex_amr_module, only: amrex_tagboxarray,amrex_box,amrex_mfiter,amrex_mfiter_build,amrex_mfiter_destroy + use amrgrid_class, only: SETtag + implicit none + class(amrpd), intent(inout) :: this + integer, intent(in) :: lvl + real(WP), intent(in) :: time + type(c_ptr), intent(in) :: tags + type(amrex_tagboxarray) :: tba + type(amrex_mfiter) :: mfi + type(amrex_box) :: bx + character(kind=c_char), dimension(:,:,:,:), contiguous, pointer :: tagarr + real(WP), dimension(:,:,:,:), contiguous, pointer :: pVF + integer :: i,j,k + ! Skip if VF tagging is disabled + if (this%VF_tag.le.0.0_WP) return + ! Resolve tagboxarray pointer + tba=tags + ! Loop over tiles and tag + call amrex_mfiter_build(mfi,this%VF%mf(lvl)) + do while (mfi%next()) + tagarr=>tba%dataPtr(mfi) + pVF=>this%VF%mf(lvl)%dataptr(mfi) + bx=mfi%tilebox() + do k=bx%lo(3),bx%hi(3); do j=bx%lo(2),bx%hi(2); do i=bx%lo(1),bx%hi(1) + if (pVF(i,j,k,1).gt.this%VF_tag) tagarr(i,j,k,1)=SETtag + end do; end do; end do + end do + call amrex_mfiter_destroy(mfi) + end subroutine tagging + + !> Compute particle volume fraction on the Eulerian AMR mesh: trilinear + !> deposit of each particle's volume dV onto the 8 surrounding cell centers, + !> then convert extensive->intensive (divide by cell_vol), propagate across + !> C/F boundaries, average down, fill ghosts, and optionally smooth. + subroutine update_VF(this) + use amrex_amr_module, only: amrex_mfiter,amrex_multifab,amrex_multifab_build,amrex_multifab_destroy + use amrex_distromap_module, only: operator(.eq.) + implicit none + class(amrpd), intent(inout) :: this + type(amrex_mfiter) :: mfi + type(part), dimension(:), pointer :: p + real(WP), dimension(:,:,:,:), contiguous, pointer :: pVF + integer(I8) :: np_,i + integer :: lvl,ii,jj,kk + real(WP) :: dxi,dyi,dzi,wx,wy,wz,Vp + type(amrex_multifab) :: tmpVF + logical :: dual_dm + + ! Zero VF on all levels + call this%VF%setval(0.0_WP) + Vp=this%dV + + do lvl=0,this%amr%clvl() + dxi=1.0_WP/this%amr%dx(lvl) + dyi=1.0_WP/this%amr%dy(lvl) + dzi=1.0_WP/this%amr%dz(lvl) + + ! Particles may live on a different DM than VF -- deposit on the + ! particle DM into a scratch mfab, then parallel_copy to VF + dual_dm=(.not.(this%VF%mf(lvl)%dm.eq.get_pdm())) + if (dual_dm) then + call amrex_multifab_build(mf=tmpVF,ba=this%amr%ba(lvl),dm=get_pdm(),nc=this%VF%mf(lvl)%ncomp(),ng=this%VF%mf(lvl)%nghost(),nodal=this%VF%nodal) + call tmpVF%setval(0.0_WP) + end if + + call this%mfiter_build(lvl,mfi) + do while (mfi%next()) + if (dual_dm) then + pVF=>tmpVF%dataptr(mfi) + else + pVF=>this%VF%mf(lvl)%dataptr(mfi) + end if + call this%get_particles(lvl,mfi,p,np_) + do i=1_I8,np_ + if (p(i)%flag.eq.PART_IS_DEAD) cycle + ii=floor((p(i)%pos(1)-this%amr%xlo)*dxi-0.5_WP); wx=(p(i)%pos(1)-this%amr%xlo)*dxi-0.5_WP-real(ii,WP) + jj=floor((p(i)%pos(2)-this%amr%ylo)*dyi-0.5_WP); wy=(p(i)%pos(2)-this%amr%ylo)*dyi-0.5_WP-real(jj,WP) + kk=floor((p(i)%pos(3)-this%amr%zlo)*dzi-0.5_WP); wz=(p(i)%pos(3)-this%amr%zlo)*dzi-0.5_WP-real(kk,WP) + ! Clamp 8-cell stencil at WALL faces (mirrors amrlpt) + if (this%lo_bc(1).eq.PD_WALL.and.ii .lt.this%amr%geom(lvl)%domain%lo(1)) then; ii=this%amr%geom(lvl)%domain%lo(1) ; wx=0.0_WP; end if + if (this%hi_bc(1).eq.PD_WALL.and.ii+1.gt.this%amr%geom(lvl)%domain%hi(1)) then; ii=this%amr%geom(lvl)%domain%hi(1)-1; wx=1.0_WP; end if + if (this%lo_bc(2).eq.PD_WALL.and.jj .lt.this%amr%geom(lvl)%domain%lo(2)) then; jj=this%amr%geom(lvl)%domain%lo(2) ; wy=0.0_WP; end if + if (this%hi_bc(2).eq.PD_WALL.and.jj+1.gt.this%amr%geom(lvl)%domain%hi(2)) then; jj=this%amr%geom(lvl)%domain%hi(2)-1; wy=1.0_WP; end if + if (this%lo_bc(3).eq.PD_WALL.and.kk .lt.this%amr%geom(lvl)%domain%lo(3)) then; kk=this%amr%geom(lvl)%domain%lo(3) ; wz=0.0_WP; end if + if (this%hi_bc(3).eq.PD_WALL.and.kk+1.gt.this%amr%geom(lvl)%domain%hi(3)) then; kk=this%amr%geom(lvl)%domain%hi(3)-1; wz=1.0_WP; end if + pVF(ii:ii+1,jj:jj+1,kk:kk+1,1)=pVF(ii:ii+1,jj:jj+1,kk:kk+1,1)+Vp*reshape([(1.0_WP-wx)*(1.0_WP-wy)*(1.0_WP-wz),wx*(1.0_WP-wy)*(1.0_WP-wz),(1.0_WP-wx)*wy*(1.0_WP-wz),wx*wy*(1.0_WP-wz),(1.0_WP-wx)*(1.0_WP-wy)*wz,wx*(1.0_WP-wy)*wz,(1.0_WP-wx)*wy*wz,wx*wy*wz],[2,2,2]) + end do + end do + call this%mfiter_destroy(mfi) + + if (dual_dm) then + call this%VF%mf(lvl)%parallel_copy(tmpVF,1,1,this%VF%mf(lvl)%ncomp(),this%VF%mf(lvl)%nghost(),this%VF%mf(lvl)%nghost(),this%amr%geom(lvl)) + call amrex_multifab_destroy(tmpVF) + end if + end do + + ! Convert extensive -> intensive (VF) and reconcile across C/F + call this%process_deposit(this%VF) + ! Fill ghost cells via amrdata's standard machinery + call this%VF%fill(time=0.0_WP) + ! Optional smoothing (zero filter_width disables) + call this%filter(this%VF) + ! Snap out the deposit moire: the particle lattice is incommensurate with the + ! grid (and moves), so a fully packed interior deposits VF slightly below 1. + ! Rescale+clip so it reads exactly 1; continuous, so no jump is introduced. + if (this%VF_snap.gt.0.0_WP) then + do lvl=0,this%amr%clvl() + call this%VF%mf(lvl)%mult(1.0_WP/(1.0_WP-this%VF_snap),1,1,this%VF%ng) + end do + call this%VF%clip(0.0_WP,1.0_WP) + call this%VF%fill(time=0.0_WP) + end if + + contains + + !> Helper: get the particle distribution map for this level. Returns the + !> DM that the particle container is currently using (which may differ + !> from the Eulerian DM). + function get_pdm() result(dm) + use amrex_distromap_module, only: amrex_distromap + type(amrex_distromap) :: dm + call amrpd_get_particle_distromap_p(this%pcp,lvl,dm%p) + dm%owner=.false. + end function get_pdm + end subroutine update_VF + + !> Post-process an extensive deposit (sum of particle volumes per cell) into + !> an intensive field (VF = sum/cell_vol), with cross-level transfers to + !> avoid double-counting on covered cells. Verbatim port of amrlpt's + !> process_deposit. + subroutine process_deposit(this,A) + use amrex_amr_module, only: amrex_multifab,amrex_multifab_destroy + use amrex_interface, only: amrmfab_sum_downto,amrmfab_interp_from_coarse + implicit none + class(amrpd), intent(inout) :: this + type(amrdata), intent(inout) :: A + type(amrex_multifab), dimension(:), allocatable :: tmp + integer :: lvl + ! Convert extensive deposits to intensive + do lvl=0,this%amr%clvl() + call A%mf(lvl)%mult(1.0_WP/this%amr%cell_vol(lvl),1,A%ncomp,A%ng) + end do + ! Scratch mfabs for coarse->fine interpolation + allocate(tmp(0:this%amr%clvl())) + do lvl=0,this%amr%clvl() + call this%amr%mfab_build(lvl,tmp(lvl),ncomp=A%ncomp,nover=0); call tmp(lvl)%setval(0.0_WP) + end do + ! Forward pass (coarse to fine) + do lvl=0,this%amr%clvl() + call A%syncsum_lvl(lvl) + if (lvl.lt.this%amr%clvl()) then + call amrmfab_interp_from_coarse(tmp(lvl+1),A%mf(lvl),[this%amr%rrefx(lvl),this%amr%rrefy(lvl),this%amr%rrefz(lvl)],cgeom=this%amr%geom(lvl),fgeom=this%amr%geom(lvl+1),scomp=1,ncomp=A%ncomp) + end if + if (lvl.gt.0) then + call amrmfab_sum_downto(A%mf(lvl),A%mf(lvl-1),[this%amr%rrefx(lvl-1),this%amr%rrefy(lvl-1),this%amr%rrefz(lvl-1)],cgeom=this%amr%geom(lvl-1),fgeom=this%amr%geom(lvl)) + end if + call A%mf(lvl)%add(tmp(lvl),1,1,A%ncomp,0) + end do + ! Backward pass: average down to fix double-counted covered cells + do lvl=this%amr%clvl()-1,0,-1 + call A%average_downto(lvl) + end do + do lvl=0,this%amr%clvl() + call amrex_multifab_destroy(tmp(lvl)) + end do + deallocate(tmp) + end subroutine process_deposit + + !> Explicit-diffusion (Gaussian-equivalent) smoothing of a cell-centered + !> amrdata field. Skips if filter_width<=mesh-size. Verbatim port of amrlpt. + subroutine filter(this,A) + use amrex_amr_module, only: amrex_box,amrex_mfiter,amrex_mfiter_build,amrex_mfiter_destroy,amrex_multifab,amrex_multifab_destroy + use amrex_interface, only: amrmfab_average_down_face + implicit none + class(amrpd), intent(inout) :: this + type(amrdata), intent(inout) :: A + real(WP) :: alpha,alpha_step,dxi,dyi,dzi + integer :: nstep,n,nc,lvl,i,j,k + type(amrex_mfiter) :: mfi + type(amrex_box) :: bx + type(amrex_multifab), dimension(:), allocatable :: Fx,Fy,Fz + real(WP), dimension(:,:,:,:), contiguous, pointer :: pA,pFx,pFy,pFz + + alpha=max(this%filter_width**2-this%amr%min_meshsize(this%amr%clvl())**2,0.0_WP)/(16.0_WP*log(2.0_WP)) + if (alpha.le.0.0_WP) return + + nstep=ceiling(6.0_WP*alpha/this%amr%min_meshsize(this%amr%clvl())**2) + alpha_step=alpha/real(nstep,WP) + + allocate(Fx(0:this%amr%maxlvl),Fy(0:this%amr%maxlvl),Fz(0:this%amr%maxlvl)) + do lvl=0,this%amr%clvl() + call this%amr%mfab_build(lvl,Fx(lvl),ncomp=A%ncomp,nover=0,atface=[.true., .false.,.false.]); call Fx(lvl)%setval(0.0_WP) + call this%amr%mfab_build(lvl,Fy(lvl),ncomp=A%ncomp,nover=0,atface=[.false.,.true., .false.]); call Fy(lvl)%setval(0.0_WP) + call this%amr%mfab_build(lvl,Fz(lvl),ncomp=A%ncomp,nover=0,atface=[.false.,.false.,.true. ]); call Fz(lvl)%setval(0.0_WP) + end do + + do n=1,nstep + do lvl=0,this%amr%clvl() + dxi=1.0_WP/this%amr%dx(lvl) + dyi=1.0_WP/this%amr%dy(lvl) + dzi=1.0_WP/this%amr%dz(lvl) + call amrex_mfiter_build(mfi,A%mf(lvl),tiling=.false.) + do while (mfi%next()) + pA =>A%mf(lvl)%dataptr(mfi) + pFx=>Fx(lvl)%dataptr(mfi); pFy=>Fy(lvl)%dataptr(mfi); pFz=>Fz(lvl)%dataptr(mfi) + bx=mfi%nodaltilebox(1) + do nc=1,A%ncomp; do k=bx%lo(3),bx%hi(3); do j=bx%lo(2),bx%hi(2); do i=bx%lo(1),bx%hi(1) + pFx(i,j,k,nc)=alpha_step*(pA(i,j,k,nc)-pA(i-1,j,k,nc))*dxi + end do; end do; end do; end do + bx=mfi%nodaltilebox(2) + do nc=1,A%ncomp; do k=bx%lo(3),bx%hi(3); do j=bx%lo(2),bx%hi(2); do i=bx%lo(1),bx%hi(1) + pFy(i,j,k,nc)=alpha_step*(pA(i,j,k,nc)-pA(i,j-1,k,nc))*dyi + end do; end do; end do; end do + bx=mfi%nodaltilebox(3) + do nc=1,A%ncomp; do k=bx%lo(3),bx%hi(3); do j=bx%lo(2),bx%hi(2); do i=bx%lo(1),bx%hi(1) + pFz(i,j,k,nc)=alpha_step*(pA(i,j,k,nc)-pA(i,j,k-1,nc))*dzi + end do; end do; end do; end do + end do + call amrex_mfiter_destroy(mfi) + end do + do lvl=this%amr%clvl(),1,-1 + call amrmfab_average_down_face(fmf=Fx(lvl),cmf=Fx(lvl-1),rr=[this%amr%rrefx(lvl-1),this%amr%rrefy(lvl-1),this%amr%rrefz(lvl-1)],cgeom=this%amr%geom(lvl-1)) + call amrmfab_average_down_face(fmf=Fy(lvl),cmf=Fy(lvl-1),rr=[this%amr%rrefx(lvl-1),this%amr%rrefy(lvl-1),this%amr%rrefz(lvl-1)],cgeom=this%amr%geom(lvl-1)) + call amrmfab_average_down_face(fmf=Fz(lvl),cmf=Fz(lvl-1),rr=[this%amr%rrefx(lvl-1),this%amr%rrefy(lvl-1),this%amr%rrefz(lvl-1)],cgeom=this%amr%geom(lvl-1)) + end do + do lvl=0,this%amr%clvl() + dxi=1.0_WP/this%amr%dx(lvl) + dyi=1.0_WP/this%amr%dy(lvl) + dzi=1.0_WP/this%amr%dz(lvl) + call amrex_mfiter_build(mfi,A%mf(lvl),tiling=.false.) + do while (mfi%next()) + pA =>A%mf(lvl)%dataptr(mfi) + pFx=>Fx(lvl)%dataptr(mfi); pFy=>Fy(lvl)%dataptr(mfi); pFz=>Fz(lvl)%dataptr(mfi) + bx=mfi%tilebox() + do nc=1,A%ncomp; do k=bx%lo(3),bx%hi(3); do j=bx%lo(2),bx%hi(2); do i=bx%lo(1),bx%hi(1) + pA(i,j,k,nc)=pA(i,j,k,nc)+dxi*(pFx(i+1,j,k,nc)-pFx(i,j,k,nc))+dyi*(pFy(i,j+1,k,nc)-pFy(i,j,k,nc))+dzi*(pFz(i,j,k+1,nc)-pFz(i,j,k,nc)) + end do; end do; end do; end do + end do + call amrex_mfiter_destroy(mfi) + end do + call A%average_down() + call A%fill(time=0.0_WP) + end do + + do lvl=0,this%amr%clvl() + call amrex_multifab_destroy(Fx(lvl)) + call amrex_multifab_destroy(Fy(lvl)) + call amrex_multifab_destroy(Fz(lvl)) + end do + deallocate(Fx,Fy,Fz) + end subroutine filter + + + ! ============================================================================ + ! FIELD INTERPOLATION + ! ============================================================================ + + + + !> Trilinear cell-centered interpolation of a multifab data array at a 3D + !> position (drivers use it to sample fields at particle positions). + function interp(this,lvl,pos,arr,comp) result(val) + implicit none + class(amrpd), intent(in) :: this + integer, intent(in) :: lvl + real(WP), dimension(3), intent(in) :: pos + real(WP), dimension(:,:,:,:), contiguous, pointer, intent(in) :: arr + integer, intent(in) :: comp + real(WP) :: val,wx,wy,wz + integer :: ii,jj,kk + ii=floor((pos(1)-this%amr%xlo)/this%amr%dx(lvl)-0.5_WP); wx=(pos(1)-this%amr%xlo)/this%amr%dx(lvl)-0.5_WP-real(ii,WP) + jj=floor((pos(2)-this%amr%ylo)/this%amr%dy(lvl)-0.5_WP); wy=(pos(2)-this%amr%ylo)/this%amr%dy(lvl)-0.5_WP-real(jj,WP) + kk=floor((pos(3)-this%amr%zlo)/this%amr%dz(lvl)-0.5_WP); wz=(pos(3)-this%amr%zlo)/this%amr%dz(lvl)-0.5_WP-real(kk,WP) + val=(1.0_WP-wx)*(1.0_WP-wy)*(1.0_WP-wz)*arr(ii ,jj ,kk ,comp) & + & + wx *(1.0_WP-wy)*(1.0_WP-wz)*arr(ii+1,jj ,kk ,comp) & + & +(1.0_WP-wx)* wy *(1.0_WP-wz)*arr(ii ,jj+1,kk ,comp) & + & + wx * wy *(1.0_WP-wz)*arr(ii+1,jj+1,kk ,comp) & + & +(1.0_WP-wx)*(1.0_WP-wy)* wz *arr(ii ,jj ,kk+1,comp) & + & + wx *(1.0_WP-wy)* wz *arr(ii+1,jj ,kk+1,comp) & + & +(1.0_WP-wx)* wy * wz *arr(ii ,jj+1,kk+1,comp) & + & + wx * wy * wz *arr(ii+1,jj+1,kk+1,comp) + end function interp + + + + + + ! ============================================================================ + ! CHECKPOINT I/O + ! ============================================================================ + + !> Write the particle-container checkpoint under /particles. + !> Caller is responsible for creating . + subroutine write(this,dirname) + implicit none + class(amrpd), intent(inout) :: this + character(len=*), intent(in) :: dirname + call amrpd_checkpoint_p(this%pcp,trim(dirname)//'/particles'//c_null_char) + end subroutine write + + !> Restore the particle container from a checkpoint written by write. The + !> amrgrid must already be rebuilt; syncs BA/DM, restarts, redistributes. + subroutine read(this,dirname) + implicit none + class(amrpd), intent(inout) :: this + character(len=*), intent(in) :: dirname + integer :: lvl + ! Sync the container to the restored grid's BA/DM + do lvl=0,this%amr%clvl() + call this%set_particle_ba_p(lvl,this%amr%get_boxarray(lvl)) + call this%set_particle_dm_p(lvl,this%amr%get_distromap(lvl)) + end do + ! AMReX Restart + call amrpd_restart_p(this%pcp,trim(dirname)//'/particles'//c_null_char) + ! Settle and refresh + call this%redistribute() + call this%get_info() + end subroutine read + + + ! ============================================================================ + ! DIAGNOSTICS + ! ============================================================================ + + !> Log solver info on root + subroutine print(this) + use, intrinsic :: iso_fortran_env, only: output_unit + use param, only: verbose + use messager, only: log + use string, only: str_long + implicit none + class(amrpd), intent(inout) :: this + character(len=str_long) :: message + if (this%amr%amRoot) then + write(message,'("AMRPD solver [",a,"] on AMR grid [",a,"]")') trim(this%name),trim(this%amr%name) + if (verbose .gt. 1) write(output_unit,'(a)') trim(message) + if (verbose .gt. 0) call log(message) + end if + end subroutine print + + +end module amrpd_class diff --git a/examples/NOSB_plate_with_hole_peridigm/src/geometry.f90 b/examples/NOSB_plate_with_hole_peridigm/src/geometry.f90 new file mode 100644 index 000000000..7abf2660d --- /dev/null +++ b/examples/NOSB_plate_with_hole_peridigm/src/geometry.f90 @@ -0,0 +1,73 @@ +!> Various definitions and tools for initializing NGA2 config +module geometry + use config_class, only: config + use precision, only: WP + implicit none + private + + !> Single config + type(config), public :: cfg + + public :: geometry_init + +contains + + + !> Initialization of problem geometry + subroutine geometry_init + use sgrid_class, only: sgrid + use param, only: param_read + implicit none + type(sgrid) :: grid + + + ! Create a grid from input params + create_grid: block + use sgrid_class, only: cartesian + integer :: i,j,k,nx,ny,nz + real(WP) :: Lx,Ly,Lz + real(WP), dimension(:), allocatable :: x,y,z + + ! Read in grid definition + call param_read('Lx',Lx); call param_read('nx',nx); allocate(x(nx+1)) + call param_read('Ly',Ly); call param_read('ny',ny); allocate(y(ny+1)) + call param_read('Lz',Lz); call param_read('nz',nz); allocate(z(nz+1)) + + ! Create simple rectilinear grid + do i=1,nx+1 + x(i)=real(i-1,WP)/real(nx,WP)*Lx-0.2_WP + end do + do j=1,ny+1 + y(j)=real(j-1,WP)/real(ny,WP)*Ly-0.5_WP*Ly + end do + do k=1,nz+1 + z(k)=real(k-1,WP)/real(nz,WP)*Lz-0.5_WP*Lz + end do + + ! General serial grid object (no=3 needed to support ghost/image point interpolation/extrapolation) + grid=sgrid(coord=cartesian,no=2,x=x,y=y,z=z,xper=.false.,yper=.true.,zper=.true.,name='box') + + end block create_grid + + + ! Create a config from that grid on our entire group + create_cfg: block + use parallel, only: group + integer, dimension(3) :: partition + ! Read in partition + call param_read('Partition',partition,short='p') + ! Create partitioned grid + cfg=config(grp=group,decomp=partition,grid=grid) + end block create_cfg + + + ! Create walls for this config + create_walls: block + cfg%VF=1.0_WP + end block create_walls + + + end subroutine geometry_init + + +end module geometry diff --git a/examples/NOSB_plate_with_hole_peridigm/src/incomp_class.f90 b/examples/NOSB_plate_with_hole_peridigm/src/incomp_class.f90 new file mode 100644 index 000000000..17d5fc3b2 --- /dev/null +++ b/examples/NOSB_plate_with_hole_peridigm/src/incomp_class.f90 @@ -0,0 +1,2129 @@ +!> Incompressible flow solver class: +!> Provides support for various BC, RHS calculation, +!> implicit solver, and pressure solution +!> Assumes constant viscosity and density. +module incomp_class + use precision, only: WP + use string, only: str_medium + use config_class, only: config + use linsol_class, only: linsol + use iterator_class, only: iterator + implicit none + private + + ! Expose type/constructor/methods + public :: incomp,bcond + + ! List of known available bcond types for this solver + integer, parameter, public :: wall=1 !< Dirichlet at zero condition + integer, parameter, public :: dirichlet=2 !< Dirichlet condition + integer, parameter, public :: neumann=3 !< Zero normal gradient + integer, parameter, public :: convective=4 !< Convective outflow condition + integer, parameter, public :: clipped_neumann=5 !< Clipped Neumann condition (outflow only) + integer, parameter, public :: slip=6 !< Free-slip condition + + !> Boundary conditions for the incompressible solver + type :: bcond + type(bcond), pointer :: next !< Linked list of bconds + character(len=str_medium) :: name='UNNAMED_BCOND' !< Bcond name (default=UNNAMED_BCOND) + integer :: type !< Bcond type + type(iterator) :: itr !< This is the iterator for the bcond - this identifies the (i,j,k) + character(len=1) :: face !< Bcond face (x/y/z) + integer :: dir !< Bcond direction (+1,-1,0 for interior) + real(WP) :: rdir !< Bcond direction (real variable) + logical :: canCorrect !< Can this bcond be corrected for global conservation? + end type bcond + + !> Incompressible solver object definition + type :: incomp + + ! This is our config + class(config), pointer :: cfg !< This is the config the solver is build for + + ! This is the name of the solver + character(len=str_medium) :: name='UNNAMED_INCOMP' !< Solver name (default=UNNAMED_INCOMP) + + ! Constant property fluid + real(WP) :: rho !< This is our constant fluid density + real(WP), dimension(:,:,:), allocatable :: visc !< These is our constant+SGS dynamic viscosity + + ! Gravitational acceleration + real(WP), dimension(3) :: gravity=0.0_WP !< Acceleration of gravity + + ! Boundary condition list + integer :: nbc !< Number of bcond for our solver + real(WP), dimension(:), allocatable :: mfr !< MFR through each bcond + real(WP), dimension(:), allocatable :: area !< Area for each bcond + real(WP) :: correctable_area !< Area of bcond that can be corrected + type(bcond), pointer :: first_bc !< List of bcond for our solver + + ! Flow variables + real(WP), dimension(:,:,:), allocatable :: U !< U velocity array + real(WP), dimension(:,:,:), allocatable :: V !< V velocity array + real(WP), dimension(:,:,:), allocatable :: W !< W velocity array + real(WP), dimension(:,:,:), allocatable :: P !< Pressure array + + ! Old flow variables + real(WP), dimension(:,:,:), allocatable :: Uold !< Uold velocity array + real(WP), dimension(:,:,:), allocatable :: Vold !< Vold velocity array + real(WP), dimension(:,:,:), allocatable :: Wold !< Wold velocity array + + ! Flow divergence + real(WP), dimension(:,:,:), allocatable :: div !< Divergence array + + ! Pressure solver + class(linsol), pointer :: psolv !< Iterative linear solver object for the pressure Poisson equation + + ! Implicit velocity solver + class(linsol), pointer :: implicit !< Iterative linear solver object for an implicit prediction of the NS residual + + ! Metrics + real(WP), dimension(:,:,:,:,:), allocatable :: itp_xy,itp_yz,itp_xz !< Interpolation for viscosity + real(WP), dimension(:,:,:,:), allocatable :: itpr_x,itpr_y,itpr_z !< Interpolation for density + real(WP), dimension(:,:,:,:), allocatable :: itpu_x,itpu_y,itpu_z !< Interpolation for U + real(WP), dimension(:,:,:,:), allocatable :: itpv_x,itpv_y,itpv_z !< Interpolation for V + real(WP), dimension(:,:,:,:), allocatable :: itpw_x,itpw_y,itpw_z !< Interpolation for W + real(WP), dimension(:,:,:,:), allocatable :: divp_x,divp_y,divp_z !< Divergence for P-cell + real(WP), dimension(:,:,:,:), allocatable :: divu_x,divu_y,divu_z !< Divergence for U-cell + real(WP), dimension(:,:,:,:), allocatable :: divv_x,divv_y,divv_z !< Divergence for V-cell + real(WP), dimension(:,:,:,:), allocatable :: divw_x,divw_y,divw_z !< Divergence for W-cell + real(WP), dimension(:,:,:,:), allocatable :: grdu_x,grdu_y,grdu_z !< Velocity gradient for U + real(WP), dimension(:,:,:,:), allocatable :: grdv_x,grdv_y,grdv_z !< Velocity gradient for V + real(WP), dimension(:,:,:,:), allocatable :: grdw_x,grdw_y,grdw_z !< Velocity gradient for W + + ! Masking info for metric modification + integer, dimension(:,:,:), allocatable :: mask !< Integer array used for modifying P metrics + integer, dimension(:,:,:), allocatable :: umask !< Integer array used for modifying U metrics + integer, dimension(:,:,:), allocatable :: vmask !< Integer array used for modifying V metrics + integer, dimension(:,:,:), allocatable :: wmask !< Integer array used for modifying W metrics + + ! CFL numbers + real(WP) :: CFLc_x,CFLc_y,CFLc_z !< Convective CFL numbers + real(WP) :: CFLv_x,CFLv_y,CFLv_z !< Viscous CFL numbers + + ! Monitoring quantities + real(WP) :: Umax,Vmax,Wmax,Pmax,divmax !< Maximum velocity, pressure, divergence + + contains + procedure :: print=>incomp_print !< Output solver to the screen + procedure :: setup !< Finish configuring the flow solver + procedure :: add_bcond !< Add a boundary condition + procedure :: get_bcond !< Get a boundary condition + procedure :: apply_bcond !< Apply all boundary conditions + procedure :: init_metrics !< Initialize metrics + procedure :: adjust_metrics !< Adjust metrics + procedure :: get_dmomdt !< Calculate dmom/dt + procedure :: get_div_stress !< Calculate div(stress) + procedure :: get_div !< Calculate velocity divergence + procedure :: get_pgrad !< Calculate pressure gradient + procedure :: get_cfl !< Calculate maximum CFL + procedure :: get_max !< Calculate maximum field values + procedure :: interp_vel !< Calculate interpolated velocity + procedure :: get_strainrate !< Calculate deviatoric part of strain rate tensor + procedure :: get_gradu !< Calculate velocity gradient tensor + procedure :: get_vorticity !< Calculate vorticity tensor + procedure :: get_mfr !< Calculate outgoing MFR through each bcond + procedure :: correct_mfr !< Correct for mfr mismatch to ensure global conservation + procedure :: shift_p !< Shift pressure to have zero average + procedure :: solve_implicit !< Solve for the velocity residuals implicitly + procedure :: addsrc_gravity !< Gravitational body force + end type incomp + + + !> Declare incompressible solver constructor + interface incomp + procedure constructor + end interface incomp + +contains + + + !> Default constructor for incompressible flow solver + function constructor(cfg,name) result(self) + implicit none + type(incomp) :: self + class(config), target, intent(in) :: cfg + character(len=*), optional :: name + integer :: i,j,k + + ! Set the name for the solver + if (present(name)) self%name=trim(adjustl(name)) + + ! Point to pgrid object + self%cfg=>cfg + + ! Nullify bcond list + self%nbc=0 + self%first_bc=>NULL() + + ! Allocate flow variables + allocate(self%U(self%cfg%imino_:self%cfg%imaxo_,self%cfg%jmino_:self%cfg%jmaxo_,self%cfg%kmino_:self%cfg%kmaxo_)); self%U=0.0_WP + allocate(self%V(self%cfg%imino_:self%cfg%imaxo_,self%cfg%jmino_:self%cfg%jmaxo_,self%cfg%kmino_:self%cfg%kmaxo_)); self%V=0.0_WP + allocate(self%W(self%cfg%imino_:self%cfg%imaxo_,self%cfg%jmino_:self%cfg%jmaxo_,self%cfg%kmino_:self%cfg%kmaxo_)); self%W=0.0_WP + allocate(self%P(self%cfg%imino_:self%cfg%imaxo_,self%cfg%jmino_:self%cfg%jmaxo_,self%cfg%kmino_:self%cfg%kmaxo_)); self%P=0.0_WP + + ! Allocate flow divergence + allocate(self%div(self%cfg%imino_:self%cfg%imaxo_,self%cfg%jmino_:self%cfg%jmaxo_,self%cfg%kmino_:self%cfg%kmaxo_)); self%div=0.0_WP + + ! Allocate fluid viscosity + allocate(self%visc(self%cfg%imino_:self%cfg%imaxo_,self%cfg%jmino_:self%cfg%jmaxo_,self%cfg%kmino_:self%cfg%kmaxo_)); self%visc=0.0_WP + + ! Allocate old flow variables + allocate(self%Uold(self%cfg%imino_:self%cfg%imaxo_,self%cfg%jmino_:self%cfg%jmaxo_,self%cfg%kmino_:self%cfg%kmaxo_)); self%Uold=0.0_WP + allocate(self%Vold(self%cfg%imino_:self%cfg%imaxo_,self%cfg%jmino_:self%cfg%jmaxo_,self%cfg%kmino_:self%cfg%kmaxo_)); self%Vold=0.0_WP + allocate(self%Wold(self%cfg%imino_:self%cfg%imaxo_,self%cfg%jmino_:self%cfg%jmaxo_,self%cfg%kmino_:self%cfg%kmaxo_)); self%Wold=0.0_WP + + ! Prepare default metrics + call self%init_metrics() + + ! Prepare P-cell masks + allocate(self%mask(self%cfg%imino_:self%cfg%imaxo_,self%cfg%jmino_:self%cfg%jmaxo_,self%cfg%kmino_:self%cfg%kmaxo_)); self%mask=0 + if (.not.self%cfg%xper) then + if (self%cfg%iproc.eq. 1) self%mask(:self%cfg%imin-1,:,:)=2 + if (self%cfg%iproc.eq.self%cfg%npx) self%mask(self%cfg%imax+1:,:,:)=2 + end if + if (.not.self%cfg%yper) then + if (self%cfg%jproc.eq. 1) self%mask(:,:self%cfg%jmin-1,:)=2 + if (self%cfg%jproc.eq.self%cfg%npy) self%mask(:,self%cfg%jmax+1:,:)=2 + end if + if (.not.self%cfg%zper) then + if (self%cfg%kproc.eq. 1) self%mask(:,:,:self%cfg%kmin-1)=2 + if (self%cfg%kproc.eq.self%cfg%npz) self%mask(:,:,self%cfg%kmax+1:)=2 + end if + do k=self%cfg%kmino_,self%cfg%kmaxo_ + do j=self%cfg%jmino_,self%cfg%jmaxo_ + do i=self%cfg%imino_,self%cfg%imaxo_ + if (self%cfg%VF(i,j,k).eq.0.0_WP) self%mask(i,j,k)=1 + end do + end do + end do + call self%cfg%sync(self%mask) + + ! Prepare face mask for U + allocate(self%umask(self%cfg%imino_:self%cfg%imaxo_,self%cfg%jmino_:self%cfg%jmaxo_,self%cfg%kmino_:self%cfg%kmaxo_)); self%umask=0 + if (.not.self%cfg%xper) then + if (self%cfg%iproc.eq. 1) self%umask(self%cfg%imin ,:,:)=2 + if (self%cfg%iproc.eq.self%cfg%npx) self%umask(self%cfg%imax+1,:,:)=2 + end if + do k=self%cfg%kmino_ ,self%cfg%kmaxo_ + do j=self%cfg%jmino_ ,self%cfg%jmaxo_ + do i=self%cfg%imino_+1,self%cfg%imaxo_ + if (minval(self%cfg%VF(i-1:i,j,k)).eq.0.0_WP) self%umask(i,j,k)=1 + end do + end do + end do + call self%cfg%sync(self%umask) + if (.not.self%cfg%xper.and.self%cfg%iproc.eq.1) self%umask(self%cfg%imino,:,:)=self%umask(self%cfg%imino+1,:,:) + + ! Prepare face mask for V + allocate(self%vmask(self%cfg%imino_:self%cfg%imaxo_,self%cfg%jmino_:self%cfg%jmaxo_,self%cfg%kmino_:self%cfg%kmaxo_)); self%vmask=0 + if (.not.self%cfg%yper) then + if (self%cfg%jproc.eq. 1) self%vmask(:,self%cfg%jmin ,:)=2 + if (self%cfg%jproc.eq.self%cfg%npy) self%vmask(:,self%cfg%jmax+1,:)=2 + end if + do k=self%cfg%kmino_ ,self%cfg%kmaxo_ + do j=self%cfg%jmino_+1,self%cfg%jmaxo_ + do i=self%cfg%imino_ ,self%cfg%imaxo_ + if (minval(self%cfg%VF(i,j-1:j,k)).eq.0.0_WP) self%vmask(i,j,k)=1 + end do + end do + end do + call self%cfg%sync(self%vmask) + if (.not.self%cfg%yper.and.self%cfg%jproc.eq.1) self%vmask(:,self%cfg%jmino,:)=self%vmask(:,self%cfg%jmino+1,:) + + ! Prepare face mask for W + allocate(self%wmask(self%cfg%imino_:self%cfg%imaxo_,self%cfg%jmino_:self%cfg%jmaxo_,self%cfg%kmino_:self%cfg%kmaxo_)); self%wmask=0 + if (.not.self%cfg%zper) then + if (self%cfg%kproc.eq. 1) self%wmask(:,:,self%cfg%kmin )=2 + if (self%cfg%kproc.eq.self%cfg%npz) self%wmask(:,:,self%cfg%kmax+1)=2 + end if + do k=self%cfg%kmino_+1,self%cfg%kmaxo_ + do j=self%cfg%jmino_ ,self%cfg%jmaxo_ + do i=self%cfg%imino_ ,self%cfg%imaxo_ + if (minval(self%cfg%VF(i,j,k-1:k)).eq.0.0_WP) self%wmask(i,j,k)=1 + end do + end do + end do + call self%cfg%sync(self%wmask) + if (.not.self%cfg%zper.and.self%cfg%kproc.eq.1) self%wmask(:,:,self%cfg%kmino)=self%wmask(:,:,self%cfg%kmino+1) + + end function constructor + + + !> Metric initialization with no awareness of walls nor bcond + subroutine init_metrics(this) + implicit none + class(incomp), intent(inout) :: this + integer :: i,j,k,st1,st2 + real(WP), dimension(-1:0) :: itpx,itpy,itpz + + ! Allocate finite difference density (or other things) interpolation coefficients + allocate(this%itpr_x(-1:0,this%cfg%imin_:this%cfg%imax_+1,this%cfg%jmin_:this%cfg%jmax_+1,this%cfg%kmin_:this%cfg%kmax_+1)) !< X-face-centered + allocate(this%itpr_y(-1:0,this%cfg%imin_:this%cfg%imax_+1,this%cfg%jmin_:this%cfg%jmax_+1,this%cfg%kmin_:this%cfg%kmax_+1)) !< Y-face-centered + allocate(this%itpr_z(-1:0,this%cfg%imin_:this%cfg%imax_+1,this%cfg%jmin_:this%cfg%jmax_+1,this%cfg%kmin_:this%cfg%kmax_+1)) !< Z-face-centered + ! Create density (or other things) interpolation coefficients to cell face + do k=this%cfg%kmin_,this%cfg%kmax_+1 + do j=this%cfg%jmin_,this%cfg%jmax_+1 + do i=this%cfg%imin_,this%cfg%imax_+1 + this%itpr_x(:,i,j,k)=this%cfg%dxmi(i)*[this%cfg%xm(i)-this%cfg%x(i),this%cfg%x(i)-this%cfg%xm(i-1)] !< Linear interpolation in x from [xm,ym,zm] to [x,ym,zm] + this%itpr_y(:,i,j,k)=this%cfg%dymi(j)*[this%cfg%ym(j)-this%cfg%y(j),this%cfg%y(j)-this%cfg%ym(j-1)] !< Linear interpolation in y from [xm,ym,zm] to [xm,y,zm] + this%itpr_z(:,i,j,k)=this%cfg%dzmi(k)*[this%cfg%zm(k)-this%cfg%z(k),this%cfg%z(k)-this%cfg%zm(k-1)] !< Linear interpolation in z from [xm,ym,zm] to [xm,ym,z] + end do + end do + end do + + ! Allocate finite difference viscosity interpolation coefficients + allocate(this%itp_xy(-1:0,-1:0,this%cfg%imino_+1:this%cfg%imaxo_,this%cfg%jmino_+1:this%cfg%jmaxo_,this%cfg%kmino_+1:this%cfg%kmaxo_)) !< Edge-centered (xy) + allocate(this%itp_yz(-1:0,-1:0,this%cfg%imino_+1:this%cfg%imaxo_,this%cfg%jmino_+1:this%cfg%jmaxo_,this%cfg%kmino_+1:this%cfg%kmaxo_)) !< Edge-centered (yz) + allocate(this%itp_xz(-1:0,-1:0,this%cfg%imino_+1:this%cfg%imaxo_,this%cfg%jmino_+1:this%cfg%jmaxo_,this%cfg%kmino_+1:this%cfg%kmaxo_)) !< Edge-centered (zx) + ! Create viscosity interpolation coefficients to cell edge + do k=this%cfg%kmino_+1,this%cfg%kmaxo_ + do j=this%cfg%jmino_+1,this%cfg%jmaxo_ + do i=this%cfg%imino_+1,this%cfg%imaxo_ + ! Prepare local 1D metrics + itpx=this%cfg%dxmi(i)*[this%cfg%xm(i)-this%cfg%x(i),this%cfg%x(i)-this%cfg%xm(i-1)] + itpy=this%cfg%dymi(j)*[this%cfg%ym(j)-this%cfg%y(j),this%cfg%y(j)-this%cfg%ym(j-1)] + itpz=this%cfg%dzmi(k)*[this%cfg%zm(k)-this%cfg%z(k),this%cfg%z(k)-this%cfg%zm(k-1)] + ! Combine for 2D interpolations + do st1=-1,0 + do st2=-1,0 + this%itp_xy(st1,st2,i,j,k)=itpx(st1)*itpy(st2) + this%itp_yz(st1,st2,i,j,k)=itpy(st1)*itpz(st2) + this%itp_xz(st1,st2,i,j,k)=itpx(st1)*itpz(st2) + end do + end do + end do + end do + end do + + ! Allocate finite difference velocity interpolation coefficients + allocate(this%itpu_x( 0:+1,this%cfg%imino_ :this%cfg%imaxo_,this%cfg%jmino_ :this%cfg%jmaxo_,this%cfg%kmino_ :this%cfg%kmaxo_)) !< Cell-centered + allocate(this%itpv_y( 0:+1,this%cfg%imino_ :this%cfg%imaxo_,this%cfg%jmino_ :this%cfg%jmaxo_,this%cfg%kmino_ :this%cfg%kmaxo_)) !< Cell-centered + allocate(this%itpw_z( 0:+1,this%cfg%imino_ :this%cfg%imaxo_,this%cfg%jmino_ :this%cfg%jmaxo_,this%cfg%kmino_ :this%cfg%kmaxo_)) !< Cell-centered + allocate(this%itpv_x(-1: 0,this%cfg%imino_+1:this%cfg%imaxo_,this%cfg%jmino_ :this%cfg%jmaxo_,this%cfg%kmino_ :this%cfg%kmaxo_)) !< Edge-centered (xy) + allocate(this%itpw_x(-1: 0,this%cfg%imino_+1:this%cfg%imaxo_,this%cfg%jmino_ :this%cfg%jmaxo_,this%cfg%kmino_ :this%cfg%kmaxo_)) !< Edge-centered (zx) + allocate(this%itpu_y(-1: 0,this%cfg%imino_ :this%cfg%imaxo_,this%cfg%jmino_+1:this%cfg%jmaxo_,this%cfg%kmino_ :this%cfg%kmaxo_)) !< Edge-centered (xy) + allocate(this%itpw_y(-1: 0,this%cfg%imino_ :this%cfg%imaxo_,this%cfg%jmino_+1:this%cfg%jmaxo_,this%cfg%kmino_ :this%cfg%kmaxo_)) !< Edge-centered (yz) + allocate(this%itpu_z(-1: 0,this%cfg%imino_ :this%cfg%imaxo_,this%cfg%jmino_ :this%cfg%jmaxo_,this%cfg%kmino_+1:this%cfg%kmaxo_)) !< Edge-centered (zx) + allocate(this%itpv_z(-1: 0,this%cfg%imino_ :this%cfg%imaxo_,this%cfg%jmino_ :this%cfg%jmaxo_,this%cfg%kmino_+1:this%cfg%kmaxo_)) !< Edge-centered (yz) + ! Create velocity interpolation coefficients to cell center [xm,ym,zm] + do k=this%cfg%kmino_,this%cfg%kmaxo_ + do j=this%cfg%jmino_,this%cfg%jmaxo_ + do i=this%cfg%imino_,this%cfg%imaxo_ + this%itpu_x(:,i,j,k)=[+0.5_WP,+0.5_WP] !< Linear interpolation in x of U from [x ,ym,zm] + this%itpv_y(:,i,j,k)=[+0.5_WP,+0.5_WP] !< Linear interpolation in y of V from [xm,y ,zm] + this%itpw_z(:,i,j,k)=[+0.5_WP,+0.5_WP] !< Linear interpolation in z of W from [xm,ym,z ] + end do + end do + end do + ! Create velocity interpolation coefficients to cell edge in x + do k=this%cfg%kmino_ ,this%cfg%kmaxo_ + do j=this%cfg%jmino_ ,this%cfg%jmaxo_ + do i=this%cfg%imino_+1,this%cfg%imaxo_ + this%itpv_x(:,i,j,k)=this%cfg%dxmi(i)*[this%cfg%xm(i)-this%cfg%x(i),this%cfg%x(i)-this%cfg%xm(i-1)] !< Linear interpolation in x of V from [xm,y ,zm] + this%itpw_x(:,i,j,k)=this%cfg%dxmi(i)*[this%cfg%xm(i)-this%cfg%x(i),this%cfg%x(i)-this%cfg%xm(i-1)] !< Linear interpolation in x of W from [xm,ym,z ] + end do + end do + end do + ! Create velocity interpolation coefficients to cell edge in y + do k=this%cfg%kmino_ ,this%cfg%kmaxo_ + do j=this%cfg%jmino_+1,this%cfg%jmaxo_ + do i=this%cfg%imino_ ,this%cfg%imaxo_ + this%itpu_y(:,i,j,k)=this%cfg%dymi(j)*[this%cfg%ym(j)-this%cfg%y(j),this%cfg%y(j)-this%cfg%ym(j-1)] !< Linear interpolation in y of U from [x ,ym,zm] + this%itpw_y(:,i,j,k)=this%cfg%dymi(j)*[this%cfg%ym(j)-this%cfg%y(j),this%cfg%y(j)-this%cfg%ym(j-1)] !< Linear interpolation in y of W from [xm,ym,z ] + end do + end do + end do + ! Create velocity interpolation coefficients to cell edge in z + do k=this%cfg%kmino_+1,this%cfg%kmaxo_ + do j=this%cfg%jmino_ ,this%cfg%jmaxo_ + do i=this%cfg%imino_ ,this%cfg%imaxo_ + this%itpu_z(:,i,j,k)=this%cfg%dzmi(k)*[this%cfg%zm(k)-this%cfg%z(k),this%cfg%z(k)-this%cfg%zm(k-1)] !< Linear interpolation in z of U from [x ,ym,zm] + this%itpv_z(:,i,j,k)=this%cfg%dzmi(k)*[this%cfg%zm(k)-this%cfg%z(k),this%cfg%z(k)-this%cfg%zm(k-1)] !< Linear interpolation in z of V from [xm,y ,zm] + end do + end do + end do + + ! Allocate finite volume divergence operators + allocate(this%divp_x( 0:+1,this%cfg%imino_ :this%cfg%imaxo_,this%cfg%jmino_ :this%cfg%jmaxo_,this%cfg%kmino_ :this%cfg%kmaxo_)) !< Cell-centered + allocate(this%divp_y( 0:+1,this%cfg%imino_ :this%cfg%imaxo_,this%cfg%jmino_ :this%cfg%jmaxo_,this%cfg%kmino_ :this%cfg%kmaxo_)) !< Cell-centered + allocate(this%divp_z( 0:+1,this%cfg%imino_ :this%cfg%imaxo_,this%cfg%jmino_ :this%cfg%jmaxo_,this%cfg%kmino_ :this%cfg%kmaxo_)) !< Cell-centered + allocate(this%divu_x(-1: 0,this%cfg%imino_+1:this%cfg%imaxo_,this%cfg%jmino_ :this%cfg%jmaxo_,this%cfg%kmino_ :this%cfg%kmaxo_)) !< Face-centered (x) + allocate(this%divu_y( 0:+1,this%cfg%imino_ :this%cfg%imaxo_,this%cfg%jmino_ :this%cfg%jmaxo_,this%cfg%kmino_ :this%cfg%kmaxo_)) !< Face-centered (x) + allocate(this%divu_z( 0:+1,this%cfg%imino_ :this%cfg%imaxo_,this%cfg%jmino_ :this%cfg%jmaxo_,this%cfg%kmino_ :this%cfg%kmaxo_)) !< Face-centered (x) + allocate(this%divv_x( 0:+1,this%cfg%imino_ :this%cfg%imaxo_,this%cfg%jmino_ :this%cfg%jmaxo_,this%cfg%kmino_ :this%cfg%kmaxo_)) !< Face-centered (y) + allocate(this%divv_y(-1: 0,this%cfg%imino_ :this%cfg%imaxo_,this%cfg%jmino_+1:this%cfg%jmaxo_,this%cfg%kmino_ :this%cfg%kmaxo_)) !< Face-centered (y) + allocate(this%divv_z( 0:+1,this%cfg%imino_ :this%cfg%imaxo_,this%cfg%jmino_ :this%cfg%jmaxo_,this%cfg%kmino_ :this%cfg%kmaxo_)) !< Face-centered (y) + allocate(this%divw_x( 0:+1,this%cfg%imino_ :this%cfg%imaxo_,this%cfg%jmino_ :this%cfg%jmaxo_,this%cfg%kmino_ :this%cfg%kmaxo_)) !< Face-centered (z) + allocate(this%divw_y( 0:+1,this%cfg%imino_ :this%cfg%imaxo_,this%cfg%jmino_ :this%cfg%jmaxo_,this%cfg%kmino_ :this%cfg%kmaxo_)) !< Face-centered (z) + allocate(this%divw_z(-1: 0,this%cfg%imino_ :this%cfg%imaxo_,this%cfg%jmino_ :this%cfg%jmaxo_,this%cfg%kmino_+1:this%cfg%kmaxo_)) !< Face-centered (z) + ! Create divergence operator to cell center [xm,ym,zm] or tangent to cell face + do k=this%cfg%kmino_,this%cfg%kmaxo_ + do j=this%cfg%jmino_,this%cfg%jmaxo_ + do i=this%cfg%imino_,this%cfg%imaxo_ + this%divp_x(:,i,j,k)=this%cfg%dxi(i)*[-1.0_WP,+1.0_WP] !< FV divergence from [x ,ym,zm] + this%divp_y(:,i,j,k)=this%cfg%dyi(j)*[-1.0_WP,+1.0_WP] !< FV divergence from [xm,y ,zm] + this%divp_z(:,i,j,k)=this%cfg%dzi(k)*[-1.0_WP,+1.0_WP] !< FV divergence from [xm,ym,z ] + + this%divu_y(:,i,j,k)=this%cfg%dyi(j)*[-1.0_WP,+1.0_WP] !< FV divergence from [x ,y ,zm] + this%divu_z(:,i,j,k)=this%cfg%dzi(k)*[-1.0_WP,+1.0_WP] !< FV divergence from [x ,ym,z ] + + this%divv_x(:,i,j,k)=this%cfg%dxi(i)*[-1.0_WP,+1.0_WP] !< FV divergence from [x ,y ,zm] + this%divv_z(:,i,j,k)=this%cfg%dzi(k)*[-1.0_WP,+1.0_WP] !< FV divergence from [xm,y ,z ] + + this%divw_x(:,i,j,k)=this%cfg%dxi(i)*[-1.0_WP,+1.0_WP] !< FV divergence from [x ,ym,z ] + this%divw_y(:,i,j,k)=this%cfg%dyi(j)*[-1.0_WP,+1.0_WP] !< FV divergence from [xm,y ,z ] + end do + end do + end do + ! Create divergence operator perpendicular to cell face [x ,ym,zm] + do k=this%cfg%kmino_ ,this%cfg%kmaxo_ + do j=this%cfg%jmino_ ,this%cfg%jmaxo_ + do i=this%cfg%imino_+1,this%cfg%imaxo_ + this%divu_x(:,i,j,k)=this%cfg%dxmi(i)*[-1.0_WP,+1.0_WP] !< FV divergence from [xm,ym,zm] + end do + end do + end do + ! Create divergence operator perpendicular to cell face [xm,y ,zm] + do k=this%cfg%kmino_ ,this%cfg%kmaxo_ + do j=this%cfg%jmino_+1,this%cfg%jmaxo_ + do i=this%cfg%imino_ ,this%cfg%imaxo_ + this%divv_y(:,i,j,k)=this%cfg%dymi(j)*[-1.0_WP,+1.0_WP] !< FV divergence from [xm,ym,zm] + end do + end do + end do + ! Create divergence operator perpendicular to cell face [xm,ym,z ] + do k=this%cfg%kmino_+1,this%cfg%kmaxo_ + do j=this%cfg%jmino_ ,this%cfg%jmaxo_ + do i=this%cfg%imino_ ,this%cfg%imaxo_ + this%divw_z(:,i,j,k)=this%cfg%dzmi(k)*[-1.0_WP,+1.0_WP] !< FV divergence from [xm,ym,zm] + end do + end do + end do + + ! Allocate finite difference velocity gradient operators + allocate(this%grdu_x( 0:+1,this%cfg%imino_ :this%cfg%imaxo_,this%cfg%jmino_ :this%cfg%jmaxo_,this%cfg%kmino_ :this%cfg%kmaxo_)) !< Cell-centered + allocate(this%grdv_y( 0:+1,this%cfg%imino_ :this%cfg%imaxo_,this%cfg%jmino_ :this%cfg%jmaxo_,this%cfg%kmino_ :this%cfg%kmaxo_)) !< Cell-centered + allocate(this%grdw_z( 0:+1,this%cfg%imino_ :this%cfg%imaxo_,this%cfg%jmino_ :this%cfg%jmaxo_,this%cfg%kmino_ :this%cfg%kmaxo_)) !< Cell-centered + allocate(this%grdv_x(-1: 0,this%cfg%imino_+1:this%cfg%imaxo_,this%cfg%jmino_ :this%cfg%jmaxo_,this%cfg%kmino_ :this%cfg%kmaxo_)) !< Edge-centered (xy) + allocate(this%grdw_x(-1: 0,this%cfg%imino_+1:this%cfg%imaxo_,this%cfg%jmino_ :this%cfg%jmaxo_,this%cfg%kmino_ :this%cfg%kmaxo_)) !< Edge-centered (zx) + allocate(this%grdu_y(-1: 0,this%cfg%imino_ :this%cfg%imaxo_,this%cfg%jmino_+1:this%cfg%jmaxo_,this%cfg%kmino_ :this%cfg%kmaxo_)) !< Edge-centered (xy) + allocate(this%grdw_y(-1: 0,this%cfg%imino_ :this%cfg%imaxo_,this%cfg%jmino_+1:this%cfg%jmaxo_,this%cfg%kmino_ :this%cfg%kmaxo_)) !< Edge-centered (yz) + allocate(this%grdu_z(-1: 0,this%cfg%imino_ :this%cfg%imaxo_,this%cfg%jmino_ :this%cfg%jmaxo_,this%cfg%kmino_+1:this%cfg%kmaxo_)) !< Edge-centered (zx) + allocate(this%grdv_z(-1: 0,this%cfg%imino_ :this%cfg%imaxo_,this%cfg%jmino_ :this%cfg%jmaxo_,this%cfg%kmino_+1:this%cfg%kmaxo_)) !< Edge-centered (yz) + ! Create gradient coefficients to cell center [xm,ym,zm] + do k=this%cfg%kmino_,this%cfg%kmaxo_ + do j=this%cfg%jmino_,this%cfg%jmaxo_ + do i=this%cfg%imino_,this%cfg%imaxo_ + this%grdu_x(:,i,j,k)=this%cfg%dxi(i)*[-1.0_WP,+1.0_WP] !< FD gradient in x of U from [x ,ym,zm] + this%grdv_y(:,i,j,k)=this%cfg%dyi(j)*[-1.0_WP,+1.0_WP] !< FD gradient in y of V from [xm,y ,zm] + this%grdw_z(:,i,j,k)=this%cfg%dzi(k)*[-1.0_WP,+1.0_WP] !< FD gradient in z of W from [xm,ym,z ] + end do + end do + end do + ! Create gradient coefficients to cell edge in x + do k=this%cfg%kmino_ ,this%cfg%kmaxo_ + do j=this%cfg%jmino_ ,this%cfg%jmaxo_ + do i=this%cfg%imino_+1,this%cfg%imaxo_ + this%grdv_x(:,i,j,k)=this%cfg%dxmi(i)*[-1.0_WP,+1.0_WP] !< FD gradient in x of V from [xm,y ,zm] + this%grdw_x(:,i,j,k)=this%cfg%dxmi(i)*[-1.0_WP,+1.0_WP] !< FD gradient in x of W from [xm,ym,z ] + end do + end do + end do + ! Create gradient coefficients to cell edge in y + do k=this%cfg%kmino_ ,this%cfg%kmaxo_ + do j=this%cfg%jmino_+1,this%cfg%jmaxo_ + do i=this%cfg%imino_ ,this%cfg%imaxo_ + this%grdu_y(:,i,j,k)=this%cfg%dymi(j)*[-1.0_WP,+1.0_WP] !< FD gradient in y of U from [x ,ym,zm] + this%grdw_y(:,i,j,k)=this%cfg%dymi(j)*[-1.0_WP,+1.0_WP] !< FD gradient in y of W from [xm,ym,z ] + end do + end do + end do + ! Create gradient coefficients to cell edge in z + do k=this%cfg%kmino_+1,this%cfg%kmaxo_ + do j=this%cfg%jmino_ ,this%cfg%jmaxo_ + do i=this%cfg%imino_ ,this%cfg%imaxo_ + this%grdu_z(:,i,j,k)=this%cfg%dzmi(k)*[-1.0_WP,+1.0_WP] !< FD gradient in z of U from [x ,ym,zm] + this%grdv_z(:,i,j,k)=this%cfg%dzmi(k)*[-1.0_WP,+1.0_WP] !< FD gradient in z of V from [xm,y ,zm] + end do + end do + end do + + end subroutine init_metrics + + + !> Metric adjustment accounting for bconds and walls + subroutine adjust_metrics(this) + implicit none + class(incomp), intent(inout) :: this + integer :: i,j,k,st1,st2 + real(WP) :: delta,mysum + + ! Sync up u/v/wmasks + call this%cfg%sync(this%umask) + call this%cfg%sync(this%vmask) + call this%cfg%sync(this%wmask) + if (.not.this%cfg%xper.and.this%cfg%iproc.eq.1) this%umask(this%cfg%imino,:,:)=this%umask(this%cfg%imino+1,:,:) + if (.not.this%cfg%yper.and.this%cfg%jproc.eq.1) this%vmask(:,this%cfg%jmino,:)=this%vmask(:,this%cfg%jmino+1,:) + if (.not.this%cfg%zper.and.this%cfg%kproc.eq.1) this%wmask(:,:,this%cfg%kmino)=this%wmask(:,:,this%cfg%kmino+1) + + ! I am assuming here that we do not really need to zero out wall cells + ! as they could be used for Dirichlet (then the density needs to be available! could be problematic if we do not have an explicit BC for scalars, e.g. for a Couette flow) + ! or outflow condition (then the density needs to be available but it should be directly calculated) + ! or used for a real no-slip wall (then density is always multiplied by zero) + ! Adjust density interpolation coefficients to cell faces in the presence of walls (only walls!) + !do k=this%cfg%kmin_,this%cfg%kmax_+1 + ! do j=this%cfg%jmin_,this%cfg%jmax_+1 + ! do i=this%cfg%imin_,this%cfg%imax_+1 + ! ! Linear interpolation in x + ! if (this%cfg%VF(i,j,k).eq.0.0_WP.and.this%cfg%VF(i-1,j,k).gt.0.0_WP) this%itpr_x(:,i,j,k)=[1.0_WP,0.0_WP] + ! if (this%cfg%VF(i,j,k).gt.0.0_WP.and.this%cfg%VF(i-1,j,k).eq.0.0_WP) this%itpr_x(:,i,j,k)=[0.0_WP,1.0_WP] + ! ! Linear interpolation in y + ! if (this%cfg%VF(i,j,k).eq.0.0_WP.and.this%cfg%VF(i,j-1,k).gt.0.0_WP) this%itpr_y(:,i,j,k)=[1.0_WP,0.0_WP] + ! if (this%cfg%VF(i,j,k).gt.0.0_WP.and.this%cfg%VF(i,j-1,k).eq.0.0_WP) this%itpr_y(:,i,j,k)=[0.0_WP,1.0_WP] + ! ! Linear interpolation in z + ! if (this%cfg%VF(i,j,k).eq.0.0_WP.and.this%cfg%VF(i,j,k-1).gt.0.0_WP) this%itpr_z(:,i,j,k)=[1.0_WP,0.0_WP] + ! if (this%cfg%VF(i,j,k).gt.0.0_WP.and.this%cfg%VF(i,j,k-1).eq.0.0_WP) this%itpr_z(:,i,j,k)=[0.0_WP,1.0_WP] + ! end do + ! end do + !end do + + ! Adjust interpolation coefficients to cell centers in the presence of walls (only walls!) + do k=this%cfg%kmino_,this%cfg%kmaxo_ + do j=this%cfg%jmino_,this%cfg%jmaxo_ + do i=this%cfg%imino_,this%cfg%imaxo_ + if (this%mask(i,j,k).eq.1) this%itpu_x(:,i,j,k)=0.0_WP + if (this%mask(i,j,k).eq.1) this%itpv_y(:,i,j,k)=0.0_WP + if (this%mask(i,j,k).eq.1) this%itpw_z(:,i,j,k)=0.0_WP + end do + end do + end do + + ! Adjust viscosity interpolation coefficients to cell edge in the presence of walls (only walls) + do k=this%cfg%kmino_+1,this%cfg%kmaxo_ + do j=this%cfg%jmino_+1,this%cfg%jmaxo_ + do i=this%cfg%imino_+1,this%cfg%imaxo_ + ! Zero out interpolation coefficients reaching in the walls + do st1=-1,0 + do st2=-1,0 + if (this%mask(i+st1,j+st2,k).eq.1) this%itp_xy(st1,st2,i,j,k)=0.0_WP + if (this%mask(i,j+st1,k+st2).eq.1) this%itp_yz(st1,st2,i,j,k)=0.0_WP + if (this%mask(i+st1,j,k+st2).eq.1) this%itp_xz(st1,st2,i,j,k)=0.0_WP + end do + end do + ! Rescale to ensure sum(itp)=1 + mysum=sum(this%itp_xy(:,:,i,j,k)); if (mysum.gt.0.0_WP) this%itp_xy(:,:,i,j,k)=this%itp_xy(:,:,i,j,k)/mysum + mysum=sum(this%itp_yz(:,:,i,j,k)); if (mysum.gt.0.0_WP) this%itp_yz(:,:,i,j,k)=this%itp_yz(:,:,i,j,k)/mysum + mysum=sum(this%itp_xz(:,:,i,j,k)); if (mysum.gt.0.0_WP) this%itp_xz(:,:,i,j,k)=this%itp_xz(:,:,i,j,k)/mysum + end do + end do + end do + + ! Loop over the domain and adjust divergence for P cell + do k=this%cfg%kmino_,this%cfg%kmaxo_ + do j=this%cfg%jmino_,this%cfg%jmaxo_ + do i=this%cfg%imino_,this%cfg%imaxo_ + if (this%mask(i,j,k).gt.0) then + this%divp_x(:,i,j,k)=0.0_WP + this%divp_y(:,i,j,k)=0.0_WP + this%divp_z(:,i,j,k)=0.0_WP + end if + end do + end do + end do + + ! Loop over the domain and apply masked conditions to U metrics + do k=this%cfg%kmino_ ,this%cfg%kmaxo_ + do j=this%cfg%jmino_ ,this%cfg%jmaxo_ + do i=this%cfg%imino_+1,this%cfg%imaxo_ + if (this%umask(i,j,k).gt.0) then + this%divu_x(:,i,j,k)=0.0_WP + this%divu_y(:,i,j,k)=0.0_WP + this%divu_z(:,i,j,k)=0.0_WP + end if + end do + end do + end do + + ! Loop over the domain and apply masked conditions to V metrics + do k=this%cfg%kmino_ ,this%cfg%kmaxo_ + do j=this%cfg%jmino_+1,this%cfg%jmaxo_ + do i=this%cfg%imino_ ,this%cfg%imaxo_ + if (this%vmask(i,j,k).gt.0) then + this%divv_x(:,i,j,k)=0.0_WP + this%divv_y(:,i,j,k)=0.0_WP + this%divv_z(:,i,j,k)=0.0_WP + end if + end do + end do + end do + + ! Loop over the domain and apply masked conditions to W metrics + do k=this%cfg%kmino_+1,this%cfg%kmaxo_ + do j=this%cfg%jmino_ ,this%cfg%jmaxo_ + do i=this%cfg%imino_ ,this%cfg%imaxo_ + if (this%wmask(i,j,k).gt.0) then + this%divw_x(:,i,j,k)=0.0_WP + this%divw_y(:,i,j,k)=0.0_WP + this%divw_z(:,i,j,k)=0.0_WP + end if + end do + end do + end do + + ! Adjust gradient coefficients to cell edge in x + do k=this%cfg%kmino_ ,this%cfg%kmaxo_ + do j=this%cfg%jmino_ ,this%cfg%jmaxo_ + do i=this%cfg%imino_+1,this%cfg%imaxo_ + ! FD gradient in x of V from [xm,y ,zm] + if (maxval(this%vmask(i-1:i,j,k)).gt.0) then + delta=0.0_WP + if (this%vmask(i ,j,k).eq.0) delta=delta+(this%cfg%xm(i)-this%cfg%x (i )) + if (this%vmask(i-1,j,k).eq.0) delta=delta+(this%cfg%x (i)-this%cfg%xm(i-1)) + if (delta.gt.0.0_WP) then + this%grdv_x(:,i,j,k)=[-1.0_WP,+1.0_WP]/delta + else + this%grdv_x(:,i,j,k)=0.0_WP + end if + end if + ! FD gradient in x of W from [xm,ym,z ] + if (maxval(this%wmask(i-1:i,j,k)).gt.0) then + delta=0.0_WP + if (this%wmask(i ,j,k).eq.0) delta=delta+(this%cfg%xm(i)-this%cfg%x (i )) + if (this%wmask(i-1,j,k).eq.0) delta=delta+(this%cfg%x (i)-this%cfg%xm(i-1)) + if (delta.gt.0.0_WP) then + this%grdw_x(:,i,j,k)=[-1.0_WP,+1.0_WP]/delta + else + this%grdw_x(:,i,j,k)=0.0_WP + end if + end if + end do + end do + end do + + ! Adjust gradient coefficients to cell edge in y + do k=this%cfg%kmino_ ,this%cfg%kmaxo_ + do j=this%cfg%jmino_+1,this%cfg%jmaxo_ + do i=this%cfg%imino_ ,this%cfg%imaxo_ + ! FD gradient in y of U from [x ,ym,zm] + if (maxval(this%umask(i,j-1:j,k)).gt.0) then + delta=0.0_WP + if (this%umask(i,j ,k).eq.0) delta=delta+(this%cfg%ym(j)-this%cfg%y (j )) + if (this%umask(i,j-1,k).eq.0) delta=delta+(this%cfg%y (j)-this%cfg%ym(j-1)) + if (delta.gt.0.0_WP) then + this%grdu_y(:,i,j,k)=[-1.0_WP,+1.0_WP]/delta + else + this%grdu_y(:,i,j,k)=0.0_WP + end if + end if + ! FD gradient in y of W from [xm,ym,z ] + if (maxval(this%wmask(i,j-1:j,k)).gt.0) then + delta=0.0_WP + if (this%wmask(i,j ,k).eq.0) delta=delta+(this%cfg%ym(j)-this%cfg%y (j )) + if (this%wmask(i,j-1,k).eq.0) delta=delta+(this%cfg%y (j)-this%cfg%ym(j-1)) + if (delta.gt.0.0_WP) then + this%grdw_y(:,i,j,k)=[-1.0_WP,+1.0_WP]/delta + else + this%grdw_y(:,i,j,k)=0.0_WP + end if + end if + end do + end do + end do + + ! Adjust gradient coefficients to cell edge in z + do k=this%cfg%kmino_+1,this%cfg%kmaxo_ + do j=this%cfg%jmino_ ,this%cfg%jmaxo_ + do i=this%cfg%imino_ ,this%cfg%imaxo_ + ! FD gradient in z of U from [x ,ym,zm] + if (maxval(this%umask(i,j,k-1:k)).gt.0) then + delta=0.0_WP + if (this%umask(i,j,k ).eq.0) delta=delta+(this%cfg%zm(k)-this%cfg%z (k )) + if (this%umask(i,j,k-1).eq.0) delta=delta+(this%cfg%z (k)-this%cfg%zm(k-1)) + if (delta.gt.0.0_WP) then + this%grdu_z(:,i,j,k)=[-1.0_WP,+1.0_WP]/delta + else + this%grdu_z(:,i,j,k)=0.0_WP + end if + end if + ! FD gradient in z of V from [xm,y ,zm] + if (maxval(this%vmask(i,j,k-1:k)).gt.0) then + delta=0.0_WP + if (this%vmask(i,j,k ).eq.0) delta=delta+(this%cfg%zm(k)-this%cfg%z (k )) + if (this%vmask(i,j,k-1).eq.0) delta=delta+(this%cfg%z (k)-this%cfg%zm(k-1)) + if (delta.gt.0.0_WP) then + this%grdv_z(:,i,j,k)=[-1.0_WP,+1.0_WP]/delta + else + this%grdv_z(:,i,j,k)=0.0_WP + end if + end if + end do + end do + end do + + ! Adjust interpolation coefficients to cell centers in the presence of walls (only walls!) + do k=this%cfg%kmino_,this%cfg%kmaxo_ + do j=this%cfg%jmino_,this%cfg%jmaxo_ + do i=this%cfg%imino_,this%cfg%imaxo_ + if (this%mask(i,j,k).eq.1) this%itpu_x(:,i,j,k)=0.0_WP + if (this%mask(i,j,k).eq.1) this%itpv_y(:,i,j,k)=0.0_WP + if (this%mask(i,j,k).eq.1) this%itpw_z(:,i,j,k)=0.0_WP + end do + end do + end do + + ! Adjust interpolation coefficients to cell edge in x + do k=this%cfg%kmino_ ,this%cfg%kmaxo_ + do j=this%cfg%jmino_ ,this%cfg%jmaxo_ + do i=this%cfg%imino_+1,this%cfg%imaxo_ + ! Linear interpolation in x of V from [xm,y ,zm] + if (this%vmask(i,j,k).eq.0.and.this%vmask(i-1,j,k).gt.0) this%itpv_x(:,i,j,k)=[1.0_WP,0.0_WP] + if (this%vmask(i,j,k).gt.0.and.this%vmask(i-1,j,k).eq.0) this%itpv_x(:,i,j,k)=[0.0_WP,1.0_WP] + ! Linear interpolation in x of W from [xm,ym,z ] + if (this%wmask(i,j,k).eq.0.and.this%wmask(i-1,j,k).gt.0) this%itpw_x(:,i,j,k)=[1.0_WP,0.0_WP] + if (this%wmask(i,j,k).gt.0.and.this%wmask(i-1,j,k).eq.0) this%itpw_x(:,i,j,k)=[0.0_WP,1.0_WP] + end do + end do + end do + + ! Adjust interpolation coefficients to cell edge in y + do k=this%cfg%kmino_ ,this%cfg%kmaxo_ + do j=this%cfg%jmino_+1,this%cfg%jmaxo_ + do i=this%cfg%imino_ ,this%cfg%imaxo_ + ! Linear interpolation in y of U from [x ,ym,zm] + if (this%umask(i,j,k).eq.0.and.this%umask(i,j-1,k).gt.0) this%itpu_y(:,i,j,k)=[1.0_WP,0.0_WP] + if (this%umask(i,j,k).gt.0.and.this%umask(i,j-1,k).eq.0) this%itpu_y(:,i,j,k)=[0.0_WP,1.0_WP] + ! Linear interpolation in y of W from [xm,ym,z ] + if (this%wmask(i,j,k).eq.0.and.this%wmask(i,j-1,k).gt.0) this%itpw_y(:,i,j,k)=[1.0_WP,0.0_WP] + if (this%wmask(i,j,k).gt.0.and.this%wmask(i,j-1,k).eq.0) this%itpw_y(:,i,j,k)=[0.0_WP,1.0_WP] + end do + end do + end do + + ! Adjust interpolation coefficients to cell edge in z + do k=this%cfg%kmino_+1,this%cfg%kmaxo_ + do j=this%cfg%jmino_ ,this%cfg%jmaxo_ + do i=this%cfg%imino_ ,this%cfg%imaxo_ + ! Linear interpolation in z of U from [x ,ym,zm] + if (this%umask(i,j,k).eq.0.and.this%umask(i,j,k-1).gt.0) this%itpu_z(:,i,j,k)=[1.0_WP,0.0_WP] + if (this%umask(i,j,k).gt.0.and.this%umask(i,j,k-1).eq.0) this%itpu_z(:,i,j,k)=[0.0_WP,1.0_WP] + ! Linear interpolation in z of V from [xm,y ,zm] + if (this%vmask(i,j,k).eq.0.and.this%vmask(i,j,k-1).gt.0) this%itpv_z(:,i,j,k)=[1.0_WP,0.0_WP] + if (this%vmask(i,j,k).gt.0.and.this%vmask(i,j,k-1).eq.0) this%itpv_z(:,i,j,k)=[0.0_WP,1.0_WP] + end do + end do + end do + + ! Adjust metrics to account for lower dimensionality + if (this%cfg%nx.eq.1) then + this%divp_x=0.0_WP + this%divu_x=0.0_WP + this%divv_x=0.0_WP + this%divw_x=0.0_WP + this%grdu_x=0.0_WP + this%grdv_x=0.0_WP + this%grdw_x=0.0_WP + end if + if (this%cfg%ny.eq.1) then + this%divp_y=0.0_WP + this%divu_y=0.0_WP + this%divv_y=0.0_WP + this%divw_y=0.0_WP + this%grdu_y=0.0_WP + this%grdv_y=0.0_WP + this%grdw_y=0.0_WP + end if + if (this%cfg%nz.eq.1) then + this%divp_z=0.0_WP + this%divu_z=0.0_WP + this%divv_z=0.0_WP + this%divw_z=0.0_WP + this%grdu_z=0.0_WP + this%grdv_z=0.0_WP + this%grdw_z=0.0_WP + end if + + end subroutine adjust_metrics + + + !> Finish setting up the flow solver now that bconds have been defined + subroutine setup(this,pressure_solver,implicit_solver) + implicit none + class(incomp), intent(inout) :: this + class(linsol), target, intent(in) :: pressure_solver !< A pressure solver is required + class(linsol), target, intent(in), optional :: implicit_solver !< An implicit solver can be provided + integer :: i,j,k + + ! Adjust metrics based on bcflag array + call this%adjust_metrics() + + ! Point to pressure solver linsol object + this%psolv=>pressure_solver + + ! Set 7-pt stencil map for the pressure solver + this%psolv%stc(1,:)=[ 0, 0, 0] + this%psolv%stc(2,:)=[+1, 0, 0] + this%psolv%stc(3,:)=[-1, 0, 0] + this%psolv%stc(4,:)=[ 0,+1, 0] + this%psolv%stc(5,:)=[ 0,-1, 0] + this%psolv%stc(6,:)=[ 0, 0,+1] + this%psolv%stc(7,:)=[ 0, 0,-1] + + ! Setup the scaled Laplacian operator from incomp metrics: lap(*)=-vol*div(grad(*)) + do k=this%cfg%kmin_,this%cfg%kmax_ + do j=this%cfg%jmin_,this%cfg%jmax_ + do i=this%cfg%imin_,this%cfg%imax_ + ! Set Laplacian + this%psolv%opr(1,i,j,k)=this%divp_x(1,i,j,k)*this%divu_x(-1,i+1,j,k)+& + & this%divp_x(0,i,j,k)*this%divu_x( 0,i ,j,k)+& + & this%divp_y(1,i,j,k)*this%divv_y(-1,i,j+1,k)+& + & this%divp_y(0,i,j,k)*this%divv_y( 0,i,j ,k)+& + & this%divp_z(1,i,j,k)*this%divw_z(-1,i,j,k+1)+& + & this%divp_z(0,i,j,k)*this%divw_z( 0,i,j,k ) + this%psolv%opr(2,i,j,k)=this%divp_x(1,i,j,k)*this%divu_x( 0,i+1,j,k) + this%psolv%opr(3,i,j,k)=this%divp_x(0,i,j,k)*this%divu_x(-1,i ,j,k) + this%psolv%opr(4,i,j,k)=this%divp_y(1,i,j,k)*this%divv_y( 0,i,j+1,k) + this%psolv%opr(5,i,j,k)=this%divp_y(0,i,j,k)*this%divv_y(-1,i,j ,k) + this%psolv%opr(6,i,j,k)=this%divp_z(1,i,j,k)*this%divw_z( 0,i,j,k+1) + this%psolv%opr(7,i,j,k)=this%divp_z(0,i,j,k)*this%divw_z(-1,i,j,k ) + ! Scale it by the cell volume + this%psolv%opr(:,i,j,k)=-this%psolv%opr(:,i,j,k)*this%cfg%vol(i,j,k) + end do + end do + end do + + ! Initialize the pressure Poisson solver + call this%psolv%init() + call this%psolv%setup() + + ! Prepare implicit solver if it had been provided + if (present(implicit_solver)) then + + ! Point to implicit solver linsol object + this%implicit=>implicit_solver + + ! Set 7-pt stencil map for the velocity solver + this%implicit%stc(1,:)=[ 0, 0, 0] + this%implicit%stc(2,:)=[+1, 0, 0] + this%implicit%stc(3,:)=[-1, 0, 0] + this%implicit%stc(4,:)=[ 0,+1, 0] + this%implicit%stc(5,:)=[ 0,-1, 0] + this%implicit%stc(6,:)=[ 0, 0,+1] + this%implicit%stc(7,:)=[ 0, 0,-1] + + ! Set the diagonal to 1 to make sure all cells participate in solver + this%implicit%opr(1,:,:,:)=1.0_WP + + ! Initialize the implicit velocity solver + call this%implicit%init() + + else + + ! Point to implicit solver linsol object + this%implicit=>NULL() + + end if + + end subroutine setup + + + !> Add a boundary condition + subroutine add_bcond(this,name,type,locator,face,dir,canCorrect) + use string, only: lowercase + use messager, only: die + use iterator_class, only: locator_ftype + implicit none + class(incomp), intent(inout) :: this + character(len=*), intent(in) :: name + integer, intent(in) :: type + procedure(locator_ftype) :: locator + character(len=1), intent(in) :: face + integer, intent(in) :: dir + logical, intent(in) :: canCorrect + type(bcond), pointer :: new_bc + integer :: i,j,k,n + + ! Prepare new bcond + allocate(new_bc) + new_bc%name=trim(adjustl(name)) + new_bc%type=type + select case (lowercase(face)) + case ('x'); new_bc%face='x' + case ('y'); new_bc%face='y' + case ('z'); new_bc%face='z' + case default; call die('[incomp add_bcond] Unknown bcond face - expecting x, y, or z') + end select + new_bc%itr=iterator(pg=this%cfg,name=new_bc%name,locator=locator,face=new_bc%face) + select case (dir) ! Outward-oriented + case (+1); new_bc%dir=+1 + case (-1); new_bc%dir=-1 + case ( 0); new_bc%dir= 0 + case default; call die('[incomp add_bcond] Unknown bcond dir - expecting -1, +1, or 0') + end select + new_bc%rdir=real(new_bc%dir,WP) + new_bc%canCorrect=canCorrect + + ! Insert it up front + new_bc%next=>this%first_bc + this%first_bc=>new_bc + + ! Increment bcond counter + this%nbc=this%nbc+1 + + ! Now adjust the metrics accordingly + select case (new_bc%type) + case (dirichlet) !< Dirichlet is set one face (i.e., velocit component) at the time + select case (new_bc%face) + case ('x') + do n=1,new_bc%itr%n_ + i=new_bc%itr%map(1,n); j=new_bc%itr%map(2,n); k=new_bc%itr%map(3,n) + this%umask(i,j,k)=2 + end do + case ('y') + do n=1,new_bc%itr%n_ + i=new_bc%itr%map(1,n); j=new_bc%itr%map(2,n); k=new_bc%itr%map(3,n) + this%vmask(i,j,k)=2 + end do + case ('z') + do n=1,new_bc%itr%n_ + i=new_bc%itr%map(1,n); j=new_bc%itr%map(2,n); k=new_bc%itr%map(3,n) + this%wmask(i,j,k)=2 + end do + end select + + case (neumann) !< Neumann has to be at existing wall or at domain boundary! + case (clipped_neumann) + case (convective) + case (slip) + case default + call die('[incomp apply_bcond] Unknown bcond type') + end select + + end subroutine add_bcond + + + !> Get a boundary condition + subroutine get_bcond(this,name,my_bc) + use messager, only: die + implicit none + class(incomp), intent(inout) :: this + character(len=*), intent(in) :: name + type(bcond), pointer, intent(out) :: my_bc + my_bc=>this%first_bc + search: do while (associated(my_bc)) + if (trim(my_bc%name).eq.trim(name)) exit search + my_bc=>my_bc%next + end do search + if (.not.associated(my_bc)) call die('[incomp get_bcond] Boundary condition was not found') + end subroutine get_bcond + + + !> Enforce boundary condition + subroutine apply_bcond(this,t,dt) + use messager, only: die + implicit none + class(incomp), intent(inout) :: this + real(WP), intent(in) :: t,dt + integer :: i,j,k,n,stag + type(bcond), pointer :: my_bc + + ! ! First enfore zero velocity at walls + ! do k=this%cfg%kmin_,this%cfg%kmax_ + ! do j=this%cfg%jmin_,this%cfg%jmax_ + ! do i=this%cfg%imin_,this%cfg%imax_ + ! if (minval(this%cfg%VF(i-1:i,j,k)).lt.10.0_WP*epsilon(1.0_WP)) this%U(i,j,k)=0.0_WP + ! if (minval(this%cfg%VF(i,j-1:j,k)).lt.10.0_WP*epsilon(1.0_WP)) this%V(i,j,k)=0.0_WP + ! if (minval(this%cfg%VF(i,j,k-1:k)).lt.10.0_WP*epsilon(1.0_WP)) this%W(i,j,k)=0.0_WP + ! end do + ! end do + ! end do + ! ! Sync fields + ! call this%cfg%sync(this%U) + ! call this%cfg%sync(this%V) + ! call this%cfg%sync(this%W) + + ! Traverse bcond list + my_bc=>this%first_bc + do while (associated(my_bc)) + + ! Only processes inside the bcond work here + if (my_bc%itr%amIn) then + + ! Select appropriate action based on the bcond type + select case (my_bc%type) + + case (dirichlet) !< Apply Dirichlet conditions + + ! This is done by the user directly + ! Unclear whether we want to do this within the solver... + + case (neumann,clipped_neumann,slip) !< Apply Neumann condition to all 3 components + ! Handle index shift due to staggering + stag=min(my_bc%dir,0) + ! Implement based on bcond direction + select case (my_bc%face) + case ('x') + stag=min(my_bc%dir,0) + do n=1,my_bc%itr%n_ + i=my_bc%itr%map(1,n); j=my_bc%itr%map(2,n); k=my_bc%itr%map(3,n) + this%U(i ,j ,k )=this%U(i-my_bc%dir ,j ,k ) + this%V(i+stag,j:j+1,k )=this%V(i-my_bc%dir+stag,j:j+1,k ) + this%W(i+stag,j ,k:k+1)=this%W(i-my_bc%dir+stag,j ,k:k+1) + end do + case ('y') + stag=min(my_bc%dir,0) + do n=1,my_bc%itr%n_ + i=my_bc%itr%map(1,n); j=my_bc%itr%map(2,n); k=my_bc%itr%map(3,n) + this%U(i:i+1,j+stag,k )=this%U(i:i+1,j-my_bc%dir+stag,k ) + this%V(i ,j ,k )=this%V(i ,j-my_bc%dir ,k ) + this%W(i ,j+stag,k:k+1)=this%W(i ,j-my_bc%dir+stag,k:k+1) + end do + case ('z') + stag=min(my_bc%dir,0) + do n=1,my_bc%itr%n_ + i=my_bc%itr%map(1,n); j=my_bc%itr%map(2,n); k=my_bc%itr%map(3,n) + this%U(i:i+1,j ,k+stag)=this%U(i:i+1,j ,k-my_bc%dir+stag) + this%V(i ,j:j+1,k+stag)=this%V(i ,j:j+1,k-my_bc%dir+stag) + this%W(i ,j ,k )=this%W(i ,j ,k-my_bc%dir ) + end do + end select + ! If needed, clip + if (my_bc%type.eq.clipped_neumann) then + select case (my_bc%face) + case ('x') + do n=1,my_bc%itr%n_ + i=my_bc%itr%map(1,n); j=my_bc%itr%map(2,n); k=my_bc%itr%map(3,n) + if (this%U(i,j,k)*my_bc%rdir.lt.0.0_WP) this%U(i,j,k)=0.0_WP + end do + case ('y') + do n=1,my_bc%itr%n_ + i=my_bc%itr%map(1,n); j=my_bc%itr%map(2,n); k=my_bc%itr%map(3,n) + if (this%V(i,j,k)*my_bc%rdir.lt.0.0_WP) this%V(i,j,k)=0.0_WP + end do + case ('z') + do n=1,my_bc%itr%n_ + i=my_bc%itr%map(1,n); j=my_bc%itr%map(2,n); k=my_bc%itr%map(3,n) + if (this%W(i,j,k)*my_bc%rdir.lt.0.0_WP) this%W(i,j,k)=0.0_WP + end do + end select + end if + ! If needed, no penetration + if (my_bc%type.eq.slip) then + select case (my_bc%face) + case ('x') + do n=1,my_bc%itr%n_ + i=my_bc%itr%map(1,n); j=my_bc%itr%map(2,n); k=my_bc%itr%map(3,n) + this%U(i,j,k)=0.0_WP + end do + case ('y') + do n=1,my_bc%itr%n_ + i=my_bc%itr%map(1,n); j=my_bc%itr%map(2,n); k=my_bc%itr%map(3,n) + this%V(i,j,k)=0.0_WP + end do + case ('z') + do n=1,my_bc%itr%n_ + i=my_bc%itr%map(1,n); j=my_bc%itr%map(2,n); k=my_bc%itr%map(3,n) + this%W(i,j,k)=0.0_WP + end do + end select + end if + + case (convective) ! Not implemented yet! + + case default + call die('[incomp apply_bcond] Unknown bcond type') + end select + + end if + + ! Move on to the next bcond + my_bc=>my_bc%next + + end do + + ! Sync full fields after all bcond + call this%cfg%sync(this%U) + call this%cfg%sync(this%V) + call this%cfg%sync(this%W) + + end subroutine apply_bcond + + + !> Calculate the explicit momentum time derivative based on U/V/W/P + subroutine get_dmomdt(this,drhoUdt,drhoVdt,drhoWdt) + implicit none + class(incomp), intent(inout) :: this + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(out) :: drhoUdt !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(out) :: drhoVdt !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(out) :: drhoWdt !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + integer :: i,j,k,ii,jj,kk + real(WP), dimension(:,:,:), allocatable :: FX,FY,FZ + + ! Zero out drhoUVW/dt arrays + drhoUdt=0.0_WP; drhoVdt=0.0_WP; drhoWdt=0.0_WP + + ! Allocate flux arrays + allocate(FX(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + allocate(FY(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + allocate(FZ(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + + ! Flux of rhoU + do kk=this%cfg%kmin_,this%cfg%kmax_+1 + do jj=this%cfg%jmin_,this%cfg%jmax_+1 + do ii=this%cfg%imin_,this%cfg%imax_+1 + ! Fluxes on x-face + i=ii-1; j=jj-1; k=kk-1 + FX(i,j,k)=-this%rho*sum(this%itpu_x(:,i,j,k)*this%U(i:i+1,j,k))*sum(this%itpu_x(:,i,j,k)*this%U(i:i+1,j,k)) & + & +this%visc(i,j,k)*(sum(this%grdu_x(:,i,j,k)*this%U(i:i+1,j,k))+sum(this%grdu_x(:,i,j,k)*this%U(i:i+1,j,k)) & + & -2.0_WP/3.0_WP*(sum(this%divp_x(:,i,j,k)*this%U(i:i+1,j,k))+sum(this%divp_y(:,i,j,k)*this%V(i,j:j+1,k))+sum(this%divp_z(:,i,j,k)*this%W(i,j,k:k+1)))) & + & -this%P(i,j,k) + ! Fluxes on y-face + i=ii; j=jj; k=kk + FY(i,j,k)=-this%rho*sum(this%itpu_y(:,i,j,k)*this%U(i,j-1:j,k))*sum(this%itpv_x(:,i,j,k)*this%V(i-1:i,j,k)) & + & +sum(this%itp_xy(:,:,i,j,k)*this%visc(i-1:i,j-1:j,k))*(sum(this%grdu_y(:,i,j,k)*this%U(i,j-1:j,k))+sum(this%grdv_x(:,i,j,k)*this%V(i-1:i,j,k))) + ! Fluxes on z-face + i=ii; j=jj; k=kk + FZ(i,j,k)=-this%rho*sum(this%itpu_z(:,i,j,k)*this%U(i,j,k-1:k))*sum(this%itpw_x(:,i,j,k)*this%W(i-1:i,j,k)) & + & +sum(this%itp_xz(:,:,i,j,k)*this%visc(i-1:i,j,k-1:k))*(sum(this%grdu_z(:,i,j,k)*this%U(i,j,k-1:k))+sum(this%grdw_x(:,i,j,k)*this%W(i-1:i,j,k))) + end do + end do + end do + ! Time derivative of rhoU + do k=this%cfg%kmin_,this%cfg%kmax_ + do j=this%cfg%jmin_,this%cfg%jmax_ + do i=this%cfg%imin_,this%cfg%imax_ + drhoUdt(i,j,k)=sum(this%divu_x(:,i,j,k)*FX(i-1:i,j,k))+& + & sum(this%divu_y(:,i,j,k)*FY(i,j:j+1,k))+& + & sum(this%divu_z(:,i,j,k)*FZ(i,j,k:k+1)) + end do + end do + end do + ! Sync it + call this%cfg%sync(drhoUdt) + + ! Flux of rhoV + do kk=this%cfg%kmin_,this%cfg%kmax_+1 + do jj=this%cfg%jmin_,this%cfg%jmax_+1 + do ii=this%cfg%imin_,this%cfg%imax_+1 + ! Fluxes on x-face + i=ii; j=jj; k=kk + FX(i,j,k)=-this%rho*sum(this%itpv_x(:,i,j,k)*this%V(i-1:i,j,k))*sum(this%itpu_y(:,i,j,k)*this%U(i,j-1:j,k)) & + & +sum(this%itp_xy(:,:,i,j,k)*this%visc(i-1:i,j-1:j,k))*(sum(this%grdv_x(:,i,j,k)*this%V(i-1:i,j,k))+sum(this%grdu_y(:,i,j,k)*this%U(i,j-1:j,k))) + ! Fluxes on y-face + i=ii-1; j=jj-1; k=kk-1 + FY(i,j,k)=-this%rho*sum(this%itpv_y(:,i,j,k)*this%V(i,j:j+1,k))*sum(this%itpv_y(:,i,j,k)*this%V(i,j:j+1,k)) & + & +this%visc(i,j,k)*(sum(this%grdv_y(:,i,j,k)*this%V(i,j:j+1,k))+sum(this%grdv_y(:,i,j,k)*this%V(i,j:j+1,k)) & + & -2.0_WP/3.0_WP*(sum(this%divp_x(:,i,j,k)*this%U(i:i+1,j,k))+sum(this%divp_y(:,i,j,k)*this%V(i,j:j+1,k))+sum(this%divp_z(:,i,j,k)*this%W(i,j,k:k+1)))) & + & -this%P(i,j,k) + ! Fluxes on z-face + i=ii; j=jj; k=kk + FZ(i,j,k)=-this%rho*sum(this%itpv_z(:,i,j,k)*this%V(i,j,k-1:k))*sum(this%itpw_y(:,i,j,k)*this%W(i,j-1:j,k)) & + & +sum(this%itp_yz(:,:,i,j,k)*this%visc(i,j-1:j,k-1:k))*(sum(this%grdv_z(:,i,j,k)*this%V(i,j,k-1:k))+sum(this%grdw_y(:,i,j,k)*this%W(i,j-1:j,k))) + end do + end do + end do + ! Time derivative of rhoV + do k=this%cfg%kmin_,this%cfg%kmax_ + do j=this%cfg%jmin_,this%cfg%jmax_ + do i=this%cfg%imin_,this%cfg%imax_ + drhoVdt(i,j,k)=sum(this%divv_x(:,i,j,k)*FX(i:i+1,j,k))+& + & sum(this%divv_y(:,i,j,k)*FY(i,j-1:j,k))+& + & sum(this%divv_z(:,i,j,k)*FZ(i,j,k:k+1)) + end do + end do + end do + ! Sync it + call this%cfg%sync(drhoVdt) + + ! Flux of rhoW + do kk=this%cfg%kmin_,this%cfg%kmax_+1 + do jj=this%cfg%jmin_,this%cfg%jmax_+1 + do ii=this%cfg%imin_,this%cfg%imax_+1 + ! Fluxes on x-face + i=ii; j=jj; k=kk + FX(i,j,k)=-this%rho*sum(this%itpw_x(:,i,j,k)*this%W(i-1:i,j,k))*sum(this%itpu_z(:,i,j,k)*this%U(i,j,k-1:k)) & + & +sum(this%itp_xz(:,:,i,j,k)*this%visc(i-1:i,j,k-1:k))*(sum(this%grdw_x(:,i,j,k)*this%W(i-1:i,j,k))+sum(this%grdu_z(:,i,j,k)*this%U(i,j,k-1:k))) + ! Fluxes on y-face + i=ii; j=jj; k=kk + FY(i,j,k)=-this%rho*sum(this%itpw_y(:,i,j,k)*this%W(i,j-1:j,k))*sum(this%itpv_z(:,i,j,k)*this%V(i,j,k-1:k)) & + & +sum(this%itp_yz(:,:,i,j,k)*this%visc(i,j-1:j,k-1:k))*(sum(this%grdw_y(:,i,j,k)*this%W(i,j-1:j,k))+sum(this%grdv_z(:,i,j,k)*this%V(i,j,k-1:k))) + ! Fluxes on z-face + i=ii-1; j=jj-1; k=kk-1 + FZ(i,j,k)=-this%rho*sum(this%itpw_z(:,i,j,k)*this%W(i,j,k:k+1))*sum(this%itpw_z(:,i,j,k)*this%W(i,j,k:k+1)) & + & +this%visc(i,j,k)*(sum(this%grdw_z(:,i,j,k)*this%W(i,j,k:k+1))+sum(this%grdw_z(:,i,j,k)*this%W(i,j,k:k+1)) & + & -2.0_WP/3.0_WP*(sum(this%divp_x(:,i,j,k)*this%U(i:i+1,j,k))+sum(this%divp_y(:,i,j,k)*this%V(i,j:j+1,k))+sum(this%divp_z(:,i,j,k)*this%W(i,j,k:k+1)))) & + & -this%P(i,j,k) + end do + end do + end do + ! Time derivative of rhoW + do k=this%cfg%kmin_,this%cfg%kmax_ + do j=this%cfg%jmin_,this%cfg%jmax_ + do i=this%cfg%imin_,this%cfg%imax_ + drhoWdt(i,j,k)=sum(this%divw_x(:,i,j,k)*FX(i:i+1,j,k))+& + & sum(this%divw_y(:,i,j,k)*FY(i,j:j+1,k))+& + & sum(this%divw_z(:,i,j,k)*FZ(i,j,k-1:k)) + end do + end do + end do + ! Sync it + call this%cfg%sync(drhoWdt) + + ! Deallocate flux arrays + deallocate(FX,FY,FZ) + + end subroutine get_dmomdt + + + !> Calculate the divergence of fluid stress + subroutine get_div_stress(this,divx,divy,divz) + implicit none + class(incomp), intent(inout) :: this + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(out) :: divx !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(out) :: divy !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(out) :: divz !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + integer :: i,j,k,ii,jj,kk + real(WP), dimension(:,:,:), allocatable :: FX,FY,FZ + + ! Zero out drhoUVW/dt arrays + divx=0.0_WP; divy=0.0_WP; divz=0.0_WP + + ! Allocate flux arrays + allocate(FX(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + allocate(FY(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + allocate(FZ(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + + ! Flux of rhoU + do kk=this%cfg%kmin_,this%cfg%kmax_+1 + do jj=this%cfg%jmin_,this%cfg%jmax_+1 + do ii=this%cfg%imin_,this%cfg%imax_+1 + ! Fluxes on x-face + i=ii-1; j=jj-1; k=kk-1 + FX(i,j,k)=+this%visc(i,j,k)*(sum(this%grdu_x(:,i,j,k)*this%U(i:i+1,j,k))+sum(this%grdu_x(:,i,j,k)*this%U(i:i+1,j,k)) & + & -2.0_WP/3.0_WP*(sum(this%divp_x(:,i,j,k)*this%U(i:i+1,j,k))+sum(this%divp_y(:,i,j,k)*this%V(i,j:j+1,k))+sum(this%divp_z(:,i,j,k)*this%W(i,j,k:k+1)))) & + & -this%P(i,j,k) + ! Fluxes on y-face + i=ii; j=jj; k=kk + FY(i,j,k)=+sum(this%itp_xy(:,:,i,j,k)*this%visc(i-1:i,j-1:j,k))*(sum(this%grdu_y(:,i,j,k)*this%U(i,j-1:j,k))+sum(this%grdv_x(:,i,j,k)*this%V(i-1:i,j,k))) + ! Fluxes on z-face + i=ii; j=jj; k=kk + FZ(i,j,k)=+sum(this%itp_xz(:,:,i,j,k)*this%visc(i-1:i,j,k-1:k))*(sum(this%grdu_z(:,i,j,k)*this%U(i,j,k-1:k))+sum(this%grdw_x(:,i,j,k)*this%W(i-1:i,j,k))) + end do + end do + end do + ! Time derivative of rhoU + do k=this%cfg%kmin_,this%cfg%kmax_ + do j=this%cfg%jmin_,this%cfg%jmax_ + do i=this%cfg%imin_,this%cfg%imax_ + divx(i,j,k)=sum(this%divu_x(:,i,j,k)*FX(i-1:i,j,k))+& + & sum(this%divu_y(:,i,j,k)*FY(i,j:j+1,k))+& + & sum(this%divu_z(:,i,j,k)*FZ(i,j,k:k+1)) + end do + end do + end do + ! Sync it + call this%cfg%sync(divx) + + ! Flux of rhoV + do kk=this%cfg%kmin_,this%cfg%kmax_+1 + do jj=this%cfg%jmin_,this%cfg%jmax_+1 + do ii=this%cfg%imin_,this%cfg%imax_+1 + ! Fluxes on x-face + i=ii; j=jj; k=kk + FX(i,j,k)=+sum(this%itp_xy(:,:,i,j,k)*this%visc(i-1:i,j-1:j,k))*(sum(this%grdv_x(:,i,j,k)*this%V(i-1:i,j,k))+sum(this%grdu_y(:,i,j,k)*this%U(i,j-1:j,k))) + ! Fluxes on y-face + i=ii-1; j=jj-1; k=kk-1 + FY(i,j,k)=+this%visc(i,j,k)*(sum(this%grdv_y(:,i,j,k)*this%V(i,j:j+1,k))+sum(this%grdv_y(:,i,j,k)*this%V(i,j:j+1,k)) & + & -2.0_WP/3.0_WP*(sum(this%divp_x(:,i,j,k)*this%U(i:i+1,j,k))+sum(this%divp_y(:,i,j,k)*this%V(i,j:j+1,k))+sum(this%divp_z(:,i,j,k)*this%W(i,j,k:k+1)))) & + & -this%P(i,j,k) + ! Fluxes on z-face + i=ii; j=jj; k=kk + FZ(i,j,k)=+sum(this%itp_yz(:,:,i,j,k)*this%visc(i,j-1:j,k-1:k))*(sum(this%grdv_z(:,i,j,k)*this%V(i,j,k-1:k))+sum(this%grdw_y(:,i,j,k)*this%W(i,j-1:j,k))) + end do + end do + end do + ! Time derivative of rhoV + do k=this%cfg%kmin_,this%cfg%kmax_ + do j=this%cfg%jmin_,this%cfg%jmax_ + do i=this%cfg%imin_,this%cfg%imax_ + divy(i,j,k)=sum(this%divv_x(:,i,j,k)*FX(i:i+1,j,k))+& + & sum(this%divv_y(:,i,j,k)*FY(i,j-1:j,k))+& + & sum(this%divv_z(:,i,j,k)*FZ(i,j,k:k+1)) + end do + end do + end do + ! Sync it + call this%cfg%sync(divy) + + ! Flux of rhoW + do kk=this%cfg%kmin_,this%cfg%kmax_+1 + do jj=this%cfg%jmin_,this%cfg%jmax_+1 + do ii=this%cfg%imin_,this%cfg%imax_+1 + ! Fluxes on x-face + i=ii; j=jj; k=kk + FX(i,j,k)=+sum(this%itp_xz(:,:,i,j,k)*this%visc(i-1:i,j,k-1:k))*(sum(this%grdw_x(:,i,j,k)*this%W(i-1:i,j,k))+sum(this%grdu_z(:,i,j,k)*this%U(i,j,k-1:k))) + ! Fluxes on y-face + i=ii; j=jj; k=kk + FY(i,j,k)=+sum(this%itp_yz(:,:,i,j,k)*this%visc(i,j-1:j,k-1:k))*(sum(this%grdw_y(:,i,j,k)*this%W(i,j-1:j,k))+sum(this%grdv_z(:,i,j,k)*this%V(i,j,k-1:k))) + ! Fluxes on z-face + i=ii-1; j=jj-1; k=kk-1 + FZ(i,j,k)=+this%visc(i,j,k)*(sum(this%grdw_z(:,i,j,k)*this%W(i,j,k:k+1))+sum(this%grdw_z(:,i,j,k)*this%W(i,j,k:k+1)) & + & -2.0_WP/3.0_WP*(sum(this%divp_x(:,i,j,k)*this%U(i:i+1,j,k))+sum(this%divp_y(:,i,j,k)*this%V(i,j:j+1,k))+sum(this%divp_z(:,i,j,k)*this%W(i,j,k:k+1)))) & + & -this%P(i,j,k) + end do + end do + end do + ! Time derivative of rhoW + do k=this%cfg%kmin_,this%cfg%kmax_ + do j=this%cfg%jmin_,this%cfg%jmax_ + do i=this%cfg%imin_,this%cfg%imax_ + divz(i,j,k)=sum(this%divw_x(:,i,j,k)*FX(i:i+1,j,k))+& + & sum(this%divw_y(:,i,j,k)*FY(i,j:j+1,k))+& + & sum(this%divw_z(:,i,j,k)*FZ(i,j,k-1:k)) + end do + end do + end do + ! Sync it + call this%cfg%sync(divz) + + ! Deallocate flux arrays + deallocate(FX,FY,FZ) + + end subroutine get_div_stress + + + !> Calculate the velocity divergence based on U/V/W + subroutine get_div(this,src) + implicit none + class(incomp), intent(inout) :: this + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), optional :: src !< Mass source term + integer :: i,j,k + ! Calculate divergence of velocity + do k=this%cfg%kmin_,this%cfg%kmax_ + do j=this%cfg%jmin_,this%cfg%jmax_ + do i=this%cfg%imin_,this%cfg%imax_ + this%div(i,j,k)=sum(this%divp_x(:,i,j,k)*this%U(i:i+1,j,k))+& + & sum(this%divp_y(:,i,j,k)*this%V(i,j:j+1,k))+& + & sum(this%divp_z(:,i,j,k)*this%W(i,j,k:k+1)) + end do + end do + end do + ! If present, account for mass source + if (present(src)) then + do k=this%cfg%kmin_,this%cfg%kmax_ + do j=this%cfg%jmin_,this%cfg%jmax_ + do i=this%cfg%imin_,this%cfg%imax_ + this%div(i,j,k)=this%div(i,j,k)-src(i,j,k) + end do + end do + end do + end if + ! Sync it + call this%cfg%sync(this%div) + end subroutine get_div + + + !> Calculate the pressure gradient based on P + subroutine get_pgrad(this,P,Pgradx,Pgrady,Pgradz) + implicit none + class(incomp), intent(inout) :: this + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(in) :: P !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(out) :: Pgradx !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(out) :: Pgrady !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(out) :: Pgradz !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + integer :: i,j,k + Pgradx=0.0_WP; Pgrady=0.0_WP; Pgradz=0.0_WP + do k=this%cfg%kmin_,this%cfg%kmax_ + do j=this%cfg%jmin_,this%cfg%jmax_ + do i=this%cfg%imin_,this%cfg%imax_ + Pgradx(i,j,k)=sum(this%divu_x(:,i,j,k)*P(i-1:i,j,k)) + Pgrady(i,j,k)=sum(this%divv_y(:,i,j,k)*P(i,j-1:j,k)) + Pgradz(i,j,k)=sum(this%divw_z(:,i,j,k)*P(i,j,k-1:k)) + end do + end do + end do + ! Sync it + call this%cfg%sync(Pgradx) + call this%cfg%sync(Pgrady) + call this%cfg%sync(Pgradz) + end subroutine get_pgrad + + + !> Calculate the interpolated velocity, including overlap and ghosts + subroutine interp_vel(this,Ui,Vi,Wi) + implicit none + class(incomp), intent(inout) :: this + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(out) :: Ui !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(out) :: Vi !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(out) :: Wi !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + integer :: i,j,k + ! Calculate as far as possible each component + do k=this%cfg%kmino_,this%cfg%kmaxo_ + do j=this%cfg%jmino_,this%cfg%jmaxo_ + do i=this%cfg%imino_,this%cfg%imaxo_-1 + Ui(i,j,k)=sum(this%itpu_x(:,i,j,k)*this%U(i:i+1,j,k)) + end do + end do + end do + do k=this%cfg%kmino_,this%cfg%kmaxo_ + do j=this%cfg%jmino_,this%cfg%jmaxo_-1 + do i=this%cfg%imino_,this%cfg%imaxo_ + Vi(i,j,k)=sum(this%itpv_y(:,i,j,k)*this%V(i,j:j+1,k)) + end do + end do + end do + do k=this%cfg%kmino_,this%cfg%kmaxo_-1 + do j=this%cfg%jmino_,this%cfg%jmaxo_ + do i=this%cfg%imino_,this%cfg%imaxo_ + Wi(i,j,k)=sum(this%itpw_z(:,i,j,k)*this%W(i,j,k:k+1)) + end do + end do + end do + ! Add last layer in each direction + if (.not.this%cfg%xper.and.this%cfg%iproc.eq.this%cfg%npx) Ui(this%cfg%imaxo,:,:)=this%U(this%cfg%imaxo,:,:) + if (.not.this%cfg%yper.and.this%cfg%jproc.eq.this%cfg%npy) Vi(:,this%cfg%jmaxo,:)=this%V(:,this%cfg%jmaxo,:) + if (.not.this%cfg%zper.and.this%cfg%kproc.eq.this%cfg%npz) Wi(:,:,this%cfg%kmaxo)=this%W(:,:,this%cfg%kmaxo) + ! Sync it + call this%cfg%sync(Ui) + call this%cfg%sync(Vi) + call this%cfg%sync(Wi) + end subroutine interp_vel + + + !> Calculate the deviatoric part of the strain rate tensor from U/V/W + !> 1: du/dx-div/3 + !> 2: dv/dy-div/3 + !> 3: dw/dz-div/3 + !> 4: (du/dy+dv/dx)/2 + !> 5: (dv/dz+dw/dy)/2 + !> 6: (dw/dx+du/dz)/2 + subroutine get_strainrate(this,SR) + use messager, only: die + implicit none + class(incomp), intent(inout) :: this + real(WP), dimension(1:,this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(out) :: SR !< Needs to be (1:6,imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + real(WP), dimension(:,:,:), allocatable :: dudy,dudz,dvdx,dvdz,dwdx,dwdy + real(WP) :: div + integer :: i,j,k + + ! Check SR's first dimension + if (size(SR,dim=1).ne.6) call die('[incomp get_strainrate] SR should be of size (1:6,imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_)') + + ! Compute dudx, dvdy, and dwdz first + do k=this%cfg%kmin_,this%cfg%kmax_ + do j=this%cfg%jmin_,this%cfg%jmax_ + do i=this%cfg%imin_,this%cfg%imax_ + SR(1,i,j,k)=sum(this%grdu_x(:,i,j,k)*this%U(i:i+1,j,k)) + SR(2,i,j,k)=sum(this%grdv_y(:,i,j,k)*this%V(i,j:j+1,k)) + SR(3,i,j,k)=sum(this%grdw_z(:,i,j,k)*this%W(i,j,k:k+1)) + div=sum(SR(1:3,i,j,k))/3.0_WP + SR(1,i,j,k)=SR(1,i,j,k)-div + SR(2,i,j,k)=SR(2,i,j,k)-div + SR(3,i,j,k)=SR(3,i,j,k)-div + end do + end do + end do + + ! Allocate velocity gradient components + allocate(dudy(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + allocate(dudz(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + allocate(dvdx(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + allocate(dvdz(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + allocate(dwdx(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + allocate(dwdy(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + + ! Calculate components of the velocity gradient at their natural locations with an extra cell for interpolation + do k=this%cfg%kmin_,this%cfg%kmax_+1 + do j=this%cfg%jmin_,this%cfg%jmax_+1 + do i=this%cfg%imin_,this%cfg%imax_+1 + dudy(i,j,k)=sum(this%grdu_y(:,i,j,k)*this%U(i,j-1:j,k)) + dudz(i,j,k)=sum(this%grdu_z(:,i,j,k)*this%U(i,j,k-1:k)) + dvdx(i,j,k)=sum(this%grdv_x(:,i,j,k)*this%V(i-1:i,j,k)) + dvdz(i,j,k)=sum(this%grdv_z(:,i,j,k)*this%V(i,j,k-1:k)) + dwdx(i,j,k)=sum(this%grdw_x(:,i,j,k)*this%W(i-1:i,j,k)) + dwdy(i,j,k)=sum(this%grdw_y(:,i,j,k)*this%W(i,j-1:j,k)) + end do + end do + end do + + ! Interpolate off-diagonal components of the velocity gradient to the cell center and store strain rate + do k=this%cfg%kmin_,this%cfg%kmax_ + do j=this%cfg%jmin_,this%cfg%jmax_ + do i=this%cfg%imin_,this%cfg%imax_ + SR(4,i,j,k)=0.125_WP*(sum(dudy(i:i+1,j:j+1,k ))+sum(dvdx(i:i+1,j:j+1,k ))) + SR(5,i,j,k)=0.125_WP*(sum(dvdz(i ,j:j+1,k:k+1))+sum(dwdy(i ,j:j+1,k:k+1))) + SR(6,i,j,k)=0.125_WP*(sum(dwdx(i:i+1,j ,k:k+1))+sum(dudz(i:i+1,j ,k:k+1))) + end do + end do + end do + + ! Apply a Neumann condition in non-periodic directions + if (.not.this%cfg%xper) then + if (this%cfg%iproc.eq.1) SR(:,this%cfg%imin-1,:,:)=SR(:,this%cfg%imin,:,:) + if (this%cfg%iproc.eq.this%cfg%npx) SR(:,this%cfg%imax+1,:,:)=SR(:,this%cfg%imax,:,:) + end if + if (.not.this%cfg%yper) then + if (this%cfg%jproc.eq.1) SR(:,:,this%cfg%jmin-1,:)=SR(:,:,this%cfg%jmin,:) + if (this%cfg%jproc.eq.this%cfg%npy) SR(:,:,this%cfg%jmax+1,:)=SR(:,:,this%cfg%jmax,:) + end if + if (.not.this%cfg%zper) then + if (this%cfg%kproc.eq.1) SR(:,:,:,this%cfg%kmin-1)=SR(:,:,:,this%cfg%kmin) + if (this%cfg%kproc.eq.this%cfg%npz) SR(:,:,:,this%cfg%kmax+1)=SR(:,:,:,this%cfg%kmax) + end if + + ! Ensure zero in walls + do k=this%cfg%kmino_,this%cfg%kmaxo_ + do j=this%cfg%jmino_,this%cfg%jmaxo_ + do i=this%cfg%imino_,this%cfg%imaxo_ + if (this%mask(i,j,k).eq.1) SR(:,i,j,k)=0.0_WP + end do + end do + end do + + ! Sync it + call this%cfg%sync(SR) + + ! Deallocate velocity gradient storage + deallocate(dudy,dudz,dvdx,dvdz,dwdx,dwdy) + + end subroutine get_strainrate + + + !> Calculate the velocity gradient tensor from U/V/W + !> Note that gradu(i,j)=duj/dxi + subroutine get_gradu(this,gradu) + use messager, only: die + implicit none + class(incomp), intent(inout) :: this + real(WP), dimension(1:,1:,this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(out) :: gradu !< Needs to be (1:3,1:3,imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + integer :: i,j,k + real(WP), dimension(:,:,:), allocatable :: dudy,dudz,dvdx,dvdz,dwdx,dwdy + + ! Check gradu's first two dimensions + if (size(gradu,dim=1).ne.3.or.size(gradu,dim=2).ne.3) call die('[incomp get_gradu] gradu should be of size (1:3,1:3,imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_)') + + ! Compute dudx, dvdy, and dwdz first + do k=this%cfg%kmin_,this%cfg%kmax_ + do j=this%cfg%jmin_,this%cfg%jmax_ + do i=this%cfg%imin_,this%cfg%imax_ + gradu(1,1,i,j,k)=sum(this%grdu_x(:,i,j,k)*this%U(i:i+1,j,k)) + gradu(2,2,i,j,k)=sum(this%grdv_y(:,i,j,k)*this%V(i,j:j+1,k)) + gradu(3,3,i,j,k)=sum(this%grdw_z(:,i,j,k)*this%W(i,j,k:k+1)) + end do + end do + end do + + ! Allocate velocity gradient components + allocate(dudy(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + allocate(dudz(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + allocate(dvdx(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + allocate(dvdz(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + allocate(dwdx(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + allocate(dwdy(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + + ! Calculate components of the velocity gradient at their natural locations with an extra cell for interpolation + do k=this%cfg%kmin_,this%cfg%kmax_+1 + do j=this%cfg%jmin_,this%cfg%jmax_+1 + do i=this%cfg%imin_,this%cfg%imax_+1 + dudy(i,j,k)=sum(this%grdu_y(:,i,j,k)*this%U(i,j-1:j,k)) + dudz(i,j,k)=sum(this%grdu_z(:,i,j,k)*this%U(i,j,k-1:k)) + dvdx(i,j,k)=sum(this%grdv_x(:,i,j,k)*this%V(i-1:i,j,k)) + dvdz(i,j,k)=sum(this%grdv_z(:,i,j,k)*this%V(i,j,k-1:k)) + dwdx(i,j,k)=sum(this%grdw_x(:,i,j,k)*this%W(i-1:i,j,k)) + dwdy(i,j,k)=sum(this%grdw_y(:,i,j,k)*this%W(i,j-1:j,k)) + end do + end do + end do + + ! Interpolate off-diagonal components of the velocity gradient to the cell center + do k=this%cfg%kmin_,this%cfg%kmax_ + do j=this%cfg%jmin_,this%cfg%jmax_ + do i=this%cfg%imin_,this%cfg%imax_ + gradu(2,1,i,j,k)=0.25_WP*sum(dudy(i:i+1,j:j+1,k)) + gradu(3,1,i,j,k)=0.25_WP*sum(dudz(i:i+1,j,k:k+1)) + gradu(1,2,i,j,k)=0.25_WP*sum(dvdx(i:i+1,j:j+1,k)) + gradu(3,2,i,j,k)=0.25_WP*sum(dvdz(i,j:j+1,k:k+1)) + gradu(1,3,i,j,k)=0.25_WP*sum(dwdx(i:i+1,j,k:k+1)) + gradu(2,3,i,j,k)=0.25_WP*sum(dwdy(i,j:j+1,k:k+1)) + end do + end do + end do + + ! Apply a Neumann condition in non-periodic directions + if (.not.this%cfg%xper) then + if (this%cfg%iproc.eq.1) gradu(:,:,this%cfg%imin-1,:,:)=gradu(:,:,this%cfg%imin,:,:) + if (this%cfg%iproc.eq.this%cfg%npx) gradu(:,:,this%cfg%imax+1,:,:)=gradu(:,:,this%cfg%imax,:,:) + end if + if (.not.this%cfg%yper) then + if (this%cfg%jproc.eq.1) gradu(:,:,:,this%cfg%jmin-1,:)=gradu(:,:,:,this%cfg%jmin,:) + if (this%cfg%jproc.eq.this%cfg%npy) gradu(:,:,:,this%cfg%jmax+1,:)=gradu(:,:,:,this%cfg%jmax,:) + end if + if (.not.this%cfg%zper) then + if (this%cfg%kproc.eq.1) gradu(:,:,:,:,this%cfg%kmin-1)=gradu(:,:,:,:,this%cfg%kmin) + if (this%cfg%kproc.eq.this%cfg%npz) gradu(:,:,:,:,this%cfg%kmax+1)=gradu(:,:,:,:,this%cfg%kmax) + end if + + ! Ensure zero in walls + do k=this%cfg%kmino_,this%cfg%kmaxo_ + do j=this%cfg%jmino_,this%cfg%jmaxo_ + do i=this%cfg%imino_,this%cfg%imaxo_ + if (this%mask(i,j,k).eq.1) gradu(:,:,i,j,k)=0.0_WP + end do + end do + end do + + ! Sync it + call this%cfg%sync(gradu) + + ! Deallocate velocity gradient storage + deallocate(dudy,dudz,dvdx,dvdz,dwdx,dwdy) + + end subroutine get_gradu + + + !> Calculate vorticity vector + subroutine get_vorticity(this,vort) + use messager, only: die + implicit none + class(incomp), intent(inout) :: this + real(WP), dimension(1:,this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(out) :: vort !< Needs to be (1:3,imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + integer :: i,j,k + real(WP), dimension(:,:,:), allocatable :: dudy,dudz,dvdx,dvdz,dwdx,dwdy + + ! Check vort's first two dimensions + if (size(vort,dim=1).ne.3) call die('[incomp get_vorticity] vort should be of size (1:3,imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_)') + + ! Allocate velocity gradient components + allocate(dudy(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + allocate(dudz(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + allocate(dvdx(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + allocate(dvdz(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + allocate(dwdx(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + allocate(dwdy(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + + ! Calculate components of the velocity gradient at their natural locations with an extra cell for interpolation + do k=this%cfg%kmin_,this%cfg%kmax_+1 + do j=this%cfg%jmin_,this%cfg%jmax_+1 + do i=this%cfg%imin_,this%cfg%imax_+1 + dudy(i,j,k)=sum(this%grdu_y(:,i,j,k)*this%U(i,j-1:j,k)) + dudz(i,j,k)=sum(this%grdu_z(:,i,j,k)*this%U(i,j,k-1:k)) + dvdx(i,j,k)=sum(this%grdv_x(:,i,j,k)*this%V(i-1:i,j,k)) + dvdz(i,j,k)=sum(this%grdv_z(:,i,j,k)*this%V(i,j,k-1:k)) + dwdx(i,j,k)=sum(this%grdw_x(:,i,j,k)*this%W(i-1:i,j,k)) + dwdy(i,j,k)=sum(this%grdw_y(:,i,j,k)*this%W(i,j-1:j,k)) + end do + end do + end do + + ! Interpolate off-diagonal components of the velocity gradient to the cell center + do k=this%cfg%kmin_,this%cfg%kmax_ + do j=this%cfg%jmin_,this%cfg%jmax_ + do i=this%cfg%imin_,this%cfg%imax_ + vort(1,i,j,k)=0.25_WP*(sum(dwdy(i,j:j+1,k:k+1))-sum(dvdz(i,j:j+1,k:k+1))) + vort(2,i,j,k)=0.25_WP*(sum(dudz(i:i+1,j,k:k+1))-sum(dwdx(i:i+1,j,k:k+1))) + vort(3,i,j,k)=0.25_WP*(sum(dvdx(i:i+1,j:j+1,k))-sum(dudy(i:i+1,j:j+1,k))) + end do + end do + end do + + ! Apply a Neumann condition in non-periodic directions + if (.not.this%cfg%xper) then + if (this%cfg%iproc.eq.1) vort(:,this%cfg%imin-1,:,:)=vort(:,this%cfg%imin,:,:) + if (this%cfg%iproc.eq.this%cfg%npx) vort(:,this%cfg%imax+1,:,:)=vort(:,this%cfg%imax,:,:) + end if + if (.not.this%cfg%yper) then + if (this%cfg%jproc.eq.1) vort(:,:,this%cfg%jmin-1,:)=vort(:,:,this%cfg%jmin,:) + if (this%cfg%jproc.eq.this%cfg%npy) vort(:,:,this%cfg%jmax+1,:)=vort(:,:,this%cfg%jmax,:) + end if + if (.not.this%cfg%zper) then + if (this%cfg%kproc.eq.1) vort(:,:,:,this%cfg%kmin-1)=vort(:,:,:,this%cfg%kmin) + if (this%cfg%kproc.eq.this%cfg%npz) vort(:,:,:,this%cfg%kmax+1)=vort(:,:,:,this%cfg%kmax) + end if + + ! Ensure zero in walls + do k=this%cfg%kmino_,this%cfg%kmaxo_ + do j=this%cfg%jmino_,this%cfg%jmaxo_ + do i=this%cfg%imino_,this%cfg%imaxo_ + if (this%mask(i,j,k).eq.1) vort(:,i,j,k)=0.0_WP + end do + end do + end do + + ! Sync it + call this%cfg%sync(vort) + + ! Deallocate velocity gradient storage + deallocate(dudy,dudz,dvdx,dvdz,dwdx,dwdy) + + end subroutine get_vorticity + + + !> Calculate the CFL + subroutine get_cfl(this,dt,cflc,cfl) + use mpi_f08, only: MPI_ALLREDUCE,MPI_MAX + use parallel, only: MPI_REAL_WP + implicit none + class(incomp), intent(inout) :: this + real(WP), intent(in) :: dt + real(WP), intent(out) :: cflc + real(WP), optional :: cfl + integer :: i,j,k,ierr + real(WP) :: my_CFLc_x,my_CFLc_y,my_CFLc_z,my_CFLv_x,my_CFLv_y,my_CFLv_z + + ! Set the CFLs to zero + my_CFLc_x=0.0_WP; my_CFLc_y=0.0_WP; my_CFLc_z=0.0_WP + my_CFLv_x=0.0_WP; my_CFLv_y=0.0_WP; my_CFLv_z=0.0_WP + do k=this%cfg%kmin_,this%cfg%kmax_ + do j=this%cfg%jmin_,this%cfg%jmax_ + do i=this%cfg%imin_,this%cfg%imax_ + my_CFLc_x=max(my_CFLc_x,abs(this%U(i,j,k))*this%cfg%dxmi(i)) + my_CFLc_y=max(my_CFLc_y,abs(this%V(i,j,k))*this%cfg%dymi(j)) + my_CFLc_z=max(my_CFLc_z,abs(this%W(i,j,k))*this%cfg%dzmi(k)) + my_CFLv_x=max(my_CFLv_x,4.0_WP*this%visc(i,j,k)*this%cfg%dxi(i)**2/this%rho) + my_CFLv_y=max(my_CFLv_y,4.0_WP*this%visc(i,j,k)*this%cfg%dyi(j)**2/this%rho) + my_CFLv_z=max(my_CFLv_z,4.0_WP*this%visc(i,j,k)*this%cfg%dzi(k)**2/this%rho) + end do + end do + end do + my_CFLc_x=my_CFLc_x*dt; my_CFLc_y=my_CFLc_y*dt; my_CFLc_z=my_CFLc_z*dt + my_CFLv_x=my_CFLv_x*dt; my_CFLv_y=my_CFLv_y*dt; my_CFLv_z=my_CFLv_z*dt + + ! Get the parallel max + call MPI_ALLREDUCE(my_CFLc_x,this%CFLc_x,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + call MPI_ALLREDUCE(my_CFLc_y,this%CFLc_y,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + call MPI_ALLREDUCE(my_CFLc_z,this%CFLc_z,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + call MPI_ALLREDUCE(my_CFLv_x,this%CFLv_x,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + call MPI_ALLREDUCE(my_CFLv_y,this%CFLv_y,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + call MPI_ALLREDUCE(my_CFLv_z,this%CFLv_z,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + + ! Return the maximum convective CFL + cflc=max(this%CFLc_x,this%CFLc_y,this%CFLc_z) + + ! If asked for, also return the maximum overall CFL + if (present(CFL)) cfl=max(this%CFLc_x,this%CFLc_y,this%CFLc_z,this%CFLv_x,this%CFLv_y,this%CFLv_z) + + end subroutine get_cfl + + + !> Calculate the max of our fields + subroutine get_max(this) + use mpi_f08, only: MPI_ALLREDUCE,MPI_MAX + use parallel, only: MPI_REAL_WP + implicit none + class(incomp), intent(inout) :: this + integer :: i,j,k,ierr + real(WP) :: my_Umax,my_Vmax,my_Wmax,my_Pmax,my_divmax + + ! Set all to zero + my_Umax=0.0_WP; my_Vmax=0.0_WP; my_Wmax=0.0_WP; my_Pmax=0.0_WP; my_divmax=0.0_WP + do k=this%cfg%kmin_,this%cfg%kmax_ + do j=this%cfg%jmin_,this%cfg%jmax_ + do i=this%cfg%imin_,this%cfg%imax_ + my_Umax =max(my_Umax ,abs(this%U(i,j,k) )) + my_Vmax =max(my_Vmax ,abs(this%V(i,j,k) )) + my_Wmax =max(my_Wmax ,abs(this%W(i,j,k) )) + if (this%cfg%VF(i,j,k).gt.0.0_WP) my_Pmax =max(my_Pmax ,abs(this%P(i,j,k) )) + if (this%cfg%VF(i,j,k).gt.0.0_WP) my_divmax=max(my_divmax,abs(this%div(i,j,k))) + end do + end do + end do + + ! Get the parallel max + call MPI_ALLREDUCE(my_Umax ,this%Umax ,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + call MPI_ALLREDUCE(my_Vmax ,this%Vmax ,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + call MPI_ALLREDUCE(my_Wmax ,this%Wmax ,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + call MPI_ALLREDUCE(my_Pmax ,this%Pmax ,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + call MPI_ALLREDUCE(my_divmax,this%divmax,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + + end subroutine get_max + + + !> Compute MFR through all bcs + subroutine get_mfr(this) + use mpi_f08, only: MPI_SUM,MPI_ALLREDUCE + use parallel, only: MPI_REAL_WP + implicit none + class(incomp), intent(inout) :: this + integer :: i,j,k,n,ibc,ierr + type(bcond), pointer :: my_bc + real(WP), dimension(:), allocatable :: my_mfr,my_area + real(WP), dimension(:), allocatable :: canCorrect + + ! Ensure this%mfr is of proper size + if (.not.allocated(this%mfr)) then + allocate(this%mfr(this%nbc)) + else + if (size(this%mfr).ne.this%nbc) then + deallocate(this%mfr); allocate(this%mfr(this%nbc)) + end if + end if + + ! Ensure this%area is of proper size + if (.not.allocated(this%area)) then + allocate(this%area(this%nbc)) + else + if (size(this%area).ne.this%nbc) then + deallocate(this%area); allocate(this%area(this%nbc)) + end if + end if + + ! Allocate temp array for communication + allocate(my_mfr(this%nbc)) + allocate(my_area(this%nbc)) + allocate(canCorrect(this%nbc)) + + ! Traverse bcond list and integrate local outgoing MFR + my_bc=>this%first_bc; ibc=1 + do while (associated(my_bc)) + + ! Set zero local MFR and area + my_mfr(ibc)=0.0_WP + my_area(ibc)=0.0_WP + if (my_bc%canCorrect) then + canCorrect(ibc)=1.0_WP + else + canCorrect(ibc)=0.0_WP + end if + + ! Only processes inside the bcond have a non-zero MFR + if (my_bc%itr%amIn) then + + ! Implement based on bcond face and dir, loop over interior only + select case (my_bc%face) + case ('x') + do n=1,my_bc%itr%n_ + i=my_bc%itr%map(1,n); j=my_bc%itr%map(2,n); k=my_bc%itr%map(3,n) + my_mfr(ibc)=my_mfr(ibc)+my_bc%rdir*this%rho*this%U(i,j,k)*this%cfg%dy(j)*this%cfg%dz(k) + my_area(ibc)=my_area(ibc)+this%cfg%dy(j)*this%cfg%dz(k) + end do + case ('y') + do n=1,my_bc%itr%n_ + i=my_bc%itr%map(1,n); j=my_bc%itr%map(2,n); k=my_bc%itr%map(3,n) + my_mfr(ibc)=my_mfr(ibc)+my_bc%rdir*this%rho*this%V(i,j,k)*this%cfg%dz(k)*this%cfg%dx(i) + my_area(ibc)=my_area(ibc)+this%cfg%dz(k)*this%cfg%dx(i) + end do + case ('z') + do n=1,my_bc%itr%n_ + i=my_bc%itr%map(1,n); j=my_bc%itr%map(2,n); k=my_bc%itr%map(3,n) + my_mfr(ibc)=my_mfr(ibc)+my_bc%rdir*this%rho*this%W(i,j,k)*this%cfg%dx(i)*this%cfg%dy(j) + my_area(ibc)=my_area(ibc)+this%cfg%dx(i)*this%cfg%dy(j) + end do + end select + + end if + + ! Move on to the next bcond + my_bc=>my_bc%next; ibc=ibc+1 + + end do + + ! Sum up all values + call MPI_ALLREDUCE(my_mfr ,this%mfr ,this%nbc,MPI_REAL_WP,MPI_SUM,this%cfg%comm,ierr) + call MPI_ALLREDUCE(my_area,this%area,this%nbc,MPI_REAL_WP,MPI_SUM,this%cfg%comm,ierr) + + ! Compute the correctable area + this%correctable_area=sum(this%area*canCorrect) + + ! Deallocate temp array + deallocate(my_mfr,my_area,canCorrect) + + end subroutine get_mfr + + + !> Correct MFR through correctable bconds + subroutine correct_mfr(this,src) + use mpi_f08, only: MPI_SUM + implicit none + class(incomp), intent(inout) :: this + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), optional :: src !< Mass source term + real(WP) :: mfr_error,vel_correction,int + integer :: i,j,k,n + type(bcond), pointer :: my_bc + + ! Evaluate MFR mismatch and velocity correction + call this%get_mfr() + mfr_error=sum(this%mfr) + if (present(src)) then + ! Also account for provided source term + call this%cfg%integrate_without_VF(src,int) + mfr_error=mfr_error-int + end if + if (abs(mfr_error).lt.10.0_WP*epsilon(1.0_WP).or.abs(this%correctable_area).lt.10.0_WP*epsilon(1.0_WP)) return + vel_correction=-mfr_error/(this%rho*this%correctable_area) + + ! Traverse bcond list and correct bcond MFR + my_bc=>this%first_bc + do while (associated(my_bc)) + + ! Only processes inside correctable bcond need to work + if (my_bc%itr%amIn.and.my_bc%canCorrect) then + + ! Implement based on bcond direction, loop over all cell + select case (my_bc%face) + case ('x') + do n=1,my_bc%itr%n_ + i=my_bc%itr%map(1,n); j=my_bc%itr%map(2,n); k=my_bc%itr%map(3,n) + this%U(i,j,k)=this%U(i,j,k)+my_bc%rdir*vel_correction + end do + case ('y') + do n=1,my_bc%itr%n_ + i=my_bc%itr%map(1,n); j=my_bc%itr%map(2,n); k=my_bc%itr%map(3,n) + this%V(i,j,k)=this%V(i,j,k)+my_bc%rdir*vel_correction + end do + case ('z') + do n=1,my_bc%itr%n_ + i=my_bc%itr%map(1,n); j=my_bc%itr%map(2,n); k=my_bc%itr%map(3,n) + this%W(i,j,k)=this%W(i,j,k)+my_bc%rdir*vel_correction + end do + end select + + end if + + ! Move on to the next bcond + my_bc=>my_bc%next + + end do + + ! Sync full fields + call this%cfg%sync(this%U) + call this%cfg%sync(this%V) + call this%cfg%sync(this%W) + + end subroutine correct_mfr + + + !> Shift pressure to ensure zero average + subroutine shift_p(this,pressure) + implicit none + class(incomp), intent(in) :: this + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(inout) :: pressure !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + real(WP) :: pressure_tot + integer :: i,j,k + + ! Compute volume-averaged pressure + call this%cfg%integrate(A=pressure,integral=pressure_tot); pressure_tot=pressure_tot/this%cfg%fluid_vol + + ! Shift the pressure + do k=this%cfg%kmin_,this%cfg%kmax_ + do j=this%cfg%jmin_,this%cfg%jmax_ + do i=this%cfg%imin_,this%cfg%imax_ + if (this%cfg%VF(i,j,k).gt.0.0_WP) pressure(i,j,k)=pressure(i,j,k)-pressure_tot + end do + end do + end do + call this%cfg%sync(pressure) + + end subroutine shift_p + + + !> Solve for implicit velocity residual + subroutine solve_implicit(this,dt,resU,resV,resW) + implicit none + class(incomp), intent(inout) :: this + real(WP), intent(in) :: dt + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(inout) :: resU !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(inout) :: resV !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(inout) :: resW !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + integer :: i,j,k + real(WP) :: rhoUp,rhoUm,rhoVp,rhoVm,rhoWp,rhoWm + + ! If no implicit solver available, just divide by density and return + if (.not.associated(this%implicit)) then + resU=resU/this%rho + resV=resV/this%rho + resW=resW/this%rho + call this%cfg%sync(resU) + call this%cfg%sync(resV) + call this%cfg%sync(resW) + return + end if + + ! Solve implicit U problem + this%implicit%opr(1,:,:,:)=this%rho; this%implicit%opr(2:,:,:,:)=0.0_WP + do k=this%cfg%kmin_,this%cfg%kmax_ + do j=this%cfg%jmin_,this%cfg%jmax_ + do i=this%cfg%imin_,this%cfg%imax_ + rhoUp=this%rho*sum(this%itpu_x(:,i ,j,k)*this%U(i :i+1,j,k))*2.0_WP + rhoUm=this%rho*sum(this%itpu_x(:,i-1,j,k)*this%U(i-1:i ,j,k))*2.0_WP + rhoVp=this%rho*sum(this%itpv_x(:,i,j+1,k)*this%V(i-1:i,j+1,k)) + rhoVm=this%rho*sum(this%itpv_x(:,i,j ,k)*this%V(i-1:i,j ,k)) + rhoWp=this%rho*sum(this%itpw_x(:,i,j,k+1)*this%W(i-1:i,j,k+1)) + rhoWm=this%rho*sum(this%itpw_x(:,i,j,k )*this%W(i-1:i,j,k )) + this%implicit%opr(1,i,j,k)=this%implicit%opr(1,i,j,k)+0.5_WP*dt*(this%divu_x( 0,i,j,k)*this%itpu_x( 0,i ,j,k)*rhoUp+& + & this%divu_x(-1,i,j,k)*this%itpu_x(+1,i-1,j,k)*rhoUm+& + & this%divu_y(+1,i,j,k)*this%itpu_y(-1,i,j+1,k)*rhoVp+& + & this%divu_y( 0,i,j,k)*this%itpu_y( 0,i,j ,k)*rhoVm+& + & this%divu_z(+1,i,j,k)*this%itpu_z(-1,i,j,k+1)*rhoWp+& + & this%divu_z( 0,i,j,k)*this%itpu_z( 0,i,j,k )*rhoWm) + this%implicit%opr(2,i,j,k)=this%implicit%opr(2,i,j,k)+0.5_WP*dt*(this%divu_x( 0,i,j,k)*this%itpu_x(+1,i ,j,k)*rhoUp) + this%implicit%opr(3,i,j,k)=this%implicit%opr(3,i,j,k)+0.5_WP*dt*(this%divu_x(-1,i,j,k)*this%itpu_x( 0,i-1,j,k)*rhoUm) + this%implicit%opr(4,i,j,k)=this%implicit%opr(4,i,j,k)+0.5_WP*dt*(this%divu_y(+1,i,j,k)*this%itpu_y( 0,i,j+1,k)*rhoVp) + this%implicit%opr(5,i,j,k)=this%implicit%opr(5,i,j,k)+0.5_WP*dt*(this%divu_y( 0,i,j,k)*this%itpu_y(-1,i,j ,k)*rhoVm) + this%implicit%opr(6,i,j,k)=this%implicit%opr(6,i,j,k)+0.5_WP*dt*(this%divu_z(+1,i,j,k)*this%itpu_z( 0,i,j,k+1)*rhoWp) + this%implicit%opr(7,i,j,k)=this%implicit%opr(7,i,j,k)+0.5_WP*dt*(this%divu_z( 0,i,j,k)*this%itpu_z(-1,i,j,k )*rhoWm) + end do + end do + end do + do k=this%cfg%kmin_,this%cfg%kmax_ + do j=this%cfg%jmin_,this%cfg%jmax_ + do i=this%cfg%imin_,this%cfg%imax_ + this%implicit%opr(1,i,j,k)=this%implicit%opr(1,i,j,k)-0.5_WP*dt*(this%divu_x( 0,i,j,k)*4.0_WP/3.0_WP* this%visc(i ,j,k) *this%grdu_x( 0,i ,j,k)+& + & this%divu_x(-1,i,j,k)*4.0_WP/3.0_WP* this%visc(i-1,j,k) *this%grdu_x(+1,i-1,j,k)+& + & this%divu_y(+1,i,j,k)*sum(this%itp_xy(:,:,i,j+1,k)*this%visc(i-1:i,j:j+1,k))*this%grdu_y(-1,i,j+1,k)+& + & this%divu_y( 0,i,j,k)*sum(this%itp_xy(:,:,i,j ,k)*this%visc(i-1:i,j-1:j,k))*this%grdu_y( 0,i,j ,k)+& + & this%divu_z(+1,i,j,k)*sum(this%itp_xz(:,:,i,j,k+1)*this%visc(i-1:i,j,k:k+1))*this%grdu_z(-1,i,j,k+1)+& + & this%divu_z( 0,i,j,k)*sum(this%itp_xz(:,:,i,j,k )*this%visc(i-1:i,j,k-1:k))*this%grdu_z( 0,i,j,k )) + this%implicit%opr(2,i,j,k)=this%implicit%opr(2,i,j,k)-0.5_WP*dt*(this%divu_x( 0,i,j,k)*4.0_WP/3.0_WP* this%visc(i ,j,k) *this%grdu_x(+1,i ,j,k)) + this%implicit%opr(3,i,j,k)=this%implicit%opr(3,i,j,k)-0.5_WP*dt*(this%divu_x(-1,i,j,k)*4.0_WP/3.0_WP* this%visc(i-1,j,k) *this%grdu_x( 0,i-1,j,k)) + this%implicit%opr(4,i,j,k)=this%implicit%opr(4,i,j,k)-0.5_WP*dt*(this%divu_y(+1,i,j,k)*sum(this%itp_xy(:,:,i,j+1,k)*this%visc(i-1:i,j:j+1,k))*this%grdu_y( 0,i,j+1,k)) + this%implicit%opr(5,i,j,k)=this%implicit%opr(5,i,j,k)-0.5_WP*dt*(this%divu_y( 0,i,j,k)*sum(this%itp_xy(:,:,i,j ,k)*this%visc(i-1:i,j-1:j,k))*this%grdu_y(-1,i,j ,k)) + this%implicit%opr(6,i,j,k)=this%implicit%opr(6,i,j,k)-0.5_WP*dt*(this%divu_z(+1,i,j,k)*sum(this%itp_xz(:,:,i,j,k+1)*this%visc(i-1:i,j,k:k+1))*this%grdu_z( 0,i,j,k+1)) + this%implicit%opr(7,i,j,k)=this%implicit%opr(7,i,j,k)-0.5_WP*dt*(this%divu_z( 0,i,j,k)*sum(this%itp_xz(:,:,i,j,k )*this%visc(i-1:i,j,k-1:k))*this%grdu_z(-1,i,j,k )) + end do + end do + end do + call this%implicit%setup() + this%implicit%rhs=resU + this%implicit%sol=0.0_WP + call this%implicit%solve() + resU=this%implicit%sol + + ! Solve implicit V problem + this%implicit%opr(1,:,:,:)=this%rho; this%implicit%opr(2:,:,:,:)=0.0_WP + do k=this%cfg%kmin_,this%cfg%kmax_ + do j=this%cfg%jmin_,this%cfg%jmax_ + do i=this%cfg%imin_,this%cfg%imax_ + rhoUp=this%rho*sum(this%itpu_y(:,i+1,j,k)*this%U(i+1,j-1:j,k)) + rhoUm=this%rho*sum(this%itpu_y(:,i ,j,k)*this%U(i ,j-1:j,k)) + rhoVp=this%rho*sum(this%itpv_y(:,i,j ,k)*this%V(i,j :j+1,k))*2.0_WP + rhoVm=this%rho*sum(this%itpv_y(:,i,j-1,k)*this%V(i,j-1:j ,k))*2.0_WP + rhoWp=this%rho*sum(this%itpw_y(:,i,j,k+1)*this%W(i,j-1:j,k+1)) + rhoWm=this%rho*sum(this%itpw_y(:,i,j,k )*this%W(i,j-1:j,k )) + this%implicit%opr(1,i,j,k)=this%implicit%opr(1,i,j,k)+0.5_WP*dt*(this%divv_x(+1,i,j,k)*this%itpv_x(-1,i+1,j,k)*rhoUp+& + & this%divv_x( 0,i,j,k)*this%itpv_x( 0,i ,j,k)*rhoUm+& + & this%divv_y( 0,i,j,k)*this%itpv_y( 0,i,j ,k)*rhoVp+& + & this%divv_y(-1,i,j,k)*this%itpv_y(+1,i,j-1,k)*rhoVm+& + & this%divv_z(+1,i,j,k)*this%itpv_z(-1,i,j,k+1)*rhoWp+& + & this%divv_z( 0,i,j,k)*this%itpv_z( 0,i,j,k )*rhoWm) + this%implicit%opr(2,i,j,k)=this%implicit%opr(2,i,j,k)+0.5_WP*dt*(this%divv_x(+1,i,j,k)*this%itpv_x( 0,i+1,j,k)*rhoUp) + this%implicit%opr(3,i,j,k)=this%implicit%opr(3,i,j,k)+0.5_WP*dt*(this%divv_x( 0,i,j,k)*this%itpv_x(-1,i ,j,k)*rhoUm) + this%implicit%opr(4,i,j,k)=this%implicit%opr(4,i,j,k)+0.5_WP*dt*(this%divv_y( 0,i,j,k)*this%itpv_y(+1,i,j ,k)*rhoVp) + this%implicit%opr(5,i,j,k)=this%implicit%opr(5,i,j,k)+0.5_WP*dt*(this%divv_y(-1,i,j,k)*this%itpv_y( 0,i,j-1,k)*rhoVm) + this%implicit%opr(6,i,j,k)=this%implicit%opr(6,i,j,k)+0.5_WP*dt*(this%divv_z(+1,i,j,k)*this%itpv_z( 0,i,j,k+1)*rhoWp) + this%implicit%opr(7,i,j,k)=this%implicit%opr(7,i,j,k)+0.5_WP*dt*(this%divv_z( 0,i,j,k)*this%itpv_z(-1,i,j,k )*rhoWm) + end do + end do + end do + do k=this%cfg%kmin_,this%cfg%kmax_ + do j=this%cfg%jmin_,this%cfg%jmax_ + do i=this%cfg%imin_,this%cfg%imax_ + this%implicit%opr(1,i,j,k)=this%implicit%opr(1,i,j,k)-0.5_WP*dt*(this%divv_x(+1,i,j,k)*sum(this%itp_xy(:,:,i+1,j,k)*this%visc(i:i+1,j-1:j,k))*this%grdv_x(-1,i+1,j,k)+& + & this%divv_x( 0,i,j,k)*sum(this%itp_xy(:,:,i ,j,k)*this%visc(i-1:i,j-1:j,k))*this%grdv_x( 0,i ,j,k)+& + & this%divv_y( 0,i,j,k)*4.0_WP/3.0_WP* this%visc(i,j ,k) *this%grdv_y( 0,i,j ,k)+& + & this%divv_y(-1,i,j,k)*4.0_WP/3.0_WP* this%visc(i,j-1,k) *this%grdv_y(+1,i,j-1,k)+& + & this%divv_z(+1,i,j,k)*sum(this%itp_yz(:,:,i,j,k+1)*this%visc(i,j-1:j,k:k+1))*this%grdv_z(-1,i,j,k+1)+& + & this%divv_z( 0,i,j,k)*sum(this%itp_yz(:,:,i,j,k )*this%visc(i,j-1:j,k-1:k))*this%grdv_z( 0,i,j,k )) + this%implicit%opr(2,i,j,k)=this%implicit%opr(2,i,j,k)-0.5_WP*dt*(this%divv_x(+1,i,j,k)*sum(this%itp_xy(:,:,i+1,j,k)*this%visc(i:i+1,j-1:j,k))*this%grdv_x( 0,i+1,j,k)) + this%implicit%opr(3,i,j,k)=this%implicit%opr(3,i,j,k)-0.5_WP*dt*(this%divv_x( 0,i,j,k)*sum(this%itp_xy(:,:,i ,j,k)*this%visc(i-1:i,j-1:j,k))*this%grdv_x(-1,i ,j,k)) + this%implicit%opr(4,i,j,k)=this%implicit%opr(4,i,j,k)-0.5_WP*dt*(this%divv_y( 0,i,j,k)*4.0_WP/3.0_WP* this%visc(i,j ,k) *this%grdv_y(+1,i,j ,k)) + this%implicit%opr(5,i,j,k)=this%implicit%opr(5,i,j,k)-0.5_WP*dt*(this%divv_y(-1,i,j,k)*4.0_WP/3.0_WP* this%visc(i,j-1,k) *this%grdv_y( 0,i,j-1,k)) + this%implicit%opr(6,i,j,k)=this%implicit%opr(6,i,j,k)-0.5_WP*dt*(this%divv_z(+1,i,j,k)*sum(this%itp_yz(:,:,i,j,k+1)*this%visc(i,j-1:j,k:k+1))*this%grdv_z( 0,i,j,k+1)) + this%implicit%opr(7,i,j,k)=this%implicit%opr(7,i,j,k)-0.5_WP*dt*(this%divv_z( 0,i,j,k)*sum(this%itp_yz(:,:,i,j,k )*this%visc(i,j-1:j,k-1:k))*this%grdv_z(-1,i,j,k )) + end do + end do + end do + call this%implicit%setup() + this%implicit%rhs=resV + this%implicit%sol=0.0_WP + call this%implicit%solve() + resV=this%implicit%sol + + ! Solve implicit W problem + this%implicit%opr(1,:,:,:)=this%rho; this%implicit%opr(2:,:,:,:)=0.0_WP + do k=this%cfg%kmin_,this%cfg%kmax_ + do j=this%cfg%jmin_,this%cfg%jmax_ + do i=this%cfg%imin_,this%cfg%imax_ + rhoUp=this%rho*sum(this%itpu_z(:,i+1,j,k)*this%U(i+1,j,k-1:k)) + rhoUm=this%rho*sum(this%itpu_z(:,i ,j,k)*this%U(i ,j,k-1:k)) + rhoVp=this%rho*sum(this%itpv_z(:,i,j+1,k)*this%V(i,j+1,k-1:k)) + rhoVm=this%rho*sum(this%itpv_z(:,i,j ,k)*this%V(i,j ,k-1:k)) + rhoWp=this%rho*sum(this%itpw_z(:,i,j,k )*this%W(i,j,k :k+1))*2.0_WP + rhoWm=this%rho*sum(this%itpw_z(:,i,j,k-1)*this%W(i,j,k-1:k ))*2.0_WP + this%implicit%opr(1,i,j,k)=this%implicit%opr(1,i,j,k)+0.5_WP*dt*(this%divw_x(+1,i,j,k)*this%itpw_x(-1,i+1,j,k)*rhoUp+& + & this%divw_x( 0,i,j,k)*this%itpw_x( 0,i ,j,k)*rhoUm+& + & this%divw_y(+1,i,j,k)*this%itpw_y(-1,i,j+1,k)*rhoVp+& + & this%divw_y( 0,i,j,k)*this%itpw_y( 0,i,j ,k)*rhoVm+& + & this%divw_z( 0,i,j,k)*this%itpw_z( 0,i,j,k )*rhoWp+& + & this%divw_z(-1,i,j,k)*this%itpw_z(+1,i,j,k-1)*rhoWm) + this%implicit%opr(2,i,j,k)=this%implicit%opr(2,i,j,k)+0.5_WP*dt*(this%divw_x(+1,i,j,k)*this%itpw_x( 0,i+1,j,k)*rhoUp) + this%implicit%opr(3,i,j,k)=this%implicit%opr(3,i,j,k)+0.5_WP*dt*(this%divw_x( 0,i,j,k)*this%itpw_x(-1,i ,j,k)*rhoUm) + this%implicit%opr(4,i,j,k)=this%implicit%opr(4,i,j,k)+0.5_WP*dt*(this%divw_y(+1,i,j,k)*this%itpw_y( 0,i,j+1,k)*rhoVp) + this%implicit%opr(5,i,j,k)=this%implicit%opr(5,i,j,k)+0.5_WP*dt*(this%divw_y( 0,i,j,k)*this%itpw_y(-1,i,j ,k)*rhoVm) + this%implicit%opr(6,i,j,k)=this%implicit%opr(6,i,j,k)+0.5_WP*dt*(this%divw_z( 0,i,j,k)*this%itpw_z(+1,i,j,k )*rhoWp) + this%implicit%opr(7,i,j,k)=this%implicit%opr(7,i,j,k)+0.5_WP*dt*(this%divw_z(-1,i,j,k)*this%itpw_z( 0,i,j,k-1)*rhoWm) + end do + end do + end do + do k=this%cfg%kmin_,this%cfg%kmax_ + do j=this%cfg%jmin_,this%cfg%jmax_ + do i=this%cfg%imin_,this%cfg%imax_ + this%implicit%opr(1,i,j,k)=this%implicit%opr(1,i,j,k)-0.5_WP*dt*(this%divw_x(+1,i,j,k)*sum(this%itp_xz(:,:,i+1,j,k)*this%visc(i:i+1,j,k-1:k))*this%grdw_x(-1,i+1,j,k)+& + & this%divw_x( 0,i,j,k)*sum(this%itp_xz(:,:,i ,j,k)*this%visc(i-1:i,j,k-1:k))*this%grdw_x( 0,i ,j,k)+& + & this%divw_y(+1,i,j,k)*sum(this%itp_yz(:,:,i,j+1,k)*this%visc(i,j:j+1,k-1:k))*this%grdw_y(-1,i,j+1,k)+& + & this%divw_y( 0,i,j,k)*sum(this%itp_yz(:,:,i,j ,k)*this%visc(i,j-1:j,k-1:k))*this%grdw_y( 0,i,j ,k)+& + & this%divw_z( 0,i,j,k)*4.0_WP/3.0_WP* this%visc(i,j,k ) *this%grdw_z( 0,i,j,k )+& + & this%divw_z(-1,i,j,k)*4.0_WP/3.0_WP* this%visc(i,j,k-1) *this%grdw_z(+1,i,j,k-1)) + this%implicit%opr(2,i,j,k)=this%implicit%opr(2,i,j,k)-0.5_WP*dt*(this%divw_x(+1,i,j,k)*sum(this%itp_xz(:,:,i+1,j,k)*this%visc(i:i+1,j,k-1:k))*this%grdw_x( 0,i+1,j,k)) + this%implicit%opr(3,i,j,k)=this%implicit%opr(3,i,j,k)-0.5_WP*dt*(this%divw_x( 0,i,j,k)*sum(this%itp_xz(:,:,i ,j,k)*this%visc(i-1:i,j,k-1:k))*this%grdw_x(-1,i ,j,k)) + this%implicit%opr(4,i,j,k)=this%implicit%opr(4,i,j,k)-0.5_WP*dt*(this%divw_y(+1,i,j,k)*sum(this%itp_yz(:,:,i,j+1,k)*this%visc(i,j:j+1,k-1:k))*this%grdw_y( 0,i,j+1,k)) + this%implicit%opr(5,i,j,k)=this%implicit%opr(5,i,j,k)-0.5_WP*dt*(this%divw_y( 0,i,j,k)*sum(this%itp_yz(:,:,i,j ,k)*this%visc(i,j-1:j,k-1:k))*this%grdw_y(-1,i,j ,k)) + this%implicit%opr(6,i,j,k)=this%implicit%opr(6,i,j,k)-0.5_WP*dt*(this%divw_z( 0,i,j,k)*4.0_WP/3.0_WP* this%visc(i,j,k ) *this%grdw_z(+1,i,j,k )) + this%implicit%opr(7,i,j,k)=this%implicit%opr(7,i,j,k)-0.5_WP*dt*(this%divw_z(-1,i,j,k)*4.0_WP/3.0_WP* this%visc(i,j,k-1) *this%grdw_z( 0,i,j,k-1)) + end do + end do + end do + call this%implicit%setup() + this%implicit%rhs=resW + this%implicit%sol=0.0_WP + call this%implicit%solve() + resW=this%implicit%sol + + end subroutine solve_implicit + + + !> Add gravity source term + subroutine addsrc_gravity(this,resU,resV,resW) + implicit none + class(incomp), intent(inout) :: this + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(inout) :: resU !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(inout) :: resV !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(inout) :: resW !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + integer :: i,j,k + do k=this%cfg%kmin_,this%cfg%kmax_ + do j=this%cfg%jmin_,this%cfg%jmax_ + do i=this%cfg%imin_,this%cfg%imax_ + if (this%umask(i,j,k).eq.0) resU(i,j,k)=resU(i,j,k)+this%rho*this%gravity(1) + if (this%vmask(i,j,k).eq.0) resV(i,j,k)=resV(i,j,k)+this%rho*this%gravity(2) + if (this%wmask(i,j,k).eq.0) resW(i,j,k)=resW(i,j,k)+this%rho*this%gravity(3) + end do + end do + end do + end subroutine addsrc_gravity + + + !> Print out info for incompressible flow solver + subroutine incomp_print(this) + use, intrinsic :: iso_fortran_env, only: output_unit + implicit none + class(incomp), intent(in) :: this + + ! Output + if (this%cfg%amRoot) then + write(output_unit,'("Incompressible solver [",a,"] for config [",a,"]")') trim(this%name),trim(this%cfg%name) + write(output_unit,'(" > density = ",es12.5)') this%rho + end if + + end subroutine incomp_print + + +end module incomp_class diff --git a/examples/NOSB_plate_with_hole_peridigm/src/incomp_class_old.f90 b/examples/NOSB_plate_with_hole_peridigm/src/incomp_class_old.f90 new file mode 100644 index 000000000..c8e6f79b7 --- /dev/null +++ b/examples/NOSB_plate_with_hole_peridigm/src/incomp_class_old.f90 @@ -0,0 +1,2128 @@ +!> Incompressible flow solver class: +!> Provides support for various BC, RHS calculation, +!> implicit solver, and pressure solution +!> Assumes constant viscosity and density. +module incomp_class + use precision, only: WP + use string, only: str_medium + use config_class, only: config + use linsol_class, only: linsol + use iterator_class, only: iterator + implicit none + private + + ! Expose type/constructor/methods + public :: incomp,bcond + + ! List of known available bcond types for this solver + integer, parameter, public :: wall=1 !< Dirichlet at zero condition + integer, parameter, public :: dirichlet=2 !< Dirichlet condition + integer, parameter, public :: neumann=3 !< Zero normal gradient + integer, parameter, public :: convective=4 !< Convective outflow condition + integer, parameter, public :: clipped_neumann=5 !< Clipped Neumann condition (outflow only) + integer, parameter, public :: slip=6 !< Free-slip condition + + !> Boundary conditions for the incompressible solver + type :: bcond + type(bcond), pointer :: next !< Linked list of bconds + character(len=str_medium) :: name='UNNAMED_BCOND' !< Bcond name (default=UNNAMED_BCOND) + integer :: type !< Bcond type + type(iterator) :: itr !< This is the iterator for the bcond - this identifies the (i,j,k) + character(len=1) :: face !< Bcond face (x/y/z) + integer :: dir !< Bcond direction (+1,-1,0 for interior) + real(WP) :: rdir !< Bcond direction (real variable) + logical :: canCorrect !< Can this bcond be corrected for global conservation? + end type bcond + + !> Incompressible solver object definition + type :: incomp + + ! This is our config + class(config), pointer :: cfg !< This is the config the solver is build for + + ! This is the name of the solver + character(len=str_medium) :: name='UNNAMED_INCOMP' !< Solver name (default=UNNAMED_INCOMP) + + ! Constant property fluid + real(WP) :: rho !< This is our constant fluid density + real(WP), dimension(:,:,:), allocatable :: visc !< These is our constant+SGS dynamic viscosity + + ! Gravitational acceleration + real(WP), dimension(3) :: gravity=0.0_WP !< Acceleration of gravity + + ! Boundary condition list + integer :: nbc !< Number of bcond for our solver + real(WP), dimension(:), allocatable :: mfr !< MFR through each bcond + real(WP), dimension(:), allocatable :: area !< Area for each bcond + real(WP) :: correctable_area !< Area of bcond that can be corrected + type(bcond), pointer :: first_bc !< List of bcond for our solver + + ! Flow variables + real(WP), dimension(:,:,:), allocatable :: U !< U velocity array + real(WP), dimension(:,:,:), allocatable :: V !< V velocity array + real(WP), dimension(:,:,:), allocatable :: W !< W velocity array + real(WP), dimension(:,:,:), allocatable :: P !< Pressure array + + ! Old flow variables + real(WP), dimension(:,:,:), allocatable :: Uold !< Uold velocity array + real(WP), dimension(:,:,:), allocatable :: Vold !< Vold velocity array + real(WP), dimension(:,:,:), allocatable :: Wold !< Wold velocity array + + ! Flow divergence + real(WP), dimension(:,:,:), allocatable :: div !< Divergence array + + ! Pressure solver + class(linsol), pointer :: psolv !< Iterative linear solver object for the pressure Poisson equation + + ! Implicit velocity solver + class(linsol), pointer :: implicit !< Iterative linear solver object for an implicit prediction of the NS residual + + ! Metrics + real(WP), dimension(:,:,:,:,:), allocatable :: itp_xy,itp_yz,itp_xz !< Interpolation for viscosity + real(WP), dimension(:,:,:,:), allocatable :: itpr_x,itpr_y,itpr_z !< Interpolation for density + real(WP), dimension(:,:,:,:), allocatable :: itpu_x,itpu_y,itpu_z !< Interpolation for U + real(WP), dimension(:,:,:,:), allocatable :: itpv_x,itpv_y,itpv_z !< Interpolation for V + real(WP), dimension(:,:,:,:), allocatable :: itpw_x,itpw_y,itpw_z !< Interpolation for W + real(WP), dimension(:,:,:,:), allocatable :: divp_x,divp_y,divp_z !< Divergence for P-cell + real(WP), dimension(:,:,:,:), allocatable :: divu_x,divu_y,divu_z !< Divergence for U-cell + real(WP), dimension(:,:,:,:), allocatable :: divv_x,divv_y,divv_z !< Divergence for V-cell + real(WP), dimension(:,:,:,:), allocatable :: divw_x,divw_y,divw_z !< Divergence for W-cell + real(WP), dimension(:,:,:,:), allocatable :: grdu_x,grdu_y,grdu_z !< Velocity gradient for U + real(WP), dimension(:,:,:,:), allocatable :: grdv_x,grdv_y,grdv_z !< Velocity gradient for V + real(WP), dimension(:,:,:,:), allocatable :: grdw_x,grdw_y,grdw_z !< Velocity gradient for W + + ! Masking info for metric modification + integer, dimension(:,:,:), allocatable :: mask !< Integer array used for modifying P metrics + integer, dimension(:,:,:), allocatable :: umask !< Integer array used for modifying U metrics + integer, dimension(:,:,:), allocatable :: vmask !< Integer array used for modifying V metrics + integer, dimension(:,:,:), allocatable :: wmask !< Integer array used for modifying W metrics + + ! CFL numbers + real(WP) :: CFLc_x,CFLc_y,CFLc_z !< Convective CFL numbers + real(WP) :: CFLv_x,CFLv_y,CFLv_z !< Viscous CFL numbers + + ! Monitoring quantities + real(WP) :: Umax,Vmax,Wmax,Pmax,divmax !< Maximum velocity, pressure, divergence + + contains + procedure :: print=>incomp_print !< Output solver to the screen + procedure :: setup !< Finish configuring the flow solver + procedure :: add_bcond !< Add a boundary condition + procedure :: get_bcond !< Get a boundary condition + procedure :: apply_bcond !< Apply all boundary conditions + procedure :: init_metrics !< Initialize metrics + procedure :: adjust_metrics !< Adjust metrics + procedure :: get_dmomdt !< Calculate dmom/dt + procedure :: get_div !< Calculate velocity divergence + procedure :: get_div_stress !< Calculate divergence of stresses for LPT solver + procedure :: get_pgrad !< Calculate pressure gradient + procedure :: get_cfl !< Calculate maximum CFL + procedure :: get_max !< Calculate maximum field values + procedure :: interp_vel !< Calculate interpolated velocity + procedure :: get_strainrate !< Calculate deviatoric part of strain rate tensor + procedure :: get_gradu !< Calculate velocity gradient tensor + procedure :: get_vorticity !< Calculate vorticity tensor + procedure :: get_mfr !< Calculate outgoing MFR through each bcond + procedure :: correct_mfr !< Correct for mfr mismatch to ensure global conservation + procedure :: shift_p !< Shift pressure to have zero average + procedure :: solve_implicit !< Solve for the velocity residuals implicitly + procedure :: addsrc_gravity !< Gravitational body force + end type incomp + + + !> Declare incompressible solver constructor + interface incomp + procedure constructor + end interface incomp + +contains + + + !> Default constructor for incompressible flow solver + function constructor(cfg,name) result(self) + implicit none + type(incomp) :: self + class(config), target, intent(in) :: cfg + character(len=*), optional :: name + integer :: i,j,k + + ! Set the name for the solver + if (present(name)) self%name=trim(adjustl(name)) + + ! Point to pgrid object + self%cfg=>cfg + + ! Nullify bcond list + self%nbc=0 + self%first_bc=>NULL() + + ! Allocate flow variables + allocate(self%U(self%cfg%imino_:self%cfg%imaxo_,self%cfg%jmino_:self%cfg%jmaxo_,self%cfg%kmino_:self%cfg%kmaxo_)); self%U=0.0_WP + allocate(self%V(self%cfg%imino_:self%cfg%imaxo_,self%cfg%jmino_:self%cfg%jmaxo_,self%cfg%kmino_:self%cfg%kmaxo_)); self%V=0.0_WP + allocate(self%W(self%cfg%imino_:self%cfg%imaxo_,self%cfg%jmino_:self%cfg%jmaxo_,self%cfg%kmino_:self%cfg%kmaxo_)); self%W=0.0_WP + allocate(self%P(self%cfg%imino_:self%cfg%imaxo_,self%cfg%jmino_:self%cfg%jmaxo_,self%cfg%kmino_:self%cfg%kmaxo_)); self%P=0.0_WP + + ! Allocate flow divergence + allocate(self%div(self%cfg%imino_:self%cfg%imaxo_,self%cfg%jmino_:self%cfg%jmaxo_,self%cfg%kmino_:self%cfg%kmaxo_)); self%div=0.0_WP + + ! Allocate fluid viscosity + allocate(self%visc(self%cfg%imino_:self%cfg%imaxo_,self%cfg%jmino_:self%cfg%jmaxo_,self%cfg%kmino_:self%cfg%kmaxo_)); self%visc=0.0_WP + + ! Allocate old flow variables + allocate(self%Uold(self%cfg%imino_:self%cfg%imaxo_,self%cfg%jmino_:self%cfg%jmaxo_,self%cfg%kmino_:self%cfg%kmaxo_)); self%Uold=0.0_WP + allocate(self%Vold(self%cfg%imino_:self%cfg%imaxo_,self%cfg%jmino_:self%cfg%jmaxo_,self%cfg%kmino_:self%cfg%kmaxo_)); self%Vold=0.0_WP + allocate(self%Wold(self%cfg%imino_:self%cfg%imaxo_,self%cfg%jmino_:self%cfg%jmaxo_,self%cfg%kmino_:self%cfg%kmaxo_)); self%Wold=0.0_WP + + ! Prepare default metrics + call self%init_metrics() + + ! Prepare P-cell masks + allocate(self%mask(self%cfg%imino_:self%cfg%imaxo_,self%cfg%jmino_:self%cfg%jmaxo_,self%cfg%kmino_:self%cfg%kmaxo_)); self%mask=0 + if (.not.self%cfg%xper) then + if (self%cfg%iproc.eq. 1) self%mask(:self%cfg%imin-1,:,:)=2 + if (self%cfg%iproc.eq.self%cfg%npx) self%mask(self%cfg%imax+1:,:,:)=2 + end if + if (.not.self%cfg%yper) then + if (self%cfg%jproc.eq. 1) self%mask(:,:self%cfg%jmin-1,:)=2 + if (self%cfg%jproc.eq.self%cfg%npy) self%mask(:,self%cfg%jmax+1:,:)=2 + end if + if (.not.self%cfg%zper) then + if (self%cfg%kproc.eq. 1) self%mask(:,:,:self%cfg%kmin-1)=2 + if (self%cfg%kproc.eq.self%cfg%npz) self%mask(:,:,self%cfg%kmax+1:)=2 + end if + do k=self%cfg%kmino_,self%cfg%kmaxo_ + do j=self%cfg%jmino_,self%cfg%jmaxo_ + do i=self%cfg%imino_,self%cfg%imaxo_ + if (self%cfg%VF(i,j,k).eq.0.0_WP) self%mask(i,j,k)=1 + end do + end do + end do + call self%cfg%sync(self%mask) + + ! Prepare face mask for U + allocate(self%umask(self%cfg%imino_:self%cfg%imaxo_,self%cfg%jmino_:self%cfg%jmaxo_,self%cfg%kmino_:self%cfg%kmaxo_)); self%umask=0 + if (.not.self%cfg%xper) then + if (self%cfg%iproc.eq. 1) self%umask(self%cfg%imin ,:,:)=2 + if (self%cfg%iproc.eq.self%cfg%npx) self%umask(self%cfg%imax+1,:,:)=2 + end if + do k=self%cfg%kmino_ ,self%cfg%kmaxo_ + do j=self%cfg%jmino_ ,self%cfg%jmaxo_ + do i=self%cfg%imino_+1,self%cfg%imaxo_ + if (minval(self%cfg%VF(i-1:i,j,k)).eq.0.0_WP) self%umask(i,j,k)=1 + end do + end do + end do + call self%cfg%sync(self%umask) + if (.not.self%cfg%xper.and.self%cfg%iproc.eq.1) self%umask(self%cfg%imino,:,:)=self%umask(self%cfg%imino+1,:,:) + + ! Prepare face mask for V + allocate(self%vmask(self%cfg%imino_:self%cfg%imaxo_,self%cfg%jmino_:self%cfg%jmaxo_,self%cfg%kmino_:self%cfg%kmaxo_)); self%vmask=0 + if (.not.self%cfg%yper) then + if (self%cfg%jproc.eq. 1) self%vmask(:,self%cfg%jmin ,:)=2 + if (self%cfg%jproc.eq.self%cfg%npy) self%vmask(:,self%cfg%jmax+1,:)=2 + end if + do k=self%cfg%kmino_ ,self%cfg%kmaxo_ + do j=self%cfg%jmino_+1,self%cfg%jmaxo_ + do i=self%cfg%imino_ ,self%cfg%imaxo_ + if (minval(self%cfg%VF(i,j-1:j,k)).eq.0.0_WP) self%vmask(i,j,k)=1 + end do + end do + end do + call self%cfg%sync(self%vmask) + if (.not.self%cfg%yper.and.self%cfg%jproc.eq.1) self%vmask(:,self%cfg%jmino,:)=self%vmask(:,self%cfg%jmino+1,:) + + ! Prepare face mask for W + allocate(self%wmask(self%cfg%imino_:self%cfg%imaxo_,self%cfg%jmino_:self%cfg%jmaxo_,self%cfg%kmino_:self%cfg%kmaxo_)); self%wmask=0 + if (.not.self%cfg%zper) then + if (self%cfg%kproc.eq. 1) self%wmask(:,:,self%cfg%kmin )=2 + if (self%cfg%kproc.eq.self%cfg%npz) self%wmask(:,:,self%cfg%kmax+1)=2 + end if + do k=self%cfg%kmino_+1,self%cfg%kmaxo_ + do j=self%cfg%jmino_ ,self%cfg%jmaxo_ + do i=self%cfg%imino_ ,self%cfg%imaxo_ + if (minval(self%cfg%VF(i,j,k-1:k)).eq.0.0_WP) self%wmask(i,j,k)=1 + end do + end do + end do + call self%cfg%sync(self%wmask) + if (.not.self%cfg%zper.and.self%cfg%kproc.eq.1) self%wmask(:,:,self%cfg%kmino)=self%wmask(:,:,self%cfg%kmino+1) + + end function constructor + + + !> Metric initialization with no awareness of walls nor bcond + subroutine init_metrics(this) + implicit none + class(incomp), intent(inout) :: this + integer :: i,j,k,st1,st2 + real(WP), dimension(-1:0) :: itpx,itpy,itpz + + ! Allocate finite difference density (or other things) interpolation coefficients + allocate(this%itpr_x(-1:0,this%cfg%imin_:this%cfg%imax_+1,this%cfg%jmin_:this%cfg%jmax_+1,this%cfg%kmin_:this%cfg%kmax_+1)) !< X-face-centered + allocate(this%itpr_y(-1:0,this%cfg%imin_:this%cfg%imax_+1,this%cfg%jmin_:this%cfg%jmax_+1,this%cfg%kmin_:this%cfg%kmax_+1)) !< Y-face-centered + allocate(this%itpr_z(-1:0,this%cfg%imin_:this%cfg%imax_+1,this%cfg%jmin_:this%cfg%jmax_+1,this%cfg%kmin_:this%cfg%kmax_+1)) !< Z-face-centered + ! Create density (or other things) interpolation coefficients to cell face + do k=this%cfg%kmin_,this%cfg%kmax_+1 + do j=this%cfg%jmin_,this%cfg%jmax_+1 + do i=this%cfg%imin_,this%cfg%imax_+1 + this%itpr_x(:,i,j,k)=this%cfg%dxmi(i)*[this%cfg%xm(i)-this%cfg%x(i),this%cfg%x(i)-this%cfg%xm(i-1)] !< Linear interpolation in x from [xm,ym,zm] to [x,ym,zm] + this%itpr_y(:,i,j,k)=this%cfg%dymi(j)*[this%cfg%ym(j)-this%cfg%y(j),this%cfg%y(j)-this%cfg%ym(j-1)] !< Linear interpolation in y from [xm,ym,zm] to [xm,y,zm] + this%itpr_z(:,i,j,k)=this%cfg%dzmi(k)*[this%cfg%zm(k)-this%cfg%z(k),this%cfg%z(k)-this%cfg%zm(k-1)] !< Linear interpolation in z from [xm,ym,zm] to [xm,ym,z] + end do + end do + end do + + ! Allocate finite difference viscosity interpolation coefficients + allocate(this%itp_xy(-1:0,-1:0,this%cfg%imino_+1:this%cfg%imaxo_,this%cfg%jmino_+1:this%cfg%jmaxo_,this%cfg%kmino_+1:this%cfg%kmaxo_)) !< Edge-centered (xy) + allocate(this%itp_yz(-1:0,-1:0,this%cfg%imino_+1:this%cfg%imaxo_,this%cfg%jmino_+1:this%cfg%jmaxo_,this%cfg%kmino_+1:this%cfg%kmaxo_)) !< Edge-centered (yz) + allocate(this%itp_xz(-1:0,-1:0,this%cfg%imino_+1:this%cfg%imaxo_,this%cfg%jmino_+1:this%cfg%jmaxo_,this%cfg%kmino_+1:this%cfg%kmaxo_)) !< Edge-centered (zx) + ! Create viscosity interpolation coefficients to cell edge + do k=this%cfg%kmino_+1,this%cfg%kmaxo_ + do j=this%cfg%jmino_+1,this%cfg%jmaxo_ + do i=this%cfg%imino_+1,this%cfg%imaxo_ + ! Prepare local 1D metrics + itpx=this%cfg%dxmi(i)*[this%cfg%xm(i)-this%cfg%x(i),this%cfg%x(i)-this%cfg%xm(i-1)] + itpy=this%cfg%dymi(j)*[this%cfg%ym(j)-this%cfg%y(j),this%cfg%y(j)-this%cfg%ym(j-1)] + itpz=this%cfg%dzmi(k)*[this%cfg%zm(k)-this%cfg%z(k),this%cfg%z(k)-this%cfg%zm(k-1)] + ! Combine for 2D interpolations + do st1=-1,0 + do st2=-1,0 + this%itp_xy(st1,st2,i,j,k)=itpx(st1)*itpy(st2) + this%itp_yz(st1,st2,i,j,k)=itpy(st1)*itpz(st2) + this%itp_xz(st1,st2,i,j,k)=itpx(st1)*itpz(st2) + end do + end do + end do + end do + end do + + ! Allocate finite difference velocity interpolation coefficients + allocate(this%itpu_x( 0:+1,this%cfg%imino_ :this%cfg%imaxo_,this%cfg%jmino_ :this%cfg%jmaxo_,this%cfg%kmino_ :this%cfg%kmaxo_)) !< Cell-centered + allocate(this%itpv_y( 0:+1,this%cfg%imino_ :this%cfg%imaxo_,this%cfg%jmino_ :this%cfg%jmaxo_,this%cfg%kmino_ :this%cfg%kmaxo_)) !< Cell-centered + allocate(this%itpw_z( 0:+1,this%cfg%imino_ :this%cfg%imaxo_,this%cfg%jmino_ :this%cfg%jmaxo_,this%cfg%kmino_ :this%cfg%kmaxo_)) !< Cell-centered + allocate(this%itpv_x(-1: 0,this%cfg%imino_+1:this%cfg%imaxo_,this%cfg%jmino_ :this%cfg%jmaxo_,this%cfg%kmino_ :this%cfg%kmaxo_)) !< Edge-centered (xy) + allocate(this%itpw_x(-1: 0,this%cfg%imino_+1:this%cfg%imaxo_,this%cfg%jmino_ :this%cfg%jmaxo_,this%cfg%kmino_ :this%cfg%kmaxo_)) !< Edge-centered (zx) + allocate(this%itpu_y(-1: 0,this%cfg%imino_ :this%cfg%imaxo_,this%cfg%jmino_+1:this%cfg%jmaxo_,this%cfg%kmino_ :this%cfg%kmaxo_)) !< Edge-centered (xy) + allocate(this%itpw_y(-1: 0,this%cfg%imino_ :this%cfg%imaxo_,this%cfg%jmino_+1:this%cfg%jmaxo_,this%cfg%kmino_ :this%cfg%kmaxo_)) !< Edge-centered (yz) + allocate(this%itpu_z(-1: 0,this%cfg%imino_ :this%cfg%imaxo_,this%cfg%jmino_ :this%cfg%jmaxo_,this%cfg%kmino_+1:this%cfg%kmaxo_)) !< Edge-centered (zx) + allocate(this%itpv_z(-1: 0,this%cfg%imino_ :this%cfg%imaxo_,this%cfg%jmino_ :this%cfg%jmaxo_,this%cfg%kmino_+1:this%cfg%kmaxo_)) !< Edge-centered (yz) + ! Create velocity interpolation coefficients to cell center [xm,ym,zm] + do k=this%cfg%kmino_,this%cfg%kmaxo_ + do j=this%cfg%jmino_,this%cfg%jmaxo_ + do i=this%cfg%imino_,this%cfg%imaxo_ + this%itpu_x(:,i,j,k)=[+0.5_WP,+0.5_WP] !< Linear interpolation in x of U from [x ,ym,zm] + this%itpv_y(:,i,j,k)=[+0.5_WP,+0.5_WP] !< Linear interpolation in y of V from [xm,y ,zm] + this%itpw_z(:,i,j,k)=[+0.5_WP,+0.5_WP] !< Linear interpolation in z of W from [xm,ym,z ] + end do + end do + end do + ! Create velocity interpolation coefficients to cell edge in x + do k=this%cfg%kmino_ ,this%cfg%kmaxo_ + do j=this%cfg%jmino_ ,this%cfg%jmaxo_ + do i=this%cfg%imino_+1,this%cfg%imaxo_ + this%itpv_x(:,i,j,k)=this%cfg%dxmi(i)*[this%cfg%xm(i)-this%cfg%x(i),this%cfg%x(i)-this%cfg%xm(i-1)] !< Linear interpolation in x of V from [xm,y ,zm] + this%itpw_x(:,i,j,k)=this%cfg%dxmi(i)*[this%cfg%xm(i)-this%cfg%x(i),this%cfg%x(i)-this%cfg%xm(i-1)] !< Linear interpolation in x of W from [xm,ym,z ] + end do + end do + end do + ! Create velocity interpolation coefficients to cell edge in y + do k=this%cfg%kmino_ ,this%cfg%kmaxo_ + do j=this%cfg%jmino_+1,this%cfg%jmaxo_ + do i=this%cfg%imino_ ,this%cfg%imaxo_ + this%itpu_y(:,i,j,k)=this%cfg%dymi(j)*[this%cfg%ym(j)-this%cfg%y(j),this%cfg%y(j)-this%cfg%ym(j-1)] !< Linear interpolation in y of U from [x ,ym,zm] + this%itpw_y(:,i,j,k)=this%cfg%dymi(j)*[this%cfg%ym(j)-this%cfg%y(j),this%cfg%y(j)-this%cfg%ym(j-1)] !< Linear interpolation in y of W from [xm,ym,z ] + end do + end do + end do + ! Create velocity interpolation coefficients to cell edge in z + do k=this%cfg%kmino_+1,this%cfg%kmaxo_ + do j=this%cfg%jmino_ ,this%cfg%jmaxo_ + do i=this%cfg%imino_ ,this%cfg%imaxo_ + this%itpu_z(:,i,j,k)=this%cfg%dzmi(k)*[this%cfg%zm(k)-this%cfg%z(k),this%cfg%z(k)-this%cfg%zm(k-1)] !< Linear interpolation in z of U from [x ,ym,zm] + this%itpv_z(:,i,j,k)=this%cfg%dzmi(k)*[this%cfg%zm(k)-this%cfg%z(k),this%cfg%z(k)-this%cfg%zm(k-1)] !< Linear interpolation in z of V from [xm,y ,zm] + end do + end do + end do + + ! Allocate finite volume divergence operators + allocate(this%divp_x( 0:+1,this%cfg%imino_ :this%cfg%imaxo_,this%cfg%jmino_ :this%cfg%jmaxo_,this%cfg%kmino_ :this%cfg%kmaxo_)) !< Cell-centered + allocate(this%divp_y( 0:+1,this%cfg%imino_ :this%cfg%imaxo_,this%cfg%jmino_ :this%cfg%jmaxo_,this%cfg%kmino_ :this%cfg%kmaxo_)) !< Cell-centered + allocate(this%divp_z( 0:+1,this%cfg%imino_ :this%cfg%imaxo_,this%cfg%jmino_ :this%cfg%jmaxo_,this%cfg%kmino_ :this%cfg%kmaxo_)) !< Cell-centered + allocate(this%divu_x(-1: 0,this%cfg%imino_+1:this%cfg%imaxo_,this%cfg%jmino_ :this%cfg%jmaxo_,this%cfg%kmino_ :this%cfg%kmaxo_)) !< Face-centered (x) + allocate(this%divu_y( 0:+1,this%cfg%imino_ :this%cfg%imaxo_,this%cfg%jmino_ :this%cfg%jmaxo_,this%cfg%kmino_ :this%cfg%kmaxo_)) !< Face-centered (x) + allocate(this%divu_z( 0:+1,this%cfg%imino_ :this%cfg%imaxo_,this%cfg%jmino_ :this%cfg%jmaxo_,this%cfg%kmino_ :this%cfg%kmaxo_)) !< Face-centered (x) + allocate(this%divv_x( 0:+1,this%cfg%imino_ :this%cfg%imaxo_,this%cfg%jmino_ :this%cfg%jmaxo_,this%cfg%kmino_ :this%cfg%kmaxo_)) !< Face-centered (y) + allocate(this%divv_y(-1: 0,this%cfg%imino_ :this%cfg%imaxo_,this%cfg%jmino_+1:this%cfg%jmaxo_,this%cfg%kmino_ :this%cfg%kmaxo_)) !< Face-centered (y) + allocate(this%divv_z( 0:+1,this%cfg%imino_ :this%cfg%imaxo_,this%cfg%jmino_ :this%cfg%jmaxo_,this%cfg%kmino_ :this%cfg%kmaxo_)) !< Face-centered (y) + allocate(this%divw_x( 0:+1,this%cfg%imino_ :this%cfg%imaxo_,this%cfg%jmino_ :this%cfg%jmaxo_,this%cfg%kmino_ :this%cfg%kmaxo_)) !< Face-centered (z) + allocate(this%divw_y( 0:+1,this%cfg%imino_ :this%cfg%imaxo_,this%cfg%jmino_ :this%cfg%jmaxo_,this%cfg%kmino_ :this%cfg%kmaxo_)) !< Face-centered (z) + allocate(this%divw_z(-1: 0,this%cfg%imino_ :this%cfg%imaxo_,this%cfg%jmino_ :this%cfg%jmaxo_,this%cfg%kmino_+1:this%cfg%kmaxo_)) !< Face-centered (z) + ! Create divergence operator to cell center [xm,ym,zm] or tangent to cell face + do k=this%cfg%kmino_,this%cfg%kmaxo_ + do j=this%cfg%jmino_,this%cfg%jmaxo_ + do i=this%cfg%imino_,this%cfg%imaxo_ + this%divp_x(:,i,j,k)=this%cfg%dxi(i)*[-1.0_WP,+1.0_WP] !< FV divergence from [x ,ym,zm] + this%divp_y(:,i,j,k)=this%cfg%dyi(j)*[-1.0_WP,+1.0_WP] !< FV divergence from [xm,y ,zm] + this%divp_z(:,i,j,k)=this%cfg%dzi(k)*[-1.0_WP,+1.0_WP] !< FV divergence from [xm,ym,z ] + + this%divu_y(:,i,j,k)=this%cfg%dyi(j)*[-1.0_WP,+1.0_WP] !< FV divergence from [x ,y ,zm] + this%divu_z(:,i,j,k)=this%cfg%dzi(k)*[-1.0_WP,+1.0_WP] !< FV divergence from [x ,ym,z ] + + this%divv_x(:,i,j,k)=this%cfg%dxi(i)*[-1.0_WP,+1.0_WP] !< FV divergence from [x ,y ,zm] + this%divv_z(:,i,j,k)=this%cfg%dzi(k)*[-1.0_WP,+1.0_WP] !< FV divergence from [xm,y ,z ] + + this%divw_x(:,i,j,k)=this%cfg%dxi(i)*[-1.0_WP,+1.0_WP] !< FV divergence from [x ,ym,z ] + this%divw_y(:,i,j,k)=this%cfg%dyi(j)*[-1.0_WP,+1.0_WP] !< FV divergence from [xm,y ,z ] + end do + end do + end do + ! Create divergence operator perpendicular to cell face [x ,ym,zm] + do k=this%cfg%kmino_ ,this%cfg%kmaxo_ + do j=this%cfg%jmino_ ,this%cfg%jmaxo_ + do i=this%cfg%imino_+1,this%cfg%imaxo_ + this%divu_x(:,i,j,k)=this%cfg%dxmi(i)*[-1.0_WP,+1.0_WP] !< FV divergence from [xm,ym,zm] + end do + end do + end do + ! Create divergence operator perpendicular to cell face [xm,y ,zm] + do k=this%cfg%kmino_ ,this%cfg%kmaxo_ + do j=this%cfg%jmino_+1,this%cfg%jmaxo_ + do i=this%cfg%imino_ ,this%cfg%imaxo_ + this%divv_y(:,i,j,k)=this%cfg%dymi(j)*[-1.0_WP,+1.0_WP] !< FV divergence from [xm,ym,zm] + end do + end do + end do + ! Create divergence operator perpendicular to cell face [xm,ym,z ] + do k=this%cfg%kmino_+1,this%cfg%kmaxo_ + do j=this%cfg%jmino_ ,this%cfg%jmaxo_ + do i=this%cfg%imino_ ,this%cfg%imaxo_ + this%divw_z(:,i,j,k)=this%cfg%dzmi(k)*[-1.0_WP,+1.0_WP] !< FV divergence from [xm,ym,zm] + end do + end do + end do + + ! Allocate finite difference velocity gradient operators + allocate(this%grdu_x( 0:+1,this%cfg%imino_ :this%cfg%imaxo_,this%cfg%jmino_ :this%cfg%jmaxo_,this%cfg%kmino_ :this%cfg%kmaxo_)) !< Cell-centered + allocate(this%grdv_y( 0:+1,this%cfg%imino_ :this%cfg%imaxo_,this%cfg%jmino_ :this%cfg%jmaxo_,this%cfg%kmino_ :this%cfg%kmaxo_)) !< Cell-centered + allocate(this%grdw_z( 0:+1,this%cfg%imino_ :this%cfg%imaxo_,this%cfg%jmino_ :this%cfg%jmaxo_,this%cfg%kmino_ :this%cfg%kmaxo_)) !< Cell-centered + allocate(this%grdv_x(-1: 0,this%cfg%imino_+1:this%cfg%imaxo_,this%cfg%jmino_ :this%cfg%jmaxo_,this%cfg%kmino_ :this%cfg%kmaxo_)) !< Edge-centered (xy) + allocate(this%grdw_x(-1: 0,this%cfg%imino_+1:this%cfg%imaxo_,this%cfg%jmino_ :this%cfg%jmaxo_,this%cfg%kmino_ :this%cfg%kmaxo_)) !< Edge-centered (zx) + allocate(this%grdu_y(-1: 0,this%cfg%imino_ :this%cfg%imaxo_,this%cfg%jmino_+1:this%cfg%jmaxo_,this%cfg%kmino_ :this%cfg%kmaxo_)) !< Edge-centered (xy) + allocate(this%grdw_y(-1: 0,this%cfg%imino_ :this%cfg%imaxo_,this%cfg%jmino_+1:this%cfg%jmaxo_,this%cfg%kmino_ :this%cfg%kmaxo_)) !< Edge-centered (yz) + allocate(this%grdu_z(-1: 0,this%cfg%imino_ :this%cfg%imaxo_,this%cfg%jmino_ :this%cfg%jmaxo_,this%cfg%kmino_+1:this%cfg%kmaxo_)) !< Edge-centered (zx) + allocate(this%grdv_z(-1: 0,this%cfg%imino_ :this%cfg%imaxo_,this%cfg%jmino_ :this%cfg%jmaxo_,this%cfg%kmino_+1:this%cfg%kmaxo_)) !< Edge-centered (yz) + ! Create gradient coefficients to cell center [xm,ym,zm] + do k=this%cfg%kmino_,this%cfg%kmaxo_ + do j=this%cfg%jmino_,this%cfg%jmaxo_ + do i=this%cfg%imino_,this%cfg%imaxo_ + this%grdu_x(:,i,j,k)=this%cfg%dxi(i)*[-1.0_WP,+1.0_WP] !< FD gradient in x of U from [x ,ym,zm] + this%grdv_y(:,i,j,k)=this%cfg%dyi(j)*[-1.0_WP,+1.0_WP] !< FD gradient in y of V from [xm,y ,zm] + this%grdw_z(:,i,j,k)=this%cfg%dzi(k)*[-1.0_WP,+1.0_WP] !< FD gradient in z of W from [xm,ym,z ] + end do + end do + end do + ! Create gradient coefficients to cell edge in x + do k=this%cfg%kmino_ ,this%cfg%kmaxo_ + do j=this%cfg%jmino_ ,this%cfg%jmaxo_ + do i=this%cfg%imino_+1,this%cfg%imaxo_ + this%grdv_x(:,i,j,k)=this%cfg%dxmi(i)*[-1.0_WP,+1.0_WP] !< FD gradient in x of V from [xm,y ,zm] + this%grdw_x(:,i,j,k)=this%cfg%dxmi(i)*[-1.0_WP,+1.0_WP] !< FD gradient in x of W from [xm,ym,z ] + end do + end do + end do + ! Create gradient coefficients to cell edge in y + do k=this%cfg%kmino_ ,this%cfg%kmaxo_ + do j=this%cfg%jmino_+1,this%cfg%jmaxo_ + do i=this%cfg%imino_ ,this%cfg%imaxo_ + this%grdu_y(:,i,j,k)=this%cfg%dymi(j)*[-1.0_WP,+1.0_WP] !< FD gradient in y of U from [x ,ym,zm] + this%grdw_y(:,i,j,k)=this%cfg%dymi(j)*[-1.0_WP,+1.0_WP] !< FD gradient in y of W from [xm,ym,z ] + end do + end do + end do + ! Create gradient coefficients to cell edge in z + do k=this%cfg%kmino_+1,this%cfg%kmaxo_ + do j=this%cfg%jmino_ ,this%cfg%jmaxo_ + do i=this%cfg%imino_ ,this%cfg%imaxo_ + this%grdu_z(:,i,j,k)=this%cfg%dzmi(k)*[-1.0_WP,+1.0_WP] !< FD gradient in z of U from [x ,ym,zm] + this%grdv_z(:,i,j,k)=this%cfg%dzmi(k)*[-1.0_WP,+1.0_WP] !< FD gradient in z of V from [xm,y ,zm] + end do + end do + end do + + end subroutine init_metrics + + + !> Metric adjustment accounting for bconds and walls + subroutine adjust_metrics(this) + implicit none + class(incomp), intent(inout) :: this + integer :: i,j,k,st1,st2 + real(WP) :: delta,mysum + + ! Sync up u/v/wmasks + call this%cfg%sync(this%umask) + call this%cfg%sync(this%vmask) + call this%cfg%sync(this%wmask) + if (.not.this%cfg%xper.and.this%cfg%iproc.eq.1) this%umask(this%cfg%imino,:,:)=this%umask(this%cfg%imino+1,:,:) + if (.not.this%cfg%yper.and.this%cfg%jproc.eq.1) this%vmask(:,this%cfg%jmino,:)=this%vmask(:,this%cfg%jmino+1,:) + if (.not.this%cfg%zper.and.this%cfg%kproc.eq.1) this%wmask(:,:,this%cfg%kmino)=this%wmask(:,:,this%cfg%kmino+1) + + ! I am assuming here that we do not really need to zero out wall cells + ! as they could be used for Dirichlet (then the density needs to be available! could be problematic if we do not have an explicit BC for scalars, e.g. for a Couette flow) + ! or outflow condition (then the density needs to be available but it should be directly calculated) + ! or used for a real no-slip wall (then density is always multiplied by zero) + ! Adjust density interpolation coefficients to cell faces in the presence of walls (only walls!) + !do k=this%cfg%kmin_,this%cfg%kmax_+1 + ! do j=this%cfg%jmin_,this%cfg%jmax_+1 + ! do i=this%cfg%imin_,this%cfg%imax_+1 + ! ! Linear interpolation in x + ! if (this%cfg%VF(i,j,k).eq.0.0_WP.and.this%cfg%VF(i-1,j,k).gt.0.0_WP) this%itpr_x(:,i,j,k)=[1.0_WP,0.0_WP] + ! if (this%cfg%VF(i,j,k).gt.0.0_WP.and.this%cfg%VF(i-1,j,k).eq.0.0_WP) this%itpr_x(:,i,j,k)=[0.0_WP,1.0_WP] + ! ! Linear interpolation in y + ! if (this%cfg%VF(i,j,k).eq.0.0_WP.and.this%cfg%VF(i,j-1,k).gt.0.0_WP) this%itpr_y(:,i,j,k)=[1.0_WP,0.0_WP] + ! if (this%cfg%VF(i,j,k).gt.0.0_WP.and.this%cfg%VF(i,j-1,k).eq.0.0_WP) this%itpr_y(:,i,j,k)=[0.0_WP,1.0_WP] + ! ! Linear interpolation in z + ! if (this%cfg%VF(i,j,k).eq.0.0_WP.and.this%cfg%VF(i,j,k-1).gt.0.0_WP) this%itpr_z(:,i,j,k)=[1.0_WP,0.0_WP] + ! if (this%cfg%VF(i,j,k).gt.0.0_WP.and.this%cfg%VF(i,j,k-1).eq.0.0_WP) this%itpr_z(:,i,j,k)=[0.0_WP,1.0_WP] + ! end do + ! end do + !end do + + ! Adjust interpolation coefficients to cell centers in the presence of walls (only walls!) + do k=this%cfg%kmino_,this%cfg%kmaxo_ + do j=this%cfg%jmino_,this%cfg%jmaxo_ + do i=this%cfg%imino_,this%cfg%imaxo_ + if (this%mask(i,j,k).eq.1) this%itpu_x(:,i,j,k)=0.0_WP + if (this%mask(i,j,k).eq.1) this%itpv_y(:,i,j,k)=0.0_WP + if (this%mask(i,j,k).eq.1) this%itpw_z(:,i,j,k)=0.0_WP + end do + end do + end do + + ! Adjust viscosity interpolation coefficients to cell edge in the presence of walls (only walls) + do k=this%cfg%kmino_+1,this%cfg%kmaxo_ + do j=this%cfg%jmino_+1,this%cfg%jmaxo_ + do i=this%cfg%imino_+1,this%cfg%imaxo_ + ! Zero out interpolation coefficients reaching in the walls + do st1=-1,0 + do st2=-1,0 + if (this%mask(i+st1,j+st2,k).eq.1) this%itp_xy(st1,st2,i,j,k)=0.0_WP + if (this%mask(i,j+st1,k+st2).eq.1) this%itp_yz(st1,st2,i,j,k)=0.0_WP + if (this%mask(i+st1,j,k+st2).eq.1) this%itp_xz(st1,st2,i,j,k)=0.0_WP + end do + end do + ! Rescale to ensure sum(itp)=1 + mysum=sum(this%itp_xy(:,:,i,j,k)); if (mysum.gt.0.0_WP) this%itp_xy(:,:,i,j,k)=this%itp_xy(:,:,i,j,k)/mysum + mysum=sum(this%itp_yz(:,:,i,j,k)); if (mysum.gt.0.0_WP) this%itp_yz(:,:,i,j,k)=this%itp_yz(:,:,i,j,k)/mysum + mysum=sum(this%itp_xz(:,:,i,j,k)); if (mysum.gt.0.0_WP) this%itp_xz(:,:,i,j,k)=this%itp_xz(:,:,i,j,k)/mysum + end do + end do + end do + + ! Loop over the domain and adjust divergence for P cell + do k=this%cfg%kmino_,this%cfg%kmaxo_ + do j=this%cfg%jmino_,this%cfg%jmaxo_ + do i=this%cfg%imino_,this%cfg%imaxo_ + if (this%mask(i,j,k).gt.0) then + this%divp_x(:,i,j,k)=0.0_WP + this%divp_y(:,i,j,k)=0.0_WP + this%divp_z(:,i,j,k)=0.0_WP + end if + end do + end do + end do + + ! Loop over the domain and apply masked conditions to U metrics + do k=this%cfg%kmino_ ,this%cfg%kmaxo_ + do j=this%cfg%jmino_ ,this%cfg%jmaxo_ + do i=this%cfg%imino_+1,this%cfg%imaxo_ + if (this%umask(i,j,k).gt.0) then + this%divu_x(:,i,j,k)=0.0_WP + this%divu_y(:,i,j,k)=0.0_WP + this%divu_z(:,i,j,k)=0.0_WP + end if + end do + end do + end do + + ! Loop over the domain and apply masked conditions to V metrics + do k=this%cfg%kmino_ ,this%cfg%kmaxo_ + do j=this%cfg%jmino_+1,this%cfg%jmaxo_ + do i=this%cfg%imino_ ,this%cfg%imaxo_ + if (this%vmask(i,j,k).gt.0) then + this%divv_x(:,i,j,k)=0.0_WP + this%divv_y(:,i,j,k)=0.0_WP + this%divv_z(:,i,j,k)=0.0_WP + end if + end do + end do + end do + + ! Loop over the domain and apply masked conditions to W metrics + do k=this%cfg%kmino_+1,this%cfg%kmaxo_ + do j=this%cfg%jmino_ ,this%cfg%jmaxo_ + do i=this%cfg%imino_ ,this%cfg%imaxo_ + if (this%wmask(i,j,k).gt.0) then + this%divw_x(:,i,j,k)=0.0_WP + this%divw_y(:,i,j,k)=0.0_WP + this%divw_z(:,i,j,k)=0.0_WP + end if + end do + end do + end do + + ! Adjust gradient coefficients to cell edge in x + do k=this%cfg%kmino_ ,this%cfg%kmaxo_ + do j=this%cfg%jmino_ ,this%cfg%jmaxo_ + do i=this%cfg%imino_+1,this%cfg%imaxo_ + ! FD gradient in x of V from [xm,y ,zm] + if (maxval(this%vmask(i-1:i,j,k)).gt.0) then + delta=0.0_WP + if (this%vmask(i ,j,k).eq.0) delta=delta+(this%cfg%xm(i)-this%cfg%x (i )) + if (this%vmask(i-1,j,k).eq.0) delta=delta+(this%cfg%x (i)-this%cfg%xm(i-1)) + if (delta.gt.0.0_WP) then + this%grdv_x(:,i,j,k)=[-1.0_WP,+1.0_WP]/delta + else + this%grdv_x(:,i,j,k)=0.0_WP + end if + end if + ! FD gradient in x of W from [xm,ym,z ] + if (maxval(this%wmask(i-1:i,j,k)).gt.0) then + delta=0.0_WP + if (this%wmask(i ,j,k).eq.0) delta=delta+(this%cfg%xm(i)-this%cfg%x (i )) + if (this%wmask(i-1,j,k).eq.0) delta=delta+(this%cfg%x (i)-this%cfg%xm(i-1)) + if (delta.gt.0.0_WP) then + this%grdw_x(:,i,j,k)=[-1.0_WP,+1.0_WP]/delta + else + this%grdw_x(:,i,j,k)=0.0_WP + end if + end if + end do + end do + end do + + ! Adjust gradient coefficients to cell edge in y + do k=this%cfg%kmino_ ,this%cfg%kmaxo_ + do j=this%cfg%jmino_+1,this%cfg%jmaxo_ + do i=this%cfg%imino_ ,this%cfg%imaxo_ + ! FD gradient in y of U from [x ,ym,zm] + if (maxval(this%umask(i,j-1:j,k)).gt.0) then + delta=0.0_WP + if (this%umask(i,j ,k).eq.0) delta=delta+(this%cfg%ym(j)-this%cfg%y (j )) + if (this%umask(i,j-1,k).eq.0) delta=delta+(this%cfg%y (j)-this%cfg%ym(j-1)) + if (delta.gt.0.0_WP) then + this%grdu_y(:,i,j,k)=[-1.0_WP,+1.0_WP]/delta + else + this%grdu_y(:,i,j,k)=0.0_WP + end if + end if + ! FD gradient in y of W from [xm,ym,z ] + if (maxval(this%wmask(i,j-1:j,k)).gt.0) then + delta=0.0_WP + if (this%wmask(i,j ,k).eq.0) delta=delta+(this%cfg%ym(j)-this%cfg%y (j )) + if (this%wmask(i,j-1,k).eq.0) delta=delta+(this%cfg%y (j)-this%cfg%ym(j-1)) + if (delta.gt.0.0_WP) then + this%grdw_y(:,i,j,k)=[-1.0_WP,+1.0_WP]/delta + else + this%grdw_y(:,i,j,k)=0.0_WP + end if + end if + end do + end do + end do + + ! Adjust gradient coefficients to cell edge in z + do k=this%cfg%kmino_+1,this%cfg%kmaxo_ + do j=this%cfg%jmino_ ,this%cfg%jmaxo_ + do i=this%cfg%imino_ ,this%cfg%imaxo_ + ! FD gradient in z of U from [x ,ym,zm] + if (maxval(this%umask(i,j,k-1:k)).gt.0) then + delta=0.0_WP + if (this%umask(i,j,k ).eq.0) delta=delta+(this%cfg%zm(k)-this%cfg%z (k )) + if (this%umask(i,j,k-1).eq.0) delta=delta+(this%cfg%z (k)-this%cfg%zm(k-1)) + if (delta.gt.0.0_WP) then + this%grdu_z(:,i,j,k)=[-1.0_WP,+1.0_WP]/delta + else + this%grdu_z(:,i,j,k)=0.0_WP + end if + end if + ! FD gradient in z of V from [xm,y ,zm] + if (maxval(this%vmask(i,j,k-1:k)).gt.0) then + delta=0.0_WP + if (this%vmask(i,j,k ).eq.0) delta=delta+(this%cfg%zm(k)-this%cfg%z (k )) + if (this%vmask(i,j,k-1).eq.0) delta=delta+(this%cfg%z (k)-this%cfg%zm(k-1)) + if (delta.gt.0.0_WP) then + this%grdv_z(:,i,j,k)=[-1.0_WP,+1.0_WP]/delta + else + this%grdv_z(:,i,j,k)=0.0_WP + end if + end if + end do + end do + end do + + ! Adjust interpolation coefficients to cell centers in the presence of walls (only walls!) + do k=this%cfg%kmino_,this%cfg%kmaxo_ + do j=this%cfg%jmino_,this%cfg%jmaxo_ + do i=this%cfg%imino_,this%cfg%imaxo_ + if (this%mask(i,j,k).eq.1) this%itpu_x(:,i,j,k)=0.0_WP + if (this%mask(i,j,k).eq.1) this%itpv_y(:,i,j,k)=0.0_WP + if (this%mask(i,j,k).eq.1) this%itpw_z(:,i,j,k)=0.0_WP + end do + end do + end do + + ! Adjust interpolation coefficients to cell edge in x + do k=this%cfg%kmino_ ,this%cfg%kmaxo_ + do j=this%cfg%jmino_ ,this%cfg%jmaxo_ + do i=this%cfg%imino_+1,this%cfg%imaxo_ + ! Linear interpolation in x of V from [xm,y ,zm] + if (this%vmask(i,j,k).eq.0.and.this%vmask(i-1,j,k).gt.0) this%itpv_x(:,i,j,k)=[1.0_WP,0.0_WP] + if (this%vmask(i,j,k).gt.0.and.this%vmask(i-1,j,k).eq.0) this%itpv_x(:,i,j,k)=[0.0_WP,1.0_WP] + ! Linear interpolation in x of W from [xm,ym,z ] + if (this%wmask(i,j,k).eq.0.and.this%wmask(i-1,j,k).gt.0) this%itpw_x(:,i,j,k)=[1.0_WP,0.0_WP] + if (this%wmask(i,j,k).gt.0.and.this%wmask(i-1,j,k).eq.0) this%itpw_x(:,i,j,k)=[0.0_WP,1.0_WP] + end do + end do + end do + + ! Adjust interpolation coefficients to cell edge in y + do k=this%cfg%kmino_ ,this%cfg%kmaxo_ + do j=this%cfg%jmino_+1,this%cfg%jmaxo_ + do i=this%cfg%imino_ ,this%cfg%imaxo_ + ! Linear interpolation in y of U from [x ,ym,zm] + if (this%umask(i,j,k).eq.0.and.this%umask(i,j-1,k).gt.0) this%itpu_y(:,i,j,k)=[1.0_WP,0.0_WP] + if (this%umask(i,j,k).gt.0.and.this%umask(i,j-1,k).eq.0) this%itpu_y(:,i,j,k)=[0.0_WP,1.0_WP] + ! Linear interpolation in y of W from [xm,ym,z ] + if (this%wmask(i,j,k).eq.0.and.this%wmask(i,j-1,k).gt.0) this%itpw_y(:,i,j,k)=[1.0_WP,0.0_WP] + if (this%wmask(i,j,k).gt.0.and.this%wmask(i,j-1,k).eq.0) this%itpw_y(:,i,j,k)=[0.0_WP,1.0_WP] + end do + end do + end do + + ! Adjust interpolation coefficients to cell edge in z + do k=this%cfg%kmino_+1,this%cfg%kmaxo_ + do j=this%cfg%jmino_ ,this%cfg%jmaxo_ + do i=this%cfg%imino_ ,this%cfg%imaxo_ + ! Linear interpolation in z of U from [x ,ym,zm] + if (this%umask(i,j,k).eq.0.and.this%umask(i,j,k-1).gt.0) this%itpu_z(:,i,j,k)=[1.0_WP,0.0_WP] + if (this%umask(i,j,k).gt.0.and.this%umask(i,j,k-1).eq.0) this%itpu_z(:,i,j,k)=[0.0_WP,1.0_WP] + ! Linear interpolation in z of V from [xm,y ,zm] + if (this%vmask(i,j,k).eq.0.and.this%vmask(i,j,k-1).gt.0) this%itpv_z(:,i,j,k)=[1.0_WP,0.0_WP] + if (this%vmask(i,j,k).gt.0.and.this%vmask(i,j,k-1).eq.0) this%itpv_z(:,i,j,k)=[0.0_WP,1.0_WP] + end do + end do + end do + + ! Adjust metrics to account for lower dimensionality + if (this%cfg%nx.eq.1) then + this%divp_x=0.0_WP + this%divu_x=0.0_WP + this%divv_x=0.0_WP + this%divw_x=0.0_WP + this%grdu_x=0.0_WP + this%grdv_x=0.0_WP + this%grdw_x=0.0_WP + end if + if (this%cfg%ny.eq.1) then + this%divp_y=0.0_WP + this%divu_y=0.0_WP + this%divv_y=0.0_WP + this%divw_y=0.0_WP + this%grdu_y=0.0_WP + this%grdv_y=0.0_WP + this%grdw_y=0.0_WP + end if + if (this%cfg%nz.eq.1) then + this%divp_z=0.0_WP + this%divu_z=0.0_WP + this%divv_z=0.0_WP + this%divw_z=0.0_WP + this%grdu_z=0.0_WP + this%grdv_z=0.0_WP + this%grdw_z=0.0_WP + end if + + end subroutine adjust_metrics + + + !> Finish setting up the flow solver now that bconds have been defined + subroutine setup(this,pressure_solver,implicit_solver) + implicit none + class(incomp), intent(inout) :: this + class(linsol), target, intent(in) :: pressure_solver !< A pressure solver is required + class(linsol), target, intent(in), optional :: implicit_solver !< An implicit solver can be provided + integer :: i,j,k + + ! Adjust metrics based on bcflag array + call this%adjust_metrics() + + ! Point to pressure solver linsol object + this%psolv=>pressure_solver + + ! Set 7-pt stencil map for the pressure solver + this%psolv%stc(1,:)=[ 0, 0, 0] + this%psolv%stc(2,:)=[+1, 0, 0] + this%psolv%stc(3,:)=[-1, 0, 0] + this%psolv%stc(4,:)=[ 0,+1, 0] + this%psolv%stc(5,:)=[ 0,-1, 0] + this%psolv%stc(6,:)=[ 0, 0,+1] + this%psolv%stc(7,:)=[ 0, 0,-1] + + ! Setup the scaled Laplacian operator from incomp metrics: lap(*)=-vol*div(grad(*)) + do k=this%cfg%kmin_,this%cfg%kmax_ + do j=this%cfg%jmin_,this%cfg%jmax_ + do i=this%cfg%imin_,this%cfg%imax_ + ! Set Laplacian + this%psolv%opr(1,i,j,k)=this%divp_x(1,i,j,k)*this%divu_x(-1,i+1,j,k)+& + & this%divp_x(0,i,j,k)*this%divu_x( 0,i ,j,k)+& + & this%divp_y(1,i,j,k)*this%divv_y(-1,i,j+1,k)+& + & this%divp_y(0,i,j,k)*this%divv_y( 0,i,j ,k)+& + & this%divp_z(1,i,j,k)*this%divw_z(-1,i,j,k+1)+& + & this%divp_z(0,i,j,k)*this%divw_z( 0,i,j,k ) + this%psolv%opr(2,i,j,k)=this%divp_x(1,i,j,k)*this%divu_x( 0,i+1,j,k) + this%psolv%opr(3,i,j,k)=this%divp_x(0,i,j,k)*this%divu_x(-1,i ,j,k) + this%psolv%opr(4,i,j,k)=this%divp_y(1,i,j,k)*this%divv_y( 0,i,j+1,k) + this%psolv%opr(5,i,j,k)=this%divp_y(0,i,j,k)*this%divv_y(-1,i,j ,k) + this%psolv%opr(6,i,j,k)=this%divp_z(1,i,j,k)*this%divw_z( 0,i,j,k+1) + this%psolv%opr(7,i,j,k)=this%divp_z(0,i,j,k)*this%divw_z(-1,i,j,k ) + ! Scale it by the cell volume + this%psolv%opr(:,i,j,k)=-this%psolv%opr(:,i,j,k)*this%cfg%vol(i,j,k) + end do + end do + end do + + ! Initialize the pressure Poisson solver + call this%psolv%init() + call this%psolv%setup() + + ! Prepare implicit solver if it had been provided + if (present(implicit_solver)) then + + ! Point to implicit solver linsol object + this%implicit=>implicit_solver + + ! Set 7-pt stencil map for the velocity solver + this%implicit%stc(1,:)=[ 0, 0, 0] + this%implicit%stc(2,:)=[+1, 0, 0] + this%implicit%stc(3,:)=[-1, 0, 0] + this%implicit%stc(4,:)=[ 0,+1, 0] + this%implicit%stc(5,:)=[ 0,-1, 0] + this%implicit%stc(6,:)=[ 0, 0,+1] + this%implicit%stc(7,:)=[ 0, 0,-1] + + ! Set the diagonal to 1 to make sure all cells participate in solver + this%implicit%opr(1,:,:,:)=1.0_WP + + ! Initialize the implicit velocity solver + call this%implicit%init() + + else + + ! Point to implicit solver linsol object + this%implicit=>NULL() + + end if + + end subroutine setup + + + !> Add a boundary condition + subroutine add_bcond(this,name,type,locator,face,dir,canCorrect) + use string, only: lowercase + use messager, only: die + use iterator_class, only: locator_ftype + implicit none + class(incomp), intent(inout) :: this + character(len=*), intent(in) :: name + integer, intent(in) :: type + procedure(locator_ftype) :: locator + character(len=1), intent(in) :: face + integer, intent(in) :: dir + logical, intent(in) :: canCorrect + type(bcond), pointer :: new_bc + integer :: i,j,k,n + + ! Prepare new bcond + allocate(new_bc) + new_bc%name=trim(adjustl(name)) + new_bc%type=type + select case (lowercase(face)) + case ('x'); new_bc%face='x' + case ('y'); new_bc%face='y' + case ('z'); new_bc%face='z' + case default; call die('[incomp add_bcond] Unknown bcond face - expecting x, y, or z') + end select + new_bc%itr=iterator(pg=this%cfg,name=new_bc%name,locator=locator,face=new_bc%face) + select case (dir) ! Outward-oriented + case (+1); new_bc%dir=+1 + case (-1); new_bc%dir=-1 + case ( 0); new_bc%dir= 0 + case default; call die('[incomp add_bcond] Unknown bcond dir - expecting -1, +1, or 0') + end select + new_bc%rdir=real(new_bc%dir,WP) + new_bc%canCorrect=canCorrect + + ! Insert it up front + new_bc%next=>this%first_bc + this%first_bc=>new_bc + + ! Increment bcond counter + this%nbc=this%nbc+1 + + ! Now adjust the metrics accordingly + select case (new_bc%type) + case (dirichlet) !< Dirichlet is set one face (i.e., velocit component) at the time + select case (new_bc%face) + case ('x') + do n=1,new_bc%itr%n_ + i=new_bc%itr%map(1,n); j=new_bc%itr%map(2,n); k=new_bc%itr%map(3,n) + this%umask(i,j,k)=2 + end do + case ('y') + do n=1,new_bc%itr%n_ + i=new_bc%itr%map(1,n); j=new_bc%itr%map(2,n); k=new_bc%itr%map(3,n) + this%vmask(i,j,k)=2 + end do + case ('z') + do n=1,new_bc%itr%n_ + i=new_bc%itr%map(1,n); j=new_bc%itr%map(2,n); k=new_bc%itr%map(3,n) + this%wmask(i,j,k)=2 + end do + end select + + case (neumann) !< Neumann has to be at existing wall or at domain boundary! + case (clipped_neumann) + case (convective) + case (slip) + case default + call die('[incomp apply_bcond] Unknown bcond type') + end select + + end subroutine add_bcond + + + !> Get a boundary condition + subroutine get_bcond(this,name,my_bc) + use messager, only: die + implicit none + class(incomp), intent(inout) :: this + character(len=*), intent(in) :: name + type(bcond), pointer, intent(out) :: my_bc + my_bc=>this%first_bc + search: do while (associated(my_bc)) + if (trim(my_bc%name).eq.trim(name)) exit search + my_bc=>my_bc%next + end do search + if (.not.associated(my_bc)) call die('[incomp get_bcond] Boundary condition was not found') + end subroutine get_bcond + + + !> Enforce boundary condition + subroutine apply_bcond(this,t,dt) + use messager, only: die + implicit none + class(incomp), intent(inout) :: this + real(WP), intent(in) :: t,dt + integer :: i,j,k,n,stag + type(bcond), pointer :: my_bc + + ! ! First enfore zero velocity at walls + ! do k=this%cfg%kmin_,this%cfg%kmax_ + ! do j=this%cfg%jmin_,this%cfg%jmax_ + ! do i=this%cfg%imin_,this%cfg%imax_ + ! if (minval(this%cfg%VF(i-1:i,j,k)).lt.10.0_WP*epsilon(1.0_WP)) this%U(i,j,k)=0.0_WP + ! if (minval(this%cfg%VF(i,j-1:j,k)).lt.10.0_WP*epsilon(1.0_WP)) this%V(i,j,k)=0.0_WP + ! if (minval(this%cfg%VF(i,j,k-1:k)).lt.10.0_WP*epsilon(1.0_WP)) this%W(i,j,k)=0.0_WP + ! end do + ! end do + ! end do + ! ! Sync fields + ! call this%cfg%sync(this%U) + ! call this%cfg%sync(this%V) + ! call this%cfg%sync(this%W) + + ! Traverse bcond list + my_bc=>this%first_bc + do while (associated(my_bc)) + + ! Only processes inside the bcond work here + if (my_bc%itr%amIn) then + + ! Select appropriate action based on the bcond type + select case (my_bc%type) + + case (dirichlet) !< Apply Dirichlet conditions + + ! This is done by the user directly + ! Unclear whether we want to do this within the solver... + + case (neumann,clipped_neumann,slip) !< Apply Neumann condition to all 3 components + ! Handle index shift due to staggering + stag=min(my_bc%dir,0) + ! Implement based on bcond direction + select case (my_bc%face) + case ('x') + stag=min(my_bc%dir,0) + do n=1,my_bc%itr%n_ + i=my_bc%itr%map(1,n); j=my_bc%itr%map(2,n); k=my_bc%itr%map(3,n) + this%U(i ,j ,k )=this%U(i-my_bc%dir ,j ,k ) + this%V(i+stag,j:j+1,k )=this%V(i-my_bc%dir+stag,j:j+1,k ) + this%W(i+stag,j ,k:k+1)=this%W(i-my_bc%dir+stag,j ,k:k+1) + end do + case ('y') + stag=min(my_bc%dir,0) + do n=1,my_bc%itr%n_ + i=my_bc%itr%map(1,n); j=my_bc%itr%map(2,n); k=my_bc%itr%map(3,n) + this%U(i:i+1,j+stag,k )=this%U(i:i+1,j-my_bc%dir+stag,k ) + this%V(i ,j ,k )=this%V(i ,j-my_bc%dir ,k ) + this%W(i ,j+stag,k:k+1)=this%W(i ,j-my_bc%dir+stag,k:k+1) + end do + case ('z') + stag=min(my_bc%dir,0) + do n=1,my_bc%itr%n_ + i=my_bc%itr%map(1,n); j=my_bc%itr%map(2,n); k=my_bc%itr%map(3,n) + this%U(i:i+1,j ,k+stag)=this%U(i:i+1,j ,k-my_bc%dir+stag) + this%V(i ,j:j+1,k+stag)=this%V(i ,j:j+1,k-my_bc%dir+stag) + this%W(i ,j ,k )=this%W(i ,j ,k-my_bc%dir ) + end do + end select + ! If needed, clip + if (my_bc%type.eq.clipped_neumann) then + select case (my_bc%face) + case ('x') + do n=1,my_bc%itr%n_ + i=my_bc%itr%map(1,n); j=my_bc%itr%map(2,n); k=my_bc%itr%map(3,n) + if (this%U(i,j,k)*my_bc%rdir.lt.0.0_WP) this%U(i,j,k)=0.0_WP + end do + case ('y') + do n=1,my_bc%itr%n_ + i=my_bc%itr%map(1,n); j=my_bc%itr%map(2,n); k=my_bc%itr%map(3,n) + if (this%V(i,j,k)*my_bc%rdir.lt.0.0_WP) this%V(i,j,k)=0.0_WP + end do + case ('z') + do n=1,my_bc%itr%n_ + i=my_bc%itr%map(1,n); j=my_bc%itr%map(2,n); k=my_bc%itr%map(3,n) + if (this%W(i,j,k)*my_bc%rdir.lt.0.0_WP) this%W(i,j,k)=0.0_WP + end do + end select + end if + ! If needed, no penetration + if (my_bc%type.eq.slip) then + select case (my_bc%face) + case ('x') + do n=1,my_bc%itr%n_ + i=my_bc%itr%map(1,n); j=my_bc%itr%map(2,n); k=my_bc%itr%map(3,n) + this%U(i,j,k)=0.0_WP + end do + case ('y') + do n=1,my_bc%itr%n_ + i=my_bc%itr%map(1,n); j=my_bc%itr%map(2,n); k=my_bc%itr%map(3,n) + this%V(i,j,k)=0.0_WP + end do + case ('z') + do n=1,my_bc%itr%n_ + i=my_bc%itr%map(1,n); j=my_bc%itr%map(2,n); k=my_bc%itr%map(3,n) + this%W(i,j,k)=0.0_WP + end do + end select + end if + + case (convective) ! Not implemented yet! + + case default + call die('[incomp apply_bcond] Unknown bcond type') + end select + + end if + + ! Move on to the next bcond + my_bc=>my_bc%next + + end do + + ! Sync full fields after all bcond + call this%cfg%sync(this%U) + call this%cfg%sync(this%V) + call this%cfg%sync(this%W) + + end subroutine apply_bcond + + + !> Calculate the explicit momentum time derivative based on U/V/W/P + subroutine get_dmomdt(this,drhoUdt,drhoVdt,drhoWdt) + implicit none + class(incomp), intent(inout) :: this + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(out) :: drhoUdt !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(out) :: drhoVdt !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(out) :: drhoWdt !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + integer :: i,j,k,ii,jj,kk + real(WP), dimension(:,:,:), allocatable :: FX,FY,FZ + + ! Zero out drhoUVW/dt arrays + drhoUdt=0.0_WP; drhoVdt=0.0_WP; drhoWdt=0.0_WP + + ! Allocate flux arrays + allocate(FX(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + allocate(FY(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + allocate(FZ(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + + ! Flux of rhoU + do kk=this%cfg%kmin_,this%cfg%kmax_+1 + do jj=this%cfg%jmin_,this%cfg%jmax_+1 + do ii=this%cfg%imin_,this%cfg%imax_+1 + ! Fluxes on x-face + i=ii-1; j=jj-1; k=kk-1 + FX(i,j,k)=-this%rho*sum(this%itpu_x(:,i,j,k)*this%U(i:i+1,j,k))*sum(this%itpu_x(:,i,j,k)*this%U(i:i+1,j,k)) & + & +this%visc(i,j,k)*(sum(this%grdu_x(:,i,j,k)*this%U(i:i+1,j,k))+sum(this%grdu_x(:,i,j,k)*this%U(i:i+1,j,k)) & + & -2.0_WP/3.0_WP*(sum(this%divp_x(:,i,j,k)*this%U(i:i+1,j,k))+sum(this%divp_y(:,i,j,k)*this%V(i,j:j+1,k))+sum(this%divp_z(:,i,j,k)*this%W(i,j,k:k+1)))) & + & -this%P(i,j,k) + ! Fluxes on y-face + i=ii; j=jj; k=kk + FY(i,j,k)=-this%rho*sum(this%itpu_y(:,i,j,k)*this%U(i,j-1:j,k))*sum(this%itpv_x(:,i,j,k)*this%V(i-1:i,j,k)) & + & +sum(this%itp_xy(:,:,i,j,k)*this%visc(i-1:i,j-1:j,k))*(sum(this%grdu_y(:,i,j,k)*this%U(i,j-1:j,k))+sum(this%grdv_x(:,i,j,k)*this%V(i-1:i,j,k))) + ! Fluxes on z-face + i=ii; j=jj; k=kk + FZ(i,j,k)=-this%rho*sum(this%itpu_z(:,i,j,k)*this%U(i,j,k-1:k))*sum(this%itpw_x(:,i,j,k)*this%W(i-1:i,j,k)) & + & +sum(this%itp_xz(:,:,i,j,k)*this%visc(i-1:i,j,k-1:k))*(sum(this%grdu_z(:,i,j,k)*this%U(i,j,k-1:k))+sum(this%grdw_x(:,i,j,k)*this%W(i-1:i,j,k))) + end do + end do + end do + ! Time derivative of rhoU + do k=this%cfg%kmin_,this%cfg%kmax_ + do j=this%cfg%jmin_,this%cfg%jmax_ + do i=this%cfg%imin_,this%cfg%imax_ + drhoUdt(i,j,k)=sum(this%divu_x(:,i,j,k)*FX(i-1:i,j,k))+& + & sum(this%divu_y(:,i,j,k)*FY(i,j:j+1,k))+& + & sum(this%divu_z(:,i,j,k)*FZ(i,j,k:k+1)) + end do + end do + end do + ! Sync it + call this%cfg%sync(drhoUdt) + + ! Flux of rhoV + do kk=this%cfg%kmin_,this%cfg%kmax_+1 + do jj=this%cfg%jmin_,this%cfg%jmax_+1 + do ii=this%cfg%imin_,this%cfg%imax_+1 + ! Fluxes on x-face + i=ii; j=jj; k=kk + FX(i,j,k)=-this%rho*sum(this%itpv_x(:,i,j,k)*this%V(i-1:i,j,k))*sum(this%itpu_y(:,i,j,k)*this%U(i,j-1:j,k)) & + & +sum(this%itp_xy(:,:,i,j,k)*this%visc(i-1:i,j-1:j,k))*(sum(this%grdv_x(:,i,j,k)*this%V(i-1:i,j,k))+sum(this%grdu_y(:,i,j,k)*this%U(i,j-1:j,k))) + ! Fluxes on y-face + i=ii-1; j=jj-1; k=kk-1 + FY(i,j,k)=-this%rho*sum(this%itpv_y(:,i,j,k)*this%V(i,j:j+1,k))*sum(this%itpv_y(:,i,j,k)*this%V(i,j:j+1,k)) & + & +this%visc(i,j,k)*(sum(this%grdv_y(:,i,j,k)*this%V(i,j:j+1,k))+sum(this%grdv_y(:,i,j,k)*this%V(i,j:j+1,k)) & + & -2.0_WP/3.0_WP*(sum(this%divp_x(:,i,j,k)*this%U(i:i+1,j,k))+sum(this%divp_y(:,i,j,k)*this%V(i,j:j+1,k))+sum(this%divp_z(:,i,j,k)*this%W(i,j,k:k+1)))) & + & -this%P(i,j,k) + ! Fluxes on z-face + i=ii; j=jj; k=kk + FZ(i,j,k)=-this%rho*sum(this%itpv_z(:,i,j,k)*this%V(i,j,k-1:k))*sum(this%itpw_y(:,i,j,k)*this%W(i,j-1:j,k)) & + & +sum(this%itp_yz(:,:,i,j,k)*this%visc(i,j-1:j,k-1:k))*(sum(this%grdv_z(:,i,j,k)*this%V(i,j,k-1:k))+sum(this%grdw_y(:,i,j,k)*this%W(i,j-1:j,k))) + end do + end do + end do + ! Time derivative of rhoV + do k=this%cfg%kmin_,this%cfg%kmax_ + do j=this%cfg%jmin_,this%cfg%jmax_ + do i=this%cfg%imin_,this%cfg%imax_ + drhoVdt(i,j,k)=sum(this%divv_x(:,i,j,k)*FX(i:i+1,j,k))+& + & sum(this%divv_y(:,i,j,k)*FY(i,j-1:j,k))+& + & sum(this%divv_z(:,i,j,k)*FZ(i,j,k:k+1)) + end do + end do + end do + ! Sync it + call this%cfg%sync(drhoVdt) + + ! Flux of rhoW + do kk=this%cfg%kmin_,this%cfg%kmax_+1 + do jj=this%cfg%jmin_,this%cfg%jmax_+1 + do ii=this%cfg%imin_,this%cfg%imax_+1 + ! Fluxes on x-face + i=ii; j=jj; k=kk + FX(i,j,k)=-this%rho*sum(this%itpw_x(:,i,j,k)*this%W(i-1:i,j,k))*sum(this%itpu_z(:,i,j,k)*this%U(i,j,k-1:k)) & + & +sum(this%itp_xz(:,:,i,j,k)*this%visc(i-1:i,j,k-1:k))*(sum(this%grdw_x(:,i,j,k)*this%W(i-1:i,j,k))+sum(this%grdu_z(:,i,j,k)*this%U(i,j,k-1:k))) + ! Fluxes on y-face + i=ii; j=jj; k=kk + FY(i,j,k)=-this%rho*sum(this%itpw_y(:,i,j,k)*this%W(i,j-1:j,k))*sum(this%itpv_z(:,i,j,k)*this%V(i,j,k-1:k)) & + & +sum(this%itp_yz(:,:,i,j,k)*this%visc(i,j-1:j,k-1:k))*(sum(this%grdw_y(:,i,j,k)*this%W(i,j-1:j,k))+sum(this%grdv_z(:,i,j,k)*this%V(i,j,k-1:k))) + ! Fluxes on z-face + i=ii-1; j=jj-1; k=kk-1 + FZ(i,j,k)=-this%rho*sum(this%itpw_z(:,i,j,k)*this%W(i,j,k:k+1))*sum(this%itpw_z(:,i,j,k)*this%W(i,j,k:k+1)) & + & +this%visc(i,j,k)*(sum(this%grdw_z(:,i,j,k)*this%W(i,j,k:k+1))+sum(this%grdw_z(:,i,j,k)*this%W(i,j,k:k+1)) & + & -2.0_WP/3.0_WP*(sum(this%divp_x(:,i,j,k)*this%U(i:i+1,j,k))+sum(this%divp_y(:,i,j,k)*this%V(i,j:j+1,k))+sum(this%divp_z(:,i,j,k)*this%W(i,j,k:k+1)))) & + & -this%P(i,j,k) + end do + end do + end do + ! Time derivative of rhoW + do k=this%cfg%kmin_,this%cfg%kmax_ + do j=this%cfg%jmin_,this%cfg%jmax_ + do i=this%cfg%imin_,this%cfg%imax_ + drhoWdt(i,j,k)=sum(this%divw_x(:,i,j,k)*FX(i:i+1,j,k))+& + & sum(this%divw_y(:,i,j,k)*FY(i,j:j+1,k))+& + & sum(this%divw_z(:,i,j,k)*FZ(i,j,k-1:k)) + end do + end do + end do + ! Sync it + call this%cfg%sync(drhoWdt) + + ! Deallocate flux arrays + deallocate(FX,FY,FZ) + + end subroutine get_dmomdt + + !> Calculate divergence of stress for LPT solver + subroutine get_div_stress(this,divx,divy,divz) + implicit none + class(incomp), intent(inout) :: this + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(out) :: divx !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(out) :: divy !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(out) :: divz !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + integer :: i,j,k,ii,jj,kk + real(WP), dimension(:,:,:), allocatable :: FX,FY,FZ + + ! Zero out drhoUVW/dt arrays + divx=0.0_WP; divy=0.0_WP; divz=0.0_WP + + ! Allocate flux arrays + allocate(FX(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + allocate(FY(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + allocate(FZ(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + + ! Flux of rhoU + do kk=this%cfg%kmin_,this%cfg%kmax_+1 + do jj=this%cfg%jmin_,this%cfg%jmax_+1 + do ii=this%cfg%imin_,this%cfg%imax_+1 + ! Fluxes on x-face + i=ii-1; j=jj-1; k=kk-1 + FX(i,j,k)=this%visc(i,j,k)*(sum(this%grdu_x(:,i,j,k)*this%U(i:i+1,j,k))+sum(this%grdu_x(:,i,j,k)*this%U(i:i+1,j,k))) & + ! & -2.0_WP/3.0_WP*(sum(this%divp_x(:,i,j,k)*this%U(i:i+1,j,k))+sum(this%divp_y(:,i,j,k)*this%V(i,j:j+1,k))+sum(this%divp_z(:,i,j,k)*this%W(i,j,k:k+1)))) & + & -this%P(i,j,k) + ! Fluxes on y-face + i=ii; j=jj; k=kk + FY(i,j,k)=sum(this%itp_xy(:,:,i,j,k)*this%visc(i-1:i,j-1:j,k))*(sum(this%grdu_y(:,i,j,k)*this%U(i,j-1:j,k))+sum(this%grdv_x(:,i,j,k)*this%V(i-1:i,j,k))) + ! Fluxes on z-face + i=ii; j=jj; k=kk + FZ(i,j,k)=sum(this%itp_xz(:,:,i,j,k)*this%visc(i-1:i,j,k-1:k))*(sum(this%grdu_z(:,i,j,k)*this%U(i,j,k-1:k))+sum(this%grdw_x(:,i,j,k)*this%W(i-1:i,j,k))) + end do + end do + end do + ! Divergence of stresses + do k=this%cfg%kmin_,this%cfg%kmax_ + do j=this%cfg%jmin_,this%cfg%jmax_ + do i=this%cfg%imin_,this%cfg%imax_ + divx(i,j,k)=sum(this%divu_x(:,i,j,k)*FX(i-1:i,j,k))+& + & sum(this%divu_y(:,i,j,k)*FY(i,j:j+1,k))+& + & sum(this%divu_z(:,i,j,k)*FZ(i,j,k:k+1)) + end do + end do + end do + ! Sync it + call this%cfg%sync(divx) + + ! Flux of rhoV + do kk=this%cfg%kmin_,this%cfg%kmax_+1 + do jj=this%cfg%jmin_,this%cfg%jmax_+1 + do ii=this%cfg%imin_,this%cfg%imax_+1 + ! Fluxes on x-face + i=ii; j=jj; k=kk + FX(i,j,k)=sum(this%itp_xy(:,:,i,j,k)*this%visc(i-1:i,j-1:j,k))*(sum(this%grdv_x(:,i,j,k)*this%V(i-1:i,j,k))+sum(this%grdu_y(:,i,j,k)*this%U(i,j-1:j,k))) + ! Fluxes on y-face + i=ii-1; j=jj-1; k=kk-1 + FY(i,j,k)=this%visc(i,j,k)*(sum(this%grdv_y(:,i,j,k)*this%V(i,j:j+1,k))+sum(this%grdv_y(:,i,j,k)*this%V(i,j:j+1,k))) & + ! & -2.0_WP/3.0_WP*(sum(this%divp_x(:,i,j,k)*this%U(i:i+1,j,k))+sum(this%divp_y(:,i,j,k)*this%V(i,j:j+1,k))+sum(this%divp_z(:,i,j,k)*this%W(i,j,k:k+1)))) & + & -this%P(i,j,k) + ! Fluxes on z-face + i=ii; j=jj; k=kk + FZ(i,j,k)=sum(this%itp_yz(:,:,i,j,k)*this%visc(i,j-1:j,k-1:k))*(sum(this%grdv_z(:,i,j,k)*this%V(i,j,k-1:k))+sum(this%grdw_y(:,i,j,k)*this%W(i,j-1:j,k))) + end do + end do + end do + ! Divergence of stresses + do k=this%cfg%kmin_,this%cfg%kmax_ + do j=this%cfg%jmin_,this%cfg%jmax_ + do i=this%cfg%imin_,this%cfg%imax_ + divy(i,j,k)=sum(this%divv_x(:,i,j,k)*FX(i:i+1,j,k))+& + & sum(this%divv_y(:,i,j,k)*FY(i,j-1:j,k))+& + & sum(this%divv_z(:,i,j,k)*FZ(i,j,k:k+1)) + end do + end do + end do + ! Sync it + call this%cfg%sync(divy) + + ! Flux of rhoW + do kk=this%cfg%kmin_,this%cfg%kmax_+1 + do jj=this%cfg%jmin_,this%cfg%jmax_+1 + do ii=this%cfg%imin_,this%cfg%imax_+1 + ! Fluxes on x-face + i=ii; j=jj; k=kk + FX(i,j,k)=sum(this%itp_xz(:,:,i,j,k)*this%visc(i-1:i,j,k-1:k))*(sum(this%grdw_x(:,i,j,k)*this%W(i-1:i,j,k))+sum(this%grdu_z(:,i,j,k)*this%U(i,j,k-1:k))) + ! Fluxes on y-face + i=ii; j=jj; k=kk + FY(i,j,k)=sum(this%itp_yz(:,:,i,j,k)*this%visc(i,j-1:j,k-1:k))*(sum(this%grdw_y(:,i,j,k)*this%W(i,j-1:j,k))+sum(this%grdv_z(:,i,j,k)*this%V(i,j,k-1:k))) + ! Fluxes on z-face + i=ii-1; j=jj-1; k=kk-1 + FZ(i,j,k)=this%visc(i,j,k)*(sum(this%grdw_z(:,i,j,k)*this%W(i,j,k:k+1))+sum(this%grdw_z(:,i,j,k)*this%W(i,j,k:k+1))) & + ! & -2.0_WP/3.0_WP*(sum(this%divp_x(:,i,j,k)*this%U(i:i+1,j,k))+sum(this%divp_y(:,i,j,k)*this%V(i,j:j+1,k))+sum(this%divp_z(:,i,j,k)*this%W(i,j,k:k+1)))) & + & -this%P(i,j,k) + end do + end do + end do + ! Divergence of stresses + do k=this%cfg%kmin_,this%cfg%kmax_ + do j=this%cfg%jmin_,this%cfg%jmax_ + do i=this%cfg%imin_,this%cfg%imax_ + divz(i,j,k)=sum(this%divw_x(:,i,j,k)*FX(i:i+1,j,k))+& + & sum(this%divw_y(:,i,j,k)*FY(i,j:j+1,k))+& + & sum(this%divw_z(:,i,j,k)*FZ(i,j,k-1:k)) + end do + end do + end do + ! Sync it + call this%cfg%sync(divz) + + ! Deallocate flux arrays + deallocate(FX,FY,FZ) + + end subroutine get_div_stress + + + !> Calculate the velocity divergence based on U/V/W + subroutine get_div(this,src) + implicit none + class(incomp), intent(inout) :: this + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), optional :: src !< Mass source term + integer :: i,j,k + ! Calculate divergence of velocity + do k=this%cfg%kmin_,this%cfg%kmax_ + do j=this%cfg%jmin_,this%cfg%jmax_ + do i=this%cfg%imin_,this%cfg%imax_ + this%div(i,j,k)=sum(this%divp_x(:,i,j,k)*this%U(i:i+1,j,k))+& + & sum(this%divp_y(:,i,j,k)*this%V(i,j:j+1,k))+& + & sum(this%divp_z(:,i,j,k)*this%W(i,j,k:k+1)) + end do + end do + end do + ! If present, account for mass source + if (present(src)) then + do k=this%cfg%kmin_,this%cfg%kmax_ + do j=this%cfg%jmin_,this%cfg%jmax_ + do i=this%cfg%imin_,this%cfg%imax_ + this%div(i,j,k)=this%div(i,j,k)-src(i,j,k) + end do + end do + end do + end if + ! Sync it + call this%cfg%sync(this%div) + end subroutine get_div + + + !> Calculate the pressure gradient based on P + subroutine get_pgrad(this,P,Pgradx,Pgrady,Pgradz) + implicit none + class(incomp), intent(inout) :: this + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(in) :: P !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(out) :: Pgradx !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(out) :: Pgrady !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(out) :: Pgradz !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + integer :: i,j,k + Pgradx=0.0_WP; Pgrady=0.0_WP; Pgradz=0.0_WP + do k=this%cfg%kmin_,this%cfg%kmax_ + do j=this%cfg%jmin_,this%cfg%jmax_ + do i=this%cfg%imin_,this%cfg%imax_ + Pgradx(i,j,k)=sum(this%divu_x(:,i,j,k)*P(i-1:i,j,k)) + Pgrady(i,j,k)=sum(this%divv_y(:,i,j,k)*P(i,j-1:j,k)) + Pgradz(i,j,k)=sum(this%divw_z(:,i,j,k)*P(i,j,k-1:k)) + end do + end do + end do + ! Sync it + call this%cfg%sync(Pgradx) + call this%cfg%sync(Pgrady) + call this%cfg%sync(Pgradz) + end subroutine get_pgrad + + + !> Calculate the interpolated velocity, including overlap and ghosts + subroutine interp_vel(this,Ui,Vi,Wi) + implicit none + class(incomp), intent(inout) :: this + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(out) :: Ui !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(out) :: Vi !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(out) :: Wi !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + integer :: i,j,k + ! Calculate as far as possible each component + do k=this%cfg%kmino_,this%cfg%kmaxo_ + do j=this%cfg%jmino_,this%cfg%jmaxo_ + do i=this%cfg%imino_,this%cfg%imaxo_-1 + Ui(i,j,k)=sum(this%itpu_x(:,i,j,k)*this%U(i:i+1,j,k)) + end do + end do + end do + do k=this%cfg%kmino_,this%cfg%kmaxo_ + do j=this%cfg%jmino_,this%cfg%jmaxo_-1 + do i=this%cfg%imino_,this%cfg%imaxo_ + Vi(i,j,k)=sum(this%itpv_y(:,i,j,k)*this%V(i,j:j+1,k)) + end do + end do + end do + do k=this%cfg%kmino_,this%cfg%kmaxo_-1 + do j=this%cfg%jmino_,this%cfg%jmaxo_ + do i=this%cfg%imino_,this%cfg%imaxo_ + Wi(i,j,k)=sum(this%itpw_z(:,i,j,k)*this%W(i,j,k:k+1)) + end do + end do + end do + ! Add last layer in each direction + if (.not.this%cfg%xper.and.this%cfg%iproc.eq.this%cfg%npx) Ui(this%cfg%imaxo,:,:)=this%U(this%cfg%imaxo,:,:) + if (.not.this%cfg%yper.and.this%cfg%jproc.eq.this%cfg%npy) Vi(:,this%cfg%jmaxo,:)=this%V(:,this%cfg%jmaxo,:) + if (.not.this%cfg%zper.and.this%cfg%kproc.eq.this%cfg%npz) Wi(:,:,this%cfg%kmaxo)=this%W(:,:,this%cfg%kmaxo) + ! Sync it + call this%cfg%sync(Ui) + call this%cfg%sync(Vi) + call this%cfg%sync(Wi) + end subroutine interp_vel + + + !> Calculate the deviatoric part of the strain rate tensor from U/V/W + !> 1: du/dx-div/3 + !> 2: dv/dy-div/3 + !> 3: dw/dz-div/3 + !> 4: (du/dy+dv/dx)/2 + !> 5: (dv/dz+dw/dy)/2 + !> 6: (dw/dx+du/dz)/2 + subroutine get_strainrate(this,SR) + use messager, only: die + implicit none + class(incomp), intent(inout) :: this + real(WP), dimension(1:,this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(out) :: SR !< Needs to be (1:6,imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + real(WP), dimension(:,:,:), allocatable :: dudy,dudz,dvdx,dvdz,dwdx,dwdy + real(WP) :: div + integer :: i,j,k + + ! Check SR's first dimension + if (size(SR,dim=1).ne.6) call die('[incomp get_strainrate] SR should be of size (1:6,imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_)') + + ! Compute dudx, dvdy, and dwdz first + do k=this%cfg%kmin_,this%cfg%kmax_ + do j=this%cfg%jmin_,this%cfg%jmax_ + do i=this%cfg%imin_,this%cfg%imax_ + SR(1,i,j,k)=sum(this%grdu_x(:,i,j,k)*this%U(i:i+1,j,k)) + SR(2,i,j,k)=sum(this%grdv_y(:,i,j,k)*this%V(i,j:j+1,k)) + SR(3,i,j,k)=sum(this%grdw_z(:,i,j,k)*this%W(i,j,k:k+1)) + div=sum(SR(1:3,i,j,k))/3.0_WP + SR(1,i,j,k)=SR(1,i,j,k)-div + SR(2,i,j,k)=SR(2,i,j,k)-div + SR(3,i,j,k)=SR(3,i,j,k)-div + end do + end do + end do + + ! Allocate velocity gradient components + allocate(dudy(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + allocate(dudz(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + allocate(dvdx(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + allocate(dvdz(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + allocate(dwdx(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + allocate(dwdy(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + + ! Calculate components of the velocity gradient at their natural locations with an extra cell for interpolation + do k=this%cfg%kmin_,this%cfg%kmax_+1 + do j=this%cfg%jmin_,this%cfg%jmax_+1 + do i=this%cfg%imin_,this%cfg%imax_+1 + dudy(i,j,k)=sum(this%grdu_y(:,i,j,k)*this%U(i,j-1:j,k)) + dudz(i,j,k)=sum(this%grdu_z(:,i,j,k)*this%U(i,j,k-1:k)) + dvdx(i,j,k)=sum(this%grdv_x(:,i,j,k)*this%V(i-1:i,j,k)) + dvdz(i,j,k)=sum(this%grdv_z(:,i,j,k)*this%V(i,j,k-1:k)) + dwdx(i,j,k)=sum(this%grdw_x(:,i,j,k)*this%W(i-1:i,j,k)) + dwdy(i,j,k)=sum(this%grdw_y(:,i,j,k)*this%W(i,j-1:j,k)) + end do + end do + end do + + ! Interpolate off-diagonal components of the velocity gradient to the cell center and store strain rate + do k=this%cfg%kmin_,this%cfg%kmax_ + do j=this%cfg%jmin_,this%cfg%jmax_ + do i=this%cfg%imin_,this%cfg%imax_ + SR(4,i,j,k)=0.125_WP*(sum(dudy(i:i+1,j:j+1,k ))+sum(dvdx(i:i+1,j:j+1,k ))) + SR(5,i,j,k)=0.125_WP*(sum(dvdz(i ,j:j+1,k:k+1))+sum(dwdy(i ,j:j+1,k:k+1))) + SR(6,i,j,k)=0.125_WP*(sum(dwdx(i:i+1,j ,k:k+1))+sum(dudz(i:i+1,j ,k:k+1))) + end do + end do + end do + + ! Apply a Neumann condition in non-periodic directions + if (.not.this%cfg%xper) then + if (this%cfg%iproc.eq.1) SR(:,this%cfg%imin-1,:,:)=SR(:,this%cfg%imin,:,:) + if (this%cfg%iproc.eq.this%cfg%npx) SR(:,this%cfg%imax+1,:,:)=SR(:,this%cfg%imax,:,:) + end if + if (.not.this%cfg%yper) then + if (this%cfg%jproc.eq.1) SR(:,:,this%cfg%jmin-1,:)=SR(:,:,this%cfg%jmin,:) + if (this%cfg%jproc.eq.this%cfg%npy) SR(:,:,this%cfg%jmax+1,:)=SR(:,:,this%cfg%jmax,:) + end if + if (.not.this%cfg%zper) then + if (this%cfg%kproc.eq.1) SR(:,:,:,this%cfg%kmin-1)=SR(:,:,:,this%cfg%kmin) + if (this%cfg%kproc.eq.this%cfg%npz) SR(:,:,:,this%cfg%kmax+1)=SR(:,:,:,this%cfg%kmax) + end if + + ! Ensure zero in walls + do k=this%cfg%kmino_,this%cfg%kmaxo_ + do j=this%cfg%jmino_,this%cfg%jmaxo_ + do i=this%cfg%imino_,this%cfg%imaxo_ + if (this%mask(i,j,k).eq.1) SR(:,i,j,k)=0.0_WP + end do + end do + end do + + ! Sync it + call this%cfg%sync(SR) + + ! Deallocate velocity gradient storage + deallocate(dudy,dudz,dvdx,dvdz,dwdx,dwdy) + + end subroutine get_strainrate + + + !> Calculate the velocity gradient tensor from U/V/W + !> Note that gradu(i,j)=duj/dxi + subroutine get_gradu(this,gradu) + use messager, only: die + implicit none + class(incomp), intent(inout) :: this + real(WP), dimension(1:,1:,this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(out) :: gradu !< Needs to be (1:3,1:3,imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + integer :: i,j,k + real(WP), dimension(:,:,:), allocatable :: dudy,dudz,dvdx,dvdz,dwdx,dwdy + + ! Check gradu's first two dimensions + if (size(gradu,dim=1).ne.3.or.size(gradu,dim=2).ne.3) call die('[incomp get_gradu] gradu should be of size (1:3,1:3,imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_)') + + ! Compute dudx, dvdy, and dwdz first + do k=this%cfg%kmin_,this%cfg%kmax_ + do j=this%cfg%jmin_,this%cfg%jmax_ + do i=this%cfg%imin_,this%cfg%imax_ + gradu(1,1,i,j,k)=sum(this%grdu_x(:,i,j,k)*this%U(i:i+1,j,k)) + gradu(2,2,i,j,k)=sum(this%grdv_y(:,i,j,k)*this%V(i,j:j+1,k)) + gradu(3,3,i,j,k)=sum(this%grdw_z(:,i,j,k)*this%W(i,j,k:k+1)) + end do + end do + end do + + ! Allocate velocity gradient components + allocate(dudy(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + allocate(dudz(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + allocate(dvdx(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + allocate(dvdz(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + allocate(dwdx(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + allocate(dwdy(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + + ! Calculate components of the velocity gradient at their natural locations with an extra cell for interpolation + do k=this%cfg%kmin_,this%cfg%kmax_+1 + do j=this%cfg%jmin_,this%cfg%jmax_+1 + do i=this%cfg%imin_,this%cfg%imax_+1 + dudy(i,j,k)=sum(this%grdu_y(:,i,j,k)*this%U(i,j-1:j,k)) + dudz(i,j,k)=sum(this%grdu_z(:,i,j,k)*this%U(i,j,k-1:k)) + dvdx(i,j,k)=sum(this%grdv_x(:,i,j,k)*this%V(i-1:i,j,k)) + dvdz(i,j,k)=sum(this%grdv_z(:,i,j,k)*this%V(i,j,k-1:k)) + dwdx(i,j,k)=sum(this%grdw_x(:,i,j,k)*this%W(i-1:i,j,k)) + dwdy(i,j,k)=sum(this%grdw_y(:,i,j,k)*this%W(i,j-1:j,k)) + end do + end do + end do + + ! Interpolate off-diagonal components of the velocity gradient to the cell center + do k=this%cfg%kmin_,this%cfg%kmax_ + do j=this%cfg%jmin_,this%cfg%jmax_ + do i=this%cfg%imin_,this%cfg%imax_ + gradu(2,1,i,j,k)=0.25_WP*sum(dudy(i:i+1,j:j+1,k)) + gradu(3,1,i,j,k)=0.25_WP*sum(dudz(i:i+1,j,k:k+1)) + gradu(1,2,i,j,k)=0.25_WP*sum(dvdx(i:i+1,j:j+1,k)) + gradu(3,2,i,j,k)=0.25_WP*sum(dvdz(i,j:j+1,k:k+1)) + gradu(1,3,i,j,k)=0.25_WP*sum(dwdx(i:i+1,j,k:k+1)) + gradu(2,3,i,j,k)=0.25_WP*sum(dwdy(i,j:j+1,k:k+1)) + end do + end do + end do + + ! Apply a Neumann condition in non-periodic directions + if (.not.this%cfg%xper) then + if (this%cfg%iproc.eq.1) gradu(:,:,this%cfg%imin-1,:,:)=gradu(:,:,this%cfg%imin,:,:) + if (this%cfg%iproc.eq.this%cfg%npx) gradu(:,:,this%cfg%imax+1,:,:)=gradu(:,:,this%cfg%imax,:,:) + end if + if (.not.this%cfg%yper) then + if (this%cfg%jproc.eq.1) gradu(:,:,:,this%cfg%jmin-1,:)=gradu(:,:,:,this%cfg%jmin,:) + if (this%cfg%jproc.eq.this%cfg%npy) gradu(:,:,:,this%cfg%jmax+1,:)=gradu(:,:,:,this%cfg%jmax,:) + end if + if (.not.this%cfg%zper) then + if (this%cfg%kproc.eq.1) gradu(:,:,:,:,this%cfg%kmin-1)=gradu(:,:,:,:,this%cfg%kmin) + if (this%cfg%kproc.eq.this%cfg%npz) gradu(:,:,:,:,this%cfg%kmax+1)=gradu(:,:,:,:,this%cfg%kmax) + end if + + ! Ensure zero in walls + do k=this%cfg%kmino_,this%cfg%kmaxo_ + do j=this%cfg%jmino_,this%cfg%jmaxo_ + do i=this%cfg%imino_,this%cfg%imaxo_ + if (this%mask(i,j,k).eq.1) gradu(:,:,i,j,k)=0.0_WP + end do + end do + end do + + ! Sync it + call this%cfg%sync(gradu) + + ! Deallocate velocity gradient storage + deallocate(dudy,dudz,dvdx,dvdz,dwdx,dwdy) + + end subroutine get_gradu + + + !> Calculate vorticity vector + subroutine get_vorticity(this,vort) + use messager, only: die + implicit none + class(incomp), intent(inout) :: this + real(WP), dimension(1:,this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(out) :: vort !< Needs to be (1:3,imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + integer :: i,j,k + real(WP), dimension(:,:,:), allocatable :: dudy,dudz,dvdx,dvdz,dwdx,dwdy + + ! Check vort's first two dimensions + if (size(vort,dim=1).ne.3) call die('[incomp get_vorticity] vort should be of size (1:3,imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_)') + + ! Allocate velocity gradient components + allocate(dudy(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + allocate(dudz(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + allocate(dvdx(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + allocate(dvdz(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + allocate(dwdx(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + allocate(dwdy(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + + ! Calculate components of the velocity gradient at their natural locations with an extra cell for interpolation + do k=this%cfg%kmin_,this%cfg%kmax_+1 + do j=this%cfg%jmin_,this%cfg%jmax_+1 + do i=this%cfg%imin_,this%cfg%imax_+1 + dudy(i,j,k)=sum(this%grdu_y(:,i,j,k)*this%U(i,j-1:j,k)) + dudz(i,j,k)=sum(this%grdu_z(:,i,j,k)*this%U(i,j,k-1:k)) + dvdx(i,j,k)=sum(this%grdv_x(:,i,j,k)*this%V(i-1:i,j,k)) + dvdz(i,j,k)=sum(this%grdv_z(:,i,j,k)*this%V(i,j,k-1:k)) + dwdx(i,j,k)=sum(this%grdw_x(:,i,j,k)*this%W(i-1:i,j,k)) + dwdy(i,j,k)=sum(this%grdw_y(:,i,j,k)*this%W(i,j-1:j,k)) + end do + end do + end do + + ! Interpolate off-diagonal components of the velocity gradient to the cell center + do k=this%cfg%kmin_,this%cfg%kmax_ + do j=this%cfg%jmin_,this%cfg%jmax_ + do i=this%cfg%imin_,this%cfg%imax_ + vort(1,i,j,k)=0.25_WP*(sum(dwdy(i,j:j+1,k:k+1))-sum(dvdz(i,j:j+1,k:k+1))) + vort(2,i,j,k)=0.25_WP*(sum(dudz(i:i+1,j,k:k+1))-sum(dwdx(i:i+1,j,k:k+1))) + vort(3,i,j,k)=0.25_WP*(sum(dvdx(i:i+1,j:j+1,k))-sum(dudy(i:i+1,j:j+1,k))) + end do + end do + end do + + ! Apply a Neumann condition in non-periodic directions + if (.not.this%cfg%xper) then + if (this%cfg%iproc.eq.1) vort(:,this%cfg%imin-1,:,:)=vort(:,this%cfg%imin,:,:) + if (this%cfg%iproc.eq.this%cfg%npx) vort(:,this%cfg%imax+1,:,:)=vort(:,this%cfg%imax,:,:) + end if + if (.not.this%cfg%yper) then + if (this%cfg%jproc.eq.1) vort(:,:,this%cfg%jmin-1,:)=vort(:,:,this%cfg%jmin,:) + if (this%cfg%jproc.eq.this%cfg%npy) vort(:,:,this%cfg%jmax+1,:)=vort(:,:,this%cfg%jmax,:) + end if + if (.not.this%cfg%zper) then + if (this%cfg%kproc.eq.1) vort(:,:,:,this%cfg%kmin-1)=vort(:,:,:,this%cfg%kmin) + if (this%cfg%kproc.eq.this%cfg%npz) vort(:,:,:,this%cfg%kmax+1)=vort(:,:,:,this%cfg%kmax) + end if + + ! Ensure zero in walls + do k=this%cfg%kmino_,this%cfg%kmaxo_ + do j=this%cfg%jmino_,this%cfg%jmaxo_ + do i=this%cfg%imino_,this%cfg%imaxo_ + if (this%mask(i,j,k).eq.1) vort(:,i,j,k)=0.0_WP + end do + end do + end do + + ! Sync it + call this%cfg%sync(vort) + + ! Deallocate velocity gradient storage + deallocate(dudy,dudz,dvdx,dvdz,dwdx,dwdy) + + end subroutine get_vorticity + + + !> Calculate the CFL + subroutine get_cfl(this,dt,cflc,cfl) + use mpi_f08, only: MPI_ALLREDUCE,MPI_MAX + use parallel, only: MPI_REAL_WP + implicit none + class(incomp), intent(inout) :: this + real(WP), intent(in) :: dt + real(WP), intent(out) :: cflc + real(WP), optional :: cfl + integer :: i,j,k,ierr + real(WP) :: my_CFLc_x,my_CFLc_y,my_CFLc_z,my_CFLv_x,my_CFLv_y,my_CFLv_z + + ! Set the CFLs to zero + my_CFLc_x=0.0_WP; my_CFLc_y=0.0_WP; my_CFLc_z=0.0_WP + my_CFLv_x=0.0_WP; my_CFLv_y=0.0_WP; my_CFLv_z=0.0_WP + do k=this%cfg%kmin_,this%cfg%kmax_ + do j=this%cfg%jmin_,this%cfg%jmax_ + do i=this%cfg%imin_,this%cfg%imax_ + my_CFLc_x=max(my_CFLc_x,abs(this%U(i,j,k))*this%cfg%dxmi(i)) + my_CFLc_y=max(my_CFLc_y,abs(this%V(i,j,k))*this%cfg%dymi(j)) + my_CFLc_z=max(my_CFLc_z,abs(this%W(i,j,k))*this%cfg%dzmi(k)) + my_CFLv_x=max(my_CFLv_x,4.0_WP*this%visc(i,j,k)*this%cfg%dxi(i)**2/this%rho) + my_CFLv_y=max(my_CFLv_y,4.0_WP*this%visc(i,j,k)*this%cfg%dyi(j)**2/this%rho) + my_CFLv_z=max(my_CFLv_z,4.0_WP*this%visc(i,j,k)*this%cfg%dzi(k)**2/this%rho) + end do + end do + end do + my_CFLc_x=my_CFLc_x*dt; my_CFLc_y=my_CFLc_y*dt; my_CFLc_z=my_CFLc_z*dt + my_CFLv_x=my_CFLv_x*dt; my_CFLv_y=my_CFLv_y*dt; my_CFLv_z=my_CFLv_z*dt + + ! Get the parallel max + call MPI_ALLREDUCE(my_CFLc_x,this%CFLc_x,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + call MPI_ALLREDUCE(my_CFLc_y,this%CFLc_y,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + call MPI_ALLREDUCE(my_CFLc_z,this%CFLc_z,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + call MPI_ALLREDUCE(my_CFLv_x,this%CFLv_x,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + call MPI_ALLREDUCE(my_CFLv_y,this%CFLv_y,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + call MPI_ALLREDUCE(my_CFLv_z,this%CFLv_z,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + + ! Return the maximum convective CFL + cflc=max(this%CFLc_x,this%CFLc_y,this%CFLc_z) + + ! If asked for, also return the maximum overall CFL + if (present(CFL)) cfl=max(this%CFLc_x,this%CFLc_y,this%CFLc_z,this%CFLv_x,this%CFLv_y,this%CFLv_z) + + end subroutine get_cfl + + + !> Calculate the max of our fields + subroutine get_max(this) + use mpi_f08, only: MPI_ALLREDUCE,MPI_MAX + use parallel, only: MPI_REAL_WP + implicit none + class(incomp), intent(inout) :: this + integer :: i,j,k,ierr + real(WP) :: my_Umax,my_Vmax,my_Wmax,my_Pmax,my_divmax + + ! Set all to zero + my_Umax=0.0_WP; my_Vmax=0.0_WP; my_Wmax=0.0_WP; my_Pmax=0.0_WP; my_divmax=0.0_WP + do k=this%cfg%kmin_,this%cfg%kmax_ + do j=this%cfg%jmin_,this%cfg%jmax_ + do i=this%cfg%imin_,this%cfg%imax_ + my_Umax =max(my_Umax ,abs(this%U(i,j,k) )) + my_Vmax =max(my_Vmax ,abs(this%V(i,j,k) )) + my_Wmax =max(my_Wmax ,abs(this%W(i,j,k) )) + if (this%cfg%VF(i,j,k).gt.0.0_WP) my_Pmax =max(my_Pmax ,abs(this%P(i,j,k) )) + if (this%cfg%VF(i,j,k).gt.0.0_WP) my_divmax=max(my_divmax,abs(this%div(i,j,k))) + end do + end do + end do + + ! Get the parallel max + call MPI_ALLREDUCE(my_Umax ,this%Umax ,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + call MPI_ALLREDUCE(my_Vmax ,this%Vmax ,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + call MPI_ALLREDUCE(my_Wmax ,this%Wmax ,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + call MPI_ALLREDUCE(my_Pmax ,this%Pmax ,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + call MPI_ALLREDUCE(my_divmax,this%divmax,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + + end subroutine get_max + + + !> Compute MFR through all bcs + subroutine get_mfr(this) + use mpi_f08, only: MPI_SUM,MPI_ALLREDUCE + use parallel, only: MPI_REAL_WP + implicit none + class(incomp), intent(inout) :: this + integer :: i,j,k,n,ibc,ierr + type(bcond), pointer :: my_bc + real(WP), dimension(:), allocatable :: my_mfr,my_area + real(WP), dimension(:), allocatable :: canCorrect + + ! Ensure this%mfr is of proper size + if (.not.allocated(this%mfr)) then + allocate(this%mfr(this%nbc)) + else + if (size(this%mfr).ne.this%nbc) then + deallocate(this%mfr); allocate(this%mfr(this%nbc)) + end if + end if + + ! Ensure this%area is of proper size + if (.not.allocated(this%area)) then + allocate(this%area(this%nbc)) + else + if (size(this%area).ne.this%nbc) then + deallocate(this%area); allocate(this%area(this%nbc)) + end if + end if + + ! Allocate temp array for communication + allocate(my_mfr(this%nbc)) + allocate(my_area(this%nbc)) + allocate(canCorrect(this%nbc)) + + ! Traverse bcond list and integrate local outgoing MFR + my_bc=>this%first_bc; ibc=1 + do while (associated(my_bc)) + + ! Set zero local MFR and area + my_mfr(ibc)=0.0_WP + my_area(ibc)=0.0_WP + if (my_bc%canCorrect) then + canCorrect(ibc)=1.0_WP + else + canCorrect(ibc)=0.0_WP + end if + + ! Only processes inside the bcond have a non-zero MFR + if (my_bc%itr%amIn) then + + ! Implement based on bcond face and dir, loop over interior only + select case (my_bc%face) + case ('x') + do n=1,my_bc%itr%n_ + i=my_bc%itr%map(1,n); j=my_bc%itr%map(2,n); k=my_bc%itr%map(3,n) + my_mfr(ibc)=my_mfr(ibc)+my_bc%rdir*this%rho*this%U(i,j,k)*this%cfg%dy(j)*this%cfg%dz(k) + my_area(ibc)=my_area(ibc)+this%cfg%dy(j)*this%cfg%dz(k) + end do + case ('y') + do n=1,my_bc%itr%n_ + i=my_bc%itr%map(1,n); j=my_bc%itr%map(2,n); k=my_bc%itr%map(3,n) + my_mfr(ibc)=my_mfr(ibc)+my_bc%rdir*this%rho*this%V(i,j,k)*this%cfg%dz(k)*this%cfg%dx(i) + my_area(ibc)=my_area(ibc)+this%cfg%dz(k)*this%cfg%dx(i) + end do + case ('z') + do n=1,my_bc%itr%n_ + i=my_bc%itr%map(1,n); j=my_bc%itr%map(2,n); k=my_bc%itr%map(3,n) + my_mfr(ibc)=my_mfr(ibc)+my_bc%rdir*this%rho*this%W(i,j,k)*this%cfg%dx(i)*this%cfg%dy(j) + my_area(ibc)=my_area(ibc)+this%cfg%dx(i)*this%cfg%dy(j) + end do + end select + + end if + + ! Move on to the next bcond + my_bc=>my_bc%next; ibc=ibc+1 + + end do + + ! Sum up all values + call MPI_ALLREDUCE(my_mfr ,this%mfr ,this%nbc,MPI_REAL_WP,MPI_SUM,this%cfg%comm,ierr) + call MPI_ALLREDUCE(my_area,this%area,this%nbc,MPI_REAL_WP,MPI_SUM,this%cfg%comm,ierr) + + ! Compute the correctable area + this%correctable_area=sum(this%area*canCorrect) + + ! Deallocate temp array + deallocate(my_mfr,my_area,canCorrect) + + end subroutine get_mfr + + + !> Correct MFR through correctable bconds + subroutine correct_mfr(this,src) + use mpi_f08, only: MPI_SUM + implicit none + class(incomp), intent(inout) :: this + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), optional :: src !< Mass source term + real(WP) :: mfr_error,vel_correction,int + integer :: i,j,k,n + type(bcond), pointer :: my_bc + + ! Evaluate MFR mismatch and velocity correction + call this%get_mfr() + mfr_error=sum(this%mfr) + if (present(src)) then + ! Also account for provided source term + call this%cfg%integrate_without_VF(src,int) + mfr_error=mfr_error-int + end if + if (abs(mfr_error).lt.10.0_WP*epsilon(1.0_WP).or.abs(this%correctable_area).lt.10.0_WP*epsilon(1.0_WP)) return + vel_correction=-mfr_error/(this%rho*this%correctable_area) + + ! Traverse bcond list and correct bcond MFR + my_bc=>this%first_bc + do while (associated(my_bc)) + + ! Only processes inside correctable bcond need to work + if (my_bc%itr%amIn.and.my_bc%canCorrect) then + + ! Implement based on bcond direction, loop over all cell + select case (my_bc%face) + case ('x') + do n=1,my_bc%itr%n_ + i=my_bc%itr%map(1,n); j=my_bc%itr%map(2,n); k=my_bc%itr%map(3,n) + this%U(i,j,k)=this%U(i,j,k)+my_bc%rdir*vel_correction + end do + case ('y') + do n=1,my_bc%itr%n_ + i=my_bc%itr%map(1,n); j=my_bc%itr%map(2,n); k=my_bc%itr%map(3,n) + this%V(i,j,k)=this%V(i,j,k)+my_bc%rdir*vel_correction + end do + case ('z') + do n=1,my_bc%itr%n_ + i=my_bc%itr%map(1,n); j=my_bc%itr%map(2,n); k=my_bc%itr%map(3,n) + this%W(i,j,k)=this%W(i,j,k)+my_bc%rdir*vel_correction + end do + end select + + end if + + ! Move on to the next bcond + my_bc=>my_bc%next + + end do + + ! Sync full fields + call this%cfg%sync(this%U) + call this%cfg%sync(this%V) + call this%cfg%sync(this%W) + + end subroutine correct_mfr + + + !> Shift pressure to ensure zero average + subroutine shift_p(this,pressure) + implicit none + class(incomp), intent(in) :: this + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(inout) :: pressure !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + real(WP) :: pressure_tot + integer :: i,j,k + + ! Compute volume-averaged pressure + call this%cfg%integrate(A=pressure,integral=pressure_tot); pressure_tot=pressure_tot/this%cfg%fluid_vol + + ! Shift the pressure + do k=this%cfg%kmin_,this%cfg%kmax_ + do j=this%cfg%jmin_,this%cfg%jmax_ + do i=this%cfg%imin_,this%cfg%imax_ + if (this%cfg%VF(i,j,k).gt.0.0_WP) pressure(i,j,k)=pressure(i,j,k)-pressure_tot + end do + end do + end do + call this%cfg%sync(pressure) + + end subroutine shift_p + + + !> Solve for implicit velocity residual + subroutine solve_implicit(this,dt,resU,resV,resW) + implicit none + class(incomp), intent(inout) :: this + real(WP), intent(in) :: dt + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(inout) :: resU !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(inout) :: resV !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(inout) :: resW !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + integer :: i,j,k + real(WP) :: rhoUp,rhoUm,rhoVp,rhoVm,rhoWp,rhoWm + + ! If no implicit solver available, just divide by density and return + if (.not.associated(this%implicit)) then + resU=resU/this%rho + resV=resV/this%rho + resW=resW/this%rho + call this%cfg%sync(resU) + call this%cfg%sync(resV) + call this%cfg%sync(resW) + return + end if + + ! Solve implicit U problem + this%implicit%opr(1,:,:,:)=this%rho; this%implicit%opr(2:,:,:,:)=0.0_WP + do k=this%cfg%kmin_,this%cfg%kmax_ + do j=this%cfg%jmin_,this%cfg%jmax_ + do i=this%cfg%imin_,this%cfg%imax_ + rhoUp=this%rho*sum(this%itpu_x(:,i ,j,k)*this%U(i :i+1,j,k))*2.0_WP + rhoUm=this%rho*sum(this%itpu_x(:,i-1,j,k)*this%U(i-1:i ,j,k))*2.0_WP + rhoVp=this%rho*sum(this%itpv_x(:,i,j+1,k)*this%V(i-1:i,j+1,k)) + rhoVm=this%rho*sum(this%itpv_x(:,i,j ,k)*this%V(i-1:i,j ,k)) + rhoWp=this%rho*sum(this%itpw_x(:,i,j,k+1)*this%W(i-1:i,j,k+1)) + rhoWm=this%rho*sum(this%itpw_x(:,i,j,k )*this%W(i-1:i,j,k )) + this%implicit%opr(1,i,j,k)=this%implicit%opr(1,i,j,k)+0.5_WP*dt*(this%divu_x( 0,i,j,k)*this%itpu_x( 0,i ,j,k)*rhoUp+& + & this%divu_x(-1,i,j,k)*this%itpu_x(+1,i-1,j,k)*rhoUm+& + & this%divu_y(+1,i,j,k)*this%itpu_y(-1,i,j+1,k)*rhoVp+& + & this%divu_y( 0,i,j,k)*this%itpu_y( 0,i,j ,k)*rhoVm+& + & this%divu_z(+1,i,j,k)*this%itpu_z(-1,i,j,k+1)*rhoWp+& + & this%divu_z( 0,i,j,k)*this%itpu_z( 0,i,j,k )*rhoWm) + this%implicit%opr(2,i,j,k)=this%implicit%opr(2,i,j,k)+0.5_WP*dt*(this%divu_x( 0,i,j,k)*this%itpu_x(+1,i ,j,k)*rhoUp) + this%implicit%opr(3,i,j,k)=this%implicit%opr(3,i,j,k)+0.5_WP*dt*(this%divu_x(-1,i,j,k)*this%itpu_x( 0,i-1,j,k)*rhoUm) + this%implicit%opr(4,i,j,k)=this%implicit%opr(4,i,j,k)+0.5_WP*dt*(this%divu_y(+1,i,j,k)*this%itpu_y( 0,i,j+1,k)*rhoVp) + this%implicit%opr(5,i,j,k)=this%implicit%opr(5,i,j,k)+0.5_WP*dt*(this%divu_y( 0,i,j,k)*this%itpu_y(-1,i,j ,k)*rhoVm) + this%implicit%opr(6,i,j,k)=this%implicit%opr(6,i,j,k)+0.5_WP*dt*(this%divu_z(+1,i,j,k)*this%itpu_z( 0,i,j,k+1)*rhoWp) + this%implicit%opr(7,i,j,k)=this%implicit%opr(7,i,j,k)+0.5_WP*dt*(this%divu_z( 0,i,j,k)*this%itpu_z(-1,i,j,k )*rhoWm) + end do + end do + end do + do k=this%cfg%kmin_,this%cfg%kmax_ + do j=this%cfg%jmin_,this%cfg%jmax_ + do i=this%cfg%imin_,this%cfg%imax_ + this%implicit%opr(1,i,j,k)=this%implicit%opr(1,i,j,k)-0.5_WP*dt*(this%divu_x( 0,i,j,k)*4.0_WP/3.0_WP* this%visc(i ,j,k) *this%grdu_x( 0,i ,j,k)+& + & this%divu_x(-1,i,j,k)*4.0_WP/3.0_WP* this%visc(i-1,j,k) *this%grdu_x(+1,i-1,j,k)+& + & this%divu_y(+1,i,j,k)*sum(this%itp_xy(:,:,i,j+1,k)*this%visc(i-1:i,j:j+1,k))*this%grdu_y(-1,i,j+1,k)+& + & this%divu_y( 0,i,j,k)*sum(this%itp_xy(:,:,i,j ,k)*this%visc(i-1:i,j-1:j,k))*this%grdu_y( 0,i,j ,k)+& + & this%divu_z(+1,i,j,k)*sum(this%itp_xz(:,:,i,j,k+1)*this%visc(i-1:i,j,k:k+1))*this%grdu_z(-1,i,j,k+1)+& + & this%divu_z( 0,i,j,k)*sum(this%itp_xz(:,:,i,j,k )*this%visc(i-1:i,j,k-1:k))*this%grdu_z( 0,i,j,k )) + this%implicit%opr(2,i,j,k)=this%implicit%opr(2,i,j,k)-0.5_WP*dt*(this%divu_x( 0,i,j,k)*4.0_WP/3.0_WP* this%visc(i ,j,k) *this%grdu_x(+1,i ,j,k)) + this%implicit%opr(3,i,j,k)=this%implicit%opr(3,i,j,k)-0.5_WP*dt*(this%divu_x(-1,i,j,k)*4.0_WP/3.0_WP* this%visc(i-1,j,k) *this%grdu_x( 0,i-1,j,k)) + this%implicit%opr(4,i,j,k)=this%implicit%opr(4,i,j,k)-0.5_WP*dt*(this%divu_y(+1,i,j,k)*sum(this%itp_xy(:,:,i,j+1,k)*this%visc(i-1:i,j:j+1,k))*this%grdu_y( 0,i,j+1,k)) + this%implicit%opr(5,i,j,k)=this%implicit%opr(5,i,j,k)-0.5_WP*dt*(this%divu_y( 0,i,j,k)*sum(this%itp_xy(:,:,i,j ,k)*this%visc(i-1:i,j-1:j,k))*this%grdu_y(-1,i,j ,k)) + this%implicit%opr(6,i,j,k)=this%implicit%opr(6,i,j,k)-0.5_WP*dt*(this%divu_z(+1,i,j,k)*sum(this%itp_xz(:,:,i,j,k+1)*this%visc(i-1:i,j,k:k+1))*this%grdu_z( 0,i,j,k+1)) + this%implicit%opr(7,i,j,k)=this%implicit%opr(7,i,j,k)-0.5_WP*dt*(this%divu_z( 0,i,j,k)*sum(this%itp_xz(:,:,i,j,k )*this%visc(i-1:i,j,k-1:k))*this%grdu_z(-1,i,j,k )) + end do + end do + end do + call this%implicit%setup() + this%implicit%rhs=resU + this%implicit%sol=0.0_WP + call this%implicit%solve() + resU=this%implicit%sol + + ! Solve implicit V problem + this%implicit%opr(1,:,:,:)=this%rho; this%implicit%opr(2:,:,:,:)=0.0_WP + do k=this%cfg%kmin_,this%cfg%kmax_ + do j=this%cfg%jmin_,this%cfg%jmax_ + do i=this%cfg%imin_,this%cfg%imax_ + rhoUp=this%rho*sum(this%itpu_y(:,i+1,j,k)*this%U(i+1,j-1:j,k)) + rhoUm=this%rho*sum(this%itpu_y(:,i ,j,k)*this%U(i ,j-1:j,k)) + rhoVp=this%rho*sum(this%itpv_y(:,i,j ,k)*this%V(i,j :j+1,k))*2.0_WP + rhoVm=this%rho*sum(this%itpv_y(:,i,j-1,k)*this%V(i,j-1:j ,k))*2.0_WP + rhoWp=this%rho*sum(this%itpw_y(:,i,j,k+1)*this%W(i,j-1:j,k+1)) + rhoWm=this%rho*sum(this%itpw_y(:,i,j,k )*this%W(i,j-1:j,k )) + this%implicit%opr(1,i,j,k)=this%implicit%opr(1,i,j,k)+0.5_WP*dt*(this%divv_x(+1,i,j,k)*this%itpv_x(-1,i+1,j,k)*rhoUp+& + & this%divv_x( 0,i,j,k)*this%itpv_x( 0,i ,j,k)*rhoUm+& + & this%divv_y( 0,i,j,k)*this%itpv_y( 0,i,j ,k)*rhoVp+& + & this%divv_y(-1,i,j,k)*this%itpv_y(+1,i,j-1,k)*rhoVm+& + & this%divv_z(+1,i,j,k)*this%itpv_z(-1,i,j,k+1)*rhoWp+& + & this%divv_z( 0,i,j,k)*this%itpv_z( 0,i,j,k )*rhoWm) + this%implicit%opr(2,i,j,k)=this%implicit%opr(2,i,j,k)+0.5_WP*dt*(this%divv_x(+1,i,j,k)*this%itpv_x( 0,i+1,j,k)*rhoUp) + this%implicit%opr(3,i,j,k)=this%implicit%opr(3,i,j,k)+0.5_WP*dt*(this%divv_x( 0,i,j,k)*this%itpv_x(-1,i ,j,k)*rhoUm) + this%implicit%opr(4,i,j,k)=this%implicit%opr(4,i,j,k)+0.5_WP*dt*(this%divv_y( 0,i,j,k)*this%itpv_y(+1,i,j ,k)*rhoVp) + this%implicit%opr(5,i,j,k)=this%implicit%opr(5,i,j,k)+0.5_WP*dt*(this%divv_y(-1,i,j,k)*this%itpv_y( 0,i,j-1,k)*rhoVm) + this%implicit%opr(6,i,j,k)=this%implicit%opr(6,i,j,k)+0.5_WP*dt*(this%divv_z(+1,i,j,k)*this%itpv_z( 0,i,j,k+1)*rhoWp) + this%implicit%opr(7,i,j,k)=this%implicit%opr(7,i,j,k)+0.5_WP*dt*(this%divv_z( 0,i,j,k)*this%itpv_z(-1,i,j,k )*rhoWm) + end do + end do + end do + do k=this%cfg%kmin_,this%cfg%kmax_ + do j=this%cfg%jmin_,this%cfg%jmax_ + do i=this%cfg%imin_,this%cfg%imax_ + this%implicit%opr(1,i,j,k)=this%implicit%opr(1,i,j,k)-0.5_WP*dt*(this%divv_x(+1,i,j,k)*sum(this%itp_xy(:,:,i+1,j,k)*this%visc(i:i+1,j-1:j,k))*this%grdv_x(-1,i+1,j,k)+& + & this%divv_x( 0,i,j,k)*sum(this%itp_xy(:,:,i ,j,k)*this%visc(i-1:i,j-1:j,k))*this%grdv_x( 0,i ,j,k)+& + & this%divv_y( 0,i,j,k)*4.0_WP/3.0_WP* this%visc(i,j ,k) *this%grdv_y( 0,i,j ,k)+& + & this%divv_y(-1,i,j,k)*4.0_WP/3.0_WP* this%visc(i,j-1,k) *this%grdv_y(+1,i,j-1,k)+& + & this%divv_z(+1,i,j,k)*sum(this%itp_yz(:,:,i,j,k+1)*this%visc(i,j-1:j,k:k+1))*this%grdv_z(-1,i,j,k+1)+& + & this%divv_z( 0,i,j,k)*sum(this%itp_yz(:,:,i,j,k )*this%visc(i,j-1:j,k-1:k))*this%grdv_z( 0,i,j,k )) + this%implicit%opr(2,i,j,k)=this%implicit%opr(2,i,j,k)-0.5_WP*dt*(this%divv_x(+1,i,j,k)*sum(this%itp_xy(:,:,i+1,j,k)*this%visc(i:i+1,j-1:j,k))*this%grdv_x( 0,i+1,j,k)) + this%implicit%opr(3,i,j,k)=this%implicit%opr(3,i,j,k)-0.5_WP*dt*(this%divv_x( 0,i,j,k)*sum(this%itp_xy(:,:,i ,j,k)*this%visc(i-1:i,j-1:j,k))*this%grdv_x(-1,i ,j,k)) + this%implicit%opr(4,i,j,k)=this%implicit%opr(4,i,j,k)-0.5_WP*dt*(this%divv_y( 0,i,j,k)*4.0_WP/3.0_WP* this%visc(i,j ,k) *this%grdv_y(+1,i,j ,k)) + this%implicit%opr(5,i,j,k)=this%implicit%opr(5,i,j,k)-0.5_WP*dt*(this%divv_y(-1,i,j,k)*4.0_WP/3.0_WP* this%visc(i,j-1,k) *this%grdv_y( 0,i,j-1,k)) + this%implicit%opr(6,i,j,k)=this%implicit%opr(6,i,j,k)-0.5_WP*dt*(this%divv_z(+1,i,j,k)*sum(this%itp_yz(:,:,i,j,k+1)*this%visc(i,j-1:j,k:k+1))*this%grdv_z( 0,i,j,k+1)) + this%implicit%opr(7,i,j,k)=this%implicit%opr(7,i,j,k)-0.5_WP*dt*(this%divv_z( 0,i,j,k)*sum(this%itp_yz(:,:,i,j,k )*this%visc(i,j-1:j,k-1:k))*this%grdv_z(-1,i,j,k )) + end do + end do + end do + call this%implicit%setup() + this%implicit%rhs=resV + this%implicit%sol=0.0_WP + call this%implicit%solve() + resV=this%implicit%sol + + ! Solve implicit W problem + this%implicit%opr(1,:,:,:)=this%rho; this%implicit%opr(2:,:,:,:)=0.0_WP + do k=this%cfg%kmin_,this%cfg%kmax_ + do j=this%cfg%jmin_,this%cfg%jmax_ + do i=this%cfg%imin_,this%cfg%imax_ + rhoUp=this%rho*sum(this%itpu_z(:,i+1,j,k)*this%U(i+1,j,k-1:k)) + rhoUm=this%rho*sum(this%itpu_z(:,i ,j,k)*this%U(i ,j,k-1:k)) + rhoVp=this%rho*sum(this%itpv_z(:,i,j+1,k)*this%V(i,j+1,k-1:k)) + rhoVm=this%rho*sum(this%itpv_z(:,i,j ,k)*this%V(i,j ,k-1:k)) + rhoWp=this%rho*sum(this%itpw_z(:,i,j,k )*this%W(i,j,k :k+1))*2.0_WP + rhoWm=this%rho*sum(this%itpw_z(:,i,j,k-1)*this%W(i,j,k-1:k ))*2.0_WP + this%implicit%opr(1,i,j,k)=this%implicit%opr(1,i,j,k)+0.5_WP*dt*(this%divw_x(+1,i,j,k)*this%itpw_x(-1,i+1,j,k)*rhoUp+& + & this%divw_x( 0,i,j,k)*this%itpw_x( 0,i ,j,k)*rhoUm+& + & this%divw_y(+1,i,j,k)*this%itpw_y(-1,i,j+1,k)*rhoVp+& + & this%divw_y( 0,i,j,k)*this%itpw_y( 0,i,j ,k)*rhoVm+& + & this%divw_z( 0,i,j,k)*this%itpw_z( 0,i,j,k )*rhoWp+& + & this%divw_z(-1,i,j,k)*this%itpw_z(+1,i,j,k-1)*rhoWm) + this%implicit%opr(2,i,j,k)=this%implicit%opr(2,i,j,k)+0.5_WP*dt*(this%divw_x(+1,i,j,k)*this%itpw_x( 0,i+1,j,k)*rhoUp) + this%implicit%opr(3,i,j,k)=this%implicit%opr(3,i,j,k)+0.5_WP*dt*(this%divw_x( 0,i,j,k)*this%itpw_x(-1,i ,j,k)*rhoUm) + this%implicit%opr(4,i,j,k)=this%implicit%opr(4,i,j,k)+0.5_WP*dt*(this%divw_y(+1,i,j,k)*this%itpw_y( 0,i,j+1,k)*rhoVp) + this%implicit%opr(5,i,j,k)=this%implicit%opr(5,i,j,k)+0.5_WP*dt*(this%divw_y( 0,i,j,k)*this%itpw_y(-1,i,j ,k)*rhoVm) + this%implicit%opr(6,i,j,k)=this%implicit%opr(6,i,j,k)+0.5_WP*dt*(this%divw_z( 0,i,j,k)*this%itpw_z(+1,i,j,k )*rhoWp) + this%implicit%opr(7,i,j,k)=this%implicit%opr(7,i,j,k)+0.5_WP*dt*(this%divw_z(-1,i,j,k)*this%itpw_z( 0,i,j,k-1)*rhoWm) + end do + end do + end do + do k=this%cfg%kmin_,this%cfg%kmax_ + do j=this%cfg%jmin_,this%cfg%jmax_ + do i=this%cfg%imin_,this%cfg%imax_ + this%implicit%opr(1,i,j,k)=this%implicit%opr(1,i,j,k)-0.5_WP*dt*(this%divw_x(+1,i,j,k)*sum(this%itp_xz(:,:,i+1,j,k)*this%visc(i:i+1,j,k-1:k))*this%grdw_x(-1,i+1,j,k)+& + & this%divw_x( 0,i,j,k)*sum(this%itp_xz(:,:,i ,j,k)*this%visc(i-1:i,j,k-1:k))*this%grdw_x( 0,i ,j,k)+& + & this%divw_y(+1,i,j,k)*sum(this%itp_yz(:,:,i,j+1,k)*this%visc(i,j:j+1,k-1:k))*this%grdw_y(-1,i,j+1,k)+& + & this%divw_y( 0,i,j,k)*sum(this%itp_yz(:,:,i,j ,k)*this%visc(i,j-1:j,k-1:k))*this%grdw_y( 0,i,j ,k)+& + & this%divw_z( 0,i,j,k)*4.0_WP/3.0_WP* this%visc(i,j,k ) *this%grdw_z( 0,i,j,k )+& + & this%divw_z(-1,i,j,k)*4.0_WP/3.0_WP* this%visc(i,j,k-1) *this%grdw_z(+1,i,j,k-1)) + this%implicit%opr(2,i,j,k)=this%implicit%opr(2,i,j,k)-0.5_WP*dt*(this%divw_x(+1,i,j,k)*sum(this%itp_xz(:,:,i+1,j,k)*this%visc(i:i+1,j,k-1:k))*this%grdw_x( 0,i+1,j,k)) + this%implicit%opr(3,i,j,k)=this%implicit%opr(3,i,j,k)-0.5_WP*dt*(this%divw_x( 0,i,j,k)*sum(this%itp_xz(:,:,i ,j,k)*this%visc(i-1:i,j,k-1:k))*this%grdw_x(-1,i ,j,k)) + this%implicit%opr(4,i,j,k)=this%implicit%opr(4,i,j,k)-0.5_WP*dt*(this%divw_y(+1,i,j,k)*sum(this%itp_yz(:,:,i,j+1,k)*this%visc(i,j:j+1,k-1:k))*this%grdw_y( 0,i,j+1,k)) + this%implicit%opr(5,i,j,k)=this%implicit%opr(5,i,j,k)-0.5_WP*dt*(this%divw_y( 0,i,j,k)*sum(this%itp_yz(:,:,i,j ,k)*this%visc(i,j-1:j,k-1:k))*this%grdw_y(-1,i,j ,k)) + this%implicit%opr(6,i,j,k)=this%implicit%opr(6,i,j,k)-0.5_WP*dt*(this%divw_z( 0,i,j,k)*4.0_WP/3.0_WP* this%visc(i,j,k ) *this%grdw_z(+1,i,j,k )) + this%implicit%opr(7,i,j,k)=this%implicit%opr(7,i,j,k)-0.5_WP*dt*(this%divw_z(-1,i,j,k)*4.0_WP/3.0_WP* this%visc(i,j,k-1) *this%grdw_z( 0,i,j,k-1)) + end do + end do + end do + call this%implicit%setup() + this%implicit%rhs=resW + this%implicit%sol=0.0_WP + call this%implicit%solve() + resW=this%implicit%sol + + end subroutine solve_implicit + + + !> Add gravity source term + subroutine addsrc_gravity(this,resU,resV,resW) + implicit none + class(incomp), intent(inout) :: this + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(inout) :: resU !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(inout) :: resV !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(inout) :: resW !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + integer :: i,j,k + do k=this%cfg%kmin_,this%cfg%kmax_ + do j=this%cfg%jmin_,this%cfg%jmax_ + do i=this%cfg%imin_,this%cfg%imax_ + if (this%umask(i,j,k).eq.0) resU(i,j,k)=resU(i,j,k)+this%rho*this%gravity(1) + if (this%vmask(i,j,k).eq.0) resV(i,j,k)=resV(i,j,k)+this%rho*this%gravity(2) + if (this%wmask(i,j,k).eq.0) resW(i,j,k)=resW(i,j,k)+this%rho*this%gravity(3) + end do + end do + end do + end subroutine addsrc_gravity + + + !> Print out info for incompressible flow solver + subroutine incomp_print(this) + use, intrinsic :: iso_fortran_env, only: output_unit + implicit none + class(incomp), intent(in) :: this + + ! Output + if (this%cfg%amRoot) then + write(output_unit,'("Incompressible solver [",a,"] for config [",a,"]")') trim(this%name),trim(this%cfg%name) + write(output_unit,'(" > density = ",es12.5)') this%rho + end if + + end subroutine incomp_print + + +end module incomp_class diff --git a/examples/NOSB_plate_with_hole_peridigm/src/lss_class.f90 b/examples/NOSB_plate_with_hole_peridigm/src/lss_class.f90 new file mode 100644 index 000000000..6ec20724b --- /dev/null +++ b/examples/NOSB_plate_with_hole_peridigm/src/lss_class.f90 @@ -0,0 +1,1585 @@ +!> Lagrangian solid solver object +!> Implements peridynamics equations +module lss_class + use precision, only: WP + use string, only: str_medium + use config_class, only: config + use ddadi_class, only: ddadi + use mpi_f08, only: MPI_Datatype,MPI_INTEGER8,MPI_INTEGER,MPI_DOUBLE_PRECISION + implicit none + private + + + ! Expose type/constructor/methods + public :: lss + + + !> Memory adaptation parameter + real(WP), parameter :: coeff_up=1.3_WP !< Particle array size increase factor + real(WP), parameter :: coeff_dn=0.7_WP !< Particle array size decrease factor + + + !> I/O chunk size to read at a time + integer, parameter :: part_chunk_size=1000 !< Read 1000 particles at a time before redistributing + + + !> Maximum number of bonds per particle + integer, parameter, public :: max_bond=200 !< Assumes something like a 7x7x7 stencil in 3D + + + !> Bonded solid particle definition + type :: part + !> MPI_DOUBLE_PRECISION data + real(WP) :: vonMises !< Element dilatation + real(WP) :: vol !< Particle volume + real(WP), dimension(max_bond) :: dbond !< Length of initial bonds + real(WP), dimension(3) :: pos !< Particle center coordinates + real(WP), dimension(3) :: vel !< Velocity of particle + real(WP), dimension(3) :: Abond !< Bond acceleration for particle + real(WP), dimension(3) :: Afluid !< Fluid acceleration for particle + real(WP), dimension(3) :: ipos !< Initial position + real(WP), dimension(3) :: displacement !< Displacement + real(WP), dimension(3,3) :: F !< Deformation gradient tensor + real(WP), dimension(3,3) :: PK_inv !< First Piola-Kirchoff tensor times shape tensor inverse + !> MPI_INTEGER data + integer :: id !< ID the object is associated with + integer :: i !< Unique index of particle (assumed >0) + integer :: nbond !< Number of initial bonds + integer, dimension(max_bond) :: ibond !< Indices of initially bonded particles (0 values ignored) + integer , dimension(3) :: ind !< Index of cell containing particle center + integer :: flag !< Control parameter (0=normal, 1=done->will be removed) + end type part + !> Number of blocks, block length, and block types in a particle + integer, parameter :: part_nblock=2 + integer , dimension(part_nblock) :: part_lblock=[38+max_bond,7+max_bond] + type(MPI_Datatype), dimension(part_nblock) :: part_tblock=[MPI_DOUBLE_PRECISION,MPI_INTEGER] + !> MPI_PART derived datatype and size + type(MPI_Datatype) :: MPI_PART + integer :: MPI_PART_SIZE + + + !> Lagrangian solid solver object definition + type :: lss + + ! This config is used for parallelization and for calculating bond/collision forces + class(config), pointer :: cfg + + type(ddadi) :: implicit !< Implicit solver for filtering + + ! This is the name of the solver + character(len=str_medium) :: name='UNNAMED_LSS' + + ! Solid material properties + real(WP) :: elastic_modulus !< Elastic modulus of the material + real(WP) :: poisson_ratio !< Poisson's ratio of the material + real(WP) :: rho !< Density of the material + real(WP) :: crit_energy !< Critical energy release + real(WP) :: beta + + ! Bonding parameters + real(WP) :: delta !< Bonding horizon (distance) + real(WP) :: min_dist !< Minimum bonding distance + integer :: nb !< Cell-based horizon + + ! Global and local particle data + integer :: np !< Global number of particles + integer :: np_ !< Local number of particles + integer, dimension(:), allocatable :: np_proc !< Number of particles on each processor + type(part), dimension(:), allocatable :: p !< Array of particles of type part + + ! Overlap particle (i.e., ghost) data + integer :: ng_ !< Local number of ghosts + type(part), dimension(:), allocatable :: g !< Array of ghosts of type part + + ! Gravitational acceleration + real(WP), dimension(3) :: gravity=0.0_WP + + ! Solid volume fraction and momentum + real(WP), dimension(:,:,:), allocatable :: VF !< Volume fraction, cell-centered + real(WP), dimension(:,:,:), allocatable :: VFU !< Solid velocity, U-face + real(WP), dimension(:,:,:), allocatable :: VFV !< Solid velocity, V-face + real(WP), dimension(:,:,:), allocatable :: VFW !< Solid velocity, W-face + + ! CFL numbers + real(WP) :: CFLp_x,CFLp_y,CFLp_z,CFLp_a + + ! Number of substeps for time integrator + real(WP) :: nstep=1 + + ! Monitoring info + real(WP) :: Umin,Umax,Umean !< U velocity info + real(WP) :: Vmin,Vmax,Vmean !< V velocity info + real(WP) :: Wmin,Wmax,Wmean !< W velocity info + real(WP) :: VFmax !< Volume fraction info + real(WP), dimension(3) :: ibmForce !< Total force due to IBM + integer :: np_out !< Number of particles leaving the domain + + ! Filtering operation + real(WP) :: filter_width !< Characteristic filter width + real(WP), dimension(:,:,:,:), allocatable :: div_x,div_y,div_z !< Divergence operator + real(WP), dimension(:,:,:,:), allocatable :: grd_x,grd_y,grd_z !< Gradient operator + + contains + procedure :: bond_init !< Setup initial interparticle bonds + procedure :: get_bond_force !< Compute interparticle bond force + procedure :: advance !< Step forward the particle ODEs + procedure :: get_cfl !< Calculate maximum CFL + procedure :: get_max !< Extract various monitoring data + procedure :: update_partmesh !< Update a partmesh object using current particles + procedure :: share !< Share particles across interprocessor boundaries + procedure :: sync !< Synchronize particles across interprocessor boundaries + procedure :: resize !< Resize particle array to given size + procedure :: resize_ghost !< Resize ghost array to given size + procedure :: recycle !< Recycle particle array by removing flagged particles + procedure :: write !< Parallel write particles to file + procedure :: read !< Parallel read particles from file + procedure :: update_VF !< Compute volume fraction + procedure :: filter !< Apply volume filtering to field + end type lss + + + !> Declare lss constructor + interface lss + procedure constructor + end interface lss + +contains + + + ! Quasi-Gaussian weighting function - h is the cut-off + real(WP) function wgauss(d,h) + implicit none + real(WP), intent(in) :: d,h + real(WP), parameter :: coeff=2.6_WP + real(WP) :: hh + hh=coeff*h + if (d.ge.hh) then + wgauss=0.0_WP + else + wgauss=(1.0_WP+4.0_WP*d/hh)*(1.0_WP-d/hh)**4 + end if + end function wgauss + + + !> Default constructor for Lagrangian solid solver + function constructor(cfg,name) result(self) + implicit none + type(lss) :: self + class(config), target, intent(in) :: cfg + character(len=*), optional :: name + integer :: i,j,k + + ! Set the name for the solver + if (present(name)) self%name=trim(adjustl(name)) + + ! Point to pgrid object + self%cfg=>cfg + + ! Set default bonding horizon based on underlying mesh + self%delta=self%cfg%min_meshsize + self%nb=1 + self%min_dist=huge(1.0_WP) + + ! Allocate variables + allocate(self%np_proc(1:self%cfg%nproc)); self%np_proc=0 + self%np_=0; self%np=0 + call self%resize(0) + + ! Initialize MPI derived datatype for a particle + call prepare_mpi_part() + + ! Allocate VF array on cfg mesh + allocate(self%VF(self%cfg%imino_:self%cfg%imaxo_,self%cfg%jmino_:self%cfg%jmaxo_,self%cfg%kmino_:self%cfg%kmaxo_)); self%VF=0.0_WP + allocate(self%VFU(self%cfg%imino_:self%cfg%imaxo_,self%cfg%jmino_:self%cfg%jmaxo_,self%cfg%kmino_:self%cfg%kmaxo_)); self%VFU=0.0_WP + allocate(self%VFV(self%cfg%imino_:self%cfg%imaxo_,self%cfg%jmino_:self%cfg%jmaxo_,self%cfg%kmino_:self%cfg%kmaxo_)); self%VFV=0.0_WP + allocate(self%VFW(self%cfg%imino_:self%cfg%imaxo_,self%cfg%jmino_:self%cfg%jmaxo_,self%cfg%kmino_:self%cfg%kmaxo_)); self%VFW=0.0_WP + + ! Allocate finite volume divergence operators + allocate(self%div_x(0:+1,self%cfg%imin_:self%cfg%imax_,self%cfg%jmin_:self%cfg%jmax_,self%cfg%kmin_:self%cfg%kmax_)) !< Cell-centered + allocate(self%div_y(0:+1,self%cfg%imin_:self%cfg%imax_,self%cfg%jmin_:self%cfg%jmax_,self%cfg%kmin_:self%cfg%kmax_)) !< Cell-centered + allocate(self%div_z(0:+1,self%cfg%imin_:self%cfg%imax_,self%cfg%jmin_:self%cfg%jmax_,self%cfg%kmin_:self%cfg%kmax_)) !< Cell-centered + ! Create divergence operator to cell center [xm,ym,zm] + do k=self%cfg%kmin_,self%cfg%kmax_ + do j=self%cfg%jmin_,self%cfg%jmax_ + do i=self%cfg%imin_,self%cfg%imax_ + self%div_x(:,i,j,k)=self%cfg%dxi(i)*[-1.0_WP,+1.0_WP] !< Divergence from [x ,ym,zm] + self%div_y(:,i,j,k)=self%cfg%dyi(j)*[-1.0_WP,+1.0_WP] !< Divergence from [xm,y ,zm] + self%div_z(:,i,j,k)=self%cfg%dzi(k)*[-1.0_WP,+1.0_WP] !< Divergence from [xm,ym,z ] + end do + end do + end do + + ! Allocate finite difference velocity gradient operators + allocate(self%grd_x(-1:0,self%cfg%imin_:self%cfg%imax_+1,self%cfg%jmin_:self%cfg%jmax_+1,self%cfg%kmin_:self%cfg%kmax_+1)) !< X-face-centered + allocate(self%grd_y(-1:0,self%cfg%imin_:self%cfg%imax_+1,self%cfg%jmin_:self%cfg%jmax_+1,self%cfg%kmin_:self%cfg%kmax_+1)) !< Y-face-centered + allocate(self%grd_z(-1:0,self%cfg%imin_:self%cfg%imax_+1,self%cfg%jmin_:self%cfg%jmax_+1,self%cfg%kmin_:self%cfg%kmax_+1)) !< Z-face-centered + ! Create gradient coefficients to cell faces + do k=self%cfg%kmin_,self%cfg%kmax_+1 + do j=self%cfg%jmin_,self%cfg%jmax_+1 + do i=self%cfg%imin_,self%cfg%imax_+1 + self%grd_x(:,i,j,k)=self%cfg%dxmi(i)*[-1.0_WP,+1.0_WP] !< Gradient in x from [xm,ym,zm] to [x,ym,zm] + self%grd_y(:,i,j,k)=self%cfg%dymi(j)*[-1.0_WP,+1.0_WP] !< Gradient in y from [xm,ym,zm] to [xm,y,zm] + self%grd_z(:,i,j,k)=self%cfg%dzmi(k)*[-1.0_WP,+1.0_WP] !< Gradient in z from [xm,ym,zm] to [xm,ym,z] + end do + end do + end do + + ! Loop over the domain and zero divergence in walls + do k=self%cfg%kmin_,self%cfg%kmax_ + do j=self%cfg%jmin_,self%cfg%jmax_ + do i=self%cfg%imin_,self%cfg%imax_ + if (self%cfg%VF(i,j,k).eq.0.0_WP) then + self%div_x(:,i,j,k)=0.0_WP + self%div_y(:,i,j,k)=0.0_WP + self%div_z(:,i,j,k)=0.0_WP + end if + end do + end do + end do + + ! Zero out gradient to wall faces + do k=self%cfg%kmin_,self%cfg%kmax_+1 + do j=self%cfg%jmin_,self%cfg%jmax_+1 + do i=self%cfg%imin_,self%cfg%imax_+1 + if (self%cfg%VF(i,j,k).eq.0.0_WP.or.self%cfg%VF(i-1,j,k).eq.0.0_WP) self%grd_x(:,i,j,k)=0.0_WP + if (self%cfg%VF(i,j,k).eq.0.0_WP.or.self%cfg%VF(i,j-1,k).eq.0.0_WP) self%grd_y(:,i,j,k)=0.0_WP + if (self%cfg%VF(i,j,k).eq.0.0_WP.or.self%cfg%VF(i,j,k-1).eq.0.0_WP) self%grd_z(:,i,j,k)=0.0_WP + end do + end do + end do + + ! Adjust metrics to account for lower dimensionality + if (self%cfg%nx.eq.1) then + self%div_x=0.0_WP + self%grd_x=0.0_WP + end if + if (self%cfg%ny.eq.1) then + self%div_y=0.0_WP + self%grd_y=0.0_WP + end if + if (self%cfg%nz.eq.1) then + self%div_z=0.0_WP + self%grd_z=0.0_WP + end if + + ! Create implicit solver object for filtering + self%implicit=ddadi(cfg=self%cfg,name='Filter',nst=7) + self%implicit%stc(1,:)=[ 0, 0, 0] + self%implicit%stc(2,:)=[+1, 0, 0] + self%implicit%stc(3,:)=[-1, 0, 0] + self%implicit%stc(4,:)=[ 0,+1, 0] + self%implicit%stc(5,:)=[ 0,-1, 0] + self%implicit%stc(6,:)=[ 0, 0,+1] + self%implicit%stc(7,:)=[ 0, 0,-1] + call self%implicit%init() + + ! Set default filter width + self%filter_width=1.0_WP*self%cfg%min_meshsize + + ! Log/screen output + logging: block + use, intrinsic :: iso_fortran_env, only: output_unit + use param, only: verbose + use messager, only: log + use string, only: str_long + character(len=str_long) :: message + if (self%cfg%amRoot) then + write(message,'("LSS object [",a,"] on partitioned grid [",a,"]")') trim(self%name),trim(self%cfg%name) + if (verbose.gt.1) write(output_unit,'(a)') trim(message) + if (verbose.gt.0) call log(message) + end if + end block logging + + end function constructor + + + !> Initialize bond force between particles + subroutine bond_init(this) + use messager, only: die + implicit none + class(lss), intent(inout) :: this + integer, dimension(:,:,:), allocatable :: npic !< Number of particle in cell + integer, dimension(:,:,:,:), allocatable :: ipic !< Index of particle in cell + + ! Communicate particles in ghost cells + call this%share() + + ! We can now assemble particle-in-cell information + pic_prep: block + use mpi_f08 + integer :: i,ip,jp,kp,ierr + integer :: mymax_npic,max_npic + + ! Allocate number of particle in cell + allocate(npic(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)); npic=0 + + ! Count particles and ghosts per cell + do i=1,this%np_ + ip=this%p(i)%ind(1); jp=this%p(i)%ind(2); kp=this%p(i)%ind(3) + npic(ip,jp,kp)=npic(ip,jp,kp)+1 + end do + do i=1,this%ng_ + ip=this%g(i)%ind(1); jp=this%g(i)%ind(2); kp=this%g(i)%ind(3) + npic(ip,jp,kp)=npic(ip,jp,kp)+1 + end do + + ! Get maximum number of particle in cell + mymax_npic=maxval(npic); call MPI_ALLREDUCE(mymax_npic,max_npic,1,MPI_INTEGER,MPI_MAX,this%cfg%comm,ierr) + + ! Allocate pic map + allocate(ipic(1:max_npic,this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)); ipic=0 + + ! Assemble pic map + npic=0 + do i=1,this%np_ + ip=this%p(i)%ind(1); jp=this%p(i)%ind(2); kp=this%p(i)%ind(3) + npic(ip,jp,kp)=npic(ip,jp,kp)+1 + ipic(npic(ip,jp,kp),ip,jp,kp)=+i + end do + do i=1,this%ng_ + ip=this%g(i)%ind(1); jp=this%g(i)%ind(2); kp=this%g(i)%ind(3) + npic(ip,jp,kp)=npic(ip,jp,kp)+1 + ipic(npic(ip,jp,kp),ip,jp,kp)=-i + end do + + end block pic_prep + + ! Establish initial bonds + create_bonds: block + use mpi_f08, only: MPI_ALLREDUCE,MPI_MIN,MPI_IN_PLACE + use parallel, only: MPI_REAL_WP + use mathtools, only: Pi + integer :: i,j,k,n1,nn,n2,ierr + type(part) :: p1,p2 + real(WP), dimension(3) :: rpos + real(WP) :: dist + ! Reset minimum bond distance + this%min_dist=huge(1.0_WP) + ! Loop over particles + do n1=1,this%np_ + ! Create copy of our particle + p1=this%p(n1) + ! Zero out bonds + p1%ibond=0 + p1%nbond=0 + ! Loop over neighbor cells + do k=p1%ind(3)-this%nb,p1%ind(3)+this%nb + do j=p1%ind(2)-this%nb,p1%ind(2)+this%nb + do i=p1%ind(1)-this%nb,p1%ind(1)+this%nb + ! Loop over particles in that cell + do nn=1,npic(i,j,k) + ! Create copy of our neighbor + n2=ipic(nn,i,j,k) + if (n2.gt.0) then + p2=this%p(+n2) + else if (n2.lt.0) then + p2=this%g(-n2) + end if + ! Cannot self-bond + if (p1%i.eq.p2%i) cycle + ! Cannot bond with different id except <=0 (<=0 bonds with everyone) + if (p1%id.ne.p2%id.and.p1%id.ge.0.and.p2%id.ge.0) cycle + ! Check interparticle distance + rpos=p2%pos-p1%pos + dist=sqrt(dot_product(rpos,rpos)) + if (dist.lt.this%delta) then + ! This particle is in horizon, create a bond + p1%nbond=p1%nbond+1 + if (p1%nbond.gt.max_bond) call die('[lss_class bond_init] Number of detected bonds is larger than max allowed') + p1%ibond(p1%nbond)=p2%i + p1%dbond(p1%nbond)=dist + ! Determine minimum bond distance + this%min_dist=min(this%min_dist,dist) + end if + end do + end do + end do + end do + ! Copy back the particle + this%p(n1)=p1 + end do + ! Get global minimum + call MPI_ALLREDUCE(MPI_IN_PLACE,this%min_dist,1,MPI_REAL_WP,MPI_MIN,this%cfg%comm,ierr) + end block create_bonds + + ! Clean up + if (allocated(npic)) deallocate(npic) + if (allocated(ipic)) deallocate(ipic) + + end subroutine bond_init + + + !> Calculate bond force between particles + subroutine get_bond_force(this) + implicit none + class(lss), intent(inout) :: this + integer, dimension(:,:,:), allocatable :: npic !< Number of particle in cell + integer, dimension(:,:,:,:), allocatable :: ipic !< Index of particle in cell + integer :: dim2d + logical :: is2D + + ! Need to modify parameters in 2D + is2D=this%cfg%nx.eq.1.or.this%cfg%ny.eq.1.or.this%cfg%nz.eq.1 + dim2d = 0 + if (this%cfg%nx.eq.1) dim2d = 1 + if (this%cfg%ny.eq.1) dim2d = 2 + if (this%cfg%nz.eq.1) dim2d = 3 + + ! Communicate particles in ghost cells + call this%share() + + ! We can now assemble particle-in-cell information + pic_prep: block + use mpi_f08 + integer :: i,ip,jp,kp,ierr + integer :: mymax_npic,max_npic + + ! Allocate number of particle in cell + allocate(npic(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)); npic=0 + + ! Count particles and ghosts per cell + do i=1,this%np_ + ip=this%p(i)%ind(1); jp=this%p(i)%ind(2); kp=this%p(i)%ind(3) + npic(ip,jp,kp)=npic(ip,jp,kp)+1 + end do + do i=1,this%ng_ + ip=this%g(i)%ind(1); jp=this%g(i)%ind(2); kp=this%g(i)%ind(3) + npic(ip,jp,kp)=npic(ip,jp,kp)+1 + end do + + ! Get maximum number of particle in cell + mymax_npic=maxval(npic); call MPI_ALLREDUCE(mymax_npic,max_npic,1,MPI_INTEGER,MPI_MAX,this%cfg%comm,ierr) + + ! Allocate pic map + allocate(ipic(1:max_npic,this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)); ipic=0 + + ! Assemble pic map + npic=0 + do i=1,this%np_ + ip=this%p(i)%ind(1); jp=this%p(i)%ind(2); kp=this%p(i)%ind(3) + npic(ip,jp,kp)=npic(ip,jp,kp)+1 + ipic(npic(ip,jp,kp),ip,jp,kp)=+i + end do + do i=1,this%ng_ + ip=this%g(i)%ind(1); jp=this%g(i)%ind(2); kp=this%g(i)%ind(3) + npic(ip,jp,kp)=npic(ip,jp,kp)+1 + ipic(npic(ip,jp,kp),ip,jp,kp)=-i + end do + + end block pic_prep + + ! Update shape and deformation gradient tensor + update_tensors: block + use mathtools + integer :: i,j,k,n1,nn,n2 + type(part) :: p1,p2 + integer :: nb,nbond + real(WP), dimension(3) :: rpos, xi + real(WP) :: dist,w,mu,kk,detK,traceE,J_F,sigma_vm, traceS + real(WP), dimension(3,3) :: K_mat,E_mat,I_mat,S_mat,K_inv,sigma, s_dev + + mu=this%elastic_modulus/(2.0_WP+2.0_WP*this%poisson_ratio) ! shear modulus + kk=this%elastic_modulus/(3.0_WP-6.0_WP*this%poisson_ratio) ! bulk moduls + I_mat = 0.0_WP + S_mat = 0.0_WP + traceE = 0.0_WP + E_mat = 0.0_WP + K_inv = 0.0_WP + I_mat(1,1) = 1.0_WP + I_mat(2,2) = 1.0_WP + I_mat(3,3) = 1.0_WP + + ! Loop over particles + do n1=1,this%np_ + ! Create copy of our particle + p1=this%p(n1) + ! Zero out weighted volume and dilatation + K_mat=0.0_WP + K_inv = 0.0_WP + p1%F=0.0_WP + ! Loop over neighbor cells + do k=p1%ind(3)-this%nb,p1%ind(3)+this%nb + do j=p1%ind(2)-this%nb,p1%ind(2)+this%nb + do i=p1%ind(1)-this%nb,p1%ind(1)+this%nb + ! Loop over particles in that cell + do nn=1,npic(i,j,k) + ! Create copy of our neighbor + n2=ipic(nn,i,j,k) + if (n2.gt.0) then + p2=this%p(+n2) + else if (n2.lt.0) then + p2=this%g(-n2) + end if + ! Check if a bond exists + do nb=1,max_bond + if (p1%ibond(nb).eq.p2%i) then + ! Get current distance + rpos=p2%pos-p1%pos + !print *, rpos + ! Compute summation of K + xi = p2%ipos-p1%ipos + w = wgauss(p1%dbond(nb),this%delta) + K_mat(1,1)=K_mat(1,1)+xi(1)*xi(1)*w*p2%vol; K_mat(1,2)=K_mat(1,2)+xi(1)*xi(2)*w*p2%vol; K_mat(1,3)=K_mat(1,3)+xi(1)*xi(3)*w*p2%vol; + K_mat(2,1)=K_mat(2,1)+xi(2)*xi(1)*w*p2%vol; K_mat(2,2)=K_mat(2,2)+xi(2)*xi(2)*w*p2%vol; K_mat(2,3)=K_mat(2,3)+xi(2)*xi(3)*w*p2%vol; + K_mat(3,1)=K_mat(3,1)+xi(3)*xi(1)*w*p2%vol; K_mat(3,2)=K_mat(3,2)+xi(3)*xi(2)*w*p2%vol; K_mat(3,3)=K_mat(3,3)+xi(3)*xi(3)*w*p2%vol; + + ! Compute interior summation of F + p1%F(1,1)=p1%F(1,1)+rpos(1)*xi(1)*w*p2%vol; p1%F(1,2)=p1%F(1,2)+rpos(1)*xi(2)*w*p2%vol; p1%F(1,3)=p1%F(1,3)+rpos(1)*xi(3)*w*p2%vol; + p1%F(2,1)=p1%F(2,1)+rpos(2)*xi(1)*w*p2%vol; p1%F(2,2)=p1%F(2,2)+rpos(2)*xi(2)*w*p2%vol; p1%F(2,3)=p1%F(2,3)+rpos(2)*xi(3)*w*p2%vol; + p1%F(3,1)=p1%F(3,1)+rpos(3)*xi(1)*w*p2%vol; p1%F(3,2)=p1%F(3,2)+rpos(3)*xi(2)*w*p2%vol; p1%F(3,3)=p1%F(3,3)+rpos(3)*xi(3)*w*p2%vol; + end if + end do + end do + end do + end do + end do + ! Apply inverse of K to get F = F*K^-1 + if (is2D) then + ! The row/column of K_mat associated with the degenerate + ! direction is ~zero (particles don't vary in that + ! direction), so the full 3x3 K is singular. Invert + ! only the active in-plane 2x2 block, and set the + ! out-of-plane row/column of K_inv to identity. + select case (dim2d) + case (1) ! x degenerate, active plane is (y,z) + detK = K_mat(2,2)*K_mat(3,3) - K_mat(2,3)*K_mat(3,2) + K_inv(1,1) = 1.0_WP + K_inv(2,2) = K_mat(3,3)/detK + K_inv(2,3) = -K_mat(2,3)/detK + K_inv(3,2) = -K_mat(3,2)/detK + K_inv(3,3) = K_mat(2,2)/detK + case (2) ! y degenerate, active plane is (x,z) + detK = K_mat(1,1)*K_mat(3,3) - K_mat(1,3)*K_mat(3,1) + K_inv(2,2) = 1.0_WP + K_inv(1,1) = K_mat(3,3)/detK + K_inv(1,3) = -K_mat(1,3)/detK + K_inv(3,1) = -K_mat(3,1)/detK + K_inv(3,3) = K_mat(1,1)/detK + case (3) ! z degenerate, active plane is (x,y) + detK = K_mat(1,1)*K_mat(2,2) - K_mat(1,2)*K_mat(2,1) + K_inv(3,3) = 1.0_WP + K_inv(1,1) = K_mat(2,2)/detK + K_inv(1,2) = -K_mat(1,2)/detK + K_inv(2,1) = -K_mat(2,1)/detK + K_inv(2,2) = K_mat(1,1)/detK + end select + else + detK = K_mat(1,1)*(K_mat(2,2)*K_mat(3,3)-K_mat(2,3)*K_mat(3,2)) & + -K_mat(1,2)*(K_mat(2,1)*K_mat(3,3)-K_mat(2,3)*K_mat(3,1)) & + +K_mat(1,3)*(K_mat(2,1)*K_mat(3,2)-K_mat(2,2)*K_mat(3,1)) + K_inv(1,1) = (K_mat(2,2)*K_mat(3,3) - K_mat(2,3)*K_mat(3,2))/detK + K_inv(2,1) = -(K_mat(2,1)*K_mat(3,3) - K_mat(2,3)*K_mat(3,1))/detK + K_inv(3,1) = (K_mat(2,1)*K_mat(3,2) - K_mat(2,2)*K_mat(3,1))/detK + K_inv(1,2) = -(K_mat(1,2)*K_mat(3,3) - K_mat(1,3)*K_mat(3,2))/detK + K_inv(2,2) = (K_mat(1,1)*K_mat(3,3) - K_mat(1,3)*K_mat(3,1))/detK + K_inv(3,2) = -(K_mat(1,1)*K_mat(3,2) - K_mat(1,2)*K_mat(3,1))/detK + K_inv(1,3) = (K_mat(1,2)*K_mat(2,3) - K_mat(1,3)*K_mat(2,2))/detK + K_inv(2,3) = -(K_mat(1,1)*K_mat(2,3) - K_mat(1,3)*K_mat(2,1))/detK + K_inv(3,3) = (K_mat(1,1)*K_mat(2,2) - K_mat(1,2)*K_mat(2,1))/detK + end if + + + !if(detK.lt.1e-16_WP) K_inv = I_mat ! is this valid? What to do when this is small, + ! and is this the source of spurious movement? Very small when no displacement has occured + + + p1%F = MATMUL(p1%F,K_inv) + if (is2D) p1%F(dim2d,dim2d) = 1.0_WP + + ! Compute first Piola-Kirchoff stress tensor - constitutive model dependent + E_mat = 0.5_WP * (MATMUL(TRANSPOSE(p1%F),p1%F)-I_mat) + traceE = E_mat(1,1) + E_mat(2,2) + E_mat(3,3) + S_mat = (kk-2.0_WP/3.0_WP*mu)*traceE*I_mat + 2.0_WP*mu*E_mat + p1%PK_inv = MATMUL(MATMUL(p1%F,S_mat),K_inv) + + J_F = p1%F(1,1)*(p1%F(2,2)*p1%F(3,3)-p1%F(2,3)*p1%F(3,2)) & + -p1%F(1,2)*(p1%F(2,1)*p1%F(3,3)-p1%F(2,3)*p1%F(3,1)) & + +p1%F(1,3)*(p1%F(2,1)*p1%F(3,2)-p1%F(2,2)*p1%F(3,1)) + + sigma = MATMUL(MATMUL(p1%F, S_mat), TRANSPOSE(p1%F)) / J_F + + ! Deviatoric part + + traceS = sigma(1,1) + sigma(2,2) + sigma(3,3) + s_dev = sigma - (traceS/3.0_WP)*I_mat + + ! Von Mises + p1%vonMises = sqrt(1.5_WP * (s_dev(1,1)**2 + s_dev(2,2)**2 + s_dev(3,3)**2 & + + 2.0_WP*s_dev(1,2)**2 + 2.0_WP*s_dev(1,3)**2 & + + 2.0_WP*s_dev(2,3)**2)) + + ! Copy back the particle + this%p(n1)=p1 + end do + end block update_tensors + + ! Re-communicate particles in ghost cells to update dil and mw + call this%share() + + ! Update bond force, including collision force + update_bond_force: block + use mpi_f08, only: MPI_ALLREDUCE,MPI_MIN,MPI_IN_PLACE + use parallel, only: MPI_REAL_WP + use mathtools, only: Pi + integer :: i,j,k,n1,nn,n2,ierr + type(part) :: p1,p2 + real(WP), dimension(3) :: rpos,t1,t2,tc1,tc2,xi,z + real(WP), dimension(3,3) :: PK_inv + real(WP) :: dist,t,w + real(WP) :: stretch,max_stretch,mu,kk + real(WP) :: nc,rc,kc + integer :: nb,nbond + logical :: found_bond + ! Recompute a few physical parameters + mu=this%elastic_modulus/(2.0_WP+2.0_WP*this%poisson_ratio) + kk=this%elastic_modulus/(3.0_WP-6.0_WP*this%poisson_ratio) + if (is2D) then + if (this%cfg%nx.eq.1) t=this%cfg%xL + if (this%cfg%ny.eq.1) t=this%cfg%yL + if (this%cfg%nz.eq.1) t=this%cfg%zL + max_stretch=sqrt(this%crit_energy/((6.0_WP*mu/Pi+16.0_WP/(9.0_WP*Pi**2)*(kk-2.0_WP*mu))*this%delta)) + kc=15.0_WP*48.0_WP*this%elastic_modulus/(Pi*5.0_WP*t*this%delta**3) + else + max_stretch=sqrt(this%crit_energy/((3.0_WP*mu+(kk-5.0_WP*mu/3.0_WP)*0.75_WP**4)*this%delta)) + kc=15.0_WP*12.0_WP*this%elastic_modulus/(Pi*this%delta**4) + end if + nc=1.0_WP + this%min_dist=huge(1.0_WP) + ! Loop over particles + do n1=1,this%np_ + ! Particles marked 0 do not update their forces + if (this%p(n1)%id.eq.0) cycle + ! Create copy of our particle + p1=this%p(n1) + ! Zero out bond force + p1%Abond=0.0_WP + ! Zero out PK_inv + PK_inv=0.0_WP + ! Loop over neighbor cells + do k=p1%ind(3)-this%nb,p1%ind(3)+this%nb + do j=p1%ind(2)-this%nb,p1%ind(2)+this%nb + do i=p1%ind(1)-this%nb,p1%ind(1)+this%nb + ! Loop over particles in that cell + do nn=1,npic(i,j,k) + ! Create copy of our neighbor + n2=ipic(nn,i,j,k) + if (n2.gt.0) then + p2=this%p(+n2) + else if (n2.lt.0) then + p2=this%g(-n2) + end if + ! Current distance + rpos=p2%pos-p1%pos + dist=sqrt(dot_product(rpos,rpos)) + ! Check if a bond exists + found_bond=.false. + do nb=1,max_bond + if (p1%ibond(nb).eq.p2%i) then + ! Check for breakage first + stretch=(dist-p1%dbond(nb))/p1%dbond(nb) + if (stretch.gt.max_stretch) then + ! Remove the bond and flag as surface particle + p1%ibond(nb)=0 + p1%dbond(nb)=0.0_WP + cycle + end if + w = wgauss(p1%dbond(nb),this%delta) + xi = p2%ipos-p1%ipos + ! Force density 1->2 + t1 = w*MATMUL(p1%PK_inv,xi) + ! Force density 2->1 + t2 = w*MATMUL(p2%PK_inv,xi) + ! Force correction term (not formulated for 2D?) + ! z = rpos-MATMUL(p1%F,xi) + ! tc1 = w*(9.0_WP*kk/(Pi * this%delta**4))*(dot_product(xi,z)/(sqrt(dot_product(xi,xi)))**3)*xi + ! z = rpos-MATMUL(p2%F,xi) + ! tc2 = w*(9.0_WP*kk/(Pi * this%delta**4))*(dot_product(xi,z)/(sqrt(dot_product(xi,xi)))**3)*xi + ! Compute bond acceleration + !p1%Abond=p1%Abond+(t1+t2+tc1+tc2)*p2%vol/this%rho + p1%Abond=p1%Abond+(t1+t2)*p2%vol/this%rho + ! If still here, we have an active bond + found_bond=.true. + ! Determine minimum bond distance + this%min_dist=min(this%min_dist,dist) + cycle + end if + end do + ! Add collision force now + ! if (is2D) then + ! rc=p1%vol**(1.0_WP/2.0_WP) + ! else + ! rc=p1%vol**(1.0_WP/3.0_WP) + ! end if + ! if (.not.found_bond.and.p1%i.ne.p2%i.and.dist.lt.rc) then + ! p1%Abond=p1%Abond-max(kc*((rc/dist)**nc-1.0_WP),0.0_WP)*(rpos/dist)*p1%vol/this%rho + ! p1%flag = -2 + ! end if + end do + end do + end do + end do + ! Deal with dimensionality + if (this%cfg%nx.eq.1) p1%Abond(1)=0.0_WP + if (this%cfg%ny.eq.1) p1%Abond(2)=0.0_WP + if (this%cfg%nz.eq.1) p1%Abond(3)=0.0_WP + ! Copy back the particle + this%p(n1)=p1 + end do + ! Get global minimum + call MPI_ALLREDUCE(MPI_IN_PLACE,this%min_dist,1,MPI_REAL_WP,MPI_MIN,this%cfg%comm,ierr) + end block update_bond_force + + ! Clean up + if (allocated(npic)) deallocate(npic) + if (allocated(ipic)) deallocate(ipic) + + end subroutine get_bond_force + + + !> Advance the particle equations by a specified time step dt + !> p%id=-2 => do not solve for position nor velocity + !> p%id=-1 => do not solve for velocity + !> p%id= 0 => do not update force + subroutine advance(this,dt,stress_x,stress_y,stress_z) + use mpi_f08, only : MPI_SUM,MPI_INTEGER,MPI_IN_PLACE + use mathtools, only: Pi + implicit none + class(lss), intent(inout) :: this + real(WP), intent(inout) :: dt !< Timestep size over which to advance + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(inout) :: stress_x !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(inout) :: stress_y !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(inout) :: stress_z !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + integer :: n,ierr + real(WP), dimension(3) :: stress + + ! Zero out number of particles removed + this%np_out=0 + + ! Advance velocity based on old force and position based on mid-velocity + do n=1,this%np_ + ! Advance with Verlet scheme + ! Damping is put here, was in the thrombosis paper, unsure if should be + if (this%p(n)%id.gt.-1) this%p(n)%vel=(1.0_WP-(this%beta*dt/2))*this%p(n)%vel+0.5_WP*dt*(this%gravity+this%p(n)%Abond+this%p(n)%Afluid) + if (this%p(n)%id.gt.-2) this%p(n)%pos=this%p(n)%pos+dt*this%p(n)%vel + ! Relocalize + this%p(n)%ind=this%cfg%get_ijk_global(this%p(n)%pos,this%p(n)%ind) + ! Correct the position to take into account periodicity + if (this%cfg%xper) this%p(n)%pos(1)=this%cfg%x(this%cfg%imin)+modulo(this%p(n)%pos(1)-this%cfg%x(this%cfg%imin),this%cfg%xL) + if (this%cfg%yper) this%p(n)%pos(2)=this%cfg%y(this%cfg%jmin)+modulo(this%p(n)%pos(2)-this%cfg%y(this%cfg%jmin),this%cfg%yL) + if (this%cfg%zper) this%p(n)%pos(3)=this%cfg%z(this%cfg%kmin)+modulo(this%p(n)%pos(3)-this%cfg%z(this%cfg%kmin),this%cfg%zL) + ! Handle particles that have left the domain + if (this%p(n)%pos(1).lt.this%cfg%x(this%cfg%imin).or.this%p(n)%pos(1).gt.this%cfg%x(this%cfg%imax+1)) this%p(n)%flag=1 + if (this%p(n)%pos(2).lt.this%cfg%y(this%cfg%jmin).or.this%p(n)%pos(2).gt.this%cfg%y(this%cfg%jmax+1)) this%p(n)%flag=1 + if (this%p(n)%pos(3).lt.this%cfg%z(this%cfg%kmin).or.this%p(n)%pos(3).gt.this%cfg%z(this%cfg%kmax+1)) this%p(n)%flag=1 + ! Relocalize the particle + this%p(n)%ind=this%cfg%get_ijk_global(this%p(n)%pos,this%p(n)%ind) + ! Count number of particles removed + if (this%p(n)%flag.eq.1) this%np_out=this%np_out+1 + end do + + ! Communicate particles + call this%sync() + + ! Sum up particles removed + call MPI_ALLREDUCE(this%np_out,n,1,MPI_INTEGER,MPI_SUM,this%cfg%comm,ierr); this%np_out=n + + ! Calculate bond force + call this%get_bond_force() + + ! Advance velocity only based on new force + do n=1,this%np_ + ! Advance with Verlet scheme + stress=this%cfg%get_velocity(pos=this%p(n)%pos,i0=this%p(n)%ind(1),j0=this%p(n)%ind(2),k0=this%p(n)%ind(3),U=stress_x,V=stress_y,W=stress_z) + this%p(n)%Afluid=stress/this%rho + if (this%p(n)%id.le.-1) cycle + ! Damping is put here, was in the thrombosis paper, unsure if should be + this%p(n)%vel=this%p(n)%vel*(1.0_WP-(this%beta*dt/2))+0.5_WP*dt*(this%gravity+this%p(n)%Abond+this%p(n)%Afluid) + end do + + ! Recompute volume fraction + call this%update_VF() + + ! Log/screen output + logging: block + use, intrinsic :: iso_fortran_env, only: output_unit + use param, only: verbose + use messager, only: log + use string, only: str_long + character(len=str_long) :: message + if (this%cfg%amRoot) then + write(message,'("Particle solver [",a,"] on partitioned grid [",a,"]: ",i0," particles were advanced")') trim(this%name),trim(this%cfg%name),this%np + if (verbose.gt.1) write(output_unit,'(a)') trim(message) + if (verbose.gt.0) call log(message) + end if + end block logging + + end subroutine advance + + + !> Update particle volume fraction using our current particles + subroutine update_VF(this) + implicit none + class(lss), intent(inout) :: this + integer :: i + ! Reset volume fraction and momentum + this%VF=0.0_WP; this%VFU=0.0_WP; this%VFV=0.0_WP; this%VFW=0.0_WP + ! Transfer particle volume + do i=1,this%np_ + ! Skip inactive particle + if (this%p(i)%flag.eq.1) cycle + ! Transfer volume to mesh + call this%cfg%set_scalar(Sp=this%p(i)%vol, pos=this%p(i)%pos,i0=this%p(i)%ind(1),j0=this%p(i)%ind(2),k0=this%p(i)%ind(3),S=this%VF ,bc='n') + call this%cfg%set_scalar(Sp=this%p(i)%vol*this%p(i)%vel(1),pos=this%p(i)%pos,i0=this%p(i)%ind(1),j0=this%p(i)%ind(2),k0=this%p(i)%ind(3),S=this%VFU,bc='n') + call this%cfg%set_scalar(Sp=this%p(i)%vol*this%p(i)%vel(2),pos=this%p(i)%pos,i0=this%p(i)%ind(1),j0=this%p(i)%ind(2),k0=this%p(i)%ind(3),S=this%VFV,bc='n') + call this%cfg%set_scalar(Sp=this%p(i)%vol*this%p(i)%vel(3),pos=this%p(i)%pos,i0=this%p(i)%ind(1),j0=this%p(i)%ind(2),k0=this%p(i)%ind(3),S=this%VFW,bc='n') + end do + this%VF =this%VF /this%cfg%vol + this%VFU=this%VFU/this%cfg%vol + this%VFV=this%VFV/this%cfg%vol + this%VFW=this%VFW/this%cfg%vol + ! Sum at boundaries + call this%cfg%syncsum(this%VF ) + call this%cfg%syncsum(this%VFU) + call this%cfg%syncsum(this%VFV) + call this%cfg%syncsum(this%VFW) + ! Apply volume filter + call this%filter(this%VF ) + call this%filter(this%VFU) + call this%filter(this%VFV) + call this%filter(this%VFW) + ! Clip + where (this%VF.lt.0.0_WP) this%VF=0.0_WP + this%VF=min(this%VF,1.0_WP-epsilon(1.0_WP)) + + end subroutine update_VF + + + !> Laplacian filtering operation + subroutine filter(this,A) + implicit none + class(lss), intent(inout) :: this + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(inout) :: A !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + real(WP) :: filter_coeff + integer :: i,j,k,n,nstep + real(WP), dimension(:,:,:), allocatable :: FX,FY,FZ + + ! Recompute filter coefficient + filter_coeff=max(this%filter_width**2-this%cfg%min_meshsize**2,0.0_WP)/(16.0_WP*log(2.0_WP)) + if (filter_coeff.le.0.0_WP) return + + ! Allocate flux arrays + allocate(FX(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + allocate(FY(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + allocate(FZ(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + + if (.not.this%implicit%setup_done) then + ! Prepare diffusive operator (only need to do this once) + do k=this%cfg%kmin_,this%cfg%kmax_ + do j=this%cfg%jmin_,this%cfg%jmax_ + do i=this%cfg%imin_,this%cfg%imax_ + this%implicit%opr(1,i,j,k)=1.0_WP-(this%div_x(+1,i,j,k)*filter_coeff*this%grd_x(-1,i+1,j,k)+& + & this%div_x( 0,i,j,k)*filter_coeff*this%grd_x( 0,i ,j,k)+& + & this%div_y(+1,i,j,k)*filter_coeff*this%grd_y(-1,i,j+1,k)+& + & this%div_y( 0,i,j,k)*filter_coeff*this%grd_y( 0,i,j ,k)+& + & this%div_z(+1,i,j,k)*filter_coeff*this%grd_z(-1,i,j,k+1)+& + & this%div_z( 0,i,j,k)*filter_coeff*this%grd_z( 0,i,j,k )) + this%implicit%opr(2,i,j,k)= -(this%div_x(+1,i,j,k)*filter_coeff*this%grd_x( 0,i+1,j,k)) + this%implicit%opr(3,i,j,k)= -(this%div_x( 0,i,j,k)*filter_coeff*this%grd_x(-1,i ,j,k)) + this%implicit%opr(4,i,j,k)= -(this%div_y(+1,i,j,k)*filter_coeff*this%grd_y( 0,i,j+1,k)) + this%implicit%opr(5,i,j,k)= -(this%div_y( 0,i,j,k)*filter_coeff*this%grd_y(-1,i,j ,k)) + this%implicit%opr(6,i,j,k)= -(this%div_z(+1,i,j,k)*filter_coeff*this%grd_z( 0,i,j,k+1)) + this%implicit%opr(7,i,j,k)= -(this%div_z( 0,i,j,k)*filter_coeff*this%grd_z(-1,i,j,k )) + end do + end do + end do + end if + ! Explicit step + do k=this%cfg%kmin_,this%cfg%kmax_+1 + do j=this%cfg%jmin_,this%cfg%jmax_+1 + do i=this%cfg%imin_,this%cfg%imax_+1 + FX(i,j,k)=filter_coeff*sum(this%grd_x(:,i,j,k)*A(i-1:i,j,k)) + FY(i,j,k)=filter_coeff*sum(this%grd_y(:,i,j,k)*A(i,j-1:j,k)) + FZ(i,j,k)=filter_coeff*sum(this%grd_z(:,i,j,k)*A(i,j,k-1:k)) + end do + end do + end do + do k=this%cfg%kmin_,this%cfg%kmax_ + do j=this%cfg%jmin_,this%cfg%jmax_ + do i=this%cfg%imin_,this%cfg%imax_ + this%implicit%rhs(i,j,k)=sum(this%div_x(:,i,j,k)*FX(i:i+1,j,k))+sum(this%div_y(:,i,j,k)*FY(i,j:j+1,k))+sum(this%div_z(:,i,j,k)*FZ(i,j,k:k+1)) + end do + end do + end do + ! Implicit step + call this%implicit%setup() + this%implicit%sol=0.0_WP + call this%implicit%solve() + A=A+this%implicit%sol + call this%cfg%sync(A) + + ! Deallocate flux arrays + deallocate(FX,FY,FZ) + + end subroutine filter + + + !> Calculate the CFL + subroutine get_cfl(this,dt,cfl) + use mpi_f08, only: MPI_ALLREDUCE,MPI_MAX + use parallel, only: MPI_REAL_WP + implicit none + class(lss), intent(inout) :: this + real(WP), intent(in) :: dt + real(WP), intent(out) :: cfl + integer :: i,ierr + real(WP) :: my_CFLp_x,my_CFLp_y,my_CFLp_z,kk,mu,a + + ! Set the CFLs to zero + my_CFLp_x=0.0_WP; my_CFLp_y=0.0_WP; my_CFLp_z=0.0_WP + do i=1,this%np_ + my_CFLp_x=max(my_CFLp_x,abs(this%p(i)%vel(1))*this%cfg%dxi(this%p(i)%ind(1))) + my_CFLp_y=max(my_CFLp_y,abs(this%p(i)%vel(2))*this%cfg%dyi(this%p(i)%ind(2))) + my_CFLp_z=max(my_CFLp_z,abs(this%p(i)%vel(3))*this%cfg%dzi(this%p(i)%ind(3))) + end do + my_CFLp_x=my_CFLp_x*dt; my_CFLp_y=my_CFLp_y*dt; my_CFLp_z=my_CFLp_z*dt + + ! Get the parallel max + call MPI_ALLREDUCE(my_CFLp_x,this%CFLp_x,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + call MPI_ALLREDUCE(my_CFLp_y,this%CFLp_y,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + call MPI_ALLREDUCE(my_CFLp_z,this%CFLp_z,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + + ! CFL based on elastic wave speed in material + kk=this%elastic_modulus/(3.0_WP-6.0_WP*this%poisson_ratio) + mu=this%elastic_modulus/(2.0_WP+2.0_WP*this%poisson_ratio) + a=sqrt((kk+4.0_WP*mu/3.0_WP)/this%rho) + this%CFLp_a=dt*a/this%delta + + ! Return the maximum CFL + cfl=max(this%CFLp_x,this%CFLp_y,this%CFLp_z,this%CFLp_a) + + end subroutine get_cfl + + + !> Extract various monitoring data from particle field + subroutine get_max(this) + use mpi_f08, only: MPI_ALLREDUCE,MPI_MAX,MPI_MIN,MPI_SUM + use parallel, only: MPI_REAL_WP + implicit none + class(lss), intent(inout) :: this + real(WP) :: buf,safe_np + real(WP), dimension(3) :: buf3D + integer :: i,j,k,ierr + + ! Create safe np + safe_np=real(max(this%np,1),WP) + + ! Velocity min/max/mean + this%Umin=huge(1.0_WP); this%Umax=-huge(1.0_WP); this%Umean=0.0_WP + this%Vmin=huge(1.0_WP); this%Vmax=-huge(1.0_WP); this%Vmean=0.0_WP + this%Wmin=huge(1.0_WP); this%Wmax=-huge(1.0_WP); this%Wmean=0.0_WP + this%ibmForce=0.0_WP + do i=1,this%np_ + this%Umin=min(this%Umin,this%p(i)%vel(1)); this%Umax=max(this%Umax,this%p(i)%vel(1)); this%Umean=this%Umean+this%p(i)%vel(1) + this%Vmin=min(this%Vmin,this%p(i)%vel(2)); this%Vmax=max(this%Vmax,this%p(i)%vel(2)); this%Vmean=this%Vmean+this%p(i)%vel(2) + this%Wmin=min(this%Wmin,this%p(i)%vel(3)); this%Wmax=max(this%Wmax,this%p(i)%vel(3)); this%Wmean=this%Wmean+this%p(i)%vel(3) + this%ibmForce=this%ibmForce+this%p(i)%Afluid*this%p(i)%vol*this%rho + end do + call MPI_ALLREDUCE(this%Umin ,buf,1,MPI_REAL_WP,MPI_MIN,this%cfg%comm,ierr); this%Umin =buf + call MPI_ALLREDUCE(this%Umax ,buf,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr); this%Umax =buf + call MPI_ALLREDUCE(this%Umean,buf,1,MPI_REAL_WP,MPI_SUM,this%cfg%comm,ierr); this%Umean=buf/safe_np + call MPI_ALLREDUCE(this%Vmin ,buf,1,MPI_REAL_WP,MPI_MIN,this%cfg%comm,ierr); this%Vmin =buf + call MPI_ALLREDUCE(this%Vmax ,buf,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr); this%Vmax =buf + call MPI_ALLREDUCE(this%Vmean,buf,1,MPI_REAL_WP,MPI_SUM,this%cfg%comm,ierr); this%Vmean=buf/safe_np + call MPI_ALLREDUCE(this%Wmin ,buf,1,MPI_REAL_WP,MPI_MIN,this%cfg%comm,ierr); this%Wmin =buf + call MPI_ALLREDUCE(this%Wmax ,buf,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr); this%Wmax =buf + call MPI_ALLREDUCE(this%Wmean,buf,1,MPI_REAL_WP,MPI_SUM,this%cfg%comm,ierr); this%Wmean=buf/safe_np + call MPI_ALLREDUCE(this%ibmForce,buf3D,3,MPI_REAL_WP,MPI_SUM,this%cfg%comm,ierr); this%ibmForce=buf3D + + ! Get max volume fraction + this%VFmax =-huge(1.0_WP) + do k=this%cfg%kmin_,this%cfg%kmax_ + do j=this%cfg%jmin_,this%cfg%jmax_ + do i=this%cfg%imin_,this%cfg%imax_ + this%VFmax=max(this%VFmax,this%VF(i,j,k)) + end do + end do + end do + call MPI_ALLREDUCE(this%VFmax,buf,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr); this%VFmax=buf + + end subroutine get_max + + + !> Update particle mesh using our current particles + subroutine update_partmesh(this,pmesh) + use partmesh_class, only: partmesh + implicit none + class(lss), intent(inout) :: this + class(partmesh), intent(inout) :: pmesh + integer :: i + ! Reset particle mesh storage + call pmesh%reset() + ! Nothing else to do if no particle is present + if (this%np_.eq.0) return + ! Copy particle info + call pmesh%set_size(this%np_) + do i=1,this%np_ + pmesh%pos(:,i)=this%p(i)%pos + end do + end subroutine update_partmesh + + + !> Creation of the MPI datatype for particle + subroutine prepare_mpi_part() + use mpi_f08 + use messager, only: die + implicit none + integer(MPI_ADDRESS_KIND), dimension(part_nblock) :: disp + integer(MPI_ADDRESS_KIND) :: lb,extent + type(MPI_Datatype) :: MPI_PART_TMP + integer :: i,mysize,ierr + ! Prepare the displacement array + disp(1)=0 + do i=2,part_nblock + call MPI_Type_size(part_tblock(i-1),mysize,ierr) + disp(i)=disp(i-1)+int(mysize,MPI_ADDRESS_KIND)*int(part_lblock(i-1),MPI_ADDRESS_KIND) + end do + ! Create and commit the new type + call MPI_Type_create_struct(part_nblock,part_lblock,disp,part_tblock,MPI_PART_TMP,ierr) + call MPI_Type_get_extent(MPI_PART_TMP,lb,extent,ierr) + call MPI_Type_create_resized(MPI_PART_TMP,lb,extent,MPI_PART,ierr) + call MPI_Type_commit(MPI_PART,ierr) + ! If a problem was encountered, say it + if (ierr.ne.0) call die('[lss prepare_mpi_part] MPI Particle type creation failed') + ! Get the size of this type + call MPI_type_size(MPI_PART,MPI_PART_SIZE,ierr) + end subroutine prepare_mpi_part + + + !> Share particles across processor boundaries + subroutine share(this,nover) + use mpi_f08 + use messager, only: warn,die + implicit none + class(lss), intent(inout) :: this + integer, optional :: nover + type(part), dimension(:), allocatable :: tosend + type(part), dimension(:), allocatable :: torecv + integer :: no,nsend,nrecv + type(MPI_Status) :: status + integer :: icnt,isrc,idst,ierr + integer :: i,n + + ! Check overlap size + if (present(nover)) then + no=nover + if (no.gt.this%cfg%no) then + call warn('[lss share] Specified overlap is larger than that of cfg - reducing no') + no=this%cfg%no + else if (no.le.0) then + call die('[lss share] Specified overlap cannot be less or equal to zero') + end if + else + no=1 + end if + + ! Clean up ghost array + call this%resize_ghost(n=0); this%ng_=0 + + ! Share ghost particles in -x (no ghosts are sent here) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(1).lt.this%cfg%imin_+no) nsend=nsend+1 + end do + allocate(tosend(nsend)) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(1).lt.this%cfg%imin_+no) then + nsend=nsend+1 + tosend(nsend)=this%p(n) + if (this%cfg%xper.and.tosend(nsend)%ind(1).lt.this%cfg%imin+no) then + tosend(nsend)%pos(1)=tosend(nsend)%pos(1)+this%cfg%xL + tosend(nsend)%ind(1)=tosend(nsend)%ind(1)+this%cfg%nx + end if + end if + end do + nrecv=0 + call MPI_CART_SHIFT(this%cfg%comm,0,-1,isrc,idst,ierr) + call MPI_SENDRECV(nsend,1,MPI_INTEGER,idst,0,nrecv,1,MPI_INTEGER,isrc,0,this%cfg%comm,status,ierr) + allocate(torecv(nrecv)) + call MPI_SENDRECV(tosend,nsend,MPI_PART,idst,0,torecv,nrecv,MPI_PART,isrc,0,this%cfg%comm,status,ierr) + call this%resize_ghost(this%ng_+nrecv) + this%g(this%ng_+1:this%ng_+nrecv)=torecv + this%ng_=this%ng_+nrecv + if (allocated(tosend)) deallocate(tosend) + if (allocated(torecv)) deallocate(torecv) + + ! Share ghost particles in +x (no ghosts are sent here) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(1).gt.this%cfg%imax_-no) nsend=nsend+1 + end do + allocate(tosend(nsend)) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(1).gt.this%cfg%imax_-no) then + nsend=nsend+1 + tosend(nsend)=this%p(n) + if (this%cfg%xper.and.tosend(nsend)%ind(1).gt.this%cfg%imax-no) then + tosend(nsend)%pos(1)=tosend(nsend)%pos(1)-this%cfg%xL + tosend(nsend)%ind(1)=tosend(nsend)%ind(1)-this%cfg%nx + end if + end if + end do + nrecv=0 + call MPI_CART_SHIFT(this%cfg%comm,0,+1,isrc,idst,ierr) + call MPI_SENDRECV(nsend,1,MPI_INTEGER,idst,0,nrecv,1,MPI_INTEGER,isrc,0,this%cfg%comm,status,ierr) + allocate(torecv(nrecv)) + call MPI_SENDRECV(tosend,nsend,MPI_PART,idst,0,torecv,nrecv,MPI_PART,isrc,0,this%cfg%comm,status,ierr) + call this%resize_ghost(this%ng_+nrecv) + this%g(this%ng_+1:this%ng_+nrecv)=torecv + this%ng_=this%ng_+nrecv + if (allocated(tosend)) deallocate(tosend) + if (allocated(torecv)) deallocate(torecv) + + ! Share ghost particles in -y (ghosts need to be sent now) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(2).lt.this%cfg%jmin_+no) nsend=nsend+1 + end do + do n=1,this%ng_ + if (this%g(n)%ind(2).lt.this%cfg%jmin_+no) nsend=nsend+1 + end do + allocate(tosend(nsend)) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(2).lt.this%cfg%jmin_+no) then + nsend=nsend+1 + tosend(nsend)=this%p(n) + if (this%cfg%yper.and.tosend(nsend)%ind(2).lt.this%cfg%jmin+no) then + tosend(nsend)%pos(2)=tosend(nsend)%pos(2)+this%cfg%yL + tosend(nsend)%ind(2)=tosend(nsend)%ind(2)+this%cfg%ny + end if + end if + end do + do n=1,this%ng_ + if (this%g(n)%ind(2).lt.this%cfg%jmin_+no) then + nsend=nsend+1 + tosend(nsend)=this%g(n) + if (this%cfg%yper.and.tosend(nsend)%ind(2).lt.this%cfg%jmin+no) then + tosend(nsend)%pos(2)=tosend(nsend)%pos(2)+this%cfg%yL + tosend(nsend)%ind(2)=tosend(nsend)%ind(2)+this%cfg%ny + end if + end if + end do + nrecv=0 + call MPI_CART_SHIFT(this%cfg%comm,1,-1,isrc,idst,ierr) + call MPI_SENDRECV(nsend,1,MPI_INTEGER,idst,0,nrecv,1,MPI_INTEGER,isrc,0,this%cfg%comm,status,ierr) + allocate(torecv(nrecv)) + call MPI_SENDRECV(tosend,nsend,MPI_PART,idst,0,torecv,nrecv,MPI_PART,isrc,0,this%cfg%comm,status,ierr) + call this%resize_ghost(this%ng_+nrecv) + this%g(this%ng_+1:this%ng_+nrecv)=torecv + this%ng_=this%ng_+nrecv + if (allocated(tosend)) deallocate(tosend) + if (allocated(torecv)) deallocate(torecv) + + ! Share ghost particles in +y (ghosts need to be sent now - but not newly received ghosts!) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(2).gt.this%cfg%jmax_-no) nsend=nsend+1 + end do + do n=1,this%ng_-nrecv + if (this%g(n)%ind(2).gt.this%cfg%jmax_-no) nsend=nsend+1 + end do + allocate(tosend(nsend)) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(2).gt.this%cfg%jmax_-no) then + nsend=nsend+1 + tosend(nsend)=this%p(n) + if (this%cfg%yper.and.tosend(nsend)%ind(2).gt.this%cfg%jmax-no) then + tosend(nsend)%pos(2)=tosend(nsend)%pos(2)-this%cfg%yL + tosend(nsend)%ind(2)=tosend(nsend)%ind(2)-this%cfg%ny + end if + end if + end do + do n=1,this%ng_-nrecv + if (this%g(n)%ind(2).gt.this%cfg%jmax_-no) then + nsend=nsend+1 + tosend(nsend)=this%g(n) + if (this%cfg%yper.and.tosend(nsend)%ind(2).gt.this%cfg%jmax-no) then + tosend(nsend)%pos(2)=tosend(nsend)%pos(2)-this%cfg%yL + tosend(nsend)%ind(2)=tosend(nsend)%ind(2)-this%cfg%ny + end if + end if + end do + nrecv=0 + call MPI_CART_SHIFT(this%cfg%comm,1,+1,isrc,idst,ierr) + call MPI_SENDRECV(nsend,1,MPI_INTEGER,idst,0,nrecv,1,MPI_INTEGER,isrc,0,this%cfg%comm,status,ierr) + allocate(torecv(nrecv)) + call MPI_SENDRECV(tosend,nsend,MPI_PART,idst,0,torecv,nrecv,MPI_PART,isrc,0,this%cfg%comm,status,ierr) + call this%resize_ghost(this%ng_+nrecv) + this%g(this%ng_+1:this%ng_+nrecv)=torecv + this%ng_=this%ng_+nrecv + if (allocated(tosend)) deallocate(tosend) + if (allocated(torecv)) deallocate(torecv) + + ! Share ghost particles in -z (ghosts need to be sent now) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(3).lt.this%cfg%kmin_+no) nsend=nsend+1 + end do + do n=1,this%ng_ + if (this%g(n)%ind(3).lt.this%cfg%kmin_+no) nsend=nsend+1 + end do + allocate(tosend(nsend)) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(3).lt.this%cfg%kmin_+no) then + nsend=nsend+1 + tosend(nsend)=this%p(n) + if (this%cfg%zper.and.tosend(nsend)%ind(3).lt.this%cfg%kmin+no) then + tosend(nsend)%pos(3)=tosend(nsend)%pos(3)+this%cfg%zL + tosend(nsend)%ind(3)=tosend(nsend)%ind(3)+this%cfg%nz + end if + end if + end do + do n=1,this%ng_ + if (this%g(n)%ind(3).lt.this%cfg%kmin_+no) then + nsend=nsend+1 + tosend(nsend)=this%g(n) + if (this%cfg%zper.and.tosend(nsend)%ind(3).lt.this%cfg%kmin+no) then + tosend(nsend)%pos(3)=tosend(nsend)%pos(3)+this%cfg%zL + tosend(nsend)%ind(3)=tosend(nsend)%ind(3)+this%cfg%nz + end if + end if + end do + nrecv=0 + call MPI_CART_SHIFT(this%cfg%comm,2,-1,isrc,idst,ierr) + call MPI_SENDRECV(nsend,1,MPI_INTEGER,idst,0,nrecv,1,MPI_INTEGER,isrc,0,this%cfg%comm,status,ierr) + allocate(torecv(nrecv)) + call MPI_SENDRECV(tosend,nsend,MPI_PART,idst,0,torecv,nrecv,MPI_PART,isrc,0,this%cfg%comm,status,ierr) + call this%resize_ghost(this%ng_+nrecv) + this%g(this%ng_+1:this%ng_+nrecv)=torecv + this%ng_=this%ng_+nrecv + if (allocated(tosend)) deallocate(tosend) + if (allocated(torecv)) deallocate(torecv) + + ! Share ghost particles in +z (ghosts need to be sent now - but not newly received ghosts!) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(3).gt.this%cfg%kmax_-no) nsend=nsend+1 + end do + do n=1,this%ng_-nrecv + if (this%g(n)%ind(3).gt.this%cfg%kmax_-no) nsend=nsend+1 + end do + allocate(tosend(nsend)) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(3).gt.this%cfg%kmax_-no) then + nsend=nsend+1 + tosend(nsend)=this%p(n) + if (this%cfg%zper.and.tosend(nsend)%ind(3).gt.this%cfg%kmax-no) then + tosend(nsend)%pos(3)=tosend(nsend)%pos(3)-this%cfg%zL + tosend(nsend)%ind(3)=tosend(nsend)%ind(3)-this%cfg%nz + end if + end if + end do + do n=1,this%ng_-nrecv + if (this%g(n)%ind(3).gt.this%cfg%kmax_-no) then + nsend=nsend+1 + tosend(nsend)=this%g(n) + if (this%cfg%zper.and.tosend(nsend)%ind(3).gt.this%cfg%kmax-no) then + tosend(nsend)%pos(3)=tosend(nsend)%pos(3)-this%cfg%zL + tosend(nsend)%ind(3)=tosend(nsend)%ind(3)-this%cfg%nz + end if + end if + end do + nrecv=0 + call MPI_CART_SHIFT(this%cfg%comm,2,+1,isrc,idst,ierr) + call MPI_SENDRECV(nsend,1,MPI_INTEGER,idst,0,nrecv,1,MPI_INTEGER,isrc,0,this%cfg%comm,status,ierr) + allocate(torecv(nrecv)) + call MPI_SENDRECV(tosend,nsend,MPI_PART,idst,0,torecv,nrecv,MPI_PART,isrc,0,this%cfg%comm,status,ierr) + call this%resize_ghost(this%ng_+nrecv) + this%g(this%ng_+1:this%ng_+nrecv)=torecv + this%ng_=this%ng_+nrecv + if (allocated(tosend)) deallocate(tosend) + if (allocated(torecv)) deallocate(torecv) + + end subroutine share + + + !> Synchronize particle arrays across processors + subroutine sync(this) + use mpi_f08 + implicit none + class(lss), intent(inout) :: this + integer, dimension(0:this%cfg%nproc-1) :: nsend_proc,nrecv_proc + integer, dimension(0:this%cfg%nproc-1) :: nsend_disp,nrecv_disp + integer :: n,prank,ierr + type(part), dimension(:), allocatable :: buf_send + ! Recycle first to minimize communication load + call this%recycle() + ! Prepare information about what to send + nsend_proc=0 + do n=1,this%np_ + prank=this%cfg%get_rank(this%p(n)%ind) + nsend_proc(prank)=nsend_proc(prank)+1 + end do + nsend_proc(this%cfg%rank)=0 + ! Inform processors of what they will receive + call MPI_ALLtoALL(nsend_proc,1,MPI_INTEGER,nrecv_proc,1,MPI_INTEGER,this%cfg%comm,ierr) + ! Prepare displacements for all-to-all + nsend_disp(0)=0 + nrecv_disp(0)=this%np_ !< Directly add particles at the end of main array + do n=1,this%cfg%nproc-1 + nsend_disp(n)=nsend_disp(n-1)+nsend_proc(n-1) + nrecv_disp(n)=nrecv_disp(n-1)+nrecv_proc(n-1) + end do + ! Allocate buffer to send particles + allocate(buf_send(sum(nsend_proc))) + ! Pack the particles in the send buffer + nsend_proc=0 + do n=1,this%np_ + ! Get the rank + prank=this%cfg%get_rank(this%p(n)%ind) + ! Skip particles still inside + if (prank.eq.this%cfg%rank) cycle + ! Pack up for sending + nsend_proc(prank)=nsend_proc(prank)+1 + buf_send(nsend_disp(prank)+nsend_proc(prank))=this%p(n) + ! Flag particle for removal + this%p(n)%flag=1 + end do + ! Allocate buffer for receiving particles + call this%resize(this%np_+sum(nrecv_proc)) + ! Perform communication + call MPI_ALLtoALLv(buf_send,nsend_proc,nsend_disp,MPI_PART,this%p,nrecv_proc,nrecv_disp,MPI_PART,this%cfg%comm,ierr) + ! Deallocate buffer + deallocate(buf_send) + ! Recycle to remove duplicate particles + call this%recycle() + end subroutine sync + + + !> Adaptation of particle array size + subroutine resize(this,n) + implicit none + class(lss), intent(inout) :: this + integer, intent(in) :: n + type(part), dimension(:), allocatable :: tmp + integer :: size_now,size_new + ! Resize particle array to size n + if (.not.allocated(this%p)) then + ! Allocate directly to size n + allocate(this%p(n)) + this%p(1:n)%flag=1 + else + ! Update from a non-zero size to another non-zero size + size_now=size(this%p,dim=1) + if (n.gt.size_now) then + size_new=max(n,int(real(size_now,WP)*coeff_up)) + allocate(tmp(size_new)) + tmp(1:size_now)=this%p + tmp(size_now+1:)%flag=1 + call move_alloc(tmp,this%p) + else if (n.lt.int(real(size_now,WP)*coeff_dn)) then + allocate(tmp(n)) + tmp(1:n)=this%p(1:n) + call move_alloc(tmp,this%p) + end if + end if + end subroutine resize + + + !> Adaptation of ghost array size + subroutine resize_ghost(this,n) + implicit none + class(lss), intent(inout) :: this + integer, intent(in) :: n + type(part), dimension(:), allocatable :: tmp + integer :: size_now,size_new + ! Resize ghost array to size n + if (.not.allocated(this%g)) then + ! Allocate directly to size n + allocate(this%g(n)) + this%g(1:n)%flag=1 + else + ! Update from a non-zero size to another non-zero size + size_now=size(this%g,dim=1) + if (n.gt.size_now) then + size_new=max(n,int(real(size_now,WP)*coeff_up)) + allocate(tmp(size_new)) + tmp(1:size_now)=this%g + tmp(size_now+1:)%flag=1 + call move_alloc(tmp,this%g) + else if (n.lt.int(real(size_now,WP)*coeff_dn)) then + allocate(tmp(n)) + tmp(1:n)=this%g(1:n) + call move_alloc(tmp,this%g) + end if + end if + end subroutine resize_ghost + + + !> Clean-up of particle array by removing flag=1 particles + subroutine recycle(this) + implicit none + class(lss), intent(inout) :: this + integer :: new_size,i,ierr + ! Compact all active particles at the beginning of the array + new_size=0 + if (allocated(this%p)) then + do i=1,size(this%p,dim=1) + if (this%p(i)%flag.ne.1) then + new_size=new_size+1 + if (i.ne.new_size) then + this%p(new_size)=this%p(i) + this%p(i)%flag=1 + end if + end if + end do + end if + ! Resize to new size + call this%resize(new_size) + ! Update number of particles + this%np_=new_size + call MPI_ALLGATHER(this%np_,1,MPI_INTEGER,this%np_proc,1,MPI_INTEGER,this%cfg%comm,ierr) + this%np=sum(this%np_proc) + end subroutine recycle + + + !> Parallel write particles to file + subroutine write(this,filename) + use mpi_f08 + use messager, only: die + use parallel, only: info_mpiio + implicit none + class(lss), intent(inout) :: this + character(len=*), intent(in) :: filename + type(MPI_File) :: ifile + type(MPI_Status):: status + integer(kind=MPI_OFFSET_KIND) :: offset + integer :: i,ierr,iunit + + ! Root serial-writes the file header + if (this%cfg%amRoot) then + ! Open the file + open(newunit=iunit,file=trim(filename),form='unformatted',status='replace',access='stream',iostat=ierr) + if (ierr.ne.0) call die('[lss write] Problem encountered while serial-opening data file: '//trim(filename)) + ! Number of particles and particle object size + write(iunit) this%np,MPI_PART_SIZE + ! Done with the header + close(iunit) + end if + + ! The rest is done in parallel + call MPI_FILE_OPEN(this%cfg%comm,trim(filename),IOR(MPI_MODE_WRONLY,MPI_MODE_APPEND),info_mpiio,ifile,ierr) + if (ierr.ne.0) call die('[lss write] Problem encountered while parallel-opening data file: '//trim(filename)) + + ! Get current position + call MPI_FILE_GET_POSITION(ifile,offset,ierr) + + ! Compute the offset and write + do i=1,this%cfg%rank + offset=offset+int(this%np_proc(i),MPI_OFFSET_KIND)*int(MPI_PART_SIZE,MPI_OFFSET_KIND) + end do + if (this%np_.gt.0) call MPI_FILE_WRITE_AT(ifile,offset,this%p,this%np_,MPI_PART,status,ierr) + + ! Close the file + call MPI_FILE_CLOSE(ifile,ierr) + + ! Log/screen output + logging: block + use, intrinsic :: iso_fortran_env, only: output_unit + use param, only: verbose + use messager, only: log + use string, only: str_long + character(len=str_long) :: message + if (this%cfg%amRoot) then + write(message,'("[lss write] Wrote ",i0," particles to file [",a,"] on partitioned grid [",a,"]")') this%np,trim(filename),trim(this%cfg%name) + if (verbose.gt.2) write(output_unit,'(a)') trim(message) + if (verbose.gt.1) call log(message) + end if + end block logging + + end subroutine write + + + !> Parallel read particles to file + subroutine read(this,filename) + use mpi_f08 + use messager, only: die + use parallel, only: info_mpiio + implicit none + class(lss), intent(inout) :: this + character(len=*), intent(in) :: filename + type(MPI_File) :: ifile + type(MPI_Status):: status + integer(kind=MPI_OFFSET_KIND) :: offset,header_offset + integer :: i,j,ierr,npadd,psize,nchunk,cnt + integer, dimension(:,:), allocatable :: ppp + + ! First open the file in parallel + call MPI_FILE_OPEN(this%cfg%comm,trim(filename),MPI_MODE_RDONLY,info_mpiio,ifile,ierr) + if (ierr.ne.0) call die('[lss read] Problem encountered while reading data file: '//trim(filename)) + + ! Read file header first + call MPI_FILE_READ_ALL(ifile,npadd,1,MPI_INTEGER,status,ierr) + call MPI_FILE_READ_ALL(ifile,psize,1,MPI_INTEGER,status,ierr) + + ! Remember current position + call MPI_FILE_GET_POSITION(ifile,header_offset,ierr) + + ! Check compatibility of particle type + if (psize.ne.MPI_PART_SIZE) call die('[lss read] Particle type unreadable') + + ! Naively share reading task among all processors + nchunk=int(npadd/(this%cfg%nproc*part_chunk_size))+1 + allocate(ppp(this%cfg%nproc,nchunk)) + ppp=int(npadd/(this%cfg%nproc*nchunk)) + cnt=0 + out:do j=1,nchunk + do i=1,this%cfg%nproc + cnt=cnt+1 + if (cnt.gt.mod(npadd,this%cfg%nproc*nchunk)) exit out + ppp(i,j)=ppp(i,j)+1 + end do + end do out + + ! Read by chunk + do j=1,nchunk + ! Find offset + offset=header_offset+int(MPI_PART_SIZE,MPI_OFFSET_KIND)*int(sum(ppp(1:this%cfg%rank,:))+sum(ppp(this%cfg%rank+1,1:j-1)),MPI_OFFSET_KIND) + ! Resize particle array + call this%resize(this%np_+ppp(this%cfg%rank+1,j)) + ! Read this file + call MPI_FILE_READ_AT(ifile,offset,this%p(this%np_+1:this%np_+ppp(this%cfg%rank+1,j)),ppp(this%cfg%rank+1,j),MPI_PART,status,ierr) + ! Most general case: relocate every droplet + do i=this%np_+1,this%np_+ppp(this%cfg%rank+1,j) + this%p(i)%ind=this%cfg%get_ijk_global(this%p(i)%pos,this%p(i)%ind) + end do + ! Exchange all that + call this%sync() + end do + + ! Close the file + call MPI_FILE_CLOSE(ifile,ierr) + + ! Log/screen output + logging: block + use, intrinsic :: iso_fortran_env, only: output_unit + use param, only: verbose + use messager, only: log + use string, only: str_long + character(len=str_long) :: message + if (this%cfg%amRoot) then + write(message,'("[lss read] Read ",i0," particles from file [",a,"] on partitioned grid [",a,"]")') npadd,trim(filename),trim(this%cfg%name) + if (verbose.gt.2) write(output_unit,'(a)') trim(message) + if (verbose.gt.1) call log(message) + end if + end block logging + + end subroutine read + + +end module lss_class diff --git a/examples/NOSB_plate_with_hole_peridigm/src/lsspd_class.f90 b/examples/NOSB_plate_with_hole_peridigm/src/lsspd_class.f90 new file mode 100644 index 000000000..bf5f01250 --- /dev/null +++ b/examples/NOSB_plate_with_hole_peridigm/src/lsspd_class.f90 @@ -0,0 +1,456 @@ +!> Lagrangian solid solver object +!> Attempt at integrating the pdsolver_class without AMR +module lsspd_class + use precision, only: WP + use string, only: str_medium + use config_class, only: config + use ddadi_class, only: ddadi + use mpi_f08, only: MPI_Datatype,MPI_INTEGER8,MPI_INTEGER,MPI_DOUBLE_PRECISION + use NOSB_class, only: pdsolver, PDC_IS_DEAD, PDC_BONDS, PDC_INTEGRATES, PDC_MOVES, pd_partition + implicit none + private + + + ! Expose type/constructor/methods + public :: lss, PDC_MOVES, PDC_IS_DEAD, PDC_BONDS, PDC_INTEGRATES, pd_partition + + + !> Memory adaptation parameter + real(WP), parameter :: coeff_up=1.3_WP !< Particle array size increase factor + real(WP), parameter :: coeff_dn=0.7_WP !< Particle array size decrease factor + + + !> I/O chunk size to read at a time + integer, parameter :: part_chunk_size=1000 !< Read 1000 particles at a time before redistributing + + + !> Lagrangian solid solver object definition + !> Extends the existing pdsolver_class, incorporating the coupling functions + type, extends(pdsolver) :: lss + + ! This config is used for parallelization and for calculating bond/collision forces + class(config), pointer :: cfg + + type(ddadi) :: implicit !< Implicit solver for filtering + + ! Solid volume fraction and momentum + real(WP), dimension(:,:,:), allocatable :: VF !< Volume fraction, cell-centered + real(WP), dimension(:,:,:), allocatable :: VFU !< Solid velocity, U-face + real(WP), dimension(:,:,:), allocatable :: VFV !< Solid velocity, V-face + real(WP), dimension(:,:,:), allocatable :: VFW !< Solid velocity, W-face + + ! CFL numbers + real(WP) :: CFLp_x,CFLp_y,CFLp_z,CFLp_a + + real(WP) :: VFmax !< Volume fraction info + real(WP), dimension(3) :: ibmForce !< Total force due to IBM + + ! Filtering operation + real(WP) :: filter_width !< Characteristic filter width + real(WP), dimension(:,:,:,:), allocatable :: div_x,div_y,div_z !< Divergence operator + real(WP), dimension(:,:,:,:), allocatable :: grd_x,grd_y,grd_z !< Gradient operator + + ! Compatibility with the old non-amr version + integer, dimension(:,:), allocatable :: icell !< Index of cell containing the particle + !< (this might be unnecessary or already exist somewhere, + !< but not in the pdsolver alone I think) + + ! Moving or not (allow flow to setup) + real(WP) :: unfreeze_time + + + contains + procedure :: advance !< Step forward the particle ODEs + procedure :: update_partmesh !< Update a partmesh object using current particles + procedure :: update_VF !< Compute volume fraction + procedure :: filter !< Apply volume filtering to field + ! procedure :: get_cfl + end type lss + + + !> Declare lss constructor + interface lss + procedure constructor + end interface lss + +contains + + + !> Default constructor for Lagrangian solid solver + function constructor(cfg,name) result(self) + implicit none + type(lss) :: self + class(config), target, intent(in) :: cfg + character(len=*), optional :: name + integer :: i,j,k + + ! Set the name for the solver + if (present(name)) self%name=trim(adjustl(name)) + + ! Point to pgrid object + self%cfg=>cfg + + ! ! Initialize MPI derived datatype for a particle + ! call prepare_mpi_part() ! IVM, do we need this still? I think that pdsolver handles communication... + + + ! Allocate VF array on cfg mesh + allocate(self%VF(self%cfg%imino_:self%cfg%imaxo_,self%cfg%jmino_:self%cfg%jmaxo_,self%cfg%kmino_:self%cfg%kmaxo_)); self%VF=0.0_WP + allocate(self%VFU(self%cfg%imino_:self%cfg%imaxo_,self%cfg%jmino_:self%cfg%jmaxo_,self%cfg%kmino_:self%cfg%kmaxo_)); self%VFU=0.0_WP + allocate(self%VFV(self%cfg%imino_:self%cfg%imaxo_,self%cfg%jmino_:self%cfg%jmaxo_,self%cfg%kmino_:self%cfg%kmaxo_)); self%VFV=0.0_WP + allocate(self%VFW(self%cfg%imino_:self%cfg%imaxo_,self%cfg%jmino_:self%cfg%jmaxo_,self%cfg%kmino_:self%cfg%kmaxo_)); self%VFW=0.0_WP + + ! Allocate finite volume divergence operators + allocate(self%div_x(0:+1,self%cfg%imin_:self%cfg%imax_,self%cfg%jmin_:self%cfg%jmax_,self%cfg%kmin_:self%cfg%kmax_)) !< Cell-centered + allocate(self%div_y(0:+1,self%cfg%imin_:self%cfg%imax_,self%cfg%jmin_:self%cfg%jmax_,self%cfg%kmin_:self%cfg%kmax_)) !< Cell-centered + allocate(self%div_z(0:+1,self%cfg%imin_:self%cfg%imax_,self%cfg%jmin_:self%cfg%jmax_,self%cfg%kmin_:self%cfg%kmax_)) !< Cell-centered + ! Create divergence operator to cell center [xm,ym,zm] + do k=self%cfg%kmin_,self%cfg%kmax_ + do j=self%cfg%jmin_,self%cfg%jmax_ + do i=self%cfg%imin_,self%cfg%imax_ + self%div_x(:,i,j,k)=self%cfg%dxi(i)*[-1.0_WP,+1.0_WP] !< Divergence from [x ,ym,zm] + self%div_y(:,i,j,k)=self%cfg%dyi(j)*[-1.0_WP,+1.0_WP] !< Divergence from [xm,y ,zm] + self%div_z(:,i,j,k)=self%cfg%dzi(k)*[-1.0_WP,+1.0_WP] !< Divergence from [xm,ym,z ] + end do + end do + end do + + ! Allocate finite difference velocity gradient operators + allocate(self%grd_x(-1:0,self%cfg%imin_:self%cfg%imax_+1,self%cfg%jmin_:self%cfg%jmax_+1,self%cfg%kmin_:self%cfg%kmax_+1)) !< X-face-centered + allocate(self%grd_y(-1:0,self%cfg%imin_:self%cfg%imax_+1,self%cfg%jmin_:self%cfg%jmax_+1,self%cfg%kmin_:self%cfg%kmax_+1)) !< Y-face-centered + allocate(self%grd_z(-1:0,self%cfg%imin_:self%cfg%imax_+1,self%cfg%jmin_:self%cfg%jmax_+1,self%cfg%kmin_:self%cfg%kmax_+1)) !< Z-face-centered + ! Create gradient coefficients to cell faces + do k=self%cfg%kmin_,self%cfg%kmax_+1 + do j=self%cfg%jmin_,self%cfg%jmax_+1 + do i=self%cfg%imin_,self%cfg%imax_+1 + self%grd_x(:,i,j,k)=self%cfg%dxmi(i)*[-1.0_WP,+1.0_WP] !< Gradient in x from [xm,ym,zm] to [x,ym,zm] + self%grd_y(:,i,j,k)=self%cfg%dymi(j)*[-1.0_WP,+1.0_WP] !< Gradient in y from [xm,ym,zm] to [xm,y,zm] + self%grd_z(:,i,j,k)=self%cfg%dzmi(k)*[-1.0_WP,+1.0_WP] !< Gradient in z from [xm,ym,zm] to [xm,ym,z] + end do + end do + end do + + ! Loop over the domain and zero divergence in walls + do k=self%cfg%kmin_,self%cfg%kmax_ + do j=self%cfg%jmin_,self%cfg%jmax_ + do i=self%cfg%imin_,self%cfg%imax_ + if (self%cfg%VF(i,j,k).eq.0.0_WP) then + self%div_x(:,i,j,k)=0.0_WP + self%div_y(:,i,j,k)=0.0_WP + self%div_z(:,i,j,k)=0.0_WP + end if + end do + end do + end do + + ! Zero out gradient to wall faces + do k=self%cfg%kmin_,self%cfg%kmax_+1 + do j=self%cfg%jmin_,self%cfg%jmax_+1 + do i=self%cfg%imin_,self%cfg%imax_+1 + if (self%cfg%VF(i,j,k).eq.0.0_WP.or.self%cfg%VF(i-1,j,k).eq.0.0_WP) self%grd_x(:,i,j,k)=0.0_WP + if (self%cfg%VF(i,j,k).eq.0.0_WP.or.self%cfg%VF(i,j-1,k).eq.0.0_WP) self%grd_y(:,i,j,k)=0.0_WP + if (self%cfg%VF(i,j,k).eq.0.0_WP.or.self%cfg%VF(i,j,k-1).eq.0.0_WP) self%grd_z(:,i,j,k)=0.0_WP + end do + end do + end do + + ! Adjust metrics to account for lower dimensionality + if (self%cfg%nx.eq.1) then + self%div_x=0.0_WP + self%grd_x=0.0_WP + end if + if (self%cfg%ny.eq.1) then + self%div_y=0.0_WP + self%grd_y=0.0_WP + end if + if (self%cfg%nz.eq.1) then + self%div_z=0.0_WP + self%grd_z=0.0_WP + end if + + ! Create implicit solver object for filtering + self%implicit=ddadi(cfg=self%cfg,name='Filter',nst=7) + self%implicit%stc(1,:)=[ 0, 0, 0] + self%implicit%stc(2,:)=[+1, 0, 0] + self%implicit%stc(3,:)=[-1, 0, 0] + self%implicit%stc(4,:)=[ 0,+1, 0] + self%implicit%stc(5,:)=[ 0,-1, 0] + self%implicit%stc(6,:)=[ 0, 0,+1] + self%implicit%stc(7,:)=[ 0, 0,-1] + call self%implicit%init() + + ! Set default filter width + self%filter_width=1.0_WP*self%cfg%min_meshsize + + ! Log/screen output + logging: block + use, intrinsic :: iso_fortran_env, only: output_unit + use param, only: verbose + use messager, only: log + use string, only: str_long + character(len=str_long) :: message + if (self%cfg%amRoot) then + write(message,'("LSS object [",a,"] on partitioned grid [",a,"]")') trim(self%name),trim(self%cfg%name) + if (verbose.gt.1) write(output_unit,'(a)') trim(message) + if (verbose.gt.0) call log(message) + end if + end block logging + + end function constructor + + + + !> Advance the particle equations by a specified time step dt + subroutine advance(this,dt,unfreeze,div_stress_x,div_stress_y,div_stress_z) + implicit none + class(lss), intent(inout) :: this + real(WP), intent(inout) :: dt !< Timestep size over which to advance + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(inout) :: div_stress_x !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(inout) :: div_stress_y !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(inout) :: div_stress_z !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + integer :: n,i + logical, intent(in) :: unfreeze + + + + do i=1,this%nown + + if (this%flag(i).eq.PDC_IS_DEAD) cycle + ! this%ff(:,i)=this%cfg%get_velocity( & ! we do (div_stress)/rho later to make it acc inside of the pd_advnace routine + ! pos=this%y(:,i), & + ! i0=this%icell(1,i), & + ! j0=this%icell(2,i), & + ! k0=this%icell(3,i), & + ! U=div_stress_x,V=div_stress_y,W=div_stress_z) ! interpolates the divergence of stress to the location of the particle (this term is a force density now) + + this%ff(:,i)=0.0_WP! we do (div_stress)/rho later to make it acc inside of the pd_advnace routine + + end do + call this%pd_advance(dt) ! use fluid forces and compute bond forces, and update position due to verlet scheme + + + ! do i=1,this%nown + ! if (this%flag(i).eq.PDC_IS_DEAD) cycle + + ! this%icell(:,i)=this%cfg%get_ijk_global(this%y(:,i),this%icell(:,i)) ! do we need to do this? + + ! ! if(unfreeze) this%flag(i) = PDC_BONDS + PDC_INTEGRATES + PDC_MOVES + ! end do + + if (unfreeze) then + do i = 1,this%nown + this%damping_rate = 0.0005_WP + if (this%flag(i).eq.(PDC_MOVES+PDC_BONDS)) this%v(:,i)= 0.0_WP + end do + end if + + + + ! call this%update_VF() ! now we update the volume fraction + + + ! Log/screen output (do we need to do this still?) + ! logging: block + ! use, intrinsic :: iso_fortran_env, only: output_unit + ! use param, only: verbose + ! use messager, only: log + ! use string, only: str_long + ! character(len=str_long) :: message + ! if (this%cfg%amRoot) then + ! write(message,'("Particle solver [",a,"] on partitioned grid [",a,"]: ",i0," particles were advanced")') trim(this%name),trim(this%cfg%name),this%np + ! if (verbose.gt.1) write(output_unit,'(a)') trim(message) + ! if (verbose.gt.0) call log(message) + ! end if + ! end block logging + + end subroutine advance + + + !> Update particle volume fraction using our current particles + subroutine update_VF(this) + implicit none + class(lss), intent(inout) :: this + integer :: i + ! Reset volume fraction and momentum + this%VF=0.0_WP; this%VFU=0.0_WP; this%VFV=0.0_WP; this%VFW=0.0_WP + ! Transfer particle volume + do i=1,this%nown ! halo included here? + ! Skip inactive particle + if (this%flag(i).eq.PDC_IS_DEAD) cycle + ! Transfer volume to mesh + call this%cfg%set_scalar(Sp=this%vol(i), pos=this%y(:,i),i0=this%icell(1,i),j0=this%icell(2,i),k0=this%icell(3,i),S=this%VF ,bc='n') + call this%cfg%set_scalar(Sp=this%vol(i)*this%v(1,i), pos=this%y(:,i),i0=this%icell(1,i),j0=this%icell(2,i),k0=this%icell(3,i),S=this%VFU,bc='n') + call this%cfg%set_scalar(Sp=this%vol(i)*this%v(2,i), pos=this%y(:,i),i0=this%icell(1,i),j0=this%icell(2,i),k0=this%icell(3,i),S=this%VFV,bc='n') + call this%cfg%set_scalar(Sp=this%vol(i)*this%v(3,i), pos=this%y(:,i),i0=this%icell(1,i),j0=this%icell(2,i),k0=this%icell(3,i),S=this%VFW,bc='n') + end do + this%VF =this%VF /this%cfg%vol + this%VFU=this%VFU/this%cfg%vol + this%VFV=this%VFV/this%cfg%vol + this%VFW=this%VFW/this%cfg%vol + ! Sum at boundaries + call this%cfg%syncsum(this%VF ) + call this%cfg%syncsum(this%VFU) + call this%cfg%syncsum(this%VFV) + call this%cfg%syncsum(this%VFW) + ! Apply volume filter + call this%filter(this%VF ) + call this%filter(this%VFU) + call this%filter(this%VFV) + call this%filter(this%VFW) + ! Clip + where (this%VF.lt.0.0_WP) this%VF=0.0_WP + this%VF=min(this%VF,1.0_WP-epsilon(1.0_WP)) + + end subroutine update_VF + + ! subroutine get_cfl(this,dt,cfl) + ! use mpi_f08, only: MPI_ALLREDUCE,MPI_MAX + ! use parallel, only: MPI_REAL_WP + ! implicit none + ! class(lss), intent(inout) :: this + ! real(WP), intent(in) :: dt + ! real(WP), intent(out) :: cfl + ! integer :: i,ierr + ! real(WP) :: my_CFLp_x,my_CFLp_y,my_CFLp_z,kk,mu,a + + ! ! Set the CFLs to zero + ! my_CFLp_x=0.0_WP; my_CFLp_y=0.0_WP; my_CFLp_z=0.0_WP + ! do i=1,this%nown + ! my_CFLp_x=max(my_CFLp_x,abs(this%v(1,i))*this%cfg%dxi(this%icell(1,i))) + ! my_CFLp_y=max(my_CFLp_y,abs(this%v(2,i))*this%cfg%dyi(this%icell(2,i))) + ! my_CFLp_z=max(my_CFLp_z,abs(this%v(3,i))*this%cfg%dzi(this%icell(3,i))) + ! end do + ! my_CFLp_x=my_CFLp_x*dt; my_CFLp_y=my_CFLp_y*dt; my_CFLp_z=my_CFLp_z*dt + + ! ! Get the parallel max + ! call MPI_ALLREDUCE(my_CFLp_x,this%CFLp_x,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + ! call MPI_ALLREDUCE(my_CFLp_y,this%CFLp_y,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + ! call MPI_ALLREDUCE(my_CFLp_z,this%CFLp_z,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + + ! ! CFL based on elastic wave speed in material + ! kk=this%elastic_modulus/(3.0_WP-6.0_WP*this%poisson_ratio) + ! mu=this%elastic_modulus/(2.0_WP+2.0_WP*this%poisson_ratio) + ! a=sqrt((kk+4.0_WP*mu/3.0_WP)/this%rho) + ! this%CFLp_a=dt*a/this%delta + + ! ! Return the maximum CFL + ! cfl=max(this%CFLp_x,this%CFLp_y,this%CFLp_z,this%CFLp_a) + + ! end subroutine get_cfl + + + !> Laplacian filtering operation + subroutine filter(this,A) + implicit none + class(lss), intent(inout) :: this + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(inout) :: A !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + real(WP) :: filter_coeff + integer :: i,j,k,n,nstep + real(WP), dimension(:,:,:), allocatable :: FX,FY,FZ + + ! Recompute filter coefficient + filter_coeff=max(this%filter_width**2-this%cfg%min_meshsize**2,0.0_WP)/(16.0_WP*log(2.0_WP)) + if (filter_coeff.le.0.0_WP) return + + ! Allocate flux arrays + allocate(FX(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + allocate(FY(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + allocate(FZ(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + + if (.not.this%implicit%setup_done) then + ! Prepare diffusive operator (only need to do this once) + do k=this%cfg%kmin_,this%cfg%kmax_ + do j=this%cfg%jmin_,this%cfg%jmax_ + do i=this%cfg%imin_,this%cfg%imax_ + this%implicit%opr(1,i,j,k)=1.0_WP-(this%div_x(+1,i,j,k)*filter_coeff*this%grd_x(-1,i+1,j,k)+& + & this%div_x( 0,i,j,k)*filter_coeff*this%grd_x( 0,i ,j,k)+& + & this%div_y(+1,i,j,k)*filter_coeff*this%grd_y(-1,i,j+1,k)+& + & this%div_y( 0,i,j,k)*filter_coeff*this%grd_y( 0,i,j ,k)+& + & this%div_z(+1,i,j,k)*filter_coeff*this%grd_z(-1,i,j,k+1)+& + & this%div_z( 0,i,j,k)*filter_coeff*this%grd_z( 0,i,j,k )) + this%implicit%opr(2,i,j,k)= -(this%div_x(+1,i,j,k)*filter_coeff*this%grd_x( 0,i+1,j,k)) + this%implicit%opr(3,i,j,k)= -(this%div_x( 0,i,j,k)*filter_coeff*this%grd_x(-1,i ,j,k)) + this%implicit%opr(4,i,j,k)= -(this%div_y(+1,i,j,k)*filter_coeff*this%grd_y( 0,i,j+1,k)) + this%implicit%opr(5,i,j,k)= -(this%div_y( 0,i,j,k)*filter_coeff*this%grd_y(-1,i,j ,k)) + this%implicit%opr(6,i,j,k)= -(this%div_z(+1,i,j,k)*filter_coeff*this%grd_z( 0,i,j,k+1)) + this%implicit%opr(7,i,j,k)= -(this%div_z( 0,i,j,k)*filter_coeff*this%grd_z(-1,i,j,k )) + end do + end do + end do + end if + ! Explicit step + do k=this%cfg%kmin_,this%cfg%kmax_+1 + do j=this%cfg%jmin_,this%cfg%jmax_+1 + do i=this%cfg%imin_,this%cfg%imax_+1 + FX(i,j,k)=filter_coeff*sum(this%grd_x(:,i,j,k)*A(i-1:i,j,k)) + FY(i,j,k)=filter_coeff*sum(this%grd_y(:,i,j,k)*A(i,j-1:j,k)) + FZ(i,j,k)=filter_coeff*sum(this%grd_z(:,i,j,k)*A(i,j,k-1:k)) + end do + end do + end do + do k=this%cfg%kmin_,this%cfg%kmax_ + do j=this%cfg%jmin_,this%cfg%jmax_ + do i=this%cfg%imin_,this%cfg%imax_ + this%implicit%rhs(i,j,k)=sum(this%div_x(:,i,j,k)*FX(i:i+1,j,k))+sum(this%div_y(:,i,j,k)*FY(i,j:j+1,k))+sum(this%div_z(:,i,j,k)*FZ(i,j,k:k+1)) + end do + end do + end do + ! Implicit step + call this%implicit%setup() + this%implicit%sol=0.0_WP + call this%implicit%solve() + A=A+this%implicit%sol + call this%cfg%sync(A) + + ! Deallocate flux arrays + deallocate(FX,FY,FZ) + + end subroutine filter + + !> Update particle mesh using our current particles + subroutine update_partmesh(this,pmesh) + use partmesh_class, only: partmesh + implicit none + class(lss), intent(inout) :: this + class(partmesh), intent(inout) :: pmesh + integer :: i + ! Reset particle mesh storage + call pmesh%reset() + ! Nothing else to do if no particle is present + if (this%nown.eq.0) return + ! Copy particle info + call pmesh%set_size(this%nown) + do i=1,this%nown !< IVM, this might not be good, I think we will get duplicates this way + pmesh%pos(:,i)=this%y(:,i) + end do + end subroutine update_partmesh + + + ! !> Creation of the MPI datatype for particle ! IVM, Maybe we dont need this, since comm is handled by pdsolver? + ! subroutine prepare_mpi_part() + ! use mpi_f08 + ! use messager, only: die + ! implicit none + ! integer(MPI_ADDRESS_KIND), dimension(part_nblock) :: disp + ! integer(MPI_ADDRESS_KIND) :: lb,extent + ! type(MPI_Datatype) :: MPI_PART_TMP + ! integer :: i,mysize,ierr + ! ! Prepare the displacement array + ! disp(1)=0 + ! do i=2,part_nblock + ! call MPI_Type_size(part_tblock(i-1),mysize,ierr) + ! disp(i)=disp(i-1)+int(mysize,MPI_ADDRESS_KIND)*int(part_lblock(i-1),MPI_ADDRESS_KIND) + ! end do + ! ! Create and commit the new type + ! call MPI_Type_create_struct(part_nblock,part_lblock,disp,part_tblock,MPI_PART_TMP,ierr) + ! call MPI_Type_get_extent(MPI_PART_TMP,lb,extent,ierr) + ! call MPI_Type_create_resized(MPI_PART_TMP,lb,extent,MPI_PART,ierr) + ! call MPI_Type_commit(MPI_PART,ierr) + ! ! If a problem was encountered, say it + ! if (ierr.ne.0) call die('[lss prepare_mpi_part] MPI Particle type creation failed') + ! ! Get the size of this type + ! call MPI_type_size(MPI_PART,MPI_PART_SIZE,ierr) + ! end subroutine prepare_mpi_part + + +end module lsspd_class diff --git a/examples/NOSB_plate_with_hole_peridigm/src/pdhalo_class.f90 b/examples/NOSB_plate_with_hole_peridigm/src/pdhalo_class.f90 new file mode 100644 index 000000000..7a8b88239 --- /dev/null +++ b/examples/NOSB_plate_with_hole_peridigm/src/pdhalo_class.f90 @@ -0,0 +1,555 @@ +!> Persistent graph-halo communication for the peridynamics solver (pdsolver). +!> +!> Two objects: +!> pddir -- distributed GID directory. Owner-rank resolution for arbitrary +!> global ids via a hashed home-rank protocol (Fibonacci-mixed: +!> raw mod collapses on structured idcpu keys). +!> Built once at init, used during plan construction, then discarded. +!> pdhalo -- persistent halo exchange plan. A halo SLOT is a (gid, image-offset) +!> pair: a node bonded to two periodic images of the same partner +!> gets two slots with different shifts. Shifts are applied at +!> unpack time on the receiver, so send buffers are pure copies and +!> the same owned node can serve any number of slots/images. +!> Two operations per substep: +!> update(field) -- owner values -> halo slots (positions get +shift) +!> reduce(field) -- halo-slot accumulations -> add back into owners +!> Both are nonblocking isend/irecv with fixed, deterministic +!> pack/unpack order (neighbor rank ascending, slot order within). +!> +!> Self-rank "neighbors" (periodic self-images or same-rank image bonds) are +!> handled uniformly through MPI self-messages -- no special-case code path. +module pdhalo_class + use precision, only: WP,I8 + use mpi_f08 + implicit none + private + + public :: pddir,pdhalo,sort3_perm,PDHALO_KEY0 + + !> Packed zero image offset ((0+128) + (0+128)*256 + (0+128)*65536), + !> matching amrpd's hist1 convention. + integer, parameter :: PDHALO_KEY0=8421504 + + !> Distributed GID directory (hashed home-rank protocol) + type :: pddir + integer :: n=0 !< number of gids homed on this rank + integer(I8), allocatable :: keys(:) !< gids homed on this rank (sorted) + integer, allocatable :: owner(:) !< owner rank per homed gid (aligned with keys) + contains + procedure :: register + procedure :: query + procedure :: finalize => dir_finalize + end type pddir + + !> Persistent halo plan + exchange buffers + type :: pdhalo + integer :: nown=0 !< owned nodes (halo slots are indexed nown+1..nown+nhalo) + integer :: nhalo=0 !< halo slot count + ! Receive side: whom I receive halo data from (= owners of my slots) + integer :: nrecv=0 + integer, allocatable :: nbr_recv(:) !< source ranks, ascending + integer, allocatable :: recv_ptr(:) !< (nrecv+1) slot group offsets + ! Send side: whom I send owned data to (= ranks holding slots of my nodes) + integer :: nsend=0 + integer, allocatable :: nbr_send(:) !< destination ranks, ascending + integer, allocatable :: send_ptr(:) !< (nsend+1) entry group offsets + integer, allocatable :: send_idx(:) !< owned node index per send entry (duplicates allowed: one per remote slot) + ! Per-slot image shift (added to position components at unpack) + real(WP), allocatable :: shift(:,:) !< (3,nhalo) + ! Persistent message buffers (grown on demand) + real(WP), allocatable :: sbuf(:),rbuf(:) + contains + procedure :: build + procedure :: update + procedure :: update1 + procedure :: reduce + procedure :: finalize => halo_finalize + end type pdhalo + +contains + + + ! =========================================================================== + ! Sorting utility: recursive quicksort of a permutation over a triple key + ! (a int, g int64, k int), ordered lexicographically. Used for deterministic + ! halo-slot and CSR ordering. a is typically an owner rank or a node index. + ! =========================================================================== + recursive subroutine sort3_perm(a,g,k,perm,lo,hi) + implicit none + integer, intent(in) :: a(:) + integer(I8), intent(in) :: g(:) + integer, intent(in) :: k(:) + integer, intent(inout) :: perm(:) + integer, intent(in) :: lo,hi + integer :: i,j,tp,pv + if (lo.ge.hi) return + pv=perm((lo+hi)/2) + i=lo; j=hi + do + do while (less3(perm(i),pv)); i=i+1; end do + do while (less3(pv,perm(j))); j=j-1; end do + if (i.le.j) then + tp=perm(i); perm(i)=perm(j); perm(j)=tp + i=i+1; j=j-1 + end if + if (i.gt.j) exit + end do + call sort3_perm(a,g,k,perm,lo,j) + call sort3_perm(a,g,k,perm,i,hi) + contains + logical function less3(p,q) + integer, intent(in) :: p,q + if (a(p).ne.a(q)) then + less3=a(p).lt.a(q) + else if (g(p).ne.g(q)) then + less3=g(p).lt.g(q) + else + less3=k(p).lt.k(q) + end if + end function less3 + end subroutine sort3_perm + + + ! =========================================================================== + ! PDDIR -- distributed GID directory + ! =========================================================================== + + !> Register this rank's owned gids with their home ranks. Collective. + subroutine register(this,n,gids) + use parallel, only: comm,rank,nproc + use pdhash_class, only: gid_hash + implicit none + class(pddir), intent(inout) :: this + integer, intent(in) :: n + integer(I8), intent(in) :: gids(:) + integer, dimension(0:nproc-1) :: sc,rc,sd,rd + integer(I8), allocatable :: sg(:),rg(:) + integer, allocatable :: pos(:) + integer :: i,h,nr,r,ierr + ! Count per home rank + sc=0 + do i=1,n + h=home(gids(i)); sc(h)=sc(h)+1 + end do + call MPI_ALLTOALL(sc,1,MPI_INTEGER,rc,1,MPI_INTEGER,comm,ierr) + sd(0)=0; rd(0)=0 + do r=1,nproc-1 + sd(r)=sd(r-1)+sc(r-1); rd(r)=rd(r-1)+rc(r-1) + end do + ! Pack and exchange gids + allocate(sg(max(n,1)),pos(0:nproc-1)) + pos=sd + do i=1,n + h=home(gids(i)); pos(h)=pos(h)+1; sg(pos(h))=gids(i) + end do + nr=sum(rc) + allocate(rg(max(nr,1))) + call MPI_ALLTOALLV(sg,sc,sd,MPI_INTEGER8,rg,rc,rd,MPI_INTEGER8,comm,ierr) + deallocate(sg,pos) + ! Store: owner of each received gid = the rank it arrived from + this%n=nr + allocate(this%keys(max(nr,1)),this%owner(max(nr,1))) + this%keys(1:nr)=rg(1:nr) + do r=0,nproc-1 + do i=rd(r)+1,rd(r)+rc(r) + this%owner(i)=r + end do + end do + ! Sort keys with the owner array following (simple perm sort) + sort_dir: block + integer, allocatable :: perm(:),zk(:),ow(:) + integer(I8), allocatable :: kk(:) + integer :: m + m=nr + if (m.gt.0) then + allocate(perm(m),zk(m),ow(m),kk(m)) + do i=1,m + perm(i)=i + end do + zk=0 + call sort3_perm(zk,this%keys(1:m),zk,perm,1,m) + kk=this%keys(1:m); ow=this%owner(1:m) + do i=1,m + this%keys(i) =kk(perm(i)) + this%owner(i)=ow(perm(i)) + end do + deallocate(perm,zk,ow,kk) + end if + end block sort_dir + deallocate(rg) + end subroutine register + + !> Resolve owner ranks for m gids. Collective. Dies on unknown gid. + subroutine query(this,m,gids,owners) + use parallel, only: comm,nproc + use messager, only: die + implicit none + class(pddir), intent(in) :: this + integer, intent(in) :: m + integer(I8), intent(in) :: gids(:) + integer, intent(out) :: owners(:) + integer, dimension(0:nproc-1) :: sc,rc,sd,rd + integer(I8), allocatable :: sg(:),rg(:) + integer, allocatable :: pos(:),qpos(:),rans(:),reply(:) + integer :: i,h,nr,r,idx,ierr + ! Count and pack queries by home rank; remember each query's packed slot + sc=0 + do i=1,m + h=home(gids(i)); sc(h)=sc(h)+1 + end do + call MPI_ALLTOALL(sc,1,MPI_INTEGER,rc,1,MPI_INTEGER,comm,ierr) + sd(0)=0; rd(0)=0 + do r=1,nproc-1 + sd(r)=sd(r-1)+sc(r-1); rd(r)=rd(r-1)+rc(r-1) + end do + allocate(sg(max(m,1)),pos(0:nproc-1),qpos(max(m,1))) + pos=sd + do i=1,m + h=home(gids(i)); pos(h)=pos(h)+1; sg(pos(h))=gids(i); qpos(i)=pos(h) + end do + nr=sum(rc) + allocate(rg(max(nr,1))) + call MPI_ALLTOALLV(sg,sc,sd,MPI_INTEGER8,rg,rc,rd,MPI_INTEGER8,comm,ierr) + ! Answer each received query by binary search of the sorted directory + allocate(rans(max(nr,1))) + do i=1,nr + idx=dir_lookup(this,rg(i)) + if (idx.lt.1) call die('[pddir query] gid not found in directory') + rans(i)=this%owner(idx) + end do + ! Send answers back along the reverse route (counts swapped) + allocate(reply(max(m,1))) + call MPI_ALLTOALLV(rans,rc,rd,MPI_INTEGER,reply,sc,sd,MPI_INTEGER,comm,ierr) + do i=1,m + owners(i)=reply(qpos(i)) + end do + deallocate(sg,rg,pos,qpos,rans,reply) + end subroutine query + + !> Binary search of the sorted directory keys. Returns index or -1. + pure function dir_lookup(this,key) result(idx) + implicit none + class(pddir), intent(in) :: this + integer(I8), intent(in) :: key + integer :: idx,lo,hi,mid + idx=-1 + if (.not.allocated(this%keys).or.this%n.eq.0) return + lo=1; hi=this%n + do while (lo.le.hi) + mid=(lo+hi)/2 + if (this%keys(mid).lt.key) then + lo=mid+1 + else if (this%keys(mid).gt.key) then + hi=mid-1 + else + idx=mid + return + end if + end do + end function dir_lookup + + !> Release directory storage + subroutine dir_finalize(this) + implicit none + class(pddir), intent(inout) :: this + if (allocated(this%keys)) deallocate(this%keys) + if (allocated(this%owner)) deallocate(this%owner) + this%n=0 + end subroutine dir_finalize + + !> Home rank of a gid. Keys are STRUCTURED (AMReX idcpu = id<<24|cpu: raw + !> mod collapses onto few ranks -- all of them rank 0 for power-of-two + !> nproc when cpu=0), so mix the bits first (Fibonacci hash; the multiply + !> wraps by design, and the logical shift keeps the result nonnegative). + pure function home(gid) result(h) + use parallel, only: nproc + implicit none + integer(I8), intent(in) :: gid + integer :: h + integer(I8) :: k + k=gid*(-7046029254386353131_I8) + h=int(mod(ishft(k,-40),int(nproc,I8))) + end function home + + + ! =========================================================================== + ! PDHALO -- persistent halo plan + ! =========================================================================== + + !> Build the halo plan. Collective. + !> nown : owned node count (slots index from nown+1) + !> ohash : gid->owned-index hash over this rank's owned gids + !> nreq : number of UNIQUE remote references (gid, image-key) pairs + !> rgid/rkey: the references (key packs the image offset, amrpd hist1 style) + !> rowner : owner rank of each reference's gid (from pddir%query) + !> Ldom/per : domain lengths and periodicity (for shift vectors) + !> slot : OUT -- final halo slot (1..nhalo) of each input reference + subroutine build(this,nown,ohash,nreq,rgid,rkey,rowner,Ldom,per,slot) + use parallel, only: comm,nproc + use messager, only: die + use pdhash_class, only: gid_hash + implicit none + class(pdhalo), intent(inout) :: this + integer, intent(in) :: nown,nreq + type(gid_hash), intent(in) :: ohash + integer(I8), intent(in) :: rgid(:) + integer, intent(in) :: rkey(:),rowner(:) + real(WP), intent(in) :: Ldom(3) + logical, intent(in) :: per(3) + integer, intent(out) :: slot(:) + integer, allocatable :: perm(:) + integer, dimension(0:nproc-1) :: sc,rc,sd,rd + integer :: i,s,r,n1,n2,n3,ierr,nr,lid + integer(I8), allocatable :: sg(:),rg(:) + + this%nown=nown + this%nhalo=nreq + + ! Deterministic slot order: sort references by (owner, gid, key) + allocate(perm(max(nreq,1))) + do i=1,nreq + perm(i)=i + end do + if (nreq.gt.1) call sort3_perm(rowner,rgid,rkey,perm,1,nreq) + do s=1,nreq + slot(perm(s))=s + end do + + ! Receive groups (one per distinct owner, ascending by construction) + count_recv: block + integer :: prev + this%nrecv=0; prev=-1 + do s=1,nreq + if (rowner(perm(s)).ne.prev) then + this%nrecv=this%nrecv+1; prev=rowner(perm(s)) + end if + end do + allocate(this%nbr_recv(max(this%nrecv,1)),this%recv_ptr(this%nrecv+1)) + this%nrecv=0; prev=-1 + do s=1,nreq + if (rowner(perm(s)).ne.prev) then + this%nrecv=this%nrecv+1; prev=rowner(perm(s)) + this%nbr_recv(this%nrecv)=prev + this%recv_ptr(this%nrecv)=s + end if + end do + this%recv_ptr(this%nrecv+1)=nreq+1 + end block count_recv + + ! Per-slot shift vectors from the packed image key + allocate(this%shift(3,max(nreq,1))) + do s=1,nreq + i=perm(s) + n1=mod(rkey(i),256)-128; n2=mod(rkey(i)/256,256)-128; n3=rkey(i)/65536-128 + if ((n1.ne.0.and..not.per(1)).or.(n2.ne.0.and..not.per(2)).or.(n3.ne.0.and..not.per(3))) & + & call die('[pdhalo build] nonzero image offset along a non-periodic direction') + this%shift(1,s)=real(n1,WP)*Ldom(1) + this%shift(2,s)=real(n2,WP)*Ldom(2) + this%shift(3,s)=real(n3,WP)*Ldom(3) + end do + + ! Tell every owner which of its nodes we need (gids in slot order). + ! Payload order within each destination = our slot order, and MPI + ! preserves per-pair message order, so the owner's send list built in + ! arrival order matches our slot order exactly. + sc=0 + do s=1,nreq + sc(rowner(perm(s)))=sc(rowner(perm(s)))+1 + end do + call MPI_ALLTOALL(sc,1,MPI_INTEGER,rc,1,MPI_INTEGER,comm,ierr) + sd(0)=0; rd(0)=0 + do r=1,nproc-1 + sd(r)=sd(r-1)+sc(r-1); rd(r)=rd(r-1)+rc(r-1) + end do + allocate(sg(max(nreq,1))) + do s=1,nreq + sg(s)=rgid(perm(s)) ! grouped by owner because slots are owner-sorted + end do + nr=sum(rc) + allocate(rg(max(nr,1))) + call MPI_ALLTOALLV(sg,sc,sd,MPI_INTEGER8,rg,rc,rd,MPI_INTEGER8,comm,ierr) + + ! Send groups: ranks that requested nodes from me + count_send: block + integer :: g + this%nsend=count(rc.gt.0) + allocate(this%nbr_send(max(this%nsend,1)),this%send_ptr(this%nsend+1)) + allocate(this%send_idx(max(nr,1))) + g=0; this%send_ptr(1)=1 + do r=0,nproc-1 + if (rc(r).gt.0) then + g=g+1 + this%nbr_send(g)=r + this%send_ptr(g+1)=this%send_ptr(g)+rc(r) + do i=rd(r)+1,rd(r)+rc(r) + lid=ohash%lookup(rg(i)) + if (lid.lt.1) call die('[pdhalo build] halo request for a gid this rank does not own') + this%send_idx(this%send_ptr(g)+(i-rd(r)-1))=lid + end do + end if + end do + end block count_send + + deallocate(perm,sg,rg) + end subroutine build + + !> Refresh halo slots with current owner values: field(:,1:nown) -> slots. + !> field is (ncomp, nown+nhalo). If shifted, per-slot image shifts are added + !> to components 1:3 (positions). Deterministic unpack order. + subroutine update(this,field,ncomp,shifted) + use parallel, only: comm,MPI_REAL_WP + use messager, only: die + implicit none + class(pdhalo), intent(inout) :: this + real(WP), intent(inout) :: field(:,:) + integer, intent(in) :: ncomp + logical, intent(in) :: shifted + type(MPI_Request), allocatable :: reqs(:) + integer :: i,g,s,off,cnt,nrq,ierr + integer :: nsend_tot + if (shifted.and.ncomp.lt.3) call die('[pdhalo update] shifted update requires ncomp>=3') + nsend_tot=this%send_ptr(this%nsend+1)-1 + call ensure_buffers(this,ncomp*max(nsend_tot,1),ncomp*max(this%nhalo,1)) + allocate(reqs(this%nrecv+this%nsend)) + nrq=0 + ! Post receives (one message per source rank) + do g=1,this%nrecv + off=ncomp*(this%recv_ptr(g)-1) + cnt=ncomp*(this%recv_ptr(g+1)-this%recv_ptr(g)) + nrq=nrq+1 + call MPI_IRECV(this%rbuf(off+1:off+cnt),cnt,MPI_REAL_WP,this%nbr_recv(g),101,comm,reqs(nrq),ierr) + end do + ! Pack and send (one message per destination rank) + do g=1,this%nsend + off=ncomp*(this%send_ptr(g)-1) + do i=this%send_ptr(g),this%send_ptr(g+1)-1 + this%sbuf(off+ncomp*(i-this%send_ptr(g))+1:off+ncomp*(i-this%send_ptr(g))+ncomp)=field(1:ncomp,this%send_idx(i)) + end do + cnt=ncomp*(this%send_ptr(g+1)-this%send_ptr(g)) + nrq=nrq+1 + call MPI_ISEND(this%sbuf(off+1:off+cnt),cnt,MPI_REAL_WP,this%nbr_send(g),101,comm,reqs(nrq),ierr) + end do + call MPI_WAITALL(nrq,reqs,MPI_STATUSES_IGNORE,ierr) + ! Unpack into halo slots (slot s lives at field index nown+s) + do s=1,this%nhalo + field(1:ncomp,this%nown+s)=this%rbuf(ncomp*(s-1)+1:ncomp*(s-1)+ncomp) + end do + if (shifted) then + do s=1,this%nhalo + field(1:3,this%nown+s)=field(1:3,this%nown+s)+this%shift(1:3,s) + end do + end if + deallocate(reqs) + end subroutine update + + !> Scalar-field variant of update (no shift): owner values -> halo slots. + !> Used for static per-node scalars (e.g., nodal volume) filled once at init. + subroutine update1(this,field) + use parallel, only: comm,MPI_REAL_WP + implicit none + class(pdhalo), intent(inout) :: this + real(WP), intent(inout) :: field(:) + type(MPI_Request), allocatable :: reqs(:) + integer :: i,g,s,off,cnt,nrq,ierr + integer :: nsend_tot + nsend_tot=this%send_ptr(this%nsend+1)-1 + call ensure_buffers(this,max(nsend_tot,1),max(this%nhalo,1)) + allocate(reqs(this%nrecv+this%nsend)) + nrq=0 + do g=1,this%nrecv + off=this%recv_ptr(g)-1 + cnt=this%recv_ptr(g+1)-this%recv_ptr(g) + nrq=nrq+1 + call MPI_IRECV(this%rbuf(off+1:off+cnt),cnt,MPI_REAL_WP,this%nbr_recv(g),103,comm,reqs(nrq),ierr) + end do + do g=1,this%nsend + off=this%send_ptr(g)-1 + do i=this%send_ptr(g),this%send_ptr(g+1)-1 + this%sbuf(i)=field(this%send_idx(i)) + end do + cnt=this%send_ptr(g+1)-this%send_ptr(g) + nrq=nrq+1 + call MPI_ISEND(this%sbuf(off+1:off+cnt),cnt,MPI_REAL_WP,this%nbr_send(g),103,comm,reqs(nrq),ierr) + end do + call MPI_WAITALL(nrq,reqs,MPI_STATUSES_IGNORE,ierr) + do s=1,this%nhalo + field(this%nown+s)=this%rbuf(s) + end do + deallocate(reqs) + end subroutine update1 + + !> Add halo-slot accumulations back into their owners: slots -> field(:,1:nown). + !> Reverse of update: slot data flows to the owner, which adds it into the + !> owned entries listed in send_idx. Deterministic add order (group order, + !> then entry order within group). + subroutine reduce(this,field,ncomp) + use parallel, only: comm,MPI_REAL_WP + implicit none + class(pdhalo), intent(inout) :: this + real(WP), intent(inout) :: field(:,:) + integer, intent(in) :: ncomp + type(MPI_Request), allocatable :: reqs(:) + integer :: i,g,s,off,cnt,nrq,ierr + integer :: nsend_tot + nsend_tot=this%send_ptr(this%nsend+1)-1 + ! Buffers: sending nhalo slots, receiving nsend_tot contributions + call ensure_buffers(this,ncomp*max(this%nhalo,1),ncomp*max(nsend_tot,1)) + allocate(reqs(this%nrecv+this%nsend)) + nrq=0 + ! Post receives along the send-plan links (contributions to my owned nodes) + do g=1,this%nsend + off=ncomp*(this%send_ptr(g)-1) + cnt=ncomp*(this%send_ptr(g+1)-this%send_ptr(g)) + nrq=nrq+1 + call MPI_IRECV(this%rbuf(off+1:off+cnt),cnt,MPI_REAL_WP,this%nbr_send(g),102,comm,reqs(nrq),ierr) + end do + ! Pack halo slots and send to their owners along the recv-plan links + do g=1,this%nrecv + off=ncomp*(this%recv_ptr(g)-1) + do s=this%recv_ptr(g),this%recv_ptr(g+1)-1 + this%sbuf(off+ncomp*(s-this%recv_ptr(g))+1:off+ncomp*(s-this%recv_ptr(g))+ncomp)=field(1:ncomp,this%nown+s) + end do + cnt=ncomp*(this%recv_ptr(g+1)-this%recv_ptr(g)) + nrq=nrq+1 + call MPI_ISEND(this%sbuf(off+1:off+cnt),cnt,MPI_REAL_WP,this%nbr_recv(g),102,comm,reqs(nrq),ierr) + end do + call MPI_WAITALL(nrq,reqs,MPI_STATUSES_IGNORE,ierr) + ! Accumulate received contributions into owned nodes + do i=1,nsend_tot + field(1:ncomp,this%send_idx(i))=field(1:ncomp,this%send_idx(i))+this%rbuf(ncomp*(i-1)+1:ncomp*(i-1)+ncomp) + end do + deallocate(reqs) + end subroutine reduce + + !> Grow persistent buffers on demand + subroutine ensure_buffers(this,ns,nr) + implicit none + class(pdhalo), intent(inout) :: this + integer, intent(in) :: ns,nr + if (allocated(this%sbuf)) then + if (size(this%sbuf).lt.ns) deallocate(this%sbuf) + end if + if (.not.allocated(this%sbuf)) allocate(this%sbuf(ns)) + if (allocated(this%rbuf)) then + if (size(this%rbuf).lt.nr) deallocate(this%rbuf) + end if + if (.not.allocated(this%rbuf)) allocate(this%rbuf(nr)) + end subroutine ensure_buffers + + !> Release plan storage + subroutine halo_finalize(this) + implicit none + class(pdhalo), intent(inout) :: this + if (allocated(this%nbr_recv)) deallocate(this%nbr_recv) + if (allocated(this%recv_ptr)) deallocate(this%recv_ptr) + if (allocated(this%nbr_send)) deallocate(this%nbr_send) + if (allocated(this%send_ptr)) deallocate(this%send_ptr) + if (allocated(this%send_idx)) deallocate(this%send_idx) + if (allocated(this%shift)) deallocate(this%shift) + if (allocated(this%sbuf)) deallocate(this%sbuf) + if (allocated(this%rbuf)) deallocate(this%rbuf) + this%nown=0; this%nhalo=0; this%nrecv=0; this%nsend=0 + end subroutine halo_finalize + + +end module pdhalo_class diff --git a/examples/NOSB_plate_with_hole_peridigm/src/pdhash_class.f90 b/examples/NOSB_plate_with_hole_peridigm/src/pdhash_class.f90 new file mode 100644 index 000000000..7d7e4d197 --- /dev/null +++ b/examples/NOSB_plate_with_hole_peridigm/src/pdhash_class.f90 @@ -0,0 +1,155 @@ +!> GID -> LID hash (sorted array + binary search; build O(N log N), lookup +!> O(log N)). Used by pdsolver for owned-node gid resolution and halo-plan +!> construction. +module pdhash_class + use iso_c_binding, only: c_int64_t + implicit none + private + + public :: gid_hash + + !> Sorted (key, val) pairs. Key is a unique int64 GID; val is the 1-based + !> local index into the source particle array. + type :: gid_hash + integer(c_int64_t), allocatable :: keys(:) + integer, allocatable :: vals(:) + integer :: n = 0 + contains + procedure :: build + procedure :: lookup + procedure :: lookup_range !< For periodic-image disambiguation: returns ALL duplicates of a key + procedure :: finalize + end type gid_hash + +contains + + !> Build a sorted hash from an array of keys. Values are assigned 1..n + !> (the LIDs in the source array). Caller supplies the key array; this + !> routine copies and sorts. + subroutine build(this,n,keys) + implicit none + class(gid_hash), intent(inout) :: this + integer, intent(in) :: n + integer(c_int64_t), intent(in) :: keys(n) + integer :: i + call this%finalize() + this%n = n + if (n.gt.0) then + allocate(this%keys(n),this%vals(n)) + this%keys = keys + do i = 1, n + this%vals(i) = i + end do + call quicksort_pair(this%keys,this%vals,1,n) + end if + end subroutine build + + !> Look up a key. Returns the 1-based LID on hit, -1 on miss. + pure function lookup(this,key) result(lid) + implicit none + class(gid_hash), intent(in) :: this + integer(c_int64_t), intent(in) :: key + integer :: lid + integer :: lo,hi,mid + lid = -1 + if (this%n.eq.0) return + lo = 1; hi = this%n + do while (lo.le.hi) + mid = (lo + hi) / 2 + if (this%keys(mid).lt.key) then + lo = mid + 1 + else if (this%keys(mid).gt.key) then + hi = mid - 1 + else + lid = this%vals(mid) + return + end if + end do + end function lookup + + !> Find the contiguous bracket of duplicates for a given key in the sorted + !> array. Returns first_idx (1-based) and n_dup. On miss, n_dup = 0. + !> + !> Use case: periodic-image disambiguation. When the hash is built from a + !> particle array that contains both an owned particle and its periodic- + !> image ghost copy (which share the same idcpu = key), multiple entries + !> exist. The caller walks the bracket [first_idx .. first_idx+n_dup-1] + !> in self%vals to get all candidate LIDs, then picks the right image by + !> minimum-image distance to an anchor position. + !> + !> Common case (no duplicates): n_dup = 1, self%vals(first_idx) is the LID. + pure subroutine lookup_range(this,key,first_idx,n_dup) + implicit none + class(gid_hash), intent(in) :: this + integer(c_int64_t), intent(in) :: key + integer, intent(out) :: first_idx,n_dup + integer :: lo,hi,mid,i,j + first_idx = -1; n_dup = 0 + if (this%n.eq.0) return + ! Binary search for any matching index + lo = 1; hi = this%n + mid = -1 + do while (lo.le.hi) + mid = (lo + hi) / 2 + if (this%keys(mid).lt.key) then + lo = mid + 1 + else if (this%keys(mid).gt.key) then + hi = mid - 1 + else + exit + end if + end do + if (mid.lt.1.or.mid.gt.this%n) return + if (this%keys(mid).ne.key) return + ! Scan left and right for duplicates (sorted -> contiguous) + i = mid + do while (i.gt.1) + if (this%keys(i-1).ne.key) exit + i = i - 1 + end do + j = mid + do while (j.lt.this%n) + if (this%keys(j+1).ne.key) exit + j = j + 1 + end do + first_idx = i + n_dup = j - i + 1 + end subroutine lookup_range + + !> Release allocated storage. + subroutine finalize(this) + implicit none + class(gid_hash), intent(inout) :: this + if (allocated(this%keys)) deallocate(this%keys) + if (allocated(this%vals)) deallocate(this%vals) + this%n = 0 + end subroutine finalize + + + !> Recursive Hoare-partition quicksort on (key, val) pairs, sorted by key. + !> Private module helper. + recursive subroutine quicksort_pair(keys,vals,lo,hi) + implicit none + integer(c_int64_t), intent(inout) :: keys(:) + integer, intent(inout) :: vals(:) + integer, intent(in) :: lo,hi + integer :: i,j,tv + integer(c_int64_t) :: pivot,tk + if (lo.ge.hi) return + pivot = keys((lo + hi) / 2) + i = lo; j = hi + do + do while (keys(i).lt.pivot); i = i + 1; end do + do while (keys(j).gt.pivot); j = j - 1; end do + if (i.le.j) then + tk = keys(i); keys(i) = keys(j); keys(j) = tk + tv = vals(i); vals(i) = vals(j); vals(j) = tv + i = i + 1; j = j - 1 + end if + if (i.gt.j) exit + end do + call quicksort_pair(keys,vals,lo,j) + call quicksort_pair(keys,vals,i,hi) + end subroutine quicksort_pair + +end module pdhash_class diff --git a/examples/NOSB_plate_with_hole_peridigm/src/pdsolver_class.f90 b/examples/NOSB_plate_with_hole_peridigm/src/pdsolver_class.f90 new file mode 100644 index 000000000..ea5d6ff70 --- /dev/null +++ b/examples/NOSB_plate_with_hole_peridigm/src/pdsolver_class.f90 @@ -0,0 +1,2281 @@ +!> Peridynamics solver: node-centered, CSR-based solid dynamics on flat +!> per-field arrays with persistent graph-halo communication. GRID-FREE: +!> no AMReX anywhere -- ownership follows the reference configuration +!> (Morton partition, motion-invariant), neighborhoods and communication +!> plans are built once and reused every substep. +!> +!> Physics: linear peridynamic solid (LPS, dimension-aware coefficients, +!> influence function hard-coded in omega() with derived quantities +!> generalized through its moments), brittle stretch damage, per-side +!> viscoelastic/viscoplastic flow with J2 (Mitchell OSB) yield, soft-sphere +!> contact (walls + particle-particle via a displacement-triggered spatial +!> service), velocity-Verlet integration. +!> Checkpoint/restart is gid-space and rank-count portable, including all +!> bond damage and plastic history. +!> +!> Usage tiers (amrpd EXTENDS pdsolver -- see amrpd_class): +!> 1. pdsolver alone -- standalone solid dynamics (this module only) +!> 2. amrpd -- adds viz, mesh VF, AMR refinement, seeding +!> 3. ... + a flow solver -- two-way FSI via amrpd%exchange_solid +!> +!> Configuration style: assign the public fields (material, damage, contact), +!> then build the network (detect_families/connect/read_state) -- derived +!> quantities resolve there via derive_config, uniformly for fresh and restart. +!> +!> Layout: owned nodes 1..nown; halo slots nown+1..ntot, keyed (gid, periodic +!> image offset) with shifts applied at exchange time. Each physical bond is +!> two CSR half-entries (one per endpoint row, Peridigm convention): kernels +!> compute each row's own force state -- ghost dilatation is never +!> communicated -- and a single halo reduce assembles cross-rank pairs. +!> Kernels are pure loops over owned nodes with no mutable module-level +!> state (OpenMP-ready by construction; threads deferred). +module pdsolver_class + use precision, only: WP,I8 + use string, only: str_medium + use pdhalo_class, only: pddir,pdhalo,sort3_perm,PDHALO_KEY0 + use pdhash_class, only: gid_hash + implicit none + private + + public :: pdsolver,pd_partition + public :: PDC_IS_DEAD,PDC_MOVES,PDC_INTEGRATES,PDC_BONDS + public :: PD_OPEN,PD_WALL + + ! Motion-control bit flags -- values MUST match amrpd's PART_* constants + ! (handoff copies amrpd flags verbatim) + integer, parameter :: PDC_IS_DEAD =0 + integer, parameter :: PDC_MOVES =1 + integer, parameter :: PDC_INTEGRATES=2 + integer, parameter :: PDC_BONDS =4 + + ! Domain-face BC values for lo_bc/hi_bc + integer, parameter :: PD_OPEN=0 + integer, parameter :: PD_WALL=1 + + !> Graph-core PD solver + type :: pdsolver + character(len=str_medium) :: name='UNNAMED_PDSOLVER' + + ! Sizes + integer :: nown=0 !< owned nodes on this rank + integer :: nhalo=0 !< halo slots + integer :: ntot=0 !< nown+nhalo + integer(I8) :: np=0 !< global node count (get_info) + integer(I8) :: nbond=0 !< global bond count (half-entries/2, get_info) + + ! Material / discretization + real(WP) :: rho =0.0_WP !< density + real(WP) :: elastic_modulus=0.0_WP !< Young's modulus + real(WP) :: poisson_ratio =0.0_WP !< Poisson's ratio + real(WP) :: delta =0.0_WP !< horizon + real(WP) :: dV =0.0_WP !< nominal element volume (CFL length scale; kernels use per-node V) + real(WP) :: s0 =huge(1.0_WP) !< critical bond stretch (huge = no damage) + real(WP) :: fail_stretch =huge(1.0_WP) !< direct s0 override (takes precedence over crit_energy) + real(WP) :: crit_energy =huge(1.0_WP) !< critical energy release rate G_c (-> s0 when fail_stretch unset) + real(WP) :: dtcrit =0.0_WP !< Silling-Askari critical dt (diagnostic, stamped at connect) + ! Viscoelastic / viscoplastic flow (PER-SIDE form: each half-entry evolves + ! its own e_v with its own endpoint's dilatation and yield factor -- + ! exactly Peridigm's elastic_plastic.cxx, verified term-by-term against + ! amrpd's J2 2026-07-14. This is the one INTENDED delta from amrpd, which + ! averages the endpoints into a single per-bond e_v.) + real(WP) :: tau =huge(1.0_WP) !< Maxwell deviatoric relaxation time (huge = purely elastic) + real(WP) :: visc_lambda =1.0_WP !< SLS relaxing fraction [0,1] + real(WP) :: yield_stretch =0.0_WP !< legacy per-bond Perzyna yield strain (0 = pure Maxwell) + real(WP) :: sigma_yield =0.0_WP !< J2 yield stress (Mitchell OSB family norm; overrides yield_stretch) + real(WP) :: hard_mod =0.0_WP !< linear isotropic hardening modulus H: flow stress = sigma_yield + H*lam_p (0 = perfectly plastic) + real(WP), dimension(3) :: gravity=0.0_WP !< body acceleration + logical, dimension(3) :: collapsed=.false. !< collapsed (n==1) directions: velocity locked + real(WP), dimension(3) :: Ldom=0.0_WP !< domain lengths (image shifts) + logical, dimension(3) :: per=.false. !< periodicity per direction + real(WP), dimension(3) :: dom_lo=0.0_WP !< domain lower bounds (wall contact) + real(WP), dimension(3) :: dom_hi=0.0_WP !< domain upper bounds (wall contact) + + ! Short-range soft-sphere contact (soft-sphere penalty + damping). + ! Contact is a pure SPATIAL service, fully separate from the bond graph: + ! candidates are (owned nodes + contact-halo slots) discovered by a + ! displacement-triggered broad phase; the graph halo is never binned, so + ! bonded remote partners arrive as contact slots when in range and + ! double-counting is structurally impossible. The narrow phase is + ! gather-only (each owned node accumulates from its candidates -- the + ! partner gets its share from its own row), so no force reduction. + logical :: use_contact =.false. + real(WP) :: contact_dist =0.0_WP !< d_c (p-p d_eff; wall d_eff = 0.5*d_c) + real(WP) :: tau_col =0.0_WP !< collision duration (<=0 -> auto 5*dt) + real(WP) :: e_n=0.7_WP,e_w=0.7_WP !< restitution (p-p, wall) + real(WP) :: clip_col =0.2_WP !< overlap clip fraction + integer, dimension(3) :: lo_bc=PD_OPEN,hi_bc=PD_OPEN !< per-face: PD_OPEN or PD_WALL + real(WP) :: cskin =0.0_WP !< broad-phase skin (<=0 -> auto 0.5*contact_dist) + type(pdhalo) :: chalo !< contact halo (rebuilt at trigger cadence; nown=ntot) + integer :: nchalo=0 !< contact slots (y/v extended to ntot+nchalo) + integer, allocatable :: cptr(:),clst(:) !< candidate CSR (owned rows; entries index owned+contact slots) + real(WP), allocatable :: ylast(:,:) !< (3,nown) positions at last broad-phase build + + ! Node state -- flat per-field arrays; owned first, halo slots appended. + ! (3,:) fields are xyz-interleaved per node (Fortran-natural gather layout). + integer(I8), allocatable :: gid(:) !< (ntot) global id (halo slots carry partner gid) + real(WP), allocatable :: x0(:,:) !< (3,ntot) reference position; halo PRE-SHIFTED + real(WP), allocatable :: y(:,:) !< (3,ntot) current position; halo shifted at update + real(WP), allocatable :: v(:,:) !< (3,nown) velocity + real(WP), allocatable :: f(:,:) !< (3,ntot) bond force density (halo = scatter buffer) + real(WP), allocatable :: ff(:,:) !< (3,nown) external (fluid) force density + real(WP), allocatable :: vol(:) !< (ntot) per-node volume (reference; halo slots filled at connect) + real(WP), allocatable :: mw(:) !< (nown) weighted volume (reference, set at connect) + real(WP), allocatable :: theta(:) !< (nown) dilatation (recomputed each substep) + real(WP), allocatable :: damage(:) !< (nown) accumulated damage fraction (broken/reference bonds) + real(WP), allocatable :: lam_p(:) !< (nown) accumulated equivalent plastic strain (J2 path; drives hardening, free diagnostic when hard_mod=0) + real(WP), allocatable :: alive(:) !< (ntot) 1=alive, 0=dead (exit through open face); halo-exchanged on death events only + integer, allocatable :: flag(:) !< (nown) motion-control flags + logical :: watch_exit=.false. !< exit detection active (set at connect: domain set + any open non-periodic face) + + ! CSR families (built once at connect) + integer, allocatable :: ptr(:) !< (nown+1) row offsets + integer, allocatable :: lst(:) !< neighbor index (1..ntot) per half-entry + integer(1), allocatable :: dmg(:) !< per half-entry: 0 intact, 1 broken (irreversible) + real(WP), allocatable :: e_v(:) !< per half-entry: inelastic deviatoric stretch (per-side history) + real(WP), allocatable :: td2(:),td2a(:) !< (nown) J2 family deviatoric norm^2: previous substep / accumulator. + !< Node-centered => pure own-row gather, NO communication (amrpd + !< needed sum_ghosts_td2 + ghost refresh for the same quantity). + + ! Parallel machinery + type(gid_hash) :: ohash !< gid -> owned index (built at set_nodes) + type(pddir) :: dir !< persistent gid directory (owner lookups; registered at connect/read_state) + type(pdhalo) :: halo !< persistent halo plan + real(WP), allocatable :: rextra_tmp(:,:) !< read_state scratch (restart-field overlay across assemble) + + ! Monitoring + real(WP) :: Umin=0.0_WP,Umax=0.0_WP !< signed per-component velocity extrema + real(WP) :: Vmin=0.0_WP,Vmax=0.0_WP !< over live nodes (get_info) + real(WP) :: Wmin=0.0_WP,Wmax=0.0_WP + real(WP) :: EPmax=0.0_WP !< max accumulated equivalent plastic strain (get_info) + real(WP) :: CFLe=0.0_WP,CFLp=0.0_WP !< elastic-wave / convective CFL (get_cfl) + integer(I8) :: nbroken=0 !< global broken half-entry count (internal) + integer(I8) :: nb_broken=0 !< global broken BOND count (exact census, get_info) + integer(I8) :: nb=0 !< global bond count (exact census, stamped at assemble) + integer(I8) :: nrebuild=0 !< broad-phase rebuild count (cumulative) + integer(I8) :: nchalo_glob=0 !< global contact-slot count (get_info) + integer(I8) :: ncand_glob=0 !< global contact-candidate count (get_info) + + ! Per-rank phase timers (accumulated in advance; reduced+reset in get_info) + real(WP) :: wt_kick=0.0_WP,wt_halo=0.0_WP,wt_dil=0.0_WP,wt_force=0.0_WP,wt_reduce=0.0_WP + real(WP) :: wt_contact=0.0_WP,wt_broad=0.0_WP + real(WP) :: wtmax_kick=0.0_WP,wtmax_halo=0.0_WP,wtmax_dil=0.0_WP,wtmax_force=0.0_WP,wtmax_reduce=0.0_WP + real(WP) :: wtmax_contact=0.0_WP,wtmax_broad=0.0_WP + real(WP) :: wtmin_dil=0.0_WP,wtmin_force=0.0_WP + + ! Damping rate for steady state + real(WP) :: damping_rate=0.0_WP + + ! NOSB Tracked parameters + real(WP), allocatable :: F_mat(:,:,:) !< F matrix (:,:,nown) I don't think this needs the halo + real(WP), allocatable :: PK_inv(:,:,:) !< P*K^-1 matrix (:,:,ntot) This needs to have gthe halo + + + + + contains + procedure :: set_nodes + procedure :: connect + procedure :: detect_families + procedure :: pd_advance + procedure :: query_owners + procedure :: write_state + procedure :: read_state + procedure :: get_cfl + procedure :: get_info + procedure :: finalize + procedure, private :: derive_config + procedure, private :: lps_coefs + procedure, private :: compute_mw + procedure, private :: contact_broadphase + procedure, private :: contact_narrow + procedure, private :: assemble + + end type pdsolver + +contains + + + !> Resolve derived configuration: s0 from fail_stretch/crit_energy, contact + !> reach default. Called by every network-building entry point (connect, + !> detect_families, read_state) so fresh init and restart share one path. + subroutine derive_config(this) + use messager, only: die + implicit none + class(pdsolver), intent(inout) :: this + real(WP) :: K_bulk + if (this%rho.le.0.0_WP.or.this%elastic_modulus.le.0.0_WP.or. & + & this%delta.le.0.0_WP.or.this%dV.le.0.0_WP) & + & call die('[pdsolver] material/discretization not configured (need rho, elastic_modulus, delta, dV > 0)') + if (this%fail_stretch.lt.huge(1.0_WP)) then + this%s0=this%fail_stretch + else if (this%crit_energy.gt.0.0_WP.and.this%crit_energy.lt.huge(1.0_WP)) then + ! Silling-Askari bond-energy argument, generalized to the active + ! influence function: G_c = (9/4)*K*s0^2*Iw4/Iw3 (w=1 recovers the + ! classical s0 = sqrt(5*G_c/(9*K*delta))) + K_bulk=this%elastic_modulus/(3.0_WP*(1.0_WP-2.0_WP*this%poisson_ratio)) + this%s0=sqrt(4.0_WP*this%crit_energy*wmoment(this%delta,3,1)/(9.0_WP*K_bulk*wmoment(this%delta,4,1))) + end if + if (this%use_contact.and.this%contact_dist.le.0.0_WP) this%contact_dist=0.9_WP*this%dV**(1.0_WP/3.0_WP) + end subroutine derive_config + + !> Load this rank's owned nodes (any distribution; it becomes the static + !> partition). Builds the gid->index hash used by connect and the halo plan. + !> vol is the per-node volume (pass a constant-filled array for a uniform + !> lattice; kernels use it per neighbor, Peridigm-style). + subroutine set_nodes(this,n,gids,pos,vel,flags,vol) + implicit none + class(pdsolver), intent(inout) :: this + integer, intent(in) :: n + integer(I8), intent(in) :: gids(:) + real(WP), intent(in) :: pos(:,:),vel(:,:) + integer, intent(in) :: flags(:) + real(WP), intent(in) :: vol(:) + integer :: i + this%nown=n + this%nhalo=0 + this%ntot=n + allocate(this%gid(max(n,1)),this%x0(3,max(n,1)),this%y(3,max(n,1))) + allocate(this%v(3,max(n,1)),this%f(3,max(n,1)),this%ff(3,max(n,1))) + allocate(this%mw(max(n,1)),this%theta(max(n,1)),this%flag(max(n,1))) + allocate(this%vol(max(n,1)),this%damage(max(n,1)),this%lam_p(max(n,1))) + allocate(this%PK_inv(3,3,max(n,1)),this%F_mat(3,3,max(n,1))) + do i=1,n + this%gid(i) =gids(i) + this%x0(:,i)=pos(:,i) + this%y(:,i) =pos(:,i) + this%v(:,i) =vel(:,i) + this%flag(i)=flags(i) + this%vol(i) =vol(i) + end do + this%f=0.0_WP; this%ff=0.0_WP; this%mw=0.0_WP; this%theta=0.0_WP; this%damage=0.0_WP; this%lam_p=0.0_WP + this%F_mat=0.0_WP; this%PK_inv=0.0_WP + call this%ohash%build(n,gids(1:n)) + end subroutine set_nodes + + !> Build the static CSR families and the halo plan from a distributed bond + !> list (this rank passes the bonds it holds; any distribution is fine -- + !> half-entries are routed to their node's owner through the gid directory). + !> Collective. bkey packs the periodic image offset of the HI endpoint in + !> amrpd's hist1 convention. Self-image bonds (gid_lo==gid_hi) yield ONE + !> half-entry (the opposite-image bond exists separately in the input, exactly + !> as amrpd stores them). + subroutine connect(this,nb,bgid_lo,bgid_hi,bkey) + use parallel, only: comm,nproc + use messager, only: die + use mpi_f08 + implicit none + class(pdsolver), intent(inout) :: this + integer, intent(in) :: nb + integer(I8), intent(in) :: bgid_lo(:),bgid_hi(:) + integer, intent(in) :: bkey(:) + integer(I8), allocatable :: hnode(:),hnbr(:),rnode(:),rnbr(:) + integer, allocatable :: hkey(:),howner(:),rkey(:) + real(WP), allocatable :: rev(:) + integer(1), allocatable :: rdmg(:) + integer :: nhe,rn,i,ib,ierr + + ! Resolve derived configuration (restart-safe shared path) + call this%derive_config() + + ! Distributed gid directory over the node partition (persistent: also + ! serves owner queries for face-tag restamping after restart) + call this%dir%finalize() + call this%dir%register(this%nown,this%gid(1:this%nown)) + + ! Expand bonds into half-entries (one per endpoint row; one total for + ! self-image bonds -- see header) + nhe=0 + do ib=1,nb + nhe=nhe+1 + if (bgid_lo(ib).ne.bgid_hi(ib)) nhe=nhe+1 + end do + allocate(hnode(max(nhe,1)),hnbr(max(nhe,1)),hkey(max(nhe,1)),howner(max(nhe,1))) + nhe=0 + do ib=1,nb + nhe=nhe+1 + hnode(nhe)=bgid_lo(ib); hnbr(nhe)=bgid_hi(ib); hkey(nhe)=bkey(ib) + if (bgid_lo(ib).ne.bgid_hi(ib)) then + nhe=nhe+1 + hnode(nhe)=bgid_hi(ib); hnbr(nhe)=bgid_lo(ib); hkey(nhe)=negkey(bkey(ib)) + end if + end do + + ! Route each half-entry to the rank owning its node + call this%dir%query(nhe,hnode,howner) + route_entries: block + integer, dimension(0:nproc-1) :: sc,rc,sd,rd + integer, allocatable :: pos(:) + integer(I8), allocatable :: s8(:) + integer, allocatable :: s4(:) + integer :: r,h + sc=0 + do i=1,nhe + sc(howner(i))=sc(howner(i))+1 + end do + call MPI_ALLTOALL(sc,1,MPI_INTEGER,rc,1,MPI_INTEGER,comm,ierr) + sd(0)=0; rd(0)=0 + do r=1,nproc-1 + sd(r)=sd(r-1)+sc(r-1); rd(r)=rd(r-1)+rc(r-1) + end do + rn=sum(rc) + allocate(rnode(max(rn,1)),rnbr(max(rn,1)),rkey(max(rn,1))) + allocate(pos(0:nproc-1),s8(max(nhe,1)),s4(max(nhe,1))) + ! node gids + pos=sd + do i=1,nhe + h=howner(i); pos(h)=pos(h)+1; s8(pos(h))=hnode(i) + end do + call MPI_ALLTOALLV(s8,sc,sd,MPI_INTEGER8,rnode,rc,rd,MPI_INTEGER8,comm,ierr) + ! neighbor gids + pos=sd + do i=1,nhe + h=howner(i); pos(h)=pos(h)+1; s8(pos(h))=hnbr(i) + end do + call MPI_ALLTOALLV(s8,sc,sd,MPI_INTEGER8,rnbr,rc,rd,MPI_INTEGER8,comm,ierr) + ! image keys + pos=sd + do i=1,nhe + h=howner(i); pos(h)=pos(h)+1; s4(pos(h))=hkey(i) + end do + call MPI_ALLTOALLV(s4,sc,sd,MPI_INTEGER,rkey,rc,rd,MPI_INTEGER,comm,ierr) + deallocate(pos,s8,s4) + end block route_entries + deallocate(hnode,hnbr,hkey,howner) + + ! Fresh bonds carry zero inelastic state + allocate(rev(max(rn,1)),rdmg(max(rn,1))) + rev=0.0_WP; rdmg=0_1 + call this%assemble(rn,rnode,rnbr,rkey,rev,rdmg) + deallocate(rnode,rnbr,rkey,rev,rdmg) + end subroutine connect + + + !> Build the bond families directly from the REFERENCE configuration -- no + !> amrpd bond container, no bond expansion: distributed neighbor discovery + !> at radius delta (bounds allgather + per-(rank,image-offset) offers of + !> shifted x0, contact-broadphase pattern), then each owned row's + !> half-entries are generated straight from the binned candidates and fed + !> to assemble with zero inelastic state. Acceptance test r2 <= delta^2 + !> matches amrpd bond_init exactly. Collective; call after set_nodes. + subroutine detect_families(this) + use parallel, only: comm,rank,nproc,amRoot,MPI_REAL_WP + use messager, only: log,die + use string, only: str_long + use mpi_f08 + implicit none + class(pdsolver), intent(inout) :: this + real(WP), dimension(3) :: bl,bh,shift,pos_s,gl,hcell + real(WP), allocatable :: allb(:,:),opos(:,:),rpos(:,:),cpos(:,:) + integer(I8), allocatable :: ogid(:),rgid(:),cgid(:),hnode(:),hnbr(:) + integer, allocatable :: okey(:),rkey(:),ckey(:),hkey(:),head(:),nxt(:) + real(WP), allocatable :: rev(:) + integer(1), allocatable :: rdmg(:) + integer, dimension(0:nproc-1) :: sc,rc,sd,rd,sc3,rc3,sd3,rd3 + integer, dimension(3) :: nmax,nc + integer :: d,r,n1,n2,n3,i,k,m,noff,nrecv,ncand,nhe,pass,ic,jc,kc,c1,c2,c3,ierr + character(len=str_long) :: message + + ! Resolve derived configuration (restart-safe shared path) + call this%derive_config() + + ! Directory over the node partition (persistent) + call this%dir%finalize() + call this%dir%register(this%nown,this%gid(1:this%nown)) + + ! Owned reference bounds, exchanged globally + bl=huge(1.0_WP); bh=-huge(1.0_WP) + do i=1,this%nown + bl=min(bl,this%x0(:,i)); bh=max(bh,this%x0(:,i)) + end do + allocate(allb(6,0:nproc-1)) + call MPI_ALLGATHER([bl,bh],6,MPI_REAL_WP,allb,6,MPI_REAL_WP,comm,ierr) + do d=1,3 + nmax(d)=0 + if (this%per(d).and.this%Ldom(d).gt.0.0_WP) nmax(d)=min(4,int(this%delta/this%Ldom(d))+1) + end do + + ! Offers of shifted reference positions (two passes: count, fill) + do pass=1,2 + sc=0 + do r=0,nproc-1 + do n3=-nmax(3),nmax(3); do n2=-nmax(2),nmax(2); do n1=-nmax(1),nmax(1) + if (r.eq.rank.and.n1.eq.0.and.n2.eq.0.and.n3.eq.0) cycle + shift=[real(n1,WP)*this%Ldom(1),real(n2,WP)*this%Ldom(2),real(n3,WP)*this%Ldom(3)] + if (any(bl+shift-this%delta.gt.allb(4:6,r)).or.any(bh+shift+this%delta.lt.allb(1:3,r))) cycle + do i=1,this%nown + pos_s=this%x0(:,i)+shift + if (any(pos_s.lt.allb(1:3,r)-this%delta).or.any(pos_s.gt.allb(4:6,r)+this%delta)) cycle + sc(r)=sc(r)+1 + if (pass.eq.2) then + ogid(sd(r)+sc(r))=this%gid(i) + okey(sd(r)+sc(r))=(n1+128)+(n2+128)*256+(n3+128)*65536 + opos(:,sd(r)+sc(r))=pos_s + end if + end do + end do; end do; end do + end do + if (pass.eq.1) then + sd(0)=0 + do r=1,nproc-1 + sd(r)=sd(r-1)+sc(r-1) + end do + noff=sum(sc) + allocate(ogid(max(noff,1)),okey(max(noff,1)),opos(3,max(noff,1))) + end if + end do + call MPI_ALLTOALL(sc,1,MPI_INTEGER,rc,1,MPI_INTEGER,comm,ierr) + rd(0)=0 + do r=1,nproc-1 + rd(r)=rd(r-1)+rc(r-1) + end do + nrecv=sum(rc) + allocate(rgid(max(nrecv,1)),rkey(max(nrecv,1)),rpos(3,max(nrecv,1))) + call MPI_ALLTOALLV(ogid,sc,sd,MPI_INTEGER8,rgid,rc,rd,MPI_INTEGER8,comm,ierr) + call MPI_ALLTOALLV(okey,sc,sd,MPI_INTEGER, rkey,rc,rd,MPI_INTEGER, comm,ierr) + sc3=3*sc; sd3=3*sd; rc3=3*rc; rd3=3*rd + call MPI_ALLTOALLV(opos,sc3,sd3,MPI_REAL_WP,rpos,rc3,rd3,MPI_REAL_WP,comm,ierr) + deallocate(ogid,okey,opos) + + ! Candidate set = owned nodes (zero offset) + received offers + ncand=this%nown+nrecv + allocate(cgid(max(ncand,1)),ckey(max(ncand,1)),cpos(3,max(ncand,1))) + do i=1,this%nown + cgid(i)=this%gid(i); ckey(i)=PDHALO_KEY0; cpos(:,i)=this%x0(:,i) + end do + do i=1,nrecv + cgid(this%nown+i)=rgid(i); ckey(this%nown+i)=rkey(i); cpos(:,this%nown+i)=rpos(:,i) + end do + deallocate(rgid,rkey,rpos) + + ! Bin candidates; generate each owned row directly (two passes) + bl=huge(1.0_WP); bh=-huge(1.0_WP) + do m=1,ncand + bl=min(bl,cpos(:,m)); bh=max(bh,cpos(:,m)) + end do + call setup_bins(bl,bh,this%delta,gl,hcell,nc) + allocate(head(nc(1)*nc(2)*nc(3)),nxt(max(ncand,1))) + head=0 + do m=1,ncand + k=cell_of(cpos(:,m),gl,hcell,nc) + nxt(m)=head(k); head(k)=m + end do + do pass=1,2 + nhe=0 + do i=1,this%nown + ic=min(nc(1),max(1,int((this%x0(1,i)-gl(1))/hcell(1))+1)) + jc=min(nc(2),max(1,int((this%x0(2,i)-gl(2))/hcell(2))+1)) + kc=min(nc(3),max(1,int((this%x0(3,i)-gl(3))/hcell(3))+1)) + do c3=max(1,kc-1),min(nc(3),kc+1); do c2=max(1,jc-1),min(nc(2),jc+1); do c1=max(1,ic-1),min(nc(1),ic+1) + m=head(c1+nc(1)*(c2-1)+nc(1)*nc(2)*(c3-1)) + do while (m.gt.0) + if (m.ne.i) then + if (sum((cpos(:,m)-this%x0(:,i))**2).le.this%delta**2) then + nhe=nhe+1 + if (pass.eq.2) then + hnode(nhe)=this%gid(i) + hnbr(nhe) =cgid(m) + hkey(nhe) =ckey(m) + end if + end if + end if + m=nxt(m) + end do + end do; end do; end do + end do + if (pass.eq.1) allocate(hnode(max(nhe,1)),hnbr(max(nhe,1)),hkey(max(nhe,1))) + end do + deallocate(cgid,ckey,cpos,head,nxt,allb) + + ! Assemble with zero inelastic state (entries are already local rows) + allocate(rev(max(nhe,1)),rdmg(max(nhe,1))) + rev=0.0_WP; rdmg=0_1 + call this%assemble(nhe,hnode,hnbr,hkey,rev,rdmg) + deallocate(hnode,hnbr,hkey,rev,rdmg) + if (amRoot) then + write(message,'("[",a,"] detect_families: ",i0," half-entries (~2x bonds)")') trim(this%name),this%nbond + call log(message) + end if + end subroutine detect_families + + !> Assemble the CSR families, halo plan, and reference state from LOCAL + !> half-entry arrays (already routed to this rank: every entry's node gid is + !> owned here). Per-entry inelastic state (dmg, e_v) travels with the + !> entries -- zeros for a fresh connect, loaded values on restart. Shared by + !> connect and read_state; collective. + subroutine assemble(this,rn,rnode,rnbr,rkey,rev,rdmg) + use parallel, only: comm,nproc + use messager, only: die + use mpi_f08 + implicit none + class(pdsolver), intent(inout) :: this + integer, intent(in) :: rn + integer(I8), intent(in) :: rnode(:),rnbr(:) + integer, intent(in) :: rkey(:) + real(WP), intent(in) :: rev(:) + integer(1), intent(in) :: rdmg(:) + integer, allocatable :: ridx(:),perm(:) + integer :: i,s,ierr + + if (allocated(this%ptr)) deallocate(this%ptr) + if (allocated(this%lst)) deallocate(this%lst) + if (allocated(this%dmg)) deallocate(this%dmg) + if (allocated(this%e_v)) deallocate(this%e_v) + if (allocated(this%td2)) deallocate(this%td2) + if (allocated(this%td2a)) deallocate(this%td2a) + + ! Resolve each received entry's node to an owned index + allocate(ridx(max(rn,1)),perm(max(rn,1))) + do i=1,rn + ridx(i)=this%ohash%lookup(rnode(i)) + if (ridx(i).lt.1) call die('[pdsolver assemble] half-entry routed to a rank that does not own its node') + perm(i)=i + end do + + ! Deterministic CSR order: sort by (node index, neighbor gid, image key) + if (rn.gt.1) call sort3_perm(ridx,rnbr,rkey,perm,1,rn) + + ! Row pointers + allocate(this%ptr(this%nown+1)) + row_pointers: block + integer, allocatable :: cnt(:) + allocate(cnt(this%nown)); cnt=0 + do i=1,rn + cnt(ridx(i))=cnt(ridx(i))+1 + end do + this%ptr(1)=1 + do i=1,this%nown + this%ptr(i+1)=this%ptr(i)+cnt(i) + end do + deallocate(cnt) + end block row_pointers + + ! Classify entries (owned direct vs halo reference), dedupe references, + ! build the halo plan, and finalize the CSR neighbor indices + build_refs_and_halo: block + integer(I8), allocatable :: refgid(:),ugid(:) + integer, allocatable :: refkey(:),refpos(:),rperm(:),zeros(:) + integer, allocatable :: ukey(:),uowner(:),uslot(:) + integer :: nref,nuniq,lid,u + allocate(this%lst(max(rn,1))) + allocate(this%dmg(max(rn,1))); this%dmg=0_1 + allocate(this%e_v(max(rn,1))); this%e_v=0.0_WP + ! Per-entry inelastic state follows the deterministic CSR order + do s=1,rn + this%dmg(s)=rdmg(perm(s)) + this%e_v(s)=rev(perm(s)) + end do + allocate(this%td2(max(this%nown,1)),this%td2a(max(this%nown,1))) + this%td2=0.0_WP; this%td2a=0.0_WP + allocate(refgid(max(rn,1)),refkey(max(rn,1)),refpos(max(rn,1))) + nref=0 + do s=1,rn + i=perm(s) + if (rkey(i).eq.PDHALO_KEY0) then + lid=this%ohash%lookup(rnbr(i)) + if (lid.ge.1) then + this%lst(s)=lid ! owned, zero image offset: direct index + cycle + end if + end if + nref=nref+1 + refgid(nref)=rnbr(i); refkey(nref)=rkey(i); refpos(nref)=s + end do + ! Unique (gid,key) references, deterministic order + allocate(rperm(max(nref,1)),zeros(max(nref,1))) + zeros=0 + do i=1,nref + rperm(i)=i + end do + if (nref.gt.1) call sort3_perm(zeros,refgid,refkey,rperm,1,nref) + allocate(ugid(max(nref,1)),ukey(max(nref,1))) + nuniq=0 + do s=1,nref + i=rperm(s) + if (s.eq.1) then + nuniq=1; ugid(1)=refgid(i); ukey(1)=refkey(i) + else if (refgid(i).ne.refgid(rperm(s-1)).or.refkey(i).ne.refkey(rperm(s-1))) then + nuniq=nuniq+1; ugid(nuniq)=refgid(i); ukey(nuniq)=refkey(i) + end if + this%lst(refpos(i))=-nuniq ! provisional: -(unique ref id) + end do + ! Owners of the unique references, then the persistent halo plan + allocate(uowner(max(nuniq,1)),uslot(max(nuniq,1))) + call this%dir%query(nuniq,ugid,uowner) + call this%halo%build(this%nown,this%ohash,nuniq,ugid,ukey,uowner,this%Ldom,this%per,uslot) + this%nhalo=this%halo%nhalo + this%ntot=this%nown+this%nhalo + ! Finalize CSR: provisional negatives -> halo slot indices + do s=1,rn + if (this%lst(s).lt.0) this%lst(s)=this%nown+uslot(-this%lst(s)) + end do + ! Extend node arrays to include halo slots; stamp halo gids + extend_arrays: block + integer(I8), allocatable :: g2(:) + real(WP), allocatable :: a2(:,:) + allocate(g2(max(this%ntot,1))); g2(1:this%nown)=this%gid(1:this%nown) + do u=1,nuniq + g2(this%nown+uslot(u))=ugid(u) + end do + call move_alloc(g2,this%gid) + allocate(a2(3,max(this%ntot,1))); a2=0.0_WP; a2(:,1:this%nown)=this%x0(:,1:this%nown) + call move_alloc(a2,this%x0) + allocate(a2(3,max(this%ntot,1))); a2=0.0_WP; a2(:,1:this%nown)=this%y(:,1:this%nown) + call move_alloc(a2,this%y) + allocate(a2(3,max(this%ntot,1))); a2=0.0_WP; a2(:,1:this%nown)=this%f(:,1:this%nown) + call move_alloc(a2,this%f) + extend_tensors: block ! I am copying the patterm but I think this will correctly extend things to include halos + real(WP), allocatable :: t2(:,:,:) + allocate(t2(3,3,max(this%ntot,1))); t2=0.0_WP; t2(:,:,1:this%nown)=this%PK_inv(:,:,1:this%nown) + call move_alloc(t2,this%PK_inv) + end block extend_tensors + extend_volume: block + real(WP), allocatable :: v2(:) + allocate(v2(max(this%ntot,1))); v2=0.0_WP; v2(1:this%nown)=this%vol(1:this%nown) + call move_alloc(v2,this%vol) + end block extend_volume + end block extend_arrays + deallocate(refgid,refkey,refpos,rperm,zeros,ugid,ukey,uowner,uslot) + end block build_refs_and_halo + deallocate(ridx,perm) + + ! Fill halo reference positions ONCE, pre-shifted by the image offsets + ! (x0 is static; this is the only x0 exchange of the entire run), and + ! the halo per-node volumes (also static) + call this%halo%update(this%x0,3,shifted=.true.) + call this%halo%update1(this%vol) + this%y(:,this%nown+1:this%ntot)=this%x0(:,this%nown+1:this%ntot) + + ! Life status (exit-through-open-face handling). Exchanged over the halo + ! ONLY on substeps where a death occurs somewhere; steady state is free. + if (allocated(this%alive)) deallocate(this%alive) + allocate(this%alive(max(this%ntot,1))); this%alive=1.0_WP + this%watch_exit=(this%dom_hi(1).gt.this%dom_lo(1)).and. & + & any((.not.this%per).and.(this%lo_bc.eq.0.or.this%hi_bc.eq.0)) + + ! Stamp the reference weighted volume + call this%compute_mw() + + ! Silling-Askari critical time step (Peridigm form, 3D bond-based + ! micromodulus c(z) = c0*w(z), c0 = 9K/(2*pi*Iw3); w=1 recovers the + ! classical 18K/(pi*delta^4)): + ! dt_crit_i = sqrt(2*rho / sum_family(V_j * c(zeta) / zeta)), global min. + ! DIAGNOSTIC only for now -- reported at init, does not bind dt. The + ! micromodulus constant is 3D-based; in quasi-2D slabs treat it as + ! indicative. + critical_dt: block + use mathtools, only: Pi + use messager, only: log + use string, only: str_long + use parallel, only: amRoot,MPI_REAL_WP + real(WP) :: K_bulk,c0,denom,zeta,dtc + character(len=str_long) :: message + integer :: i,e,j + K_bulk=this%elastic_modulus/(3.0_WP*(1.0_WP-2.0_WP*this%poisson_ratio)) + c0=9.0_WP*K_bulk/(2.0_WP*Pi*wmoment(this%delta,3,1)) + dtc=huge(1.0_WP) + do i=1,this%nown + denom=0.0_WP + do e=this%ptr(i),this%ptr(i+1)-1 + j=this%lst(e) + zeta=sqrt(sum((this%x0(:,j)-this%x0(:,i))**2)) + if (zeta.gt.0.0_WP) denom=denom+this%vol(j)*c0*omega(zeta,this%delta)/zeta + end do + if (denom.gt.0.0_WP) dtc=min(dtc,sqrt(2.0_WP*this%rho/denom)) + end do + call MPI_ALLREDUCE(MPI_IN_PLACE,dtc,1,MPI_REAL_WP,MPI_MIN,comm,ierr) + this%dtcrit=dtc + if (amRoot) then + write(message,'("[",a,"] Silling-Askari critical dt = ",es12.5," (diagnostic)")') trim(this%name),this%dtcrit + call log(message) + end if + end block critical_dt + + ! Global half-entry count for logging (= 2*bonds - self-image bonds) + count_bonds: block + use parallel, only: comm + integer(I8) :: nhe8 + nhe8=int(rn,I8) + call MPI_ALLREDUCE(MPI_IN_PLACE,nhe8,1,MPI_INTEGER8,MPI_SUM,comm,ierr) + this%nbond=nhe8 ! total half-entries; = 2*bonds - self-image bonds + ! Exact bond census (lower-gid rule; positive-offset self-images) + count_nb: block + integer :: i2,e2,j2 + this%nb=0_I8 + do i2=1,this%nown + do e2=this%ptr(i2),this%ptr(i2+1)-1 + j2=this%lst(e2) + if (this%gid(i2).lt.this%gid(j2)) then + this%nb=this%nb+1_I8 + else if (this%gid(i2).eq.this%gid(j2).and.j2.gt.this%nown) then + if (shift_positive(this%halo%shift(:,j2-this%nown))) this%nb=this%nb+1_I8 + end if + end do + end do + call MPI_ALLREDUCE(MPI_IN_PLACE,this%nb,1,MPI_INTEGER8,MPI_SUM,comm,ierr) + end block count_nb + end block count_bonds + end subroutine assemble + + !> Weighted volume: mw_i = sum_family w(zeta)*zeta^2*V_j (reference state; + !> never updated by damage) + subroutine compute_mw(this) + implicit none + class(pdsolver), intent(inout) :: this + integer :: i,e,j + real(WP) :: zeta + do i=1,this%nown + this%mw(i)=0.0_WP + do e=this%ptr(i),this%ptr(i+1)-1 + j=this%lst(e) + zeta=sqrt(sum((this%x0(:,j)-this%x0(:,i))**2)) + this%mw(i)=this%mw(i)+omega(zeta,this%delta)*zeta**2*this%vol(j) + end do + end do + end subroutine compute_mw + + !> Dimension-aware LPS constitutive coefficients (omega-independent: mw + !> absorbs the influence function). psi_fac sets the J2 yield threshold on + !> the family deviatoric force-state norm -- yield when + !> ||t_dev||^2 > psi_fac*sigma_yield^2/mw (Mitchell OSB) -- and DOES depend + !> on omega: since td ~ w, the norm scales by the w^2/w moment ratio + !> (int w^2 z^p / int w z^p, p=4 in 3D, 3 in 2D; ratio = 1 for w=1). + subroutine lps_coefs(this,fdim,coef_vol,coef_dev,psi_fac) + implicit none + class(pdsolver), intent(in) :: this + real(WP), intent(out) :: fdim,coef_vol,coef_dev + real(WP), intent(out), optional :: psi_fac + real(WP) :: K_bulk,mu_shear + integer :: ndim + ndim=3-count(this%collapsed) + K_bulk =this%elastic_modulus/(3.0_WP*(1.0_WP-2.0_WP*this%poisson_ratio)) + mu_shear=this%elastic_modulus/(2.0_WP*(1.0_WP+this%poisson_ratio)) + select case (ndim) + case (3) + fdim=3.0_WP; coef_vol=3.0_WP*K_bulk; coef_dev=15.0_WP*mu_shear + if (present(psi_fac)) psi_fac=5.0_WP*wmoment(this%delta,4,2)/wmoment(this%delta,4,1) + case (2) + fdim=2.0_WP; coef_vol=2.0_WP*(K_bulk+mu_shear/3.0_WP); coef_dev= 8.0_WP*mu_shear + if (present(psi_fac)) psi_fac=8.0_WP/3.0_WP*wmoment(this%delta,3,2)/wmoment(this%delta,3,1) + case default + fdim=1.0_WP; coef_vol=this%elastic_modulus; coef_dev= 0.0_WP + if (present(psi_fac)) psi_fac=0.0_WP + end select + end subroutine lps_coefs + + !> Velocity-Verlet step: half-kick + drift, halo position update, + !> dilatation gather, node-centered force sweep, halo force reduce, + !> contact, second half-kick. + subroutine pd_advance(this,dt) + use parallel, only: parallel_time + implicit none + class(pdsolver), intent(inout) :: this + real(WP), intent(in) :: dt + real(WP) :: rho_inv,fdim,cvol,cdev,t0 + real(WP) :: zeta,dY,e_b,t,w + real(WP) :: psi_fac,decay,e_d,td,beta,e_e,over + real(WP) :: sYe2,strial,mu3i + logical :: plastic,do_j2 + real(WP), dimension(3) :: acc,dxv,fx + real(WP), dimension(3,3) :: K_mat,E_mat,I_mat,S_mat,K_inv,sigma, s_dev + real(WP) :: detK,traceE + real(WP) :: kk,mu + real(WP), dimension(3) :: xi,rpos,z,t1,t2,tc + integer :: i,e,j + + rho_inv=1.0_WP/this%rho + mu=this%elastic_modulus/(2.0_WP+2.0_WP*this%poisson_ratio) + kk=this%elastic_modulus/(3.0_WP-6.0_WP*this%poisson_ratio) + call this%lps_coefs(fdim,cvol,cdev,psi_fac) + ! ! Viscoplastic setup: decay is loop-invariant (exact exponential update, + ! ! unconditionally stable -- no viscous CFL) + ! plastic=(this%tau.gt.0.0_WP.and.this%tau.lt.huge(1.0_WP)) + ! do_j2=(this%sigma_yield.gt.0.0_WP) + ! decay=0.0_WP + ! if (plastic) decay=exp(-dt/this%tau) + ! mu3i=2.0_WP*(1.0_WP+this%poisson_ratio)/(3.0_WP*this%elastic_modulus) ! 1/(3*mu_shear) + + ! First half-kick and drift (owned nodes) + t0=parallel_time() + do i=1,this%nown + if (this%flag(i).eq.PDC_IS_DEAD) cycle + acc=this%gravity+(this%f(:,i)+this%ff(:,i))*rho_inv + if (iand(this%flag(i),PDC_INTEGRATES).ne.0) this%v(:,i)=(1.0_WP-this%damping_rate)*this%v(:,i)+0.5_WP*dt*acc + if (this%collapsed(1)) this%v(1,i)=0.0_WP + if (this%collapsed(2)) this%v(2,i)=0.0_WP + if (this%collapsed(3)) this%v(3,i)=0.0_WP + if (iand(this%flag(i),PDC_MOVES).ne.0) this%y(:,i)=this%y(:,i)+dt*this%v(:,i) + end do + this%wt_kick=this%wt_kick+(parallel_time()-t0) + + ! Exit handling: nodes drifting out through an OPEN non-periodic face die + ! (amrpd drops them at Redistribute; here they are flagged and muted). + ! The death-count allreduce runs only when exits are possible at all, and + ! the mute propagation only on substeps where a death actually occurred. + if (this%watch_exit) then + death_watch: block + use parallel, only: comm + use mpi_f08, only: MPI_ALLREDUCE,MPI_IN_PLACE,MPI_SUM,MPI_INTEGER + integer :: nd,d,e,ierr + logical :: out + nd=0 + do i=1,this%nown + if (this%flag(i).eq.PDC_IS_DEAD) cycle + out=.false. + do d=1,3 + if (this%per(d)) cycle + if (this%lo_bc(d).eq.0.and.this%y(d,i).lt.this%dom_lo(d)) out=.true. + if (this%hi_bc(d).eq.0.and.this%y(d,i).gt.this%dom_hi(d)) out=.true. + end do + if (out) then + this%flag(i)=PDC_IS_DEAD + this%v(:,i)=0.0_WP + this%alive(i)=0.0_WP + nd=nd+1 + end if + end do + call MPI_ALLREDUCE(MPI_IN_PLACE,nd,1,MPI_INTEGER,MPI_SUM,comm,ierr) + if (nd.gt.0) then + ! Propagate life status to halo slots, then permanently mute + ! every entry touching a dead node (dmg=2: distinct from broken, + ! so damage statistics stay honest -- amrpd does not count + ! dropped-particle bonds as damage either) + call this%halo%update1(this%alive) + do i=1,this%nown + if (this%flag(i).eq.PDC_IS_DEAD) then + do e=this%ptr(i),this%ptr(i+1)-1 + if (this%dmg(e).eq.0_1) this%dmg(e)=2_1 + end do + else + do e=this%ptr(i),this%ptr(i+1)-1 + if (this%dmg(e).eq.0_1.and.this%alive(this%lst(e)).lt.0.5_WP) this%dmg(e)=2_1 + end do + end if + end do + ! Force a contact broad-phase rebuild so no candidate list + ! references a corpse (dead nodes are excluded from offers/bins) + if (this%use_contact.and.allocated(this%ylast)) deallocate(this%ylast) + end if + end block death_watch + end if + + ! Refresh halo positions (owner y -> slots, with image shifts) + t0=parallel_time() + call this%halo%update(this%y,3,shifted=.true.) + this%wt_halo=this%wt_halo+(parallel_time()-t0) + + ! Contact service: displacement-triggered broad phase (rebuilds contact + ! halo + candidate list when cumulative drift exhausts the skin), then + ! per-substep refresh of contact-slot positions AND velocities (the only + ! place velocity crosses ranks; the graph halo never carries it) + if (this%use_contact) then + t0=parallel_time() + call this%contact_broadphase() + this%wt_broad=this%wt_broad+(parallel_time()-t0) + t0=parallel_time() + call this%chalo%update(this%y,3,shifted=.true.) + call this%chalo%update(this%v,3,shifted=.false.) + this%wt_halo=this%wt_halo+(parallel_time()-t0) + end if + + ! ! Dilatation (pure gather; own family only; broken entries excluded -- + ! ! breaks happen in the force sweep AFTER this, matching amrpd's ordering) + ! t0=parallel_time() + ! do i=1,this%nown + ! this%theta(i)=0.0_WP + ! do e=this%ptr(i),this%ptr(i+1)-1 + ! if (this%dmg(e).ne.0_1) cycle + ! j=this%lst(e) + ! zeta=sqrt(sum((this%x0(:,j)-this%x0(:,i))**2)) + ! dY =sqrt(sum((this%y(:,j) -this%y(:,i) )**2)) + ! e_b=dY-zeta + ! this%theta(i)=this%theta(i)+omega(zeta,this%delta)*zeta*e_b*this%vol(j) + ! end do + ! if (this%mw(i).gt.0.0_WP) then + ! this%theta(i)=fdim*this%theta(i)/this%mw(i) + ! else + ! this%theta(i)=0.0_WP + ! end if + ! end do + ! this%wt_dil=this%wt_dil+(parallel_time()-t0) + + ! Equivalent to the dilatation sweep from before, I think that each one needs to sweep over + ! and compute the tensors K_mat and F + I_mat = 0.0_WP + I_mat(1,1) = 1.0_WP + I_mat(2,2) = 1.0_WP + I_mat(3,3) = 1.0_WP + do i=1,this%nown + K_mat=0.0_WP + K_inv = 0.0_WP + S_mat = 0.0_WP + traceE = 0.0_WP + E_mat = 0.0_WP + this%F_mat(:,:,i)=0.0_WP + this%PK_inv(:,:,i)=0.0_WP + do e=this%ptr(i),this%ptr(i+1)-1 + if (this%dmg(e).ne.0_1) cycle + j=this%lst(e) + xi=this%x0(:,j)-this%x0(:,i) + rpos=this%y(:,j) -this%y(:,i) + zeta=sqrt(sum(xi**2)) + w = omega(zeta,this%delta) + K_mat(1,1)=K_mat(1,1)+xi(1)*xi(1)*w*this%vol(j); K_mat(1,2)=K_mat(1,2)+xi(1)*xi(2)*w*this%vol(j); K_mat(1,3)=K_mat(1,3)+xi(1)*xi(3)*w*this%vol(j); + K_mat(2,1)=K_mat(2,1)+xi(2)*xi(1)*w*this%vol(j); K_mat(2,2)=K_mat(2,2)+xi(2)*xi(2)*w*this%vol(j); K_mat(2,3)=K_mat(2,3)+xi(2)*xi(3)*w*this%vol(j); + K_mat(3,1)=K_mat(3,1)+xi(3)*xi(1)*w*this%vol(j); K_mat(3,2)=K_mat(3,2)+xi(3)*xi(2)*w*this%vol(j); K_mat(3,3)=K_mat(3,3)+xi(3)*xi(3)*w*this%vol(j); + + this%F_mat(1,1,i)=this%F_mat(1,1,i)+rpos(1)*xi(1)*w*this%vol(j); this%F_mat(1,2,i)=this%F_mat(1,2,i)+rpos(1)*xi(2)*w*this%vol(j); this%F_mat(1,3,i)=this%F_mat(1,3,i)+rpos(1)*xi(3)*w*this%vol(j); + this%F_mat(2,1,i)=this%F_mat(2,1,i)+rpos(2)*xi(1)*w*this%vol(j); this%F_mat(2,2,i)=this%F_mat(2,2,i)+rpos(2)*xi(2)*w*this%vol(j); this%F_mat(2,3,i)=this%F_mat(2,3,i)+rpos(2)*xi(3)*w*this%vol(j); + this%F_mat(3,1,i)=this%F_mat(3,1,i)+rpos(3)*xi(1)*w*this%vol(j); this%F_mat(3,2,i)=this%F_mat(3,2,i)+rpos(3)*xi(2)*w*this%vol(j); this%F_mat(3,3,i)=this%F_mat(3,3,i)+rpos(3)*xi(3)*w*this%vol(j); + end do + + detK = K_mat(1,1)*(K_mat(2,2)*K_mat(3,3)-K_mat(2,3)*K_mat(3,2)) & + -K_mat(1,2)*(K_mat(2,1)*K_mat(3,3)-K_mat(2,3)*K_mat(3,1)) & + +K_mat(1,3)*(K_mat(2,1)*K_mat(3,2)-K_mat(2,2)*K_mat(3,1)) + K_inv(1,1) = (K_mat(2,2)*K_mat(3,3) - K_mat(2,3)*K_mat(3,2))/detK + K_inv(2,1) = -(K_mat(2,1)*K_mat(3,3) - K_mat(2,3)*K_mat(3,1))/detK + K_inv(3,1) = (K_mat(2,1)*K_mat(3,2) - K_mat(2,2)*K_mat(3,1))/detK + K_inv(1,2) = -(K_mat(1,2)*K_mat(3,3) - K_mat(1,3)*K_mat(3,2))/detK + K_inv(2,2) = (K_mat(1,1)*K_mat(3,3) - K_mat(1,3)*K_mat(3,1))/detK + K_inv(3,2) = -(K_mat(1,1)*K_mat(3,2) - K_mat(1,2)*K_mat(3,1))/detK + K_inv(1,3) = (K_mat(1,2)*K_mat(2,3) - K_mat(1,3)*K_mat(2,2))/detK + K_inv(2,3) = -(K_mat(1,1)*K_mat(2,3) - K_mat(1,3)*K_mat(2,1))/detK + K_inv(3,3) = (K_mat(1,1)*K_mat(2,2) - K_mat(1,2)*K_mat(2,1))/detK + + this%F_mat(:,:,i) = MATMUL(this%F_mat(:,:,i),K_inv) + E_mat = 0.5_WP * (MATMUL(TRANSPOSE(this%F_mat(:,:,i)),this%F_mat(:,:,i))-I_mat) + traceE = E_mat(1,1) + E_mat(2,2) + E_mat(3,3) + S_mat = (kk-2.0_WP/3.0_WP*mu)*traceE*I_mat + 2.0_WP*mu*E_mat + this%PK_inv(:,:,i) = MATMUL(MATMUL(this%F_mat(:,:,i),S_mat),K_inv) + end do + + ! I think here we just need to communicate PK_inv and F_mat, everything else can stay local + ! t0=parallel_time() + do e=1,3 + call this%halo%update(this%PK_inv(:,e,:),3,shifted=.false.) + end do + ! this%wt_halo=this%wt_halo+(parallel_time()-t0) + + ! Node-centered force sweep: each row computes its OWN force state t + ! (own theta, own mw) and scatters +t/-t; the neighbor's t arrives from + ! the neighbor's own row (locally or via the halo reduce below). + t0=parallel_time() + this%f=0.0_WP + do i=1,this%nown + ! if (this%mw(i).le.0.0_WP) cycle + ! ! Per-node J2 return factor from the LAGGED family norm. With + ! ! hardening (hard_mod>0) the surface radius grows with the node's + ! ! accumulated equivalent plastic strain lam_p (surface lagged one + ! ! substep like the norm: exact to O(H/3mu) per substep, and H<<3mu + ! ! for metals; stress-space equivalent of Peridigm's + ! ! elastic_plastic_hardening). The increment uses (1-beta)*strial = + ! ! the trial-stress excess, so the rate-independent limit matches the + ! ! classical radial return; (1-decay) is the Perzyna-realized + ! ! fraction. lam_p accumulates even at hard_mod=0 (free plastic- + ! ! strain diagnostic; forces unchanged there, bit-exact w/ flat yield). + ! beta=1.0_WP + ! if (plastic.and.do_j2) then + ! sYe2=(this%sigma_yield+this%hard_mod*this%lam_p(i))**2 + ! if (this%td2(i)*this%mw(i).gt.psi_fac*sYe2) then + ! beta=sqrt(psi_fac*sYe2/(this%td2(i)*this%mw(i))) + ! strial=sqrt(this%td2(i)*this%mw(i)/psi_fac) + ! this%lam_p(i)=this%lam_p(i)+(1.0_WP-beta)*(1.0_WP-decay)*strial*mu3i + ! end if + ! end if + + ! We are not currently doing the plastic behavior, so we can skip this + do e=this%ptr(i),this%ptr(i+1)-1 !IVM, does this work out so that each point is visited at the main, or do we only end up visiting half?? + if (this%dmg(e).ne.0_1) cycle + j=this%lst(e) + ! zeta=sqrt(sum((this%x0(:,j)-this%x0(:,i))**2)) + ! dxv=this%y(:,j)-this%y(:,i) + ! dY=sqrt(sum(dxv**2)) + xi=this%x0(:,j)-this%x0(:,i) + rpos=this%y(:,j) -this%y(:,i) + zeta=sqrt(sum(xi**2)) + dY = sqrt(sum(rpos**2)) + if (dY.le.0.0_WP) cycle + e_b=dY-zeta + ! Brittle break on total stretch (e > s0*zeta), irreversible. + ! Each row breaks its OWN half-entry and increments its OWN node's + ! damage by 1/nb0 (nb0 = reference row length); the counterpart row + ! breaks its half independently -- the criterion is symmetric in + ! the endpoints, so both halves break in the same substep (for + ! image bonds, up to shift-association roundoff: a 1-ulp-marginal + ! bond may break one substep apart, a benign local transient -- + ! the intact half still applies its +/- pair, conserving momentum). + if (e_b.gt.this%s0*zeta) then + this%dmg(e)=1_1 + this%damage(i)=this%damage(i)+1.0_WP/real(this%ptr(i+1)-this%ptr(i),WP) + cycle + end if + w=omega(zeta,this%delta) + ! ! Deviatoric split: e_d carries this HALF-ENTRY's inelastic stretch + ! ! e_v (per-side history: own theta, own mw -- Peridigm form; e_v=0 + ! ! recovers canonical elastic LPS bit-for-bit) + ! e_d=e_b-this%theta(i)*zeta/fdim + ! td=w/this%mw(i)*cdev*(e_d-this%visc_lambda*this%e_v(e)) + ! t =w/this%mw(i)*cvol*this%theta(i)*zeta+td + ! ! J2 family norm: pure own-row gather (no communication) + ! if (do_j2) this%td2a(i)=this%td2a(i)+td*td*this%vol(j) + ! ! Pair contribution from THIS row's force state (Peridigm volumes: + ! ! +t*V_j to self, -t*V_i to the neighbor) + ! fx=t*dxv/dY + ! this%f(:,i)=this%f(:,i)+fx*this%vol(j) + ! this%f(:,j)=this%f(:,j)-fx*this%vol(i) + ! ! Per-side viscoplastic flow of e_v (exact exponential). Two yield + ! ! criteria, as in amrpd: + ! ! sigma_yield>0: J2 radial return (per-node beta computed at the + ! ! row head above, incl. isotropic hardening), Perzyna- + ! ! regularized by (1-decay); tau->0 recovers Peridigm's + ! ! rate-independent return. + ! ! else: per-bond overstress (yield_stretch=0 -> pure Maxwell). + ! if (plastic) then + ! if (do_j2) then + ! this%e_v(e)=this%e_v(e)+(1.0_WP-beta)*(e_d-this%e_v(e))*(1.0_WP-decay) + ! else + ! e_e=e_d-this%e_v(e) + ! over=abs(e_e)-this%yield_stretch*zeta + ! if (over.gt.0.0_WP) this%e_v(e)=this%e_v(e)+sign(over*(1.0_WP-decay),e_e) + ! end if + ! end if + + ! Now we compute forces, similar to before, but we only plus up the one particle instead of being slick with both + t1 = w*MATMUL(this%PK_inv(:,:,i),xi) + ! Force density 2->1 + t2 = w*MATMUL(this%PK_inv(:,:,j),xi) + ! Force correction term + z = rpos-MATMUL(this%F_mat(:,:,i),xi) + tc = w*(9.0_WP*kk/((3.14159265_WP) * this%delta**4))*(dot_product(xi,z)/(sqrt(dot_product(xi,xi)))**3)*xi + ! Compute bond acceleration + this%f(:,i)=this%f(:,i)+(t1+t2+tc)*this%vol(j) + end do + end do + ! ! Publish this substep's J2 norm (read by the NEXT substep's return) + ! if (do_j2) then + ! this%td2(1:this%nown)=this%td2a(1:this%nown) + ! this%td2a(1:this%nown)=0.0_WP + ! end if + this%wt_force=this%wt_force+(parallel_time()-t0) + + ! Assemble cross-rank pair forces (halo slots -> owners, add) + t0=parallel_time() + call this%halo%reduce(this%f,3) + this%wt_reduce=this%wt_reduce+(parallel_time()-t0) + + ! Short-range contact (walls + particle-particle), gather-only: adds + ! into owned f, no reduction (amrpd ordering: after the bond force) + if (this%use_contact) then + t0=parallel_time() + call this%contact_narrow(dt) + this%wt_contact=this%wt_contact+(parallel_time()-t0) + end if + + ! Second half-kick with the fresh force + t0=parallel_time() + do i=1,this%nown + if (this%flag(i).eq.PDC_IS_DEAD) cycle + if (iand(this%flag(i),PDC_INTEGRATES).ne.0) then + acc=this%gravity+(this%f(:,i)+this%ff(:,i))*rho_inv + this%v(:,i)=(1.0_WP-this%damping_rate)*this%v(:,i)+0.5_WP*dt*acc + end if + if (this%collapsed(1)) this%v(1,i)=0.0_WP + if (this%collapsed(2)) this%v(2,i)=0.0_WP + if (this%collapsed(3)) this%v(3,i)=0.0_WP + end do + this%wt_kick=this%wt_kick+(parallel_time()-t0) + end subroutine pd_advance + + !> Contact broad phase: displacement-triggered rebuild of the contact halo + !> and the candidate CSR. The trigger is one scalar allreduce per substep so + !> the (collective) rebuild decision is rank-consistent. rbuild = + !> 1.2*contact_dist + 2*cskin: engagement reach is bounded by d_eff*(1+0.2) + !> (the r_influ clip) and two nodes drifting cskin each can close 2*cskin + !> between rebuilds, so the candidate set provably contains every pair that + !> can produce force before the next rebuild. + !> + !> Discovery: allgather of per-rank owned-node bounds; for each (rank, + !> periodic-image offset) whose shifted bounds approach mine within rbuild, + !> OFFER my owned nodes in range as (gid, image key, shifted position). The + !> receiver keeps offers with an owned node within rbuild (binned test) and + !> builds the contact halo from the kept references via the standard pdhalo + !> protocol (chalo%nown = ntot, so contact slots append after graph slots). + !> Candidates are then binned over OWNED + CONTACT slots only -- the graph + !> halo is never binned, so bonded remote partners arrive as contact slots + !> when in range and double-counting is structurally impossible. + subroutine contact_broadphase(this) + use parallel, only: comm,rank,nproc,MPI_REAL_WP + use mpi_f08 + use messager, only: die + implicit none + class(pdsolver), intent(inout) :: this + real(WP) :: rbuild,drift + integer :: i,ierr + + if (this%contact_dist.le.0.0_WP) call die('[pdsolver contact] use_contact requires contact_dist > 0') + if (this%cskin.le.0.0_WP) this%cskin=0.5_WP*this%contact_dist + rbuild=1.2_WP*this%contact_dist+2.0_WP*this%cskin + + ! Displacement trigger (collective decision) + if (allocated(this%ylast)) then + drift=0.0_WP + do i=1,this%nown + drift=max(drift,sum((this%y(:,i)-this%ylast(:,i))**2)) + end do + drift=sqrt(drift) + else + drift=huge(1.0_WP) + end if + call MPI_ALLREDUCE(MPI_IN_PLACE,drift,1,MPI_REAL_WP,MPI_MAX,comm,ierr) + if (drift.le.this%cskin) return + this%nrebuild=this%nrebuild+1_I8 + + rebuild: block + real(WP), dimension(3) :: bl,bh,shift,pos_s + real(WP), allocatable :: allb(:,:),opos(:,:),rpos(:,:),kpos(:,:) + integer(I8), allocatable :: ogid(:),rgid(:),kgid(:) + integer, allocatable :: okey(:),rkey(:),kkey(:),kowner(:),slot(:) + integer, dimension(0:nproc-1) :: sc,rc,sd,rd + integer, dimension(0:nproc-1) :: sc3,rc3,sd3,rd3 + integer :: nmax(3),d,r,n1,n2,n3,noff,nrecv,nkeep,k,pass + ! Binning workspace (owned nodes for offer filtering, then combined + ! set for the candidate CSR) + real(WP), dimension(3) :: gl,hcell + integer, dimension(3) :: nc + integer, allocatable :: head(:),nxt(:) + + ! Owned bounds and their global exchange + bl=huge(1.0_WP); bh=-huge(1.0_WP) + do i=1,this%nown + bl=min(bl,this%y(:,i)); bh=max(bh,this%y(:,i)) + end do + allocate(allb(6,0:nproc-1)) + call MPI_ALLGATHER([bl,bh],6,MPI_REAL_WP,allb,6,MPI_REAL_WP,comm,ierr) + + ! Admissible periodic-image offsets for contact range + do d=1,3 + nmax(d)=0 + if (this%per(d).and.this%Ldom(d).gt.0.0_WP) nmax(d)=min(4,int(rbuild/this%Ldom(d))+1) + end do + + ! Offers: two passes (count, then fill), grouped by destination rank + do pass=1,2 + sc=0 + do r=0,nproc-1 + do n3=-nmax(3),nmax(3); do n2=-nmax(2),nmax(2); do n1=-nmax(1),nmax(1) + if (r.eq.rank.and.n1.eq.0.and.n2.eq.0.and.n3.eq.0) cycle + shift=[real(n1,WP)*this%Ldom(1),real(n2,WP)*this%Ldom(2),real(n3,WP)*this%Ldom(3)] + ! Shifted-bounds proximity prefilter + if (any(bl+shift-rbuild.gt.allb(4:6,r)).or.any(bh+shift+rbuild.lt.allb(1:3,r))) cycle + do i=1,this%nown + if (this%flag(i).eq.PDC_IS_DEAD) cycle + pos_s=this%y(:,i)+shift + if (any(pos_s.lt.allb(1:3,r)-rbuild).or.any(pos_s.gt.allb(4:6,r)+rbuild)) cycle + sc(r)=sc(r)+1 + if (pass.eq.2) then + ogid(sd(r)+sc(r))=this%gid(i) + okey(sd(r)+sc(r))=(n1+128)+(n2+128)*256+(n3+128)*65536 + opos(:,sd(r)+sc(r))=pos_s + end if + end do + end do; end do; end do + end do + if (pass.eq.1) then + sd(0)=0 + do r=1,nproc-1 + sd(r)=sd(r-1)+sc(r-1) + end do + noff=sum(sc) + allocate(ogid(max(noff,1)),okey(max(noff,1)),opos(3,max(noff,1))) + end if + end do + + ! Exchange offers (gid, key, shifted position) + call MPI_ALLTOALL(sc,1,MPI_INTEGER,rc,1,MPI_INTEGER,comm,ierr) + rd(0)=0 + do r=1,nproc-1 + rd(r)=rd(r-1)+rc(r-1) + end do + nrecv=sum(rc) + allocate(rgid(max(nrecv,1)),rkey(max(nrecv,1)),rpos(3,max(nrecv,1))) + call MPI_ALLTOALLV(ogid,sc,sd,MPI_INTEGER8,rgid,rc,rd,MPI_INTEGER8,comm,ierr) + call MPI_ALLTOALLV(okey,sc,sd,MPI_INTEGER, rkey,rc,rd,MPI_INTEGER, comm,ierr) + sc3=3*sc; sd3=3*sd; rc3=3*rc; rd3=3*rd + call MPI_ALLTOALLV(opos,sc3,sd3,MPI_REAL_WP,rpos,rc3,rd3,MPI_REAL_WP,comm,ierr) + deallocate(ogid,okey,opos) + + ! Filter offers: keep those with an owned node within rbuild. + ! Bin owned nodes (cell size >= rbuild so a +/-1 cell sweep suffices; + ! dims clamped so degenerate/huge extents stay bounded). + call setup_bins(bl,bh,rbuild,gl,hcell,nc) + allocate(head(nc(1)*nc(2)*nc(3)),nxt(max(this%nown,1))) + head=0 + do i=1,this%nown + if (this%flag(i).eq.PDC_IS_DEAD) cycle + k=cell_of(this%y(:,i),gl,hcell,nc) + nxt(i)=head(k); head(k)=i + end do + allocate(kgid(max(nrecv,1)),kkey(max(nrecv,1)),kowner(max(nrecv,1)),kpos(3,max(nrecv,1))) + nkeep=0 + do r=0,nproc-1 + do i=rd(r)+1,rd(r)+rc(r) + if (near_owned(rpos(:,i),rbuild,gl,hcell,nc,head,nxt)) then + nkeep=nkeep+1 + kgid(nkeep)=rgid(i); kkey(nkeep)=rkey(i); kowner(nkeep)=r; kpos(:,nkeep)=rpos(:,i) + end if + end do + end do + deallocate(rgid,rkey,rpos,head,nxt) + + ! Rebuild the contact halo (slots append after graph slots: nown=ntot) + call this%chalo%finalize() + allocate(slot(max(nkeep,1))) + call this%chalo%build(this%ntot,this%ohash,nkeep,kgid,kkey,kowner,this%Ldom,this%per,slot) + this%nchalo=this%chalo%nhalo + + ! Extend y and v to cover contact slots; stamp slot positions from the + ! kept offers (current values -- chalo%update refreshes each substep) + resize_state: block + real(WP), allocatable :: a2(:,:) + integer :: ntc + ntc=this%ntot+this%nchalo + allocate(a2(3,max(ntc,1))); a2=0.0_WP + a2(:,1:this%ntot)=this%y(:,1:this%ntot) + call move_alloc(a2,this%y) + allocate(a2(3,max(ntc,1))); a2=0.0_WP + a2(:,1:this%nown)=this%v(:,1:this%nown) + call move_alloc(a2,this%v) + do k=1,nkeep + this%y(:,this%ntot+slot(k))=kpos(:,k) + end do + end block resize_state + deallocate(kgid,kkey,kowner,kpos,slot) + + ! Candidate CSR over the contact-visible set: owned nodes (indices + ! 1..nown) + contact slots (ntot+1..ntot+nchalo). Two passes. + candidates: block + integer :: ns,m,jj,cnt,ic,jc,kc,c1,c2,c3 + integer, allocatable :: midx(:) + real(WP), dimension(3) :: blc,bhc + ns=this%nown+this%nchalo + allocate(midx(max(ns,1))) + do m=1,this%nown + midx(m)=m + end do + do m=1,this%nchalo + midx(this%nown+m)=this%ntot+m + end do + blc=bl; bhc=bh + do m=this%nown+1,ns + blc=min(blc,this%y(:,midx(m))); bhc=max(bhc,this%y(:,midx(m))) + end do + call setup_bins(blc,bhc,rbuild,gl,hcell,nc) + allocate(head(nc(1)*nc(2)*nc(3)),nxt(max(ns,1))) + head=0 + do m=1,ns + if (m.le.this%nown) then + if (this%flag(m).eq.PDC_IS_DEAD) cycle + end if + k=cell_of(this%y(:,midx(m)),gl,hcell,nc) + nxt(m)=head(k); head(k)=m + end do + if (allocated(this%cptr)) deallocate(this%cptr) + if (allocated(this%clst)) deallocate(this%clst) + allocate(this%cptr(this%nown+1)) + do pass=1,2 + do i=1,this%nown + cnt=0 + if (this%flag(i).eq.PDC_IS_DEAD) then + if (pass.eq.1) this%cptr(i+1)=0 + cycle + end if + ic=min(nc(1),max(1,int((this%y(1,i)-gl(1))/hcell(1))+1)) + jc=min(nc(2),max(1,int((this%y(2,i)-gl(2))/hcell(2))+1)) + kc=min(nc(3),max(1,int((this%y(3,i)-gl(3))/hcell(3))+1)) + do c3=max(1,kc-1),min(nc(3),kc+1); do c2=max(1,jc-1),min(nc(2),jc+1); do c1=max(1,ic-1),min(nc(1),ic+1) + m=head(c1+nc(1)*(c2-1)+nc(1)*nc(2)*(c3-1)) + do while (m.gt.0) + jj=midx(m) + if (jj.ne.i) then + if (sum((this%y(:,jj)-this%y(:,i))**2).le.rbuild**2) then + cnt=cnt+1 + if (pass.eq.2) this%clst(this%cptr(i)+cnt-1)=jj + end if + end if + m=nxt(m) + end do + end do; end do; end do + if (pass.eq.1) this%cptr(i+1)=cnt ! provisional count + end do + if (pass.eq.1) then + this%cptr(1)=1 + do i=1,this%nown + this%cptr(i+1)=this%cptr(i)+this%cptr(i+1) + end do + allocate(this%clst(max(this%cptr(this%nown+1)-1,1))) + end if + end do + deallocate(midx,head,nxt) + end block candidates + + ! Snapshot positions for the drift trigger + if (allocated(this%ylast)) deallocate(this%ylast) + allocate(this%ylast(3,max(this%nown,1))) + this%ylast(:,1:this%nown)=this%y(:,1:this%nown) + deallocate(allb) + end block rebuild + + contains + + !> Any owned node within r of position p? (binned +/-1 cell sweep) + function near_owned(p,r,gl,h,nc,head,nxt) result(hit) + real(WP), dimension(3), intent(in) :: p,gl,h + real(WP), intent(in) :: r + integer, dimension(3), intent(in) :: nc + integer, intent(in) :: head(:),nxt(:) + logical :: hit + integer :: c(3),d,c1,c2,c3,m + hit=.false. + do d=1,3 + c(d)=min(nc(d),max(1,int((p(d)-gl(d))/h(d))+1)) + end do + do c3=max(1,c(3)-1),min(nc(3),c(3)+1); do c2=max(1,c(2)-1),min(nc(2),c(2)+1); do c1=max(1,c(1)-1),min(nc(1),c(1)+1) + m=head(c1+nc(1)*(c2-1)+nc(1)*nc(2)*(c3-1)) + do while (m.gt.0) + if (sum((this%y(:,m)-p)**2).le.r**2) then + hit=.true. + return + end if + m=nxt(m) + end do + end do; end do; end do + end function near_owned + + end subroutine contact_broadphase + + !> Contact narrow phase: soft-sphere walls + particle-particle over the + !> candidate CSR, gather-only (soft-sphere penalty ported from amrlpt's collision model; + !> IB contact arrives with the coupling layer). Adds force/volume into owned + !> f. Walls use e_w with d_eff = 0.5*contact_dist and m_eff = m1; pairs use + !> e_n with d_eff = contact_dist and m_eff = 0.5*m1 (m1 = rho*vol(i), + !> matching amrpd's uniform rho*dV on a uniform lattice). + subroutine contact_narrow(this,dt) + use mathtools, only: Pi + implicit none + class(pdsolver), intent(inout) :: this + real(WP), intent(in) :: dt + real(WP) :: tau,k_n,eta_n,k_w,eta_w,d_eff_w,m1 + real(WP), dimension(3) :: r1,v1,floc,r2 + real(WP), dimension(3), parameter :: vzero=[0.0_WP,0.0_WP,0.0_WP] + integer :: i,k,j + if (this%contact_dist.le.0.0_WP.or.dt.le.0.0_WP) return + if (this%e_n.le.0.0_WP.or.this%e_w.le.0.0_WP) return + if (this%tau_col.gt.0.0_WP) then + tau=this%tau_col + else + tau=5.0_WP*dt + end if + k_n =(Pi**2+log(this%e_n)**2)/tau**2 + eta_n=-2.0_WP*log(this%e_n)/tau + k_w =(Pi**2+log(this%e_w)**2)/tau**2 + eta_w=-2.0_WP*log(this%e_w)/tau + d_eff_w=0.5_WP*this%contact_dist + do i=1,this%nown + if (this%flag(i).eq.PDC_IS_DEAD) cycle + m1=this%rho*this%vol(i) + r1=this%y(:,i); v1=this%v(:,i) + floc=0.0_WP + ! Wall collisions on faces flagged as walls (virtual partner on the + ! wall directly normal to the node) + if (this%lo_bc(1).eq.1) then; r2=[this%dom_lo(1),r1(2),r1(3)]; call apply_col(k_w,eta_w,d_eff_w,m1,r2,vzero); end if + if (this%hi_bc(1).eq.1) then; r2=[this%dom_hi(1),r1(2),r1(3)]; call apply_col(k_w,eta_w,d_eff_w,m1,r2,vzero); end if + if (this%lo_bc(2).eq.1) then; r2=[r1(1),this%dom_lo(2),r1(3)]; call apply_col(k_w,eta_w,d_eff_w,m1,r2,vzero); end if + if (this%hi_bc(2).eq.1) then; r2=[r1(1),this%dom_hi(2),r1(3)]; call apply_col(k_w,eta_w,d_eff_w,m1,r2,vzero); end if + if (this%lo_bc(3).eq.1) then; r2=[r1(1),r1(2),this%dom_lo(3)]; call apply_col(k_w,eta_w,d_eff_w,m1,r2,vzero); end if + if (this%hi_bc(3).eq.1) then; r2=[r1(1),r1(2),this%dom_hi(3)]; call apply_col(k_w,eta_w,d_eff_w,m1,r2,vzero); end if + ! Particle-particle via the candidate CSR + do k=this%cptr(i),this%cptr(i+1)-1 + j=this%clst(k) + call apply_col(k_n,eta_n,this%contact_dist,0.5_WP*m1,this%y(:,j),this%v(:,j)) + end do + ! Accumulate as force/volume (matches bond force units) + this%f(:,i)=this%f(:,i)+floc/this%vol(i) + end do + + contains + + !> Soft-sphere normal force from virtual partner (r2_in, v2_in) onto i. + !> Host-associated r1, v1, dt, floc. + subroutine apply_col(kk,ee,d_eff,m_eff,r2_in,v2_in) + real(WP), intent(in) :: kk,ee,d_eff,m_eff + real(WP), dimension(3), intent(in) :: r2_in,v2_in + real(WP) :: d12,rnv,r_influ,delta_n + real(WP), dimension(3) :: n12,v12,f_n + d12=norm2(r2_in-r1) + if (d12.lt.10.0_WP*epsilon(d12)) return ! self-overlap guard + n12=(r2_in-r1)/d12 + v12=v1-v2_in + rnv=dot_product(v12,n12) + r_influ=min(abs(rnv)*dt,0.2_WP*d_eff) + delta_n=min(d_eff+r_influ-d12,this%clip_col*d_eff) + if (delta_n.le.0.0_WP) return + f_n=(-m_eff*kk*delta_n-m_eff*ee*rnv)*n12 + floc=floc+f_n + end subroutine apply_col + + end subroutine contact_narrow + + !> Binding CFL: elastic wave + scaled convective (limits 0.5 / 0.1) + subroutine get_cfl(this,dt,cfl) + use parallel, only: comm,MPI_REAL_WP + use mpi_f08, only: MPI_ALLREDUCE,MPI_MAX,MPI_IN_PLACE + implicit none + class(pdsolver), intent(inout) :: this + real(WP), intent(in) :: dt + real(WP), intent(out) :: cfl + real(WP), parameter :: CFL_scale_conv=5.0_WP + real(WP) :: K_bulk,mu_shear,c_p,dp_inv,vmax + integer :: i,ierr + K_bulk =this%elastic_modulus/(3.0_WP*(1.0_WP-2.0_WP*this%poisson_ratio)) + mu_shear=this%elastic_modulus/(2.0_WP*(1.0_WP+this%poisson_ratio)) + c_p =sqrt((K_bulk+4.0_WP*mu_shear/3.0_WP)/this%rho) + dp_inv =1.0_WP/this%dV**(1.0_WP/3.0_WP) + this%CFLe=c_p*dp_inv*dt + this%CFLp=0.0_WP + do i=1,this%nown + if (this%flag(i).eq.PDC_IS_DEAD) cycle + vmax=max(abs(this%v(1,i)),abs(this%v(2,i)),abs(this%v(3,i))) + this%CFLp=max(this%CFLp,vmax*dp_inv) + end do + call MPI_ALLREDUCE(MPI_IN_PLACE,this%CFLp,1,MPI_REAL_WP,MPI_MAX,comm,ierr) + this%CFLp=this%CFLp*dt + cfl=max(CFL_scale_conv*this%CFLp,this%CFLe) + end subroutine get_cfl + + !> Global counts, velocity max, and timer reduction (+reset). Collective. + subroutine get_info(this) + use parallel, only: comm,MPI_REAL_WP + use mpi_f08, only: MPI_ALLREDUCE,MPI_MAX,MPI_MIN,MPI_SUM,MPI_IN_PLACE,MPI_INTEGER8 + implicit none + class(pdsolver), intent(inout) :: this + integer :: i,ierr + integer(I8) :: np_loc + real(WP), dimension(3) :: vmin,vmax + np_loc=0_I8 + vmin=huge(1.0_WP); vmax=-huge(1.0_WP) + this%EPmax=0.0_WP + do i=1,this%nown + if (this%flag(i).eq.PDC_IS_DEAD) cycle + np_loc=np_loc+1_I8 + vmin=min(vmin,this%v(:,i)); vmax=max(vmax,this%v(:,i)) + this%EPmax=max(this%EPmax,this%lam_p(i)) + end do + this%np=np_loc + call MPI_ALLREDUCE(MPI_IN_PLACE,this%np,1,MPI_INTEGER8,MPI_SUM,comm,ierr) + call MPI_ALLREDUCE(MPI_IN_PLACE,this%EPmax,1,MPI_REAL_WP,MPI_MAX,comm,ierr) + call MPI_ALLREDUCE(MPI_IN_PLACE,vmin,3,MPI_REAL_WP,MPI_MIN,comm,ierr) + call MPI_ALLREDUCE(MPI_IN_PLACE,vmax,3,MPI_REAL_WP,MPI_MAX,comm,ierr) + if (this%np.eq.0_I8) then + vmin=0.0_WP; vmax=0.0_WP + end if + this%Umin=vmin(1); this%Umax=vmax(1) + this%Vmin=vmin(2); this%Vmax=vmax(2) + this%Wmin=vmin(3); this%Wmax=vmax(3) + ! Broken half-entry census (each broken bond counts twice, except + ! self-image bonds which have a single half-entry) + count_broken: block + integer(I8) :: nb_loc + integer :: e,i2,j2 + ! Half-entry count (internal) and EXACT broken-bond census: each bond + ! is counted at exactly one of its two half-entries -- the one whose + ! node gid is lower (ties = self-image bonds, counted at the + ! positive-offset image so each appears once) + nb_loc=0_I8; this%nb_broken=0_I8 + do i2=1,this%nown + do e=this%ptr(i2),this%ptr(i2+1)-1 + if (this%dmg(e).eq.0_1) cycle + nb_loc=nb_loc+1_I8 + j2=this%lst(e) + if (this%gid(i2).lt.this%gid(j2)) then + this%nb_broken=this%nb_broken+1_I8 + else if (this%gid(i2).eq.this%gid(j2)) then + if (j2.gt.this%nown) then + if (shift_positive(this%halo%shift(:,j2-this%nown))) this%nb_broken=this%nb_broken+1_I8 + end if + end if + end do + end do + this%nbroken=nb_loc + call MPI_ALLREDUCE(MPI_IN_PLACE,this%nbroken,1,MPI_INTEGER8,MPI_SUM,comm,ierr) + call MPI_ALLREDUCE(MPI_IN_PLACE,this%nb_broken,1,MPI_INTEGER8,MPI_SUM,comm,ierr) + end block count_broken + ! Timers: max (and min for the compute-heavy phases) across ranks, then reset + call MPI_ALLREDUCE(this%wt_kick, this%wtmax_kick, 1,MPI_REAL_WP,MPI_MAX,comm,ierr) + call MPI_ALLREDUCE(this%wt_halo, this%wtmax_halo, 1,MPI_REAL_WP,MPI_MAX,comm,ierr) + call MPI_ALLREDUCE(this%wt_dil, this%wtmax_dil, 1,MPI_REAL_WP,MPI_MAX,comm,ierr) + call MPI_ALLREDUCE(this%wt_dil, this%wtmin_dil, 1,MPI_REAL_WP,MPI_MIN,comm,ierr) + call MPI_ALLREDUCE(this%wt_force, this%wtmax_force, 1,MPI_REAL_WP,MPI_MAX,comm,ierr) + call MPI_ALLREDUCE(this%wt_force, this%wtmin_force, 1,MPI_REAL_WP,MPI_MIN,comm,ierr) + call MPI_ALLREDUCE(this%wt_reduce,this%wtmax_reduce,1,MPI_REAL_WP,MPI_MAX,comm,ierr) + call MPI_ALLREDUCE(this%wt_contact,this%wtmax_contact,1,MPI_REAL_WP,MPI_MAX,comm,ierr) + call MPI_ALLREDUCE(this%wt_broad, this%wtmax_broad, 1,MPI_REAL_WP,MPI_MAX,comm,ierr) + this%wt_kick=0.0_WP; this%wt_halo=0.0_WP; this%wt_dil=0.0_WP; this%wt_force=0.0_WP; this%wt_reduce=0.0_WP + this%wt_contact=0.0_WP; this%wt_broad=0.0_WP + ! Contact-service size census (visibility into the fragmentation-driven + ! degradation mode of the static graph partition) + contact_census: block + integer(I8) :: tmp + this%nchalo_glob=int(this%nchalo,I8) + call MPI_ALLREDUCE(MPI_IN_PLACE,this%nchalo_glob,1,MPI_INTEGER8,MPI_SUM,comm,ierr) + tmp=0_I8 + if (allocated(this%cptr)) tmp=int(this%cptr(this%nown+1)-1,I8) + this%ncand_glob=tmp + call MPI_ALLREDUCE(MPI_IN_PLACE,this%ncand_glob,1,MPI_INTEGER8,MPI_SUM,comm,ierr) + end block contact_census + end subroutine get_info + + !> Release all storage + subroutine finalize(this) + implicit none + class(pdsolver), intent(inout) :: this + if (allocated(this%gid)) deallocate(this%gid) + if (allocated(this%x0)) deallocate(this%x0) + if (allocated(this%y)) deallocate(this%y) + if (allocated(this%v)) deallocate(this%v) + if (allocated(this%f)) deallocate(this%f) + if (allocated(this%ff)) deallocate(this%ff) + if (allocated(this%vol)) deallocate(this%vol) + if (allocated(this%mw)) deallocate(this%mw) + if (allocated(this%theta)) deallocate(this%theta) + if (allocated(this%damage))deallocate(this%damage) + if (allocated(this%lam_p)) deallocate(this%lam_p) + if (allocated(this%alive)) deallocate(this%alive) + if (allocated(this%flag)) deallocate(this%flag) + if (allocated(this%ptr)) deallocate(this%ptr) + if (allocated(this%lst)) deallocate(this%lst) + if (allocated(this%dmg)) deallocate(this%dmg) + if (allocated(this%e_v)) deallocate(this%e_v) + if (allocated(this%td2)) deallocate(this%td2) + if (allocated(this%td2a)) deallocate(this%td2a) + if (allocated(this%cptr)) deallocate(this%cptr) + if (allocated(this%clst)) deallocate(this%clst) + if (allocated(this%ylast)) deallocate(this%ylast) + if (allocated(this%rextra_tmp)) deallocate(this%rextra_tmp) + call this%ohash%finalize() + call this%dir%finalize() + call this%halo%finalize() + call this%chalo%finalize() + this%nown=0; this%nhalo=0; this%ntot=0; this%nchalo=0 + end subroutine finalize + + + !> Mirror synchronization (the coupling bridge). Collective, once per FLUID + !> step. The caller walks its face particles (AMReX container on the + !> fluid decomposition) and passes per particle: gid, core owner rank (read + !> from the face particle's repurposed flag tag), and the F_fluid it interpolated + !> from the grid. This routine routes F_fluid to the owning nodes (held in + !> ff across the subsequent PD subcycles) and replies with each node's + !> current (pos, vel, damage, alive), returned aligned with the caller's + !> input order for direct write-back into the face particles. + subroutine exchange(this,nm,mgid,mowner,mff,mpos,mvel,mdmg,malive) + use parallel, only: comm,nproc,MPI_REAL_WP + use messager, only: die + use mpi_f08 + implicit none + class(pdsolver), intent(inout) :: this + integer, intent(in) :: nm + integer(I8), intent(in) :: mgid(:) + integer, intent(in) :: mowner(:) + real(WP), intent(in) :: mff(:,:) + real(WP), intent(out) :: mpos(:,:),mvel(:,:) + real(WP), intent(out) :: mdmg(:),malive(:) + integer, dimension(0:nproc-1) :: sc,rc,sd,rd + integer, dimension(0:nproc-1) :: scw,rcw,sdw,rdw + integer, allocatable :: pos(:),qpos(:) + integer(I8), allocatable :: sg(:),rg(:) + real(WP), allocatable :: sff(:,:),rff(:,:),srep(:,:),rrep(:,:) + integer :: i,r,nr,idx,ierr + + ! Count and pack by owner, remembering each entry's packed slot + sc=0 + do i=1,nm + sc(mowner(i))=sc(mowner(i))+1 + end do + call MPI_ALLTOALL(sc,1,MPI_INTEGER,rc,1,MPI_INTEGER,comm,ierr) + sd(0)=0; rd(0)=0 + do r=1,nproc-1 + sd(r)=sd(r-1)+sc(r-1); rd(r)=rd(r-1)+rc(r-1) + end do + allocate(pos(0:nproc-1),qpos(max(nm,1))) + allocate(sg(max(nm,1)),sff(3,max(nm,1))) + pos=sd + do i=1,nm + r=mowner(i); pos(r)=pos(r)+1 + sg(pos(r))=mgid(i); sff(:,pos(r))=mff(:,i); qpos(i)=pos(r) + end do + nr=sum(rc) + allocate(rg(max(nr,1)),rff(3,max(nr,1))) + call MPI_ALLTOALLV(sg,sc,sd,MPI_INTEGER8,rg,rc,rd,MPI_INTEGER8,comm,ierr) + scw=3*sc; sdw=3*sd; rcw=3*rc; rdw=3*rd + call MPI_ALLTOALLV(sff,scw,sdw,MPI_REAL_WP,rff,rcw,rdw,MPI_REAL_WP,comm,ierr) + + ! Owner side: ingest F_fluid, build the state reply in arrival order + allocate(rrep(8,max(nr,1))) + do i=1,nr + idx=this%ohash%lookup(rg(i)) + if (idx.lt.1) call die('[pdsolver exchange] face gid not owned by tagged rank') + this%ff(:,idx)=rff(:,i) + rrep(1:3,i)=this%y(:,idx) + rrep(4:6,i)=this%v(:,idx) + rrep(7,i) =this%damage(idx) + rrep(8,i) =this%alive(idx) + end do + + ! Reply along the reverse route; unpack to the caller's original order + allocate(srep(8,max(nm,1))) + scw=8*rc; sdw=8*rd; rcw=8*sc; rdw=8*sd + call MPI_ALLTOALLV(rrep,scw,sdw,MPI_REAL_WP,srep,rcw,rdw,MPI_REAL_WP,comm,ierr) + do i=1,nm + mpos(:,i) =srep(1:3,qpos(i)) + mvel(:,i) =srep(4:6,qpos(i)) + mdmg(i) =srep(7,qpos(i)) + malive(i) =srep(8,qpos(i)) + end do + deallocate(pos,qpos,sg,sff,rg,rff,rrep,srep) + end subroutine exchange + + + !> Owner-rank lookup for arbitrary node gids via the persistent directory. + !> Collective. Drivers use it to re-stamp face routing tags after restart. + subroutine query_owners(this,n,gids,owners) + implicit none + class(pdsolver), intent(inout) :: this + integer, intent(in) :: n + integer(I8), intent(in) :: gids(:) + integer, intent(out) :: owners(:) + call this%dir%query(n,gids,owners) + end subroutine query_owners + + !> Checkpoint the core under /: per-rank stream files + root + !> header. Records are GID-SPACE (no local indices, no partition info) -- + !> nodes: (gid, flag, x0, y, v, f, vol, damage, td2, lam_p); half-entries: + !> (node_gid, nbr_gid, image_key, dmg, e_v), the image key reconstructed + !> from the halo slot's shift. Rank-count portable on read. Format v2 + !> (v1 = pre-hardening, no lam_p record; read_state accepts both). + subroutine write_state(this,dirname) + use parallel, only: rank,nproc,amRoot + use messager, only: die + use string, only: str_medium + implicit none + class(pdsolver), intent(inout) :: this + character(len=*), intent(in) :: dirname + character(len=str_medium) :: fname + integer :: iunit,ios,i,e,j,nhe + integer, allocatable :: hkey(:) + integer(I8), allocatable :: hnode(:),hnbr(:) + ! Half-entries in gid space + nhe=this%ptr(this%nown+1)-1 + allocate(hnode(max(nhe,1)),hnbr(max(nhe,1)),hkey(max(nhe,1))) + do i=1,this%nown + do e=this%ptr(i),this%ptr(i+1)-1 + j=this%lst(e) + hnode(e)=this%gid(i) + hnbr(e) =this%gid(j) + if (j.le.this%nown) then + hkey(e)=PDHALO_KEY0 + else + hkey(e)=key_of_shift(this%halo%shift(:,j-this%nown),this%Ldom) + end if + end do + end do + ! Per-rank stream file + ! All solid state lives under /pd/ (root creates it) + make_dir: block + use parallel, only: comm + use mpi_f08, only: MPI_BARRIER + integer :: ierr2 + if (amRoot) call execute_command_line('mkdir -p '//trim(dirname)//'/pd') + call MPI_BARRIER(comm,ierr2) + end block make_dir + write(fname,'(a,"/pd/pd_",i7.7,".bin")') trim(dirname),rank + open(newunit=iunit,file=trim(fname),form='unformatted',access='stream',status='replace',iostat=ios) + if (ios.ne.0) call die('[pdsolver write_state] cannot open '//trim(fname)) + write(iunit) this%nown,nhe + write(iunit) this%gid(1:this%nown) + write(iunit) this%flag(1:this%nown) + write(iunit) this%x0(:,1:this%nown) + write(iunit) this%y(:,1:this%nown) + write(iunit) this%v(:,1:this%nown) + write(iunit) this%f(:,1:this%nown) + write(iunit) this%vol(1:this%nown) + write(iunit) this%damage(1:this%nown) + write(iunit) this%td2(1:this%nown) + write(iunit) this%lam_p(1:this%nown) + write(iunit) hnode(1:nhe) + write(iunit) hnbr(1:nhe) + write(iunit) hkey(1:nhe) + write(iunit) this%dmg(1:nhe) + write(iunit) this%e_v(1:nhe) + close(iunit) + deallocate(hnode,hnbr,hkey) + ! Root header (file count for portable round-robin reads) + if (amRoot) then + open(newunit=iunit,file=trim(dirname)//'/pd/header',form='formatted',status='replace',iostat=ios) + if (ios.ne.0) call die('[pdsolver write_state] cannot open header') + write(iunit,'(a)') 'pdsolver checkpoint v2' + write(iunit,'(i0)') nproc + close(iunit) + end if + contains + !> Reconstruct the packed image key from a slot shift vector + pure function key_of_shift(s,L) result(k) + implicit none + real(WP), dimension(3), intent(in) :: s,L + integer :: k,n1,n2,n3 + n1=0; n2=0; n3=0 + if (L(1).gt.0.0_WP) n1=nint(s(1)/L(1)) + if (L(2).gt.0.0_WP) n2=nint(s(2)/L(2)) + if (L(3).gt.0.0_WP) n3=nint(s(3)/L(3)) + k=(n1+128)+(n2+128)*256+(n3+128)*65536 + end function key_of_shift + end subroutine write_state + + !> Restore the core from a checkpoint written by write_state. Collective; + !> rank-count portable: files read round-robin, nodes re-partitioned by + !> Morton order of the reference configuration, half-entries routed to + !> their owners, CSR/halo rebuilt via assemble with the loaded per-entry + !> state. The caller must configure the solver (initialize + material/ + !> contact/plastic component assignments) BEFORE calling this. + subroutine read_state(this,dirname) + use parallel, only: comm,rank,nproc,MPI_REAL_WP + use messager, only: die + use string, only: str_medium + use mpi_f08 + implicit none + class(pdsolver), intent(inout) :: this + character(len=*), intent(in) :: dirname + character(len=str_medium) :: fname,line + integer :: nfiles,iunit,ios,f,i,r,ierr,iver + integer :: nn,nhe,nf,nhf + integer(I8), allocatable :: gid(:),hnode(:),hnbr(:) + integer, allocatable :: flag(:),hkey(:),owner(:) + real(WP), allocatable :: x0(:,:),yy(:,:),vv(:,:),ffb(:,:),vol(:),dmgn(:),td2n(:),lamn(:) + real(WP), allocatable :: hev(:) + integer(1), allocatable :: hdmg(:) + + ! Resolve derived configuration (restart-safe shared path) + call this%derive_config() + + ! Header: number of files written + format version (v1 = no lam_p record) + nfiles=0; iver=1 + if (rank.eq.0) then + open(newunit=iunit,file=trim(dirname)//'/pd/header',form='formatted',status='old',iostat=ios) + if (ios.ne.0) call die('[pdsolver read_state] no pd/header under '//trim(dirname)) + read(iunit,'(a)') line + if (index(line,'v2').gt.0) iver=2 + read(iunit,*) nfiles + close(iunit) + end if + call MPI_BCAST(nfiles,1,MPI_INTEGER,0,comm,ierr) + call MPI_BCAST(iver,1,MPI_INTEGER,0,comm,ierr) + + ! Read my round-robin share of the files, concatenating records + nn=0; nhe=0 + do f=rank,nfiles-1,nproc + write(fname,'(a,"/pd/pd_",i7.7,".bin")') trim(dirname),f + open(newunit=iunit,file=trim(fname),form='unformatted',access='stream',status='old',iostat=ios) + if (ios.ne.0) call die('[pdsolver read_state] cannot open '//trim(fname)) + read(iunit) nf,nhf + call grow_i8(gid,nn,nf); call grow_i4(flag,nn,nf) + call grow_r2(x0,nn,nf); call grow_r2(yy,nn,nf) + call grow_r2(vv,nn,nf); call grow_r2(ffb,nn,nf) + call grow_r1(vol,nn,nf); call grow_r1(dmgn,nn,nf); call grow_r1(td2n,nn,nf) + call grow_r1(lamn,nn,nf) + read(iunit) gid(nn+1:nn+nf) + read(iunit) flag(nn+1:nn+nf) + read(iunit) x0(:,nn+1:nn+nf) + read(iunit) yy(:,nn+1:nn+nf) + read(iunit) vv(:,nn+1:nn+nf) + read(iunit) ffb(:,nn+1:nn+nf) + read(iunit) vol(nn+1:nn+nf) + read(iunit) dmgn(nn+1:nn+nf) + read(iunit) td2n(nn+1:nn+nf) + if (iver.ge.2) then + read(iunit) lamn(nn+1:nn+nf) + else + lamn(nn+1:nn+nf)=0.0_WP + end if + call grow_i8(hnode,nhe,nhf); call grow_i8(hnbr,nhe,nhf) + call grow_i4(hkey,nhe,nhf); call grow_i1(hdmg,nhe,nhf); call grow_r1(hev,nhe,nhf) + read(iunit) hnode(nhe+1:nhe+nhf) + read(iunit) hnbr(nhe+1:nhe+nhf) + read(iunit) hkey(nhe+1:nhe+nhf) + read(iunit) hdmg(nhe+1:nhe+nhf) + read(iunit) hev(nhe+1:nhe+nhf) + close(iunit) + nn=nn+nf; nhe=nhe+nhf + end do + if (.not.allocated(gid)) then ! ranks with no files still join collectives + allocate(gid(1),flag(1),x0(3,1),yy(3,1),vv(3,1),ffb(3,1),vol(1),dmgn(1),td2n(1),lamn(1)) + allocate(hnode(1),hnbr(1),hkey(1),hdmg(1),hev(1)) + end if + + ! Re-partition nodes by Morton order of the REFERENCE configuration and + ! route the full records (pd_partition routes the set_nodes payload; the + ! remaining fields ride a second, identically-ordered exchange) + repartition: block + integer(I8), allocatable :: rgid(:) + real(WP), allocatable :: rx0(:,:),rvv(:,:),rvol(:),extra(:,:) + integer, allocatable :: rflag(:) + integer, dimension(0:nproc-1) :: sc,rc,sd,rd,scw,rcw,sdw,rdw + integer, allocatable :: pos(:) + integer :: nr + allocate(owner(max(nn,1))) + call pd_partition(nn,gid,x0,vv,flag,vol,owner,nr,rgid,rx0,rvv,rflag,rvol) + ! Second exchange: (y, f, damage, td2) = 8 reals, packed in the same + ! per-destination input order as pd_partition's own packing + sc=0 + do i=1,nn + sc(owner(i))=sc(owner(i))+1 + end do + call MPI_ALLTOALL(sc,1,MPI_INTEGER,rc,1,MPI_INTEGER,comm,ierr) + sd(0)=0; rd(0)=0 + do r=1,nproc-1 + sd(r)=sd(r-1)+sc(r-1); rd(r)=rd(r-1)+rc(r-1) + end do + allocate(pos(0:nproc-1),extra(9,max(nn,1)),this%rextra_tmp(9,max(nr,1))) + pos=sd + do i=1,nn + r=owner(i); pos(r)=pos(r)+1 + extra(1:3,pos(r))=yy(:,i) + extra(4:6,pos(r))=ffb(:,i) + extra(7,pos(r)) =dmgn(i) + extra(8,pos(r)) =td2n(i) + extra(9,pos(r)) =lamn(i) + end do + scw=9*sc; sdw=9*sd; rcw=9*rc; rdw=9*rd + call MPI_ALLTOALLV(extra,scw,sdw,MPI_REAL_WP,this%rextra_tmp,rcw,rdw,MPI_REAL_WP,comm,ierr) + ! Load the routed nodes, then overlay the restart-only fields + call this%set_nodes(nr,rgid,rx0,rvv,rflag,rvol) + do i=1,nr + this%y(:,i) =this%rextra_tmp(1:3,i) + this%f(:,i) =this%rextra_tmp(4:6,i) + this%damage(i)=this%rextra_tmp(7,i) + end do + deallocate(pos,extra,rgid,rx0,rvv,rflag,rvol) + end block repartition + + ! Register the directory over the new partition, route half-entries to + ! their owners (state travels along), and rebuild CSR/halo/reference + route_and_assemble: block + integer(I8), allocatable :: rnode(:),rnbr(:) + integer, allocatable :: rkey(:),howner(:) + real(WP), allocatable :: rev(:) + integer(1), allocatable :: rdmg(:) + integer, dimension(0:nproc-1) :: sc,rc,sd,rd + integer, allocatable :: pos(:) + integer(I8), allocatable :: s8(:) + integer, allocatable :: s4(:) + real(WP), allocatable :: sr(:) + integer(1), allocatable :: s1(:) + integer :: rn,h + call this%dir%finalize() + call this%dir%register(this%nown,this%gid(1:this%nown)) + allocate(howner(max(nhe,1))) + call this%dir%query(nhe,hnode,howner) + sc=0 + do i=1,nhe + sc(howner(i))=sc(howner(i))+1 + end do + call MPI_ALLTOALL(sc,1,MPI_INTEGER,rc,1,MPI_INTEGER,comm,ierr) + sd(0)=0; rd(0)=0 + do r=1,nproc-1 + sd(r)=sd(r-1)+sc(r-1); rd(r)=rd(r-1)+rc(r-1) + end do + rn=sum(rc) + allocate(rnode(max(rn,1)),rnbr(max(rn,1)),rkey(max(rn,1)),rev(max(rn,1)),rdmg(max(rn,1))) + allocate(pos(0:nproc-1),s8(max(nhe,1)),s4(max(nhe,1)),sr(max(nhe,1)),s1(max(nhe,1))) + pos=sd + do i=1,nhe + h=howner(i); pos(h)=pos(h)+1; s8(pos(h))=hnode(i) + end do + call MPI_ALLTOALLV(s8,sc,sd,MPI_INTEGER8,rnode,rc,rd,MPI_INTEGER8,comm,ierr) + pos=sd + do i=1,nhe + h=howner(i); pos(h)=pos(h)+1; s8(pos(h))=hnbr(i) + end do + call MPI_ALLTOALLV(s8,sc,sd,MPI_INTEGER8,rnbr,rc,rd,MPI_INTEGER8,comm,ierr) + pos=sd + do i=1,nhe + h=howner(i); pos(h)=pos(h)+1; s4(pos(h))=hkey(i) + end do + call MPI_ALLTOALLV(s4,sc,sd,MPI_INTEGER,rkey,rc,rd,MPI_INTEGER,comm,ierr) + pos=sd + do i=1,nhe + h=howner(i); pos(h)=pos(h)+1; sr(pos(h))=hev(i) + end do + call MPI_ALLTOALLV(sr,sc,sd,MPI_REAL_WP,rev,rc,rd,MPI_REAL_WP,comm,ierr) + pos=sd + do i=1,nhe + h=howner(i); pos(h)=pos(h)+1; s1(pos(h))=hdmg(i) + end do + call MPI_ALLTOALLV(s1,sc,sd,MPI_INTEGER1,rdmg,rc,rd,MPI_INTEGER1,comm,ierr) + call this%assemble(rn,rnode,rnbr,rkey,rev,rdmg) + deallocate(rnode,rnbr,rkey,rev,rdmg,pos,s8,s4,sr,s1,howner) + end block route_and_assemble + + ! Overlay td2/lam_p (assemble/set_nodes zero them) and life status + do i=1,this%nown + this%td2(i) =this%rextra_tmp(8,i) + this%lam_p(i)=this%rextra_tmp(9,i) + if (this%flag(i).eq.PDC_IS_DEAD) this%alive(i)=0.0_WP + end do + deallocate(this%rextra_tmp) + call this%halo%update1(this%alive) + deallocate(gid,flag,x0,yy,vv,ffb,vol,dmgn,td2n,lamn,hnode,hnbr,hkey,hdmg,hev,owner) + + contains + + subroutine grow_i8(a,n,add) + integer(I8), allocatable, intent(inout) :: a(:) + integer, intent(in) :: n,add + integer(I8), allocatable :: t(:) + allocate(t(n+add)); if (n.gt.0) t(1:n)=a(1:n) + call move_alloc(t,a) + end subroutine grow_i8 + subroutine grow_i4(a,n,add) + integer, allocatable, intent(inout) :: a(:) + integer, intent(in) :: n,add + integer, allocatable :: t(:) + allocate(t(n+add)); if (n.gt.0) t(1:n)=a(1:n) + call move_alloc(t,a) + end subroutine grow_i4 + subroutine grow_i1(a,n,add) + integer(1), allocatable, intent(inout) :: a(:) + integer, intent(in) :: n,add + integer(1), allocatable :: t(:) + allocate(t(n+add)); if (n.gt.0) t(1:n)=a(1:n) + call move_alloc(t,a) + end subroutine grow_i1 + subroutine grow_r1(a,n,add) + real(WP), allocatable, intent(inout) :: a(:) + integer, intent(in) :: n,add + real(WP), allocatable :: t(:) + allocate(t(n+add)); if (n.gt.0) t(1:n)=a(1:n) + call move_alloc(t,a) + end subroutine grow_r1 + subroutine grow_r2(a,n,add) + real(WP), allocatable, intent(inout) :: a(:,:) + integer, intent(in) :: n,add + real(WP), allocatable :: t(:,:) + allocate(t(3,n+add)); if (n.gt.0) t(:,1:n)=a(:,1:n) + call move_alloc(t,a) + end subroutine grow_r2 + + end subroutine read_state + + + !> Static load-balancing partition of the reference configuration. + !> Collective; called once at handoff, BEFORE set_nodes. Nodes are ordered + !> by the Morton key of their reference position and split into equal-count + !> contiguous ranges: on a uniform lattice family size is ~constant, so node + !> count ~ bond work (a family-weighted split can substitute later), and + !> bond work is motion-invariant -- this balance holds for the entire run + !> regardless of deformation or flight, using ALL ranks even when the solid + !> occupies a corner of the fluid domain. + !> Inputs: this rank's extracted nodes (any distribution). Outputs: the + !> nodes assigned to this rank, plus each INPUT node's assigned owner (for + !> stamping the face particles' routing tags). + subroutine pd_partition(n_in,gid_in,pos_in,vel_in,flag_in,vol_in,owner_out, & + & n_out,gid_out,pos_out,vel_out,flag_out,vol_out) + use parallel, only: comm,rank,nproc,amRoot,MPI_REAL_WP + use pdhalo_class, only: sort3_perm + use mpi_f08 + implicit none + integer, intent(in) :: n_in + integer(I8), intent(in) :: gid_in(:) + real(WP), intent(in) :: pos_in(:,:),vel_in(:,:) + integer, intent(in) :: flag_in(:) + real(WP), intent(in) :: vol_in(:) + integer, intent(out) :: owner_out(:) + integer, intent(out) :: n_out + integer(I8), allocatable, intent(out) :: gid_out(:) + real(WP), allocatable, intent(out) :: pos_out(:,:),vel_out(:,:),vol_out(:) + integer, allocatable, intent(out) :: flag_out(:) + real(WP), dimension(3) :: blo,bhi,inv + integer(I8), allocatable :: keys(:),splitters(:) + integer :: i,r,d,ierr + + ! Global reference bounds + blo=huge(1.0_WP); bhi=-huge(1.0_WP) + do i=1,n_in + blo=min(blo,pos_in(:,i)); bhi=max(bhi,pos_in(:,i)) + end do + call MPI_ALLREDUCE(MPI_IN_PLACE,blo,3,MPI_REAL_WP,MPI_MIN,comm,ierr) + call MPI_ALLREDUCE(MPI_IN_PLACE,bhi,3,MPI_REAL_WP,MPI_MAX,comm,ierr) + do d=1,3 + inv(d)=0.0_WP + if (bhi(d).gt.blo(d)) inv(d)=2097151.0_WP/(bhi(d)-blo(d)) + end do + + ! Morton keys of this rank's nodes + allocate(keys(max(n_in,1))) + do i=1,n_in + keys(i)=morton(pos_in(:,i),blo,inv) + end do + + ! Equal-weight splitters by SAMPLE SORT: each rank contributes a few + ! evenly-spaced samples of its locally sorted keys, weighted by its node + ! count -- root memory is O(nproc*S), not O(N_global), so this scales to + ! very large rank counts (the old gather-all-keys approach walled at + ! root memory and int32 N_global). + allocate(splitters(max(nproc-1,1))) + sample_splitters: block + integer, parameter :: S=16 + integer(I8), allocatable :: lsamp(:),gsamp(:),gw(:) + real(WP), allocatable :: w(:) + integer, allocatable :: perm(:),zk(:),scnt(:),sdis(:) + integer(I8) :: wtot,wcum,wtarg + integer :: ns,j,r2,gtot + ! Locally sort keys (permutation) and draw samples + allocate(perm(max(n_in,1)),zk(max(n_in,1))) + do i=1,n_in + perm(i)=i + end do + zk=0 + if (n_in.gt.1) call sort3_perm(zk,keys(1:n_in),zk,perm,1,n_in) + ns=min(S,n_in) + allocate(lsamp(max(ns,1))) + do j=1,ns + lsamp(j)=keys(perm(min(n_in,int((real(j,WP)-0.5_WP)*real(n_in,WP)/real(ns,WP))+1))) + end do + deallocate(perm,zk) + ! Gather samples (+ per-rank sample counts and node counts) on root + allocate(scnt(nproc),sdis(nproc)) + call MPI_GATHER(ns,1,MPI_INTEGER,scnt,1,MPI_INTEGER,0,comm,ierr) + gtot=0 + if (amRoot) then + sdis(1)=0 + do r2=2,nproc + sdis(r2)=sdis(r2-1)+scnt(r2-1) + end do + gtot=sum(scnt) + end if + allocate(gsamp(max(gtot,1)),gw(nproc)) + call MPI_GATHERV(lsamp,ns,MPI_INTEGER8,gsamp,scnt,sdis,MPI_INTEGER8,0,comm,ierr) + call MPI_GATHER(int(n_in,I8),1,MPI_INTEGER8,gw,1,MPI_INTEGER8,0,comm,ierr) + if (amRoot.and.gtot.gt.0) then + root_split: block + integer, allocatable :: p2(:),z2(:) + real(WP), allocatable :: sw(:) + ! Weight each sample by (its rank's node count)/(its rank's samples) + allocate(sw(gtot),p2(gtot),z2(gtot)) + do r2=1,nproc + do j=sdis(r2)+1,sdis(r2)+scnt(r2) + sw(j)=real(gw(r2),WP)/real(max(scnt(r2),1),WP) + end do + end do + do j=1,gtot + p2(j)=j + end do + z2=0 + call sort3_perm(z2,gsamp(1:gtot),z2,p2,1,gtot) + ! Single cumulative-weight pass placing all nproc-1 splitters + wtot=sum(gw) + wcum=0_I8; r2=1 + do j=1,gtot + if (r2.gt.nproc-1) exit + wcum=wcum+int(sw(p2(j)),I8) + do while (r2.le.nproc-1.and.wcum.ge.(int(r2,I8)*wtot)/int(nproc,I8)) + splitters(r2)=gsamp(p2(j)) + r2=r2+1 + end do + end do + do while (r2.le.nproc-1) + splitters(r2)=huge(1_I8) ! degenerate tail: empty upper buckets + r2=r2+1 + end do + deallocate(sw,p2,z2) + end block root_split + end if + deallocate(lsamp,gsamp,gw,scnt,sdis) + end block sample_splitters + if (nproc.gt.1) call MPI_BCAST(splitters,nproc-1,MPI_INTEGER8,0,comm,ierr) + + ! Assign owners: bucket = number of splitters <= key + do i=1,n_in + owner_out(i)=0 + do r=1,nproc-1 + if (keys(i).ge.splitters(r)) owner_out(i)=r + end do + end do + deallocate(keys,splitters) + + ! Route node payloads to their owners + route_nodes: block + integer, dimension(0:nproc-1) :: sc,rc,sd,rd,scw,rcw,sdw,rdw + integer, allocatable :: pos(:),sflag(:) + integer(I8), allocatable :: sgid(:) + real(WP), allocatable :: sdat(:,:),rdat(:,:) + sc=0 + do i=1,n_in + sc(owner_out(i))=sc(owner_out(i))+1 + end do + call MPI_ALLTOALL(sc,1,MPI_INTEGER,rc,1,MPI_INTEGER,comm,ierr) + sd(0)=0; rd(0)=0 + do r=1,nproc-1 + sd(r)=sd(r-1)+sc(r-1); rd(r)=rd(r-1)+rc(r-1) + end do + n_out=sum(rc) + allocate(pos(0:nproc-1),sgid(max(n_in,1)),sflag(max(n_in,1)),sdat(7,max(n_in,1))) + pos=sd + do i=1,n_in + r=owner_out(i); pos(r)=pos(r)+1 + sgid(pos(r))=gid_in(i) + sflag(pos(r))=flag_in(i) + sdat(1:3,pos(r))=pos_in(:,i) + sdat(4:6,pos(r))=vel_in(:,i) + sdat(7,pos(r)) =vol_in(i) + end do + allocate(gid_out(max(n_out,1)),flag_out(max(n_out,1)),rdat(7,max(n_out,1))) + allocate(pos_out(3,max(n_out,1)),vel_out(3,max(n_out,1)),vol_out(max(n_out,1))) + call MPI_ALLTOALLV(sgid,sc,sd,MPI_INTEGER8,gid_out,rc,rd,MPI_INTEGER8,comm,ierr) + call MPI_ALLTOALLV(sflag,sc,sd,MPI_INTEGER,flag_out,rc,rd,MPI_INTEGER,comm,ierr) + scw=7*sc; sdw=7*sd; rcw=7*rc; rdw=7*rd + call MPI_ALLTOALLV(sdat,scw,sdw,MPI_REAL_WP,rdat,rcw,rdw,MPI_REAL_WP,comm,ierr) + do i=1,n_out + pos_out(:,i)=rdat(1:3,i) + vel_out(:,i)=rdat(4:6,i) + vol_out(i) =rdat(7,i) + end do + deallocate(pos,sgid,sflag,sdat,rdat) + end block route_nodes + + contains + + !> 63-bit Morton key: 21 bits per dimension, bit-interleaved + pure function morton(p,lo,inv) result(key) + implicit none + real(WP), dimension(3), intent(in) :: p,lo,inv + integer(I8) :: key + integer(I8), dimension(3) :: ix + integer :: b,d + do d=1,3 + ix(d)=int(min(max((p(d)-lo(d))*inv(d),0.0_WP),2097151.0_WP),I8) + end do + key=0_I8 + do b=0,20 + do d=1,3 + if (btest(ix(d),b)) key=ibset(key,3*b+d-1) + end do + end do + end function morton + + end subroutine pd_partition + + + !> Bin geometry: cell size >= the search radius (so +/-1 cell sweeps are complete), + !> dims clamped to keep total cell count bounded on huge/degenerate extents + subroutine setup_bins(lo,hi,r,gl,h,nc) + real(WP), dimension(3), intent(in) :: lo,hi + real(WP), intent(in) :: r + real(WP), dimension(3), intent(out) :: gl,h + integer, dimension(3), intent(out) :: nc + integer :: d + do d=1,3 + gl(d)=lo(d)-0.5_WP*r + nc(d)=max(1,min(256,int((hi(d)-lo(d)+r)/r))) + h(d)=max((hi(d)+0.5_WP*r-gl(d))/real(nc(d),WP),r) + end do + end subroutine setup_bins + + !> Flattened cell index of a position (clamped into the grid) + pure function cell_of(p,gl,h,nc) result(k) + real(WP), dimension(3), intent(in) :: p,gl,h + integer, dimension(3), intent(in) :: nc + integer :: k,c(3),d + do d=1,3 + c(d)=min(nc(d),max(1,int((p(d)-gl(d))/h(d))+1)) + end do + k=c(1)+nc(1)*(c(2)-1)+nc(1)*nc(2)*(c(3)-1) + end function cell_of + + + !> Influence function w(zeta) (Peridigm forms). ONE form active, hard-coded; + !> flip by (un)commenting -- s0-from-G_c, psi_fac, and the critical-dt + !> diagnostic all generalize through wmoment(), so nothing else changes. + pure function omega(d,h) result(w) + ! implicit none + ! real(WP), intent(in) :: d,h + ! real(WP) :: w + ! real(WP) :: s + ! ! Parabolic decay (ACTIVE): 1 in the core, C1 taper to 0 at the horizon + ! s=d/h + ! if (s.lt.0.5_WP) then + ! w=1.0_WP + ! else + ! w=max(4.0_WP*s*(1.0_WP-s),0.0_WP) + ! end if + ! ! Constant (Peridigm default; pre-2026-07-16 behavior) + ! !w=1.0_WP + ! ! Gaussian + ! !w=exp(-(d/(0.4_WP*h))**2) + implicit none + real(WP), intent(in) :: d,h + real(WP), parameter :: coeff=2.6_WP + real(WP) :: hh, w + ! hh=coeff*h + hh=h + if (d.ge.hh) then + w=0.0_WP + else + ! wgauss=(1.0_WP+4.0_WP*d/hh)*(1.0_WP-d/hh)**4 + w=(1.0_WP-d/h)**3 + end if + end function omega + + !> Moment of the influence function: int_0^delta w(z)^wpow * z^zpow dz + !> (midpoint quadrature through omega(), so any form change propagates) + pure function wmoment(delta,zpow,wpow) result(m) + implicit none + real(WP), intent(in) :: delta + integer, intent(in) :: zpow,wpow + real(WP) :: m + integer, parameter :: NQ=2048 + integer :: i + real(WP) :: z,dz + dz=delta/real(NQ,WP) + m=0.0_WP + do i=1,NQ + z=(real(i,WP)-0.5_WP)*dz + m=m+omega(z,delta)**wpow*z**zpow + end do + m=m*dz + end function wmoment + + !> Lexicographic sign of an image shift: .true. for the "positive" member + !> of a self-image pair (first nonzero component positive), so each + !> self-image bond is census-counted exactly once. + pure function shift_positive(s) result(p) + implicit none + real(WP), dimension(3), intent(in) :: s + logical :: p + integer :: d + p=.false. + do d=1,3 + if (abs(s(d)).gt.0.0_WP) then + p=(s(d).gt.0.0_WP) + return + end if + end do + end function shift_positive + + !> Negate a packed periodic image offset (amrpd hist1 convention) + pure function negkey(key) result(nk) + implicit none + integer, intent(in) :: key + integer :: nk,n1,n2,n3 + n1=mod(key,256)-128; n2=mod(key/256,256)-128; n3=key/65536-128 + nk=(-n1+128)+(-n2+128)*256+(-n3+128)*65536 + end function negkey + +end module pdsolver_class diff --git a/examples/NOSB_plate_with_hole_peridigm/src/simulation.f90 b/examples/NOSB_plate_with_hole_peridigm/src/simulation.f90 new file mode 100644 index 000000000..9af3ca25d --- /dev/null +++ b/examples/NOSB_plate_with_hole_peridigm/src/simulation.f90 @@ -0,0 +1,584 @@ +!> Various definitions and tools for running an NGA2 simulation +module simulation + use precision, only: WP, I8 + use geometry, only: cfg + use fft2d_class, only: fft2d + use ddadi_class, only: ddadi + use incomp_class, only: incomp + use lsspd_class, only: lss, pd_partition, PDC_MOVES,PDC_INTEGRATES,PDC_BONDS + use timetracker_class, only: timetracker + use ensight_class, only: ensight + use partmesh_class, only: partmesh + use event_class, only: event + use monitor_class, only: monitor + implicit none + private + + !> Get a couple linear solvers, an incompressible flow solver and corresponding time tracker + type(fft2d), public :: ps + type(ddadi), public :: vs + type(incomp), public :: fs + type(lss), public :: ls + type(timetracker), public :: time + + !> Ensight postprocessing + + type(ensight) :: ens_out + type(event) :: ens_evt + type(partmesh), public :: pmesh + !> Simulation monitor file + type(monitor) :: mfile,cflfile,sfile + + public :: simulation_init,simulation_run,simulation_final + + !> Private work arrays + real(WP), dimension(:,:,:), allocatable :: div_x,div_y,div_z + real(WP), dimension(:,:,:), allocatable :: resU,resV,resW + real(WP), dimension(:,:,:), allocatable :: Ui,Vi,Wi + real(WP), dimension(:,:,:), allocatable :: Uib,Vib,Wib,srcM + real(WP), dimension(:,:,:,:,:), allocatable :: gradU + + !> Max timestep size for solid solver + real(WP) :: ls_dt,ls_dt_max + + contains + + + !> Function that localizes the left (x-) of the domain + function left_of_domain(pg,i,j,k) result(isIn) + use pgrid_class, only: pgrid + implicit none + class(pgrid), intent(in) :: pg + integer, intent(in) :: i,j,k + logical :: isIn + isIn=.false. + if (i.eq.pg%imin) isIn=.true. + end function left_of_domain + + + !> Function that localizes the right (x+) of the domain + function right_of_domain(pg,i,j,k) result(isIn) + use pgrid_class, only: pgrid + implicit none + class(pgrid), intent(in) :: pg + integer, intent(in) :: i,j,k + logical :: isIn + isIn=.false. + if (i.eq.pg%imax+1) isIn=.true. + end function right_of_domain + + + !> Initialization of problem solver + subroutine simulation_init + use param, only: param_read,param_exists + use parallel, only: amRoot + implicit none + + + ! Allocate work arrays + allocate_work_arrays: block + allocate(div_x(cfg%imino_:cfg%imaxo_,cfg%jmino_:cfg%jmaxo_,cfg%kmino_:cfg%kmaxo_)) + allocate(div_y(cfg%imino_:cfg%imaxo_,cfg%jmino_:cfg%jmaxo_,cfg%kmino_:cfg%kmaxo_)) + allocate(div_z(cfg%imino_:cfg%imaxo_,cfg%jmino_:cfg%jmaxo_,cfg%kmino_:cfg%kmaxo_)) + allocate(resU(cfg%imino_:cfg%imaxo_,cfg%jmino_:cfg%jmaxo_,cfg%kmino_:cfg%kmaxo_)) + allocate(resV(cfg%imino_:cfg%imaxo_,cfg%jmino_:cfg%jmaxo_,cfg%kmino_:cfg%kmaxo_)) + allocate(resW(cfg%imino_:cfg%imaxo_,cfg%jmino_:cfg%jmaxo_,cfg%kmino_:cfg%kmaxo_)) + allocate(Ui (cfg%imino_:cfg%imaxo_,cfg%jmino_:cfg%jmaxo_,cfg%kmino_:cfg%kmaxo_)) + allocate(Vi (cfg%imino_:cfg%imaxo_,cfg%jmino_:cfg%jmaxo_,cfg%kmino_:cfg%kmaxo_)) + allocate(Wi (cfg%imino_:cfg%imaxo_,cfg%jmino_:cfg%jmaxo_,cfg%kmino_:cfg%kmaxo_)) + allocate(Uib (cfg%imino_:cfg%imaxo_,cfg%jmino_:cfg%jmaxo_,cfg%kmino_:cfg%kmaxo_)) + allocate(Vib (cfg%imino_:cfg%imaxo_,cfg%jmino_:cfg%jmaxo_,cfg%kmino_:cfg%kmaxo_)) + allocate(Wib (cfg%imino_:cfg%imaxo_,cfg%jmino_:cfg%jmaxo_,cfg%kmino_:cfg%kmaxo_)) + allocate(srcM(cfg%imino_:cfg%imaxo_,cfg%jmino_:cfg%jmaxo_,cfg%kmino_:cfg%kmaxo_)) + allocate(gradU(1:3,1:3,cfg%imino_:cfg%imaxo_,cfg%jmino_:cfg%jmaxo_,cfg%kmino_:cfg%kmaxo_)) + end block allocate_work_arrays + + + ! Initialize time tracker with 2 subiterations + initialize_timetracker: block + time=timetracker(amRoot=cfg%amRoot) + call param_read('Max timestep size',time%dtmax) + call param_read('Max cfl number',time%cflmax) + call param_read('Max time',time%tmax) + time%dt=time%dtmax + time%itmax=2 + end block initialize_timetracker + + ! Initialize Lagrangian solid solver + initialize_lss: block + use mathtools, only: Pi + + integer(I8), allocatable :: gids(:),rgid(:) + real(WP), allocatable :: pos(:,:),vel(:,:),voll(:),rpos(:,:),rvel(:,:),rvol(:) + integer, allocatable :: flags(:),owner(:),rflag(:) + integer :: i,j,k,n,nn,nr,nx,ny,nz,N_w + real(WP) :: dx,x0,y0,z0,x1,y1,z1,x2,y2,z2,cx,sx,cy,sy,cz,sz + real(WP) :: R,L,H,W,dist + real(WP) :: rho,E,nu,elem,delta,contract,ratio + + ls=lss(cfg=cfg,name='solid') + + call param_read('R',R,default=0.015_WP) + call param_read('L',L,default=0.1_WP) + call param_read('H',H,default=0.1_WP) + call param_read('W',W,default=0.02_WP) + call param_read('N_w',N_w,default=5) + elem = W/real(N_w,WP) + call param_read('Horizon', delta,default=3.0125_WP*elem) + + call param_read('Material density',rho,default=7850.0_WP) + call param_read('Elastic modulus', E,default=2.0e11_WP) + call param_read('Poisson ratio', nu,default=0.3_WP) + call param_read('Tau', ls%tau, default=huge(1.0_WP)) + + call param_read('Particle timestep size',ls_dt_max,default=huge(1.0_WP)) + + call param_read('Horizon Ratio',ratio) + + call param_read('Unfreeze time', ls%unfreeze_time) + ls%damping_rate=0.0_WP + ls_dt=min(ls_dt_max,time%dtmax) + ! Configure by field assignment (grid-free: no domain, no periodicity) + + ls%rho=rho; ls%elastic_modulus=E; ls%poisson_ratio=nu + ls%delta=delta; ls%dV=elem**3 + ! Root builds the whole lattice; pd_partition routes it (gids are + ! simply 1..n -- any unique positive keys work) + + + + nz = N_w + elem = W/real(N_w,WP) + ny = int(L/W*N_w) + nx = int(H/W*N_w) + 12 ! 6 on each side, where we pull from + nn=0 + if(amRoot) then + + do k=1,nz; do j=1,ny; do i=1,nx + + x0 = (real(i,WP) - 0.5_WP*real(nx+1,WP))*elem + y0 = (real(j,WP) - 0.5_WP*real(ny+1,WP))*elem + z0 = (real(k,WP) - 0.5_WP*real(nz+1,WP))*elem + if (((x0)*(x0) + y0*y0).le.R*R) cycle; + nn=nn+1 + end do; end do; end do + end if + + + allocate(gids(max(nn,1)),pos(3,max(nn,1)),vel(3,max(nn,1)),flags(max(nn,1)),voll(max(nn,1)),owner(max(nn,1))) + allocate(ls%icell(3,max(nn,1))) + n=0 + do k=1,nz; do j=1,ny; do i=1,nx + if (.not.amRoot) exit + x0 = (real(i,WP) - 0.5_WP*real(nx+1,WP))*elem + y0 = (real(j,WP) - 0.5_WP*real(ny+1,WP))*elem + z0 = (real(k,WP) - 0.5_WP*real(nz+1,WP))*elem + if (((x0)*(x0) + y0*y0).le.R*R) cycle; + n=n+1 + pos(:,n)=[x0, y0, z0] + vel(:,n)=[0.0_WP, 0.0_WP, 0.0_WP] + flags(n)=PDC_MOVES+PDC_INTEGRATES+PDC_BONDS !< IVM, bitwise, this should keep it still? + gids(n)=int(n,I8) + voll(n)=elem**3 + if (i.lt.7) then; flags(n)=PDC_MOVES+PDC_BONDS; vel(:,n)=[-1.0e-3_WP, 0.0_WP, 0.0_WP]; end if + if (i.gt.nx-6) then; flags(n)=PDC_MOVES+PDC_BONDS; vel(:,n)=[1.0e-3_WP, 0.0_WP, 0.0_WP]; end if + + ! ls%icell(:,n)=ls%cfg%get_ijk_global(pos(:,n),[ls%cfg%imin,ls%cfg%jmin,ls%cfg%kmin]) + end do; end do; end do + call pd_partition(nn,gids,pos,vel,flags,voll,owner,nr,rgid,rpos,rvel,rflag,rvol) + call ls%set_nodes(nr,rgid,rpos,rvel,rflag,rvol) + + call ls%detect_families() + ! call ls%update_VF() + + + end block initialize_lss + + + + ! Create partmesh object for visualizing Lagrangian particles + create_pmesh: block + use lss_class, only: max_bond + integer :: i,n,nbond + pmesh=partmesh(nvar=2,nvec=3,name='solid') + pmesh%varname(1)='damage' + pmesh%varname(2)='flag' + ! pmesh%varname(3)='nbond' ! IVM, seems like we don't currently track this? + ! mesh%varname(4)='von-Mises' + + + pmesh%vecname(1)='velocity' + ! pmesh%vecname(2)='bond_force' + pmesh%vecname(2)='fluid_force' + pmesh%vecname(3) = 'displacement' + call ls%update_partmesh(pmesh) + + do i=1,ls%nown ! IVM, probably not the right thing + + pmesh%vec(:,1,i)=ls%v(:,i) + pmesh%vec(:,2,i)=ls%ff(:,i) + pmesh%vec(:,3,i)=ls%y(:,i)-ls%x0(:,i) + pmesh%var(2,i)=ls%flag(i) + + + + end do + end block create_pmesh + + + + ! Create a flow solver with inflow-outflow + create_flow_solver: block + use incomp_class, only: dirichlet,clipped_neumann + real(WP) :: visc + ! Create flow solver + fs=incomp(cfg=cfg,name='Incompressible NS') + ! Set the flow properties + call param_read('Density',fs%rho) + call param_read('Dynamic viscosity',visc); fs%visc=visc + ! Define boundary conditions + call fs%add_bcond(name='inflow', type=dirichlet ,locator=left_of_domain ,face='x',dir=-1,canCorrect=.false.) + call fs%add_bcond(name='outflow',type=clipped_neumann,locator=right_of_domain,face='x',dir=+1,canCorrect=.true. ) + ! Configure pressure solver + ps=fft2d(cfg=cfg,name='Pressure',nst=7) + ! Configure implicit velocity solver + vs=ddadi(cfg=cfg,name='Velocity',nst=7) + ! Setup the solver + call fs%setup(pressure_solver=ps,implicit_solver=vs) + end block create_flow_solver + + + ! ! Initialize our velocity field + ! initialize_velocity: block + ! use random, only: random_normal + ! use incomp_class, only: bcond + ! type(bcond), pointer :: mybc + ! integer :: n,i,j,k + ! real(WP) :: Uin + ! ! Read inflow velocity + ! call param_read('Inlet velocity',Uin) + ! ! IB arrays + ! Uib=0.0_WP; Vib=0.0_WP; Wib=0.0_WP; srcM=0.0_WP + ! ! Make initial velocity field random to trigger transition + ! do k=fs%cfg%kmin_,fs%cfg%kmax_ + ! do j=fs%cfg%jmin_,fs%cfg%jmax_ + ! do i=fs%cfg%imin_,fs%cfg%imax_ + ! fs%U(i,j,k)=0.0_WP + ! fs%V(i,j,k)=0.0_WP + ! fs%W(i,j,k)=0.0_WP + ! end do + ! end do + ! end do + ! call fs%cfg%sync(fs%U) + ! call fs%cfg%sync(fs%V) + ! call fs%cfg%sync(fs%W) + ! ! Set inflow velocity + ! call fs%get_bcond('inflow',mybc) + ! do n=1,mybc%itr%no_ + ! i=mybc%itr%map(1,n); j=mybc%itr%map(2,n); k=mybc%itr%map(3,n) + ! fs%U(i,j,k)=Uin + ! end do + ! ! Compute MFR through all boundary conditions + ! call fs%get_mfr() + ! ! Adjust MFR for global mass balance + ! call fs%correct_mfr(src=srcM) + ! ! Compute cell-centered velocity + ! call fs%interp_vel(Ui,Vi,Wi) + ! ! Compute divergence + ! resU=srcM/fs%rho !< Careful, we need to provide + ! call fs%get_div(src=resU) !< a volume source term to div + + ! end block initialize_velocity + + + ! Add Ensight output + create_ensight: block + ! Create Ensight output from cfg + ens_out=ensight(cfg=cfg,name='cylinder') + ! Create event for Ensight output + ens_evt=event(time=time,name='Ensight output') + call param_read('Ensight output period',ens_evt%tper) + ! Add variables to output + call ens_out%add_particle('particles',pmesh) + call ens_out%add_scalar('divergence',fs%div) + call ens_out%add_vector('velocity',Ui,Vi,Wi) + call ens_out%add_vector('velocity_s',Uib,Vib,Wib) + call ens_out%add_scalar('pressure',fs%P) + call ens_out%add_scalar('VFs',ls%VF) + call ens_out%add_scalar('SRCM',srcM) + ! Output to ensight + if (ens_evt%occurs()) call ens_out%write_data(time%t) + end block create_ensight + + + + ! Create monitor files + create_monitor: block + real(WP) :: cfl + ! ! Prepare some info about fields + ! call fs%get_cfl(time%dt,time%cfl) + ! call fs%get_max() + ! ! Create simulation monitor + ! mfile=monitor(fs%cfg%amRoot,'simulation') + ! call mfile%add_column(time%n,'Timestep number') + ! call mfile%add_column(time%t,'Time') + ! call mfile%add_column(time%dt,'Timestep size') + ! call mfile%add_column(time%cfl,'Maximum CFL') + ! call mfile%add_column(fs%Umax,'Umax') + ! call mfile%add_column(fs%Vmax,'Vmax') + ! call mfile%add_column(fs%Wmax,'Wmax') + ! call mfile%add_column(fs%Pmax,'Pmax') + ! call mfile%add_column(fs%divmax,'Maximum divergence') + ! call mfile%add_column(fs%psolv%it,'Pressure iteration') + ! call mfile%add_column(fs%psolv%rerr,'Pressure error') + ! call mfile%write() + ! ! Create CFL monitor + ! cflfile=monitor(fs%cfg%amRoot,'cfl') + ! call cflfile%add_column(time%n,'Timestep number') + ! call cflfile%add_column(time%t,'Time') + ! call cflfile%add_column(fs%CFLc_x,'Convective xCFL') + ! call cflfile%add_column(fs%CFLc_y,'Convective yCFL') + ! call cflfile%add_column(fs%CFLc_z,'Convective zCFL') + ! call cflfile%add_column(fs%CFLv_x,'Viscous xCFL') + ! call cflfile%add_column(fs%CFLv_y,'Viscous yCFL') + ! call cflfile%add_column(fs%CFLv_z,'Viscous zCFL') + ! call cflfile%write() + + ! Create solid monitor + sfile=monitor(fs%cfg%amRoot,'solid') + call sfile%add_column(time%n,'Timestep number') + call sfile%add_column(time%t,'Time') + call sfile%add_column(ls_dt,'Particle dt') + call sfile%add_column(time%cfl,'Maximum CFL') + ! call sfile%add_column(ls%np,'Particle number') + call sfile%add_column(ls%VFmax,'VFmax') + call sfile%add_column(ls%Umin,'Particle Umin') + call sfile%add_column(ls%Umax,'Particle Umax') + call sfile%add_column(ls%Vmin,'Particle Vmin') + call sfile%add_column(ls%Vmax,'Particle Vmax') + call sfile%add_column(ls%Wmin,'Particle Wmin') + call sfile%add_column(ls%Wmax,'Particle Wmax') + + call sfile%add_column(ls%ibmForce(1),'Particle Fx') + call sfile%add_column(ls%ibmForce(2),'Particle Fy') + call sfile%add_column(ls%ibmForce(3),'Particle Fz') + call sfile%write() + + call ls%get_info() + mfile=monitor(amRoot=amRoot,name='simulation') + call mfile%add_column(time%n,'Timestep') + call mfile%add_column(time%t,'Time') + call mfile%add_column(ls%np,'Nodes') + call mfile%add_column(ls%nb,'Bonds') + call mfile%add_column(ls%wtmax_kick, 'kick_max') + call mfile%add_column(ls%wtmax_halo, 'halo_max') + call mfile%add_column(ls%wtmax_dil, 'dil_max') + call mfile%add_column(ls%wtmin_dil, 'dil_min') + call mfile%add_column(ls%wtmax_force, 'force_max') + call mfile%add_column(ls%wtmin_force, 'force_min') + call mfile%add_column(ls%wtmax_reduce, 'reduce_max') + call mfile%add_column(ls%wtmax_contact,'contact_max') + call mfile%add_column(ls%wtmax_broad, 'broad_max') + call mfile%add_column(ls%maxtot_time, 'total_max') + call mfile%write() + end block create_monitor + + print *, '================== simulation_init COMPLETE ==================' + + end subroutine simulation_init + + + !> Perform an NGA2 simulation - this mimicks NGA's old time integration for multiphase + subroutine simulation_run + implicit none + real(WP) :: cfl + logical :: freeze_particles + + freeze_particles = .false. + + ! Perform time integration + do while (.not.time%done()) + ! Increment time + call ls%get_cfl(time%dt,time%cfl) + ! call fs%get_cfl(time%dt,cfl); + time%cfl=max(time%cfl,cfl) + call time%adjust_dt() + call time%increment() + + ! Advance solid solver + solid: block + real(WP) :: dt_done,mydt + ! Compute divergence of fluid stress + ! call fs%get_div_stress(divx=div_x(:,:,:),divy=div_y(:,:,:),divz=div_z(:,:,:)) + ! Sub-iteratore + call ls%get_cfl(ls_dt,cfl=cfl) + if (cfl.gt.0.0_WP) ls_dt=min(ls_dt*time%cflmax/cfl,ls_dt_max) + dt_done=0.0_WP + do while (dt_done.lt.time%dtmid) + ! Decide the timestep size + + mydt=min(ls_dt,time%dtmid-dt_done) + ! Advance particles + if (time%t.gt.ls%unfreeze_time) freeze_particles=.true. + call ls%advance(dt =mydt, & + & unfreeze = freeze_particles, & + & div_stress_x=div_x(:,:,:),& + & div_stress_y=div_y(:,:,:),& + & div_stress_z=div_z(:,:,:)) + ! Increment + + dt_done=dt_done+mydt + end do + + end block solid + + ! ! Evaluate IB velocity and mass source + ! calc_ib_velocity: block + ! integer :: i,j,k + ! do k=fs%cfg%kmin_,fs%cfg%kmax_ + ! do j=fs%cfg%jmin_,fs%cfg%jmax_ + ! do i=fs%cfg%imin_,fs%cfg%imax_ + ! ! VF based velocity + ! Uib(i,j,k)=0.5_WP*(ls%VFU(i-1,j,k)+ls%VFU(i,j,k))/(sum(fs%itpr_x(:,i,j,k)*ls%VF(i-1:i,j,k))+epsilon(1.0_WP)) + ! Vib(i,j,k)=0.5_WP*(ls%VFV(i,j-1,k)+ls%VFV(i,j,k))/(sum(fs%itpr_y(:,i,j,k)*ls%VF(i,j-1:j,k))+epsilon(1.0_WP)) + ! Wib(i,j,k)=0.5_WP*(ls%VFW(i,j,k-1)+ls%VFW(i,j,k))/(sum(fs%itpr_z(:,i,j,k)*ls%VF(i,j,k-1:k))+epsilon(1.0_WP)) + ! end do + ! end do + ! end do + ! call cfg%sync(Uib) + ! call cfg%sync(Vib) + ! call cfg%sync(Wib) + ! ! Compute IB mass source + ! do k=fs%cfg%kmin_,fs%cfg%kmax_ + ! do j=fs%cfg%jmin_,fs%cfg%jmax_ + ! do i=fs%cfg%imin_,fs%cfg%imax_ + ! srcM(i,j,k)=fs%rho*(ls%VF(i,j,k)*(sum(fs%divp_x(:,i,j,k)*Uib(i:i+1,j,k))+& + ! & sum(fs%divp_y(:,i,j,k)*Vib(i,j:j+1,k))+& + ! & sum(fs%divp_z(:,i,j,k)*Wib(i,j,k:k+1)))) + + ! end do + ! end do + ! end do + ! call cfg%sync(srcM) + ! end block calc_ib_velocity + + + ! ! Remember old velocity + ! fs%Uold=fs%U + ! fs%Vold=fs%V + ! fs%Wold=fs%W + + ! ! Perform sub-iterations + ! do while (time%it.le.time%itmax) + + ! ! Build mid-time velocity + ! fs%U=0.5_WP*(fs%U+fs%Uold) + ! fs%V=0.5_WP*(fs%V+fs%Vold) + ! fs%W=0.5_WP*(fs%W+fs%Wold) + + ! ! Explicit calculation of drho*u/dt from NS + ! call fs%get_dmomdt(resU,resV,resW) + + ! ! Assemble explicit residual + ! resU=-2.0_WP*(fs%rho*fs%U-fs%rho*fs%Uold)+time%dtmid*resU + ! resV=-2.0_WP*(fs%rho*fs%V-fs%rho*fs%Vold)+time%dtmid*resV + ! resW=-2.0_WP*(fs%rho*fs%W-fs%rho*fs%Wold)+time%dtmid*resW + + ! ! Form implicit residuals + ! call fs%solve_implicit(time%dtmid,resU,resV,resW) + + ! ! Apply these residuals + ! fs%U=2.0_WP*fs%U-fs%Uold+resU + ! fs%V=2.0_WP*fs%V-fs%Vold+resV + ! fs%W=2.0_WP*fs%W-fs%Wold+resW + + ! ! Apply direct IB forcing + ! ibforcing: block + ! integer :: i,j,k + ! do k=fs%cfg%kmin_,fs%cfg%kmax_; do j=fs%cfg%jmin_,fs%cfg%jmax_; do i=fs%cfg%imin_,fs%cfg%imax_ + ! fs%U(i,j,k)=(1.0_WP-sum(fs%itpr_x(:,i,j,k)*ls%VF(i-1:i,j,k)))*fs%U(i,j,k)+0.5_WP*(ls%VFU(i-1,j,k)+ls%VFU(i,j,k)) + ! fs%V(i,j,k)=(1.0_WP-sum(fs%itpr_y(:,i,j,k)*ls%VF(i,j-1:j,k)))*fs%V(i,j,k)+0.5_WP*(ls%VFV(i,j-1,k)+ls%VFV(i,j,k)) + ! fs%W(i,j,k)=(1.0_WP-sum(fs%itpr_z(:,i,j,k)*ls%VF(i,j,k-1:k)))*fs%W(i,j,k)+0.5_WP*(ls%VFW(i,j,k-1)+ls%VFW(i,j,k)) + ! end do; end do; end do + ! call fs%cfg%sync(fs%U) + ! call fs%cfg%sync(fs%V) + ! call fs%cfg%sync(fs%W) + ! end block ibforcing + + ! ! Apply other boundary conditions + ! call fs%apply_bcond(time%t,time%dtmid) + + ! ! Solve Poisson equation + ! call fs%correct_mfr(src=srcM) + ! resU=srcM/fs%rho !< Careful, we need to provide + ! call fs%get_div(src=resU) !< a volume source term to div + ! fs%psolv%rhs=-fs%cfg%vol*fs%div*fs%rho/time%dtmid + ! fs%psolv%sol=0.0_WP + ! call fs%psolv%solve() + ! call fs%shift_p(fs%psolv%sol) + + ! ! Correct velocity + ! call fs%get_pgrad(fs%psolv%sol,resU,resV,resW) + ! fs%P=fs%P+fs%psolv%sol + ! fs%U=fs%U-time%dtmid*resU/fs%rho + ! fs%V=fs%V-time%dtmid*resV/fs%rho + ! fs%W=fs%W-time%dtmid*resW/fs%rho + + ! ! Increment sub-iteration counter + ! time%it=time%it+1 + + ! end do + + ! ! Recompute interpolated velocity and divergence + ! call fs%interp_vel(Ui,Vi,Wi) + ! resU=srcM/fs%rho !< Careful, we need to provide + ! call fs%get_div(src=resU) !< a volume source term to div + + ! Output to ensight + if (ens_evt%occurs()) then + update_pmesh: block + use lss_class, only: max_bond + integer :: i,n,nbond + call ls%update_partmesh(pmesh) + do i=1,ls%nown ! IVM, probably not the right thing + pmesh%vec(:,1,i)=ls%v(:,i) + pmesh%vec(:,2,i)=ls%ff(:,i) + pmesh%vec(:,3,i)=ls%y(:,i)-ls%x0(:,i) + pmesh%var(2,i)=ls%flag(i) + end do + end block update_pmesh + call ens_out%write_data(time%t) + end if + + ! ! Perform and output monitoring + ! call fs%get_max() + ! ! call ls%get_max() ! IVM, need a fix for this guy, I am sure something exists we can pull + ! call mfile%write() + ! call cflfile%write() + ! call sfile%write() + + call ls%get_info() + call mfile%write() + + end do + + end subroutine simulation_run + + + !> Finalize the NGA2 simulation + subroutine simulation_final + implicit none + + ! Get rid of all objects - need destructors + ! monitor + ! ensight + ! bcond + ! timetracker + + ! Deallocate work arrays + deallocate(div_x,div_y,div_z,resU,resV,resW,Ui,Vi,Wi,Uib,Vib,Wib,srcM,gradU) + + end subroutine simulation_final + + +end module simulation diff --git a/examples/beam_tension/GNUmakefile b/examples/beam_tension/GNUmakefile new file mode 100644 index 000000000..23c4d3dba --- /dev/null +++ b/examples/beam_tension/GNUmakefile @@ -0,0 +1,49 @@ +# NGA location if not yet defined +NGA_HOME ?= ~/nga2/Repositories/nga2 + +# Compilation parameters +PRECISION = DOUBLE +USE_MPI = TRUE +USE_HYPRE = TRUE +USE_LAPACK= TRUE +USE_FFTW = TRUE +USE_IRL = FALSE +PROFILE = FALSE +DEBUG = FALSE +COMP = gnu +EXEBASE = nga + +# Directories that contain user-defined code +Udirs := src + +# Include user-defined sources +Upack += $(foreach dir, $(Udirs), $(wildcard $(dir)/Make.package)) +Ulocs += $(foreach dir, $(Udirs), $(wildcard $(dir))) +include $(Upack) +INCLUDE_LOCATIONS += $(Ulocs) +VPATH_LOCATIONS += $(Ulocs) + +# External libraries are defined in .profile/.bashrc/.zshrc, but could be defined here as well +HYPRE_DIR=/Users/imauser/nga2/Repositories/hypre/src/hypre +FFTW_DIR=/opt/homebrew/Cellar/fftw/3.3.10_2 + +# NGA compilation definitions +include $(NGA_HOME)/tools/GNUMake/Make.defs + +# Include NGA base code +Bdirs := constant_density particles core data transform solver config grid libraries +Bpack += $(foreach dir, $(Bdirs), $(NGA_HOME)/src/$(dir)/Make.package) +include $(Bpack) + +# Inform user of Make.packages used +ifdef Ulocs + $(info Taking user code from: $(Ulocs)) +endif +$(info Taking base code from: $(Bdirs)) + +# Target definition +all: $(executable) + @echo COMPILATION SUCCESSFUL + +# NGA compilation rules +include $(NGA_HOME)/tools/GNUMake/Make.rules diff --git a/examples/beam_tension/input b/examples/beam_tension/input new file mode 100644 index 000000000..a5792b922 --- /dev/null +++ b/examples/beam_tension/input @@ -0,0 +1,30 @@ +# Parallelization +Partition : 2 2 2 + + +# Beam Shape +Lz : 0.01 +Ly : 0.01 +Lx : 0.1 +R : 0.000 +Particle file: element_data.bin + +# Solid properties +Subdivisions : 33 +Elastic Modulus : 200e9 +Poisson Ratio : 0.30 +Solid density : 7850 +Critical Energy Release Rate : 100000 +Horizon Ratio : 3.015 +Solid Spacing: 0.001 +Mean Particle Spacing : 0.00125 +Solid Load : 1e3 +Solid Damping Constant : 0.005 + +# Time integration +Max timestep size : 3.0e-7 +Max cfl number : 2 +Max time : 10 + +# Ensight output +Ensight output period : 1e-5 diff --git a/examples/beam_tension/src/Make.package b/examples/beam_tension/src/Make.package new file mode 100644 index 000000000..ddc060c7d --- /dev/null +++ b/examples/beam_tension/src/Make.package @@ -0,0 +1,2 @@ +# List here the extra files here +f90EXE_sources += simulation.f90 geometry.f90 lss_class.f90 spcomp_class.f90 diff --git a/examples/beam_tension/src/geometry copy.f90 b/examples/beam_tension/src/geometry copy.f90 new file mode 100644 index 000000000..d32d69565 --- /dev/null +++ b/examples/beam_tension/src/geometry copy.f90 @@ -0,0 +1,136 @@ +!> Various definitions and tools for initializing NGA2 config +module geometry + use config_class, only: config + use precision, only: WP + implicit none + private + + !> Single config + type(config), public :: cfg + + public :: geometry_init + +contains + + + !> Initialization of problem geometry + subroutine geometry_init + use sgrid_class, only: sgrid + use param, only: param_read + implicit none + type(sgrid) :: grid + + + ! Create a grid from input params + create_grid: block + use sgrid_class, only: cartesian + integer :: i,j,k,nx,ny,nz + real(WP) :: Lx,Ly,Lz,dist,dx,R + real(WP), dimension(:), allocatable :: x,y,z + + call param_read('Lx',Lx) + call param_read('Ly',Ly) + call param_read('Lz',Lz) + call param_read('R',R) + call param_read('Solid Spacing',dist) + ! Lx = 1.0_WP ! beam length + ! Ly = 1.0_WP ! beam length + + ! dist = 0.01_WP ! Space between particles + + Lx = Lx + 6.03_WP * dist ! total length of the beam + ! Ly = Ly + 3.0_WP * dist ! total length of the beam + + dx = 3.015_WP*dist ! grid spacing + + nx = ceiling(Lx/dx)+2 ! number of division in x + ny = ceiling(Ly/dx) + nz = ceiling(Lz/dx) + + allocate(x(nx+1)) + allocate(y(ny+1)) + allocate(z(nz+1)) + + ! Create simple rectilinear grid + do i=1,nx+1 + x(i)=real(i-2,WP)*dx - Lx/2.0_WP - 1.5_WP*dist + end do + do j=1,ny+1 + y(j)=real(j-1,WP)*dx - Ly/2.0_WP - 1.5_WP*dist + end do + do k=1,nz+1 + z(k)=real(k-1,WP)*dx - Lz/2.0_WP - 1.5_WP*dist + end do + ! General serial grid object (no=3 needed to support ghost/image point interpolation/extrapolation) + grid=sgrid(coord=cartesian,no=3,x=x,y=y,z=z,xper=.false.,yper=.false.,zper=.false.,name='box') + + end block create_grid + + ! create_grid: block + ! use sgrid_class, only: cartesian + ! integer :: i,j,k,nx,ny,nz + ! real(WP) :: Lx,Ly,Lz,dist + ! real(WP), dimension(:), allocatable :: x,y,z + + ! ! Read in grid definition + ! call param_read('Lx',Lx); Lx=Lx + ! call param_read('Ly',Ly); Ly=Ly + ! call param_read('Lz',Lz); Lz=Lz + ! call param_read('Subdivisions',ny) + ! dist = 3.0_WP * Ly / real(ny,WP) + ! Lx = Lx + 3.0_WP * dist + ! nx = ceiling(Lx / dist) + 4 + ! ny = ceiling(Ly / dist) + 2 + ! nz = ceiling(Lz / dist) + 2 + + ! Lx = real(nx,WP) * dist + ! Ly = real(ny,WP) * dist + ! Lz = real(nz,WP) * dist + + + ! allocate(x(nx)) + ! allocate(y(ny+1)) + ! allocate(z(nz+1)) + + + ! ! Create simple rectilinear grid + ! do i=1,nx + ! x(i)=real(i-2,WP)*dist + ! end do + ! do j=1,ny+1 + ! y(j)=real(j-1,WP)*dist-0.5_WP*Ly + ! end do + ! do k=1,nz+1 + ! z(k)=real(k-1,WP)*dist-0.5_WP*Lz + ! end do + + + + + ! ! General serial grid object (no=3 needed to support ghost/image point interpolation/extrapolation) + ! grid=sgrid(coord=cartesian,no=2,x=x,y=y,z=z,xper=.false.,yper=.false.,zper=.false.,name='box') + + ! end block create_grid + + + ! Create a config from that grid on our entire group + create_cfg: block + use parallel, only: group + integer, dimension(3) :: partition + ! Read in partition + call param_read('Partition',partition,short='p') + ! Create partitioned grid + cfg=config(grp=group,decomp=partition,grid=grid) + end block create_cfg + + + ! Create walls for this config + create_walls: block + cfg%VF=1.0_WP + end block create_walls + + + end subroutine geometry_init + + +end module geometry diff --git a/examples/beam_tension/src/geometry.f90 b/examples/beam_tension/src/geometry.f90 new file mode 100644 index 000000000..5fb5feb9c --- /dev/null +++ b/examples/beam_tension/src/geometry.f90 @@ -0,0 +1,137 @@ +!> Various definitions and tools for initializing NGA2 config +module geometry + use config_class, only: config + use precision, only: WP + implicit none + private + + !> Single config + type(config), public :: cfg + + public :: geometry_init + +contains + + + !> Initialization of problem geometry + subroutine geometry_init + use sgrid_class, only: sgrid + use param, only: param_read + implicit none + type(sgrid) :: grid + + + ! Create a grid from input params + create_grid: block + use sgrid_class, only: cartesian + integer :: i,j,k,nx,ny,nz + real(WP) :: Lx,Ly,Lz,dist,dx,R + real(WP), dimension(:), allocatable :: x,y,z + + call param_read('Lx',Lx) + call param_read('Ly',Ly) + call param_read('Lz',Lz) + call param_read('R',R) + call param_read('Solid Spacing',dist) + ! Lx = 1.0_WP ! beam length + ! Ly = 1.0_WP ! beam length + + ! dist = 0.01_WP ! Space between particles + + Lx = Lx + 6.03_WP * dist ! total length of the beam + ! Ly = Ly + 3.0_WP * dist ! total length of the beam + + dx = 3.015_WP*dist ! grid spacing + ! print*, "Grid Spacing : ", dx + + nx = ceiling(Lx/dx)+2 ! number of division in x + ny = ceiling(Ly/dx)+2 + nz = ceiling(Lz/dx)+2 + + allocate(x(nx+1)) + allocate(y(ny+1)) + allocate(z(nz+1)) + + ! Create simple rectilinear grid + do i=1,nx+1 + x(i)=real(i-2,WP)*dx - Lx/2.0_WP - 1.5_WP*dist + end do + do j=1,ny+1 + y(j)=real(j-2,WP)*dx - Ly/2.0_WP - 1.5_WP*dist + end do + do k=1,nz+1 + z(k)=real(k-2,WP)*dx - Lz/2.0_WP - 1.5_WP*dist + end do + ! General serial grid object (no=3 needed to support ghost/image point interpolation/extrapolation) + grid=sgrid(coord=cartesian,no=3,x=x,y=y,z=z,xper=.false.,yper=.false.,zper=.false.,name='box') + + end block create_grid + + ! create_grid: block + ! use sgrid_class, only: cartesian + ! integer :: i,j,k,nx,ny,nz + ! real(WP) :: Lx,Ly,Lz,dist + ! real(WP), dimension(:), allocatable :: x,y,z + + ! ! Read in grid definition + ! call param_read('Lx',Lx); Lx=Lx + ! call param_read('Ly',Ly); Ly=Ly + ! call param_read('Lz',Lz); Lz=Lz + ! call param_read('Subdivisions',ny) + ! dist = 3.0_WP * Ly / real(ny,WP) + ! Lx = Lx + 3.0_WP * dist + ! nx = ceiling(Lx / dist) + 4 + ! ny = ceiling(Ly / dist) + 2 + ! nz = ceiling(Lz / dist) + 2 + + ! Lx = real(nx,WP) * dist + ! Ly = real(ny,WP) * dist + ! Lz = real(nz,WP) * dist + + + ! allocate(x(nx)) + ! allocate(y(ny+1)) + ! allocate(z(nz+1)) + + + ! ! Create simple rectilinear grid + ! do i=1,nx + ! x(i)=real(i-2,WP)*dist + ! end do + ! do j=1,ny+1 + ! y(j)=real(j-1,WP)*dist-0.5_WP*Ly + ! end do + ! do k=1,nz+1 + ! z(k)=real(k-1,WP)*dist-0.5_WP*Lz + ! end do + + + + + ! ! General serial grid object (no=3 needed to support ghost/image point interpolation/extrapolation) + ! grid=sgrid(coord=cartesian,no=2,x=x,y=y,z=z,xper=.false.,yper=.false.,zper=.false.,name='box') + + ! end block create_grid + + + ! Create a config from that grid on our entire group + create_cfg: block + use parallel, only: group + integer, dimension(3) :: partition + ! Read in partition + call param_read('Partition',partition,short='p') + ! Create partitioned grid + cfg=config(grp=group,decomp=partition,grid=grid) + end block create_cfg + + + ! Create walls for this config + create_walls: block + cfg%VF=1.0_WP + end block create_walls + + + end subroutine geometry_init + + +end module geometry diff --git a/examples/beam_tension/src/lss_class.f90 b/examples/beam_tension/src/lss_class.f90 new file mode 100644 index 000000000..07a288b32 --- /dev/null +++ b/examples/beam_tension/src/lss_class.f90 @@ -0,0 +1,1606 @@ +!> Lagrangian solid solver object +!> Implements peridynamics equations +module lss_class + use precision, only: WP + use string, only: str_medium + use config_class, only: config + use mpi_f08, only: MPI_Datatype,MPI_INTEGER8,MPI_INTEGER,MPI_DOUBLE_PRECISION + implicit none + private + + + ! Expose type/constructor/methods + public :: lss + + + !> Memory adaptation parameter + real(WP), parameter :: coeff_up=1.3_WP !< Particle array size increase factor + real(WP), parameter :: coeff_dn=0.7_WP !< Particle array size decrease factor + + + !> I/O chunk size to read at a time + integer, parameter :: part_chunk_size=1000 !< Read 1000 particles at a time before redistributing + + + !> Maximum number of bonds per particle + integer, parameter, public :: max_bond=400 !< Assumes something like a 7x7x7 stencil in 3D + + + !> Bonded solid particle definition + type :: part + !> MPI_DOUBLE_PRECISION data + real(WP) :: mw !< Weighted volume + real(WP) :: dil !< Element dilatation + real(WP) :: vonMises !< Element dilatation + real(WP) :: vol !< Particle volume + real(WP), dimension(max_bond) :: dbond !< Length of initial bonds + real(WP), dimension(3) :: pos !< Particle center coordinates + real(WP), dimension(3) :: vel !< Velocity of particle + real(WP), dimension(3) :: Abond !< Bond acceleration for particle + real(WP), dimension(3) :: Afluid !< Fluid acceleration for particle + real(WP), dimension(3) :: ipos !< Initial position + real(WP), dimension(3) :: displacement !< Displacement + real(WP), dimension(3) :: gd !< + real(WP), dimension(3) :: gb !< + real(WP), dimension(6) :: sigma !< Cauchy stress tensor + !> MPI_INTEGER data + integer :: id !< ID the object is associated with + integer :: i !< Unique index of particle (assumed >0) + integer :: nbond !< Number of initial bonds + integer, dimension(max_bond) :: ibond !< Indices of initially bonded particles (0 values ignored) + integer , dimension(3) :: ind !< Index of cell containing particle center + integer :: flag !< Control parameter (0=normal, 1=done->will be removed) + end type part + !> Number of blocks, block length, and block types in a particle + integer, parameter :: part_nblock=2 + integer , dimension(part_nblock) :: part_lblock=[34+max_bond,7+max_bond] + type(MPI_Datatype), dimension(part_nblock) :: part_tblock=[MPI_DOUBLE_PRECISION,MPI_INTEGER] + !> MPI_PART derived datatype and size + type(MPI_Datatype) :: MPI_PART + integer :: MPI_PART_SIZE + + + !> Lagrangian solid solver object definition + type :: lss + + ! This config is used for parallelization and for calculating bond/collision forces + class(config), pointer :: cfg + + ! This is the name of the solver + character(len=str_medium) :: name='UNNAMED_LSS' + + ! Solid material properties + real(WP) :: elastic_modulus !< Elastic modulus of the material + real(WP) :: poisson_ratio !< Poisson's ratio of the material + real(WP) :: rho !< Density of the material + real(WP) :: crit_energy !< Critical energy release + real(WP) :: beta !< Damping constant + + ! Bonding parameters + real(WP) :: delta !< Bonding horizon (distance) + real(WP) :: min_dist !< Minimum bonding distance + integer :: nb !< Cell-based horizon + + ! Global and local particle data + integer :: np !< Global number of particles + integer :: np_ !< Local number of particles + integer, dimension(:), allocatable :: np_proc !< Number of particles on each processor + type(part), dimension(:), allocatable :: p !< Array of particles of type part + + ! Overlap particle (i.e., ghost) data + integer :: ng_ !< Local number of ghosts + type(part), dimension(:), allocatable :: g !< Array of ghosts of type part + + ! Gravitational acceleration + real(WP), dimension(3) :: gravity=[0.0_WP,0.0_WP,0.0_WP] + + ! Solid volume fraction and momentum + real(WP), dimension(:,:,:), allocatable :: VF !< Volume fraction, cell-centered + real(WP), dimension(:,:,:), allocatable :: VFU !< Solid velocity, U-face + real(WP), dimension(:,:,:), allocatable :: VFV !< Solid velocity, V-face + real(WP), dimension(:,:,:), allocatable :: VFW !< Solid velocity, W-face + + ! CFL numbers + real(WP) :: CFLp_x,CFLp_y,CFLp_z,CFLp_a + + ! Number of substeps for time integrator + real(WP) :: nstep=1 + + ! Monitoring info + real(WP) :: Umin,Umax,Umean !< U velocity info + real(WP) :: Vmin,Vmax,Vmean !< V velocity info + real(WP) :: Wmin,Wmax,Wmean !< W velocity info + real(WP) :: VFmax !< Volume fraction info + real(WP), dimension(3) :: ibmForce !< Total force due to IBM + integer :: np_out !< Number of particles leaving the domain + + contains + procedure :: bond_init !< Setup initial interparticle bonds + procedure :: get_bond_force !< Compute interparticle bond force + procedure :: advance !< Step forward the particle ODEs + procedure :: get_cfl !< Calculate maximum CFL + procedure :: get_max !< Extract various monitoring data + procedure :: update_partmesh !< Update a partmesh object using current particles + procedure :: share !< Share particles across interprocessor boundaries + procedure :: sync !< Synchronize particles across interprocessor boundaries + procedure :: resize !< Resize particle array to given size + procedure :: resize_ghost !< Resize ghost array to given size + procedure :: recycle !< Recycle particle array by removing flagged particles + procedure :: write !< Parallel write particles to file + procedure :: read !< Parallel read particles from file + procedure :: update_VF !< Compute volume fraction + procedure :: get_delta !< Compute regularized delta function + procedure :: interpolate !< Interpolation routine from mesh=>marker + procedure :: extrapolate !< Extrapolation routine from marker=>mesh + procedure :: stretch + end type lss + + + !> Declare lss constructor + interface lss + procedure constructor + end interface lss + +contains + + + ! Quasi-Gaussian weighting function - h is the cut-off + real(WP) function wgauss(d,h) + implicit none + real(WP), intent(in) :: d,h + real(WP), parameter :: coeff=2.6_WP + real(WP) :: hh + hh=coeff*h + if (d.ge.hh) then + wgauss=0.0_WP + else + wgauss=(1.0_WP+4.0_WP*d/hh)*(1.0_WP-d/hh)**4 + end if + end function wgauss + + + !> Default constructor for Lagrangian solid solver + function constructor(cfg,name) result(self) + implicit none + type(lss) :: self + class(config), target, intent(in) :: cfg + character(len=*), optional :: name + integer :: i,j,k + + ! Set the name for the solver + if (present(name)) self%name=trim(adjustl(name)) + + ! Point to pgrid object + self%cfg=>cfg + + ! Set default bonding horizon based on underlying mesh + self%delta=self%cfg%min_meshsize + self%nb=2 + self%min_dist=huge(1.0_WP) + + ! Allocate variables + allocate(self%np_proc(1:self%cfg%nproc)); self%np_proc=0 + self%np_=0; self%np=0 + call self%resize(0) + + ! Initialize MPI derived datatype for a particle + call prepare_mpi_part() + + ! Allocate VF array on cfg mesh + allocate(self%VF(self%cfg%imino_:self%cfg%imaxo_,self%cfg%jmino_:self%cfg%jmaxo_,self%cfg%kmino_:self%cfg%kmaxo_)); self%VF=0.0_WP + allocate(self%VFU(self%cfg%imino_:self%cfg%imaxo_,self%cfg%jmino_:self%cfg%jmaxo_,self%cfg%kmino_:self%cfg%kmaxo_)); self%VFU=0.0_WP + allocate(self%VFV(self%cfg%imino_:self%cfg%imaxo_,self%cfg%jmino_:self%cfg%jmaxo_,self%cfg%kmino_:self%cfg%kmaxo_)); self%VFV=0.0_WP + allocate(self%VFW(self%cfg%imino_:self%cfg%imaxo_,self%cfg%jmino_:self%cfg%jmaxo_,self%cfg%kmino_:self%cfg%kmaxo_)); self%VFW=0.0_WP + + ! Log/screen output + logging: block + use, intrinsic :: iso_fortran_env, only: output_unit + use param, only: verbose + use messager, only: log + use string, only: str_long + character(len=str_long) :: message + if (self%cfg%amRoot) then + write(message,'("LSS object [",a,"] on partitioned grid [",a,"]")') trim(self%name),trim(self%cfg%name) + if (verbose.gt.1) write(output_unit,'(a)') trim(message) + if (verbose.gt.0) call log(message) + end if + end block logging + + end function constructor + + + !> Initialize bond force between particles + subroutine bond_init(this) + use messager, only: die + implicit none + class(lss), intent(inout) :: this + integer, dimension(:,:,:), allocatable :: npic !< Number of particle in cell + integer, dimension(:,:,:,:), allocatable :: ipic !< Index of particle in cell + + ! Communicate particles in ghost cells + call this%share() + + ! We can now assemble particle-in-cell information + pic_prep: block + use mpi_f08 + integer :: i,ip,jp,kp,ierr + integer :: mymax_npic,max_npic + + ! Allocate number of particle in cell + allocate(npic(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)); npic=0 + + ! Count particles and ghosts per cell + do i=1,this%np_ + ip=this%p(i)%ind(1); jp=this%p(i)%ind(2); kp=this%p(i)%ind(3) + npic(ip,jp,kp)=npic(ip,jp,kp)+1 + end do + do i=1,this%ng_ + ip=this%g(i)%ind(1); jp=this%g(i)%ind(2); kp=this%g(i)%ind(3) + npic(ip,jp,kp)=npic(ip,jp,kp)+1 + end do + + ! Get maximum number of particle in cell + mymax_npic=maxval(npic); call MPI_ALLREDUCE(mymax_npic,max_npic,1,MPI_INTEGER,MPI_MAX,this%cfg%comm,ierr) + + ! Allocate pic map + allocate(ipic(1:max_npic,this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)); ipic=0 + + ! Assemble pic map + npic=0 + do i=1,this%np_ + ip=this%p(i)%ind(1); jp=this%p(i)%ind(2); kp=this%p(i)%ind(3) + npic(ip,jp,kp)=npic(ip,jp,kp)+1 + ipic(npic(ip,jp,kp),ip,jp,kp)=+i + end do + do i=1,this%ng_ + ip=this%g(i)%ind(1); jp=this%g(i)%ind(2); kp=this%g(i)%ind(3) + npic(ip,jp,kp)=npic(ip,jp,kp)+1 + ipic(npic(ip,jp,kp),ip,jp,kp)=-i + end do + + end block pic_prep + + ! Establish initial bonds + create_bonds: block + use mpi_f08, only: MPI_ALLREDUCE,MPI_MIN,MPI_IN_PLACE + use parallel, only: MPI_REAL_WP + use mathtools, only: Pi + integer :: i,j,k,n1,nn,n2,ierr + type(part) :: p1,p2 + real(WP), dimension(3) :: rpos + real(WP) :: dist + ! Reset minimum bond distance + this%min_dist=huge(1.0_WP) + ! Loop over particles + do n1=1,this%np_ + ! Create copy of our particle + p1=this%p(n1) + ! Zero out weighted volume + p1%mw=0.0_WP + ! Zero out bonds + p1%ibond=0 + p1%nbond=0 + ! Loop over neighbor cells + do k=p1%ind(3)-this%nb,p1%ind(3)+this%nb + do j=p1%ind(2)-this%nb,p1%ind(2)+this%nb + do i=p1%ind(1)-this%nb,p1%ind(1)+this%nb + ! Loop over particles in that cell + do nn=1,npic(i,j,k) + ! Create copy of our neighbor + n2=ipic(nn,i,j,k) + if (n2.gt.0) then + p2=this%p(+n2) + else if (n2.lt.0) then + p2=this%g(-n2) + end if + ! Cannot self-bond + if (p1%i.eq.p2%i) cycle + ! Cannot bond with different id except <=0 (<=0 bonds with everyone) + if (p1%id.ne.p2%id.and.p1%id.ge.0.and.p2%id.ge.0) cycle + ! Check interparticle distance + rpos=p2%pos-p1%pos + dist=sqrt(dot_product(rpos,rpos)) + if (dist.lt.this%delta) then + ! This particle is in horizon, create a bond + p1%nbond=p1%nbond+1 + if (p1%nbond.gt.max_bond) call die('[lss_class bond_init] Number of detected bonds is larger than max allowed') + p1%ibond(p1%nbond)=p2%i + p1%dbond(p1%nbond)=dist + ! Increment weighted volume + p1%mw=p1%mw+wgauss(dist,this%delta)*dist**2*p1%vol + ! Determine minimum bond distance + this%min_dist=min(this%min_dist,dist) + end if + end do + end do + end do + end do + ! Zero out initial dilatation + p1%dil=0.0_WP + ! Copy back the particle + this%p(n1)=p1 + end do + ! Get global minimum + call MPI_ALLREDUCE(MPI_IN_PLACE,this%min_dist,1,MPI_REAL_WP,MPI_MIN,this%cfg%comm,ierr) + end block create_bonds + + ! Clean up + if (allocated(npic)) deallocate(npic) + if (allocated(ipic)) deallocate(ipic) + + + end subroutine bond_init + + + !> Calculate bond force between particles + subroutine get_bond_force(this) + implicit none + class(lss), intent(inout) :: this + integer, dimension(:,:,:), allocatable :: npic !< Number of particle in cell + integer, dimension(:,:,:,:), allocatable :: ipic !< Index of particle in cell + logical :: is2D + + ! Need to modify parameters in 2D + is2D=this%cfg%nx.eq.1.or.this%cfg%ny.eq.1.or.this%cfg%nz.eq.1 + + ! Communicate particles in ghost cells + call this%share() + + ! We can now assemble particle-in-cell information + pic_prep: block + use mpi_f08 + integer :: i,ip,jp,kp,ierr + integer :: mymax_npic,max_npic + + ! Allocate number of particle in cell + allocate(npic(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)); npic=0 + + ! Count particles and ghosts per cell + do i=1,this%np_ + ip=this%p(i)%ind(1); jp=this%p(i)%ind(2); kp=this%p(i)%ind(3) + npic(ip,jp,kp)=npic(ip,jp,kp)+1 + end do + do i=1,this%ng_ + ip=this%g(i)%ind(1); jp=this%g(i)%ind(2); kp=this%g(i)%ind(3) + npic(ip,jp,kp)=npic(ip,jp,kp)+1 + end do + + ! Get maximum number of particle in cell + mymax_npic=maxval(npic); call MPI_ALLREDUCE(mymax_npic,max_npic,1,MPI_INTEGER,MPI_MAX,this%cfg%comm,ierr) + + ! Allocate pic map + allocate(ipic(1:max_npic,this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)); ipic=0 + + ! Assemble pic map + npic=0 + do i=1,this%np_ + ip=this%p(i)%ind(1); jp=this%p(i)%ind(2); kp=this%p(i)%ind(3) + npic(ip,jp,kp)=npic(ip,jp,kp)+1 + ipic(npic(ip,jp,kp),ip,jp,kp)=+i + end do + do i=1,this%ng_ + ip=this%g(i)%ind(1); jp=this%g(i)%ind(2); kp=this%g(i)%ind(3) + npic(ip,jp,kp)=npic(ip,jp,kp)+1 + ipic(npic(ip,jp,kp),ip,jp,kp)=-i + end do + + end block pic_prep + + ! Update weighted volume and dilatation + update_weighted_vol_and_dilatation: block + integer :: i,j,k,n1,nn,n2 + type(part) :: p1,p2 + integer :: nb,nbond + real(WP), dimension(3) :: rpos, Gd_vec + real(WP) :: dist, Gd_mag + ! Loop over particles + do n1=1,this%np_ + ! Create copy of our particle + p1=this%p(n1) + ! Zero out weighted volume and dilatation + p1%mw=0.0_WP + p1%dil=0.0_WP + ! Loop over neighbor cells + do k=p1%ind(3)-this%nb,p1%ind(3)+this%nb + do j=p1%ind(2)-this%nb,p1%ind(2)+this%nb + do i=p1%ind(1)-this%nb,p1%ind(1)+this%nb + ! Loop over particles in that cell + do nn=1,npic(i,j,k) + ! Create copy of our neighbor + n2=ipic(nn,i,j,k) + if (n2.gt.0) then + p2=this%p(+n2) + else if (n2.lt.0) then + p2=this%g(-n2) + end if + ! Check if a bond exists + do nb=1,max_bond + if (p1%ibond(nb).eq.p2%i) then + ! Increment weighted volume + p1%mw=p1%mw+wgauss(p1%dbond(nb),this%delta)*p1%dbond(nb)**2*p2%vol + ! Get current distance + rpos=p2%pos-p1%pos + dist=sqrt(dot_product(rpos,rpos)) + ! compute average G correction for dilitation + Gd_vec = (p2%gd + p1%gd)/2.0_WP + + Gd_mag = sqrt(1.0_WP/(((rpos(1)/dist)/Gd_vec(1))**2 + ((rpos(2)/dist)/Gd_vec(2))**2 + ((rpos(3)/dist)/Gd_vec(3))**2 )) + ! Increment dilatation + p1%dil=p1%dil+wgauss(p1%dbond(nb),this%delta)*p1%dbond(nb)*(dist-p1%dbond(nb))*p2%vol!*Gd_mag + end if + end do + end do + end do + end do + end do + ! Rescale dilatation + if (p1%mw.gt.epsilon(1.0_WP)) then + if (is2D) then + ! 2D plane strain + p1%dil=p1%dil*2.0_WP/p1%mw + else + ! 3D + p1%dil=p1%dil*3.0_WP/p1%mw + end if + else + p1%dil=0.0_WP + end if + ! Copy back the particle + this%p(n1)=p1 + end do + end block update_weighted_vol_and_dilatation + + ! Re-communicate particles in ghost cells to update dil and mw + call this%share() + + ! Update bond force, including collision force, and SED + update_bond_force: block + use mpi_f08, only: MPI_ALLREDUCE,MPI_MIN,MPI_IN_PLACE + use parallel, only: MPI_REAL_WP + use mathtools, only: Pi + integer :: i,j,k,n1,nn,n2,ierr + type(part) :: p1,p2 + real(WP), dimension(3) :: rpos,t12,t21,Gd_vec,f + real(WP) :: dist,beta,alpha,ed,t,Gd_mag + real(WP) :: stretch,max_stretch,mu,kk + real(WP) :: nc,rc,kc + integer :: nb,nbond + logical :: found_bond + ! Recompute a few physical parameters + mu=this%elastic_modulus/(2.0_WP+2.0_WP*this%poisson_ratio) + kk=this%elastic_modulus/(3.0_WP-6.0_WP*this%poisson_ratio) + + if (is2D) then + if (this%cfg%nx.eq.1) t=this%cfg%xL + if (this%cfg%ny.eq.1) t=this%cfg%yL + if (this%cfg%nz.eq.1) t=this%cfg%zL + max_stretch=sqrt(this%crit_energy/((6.0_WP*mu/Pi+16.0_WP/(9.0_WP*Pi**2)*(kk-2.0_WP*mu))*this%delta)) + kc=15.0_WP*48.0_WP*this%elastic_modulus/(Pi*5.0_WP*t*this%delta**3) + else + max_stretch=sqrt(this%crit_energy/((3.0_WP*mu+(kk-5.0_WP*mu/3.0_WP)*0.75_WP**4)*this%delta)) + kc=15.0_WP*12.0_WP*this%elastic_modulus/(Pi*this%delta**4) + end if + nc=1.0_WP + this%min_dist=huge(1.0_WP) + ! Loop over particles + do n1=1,this%np_ + ! Particles marked 0 do not update their forces + if (this%p(n1)%id.eq.0) cycle + ! Create copy of our particle + p1=this%p(n1) + ! Zero out bond force + p1%Abond=0.0_WP + p1%sigma=0.0_WP + p1%vonMises=0.0_WP + ! Loop over neighbor cells + do k=p1%ind(3)-this%nb,p1%ind(3)+this%nb + do j=p1%ind(2)-this%nb,p1%ind(2)+this%nb + do i=p1%ind(1)-this%nb,p1%ind(1)+this%nb + ! Loop over particles in that cell + do nn=1,npic(i,j,k) + ! Create copy of our neighbor + n2=ipic(nn,i,j,k) + if (n2.gt.0) then + p2=this%p(+n2) + else if (n2.lt.0) then + p2=this%g(-n2) + end if + ! Current distance + rpos=p2%pos-p1%pos + dist=sqrt(dot_product(rpos,rpos)) + ! Check if a bond exists + found_bond=.false. + do nb=1,max_bond + if (p1%ibond(nb).eq.p2%i) then + ! Check for breakage first + stretch=(dist-p1%dbond(nb))/p1%dbond(nb) + if (stretch.gt.max_stretch) then + ! Remove the bond and flag as surface particle + p1%ibond(nb)=0 + p1%dbond(nb)=0.0_WP + cycle + end if + ! Particle 1 + if (is2D) then + ! 2D plane strain + beta = 2.0_WP * kk * p1%dil + alpha = 8.0_WP * mu / p1%mw + ed = dist - p1%dbond(nb) * (1.0_WP + p1%dil / 2.0_WP) + else + ! 3D + beta = 3.0_WP * kk * p1%dil + alpha = 15.0_WP * mu / p1%mw + ed = dist - p1%dbond(nb) * (1.0_WP + p1%dil / 3.0_WP) + end if + ! Force density 1->2 + ! print*, beta + t12=+wgauss(p1%dbond(nb),this%delta)*(beta/p1%mw*p1%dbond(nb)+alpha*ed)*rpos/dist + ! t12=+wgauss(p1%dbond(nb),this%delta)*((3.0_WP*kk - 15.0_WP*mu/3.0_WP)*(p1%dil*p1%dbond(nb)/p1%mw) + 15*mu*dist/p1%mw)*rpos/dist + ! Gd_vec = (p2%gd + p1%gd)/2.0_WP + ! Gd_mag = sqrt(1.0_WP/(((rpos(1)/dist)/Gd_vec(1))**2 + ((rpos(2)/dist)/Gd_vec(2))**2 + ((rpos(3)/dist)/Gd_vec(3))**2 )) + ! t12=+wgauss(p1%dbond(nb),this%delta)*((3.0_WP*kk - 15.0_WP*mu/3.0_WP)*(Gd_mag*p1%dil*p1%dbond(nb)/p1%mw) + (15.0_WP*mu/p1%mw)*(dist - p1%dbond(nb)) )*rpos/dist + ! Particle 2 + p1%vonMises =p1%vonMises + p1%mw/(wgauss(p1%dbond(nb),this%delta)*5.0_WP) * ((alpha * wgauss(p1%dbond(nb),this%delta) * ed)**2) * p2%vol + if (is2D) then + ! 2D plane strain + beta = 2.0_WP * kk * p2%dil + alpha = 8.0_WP * mu / p2%mw + ed = dist - p1%dbond(nb) * (1.0_WP + p2%dil / 2.0_WP) + else + ! 3D + beta = 3.0_WP * kk * p2%dil + alpha = 15.0_WP * mu / p2%mw + ed = dist - p1%dbond(nb) * (1.0_WP + p2%dil / 3.0_WP) + end if + ! Force density 2->1 + ! print *, rpos/dist + t21=-wgauss(p1%dbond(nb),this%delta)*(beta/p2%mw*p1%dbond(nb)+alpha*ed)*rpos/dist + ! t21=-wgauss(p1%dbond(nb),this%delta)*((3.0_WP*kk - 15.0_WP*mu/3.0_WP)*(Gd_mag*p2%dil*p1%dbond(nb)/p2%mw)+ (15.0_WP*mu/p2%mw)*(dist - p1%dbond(nb)) )*rpos/dist ! Increment bond force + p1%Abond=p1%Abond+(t12-t21)*p2%vol/this%rho + f = t12-t21 + p1%sigma(1)=p1%sigma(1) + 0.5_WP*f(1)*rpos(1)*p2%vol + p1%sigma(2)=p1%sigma(2) + 0.5_WP*f(2)*rpos(2)*p2%vol + p1%sigma(3)=p1%sigma(3) + 0.5_WP*f(3)*rpos(3)*p2%vol + p1%sigma(4)=p1%sigma(4) + 0.25_WP*(f(1)*rpos(2) + f(2)*rpos(1))*p2%vol + p1%sigma(5)=p1%sigma(5) + 0.25_WP*(f(1)*rpos(3) + f(3)*rpos(1))*p2%vol + p1%sigma(6)=p1%sigma(6) + 0.25_WP*(f(2)*rpos(3) + f(3)*rpos(2))*p2%vol + ! If still here, we have an active bond + found_bond=.true. + ! Determine minimum bond distance + this%min_dist=min(this%min_dist,dist) + cycle + end if + end do + ! Add collision force now + ! if (is2D) then + ! rc=p1%vol**(1.0_WP/2.0_WP) + ! else + ! rc=p1%vol**(1.0_WP/3.0_WP) + ! end if + ! if (.not.found_bond.and.p1%i.ne.p2%i.and.dist.lt.rc) then + ! p1%Abond=p1%Abond-max(kc*((rc/dist)**nc-1.0_WP),0.0_WP)*(rpos/dist)*p1%vol/this%rho + ! p1%flag = -2 + ! end if + end do + end do + end do + end do + ! Deal with dimensionality + if (this%cfg%nx.eq.1) p1%Abond(1)=0.0_WP + if (this%cfg%ny.eq.1) p1%Abond(2)=0.0_WP + if (this%cfg%nz.eq.1) p1%Abond(3)=0.0_WP + + p1%sigma=p1%sigma/p1%vol + !p1%vonMises=sqrt(((p1%sigma(1)-p1%sigma(2))**2 + (p1%sigma(1)-p1%sigma(3))**2 + (p1%sigma(3)-p1%sigma(2))**2 + 6.0_WP*(p1%sigma(4)**2 + p1%sigma(5)**2 + p1%sigma(6)**2))/2.0_WP) + p1%vonMises = sqrt(p1%vonMises) + ! Copy back the particle + this%p(n1)=p1 + end do + ! Get global minimum + call MPI_ALLREDUCE(MPI_IN_PLACE,this%min_dist,1,MPI_REAL_WP,MPI_MIN,this%cfg%comm,ierr) + end block update_bond_force + + ! Clean up + if (allocated(npic)) deallocate(npic) + if (allocated(ipic)) deallocate(ipic) + + end subroutine get_bond_force + + + !> Advance the particle equations by a specified time step dt + !> p%id=-2 => do not solve for position nor velocity + !> p%id=-1 => do not solve for velocity + !> p%id= 0 => do not update force + + subroutine advance(this,dt)!,stress_x,stress_y,stress_z) + use mpi_f08, only : MPI_SUM,MPI_INTEGER,MPI_IN_PLACE + use mathtools, only: Pi + implicit none + class(lss), intent(inout) :: this + real(WP), intent(inout) :: dt !< Timestep size over which to advance + ! real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(inout) :: stress_x !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + ! real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(inout) :: stress_y !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + ! real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(inout) :: stress_z !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + integer :: n,ierr + ! real(WP), dimension(3) :: stress + + ! Zero out number of particles removed + this%np_out=0 + + ! Advance velocity based on old force and position based on mid-velocity + do n=1,this%np_ + ! Advance with Verlet scheme + if (this%p(n)%id.gt.-1) this%p(n)%vel=(1-this%beta)*this%p(n)%vel+0.5_WP*dt*(this%gravity+this%p(n)%Abond+this%p(n)%Afluid) + if (this%p(n)%id.gt.-2) this%p(n)%pos=this%p(n)%pos+dt*this%p(n)%vel + this%p(n)%displacement=this%p(n)%pos-this%p(n)%ipos + ! Relocalize + this%p(n)%ind=this%cfg%get_ijk_global(this%p(n)%pos,this%p(n)%ind) + ! Correct the position to take into account periodicity + if (this%cfg%xper) this%p(n)%pos(1)=this%cfg%x(this%cfg%imin)+modulo(this%p(n)%pos(1)-this%cfg%x(this%cfg%imin),this%cfg%xL) + if (this%cfg%yper) this%p(n)%pos(2)=this%cfg%y(this%cfg%jmin)+modulo(this%p(n)%pos(2)-this%cfg%y(this%cfg%jmin),this%cfg%yL) + if (this%cfg%zper) this%p(n)%pos(3)=this%cfg%z(this%cfg%kmin)+modulo(this%p(n)%pos(3)-this%cfg%z(this%cfg%kmin),this%cfg%zL) + ! Handle particles that have left the domain + if (this%p(n)%pos(1).lt.this%cfg%x(this%cfg%imin).or.this%p(n)%pos(1).gt.this%cfg%x(this%cfg%imax+1)) this%p(n)%flag=1 + if (this%p(n)%pos(2).lt.this%cfg%y(this%cfg%jmin).or.this%p(n)%pos(2).gt.this%cfg%y(this%cfg%jmax+1)) this%p(n)%flag=1 + if (this%p(n)%pos(3).lt.this%cfg%z(this%cfg%kmin).or.this%p(n)%pos(3).gt.this%cfg%z(this%cfg%kmax+1)) this%p(n)%flag=1 + ! Relocalize the particle + this%p(n)%ind=this%cfg%get_ijk_global(this%p(n)%pos,this%p(n)%ind) + ! Count number of particles removed + if (this%p(n)%flag.eq.1) this%np_out=this%np_out+1 + end do + + ! Communicate particles + call this%sync() + + ! Sum up particles removed + call MPI_ALLREDUCE(this%np_out,n,1,MPI_INTEGER,MPI_SUM,this%cfg%comm,ierr); this%np_out=n + + ! Calculate bond force + call this%get_bond_force() + + ! Advance velocity only based on new force + do n=1,this%np_ + ! Advance with Verlet scheme + if (this%p(n)%id.le.-1) cycle + ! stress=this%cfg%get_velocity(pos=this%p(n)%pos,i0=this%p(n)%ind(1),j0=this%p(n)%ind(2),k0=this%p(n)%ind(3),U=stress_x,V=stress_y,W=stress_z) + ! this%p(n)%Afluid=stress/this%rho + ! this%p(n)%Afluid=0.0_WP + ! A Fluid is zero in the init, but is non-zero for pulling elements if specified + this%p(n)%vel=this%p(n)%vel*(1-this%beta)+0.5_WP*dt*(this%gravity+this%p(n)%Abond+this%p(n)%Afluid) + end do + + ! Recompute volume fraction + ! call this%update_VF() + + ! Log/screen output + logging: block + use, intrinsic :: iso_fortran_env, only: output_unit + use param, only: verbose + use messager, only: log + use string, only: str_long + character(len=str_long) :: message + if (this%cfg%amRoot) then + write(message,'("Particle solver [",a,"] on partitioned grid [",a,"]: ",i0," particles were advanced")') trim(this%name),trim(this%cfg%name),this%np + if (verbose.gt.1) write(output_unit,'(a)') trim(message) + if (verbose.gt.0) call log(message) + end if + end block logging + + end subroutine advance + + subroutine stretch(this,dt)!,stress_x,stress_y,stress_z) + use mpi_f08, only : MPI_SUM,MPI_INTEGER,MPI_IN_PLACE + use mathtools, only: Pi + implicit none + class(lss), intent(inout) :: this + real(WP), intent(inout) :: dt !< Timestep size over which to advance + real(WP) :: mu + integer :: n,ierr + real(WP), dimension(:,:), allocatable :: temp_gd + + allocate(temp_gd(this%np_, 3)) + !======================================================================================== + ! X-Axis Stretch: + ! Zero out number of particles removed + this%np_out=0 + do n=1,this%np_ + ! Stretch the beam along the x axis with a uniform strain-rate of 0.001 + this%p(n)%pos(1)=this%p(n)%pos(1)*1.001_WP + end do + + ! Communicate particles + call this%sync() + + ! Calculate bond force + call this%get_bond_force() + + mu=this%elastic_modulus/(2.0_WP+2.0_WP*this%poisson_ratio) + + do n=1,this%np_ + temp_gd(n,1)=0.001_WP/this%p(n)%dil + end do + + !======================================================================================== + ! Y-Axis Stretch: + ! Zero out number of particles removed + this%np_out=0 + do n=1,this%np_ + ! Stretch the beam along the x axis with a uniform strain-rate of 0.001 + this%p(n)%pos(1)=this%p(n)%pos(1)/1.001_WP + this%p(n)%pos(2)=this%p(n)%pos(2)*1.001_WP + end do + + ! Communicate particles + call this%sync() + + ! Calculate bond force + call this%get_bond_force() + + mu=this%elastic_modulus/(2.0_WP+2.0_WP*this%poisson_ratio) + + do n=1,this%np_ + temp_gd(n,2)=0.001_WP/this%p(n)%dil + end do + + !======================================================================================== + ! Z-Axis Stretch: + ! Zero out number of particles removed + this%np_out=0 + do n=1,this%np_ + ! Stretch the beam along the x axis with a uniform strain-rate of 0.001 + this%p(n)%pos(2)=this%p(n)%pos(2)/1.001_WP + this%p(n)%pos(3)=this%p(n)%pos(3)*1.001_WP + end do + + ! Communicate particles + call this%sync() + + ! Calculate bond force + call this%get_bond_force() + + mu=this%elastic_modulus/(2.0_WP+2.0_WP*this%poisson_ratio) + + do n=1,this%np_ + temp_gd(n,3)=0.001_WP/this%p(n)%dil + end do + + ! Put the particle back where it was + do n=1,this%np_ + this%p(n)%pos(3)=this%p(n)%pos(3)/1.001_WP + end do + + !====================================================================================== + + ! Now stretch particle for the first time step + + do n=1,this%np_ + ! Stretch the beam along the x axis with a uniform strain-rate of 0.001 + this%p(n)%gd=temp_gd(n,:) + end do + + do n=1,this%np_ + ! Stretch the beam along the x axis with a uniform strain-rate of 0.001 + this%p(n)%pos=this%p(n)%pos*1.001_WP + this%p(n)%displacement=this%p(n)%pos-this%p(n)%ipos + end do + + ! Communicate particles + call this%sync() + + ! Calculate bond force + call this%get_bond_force() + + deallocate(temp_gd) + + + end subroutine stretch + + !> Update particle volume fraction using our current particles + subroutine update_VF(this) + implicit none + class(lss), intent(inout) :: this + integer :: i + ! Reset volume fraction and momentum + this%VF=0.0_WP; this%VFU=0.0_WP; this%VFV=0.0_WP; this%VFW=0.0_WP + ! Transfer particle volume + do i=1,this%np_ + ! Skip inactive particle + if (this%p(i)%flag.eq.1) cycle + ! Transfer volume to mesh + call this%extrapolate(Ap=this%p(i)%vol,xp=this%p(i)%pos(1),yp=this%p(i)%pos(2),zp=this%p(i)%pos(3),ip=this%p(i)%ind(1),jp=this%p(i)%ind(2),kp=this%p(i)%ind(3),A=this%VF,dir='SC') + call this%extrapolate(Ap=this%p(i)%vol*this%p(i)%vel(1),xp=this%p(i)%pos(1),yp=this%p(i)%pos(2),zp=this%p(i)%pos(3),ip=this%p(i)%ind(1),jp=this%p(i)%ind(2),kp=this%p(i)%ind(3),A=this%VFU,dir='U') + call this%extrapolate(Ap=this%p(i)%vol*this%p(i)%vel(2),xp=this%p(i)%pos(1),yp=this%p(i)%pos(2),zp=this%p(i)%pos(3),ip=this%p(i)%ind(1),jp=this%p(i)%ind(2),kp=this%p(i)%ind(3),A=this%VFV,dir='V') + call this%extrapolate(Ap=this%p(i)%vol*this%p(i)%vel(3),xp=this%p(i)%pos(1),yp=this%p(i)%pos(2),zp=this%p(i)%pos(3),ip=this%p(i)%ind(1),jp=this%p(i)%ind(2),kp=this%p(i)%ind(3),A=this%VFW,dir='W') + end do + ! Sum at boundaries + call this%cfg%syncsum(this%VF) + call this%cfg%syncsum(this%VFU) + call this%cfg%syncsum(this%VFV) + call this%cfg%syncsum(this%VFW) + ! Clip + where (this%VF.gt.1.0_WP) this%VF=1.0_WP + where (this%VF.lt.0.0_WP) this%VF=0.0_WP + end subroutine update_VF + + + !> Compute regularized delta function + subroutine get_delta(this,delta,ic,jc,kc,xp,yp,zp,dir) + implicit none + class(lss), intent(inout) :: this + real(WP), intent(out) :: delta !< Return delta function + integer, intent(in) :: ic,jc,kc !< Cell index + real(WP), intent(in) :: xp,yp,zp !< Position of marker + character(len=*) :: dir + real(WP) :: deltax,deltay,deltaz,r + + ! Compute in X + if (trim(adjustl(dir)).eq.'U') then + r=(xp-this%cfg%x(ic))*this%cfg%dxmi(ic) + deltax=roma_kernel(r)*this%cfg%dxmi(ic) + else + r=(xp-this%cfg%xm(ic))*this%cfg%dxi(ic) + deltax=roma_kernel(r)*this%cfg%dxi(ic) + end if + + ! Compute in Y + if (trim(adjustl(dir)).eq.'V') then + r=(yp-this%cfg%y(jc))*this%cfg%dymi(jc) + deltay=roma_kernel(r)*this%cfg%dymi(jc) + else + r=(yp-this%cfg%ym(jc))*this%cfg%dyi(jc) + deltay=roma_kernel(r)*this%cfg%dyi(jc) + end if + + ! Compute in Z + if (trim(adjustl(dir)).eq.'W') then + r=(zp-this%cfg%z(kc))*this%cfg%dzmi(kc) + deltaz=roma_kernel(r)*this%cfg%dzmi(kc) + else + r=(zp-this%cfg%zm(kc))*this%cfg%dzi(kc) + deltaz=roma_kernel(r)*this%cfg%dzi(kc) + end if + !else + + ! Put it all together + delta=deltax*deltay*deltaz + + contains + ! Mollification kernel + ! Roma A, Peskin C and Berger M 1999 J. Comput. Phys. 153 509–534 + function roma_kernel(r) result(phi) + implicit none + real(WP), intent(in) :: r + real(WP) :: phi + if (abs(r).le.0.5_WP) then + phi=1.0_WP/3.0_WP*(1.0_WP+sqrt(-3.0_WP*r**2+1.0_WP)) + else if (abs(r).gt.0.5_WP .and. abs(r).le.1.5_WP) then + phi=1.0_WP/6.0_WP*(5.0_WP-3.0_WP*abs(r)-sqrt(-3.0_WP*(1.0_WP-abs(r))**2+1.0_WP)) + else + phi=0.0_WP + end if + end function roma_kernel + + end subroutine get_delta + + + !> Interpolation routine + function interpolate(this,A,xp,yp,zp,ip,jp,kp,dir) result(Ap) + implicit none + class(lss), intent(inout) :: this + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(in) :: A !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + real(WP), intent(in) :: xp,yp,zp + integer, intent(in) :: ip,jp,kp + character(len=*) :: dir + real(WP) :: Ap + integer :: di,dj,dk + integer :: i1,i2,j1,j2,k1,k2 + real(WP), dimension(-2:+2,-2:+2,-2:+2) :: delta + ! Get the interpolation points + i1=ip-2; i2=ip+2 + j1=jp-2; j2=jp+2 + k1=kp-2; k2=kp+2 + ! Loop over neighboring cells and compute regularized delta function + do dk=-2,+2 + do dj=-2,+2 + do di=-2,+2 + call this%get_delta(delta=delta(di,dj,dk),ic=ip+di,jc=jp+dj,kc=kp+dk,xp=xp,yp=yp,zp=zp,dir=trim(dir)) + end do + end do + end do + ! Perform the actual interpolation on Ap + Ap = sum(delta*A(i1:i2,j1:j2,k1:k2))*this%cfg%vol(ip,jp,kp) + end function interpolate + + + !> Extrapolation routine + subroutine extrapolate(this,Ap,xp,yp,zp,ip,jp,kp,A,dir) + use messager, only: die + implicit none + class(lss), intent(inout) :: this + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:) :: A !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + real(WP), intent(in) :: xp,yp,zp + integer, intent(in) :: ip,jp,kp + real(WP), intent(in) :: Ap + character(len=*) :: dir + real(WP), dimension(-2:+2,-2:+2,-2:+2) :: delta + integer :: di,dj,dk + ! If particle has left processor domain or reached last ghost cell, kill job + if ( ip.lt.this%cfg%imin_-1.or.ip.gt.this%cfg%imax_+1.or.& + & jp.lt.this%cfg%jmin_-1.or.jp.gt.this%cfg%jmax_+1.or.& + & kp.lt.this%cfg%kmin_-1.or.kp.gt.this%cfg%kmax_+1) then + write(*,*) ip,jp,kp,xp,yp,zp + call die('[df extrapolate] Particle has left the domain') + end if + ! Loop over neighboring cells and compute regularized delta function + do dk=-2,+2 + do dj=-2,+2 + do di=-2,+2 + call this%get_delta(delta=delta(di,dj,dk),ic=ip+di,jc=jp+dj,kc=kp+dk,xp=xp,yp=yp,zp=zp,dir=trim(dir)) + end do + end do + end do + ! Perform the actual extrapolation on A + A(ip-2:ip+2,jp-2:jp+2,kp-2:kp+2)=A(ip-2:ip+2,jp-2:jp+2,kp-2:kp+2)+delta*Ap + end subroutine extrapolate + + + !> Calculate the CFL + subroutine get_cfl(this,dt,cfl) + use mpi_f08, only: MPI_ALLREDUCE,MPI_MAX + use parallel, only: MPI_REAL_WP + implicit none + class(lss), intent(inout) :: this + real(WP), intent(in) :: dt + real(WP), intent(out) :: cfl + integer :: i,ierr + real(WP) :: my_CFLp_x,my_CFLp_y,my_CFLp_z,kk,mu,a + + ! Set the CFLs to zero + my_CFLp_x=0.0_WP; my_CFLp_y=0.0_WP; my_CFLp_z=0.0_WP + do i=1,this%np_ + my_CFLp_x=max(my_CFLp_x,abs(this%p(i)%vel(1))*this%cfg%dxi(this%p(i)%ind(1))) + my_CFLp_y=max(my_CFLp_y,abs(this%p(i)%vel(2))*this%cfg%dyi(this%p(i)%ind(2))) + my_CFLp_z=max(my_CFLp_z,abs(this%p(i)%vel(3))*this%cfg%dzi(this%p(i)%ind(3))) + end do + my_CFLp_x=my_CFLp_x*dt; my_CFLp_y=my_CFLp_y*dt; my_CFLp_z=my_CFLp_z*dt + + ! Get the parallel max + call MPI_ALLREDUCE(my_CFLp_x,this%CFLp_x,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + call MPI_ALLREDUCE(my_CFLp_y,this%CFLp_y,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + call MPI_ALLREDUCE(my_CFLp_z,this%CFLp_z,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + + ! CFL based on elastic wave speed in material + kk=this%elastic_modulus/(3.0_WP-6.0_WP*this%poisson_ratio) + mu=this%elastic_modulus/(2.0_WP+2.0_WP*this%poisson_ratio) + a=sqrt((kk+4.0_WP*mu/3.0_WP)/this%rho) + this%CFLp_a=dt*a*3/this%delta + + ! Return the maximum CFL + cfl=max(this%CFLp_x,this%CFLp_y,this%CFLp_z,this%CFLp_a) + + end subroutine get_cfl + + + !> Extract various monitoring data from particle field + subroutine get_max(this) + use mpi_f08, only: MPI_ALLREDUCE,MPI_MAX,MPI_MIN,MPI_SUM + use parallel, only: MPI_REAL_WP + implicit none + class(lss), intent(inout) :: this + real(WP) :: buf,safe_np + real(WP), dimension(3) :: buf3D + integer :: i,j,k,ierr + + ! Create safe np + safe_np=real(max(this%np,1),WP) + + ! Velocity min/max/mean + this%Umin=huge(1.0_WP); this%Umax=-huge(1.0_WP); this%Umean=0.0_WP + this%Vmin=huge(1.0_WP); this%Vmax=-huge(1.0_WP); this%Vmean=0.0_WP + this%Wmin=huge(1.0_WP); this%Wmax=-huge(1.0_WP); this%Wmean=0.0_WP + this%ibmForce=0.0_WP + do i=1,this%np_ + this%Umin=min(this%Umin,this%p(i)%vel(1)); this%Umax=max(this%Umax,this%p(i)%vel(1)); this%Umean=this%Umean+this%p(i)%vel(1) + this%Vmin=min(this%Vmin,this%p(i)%vel(2)); this%Vmax=max(this%Vmax,this%p(i)%vel(2)); this%Vmean=this%Vmean+this%p(i)%vel(2) + this%Wmin=min(this%Wmin,this%p(i)%vel(3)); this%Wmax=max(this%Wmax,this%p(i)%vel(3)); this%Wmean=this%Wmean+this%p(i)%vel(3) + this%ibmForce=this%ibmForce+this%p(i)%Afluid*this%p(i)%vol*this%rho + end do + call MPI_ALLREDUCE(this%Umin ,buf,1,MPI_REAL_WP,MPI_MIN,this%cfg%comm,ierr); this%Umin =buf + call MPI_ALLREDUCE(this%Umax ,buf,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr); this%Umax =buf + call MPI_ALLREDUCE(this%Umean,buf,1,MPI_REAL_WP,MPI_SUM,this%cfg%comm,ierr); this%Umean=buf/safe_np + call MPI_ALLREDUCE(this%Vmin ,buf,1,MPI_REAL_WP,MPI_MIN,this%cfg%comm,ierr); this%Vmin =buf + call MPI_ALLREDUCE(this%Vmax ,buf,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr); this%Vmax =buf + call MPI_ALLREDUCE(this%Vmean,buf,1,MPI_REAL_WP,MPI_SUM,this%cfg%comm,ierr); this%Vmean=buf/safe_np + call MPI_ALLREDUCE(this%Wmin ,buf,1,MPI_REAL_WP,MPI_MIN,this%cfg%comm,ierr); this%Wmin =buf + call MPI_ALLREDUCE(this%Wmax ,buf,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr); this%Wmax =buf + call MPI_ALLREDUCE(this%Wmean,buf,1,MPI_REAL_WP,MPI_SUM,this%cfg%comm,ierr); this%Wmean=buf/safe_np + call MPI_ALLREDUCE(this%ibmForce,buf3D,3,MPI_REAL_WP,MPI_SUM,this%cfg%comm,ierr); this%ibmForce=buf3D + + ! Get max volume fraction + this%VFmax =-huge(1.0_WP) + do k=this%cfg%kmin_,this%cfg%kmax_ + do j=this%cfg%jmin_,this%cfg%jmax_ + do i=this%cfg%imin_,this%cfg%imax_ + this%VFmax=max(this%VFmax,this%VF(i,j,k)) + end do + end do + end do + call MPI_ALLREDUCE(this%VFmax,buf,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr); this%VFmax=buf + + end subroutine get_max + + + !> Update particle mesh using our current particles + subroutine update_partmesh(this,pmesh) + use partmesh_class, only: partmesh + implicit none + class(lss), intent(inout) :: this + class(partmesh), intent(inout) :: pmesh + integer :: i + ! Reset particle mesh storage + call pmesh%reset() + ! Nothing else to do if no particle is present + if (this%np_.eq.0) return + ! Copy particle info + call pmesh%set_size(this%np_) + do i=1,this%np_ + pmesh%pos(:,i)=this%p(i)%pos + end do + end subroutine update_partmesh + + + !> Creation of the MPI datatype for particle + subroutine prepare_mpi_part() + use mpi_f08 + use messager, only: die + implicit none + integer(MPI_ADDRESS_KIND), dimension(part_nblock) :: disp + integer(MPI_ADDRESS_KIND) :: lb,extent + type(MPI_Datatype) :: MPI_PART_TMP + integer :: i,mysize,ierr + ! Prepare the displacement array + disp(1)=0 + do i=2,part_nblock + call MPI_Type_size(part_tblock(i-1),mysize,ierr) + disp(i)=disp(i-1)+int(mysize,MPI_ADDRESS_KIND)*int(part_lblock(i-1),MPI_ADDRESS_KIND) + end do + ! Create and commit the new type + call MPI_Type_create_struct(part_nblock,part_lblock,disp,part_tblock,MPI_PART_TMP,ierr) + call MPI_Type_get_extent(MPI_PART_TMP,lb,extent,ierr) + call MPI_Type_create_resized(MPI_PART_TMP,lb,extent,MPI_PART,ierr) + call MPI_Type_commit(MPI_PART,ierr) + ! If a problem was encountered, say it + if (ierr.ne.0) call die('[lss prepare_mpi_part] MPI Particle type creation failed') + ! Get the size of this type + call MPI_type_size(MPI_PART,MPI_PART_SIZE,ierr) + end subroutine prepare_mpi_part + + + !> Share particles across processor boundaries + subroutine share(this,nover) + use mpi_f08 + use messager, only: warn,die + implicit none + class(lss), intent(inout) :: this + integer, optional :: nover + type(part), dimension(:), allocatable :: tosend + type(part), dimension(:), allocatable :: torecv + integer :: no,nsend,nrecv + type(MPI_Status) :: status + integer :: icnt,isrc,idst,ierr + integer :: i,n + + ! Check overlap size + if (present(nover)) then + no=nover + if (no.gt.this%cfg%no) then + call warn('[lss share] Specified overlap is larger than that of cfg - reducing no') + no=this%cfg%no + else if (no.le.0) then + call die('[lss share] Specified overlap cannot be less or equal to zero') + end if + else + no=1 + end if + + ! Clean up ghost array + call this%resize_ghost(n=0); this%ng_=0 + + ! Share ghost particles in -x (no ghosts are sent here) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(1).lt.this%cfg%imin_+no) nsend=nsend+1 + end do + allocate(tosend(nsend)) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(1).lt.this%cfg%imin_+no) then + nsend=nsend+1 + tosend(nsend)=this%p(n) + if (this%cfg%xper.and.tosend(nsend)%ind(1).lt.this%cfg%imin+no) then + tosend(nsend)%pos(1)=tosend(nsend)%pos(1)+this%cfg%xL + tosend(nsend)%ind(1)=tosend(nsend)%ind(1)+this%cfg%nx + end if + end if + end do + nrecv=0 + call MPI_CART_SHIFT(this%cfg%comm,0,-1,isrc,idst,ierr) + call MPI_SENDRECV(nsend,1,MPI_INTEGER,idst,0,nrecv,1,MPI_INTEGER,isrc,0,this%cfg%comm,status,ierr) + allocate(torecv(nrecv)) + call MPI_SENDRECV(tosend,nsend,MPI_PART,idst,0,torecv,nrecv,MPI_PART,isrc,0,this%cfg%comm,status,ierr) + call this%resize_ghost(this%ng_+nrecv) + this%g(this%ng_+1:this%ng_+nrecv)=torecv + this%ng_=this%ng_+nrecv + if (allocated(tosend)) deallocate(tosend) + if (allocated(torecv)) deallocate(torecv) + + ! Share ghost particles in +x (no ghosts are sent here) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(1).gt.this%cfg%imax_-no) nsend=nsend+1 + end do + allocate(tosend(nsend)) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(1).gt.this%cfg%imax_-no) then + nsend=nsend+1 + tosend(nsend)=this%p(n) + if (this%cfg%xper.and.tosend(nsend)%ind(1).gt.this%cfg%imax-no) then + tosend(nsend)%pos(1)=tosend(nsend)%pos(1)-this%cfg%xL + tosend(nsend)%ind(1)=tosend(nsend)%ind(1)-this%cfg%nx + end if + end if + end do + nrecv=0 + call MPI_CART_SHIFT(this%cfg%comm,0,+1,isrc,idst,ierr) + call MPI_SENDRECV(nsend,1,MPI_INTEGER,idst,0,nrecv,1,MPI_INTEGER,isrc,0,this%cfg%comm,status,ierr) + allocate(torecv(nrecv)) + call MPI_SENDRECV(tosend,nsend,MPI_PART,idst,0,torecv,nrecv,MPI_PART,isrc,0,this%cfg%comm,status,ierr) + call this%resize_ghost(this%ng_+nrecv) + this%g(this%ng_+1:this%ng_+nrecv)=torecv + this%ng_=this%ng_+nrecv + if (allocated(tosend)) deallocate(tosend) + if (allocated(torecv)) deallocate(torecv) + + ! Share ghost particles in -y (ghosts need to be sent now) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(2).lt.this%cfg%jmin_+no) nsend=nsend+1 + end do + do n=1,this%ng_ + if (this%g(n)%ind(2).lt.this%cfg%jmin_+no) nsend=nsend+1 + end do + allocate(tosend(nsend)) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(2).lt.this%cfg%jmin_+no) then + nsend=nsend+1 + tosend(nsend)=this%p(n) + if (this%cfg%yper.and.tosend(nsend)%ind(2).lt.this%cfg%jmin+no) then + tosend(nsend)%pos(2)=tosend(nsend)%pos(2)+this%cfg%yL + tosend(nsend)%ind(2)=tosend(nsend)%ind(2)+this%cfg%ny + end if + end if + end do + do n=1,this%ng_ + if (this%g(n)%ind(2).lt.this%cfg%jmin_+no) then + nsend=nsend+1 + tosend(nsend)=this%g(n) + if (this%cfg%yper.and.tosend(nsend)%ind(2).lt.this%cfg%jmin+no) then + tosend(nsend)%pos(2)=tosend(nsend)%pos(2)+this%cfg%yL + tosend(nsend)%ind(2)=tosend(nsend)%ind(2)+this%cfg%ny + end if + end if + end do + nrecv=0 + call MPI_CART_SHIFT(this%cfg%comm,1,-1,isrc,idst,ierr) + call MPI_SENDRECV(nsend,1,MPI_INTEGER,idst,0,nrecv,1,MPI_INTEGER,isrc,0,this%cfg%comm,status,ierr) + allocate(torecv(nrecv)) + call MPI_SENDRECV(tosend,nsend,MPI_PART,idst,0,torecv,nrecv,MPI_PART,isrc,0,this%cfg%comm,status,ierr) + call this%resize_ghost(this%ng_+nrecv) + this%g(this%ng_+1:this%ng_+nrecv)=torecv + this%ng_=this%ng_+nrecv + if (allocated(tosend)) deallocate(tosend) + if (allocated(torecv)) deallocate(torecv) + + ! Share ghost particles in +y (ghosts need to be sent now - but not newly received ghosts!) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(2).gt.this%cfg%jmax_-no) nsend=nsend+1 + end do + do n=1,this%ng_-nrecv + if (this%g(n)%ind(2).gt.this%cfg%jmax_-no) nsend=nsend+1 + end do + allocate(tosend(nsend)) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(2).gt.this%cfg%jmax_-no) then + nsend=nsend+1 + tosend(nsend)=this%p(n) + if (this%cfg%yper.and.tosend(nsend)%ind(2).gt.this%cfg%jmax-no) then + tosend(nsend)%pos(2)=tosend(nsend)%pos(2)-this%cfg%yL + tosend(nsend)%ind(2)=tosend(nsend)%ind(2)-this%cfg%ny + end if + end if + end do + do n=1,this%ng_-nrecv + if (this%g(n)%ind(2).gt.this%cfg%jmax_-no) then + nsend=nsend+1 + tosend(nsend)=this%g(n) + if (this%cfg%yper.and.tosend(nsend)%ind(2).gt.this%cfg%jmax-no) then + tosend(nsend)%pos(2)=tosend(nsend)%pos(2)-this%cfg%yL + tosend(nsend)%ind(2)=tosend(nsend)%ind(2)-this%cfg%ny + end if + end if + end do + nrecv=0 + call MPI_CART_SHIFT(this%cfg%comm,1,+1,isrc,idst,ierr) + call MPI_SENDRECV(nsend,1,MPI_INTEGER,idst,0,nrecv,1,MPI_INTEGER,isrc,0,this%cfg%comm,status,ierr) + allocate(torecv(nrecv)) + call MPI_SENDRECV(tosend,nsend,MPI_PART,idst,0,torecv,nrecv,MPI_PART,isrc,0,this%cfg%comm,status,ierr) + call this%resize_ghost(this%ng_+nrecv) + this%g(this%ng_+1:this%ng_+nrecv)=torecv + this%ng_=this%ng_+nrecv + if (allocated(tosend)) deallocate(tosend) + if (allocated(torecv)) deallocate(torecv) + + ! Share ghost particles in -z (ghosts need to be sent now) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(3).lt.this%cfg%kmin_+no) nsend=nsend+1 + end do + do n=1,this%ng_ + if (this%g(n)%ind(3).lt.this%cfg%kmin_+no) nsend=nsend+1 + end do + allocate(tosend(nsend)) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(3).lt.this%cfg%kmin_+no) then + nsend=nsend+1 + tosend(nsend)=this%p(n) + if (this%cfg%zper.and.tosend(nsend)%ind(3).lt.this%cfg%kmin+no) then + tosend(nsend)%pos(3)=tosend(nsend)%pos(3)+this%cfg%zL + tosend(nsend)%ind(3)=tosend(nsend)%ind(3)+this%cfg%nz + end if + end if + end do + do n=1,this%ng_ + if (this%g(n)%ind(3).lt.this%cfg%kmin_+no) then + nsend=nsend+1 + tosend(nsend)=this%g(n) + if (this%cfg%zper.and.tosend(nsend)%ind(3).lt.this%cfg%kmin+no) then + tosend(nsend)%pos(3)=tosend(nsend)%pos(3)+this%cfg%zL + tosend(nsend)%ind(3)=tosend(nsend)%ind(3)+this%cfg%nz + end if + end if + end do + nrecv=0 + call MPI_CART_SHIFT(this%cfg%comm,2,-1,isrc,idst,ierr) + call MPI_SENDRECV(nsend,1,MPI_INTEGER,idst,0,nrecv,1,MPI_INTEGER,isrc,0,this%cfg%comm,status,ierr) + allocate(torecv(nrecv)) + call MPI_SENDRECV(tosend,nsend,MPI_PART,idst,0,torecv,nrecv,MPI_PART,isrc,0,this%cfg%comm,status,ierr) + call this%resize_ghost(this%ng_+nrecv) + this%g(this%ng_+1:this%ng_+nrecv)=torecv + this%ng_=this%ng_+nrecv + if (allocated(tosend)) deallocate(tosend) + if (allocated(torecv)) deallocate(torecv) + + ! Share ghost particles in +z (ghosts need to be sent now - but not newly received ghosts!) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(3).gt.this%cfg%kmax_-no) nsend=nsend+1 + end do + do n=1,this%ng_-nrecv + if (this%g(n)%ind(3).gt.this%cfg%kmax_-no) nsend=nsend+1 + end do + allocate(tosend(nsend)) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(3).gt.this%cfg%kmax_-no) then + nsend=nsend+1 + tosend(nsend)=this%p(n) + if (this%cfg%zper.and.tosend(nsend)%ind(3).gt.this%cfg%kmax-no) then + tosend(nsend)%pos(3)=tosend(nsend)%pos(3)-this%cfg%zL + tosend(nsend)%ind(3)=tosend(nsend)%ind(3)-this%cfg%nz + end if + end if + end do + do n=1,this%ng_-nrecv + if (this%g(n)%ind(3).gt.this%cfg%kmax_-no) then + nsend=nsend+1 + tosend(nsend)=this%g(n) + if (this%cfg%zper.and.tosend(nsend)%ind(3).gt.this%cfg%kmax-no) then + tosend(nsend)%pos(3)=tosend(nsend)%pos(3)-this%cfg%zL + tosend(nsend)%ind(3)=tosend(nsend)%ind(3)-this%cfg%nz + end if + end if + end do + nrecv=0 + call MPI_CART_SHIFT(this%cfg%comm,2,+1,isrc,idst,ierr) + call MPI_SENDRECV(nsend,1,MPI_INTEGER,idst,0,nrecv,1,MPI_INTEGER,isrc,0,this%cfg%comm,status,ierr) + allocate(torecv(nrecv)) + call MPI_SENDRECV(tosend,nsend,MPI_PART,idst,0,torecv,nrecv,MPI_PART,isrc,0,this%cfg%comm,status,ierr) + call this%resize_ghost(this%ng_+nrecv) + this%g(this%ng_+1:this%ng_+nrecv)=torecv + this%ng_=this%ng_+nrecv + if (allocated(tosend)) deallocate(tosend) + if (allocated(torecv)) deallocate(torecv) + + end subroutine share + + + !> Synchronize particle arrays across processors + subroutine sync(this) + use mpi_f08 + implicit none + class(lss), intent(inout) :: this + integer, dimension(0:this%cfg%nproc-1) :: nsend_proc,nrecv_proc + integer, dimension(0:this%cfg%nproc-1) :: nsend_disp,nrecv_disp + integer :: n,prank,ierr + type(part), dimension(:), allocatable :: buf_send + ! Recycle first to minimize communication load + call this%recycle() + ! Prepare information about what to send + nsend_proc=0 + do n=1,this%np_ + prank=this%cfg%get_rank(this%p(n)%ind) + nsend_proc(prank)=nsend_proc(prank)+1 + end do + nsend_proc(this%cfg%rank)=0 + ! Inform processors of what they will receive + call MPI_ALLtoALL(nsend_proc,1,MPI_INTEGER,nrecv_proc,1,MPI_INTEGER,this%cfg%comm,ierr) + ! Prepare displacements for all-to-all + nsend_disp(0)=0 + nrecv_disp(0)=this%np_ !< Directly add particles at the end of main array + do n=1,this%cfg%nproc-1 + nsend_disp(n)=nsend_disp(n-1)+nsend_proc(n-1) + nrecv_disp(n)=nrecv_disp(n-1)+nrecv_proc(n-1) + end do + ! Allocate buffer to send particles + allocate(buf_send(sum(nsend_proc))) + ! Pack the particles in the send buffer + nsend_proc=0 + do n=1,this%np_ + ! Get the rank + prank=this%cfg%get_rank(this%p(n)%ind) + ! Skip particles still inside + if (prank.eq.this%cfg%rank) cycle + ! Pack up for sending + nsend_proc(prank)=nsend_proc(prank)+1 + buf_send(nsend_disp(prank)+nsend_proc(prank))=this%p(n) + ! Flag particle for removal + this%p(n)%flag=1 + end do + ! Allocate buffer for receiving particles + call this%resize(this%np_+sum(nrecv_proc)) + ! Perform communication + call MPI_ALLtoALLv(buf_send,nsend_proc,nsend_disp,MPI_PART,this%p,nrecv_proc,nrecv_disp,MPI_PART,this%cfg%comm,ierr) + ! Deallocate buffer + deallocate(buf_send) + ! Recycle to remove duplicate particles + call this%recycle() + end subroutine sync + + + !> Adaptation of particle array size + subroutine resize(this,n) + implicit none + class(lss), intent(inout) :: this + integer, intent(in) :: n + type(part), dimension(:), allocatable :: tmp + integer :: size_now,size_new + ! Resize particle array to size n + if (.not.allocated(this%p)) then + ! Allocate directly to size n + allocate(this%p(n)) + this%p(1:n)%flag=1 + else + ! Update from a non-zero size to another non-zero size + size_now=size(this%p,dim=1) + if (n.gt.size_now) then + size_new=max(n,int(real(size_now,WP)*coeff_up)) + allocate(tmp(size_new)) + tmp(1:size_now)=this%p + tmp(size_now+1:)%flag=1 + call move_alloc(tmp,this%p) + else if (n.lt.int(real(size_now,WP)*coeff_dn)) then + allocate(tmp(n)) + tmp(1:n)=this%p(1:n) + call move_alloc(tmp,this%p) + end if + end if + end subroutine resize + + + !> Adaptation of ghost array size + subroutine resize_ghost(this,n) + implicit none + class(lss), intent(inout) :: this + integer, intent(in) :: n + type(part), dimension(:), allocatable :: tmp + integer :: size_now,size_new + ! Resize ghost array to size n + if (.not.allocated(this%g)) then + ! Allocate directly to size n + allocate(this%g(n)) + this%g(1:n)%flag=1 + else + ! Update from a non-zero size to another non-zero size + size_now=size(this%g,dim=1) + if (n.gt.size_now) then + size_new=max(n,int(real(size_now,WP)*coeff_up)) + allocate(tmp(size_new)) + tmp(1:size_now)=this%g + tmp(size_now+1:)%flag=1 + call move_alloc(tmp,this%g) + else if (n.lt.int(real(size_now,WP)*coeff_dn)) then + allocate(tmp(n)) + tmp(1:n)=this%g(1:n) + call move_alloc(tmp,this%g) + end if + end if + end subroutine resize_ghost + + + !> Clean-up of particle array by removing flag=1 particles + subroutine recycle(this) + implicit none + class(lss), intent(inout) :: this + integer :: new_size,i,ierr + ! Compact all active particles at the beginning of the array + new_size=0 + if (allocated(this%p)) then + do i=1,size(this%p,dim=1) + if (this%p(i)%flag.ne.1) then + new_size=new_size+1 + if (i.ne.new_size) then + this%p(new_size)=this%p(i) + this%p(i)%flag=1 + end if + end if + end do + end if + ! Resize to new size + call this%resize(new_size) + ! Update number of particles + this%np_=new_size + call MPI_ALLGATHER(this%np_,1,MPI_INTEGER,this%np_proc,1,MPI_INTEGER,this%cfg%comm,ierr) + this%np=sum(this%np_proc) + end subroutine recycle + + + !> Parallel write particles to file + subroutine write(this,filename) + use mpi_f08 + use messager, only: die + use parallel, only: info_mpiio + implicit none + class(lss), intent(inout) :: this + character(len=*), intent(in) :: filename + type(MPI_File) :: ifile + type(MPI_Status):: status + integer(kind=MPI_OFFSET_KIND) :: offset + integer :: i,ierr,iunit + + ! Root serial-writes the file header + if (this%cfg%amRoot) then + ! Open the file + open(newunit=iunit,file=trim(filename),form='unformatted',status='replace',access='stream',iostat=ierr) + if (ierr.ne.0) call die('[lss write] Problem encountered while serial-opening data file: '//trim(filename)) + ! Number of particles and particle object size + write(iunit) this%np,MPI_PART_SIZE + ! Done with the header + close(iunit) + end if + + ! The rest is done in parallel + call MPI_FILE_OPEN(this%cfg%comm,trim(filename),IOR(MPI_MODE_WRONLY,MPI_MODE_APPEND),info_mpiio,ifile,ierr) + if (ierr.ne.0) call die('[lss write] Problem encountered while parallel-opening data file: '//trim(filename)) + + ! Get current position + call MPI_FILE_GET_POSITION(ifile,offset,ierr) + + ! Compute the offset and write + do i=1,this%cfg%rank + offset=offset+int(this%np_proc(i),MPI_OFFSET_KIND)*int(MPI_PART_SIZE,MPI_OFFSET_KIND) + end do + if (this%np_.gt.0) call MPI_FILE_WRITE_AT(ifile,offset,this%p,this%np_,MPI_PART,status,ierr) + + ! Close the file + call MPI_FILE_CLOSE(ifile,ierr) + + ! Log/screen output + logging: block + use, intrinsic :: iso_fortran_env, only: output_unit + use param, only: verbose + use messager, only: log + use string, only: str_long + character(len=str_long) :: message + if (this%cfg%amRoot) then + write(message,'("[lss write] Wrote ",i0," particles to file [",a,"] on partitioned grid [",a,"]")') this%np,trim(filename),trim(this%cfg%name) + if (verbose.gt.2) write(output_unit,'(a)') trim(message) + if (verbose.gt.1) call log(message) + end if + end block logging + + end subroutine write + + + !> Parallel read particles to file + subroutine read(this,filename) + use mpi_f08 + use messager, only: die + use parallel, only: info_mpiio + implicit none + class(lss), intent(inout) :: this + character(len=*), intent(in) :: filename + type(MPI_File) :: ifile + type(MPI_Status):: status + integer(kind=MPI_OFFSET_KIND) :: offset,header_offset + integer :: i,j,ierr,npadd,psize,nchunk,cnt + integer, dimension(:,:), allocatable :: ppp + + ! First open the file in parallel + call MPI_FILE_OPEN(this%cfg%comm,trim(filename),MPI_MODE_RDONLY,info_mpiio,ifile,ierr) + if (ierr.ne.0) call die('[lss read] Problem encountered while reading data file: '//trim(filename)) + + ! Read file header first + call MPI_FILE_READ_ALL(ifile,npadd,1,MPI_INTEGER,status,ierr) + call MPI_FILE_READ_ALL(ifile,psize,1,MPI_INTEGER,status,ierr) + + ! Remember current position + call MPI_FILE_GET_POSITION(ifile,header_offset,ierr) + + ! Check compatibility of particle type + if (psize.ne.MPI_PART_SIZE) call die('[lss read] Particle type unreadable') + + ! Naively share reading task among all processors + nchunk=int(npadd/(this%cfg%nproc*part_chunk_size))+1 + allocate(ppp(this%cfg%nproc,nchunk)) + ppp=int(npadd/(this%cfg%nproc*nchunk)) + cnt=0 + out:do j=1,nchunk + do i=1,this%cfg%nproc + cnt=cnt+1 + if (cnt.gt.mod(npadd,this%cfg%nproc*nchunk)) exit out + ppp(i,j)=ppp(i,j)+1 + end do + end do out + + ! Read by chunk + do j=1,nchunk + ! Find offset + offset=header_offset+int(MPI_PART_SIZE,MPI_OFFSET_KIND)*int(sum(ppp(1:this%cfg%rank,:))+sum(ppp(this%cfg%rank+1,1:j-1)),MPI_OFFSET_KIND) + ! Resize particle array + call this%resize(this%np_+ppp(this%cfg%rank+1,j)) + ! Read this file + call MPI_FILE_READ_AT(ifile,offset,this%p(this%np_+1:this%np_+ppp(this%cfg%rank+1,j)),ppp(this%cfg%rank+1,j),MPI_PART,status,ierr) + ! Most general case: relocate every droplet + do i=this%np_+1,this%np_+ppp(this%cfg%rank+1,j) + this%p(i)%ind=this%cfg%get_ijk_global(this%p(i)%pos,this%p(i)%ind) + end do + ! Exchange all that + call this%sync() + end do + + ! Close the file + call MPI_FILE_CLOSE(ifile,ierr) + + ! Log/screen output + logging: block + use, intrinsic :: iso_fortran_env, only: output_unit + use param, only: verbose + use messager, only: log + use string, only: str_long + character(len=str_long) :: message + if (this%cfg%amRoot) then + write(message,'("[lss read] Read ",i0," particles from file [",a,"] on partitioned grid [",a,"]")') npadd,trim(filename),trim(this%cfg%name) + if (verbose.gt.2) write(output_unit,'(a)') trim(message) + if (verbose.gt.1) call log(message) + end if + end block logging + + end subroutine read + + +end module lss_class diff --git a/examples/beam_tension/src/lss_class_3_axis.f90 b/examples/beam_tension/src/lss_class_3_axis.f90 new file mode 100644 index 000000000..1650239f7 --- /dev/null +++ b/examples/beam_tension/src/lss_class_3_axis.f90 @@ -0,0 +1,1637 @@ +!> Lagrangian solid solver object +!> Implements peridynamics equations +module lss_class + use precision, only: WP + use string, only: str_medium + use config_class, only: config + use mpi_f08, only: MPI_Datatype,MPI_INTEGER8,MPI_INTEGER,MPI_DOUBLE_PRECISION + implicit none + private + + + ! Expose type/constructor/methods + public :: lss + + + !> Memory adaptation parameter + real(WP), parameter :: coeff_up=1.3_WP !< Particle array size increase factor + real(WP), parameter :: coeff_dn=0.7_WP !< Particle array size decrease factor + + + !> I/O chunk size to read at a time + integer, parameter :: part_chunk_size=1000 !< Read 1000 particles at a time before redistributing + + + !> Maximum number of bonds per particle + integer, parameter, public :: max_bond=400 !< Assumes something like a 7x7x7 stencil in 3D + + + !> Bonded solid particle definition + type :: part + !> MPI_DOUBLE_PRECISION data + real(WP) :: mw !< Weighted volume + real(WP) :: dil !< Element dilatation + real(WP) :: ste !< Element dilatation + real(WP) :: vol !< Particle volume + real(WP), dimension(max_bond) :: dbond !< Length of initial bonds + real(WP), dimension(3) :: pos !< Particle center coordinates + real(WP), dimension(3) :: vel !< Velocity of particle + real(WP), dimension(3) :: Abond !< Bond acceleration for particle + real(WP), dimension(3) :: Afluid !< Fluid acceleration for particle + real(WP), dimension(3) :: gd !< Dilitation corrections + real(WP), dimension(3) :: gb !< Shear corrections + !> MPI_INTEGER data + integer :: id !< ID the object is associated with + integer :: i !< Unique index of particle (assumed >0) + integer :: nbond !< Number of initial bonds + integer, dimension(max_bond) :: ibond !< Indices of initially bonded particles (0 values ignored) + integer , dimension(3) :: ind !< Index of cell containing particle center + integer :: flag !< Control parameter (0=normal, 1=done->will be removed) + end type part + !> Number of blocks, block length, and block types in a particle + integer, parameter :: part_nblock=2 + integer , dimension(part_nblock) :: part_lblock=[22+max_bond,7+max_bond] + type(MPI_Datatype), dimension(part_nblock) :: part_tblock=[MPI_DOUBLE_PRECISION,MPI_INTEGER] + !> MPI_PART derived datatype and size + type(MPI_Datatype) :: MPI_PART + integer :: MPI_PART_SIZE + + + !> Lagrangian solid solver object definition + type :: lss + + ! This config is used for parallelization and for calculating bond/collision forces + class(config), pointer :: cfg + + ! This is the name of the solver + character(len=str_medium) :: name='UNNAMED_LSS' + + ! Solid material properties + real(WP) :: elastic_modulus !< Elastic modulus of the material + real(WP) :: poisson_ratio !< Poisson's ratio of the material + real(WP) :: rho !< Density of the material + real(WP) :: crit_energy !< Critical energy release + + ! Bonding parameters + real(WP) :: delta !< Bonding horizon (distance) + real(WP) :: min_dist !< Minimum bonding distance + integer :: nb !< Cell-based horizon + + ! Global and local particle data + integer :: np !< Global number of particles + integer :: np_ !< Local number of particles + integer, dimension(:), allocatable :: np_proc !< Number of particles on each processor + type(part), dimension(:), allocatable :: p !< Array of particles of type part + + ! Overlap particle (i.e., ghost) data + integer :: ng_ !< Local number of ghosts + type(part), dimension(:), allocatable :: g !< Array of ghosts of type part + + ! Gravitational acceleration + real(WP), dimension(3) :: gravity=[0.0_WP,0.0_WP,0.0_WP] + + ! Solid volume fraction and momentum + real(WP), dimension(:,:,:), allocatable :: VF !< Volume fraction, cell-centered + real(WP), dimension(:,:,:), allocatable :: VFU !< Solid velocity, U-face + real(WP), dimension(:,:,:), allocatable :: VFV !< Solid velocity, V-face + real(WP), dimension(:,:,:), allocatable :: VFW !< Solid velocity, W-face + + ! CFL numbers + real(WP) :: CFLp_x,CFLp_y,CFLp_z,CFLp_a + + ! Number of substeps for time integrator + real(WP) :: nstep=1 + + ! Monitoring info + real(WP) :: Umin,Umax,Umean !< U velocity info + real(WP) :: Vmin,Vmax,Vmean !< V velocity info + real(WP) :: Wmin,Wmax,Wmean !< W velocity info + real(WP) :: VFmax !< Volume fraction info + real(WP), dimension(3) :: ibmForce !< Total force due to IBM + integer :: np_out !< Number of particles leaving the domain + + contains + procedure :: bond_init !< Setup initial interparticle bonds + procedure :: get_bond_force !< Compute interparticle bond force + procedure :: advance !< Step forward the particle ODEs + procedure :: get_cfl !< Calculate maximum CFL + procedure :: get_max !< Extract various monitoring data + procedure :: update_partmesh !< Update a partmesh object using current particles + procedure :: share !< Share particles across interprocessor boundaries + procedure :: sync !< Synchronize particles across interprocessor boundaries + procedure :: resize !< Resize particle array to given size + procedure :: resize_ghost !< Resize ghost array to given size + procedure :: recycle !< Recycle particle array by removing flagged particles + procedure :: write !< Parallel write particles to file + procedure :: read !< Parallel read particles from file + procedure :: update_VF !< Compute volume fraction + procedure :: get_delta !< Compute regularized delta function + procedure :: interpolate !< Interpolation routine from mesh=>marker + procedure :: extrapolate !< Extrapolation routine from marker=>mesh + procedure :: stretch + end type lss + + + !> Declare lss constructor + interface lss + procedure constructor + end interface lss + +contains + + + ! Quasi-Gaussian weighting function - h is the cut-off + real(WP) function wgauss(d,h) + implicit none + real(WP), intent(in) :: d,h + real(WP), parameter :: coeff=2.6_WP + real(WP) :: hh + hh=coeff*h + if (d.ge.hh) then + wgauss=0.0_WP + else + wgauss=(1.0_WP+4.0_WP*d/hh)*(1.0_WP-d/hh)**4 + end if + end function wgauss + + + !> Default constructor for Lagrangian solid solver + function constructor(cfg,name) result(self) + implicit none + type(lss) :: self + class(config), target, intent(in) :: cfg + character(len=*), optional :: name + integer :: i,j,k + + ! Set the name for the solver + if (present(name)) self%name=trim(adjustl(name)) + + ! Point to pgrid object + self%cfg=>cfg + + ! Set default bonding horizon based on underlying mesh + self%delta=self%cfg%min_meshsize + self%nb=1 + self%min_dist=huge(1.0_WP) + + ! Allocate variables + allocate(self%np_proc(1:self%cfg%nproc)); self%np_proc=0 + self%np_=0; self%np=0 + call self%resize(0) + + ! Initialize MPI derived datatype for a particle + call prepare_mpi_part() + + ! Allocate VF array on cfg mesh + allocate(self%VF(self%cfg%imino_:self%cfg%imaxo_,self%cfg%jmino_:self%cfg%jmaxo_,self%cfg%kmino_:self%cfg%kmaxo_)); self%VF=0.0_WP + allocate(self%VFU(self%cfg%imino_:self%cfg%imaxo_,self%cfg%jmino_:self%cfg%jmaxo_,self%cfg%kmino_:self%cfg%kmaxo_)); self%VFU=0.0_WP + allocate(self%VFV(self%cfg%imino_:self%cfg%imaxo_,self%cfg%jmino_:self%cfg%jmaxo_,self%cfg%kmino_:self%cfg%kmaxo_)); self%VFV=0.0_WP + allocate(self%VFW(self%cfg%imino_:self%cfg%imaxo_,self%cfg%jmino_:self%cfg%jmaxo_,self%cfg%kmino_:self%cfg%kmaxo_)); self%VFW=0.0_WP + + ! Log/screen output + logging: block + use, intrinsic :: iso_fortran_env, only: output_unit + use param, only: verbose + use messager, only: log + use string, only: str_long + character(len=str_long) :: message + if (self%cfg%amRoot) then + write(message,'("LSS object [",a,"] on partitioned grid [",a,"]")') trim(self%name),trim(self%cfg%name) + if (verbose.gt.1) write(output_unit,'(a)') trim(message) + if (verbose.gt.0) call log(message) + end if + end block logging + + end function constructor + + + !> Initialize bond force between particles + subroutine bond_init(this) + use messager, only: die + implicit none + class(lss), intent(inout) :: this + integer, dimension(:,:,:), allocatable :: npic !< Number of particle in cell + integer, dimension(:,:,:,:), allocatable :: ipic !< Index of particle in cell + + ! Communicate particles in ghost cells + call this%share() + + ! We can now assemble particle-in-cell information + pic_prep: block + use mpi_f08 + integer :: i,ip,jp,kp,ierr + integer :: mymax_npic,max_npic + + ! Allocate number of particle in cell + allocate(npic(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)); npic=0 + + ! Count particles and ghosts per cell + do i=1,this%np_ + ip=this%p(i)%ind(1); jp=this%p(i)%ind(2); kp=this%p(i)%ind(3) + npic(ip,jp,kp)=npic(ip,jp,kp)+1 + end do + do i=1,this%ng_ + ip=this%g(i)%ind(1); jp=this%g(i)%ind(2); kp=this%g(i)%ind(3) + npic(ip,jp,kp)=npic(ip,jp,kp)+1 + end do + + ! Get maximum number of particle in cell + mymax_npic=maxval(npic); call MPI_ALLREDUCE(mymax_npic,max_npic,1,MPI_INTEGER,MPI_MAX,this%cfg%comm,ierr) + + ! Allocate pic map + allocate(ipic(1:max_npic,this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)); ipic=0 + + ! Assemble pic map + npic=0 + do i=1,this%np_ + ip=this%p(i)%ind(1); jp=this%p(i)%ind(2); kp=this%p(i)%ind(3) + npic(ip,jp,kp)=npic(ip,jp,kp)+1 + ipic(npic(ip,jp,kp),ip,jp,kp)=+i + end do + do i=1,this%ng_ + ip=this%g(i)%ind(1); jp=this%g(i)%ind(2); kp=this%g(i)%ind(3) + npic(ip,jp,kp)=npic(ip,jp,kp)+1 + ipic(npic(ip,jp,kp),ip,jp,kp)=-i + end do + + end block pic_prep + + ! Establish initial bonds + create_bonds: block + use mpi_f08, only: MPI_ALLREDUCE,MPI_MIN,MPI_IN_PLACE + use parallel, only: MPI_REAL_WP + use mathtools, only: Pi + integer :: i,j,k,n1,nn,n2,ierr + type(part) :: p1,p2 + real(WP), dimension(3) :: rpos + real(WP) :: dist + ! Reset minimum bond distance + this%min_dist=huge(1.0_WP) + ! Loop over particles + do n1=1,this%np_ + ! Create copy of our particle + p1=this%p(n1) + ! Zero out weighted volume + p1%mw=0.0_WP + ! Zero out bonds + p1%ibond=0 + p1%nbond=0 + ! Loop over neighbor cells + do k=p1%ind(3)-this%nb,p1%ind(3)+this%nb + do j=p1%ind(2)-this%nb,p1%ind(2)+this%nb + do i=p1%ind(1)-this%nb,p1%ind(1)+this%nb + ! Loop over particles in that cell + do nn=1,npic(i,j,k) + ! Create copy of our neighbor + n2=ipic(nn,i,j,k) + if (n2.gt.0) then + p2=this%p(+n2) + else if (n2.lt.0) then + p2=this%g(-n2) + end if + ! Cannot self-bond + if (p1%i.eq.p2%i) cycle + ! Cannot bond with different id except <=0 (<=0 bonds with everyone) + if (p1%id.ne.p2%id.and.p1%id.ge.0.and.p2%id.ge.0) cycle + ! Check interparticle distance + rpos=p2%pos-p1%pos + dist=sqrt(dot_product(rpos,rpos)) + if (dist.lt.this%delta) then + ! This particle is in horizon, create a bond + p1%nbond=p1%nbond+1 + if (p1%nbond.gt.max_bond) call die('[lss_class bond_init] Number of detected bonds is larger than max allowed') + p1%ibond(p1%nbond)=p2%i + p1%dbond(p1%nbond)=dist + ! Increment weighted volume + p1%mw=p1%mw+wgauss(dist,this%delta)*dist**2*p1%vol + ! Determine minimum bond distance + this%min_dist=min(this%min_dist,dist) + end if + end do + end do + end do + end do + ! Zero out initial dilatation + p1%dil=0.0_WP + ! Copy back the particle + this%p(n1)=p1 + end do + ! Get global minimum + call MPI_ALLREDUCE(MPI_IN_PLACE,this%min_dist,1,MPI_REAL_WP,MPI_MIN,this%cfg%comm,ierr) + end block create_bonds + + ! Clean up + if (allocated(npic)) deallocate(npic) + if (allocated(ipic)) deallocate(ipic) + + end subroutine bond_init + + + !> Calculate bond force between particles + subroutine get_bond_force(this) + implicit none + class(lss), intent(inout) :: this + integer, dimension(:,:,:), allocatable :: npic !< Number of particle in cell + integer, dimension(:,:,:,:), allocatable :: ipic !< Index of particle in cell + logical :: is2D + + ! Need to modify parameters in 2D + is2D=this%cfg%nx.eq.1.or.this%cfg%ny.eq.1.or.this%cfg%nz.eq.1 + + ! Communicate particles in ghost cells + call this%share() + + ! We can now assemble particle-in-cell information + pic_prep: block + use mpi_f08 + integer :: i,ip,jp,kp,ierr + integer :: mymax_npic,max_npic + + ! Allocate number of particle in cell + allocate(npic(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)); npic=0 + + ! Count particles and ghosts per cell + do i=1,this%np_ + ip=this%p(i)%ind(1); jp=this%p(i)%ind(2); kp=this%p(i)%ind(3) + npic(ip,jp,kp)=npic(ip,jp,kp)+1 + end do + do i=1,this%ng_ + ip=this%g(i)%ind(1); jp=this%g(i)%ind(2); kp=this%g(i)%ind(3) + npic(ip,jp,kp)=npic(ip,jp,kp)+1 + end do + + ! Get maximum number of particle in cell + mymax_npic=maxval(npic); call MPI_ALLREDUCE(mymax_npic,max_npic,1,MPI_INTEGER,MPI_MAX,this%cfg%comm,ierr) + + ! Allocate pic map + allocate(ipic(1:max_npic,this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)); ipic=0 + + ! Assemble pic map + npic=0 + do i=1,this%np_ + ip=this%p(i)%ind(1); jp=this%p(i)%ind(2); kp=this%p(i)%ind(3) + npic(ip,jp,kp)=npic(ip,jp,kp)+1 + ipic(npic(ip,jp,kp),ip,jp,kp)=+i + end do + do i=1,this%ng_ + ip=this%g(i)%ind(1); jp=this%g(i)%ind(2); kp=this%g(i)%ind(3) + npic(ip,jp,kp)=npic(ip,jp,kp)+1 + ipic(npic(ip,jp,kp),ip,jp,kp)=-i + end do + + end block pic_prep + + ! Update weighted volume and dilatation + update_weighted_vol_and_dilatation: block + integer :: i,j,k,n1,nn,n2 + type(part) :: p1,p2 + integer :: nb,nbond + real(WP), dimension(3) :: rpos, Gd_vec + real(WP) :: dist, Gd_mag + ! Loop over particles + do n1=1,this%np_ + ! Create copy of our particle + p1=this%p(n1) + ! Zero out weighted volume and dilatation + p1%mw=0.0_WP + p1%dil=0.0_WP + ! Loop over neighbor cells + do k=p1%ind(3)-this%nb,p1%ind(3)+this%nb + do j=p1%ind(2)-this%nb,p1%ind(2)+this%nb + do i=p1%ind(1)-this%nb,p1%ind(1)+this%nb + ! Loop over particles in that cell + do nn=1,npic(i,j,k) + ! Create copy of our neighbor + n2=ipic(nn,i,j,k) + if (n2.gt.0) then + p2=this%p(+n2) + else if (n2.lt.0) then + p2=this%g(-n2) + end if + ! Check if a bond exists + do nb=1,max_bond + if (p1%ibond(nb).eq.p2%i) then + ! Increment weighted volume + p1%mw=p1%mw+wgauss(p1%dbond(nb),this%delta)*p1%dbond(nb)**2*p2%vol + ! Get current distance + rpos=p2%pos-p1%pos + dist=sqrt(dot_product(rpos,rpos)) + ! compute average G correction for dilitation + Gd_vec = (p2%gd + p1%gd)/2.0_WP + + Gd_mag = sqrt(1.0_WP/(((rpos(1)/dist)/Gd_vec(1))**2 + ((rpos(2)/dist)/Gd_vec(2))**2 + ((rpos(3)/dist)/Gd_vec(3))**2 )) + ! Increment dilatation + p1%dil=p1%dil+wgauss(p1%dbond(nb),this%delta)*p1%dbond(nb)*(dist-p1%dbond(nb))*p2%vol*Gd_mag + end if + end do + end do + end do + end do + end do + ! Rescale dilatation + if (p1%mw.gt.epsilon(1.0_WP)) then + if (is2D) then + ! 2D plane strain + p1%dil=p1%dil*2.0_WP/p1%mw + else + ! 3D + p1%dil=p1%dil*3.0_WP/p1%mw + end if + else + p1%dil=0.0_WP + end if + ! Copy back the particle + this%p(n1)=p1 + end do + end block update_weighted_vol_and_dilatation + + ! Re-communicate particles in ghost cells to update dil and mw + call this%share() + + ! Update bond force, including collision force, and SED + update_bond_force: block + use mpi_f08, only: MPI_ALLREDUCE,MPI_MIN,MPI_IN_PLACE + use parallel, only: MPI_REAL_WP + use mathtools, only: Pi + integer :: i,j,k,n1,nn,n2,ierr + type(part) :: p1,p2 + real(WP), dimension(3) :: rpos,t12,t21,Gd_vec + real(WP) :: dist,beta,alpha,ed,t,Gd_mag + real(WP) :: stretch,max_stretch,mu,kk + real(WP) :: nc,rc,kc + integer :: nb,nbond + logical :: found_bond + ! Recompute a few physical parameters + mu=this%elastic_modulus/(2.0_WP+2.0_WP*this%poisson_ratio) + kk=this%elastic_modulus/(3.0_WP-6.0_WP*this%poisson_ratio) + if (is2D) then + if (this%cfg%nx.eq.1) t=this%cfg%xL + if (this%cfg%ny.eq.1) t=this%cfg%yL + if (this%cfg%nz.eq.1) t=this%cfg%zL + max_stretch=sqrt(this%crit_energy/((6.0_WP*mu/Pi+16.0_WP/(9.0_WP*Pi**2)*(kk-2.0_WP*mu))*this%delta)) + kc=15.0_WP*48.0_WP*this%elastic_modulus/(Pi*5.0_WP*t*this%delta**3) + else + max_stretch=sqrt(this%crit_energy/((3.0_WP*mu+(kk-5.0_WP*mu/3.0_WP)*0.75_WP**4)*this%delta)) + kc=15.0_WP*12.0_WP*this%elastic_modulus/(Pi*this%delta**4) + end if + nc=1.0_WP + this%min_dist=huge(1.0_WP) + ! Loop over particles + do n1=1,this%np_ + ! Particles marked 0 do not update their forces + if (this%p(n1)%id.eq.0) cycle + ! Create copy of our particle + p1=this%p(n1) + ! Zero out bond force + p1%Abond=0.0_WP + ! Loop over neighbor cells + do k=p1%ind(3)-this%nb,p1%ind(3)+this%nb + do j=p1%ind(2)-this%nb,p1%ind(2)+this%nb + do i=p1%ind(1)-this%nb,p1%ind(1)+this%nb + ! Loop over particles in that cell + do nn=1,npic(i,j,k) + ! Create copy of our neighbor + n2=ipic(nn,i,j,k) + if (n2.gt.0) then + p2=this%p(+n2) + else if (n2.lt.0) then + p2=this%g(-n2) + end if + ! Current distance + rpos=p2%pos-p1%pos + dist=sqrt(dot_product(rpos,rpos)) + ! Check if a bond exists + found_bond=.false. + do nb=1,max_bond + if (p1%ibond(nb).eq.p2%i) then + ! Check for breakage first + stretch=(dist-p1%dbond(nb))/p1%dbond(nb) + if (stretch.gt.max_stretch) then + ! Remove the bond and flag as surface particle + p1%ibond(nb)=0 + p1%dbond(nb)=0.0_WP + cycle + end if + ! Particle 1 + if (is2D) then + ! 2D plane strain + beta = 2.0_WP * kk * p1%dil + alpha = 8.0_WP * mu / p1%mw + ed = dist - p1%dbond(nb) * (1.0_WP + p1%dil / 2.0_WP) + else + ! 3D + beta = 3.0_WP * kk * p1%dil + alpha = 15.0_WP * mu / p1%mw + ed = dist - p1%dbond(nb) * (1.0_WP + p1%dil / 3.0_WP) + end if + ! Force density 1->2 + ! t12=+wgauss(p1%dbond(nb),this%delta)*(beta/p1%mw*p1%dbond(nb)+alpha*ed)*rpos/dist + ! t12=+wgauss(p1%dbond(nb),this%delta)*((3.0_WP*kk - 15.0_WP*mu/3.0_WP)*(p1%dil*p1%dbond(nb)/p1%mw) + 15*mu*dist/p1%mw)*rpos/dist + Gd_vec = (p2%gd + p1%gd)/2.0_WP + + Gd_mag = sqrt(1.0_WP/(((rpos(1)/dist)/Gd_vec(1))**2 + ((rpos(2)/dist)/Gd_vec(2))**2 + ((rpos(3)/dist)/Gd_vec(3))**2 )) + t12=+wgauss(p1%dbond(nb),this%delta)*((3.0_WP*kk - 15.0_WP*mu/3.0_WP)*(Gd_mag*p1%dil*p1%dbond(nb)/p1%mw) + (15.0_WP*mu/p1%mw)*(dist - p1%dbond(nb)) )*rpos/dist + ! Particle 2 + if (is2D) then + ! 2D plane strain + beta = 2.0_WP * kk * p2%dil + alpha = 8.0_WP * mu / p2%mw + ed = dist - p1%dbond(nb) * (1.0_WP + p2%dil / 2.0_WP) + else + ! 3D + beta = 3.0_WP * kk * p2%dil + alpha = 15.0_WP * mu / p2%mw + ed = dist - p1%dbond(nb) * (1.0_WP + p2%dil / 3.0_WP) + end if + ! Force density 2->1 + ! t21=-wgauss(p1%dbond(nb),this%delta)*(beta/p2%mw*p1%dbond(nb)+alpha*ed)*rpos/dist + t21=-wgauss(p1%dbond(nb),this%delta)*((3.0_WP*kk - 15.0_WP*mu/3.0_WP)*(Gd_mag*p2%dil*p1%dbond(nb)/p2%mw)+ (15.0_WP*mu/p2%mw)*(dist - p1%dbond(nb)) )*rpos/dist ! Increment bond force + p1%Abond=p1%Abond+(t12-t21)*p2%vol/this%rho + ! Incremend SED + p1%ste=p1%ste+alpha/2.0_WP*(wgauss(p1%dbond(nb),this%delta)*((dist-p1%dbond(nb)))*p2%vol) + ! If still here, we have an active bond + found_bond=.true. + ! Determine minimum bond distance + this%min_dist=min(this%min_dist,dist) + cycle + end if + end do + ! Add collision force now + ! if (is2D) then + ! rc=p1%vol**(1.0_WP/2.0_WP) + ! else + ! rc=p1%vol**(1.0_WP/3.0_WP) + ! end if + ! if (.not.found_bond.and.p1%i.ne.p2%i.and.dist.lt.rc) then + ! p1%Abond=p1%Abond-max(kc*((rc/dist)**nc-1.0_WP),0.0_WP)*(rpos/dist)*p1%vol/this%rho + ! p1%flag = -2 + ! end if + end do + end do + end do + end do + ! Deal with dimensionality + if (this%cfg%nx.eq.1) p1%Abond(1)=0.0_WP + if (this%cfg%ny.eq.1) p1%Abond(2)=0.0_WP + if (this%cfg%nz.eq.1) p1%Abond(3)=0.0_WP + ! Copy back the particle + this%p(n1)=p1 + end do + ! Get global minimum + call MPI_ALLREDUCE(MPI_IN_PLACE,this%min_dist,1,MPI_REAL_WP,MPI_MIN,this%cfg%comm,ierr) + end block update_bond_force + + ! Clean up + if (allocated(npic)) deallocate(npic) + if (allocated(ipic)) deallocate(ipic) + + end subroutine get_bond_force + + + !> Advance the particle equations by a specified time step dt + !> p%id=-2 => do not solve for position nor velocity + !> p%id=-1 => do not solve for velocity + !> p%id= 0 => do not update force + + subroutine advance(this,dt)!,stress_x,stress_y,stress_z) + use mpi_f08, only : MPI_SUM,MPI_INTEGER,MPI_IN_PLACE + use mathtools, only: Pi + implicit none + class(lss), intent(inout) :: this + real(WP), intent(inout) :: dt !< Timestep size over which to advance + ! real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(inout) :: stress_x !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + ! real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(inout) :: stress_y !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + ! real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(inout) :: stress_z !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + integer :: n,ierr + ! real(WP), dimension(3) :: stress + + ! Zero out number of particles removed + this%np_out=0 + + ! Advance velocity based on old force and position based on mid-velocity + do n=1,this%np_ + ! Advance with Verlet scheme + if (this%p(n)%id.gt.-1) this%p(n)%vel=this%p(n)%vel+0.5_WP*dt*(this%gravity+this%p(n)%Abond+this%p(n)%Afluid) + if (this%p(n)%id.gt.-2) this%p(n)%pos=this%p(n)%pos+dt*this%p(n)%vel + ! Relocalize + this%p(n)%ind=this%cfg%get_ijk_global(this%p(n)%pos,this%p(n)%ind) + ! Correct the position to take into account periodicity + if (this%cfg%xper) this%p(n)%pos(1)=this%cfg%x(this%cfg%imin)+modulo(this%p(n)%pos(1)-this%cfg%x(this%cfg%imin),this%cfg%xL) + if (this%cfg%yper) this%p(n)%pos(2)=this%cfg%y(this%cfg%jmin)+modulo(this%p(n)%pos(2)-this%cfg%y(this%cfg%jmin),this%cfg%yL) + if (this%cfg%zper) this%p(n)%pos(3)=this%cfg%z(this%cfg%kmin)+modulo(this%p(n)%pos(3)-this%cfg%z(this%cfg%kmin),this%cfg%zL) + ! Handle particles that have left the domain + if (this%p(n)%pos(1).lt.this%cfg%x(this%cfg%imin).or.this%p(n)%pos(1).gt.this%cfg%x(this%cfg%imax+1)) this%p(n)%flag=1 + if (this%p(n)%pos(2).lt.this%cfg%y(this%cfg%jmin).or.this%p(n)%pos(2).gt.this%cfg%y(this%cfg%jmax+1)) this%p(n)%flag=1 + if (this%p(n)%pos(3).lt.this%cfg%z(this%cfg%kmin).or.this%p(n)%pos(3).gt.this%cfg%z(this%cfg%kmax+1)) this%p(n)%flag=1 + ! Relocalize the particle + this%p(n)%ind=this%cfg%get_ijk_global(this%p(n)%pos,this%p(n)%ind) + ! Count number of particles removed + if (this%p(n)%flag.eq.1) this%np_out=this%np_out+1 + end do + + ! Communicate particles + call this%sync() + + ! Sum up particles removed + call MPI_ALLREDUCE(this%np_out,n,1,MPI_INTEGER,MPI_SUM,this%cfg%comm,ierr); this%np_out=n + + ! Calculate bond force + call this%get_bond_force() + + ! Advance velocity only based on new force + do n=1,this%np_ + ! Advance with Verlet scheme + if (this%p(n)%id.le.-1) cycle + ! stress=this%cfg%get_velocity(pos=this%p(n)%pos,i0=this%p(n)%ind(1),j0=this%p(n)%ind(2),k0=this%p(n)%ind(3),U=stress_x,V=stress_y,W=stress_z) + ! this%p(n)%Afluid=stress/this%rho + this%p(n)%Afluid=0.0_WP + this%p(n)%vel=this%p(n)%vel+0.5_WP*dt*(this%gravity+this%p(n)%Abond+this%p(n)%Afluid) + end do + + ! Recompute volume fraction + ! call this%update_VF() + + ! Log/screen output + logging: block + use, intrinsic :: iso_fortran_env, only: output_unit + use param, only: verbose + use messager, only: log + use string, only: str_long + character(len=str_long) :: message + if (this%cfg%amRoot) then + write(message,'("Particle solver [",a,"] on partitioned grid [",a,"]: ",i0," particles were advanced")') trim(this%name),trim(this%cfg%name),this%np + if (verbose.gt.1) write(output_unit,'(a)') trim(message) + if (verbose.gt.0) call log(message) + end if + end block logging + + end subroutine advance + + subroutine stretch(this,dt)!,stress_x,stress_y,stress_z) + use mpi_f08, only : MPI_SUM,MPI_INTEGER,MPI_IN_PLACE + use mathtools, only: Pi + implicit none + class(lss), intent(inout) :: this + real(WP), intent(inout) :: dt !< Timestep size over which to advance + real(WP) :: mu + integer :: n,ierr + !======================================================================================== + ! X-Axis Stretch: + ! Zero out number of particles removed + this%np_out=0 + do n=1,this%np_ + ! Stretch the beam along the x axis with a uniform strain-rate of 0.001 + if (this%p(n)%id.gt.-2) this%p(n)%pos(1)=this%p(n)%pos(1)*1.001_WP + end do + + ! Communicate particles + call this%sync() + + ! Calculate bond force + call this%get_bond_force() + + mu=this%elastic_modulus/(2.0_WP+2.0_WP*this%poisson_ratio) + + do n=1,this%np_ + if (this%p(n)%id.gt.-2) this%p(n)%gd(1)=0.001_WP/this%p(n)%dil + end do + + !======================================================================================== + ! Y-Axis Stretch: + ! Zero out number of particles removed + this%np_out=0 + do n=1,this%np_ + ! Stretch the beam along the x axis with a uniform strain-rate of 0.001 + if (this%p(n)%id.gt.-2) this%p(n)%pos(1)=this%p(n)%pos(1)/1.001_WP + if (this%p(n)%id.gt.-2) this%p(n)%pos(2)=this%p(n)%pos(2)*1.001_WP + end do + + ! Communicate particles + call this%sync() + + ! Calculate bond force + call this%get_bond_force() + + mu=this%elastic_modulus/(2.0_WP+2.0_WP*this%poisson_ratio) + + do n=1,this%np_ + if (this%p(n)%id.gt.-2) this%p(n)%gd(2)=0.001_WP/this%p(n)%dil + end do + + !======================================================================================== + ! Z-Axis Stretch: + ! Zero out number of particles removed + this%np_out=0 + do n=1,this%np_ + ! Stretch the beam along the x axis with a uniform strain-rate of 0.001 + if (this%p(n)%id.gt.-2) this%p(n)%pos(2)=this%p(n)%pos(2)/1.001_WP + if (this%p(n)%id.gt.-2) this%p(n)%pos(3)=this%p(n)%pos(3)*1.001_WP + end do + + ! Communicate particles + call this%sync() + + ! Calculate bond force + call this%get_bond_force() + + mu=this%elastic_modulus/(2.0_WP+2.0_WP*this%poisson_ratio) + + do n=1,this%np_ + this%p(n)%gd(3)=0.001_WP/this%p(n)%dil + end do + + ! Put the particle back where it was + do n=1,this%np_ + if (this%p(n)%id.gt.-2) this%p(n)%pos(3)=this%p(n)%pos(3)/1.001_WP + end do + + !====================================================================================== + + ! Now stretch particle for the first time step + + do n=1,this%np_ + ! Stretch the beam along the x axis with a uniform strain-rate of 0.001 + if (this%p(n)%id.gt.-2) this%p(n)%pos(1)=this%p(n)%pos(1)*1.001_WP + end do + + ! Communicate particles + call this%sync() + + ! Calculate bond force + call this%get_bond_force() + + + + + end subroutine stretch + + subroutine get_correction_coeffs(this,dt)!,stress_x,stress_y,stress_z) + use mpi_f08, only : MPI_SUM,MPI_INTEGER,MPI_IN_PLACE + use mathtools, only: Pi + implicit none + class(lss), intent(inout) :: this + real(WP), intent(inout) :: dt !< Timestep size over which to advance + real(WP) :: mu + integer :: n,ierr + ! Zero out number of particles removed + this%np_out=0 + do n=1,this%np_ + ! Stretch the beam along the x axis with a uniform strain-rate of 0.001 + if (this%p(n)%id.gt.-2) this%p(n)%pos(1)=this%p(n)%pos(1) + this%p(n)%pos(1)*0.001_WP + ! Relocalize + this%p(n)%ind=this%cfg%get_ijk_global(this%p(n)%pos,this%p(n)%ind) + ! Correct the position to take into account periodicity + if (this%cfg%xper) this%p(n)%pos(1)=this%cfg%x(this%cfg%imin)+modulo(this%p(n)%pos(1)-this%cfg%x(this%cfg%imin),this%cfg%xL) + if (this%cfg%yper) this%p(n)%pos(2)=this%cfg%y(this%cfg%jmin)+modulo(this%p(n)%pos(2)-this%cfg%y(this%cfg%jmin),this%cfg%yL) + if (this%cfg%zper) this%p(n)%pos(3)=this%cfg%z(this%cfg%kmin)+modulo(this%p(n)%pos(3)-this%cfg%z(this%cfg%kmin),this%cfg%zL) + ! Handle particles that have left the domain + if (this%p(n)%pos(1).lt.this%cfg%x(this%cfg%imin).or.this%p(n)%pos(1).gt.this%cfg%x(this%cfg%imax+1)) this%p(n)%flag=1 + if (this%p(n)%pos(2).lt.this%cfg%y(this%cfg%jmin).or.this%p(n)%pos(2).gt.this%cfg%y(this%cfg%jmax+1)) this%p(n)%flag=1 + if (this%p(n)%pos(3).lt.this%cfg%z(this%cfg%kmin).or.this%p(n)%pos(3).gt.this%cfg%z(this%cfg%kmax+1)) this%p(n)%flag=1 + ! Relocalize the particle + this%p(n)%ind=this%cfg%get_ijk_global(this%p(n)%pos,this%p(n)%ind) + ! Count number of particles removed + end do + + ! Communicate particles + call this%sync() + + ! Sum up particles removed + call MPI_ALLREDUCE(this%np_out,n,1,MPI_INTEGER,MPI_SUM,this%cfg%comm,ierr); this%np_out=n + + ! Calculate bond force + call this%get_bond_force() + + mu=this%elastic_modulus/(2.0_WP+2.0_WP*this%poisson_ratio) + + do n=1,this%np_ + this%p(n)%gd=0.001_WP/this%p(n)%dil + this%p(n)%Gb=0.5_WP*mu*(0.001_WP*0.001_WP)/this%p(n)%ste + end do + + ! Log/screen output + logging: block + use, intrinsic :: iso_fortran_env, only: output_unit + use param, only: verbose + use messager, only: log + use string, only: str_long + character(len=str_long) :: message + if (this%cfg%amRoot) then + write(message,'("Particle solver [",a,"] on partitioned grid [",a,"]: ",i0," particles were advanced")') trim(this%name),trim(this%cfg%name),this%np + if (verbose.gt.1) write(output_unit,'(a)') trim(message) + if (verbose.gt.0) call log(message) + end if + end block logging + + end subroutine get_correction_coeffs + + + !> Update particle volume fraction using our current particles + subroutine update_VF(this) + implicit none + class(lss), intent(inout) :: this + integer :: i + ! Reset volume fraction and momentum + this%VF=0.0_WP; this%VFU=0.0_WP; this%VFV=0.0_WP; this%VFW=0.0_WP + ! Transfer particle volume + do i=1,this%np_ + ! Skip inactive particle + if (this%p(i)%flag.eq.1) cycle + ! Transfer volume to mesh + call this%extrapolate(Ap=this%p(i)%vol,xp=this%p(i)%pos(1),yp=this%p(i)%pos(2),zp=this%p(i)%pos(3),ip=this%p(i)%ind(1),jp=this%p(i)%ind(2),kp=this%p(i)%ind(3),A=this%VF,dir='SC') + call this%extrapolate(Ap=this%p(i)%vol*this%p(i)%vel(1),xp=this%p(i)%pos(1),yp=this%p(i)%pos(2),zp=this%p(i)%pos(3),ip=this%p(i)%ind(1),jp=this%p(i)%ind(2),kp=this%p(i)%ind(3),A=this%VFU,dir='U') + call this%extrapolate(Ap=this%p(i)%vol*this%p(i)%vel(2),xp=this%p(i)%pos(1),yp=this%p(i)%pos(2),zp=this%p(i)%pos(3),ip=this%p(i)%ind(1),jp=this%p(i)%ind(2),kp=this%p(i)%ind(3),A=this%VFV,dir='V') + call this%extrapolate(Ap=this%p(i)%vol*this%p(i)%vel(3),xp=this%p(i)%pos(1),yp=this%p(i)%pos(2),zp=this%p(i)%pos(3),ip=this%p(i)%ind(1),jp=this%p(i)%ind(2),kp=this%p(i)%ind(3),A=this%VFW,dir='W') + end do + ! Sum at boundaries + call this%cfg%syncsum(this%VF) + call this%cfg%syncsum(this%VFU) + call this%cfg%syncsum(this%VFV) + call this%cfg%syncsum(this%VFW) + ! Clip + where (this%VF.gt.1.0_WP) this%VF=1.0_WP + where (this%VF.lt.0.0_WP) this%VF=0.0_WP + end subroutine update_VF + + + !> Compute regularized delta function + subroutine get_delta(this,delta,ic,jc,kc,xp,yp,zp,dir) + implicit none + class(lss), intent(inout) :: this + real(WP), intent(out) :: delta !< Return delta function + integer, intent(in) :: ic,jc,kc !< Cell index + real(WP), intent(in) :: xp,yp,zp !< Position of marker + character(len=*) :: dir + real(WP) :: deltax,deltay,deltaz,r + + ! Compute in X + if (trim(adjustl(dir)).eq.'U') then + r=(xp-this%cfg%x(ic))*this%cfg%dxmi(ic) + deltax=roma_kernel(r)*this%cfg%dxmi(ic) + else + r=(xp-this%cfg%xm(ic))*this%cfg%dxi(ic) + deltax=roma_kernel(r)*this%cfg%dxi(ic) + end if + + ! Compute in Y + if (trim(adjustl(dir)).eq.'V') then + r=(yp-this%cfg%y(jc))*this%cfg%dymi(jc) + deltay=roma_kernel(r)*this%cfg%dymi(jc) + else + r=(yp-this%cfg%ym(jc))*this%cfg%dyi(jc) + deltay=roma_kernel(r)*this%cfg%dyi(jc) + end if + + ! Compute in Z + if (trim(adjustl(dir)).eq.'W') then + r=(zp-this%cfg%z(kc))*this%cfg%dzmi(kc) + deltaz=roma_kernel(r)*this%cfg%dzmi(kc) + else + r=(zp-this%cfg%zm(kc))*this%cfg%dzi(kc) + deltaz=roma_kernel(r)*this%cfg%dzi(kc) + end if + !else + + ! Put it all together + delta=deltax*deltay*deltaz + + contains + ! Mollification kernel + ! Roma A, Peskin C and Berger M 1999 J. Comput. Phys. 153 509–534 + function roma_kernel(r) result(phi) + implicit none + real(WP), intent(in) :: r + real(WP) :: phi + if (abs(r).le.0.5_WP) then + phi=1.0_WP/3.0_WP*(1.0_WP+sqrt(-3.0_WP*r**2+1.0_WP)) + else if (abs(r).gt.0.5_WP .and. abs(r).le.1.5_WP) then + phi=1.0_WP/6.0_WP*(5.0_WP-3.0_WP*abs(r)-sqrt(-3.0_WP*(1.0_WP-abs(r))**2+1.0_WP)) + else + phi=0.0_WP + end if + end function roma_kernel + + end subroutine get_delta + + + !> Interpolation routine + function interpolate(this,A,xp,yp,zp,ip,jp,kp,dir) result(Ap) + implicit none + class(lss), intent(inout) :: this + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(in) :: A !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + real(WP), intent(in) :: xp,yp,zp + integer, intent(in) :: ip,jp,kp + character(len=*) :: dir + real(WP) :: Ap + integer :: di,dj,dk + integer :: i1,i2,j1,j2,k1,k2 + real(WP), dimension(-2:+2,-2:+2,-2:+2) :: delta + ! Get the interpolation points + i1=ip-2; i2=ip+2 + j1=jp-2; j2=jp+2 + k1=kp-2; k2=kp+2 + ! Loop over neighboring cells and compute regularized delta function + do dk=-2,+2 + do dj=-2,+2 + do di=-2,+2 + call this%get_delta(delta=delta(di,dj,dk),ic=ip+di,jc=jp+dj,kc=kp+dk,xp=xp,yp=yp,zp=zp,dir=trim(dir)) + end do + end do + end do + ! Perform the actual interpolation on Ap + Ap = sum(delta*A(i1:i2,j1:j2,k1:k2))*this%cfg%vol(ip,jp,kp) + end function interpolate + + + !> Extrapolation routine + subroutine extrapolate(this,Ap,xp,yp,zp,ip,jp,kp,A,dir) + use messager, only: die + implicit none + class(lss), intent(inout) :: this + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:) :: A !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + real(WP), intent(in) :: xp,yp,zp + integer, intent(in) :: ip,jp,kp + real(WP), intent(in) :: Ap + character(len=*) :: dir + real(WP), dimension(-2:+2,-2:+2,-2:+2) :: delta + integer :: di,dj,dk + ! If particle has left processor domain or reached last ghost cell, kill job + if ( ip.lt.this%cfg%imin_-1.or.ip.gt.this%cfg%imax_+1.or.& + & jp.lt.this%cfg%jmin_-1.or.jp.gt.this%cfg%jmax_+1.or.& + & kp.lt.this%cfg%kmin_-1.or.kp.gt.this%cfg%kmax_+1) then + write(*,*) ip,jp,kp,xp,yp,zp + call die('[df extrapolate] Particle has left the domain') + end if + ! Loop over neighboring cells and compute regularized delta function + do dk=-2,+2 + do dj=-2,+2 + do di=-2,+2 + call this%get_delta(delta=delta(di,dj,dk),ic=ip+di,jc=jp+dj,kc=kp+dk,xp=xp,yp=yp,zp=zp,dir=trim(dir)) + end do + end do + end do + ! Perform the actual extrapolation on A + A(ip-2:ip+2,jp-2:jp+2,kp-2:kp+2)=A(ip-2:ip+2,jp-2:jp+2,kp-2:kp+2)+delta*Ap + end subroutine extrapolate + + + !> Calculate the CFL + subroutine get_cfl(this,dt,cfl) + use mpi_f08, only: MPI_ALLREDUCE,MPI_MAX + use parallel, only: MPI_REAL_WP + implicit none + class(lss), intent(inout) :: this + real(WP), intent(in) :: dt + real(WP), intent(out) :: cfl + integer :: i,ierr + real(WP) :: my_CFLp_x,my_CFLp_y,my_CFLp_z,kk,mu,a + + ! Set the CFLs to zero + my_CFLp_x=0.0_WP; my_CFLp_y=0.0_WP; my_CFLp_z=0.0_WP + do i=1,this%np_ + my_CFLp_x=max(my_CFLp_x,abs(this%p(i)%vel(1))*this%cfg%dxi(this%p(i)%ind(1))) + my_CFLp_y=max(my_CFLp_y,abs(this%p(i)%vel(2))*this%cfg%dyi(this%p(i)%ind(2))) + my_CFLp_z=max(my_CFLp_z,abs(this%p(i)%vel(3))*this%cfg%dzi(this%p(i)%ind(3))) + end do + my_CFLp_x=my_CFLp_x*dt; my_CFLp_y=my_CFLp_y*dt; my_CFLp_z=my_CFLp_z*dt + + ! Get the parallel max + call MPI_ALLREDUCE(my_CFLp_x,this%CFLp_x,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + call MPI_ALLREDUCE(my_CFLp_y,this%CFLp_y,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + call MPI_ALLREDUCE(my_CFLp_z,this%CFLp_z,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + + ! CFL based on elastic wave speed in material + kk=this%elastic_modulus/(3.0_WP-6.0_WP*this%poisson_ratio) + mu=this%elastic_modulus/(2.0_WP+2.0_WP*this%poisson_ratio) + a=sqrt((kk+4.0_WP*mu/3.0_WP)/this%rho) + this%CFLp_a=dt*a*3/this%delta + + ! Return the maximum CFL + cfl=max(this%CFLp_x,this%CFLp_y,this%CFLp_z,this%CFLp_a) + + end subroutine get_cfl + + + !> Extract various monitoring data from particle field + subroutine get_max(this) + use mpi_f08, only: MPI_ALLREDUCE,MPI_MAX,MPI_MIN,MPI_SUM + use parallel, only: MPI_REAL_WP + implicit none + class(lss), intent(inout) :: this + real(WP) :: buf,safe_np + real(WP), dimension(3) :: buf3D + integer :: i,j,k,ierr + + ! Create safe np + safe_np=real(max(this%np,1),WP) + + ! Velocity min/max/mean + this%Umin=huge(1.0_WP); this%Umax=-huge(1.0_WP); this%Umean=0.0_WP + this%Vmin=huge(1.0_WP); this%Vmax=-huge(1.0_WP); this%Vmean=0.0_WP + this%Wmin=huge(1.0_WP); this%Wmax=-huge(1.0_WP); this%Wmean=0.0_WP + this%ibmForce=0.0_WP + do i=1,this%np_ + this%Umin=min(this%Umin,this%p(i)%vel(1)); this%Umax=max(this%Umax,this%p(i)%vel(1)); this%Umean=this%Umean+this%p(i)%vel(1) + this%Vmin=min(this%Vmin,this%p(i)%vel(2)); this%Vmax=max(this%Vmax,this%p(i)%vel(2)); this%Vmean=this%Vmean+this%p(i)%vel(2) + this%Wmin=min(this%Wmin,this%p(i)%vel(3)); this%Wmax=max(this%Wmax,this%p(i)%vel(3)); this%Wmean=this%Wmean+this%p(i)%vel(3) + this%ibmForce=this%ibmForce+this%p(i)%Afluid*this%p(i)%vol*this%rho + end do + call MPI_ALLREDUCE(this%Umin ,buf,1,MPI_REAL_WP,MPI_MIN,this%cfg%comm,ierr); this%Umin =buf + call MPI_ALLREDUCE(this%Umax ,buf,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr); this%Umax =buf + call MPI_ALLREDUCE(this%Umean,buf,1,MPI_REAL_WP,MPI_SUM,this%cfg%comm,ierr); this%Umean=buf/safe_np + call MPI_ALLREDUCE(this%Vmin ,buf,1,MPI_REAL_WP,MPI_MIN,this%cfg%comm,ierr); this%Vmin =buf + call MPI_ALLREDUCE(this%Vmax ,buf,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr); this%Vmax =buf + call MPI_ALLREDUCE(this%Vmean,buf,1,MPI_REAL_WP,MPI_SUM,this%cfg%comm,ierr); this%Vmean=buf/safe_np + call MPI_ALLREDUCE(this%Wmin ,buf,1,MPI_REAL_WP,MPI_MIN,this%cfg%comm,ierr); this%Wmin =buf + call MPI_ALLREDUCE(this%Wmax ,buf,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr); this%Wmax =buf + call MPI_ALLREDUCE(this%Wmean,buf,1,MPI_REAL_WP,MPI_SUM,this%cfg%comm,ierr); this%Wmean=buf/safe_np + call MPI_ALLREDUCE(this%ibmForce,buf3D,3,MPI_REAL_WP,MPI_SUM,this%cfg%comm,ierr); this%ibmForce=buf3D + + ! Get max volume fraction + this%VFmax =-huge(1.0_WP) + do k=this%cfg%kmin_,this%cfg%kmax_ + do j=this%cfg%jmin_,this%cfg%jmax_ + do i=this%cfg%imin_,this%cfg%imax_ + this%VFmax=max(this%VFmax,this%VF(i,j,k)) + end do + end do + end do + call MPI_ALLREDUCE(this%VFmax,buf,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr); this%VFmax=buf + + end subroutine get_max + + + !> Update particle mesh using our current particles + subroutine update_partmesh(this,pmesh) + use partmesh_class, only: partmesh + implicit none + class(lss), intent(inout) :: this + class(partmesh), intent(inout) :: pmesh + integer :: i + ! Reset particle mesh storage + call pmesh%reset() + ! Nothing else to do if no particle is present + if (this%np_.eq.0) return + ! Copy particle info + call pmesh%set_size(this%np_) + do i=1,this%np_ + pmesh%pos(:,i)=this%p(i)%pos + end do + end subroutine update_partmesh + + + !> Creation of the MPI datatype for particle + subroutine prepare_mpi_part() + use mpi_f08 + use messager, only: die + implicit none + integer(MPI_ADDRESS_KIND), dimension(part_nblock) :: disp + integer(MPI_ADDRESS_KIND) :: lb,extent + type(MPI_Datatype) :: MPI_PART_TMP + integer :: i,mysize,ierr + ! Prepare the displacement array + disp(1)=0 + do i=2,part_nblock + call MPI_Type_size(part_tblock(i-1),mysize,ierr) + disp(i)=disp(i-1)+int(mysize,MPI_ADDRESS_KIND)*int(part_lblock(i-1),MPI_ADDRESS_KIND) + end do + ! Create and commit the new type + call MPI_Type_create_struct(part_nblock,part_lblock,disp,part_tblock,MPI_PART_TMP,ierr) + call MPI_Type_get_extent(MPI_PART_TMP,lb,extent,ierr) + call MPI_Type_create_resized(MPI_PART_TMP,lb,extent,MPI_PART,ierr) + call MPI_Type_commit(MPI_PART,ierr) + ! If a problem was encountered, say it + if (ierr.ne.0) call die('[lss prepare_mpi_part] MPI Particle type creation failed') + ! Get the size of this type + call MPI_type_size(MPI_PART,MPI_PART_SIZE,ierr) + end subroutine prepare_mpi_part + + + !> Share particles across processor boundaries + subroutine share(this,nover) + use mpi_f08 + use messager, only: warn,die + implicit none + class(lss), intent(inout) :: this + integer, optional :: nover + type(part), dimension(:), allocatable :: tosend + type(part), dimension(:), allocatable :: torecv + integer :: no,nsend,nrecv + type(MPI_Status) :: status + integer :: icnt,isrc,idst,ierr + integer :: i,n + + ! Check overlap size + if (present(nover)) then + no=nover + if (no.gt.this%cfg%no) then + call warn('[lss share] Specified overlap is larger than that of cfg - reducing no') + no=this%cfg%no + else if (no.le.0) then + call die('[lss share] Specified overlap cannot be less or equal to zero') + end if + else + no=1 + end if + + ! Clean up ghost array + call this%resize_ghost(n=0); this%ng_=0 + + ! Share ghost particles in -x (no ghosts are sent here) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(1).lt.this%cfg%imin_+no) nsend=nsend+1 + end do + allocate(tosend(nsend)) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(1).lt.this%cfg%imin_+no) then + nsend=nsend+1 + tosend(nsend)=this%p(n) + if (this%cfg%xper.and.tosend(nsend)%ind(1).lt.this%cfg%imin+no) then + tosend(nsend)%pos(1)=tosend(nsend)%pos(1)+this%cfg%xL + tosend(nsend)%ind(1)=tosend(nsend)%ind(1)+this%cfg%nx + end if + end if + end do + nrecv=0 + call MPI_CART_SHIFT(this%cfg%comm,0,-1,isrc,idst,ierr) + call MPI_SENDRECV(nsend,1,MPI_INTEGER,idst,0,nrecv,1,MPI_INTEGER,isrc,0,this%cfg%comm,status,ierr) + allocate(torecv(nrecv)) + call MPI_SENDRECV(tosend,nsend,MPI_PART,idst,0,torecv,nrecv,MPI_PART,isrc,0,this%cfg%comm,status,ierr) + call this%resize_ghost(this%ng_+nrecv) + this%g(this%ng_+1:this%ng_+nrecv)=torecv + this%ng_=this%ng_+nrecv + if (allocated(tosend)) deallocate(tosend) + if (allocated(torecv)) deallocate(torecv) + + ! Share ghost particles in +x (no ghosts are sent here) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(1).gt.this%cfg%imax_-no) nsend=nsend+1 + end do + allocate(tosend(nsend)) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(1).gt.this%cfg%imax_-no) then + nsend=nsend+1 + tosend(nsend)=this%p(n) + if (this%cfg%xper.and.tosend(nsend)%ind(1).gt.this%cfg%imax-no) then + tosend(nsend)%pos(1)=tosend(nsend)%pos(1)-this%cfg%xL + tosend(nsend)%ind(1)=tosend(nsend)%ind(1)-this%cfg%nx + end if + end if + end do + nrecv=0 + call MPI_CART_SHIFT(this%cfg%comm,0,+1,isrc,idst,ierr) + call MPI_SENDRECV(nsend,1,MPI_INTEGER,idst,0,nrecv,1,MPI_INTEGER,isrc,0,this%cfg%comm,status,ierr) + allocate(torecv(nrecv)) + call MPI_SENDRECV(tosend,nsend,MPI_PART,idst,0,torecv,nrecv,MPI_PART,isrc,0,this%cfg%comm,status,ierr) + call this%resize_ghost(this%ng_+nrecv) + this%g(this%ng_+1:this%ng_+nrecv)=torecv + this%ng_=this%ng_+nrecv + if (allocated(tosend)) deallocate(tosend) + if (allocated(torecv)) deallocate(torecv) + + ! Share ghost particles in -y (ghosts need to be sent now) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(2).lt.this%cfg%jmin_+no) nsend=nsend+1 + end do + do n=1,this%ng_ + if (this%g(n)%ind(2).lt.this%cfg%jmin_+no) nsend=nsend+1 + end do + allocate(tosend(nsend)) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(2).lt.this%cfg%jmin_+no) then + nsend=nsend+1 + tosend(nsend)=this%p(n) + if (this%cfg%yper.and.tosend(nsend)%ind(2).lt.this%cfg%jmin+no) then + tosend(nsend)%pos(2)=tosend(nsend)%pos(2)+this%cfg%yL + tosend(nsend)%ind(2)=tosend(nsend)%ind(2)+this%cfg%ny + end if + end if + end do + do n=1,this%ng_ + if (this%g(n)%ind(2).lt.this%cfg%jmin_+no) then + nsend=nsend+1 + tosend(nsend)=this%g(n) + if (this%cfg%yper.and.tosend(nsend)%ind(2).lt.this%cfg%jmin+no) then + tosend(nsend)%pos(2)=tosend(nsend)%pos(2)+this%cfg%yL + tosend(nsend)%ind(2)=tosend(nsend)%ind(2)+this%cfg%ny + end if + end if + end do + nrecv=0 + call MPI_CART_SHIFT(this%cfg%comm,1,-1,isrc,idst,ierr) + call MPI_SENDRECV(nsend,1,MPI_INTEGER,idst,0,nrecv,1,MPI_INTEGER,isrc,0,this%cfg%comm,status,ierr) + allocate(torecv(nrecv)) + call MPI_SENDRECV(tosend,nsend,MPI_PART,idst,0,torecv,nrecv,MPI_PART,isrc,0,this%cfg%comm,status,ierr) + call this%resize_ghost(this%ng_+nrecv) + this%g(this%ng_+1:this%ng_+nrecv)=torecv + this%ng_=this%ng_+nrecv + if (allocated(tosend)) deallocate(tosend) + if (allocated(torecv)) deallocate(torecv) + + ! Share ghost particles in +y (ghosts need to be sent now - but not newly received ghosts!) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(2).gt.this%cfg%jmax_-no) nsend=nsend+1 + end do + do n=1,this%ng_-nrecv + if (this%g(n)%ind(2).gt.this%cfg%jmax_-no) nsend=nsend+1 + end do + allocate(tosend(nsend)) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(2).gt.this%cfg%jmax_-no) then + nsend=nsend+1 + tosend(nsend)=this%p(n) + if (this%cfg%yper.and.tosend(nsend)%ind(2).gt.this%cfg%jmax-no) then + tosend(nsend)%pos(2)=tosend(nsend)%pos(2)-this%cfg%yL + tosend(nsend)%ind(2)=tosend(nsend)%ind(2)-this%cfg%ny + end if + end if + end do + do n=1,this%ng_-nrecv + if (this%g(n)%ind(2).gt.this%cfg%jmax_-no) then + nsend=nsend+1 + tosend(nsend)=this%g(n) + if (this%cfg%yper.and.tosend(nsend)%ind(2).gt.this%cfg%jmax-no) then + tosend(nsend)%pos(2)=tosend(nsend)%pos(2)-this%cfg%yL + tosend(nsend)%ind(2)=tosend(nsend)%ind(2)-this%cfg%ny + end if + end if + end do + nrecv=0 + call MPI_CART_SHIFT(this%cfg%comm,1,+1,isrc,idst,ierr) + call MPI_SENDRECV(nsend,1,MPI_INTEGER,idst,0,nrecv,1,MPI_INTEGER,isrc,0,this%cfg%comm,status,ierr) + allocate(torecv(nrecv)) + call MPI_SENDRECV(tosend,nsend,MPI_PART,idst,0,torecv,nrecv,MPI_PART,isrc,0,this%cfg%comm,status,ierr) + call this%resize_ghost(this%ng_+nrecv) + this%g(this%ng_+1:this%ng_+nrecv)=torecv + this%ng_=this%ng_+nrecv + if (allocated(tosend)) deallocate(tosend) + if (allocated(torecv)) deallocate(torecv) + + ! Share ghost particles in -z (ghosts need to be sent now) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(3).lt.this%cfg%kmin_+no) nsend=nsend+1 + end do + do n=1,this%ng_ + if (this%g(n)%ind(3).lt.this%cfg%kmin_+no) nsend=nsend+1 + end do + allocate(tosend(nsend)) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(3).lt.this%cfg%kmin_+no) then + nsend=nsend+1 + tosend(nsend)=this%p(n) + if (this%cfg%zper.and.tosend(nsend)%ind(3).lt.this%cfg%kmin+no) then + tosend(nsend)%pos(3)=tosend(nsend)%pos(3)+this%cfg%zL + tosend(nsend)%ind(3)=tosend(nsend)%ind(3)+this%cfg%nz + end if + end if + end do + do n=1,this%ng_ + if (this%g(n)%ind(3).lt.this%cfg%kmin_+no) then + nsend=nsend+1 + tosend(nsend)=this%g(n) + if (this%cfg%zper.and.tosend(nsend)%ind(3).lt.this%cfg%kmin+no) then + tosend(nsend)%pos(3)=tosend(nsend)%pos(3)+this%cfg%zL + tosend(nsend)%ind(3)=tosend(nsend)%ind(3)+this%cfg%nz + end if + end if + end do + nrecv=0 + call MPI_CART_SHIFT(this%cfg%comm,2,-1,isrc,idst,ierr) + call MPI_SENDRECV(nsend,1,MPI_INTEGER,idst,0,nrecv,1,MPI_INTEGER,isrc,0,this%cfg%comm,status,ierr) + allocate(torecv(nrecv)) + call MPI_SENDRECV(tosend,nsend,MPI_PART,idst,0,torecv,nrecv,MPI_PART,isrc,0,this%cfg%comm,status,ierr) + call this%resize_ghost(this%ng_+nrecv) + this%g(this%ng_+1:this%ng_+nrecv)=torecv + this%ng_=this%ng_+nrecv + if (allocated(tosend)) deallocate(tosend) + if (allocated(torecv)) deallocate(torecv) + + ! Share ghost particles in +z (ghosts need to be sent now - but not newly received ghosts!) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(3).gt.this%cfg%kmax_-no) nsend=nsend+1 + end do + do n=1,this%ng_-nrecv + if (this%g(n)%ind(3).gt.this%cfg%kmax_-no) nsend=nsend+1 + end do + allocate(tosend(nsend)) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(3).gt.this%cfg%kmax_-no) then + nsend=nsend+1 + tosend(nsend)=this%p(n) + if (this%cfg%zper.and.tosend(nsend)%ind(3).gt.this%cfg%kmax-no) then + tosend(nsend)%pos(3)=tosend(nsend)%pos(3)-this%cfg%zL + tosend(nsend)%ind(3)=tosend(nsend)%ind(3)-this%cfg%nz + end if + end if + end do + do n=1,this%ng_-nrecv + if (this%g(n)%ind(3).gt.this%cfg%kmax_-no) then + nsend=nsend+1 + tosend(nsend)=this%g(n) + if (this%cfg%zper.and.tosend(nsend)%ind(3).gt.this%cfg%kmax-no) then + tosend(nsend)%pos(3)=tosend(nsend)%pos(3)-this%cfg%zL + tosend(nsend)%ind(3)=tosend(nsend)%ind(3)-this%cfg%nz + end if + end if + end do + nrecv=0 + call MPI_CART_SHIFT(this%cfg%comm,2,+1,isrc,idst,ierr) + call MPI_SENDRECV(nsend,1,MPI_INTEGER,idst,0,nrecv,1,MPI_INTEGER,isrc,0,this%cfg%comm,status,ierr) + allocate(torecv(nrecv)) + call MPI_SENDRECV(tosend,nsend,MPI_PART,idst,0,torecv,nrecv,MPI_PART,isrc,0,this%cfg%comm,status,ierr) + call this%resize_ghost(this%ng_+nrecv) + this%g(this%ng_+1:this%ng_+nrecv)=torecv + this%ng_=this%ng_+nrecv + if (allocated(tosend)) deallocate(tosend) + if (allocated(torecv)) deallocate(torecv) + + end subroutine share + + + !> Synchronize particle arrays across processors + subroutine sync(this) + use mpi_f08 + implicit none + class(lss), intent(inout) :: this + integer, dimension(0:this%cfg%nproc-1) :: nsend_proc,nrecv_proc + integer, dimension(0:this%cfg%nproc-1) :: nsend_disp,nrecv_disp + integer :: n,prank,ierr + type(part), dimension(:), allocatable :: buf_send + ! Recycle first to minimize communication load + call this%recycle() + ! Prepare information about what to send + nsend_proc=0 + do n=1,this%np_ + prank=this%cfg%get_rank(this%p(n)%ind) + nsend_proc(prank)=nsend_proc(prank)+1 + end do + nsend_proc(this%cfg%rank)=0 + ! Inform processors of what they will receive + call MPI_ALLtoALL(nsend_proc,1,MPI_INTEGER,nrecv_proc,1,MPI_INTEGER,this%cfg%comm,ierr) + ! Prepare displacements for all-to-all + nsend_disp(0)=0 + nrecv_disp(0)=this%np_ !< Directly add particles at the end of main array + do n=1,this%cfg%nproc-1 + nsend_disp(n)=nsend_disp(n-1)+nsend_proc(n-1) + nrecv_disp(n)=nrecv_disp(n-1)+nrecv_proc(n-1) + end do + ! Allocate buffer to send particles + allocate(buf_send(sum(nsend_proc))) + ! Pack the particles in the send buffer + nsend_proc=0 + do n=1,this%np_ + ! Get the rank + prank=this%cfg%get_rank(this%p(n)%ind) + ! Skip particles still inside + if (prank.eq.this%cfg%rank) cycle + ! Pack up for sending + nsend_proc(prank)=nsend_proc(prank)+1 + buf_send(nsend_disp(prank)+nsend_proc(prank))=this%p(n) + ! Flag particle for removal + this%p(n)%flag=1 + end do + ! Allocate buffer for receiving particles + call this%resize(this%np_+sum(nrecv_proc)) + ! Perform communication + call MPI_ALLtoALLv(buf_send,nsend_proc,nsend_disp,MPI_PART,this%p,nrecv_proc,nrecv_disp,MPI_PART,this%cfg%comm,ierr) + ! Deallocate buffer + deallocate(buf_send) + ! Recycle to remove duplicate particles + call this%recycle() + end subroutine sync + + + !> Adaptation of particle array size + subroutine resize(this,n) + implicit none + class(lss), intent(inout) :: this + integer, intent(in) :: n + type(part), dimension(:), allocatable :: tmp + integer :: size_now,size_new + ! Resize particle array to size n + if (.not.allocated(this%p)) then + ! Allocate directly to size n + allocate(this%p(n)) + this%p(1:n)%flag=1 + else + ! Update from a non-zero size to another non-zero size + size_now=size(this%p,dim=1) + if (n.gt.size_now) then + size_new=max(n,int(real(size_now,WP)*coeff_up)) + allocate(tmp(size_new)) + tmp(1:size_now)=this%p + tmp(size_now+1:)%flag=1 + call move_alloc(tmp,this%p) + else if (n.lt.int(real(size_now,WP)*coeff_dn)) then + allocate(tmp(n)) + tmp(1:n)=this%p(1:n) + call move_alloc(tmp,this%p) + end if + end if + end subroutine resize + + + !> Adaptation of ghost array size + subroutine resize_ghost(this,n) + implicit none + class(lss), intent(inout) :: this + integer, intent(in) :: n + type(part), dimension(:), allocatable :: tmp + integer :: size_now,size_new + ! Resize ghost array to size n + if (.not.allocated(this%g)) then + ! Allocate directly to size n + allocate(this%g(n)) + this%g(1:n)%flag=1 + else + ! Update from a non-zero size to another non-zero size + size_now=size(this%g,dim=1) + if (n.gt.size_now) then + size_new=max(n,int(real(size_now,WP)*coeff_up)) + allocate(tmp(size_new)) + tmp(1:size_now)=this%g + tmp(size_now+1:)%flag=1 + call move_alloc(tmp,this%g) + else if (n.lt.int(real(size_now,WP)*coeff_dn)) then + allocate(tmp(n)) + tmp(1:n)=this%g(1:n) + call move_alloc(tmp,this%g) + end if + end if + end subroutine resize_ghost + + + !> Clean-up of particle array by removing flag=1 particles + subroutine recycle(this) + implicit none + class(lss), intent(inout) :: this + integer :: new_size,i,ierr + ! Compact all active particles at the beginning of the array + new_size=0 + if (allocated(this%p)) then + do i=1,size(this%p,dim=1) + if (this%p(i)%flag.ne.1) then + new_size=new_size+1 + if (i.ne.new_size) then + this%p(new_size)=this%p(i) + this%p(i)%flag=1 + end if + end if + end do + end if + ! Resize to new size + call this%resize(new_size) + ! Update number of particles + this%np_=new_size + call MPI_ALLGATHER(this%np_,1,MPI_INTEGER,this%np_proc,1,MPI_INTEGER,this%cfg%comm,ierr) + this%np=sum(this%np_proc) + end subroutine recycle + + + !> Parallel write particles to file + subroutine write(this,filename) + use mpi_f08 + use messager, only: die + use parallel, only: info_mpiio + implicit none + class(lss), intent(inout) :: this + character(len=*), intent(in) :: filename + type(MPI_File) :: ifile + type(MPI_Status):: status + integer(kind=MPI_OFFSET_KIND) :: offset + integer :: i,ierr,iunit + + ! Root serial-writes the file header + if (this%cfg%amRoot) then + ! Open the file + open(newunit=iunit,file=trim(filename),form='unformatted',status='replace',access='stream',iostat=ierr) + if (ierr.ne.0) call die('[lss write] Problem encountered while serial-opening data file: '//trim(filename)) + ! Number of particles and particle object size + write(iunit) this%np,MPI_PART_SIZE + ! Done with the header + close(iunit) + end if + + ! The rest is done in parallel + call MPI_FILE_OPEN(this%cfg%comm,trim(filename),IOR(MPI_MODE_WRONLY,MPI_MODE_APPEND),info_mpiio,ifile,ierr) + if (ierr.ne.0) call die('[lss write] Problem encountered while parallel-opening data file: '//trim(filename)) + + ! Get current position + call MPI_FILE_GET_POSITION(ifile,offset,ierr) + + ! Compute the offset and write + do i=1,this%cfg%rank + offset=offset+int(this%np_proc(i),MPI_OFFSET_KIND)*int(MPI_PART_SIZE,MPI_OFFSET_KIND) + end do + if (this%np_.gt.0) call MPI_FILE_WRITE_AT(ifile,offset,this%p,this%np_,MPI_PART,status,ierr) + + ! Close the file + call MPI_FILE_CLOSE(ifile,ierr) + + ! Log/screen output + logging: block + use, intrinsic :: iso_fortran_env, only: output_unit + use param, only: verbose + use messager, only: log + use string, only: str_long + character(len=str_long) :: message + if (this%cfg%amRoot) then + write(message,'("[lss write] Wrote ",i0," particles to file [",a,"] on partitioned grid [",a,"]")') this%np,trim(filename),trim(this%cfg%name) + if (verbose.gt.2) write(output_unit,'(a)') trim(message) + if (verbose.gt.1) call log(message) + end if + end block logging + + end subroutine write + + + !> Parallel read particles to file + subroutine read(this,filename) + use mpi_f08 + use messager, only: die + use parallel, only: info_mpiio + implicit none + class(lss), intent(inout) :: this + character(len=*), intent(in) :: filename + type(MPI_File) :: ifile + type(MPI_Status):: status + integer(kind=MPI_OFFSET_KIND) :: offset,header_offset + integer :: i,j,ierr,npadd,psize,nchunk,cnt + integer, dimension(:,:), allocatable :: ppp + + ! First open the file in parallel + call MPI_FILE_OPEN(this%cfg%comm,trim(filename),MPI_MODE_RDONLY,info_mpiio,ifile,ierr) + if (ierr.ne.0) call die('[lss read] Problem encountered while reading data file: '//trim(filename)) + + ! Read file header first + call MPI_FILE_READ_ALL(ifile,npadd,1,MPI_INTEGER,status,ierr) + call MPI_FILE_READ_ALL(ifile,psize,1,MPI_INTEGER,status,ierr) + + ! Remember current position + call MPI_FILE_GET_POSITION(ifile,header_offset,ierr) + + ! Check compatibility of particle type + if (psize.ne.MPI_PART_SIZE) call die('[lss read] Particle type unreadable') + + ! Naively share reading task among all processors + nchunk=int(npadd/(this%cfg%nproc*part_chunk_size))+1 + allocate(ppp(this%cfg%nproc,nchunk)) + ppp=int(npadd/(this%cfg%nproc*nchunk)) + cnt=0 + out:do j=1,nchunk + do i=1,this%cfg%nproc + cnt=cnt+1 + if (cnt.gt.mod(npadd,this%cfg%nproc*nchunk)) exit out + ppp(i,j)=ppp(i,j)+1 + end do + end do out + + ! Read by chunk + do j=1,nchunk + ! Find offset + offset=header_offset+int(MPI_PART_SIZE,MPI_OFFSET_KIND)*int(sum(ppp(1:this%cfg%rank,:))+sum(ppp(this%cfg%rank+1,1:j-1)),MPI_OFFSET_KIND) + ! Resize particle array + call this%resize(this%np_+ppp(this%cfg%rank+1,j)) + ! Read this file + call MPI_FILE_READ_AT(ifile,offset,this%p(this%np_+1:this%np_+ppp(this%cfg%rank+1,j)),ppp(this%cfg%rank+1,j),MPI_PART,status,ierr) + ! Most general case: relocate every droplet + do i=this%np_+1,this%np_+ppp(this%cfg%rank+1,j) + this%p(i)%ind=this%cfg%get_ijk_global(this%p(i)%pos,this%p(i)%ind) + end do + ! Exchange all that + call this%sync() + end do + + ! Close the file + call MPI_FILE_CLOSE(ifile,ierr) + + ! Log/screen output + logging: block + use, intrinsic :: iso_fortran_env, only: output_unit + use param, only: verbose + use messager, only: log + use string, only: str_long + character(len=str_long) :: message + if (this%cfg%amRoot) then + write(message,'("[lss read] Read ",i0," particles from file [",a,"] on partitioned grid [",a,"]")') npadd,trim(filename),trim(this%cfg%name) + if (verbose.gt.2) write(output_unit,'(a)') trim(message) + if (verbose.gt.1) call log(message) + end if + end block logging + + end subroutine read + + +end module lss_class diff --git a/examples/beam_tension/src/lss_class_stl.f90 b/examples/beam_tension/src/lss_class_stl.f90 new file mode 100644 index 000000000..584855c36 --- /dev/null +++ b/examples/beam_tension/src/lss_class_stl.f90 @@ -0,0 +1,1636 @@ +!> Lagrangian solid solver object +!> Implements peridynamics equations +module lss_class + use precision, only: WP + use string, only: str_medium + use config_class, only: config + use mpi_f08, only: MPI_Datatype,MPI_INTEGER8,MPI_INTEGER,MPI_DOUBLE_PRECISION + implicit none + private + + + ! Expose type/constructor/methods + public :: lss + + + !> Memory adaptation parameter + real(WP), parameter :: coeff_up=1.3_WP !< Particle array size increase factor + real(WP), parameter :: coeff_dn=0.7_WP !< Particle array size decrease factor + + + !> I/O chunk size to read at a time + integer, parameter :: part_chunk_size=1000 !< Read 1000 particles at a time before redistributing + + + !> Maximum number of bonds per particle + integer, parameter, public :: max_bond=400 !< Assumes something like a 7x7x7 stencil in 3D + + + !> Bonded solid particle definition + type :: part + !> MPI_DOUBLE_PRECISION data + real(WP) :: mw !< Weighted volume + real(WP) :: dil !< Element dilatation + real(WP) :: ste !< Element dilatation + real(WP) :: vol !< Particle volume + real(WP), dimension(max_bond) :: dbond !< Length of initial bonds + real(WP), dimension(3) :: pos !< Particle center coordinates + real(WP), dimension(3) :: vel !< Velocity of particle + real(WP), dimension(3) :: Abond !< Bond acceleration for particle + real(WP), dimension(3) :: Afluid !< Fluid acceleration for particle + real(WP), dimension(3) :: gd !< Dilitation corrections + real(WP), dimension(3) :: gb !< Shear corrections + !> MPI_INTEGER data + integer :: id !< ID the object is associated with + integer :: i !< Unique index of particle (assumed >0) + integer :: nbond !< Number of initial bonds + integer, dimension(max_bond) :: ibond !< Indices of initially bonded particles (0 values ignored) + integer , dimension(3) :: ind !< Index of cell containing particle center + integer :: flag !< Control parameter (0=normal, 1=done->will be removed) + end type part + !> Number of blocks, block length, and block types in a particle + integer, parameter :: part_nblock=2 + integer , dimension(part_nblock) :: part_lblock=[22+max_bond,7+max_bond] + type(MPI_Datatype), dimension(part_nblock) :: part_tblock=[MPI_DOUBLE_PRECISION,MPI_INTEGER] + !> MPI_PART derived datatype and size + type(MPI_Datatype) :: MPI_PART + integer :: MPI_PART_SIZE + + + !> Lagrangian solid solver object definition + type :: lss + + ! This config is used for parallelization and for calculating bond/collision forces + class(config), pointer :: cfg + + ! This is the name of the solver + character(len=str_medium) :: name='UNNAMED_LSS' + + ! Solid material properties + real(WP) :: elastic_modulus !< Elastic modulus of the material + real(WP) :: poisson_ratio !< Poisson's ratio of the material + real(WP) :: rho !< Density of the material + real(WP) :: crit_energy !< Critical energy release + + ! Bonding parameters + real(WP) :: delta !< Bonding horizon (distance) + real(WP) :: min_dist !< Minimum bonding distance + integer :: nb !< Cell-based horizon + + ! Global and local particle data + integer :: np !< Global number of particles + integer :: np_ !< Local number of particles + integer, dimension(:), allocatable :: np_proc !< Number of particles on each processor + type(part), dimension(:), allocatable :: p !< Array of particles of type part + + ! Overlap particle (i.e., ghost) data + integer :: ng_ !< Local number of ghosts + type(part), dimension(:), allocatable :: g !< Array of ghosts of type part + + ! Gravitational acceleration + real(WP), dimension(3) :: gravity=[0.0_WP,0.0_WP,0.0_WP] + + ! Solid volume fraction and momentum + real(WP), dimension(:,:,:), allocatable :: VF !< Volume fraction, cell-centered + real(WP), dimension(:,:,:), allocatable :: VFU !< Solid velocity, U-face + real(WP), dimension(:,:,:), allocatable :: VFV !< Solid velocity, V-face + real(WP), dimension(:,:,:), allocatable :: VFW !< Solid velocity, W-face + + ! CFL numbers + real(WP) :: CFLp_x,CFLp_y,CFLp_z,CFLp_a + + ! Number of substeps for time integrator + real(WP) :: nstep=1 + + ! Monitoring info + real(WP) :: Umin,Umax,Umean !< U velocity info + real(WP) :: Vmin,Vmax,Vmean !< V velocity info + real(WP) :: Wmin,Wmax,Wmean !< W velocity info + real(WP) :: VFmax !< Volume fraction info + real(WP), dimension(3) :: ibmForce !< Total force due to IBM + integer :: np_out !< Number of particles leaving the domain + + contains + procedure :: bond_init !< Setup initial interparticle bonds + procedure :: get_bond_force !< Compute interparticle bond force + procedure :: advance !< Step forward the particle ODEs + procedure :: get_cfl !< Calculate maximum CFL + procedure :: get_max !< Extract various monitoring data + procedure :: update_partmesh !< Update a partmesh object using current particles + procedure :: share !< Share particles across interprocessor boundaries + procedure :: sync !< Synchronize particles across interprocessor boundaries + procedure :: resize !< Resize particle array to given size + procedure :: resize_ghost !< Resize ghost array to given size + procedure :: recycle !< Recycle particle array by removing flagged particles + procedure :: write !< Parallel write particles to file + procedure :: read !< Parallel read particles from file + procedure :: update_VF !< Compute volume fraction + procedure :: get_delta !< Compute regularized delta function + procedure :: interpolate !< Interpolation routine from mesh=>marker + procedure :: extrapolate !< Extrapolation routine from marker=>mesh + procedure :: stretch + end type lss + + + !> Declare lss constructor + interface lss + procedure constructor + end interface lss + +contains + + + ! Quasi-Gaussian weighting function - h is the cut-off + real(WP) function wgauss(d,h) + implicit none + real(WP), intent(in) :: d,h + real(WP), parameter :: coeff=2.6_WP + real(WP) :: hh + hh=coeff*h + if (d.ge.hh) then + wgauss=0.0_WP + else + wgauss=(1.0_WP+4.0_WP*d/hh)*(1.0_WP-d/hh)**4 + end if + end function wgauss + + + !> Default constructor for Lagrangian solid solver + function constructor(cfg,name) result(self) + implicit none + type(lss) :: self + class(config), target, intent(in) :: cfg + character(len=*), optional :: name + integer :: i,j,k + + ! Set the name for the solver + if (present(name)) self%name=trim(adjustl(name)) + + ! Point to pgrid object + self%cfg=>cfg + + ! Set default bonding horizon based on underlying mesh + self%delta=self%cfg%min_meshsize + self%nb=1 + self%min_dist=huge(1.0_WP) + + ! Allocate variables + allocate(self%np_proc(1:self%cfg%nproc)); self%np_proc=0 + self%np_=0; self%np=0 + call self%resize(0) + + ! Initialize MPI derived datatype for a particle + call prepare_mpi_part() + + ! Allocate VF array on cfg mesh + allocate(self%VF(self%cfg%imino_:self%cfg%imaxo_,self%cfg%jmino_:self%cfg%jmaxo_,self%cfg%kmino_:self%cfg%kmaxo_)); self%VF=0.0_WP + allocate(self%VFU(self%cfg%imino_:self%cfg%imaxo_,self%cfg%jmino_:self%cfg%jmaxo_,self%cfg%kmino_:self%cfg%kmaxo_)); self%VFU=0.0_WP + allocate(self%VFV(self%cfg%imino_:self%cfg%imaxo_,self%cfg%jmino_:self%cfg%jmaxo_,self%cfg%kmino_:self%cfg%kmaxo_)); self%VFV=0.0_WP + allocate(self%VFW(self%cfg%imino_:self%cfg%imaxo_,self%cfg%jmino_:self%cfg%jmaxo_,self%cfg%kmino_:self%cfg%kmaxo_)); self%VFW=0.0_WP + + ! Log/screen output + logging: block + use, intrinsic :: iso_fortran_env, only: output_unit + use param, only: verbose + use messager, only: log + use string, only: str_long + character(len=str_long) :: message + if (self%cfg%amRoot) then + write(message,'("LSS object [",a,"] on partitioned grid [",a,"]")') trim(self%name),trim(self%cfg%name) + if (verbose.gt.1) write(output_unit,'(a)') trim(message) + if (verbose.gt.0) call log(message) + end if + end block logging + + end function constructor + + + !> Initialize bond force between particles + subroutine bond_init(this) + use messager, only: die + implicit none + class(lss), intent(inout) :: this + integer, dimension(:,:,:), allocatable :: npic !< Number of particle in cell + integer, dimension(:,:,:,:), allocatable :: ipic !< Index of particle in cell + + ! Communicate particles in ghost cells + call this%share() + + ! We can now assemble particle-in-cell information + pic_prep: block + use mpi_f08 + integer :: i,ip,jp,kp,ierr + integer :: mymax_npic,max_npic + + ! Allocate number of particle in cell + allocate(npic(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)); npic=0 + + ! Count particles and ghosts per cell + do i=1,this%np_ + ip=this%p(i)%ind(1); jp=this%p(i)%ind(2); kp=this%p(i)%ind(3) + npic(ip,jp,kp)=npic(ip,jp,kp)+1 + end do + do i=1,this%ng_ + ip=this%g(i)%ind(1); jp=this%g(i)%ind(2); kp=this%g(i)%ind(3) + npic(ip,jp,kp)=npic(ip,jp,kp)+1 + end do + + ! Get maximum number of particle in cell + mymax_npic=maxval(npic); call MPI_ALLREDUCE(mymax_npic,max_npic,1,MPI_INTEGER,MPI_MAX,this%cfg%comm,ierr) + + ! Allocate pic map + allocate(ipic(1:max_npic,this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)); ipic=0 + + ! Assemble pic map + npic=0 + do i=1,this%np_ + ip=this%p(i)%ind(1); jp=this%p(i)%ind(2); kp=this%p(i)%ind(3) + npic(ip,jp,kp)=npic(ip,jp,kp)+1 + ipic(npic(ip,jp,kp),ip,jp,kp)=+i + end do + do i=1,this%ng_ + ip=this%g(i)%ind(1); jp=this%g(i)%ind(2); kp=this%g(i)%ind(3) + npic(ip,jp,kp)=npic(ip,jp,kp)+1 + ipic(npic(ip,jp,kp),ip,jp,kp)=-i + end do + + end block pic_prep + + ! Establish initial bonds + create_bonds: block + use mpi_f08, only: MPI_ALLREDUCE,MPI_MIN,MPI_IN_PLACE + use parallel, only: MPI_REAL_WP + use mathtools, only: Pi + integer :: i,j,k,n1,nn,n2,ierr + type(part) :: p1,p2 + real(WP), dimension(3) :: rpos + real(WP) :: dist + ! Reset minimum bond distance + this%min_dist=huge(1.0_WP) + ! Loop over particles + do n1=1,this%np_ + ! Create copy of our particle + p1=this%p(n1) + ! Zero out weighted volume + p1%mw=0.0_WP + ! Zero out bonds + p1%ibond=0 + p1%nbond=0 + ! Loop over neighbor cells + do k=p1%ind(3)-this%nb,p1%ind(3)+this%nb + do j=p1%ind(2)-this%nb,p1%ind(2)+this%nb + do i=p1%ind(1)-this%nb,p1%ind(1)+this%nb + ! Loop over particles in that cell + do nn=1,npic(i,j,k) + ! Create copy of our neighbor + n2=ipic(nn,i,j,k) + if (n2.gt.0) then + p2=this%p(+n2) + else if (n2.lt.0) then + p2=this%g(-n2) + end if + ! Cannot self-bond + if (p1%i.eq.p2%i) cycle + ! Cannot bond with different id except <=0 (<=0 bonds with everyone) + if (p1%id.ne.p2%id.and.p1%id.ge.0.and.p2%id.ge.0) cycle + ! Check interparticle distance + rpos=p2%pos-p1%pos + dist=sqrt(dot_product(rpos,rpos)) + if (dist.lt.this%delta) then + ! This particle is in horizon, create a bond + p1%nbond=p1%nbond+1 + if (p1%nbond.gt.max_bond) call die('[lss_class bond_init] Number of detected bonds is larger than max allowed') + p1%ibond(p1%nbond)=p2%i + p1%dbond(p1%nbond)=dist + ! Increment weighted volume + p1%mw=p1%mw+wgauss(dist,this%delta)*dist**2*p1%vol + ! Determine minimum bond distance + this%min_dist=min(this%min_dist,dist) + end if + end do + end do + end do + end do + ! Zero out initial dilatation + p1%dil=0.0_WP + ! Copy back the particle + this%p(n1)=p1 + end do + ! Get global minimum + call MPI_ALLREDUCE(MPI_IN_PLACE,this%min_dist,1,MPI_REAL_WP,MPI_MIN,this%cfg%comm,ierr) + end block create_bonds + + ! Clean up + if (allocated(npic)) deallocate(npic) + if (allocated(ipic)) deallocate(ipic) + + end subroutine bond_init + + + !> Calculate bond force between particles + subroutine get_bond_force(this) + implicit none + class(lss), intent(inout) :: this + integer, dimension(:,:,:), allocatable :: npic !< Number of particle in cell + integer, dimension(:,:,:,:), allocatable :: ipic !< Index of particle in cell + logical :: is2D + + ! Need to modify parameters in 2D + is2D=this%cfg%nx.eq.1.or.this%cfg%ny.eq.1.or.this%cfg%nz.eq.1 + + ! Communicate particles in ghost cells + call this%share() + + ! We can now assemble particle-in-cell information + pic_prep: block + use mpi_f08 + integer :: i,ip,jp,kp,ierr + integer :: mymax_npic,max_npic + + ! Allocate number of particle in cell + allocate(npic(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)); npic=0 + + ! Count particles and ghosts per cell + do i=1,this%np_ + ip=this%p(i)%ind(1); jp=this%p(i)%ind(2); kp=this%p(i)%ind(3) + npic(ip,jp,kp)=npic(ip,jp,kp)+1 + end do + do i=1,this%ng_ + ip=this%g(i)%ind(1); jp=this%g(i)%ind(2); kp=this%g(i)%ind(3) + npic(ip,jp,kp)=npic(ip,jp,kp)+1 + end do + + ! Get maximum number of particle in cell + mymax_npic=maxval(npic); call MPI_ALLREDUCE(mymax_npic,max_npic,1,MPI_INTEGER,MPI_MAX,this%cfg%comm,ierr) + + ! Allocate pic map + allocate(ipic(1:max_npic,this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)); ipic=0 + + ! Assemble pic map + npic=0 + do i=1,this%np_ + ip=this%p(i)%ind(1); jp=this%p(i)%ind(2); kp=this%p(i)%ind(3) + npic(ip,jp,kp)=npic(ip,jp,kp)+1 + ipic(npic(ip,jp,kp),ip,jp,kp)=+i + end do + do i=1,this%ng_ + ip=this%g(i)%ind(1); jp=this%g(i)%ind(2); kp=this%g(i)%ind(3) + npic(ip,jp,kp)=npic(ip,jp,kp)+1 + ipic(npic(ip,jp,kp),ip,jp,kp)=-i + end do + + end block pic_prep + + ! Update weighted volume and dilatation + update_weighted_vol_and_dilatation: block + integer :: i,j,k,n1,nn,n2 + type(part) :: p1,p2 + integer :: nb,nbond + real(WP), dimension(3) :: rpos, Gd_vec + real(WP) :: dist, Gd_mag + ! Loop over particles + do n1=1,this%np_ + ! Create copy of our particle + p1=this%p(n1) + ! Zero out weighted volume and dilatation + p1%mw=0.0_WP + p1%dil=0.0_WP + ! Loop over neighbor cells + do k=p1%ind(3)-this%nb,p1%ind(3)+this%nb + do j=p1%ind(2)-this%nb,p1%ind(2)+this%nb + do i=p1%ind(1)-this%nb,p1%ind(1)+this%nb + ! Loop over particles in that cell + do nn=1,npic(i,j,k) + ! Create copy of our neighbor + n2=ipic(nn,i,j,k) + if (n2.gt.0) then + p2=this%p(+n2) + else if (n2.lt.0) then + p2=this%g(-n2) + end if + ! Check if a bond exists + do nb=1,max_bond + if (p1%ibond(nb).eq.p2%i) then + ! Increment weighted volume + p1%mw=p1%mw+wgauss(p1%dbond(nb),this%delta)*p1%dbond(nb)**2*p2%vol + ! Get current distance + rpos=p2%pos-p1%pos + dist=sqrt(dot_product(rpos,rpos)) + ! compute average G correction for dilitation + Gd_vec = (p2%gd + p1%gd)/2.0_WP + + Gd_mag = sqrt(1.0_WP/(((rpos(1)/dist)/Gd_vec(1))**2 + ((rpos(2)/dist)/Gd_vec(2))**2 + ((rpos(3)/dist)/Gd_vec(3))**2 )) + ! Increment dilatation + p1%dil=p1%dil+wgauss(p1%dbond(nb),this%delta)*p1%dbond(nb)*(dist-p1%dbond(nb))*p2%vol*Gd_mag + end if + end do + end do + end do + end do + end do + ! Rescale dilatation + if (p1%mw.gt.epsilon(1.0_WP)) then + if (is2D) then + ! 2D plane strain + p1%dil=p1%dil*2.0_WP/p1%mw + else + ! 3D + p1%dil=p1%dil*3.0_WP/p1%mw + end if + else + p1%dil=0.0_WP + end if + ! Copy back the particle + this%p(n1)=p1 + end do + end block update_weighted_vol_and_dilatation + + ! Re-communicate particles in ghost cells to update dil and mw + call this%share() + + ! Update bond force, including collision force, and SED + update_bond_force: block + use mpi_f08, only: MPI_ALLREDUCE,MPI_MIN,MPI_IN_PLACE + use parallel, only: MPI_REAL_WP + use mathtools, only: Pi + integer :: i,j,k,n1,nn,n2,ierr + type(part) :: p1,p2 + real(WP), dimension(3) :: rpos,t12,t21,Gd_vec + real(WP) :: dist,beta,alpha,ed,t,Gd_mag + real(WP) :: stretch,max_stretch,mu,kk + real(WP) :: nc,rc,kc + integer :: nb,nbond + logical :: found_bond + ! Recompute a few physical parameters + mu=this%elastic_modulus/(2.0_WP+2.0_WP*this%poisson_ratio) + kk=this%elastic_modulus/(3.0_WP-6.0_WP*this%poisson_ratio) + if (is2D) then + if (this%cfg%nx.eq.1) t=this%cfg%xL + if (this%cfg%ny.eq.1) t=this%cfg%yL + if (this%cfg%nz.eq.1) t=this%cfg%zL + max_stretch=sqrt(this%crit_energy/((6.0_WP*mu/Pi+16.0_WP/(9.0_WP*Pi**2)*(kk-2.0_WP*mu))*this%delta)) + kc=15.0_WP*48.0_WP*this%elastic_modulus/(Pi*5.0_WP*t*this%delta**3) + else + max_stretch=sqrt(this%crit_energy/((3.0_WP*mu+(kk-5.0_WP*mu/3.0_WP)*0.75_WP**4)*this%delta)) + kc=15.0_WP*12.0_WP*this%elastic_modulus/(Pi*this%delta**4) + end if + nc=1.0_WP + this%min_dist=huge(1.0_WP) + ! Loop over particles + do n1=1,this%np_ + ! Particles marked 0 do not update their forces + if (this%p(n1)%id.eq.0) cycle + ! Create copy of our particle + p1=this%p(n1) + ! Zero out bond force + p1%Abond=0.0_WP + ! Loop over neighbor cells + do k=p1%ind(3)-this%nb,p1%ind(3)+this%nb + do j=p1%ind(2)-this%nb,p1%ind(2)+this%nb + do i=p1%ind(1)-this%nb,p1%ind(1)+this%nb + ! Loop over particles in that cell + do nn=1,npic(i,j,k) + ! Create copy of our neighbor + n2=ipic(nn,i,j,k) + if (n2.gt.0) then + p2=this%p(+n2) + else if (n2.lt.0) then + p2=this%g(-n2) + end if + ! Current distance + rpos=p2%pos-p1%pos + dist=sqrt(dot_product(rpos,rpos)) + ! Check if a bond exists + found_bond=.false. + do nb=1,max_bond + if (p1%ibond(nb).eq.p2%i) then + ! Check for breakage first + stretch=(dist-p1%dbond(nb))/p1%dbond(nb) + if (stretch.gt.max_stretch) then + ! Remove the bond and flag as surface particle + p1%ibond(nb)=0 + p1%dbond(nb)=0.0_WP + cycle + end if + ! Particle 1 + if (is2D) then + ! 2D plane strain + beta = 2.0_WP * kk * p1%dil + alpha = 8.0_WP * mu / p1%mw + ed = dist - p1%dbond(nb) * (1.0_WP + p1%dil / 2.0_WP) + else + ! 3D + beta = 3.0_WP * kk * p1%dil + alpha = 15.0_WP * mu / p1%mw + ed = dist - p1%dbond(nb) * (1.0_WP + p1%dil / 3.0_WP) + end if + ! Force density 1->2 + ! t12=+wgauss(p1%dbond(nb),this%delta)*(beta/p1%mw*p1%dbond(nb)+alpha*ed)*rpos/dist + Gd_vec = (p2%gd + p1%gd)/2.0_WP + + Gd_mag = sqrt(1.0_WP/(((rpos(1)/dist)/Gd_vec(1))**2 + ((rpos(2)/dist)/Gd_vec(2))**2 + ((rpos(3)/dist)/Gd_vec(3))**2 )) + t12=+wgauss(p1%dbond(nb),this%delta)*((3.0_WP*kk - 15.0_WP*mu/3.0_WP)*(Gd_mag*p1%dil*p1%dbond(nb)/p1%mw) + (15.0_WP*mu/p1%mw)*(dist - p1%dbond(nb)) )*rpos/dist + ! Particle 2 + if (is2D) then + ! 2D plane strain + beta = 2.0_WP * kk * p2%dil + alpha = 8.0_WP * mu / p2%mw + ed = dist - p1%dbond(nb) * (1.0_WP + p2%dil / 2.0_WP) + else + ! 3D + beta = 3.0_WP * kk * p2%dil + alpha = 15.0_WP * mu / p2%mw + ed = dist - p1%dbond(nb) * (1.0_WP + p2%dil / 3.0_WP) + end if + ! Force density 2->1 + ! t21=-wgauss(p1%dbond(nb),this%delta)*(beta/p2%mw*p1%dbond(nb)+alpha*ed)*rpos/dist + t21=-wgauss(p1%dbond(nb),this%delta)*((3.0_WP*kk - 15.0_WP*mu/3.0_WP)*(Gd_mag*p2%dil*p1%dbond(nb)/p2%mw)+ (15.0_WP*mu/p2%mw)*(dist - p1%dbond(nb)) )*rpos/dist ! Increment bond force + p1%Abond=p1%Abond+(t12-t21)*p2%vol/this%rho + ! Incremend SED + p1%ste=p1%ste+alpha/2.0_WP*(wgauss(p1%dbond(nb),this%delta)*((dist-p1%dbond(nb)))*p2%vol) + ! If still here, we have an active bond + found_bond=.true. + ! Determine minimum bond distance + this%min_dist=min(this%min_dist,dist) + cycle + end if + end do + ! Add collision force now + ! if (is2D) then + ! rc=p1%vol**(1.0_WP/2.0_WP) + ! else + ! rc=p1%vol**(1.0_WP/3.0_WP) + ! end if + ! if (.not.found_bond.and.p1%i.ne.p2%i.and.dist.lt.rc) then + ! p1%Abond=p1%Abond-max(kc*((rc/dist)**nc-1.0_WP),0.0_WP)*(rpos/dist)*p1%vol/this%rho + ! p1%flag = -2 + ! end if + end do + end do + end do + end do + ! Deal with dimensionality + if (this%cfg%nx.eq.1) p1%Abond(1)=0.0_WP + if (this%cfg%ny.eq.1) p1%Abond(2)=0.0_WP + if (this%cfg%nz.eq.1) p1%Abond(3)=0.0_WP + ! Copy back the particle + this%p(n1)=p1 + end do + ! Get global minimum + call MPI_ALLREDUCE(MPI_IN_PLACE,this%min_dist,1,MPI_REAL_WP,MPI_MIN,this%cfg%comm,ierr) + end block update_bond_force + + ! Clean up + if (allocated(npic)) deallocate(npic) + if (allocated(ipic)) deallocate(ipic) + + end subroutine get_bond_force + + + !> Advance the particle equations by a specified time step dt + !> p%id=-2 => do not solve for position nor velocity + !> p%id=-1 => do not solve for velocity + !> p%id= 0 => do not update force + + subroutine advance(this,dt)!,stress_x,stress_y,stress_z) + use mpi_f08, only : MPI_SUM,MPI_INTEGER,MPI_IN_PLACE + use mathtools, only: Pi + implicit none + class(lss), intent(inout) :: this + real(WP), intent(inout) :: dt !< Timestep size over which to advance + ! real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(inout) :: stress_x !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + ! real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(inout) :: stress_y !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + ! real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(inout) :: stress_z !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + integer :: n,ierr + ! real(WP), dimension(3) :: stress + + ! Zero out number of particles removed + this%np_out=0 + + ! Advance velocity based on old force and position based on mid-velocity + do n=1,this%np_ + ! Advance with Verlet scheme + if (this%p(n)%id.gt.-1) this%p(n)%vel=this%p(n)%vel+0.5_WP*dt*(this%gravity+this%p(n)%Abond+this%p(n)%Afluid) + if (this%p(n)%id.gt.-2) this%p(n)%pos=this%p(n)%pos+dt*this%p(n)%vel + ! Relocalize + this%p(n)%ind=this%cfg%get_ijk_global(this%p(n)%pos,this%p(n)%ind) + ! Correct the position to take into account periodicity + if (this%cfg%xper) this%p(n)%pos(1)=this%cfg%x(this%cfg%imin)+modulo(this%p(n)%pos(1)-this%cfg%x(this%cfg%imin),this%cfg%xL) + if (this%cfg%yper) this%p(n)%pos(2)=this%cfg%y(this%cfg%jmin)+modulo(this%p(n)%pos(2)-this%cfg%y(this%cfg%jmin),this%cfg%yL) + if (this%cfg%zper) this%p(n)%pos(3)=this%cfg%z(this%cfg%kmin)+modulo(this%p(n)%pos(3)-this%cfg%z(this%cfg%kmin),this%cfg%zL) + ! Handle particles that have left the domain + if (this%p(n)%pos(1).lt.this%cfg%x(this%cfg%imin).or.this%p(n)%pos(1).gt.this%cfg%x(this%cfg%imax+1)) this%p(n)%flag=1 + if (this%p(n)%pos(2).lt.this%cfg%y(this%cfg%jmin).or.this%p(n)%pos(2).gt.this%cfg%y(this%cfg%jmax+1)) this%p(n)%flag=1 + if (this%p(n)%pos(3).lt.this%cfg%z(this%cfg%kmin).or.this%p(n)%pos(3).gt.this%cfg%z(this%cfg%kmax+1)) this%p(n)%flag=1 + ! Relocalize the particle + this%p(n)%ind=this%cfg%get_ijk_global(this%p(n)%pos,this%p(n)%ind) + ! Count number of particles removed + if (this%p(n)%flag.eq.1) this%np_out=this%np_out+1 + end do + + ! Communicate particles + call this%sync() + + ! Sum up particles removed + call MPI_ALLREDUCE(this%np_out,n,1,MPI_INTEGER,MPI_SUM,this%cfg%comm,ierr); this%np_out=n + + ! Calculate bond force + call this%get_bond_force() + + ! Advance velocity only based on new force + do n=1,this%np_ + ! Advance with Verlet scheme + if (this%p(n)%id.le.-1) cycle + ! stress=this%cfg%get_velocity(pos=this%p(n)%pos,i0=this%p(n)%ind(1),j0=this%p(n)%ind(2),k0=this%p(n)%ind(3),U=stress_x,V=stress_y,W=stress_z) + ! this%p(n)%Afluid=stress/this%rho + this%p(n)%Afluid=0.0_WP + this%p(n)%vel=this%p(n)%vel+0.5_WP*dt*(this%gravity+this%p(n)%Abond+this%p(n)%Afluid) + end do + + ! Recompute volume fraction + ! call this%update_VF() + + ! Log/screen output + logging: block + use, intrinsic :: iso_fortran_env, only: output_unit + use param, only: verbose + use messager, only: log + use string, only: str_long + character(len=str_long) :: message + if (this%cfg%amRoot) then + write(message,'("Particle solver [",a,"] on partitioned grid [",a,"]: ",i0," particles were advanced")') trim(this%name),trim(this%cfg%name),this%np + if (verbose.gt.1) write(output_unit,'(a)') trim(message) + if (verbose.gt.0) call log(message) + end if + end block logging + + end subroutine advance + + subroutine stretch(this,dt)!,stress_x,stress_y,stress_z) + use mpi_f08, only : MPI_SUM,MPI_INTEGER,MPI_IN_PLACE + use mathtools, only: Pi + implicit none + class(lss), intent(inout) :: this + real(WP), intent(inout) :: dt !< Timestep size over which to advance + real(WP) :: mu + integer :: n,ierr + !======================================================================================== + ! X-Axis Stretch: + ! Zero out number of particles removed + this%np_out=0 + do n=1,this%np_ + ! Stretch the beam along the x axis with a uniform strain-rate of 0.001 + if (this%p(n)%id.gt.-2) this%p(n)%pos(1)=this%p(n)%pos(1)*1.001_WP + end do + + ! Communicate particles + call this%sync() + + ! Calculate bond force + call this%get_bond_force() + + mu=this%elastic_modulus/(2.0_WP+2.0_WP*this%poisson_ratio) + + do n=1,this%np_ + if (this%p(n)%id.gt.-2) this%p(n)%gd(1)=0.001_WP/this%p(n)%dil + end do + + !======================================================================================== + ! Y-Axis Stretch: + ! Zero out number of particles removed + this%np_out=0 + do n=1,this%np_ + ! Stretch the beam along the x axis with a uniform strain-rate of 0.001 + if (this%p(n)%id.gt.-2) this%p(n)%pos(1)=this%p(n)%pos(1)/1.001_WP + if (this%p(n)%id.gt.-2) this%p(n)%pos(2)=this%p(n)%pos(2)*1.001_WP + end do + + ! Communicate particles + call this%sync() + + ! Calculate bond force + call this%get_bond_force() + + mu=this%elastic_modulus/(2.0_WP+2.0_WP*this%poisson_ratio) + + do n=1,this%np_ + if (this%p(n)%id.gt.-2) this%p(n)%gd(2)=0.001_WP/this%p(n)%dil + end do + + !======================================================================================== + ! Z-Axis Stretch: + ! Zero out number of particles removed + this%np_out=0 + do n=1,this%np_ + ! Stretch the beam along the x axis with a uniform strain-rate of 0.001 + if (this%p(n)%id.gt.-2) this%p(n)%pos(2)=this%p(n)%pos(2)/1.001_WP + if (this%p(n)%id.gt.-2) this%p(n)%pos(3)=this%p(n)%pos(3)*1.001_WP + end do + + ! Communicate particles + call this%sync() + + ! Calculate bond force + call this%get_bond_force() + + mu=this%elastic_modulus/(2.0_WP+2.0_WP*this%poisson_ratio) + + do n=1,this%np_ + if (this%p(n)%id.gt.-2) this%p(n)%gd(3)=0.001_WP/this%p(n)%dil + end do + + ! Put the particle back where it was + do n=1,this%np_ + if (this%p(n)%id.gt.-2) this%p(n)%pos(3)=this%p(n)%pos(3)/1.001_WP + end do + + !====================================================================================== + + ! Now stretch particle for the first time step + + do n=1,this%np_ + ! Stretch the beam along the x axis with a uniform strain-rate of 0.001 + if (this%p(n)%id.gt.-2) this%p(n)%pos(1)=this%p(n)%pos(1)*1.001_WP + end do + + ! Communicate particles + call this%sync() + + ! Calculate bond force + call this%get_bond_force() + + + + + end subroutine stretch + + subroutine get_correction_coeffs(this,dt)!,stress_x,stress_y,stress_z) + use mpi_f08, only : MPI_SUM,MPI_INTEGER,MPI_IN_PLACE + use mathtools, only: Pi + implicit none + class(lss), intent(inout) :: this + real(WP), intent(inout) :: dt !< Timestep size over which to advance + real(WP) :: mu + integer :: n,ierr + ! Zero out number of particles removed + this%np_out=0 + do n=1,this%np_ + ! Stretch the beam along the x axis with a uniform strain-rate of 0.001 + if (this%p(n)%id.gt.-2) this%p(n)%pos(1)=this%p(n)%pos(1) + this%p(n)%pos(1)*0.001_WP + ! Relocalize + this%p(n)%ind=this%cfg%get_ijk_global(this%p(n)%pos,this%p(n)%ind) + ! Correct the position to take into account periodicity + if (this%cfg%xper) this%p(n)%pos(1)=this%cfg%x(this%cfg%imin)+modulo(this%p(n)%pos(1)-this%cfg%x(this%cfg%imin),this%cfg%xL) + if (this%cfg%yper) this%p(n)%pos(2)=this%cfg%y(this%cfg%jmin)+modulo(this%p(n)%pos(2)-this%cfg%y(this%cfg%jmin),this%cfg%yL) + if (this%cfg%zper) this%p(n)%pos(3)=this%cfg%z(this%cfg%kmin)+modulo(this%p(n)%pos(3)-this%cfg%z(this%cfg%kmin),this%cfg%zL) + ! Handle particles that have left the domain + if (this%p(n)%pos(1).lt.this%cfg%x(this%cfg%imin).or.this%p(n)%pos(1).gt.this%cfg%x(this%cfg%imax+1)) this%p(n)%flag=1 + if (this%p(n)%pos(2).lt.this%cfg%y(this%cfg%jmin).or.this%p(n)%pos(2).gt.this%cfg%y(this%cfg%jmax+1)) this%p(n)%flag=1 + if (this%p(n)%pos(3).lt.this%cfg%z(this%cfg%kmin).or.this%p(n)%pos(3).gt.this%cfg%z(this%cfg%kmax+1)) this%p(n)%flag=1 + ! Relocalize the particle + this%p(n)%ind=this%cfg%get_ijk_global(this%p(n)%pos,this%p(n)%ind) + ! Count number of particles removed + end do + + ! Communicate particles + call this%sync() + + ! Sum up particles removed + call MPI_ALLREDUCE(this%np_out,n,1,MPI_INTEGER,MPI_SUM,this%cfg%comm,ierr); this%np_out=n + + ! Calculate bond force + call this%get_bond_force() + + mu=this%elastic_modulus/(2.0_WP+2.0_WP*this%poisson_ratio) + + do n=1,this%np_ + this%p(n)%gd=0.001_WP/this%p(n)%dil + this%p(n)%Gb=0.5_WP*mu*(0.001_WP*0.001_WP)/this%p(n)%ste + end do + + ! Log/screen output + logging: block + use, intrinsic :: iso_fortran_env, only: output_unit + use param, only: verbose + use messager, only: log + use string, only: str_long + character(len=str_long) :: message + if (this%cfg%amRoot) then + write(message,'("Particle solver [",a,"] on partitioned grid [",a,"]: ",i0," particles were advanced")') trim(this%name),trim(this%cfg%name),this%np + if (verbose.gt.1) write(output_unit,'(a)') trim(message) + if (verbose.gt.0) call log(message) + end if + end block logging + + end subroutine get_correction_coeffs + + + !> Update particle volume fraction using our current particles + subroutine update_VF(this) + implicit none + class(lss), intent(inout) :: this + integer :: i + ! Reset volume fraction and momentum + this%VF=0.0_WP; this%VFU=0.0_WP; this%VFV=0.0_WP; this%VFW=0.0_WP + ! Transfer particle volume + do i=1,this%np_ + ! Skip inactive particle + if (this%p(i)%flag.eq.1) cycle + ! Transfer volume to mesh + call this%extrapolate(Ap=this%p(i)%vol,xp=this%p(i)%pos(1),yp=this%p(i)%pos(2),zp=this%p(i)%pos(3),ip=this%p(i)%ind(1),jp=this%p(i)%ind(2),kp=this%p(i)%ind(3),A=this%VF,dir='SC') + call this%extrapolate(Ap=this%p(i)%vol*this%p(i)%vel(1),xp=this%p(i)%pos(1),yp=this%p(i)%pos(2),zp=this%p(i)%pos(3),ip=this%p(i)%ind(1),jp=this%p(i)%ind(2),kp=this%p(i)%ind(3),A=this%VFU,dir='U') + call this%extrapolate(Ap=this%p(i)%vol*this%p(i)%vel(2),xp=this%p(i)%pos(1),yp=this%p(i)%pos(2),zp=this%p(i)%pos(3),ip=this%p(i)%ind(1),jp=this%p(i)%ind(2),kp=this%p(i)%ind(3),A=this%VFV,dir='V') + call this%extrapolate(Ap=this%p(i)%vol*this%p(i)%vel(3),xp=this%p(i)%pos(1),yp=this%p(i)%pos(2),zp=this%p(i)%pos(3),ip=this%p(i)%ind(1),jp=this%p(i)%ind(2),kp=this%p(i)%ind(3),A=this%VFW,dir='W') + end do + ! Sum at boundaries + call this%cfg%syncsum(this%VF) + call this%cfg%syncsum(this%VFU) + call this%cfg%syncsum(this%VFV) + call this%cfg%syncsum(this%VFW) + ! Clip + where (this%VF.gt.1.0_WP) this%VF=1.0_WP + where (this%VF.lt.0.0_WP) this%VF=0.0_WP + end subroutine update_VF + + + !> Compute regularized delta function + subroutine get_delta(this,delta,ic,jc,kc,xp,yp,zp,dir) + implicit none + class(lss), intent(inout) :: this + real(WP), intent(out) :: delta !< Return delta function + integer, intent(in) :: ic,jc,kc !< Cell index + real(WP), intent(in) :: xp,yp,zp !< Position of marker + character(len=*) :: dir + real(WP) :: deltax,deltay,deltaz,r + + ! Compute in X + if (trim(adjustl(dir)).eq.'U') then + r=(xp-this%cfg%x(ic))*this%cfg%dxmi(ic) + deltax=roma_kernel(r)*this%cfg%dxmi(ic) + else + r=(xp-this%cfg%xm(ic))*this%cfg%dxi(ic) + deltax=roma_kernel(r)*this%cfg%dxi(ic) + end if + + ! Compute in Y + if (trim(adjustl(dir)).eq.'V') then + r=(yp-this%cfg%y(jc))*this%cfg%dymi(jc) + deltay=roma_kernel(r)*this%cfg%dymi(jc) + else + r=(yp-this%cfg%ym(jc))*this%cfg%dyi(jc) + deltay=roma_kernel(r)*this%cfg%dyi(jc) + end if + + ! Compute in Z + if (trim(adjustl(dir)).eq.'W') then + r=(zp-this%cfg%z(kc))*this%cfg%dzmi(kc) + deltaz=roma_kernel(r)*this%cfg%dzmi(kc) + else + r=(zp-this%cfg%zm(kc))*this%cfg%dzi(kc) + deltaz=roma_kernel(r)*this%cfg%dzi(kc) + end if + !else + + ! Put it all together + delta=deltax*deltay*deltaz + + contains + ! Mollification kernel + ! Roma A, Peskin C and Berger M 1999 J. Comput. Phys. 153 509–534 + function roma_kernel(r) result(phi) + implicit none + real(WP), intent(in) :: r + real(WP) :: phi + if (abs(r).le.0.5_WP) then + phi=1.0_WP/3.0_WP*(1.0_WP+sqrt(-3.0_WP*r**2+1.0_WP)) + else if (abs(r).gt.0.5_WP .and. abs(r).le.1.5_WP) then + phi=1.0_WP/6.0_WP*(5.0_WP-3.0_WP*abs(r)-sqrt(-3.0_WP*(1.0_WP-abs(r))**2+1.0_WP)) + else + phi=0.0_WP + end if + end function roma_kernel + + end subroutine get_delta + + + !> Interpolation routine + function interpolate(this,A,xp,yp,zp,ip,jp,kp,dir) result(Ap) + implicit none + class(lss), intent(inout) :: this + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(in) :: A !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + real(WP), intent(in) :: xp,yp,zp + integer, intent(in) :: ip,jp,kp + character(len=*) :: dir + real(WP) :: Ap + integer :: di,dj,dk + integer :: i1,i2,j1,j2,k1,k2 + real(WP), dimension(-2:+2,-2:+2,-2:+2) :: delta + ! Get the interpolation points + i1=ip-2; i2=ip+2 + j1=jp-2; j2=jp+2 + k1=kp-2; k2=kp+2 + ! Loop over neighboring cells and compute regularized delta function + do dk=-2,+2 + do dj=-2,+2 + do di=-2,+2 + call this%get_delta(delta=delta(di,dj,dk),ic=ip+di,jc=jp+dj,kc=kp+dk,xp=xp,yp=yp,zp=zp,dir=trim(dir)) + end do + end do + end do + ! Perform the actual interpolation on Ap + Ap = sum(delta*A(i1:i2,j1:j2,k1:k2))*this%cfg%vol(ip,jp,kp) + end function interpolate + + + !> Extrapolation routine + subroutine extrapolate(this,Ap,xp,yp,zp,ip,jp,kp,A,dir) + use messager, only: die + implicit none + class(lss), intent(inout) :: this + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:) :: A !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + real(WP), intent(in) :: xp,yp,zp + integer, intent(in) :: ip,jp,kp + real(WP), intent(in) :: Ap + character(len=*) :: dir + real(WP), dimension(-2:+2,-2:+2,-2:+2) :: delta + integer :: di,dj,dk + ! If particle has left processor domain or reached last ghost cell, kill job + if ( ip.lt.this%cfg%imin_-1.or.ip.gt.this%cfg%imax_+1.or.& + & jp.lt.this%cfg%jmin_-1.or.jp.gt.this%cfg%jmax_+1.or.& + & kp.lt.this%cfg%kmin_-1.or.kp.gt.this%cfg%kmax_+1) then + write(*,*) ip,jp,kp,xp,yp,zp + call die('[df extrapolate] Particle has left the domain') + end if + ! Loop over neighboring cells and compute regularized delta function + do dk=-2,+2 + do dj=-2,+2 + do di=-2,+2 + call this%get_delta(delta=delta(di,dj,dk),ic=ip+di,jc=jp+dj,kc=kp+dk,xp=xp,yp=yp,zp=zp,dir=trim(dir)) + end do + end do + end do + ! Perform the actual extrapolation on A + A(ip-2:ip+2,jp-2:jp+2,kp-2:kp+2)=A(ip-2:ip+2,jp-2:jp+2,kp-2:kp+2)+delta*Ap + end subroutine extrapolate + + + !> Calculate the CFL + subroutine get_cfl(this,dt,cfl) + use mpi_f08, only: MPI_ALLREDUCE,MPI_MAX + use parallel, only: MPI_REAL_WP + implicit none + class(lss), intent(inout) :: this + real(WP), intent(in) :: dt + real(WP), intent(out) :: cfl + integer :: i,ierr + real(WP) :: my_CFLp_x,my_CFLp_y,my_CFLp_z,kk,mu,a + + ! Set the CFLs to zero + my_CFLp_x=0.0_WP; my_CFLp_y=0.0_WP; my_CFLp_z=0.0_WP + do i=1,this%np_ + my_CFLp_x=max(my_CFLp_x,abs(this%p(i)%vel(1))*this%cfg%dxi(this%p(i)%ind(1))) + my_CFLp_y=max(my_CFLp_y,abs(this%p(i)%vel(2))*this%cfg%dyi(this%p(i)%ind(2))) + my_CFLp_z=max(my_CFLp_z,abs(this%p(i)%vel(3))*this%cfg%dzi(this%p(i)%ind(3))) + end do + my_CFLp_x=my_CFLp_x*dt; my_CFLp_y=my_CFLp_y*dt; my_CFLp_z=my_CFLp_z*dt + + ! Get the parallel max + call MPI_ALLREDUCE(my_CFLp_x,this%CFLp_x,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + call MPI_ALLREDUCE(my_CFLp_y,this%CFLp_y,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + call MPI_ALLREDUCE(my_CFLp_z,this%CFLp_z,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + + ! CFL based on elastic wave speed in material + kk=this%elastic_modulus/(3.0_WP-6.0_WP*this%poisson_ratio) + mu=this%elastic_modulus/(2.0_WP+2.0_WP*this%poisson_ratio) + a=sqrt((kk+4.0_WP*mu/3.0_WP)/this%rho) + this%CFLp_a=dt*a*3/this%delta + + ! Return the maximum CFL + cfl=max(this%CFLp_x,this%CFLp_y,this%CFLp_z,this%CFLp_a) + + end subroutine get_cfl + + + !> Extract various monitoring data from particle field + subroutine get_max(this) + use mpi_f08, only: MPI_ALLREDUCE,MPI_MAX,MPI_MIN,MPI_SUM + use parallel, only: MPI_REAL_WP + implicit none + class(lss), intent(inout) :: this + real(WP) :: buf,safe_np + real(WP), dimension(3) :: buf3D + integer :: i,j,k,ierr + + ! Create safe np + safe_np=real(max(this%np,1),WP) + + ! Velocity min/max/mean + this%Umin=huge(1.0_WP); this%Umax=-huge(1.0_WP); this%Umean=0.0_WP + this%Vmin=huge(1.0_WP); this%Vmax=-huge(1.0_WP); this%Vmean=0.0_WP + this%Wmin=huge(1.0_WP); this%Wmax=-huge(1.0_WP); this%Wmean=0.0_WP + this%ibmForce=0.0_WP + do i=1,this%np_ + this%Umin=min(this%Umin,this%p(i)%vel(1)); this%Umax=max(this%Umax,this%p(i)%vel(1)); this%Umean=this%Umean+this%p(i)%vel(1) + this%Vmin=min(this%Vmin,this%p(i)%vel(2)); this%Vmax=max(this%Vmax,this%p(i)%vel(2)); this%Vmean=this%Vmean+this%p(i)%vel(2) + this%Wmin=min(this%Wmin,this%p(i)%vel(3)); this%Wmax=max(this%Wmax,this%p(i)%vel(3)); this%Wmean=this%Wmean+this%p(i)%vel(3) + this%ibmForce=this%ibmForce+this%p(i)%Afluid*this%p(i)%vol*this%rho + end do + call MPI_ALLREDUCE(this%Umin ,buf,1,MPI_REAL_WP,MPI_MIN,this%cfg%comm,ierr); this%Umin =buf + call MPI_ALLREDUCE(this%Umax ,buf,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr); this%Umax =buf + call MPI_ALLREDUCE(this%Umean,buf,1,MPI_REAL_WP,MPI_SUM,this%cfg%comm,ierr); this%Umean=buf/safe_np + call MPI_ALLREDUCE(this%Vmin ,buf,1,MPI_REAL_WP,MPI_MIN,this%cfg%comm,ierr); this%Vmin =buf + call MPI_ALLREDUCE(this%Vmax ,buf,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr); this%Vmax =buf + call MPI_ALLREDUCE(this%Vmean,buf,1,MPI_REAL_WP,MPI_SUM,this%cfg%comm,ierr); this%Vmean=buf/safe_np + call MPI_ALLREDUCE(this%Wmin ,buf,1,MPI_REAL_WP,MPI_MIN,this%cfg%comm,ierr); this%Wmin =buf + call MPI_ALLREDUCE(this%Wmax ,buf,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr); this%Wmax =buf + call MPI_ALLREDUCE(this%Wmean,buf,1,MPI_REAL_WP,MPI_SUM,this%cfg%comm,ierr); this%Wmean=buf/safe_np + call MPI_ALLREDUCE(this%ibmForce,buf3D,3,MPI_REAL_WP,MPI_SUM,this%cfg%comm,ierr); this%ibmForce=buf3D + + ! Get max volume fraction + this%VFmax =-huge(1.0_WP) + do k=this%cfg%kmin_,this%cfg%kmax_ + do j=this%cfg%jmin_,this%cfg%jmax_ + do i=this%cfg%imin_,this%cfg%imax_ + this%VFmax=max(this%VFmax,this%VF(i,j,k)) + end do + end do + end do + call MPI_ALLREDUCE(this%VFmax,buf,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr); this%VFmax=buf + + end subroutine get_max + + + !> Update particle mesh using our current particles + subroutine update_partmesh(this,pmesh) + use partmesh_class, only: partmesh + implicit none + class(lss), intent(inout) :: this + class(partmesh), intent(inout) :: pmesh + integer :: i + ! Reset particle mesh storage + call pmesh%reset() + ! Nothing else to do if no particle is present + if (this%np_.eq.0) return + ! Copy particle info + call pmesh%set_size(this%np_) + do i=1,this%np_ + pmesh%pos(:,i)=this%p(i)%pos + end do + end subroutine update_partmesh + + + !> Creation of the MPI datatype for particle + subroutine prepare_mpi_part() + use mpi_f08 + use messager, only: die + implicit none + integer(MPI_ADDRESS_KIND), dimension(part_nblock) :: disp + integer(MPI_ADDRESS_KIND) :: lb,extent + type(MPI_Datatype) :: MPI_PART_TMP + integer :: i,mysize,ierr + ! Prepare the displacement array + disp(1)=0 + do i=2,part_nblock + call MPI_Type_size(part_tblock(i-1),mysize,ierr) + disp(i)=disp(i-1)+int(mysize,MPI_ADDRESS_KIND)*int(part_lblock(i-1),MPI_ADDRESS_KIND) + end do + ! Create and commit the new type + call MPI_Type_create_struct(part_nblock,part_lblock,disp,part_tblock,MPI_PART_TMP,ierr) + call MPI_Type_get_extent(MPI_PART_TMP,lb,extent,ierr) + call MPI_Type_create_resized(MPI_PART_TMP,lb,extent,MPI_PART,ierr) + call MPI_Type_commit(MPI_PART,ierr) + ! If a problem was encountered, say it + if (ierr.ne.0) call die('[lss prepare_mpi_part] MPI Particle type creation failed') + ! Get the size of this type + call MPI_type_size(MPI_PART,MPI_PART_SIZE,ierr) + end subroutine prepare_mpi_part + + + !> Share particles across processor boundaries + subroutine share(this,nover) + use mpi_f08 + use messager, only: warn,die + implicit none + class(lss), intent(inout) :: this + integer, optional :: nover + type(part), dimension(:), allocatable :: tosend + type(part), dimension(:), allocatable :: torecv + integer :: no,nsend,nrecv + type(MPI_Status) :: status + integer :: icnt,isrc,idst,ierr + integer :: i,n + + ! Check overlap size + if (present(nover)) then + no=nover + if (no.gt.this%cfg%no) then + call warn('[lss share] Specified overlap is larger than that of cfg - reducing no') + no=this%cfg%no + else if (no.le.0) then + call die('[lss share] Specified overlap cannot be less or equal to zero') + end if + else + no=1 + end if + + ! Clean up ghost array + call this%resize_ghost(n=0); this%ng_=0 + + ! Share ghost particles in -x (no ghosts are sent here) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(1).lt.this%cfg%imin_+no) nsend=nsend+1 + end do + allocate(tosend(nsend)) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(1).lt.this%cfg%imin_+no) then + nsend=nsend+1 + tosend(nsend)=this%p(n) + if (this%cfg%xper.and.tosend(nsend)%ind(1).lt.this%cfg%imin+no) then + tosend(nsend)%pos(1)=tosend(nsend)%pos(1)+this%cfg%xL + tosend(nsend)%ind(1)=tosend(nsend)%ind(1)+this%cfg%nx + end if + end if + end do + nrecv=0 + call MPI_CART_SHIFT(this%cfg%comm,0,-1,isrc,idst,ierr) + call MPI_SENDRECV(nsend,1,MPI_INTEGER,idst,0,nrecv,1,MPI_INTEGER,isrc,0,this%cfg%comm,status,ierr) + allocate(torecv(nrecv)) + call MPI_SENDRECV(tosend,nsend,MPI_PART,idst,0,torecv,nrecv,MPI_PART,isrc,0,this%cfg%comm,status,ierr) + call this%resize_ghost(this%ng_+nrecv) + this%g(this%ng_+1:this%ng_+nrecv)=torecv + this%ng_=this%ng_+nrecv + if (allocated(tosend)) deallocate(tosend) + if (allocated(torecv)) deallocate(torecv) + + ! Share ghost particles in +x (no ghosts are sent here) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(1).gt.this%cfg%imax_-no) nsend=nsend+1 + end do + allocate(tosend(nsend)) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(1).gt.this%cfg%imax_-no) then + nsend=nsend+1 + tosend(nsend)=this%p(n) + if (this%cfg%xper.and.tosend(nsend)%ind(1).gt.this%cfg%imax-no) then + tosend(nsend)%pos(1)=tosend(nsend)%pos(1)-this%cfg%xL + tosend(nsend)%ind(1)=tosend(nsend)%ind(1)-this%cfg%nx + end if + end if + end do + nrecv=0 + call MPI_CART_SHIFT(this%cfg%comm,0,+1,isrc,idst,ierr) + call MPI_SENDRECV(nsend,1,MPI_INTEGER,idst,0,nrecv,1,MPI_INTEGER,isrc,0,this%cfg%comm,status,ierr) + allocate(torecv(nrecv)) + call MPI_SENDRECV(tosend,nsend,MPI_PART,idst,0,torecv,nrecv,MPI_PART,isrc,0,this%cfg%comm,status,ierr) + call this%resize_ghost(this%ng_+nrecv) + this%g(this%ng_+1:this%ng_+nrecv)=torecv + this%ng_=this%ng_+nrecv + if (allocated(tosend)) deallocate(tosend) + if (allocated(torecv)) deallocate(torecv) + + ! Share ghost particles in -y (ghosts need to be sent now) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(2).lt.this%cfg%jmin_+no) nsend=nsend+1 + end do + do n=1,this%ng_ + if (this%g(n)%ind(2).lt.this%cfg%jmin_+no) nsend=nsend+1 + end do + allocate(tosend(nsend)) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(2).lt.this%cfg%jmin_+no) then + nsend=nsend+1 + tosend(nsend)=this%p(n) + if (this%cfg%yper.and.tosend(nsend)%ind(2).lt.this%cfg%jmin+no) then + tosend(nsend)%pos(2)=tosend(nsend)%pos(2)+this%cfg%yL + tosend(nsend)%ind(2)=tosend(nsend)%ind(2)+this%cfg%ny + end if + end if + end do + do n=1,this%ng_ + if (this%g(n)%ind(2).lt.this%cfg%jmin_+no) then + nsend=nsend+1 + tosend(nsend)=this%g(n) + if (this%cfg%yper.and.tosend(nsend)%ind(2).lt.this%cfg%jmin+no) then + tosend(nsend)%pos(2)=tosend(nsend)%pos(2)+this%cfg%yL + tosend(nsend)%ind(2)=tosend(nsend)%ind(2)+this%cfg%ny + end if + end if + end do + nrecv=0 + call MPI_CART_SHIFT(this%cfg%comm,1,-1,isrc,idst,ierr) + call MPI_SENDRECV(nsend,1,MPI_INTEGER,idst,0,nrecv,1,MPI_INTEGER,isrc,0,this%cfg%comm,status,ierr) + allocate(torecv(nrecv)) + call MPI_SENDRECV(tosend,nsend,MPI_PART,idst,0,torecv,nrecv,MPI_PART,isrc,0,this%cfg%comm,status,ierr) + call this%resize_ghost(this%ng_+nrecv) + this%g(this%ng_+1:this%ng_+nrecv)=torecv + this%ng_=this%ng_+nrecv + if (allocated(tosend)) deallocate(tosend) + if (allocated(torecv)) deallocate(torecv) + + ! Share ghost particles in +y (ghosts need to be sent now - but not newly received ghosts!) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(2).gt.this%cfg%jmax_-no) nsend=nsend+1 + end do + do n=1,this%ng_-nrecv + if (this%g(n)%ind(2).gt.this%cfg%jmax_-no) nsend=nsend+1 + end do + allocate(tosend(nsend)) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(2).gt.this%cfg%jmax_-no) then + nsend=nsend+1 + tosend(nsend)=this%p(n) + if (this%cfg%yper.and.tosend(nsend)%ind(2).gt.this%cfg%jmax-no) then + tosend(nsend)%pos(2)=tosend(nsend)%pos(2)-this%cfg%yL + tosend(nsend)%ind(2)=tosend(nsend)%ind(2)-this%cfg%ny + end if + end if + end do + do n=1,this%ng_-nrecv + if (this%g(n)%ind(2).gt.this%cfg%jmax_-no) then + nsend=nsend+1 + tosend(nsend)=this%g(n) + if (this%cfg%yper.and.tosend(nsend)%ind(2).gt.this%cfg%jmax-no) then + tosend(nsend)%pos(2)=tosend(nsend)%pos(2)-this%cfg%yL + tosend(nsend)%ind(2)=tosend(nsend)%ind(2)-this%cfg%ny + end if + end if + end do + nrecv=0 + call MPI_CART_SHIFT(this%cfg%comm,1,+1,isrc,idst,ierr) + call MPI_SENDRECV(nsend,1,MPI_INTEGER,idst,0,nrecv,1,MPI_INTEGER,isrc,0,this%cfg%comm,status,ierr) + allocate(torecv(nrecv)) + call MPI_SENDRECV(tosend,nsend,MPI_PART,idst,0,torecv,nrecv,MPI_PART,isrc,0,this%cfg%comm,status,ierr) + call this%resize_ghost(this%ng_+nrecv) + this%g(this%ng_+1:this%ng_+nrecv)=torecv + this%ng_=this%ng_+nrecv + if (allocated(tosend)) deallocate(tosend) + if (allocated(torecv)) deallocate(torecv) + + ! Share ghost particles in -z (ghosts need to be sent now) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(3).lt.this%cfg%kmin_+no) nsend=nsend+1 + end do + do n=1,this%ng_ + if (this%g(n)%ind(3).lt.this%cfg%kmin_+no) nsend=nsend+1 + end do + allocate(tosend(nsend)) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(3).lt.this%cfg%kmin_+no) then + nsend=nsend+1 + tosend(nsend)=this%p(n) + if (this%cfg%zper.and.tosend(nsend)%ind(3).lt.this%cfg%kmin+no) then + tosend(nsend)%pos(3)=tosend(nsend)%pos(3)+this%cfg%zL + tosend(nsend)%ind(3)=tosend(nsend)%ind(3)+this%cfg%nz + end if + end if + end do + do n=1,this%ng_ + if (this%g(n)%ind(3).lt.this%cfg%kmin_+no) then + nsend=nsend+1 + tosend(nsend)=this%g(n) + if (this%cfg%zper.and.tosend(nsend)%ind(3).lt.this%cfg%kmin+no) then + tosend(nsend)%pos(3)=tosend(nsend)%pos(3)+this%cfg%zL + tosend(nsend)%ind(3)=tosend(nsend)%ind(3)+this%cfg%nz + end if + end if + end do + nrecv=0 + call MPI_CART_SHIFT(this%cfg%comm,2,-1,isrc,idst,ierr) + call MPI_SENDRECV(nsend,1,MPI_INTEGER,idst,0,nrecv,1,MPI_INTEGER,isrc,0,this%cfg%comm,status,ierr) + allocate(torecv(nrecv)) + call MPI_SENDRECV(tosend,nsend,MPI_PART,idst,0,torecv,nrecv,MPI_PART,isrc,0,this%cfg%comm,status,ierr) + call this%resize_ghost(this%ng_+nrecv) + this%g(this%ng_+1:this%ng_+nrecv)=torecv + this%ng_=this%ng_+nrecv + if (allocated(tosend)) deallocate(tosend) + if (allocated(torecv)) deallocate(torecv) + + ! Share ghost particles in +z (ghosts need to be sent now - but not newly received ghosts!) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(3).gt.this%cfg%kmax_-no) nsend=nsend+1 + end do + do n=1,this%ng_-nrecv + if (this%g(n)%ind(3).gt.this%cfg%kmax_-no) nsend=nsend+1 + end do + allocate(tosend(nsend)) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(3).gt.this%cfg%kmax_-no) then + nsend=nsend+1 + tosend(nsend)=this%p(n) + if (this%cfg%zper.and.tosend(nsend)%ind(3).gt.this%cfg%kmax-no) then + tosend(nsend)%pos(3)=tosend(nsend)%pos(3)-this%cfg%zL + tosend(nsend)%ind(3)=tosend(nsend)%ind(3)-this%cfg%nz + end if + end if + end do + do n=1,this%ng_-nrecv + if (this%g(n)%ind(3).gt.this%cfg%kmax_-no) then + nsend=nsend+1 + tosend(nsend)=this%g(n) + if (this%cfg%zper.and.tosend(nsend)%ind(3).gt.this%cfg%kmax-no) then + tosend(nsend)%pos(3)=tosend(nsend)%pos(3)-this%cfg%zL + tosend(nsend)%ind(3)=tosend(nsend)%ind(3)-this%cfg%nz + end if + end if + end do + nrecv=0 + call MPI_CART_SHIFT(this%cfg%comm,2,+1,isrc,idst,ierr) + call MPI_SENDRECV(nsend,1,MPI_INTEGER,idst,0,nrecv,1,MPI_INTEGER,isrc,0,this%cfg%comm,status,ierr) + allocate(torecv(nrecv)) + call MPI_SENDRECV(tosend,nsend,MPI_PART,idst,0,torecv,nrecv,MPI_PART,isrc,0,this%cfg%comm,status,ierr) + call this%resize_ghost(this%ng_+nrecv) + this%g(this%ng_+1:this%ng_+nrecv)=torecv + this%ng_=this%ng_+nrecv + if (allocated(tosend)) deallocate(tosend) + if (allocated(torecv)) deallocate(torecv) + + end subroutine share + + + !> Synchronize particle arrays across processors + subroutine sync(this) + use mpi_f08 + implicit none + class(lss), intent(inout) :: this + integer, dimension(0:this%cfg%nproc-1) :: nsend_proc,nrecv_proc + integer, dimension(0:this%cfg%nproc-1) :: nsend_disp,nrecv_disp + integer :: n,prank,ierr + type(part), dimension(:), allocatable :: buf_send + ! Recycle first to minimize communication load + call this%recycle() + ! Prepare information about what to send + nsend_proc=0 + do n=1,this%np_ + prank=this%cfg%get_rank(this%p(n)%ind) + nsend_proc(prank)=nsend_proc(prank)+1 + end do + nsend_proc(this%cfg%rank)=0 + ! Inform processors of what they will receive + call MPI_ALLtoALL(nsend_proc,1,MPI_INTEGER,nrecv_proc,1,MPI_INTEGER,this%cfg%comm,ierr) + ! Prepare displacements for all-to-all + nsend_disp(0)=0 + nrecv_disp(0)=this%np_ !< Directly add particles at the end of main array + do n=1,this%cfg%nproc-1 + nsend_disp(n)=nsend_disp(n-1)+nsend_proc(n-1) + nrecv_disp(n)=nrecv_disp(n-1)+nrecv_proc(n-1) + end do + ! Allocate buffer to send particles + allocate(buf_send(sum(nsend_proc))) + ! Pack the particles in the send buffer + nsend_proc=0 + do n=1,this%np_ + ! Get the rank + prank=this%cfg%get_rank(this%p(n)%ind) + ! Skip particles still inside + if (prank.eq.this%cfg%rank) cycle + ! Pack up for sending + nsend_proc(prank)=nsend_proc(prank)+1 + buf_send(nsend_disp(prank)+nsend_proc(prank))=this%p(n) + ! Flag particle for removal + this%p(n)%flag=1 + end do + ! Allocate buffer for receiving particles + call this%resize(this%np_+sum(nrecv_proc)) + ! Perform communication + call MPI_ALLtoALLv(buf_send,nsend_proc,nsend_disp,MPI_PART,this%p,nrecv_proc,nrecv_disp,MPI_PART,this%cfg%comm,ierr) + ! Deallocate buffer + deallocate(buf_send) + ! Recycle to remove duplicate particles + call this%recycle() + end subroutine sync + + + !> Adaptation of particle array size + subroutine resize(this,n) + implicit none + class(lss), intent(inout) :: this + integer, intent(in) :: n + type(part), dimension(:), allocatable :: tmp + integer :: size_now,size_new + ! Resize particle array to size n + if (.not.allocated(this%p)) then + ! Allocate directly to size n + allocate(this%p(n)) + this%p(1:n)%flag=1 + else + ! Update from a non-zero size to another non-zero size + size_now=size(this%p,dim=1) + if (n.gt.size_now) then + size_new=max(n,int(real(size_now,WP)*coeff_up)) + allocate(tmp(size_new)) + tmp(1:size_now)=this%p + tmp(size_now+1:)%flag=1 + call move_alloc(tmp,this%p) + else if (n.lt.int(real(size_now,WP)*coeff_dn)) then + allocate(tmp(n)) + tmp(1:n)=this%p(1:n) + call move_alloc(tmp,this%p) + end if + end if + end subroutine resize + + + !> Adaptation of ghost array size + subroutine resize_ghost(this,n) + implicit none + class(lss), intent(inout) :: this + integer, intent(in) :: n + type(part), dimension(:), allocatable :: tmp + integer :: size_now,size_new + ! Resize ghost array to size n + if (.not.allocated(this%g)) then + ! Allocate directly to size n + allocate(this%g(n)) + this%g(1:n)%flag=1 + else + ! Update from a non-zero size to another non-zero size + size_now=size(this%g,dim=1) + if (n.gt.size_now) then + size_new=max(n,int(real(size_now,WP)*coeff_up)) + allocate(tmp(size_new)) + tmp(1:size_now)=this%g + tmp(size_now+1:)%flag=1 + call move_alloc(tmp,this%g) + else if (n.lt.int(real(size_now,WP)*coeff_dn)) then + allocate(tmp(n)) + tmp(1:n)=this%g(1:n) + call move_alloc(tmp,this%g) + end if + end if + end subroutine resize_ghost + + + !> Clean-up of particle array by removing flag=1 particles + subroutine recycle(this) + implicit none + class(lss), intent(inout) :: this + integer :: new_size,i,ierr + ! Compact all active particles at the beginning of the array + new_size=0 + if (allocated(this%p)) then + do i=1,size(this%p,dim=1) + if (this%p(i)%flag.ne.1) then + new_size=new_size+1 + if (i.ne.new_size) then + this%p(new_size)=this%p(i) + this%p(i)%flag=1 + end if + end if + end do + end if + ! Resize to new size + call this%resize(new_size) + ! Update number of particles + this%np_=new_size + call MPI_ALLGATHER(this%np_,1,MPI_INTEGER,this%np_proc,1,MPI_INTEGER,this%cfg%comm,ierr) + this%np=sum(this%np_proc) + end subroutine recycle + + + !> Parallel write particles to file + subroutine write(this,filename) + use mpi_f08 + use messager, only: die + use parallel, only: info_mpiio + implicit none + class(lss), intent(inout) :: this + character(len=*), intent(in) :: filename + type(MPI_File) :: ifile + type(MPI_Status):: status + integer(kind=MPI_OFFSET_KIND) :: offset + integer :: i,ierr,iunit + + ! Root serial-writes the file header + if (this%cfg%amRoot) then + ! Open the file + open(newunit=iunit,file=trim(filename),form='unformatted',status='replace',access='stream',iostat=ierr) + if (ierr.ne.0) call die('[lss write] Problem encountered while serial-opening data file: '//trim(filename)) + ! Number of particles and particle object size + write(iunit) this%np,MPI_PART_SIZE + ! Done with the header + close(iunit) + end if + + ! The rest is done in parallel + call MPI_FILE_OPEN(this%cfg%comm,trim(filename),IOR(MPI_MODE_WRONLY,MPI_MODE_APPEND),info_mpiio,ifile,ierr) + if (ierr.ne.0) call die('[lss write] Problem encountered while parallel-opening data file: '//trim(filename)) + + ! Get current position + call MPI_FILE_GET_POSITION(ifile,offset,ierr) + + ! Compute the offset and write + do i=1,this%cfg%rank + offset=offset+int(this%np_proc(i),MPI_OFFSET_KIND)*int(MPI_PART_SIZE,MPI_OFFSET_KIND) + end do + if (this%np_.gt.0) call MPI_FILE_WRITE_AT(ifile,offset,this%p,this%np_,MPI_PART,status,ierr) + + ! Close the file + call MPI_FILE_CLOSE(ifile,ierr) + + ! Log/screen output + logging: block + use, intrinsic :: iso_fortran_env, only: output_unit + use param, only: verbose + use messager, only: log + use string, only: str_long + character(len=str_long) :: message + if (this%cfg%amRoot) then + write(message,'("[lss write] Wrote ",i0," particles to file [",a,"] on partitioned grid [",a,"]")') this%np,trim(filename),trim(this%cfg%name) + if (verbose.gt.2) write(output_unit,'(a)') trim(message) + if (verbose.gt.1) call log(message) + end if + end block logging + + end subroutine write + + + !> Parallel read particles to file + subroutine read(this,filename) + use mpi_f08 + use messager, only: die + use parallel, only: info_mpiio + implicit none + class(lss), intent(inout) :: this + character(len=*), intent(in) :: filename + type(MPI_File) :: ifile + type(MPI_Status):: status + integer(kind=MPI_OFFSET_KIND) :: offset,header_offset + integer :: i,j,ierr,npadd,psize,nchunk,cnt + integer, dimension(:,:), allocatable :: ppp + + ! First open the file in parallel + call MPI_FILE_OPEN(this%cfg%comm,trim(filename),MPI_MODE_RDONLY,info_mpiio,ifile,ierr) + if (ierr.ne.0) call die('[lss read] Problem encountered while reading data file: '//trim(filename)) + + ! Read file header first + call MPI_FILE_READ_ALL(ifile,npadd,1,MPI_INTEGER,status,ierr) + call MPI_FILE_READ_ALL(ifile,psize,1,MPI_INTEGER,status,ierr) + + ! Remember current position + call MPI_FILE_GET_POSITION(ifile,header_offset,ierr) + + ! Check compatibility of particle type + if (psize.ne.MPI_PART_SIZE) call die('[lss read] Particle type unreadable') + + ! Naively share reading task among all processors + nchunk=int(npadd/(this%cfg%nproc*part_chunk_size))+1 + allocate(ppp(this%cfg%nproc,nchunk)) + ppp=int(npadd/(this%cfg%nproc*nchunk)) + cnt=0 + out:do j=1,nchunk + do i=1,this%cfg%nproc + cnt=cnt+1 + if (cnt.gt.mod(npadd,this%cfg%nproc*nchunk)) exit out + ppp(i,j)=ppp(i,j)+1 + end do + end do out + + ! Read by chunk + do j=1,nchunk + ! Find offset + offset=header_offset+int(MPI_PART_SIZE,MPI_OFFSET_KIND)*int(sum(ppp(1:this%cfg%rank,:))+sum(ppp(this%cfg%rank+1,1:j-1)),MPI_OFFSET_KIND) + ! Resize particle array + call this%resize(this%np_+ppp(this%cfg%rank+1,j)) + ! Read this file + call MPI_FILE_READ_AT(ifile,offset,this%p(this%np_+1:this%np_+ppp(this%cfg%rank+1,j)),ppp(this%cfg%rank+1,j),MPI_PART,status,ierr) + ! Most general case: relocate every droplet + do i=this%np_+1,this%np_+ppp(this%cfg%rank+1,j) + this%p(i)%ind=this%cfg%get_ijk_global(this%p(i)%pos,this%p(i)%ind) + end do + ! Exchange all that + call this%sync() + end do + + ! Close the file + call MPI_FILE_CLOSE(ifile,ierr) + + ! Log/screen output + logging: block + use, intrinsic :: iso_fortran_env, only: output_unit + use param, only: verbose + use messager, only: log + use string, only: str_long + character(len=str_long) :: message + if (this%cfg%amRoot) then + write(message,'("[lss read] Read ",i0," particles from file [",a,"] on partitioned grid [",a,"]")') npadd,trim(filename),trim(this%cfg%name) + if (verbose.gt.2) write(output_unit,'(a)') trim(message) + if (verbose.gt.1) call log(message) + end if + end block logging + + end subroutine read + + +end module lss_class diff --git a/examples/beam_tension/src/lss_class_working.f90 b/examples/beam_tension/src/lss_class_working.f90 new file mode 100644 index 000000000..f3a66b852 --- /dev/null +++ b/examples/beam_tension/src/lss_class_working.f90 @@ -0,0 +1,1637 @@ +!> Lagrangian solid solver object +!> Implements peridynamics equations +module lss_class + use precision, only: WP + use string, only: str_medium + use config_class, only: config + use mpi_f08, only: MPI_Datatype,MPI_INTEGER8,MPI_INTEGER,MPI_DOUBLE_PRECISION + implicit none + private + + + ! Expose type/constructor/methods + public :: lss + + + !> Memory adaptation parameter + real(WP), parameter :: coeff_up=1.3_WP !< Particle array size increase factor + real(WP), parameter :: coeff_dn=0.7_WP !< Particle array size decrease factor + + + !> I/O chunk size to read at a time + integer, parameter :: part_chunk_size=1000 !< Read 1000 particles at a time before redistributing + + + !> Maximum number of bonds per particle + integer, parameter, public :: max_bond=400 !< Assumes something like a 7x7x7 stencil in 3D + + + !> Bonded solid particle definition + type :: part + !> MPI_DOUBLE_PRECISION data + real(WP) :: mw !< Weighted volume + real(WP) :: dil !< Element dilatation + real(WP) :: ste !< Element dilatation + real(WP) :: vol !< Particle volume + real(WP), dimension(max_bond) :: dbond !< Length of initial bonds + real(WP), dimension(3) :: pos !< Particle center coordinates + real(WP), dimension(3) :: vel !< Velocity of particle + real(WP), dimension(3) :: Abond !< Bond acceleration for particle + real(WP), dimension(3) :: Afluid !< Fluid acceleration for particle + real(WP), dimension(3) :: gd !< Dilitation corrections + real(WP), dimension(3) :: gb !< Shear corrections + !> MPI_INTEGER data + integer :: id !< ID the object is associated with + integer :: i !< Unique index of particle (assumed >0) + integer :: nbond !< Number of initial bonds + integer, dimension(max_bond) :: ibond !< Indices of initially bonded particles (0 values ignored) + integer , dimension(3) :: ind !< Index of cell containing particle center + integer :: flag !< Control parameter (0=normal, 1=done->will be removed) + end type part + !> Number of blocks, block length, and block types in a particle + integer, parameter :: part_nblock=2 + integer , dimension(part_nblock) :: part_lblock=[22+max_bond,7+max_bond] + type(MPI_Datatype), dimension(part_nblock) :: part_tblock=[MPI_DOUBLE_PRECISION,MPI_INTEGER] + !> MPI_PART derived datatype and size + type(MPI_Datatype) :: MPI_PART + integer :: MPI_PART_SIZE + + + !> Lagrangian solid solver object definition + type :: lss + + ! This config is used for parallelization and for calculating bond/collision forces + class(config), pointer :: cfg + + ! This is the name of the solver + character(len=str_medium) :: name='UNNAMED_LSS' + + ! Solid material properties + real(WP) :: elastic_modulus !< Elastic modulus of the material + real(WP) :: poisson_ratio !< Poisson's ratio of the material + real(WP) :: rho !< Density of the material + real(WP) :: crit_energy !< Critical energy release + + ! Bonding parameters + real(WP) :: delta !< Bonding horizon (distance) + real(WP) :: min_dist !< Minimum bonding distance + integer :: nb !< Cell-based horizon + + ! Global and local particle data + integer :: np !< Global number of particles + integer :: np_ !< Local number of particles + integer, dimension(:), allocatable :: np_proc !< Number of particles on each processor + type(part), dimension(:), allocatable :: p !< Array of particles of type part + + ! Overlap particle (i.e., ghost) data + integer :: ng_ !< Local number of ghosts + type(part), dimension(:), allocatable :: g !< Array of ghosts of type part + + ! Gravitational acceleration + real(WP), dimension(3) :: gravity=[0.0_WP,0.0_WP,0.0_WP] + + ! Solid volume fraction and momentum + real(WP), dimension(:,:,:), allocatable :: VF !< Volume fraction, cell-centered + real(WP), dimension(:,:,:), allocatable :: VFU !< Solid velocity, U-face + real(WP), dimension(:,:,:), allocatable :: VFV !< Solid velocity, V-face + real(WP), dimension(:,:,:), allocatable :: VFW !< Solid velocity, W-face + + ! CFL numbers + real(WP) :: CFLp_x,CFLp_y,CFLp_z,CFLp_a + + ! Number of substeps for time integrator + real(WP) :: nstep=1 + + ! Monitoring info + real(WP) :: Umin,Umax,Umean !< U velocity info + real(WP) :: Vmin,Vmax,Vmean !< V velocity info + real(WP) :: Wmin,Wmax,Wmean !< W velocity info + real(WP) :: VFmax !< Volume fraction info + real(WP), dimension(3) :: ibmForce !< Total force due to IBM + integer :: np_out !< Number of particles leaving the domain + + contains + procedure :: bond_init !< Setup initial interparticle bonds + procedure :: get_bond_force !< Compute interparticle bond force + procedure :: advance !< Step forward the particle ODEs + procedure :: get_cfl !< Calculate maximum CFL + procedure :: get_max !< Extract various monitoring data + procedure :: update_partmesh !< Update a partmesh object using current particles + procedure :: share !< Share particles across interprocessor boundaries + procedure :: sync !< Synchronize particles across interprocessor boundaries + procedure :: resize !< Resize particle array to given size + procedure :: resize_ghost !< Resize ghost array to given size + procedure :: recycle !< Recycle particle array by removing flagged particles + procedure :: write !< Parallel write particles to file + procedure :: read !< Parallel read particles from file + procedure :: update_VF !< Compute volume fraction + procedure :: get_delta !< Compute regularized delta function + procedure :: interpolate !< Interpolation routine from mesh=>marker + procedure :: extrapolate !< Extrapolation routine from marker=>mesh + procedure :: stretch + end type lss + + + !> Declare lss constructor + interface lss + procedure constructor + end interface lss + +contains + + + ! Quasi-Gaussian weighting function - h is the cut-off + real(WP) function wgauss(d,h) + implicit none + real(WP), intent(in) :: d,h + real(WP), parameter :: coeff=2.6_WP + real(WP) :: hh + hh=coeff*h + if (d.ge.hh) then + wgauss=0.0_WP + else + wgauss=(1.0_WP+4.0_WP*d/hh)*(1.0_WP-d/hh)**4 + end if + end function wgauss + + + !> Default constructor for Lagrangian solid solver + function constructor(cfg,name) result(self) + implicit none + type(lss) :: self + class(config), target, intent(in) :: cfg + character(len=*), optional :: name + integer :: i,j,k + + ! Set the name for the solver + if (present(name)) self%name=trim(adjustl(name)) + + ! Point to pgrid object + self%cfg=>cfg + + ! Set default bonding horizon based on underlying mesh + self%delta=self%cfg%min_meshsize + self%nb=1 + self%min_dist=huge(1.0_WP) + + ! Allocate variables + allocate(self%np_proc(1:self%cfg%nproc)); self%np_proc=0 + self%np_=0; self%np=0 + call self%resize(0) + + ! Initialize MPI derived datatype for a particle + call prepare_mpi_part() + + ! Allocate VF array on cfg mesh + allocate(self%VF(self%cfg%imino_:self%cfg%imaxo_,self%cfg%jmino_:self%cfg%jmaxo_,self%cfg%kmino_:self%cfg%kmaxo_)); self%VF=0.0_WP + allocate(self%VFU(self%cfg%imino_:self%cfg%imaxo_,self%cfg%jmino_:self%cfg%jmaxo_,self%cfg%kmino_:self%cfg%kmaxo_)); self%VFU=0.0_WP + allocate(self%VFV(self%cfg%imino_:self%cfg%imaxo_,self%cfg%jmino_:self%cfg%jmaxo_,self%cfg%kmino_:self%cfg%kmaxo_)); self%VFV=0.0_WP + allocate(self%VFW(self%cfg%imino_:self%cfg%imaxo_,self%cfg%jmino_:self%cfg%jmaxo_,self%cfg%kmino_:self%cfg%kmaxo_)); self%VFW=0.0_WP + + ! Log/screen output + logging: block + use, intrinsic :: iso_fortran_env, only: output_unit + use param, only: verbose + use messager, only: log + use string, only: str_long + character(len=str_long) :: message + if (self%cfg%amRoot) then + write(message,'("LSS object [",a,"] on partitioned grid [",a,"]")') trim(self%name),trim(self%cfg%name) + if (verbose.gt.1) write(output_unit,'(a)') trim(message) + if (verbose.gt.0) call log(message) + end if + end block logging + + end function constructor + + + !> Initialize bond force between particles + subroutine bond_init(this) + use messager, only: die + implicit none + class(lss), intent(inout) :: this + integer, dimension(:,:,:), allocatable :: npic !< Number of particle in cell + integer, dimension(:,:,:,:), allocatable :: ipic !< Index of particle in cell + + ! Communicate particles in ghost cells + call this%share() + + ! We can now assemble particle-in-cell information + pic_prep: block + use mpi_f08 + integer :: i,ip,jp,kp,ierr + integer :: mymax_npic,max_npic + + ! Allocate number of particle in cell + allocate(npic(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)); npic=0 + + ! Count particles and ghosts per cell + do i=1,this%np_ + ip=this%p(i)%ind(1); jp=this%p(i)%ind(2); kp=this%p(i)%ind(3) + npic(ip,jp,kp)=npic(ip,jp,kp)+1 + end do + do i=1,this%ng_ + ip=this%g(i)%ind(1); jp=this%g(i)%ind(2); kp=this%g(i)%ind(3) + npic(ip,jp,kp)=npic(ip,jp,kp)+1 + end do + + ! Get maximum number of particle in cell + mymax_npic=maxval(npic); call MPI_ALLREDUCE(mymax_npic,max_npic,1,MPI_INTEGER,MPI_MAX,this%cfg%comm,ierr) + + ! Allocate pic map + allocate(ipic(1:max_npic,this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)); ipic=0 + + ! Assemble pic map + npic=0 + do i=1,this%np_ + ip=this%p(i)%ind(1); jp=this%p(i)%ind(2); kp=this%p(i)%ind(3) + npic(ip,jp,kp)=npic(ip,jp,kp)+1 + ipic(npic(ip,jp,kp),ip,jp,kp)=+i + end do + do i=1,this%ng_ + ip=this%g(i)%ind(1); jp=this%g(i)%ind(2); kp=this%g(i)%ind(3) + npic(ip,jp,kp)=npic(ip,jp,kp)+1 + ipic(npic(ip,jp,kp),ip,jp,kp)=-i + end do + + end block pic_prep + + ! Establish initial bonds + create_bonds: block + use mpi_f08, only: MPI_ALLREDUCE,MPI_MIN,MPI_IN_PLACE + use parallel, only: MPI_REAL_WP + use mathtools, only: Pi + integer :: i,j,k,n1,nn,n2,ierr + type(part) :: p1,p2 + real(WP), dimension(3) :: rpos + real(WP) :: dist + ! Reset minimum bond distance + this%min_dist=huge(1.0_WP) + ! Loop over particles + do n1=1,this%np_ + ! Create copy of our particle + p1=this%p(n1) + ! Zero out weighted volume + p1%mw=0.0_WP + ! Zero out bonds + p1%ibond=0 + p1%nbond=0 + ! Loop over neighbor cells + do k=p1%ind(3)-this%nb,p1%ind(3)+this%nb + do j=p1%ind(2)-this%nb,p1%ind(2)+this%nb + do i=p1%ind(1)-this%nb,p1%ind(1)+this%nb + ! Loop over particles in that cell + do nn=1,npic(i,j,k) + ! Create copy of our neighbor + n2=ipic(nn,i,j,k) + if (n2.gt.0) then + p2=this%p(+n2) + else if (n2.lt.0) then + p2=this%g(-n2) + end if + ! Cannot self-bond + if (p1%i.eq.p2%i) cycle + ! Cannot bond with different id except <=0 (<=0 bonds with everyone) + if (p1%id.ne.p2%id.and.p1%id.ge.0.and.p2%id.ge.0) cycle + ! Check interparticle distance + rpos=p2%pos-p1%pos + dist=sqrt(dot_product(rpos,rpos)) + if (dist.lt.this%delta) then + ! This particle is in horizon, create a bond + p1%nbond=p1%nbond+1 + if (p1%nbond.gt.max_bond) call die('[lss_class bond_init] Number of detected bonds is larger than max allowed') + p1%ibond(p1%nbond)=p2%i + p1%dbond(p1%nbond)=dist + ! Increment weighted volume + p1%mw=p1%mw+wgauss(dist,this%delta)*dist**2*p1%vol + ! Determine minimum bond distance + this%min_dist=min(this%min_dist,dist) + end if + end do + end do + end do + end do + ! Zero out initial dilatation + p1%dil=0.0_WP + ! Copy back the particle + this%p(n1)=p1 + end do + ! Get global minimum + call MPI_ALLREDUCE(MPI_IN_PLACE,this%min_dist,1,MPI_REAL_WP,MPI_MIN,this%cfg%comm,ierr) + end block create_bonds + + ! Clean up + if (allocated(npic)) deallocate(npic) + if (allocated(ipic)) deallocate(ipic) + + end subroutine bond_init + + + !> Calculate bond force between particles + subroutine get_bond_force(this) + implicit none + class(lss), intent(inout) :: this + integer, dimension(:,:,:), allocatable :: npic !< Number of particle in cell + integer, dimension(:,:,:,:), allocatable :: ipic !< Index of particle in cell + logical :: is2D + + ! Need to modify parameters in 2D + is2D=this%cfg%nx.eq.1.or.this%cfg%ny.eq.1.or.this%cfg%nz.eq.1 + + ! Communicate particles in ghost cells + call this%share() + + ! We can now assemble particle-in-cell information + pic_prep: block + use mpi_f08 + integer :: i,ip,jp,kp,ierr + integer :: mymax_npic,max_npic + + ! Allocate number of particle in cell + allocate(npic(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)); npic=0 + + ! Count particles and ghosts per cell + do i=1,this%np_ + ip=this%p(i)%ind(1); jp=this%p(i)%ind(2); kp=this%p(i)%ind(3) + npic(ip,jp,kp)=npic(ip,jp,kp)+1 + end do + do i=1,this%ng_ + ip=this%g(i)%ind(1); jp=this%g(i)%ind(2); kp=this%g(i)%ind(3) + npic(ip,jp,kp)=npic(ip,jp,kp)+1 + end do + + ! Get maximum number of particle in cell + mymax_npic=maxval(npic); call MPI_ALLREDUCE(mymax_npic,max_npic,1,MPI_INTEGER,MPI_MAX,this%cfg%comm,ierr) + + ! Allocate pic map + allocate(ipic(1:max_npic,this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)); ipic=0 + + ! Assemble pic map + npic=0 + do i=1,this%np_ + ip=this%p(i)%ind(1); jp=this%p(i)%ind(2); kp=this%p(i)%ind(3) + npic(ip,jp,kp)=npic(ip,jp,kp)+1 + ipic(npic(ip,jp,kp),ip,jp,kp)=+i + end do + do i=1,this%ng_ + ip=this%g(i)%ind(1); jp=this%g(i)%ind(2); kp=this%g(i)%ind(3) + npic(ip,jp,kp)=npic(ip,jp,kp)+1 + ipic(npic(ip,jp,kp),ip,jp,kp)=-i + end do + + end block pic_prep + + ! Update weighted volume and dilatation + update_weighted_vol_and_dilatation: block + integer :: i,j,k,n1,nn,n2 + type(part) :: p1,p2 + integer :: nb,nbond + real(WP), dimension(3) :: rpos, Gd_vec + real(WP) :: dist, Gd_mag + ! Loop over particles + do n1=1,this%np_ + ! Create copy of our particle + p1=this%p(n1) + ! Zero out weighted volume and dilatation + p1%mw=0.0_WP + p1%dil=0.0_WP + ! Loop over neighbor cells + do k=p1%ind(3)-this%nb,p1%ind(3)+this%nb + do j=p1%ind(2)-this%nb,p1%ind(2)+this%nb + do i=p1%ind(1)-this%nb,p1%ind(1)+this%nb + ! Loop over particles in that cell + do nn=1,npic(i,j,k) + ! Create copy of our neighbor + n2=ipic(nn,i,j,k) + if (n2.gt.0) then + p2=this%p(+n2) + else if (n2.lt.0) then + p2=this%g(-n2) + end if + ! Check if a bond exists + do nb=1,max_bond + if (p1%ibond(nb).eq.p2%i) then + ! Increment weighted volume + p1%mw=p1%mw+wgauss(p1%dbond(nb),this%delta)*p1%dbond(nb)**2*p2%vol + ! Get current distance + rpos=p2%pos-p1%pos + dist=sqrt(dot_product(rpos,rpos)) + ! compute average G correction for dilitation + Gd_vec = (p2%gd + p1%gd)/2.0_WP + + Gd_mag = sqrt(1.0_WP/(((rpos(1)/dist)/Gd_vec(1))**2 + ((rpos(2)/dist)/Gd_vec(2))**2 + ((rpos(3)/dist)/Gd_vec(3))**2 )) + ! Increment dilatation + p1%dil=p1%dil+wgauss(p1%dbond(nb),this%delta)*p1%dbond(nb)*(dist-p1%dbond(nb))*p2%vol*Gd_mag + end if + end do + end do + end do + end do + end do + ! Rescale dilatation + if (p1%mw.gt.epsilon(1.0_WP)) then + if (is2D) then + ! 2D plane strain + p1%dil=p1%dil*2.0_WP/p1%mw + else + ! 3D + p1%dil=p1%dil*3.0_WP/p1%mw + end if + else + p1%dil=0.0_WP + end if + ! Copy back the particle + this%p(n1)=p1 + end do + end block update_weighted_vol_and_dilatation + + ! Re-communicate particles in ghost cells to update dil and mw + call this%share() + + ! Update bond force, including collision force, and SED + update_bond_force: block + use mpi_f08, only: MPI_ALLREDUCE,MPI_MIN,MPI_IN_PLACE + use parallel, only: MPI_REAL_WP + use mathtools, only: Pi + integer :: i,j,k,n1,nn,n2,ierr + type(part) :: p1,p2 + real(WP), dimension(3) :: rpos,t12,t21,Gd_vec + real(WP) :: dist,beta,alpha,ed,t,Gd_mag + real(WP) :: stretch,max_stretch,mu,kk + real(WP) :: nc,rc,kc + integer :: nb,nbond + logical :: found_bond + ! Recompute a few physical parameters + mu=this%elastic_modulus/(2.0_WP+2.0_WP*this%poisson_ratio) + kk=this%elastic_modulus/(3.0_WP-6.0_WP*this%poisson_ratio) + if (is2D) then + if (this%cfg%nx.eq.1) t=this%cfg%xL + if (this%cfg%ny.eq.1) t=this%cfg%yL + if (this%cfg%nz.eq.1) t=this%cfg%zL + max_stretch=sqrt(this%crit_energy/((6.0_WP*mu/Pi+16.0_WP/(9.0_WP*Pi**2)*(kk-2.0_WP*mu))*this%delta)) + kc=15.0_WP*48.0_WP*this%elastic_modulus/(Pi*5.0_WP*t*this%delta**3) + else + max_stretch=sqrt(this%crit_energy/((3.0_WP*mu+(kk-5.0_WP*mu/3.0_WP)*0.75_WP**4)*this%delta)) + kc=15.0_WP*12.0_WP*this%elastic_modulus/(Pi*this%delta**4) + end if + nc=1.0_WP + this%min_dist=huge(1.0_WP) + ! Loop over particles + do n1=1,this%np_ + ! Particles marked 0 do not update their forces + if (this%p(n1)%id.eq.0) cycle + ! Create copy of our particle + p1=this%p(n1) + ! Zero out bond force + p1%Abond=0.0_WP + ! Loop over neighbor cells + do k=p1%ind(3)-this%nb,p1%ind(3)+this%nb + do j=p1%ind(2)-this%nb,p1%ind(2)+this%nb + do i=p1%ind(1)-this%nb,p1%ind(1)+this%nb + ! Loop over particles in that cell + do nn=1,npic(i,j,k) + ! Create copy of our neighbor + n2=ipic(nn,i,j,k) + if (n2.gt.0) then + p2=this%p(+n2) + else if (n2.lt.0) then + p2=this%g(-n2) + end if + ! Current distance + rpos=p2%pos-p1%pos + dist=sqrt(dot_product(rpos,rpos)) + ! Check if a bond exists + found_bond=.false. + do nb=1,max_bond + if (p1%ibond(nb).eq.p2%i) then + ! Check for breakage first + stretch=(dist-p1%dbond(nb))/p1%dbond(nb) + if (stretch.gt.max_stretch) then + ! Remove the bond and flag as surface particle + p1%ibond(nb)=0 + p1%dbond(nb)=0.0_WP + cycle + end if + ! Particle 1 + if (is2D) then + ! 2D plane strain + beta = 2.0_WP * kk * p1%dil + alpha = 8.0_WP * mu / p1%mw + ed = dist - p1%dbond(nb) * (1.0_WP + p1%dil / 2.0_WP) + else + ! 3D + beta = 3.0_WP * kk * p1%dil + alpha = 15.0_WP * mu / p1%mw + ed = dist - p1%dbond(nb) * (1.0_WP + p1%dil / 3.0_WP) + end if + ! Force density 1->2 + ! t12=+wgauss(p1%dbond(nb),this%delta)*(beta/p1%mw*p1%dbond(nb)+alpha*ed)*rpos/dist + ! t12=+wgauss(p1%dbond(nb),this%delta)*((3.0_WP*kk - 15.0_WP*mu/3.0_WP)*(p1%dil*p1%dbond(nb)/p1%mw) + 15*mu*dist/p1%mw)*rpos/dist + Gd_vec = (p2%gd + p1%gd)/2.0_WP + + Gd_mag = sqrt(1.0_WP/(((rpos(1)/dist)/Gd_vec(1))**2 + ((rpos(2)/dist)/Gd_vec(2))**2 + ((rpos(3)/dist)/Gd_vec(3))**2 )) + t12=+wgauss(p1%dbond(nb),this%delta)*((3.0_WP*kk - 15.0_WP*mu/3.0_WP)*(Gd_mag*p1%dil*p1%dbond(nb)/p1%mw) + (15.0_WP*mu/p1%mw)*(dist - p1%dbond(nb)) )*rpos/dist + ! Particle 2 + if (is2D) then + ! 2D plane strain + beta = 2.0_WP * kk * p2%dil + alpha = 8.0_WP * mu / p2%mw + ed = dist - p1%dbond(nb) * (1.0_WP + p2%dil / 2.0_WP) + else + ! 3D + beta = 3.0_WP * kk * p2%dil + alpha = 15.0_WP * mu / p2%mw + ed = dist - p1%dbond(nb) * (1.0_WP + p2%dil / 3.0_WP) + end if + ! Force density 2->1 + ! t21=-wgauss(p1%dbond(nb),this%delta)*(beta/p2%mw*p1%dbond(nb)+alpha*ed)*rpos/dist + t21=-wgauss(p1%dbond(nb),this%delta)*((3.0_WP*kk - 15.0_WP*mu/3.0_WP)*(Gd_mag*p2%dil*p1%dbond(nb)/p2%mw)+ (15.0_WP*mu/p2%mw)*(dist - p1%dbond(nb)) )*rpos/dist ! Increment bond force + p1%Abond=p1%Abond+(t12-t21)*p2%vol/this%rho + ! Incremend SED + p1%ste=p1%ste+alpha/2.0_WP*(wgauss(p1%dbond(nb),this%delta)*((dist-p1%dbond(nb)))*p2%vol) + ! If still here, we have an active bond + found_bond=.true. + ! Determine minimum bond distance + this%min_dist=min(this%min_dist,dist) + cycle + end if + end do + ! Add collision force now + ! if (is2D) then + ! rc=p1%vol**(1.0_WP/2.0_WP) + ! else + ! rc=p1%vol**(1.0_WP/3.0_WP) + ! end if + ! if (.not.found_bond.and.p1%i.ne.p2%i.and.dist.lt.rc) then + ! p1%Abond=p1%Abond-max(kc*((rc/dist)**nc-1.0_WP),0.0_WP)*(rpos/dist)*p1%vol/this%rho + ! p1%flag = -2 + ! end if + end do + end do + end do + end do + ! Deal with dimensionality + if (this%cfg%nx.eq.1) p1%Abond(1)=0.0_WP + if (this%cfg%ny.eq.1) p1%Abond(2)=0.0_WP + if (this%cfg%nz.eq.1) p1%Abond(3)=0.0_WP + ! Copy back the particle + this%p(n1)=p1 + end do + ! Get global minimum + call MPI_ALLREDUCE(MPI_IN_PLACE,this%min_dist,1,MPI_REAL_WP,MPI_MIN,this%cfg%comm,ierr) + end block update_bond_force + + ! Clean up + if (allocated(npic)) deallocate(npic) + if (allocated(ipic)) deallocate(ipic) + + end subroutine get_bond_force + + + !> Advance the particle equations by a specified time step dt + !> p%id=-2 => do not solve for position nor velocity + !> p%id=-1 => do not solve for velocity + !> p%id= 0 => do not update force + + subroutine advance(this,dt)!,stress_x,stress_y,stress_z) + use mpi_f08, only : MPI_SUM,MPI_INTEGER,MPI_IN_PLACE + use mathtools, only: Pi + implicit none + class(lss), intent(inout) :: this + real(WP), intent(inout) :: dt !< Timestep size over which to advance + ! real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(inout) :: stress_x !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + ! real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(inout) :: stress_y !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + ! real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(inout) :: stress_z !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + integer :: n,ierr + ! real(WP), dimension(3) :: stress + + ! Zero out number of particles removed + this%np_out=0 + + ! Advance velocity based on old force and position based on mid-velocity + do n=1,this%np_ + ! Advance with Verlet scheme + if (this%p(n)%id.gt.-1) this%p(n)%vel=this%p(n)%vel+0.5_WP*dt*(this%gravity+this%p(n)%Abond+this%p(n)%Afluid) + if (this%p(n)%id.gt.-2) this%p(n)%pos=this%p(n)%pos+dt*this%p(n)%vel + ! Relocalize + this%p(n)%ind=this%cfg%get_ijk_global(this%p(n)%pos,this%p(n)%ind) + ! Correct the position to take into account periodicity + if (this%cfg%xper) this%p(n)%pos(1)=this%cfg%x(this%cfg%imin)+modulo(this%p(n)%pos(1)-this%cfg%x(this%cfg%imin),this%cfg%xL) + if (this%cfg%yper) this%p(n)%pos(2)=this%cfg%y(this%cfg%jmin)+modulo(this%p(n)%pos(2)-this%cfg%y(this%cfg%jmin),this%cfg%yL) + if (this%cfg%zper) this%p(n)%pos(3)=this%cfg%z(this%cfg%kmin)+modulo(this%p(n)%pos(3)-this%cfg%z(this%cfg%kmin),this%cfg%zL) + ! Handle particles that have left the domain + if (this%p(n)%pos(1).lt.this%cfg%x(this%cfg%imin).or.this%p(n)%pos(1).gt.this%cfg%x(this%cfg%imax+1)) this%p(n)%flag=1 + if (this%p(n)%pos(2).lt.this%cfg%y(this%cfg%jmin).or.this%p(n)%pos(2).gt.this%cfg%y(this%cfg%jmax+1)) this%p(n)%flag=1 + if (this%p(n)%pos(3).lt.this%cfg%z(this%cfg%kmin).or.this%p(n)%pos(3).gt.this%cfg%z(this%cfg%kmax+1)) this%p(n)%flag=1 + ! Relocalize the particle + this%p(n)%ind=this%cfg%get_ijk_global(this%p(n)%pos,this%p(n)%ind) + ! Count number of particles removed + if (this%p(n)%flag.eq.1) this%np_out=this%np_out+1 + end do + + ! Communicate particles + call this%sync() + + ! Sum up particles removed + call MPI_ALLREDUCE(this%np_out,n,1,MPI_INTEGER,MPI_SUM,this%cfg%comm,ierr); this%np_out=n + + ! Calculate bond force + call this%get_bond_force() + + ! Advance velocity only based on new force + do n=1,this%np_ + ! Advance with Verlet scheme + if (this%p(n)%id.le.-1) cycle + ! stress=this%cfg%get_velocity(pos=this%p(n)%pos,i0=this%p(n)%ind(1),j0=this%p(n)%ind(2),k0=this%p(n)%ind(3),U=stress_x,V=stress_y,W=stress_z) + ! this%p(n)%Afluid=stress/this%rho + this%p(n)%Afluid=0.0_WP + this%p(n)%vel=this%p(n)%vel+0.5_WP*dt*(this%gravity+this%p(n)%Abond+this%p(n)%Afluid) + end do + + ! Recompute volume fraction + ! call this%update_VF() + + ! Log/screen output + logging: block + use, intrinsic :: iso_fortran_env, only: output_unit + use param, only: verbose + use messager, only: log + use string, only: str_long + character(len=str_long) :: message + if (this%cfg%amRoot) then + write(message,'("Particle solver [",a,"] on partitioned grid [",a,"]: ",i0," particles were advanced")') trim(this%name),trim(this%cfg%name),this%np + if (verbose.gt.1) write(output_unit,'(a)') trim(message) + if (verbose.gt.0) call log(message) + end if + end block logging + + end subroutine advance + + subroutine stretch(this,dt)!,stress_x,stress_y,stress_z) + use mpi_f08, only : MPI_SUM,MPI_INTEGER,MPI_IN_PLACE + use mathtools, only: Pi + implicit none + class(lss), intent(inout) :: this + real(WP), intent(inout) :: dt !< Timestep size over which to advance + real(WP) :: mu + integer :: n,ierr + !======================================================================================== + ! X-Axis Stretch: + ! Zero out number of particles removed + this%np_out=0 + do n=1,this%np_ + ! Stretch the beam along the x axis with a uniform strain-rate of 0.001 + if (this%p(n)%id.gt.-2) this%p(n)%pos(1)=this%p(n)%pos(1)*1.001_WP + end do + + ! Communicate particles + call this%sync() + + ! Calculate bond force + call this%get_bond_force() + + mu=this%elastic_modulus/(2.0_WP+2.0_WP*this%poisson_ratio) + + do n=1,this%np_ + if (this%p(n)%id.gt.-2) this%p(n)%gd(1)=0.001_WP/this%p(n)%dil + end do + + !======================================================================================== + ! Y-Axis Stretch: + ! Zero out number of particles removed + this%np_out=0 + do n=1,this%np_ + ! Stretch the beam along the x axis with a uniform strain-rate of 0.001 + if (this%p(n)%id.gt.-2) this%p(n)%pos(1)=this%p(n)%pos(1)/1.001_WP + if (this%p(n)%id.gt.-2) this%p(n)%pos(2)=this%p(n)%pos(2)*1.001_WP + end do + + ! Communicate particles + call this%sync() + + ! Calculate bond force + call this%get_bond_force() + + mu=this%elastic_modulus/(2.0_WP+2.0_WP*this%poisson_ratio) + + do n=1,this%np_ + if (this%p(n)%id.gt.-2) this%p(n)%gd(2)=0.001_WP/this%p(n)%dil + end do + + !======================================================================================== + ! Z-Axis Stretch: + ! Zero out number of particles removed + this%np_out=0 + do n=1,this%np_ + ! Stretch the beam along the x axis with a uniform strain-rate of 0.001 + if (this%p(n)%id.gt.-2) this%p(n)%pos(2)=this%p(n)%pos(2)/1.001_WP + if (this%p(n)%id.gt.-2) this%p(n)%pos(3)=this%p(n)%pos(3)*1.001_WP + end do + + ! Communicate particles + call this%sync() + + ! Calculate bond force + call this%get_bond_force() + + mu=this%elastic_modulus/(2.0_WP+2.0_WP*this%poisson_ratio) + + do n=1,this%np_ + if (this%p(n)%id.gt.-2) this%p(n)%gd(3)=0.001_WP/this%p(n)%dil + end do + + ! Put the particle back where it was + do n=1,this%np_ + if (this%p(n)%id.gt.-2) this%p(n)%pos(3)=this%p(n)%pos(3)/1.001_WP + end do + + !====================================================================================== + + ! Now stretch particle for the first time step + + do n=1,this%np_ + ! Stretch the beam along the x axis with a uniform strain-rate of 0.001 + if (this%p(n)%id.gt.-2) this%p(n)%pos(1)=this%p(n)%pos(1)*1.001_WP + end do + + ! Communicate particles + call this%sync() + + ! Calculate bond force + call this%get_bond_force() + + + + + end subroutine stretch + + subroutine get_correction_coeffs(this,dt)!,stress_x,stress_y,stress_z) + use mpi_f08, only : MPI_SUM,MPI_INTEGER,MPI_IN_PLACE + use mathtools, only: Pi + implicit none + class(lss), intent(inout) :: this + real(WP), intent(inout) :: dt !< Timestep size over which to advance + real(WP) :: mu + integer :: n,ierr + ! Zero out number of particles removed + this%np_out=0 + do n=1,this%np_ + ! Stretch the beam along the x axis with a uniform strain-rate of 0.001 + if (this%p(n)%id.gt.-2) this%p(n)%pos(1)=this%p(n)%pos(1) + this%p(n)%pos(1)*0.001_WP + ! Relocalize + this%p(n)%ind=this%cfg%get_ijk_global(this%p(n)%pos,this%p(n)%ind) + ! Correct the position to take into account periodicity + if (this%cfg%xper) this%p(n)%pos(1)=this%cfg%x(this%cfg%imin)+modulo(this%p(n)%pos(1)-this%cfg%x(this%cfg%imin),this%cfg%xL) + if (this%cfg%yper) this%p(n)%pos(2)=this%cfg%y(this%cfg%jmin)+modulo(this%p(n)%pos(2)-this%cfg%y(this%cfg%jmin),this%cfg%yL) + if (this%cfg%zper) this%p(n)%pos(3)=this%cfg%z(this%cfg%kmin)+modulo(this%p(n)%pos(3)-this%cfg%z(this%cfg%kmin),this%cfg%zL) + ! Handle particles that have left the domain + if (this%p(n)%pos(1).lt.this%cfg%x(this%cfg%imin).or.this%p(n)%pos(1).gt.this%cfg%x(this%cfg%imax+1)) this%p(n)%flag=1 + if (this%p(n)%pos(2).lt.this%cfg%y(this%cfg%jmin).or.this%p(n)%pos(2).gt.this%cfg%y(this%cfg%jmax+1)) this%p(n)%flag=1 + if (this%p(n)%pos(3).lt.this%cfg%z(this%cfg%kmin).or.this%p(n)%pos(3).gt.this%cfg%z(this%cfg%kmax+1)) this%p(n)%flag=1 + ! Relocalize the particle + this%p(n)%ind=this%cfg%get_ijk_global(this%p(n)%pos,this%p(n)%ind) + ! Count number of particles removed + end do + + ! Communicate particles + call this%sync() + + ! Sum up particles removed + call MPI_ALLREDUCE(this%np_out,n,1,MPI_INTEGER,MPI_SUM,this%cfg%comm,ierr); this%np_out=n + + ! Calculate bond force + call this%get_bond_force() + + mu=this%elastic_modulus/(2.0_WP+2.0_WP*this%poisson_ratio) + + do n=1,this%np_ + this%p(n)%gd=0.001_WP/this%p(n)%dil + this%p(n)%Gb=0.5_WP*mu*(0.001_WP*0.001_WP)/this%p(n)%ste + end do + + ! Log/screen output + logging: block + use, intrinsic :: iso_fortran_env, only: output_unit + use param, only: verbose + use messager, only: log + use string, only: str_long + character(len=str_long) :: message + if (this%cfg%amRoot) then + write(message,'("Particle solver [",a,"] on partitioned grid [",a,"]: ",i0," particles were advanced")') trim(this%name),trim(this%cfg%name),this%np + if (verbose.gt.1) write(output_unit,'(a)') trim(message) + if (verbose.gt.0) call log(message) + end if + end block logging + + end subroutine get_correction_coeffs + + + !> Update particle volume fraction using our current particles + subroutine update_VF(this) + implicit none + class(lss), intent(inout) :: this + integer :: i + ! Reset volume fraction and momentum + this%VF=0.0_WP; this%VFU=0.0_WP; this%VFV=0.0_WP; this%VFW=0.0_WP + ! Transfer particle volume + do i=1,this%np_ + ! Skip inactive particle + if (this%p(i)%flag.eq.1) cycle + ! Transfer volume to mesh + call this%extrapolate(Ap=this%p(i)%vol,xp=this%p(i)%pos(1),yp=this%p(i)%pos(2),zp=this%p(i)%pos(3),ip=this%p(i)%ind(1),jp=this%p(i)%ind(2),kp=this%p(i)%ind(3),A=this%VF,dir='SC') + call this%extrapolate(Ap=this%p(i)%vol*this%p(i)%vel(1),xp=this%p(i)%pos(1),yp=this%p(i)%pos(2),zp=this%p(i)%pos(3),ip=this%p(i)%ind(1),jp=this%p(i)%ind(2),kp=this%p(i)%ind(3),A=this%VFU,dir='U') + call this%extrapolate(Ap=this%p(i)%vol*this%p(i)%vel(2),xp=this%p(i)%pos(1),yp=this%p(i)%pos(2),zp=this%p(i)%pos(3),ip=this%p(i)%ind(1),jp=this%p(i)%ind(2),kp=this%p(i)%ind(3),A=this%VFV,dir='V') + call this%extrapolate(Ap=this%p(i)%vol*this%p(i)%vel(3),xp=this%p(i)%pos(1),yp=this%p(i)%pos(2),zp=this%p(i)%pos(3),ip=this%p(i)%ind(1),jp=this%p(i)%ind(2),kp=this%p(i)%ind(3),A=this%VFW,dir='W') + end do + ! Sum at boundaries + call this%cfg%syncsum(this%VF) + call this%cfg%syncsum(this%VFU) + call this%cfg%syncsum(this%VFV) + call this%cfg%syncsum(this%VFW) + ! Clip + where (this%VF.gt.1.0_WP) this%VF=1.0_WP + where (this%VF.lt.0.0_WP) this%VF=0.0_WP + end subroutine update_VF + + + !> Compute regularized delta function + subroutine get_delta(this,delta,ic,jc,kc,xp,yp,zp,dir) + implicit none + class(lss), intent(inout) :: this + real(WP), intent(out) :: delta !< Return delta function + integer, intent(in) :: ic,jc,kc !< Cell index + real(WP), intent(in) :: xp,yp,zp !< Position of marker + character(len=*) :: dir + real(WP) :: deltax,deltay,deltaz,r + + ! Compute in X + if (trim(adjustl(dir)).eq.'U') then + r=(xp-this%cfg%x(ic))*this%cfg%dxmi(ic) + deltax=roma_kernel(r)*this%cfg%dxmi(ic) + else + r=(xp-this%cfg%xm(ic))*this%cfg%dxi(ic) + deltax=roma_kernel(r)*this%cfg%dxi(ic) + end if + + ! Compute in Y + if (trim(adjustl(dir)).eq.'V') then + r=(yp-this%cfg%y(jc))*this%cfg%dymi(jc) + deltay=roma_kernel(r)*this%cfg%dymi(jc) + else + r=(yp-this%cfg%ym(jc))*this%cfg%dyi(jc) + deltay=roma_kernel(r)*this%cfg%dyi(jc) + end if + + ! Compute in Z + if (trim(adjustl(dir)).eq.'W') then + r=(zp-this%cfg%z(kc))*this%cfg%dzmi(kc) + deltaz=roma_kernel(r)*this%cfg%dzmi(kc) + else + r=(zp-this%cfg%zm(kc))*this%cfg%dzi(kc) + deltaz=roma_kernel(r)*this%cfg%dzi(kc) + end if + !else + + ! Put it all together + delta=deltax*deltay*deltaz + + contains + ! Mollification kernel + ! Roma A, Peskin C and Berger M 1999 J. Comput. Phys. 153 509–534 + function roma_kernel(r) result(phi) + implicit none + real(WP), intent(in) :: r + real(WP) :: phi + if (abs(r).le.0.5_WP) then + phi=1.0_WP/3.0_WP*(1.0_WP+sqrt(-3.0_WP*r**2+1.0_WP)) + else if (abs(r).gt.0.5_WP .and. abs(r).le.1.5_WP) then + phi=1.0_WP/6.0_WP*(5.0_WP-3.0_WP*abs(r)-sqrt(-3.0_WP*(1.0_WP-abs(r))**2+1.0_WP)) + else + phi=0.0_WP + end if + end function roma_kernel + + end subroutine get_delta + + + !> Interpolation routine + function interpolate(this,A,xp,yp,zp,ip,jp,kp,dir) result(Ap) + implicit none + class(lss), intent(inout) :: this + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(in) :: A !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + real(WP), intent(in) :: xp,yp,zp + integer, intent(in) :: ip,jp,kp + character(len=*) :: dir + real(WP) :: Ap + integer :: di,dj,dk + integer :: i1,i2,j1,j2,k1,k2 + real(WP), dimension(-2:+2,-2:+2,-2:+2) :: delta + ! Get the interpolation points + i1=ip-2; i2=ip+2 + j1=jp-2; j2=jp+2 + k1=kp-2; k2=kp+2 + ! Loop over neighboring cells and compute regularized delta function + do dk=-2,+2 + do dj=-2,+2 + do di=-2,+2 + call this%get_delta(delta=delta(di,dj,dk),ic=ip+di,jc=jp+dj,kc=kp+dk,xp=xp,yp=yp,zp=zp,dir=trim(dir)) + end do + end do + end do + ! Perform the actual interpolation on Ap + Ap = sum(delta*A(i1:i2,j1:j2,k1:k2))*this%cfg%vol(ip,jp,kp) + end function interpolate + + + !> Extrapolation routine + subroutine extrapolate(this,Ap,xp,yp,zp,ip,jp,kp,A,dir) + use messager, only: die + implicit none + class(lss), intent(inout) :: this + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:) :: A !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + real(WP), intent(in) :: xp,yp,zp + integer, intent(in) :: ip,jp,kp + real(WP), intent(in) :: Ap + character(len=*) :: dir + real(WP), dimension(-2:+2,-2:+2,-2:+2) :: delta + integer :: di,dj,dk + ! If particle has left processor domain or reached last ghost cell, kill job + if ( ip.lt.this%cfg%imin_-1.or.ip.gt.this%cfg%imax_+1.or.& + & jp.lt.this%cfg%jmin_-1.or.jp.gt.this%cfg%jmax_+1.or.& + & kp.lt.this%cfg%kmin_-1.or.kp.gt.this%cfg%kmax_+1) then + write(*,*) ip,jp,kp,xp,yp,zp + call die('[df extrapolate] Particle has left the domain') + end if + ! Loop over neighboring cells and compute regularized delta function + do dk=-2,+2 + do dj=-2,+2 + do di=-2,+2 + call this%get_delta(delta=delta(di,dj,dk),ic=ip+di,jc=jp+dj,kc=kp+dk,xp=xp,yp=yp,zp=zp,dir=trim(dir)) + end do + end do + end do + ! Perform the actual extrapolation on A + A(ip-2:ip+2,jp-2:jp+2,kp-2:kp+2)=A(ip-2:ip+2,jp-2:jp+2,kp-2:kp+2)+delta*Ap + end subroutine extrapolate + + + !> Calculate the CFL + subroutine get_cfl(this,dt,cfl) + use mpi_f08, only: MPI_ALLREDUCE,MPI_MAX + use parallel, only: MPI_REAL_WP + implicit none + class(lss), intent(inout) :: this + real(WP), intent(in) :: dt + real(WP), intent(out) :: cfl + integer :: i,ierr + real(WP) :: my_CFLp_x,my_CFLp_y,my_CFLp_z,kk,mu,a + + ! Set the CFLs to zero + my_CFLp_x=0.0_WP; my_CFLp_y=0.0_WP; my_CFLp_z=0.0_WP + do i=1,this%np_ + my_CFLp_x=max(my_CFLp_x,abs(this%p(i)%vel(1))*this%cfg%dxi(this%p(i)%ind(1))) + my_CFLp_y=max(my_CFLp_y,abs(this%p(i)%vel(2))*this%cfg%dyi(this%p(i)%ind(2))) + my_CFLp_z=max(my_CFLp_z,abs(this%p(i)%vel(3))*this%cfg%dzi(this%p(i)%ind(3))) + end do + my_CFLp_x=my_CFLp_x*dt; my_CFLp_y=my_CFLp_y*dt; my_CFLp_z=my_CFLp_z*dt + + ! Get the parallel max + call MPI_ALLREDUCE(my_CFLp_x,this%CFLp_x,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + call MPI_ALLREDUCE(my_CFLp_y,this%CFLp_y,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + call MPI_ALLREDUCE(my_CFLp_z,this%CFLp_z,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + + ! CFL based on elastic wave speed in material + kk=this%elastic_modulus/(3.0_WP-6.0_WP*this%poisson_ratio) + mu=this%elastic_modulus/(2.0_WP+2.0_WP*this%poisson_ratio) + a=sqrt((kk+4.0_WP*mu/3.0_WP)/this%rho) + this%CFLp_a=dt*a*3/this%delta + + ! Return the maximum CFL + cfl=max(this%CFLp_x,this%CFLp_y,this%CFLp_z,this%CFLp_a) + + end subroutine get_cfl + + + !> Extract various monitoring data from particle field + subroutine get_max(this) + use mpi_f08, only: MPI_ALLREDUCE,MPI_MAX,MPI_MIN,MPI_SUM + use parallel, only: MPI_REAL_WP + implicit none + class(lss), intent(inout) :: this + real(WP) :: buf,safe_np + real(WP), dimension(3) :: buf3D + integer :: i,j,k,ierr + + ! Create safe np + safe_np=real(max(this%np,1),WP) + + ! Velocity min/max/mean + this%Umin=huge(1.0_WP); this%Umax=-huge(1.0_WP); this%Umean=0.0_WP + this%Vmin=huge(1.0_WP); this%Vmax=-huge(1.0_WP); this%Vmean=0.0_WP + this%Wmin=huge(1.0_WP); this%Wmax=-huge(1.0_WP); this%Wmean=0.0_WP + this%ibmForce=0.0_WP + do i=1,this%np_ + this%Umin=min(this%Umin,this%p(i)%vel(1)); this%Umax=max(this%Umax,this%p(i)%vel(1)); this%Umean=this%Umean+this%p(i)%vel(1) + this%Vmin=min(this%Vmin,this%p(i)%vel(2)); this%Vmax=max(this%Vmax,this%p(i)%vel(2)); this%Vmean=this%Vmean+this%p(i)%vel(2) + this%Wmin=min(this%Wmin,this%p(i)%vel(3)); this%Wmax=max(this%Wmax,this%p(i)%vel(3)); this%Wmean=this%Wmean+this%p(i)%vel(3) + this%ibmForce=this%ibmForce+this%p(i)%Afluid*this%p(i)%vol*this%rho + end do + call MPI_ALLREDUCE(this%Umin ,buf,1,MPI_REAL_WP,MPI_MIN,this%cfg%comm,ierr); this%Umin =buf + call MPI_ALLREDUCE(this%Umax ,buf,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr); this%Umax =buf + call MPI_ALLREDUCE(this%Umean,buf,1,MPI_REAL_WP,MPI_SUM,this%cfg%comm,ierr); this%Umean=buf/safe_np + call MPI_ALLREDUCE(this%Vmin ,buf,1,MPI_REAL_WP,MPI_MIN,this%cfg%comm,ierr); this%Vmin =buf + call MPI_ALLREDUCE(this%Vmax ,buf,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr); this%Vmax =buf + call MPI_ALLREDUCE(this%Vmean,buf,1,MPI_REAL_WP,MPI_SUM,this%cfg%comm,ierr); this%Vmean=buf/safe_np + call MPI_ALLREDUCE(this%Wmin ,buf,1,MPI_REAL_WP,MPI_MIN,this%cfg%comm,ierr); this%Wmin =buf + call MPI_ALLREDUCE(this%Wmax ,buf,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr); this%Wmax =buf + call MPI_ALLREDUCE(this%Wmean,buf,1,MPI_REAL_WP,MPI_SUM,this%cfg%comm,ierr); this%Wmean=buf/safe_np + call MPI_ALLREDUCE(this%ibmForce,buf3D,3,MPI_REAL_WP,MPI_SUM,this%cfg%comm,ierr); this%ibmForce=buf3D + + ! Get max volume fraction + this%VFmax =-huge(1.0_WP) + do k=this%cfg%kmin_,this%cfg%kmax_ + do j=this%cfg%jmin_,this%cfg%jmax_ + do i=this%cfg%imin_,this%cfg%imax_ + this%VFmax=max(this%VFmax,this%VF(i,j,k)) + end do + end do + end do + call MPI_ALLREDUCE(this%VFmax,buf,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr); this%VFmax=buf + + end subroutine get_max + + + !> Update particle mesh using our current particles + subroutine update_partmesh(this,pmesh) + use partmesh_class, only: partmesh + implicit none + class(lss), intent(inout) :: this + class(partmesh), intent(inout) :: pmesh + integer :: i + ! Reset particle mesh storage + call pmesh%reset() + ! Nothing else to do if no particle is present + if (this%np_.eq.0) return + ! Copy particle info + call pmesh%set_size(this%np_) + do i=1,this%np_ + pmesh%pos(:,i)=this%p(i)%pos + end do + end subroutine update_partmesh + + + !> Creation of the MPI datatype for particle + subroutine prepare_mpi_part() + use mpi_f08 + use messager, only: die + implicit none + integer(MPI_ADDRESS_KIND), dimension(part_nblock) :: disp + integer(MPI_ADDRESS_KIND) :: lb,extent + type(MPI_Datatype) :: MPI_PART_TMP + integer :: i,mysize,ierr + ! Prepare the displacement array + disp(1)=0 + do i=2,part_nblock + call MPI_Type_size(part_tblock(i-1),mysize,ierr) + disp(i)=disp(i-1)+int(mysize,MPI_ADDRESS_KIND)*int(part_lblock(i-1),MPI_ADDRESS_KIND) + end do + ! Create and commit the new type + call MPI_Type_create_struct(part_nblock,part_lblock,disp,part_tblock,MPI_PART_TMP,ierr) + call MPI_Type_get_extent(MPI_PART_TMP,lb,extent,ierr) + call MPI_Type_create_resized(MPI_PART_TMP,lb,extent,MPI_PART,ierr) + call MPI_Type_commit(MPI_PART,ierr) + ! If a problem was encountered, say it + if (ierr.ne.0) call die('[lss prepare_mpi_part] MPI Particle type creation failed') + ! Get the size of this type + call MPI_type_size(MPI_PART,MPI_PART_SIZE,ierr) + end subroutine prepare_mpi_part + + + !> Share particles across processor boundaries + subroutine share(this,nover) + use mpi_f08 + use messager, only: warn,die + implicit none + class(lss), intent(inout) :: this + integer, optional :: nover + type(part), dimension(:), allocatable :: tosend + type(part), dimension(:), allocatable :: torecv + integer :: no,nsend,nrecv + type(MPI_Status) :: status + integer :: icnt,isrc,idst,ierr + integer :: i,n + + ! Check overlap size + if (present(nover)) then + no=nover + if (no.gt.this%cfg%no) then + call warn('[lss share] Specified overlap is larger than that of cfg - reducing no') + no=this%cfg%no + else if (no.le.0) then + call die('[lss share] Specified overlap cannot be less or equal to zero') + end if + else + no=1 + end if + + ! Clean up ghost array + call this%resize_ghost(n=0); this%ng_=0 + + ! Share ghost particles in -x (no ghosts are sent here) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(1).lt.this%cfg%imin_+no) nsend=nsend+1 + end do + allocate(tosend(nsend)) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(1).lt.this%cfg%imin_+no) then + nsend=nsend+1 + tosend(nsend)=this%p(n) + if (this%cfg%xper.and.tosend(nsend)%ind(1).lt.this%cfg%imin+no) then + tosend(nsend)%pos(1)=tosend(nsend)%pos(1)+this%cfg%xL + tosend(nsend)%ind(1)=tosend(nsend)%ind(1)+this%cfg%nx + end if + end if + end do + nrecv=0 + call MPI_CART_SHIFT(this%cfg%comm,0,-1,isrc,idst,ierr) + call MPI_SENDRECV(nsend,1,MPI_INTEGER,idst,0,nrecv,1,MPI_INTEGER,isrc,0,this%cfg%comm,status,ierr) + allocate(torecv(nrecv)) + call MPI_SENDRECV(tosend,nsend,MPI_PART,idst,0,torecv,nrecv,MPI_PART,isrc,0,this%cfg%comm,status,ierr) + call this%resize_ghost(this%ng_+nrecv) + this%g(this%ng_+1:this%ng_+nrecv)=torecv + this%ng_=this%ng_+nrecv + if (allocated(tosend)) deallocate(tosend) + if (allocated(torecv)) deallocate(torecv) + + ! Share ghost particles in +x (no ghosts are sent here) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(1).gt.this%cfg%imax_-no) nsend=nsend+1 + end do + allocate(tosend(nsend)) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(1).gt.this%cfg%imax_-no) then + nsend=nsend+1 + tosend(nsend)=this%p(n) + if (this%cfg%xper.and.tosend(nsend)%ind(1).gt.this%cfg%imax-no) then + tosend(nsend)%pos(1)=tosend(nsend)%pos(1)-this%cfg%xL + tosend(nsend)%ind(1)=tosend(nsend)%ind(1)-this%cfg%nx + end if + end if + end do + nrecv=0 + call MPI_CART_SHIFT(this%cfg%comm,0,+1,isrc,idst,ierr) + call MPI_SENDRECV(nsend,1,MPI_INTEGER,idst,0,nrecv,1,MPI_INTEGER,isrc,0,this%cfg%comm,status,ierr) + allocate(torecv(nrecv)) + call MPI_SENDRECV(tosend,nsend,MPI_PART,idst,0,torecv,nrecv,MPI_PART,isrc,0,this%cfg%comm,status,ierr) + call this%resize_ghost(this%ng_+nrecv) + this%g(this%ng_+1:this%ng_+nrecv)=torecv + this%ng_=this%ng_+nrecv + if (allocated(tosend)) deallocate(tosend) + if (allocated(torecv)) deallocate(torecv) + + ! Share ghost particles in -y (ghosts need to be sent now) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(2).lt.this%cfg%jmin_+no) nsend=nsend+1 + end do + do n=1,this%ng_ + if (this%g(n)%ind(2).lt.this%cfg%jmin_+no) nsend=nsend+1 + end do + allocate(tosend(nsend)) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(2).lt.this%cfg%jmin_+no) then + nsend=nsend+1 + tosend(nsend)=this%p(n) + if (this%cfg%yper.and.tosend(nsend)%ind(2).lt.this%cfg%jmin+no) then + tosend(nsend)%pos(2)=tosend(nsend)%pos(2)+this%cfg%yL + tosend(nsend)%ind(2)=tosend(nsend)%ind(2)+this%cfg%ny + end if + end if + end do + do n=1,this%ng_ + if (this%g(n)%ind(2).lt.this%cfg%jmin_+no) then + nsend=nsend+1 + tosend(nsend)=this%g(n) + if (this%cfg%yper.and.tosend(nsend)%ind(2).lt.this%cfg%jmin+no) then + tosend(nsend)%pos(2)=tosend(nsend)%pos(2)+this%cfg%yL + tosend(nsend)%ind(2)=tosend(nsend)%ind(2)+this%cfg%ny + end if + end if + end do + nrecv=0 + call MPI_CART_SHIFT(this%cfg%comm,1,-1,isrc,idst,ierr) + call MPI_SENDRECV(nsend,1,MPI_INTEGER,idst,0,nrecv,1,MPI_INTEGER,isrc,0,this%cfg%comm,status,ierr) + allocate(torecv(nrecv)) + call MPI_SENDRECV(tosend,nsend,MPI_PART,idst,0,torecv,nrecv,MPI_PART,isrc,0,this%cfg%comm,status,ierr) + call this%resize_ghost(this%ng_+nrecv) + this%g(this%ng_+1:this%ng_+nrecv)=torecv + this%ng_=this%ng_+nrecv + if (allocated(tosend)) deallocate(tosend) + if (allocated(torecv)) deallocate(torecv) + + ! Share ghost particles in +y (ghosts need to be sent now - but not newly received ghosts!) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(2).gt.this%cfg%jmax_-no) nsend=nsend+1 + end do + do n=1,this%ng_-nrecv + if (this%g(n)%ind(2).gt.this%cfg%jmax_-no) nsend=nsend+1 + end do + allocate(tosend(nsend)) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(2).gt.this%cfg%jmax_-no) then + nsend=nsend+1 + tosend(nsend)=this%p(n) + if (this%cfg%yper.and.tosend(nsend)%ind(2).gt.this%cfg%jmax-no) then + tosend(nsend)%pos(2)=tosend(nsend)%pos(2)-this%cfg%yL + tosend(nsend)%ind(2)=tosend(nsend)%ind(2)-this%cfg%ny + end if + end if + end do + do n=1,this%ng_-nrecv + if (this%g(n)%ind(2).gt.this%cfg%jmax_-no) then + nsend=nsend+1 + tosend(nsend)=this%g(n) + if (this%cfg%yper.and.tosend(nsend)%ind(2).gt.this%cfg%jmax-no) then + tosend(nsend)%pos(2)=tosend(nsend)%pos(2)-this%cfg%yL + tosend(nsend)%ind(2)=tosend(nsend)%ind(2)-this%cfg%ny + end if + end if + end do + nrecv=0 + call MPI_CART_SHIFT(this%cfg%comm,1,+1,isrc,idst,ierr) + call MPI_SENDRECV(nsend,1,MPI_INTEGER,idst,0,nrecv,1,MPI_INTEGER,isrc,0,this%cfg%comm,status,ierr) + allocate(torecv(nrecv)) + call MPI_SENDRECV(tosend,nsend,MPI_PART,idst,0,torecv,nrecv,MPI_PART,isrc,0,this%cfg%comm,status,ierr) + call this%resize_ghost(this%ng_+nrecv) + this%g(this%ng_+1:this%ng_+nrecv)=torecv + this%ng_=this%ng_+nrecv + if (allocated(tosend)) deallocate(tosend) + if (allocated(torecv)) deallocate(torecv) + + ! Share ghost particles in -z (ghosts need to be sent now) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(3).lt.this%cfg%kmin_+no) nsend=nsend+1 + end do + do n=1,this%ng_ + if (this%g(n)%ind(3).lt.this%cfg%kmin_+no) nsend=nsend+1 + end do + allocate(tosend(nsend)) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(3).lt.this%cfg%kmin_+no) then + nsend=nsend+1 + tosend(nsend)=this%p(n) + if (this%cfg%zper.and.tosend(nsend)%ind(3).lt.this%cfg%kmin+no) then + tosend(nsend)%pos(3)=tosend(nsend)%pos(3)+this%cfg%zL + tosend(nsend)%ind(3)=tosend(nsend)%ind(3)+this%cfg%nz + end if + end if + end do + do n=1,this%ng_ + if (this%g(n)%ind(3).lt.this%cfg%kmin_+no) then + nsend=nsend+1 + tosend(nsend)=this%g(n) + if (this%cfg%zper.and.tosend(nsend)%ind(3).lt.this%cfg%kmin+no) then + tosend(nsend)%pos(3)=tosend(nsend)%pos(3)+this%cfg%zL + tosend(nsend)%ind(3)=tosend(nsend)%ind(3)+this%cfg%nz + end if + end if + end do + nrecv=0 + call MPI_CART_SHIFT(this%cfg%comm,2,-1,isrc,idst,ierr) + call MPI_SENDRECV(nsend,1,MPI_INTEGER,idst,0,nrecv,1,MPI_INTEGER,isrc,0,this%cfg%comm,status,ierr) + allocate(torecv(nrecv)) + call MPI_SENDRECV(tosend,nsend,MPI_PART,idst,0,torecv,nrecv,MPI_PART,isrc,0,this%cfg%comm,status,ierr) + call this%resize_ghost(this%ng_+nrecv) + this%g(this%ng_+1:this%ng_+nrecv)=torecv + this%ng_=this%ng_+nrecv + if (allocated(tosend)) deallocate(tosend) + if (allocated(torecv)) deallocate(torecv) + + ! Share ghost particles in +z (ghosts need to be sent now - but not newly received ghosts!) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(3).gt.this%cfg%kmax_-no) nsend=nsend+1 + end do + do n=1,this%ng_-nrecv + if (this%g(n)%ind(3).gt.this%cfg%kmax_-no) nsend=nsend+1 + end do + allocate(tosend(nsend)) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(3).gt.this%cfg%kmax_-no) then + nsend=nsend+1 + tosend(nsend)=this%p(n) + if (this%cfg%zper.and.tosend(nsend)%ind(3).gt.this%cfg%kmax-no) then + tosend(nsend)%pos(3)=tosend(nsend)%pos(3)-this%cfg%zL + tosend(nsend)%ind(3)=tosend(nsend)%ind(3)-this%cfg%nz + end if + end if + end do + do n=1,this%ng_-nrecv + if (this%g(n)%ind(3).gt.this%cfg%kmax_-no) then + nsend=nsend+1 + tosend(nsend)=this%g(n) + if (this%cfg%zper.and.tosend(nsend)%ind(3).gt.this%cfg%kmax-no) then + tosend(nsend)%pos(3)=tosend(nsend)%pos(3)-this%cfg%zL + tosend(nsend)%ind(3)=tosend(nsend)%ind(3)-this%cfg%nz + end if + end if + end do + nrecv=0 + call MPI_CART_SHIFT(this%cfg%comm,2,+1,isrc,idst,ierr) + call MPI_SENDRECV(nsend,1,MPI_INTEGER,idst,0,nrecv,1,MPI_INTEGER,isrc,0,this%cfg%comm,status,ierr) + allocate(torecv(nrecv)) + call MPI_SENDRECV(tosend,nsend,MPI_PART,idst,0,torecv,nrecv,MPI_PART,isrc,0,this%cfg%comm,status,ierr) + call this%resize_ghost(this%ng_+nrecv) + this%g(this%ng_+1:this%ng_+nrecv)=torecv + this%ng_=this%ng_+nrecv + if (allocated(tosend)) deallocate(tosend) + if (allocated(torecv)) deallocate(torecv) + + end subroutine share + + + !> Synchronize particle arrays across processors + subroutine sync(this) + use mpi_f08 + implicit none + class(lss), intent(inout) :: this + integer, dimension(0:this%cfg%nproc-1) :: nsend_proc,nrecv_proc + integer, dimension(0:this%cfg%nproc-1) :: nsend_disp,nrecv_disp + integer :: n,prank,ierr + type(part), dimension(:), allocatable :: buf_send + ! Recycle first to minimize communication load + call this%recycle() + ! Prepare information about what to send + nsend_proc=0 + do n=1,this%np_ + prank=this%cfg%get_rank(this%p(n)%ind) + nsend_proc(prank)=nsend_proc(prank)+1 + end do + nsend_proc(this%cfg%rank)=0 + ! Inform processors of what they will receive + call MPI_ALLtoALL(nsend_proc,1,MPI_INTEGER,nrecv_proc,1,MPI_INTEGER,this%cfg%comm,ierr) + ! Prepare displacements for all-to-all + nsend_disp(0)=0 + nrecv_disp(0)=this%np_ !< Directly add particles at the end of main array + do n=1,this%cfg%nproc-1 + nsend_disp(n)=nsend_disp(n-1)+nsend_proc(n-1) + nrecv_disp(n)=nrecv_disp(n-1)+nrecv_proc(n-1) + end do + ! Allocate buffer to send particles + allocate(buf_send(sum(nsend_proc))) + ! Pack the particles in the send buffer + nsend_proc=0 + do n=1,this%np_ + ! Get the rank + prank=this%cfg%get_rank(this%p(n)%ind) + ! Skip particles still inside + if (prank.eq.this%cfg%rank) cycle + ! Pack up for sending + nsend_proc(prank)=nsend_proc(prank)+1 + buf_send(nsend_disp(prank)+nsend_proc(prank))=this%p(n) + ! Flag particle for removal + this%p(n)%flag=1 + end do + ! Allocate buffer for receiving particles + call this%resize(this%np_+sum(nrecv_proc)) + ! Perform communication + call MPI_ALLtoALLv(buf_send,nsend_proc,nsend_disp,MPI_PART,this%p,nrecv_proc,nrecv_disp,MPI_PART,this%cfg%comm,ierr) + ! Deallocate buffer + deallocate(buf_send) + ! Recycle to remove duplicate particles + call this%recycle() + end subroutine sync + + + !> Adaptation of particle array size + subroutine resize(this,n) + implicit none + class(lss), intent(inout) :: this + integer, intent(in) :: n + type(part), dimension(:), allocatable :: tmp + integer :: size_now,size_new + ! Resize particle array to size n + if (.not.allocated(this%p)) then + ! Allocate directly to size n + allocate(this%p(n)) + this%p(1:n)%flag=1 + else + ! Update from a non-zero size to another non-zero size + size_now=size(this%p,dim=1) + if (n.gt.size_now) then + size_new=max(n,int(real(size_now,WP)*coeff_up)) + allocate(tmp(size_new)) + tmp(1:size_now)=this%p + tmp(size_now+1:)%flag=1 + call move_alloc(tmp,this%p) + else if (n.lt.int(real(size_now,WP)*coeff_dn)) then + allocate(tmp(n)) + tmp(1:n)=this%p(1:n) + call move_alloc(tmp,this%p) + end if + end if + end subroutine resize + + + !> Adaptation of ghost array size + subroutine resize_ghost(this,n) + implicit none + class(lss), intent(inout) :: this + integer, intent(in) :: n + type(part), dimension(:), allocatable :: tmp + integer :: size_now,size_new + ! Resize ghost array to size n + if (.not.allocated(this%g)) then + ! Allocate directly to size n + allocate(this%g(n)) + this%g(1:n)%flag=1 + else + ! Update from a non-zero size to another non-zero size + size_now=size(this%g,dim=1) + if (n.gt.size_now) then + size_new=max(n,int(real(size_now,WP)*coeff_up)) + allocate(tmp(size_new)) + tmp(1:size_now)=this%g + tmp(size_now+1:)%flag=1 + call move_alloc(tmp,this%g) + else if (n.lt.int(real(size_now,WP)*coeff_dn)) then + allocate(tmp(n)) + tmp(1:n)=this%g(1:n) + call move_alloc(tmp,this%g) + end if + end if + end subroutine resize_ghost + + + !> Clean-up of particle array by removing flag=1 particles + subroutine recycle(this) + implicit none + class(lss), intent(inout) :: this + integer :: new_size,i,ierr + ! Compact all active particles at the beginning of the array + new_size=0 + if (allocated(this%p)) then + do i=1,size(this%p,dim=1) + if (this%p(i)%flag.ne.1) then + new_size=new_size+1 + if (i.ne.new_size) then + this%p(new_size)=this%p(i) + this%p(i)%flag=1 + end if + end if + end do + end if + ! Resize to new size + call this%resize(new_size) + ! Update number of particles + this%np_=new_size + call MPI_ALLGATHER(this%np_,1,MPI_INTEGER,this%np_proc,1,MPI_INTEGER,this%cfg%comm,ierr) + this%np=sum(this%np_proc) + end subroutine recycle + + + !> Parallel write particles to file + subroutine write(this,filename) + use mpi_f08 + use messager, only: die + use parallel, only: info_mpiio + implicit none + class(lss), intent(inout) :: this + character(len=*), intent(in) :: filename + type(MPI_File) :: ifile + type(MPI_Status):: status + integer(kind=MPI_OFFSET_KIND) :: offset + integer :: i,ierr,iunit + + ! Root serial-writes the file header + if (this%cfg%amRoot) then + ! Open the file + open(newunit=iunit,file=trim(filename),form='unformatted',status='replace',access='stream',iostat=ierr) + if (ierr.ne.0) call die('[lss write] Problem encountered while serial-opening data file: '//trim(filename)) + ! Number of particles and particle object size + write(iunit) this%np,MPI_PART_SIZE + ! Done with the header + close(iunit) + end if + + ! The rest is done in parallel + call MPI_FILE_OPEN(this%cfg%comm,trim(filename),IOR(MPI_MODE_WRONLY,MPI_MODE_APPEND),info_mpiio,ifile,ierr) + if (ierr.ne.0) call die('[lss write] Problem encountered while parallel-opening data file: '//trim(filename)) + + ! Get current position + call MPI_FILE_GET_POSITION(ifile,offset,ierr) + + ! Compute the offset and write + do i=1,this%cfg%rank + offset=offset+int(this%np_proc(i),MPI_OFFSET_KIND)*int(MPI_PART_SIZE,MPI_OFFSET_KIND) + end do + if (this%np_.gt.0) call MPI_FILE_WRITE_AT(ifile,offset,this%p,this%np_,MPI_PART,status,ierr) + + ! Close the file + call MPI_FILE_CLOSE(ifile,ierr) + + ! Log/screen output + logging: block + use, intrinsic :: iso_fortran_env, only: output_unit + use param, only: verbose + use messager, only: log + use string, only: str_long + character(len=str_long) :: message + if (this%cfg%amRoot) then + write(message,'("[lss write] Wrote ",i0," particles to file [",a,"] on partitioned grid [",a,"]")') this%np,trim(filename),trim(this%cfg%name) + if (verbose.gt.2) write(output_unit,'(a)') trim(message) + if (verbose.gt.1) call log(message) + end if + end block logging + + end subroutine write + + + !> Parallel read particles to file + subroutine read(this,filename) + use mpi_f08 + use messager, only: die + use parallel, only: info_mpiio + implicit none + class(lss), intent(inout) :: this + character(len=*), intent(in) :: filename + type(MPI_File) :: ifile + type(MPI_Status):: status + integer(kind=MPI_OFFSET_KIND) :: offset,header_offset + integer :: i,j,ierr,npadd,psize,nchunk,cnt + integer, dimension(:,:), allocatable :: ppp + + ! First open the file in parallel + call MPI_FILE_OPEN(this%cfg%comm,trim(filename),MPI_MODE_RDONLY,info_mpiio,ifile,ierr) + if (ierr.ne.0) call die('[lss read] Problem encountered while reading data file: '//trim(filename)) + + ! Read file header first + call MPI_FILE_READ_ALL(ifile,npadd,1,MPI_INTEGER,status,ierr) + call MPI_FILE_READ_ALL(ifile,psize,1,MPI_INTEGER,status,ierr) + + ! Remember current position + call MPI_FILE_GET_POSITION(ifile,header_offset,ierr) + + ! Check compatibility of particle type + if (psize.ne.MPI_PART_SIZE) call die('[lss read] Particle type unreadable') + + ! Naively share reading task among all processors + nchunk=int(npadd/(this%cfg%nproc*part_chunk_size))+1 + allocate(ppp(this%cfg%nproc,nchunk)) + ppp=int(npadd/(this%cfg%nproc*nchunk)) + cnt=0 + out:do j=1,nchunk + do i=1,this%cfg%nproc + cnt=cnt+1 + if (cnt.gt.mod(npadd,this%cfg%nproc*nchunk)) exit out + ppp(i,j)=ppp(i,j)+1 + end do + end do out + + ! Read by chunk + do j=1,nchunk + ! Find offset + offset=header_offset+int(MPI_PART_SIZE,MPI_OFFSET_KIND)*int(sum(ppp(1:this%cfg%rank,:))+sum(ppp(this%cfg%rank+1,1:j-1)),MPI_OFFSET_KIND) + ! Resize particle array + call this%resize(this%np_+ppp(this%cfg%rank+1,j)) + ! Read this file + call MPI_FILE_READ_AT(ifile,offset,this%p(this%np_+1:this%np_+ppp(this%cfg%rank+1,j)),ppp(this%cfg%rank+1,j),MPI_PART,status,ierr) + ! Most general case: relocate every droplet + do i=this%np_+1,this%np_+ppp(this%cfg%rank+1,j) + this%p(i)%ind=this%cfg%get_ijk_global(this%p(i)%pos,this%p(i)%ind) + end do + ! Exchange all that + call this%sync() + end do + + ! Close the file + call MPI_FILE_CLOSE(ifile,ierr) + + ! Log/screen output + logging: block + use, intrinsic :: iso_fortran_env, only: output_unit + use param, only: verbose + use messager, only: log + use string, only: str_long + character(len=str_long) :: message + if (this%cfg%amRoot) then + write(message,'("[lss read] Read ",i0," particles from file [",a,"] on partitioned grid [",a,"]")') npadd,trim(filename),trim(this%cfg%name) + if (verbose.gt.2) write(output_unit,'(a)') trim(message) + if (verbose.gt.1) call log(message) + end if + end block logging + + end subroutine read + + +end module lss_class diff --git a/examples/beam_tension/src/simulation.f90 b/examples/beam_tension/src/simulation.f90 new file mode 100644 index 000000000..b54816f3e --- /dev/null +++ b/examples/beam_tension/src/simulation.f90 @@ -0,0 +1,790 @@ +!> Various definitions and tools for running an NGA2 simulation +module simulation + use precision, only: WP,SP + use geometry, only: cfg + use spcomp_class, only: spcomp + use lss_class, only: lss + use timetracker_class, only: timetracker + use ensight_class, only: ensight + use partmesh_class, only: partmesh + use event_class, only: event + use monitor_class, only: monitor + implicit none + private + + !> Get a couple linear solvers, an incompressible flow solver and corresponding time tracker + type(spcomp), public :: fs + type(lss), public :: ls + type(timetracker), public :: time + + !> Ensight postprocessing + type(partmesh) :: pmesh + type(ensight) :: ens_out + type(event) :: ens_evt + + !> Simulation monitor file + type(monitor) :: mfile,cflfile,consfile,sfile,dispfile + + public :: simulation_init,simulation_run,simulation_final + + !> Private work arrays + real(WP), dimension(:,:,:,:,:), allocatable :: dQdt + real(WP), dimension(:,:,:) , allocatable :: Ui,Vi,Wi,Ma,beta,visc,visc_t,div + !> Post-shock viscosity and temperature + real(WP) :: visc0,T0 + + !> Equations of state + real(WP) :: Pinf,Gamma,Cv,Prandtl + + !> Flow parameters + real(WP) :: Ms,Xs,Rcyl + real(WP) :: rho1,p1,u1,M1 + real(WP) :: rho2,p2,u2,M2 + real(WP) :: Re + + !> Max timestep size for solid solver + real(WP) :: ls_dt,ls_dt_max + + integer :: target_index + real(WP), dimension(3) :: target_position + + + contains + + + !> Function that returns a smooth Heaviside of thickness delta + real(WP) function Hshock(x,delta) + real(WP), intent(in) :: x,delta + ! Goes from 0 to 1 as x goes from begative to positive + Hshock=1.0_WP/(1.0_WP+exp(-x/delta)) + end function Hshock + + !> P=EOS(RHO,I) + pure real(WP) function get_P(RHO,I) + implicit none + real(WP), intent(in) :: RHO,I + get_P=RHO*I*(Gamma-1.0_WP)-Gamma*Pinf + end function get_P + !> T=f(RHO,P) + pure real(WP) function get_T(RHO,P) + implicit none + real(WP), intent(in) :: RHO,P + get_T=(P+Pinf)/(Cv*RHO*(Gamma-1.0_WP)) + end function get_T + !> RHO=f(T,P) + pure real(WP) function get_RHO(T,P) + implicit none + real(WP), intent(in) :: T,P + get_RHO=(P+Pinf)/(Cv*T*(Gamma-1.0_WP)) + end function get_RHO + !> I=EOS(RHO,P) + pure real(WP) function get_I(RHO,P) + implicit none + real(WP), intent(in) :: RHO,P + get_I=(P+Gamma*Pinf)/(RHO*(Gamma-1.0_WP)) + end function get_I + !> C=f(RHO,P) + pure real(WP) function get_C(RHO,P) + implicit none + real(WP), intent(in) :: RHO,P + get_C=sqrt(Gamma*(P+Pinf)/RHO) + end function get_C + !> S=f(RHO,P) + pure real(WP) function get_S(RHO,P) + implicit none + real(WP), intent(in) :: RHO,P + get_S=Cv*log((P+Pinf)/RHO**Gamma) + end function get_S + + subroutine get_tracked_particle() + use mpi_f08 + implicit none + integer :: i, ierr + real(WP) :: local_pos(3), global_pos(3) + + local_pos = 0.0_WP + + do i=1,ls%np_ + if (ls%p(i)%i.eq.target_index) then + local_pos = ls%p(i)%pos + end if + end do + call MPI_ALLREDUCE(local_pos, global_pos, 3, MPI_DOUBLE_PRECISION, MPI_SUM, ls%cfg%comm, ierr) + + target_position = global_pos + end subroutine + + !> Calculate viscosities + subroutine prepare_viscosities() + implicit none + integer :: i,j,k + real(WP) :: S + ! Get viscosity from Sutherland's law + S=110.4_WP/273.15_WP*T0 + do k=fs%cfg%kmino_,fs%cfg%kmaxo_ + do j=fs%cfg%jmino_,fs%cfg%jmaxo_ + do i=fs%cfg%imino_,fs%cfg%imaxo_ + visc(i,j,k)=visc0*(T0+S)/(fs%T(i,j,k)+S)*(fs%T(i,j,k)/T0)**1.5_WP + end do + end do + end do + ! Get LAD + call fs%get_viscartif(dt=time%dt,beta=beta); fs%BETA=fs%Q(:,:,:,1)*beta + ! Get eddy viscosity + call fs%get_vreman (dt=time%dt,visc=visc_t); fs%VISC=fs%Q(:,:,:,1)*visc_t+visc + ! Recompute thermal conductivity + fs%diff=Gamma*Cv*fs%visc/Prandtl + ! Add LAD + fs%VISC=fs%VISC+0.002_WP*fs%BETA + end subroutine prepare_viscosities + + + !> Calculate velocity divergence + subroutine get_div() + implicit none + integer :: i,j,k + do k=fs%cfg%kmino_,fs%cfg%kmaxo_-1; do j=fs%cfg%jmino_,fs%cfg%jmaxo_-1; do i=fs%cfg%imino_,fs%cfg%imaxo_-1 + div(i,j,k)=fs%dxi*(fs%U(i+1,j,k)-fs%U(i,j,k))+fs%dyi*(fs%V(i,j+1,k)-fs%V(i,j,k))+fs%dzi*(fs%W(i,j,k+1)-fs%W(i,j,k)) + end do; end do; end do + call fs%cfg%sync(div) + if (.not.fs%cfg%xper.and.fs%cfg%iproc.eq.fs%cfg%npx) div(fs%cfg%imaxo,:,:)=div(fs%cfg%imaxo-1,:,:) + if (.not.fs%cfg%yper.and.fs%cfg%jproc.eq.fs%cfg%npy) div(:,fs%cfg%jmaxo,:)=div(:,fs%cfg%jmaxo-1,:) + if (.not.fs%cfg%zper.and.fs%cfg%kproc.eq.fs%cfg%npz) div(:,:,fs%cfg%kmaxo)=div(:,:,fs%cfg%kmaxo-1) + end subroutine get_div + + + !> Overwrite cosnerved variables using volume-of-solid IBM + subroutine apply_ibm() + implicit none + integer :: i,j,k,ii,jj,kk + real(WP) :: sum_VF,sum_VFQ1,sum_VFQ2 + do k=cfg%kmin_,cfg%kmax_ + do j=cfg%jmin_,cfg%jmax_ + do i=cfg%imin_,cfg%imax_ + if (ls%VF(i,j,k).eq.0.0_WP) cycle + ! Neumann: VF-weighted neighbor average for Q(1) and Q(2) + sum_VF=0.0_WP; sum_VFQ1=0.0_WP; sum_VFQ2=0.0_WP + do kk=-1,1; do jj=-1,1; do ii=-1,1 + if (ii.eq.0.and.jj.eq.0.and.kk.eq.0) cycle + sum_VF =sum_VF +(1.0_WP-ls%VF(i+ii,j+jj,k+kk)) + sum_VFQ1=sum_VFQ1+(1.0_WP-ls%VF(i+ii,j+jj,k+kk))*fs%Q(i+ii,j+jj,k+kk,1) + sum_VFQ2=sum_VFQ2+(1.0_WP-ls%VF(i+ii,j+jj,k+kk))*fs%Q(i+ii,j+jj,k+kk,2) + end do; end do; end do + if (sum_VF.gt.0.0_WP) then + fs%Q(i,j,k,1)=(1.0_WP-ls%VF(i,j,k))*fs%Q(i,j,k,1)+ls%VF(i,j,k)*sum_VFQ1/sum_VF + fs%Q(i,j,k,2)=(1.0_WP-ls%VF(i,j,k))*fs%Q(i,j,k,2)+ls%VF(i,j,k)*sum_VFQ2/sum_VF + end if + ! No-slip now that density is determined + fs%Q(i,j,k,3)=(1.0_WP-0.5_WP*(ls%VF(i-1,j,k)+ls%VF(i,j,k)))*fs%Q(i,j,k,3)+0.5_WP*(fs%Q(i-1,j,k,1)+fs%Q(i,j,k,1))*ls%VFU(i,j,k) + fs%Q(i,j,k,4)=(1.0_WP-0.5_WP*(ls%VF(i,j-1,k)+ls%VF(i,j,k)))*fs%Q(i,j,k,4)+0.5_WP*(fs%Q(i,j-1,k,1)+fs%Q(i,j,k,1))*ls%VFV(i,j,k) + fs%Q(i,j,k,5)=(1.0_WP-0.5_WP*(ls%VF(i,j,k-1)+ls%VF(i,j,k)))*fs%Q(i,j,k,5)+0.5_WP*(fs%Q(i,j,k-1,1)+fs%Q(i,j,k,1))*ls%VFW(i,j,k) + end do + end do + end do + ! Communicate + call fs%cfg%sync(fs%Q(:,:,:,1)) + call fs%cfg%sync(fs%Q(:,:,:,2)) + call fs%cfg%sync(fs%Q(:,:,:,3)) + call fs%cfg%sync(fs%Q(:,:,:,4)) + call fs%cfg%sync(fs%Q(:,:,:,5)) + ! Rebuild primitive variables + call fs%get_primitive() + end subroutine apply_ibm + + + !> Apply boundary conditions + subroutine apply_bconds() + implicit none + integer :: i,j,k + + ! Apply clipped Neumann on primitive variables in x+ + if (.not.fs%cfg%xper.and.fs%cfg%iproc.eq.fs%cfg%npx) then + do k=fs%cfg%kmino_,fs%cfg%kmaxo_; do j=fs%cfg%jmino_,fs%cfg%jmaxo_ + ! Copy over from imax to imax+1 and above + do i=fs%cfg%imax+1,fs%cfg%imaxo + ! Copy primitive variables + ls%VF(i,j,k)=ls%VF(fs%cfg%imax,j,k) + fs%Q(i,j,k,1)=fs%Q(fs%cfg%imax,j,k,1) + fs%P(i,j,k)=fs%P(fs%cfg%imax,j,k) + fs%I(i,j,k)=fs%I(fs%cfg%imax,j,k) + fs%U(i,j,k)=max(fs%U(fs%cfg%imax,j,k),0.0_WP) + fs%V(i,j,k)=fs%V(fs%cfg%imax,j,k) + fs%W(i,j,k)=fs%W(fs%cfg%imax,j,k) + end do + end do; end do + end if + + ! Apply clipped Neumann on primitive variables in y+ + if (.not.fs%cfg%yper.and.fs%cfg%jproc.eq.fs%cfg%npy) then + do k=fs%cfg%kmino_,fs%cfg%kmaxo_; do i=fs%cfg%imino_,fs%cfg%imaxo_ + ! Copy over from jmax to jmax+1 and above + do j=fs%cfg%jmax+1,fs%cfg%jmaxo + ! Copy primitive variables + ls%VF(i,j,k)=ls%VF(i,fs%cfg%jmax,k) + fs%Q(i,j,k,1)=fs%Q(i,fs%cfg%jmax,k,1) + fs%P(i,j,k)=fs%P(i,fs%cfg%jmax,k) + fs%I(i,j,k)=fs%I(i,fs%cfg%jmax,k) + fs%U(i,j,k)=fs%U(i,fs%cfg%jmax,k) + fs%V(i,j,k)=max(fs%V(i,fs%cfg%jmax,k),0.0_WP) + fs%W(i,j,k)=fs%W(i,fs%cfg%jmax,k) + end do + end do; end do + end if + + ! Apply clipped Neumann on primitive variables in y- + if (.not.fs%cfg%yper.and.fs%cfg%jproc.eq.1) then + do k=fs%cfg%kmino_,fs%cfg%kmaxo_; do i=fs%cfg%imino_,fs%cfg%imaxo_ + ! First copy over V from jmin+1 to jmin + fs%V(i,fs%cfg%jmin,k)=min(fs%V(i,fs%cfg%jmin+1,k),0.0_WP) + ! Then copy over from jmin to jmin-1 and below + do j=fs%cfg%jmino,fs%cfg%jmin-1 + ! Copy primitive variables + ls%VF(i,j,k)=ls%VF(i,fs%cfg%jmin,k) + fs%Q(i,j,k,1)=fs%Q(i,fs%cfg%jmin,k,1) + fs%P(i,j,k)=fs%P(i,fs%cfg%jmin,k) + fs%I(i,j,k)=fs%I(i,fs%cfg%jmin,k) + fs%U(i,j,k)=fs%U(i,fs%cfg%jmin,k) + fs%V(i,j,k)=min(fs%V(i,fs%cfg%jmin,k),0.0_WP) + fs%W(i,j,k)=fs%W(i,fs%cfg%jmin,k) + end do + end do; end do + end if + + ! Apply clipped Neumann on primitive variables in z+ + if (.not.fs%cfg%zper.and.fs%cfg%kproc.eq.fs%cfg%npz) then + do j=fs%cfg%jmino_,fs%cfg%jmaxo_; do i=fs%cfg%imino_,fs%cfg%imaxo_ + ! Copy over from kmax to kmax+1 and above + do k=fs%cfg%kmax+1,fs%cfg%kmaxo + ! Copy primitive variables + ls%VF(i,j,k)=ls%VF(i,j,fs%cfg%kmax) + fs%Q(i,j,k,1)=fs%Q(i,j,fs%cfg%kmax,1) + fs%P(i,j,k)=fs%P(i,j,fs%cfg%kmax) + fs%I(i,j,k)=fs%I(i,j,fs%cfg%kmax) + fs%U(i,j,k)=fs%U(i,j,fs%cfg%kmax) + fs%V(i,j,k)=fs%V(i,j,fs%cfg%kmax) + fs%W(i,j,k)=max(fs%W(i,j,fs%cfg%kmax),0.0_WP) + end do + end do; end do + end if + + ! Apply clipped Neumann on primitive variables in z- + if (.not.fs%cfg%zper.and.fs%cfg%kproc.eq.1) then + do j=fs%cfg%jmino_,fs%cfg%jmaxo_; do i=fs%cfg%imino_,fs%cfg%imaxo_ + ! First copy over W from kmin+1 to kmin + fs%W(i,j,fs%cfg%kmin)=min(fs%W(i,j,fs%cfg%kmin+1),0.0_WP) + ! Then copy over from kmin to kmin-1 and below + do k=fs%cfg%kmino,fs%cfg%kmin-1 + ! Copy primitive variables + ls%VF(i,j,k)=ls%VF(i,j,fs%cfg%kmin) + fs%Q(i,j,k,1)=fs%Q(i,j,fs%cfg%kmin,1) + fs%P(i,j,k)=fs%P(i,j,fs%cfg%kmin) + fs%I(i,j,k)=fs%I(i,j,fs%cfg%kmin) + fs%U(i,j,k)=fs%U(i,j,fs%cfg%kmin) + fs%V(i,j,k)=fs%V(i,j,fs%cfg%kmin) + fs%W(i,j,k)=min(fs%W(i,j,fs%cfg%kmin),0.0_WP) + end do + end do; end do + end if + + ! Rebuild conserved quantities + fs%Q(:,:,:,2)=fs%Q(:,:,:,1)*fs%I + call fs%get_momentum() + + end subroutine apply_bconds + + + !> Initialization of problem solver + subroutine simulation_init + + use param, only: param_read,param_exists + implicit none + + ! Allocate work arrays + allocate_work_arrays: block + allocate(dQdt (cfg%imino_:cfg%imaxo_,cfg%jmino_:cfg%jmaxo_,cfg%kmino_:cfg%kmaxo_,1:5,1:4)) + end block allocate_work_arrays + + ! Initialize time tracker with 2 subiterations + initialize_timetracker: block + time=timetracker(amRoot=cfg%amRoot) + call param_read('Max timestep size',time%dtmax) + call param_read('Max cfl number',time%cflmax) + call param_read('Max time',time%tmax) + time%dt=time%dtmax + time%itmax=2 + end block initialize_timetracker + + + + ! ! Initialize Lagrangian solid solver + ! initialize_lss: block + ! use mpi_f08, only: MPI_ALLREDUCE,MPI_MAX,MPI_INTEGER + ! real(WP) :: dx,mu,kk,max_stretch,Lx,Ly,Lz + ! real(WP) :: xmin,xmax,ymin,ymax,zmin,zmax,ratio,P_load + ! integer :: np,nt,nx,ny,nz,ierr,global_index + ! type triangle_type + ! real(WP), dimension(3) :: norm + ! real(WP), dimension(3) :: v1 + ! real(WP), dimension(3) :: v2 + ! real(WP), dimension(3) :: v3 + ! end type triangle_type + ! type(triangle_type), dimension(:), allocatable :: t + + + ! ! Create solver + ! ls=lss(cfg=cfg,name='solid') + ! !call fs%initialize(cfg=cfg,name='Compressible NS') + + + ! ! Set material properties + ! call param_read('Elastic Modulus',ls%elastic_modulus) + ! call param_read('Poisson Ratio',ls%poisson_ratio) + ! call param_read('Solid density',ls%rho) + ! call param_read('Critical Energy Release Rate',ls%crit_energy) + + ! ! Maximum timestep size used for particles + ! call param_read('Particle timestep size',ls_dt_max,default=huge(1.0_WP)) + ! ls_dt=min(ls_dt_max,time%dtmax) + + ! ! Discretization + ! ! ls%delta=fs%cfg%min_meshsize*1.01 + ! ! Load',P_load) + ! call param_read('Lx',Lx) + ! call param_read('Ly',Ly) + ! call param_read('Lz',Lz) + ! call param_read('Subdivisions',ny) + ! nz = ny + ! nx = NINT(Lx/Lz)*ny + ! call param_read('Horizon Ratio',ratio) + ! ls%delta = Ly/real(ny,WP)*ratio + ! ! Output some info on stretch + ! mu=ls%elastic_modulus/(2.0_WP+2.0_WP*ls%poisson_ratio) + ! kk=ls%elastic_modulus/(3.0_WP-6.0_WP*ls%poisson_ratio) + ! max_stretch=sqrt(ls%crit_energy/((3.0_WP*mu+(kk-5.0_WP*mu/3.0_WP)*0.75_WP**4)*ls%delta)) + + ! ! Only root process initializes solid particles + ! if (ls%cfg%amRoot) then + ! ! Read the STL file and get domain extents and levelset + ! print*, Lx * Ly * Lz / real(ny*nz*nx,WP) + ! read_bin: block + + ! use messager, only: die + ! integer :: p,iunit,ierr, wall_np, i, j, k + ! global_index = 0 + ! target_index = 0 + + ! ! Read in grid definition + ! wall_np = ny*nz*(nx+3) + ! ! call ls%resize(np+wall_np) + ! call ls%resize(wall_np) + ! p=0 + ! do i=1,nx+3 + ! do j=1,ny + ! do k=1,nz + ! p = p+1 + ! ls%p(p)%pos(1) = (i-1) * (Lx/real(nx,WP)) + ! ls%p(p)%pos(2) = (j) * (Ly/real(ny,WP)) - Ly/2.0_WP + ! ls%p(p)%pos(3) = (k) * (Lz/real(nz,WP)) - Lz/2.0_WP + ! ls%p(p)%vol = Lx * Ly * Lz / real(ny*nz*nx,WP) + ! ls%p(p)%id=1 + ! if(i.le.3) ls%p(p)%id=-2 + + ! ls%p(p)%vel=[0.0_WP,0.0_WP,0.0_WP] + ! ! Zero out force + ! ls%p(p)%Abond=0.0_WP + ! ! Zero out fluid unless end, using this for the load + ! ls%p(p)%Afluid=0.0_WP + ! !if(i.eq.nx+3) ls%p(p)%Afluid=[(P_load*Ly*Lz)/(ls%rho*ls%p(p)%vol),0.0_WP,0.0_WP] + ! ! Locate the particle on the mesh + ! ls%p(p)%ind=ls%cfg%get_ijk_global(ls%p(p)%pos,[ls%cfg%imin,ls%cfg%jmin,ls%cfg%kmin]) + ! ! Assign a unique integer to particle + ! ls%p(p)%i=p + ! ! Activate the particle + ! ls%p(p)%flag=0 + ! if(i.eq.(nx/2+1).and.j.eq.(ny/2+1).and.k.eq.(nz/2+1)) target_index = p + ! end do + ! end do + ! end do + + ! np = wall_np + ! end block read_bin + ! end if + + ! ! Allreduce with MPI_MAX ensures the nonzero index propagates to all + ! call MPI_ALLREDUCE(target_index, global_index, 1, MPI_INTEGER, MPI_MAX, ls%cfg%comm, ierr) + + ! ! Update target_index globally + ! target_index = global_index + + + ! ! Communicate particles + ! call ls%sync() + + ! call get_tracked_particle() + + ! ! Get initial volume fraction + ! ! call ls%update_VF() + + ! ! Initalize bonds + ! call ls%bond_init() + + ! if (ls%cfg%amRoot) then + ! print*,"===== Solid Setup Description =====" + ! print*,'Number of particles', np + ! print*,'Maximum stretching =',max_stretch + ! end if + + ! end block initialize_lss + + initialize_lss: block + use mpi_f08, only: MPI_ALLREDUCE,MPI_MAX,MPI_INTEGER + real(WP) :: dx,mu,kk,max_stretch,Lx,Ly,Lz,R,x,y,z,P_load + real(WP) :: xmin,xmax,ymin,ymax,zmin,zmax,ratio,dist + integer :: np,nt,nx,ny,nz,ierr,global_index + type triangle_type + real(WP), dimension(3) :: norm + real(WP), dimension(3) :: v1 + real(WP), dimension(3) :: v2 + real(WP), dimension(3) :: v3 + end type triangle_type + type(triangle_type), dimension(:), allocatable :: t + + + + + ! Create solver + ls=lss(cfg=cfg,name='solid') + !call fs%initialize(cfg=cfg,name='Compressible NS') + + + ! Set material properties + call param_read('Elastic Modulus',ls%elastic_modulus) + call param_read('Poisson Ratio',ls%poisson_ratio) + call param_read('Solid density',ls%rho) + call param_read('Critical Energy Release Rate',ls%crit_energy) + call param_read('Solid Damping Constant',ls%beta) + + ! Maximum timestep size used for particles + call param_read('Particle timestep size',ls_dt_max,default=huge(1.0_WP)) + ls_dt=min(ls_dt_max,time%dtmax) + + ! Discretization + ! ls%delta=fs%cfg%min_meshsize*1.01 + ! Load',P_load) + call param_read('Lx',Lx) + call param_read('Ly',Ly) + call param_read('Lz',Lz) + call param_read('R',R) + call param_read('Solid Spacing',dist) + call param_read('Solid Load',P_load) + ! Lx = 1.0_WP + ! Ly = 1.0_WP + ! dist = 0.01_WP ! Space between particles + Lx = Lx + 6.0_WP * dist + ! Ly = Ly + 3.0_WP * dist + + ny = ceiling(Ly/dist)+1 + nz = ceiling(Lz/dist)+1 + nx = ceiling(Lx/dist) + call param_read('Horizon Ratio',ratio) + ls%delta = dist*ratio + print*, ls%delta + ! Output some info on stretch + mu=ls%elastic_modulus/(2.0_WP+2.0_WP*ls%poisson_ratio) + kk=ls%elastic_modulus/(3.0_WP-6.0_WP*ls%poisson_ratio) + max_stretch=sqrt(ls%crit_energy/((3.0_WP*mu+(kk-5.0_WP*mu/3.0_WP)*0.75_WP**4)*ls%delta)) + + ! Only root process initializes solid particles + if (ls%cfg%amRoot) then + print *, (dist*dist*dist/ls%rho) + ! Read the STL fiprint*, "here" + read_bin: block + + use messager, only: die + integer :: p,iunit,ierr, wall_np, i, j, k + real(WP) :: net_vol + net_vol = 0.0_WP + global_index = 0 + target_index = 0 + ! Read in grid definition + wall_np = (ny)*(nz)*(nx+3) + ! call ls%resize(np+wall_np) + call ls%resize(wall_np) + p=0 + do i=1,nx+3 + do j=1,ny + do k=1,nz + x = (i-4) * dist - Lx/2.0_WP; + y = (j-1) * (dist) - Ly/2.0_WP + z = (k-1) * (dist) - Lz/2.0_WP; + !if ((x*x + y*y).gt.R*R) cycle; + !if (((x)*(x) + y*y + z*z).lt.R*R) cycle; + p = p+1 + + ls%p(p)%pos(1) = x + ls%p(p)%pos(2) = y + ls%p(p)%pos(3) = z + ls%p(p)%ipos=ls%p(p)%pos + ls%p(p)%displacement=0.0_WP + ls%p(p)%vol = dist*dist*dist + ls%p(p)%gd = 1.0_WP + ls%p(p)%gb = 1.0_WP + ls%p(p)%id=1 + if(i.le.6) ls%p(p)%id=-1 + ! if(i.ge.nx-2) ls%p(p)%id=0 + + ls%p(p)%vel=[0.0_WP,0.0_WP,0.0_WP] + ! if(ls%p(p)%id.eq.-1.and.ls%p(p)%pos(1).gt.0) ls%p(p)%vel=[0.01_WP,0.0_WP,0.0_WP] + ! if(ls%p(p)%id.eq.-1.and.ls%p(p)%pos(1).lt.0) ls%p(p)%id=-2 + if(i.ge.(nx+3)-2) net_vol=net_vol+ls%p(p)%vol + ! Zero out force + ls%p(p)%Abond=0.0_WP + ! Zero out fluid unless end, using this for the load + ls%p(p)%Afluid=0.0_WP + if(i.ge.(nx+3)-2) ls%p(p)%Afluid=[(P_load/(dist**3 * ny * nz * 3))/(ls%rho),0.0_WP,0.0_WP] + ! Locate the particle on the mesh + ls%p(p)%ind=ls%cfg%get_ijk_global(ls%p(p)%pos,[ls%cfg%imin,ls%cfg%jmin,ls%cfg%kmin]) + ! Assign a unique integer to particle + ls%p(p)%i=p + ! Activate the particle + ls%p(p)%flag=0 + if(i.eq.(nx/2).and.j.eq.(ny/2).and.k.eq.(nz/2)) target_index = p + end do + end do + end do + + np = wall_np + print*, "Nx: ", nx + print*, "Ny: ", ny + print*, "Nz: ", nz + print*, "Net Force Volume", net_vol + print*, "Used Volume", (dist**3 * ny * nz * 3) + end block read_bin + end if + + ! Allreduce with MPI_MAX ensures the nonzero index propagates to all + call MPI_ALLREDUCE(target_index, global_index, 1, MPI_INTEGER, MPI_MAX, ls%cfg%comm, ierr) + + ! Update target_index globally + target_index = global_index + + + ! Communicate particles + call ls%sync() + + call get_tracked_particle() + + ! Get initial volume fraction + ! call ls%update_VF() + + ! Initalize bonds + call ls%bond_init() + + call ls%get_bond_force() + call ls%sync() + + if (ls%cfg%amRoot) then + print*,"===== Solid Setup Description =====" + print*,'Number of particles', np + print*,'Maximum stretching =',max_stretch + end if + + end block initialize_lss + + + ! Create partmesh object for visualizing Lagrangian particles + create_pmesh: block + use lss_class, only: max_bond + integer :: i,n,nbond + pmesh=partmesh(nvar=6,nvec=3,name='solid') + pmesh%varname(1)='failfrac' + pmesh%varname(2)='dilatation' + pmesh%varname(3)='id' + pmesh%varname(4)='nbond' + pmesh%varname(5)='von-Mises' + pmesh%varname(6)='mw' + + pmesh%vecname(1)='velocity' + pmesh%vecname(2)='bond_force' + pmesh%vecname(3)='disp' + call ls%update_partmesh(pmesh) + do i=1,ls%np_ + pmesh%var(1,i)=0.0_WP + nbond=0 + do n=1,max_bond + if (ls%p(i)%ibond(n).gt.0) nbond=nbond+1 + end do + if (ls%p(i)%nbond.gt.0) then + pmesh%var(1,i)=1.0_WP-real(nbond,WP)/real(ls%p(i)%nbond,WP) + else + pmesh%var(1,i)=0.0_WP + end if + pmesh%var(2,i) =ls%p(i)%dil + pmesh%var(3,i) =ls%p(i)%id + pmesh%vec(:,1,i)=ls%p(i)%vel + pmesh%vec(:,2,i)=ls%p(i)%Abond + pmesh%var(4,i) =ls%p(i)%nbond + pmesh%var(5,i) =ls%p(i)%vonMises + pmesh%vec(:,3,i) =ls%p(i)%displacement + pmesh%var(6,i) =ls%p(i)%mw + + end do + end block create_pmesh + + ! Add Ensight output + create_ensight: block + ! Create Ensight output from cfg + ens_out=ensight(cfg=cfg,name='shock') + ! Create event for Ensight output + ens_evt=event(time=time,name='Ensight output') + call param_read('Ensight output period',ens_evt%tper) + ! Add variables to output + call ens_out%add_particle('particles',pmesh) + ! Output to ensight + if (ens_evt%occurs()) call ens_out%write_data(time%t) + end block create_ensight + + + ! Create monitor files + create_monitor: block + real(WP) :: cfl + ! Prepare some info about fields + call ls%get_cfl(time%dt,time%cfl) + call ls%get_max() + ! Create solid monitor + sfile=monitor(ls%cfg%amRoot,'solid') + call sfile%add_column(time%n,'Timestep number') + call sfile%add_column(time%t,'Time') + call sfile%add_column(ls_dt,'Particle dt') + call sfile%add_column(time%cfl,'Maximum CFL') + call sfile%add_column(ls%np,'Particle number') + call sfile%add_column(ls%VFmax,'VFmax') + call sfile%add_column(ls%Umin,'Particle Umin') + call sfile%add_column(ls%Umax,'Particle Umax') + call sfile%add_column(ls%Vmin,'Particle Vmin') + call sfile%add_column(ls%Vmax,'Particle Vmax') + call sfile%add_column(ls%Wmin,'Particle Wmin') + call sfile%add_column(ls%Wmax,'Particle Wmax') + call sfile%add_column(ls%ibmForce(1),'Particle Fx') + call sfile%add_column(ls%ibmForce(2),'Particle Fy') + call sfile%add_column(ls%ibmForce(3),'Particle Fz') + call sfile%write() + dispfile=monitor(ls%cfg%amRoot,'displacement') + call dispfile%add_column(time%n,'Timestep number') + call dispfile%add_column(time%t,'Time') + call dispfile%add_column(ls_dt,'Particle dt') + call dispfile%add_column(target_position(1),'X') + call dispfile%add_column(target_position(2),'Y') + call dispfile%add_column(target_position(3),'Z') + call dispfile%write() + end block create_monitor + + end subroutine simulation_init + + + !> Perform an NGA2 simulation + subroutine simulation_run + implicit none + real(WP) :: cfl + logical :: first_time + + first_time = .true. + ! Perform time integration + do while (.not.time%done()) + + ! Increment time + call ls%get_cfl(time%dt,time%cfl) + ! call fs%get_cfl(time%dt,cfl); time%cfl=max(time%cfl,cfl) + call time%adjust_dt() + call time%increment() + + ! Advance solid solver + solid: block + real(WP) :: dt_done,mydt + ! Sub-iteratore + call ls%get_cfl(ls_dt,cfl=cfl) + if (cfl.gt.0.0_WP) ls_dt=min(ls_dt*time%cflmax/cfl,ls_dt_max) + dt_done=0.0_WP + do while (dt_done.lt.time%dtmid) + ! Decide the timestep size + if(first_time) then + ! call ls%stretch(dt =mydt) + first_time=.false. + dt_done=dt_done+mydt + else + mydt=min(ls_dt,time%dtmid-dt_done) + ! ! Advance particles + call ls%advance(dt =mydt) + ! ! Increment + dt_done=dt_done+mydt + end if + + + ! mydt=min(ls_dt,time%dtmid-dt_done) + ! ! Advance particles + ! call ls%advance(dt =mydt) + ! ! ! Increment + ! dt_done=dt_done+mydt + + end do + end block solid + + !> Perform and output monitoring + call ls%get_max() + call get_tracked_particle() + call sfile%write() + call dispfile%write() + + + ! Output to ensight + if (ens_evt%occurs()) then + update_pmesh: block + use lss_class, only: max_bond + integer :: i,n,nbond + call ls%update_partmesh(pmesh) + do i=1,ls%np_ + nbond=0 + do n=1,max_bond + if (ls%p(i)%ibond(n).gt.0) nbond=nbond+1 + end do + if (ls%p(i)%nbond.gt.0) then + pmesh%var(1,i)=1.0_WP-real(nbond,WP)/real(ls%p(i)%nbond,WP) + else + pmesh%var(1,i)=0.0_WP + end if + pmesh%var(2,i) =ls%p(i)%dil + pmesh%var(3,i) =ls%p(i)%id + pmesh%vec(:,1,i)=ls%p(i)%vel + pmesh%vec(:,2,i)=ls%p(i)%Abond + pmesh%var(4,i) =ls%p(i)%nbond + pmesh%var(5,i) =ls%p(i)%vonMises + pmesh%vec(:,3,i) =ls%p(i)%displacement + pmesh%var(6,i) =ls%p(i)%mw + + + end do + end block update_pmesh + call ens_out%write_data(time%t) + end if + + end do + + end subroutine simulation_run + + + !> Finalize the NGA2 simulation + subroutine simulation_final + implicit none + + ! Get rid of all objects - need destructors + ! monitor + ! ensight + ! bcond + ! timetracker + + ! Deallocate work arrays + deallocate(dQdt) + end subroutine simulation_final + + +end module simulation diff --git a/examples/beam_tension/src/simulation_stl.f90 b/examples/beam_tension/src/simulation_stl.f90 new file mode 100644 index 000000000..2cf330826 --- /dev/null +++ b/examples/beam_tension/src/simulation_stl.f90 @@ -0,0 +1,753 @@ +!> Various definitions and tools for running an NGA2 simulation +module simulation + use precision, only: WP,SP + use geometry, only: cfg + use spcomp_class, only: spcomp + use lss_class, only: lss + use timetracker_class, only: timetracker + use ensight_class, only: ensight + use partmesh_class, only: partmesh + use event_class, only: event + use monitor_class, only: monitor + implicit none + private + + !> Get a couple linear solvers, an incompressible flow solver and corresponding time tracker + type(spcomp), public :: fs + type(lss), public :: ls + type(timetracker), public :: time + + !> Ensight postprocessing + type(partmesh) :: pmesh + type(ensight) :: ens_out + type(event) :: ens_evt + + !> Simulation monitor file + type(monitor) :: mfile,cflfile,consfile,sfile,dispfile + + public :: simulation_init,simulation_run,simulation_final + + !> Private work arrays + real(WP), dimension(:,:,:,:,:), allocatable :: dQdt + real(WP), dimension(:,:,:) , allocatable :: Ui,Vi,Wi,Ma,beta,visc,visc_t,div + !> Post-shock viscosity and temperature + real(WP) :: visc0,T0 + + !> Equations of state + real(WP) :: Pinf,Gamma,Cv,Prandtl + + !> Flow parameters + real(WP) :: Ms,Xs,Rcyl + real(WP) :: rho1,p1,u1,M1 + real(WP) :: rho2,p2,u2,M2 + real(WP) :: Re + + !> Max timestep size for solid solver + real(WP) :: ls_dt,ls_dt_max + + integer :: target_index + real(WP), dimension(3) :: target_position + + + contains + + + !> Function that returns a smooth Heaviside of thickness delta + real(WP) function Hshock(x,delta) + real(WP), intent(in) :: x,delta + ! Goes from 0 to 1 as x goes from begative to positive + Hshock=1.0_WP/(1.0_WP+exp(-x/delta)) + end function Hshock + + !> P=EOS(RHO,I) + pure real(WP) function get_P(RHO,I) + implicit none + real(WP), intent(in) :: RHO,I + get_P=RHO*I*(Gamma-1.0_WP)-Gamma*Pinf + end function get_P + !> T=f(RHO,P) + pure real(WP) function get_T(RHO,P) + implicit none + real(WP), intent(in) :: RHO,P + get_T=(P+Pinf)/(Cv*RHO*(Gamma-1.0_WP)) + end function get_T + !> RHO=f(T,P) + pure real(WP) function get_RHO(T,P) + implicit none + real(WP), intent(in) :: T,P + get_RHO=(P+Pinf)/(Cv*T*(Gamma-1.0_WP)) + end function get_RHO + !> I=EOS(RHO,P) + pure real(WP) function get_I(RHO,P) + implicit none + real(WP), intent(in) :: RHO,P + get_I=(P+Gamma*Pinf)/(RHO*(Gamma-1.0_WP)) + end function get_I + !> C=f(RHO,P) + pure real(WP) function get_C(RHO,P) + implicit none + real(WP), intent(in) :: RHO,P + get_C=sqrt(Gamma*(P+Pinf)/RHO) + end function get_C + !> S=f(RHO,P) + pure real(WP) function get_S(RHO,P) + implicit none + real(WP), intent(in) :: RHO,P + get_S=Cv*log((P+Pinf)/RHO**Gamma) + end function get_S + + subroutine get_tracked_particle() + use mpi_f08 + implicit none + integer :: i, ierr + real(WP) :: local_pos(3), global_pos(3) + + local_pos = 0.0_WP + + do i=1,ls%np_ + if (ls%p(i)%i.eq.target_index) then + local_pos = ls%p(i)%pos + end if + end do + call MPI_ALLREDUCE(local_pos, global_pos, 3, MPI_DOUBLE_PRECISION, MPI_SUM, ls%cfg%comm, ierr) + + target_position = global_pos + end subroutine + + !> Calculate viscosities + subroutine prepare_viscosities() + implicit none + integer :: i,j,k + real(WP) :: S + ! Get viscosity from Sutherland's law + S=110.4_WP/273.15_WP*T0 + do k=fs%cfg%kmino_,fs%cfg%kmaxo_ + do j=fs%cfg%jmino_,fs%cfg%jmaxo_ + do i=fs%cfg%imino_,fs%cfg%imaxo_ + visc(i,j,k)=visc0*(T0+S)/(fs%T(i,j,k)+S)*(fs%T(i,j,k)/T0)**1.5_WP + end do + end do + end do + ! Get LAD + call fs%get_viscartif(dt=time%dt,beta=beta); fs%BETA=fs%Q(:,:,:,1)*beta + ! Get eddy viscosity + call fs%get_vreman (dt=time%dt,visc=visc_t); fs%VISC=fs%Q(:,:,:,1)*visc_t+visc + ! Recompute thermal conductivity + fs%diff=Gamma*Cv*fs%visc/Prandtl + ! Add LAD + fs%VISC=fs%VISC+0.002_WP*fs%BETA + end subroutine prepare_viscosities + + + !> Calculate velocity divergence + subroutine get_div() + implicit none + integer :: i,j,k + do k=fs%cfg%kmino_,fs%cfg%kmaxo_-1; do j=fs%cfg%jmino_,fs%cfg%jmaxo_-1; do i=fs%cfg%imino_,fs%cfg%imaxo_-1 + div(i,j,k)=fs%dxi*(fs%U(i+1,j,k)-fs%U(i,j,k))+fs%dyi*(fs%V(i,j+1,k)-fs%V(i,j,k))+fs%dzi*(fs%W(i,j,k+1)-fs%W(i,j,k)) + end do; end do; end do + call fs%cfg%sync(div) + if (.not.fs%cfg%xper.and.fs%cfg%iproc.eq.fs%cfg%npx) div(fs%cfg%imaxo,:,:)=div(fs%cfg%imaxo-1,:,:) + if (.not.fs%cfg%yper.and.fs%cfg%jproc.eq.fs%cfg%npy) div(:,fs%cfg%jmaxo,:)=div(:,fs%cfg%jmaxo-1,:) + if (.not.fs%cfg%zper.and.fs%cfg%kproc.eq.fs%cfg%npz) div(:,:,fs%cfg%kmaxo)=div(:,:,fs%cfg%kmaxo-1) + end subroutine get_div + + + !> Overwrite cosnerved variables using volume-of-solid IBM + subroutine apply_ibm() + implicit none + integer :: i,j,k,ii,jj,kk + real(WP) :: sum_VF,sum_VFQ1,sum_VFQ2 + do k=cfg%kmin_,cfg%kmax_ + do j=cfg%jmin_,cfg%jmax_ + do i=cfg%imin_,cfg%imax_ + if (ls%VF(i,j,k).eq.0.0_WP) cycle + ! Neumann: VF-weighted neighbor average for Q(1) and Q(2) + sum_VF=0.0_WP; sum_VFQ1=0.0_WP; sum_VFQ2=0.0_WP + do kk=-1,1; do jj=-1,1; do ii=-1,1 + if (ii.eq.0.and.jj.eq.0.and.kk.eq.0) cycle + sum_VF =sum_VF +(1.0_WP-ls%VF(i+ii,j+jj,k+kk)) + sum_VFQ1=sum_VFQ1+(1.0_WP-ls%VF(i+ii,j+jj,k+kk))*fs%Q(i+ii,j+jj,k+kk,1) + sum_VFQ2=sum_VFQ2+(1.0_WP-ls%VF(i+ii,j+jj,k+kk))*fs%Q(i+ii,j+jj,k+kk,2) + end do; end do; end do + if (sum_VF.gt.0.0_WP) then + fs%Q(i,j,k,1)=(1.0_WP-ls%VF(i,j,k))*fs%Q(i,j,k,1)+ls%VF(i,j,k)*sum_VFQ1/sum_VF + fs%Q(i,j,k,2)=(1.0_WP-ls%VF(i,j,k))*fs%Q(i,j,k,2)+ls%VF(i,j,k)*sum_VFQ2/sum_VF + end if + ! No-slip now that density is determined + fs%Q(i,j,k,3)=(1.0_WP-0.5_WP*(ls%VF(i-1,j,k)+ls%VF(i,j,k)))*fs%Q(i,j,k,3)+0.5_WP*(fs%Q(i-1,j,k,1)+fs%Q(i,j,k,1))*ls%VFU(i,j,k) + fs%Q(i,j,k,4)=(1.0_WP-0.5_WP*(ls%VF(i,j-1,k)+ls%VF(i,j,k)))*fs%Q(i,j,k,4)+0.5_WP*(fs%Q(i,j-1,k,1)+fs%Q(i,j,k,1))*ls%VFV(i,j,k) + fs%Q(i,j,k,5)=(1.0_WP-0.5_WP*(ls%VF(i,j,k-1)+ls%VF(i,j,k)))*fs%Q(i,j,k,5)+0.5_WP*(fs%Q(i,j,k-1,1)+fs%Q(i,j,k,1))*ls%VFW(i,j,k) + end do + end do + end do + ! Communicate + call fs%cfg%sync(fs%Q(:,:,:,1)) + call fs%cfg%sync(fs%Q(:,:,:,2)) + call fs%cfg%sync(fs%Q(:,:,:,3)) + call fs%cfg%sync(fs%Q(:,:,:,4)) + call fs%cfg%sync(fs%Q(:,:,:,5)) + ! Rebuild primitive variables + call fs%get_primitive() + end subroutine apply_ibm + + + !> Apply boundary conditions + subroutine apply_bconds() + implicit none + integer :: i,j,k + + ! Apply clipped Neumann on primitive variables in x+ + if (.not.fs%cfg%xper.and.fs%cfg%iproc.eq.fs%cfg%npx) then + do k=fs%cfg%kmino_,fs%cfg%kmaxo_; do j=fs%cfg%jmino_,fs%cfg%jmaxo_ + ! Copy over from imax to imax+1 and above + do i=fs%cfg%imax+1,fs%cfg%imaxo + ! Copy primitive variables + ls%VF(i,j,k)=ls%VF(fs%cfg%imax,j,k) + fs%Q(i,j,k,1)=fs%Q(fs%cfg%imax,j,k,1) + fs%P(i,j,k)=fs%P(fs%cfg%imax,j,k) + fs%I(i,j,k)=fs%I(fs%cfg%imax,j,k) + fs%U(i,j,k)=max(fs%U(fs%cfg%imax,j,k),0.0_WP) + fs%V(i,j,k)=fs%V(fs%cfg%imax,j,k) + fs%W(i,j,k)=fs%W(fs%cfg%imax,j,k) + end do + end do; end do + end if + + ! Apply clipped Neumann on primitive variables in y+ + if (.not.fs%cfg%yper.and.fs%cfg%jproc.eq.fs%cfg%npy) then + do k=fs%cfg%kmino_,fs%cfg%kmaxo_; do i=fs%cfg%imino_,fs%cfg%imaxo_ + ! Copy over from jmax to jmax+1 and above + do j=fs%cfg%jmax+1,fs%cfg%jmaxo + ! Copy primitive variables + ls%VF(i,j,k)=ls%VF(i,fs%cfg%jmax,k) + fs%Q(i,j,k,1)=fs%Q(i,fs%cfg%jmax,k,1) + fs%P(i,j,k)=fs%P(i,fs%cfg%jmax,k) + fs%I(i,j,k)=fs%I(i,fs%cfg%jmax,k) + fs%U(i,j,k)=fs%U(i,fs%cfg%jmax,k) + fs%V(i,j,k)=max(fs%V(i,fs%cfg%jmax,k),0.0_WP) + fs%W(i,j,k)=fs%W(i,fs%cfg%jmax,k) + end do + end do; end do + end if + + ! Apply clipped Neumann on primitive variables in y- + if (.not.fs%cfg%yper.and.fs%cfg%jproc.eq.1) then + do k=fs%cfg%kmino_,fs%cfg%kmaxo_; do i=fs%cfg%imino_,fs%cfg%imaxo_ + ! First copy over V from jmin+1 to jmin + fs%V(i,fs%cfg%jmin,k)=min(fs%V(i,fs%cfg%jmin+1,k),0.0_WP) + ! Then copy over from jmin to jmin-1 and below + do j=fs%cfg%jmino,fs%cfg%jmin-1 + ! Copy primitive variables + ls%VF(i,j,k)=ls%VF(i,fs%cfg%jmin,k) + fs%Q(i,j,k,1)=fs%Q(i,fs%cfg%jmin,k,1) + fs%P(i,j,k)=fs%P(i,fs%cfg%jmin,k) + fs%I(i,j,k)=fs%I(i,fs%cfg%jmin,k) + fs%U(i,j,k)=fs%U(i,fs%cfg%jmin,k) + fs%V(i,j,k)=min(fs%V(i,fs%cfg%jmin,k),0.0_WP) + fs%W(i,j,k)=fs%W(i,fs%cfg%jmin,k) + end do + end do; end do + end if + + ! Apply clipped Neumann on primitive variables in z+ + if (.not.fs%cfg%zper.and.fs%cfg%kproc.eq.fs%cfg%npz) then + do j=fs%cfg%jmino_,fs%cfg%jmaxo_; do i=fs%cfg%imino_,fs%cfg%imaxo_ + ! Copy over from kmax to kmax+1 and above + do k=fs%cfg%kmax+1,fs%cfg%kmaxo + ! Copy primitive variables + ls%VF(i,j,k)=ls%VF(i,j,fs%cfg%kmax) + fs%Q(i,j,k,1)=fs%Q(i,j,fs%cfg%kmax,1) + fs%P(i,j,k)=fs%P(i,j,fs%cfg%kmax) + fs%I(i,j,k)=fs%I(i,j,fs%cfg%kmax) + fs%U(i,j,k)=fs%U(i,j,fs%cfg%kmax) + fs%V(i,j,k)=fs%V(i,j,fs%cfg%kmax) + fs%W(i,j,k)=max(fs%W(i,j,fs%cfg%kmax),0.0_WP) + end do + end do; end do + end if + + ! Apply clipped Neumann on primitive variables in z- + if (.not.fs%cfg%zper.and.fs%cfg%kproc.eq.1) then + do j=fs%cfg%jmino_,fs%cfg%jmaxo_; do i=fs%cfg%imino_,fs%cfg%imaxo_ + ! First copy over W from kmin+1 to kmin + fs%W(i,j,fs%cfg%kmin)=min(fs%W(i,j,fs%cfg%kmin+1),0.0_WP) + ! Then copy over from kmin to kmin-1 and below + do k=fs%cfg%kmino,fs%cfg%kmin-1 + ! Copy primitive variables + ls%VF(i,j,k)=ls%VF(i,j,fs%cfg%kmin) + fs%Q(i,j,k,1)=fs%Q(i,j,fs%cfg%kmin,1) + fs%P(i,j,k)=fs%P(i,j,fs%cfg%kmin) + fs%I(i,j,k)=fs%I(i,j,fs%cfg%kmin) + fs%U(i,j,k)=fs%U(i,j,fs%cfg%kmin) + fs%V(i,j,k)=fs%V(i,j,fs%cfg%kmin) + fs%W(i,j,k)=min(fs%W(i,j,fs%cfg%kmin),0.0_WP) + end do + end do; end do + end if + + ! Rebuild conserved quantities + fs%Q(:,:,:,2)=fs%Q(:,:,:,1)*fs%I + call fs%get_momentum() + + end subroutine apply_bconds + + + !> Initialization of problem solver + subroutine simulation_init + use param, only: param_read,param_exists + implicit none + + ! Allocate work arrays + allocate_work_arrays: block + allocate(dQdt (cfg%imino_:cfg%imaxo_,cfg%jmino_:cfg%jmaxo_,cfg%kmino_:cfg%kmaxo_,1:5,1:4)) + end block allocate_work_arrays + + ! Initialize time tracker with 2 subiterations + initialize_timetracker: block + time=timetracker(amRoot=cfg%amRoot) + call param_read('Max timestep size',time%dtmax) + call param_read('Max cfl number',time%cflmax) + call param_read('Max time',time%tmax) + time%dt=time%dtmax + time%itmax=2 + end block initialize_timetracker + + + + ! ! Initialize Lagrangian solid solver + ! initialize_lss: block + ! use mpi_f08, only: MPI_ALLREDUCE,MPI_MAX,MPI_INTEGER + ! real(WP) :: dx,mu,kk,max_stretch,Lx,Ly,Lz + ! real(WP) :: xmin,xmax,ymin,ymax,zmin,zmax,ratio,P_load + ! integer :: np,nt,nx,ny,nz,ierr,global_index + ! type triangle_type + ! real(WP), dimension(3) :: norm + ! real(WP), dimension(3) :: v1 + ! real(WP), dimension(3) :: v2 + ! real(WP), dimension(3) :: v3 + ! end type triangle_type + ! type(triangle_type), dimension(:), allocatable :: t + + + ! ! Create solver + ! ls=lss(cfg=cfg,name='solid') + ! !call fs%initialize(cfg=cfg,name='Compressible NS') + + + ! ! Set material properties + ! call param_read('Elastic Modulus',ls%elastic_modulus) + ! call param_read('Poisson Ratio',ls%poisson_ratio) + ! call param_read('Solid density',ls%rho) + ! call param_read('Critical Energy Release Rate',ls%crit_energy) + + ! ! Maximum timestep size used for particles + ! call param_read('Particle timestep size',ls_dt_max,default=huge(1.0_WP)) + ! ls_dt=min(ls_dt_max,time%dtmax) + + ! ! Discretization + ! ! ls%delta=fs%cfg%min_meshsize*1.01 + ! ! Load',P_load) + ! call param_read('Lx',Lx) + ! call param_read('Ly',Ly) + ! call param_read('Lz',Lz) + ! call param_read('Subdivisions',ny) + ! nz = ny + ! nx = NINT(Lx/Lz)*ny + ! call param_read('Horizon Ratio',ratio) + ! ls%delta = Ly/real(ny,WP)*ratio + ! ! Output some info on stretch + ! mu=ls%elastic_modulus/(2.0_WP+2.0_WP*ls%poisson_ratio) + ! kk=ls%elastic_modulus/(3.0_WP-6.0_WP*ls%poisson_ratio) + ! max_stretch=sqrt(ls%crit_energy/((3.0_WP*mu+(kk-5.0_WP*mu/3.0_WP)*0.75_WP**4)*ls%delta)) + + ! ! Only root process initializes solid particles + ! if (ls%cfg%amRoot) then + ! ! Read the STL file and get domain extents and levelset + ! print*, Lx * Ly * Lz / real(ny*nz*nx,WP) + ! read_bin: block + + ! use messager, only: die + ! integer :: p,iunit,ierr, wall_np, i, j, k + ! global_index = 0 + ! target_index = 0 + + ! ! Read in grid definition + ! wall_np = ny*nz*(nx+3) + ! ! call ls%resize(np+wall_np) + ! call ls%resize(wall_np) + ! p=0 + ! do i=1,nx+3 + ! do j=1,ny + ! do k=1,nz + ! p = p+1 + ! ls%p(p)%pos(1) = (i-1) * (Lx/real(nx,WP)) + ! ls%p(p)%pos(2) = (j) * (Ly/real(ny,WP)) - Ly/2.0_WP + ! ls%p(p)%pos(3) = (k) * (Lz/real(nz,WP)) - Lz/2.0_WP + ! ls%p(p)%vol = Lx * Ly * Lz / real(ny*nz*nx,WP) + ! ls%p(p)%id=1 + ! if(i.le.3) ls%p(p)%id=-2 + + ! ls%p(p)%vel=[0.0_WP,0.0_WP,0.0_WP] + ! ! Zero out force + ! ls%p(p)%Abond=0.0_WP + ! ! Zero out fluid unless end, using this for the load + ! ls%p(p)%Afluid=0.0_WP + ! !if(i.eq.nx+3) ls%p(p)%Afluid=[(P_load*Ly*Lz)/(ls%rho*ls%p(p)%vol),0.0_WP,0.0_WP] + ! ! Locate the particle on the mesh + ! ls%p(p)%ind=ls%cfg%get_ijk_global(ls%p(p)%pos,[ls%cfg%imin,ls%cfg%jmin,ls%cfg%kmin]) + ! ! Assign a unique integer to particle + ! ls%p(p)%i=p + ! ! Activate the particle + ! ls%p(p)%flag=0 + ! if(i.eq.(nx/2+1).and.j.eq.(ny/2+1).and.k.eq.(nz/2+1)) target_index = p + ! end do + ! end do + ! end do + + ! np = wall_np + ! end block read_bin + ! end if + + ! ! Allreduce with MPI_MAX ensures the nonzero index propagates to all + ! call MPI_ALLREDUCE(target_index, global_index, 1, MPI_INTEGER, MPI_MAX, ls%cfg%comm, ierr) + + ! ! Update target_index globally + ! target_index = global_index + + + ! ! Communicate particles + ! call ls%sync() + + ! call get_tracked_particle() + + ! ! Get initial volume fraction + ! ! call ls%update_VF() + + ! ! Initalize bonds + ! call ls%bond_init() + + ! if (ls%cfg%amRoot) then + ! print*,"===== Solid Setup Description =====" + ! print*,'Number of particles', np + ! print*,'Maximum stretching =',max_stretch + ! end if + + ! end block initialize_lss + + initialize_lss: block + use mpi_f08, only: MPI_ALLREDUCE,MPI_MAX,MPI_INTEGER + real(WP) :: dx,mu,kk,max_stretch,Lx,Ly,Lz + real(WP) :: xmin,xmax,ymin,ymax,zmin,zmax,ratio,dist,net_vol,center_dist,prev_center_dist + real(WP), dimension(3) :: location + integer :: np,nt,nx,ny,nz,ierr,global_index + type triangle_type + real(WP), dimension(3) :: norm + real(WP), dimension(3) :: v1 + real(WP), dimension(3) :: v2 + real(WP), dimension(3) :: v3 + end type triangle_type + type(triangle_type), dimension(:), allocatable :: t + + + location=[0.5_WP,0.03_WP,0.03_WP] + prev_center_dist=huge(1.0_WP) + + ! Create solver + ls=lss(cfg=cfg,name='solid') + !call fs%initialize(cfg=cfg,name='Compressible NS') + + + ! Set material properties + call param_read('Elastic Modulus',ls%elastic_modulus) + call param_read('Poisson Ratio',ls%poisson_ratio) + call param_read('Solid density',ls%rho) + call param_read('Critical Energy Release Rate',ls%crit_energy) + + ! Maximum timestep size used for particles + call param_read('Particle timestep size',ls_dt_max,default=huge(1.0_WP)) + ls_dt=min(ls_dt_max,time%dtmax) + + ! Discretization + ! ls%delta=fs%cfg%min_meshsize*1.01 + ! Load',P_load) + call param_read('Horizon Ratio',ratio) + call param_read('Mean Particle Spacing',dist) + call param_read('Lx',Lx) + Lx = Lx + 3.015_WP * dist + call param_read('Lz',Lz) + ! print *, Lz + + ls%delta = dist*ratio + print*, "Delta :", ls%delta + print*, "Required Bond Horizon Distance :", 3.0_WP*ls%delta + ! Output some info on stretch + mu=ls%elastic_modulus/(2.0_WP+2.0_WP*ls%poisson_ratio) + kk=ls%elastic_modulus/(3.0_WP-6.0_WP*ls%poisson_ratio) + max_stretch=sqrt(ls%crit_energy/((3.0_WP*mu+(kk-5.0_WP*mu/3.0_WP)*0.75_WP**4)*ls%delta)) + + ! Only root process initializes solid particles + if (ls%cfg%amRoot) then + ! Read the STL file and get domain extents and levelset + read_bin: block + use messager, only: die + integer :: p,iunit,ierr + character(len=80) :: partfile + call param_read('Particle file',partfile) + open(newunit=iunit,file=trim(partfile),access="stream",form="unformatted",action="read",status="old",iostat=ierr) + if(ierr.ne.0) call die('[read_stl] Could not open file: '//trim(partfile)) + read(iunit) np + call ls%resize(np) + do p=1,np + center_dist = 0.0_WP + read(iunit) ls%p(p)%pos(1), ls%p(p)%pos(2), ls%p(p)%pos(3), ls%p(p)%vol + ls%p(p)%id=1 + if(ls%p(p)%pos(1)<=epsilon(1.0_WP)) ls%p(p)%id=-2 + if(ls%p(p)%pos(1)>=(0.1_WP-epsilon(1.0_WP))) ls%p(p)%id=-1 + ls%p(p)%pos(1)=ls%p(p)%pos(1)-Lx/2.0_WP + ! ! print*, -Lz/2.0_WP + ls%p(p)%pos(3)=ls%p(p)%pos(3)-0.00175_WP + ls%p(p)%ipos=ls%p(p)%pos + ls%p(p)%displacement=0.0_WP + ! Set object id and velocity + ls%p(p)%gd = 1.0_WP + ls%p(p)%gb = 1.0_WP + + ls%p(p)%vel=[0.0_WP,0.0_WP,0.0_WP] + if(ls%p(p)%id.eq.-1 ) ls%p(p)%vel=[0.01_WP,0.0_WP,0.0_WP] + + net_vol=net_vol+ls%p(p)%vol + ! Zero out force + ls%p(p)%Abond=0.0_WP + ! Zero out fluid unless end, using this for the load + ls%p(p)%Afluid=0.0_WP + !if(i.eq.nx+3) ls%p(p)%Afluid=[(P_load*Ly*Lz)/(ls%rho*ls%p(p)%vol),0.0_WP,0.0_WP] + ! Locate the particle on the mesh + ls%p(p)%ind=ls%cfg%get_ijk_global(ls%p(p)%pos,[ls%cfg%imin,ls%cfg%jmin,ls%cfg%kmin]) + ! Assign a unique integer to particle + ls%p(p)%i=p + ! Activate the particle + ls%p(p)%flag=0 + center_dist=sqrt(dot_product((ls%p(p)%pos - location),(ls%p(p)%pos - location))) + if(center_dist < prev_center_dist) then + target_index = p + prev_center_dist=center_dist + end if + end do + close(iunit) + print*, "Net Volume: ", net_vol + end block read_bin + end if + + ! Allreduce with MPI_MAX ensures the nonzero index propagates to all + call MPI_ALLREDUCE(target_index, global_index, 1, MPI_INTEGER, MPI_MAX, ls%cfg%comm, ierr) + + ! Update target_index globally + target_index = global_index + + + ! Communicate particles + call ls%sync() + + call get_tracked_particle() + + ! Get initial volume fraction + ! call ls%update_VF() + + ! Initalize bonds + call ls%bond_init() + + if (ls%cfg%amRoot) then + print*,"===== Solid Setup Description =====" + print*,'Number of particles', np + print*,'Maximum stretching =',max_stretch + end if + + end block initialize_lss + + + ! Create partmesh object for visualizing Lagrangian particles + create_pmesh: block + use lss_class, only: max_bond + integer :: i,n,nbond + pmesh=partmesh(nvar=5,nvec=3,name='solid') + pmesh%varname(1)='failfrac' + pmesh%varname(2)='dilatation' + pmesh%varname(3)='id' + pmesh%varname(4)='nbond' + pmesh%varname(5)='von-Mises' + + pmesh%vecname(1)='velocity' + pmesh%vecname(2)='bond_force' + pmesh%vecname(3)='disp' + call ls%update_partmesh(pmesh) + do i=1,ls%np_ + pmesh%var(1,i)=0.0_WP + nbond=0 + do n=1,max_bond + if (ls%p(i)%ibond(n).gt.0) nbond=nbond+1 + end do + if (ls%p(i)%nbond.gt.0) then + pmesh%var(1,i)=1.0_WP-real(nbond,WP)/real(ls%p(i)%nbond,WP) + else + pmesh%var(1,i)=0.0_WP + end if + pmesh%var(2,i) =ls%p(i)%dil + pmesh%var(3,i) =ls%p(i)%id + pmesh%vec(:,1,i)=ls%p(i)%vel + pmesh%vec(:,2,i)=ls%p(i)%Abond + pmesh%var(4,i) =ls%p(i)%nbond + pmesh%var(5,i) =ls%p(i)%vonMises + pmesh%vec(:,3,i) =ls%p(i)%displacement + end do + end block create_pmesh + + ! Add Ensight output + create_ensight: block + ! Create Ensight output from cfg + ens_out=ensight(cfg=cfg,name='shock') + ! Create event for Ensight output + ens_evt=event(time=time,name='Ensight output') + call param_read('Ensight output period',ens_evt%tper) + ! Add variables to output + call ens_out%add_particle('particles',pmesh) + ! Output to ensight + if (ens_evt%occurs()) call ens_out%write_data(time%t) + end block create_ensight + + + ! Create monitor files + create_monitor: block + real(WP) :: cfl + ! Prepare some info about fields + call ls%get_cfl(time%dt,time%cfl) + call ls%get_max() + ! Create solid monitor + sfile=monitor(ls%cfg%amRoot,'solid') + call sfile%add_column(time%n,'Timestep number') + call sfile%add_column(time%t,'Time') + call sfile%add_column(ls_dt,'Particle dt') + call sfile%add_column(time%cfl,'Maximum CFL') + call sfile%add_column(ls%np,'Particle number') + call sfile%add_column(ls%VFmax,'VFmax') + call sfile%add_column(ls%Umin,'Particle Umin') + call sfile%add_column(ls%Umax,'Particle Umax') + call sfile%add_column(ls%Vmin,'Particle Vmin') + call sfile%add_column(ls%Vmax,'Particle Vmax') + call sfile%add_column(ls%Wmin,'Particle Wmin') + call sfile%add_column(ls%Wmax,'Particle Wmax') + call sfile%add_column(ls%ibmForce(1),'Particle Fx') + call sfile%add_column(ls%ibmForce(2),'Particle Fy') + call sfile%add_column(ls%ibmForce(3),'Particle Fz') + call sfile%write() + dispfile=monitor(ls%cfg%amRoot,'displacement') + call dispfile%add_column(time%n,'Timestep number') + call dispfile%add_column(time%t,'Time') + call dispfile%add_column(ls_dt,'Particle dt') + call dispfile%add_column(target_position(1),'X') + call dispfile%add_column(target_position(2),'Y') + call dispfile%add_column(target_position(3),'Z') + call dispfile%write() + end block create_monitor + + end subroutine simulation_init + + + !> Perform an NGA2 simulation + subroutine simulation_run + implicit none + real(WP) :: cfl + logical :: first_time + + first_time = .true. + ! Perform time integration + do while (.not.time%done()) + + ! Increment time + call ls%get_cfl(time%dt,time%cfl) + ! call fs%get_cfl(time%dt,cfl); time%cfl=max(time%cfl,cfl) + call time%adjust_dt() + call time%increment() + + ! Advance solid solver + solid: block + real(WP) :: dt_done,mydt + ! Sub-iteratore + call ls%get_cfl(ls_dt,cfl=cfl) + if (cfl.gt.0.0_WP) ls_dt=min(ls_dt*time%cflmax/cfl,ls_dt_max) + dt_done=0.0_WP + do while (dt_done.lt.time%dtmid) + ! Decide the timestep size + if(first_time) then + call ls%stretch(dt =mydt) + first_time=.false. + dt_done=dt_done+mydt + else + mydt=min(ls_dt,time%dtmid-dt_done) + ! ! Advance particles + call ls%advance(dt =mydt) + ! ! Increment + dt_done=dt_done+mydt + end if + + end do + end block solid + + !> Perform and output monitoring + call ls%get_max() + call get_tracked_particle() + call sfile%write() + call dispfile%write() + + + ! Output to ensight + if (ens_evt%occurs()) then + update_pmesh: block + use lss_class, only: max_bond + integer :: i,n,nbond + call ls%update_partmesh(pmesh) + do i=1,ls%np_ + nbond=0 + do n=1,max_bond + if (ls%p(i)%ibond(n).gt.0) nbond=nbond+1 + end do + if (ls%p(i)%nbond.gt.0) then + pmesh%var(1,i)=1.0_WP-real(nbond,WP)/real(ls%p(i)%nbond,WP) + else + pmesh%var(1,i)=0.0_WP + end if + pmesh%var(2,i) =ls%p(i)%dil + pmesh%var(3,i) =ls%p(i)%id + pmesh%vec(:,1,i)=ls%p(i)%vel + pmesh%vec(:,2,i)=ls%p(i)%Abond + pmesh%var(4,i) =ls%p(i)%nbond + pmesh%var(5,i) =ls%p(i)%vonMises + pmesh%vec(:,3,i) =ls%p(i)%displacement + + + end do + end block update_pmesh + call ens_out%write_data(time%t) + end if + + end do + + end subroutine simulation_run + + + !> Finalize the NGA2 simulation + subroutine simulation_final + implicit none + + ! Get rid of all objects - need destructors + ! monitor + ! ensight + ! bcond + ! timetracker + + ! Deallocate work arrays + deallocate(dQdt) + end subroutine simulation_final + + +end module simulation diff --git a/examples/beam_tension/src/simulation_working.f90 b/examples/beam_tension/src/simulation_working.f90 new file mode 100644 index 000000000..b5584ed0a --- /dev/null +++ b/examples/beam_tension/src/simulation_working.f90 @@ -0,0 +1,775 @@ +!> Various definitions and tools for running an NGA2 simulation +module simulation + use precision, only: WP,SP + use geometry, only: cfg + use spcomp_class, only: spcomp + use lss_class, only: lss + use timetracker_class, only: timetracker + use ensight_class, only: ensight + use partmesh_class, only: partmesh + use event_class, only: event + use monitor_class, only: monitor + implicit none + private + + !> Get a couple linear solvers, an incompressible flow solver and corresponding time tracker + type(spcomp), public :: fs + type(lss), public :: ls + type(timetracker), public :: time + + !> Ensight postprocessing + type(partmesh) :: pmesh + type(ensight) :: ens_out + type(event) :: ens_evt + + !> Simulation monitor file + type(monitor) :: mfile,cflfile,consfile,sfile,dispfile + + public :: simulation_init,simulation_run,simulation_final + + !> Private work arrays + real(WP), dimension(:,:,:,:,:), allocatable :: dQdt + real(WP), dimension(:,:,:) , allocatable :: Ui,Vi,Wi,Ma,beta,visc,visc_t,div + !> Post-shock viscosity and temperature + real(WP) :: visc0,T0 + + !> Equations of state + real(WP) :: Pinf,Gamma,Cv,Prandtl + + !> Flow parameters + real(WP) :: Ms,Xs,Rcyl + real(WP) :: rho1,p1,u1,M1 + real(WP) :: rho2,p2,u2,M2 + real(WP) :: Re + + !> Max timestep size for solid solver + real(WP) :: ls_dt,ls_dt_max + + integer :: target_index + real(WP), dimension(3) :: target_position + + + contains + + + !> Function that returns a smooth Heaviside of thickness delta + real(WP) function Hshock(x,delta) + real(WP), intent(in) :: x,delta + ! Goes from 0 to 1 as x goes from begative to positive + Hshock=1.0_WP/(1.0_WP+exp(-x/delta)) + end function Hshock + + !> P=EOS(RHO,I) + pure real(WP) function get_P(RHO,I) + implicit none + real(WP), intent(in) :: RHO,I + get_P=RHO*I*(Gamma-1.0_WP)-Gamma*Pinf + end function get_P + !> T=f(RHO,P) + pure real(WP) function get_T(RHO,P) + implicit none + real(WP), intent(in) :: RHO,P + get_T=(P+Pinf)/(Cv*RHO*(Gamma-1.0_WP)) + end function get_T + !> RHO=f(T,P) + pure real(WP) function get_RHO(T,P) + implicit none + real(WP), intent(in) :: T,P + get_RHO=(P+Pinf)/(Cv*T*(Gamma-1.0_WP)) + end function get_RHO + !> I=EOS(RHO,P) + pure real(WP) function get_I(RHO,P) + implicit none + real(WP), intent(in) :: RHO,P + get_I=(P+Gamma*Pinf)/(RHO*(Gamma-1.0_WP)) + end function get_I + !> C=f(RHO,P) + pure real(WP) function get_C(RHO,P) + implicit none + real(WP), intent(in) :: RHO,P + get_C=sqrt(Gamma*(P+Pinf)/RHO) + end function get_C + !> S=f(RHO,P) + pure real(WP) function get_S(RHO,P) + implicit none + real(WP), intent(in) :: RHO,P + get_S=Cv*log((P+Pinf)/RHO**Gamma) + end function get_S + + subroutine get_tracked_particle() + use mpi_f08 + implicit none + integer :: i, ierr + real(WP) :: local_pos(3), global_pos(3) + + local_pos = 0.0_WP + + do i=1,ls%np_ + if (ls%p(i)%i.eq.target_index) then + local_pos = ls%p(i)%pos + end if + end do + call MPI_ALLREDUCE(local_pos, global_pos, 3, MPI_DOUBLE_PRECISION, MPI_SUM, ls%cfg%comm, ierr) + + target_position = global_pos + end subroutine + + !> Calculate viscosities + subroutine prepare_viscosities() + implicit none + integer :: i,j,k + real(WP) :: S + ! Get viscosity from Sutherland's law + S=110.4_WP/273.15_WP*T0 + do k=fs%cfg%kmino_,fs%cfg%kmaxo_ + do j=fs%cfg%jmino_,fs%cfg%jmaxo_ + do i=fs%cfg%imino_,fs%cfg%imaxo_ + visc(i,j,k)=visc0*(T0+S)/(fs%T(i,j,k)+S)*(fs%T(i,j,k)/T0)**1.5_WP + end do + end do + end do + ! Get LAD + call fs%get_viscartif(dt=time%dt,beta=beta); fs%BETA=fs%Q(:,:,:,1)*beta + ! Get eddy viscosity + call fs%get_vreman (dt=time%dt,visc=visc_t); fs%VISC=fs%Q(:,:,:,1)*visc_t+visc + ! Recompute thermal conductivity + fs%diff=Gamma*Cv*fs%visc/Prandtl + ! Add LAD + fs%VISC=fs%VISC+0.002_WP*fs%BETA + end subroutine prepare_viscosities + + + !> Calculate velocity divergence + subroutine get_div() + implicit none + integer :: i,j,k + do k=fs%cfg%kmino_,fs%cfg%kmaxo_-1; do j=fs%cfg%jmino_,fs%cfg%jmaxo_-1; do i=fs%cfg%imino_,fs%cfg%imaxo_-1 + div(i,j,k)=fs%dxi*(fs%U(i+1,j,k)-fs%U(i,j,k))+fs%dyi*(fs%V(i,j+1,k)-fs%V(i,j,k))+fs%dzi*(fs%W(i,j,k+1)-fs%W(i,j,k)) + end do; end do; end do + call fs%cfg%sync(div) + if (.not.fs%cfg%xper.and.fs%cfg%iproc.eq.fs%cfg%npx) div(fs%cfg%imaxo,:,:)=div(fs%cfg%imaxo-1,:,:) + if (.not.fs%cfg%yper.and.fs%cfg%jproc.eq.fs%cfg%npy) div(:,fs%cfg%jmaxo,:)=div(:,fs%cfg%jmaxo-1,:) + if (.not.fs%cfg%zper.and.fs%cfg%kproc.eq.fs%cfg%npz) div(:,:,fs%cfg%kmaxo)=div(:,:,fs%cfg%kmaxo-1) + end subroutine get_div + + + !> Overwrite cosnerved variables using volume-of-solid IBM + subroutine apply_ibm() + implicit none + integer :: i,j,k,ii,jj,kk + real(WP) :: sum_VF,sum_VFQ1,sum_VFQ2 + do k=cfg%kmin_,cfg%kmax_ + do j=cfg%jmin_,cfg%jmax_ + do i=cfg%imin_,cfg%imax_ + if (ls%VF(i,j,k).eq.0.0_WP) cycle + ! Neumann: VF-weighted neighbor average for Q(1) and Q(2) + sum_VF=0.0_WP; sum_VFQ1=0.0_WP; sum_VFQ2=0.0_WP + do kk=-1,1; do jj=-1,1; do ii=-1,1 + if (ii.eq.0.and.jj.eq.0.and.kk.eq.0) cycle + sum_VF =sum_VF +(1.0_WP-ls%VF(i+ii,j+jj,k+kk)) + sum_VFQ1=sum_VFQ1+(1.0_WP-ls%VF(i+ii,j+jj,k+kk))*fs%Q(i+ii,j+jj,k+kk,1) + sum_VFQ2=sum_VFQ2+(1.0_WP-ls%VF(i+ii,j+jj,k+kk))*fs%Q(i+ii,j+jj,k+kk,2) + end do; end do; end do + if (sum_VF.gt.0.0_WP) then + fs%Q(i,j,k,1)=(1.0_WP-ls%VF(i,j,k))*fs%Q(i,j,k,1)+ls%VF(i,j,k)*sum_VFQ1/sum_VF + fs%Q(i,j,k,2)=(1.0_WP-ls%VF(i,j,k))*fs%Q(i,j,k,2)+ls%VF(i,j,k)*sum_VFQ2/sum_VF + end if + ! No-slip now that density is determined + fs%Q(i,j,k,3)=(1.0_WP-0.5_WP*(ls%VF(i-1,j,k)+ls%VF(i,j,k)))*fs%Q(i,j,k,3)+0.5_WP*(fs%Q(i-1,j,k,1)+fs%Q(i,j,k,1))*ls%VFU(i,j,k) + fs%Q(i,j,k,4)=(1.0_WP-0.5_WP*(ls%VF(i,j-1,k)+ls%VF(i,j,k)))*fs%Q(i,j,k,4)+0.5_WP*(fs%Q(i,j-1,k,1)+fs%Q(i,j,k,1))*ls%VFV(i,j,k) + fs%Q(i,j,k,5)=(1.0_WP-0.5_WP*(ls%VF(i,j,k-1)+ls%VF(i,j,k)))*fs%Q(i,j,k,5)+0.5_WP*(fs%Q(i,j,k-1,1)+fs%Q(i,j,k,1))*ls%VFW(i,j,k) + end do + end do + end do + ! Communicate + call fs%cfg%sync(fs%Q(:,:,:,1)) + call fs%cfg%sync(fs%Q(:,:,:,2)) + call fs%cfg%sync(fs%Q(:,:,:,3)) + call fs%cfg%sync(fs%Q(:,:,:,4)) + call fs%cfg%sync(fs%Q(:,:,:,5)) + ! Rebuild primitive variables + call fs%get_primitive() + end subroutine apply_ibm + + + !> Apply boundary conditions + subroutine apply_bconds() + implicit none + integer :: i,j,k + + ! Apply clipped Neumann on primitive variables in x+ + if (.not.fs%cfg%xper.and.fs%cfg%iproc.eq.fs%cfg%npx) then + do k=fs%cfg%kmino_,fs%cfg%kmaxo_; do j=fs%cfg%jmino_,fs%cfg%jmaxo_ + ! Copy over from imax to imax+1 and above + do i=fs%cfg%imax+1,fs%cfg%imaxo + ! Copy primitive variables + ls%VF(i,j,k)=ls%VF(fs%cfg%imax,j,k) + fs%Q(i,j,k,1)=fs%Q(fs%cfg%imax,j,k,1) + fs%P(i,j,k)=fs%P(fs%cfg%imax,j,k) + fs%I(i,j,k)=fs%I(fs%cfg%imax,j,k) + fs%U(i,j,k)=max(fs%U(fs%cfg%imax,j,k),0.0_WP) + fs%V(i,j,k)=fs%V(fs%cfg%imax,j,k) + fs%W(i,j,k)=fs%W(fs%cfg%imax,j,k) + end do + end do; end do + end if + + ! Apply clipped Neumann on primitive variables in y+ + if (.not.fs%cfg%yper.and.fs%cfg%jproc.eq.fs%cfg%npy) then + do k=fs%cfg%kmino_,fs%cfg%kmaxo_; do i=fs%cfg%imino_,fs%cfg%imaxo_ + ! Copy over from jmax to jmax+1 and above + do j=fs%cfg%jmax+1,fs%cfg%jmaxo + ! Copy primitive variables + ls%VF(i,j,k)=ls%VF(i,fs%cfg%jmax,k) + fs%Q(i,j,k,1)=fs%Q(i,fs%cfg%jmax,k,1) + fs%P(i,j,k)=fs%P(i,fs%cfg%jmax,k) + fs%I(i,j,k)=fs%I(i,fs%cfg%jmax,k) + fs%U(i,j,k)=fs%U(i,fs%cfg%jmax,k) + fs%V(i,j,k)=max(fs%V(i,fs%cfg%jmax,k),0.0_WP) + fs%W(i,j,k)=fs%W(i,fs%cfg%jmax,k) + end do + end do; end do + end if + + ! Apply clipped Neumann on primitive variables in y- + if (.not.fs%cfg%yper.and.fs%cfg%jproc.eq.1) then + do k=fs%cfg%kmino_,fs%cfg%kmaxo_; do i=fs%cfg%imino_,fs%cfg%imaxo_ + ! First copy over V from jmin+1 to jmin + fs%V(i,fs%cfg%jmin,k)=min(fs%V(i,fs%cfg%jmin+1,k),0.0_WP) + ! Then copy over from jmin to jmin-1 and below + do j=fs%cfg%jmino,fs%cfg%jmin-1 + ! Copy primitive variables + ls%VF(i,j,k)=ls%VF(i,fs%cfg%jmin,k) + fs%Q(i,j,k,1)=fs%Q(i,fs%cfg%jmin,k,1) + fs%P(i,j,k)=fs%P(i,fs%cfg%jmin,k) + fs%I(i,j,k)=fs%I(i,fs%cfg%jmin,k) + fs%U(i,j,k)=fs%U(i,fs%cfg%jmin,k) + fs%V(i,j,k)=min(fs%V(i,fs%cfg%jmin,k),0.0_WP) + fs%W(i,j,k)=fs%W(i,fs%cfg%jmin,k) + end do + end do; end do + end if + + ! Apply clipped Neumann on primitive variables in z+ + if (.not.fs%cfg%zper.and.fs%cfg%kproc.eq.fs%cfg%npz) then + do j=fs%cfg%jmino_,fs%cfg%jmaxo_; do i=fs%cfg%imino_,fs%cfg%imaxo_ + ! Copy over from kmax to kmax+1 and above + do k=fs%cfg%kmax+1,fs%cfg%kmaxo + ! Copy primitive variables + ls%VF(i,j,k)=ls%VF(i,j,fs%cfg%kmax) + fs%Q(i,j,k,1)=fs%Q(i,j,fs%cfg%kmax,1) + fs%P(i,j,k)=fs%P(i,j,fs%cfg%kmax) + fs%I(i,j,k)=fs%I(i,j,fs%cfg%kmax) + fs%U(i,j,k)=fs%U(i,j,fs%cfg%kmax) + fs%V(i,j,k)=fs%V(i,j,fs%cfg%kmax) + fs%W(i,j,k)=max(fs%W(i,j,fs%cfg%kmax),0.0_WP) + end do + end do; end do + end if + + ! Apply clipped Neumann on primitive variables in z- + if (.not.fs%cfg%zper.and.fs%cfg%kproc.eq.1) then + do j=fs%cfg%jmino_,fs%cfg%jmaxo_; do i=fs%cfg%imino_,fs%cfg%imaxo_ + ! First copy over W from kmin+1 to kmin + fs%W(i,j,fs%cfg%kmin)=min(fs%W(i,j,fs%cfg%kmin+1),0.0_WP) + ! Then copy over from kmin to kmin-1 and below + do k=fs%cfg%kmino,fs%cfg%kmin-1 + ! Copy primitive variables + ls%VF(i,j,k)=ls%VF(i,j,fs%cfg%kmin) + fs%Q(i,j,k,1)=fs%Q(i,j,fs%cfg%kmin,1) + fs%P(i,j,k)=fs%P(i,j,fs%cfg%kmin) + fs%I(i,j,k)=fs%I(i,j,fs%cfg%kmin) + fs%U(i,j,k)=fs%U(i,j,fs%cfg%kmin) + fs%V(i,j,k)=fs%V(i,j,fs%cfg%kmin) + fs%W(i,j,k)=min(fs%W(i,j,fs%cfg%kmin),0.0_WP) + end do + end do; end do + end if + + ! Rebuild conserved quantities + fs%Q(:,:,:,2)=fs%Q(:,:,:,1)*fs%I + call fs%get_momentum() + + end subroutine apply_bconds + + + !> Initialization of problem solver + subroutine simulation_init + + use param, only: param_read,param_exists + implicit none + + ! Allocate work arrays + allocate_work_arrays: block + allocate(dQdt (cfg%imino_:cfg%imaxo_,cfg%jmino_:cfg%jmaxo_,cfg%kmino_:cfg%kmaxo_,1:5,1:4)) + end block allocate_work_arrays + + ! Initialize time tracker with 2 subiterations + initialize_timetracker: block + time=timetracker(amRoot=cfg%amRoot) + call param_read('Max timestep size',time%dtmax) + call param_read('Max cfl number',time%cflmax) + call param_read('Max time',time%tmax) + time%dt=time%dtmax + time%itmax=2 + end block initialize_timetracker + + + + ! ! Initialize Lagrangian solid solver + ! initialize_lss: block + ! use mpi_f08, only: MPI_ALLREDUCE,MPI_MAX,MPI_INTEGER + ! real(WP) :: dx,mu,kk,max_stretch,Lx,Ly,Lz + ! real(WP) :: xmin,xmax,ymin,ymax,zmin,zmax,ratio,P_load + ! integer :: np,nt,nx,ny,nz,ierr,global_index + ! type triangle_type + ! real(WP), dimension(3) :: norm + ! real(WP), dimension(3) :: v1 + ! real(WP), dimension(3) :: v2 + ! real(WP), dimension(3) :: v3 + ! end type triangle_type + ! type(triangle_type), dimension(:), allocatable :: t + + + ! ! Create solver + ! ls=lss(cfg=cfg,name='solid') + ! !call fs%initialize(cfg=cfg,name='Compressible NS') + + + ! ! Set material properties + ! call param_read('Elastic Modulus',ls%elastic_modulus) + ! call param_read('Poisson Ratio',ls%poisson_ratio) + ! call param_read('Solid density',ls%rho) + ! call param_read('Critical Energy Release Rate',ls%crit_energy) + + ! ! Maximum timestep size used for particles + ! call param_read('Particle timestep size',ls_dt_max,default=huge(1.0_WP)) + ! ls_dt=min(ls_dt_max,time%dtmax) + + ! ! Discretization + ! ! ls%delta=fs%cfg%min_meshsize*1.01 + ! ! Load',P_load) + ! call param_read('Lx',Lx) + ! call param_read('Ly',Ly) + ! call param_read('Lz',Lz) + ! call param_read('Subdivisions',ny) + ! nz = ny + ! nx = NINT(Lx/Lz)*ny + ! call param_read('Horizon Ratio',ratio) + ! ls%delta = Ly/real(ny,WP)*ratio + ! ! Output some info on stretch + ! mu=ls%elastic_modulus/(2.0_WP+2.0_WP*ls%poisson_ratio) + ! kk=ls%elastic_modulus/(3.0_WP-6.0_WP*ls%poisson_ratio) + ! max_stretch=sqrt(ls%crit_energy/((3.0_WP*mu+(kk-5.0_WP*mu/3.0_WP)*0.75_WP**4)*ls%delta)) + + ! ! Only root process initializes solid particles + ! if (ls%cfg%amRoot) then + ! ! Read the STL file and get domain extents and levelset + ! print*, Lx * Ly * Lz / real(ny*nz*nx,WP) + ! read_bin: block + + ! use messager, only: die + ! integer :: p,iunit,ierr, wall_np, i, j, k + ! global_index = 0 + ! target_index = 0 + + ! ! Read in grid definition + ! wall_np = ny*nz*(nx+3) + ! ! call ls%resize(np+wall_np) + ! call ls%resize(wall_np) + ! p=0 + ! do i=1,nx+3 + ! do j=1,ny + ! do k=1,nz + ! p = p+1 + ! ls%p(p)%pos(1) = (i-1) * (Lx/real(nx,WP)) + ! ls%p(p)%pos(2) = (j) * (Ly/real(ny,WP)) - Ly/2.0_WP + ! ls%p(p)%pos(3) = (k) * (Lz/real(nz,WP)) - Lz/2.0_WP + ! ls%p(p)%vol = Lx * Ly * Lz / real(ny*nz*nx,WP) + ! ls%p(p)%id=1 + ! if(i.le.3) ls%p(p)%id=-2 + + ! ls%p(p)%vel=[0.0_WP,0.0_WP,0.0_WP] + ! ! Zero out force + ! ls%p(p)%Abond=0.0_WP + ! ! Zero out fluid unless end, using this for the load + ! ls%p(p)%Afluid=0.0_WP + ! !if(i.eq.nx+3) ls%p(p)%Afluid=[(P_load*Ly*Lz)/(ls%rho*ls%p(p)%vol),0.0_WP,0.0_WP] + ! ! Locate the particle on the mesh + ! ls%p(p)%ind=ls%cfg%get_ijk_global(ls%p(p)%pos,[ls%cfg%imin,ls%cfg%jmin,ls%cfg%kmin]) + ! ! Assign a unique integer to particle + ! ls%p(p)%i=p + ! ! Activate the particle + ! ls%p(p)%flag=0 + ! if(i.eq.(nx/2+1).and.j.eq.(ny/2+1).and.k.eq.(nz/2+1)) target_index = p + ! end do + ! end do + ! end do + + ! np = wall_np + ! end block read_bin + ! end if + + ! ! Allreduce with MPI_MAX ensures the nonzero index propagates to all + ! call MPI_ALLREDUCE(target_index, global_index, 1, MPI_INTEGER, MPI_MAX, ls%cfg%comm, ierr) + + ! ! Update target_index globally + ! target_index = global_index + + + ! ! Communicate particles + ! call ls%sync() + + ! call get_tracked_particle() + + ! ! Get initial volume fraction + ! ! call ls%update_VF() + + ! ! Initalize bonds + ! call ls%bond_init() + + ! if (ls%cfg%amRoot) then + ! print*,"===== Solid Setup Description =====" + ! print*,'Number of particles', np + ! print*,'Maximum stretching =',max_stretch + ! end if + + ! end block initialize_lss + + initialize_lss: block + use mpi_f08, only: MPI_ALLREDUCE,MPI_MAX,MPI_INTEGER + real(WP) :: dx,mu,kk,max_stretch,Lx,Ly,Lz,R,x,y,z + real(WP) :: xmin,xmax,ymin,ymax,zmin,zmax,ratio,dist + integer :: np,nt,nx,ny,nz,ierr,global_index + type triangle_type + real(WP), dimension(3) :: norm + real(WP), dimension(3) :: v1 + real(WP), dimension(3) :: v2 + real(WP), dimension(3) :: v3 + end type triangle_type + type(triangle_type), dimension(:), allocatable :: t + + + + + ! Create solver + ls=lss(cfg=cfg,name='solid') + !call fs%initialize(cfg=cfg,name='Compressible NS') + + + ! Set material properties + call param_read('Elastic Modulus',ls%elastic_modulus) + call param_read('Poisson Ratio',ls%poisson_ratio) + call param_read('Solid density',ls%rho) + call param_read('Critical Energy Release Rate',ls%crit_energy) + + ! Maximum timestep size used for particles + call param_read('Particle timestep size',ls_dt_max,default=huge(1.0_WP)) + ls_dt=min(ls_dt_max,time%dtmax) + + ! Discretization + ! ls%delta=fs%cfg%min_meshsize*1.01 + ! Load',P_load) + call param_read('Lx',Lx) + call param_read('Ly',Ly) + call param_read('Lz',Lz) + call param_read('R',R) + call param_read('Solid Spacing',dist) + ! Lx = 1.0_WP + ! Ly = 1.0_WP + ! dist = 0.01_WP ! Space between particles + Lx = Lx + 3.0_WP * dist + ! Ly = Ly + 3.0_WP * dist + + ny = ceiling(Ly/dist) + nz = ceiling(Lz/dist) + nx = ceiling(Lx/dist) + call param_read('Horizon Ratio',ratio) + ls%delta = dist*ratio + print*, ls%delta + ! Output some info on stretch + mu=ls%elastic_modulus/(2.0_WP+2.0_WP*ls%poisson_ratio) + kk=ls%elastic_modulus/(3.0_WP-6.0_WP*ls%poisson_ratio) + max_stretch=sqrt(ls%crit_energy/((3.0_WP*mu+(kk-5.0_WP*mu/3.0_WP)*0.75_WP**4)*ls%delta)) + + ! Only root process initializes solid particles + if (ls%cfg%amRoot) then + ! Read the STL fiprint*, "here" + read_bin: block + + use messager, only: die + integer :: p,iunit,ierr, wall_np, i, j, k + real(WP) :: net_vol + net_vol = 0.0_WP + global_index = 0 + target_index = 0 + ! Read in grid definition + wall_np = (ny)*(nz)*(nx) + ! call ls%resize(np+wall_np) + call ls%resize(wall_np) + p=0 + do i=1,nx + do j=1,ny + do k=1,nz + x = (i-1) * dist - Lx/2.0_WP; + y = (j-1) * (dist) - Ly/2.0_WP + z = (k-1) * (dist) - Lz/2.0_WP - dist + if ((x*x + y*y).lt.R*R) cycle; + p = p+1 + + ls%p(p)%pos(1) = x + ls%p(p)%pos(2) = y + ls%p(p)%pos(3) = z + ls%p(p)%ipos=ls%p(p)%pos + ls%p(p)%displacement=0.0_WP + ls%p(p)%vol = dist*dist*dist + ls%p(p)%gd = 1.0_WP + ls%p(p)%gb = 1.0_WP + ls%p(p)%id=1 + if(i.le.3) ls%p(p)%id=-1 + if(i.ge.nx-2) ls%p(p)%id=-1 + + ls%p(p)%vel=[0.0_WP,0.0_WP,0.0_WP] + if(ls%p(p)%id.eq.-1.and.ls%p(p)%pos(1).gt.0) ls%p(p)%vel=[0.01_WP,0.0_WP,0.0_WP] + if(ls%p(p)%id.eq.-1.and.ls%p(p)%pos(1).lt.0) ls%p(p)%id=-2 + ! if(i.gt.3) net_vol=net_vol+ls%p(p)%vol + ! Zero out force + ls%p(p)%Abond=0.0_WP + ! Zero out fluid unless end, using this for the load + ls%p(p)%Afluid=0.0_WP + !if(i.eq.nx+3) ls%p(p)%Afluid=[(P_load*Ly*Lz)/(ls%rho*ls%p(p)%vol),0.0_WP,0.0_WP] + ! Locate the particle on the mesh + ls%p(p)%ind=ls%cfg%get_ijk_global(ls%p(p)%pos,[ls%cfg%imin,ls%cfg%jmin,ls%cfg%kmin]) + ! Assign a unique integer to particle + ls%p(p)%i=p + ! Activate the particle + ls%p(p)%flag=0 + if(i.eq.(nx/2+2).and.j.eq.(5).and.k.eq.(5)) target_index = p + end do + end do + end do + + np = wall_np + print*, "Net Volume: ", net_vol + end block read_bin + end if + + ! Allreduce with MPI_MAX ensures the nonzero index propagates to all + call MPI_ALLREDUCE(target_index, global_index, 1, MPI_INTEGER, MPI_MAX, ls%cfg%comm, ierr) + + ! Update target_index globally + target_index = global_index + + + ! Communicate particles + call ls%sync() + + call get_tracked_particle() + + ! Get initial volume fraction + ! call ls%update_VF() + + ! Initalize bonds + call ls%bond_init() + + if (ls%cfg%amRoot) then + print*,"===== Solid Setup Description =====" + print*,'Number of particles', np + print*,'Maximum stretching =',max_stretch + end if + + end block initialize_lss + + + ! Create partmesh object for visualizing Lagrangian particles + create_pmesh: block + use lss_class, only: max_bond + integer :: i,n,nbond + pmesh=partmesh(nvar=5,nvec=3,name='solid') + pmesh%varname(1)='failfrac' + pmesh%varname(2)='dilatation' + pmesh%varname(3)='id' + pmesh%varname(4)='nbond' + pmesh%varname(5)='von-Mises' + + pmesh%vecname(1)='velocity' + pmesh%vecname(2)='bond_force' + pmesh%vecname(3)='disp' + call ls%update_partmesh(pmesh) + do i=1,ls%np_ + pmesh%var(1,i)=0.0_WP + nbond=0 + do n=1,max_bond + if (ls%p(i)%ibond(n).gt.0) nbond=nbond+1 + end do + if (ls%p(i)%nbond.gt.0) then + pmesh%var(1,i)=1.0_WP-real(nbond,WP)/real(ls%p(i)%nbond,WP) + else + pmesh%var(1,i)=0.0_WP + end if + pmesh%var(2,i) =ls%p(i)%dil + pmesh%var(3,i) =ls%p(i)%id + pmesh%vec(:,1,i)=ls%p(i)%vel + pmesh%vec(:,2,i)=ls%p(i)%Abond + pmesh%var(4,i) =ls%p(i)%nbond + pmesh%var(5,i) =ls%p(i)%vonMises + pmesh%vec(:,3,i) =ls%p(i)%displacement + end do + end block create_pmesh + + ! Add Ensight output + create_ensight: block + ! Create Ensight output from cfg + ens_out=ensight(cfg=cfg,name='shock') + ! Create event for Ensight output + ens_evt=event(time=time,name='Ensight output') + call param_read('Ensight output period',ens_evt%tper) + ! Add variables to output + call ens_out%add_particle('particles',pmesh) + ! Output to ensight + if (ens_evt%occurs()) call ens_out%write_data(time%t) + end block create_ensight + + + ! Create monitor files + create_monitor: block + real(WP) :: cfl + ! Prepare some info about fields + call ls%get_cfl(time%dt,time%cfl) + call ls%get_max() + ! Create solid monitor + sfile=monitor(ls%cfg%amRoot,'solid') + call sfile%add_column(time%n,'Timestep number') + call sfile%add_column(time%t,'Time') + call sfile%add_column(ls_dt,'Particle dt') + call sfile%add_column(time%cfl,'Maximum CFL') + call sfile%add_column(ls%np,'Particle number') + call sfile%add_column(ls%VFmax,'VFmax') + call sfile%add_column(ls%Umin,'Particle Umin') + call sfile%add_column(ls%Umax,'Particle Umax') + call sfile%add_column(ls%Vmin,'Particle Vmin') + call sfile%add_column(ls%Vmax,'Particle Vmax') + call sfile%add_column(ls%Wmin,'Particle Wmin') + call sfile%add_column(ls%Wmax,'Particle Wmax') + call sfile%add_column(ls%ibmForce(1),'Particle Fx') + call sfile%add_column(ls%ibmForce(2),'Particle Fy') + call sfile%add_column(ls%ibmForce(3),'Particle Fz') + call sfile%write() + dispfile=monitor(ls%cfg%amRoot,'displacement') + call dispfile%add_column(time%n,'Timestep number') + call dispfile%add_column(time%t,'Time') + call dispfile%add_column(ls_dt,'Particle dt') + call dispfile%add_column(target_position(1),'X') + call dispfile%add_column(target_position(2),'Y') + call dispfile%add_column(target_position(3),'Z') + call dispfile%write() + end block create_monitor + + end subroutine simulation_init + + + !> Perform an NGA2 simulation + subroutine simulation_run + implicit none + real(WP) :: cfl + logical :: first_time + + first_time = .true. + ! Perform time integration + do while (.not.time%done()) + + ! Increment time + call ls%get_cfl(time%dt,time%cfl) + ! call fs%get_cfl(time%dt,cfl); time%cfl=max(time%cfl,cfl) + call time%adjust_dt() + call time%increment() + + ! Advance solid solver + solid: block + real(WP) :: dt_done,mydt + ! Sub-iteratore + call ls%get_cfl(ls_dt,cfl=cfl) + if (cfl.gt.0.0_WP) ls_dt=min(ls_dt*time%cflmax/cfl,ls_dt_max) + dt_done=0.0_WP + do while (dt_done.lt.time%dtmid) + ! Decide the timestep size + if(first_time) then + call ls%stretch(dt =mydt) + first_time=.false. + dt_done=dt_done+mydt + else + mydt=min(ls_dt,time%dtmid-dt_done) + ! ! Advance particles + call ls%advance(dt =mydt) + ! ! Increment + dt_done=dt_done+mydt + end if + + + ! mydt=min(ls_dt,time%dtmid-dt_done) + ! ! Advance particles + ! call ls%advance(dt =mydt) + ! ! ! Increment + ! dt_done=dt_done+mydt + + end do + end block solid + + !> Perform and output monitoring + call ls%get_max() + call get_tracked_particle() + call sfile%write() + call dispfile%write() + + + ! Output to ensight + if (ens_evt%occurs()) then + update_pmesh: block + use lss_class, only: max_bond + integer :: i,n,nbond + call ls%update_partmesh(pmesh) + do i=1,ls%np_ + nbond=0 + do n=1,max_bond + if (ls%p(i)%ibond(n).gt.0) nbond=nbond+1 + end do + if (ls%p(i)%nbond.gt.0) then + pmesh%var(1,i)=1.0_WP-real(nbond,WP)/real(ls%p(i)%nbond,WP) + else + pmesh%var(1,i)=0.0_WP + end if + pmesh%var(2,i) =ls%p(i)%dil + pmesh%var(3,i) =ls%p(i)%id + pmesh%vec(:,1,i)=ls%p(i)%vel + pmesh%vec(:,2,i)=ls%p(i)%Abond + pmesh%var(4,i) =ls%p(i)%nbond + pmesh%var(5,i) =ls%p(i)%vonMises + pmesh%vec(:,3,i) =ls%p(i)%displacement + + + end do + end block update_pmesh + call ens_out%write_data(time%t) + end if + + end do + + end subroutine simulation_run + + + !> Finalize the NGA2 simulation + subroutine simulation_final + implicit none + + ! Get rid of all objects - need destructors + ! monitor + ! ensight + ! bcond + ! timetracker + + ! Deallocate work arrays + deallocate(dQdt) + end subroutine simulation_final + + +end module simulation diff --git a/examples/beam_tension/src/spcomp_class.f90 b/examples/beam_tension/src/spcomp_class.f90 new file mode 100644 index 000000000..00ec1fe25 --- /dev/null +++ b/examples/beam_tension/src/spcomp_class.f90 @@ -0,0 +1,942 @@ +!> Single phase compressible flow solver class: +!> Provides support for RHS calculation only +module spcomp_class + use precision, only: WP + use string, only: str_medium + use config_class, only: config + use timer_class, only: timer + implicit none + private + + ! Expose type + public :: spcomp + + !> Single phase compressible solver object definition + type :: spcomp + + ! This is the config around which solver is built + class(config), pointer :: cfg + + ! Solver name + character(len=str_medium) :: name='UNNAMED_SPCOMP' + + ! Pointers to functions to evaluate P(RHO,E), T(RHO,P), and C(RHO,P) + procedure(Pfunc_type), pointer, nopass :: getP=>NULL() + procedure(Tfunc_type), pointer, nopass :: getT=>NULL() + procedure(Cfunc_type), pointer, nopass :: getC=>NULL() + procedure(Sfunc_type), pointer, nopass :: getS=>NULL() + + ! Conserved variables: 1=RHO, 2=RHO*I, 3=RHO*U, 4=RHO*V, 5=RHO*W + integer :: nQ + real(WP), dimension(:,:,:,:), allocatable :: Q,Qold + + ! Flow velocity + real(WP), dimension(:,:,:), allocatable :: U,V,W + + ! Internal energy + real(WP), dimension(:,:,:), allocatable :: I + + ! Pressure + real(WP), dimension(:,:,:), allocatable :: P + + ! Temperature + real(WP), dimension(:,:,:), allocatable :: T + + ! Speed of sound + real(WP), dimension(:,:,:), allocatable :: C + + ! Viscosities and heat diffusivity + real(WP), dimension(:,:,:), allocatable :: VISC,BETA,DIFF + + ! Gravitational acceleration + real(WP), dimension(3) :: gravity=0.0_WP + + ! Store mesh info + real(WP) :: dx,dy,dz,dxi,dyi,dzi,vol + + ! CFL numbers + real(WP) :: CFLc_x,CFLc_y,CFLc_z !< Convective CFL numbers + real(WP) :: CFLa_x,CFLa_y,CFLa_z !< Acoustic CFL numbers + real(WP) :: CFLv_x,CFLv_y,CFLv_z !< Viscous CFL numbers + + ! Monitoring quantities for conserved variables + real(WP), dimension(:), allocatable :: Qmin,Qmax,Qint + real(WP) :: RHOKint + real(WP) :: RHOSint + + ! Monitoring quantities for primitive variables + real(WP) :: Umax,Vmax,Wmax !< Velocity stats + real(WP) :: RHOmin,RHOmax !< Density stats + real(WP) :: Imin,Imax !< Internal energy stats + real(WP) :: Pmin,Pmax !< Pressure stats + real(WP) :: Tmin,Tmax !< Temperature stats + + ! Timer + type(timer) :: trhs !< Timer for RHS calculation + + contains + procedure :: print=>spcomp_print !< Output solver to the screen + procedure :: initialize !< Initialize the flow solver + procedure :: finalize !< Finalize the flow solver + procedure :: get_div_stress !< Compute divergence of stress for LSS solver + procedure :: rhs !< Compute rhs of our equations using standard fluxes + procedure :: get_primitive !< Calculate primitive variables from conserved variables + procedure :: get_viscartif !< Calculate artifical bulk kinematic viscosity + procedure :: get_vreman !< Get kinematic eddy viscosity using Vreman's model + procedure :: get_velocity !< Calculate velocity from momentum + procedure :: get_ke !< Calculate kinetic energy per unit mass from velocity + procedure :: get_momentum !< Calculate momentum from velocity + procedure :: interp_vel !< Calculate interpolated velocity + procedure :: get_cfl !< Calculate maximum CFL + procedure :: get_info !< Calculate maximum field values + end type spcomp + + !> Interfaces for user-defined function + abstract interface + !> P=P(RHO,I) + pure real(WP) function Pfunc_type(RHO,I) + import :: WP + implicit none + real(WP), intent(in) :: RHO + real(WP), intent(in) :: I + end function Pfunc_type + !> T=T(RHO,P) + pure real(WP) function Tfunc_type(RHO,P) + import :: WP + implicit none + real(WP), intent(in) :: RHO + real(WP), intent(in) :: P + end function Tfunc_type + !> C=C(RHO,P) + pure real(WP) function Cfunc_type(RHO,P) + import :: WP + implicit none + real(WP), intent(in) :: RHO + real(WP), intent(in) :: P + end function Cfunc_type + !> S=S(RHO,P) + pure real(WP) function Sfunc_type(RHO,P) + import :: WP + implicit none + real(WP), intent(in) :: RHO + real(WP), intent(in) :: P + end function Sfunc_type + end interface + +contains + + + !> Initialization for compressible flow solver + subroutine initialize(this,cfg,name) + use messager, only: die + implicit none + class(spcomp) :: this + class(config), target, intent(in) :: cfg + character(len=*), optional :: name + + ! Set the name for the solver + if (present(name)) this%name=trim(adjustl(name)) + + ! Point to config object + this%cfg=>cfg + + ! Check that config is uniform with at least 2 cells of overlap + if (this%cfg%no.lt.2) call die('[spcomp initialize] spcomp solver requires at least 2 cells of overlap') + if (.not.all([this%cfg%uniform_x,this%cfg%uniform_y,this%cfg%uniform_z])) call die('[spcomp initialize] spcomp solver requires a uniform mesh') + + ! Store constant cell size and its inverse, handle 2D conditions, store cell volume + this%dx=this%cfg%dx(this%cfg%imin_); this%dxi=1.0_WP/this%dx; if (this%cfg%nx.eq.1) this%dxi=0.0_WP + this%dy=this%cfg%dy(this%cfg%jmin_); this%dyi=1.0_WP/this%dy; if (this%cfg%ny.eq.1) this%dyi=0.0_WP + this%dz=this%cfg%dz(this%cfg%kmin_); this%dzi=1.0_WP/this%dz; if (this%cfg%nz.eq.1) this%dzi=0.0_WP + this%vol=this%dx*this%dy*this%dz + + ! Allocate and zero out conserved variables + this%nQ=5 + allocate(this%Q (this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_,1:this%nQ)); this%Q =0.0_WP + allocate(this%Qold(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_,1:this%nQ)); this%Qold=0.0_WP + + ! Conserved variables monitoring + allocate(this%Qmin(1:this%nQ),this%Qmax(1:this%nQ),this%Qint(1:this%nQ)) + + ! Flow velocity + allocate(this%U(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)); this%U=0.0_WP + allocate(this%V(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)); this%V=0.0_WP + allocate(this%W(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)); this%W=0.0_WP + + ! Internal energy + allocate(this%I(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)); this%I=0.0_WP + + ! Pressure + allocate(this%P(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)); this%P=0.0_WP + + ! Temperature + allocate(this%T(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)); this%T=0.0_WP + + ! Speed of sound + allocate(this%C(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)); this%C=0.0_WP + + ! Viscosities and heat diffusivity + allocate(this%VISC(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)); this%VISC=0.0_WP + allocate(this%BETA(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)); this%BETA=0.0_WP + allocate(this%DIFF(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)); this%DIFF=0.0_WP + + ! Create timers + this%trhs=timer(comm=this%cfg%comm,name='RHS') + + end subroutine initialize + + + !> Obtain RHS for all equations + subroutine rhs(this,dQdt) + implicit none + class(spcomp), intent(inout) :: this + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:,1:), intent(out) :: dQdt !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_,1:nVAR) + real(WP), dimension(:,:,:,:), allocatable :: FQx,FQy,FQz + integer :: i,j,k,n + real(WP) :: w,div + real(WP), parameter :: eps=1.0e-15_WP + real(WP), dimension(-2: 0) :: wenop + real(WP), dimension(-1:+1) :: wenom + + ! Start rhs timer + call this%trhs%start() + + ! Zero out RHS + dQdt=0.0_WP + + ! ================================================================ ! + ! ======================== INVISID FLUXES ======================== ! + ! ================================================================ ! + + ! Allocate fluxes of conserved variables + allocate(FQx(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_,1:this%nQ)); FQx=0.0_WP + allocate(FQy(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_,1:this%nQ)); FQy=0.0_WP + allocate(FQz(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_,1:this%nQ)); FQz=0.0_WP + + ! Calculate standard fluxes + do k=this%cfg%kmin_,this%cfg%kmax_+1 + do j=this%cfg%jmin_,this%cfg%jmax_+1 + do i=this%cfg%imin_,this%cfg%imax_+1 + ! X fluxes + ! WENO mass flux + w=weno_weight((abs(this%Q(i-1,j,k,1)-this%Q(i-2,j,k,1))+eps)/(abs(this%Q(i,j,k,1)-this%Q(i-1,j,k,1))+eps)); wenop=0.5_WP*[ -w,1.0_WP+2.0_WP*w,1.0_WP-w] + w=weno_weight((abs(this%Q(i+1,j,k,1)-this%Q(i ,j,k,1))+eps)/(abs(this%Q(i,j,k,1)-this%Q(i-1,j,k,1))+eps)); wenom=0.5_WP*[1.0_WP-w,1.0_WP+2.0_WP*w, -w] + FQx(i,j,k,1)=-0.5_WP*(this%U(i,j,k)+abs(this%U(i,j,k)))*sum(wenop*this%Q(i-2:i ,j,k,1))& + & -0.5_WP*(this%U(i,j,k)-abs(this%U(i,j,k)))*sum(wenom*this%Q(i-1:i+1,j,k,1)) + ! Centered mass flux + !FQx(i,j,k,1)=-this%U(i,j,k)*0.5_WP*sum(this%Q(i-1:i,j,k,1)) + ! WENO internal energy flux + w=weno_weight((abs(this%I(i-1,j,k)-this%I(i-2,j,k))+eps)/(abs(this%I(i,j,k)-this%I(i-1,j,k))+eps)); wenop=0.5_WP*[ -w,1.0_WP+2.0_WP*w,1.0_WP-w] + w=weno_weight((abs(this%I(i+1,j,k)-this%I(i ,j,k))+eps)/(abs(this%I(i,j,k)-this%I(i-1,j,k))+eps)); wenom=0.5_WP*[1.0_WP-w,1.0_WP+2.0_WP*w, -w] + FQx(i,j,k,2)=0.5_WP*(FQx(i,j,k,1)-abs(-FQx(i,j,k,1)))*sum(wenop*this%I(i-2:i ,j,k))& + & +0.5_WP*(FQx(i,j,k,1)+abs(-FQx(i,j,k,1)))*sum(wenom*this%I(i-1:i+1,j,k)) + ! Centered internal energy flux + !FQx(i,j,k,2)=FQx(i,j,k,1)*0.5_WP*sum(this%I(i-1:i,j,k)) + ! Heat flux + FQx(i,j,k,2)=FQx(i,j,k,2)+0.5_WP*(this%DIFF(i-1,j,k)+this%DIFF(i,j,k))*this%dxi*(this%T(i,j,k)-this%T(i-1,j,k)) + ! Y fluxes + ! WENO mass flux + w=weno_weight((abs(this%Q(i,j-1,k,1)-this%Q(i,j-2,k,1))+eps)/(abs(this%Q(i,j,k,1)-this%Q(i,j-1,k,1))+eps)); wenop=0.5_WP*[ -w,1.0_WP+2.0_WP*w,1.0_WP-w] + w=weno_weight((abs(this%Q(i,j+1,k,1)-this%Q(i,j ,k,1))+eps)/(abs(this%Q(i,j,k,1)-this%Q(i,j-1,k,1))+eps)); wenom=0.5_WP*[1.0_WP-w,1.0_WP+2.0_WP*w, -w] + FQy(i,j,k,1)=-0.5_WP*(this%V(i,j,k)+abs(this%V(i,j,k)))*sum(wenop*this%Q(i,j-2:j ,k,1))& + & -0.5_WP*(this%V(i,j,k)-abs(this%V(i,j,k)))*sum(wenom*this%Q(i,j-1:j+1,k,1)) + ! Centered mass flux + !FQy(i,j,k,1)=-this%V(i,j,k)*0.5_WP*sum(this%Q(i,j-1:j,k,1)) + ! WENO internal energy flux + w=weno_weight((abs(this%I(i,j-1,k)-this%I(i,j-2,k))+eps)/(abs(this%I(i,j,k)-this%I(i,j-1,k))+eps)); wenop=0.5_WP*[ -w,1.0_WP+2.0_WP*w,1.0_WP-w] + w=weno_weight((abs(this%I(i,j+1,k)-this%I(i,j ,k))+eps)/(abs(this%I(i,j,k)-this%I(i,j-1,k))+eps)); wenom=0.5_WP*[1.0_WP-w,1.0_WP+2.0_WP*w, -w] + FQy(i,j,k,2)=0.5_WP*(FQy(i,j,k,1)-abs(-FQy(i,j,k,1)))*sum(wenop*this%I(i,j-2:j ,k))& + & +0.5_WP*(FQy(i,j,k,1)+abs(-FQy(i,j,k,1)))*sum(wenom*this%I(i,j-1:j+1,k)) + ! Centered internal energy flux + !FQy(i,j,k,2)=FQy(i,j,k,1)*0.5_WP*sum(this%I(i,j-1:j,k)) + ! Heat flux + FQy(i,j,k,2)=FQy(i,j,k,2)+0.5_WP*(this%DIFF(i,j-1,k)+this%DIFF(i,j,k))*this%dyi*(this%T(i,j,k)-this%T(i,j-1,k)) + ! Z fluxes + ! WENO mass flux + w=weno_weight((abs(this%Q(i,j,k-1,1)-this%Q(i,j,k-2,1))+eps)/(abs(this%Q(i,j,k,1)-this%Q(i,j,k-1,1))+eps)); wenop=0.5_WP*[ -w,1.0_WP+2.0_WP*w,1.0_WP-w] + w=weno_weight((abs(this%Q(i,j,k+1,1)-this%Q(i,j,k ,1))+eps)/(abs(this%Q(i,j,k,1)-this%Q(i,j,k-1,1))+eps)); wenom=0.5_WP*[1.0_WP-w,1.0_WP+2.0_WP*w, -w] + FQz(i,j,k,1)=-0.5_WP*(this%W(i,j,k)+abs(this%W(i,j,k)))*sum(wenop*this%Q(i,j,k-2:k ,1))& + & -0.5_WP*(this%W(i,j,k)-abs(this%W(i,j,k)))*sum(wenom*this%Q(i,j,k-1:k+1,1)) + ! Centered mass flux + !FQz(i,j,k,1)=-this%W(i,j,k)*0.5_WP*sum(this%Q(i,j,k-1:k,1)) + ! WENO internal energy flux + w=weno_weight((abs(this%I(i,j,k-1)-this%I(i,j,k-2))+eps)/(abs(this%I(i,j,k)-this%I(i,j,k-1))+eps)); wenop=0.5_WP*[ -w,1.0_WP+2.0_WP*w,1.0_WP-w] + w=weno_weight((abs(this%I(i,j,k+1)-this%I(i,j,k ))+eps)/(abs(this%I(i,j,k)-this%I(i,j,k-1))+eps)); wenom=0.5_WP*[1.0_WP-w,1.0_WP+2.0_WP*w, -w] + FQz(i,j,k,2)=0.5_WP*(FQz(i,j,k,1)-abs(-FQz(i,j,k,1)))*sum(wenop*this%I(i,j,k-2:k ))& + & +0.5_WP*(FQz(i,j,k,1)+abs(-FQz(i,j,k,1)))*sum(wenom*this%I(i,j,k-1:k+1)) + ! Centered internal energy flux + !FQz(i,j,k,2)=FQz(i,j,k,1)*0.5_WP*sum(this%I(i,j,k-1:k)) + ! Heat flux + FQz(i,j,k,2)=FQz(i,j,k,2)+0.5_WP*(this%DIFF(i,j,k-1)+this%DIFF(i,j,k))*this%dzi*(this%T(i,j,k)-this%T(i,j,k-1)) + end do + end do + end do + + ! Mass fluxes will be used to build momentum fluxes, they need to be extended by one cell on the left because of staggering + call this%cfg%sync(FQx(:,:,:,1)); if (.not.this%cfg%xper.and.this%cfg%iproc.eq.1) FQx(this%cfg%imin-1,:,:,1)=FQx(this%cfg%imin,:,:,1) + call this%cfg%sync(FQy(:,:,:,1)); if (.not.this%cfg%yper.and.this%cfg%jproc.eq.1) FQy(:,this%cfg%jmin-1,:,1)=FQy(:,this%cfg%jmin,:,1) + call this%cfg%sync(FQz(:,:,:,1)); if (.not.this%cfg%zper.and.this%cfg%kproc.eq.1) FQz(:,:,this%cfg%kmin-1,1)=FQz(:,:,this%cfg%kmin,1) + + ! Calculate cell-centered momentum fluxes with extra cell on the left due to staggering + do k=this%cfg%kmin_-1,this%cfg%kmax_ + do j=this%cfg%jmin_-1,this%cfg%jmax_ + do i=this%cfg%imin_-1,this%cfg%imax_ + FQx(i,j,k,3)=0.25_WP*sum(FQx(i:i+1,j,k,1))*sum(this%U(i:i+1,j,k))-this%P(i,j,k) + FQy(i,j,k,4)=0.25_WP*sum(FQy(i,j:j+1,k,1))*sum(this%V(i,j:j+1,k))-this%P(i,j,k) + FQz(i,j,k,5)=0.25_WP*sum(FQz(i,j,k:k+1,1))*sum(this%W(i,j,k:k+1))-this%P(i,j,k) + end do + end do + end do + + ! Calculate edge-centered momentum fluxes + do k=this%cfg%kmin_,this%cfg%kmax_+1 + do j=this%cfg%jmin_,this%cfg%jmax_+1 + do i=this%cfg%imin_,this%cfg%imax_+1 + FQy(i,j,k,3)=0.25_WP*sum(FQy(i-1:i,j,k,1))*sum(this%U(i,j-1:j,k)) + FQz(i,j,k,3)=0.25_WP*sum(FQz(i-1:i,j,k,1))*sum(this%U(i,j,k-1:k)) + FQx(i,j,k,4)=0.25_WP*sum(FQx(i,j-1:j,k,1))*sum(this%V(i-1:i,j,k)) + FQz(i,j,k,4)=0.25_WP*sum(FQz(i,j-1:j,k,1))*sum(this%V(i,j,k-1:k)) + FQx(i,j,k,5)=0.25_WP*sum(FQx(i,j,k-1:k,1))*sum(this%W(i-1:i,j,k)) + FQy(i,j,k,5)=0.25_WP*sum(FQy(i,j,k-1:k,1))*sum(this%W(i,j-1:j,k)) + end do + end do + end do + + ! Assemble time derivative for conserved variables + do k=this%cfg%kmin_,this%cfg%kmax_ + do j=this%cfg%jmin_,this%cfg%jmax_ + do i=this%cfg%imin_,this%cfg%imax_ + ! Mass and internal energy advection + dQdt(i,j,k,1)=this%dxi*(FQx(i+1,j,k,1)-FQx(i,j,k,1))+this%dyi*(FQy(i,j+1,k,1)-FQy(i,j,k,1))+this%dzi*(FQz(i,j,k+1,1)-FQz(i,j,k,1)) + dQdt(i,j,k,2)=this%dxi*(FQx(i+1,j,k,2)-FQx(i,j,k,2))+this%dyi*(FQy(i,j+1,k,2)-FQy(i,j,k,2))+this%dzi*(FQz(i,j,k+1,2)-FQz(i,j,k,2)) + ! Momentum advection and pressure stress + dQdt(i,j,k,3)=this%dxi*(FQx(i ,j,k,3)-FQx(i-1,j,k,3))+this%dyi*(FQy(i,j+1,k,3)-FQy(i,j ,k,3))+this%dzi*(FQz(i,j,k+1,3)-FQz(i,j,k ,3)) + dQdt(i,j,k,4)=this%dxi*(FQx(i+1,j,k,4)-FQx(i ,j,k,4))+this%dyi*(FQy(i,j ,k,4)-FQy(i,j-1,k,4))+this%dzi*(FQz(i,j,k+1,4)-FQz(i,j,k ,4)) + dQdt(i,j,k,5)=this%dxi*(FQx(i+1,j,k,5)-FQx(i ,j,k,5))+this%dyi*(FQy(i,j+1,k,5)-FQy(i,j ,k,5))+this%dzi*(FQz(i,j,k ,5)-FQz(i,j,k-1,5)) + ! Pressure dilatation term + dQdt(i,j,k,2)=dQdt(i,j,k,2)-this%P(i,j,k)*(this%dxi*(this%U(i+1,j,k)-this%U(i,j,k))+this%dyi*(this%V(i,j+1,k)-this%V(i,j,k))+this%dzi*(this%W(i,j,k+1)-this%W(i,j,k))) + end do + end do + end do + + ! ================================================================ ! + ! ======================== VISCOUS FLUXES ======================= ! + ! ================================================================ ! + + ! Zero out fluxes + FQx=0.0_WP; FQy=0.0_WP; FQz=0.0_WP + + ! Compute cell-centered momentum viscous fluxes + do k=this%cfg%kmin_-1,this%cfg%kmax_ + do j=this%cfg%jmin_-1,this%cfg%jmax_ + do i=this%cfg%imin_-1,this%cfg%imax_ + div=this%dxi*(this%U(i+1,j,k)-this%U(i,j,k))+this%dyi*(this%V(i,j+1,k)-this%V(i,j,k))+this%dzi*(this%W(i,j,k+1)-this%W(i,j,k)) + FQx(i,j,k,3)=2.0_WP*this%VISC(i,j,k)*this%dxi*(this%U(i+1,j,k)-this%U(i,j,k))+(this%BETA(i,j,k)-2.0_WP*this%VISC(i,j,k)/3.0_WP)*div + FQy(i,j,k,4)=2.0_WP*this%VISC(i,j,k)*this%dyi*(this%V(i,j+1,k)-this%V(i,j,k))+(this%BETA(i,j,k)-2.0_WP*this%VISC(i,j,k)/3.0_WP)*div + FQz(i,j,k,5)=2.0_WP*this%VISC(i,j,k)*this%dzi*(this%W(i,j,k+1)-this%W(i,j,k))+(this%BETA(i,j,k)-2.0_WP*this%VISC(i,j,k)/3.0_WP)*div + end do + end do + end do + + ! Compute edge-centered momentum viscous fluxes and corresponding viscous heating + do k=this%cfg%kmin_,this%cfg%kmax_+1 + do j=this%cfg%jmin_,this%cfg%jmax_+1 + do i=this%cfg%imin_,this%cfg%imax_+1 + FQy(i,j,k,3)=0.25_WP*sum(this%VISC(i-1:i,j-1:j,k))*(this%dyi*(this%U(i,j,k)-this%U(i,j-1,k))+this%dxi*(this%V(i,j,k)-this%V(i-1,j,k))); FQx(i,j,k,4)=FQy(i,j,k,3) + FQz(i,j,k,2)=FQy(i,j,k,3)*(this%dyi*(this%U(i,j,k)-this%U(i,j-1,k))+this%dxi*(this%V(i,j,k)-this%V(i-1,j,k))) + FQz(i,j,k,4)=0.25_WP*sum(this%VISC(i,j-1:j,k-1:k))*(this%dzi*(this%V(i,j,k)-this%V(i,j,k-1))+this%dyi*(this%W(i,j,k)-this%W(i,j-1,k))); FQy(i,j,k,5)=FQz(i,j,k,4) + FQx(i,j,k,2)=FQz(i,j,k,4)*(this%dzi*(this%V(i,j,k)-this%V(i,j,k-1))+this%dyi*(this%W(i,j,k)-this%W(i,j-1,k))) + FQx(i,j,k,5)=0.25_WP*sum(this%VISC(i-1:i,j,k-1:k))*(this%dxi*(this%W(i,j,k)-this%W(i-1,j,k))+this%dzi*(this%U(i,j,k)-this%U(i,j,k-1))); FQz(i,j,k,3)=FQx(i,j,k,5) + FQy(i,j,k,2)=FQx(i,j,k,5)*(this%dxi*(this%W(i,j,k)-this%W(i-1,j,k))+this%dzi*(this%U(i,j,k)-this%U(i,j,k-1))) + end do + end do + end do + + ! Assemble time derivative for conserved variables + do k=this%cfg%kmin_,this%cfg%kmax_ + do j=this%cfg%jmin_,this%cfg%jmax_ + do i=this%cfg%imin_,this%cfg%imax_ + ! Viscous momentum transport + dQdt(i,j,k,3)=dQdt(i,j,k,3)+this%dxi*(FQx(i ,j,k,3)-FQx(i-1,j,k,3))+this%dyi*(FQy(i,j+1,k,3)-FQy(i,j ,k,3))+this%dzi*(FQz(i,j,k+1,3)-FQz(i,j,k ,3)) + dQdt(i,j,k,4)=dQdt(i,j,k,4)+this%dxi*(FQx(i+1,j,k,4)-FQx(i ,j,k,4))+this%dyi*(FQy(i,j ,k,4)-FQy(i,j-1,k,4))+this%dzi*(FQz(i,j,k+1,4)-FQz(i,j,k ,4)) + dQdt(i,j,k,5)=dQdt(i,j,k,5)+this%dxi*(FQx(i+1,j,k,5)-FQx(i ,j,k,5))+this%dyi*(FQy(i,j+1,k,5)-FQy(i,j ,k,5))+this%dzi*(FQz(i,j,k ,5)-FQz(i,j,k-1,5)) + ! Viscous heating term + dQdt(i,j,k,2)=dQdt(i,j,k,2)+FQx(i,j,k,3)*this%dxi*(this%U(i+1,j,k)-this%U(i,j,k))+FQy(i,j,k,4)*this%dyi*(this%V(i,j+1,k)-this%V(i,j,k))+FQz(i,j,k,5)*this%dzi*(this%W(i,j,k+1)-this%W(i,j,k))+0.25_WP*sum(FQz(i:i+1,j:j+1,k,2))+0.25_WP*sum(FQx(i,j:j+1,k:k+1,2))+0.25_WP*sum(FQy(i:i+1,j,k:k+1,2)) + end do + end do + end do + + ! Deallocate flux arrays + deallocate(FQx,FQy,FQz) + + ! Synchronize all dQdt fields + do n=1,this%nQ; call this%cfg%sync(dQdt(:,:,:,n)); end do + + ! Stop rhs timer + call this%trhs%stop() + + contains + !> WENO switch function + real(WP) function weno_weight(ratio) + implicit none + real(WP), intent(in) :: ratio + real(WP), parameter :: lambda=0.13_WP ! Switching parameter + real(WP), parameter :: delta=0.01_WP ! Switching thickness + weno_weight=(1.0_WP-tanh((ratio-lambda)/delta))/3.0_WP+(1.0_WP-tanh((ratio-1.0_WP/lambda)/delta))/6.0_WP + end function weno_weight + end subroutine rhs + + + !> Calculate divergence of stress for LPT solver + subroutine get_div_stress(this,divx,divy,divz) + implicit none + class(spcomp), intent(inout) :: this + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(out) :: divx !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(out) :: divy !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(out) :: divz !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + real(WP), dimension(:,:,:,:), allocatable :: FQx,FQy,FQz + integer :: i,j,k + real(WP) :: div + + ! Zero out divergence of stresses + divx=0.0_WP + divy=0.0_WP + divz=0.0_WP + + ! Allocate fluxes of conserved variables + allocate(FQx(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_,1:3)); FQx=0.0_WP + allocate(FQy(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_,1:3)); FQy=0.0_WP + allocate(FQz(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_,1:3)); FQz=0.0_WP + + ! Compute cell-centered momentum fluxes + do k=this%cfg%kmin_-1,this%cfg%kmax_ + do j=this%cfg%jmin_-1,this%cfg%jmax_ + do i=this%cfg%imin_-1,this%cfg%imax_ + div=this%dxi*(this%U(i+1,j,k)-this%U(i,j,k))+this%dyi*(this%V(i,j+1,k)-this%V(i,j,k))+this%dzi*(this%W(i,j,k+1)-this%W(i,j,k)) + FQx(i,j,k,1)=2.0_WP*this%VISC(i,j,k)*this%dxi*(this%U(i+1,j,k)-this%U(i,j,k))+(this%BETA(i,j,k)-2.0_WP*this%VISC(i,j,k)/3.0_WP)*div-this%P(i,j,k) + FQy(i,j,k,2)=2.0_WP*this%VISC(i,j,k)*this%dyi*(this%V(i,j+1,k)-this%V(i,j,k))+(this%BETA(i,j,k)-2.0_WP*this%VISC(i,j,k)/3.0_WP)*div-this%P(i,j,k) + FQz(i,j,k,3)=2.0_WP*this%VISC(i,j,k)*this%dzi*(this%W(i,j,k+1)-this%W(i,j,k))+(this%BETA(i,j,k)-2.0_WP*this%VISC(i,j,k)/3.0_WP)*div-this%P(i,j,k) + end do + end do + end do + + ! Compute edge-centered momentum viscous fluxes and corresponding viscous heating + do k=this%cfg%kmin_,this%cfg%kmax_+1 + do j=this%cfg%jmin_,this%cfg%jmax_+1 + do i=this%cfg%imin_,this%cfg%imax_+1 + ! Momentum fluxes + FQy(i,j,k,1)=0.25_WP*sum(this%VISC(i-1:i,j-1:j,k))*(this%dyi*(this%U(i,j,k)-this%U(i,j-1,k))+this%dxi*(this%V(i,j,k)-this%V(i-1,j,k))); FQx(i,j,k,2)=FQy(i,j,k,1) + FQz(i,j,k,2)=0.25_WP*sum(this%VISC(i,j-1:j,k-1:k))*(this%dzi*(this%V(i,j,k)-this%V(i,j,k-1))+this%dyi*(this%W(i,j,k)-this%W(i,j-1,k))); FQy(i,j,k,3)=FQz(i,j,k,2) + FQx(i,j,k,3)=0.25_WP*sum(this%VISC(i-1:i,j,k-1:k))*(this%dxi*(this%W(i,j,k)-this%W(i-1,j,k))+this%dzi*(this%U(i,j,k)-this%U(i,j,k-1))); FQz(i,j,k,1)=FQx(i,j,k,3) + end do + end do + end do + + do i=1,3 + call this%cfg%sync(FQx(:,:,:,i)) + call this%cfg%sync(FQy(:,:,:,i)) + call this%cfg%sync(FQz(:,:,:,i)) + end do + + ! Assemble time derivative for conserved variables + do k=this%cfg%kmin_,this%cfg%kmax_ + do j=this%cfg%jmin_,this%cfg%jmax_ + do i=this%cfg%imin_,this%cfg%imax_ + ! Viscous momentum transport + divx(i,j,k)=this%dxi*(FQx(i ,j,k,1)-FQx(i-1,j,k,1))+this%dyi*(FQy(i,j+1,k,1)-FQy(i,j ,k,1))+this%dzi*(FQz(i,j,k+1,1)-FQz(i,j,k ,1)) + divy(i,j,k)=this%dxi*(FQx(i+1,j,k,2)-FQx(i ,j,k,2))+this%dyi*(FQy(i,j ,k,2)-FQy(i,j-1,k,2))+this%dzi*(FQz(i,j,k+1,2)-FQz(i,j,k ,2)) + divz(i,j,k)=this%dxi*(FQx(i+1,j,k,3)-FQx(i ,j,k,3))+this%dyi*(FQy(i,j+1,k,3)-FQy(i,j ,k,3))+this%dzi*(FQz(i,j,k ,3)-FQz(i,j,k-1,3)) + end do + end do + end do + + ! Deallocate flux arrays + deallocate(FQx,FQy,FQz) + + ! Synchronize + call this%cfg%sync(divx) + call this%cfg%sync(divy) + call this%cfg%sync(divz) + + end subroutine get_div_stress + + + !> Calculate all primitive variables from updated conserved variables + subroutine get_primitive(this) + implicit none + class(spcomp), intent(inout) :: this + integer :: i,j,k + ! Get velocity + call this%get_velocity() + ! Get primitive variables + do k=this%cfg%kmino_,this%cfg%kmaxo_; do j=this%cfg%jmino_,this%cfg%jmaxo_; do i=this%cfg%imino_,this%cfg%imaxo_ + this%I(i,j,k)=this%Q(i,j,k,2)/this%Q(i,j,k,1) + this%P(i,j,k)=this%getP(this%Q(i,j,k,1),this%I(i,j,k)) + this%C(i,j,k)=this%getC(this%Q(i,j,k,1),this%P(i,j,k)) + end do; end do; end do + ! Get temperature + if (associated(this%getT)) then + do k=this%cfg%kmino_,this%cfg%kmaxo_; do j=this%cfg%jmino_,this%cfg%jmaxo_; do i=this%cfg%imino_,this%cfg%imaxo_ + this%T(i,j,k)=this%getT(this%Q(i,j,k,1),this%P(i,j,k)) + end do; end do; end do + end if + end subroutine get_primitive + + + !> Calculate velocity from momentum and density + subroutine get_velocity(this) + implicit none + class(spcomp), intent(inout) :: this + integer :: i,j,k + ! Calculate velocity as far as possible + do k=this%cfg%kmino_+1,this%cfg%kmaxo_ + do j=this%cfg%jmino_+1,this%cfg%jmaxo_ + do i=this%cfg%imino_+1,this%cfg%imaxo_ + this%U(i,j,k)=2.0_WP*this%Q(i,j,k,3)/sum(this%Q(i-1:i,j,k,1)) + this%V(i,j,k)=2.0_WP*this%Q(i,j,k,4)/sum(this%Q(i,j-1:j,k,1)) + this%W(i,j,k)=2.0_WP*this%Q(i,j,k,5)/sum(this%Q(i,j,k-1:k,1)) + end do + end do + end do + ! Sync velocity + call this%cfg%sync(this%U) + call this%cfg%sync(this%V) + call this%cfg%sync(this%W) + ! Add last layer in each direction + if (.not.this%cfg%xper.and.this%cfg%iproc.eq.1) then + this%U(this%cfg%imino,:,:)=this%Q(this%cfg%imino,:,:,3)/(this%Q(this%cfg%imino,:,:,1)) + this%V(this%cfg%imino,:,:)=this%Q(this%cfg%imino,:,:,4)/(this%Q(this%cfg%imino,:,:,1)) + this%W(this%cfg%imino,:,:)=this%Q(this%cfg%imino,:,:,5)/(this%Q(this%cfg%imino,:,:,1)) + end if + if (.not.this%cfg%yper.and.this%cfg%jproc.eq.1) then + this%U(:,this%cfg%jmino,:)=this%Q(:,this%cfg%jmino,:,3)/(this%Q(:,this%cfg%jmino,:,1)) + this%V(:,this%cfg%jmino,:)=this%Q(:,this%cfg%jmino,:,4)/(this%Q(:,this%cfg%jmino,:,1)) + this%W(:,this%cfg%jmino,:)=this%Q(:,this%cfg%jmino,:,5)/(this%Q(:,this%cfg%jmino,:,1)) + end if + if (.not.this%cfg%zper.and.this%cfg%kproc.eq.1) then + this%U(:,:,this%cfg%kmino)=this%Q(:,:,this%cfg%kmino,3)/(this%Q(:,:,this%cfg%kmino,1)) + this%V(:,:,this%cfg%kmino)=this%Q(:,:,this%cfg%kmino,4)/(this%Q(:,:,this%cfg%kmino,1)) + this%W(:,:,this%cfg%kmino)=this%Q(:,:,this%cfg%kmino,5)/(this%Q(:,:,this%cfg%kmino,1)) + end if + end subroutine get_velocity + + + !> Calculate kinetic energy per unit mass from pre-calculated velocity + !> Need to redo this better + subroutine get_ke(this,KE) + implicit none + class(spcomp), intent(inout) :: this + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(out) :: KE !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + integer :: i,j,k + do k=this%cfg%kmino_,this%cfg%kmaxo_-1 + do j=this%cfg%jmino_,this%cfg%jmaxo_-1 + do i=this%cfg%imino_,this%cfg%imaxo_-1 + KE(i,j,k)=0.5_WP*sum(this%U(i:i+1,j,k)**2+this%V(i,j:j+1,k)**2+this%W(i,j,k:k+1)**2) + end do + end do + end do + call this%cfg%sync(KE) + if (.not.this%cfg%xper.and.this%cfg%iproc.eq.this%cfg%npx) KE(this%cfg%imaxo,:,:)=KE(this%cfg%imaxo-1,:,:) + if (.not.this%cfg%yper.and.this%cfg%jproc.eq.this%cfg%npy) KE(:,this%cfg%jmaxo,:)=KE(:,this%cfg%jmaxo-1,:) + if (.not.this%cfg%zper.and.this%cfg%kproc.eq.this%cfg%npz) KE(:,:,this%cfg%kmaxo)=KE(:,:,this%cfg%kmaxo-1) + end subroutine get_ke + + + !> Calculate momentum from velocity and density + subroutine get_momentum(this) + implicit none + class(spcomp), intent(inout) :: this + integer :: i,j,k + ! Calculate momentum as far as possible + do k=this%cfg%kmino_+1,this%cfg%kmaxo_ + do j=this%cfg%jmino_+1,this%cfg%jmaxo_ + do i=this%cfg%imino_+1,this%cfg%imaxo_ + this%Q(i,j,k,3)=0.5_WP*sum(this%Q(i-1:i,j,k,1))*this%U(i,j,k) + this%Q(i,j,k,4)=0.5_WP*sum(this%Q(i,j-1:j,k,1))*this%V(i,j,k) + this%Q(i,j,k,5)=0.5_WP*sum(this%Q(i,j,k-1:k,1))*this%W(i,j,k) + end do + end do + end do + ! Sync momentum + call this%cfg%sync(this%Q(:,:,:,3)) + call this%cfg%sync(this%Q(:,:,:,4)) + call this%cfg%sync(this%Q(:,:,:,5)) + ! Add last layer in each direction + if (.not.this%cfg%xper.and.this%cfg%iproc.eq.1) then + this%Q(this%cfg%imino,:,:,3)=this%Q(this%cfg%imino,:,:,1)*this%U(this%cfg%imino,:,:) + this%Q(this%cfg%imino,:,:,4)=this%Q(this%cfg%imino,:,:,1)*this%V(this%cfg%imino,:,:) + this%Q(this%cfg%imino,:,:,5)=this%Q(this%cfg%imino,:,:,1)*this%W(this%cfg%imino,:,:) + end if + if (.not.this%cfg%yper.and.this%cfg%jproc.eq.1) then + this%Q(:,this%cfg%jmino,:,3)=this%Q(:,this%cfg%jmino,:,1)*this%U(:,this%cfg%jmino,:) + this%Q(:,this%cfg%jmino,:,4)=this%Q(:,this%cfg%jmino,:,1)*this%V(:,this%cfg%jmino,:) + this%Q(:,this%cfg%jmino,:,5)=this%Q(:,this%cfg%jmino,:,1)*this%W(:,this%cfg%jmino,:) + end if + if (.not.this%cfg%zper.and.this%cfg%kproc.eq.1) then + this%Q(:,:,this%cfg%kmino,3)=this%Q(:,:,this%cfg%kmino,1)*this%U(:,:,this%cfg%kmino) + this%Q(:,:,this%cfg%kmino,4)=this%Q(:,:,this%cfg%kmino,1)*this%V(:,:,this%cfg%kmino) + this%Q(:,:,this%cfg%kmino,5)=this%Q(:,:,this%cfg%kmino,1)*this%W(:,:,this%cfg%kmino) + end if + end subroutine get_momentum + + + !> Interpolate velocity to cell-center, including overlap and ghosts + subroutine interp_vel(this,Ui,Vi,Wi) + implicit none + class(spcomp), intent(inout) :: this + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(out) :: Ui !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(out) :: Vi !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(out) :: Wi !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + integer :: i,j,k + ! Calculate interpolated velocity as far as possible + do k=this%cfg%kmino_,this%cfg%kmaxo_-1 + do j=this%cfg%jmino_,this%cfg%jmaxo_-1 + do i=this%cfg%imino_,this%cfg%imaxo_-1 + Ui(i,j,k)=0.5_WP*sum(this%U(i:i+1,j,k)) + Vi(i,j,k)=0.5_WP*sum(this%V(i,j:j+1,k)) + Wi(i,j,k)=0.5_WP*sum(this%W(i,j,k:k+1)) + end do + end do + end do + ! Sync interpolated velocity + call this%cfg%sync(Ui) + call this%cfg%sync(Vi) + call this%cfg%sync(Wi) + ! Add last layer in each direction + if (.not.this%cfg%xper.and.this%cfg%iproc.eq.this%cfg%npx) then + Ui(this%cfg%imaxo,:,:)=this%U(this%cfg%imaxo,:,:) + Vi(this%cfg%imaxo,:,:)=this%V(this%cfg%imaxo,:,:) + Wi(this%cfg%imaxo,:,:)=this%W(this%cfg%imaxo,:,:) + end if + if (.not.this%cfg%yper.and.this%cfg%jproc.eq.this%cfg%npy) then + Ui(:,this%cfg%jmaxo,:)=this%U(:,this%cfg%jmaxo,:) + Vi(:,this%cfg%jmaxo,:)=this%V(:,this%cfg%jmaxo,:) + Wi(:,this%cfg%jmaxo,:)=this%W(:,this%cfg%jmaxo,:) + end if + if (.not.this%cfg%zper.and.this%cfg%kproc.eq.this%cfg%npz) then + Ui(:,:,this%cfg%kmaxo)=this%U(:,:,this%cfg%kmaxo) + Vi(:,:,this%cfg%kmaxo)=this%V(:,:,this%cfg%kmaxo) + Wi(:,:,this%cfg%kmaxo)=this%W(:,:,this%cfg%kmaxo) + end if + end subroutine interp_vel + + + !> Get artifical bulk kinematic viscosity + subroutine get_viscartif(this,dt,beta) + implicit none + class(spcomp), intent(inout) :: this + real(WP), intent(in) :: dt + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(out) :: beta + integer :: i,j,k,si,sj,sk,n + integer, parameter :: nfilter=1 + real(WP) :: max_beta,dudy,dudz,dvdx,dvdz,dwdx,dwdy,vort,grad_div,H + real(WP), parameter :: max_cfl=0.5_WP + real(WP), parameter :: Cartif=2.0_WP + real(WP), parameter :: Cartif_vort=100.0_WP + real(WP), dimension(:,:,:), allocatable :: div + real(WP), dimension(-1:+1), parameter :: filter=[1.0_WP/6.0_WP,2.0_WP/3.0_WP,1.0_WP/6.0_WP] + ! Calculate max beta permissible + max_beta=max_cfl*min(this%dx**2,this%dy**2,this%dz**2)/(4.0_WP*dt) + ! Zero out array + beta=0.0_WP + ! Compute velocity divergence + allocate(div(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + do k=this%cfg%kmino_,this%cfg%kmaxo_-1; do j=this%cfg%jmino_,this%cfg%jmaxo_-1; do i=this%cfg%imino_,this%cfg%imaxo_-1 + div(i,j,k)=this%dxi*(this%U(i+1,j,k)-this%U(i,j,k))+this%dyi*(this%V(i,j+1,k)-this%V(i,j,k))+this%dzi*(this%W(i,j,k+1)-this%W(i,j,k)) + end do; end do; end do + call this%cfg%sync(div) + if (.not.this%cfg%xper.and.this%cfg%iproc.eq.this%cfg%npx) div(this%cfg%imaxo,:,:)=div(this%cfg%imaxo-1,:,:) + if (.not.this%cfg%yper.and.this%cfg%jproc.eq.this%cfg%npy) div(:,this%cfg%jmaxo,:)=div(:,this%cfg%jmaxo-1,:) + if (.not.this%cfg%zper.and.this%cfg%kproc.eq.this%cfg%npz) div(:,:,this%cfg%kmaxo)=div(:,:,this%cfg%kmaxo-1) + ! Compute artificial bulk viscosity based on gradU provided + do k=this%cfg%kmin_,this%cfg%kmax_; do j=this%cfg%jmin_,this%cfg%jmax_; do i=this%cfg%imin_,this%cfg%imax_ + ! Only work in compression regions + if (div(i,j,k).ge.0.0_WP) cycle + ! Compute local vorticity + dudy=0.25_WP*this%dyi*sum(this%U(i:i+1,j:j+1,k)-this%U(i:i+1,j-1:j,k)) + dudz=0.25_WP*this%dzi*sum(this%U(i:i+1,j,k:k+1)-this%U(i:i+1,j,k-1:k)) + dvdx=0.25_WP*this%dxi*sum(this%V(i:i+1,j:j+1,k)-this%V(i-1:i,j:j+1,k)) + dvdz=0.25_WP*this%dzi*sum(this%V(i,j:j+1,k:k+1)-this%V(i,j:j+1,k-1:k)) + dwdx=0.25_WP*this%dxi*sum(this%W(i:i+1,j,k:k+1)-this%W(i-1:i,j,k:k+1)) + dwdy=0.25_WP*this%dyi*sum(this%W(i,j:j+1,k:k+1)-this%W(i,j-1:j,k:k+1)) + vort=(dwdy-dvdz)**2+(dudz-dwdx)**2+(dvdx-dudy)**2 + ! Compute |grad(div)| + grad_div=max(abs(div(i+1,j,k)-div(i,j,k)),abs(div(i,j,k)-div(i-1,j,k)))*this%dx**2& + & +max(abs(div(i,j+1,k)-div(i,j,k)),abs(div(i,j,k)-div(i,j-1,k)))*this%dy**2& + & +max(abs(div(i,j,k+1)-div(i,j,k)),abs(div(i,j,k)-div(i,j,k-1)))*this%dz**2 + ! Estimate artificial kinematic viscosity using grad(div) + !beta(i,j,k)=Cartif*grad_div*div(i,j,k)**2/(div(i,j,k)**2+Cartif_vort*vort+1.0e-15_WP) + + ! Sensor originally proposed by Ducros et al. (1999) and later improved by + ! Hendrickson, T. R., Kartha, A., & Candler, G. V. (2018) + vort=max(vort,(0.05_WP*this%C(i,j,k)/min(this%dx,this%dy))**2) + beta(i,j,k)=Cartif*grad_div*min(4.0_WP/3.0_WP*div(i,j,k)**2/(div(i,j,k)**2+vort+epsilon(1.0_WP)),1.0_WP) + ! Clip it so CFL Get kinematic eddy viscosity using Vreman's model + subroutine get_vreman(this,dt,visc) + implicit none + class(spcomp), intent(inout) :: this + real(WP), intent(in) :: dt + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(out) :: visc + real(WP), parameter :: Cs_ref=0.17_WP + real(WP), parameter :: max_cfl=0.5_WP + real(WP) :: max_visc,A,B,C + real(WP), dimension(1:3,1:3) :: beta,gradU + real(WP), dimension(:,:,:), allocatable :: tmp + real(WP), dimension(-1:+1), parameter :: filter=[1.0_WP/6.0_WP,2.0_WP/3.0_WP,1.0_WP/6.0_WP] + integer :: i,j,k,si,sj,sk,n + integer, parameter :: nfilter=1 + ! Model constant is c=2.5*Cs_ref**2 - Vreman uses c=0.07 which corresponds to Cs_ref=0.17 + C=2.5_WP*Cs_ref**2 + ! Calculate max visc permissible + max_visc=max_cfl*min(this%dx**2,this%dy**2,this%dz**2)/(4.0_WP*dt) + ! Zero out array + visc=0.0_WP + ! Compute the eddy viscosity + do k=this%cfg%kmin_,this%cfg%kmax_; do j=this%cfg%jmin_,this%cfg%jmax_; do i=this%cfg%imin_,this%cfg%imax_ + ! Compute velocity gradient tensor + gradU(1,1)=this%dxi*(this%U(i+1,j,k)-this%U(i,j,k)) + gradU(2,1)=0.25_WP*this%dyi*sum(this%U(i:i+1,j:j+1,k)-this%U(i:i+1,j-1:j,k)) + gradU(3,1)=0.25_WP*this%dzi*sum(this%U(i:i+1,j,k:k+1)-this%U(i:i+1,j,k-1:k)) + gradU(1,2)=0.25_WP*this%dxi*sum(this%V(i:i+1,j:j+1,k)-this%V(i-1:i,j:j+1,k)) + gradU(2,2)=this%dyi*(this%V(i,j+1,k)-this%V(i,j,k)) + gradU(3,2)=0.25_WP*this%dzi*sum(this%V(i,j:j+1,k:k+1)-this%V(i,j:j+1,k-1:k)) + gradU(1,3)=0.25_WP*this%dxi*sum(this%W(i:i+1,j,k:k+1)-this%W(i-1:i,j,k:k+1)) + gradU(2,3)=0.25_WP*this%dyi*sum(this%W(i,j:j+1,k:k+1)-this%W(i,j-1:j,k:k+1)) + gradU(3,3)=this%dzi*(this%W(i,j,k+1)-this%W(i,j,k)) + ! Compute A=gradu_ij*gradu_ij invariant + A=sum(gradU**2) + ! Compute beta_ij=dx_m*dx_m*gradu_mi*gradu_mj + do sj=1,3; do si=1,3; beta(si,sj)=this%dx**2*gradU(1,si)*gradU(1,sj)+this%dy**2*gradU(2,si)*gradU(2,sj)+this%dz**2*gradU(3,si)*gradU(3,sj); end do; end do + ! Compute B invariant + B=beta(1,1)*beta(2,2)-beta(1,2)**2+beta(1,1)*beta(3,3)-beta(1,3)**2+beta(2,2)*beta(3,3)-beta(2,3)**2 + ! Assemble algebraic eddy viscosity model + if (B.lt.1.0e-8_WP) then + visc(i,j,k)=0.0_WP + else + visc(i,j,k)=C*sqrt(B/A) + end if + ! Clip it so CFL Calculate the CFL + subroutine get_cfl(this,dt,cfl) + use mpi_f08, only: MPI_ALLREDUCE,MPI_MAX,MPI_IN_PLACE + use parallel, only: MPI_REAL_WP + implicit none + class(spcomp), intent(inout) :: this + real(WP), intent(in) :: dt + real(WP), intent(out) :: cfl + integer :: ierr + real(WP) :: maxvisc,maxC + ! Compute convective+acoustic CFLs + this%CFLc_x=maxval(abs(this%U)+abs(this%C))*dt*this%dxi; call MPI_ALLREDUCE(MPI_IN_PLACE,this%CFLc_x,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + this%CFLc_y=maxval(abs(this%V)+abs(this%C))*dt*this%dyi; call MPI_ALLREDUCE(MPI_IN_PLACE,this%CFLc_y,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + this%CFLc_z=maxval(abs(this%W)+abs(this%C))*dt*this%dzi; call MPI_ALLREDUCE(MPI_IN_PLACE,this%CFLc_z,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + ! Compute acoustic CFLs + maxC=maxval(this%C); call MPI_ALLREDUCE(MPI_IN_PLACE,maxC,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + this%CFLa_x=maxC*dt*this%dxi + this%CFLa_y=maxC*dt*this%dyi + this%CFLa_z=maxC*dt*this%dzi + ! Compute viscous CFLs + maxvisc=maxval((this%VISC+this%BETA)/this%Q(:,:,:,1)); call MPI_ALLREDUCE(MPI_IN_PLACE,maxvisc,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + this%CFLv_x=4.0_WP*maxvisc*dt*this%dxi**2 + this%CFLv_y=4.0_WP*maxvisc*dt*this%dyi**2 + this%CFLv_z=4.0_WP*maxvisc*dt*this%dzi**2 + ! Return the maximum overall CFL + cfl=max(this%CFLc_x,this%CFLc_y,this%CFLc_z,& + & this%CFLa_x,this%CFLa_y,this%CFLa_z,& + & this%CFLv_x,this%CFLv_y,this%CFLv_z) + end subroutine get_cfl + + + !> Calculate info about our fields + subroutine get_info(this) + use mpi_f08, only: MPI_ALLREDUCE,MPI_MIN,MPI_MAX,MPI_IN_PLACE + use parallel, only: MPI_REAL_WP + implicit none + class(spcomp), intent(inout) :: this + integer :: n,i,j,k,ierr + real(WP), dimension(:,:,:), allocatable :: tmp + + ! Compute integrals and extrema of conserved variables + do n=1,this%nQ + call this%cfg%integrate(this%Q(:,:,:,n),integral=this%Qint(n)) + end do + this%Qmin=+huge(1.0_WP) + this%Qmax=-huge(1.0_WP) + do k=this%cfg%kmin_,this%cfg%kmax_; do j=this%cfg%jmin_,this%cfg%jmax_; do i=this%cfg%imin_,this%cfg%imax_ + do n=1,this%nQ + this%Qmin(n)=min(this%Qmin(n),this%Q(i,j,k,n)) + this%Qmax(n)=max(this%Qmax(n),this%Q(i,j,k,n)) + end do + end do; end do; end do + call MPI_ALLREDUCE(MPI_IN_PLACE,this%Qmin,this%nQ,MPI_REAL_WP,MPI_MIN,this%cfg%comm,ierr) + call MPI_ALLREDUCE(MPI_IN_PLACE,this%Qmax,this%nQ,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + + ! Also compute integral of KE and entropy + allocate(tmp(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + call this%get_ke(tmp); tmp=this%Q(:,:,:,1)*tmp; call this%cfg%integrate(tmp,integral=this%RHOKint) + this%RHOSint=0.0_WP + if (associated(this%getS)) then + do k=this%cfg%kmin_,this%cfg%kmax_; do j=this%cfg%jmin_,this%cfg%jmax_; do i=this%cfg%imin_,this%cfg%imax_ + tmp(i,j,k)=this%Q(i,j,k,1)*this%getS(this%Q(i,j,k,1),this%P(i,j,k)) + end do; end do; end do + call this%cfg%integrate(tmp,integral=this%RHOSint) + end if + deallocate(tmp) + + ! Calculate extrema of primitive fields + this%RHOmin=+huge(1.0_WP); this%RHOmax=-huge(1.0_WP) + this%Imin =+huge(1.0_WP); this%Imax =-huge(1.0_WP) + this%Pmin =+huge(1.0_WP); this%Pmax =-huge(1.0_WP) + this%Tmin =+huge(1.0_WP); this%Tmax =-huge(1.0_WP) + this%Umax=0.0_WP; this%Vmax=0.0_WP; this%Wmax=0.0_WP + do k=this%cfg%kmin_,this%cfg%kmax_; do j=this%cfg%jmin_,this%cfg%jmax_; do i=this%cfg%imin_,this%cfg%imax_ + this%RHOmin=min(this%RHOmin,this%Q(i,j,k,1)); this%RHOmax=max(this%RHOmax,this%Q(i,j,k,1)) + this%Imin =min(this%Imin ,this%I (i,j,k)); this%Imax =max(this%Imax ,this%I (i,j,k)) + this%Pmin =min(this%Pmin ,this%P (i,j,k)); this%Pmax =max(this%Pmax ,this%P (i,j,k)) + this%Tmin =min(this%Tmin ,this%T (i,j,k)); this%Tmax =max(this%Tmax ,this%T (i,j,k)) + this%Umax=max(this%Umax,abs(this%U(i,j,k))) + this%Vmax=max(this%Vmax,abs(this%V(i,j,k))) + this%Wmax=max(this%Wmax,abs(this%W(i,j,k))) + end do; end do; end do + call MPI_ALLREDUCE(MPI_IN_PLACE,this%RHOmin,1,MPI_REAL_WP,MPI_MIN,this%cfg%comm,ierr) + call MPI_ALLREDUCE(MPI_IN_PLACE,this%RHOmax,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + call MPI_ALLREDUCE(MPI_IN_PLACE,this%Imin ,1,MPI_REAL_WP,MPI_MIN,this%cfg%comm,ierr) + call MPI_ALLREDUCE(MPI_IN_PLACE,this%Imax ,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + call MPI_ALLREDUCE(MPI_IN_PLACE,this%Pmin ,1,MPI_REAL_WP,MPI_MIN,this%cfg%comm,ierr) + call MPI_ALLREDUCE(MPI_IN_PLACE,this%Pmax ,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + call MPI_ALLREDUCE(MPI_IN_PLACE,this%Tmin ,1,MPI_REAL_WP,MPI_MIN,this%cfg%comm,ierr) + call MPI_ALLREDUCE(MPI_IN_PLACE,this%Tmax ,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + call MPI_ALLREDUCE(MPI_IN_PLACE,this%Umax ,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + call MPI_ALLREDUCE(MPI_IN_PLACE,this%Vmax ,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + call MPI_ALLREDUCE(MPI_IN_PLACE,this%Wmax ,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + + end subroutine get_info + + + !> Print out info for spcomp flow solver + subroutine spcomp_print(this) + use, intrinsic :: iso_fortran_env, only: output_unit + implicit none + class(spcomp), intent(in) :: this + if (this%cfg%amRoot) write(output_unit,'("spcomp solver [",a,"] for config [",a,"]")') trim(this%name),trim(this%cfg%name) + end subroutine spcomp_print + + + !> Finalize spcomp flow solver + subroutine finalize(this) + implicit none + class(spcomp), intent(inout) :: this + nullify(this%cfg) + this%name='UNNAMED_SPCOMP' + nullify(this%getP) + nullify(this%getT) + nullify(this%getC) + nullify(this%getS) + this%nQ=0 + if (allocated(this%Q)) deallocate(this%Q) + if (allocated(this%Qold)) deallocate(this%Qold) + if (allocated(this%U)) deallocate(this%U) + if (allocated(this%V)) deallocate(this%V) + if (allocated(this%W)) deallocate(this%W) + if (allocated(this%I)) deallocate(this%I) + if (allocated(this%P)) deallocate(this%P) + if (allocated(this%T)) deallocate(this%T) + if (allocated(this%C)) deallocate(this%C) + if (allocated(this%VISC)) deallocate(this%VISC) + if (allocated(this%BETA)) deallocate(this%BETA) + if (allocated(this%DIFF)) deallocate(this%DIFF) + if (allocated(this%Qmin)) deallocate(this%Qmin) + if (allocated(this%Qmax)) deallocate(this%Qmax) + if (allocated(this%Qint)) deallocate(this%Qint) + call this%trhs%finalize() + end subroutine finalize + + +end module spcomp_class diff --git a/examples/beam_test/GNUmakefile b/examples/beam_test/GNUmakefile new file mode 100644 index 000000000..23c4d3dba --- /dev/null +++ b/examples/beam_test/GNUmakefile @@ -0,0 +1,49 @@ +# NGA location if not yet defined +NGA_HOME ?= ~/nga2/Repositories/nga2 + +# Compilation parameters +PRECISION = DOUBLE +USE_MPI = TRUE +USE_HYPRE = TRUE +USE_LAPACK= TRUE +USE_FFTW = TRUE +USE_IRL = FALSE +PROFILE = FALSE +DEBUG = FALSE +COMP = gnu +EXEBASE = nga + +# Directories that contain user-defined code +Udirs := src + +# Include user-defined sources +Upack += $(foreach dir, $(Udirs), $(wildcard $(dir)/Make.package)) +Ulocs += $(foreach dir, $(Udirs), $(wildcard $(dir))) +include $(Upack) +INCLUDE_LOCATIONS += $(Ulocs) +VPATH_LOCATIONS += $(Ulocs) + +# External libraries are defined in .profile/.bashrc/.zshrc, but could be defined here as well +HYPRE_DIR=/Users/imauser/nga2/Repositories/hypre/src/hypre +FFTW_DIR=/opt/homebrew/Cellar/fftw/3.3.10_2 + +# NGA compilation definitions +include $(NGA_HOME)/tools/GNUMake/Make.defs + +# Include NGA base code +Bdirs := constant_density particles core data transform solver config grid libraries +Bpack += $(foreach dir, $(Bdirs), $(NGA_HOME)/src/$(dir)/Make.package) +include $(Bpack) + +# Inform user of Make.packages used +ifdef Ulocs + $(info Taking user code from: $(Ulocs)) +endif +$(info Taking base code from: $(Bdirs)) + +# Target definition +all: $(executable) + @echo COMPILATION SUCCESSFUL + +# NGA compilation rules +include $(NGA_HOME)/tools/GNUMake/Make.rules diff --git a/examples/beam_test/input b/examples/beam_test/input new file mode 100644 index 000000000..45553d065 --- /dev/null +++ b/examples/beam_test/input @@ -0,0 +1,26 @@ +# Parallelization +Partition : 2 2 2 + + +# Beam Shape +Lx : 1.0 +Ly : 0.1 +Lz : 0.1 +Particle file: element_data.bin + +# Solid properties +Subdivisions : 33 +Elastic Modulus : 200e9 +Poisson Ratio : 0.25 +Solid density : 7850 +Critical Energy Release Rate : 10000000 +Horizon Ratio : 3.015 +Mean Particle Spacing: 0.00802 + +# Time integration +Max timestep size : 2e-6 +Max cfl number : 0.9 +Max time : 0.06 + +# Ensight output +Ensight output period : 1e-3 diff --git a/examples/beam_test/src/Make.package b/examples/beam_test/src/Make.package new file mode 100644 index 000000000..ddc060c7d --- /dev/null +++ b/examples/beam_test/src/Make.package @@ -0,0 +1,2 @@ +# List here the extra files here +f90EXE_sources += simulation.f90 geometry.f90 lss_class.f90 spcomp_class.f90 diff --git a/examples/beam_test/src/geometry.f90 b/examples/beam_test/src/geometry.f90 new file mode 100644 index 000000000..f0de3032a --- /dev/null +++ b/examples/beam_test/src/geometry.f90 @@ -0,0 +1,128 @@ +!> Various definitions and tools for initializing NGA2 config +module geometry + use config_class, only: config + use precision, only: WP + implicit none + private + + !> Single config + type(config), public :: cfg + + public :: geometry_init + +contains + + + !> Initialization of problem geometry + subroutine geometry_init + use sgrid_class, only: sgrid + use param, only: param_read + implicit none + type(sgrid) :: grid + + + ! Create a grid from input params + create_grid: block + use sgrid_class, only: cartesian + integer :: i,j,k,nx,ny,nz + real(WP) :: Lx,Ly,Lz,dist,dx + real(WP), dimension(:), allocatable :: x,y,z + + Lx = 1.0_WP ! beam length + dist = 0.01_WP ! Space between particles + + Lx = Lx + 3.0_WP * dist ! total length of the beam + dx = 3.0_WP*dist ! grid spacing + + nx = ceiling(Lx/dx)+2 ! number of division in x + ny = 3 + nz = 3 + + allocate(x(nx+1)) + allocate(y(ny+1)) + allocate(z(nz+1)) + + ! Create simple rectilinear grid + do i=1,nx+1 + x(i)=real(i-1,WP)*dx - 2.0_WP*dx + end do + do j=1,ny+1 + y(j)=real(j,WP)*dx-1.5_WP*dx + end do + do k=1,nz+1 + z(k)=real(k,WP)*dx-1.5_WP*dx + end do + + ! General serial grid object (no=3 needed to support ghost/image point interpolation/extrapolation) + grid=sgrid(coord=cartesian,no=3,x=x,y=y,z=z,xper=.false.,yper=.false.,zper=.false.,name='box') + + end block create_grid + + ! create_grid: block + ! use sgrid_class, only: cartesian + ! integer :: i,j,k,nx,ny,nz + ! real(WP) :: Lx,Ly,Lz,dist + ! real(WP), dimension(:), allocatable :: x,y,z + + ! ! Read in grid definition + ! call param_read('Lx',Lx); Lx=Lx + ! call param_read('Ly',Ly); Ly=Ly + ! call param_read('Lz',Lz); Lz=Lz + ! call param_read('Subdivisions',ny) + ! dist = 3.0_WP * Ly / real(ny,WP) + ! Lx = Lx + 3.0_WP * dist + ! nx = ceiling(Lx / dist) + 4 + ! ny = ceiling(Ly / dist) + 2 + ! nz = ceiling(Lz / dist) + 2 + + ! Lx = real(nx,WP) * dist + ! Ly = real(ny,WP) * dist + ! Lz = real(nz,WP) * dist + + + ! allocate(x(nx)) + ! allocate(y(ny+1)) + ! allocate(z(nz+1)) + + + ! ! Create simple rectilinear grid + ! do i=1,nx + ! x(i)=real(i-2,WP)*dist + ! end do + ! do j=1,ny+1 + ! y(j)=real(j-1,WP)*dist-0.5_WP*Ly + ! end do + ! do k=1,nz+1 + ! z(k)=real(k-1,WP)*dist-0.5_WP*Lz + ! end do + + + + + ! ! General serial grid object (no=3 needed to support ghost/image point interpolation/extrapolation) + ! grid=sgrid(coord=cartesian,no=2,x=x,y=y,z=z,xper=.false.,yper=.false.,zper=.false.,name='box') + + ! end block create_grid + + + ! Create a config from that grid on our entire group + create_cfg: block + use parallel, only: group + integer, dimension(3) :: partition + ! Read in partition + call param_read('Partition',partition,short='p') + ! Create partitioned grid + cfg=config(grp=group,decomp=partition,grid=grid) + end block create_cfg + + + ! Create walls for this config + create_walls: block + cfg%VF=1.0_WP + end block create_walls + + + end subroutine geometry_init + + +end module geometry diff --git a/examples/beam_test/src/lss_class.f90 b/examples/beam_test/src/lss_class.f90 new file mode 100644 index 000000000..cb12467ea --- /dev/null +++ b/examples/beam_test/src/lss_class.f90 @@ -0,0 +1,1656 @@ +!> Lagrangian solid solver object +!> Implements peridynamics equations +module lss_class + use precision, only: WP + use string, only: str_medium + use config_class, only: config + use mpi_f08, only: MPI_Datatype,MPI_INTEGER8,MPI_INTEGER,MPI_DOUBLE_PRECISION + implicit none + private + + + ! Expose type/constructor/methods + public :: lss + + + !> Memory adaptation parameter + real(WP), parameter :: coeff_up=1.3_WP !< Particle array size increase factor + real(WP), parameter :: coeff_dn=0.7_WP !< Particle array size decrease factor + + + !> I/O chunk size to read at a time + integer, parameter :: part_chunk_size=1000 !< Read 1000 particles at a time before redistributing + + + !> Maximum number of bonds per particle + integer, parameter, public :: max_bond=400 !< Assumes something like a 7x7x7 stencil in 3D + + + !> Bonded solid particle definition + type :: part + !> MPI_DOUBLE_PRECISION data + real(WP) :: mw !< Weighted volume + real(WP) :: dil !< Element dilatation + real(WP) :: ste !< Element dilatation + real(WP) :: vol !< Particle volume + real(WP), dimension(max_bond) :: dbond !< Length of initial bonds + real(WP), dimension(3) :: pos !< Particle center coordinates + real(WP), dimension(3) :: vel !< Velocity of particle + real(WP), dimension(3) :: Abond !< Bond acceleration for particle + real(WP), dimension(3) :: Afluid !< Fluid acceleration for particle + real(WP), dimension(3) :: gd !< Dilitation corrections + real(WP), dimension(3) :: gb !< Shear corrections + !> MPI_INTEGER data + integer :: id !< ID the object is associated with + integer :: i !< Unique index of particle (assumed >0) + integer :: nbond !< Number of initial bonds + integer, dimension(max_bond) :: ibond !< Indices of initially bonded particles (0 values ignored) + integer , dimension(3) :: ind !< Index of cell containing particle center + integer :: flag !< Control parameter (0=normal, 1=done->will be removed) + end type part + !> Number of blocks, block length, and block types in a particle + integer, parameter :: part_nblock=2 + integer , dimension(part_nblock) :: part_lblock=[22+max_bond,7+max_bond] + type(MPI_Datatype), dimension(part_nblock) :: part_tblock=[MPI_DOUBLE_PRECISION,MPI_INTEGER] + !> MPI_PART derived datatype and size + type(MPI_Datatype) :: MPI_PART + integer :: MPI_PART_SIZE + + + !> Lagrangian solid solver object definition + type :: lss + + ! This config is used for parallelization and for calculating bond/collision forces + class(config), pointer :: cfg + + ! This is the name of the solver + character(len=str_medium) :: name='UNNAMED_LSS' + + ! Solid material properties + real(WP) :: elastic_modulus !< Elastic modulus of the material + real(WP) :: poisson_ratio !< Poisson's ratio of the material + real(WP) :: rho !< Density of the material + real(WP) :: crit_energy !< Critical energy release + + ! Bonding parameters + real(WP) :: delta !< Bonding horizon (distance) + real(WP) :: min_dist !< Minimum bonding distance + integer :: nb !< Cell-based horizon + + ! Global and local particle data + integer :: np !< Global number of particles + integer :: np_ !< Local number of particles + integer, dimension(:), allocatable :: np_proc !< Number of particles on each processor + type(part), dimension(:), allocatable :: p !< Array of particles of type part + + ! Overlap particle (i.e., ghost) data + integer :: ng_ !< Local number of ghosts + type(part), dimension(:), allocatable :: g !< Array of ghosts of type part + + ! Gravitational acceleration + real(WP), dimension(3) :: gravity=[0.0_WP,0.0_WP,0.0_WP] + + ! Solid volume fraction and momentum + real(WP), dimension(:,:,:), allocatable :: VF !< Volume fraction, cell-centered + real(WP), dimension(:,:,:), allocatable :: VFU !< Solid velocity, U-face + real(WP), dimension(:,:,:), allocatable :: VFV !< Solid velocity, V-face + real(WP), dimension(:,:,:), allocatable :: VFW !< Solid velocity, W-face + + ! CFL numbers + real(WP) :: CFLp_x,CFLp_y,CFLp_z,CFLp_a + + ! Number of substeps for time integrator + real(WP) :: nstep=1 + + ! Monitoring info + real(WP) :: Umin,Umax,Umean !< U velocity info + real(WP) :: Vmin,Vmax,Vmean !< V velocity info + real(WP) :: Wmin,Wmax,Wmean !< W velocity info + real(WP) :: VFmax !< Volume fraction info + real(WP), dimension(3) :: ibmForce !< Total force due to IBM + integer :: np_out !< Number of particles leaving the domain + + contains + procedure :: bond_init !< Setup initial interparticle bonds + procedure :: get_bond_force !< Compute interparticle bond force + procedure :: advance !< Step forward the particle ODEs + procedure :: get_cfl !< Calculate maximum CFL + procedure :: get_max !< Extract various monitoring data + procedure :: update_partmesh !< Update a partmesh object using current particles + procedure :: share !< Share particles across interprocessor boundaries + procedure :: sync !< Synchronize particles across interprocessor boundaries + procedure :: resize !< Resize particle array to given size + procedure :: resize_ghost !< Resize ghost array to given size + procedure :: recycle !< Recycle particle array by removing flagged particles + procedure :: write !< Parallel write particles to file + procedure :: read !< Parallel read particles from file + procedure :: update_VF !< Compute volume fraction + procedure :: get_delta !< Compute regularized delta function + procedure :: interpolate !< Interpolation routine from mesh=>marker + procedure :: extrapolate !< Extrapolation routine from marker=>mesh + procedure :: stretch + end type lss + + + !> Declare lss constructor + interface lss + procedure constructor + end interface lss + +contains + + + ! Quasi-Gaussian weighting function - h is the cut-off + real(WP) function wgauss(d,h) + implicit none + real(WP), intent(in) :: d,h + real(WP), parameter :: coeff=2.6_WP + real(WP) :: hh + hh=coeff*h + if (d.ge.hh) then + wgauss=0.0_WP + else + wgauss=(1.0_WP+4.0_WP*d/hh)*(1.0_WP-d/hh)**4 + end if + end function wgauss + + + !> Default constructor for Lagrangian solid solver + function constructor(cfg,name) result(self) + implicit none + type(lss) :: self + class(config), target, intent(in) :: cfg + character(len=*), optional :: name + integer :: i,j,k + + ! Set the name for the solver + if (present(name)) self%name=trim(adjustl(name)) + + ! Point to pgrid object + self%cfg=>cfg + + ! Set default bonding horizon based on underlying mesh + self%delta=self%cfg%min_meshsize + self%nb=1 + self%min_dist=huge(1.0_WP) + + ! Allocate variables + allocate(self%np_proc(1:self%cfg%nproc)); self%np_proc=0 + self%np_=0; self%np=0 + call self%resize(0) + + ! Initialize MPI derived datatype for a particle + call prepare_mpi_part() + + ! Allocate VF array on cfg mesh + allocate(self%VF(self%cfg%imino_:self%cfg%imaxo_,self%cfg%jmino_:self%cfg%jmaxo_,self%cfg%kmino_:self%cfg%kmaxo_)); self%VF=0.0_WP + allocate(self%VFU(self%cfg%imino_:self%cfg%imaxo_,self%cfg%jmino_:self%cfg%jmaxo_,self%cfg%kmino_:self%cfg%kmaxo_)); self%VFU=0.0_WP + allocate(self%VFV(self%cfg%imino_:self%cfg%imaxo_,self%cfg%jmino_:self%cfg%jmaxo_,self%cfg%kmino_:self%cfg%kmaxo_)); self%VFV=0.0_WP + allocate(self%VFW(self%cfg%imino_:self%cfg%imaxo_,self%cfg%jmino_:self%cfg%jmaxo_,self%cfg%kmino_:self%cfg%kmaxo_)); self%VFW=0.0_WP + + ! Log/screen output + logging: block + use, intrinsic :: iso_fortran_env, only: output_unit + use param, only: verbose + use messager, only: log + use string, only: str_long + character(len=str_long) :: message + if (self%cfg%amRoot) then + write(message,'("LSS object [",a,"] on partitioned grid [",a,"]")') trim(self%name),trim(self%cfg%name) + if (verbose.gt.1) write(output_unit,'(a)') trim(message) + if (verbose.gt.0) call log(message) + end if + end block logging + + end function constructor + + + !> Initialize bond force between particles + subroutine bond_init(this) + use messager, only: die + implicit none + class(lss), intent(inout) :: this + integer, dimension(:,:,:), allocatable :: npic !< Number of particle in cell + integer, dimension(:,:,:,:), allocatable :: ipic !< Index of particle in cell + + ! Communicate particles in ghost cells + call this%share() + + ! We can now assemble particle-in-cell information + pic_prep: block + use mpi_f08 + integer :: i,ip,jp,kp,ierr + integer :: mymax_npic,max_npic + + ! Allocate number of particle in cell + allocate(npic(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)); npic=0 + + ! Count particles and ghosts per cell + do i=1,this%np_ + ip=this%p(i)%ind(1); jp=this%p(i)%ind(2); kp=this%p(i)%ind(3) + npic(ip,jp,kp)=npic(ip,jp,kp)+1 + end do + do i=1,this%ng_ + ip=this%g(i)%ind(1); jp=this%g(i)%ind(2); kp=this%g(i)%ind(3) + npic(ip,jp,kp)=npic(ip,jp,kp)+1 + end do + + ! Get maximum number of particle in cell + mymax_npic=maxval(npic); call MPI_ALLREDUCE(mymax_npic,max_npic,1,MPI_INTEGER,MPI_MAX,this%cfg%comm,ierr) + + ! Allocate pic map + allocate(ipic(1:max_npic,this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)); ipic=0 + + ! Assemble pic map + npic=0 + do i=1,this%np_ + ip=this%p(i)%ind(1); jp=this%p(i)%ind(2); kp=this%p(i)%ind(3) + npic(ip,jp,kp)=npic(ip,jp,kp)+1 + ipic(npic(ip,jp,kp),ip,jp,kp)=+i + end do + do i=1,this%ng_ + ip=this%g(i)%ind(1); jp=this%g(i)%ind(2); kp=this%g(i)%ind(3) + npic(ip,jp,kp)=npic(ip,jp,kp)+1 + ipic(npic(ip,jp,kp),ip,jp,kp)=-i + end do + + end block pic_prep + + ! Establish initial bonds + create_bonds: block + use mpi_f08, only: MPI_ALLREDUCE,MPI_MIN,MPI_IN_PLACE + use parallel, only: MPI_REAL_WP + use mathtools, only: Pi + integer :: i,j,k,n1,nn,n2,ierr + type(part) :: p1,p2 + real(WP), dimension(3) :: rpos + real(WP) :: dist + ! Reset minimum bond distance + this%min_dist=huge(1.0_WP) + ! Loop over particles + do n1=1,this%np_ + ! Create copy of our particle + p1=this%p(n1) + ! Zero out weighted volume + p1%mw=0.0_WP + ! Zero out bonds + p1%ibond=0 + p1%nbond=0 + ! Loop over neighbor cells + do k=p1%ind(3)-this%nb,p1%ind(3)+this%nb + do j=p1%ind(2)-this%nb,p1%ind(2)+this%nb + do i=p1%ind(1)-this%nb,p1%ind(1)+this%nb + ! Loop over particles in that cell + do nn=1,npic(i,j,k) + ! Create copy of our neighbor + n2=ipic(nn,i,j,k) + if (n2.gt.0) then + p2=this%p(+n2) + else if (n2.lt.0) then + p2=this%g(-n2) + end if + ! Cannot self-bond + if (p1%i.eq.p2%i) cycle + ! Cannot bond with different id except <=0 (<=0 bonds with everyone) + if (p1%id.ne.p2%id.and.p1%id.ge.0.and.p2%id.ge.0) cycle + ! Check interparticle distance + rpos=p2%pos-p1%pos + dist=sqrt(dot_product(rpos,rpos)) + if (dist.lt.this%delta) then + ! This particle is in horizon, create a bond + p1%nbond=p1%nbond+1 + if (p1%nbond.gt.max_bond) call die('[lss_class bond_init] Number of detected bonds is larger than max allowed') + p1%ibond(p1%nbond)=p2%i + p1%dbond(p1%nbond)=dist + ! Increment weighted volume + p1%mw=p1%mw+wgauss(dist,this%delta)*dist**2*p1%vol + ! Determine minimum bond distance + this%min_dist=min(this%min_dist,dist) + end if + end do + end do + end do + end do + ! Zero out initial dilatation + p1%dil=0.0_WP + ! Copy back the particle + this%p(n1)=p1 + end do + ! Get global minimum + call MPI_ALLREDUCE(MPI_IN_PLACE,this%min_dist,1,MPI_REAL_WP,MPI_MIN,this%cfg%comm,ierr) + end block create_bonds + + ! Clean up + if (allocated(npic)) deallocate(npic) + if (allocated(ipic)) deallocate(ipic) + + end subroutine bond_init + + + !> Calculate bond force between particles + subroutine get_bond_force(this) + implicit none + class(lss), intent(inout) :: this + integer, dimension(:,:,:), allocatable :: npic !< Number of particle in cell + integer, dimension(:,:,:,:), allocatable :: ipic !< Index of particle in cell + logical :: is2D + + ! Need to modify parameters in 2D + is2D=this%cfg%nx.eq.1.or.this%cfg%ny.eq.1.or.this%cfg%nz.eq.1 + + ! Communicate particles in ghost cells + call this%share() + + ! We can now assemble particle-in-cell information + pic_prep: block + use mpi_f08 + integer :: i,ip,jp,kp,ierr + integer :: mymax_npic,max_npic + + ! Allocate number of particle in cell + allocate(npic(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)); npic=0 + + ! Count particles and ghosts per cell + do i=1,this%np_ + ip=this%p(i)%ind(1); jp=this%p(i)%ind(2); kp=this%p(i)%ind(3) + npic(ip,jp,kp)=npic(ip,jp,kp)+1 + end do + do i=1,this%ng_ + ip=this%g(i)%ind(1); jp=this%g(i)%ind(2); kp=this%g(i)%ind(3) + npic(ip,jp,kp)=npic(ip,jp,kp)+1 + end do + + ! Get maximum number of particle in cell + mymax_npic=maxval(npic); call MPI_ALLREDUCE(mymax_npic,max_npic,1,MPI_INTEGER,MPI_MAX,this%cfg%comm,ierr) + + ! Allocate pic map + allocate(ipic(1:max_npic,this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)); ipic=0 + + ! Assemble pic map + npic=0 + do i=1,this%np_ + ip=this%p(i)%ind(1); jp=this%p(i)%ind(2); kp=this%p(i)%ind(3) + npic(ip,jp,kp)=npic(ip,jp,kp)+1 + ipic(npic(ip,jp,kp),ip,jp,kp)=+i + end do + do i=1,this%ng_ + ip=this%g(i)%ind(1); jp=this%g(i)%ind(2); kp=this%g(i)%ind(3) + npic(ip,jp,kp)=npic(ip,jp,kp)+1 + ipic(npic(ip,jp,kp),ip,jp,kp)=-i + end do + + end block pic_prep + + ! Update weighted volume and dilatation + update_weighted_vol_and_dilatation: block + integer :: i,j,k,n1,nn,n2 + type(part) :: p1,p2 + integer :: nb,nbond + real(WP), dimension(3) :: rpos, Gd_vec + real(WP) :: dist, Gd_mag + ! Loop over particles + do n1=1,this%np_ + ! Create copy of our particle + p1=this%p(n1) + ! Zero out weighted volume and dilatation + p1%mw=0.0_WP + p1%dil=0.0_WP + ! Loop over neighbor cells + do k=p1%ind(3)-this%nb,p1%ind(3)+this%nb + do j=p1%ind(2)-this%nb,p1%ind(2)+this%nb + do i=p1%ind(1)-this%nb,p1%ind(1)+this%nb + ! Loop over particles in that cell + do nn=1,npic(i,j,k) + ! Create copy of our neighbor + n2=ipic(nn,i,j,k) + if (n2.gt.0) then + p2=this%p(+n2) + else if (n2.lt.0) then + p2=this%g(-n2) + end if + ! Check if a bond exists + do nb=1,max_bond + if (p1%ibond(nb).eq.p2%i) then + ! Increment weighted volume + p1%mw=p1%mw+wgauss(p1%dbond(nb),this%delta)*p1%dbond(nb)**2*p2%vol + ! Get current distance + rpos=p2%pos-p1%pos + dist=sqrt(dot_product(rpos,rpos)) + ! compute average G correction for dilitation + Gd_vec = (p2%gd + p1%gd)/2.0_WP + + Gd_mag = sqrt(1.0_WP/(((rpos(1)/dist)/Gd_vec(1))**2 + ((rpos(2)/dist)/Gd_vec(2))**2 + ((rpos(3)/dist)/Gd_vec(3))**2 )) + ! Increment dilatation + p1%dil=p1%dil+wgauss(p1%dbond(nb),this%delta)*p1%dbond(nb)*(dist-p1%dbond(nb))*p2%vol*Gd_mag + end if + end do + end do + end do + end do + end do + ! Rescale dilatation + if (p1%mw.gt.epsilon(1.0_WP)) then + if (is2D) then + ! 2D plane strain + p1%dil=p1%dil*2.0_WP/p1%mw + else + ! 3D + p1%dil=p1%dil*3.0_WP/p1%mw + end if + else + p1%dil=0.0_WP + end if + ! Copy back the particle + this%p(n1)=p1 + end do + end block update_weighted_vol_and_dilatation + + ! Re-communicate particles in ghost cells to update dil and mw + call this%share() + + ! Update bond force, including collision force, and SED + update_bond_force: block + use mpi_f08, only: MPI_ALLREDUCE,MPI_MIN,MPI_IN_PLACE + use parallel, only: MPI_REAL_WP + use mathtools, only: Pi + integer :: i,j,k,n1,nn,n2,ierr + type(part) :: p1,p2 + real(WP), dimension(3) :: rpos,t12,t21,Gd_vec + real(WP) :: dist,beta,alpha,ed,t,Gd_mag + real(WP) :: stretch,max_stretch,mu,kk + real(WP) :: nc,rc,kc + integer :: nb,nbond + logical :: found_bond + ! Recompute a few physical parameters + mu=this%elastic_modulus/(2.0_WP+2.0_WP*this%poisson_ratio) + kk=this%elastic_modulus/(3.0_WP-6.0_WP*this%poisson_ratio) + if (is2D) then + if (this%cfg%nx.eq.1) t=this%cfg%xL + if (this%cfg%ny.eq.1) t=this%cfg%yL + if (this%cfg%nz.eq.1) t=this%cfg%zL + max_stretch=sqrt(this%crit_energy/((6.0_WP*mu/Pi+16.0_WP/(9.0_WP*Pi**2)*(kk-2.0_WP*mu))*this%delta)) + kc=15.0_WP*48.0_WP*this%elastic_modulus/(Pi*5.0_WP*t*this%delta**3) + else + max_stretch=sqrt(this%crit_energy/((3.0_WP*mu+(kk-5.0_WP*mu/3.0_WP)*0.75_WP**4)*this%delta)) + kc=15.0_WP*12.0_WP*this%elastic_modulus/(Pi*this%delta**4) + end if + nc=1.0_WP + this%min_dist=huge(1.0_WP) + ! Loop over particles + do n1=1,this%np_ + ! Particles marked 0 do not update their forces + if (this%p(n1)%id.eq.0) cycle + ! Create copy of our particle + p1=this%p(n1) + ! Zero out bond force + p1%Abond=0.0_WP + ! Loop over neighbor cells + do k=p1%ind(3)-this%nb,p1%ind(3)+this%nb + do j=p1%ind(2)-this%nb,p1%ind(2)+this%nb + do i=p1%ind(1)-this%nb,p1%ind(1)+this%nb + ! Loop over particles in that cell + do nn=1,npic(i,j,k) + ! Create copy of our neighbor + n2=ipic(nn,i,j,k) + if (n2.gt.0) then + p2=this%p(+n2) + else if (n2.lt.0) then + p2=this%g(-n2) + end if + ! Current distance + rpos=p2%pos-p1%pos + dist=sqrt(dot_product(rpos,rpos)) + ! Check if a bond exists + found_bond=.false. + do nb=1,max_bond + if (p1%ibond(nb).eq.p2%i) then + ! Check for breakage first + stretch=(dist-p1%dbond(nb))/p1%dbond(nb) + if (stretch.gt.max_stretch) then + ! Remove the bond and flag as surface particle + p1%ibond(nb)=0 + p1%dbond(nb)=0.0_WP + cycle + end if + ! Particle 1 + if (is2D) then + ! 2D plane strain + beta = 2.0_WP * kk * p1%dil + alpha = 8.0_WP * mu / p1%mw + ed = dist - p1%dbond(nb) * (1.0_WP + p1%dil / 2.0_WP) + else + ! 3D + beta = 3.0_WP * kk * p1%dil + alpha = 15.0_WP * mu / p1%mw + ed = dist - p1%dbond(nb) * (1.0_WP + p1%dil / 3.0_WP) + end if + ! Force density 1->2 + ! t12=+wgauss(p1%dbond(nb),this%delta)*(beta/p1%mw*p1%dbond(nb)+alpha*ed)*rpos/dist + ! t12=+wgauss(p1%dbond(nb),this%delta)*((3.0_WP*kk - 15.0_WP*mu/3.0_WP)*(p1%dil*p1%dbond(nb)/p1%mw) + 15*mu*dist/p1%mw)*rpos/dist + Gd_vec = (p2%gd + p1%gd)/2.0_WP + Gd_mag = sqrt(1.0_WP/(((rpos(1)/dist)/Gd_vec(1))**2 + ((rpos(2)/dist)/Gd_vec(2))**2 + ((rpos(3)/dist)/Gd_vec(3))**2 )) + t12=+wgauss(p1%dbond(nb),this%delta)*((3.0_WP*kk - 15.0_WP*mu/3.0_WP)*(Gd_mag*p1%dil*p1%dbond(nb)/p1%mw) + (15.0_WP*mu/p1%mw)*(dist - p1%dbond(nb)) )*rpos/dist + ! Particle 2 + if (is2D) then + ! 2D plane strain + beta = 2.0_WP * kk * p2%dil + alpha = 8.0_WP * mu / p2%mw + ed = dist - p1%dbond(nb) * (1.0_WP + p2%dil / 2.0_WP) + else + ! 3D + beta = 3.0_WP * kk * p2%dil + alpha = 15.0_WP * mu / p2%mw + ed = dist - p1%dbond(nb) * (1.0_WP + p2%dil / 3.0_WP) + end if + ! Force density 2->1 + ! t21=-wgauss(p1%dbond(nb),this%delta)*(beta/p2%mw*p1%dbond(nb)+alpha*ed)*rpos/dist + t21=-wgauss(p1%dbond(nb),this%delta)*((3.0_WP*kk - 15.0_WP*mu/3.0_WP)*(Gd_mag*p2%dil*p1%dbond(nb)/p2%mw)+ (15.0_WP*mu/p2%mw)*(dist - p1%dbond(nb)) )*rpos/dist ! Increment bond force + p1%Abond=p1%Abond+(t12-t21)*p2%vol/this%rho + ! Incremend SED + p1%ste=p1%ste+alpha/2.0_WP*(wgauss(p1%dbond(nb),this%delta)*((dist-p1%dbond(nb)))*p2%vol) + ! If still here, we have an active bond + found_bond=.true. + ! Determine minimum bond distance + this%min_dist=min(this%min_dist,dist) + cycle + end if + end do + ! Add collision force now + ! if (is2D) then + ! rc=p1%vol**(1.0_WP/2.0_WP) + ! else + ! rc=p1%vol**(1.0_WP/3.0_WP) + ! end if + ! if (.not.found_bond.and.p1%i.ne.p2%i.and.dist.lt.rc) then + ! p1%Abond=p1%Abond-max(kc*((rc/dist)**nc-1.0_WP),0.0_WP)*(rpos/dist)*p1%vol/this%rho + ! p1%flag = -2 + ! end if + end do + end do + end do + end do + ! Deal with dimensionality + if (this%cfg%nx.eq.1) p1%Abond(1)=0.0_WP + if (this%cfg%ny.eq.1) p1%Abond(2)=0.0_WP + if (this%cfg%nz.eq.1) p1%Abond(3)=0.0_WP + ! Copy back the particle + this%p(n1)=p1 + end do + ! Get global minimum + call MPI_ALLREDUCE(MPI_IN_PLACE,this%min_dist,1,MPI_REAL_WP,MPI_MIN,this%cfg%comm,ierr) + end block update_bond_force + + ! Clean up + if (allocated(npic)) deallocate(npic) + if (allocated(ipic)) deallocate(ipic) + + end subroutine get_bond_force + + + !> Advance the particle equations by a specified time step dt + !> p%id=-2 => do not solve for position nor velocity + !> p%id=-1 => do not solve for velocity + !> p%id= 0 => do not update force + + subroutine advance(this,dt)!,stress_x,stress_y,stress_z) + use mpi_f08, only : MPI_SUM,MPI_INTEGER,MPI_IN_PLACE + use mathtools, only: Pi + implicit none + class(lss), intent(inout) :: this + real(WP), intent(inout) :: dt !< Timestep size over which to advance + ! real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(inout) :: stress_x !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + ! real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(inout) :: stress_y !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + ! real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(inout) :: stress_z !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + integer :: n,ierr + ! real(WP), dimension(3) :: stress + + ! Zero out number of particles removed + this%np_out=0 + + ! Advance velocity based on old force and position based on mid-velocity + do n=1,this%np_ + ! Advance with Verlet scheme + if (this%p(n)%id.gt.-1) this%p(n)%vel=this%p(n)%vel+0.5_WP*dt*(this%gravity+this%p(n)%Abond+this%p(n)%Afluid) + if (this%p(n)%id.gt.-2) this%p(n)%pos=this%p(n)%pos+dt*this%p(n)%vel + ! Relocalize + this%p(n)%ind=this%cfg%get_ijk_global(this%p(n)%pos,this%p(n)%ind) + ! Correct the position to take into account periodicity + if (this%cfg%xper) this%p(n)%pos(1)=this%cfg%x(this%cfg%imin)+modulo(this%p(n)%pos(1)-this%cfg%x(this%cfg%imin),this%cfg%xL) + if (this%cfg%yper) this%p(n)%pos(2)=this%cfg%y(this%cfg%jmin)+modulo(this%p(n)%pos(2)-this%cfg%y(this%cfg%jmin),this%cfg%yL) + if (this%cfg%zper) this%p(n)%pos(3)=this%cfg%z(this%cfg%kmin)+modulo(this%p(n)%pos(3)-this%cfg%z(this%cfg%kmin),this%cfg%zL) + ! Handle particles that have left the domain + if (this%p(n)%pos(1).lt.this%cfg%x(this%cfg%imin).or.this%p(n)%pos(1).gt.this%cfg%x(this%cfg%imax+1)) this%p(n)%flag=1 + if (this%p(n)%pos(2).lt.this%cfg%y(this%cfg%jmin).or.this%p(n)%pos(2).gt.this%cfg%y(this%cfg%jmax+1)) this%p(n)%flag=1 + if (this%p(n)%pos(3).lt.this%cfg%z(this%cfg%kmin).or.this%p(n)%pos(3).gt.this%cfg%z(this%cfg%kmax+1)) this%p(n)%flag=1 + ! Relocalize the particle + this%p(n)%ind=this%cfg%get_ijk_global(this%p(n)%pos,this%p(n)%ind) + ! Count number of particles removed + if (this%p(n)%flag.eq.1) this%np_out=this%np_out+1 + end do + + ! Communicate particles + call this%sync() + + ! Sum up particles removed + call MPI_ALLREDUCE(this%np_out,n,1,MPI_INTEGER,MPI_SUM,this%cfg%comm,ierr); this%np_out=n + + ! Calculate bond force + call this%get_bond_force() + + ! Advance velocity only based on new force + do n=1,this%np_ + ! Advance with Verlet scheme + if (this%p(n)%id.le.-1) cycle + ! stress=this%cfg%get_velocity(pos=this%p(n)%pos,i0=this%p(n)%ind(1),j0=this%p(n)%ind(2),k0=this%p(n)%ind(3),U=stress_x,V=stress_y,W=stress_z) + ! this%p(n)%Afluid=stress/this%rho + this%p(n)%Afluid=0.0_WP + this%p(n)%vel=this%p(n)%vel+0.5_WP*dt*(this%gravity+this%p(n)%Abond+this%p(n)%Afluid) + end do + + ! Recompute volume fraction + ! call this%update_VF() + + ! Log/screen output + logging: block + use, intrinsic :: iso_fortran_env, only: output_unit + use param, only: verbose + use messager, only: log + use string, only: str_long + character(len=str_long) :: message + if (this%cfg%amRoot) then + write(message,'("Particle solver [",a,"] on partitioned grid [",a,"]: ",i0," particles were advanced")') trim(this%name),trim(this%cfg%name),this%np + if (verbose.gt.1) write(output_unit,'(a)') trim(message) + if (verbose.gt.0) call log(message) + end if + end block logging + + end subroutine advance + + subroutine stretch(this,dt)!,stress_x,stress_y,stress_z) + use mpi_f08, only : MPI_SUM,MPI_INTEGER,MPI_IN_PLACE + use mathtools, only: Pi + implicit none + class(lss), intent(inout) :: this + real(WP), intent(inout) :: dt !< Timestep size over which to advance + real(WP) :: mu + integer :: n,ierr + real(WP), allocatable :: temp_gd(:,:) + + allocate(temp_gd(this%np_, 3)) + + !======================================================================================== + ! X-Axis Stretch: + ! Zero out number of particles removed + this%np_out=0 + do n=1,this%np_ + ! Stretch the beam along the x axis with a uniform strain-rate of 0.001 + ! if (this%p(n)%id.gt.-2) this%p(n)%pos(1)=this%p(n)%pos(1)*1.001_WP + this%p(n)%pos(1)=this%p(n)%pos(1)*1.001_WP + end do + + ! Communicate particles + call this%sync() + + ! Calculate bond force + call this%get_bond_force() + + mu=this%elastic_modulus/(2.0_WP+2.0_WP*this%poisson_ratio) + + do n=1,this%np_ + !if (this%p(n)%id.gt.-2) temp_gd(n,1)=0.001_WP/this%p(n)%dil + temp_gd(n,1)=0.001_WP/this%p(n)%dil + end do + + !======================================================================================== + ! Y-Axis Stretch: + ! Zero out number of particles removed + this%np_out=0 + do n=1,this%np_ + ! Stretch the beam along the x axis with a uniform strain-rate of 0.001 + ! if (this%p(n)%id.gt.-2) this%p(n)%pos(1)=this%p(n)%pos(1)/1.001_WP + ! if (this%p(n)%id.gt.-2) this%p(n)%pos(2)=this%p(n)%pos(2)*1.001_WP + this%p(n)%pos(1)=this%p(n)%pos(1)/1.001_WP + this%p(n)%pos(2)=this%p(n)%pos(2)*1.001_WP + end do + + ! Communicate particles + call this%sync() + + ! Calculate bond force + call this%get_bond_force() + + mu=this%elastic_modulus/(2.0_WP+2.0_WP*this%poisson_ratio) + + do n=1,this%np_ + !if (this%p(n)%id.gt.-2) temp_gd(n,2)=0.001_WP/this%p(n)%dil + temp_gd(n,2)=0.001_WP/this%p(n)%dil + end do + + !======================================================================================== + ! Z-Axis Stretch: + ! Zero out number of particles removed + this%np_out=0 + do n=1,this%np_ + ! Stretch the beam along the x axis with a uniform strain-rate of 0.001 + ! if (this%p(n)%id.gt.-2) this%p(n)%pos(2)=this%p(n)%pos(2)/1.001_WP + ! if (this%p(n)%id.gt.-2) this%p(n)%pos(3)=this%p(n)%pos(3)*1.001_WP + this%p(n)%pos(2)=this%p(n)%pos(2)/1.001_WP + this%p(n)%pos(3)=this%p(n)%pos(3)*1.001_WP + end do + + ! Communicate particles + call this%sync() + + ! Calculate bond force + call this%get_bond_force() + + mu=this%elastic_modulus/(2.0_WP+2.0_WP*this%poisson_ratio) + + do n=1,this%np_ + !if (this%p(n)%id.gt.-2) temp_gd(n,3)=0.001_WP/this%p(n)%dil + temp_gd(n,3)=0.001_WP/this%p(n)%dil + end do + + ! Put the particle back where it was + do n=1,this%np_ + !if (this%p(n)%id.gt.-2) this%p(n)%pos(3)=this%p(n)%pos(3)/1.001_WP + this%p(n)%pos(3)=this%p(n)%pos(3)/1.001_WP + end do + + !====================================================================================== + + do n=1,this%np_ + !if (this%p(n)%id.gt.-2) then + this%p(n)%gd(1) = temp_gd(n,1) + this%p(n)%gd(2) = temp_gd(n,2) + this%p(n)%gd(3) = temp_gd(n,3) + !end if + end do + ! Now stretch particle for the first time step + + do n=1,this%np_ + ! Stretch the beam along the x axis with a uniform strain-rate of 0.001 + if (this%p(n)%id.gt.-2) this%p(n)%pos(1)=this%p(n)%pos(1)*1.001_WP + end do + + ! Communicate particles + call this%sync() + + ! Calculate bond force + call this%get_bond_force() + + + + + end subroutine stretch + + subroutine get_correction_coeffs(this,dt)!,stress_x,stress_y,stress_z) + use mpi_f08, only : MPI_SUM,MPI_INTEGER,MPI_IN_PLACE + use mathtools, only: Pi + implicit none + class(lss), intent(inout) :: this + real(WP), intent(inout) :: dt !< Timestep size over which to advance + real(WP) :: mu + integer :: n,ierr + ! Zero out number of particles removed + this%np_out=0 + do n=1,this%np_ + ! Stretch the beam along the x axis with a uniform strain-rate of 0.001 + if (this%p(n)%id.gt.-2) this%p(n)%pos(1)=this%p(n)%pos(1) + this%p(n)%pos(1)*0.001_WP + ! Relocalize + this%p(n)%ind=this%cfg%get_ijk_global(this%p(n)%pos,this%p(n)%ind) + ! Correct the position to take into account periodicity + if (this%cfg%xper) this%p(n)%pos(1)=this%cfg%x(this%cfg%imin)+modulo(this%p(n)%pos(1)-this%cfg%x(this%cfg%imin),this%cfg%xL) + if (this%cfg%yper) this%p(n)%pos(2)=this%cfg%y(this%cfg%jmin)+modulo(this%p(n)%pos(2)-this%cfg%y(this%cfg%jmin),this%cfg%yL) + if (this%cfg%zper) this%p(n)%pos(3)=this%cfg%z(this%cfg%kmin)+modulo(this%p(n)%pos(3)-this%cfg%z(this%cfg%kmin),this%cfg%zL) + ! Handle particles that have left the domain + if (this%p(n)%pos(1).lt.this%cfg%x(this%cfg%imin).or.this%p(n)%pos(1).gt.this%cfg%x(this%cfg%imax+1)) this%p(n)%flag=1 + if (this%p(n)%pos(2).lt.this%cfg%y(this%cfg%jmin).or.this%p(n)%pos(2).gt.this%cfg%y(this%cfg%jmax+1)) this%p(n)%flag=1 + if (this%p(n)%pos(3).lt.this%cfg%z(this%cfg%kmin).or.this%p(n)%pos(3).gt.this%cfg%z(this%cfg%kmax+1)) this%p(n)%flag=1 + ! Relocalize the particle + this%p(n)%ind=this%cfg%get_ijk_global(this%p(n)%pos,this%p(n)%ind) + ! Count number of particles removed + end do + + ! Communicate particles + call this%sync() + + ! Sum up particles removed + call MPI_ALLREDUCE(this%np_out,n,1,MPI_INTEGER,MPI_SUM,this%cfg%comm,ierr); this%np_out=n + + ! Calculate bond force + call this%get_bond_force() + + mu=this%elastic_modulus/(2.0_WP+2.0_WP*this%poisson_ratio) + + do n=1,this%np_ + this%p(n)%gd=0.001_WP/this%p(n)%dil + this%p(n)%Gb=0.5_WP*mu*(0.001_WP*0.001_WP)/this%p(n)%ste + end do + + ! Log/screen output + logging: block + use, intrinsic :: iso_fortran_env, only: output_unit + use param, only: verbose + use messager, only: log + use string, only: str_long + character(len=str_long) :: message + if (this%cfg%amRoot) then + write(message,'("Particle solver [",a,"] on partitioned grid [",a,"]: ",i0," particles were advanced")') trim(this%name),trim(this%cfg%name),this%np + if (verbose.gt.1) write(output_unit,'(a)') trim(message) + if (verbose.gt.0) call log(message) + end if + end block logging + + end subroutine get_correction_coeffs + + + !> Update particle volume fraction using our current particles + subroutine update_VF(this) + implicit none + class(lss), intent(inout) :: this + integer :: i + ! Reset volume fraction and momentum + this%VF=0.0_WP; this%VFU=0.0_WP; this%VFV=0.0_WP; this%VFW=0.0_WP + ! Transfer particle volume + do i=1,this%np_ + ! Skip inactive particle + if (this%p(i)%flag.eq.1) cycle + ! Transfer volume to mesh + call this%extrapolate(Ap=this%p(i)%vol,xp=this%p(i)%pos(1),yp=this%p(i)%pos(2),zp=this%p(i)%pos(3),ip=this%p(i)%ind(1),jp=this%p(i)%ind(2),kp=this%p(i)%ind(3),A=this%VF,dir='SC') + call this%extrapolate(Ap=this%p(i)%vol*this%p(i)%vel(1),xp=this%p(i)%pos(1),yp=this%p(i)%pos(2),zp=this%p(i)%pos(3),ip=this%p(i)%ind(1),jp=this%p(i)%ind(2),kp=this%p(i)%ind(3),A=this%VFU,dir='U') + call this%extrapolate(Ap=this%p(i)%vol*this%p(i)%vel(2),xp=this%p(i)%pos(1),yp=this%p(i)%pos(2),zp=this%p(i)%pos(3),ip=this%p(i)%ind(1),jp=this%p(i)%ind(2),kp=this%p(i)%ind(3),A=this%VFV,dir='V') + call this%extrapolate(Ap=this%p(i)%vol*this%p(i)%vel(3),xp=this%p(i)%pos(1),yp=this%p(i)%pos(2),zp=this%p(i)%pos(3),ip=this%p(i)%ind(1),jp=this%p(i)%ind(2),kp=this%p(i)%ind(3),A=this%VFW,dir='W') + end do + ! Sum at boundaries + call this%cfg%syncsum(this%VF) + call this%cfg%syncsum(this%VFU) + call this%cfg%syncsum(this%VFV) + call this%cfg%syncsum(this%VFW) + ! Clip + where (this%VF.gt.1.0_WP) this%VF=1.0_WP + where (this%VF.lt.0.0_WP) this%VF=0.0_WP + end subroutine update_VF + + + !> Compute regularized delta function + subroutine get_delta(this,delta,ic,jc,kc,xp,yp,zp,dir) + implicit none + class(lss), intent(inout) :: this + real(WP), intent(out) :: delta !< Return delta function + integer, intent(in) :: ic,jc,kc !< Cell index + real(WP), intent(in) :: xp,yp,zp !< Position of marker + character(len=*) :: dir + real(WP) :: deltax,deltay,deltaz,r + + ! Compute in X + if (trim(adjustl(dir)).eq.'U') then + r=(xp-this%cfg%x(ic))*this%cfg%dxmi(ic) + deltax=roma_kernel(r)*this%cfg%dxmi(ic) + else + r=(xp-this%cfg%xm(ic))*this%cfg%dxi(ic) + deltax=roma_kernel(r)*this%cfg%dxi(ic) + end if + + ! Compute in Y + if (trim(adjustl(dir)).eq.'V') then + r=(yp-this%cfg%y(jc))*this%cfg%dymi(jc) + deltay=roma_kernel(r)*this%cfg%dymi(jc) + else + r=(yp-this%cfg%ym(jc))*this%cfg%dyi(jc) + deltay=roma_kernel(r)*this%cfg%dyi(jc) + end if + + ! Compute in Z + if (trim(adjustl(dir)).eq.'W') then + r=(zp-this%cfg%z(kc))*this%cfg%dzmi(kc) + deltaz=roma_kernel(r)*this%cfg%dzmi(kc) + else + r=(zp-this%cfg%zm(kc))*this%cfg%dzi(kc) + deltaz=roma_kernel(r)*this%cfg%dzi(kc) + end if + !else + + ! Put it all together + delta=deltax*deltay*deltaz + + contains + ! Mollification kernel + ! Roma A, Peskin C and Berger M 1999 J. Comput. Phys. 153 509–534 + function roma_kernel(r) result(phi) + implicit none + real(WP), intent(in) :: r + real(WP) :: phi + if (abs(r).le.0.5_WP) then + phi=1.0_WP/3.0_WP*(1.0_WP+sqrt(-3.0_WP*r**2+1.0_WP)) + else if (abs(r).gt.0.5_WP .and. abs(r).le.1.5_WP) then + phi=1.0_WP/6.0_WP*(5.0_WP-3.0_WP*abs(r)-sqrt(-3.0_WP*(1.0_WP-abs(r))**2+1.0_WP)) + else + phi=0.0_WP + end if + end function roma_kernel + + end subroutine get_delta + + + !> Interpolation routine + function interpolate(this,A,xp,yp,zp,ip,jp,kp,dir) result(Ap) + implicit none + class(lss), intent(inout) :: this + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(in) :: A !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + real(WP), intent(in) :: xp,yp,zp + integer, intent(in) :: ip,jp,kp + character(len=*) :: dir + real(WP) :: Ap + integer :: di,dj,dk + integer :: i1,i2,j1,j2,k1,k2 + real(WP), dimension(-2:+2,-2:+2,-2:+2) :: delta + ! Get the interpolation points + i1=ip-2; i2=ip+2 + j1=jp-2; j2=jp+2 + k1=kp-2; k2=kp+2 + ! Loop over neighboring cells and compute regularized delta function + do dk=-2,+2 + do dj=-2,+2 + do di=-2,+2 + call this%get_delta(delta=delta(di,dj,dk),ic=ip+di,jc=jp+dj,kc=kp+dk,xp=xp,yp=yp,zp=zp,dir=trim(dir)) + end do + end do + end do + ! Perform the actual interpolation on Ap + Ap = sum(delta*A(i1:i2,j1:j2,k1:k2))*this%cfg%vol(ip,jp,kp) + end function interpolate + + + !> Extrapolation routine + subroutine extrapolate(this,Ap,xp,yp,zp,ip,jp,kp,A,dir) + use messager, only: die + implicit none + class(lss), intent(inout) :: this + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:) :: A !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + real(WP), intent(in) :: xp,yp,zp + integer, intent(in) :: ip,jp,kp + real(WP), intent(in) :: Ap + character(len=*) :: dir + real(WP), dimension(-2:+2,-2:+2,-2:+2) :: delta + integer :: di,dj,dk + ! If particle has left processor domain or reached last ghost cell, kill job + if ( ip.lt.this%cfg%imin_-1.or.ip.gt.this%cfg%imax_+1.or.& + & jp.lt.this%cfg%jmin_-1.or.jp.gt.this%cfg%jmax_+1.or.& + & kp.lt.this%cfg%kmin_-1.or.kp.gt.this%cfg%kmax_+1) then + write(*,*) ip,jp,kp,xp,yp,zp + call die('[df extrapolate] Particle has left the domain') + end if + ! Loop over neighboring cells and compute regularized delta function + do dk=-2,+2 + do dj=-2,+2 + do di=-2,+2 + call this%get_delta(delta=delta(di,dj,dk),ic=ip+di,jc=jp+dj,kc=kp+dk,xp=xp,yp=yp,zp=zp,dir=trim(dir)) + end do + end do + end do + ! Perform the actual extrapolation on A + A(ip-2:ip+2,jp-2:jp+2,kp-2:kp+2)=A(ip-2:ip+2,jp-2:jp+2,kp-2:kp+2)+delta*Ap + end subroutine extrapolate + + + !> Calculate the CFL + subroutine get_cfl(this,dt,cfl) + use mpi_f08, only: MPI_ALLREDUCE,MPI_MAX + use parallel, only: MPI_REAL_WP + implicit none + class(lss), intent(inout) :: this + real(WP), intent(in) :: dt + real(WP), intent(out) :: cfl + integer :: i,ierr + real(WP) :: my_CFLp_x,my_CFLp_y,my_CFLp_z,kk,mu,a + + ! Set the CFLs to zero + my_CFLp_x=0.0_WP; my_CFLp_y=0.0_WP; my_CFLp_z=0.0_WP + do i=1,this%np_ + my_CFLp_x=max(my_CFLp_x,abs(this%p(i)%vel(1))*this%cfg%dxi(this%p(i)%ind(1))) + my_CFLp_y=max(my_CFLp_y,abs(this%p(i)%vel(2))*this%cfg%dyi(this%p(i)%ind(2))) + my_CFLp_z=max(my_CFLp_z,abs(this%p(i)%vel(3))*this%cfg%dzi(this%p(i)%ind(3))) + end do + my_CFLp_x=my_CFLp_x*dt; my_CFLp_y=my_CFLp_y*dt; my_CFLp_z=my_CFLp_z*dt + + ! Get the parallel max + call MPI_ALLREDUCE(my_CFLp_x,this%CFLp_x,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + call MPI_ALLREDUCE(my_CFLp_y,this%CFLp_y,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + call MPI_ALLREDUCE(my_CFLp_z,this%CFLp_z,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + + ! CFL based on elastic wave speed in material + kk=this%elastic_modulus/(3.0_WP-6.0_WP*this%poisson_ratio) + mu=this%elastic_modulus/(2.0_WP+2.0_WP*this%poisson_ratio) + a=sqrt((kk+4.0_WP*mu/3.0_WP)/this%rho) + this%CFLp_a=dt*a*3/this%delta + + ! Return the maximum CFL + cfl=max(this%CFLp_x,this%CFLp_y,this%CFLp_z,this%CFLp_a) + + end subroutine get_cfl + + + !> Extract various monitoring data from particle field + subroutine get_max(this) + use mpi_f08, only: MPI_ALLREDUCE,MPI_MAX,MPI_MIN,MPI_SUM + use parallel, only: MPI_REAL_WP + implicit none + class(lss), intent(inout) :: this + real(WP) :: buf,safe_np + real(WP), dimension(3) :: buf3D + integer :: i,j,k,ierr + + ! Create safe np + safe_np=real(max(this%np,1),WP) + + ! Velocity min/max/mean + this%Umin=huge(1.0_WP); this%Umax=-huge(1.0_WP); this%Umean=0.0_WP + this%Vmin=huge(1.0_WP); this%Vmax=-huge(1.0_WP); this%Vmean=0.0_WP + this%Wmin=huge(1.0_WP); this%Wmax=-huge(1.0_WP); this%Wmean=0.0_WP + this%ibmForce=0.0_WP + do i=1,this%np_ + this%Umin=min(this%Umin,this%p(i)%vel(1)); this%Umax=max(this%Umax,this%p(i)%vel(1)); this%Umean=this%Umean+this%p(i)%vel(1) + this%Vmin=min(this%Vmin,this%p(i)%vel(2)); this%Vmax=max(this%Vmax,this%p(i)%vel(2)); this%Vmean=this%Vmean+this%p(i)%vel(2) + this%Wmin=min(this%Wmin,this%p(i)%vel(3)); this%Wmax=max(this%Wmax,this%p(i)%vel(3)); this%Wmean=this%Wmean+this%p(i)%vel(3) + this%ibmForce=this%ibmForce+this%p(i)%Afluid*this%p(i)%vol*this%rho + end do + call MPI_ALLREDUCE(this%Umin ,buf,1,MPI_REAL_WP,MPI_MIN,this%cfg%comm,ierr); this%Umin =buf + call MPI_ALLREDUCE(this%Umax ,buf,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr); this%Umax =buf + call MPI_ALLREDUCE(this%Umean,buf,1,MPI_REAL_WP,MPI_SUM,this%cfg%comm,ierr); this%Umean=buf/safe_np + call MPI_ALLREDUCE(this%Vmin ,buf,1,MPI_REAL_WP,MPI_MIN,this%cfg%comm,ierr); this%Vmin =buf + call MPI_ALLREDUCE(this%Vmax ,buf,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr); this%Vmax =buf + call MPI_ALLREDUCE(this%Vmean,buf,1,MPI_REAL_WP,MPI_SUM,this%cfg%comm,ierr); this%Vmean=buf/safe_np + call MPI_ALLREDUCE(this%Wmin ,buf,1,MPI_REAL_WP,MPI_MIN,this%cfg%comm,ierr); this%Wmin =buf + call MPI_ALLREDUCE(this%Wmax ,buf,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr); this%Wmax =buf + call MPI_ALLREDUCE(this%Wmean,buf,1,MPI_REAL_WP,MPI_SUM,this%cfg%comm,ierr); this%Wmean=buf/safe_np + call MPI_ALLREDUCE(this%ibmForce,buf3D,3,MPI_REAL_WP,MPI_SUM,this%cfg%comm,ierr); this%ibmForce=buf3D + + ! Get max volume fraction + this%VFmax =-huge(1.0_WP) + do k=this%cfg%kmin_,this%cfg%kmax_ + do j=this%cfg%jmin_,this%cfg%jmax_ + do i=this%cfg%imin_,this%cfg%imax_ + this%VFmax=max(this%VFmax,this%VF(i,j,k)) + end do + end do + end do + call MPI_ALLREDUCE(this%VFmax,buf,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr); this%VFmax=buf + + end subroutine get_max + + + !> Update particle mesh using our current particles + subroutine update_partmesh(this,pmesh) + use partmesh_class, only: partmesh + implicit none + class(lss), intent(inout) :: this + class(partmesh), intent(inout) :: pmesh + integer :: i + ! Reset particle mesh storage + call pmesh%reset() + ! Nothing else to do if no particle is present + if (this%np_.eq.0) return + ! Copy particle info + call pmesh%set_size(this%np_) + do i=1,this%np_ + pmesh%pos(:,i)=this%p(i)%pos + end do + end subroutine update_partmesh + + + !> Creation of the MPI datatype for particle + subroutine prepare_mpi_part() + use mpi_f08 + use messager, only: die + implicit none + integer(MPI_ADDRESS_KIND), dimension(part_nblock) :: disp + integer(MPI_ADDRESS_KIND) :: lb,extent + type(MPI_Datatype) :: MPI_PART_TMP + integer :: i,mysize,ierr + ! Prepare the displacement array + disp(1)=0 + do i=2,part_nblock + call MPI_Type_size(part_tblock(i-1),mysize,ierr) + disp(i)=disp(i-1)+int(mysize,MPI_ADDRESS_KIND)*int(part_lblock(i-1),MPI_ADDRESS_KIND) + end do + ! Create and commit the new type + call MPI_Type_create_struct(part_nblock,part_lblock,disp,part_tblock,MPI_PART_TMP,ierr) + call MPI_Type_get_extent(MPI_PART_TMP,lb,extent,ierr) + call MPI_Type_create_resized(MPI_PART_TMP,lb,extent,MPI_PART,ierr) + call MPI_Type_commit(MPI_PART,ierr) + ! If a problem was encountered, say it + if (ierr.ne.0) call die('[lss prepare_mpi_part] MPI Particle type creation failed') + ! Get the size of this type + call MPI_type_size(MPI_PART,MPI_PART_SIZE,ierr) + end subroutine prepare_mpi_part + + + !> Share particles across processor boundaries + subroutine share(this,nover) + use mpi_f08 + use messager, only: warn,die + implicit none + class(lss), intent(inout) :: this + integer, optional :: nover + type(part), dimension(:), allocatable :: tosend + type(part), dimension(:), allocatable :: torecv + integer :: no,nsend,nrecv + type(MPI_Status) :: status + integer :: icnt,isrc,idst,ierr + integer :: i,n + + ! Check overlap size + if (present(nover)) then + no=nover + if (no.gt.this%cfg%no) then + call warn('[lss share] Specified overlap is larger than that of cfg - reducing no') + no=this%cfg%no + else if (no.le.0) then + call die('[lss share] Specified overlap cannot be less or equal to zero') + end if + else + no=1 + end if + + ! Clean up ghost array + call this%resize_ghost(n=0); this%ng_=0 + + ! Share ghost particles in -x (no ghosts are sent here) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(1).lt.this%cfg%imin_+no) nsend=nsend+1 + end do + allocate(tosend(nsend)) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(1).lt.this%cfg%imin_+no) then + nsend=nsend+1 + tosend(nsend)=this%p(n) + if (this%cfg%xper.and.tosend(nsend)%ind(1).lt.this%cfg%imin+no) then + tosend(nsend)%pos(1)=tosend(nsend)%pos(1)+this%cfg%xL + tosend(nsend)%ind(1)=tosend(nsend)%ind(1)+this%cfg%nx + end if + end if + end do + nrecv=0 + call MPI_CART_SHIFT(this%cfg%comm,0,-1,isrc,idst,ierr) + call MPI_SENDRECV(nsend,1,MPI_INTEGER,idst,0,nrecv,1,MPI_INTEGER,isrc,0,this%cfg%comm,status,ierr) + allocate(torecv(nrecv)) + call MPI_SENDRECV(tosend,nsend,MPI_PART,idst,0,torecv,nrecv,MPI_PART,isrc,0,this%cfg%comm,status,ierr) + call this%resize_ghost(this%ng_+nrecv) + this%g(this%ng_+1:this%ng_+nrecv)=torecv + this%ng_=this%ng_+nrecv + if (allocated(tosend)) deallocate(tosend) + if (allocated(torecv)) deallocate(torecv) + + ! Share ghost particles in +x (no ghosts are sent here) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(1).gt.this%cfg%imax_-no) nsend=nsend+1 + end do + allocate(tosend(nsend)) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(1).gt.this%cfg%imax_-no) then + nsend=nsend+1 + tosend(nsend)=this%p(n) + if (this%cfg%xper.and.tosend(nsend)%ind(1).gt.this%cfg%imax-no) then + tosend(nsend)%pos(1)=tosend(nsend)%pos(1)-this%cfg%xL + tosend(nsend)%ind(1)=tosend(nsend)%ind(1)-this%cfg%nx + end if + end if + end do + nrecv=0 + call MPI_CART_SHIFT(this%cfg%comm,0,+1,isrc,idst,ierr) + call MPI_SENDRECV(nsend,1,MPI_INTEGER,idst,0,nrecv,1,MPI_INTEGER,isrc,0,this%cfg%comm,status,ierr) + allocate(torecv(nrecv)) + call MPI_SENDRECV(tosend,nsend,MPI_PART,idst,0,torecv,nrecv,MPI_PART,isrc,0,this%cfg%comm,status,ierr) + call this%resize_ghost(this%ng_+nrecv) + this%g(this%ng_+1:this%ng_+nrecv)=torecv + this%ng_=this%ng_+nrecv + if (allocated(tosend)) deallocate(tosend) + if (allocated(torecv)) deallocate(torecv) + + ! Share ghost particles in -y (ghosts need to be sent now) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(2).lt.this%cfg%jmin_+no) nsend=nsend+1 + end do + do n=1,this%ng_ + if (this%g(n)%ind(2).lt.this%cfg%jmin_+no) nsend=nsend+1 + end do + allocate(tosend(nsend)) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(2).lt.this%cfg%jmin_+no) then + nsend=nsend+1 + tosend(nsend)=this%p(n) + if (this%cfg%yper.and.tosend(nsend)%ind(2).lt.this%cfg%jmin+no) then + tosend(nsend)%pos(2)=tosend(nsend)%pos(2)+this%cfg%yL + tosend(nsend)%ind(2)=tosend(nsend)%ind(2)+this%cfg%ny + end if + end if + end do + do n=1,this%ng_ + if (this%g(n)%ind(2).lt.this%cfg%jmin_+no) then + nsend=nsend+1 + tosend(nsend)=this%g(n) + if (this%cfg%yper.and.tosend(nsend)%ind(2).lt.this%cfg%jmin+no) then + tosend(nsend)%pos(2)=tosend(nsend)%pos(2)+this%cfg%yL + tosend(nsend)%ind(2)=tosend(nsend)%ind(2)+this%cfg%ny + end if + end if + end do + nrecv=0 + call MPI_CART_SHIFT(this%cfg%comm,1,-1,isrc,idst,ierr) + call MPI_SENDRECV(nsend,1,MPI_INTEGER,idst,0,nrecv,1,MPI_INTEGER,isrc,0,this%cfg%comm,status,ierr) + allocate(torecv(nrecv)) + call MPI_SENDRECV(tosend,nsend,MPI_PART,idst,0,torecv,nrecv,MPI_PART,isrc,0,this%cfg%comm,status,ierr) + call this%resize_ghost(this%ng_+nrecv) + this%g(this%ng_+1:this%ng_+nrecv)=torecv + this%ng_=this%ng_+nrecv + if (allocated(tosend)) deallocate(tosend) + if (allocated(torecv)) deallocate(torecv) + + ! Share ghost particles in +y (ghosts need to be sent now - but not newly received ghosts!) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(2).gt.this%cfg%jmax_-no) nsend=nsend+1 + end do + do n=1,this%ng_-nrecv + if (this%g(n)%ind(2).gt.this%cfg%jmax_-no) nsend=nsend+1 + end do + allocate(tosend(nsend)) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(2).gt.this%cfg%jmax_-no) then + nsend=nsend+1 + tosend(nsend)=this%p(n) + if (this%cfg%yper.and.tosend(nsend)%ind(2).gt.this%cfg%jmax-no) then + tosend(nsend)%pos(2)=tosend(nsend)%pos(2)-this%cfg%yL + tosend(nsend)%ind(2)=tosend(nsend)%ind(2)-this%cfg%ny + end if + end if + end do + do n=1,this%ng_-nrecv + if (this%g(n)%ind(2).gt.this%cfg%jmax_-no) then + nsend=nsend+1 + tosend(nsend)=this%g(n) + if (this%cfg%yper.and.tosend(nsend)%ind(2).gt.this%cfg%jmax-no) then + tosend(nsend)%pos(2)=tosend(nsend)%pos(2)-this%cfg%yL + tosend(nsend)%ind(2)=tosend(nsend)%ind(2)-this%cfg%ny + end if + end if + end do + nrecv=0 + call MPI_CART_SHIFT(this%cfg%comm,1,+1,isrc,idst,ierr) + call MPI_SENDRECV(nsend,1,MPI_INTEGER,idst,0,nrecv,1,MPI_INTEGER,isrc,0,this%cfg%comm,status,ierr) + allocate(torecv(nrecv)) + call MPI_SENDRECV(tosend,nsend,MPI_PART,idst,0,torecv,nrecv,MPI_PART,isrc,0,this%cfg%comm,status,ierr) + call this%resize_ghost(this%ng_+nrecv) + this%g(this%ng_+1:this%ng_+nrecv)=torecv + this%ng_=this%ng_+nrecv + if (allocated(tosend)) deallocate(tosend) + if (allocated(torecv)) deallocate(torecv) + + ! Share ghost particles in -z (ghosts need to be sent now) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(3).lt.this%cfg%kmin_+no) nsend=nsend+1 + end do + do n=1,this%ng_ + if (this%g(n)%ind(3).lt.this%cfg%kmin_+no) nsend=nsend+1 + end do + allocate(tosend(nsend)) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(3).lt.this%cfg%kmin_+no) then + nsend=nsend+1 + tosend(nsend)=this%p(n) + if (this%cfg%zper.and.tosend(nsend)%ind(3).lt.this%cfg%kmin+no) then + tosend(nsend)%pos(3)=tosend(nsend)%pos(3)+this%cfg%zL + tosend(nsend)%ind(3)=tosend(nsend)%ind(3)+this%cfg%nz + end if + end if + end do + do n=1,this%ng_ + if (this%g(n)%ind(3).lt.this%cfg%kmin_+no) then + nsend=nsend+1 + tosend(nsend)=this%g(n) + if (this%cfg%zper.and.tosend(nsend)%ind(3).lt.this%cfg%kmin+no) then + tosend(nsend)%pos(3)=tosend(nsend)%pos(3)+this%cfg%zL + tosend(nsend)%ind(3)=tosend(nsend)%ind(3)+this%cfg%nz + end if + end if + end do + nrecv=0 + call MPI_CART_SHIFT(this%cfg%comm,2,-1,isrc,idst,ierr) + call MPI_SENDRECV(nsend,1,MPI_INTEGER,idst,0,nrecv,1,MPI_INTEGER,isrc,0,this%cfg%comm,status,ierr) + allocate(torecv(nrecv)) + call MPI_SENDRECV(tosend,nsend,MPI_PART,idst,0,torecv,nrecv,MPI_PART,isrc,0,this%cfg%comm,status,ierr) + call this%resize_ghost(this%ng_+nrecv) + this%g(this%ng_+1:this%ng_+nrecv)=torecv + this%ng_=this%ng_+nrecv + if (allocated(tosend)) deallocate(tosend) + if (allocated(torecv)) deallocate(torecv) + + ! Share ghost particles in +z (ghosts need to be sent now - but not newly received ghosts!) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(3).gt.this%cfg%kmax_-no) nsend=nsend+1 + end do + do n=1,this%ng_-nrecv + if (this%g(n)%ind(3).gt.this%cfg%kmax_-no) nsend=nsend+1 + end do + allocate(tosend(nsend)) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(3).gt.this%cfg%kmax_-no) then + nsend=nsend+1 + tosend(nsend)=this%p(n) + if (this%cfg%zper.and.tosend(nsend)%ind(3).gt.this%cfg%kmax-no) then + tosend(nsend)%pos(3)=tosend(nsend)%pos(3)-this%cfg%zL + tosend(nsend)%ind(3)=tosend(nsend)%ind(3)-this%cfg%nz + end if + end if + end do + do n=1,this%ng_-nrecv + if (this%g(n)%ind(3).gt.this%cfg%kmax_-no) then + nsend=nsend+1 + tosend(nsend)=this%g(n) + if (this%cfg%zper.and.tosend(nsend)%ind(3).gt.this%cfg%kmax-no) then + tosend(nsend)%pos(3)=tosend(nsend)%pos(3)-this%cfg%zL + tosend(nsend)%ind(3)=tosend(nsend)%ind(3)-this%cfg%nz + end if + end if + end do + nrecv=0 + call MPI_CART_SHIFT(this%cfg%comm,2,+1,isrc,idst,ierr) + call MPI_SENDRECV(nsend,1,MPI_INTEGER,idst,0,nrecv,1,MPI_INTEGER,isrc,0,this%cfg%comm,status,ierr) + allocate(torecv(nrecv)) + call MPI_SENDRECV(tosend,nsend,MPI_PART,idst,0,torecv,nrecv,MPI_PART,isrc,0,this%cfg%comm,status,ierr) + call this%resize_ghost(this%ng_+nrecv) + this%g(this%ng_+1:this%ng_+nrecv)=torecv + this%ng_=this%ng_+nrecv + if (allocated(tosend)) deallocate(tosend) + if (allocated(torecv)) deallocate(torecv) + + end subroutine share + + + !> Synchronize particle arrays across processors + subroutine sync(this) + use mpi_f08 + implicit none + class(lss), intent(inout) :: this + integer, dimension(0:this%cfg%nproc-1) :: nsend_proc,nrecv_proc + integer, dimension(0:this%cfg%nproc-1) :: nsend_disp,nrecv_disp + integer :: n,prank,ierr + type(part), dimension(:), allocatable :: buf_send + ! Recycle first to minimize communication load + call this%recycle() + ! Prepare information about what to send + nsend_proc=0 + do n=1,this%np_ + prank=this%cfg%get_rank(this%p(n)%ind) + nsend_proc(prank)=nsend_proc(prank)+1 + end do + nsend_proc(this%cfg%rank)=0 + ! Inform processors of what they will receive + call MPI_ALLtoALL(nsend_proc,1,MPI_INTEGER,nrecv_proc,1,MPI_INTEGER,this%cfg%comm,ierr) + ! Prepare displacements for all-to-all + nsend_disp(0)=0 + nrecv_disp(0)=this%np_ !< Directly add particles at the end of main array + do n=1,this%cfg%nproc-1 + nsend_disp(n)=nsend_disp(n-1)+nsend_proc(n-1) + nrecv_disp(n)=nrecv_disp(n-1)+nrecv_proc(n-1) + end do + ! Allocate buffer to send particles + allocate(buf_send(sum(nsend_proc))) + ! Pack the particles in the send buffer + nsend_proc=0 + do n=1,this%np_ + ! Get the rank + prank=this%cfg%get_rank(this%p(n)%ind) + ! Skip particles still inside + if (prank.eq.this%cfg%rank) cycle + ! Pack up for sending + nsend_proc(prank)=nsend_proc(prank)+1 + buf_send(nsend_disp(prank)+nsend_proc(prank))=this%p(n) + ! Flag particle for removal + this%p(n)%flag=1 + end do + ! Allocate buffer for receiving particles + call this%resize(this%np_+sum(nrecv_proc)) + ! Perform communication + call MPI_ALLtoALLv(buf_send,nsend_proc,nsend_disp,MPI_PART,this%p,nrecv_proc,nrecv_disp,MPI_PART,this%cfg%comm,ierr) + ! Deallocate buffer + deallocate(buf_send) + ! Recycle to remove duplicate particles + call this%recycle() + end subroutine sync + + + !> Adaptation of particle array size + subroutine resize(this,n) + implicit none + class(lss), intent(inout) :: this + integer, intent(in) :: n + type(part), dimension(:), allocatable :: tmp + integer :: size_now,size_new + ! Resize particle array to size n + if (.not.allocated(this%p)) then + ! Allocate directly to size n + allocate(this%p(n)) + this%p(1:n)%flag=1 + else + ! Update from a non-zero size to another non-zero size + size_now=size(this%p,dim=1) + if (n.gt.size_now) then + size_new=max(n,int(real(size_now,WP)*coeff_up)) + allocate(tmp(size_new)) + tmp(1:size_now)=this%p + tmp(size_now+1:)%flag=1 + call move_alloc(tmp,this%p) + else if (n.lt.int(real(size_now,WP)*coeff_dn)) then + allocate(tmp(n)) + tmp(1:n)=this%p(1:n) + call move_alloc(tmp,this%p) + end if + end if + end subroutine resize + + + !> Adaptation of ghost array size + subroutine resize_ghost(this,n) + implicit none + class(lss), intent(inout) :: this + integer, intent(in) :: n + type(part), dimension(:), allocatable :: tmp + integer :: size_now,size_new + ! Resize ghost array to size n + if (.not.allocated(this%g)) then + ! Allocate directly to size n + allocate(this%g(n)) + this%g(1:n)%flag=1 + else + ! Update from a non-zero size to another non-zero size + size_now=size(this%g,dim=1) + if (n.gt.size_now) then + size_new=max(n,int(real(size_now,WP)*coeff_up)) + allocate(tmp(size_new)) + tmp(1:size_now)=this%g + tmp(size_now+1:)%flag=1 + call move_alloc(tmp,this%g) + else if (n.lt.int(real(size_now,WP)*coeff_dn)) then + allocate(tmp(n)) + tmp(1:n)=this%g(1:n) + call move_alloc(tmp,this%g) + end if + end if + end subroutine resize_ghost + + + !> Clean-up of particle array by removing flag=1 particles + subroutine recycle(this) + implicit none + class(lss), intent(inout) :: this + integer :: new_size,i,ierr + ! Compact all active particles at the beginning of the array + new_size=0 + if (allocated(this%p)) then + do i=1,size(this%p,dim=1) + if (this%p(i)%flag.ne.1) then + new_size=new_size+1 + if (i.ne.new_size) then + this%p(new_size)=this%p(i) + this%p(i)%flag=1 + end if + end if + end do + end if + ! Resize to new size + call this%resize(new_size) + ! Update number of particles + this%np_=new_size + call MPI_ALLGATHER(this%np_,1,MPI_INTEGER,this%np_proc,1,MPI_INTEGER,this%cfg%comm,ierr) + this%np=sum(this%np_proc) + end subroutine recycle + + + !> Parallel write particles to file + subroutine write(this,filename) + use mpi_f08 + use messager, only: die + use parallel, only: info_mpiio + implicit none + class(lss), intent(inout) :: this + character(len=*), intent(in) :: filename + type(MPI_File) :: ifile + type(MPI_Status):: status + integer(kind=MPI_OFFSET_KIND) :: offset + integer :: i,ierr,iunit + + ! Root serial-writes the file header + if (this%cfg%amRoot) then + ! Open the file + open(newunit=iunit,file=trim(filename),form='unformatted',status='replace',access='stream',iostat=ierr) + if (ierr.ne.0) call die('[lss write] Problem encountered while serial-opening data file: '//trim(filename)) + ! Number of particles and particle object size + write(iunit) this%np,MPI_PART_SIZE + ! Done with the header + close(iunit) + end if + + ! The rest is done in parallel + call MPI_FILE_OPEN(this%cfg%comm,trim(filename),IOR(MPI_MODE_WRONLY,MPI_MODE_APPEND),info_mpiio,ifile,ierr) + if (ierr.ne.0) call die('[lss write] Problem encountered while parallel-opening data file: '//trim(filename)) + + ! Get current position + call MPI_FILE_GET_POSITION(ifile,offset,ierr) + + ! Compute the offset and write + do i=1,this%cfg%rank + offset=offset+int(this%np_proc(i),MPI_OFFSET_KIND)*int(MPI_PART_SIZE,MPI_OFFSET_KIND) + end do + if (this%np_.gt.0) call MPI_FILE_WRITE_AT(ifile,offset,this%p,this%np_,MPI_PART,status,ierr) + + ! Close the file + call MPI_FILE_CLOSE(ifile,ierr) + + ! Log/screen output + logging: block + use, intrinsic :: iso_fortran_env, only: output_unit + use param, only: verbose + use messager, only: log + use string, only: str_long + character(len=str_long) :: message + if (this%cfg%amRoot) then + write(message,'("[lss write] Wrote ",i0," particles to file [",a,"] on partitioned grid [",a,"]")') this%np,trim(filename),trim(this%cfg%name) + if (verbose.gt.2) write(output_unit,'(a)') trim(message) + if (verbose.gt.1) call log(message) + end if + end block logging + + end subroutine write + + + !> Parallel read particles to file + subroutine read(this,filename) + use mpi_f08 + use messager, only: die + use parallel, only: info_mpiio + implicit none + class(lss), intent(inout) :: this + character(len=*), intent(in) :: filename + type(MPI_File) :: ifile + type(MPI_Status):: status + integer(kind=MPI_OFFSET_KIND) :: offset,header_offset + integer :: i,j,ierr,npadd,psize,nchunk,cnt + integer, dimension(:,:), allocatable :: ppp + + ! First open the file in parallel + call MPI_FILE_OPEN(this%cfg%comm,trim(filename),MPI_MODE_RDONLY,info_mpiio,ifile,ierr) + if (ierr.ne.0) call die('[lss read] Problem encountered while reading data file: '//trim(filename)) + + ! Read file header first + call MPI_FILE_READ_ALL(ifile,npadd,1,MPI_INTEGER,status,ierr) + call MPI_FILE_READ_ALL(ifile,psize,1,MPI_INTEGER,status,ierr) + + ! Remember current position + call MPI_FILE_GET_POSITION(ifile,header_offset,ierr) + + ! Check compatibility of particle type + if (psize.ne.MPI_PART_SIZE) call die('[lss read] Particle type unreadable') + + ! Naively share reading task among all processors + nchunk=int(npadd/(this%cfg%nproc*part_chunk_size))+1 + allocate(ppp(this%cfg%nproc,nchunk)) + ppp=int(npadd/(this%cfg%nproc*nchunk)) + cnt=0 + out:do j=1,nchunk + do i=1,this%cfg%nproc + cnt=cnt+1 + if (cnt.gt.mod(npadd,this%cfg%nproc*nchunk)) exit out + ppp(i,j)=ppp(i,j)+1 + end do + end do out + + ! Read by chunk + do j=1,nchunk + ! Find offset + offset=header_offset+int(MPI_PART_SIZE,MPI_OFFSET_KIND)*int(sum(ppp(1:this%cfg%rank,:))+sum(ppp(this%cfg%rank+1,1:j-1)),MPI_OFFSET_KIND) + ! Resize particle array + call this%resize(this%np_+ppp(this%cfg%rank+1,j)) + ! Read this file + call MPI_FILE_READ_AT(ifile,offset,this%p(this%np_+1:this%np_+ppp(this%cfg%rank+1,j)),ppp(this%cfg%rank+1,j),MPI_PART,status,ierr) + ! Most general case: relocate every droplet + do i=this%np_+1,this%np_+ppp(this%cfg%rank+1,j) + this%p(i)%ind=this%cfg%get_ijk_global(this%p(i)%pos,this%p(i)%ind) + end do + ! Exchange all that + call this%sync() + end do + + ! Close the file + call MPI_FILE_CLOSE(ifile,ierr) + + ! Log/screen output + logging: block + use, intrinsic :: iso_fortran_env, only: output_unit + use param, only: verbose + use messager, only: log + use string, only: str_long + character(len=str_long) :: message + if (this%cfg%amRoot) then + write(message,'("[lss read] Read ",i0," particles from file [",a,"] on partitioned grid [",a,"]")') npadd,trim(filename),trim(this%cfg%name) + if (verbose.gt.2) write(output_unit,'(a)') trim(message) + if (verbose.gt.1) call log(message) + end if + end block logging + + end subroutine read + + +end module lss_class diff --git a/examples/beam_test/src/lss_class_3_axis.f90 b/examples/beam_test/src/lss_class_3_axis.f90 new file mode 100644 index 000000000..1650239f7 --- /dev/null +++ b/examples/beam_test/src/lss_class_3_axis.f90 @@ -0,0 +1,1637 @@ +!> Lagrangian solid solver object +!> Implements peridynamics equations +module lss_class + use precision, only: WP + use string, only: str_medium + use config_class, only: config + use mpi_f08, only: MPI_Datatype,MPI_INTEGER8,MPI_INTEGER,MPI_DOUBLE_PRECISION + implicit none + private + + + ! Expose type/constructor/methods + public :: lss + + + !> Memory adaptation parameter + real(WP), parameter :: coeff_up=1.3_WP !< Particle array size increase factor + real(WP), parameter :: coeff_dn=0.7_WP !< Particle array size decrease factor + + + !> I/O chunk size to read at a time + integer, parameter :: part_chunk_size=1000 !< Read 1000 particles at a time before redistributing + + + !> Maximum number of bonds per particle + integer, parameter, public :: max_bond=400 !< Assumes something like a 7x7x7 stencil in 3D + + + !> Bonded solid particle definition + type :: part + !> MPI_DOUBLE_PRECISION data + real(WP) :: mw !< Weighted volume + real(WP) :: dil !< Element dilatation + real(WP) :: ste !< Element dilatation + real(WP) :: vol !< Particle volume + real(WP), dimension(max_bond) :: dbond !< Length of initial bonds + real(WP), dimension(3) :: pos !< Particle center coordinates + real(WP), dimension(3) :: vel !< Velocity of particle + real(WP), dimension(3) :: Abond !< Bond acceleration for particle + real(WP), dimension(3) :: Afluid !< Fluid acceleration for particle + real(WP), dimension(3) :: gd !< Dilitation corrections + real(WP), dimension(3) :: gb !< Shear corrections + !> MPI_INTEGER data + integer :: id !< ID the object is associated with + integer :: i !< Unique index of particle (assumed >0) + integer :: nbond !< Number of initial bonds + integer, dimension(max_bond) :: ibond !< Indices of initially bonded particles (0 values ignored) + integer , dimension(3) :: ind !< Index of cell containing particle center + integer :: flag !< Control parameter (0=normal, 1=done->will be removed) + end type part + !> Number of blocks, block length, and block types in a particle + integer, parameter :: part_nblock=2 + integer , dimension(part_nblock) :: part_lblock=[22+max_bond,7+max_bond] + type(MPI_Datatype), dimension(part_nblock) :: part_tblock=[MPI_DOUBLE_PRECISION,MPI_INTEGER] + !> MPI_PART derived datatype and size + type(MPI_Datatype) :: MPI_PART + integer :: MPI_PART_SIZE + + + !> Lagrangian solid solver object definition + type :: lss + + ! This config is used for parallelization and for calculating bond/collision forces + class(config), pointer :: cfg + + ! This is the name of the solver + character(len=str_medium) :: name='UNNAMED_LSS' + + ! Solid material properties + real(WP) :: elastic_modulus !< Elastic modulus of the material + real(WP) :: poisson_ratio !< Poisson's ratio of the material + real(WP) :: rho !< Density of the material + real(WP) :: crit_energy !< Critical energy release + + ! Bonding parameters + real(WP) :: delta !< Bonding horizon (distance) + real(WP) :: min_dist !< Minimum bonding distance + integer :: nb !< Cell-based horizon + + ! Global and local particle data + integer :: np !< Global number of particles + integer :: np_ !< Local number of particles + integer, dimension(:), allocatable :: np_proc !< Number of particles on each processor + type(part), dimension(:), allocatable :: p !< Array of particles of type part + + ! Overlap particle (i.e., ghost) data + integer :: ng_ !< Local number of ghosts + type(part), dimension(:), allocatable :: g !< Array of ghosts of type part + + ! Gravitational acceleration + real(WP), dimension(3) :: gravity=[0.0_WP,0.0_WP,0.0_WP] + + ! Solid volume fraction and momentum + real(WP), dimension(:,:,:), allocatable :: VF !< Volume fraction, cell-centered + real(WP), dimension(:,:,:), allocatable :: VFU !< Solid velocity, U-face + real(WP), dimension(:,:,:), allocatable :: VFV !< Solid velocity, V-face + real(WP), dimension(:,:,:), allocatable :: VFW !< Solid velocity, W-face + + ! CFL numbers + real(WP) :: CFLp_x,CFLp_y,CFLp_z,CFLp_a + + ! Number of substeps for time integrator + real(WP) :: nstep=1 + + ! Monitoring info + real(WP) :: Umin,Umax,Umean !< U velocity info + real(WP) :: Vmin,Vmax,Vmean !< V velocity info + real(WP) :: Wmin,Wmax,Wmean !< W velocity info + real(WP) :: VFmax !< Volume fraction info + real(WP), dimension(3) :: ibmForce !< Total force due to IBM + integer :: np_out !< Number of particles leaving the domain + + contains + procedure :: bond_init !< Setup initial interparticle bonds + procedure :: get_bond_force !< Compute interparticle bond force + procedure :: advance !< Step forward the particle ODEs + procedure :: get_cfl !< Calculate maximum CFL + procedure :: get_max !< Extract various monitoring data + procedure :: update_partmesh !< Update a partmesh object using current particles + procedure :: share !< Share particles across interprocessor boundaries + procedure :: sync !< Synchronize particles across interprocessor boundaries + procedure :: resize !< Resize particle array to given size + procedure :: resize_ghost !< Resize ghost array to given size + procedure :: recycle !< Recycle particle array by removing flagged particles + procedure :: write !< Parallel write particles to file + procedure :: read !< Parallel read particles from file + procedure :: update_VF !< Compute volume fraction + procedure :: get_delta !< Compute regularized delta function + procedure :: interpolate !< Interpolation routine from mesh=>marker + procedure :: extrapolate !< Extrapolation routine from marker=>mesh + procedure :: stretch + end type lss + + + !> Declare lss constructor + interface lss + procedure constructor + end interface lss + +contains + + + ! Quasi-Gaussian weighting function - h is the cut-off + real(WP) function wgauss(d,h) + implicit none + real(WP), intent(in) :: d,h + real(WP), parameter :: coeff=2.6_WP + real(WP) :: hh + hh=coeff*h + if (d.ge.hh) then + wgauss=0.0_WP + else + wgauss=(1.0_WP+4.0_WP*d/hh)*(1.0_WP-d/hh)**4 + end if + end function wgauss + + + !> Default constructor for Lagrangian solid solver + function constructor(cfg,name) result(self) + implicit none + type(lss) :: self + class(config), target, intent(in) :: cfg + character(len=*), optional :: name + integer :: i,j,k + + ! Set the name for the solver + if (present(name)) self%name=trim(adjustl(name)) + + ! Point to pgrid object + self%cfg=>cfg + + ! Set default bonding horizon based on underlying mesh + self%delta=self%cfg%min_meshsize + self%nb=1 + self%min_dist=huge(1.0_WP) + + ! Allocate variables + allocate(self%np_proc(1:self%cfg%nproc)); self%np_proc=0 + self%np_=0; self%np=0 + call self%resize(0) + + ! Initialize MPI derived datatype for a particle + call prepare_mpi_part() + + ! Allocate VF array on cfg mesh + allocate(self%VF(self%cfg%imino_:self%cfg%imaxo_,self%cfg%jmino_:self%cfg%jmaxo_,self%cfg%kmino_:self%cfg%kmaxo_)); self%VF=0.0_WP + allocate(self%VFU(self%cfg%imino_:self%cfg%imaxo_,self%cfg%jmino_:self%cfg%jmaxo_,self%cfg%kmino_:self%cfg%kmaxo_)); self%VFU=0.0_WP + allocate(self%VFV(self%cfg%imino_:self%cfg%imaxo_,self%cfg%jmino_:self%cfg%jmaxo_,self%cfg%kmino_:self%cfg%kmaxo_)); self%VFV=0.0_WP + allocate(self%VFW(self%cfg%imino_:self%cfg%imaxo_,self%cfg%jmino_:self%cfg%jmaxo_,self%cfg%kmino_:self%cfg%kmaxo_)); self%VFW=0.0_WP + + ! Log/screen output + logging: block + use, intrinsic :: iso_fortran_env, only: output_unit + use param, only: verbose + use messager, only: log + use string, only: str_long + character(len=str_long) :: message + if (self%cfg%amRoot) then + write(message,'("LSS object [",a,"] on partitioned grid [",a,"]")') trim(self%name),trim(self%cfg%name) + if (verbose.gt.1) write(output_unit,'(a)') trim(message) + if (verbose.gt.0) call log(message) + end if + end block logging + + end function constructor + + + !> Initialize bond force between particles + subroutine bond_init(this) + use messager, only: die + implicit none + class(lss), intent(inout) :: this + integer, dimension(:,:,:), allocatable :: npic !< Number of particle in cell + integer, dimension(:,:,:,:), allocatable :: ipic !< Index of particle in cell + + ! Communicate particles in ghost cells + call this%share() + + ! We can now assemble particle-in-cell information + pic_prep: block + use mpi_f08 + integer :: i,ip,jp,kp,ierr + integer :: mymax_npic,max_npic + + ! Allocate number of particle in cell + allocate(npic(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)); npic=0 + + ! Count particles and ghosts per cell + do i=1,this%np_ + ip=this%p(i)%ind(1); jp=this%p(i)%ind(2); kp=this%p(i)%ind(3) + npic(ip,jp,kp)=npic(ip,jp,kp)+1 + end do + do i=1,this%ng_ + ip=this%g(i)%ind(1); jp=this%g(i)%ind(2); kp=this%g(i)%ind(3) + npic(ip,jp,kp)=npic(ip,jp,kp)+1 + end do + + ! Get maximum number of particle in cell + mymax_npic=maxval(npic); call MPI_ALLREDUCE(mymax_npic,max_npic,1,MPI_INTEGER,MPI_MAX,this%cfg%comm,ierr) + + ! Allocate pic map + allocate(ipic(1:max_npic,this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)); ipic=0 + + ! Assemble pic map + npic=0 + do i=1,this%np_ + ip=this%p(i)%ind(1); jp=this%p(i)%ind(2); kp=this%p(i)%ind(3) + npic(ip,jp,kp)=npic(ip,jp,kp)+1 + ipic(npic(ip,jp,kp),ip,jp,kp)=+i + end do + do i=1,this%ng_ + ip=this%g(i)%ind(1); jp=this%g(i)%ind(2); kp=this%g(i)%ind(3) + npic(ip,jp,kp)=npic(ip,jp,kp)+1 + ipic(npic(ip,jp,kp),ip,jp,kp)=-i + end do + + end block pic_prep + + ! Establish initial bonds + create_bonds: block + use mpi_f08, only: MPI_ALLREDUCE,MPI_MIN,MPI_IN_PLACE + use parallel, only: MPI_REAL_WP + use mathtools, only: Pi + integer :: i,j,k,n1,nn,n2,ierr + type(part) :: p1,p2 + real(WP), dimension(3) :: rpos + real(WP) :: dist + ! Reset minimum bond distance + this%min_dist=huge(1.0_WP) + ! Loop over particles + do n1=1,this%np_ + ! Create copy of our particle + p1=this%p(n1) + ! Zero out weighted volume + p1%mw=0.0_WP + ! Zero out bonds + p1%ibond=0 + p1%nbond=0 + ! Loop over neighbor cells + do k=p1%ind(3)-this%nb,p1%ind(3)+this%nb + do j=p1%ind(2)-this%nb,p1%ind(2)+this%nb + do i=p1%ind(1)-this%nb,p1%ind(1)+this%nb + ! Loop over particles in that cell + do nn=1,npic(i,j,k) + ! Create copy of our neighbor + n2=ipic(nn,i,j,k) + if (n2.gt.0) then + p2=this%p(+n2) + else if (n2.lt.0) then + p2=this%g(-n2) + end if + ! Cannot self-bond + if (p1%i.eq.p2%i) cycle + ! Cannot bond with different id except <=0 (<=0 bonds with everyone) + if (p1%id.ne.p2%id.and.p1%id.ge.0.and.p2%id.ge.0) cycle + ! Check interparticle distance + rpos=p2%pos-p1%pos + dist=sqrt(dot_product(rpos,rpos)) + if (dist.lt.this%delta) then + ! This particle is in horizon, create a bond + p1%nbond=p1%nbond+1 + if (p1%nbond.gt.max_bond) call die('[lss_class bond_init] Number of detected bonds is larger than max allowed') + p1%ibond(p1%nbond)=p2%i + p1%dbond(p1%nbond)=dist + ! Increment weighted volume + p1%mw=p1%mw+wgauss(dist,this%delta)*dist**2*p1%vol + ! Determine minimum bond distance + this%min_dist=min(this%min_dist,dist) + end if + end do + end do + end do + end do + ! Zero out initial dilatation + p1%dil=0.0_WP + ! Copy back the particle + this%p(n1)=p1 + end do + ! Get global minimum + call MPI_ALLREDUCE(MPI_IN_PLACE,this%min_dist,1,MPI_REAL_WP,MPI_MIN,this%cfg%comm,ierr) + end block create_bonds + + ! Clean up + if (allocated(npic)) deallocate(npic) + if (allocated(ipic)) deallocate(ipic) + + end subroutine bond_init + + + !> Calculate bond force between particles + subroutine get_bond_force(this) + implicit none + class(lss), intent(inout) :: this + integer, dimension(:,:,:), allocatable :: npic !< Number of particle in cell + integer, dimension(:,:,:,:), allocatable :: ipic !< Index of particle in cell + logical :: is2D + + ! Need to modify parameters in 2D + is2D=this%cfg%nx.eq.1.or.this%cfg%ny.eq.1.or.this%cfg%nz.eq.1 + + ! Communicate particles in ghost cells + call this%share() + + ! We can now assemble particle-in-cell information + pic_prep: block + use mpi_f08 + integer :: i,ip,jp,kp,ierr + integer :: mymax_npic,max_npic + + ! Allocate number of particle in cell + allocate(npic(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)); npic=0 + + ! Count particles and ghosts per cell + do i=1,this%np_ + ip=this%p(i)%ind(1); jp=this%p(i)%ind(2); kp=this%p(i)%ind(3) + npic(ip,jp,kp)=npic(ip,jp,kp)+1 + end do + do i=1,this%ng_ + ip=this%g(i)%ind(1); jp=this%g(i)%ind(2); kp=this%g(i)%ind(3) + npic(ip,jp,kp)=npic(ip,jp,kp)+1 + end do + + ! Get maximum number of particle in cell + mymax_npic=maxval(npic); call MPI_ALLREDUCE(mymax_npic,max_npic,1,MPI_INTEGER,MPI_MAX,this%cfg%comm,ierr) + + ! Allocate pic map + allocate(ipic(1:max_npic,this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)); ipic=0 + + ! Assemble pic map + npic=0 + do i=1,this%np_ + ip=this%p(i)%ind(1); jp=this%p(i)%ind(2); kp=this%p(i)%ind(3) + npic(ip,jp,kp)=npic(ip,jp,kp)+1 + ipic(npic(ip,jp,kp),ip,jp,kp)=+i + end do + do i=1,this%ng_ + ip=this%g(i)%ind(1); jp=this%g(i)%ind(2); kp=this%g(i)%ind(3) + npic(ip,jp,kp)=npic(ip,jp,kp)+1 + ipic(npic(ip,jp,kp),ip,jp,kp)=-i + end do + + end block pic_prep + + ! Update weighted volume and dilatation + update_weighted_vol_and_dilatation: block + integer :: i,j,k,n1,nn,n2 + type(part) :: p1,p2 + integer :: nb,nbond + real(WP), dimension(3) :: rpos, Gd_vec + real(WP) :: dist, Gd_mag + ! Loop over particles + do n1=1,this%np_ + ! Create copy of our particle + p1=this%p(n1) + ! Zero out weighted volume and dilatation + p1%mw=0.0_WP + p1%dil=0.0_WP + ! Loop over neighbor cells + do k=p1%ind(3)-this%nb,p1%ind(3)+this%nb + do j=p1%ind(2)-this%nb,p1%ind(2)+this%nb + do i=p1%ind(1)-this%nb,p1%ind(1)+this%nb + ! Loop over particles in that cell + do nn=1,npic(i,j,k) + ! Create copy of our neighbor + n2=ipic(nn,i,j,k) + if (n2.gt.0) then + p2=this%p(+n2) + else if (n2.lt.0) then + p2=this%g(-n2) + end if + ! Check if a bond exists + do nb=1,max_bond + if (p1%ibond(nb).eq.p2%i) then + ! Increment weighted volume + p1%mw=p1%mw+wgauss(p1%dbond(nb),this%delta)*p1%dbond(nb)**2*p2%vol + ! Get current distance + rpos=p2%pos-p1%pos + dist=sqrt(dot_product(rpos,rpos)) + ! compute average G correction for dilitation + Gd_vec = (p2%gd + p1%gd)/2.0_WP + + Gd_mag = sqrt(1.0_WP/(((rpos(1)/dist)/Gd_vec(1))**2 + ((rpos(2)/dist)/Gd_vec(2))**2 + ((rpos(3)/dist)/Gd_vec(3))**2 )) + ! Increment dilatation + p1%dil=p1%dil+wgauss(p1%dbond(nb),this%delta)*p1%dbond(nb)*(dist-p1%dbond(nb))*p2%vol*Gd_mag + end if + end do + end do + end do + end do + end do + ! Rescale dilatation + if (p1%mw.gt.epsilon(1.0_WP)) then + if (is2D) then + ! 2D plane strain + p1%dil=p1%dil*2.0_WP/p1%mw + else + ! 3D + p1%dil=p1%dil*3.0_WP/p1%mw + end if + else + p1%dil=0.0_WP + end if + ! Copy back the particle + this%p(n1)=p1 + end do + end block update_weighted_vol_and_dilatation + + ! Re-communicate particles in ghost cells to update dil and mw + call this%share() + + ! Update bond force, including collision force, and SED + update_bond_force: block + use mpi_f08, only: MPI_ALLREDUCE,MPI_MIN,MPI_IN_PLACE + use parallel, only: MPI_REAL_WP + use mathtools, only: Pi + integer :: i,j,k,n1,nn,n2,ierr + type(part) :: p1,p2 + real(WP), dimension(3) :: rpos,t12,t21,Gd_vec + real(WP) :: dist,beta,alpha,ed,t,Gd_mag + real(WP) :: stretch,max_stretch,mu,kk + real(WP) :: nc,rc,kc + integer :: nb,nbond + logical :: found_bond + ! Recompute a few physical parameters + mu=this%elastic_modulus/(2.0_WP+2.0_WP*this%poisson_ratio) + kk=this%elastic_modulus/(3.0_WP-6.0_WP*this%poisson_ratio) + if (is2D) then + if (this%cfg%nx.eq.1) t=this%cfg%xL + if (this%cfg%ny.eq.1) t=this%cfg%yL + if (this%cfg%nz.eq.1) t=this%cfg%zL + max_stretch=sqrt(this%crit_energy/((6.0_WP*mu/Pi+16.0_WP/(9.0_WP*Pi**2)*(kk-2.0_WP*mu))*this%delta)) + kc=15.0_WP*48.0_WP*this%elastic_modulus/(Pi*5.0_WP*t*this%delta**3) + else + max_stretch=sqrt(this%crit_energy/((3.0_WP*mu+(kk-5.0_WP*mu/3.0_WP)*0.75_WP**4)*this%delta)) + kc=15.0_WP*12.0_WP*this%elastic_modulus/(Pi*this%delta**4) + end if + nc=1.0_WP + this%min_dist=huge(1.0_WP) + ! Loop over particles + do n1=1,this%np_ + ! Particles marked 0 do not update their forces + if (this%p(n1)%id.eq.0) cycle + ! Create copy of our particle + p1=this%p(n1) + ! Zero out bond force + p1%Abond=0.0_WP + ! Loop over neighbor cells + do k=p1%ind(3)-this%nb,p1%ind(3)+this%nb + do j=p1%ind(2)-this%nb,p1%ind(2)+this%nb + do i=p1%ind(1)-this%nb,p1%ind(1)+this%nb + ! Loop over particles in that cell + do nn=1,npic(i,j,k) + ! Create copy of our neighbor + n2=ipic(nn,i,j,k) + if (n2.gt.0) then + p2=this%p(+n2) + else if (n2.lt.0) then + p2=this%g(-n2) + end if + ! Current distance + rpos=p2%pos-p1%pos + dist=sqrt(dot_product(rpos,rpos)) + ! Check if a bond exists + found_bond=.false. + do nb=1,max_bond + if (p1%ibond(nb).eq.p2%i) then + ! Check for breakage first + stretch=(dist-p1%dbond(nb))/p1%dbond(nb) + if (stretch.gt.max_stretch) then + ! Remove the bond and flag as surface particle + p1%ibond(nb)=0 + p1%dbond(nb)=0.0_WP + cycle + end if + ! Particle 1 + if (is2D) then + ! 2D plane strain + beta = 2.0_WP * kk * p1%dil + alpha = 8.0_WP * mu / p1%mw + ed = dist - p1%dbond(nb) * (1.0_WP + p1%dil / 2.0_WP) + else + ! 3D + beta = 3.0_WP * kk * p1%dil + alpha = 15.0_WP * mu / p1%mw + ed = dist - p1%dbond(nb) * (1.0_WP + p1%dil / 3.0_WP) + end if + ! Force density 1->2 + ! t12=+wgauss(p1%dbond(nb),this%delta)*(beta/p1%mw*p1%dbond(nb)+alpha*ed)*rpos/dist + ! t12=+wgauss(p1%dbond(nb),this%delta)*((3.0_WP*kk - 15.0_WP*mu/3.0_WP)*(p1%dil*p1%dbond(nb)/p1%mw) + 15*mu*dist/p1%mw)*rpos/dist + Gd_vec = (p2%gd + p1%gd)/2.0_WP + + Gd_mag = sqrt(1.0_WP/(((rpos(1)/dist)/Gd_vec(1))**2 + ((rpos(2)/dist)/Gd_vec(2))**2 + ((rpos(3)/dist)/Gd_vec(3))**2 )) + t12=+wgauss(p1%dbond(nb),this%delta)*((3.0_WP*kk - 15.0_WP*mu/3.0_WP)*(Gd_mag*p1%dil*p1%dbond(nb)/p1%mw) + (15.0_WP*mu/p1%mw)*(dist - p1%dbond(nb)) )*rpos/dist + ! Particle 2 + if (is2D) then + ! 2D plane strain + beta = 2.0_WP * kk * p2%dil + alpha = 8.0_WP * mu / p2%mw + ed = dist - p1%dbond(nb) * (1.0_WP + p2%dil / 2.0_WP) + else + ! 3D + beta = 3.0_WP * kk * p2%dil + alpha = 15.0_WP * mu / p2%mw + ed = dist - p1%dbond(nb) * (1.0_WP + p2%dil / 3.0_WP) + end if + ! Force density 2->1 + ! t21=-wgauss(p1%dbond(nb),this%delta)*(beta/p2%mw*p1%dbond(nb)+alpha*ed)*rpos/dist + t21=-wgauss(p1%dbond(nb),this%delta)*((3.0_WP*kk - 15.0_WP*mu/3.0_WP)*(Gd_mag*p2%dil*p1%dbond(nb)/p2%mw)+ (15.0_WP*mu/p2%mw)*(dist - p1%dbond(nb)) )*rpos/dist ! Increment bond force + p1%Abond=p1%Abond+(t12-t21)*p2%vol/this%rho + ! Incremend SED + p1%ste=p1%ste+alpha/2.0_WP*(wgauss(p1%dbond(nb),this%delta)*((dist-p1%dbond(nb)))*p2%vol) + ! If still here, we have an active bond + found_bond=.true. + ! Determine minimum bond distance + this%min_dist=min(this%min_dist,dist) + cycle + end if + end do + ! Add collision force now + ! if (is2D) then + ! rc=p1%vol**(1.0_WP/2.0_WP) + ! else + ! rc=p1%vol**(1.0_WP/3.0_WP) + ! end if + ! if (.not.found_bond.and.p1%i.ne.p2%i.and.dist.lt.rc) then + ! p1%Abond=p1%Abond-max(kc*((rc/dist)**nc-1.0_WP),0.0_WP)*(rpos/dist)*p1%vol/this%rho + ! p1%flag = -2 + ! end if + end do + end do + end do + end do + ! Deal with dimensionality + if (this%cfg%nx.eq.1) p1%Abond(1)=0.0_WP + if (this%cfg%ny.eq.1) p1%Abond(2)=0.0_WP + if (this%cfg%nz.eq.1) p1%Abond(3)=0.0_WP + ! Copy back the particle + this%p(n1)=p1 + end do + ! Get global minimum + call MPI_ALLREDUCE(MPI_IN_PLACE,this%min_dist,1,MPI_REAL_WP,MPI_MIN,this%cfg%comm,ierr) + end block update_bond_force + + ! Clean up + if (allocated(npic)) deallocate(npic) + if (allocated(ipic)) deallocate(ipic) + + end subroutine get_bond_force + + + !> Advance the particle equations by a specified time step dt + !> p%id=-2 => do not solve for position nor velocity + !> p%id=-1 => do not solve for velocity + !> p%id= 0 => do not update force + + subroutine advance(this,dt)!,stress_x,stress_y,stress_z) + use mpi_f08, only : MPI_SUM,MPI_INTEGER,MPI_IN_PLACE + use mathtools, only: Pi + implicit none + class(lss), intent(inout) :: this + real(WP), intent(inout) :: dt !< Timestep size over which to advance + ! real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(inout) :: stress_x !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + ! real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(inout) :: stress_y !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + ! real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(inout) :: stress_z !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + integer :: n,ierr + ! real(WP), dimension(3) :: stress + + ! Zero out number of particles removed + this%np_out=0 + + ! Advance velocity based on old force and position based on mid-velocity + do n=1,this%np_ + ! Advance with Verlet scheme + if (this%p(n)%id.gt.-1) this%p(n)%vel=this%p(n)%vel+0.5_WP*dt*(this%gravity+this%p(n)%Abond+this%p(n)%Afluid) + if (this%p(n)%id.gt.-2) this%p(n)%pos=this%p(n)%pos+dt*this%p(n)%vel + ! Relocalize + this%p(n)%ind=this%cfg%get_ijk_global(this%p(n)%pos,this%p(n)%ind) + ! Correct the position to take into account periodicity + if (this%cfg%xper) this%p(n)%pos(1)=this%cfg%x(this%cfg%imin)+modulo(this%p(n)%pos(1)-this%cfg%x(this%cfg%imin),this%cfg%xL) + if (this%cfg%yper) this%p(n)%pos(2)=this%cfg%y(this%cfg%jmin)+modulo(this%p(n)%pos(2)-this%cfg%y(this%cfg%jmin),this%cfg%yL) + if (this%cfg%zper) this%p(n)%pos(3)=this%cfg%z(this%cfg%kmin)+modulo(this%p(n)%pos(3)-this%cfg%z(this%cfg%kmin),this%cfg%zL) + ! Handle particles that have left the domain + if (this%p(n)%pos(1).lt.this%cfg%x(this%cfg%imin).or.this%p(n)%pos(1).gt.this%cfg%x(this%cfg%imax+1)) this%p(n)%flag=1 + if (this%p(n)%pos(2).lt.this%cfg%y(this%cfg%jmin).or.this%p(n)%pos(2).gt.this%cfg%y(this%cfg%jmax+1)) this%p(n)%flag=1 + if (this%p(n)%pos(3).lt.this%cfg%z(this%cfg%kmin).or.this%p(n)%pos(3).gt.this%cfg%z(this%cfg%kmax+1)) this%p(n)%flag=1 + ! Relocalize the particle + this%p(n)%ind=this%cfg%get_ijk_global(this%p(n)%pos,this%p(n)%ind) + ! Count number of particles removed + if (this%p(n)%flag.eq.1) this%np_out=this%np_out+1 + end do + + ! Communicate particles + call this%sync() + + ! Sum up particles removed + call MPI_ALLREDUCE(this%np_out,n,1,MPI_INTEGER,MPI_SUM,this%cfg%comm,ierr); this%np_out=n + + ! Calculate bond force + call this%get_bond_force() + + ! Advance velocity only based on new force + do n=1,this%np_ + ! Advance with Verlet scheme + if (this%p(n)%id.le.-1) cycle + ! stress=this%cfg%get_velocity(pos=this%p(n)%pos,i0=this%p(n)%ind(1),j0=this%p(n)%ind(2),k0=this%p(n)%ind(3),U=stress_x,V=stress_y,W=stress_z) + ! this%p(n)%Afluid=stress/this%rho + this%p(n)%Afluid=0.0_WP + this%p(n)%vel=this%p(n)%vel+0.5_WP*dt*(this%gravity+this%p(n)%Abond+this%p(n)%Afluid) + end do + + ! Recompute volume fraction + ! call this%update_VF() + + ! Log/screen output + logging: block + use, intrinsic :: iso_fortran_env, only: output_unit + use param, only: verbose + use messager, only: log + use string, only: str_long + character(len=str_long) :: message + if (this%cfg%amRoot) then + write(message,'("Particle solver [",a,"] on partitioned grid [",a,"]: ",i0," particles were advanced")') trim(this%name),trim(this%cfg%name),this%np + if (verbose.gt.1) write(output_unit,'(a)') trim(message) + if (verbose.gt.0) call log(message) + end if + end block logging + + end subroutine advance + + subroutine stretch(this,dt)!,stress_x,stress_y,stress_z) + use mpi_f08, only : MPI_SUM,MPI_INTEGER,MPI_IN_PLACE + use mathtools, only: Pi + implicit none + class(lss), intent(inout) :: this + real(WP), intent(inout) :: dt !< Timestep size over which to advance + real(WP) :: mu + integer :: n,ierr + !======================================================================================== + ! X-Axis Stretch: + ! Zero out number of particles removed + this%np_out=0 + do n=1,this%np_ + ! Stretch the beam along the x axis with a uniform strain-rate of 0.001 + if (this%p(n)%id.gt.-2) this%p(n)%pos(1)=this%p(n)%pos(1)*1.001_WP + end do + + ! Communicate particles + call this%sync() + + ! Calculate bond force + call this%get_bond_force() + + mu=this%elastic_modulus/(2.0_WP+2.0_WP*this%poisson_ratio) + + do n=1,this%np_ + if (this%p(n)%id.gt.-2) this%p(n)%gd(1)=0.001_WP/this%p(n)%dil + end do + + !======================================================================================== + ! Y-Axis Stretch: + ! Zero out number of particles removed + this%np_out=0 + do n=1,this%np_ + ! Stretch the beam along the x axis with a uniform strain-rate of 0.001 + if (this%p(n)%id.gt.-2) this%p(n)%pos(1)=this%p(n)%pos(1)/1.001_WP + if (this%p(n)%id.gt.-2) this%p(n)%pos(2)=this%p(n)%pos(2)*1.001_WP + end do + + ! Communicate particles + call this%sync() + + ! Calculate bond force + call this%get_bond_force() + + mu=this%elastic_modulus/(2.0_WP+2.0_WP*this%poisson_ratio) + + do n=1,this%np_ + if (this%p(n)%id.gt.-2) this%p(n)%gd(2)=0.001_WP/this%p(n)%dil + end do + + !======================================================================================== + ! Z-Axis Stretch: + ! Zero out number of particles removed + this%np_out=0 + do n=1,this%np_ + ! Stretch the beam along the x axis with a uniform strain-rate of 0.001 + if (this%p(n)%id.gt.-2) this%p(n)%pos(2)=this%p(n)%pos(2)/1.001_WP + if (this%p(n)%id.gt.-2) this%p(n)%pos(3)=this%p(n)%pos(3)*1.001_WP + end do + + ! Communicate particles + call this%sync() + + ! Calculate bond force + call this%get_bond_force() + + mu=this%elastic_modulus/(2.0_WP+2.0_WP*this%poisson_ratio) + + do n=1,this%np_ + this%p(n)%gd(3)=0.001_WP/this%p(n)%dil + end do + + ! Put the particle back where it was + do n=1,this%np_ + if (this%p(n)%id.gt.-2) this%p(n)%pos(3)=this%p(n)%pos(3)/1.001_WP + end do + + !====================================================================================== + + ! Now stretch particle for the first time step + + do n=1,this%np_ + ! Stretch the beam along the x axis with a uniform strain-rate of 0.001 + if (this%p(n)%id.gt.-2) this%p(n)%pos(1)=this%p(n)%pos(1)*1.001_WP + end do + + ! Communicate particles + call this%sync() + + ! Calculate bond force + call this%get_bond_force() + + + + + end subroutine stretch + + subroutine get_correction_coeffs(this,dt)!,stress_x,stress_y,stress_z) + use mpi_f08, only : MPI_SUM,MPI_INTEGER,MPI_IN_PLACE + use mathtools, only: Pi + implicit none + class(lss), intent(inout) :: this + real(WP), intent(inout) :: dt !< Timestep size over which to advance + real(WP) :: mu + integer :: n,ierr + ! Zero out number of particles removed + this%np_out=0 + do n=1,this%np_ + ! Stretch the beam along the x axis with a uniform strain-rate of 0.001 + if (this%p(n)%id.gt.-2) this%p(n)%pos(1)=this%p(n)%pos(1) + this%p(n)%pos(1)*0.001_WP + ! Relocalize + this%p(n)%ind=this%cfg%get_ijk_global(this%p(n)%pos,this%p(n)%ind) + ! Correct the position to take into account periodicity + if (this%cfg%xper) this%p(n)%pos(1)=this%cfg%x(this%cfg%imin)+modulo(this%p(n)%pos(1)-this%cfg%x(this%cfg%imin),this%cfg%xL) + if (this%cfg%yper) this%p(n)%pos(2)=this%cfg%y(this%cfg%jmin)+modulo(this%p(n)%pos(2)-this%cfg%y(this%cfg%jmin),this%cfg%yL) + if (this%cfg%zper) this%p(n)%pos(3)=this%cfg%z(this%cfg%kmin)+modulo(this%p(n)%pos(3)-this%cfg%z(this%cfg%kmin),this%cfg%zL) + ! Handle particles that have left the domain + if (this%p(n)%pos(1).lt.this%cfg%x(this%cfg%imin).or.this%p(n)%pos(1).gt.this%cfg%x(this%cfg%imax+1)) this%p(n)%flag=1 + if (this%p(n)%pos(2).lt.this%cfg%y(this%cfg%jmin).or.this%p(n)%pos(2).gt.this%cfg%y(this%cfg%jmax+1)) this%p(n)%flag=1 + if (this%p(n)%pos(3).lt.this%cfg%z(this%cfg%kmin).or.this%p(n)%pos(3).gt.this%cfg%z(this%cfg%kmax+1)) this%p(n)%flag=1 + ! Relocalize the particle + this%p(n)%ind=this%cfg%get_ijk_global(this%p(n)%pos,this%p(n)%ind) + ! Count number of particles removed + end do + + ! Communicate particles + call this%sync() + + ! Sum up particles removed + call MPI_ALLREDUCE(this%np_out,n,1,MPI_INTEGER,MPI_SUM,this%cfg%comm,ierr); this%np_out=n + + ! Calculate bond force + call this%get_bond_force() + + mu=this%elastic_modulus/(2.0_WP+2.0_WP*this%poisson_ratio) + + do n=1,this%np_ + this%p(n)%gd=0.001_WP/this%p(n)%dil + this%p(n)%Gb=0.5_WP*mu*(0.001_WP*0.001_WP)/this%p(n)%ste + end do + + ! Log/screen output + logging: block + use, intrinsic :: iso_fortran_env, only: output_unit + use param, only: verbose + use messager, only: log + use string, only: str_long + character(len=str_long) :: message + if (this%cfg%amRoot) then + write(message,'("Particle solver [",a,"] on partitioned grid [",a,"]: ",i0," particles were advanced")') trim(this%name),trim(this%cfg%name),this%np + if (verbose.gt.1) write(output_unit,'(a)') trim(message) + if (verbose.gt.0) call log(message) + end if + end block logging + + end subroutine get_correction_coeffs + + + !> Update particle volume fraction using our current particles + subroutine update_VF(this) + implicit none + class(lss), intent(inout) :: this + integer :: i + ! Reset volume fraction and momentum + this%VF=0.0_WP; this%VFU=0.0_WP; this%VFV=0.0_WP; this%VFW=0.0_WP + ! Transfer particle volume + do i=1,this%np_ + ! Skip inactive particle + if (this%p(i)%flag.eq.1) cycle + ! Transfer volume to mesh + call this%extrapolate(Ap=this%p(i)%vol,xp=this%p(i)%pos(1),yp=this%p(i)%pos(2),zp=this%p(i)%pos(3),ip=this%p(i)%ind(1),jp=this%p(i)%ind(2),kp=this%p(i)%ind(3),A=this%VF,dir='SC') + call this%extrapolate(Ap=this%p(i)%vol*this%p(i)%vel(1),xp=this%p(i)%pos(1),yp=this%p(i)%pos(2),zp=this%p(i)%pos(3),ip=this%p(i)%ind(1),jp=this%p(i)%ind(2),kp=this%p(i)%ind(3),A=this%VFU,dir='U') + call this%extrapolate(Ap=this%p(i)%vol*this%p(i)%vel(2),xp=this%p(i)%pos(1),yp=this%p(i)%pos(2),zp=this%p(i)%pos(3),ip=this%p(i)%ind(1),jp=this%p(i)%ind(2),kp=this%p(i)%ind(3),A=this%VFV,dir='V') + call this%extrapolate(Ap=this%p(i)%vol*this%p(i)%vel(3),xp=this%p(i)%pos(1),yp=this%p(i)%pos(2),zp=this%p(i)%pos(3),ip=this%p(i)%ind(1),jp=this%p(i)%ind(2),kp=this%p(i)%ind(3),A=this%VFW,dir='W') + end do + ! Sum at boundaries + call this%cfg%syncsum(this%VF) + call this%cfg%syncsum(this%VFU) + call this%cfg%syncsum(this%VFV) + call this%cfg%syncsum(this%VFW) + ! Clip + where (this%VF.gt.1.0_WP) this%VF=1.0_WP + where (this%VF.lt.0.0_WP) this%VF=0.0_WP + end subroutine update_VF + + + !> Compute regularized delta function + subroutine get_delta(this,delta,ic,jc,kc,xp,yp,zp,dir) + implicit none + class(lss), intent(inout) :: this + real(WP), intent(out) :: delta !< Return delta function + integer, intent(in) :: ic,jc,kc !< Cell index + real(WP), intent(in) :: xp,yp,zp !< Position of marker + character(len=*) :: dir + real(WP) :: deltax,deltay,deltaz,r + + ! Compute in X + if (trim(adjustl(dir)).eq.'U') then + r=(xp-this%cfg%x(ic))*this%cfg%dxmi(ic) + deltax=roma_kernel(r)*this%cfg%dxmi(ic) + else + r=(xp-this%cfg%xm(ic))*this%cfg%dxi(ic) + deltax=roma_kernel(r)*this%cfg%dxi(ic) + end if + + ! Compute in Y + if (trim(adjustl(dir)).eq.'V') then + r=(yp-this%cfg%y(jc))*this%cfg%dymi(jc) + deltay=roma_kernel(r)*this%cfg%dymi(jc) + else + r=(yp-this%cfg%ym(jc))*this%cfg%dyi(jc) + deltay=roma_kernel(r)*this%cfg%dyi(jc) + end if + + ! Compute in Z + if (trim(adjustl(dir)).eq.'W') then + r=(zp-this%cfg%z(kc))*this%cfg%dzmi(kc) + deltaz=roma_kernel(r)*this%cfg%dzmi(kc) + else + r=(zp-this%cfg%zm(kc))*this%cfg%dzi(kc) + deltaz=roma_kernel(r)*this%cfg%dzi(kc) + end if + !else + + ! Put it all together + delta=deltax*deltay*deltaz + + contains + ! Mollification kernel + ! Roma A, Peskin C and Berger M 1999 J. Comput. Phys. 153 509–534 + function roma_kernel(r) result(phi) + implicit none + real(WP), intent(in) :: r + real(WP) :: phi + if (abs(r).le.0.5_WP) then + phi=1.0_WP/3.0_WP*(1.0_WP+sqrt(-3.0_WP*r**2+1.0_WP)) + else if (abs(r).gt.0.5_WP .and. abs(r).le.1.5_WP) then + phi=1.0_WP/6.0_WP*(5.0_WP-3.0_WP*abs(r)-sqrt(-3.0_WP*(1.0_WP-abs(r))**2+1.0_WP)) + else + phi=0.0_WP + end if + end function roma_kernel + + end subroutine get_delta + + + !> Interpolation routine + function interpolate(this,A,xp,yp,zp,ip,jp,kp,dir) result(Ap) + implicit none + class(lss), intent(inout) :: this + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(in) :: A !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + real(WP), intent(in) :: xp,yp,zp + integer, intent(in) :: ip,jp,kp + character(len=*) :: dir + real(WP) :: Ap + integer :: di,dj,dk + integer :: i1,i2,j1,j2,k1,k2 + real(WP), dimension(-2:+2,-2:+2,-2:+2) :: delta + ! Get the interpolation points + i1=ip-2; i2=ip+2 + j1=jp-2; j2=jp+2 + k1=kp-2; k2=kp+2 + ! Loop over neighboring cells and compute regularized delta function + do dk=-2,+2 + do dj=-2,+2 + do di=-2,+2 + call this%get_delta(delta=delta(di,dj,dk),ic=ip+di,jc=jp+dj,kc=kp+dk,xp=xp,yp=yp,zp=zp,dir=trim(dir)) + end do + end do + end do + ! Perform the actual interpolation on Ap + Ap = sum(delta*A(i1:i2,j1:j2,k1:k2))*this%cfg%vol(ip,jp,kp) + end function interpolate + + + !> Extrapolation routine + subroutine extrapolate(this,Ap,xp,yp,zp,ip,jp,kp,A,dir) + use messager, only: die + implicit none + class(lss), intent(inout) :: this + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:) :: A !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + real(WP), intent(in) :: xp,yp,zp + integer, intent(in) :: ip,jp,kp + real(WP), intent(in) :: Ap + character(len=*) :: dir + real(WP), dimension(-2:+2,-2:+2,-2:+2) :: delta + integer :: di,dj,dk + ! If particle has left processor domain or reached last ghost cell, kill job + if ( ip.lt.this%cfg%imin_-1.or.ip.gt.this%cfg%imax_+1.or.& + & jp.lt.this%cfg%jmin_-1.or.jp.gt.this%cfg%jmax_+1.or.& + & kp.lt.this%cfg%kmin_-1.or.kp.gt.this%cfg%kmax_+1) then + write(*,*) ip,jp,kp,xp,yp,zp + call die('[df extrapolate] Particle has left the domain') + end if + ! Loop over neighboring cells and compute regularized delta function + do dk=-2,+2 + do dj=-2,+2 + do di=-2,+2 + call this%get_delta(delta=delta(di,dj,dk),ic=ip+di,jc=jp+dj,kc=kp+dk,xp=xp,yp=yp,zp=zp,dir=trim(dir)) + end do + end do + end do + ! Perform the actual extrapolation on A + A(ip-2:ip+2,jp-2:jp+2,kp-2:kp+2)=A(ip-2:ip+2,jp-2:jp+2,kp-2:kp+2)+delta*Ap + end subroutine extrapolate + + + !> Calculate the CFL + subroutine get_cfl(this,dt,cfl) + use mpi_f08, only: MPI_ALLREDUCE,MPI_MAX + use parallel, only: MPI_REAL_WP + implicit none + class(lss), intent(inout) :: this + real(WP), intent(in) :: dt + real(WP), intent(out) :: cfl + integer :: i,ierr + real(WP) :: my_CFLp_x,my_CFLp_y,my_CFLp_z,kk,mu,a + + ! Set the CFLs to zero + my_CFLp_x=0.0_WP; my_CFLp_y=0.0_WP; my_CFLp_z=0.0_WP + do i=1,this%np_ + my_CFLp_x=max(my_CFLp_x,abs(this%p(i)%vel(1))*this%cfg%dxi(this%p(i)%ind(1))) + my_CFLp_y=max(my_CFLp_y,abs(this%p(i)%vel(2))*this%cfg%dyi(this%p(i)%ind(2))) + my_CFLp_z=max(my_CFLp_z,abs(this%p(i)%vel(3))*this%cfg%dzi(this%p(i)%ind(3))) + end do + my_CFLp_x=my_CFLp_x*dt; my_CFLp_y=my_CFLp_y*dt; my_CFLp_z=my_CFLp_z*dt + + ! Get the parallel max + call MPI_ALLREDUCE(my_CFLp_x,this%CFLp_x,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + call MPI_ALLREDUCE(my_CFLp_y,this%CFLp_y,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + call MPI_ALLREDUCE(my_CFLp_z,this%CFLp_z,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + + ! CFL based on elastic wave speed in material + kk=this%elastic_modulus/(3.0_WP-6.0_WP*this%poisson_ratio) + mu=this%elastic_modulus/(2.0_WP+2.0_WP*this%poisson_ratio) + a=sqrt((kk+4.0_WP*mu/3.0_WP)/this%rho) + this%CFLp_a=dt*a*3/this%delta + + ! Return the maximum CFL + cfl=max(this%CFLp_x,this%CFLp_y,this%CFLp_z,this%CFLp_a) + + end subroutine get_cfl + + + !> Extract various monitoring data from particle field + subroutine get_max(this) + use mpi_f08, only: MPI_ALLREDUCE,MPI_MAX,MPI_MIN,MPI_SUM + use parallel, only: MPI_REAL_WP + implicit none + class(lss), intent(inout) :: this + real(WP) :: buf,safe_np + real(WP), dimension(3) :: buf3D + integer :: i,j,k,ierr + + ! Create safe np + safe_np=real(max(this%np,1),WP) + + ! Velocity min/max/mean + this%Umin=huge(1.0_WP); this%Umax=-huge(1.0_WP); this%Umean=0.0_WP + this%Vmin=huge(1.0_WP); this%Vmax=-huge(1.0_WP); this%Vmean=0.0_WP + this%Wmin=huge(1.0_WP); this%Wmax=-huge(1.0_WP); this%Wmean=0.0_WP + this%ibmForce=0.0_WP + do i=1,this%np_ + this%Umin=min(this%Umin,this%p(i)%vel(1)); this%Umax=max(this%Umax,this%p(i)%vel(1)); this%Umean=this%Umean+this%p(i)%vel(1) + this%Vmin=min(this%Vmin,this%p(i)%vel(2)); this%Vmax=max(this%Vmax,this%p(i)%vel(2)); this%Vmean=this%Vmean+this%p(i)%vel(2) + this%Wmin=min(this%Wmin,this%p(i)%vel(3)); this%Wmax=max(this%Wmax,this%p(i)%vel(3)); this%Wmean=this%Wmean+this%p(i)%vel(3) + this%ibmForce=this%ibmForce+this%p(i)%Afluid*this%p(i)%vol*this%rho + end do + call MPI_ALLREDUCE(this%Umin ,buf,1,MPI_REAL_WP,MPI_MIN,this%cfg%comm,ierr); this%Umin =buf + call MPI_ALLREDUCE(this%Umax ,buf,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr); this%Umax =buf + call MPI_ALLREDUCE(this%Umean,buf,1,MPI_REAL_WP,MPI_SUM,this%cfg%comm,ierr); this%Umean=buf/safe_np + call MPI_ALLREDUCE(this%Vmin ,buf,1,MPI_REAL_WP,MPI_MIN,this%cfg%comm,ierr); this%Vmin =buf + call MPI_ALLREDUCE(this%Vmax ,buf,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr); this%Vmax =buf + call MPI_ALLREDUCE(this%Vmean,buf,1,MPI_REAL_WP,MPI_SUM,this%cfg%comm,ierr); this%Vmean=buf/safe_np + call MPI_ALLREDUCE(this%Wmin ,buf,1,MPI_REAL_WP,MPI_MIN,this%cfg%comm,ierr); this%Wmin =buf + call MPI_ALLREDUCE(this%Wmax ,buf,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr); this%Wmax =buf + call MPI_ALLREDUCE(this%Wmean,buf,1,MPI_REAL_WP,MPI_SUM,this%cfg%comm,ierr); this%Wmean=buf/safe_np + call MPI_ALLREDUCE(this%ibmForce,buf3D,3,MPI_REAL_WP,MPI_SUM,this%cfg%comm,ierr); this%ibmForce=buf3D + + ! Get max volume fraction + this%VFmax =-huge(1.0_WP) + do k=this%cfg%kmin_,this%cfg%kmax_ + do j=this%cfg%jmin_,this%cfg%jmax_ + do i=this%cfg%imin_,this%cfg%imax_ + this%VFmax=max(this%VFmax,this%VF(i,j,k)) + end do + end do + end do + call MPI_ALLREDUCE(this%VFmax,buf,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr); this%VFmax=buf + + end subroutine get_max + + + !> Update particle mesh using our current particles + subroutine update_partmesh(this,pmesh) + use partmesh_class, only: partmesh + implicit none + class(lss), intent(inout) :: this + class(partmesh), intent(inout) :: pmesh + integer :: i + ! Reset particle mesh storage + call pmesh%reset() + ! Nothing else to do if no particle is present + if (this%np_.eq.0) return + ! Copy particle info + call pmesh%set_size(this%np_) + do i=1,this%np_ + pmesh%pos(:,i)=this%p(i)%pos + end do + end subroutine update_partmesh + + + !> Creation of the MPI datatype for particle + subroutine prepare_mpi_part() + use mpi_f08 + use messager, only: die + implicit none + integer(MPI_ADDRESS_KIND), dimension(part_nblock) :: disp + integer(MPI_ADDRESS_KIND) :: lb,extent + type(MPI_Datatype) :: MPI_PART_TMP + integer :: i,mysize,ierr + ! Prepare the displacement array + disp(1)=0 + do i=2,part_nblock + call MPI_Type_size(part_tblock(i-1),mysize,ierr) + disp(i)=disp(i-1)+int(mysize,MPI_ADDRESS_KIND)*int(part_lblock(i-1),MPI_ADDRESS_KIND) + end do + ! Create and commit the new type + call MPI_Type_create_struct(part_nblock,part_lblock,disp,part_tblock,MPI_PART_TMP,ierr) + call MPI_Type_get_extent(MPI_PART_TMP,lb,extent,ierr) + call MPI_Type_create_resized(MPI_PART_TMP,lb,extent,MPI_PART,ierr) + call MPI_Type_commit(MPI_PART,ierr) + ! If a problem was encountered, say it + if (ierr.ne.0) call die('[lss prepare_mpi_part] MPI Particle type creation failed') + ! Get the size of this type + call MPI_type_size(MPI_PART,MPI_PART_SIZE,ierr) + end subroutine prepare_mpi_part + + + !> Share particles across processor boundaries + subroutine share(this,nover) + use mpi_f08 + use messager, only: warn,die + implicit none + class(lss), intent(inout) :: this + integer, optional :: nover + type(part), dimension(:), allocatable :: tosend + type(part), dimension(:), allocatable :: torecv + integer :: no,nsend,nrecv + type(MPI_Status) :: status + integer :: icnt,isrc,idst,ierr + integer :: i,n + + ! Check overlap size + if (present(nover)) then + no=nover + if (no.gt.this%cfg%no) then + call warn('[lss share] Specified overlap is larger than that of cfg - reducing no') + no=this%cfg%no + else if (no.le.0) then + call die('[lss share] Specified overlap cannot be less or equal to zero') + end if + else + no=1 + end if + + ! Clean up ghost array + call this%resize_ghost(n=0); this%ng_=0 + + ! Share ghost particles in -x (no ghosts are sent here) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(1).lt.this%cfg%imin_+no) nsend=nsend+1 + end do + allocate(tosend(nsend)) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(1).lt.this%cfg%imin_+no) then + nsend=nsend+1 + tosend(nsend)=this%p(n) + if (this%cfg%xper.and.tosend(nsend)%ind(1).lt.this%cfg%imin+no) then + tosend(nsend)%pos(1)=tosend(nsend)%pos(1)+this%cfg%xL + tosend(nsend)%ind(1)=tosend(nsend)%ind(1)+this%cfg%nx + end if + end if + end do + nrecv=0 + call MPI_CART_SHIFT(this%cfg%comm,0,-1,isrc,idst,ierr) + call MPI_SENDRECV(nsend,1,MPI_INTEGER,idst,0,nrecv,1,MPI_INTEGER,isrc,0,this%cfg%comm,status,ierr) + allocate(torecv(nrecv)) + call MPI_SENDRECV(tosend,nsend,MPI_PART,idst,0,torecv,nrecv,MPI_PART,isrc,0,this%cfg%comm,status,ierr) + call this%resize_ghost(this%ng_+nrecv) + this%g(this%ng_+1:this%ng_+nrecv)=torecv + this%ng_=this%ng_+nrecv + if (allocated(tosend)) deallocate(tosend) + if (allocated(torecv)) deallocate(torecv) + + ! Share ghost particles in +x (no ghosts are sent here) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(1).gt.this%cfg%imax_-no) nsend=nsend+1 + end do + allocate(tosend(nsend)) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(1).gt.this%cfg%imax_-no) then + nsend=nsend+1 + tosend(nsend)=this%p(n) + if (this%cfg%xper.and.tosend(nsend)%ind(1).gt.this%cfg%imax-no) then + tosend(nsend)%pos(1)=tosend(nsend)%pos(1)-this%cfg%xL + tosend(nsend)%ind(1)=tosend(nsend)%ind(1)-this%cfg%nx + end if + end if + end do + nrecv=0 + call MPI_CART_SHIFT(this%cfg%comm,0,+1,isrc,idst,ierr) + call MPI_SENDRECV(nsend,1,MPI_INTEGER,idst,0,nrecv,1,MPI_INTEGER,isrc,0,this%cfg%comm,status,ierr) + allocate(torecv(nrecv)) + call MPI_SENDRECV(tosend,nsend,MPI_PART,idst,0,torecv,nrecv,MPI_PART,isrc,0,this%cfg%comm,status,ierr) + call this%resize_ghost(this%ng_+nrecv) + this%g(this%ng_+1:this%ng_+nrecv)=torecv + this%ng_=this%ng_+nrecv + if (allocated(tosend)) deallocate(tosend) + if (allocated(torecv)) deallocate(torecv) + + ! Share ghost particles in -y (ghosts need to be sent now) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(2).lt.this%cfg%jmin_+no) nsend=nsend+1 + end do + do n=1,this%ng_ + if (this%g(n)%ind(2).lt.this%cfg%jmin_+no) nsend=nsend+1 + end do + allocate(tosend(nsend)) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(2).lt.this%cfg%jmin_+no) then + nsend=nsend+1 + tosend(nsend)=this%p(n) + if (this%cfg%yper.and.tosend(nsend)%ind(2).lt.this%cfg%jmin+no) then + tosend(nsend)%pos(2)=tosend(nsend)%pos(2)+this%cfg%yL + tosend(nsend)%ind(2)=tosend(nsend)%ind(2)+this%cfg%ny + end if + end if + end do + do n=1,this%ng_ + if (this%g(n)%ind(2).lt.this%cfg%jmin_+no) then + nsend=nsend+1 + tosend(nsend)=this%g(n) + if (this%cfg%yper.and.tosend(nsend)%ind(2).lt.this%cfg%jmin+no) then + tosend(nsend)%pos(2)=tosend(nsend)%pos(2)+this%cfg%yL + tosend(nsend)%ind(2)=tosend(nsend)%ind(2)+this%cfg%ny + end if + end if + end do + nrecv=0 + call MPI_CART_SHIFT(this%cfg%comm,1,-1,isrc,idst,ierr) + call MPI_SENDRECV(nsend,1,MPI_INTEGER,idst,0,nrecv,1,MPI_INTEGER,isrc,0,this%cfg%comm,status,ierr) + allocate(torecv(nrecv)) + call MPI_SENDRECV(tosend,nsend,MPI_PART,idst,0,torecv,nrecv,MPI_PART,isrc,0,this%cfg%comm,status,ierr) + call this%resize_ghost(this%ng_+nrecv) + this%g(this%ng_+1:this%ng_+nrecv)=torecv + this%ng_=this%ng_+nrecv + if (allocated(tosend)) deallocate(tosend) + if (allocated(torecv)) deallocate(torecv) + + ! Share ghost particles in +y (ghosts need to be sent now - but not newly received ghosts!) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(2).gt.this%cfg%jmax_-no) nsend=nsend+1 + end do + do n=1,this%ng_-nrecv + if (this%g(n)%ind(2).gt.this%cfg%jmax_-no) nsend=nsend+1 + end do + allocate(tosend(nsend)) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(2).gt.this%cfg%jmax_-no) then + nsend=nsend+1 + tosend(nsend)=this%p(n) + if (this%cfg%yper.and.tosend(nsend)%ind(2).gt.this%cfg%jmax-no) then + tosend(nsend)%pos(2)=tosend(nsend)%pos(2)-this%cfg%yL + tosend(nsend)%ind(2)=tosend(nsend)%ind(2)-this%cfg%ny + end if + end if + end do + do n=1,this%ng_-nrecv + if (this%g(n)%ind(2).gt.this%cfg%jmax_-no) then + nsend=nsend+1 + tosend(nsend)=this%g(n) + if (this%cfg%yper.and.tosend(nsend)%ind(2).gt.this%cfg%jmax-no) then + tosend(nsend)%pos(2)=tosend(nsend)%pos(2)-this%cfg%yL + tosend(nsend)%ind(2)=tosend(nsend)%ind(2)-this%cfg%ny + end if + end if + end do + nrecv=0 + call MPI_CART_SHIFT(this%cfg%comm,1,+1,isrc,idst,ierr) + call MPI_SENDRECV(nsend,1,MPI_INTEGER,idst,0,nrecv,1,MPI_INTEGER,isrc,0,this%cfg%comm,status,ierr) + allocate(torecv(nrecv)) + call MPI_SENDRECV(tosend,nsend,MPI_PART,idst,0,torecv,nrecv,MPI_PART,isrc,0,this%cfg%comm,status,ierr) + call this%resize_ghost(this%ng_+nrecv) + this%g(this%ng_+1:this%ng_+nrecv)=torecv + this%ng_=this%ng_+nrecv + if (allocated(tosend)) deallocate(tosend) + if (allocated(torecv)) deallocate(torecv) + + ! Share ghost particles in -z (ghosts need to be sent now) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(3).lt.this%cfg%kmin_+no) nsend=nsend+1 + end do + do n=1,this%ng_ + if (this%g(n)%ind(3).lt.this%cfg%kmin_+no) nsend=nsend+1 + end do + allocate(tosend(nsend)) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(3).lt.this%cfg%kmin_+no) then + nsend=nsend+1 + tosend(nsend)=this%p(n) + if (this%cfg%zper.and.tosend(nsend)%ind(3).lt.this%cfg%kmin+no) then + tosend(nsend)%pos(3)=tosend(nsend)%pos(3)+this%cfg%zL + tosend(nsend)%ind(3)=tosend(nsend)%ind(3)+this%cfg%nz + end if + end if + end do + do n=1,this%ng_ + if (this%g(n)%ind(3).lt.this%cfg%kmin_+no) then + nsend=nsend+1 + tosend(nsend)=this%g(n) + if (this%cfg%zper.and.tosend(nsend)%ind(3).lt.this%cfg%kmin+no) then + tosend(nsend)%pos(3)=tosend(nsend)%pos(3)+this%cfg%zL + tosend(nsend)%ind(3)=tosend(nsend)%ind(3)+this%cfg%nz + end if + end if + end do + nrecv=0 + call MPI_CART_SHIFT(this%cfg%comm,2,-1,isrc,idst,ierr) + call MPI_SENDRECV(nsend,1,MPI_INTEGER,idst,0,nrecv,1,MPI_INTEGER,isrc,0,this%cfg%comm,status,ierr) + allocate(torecv(nrecv)) + call MPI_SENDRECV(tosend,nsend,MPI_PART,idst,0,torecv,nrecv,MPI_PART,isrc,0,this%cfg%comm,status,ierr) + call this%resize_ghost(this%ng_+nrecv) + this%g(this%ng_+1:this%ng_+nrecv)=torecv + this%ng_=this%ng_+nrecv + if (allocated(tosend)) deallocate(tosend) + if (allocated(torecv)) deallocate(torecv) + + ! Share ghost particles in +z (ghosts need to be sent now - but not newly received ghosts!) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(3).gt.this%cfg%kmax_-no) nsend=nsend+1 + end do + do n=1,this%ng_-nrecv + if (this%g(n)%ind(3).gt.this%cfg%kmax_-no) nsend=nsend+1 + end do + allocate(tosend(nsend)) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(3).gt.this%cfg%kmax_-no) then + nsend=nsend+1 + tosend(nsend)=this%p(n) + if (this%cfg%zper.and.tosend(nsend)%ind(3).gt.this%cfg%kmax-no) then + tosend(nsend)%pos(3)=tosend(nsend)%pos(3)-this%cfg%zL + tosend(nsend)%ind(3)=tosend(nsend)%ind(3)-this%cfg%nz + end if + end if + end do + do n=1,this%ng_-nrecv + if (this%g(n)%ind(3).gt.this%cfg%kmax_-no) then + nsend=nsend+1 + tosend(nsend)=this%g(n) + if (this%cfg%zper.and.tosend(nsend)%ind(3).gt.this%cfg%kmax-no) then + tosend(nsend)%pos(3)=tosend(nsend)%pos(3)-this%cfg%zL + tosend(nsend)%ind(3)=tosend(nsend)%ind(3)-this%cfg%nz + end if + end if + end do + nrecv=0 + call MPI_CART_SHIFT(this%cfg%comm,2,+1,isrc,idst,ierr) + call MPI_SENDRECV(nsend,1,MPI_INTEGER,idst,0,nrecv,1,MPI_INTEGER,isrc,0,this%cfg%comm,status,ierr) + allocate(torecv(nrecv)) + call MPI_SENDRECV(tosend,nsend,MPI_PART,idst,0,torecv,nrecv,MPI_PART,isrc,0,this%cfg%comm,status,ierr) + call this%resize_ghost(this%ng_+nrecv) + this%g(this%ng_+1:this%ng_+nrecv)=torecv + this%ng_=this%ng_+nrecv + if (allocated(tosend)) deallocate(tosend) + if (allocated(torecv)) deallocate(torecv) + + end subroutine share + + + !> Synchronize particle arrays across processors + subroutine sync(this) + use mpi_f08 + implicit none + class(lss), intent(inout) :: this + integer, dimension(0:this%cfg%nproc-1) :: nsend_proc,nrecv_proc + integer, dimension(0:this%cfg%nproc-1) :: nsend_disp,nrecv_disp + integer :: n,prank,ierr + type(part), dimension(:), allocatable :: buf_send + ! Recycle first to minimize communication load + call this%recycle() + ! Prepare information about what to send + nsend_proc=0 + do n=1,this%np_ + prank=this%cfg%get_rank(this%p(n)%ind) + nsend_proc(prank)=nsend_proc(prank)+1 + end do + nsend_proc(this%cfg%rank)=0 + ! Inform processors of what they will receive + call MPI_ALLtoALL(nsend_proc,1,MPI_INTEGER,nrecv_proc,1,MPI_INTEGER,this%cfg%comm,ierr) + ! Prepare displacements for all-to-all + nsend_disp(0)=0 + nrecv_disp(0)=this%np_ !< Directly add particles at the end of main array + do n=1,this%cfg%nproc-1 + nsend_disp(n)=nsend_disp(n-1)+nsend_proc(n-1) + nrecv_disp(n)=nrecv_disp(n-1)+nrecv_proc(n-1) + end do + ! Allocate buffer to send particles + allocate(buf_send(sum(nsend_proc))) + ! Pack the particles in the send buffer + nsend_proc=0 + do n=1,this%np_ + ! Get the rank + prank=this%cfg%get_rank(this%p(n)%ind) + ! Skip particles still inside + if (prank.eq.this%cfg%rank) cycle + ! Pack up for sending + nsend_proc(prank)=nsend_proc(prank)+1 + buf_send(nsend_disp(prank)+nsend_proc(prank))=this%p(n) + ! Flag particle for removal + this%p(n)%flag=1 + end do + ! Allocate buffer for receiving particles + call this%resize(this%np_+sum(nrecv_proc)) + ! Perform communication + call MPI_ALLtoALLv(buf_send,nsend_proc,nsend_disp,MPI_PART,this%p,nrecv_proc,nrecv_disp,MPI_PART,this%cfg%comm,ierr) + ! Deallocate buffer + deallocate(buf_send) + ! Recycle to remove duplicate particles + call this%recycle() + end subroutine sync + + + !> Adaptation of particle array size + subroutine resize(this,n) + implicit none + class(lss), intent(inout) :: this + integer, intent(in) :: n + type(part), dimension(:), allocatable :: tmp + integer :: size_now,size_new + ! Resize particle array to size n + if (.not.allocated(this%p)) then + ! Allocate directly to size n + allocate(this%p(n)) + this%p(1:n)%flag=1 + else + ! Update from a non-zero size to another non-zero size + size_now=size(this%p,dim=1) + if (n.gt.size_now) then + size_new=max(n,int(real(size_now,WP)*coeff_up)) + allocate(tmp(size_new)) + tmp(1:size_now)=this%p + tmp(size_now+1:)%flag=1 + call move_alloc(tmp,this%p) + else if (n.lt.int(real(size_now,WP)*coeff_dn)) then + allocate(tmp(n)) + tmp(1:n)=this%p(1:n) + call move_alloc(tmp,this%p) + end if + end if + end subroutine resize + + + !> Adaptation of ghost array size + subroutine resize_ghost(this,n) + implicit none + class(lss), intent(inout) :: this + integer, intent(in) :: n + type(part), dimension(:), allocatable :: tmp + integer :: size_now,size_new + ! Resize ghost array to size n + if (.not.allocated(this%g)) then + ! Allocate directly to size n + allocate(this%g(n)) + this%g(1:n)%flag=1 + else + ! Update from a non-zero size to another non-zero size + size_now=size(this%g,dim=1) + if (n.gt.size_now) then + size_new=max(n,int(real(size_now,WP)*coeff_up)) + allocate(tmp(size_new)) + tmp(1:size_now)=this%g + tmp(size_now+1:)%flag=1 + call move_alloc(tmp,this%g) + else if (n.lt.int(real(size_now,WP)*coeff_dn)) then + allocate(tmp(n)) + tmp(1:n)=this%g(1:n) + call move_alloc(tmp,this%g) + end if + end if + end subroutine resize_ghost + + + !> Clean-up of particle array by removing flag=1 particles + subroutine recycle(this) + implicit none + class(lss), intent(inout) :: this + integer :: new_size,i,ierr + ! Compact all active particles at the beginning of the array + new_size=0 + if (allocated(this%p)) then + do i=1,size(this%p,dim=1) + if (this%p(i)%flag.ne.1) then + new_size=new_size+1 + if (i.ne.new_size) then + this%p(new_size)=this%p(i) + this%p(i)%flag=1 + end if + end if + end do + end if + ! Resize to new size + call this%resize(new_size) + ! Update number of particles + this%np_=new_size + call MPI_ALLGATHER(this%np_,1,MPI_INTEGER,this%np_proc,1,MPI_INTEGER,this%cfg%comm,ierr) + this%np=sum(this%np_proc) + end subroutine recycle + + + !> Parallel write particles to file + subroutine write(this,filename) + use mpi_f08 + use messager, only: die + use parallel, only: info_mpiio + implicit none + class(lss), intent(inout) :: this + character(len=*), intent(in) :: filename + type(MPI_File) :: ifile + type(MPI_Status):: status + integer(kind=MPI_OFFSET_KIND) :: offset + integer :: i,ierr,iunit + + ! Root serial-writes the file header + if (this%cfg%amRoot) then + ! Open the file + open(newunit=iunit,file=trim(filename),form='unformatted',status='replace',access='stream',iostat=ierr) + if (ierr.ne.0) call die('[lss write] Problem encountered while serial-opening data file: '//trim(filename)) + ! Number of particles and particle object size + write(iunit) this%np,MPI_PART_SIZE + ! Done with the header + close(iunit) + end if + + ! The rest is done in parallel + call MPI_FILE_OPEN(this%cfg%comm,trim(filename),IOR(MPI_MODE_WRONLY,MPI_MODE_APPEND),info_mpiio,ifile,ierr) + if (ierr.ne.0) call die('[lss write] Problem encountered while parallel-opening data file: '//trim(filename)) + + ! Get current position + call MPI_FILE_GET_POSITION(ifile,offset,ierr) + + ! Compute the offset and write + do i=1,this%cfg%rank + offset=offset+int(this%np_proc(i),MPI_OFFSET_KIND)*int(MPI_PART_SIZE,MPI_OFFSET_KIND) + end do + if (this%np_.gt.0) call MPI_FILE_WRITE_AT(ifile,offset,this%p,this%np_,MPI_PART,status,ierr) + + ! Close the file + call MPI_FILE_CLOSE(ifile,ierr) + + ! Log/screen output + logging: block + use, intrinsic :: iso_fortran_env, only: output_unit + use param, only: verbose + use messager, only: log + use string, only: str_long + character(len=str_long) :: message + if (this%cfg%amRoot) then + write(message,'("[lss write] Wrote ",i0," particles to file [",a,"] on partitioned grid [",a,"]")') this%np,trim(filename),trim(this%cfg%name) + if (verbose.gt.2) write(output_unit,'(a)') trim(message) + if (verbose.gt.1) call log(message) + end if + end block logging + + end subroutine write + + + !> Parallel read particles to file + subroutine read(this,filename) + use mpi_f08 + use messager, only: die + use parallel, only: info_mpiio + implicit none + class(lss), intent(inout) :: this + character(len=*), intent(in) :: filename + type(MPI_File) :: ifile + type(MPI_Status):: status + integer(kind=MPI_OFFSET_KIND) :: offset,header_offset + integer :: i,j,ierr,npadd,psize,nchunk,cnt + integer, dimension(:,:), allocatable :: ppp + + ! First open the file in parallel + call MPI_FILE_OPEN(this%cfg%comm,trim(filename),MPI_MODE_RDONLY,info_mpiio,ifile,ierr) + if (ierr.ne.0) call die('[lss read] Problem encountered while reading data file: '//trim(filename)) + + ! Read file header first + call MPI_FILE_READ_ALL(ifile,npadd,1,MPI_INTEGER,status,ierr) + call MPI_FILE_READ_ALL(ifile,psize,1,MPI_INTEGER,status,ierr) + + ! Remember current position + call MPI_FILE_GET_POSITION(ifile,header_offset,ierr) + + ! Check compatibility of particle type + if (psize.ne.MPI_PART_SIZE) call die('[lss read] Particle type unreadable') + + ! Naively share reading task among all processors + nchunk=int(npadd/(this%cfg%nproc*part_chunk_size))+1 + allocate(ppp(this%cfg%nproc,nchunk)) + ppp=int(npadd/(this%cfg%nproc*nchunk)) + cnt=0 + out:do j=1,nchunk + do i=1,this%cfg%nproc + cnt=cnt+1 + if (cnt.gt.mod(npadd,this%cfg%nproc*nchunk)) exit out + ppp(i,j)=ppp(i,j)+1 + end do + end do out + + ! Read by chunk + do j=1,nchunk + ! Find offset + offset=header_offset+int(MPI_PART_SIZE,MPI_OFFSET_KIND)*int(sum(ppp(1:this%cfg%rank,:))+sum(ppp(this%cfg%rank+1,1:j-1)),MPI_OFFSET_KIND) + ! Resize particle array + call this%resize(this%np_+ppp(this%cfg%rank+1,j)) + ! Read this file + call MPI_FILE_READ_AT(ifile,offset,this%p(this%np_+1:this%np_+ppp(this%cfg%rank+1,j)),ppp(this%cfg%rank+1,j),MPI_PART,status,ierr) + ! Most general case: relocate every droplet + do i=this%np_+1,this%np_+ppp(this%cfg%rank+1,j) + this%p(i)%ind=this%cfg%get_ijk_global(this%p(i)%pos,this%p(i)%ind) + end do + ! Exchange all that + call this%sync() + end do + + ! Close the file + call MPI_FILE_CLOSE(ifile,ierr) + + ! Log/screen output + logging: block + use, intrinsic :: iso_fortran_env, only: output_unit + use param, only: verbose + use messager, only: log + use string, only: str_long + character(len=str_long) :: message + if (this%cfg%amRoot) then + write(message,'("[lss read] Read ",i0," particles from file [",a,"] on partitioned grid [",a,"]")') npadd,trim(filename),trim(this%cfg%name) + if (verbose.gt.2) write(output_unit,'(a)') trim(message) + if (verbose.gt.1) call log(message) + end if + end block logging + + end subroutine read + + +end module lss_class diff --git a/examples/beam_test/src/lss_class_stl.f90 b/examples/beam_test/src/lss_class_stl.f90 new file mode 100644 index 000000000..584855c36 --- /dev/null +++ b/examples/beam_test/src/lss_class_stl.f90 @@ -0,0 +1,1636 @@ +!> Lagrangian solid solver object +!> Implements peridynamics equations +module lss_class + use precision, only: WP + use string, only: str_medium + use config_class, only: config + use mpi_f08, only: MPI_Datatype,MPI_INTEGER8,MPI_INTEGER,MPI_DOUBLE_PRECISION + implicit none + private + + + ! Expose type/constructor/methods + public :: lss + + + !> Memory adaptation parameter + real(WP), parameter :: coeff_up=1.3_WP !< Particle array size increase factor + real(WP), parameter :: coeff_dn=0.7_WP !< Particle array size decrease factor + + + !> I/O chunk size to read at a time + integer, parameter :: part_chunk_size=1000 !< Read 1000 particles at a time before redistributing + + + !> Maximum number of bonds per particle + integer, parameter, public :: max_bond=400 !< Assumes something like a 7x7x7 stencil in 3D + + + !> Bonded solid particle definition + type :: part + !> MPI_DOUBLE_PRECISION data + real(WP) :: mw !< Weighted volume + real(WP) :: dil !< Element dilatation + real(WP) :: ste !< Element dilatation + real(WP) :: vol !< Particle volume + real(WP), dimension(max_bond) :: dbond !< Length of initial bonds + real(WP), dimension(3) :: pos !< Particle center coordinates + real(WP), dimension(3) :: vel !< Velocity of particle + real(WP), dimension(3) :: Abond !< Bond acceleration for particle + real(WP), dimension(3) :: Afluid !< Fluid acceleration for particle + real(WP), dimension(3) :: gd !< Dilitation corrections + real(WP), dimension(3) :: gb !< Shear corrections + !> MPI_INTEGER data + integer :: id !< ID the object is associated with + integer :: i !< Unique index of particle (assumed >0) + integer :: nbond !< Number of initial bonds + integer, dimension(max_bond) :: ibond !< Indices of initially bonded particles (0 values ignored) + integer , dimension(3) :: ind !< Index of cell containing particle center + integer :: flag !< Control parameter (0=normal, 1=done->will be removed) + end type part + !> Number of blocks, block length, and block types in a particle + integer, parameter :: part_nblock=2 + integer , dimension(part_nblock) :: part_lblock=[22+max_bond,7+max_bond] + type(MPI_Datatype), dimension(part_nblock) :: part_tblock=[MPI_DOUBLE_PRECISION,MPI_INTEGER] + !> MPI_PART derived datatype and size + type(MPI_Datatype) :: MPI_PART + integer :: MPI_PART_SIZE + + + !> Lagrangian solid solver object definition + type :: lss + + ! This config is used for parallelization and for calculating bond/collision forces + class(config), pointer :: cfg + + ! This is the name of the solver + character(len=str_medium) :: name='UNNAMED_LSS' + + ! Solid material properties + real(WP) :: elastic_modulus !< Elastic modulus of the material + real(WP) :: poisson_ratio !< Poisson's ratio of the material + real(WP) :: rho !< Density of the material + real(WP) :: crit_energy !< Critical energy release + + ! Bonding parameters + real(WP) :: delta !< Bonding horizon (distance) + real(WP) :: min_dist !< Minimum bonding distance + integer :: nb !< Cell-based horizon + + ! Global and local particle data + integer :: np !< Global number of particles + integer :: np_ !< Local number of particles + integer, dimension(:), allocatable :: np_proc !< Number of particles on each processor + type(part), dimension(:), allocatable :: p !< Array of particles of type part + + ! Overlap particle (i.e., ghost) data + integer :: ng_ !< Local number of ghosts + type(part), dimension(:), allocatable :: g !< Array of ghosts of type part + + ! Gravitational acceleration + real(WP), dimension(3) :: gravity=[0.0_WP,0.0_WP,0.0_WP] + + ! Solid volume fraction and momentum + real(WP), dimension(:,:,:), allocatable :: VF !< Volume fraction, cell-centered + real(WP), dimension(:,:,:), allocatable :: VFU !< Solid velocity, U-face + real(WP), dimension(:,:,:), allocatable :: VFV !< Solid velocity, V-face + real(WP), dimension(:,:,:), allocatable :: VFW !< Solid velocity, W-face + + ! CFL numbers + real(WP) :: CFLp_x,CFLp_y,CFLp_z,CFLp_a + + ! Number of substeps for time integrator + real(WP) :: nstep=1 + + ! Monitoring info + real(WP) :: Umin,Umax,Umean !< U velocity info + real(WP) :: Vmin,Vmax,Vmean !< V velocity info + real(WP) :: Wmin,Wmax,Wmean !< W velocity info + real(WP) :: VFmax !< Volume fraction info + real(WP), dimension(3) :: ibmForce !< Total force due to IBM + integer :: np_out !< Number of particles leaving the domain + + contains + procedure :: bond_init !< Setup initial interparticle bonds + procedure :: get_bond_force !< Compute interparticle bond force + procedure :: advance !< Step forward the particle ODEs + procedure :: get_cfl !< Calculate maximum CFL + procedure :: get_max !< Extract various monitoring data + procedure :: update_partmesh !< Update a partmesh object using current particles + procedure :: share !< Share particles across interprocessor boundaries + procedure :: sync !< Synchronize particles across interprocessor boundaries + procedure :: resize !< Resize particle array to given size + procedure :: resize_ghost !< Resize ghost array to given size + procedure :: recycle !< Recycle particle array by removing flagged particles + procedure :: write !< Parallel write particles to file + procedure :: read !< Parallel read particles from file + procedure :: update_VF !< Compute volume fraction + procedure :: get_delta !< Compute regularized delta function + procedure :: interpolate !< Interpolation routine from mesh=>marker + procedure :: extrapolate !< Extrapolation routine from marker=>mesh + procedure :: stretch + end type lss + + + !> Declare lss constructor + interface lss + procedure constructor + end interface lss + +contains + + + ! Quasi-Gaussian weighting function - h is the cut-off + real(WP) function wgauss(d,h) + implicit none + real(WP), intent(in) :: d,h + real(WP), parameter :: coeff=2.6_WP + real(WP) :: hh + hh=coeff*h + if (d.ge.hh) then + wgauss=0.0_WP + else + wgauss=(1.0_WP+4.0_WP*d/hh)*(1.0_WP-d/hh)**4 + end if + end function wgauss + + + !> Default constructor for Lagrangian solid solver + function constructor(cfg,name) result(self) + implicit none + type(lss) :: self + class(config), target, intent(in) :: cfg + character(len=*), optional :: name + integer :: i,j,k + + ! Set the name for the solver + if (present(name)) self%name=trim(adjustl(name)) + + ! Point to pgrid object + self%cfg=>cfg + + ! Set default bonding horizon based on underlying mesh + self%delta=self%cfg%min_meshsize + self%nb=1 + self%min_dist=huge(1.0_WP) + + ! Allocate variables + allocate(self%np_proc(1:self%cfg%nproc)); self%np_proc=0 + self%np_=0; self%np=0 + call self%resize(0) + + ! Initialize MPI derived datatype for a particle + call prepare_mpi_part() + + ! Allocate VF array on cfg mesh + allocate(self%VF(self%cfg%imino_:self%cfg%imaxo_,self%cfg%jmino_:self%cfg%jmaxo_,self%cfg%kmino_:self%cfg%kmaxo_)); self%VF=0.0_WP + allocate(self%VFU(self%cfg%imino_:self%cfg%imaxo_,self%cfg%jmino_:self%cfg%jmaxo_,self%cfg%kmino_:self%cfg%kmaxo_)); self%VFU=0.0_WP + allocate(self%VFV(self%cfg%imino_:self%cfg%imaxo_,self%cfg%jmino_:self%cfg%jmaxo_,self%cfg%kmino_:self%cfg%kmaxo_)); self%VFV=0.0_WP + allocate(self%VFW(self%cfg%imino_:self%cfg%imaxo_,self%cfg%jmino_:self%cfg%jmaxo_,self%cfg%kmino_:self%cfg%kmaxo_)); self%VFW=0.0_WP + + ! Log/screen output + logging: block + use, intrinsic :: iso_fortran_env, only: output_unit + use param, only: verbose + use messager, only: log + use string, only: str_long + character(len=str_long) :: message + if (self%cfg%amRoot) then + write(message,'("LSS object [",a,"] on partitioned grid [",a,"]")') trim(self%name),trim(self%cfg%name) + if (verbose.gt.1) write(output_unit,'(a)') trim(message) + if (verbose.gt.0) call log(message) + end if + end block logging + + end function constructor + + + !> Initialize bond force between particles + subroutine bond_init(this) + use messager, only: die + implicit none + class(lss), intent(inout) :: this + integer, dimension(:,:,:), allocatable :: npic !< Number of particle in cell + integer, dimension(:,:,:,:), allocatable :: ipic !< Index of particle in cell + + ! Communicate particles in ghost cells + call this%share() + + ! We can now assemble particle-in-cell information + pic_prep: block + use mpi_f08 + integer :: i,ip,jp,kp,ierr + integer :: mymax_npic,max_npic + + ! Allocate number of particle in cell + allocate(npic(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)); npic=0 + + ! Count particles and ghosts per cell + do i=1,this%np_ + ip=this%p(i)%ind(1); jp=this%p(i)%ind(2); kp=this%p(i)%ind(3) + npic(ip,jp,kp)=npic(ip,jp,kp)+1 + end do + do i=1,this%ng_ + ip=this%g(i)%ind(1); jp=this%g(i)%ind(2); kp=this%g(i)%ind(3) + npic(ip,jp,kp)=npic(ip,jp,kp)+1 + end do + + ! Get maximum number of particle in cell + mymax_npic=maxval(npic); call MPI_ALLREDUCE(mymax_npic,max_npic,1,MPI_INTEGER,MPI_MAX,this%cfg%comm,ierr) + + ! Allocate pic map + allocate(ipic(1:max_npic,this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)); ipic=0 + + ! Assemble pic map + npic=0 + do i=1,this%np_ + ip=this%p(i)%ind(1); jp=this%p(i)%ind(2); kp=this%p(i)%ind(3) + npic(ip,jp,kp)=npic(ip,jp,kp)+1 + ipic(npic(ip,jp,kp),ip,jp,kp)=+i + end do + do i=1,this%ng_ + ip=this%g(i)%ind(1); jp=this%g(i)%ind(2); kp=this%g(i)%ind(3) + npic(ip,jp,kp)=npic(ip,jp,kp)+1 + ipic(npic(ip,jp,kp),ip,jp,kp)=-i + end do + + end block pic_prep + + ! Establish initial bonds + create_bonds: block + use mpi_f08, only: MPI_ALLREDUCE,MPI_MIN,MPI_IN_PLACE + use parallel, only: MPI_REAL_WP + use mathtools, only: Pi + integer :: i,j,k,n1,nn,n2,ierr + type(part) :: p1,p2 + real(WP), dimension(3) :: rpos + real(WP) :: dist + ! Reset minimum bond distance + this%min_dist=huge(1.0_WP) + ! Loop over particles + do n1=1,this%np_ + ! Create copy of our particle + p1=this%p(n1) + ! Zero out weighted volume + p1%mw=0.0_WP + ! Zero out bonds + p1%ibond=0 + p1%nbond=0 + ! Loop over neighbor cells + do k=p1%ind(3)-this%nb,p1%ind(3)+this%nb + do j=p1%ind(2)-this%nb,p1%ind(2)+this%nb + do i=p1%ind(1)-this%nb,p1%ind(1)+this%nb + ! Loop over particles in that cell + do nn=1,npic(i,j,k) + ! Create copy of our neighbor + n2=ipic(nn,i,j,k) + if (n2.gt.0) then + p2=this%p(+n2) + else if (n2.lt.0) then + p2=this%g(-n2) + end if + ! Cannot self-bond + if (p1%i.eq.p2%i) cycle + ! Cannot bond with different id except <=0 (<=0 bonds with everyone) + if (p1%id.ne.p2%id.and.p1%id.ge.0.and.p2%id.ge.0) cycle + ! Check interparticle distance + rpos=p2%pos-p1%pos + dist=sqrt(dot_product(rpos,rpos)) + if (dist.lt.this%delta) then + ! This particle is in horizon, create a bond + p1%nbond=p1%nbond+1 + if (p1%nbond.gt.max_bond) call die('[lss_class bond_init] Number of detected bonds is larger than max allowed') + p1%ibond(p1%nbond)=p2%i + p1%dbond(p1%nbond)=dist + ! Increment weighted volume + p1%mw=p1%mw+wgauss(dist,this%delta)*dist**2*p1%vol + ! Determine minimum bond distance + this%min_dist=min(this%min_dist,dist) + end if + end do + end do + end do + end do + ! Zero out initial dilatation + p1%dil=0.0_WP + ! Copy back the particle + this%p(n1)=p1 + end do + ! Get global minimum + call MPI_ALLREDUCE(MPI_IN_PLACE,this%min_dist,1,MPI_REAL_WP,MPI_MIN,this%cfg%comm,ierr) + end block create_bonds + + ! Clean up + if (allocated(npic)) deallocate(npic) + if (allocated(ipic)) deallocate(ipic) + + end subroutine bond_init + + + !> Calculate bond force between particles + subroutine get_bond_force(this) + implicit none + class(lss), intent(inout) :: this + integer, dimension(:,:,:), allocatable :: npic !< Number of particle in cell + integer, dimension(:,:,:,:), allocatable :: ipic !< Index of particle in cell + logical :: is2D + + ! Need to modify parameters in 2D + is2D=this%cfg%nx.eq.1.or.this%cfg%ny.eq.1.or.this%cfg%nz.eq.1 + + ! Communicate particles in ghost cells + call this%share() + + ! We can now assemble particle-in-cell information + pic_prep: block + use mpi_f08 + integer :: i,ip,jp,kp,ierr + integer :: mymax_npic,max_npic + + ! Allocate number of particle in cell + allocate(npic(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)); npic=0 + + ! Count particles and ghosts per cell + do i=1,this%np_ + ip=this%p(i)%ind(1); jp=this%p(i)%ind(2); kp=this%p(i)%ind(3) + npic(ip,jp,kp)=npic(ip,jp,kp)+1 + end do + do i=1,this%ng_ + ip=this%g(i)%ind(1); jp=this%g(i)%ind(2); kp=this%g(i)%ind(3) + npic(ip,jp,kp)=npic(ip,jp,kp)+1 + end do + + ! Get maximum number of particle in cell + mymax_npic=maxval(npic); call MPI_ALLREDUCE(mymax_npic,max_npic,1,MPI_INTEGER,MPI_MAX,this%cfg%comm,ierr) + + ! Allocate pic map + allocate(ipic(1:max_npic,this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)); ipic=0 + + ! Assemble pic map + npic=0 + do i=1,this%np_ + ip=this%p(i)%ind(1); jp=this%p(i)%ind(2); kp=this%p(i)%ind(3) + npic(ip,jp,kp)=npic(ip,jp,kp)+1 + ipic(npic(ip,jp,kp),ip,jp,kp)=+i + end do + do i=1,this%ng_ + ip=this%g(i)%ind(1); jp=this%g(i)%ind(2); kp=this%g(i)%ind(3) + npic(ip,jp,kp)=npic(ip,jp,kp)+1 + ipic(npic(ip,jp,kp),ip,jp,kp)=-i + end do + + end block pic_prep + + ! Update weighted volume and dilatation + update_weighted_vol_and_dilatation: block + integer :: i,j,k,n1,nn,n2 + type(part) :: p1,p2 + integer :: nb,nbond + real(WP), dimension(3) :: rpos, Gd_vec + real(WP) :: dist, Gd_mag + ! Loop over particles + do n1=1,this%np_ + ! Create copy of our particle + p1=this%p(n1) + ! Zero out weighted volume and dilatation + p1%mw=0.0_WP + p1%dil=0.0_WP + ! Loop over neighbor cells + do k=p1%ind(3)-this%nb,p1%ind(3)+this%nb + do j=p1%ind(2)-this%nb,p1%ind(2)+this%nb + do i=p1%ind(1)-this%nb,p1%ind(1)+this%nb + ! Loop over particles in that cell + do nn=1,npic(i,j,k) + ! Create copy of our neighbor + n2=ipic(nn,i,j,k) + if (n2.gt.0) then + p2=this%p(+n2) + else if (n2.lt.0) then + p2=this%g(-n2) + end if + ! Check if a bond exists + do nb=1,max_bond + if (p1%ibond(nb).eq.p2%i) then + ! Increment weighted volume + p1%mw=p1%mw+wgauss(p1%dbond(nb),this%delta)*p1%dbond(nb)**2*p2%vol + ! Get current distance + rpos=p2%pos-p1%pos + dist=sqrt(dot_product(rpos,rpos)) + ! compute average G correction for dilitation + Gd_vec = (p2%gd + p1%gd)/2.0_WP + + Gd_mag = sqrt(1.0_WP/(((rpos(1)/dist)/Gd_vec(1))**2 + ((rpos(2)/dist)/Gd_vec(2))**2 + ((rpos(3)/dist)/Gd_vec(3))**2 )) + ! Increment dilatation + p1%dil=p1%dil+wgauss(p1%dbond(nb),this%delta)*p1%dbond(nb)*(dist-p1%dbond(nb))*p2%vol*Gd_mag + end if + end do + end do + end do + end do + end do + ! Rescale dilatation + if (p1%mw.gt.epsilon(1.0_WP)) then + if (is2D) then + ! 2D plane strain + p1%dil=p1%dil*2.0_WP/p1%mw + else + ! 3D + p1%dil=p1%dil*3.0_WP/p1%mw + end if + else + p1%dil=0.0_WP + end if + ! Copy back the particle + this%p(n1)=p1 + end do + end block update_weighted_vol_and_dilatation + + ! Re-communicate particles in ghost cells to update dil and mw + call this%share() + + ! Update bond force, including collision force, and SED + update_bond_force: block + use mpi_f08, only: MPI_ALLREDUCE,MPI_MIN,MPI_IN_PLACE + use parallel, only: MPI_REAL_WP + use mathtools, only: Pi + integer :: i,j,k,n1,nn,n2,ierr + type(part) :: p1,p2 + real(WP), dimension(3) :: rpos,t12,t21,Gd_vec + real(WP) :: dist,beta,alpha,ed,t,Gd_mag + real(WP) :: stretch,max_stretch,mu,kk + real(WP) :: nc,rc,kc + integer :: nb,nbond + logical :: found_bond + ! Recompute a few physical parameters + mu=this%elastic_modulus/(2.0_WP+2.0_WP*this%poisson_ratio) + kk=this%elastic_modulus/(3.0_WP-6.0_WP*this%poisson_ratio) + if (is2D) then + if (this%cfg%nx.eq.1) t=this%cfg%xL + if (this%cfg%ny.eq.1) t=this%cfg%yL + if (this%cfg%nz.eq.1) t=this%cfg%zL + max_stretch=sqrt(this%crit_energy/((6.0_WP*mu/Pi+16.0_WP/(9.0_WP*Pi**2)*(kk-2.0_WP*mu))*this%delta)) + kc=15.0_WP*48.0_WP*this%elastic_modulus/(Pi*5.0_WP*t*this%delta**3) + else + max_stretch=sqrt(this%crit_energy/((3.0_WP*mu+(kk-5.0_WP*mu/3.0_WP)*0.75_WP**4)*this%delta)) + kc=15.0_WP*12.0_WP*this%elastic_modulus/(Pi*this%delta**4) + end if + nc=1.0_WP + this%min_dist=huge(1.0_WP) + ! Loop over particles + do n1=1,this%np_ + ! Particles marked 0 do not update their forces + if (this%p(n1)%id.eq.0) cycle + ! Create copy of our particle + p1=this%p(n1) + ! Zero out bond force + p1%Abond=0.0_WP + ! Loop over neighbor cells + do k=p1%ind(3)-this%nb,p1%ind(3)+this%nb + do j=p1%ind(2)-this%nb,p1%ind(2)+this%nb + do i=p1%ind(1)-this%nb,p1%ind(1)+this%nb + ! Loop over particles in that cell + do nn=1,npic(i,j,k) + ! Create copy of our neighbor + n2=ipic(nn,i,j,k) + if (n2.gt.0) then + p2=this%p(+n2) + else if (n2.lt.0) then + p2=this%g(-n2) + end if + ! Current distance + rpos=p2%pos-p1%pos + dist=sqrt(dot_product(rpos,rpos)) + ! Check if a bond exists + found_bond=.false. + do nb=1,max_bond + if (p1%ibond(nb).eq.p2%i) then + ! Check for breakage first + stretch=(dist-p1%dbond(nb))/p1%dbond(nb) + if (stretch.gt.max_stretch) then + ! Remove the bond and flag as surface particle + p1%ibond(nb)=0 + p1%dbond(nb)=0.0_WP + cycle + end if + ! Particle 1 + if (is2D) then + ! 2D plane strain + beta = 2.0_WP * kk * p1%dil + alpha = 8.0_WP * mu / p1%mw + ed = dist - p1%dbond(nb) * (1.0_WP + p1%dil / 2.0_WP) + else + ! 3D + beta = 3.0_WP * kk * p1%dil + alpha = 15.0_WP * mu / p1%mw + ed = dist - p1%dbond(nb) * (1.0_WP + p1%dil / 3.0_WP) + end if + ! Force density 1->2 + ! t12=+wgauss(p1%dbond(nb),this%delta)*(beta/p1%mw*p1%dbond(nb)+alpha*ed)*rpos/dist + Gd_vec = (p2%gd + p1%gd)/2.0_WP + + Gd_mag = sqrt(1.0_WP/(((rpos(1)/dist)/Gd_vec(1))**2 + ((rpos(2)/dist)/Gd_vec(2))**2 + ((rpos(3)/dist)/Gd_vec(3))**2 )) + t12=+wgauss(p1%dbond(nb),this%delta)*((3.0_WP*kk - 15.0_WP*mu/3.0_WP)*(Gd_mag*p1%dil*p1%dbond(nb)/p1%mw) + (15.0_WP*mu/p1%mw)*(dist - p1%dbond(nb)) )*rpos/dist + ! Particle 2 + if (is2D) then + ! 2D plane strain + beta = 2.0_WP * kk * p2%dil + alpha = 8.0_WP * mu / p2%mw + ed = dist - p1%dbond(nb) * (1.0_WP + p2%dil / 2.0_WP) + else + ! 3D + beta = 3.0_WP * kk * p2%dil + alpha = 15.0_WP * mu / p2%mw + ed = dist - p1%dbond(nb) * (1.0_WP + p2%dil / 3.0_WP) + end if + ! Force density 2->1 + ! t21=-wgauss(p1%dbond(nb),this%delta)*(beta/p2%mw*p1%dbond(nb)+alpha*ed)*rpos/dist + t21=-wgauss(p1%dbond(nb),this%delta)*((3.0_WP*kk - 15.0_WP*mu/3.0_WP)*(Gd_mag*p2%dil*p1%dbond(nb)/p2%mw)+ (15.0_WP*mu/p2%mw)*(dist - p1%dbond(nb)) )*rpos/dist ! Increment bond force + p1%Abond=p1%Abond+(t12-t21)*p2%vol/this%rho + ! Incremend SED + p1%ste=p1%ste+alpha/2.0_WP*(wgauss(p1%dbond(nb),this%delta)*((dist-p1%dbond(nb)))*p2%vol) + ! If still here, we have an active bond + found_bond=.true. + ! Determine minimum bond distance + this%min_dist=min(this%min_dist,dist) + cycle + end if + end do + ! Add collision force now + ! if (is2D) then + ! rc=p1%vol**(1.0_WP/2.0_WP) + ! else + ! rc=p1%vol**(1.0_WP/3.0_WP) + ! end if + ! if (.not.found_bond.and.p1%i.ne.p2%i.and.dist.lt.rc) then + ! p1%Abond=p1%Abond-max(kc*((rc/dist)**nc-1.0_WP),0.0_WP)*(rpos/dist)*p1%vol/this%rho + ! p1%flag = -2 + ! end if + end do + end do + end do + end do + ! Deal with dimensionality + if (this%cfg%nx.eq.1) p1%Abond(1)=0.0_WP + if (this%cfg%ny.eq.1) p1%Abond(2)=0.0_WP + if (this%cfg%nz.eq.1) p1%Abond(3)=0.0_WP + ! Copy back the particle + this%p(n1)=p1 + end do + ! Get global minimum + call MPI_ALLREDUCE(MPI_IN_PLACE,this%min_dist,1,MPI_REAL_WP,MPI_MIN,this%cfg%comm,ierr) + end block update_bond_force + + ! Clean up + if (allocated(npic)) deallocate(npic) + if (allocated(ipic)) deallocate(ipic) + + end subroutine get_bond_force + + + !> Advance the particle equations by a specified time step dt + !> p%id=-2 => do not solve for position nor velocity + !> p%id=-1 => do not solve for velocity + !> p%id= 0 => do not update force + + subroutine advance(this,dt)!,stress_x,stress_y,stress_z) + use mpi_f08, only : MPI_SUM,MPI_INTEGER,MPI_IN_PLACE + use mathtools, only: Pi + implicit none + class(lss), intent(inout) :: this + real(WP), intent(inout) :: dt !< Timestep size over which to advance + ! real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(inout) :: stress_x !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + ! real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(inout) :: stress_y !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + ! real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(inout) :: stress_z !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + integer :: n,ierr + ! real(WP), dimension(3) :: stress + + ! Zero out number of particles removed + this%np_out=0 + + ! Advance velocity based on old force and position based on mid-velocity + do n=1,this%np_ + ! Advance with Verlet scheme + if (this%p(n)%id.gt.-1) this%p(n)%vel=this%p(n)%vel+0.5_WP*dt*(this%gravity+this%p(n)%Abond+this%p(n)%Afluid) + if (this%p(n)%id.gt.-2) this%p(n)%pos=this%p(n)%pos+dt*this%p(n)%vel + ! Relocalize + this%p(n)%ind=this%cfg%get_ijk_global(this%p(n)%pos,this%p(n)%ind) + ! Correct the position to take into account periodicity + if (this%cfg%xper) this%p(n)%pos(1)=this%cfg%x(this%cfg%imin)+modulo(this%p(n)%pos(1)-this%cfg%x(this%cfg%imin),this%cfg%xL) + if (this%cfg%yper) this%p(n)%pos(2)=this%cfg%y(this%cfg%jmin)+modulo(this%p(n)%pos(2)-this%cfg%y(this%cfg%jmin),this%cfg%yL) + if (this%cfg%zper) this%p(n)%pos(3)=this%cfg%z(this%cfg%kmin)+modulo(this%p(n)%pos(3)-this%cfg%z(this%cfg%kmin),this%cfg%zL) + ! Handle particles that have left the domain + if (this%p(n)%pos(1).lt.this%cfg%x(this%cfg%imin).or.this%p(n)%pos(1).gt.this%cfg%x(this%cfg%imax+1)) this%p(n)%flag=1 + if (this%p(n)%pos(2).lt.this%cfg%y(this%cfg%jmin).or.this%p(n)%pos(2).gt.this%cfg%y(this%cfg%jmax+1)) this%p(n)%flag=1 + if (this%p(n)%pos(3).lt.this%cfg%z(this%cfg%kmin).or.this%p(n)%pos(3).gt.this%cfg%z(this%cfg%kmax+1)) this%p(n)%flag=1 + ! Relocalize the particle + this%p(n)%ind=this%cfg%get_ijk_global(this%p(n)%pos,this%p(n)%ind) + ! Count number of particles removed + if (this%p(n)%flag.eq.1) this%np_out=this%np_out+1 + end do + + ! Communicate particles + call this%sync() + + ! Sum up particles removed + call MPI_ALLREDUCE(this%np_out,n,1,MPI_INTEGER,MPI_SUM,this%cfg%comm,ierr); this%np_out=n + + ! Calculate bond force + call this%get_bond_force() + + ! Advance velocity only based on new force + do n=1,this%np_ + ! Advance with Verlet scheme + if (this%p(n)%id.le.-1) cycle + ! stress=this%cfg%get_velocity(pos=this%p(n)%pos,i0=this%p(n)%ind(1),j0=this%p(n)%ind(2),k0=this%p(n)%ind(3),U=stress_x,V=stress_y,W=stress_z) + ! this%p(n)%Afluid=stress/this%rho + this%p(n)%Afluid=0.0_WP + this%p(n)%vel=this%p(n)%vel+0.5_WP*dt*(this%gravity+this%p(n)%Abond+this%p(n)%Afluid) + end do + + ! Recompute volume fraction + ! call this%update_VF() + + ! Log/screen output + logging: block + use, intrinsic :: iso_fortran_env, only: output_unit + use param, only: verbose + use messager, only: log + use string, only: str_long + character(len=str_long) :: message + if (this%cfg%amRoot) then + write(message,'("Particle solver [",a,"] on partitioned grid [",a,"]: ",i0," particles were advanced")') trim(this%name),trim(this%cfg%name),this%np + if (verbose.gt.1) write(output_unit,'(a)') trim(message) + if (verbose.gt.0) call log(message) + end if + end block logging + + end subroutine advance + + subroutine stretch(this,dt)!,stress_x,stress_y,stress_z) + use mpi_f08, only : MPI_SUM,MPI_INTEGER,MPI_IN_PLACE + use mathtools, only: Pi + implicit none + class(lss), intent(inout) :: this + real(WP), intent(inout) :: dt !< Timestep size over which to advance + real(WP) :: mu + integer :: n,ierr + !======================================================================================== + ! X-Axis Stretch: + ! Zero out number of particles removed + this%np_out=0 + do n=1,this%np_ + ! Stretch the beam along the x axis with a uniform strain-rate of 0.001 + if (this%p(n)%id.gt.-2) this%p(n)%pos(1)=this%p(n)%pos(1)*1.001_WP + end do + + ! Communicate particles + call this%sync() + + ! Calculate bond force + call this%get_bond_force() + + mu=this%elastic_modulus/(2.0_WP+2.0_WP*this%poisson_ratio) + + do n=1,this%np_ + if (this%p(n)%id.gt.-2) this%p(n)%gd(1)=0.001_WP/this%p(n)%dil + end do + + !======================================================================================== + ! Y-Axis Stretch: + ! Zero out number of particles removed + this%np_out=0 + do n=1,this%np_ + ! Stretch the beam along the x axis with a uniform strain-rate of 0.001 + if (this%p(n)%id.gt.-2) this%p(n)%pos(1)=this%p(n)%pos(1)/1.001_WP + if (this%p(n)%id.gt.-2) this%p(n)%pos(2)=this%p(n)%pos(2)*1.001_WP + end do + + ! Communicate particles + call this%sync() + + ! Calculate bond force + call this%get_bond_force() + + mu=this%elastic_modulus/(2.0_WP+2.0_WP*this%poisson_ratio) + + do n=1,this%np_ + if (this%p(n)%id.gt.-2) this%p(n)%gd(2)=0.001_WP/this%p(n)%dil + end do + + !======================================================================================== + ! Z-Axis Stretch: + ! Zero out number of particles removed + this%np_out=0 + do n=1,this%np_ + ! Stretch the beam along the x axis with a uniform strain-rate of 0.001 + if (this%p(n)%id.gt.-2) this%p(n)%pos(2)=this%p(n)%pos(2)/1.001_WP + if (this%p(n)%id.gt.-2) this%p(n)%pos(3)=this%p(n)%pos(3)*1.001_WP + end do + + ! Communicate particles + call this%sync() + + ! Calculate bond force + call this%get_bond_force() + + mu=this%elastic_modulus/(2.0_WP+2.0_WP*this%poisson_ratio) + + do n=1,this%np_ + if (this%p(n)%id.gt.-2) this%p(n)%gd(3)=0.001_WP/this%p(n)%dil + end do + + ! Put the particle back where it was + do n=1,this%np_ + if (this%p(n)%id.gt.-2) this%p(n)%pos(3)=this%p(n)%pos(3)/1.001_WP + end do + + !====================================================================================== + + ! Now stretch particle for the first time step + + do n=1,this%np_ + ! Stretch the beam along the x axis with a uniform strain-rate of 0.001 + if (this%p(n)%id.gt.-2) this%p(n)%pos(1)=this%p(n)%pos(1)*1.001_WP + end do + + ! Communicate particles + call this%sync() + + ! Calculate bond force + call this%get_bond_force() + + + + + end subroutine stretch + + subroutine get_correction_coeffs(this,dt)!,stress_x,stress_y,stress_z) + use mpi_f08, only : MPI_SUM,MPI_INTEGER,MPI_IN_PLACE + use mathtools, only: Pi + implicit none + class(lss), intent(inout) :: this + real(WP), intent(inout) :: dt !< Timestep size over which to advance + real(WP) :: mu + integer :: n,ierr + ! Zero out number of particles removed + this%np_out=0 + do n=1,this%np_ + ! Stretch the beam along the x axis with a uniform strain-rate of 0.001 + if (this%p(n)%id.gt.-2) this%p(n)%pos(1)=this%p(n)%pos(1) + this%p(n)%pos(1)*0.001_WP + ! Relocalize + this%p(n)%ind=this%cfg%get_ijk_global(this%p(n)%pos,this%p(n)%ind) + ! Correct the position to take into account periodicity + if (this%cfg%xper) this%p(n)%pos(1)=this%cfg%x(this%cfg%imin)+modulo(this%p(n)%pos(1)-this%cfg%x(this%cfg%imin),this%cfg%xL) + if (this%cfg%yper) this%p(n)%pos(2)=this%cfg%y(this%cfg%jmin)+modulo(this%p(n)%pos(2)-this%cfg%y(this%cfg%jmin),this%cfg%yL) + if (this%cfg%zper) this%p(n)%pos(3)=this%cfg%z(this%cfg%kmin)+modulo(this%p(n)%pos(3)-this%cfg%z(this%cfg%kmin),this%cfg%zL) + ! Handle particles that have left the domain + if (this%p(n)%pos(1).lt.this%cfg%x(this%cfg%imin).or.this%p(n)%pos(1).gt.this%cfg%x(this%cfg%imax+1)) this%p(n)%flag=1 + if (this%p(n)%pos(2).lt.this%cfg%y(this%cfg%jmin).or.this%p(n)%pos(2).gt.this%cfg%y(this%cfg%jmax+1)) this%p(n)%flag=1 + if (this%p(n)%pos(3).lt.this%cfg%z(this%cfg%kmin).or.this%p(n)%pos(3).gt.this%cfg%z(this%cfg%kmax+1)) this%p(n)%flag=1 + ! Relocalize the particle + this%p(n)%ind=this%cfg%get_ijk_global(this%p(n)%pos,this%p(n)%ind) + ! Count number of particles removed + end do + + ! Communicate particles + call this%sync() + + ! Sum up particles removed + call MPI_ALLREDUCE(this%np_out,n,1,MPI_INTEGER,MPI_SUM,this%cfg%comm,ierr); this%np_out=n + + ! Calculate bond force + call this%get_bond_force() + + mu=this%elastic_modulus/(2.0_WP+2.0_WP*this%poisson_ratio) + + do n=1,this%np_ + this%p(n)%gd=0.001_WP/this%p(n)%dil + this%p(n)%Gb=0.5_WP*mu*(0.001_WP*0.001_WP)/this%p(n)%ste + end do + + ! Log/screen output + logging: block + use, intrinsic :: iso_fortran_env, only: output_unit + use param, only: verbose + use messager, only: log + use string, only: str_long + character(len=str_long) :: message + if (this%cfg%amRoot) then + write(message,'("Particle solver [",a,"] on partitioned grid [",a,"]: ",i0," particles were advanced")') trim(this%name),trim(this%cfg%name),this%np + if (verbose.gt.1) write(output_unit,'(a)') trim(message) + if (verbose.gt.0) call log(message) + end if + end block logging + + end subroutine get_correction_coeffs + + + !> Update particle volume fraction using our current particles + subroutine update_VF(this) + implicit none + class(lss), intent(inout) :: this + integer :: i + ! Reset volume fraction and momentum + this%VF=0.0_WP; this%VFU=0.0_WP; this%VFV=0.0_WP; this%VFW=0.0_WP + ! Transfer particle volume + do i=1,this%np_ + ! Skip inactive particle + if (this%p(i)%flag.eq.1) cycle + ! Transfer volume to mesh + call this%extrapolate(Ap=this%p(i)%vol,xp=this%p(i)%pos(1),yp=this%p(i)%pos(2),zp=this%p(i)%pos(3),ip=this%p(i)%ind(1),jp=this%p(i)%ind(2),kp=this%p(i)%ind(3),A=this%VF,dir='SC') + call this%extrapolate(Ap=this%p(i)%vol*this%p(i)%vel(1),xp=this%p(i)%pos(1),yp=this%p(i)%pos(2),zp=this%p(i)%pos(3),ip=this%p(i)%ind(1),jp=this%p(i)%ind(2),kp=this%p(i)%ind(3),A=this%VFU,dir='U') + call this%extrapolate(Ap=this%p(i)%vol*this%p(i)%vel(2),xp=this%p(i)%pos(1),yp=this%p(i)%pos(2),zp=this%p(i)%pos(3),ip=this%p(i)%ind(1),jp=this%p(i)%ind(2),kp=this%p(i)%ind(3),A=this%VFV,dir='V') + call this%extrapolate(Ap=this%p(i)%vol*this%p(i)%vel(3),xp=this%p(i)%pos(1),yp=this%p(i)%pos(2),zp=this%p(i)%pos(3),ip=this%p(i)%ind(1),jp=this%p(i)%ind(2),kp=this%p(i)%ind(3),A=this%VFW,dir='W') + end do + ! Sum at boundaries + call this%cfg%syncsum(this%VF) + call this%cfg%syncsum(this%VFU) + call this%cfg%syncsum(this%VFV) + call this%cfg%syncsum(this%VFW) + ! Clip + where (this%VF.gt.1.0_WP) this%VF=1.0_WP + where (this%VF.lt.0.0_WP) this%VF=0.0_WP + end subroutine update_VF + + + !> Compute regularized delta function + subroutine get_delta(this,delta,ic,jc,kc,xp,yp,zp,dir) + implicit none + class(lss), intent(inout) :: this + real(WP), intent(out) :: delta !< Return delta function + integer, intent(in) :: ic,jc,kc !< Cell index + real(WP), intent(in) :: xp,yp,zp !< Position of marker + character(len=*) :: dir + real(WP) :: deltax,deltay,deltaz,r + + ! Compute in X + if (trim(adjustl(dir)).eq.'U') then + r=(xp-this%cfg%x(ic))*this%cfg%dxmi(ic) + deltax=roma_kernel(r)*this%cfg%dxmi(ic) + else + r=(xp-this%cfg%xm(ic))*this%cfg%dxi(ic) + deltax=roma_kernel(r)*this%cfg%dxi(ic) + end if + + ! Compute in Y + if (trim(adjustl(dir)).eq.'V') then + r=(yp-this%cfg%y(jc))*this%cfg%dymi(jc) + deltay=roma_kernel(r)*this%cfg%dymi(jc) + else + r=(yp-this%cfg%ym(jc))*this%cfg%dyi(jc) + deltay=roma_kernel(r)*this%cfg%dyi(jc) + end if + + ! Compute in Z + if (trim(adjustl(dir)).eq.'W') then + r=(zp-this%cfg%z(kc))*this%cfg%dzmi(kc) + deltaz=roma_kernel(r)*this%cfg%dzmi(kc) + else + r=(zp-this%cfg%zm(kc))*this%cfg%dzi(kc) + deltaz=roma_kernel(r)*this%cfg%dzi(kc) + end if + !else + + ! Put it all together + delta=deltax*deltay*deltaz + + contains + ! Mollification kernel + ! Roma A, Peskin C and Berger M 1999 J. Comput. Phys. 153 509–534 + function roma_kernel(r) result(phi) + implicit none + real(WP), intent(in) :: r + real(WP) :: phi + if (abs(r).le.0.5_WP) then + phi=1.0_WP/3.0_WP*(1.0_WP+sqrt(-3.0_WP*r**2+1.0_WP)) + else if (abs(r).gt.0.5_WP .and. abs(r).le.1.5_WP) then + phi=1.0_WP/6.0_WP*(5.0_WP-3.0_WP*abs(r)-sqrt(-3.0_WP*(1.0_WP-abs(r))**2+1.0_WP)) + else + phi=0.0_WP + end if + end function roma_kernel + + end subroutine get_delta + + + !> Interpolation routine + function interpolate(this,A,xp,yp,zp,ip,jp,kp,dir) result(Ap) + implicit none + class(lss), intent(inout) :: this + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(in) :: A !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + real(WP), intent(in) :: xp,yp,zp + integer, intent(in) :: ip,jp,kp + character(len=*) :: dir + real(WP) :: Ap + integer :: di,dj,dk + integer :: i1,i2,j1,j2,k1,k2 + real(WP), dimension(-2:+2,-2:+2,-2:+2) :: delta + ! Get the interpolation points + i1=ip-2; i2=ip+2 + j1=jp-2; j2=jp+2 + k1=kp-2; k2=kp+2 + ! Loop over neighboring cells and compute regularized delta function + do dk=-2,+2 + do dj=-2,+2 + do di=-2,+2 + call this%get_delta(delta=delta(di,dj,dk),ic=ip+di,jc=jp+dj,kc=kp+dk,xp=xp,yp=yp,zp=zp,dir=trim(dir)) + end do + end do + end do + ! Perform the actual interpolation on Ap + Ap = sum(delta*A(i1:i2,j1:j2,k1:k2))*this%cfg%vol(ip,jp,kp) + end function interpolate + + + !> Extrapolation routine + subroutine extrapolate(this,Ap,xp,yp,zp,ip,jp,kp,A,dir) + use messager, only: die + implicit none + class(lss), intent(inout) :: this + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:) :: A !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + real(WP), intent(in) :: xp,yp,zp + integer, intent(in) :: ip,jp,kp + real(WP), intent(in) :: Ap + character(len=*) :: dir + real(WP), dimension(-2:+2,-2:+2,-2:+2) :: delta + integer :: di,dj,dk + ! If particle has left processor domain or reached last ghost cell, kill job + if ( ip.lt.this%cfg%imin_-1.or.ip.gt.this%cfg%imax_+1.or.& + & jp.lt.this%cfg%jmin_-1.or.jp.gt.this%cfg%jmax_+1.or.& + & kp.lt.this%cfg%kmin_-1.or.kp.gt.this%cfg%kmax_+1) then + write(*,*) ip,jp,kp,xp,yp,zp + call die('[df extrapolate] Particle has left the domain') + end if + ! Loop over neighboring cells and compute regularized delta function + do dk=-2,+2 + do dj=-2,+2 + do di=-2,+2 + call this%get_delta(delta=delta(di,dj,dk),ic=ip+di,jc=jp+dj,kc=kp+dk,xp=xp,yp=yp,zp=zp,dir=trim(dir)) + end do + end do + end do + ! Perform the actual extrapolation on A + A(ip-2:ip+2,jp-2:jp+2,kp-2:kp+2)=A(ip-2:ip+2,jp-2:jp+2,kp-2:kp+2)+delta*Ap + end subroutine extrapolate + + + !> Calculate the CFL + subroutine get_cfl(this,dt,cfl) + use mpi_f08, only: MPI_ALLREDUCE,MPI_MAX + use parallel, only: MPI_REAL_WP + implicit none + class(lss), intent(inout) :: this + real(WP), intent(in) :: dt + real(WP), intent(out) :: cfl + integer :: i,ierr + real(WP) :: my_CFLp_x,my_CFLp_y,my_CFLp_z,kk,mu,a + + ! Set the CFLs to zero + my_CFLp_x=0.0_WP; my_CFLp_y=0.0_WP; my_CFLp_z=0.0_WP + do i=1,this%np_ + my_CFLp_x=max(my_CFLp_x,abs(this%p(i)%vel(1))*this%cfg%dxi(this%p(i)%ind(1))) + my_CFLp_y=max(my_CFLp_y,abs(this%p(i)%vel(2))*this%cfg%dyi(this%p(i)%ind(2))) + my_CFLp_z=max(my_CFLp_z,abs(this%p(i)%vel(3))*this%cfg%dzi(this%p(i)%ind(3))) + end do + my_CFLp_x=my_CFLp_x*dt; my_CFLp_y=my_CFLp_y*dt; my_CFLp_z=my_CFLp_z*dt + + ! Get the parallel max + call MPI_ALLREDUCE(my_CFLp_x,this%CFLp_x,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + call MPI_ALLREDUCE(my_CFLp_y,this%CFLp_y,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + call MPI_ALLREDUCE(my_CFLp_z,this%CFLp_z,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + + ! CFL based on elastic wave speed in material + kk=this%elastic_modulus/(3.0_WP-6.0_WP*this%poisson_ratio) + mu=this%elastic_modulus/(2.0_WP+2.0_WP*this%poisson_ratio) + a=sqrt((kk+4.0_WP*mu/3.0_WP)/this%rho) + this%CFLp_a=dt*a*3/this%delta + + ! Return the maximum CFL + cfl=max(this%CFLp_x,this%CFLp_y,this%CFLp_z,this%CFLp_a) + + end subroutine get_cfl + + + !> Extract various monitoring data from particle field + subroutine get_max(this) + use mpi_f08, only: MPI_ALLREDUCE,MPI_MAX,MPI_MIN,MPI_SUM + use parallel, only: MPI_REAL_WP + implicit none + class(lss), intent(inout) :: this + real(WP) :: buf,safe_np + real(WP), dimension(3) :: buf3D + integer :: i,j,k,ierr + + ! Create safe np + safe_np=real(max(this%np,1),WP) + + ! Velocity min/max/mean + this%Umin=huge(1.0_WP); this%Umax=-huge(1.0_WP); this%Umean=0.0_WP + this%Vmin=huge(1.0_WP); this%Vmax=-huge(1.0_WP); this%Vmean=0.0_WP + this%Wmin=huge(1.0_WP); this%Wmax=-huge(1.0_WP); this%Wmean=0.0_WP + this%ibmForce=0.0_WP + do i=1,this%np_ + this%Umin=min(this%Umin,this%p(i)%vel(1)); this%Umax=max(this%Umax,this%p(i)%vel(1)); this%Umean=this%Umean+this%p(i)%vel(1) + this%Vmin=min(this%Vmin,this%p(i)%vel(2)); this%Vmax=max(this%Vmax,this%p(i)%vel(2)); this%Vmean=this%Vmean+this%p(i)%vel(2) + this%Wmin=min(this%Wmin,this%p(i)%vel(3)); this%Wmax=max(this%Wmax,this%p(i)%vel(3)); this%Wmean=this%Wmean+this%p(i)%vel(3) + this%ibmForce=this%ibmForce+this%p(i)%Afluid*this%p(i)%vol*this%rho + end do + call MPI_ALLREDUCE(this%Umin ,buf,1,MPI_REAL_WP,MPI_MIN,this%cfg%comm,ierr); this%Umin =buf + call MPI_ALLREDUCE(this%Umax ,buf,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr); this%Umax =buf + call MPI_ALLREDUCE(this%Umean,buf,1,MPI_REAL_WP,MPI_SUM,this%cfg%comm,ierr); this%Umean=buf/safe_np + call MPI_ALLREDUCE(this%Vmin ,buf,1,MPI_REAL_WP,MPI_MIN,this%cfg%comm,ierr); this%Vmin =buf + call MPI_ALLREDUCE(this%Vmax ,buf,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr); this%Vmax =buf + call MPI_ALLREDUCE(this%Vmean,buf,1,MPI_REAL_WP,MPI_SUM,this%cfg%comm,ierr); this%Vmean=buf/safe_np + call MPI_ALLREDUCE(this%Wmin ,buf,1,MPI_REAL_WP,MPI_MIN,this%cfg%comm,ierr); this%Wmin =buf + call MPI_ALLREDUCE(this%Wmax ,buf,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr); this%Wmax =buf + call MPI_ALLREDUCE(this%Wmean,buf,1,MPI_REAL_WP,MPI_SUM,this%cfg%comm,ierr); this%Wmean=buf/safe_np + call MPI_ALLREDUCE(this%ibmForce,buf3D,3,MPI_REAL_WP,MPI_SUM,this%cfg%comm,ierr); this%ibmForce=buf3D + + ! Get max volume fraction + this%VFmax =-huge(1.0_WP) + do k=this%cfg%kmin_,this%cfg%kmax_ + do j=this%cfg%jmin_,this%cfg%jmax_ + do i=this%cfg%imin_,this%cfg%imax_ + this%VFmax=max(this%VFmax,this%VF(i,j,k)) + end do + end do + end do + call MPI_ALLREDUCE(this%VFmax,buf,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr); this%VFmax=buf + + end subroutine get_max + + + !> Update particle mesh using our current particles + subroutine update_partmesh(this,pmesh) + use partmesh_class, only: partmesh + implicit none + class(lss), intent(inout) :: this + class(partmesh), intent(inout) :: pmesh + integer :: i + ! Reset particle mesh storage + call pmesh%reset() + ! Nothing else to do if no particle is present + if (this%np_.eq.0) return + ! Copy particle info + call pmesh%set_size(this%np_) + do i=1,this%np_ + pmesh%pos(:,i)=this%p(i)%pos + end do + end subroutine update_partmesh + + + !> Creation of the MPI datatype for particle + subroutine prepare_mpi_part() + use mpi_f08 + use messager, only: die + implicit none + integer(MPI_ADDRESS_KIND), dimension(part_nblock) :: disp + integer(MPI_ADDRESS_KIND) :: lb,extent + type(MPI_Datatype) :: MPI_PART_TMP + integer :: i,mysize,ierr + ! Prepare the displacement array + disp(1)=0 + do i=2,part_nblock + call MPI_Type_size(part_tblock(i-1),mysize,ierr) + disp(i)=disp(i-1)+int(mysize,MPI_ADDRESS_KIND)*int(part_lblock(i-1),MPI_ADDRESS_KIND) + end do + ! Create and commit the new type + call MPI_Type_create_struct(part_nblock,part_lblock,disp,part_tblock,MPI_PART_TMP,ierr) + call MPI_Type_get_extent(MPI_PART_TMP,lb,extent,ierr) + call MPI_Type_create_resized(MPI_PART_TMP,lb,extent,MPI_PART,ierr) + call MPI_Type_commit(MPI_PART,ierr) + ! If a problem was encountered, say it + if (ierr.ne.0) call die('[lss prepare_mpi_part] MPI Particle type creation failed') + ! Get the size of this type + call MPI_type_size(MPI_PART,MPI_PART_SIZE,ierr) + end subroutine prepare_mpi_part + + + !> Share particles across processor boundaries + subroutine share(this,nover) + use mpi_f08 + use messager, only: warn,die + implicit none + class(lss), intent(inout) :: this + integer, optional :: nover + type(part), dimension(:), allocatable :: tosend + type(part), dimension(:), allocatable :: torecv + integer :: no,nsend,nrecv + type(MPI_Status) :: status + integer :: icnt,isrc,idst,ierr + integer :: i,n + + ! Check overlap size + if (present(nover)) then + no=nover + if (no.gt.this%cfg%no) then + call warn('[lss share] Specified overlap is larger than that of cfg - reducing no') + no=this%cfg%no + else if (no.le.0) then + call die('[lss share] Specified overlap cannot be less or equal to zero') + end if + else + no=1 + end if + + ! Clean up ghost array + call this%resize_ghost(n=0); this%ng_=0 + + ! Share ghost particles in -x (no ghosts are sent here) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(1).lt.this%cfg%imin_+no) nsend=nsend+1 + end do + allocate(tosend(nsend)) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(1).lt.this%cfg%imin_+no) then + nsend=nsend+1 + tosend(nsend)=this%p(n) + if (this%cfg%xper.and.tosend(nsend)%ind(1).lt.this%cfg%imin+no) then + tosend(nsend)%pos(1)=tosend(nsend)%pos(1)+this%cfg%xL + tosend(nsend)%ind(1)=tosend(nsend)%ind(1)+this%cfg%nx + end if + end if + end do + nrecv=0 + call MPI_CART_SHIFT(this%cfg%comm,0,-1,isrc,idst,ierr) + call MPI_SENDRECV(nsend,1,MPI_INTEGER,idst,0,nrecv,1,MPI_INTEGER,isrc,0,this%cfg%comm,status,ierr) + allocate(torecv(nrecv)) + call MPI_SENDRECV(tosend,nsend,MPI_PART,idst,0,torecv,nrecv,MPI_PART,isrc,0,this%cfg%comm,status,ierr) + call this%resize_ghost(this%ng_+nrecv) + this%g(this%ng_+1:this%ng_+nrecv)=torecv + this%ng_=this%ng_+nrecv + if (allocated(tosend)) deallocate(tosend) + if (allocated(torecv)) deallocate(torecv) + + ! Share ghost particles in +x (no ghosts are sent here) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(1).gt.this%cfg%imax_-no) nsend=nsend+1 + end do + allocate(tosend(nsend)) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(1).gt.this%cfg%imax_-no) then + nsend=nsend+1 + tosend(nsend)=this%p(n) + if (this%cfg%xper.and.tosend(nsend)%ind(1).gt.this%cfg%imax-no) then + tosend(nsend)%pos(1)=tosend(nsend)%pos(1)-this%cfg%xL + tosend(nsend)%ind(1)=tosend(nsend)%ind(1)-this%cfg%nx + end if + end if + end do + nrecv=0 + call MPI_CART_SHIFT(this%cfg%comm,0,+1,isrc,idst,ierr) + call MPI_SENDRECV(nsend,1,MPI_INTEGER,idst,0,nrecv,1,MPI_INTEGER,isrc,0,this%cfg%comm,status,ierr) + allocate(torecv(nrecv)) + call MPI_SENDRECV(tosend,nsend,MPI_PART,idst,0,torecv,nrecv,MPI_PART,isrc,0,this%cfg%comm,status,ierr) + call this%resize_ghost(this%ng_+nrecv) + this%g(this%ng_+1:this%ng_+nrecv)=torecv + this%ng_=this%ng_+nrecv + if (allocated(tosend)) deallocate(tosend) + if (allocated(torecv)) deallocate(torecv) + + ! Share ghost particles in -y (ghosts need to be sent now) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(2).lt.this%cfg%jmin_+no) nsend=nsend+1 + end do + do n=1,this%ng_ + if (this%g(n)%ind(2).lt.this%cfg%jmin_+no) nsend=nsend+1 + end do + allocate(tosend(nsend)) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(2).lt.this%cfg%jmin_+no) then + nsend=nsend+1 + tosend(nsend)=this%p(n) + if (this%cfg%yper.and.tosend(nsend)%ind(2).lt.this%cfg%jmin+no) then + tosend(nsend)%pos(2)=tosend(nsend)%pos(2)+this%cfg%yL + tosend(nsend)%ind(2)=tosend(nsend)%ind(2)+this%cfg%ny + end if + end if + end do + do n=1,this%ng_ + if (this%g(n)%ind(2).lt.this%cfg%jmin_+no) then + nsend=nsend+1 + tosend(nsend)=this%g(n) + if (this%cfg%yper.and.tosend(nsend)%ind(2).lt.this%cfg%jmin+no) then + tosend(nsend)%pos(2)=tosend(nsend)%pos(2)+this%cfg%yL + tosend(nsend)%ind(2)=tosend(nsend)%ind(2)+this%cfg%ny + end if + end if + end do + nrecv=0 + call MPI_CART_SHIFT(this%cfg%comm,1,-1,isrc,idst,ierr) + call MPI_SENDRECV(nsend,1,MPI_INTEGER,idst,0,nrecv,1,MPI_INTEGER,isrc,0,this%cfg%comm,status,ierr) + allocate(torecv(nrecv)) + call MPI_SENDRECV(tosend,nsend,MPI_PART,idst,0,torecv,nrecv,MPI_PART,isrc,0,this%cfg%comm,status,ierr) + call this%resize_ghost(this%ng_+nrecv) + this%g(this%ng_+1:this%ng_+nrecv)=torecv + this%ng_=this%ng_+nrecv + if (allocated(tosend)) deallocate(tosend) + if (allocated(torecv)) deallocate(torecv) + + ! Share ghost particles in +y (ghosts need to be sent now - but not newly received ghosts!) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(2).gt.this%cfg%jmax_-no) nsend=nsend+1 + end do + do n=1,this%ng_-nrecv + if (this%g(n)%ind(2).gt.this%cfg%jmax_-no) nsend=nsend+1 + end do + allocate(tosend(nsend)) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(2).gt.this%cfg%jmax_-no) then + nsend=nsend+1 + tosend(nsend)=this%p(n) + if (this%cfg%yper.and.tosend(nsend)%ind(2).gt.this%cfg%jmax-no) then + tosend(nsend)%pos(2)=tosend(nsend)%pos(2)-this%cfg%yL + tosend(nsend)%ind(2)=tosend(nsend)%ind(2)-this%cfg%ny + end if + end if + end do + do n=1,this%ng_-nrecv + if (this%g(n)%ind(2).gt.this%cfg%jmax_-no) then + nsend=nsend+1 + tosend(nsend)=this%g(n) + if (this%cfg%yper.and.tosend(nsend)%ind(2).gt.this%cfg%jmax-no) then + tosend(nsend)%pos(2)=tosend(nsend)%pos(2)-this%cfg%yL + tosend(nsend)%ind(2)=tosend(nsend)%ind(2)-this%cfg%ny + end if + end if + end do + nrecv=0 + call MPI_CART_SHIFT(this%cfg%comm,1,+1,isrc,idst,ierr) + call MPI_SENDRECV(nsend,1,MPI_INTEGER,idst,0,nrecv,1,MPI_INTEGER,isrc,0,this%cfg%comm,status,ierr) + allocate(torecv(nrecv)) + call MPI_SENDRECV(tosend,nsend,MPI_PART,idst,0,torecv,nrecv,MPI_PART,isrc,0,this%cfg%comm,status,ierr) + call this%resize_ghost(this%ng_+nrecv) + this%g(this%ng_+1:this%ng_+nrecv)=torecv + this%ng_=this%ng_+nrecv + if (allocated(tosend)) deallocate(tosend) + if (allocated(torecv)) deallocate(torecv) + + ! Share ghost particles in -z (ghosts need to be sent now) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(3).lt.this%cfg%kmin_+no) nsend=nsend+1 + end do + do n=1,this%ng_ + if (this%g(n)%ind(3).lt.this%cfg%kmin_+no) nsend=nsend+1 + end do + allocate(tosend(nsend)) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(3).lt.this%cfg%kmin_+no) then + nsend=nsend+1 + tosend(nsend)=this%p(n) + if (this%cfg%zper.and.tosend(nsend)%ind(3).lt.this%cfg%kmin+no) then + tosend(nsend)%pos(3)=tosend(nsend)%pos(3)+this%cfg%zL + tosend(nsend)%ind(3)=tosend(nsend)%ind(3)+this%cfg%nz + end if + end if + end do + do n=1,this%ng_ + if (this%g(n)%ind(3).lt.this%cfg%kmin_+no) then + nsend=nsend+1 + tosend(nsend)=this%g(n) + if (this%cfg%zper.and.tosend(nsend)%ind(3).lt.this%cfg%kmin+no) then + tosend(nsend)%pos(3)=tosend(nsend)%pos(3)+this%cfg%zL + tosend(nsend)%ind(3)=tosend(nsend)%ind(3)+this%cfg%nz + end if + end if + end do + nrecv=0 + call MPI_CART_SHIFT(this%cfg%comm,2,-1,isrc,idst,ierr) + call MPI_SENDRECV(nsend,1,MPI_INTEGER,idst,0,nrecv,1,MPI_INTEGER,isrc,0,this%cfg%comm,status,ierr) + allocate(torecv(nrecv)) + call MPI_SENDRECV(tosend,nsend,MPI_PART,idst,0,torecv,nrecv,MPI_PART,isrc,0,this%cfg%comm,status,ierr) + call this%resize_ghost(this%ng_+nrecv) + this%g(this%ng_+1:this%ng_+nrecv)=torecv + this%ng_=this%ng_+nrecv + if (allocated(tosend)) deallocate(tosend) + if (allocated(torecv)) deallocate(torecv) + + ! Share ghost particles in +z (ghosts need to be sent now - but not newly received ghosts!) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(3).gt.this%cfg%kmax_-no) nsend=nsend+1 + end do + do n=1,this%ng_-nrecv + if (this%g(n)%ind(3).gt.this%cfg%kmax_-no) nsend=nsend+1 + end do + allocate(tosend(nsend)) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(3).gt.this%cfg%kmax_-no) then + nsend=nsend+1 + tosend(nsend)=this%p(n) + if (this%cfg%zper.and.tosend(nsend)%ind(3).gt.this%cfg%kmax-no) then + tosend(nsend)%pos(3)=tosend(nsend)%pos(3)-this%cfg%zL + tosend(nsend)%ind(3)=tosend(nsend)%ind(3)-this%cfg%nz + end if + end if + end do + do n=1,this%ng_-nrecv + if (this%g(n)%ind(3).gt.this%cfg%kmax_-no) then + nsend=nsend+1 + tosend(nsend)=this%g(n) + if (this%cfg%zper.and.tosend(nsend)%ind(3).gt.this%cfg%kmax-no) then + tosend(nsend)%pos(3)=tosend(nsend)%pos(3)-this%cfg%zL + tosend(nsend)%ind(3)=tosend(nsend)%ind(3)-this%cfg%nz + end if + end if + end do + nrecv=0 + call MPI_CART_SHIFT(this%cfg%comm,2,+1,isrc,idst,ierr) + call MPI_SENDRECV(nsend,1,MPI_INTEGER,idst,0,nrecv,1,MPI_INTEGER,isrc,0,this%cfg%comm,status,ierr) + allocate(torecv(nrecv)) + call MPI_SENDRECV(tosend,nsend,MPI_PART,idst,0,torecv,nrecv,MPI_PART,isrc,0,this%cfg%comm,status,ierr) + call this%resize_ghost(this%ng_+nrecv) + this%g(this%ng_+1:this%ng_+nrecv)=torecv + this%ng_=this%ng_+nrecv + if (allocated(tosend)) deallocate(tosend) + if (allocated(torecv)) deallocate(torecv) + + end subroutine share + + + !> Synchronize particle arrays across processors + subroutine sync(this) + use mpi_f08 + implicit none + class(lss), intent(inout) :: this + integer, dimension(0:this%cfg%nproc-1) :: nsend_proc,nrecv_proc + integer, dimension(0:this%cfg%nproc-1) :: nsend_disp,nrecv_disp + integer :: n,prank,ierr + type(part), dimension(:), allocatable :: buf_send + ! Recycle first to minimize communication load + call this%recycle() + ! Prepare information about what to send + nsend_proc=0 + do n=1,this%np_ + prank=this%cfg%get_rank(this%p(n)%ind) + nsend_proc(prank)=nsend_proc(prank)+1 + end do + nsend_proc(this%cfg%rank)=0 + ! Inform processors of what they will receive + call MPI_ALLtoALL(nsend_proc,1,MPI_INTEGER,nrecv_proc,1,MPI_INTEGER,this%cfg%comm,ierr) + ! Prepare displacements for all-to-all + nsend_disp(0)=0 + nrecv_disp(0)=this%np_ !< Directly add particles at the end of main array + do n=1,this%cfg%nproc-1 + nsend_disp(n)=nsend_disp(n-1)+nsend_proc(n-1) + nrecv_disp(n)=nrecv_disp(n-1)+nrecv_proc(n-1) + end do + ! Allocate buffer to send particles + allocate(buf_send(sum(nsend_proc))) + ! Pack the particles in the send buffer + nsend_proc=0 + do n=1,this%np_ + ! Get the rank + prank=this%cfg%get_rank(this%p(n)%ind) + ! Skip particles still inside + if (prank.eq.this%cfg%rank) cycle + ! Pack up for sending + nsend_proc(prank)=nsend_proc(prank)+1 + buf_send(nsend_disp(prank)+nsend_proc(prank))=this%p(n) + ! Flag particle for removal + this%p(n)%flag=1 + end do + ! Allocate buffer for receiving particles + call this%resize(this%np_+sum(nrecv_proc)) + ! Perform communication + call MPI_ALLtoALLv(buf_send,nsend_proc,nsend_disp,MPI_PART,this%p,nrecv_proc,nrecv_disp,MPI_PART,this%cfg%comm,ierr) + ! Deallocate buffer + deallocate(buf_send) + ! Recycle to remove duplicate particles + call this%recycle() + end subroutine sync + + + !> Adaptation of particle array size + subroutine resize(this,n) + implicit none + class(lss), intent(inout) :: this + integer, intent(in) :: n + type(part), dimension(:), allocatable :: tmp + integer :: size_now,size_new + ! Resize particle array to size n + if (.not.allocated(this%p)) then + ! Allocate directly to size n + allocate(this%p(n)) + this%p(1:n)%flag=1 + else + ! Update from a non-zero size to another non-zero size + size_now=size(this%p,dim=1) + if (n.gt.size_now) then + size_new=max(n,int(real(size_now,WP)*coeff_up)) + allocate(tmp(size_new)) + tmp(1:size_now)=this%p + tmp(size_now+1:)%flag=1 + call move_alloc(tmp,this%p) + else if (n.lt.int(real(size_now,WP)*coeff_dn)) then + allocate(tmp(n)) + tmp(1:n)=this%p(1:n) + call move_alloc(tmp,this%p) + end if + end if + end subroutine resize + + + !> Adaptation of ghost array size + subroutine resize_ghost(this,n) + implicit none + class(lss), intent(inout) :: this + integer, intent(in) :: n + type(part), dimension(:), allocatable :: tmp + integer :: size_now,size_new + ! Resize ghost array to size n + if (.not.allocated(this%g)) then + ! Allocate directly to size n + allocate(this%g(n)) + this%g(1:n)%flag=1 + else + ! Update from a non-zero size to another non-zero size + size_now=size(this%g,dim=1) + if (n.gt.size_now) then + size_new=max(n,int(real(size_now,WP)*coeff_up)) + allocate(tmp(size_new)) + tmp(1:size_now)=this%g + tmp(size_now+1:)%flag=1 + call move_alloc(tmp,this%g) + else if (n.lt.int(real(size_now,WP)*coeff_dn)) then + allocate(tmp(n)) + tmp(1:n)=this%g(1:n) + call move_alloc(tmp,this%g) + end if + end if + end subroutine resize_ghost + + + !> Clean-up of particle array by removing flag=1 particles + subroutine recycle(this) + implicit none + class(lss), intent(inout) :: this + integer :: new_size,i,ierr + ! Compact all active particles at the beginning of the array + new_size=0 + if (allocated(this%p)) then + do i=1,size(this%p,dim=1) + if (this%p(i)%flag.ne.1) then + new_size=new_size+1 + if (i.ne.new_size) then + this%p(new_size)=this%p(i) + this%p(i)%flag=1 + end if + end if + end do + end if + ! Resize to new size + call this%resize(new_size) + ! Update number of particles + this%np_=new_size + call MPI_ALLGATHER(this%np_,1,MPI_INTEGER,this%np_proc,1,MPI_INTEGER,this%cfg%comm,ierr) + this%np=sum(this%np_proc) + end subroutine recycle + + + !> Parallel write particles to file + subroutine write(this,filename) + use mpi_f08 + use messager, only: die + use parallel, only: info_mpiio + implicit none + class(lss), intent(inout) :: this + character(len=*), intent(in) :: filename + type(MPI_File) :: ifile + type(MPI_Status):: status + integer(kind=MPI_OFFSET_KIND) :: offset + integer :: i,ierr,iunit + + ! Root serial-writes the file header + if (this%cfg%amRoot) then + ! Open the file + open(newunit=iunit,file=trim(filename),form='unformatted',status='replace',access='stream',iostat=ierr) + if (ierr.ne.0) call die('[lss write] Problem encountered while serial-opening data file: '//trim(filename)) + ! Number of particles and particle object size + write(iunit) this%np,MPI_PART_SIZE + ! Done with the header + close(iunit) + end if + + ! The rest is done in parallel + call MPI_FILE_OPEN(this%cfg%comm,trim(filename),IOR(MPI_MODE_WRONLY,MPI_MODE_APPEND),info_mpiio,ifile,ierr) + if (ierr.ne.0) call die('[lss write] Problem encountered while parallel-opening data file: '//trim(filename)) + + ! Get current position + call MPI_FILE_GET_POSITION(ifile,offset,ierr) + + ! Compute the offset and write + do i=1,this%cfg%rank + offset=offset+int(this%np_proc(i),MPI_OFFSET_KIND)*int(MPI_PART_SIZE,MPI_OFFSET_KIND) + end do + if (this%np_.gt.0) call MPI_FILE_WRITE_AT(ifile,offset,this%p,this%np_,MPI_PART,status,ierr) + + ! Close the file + call MPI_FILE_CLOSE(ifile,ierr) + + ! Log/screen output + logging: block + use, intrinsic :: iso_fortran_env, only: output_unit + use param, only: verbose + use messager, only: log + use string, only: str_long + character(len=str_long) :: message + if (this%cfg%amRoot) then + write(message,'("[lss write] Wrote ",i0," particles to file [",a,"] on partitioned grid [",a,"]")') this%np,trim(filename),trim(this%cfg%name) + if (verbose.gt.2) write(output_unit,'(a)') trim(message) + if (verbose.gt.1) call log(message) + end if + end block logging + + end subroutine write + + + !> Parallel read particles to file + subroutine read(this,filename) + use mpi_f08 + use messager, only: die + use parallel, only: info_mpiio + implicit none + class(lss), intent(inout) :: this + character(len=*), intent(in) :: filename + type(MPI_File) :: ifile + type(MPI_Status):: status + integer(kind=MPI_OFFSET_KIND) :: offset,header_offset + integer :: i,j,ierr,npadd,psize,nchunk,cnt + integer, dimension(:,:), allocatable :: ppp + + ! First open the file in parallel + call MPI_FILE_OPEN(this%cfg%comm,trim(filename),MPI_MODE_RDONLY,info_mpiio,ifile,ierr) + if (ierr.ne.0) call die('[lss read] Problem encountered while reading data file: '//trim(filename)) + + ! Read file header first + call MPI_FILE_READ_ALL(ifile,npadd,1,MPI_INTEGER,status,ierr) + call MPI_FILE_READ_ALL(ifile,psize,1,MPI_INTEGER,status,ierr) + + ! Remember current position + call MPI_FILE_GET_POSITION(ifile,header_offset,ierr) + + ! Check compatibility of particle type + if (psize.ne.MPI_PART_SIZE) call die('[lss read] Particle type unreadable') + + ! Naively share reading task among all processors + nchunk=int(npadd/(this%cfg%nproc*part_chunk_size))+1 + allocate(ppp(this%cfg%nproc,nchunk)) + ppp=int(npadd/(this%cfg%nproc*nchunk)) + cnt=0 + out:do j=1,nchunk + do i=1,this%cfg%nproc + cnt=cnt+1 + if (cnt.gt.mod(npadd,this%cfg%nproc*nchunk)) exit out + ppp(i,j)=ppp(i,j)+1 + end do + end do out + + ! Read by chunk + do j=1,nchunk + ! Find offset + offset=header_offset+int(MPI_PART_SIZE,MPI_OFFSET_KIND)*int(sum(ppp(1:this%cfg%rank,:))+sum(ppp(this%cfg%rank+1,1:j-1)),MPI_OFFSET_KIND) + ! Resize particle array + call this%resize(this%np_+ppp(this%cfg%rank+1,j)) + ! Read this file + call MPI_FILE_READ_AT(ifile,offset,this%p(this%np_+1:this%np_+ppp(this%cfg%rank+1,j)),ppp(this%cfg%rank+1,j),MPI_PART,status,ierr) + ! Most general case: relocate every droplet + do i=this%np_+1,this%np_+ppp(this%cfg%rank+1,j) + this%p(i)%ind=this%cfg%get_ijk_global(this%p(i)%pos,this%p(i)%ind) + end do + ! Exchange all that + call this%sync() + end do + + ! Close the file + call MPI_FILE_CLOSE(ifile,ierr) + + ! Log/screen output + logging: block + use, intrinsic :: iso_fortran_env, only: output_unit + use param, only: verbose + use messager, only: log + use string, only: str_long + character(len=str_long) :: message + if (this%cfg%amRoot) then + write(message,'("[lss read] Read ",i0," particles from file [",a,"] on partitioned grid [",a,"]")') npadd,trim(filename),trim(this%cfg%name) + if (verbose.gt.2) write(output_unit,'(a)') trim(message) + if (verbose.gt.1) call log(message) + end if + end block logging + + end subroutine read + + +end module lss_class diff --git a/examples/beam_test/src/lss_class_working.f90 b/examples/beam_test/src/lss_class_working.f90 new file mode 100644 index 000000000..1650239f7 --- /dev/null +++ b/examples/beam_test/src/lss_class_working.f90 @@ -0,0 +1,1637 @@ +!> Lagrangian solid solver object +!> Implements peridynamics equations +module lss_class + use precision, only: WP + use string, only: str_medium + use config_class, only: config + use mpi_f08, only: MPI_Datatype,MPI_INTEGER8,MPI_INTEGER,MPI_DOUBLE_PRECISION + implicit none + private + + + ! Expose type/constructor/methods + public :: lss + + + !> Memory adaptation parameter + real(WP), parameter :: coeff_up=1.3_WP !< Particle array size increase factor + real(WP), parameter :: coeff_dn=0.7_WP !< Particle array size decrease factor + + + !> I/O chunk size to read at a time + integer, parameter :: part_chunk_size=1000 !< Read 1000 particles at a time before redistributing + + + !> Maximum number of bonds per particle + integer, parameter, public :: max_bond=400 !< Assumes something like a 7x7x7 stencil in 3D + + + !> Bonded solid particle definition + type :: part + !> MPI_DOUBLE_PRECISION data + real(WP) :: mw !< Weighted volume + real(WP) :: dil !< Element dilatation + real(WP) :: ste !< Element dilatation + real(WP) :: vol !< Particle volume + real(WP), dimension(max_bond) :: dbond !< Length of initial bonds + real(WP), dimension(3) :: pos !< Particle center coordinates + real(WP), dimension(3) :: vel !< Velocity of particle + real(WP), dimension(3) :: Abond !< Bond acceleration for particle + real(WP), dimension(3) :: Afluid !< Fluid acceleration for particle + real(WP), dimension(3) :: gd !< Dilitation corrections + real(WP), dimension(3) :: gb !< Shear corrections + !> MPI_INTEGER data + integer :: id !< ID the object is associated with + integer :: i !< Unique index of particle (assumed >0) + integer :: nbond !< Number of initial bonds + integer, dimension(max_bond) :: ibond !< Indices of initially bonded particles (0 values ignored) + integer , dimension(3) :: ind !< Index of cell containing particle center + integer :: flag !< Control parameter (0=normal, 1=done->will be removed) + end type part + !> Number of blocks, block length, and block types in a particle + integer, parameter :: part_nblock=2 + integer , dimension(part_nblock) :: part_lblock=[22+max_bond,7+max_bond] + type(MPI_Datatype), dimension(part_nblock) :: part_tblock=[MPI_DOUBLE_PRECISION,MPI_INTEGER] + !> MPI_PART derived datatype and size + type(MPI_Datatype) :: MPI_PART + integer :: MPI_PART_SIZE + + + !> Lagrangian solid solver object definition + type :: lss + + ! This config is used for parallelization and for calculating bond/collision forces + class(config), pointer :: cfg + + ! This is the name of the solver + character(len=str_medium) :: name='UNNAMED_LSS' + + ! Solid material properties + real(WP) :: elastic_modulus !< Elastic modulus of the material + real(WP) :: poisson_ratio !< Poisson's ratio of the material + real(WP) :: rho !< Density of the material + real(WP) :: crit_energy !< Critical energy release + + ! Bonding parameters + real(WP) :: delta !< Bonding horizon (distance) + real(WP) :: min_dist !< Minimum bonding distance + integer :: nb !< Cell-based horizon + + ! Global and local particle data + integer :: np !< Global number of particles + integer :: np_ !< Local number of particles + integer, dimension(:), allocatable :: np_proc !< Number of particles on each processor + type(part), dimension(:), allocatable :: p !< Array of particles of type part + + ! Overlap particle (i.e., ghost) data + integer :: ng_ !< Local number of ghosts + type(part), dimension(:), allocatable :: g !< Array of ghosts of type part + + ! Gravitational acceleration + real(WP), dimension(3) :: gravity=[0.0_WP,0.0_WP,0.0_WP] + + ! Solid volume fraction and momentum + real(WP), dimension(:,:,:), allocatable :: VF !< Volume fraction, cell-centered + real(WP), dimension(:,:,:), allocatable :: VFU !< Solid velocity, U-face + real(WP), dimension(:,:,:), allocatable :: VFV !< Solid velocity, V-face + real(WP), dimension(:,:,:), allocatable :: VFW !< Solid velocity, W-face + + ! CFL numbers + real(WP) :: CFLp_x,CFLp_y,CFLp_z,CFLp_a + + ! Number of substeps for time integrator + real(WP) :: nstep=1 + + ! Monitoring info + real(WP) :: Umin,Umax,Umean !< U velocity info + real(WP) :: Vmin,Vmax,Vmean !< V velocity info + real(WP) :: Wmin,Wmax,Wmean !< W velocity info + real(WP) :: VFmax !< Volume fraction info + real(WP), dimension(3) :: ibmForce !< Total force due to IBM + integer :: np_out !< Number of particles leaving the domain + + contains + procedure :: bond_init !< Setup initial interparticle bonds + procedure :: get_bond_force !< Compute interparticle bond force + procedure :: advance !< Step forward the particle ODEs + procedure :: get_cfl !< Calculate maximum CFL + procedure :: get_max !< Extract various monitoring data + procedure :: update_partmesh !< Update a partmesh object using current particles + procedure :: share !< Share particles across interprocessor boundaries + procedure :: sync !< Synchronize particles across interprocessor boundaries + procedure :: resize !< Resize particle array to given size + procedure :: resize_ghost !< Resize ghost array to given size + procedure :: recycle !< Recycle particle array by removing flagged particles + procedure :: write !< Parallel write particles to file + procedure :: read !< Parallel read particles from file + procedure :: update_VF !< Compute volume fraction + procedure :: get_delta !< Compute regularized delta function + procedure :: interpolate !< Interpolation routine from mesh=>marker + procedure :: extrapolate !< Extrapolation routine from marker=>mesh + procedure :: stretch + end type lss + + + !> Declare lss constructor + interface lss + procedure constructor + end interface lss + +contains + + + ! Quasi-Gaussian weighting function - h is the cut-off + real(WP) function wgauss(d,h) + implicit none + real(WP), intent(in) :: d,h + real(WP), parameter :: coeff=2.6_WP + real(WP) :: hh + hh=coeff*h + if (d.ge.hh) then + wgauss=0.0_WP + else + wgauss=(1.0_WP+4.0_WP*d/hh)*(1.0_WP-d/hh)**4 + end if + end function wgauss + + + !> Default constructor for Lagrangian solid solver + function constructor(cfg,name) result(self) + implicit none + type(lss) :: self + class(config), target, intent(in) :: cfg + character(len=*), optional :: name + integer :: i,j,k + + ! Set the name for the solver + if (present(name)) self%name=trim(adjustl(name)) + + ! Point to pgrid object + self%cfg=>cfg + + ! Set default bonding horizon based on underlying mesh + self%delta=self%cfg%min_meshsize + self%nb=1 + self%min_dist=huge(1.0_WP) + + ! Allocate variables + allocate(self%np_proc(1:self%cfg%nproc)); self%np_proc=0 + self%np_=0; self%np=0 + call self%resize(0) + + ! Initialize MPI derived datatype for a particle + call prepare_mpi_part() + + ! Allocate VF array on cfg mesh + allocate(self%VF(self%cfg%imino_:self%cfg%imaxo_,self%cfg%jmino_:self%cfg%jmaxo_,self%cfg%kmino_:self%cfg%kmaxo_)); self%VF=0.0_WP + allocate(self%VFU(self%cfg%imino_:self%cfg%imaxo_,self%cfg%jmino_:self%cfg%jmaxo_,self%cfg%kmino_:self%cfg%kmaxo_)); self%VFU=0.0_WP + allocate(self%VFV(self%cfg%imino_:self%cfg%imaxo_,self%cfg%jmino_:self%cfg%jmaxo_,self%cfg%kmino_:self%cfg%kmaxo_)); self%VFV=0.0_WP + allocate(self%VFW(self%cfg%imino_:self%cfg%imaxo_,self%cfg%jmino_:self%cfg%jmaxo_,self%cfg%kmino_:self%cfg%kmaxo_)); self%VFW=0.0_WP + + ! Log/screen output + logging: block + use, intrinsic :: iso_fortran_env, only: output_unit + use param, only: verbose + use messager, only: log + use string, only: str_long + character(len=str_long) :: message + if (self%cfg%amRoot) then + write(message,'("LSS object [",a,"] on partitioned grid [",a,"]")') trim(self%name),trim(self%cfg%name) + if (verbose.gt.1) write(output_unit,'(a)') trim(message) + if (verbose.gt.0) call log(message) + end if + end block logging + + end function constructor + + + !> Initialize bond force between particles + subroutine bond_init(this) + use messager, only: die + implicit none + class(lss), intent(inout) :: this + integer, dimension(:,:,:), allocatable :: npic !< Number of particle in cell + integer, dimension(:,:,:,:), allocatable :: ipic !< Index of particle in cell + + ! Communicate particles in ghost cells + call this%share() + + ! We can now assemble particle-in-cell information + pic_prep: block + use mpi_f08 + integer :: i,ip,jp,kp,ierr + integer :: mymax_npic,max_npic + + ! Allocate number of particle in cell + allocate(npic(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)); npic=0 + + ! Count particles and ghosts per cell + do i=1,this%np_ + ip=this%p(i)%ind(1); jp=this%p(i)%ind(2); kp=this%p(i)%ind(3) + npic(ip,jp,kp)=npic(ip,jp,kp)+1 + end do + do i=1,this%ng_ + ip=this%g(i)%ind(1); jp=this%g(i)%ind(2); kp=this%g(i)%ind(3) + npic(ip,jp,kp)=npic(ip,jp,kp)+1 + end do + + ! Get maximum number of particle in cell + mymax_npic=maxval(npic); call MPI_ALLREDUCE(mymax_npic,max_npic,1,MPI_INTEGER,MPI_MAX,this%cfg%comm,ierr) + + ! Allocate pic map + allocate(ipic(1:max_npic,this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)); ipic=0 + + ! Assemble pic map + npic=0 + do i=1,this%np_ + ip=this%p(i)%ind(1); jp=this%p(i)%ind(2); kp=this%p(i)%ind(3) + npic(ip,jp,kp)=npic(ip,jp,kp)+1 + ipic(npic(ip,jp,kp),ip,jp,kp)=+i + end do + do i=1,this%ng_ + ip=this%g(i)%ind(1); jp=this%g(i)%ind(2); kp=this%g(i)%ind(3) + npic(ip,jp,kp)=npic(ip,jp,kp)+1 + ipic(npic(ip,jp,kp),ip,jp,kp)=-i + end do + + end block pic_prep + + ! Establish initial bonds + create_bonds: block + use mpi_f08, only: MPI_ALLREDUCE,MPI_MIN,MPI_IN_PLACE + use parallel, only: MPI_REAL_WP + use mathtools, only: Pi + integer :: i,j,k,n1,nn,n2,ierr + type(part) :: p1,p2 + real(WP), dimension(3) :: rpos + real(WP) :: dist + ! Reset minimum bond distance + this%min_dist=huge(1.0_WP) + ! Loop over particles + do n1=1,this%np_ + ! Create copy of our particle + p1=this%p(n1) + ! Zero out weighted volume + p1%mw=0.0_WP + ! Zero out bonds + p1%ibond=0 + p1%nbond=0 + ! Loop over neighbor cells + do k=p1%ind(3)-this%nb,p1%ind(3)+this%nb + do j=p1%ind(2)-this%nb,p1%ind(2)+this%nb + do i=p1%ind(1)-this%nb,p1%ind(1)+this%nb + ! Loop over particles in that cell + do nn=1,npic(i,j,k) + ! Create copy of our neighbor + n2=ipic(nn,i,j,k) + if (n2.gt.0) then + p2=this%p(+n2) + else if (n2.lt.0) then + p2=this%g(-n2) + end if + ! Cannot self-bond + if (p1%i.eq.p2%i) cycle + ! Cannot bond with different id except <=0 (<=0 bonds with everyone) + if (p1%id.ne.p2%id.and.p1%id.ge.0.and.p2%id.ge.0) cycle + ! Check interparticle distance + rpos=p2%pos-p1%pos + dist=sqrt(dot_product(rpos,rpos)) + if (dist.lt.this%delta) then + ! This particle is in horizon, create a bond + p1%nbond=p1%nbond+1 + if (p1%nbond.gt.max_bond) call die('[lss_class bond_init] Number of detected bonds is larger than max allowed') + p1%ibond(p1%nbond)=p2%i + p1%dbond(p1%nbond)=dist + ! Increment weighted volume + p1%mw=p1%mw+wgauss(dist,this%delta)*dist**2*p1%vol + ! Determine minimum bond distance + this%min_dist=min(this%min_dist,dist) + end if + end do + end do + end do + end do + ! Zero out initial dilatation + p1%dil=0.0_WP + ! Copy back the particle + this%p(n1)=p1 + end do + ! Get global minimum + call MPI_ALLREDUCE(MPI_IN_PLACE,this%min_dist,1,MPI_REAL_WP,MPI_MIN,this%cfg%comm,ierr) + end block create_bonds + + ! Clean up + if (allocated(npic)) deallocate(npic) + if (allocated(ipic)) deallocate(ipic) + + end subroutine bond_init + + + !> Calculate bond force between particles + subroutine get_bond_force(this) + implicit none + class(lss), intent(inout) :: this + integer, dimension(:,:,:), allocatable :: npic !< Number of particle in cell + integer, dimension(:,:,:,:), allocatable :: ipic !< Index of particle in cell + logical :: is2D + + ! Need to modify parameters in 2D + is2D=this%cfg%nx.eq.1.or.this%cfg%ny.eq.1.or.this%cfg%nz.eq.1 + + ! Communicate particles in ghost cells + call this%share() + + ! We can now assemble particle-in-cell information + pic_prep: block + use mpi_f08 + integer :: i,ip,jp,kp,ierr + integer :: mymax_npic,max_npic + + ! Allocate number of particle in cell + allocate(npic(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)); npic=0 + + ! Count particles and ghosts per cell + do i=1,this%np_ + ip=this%p(i)%ind(1); jp=this%p(i)%ind(2); kp=this%p(i)%ind(3) + npic(ip,jp,kp)=npic(ip,jp,kp)+1 + end do + do i=1,this%ng_ + ip=this%g(i)%ind(1); jp=this%g(i)%ind(2); kp=this%g(i)%ind(3) + npic(ip,jp,kp)=npic(ip,jp,kp)+1 + end do + + ! Get maximum number of particle in cell + mymax_npic=maxval(npic); call MPI_ALLREDUCE(mymax_npic,max_npic,1,MPI_INTEGER,MPI_MAX,this%cfg%comm,ierr) + + ! Allocate pic map + allocate(ipic(1:max_npic,this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)); ipic=0 + + ! Assemble pic map + npic=0 + do i=1,this%np_ + ip=this%p(i)%ind(1); jp=this%p(i)%ind(2); kp=this%p(i)%ind(3) + npic(ip,jp,kp)=npic(ip,jp,kp)+1 + ipic(npic(ip,jp,kp),ip,jp,kp)=+i + end do + do i=1,this%ng_ + ip=this%g(i)%ind(1); jp=this%g(i)%ind(2); kp=this%g(i)%ind(3) + npic(ip,jp,kp)=npic(ip,jp,kp)+1 + ipic(npic(ip,jp,kp),ip,jp,kp)=-i + end do + + end block pic_prep + + ! Update weighted volume and dilatation + update_weighted_vol_and_dilatation: block + integer :: i,j,k,n1,nn,n2 + type(part) :: p1,p2 + integer :: nb,nbond + real(WP), dimension(3) :: rpos, Gd_vec + real(WP) :: dist, Gd_mag + ! Loop over particles + do n1=1,this%np_ + ! Create copy of our particle + p1=this%p(n1) + ! Zero out weighted volume and dilatation + p1%mw=0.0_WP + p1%dil=0.0_WP + ! Loop over neighbor cells + do k=p1%ind(3)-this%nb,p1%ind(3)+this%nb + do j=p1%ind(2)-this%nb,p1%ind(2)+this%nb + do i=p1%ind(1)-this%nb,p1%ind(1)+this%nb + ! Loop over particles in that cell + do nn=1,npic(i,j,k) + ! Create copy of our neighbor + n2=ipic(nn,i,j,k) + if (n2.gt.0) then + p2=this%p(+n2) + else if (n2.lt.0) then + p2=this%g(-n2) + end if + ! Check if a bond exists + do nb=1,max_bond + if (p1%ibond(nb).eq.p2%i) then + ! Increment weighted volume + p1%mw=p1%mw+wgauss(p1%dbond(nb),this%delta)*p1%dbond(nb)**2*p2%vol + ! Get current distance + rpos=p2%pos-p1%pos + dist=sqrt(dot_product(rpos,rpos)) + ! compute average G correction for dilitation + Gd_vec = (p2%gd + p1%gd)/2.0_WP + + Gd_mag = sqrt(1.0_WP/(((rpos(1)/dist)/Gd_vec(1))**2 + ((rpos(2)/dist)/Gd_vec(2))**2 + ((rpos(3)/dist)/Gd_vec(3))**2 )) + ! Increment dilatation + p1%dil=p1%dil+wgauss(p1%dbond(nb),this%delta)*p1%dbond(nb)*(dist-p1%dbond(nb))*p2%vol*Gd_mag + end if + end do + end do + end do + end do + end do + ! Rescale dilatation + if (p1%mw.gt.epsilon(1.0_WP)) then + if (is2D) then + ! 2D plane strain + p1%dil=p1%dil*2.0_WP/p1%mw + else + ! 3D + p1%dil=p1%dil*3.0_WP/p1%mw + end if + else + p1%dil=0.0_WP + end if + ! Copy back the particle + this%p(n1)=p1 + end do + end block update_weighted_vol_and_dilatation + + ! Re-communicate particles in ghost cells to update dil and mw + call this%share() + + ! Update bond force, including collision force, and SED + update_bond_force: block + use mpi_f08, only: MPI_ALLREDUCE,MPI_MIN,MPI_IN_PLACE + use parallel, only: MPI_REAL_WP + use mathtools, only: Pi + integer :: i,j,k,n1,nn,n2,ierr + type(part) :: p1,p2 + real(WP), dimension(3) :: rpos,t12,t21,Gd_vec + real(WP) :: dist,beta,alpha,ed,t,Gd_mag + real(WP) :: stretch,max_stretch,mu,kk + real(WP) :: nc,rc,kc + integer :: nb,nbond + logical :: found_bond + ! Recompute a few physical parameters + mu=this%elastic_modulus/(2.0_WP+2.0_WP*this%poisson_ratio) + kk=this%elastic_modulus/(3.0_WP-6.0_WP*this%poisson_ratio) + if (is2D) then + if (this%cfg%nx.eq.1) t=this%cfg%xL + if (this%cfg%ny.eq.1) t=this%cfg%yL + if (this%cfg%nz.eq.1) t=this%cfg%zL + max_stretch=sqrt(this%crit_energy/((6.0_WP*mu/Pi+16.0_WP/(9.0_WP*Pi**2)*(kk-2.0_WP*mu))*this%delta)) + kc=15.0_WP*48.0_WP*this%elastic_modulus/(Pi*5.0_WP*t*this%delta**3) + else + max_stretch=sqrt(this%crit_energy/((3.0_WP*mu+(kk-5.0_WP*mu/3.0_WP)*0.75_WP**4)*this%delta)) + kc=15.0_WP*12.0_WP*this%elastic_modulus/(Pi*this%delta**4) + end if + nc=1.0_WP + this%min_dist=huge(1.0_WP) + ! Loop over particles + do n1=1,this%np_ + ! Particles marked 0 do not update their forces + if (this%p(n1)%id.eq.0) cycle + ! Create copy of our particle + p1=this%p(n1) + ! Zero out bond force + p1%Abond=0.0_WP + ! Loop over neighbor cells + do k=p1%ind(3)-this%nb,p1%ind(3)+this%nb + do j=p1%ind(2)-this%nb,p1%ind(2)+this%nb + do i=p1%ind(1)-this%nb,p1%ind(1)+this%nb + ! Loop over particles in that cell + do nn=1,npic(i,j,k) + ! Create copy of our neighbor + n2=ipic(nn,i,j,k) + if (n2.gt.0) then + p2=this%p(+n2) + else if (n2.lt.0) then + p2=this%g(-n2) + end if + ! Current distance + rpos=p2%pos-p1%pos + dist=sqrt(dot_product(rpos,rpos)) + ! Check if a bond exists + found_bond=.false. + do nb=1,max_bond + if (p1%ibond(nb).eq.p2%i) then + ! Check for breakage first + stretch=(dist-p1%dbond(nb))/p1%dbond(nb) + if (stretch.gt.max_stretch) then + ! Remove the bond and flag as surface particle + p1%ibond(nb)=0 + p1%dbond(nb)=0.0_WP + cycle + end if + ! Particle 1 + if (is2D) then + ! 2D plane strain + beta = 2.0_WP * kk * p1%dil + alpha = 8.0_WP * mu / p1%mw + ed = dist - p1%dbond(nb) * (1.0_WP + p1%dil / 2.0_WP) + else + ! 3D + beta = 3.0_WP * kk * p1%dil + alpha = 15.0_WP * mu / p1%mw + ed = dist - p1%dbond(nb) * (1.0_WP + p1%dil / 3.0_WP) + end if + ! Force density 1->2 + ! t12=+wgauss(p1%dbond(nb),this%delta)*(beta/p1%mw*p1%dbond(nb)+alpha*ed)*rpos/dist + ! t12=+wgauss(p1%dbond(nb),this%delta)*((3.0_WP*kk - 15.0_WP*mu/3.0_WP)*(p1%dil*p1%dbond(nb)/p1%mw) + 15*mu*dist/p1%mw)*rpos/dist + Gd_vec = (p2%gd + p1%gd)/2.0_WP + + Gd_mag = sqrt(1.0_WP/(((rpos(1)/dist)/Gd_vec(1))**2 + ((rpos(2)/dist)/Gd_vec(2))**2 + ((rpos(3)/dist)/Gd_vec(3))**2 )) + t12=+wgauss(p1%dbond(nb),this%delta)*((3.0_WP*kk - 15.0_WP*mu/3.0_WP)*(Gd_mag*p1%dil*p1%dbond(nb)/p1%mw) + (15.0_WP*mu/p1%mw)*(dist - p1%dbond(nb)) )*rpos/dist + ! Particle 2 + if (is2D) then + ! 2D plane strain + beta = 2.0_WP * kk * p2%dil + alpha = 8.0_WP * mu / p2%mw + ed = dist - p1%dbond(nb) * (1.0_WP + p2%dil / 2.0_WP) + else + ! 3D + beta = 3.0_WP * kk * p2%dil + alpha = 15.0_WP * mu / p2%mw + ed = dist - p1%dbond(nb) * (1.0_WP + p2%dil / 3.0_WP) + end if + ! Force density 2->1 + ! t21=-wgauss(p1%dbond(nb),this%delta)*(beta/p2%mw*p1%dbond(nb)+alpha*ed)*rpos/dist + t21=-wgauss(p1%dbond(nb),this%delta)*((3.0_WP*kk - 15.0_WP*mu/3.0_WP)*(Gd_mag*p2%dil*p1%dbond(nb)/p2%mw)+ (15.0_WP*mu/p2%mw)*(dist - p1%dbond(nb)) )*rpos/dist ! Increment bond force + p1%Abond=p1%Abond+(t12-t21)*p2%vol/this%rho + ! Incremend SED + p1%ste=p1%ste+alpha/2.0_WP*(wgauss(p1%dbond(nb),this%delta)*((dist-p1%dbond(nb)))*p2%vol) + ! If still here, we have an active bond + found_bond=.true. + ! Determine minimum bond distance + this%min_dist=min(this%min_dist,dist) + cycle + end if + end do + ! Add collision force now + ! if (is2D) then + ! rc=p1%vol**(1.0_WP/2.0_WP) + ! else + ! rc=p1%vol**(1.0_WP/3.0_WP) + ! end if + ! if (.not.found_bond.and.p1%i.ne.p2%i.and.dist.lt.rc) then + ! p1%Abond=p1%Abond-max(kc*((rc/dist)**nc-1.0_WP),0.0_WP)*(rpos/dist)*p1%vol/this%rho + ! p1%flag = -2 + ! end if + end do + end do + end do + end do + ! Deal with dimensionality + if (this%cfg%nx.eq.1) p1%Abond(1)=0.0_WP + if (this%cfg%ny.eq.1) p1%Abond(2)=0.0_WP + if (this%cfg%nz.eq.1) p1%Abond(3)=0.0_WP + ! Copy back the particle + this%p(n1)=p1 + end do + ! Get global minimum + call MPI_ALLREDUCE(MPI_IN_PLACE,this%min_dist,1,MPI_REAL_WP,MPI_MIN,this%cfg%comm,ierr) + end block update_bond_force + + ! Clean up + if (allocated(npic)) deallocate(npic) + if (allocated(ipic)) deallocate(ipic) + + end subroutine get_bond_force + + + !> Advance the particle equations by a specified time step dt + !> p%id=-2 => do not solve for position nor velocity + !> p%id=-1 => do not solve for velocity + !> p%id= 0 => do not update force + + subroutine advance(this,dt)!,stress_x,stress_y,stress_z) + use mpi_f08, only : MPI_SUM,MPI_INTEGER,MPI_IN_PLACE + use mathtools, only: Pi + implicit none + class(lss), intent(inout) :: this + real(WP), intent(inout) :: dt !< Timestep size over which to advance + ! real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(inout) :: stress_x !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + ! real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(inout) :: stress_y !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + ! real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(inout) :: stress_z !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + integer :: n,ierr + ! real(WP), dimension(3) :: stress + + ! Zero out number of particles removed + this%np_out=0 + + ! Advance velocity based on old force and position based on mid-velocity + do n=1,this%np_ + ! Advance with Verlet scheme + if (this%p(n)%id.gt.-1) this%p(n)%vel=this%p(n)%vel+0.5_WP*dt*(this%gravity+this%p(n)%Abond+this%p(n)%Afluid) + if (this%p(n)%id.gt.-2) this%p(n)%pos=this%p(n)%pos+dt*this%p(n)%vel + ! Relocalize + this%p(n)%ind=this%cfg%get_ijk_global(this%p(n)%pos,this%p(n)%ind) + ! Correct the position to take into account periodicity + if (this%cfg%xper) this%p(n)%pos(1)=this%cfg%x(this%cfg%imin)+modulo(this%p(n)%pos(1)-this%cfg%x(this%cfg%imin),this%cfg%xL) + if (this%cfg%yper) this%p(n)%pos(2)=this%cfg%y(this%cfg%jmin)+modulo(this%p(n)%pos(2)-this%cfg%y(this%cfg%jmin),this%cfg%yL) + if (this%cfg%zper) this%p(n)%pos(3)=this%cfg%z(this%cfg%kmin)+modulo(this%p(n)%pos(3)-this%cfg%z(this%cfg%kmin),this%cfg%zL) + ! Handle particles that have left the domain + if (this%p(n)%pos(1).lt.this%cfg%x(this%cfg%imin).or.this%p(n)%pos(1).gt.this%cfg%x(this%cfg%imax+1)) this%p(n)%flag=1 + if (this%p(n)%pos(2).lt.this%cfg%y(this%cfg%jmin).or.this%p(n)%pos(2).gt.this%cfg%y(this%cfg%jmax+1)) this%p(n)%flag=1 + if (this%p(n)%pos(3).lt.this%cfg%z(this%cfg%kmin).or.this%p(n)%pos(3).gt.this%cfg%z(this%cfg%kmax+1)) this%p(n)%flag=1 + ! Relocalize the particle + this%p(n)%ind=this%cfg%get_ijk_global(this%p(n)%pos,this%p(n)%ind) + ! Count number of particles removed + if (this%p(n)%flag.eq.1) this%np_out=this%np_out+1 + end do + + ! Communicate particles + call this%sync() + + ! Sum up particles removed + call MPI_ALLREDUCE(this%np_out,n,1,MPI_INTEGER,MPI_SUM,this%cfg%comm,ierr); this%np_out=n + + ! Calculate bond force + call this%get_bond_force() + + ! Advance velocity only based on new force + do n=1,this%np_ + ! Advance with Verlet scheme + if (this%p(n)%id.le.-1) cycle + ! stress=this%cfg%get_velocity(pos=this%p(n)%pos,i0=this%p(n)%ind(1),j0=this%p(n)%ind(2),k0=this%p(n)%ind(3),U=stress_x,V=stress_y,W=stress_z) + ! this%p(n)%Afluid=stress/this%rho + this%p(n)%Afluid=0.0_WP + this%p(n)%vel=this%p(n)%vel+0.5_WP*dt*(this%gravity+this%p(n)%Abond+this%p(n)%Afluid) + end do + + ! Recompute volume fraction + ! call this%update_VF() + + ! Log/screen output + logging: block + use, intrinsic :: iso_fortran_env, only: output_unit + use param, only: verbose + use messager, only: log + use string, only: str_long + character(len=str_long) :: message + if (this%cfg%amRoot) then + write(message,'("Particle solver [",a,"] on partitioned grid [",a,"]: ",i0," particles were advanced")') trim(this%name),trim(this%cfg%name),this%np + if (verbose.gt.1) write(output_unit,'(a)') trim(message) + if (verbose.gt.0) call log(message) + end if + end block logging + + end subroutine advance + + subroutine stretch(this,dt)!,stress_x,stress_y,stress_z) + use mpi_f08, only : MPI_SUM,MPI_INTEGER,MPI_IN_PLACE + use mathtools, only: Pi + implicit none + class(lss), intent(inout) :: this + real(WP), intent(inout) :: dt !< Timestep size over which to advance + real(WP) :: mu + integer :: n,ierr + !======================================================================================== + ! X-Axis Stretch: + ! Zero out number of particles removed + this%np_out=0 + do n=1,this%np_ + ! Stretch the beam along the x axis with a uniform strain-rate of 0.001 + if (this%p(n)%id.gt.-2) this%p(n)%pos(1)=this%p(n)%pos(1)*1.001_WP + end do + + ! Communicate particles + call this%sync() + + ! Calculate bond force + call this%get_bond_force() + + mu=this%elastic_modulus/(2.0_WP+2.0_WP*this%poisson_ratio) + + do n=1,this%np_ + if (this%p(n)%id.gt.-2) this%p(n)%gd(1)=0.001_WP/this%p(n)%dil + end do + + !======================================================================================== + ! Y-Axis Stretch: + ! Zero out number of particles removed + this%np_out=0 + do n=1,this%np_ + ! Stretch the beam along the x axis with a uniform strain-rate of 0.001 + if (this%p(n)%id.gt.-2) this%p(n)%pos(1)=this%p(n)%pos(1)/1.001_WP + if (this%p(n)%id.gt.-2) this%p(n)%pos(2)=this%p(n)%pos(2)*1.001_WP + end do + + ! Communicate particles + call this%sync() + + ! Calculate bond force + call this%get_bond_force() + + mu=this%elastic_modulus/(2.0_WP+2.0_WP*this%poisson_ratio) + + do n=1,this%np_ + if (this%p(n)%id.gt.-2) this%p(n)%gd(2)=0.001_WP/this%p(n)%dil + end do + + !======================================================================================== + ! Z-Axis Stretch: + ! Zero out number of particles removed + this%np_out=0 + do n=1,this%np_ + ! Stretch the beam along the x axis with a uniform strain-rate of 0.001 + if (this%p(n)%id.gt.-2) this%p(n)%pos(2)=this%p(n)%pos(2)/1.001_WP + if (this%p(n)%id.gt.-2) this%p(n)%pos(3)=this%p(n)%pos(3)*1.001_WP + end do + + ! Communicate particles + call this%sync() + + ! Calculate bond force + call this%get_bond_force() + + mu=this%elastic_modulus/(2.0_WP+2.0_WP*this%poisson_ratio) + + do n=1,this%np_ + this%p(n)%gd(3)=0.001_WP/this%p(n)%dil + end do + + ! Put the particle back where it was + do n=1,this%np_ + if (this%p(n)%id.gt.-2) this%p(n)%pos(3)=this%p(n)%pos(3)/1.001_WP + end do + + !====================================================================================== + + ! Now stretch particle for the first time step + + do n=1,this%np_ + ! Stretch the beam along the x axis with a uniform strain-rate of 0.001 + if (this%p(n)%id.gt.-2) this%p(n)%pos(1)=this%p(n)%pos(1)*1.001_WP + end do + + ! Communicate particles + call this%sync() + + ! Calculate bond force + call this%get_bond_force() + + + + + end subroutine stretch + + subroutine get_correction_coeffs(this,dt)!,stress_x,stress_y,stress_z) + use mpi_f08, only : MPI_SUM,MPI_INTEGER,MPI_IN_PLACE + use mathtools, only: Pi + implicit none + class(lss), intent(inout) :: this + real(WP), intent(inout) :: dt !< Timestep size over which to advance + real(WP) :: mu + integer :: n,ierr + ! Zero out number of particles removed + this%np_out=0 + do n=1,this%np_ + ! Stretch the beam along the x axis with a uniform strain-rate of 0.001 + if (this%p(n)%id.gt.-2) this%p(n)%pos(1)=this%p(n)%pos(1) + this%p(n)%pos(1)*0.001_WP + ! Relocalize + this%p(n)%ind=this%cfg%get_ijk_global(this%p(n)%pos,this%p(n)%ind) + ! Correct the position to take into account periodicity + if (this%cfg%xper) this%p(n)%pos(1)=this%cfg%x(this%cfg%imin)+modulo(this%p(n)%pos(1)-this%cfg%x(this%cfg%imin),this%cfg%xL) + if (this%cfg%yper) this%p(n)%pos(2)=this%cfg%y(this%cfg%jmin)+modulo(this%p(n)%pos(2)-this%cfg%y(this%cfg%jmin),this%cfg%yL) + if (this%cfg%zper) this%p(n)%pos(3)=this%cfg%z(this%cfg%kmin)+modulo(this%p(n)%pos(3)-this%cfg%z(this%cfg%kmin),this%cfg%zL) + ! Handle particles that have left the domain + if (this%p(n)%pos(1).lt.this%cfg%x(this%cfg%imin).or.this%p(n)%pos(1).gt.this%cfg%x(this%cfg%imax+1)) this%p(n)%flag=1 + if (this%p(n)%pos(2).lt.this%cfg%y(this%cfg%jmin).or.this%p(n)%pos(2).gt.this%cfg%y(this%cfg%jmax+1)) this%p(n)%flag=1 + if (this%p(n)%pos(3).lt.this%cfg%z(this%cfg%kmin).or.this%p(n)%pos(3).gt.this%cfg%z(this%cfg%kmax+1)) this%p(n)%flag=1 + ! Relocalize the particle + this%p(n)%ind=this%cfg%get_ijk_global(this%p(n)%pos,this%p(n)%ind) + ! Count number of particles removed + end do + + ! Communicate particles + call this%sync() + + ! Sum up particles removed + call MPI_ALLREDUCE(this%np_out,n,1,MPI_INTEGER,MPI_SUM,this%cfg%comm,ierr); this%np_out=n + + ! Calculate bond force + call this%get_bond_force() + + mu=this%elastic_modulus/(2.0_WP+2.0_WP*this%poisson_ratio) + + do n=1,this%np_ + this%p(n)%gd=0.001_WP/this%p(n)%dil + this%p(n)%Gb=0.5_WP*mu*(0.001_WP*0.001_WP)/this%p(n)%ste + end do + + ! Log/screen output + logging: block + use, intrinsic :: iso_fortran_env, only: output_unit + use param, only: verbose + use messager, only: log + use string, only: str_long + character(len=str_long) :: message + if (this%cfg%amRoot) then + write(message,'("Particle solver [",a,"] on partitioned grid [",a,"]: ",i0," particles were advanced")') trim(this%name),trim(this%cfg%name),this%np + if (verbose.gt.1) write(output_unit,'(a)') trim(message) + if (verbose.gt.0) call log(message) + end if + end block logging + + end subroutine get_correction_coeffs + + + !> Update particle volume fraction using our current particles + subroutine update_VF(this) + implicit none + class(lss), intent(inout) :: this + integer :: i + ! Reset volume fraction and momentum + this%VF=0.0_WP; this%VFU=0.0_WP; this%VFV=0.0_WP; this%VFW=0.0_WP + ! Transfer particle volume + do i=1,this%np_ + ! Skip inactive particle + if (this%p(i)%flag.eq.1) cycle + ! Transfer volume to mesh + call this%extrapolate(Ap=this%p(i)%vol,xp=this%p(i)%pos(1),yp=this%p(i)%pos(2),zp=this%p(i)%pos(3),ip=this%p(i)%ind(1),jp=this%p(i)%ind(2),kp=this%p(i)%ind(3),A=this%VF,dir='SC') + call this%extrapolate(Ap=this%p(i)%vol*this%p(i)%vel(1),xp=this%p(i)%pos(1),yp=this%p(i)%pos(2),zp=this%p(i)%pos(3),ip=this%p(i)%ind(1),jp=this%p(i)%ind(2),kp=this%p(i)%ind(3),A=this%VFU,dir='U') + call this%extrapolate(Ap=this%p(i)%vol*this%p(i)%vel(2),xp=this%p(i)%pos(1),yp=this%p(i)%pos(2),zp=this%p(i)%pos(3),ip=this%p(i)%ind(1),jp=this%p(i)%ind(2),kp=this%p(i)%ind(3),A=this%VFV,dir='V') + call this%extrapolate(Ap=this%p(i)%vol*this%p(i)%vel(3),xp=this%p(i)%pos(1),yp=this%p(i)%pos(2),zp=this%p(i)%pos(3),ip=this%p(i)%ind(1),jp=this%p(i)%ind(2),kp=this%p(i)%ind(3),A=this%VFW,dir='W') + end do + ! Sum at boundaries + call this%cfg%syncsum(this%VF) + call this%cfg%syncsum(this%VFU) + call this%cfg%syncsum(this%VFV) + call this%cfg%syncsum(this%VFW) + ! Clip + where (this%VF.gt.1.0_WP) this%VF=1.0_WP + where (this%VF.lt.0.0_WP) this%VF=0.0_WP + end subroutine update_VF + + + !> Compute regularized delta function + subroutine get_delta(this,delta,ic,jc,kc,xp,yp,zp,dir) + implicit none + class(lss), intent(inout) :: this + real(WP), intent(out) :: delta !< Return delta function + integer, intent(in) :: ic,jc,kc !< Cell index + real(WP), intent(in) :: xp,yp,zp !< Position of marker + character(len=*) :: dir + real(WP) :: deltax,deltay,deltaz,r + + ! Compute in X + if (trim(adjustl(dir)).eq.'U') then + r=(xp-this%cfg%x(ic))*this%cfg%dxmi(ic) + deltax=roma_kernel(r)*this%cfg%dxmi(ic) + else + r=(xp-this%cfg%xm(ic))*this%cfg%dxi(ic) + deltax=roma_kernel(r)*this%cfg%dxi(ic) + end if + + ! Compute in Y + if (trim(adjustl(dir)).eq.'V') then + r=(yp-this%cfg%y(jc))*this%cfg%dymi(jc) + deltay=roma_kernel(r)*this%cfg%dymi(jc) + else + r=(yp-this%cfg%ym(jc))*this%cfg%dyi(jc) + deltay=roma_kernel(r)*this%cfg%dyi(jc) + end if + + ! Compute in Z + if (trim(adjustl(dir)).eq.'W') then + r=(zp-this%cfg%z(kc))*this%cfg%dzmi(kc) + deltaz=roma_kernel(r)*this%cfg%dzmi(kc) + else + r=(zp-this%cfg%zm(kc))*this%cfg%dzi(kc) + deltaz=roma_kernel(r)*this%cfg%dzi(kc) + end if + !else + + ! Put it all together + delta=deltax*deltay*deltaz + + contains + ! Mollification kernel + ! Roma A, Peskin C and Berger M 1999 J. Comput. Phys. 153 509–534 + function roma_kernel(r) result(phi) + implicit none + real(WP), intent(in) :: r + real(WP) :: phi + if (abs(r).le.0.5_WP) then + phi=1.0_WP/3.0_WP*(1.0_WP+sqrt(-3.0_WP*r**2+1.0_WP)) + else if (abs(r).gt.0.5_WP .and. abs(r).le.1.5_WP) then + phi=1.0_WP/6.0_WP*(5.0_WP-3.0_WP*abs(r)-sqrt(-3.0_WP*(1.0_WP-abs(r))**2+1.0_WP)) + else + phi=0.0_WP + end if + end function roma_kernel + + end subroutine get_delta + + + !> Interpolation routine + function interpolate(this,A,xp,yp,zp,ip,jp,kp,dir) result(Ap) + implicit none + class(lss), intent(inout) :: this + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(in) :: A !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + real(WP), intent(in) :: xp,yp,zp + integer, intent(in) :: ip,jp,kp + character(len=*) :: dir + real(WP) :: Ap + integer :: di,dj,dk + integer :: i1,i2,j1,j2,k1,k2 + real(WP), dimension(-2:+2,-2:+2,-2:+2) :: delta + ! Get the interpolation points + i1=ip-2; i2=ip+2 + j1=jp-2; j2=jp+2 + k1=kp-2; k2=kp+2 + ! Loop over neighboring cells and compute regularized delta function + do dk=-2,+2 + do dj=-2,+2 + do di=-2,+2 + call this%get_delta(delta=delta(di,dj,dk),ic=ip+di,jc=jp+dj,kc=kp+dk,xp=xp,yp=yp,zp=zp,dir=trim(dir)) + end do + end do + end do + ! Perform the actual interpolation on Ap + Ap = sum(delta*A(i1:i2,j1:j2,k1:k2))*this%cfg%vol(ip,jp,kp) + end function interpolate + + + !> Extrapolation routine + subroutine extrapolate(this,Ap,xp,yp,zp,ip,jp,kp,A,dir) + use messager, only: die + implicit none + class(lss), intent(inout) :: this + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:) :: A !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + real(WP), intent(in) :: xp,yp,zp + integer, intent(in) :: ip,jp,kp + real(WP), intent(in) :: Ap + character(len=*) :: dir + real(WP), dimension(-2:+2,-2:+2,-2:+2) :: delta + integer :: di,dj,dk + ! If particle has left processor domain or reached last ghost cell, kill job + if ( ip.lt.this%cfg%imin_-1.or.ip.gt.this%cfg%imax_+1.or.& + & jp.lt.this%cfg%jmin_-1.or.jp.gt.this%cfg%jmax_+1.or.& + & kp.lt.this%cfg%kmin_-1.or.kp.gt.this%cfg%kmax_+1) then + write(*,*) ip,jp,kp,xp,yp,zp + call die('[df extrapolate] Particle has left the domain') + end if + ! Loop over neighboring cells and compute regularized delta function + do dk=-2,+2 + do dj=-2,+2 + do di=-2,+2 + call this%get_delta(delta=delta(di,dj,dk),ic=ip+di,jc=jp+dj,kc=kp+dk,xp=xp,yp=yp,zp=zp,dir=trim(dir)) + end do + end do + end do + ! Perform the actual extrapolation on A + A(ip-2:ip+2,jp-2:jp+2,kp-2:kp+2)=A(ip-2:ip+2,jp-2:jp+2,kp-2:kp+2)+delta*Ap + end subroutine extrapolate + + + !> Calculate the CFL + subroutine get_cfl(this,dt,cfl) + use mpi_f08, only: MPI_ALLREDUCE,MPI_MAX + use parallel, only: MPI_REAL_WP + implicit none + class(lss), intent(inout) :: this + real(WP), intent(in) :: dt + real(WP), intent(out) :: cfl + integer :: i,ierr + real(WP) :: my_CFLp_x,my_CFLp_y,my_CFLp_z,kk,mu,a + + ! Set the CFLs to zero + my_CFLp_x=0.0_WP; my_CFLp_y=0.0_WP; my_CFLp_z=0.0_WP + do i=1,this%np_ + my_CFLp_x=max(my_CFLp_x,abs(this%p(i)%vel(1))*this%cfg%dxi(this%p(i)%ind(1))) + my_CFLp_y=max(my_CFLp_y,abs(this%p(i)%vel(2))*this%cfg%dyi(this%p(i)%ind(2))) + my_CFLp_z=max(my_CFLp_z,abs(this%p(i)%vel(3))*this%cfg%dzi(this%p(i)%ind(3))) + end do + my_CFLp_x=my_CFLp_x*dt; my_CFLp_y=my_CFLp_y*dt; my_CFLp_z=my_CFLp_z*dt + + ! Get the parallel max + call MPI_ALLREDUCE(my_CFLp_x,this%CFLp_x,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + call MPI_ALLREDUCE(my_CFLp_y,this%CFLp_y,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + call MPI_ALLREDUCE(my_CFLp_z,this%CFLp_z,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + + ! CFL based on elastic wave speed in material + kk=this%elastic_modulus/(3.0_WP-6.0_WP*this%poisson_ratio) + mu=this%elastic_modulus/(2.0_WP+2.0_WP*this%poisson_ratio) + a=sqrt((kk+4.0_WP*mu/3.0_WP)/this%rho) + this%CFLp_a=dt*a*3/this%delta + + ! Return the maximum CFL + cfl=max(this%CFLp_x,this%CFLp_y,this%CFLp_z,this%CFLp_a) + + end subroutine get_cfl + + + !> Extract various monitoring data from particle field + subroutine get_max(this) + use mpi_f08, only: MPI_ALLREDUCE,MPI_MAX,MPI_MIN,MPI_SUM + use parallel, only: MPI_REAL_WP + implicit none + class(lss), intent(inout) :: this + real(WP) :: buf,safe_np + real(WP), dimension(3) :: buf3D + integer :: i,j,k,ierr + + ! Create safe np + safe_np=real(max(this%np,1),WP) + + ! Velocity min/max/mean + this%Umin=huge(1.0_WP); this%Umax=-huge(1.0_WP); this%Umean=0.0_WP + this%Vmin=huge(1.0_WP); this%Vmax=-huge(1.0_WP); this%Vmean=0.0_WP + this%Wmin=huge(1.0_WP); this%Wmax=-huge(1.0_WP); this%Wmean=0.0_WP + this%ibmForce=0.0_WP + do i=1,this%np_ + this%Umin=min(this%Umin,this%p(i)%vel(1)); this%Umax=max(this%Umax,this%p(i)%vel(1)); this%Umean=this%Umean+this%p(i)%vel(1) + this%Vmin=min(this%Vmin,this%p(i)%vel(2)); this%Vmax=max(this%Vmax,this%p(i)%vel(2)); this%Vmean=this%Vmean+this%p(i)%vel(2) + this%Wmin=min(this%Wmin,this%p(i)%vel(3)); this%Wmax=max(this%Wmax,this%p(i)%vel(3)); this%Wmean=this%Wmean+this%p(i)%vel(3) + this%ibmForce=this%ibmForce+this%p(i)%Afluid*this%p(i)%vol*this%rho + end do + call MPI_ALLREDUCE(this%Umin ,buf,1,MPI_REAL_WP,MPI_MIN,this%cfg%comm,ierr); this%Umin =buf + call MPI_ALLREDUCE(this%Umax ,buf,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr); this%Umax =buf + call MPI_ALLREDUCE(this%Umean,buf,1,MPI_REAL_WP,MPI_SUM,this%cfg%comm,ierr); this%Umean=buf/safe_np + call MPI_ALLREDUCE(this%Vmin ,buf,1,MPI_REAL_WP,MPI_MIN,this%cfg%comm,ierr); this%Vmin =buf + call MPI_ALLREDUCE(this%Vmax ,buf,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr); this%Vmax =buf + call MPI_ALLREDUCE(this%Vmean,buf,1,MPI_REAL_WP,MPI_SUM,this%cfg%comm,ierr); this%Vmean=buf/safe_np + call MPI_ALLREDUCE(this%Wmin ,buf,1,MPI_REAL_WP,MPI_MIN,this%cfg%comm,ierr); this%Wmin =buf + call MPI_ALLREDUCE(this%Wmax ,buf,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr); this%Wmax =buf + call MPI_ALLREDUCE(this%Wmean,buf,1,MPI_REAL_WP,MPI_SUM,this%cfg%comm,ierr); this%Wmean=buf/safe_np + call MPI_ALLREDUCE(this%ibmForce,buf3D,3,MPI_REAL_WP,MPI_SUM,this%cfg%comm,ierr); this%ibmForce=buf3D + + ! Get max volume fraction + this%VFmax =-huge(1.0_WP) + do k=this%cfg%kmin_,this%cfg%kmax_ + do j=this%cfg%jmin_,this%cfg%jmax_ + do i=this%cfg%imin_,this%cfg%imax_ + this%VFmax=max(this%VFmax,this%VF(i,j,k)) + end do + end do + end do + call MPI_ALLREDUCE(this%VFmax,buf,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr); this%VFmax=buf + + end subroutine get_max + + + !> Update particle mesh using our current particles + subroutine update_partmesh(this,pmesh) + use partmesh_class, only: partmesh + implicit none + class(lss), intent(inout) :: this + class(partmesh), intent(inout) :: pmesh + integer :: i + ! Reset particle mesh storage + call pmesh%reset() + ! Nothing else to do if no particle is present + if (this%np_.eq.0) return + ! Copy particle info + call pmesh%set_size(this%np_) + do i=1,this%np_ + pmesh%pos(:,i)=this%p(i)%pos + end do + end subroutine update_partmesh + + + !> Creation of the MPI datatype for particle + subroutine prepare_mpi_part() + use mpi_f08 + use messager, only: die + implicit none + integer(MPI_ADDRESS_KIND), dimension(part_nblock) :: disp + integer(MPI_ADDRESS_KIND) :: lb,extent + type(MPI_Datatype) :: MPI_PART_TMP + integer :: i,mysize,ierr + ! Prepare the displacement array + disp(1)=0 + do i=2,part_nblock + call MPI_Type_size(part_tblock(i-1),mysize,ierr) + disp(i)=disp(i-1)+int(mysize,MPI_ADDRESS_KIND)*int(part_lblock(i-1),MPI_ADDRESS_KIND) + end do + ! Create and commit the new type + call MPI_Type_create_struct(part_nblock,part_lblock,disp,part_tblock,MPI_PART_TMP,ierr) + call MPI_Type_get_extent(MPI_PART_TMP,lb,extent,ierr) + call MPI_Type_create_resized(MPI_PART_TMP,lb,extent,MPI_PART,ierr) + call MPI_Type_commit(MPI_PART,ierr) + ! If a problem was encountered, say it + if (ierr.ne.0) call die('[lss prepare_mpi_part] MPI Particle type creation failed') + ! Get the size of this type + call MPI_type_size(MPI_PART,MPI_PART_SIZE,ierr) + end subroutine prepare_mpi_part + + + !> Share particles across processor boundaries + subroutine share(this,nover) + use mpi_f08 + use messager, only: warn,die + implicit none + class(lss), intent(inout) :: this + integer, optional :: nover + type(part), dimension(:), allocatable :: tosend + type(part), dimension(:), allocatable :: torecv + integer :: no,nsend,nrecv + type(MPI_Status) :: status + integer :: icnt,isrc,idst,ierr + integer :: i,n + + ! Check overlap size + if (present(nover)) then + no=nover + if (no.gt.this%cfg%no) then + call warn('[lss share] Specified overlap is larger than that of cfg - reducing no') + no=this%cfg%no + else if (no.le.0) then + call die('[lss share] Specified overlap cannot be less or equal to zero') + end if + else + no=1 + end if + + ! Clean up ghost array + call this%resize_ghost(n=0); this%ng_=0 + + ! Share ghost particles in -x (no ghosts are sent here) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(1).lt.this%cfg%imin_+no) nsend=nsend+1 + end do + allocate(tosend(nsend)) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(1).lt.this%cfg%imin_+no) then + nsend=nsend+1 + tosend(nsend)=this%p(n) + if (this%cfg%xper.and.tosend(nsend)%ind(1).lt.this%cfg%imin+no) then + tosend(nsend)%pos(1)=tosend(nsend)%pos(1)+this%cfg%xL + tosend(nsend)%ind(1)=tosend(nsend)%ind(1)+this%cfg%nx + end if + end if + end do + nrecv=0 + call MPI_CART_SHIFT(this%cfg%comm,0,-1,isrc,idst,ierr) + call MPI_SENDRECV(nsend,1,MPI_INTEGER,idst,0,nrecv,1,MPI_INTEGER,isrc,0,this%cfg%comm,status,ierr) + allocate(torecv(nrecv)) + call MPI_SENDRECV(tosend,nsend,MPI_PART,idst,0,torecv,nrecv,MPI_PART,isrc,0,this%cfg%comm,status,ierr) + call this%resize_ghost(this%ng_+nrecv) + this%g(this%ng_+1:this%ng_+nrecv)=torecv + this%ng_=this%ng_+nrecv + if (allocated(tosend)) deallocate(tosend) + if (allocated(torecv)) deallocate(torecv) + + ! Share ghost particles in +x (no ghosts are sent here) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(1).gt.this%cfg%imax_-no) nsend=nsend+1 + end do + allocate(tosend(nsend)) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(1).gt.this%cfg%imax_-no) then + nsend=nsend+1 + tosend(nsend)=this%p(n) + if (this%cfg%xper.and.tosend(nsend)%ind(1).gt.this%cfg%imax-no) then + tosend(nsend)%pos(1)=tosend(nsend)%pos(1)-this%cfg%xL + tosend(nsend)%ind(1)=tosend(nsend)%ind(1)-this%cfg%nx + end if + end if + end do + nrecv=0 + call MPI_CART_SHIFT(this%cfg%comm,0,+1,isrc,idst,ierr) + call MPI_SENDRECV(nsend,1,MPI_INTEGER,idst,0,nrecv,1,MPI_INTEGER,isrc,0,this%cfg%comm,status,ierr) + allocate(torecv(nrecv)) + call MPI_SENDRECV(tosend,nsend,MPI_PART,idst,0,torecv,nrecv,MPI_PART,isrc,0,this%cfg%comm,status,ierr) + call this%resize_ghost(this%ng_+nrecv) + this%g(this%ng_+1:this%ng_+nrecv)=torecv + this%ng_=this%ng_+nrecv + if (allocated(tosend)) deallocate(tosend) + if (allocated(torecv)) deallocate(torecv) + + ! Share ghost particles in -y (ghosts need to be sent now) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(2).lt.this%cfg%jmin_+no) nsend=nsend+1 + end do + do n=1,this%ng_ + if (this%g(n)%ind(2).lt.this%cfg%jmin_+no) nsend=nsend+1 + end do + allocate(tosend(nsend)) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(2).lt.this%cfg%jmin_+no) then + nsend=nsend+1 + tosend(nsend)=this%p(n) + if (this%cfg%yper.and.tosend(nsend)%ind(2).lt.this%cfg%jmin+no) then + tosend(nsend)%pos(2)=tosend(nsend)%pos(2)+this%cfg%yL + tosend(nsend)%ind(2)=tosend(nsend)%ind(2)+this%cfg%ny + end if + end if + end do + do n=1,this%ng_ + if (this%g(n)%ind(2).lt.this%cfg%jmin_+no) then + nsend=nsend+1 + tosend(nsend)=this%g(n) + if (this%cfg%yper.and.tosend(nsend)%ind(2).lt.this%cfg%jmin+no) then + tosend(nsend)%pos(2)=tosend(nsend)%pos(2)+this%cfg%yL + tosend(nsend)%ind(2)=tosend(nsend)%ind(2)+this%cfg%ny + end if + end if + end do + nrecv=0 + call MPI_CART_SHIFT(this%cfg%comm,1,-1,isrc,idst,ierr) + call MPI_SENDRECV(nsend,1,MPI_INTEGER,idst,0,nrecv,1,MPI_INTEGER,isrc,0,this%cfg%comm,status,ierr) + allocate(torecv(nrecv)) + call MPI_SENDRECV(tosend,nsend,MPI_PART,idst,0,torecv,nrecv,MPI_PART,isrc,0,this%cfg%comm,status,ierr) + call this%resize_ghost(this%ng_+nrecv) + this%g(this%ng_+1:this%ng_+nrecv)=torecv + this%ng_=this%ng_+nrecv + if (allocated(tosend)) deallocate(tosend) + if (allocated(torecv)) deallocate(torecv) + + ! Share ghost particles in +y (ghosts need to be sent now - but not newly received ghosts!) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(2).gt.this%cfg%jmax_-no) nsend=nsend+1 + end do + do n=1,this%ng_-nrecv + if (this%g(n)%ind(2).gt.this%cfg%jmax_-no) nsend=nsend+1 + end do + allocate(tosend(nsend)) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(2).gt.this%cfg%jmax_-no) then + nsend=nsend+1 + tosend(nsend)=this%p(n) + if (this%cfg%yper.and.tosend(nsend)%ind(2).gt.this%cfg%jmax-no) then + tosend(nsend)%pos(2)=tosend(nsend)%pos(2)-this%cfg%yL + tosend(nsend)%ind(2)=tosend(nsend)%ind(2)-this%cfg%ny + end if + end if + end do + do n=1,this%ng_-nrecv + if (this%g(n)%ind(2).gt.this%cfg%jmax_-no) then + nsend=nsend+1 + tosend(nsend)=this%g(n) + if (this%cfg%yper.and.tosend(nsend)%ind(2).gt.this%cfg%jmax-no) then + tosend(nsend)%pos(2)=tosend(nsend)%pos(2)-this%cfg%yL + tosend(nsend)%ind(2)=tosend(nsend)%ind(2)-this%cfg%ny + end if + end if + end do + nrecv=0 + call MPI_CART_SHIFT(this%cfg%comm,1,+1,isrc,idst,ierr) + call MPI_SENDRECV(nsend,1,MPI_INTEGER,idst,0,nrecv,1,MPI_INTEGER,isrc,0,this%cfg%comm,status,ierr) + allocate(torecv(nrecv)) + call MPI_SENDRECV(tosend,nsend,MPI_PART,idst,0,torecv,nrecv,MPI_PART,isrc,0,this%cfg%comm,status,ierr) + call this%resize_ghost(this%ng_+nrecv) + this%g(this%ng_+1:this%ng_+nrecv)=torecv + this%ng_=this%ng_+nrecv + if (allocated(tosend)) deallocate(tosend) + if (allocated(torecv)) deallocate(torecv) + + ! Share ghost particles in -z (ghosts need to be sent now) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(3).lt.this%cfg%kmin_+no) nsend=nsend+1 + end do + do n=1,this%ng_ + if (this%g(n)%ind(3).lt.this%cfg%kmin_+no) nsend=nsend+1 + end do + allocate(tosend(nsend)) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(3).lt.this%cfg%kmin_+no) then + nsend=nsend+1 + tosend(nsend)=this%p(n) + if (this%cfg%zper.and.tosend(nsend)%ind(3).lt.this%cfg%kmin+no) then + tosend(nsend)%pos(3)=tosend(nsend)%pos(3)+this%cfg%zL + tosend(nsend)%ind(3)=tosend(nsend)%ind(3)+this%cfg%nz + end if + end if + end do + do n=1,this%ng_ + if (this%g(n)%ind(3).lt.this%cfg%kmin_+no) then + nsend=nsend+1 + tosend(nsend)=this%g(n) + if (this%cfg%zper.and.tosend(nsend)%ind(3).lt.this%cfg%kmin+no) then + tosend(nsend)%pos(3)=tosend(nsend)%pos(3)+this%cfg%zL + tosend(nsend)%ind(3)=tosend(nsend)%ind(3)+this%cfg%nz + end if + end if + end do + nrecv=0 + call MPI_CART_SHIFT(this%cfg%comm,2,-1,isrc,idst,ierr) + call MPI_SENDRECV(nsend,1,MPI_INTEGER,idst,0,nrecv,1,MPI_INTEGER,isrc,0,this%cfg%comm,status,ierr) + allocate(torecv(nrecv)) + call MPI_SENDRECV(tosend,nsend,MPI_PART,idst,0,torecv,nrecv,MPI_PART,isrc,0,this%cfg%comm,status,ierr) + call this%resize_ghost(this%ng_+nrecv) + this%g(this%ng_+1:this%ng_+nrecv)=torecv + this%ng_=this%ng_+nrecv + if (allocated(tosend)) deallocate(tosend) + if (allocated(torecv)) deallocate(torecv) + + ! Share ghost particles in +z (ghosts need to be sent now - but not newly received ghosts!) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(3).gt.this%cfg%kmax_-no) nsend=nsend+1 + end do + do n=1,this%ng_-nrecv + if (this%g(n)%ind(3).gt.this%cfg%kmax_-no) nsend=nsend+1 + end do + allocate(tosend(nsend)) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(3).gt.this%cfg%kmax_-no) then + nsend=nsend+1 + tosend(nsend)=this%p(n) + if (this%cfg%zper.and.tosend(nsend)%ind(3).gt.this%cfg%kmax-no) then + tosend(nsend)%pos(3)=tosend(nsend)%pos(3)-this%cfg%zL + tosend(nsend)%ind(3)=tosend(nsend)%ind(3)-this%cfg%nz + end if + end if + end do + do n=1,this%ng_-nrecv + if (this%g(n)%ind(3).gt.this%cfg%kmax_-no) then + nsend=nsend+1 + tosend(nsend)=this%g(n) + if (this%cfg%zper.and.tosend(nsend)%ind(3).gt.this%cfg%kmax-no) then + tosend(nsend)%pos(3)=tosend(nsend)%pos(3)-this%cfg%zL + tosend(nsend)%ind(3)=tosend(nsend)%ind(3)-this%cfg%nz + end if + end if + end do + nrecv=0 + call MPI_CART_SHIFT(this%cfg%comm,2,+1,isrc,idst,ierr) + call MPI_SENDRECV(nsend,1,MPI_INTEGER,idst,0,nrecv,1,MPI_INTEGER,isrc,0,this%cfg%comm,status,ierr) + allocate(torecv(nrecv)) + call MPI_SENDRECV(tosend,nsend,MPI_PART,idst,0,torecv,nrecv,MPI_PART,isrc,0,this%cfg%comm,status,ierr) + call this%resize_ghost(this%ng_+nrecv) + this%g(this%ng_+1:this%ng_+nrecv)=torecv + this%ng_=this%ng_+nrecv + if (allocated(tosend)) deallocate(tosend) + if (allocated(torecv)) deallocate(torecv) + + end subroutine share + + + !> Synchronize particle arrays across processors + subroutine sync(this) + use mpi_f08 + implicit none + class(lss), intent(inout) :: this + integer, dimension(0:this%cfg%nproc-1) :: nsend_proc,nrecv_proc + integer, dimension(0:this%cfg%nproc-1) :: nsend_disp,nrecv_disp + integer :: n,prank,ierr + type(part), dimension(:), allocatable :: buf_send + ! Recycle first to minimize communication load + call this%recycle() + ! Prepare information about what to send + nsend_proc=0 + do n=1,this%np_ + prank=this%cfg%get_rank(this%p(n)%ind) + nsend_proc(prank)=nsend_proc(prank)+1 + end do + nsend_proc(this%cfg%rank)=0 + ! Inform processors of what they will receive + call MPI_ALLtoALL(nsend_proc,1,MPI_INTEGER,nrecv_proc,1,MPI_INTEGER,this%cfg%comm,ierr) + ! Prepare displacements for all-to-all + nsend_disp(0)=0 + nrecv_disp(0)=this%np_ !< Directly add particles at the end of main array + do n=1,this%cfg%nproc-1 + nsend_disp(n)=nsend_disp(n-1)+nsend_proc(n-1) + nrecv_disp(n)=nrecv_disp(n-1)+nrecv_proc(n-1) + end do + ! Allocate buffer to send particles + allocate(buf_send(sum(nsend_proc))) + ! Pack the particles in the send buffer + nsend_proc=0 + do n=1,this%np_ + ! Get the rank + prank=this%cfg%get_rank(this%p(n)%ind) + ! Skip particles still inside + if (prank.eq.this%cfg%rank) cycle + ! Pack up for sending + nsend_proc(prank)=nsend_proc(prank)+1 + buf_send(nsend_disp(prank)+nsend_proc(prank))=this%p(n) + ! Flag particle for removal + this%p(n)%flag=1 + end do + ! Allocate buffer for receiving particles + call this%resize(this%np_+sum(nrecv_proc)) + ! Perform communication + call MPI_ALLtoALLv(buf_send,nsend_proc,nsend_disp,MPI_PART,this%p,nrecv_proc,nrecv_disp,MPI_PART,this%cfg%comm,ierr) + ! Deallocate buffer + deallocate(buf_send) + ! Recycle to remove duplicate particles + call this%recycle() + end subroutine sync + + + !> Adaptation of particle array size + subroutine resize(this,n) + implicit none + class(lss), intent(inout) :: this + integer, intent(in) :: n + type(part), dimension(:), allocatable :: tmp + integer :: size_now,size_new + ! Resize particle array to size n + if (.not.allocated(this%p)) then + ! Allocate directly to size n + allocate(this%p(n)) + this%p(1:n)%flag=1 + else + ! Update from a non-zero size to another non-zero size + size_now=size(this%p,dim=1) + if (n.gt.size_now) then + size_new=max(n,int(real(size_now,WP)*coeff_up)) + allocate(tmp(size_new)) + tmp(1:size_now)=this%p + tmp(size_now+1:)%flag=1 + call move_alloc(tmp,this%p) + else if (n.lt.int(real(size_now,WP)*coeff_dn)) then + allocate(tmp(n)) + tmp(1:n)=this%p(1:n) + call move_alloc(tmp,this%p) + end if + end if + end subroutine resize + + + !> Adaptation of ghost array size + subroutine resize_ghost(this,n) + implicit none + class(lss), intent(inout) :: this + integer, intent(in) :: n + type(part), dimension(:), allocatable :: tmp + integer :: size_now,size_new + ! Resize ghost array to size n + if (.not.allocated(this%g)) then + ! Allocate directly to size n + allocate(this%g(n)) + this%g(1:n)%flag=1 + else + ! Update from a non-zero size to another non-zero size + size_now=size(this%g,dim=1) + if (n.gt.size_now) then + size_new=max(n,int(real(size_now,WP)*coeff_up)) + allocate(tmp(size_new)) + tmp(1:size_now)=this%g + tmp(size_now+1:)%flag=1 + call move_alloc(tmp,this%g) + else if (n.lt.int(real(size_now,WP)*coeff_dn)) then + allocate(tmp(n)) + tmp(1:n)=this%g(1:n) + call move_alloc(tmp,this%g) + end if + end if + end subroutine resize_ghost + + + !> Clean-up of particle array by removing flag=1 particles + subroutine recycle(this) + implicit none + class(lss), intent(inout) :: this + integer :: new_size,i,ierr + ! Compact all active particles at the beginning of the array + new_size=0 + if (allocated(this%p)) then + do i=1,size(this%p,dim=1) + if (this%p(i)%flag.ne.1) then + new_size=new_size+1 + if (i.ne.new_size) then + this%p(new_size)=this%p(i) + this%p(i)%flag=1 + end if + end if + end do + end if + ! Resize to new size + call this%resize(new_size) + ! Update number of particles + this%np_=new_size + call MPI_ALLGATHER(this%np_,1,MPI_INTEGER,this%np_proc,1,MPI_INTEGER,this%cfg%comm,ierr) + this%np=sum(this%np_proc) + end subroutine recycle + + + !> Parallel write particles to file + subroutine write(this,filename) + use mpi_f08 + use messager, only: die + use parallel, only: info_mpiio + implicit none + class(lss), intent(inout) :: this + character(len=*), intent(in) :: filename + type(MPI_File) :: ifile + type(MPI_Status):: status + integer(kind=MPI_OFFSET_KIND) :: offset + integer :: i,ierr,iunit + + ! Root serial-writes the file header + if (this%cfg%amRoot) then + ! Open the file + open(newunit=iunit,file=trim(filename),form='unformatted',status='replace',access='stream',iostat=ierr) + if (ierr.ne.0) call die('[lss write] Problem encountered while serial-opening data file: '//trim(filename)) + ! Number of particles and particle object size + write(iunit) this%np,MPI_PART_SIZE + ! Done with the header + close(iunit) + end if + + ! The rest is done in parallel + call MPI_FILE_OPEN(this%cfg%comm,trim(filename),IOR(MPI_MODE_WRONLY,MPI_MODE_APPEND),info_mpiio,ifile,ierr) + if (ierr.ne.0) call die('[lss write] Problem encountered while parallel-opening data file: '//trim(filename)) + + ! Get current position + call MPI_FILE_GET_POSITION(ifile,offset,ierr) + + ! Compute the offset and write + do i=1,this%cfg%rank + offset=offset+int(this%np_proc(i),MPI_OFFSET_KIND)*int(MPI_PART_SIZE,MPI_OFFSET_KIND) + end do + if (this%np_.gt.0) call MPI_FILE_WRITE_AT(ifile,offset,this%p,this%np_,MPI_PART,status,ierr) + + ! Close the file + call MPI_FILE_CLOSE(ifile,ierr) + + ! Log/screen output + logging: block + use, intrinsic :: iso_fortran_env, only: output_unit + use param, only: verbose + use messager, only: log + use string, only: str_long + character(len=str_long) :: message + if (this%cfg%amRoot) then + write(message,'("[lss write] Wrote ",i0," particles to file [",a,"] on partitioned grid [",a,"]")') this%np,trim(filename),trim(this%cfg%name) + if (verbose.gt.2) write(output_unit,'(a)') trim(message) + if (verbose.gt.1) call log(message) + end if + end block logging + + end subroutine write + + + !> Parallel read particles to file + subroutine read(this,filename) + use mpi_f08 + use messager, only: die + use parallel, only: info_mpiio + implicit none + class(lss), intent(inout) :: this + character(len=*), intent(in) :: filename + type(MPI_File) :: ifile + type(MPI_Status):: status + integer(kind=MPI_OFFSET_KIND) :: offset,header_offset + integer :: i,j,ierr,npadd,psize,nchunk,cnt + integer, dimension(:,:), allocatable :: ppp + + ! First open the file in parallel + call MPI_FILE_OPEN(this%cfg%comm,trim(filename),MPI_MODE_RDONLY,info_mpiio,ifile,ierr) + if (ierr.ne.0) call die('[lss read] Problem encountered while reading data file: '//trim(filename)) + + ! Read file header first + call MPI_FILE_READ_ALL(ifile,npadd,1,MPI_INTEGER,status,ierr) + call MPI_FILE_READ_ALL(ifile,psize,1,MPI_INTEGER,status,ierr) + + ! Remember current position + call MPI_FILE_GET_POSITION(ifile,header_offset,ierr) + + ! Check compatibility of particle type + if (psize.ne.MPI_PART_SIZE) call die('[lss read] Particle type unreadable') + + ! Naively share reading task among all processors + nchunk=int(npadd/(this%cfg%nproc*part_chunk_size))+1 + allocate(ppp(this%cfg%nproc,nchunk)) + ppp=int(npadd/(this%cfg%nproc*nchunk)) + cnt=0 + out:do j=1,nchunk + do i=1,this%cfg%nproc + cnt=cnt+1 + if (cnt.gt.mod(npadd,this%cfg%nproc*nchunk)) exit out + ppp(i,j)=ppp(i,j)+1 + end do + end do out + + ! Read by chunk + do j=1,nchunk + ! Find offset + offset=header_offset+int(MPI_PART_SIZE,MPI_OFFSET_KIND)*int(sum(ppp(1:this%cfg%rank,:))+sum(ppp(this%cfg%rank+1,1:j-1)),MPI_OFFSET_KIND) + ! Resize particle array + call this%resize(this%np_+ppp(this%cfg%rank+1,j)) + ! Read this file + call MPI_FILE_READ_AT(ifile,offset,this%p(this%np_+1:this%np_+ppp(this%cfg%rank+1,j)),ppp(this%cfg%rank+1,j),MPI_PART,status,ierr) + ! Most general case: relocate every droplet + do i=this%np_+1,this%np_+ppp(this%cfg%rank+1,j) + this%p(i)%ind=this%cfg%get_ijk_global(this%p(i)%pos,this%p(i)%ind) + end do + ! Exchange all that + call this%sync() + end do + + ! Close the file + call MPI_FILE_CLOSE(ifile,ierr) + + ! Log/screen output + logging: block + use, intrinsic :: iso_fortran_env, only: output_unit + use param, only: verbose + use messager, only: log + use string, only: str_long + character(len=str_long) :: message + if (this%cfg%amRoot) then + write(message,'("[lss read] Read ",i0," particles from file [",a,"] on partitioned grid [",a,"]")') npadd,trim(filename),trim(this%cfg%name) + if (verbose.gt.2) write(output_unit,'(a)') trim(message) + if (verbose.gt.1) call log(message) + end if + end block logging + + end subroutine read + + +end module lss_class diff --git a/examples/beam_test/src/simulation.f90 b/examples/beam_test/src/simulation.f90 new file mode 100644 index 000000000..cddf0d3e5 --- /dev/null +++ b/examples/beam_test/src/simulation.f90 @@ -0,0 +1,753 @@ +!> Various definitions and tools for running an NGA2 simulation +module simulation + use precision, only: WP,SP + use geometry, only: cfg + use spcomp_class, only: spcomp + use lss_class, only: lss + use timetracker_class, only: timetracker + use ensight_class, only: ensight + use partmesh_class, only: partmesh + use event_class, only: event + use monitor_class, only: monitor + implicit none + private + + !> Get a couple linear solvers, an incompressible flow solver and corresponding time tracker + type(spcomp), public :: fs + type(lss), public :: ls + type(timetracker), public :: time + + !> Ensight postprocessing + type(partmesh) :: pmesh + type(ensight) :: ens_out + type(event) :: ens_evt + + !> Simulation monitor file + type(monitor) :: mfile,cflfile,consfile,sfile,dispfile + + public :: simulation_init,simulation_run,simulation_final + + !> Private work arrays + real(WP), dimension(:,:,:,:,:), allocatable :: dQdt + real(WP), dimension(:,:,:) , allocatable :: Ui,Vi,Wi,Ma,beta,visc,visc_t,div + !> Post-shock viscosity and temperature + real(WP) :: visc0,T0 + + !> Equations of state + real(WP) :: Pinf,Gamma,Cv,Prandtl + + !> Flow parameters + real(WP) :: Ms,Xs,Rcyl + real(WP) :: rho1,p1,u1,M1 + real(WP) :: rho2,p2,u2,M2 + real(WP) :: Re + + !> Max timestep size for solid solver + real(WP) :: ls_dt,ls_dt_max + + integer :: target_index + real(WP), dimension(3) :: target_position + + + contains + + + !> Function that returns a smooth Heaviside of thickness delta + real(WP) function Hshock(x,delta) + real(WP), intent(in) :: x,delta + ! Goes from 0 to 1 as x goes from begative to positive + Hshock=1.0_WP/(1.0_WP+exp(-x/delta)) + end function Hshock + + !> P=EOS(RHO,I) + pure real(WP) function get_P(RHO,I) + implicit none + real(WP), intent(in) :: RHO,I + get_P=RHO*I*(Gamma-1.0_WP)-Gamma*Pinf + end function get_P + !> T=f(RHO,P) + pure real(WP) function get_T(RHO,P) + implicit none + real(WP), intent(in) :: RHO,P + get_T=(P+Pinf)/(Cv*RHO*(Gamma-1.0_WP)) + end function get_T + !> RHO=f(T,P) + pure real(WP) function get_RHO(T,P) + implicit none + real(WP), intent(in) :: T,P + get_RHO=(P+Pinf)/(Cv*T*(Gamma-1.0_WP)) + end function get_RHO + !> I=EOS(RHO,P) + pure real(WP) function get_I(RHO,P) + implicit none + real(WP), intent(in) :: RHO,P + get_I=(P+Gamma*Pinf)/(RHO*(Gamma-1.0_WP)) + end function get_I + !> C=f(RHO,P) + pure real(WP) function get_C(RHO,P) + implicit none + real(WP), intent(in) :: RHO,P + get_C=sqrt(Gamma*(P+Pinf)/RHO) + end function get_C + !> S=f(RHO,P) + pure real(WP) function get_S(RHO,P) + implicit none + real(WP), intent(in) :: RHO,P + get_S=Cv*log((P+Pinf)/RHO**Gamma) + end function get_S + + subroutine get_tracked_particle() + use mpi_f08 + implicit none + integer :: i, ierr + real(WP) :: local_pos(3), global_pos(3) + + local_pos = 0.0_WP + + do i=1,ls%np_ + if (ls%p(i)%i.eq.target_index) then + local_pos = ls%p(i)%pos + end if + end do + call MPI_ALLREDUCE(local_pos, global_pos, 3, MPI_DOUBLE_PRECISION, MPI_SUM, ls%cfg%comm, ierr) + + target_position = global_pos + end subroutine + + !> Calculate viscosities + subroutine prepare_viscosities() + implicit none + integer :: i,j,k + real(WP) :: S + ! Get viscosity from Sutherland's law + S=110.4_WP/273.15_WP*T0 + do k=fs%cfg%kmino_,fs%cfg%kmaxo_ + do j=fs%cfg%jmino_,fs%cfg%jmaxo_ + do i=fs%cfg%imino_,fs%cfg%imaxo_ + visc(i,j,k)=visc0*(T0+S)/(fs%T(i,j,k)+S)*(fs%T(i,j,k)/T0)**1.5_WP + end do + end do + end do + ! Get LAD + call fs%get_viscartif(dt=time%dt,beta=beta); fs%BETA=fs%Q(:,:,:,1)*beta + ! Get eddy viscosity + call fs%get_vreman (dt=time%dt,visc=visc_t); fs%VISC=fs%Q(:,:,:,1)*visc_t+visc + ! Recompute thermal conductivity + fs%diff=Gamma*Cv*fs%visc/Prandtl + ! Add LAD + fs%VISC=fs%VISC+0.002_WP*fs%BETA + end subroutine prepare_viscosities + + + !> Calculate velocity divergence + subroutine get_div() + implicit none + integer :: i,j,k + do k=fs%cfg%kmino_,fs%cfg%kmaxo_-1; do j=fs%cfg%jmino_,fs%cfg%jmaxo_-1; do i=fs%cfg%imino_,fs%cfg%imaxo_-1 + div(i,j,k)=fs%dxi*(fs%U(i+1,j,k)-fs%U(i,j,k))+fs%dyi*(fs%V(i,j+1,k)-fs%V(i,j,k))+fs%dzi*(fs%W(i,j,k+1)-fs%W(i,j,k)) + end do; end do; end do + call fs%cfg%sync(div) + if (.not.fs%cfg%xper.and.fs%cfg%iproc.eq.fs%cfg%npx) div(fs%cfg%imaxo,:,:)=div(fs%cfg%imaxo-1,:,:) + if (.not.fs%cfg%yper.and.fs%cfg%jproc.eq.fs%cfg%npy) div(:,fs%cfg%jmaxo,:)=div(:,fs%cfg%jmaxo-1,:) + if (.not.fs%cfg%zper.and.fs%cfg%kproc.eq.fs%cfg%npz) div(:,:,fs%cfg%kmaxo)=div(:,:,fs%cfg%kmaxo-1) + end subroutine get_div + + + !> Overwrite cosnerved variables using volume-of-solid IBM + subroutine apply_ibm() + implicit none + integer :: i,j,k,ii,jj,kk + real(WP) :: sum_VF,sum_VFQ1,sum_VFQ2 + do k=cfg%kmin_,cfg%kmax_ + do j=cfg%jmin_,cfg%jmax_ + do i=cfg%imin_,cfg%imax_ + if (ls%VF(i,j,k).eq.0.0_WP) cycle + ! Neumann: VF-weighted neighbor average for Q(1) and Q(2) + sum_VF=0.0_WP; sum_VFQ1=0.0_WP; sum_VFQ2=0.0_WP + do kk=-1,1; do jj=-1,1; do ii=-1,1 + if (ii.eq.0.and.jj.eq.0.and.kk.eq.0) cycle + sum_VF =sum_VF +(1.0_WP-ls%VF(i+ii,j+jj,k+kk)) + sum_VFQ1=sum_VFQ1+(1.0_WP-ls%VF(i+ii,j+jj,k+kk))*fs%Q(i+ii,j+jj,k+kk,1) + sum_VFQ2=sum_VFQ2+(1.0_WP-ls%VF(i+ii,j+jj,k+kk))*fs%Q(i+ii,j+jj,k+kk,2) + end do; end do; end do + if (sum_VF.gt.0.0_WP) then + fs%Q(i,j,k,1)=(1.0_WP-ls%VF(i,j,k))*fs%Q(i,j,k,1)+ls%VF(i,j,k)*sum_VFQ1/sum_VF + fs%Q(i,j,k,2)=(1.0_WP-ls%VF(i,j,k))*fs%Q(i,j,k,2)+ls%VF(i,j,k)*sum_VFQ2/sum_VF + end if + ! No-slip now that density is determined + fs%Q(i,j,k,3)=(1.0_WP-0.5_WP*(ls%VF(i-1,j,k)+ls%VF(i,j,k)))*fs%Q(i,j,k,3)+0.5_WP*(fs%Q(i-1,j,k,1)+fs%Q(i,j,k,1))*ls%VFU(i,j,k) + fs%Q(i,j,k,4)=(1.0_WP-0.5_WP*(ls%VF(i,j-1,k)+ls%VF(i,j,k)))*fs%Q(i,j,k,4)+0.5_WP*(fs%Q(i,j-1,k,1)+fs%Q(i,j,k,1))*ls%VFV(i,j,k) + fs%Q(i,j,k,5)=(1.0_WP-0.5_WP*(ls%VF(i,j,k-1)+ls%VF(i,j,k)))*fs%Q(i,j,k,5)+0.5_WP*(fs%Q(i,j,k-1,1)+fs%Q(i,j,k,1))*ls%VFW(i,j,k) + end do + end do + end do + ! Communicate + call fs%cfg%sync(fs%Q(:,:,:,1)) + call fs%cfg%sync(fs%Q(:,:,:,2)) + call fs%cfg%sync(fs%Q(:,:,:,3)) + call fs%cfg%sync(fs%Q(:,:,:,4)) + call fs%cfg%sync(fs%Q(:,:,:,5)) + ! Rebuild primitive variables + call fs%get_primitive() + end subroutine apply_ibm + + + !> Apply boundary conditions + subroutine apply_bconds() + implicit none + integer :: i,j,k + + ! Apply clipped Neumann on primitive variables in x+ + if (.not.fs%cfg%xper.and.fs%cfg%iproc.eq.fs%cfg%npx) then + do k=fs%cfg%kmino_,fs%cfg%kmaxo_; do j=fs%cfg%jmino_,fs%cfg%jmaxo_ + ! Copy over from imax to imax+1 and above + do i=fs%cfg%imax+1,fs%cfg%imaxo + ! Copy primitive variables + ls%VF(i,j,k)=ls%VF(fs%cfg%imax,j,k) + fs%Q(i,j,k,1)=fs%Q(fs%cfg%imax,j,k,1) + fs%P(i,j,k)=fs%P(fs%cfg%imax,j,k) + fs%I(i,j,k)=fs%I(fs%cfg%imax,j,k) + fs%U(i,j,k)=max(fs%U(fs%cfg%imax,j,k),0.0_WP) + fs%V(i,j,k)=fs%V(fs%cfg%imax,j,k) + fs%W(i,j,k)=fs%W(fs%cfg%imax,j,k) + end do + end do; end do + end if + + ! Apply clipped Neumann on primitive variables in y+ + if (.not.fs%cfg%yper.and.fs%cfg%jproc.eq.fs%cfg%npy) then + do k=fs%cfg%kmino_,fs%cfg%kmaxo_; do i=fs%cfg%imino_,fs%cfg%imaxo_ + ! Copy over from jmax to jmax+1 and above + do j=fs%cfg%jmax+1,fs%cfg%jmaxo + ! Copy primitive variables + ls%VF(i,j,k)=ls%VF(i,fs%cfg%jmax,k) + fs%Q(i,j,k,1)=fs%Q(i,fs%cfg%jmax,k,1) + fs%P(i,j,k)=fs%P(i,fs%cfg%jmax,k) + fs%I(i,j,k)=fs%I(i,fs%cfg%jmax,k) + fs%U(i,j,k)=fs%U(i,fs%cfg%jmax,k) + fs%V(i,j,k)=max(fs%V(i,fs%cfg%jmax,k),0.0_WP) + fs%W(i,j,k)=fs%W(i,fs%cfg%jmax,k) + end do + end do; end do + end if + + ! Apply clipped Neumann on primitive variables in y- + if (.not.fs%cfg%yper.and.fs%cfg%jproc.eq.1) then + do k=fs%cfg%kmino_,fs%cfg%kmaxo_; do i=fs%cfg%imino_,fs%cfg%imaxo_ + ! First copy over V from jmin+1 to jmin + fs%V(i,fs%cfg%jmin,k)=min(fs%V(i,fs%cfg%jmin+1,k),0.0_WP) + ! Then copy over from jmin to jmin-1 and below + do j=fs%cfg%jmino,fs%cfg%jmin-1 + ! Copy primitive variables + ls%VF(i,j,k)=ls%VF(i,fs%cfg%jmin,k) + fs%Q(i,j,k,1)=fs%Q(i,fs%cfg%jmin,k,1) + fs%P(i,j,k)=fs%P(i,fs%cfg%jmin,k) + fs%I(i,j,k)=fs%I(i,fs%cfg%jmin,k) + fs%U(i,j,k)=fs%U(i,fs%cfg%jmin,k) + fs%V(i,j,k)=min(fs%V(i,fs%cfg%jmin,k),0.0_WP) + fs%W(i,j,k)=fs%W(i,fs%cfg%jmin,k) + end do + end do; end do + end if + + ! Apply clipped Neumann on primitive variables in z+ + if (.not.fs%cfg%zper.and.fs%cfg%kproc.eq.fs%cfg%npz) then + do j=fs%cfg%jmino_,fs%cfg%jmaxo_; do i=fs%cfg%imino_,fs%cfg%imaxo_ + ! Copy over from kmax to kmax+1 and above + do k=fs%cfg%kmax+1,fs%cfg%kmaxo + ! Copy primitive variables + ls%VF(i,j,k)=ls%VF(i,j,fs%cfg%kmax) + fs%Q(i,j,k,1)=fs%Q(i,j,fs%cfg%kmax,1) + fs%P(i,j,k)=fs%P(i,j,fs%cfg%kmax) + fs%I(i,j,k)=fs%I(i,j,fs%cfg%kmax) + fs%U(i,j,k)=fs%U(i,j,fs%cfg%kmax) + fs%V(i,j,k)=fs%V(i,j,fs%cfg%kmax) + fs%W(i,j,k)=max(fs%W(i,j,fs%cfg%kmax),0.0_WP) + end do + end do; end do + end if + + ! Apply clipped Neumann on primitive variables in z- + if (.not.fs%cfg%zper.and.fs%cfg%kproc.eq.1) then + do j=fs%cfg%jmino_,fs%cfg%jmaxo_; do i=fs%cfg%imino_,fs%cfg%imaxo_ + ! First copy over W from kmin+1 to kmin + fs%W(i,j,fs%cfg%kmin)=min(fs%W(i,j,fs%cfg%kmin+1),0.0_WP) + ! Then copy over from kmin to kmin-1 and below + do k=fs%cfg%kmino,fs%cfg%kmin-1 + ! Copy primitive variables + ls%VF(i,j,k)=ls%VF(i,j,fs%cfg%kmin) + fs%Q(i,j,k,1)=fs%Q(i,j,fs%cfg%kmin,1) + fs%P(i,j,k)=fs%P(i,j,fs%cfg%kmin) + fs%I(i,j,k)=fs%I(i,j,fs%cfg%kmin) + fs%U(i,j,k)=fs%U(i,j,fs%cfg%kmin) + fs%V(i,j,k)=fs%V(i,j,fs%cfg%kmin) + fs%W(i,j,k)=min(fs%W(i,j,fs%cfg%kmin),0.0_WP) + end do + end do; end do + end if + + ! Rebuild conserved quantities + fs%Q(:,:,:,2)=fs%Q(:,:,:,1)*fs%I + call fs%get_momentum() + + end subroutine apply_bconds + + + !> Initialization of problem solver + subroutine simulation_init + use param, only: param_read,param_exists + implicit none + + ! Allocate work arrays + allocate_work_arrays: block + allocate(dQdt (cfg%imino_:cfg%imaxo_,cfg%jmino_:cfg%jmaxo_,cfg%kmino_:cfg%kmaxo_,1:5,1:4)) + end block allocate_work_arrays + + ! Initialize time tracker with 2 subiterations + initialize_timetracker: block + time=timetracker(amRoot=cfg%amRoot) + call param_read('Max timestep size',time%dtmax) + call param_read('Max cfl number',time%cflmax) + call param_read('Max time',time%tmax) + time%dt=time%dtmax + time%itmax=2 + end block initialize_timetracker + + + + ! ! Initialize Lagrangian solid solver + ! initialize_lss: block + ! use mpi_f08, only: MPI_ALLREDUCE,MPI_MAX,MPI_INTEGER + ! real(WP) :: dx,mu,kk,max_stretch,Lx,Ly,Lz + ! real(WP) :: xmin,xmax,ymin,ymax,zmin,zmax,ratio,P_load + ! integer :: np,nt,nx,ny,nz,ierr,global_index + ! type triangle_type + ! real(WP), dimension(3) :: norm + ! real(WP), dimension(3) :: v1 + ! real(WP), dimension(3) :: v2 + ! real(WP), dimension(3) :: v3 + ! end type triangle_type + ! type(triangle_type), dimension(:), allocatable :: t + + + ! ! Create solver + ! ls=lss(cfg=cfg,name='solid') + ! !call fs%initialize(cfg=cfg,name='Compressible NS') + + + ! ! Set material properties + ! call param_read('Elastic Modulus',ls%elastic_modulus) + ! call param_read('Poisson Ratio',ls%poisson_ratio) + ! call param_read('Solid density',ls%rho) + ! call param_read('Critical Energy Release Rate',ls%crit_energy) + + ! ! Maximum timestep size used for particles + ! call param_read('Particle timestep size',ls_dt_max,default=huge(1.0_WP)) + ! ls_dt=min(ls_dt_max,time%dtmax) + + ! ! Discretization + ! ! ls%delta=fs%cfg%min_meshsize*1.01 + ! ! Load',P_load) + ! call param_read('Lx',Lx) + ! call param_read('Ly',Ly) + ! call param_read('Lz',Lz) + ! call param_read('Subdivisions',ny) + ! nz = ny + ! nx = NINT(Lx/Lz)*ny + ! call param_read('Horizon Ratio',ratio) + ! ls%delta = Ly/real(ny,WP)*ratio + ! ! Output some info on stretch + ! mu=ls%elastic_modulus/(2.0_WP+2.0_WP*ls%poisson_ratio) + ! kk=ls%elastic_modulus/(3.0_WP-6.0_WP*ls%poisson_ratio) + ! max_stretch=sqrt(ls%crit_energy/((3.0_WP*mu+(kk-5.0_WP*mu/3.0_WP)*0.75_WP**4)*ls%delta)) + + ! ! Only root process initializes solid particles + ! if (ls%cfg%amRoot) then + ! ! Read the STL file and get domain extents and levelset + ! print*, Lx * Ly * Lz / real(ny*nz*nx,WP) + ! read_bin: block + + ! use messager, only: die + ! integer :: p,iunit,ierr, wall_np, i, j, k + ! global_index = 0 + ! target_index = 0 + + ! ! Read in grid definition + ! wall_np = ny*nz*(nx+3) + ! ! call ls%resize(np+wall_np) + ! call ls%resize(wall_np) + ! p=0 + ! do i=1,nx+3 + ! do j=1,ny + ! do k=1,nz + ! p = p+1 + ! ls%p(p)%pos(1) = (i-1) * (Lx/real(nx,WP)) + ! ls%p(p)%pos(2) = (j) * (Ly/real(ny,WP)) - Ly/2.0_WP + ! ls%p(p)%pos(3) = (k) * (Lz/real(nz,WP)) - Lz/2.0_WP + ! ls%p(p)%vol = Lx * Ly * Lz / real(ny*nz*nx,WP) + ! ls%p(p)%id=1 + ! if(i.le.3) ls%p(p)%id=-2 + + ! ls%p(p)%vel=[0.0_WP,0.0_WP,0.0_WP] + ! ! Zero out force + ! ls%p(p)%Abond=0.0_WP + ! ! Zero out fluid unless end, using this for the load + ! ls%p(p)%Afluid=0.0_WP + ! !if(i.eq.nx+3) ls%p(p)%Afluid=[(P_load*Ly*Lz)/(ls%rho*ls%p(p)%vol),0.0_WP,0.0_WP] + ! ! Locate the particle on the mesh + ! ls%p(p)%ind=ls%cfg%get_ijk_global(ls%p(p)%pos,[ls%cfg%imin,ls%cfg%jmin,ls%cfg%kmin]) + ! ! Assign a unique integer to particle + ! ls%p(p)%i=p + ! ! Activate the particle + ! ls%p(p)%flag=0 + ! if(i.eq.(nx/2+1).and.j.eq.(ny/2+1).and.k.eq.(nz/2+1)) target_index = p + ! end do + ! end do + ! end do + + ! np = wall_np + ! end block read_bin + ! end if + + ! ! Allreduce with MPI_MAX ensures the nonzero index propagates to all + ! call MPI_ALLREDUCE(target_index, global_index, 1, MPI_INTEGER, MPI_MAX, ls%cfg%comm, ierr) + + ! ! Update target_index globally + ! target_index = global_index + + + ! ! Communicate particles + ! call ls%sync() + + ! call get_tracked_particle() + + ! ! Get initial volume fraction + ! ! call ls%update_VF() + + ! ! Initalize bonds + ! call ls%bond_init() + + ! if (ls%cfg%amRoot) then + ! print*,"===== Solid Setup Description =====" + ! print*,'Number of particles', np + ! print*,'Maximum stretching =',max_stretch + ! end if + + ! end block initialize_lss + + initialize_lss: block + use mpi_f08, only: MPI_ALLREDUCE,MPI_MAX,MPI_INTEGER + real(WP) :: dx,mu,kk,max_stretch,Lx,Ly,Lz + real(WP) :: xmin,xmax,ymin,ymax,zmin,zmax,ratio,dist + integer :: np,nt,nx,ny,nz,ierr,global_index + type triangle_type + real(WP), dimension(3) :: norm + real(WP), dimension(3) :: v1 + real(WP), dimension(3) :: v2 + real(WP), dimension(3) :: v3 + end type triangle_type + type(triangle_type), dimension(:), allocatable :: t + + + + + ! Create solver + ls=lss(cfg=cfg,name='solid') + !call fs%initialize(cfg=cfg,name='Compressible NS') + + + ! Set material properties + call param_read('Elastic Modulus',ls%elastic_modulus) + call param_read('Poisson Ratio',ls%poisson_ratio) + call param_read('Solid density',ls%rho) + call param_read('Critical Energy Release Rate',ls%crit_energy) + + ! Maximum timestep size used for particles + call param_read('Particle timestep size',ls_dt_max,default=huge(1.0_WP)) + ls_dt=min(ls_dt_max,time%dtmax) + + ! Discretization + ! ls%delta=fs%cfg%min_meshsize*1.01 + ! Load',P_load) + Lx = 1.0_WP + dist = 0.01_WP ! Space between particles + Lx = Lx + 3.0_WP * dist + ny = 3 + nz = 3 + nx = ceiling(Lx/dist) + call param_read('Horizon Ratio',ratio) + ls%delta = dist*ratio + print*, ls%delta + ! Output some info on stretch + mu=ls%elastic_modulus/(2.0_WP+2.0_WP*ls%poisson_ratio) + kk=ls%elastic_modulus/(3.0_WP-6.0_WP*ls%poisson_ratio) + max_stretch=sqrt(ls%crit_energy/((3.0_WP*mu+(kk-5.0_WP*mu/3.0_WP)*0.75_WP**4)*ls%delta)) + + ! Only root process initializes solid particles + if (ls%cfg%amRoot) then + ! Read the STL fiprint*, "here" + read_bin: block + + use messager, only: die + integer :: p,iunit,ierr, wall_np, i, j, k + real(WP) :: net_vol + net_vol = 0.0_WP + global_index = 0 + target_index = 0 + + ! Read in grid definition + wall_np = (3*ny)*(3*nz)*(nx) + ! call ls%resize(np+wall_np) + call ls%resize(wall_np) + p=0 + do i=1,nx + do j=1,3*ny + do k=1,3*nz + p = p+1 + + ls%p(p)%pos(1) = (i-1) * dist - 2.0_WP*dist + epsilon(1.0_WP); + ls%p(p)%pos(2) = (j-1) * (dist) - dist + ls%p(p)%pos(3) = (k-1) * (dist) - dist + ls%p(p)%vol = dist*dist*dist + ls%p(p)%gd = 1.0_WP + ls%p(p)%gb = 1.0_WP + ls%p(p)%id=1 + if(i.le.3) ls%p(p)%id=-2 + ls%p(p)%vel=[0.0_WP,0.0_WP,0.0_WP] + if(i.gt.3) net_vol=net_vol+ls%p(p)%vol + ! Zero out force + ls%p(p)%Abond=0.0_WP + ! Zero out fluid unless end, using this for the load + ls%p(p)%Afluid=0.0_WP + !if(i.eq.nx+3) ls%p(p)%Afluid=[(P_load*Ly*Lz)/(ls%rho*ls%p(p)%vol),0.0_WP,0.0_WP] + ! Locate the particle on the mesh + ls%p(p)%ind=ls%cfg%get_ijk_global(ls%p(p)%pos,[ls%cfg%imin,ls%cfg%jmin,ls%cfg%kmin]) + ! Assign a unique integer to particle + ls%p(p)%i=p + ! Activate the particle + ls%p(p)%flag=0 + if(i.eq.(nx/2+2).and.j.eq.(5).and.k.eq.(5)) target_index = p + end do + end do + end do + + np = wall_np + print*, "Net Volume: ", net_vol + end block read_bin + end if + + ! Allreduce with MPI_MAX ensures the nonzero index propagates to all + call MPI_ALLREDUCE(target_index, global_index, 1, MPI_INTEGER, MPI_MAX, ls%cfg%comm, ierr) + + ! Update target_index globally + target_index = global_index + + + ! Communicate particles + call ls%sync() + + call get_tracked_particle() + + ! Get initial volume fraction + ! call ls%update_VF() + + ! Initalize bonds + call ls%bond_init() + + if (ls%cfg%amRoot) then + print*,"===== Solid Setup Description =====" + print*,'Number of particles', np + print*,'Maximum stretching =',max_stretch + end if + + end block initialize_lss + + + ! Create partmesh object for visualizing Lagrangian particles + create_pmesh: block + use lss_class, only: max_bond + integer :: i,n,nbond + pmesh=partmesh(nvar=5,nvec=4,name='solid') + pmesh%varname(1)='failfrac' + pmesh%varname(2)='dilatation' + pmesh%varname(3)='id' + pmesh%varname(4)='nbond' + pmesh%varname(5)='ste' + + pmesh%vecname(1)='velocity' + pmesh%vecname(2)='bond_force' + pmesh%vecname(3)='Gd' + pmesh%vecname(4)='Gb' + call ls%update_partmesh(pmesh) + do i=1,ls%np_ + pmesh%var(1,i)=0.0_WP + nbond=0 + do n=1,max_bond + if (ls%p(i)%ibond(n).gt.0) nbond=nbond+1 + end do + if (ls%p(i)%nbond.gt.0) then + pmesh%var(1,i)=1.0_WP-real(nbond,WP)/real(ls%p(i)%nbond,WP) + else + pmesh%var(1,i)=0.0_WP + end if + pmesh%var(2,i) =ls%p(i)%dil + pmesh%var(3,i) =ls%p(i)%id + pmesh%vec(:,1,i)=ls%p(i)%vel + pmesh%vec(:,2,i)=ls%p(i)%Abond + pmesh%var(4,i) =ls%p(i)%nbond + pmesh%var(5,i) =ls%p(i)%ste + pmesh%vec(:,3,i) =ls%p(i)%gd + pmesh%vec(:,4,i) =ls%p(i)%gb + end do + end block create_pmesh + + ! Add Ensight output + create_ensight: block + ! Create Ensight output from cfg + ens_out=ensight(cfg=cfg,name='shock') + ! Create event for Ensight output + ens_evt=event(time=time,name='Ensight output') + call param_read('Ensight output period',ens_evt%tper) + ! Add variables to output + call ens_out%add_particle('particles',pmesh) + ! Output to ensight + if (ens_evt%occurs()) call ens_out%write_data(time%t) + end block create_ensight + + + ! Create monitor files + create_monitor: block + real(WP) :: cfl + ! Prepare some info about fields + call ls%get_cfl(time%dt,time%cfl) + call ls%get_max() + ! Create solid monitor + sfile=monitor(ls%cfg%amRoot,'solid') + call sfile%add_column(time%n,'Timestep number') + call sfile%add_column(time%t,'Time') + call sfile%add_column(ls_dt,'Particle dt') + call sfile%add_column(time%cfl,'Maximum CFL') + call sfile%add_column(ls%np,'Particle number') + call sfile%add_column(ls%VFmax,'VFmax') + call sfile%add_column(ls%Umin,'Particle Umin') + call sfile%add_column(ls%Umax,'Particle Umax') + call sfile%add_column(ls%Vmin,'Particle Vmin') + call sfile%add_column(ls%Vmax,'Particle Vmax') + call sfile%add_column(ls%Wmin,'Particle Wmin') + call sfile%add_column(ls%Wmax,'Particle Wmax') + call sfile%add_column(ls%ibmForce(1),'Particle Fx') + call sfile%add_column(ls%ibmForce(2),'Particle Fy') + call sfile%add_column(ls%ibmForce(3),'Particle Fz') + call sfile%write() + dispfile=monitor(ls%cfg%amRoot,'displacement') + call dispfile%add_column(time%n,'Timestep number') + call dispfile%add_column(time%t,'Time') + call dispfile%add_column(ls_dt,'Particle dt') + call dispfile%add_column(target_position(1),'X') + call dispfile%add_column(target_position(2),'Y') + call dispfile%add_column(target_position(3),'Z') + call dispfile%write() + end block create_monitor + + end subroutine simulation_init + + + !> Perform an NGA2 simulation + subroutine simulation_run + implicit none + real(WP) :: cfl + logical :: first_time + + first_time = .true. + ! Perform time integration + do while (.not.time%done()) + + ! Increment time + call ls%get_cfl(time%dt,time%cfl) + ! call fs%get_cfl(time%dt,cfl); time%cfl=max(time%cfl,cfl) + call time%adjust_dt() + call time%increment() + + ! Advance solid solver + solid: block + real(WP) :: dt_done,mydt + ! Sub-iteratore + call ls%get_cfl(ls_dt,cfl=cfl) + if (cfl.gt.0.0_WP) ls_dt=min(ls_dt*time%cflmax/cfl,ls_dt_max) + dt_done=0.0_WP + do while (dt_done.lt.time%dtmid) + ! Decide the timestep size + if(first_time) then + call ls%stretch(dt =mydt) + first_time=.false. + dt_done=dt_done+mydt + else + mydt=min(ls_dt,time%dtmid-dt_done) + ! ! Advance particles + call ls%advance(dt =mydt) + ! ! Increment + dt_done=dt_done+mydt + end if + + end do + end block solid + + !> Perform and output monitoring + call ls%get_max() + call get_tracked_particle() + call sfile%write() + call dispfile%write() + + + ! Output to ensight + if (ens_evt%occurs()) then + update_pmesh: block + use lss_class, only: max_bond + integer :: i,n,nbond + call ls%update_partmesh(pmesh) + do i=1,ls%np_ + nbond=0 + do n=1,max_bond + if (ls%p(i)%ibond(n).gt.0) nbond=nbond+1 + end do + if (ls%p(i)%nbond.gt.0) then + pmesh%var(1,i)=1.0_WP-real(nbond,WP)/real(ls%p(i)%nbond,WP) + else + pmesh%var(1,i)=0.0_WP + end if + pmesh%var(2,i) =ls%p(i)%dil + pmesh%var(3,i) =ls%p(i)%id + pmesh%vec(:,1,i)=ls%p(i)%vel + pmesh%vec(:,2,i)=ls%p(i)%Abond + pmesh%var(4,i) =ls%p(i)%nbond + pmesh%var(5,i) =ls%p(i)%ste + pmesh%vec(:,3,i) =ls%p(i)%Gd + pmesh%vec(:,4,i) =ls%p(i)%Gb + + + end do + end block update_pmesh + call ens_out%write_data(time%t) + end if + + end do + + end subroutine simulation_run + + + !> Finalize the NGA2 simulation + subroutine simulation_final + implicit none + + ! Get rid of all objects - need destructors + ! monitor + ! ensight + ! bcond + ! timetracker + + ! Deallocate work arrays + deallocate(dQdt) + end subroutine simulation_final + + +end module simulation diff --git a/examples/beam_test/src/simulation_stl.f90 b/examples/beam_test/src/simulation_stl.f90 new file mode 100644 index 000000000..9c7e1c8b1 --- /dev/null +++ b/examples/beam_test/src/simulation_stl.f90 @@ -0,0 +1,741 @@ +!> Various definitions and tools for running an NGA2 simulation +module simulation + use precision, only: WP,SP + use geometry, only: cfg + use spcomp_class, only: spcomp + use lss_class, only: lss + use timetracker_class, only: timetracker + use ensight_class, only: ensight + use partmesh_class, only: partmesh + use event_class, only: event + use monitor_class, only: monitor + implicit none + private + + !> Get a couple linear solvers, an incompressible flow solver and corresponding time tracker + type(spcomp), public :: fs + type(lss), public :: ls + type(timetracker), public :: time + + !> Ensight postprocessing + type(partmesh) :: pmesh + type(ensight) :: ens_out + type(event) :: ens_evt + + !> Simulation monitor file + type(monitor) :: mfile,cflfile,consfile,sfile,dispfile + + public :: simulation_init,simulation_run,simulation_final + + !> Private work arrays + real(WP), dimension(:,:,:,:,:), allocatable :: dQdt + real(WP), dimension(:,:,:) , allocatable :: Ui,Vi,Wi,Ma,beta,visc,visc_t,div + !> Post-shock viscosity and temperature + real(WP) :: visc0,T0 + + !> Equations of state + real(WP) :: Pinf,Gamma,Cv,Prandtl + + !> Flow parameters + real(WP) :: Ms,Xs,Rcyl + real(WP) :: rho1,p1,u1,M1 + real(WP) :: rho2,p2,u2,M2 + real(WP) :: Re + + !> Max timestep size for solid solver + real(WP) :: ls_dt,ls_dt_max + + integer :: target_index + real(WP), dimension(3) :: target_position + + + contains + + + !> Function that returns a smooth Heaviside of thickness delta + real(WP) function Hshock(x,delta) + real(WP), intent(in) :: x,delta + ! Goes from 0 to 1 as x goes from begative to positive + Hshock=1.0_WP/(1.0_WP+exp(-x/delta)) + end function Hshock + + !> P=EOS(RHO,I) + pure real(WP) function get_P(RHO,I) + implicit none + real(WP), intent(in) :: RHO,I + get_P=RHO*I*(Gamma-1.0_WP)-Gamma*Pinf + end function get_P + !> T=f(RHO,P) + pure real(WP) function get_T(RHO,P) + implicit none + real(WP), intent(in) :: RHO,P + get_T=(P+Pinf)/(Cv*RHO*(Gamma-1.0_WP)) + end function get_T + !> RHO=f(T,P) + pure real(WP) function get_RHO(T,P) + implicit none + real(WP), intent(in) :: T,P + get_RHO=(P+Pinf)/(Cv*T*(Gamma-1.0_WP)) + end function get_RHO + !> I=EOS(RHO,P) + pure real(WP) function get_I(RHO,P) + implicit none + real(WP), intent(in) :: RHO,P + get_I=(P+Gamma*Pinf)/(RHO*(Gamma-1.0_WP)) + end function get_I + !> C=f(RHO,P) + pure real(WP) function get_C(RHO,P) + implicit none + real(WP), intent(in) :: RHO,P + get_C=sqrt(Gamma*(P+Pinf)/RHO) + end function get_C + !> S=f(RHO,P) + pure real(WP) function get_S(RHO,P) + implicit none + real(WP), intent(in) :: RHO,P + get_S=Cv*log((P+Pinf)/RHO**Gamma) + end function get_S + + subroutine get_tracked_particle() + use mpi_f08 + implicit none + integer :: i, ierr + real(WP) :: local_pos(3), global_pos(3) + + local_pos = 0.0_WP + + do i=1,ls%np_ + if (ls%p(i)%i.eq.target_index) then + local_pos = ls%p(i)%pos + end if + end do + call MPI_ALLREDUCE(local_pos, global_pos, 3, MPI_DOUBLE_PRECISION, MPI_SUM, ls%cfg%comm, ierr) + + target_position = global_pos + end subroutine + + !> Calculate viscosities + subroutine prepare_viscosities() + implicit none + integer :: i,j,k + real(WP) :: S + ! Get viscosity from Sutherland's law + S=110.4_WP/273.15_WP*T0 + do k=fs%cfg%kmino_,fs%cfg%kmaxo_ + do j=fs%cfg%jmino_,fs%cfg%jmaxo_ + do i=fs%cfg%imino_,fs%cfg%imaxo_ + visc(i,j,k)=visc0*(T0+S)/(fs%T(i,j,k)+S)*(fs%T(i,j,k)/T0)**1.5_WP + end do + end do + end do + ! Get LAD + call fs%get_viscartif(dt=time%dt,beta=beta); fs%BETA=fs%Q(:,:,:,1)*beta + ! Get eddy viscosity + call fs%get_vreman (dt=time%dt,visc=visc_t); fs%VISC=fs%Q(:,:,:,1)*visc_t+visc + ! Recompute thermal conductivity + fs%diff=Gamma*Cv*fs%visc/Prandtl + ! Add LAD + fs%VISC=fs%VISC+0.002_WP*fs%BETA + end subroutine prepare_viscosities + + + !> Calculate velocity divergence + subroutine get_div() + implicit none + integer :: i,j,k + do k=fs%cfg%kmino_,fs%cfg%kmaxo_-1; do j=fs%cfg%jmino_,fs%cfg%jmaxo_-1; do i=fs%cfg%imino_,fs%cfg%imaxo_-1 + div(i,j,k)=fs%dxi*(fs%U(i+1,j,k)-fs%U(i,j,k))+fs%dyi*(fs%V(i,j+1,k)-fs%V(i,j,k))+fs%dzi*(fs%W(i,j,k+1)-fs%W(i,j,k)) + end do; end do; end do + call fs%cfg%sync(div) + if (.not.fs%cfg%xper.and.fs%cfg%iproc.eq.fs%cfg%npx) div(fs%cfg%imaxo,:,:)=div(fs%cfg%imaxo-1,:,:) + if (.not.fs%cfg%yper.and.fs%cfg%jproc.eq.fs%cfg%npy) div(:,fs%cfg%jmaxo,:)=div(:,fs%cfg%jmaxo-1,:) + if (.not.fs%cfg%zper.and.fs%cfg%kproc.eq.fs%cfg%npz) div(:,:,fs%cfg%kmaxo)=div(:,:,fs%cfg%kmaxo-1) + end subroutine get_div + + + !> Overwrite cosnerved variables using volume-of-solid IBM + subroutine apply_ibm() + implicit none + integer :: i,j,k,ii,jj,kk + real(WP) :: sum_VF,sum_VFQ1,sum_VFQ2 + do k=cfg%kmin_,cfg%kmax_ + do j=cfg%jmin_,cfg%jmax_ + do i=cfg%imin_,cfg%imax_ + if (ls%VF(i,j,k).eq.0.0_WP) cycle + ! Neumann: VF-weighted neighbor average for Q(1) and Q(2) + sum_VF=0.0_WP; sum_VFQ1=0.0_WP; sum_VFQ2=0.0_WP + do kk=-1,1; do jj=-1,1; do ii=-1,1 + if (ii.eq.0.and.jj.eq.0.and.kk.eq.0) cycle + sum_VF =sum_VF +(1.0_WP-ls%VF(i+ii,j+jj,k+kk)) + sum_VFQ1=sum_VFQ1+(1.0_WP-ls%VF(i+ii,j+jj,k+kk))*fs%Q(i+ii,j+jj,k+kk,1) + sum_VFQ2=sum_VFQ2+(1.0_WP-ls%VF(i+ii,j+jj,k+kk))*fs%Q(i+ii,j+jj,k+kk,2) + end do; end do; end do + if (sum_VF.gt.0.0_WP) then + fs%Q(i,j,k,1)=(1.0_WP-ls%VF(i,j,k))*fs%Q(i,j,k,1)+ls%VF(i,j,k)*sum_VFQ1/sum_VF + fs%Q(i,j,k,2)=(1.0_WP-ls%VF(i,j,k))*fs%Q(i,j,k,2)+ls%VF(i,j,k)*sum_VFQ2/sum_VF + end if + ! No-slip now that density is determined + fs%Q(i,j,k,3)=(1.0_WP-0.5_WP*(ls%VF(i-1,j,k)+ls%VF(i,j,k)))*fs%Q(i,j,k,3)+0.5_WP*(fs%Q(i-1,j,k,1)+fs%Q(i,j,k,1))*ls%VFU(i,j,k) + fs%Q(i,j,k,4)=(1.0_WP-0.5_WP*(ls%VF(i,j-1,k)+ls%VF(i,j,k)))*fs%Q(i,j,k,4)+0.5_WP*(fs%Q(i,j-1,k,1)+fs%Q(i,j,k,1))*ls%VFV(i,j,k) + fs%Q(i,j,k,5)=(1.0_WP-0.5_WP*(ls%VF(i,j,k-1)+ls%VF(i,j,k)))*fs%Q(i,j,k,5)+0.5_WP*(fs%Q(i,j,k-1,1)+fs%Q(i,j,k,1))*ls%VFW(i,j,k) + end do + end do + end do + ! Communicate + call fs%cfg%sync(fs%Q(:,:,:,1)) + call fs%cfg%sync(fs%Q(:,:,:,2)) + call fs%cfg%sync(fs%Q(:,:,:,3)) + call fs%cfg%sync(fs%Q(:,:,:,4)) + call fs%cfg%sync(fs%Q(:,:,:,5)) + ! Rebuild primitive variables + call fs%get_primitive() + end subroutine apply_ibm + + + !> Apply boundary conditions + subroutine apply_bconds() + implicit none + integer :: i,j,k + + ! Apply clipped Neumann on primitive variables in x+ + if (.not.fs%cfg%xper.and.fs%cfg%iproc.eq.fs%cfg%npx) then + do k=fs%cfg%kmino_,fs%cfg%kmaxo_; do j=fs%cfg%jmino_,fs%cfg%jmaxo_ + ! Copy over from imax to imax+1 and above + do i=fs%cfg%imax+1,fs%cfg%imaxo + ! Copy primitive variables + ls%VF(i,j,k)=ls%VF(fs%cfg%imax,j,k) + fs%Q(i,j,k,1)=fs%Q(fs%cfg%imax,j,k,1) + fs%P(i,j,k)=fs%P(fs%cfg%imax,j,k) + fs%I(i,j,k)=fs%I(fs%cfg%imax,j,k) + fs%U(i,j,k)=max(fs%U(fs%cfg%imax,j,k),0.0_WP) + fs%V(i,j,k)=fs%V(fs%cfg%imax,j,k) + fs%W(i,j,k)=fs%W(fs%cfg%imax,j,k) + end do + end do; end do + end if + + ! Apply clipped Neumann on primitive variables in y+ + if (.not.fs%cfg%yper.and.fs%cfg%jproc.eq.fs%cfg%npy) then + do k=fs%cfg%kmino_,fs%cfg%kmaxo_; do i=fs%cfg%imino_,fs%cfg%imaxo_ + ! Copy over from jmax to jmax+1 and above + do j=fs%cfg%jmax+1,fs%cfg%jmaxo + ! Copy primitive variables + ls%VF(i,j,k)=ls%VF(i,fs%cfg%jmax,k) + fs%Q(i,j,k,1)=fs%Q(i,fs%cfg%jmax,k,1) + fs%P(i,j,k)=fs%P(i,fs%cfg%jmax,k) + fs%I(i,j,k)=fs%I(i,fs%cfg%jmax,k) + fs%U(i,j,k)=fs%U(i,fs%cfg%jmax,k) + fs%V(i,j,k)=max(fs%V(i,fs%cfg%jmax,k),0.0_WP) + fs%W(i,j,k)=fs%W(i,fs%cfg%jmax,k) + end do + end do; end do + end if + + ! Apply clipped Neumann on primitive variables in y- + if (.not.fs%cfg%yper.and.fs%cfg%jproc.eq.1) then + do k=fs%cfg%kmino_,fs%cfg%kmaxo_; do i=fs%cfg%imino_,fs%cfg%imaxo_ + ! First copy over V from jmin+1 to jmin + fs%V(i,fs%cfg%jmin,k)=min(fs%V(i,fs%cfg%jmin+1,k),0.0_WP) + ! Then copy over from jmin to jmin-1 and below + do j=fs%cfg%jmino,fs%cfg%jmin-1 + ! Copy primitive variables + ls%VF(i,j,k)=ls%VF(i,fs%cfg%jmin,k) + fs%Q(i,j,k,1)=fs%Q(i,fs%cfg%jmin,k,1) + fs%P(i,j,k)=fs%P(i,fs%cfg%jmin,k) + fs%I(i,j,k)=fs%I(i,fs%cfg%jmin,k) + fs%U(i,j,k)=fs%U(i,fs%cfg%jmin,k) + fs%V(i,j,k)=min(fs%V(i,fs%cfg%jmin,k),0.0_WP) + fs%W(i,j,k)=fs%W(i,fs%cfg%jmin,k) + end do + end do; end do + end if + + ! Apply clipped Neumann on primitive variables in z+ + if (.not.fs%cfg%zper.and.fs%cfg%kproc.eq.fs%cfg%npz) then + do j=fs%cfg%jmino_,fs%cfg%jmaxo_; do i=fs%cfg%imino_,fs%cfg%imaxo_ + ! Copy over from kmax to kmax+1 and above + do k=fs%cfg%kmax+1,fs%cfg%kmaxo + ! Copy primitive variables + ls%VF(i,j,k)=ls%VF(i,j,fs%cfg%kmax) + fs%Q(i,j,k,1)=fs%Q(i,j,fs%cfg%kmax,1) + fs%P(i,j,k)=fs%P(i,j,fs%cfg%kmax) + fs%I(i,j,k)=fs%I(i,j,fs%cfg%kmax) + fs%U(i,j,k)=fs%U(i,j,fs%cfg%kmax) + fs%V(i,j,k)=fs%V(i,j,fs%cfg%kmax) + fs%W(i,j,k)=max(fs%W(i,j,fs%cfg%kmax),0.0_WP) + end do + end do; end do + end if + + ! Apply clipped Neumann on primitive variables in z- + if (.not.fs%cfg%zper.and.fs%cfg%kproc.eq.1) then + do j=fs%cfg%jmino_,fs%cfg%jmaxo_; do i=fs%cfg%imino_,fs%cfg%imaxo_ + ! First copy over W from kmin+1 to kmin + fs%W(i,j,fs%cfg%kmin)=min(fs%W(i,j,fs%cfg%kmin+1),0.0_WP) + ! Then copy over from kmin to kmin-1 and below + do k=fs%cfg%kmino,fs%cfg%kmin-1 + ! Copy primitive variables + ls%VF(i,j,k)=ls%VF(i,j,fs%cfg%kmin) + fs%Q(i,j,k,1)=fs%Q(i,j,fs%cfg%kmin,1) + fs%P(i,j,k)=fs%P(i,j,fs%cfg%kmin) + fs%I(i,j,k)=fs%I(i,j,fs%cfg%kmin) + fs%U(i,j,k)=fs%U(i,j,fs%cfg%kmin) + fs%V(i,j,k)=fs%V(i,j,fs%cfg%kmin) + fs%W(i,j,k)=min(fs%W(i,j,fs%cfg%kmin),0.0_WP) + end do + end do; end do + end if + + ! Rebuild conserved quantities + fs%Q(:,:,:,2)=fs%Q(:,:,:,1)*fs%I + call fs%get_momentum() + + end subroutine apply_bconds + + + !> Initialization of problem solver + subroutine simulation_init + use param, only: param_read,param_exists + implicit none + + ! Allocate work arrays + allocate_work_arrays: block + allocate(dQdt (cfg%imino_:cfg%imaxo_,cfg%jmino_:cfg%jmaxo_,cfg%kmino_:cfg%kmaxo_,1:5,1:4)) + end block allocate_work_arrays + + ! Initialize time tracker with 2 subiterations + initialize_timetracker: block + time=timetracker(amRoot=cfg%amRoot) + call param_read('Max timestep size',time%dtmax) + call param_read('Max cfl number',time%cflmax) + call param_read('Max time',time%tmax) + time%dt=time%dtmax + time%itmax=2 + end block initialize_timetracker + + + + ! ! Initialize Lagrangian solid solver + ! initialize_lss: block + ! use mpi_f08, only: MPI_ALLREDUCE,MPI_MAX,MPI_INTEGER + ! real(WP) :: dx,mu,kk,max_stretch,Lx,Ly,Lz + ! real(WP) :: xmin,xmax,ymin,ymax,zmin,zmax,ratio,P_load + ! integer :: np,nt,nx,ny,nz,ierr,global_index + ! type triangle_type + ! real(WP), dimension(3) :: norm + ! real(WP), dimension(3) :: v1 + ! real(WP), dimension(3) :: v2 + ! real(WP), dimension(3) :: v3 + ! end type triangle_type + ! type(triangle_type), dimension(:), allocatable :: t + + + ! ! Create solver + ! ls=lss(cfg=cfg,name='solid') + ! !call fs%initialize(cfg=cfg,name='Compressible NS') + + + ! ! Set material properties + ! call param_read('Elastic Modulus',ls%elastic_modulus) + ! call param_read('Poisson Ratio',ls%poisson_ratio) + ! call param_read('Solid density',ls%rho) + ! call param_read('Critical Energy Release Rate',ls%crit_energy) + + ! ! Maximum timestep size used for particles + ! call param_read('Particle timestep size',ls_dt_max,default=huge(1.0_WP)) + ! ls_dt=min(ls_dt_max,time%dtmax) + + ! ! Discretization + ! ! ls%delta=fs%cfg%min_meshsize*1.01 + ! ! Load',P_load) + ! call param_read('Lx',Lx) + ! call param_read('Ly',Ly) + ! call param_read('Lz',Lz) + ! call param_read('Subdivisions',ny) + ! nz = ny + ! nx = NINT(Lx/Lz)*ny + ! call param_read('Horizon Ratio',ratio) + ! ls%delta = Ly/real(ny,WP)*ratio + ! ! Output some info on stretch + ! mu=ls%elastic_modulus/(2.0_WP+2.0_WP*ls%poisson_ratio) + ! kk=ls%elastic_modulus/(3.0_WP-6.0_WP*ls%poisson_ratio) + ! max_stretch=sqrt(ls%crit_energy/((3.0_WP*mu+(kk-5.0_WP*mu/3.0_WP)*0.75_WP**4)*ls%delta)) + + ! ! Only root process initializes solid particles + ! if (ls%cfg%amRoot) then + ! ! Read the STL file and get domain extents and levelset + ! print*, Lx * Ly * Lz / real(ny*nz*nx,WP) + ! read_bin: block + + ! use messager, only: die + ! integer :: p,iunit,ierr, wall_np, i, j, k + ! global_index = 0 + ! target_index = 0 + + ! ! Read in grid definition + ! wall_np = ny*nz*(nx+3) + ! ! call ls%resize(np+wall_np) + ! call ls%resize(wall_np) + ! p=0 + ! do i=1,nx+3 + ! do j=1,ny + ! do k=1,nz + ! p = p+1 + ! ls%p(p)%pos(1) = (i-1) * (Lx/real(nx,WP)) + ! ls%p(p)%pos(2) = (j) * (Ly/real(ny,WP)) - Ly/2.0_WP + ! ls%p(p)%pos(3) = (k) * (Lz/real(nz,WP)) - Lz/2.0_WP + ! ls%p(p)%vol = Lx * Ly * Lz / real(ny*nz*nx,WP) + ! ls%p(p)%id=1 + ! if(i.le.3) ls%p(p)%id=-2 + + ! ls%p(p)%vel=[0.0_WP,0.0_WP,0.0_WP] + ! ! Zero out force + ! ls%p(p)%Abond=0.0_WP + ! ! Zero out fluid unless end, using this for the load + ! ls%p(p)%Afluid=0.0_WP + ! !if(i.eq.nx+3) ls%p(p)%Afluid=[(P_load*Ly*Lz)/(ls%rho*ls%p(p)%vol),0.0_WP,0.0_WP] + ! ! Locate the particle on the mesh + ! ls%p(p)%ind=ls%cfg%get_ijk_global(ls%p(p)%pos,[ls%cfg%imin,ls%cfg%jmin,ls%cfg%kmin]) + ! ! Assign a unique integer to particle + ! ls%p(p)%i=p + ! ! Activate the particle + ! ls%p(p)%flag=0 + ! if(i.eq.(nx/2+1).and.j.eq.(ny/2+1).and.k.eq.(nz/2+1)) target_index = p + ! end do + ! end do + ! end do + + ! np = wall_np + ! end block read_bin + ! end if + + ! ! Allreduce with MPI_MAX ensures the nonzero index propagates to all + ! call MPI_ALLREDUCE(target_index, global_index, 1, MPI_INTEGER, MPI_MAX, ls%cfg%comm, ierr) + + ! ! Update target_index globally + ! target_index = global_index + + + ! ! Communicate particles + ! call ls%sync() + + ! call get_tracked_particle() + + ! ! Get initial volume fraction + ! ! call ls%update_VF() + + ! ! Initalize bonds + ! call ls%bond_init() + + ! if (ls%cfg%amRoot) then + ! print*,"===== Solid Setup Description =====" + ! print*,'Number of particles', np + ! print*,'Maximum stretching =',max_stretch + ! end if + + ! end block initialize_lss + + initialize_lss: block + use mpi_f08, only: MPI_ALLREDUCE,MPI_MAX,MPI_INTEGER + real(WP) :: dx,mu,kk,max_stretch,Lx,Ly,Lz + real(WP) :: xmin,xmax,ymin,ymax,zmin,zmax,ratio,dist,net_vol,center_dist,prev_center_dist + real(WP), dimension(3) :: location + integer :: np,nt,nx,ny,nz,ierr,global_index + type triangle_type + real(WP), dimension(3) :: norm + real(WP), dimension(3) :: v1 + real(WP), dimension(3) :: v2 + real(WP), dimension(3) :: v3 + end type triangle_type + type(triangle_type), dimension(:), allocatable :: t + + + location=[0.5_WP,0.03_WP,0.03_WP] + prev_center_dist=huge(1.0_WP) + + ! Create solver + ls=lss(cfg=cfg,name='solid') + !call fs%initialize(cfg=cfg,name='Compressible NS') + + + ! Set material properties + call param_read('Elastic Modulus',ls%elastic_modulus) + call param_read('Poisson Ratio',ls%poisson_ratio) + call param_read('Solid density',ls%rho) + call param_read('Critical Energy Release Rate',ls%crit_energy) + + ! Maximum timestep size used for particles + call param_read('Particle timestep size',ls_dt_max,default=huge(1.0_WP)) + ls_dt=min(ls_dt_max,time%dtmax) + + ! Discretization + ! ls%delta=fs%cfg%min_meshsize*1.01 + ! Load',P_load) + call param_read('Horizon Ratio',ratio) + call param_read('Mean Particle Spacing',dist) + ls%delta = dist*ratio + print*, "Delta :", ls%delta + ! Output some info on stretch + mu=ls%elastic_modulus/(2.0_WP+2.0_WP*ls%poisson_ratio) + kk=ls%elastic_modulus/(3.0_WP-6.0_WP*ls%poisson_ratio) + max_stretch=sqrt(ls%crit_energy/((3.0_WP*mu+(kk-5.0_WP*mu/3.0_WP)*0.75_WP**4)*ls%delta)) + + ! Only root process initializes solid particles + if (ls%cfg%amRoot) then + ! Read the STL file and get domain extents and levelset + read_bin: block + use messager, only: die + integer :: p,iunit,ierr + character(len=80) :: partfile + call param_read('Particle file',partfile) + open(newunit=iunit,file=trim(partfile),access="stream",form="unformatted",action="read",status="old",iostat=ierr) + if(ierr.ne.0) call die('[read_stl] Could not open file: '//trim(partfile)) + read(iunit) np + call ls%resize(np) + do p=1,np + center_dist = 0.0_WP + read(iunit) ls%p(p)%pos(1), ls%p(p)%pos(2), ls%p(p)%pos(3), ls%p(p)%vol + ! Set object id and velocity + ls%p(p)%gd = 1.0_WP + ls%p(p)%gb = 1.0_WP + ls%p(p)%id=1 + if(ls%p(p)%pos(1)<=epsilon(1.0_WP)) ls%p(p)%id=-2 + ls%p(p)%vel=[0.0_WP,0.0_WP,0.0_WP] + if(ls%p(p)%pos(1)>epsilon(1.0_WP)) net_vol=net_vol+ls%p(p)%vol + ! Zero out force + ls%p(p)%Abond=0.0_WP + ! Zero out fluid unless end, using this for the load + ls%p(p)%Afluid=0.0_WP + !if(i.eq.nx+3) ls%p(p)%Afluid=[(P_load*Ly*Lz)/(ls%rho*ls%p(p)%vol),0.0_WP,0.0_WP] + ! Locate the particle on the mesh + ls%p(p)%ind=ls%cfg%get_ijk_global(ls%p(p)%pos,[ls%cfg%imin,ls%cfg%jmin,ls%cfg%kmin]) + ! Assign a unique integer to particle + ls%p(p)%i=p + ! Activate the particle + ls%p(p)%flag=0 + center_dist=sqrt(dot_product((ls%p(p)%pos - location),(ls%p(p)%pos - location))) + if(center_dist < prev_center_dist) then + target_index = p + prev_center_dist=center_dist + end if + end do + close(iunit) + print*, "Net Volume: ", net_vol + end block read_bin + end if + + ! Allreduce with MPI_MAX ensures the nonzero index propagates to all + call MPI_ALLREDUCE(target_index, global_index, 1, MPI_INTEGER, MPI_MAX, ls%cfg%comm, ierr) + + ! Update target_index globally + target_index = global_index + + + ! Communicate particles + call ls%sync() + + call get_tracked_particle() + + ! Get initial volume fraction + ! call ls%update_VF() + + ! Initalize bonds + call ls%bond_init() + + if (ls%cfg%amRoot) then + print*,"===== Solid Setup Description =====" + print*,'Number of particles', np + print*,'Maximum stretching =',max_stretch + end if + + end block initialize_lss + + + ! Create partmesh object for visualizing Lagrangian particles + create_pmesh: block + use lss_class, only: max_bond + integer :: i,n,nbond + pmesh=partmesh(nvar=5,nvec=4,name='solid') + pmesh%varname(1)='failfrac' + pmesh%varname(2)='dilatation' + pmesh%varname(3)='id' + pmesh%varname(4)='nbond' + pmesh%varname(5)='ste' + + pmesh%vecname(1)='velocity' + pmesh%vecname(2)='bond_force' + pmesh%vecname(3)='Gd' + pmesh%vecname(4)='Gb' + call ls%update_partmesh(pmesh) + do i=1,ls%np_ + pmesh%var(1,i)=0.0_WP + nbond=0 + do n=1,max_bond + if (ls%p(i)%ibond(n).gt.0) nbond=nbond+1 + end do + if (ls%p(i)%nbond.gt.0) then + pmesh%var(1,i)=1.0_WP-real(nbond,WP)/real(ls%p(i)%nbond,WP) + else + pmesh%var(1,i)=0.0_WP + end if + pmesh%var(2,i) =ls%p(i)%dil + pmesh%var(3,i) =ls%p(i)%id + pmesh%vec(:,1,i)=ls%p(i)%vel + pmesh%vec(:,2,i)=ls%p(i)%Abond + pmesh%var(4,i) =ls%p(i)%nbond + pmesh%var(5,i) =ls%p(i)%ste + pmesh%vec(:,3,i) =ls%p(i)%gd + pmesh%vec(:,4,i) =ls%p(i)%gb + end do + end block create_pmesh + + ! Add Ensight output + create_ensight: block + ! Create Ensight output from cfg + ens_out=ensight(cfg=cfg,name='shock') + ! Create event for Ensight output + ens_evt=event(time=time,name='Ensight output') + call param_read('Ensight output period',ens_evt%tper) + ! Add variables to output + call ens_out%add_particle('particles',pmesh) + ! Output to ensight + if (ens_evt%occurs()) call ens_out%write_data(time%t) + end block create_ensight + + + ! Create monitor files + create_monitor: block + real(WP) :: cfl + ! Prepare some info about fields + call ls%get_cfl(time%dt,time%cfl) + call ls%get_max() + ! Create solid monitor + sfile=monitor(ls%cfg%amRoot,'solid') + call sfile%add_column(time%n,'Timestep number') + call sfile%add_column(time%t,'Time') + call sfile%add_column(ls_dt,'Particle dt') + call sfile%add_column(time%cfl,'Maximum CFL') + call sfile%add_column(ls%np,'Particle number') + call sfile%add_column(ls%VFmax,'VFmax') + call sfile%add_column(ls%Umin,'Particle Umin') + call sfile%add_column(ls%Umax,'Particle Umax') + call sfile%add_column(ls%Vmin,'Particle Vmin') + call sfile%add_column(ls%Vmax,'Particle Vmax') + call sfile%add_column(ls%Wmin,'Particle Wmin') + call sfile%add_column(ls%Wmax,'Particle Wmax') + call sfile%add_column(ls%ibmForce(1),'Particle Fx') + call sfile%add_column(ls%ibmForce(2),'Particle Fy') + call sfile%add_column(ls%ibmForce(3),'Particle Fz') + call sfile%write() + dispfile=monitor(ls%cfg%amRoot,'displacement') + call dispfile%add_column(time%n,'Timestep number') + call dispfile%add_column(time%t,'Time') + call dispfile%add_column(ls_dt,'Particle dt') + call dispfile%add_column(target_position(1),'X') + call dispfile%add_column(target_position(2),'Y') + call dispfile%add_column(target_position(3),'Z') + call dispfile%write() + end block create_monitor + + end subroutine simulation_init + + + !> Perform an NGA2 simulation + subroutine simulation_run + implicit none + real(WP) :: cfl + logical :: first_time + + first_time = .true. + ! Perform time integration + do while (.not.time%done()) + + ! Increment time + call ls%get_cfl(time%dt,time%cfl) + ! call fs%get_cfl(time%dt,cfl); time%cfl=max(time%cfl,cfl) + call time%adjust_dt() + call time%increment() + + ! Advance solid solver + solid: block + real(WP) :: dt_done,mydt + ! Sub-iteratore + call ls%get_cfl(ls_dt,cfl=cfl) + if (cfl.gt.0.0_WP) ls_dt=min(ls_dt*time%cflmax/cfl,ls_dt_max) + dt_done=0.0_WP + do while (dt_done.lt.time%dtmid) + ! Decide the timestep size + if(first_time) then + call ls%stretch(dt =mydt) + first_time=.false. + dt_done=dt_done+mydt + else + mydt=min(ls_dt,time%dtmid-dt_done) + ! ! Advance particles + call ls%advance(dt =mydt) + ! ! Increment + dt_done=dt_done+mydt + end if + + end do + end block solid + + !> Perform and output monitoring + call ls%get_max() + call get_tracked_particle() + call sfile%write() + call dispfile%write() + + + ! Output to ensight + if (ens_evt%occurs()) then + update_pmesh: block + use lss_class, only: max_bond + integer :: i,n,nbond + call ls%update_partmesh(pmesh) + do i=1,ls%np_ + nbond=0 + do n=1,max_bond + if (ls%p(i)%ibond(n).gt.0) nbond=nbond+1 + end do + if (ls%p(i)%nbond.gt.0) then + pmesh%var(1,i)=1.0_WP-real(nbond,WP)/real(ls%p(i)%nbond,WP) + else + pmesh%var(1,i)=0.0_WP + end if + pmesh%var(2,i) =ls%p(i)%dil + pmesh%var(3,i) =ls%p(i)%id + pmesh%vec(:,1,i)=ls%p(i)%vel + pmesh%vec(:,2,i)=ls%p(i)%Abond + pmesh%var(4,i) =ls%p(i)%nbond + pmesh%var(5,i) =ls%p(i)%ste + pmesh%vec(:,3,i) =ls%p(i)%Gd + pmesh%vec(:,4,i) =ls%p(i)%Gb + + + end do + end block update_pmesh + call ens_out%write_data(time%t) + end if + + end do + + end subroutine simulation_run + + + !> Finalize the NGA2 simulation + subroutine simulation_final + implicit none + + ! Get rid of all objects - need destructors + ! monitor + ! ensight + ! bcond + ! timetracker + + ! Deallocate work arrays + deallocate(dQdt) + end subroutine simulation_final + + +end module simulation diff --git a/examples/beam_test/src/simulation_working.f90 b/examples/beam_test/src/simulation_working.f90 new file mode 100644 index 000000000..cddf0d3e5 --- /dev/null +++ b/examples/beam_test/src/simulation_working.f90 @@ -0,0 +1,753 @@ +!> Various definitions and tools for running an NGA2 simulation +module simulation + use precision, only: WP,SP + use geometry, only: cfg + use spcomp_class, only: spcomp + use lss_class, only: lss + use timetracker_class, only: timetracker + use ensight_class, only: ensight + use partmesh_class, only: partmesh + use event_class, only: event + use monitor_class, only: monitor + implicit none + private + + !> Get a couple linear solvers, an incompressible flow solver and corresponding time tracker + type(spcomp), public :: fs + type(lss), public :: ls + type(timetracker), public :: time + + !> Ensight postprocessing + type(partmesh) :: pmesh + type(ensight) :: ens_out + type(event) :: ens_evt + + !> Simulation monitor file + type(monitor) :: mfile,cflfile,consfile,sfile,dispfile + + public :: simulation_init,simulation_run,simulation_final + + !> Private work arrays + real(WP), dimension(:,:,:,:,:), allocatable :: dQdt + real(WP), dimension(:,:,:) , allocatable :: Ui,Vi,Wi,Ma,beta,visc,visc_t,div + !> Post-shock viscosity and temperature + real(WP) :: visc0,T0 + + !> Equations of state + real(WP) :: Pinf,Gamma,Cv,Prandtl + + !> Flow parameters + real(WP) :: Ms,Xs,Rcyl + real(WP) :: rho1,p1,u1,M1 + real(WP) :: rho2,p2,u2,M2 + real(WP) :: Re + + !> Max timestep size for solid solver + real(WP) :: ls_dt,ls_dt_max + + integer :: target_index + real(WP), dimension(3) :: target_position + + + contains + + + !> Function that returns a smooth Heaviside of thickness delta + real(WP) function Hshock(x,delta) + real(WP), intent(in) :: x,delta + ! Goes from 0 to 1 as x goes from begative to positive + Hshock=1.0_WP/(1.0_WP+exp(-x/delta)) + end function Hshock + + !> P=EOS(RHO,I) + pure real(WP) function get_P(RHO,I) + implicit none + real(WP), intent(in) :: RHO,I + get_P=RHO*I*(Gamma-1.0_WP)-Gamma*Pinf + end function get_P + !> T=f(RHO,P) + pure real(WP) function get_T(RHO,P) + implicit none + real(WP), intent(in) :: RHO,P + get_T=(P+Pinf)/(Cv*RHO*(Gamma-1.0_WP)) + end function get_T + !> RHO=f(T,P) + pure real(WP) function get_RHO(T,P) + implicit none + real(WP), intent(in) :: T,P + get_RHO=(P+Pinf)/(Cv*T*(Gamma-1.0_WP)) + end function get_RHO + !> I=EOS(RHO,P) + pure real(WP) function get_I(RHO,P) + implicit none + real(WP), intent(in) :: RHO,P + get_I=(P+Gamma*Pinf)/(RHO*(Gamma-1.0_WP)) + end function get_I + !> C=f(RHO,P) + pure real(WP) function get_C(RHO,P) + implicit none + real(WP), intent(in) :: RHO,P + get_C=sqrt(Gamma*(P+Pinf)/RHO) + end function get_C + !> S=f(RHO,P) + pure real(WP) function get_S(RHO,P) + implicit none + real(WP), intent(in) :: RHO,P + get_S=Cv*log((P+Pinf)/RHO**Gamma) + end function get_S + + subroutine get_tracked_particle() + use mpi_f08 + implicit none + integer :: i, ierr + real(WP) :: local_pos(3), global_pos(3) + + local_pos = 0.0_WP + + do i=1,ls%np_ + if (ls%p(i)%i.eq.target_index) then + local_pos = ls%p(i)%pos + end if + end do + call MPI_ALLREDUCE(local_pos, global_pos, 3, MPI_DOUBLE_PRECISION, MPI_SUM, ls%cfg%comm, ierr) + + target_position = global_pos + end subroutine + + !> Calculate viscosities + subroutine prepare_viscosities() + implicit none + integer :: i,j,k + real(WP) :: S + ! Get viscosity from Sutherland's law + S=110.4_WP/273.15_WP*T0 + do k=fs%cfg%kmino_,fs%cfg%kmaxo_ + do j=fs%cfg%jmino_,fs%cfg%jmaxo_ + do i=fs%cfg%imino_,fs%cfg%imaxo_ + visc(i,j,k)=visc0*(T0+S)/(fs%T(i,j,k)+S)*(fs%T(i,j,k)/T0)**1.5_WP + end do + end do + end do + ! Get LAD + call fs%get_viscartif(dt=time%dt,beta=beta); fs%BETA=fs%Q(:,:,:,1)*beta + ! Get eddy viscosity + call fs%get_vreman (dt=time%dt,visc=visc_t); fs%VISC=fs%Q(:,:,:,1)*visc_t+visc + ! Recompute thermal conductivity + fs%diff=Gamma*Cv*fs%visc/Prandtl + ! Add LAD + fs%VISC=fs%VISC+0.002_WP*fs%BETA + end subroutine prepare_viscosities + + + !> Calculate velocity divergence + subroutine get_div() + implicit none + integer :: i,j,k + do k=fs%cfg%kmino_,fs%cfg%kmaxo_-1; do j=fs%cfg%jmino_,fs%cfg%jmaxo_-1; do i=fs%cfg%imino_,fs%cfg%imaxo_-1 + div(i,j,k)=fs%dxi*(fs%U(i+1,j,k)-fs%U(i,j,k))+fs%dyi*(fs%V(i,j+1,k)-fs%V(i,j,k))+fs%dzi*(fs%W(i,j,k+1)-fs%W(i,j,k)) + end do; end do; end do + call fs%cfg%sync(div) + if (.not.fs%cfg%xper.and.fs%cfg%iproc.eq.fs%cfg%npx) div(fs%cfg%imaxo,:,:)=div(fs%cfg%imaxo-1,:,:) + if (.not.fs%cfg%yper.and.fs%cfg%jproc.eq.fs%cfg%npy) div(:,fs%cfg%jmaxo,:)=div(:,fs%cfg%jmaxo-1,:) + if (.not.fs%cfg%zper.and.fs%cfg%kproc.eq.fs%cfg%npz) div(:,:,fs%cfg%kmaxo)=div(:,:,fs%cfg%kmaxo-1) + end subroutine get_div + + + !> Overwrite cosnerved variables using volume-of-solid IBM + subroutine apply_ibm() + implicit none + integer :: i,j,k,ii,jj,kk + real(WP) :: sum_VF,sum_VFQ1,sum_VFQ2 + do k=cfg%kmin_,cfg%kmax_ + do j=cfg%jmin_,cfg%jmax_ + do i=cfg%imin_,cfg%imax_ + if (ls%VF(i,j,k).eq.0.0_WP) cycle + ! Neumann: VF-weighted neighbor average for Q(1) and Q(2) + sum_VF=0.0_WP; sum_VFQ1=0.0_WP; sum_VFQ2=0.0_WP + do kk=-1,1; do jj=-1,1; do ii=-1,1 + if (ii.eq.0.and.jj.eq.0.and.kk.eq.0) cycle + sum_VF =sum_VF +(1.0_WP-ls%VF(i+ii,j+jj,k+kk)) + sum_VFQ1=sum_VFQ1+(1.0_WP-ls%VF(i+ii,j+jj,k+kk))*fs%Q(i+ii,j+jj,k+kk,1) + sum_VFQ2=sum_VFQ2+(1.0_WP-ls%VF(i+ii,j+jj,k+kk))*fs%Q(i+ii,j+jj,k+kk,2) + end do; end do; end do + if (sum_VF.gt.0.0_WP) then + fs%Q(i,j,k,1)=(1.0_WP-ls%VF(i,j,k))*fs%Q(i,j,k,1)+ls%VF(i,j,k)*sum_VFQ1/sum_VF + fs%Q(i,j,k,2)=(1.0_WP-ls%VF(i,j,k))*fs%Q(i,j,k,2)+ls%VF(i,j,k)*sum_VFQ2/sum_VF + end if + ! No-slip now that density is determined + fs%Q(i,j,k,3)=(1.0_WP-0.5_WP*(ls%VF(i-1,j,k)+ls%VF(i,j,k)))*fs%Q(i,j,k,3)+0.5_WP*(fs%Q(i-1,j,k,1)+fs%Q(i,j,k,1))*ls%VFU(i,j,k) + fs%Q(i,j,k,4)=(1.0_WP-0.5_WP*(ls%VF(i,j-1,k)+ls%VF(i,j,k)))*fs%Q(i,j,k,4)+0.5_WP*(fs%Q(i,j-1,k,1)+fs%Q(i,j,k,1))*ls%VFV(i,j,k) + fs%Q(i,j,k,5)=(1.0_WP-0.5_WP*(ls%VF(i,j,k-1)+ls%VF(i,j,k)))*fs%Q(i,j,k,5)+0.5_WP*(fs%Q(i,j,k-1,1)+fs%Q(i,j,k,1))*ls%VFW(i,j,k) + end do + end do + end do + ! Communicate + call fs%cfg%sync(fs%Q(:,:,:,1)) + call fs%cfg%sync(fs%Q(:,:,:,2)) + call fs%cfg%sync(fs%Q(:,:,:,3)) + call fs%cfg%sync(fs%Q(:,:,:,4)) + call fs%cfg%sync(fs%Q(:,:,:,5)) + ! Rebuild primitive variables + call fs%get_primitive() + end subroutine apply_ibm + + + !> Apply boundary conditions + subroutine apply_bconds() + implicit none + integer :: i,j,k + + ! Apply clipped Neumann on primitive variables in x+ + if (.not.fs%cfg%xper.and.fs%cfg%iproc.eq.fs%cfg%npx) then + do k=fs%cfg%kmino_,fs%cfg%kmaxo_; do j=fs%cfg%jmino_,fs%cfg%jmaxo_ + ! Copy over from imax to imax+1 and above + do i=fs%cfg%imax+1,fs%cfg%imaxo + ! Copy primitive variables + ls%VF(i,j,k)=ls%VF(fs%cfg%imax,j,k) + fs%Q(i,j,k,1)=fs%Q(fs%cfg%imax,j,k,1) + fs%P(i,j,k)=fs%P(fs%cfg%imax,j,k) + fs%I(i,j,k)=fs%I(fs%cfg%imax,j,k) + fs%U(i,j,k)=max(fs%U(fs%cfg%imax,j,k),0.0_WP) + fs%V(i,j,k)=fs%V(fs%cfg%imax,j,k) + fs%W(i,j,k)=fs%W(fs%cfg%imax,j,k) + end do + end do; end do + end if + + ! Apply clipped Neumann on primitive variables in y+ + if (.not.fs%cfg%yper.and.fs%cfg%jproc.eq.fs%cfg%npy) then + do k=fs%cfg%kmino_,fs%cfg%kmaxo_; do i=fs%cfg%imino_,fs%cfg%imaxo_ + ! Copy over from jmax to jmax+1 and above + do j=fs%cfg%jmax+1,fs%cfg%jmaxo + ! Copy primitive variables + ls%VF(i,j,k)=ls%VF(i,fs%cfg%jmax,k) + fs%Q(i,j,k,1)=fs%Q(i,fs%cfg%jmax,k,1) + fs%P(i,j,k)=fs%P(i,fs%cfg%jmax,k) + fs%I(i,j,k)=fs%I(i,fs%cfg%jmax,k) + fs%U(i,j,k)=fs%U(i,fs%cfg%jmax,k) + fs%V(i,j,k)=max(fs%V(i,fs%cfg%jmax,k),0.0_WP) + fs%W(i,j,k)=fs%W(i,fs%cfg%jmax,k) + end do + end do; end do + end if + + ! Apply clipped Neumann on primitive variables in y- + if (.not.fs%cfg%yper.and.fs%cfg%jproc.eq.1) then + do k=fs%cfg%kmino_,fs%cfg%kmaxo_; do i=fs%cfg%imino_,fs%cfg%imaxo_ + ! First copy over V from jmin+1 to jmin + fs%V(i,fs%cfg%jmin,k)=min(fs%V(i,fs%cfg%jmin+1,k),0.0_WP) + ! Then copy over from jmin to jmin-1 and below + do j=fs%cfg%jmino,fs%cfg%jmin-1 + ! Copy primitive variables + ls%VF(i,j,k)=ls%VF(i,fs%cfg%jmin,k) + fs%Q(i,j,k,1)=fs%Q(i,fs%cfg%jmin,k,1) + fs%P(i,j,k)=fs%P(i,fs%cfg%jmin,k) + fs%I(i,j,k)=fs%I(i,fs%cfg%jmin,k) + fs%U(i,j,k)=fs%U(i,fs%cfg%jmin,k) + fs%V(i,j,k)=min(fs%V(i,fs%cfg%jmin,k),0.0_WP) + fs%W(i,j,k)=fs%W(i,fs%cfg%jmin,k) + end do + end do; end do + end if + + ! Apply clipped Neumann on primitive variables in z+ + if (.not.fs%cfg%zper.and.fs%cfg%kproc.eq.fs%cfg%npz) then + do j=fs%cfg%jmino_,fs%cfg%jmaxo_; do i=fs%cfg%imino_,fs%cfg%imaxo_ + ! Copy over from kmax to kmax+1 and above + do k=fs%cfg%kmax+1,fs%cfg%kmaxo + ! Copy primitive variables + ls%VF(i,j,k)=ls%VF(i,j,fs%cfg%kmax) + fs%Q(i,j,k,1)=fs%Q(i,j,fs%cfg%kmax,1) + fs%P(i,j,k)=fs%P(i,j,fs%cfg%kmax) + fs%I(i,j,k)=fs%I(i,j,fs%cfg%kmax) + fs%U(i,j,k)=fs%U(i,j,fs%cfg%kmax) + fs%V(i,j,k)=fs%V(i,j,fs%cfg%kmax) + fs%W(i,j,k)=max(fs%W(i,j,fs%cfg%kmax),0.0_WP) + end do + end do; end do + end if + + ! Apply clipped Neumann on primitive variables in z- + if (.not.fs%cfg%zper.and.fs%cfg%kproc.eq.1) then + do j=fs%cfg%jmino_,fs%cfg%jmaxo_; do i=fs%cfg%imino_,fs%cfg%imaxo_ + ! First copy over W from kmin+1 to kmin + fs%W(i,j,fs%cfg%kmin)=min(fs%W(i,j,fs%cfg%kmin+1),0.0_WP) + ! Then copy over from kmin to kmin-1 and below + do k=fs%cfg%kmino,fs%cfg%kmin-1 + ! Copy primitive variables + ls%VF(i,j,k)=ls%VF(i,j,fs%cfg%kmin) + fs%Q(i,j,k,1)=fs%Q(i,j,fs%cfg%kmin,1) + fs%P(i,j,k)=fs%P(i,j,fs%cfg%kmin) + fs%I(i,j,k)=fs%I(i,j,fs%cfg%kmin) + fs%U(i,j,k)=fs%U(i,j,fs%cfg%kmin) + fs%V(i,j,k)=fs%V(i,j,fs%cfg%kmin) + fs%W(i,j,k)=min(fs%W(i,j,fs%cfg%kmin),0.0_WP) + end do + end do; end do + end if + + ! Rebuild conserved quantities + fs%Q(:,:,:,2)=fs%Q(:,:,:,1)*fs%I + call fs%get_momentum() + + end subroutine apply_bconds + + + !> Initialization of problem solver + subroutine simulation_init + use param, only: param_read,param_exists + implicit none + + ! Allocate work arrays + allocate_work_arrays: block + allocate(dQdt (cfg%imino_:cfg%imaxo_,cfg%jmino_:cfg%jmaxo_,cfg%kmino_:cfg%kmaxo_,1:5,1:4)) + end block allocate_work_arrays + + ! Initialize time tracker with 2 subiterations + initialize_timetracker: block + time=timetracker(amRoot=cfg%amRoot) + call param_read('Max timestep size',time%dtmax) + call param_read('Max cfl number',time%cflmax) + call param_read('Max time',time%tmax) + time%dt=time%dtmax + time%itmax=2 + end block initialize_timetracker + + + + ! ! Initialize Lagrangian solid solver + ! initialize_lss: block + ! use mpi_f08, only: MPI_ALLREDUCE,MPI_MAX,MPI_INTEGER + ! real(WP) :: dx,mu,kk,max_stretch,Lx,Ly,Lz + ! real(WP) :: xmin,xmax,ymin,ymax,zmin,zmax,ratio,P_load + ! integer :: np,nt,nx,ny,nz,ierr,global_index + ! type triangle_type + ! real(WP), dimension(3) :: norm + ! real(WP), dimension(3) :: v1 + ! real(WP), dimension(3) :: v2 + ! real(WP), dimension(3) :: v3 + ! end type triangle_type + ! type(triangle_type), dimension(:), allocatable :: t + + + ! ! Create solver + ! ls=lss(cfg=cfg,name='solid') + ! !call fs%initialize(cfg=cfg,name='Compressible NS') + + + ! ! Set material properties + ! call param_read('Elastic Modulus',ls%elastic_modulus) + ! call param_read('Poisson Ratio',ls%poisson_ratio) + ! call param_read('Solid density',ls%rho) + ! call param_read('Critical Energy Release Rate',ls%crit_energy) + + ! ! Maximum timestep size used for particles + ! call param_read('Particle timestep size',ls_dt_max,default=huge(1.0_WP)) + ! ls_dt=min(ls_dt_max,time%dtmax) + + ! ! Discretization + ! ! ls%delta=fs%cfg%min_meshsize*1.01 + ! ! Load',P_load) + ! call param_read('Lx',Lx) + ! call param_read('Ly',Ly) + ! call param_read('Lz',Lz) + ! call param_read('Subdivisions',ny) + ! nz = ny + ! nx = NINT(Lx/Lz)*ny + ! call param_read('Horizon Ratio',ratio) + ! ls%delta = Ly/real(ny,WP)*ratio + ! ! Output some info on stretch + ! mu=ls%elastic_modulus/(2.0_WP+2.0_WP*ls%poisson_ratio) + ! kk=ls%elastic_modulus/(3.0_WP-6.0_WP*ls%poisson_ratio) + ! max_stretch=sqrt(ls%crit_energy/((3.0_WP*mu+(kk-5.0_WP*mu/3.0_WP)*0.75_WP**4)*ls%delta)) + + ! ! Only root process initializes solid particles + ! if (ls%cfg%amRoot) then + ! ! Read the STL file and get domain extents and levelset + ! print*, Lx * Ly * Lz / real(ny*nz*nx,WP) + ! read_bin: block + + ! use messager, only: die + ! integer :: p,iunit,ierr, wall_np, i, j, k + ! global_index = 0 + ! target_index = 0 + + ! ! Read in grid definition + ! wall_np = ny*nz*(nx+3) + ! ! call ls%resize(np+wall_np) + ! call ls%resize(wall_np) + ! p=0 + ! do i=1,nx+3 + ! do j=1,ny + ! do k=1,nz + ! p = p+1 + ! ls%p(p)%pos(1) = (i-1) * (Lx/real(nx,WP)) + ! ls%p(p)%pos(2) = (j) * (Ly/real(ny,WP)) - Ly/2.0_WP + ! ls%p(p)%pos(3) = (k) * (Lz/real(nz,WP)) - Lz/2.0_WP + ! ls%p(p)%vol = Lx * Ly * Lz / real(ny*nz*nx,WP) + ! ls%p(p)%id=1 + ! if(i.le.3) ls%p(p)%id=-2 + + ! ls%p(p)%vel=[0.0_WP,0.0_WP,0.0_WP] + ! ! Zero out force + ! ls%p(p)%Abond=0.0_WP + ! ! Zero out fluid unless end, using this for the load + ! ls%p(p)%Afluid=0.0_WP + ! !if(i.eq.nx+3) ls%p(p)%Afluid=[(P_load*Ly*Lz)/(ls%rho*ls%p(p)%vol),0.0_WP,0.0_WP] + ! ! Locate the particle on the mesh + ! ls%p(p)%ind=ls%cfg%get_ijk_global(ls%p(p)%pos,[ls%cfg%imin,ls%cfg%jmin,ls%cfg%kmin]) + ! ! Assign a unique integer to particle + ! ls%p(p)%i=p + ! ! Activate the particle + ! ls%p(p)%flag=0 + ! if(i.eq.(nx/2+1).and.j.eq.(ny/2+1).and.k.eq.(nz/2+1)) target_index = p + ! end do + ! end do + ! end do + + ! np = wall_np + ! end block read_bin + ! end if + + ! ! Allreduce with MPI_MAX ensures the nonzero index propagates to all + ! call MPI_ALLREDUCE(target_index, global_index, 1, MPI_INTEGER, MPI_MAX, ls%cfg%comm, ierr) + + ! ! Update target_index globally + ! target_index = global_index + + + ! ! Communicate particles + ! call ls%sync() + + ! call get_tracked_particle() + + ! ! Get initial volume fraction + ! ! call ls%update_VF() + + ! ! Initalize bonds + ! call ls%bond_init() + + ! if (ls%cfg%amRoot) then + ! print*,"===== Solid Setup Description =====" + ! print*,'Number of particles', np + ! print*,'Maximum stretching =',max_stretch + ! end if + + ! end block initialize_lss + + initialize_lss: block + use mpi_f08, only: MPI_ALLREDUCE,MPI_MAX,MPI_INTEGER + real(WP) :: dx,mu,kk,max_stretch,Lx,Ly,Lz + real(WP) :: xmin,xmax,ymin,ymax,zmin,zmax,ratio,dist + integer :: np,nt,nx,ny,nz,ierr,global_index + type triangle_type + real(WP), dimension(3) :: norm + real(WP), dimension(3) :: v1 + real(WP), dimension(3) :: v2 + real(WP), dimension(3) :: v3 + end type triangle_type + type(triangle_type), dimension(:), allocatable :: t + + + + + ! Create solver + ls=lss(cfg=cfg,name='solid') + !call fs%initialize(cfg=cfg,name='Compressible NS') + + + ! Set material properties + call param_read('Elastic Modulus',ls%elastic_modulus) + call param_read('Poisson Ratio',ls%poisson_ratio) + call param_read('Solid density',ls%rho) + call param_read('Critical Energy Release Rate',ls%crit_energy) + + ! Maximum timestep size used for particles + call param_read('Particle timestep size',ls_dt_max,default=huge(1.0_WP)) + ls_dt=min(ls_dt_max,time%dtmax) + + ! Discretization + ! ls%delta=fs%cfg%min_meshsize*1.01 + ! Load',P_load) + Lx = 1.0_WP + dist = 0.01_WP ! Space between particles + Lx = Lx + 3.0_WP * dist + ny = 3 + nz = 3 + nx = ceiling(Lx/dist) + call param_read('Horizon Ratio',ratio) + ls%delta = dist*ratio + print*, ls%delta + ! Output some info on stretch + mu=ls%elastic_modulus/(2.0_WP+2.0_WP*ls%poisson_ratio) + kk=ls%elastic_modulus/(3.0_WP-6.0_WP*ls%poisson_ratio) + max_stretch=sqrt(ls%crit_energy/((3.0_WP*mu+(kk-5.0_WP*mu/3.0_WP)*0.75_WP**4)*ls%delta)) + + ! Only root process initializes solid particles + if (ls%cfg%amRoot) then + ! Read the STL fiprint*, "here" + read_bin: block + + use messager, only: die + integer :: p,iunit,ierr, wall_np, i, j, k + real(WP) :: net_vol + net_vol = 0.0_WP + global_index = 0 + target_index = 0 + + ! Read in grid definition + wall_np = (3*ny)*(3*nz)*(nx) + ! call ls%resize(np+wall_np) + call ls%resize(wall_np) + p=0 + do i=1,nx + do j=1,3*ny + do k=1,3*nz + p = p+1 + + ls%p(p)%pos(1) = (i-1) * dist - 2.0_WP*dist + epsilon(1.0_WP); + ls%p(p)%pos(2) = (j-1) * (dist) - dist + ls%p(p)%pos(3) = (k-1) * (dist) - dist + ls%p(p)%vol = dist*dist*dist + ls%p(p)%gd = 1.0_WP + ls%p(p)%gb = 1.0_WP + ls%p(p)%id=1 + if(i.le.3) ls%p(p)%id=-2 + ls%p(p)%vel=[0.0_WP,0.0_WP,0.0_WP] + if(i.gt.3) net_vol=net_vol+ls%p(p)%vol + ! Zero out force + ls%p(p)%Abond=0.0_WP + ! Zero out fluid unless end, using this for the load + ls%p(p)%Afluid=0.0_WP + !if(i.eq.nx+3) ls%p(p)%Afluid=[(P_load*Ly*Lz)/(ls%rho*ls%p(p)%vol),0.0_WP,0.0_WP] + ! Locate the particle on the mesh + ls%p(p)%ind=ls%cfg%get_ijk_global(ls%p(p)%pos,[ls%cfg%imin,ls%cfg%jmin,ls%cfg%kmin]) + ! Assign a unique integer to particle + ls%p(p)%i=p + ! Activate the particle + ls%p(p)%flag=0 + if(i.eq.(nx/2+2).and.j.eq.(5).and.k.eq.(5)) target_index = p + end do + end do + end do + + np = wall_np + print*, "Net Volume: ", net_vol + end block read_bin + end if + + ! Allreduce with MPI_MAX ensures the nonzero index propagates to all + call MPI_ALLREDUCE(target_index, global_index, 1, MPI_INTEGER, MPI_MAX, ls%cfg%comm, ierr) + + ! Update target_index globally + target_index = global_index + + + ! Communicate particles + call ls%sync() + + call get_tracked_particle() + + ! Get initial volume fraction + ! call ls%update_VF() + + ! Initalize bonds + call ls%bond_init() + + if (ls%cfg%amRoot) then + print*,"===== Solid Setup Description =====" + print*,'Number of particles', np + print*,'Maximum stretching =',max_stretch + end if + + end block initialize_lss + + + ! Create partmesh object for visualizing Lagrangian particles + create_pmesh: block + use lss_class, only: max_bond + integer :: i,n,nbond + pmesh=partmesh(nvar=5,nvec=4,name='solid') + pmesh%varname(1)='failfrac' + pmesh%varname(2)='dilatation' + pmesh%varname(3)='id' + pmesh%varname(4)='nbond' + pmesh%varname(5)='ste' + + pmesh%vecname(1)='velocity' + pmesh%vecname(2)='bond_force' + pmesh%vecname(3)='Gd' + pmesh%vecname(4)='Gb' + call ls%update_partmesh(pmesh) + do i=1,ls%np_ + pmesh%var(1,i)=0.0_WP + nbond=0 + do n=1,max_bond + if (ls%p(i)%ibond(n).gt.0) nbond=nbond+1 + end do + if (ls%p(i)%nbond.gt.0) then + pmesh%var(1,i)=1.0_WP-real(nbond,WP)/real(ls%p(i)%nbond,WP) + else + pmesh%var(1,i)=0.0_WP + end if + pmesh%var(2,i) =ls%p(i)%dil + pmesh%var(3,i) =ls%p(i)%id + pmesh%vec(:,1,i)=ls%p(i)%vel + pmesh%vec(:,2,i)=ls%p(i)%Abond + pmesh%var(4,i) =ls%p(i)%nbond + pmesh%var(5,i) =ls%p(i)%ste + pmesh%vec(:,3,i) =ls%p(i)%gd + pmesh%vec(:,4,i) =ls%p(i)%gb + end do + end block create_pmesh + + ! Add Ensight output + create_ensight: block + ! Create Ensight output from cfg + ens_out=ensight(cfg=cfg,name='shock') + ! Create event for Ensight output + ens_evt=event(time=time,name='Ensight output') + call param_read('Ensight output period',ens_evt%tper) + ! Add variables to output + call ens_out%add_particle('particles',pmesh) + ! Output to ensight + if (ens_evt%occurs()) call ens_out%write_data(time%t) + end block create_ensight + + + ! Create monitor files + create_monitor: block + real(WP) :: cfl + ! Prepare some info about fields + call ls%get_cfl(time%dt,time%cfl) + call ls%get_max() + ! Create solid monitor + sfile=monitor(ls%cfg%amRoot,'solid') + call sfile%add_column(time%n,'Timestep number') + call sfile%add_column(time%t,'Time') + call sfile%add_column(ls_dt,'Particle dt') + call sfile%add_column(time%cfl,'Maximum CFL') + call sfile%add_column(ls%np,'Particle number') + call sfile%add_column(ls%VFmax,'VFmax') + call sfile%add_column(ls%Umin,'Particle Umin') + call sfile%add_column(ls%Umax,'Particle Umax') + call sfile%add_column(ls%Vmin,'Particle Vmin') + call sfile%add_column(ls%Vmax,'Particle Vmax') + call sfile%add_column(ls%Wmin,'Particle Wmin') + call sfile%add_column(ls%Wmax,'Particle Wmax') + call sfile%add_column(ls%ibmForce(1),'Particle Fx') + call sfile%add_column(ls%ibmForce(2),'Particle Fy') + call sfile%add_column(ls%ibmForce(3),'Particle Fz') + call sfile%write() + dispfile=monitor(ls%cfg%amRoot,'displacement') + call dispfile%add_column(time%n,'Timestep number') + call dispfile%add_column(time%t,'Time') + call dispfile%add_column(ls_dt,'Particle dt') + call dispfile%add_column(target_position(1),'X') + call dispfile%add_column(target_position(2),'Y') + call dispfile%add_column(target_position(3),'Z') + call dispfile%write() + end block create_monitor + + end subroutine simulation_init + + + !> Perform an NGA2 simulation + subroutine simulation_run + implicit none + real(WP) :: cfl + logical :: first_time + + first_time = .true. + ! Perform time integration + do while (.not.time%done()) + + ! Increment time + call ls%get_cfl(time%dt,time%cfl) + ! call fs%get_cfl(time%dt,cfl); time%cfl=max(time%cfl,cfl) + call time%adjust_dt() + call time%increment() + + ! Advance solid solver + solid: block + real(WP) :: dt_done,mydt + ! Sub-iteratore + call ls%get_cfl(ls_dt,cfl=cfl) + if (cfl.gt.0.0_WP) ls_dt=min(ls_dt*time%cflmax/cfl,ls_dt_max) + dt_done=0.0_WP + do while (dt_done.lt.time%dtmid) + ! Decide the timestep size + if(first_time) then + call ls%stretch(dt =mydt) + first_time=.false. + dt_done=dt_done+mydt + else + mydt=min(ls_dt,time%dtmid-dt_done) + ! ! Advance particles + call ls%advance(dt =mydt) + ! ! Increment + dt_done=dt_done+mydt + end if + + end do + end block solid + + !> Perform and output monitoring + call ls%get_max() + call get_tracked_particle() + call sfile%write() + call dispfile%write() + + + ! Output to ensight + if (ens_evt%occurs()) then + update_pmesh: block + use lss_class, only: max_bond + integer :: i,n,nbond + call ls%update_partmesh(pmesh) + do i=1,ls%np_ + nbond=0 + do n=1,max_bond + if (ls%p(i)%ibond(n).gt.0) nbond=nbond+1 + end do + if (ls%p(i)%nbond.gt.0) then + pmesh%var(1,i)=1.0_WP-real(nbond,WP)/real(ls%p(i)%nbond,WP) + else + pmesh%var(1,i)=0.0_WP + end if + pmesh%var(2,i) =ls%p(i)%dil + pmesh%var(3,i) =ls%p(i)%id + pmesh%vec(:,1,i)=ls%p(i)%vel + pmesh%vec(:,2,i)=ls%p(i)%Abond + pmesh%var(4,i) =ls%p(i)%nbond + pmesh%var(5,i) =ls%p(i)%ste + pmesh%vec(:,3,i) =ls%p(i)%Gd + pmesh%vec(:,4,i) =ls%p(i)%Gb + + + end do + end block update_pmesh + call ens_out%write_data(time%t) + end if + + end do + + end subroutine simulation_run + + + !> Finalize the NGA2 simulation + subroutine simulation_final + implicit none + + ! Get rid of all objects - need destructors + ! monitor + ! ensight + ! bcond + ! timetracker + + ! Deallocate work arrays + deallocate(dQdt) + end subroutine simulation_final + + +end module simulation diff --git a/examples/beam_test/src/spcomp_class.f90 b/examples/beam_test/src/spcomp_class.f90 new file mode 100644 index 000000000..00ec1fe25 --- /dev/null +++ b/examples/beam_test/src/spcomp_class.f90 @@ -0,0 +1,942 @@ +!> Single phase compressible flow solver class: +!> Provides support for RHS calculation only +module spcomp_class + use precision, only: WP + use string, only: str_medium + use config_class, only: config + use timer_class, only: timer + implicit none + private + + ! Expose type + public :: spcomp + + !> Single phase compressible solver object definition + type :: spcomp + + ! This is the config around which solver is built + class(config), pointer :: cfg + + ! Solver name + character(len=str_medium) :: name='UNNAMED_SPCOMP' + + ! Pointers to functions to evaluate P(RHO,E), T(RHO,P), and C(RHO,P) + procedure(Pfunc_type), pointer, nopass :: getP=>NULL() + procedure(Tfunc_type), pointer, nopass :: getT=>NULL() + procedure(Cfunc_type), pointer, nopass :: getC=>NULL() + procedure(Sfunc_type), pointer, nopass :: getS=>NULL() + + ! Conserved variables: 1=RHO, 2=RHO*I, 3=RHO*U, 4=RHO*V, 5=RHO*W + integer :: nQ + real(WP), dimension(:,:,:,:), allocatable :: Q,Qold + + ! Flow velocity + real(WP), dimension(:,:,:), allocatable :: U,V,W + + ! Internal energy + real(WP), dimension(:,:,:), allocatable :: I + + ! Pressure + real(WP), dimension(:,:,:), allocatable :: P + + ! Temperature + real(WP), dimension(:,:,:), allocatable :: T + + ! Speed of sound + real(WP), dimension(:,:,:), allocatable :: C + + ! Viscosities and heat diffusivity + real(WP), dimension(:,:,:), allocatable :: VISC,BETA,DIFF + + ! Gravitational acceleration + real(WP), dimension(3) :: gravity=0.0_WP + + ! Store mesh info + real(WP) :: dx,dy,dz,dxi,dyi,dzi,vol + + ! CFL numbers + real(WP) :: CFLc_x,CFLc_y,CFLc_z !< Convective CFL numbers + real(WP) :: CFLa_x,CFLa_y,CFLa_z !< Acoustic CFL numbers + real(WP) :: CFLv_x,CFLv_y,CFLv_z !< Viscous CFL numbers + + ! Monitoring quantities for conserved variables + real(WP), dimension(:), allocatable :: Qmin,Qmax,Qint + real(WP) :: RHOKint + real(WP) :: RHOSint + + ! Monitoring quantities for primitive variables + real(WP) :: Umax,Vmax,Wmax !< Velocity stats + real(WP) :: RHOmin,RHOmax !< Density stats + real(WP) :: Imin,Imax !< Internal energy stats + real(WP) :: Pmin,Pmax !< Pressure stats + real(WP) :: Tmin,Tmax !< Temperature stats + + ! Timer + type(timer) :: trhs !< Timer for RHS calculation + + contains + procedure :: print=>spcomp_print !< Output solver to the screen + procedure :: initialize !< Initialize the flow solver + procedure :: finalize !< Finalize the flow solver + procedure :: get_div_stress !< Compute divergence of stress for LSS solver + procedure :: rhs !< Compute rhs of our equations using standard fluxes + procedure :: get_primitive !< Calculate primitive variables from conserved variables + procedure :: get_viscartif !< Calculate artifical bulk kinematic viscosity + procedure :: get_vreman !< Get kinematic eddy viscosity using Vreman's model + procedure :: get_velocity !< Calculate velocity from momentum + procedure :: get_ke !< Calculate kinetic energy per unit mass from velocity + procedure :: get_momentum !< Calculate momentum from velocity + procedure :: interp_vel !< Calculate interpolated velocity + procedure :: get_cfl !< Calculate maximum CFL + procedure :: get_info !< Calculate maximum field values + end type spcomp + + !> Interfaces for user-defined function + abstract interface + !> P=P(RHO,I) + pure real(WP) function Pfunc_type(RHO,I) + import :: WP + implicit none + real(WP), intent(in) :: RHO + real(WP), intent(in) :: I + end function Pfunc_type + !> T=T(RHO,P) + pure real(WP) function Tfunc_type(RHO,P) + import :: WP + implicit none + real(WP), intent(in) :: RHO + real(WP), intent(in) :: P + end function Tfunc_type + !> C=C(RHO,P) + pure real(WP) function Cfunc_type(RHO,P) + import :: WP + implicit none + real(WP), intent(in) :: RHO + real(WP), intent(in) :: P + end function Cfunc_type + !> S=S(RHO,P) + pure real(WP) function Sfunc_type(RHO,P) + import :: WP + implicit none + real(WP), intent(in) :: RHO + real(WP), intent(in) :: P + end function Sfunc_type + end interface + +contains + + + !> Initialization for compressible flow solver + subroutine initialize(this,cfg,name) + use messager, only: die + implicit none + class(spcomp) :: this + class(config), target, intent(in) :: cfg + character(len=*), optional :: name + + ! Set the name for the solver + if (present(name)) this%name=trim(adjustl(name)) + + ! Point to config object + this%cfg=>cfg + + ! Check that config is uniform with at least 2 cells of overlap + if (this%cfg%no.lt.2) call die('[spcomp initialize] spcomp solver requires at least 2 cells of overlap') + if (.not.all([this%cfg%uniform_x,this%cfg%uniform_y,this%cfg%uniform_z])) call die('[spcomp initialize] spcomp solver requires a uniform mesh') + + ! Store constant cell size and its inverse, handle 2D conditions, store cell volume + this%dx=this%cfg%dx(this%cfg%imin_); this%dxi=1.0_WP/this%dx; if (this%cfg%nx.eq.1) this%dxi=0.0_WP + this%dy=this%cfg%dy(this%cfg%jmin_); this%dyi=1.0_WP/this%dy; if (this%cfg%ny.eq.1) this%dyi=0.0_WP + this%dz=this%cfg%dz(this%cfg%kmin_); this%dzi=1.0_WP/this%dz; if (this%cfg%nz.eq.1) this%dzi=0.0_WP + this%vol=this%dx*this%dy*this%dz + + ! Allocate and zero out conserved variables + this%nQ=5 + allocate(this%Q (this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_,1:this%nQ)); this%Q =0.0_WP + allocate(this%Qold(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_,1:this%nQ)); this%Qold=0.0_WP + + ! Conserved variables monitoring + allocate(this%Qmin(1:this%nQ),this%Qmax(1:this%nQ),this%Qint(1:this%nQ)) + + ! Flow velocity + allocate(this%U(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)); this%U=0.0_WP + allocate(this%V(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)); this%V=0.0_WP + allocate(this%W(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)); this%W=0.0_WP + + ! Internal energy + allocate(this%I(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)); this%I=0.0_WP + + ! Pressure + allocate(this%P(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)); this%P=0.0_WP + + ! Temperature + allocate(this%T(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)); this%T=0.0_WP + + ! Speed of sound + allocate(this%C(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)); this%C=0.0_WP + + ! Viscosities and heat diffusivity + allocate(this%VISC(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)); this%VISC=0.0_WP + allocate(this%BETA(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)); this%BETA=0.0_WP + allocate(this%DIFF(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)); this%DIFF=0.0_WP + + ! Create timers + this%trhs=timer(comm=this%cfg%comm,name='RHS') + + end subroutine initialize + + + !> Obtain RHS for all equations + subroutine rhs(this,dQdt) + implicit none + class(spcomp), intent(inout) :: this + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:,1:), intent(out) :: dQdt !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_,1:nVAR) + real(WP), dimension(:,:,:,:), allocatable :: FQx,FQy,FQz + integer :: i,j,k,n + real(WP) :: w,div + real(WP), parameter :: eps=1.0e-15_WP + real(WP), dimension(-2: 0) :: wenop + real(WP), dimension(-1:+1) :: wenom + + ! Start rhs timer + call this%trhs%start() + + ! Zero out RHS + dQdt=0.0_WP + + ! ================================================================ ! + ! ======================== INVISID FLUXES ======================== ! + ! ================================================================ ! + + ! Allocate fluxes of conserved variables + allocate(FQx(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_,1:this%nQ)); FQx=0.0_WP + allocate(FQy(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_,1:this%nQ)); FQy=0.0_WP + allocate(FQz(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_,1:this%nQ)); FQz=0.0_WP + + ! Calculate standard fluxes + do k=this%cfg%kmin_,this%cfg%kmax_+1 + do j=this%cfg%jmin_,this%cfg%jmax_+1 + do i=this%cfg%imin_,this%cfg%imax_+1 + ! X fluxes + ! WENO mass flux + w=weno_weight((abs(this%Q(i-1,j,k,1)-this%Q(i-2,j,k,1))+eps)/(abs(this%Q(i,j,k,1)-this%Q(i-1,j,k,1))+eps)); wenop=0.5_WP*[ -w,1.0_WP+2.0_WP*w,1.0_WP-w] + w=weno_weight((abs(this%Q(i+1,j,k,1)-this%Q(i ,j,k,1))+eps)/(abs(this%Q(i,j,k,1)-this%Q(i-1,j,k,1))+eps)); wenom=0.5_WP*[1.0_WP-w,1.0_WP+2.0_WP*w, -w] + FQx(i,j,k,1)=-0.5_WP*(this%U(i,j,k)+abs(this%U(i,j,k)))*sum(wenop*this%Q(i-2:i ,j,k,1))& + & -0.5_WP*(this%U(i,j,k)-abs(this%U(i,j,k)))*sum(wenom*this%Q(i-1:i+1,j,k,1)) + ! Centered mass flux + !FQx(i,j,k,1)=-this%U(i,j,k)*0.5_WP*sum(this%Q(i-1:i,j,k,1)) + ! WENO internal energy flux + w=weno_weight((abs(this%I(i-1,j,k)-this%I(i-2,j,k))+eps)/(abs(this%I(i,j,k)-this%I(i-1,j,k))+eps)); wenop=0.5_WP*[ -w,1.0_WP+2.0_WP*w,1.0_WP-w] + w=weno_weight((abs(this%I(i+1,j,k)-this%I(i ,j,k))+eps)/(abs(this%I(i,j,k)-this%I(i-1,j,k))+eps)); wenom=0.5_WP*[1.0_WP-w,1.0_WP+2.0_WP*w, -w] + FQx(i,j,k,2)=0.5_WP*(FQx(i,j,k,1)-abs(-FQx(i,j,k,1)))*sum(wenop*this%I(i-2:i ,j,k))& + & +0.5_WP*(FQx(i,j,k,1)+abs(-FQx(i,j,k,1)))*sum(wenom*this%I(i-1:i+1,j,k)) + ! Centered internal energy flux + !FQx(i,j,k,2)=FQx(i,j,k,1)*0.5_WP*sum(this%I(i-1:i,j,k)) + ! Heat flux + FQx(i,j,k,2)=FQx(i,j,k,2)+0.5_WP*(this%DIFF(i-1,j,k)+this%DIFF(i,j,k))*this%dxi*(this%T(i,j,k)-this%T(i-1,j,k)) + ! Y fluxes + ! WENO mass flux + w=weno_weight((abs(this%Q(i,j-1,k,1)-this%Q(i,j-2,k,1))+eps)/(abs(this%Q(i,j,k,1)-this%Q(i,j-1,k,1))+eps)); wenop=0.5_WP*[ -w,1.0_WP+2.0_WP*w,1.0_WP-w] + w=weno_weight((abs(this%Q(i,j+1,k,1)-this%Q(i,j ,k,1))+eps)/(abs(this%Q(i,j,k,1)-this%Q(i,j-1,k,1))+eps)); wenom=0.5_WP*[1.0_WP-w,1.0_WP+2.0_WP*w, -w] + FQy(i,j,k,1)=-0.5_WP*(this%V(i,j,k)+abs(this%V(i,j,k)))*sum(wenop*this%Q(i,j-2:j ,k,1))& + & -0.5_WP*(this%V(i,j,k)-abs(this%V(i,j,k)))*sum(wenom*this%Q(i,j-1:j+1,k,1)) + ! Centered mass flux + !FQy(i,j,k,1)=-this%V(i,j,k)*0.5_WP*sum(this%Q(i,j-1:j,k,1)) + ! WENO internal energy flux + w=weno_weight((abs(this%I(i,j-1,k)-this%I(i,j-2,k))+eps)/(abs(this%I(i,j,k)-this%I(i,j-1,k))+eps)); wenop=0.5_WP*[ -w,1.0_WP+2.0_WP*w,1.0_WP-w] + w=weno_weight((abs(this%I(i,j+1,k)-this%I(i,j ,k))+eps)/(abs(this%I(i,j,k)-this%I(i,j-1,k))+eps)); wenom=0.5_WP*[1.0_WP-w,1.0_WP+2.0_WP*w, -w] + FQy(i,j,k,2)=0.5_WP*(FQy(i,j,k,1)-abs(-FQy(i,j,k,1)))*sum(wenop*this%I(i,j-2:j ,k))& + & +0.5_WP*(FQy(i,j,k,1)+abs(-FQy(i,j,k,1)))*sum(wenom*this%I(i,j-1:j+1,k)) + ! Centered internal energy flux + !FQy(i,j,k,2)=FQy(i,j,k,1)*0.5_WP*sum(this%I(i,j-1:j,k)) + ! Heat flux + FQy(i,j,k,2)=FQy(i,j,k,2)+0.5_WP*(this%DIFF(i,j-1,k)+this%DIFF(i,j,k))*this%dyi*(this%T(i,j,k)-this%T(i,j-1,k)) + ! Z fluxes + ! WENO mass flux + w=weno_weight((abs(this%Q(i,j,k-1,1)-this%Q(i,j,k-2,1))+eps)/(abs(this%Q(i,j,k,1)-this%Q(i,j,k-1,1))+eps)); wenop=0.5_WP*[ -w,1.0_WP+2.0_WP*w,1.0_WP-w] + w=weno_weight((abs(this%Q(i,j,k+1,1)-this%Q(i,j,k ,1))+eps)/(abs(this%Q(i,j,k,1)-this%Q(i,j,k-1,1))+eps)); wenom=0.5_WP*[1.0_WP-w,1.0_WP+2.0_WP*w, -w] + FQz(i,j,k,1)=-0.5_WP*(this%W(i,j,k)+abs(this%W(i,j,k)))*sum(wenop*this%Q(i,j,k-2:k ,1))& + & -0.5_WP*(this%W(i,j,k)-abs(this%W(i,j,k)))*sum(wenom*this%Q(i,j,k-1:k+1,1)) + ! Centered mass flux + !FQz(i,j,k,1)=-this%W(i,j,k)*0.5_WP*sum(this%Q(i,j,k-1:k,1)) + ! WENO internal energy flux + w=weno_weight((abs(this%I(i,j,k-1)-this%I(i,j,k-2))+eps)/(abs(this%I(i,j,k)-this%I(i,j,k-1))+eps)); wenop=0.5_WP*[ -w,1.0_WP+2.0_WP*w,1.0_WP-w] + w=weno_weight((abs(this%I(i,j,k+1)-this%I(i,j,k ))+eps)/(abs(this%I(i,j,k)-this%I(i,j,k-1))+eps)); wenom=0.5_WP*[1.0_WP-w,1.0_WP+2.0_WP*w, -w] + FQz(i,j,k,2)=0.5_WP*(FQz(i,j,k,1)-abs(-FQz(i,j,k,1)))*sum(wenop*this%I(i,j,k-2:k ))& + & +0.5_WP*(FQz(i,j,k,1)+abs(-FQz(i,j,k,1)))*sum(wenom*this%I(i,j,k-1:k+1)) + ! Centered internal energy flux + !FQz(i,j,k,2)=FQz(i,j,k,1)*0.5_WP*sum(this%I(i,j,k-1:k)) + ! Heat flux + FQz(i,j,k,2)=FQz(i,j,k,2)+0.5_WP*(this%DIFF(i,j,k-1)+this%DIFF(i,j,k))*this%dzi*(this%T(i,j,k)-this%T(i,j,k-1)) + end do + end do + end do + + ! Mass fluxes will be used to build momentum fluxes, they need to be extended by one cell on the left because of staggering + call this%cfg%sync(FQx(:,:,:,1)); if (.not.this%cfg%xper.and.this%cfg%iproc.eq.1) FQx(this%cfg%imin-1,:,:,1)=FQx(this%cfg%imin,:,:,1) + call this%cfg%sync(FQy(:,:,:,1)); if (.not.this%cfg%yper.and.this%cfg%jproc.eq.1) FQy(:,this%cfg%jmin-1,:,1)=FQy(:,this%cfg%jmin,:,1) + call this%cfg%sync(FQz(:,:,:,1)); if (.not.this%cfg%zper.and.this%cfg%kproc.eq.1) FQz(:,:,this%cfg%kmin-1,1)=FQz(:,:,this%cfg%kmin,1) + + ! Calculate cell-centered momentum fluxes with extra cell on the left due to staggering + do k=this%cfg%kmin_-1,this%cfg%kmax_ + do j=this%cfg%jmin_-1,this%cfg%jmax_ + do i=this%cfg%imin_-1,this%cfg%imax_ + FQx(i,j,k,3)=0.25_WP*sum(FQx(i:i+1,j,k,1))*sum(this%U(i:i+1,j,k))-this%P(i,j,k) + FQy(i,j,k,4)=0.25_WP*sum(FQy(i,j:j+1,k,1))*sum(this%V(i,j:j+1,k))-this%P(i,j,k) + FQz(i,j,k,5)=0.25_WP*sum(FQz(i,j,k:k+1,1))*sum(this%W(i,j,k:k+1))-this%P(i,j,k) + end do + end do + end do + + ! Calculate edge-centered momentum fluxes + do k=this%cfg%kmin_,this%cfg%kmax_+1 + do j=this%cfg%jmin_,this%cfg%jmax_+1 + do i=this%cfg%imin_,this%cfg%imax_+1 + FQy(i,j,k,3)=0.25_WP*sum(FQy(i-1:i,j,k,1))*sum(this%U(i,j-1:j,k)) + FQz(i,j,k,3)=0.25_WP*sum(FQz(i-1:i,j,k,1))*sum(this%U(i,j,k-1:k)) + FQx(i,j,k,4)=0.25_WP*sum(FQx(i,j-1:j,k,1))*sum(this%V(i-1:i,j,k)) + FQz(i,j,k,4)=0.25_WP*sum(FQz(i,j-1:j,k,1))*sum(this%V(i,j,k-1:k)) + FQx(i,j,k,5)=0.25_WP*sum(FQx(i,j,k-1:k,1))*sum(this%W(i-1:i,j,k)) + FQy(i,j,k,5)=0.25_WP*sum(FQy(i,j,k-1:k,1))*sum(this%W(i,j-1:j,k)) + end do + end do + end do + + ! Assemble time derivative for conserved variables + do k=this%cfg%kmin_,this%cfg%kmax_ + do j=this%cfg%jmin_,this%cfg%jmax_ + do i=this%cfg%imin_,this%cfg%imax_ + ! Mass and internal energy advection + dQdt(i,j,k,1)=this%dxi*(FQx(i+1,j,k,1)-FQx(i,j,k,1))+this%dyi*(FQy(i,j+1,k,1)-FQy(i,j,k,1))+this%dzi*(FQz(i,j,k+1,1)-FQz(i,j,k,1)) + dQdt(i,j,k,2)=this%dxi*(FQx(i+1,j,k,2)-FQx(i,j,k,2))+this%dyi*(FQy(i,j+1,k,2)-FQy(i,j,k,2))+this%dzi*(FQz(i,j,k+1,2)-FQz(i,j,k,2)) + ! Momentum advection and pressure stress + dQdt(i,j,k,3)=this%dxi*(FQx(i ,j,k,3)-FQx(i-1,j,k,3))+this%dyi*(FQy(i,j+1,k,3)-FQy(i,j ,k,3))+this%dzi*(FQz(i,j,k+1,3)-FQz(i,j,k ,3)) + dQdt(i,j,k,4)=this%dxi*(FQx(i+1,j,k,4)-FQx(i ,j,k,4))+this%dyi*(FQy(i,j ,k,4)-FQy(i,j-1,k,4))+this%dzi*(FQz(i,j,k+1,4)-FQz(i,j,k ,4)) + dQdt(i,j,k,5)=this%dxi*(FQx(i+1,j,k,5)-FQx(i ,j,k,5))+this%dyi*(FQy(i,j+1,k,5)-FQy(i,j ,k,5))+this%dzi*(FQz(i,j,k ,5)-FQz(i,j,k-1,5)) + ! Pressure dilatation term + dQdt(i,j,k,2)=dQdt(i,j,k,2)-this%P(i,j,k)*(this%dxi*(this%U(i+1,j,k)-this%U(i,j,k))+this%dyi*(this%V(i,j+1,k)-this%V(i,j,k))+this%dzi*(this%W(i,j,k+1)-this%W(i,j,k))) + end do + end do + end do + + ! ================================================================ ! + ! ======================== VISCOUS FLUXES ======================= ! + ! ================================================================ ! + + ! Zero out fluxes + FQx=0.0_WP; FQy=0.0_WP; FQz=0.0_WP + + ! Compute cell-centered momentum viscous fluxes + do k=this%cfg%kmin_-1,this%cfg%kmax_ + do j=this%cfg%jmin_-1,this%cfg%jmax_ + do i=this%cfg%imin_-1,this%cfg%imax_ + div=this%dxi*(this%U(i+1,j,k)-this%U(i,j,k))+this%dyi*(this%V(i,j+1,k)-this%V(i,j,k))+this%dzi*(this%W(i,j,k+1)-this%W(i,j,k)) + FQx(i,j,k,3)=2.0_WP*this%VISC(i,j,k)*this%dxi*(this%U(i+1,j,k)-this%U(i,j,k))+(this%BETA(i,j,k)-2.0_WP*this%VISC(i,j,k)/3.0_WP)*div + FQy(i,j,k,4)=2.0_WP*this%VISC(i,j,k)*this%dyi*(this%V(i,j+1,k)-this%V(i,j,k))+(this%BETA(i,j,k)-2.0_WP*this%VISC(i,j,k)/3.0_WP)*div + FQz(i,j,k,5)=2.0_WP*this%VISC(i,j,k)*this%dzi*(this%W(i,j,k+1)-this%W(i,j,k))+(this%BETA(i,j,k)-2.0_WP*this%VISC(i,j,k)/3.0_WP)*div + end do + end do + end do + + ! Compute edge-centered momentum viscous fluxes and corresponding viscous heating + do k=this%cfg%kmin_,this%cfg%kmax_+1 + do j=this%cfg%jmin_,this%cfg%jmax_+1 + do i=this%cfg%imin_,this%cfg%imax_+1 + FQy(i,j,k,3)=0.25_WP*sum(this%VISC(i-1:i,j-1:j,k))*(this%dyi*(this%U(i,j,k)-this%U(i,j-1,k))+this%dxi*(this%V(i,j,k)-this%V(i-1,j,k))); FQx(i,j,k,4)=FQy(i,j,k,3) + FQz(i,j,k,2)=FQy(i,j,k,3)*(this%dyi*(this%U(i,j,k)-this%U(i,j-1,k))+this%dxi*(this%V(i,j,k)-this%V(i-1,j,k))) + FQz(i,j,k,4)=0.25_WP*sum(this%VISC(i,j-1:j,k-1:k))*(this%dzi*(this%V(i,j,k)-this%V(i,j,k-1))+this%dyi*(this%W(i,j,k)-this%W(i,j-1,k))); FQy(i,j,k,5)=FQz(i,j,k,4) + FQx(i,j,k,2)=FQz(i,j,k,4)*(this%dzi*(this%V(i,j,k)-this%V(i,j,k-1))+this%dyi*(this%W(i,j,k)-this%W(i,j-1,k))) + FQx(i,j,k,5)=0.25_WP*sum(this%VISC(i-1:i,j,k-1:k))*(this%dxi*(this%W(i,j,k)-this%W(i-1,j,k))+this%dzi*(this%U(i,j,k)-this%U(i,j,k-1))); FQz(i,j,k,3)=FQx(i,j,k,5) + FQy(i,j,k,2)=FQx(i,j,k,5)*(this%dxi*(this%W(i,j,k)-this%W(i-1,j,k))+this%dzi*(this%U(i,j,k)-this%U(i,j,k-1))) + end do + end do + end do + + ! Assemble time derivative for conserved variables + do k=this%cfg%kmin_,this%cfg%kmax_ + do j=this%cfg%jmin_,this%cfg%jmax_ + do i=this%cfg%imin_,this%cfg%imax_ + ! Viscous momentum transport + dQdt(i,j,k,3)=dQdt(i,j,k,3)+this%dxi*(FQx(i ,j,k,3)-FQx(i-1,j,k,3))+this%dyi*(FQy(i,j+1,k,3)-FQy(i,j ,k,3))+this%dzi*(FQz(i,j,k+1,3)-FQz(i,j,k ,3)) + dQdt(i,j,k,4)=dQdt(i,j,k,4)+this%dxi*(FQx(i+1,j,k,4)-FQx(i ,j,k,4))+this%dyi*(FQy(i,j ,k,4)-FQy(i,j-1,k,4))+this%dzi*(FQz(i,j,k+1,4)-FQz(i,j,k ,4)) + dQdt(i,j,k,5)=dQdt(i,j,k,5)+this%dxi*(FQx(i+1,j,k,5)-FQx(i ,j,k,5))+this%dyi*(FQy(i,j+1,k,5)-FQy(i,j ,k,5))+this%dzi*(FQz(i,j,k ,5)-FQz(i,j,k-1,5)) + ! Viscous heating term + dQdt(i,j,k,2)=dQdt(i,j,k,2)+FQx(i,j,k,3)*this%dxi*(this%U(i+1,j,k)-this%U(i,j,k))+FQy(i,j,k,4)*this%dyi*(this%V(i,j+1,k)-this%V(i,j,k))+FQz(i,j,k,5)*this%dzi*(this%W(i,j,k+1)-this%W(i,j,k))+0.25_WP*sum(FQz(i:i+1,j:j+1,k,2))+0.25_WP*sum(FQx(i,j:j+1,k:k+1,2))+0.25_WP*sum(FQy(i:i+1,j,k:k+1,2)) + end do + end do + end do + + ! Deallocate flux arrays + deallocate(FQx,FQy,FQz) + + ! Synchronize all dQdt fields + do n=1,this%nQ; call this%cfg%sync(dQdt(:,:,:,n)); end do + + ! Stop rhs timer + call this%trhs%stop() + + contains + !> WENO switch function + real(WP) function weno_weight(ratio) + implicit none + real(WP), intent(in) :: ratio + real(WP), parameter :: lambda=0.13_WP ! Switching parameter + real(WP), parameter :: delta=0.01_WP ! Switching thickness + weno_weight=(1.0_WP-tanh((ratio-lambda)/delta))/3.0_WP+(1.0_WP-tanh((ratio-1.0_WP/lambda)/delta))/6.0_WP + end function weno_weight + end subroutine rhs + + + !> Calculate divergence of stress for LPT solver + subroutine get_div_stress(this,divx,divy,divz) + implicit none + class(spcomp), intent(inout) :: this + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(out) :: divx !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(out) :: divy !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(out) :: divz !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + real(WP), dimension(:,:,:,:), allocatable :: FQx,FQy,FQz + integer :: i,j,k + real(WP) :: div + + ! Zero out divergence of stresses + divx=0.0_WP + divy=0.0_WP + divz=0.0_WP + + ! Allocate fluxes of conserved variables + allocate(FQx(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_,1:3)); FQx=0.0_WP + allocate(FQy(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_,1:3)); FQy=0.0_WP + allocate(FQz(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_,1:3)); FQz=0.0_WP + + ! Compute cell-centered momentum fluxes + do k=this%cfg%kmin_-1,this%cfg%kmax_ + do j=this%cfg%jmin_-1,this%cfg%jmax_ + do i=this%cfg%imin_-1,this%cfg%imax_ + div=this%dxi*(this%U(i+1,j,k)-this%U(i,j,k))+this%dyi*(this%V(i,j+1,k)-this%V(i,j,k))+this%dzi*(this%W(i,j,k+1)-this%W(i,j,k)) + FQx(i,j,k,1)=2.0_WP*this%VISC(i,j,k)*this%dxi*(this%U(i+1,j,k)-this%U(i,j,k))+(this%BETA(i,j,k)-2.0_WP*this%VISC(i,j,k)/3.0_WP)*div-this%P(i,j,k) + FQy(i,j,k,2)=2.0_WP*this%VISC(i,j,k)*this%dyi*(this%V(i,j+1,k)-this%V(i,j,k))+(this%BETA(i,j,k)-2.0_WP*this%VISC(i,j,k)/3.0_WP)*div-this%P(i,j,k) + FQz(i,j,k,3)=2.0_WP*this%VISC(i,j,k)*this%dzi*(this%W(i,j,k+1)-this%W(i,j,k))+(this%BETA(i,j,k)-2.0_WP*this%VISC(i,j,k)/3.0_WP)*div-this%P(i,j,k) + end do + end do + end do + + ! Compute edge-centered momentum viscous fluxes and corresponding viscous heating + do k=this%cfg%kmin_,this%cfg%kmax_+1 + do j=this%cfg%jmin_,this%cfg%jmax_+1 + do i=this%cfg%imin_,this%cfg%imax_+1 + ! Momentum fluxes + FQy(i,j,k,1)=0.25_WP*sum(this%VISC(i-1:i,j-1:j,k))*(this%dyi*(this%U(i,j,k)-this%U(i,j-1,k))+this%dxi*(this%V(i,j,k)-this%V(i-1,j,k))); FQx(i,j,k,2)=FQy(i,j,k,1) + FQz(i,j,k,2)=0.25_WP*sum(this%VISC(i,j-1:j,k-1:k))*(this%dzi*(this%V(i,j,k)-this%V(i,j,k-1))+this%dyi*(this%W(i,j,k)-this%W(i,j-1,k))); FQy(i,j,k,3)=FQz(i,j,k,2) + FQx(i,j,k,3)=0.25_WP*sum(this%VISC(i-1:i,j,k-1:k))*(this%dxi*(this%W(i,j,k)-this%W(i-1,j,k))+this%dzi*(this%U(i,j,k)-this%U(i,j,k-1))); FQz(i,j,k,1)=FQx(i,j,k,3) + end do + end do + end do + + do i=1,3 + call this%cfg%sync(FQx(:,:,:,i)) + call this%cfg%sync(FQy(:,:,:,i)) + call this%cfg%sync(FQz(:,:,:,i)) + end do + + ! Assemble time derivative for conserved variables + do k=this%cfg%kmin_,this%cfg%kmax_ + do j=this%cfg%jmin_,this%cfg%jmax_ + do i=this%cfg%imin_,this%cfg%imax_ + ! Viscous momentum transport + divx(i,j,k)=this%dxi*(FQx(i ,j,k,1)-FQx(i-1,j,k,1))+this%dyi*(FQy(i,j+1,k,1)-FQy(i,j ,k,1))+this%dzi*(FQz(i,j,k+1,1)-FQz(i,j,k ,1)) + divy(i,j,k)=this%dxi*(FQx(i+1,j,k,2)-FQx(i ,j,k,2))+this%dyi*(FQy(i,j ,k,2)-FQy(i,j-1,k,2))+this%dzi*(FQz(i,j,k+1,2)-FQz(i,j,k ,2)) + divz(i,j,k)=this%dxi*(FQx(i+1,j,k,3)-FQx(i ,j,k,3))+this%dyi*(FQy(i,j+1,k,3)-FQy(i,j ,k,3))+this%dzi*(FQz(i,j,k ,3)-FQz(i,j,k-1,3)) + end do + end do + end do + + ! Deallocate flux arrays + deallocate(FQx,FQy,FQz) + + ! Synchronize + call this%cfg%sync(divx) + call this%cfg%sync(divy) + call this%cfg%sync(divz) + + end subroutine get_div_stress + + + !> Calculate all primitive variables from updated conserved variables + subroutine get_primitive(this) + implicit none + class(spcomp), intent(inout) :: this + integer :: i,j,k + ! Get velocity + call this%get_velocity() + ! Get primitive variables + do k=this%cfg%kmino_,this%cfg%kmaxo_; do j=this%cfg%jmino_,this%cfg%jmaxo_; do i=this%cfg%imino_,this%cfg%imaxo_ + this%I(i,j,k)=this%Q(i,j,k,2)/this%Q(i,j,k,1) + this%P(i,j,k)=this%getP(this%Q(i,j,k,1),this%I(i,j,k)) + this%C(i,j,k)=this%getC(this%Q(i,j,k,1),this%P(i,j,k)) + end do; end do; end do + ! Get temperature + if (associated(this%getT)) then + do k=this%cfg%kmino_,this%cfg%kmaxo_; do j=this%cfg%jmino_,this%cfg%jmaxo_; do i=this%cfg%imino_,this%cfg%imaxo_ + this%T(i,j,k)=this%getT(this%Q(i,j,k,1),this%P(i,j,k)) + end do; end do; end do + end if + end subroutine get_primitive + + + !> Calculate velocity from momentum and density + subroutine get_velocity(this) + implicit none + class(spcomp), intent(inout) :: this + integer :: i,j,k + ! Calculate velocity as far as possible + do k=this%cfg%kmino_+1,this%cfg%kmaxo_ + do j=this%cfg%jmino_+1,this%cfg%jmaxo_ + do i=this%cfg%imino_+1,this%cfg%imaxo_ + this%U(i,j,k)=2.0_WP*this%Q(i,j,k,3)/sum(this%Q(i-1:i,j,k,1)) + this%V(i,j,k)=2.0_WP*this%Q(i,j,k,4)/sum(this%Q(i,j-1:j,k,1)) + this%W(i,j,k)=2.0_WP*this%Q(i,j,k,5)/sum(this%Q(i,j,k-1:k,1)) + end do + end do + end do + ! Sync velocity + call this%cfg%sync(this%U) + call this%cfg%sync(this%V) + call this%cfg%sync(this%W) + ! Add last layer in each direction + if (.not.this%cfg%xper.and.this%cfg%iproc.eq.1) then + this%U(this%cfg%imino,:,:)=this%Q(this%cfg%imino,:,:,3)/(this%Q(this%cfg%imino,:,:,1)) + this%V(this%cfg%imino,:,:)=this%Q(this%cfg%imino,:,:,4)/(this%Q(this%cfg%imino,:,:,1)) + this%W(this%cfg%imino,:,:)=this%Q(this%cfg%imino,:,:,5)/(this%Q(this%cfg%imino,:,:,1)) + end if + if (.not.this%cfg%yper.and.this%cfg%jproc.eq.1) then + this%U(:,this%cfg%jmino,:)=this%Q(:,this%cfg%jmino,:,3)/(this%Q(:,this%cfg%jmino,:,1)) + this%V(:,this%cfg%jmino,:)=this%Q(:,this%cfg%jmino,:,4)/(this%Q(:,this%cfg%jmino,:,1)) + this%W(:,this%cfg%jmino,:)=this%Q(:,this%cfg%jmino,:,5)/(this%Q(:,this%cfg%jmino,:,1)) + end if + if (.not.this%cfg%zper.and.this%cfg%kproc.eq.1) then + this%U(:,:,this%cfg%kmino)=this%Q(:,:,this%cfg%kmino,3)/(this%Q(:,:,this%cfg%kmino,1)) + this%V(:,:,this%cfg%kmino)=this%Q(:,:,this%cfg%kmino,4)/(this%Q(:,:,this%cfg%kmino,1)) + this%W(:,:,this%cfg%kmino)=this%Q(:,:,this%cfg%kmino,5)/(this%Q(:,:,this%cfg%kmino,1)) + end if + end subroutine get_velocity + + + !> Calculate kinetic energy per unit mass from pre-calculated velocity + !> Need to redo this better + subroutine get_ke(this,KE) + implicit none + class(spcomp), intent(inout) :: this + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(out) :: KE !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + integer :: i,j,k + do k=this%cfg%kmino_,this%cfg%kmaxo_-1 + do j=this%cfg%jmino_,this%cfg%jmaxo_-1 + do i=this%cfg%imino_,this%cfg%imaxo_-1 + KE(i,j,k)=0.5_WP*sum(this%U(i:i+1,j,k)**2+this%V(i,j:j+1,k)**2+this%W(i,j,k:k+1)**2) + end do + end do + end do + call this%cfg%sync(KE) + if (.not.this%cfg%xper.and.this%cfg%iproc.eq.this%cfg%npx) KE(this%cfg%imaxo,:,:)=KE(this%cfg%imaxo-1,:,:) + if (.not.this%cfg%yper.and.this%cfg%jproc.eq.this%cfg%npy) KE(:,this%cfg%jmaxo,:)=KE(:,this%cfg%jmaxo-1,:) + if (.not.this%cfg%zper.and.this%cfg%kproc.eq.this%cfg%npz) KE(:,:,this%cfg%kmaxo)=KE(:,:,this%cfg%kmaxo-1) + end subroutine get_ke + + + !> Calculate momentum from velocity and density + subroutine get_momentum(this) + implicit none + class(spcomp), intent(inout) :: this + integer :: i,j,k + ! Calculate momentum as far as possible + do k=this%cfg%kmino_+1,this%cfg%kmaxo_ + do j=this%cfg%jmino_+1,this%cfg%jmaxo_ + do i=this%cfg%imino_+1,this%cfg%imaxo_ + this%Q(i,j,k,3)=0.5_WP*sum(this%Q(i-1:i,j,k,1))*this%U(i,j,k) + this%Q(i,j,k,4)=0.5_WP*sum(this%Q(i,j-1:j,k,1))*this%V(i,j,k) + this%Q(i,j,k,5)=0.5_WP*sum(this%Q(i,j,k-1:k,1))*this%W(i,j,k) + end do + end do + end do + ! Sync momentum + call this%cfg%sync(this%Q(:,:,:,3)) + call this%cfg%sync(this%Q(:,:,:,4)) + call this%cfg%sync(this%Q(:,:,:,5)) + ! Add last layer in each direction + if (.not.this%cfg%xper.and.this%cfg%iproc.eq.1) then + this%Q(this%cfg%imino,:,:,3)=this%Q(this%cfg%imino,:,:,1)*this%U(this%cfg%imino,:,:) + this%Q(this%cfg%imino,:,:,4)=this%Q(this%cfg%imino,:,:,1)*this%V(this%cfg%imino,:,:) + this%Q(this%cfg%imino,:,:,5)=this%Q(this%cfg%imino,:,:,1)*this%W(this%cfg%imino,:,:) + end if + if (.not.this%cfg%yper.and.this%cfg%jproc.eq.1) then + this%Q(:,this%cfg%jmino,:,3)=this%Q(:,this%cfg%jmino,:,1)*this%U(:,this%cfg%jmino,:) + this%Q(:,this%cfg%jmino,:,4)=this%Q(:,this%cfg%jmino,:,1)*this%V(:,this%cfg%jmino,:) + this%Q(:,this%cfg%jmino,:,5)=this%Q(:,this%cfg%jmino,:,1)*this%W(:,this%cfg%jmino,:) + end if + if (.not.this%cfg%zper.and.this%cfg%kproc.eq.1) then + this%Q(:,:,this%cfg%kmino,3)=this%Q(:,:,this%cfg%kmino,1)*this%U(:,:,this%cfg%kmino) + this%Q(:,:,this%cfg%kmino,4)=this%Q(:,:,this%cfg%kmino,1)*this%V(:,:,this%cfg%kmino) + this%Q(:,:,this%cfg%kmino,5)=this%Q(:,:,this%cfg%kmino,1)*this%W(:,:,this%cfg%kmino) + end if + end subroutine get_momentum + + + !> Interpolate velocity to cell-center, including overlap and ghosts + subroutine interp_vel(this,Ui,Vi,Wi) + implicit none + class(spcomp), intent(inout) :: this + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(out) :: Ui !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(out) :: Vi !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(out) :: Wi !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + integer :: i,j,k + ! Calculate interpolated velocity as far as possible + do k=this%cfg%kmino_,this%cfg%kmaxo_-1 + do j=this%cfg%jmino_,this%cfg%jmaxo_-1 + do i=this%cfg%imino_,this%cfg%imaxo_-1 + Ui(i,j,k)=0.5_WP*sum(this%U(i:i+1,j,k)) + Vi(i,j,k)=0.5_WP*sum(this%V(i,j:j+1,k)) + Wi(i,j,k)=0.5_WP*sum(this%W(i,j,k:k+1)) + end do + end do + end do + ! Sync interpolated velocity + call this%cfg%sync(Ui) + call this%cfg%sync(Vi) + call this%cfg%sync(Wi) + ! Add last layer in each direction + if (.not.this%cfg%xper.and.this%cfg%iproc.eq.this%cfg%npx) then + Ui(this%cfg%imaxo,:,:)=this%U(this%cfg%imaxo,:,:) + Vi(this%cfg%imaxo,:,:)=this%V(this%cfg%imaxo,:,:) + Wi(this%cfg%imaxo,:,:)=this%W(this%cfg%imaxo,:,:) + end if + if (.not.this%cfg%yper.and.this%cfg%jproc.eq.this%cfg%npy) then + Ui(:,this%cfg%jmaxo,:)=this%U(:,this%cfg%jmaxo,:) + Vi(:,this%cfg%jmaxo,:)=this%V(:,this%cfg%jmaxo,:) + Wi(:,this%cfg%jmaxo,:)=this%W(:,this%cfg%jmaxo,:) + end if + if (.not.this%cfg%zper.and.this%cfg%kproc.eq.this%cfg%npz) then + Ui(:,:,this%cfg%kmaxo)=this%U(:,:,this%cfg%kmaxo) + Vi(:,:,this%cfg%kmaxo)=this%V(:,:,this%cfg%kmaxo) + Wi(:,:,this%cfg%kmaxo)=this%W(:,:,this%cfg%kmaxo) + end if + end subroutine interp_vel + + + !> Get artifical bulk kinematic viscosity + subroutine get_viscartif(this,dt,beta) + implicit none + class(spcomp), intent(inout) :: this + real(WP), intent(in) :: dt + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(out) :: beta + integer :: i,j,k,si,sj,sk,n + integer, parameter :: nfilter=1 + real(WP) :: max_beta,dudy,dudz,dvdx,dvdz,dwdx,dwdy,vort,grad_div,H + real(WP), parameter :: max_cfl=0.5_WP + real(WP), parameter :: Cartif=2.0_WP + real(WP), parameter :: Cartif_vort=100.0_WP + real(WP), dimension(:,:,:), allocatable :: div + real(WP), dimension(-1:+1), parameter :: filter=[1.0_WP/6.0_WP,2.0_WP/3.0_WP,1.0_WP/6.0_WP] + ! Calculate max beta permissible + max_beta=max_cfl*min(this%dx**2,this%dy**2,this%dz**2)/(4.0_WP*dt) + ! Zero out array + beta=0.0_WP + ! Compute velocity divergence + allocate(div(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + do k=this%cfg%kmino_,this%cfg%kmaxo_-1; do j=this%cfg%jmino_,this%cfg%jmaxo_-1; do i=this%cfg%imino_,this%cfg%imaxo_-1 + div(i,j,k)=this%dxi*(this%U(i+1,j,k)-this%U(i,j,k))+this%dyi*(this%V(i,j+1,k)-this%V(i,j,k))+this%dzi*(this%W(i,j,k+1)-this%W(i,j,k)) + end do; end do; end do + call this%cfg%sync(div) + if (.not.this%cfg%xper.and.this%cfg%iproc.eq.this%cfg%npx) div(this%cfg%imaxo,:,:)=div(this%cfg%imaxo-1,:,:) + if (.not.this%cfg%yper.and.this%cfg%jproc.eq.this%cfg%npy) div(:,this%cfg%jmaxo,:)=div(:,this%cfg%jmaxo-1,:) + if (.not.this%cfg%zper.and.this%cfg%kproc.eq.this%cfg%npz) div(:,:,this%cfg%kmaxo)=div(:,:,this%cfg%kmaxo-1) + ! Compute artificial bulk viscosity based on gradU provided + do k=this%cfg%kmin_,this%cfg%kmax_; do j=this%cfg%jmin_,this%cfg%jmax_; do i=this%cfg%imin_,this%cfg%imax_ + ! Only work in compression regions + if (div(i,j,k).ge.0.0_WP) cycle + ! Compute local vorticity + dudy=0.25_WP*this%dyi*sum(this%U(i:i+1,j:j+1,k)-this%U(i:i+1,j-1:j,k)) + dudz=0.25_WP*this%dzi*sum(this%U(i:i+1,j,k:k+1)-this%U(i:i+1,j,k-1:k)) + dvdx=0.25_WP*this%dxi*sum(this%V(i:i+1,j:j+1,k)-this%V(i-1:i,j:j+1,k)) + dvdz=0.25_WP*this%dzi*sum(this%V(i,j:j+1,k:k+1)-this%V(i,j:j+1,k-1:k)) + dwdx=0.25_WP*this%dxi*sum(this%W(i:i+1,j,k:k+1)-this%W(i-1:i,j,k:k+1)) + dwdy=0.25_WP*this%dyi*sum(this%W(i,j:j+1,k:k+1)-this%W(i,j-1:j,k:k+1)) + vort=(dwdy-dvdz)**2+(dudz-dwdx)**2+(dvdx-dudy)**2 + ! Compute |grad(div)| + grad_div=max(abs(div(i+1,j,k)-div(i,j,k)),abs(div(i,j,k)-div(i-1,j,k)))*this%dx**2& + & +max(abs(div(i,j+1,k)-div(i,j,k)),abs(div(i,j,k)-div(i,j-1,k)))*this%dy**2& + & +max(abs(div(i,j,k+1)-div(i,j,k)),abs(div(i,j,k)-div(i,j,k-1)))*this%dz**2 + ! Estimate artificial kinematic viscosity using grad(div) + !beta(i,j,k)=Cartif*grad_div*div(i,j,k)**2/(div(i,j,k)**2+Cartif_vort*vort+1.0e-15_WP) + + ! Sensor originally proposed by Ducros et al. (1999) and later improved by + ! Hendrickson, T. R., Kartha, A., & Candler, G. V. (2018) + vort=max(vort,(0.05_WP*this%C(i,j,k)/min(this%dx,this%dy))**2) + beta(i,j,k)=Cartif*grad_div*min(4.0_WP/3.0_WP*div(i,j,k)**2/(div(i,j,k)**2+vort+epsilon(1.0_WP)),1.0_WP) + ! Clip it so CFL Get kinematic eddy viscosity using Vreman's model + subroutine get_vreman(this,dt,visc) + implicit none + class(spcomp), intent(inout) :: this + real(WP), intent(in) :: dt + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(out) :: visc + real(WP), parameter :: Cs_ref=0.17_WP + real(WP), parameter :: max_cfl=0.5_WP + real(WP) :: max_visc,A,B,C + real(WP), dimension(1:3,1:3) :: beta,gradU + real(WP), dimension(:,:,:), allocatable :: tmp + real(WP), dimension(-1:+1), parameter :: filter=[1.0_WP/6.0_WP,2.0_WP/3.0_WP,1.0_WP/6.0_WP] + integer :: i,j,k,si,sj,sk,n + integer, parameter :: nfilter=1 + ! Model constant is c=2.5*Cs_ref**2 - Vreman uses c=0.07 which corresponds to Cs_ref=0.17 + C=2.5_WP*Cs_ref**2 + ! Calculate max visc permissible + max_visc=max_cfl*min(this%dx**2,this%dy**2,this%dz**2)/(4.0_WP*dt) + ! Zero out array + visc=0.0_WP + ! Compute the eddy viscosity + do k=this%cfg%kmin_,this%cfg%kmax_; do j=this%cfg%jmin_,this%cfg%jmax_; do i=this%cfg%imin_,this%cfg%imax_ + ! Compute velocity gradient tensor + gradU(1,1)=this%dxi*(this%U(i+1,j,k)-this%U(i,j,k)) + gradU(2,1)=0.25_WP*this%dyi*sum(this%U(i:i+1,j:j+1,k)-this%U(i:i+1,j-1:j,k)) + gradU(3,1)=0.25_WP*this%dzi*sum(this%U(i:i+1,j,k:k+1)-this%U(i:i+1,j,k-1:k)) + gradU(1,2)=0.25_WP*this%dxi*sum(this%V(i:i+1,j:j+1,k)-this%V(i-1:i,j:j+1,k)) + gradU(2,2)=this%dyi*(this%V(i,j+1,k)-this%V(i,j,k)) + gradU(3,2)=0.25_WP*this%dzi*sum(this%V(i,j:j+1,k:k+1)-this%V(i,j:j+1,k-1:k)) + gradU(1,3)=0.25_WP*this%dxi*sum(this%W(i:i+1,j,k:k+1)-this%W(i-1:i,j,k:k+1)) + gradU(2,3)=0.25_WP*this%dyi*sum(this%W(i,j:j+1,k:k+1)-this%W(i,j-1:j,k:k+1)) + gradU(3,3)=this%dzi*(this%W(i,j,k+1)-this%W(i,j,k)) + ! Compute A=gradu_ij*gradu_ij invariant + A=sum(gradU**2) + ! Compute beta_ij=dx_m*dx_m*gradu_mi*gradu_mj + do sj=1,3; do si=1,3; beta(si,sj)=this%dx**2*gradU(1,si)*gradU(1,sj)+this%dy**2*gradU(2,si)*gradU(2,sj)+this%dz**2*gradU(3,si)*gradU(3,sj); end do; end do + ! Compute B invariant + B=beta(1,1)*beta(2,2)-beta(1,2)**2+beta(1,1)*beta(3,3)-beta(1,3)**2+beta(2,2)*beta(3,3)-beta(2,3)**2 + ! Assemble algebraic eddy viscosity model + if (B.lt.1.0e-8_WP) then + visc(i,j,k)=0.0_WP + else + visc(i,j,k)=C*sqrt(B/A) + end if + ! Clip it so CFL Calculate the CFL + subroutine get_cfl(this,dt,cfl) + use mpi_f08, only: MPI_ALLREDUCE,MPI_MAX,MPI_IN_PLACE + use parallel, only: MPI_REAL_WP + implicit none + class(spcomp), intent(inout) :: this + real(WP), intent(in) :: dt + real(WP), intent(out) :: cfl + integer :: ierr + real(WP) :: maxvisc,maxC + ! Compute convective+acoustic CFLs + this%CFLc_x=maxval(abs(this%U)+abs(this%C))*dt*this%dxi; call MPI_ALLREDUCE(MPI_IN_PLACE,this%CFLc_x,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + this%CFLc_y=maxval(abs(this%V)+abs(this%C))*dt*this%dyi; call MPI_ALLREDUCE(MPI_IN_PLACE,this%CFLc_y,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + this%CFLc_z=maxval(abs(this%W)+abs(this%C))*dt*this%dzi; call MPI_ALLREDUCE(MPI_IN_PLACE,this%CFLc_z,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + ! Compute acoustic CFLs + maxC=maxval(this%C); call MPI_ALLREDUCE(MPI_IN_PLACE,maxC,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + this%CFLa_x=maxC*dt*this%dxi + this%CFLa_y=maxC*dt*this%dyi + this%CFLa_z=maxC*dt*this%dzi + ! Compute viscous CFLs + maxvisc=maxval((this%VISC+this%BETA)/this%Q(:,:,:,1)); call MPI_ALLREDUCE(MPI_IN_PLACE,maxvisc,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + this%CFLv_x=4.0_WP*maxvisc*dt*this%dxi**2 + this%CFLv_y=4.0_WP*maxvisc*dt*this%dyi**2 + this%CFLv_z=4.0_WP*maxvisc*dt*this%dzi**2 + ! Return the maximum overall CFL + cfl=max(this%CFLc_x,this%CFLc_y,this%CFLc_z,& + & this%CFLa_x,this%CFLa_y,this%CFLa_z,& + & this%CFLv_x,this%CFLv_y,this%CFLv_z) + end subroutine get_cfl + + + !> Calculate info about our fields + subroutine get_info(this) + use mpi_f08, only: MPI_ALLREDUCE,MPI_MIN,MPI_MAX,MPI_IN_PLACE + use parallel, only: MPI_REAL_WP + implicit none + class(spcomp), intent(inout) :: this + integer :: n,i,j,k,ierr + real(WP), dimension(:,:,:), allocatable :: tmp + + ! Compute integrals and extrema of conserved variables + do n=1,this%nQ + call this%cfg%integrate(this%Q(:,:,:,n),integral=this%Qint(n)) + end do + this%Qmin=+huge(1.0_WP) + this%Qmax=-huge(1.0_WP) + do k=this%cfg%kmin_,this%cfg%kmax_; do j=this%cfg%jmin_,this%cfg%jmax_; do i=this%cfg%imin_,this%cfg%imax_ + do n=1,this%nQ + this%Qmin(n)=min(this%Qmin(n),this%Q(i,j,k,n)) + this%Qmax(n)=max(this%Qmax(n),this%Q(i,j,k,n)) + end do + end do; end do; end do + call MPI_ALLREDUCE(MPI_IN_PLACE,this%Qmin,this%nQ,MPI_REAL_WP,MPI_MIN,this%cfg%comm,ierr) + call MPI_ALLREDUCE(MPI_IN_PLACE,this%Qmax,this%nQ,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + + ! Also compute integral of KE and entropy + allocate(tmp(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + call this%get_ke(tmp); tmp=this%Q(:,:,:,1)*tmp; call this%cfg%integrate(tmp,integral=this%RHOKint) + this%RHOSint=0.0_WP + if (associated(this%getS)) then + do k=this%cfg%kmin_,this%cfg%kmax_; do j=this%cfg%jmin_,this%cfg%jmax_; do i=this%cfg%imin_,this%cfg%imax_ + tmp(i,j,k)=this%Q(i,j,k,1)*this%getS(this%Q(i,j,k,1),this%P(i,j,k)) + end do; end do; end do + call this%cfg%integrate(tmp,integral=this%RHOSint) + end if + deallocate(tmp) + + ! Calculate extrema of primitive fields + this%RHOmin=+huge(1.0_WP); this%RHOmax=-huge(1.0_WP) + this%Imin =+huge(1.0_WP); this%Imax =-huge(1.0_WP) + this%Pmin =+huge(1.0_WP); this%Pmax =-huge(1.0_WP) + this%Tmin =+huge(1.0_WP); this%Tmax =-huge(1.0_WP) + this%Umax=0.0_WP; this%Vmax=0.0_WP; this%Wmax=0.0_WP + do k=this%cfg%kmin_,this%cfg%kmax_; do j=this%cfg%jmin_,this%cfg%jmax_; do i=this%cfg%imin_,this%cfg%imax_ + this%RHOmin=min(this%RHOmin,this%Q(i,j,k,1)); this%RHOmax=max(this%RHOmax,this%Q(i,j,k,1)) + this%Imin =min(this%Imin ,this%I (i,j,k)); this%Imax =max(this%Imax ,this%I (i,j,k)) + this%Pmin =min(this%Pmin ,this%P (i,j,k)); this%Pmax =max(this%Pmax ,this%P (i,j,k)) + this%Tmin =min(this%Tmin ,this%T (i,j,k)); this%Tmax =max(this%Tmax ,this%T (i,j,k)) + this%Umax=max(this%Umax,abs(this%U(i,j,k))) + this%Vmax=max(this%Vmax,abs(this%V(i,j,k))) + this%Wmax=max(this%Wmax,abs(this%W(i,j,k))) + end do; end do; end do + call MPI_ALLREDUCE(MPI_IN_PLACE,this%RHOmin,1,MPI_REAL_WP,MPI_MIN,this%cfg%comm,ierr) + call MPI_ALLREDUCE(MPI_IN_PLACE,this%RHOmax,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + call MPI_ALLREDUCE(MPI_IN_PLACE,this%Imin ,1,MPI_REAL_WP,MPI_MIN,this%cfg%comm,ierr) + call MPI_ALLREDUCE(MPI_IN_PLACE,this%Imax ,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + call MPI_ALLREDUCE(MPI_IN_PLACE,this%Pmin ,1,MPI_REAL_WP,MPI_MIN,this%cfg%comm,ierr) + call MPI_ALLREDUCE(MPI_IN_PLACE,this%Pmax ,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + call MPI_ALLREDUCE(MPI_IN_PLACE,this%Tmin ,1,MPI_REAL_WP,MPI_MIN,this%cfg%comm,ierr) + call MPI_ALLREDUCE(MPI_IN_PLACE,this%Tmax ,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + call MPI_ALLREDUCE(MPI_IN_PLACE,this%Umax ,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + call MPI_ALLREDUCE(MPI_IN_PLACE,this%Vmax ,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + call MPI_ALLREDUCE(MPI_IN_PLACE,this%Wmax ,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + + end subroutine get_info + + + !> Print out info for spcomp flow solver + subroutine spcomp_print(this) + use, intrinsic :: iso_fortran_env, only: output_unit + implicit none + class(spcomp), intent(in) :: this + if (this%cfg%amRoot) write(output_unit,'("spcomp solver [",a,"] for config [",a,"]")') trim(this%name),trim(this%cfg%name) + end subroutine spcomp_print + + + !> Finalize spcomp flow solver + subroutine finalize(this) + implicit none + class(spcomp), intent(inout) :: this + nullify(this%cfg) + this%name='UNNAMED_SPCOMP' + nullify(this%getP) + nullify(this%getT) + nullify(this%getC) + nullify(this%getS) + this%nQ=0 + if (allocated(this%Q)) deallocate(this%Q) + if (allocated(this%Qold)) deallocate(this%Qold) + if (allocated(this%U)) deallocate(this%U) + if (allocated(this%V)) deallocate(this%V) + if (allocated(this%W)) deallocate(this%W) + if (allocated(this%I)) deallocate(this%I) + if (allocated(this%P)) deallocate(this%P) + if (allocated(this%T)) deallocate(this%T) + if (allocated(this%C)) deallocate(this%C) + if (allocated(this%VISC)) deallocate(this%VISC) + if (allocated(this%BETA)) deallocate(this%BETA) + if (allocated(this%DIFF)) deallocate(this%DIFF) + if (allocated(this%Qmin)) deallocate(this%Qmin) + if (allocated(this%Qmax)) deallocate(this%Qmax) + if (allocated(this%Qint)) deallocate(this%Qint) + call this%trhs%finalize() + end subroutine finalize + + +end module spcomp_class diff --git a/examples/cylinder_NOSB/GNUmakefile b/examples/cylinder_NOSB/GNUmakefile new file mode 100644 index 000000000..23c4d3dba --- /dev/null +++ b/examples/cylinder_NOSB/GNUmakefile @@ -0,0 +1,49 @@ +# NGA location if not yet defined +NGA_HOME ?= ~/nga2/Repositories/nga2 + +# Compilation parameters +PRECISION = DOUBLE +USE_MPI = TRUE +USE_HYPRE = TRUE +USE_LAPACK= TRUE +USE_FFTW = TRUE +USE_IRL = FALSE +PROFILE = FALSE +DEBUG = FALSE +COMP = gnu +EXEBASE = nga + +# Directories that contain user-defined code +Udirs := src + +# Include user-defined sources +Upack += $(foreach dir, $(Udirs), $(wildcard $(dir)/Make.package)) +Ulocs += $(foreach dir, $(Udirs), $(wildcard $(dir))) +include $(Upack) +INCLUDE_LOCATIONS += $(Ulocs) +VPATH_LOCATIONS += $(Ulocs) + +# External libraries are defined in .profile/.bashrc/.zshrc, but could be defined here as well +HYPRE_DIR=/Users/imauser/nga2/Repositories/hypre/src/hypre +FFTW_DIR=/opt/homebrew/Cellar/fftw/3.3.10_2 + +# NGA compilation definitions +include $(NGA_HOME)/tools/GNUMake/Make.defs + +# Include NGA base code +Bdirs := constant_density particles core data transform solver config grid libraries +Bpack += $(foreach dir, $(Bdirs), $(NGA_HOME)/src/$(dir)/Make.package) +include $(Bpack) + +# Inform user of Make.packages used +ifdef Ulocs + $(info Taking user code from: $(Ulocs)) +endif +$(info Taking base code from: $(Bdirs)) + +# Target definition +all: $(executable) + @echo COMPILATION SUCCESSFUL + +# NGA compilation rules +include $(NGA_HOME)/tools/GNUMake/Make.rules diff --git a/examples/cylinder_NOSB/README b/examples/cylinder_NOSB/README new file mode 100644 index 000000000..9dbcb7bae --- /dev/null +++ b/examples/cylinder_NOSB/README @@ -0,0 +1 @@ +Flow past a cylinder with volume-of-solid approach diff --git a/examples/cylinder_NOSB/input b/examples/cylinder_NOSB/input new file mode 100644 index 000000000..0482bce51 --- /dev/null +++ b/examples/cylinder_NOSB/input @@ -0,0 +1,43 @@ +# Parallelization +Partition : 4 2 1 + +# Mesh definition +Lx : 6 +Ly : 3 +Lz : 0.3 +nx : 80 +ny : 40 +nz : 4 + +# Case definition +R : 0.5 +Inlet velocity : 1 + +# Solid properties +Subdivisions : 33 +Elastic Modulus : 1 +Poisson Ratio : 0.30 +Solid density : 1 +Critical Energy Release Rate : 100000 +Horizon Ratio : 3.015 +N Across : 5 +Solid Spacing : 0.025 +Load Rate : 0.001 +Solid Damping Constant : 0.02 +Continuous damping : .false. + +# Fluid properties +Dynamic viscosity : 0.001 +Density : 1 + +# Time integration +Max timestep size : 8e-3 +Max cfl number : 0.9 +Max time : 100 + +# Pressure solver +Pressure tolerance : 1e-5 +Pressure iteration : 100 + +# Ensight output +Ensight output period : 1e-4 diff --git a/examples/cylinder_NOSB/src/Make.package b/examples/cylinder_NOSB/src/Make.package new file mode 100644 index 000000000..0ee50eb0b --- /dev/null +++ b/examples/cylinder_NOSB/src/Make.package @@ -0,0 +1,2 @@ +# List here the extra files here +f90EXE_sources += geometry.f90 incomp_class.f90 simulation.f90 lss_class.f90 diff --git a/examples/cylinder_NOSB/src/geometry.f90 b/examples/cylinder_NOSB/src/geometry.f90 new file mode 100644 index 000000000..c642a7503 --- /dev/null +++ b/examples/cylinder_NOSB/src/geometry.f90 @@ -0,0 +1,71 @@ +!> Various definitions and tools for initializing NGA2 config +module geometry + use config_class, only: config + use precision, only: WP + implicit none + private + + !> Single config + type(config), public :: cfg + + public :: geometry_init + +contains + + + !> Initialization of problem geometry + subroutine geometry_init + use sgrid_class, only: sgrid + use param, only: param_read + implicit none + type(sgrid) :: grid + + + ! Create a grid from input params + create_grid: block + use sgrid_class, only: cartesian + integer :: i,j,k,nx,ny,nz + real(WP) :: Lx,Ly,Lz + real(WP), dimension(:), allocatable :: x,y,z + + ! Read in grid definition + call param_read('Lx',Lx); call param_read('nx',nx); allocate(x(nx+1)) + call param_read('Ly',Ly); call param_read('ny',ny); allocate(y(ny+1)) + call param_read('Lz',Lz); call param_read('nz',nz); allocate(z(nz+1)) + + ! Create simple rectilinear grid + do i=1,nx+1 + x(i)=real(i-1,WP)/real(nx,WP)*Lx-0.25_WP*Lx + end do + do j=1,ny+1 + y(j)=real(j-1,WP)/real(ny,WP)*Ly-0.5_WP*Ly + end do + do k=1,nz+1 + z(k)=real(k-1,WP)/real(nz,WP)*Lz-0.5_WP*Lz + end do + + ! General serial grid object + grid=sgrid(coord=cartesian,no=2,x=x,y=y,z=z,xper=.false.,yper=.true.,zper=.true.,name='channel') + + end block create_grid + + + ! Create a config from that grid on our entire group + create_cfg: block + use parallel, only: group + integer, dimension(3) :: partition + ! Read in partition + call param_read('Partition',partition,short='p') + ! Create partitioned grid + cfg=config(grp=group,decomp=partition,grid=grid) + end block create_cfg + + ! Create masks for this config + create_walls: block + cfg%VF=1.0_WP + end block create_walls + + end subroutine geometry_init + + +end module geometry \ No newline at end of file diff --git a/examples/cylinder_NOSB/src/incomp_class.f90 b/examples/cylinder_NOSB/src/incomp_class.f90 new file mode 100644 index 000000000..c8e6f79b7 --- /dev/null +++ b/examples/cylinder_NOSB/src/incomp_class.f90 @@ -0,0 +1,2128 @@ +!> Incompressible flow solver class: +!> Provides support for various BC, RHS calculation, +!> implicit solver, and pressure solution +!> Assumes constant viscosity and density. +module incomp_class + use precision, only: WP + use string, only: str_medium + use config_class, only: config + use linsol_class, only: linsol + use iterator_class, only: iterator + implicit none + private + + ! Expose type/constructor/methods + public :: incomp,bcond + + ! List of known available bcond types for this solver + integer, parameter, public :: wall=1 !< Dirichlet at zero condition + integer, parameter, public :: dirichlet=2 !< Dirichlet condition + integer, parameter, public :: neumann=3 !< Zero normal gradient + integer, parameter, public :: convective=4 !< Convective outflow condition + integer, parameter, public :: clipped_neumann=5 !< Clipped Neumann condition (outflow only) + integer, parameter, public :: slip=6 !< Free-slip condition + + !> Boundary conditions for the incompressible solver + type :: bcond + type(bcond), pointer :: next !< Linked list of bconds + character(len=str_medium) :: name='UNNAMED_BCOND' !< Bcond name (default=UNNAMED_BCOND) + integer :: type !< Bcond type + type(iterator) :: itr !< This is the iterator for the bcond - this identifies the (i,j,k) + character(len=1) :: face !< Bcond face (x/y/z) + integer :: dir !< Bcond direction (+1,-1,0 for interior) + real(WP) :: rdir !< Bcond direction (real variable) + logical :: canCorrect !< Can this bcond be corrected for global conservation? + end type bcond + + !> Incompressible solver object definition + type :: incomp + + ! This is our config + class(config), pointer :: cfg !< This is the config the solver is build for + + ! This is the name of the solver + character(len=str_medium) :: name='UNNAMED_INCOMP' !< Solver name (default=UNNAMED_INCOMP) + + ! Constant property fluid + real(WP) :: rho !< This is our constant fluid density + real(WP), dimension(:,:,:), allocatable :: visc !< These is our constant+SGS dynamic viscosity + + ! Gravitational acceleration + real(WP), dimension(3) :: gravity=0.0_WP !< Acceleration of gravity + + ! Boundary condition list + integer :: nbc !< Number of bcond for our solver + real(WP), dimension(:), allocatable :: mfr !< MFR through each bcond + real(WP), dimension(:), allocatable :: area !< Area for each bcond + real(WP) :: correctable_area !< Area of bcond that can be corrected + type(bcond), pointer :: first_bc !< List of bcond for our solver + + ! Flow variables + real(WP), dimension(:,:,:), allocatable :: U !< U velocity array + real(WP), dimension(:,:,:), allocatable :: V !< V velocity array + real(WP), dimension(:,:,:), allocatable :: W !< W velocity array + real(WP), dimension(:,:,:), allocatable :: P !< Pressure array + + ! Old flow variables + real(WP), dimension(:,:,:), allocatable :: Uold !< Uold velocity array + real(WP), dimension(:,:,:), allocatable :: Vold !< Vold velocity array + real(WP), dimension(:,:,:), allocatable :: Wold !< Wold velocity array + + ! Flow divergence + real(WP), dimension(:,:,:), allocatable :: div !< Divergence array + + ! Pressure solver + class(linsol), pointer :: psolv !< Iterative linear solver object for the pressure Poisson equation + + ! Implicit velocity solver + class(linsol), pointer :: implicit !< Iterative linear solver object for an implicit prediction of the NS residual + + ! Metrics + real(WP), dimension(:,:,:,:,:), allocatable :: itp_xy,itp_yz,itp_xz !< Interpolation for viscosity + real(WP), dimension(:,:,:,:), allocatable :: itpr_x,itpr_y,itpr_z !< Interpolation for density + real(WP), dimension(:,:,:,:), allocatable :: itpu_x,itpu_y,itpu_z !< Interpolation for U + real(WP), dimension(:,:,:,:), allocatable :: itpv_x,itpv_y,itpv_z !< Interpolation for V + real(WP), dimension(:,:,:,:), allocatable :: itpw_x,itpw_y,itpw_z !< Interpolation for W + real(WP), dimension(:,:,:,:), allocatable :: divp_x,divp_y,divp_z !< Divergence for P-cell + real(WP), dimension(:,:,:,:), allocatable :: divu_x,divu_y,divu_z !< Divergence for U-cell + real(WP), dimension(:,:,:,:), allocatable :: divv_x,divv_y,divv_z !< Divergence for V-cell + real(WP), dimension(:,:,:,:), allocatable :: divw_x,divw_y,divw_z !< Divergence for W-cell + real(WP), dimension(:,:,:,:), allocatable :: grdu_x,grdu_y,grdu_z !< Velocity gradient for U + real(WP), dimension(:,:,:,:), allocatable :: grdv_x,grdv_y,grdv_z !< Velocity gradient for V + real(WP), dimension(:,:,:,:), allocatable :: grdw_x,grdw_y,grdw_z !< Velocity gradient for W + + ! Masking info for metric modification + integer, dimension(:,:,:), allocatable :: mask !< Integer array used for modifying P metrics + integer, dimension(:,:,:), allocatable :: umask !< Integer array used for modifying U metrics + integer, dimension(:,:,:), allocatable :: vmask !< Integer array used for modifying V metrics + integer, dimension(:,:,:), allocatable :: wmask !< Integer array used for modifying W metrics + + ! CFL numbers + real(WP) :: CFLc_x,CFLc_y,CFLc_z !< Convective CFL numbers + real(WP) :: CFLv_x,CFLv_y,CFLv_z !< Viscous CFL numbers + + ! Monitoring quantities + real(WP) :: Umax,Vmax,Wmax,Pmax,divmax !< Maximum velocity, pressure, divergence + + contains + procedure :: print=>incomp_print !< Output solver to the screen + procedure :: setup !< Finish configuring the flow solver + procedure :: add_bcond !< Add a boundary condition + procedure :: get_bcond !< Get a boundary condition + procedure :: apply_bcond !< Apply all boundary conditions + procedure :: init_metrics !< Initialize metrics + procedure :: adjust_metrics !< Adjust metrics + procedure :: get_dmomdt !< Calculate dmom/dt + procedure :: get_div !< Calculate velocity divergence + procedure :: get_div_stress !< Calculate divergence of stresses for LPT solver + procedure :: get_pgrad !< Calculate pressure gradient + procedure :: get_cfl !< Calculate maximum CFL + procedure :: get_max !< Calculate maximum field values + procedure :: interp_vel !< Calculate interpolated velocity + procedure :: get_strainrate !< Calculate deviatoric part of strain rate tensor + procedure :: get_gradu !< Calculate velocity gradient tensor + procedure :: get_vorticity !< Calculate vorticity tensor + procedure :: get_mfr !< Calculate outgoing MFR through each bcond + procedure :: correct_mfr !< Correct for mfr mismatch to ensure global conservation + procedure :: shift_p !< Shift pressure to have zero average + procedure :: solve_implicit !< Solve for the velocity residuals implicitly + procedure :: addsrc_gravity !< Gravitational body force + end type incomp + + + !> Declare incompressible solver constructor + interface incomp + procedure constructor + end interface incomp + +contains + + + !> Default constructor for incompressible flow solver + function constructor(cfg,name) result(self) + implicit none + type(incomp) :: self + class(config), target, intent(in) :: cfg + character(len=*), optional :: name + integer :: i,j,k + + ! Set the name for the solver + if (present(name)) self%name=trim(adjustl(name)) + + ! Point to pgrid object + self%cfg=>cfg + + ! Nullify bcond list + self%nbc=0 + self%first_bc=>NULL() + + ! Allocate flow variables + allocate(self%U(self%cfg%imino_:self%cfg%imaxo_,self%cfg%jmino_:self%cfg%jmaxo_,self%cfg%kmino_:self%cfg%kmaxo_)); self%U=0.0_WP + allocate(self%V(self%cfg%imino_:self%cfg%imaxo_,self%cfg%jmino_:self%cfg%jmaxo_,self%cfg%kmino_:self%cfg%kmaxo_)); self%V=0.0_WP + allocate(self%W(self%cfg%imino_:self%cfg%imaxo_,self%cfg%jmino_:self%cfg%jmaxo_,self%cfg%kmino_:self%cfg%kmaxo_)); self%W=0.0_WP + allocate(self%P(self%cfg%imino_:self%cfg%imaxo_,self%cfg%jmino_:self%cfg%jmaxo_,self%cfg%kmino_:self%cfg%kmaxo_)); self%P=0.0_WP + + ! Allocate flow divergence + allocate(self%div(self%cfg%imino_:self%cfg%imaxo_,self%cfg%jmino_:self%cfg%jmaxo_,self%cfg%kmino_:self%cfg%kmaxo_)); self%div=0.0_WP + + ! Allocate fluid viscosity + allocate(self%visc(self%cfg%imino_:self%cfg%imaxo_,self%cfg%jmino_:self%cfg%jmaxo_,self%cfg%kmino_:self%cfg%kmaxo_)); self%visc=0.0_WP + + ! Allocate old flow variables + allocate(self%Uold(self%cfg%imino_:self%cfg%imaxo_,self%cfg%jmino_:self%cfg%jmaxo_,self%cfg%kmino_:self%cfg%kmaxo_)); self%Uold=0.0_WP + allocate(self%Vold(self%cfg%imino_:self%cfg%imaxo_,self%cfg%jmino_:self%cfg%jmaxo_,self%cfg%kmino_:self%cfg%kmaxo_)); self%Vold=0.0_WP + allocate(self%Wold(self%cfg%imino_:self%cfg%imaxo_,self%cfg%jmino_:self%cfg%jmaxo_,self%cfg%kmino_:self%cfg%kmaxo_)); self%Wold=0.0_WP + + ! Prepare default metrics + call self%init_metrics() + + ! Prepare P-cell masks + allocate(self%mask(self%cfg%imino_:self%cfg%imaxo_,self%cfg%jmino_:self%cfg%jmaxo_,self%cfg%kmino_:self%cfg%kmaxo_)); self%mask=0 + if (.not.self%cfg%xper) then + if (self%cfg%iproc.eq. 1) self%mask(:self%cfg%imin-1,:,:)=2 + if (self%cfg%iproc.eq.self%cfg%npx) self%mask(self%cfg%imax+1:,:,:)=2 + end if + if (.not.self%cfg%yper) then + if (self%cfg%jproc.eq. 1) self%mask(:,:self%cfg%jmin-1,:)=2 + if (self%cfg%jproc.eq.self%cfg%npy) self%mask(:,self%cfg%jmax+1:,:)=2 + end if + if (.not.self%cfg%zper) then + if (self%cfg%kproc.eq. 1) self%mask(:,:,:self%cfg%kmin-1)=2 + if (self%cfg%kproc.eq.self%cfg%npz) self%mask(:,:,self%cfg%kmax+1:)=2 + end if + do k=self%cfg%kmino_,self%cfg%kmaxo_ + do j=self%cfg%jmino_,self%cfg%jmaxo_ + do i=self%cfg%imino_,self%cfg%imaxo_ + if (self%cfg%VF(i,j,k).eq.0.0_WP) self%mask(i,j,k)=1 + end do + end do + end do + call self%cfg%sync(self%mask) + + ! Prepare face mask for U + allocate(self%umask(self%cfg%imino_:self%cfg%imaxo_,self%cfg%jmino_:self%cfg%jmaxo_,self%cfg%kmino_:self%cfg%kmaxo_)); self%umask=0 + if (.not.self%cfg%xper) then + if (self%cfg%iproc.eq. 1) self%umask(self%cfg%imin ,:,:)=2 + if (self%cfg%iproc.eq.self%cfg%npx) self%umask(self%cfg%imax+1,:,:)=2 + end if + do k=self%cfg%kmino_ ,self%cfg%kmaxo_ + do j=self%cfg%jmino_ ,self%cfg%jmaxo_ + do i=self%cfg%imino_+1,self%cfg%imaxo_ + if (minval(self%cfg%VF(i-1:i,j,k)).eq.0.0_WP) self%umask(i,j,k)=1 + end do + end do + end do + call self%cfg%sync(self%umask) + if (.not.self%cfg%xper.and.self%cfg%iproc.eq.1) self%umask(self%cfg%imino,:,:)=self%umask(self%cfg%imino+1,:,:) + + ! Prepare face mask for V + allocate(self%vmask(self%cfg%imino_:self%cfg%imaxo_,self%cfg%jmino_:self%cfg%jmaxo_,self%cfg%kmino_:self%cfg%kmaxo_)); self%vmask=0 + if (.not.self%cfg%yper) then + if (self%cfg%jproc.eq. 1) self%vmask(:,self%cfg%jmin ,:)=2 + if (self%cfg%jproc.eq.self%cfg%npy) self%vmask(:,self%cfg%jmax+1,:)=2 + end if + do k=self%cfg%kmino_ ,self%cfg%kmaxo_ + do j=self%cfg%jmino_+1,self%cfg%jmaxo_ + do i=self%cfg%imino_ ,self%cfg%imaxo_ + if (minval(self%cfg%VF(i,j-1:j,k)).eq.0.0_WP) self%vmask(i,j,k)=1 + end do + end do + end do + call self%cfg%sync(self%vmask) + if (.not.self%cfg%yper.and.self%cfg%jproc.eq.1) self%vmask(:,self%cfg%jmino,:)=self%vmask(:,self%cfg%jmino+1,:) + + ! Prepare face mask for W + allocate(self%wmask(self%cfg%imino_:self%cfg%imaxo_,self%cfg%jmino_:self%cfg%jmaxo_,self%cfg%kmino_:self%cfg%kmaxo_)); self%wmask=0 + if (.not.self%cfg%zper) then + if (self%cfg%kproc.eq. 1) self%wmask(:,:,self%cfg%kmin )=2 + if (self%cfg%kproc.eq.self%cfg%npz) self%wmask(:,:,self%cfg%kmax+1)=2 + end if + do k=self%cfg%kmino_+1,self%cfg%kmaxo_ + do j=self%cfg%jmino_ ,self%cfg%jmaxo_ + do i=self%cfg%imino_ ,self%cfg%imaxo_ + if (minval(self%cfg%VF(i,j,k-1:k)).eq.0.0_WP) self%wmask(i,j,k)=1 + end do + end do + end do + call self%cfg%sync(self%wmask) + if (.not.self%cfg%zper.and.self%cfg%kproc.eq.1) self%wmask(:,:,self%cfg%kmino)=self%wmask(:,:,self%cfg%kmino+1) + + end function constructor + + + !> Metric initialization with no awareness of walls nor bcond + subroutine init_metrics(this) + implicit none + class(incomp), intent(inout) :: this + integer :: i,j,k,st1,st2 + real(WP), dimension(-1:0) :: itpx,itpy,itpz + + ! Allocate finite difference density (or other things) interpolation coefficients + allocate(this%itpr_x(-1:0,this%cfg%imin_:this%cfg%imax_+1,this%cfg%jmin_:this%cfg%jmax_+1,this%cfg%kmin_:this%cfg%kmax_+1)) !< X-face-centered + allocate(this%itpr_y(-1:0,this%cfg%imin_:this%cfg%imax_+1,this%cfg%jmin_:this%cfg%jmax_+1,this%cfg%kmin_:this%cfg%kmax_+1)) !< Y-face-centered + allocate(this%itpr_z(-1:0,this%cfg%imin_:this%cfg%imax_+1,this%cfg%jmin_:this%cfg%jmax_+1,this%cfg%kmin_:this%cfg%kmax_+1)) !< Z-face-centered + ! Create density (or other things) interpolation coefficients to cell face + do k=this%cfg%kmin_,this%cfg%kmax_+1 + do j=this%cfg%jmin_,this%cfg%jmax_+1 + do i=this%cfg%imin_,this%cfg%imax_+1 + this%itpr_x(:,i,j,k)=this%cfg%dxmi(i)*[this%cfg%xm(i)-this%cfg%x(i),this%cfg%x(i)-this%cfg%xm(i-1)] !< Linear interpolation in x from [xm,ym,zm] to [x,ym,zm] + this%itpr_y(:,i,j,k)=this%cfg%dymi(j)*[this%cfg%ym(j)-this%cfg%y(j),this%cfg%y(j)-this%cfg%ym(j-1)] !< Linear interpolation in y from [xm,ym,zm] to [xm,y,zm] + this%itpr_z(:,i,j,k)=this%cfg%dzmi(k)*[this%cfg%zm(k)-this%cfg%z(k),this%cfg%z(k)-this%cfg%zm(k-1)] !< Linear interpolation in z from [xm,ym,zm] to [xm,ym,z] + end do + end do + end do + + ! Allocate finite difference viscosity interpolation coefficients + allocate(this%itp_xy(-1:0,-1:0,this%cfg%imino_+1:this%cfg%imaxo_,this%cfg%jmino_+1:this%cfg%jmaxo_,this%cfg%kmino_+1:this%cfg%kmaxo_)) !< Edge-centered (xy) + allocate(this%itp_yz(-1:0,-1:0,this%cfg%imino_+1:this%cfg%imaxo_,this%cfg%jmino_+1:this%cfg%jmaxo_,this%cfg%kmino_+1:this%cfg%kmaxo_)) !< Edge-centered (yz) + allocate(this%itp_xz(-1:0,-1:0,this%cfg%imino_+1:this%cfg%imaxo_,this%cfg%jmino_+1:this%cfg%jmaxo_,this%cfg%kmino_+1:this%cfg%kmaxo_)) !< Edge-centered (zx) + ! Create viscosity interpolation coefficients to cell edge + do k=this%cfg%kmino_+1,this%cfg%kmaxo_ + do j=this%cfg%jmino_+1,this%cfg%jmaxo_ + do i=this%cfg%imino_+1,this%cfg%imaxo_ + ! Prepare local 1D metrics + itpx=this%cfg%dxmi(i)*[this%cfg%xm(i)-this%cfg%x(i),this%cfg%x(i)-this%cfg%xm(i-1)] + itpy=this%cfg%dymi(j)*[this%cfg%ym(j)-this%cfg%y(j),this%cfg%y(j)-this%cfg%ym(j-1)] + itpz=this%cfg%dzmi(k)*[this%cfg%zm(k)-this%cfg%z(k),this%cfg%z(k)-this%cfg%zm(k-1)] + ! Combine for 2D interpolations + do st1=-1,0 + do st2=-1,0 + this%itp_xy(st1,st2,i,j,k)=itpx(st1)*itpy(st2) + this%itp_yz(st1,st2,i,j,k)=itpy(st1)*itpz(st2) + this%itp_xz(st1,st2,i,j,k)=itpx(st1)*itpz(st2) + end do + end do + end do + end do + end do + + ! Allocate finite difference velocity interpolation coefficients + allocate(this%itpu_x( 0:+1,this%cfg%imino_ :this%cfg%imaxo_,this%cfg%jmino_ :this%cfg%jmaxo_,this%cfg%kmino_ :this%cfg%kmaxo_)) !< Cell-centered + allocate(this%itpv_y( 0:+1,this%cfg%imino_ :this%cfg%imaxo_,this%cfg%jmino_ :this%cfg%jmaxo_,this%cfg%kmino_ :this%cfg%kmaxo_)) !< Cell-centered + allocate(this%itpw_z( 0:+1,this%cfg%imino_ :this%cfg%imaxo_,this%cfg%jmino_ :this%cfg%jmaxo_,this%cfg%kmino_ :this%cfg%kmaxo_)) !< Cell-centered + allocate(this%itpv_x(-1: 0,this%cfg%imino_+1:this%cfg%imaxo_,this%cfg%jmino_ :this%cfg%jmaxo_,this%cfg%kmino_ :this%cfg%kmaxo_)) !< Edge-centered (xy) + allocate(this%itpw_x(-1: 0,this%cfg%imino_+1:this%cfg%imaxo_,this%cfg%jmino_ :this%cfg%jmaxo_,this%cfg%kmino_ :this%cfg%kmaxo_)) !< Edge-centered (zx) + allocate(this%itpu_y(-1: 0,this%cfg%imino_ :this%cfg%imaxo_,this%cfg%jmino_+1:this%cfg%jmaxo_,this%cfg%kmino_ :this%cfg%kmaxo_)) !< Edge-centered (xy) + allocate(this%itpw_y(-1: 0,this%cfg%imino_ :this%cfg%imaxo_,this%cfg%jmino_+1:this%cfg%jmaxo_,this%cfg%kmino_ :this%cfg%kmaxo_)) !< Edge-centered (yz) + allocate(this%itpu_z(-1: 0,this%cfg%imino_ :this%cfg%imaxo_,this%cfg%jmino_ :this%cfg%jmaxo_,this%cfg%kmino_+1:this%cfg%kmaxo_)) !< Edge-centered (zx) + allocate(this%itpv_z(-1: 0,this%cfg%imino_ :this%cfg%imaxo_,this%cfg%jmino_ :this%cfg%jmaxo_,this%cfg%kmino_+1:this%cfg%kmaxo_)) !< Edge-centered (yz) + ! Create velocity interpolation coefficients to cell center [xm,ym,zm] + do k=this%cfg%kmino_,this%cfg%kmaxo_ + do j=this%cfg%jmino_,this%cfg%jmaxo_ + do i=this%cfg%imino_,this%cfg%imaxo_ + this%itpu_x(:,i,j,k)=[+0.5_WP,+0.5_WP] !< Linear interpolation in x of U from [x ,ym,zm] + this%itpv_y(:,i,j,k)=[+0.5_WP,+0.5_WP] !< Linear interpolation in y of V from [xm,y ,zm] + this%itpw_z(:,i,j,k)=[+0.5_WP,+0.5_WP] !< Linear interpolation in z of W from [xm,ym,z ] + end do + end do + end do + ! Create velocity interpolation coefficients to cell edge in x + do k=this%cfg%kmino_ ,this%cfg%kmaxo_ + do j=this%cfg%jmino_ ,this%cfg%jmaxo_ + do i=this%cfg%imino_+1,this%cfg%imaxo_ + this%itpv_x(:,i,j,k)=this%cfg%dxmi(i)*[this%cfg%xm(i)-this%cfg%x(i),this%cfg%x(i)-this%cfg%xm(i-1)] !< Linear interpolation in x of V from [xm,y ,zm] + this%itpw_x(:,i,j,k)=this%cfg%dxmi(i)*[this%cfg%xm(i)-this%cfg%x(i),this%cfg%x(i)-this%cfg%xm(i-1)] !< Linear interpolation in x of W from [xm,ym,z ] + end do + end do + end do + ! Create velocity interpolation coefficients to cell edge in y + do k=this%cfg%kmino_ ,this%cfg%kmaxo_ + do j=this%cfg%jmino_+1,this%cfg%jmaxo_ + do i=this%cfg%imino_ ,this%cfg%imaxo_ + this%itpu_y(:,i,j,k)=this%cfg%dymi(j)*[this%cfg%ym(j)-this%cfg%y(j),this%cfg%y(j)-this%cfg%ym(j-1)] !< Linear interpolation in y of U from [x ,ym,zm] + this%itpw_y(:,i,j,k)=this%cfg%dymi(j)*[this%cfg%ym(j)-this%cfg%y(j),this%cfg%y(j)-this%cfg%ym(j-1)] !< Linear interpolation in y of W from [xm,ym,z ] + end do + end do + end do + ! Create velocity interpolation coefficients to cell edge in z + do k=this%cfg%kmino_+1,this%cfg%kmaxo_ + do j=this%cfg%jmino_ ,this%cfg%jmaxo_ + do i=this%cfg%imino_ ,this%cfg%imaxo_ + this%itpu_z(:,i,j,k)=this%cfg%dzmi(k)*[this%cfg%zm(k)-this%cfg%z(k),this%cfg%z(k)-this%cfg%zm(k-1)] !< Linear interpolation in z of U from [x ,ym,zm] + this%itpv_z(:,i,j,k)=this%cfg%dzmi(k)*[this%cfg%zm(k)-this%cfg%z(k),this%cfg%z(k)-this%cfg%zm(k-1)] !< Linear interpolation in z of V from [xm,y ,zm] + end do + end do + end do + + ! Allocate finite volume divergence operators + allocate(this%divp_x( 0:+1,this%cfg%imino_ :this%cfg%imaxo_,this%cfg%jmino_ :this%cfg%jmaxo_,this%cfg%kmino_ :this%cfg%kmaxo_)) !< Cell-centered + allocate(this%divp_y( 0:+1,this%cfg%imino_ :this%cfg%imaxo_,this%cfg%jmino_ :this%cfg%jmaxo_,this%cfg%kmino_ :this%cfg%kmaxo_)) !< Cell-centered + allocate(this%divp_z( 0:+1,this%cfg%imino_ :this%cfg%imaxo_,this%cfg%jmino_ :this%cfg%jmaxo_,this%cfg%kmino_ :this%cfg%kmaxo_)) !< Cell-centered + allocate(this%divu_x(-1: 0,this%cfg%imino_+1:this%cfg%imaxo_,this%cfg%jmino_ :this%cfg%jmaxo_,this%cfg%kmino_ :this%cfg%kmaxo_)) !< Face-centered (x) + allocate(this%divu_y( 0:+1,this%cfg%imino_ :this%cfg%imaxo_,this%cfg%jmino_ :this%cfg%jmaxo_,this%cfg%kmino_ :this%cfg%kmaxo_)) !< Face-centered (x) + allocate(this%divu_z( 0:+1,this%cfg%imino_ :this%cfg%imaxo_,this%cfg%jmino_ :this%cfg%jmaxo_,this%cfg%kmino_ :this%cfg%kmaxo_)) !< Face-centered (x) + allocate(this%divv_x( 0:+1,this%cfg%imino_ :this%cfg%imaxo_,this%cfg%jmino_ :this%cfg%jmaxo_,this%cfg%kmino_ :this%cfg%kmaxo_)) !< Face-centered (y) + allocate(this%divv_y(-1: 0,this%cfg%imino_ :this%cfg%imaxo_,this%cfg%jmino_+1:this%cfg%jmaxo_,this%cfg%kmino_ :this%cfg%kmaxo_)) !< Face-centered (y) + allocate(this%divv_z( 0:+1,this%cfg%imino_ :this%cfg%imaxo_,this%cfg%jmino_ :this%cfg%jmaxo_,this%cfg%kmino_ :this%cfg%kmaxo_)) !< Face-centered (y) + allocate(this%divw_x( 0:+1,this%cfg%imino_ :this%cfg%imaxo_,this%cfg%jmino_ :this%cfg%jmaxo_,this%cfg%kmino_ :this%cfg%kmaxo_)) !< Face-centered (z) + allocate(this%divw_y( 0:+1,this%cfg%imino_ :this%cfg%imaxo_,this%cfg%jmino_ :this%cfg%jmaxo_,this%cfg%kmino_ :this%cfg%kmaxo_)) !< Face-centered (z) + allocate(this%divw_z(-1: 0,this%cfg%imino_ :this%cfg%imaxo_,this%cfg%jmino_ :this%cfg%jmaxo_,this%cfg%kmino_+1:this%cfg%kmaxo_)) !< Face-centered (z) + ! Create divergence operator to cell center [xm,ym,zm] or tangent to cell face + do k=this%cfg%kmino_,this%cfg%kmaxo_ + do j=this%cfg%jmino_,this%cfg%jmaxo_ + do i=this%cfg%imino_,this%cfg%imaxo_ + this%divp_x(:,i,j,k)=this%cfg%dxi(i)*[-1.0_WP,+1.0_WP] !< FV divergence from [x ,ym,zm] + this%divp_y(:,i,j,k)=this%cfg%dyi(j)*[-1.0_WP,+1.0_WP] !< FV divergence from [xm,y ,zm] + this%divp_z(:,i,j,k)=this%cfg%dzi(k)*[-1.0_WP,+1.0_WP] !< FV divergence from [xm,ym,z ] + + this%divu_y(:,i,j,k)=this%cfg%dyi(j)*[-1.0_WP,+1.0_WP] !< FV divergence from [x ,y ,zm] + this%divu_z(:,i,j,k)=this%cfg%dzi(k)*[-1.0_WP,+1.0_WP] !< FV divergence from [x ,ym,z ] + + this%divv_x(:,i,j,k)=this%cfg%dxi(i)*[-1.0_WP,+1.0_WP] !< FV divergence from [x ,y ,zm] + this%divv_z(:,i,j,k)=this%cfg%dzi(k)*[-1.0_WP,+1.0_WP] !< FV divergence from [xm,y ,z ] + + this%divw_x(:,i,j,k)=this%cfg%dxi(i)*[-1.0_WP,+1.0_WP] !< FV divergence from [x ,ym,z ] + this%divw_y(:,i,j,k)=this%cfg%dyi(j)*[-1.0_WP,+1.0_WP] !< FV divergence from [xm,y ,z ] + end do + end do + end do + ! Create divergence operator perpendicular to cell face [x ,ym,zm] + do k=this%cfg%kmino_ ,this%cfg%kmaxo_ + do j=this%cfg%jmino_ ,this%cfg%jmaxo_ + do i=this%cfg%imino_+1,this%cfg%imaxo_ + this%divu_x(:,i,j,k)=this%cfg%dxmi(i)*[-1.0_WP,+1.0_WP] !< FV divergence from [xm,ym,zm] + end do + end do + end do + ! Create divergence operator perpendicular to cell face [xm,y ,zm] + do k=this%cfg%kmino_ ,this%cfg%kmaxo_ + do j=this%cfg%jmino_+1,this%cfg%jmaxo_ + do i=this%cfg%imino_ ,this%cfg%imaxo_ + this%divv_y(:,i,j,k)=this%cfg%dymi(j)*[-1.0_WP,+1.0_WP] !< FV divergence from [xm,ym,zm] + end do + end do + end do + ! Create divergence operator perpendicular to cell face [xm,ym,z ] + do k=this%cfg%kmino_+1,this%cfg%kmaxo_ + do j=this%cfg%jmino_ ,this%cfg%jmaxo_ + do i=this%cfg%imino_ ,this%cfg%imaxo_ + this%divw_z(:,i,j,k)=this%cfg%dzmi(k)*[-1.0_WP,+1.0_WP] !< FV divergence from [xm,ym,zm] + end do + end do + end do + + ! Allocate finite difference velocity gradient operators + allocate(this%grdu_x( 0:+1,this%cfg%imino_ :this%cfg%imaxo_,this%cfg%jmino_ :this%cfg%jmaxo_,this%cfg%kmino_ :this%cfg%kmaxo_)) !< Cell-centered + allocate(this%grdv_y( 0:+1,this%cfg%imino_ :this%cfg%imaxo_,this%cfg%jmino_ :this%cfg%jmaxo_,this%cfg%kmino_ :this%cfg%kmaxo_)) !< Cell-centered + allocate(this%grdw_z( 0:+1,this%cfg%imino_ :this%cfg%imaxo_,this%cfg%jmino_ :this%cfg%jmaxo_,this%cfg%kmino_ :this%cfg%kmaxo_)) !< Cell-centered + allocate(this%grdv_x(-1: 0,this%cfg%imino_+1:this%cfg%imaxo_,this%cfg%jmino_ :this%cfg%jmaxo_,this%cfg%kmino_ :this%cfg%kmaxo_)) !< Edge-centered (xy) + allocate(this%grdw_x(-1: 0,this%cfg%imino_+1:this%cfg%imaxo_,this%cfg%jmino_ :this%cfg%jmaxo_,this%cfg%kmino_ :this%cfg%kmaxo_)) !< Edge-centered (zx) + allocate(this%grdu_y(-1: 0,this%cfg%imino_ :this%cfg%imaxo_,this%cfg%jmino_+1:this%cfg%jmaxo_,this%cfg%kmino_ :this%cfg%kmaxo_)) !< Edge-centered (xy) + allocate(this%grdw_y(-1: 0,this%cfg%imino_ :this%cfg%imaxo_,this%cfg%jmino_+1:this%cfg%jmaxo_,this%cfg%kmino_ :this%cfg%kmaxo_)) !< Edge-centered (yz) + allocate(this%grdu_z(-1: 0,this%cfg%imino_ :this%cfg%imaxo_,this%cfg%jmino_ :this%cfg%jmaxo_,this%cfg%kmino_+1:this%cfg%kmaxo_)) !< Edge-centered (zx) + allocate(this%grdv_z(-1: 0,this%cfg%imino_ :this%cfg%imaxo_,this%cfg%jmino_ :this%cfg%jmaxo_,this%cfg%kmino_+1:this%cfg%kmaxo_)) !< Edge-centered (yz) + ! Create gradient coefficients to cell center [xm,ym,zm] + do k=this%cfg%kmino_,this%cfg%kmaxo_ + do j=this%cfg%jmino_,this%cfg%jmaxo_ + do i=this%cfg%imino_,this%cfg%imaxo_ + this%grdu_x(:,i,j,k)=this%cfg%dxi(i)*[-1.0_WP,+1.0_WP] !< FD gradient in x of U from [x ,ym,zm] + this%grdv_y(:,i,j,k)=this%cfg%dyi(j)*[-1.0_WP,+1.0_WP] !< FD gradient in y of V from [xm,y ,zm] + this%grdw_z(:,i,j,k)=this%cfg%dzi(k)*[-1.0_WP,+1.0_WP] !< FD gradient in z of W from [xm,ym,z ] + end do + end do + end do + ! Create gradient coefficients to cell edge in x + do k=this%cfg%kmino_ ,this%cfg%kmaxo_ + do j=this%cfg%jmino_ ,this%cfg%jmaxo_ + do i=this%cfg%imino_+1,this%cfg%imaxo_ + this%grdv_x(:,i,j,k)=this%cfg%dxmi(i)*[-1.0_WP,+1.0_WP] !< FD gradient in x of V from [xm,y ,zm] + this%grdw_x(:,i,j,k)=this%cfg%dxmi(i)*[-1.0_WP,+1.0_WP] !< FD gradient in x of W from [xm,ym,z ] + end do + end do + end do + ! Create gradient coefficients to cell edge in y + do k=this%cfg%kmino_ ,this%cfg%kmaxo_ + do j=this%cfg%jmino_+1,this%cfg%jmaxo_ + do i=this%cfg%imino_ ,this%cfg%imaxo_ + this%grdu_y(:,i,j,k)=this%cfg%dymi(j)*[-1.0_WP,+1.0_WP] !< FD gradient in y of U from [x ,ym,zm] + this%grdw_y(:,i,j,k)=this%cfg%dymi(j)*[-1.0_WP,+1.0_WP] !< FD gradient in y of W from [xm,ym,z ] + end do + end do + end do + ! Create gradient coefficients to cell edge in z + do k=this%cfg%kmino_+1,this%cfg%kmaxo_ + do j=this%cfg%jmino_ ,this%cfg%jmaxo_ + do i=this%cfg%imino_ ,this%cfg%imaxo_ + this%grdu_z(:,i,j,k)=this%cfg%dzmi(k)*[-1.0_WP,+1.0_WP] !< FD gradient in z of U from [x ,ym,zm] + this%grdv_z(:,i,j,k)=this%cfg%dzmi(k)*[-1.0_WP,+1.0_WP] !< FD gradient in z of V from [xm,y ,zm] + end do + end do + end do + + end subroutine init_metrics + + + !> Metric adjustment accounting for bconds and walls + subroutine adjust_metrics(this) + implicit none + class(incomp), intent(inout) :: this + integer :: i,j,k,st1,st2 + real(WP) :: delta,mysum + + ! Sync up u/v/wmasks + call this%cfg%sync(this%umask) + call this%cfg%sync(this%vmask) + call this%cfg%sync(this%wmask) + if (.not.this%cfg%xper.and.this%cfg%iproc.eq.1) this%umask(this%cfg%imino,:,:)=this%umask(this%cfg%imino+1,:,:) + if (.not.this%cfg%yper.and.this%cfg%jproc.eq.1) this%vmask(:,this%cfg%jmino,:)=this%vmask(:,this%cfg%jmino+1,:) + if (.not.this%cfg%zper.and.this%cfg%kproc.eq.1) this%wmask(:,:,this%cfg%kmino)=this%wmask(:,:,this%cfg%kmino+1) + + ! I am assuming here that we do not really need to zero out wall cells + ! as they could be used for Dirichlet (then the density needs to be available! could be problematic if we do not have an explicit BC for scalars, e.g. for a Couette flow) + ! or outflow condition (then the density needs to be available but it should be directly calculated) + ! or used for a real no-slip wall (then density is always multiplied by zero) + ! Adjust density interpolation coefficients to cell faces in the presence of walls (only walls!) + !do k=this%cfg%kmin_,this%cfg%kmax_+1 + ! do j=this%cfg%jmin_,this%cfg%jmax_+1 + ! do i=this%cfg%imin_,this%cfg%imax_+1 + ! ! Linear interpolation in x + ! if (this%cfg%VF(i,j,k).eq.0.0_WP.and.this%cfg%VF(i-1,j,k).gt.0.0_WP) this%itpr_x(:,i,j,k)=[1.0_WP,0.0_WP] + ! if (this%cfg%VF(i,j,k).gt.0.0_WP.and.this%cfg%VF(i-1,j,k).eq.0.0_WP) this%itpr_x(:,i,j,k)=[0.0_WP,1.0_WP] + ! ! Linear interpolation in y + ! if (this%cfg%VF(i,j,k).eq.0.0_WP.and.this%cfg%VF(i,j-1,k).gt.0.0_WP) this%itpr_y(:,i,j,k)=[1.0_WP,0.0_WP] + ! if (this%cfg%VF(i,j,k).gt.0.0_WP.and.this%cfg%VF(i,j-1,k).eq.0.0_WP) this%itpr_y(:,i,j,k)=[0.0_WP,1.0_WP] + ! ! Linear interpolation in z + ! if (this%cfg%VF(i,j,k).eq.0.0_WP.and.this%cfg%VF(i,j,k-1).gt.0.0_WP) this%itpr_z(:,i,j,k)=[1.0_WP,0.0_WP] + ! if (this%cfg%VF(i,j,k).gt.0.0_WP.and.this%cfg%VF(i,j,k-1).eq.0.0_WP) this%itpr_z(:,i,j,k)=[0.0_WP,1.0_WP] + ! end do + ! end do + !end do + + ! Adjust interpolation coefficients to cell centers in the presence of walls (only walls!) + do k=this%cfg%kmino_,this%cfg%kmaxo_ + do j=this%cfg%jmino_,this%cfg%jmaxo_ + do i=this%cfg%imino_,this%cfg%imaxo_ + if (this%mask(i,j,k).eq.1) this%itpu_x(:,i,j,k)=0.0_WP + if (this%mask(i,j,k).eq.1) this%itpv_y(:,i,j,k)=0.0_WP + if (this%mask(i,j,k).eq.1) this%itpw_z(:,i,j,k)=0.0_WP + end do + end do + end do + + ! Adjust viscosity interpolation coefficients to cell edge in the presence of walls (only walls) + do k=this%cfg%kmino_+1,this%cfg%kmaxo_ + do j=this%cfg%jmino_+1,this%cfg%jmaxo_ + do i=this%cfg%imino_+1,this%cfg%imaxo_ + ! Zero out interpolation coefficients reaching in the walls + do st1=-1,0 + do st2=-1,0 + if (this%mask(i+st1,j+st2,k).eq.1) this%itp_xy(st1,st2,i,j,k)=0.0_WP + if (this%mask(i,j+st1,k+st2).eq.1) this%itp_yz(st1,st2,i,j,k)=0.0_WP + if (this%mask(i+st1,j,k+st2).eq.1) this%itp_xz(st1,st2,i,j,k)=0.0_WP + end do + end do + ! Rescale to ensure sum(itp)=1 + mysum=sum(this%itp_xy(:,:,i,j,k)); if (mysum.gt.0.0_WP) this%itp_xy(:,:,i,j,k)=this%itp_xy(:,:,i,j,k)/mysum + mysum=sum(this%itp_yz(:,:,i,j,k)); if (mysum.gt.0.0_WP) this%itp_yz(:,:,i,j,k)=this%itp_yz(:,:,i,j,k)/mysum + mysum=sum(this%itp_xz(:,:,i,j,k)); if (mysum.gt.0.0_WP) this%itp_xz(:,:,i,j,k)=this%itp_xz(:,:,i,j,k)/mysum + end do + end do + end do + + ! Loop over the domain and adjust divergence for P cell + do k=this%cfg%kmino_,this%cfg%kmaxo_ + do j=this%cfg%jmino_,this%cfg%jmaxo_ + do i=this%cfg%imino_,this%cfg%imaxo_ + if (this%mask(i,j,k).gt.0) then + this%divp_x(:,i,j,k)=0.0_WP + this%divp_y(:,i,j,k)=0.0_WP + this%divp_z(:,i,j,k)=0.0_WP + end if + end do + end do + end do + + ! Loop over the domain and apply masked conditions to U metrics + do k=this%cfg%kmino_ ,this%cfg%kmaxo_ + do j=this%cfg%jmino_ ,this%cfg%jmaxo_ + do i=this%cfg%imino_+1,this%cfg%imaxo_ + if (this%umask(i,j,k).gt.0) then + this%divu_x(:,i,j,k)=0.0_WP + this%divu_y(:,i,j,k)=0.0_WP + this%divu_z(:,i,j,k)=0.0_WP + end if + end do + end do + end do + + ! Loop over the domain and apply masked conditions to V metrics + do k=this%cfg%kmino_ ,this%cfg%kmaxo_ + do j=this%cfg%jmino_+1,this%cfg%jmaxo_ + do i=this%cfg%imino_ ,this%cfg%imaxo_ + if (this%vmask(i,j,k).gt.0) then + this%divv_x(:,i,j,k)=0.0_WP + this%divv_y(:,i,j,k)=0.0_WP + this%divv_z(:,i,j,k)=0.0_WP + end if + end do + end do + end do + + ! Loop over the domain and apply masked conditions to W metrics + do k=this%cfg%kmino_+1,this%cfg%kmaxo_ + do j=this%cfg%jmino_ ,this%cfg%jmaxo_ + do i=this%cfg%imino_ ,this%cfg%imaxo_ + if (this%wmask(i,j,k).gt.0) then + this%divw_x(:,i,j,k)=0.0_WP + this%divw_y(:,i,j,k)=0.0_WP + this%divw_z(:,i,j,k)=0.0_WP + end if + end do + end do + end do + + ! Adjust gradient coefficients to cell edge in x + do k=this%cfg%kmino_ ,this%cfg%kmaxo_ + do j=this%cfg%jmino_ ,this%cfg%jmaxo_ + do i=this%cfg%imino_+1,this%cfg%imaxo_ + ! FD gradient in x of V from [xm,y ,zm] + if (maxval(this%vmask(i-1:i,j,k)).gt.0) then + delta=0.0_WP + if (this%vmask(i ,j,k).eq.0) delta=delta+(this%cfg%xm(i)-this%cfg%x (i )) + if (this%vmask(i-1,j,k).eq.0) delta=delta+(this%cfg%x (i)-this%cfg%xm(i-1)) + if (delta.gt.0.0_WP) then + this%grdv_x(:,i,j,k)=[-1.0_WP,+1.0_WP]/delta + else + this%grdv_x(:,i,j,k)=0.0_WP + end if + end if + ! FD gradient in x of W from [xm,ym,z ] + if (maxval(this%wmask(i-1:i,j,k)).gt.0) then + delta=0.0_WP + if (this%wmask(i ,j,k).eq.0) delta=delta+(this%cfg%xm(i)-this%cfg%x (i )) + if (this%wmask(i-1,j,k).eq.0) delta=delta+(this%cfg%x (i)-this%cfg%xm(i-1)) + if (delta.gt.0.0_WP) then + this%grdw_x(:,i,j,k)=[-1.0_WP,+1.0_WP]/delta + else + this%grdw_x(:,i,j,k)=0.0_WP + end if + end if + end do + end do + end do + + ! Adjust gradient coefficients to cell edge in y + do k=this%cfg%kmino_ ,this%cfg%kmaxo_ + do j=this%cfg%jmino_+1,this%cfg%jmaxo_ + do i=this%cfg%imino_ ,this%cfg%imaxo_ + ! FD gradient in y of U from [x ,ym,zm] + if (maxval(this%umask(i,j-1:j,k)).gt.0) then + delta=0.0_WP + if (this%umask(i,j ,k).eq.0) delta=delta+(this%cfg%ym(j)-this%cfg%y (j )) + if (this%umask(i,j-1,k).eq.0) delta=delta+(this%cfg%y (j)-this%cfg%ym(j-1)) + if (delta.gt.0.0_WP) then + this%grdu_y(:,i,j,k)=[-1.0_WP,+1.0_WP]/delta + else + this%grdu_y(:,i,j,k)=0.0_WP + end if + end if + ! FD gradient in y of W from [xm,ym,z ] + if (maxval(this%wmask(i,j-1:j,k)).gt.0) then + delta=0.0_WP + if (this%wmask(i,j ,k).eq.0) delta=delta+(this%cfg%ym(j)-this%cfg%y (j )) + if (this%wmask(i,j-1,k).eq.0) delta=delta+(this%cfg%y (j)-this%cfg%ym(j-1)) + if (delta.gt.0.0_WP) then + this%grdw_y(:,i,j,k)=[-1.0_WP,+1.0_WP]/delta + else + this%grdw_y(:,i,j,k)=0.0_WP + end if + end if + end do + end do + end do + + ! Adjust gradient coefficients to cell edge in z + do k=this%cfg%kmino_+1,this%cfg%kmaxo_ + do j=this%cfg%jmino_ ,this%cfg%jmaxo_ + do i=this%cfg%imino_ ,this%cfg%imaxo_ + ! FD gradient in z of U from [x ,ym,zm] + if (maxval(this%umask(i,j,k-1:k)).gt.0) then + delta=0.0_WP + if (this%umask(i,j,k ).eq.0) delta=delta+(this%cfg%zm(k)-this%cfg%z (k )) + if (this%umask(i,j,k-1).eq.0) delta=delta+(this%cfg%z (k)-this%cfg%zm(k-1)) + if (delta.gt.0.0_WP) then + this%grdu_z(:,i,j,k)=[-1.0_WP,+1.0_WP]/delta + else + this%grdu_z(:,i,j,k)=0.0_WP + end if + end if + ! FD gradient in z of V from [xm,y ,zm] + if (maxval(this%vmask(i,j,k-1:k)).gt.0) then + delta=0.0_WP + if (this%vmask(i,j,k ).eq.0) delta=delta+(this%cfg%zm(k)-this%cfg%z (k )) + if (this%vmask(i,j,k-1).eq.0) delta=delta+(this%cfg%z (k)-this%cfg%zm(k-1)) + if (delta.gt.0.0_WP) then + this%grdv_z(:,i,j,k)=[-1.0_WP,+1.0_WP]/delta + else + this%grdv_z(:,i,j,k)=0.0_WP + end if + end if + end do + end do + end do + + ! Adjust interpolation coefficients to cell centers in the presence of walls (only walls!) + do k=this%cfg%kmino_,this%cfg%kmaxo_ + do j=this%cfg%jmino_,this%cfg%jmaxo_ + do i=this%cfg%imino_,this%cfg%imaxo_ + if (this%mask(i,j,k).eq.1) this%itpu_x(:,i,j,k)=0.0_WP + if (this%mask(i,j,k).eq.1) this%itpv_y(:,i,j,k)=0.0_WP + if (this%mask(i,j,k).eq.1) this%itpw_z(:,i,j,k)=0.0_WP + end do + end do + end do + + ! Adjust interpolation coefficients to cell edge in x + do k=this%cfg%kmino_ ,this%cfg%kmaxo_ + do j=this%cfg%jmino_ ,this%cfg%jmaxo_ + do i=this%cfg%imino_+1,this%cfg%imaxo_ + ! Linear interpolation in x of V from [xm,y ,zm] + if (this%vmask(i,j,k).eq.0.and.this%vmask(i-1,j,k).gt.0) this%itpv_x(:,i,j,k)=[1.0_WP,0.0_WP] + if (this%vmask(i,j,k).gt.0.and.this%vmask(i-1,j,k).eq.0) this%itpv_x(:,i,j,k)=[0.0_WP,1.0_WP] + ! Linear interpolation in x of W from [xm,ym,z ] + if (this%wmask(i,j,k).eq.0.and.this%wmask(i-1,j,k).gt.0) this%itpw_x(:,i,j,k)=[1.0_WP,0.0_WP] + if (this%wmask(i,j,k).gt.0.and.this%wmask(i-1,j,k).eq.0) this%itpw_x(:,i,j,k)=[0.0_WP,1.0_WP] + end do + end do + end do + + ! Adjust interpolation coefficients to cell edge in y + do k=this%cfg%kmino_ ,this%cfg%kmaxo_ + do j=this%cfg%jmino_+1,this%cfg%jmaxo_ + do i=this%cfg%imino_ ,this%cfg%imaxo_ + ! Linear interpolation in y of U from [x ,ym,zm] + if (this%umask(i,j,k).eq.0.and.this%umask(i,j-1,k).gt.0) this%itpu_y(:,i,j,k)=[1.0_WP,0.0_WP] + if (this%umask(i,j,k).gt.0.and.this%umask(i,j-1,k).eq.0) this%itpu_y(:,i,j,k)=[0.0_WP,1.0_WP] + ! Linear interpolation in y of W from [xm,ym,z ] + if (this%wmask(i,j,k).eq.0.and.this%wmask(i,j-1,k).gt.0) this%itpw_y(:,i,j,k)=[1.0_WP,0.0_WP] + if (this%wmask(i,j,k).gt.0.and.this%wmask(i,j-1,k).eq.0) this%itpw_y(:,i,j,k)=[0.0_WP,1.0_WP] + end do + end do + end do + + ! Adjust interpolation coefficients to cell edge in z + do k=this%cfg%kmino_+1,this%cfg%kmaxo_ + do j=this%cfg%jmino_ ,this%cfg%jmaxo_ + do i=this%cfg%imino_ ,this%cfg%imaxo_ + ! Linear interpolation in z of U from [x ,ym,zm] + if (this%umask(i,j,k).eq.0.and.this%umask(i,j,k-1).gt.0) this%itpu_z(:,i,j,k)=[1.0_WP,0.0_WP] + if (this%umask(i,j,k).gt.0.and.this%umask(i,j,k-1).eq.0) this%itpu_z(:,i,j,k)=[0.0_WP,1.0_WP] + ! Linear interpolation in z of V from [xm,y ,zm] + if (this%vmask(i,j,k).eq.0.and.this%vmask(i,j,k-1).gt.0) this%itpv_z(:,i,j,k)=[1.0_WP,0.0_WP] + if (this%vmask(i,j,k).gt.0.and.this%vmask(i,j,k-1).eq.0) this%itpv_z(:,i,j,k)=[0.0_WP,1.0_WP] + end do + end do + end do + + ! Adjust metrics to account for lower dimensionality + if (this%cfg%nx.eq.1) then + this%divp_x=0.0_WP + this%divu_x=0.0_WP + this%divv_x=0.0_WP + this%divw_x=0.0_WP + this%grdu_x=0.0_WP + this%grdv_x=0.0_WP + this%grdw_x=0.0_WP + end if + if (this%cfg%ny.eq.1) then + this%divp_y=0.0_WP + this%divu_y=0.0_WP + this%divv_y=0.0_WP + this%divw_y=0.0_WP + this%grdu_y=0.0_WP + this%grdv_y=0.0_WP + this%grdw_y=0.0_WP + end if + if (this%cfg%nz.eq.1) then + this%divp_z=0.0_WP + this%divu_z=0.0_WP + this%divv_z=0.0_WP + this%divw_z=0.0_WP + this%grdu_z=0.0_WP + this%grdv_z=0.0_WP + this%grdw_z=0.0_WP + end if + + end subroutine adjust_metrics + + + !> Finish setting up the flow solver now that bconds have been defined + subroutine setup(this,pressure_solver,implicit_solver) + implicit none + class(incomp), intent(inout) :: this + class(linsol), target, intent(in) :: pressure_solver !< A pressure solver is required + class(linsol), target, intent(in), optional :: implicit_solver !< An implicit solver can be provided + integer :: i,j,k + + ! Adjust metrics based on bcflag array + call this%adjust_metrics() + + ! Point to pressure solver linsol object + this%psolv=>pressure_solver + + ! Set 7-pt stencil map for the pressure solver + this%psolv%stc(1,:)=[ 0, 0, 0] + this%psolv%stc(2,:)=[+1, 0, 0] + this%psolv%stc(3,:)=[-1, 0, 0] + this%psolv%stc(4,:)=[ 0,+1, 0] + this%psolv%stc(5,:)=[ 0,-1, 0] + this%psolv%stc(6,:)=[ 0, 0,+1] + this%psolv%stc(7,:)=[ 0, 0,-1] + + ! Setup the scaled Laplacian operator from incomp metrics: lap(*)=-vol*div(grad(*)) + do k=this%cfg%kmin_,this%cfg%kmax_ + do j=this%cfg%jmin_,this%cfg%jmax_ + do i=this%cfg%imin_,this%cfg%imax_ + ! Set Laplacian + this%psolv%opr(1,i,j,k)=this%divp_x(1,i,j,k)*this%divu_x(-1,i+1,j,k)+& + & this%divp_x(0,i,j,k)*this%divu_x( 0,i ,j,k)+& + & this%divp_y(1,i,j,k)*this%divv_y(-1,i,j+1,k)+& + & this%divp_y(0,i,j,k)*this%divv_y( 0,i,j ,k)+& + & this%divp_z(1,i,j,k)*this%divw_z(-1,i,j,k+1)+& + & this%divp_z(0,i,j,k)*this%divw_z( 0,i,j,k ) + this%psolv%opr(2,i,j,k)=this%divp_x(1,i,j,k)*this%divu_x( 0,i+1,j,k) + this%psolv%opr(3,i,j,k)=this%divp_x(0,i,j,k)*this%divu_x(-1,i ,j,k) + this%psolv%opr(4,i,j,k)=this%divp_y(1,i,j,k)*this%divv_y( 0,i,j+1,k) + this%psolv%opr(5,i,j,k)=this%divp_y(0,i,j,k)*this%divv_y(-1,i,j ,k) + this%psolv%opr(6,i,j,k)=this%divp_z(1,i,j,k)*this%divw_z( 0,i,j,k+1) + this%psolv%opr(7,i,j,k)=this%divp_z(0,i,j,k)*this%divw_z(-1,i,j,k ) + ! Scale it by the cell volume + this%psolv%opr(:,i,j,k)=-this%psolv%opr(:,i,j,k)*this%cfg%vol(i,j,k) + end do + end do + end do + + ! Initialize the pressure Poisson solver + call this%psolv%init() + call this%psolv%setup() + + ! Prepare implicit solver if it had been provided + if (present(implicit_solver)) then + + ! Point to implicit solver linsol object + this%implicit=>implicit_solver + + ! Set 7-pt stencil map for the velocity solver + this%implicit%stc(1,:)=[ 0, 0, 0] + this%implicit%stc(2,:)=[+1, 0, 0] + this%implicit%stc(3,:)=[-1, 0, 0] + this%implicit%stc(4,:)=[ 0,+1, 0] + this%implicit%stc(5,:)=[ 0,-1, 0] + this%implicit%stc(6,:)=[ 0, 0,+1] + this%implicit%stc(7,:)=[ 0, 0,-1] + + ! Set the diagonal to 1 to make sure all cells participate in solver + this%implicit%opr(1,:,:,:)=1.0_WP + + ! Initialize the implicit velocity solver + call this%implicit%init() + + else + + ! Point to implicit solver linsol object + this%implicit=>NULL() + + end if + + end subroutine setup + + + !> Add a boundary condition + subroutine add_bcond(this,name,type,locator,face,dir,canCorrect) + use string, only: lowercase + use messager, only: die + use iterator_class, only: locator_ftype + implicit none + class(incomp), intent(inout) :: this + character(len=*), intent(in) :: name + integer, intent(in) :: type + procedure(locator_ftype) :: locator + character(len=1), intent(in) :: face + integer, intent(in) :: dir + logical, intent(in) :: canCorrect + type(bcond), pointer :: new_bc + integer :: i,j,k,n + + ! Prepare new bcond + allocate(new_bc) + new_bc%name=trim(adjustl(name)) + new_bc%type=type + select case (lowercase(face)) + case ('x'); new_bc%face='x' + case ('y'); new_bc%face='y' + case ('z'); new_bc%face='z' + case default; call die('[incomp add_bcond] Unknown bcond face - expecting x, y, or z') + end select + new_bc%itr=iterator(pg=this%cfg,name=new_bc%name,locator=locator,face=new_bc%face) + select case (dir) ! Outward-oriented + case (+1); new_bc%dir=+1 + case (-1); new_bc%dir=-1 + case ( 0); new_bc%dir= 0 + case default; call die('[incomp add_bcond] Unknown bcond dir - expecting -1, +1, or 0') + end select + new_bc%rdir=real(new_bc%dir,WP) + new_bc%canCorrect=canCorrect + + ! Insert it up front + new_bc%next=>this%first_bc + this%first_bc=>new_bc + + ! Increment bcond counter + this%nbc=this%nbc+1 + + ! Now adjust the metrics accordingly + select case (new_bc%type) + case (dirichlet) !< Dirichlet is set one face (i.e., velocit component) at the time + select case (new_bc%face) + case ('x') + do n=1,new_bc%itr%n_ + i=new_bc%itr%map(1,n); j=new_bc%itr%map(2,n); k=new_bc%itr%map(3,n) + this%umask(i,j,k)=2 + end do + case ('y') + do n=1,new_bc%itr%n_ + i=new_bc%itr%map(1,n); j=new_bc%itr%map(2,n); k=new_bc%itr%map(3,n) + this%vmask(i,j,k)=2 + end do + case ('z') + do n=1,new_bc%itr%n_ + i=new_bc%itr%map(1,n); j=new_bc%itr%map(2,n); k=new_bc%itr%map(3,n) + this%wmask(i,j,k)=2 + end do + end select + + case (neumann) !< Neumann has to be at existing wall or at domain boundary! + case (clipped_neumann) + case (convective) + case (slip) + case default + call die('[incomp apply_bcond] Unknown bcond type') + end select + + end subroutine add_bcond + + + !> Get a boundary condition + subroutine get_bcond(this,name,my_bc) + use messager, only: die + implicit none + class(incomp), intent(inout) :: this + character(len=*), intent(in) :: name + type(bcond), pointer, intent(out) :: my_bc + my_bc=>this%first_bc + search: do while (associated(my_bc)) + if (trim(my_bc%name).eq.trim(name)) exit search + my_bc=>my_bc%next + end do search + if (.not.associated(my_bc)) call die('[incomp get_bcond] Boundary condition was not found') + end subroutine get_bcond + + + !> Enforce boundary condition + subroutine apply_bcond(this,t,dt) + use messager, only: die + implicit none + class(incomp), intent(inout) :: this + real(WP), intent(in) :: t,dt + integer :: i,j,k,n,stag + type(bcond), pointer :: my_bc + + ! ! First enfore zero velocity at walls + ! do k=this%cfg%kmin_,this%cfg%kmax_ + ! do j=this%cfg%jmin_,this%cfg%jmax_ + ! do i=this%cfg%imin_,this%cfg%imax_ + ! if (minval(this%cfg%VF(i-1:i,j,k)).lt.10.0_WP*epsilon(1.0_WP)) this%U(i,j,k)=0.0_WP + ! if (minval(this%cfg%VF(i,j-1:j,k)).lt.10.0_WP*epsilon(1.0_WP)) this%V(i,j,k)=0.0_WP + ! if (minval(this%cfg%VF(i,j,k-1:k)).lt.10.0_WP*epsilon(1.0_WP)) this%W(i,j,k)=0.0_WP + ! end do + ! end do + ! end do + ! ! Sync fields + ! call this%cfg%sync(this%U) + ! call this%cfg%sync(this%V) + ! call this%cfg%sync(this%W) + + ! Traverse bcond list + my_bc=>this%first_bc + do while (associated(my_bc)) + + ! Only processes inside the bcond work here + if (my_bc%itr%amIn) then + + ! Select appropriate action based on the bcond type + select case (my_bc%type) + + case (dirichlet) !< Apply Dirichlet conditions + + ! This is done by the user directly + ! Unclear whether we want to do this within the solver... + + case (neumann,clipped_neumann,slip) !< Apply Neumann condition to all 3 components + ! Handle index shift due to staggering + stag=min(my_bc%dir,0) + ! Implement based on bcond direction + select case (my_bc%face) + case ('x') + stag=min(my_bc%dir,0) + do n=1,my_bc%itr%n_ + i=my_bc%itr%map(1,n); j=my_bc%itr%map(2,n); k=my_bc%itr%map(3,n) + this%U(i ,j ,k )=this%U(i-my_bc%dir ,j ,k ) + this%V(i+stag,j:j+1,k )=this%V(i-my_bc%dir+stag,j:j+1,k ) + this%W(i+stag,j ,k:k+1)=this%W(i-my_bc%dir+stag,j ,k:k+1) + end do + case ('y') + stag=min(my_bc%dir,0) + do n=1,my_bc%itr%n_ + i=my_bc%itr%map(1,n); j=my_bc%itr%map(2,n); k=my_bc%itr%map(3,n) + this%U(i:i+1,j+stag,k )=this%U(i:i+1,j-my_bc%dir+stag,k ) + this%V(i ,j ,k )=this%V(i ,j-my_bc%dir ,k ) + this%W(i ,j+stag,k:k+1)=this%W(i ,j-my_bc%dir+stag,k:k+1) + end do + case ('z') + stag=min(my_bc%dir,0) + do n=1,my_bc%itr%n_ + i=my_bc%itr%map(1,n); j=my_bc%itr%map(2,n); k=my_bc%itr%map(3,n) + this%U(i:i+1,j ,k+stag)=this%U(i:i+1,j ,k-my_bc%dir+stag) + this%V(i ,j:j+1,k+stag)=this%V(i ,j:j+1,k-my_bc%dir+stag) + this%W(i ,j ,k )=this%W(i ,j ,k-my_bc%dir ) + end do + end select + ! If needed, clip + if (my_bc%type.eq.clipped_neumann) then + select case (my_bc%face) + case ('x') + do n=1,my_bc%itr%n_ + i=my_bc%itr%map(1,n); j=my_bc%itr%map(2,n); k=my_bc%itr%map(3,n) + if (this%U(i,j,k)*my_bc%rdir.lt.0.0_WP) this%U(i,j,k)=0.0_WP + end do + case ('y') + do n=1,my_bc%itr%n_ + i=my_bc%itr%map(1,n); j=my_bc%itr%map(2,n); k=my_bc%itr%map(3,n) + if (this%V(i,j,k)*my_bc%rdir.lt.0.0_WP) this%V(i,j,k)=0.0_WP + end do + case ('z') + do n=1,my_bc%itr%n_ + i=my_bc%itr%map(1,n); j=my_bc%itr%map(2,n); k=my_bc%itr%map(3,n) + if (this%W(i,j,k)*my_bc%rdir.lt.0.0_WP) this%W(i,j,k)=0.0_WP + end do + end select + end if + ! If needed, no penetration + if (my_bc%type.eq.slip) then + select case (my_bc%face) + case ('x') + do n=1,my_bc%itr%n_ + i=my_bc%itr%map(1,n); j=my_bc%itr%map(2,n); k=my_bc%itr%map(3,n) + this%U(i,j,k)=0.0_WP + end do + case ('y') + do n=1,my_bc%itr%n_ + i=my_bc%itr%map(1,n); j=my_bc%itr%map(2,n); k=my_bc%itr%map(3,n) + this%V(i,j,k)=0.0_WP + end do + case ('z') + do n=1,my_bc%itr%n_ + i=my_bc%itr%map(1,n); j=my_bc%itr%map(2,n); k=my_bc%itr%map(3,n) + this%W(i,j,k)=0.0_WP + end do + end select + end if + + case (convective) ! Not implemented yet! + + case default + call die('[incomp apply_bcond] Unknown bcond type') + end select + + end if + + ! Move on to the next bcond + my_bc=>my_bc%next + + end do + + ! Sync full fields after all bcond + call this%cfg%sync(this%U) + call this%cfg%sync(this%V) + call this%cfg%sync(this%W) + + end subroutine apply_bcond + + + !> Calculate the explicit momentum time derivative based on U/V/W/P + subroutine get_dmomdt(this,drhoUdt,drhoVdt,drhoWdt) + implicit none + class(incomp), intent(inout) :: this + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(out) :: drhoUdt !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(out) :: drhoVdt !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(out) :: drhoWdt !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + integer :: i,j,k,ii,jj,kk + real(WP), dimension(:,:,:), allocatable :: FX,FY,FZ + + ! Zero out drhoUVW/dt arrays + drhoUdt=0.0_WP; drhoVdt=0.0_WP; drhoWdt=0.0_WP + + ! Allocate flux arrays + allocate(FX(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + allocate(FY(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + allocate(FZ(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + + ! Flux of rhoU + do kk=this%cfg%kmin_,this%cfg%kmax_+1 + do jj=this%cfg%jmin_,this%cfg%jmax_+1 + do ii=this%cfg%imin_,this%cfg%imax_+1 + ! Fluxes on x-face + i=ii-1; j=jj-1; k=kk-1 + FX(i,j,k)=-this%rho*sum(this%itpu_x(:,i,j,k)*this%U(i:i+1,j,k))*sum(this%itpu_x(:,i,j,k)*this%U(i:i+1,j,k)) & + & +this%visc(i,j,k)*(sum(this%grdu_x(:,i,j,k)*this%U(i:i+1,j,k))+sum(this%grdu_x(:,i,j,k)*this%U(i:i+1,j,k)) & + & -2.0_WP/3.0_WP*(sum(this%divp_x(:,i,j,k)*this%U(i:i+1,j,k))+sum(this%divp_y(:,i,j,k)*this%V(i,j:j+1,k))+sum(this%divp_z(:,i,j,k)*this%W(i,j,k:k+1)))) & + & -this%P(i,j,k) + ! Fluxes on y-face + i=ii; j=jj; k=kk + FY(i,j,k)=-this%rho*sum(this%itpu_y(:,i,j,k)*this%U(i,j-1:j,k))*sum(this%itpv_x(:,i,j,k)*this%V(i-1:i,j,k)) & + & +sum(this%itp_xy(:,:,i,j,k)*this%visc(i-1:i,j-1:j,k))*(sum(this%grdu_y(:,i,j,k)*this%U(i,j-1:j,k))+sum(this%grdv_x(:,i,j,k)*this%V(i-1:i,j,k))) + ! Fluxes on z-face + i=ii; j=jj; k=kk + FZ(i,j,k)=-this%rho*sum(this%itpu_z(:,i,j,k)*this%U(i,j,k-1:k))*sum(this%itpw_x(:,i,j,k)*this%W(i-1:i,j,k)) & + & +sum(this%itp_xz(:,:,i,j,k)*this%visc(i-1:i,j,k-1:k))*(sum(this%grdu_z(:,i,j,k)*this%U(i,j,k-1:k))+sum(this%grdw_x(:,i,j,k)*this%W(i-1:i,j,k))) + end do + end do + end do + ! Time derivative of rhoU + do k=this%cfg%kmin_,this%cfg%kmax_ + do j=this%cfg%jmin_,this%cfg%jmax_ + do i=this%cfg%imin_,this%cfg%imax_ + drhoUdt(i,j,k)=sum(this%divu_x(:,i,j,k)*FX(i-1:i,j,k))+& + & sum(this%divu_y(:,i,j,k)*FY(i,j:j+1,k))+& + & sum(this%divu_z(:,i,j,k)*FZ(i,j,k:k+1)) + end do + end do + end do + ! Sync it + call this%cfg%sync(drhoUdt) + + ! Flux of rhoV + do kk=this%cfg%kmin_,this%cfg%kmax_+1 + do jj=this%cfg%jmin_,this%cfg%jmax_+1 + do ii=this%cfg%imin_,this%cfg%imax_+1 + ! Fluxes on x-face + i=ii; j=jj; k=kk + FX(i,j,k)=-this%rho*sum(this%itpv_x(:,i,j,k)*this%V(i-1:i,j,k))*sum(this%itpu_y(:,i,j,k)*this%U(i,j-1:j,k)) & + & +sum(this%itp_xy(:,:,i,j,k)*this%visc(i-1:i,j-1:j,k))*(sum(this%grdv_x(:,i,j,k)*this%V(i-1:i,j,k))+sum(this%grdu_y(:,i,j,k)*this%U(i,j-1:j,k))) + ! Fluxes on y-face + i=ii-1; j=jj-1; k=kk-1 + FY(i,j,k)=-this%rho*sum(this%itpv_y(:,i,j,k)*this%V(i,j:j+1,k))*sum(this%itpv_y(:,i,j,k)*this%V(i,j:j+1,k)) & + & +this%visc(i,j,k)*(sum(this%grdv_y(:,i,j,k)*this%V(i,j:j+1,k))+sum(this%grdv_y(:,i,j,k)*this%V(i,j:j+1,k)) & + & -2.0_WP/3.0_WP*(sum(this%divp_x(:,i,j,k)*this%U(i:i+1,j,k))+sum(this%divp_y(:,i,j,k)*this%V(i,j:j+1,k))+sum(this%divp_z(:,i,j,k)*this%W(i,j,k:k+1)))) & + & -this%P(i,j,k) + ! Fluxes on z-face + i=ii; j=jj; k=kk + FZ(i,j,k)=-this%rho*sum(this%itpv_z(:,i,j,k)*this%V(i,j,k-1:k))*sum(this%itpw_y(:,i,j,k)*this%W(i,j-1:j,k)) & + & +sum(this%itp_yz(:,:,i,j,k)*this%visc(i,j-1:j,k-1:k))*(sum(this%grdv_z(:,i,j,k)*this%V(i,j,k-1:k))+sum(this%grdw_y(:,i,j,k)*this%W(i,j-1:j,k))) + end do + end do + end do + ! Time derivative of rhoV + do k=this%cfg%kmin_,this%cfg%kmax_ + do j=this%cfg%jmin_,this%cfg%jmax_ + do i=this%cfg%imin_,this%cfg%imax_ + drhoVdt(i,j,k)=sum(this%divv_x(:,i,j,k)*FX(i:i+1,j,k))+& + & sum(this%divv_y(:,i,j,k)*FY(i,j-1:j,k))+& + & sum(this%divv_z(:,i,j,k)*FZ(i,j,k:k+1)) + end do + end do + end do + ! Sync it + call this%cfg%sync(drhoVdt) + + ! Flux of rhoW + do kk=this%cfg%kmin_,this%cfg%kmax_+1 + do jj=this%cfg%jmin_,this%cfg%jmax_+1 + do ii=this%cfg%imin_,this%cfg%imax_+1 + ! Fluxes on x-face + i=ii; j=jj; k=kk + FX(i,j,k)=-this%rho*sum(this%itpw_x(:,i,j,k)*this%W(i-1:i,j,k))*sum(this%itpu_z(:,i,j,k)*this%U(i,j,k-1:k)) & + & +sum(this%itp_xz(:,:,i,j,k)*this%visc(i-1:i,j,k-1:k))*(sum(this%grdw_x(:,i,j,k)*this%W(i-1:i,j,k))+sum(this%grdu_z(:,i,j,k)*this%U(i,j,k-1:k))) + ! Fluxes on y-face + i=ii; j=jj; k=kk + FY(i,j,k)=-this%rho*sum(this%itpw_y(:,i,j,k)*this%W(i,j-1:j,k))*sum(this%itpv_z(:,i,j,k)*this%V(i,j,k-1:k)) & + & +sum(this%itp_yz(:,:,i,j,k)*this%visc(i,j-1:j,k-1:k))*(sum(this%grdw_y(:,i,j,k)*this%W(i,j-1:j,k))+sum(this%grdv_z(:,i,j,k)*this%V(i,j,k-1:k))) + ! Fluxes on z-face + i=ii-1; j=jj-1; k=kk-1 + FZ(i,j,k)=-this%rho*sum(this%itpw_z(:,i,j,k)*this%W(i,j,k:k+1))*sum(this%itpw_z(:,i,j,k)*this%W(i,j,k:k+1)) & + & +this%visc(i,j,k)*(sum(this%grdw_z(:,i,j,k)*this%W(i,j,k:k+1))+sum(this%grdw_z(:,i,j,k)*this%W(i,j,k:k+1)) & + & -2.0_WP/3.0_WP*(sum(this%divp_x(:,i,j,k)*this%U(i:i+1,j,k))+sum(this%divp_y(:,i,j,k)*this%V(i,j:j+1,k))+sum(this%divp_z(:,i,j,k)*this%W(i,j,k:k+1)))) & + & -this%P(i,j,k) + end do + end do + end do + ! Time derivative of rhoW + do k=this%cfg%kmin_,this%cfg%kmax_ + do j=this%cfg%jmin_,this%cfg%jmax_ + do i=this%cfg%imin_,this%cfg%imax_ + drhoWdt(i,j,k)=sum(this%divw_x(:,i,j,k)*FX(i:i+1,j,k))+& + & sum(this%divw_y(:,i,j,k)*FY(i,j:j+1,k))+& + & sum(this%divw_z(:,i,j,k)*FZ(i,j,k-1:k)) + end do + end do + end do + ! Sync it + call this%cfg%sync(drhoWdt) + + ! Deallocate flux arrays + deallocate(FX,FY,FZ) + + end subroutine get_dmomdt + + !> Calculate divergence of stress for LPT solver + subroutine get_div_stress(this,divx,divy,divz) + implicit none + class(incomp), intent(inout) :: this + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(out) :: divx !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(out) :: divy !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(out) :: divz !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + integer :: i,j,k,ii,jj,kk + real(WP), dimension(:,:,:), allocatable :: FX,FY,FZ + + ! Zero out drhoUVW/dt arrays + divx=0.0_WP; divy=0.0_WP; divz=0.0_WP + + ! Allocate flux arrays + allocate(FX(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + allocate(FY(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + allocate(FZ(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + + ! Flux of rhoU + do kk=this%cfg%kmin_,this%cfg%kmax_+1 + do jj=this%cfg%jmin_,this%cfg%jmax_+1 + do ii=this%cfg%imin_,this%cfg%imax_+1 + ! Fluxes on x-face + i=ii-1; j=jj-1; k=kk-1 + FX(i,j,k)=this%visc(i,j,k)*(sum(this%grdu_x(:,i,j,k)*this%U(i:i+1,j,k))+sum(this%grdu_x(:,i,j,k)*this%U(i:i+1,j,k))) & + ! & -2.0_WP/3.0_WP*(sum(this%divp_x(:,i,j,k)*this%U(i:i+1,j,k))+sum(this%divp_y(:,i,j,k)*this%V(i,j:j+1,k))+sum(this%divp_z(:,i,j,k)*this%W(i,j,k:k+1)))) & + & -this%P(i,j,k) + ! Fluxes on y-face + i=ii; j=jj; k=kk + FY(i,j,k)=sum(this%itp_xy(:,:,i,j,k)*this%visc(i-1:i,j-1:j,k))*(sum(this%grdu_y(:,i,j,k)*this%U(i,j-1:j,k))+sum(this%grdv_x(:,i,j,k)*this%V(i-1:i,j,k))) + ! Fluxes on z-face + i=ii; j=jj; k=kk + FZ(i,j,k)=sum(this%itp_xz(:,:,i,j,k)*this%visc(i-1:i,j,k-1:k))*(sum(this%grdu_z(:,i,j,k)*this%U(i,j,k-1:k))+sum(this%grdw_x(:,i,j,k)*this%W(i-1:i,j,k))) + end do + end do + end do + ! Divergence of stresses + do k=this%cfg%kmin_,this%cfg%kmax_ + do j=this%cfg%jmin_,this%cfg%jmax_ + do i=this%cfg%imin_,this%cfg%imax_ + divx(i,j,k)=sum(this%divu_x(:,i,j,k)*FX(i-1:i,j,k))+& + & sum(this%divu_y(:,i,j,k)*FY(i,j:j+1,k))+& + & sum(this%divu_z(:,i,j,k)*FZ(i,j,k:k+1)) + end do + end do + end do + ! Sync it + call this%cfg%sync(divx) + + ! Flux of rhoV + do kk=this%cfg%kmin_,this%cfg%kmax_+1 + do jj=this%cfg%jmin_,this%cfg%jmax_+1 + do ii=this%cfg%imin_,this%cfg%imax_+1 + ! Fluxes on x-face + i=ii; j=jj; k=kk + FX(i,j,k)=sum(this%itp_xy(:,:,i,j,k)*this%visc(i-1:i,j-1:j,k))*(sum(this%grdv_x(:,i,j,k)*this%V(i-1:i,j,k))+sum(this%grdu_y(:,i,j,k)*this%U(i,j-1:j,k))) + ! Fluxes on y-face + i=ii-1; j=jj-1; k=kk-1 + FY(i,j,k)=this%visc(i,j,k)*(sum(this%grdv_y(:,i,j,k)*this%V(i,j:j+1,k))+sum(this%grdv_y(:,i,j,k)*this%V(i,j:j+1,k))) & + ! & -2.0_WP/3.0_WP*(sum(this%divp_x(:,i,j,k)*this%U(i:i+1,j,k))+sum(this%divp_y(:,i,j,k)*this%V(i,j:j+1,k))+sum(this%divp_z(:,i,j,k)*this%W(i,j,k:k+1)))) & + & -this%P(i,j,k) + ! Fluxes on z-face + i=ii; j=jj; k=kk + FZ(i,j,k)=sum(this%itp_yz(:,:,i,j,k)*this%visc(i,j-1:j,k-1:k))*(sum(this%grdv_z(:,i,j,k)*this%V(i,j,k-1:k))+sum(this%grdw_y(:,i,j,k)*this%W(i,j-1:j,k))) + end do + end do + end do + ! Divergence of stresses + do k=this%cfg%kmin_,this%cfg%kmax_ + do j=this%cfg%jmin_,this%cfg%jmax_ + do i=this%cfg%imin_,this%cfg%imax_ + divy(i,j,k)=sum(this%divv_x(:,i,j,k)*FX(i:i+1,j,k))+& + & sum(this%divv_y(:,i,j,k)*FY(i,j-1:j,k))+& + & sum(this%divv_z(:,i,j,k)*FZ(i,j,k:k+1)) + end do + end do + end do + ! Sync it + call this%cfg%sync(divy) + + ! Flux of rhoW + do kk=this%cfg%kmin_,this%cfg%kmax_+1 + do jj=this%cfg%jmin_,this%cfg%jmax_+1 + do ii=this%cfg%imin_,this%cfg%imax_+1 + ! Fluxes on x-face + i=ii; j=jj; k=kk + FX(i,j,k)=sum(this%itp_xz(:,:,i,j,k)*this%visc(i-1:i,j,k-1:k))*(sum(this%grdw_x(:,i,j,k)*this%W(i-1:i,j,k))+sum(this%grdu_z(:,i,j,k)*this%U(i,j,k-1:k))) + ! Fluxes on y-face + i=ii; j=jj; k=kk + FY(i,j,k)=sum(this%itp_yz(:,:,i,j,k)*this%visc(i,j-1:j,k-1:k))*(sum(this%grdw_y(:,i,j,k)*this%W(i,j-1:j,k))+sum(this%grdv_z(:,i,j,k)*this%V(i,j,k-1:k))) + ! Fluxes on z-face + i=ii-1; j=jj-1; k=kk-1 + FZ(i,j,k)=this%visc(i,j,k)*(sum(this%grdw_z(:,i,j,k)*this%W(i,j,k:k+1))+sum(this%grdw_z(:,i,j,k)*this%W(i,j,k:k+1))) & + ! & -2.0_WP/3.0_WP*(sum(this%divp_x(:,i,j,k)*this%U(i:i+1,j,k))+sum(this%divp_y(:,i,j,k)*this%V(i,j:j+1,k))+sum(this%divp_z(:,i,j,k)*this%W(i,j,k:k+1)))) & + & -this%P(i,j,k) + end do + end do + end do + ! Divergence of stresses + do k=this%cfg%kmin_,this%cfg%kmax_ + do j=this%cfg%jmin_,this%cfg%jmax_ + do i=this%cfg%imin_,this%cfg%imax_ + divz(i,j,k)=sum(this%divw_x(:,i,j,k)*FX(i:i+1,j,k))+& + & sum(this%divw_y(:,i,j,k)*FY(i,j:j+1,k))+& + & sum(this%divw_z(:,i,j,k)*FZ(i,j,k-1:k)) + end do + end do + end do + ! Sync it + call this%cfg%sync(divz) + + ! Deallocate flux arrays + deallocate(FX,FY,FZ) + + end subroutine get_div_stress + + + !> Calculate the velocity divergence based on U/V/W + subroutine get_div(this,src) + implicit none + class(incomp), intent(inout) :: this + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), optional :: src !< Mass source term + integer :: i,j,k + ! Calculate divergence of velocity + do k=this%cfg%kmin_,this%cfg%kmax_ + do j=this%cfg%jmin_,this%cfg%jmax_ + do i=this%cfg%imin_,this%cfg%imax_ + this%div(i,j,k)=sum(this%divp_x(:,i,j,k)*this%U(i:i+1,j,k))+& + & sum(this%divp_y(:,i,j,k)*this%V(i,j:j+1,k))+& + & sum(this%divp_z(:,i,j,k)*this%W(i,j,k:k+1)) + end do + end do + end do + ! If present, account for mass source + if (present(src)) then + do k=this%cfg%kmin_,this%cfg%kmax_ + do j=this%cfg%jmin_,this%cfg%jmax_ + do i=this%cfg%imin_,this%cfg%imax_ + this%div(i,j,k)=this%div(i,j,k)-src(i,j,k) + end do + end do + end do + end if + ! Sync it + call this%cfg%sync(this%div) + end subroutine get_div + + + !> Calculate the pressure gradient based on P + subroutine get_pgrad(this,P,Pgradx,Pgrady,Pgradz) + implicit none + class(incomp), intent(inout) :: this + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(in) :: P !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(out) :: Pgradx !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(out) :: Pgrady !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(out) :: Pgradz !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + integer :: i,j,k + Pgradx=0.0_WP; Pgrady=0.0_WP; Pgradz=0.0_WP + do k=this%cfg%kmin_,this%cfg%kmax_ + do j=this%cfg%jmin_,this%cfg%jmax_ + do i=this%cfg%imin_,this%cfg%imax_ + Pgradx(i,j,k)=sum(this%divu_x(:,i,j,k)*P(i-1:i,j,k)) + Pgrady(i,j,k)=sum(this%divv_y(:,i,j,k)*P(i,j-1:j,k)) + Pgradz(i,j,k)=sum(this%divw_z(:,i,j,k)*P(i,j,k-1:k)) + end do + end do + end do + ! Sync it + call this%cfg%sync(Pgradx) + call this%cfg%sync(Pgrady) + call this%cfg%sync(Pgradz) + end subroutine get_pgrad + + + !> Calculate the interpolated velocity, including overlap and ghosts + subroutine interp_vel(this,Ui,Vi,Wi) + implicit none + class(incomp), intent(inout) :: this + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(out) :: Ui !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(out) :: Vi !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(out) :: Wi !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + integer :: i,j,k + ! Calculate as far as possible each component + do k=this%cfg%kmino_,this%cfg%kmaxo_ + do j=this%cfg%jmino_,this%cfg%jmaxo_ + do i=this%cfg%imino_,this%cfg%imaxo_-1 + Ui(i,j,k)=sum(this%itpu_x(:,i,j,k)*this%U(i:i+1,j,k)) + end do + end do + end do + do k=this%cfg%kmino_,this%cfg%kmaxo_ + do j=this%cfg%jmino_,this%cfg%jmaxo_-1 + do i=this%cfg%imino_,this%cfg%imaxo_ + Vi(i,j,k)=sum(this%itpv_y(:,i,j,k)*this%V(i,j:j+1,k)) + end do + end do + end do + do k=this%cfg%kmino_,this%cfg%kmaxo_-1 + do j=this%cfg%jmino_,this%cfg%jmaxo_ + do i=this%cfg%imino_,this%cfg%imaxo_ + Wi(i,j,k)=sum(this%itpw_z(:,i,j,k)*this%W(i,j,k:k+1)) + end do + end do + end do + ! Add last layer in each direction + if (.not.this%cfg%xper.and.this%cfg%iproc.eq.this%cfg%npx) Ui(this%cfg%imaxo,:,:)=this%U(this%cfg%imaxo,:,:) + if (.not.this%cfg%yper.and.this%cfg%jproc.eq.this%cfg%npy) Vi(:,this%cfg%jmaxo,:)=this%V(:,this%cfg%jmaxo,:) + if (.not.this%cfg%zper.and.this%cfg%kproc.eq.this%cfg%npz) Wi(:,:,this%cfg%kmaxo)=this%W(:,:,this%cfg%kmaxo) + ! Sync it + call this%cfg%sync(Ui) + call this%cfg%sync(Vi) + call this%cfg%sync(Wi) + end subroutine interp_vel + + + !> Calculate the deviatoric part of the strain rate tensor from U/V/W + !> 1: du/dx-div/3 + !> 2: dv/dy-div/3 + !> 3: dw/dz-div/3 + !> 4: (du/dy+dv/dx)/2 + !> 5: (dv/dz+dw/dy)/2 + !> 6: (dw/dx+du/dz)/2 + subroutine get_strainrate(this,SR) + use messager, only: die + implicit none + class(incomp), intent(inout) :: this + real(WP), dimension(1:,this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(out) :: SR !< Needs to be (1:6,imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + real(WP), dimension(:,:,:), allocatable :: dudy,dudz,dvdx,dvdz,dwdx,dwdy + real(WP) :: div + integer :: i,j,k + + ! Check SR's first dimension + if (size(SR,dim=1).ne.6) call die('[incomp get_strainrate] SR should be of size (1:6,imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_)') + + ! Compute dudx, dvdy, and dwdz first + do k=this%cfg%kmin_,this%cfg%kmax_ + do j=this%cfg%jmin_,this%cfg%jmax_ + do i=this%cfg%imin_,this%cfg%imax_ + SR(1,i,j,k)=sum(this%grdu_x(:,i,j,k)*this%U(i:i+1,j,k)) + SR(2,i,j,k)=sum(this%grdv_y(:,i,j,k)*this%V(i,j:j+1,k)) + SR(3,i,j,k)=sum(this%grdw_z(:,i,j,k)*this%W(i,j,k:k+1)) + div=sum(SR(1:3,i,j,k))/3.0_WP + SR(1,i,j,k)=SR(1,i,j,k)-div + SR(2,i,j,k)=SR(2,i,j,k)-div + SR(3,i,j,k)=SR(3,i,j,k)-div + end do + end do + end do + + ! Allocate velocity gradient components + allocate(dudy(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + allocate(dudz(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + allocate(dvdx(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + allocate(dvdz(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + allocate(dwdx(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + allocate(dwdy(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + + ! Calculate components of the velocity gradient at their natural locations with an extra cell for interpolation + do k=this%cfg%kmin_,this%cfg%kmax_+1 + do j=this%cfg%jmin_,this%cfg%jmax_+1 + do i=this%cfg%imin_,this%cfg%imax_+1 + dudy(i,j,k)=sum(this%grdu_y(:,i,j,k)*this%U(i,j-1:j,k)) + dudz(i,j,k)=sum(this%grdu_z(:,i,j,k)*this%U(i,j,k-1:k)) + dvdx(i,j,k)=sum(this%grdv_x(:,i,j,k)*this%V(i-1:i,j,k)) + dvdz(i,j,k)=sum(this%grdv_z(:,i,j,k)*this%V(i,j,k-1:k)) + dwdx(i,j,k)=sum(this%grdw_x(:,i,j,k)*this%W(i-1:i,j,k)) + dwdy(i,j,k)=sum(this%grdw_y(:,i,j,k)*this%W(i,j-1:j,k)) + end do + end do + end do + + ! Interpolate off-diagonal components of the velocity gradient to the cell center and store strain rate + do k=this%cfg%kmin_,this%cfg%kmax_ + do j=this%cfg%jmin_,this%cfg%jmax_ + do i=this%cfg%imin_,this%cfg%imax_ + SR(4,i,j,k)=0.125_WP*(sum(dudy(i:i+1,j:j+1,k ))+sum(dvdx(i:i+1,j:j+1,k ))) + SR(5,i,j,k)=0.125_WP*(sum(dvdz(i ,j:j+1,k:k+1))+sum(dwdy(i ,j:j+1,k:k+1))) + SR(6,i,j,k)=0.125_WP*(sum(dwdx(i:i+1,j ,k:k+1))+sum(dudz(i:i+1,j ,k:k+1))) + end do + end do + end do + + ! Apply a Neumann condition in non-periodic directions + if (.not.this%cfg%xper) then + if (this%cfg%iproc.eq.1) SR(:,this%cfg%imin-1,:,:)=SR(:,this%cfg%imin,:,:) + if (this%cfg%iproc.eq.this%cfg%npx) SR(:,this%cfg%imax+1,:,:)=SR(:,this%cfg%imax,:,:) + end if + if (.not.this%cfg%yper) then + if (this%cfg%jproc.eq.1) SR(:,:,this%cfg%jmin-1,:)=SR(:,:,this%cfg%jmin,:) + if (this%cfg%jproc.eq.this%cfg%npy) SR(:,:,this%cfg%jmax+1,:)=SR(:,:,this%cfg%jmax,:) + end if + if (.not.this%cfg%zper) then + if (this%cfg%kproc.eq.1) SR(:,:,:,this%cfg%kmin-1)=SR(:,:,:,this%cfg%kmin) + if (this%cfg%kproc.eq.this%cfg%npz) SR(:,:,:,this%cfg%kmax+1)=SR(:,:,:,this%cfg%kmax) + end if + + ! Ensure zero in walls + do k=this%cfg%kmino_,this%cfg%kmaxo_ + do j=this%cfg%jmino_,this%cfg%jmaxo_ + do i=this%cfg%imino_,this%cfg%imaxo_ + if (this%mask(i,j,k).eq.1) SR(:,i,j,k)=0.0_WP + end do + end do + end do + + ! Sync it + call this%cfg%sync(SR) + + ! Deallocate velocity gradient storage + deallocate(dudy,dudz,dvdx,dvdz,dwdx,dwdy) + + end subroutine get_strainrate + + + !> Calculate the velocity gradient tensor from U/V/W + !> Note that gradu(i,j)=duj/dxi + subroutine get_gradu(this,gradu) + use messager, only: die + implicit none + class(incomp), intent(inout) :: this + real(WP), dimension(1:,1:,this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(out) :: gradu !< Needs to be (1:3,1:3,imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + integer :: i,j,k + real(WP), dimension(:,:,:), allocatable :: dudy,dudz,dvdx,dvdz,dwdx,dwdy + + ! Check gradu's first two dimensions + if (size(gradu,dim=1).ne.3.or.size(gradu,dim=2).ne.3) call die('[incomp get_gradu] gradu should be of size (1:3,1:3,imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_)') + + ! Compute dudx, dvdy, and dwdz first + do k=this%cfg%kmin_,this%cfg%kmax_ + do j=this%cfg%jmin_,this%cfg%jmax_ + do i=this%cfg%imin_,this%cfg%imax_ + gradu(1,1,i,j,k)=sum(this%grdu_x(:,i,j,k)*this%U(i:i+1,j,k)) + gradu(2,2,i,j,k)=sum(this%grdv_y(:,i,j,k)*this%V(i,j:j+1,k)) + gradu(3,3,i,j,k)=sum(this%grdw_z(:,i,j,k)*this%W(i,j,k:k+1)) + end do + end do + end do + + ! Allocate velocity gradient components + allocate(dudy(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + allocate(dudz(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + allocate(dvdx(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + allocate(dvdz(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + allocate(dwdx(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + allocate(dwdy(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + + ! Calculate components of the velocity gradient at their natural locations with an extra cell for interpolation + do k=this%cfg%kmin_,this%cfg%kmax_+1 + do j=this%cfg%jmin_,this%cfg%jmax_+1 + do i=this%cfg%imin_,this%cfg%imax_+1 + dudy(i,j,k)=sum(this%grdu_y(:,i,j,k)*this%U(i,j-1:j,k)) + dudz(i,j,k)=sum(this%grdu_z(:,i,j,k)*this%U(i,j,k-1:k)) + dvdx(i,j,k)=sum(this%grdv_x(:,i,j,k)*this%V(i-1:i,j,k)) + dvdz(i,j,k)=sum(this%grdv_z(:,i,j,k)*this%V(i,j,k-1:k)) + dwdx(i,j,k)=sum(this%grdw_x(:,i,j,k)*this%W(i-1:i,j,k)) + dwdy(i,j,k)=sum(this%grdw_y(:,i,j,k)*this%W(i,j-1:j,k)) + end do + end do + end do + + ! Interpolate off-diagonal components of the velocity gradient to the cell center + do k=this%cfg%kmin_,this%cfg%kmax_ + do j=this%cfg%jmin_,this%cfg%jmax_ + do i=this%cfg%imin_,this%cfg%imax_ + gradu(2,1,i,j,k)=0.25_WP*sum(dudy(i:i+1,j:j+1,k)) + gradu(3,1,i,j,k)=0.25_WP*sum(dudz(i:i+1,j,k:k+1)) + gradu(1,2,i,j,k)=0.25_WP*sum(dvdx(i:i+1,j:j+1,k)) + gradu(3,2,i,j,k)=0.25_WP*sum(dvdz(i,j:j+1,k:k+1)) + gradu(1,3,i,j,k)=0.25_WP*sum(dwdx(i:i+1,j,k:k+1)) + gradu(2,3,i,j,k)=0.25_WP*sum(dwdy(i,j:j+1,k:k+1)) + end do + end do + end do + + ! Apply a Neumann condition in non-periodic directions + if (.not.this%cfg%xper) then + if (this%cfg%iproc.eq.1) gradu(:,:,this%cfg%imin-1,:,:)=gradu(:,:,this%cfg%imin,:,:) + if (this%cfg%iproc.eq.this%cfg%npx) gradu(:,:,this%cfg%imax+1,:,:)=gradu(:,:,this%cfg%imax,:,:) + end if + if (.not.this%cfg%yper) then + if (this%cfg%jproc.eq.1) gradu(:,:,:,this%cfg%jmin-1,:)=gradu(:,:,:,this%cfg%jmin,:) + if (this%cfg%jproc.eq.this%cfg%npy) gradu(:,:,:,this%cfg%jmax+1,:)=gradu(:,:,:,this%cfg%jmax,:) + end if + if (.not.this%cfg%zper) then + if (this%cfg%kproc.eq.1) gradu(:,:,:,:,this%cfg%kmin-1)=gradu(:,:,:,:,this%cfg%kmin) + if (this%cfg%kproc.eq.this%cfg%npz) gradu(:,:,:,:,this%cfg%kmax+1)=gradu(:,:,:,:,this%cfg%kmax) + end if + + ! Ensure zero in walls + do k=this%cfg%kmino_,this%cfg%kmaxo_ + do j=this%cfg%jmino_,this%cfg%jmaxo_ + do i=this%cfg%imino_,this%cfg%imaxo_ + if (this%mask(i,j,k).eq.1) gradu(:,:,i,j,k)=0.0_WP + end do + end do + end do + + ! Sync it + call this%cfg%sync(gradu) + + ! Deallocate velocity gradient storage + deallocate(dudy,dudz,dvdx,dvdz,dwdx,dwdy) + + end subroutine get_gradu + + + !> Calculate vorticity vector + subroutine get_vorticity(this,vort) + use messager, only: die + implicit none + class(incomp), intent(inout) :: this + real(WP), dimension(1:,this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(out) :: vort !< Needs to be (1:3,imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + integer :: i,j,k + real(WP), dimension(:,:,:), allocatable :: dudy,dudz,dvdx,dvdz,dwdx,dwdy + + ! Check vort's first two dimensions + if (size(vort,dim=1).ne.3) call die('[incomp get_vorticity] vort should be of size (1:3,imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_)') + + ! Allocate velocity gradient components + allocate(dudy(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + allocate(dudz(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + allocate(dvdx(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + allocate(dvdz(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + allocate(dwdx(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + allocate(dwdy(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + + ! Calculate components of the velocity gradient at their natural locations with an extra cell for interpolation + do k=this%cfg%kmin_,this%cfg%kmax_+1 + do j=this%cfg%jmin_,this%cfg%jmax_+1 + do i=this%cfg%imin_,this%cfg%imax_+1 + dudy(i,j,k)=sum(this%grdu_y(:,i,j,k)*this%U(i,j-1:j,k)) + dudz(i,j,k)=sum(this%grdu_z(:,i,j,k)*this%U(i,j,k-1:k)) + dvdx(i,j,k)=sum(this%grdv_x(:,i,j,k)*this%V(i-1:i,j,k)) + dvdz(i,j,k)=sum(this%grdv_z(:,i,j,k)*this%V(i,j,k-1:k)) + dwdx(i,j,k)=sum(this%grdw_x(:,i,j,k)*this%W(i-1:i,j,k)) + dwdy(i,j,k)=sum(this%grdw_y(:,i,j,k)*this%W(i,j-1:j,k)) + end do + end do + end do + + ! Interpolate off-diagonal components of the velocity gradient to the cell center + do k=this%cfg%kmin_,this%cfg%kmax_ + do j=this%cfg%jmin_,this%cfg%jmax_ + do i=this%cfg%imin_,this%cfg%imax_ + vort(1,i,j,k)=0.25_WP*(sum(dwdy(i,j:j+1,k:k+1))-sum(dvdz(i,j:j+1,k:k+1))) + vort(2,i,j,k)=0.25_WP*(sum(dudz(i:i+1,j,k:k+1))-sum(dwdx(i:i+1,j,k:k+1))) + vort(3,i,j,k)=0.25_WP*(sum(dvdx(i:i+1,j:j+1,k))-sum(dudy(i:i+1,j:j+1,k))) + end do + end do + end do + + ! Apply a Neumann condition in non-periodic directions + if (.not.this%cfg%xper) then + if (this%cfg%iproc.eq.1) vort(:,this%cfg%imin-1,:,:)=vort(:,this%cfg%imin,:,:) + if (this%cfg%iproc.eq.this%cfg%npx) vort(:,this%cfg%imax+1,:,:)=vort(:,this%cfg%imax,:,:) + end if + if (.not.this%cfg%yper) then + if (this%cfg%jproc.eq.1) vort(:,:,this%cfg%jmin-1,:)=vort(:,:,this%cfg%jmin,:) + if (this%cfg%jproc.eq.this%cfg%npy) vort(:,:,this%cfg%jmax+1,:)=vort(:,:,this%cfg%jmax,:) + end if + if (.not.this%cfg%zper) then + if (this%cfg%kproc.eq.1) vort(:,:,:,this%cfg%kmin-1)=vort(:,:,:,this%cfg%kmin) + if (this%cfg%kproc.eq.this%cfg%npz) vort(:,:,:,this%cfg%kmax+1)=vort(:,:,:,this%cfg%kmax) + end if + + ! Ensure zero in walls + do k=this%cfg%kmino_,this%cfg%kmaxo_ + do j=this%cfg%jmino_,this%cfg%jmaxo_ + do i=this%cfg%imino_,this%cfg%imaxo_ + if (this%mask(i,j,k).eq.1) vort(:,i,j,k)=0.0_WP + end do + end do + end do + + ! Sync it + call this%cfg%sync(vort) + + ! Deallocate velocity gradient storage + deallocate(dudy,dudz,dvdx,dvdz,dwdx,dwdy) + + end subroutine get_vorticity + + + !> Calculate the CFL + subroutine get_cfl(this,dt,cflc,cfl) + use mpi_f08, only: MPI_ALLREDUCE,MPI_MAX + use parallel, only: MPI_REAL_WP + implicit none + class(incomp), intent(inout) :: this + real(WP), intent(in) :: dt + real(WP), intent(out) :: cflc + real(WP), optional :: cfl + integer :: i,j,k,ierr + real(WP) :: my_CFLc_x,my_CFLc_y,my_CFLc_z,my_CFLv_x,my_CFLv_y,my_CFLv_z + + ! Set the CFLs to zero + my_CFLc_x=0.0_WP; my_CFLc_y=0.0_WP; my_CFLc_z=0.0_WP + my_CFLv_x=0.0_WP; my_CFLv_y=0.0_WP; my_CFLv_z=0.0_WP + do k=this%cfg%kmin_,this%cfg%kmax_ + do j=this%cfg%jmin_,this%cfg%jmax_ + do i=this%cfg%imin_,this%cfg%imax_ + my_CFLc_x=max(my_CFLc_x,abs(this%U(i,j,k))*this%cfg%dxmi(i)) + my_CFLc_y=max(my_CFLc_y,abs(this%V(i,j,k))*this%cfg%dymi(j)) + my_CFLc_z=max(my_CFLc_z,abs(this%W(i,j,k))*this%cfg%dzmi(k)) + my_CFLv_x=max(my_CFLv_x,4.0_WP*this%visc(i,j,k)*this%cfg%dxi(i)**2/this%rho) + my_CFLv_y=max(my_CFLv_y,4.0_WP*this%visc(i,j,k)*this%cfg%dyi(j)**2/this%rho) + my_CFLv_z=max(my_CFLv_z,4.0_WP*this%visc(i,j,k)*this%cfg%dzi(k)**2/this%rho) + end do + end do + end do + my_CFLc_x=my_CFLc_x*dt; my_CFLc_y=my_CFLc_y*dt; my_CFLc_z=my_CFLc_z*dt + my_CFLv_x=my_CFLv_x*dt; my_CFLv_y=my_CFLv_y*dt; my_CFLv_z=my_CFLv_z*dt + + ! Get the parallel max + call MPI_ALLREDUCE(my_CFLc_x,this%CFLc_x,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + call MPI_ALLREDUCE(my_CFLc_y,this%CFLc_y,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + call MPI_ALLREDUCE(my_CFLc_z,this%CFLc_z,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + call MPI_ALLREDUCE(my_CFLv_x,this%CFLv_x,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + call MPI_ALLREDUCE(my_CFLv_y,this%CFLv_y,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + call MPI_ALLREDUCE(my_CFLv_z,this%CFLv_z,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + + ! Return the maximum convective CFL + cflc=max(this%CFLc_x,this%CFLc_y,this%CFLc_z) + + ! If asked for, also return the maximum overall CFL + if (present(CFL)) cfl=max(this%CFLc_x,this%CFLc_y,this%CFLc_z,this%CFLv_x,this%CFLv_y,this%CFLv_z) + + end subroutine get_cfl + + + !> Calculate the max of our fields + subroutine get_max(this) + use mpi_f08, only: MPI_ALLREDUCE,MPI_MAX + use parallel, only: MPI_REAL_WP + implicit none + class(incomp), intent(inout) :: this + integer :: i,j,k,ierr + real(WP) :: my_Umax,my_Vmax,my_Wmax,my_Pmax,my_divmax + + ! Set all to zero + my_Umax=0.0_WP; my_Vmax=0.0_WP; my_Wmax=0.0_WP; my_Pmax=0.0_WP; my_divmax=0.0_WP + do k=this%cfg%kmin_,this%cfg%kmax_ + do j=this%cfg%jmin_,this%cfg%jmax_ + do i=this%cfg%imin_,this%cfg%imax_ + my_Umax =max(my_Umax ,abs(this%U(i,j,k) )) + my_Vmax =max(my_Vmax ,abs(this%V(i,j,k) )) + my_Wmax =max(my_Wmax ,abs(this%W(i,j,k) )) + if (this%cfg%VF(i,j,k).gt.0.0_WP) my_Pmax =max(my_Pmax ,abs(this%P(i,j,k) )) + if (this%cfg%VF(i,j,k).gt.0.0_WP) my_divmax=max(my_divmax,abs(this%div(i,j,k))) + end do + end do + end do + + ! Get the parallel max + call MPI_ALLREDUCE(my_Umax ,this%Umax ,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + call MPI_ALLREDUCE(my_Vmax ,this%Vmax ,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + call MPI_ALLREDUCE(my_Wmax ,this%Wmax ,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + call MPI_ALLREDUCE(my_Pmax ,this%Pmax ,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + call MPI_ALLREDUCE(my_divmax,this%divmax,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + + end subroutine get_max + + + !> Compute MFR through all bcs + subroutine get_mfr(this) + use mpi_f08, only: MPI_SUM,MPI_ALLREDUCE + use parallel, only: MPI_REAL_WP + implicit none + class(incomp), intent(inout) :: this + integer :: i,j,k,n,ibc,ierr + type(bcond), pointer :: my_bc + real(WP), dimension(:), allocatable :: my_mfr,my_area + real(WP), dimension(:), allocatable :: canCorrect + + ! Ensure this%mfr is of proper size + if (.not.allocated(this%mfr)) then + allocate(this%mfr(this%nbc)) + else + if (size(this%mfr).ne.this%nbc) then + deallocate(this%mfr); allocate(this%mfr(this%nbc)) + end if + end if + + ! Ensure this%area is of proper size + if (.not.allocated(this%area)) then + allocate(this%area(this%nbc)) + else + if (size(this%area).ne.this%nbc) then + deallocate(this%area); allocate(this%area(this%nbc)) + end if + end if + + ! Allocate temp array for communication + allocate(my_mfr(this%nbc)) + allocate(my_area(this%nbc)) + allocate(canCorrect(this%nbc)) + + ! Traverse bcond list and integrate local outgoing MFR + my_bc=>this%first_bc; ibc=1 + do while (associated(my_bc)) + + ! Set zero local MFR and area + my_mfr(ibc)=0.0_WP + my_area(ibc)=0.0_WP + if (my_bc%canCorrect) then + canCorrect(ibc)=1.0_WP + else + canCorrect(ibc)=0.0_WP + end if + + ! Only processes inside the bcond have a non-zero MFR + if (my_bc%itr%amIn) then + + ! Implement based on bcond face and dir, loop over interior only + select case (my_bc%face) + case ('x') + do n=1,my_bc%itr%n_ + i=my_bc%itr%map(1,n); j=my_bc%itr%map(2,n); k=my_bc%itr%map(3,n) + my_mfr(ibc)=my_mfr(ibc)+my_bc%rdir*this%rho*this%U(i,j,k)*this%cfg%dy(j)*this%cfg%dz(k) + my_area(ibc)=my_area(ibc)+this%cfg%dy(j)*this%cfg%dz(k) + end do + case ('y') + do n=1,my_bc%itr%n_ + i=my_bc%itr%map(1,n); j=my_bc%itr%map(2,n); k=my_bc%itr%map(3,n) + my_mfr(ibc)=my_mfr(ibc)+my_bc%rdir*this%rho*this%V(i,j,k)*this%cfg%dz(k)*this%cfg%dx(i) + my_area(ibc)=my_area(ibc)+this%cfg%dz(k)*this%cfg%dx(i) + end do + case ('z') + do n=1,my_bc%itr%n_ + i=my_bc%itr%map(1,n); j=my_bc%itr%map(2,n); k=my_bc%itr%map(3,n) + my_mfr(ibc)=my_mfr(ibc)+my_bc%rdir*this%rho*this%W(i,j,k)*this%cfg%dx(i)*this%cfg%dy(j) + my_area(ibc)=my_area(ibc)+this%cfg%dx(i)*this%cfg%dy(j) + end do + end select + + end if + + ! Move on to the next bcond + my_bc=>my_bc%next; ibc=ibc+1 + + end do + + ! Sum up all values + call MPI_ALLREDUCE(my_mfr ,this%mfr ,this%nbc,MPI_REAL_WP,MPI_SUM,this%cfg%comm,ierr) + call MPI_ALLREDUCE(my_area,this%area,this%nbc,MPI_REAL_WP,MPI_SUM,this%cfg%comm,ierr) + + ! Compute the correctable area + this%correctable_area=sum(this%area*canCorrect) + + ! Deallocate temp array + deallocate(my_mfr,my_area,canCorrect) + + end subroutine get_mfr + + + !> Correct MFR through correctable bconds + subroutine correct_mfr(this,src) + use mpi_f08, only: MPI_SUM + implicit none + class(incomp), intent(inout) :: this + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), optional :: src !< Mass source term + real(WP) :: mfr_error,vel_correction,int + integer :: i,j,k,n + type(bcond), pointer :: my_bc + + ! Evaluate MFR mismatch and velocity correction + call this%get_mfr() + mfr_error=sum(this%mfr) + if (present(src)) then + ! Also account for provided source term + call this%cfg%integrate_without_VF(src,int) + mfr_error=mfr_error-int + end if + if (abs(mfr_error).lt.10.0_WP*epsilon(1.0_WP).or.abs(this%correctable_area).lt.10.0_WP*epsilon(1.0_WP)) return + vel_correction=-mfr_error/(this%rho*this%correctable_area) + + ! Traverse bcond list and correct bcond MFR + my_bc=>this%first_bc + do while (associated(my_bc)) + + ! Only processes inside correctable bcond need to work + if (my_bc%itr%amIn.and.my_bc%canCorrect) then + + ! Implement based on bcond direction, loop over all cell + select case (my_bc%face) + case ('x') + do n=1,my_bc%itr%n_ + i=my_bc%itr%map(1,n); j=my_bc%itr%map(2,n); k=my_bc%itr%map(3,n) + this%U(i,j,k)=this%U(i,j,k)+my_bc%rdir*vel_correction + end do + case ('y') + do n=1,my_bc%itr%n_ + i=my_bc%itr%map(1,n); j=my_bc%itr%map(2,n); k=my_bc%itr%map(3,n) + this%V(i,j,k)=this%V(i,j,k)+my_bc%rdir*vel_correction + end do + case ('z') + do n=1,my_bc%itr%n_ + i=my_bc%itr%map(1,n); j=my_bc%itr%map(2,n); k=my_bc%itr%map(3,n) + this%W(i,j,k)=this%W(i,j,k)+my_bc%rdir*vel_correction + end do + end select + + end if + + ! Move on to the next bcond + my_bc=>my_bc%next + + end do + + ! Sync full fields + call this%cfg%sync(this%U) + call this%cfg%sync(this%V) + call this%cfg%sync(this%W) + + end subroutine correct_mfr + + + !> Shift pressure to ensure zero average + subroutine shift_p(this,pressure) + implicit none + class(incomp), intent(in) :: this + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(inout) :: pressure !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + real(WP) :: pressure_tot + integer :: i,j,k + + ! Compute volume-averaged pressure + call this%cfg%integrate(A=pressure,integral=pressure_tot); pressure_tot=pressure_tot/this%cfg%fluid_vol + + ! Shift the pressure + do k=this%cfg%kmin_,this%cfg%kmax_ + do j=this%cfg%jmin_,this%cfg%jmax_ + do i=this%cfg%imin_,this%cfg%imax_ + if (this%cfg%VF(i,j,k).gt.0.0_WP) pressure(i,j,k)=pressure(i,j,k)-pressure_tot + end do + end do + end do + call this%cfg%sync(pressure) + + end subroutine shift_p + + + !> Solve for implicit velocity residual + subroutine solve_implicit(this,dt,resU,resV,resW) + implicit none + class(incomp), intent(inout) :: this + real(WP), intent(in) :: dt + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(inout) :: resU !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(inout) :: resV !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(inout) :: resW !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + integer :: i,j,k + real(WP) :: rhoUp,rhoUm,rhoVp,rhoVm,rhoWp,rhoWm + + ! If no implicit solver available, just divide by density and return + if (.not.associated(this%implicit)) then + resU=resU/this%rho + resV=resV/this%rho + resW=resW/this%rho + call this%cfg%sync(resU) + call this%cfg%sync(resV) + call this%cfg%sync(resW) + return + end if + + ! Solve implicit U problem + this%implicit%opr(1,:,:,:)=this%rho; this%implicit%opr(2:,:,:,:)=0.0_WP + do k=this%cfg%kmin_,this%cfg%kmax_ + do j=this%cfg%jmin_,this%cfg%jmax_ + do i=this%cfg%imin_,this%cfg%imax_ + rhoUp=this%rho*sum(this%itpu_x(:,i ,j,k)*this%U(i :i+1,j,k))*2.0_WP + rhoUm=this%rho*sum(this%itpu_x(:,i-1,j,k)*this%U(i-1:i ,j,k))*2.0_WP + rhoVp=this%rho*sum(this%itpv_x(:,i,j+1,k)*this%V(i-1:i,j+1,k)) + rhoVm=this%rho*sum(this%itpv_x(:,i,j ,k)*this%V(i-1:i,j ,k)) + rhoWp=this%rho*sum(this%itpw_x(:,i,j,k+1)*this%W(i-1:i,j,k+1)) + rhoWm=this%rho*sum(this%itpw_x(:,i,j,k )*this%W(i-1:i,j,k )) + this%implicit%opr(1,i,j,k)=this%implicit%opr(1,i,j,k)+0.5_WP*dt*(this%divu_x( 0,i,j,k)*this%itpu_x( 0,i ,j,k)*rhoUp+& + & this%divu_x(-1,i,j,k)*this%itpu_x(+1,i-1,j,k)*rhoUm+& + & this%divu_y(+1,i,j,k)*this%itpu_y(-1,i,j+1,k)*rhoVp+& + & this%divu_y( 0,i,j,k)*this%itpu_y( 0,i,j ,k)*rhoVm+& + & this%divu_z(+1,i,j,k)*this%itpu_z(-1,i,j,k+1)*rhoWp+& + & this%divu_z( 0,i,j,k)*this%itpu_z( 0,i,j,k )*rhoWm) + this%implicit%opr(2,i,j,k)=this%implicit%opr(2,i,j,k)+0.5_WP*dt*(this%divu_x( 0,i,j,k)*this%itpu_x(+1,i ,j,k)*rhoUp) + this%implicit%opr(3,i,j,k)=this%implicit%opr(3,i,j,k)+0.5_WP*dt*(this%divu_x(-1,i,j,k)*this%itpu_x( 0,i-1,j,k)*rhoUm) + this%implicit%opr(4,i,j,k)=this%implicit%opr(4,i,j,k)+0.5_WP*dt*(this%divu_y(+1,i,j,k)*this%itpu_y( 0,i,j+1,k)*rhoVp) + this%implicit%opr(5,i,j,k)=this%implicit%opr(5,i,j,k)+0.5_WP*dt*(this%divu_y( 0,i,j,k)*this%itpu_y(-1,i,j ,k)*rhoVm) + this%implicit%opr(6,i,j,k)=this%implicit%opr(6,i,j,k)+0.5_WP*dt*(this%divu_z(+1,i,j,k)*this%itpu_z( 0,i,j,k+1)*rhoWp) + this%implicit%opr(7,i,j,k)=this%implicit%opr(7,i,j,k)+0.5_WP*dt*(this%divu_z( 0,i,j,k)*this%itpu_z(-1,i,j,k )*rhoWm) + end do + end do + end do + do k=this%cfg%kmin_,this%cfg%kmax_ + do j=this%cfg%jmin_,this%cfg%jmax_ + do i=this%cfg%imin_,this%cfg%imax_ + this%implicit%opr(1,i,j,k)=this%implicit%opr(1,i,j,k)-0.5_WP*dt*(this%divu_x( 0,i,j,k)*4.0_WP/3.0_WP* this%visc(i ,j,k) *this%grdu_x( 0,i ,j,k)+& + & this%divu_x(-1,i,j,k)*4.0_WP/3.0_WP* this%visc(i-1,j,k) *this%grdu_x(+1,i-1,j,k)+& + & this%divu_y(+1,i,j,k)*sum(this%itp_xy(:,:,i,j+1,k)*this%visc(i-1:i,j:j+1,k))*this%grdu_y(-1,i,j+1,k)+& + & this%divu_y( 0,i,j,k)*sum(this%itp_xy(:,:,i,j ,k)*this%visc(i-1:i,j-1:j,k))*this%grdu_y( 0,i,j ,k)+& + & this%divu_z(+1,i,j,k)*sum(this%itp_xz(:,:,i,j,k+1)*this%visc(i-1:i,j,k:k+1))*this%grdu_z(-1,i,j,k+1)+& + & this%divu_z( 0,i,j,k)*sum(this%itp_xz(:,:,i,j,k )*this%visc(i-1:i,j,k-1:k))*this%grdu_z( 0,i,j,k )) + this%implicit%opr(2,i,j,k)=this%implicit%opr(2,i,j,k)-0.5_WP*dt*(this%divu_x( 0,i,j,k)*4.0_WP/3.0_WP* this%visc(i ,j,k) *this%grdu_x(+1,i ,j,k)) + this%implicit%opr(3,i,j,k)=this%implicit%opr(3,i,j,k)-0.5_WP*dt*(this%divu_x(-1,i,j,k)*4.0_WP/3.0_WP* this%visc(i-1,j,k) *this%grdu_x( 0,i-1,j,k)) + this%implicit%opr(4,i,j,k)=this%implicit%opr(4,i,j,k)-0.5_WP*dt*(this%divu_y(+1,i,j,k)*sum(this%itp_xy(:,:,i,j+1,k)*this%visc(i-1:i,j:j+1,k))*this%grdu_y( 0,i,j+1,k)) + this%implicit%opr(5,i,j,k)=this%implicit%opr(5,i,j,k)-0.5_WP*dt*(this%divu_y( 0,i,j,k)*sum(this%itp_xy(:,:,i,j ,k)*this%visc(i-1:i,j-1:j,k))*this%grdu_y(-1,i,j ,k)) + this%implicit%opr(6,i,j,k)=this%implicit%opr(6,i,j,k)-0.5_WP*dt*(this%divu_z(+1,i,j,k)*sum(this%itp_xz(:,:,i,j,k+1)*this%visc(i-1:i,j,k:k+1))*this%grdu_z( 0,i,j,k+1)) + this%implicit%opr(7,i,j,k)=this%implicit%opr(7,i,j,k)-0.5_WP*dt*(this%divu_z( 0,i,j,k)*sum(this%itp_xz(:,:,i,j,k )*this%visc(i-1:i,j,k-1:k))*this%grdu_z(-1,i,j,k )) + end do + end do + end do + call this%implicit%setup() + this%implicit%rhs=resU + this%implicit%sol=0.0_WP + call this%implicit%solve() + resU=this%implicit%sol + + ! Solve implicit V problem + this%implicit%opr(1,:,:,:)=this%rho; this%implicit%opr(2:,:,:,:)=0.0_WP + do k=this%cfg%kmin_,this%cfg%kmax_ + do j=this%cfg%jmin_,this%cfg%jmax_ + do i=this%cfg%imin_,this%cfg%imax_ + rhoUp=this%rho*sum(this%itpu_y(:,i+1,j,k)*this%U(i+1,j-1:j,k)) + rhoUm=this%rho*sum(this%itpu_y(:,i ,j,k)*this%U(i ,j-1:j,k)) + rhoVp=this%rho*sum(this%itpv_y(:,i,j ,k)*this%V(i,j :j+1,k))*2.0_WP + rhoVm=this%rho*sum(this%itpv_y(:,i,j-1,k)*this%V(i,j-1:j ,k))*2.0_WP + rhoWp=this%rho*sum(this%itpw_y(:,i,j,k+1)*this%W(i,j-1:j,k+1)) + rhoWm=this%rho*sum(this%itpw_y(:,i,j,k )*this%W(i,j-1:j,k )) + this%implicit%opr(1,i,j,k)=this%implicit%opr(1,i,j,k)+0.5_WP*dt*(this%divv_x(+1,i,j,k)*this%itpv_x(-1,i+1,j,k)*rhoUp+& + & this%divv_x( 0,i,j,k)*this%itpv_x( 0,i ,j,k)*rhoUm+& + & this%divv_y( 0,i,j,k)*this%itpv_y( 0,i,j ,k)*rhoVp+& + & this%divv_y(-1,i,j,k)*this%itpv_y(+1,i,j-1,k)*rhoVm+& + & this%divv_z(+1,i,j,k)*this%itpv_z(-1,i,j,k+1)*rhoWp+& + & this%divv_z( 0,i,j,k)*this%itpv_z( 0,i,j,k )*rhoWm) + this%implicit%opr(2,i,j,k)=this%implicit%opr(2,i,j,k)+0.5_WP*dt*(this%divv_x(+1,i,j,k)*this%itpv_x( 0,i+1,j,k)*rhoUp) + this%implicit%opr(3,i,j,k)=this%implicit%opr(3,i,j,k)+0.5_WP*dt*(this%divv_x( 0,i,j,k)*this%itpv_x(-1,i ,j,k)*rhoUm) + this%implicit%opr(4,i,j,k)=this%implicit%opr(4,i,j,k)+0.5_WP*dt*(this%divv_y( 0,i,j,k)*this%itpv_y(+1,i,j ,k)*rhoVp) + this%implicit%opr(5,i,j,k)=this%implicit%opr(5,i,j,k)+0.5_WP*dt*(this%divv_y(-1,i,j,k)*this%itpv_y( 0,i,j-1,k)*rhoVm) + this%implicit%opr(6,i,j,k)=this%implicit%opr(6,i,j,k)+0.5_WP*dt*(this%divv_z(+1,i,j,k)*this%itpv_z( 0,i,j,k+1)*rhoWp) + this%implicit%opr(7,i,j,k)=this%implicit%opr(7,i,j,k)+0.5_WP*dt*(this%divv_z( 0,i,j,k)*this%itpv_z(-1,i,j,k )*rhoWm) + end do + end do + end do + do k=this%cfg%kmin_,this%cfg%kmax_ + do j=this%cfg%jmin_,this%cfg%jmax_ + do i=this%cfg%imin_,this%cfg%imax_ + this%implicit%opr(1,i,j,k)=this%implicit%opr(1,i,j,k)-0.5_WP*dt*(this%divv_x(+1,i,j,k)*sum(this%itp_xy(:,:,i+1,j,k)*this%visc(i:i+1,j-1:j,k))*this%grdv_x(-1,i+1,j,k)+& + & this%divv_x( 0,i,j,k)*sum(this%itp_xy(:,:,i ,j,k)*this%visc(i-1:i,j-1:j,k))*this%grdv_x( 0,i ,j,k)+& + & this%divv_y( 0,i,j,k)*4.0_WP/3.0_WP* this%visc(i,j ,k) *this%grdv_y( 0,i,j ,k)+& + & this%divv_y(-1,i,j,k)*4.0_WP/3.0_WP* this%visc(i,j-1,k) *this%grdv_y(+1,i,j-1,k)+& + & this%divv_z(+1,i,j,k)*sum(this%itp_yz(:,:,i,j,k+1)*this%visc(i,j-1:j,k:k+1))*this%grdv_z(-1,i,j,k+1)+& + & this%divv_z( 0,i,j,k)*sum(this%itp_yz(:,:,i,j,k )*this%visc(i,j-1:j,k-1:k))*this%grdv_z( 0,i,j,k )) + this%implicit%opr(2,i,j,k)=this%implicit%opr(2,i,j,k)-0.5_WP*dt*(this%divv_x(+1,i,j,k)*sum(this%itp_xy(:,:,i+1,j,k)*this%visc(i:i+1,j-1:j,k))*this%grdv_x( 0,i+1,j,k)) + this%implicit%opr(3,i,j,k)=this%implicit%opr(3,i,j,k)-0.5_WP*dt*(this%divv_x( 0,i,j,k)*sum(this%itp_xy(:,:,i ,j,k)*this%visc(i-1:i,j-1:j,k))*this%grdv_x(-1,i ,j,k)) + this%implicit%opr(4,i,j,k)=this%implicit%opr(4,i,j,k)-0.5_WP*dt*(this%divv_y( 0,i,j,k)*4.0_WP/3.0_WP* this%visc(i,j ,k) *this%grdv_y(+1,i,j ,k)) + this%implicit%opr(5,i,j,k)=this%implicit%opr(5,i,j,k)-0.5_WP*dt*(this%divv_y(-1,i,j,k)*4.0_WP/3.0_WP* this%visc(i,j-1,k) *this%grdv_y( 0,i,j-1,k)) + this%implicit%opr(6,i,j,k)=this%implicit%opr(6,i,j,k)-0.5_WP*dt*(this%divv_z(+1,i,j,k)*sum(this%itp_yz(:,:,i,j,k+1)*this%visc(i,j-1:j,k:k+1))*this%grdv_z( 0,i,j,k+1)) + this%implicit%opr(7,i,j,k)=this%implicit%opr(7,i,j,k)-0.5_WP*dt*(this%divv_z( 0,i,j,k)*sum(this%itp_yz(:,:,i,j,k )*this%visc(i,j-1:j,k-1:k))*this%grdv_z(-1,i,j,k )) + end do + end do + end do + call this%implicit%setup() + this%implicit%rhs=resV + this%implicit%sol=0.0_WP + call this%implicit%solve() + resV=this%implicit%sol + + ! Solve implicit W problem + this%implicit%opr(1,:,:,:)=this%rho; this%implicit%opr(2:,:,:,:)=0.0_WP + do k=this%cfg%kmin_,this%cfg%kmax_ + do j=this%cfg%jmin_,this%cfg%jmax_ + do i=this%cfg%imin_,this%cfg%imax_ + rhoUp=this%rho*sum(this%itpu_z(:,i+1,j,k)*this%U(i+1,j,k-1:k)) + rhoUm=this%rho*sum(this%itpu_z(:,i ,j,k)*this%U(i ,j,k-1:k)) + rhoVp=this%rho*sum(this%itpv_z(:,i,j+1,k)*this%V(i,j+1,k-1:k)) + rhoVm=this%rho*sum(this%itpv_z(:,i,j ,k)*this%V(i,j ,k-1:k)) + rhoWp=this%rho*sum(this%itpw_z(:,i,j,k )*this%W(i,j,k :k+1))*2.0_WP + rhoWm=this%rho*sum(this%itpw_z(:,i,j,k-1)*this%W(i,j,k-1:k ))*2.0_WP + this%implicit%opr(1,i,j,k)=this%implicit%opr(1,i,j,k)+0.5_WP*dt*(this%divw_x(+1,i,j,k)*this%itpw_x(-1,i+1,j,k)*rhoUp+& + & this%divw_x( 0,i,j,k)*this%itpw_x( 0,i ,j,k)*rhoUm+& + & this%divw_y(+1,i,j,k)*this%itpw_y(-1,i,j+1,k)*rhoVp+& + & this%divw_y( 0,i,j,k)*this%itpw_y( 0,i,j ,k)*rhoVm+& + & this%divw_z( 0,i,j,k)*this%itpw_z( 0,i,j,k )*rhoWp+& + & this%divw_z(-1,i,j,k)*this%itpw_z(+1,i,j,k-1)*rhoWm) + this%implicit%opr(2,i,j,k)=this%implicit%opr(2,i,j,k)+0.5_WP*dt*(this%divw_x(+1,i,j,k)*this%itpw_x( 0,i+1,j,k)*rhoUp) + this%implicit%opr(3,i,j,k)=this%implicit%opr(3,i,j,k)+0.5_WP*dt*(this%divw_x( 0,i,j,k)*this%itpw_x(-1,i ,j,k)*rhoUm) + this%implicit%opr(4,i,j,k)=this%implicit%opr(4,i,j,k)+0.5_WP*dt*(this%divw_y(+1,i,j,k)*this%itpw_y( 0,i,j+1,k)*rhoVp) + this%implicit%opr(5,i,j,k)=this%implicit%opr(5,i,j,k)+0.5_WP*dt*(this%divw_y( 0,i,j,k)*this%itpw_y(-1,i,j ,k)*rhoVm) + this%implicit%opr(6,i,j,k)=this%implicit%opr(6,i,j,k)+0.5_WP*dt*(this%divw_z( 0,i,j,k)*this%itpw_z(+1,i,j,k )*rhoWp) + this%implicit%opr(7,i,j,k)=this%implicit%opr(7,i,j,k)+0.5_WP*dt*(this%divw_z(-1,i,j,k)*this%itpw_z( 0,i,j,k-1)*rhoWm) + end do + end do + end do + do k=this%cfg%kmin_,this%cfg%kmax_ + do j=this%cfg%jmin_,this%cfg%jmax_ + do i=this%cfg%imin_,this%cfg%imax_ + this%implicit%opr(1,i,j,k)=this%implicit%opr(1,i,j,k)-0.5_WP*dt*(this%divw_x(+1,i,j,k)*sum(this%itp_xz(:,:,i+1,j,k)*this%visc(i:i+1,j,k-1:k))*this%grdw_x(-1,i+1,j,k)+& + & this%divw_x( 0,i,j,k)*sum(this%itp_xz(:,:,i ,j,k)*this%visc(i-1:i,j,k-1:k))*this%grdw_x( 0,i ,j,k)+& + & this%divw_y(+1,i,j,k)*sum(this%itp_yz(:,:,i,j+1,k)*this%visc(i,j:j+1,k-1:k))*this%grdw_y(-1,i,j+1,k)+& + & this%divw_y( 0,i,j,k)*sum(this%itp_yz(:,:,i,j ,k)*this%visc(i,j-1:j,k-1:k))*this%grdw_y( 0,i,j ,k)+& + & this%divw_z( 0,i,j,k)*4.0_WP/3.0_WP* this%visc(i,j,k ) *this%grdw_z( 0,i,j,k )+& + & this%divw_z(-1,i,j,k)*4.0_WP/3.0_WP* this%visc(i,j,k-1) *this%grdw_z(+1,i,j,k-1)) + this%implicit%opr(2,i,j,k)=this%implicit%opr(2,i,j,k)-0.5_WP*dt*(this%divw_x(+1,i,j,k)*sum(this%itp_xz(:,:,i+1,j,k)*this%visc(i:i+1,j,k-1:k))*this%grdw_x( 0,i+1,j,k)) + this%implicit%opr(3,i,j,k)=this%implicit%opr(3,i,j,k)-0.5_WP*dt*(this%divw_x( 0,i,j,k)*sum(this%itp_xz(:,:,i ,j,k)*this%visc(i-1:i,j,k-1:k))*this%grdw_x(-1,i ,j,k)) + this%implicit%opr(4,i,j,k)=this%implicit%opr(4,i,j,k)-0.5_WP*dt*(this%divw_y(+1,i,j,k)*sum(this%itp_yz(:,:,i,j+1,k)*this%visc(i,j:j+1,k-1:k))*this%grdw_y( 0,i,j+1,k)) + this%implicit%opr(5,i,j,k)=this%implicit%opr(5,i,j,k)-0.5_WP*dt*(this%divw_y( 0,i,j,k)*sum(this%itp_yz(:,:,i,j ,k)*this%visc(i,j-1:j,k-1:k))*this%grdw_y(-1,i,j ,k)) + this%implicit%opr(6,i,j,k)=this%implicit%opr(6,i,j,k)-0.5_WP*dt*(this%divw_z( 0,i,j,k)*4.0_WP/3.0_WP* this%visc(i,j,k ) *this%grdw_z(+1,i,j,k )) + this%implicit%opr(7,i,j,k)=this%implicit%opr(7,i,j,k)-0.5_WP*dt*(this%divw_z(-1,i,j,k)*4.0_WP/3.0_WP* this%visc(i,j,k-1) *this%grdw_z( 0,i,j,k-1)) + end do + end do + end do + call this%implicit%setup() + this%implicit%rhs=resW + this%implicit%sol=0.0_WP + call this%implicit%solve() + resW=this%implicit%sol + + end subroutine solve_implicit + + + !> Add gravity source term + subroutine addsrc_gravity(this,resU,resV,resW) + implicit none + class(incomp), intent(inout) :: this + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(inout) :: resU !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(inout) :: resV !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(inout) :: resW !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + integer :: i,j,k + do k=this%cfg%kmin_,this%cfg%kmax_ + do j=this%cfg%jmin_,this%cfg%jmax_ + do i=this%cfg%imin_,this%cfg%imax_ + if (this%umask(i,j,k).eq.0) resU(i,j,k)=resU(i,j,k)+this%rho*this%gravity(1) + if (this%vmask(i,j,k).eq.0) resV(i,j,k)=resV(i,j,k)+this%rho*this%gravity(2) + if (this%wmask(i,j,k).eq.0) resW(i,j,k)=resW(i,j,k)+this%rho*this%gravity(3) + end do + end do + end do + end subroutine addsrc_gravity + + + !> Print out info for incompressible flow solver + subroutine incomp_print(this) + use, intrinsic :: iso_fortran_env, only: output_unit + implicit none + class(incomp), intent(in) :: this + + ! Output + if (this%cfg%amRoot) then + write(output_unit,'("Incompressible solver [",a,"] for config [",a,"]")') trim(this%name),trim(this%cfg%name) + write(output_unit,'(" > density = ",es12.5)') this%rho + end if + + end subroutine incomp_print + + +end module incomp_class diff --git a/examples/cylinder_NOSB/src/lss_class.f90 b/examples/cylinder_NOSB/src/lss_class.f90 new file mode 100644 index 000000000..713295887 --- /dev/null +++ b/examples/cylinder_NOSB/src/lss_class.f90 @@ -0,0 +1,1511 @@ +!> Lagrangian solid solver object +!> Implements peridynamics equations +module lss_class + use precision, only: WP + use string, only: str_medium + use config_class, only: config + use mpi_f08, only: MPI_Datatype,MPI_INTEGER8,MPI_INTEGER,MPI_DOUBLE_PRECISION + implicit none + private + + + ! Expose type/constructor/methods + public :: lss + + + !> Memory adaptation parameter + real(WP), parameter :: coeff_up=1.3_WP !< Particle array size increase factor + real(WP), parameter :: coeff_dn=0.7_WP !< Particle array size decrease factor + + + !> I/O chunk size to read at a time + integer, parameter :: part_chunk_size=1000 !< Read 1000 particles at a time before redistributing + + + !> Maximum number of bonds per particle + integer, parameter, public :: max_bond=130 !< Assumes something like a 7x7x7 stencil in 3D + + + !> Bonded solid particle definition + type :: part + !> MPI_DOUBLE_PRECISION data + real(WP) :: vonMises !< Element dilatation + real(WP) :: vol !< Particle volume + real(WP) :: correcMag + real(WP), dimension(max_bond) :: dbond !< Length of initial bonds + real(WP), dimension(3) :: pos !< Particle center coordinates + real(WP), dimension(3) :: vel !< Velocity of particle + real(WP), dimension(3) :: Abond !< Bond acceleration for particle + real(WP), dimension(3) :: Afluid !< Fluid acceleration for particle + real(WP), dimension(3) :: t1 !< Fluid acceleration for particle + real(WP), dimension(3) :: t2 !< Fluid acceleration for particle + real(WP), dimension(3) :: tc !< Fluid acceleration for particle + real(WP), dimension(3) :: ipos !< Initial position + real(WP), dimension(3) :: displacement !< Displacement + real(WP), dimension(3,3) :: F !< Deformation gradient tensor + real(WP), dimension(3,3) :: PK_inv !< First Piola-Kirchoff tensor times shape tensor inverse + !> MPI_INTEGER data + integer :: id !< ID the object is associated with + integer :: i !< Unique index of particle (assumed >0) + integer :: nbond !< Number of initial bonds + integer, dimension(max_bond) :: ibond !< Indices of initially bonded particles (0 values ignored) + integer , dimension(3) :: ind !< Index of cell containing particle center + integer :: flag !< Control parameter (0=normal, 1=done->will be removed) + end type part + !> Number of blocks, block length, and block types in a particle + integer, parameter :: part_nblock=2 + integer , dimension(part_nblock) :: part_lblock=[48+max_bond,7+max_bond] + type(MPI_Datatype), dimension(part_nblock) :: part_tblock=[MPI_DOUBLE_PRECISION,MPI_INTEGER] + !> MPI_PART derived datatype and size + type(MPI_Datatype) :: MPI_PART + integer :: MPI_PART_SIZE + + + !> Lagrangian solid solver object definition + type :: lss + + ! This config is used for parallelization and for calculating bond/collision forces + class(config), pointer :: cfg + + ! This is the name of the solver + character(len=str_medium) :: name='UNNAMED_LSS' + + ! Solid material properties + real(WP) :: elastic_modulus !< Elastic modulus of the material + real(WP) :: poisson_ratio !< Poisson's ratio of the material + real(WP) :: rho !< Density of the material + real(WP) :: crit_energy !< Critical energy release + real(WP) :: beta !< Damping constant + real(WP) :: cool_down_time + logical :: continuous_damping !< True if you want damping on the whole time + + ! Bonding parameters + real(WP) :: delta !< Bonding horizon (distance) + real(WP) :: min_dist !< Minimum bonding distance + integer :: nb !< Cell-based horizon + + ! Global and local particle data + integer :: np !< Global number of particles + integer :: np_ !< Local number of particles + integer, dimension(:), allocatable :: np_proc !< Number of particles on each processor + type(part), dimension(:), allocatable :: p !< Array of particles of type part + + ! Overlap particle (i.e., ghost) data + integer :: ng_ !< Local number of ghosts + type(part), dimension(:), allocatable :: g !< Array of ghosts of type part + + ! Gravitational acceleration + real(WP), dimension(3) :: gravity=[0.0_WP,0.0_WP,0.0_WP] + + ! Solid volume fraction and momentum + real(WP), dimension(:,:,:), allocatable :: VF !< Volume fraction, cell-centered + real(WP), dimension(:,:,:), allocatable :: VFU !< Solid velocity, U-face + real(WP), dimension(:,:,:), allocatable :: VFV !< Solid velocity, V-face + real(WP), dimension(:,:,:), allocatable :: VFW !< Solid velocity, W-face + + ! CFL numbers + real(WP) :: CFLp_x,CFLp_y,CFLp_z,CFLp_a + + ! Number of substeps for time integrator + real(WP) :: nstep=1 + + ! Monitoring info + real(WP) :: Umin,Umax,Umean !< U velocity info + real(WP) :: Vmin,Vmax,Vmean !< V velocity info + real(WP) :: Wmin,Wmax,Wmean !< W velocity info + real(WP) :: VFmax !< Volume fraction info + real(WP), dimension(3) :: ibmForce !< Total force due to IBM + integer :: np_out !< Number of particles leaving the domain + + contains + procedure :: bond_init !< Setup initial interparticle bonds + procedure :: get_bond_force !< Compute interparticle bond force + procedure :: advance !< Step forward the particle ODEs + procedure :: get_cfl !< Calculate maximum CFL + procedure :: get_max !< Extract various monitoring data + procedure :: update_partmesh !< Update a partmesh object using current particles + procedure :: share !< Share particles across interprocessor boundaries + procedure :: sync !< Synchronize particles across interprocessor boundaries + procedure :: resize !< Resize particle array to given size + procedure :: resize_ghost !< Resize ghost array to given size + procedure :: recycle !< Recycle particle array by removing flagged particles + procedure :: write !< Parallel write particles to file + procedure :: read !< Parallel read particles from file + procedure :: update_VF !< Compute volume fraction + procedure :: get_delta !< Compute regularized delta function + procedure :: interpolate !< Interpolation routine from mesh=>marker + procedure :: extrapolate !< Extrapolation routine from marker=>mesh + end type lss + + + !> Declare lss constructor + interface lss + procedure constructor + end interface lss + +contains + + + ! Quasi-Gaussian weighting function - h is the cut-off + real(WP) function wgauss(d,h) + implicit none + real(WP), intent(in) :: d,h + real(WP), parameter :: coeff=2.6_WP + real(WP) :: hh + ! hh=coeff*h + hh=h + if (d.ge.hh) then + wgauss=0.0_WP + else + ! wgauss=(1.0_WP+4.0_WP*d/hh)*(1.0_WP-d/hh)**4 + wgauss=(1.0_WP-d/h)**3 + end if + end function wgauss + + + !> Default constructor for Lagrangian solid solver + function constructor(cfg,name) result(self) + implicit none + type(lss) :: self + class(config), target, intent(in) :: cfg + character(len=*), optional :: name + integer :: i,j,k + + ! Set the name for the solver + if (present(name)) self%name=trim(adjustl(name)) + + ! Point to pgrid object + self%cfg=>cfg + + ! Set default bonding horizon based on underlying mesh + self%delta=self%cfg%min_meshsize + self%nb=1 + self%min_dist=huge(1.0_WP) + + ! Allocate variables + allocate(self%np_proc(1:self%cfg%nproc)); self%np_proc=0 + self%np_=0; self%np=0 + call self%resize(0) + + ! Initialize MPI derived datatype for a particle + call prepare_mpi_part() + + ! Allocate VF array on cfg mesh + allocate(self%VF(self%cfg%imino_:self%cfg%imaxo_,self%cfg%jmino_:self%cfg%jmaxo_,self%cfg%kmino_:self%cfg%kmaxo_)); self%VF=0.0_WP + allocate(self%VFU(self%cfg%imino_:self%cfg%imaxo_,self%cfg%jmino_:self%cfg%jmaxo_,self%cfg%kmino_:self%cfg%kmaxo_)); self%VFU=0.0_WP + allocate(self%VFV(self%cfg%imino_:self%cfg%imaxo_,self%cfg%jmino_:self%cfg%jmaxo_,self%cfg%kmino_:self%cfg%kmaxo_)); self%VFV=0.0_WP + allocate(self%VFW(self%cfg%imino_:self%cfg%imaxo_,self%cfg%jmino_:self%cfg%jmaxo_,self%cfg%kmino_:self%cfg%kmaxo_)); self%VFW=0.0_WP + + ! Log/screen output + logging: block + use, intrinsic :: iso_fortran_env, only: output_unit + use param, only: verbose + use messager, only: log + use string, only: str_long + character(len=str_long) :: message + if (self%cfg%amRoot) then + write(message,'("LSS object [",a,"] on partitioned grid [",a,"]")') trim(self%name),trim(self%cfg%name) + if (verbose.gt.1) write(output_unit,'(a)') trim(message) + if (verbose.gt.0) call log(message) + end if + end block logging + + end function constructor + + + !> Initialize bond force between particles + subroutine bond_init(this) + use messager, only: die + implicit none + class(lss), intent(inout) :: this + integer, dimension(:,:,:), allocatable :: npic !< Number of particle in cell + integer, dimension(:,:,:,:), allocatable :: ipic !< Index of particle in cell + + ! Communicate particles in ghost cells + call this%share() + + ! We can now assemble particle-in-cell information + pic_prep: block + use mpi_f08 + integer :: i,ip,jp,kp,ierr + integer :: mymax_npic,max_npic + + ! Allocate number of particle in cell + allocate(npic(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)); npic=0 + + ! Count particles and ghosts per cell + do i=1,this%np_ + ip=this%p(i)%ind(1); jp=this%p(i)%ind(2); kp=this%p(i)%ind(3) + npic(ip,jp,kp)=npic(ip,jp,kp)+1 + end do + do i=1,this%ng_ + ip=this%g(i)%ind(1); jp=this%g(i)%ind(2); kp=this%g(i)%ind(3) + npic(ip,jp,kp)=npic(ip,jp,kp)+1 + end do + + ! Get maximum number of particle in cell + mymax_npic=maxval(npic); call MPI_ALLREDUCE(mymax_npic,max_npic,1,MPI_INTEGER,MPI_MAX,this%cfg%comm,ierr) + + ! Allocate pic map + allocate(ipic(1:max_npic,this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)); ipic=0 + + ! Assemble pic map + npic=0 + do i=1,this%np_ + ip=this%p(i)%ind(1); jp=this%p(i)%ind(2); kp=this%p(i)%ind(3) + npic(ip,jp,kp)=npic(ip,jp,kp)+1 + ipic(npic(ip,jp,kp),ip,jp,kp)=+i + end do + do i=1,this%ng_ + ip=this%g(i)%ind(1); jp=this%g(i)%ind(2); kp=this%g(i)%ind(3) + npic(ip,jp,kp)=npic(ip,jp,kp)+1 + ipic(npic(ip,jp,kp),ip,jp,kp)=-i + end do + + end block pic_prep + + ! Establish initial bonds + create_bonds: block + use mpi_f08, only: MPI_ALLREDUCE,MPI_MIN,MPI_IN_PLACE + use parallel, only: MPI_REAL_WP + use mathtools, only: Pi + integer :: i,j,k,n1,nn,n2,ierr + type(part) :: p1,p2 + real(WP), dimension(3) :: rpos + real(WP) :: dist + ! Reset minimum bond distance + this%min_dist=huge(1.0_WP) + ! Loop over particles + do n1=1,this%np_ + ! Create copy of our particle + p1=this%p(n1) + ! Zero out bonds + p1%ibond=0 + p1%nbond=0 + ! Loop over neighbor cells + do k=p1%ind(3)-this%nb,p1%ind(3)+this%nb + do j=p1%ind(2)-this%nb,p1%ind(2)+this%nb + do i=p1%ind(1)-this%nb,p1%ind(1)+this%nb + ! Loop over particles in that cell + do nn=1,npic(i,j,k) + ! Create copy of our neighbor + n2=ipic(nn,i,j,k) + if (n2.gt.0) then + p2=this%p(+n2) + else if (n2.lt.0) then + p2=this%g(-n2) + end if + ! Cannot self-bond + if (p1%i.eq.p2%i) cycle + ! Cannot bond with different id except <=0 (<=0 bonds with everyone) + if (p1%id.ne.p2%id.and.p1%id.ge.0.and.p2%id.ge.0) cycle + ! Check interparticle distance + rpos=p2%pos-p1%pos + dist=sqrt(dot_product(rpos,rpos)) + if (dist.lt.this%delta) then + ! This particle is in horizon, create a bond + p1%nbond=p1%nbond+1 + if (p1%nbond.gt.max_bond) call die('[lss_class bond_init] Number of detected bonds is larger than max allowed') + p1%ibond(p1%nbond)=p2%i + p1%dbond(p1%nbond)=dist + ! Determine minimum bond distance + this%min_dist=min(this%min_dist,dist) + end if + end do + end do + end do + end do + ! Copy back the particle + this%p(n1)=p1 + end do + ! Get global minimum + call MPI_ALLREDUCE(MPI_IN_PLACE,this%min_dist,1,MPI_REAL_WP,MPI_MIN,this%cfg%comm,ierr) + end block create_bonds + + ! Clean up + if (allocated(npic)) deallocate(npic) + if (allocated(ipic)) deallocate(ipic) + + + end subroutine bond_init + + + !> Calculate bond force between particles + subroutine get_bond_force(this) + implicit none + class(lss), intent(inout) :: this + integer, dimension(:,:,:), allocatable :: npic !< Number of particle in cell + integer, dimension(:,:,:,:), allocatable :: ipic !< Index of particle in cell + + ! Communicate particles in ghost cells + call this%share() + + ! We can now assemble particle-in-cell information + pic_prep: block + use mpi_f08 + integer :: i,ip,jp,kp,ierr + integer :: mymax_npic,max_npic + + ! Allocate number of particle in cell + allocate(npic(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)); npic=0 + + ! Count particles and ghosts per cell + do i=1,this%np_ + ip=this%p(i)%ind(1); jp=this%p(i)%ind(2); kp=this%p(i)%ind(3) + npic(ip,jp,kp)=npic(ip,jp,kp)+1 + end do + do i=1,this%ng_ + ip=this%g(i)%ind(1); jp=this%g(i)%ind(2); kp=this%g(i)%ind(3) + npic(ip,jp,kp)=npic(ip,jp,kp)+1 + end do + + ! Get maximum number of particle in cell + mymax_npic=maxval(npic); call MPI_ALLREDUCE(mymax_npic,max_npic,1,MPI_INTEGER,MPI_MAX,this%cfg%comm,ierr) + + ! Allocate pic map + allocate(ipic(1:max_npic,this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)); ipic=0 + + ! Assemble pic map + npic=0 + do i=1,this%np_ + ip=this%p(i)%ind(1); jp=this%p(i)%ind(2); kp=this%p(i)%ind(3) + npic(ip,jp,kp)=npic(ip,jp,kp)+1 + ipic(npic(ip,jp,kp),ip,jp,kp)=+i + end do + do i=1,this%ng_ + ip=this%g(i)%ind(1); jp=this%g(i)%ind(2); kp=this%g(i)%ind(3) + npic(ip,jp,kp)=npic(ip,jp,kp)+1 + ipic(npic(ip,jp,kp),ip,jp,kp)=-i + end do + + end block pic_prep + + ! Update shape and deformation gradient tensor + update_tensors: block + use mathtools + integer :: i,j,k,n1,nn,n2 + type(part) :: p1,p2 + integer :: nb,nbond + real(WP), dimension(3) :: rpos, xi + real(WP) :: dist,w,mu,kk,detK,traceE,J_F,sigma_vm, traceS + real(WP), dimension(3,3) :: K_mat,E_mat,I_mat,S_mat,K_inv,sigma, s_dev + + mu=this%elastic_modulus/(2.0_WP+2.0_WP*this%poisson_ratio) ! shear modulus + kk=this%elastic_modulus/(3.0_WP-6.0_WP*this%poisson_ratio) ! bulk moduls + I_mat = 0.0_WP + S_mat = 0.0_WP + traceE = 0.0_WP + E_mat = 0.0_WP + K_inv = 0.0_WP + I_mat(1,1) = 1.0_WP + I_mat(2,2) = 1.0_WP + I_mat(3,3) = 1.0_WP + + ! Loop over particles + do n1=1,this%np_ + ! Create copy of our particle + p1=this%p(n1) + ! Zero out weighted volume and dilatation + K_mat=0.0_WP + K_inv = 0.0_WP + p1%F=0.0_WP + ! Loop over neighbor cells + do k=p1%ind(3)-this%nb,p1%ind(3)+this%nb + do j=p1%ind(2)-this%nb,p1%ind(2)+this%nb + do i=p1%ind(1)-this%nb,p1%ind(1)+this%nb + ! Loop over particles in that cell + do nn=1,npic(i,j,k) + ! Create copy of our neighbor + n2=ipic(nn,i,j,k) + if (n2.gt.0) then + p2=this%p(+n2) + else if (n2.lt.0) then + p2=this%g(-n2) + end if + ! Check if a bond exists + do nb=1,max_bond + if (p1%ibond(nb).eq.p2%i) then + ! Get current distance + rpos=p2%pos-p1%pos + !print *, rpos + ! Compute summation of K + xi = p2%ipos-p1%ipos + w = wgauss(p1%dbond(nb),this%delta) + K_mat(1,1)=K_mat(1,1)+xi(1)*xi(1)*w*p2%vol; K_mat(1,2)=K_mat(1,2)+xi(1)*xi(2)*w*p2%vol; K_mat(1,3)=K_mat(1,3)+xi(1)*xi(3)*w*p2%vol; + K_mat(2,1)=K_mat(2,1)+xi(2)*xi(1)*w*p2%vol; K_mat(2,2)=K_mat(2,2)+xi(2)*xi(2)*w*p2%vol; K_mat(2,3)=K_mat(2,3)+xi(2)*xi(3)*w*p2%vol; + K_mat(3,1)=K_mat(3,1)+xi(3)*xi(1)*w*p2%vol; K_mat(3,2)=K_mat(3,2)+xi(3)*xi(2)*w*p2%vol; K_mat(3,3)=K_mat(3,3)+xi(3)*xi(3)*w*p2%vol; + + ! Compute interior summation of F + p1%F(1,1)=p1%F(1,1)+rpos(1)*xi(1)*w*p2%vol; p1%F(1,2)=p1%F(1,2)+rpos(1)*xi(2)*w*p2%vol; p1%F(1,3)=p1%F(1,3)+rpos(1)*xi(3)*w*p2%vol; + p1%F(2,1)=p1%F(2,1)+rpos(2)*xi(1)*w*p2%vol; p1%F(2,2)=p1%F(2,2)+rpos(2)*xi(2)*w*p2%vol; p1%F(2,3)=p1%F(2,3)+rpos(2)*xi(3)*w*p2%vol; + p1%F(3,1)=p1%F(3,1)+rpos(3)*xi(1)*w*p2%vol; p1%F(3,2)=p1%F(3,2)+rpos(3)*xi(2)*w*p2%vol; p1%F(3,3)=p1%F(3,3)+rpos(3)*xi(3)*w*p2%vol; + end if + end do + end do + end do + end do + end do + ! Apply inverse of K to get F = F*K^-1 + detK = K_mat(1,1)*(K_mat(2,2)*K_mat(3,3)-K_mat(2,3)*K_mat(3,2)) & + -K_mat(1,2)*(K_mat(2,1)*K_mat(3,3)-K_mat(2,3)*K_mat(3,1)) & + +K_mat(1,3)*(K_mat(2,1)*K_mat(3,2)-K_mat(2,2)*K_mat(3,1)) + K_inv(1,1) = (K_mat(2,2)*K_mat(3,3) - K_mat(2,3)*K_mat(3,2))/detK + K_inv(2,1) = -(K_mat(2,1)*K_mat(3,3) - K_mat(2,3)*K_mat(3,1))/detK + K_inv(3,1) = (K_mat(2,1)*K_mat(3,2) - K_mat(2,2)*K_mat(3,1))/detK + K_inv(1,2) = -(K_mat(1,2)*K_mat(3,3) - K_mat(1,3)*K_mat(3,2))/detK + K_inv(2,2) = (K_mat(1,1)*K_mat(3,3) - K_mat(1,3)*K_mat(3,1))/detK + K_inv(3,2) = -(K_mat(1,1)*K_mat(3,2) - K_mat(1,2)*K_mat(3,1))/detK + K_inv(1,3) = (K_mat(1,2)*K_mat(2,3) - K_mat(1,3)*K_mat(2,2))/detK + K_inv(2,3) = -(K_mat(1,1)*K_mat(2,3) - K_mat(1,3)*K_mat(2,1))/detK + K_inv(3,3) = (K_mat(1,1)*K_mat(2,2) - K_mat(1,2)*K_mat(2,1))/detK + + + p1%F = MATMUL(p1%F,K_inv) + + ! Compute first Piola-Kirchoff stress tensor - constitutive model dependent + E_mat = 0.5_WP * (MATMUL(TRANSPOSE(p1%F),p1%F)-I_mat) + traceE = E_mat(1,1) + E_mat(2,2) + E_mat(3,3) + S_mat = (kk-2.0_WP/3.0_WP*mu)*traceE*I_mat + 2.0_WP*mu*E_mat + p1%PK_inv = MATMUL(MATMUL(p1%F,S_mat),K_inv) + + J_F = p1%F(1,1)*(p1%F(2,2)*p1%F(3,3)-p1%F(2,3)*p1%F(3,2)) & + -p1%F(1,2)*(p1%F(2,1)*p1%F(3,3)-p1%F(2,3)*p1%F(3,1)) & + +p1%F(1,3)*(p1%F(2,1)*p1%F(3,2)-p1%F(2,2)*p1%F(3,1)) + + sigma = MATMUL(MATMUL(p1%F, S_mat), TRANSPOSE(p1%F)) / J_F + + ! Deviatoric part + traceS = sigma(1,1) + sigma(2,2) + sigma(3,3) + s_dev = sigma - (traceS/3.0_WP)*I_mat + + ! Von Mises + p1%vonMises = sqrt(1.5_WP * (s_dev(1,1)**2 + s_dev(2,2)**2 + s_dev(3,3)**2 & + + 2.0_WP*s_dev(1,2)**2 + 2.0_WP*s_dev(1,3)**2 & + + 2.0_WP*s_dev(2,3)**2)) + + ! Copy back the particle + this%p(n1)=p1 + end do + end block update_tensors + + ! Re-communicate particles in ghost cells to update dil and mw + call this%share() + + ! Update bond force, including collision force + update_bond_force: block + use mpi_f08, only: MPI_ALLREDUCE,MPI_MIN,MPI_IN_PLACE + use parallel, only: MPI_REAL_WP + use mathtools, only: Pi + integer :: i,j,k,n1,nn,n2,ierr + type(part) :: p1,p2 + real(WP), dimension(3) :: rpos,t1,t2,tc,xi,z + real(WP), dimension(3,3) :: PK_inv + real(WP) :: dist,t,w + real(WP) :: stretch,max_stretch,mu,kk, correcMagNum, correcMagDenom + real(WP) :: nc,rc,kc + integer :: nb,nbond + logical :: found_bond + ! Recompute a few physical parameters + mu=this%elastic_modulus/(2.0_WP+2.0_WP*this%poisson_ratio) + kk=this%elastic_modulus/(3.0_WP-6.0_WP*this%poisson_ratio) + max_stretch=sqrt(this%crit_energy/((3.0_WP*mu+(kk-5.0_WP*mu/3.0_WP)*0.75_WP**4)*this%delta)) + kc=15.0_WP*12.0_WP*this%elastic_modulus/(Pi*this%delta**4) + + nc=1.0_WP + this%min_dist=huge(1.0_WP) + ! Loop over particles + do n1=1,this%np_ + ! Particles marked 0 do not update their forces + if (this%p(n1)%id.eq.0) cycle + ! Create copy of our particle + p1=this%p(n1) + ! Zero out bond force + p1%Abond=0.0_WP + ! Zero out PK_inv + PK_inv=0.0_WP + ! Zero out correcmag num and denom + correcMagNum = 0.0_WP + correcMagDenom = 0.0_WP + ! Loop over neighbor cells + do k=p1%ind(3)-this%nb,p1%ind(3)+this%nb + do j=p1%ind(2)-this%nb,p1%ind(2)+this%nb + do i=p1%ind(1)-this%nb,p1%ind(1)+this%nb + ! Loop over particles in that cell + do nn=1,npic(i,j,k) + ! Create copy of our neighbor + n2=ipic(nn,i,j,k) + if (n2.gt.0) then + p2=this%p(+n2) + else if (n2.lt.0) then + p2=this%g(-n2) + end if + ! Current distance + rpos=p2%pos-p1%pos + dist=sqrt(dot_product(rpos,rpos)) + ! Check if a bond exists + found_bond=.false. + do nb=1,max_bond + if (p1%ibond(nb).eq.p2%i) then + ! Check for breakage first + stretch=(dist-p1%dbond(nb))/p1%dbond(nb) + if (stretch.gt.max_stretch) then + ! Remove the bond and flag as surface particle + p1%ibond(nb)=0 + p1%dbond(nb)=0.0_WP + cycle + end if + w = wgauss(p1%dbond(nb),this%delta) + xi = p2%ipos-p1%ipos + ! Force density 1->2 + t1 = w*MATMUL(p1%PK_inv,xi) + ! Force density 2->1 + t2 = w*MATMUL(p2%PK_inv,xi) + ! Force correction term + z = rpos-MATMUL(p1%F,xi) + tc = w*(9.0_WP*kk/(Pi * this%delta**4))*(dot_product(xi,z)/(sqrt(dot_product(xi,xi)))**3)*xi + ! Compute bond acceleration + p1%t1 = t1 + p1%t2 = t2 + p1%tc = tc + p1%Abond=p1%Abond+(t1+t2+tc)*p2%vol/this%rho + correcMagNum = correcMagNum + sqrt(sum(tc**2)) + correcMagDenom = correcMagDenom + max((sqrt(sum(t1**2)) + sqrt(sum(t2**2)) + sqrt(sum(tc**2))),epsilon(1.0_WP)) + ! If still here, we have an active bond + found_bond=.true. + ! Determine minimum bond distance + this%min_dist=min(this%min_dist,dist) + cycle + end if + end do + ! Add collision force now + ! if (is2D) then + ! rc=p1%vol**(1.0_WP/2.0_WP) + ! else + ! rc=p1%vol**(1.0_WP/3.0_WP) + ! end if + ! if (.not.found_bond.and.p1%i.ne.p2%i.and.dist.lt.rc) then + ! p1%Abond=p1%Abond-max(kc*((rc/dist)**nc-1.0_WP),0.0_WP)*(rpos/dist)*p1%vol/this%rho + ! p1%flag = -2 + ! end if + end do + end do + end do + end do + ! Sum up contribution + p1%correcMag = correcMagNum/correcMagDenom + ! Deal with dimensionality + if (this%cfg%nx.eq.1) p1%Abond(1)=0.0_WP + if (this%cfg%ny.eq.1) p1%Abond(2)=0.0_WP + if (this%cfg%nz.eq.1) p1%Abond(3)=0.0_WP + ! Copy back the particle + this%p(n1)=p1 + end do + ! Get global minimum + call MPI_ALLREDUCE(MPI_IN_PLACE,this%min_dist,1,MPI_REAL_WP,MPI_MIN,this%cfg%comm,ierr) + end block update_bond_force + + ! Clean up + if (allocated(npic)) deallocate(npic) + if (allocated(ipic)) deallocate(ipic) + + end subroutine get_bond_force + + + !> Advance the particle equations by a specified time step dt + !> p%id=-2 => do not solve for position nor velocity + !> p%id=-1 => do not solve for velocity + !> p%id= 0 => do not update force + + subroutine advance(this,dt,stress_x,stress_y,stress_z) + use mpi_f08, only : MPI_SUM,MPI_INTEGER,MPI_IN_PLACE + use mathtools, only: Pi + implicit none + class(lss), intent(inout) :: this + real(WP), intent(inout) :: dt !< Timestep size over which to advance + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(inout) :: stress_x !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(inout) :: stress_y !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(inout) :: stress_z !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + integer :: n,ierr + real(WP), dimension(3) :: stress + + ! Zero out number of particles removed + this%np_out=0 + ! Advance velocity based on old force and position based on mid-velocity + ! print*, beta + do n=1,this%np_ + ! Advance with Verlet scheme + if (this%p(n)%id.gt.-1) this%p(n)%vel=this%p(n)%vel+0.5_WP*dt*(this%gravity+this%p(n)%Abond+this%p(n)%Afluid) + if (this%p(n)%id.gt.-2) this%p(n)%pos=this%p(n)%pos+dt*this%p(n)%vel + + this%p(n)%displacement=this%p(n)%pos-this%p(n)%ipos + ! Relocalize + this%p(n)%ind=this%cfg%get_ijk_global(this%p(n)%pos,this%p(n)%ind) + ! Correct the position to take into account periodicity + if (this%cfg%xper) this%p(n)%pos(1)=this%cfg%x(this%cfg%imin)+modulo(this%p(n)%pos(1)-this%cfg%x(this%cfg%imin),this%cfg%xL) + if (this%cfg%yper) this%p(n)%pos(2)=this%cfg%y(this%cfg%jmin)+modulo(this%p(n)%pos(2)-this%cfg%y(this%cfg%jmin),this%cfg%yL) + if (this%cfg%zper) this%p(n)%pos(3)=this%cfg%z(this%cfg%kmin)+modulo(this%p(n)%pos(3)-this%cfg%z(this%cfg%kmin),this%cfg%zL) + ! Handle particles that have left the domain + if (this%p(n)%pos(1).lt.this%cfg%x(this%cfg%imin).or.this%p(n)%pos(1).gt.this%cfg%x(this%cfg%imax+1)) this%p(n)%flag=1 + if (this%p(n)%pos(2).lt.this%cfg%y(this%cfg%jmin).or.this%p(n)%pos(2).gt.this%cfg%y(this%cfg%jmax+1)) this%p(n)%flag=1 + if (this%p(n)%pos(3).lt.this%cfg%z(this%cfg%kmin).or.this%p(n)%pos(3).gt.this%cfg%z(this%cfg%kmax+1)) this%p(n)%flag=1 + ! Relocalize the particle + this%p(n)%ind=this%cfg%get_ijk_global(this%p(n)%pos,this%p(n)%ind) + ! Count number of particles removed + if (this%p(n)%flag.eq.1) this%np_out=this%np_out+1 + end do + + ! Communicate particles + call this%sync() + + ! Sum up particles removed + call MPI_ALLREDUCE(this%np_out,n,1,MPI_INTEGER,MPI_SUM,this%cfg%comm,ierr); this%np_out=n + + ! Calculate bond force + call this%get_bond_force() + + ! Advance velocity only based on new force + do n=1,this%np_ + ! Advance with Verlet scheme + if (this%p(n)%id.le.-1) cycle + stress=this%cfg%get_velocity(pos=this%p(n)%pos,i0=this%p(n)%ind(1),j0=this%p(n)%ind(2),k0=this%p(n)%ind(3),U=stress_x,V=stress_y,W=stress_z) + + this%p(n)%Afluid=stress/this%rho + this%p(n)%correcMag = sqrt(dot_product(this%p(n)%Afluid,this%p(n)%Afluid)) + ! A Fluid is zero in the init, but is non-zero for pulling elements if specified + this%p(n)%vel=this%p(n)%vel+0.5_WP*dt*(this%gravity+this%p(n)%Abond+this%p(n)%Afluid) + end do + + ! Recompute volume fraction + call this%update_VF() + + ! Log/screen output + logging: block + use, intrinsic :: iso_fortran_env, only: output_unit + use param, only: verbose + use messager, only: log + use string, only: str_long + character(len=str_long) :: message + if (this%cfg%amRoot) then + write(message,'("Particle solver [",a,"] on partitioned grid [",a,"]: ",i0," particles were advanced")') trim(this%name),trim(this%cfg%name),this%np + if (verbose.gt.1) write(output_unit,'(a)') trim(message) + if (verbose.gt.0) call log(message) + end if + end block logging + + end subroutine advance + + + !> Update particle volume fraction using our current particles + subroutine update_VF(this) + implicit none + class(lss), intent(inout) :: this + integer :: i + ! Reset volume fraction and momentum + this%VF=0.0_WP; this%VFU=0.0_WP; this%VFV=0.0_WP; this%VFW=0.0_WP + ! Transfer particle volume + do i=1,this%np_ + ! Skip inactive particle + if (this%p(i)%flag.eq.1) cycle + ! Transfer volume to mesh + call this%extrapolate(Ap=this%p(i)%vol,xp=this%p(i)%pos(1),yp=this%p(i)%pos(2),zp=this%p(i)%pos(3),ip=this%p(i)%ind(1),jp=this%p(i)%ind(2),kp=this%p(i)%ind(3),A=this%VF,dir='SC') + call this%extrapolate(Ap=this%p(i)%vol*this%p(i)%vel(1),xp=this%p(i)%pos(1),yp=this%p(i)%pos(2),zp=this%p(i)%pos(3),ip=this%p(i)%ind(1),jp=this%p(i)%ind(2),kp=this%p(i)%ind(3),A=this%VFU,dir='U') + call this%extrapolate(Ap=this%p(i)%vol*this%p(i)%vel(2),xp=this%p(i)%pos(1),yp=this%p(i)%pos(2),zp=this%p(i)%pos(3),ip=this%p(i)%ind(1),jp=this%p(i)%ind(2),kp=this%p(i)%ind(3),A=this%VFV,dir='V') + call this%extrapolate(Ap=this%p(i)%vol*this%p(i)%vel(3),xp=this%p(i)%pos(1),yp=this%p(i)%pos(2),zp=this%p(i)%pos(3),ip=this%p(i)%ind(1),jp=this%p(i)%ind(2),kp=this%p(i)%ind(3),A=this%VFW,dir='W') + end do + ! Sum at boundaries + call this%cfg%syncsum(this%VF) + call this%cfg%syncsum(this%VFU) + call this%cfg%syncsum(this%VFV) + call this%cfg%syncsum(this%VFW) + ! Clip + !where (this%VF.ge.1.0_WP) this%VF=1.0_WP + where (this%VF.lt.0.0_WP) this%VF=0.0_WP + this%VF=min(this%VF,1.0_WP-epsilon(1.0_WP)) + + end subroutine update_VF + + + !> Compute regularized delta function + subroutine get_delta(this,delta,ic,jc,kc,xp,yp,zp,dir) + implicit none + class(lss), intent(inout) :: this + real(WP), intent(out) :: delta !< Return delta function + integer, intent(in) :: ic,jc,kc !< Cell index + real(WP), intent(in) :: xp,yp,zp !< Position of marker + character(len=*) :: dir + real(WP) :: deltax,deltay,deltaz,r + + ! Compute in X + if (trim(adjustl(dir)).eq.'U') then + r=(xp-this%cfg%x(ic))*this%cfg%dxmi(ic) + deltax=roma_kernel(r)*this%cfg%dxmi(ic) + else + r=(xp-this%cfg%xm(ic))*this%cfg%dxi(ic) + deltax=roma_kernel(r)*this%cfg%dxi(ic) + end if + + ! Compute in Y + if (trim(adjustl(dir)).eq.'V') then + r=(yp-this%cfg%y(jc))*this%cfg%dymi(jc) + deltay=roma_kernel(r)*this%cfg%dymi(jc) + else + r=(yp-this%cfg%ym(jc))*this%cfg%dyi(jc) + deltay=roma_kernel(r)*this%cfg%dyi(jc) + end if + + ! Compute in Z + if (trim(adjustl(dir)).eq.'W') then + ! print *, this%cfg%z(kc) + ! print *, this%cfg%dzmi(kc) + r=(zp-this%cfg%z(kc))*this%cfg%dzmi(kc) + deltaz=roma_kernel(r)*this%cfg%dzmi(kc) + else + r=(zp-this%cfg%zm(kc))*this%cfg%dzi(kc) + deltaz=roma_kernel(r)*this%cfg%dzi(kc) + end if + !else + + ! Put it all together + delta=deltax*deltay*deltaz + + contains + ! Mollification kernel + ! Roma A, Peskin C and Berger M 1999 J. Comput. Phys. 153 509–534 + function roma_kernel(r) result(phi) + implicit none + real(WP), intent(in) :: r + real(WP) :: phi + if (abs(r).le.0.5_WP) then + phi=1.0_WP/3.0_WP*(1.0_WP+sqrt(-3.0_WP*r**2+1.0_WP)) + else if (abs(r).gt.0.5_WP .and. abs(r).le.1.5_WP) then + phi=1.0_WP/6.0_WP*(5.0_WP-3.0_WP*abs(r)-sqrt(-3.0_WP*(1.0_WP-abs(r))**2+1.0_WP)) + else + phi=0.0_WP + end if + end function roma_kernel + + end subroutine get_delta + + + !> Interpolation routine + function interpolate(this,A,xp,yp,zp,ip,jp,kp,dir) result(Ap) + implicit none + class(lss), intent(inout) :: this + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(in) :: A !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + real(WP), intent(in) :: xp,yp,zp + integer, intent(in) :: ip,jp,kp + character(len=*) :: dir + real(WP) :: Ap + integer :: di,dj,dk + integer :: i1,i2,j1,j2,k1,k2 + real(WP), dimension(-2:+2,-2:+2,-2:+2) :: delta + ! Get the interpolation points + i1=ip-2; i2=ip+2 + j1=jp-2; j2=jp+2 + k1=kp-2; k2=kp+2 + ! Loop over neighboring cells and compute regularized delta function + do dk=-2,+2 + do dj=-2,+2 + do di=-2,+2 + + call this%get_delta(delta=delta(di,dj,dk),ic=ip+di,jc=jp+dj,kc=kp+dk,xp=xp,yp=yp,zp=zp,dir=trim(dir)) + end do + end do + end do + ! Perform the actual interpolation on Ap + Ap = sum(delta*A(i1:i2,j1:j2,k1:k2))*this%cfg%vol(ip,jp,kp) + end function interpolate + + + !> Extrapolation routine + subroutine extrapolate(this,Ap,xp,yp,zp,ip,jp,kp,A,dir) + use messager, only: die + implicit none + class(lss), intent(inout) :: this + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:) :: A !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + real(WP), intent(in) :: xp,yp,zp + integer, intent(in) :: ip,jp,kp + real(WP), intent(in) :: Ap + character(len=*) :: dir + real(WP), dimension(-2:+2,-2:+2,-2:+2) :: delta + integer :: di,dj,dk + ! If particle has left processor domain or reached last ghost cell, kill job + if ( ip.lt.this%cfg%imin_-1.or.ip.gt.this%cfg%imax_+1.or.& + & jp.lt.this%cfg%jmin_-1.or.jp.gt.this%cfg%jmax_+1.or.& + & kp.lt.this%cfg%kmin_-1.or.kp.gt.this%cfg%kmax_+1) then + write(*,*) ip,jp,kp,xp,yp,zp + call die('[df extrapolate] Particle has left the domain') + end if + ! Loop over neighboring cells and compute regularized delta function + do dk=-2,+2 + do dj=-2,+2 + do di=-2,+2 + call this%get_delta(delta=delta(di,dj,dk),ic=ip+di,jc=jp+dj,kc=kp+dk,xp=xp,yp=yp,zp=zp,dir=trim(dir)) + end do + end do + end do + ! Perform the actual extrapolation on A + A(ip-2:ip+2,jp-2:jp+2,kp-2:kp+2)=A(ip-2:ip+2,jp-2:jp+2,kp-2:kp+2)+delta*Ap + end subroutine extrapolate + + + !> Calculate the CFL + subroutine get_cfl(this,dt,cfl) + use mpi_f08, only: MPI_ALLREDUCE,MPI_MAX + use parallel, only: MPI_REAL_WP + implicit none + class(lss), intent(inout) :: this + real(WP), intent(in) :: dt + real(WP), intent(out) :: cfl + integer :: i,ierr + real(WP) :: my_CFLp_x,my_CFLp_y,my_CFLp_z,kk,mu,a + + ! Set the CFLs to zero + my_CFLp_x=0.0_WP; my_CFLp_y=0.0_WP; my_CFLp_z=0.0_WP + do i=1,this%np_ + my_CFLp_x=max(my_CFLp_x,abs(this%p(i)%vel(1))*this%cfg%dxi(this%p(i)%ind(1))) + my_CFLp_y=max(my_CFLp_y,abs(this%p(i)%vel(2))*this%cfg%dyi(this%p(i)%ind(2))) + my_CFLp_z=max(my_CFLp_z,abs(this%p(i)%vel(3))*this%cfg%dzi(this%p(i)%ind(3))) + end do + my_CFLp_x=my_CFLp_x*dt; my_CFLp_y=my_CFLp_y*dt; my_CFLp_z=my_CFLp_z*dt + + ! Get the parallel max + call MPI_ALLREDUCE(my_CFLp_x,this%CFLp_x,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + call MPI_ALLREDUCE(my_CFLp_y,this%CFLp_y,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + call MPI_ALLREDUCE(my_CFLp_z,this%CFLp_z,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + + ! CFL based on elastic wave speed in material + kk=this%elastic_modulus/(3.0_WP-6.0_WP*this%poisson_ratio) + mu=this%elastic_modulus/(2.0_WP+2.0_WP*this%poisson_ratio) + a=sqrt((kk+4.0_WP*mu/3.0_WP)/this%rho) + this%CFLp_a=dt*a*3/this%delta + + ! Return the maximum CFL + cfl=max(this%CFLp_x,this%CFLp_y,this%CFLp_z,this%CFLp_a) + + end subroutine get_cfl + + + !> Extract various monitoring data from particle field + subroutine get_max(this) + use mpi_f08, only: MPI_ALLREDUCE,MPI_MAX,MPI_MIN,MPI_SUM + use parallel, only: MPI_REAL_WP + implicit none + class(lss), intent(inout) :: this + real(WP) :: buf,safe_np + real(WP), dimension(3) :: buf3D + integer :: i,j,k,ierr + + ! Create safe np + safe_np=real(max(this%np,1),WP) + + ! Velocity min/max/mean + this%Umin=huge(1.0_WP); this%Umax=-huge(1.0_WP); this%Umean=0.0_WP + this%Vmin=huge(1.0_WP); this%Vmax=-huge(1.0_WP); this%Vmean=0.0_WP + this%Wmin=huge(1.0_WP); this%Wmax=-huge(1.0_WP); this%Wmean=0.0_WP + this%ibmForce=0.0_WP + do i=1,this%np_ + this%Umin=min(this%Umin,this%p(i)%vel(1)); this%Umax=max(this%Umax,this%p(i)%vel(1)); this%Umean=this%Umean+this%p(i)%vel(1) + this%Vmin=min(this%Vmin,this%p(i)%vel(2)); this%Vmax=max(this%Vmax,this%p(i)%vel(2)); this%Vmean=this%Vmean+this%p(i)%vel(2) + this%Wmin=min(this%Wmin,this%p(i)%vel(3)); this%Wmax=max(this%Wmax,this%p(i)%vel(3)); this%Wmean=this%Wmean+this%p(i)%vel(3) + this%ibmForce=this%ibmForce+this%p(i)%Afluid*this%p(i)%vol*this%rho + end do + call MPI_ALLREDUCE(this%Umin ,buf,1,MPI_REAL_WP,MPI_MIN,this%cfg%comm,ierr); this%Umin =buf + call MPI_ALLREDUCE(this%Umax ,buf,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr); this%Umax =buf + call MPI_ALLREDUCE(this%Umean,buf,1,MPI_REAL_WP,MPI_SUM,this%cfg%comm,ierr); this%Umean=buf/safe_np + call MPI_ALLREDUCE(this%Vmin ,buf,1,MPI_REAL_WP,MPI_MIN,this%cfg%comm,ierr); this%Vmin =buf + call MPI_ALLREDUCE(this%Vmax ,buf,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr); this%Vmax =buf + call MPI_ALLREDUCE(this%Vmean,buf,1,MPI_REAL_WP,MPI_SUM,this%cfg%comm,ierr); this%Vmean=buf/safe_np + call MPI_ALLREDUCE(this%Wmin ,buf,1,MPI_REAL_WP,MPI_MIN,this%cfg%comm,ierr); this%Wmin =buf + call MPI_ALLREDUCE(this%Wmax ,buf,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr); this%Wmax =buf + call MPI_ALLREDUCE(this%Wmean,buf,1,MPI_REAL_WP,MPI_SUM,this%cfg%comm,ierr); this%Wmean=buf/safe_np + call MPI_ALLREDUCE(this%ibmForce,buf3D,3,MPI_REAL_WP,MPI_SUM,this%cfg%comm,ierr); this%ibmForce=buf3D + + ! Get max volume fraction + this%VFmax =-huge(1.0_WP) + do k=this%cfg%kmin_,this%cfg%kmax_ + do j=this%cfg%jmin_,this%cfg%jmax_ + do i=this%cfg%imin_,this%cfg%imax_ + this%VFmax=max(this%VFmax,this%VF(i,j,k)) + end do + end do + end do + call MPI_ALLREDUCE(this%VFmax,buf,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr); this%VFmax=buf + + end subroutine get_max + + + !> Update particle mesh using our current particles + subroutine update_partmesh(this,pmesh) + use partmesh_class, only: partmesh + implicit none + class(lss), intent(inout) :: this + class(partmesh), intent(inout) :: pmesh + integer :: i + ! Reset particle mesh storage + call pmesh%reset() + ! Nothing else to do if no particle is present + if (this%np_.eq.0) return + ! Copy particle info + call pmesh%set_size(this%np_) + do i=1,this%np_ + pmesh%pos(:,i)=this%p(i)%pos + end do + end subroutine update_partmesh + + + !> Creation of the MPI datatype for particle + subroutine prepare_mpi_part() + use mpi_f08 + use messager, only: die + implicit none + integer(MPI_ADDRESS_KIND), dimension(part_nblock) :: disp + integer(MPI_ADDRESS_KIND) :: lb,extent + type(MPI_Datatype) :: MPI_PART_TMP + integer :: i,mysize,ierr + ! Prepare the displacement array + disp(1)=0 + do i=2,part_nblock + call MPI_Type_size(part_tblock(i-1),mysize,ierr) + disp(i)=disp(i-1)+int(mysize,MPI_ADDRESS_KIND)*int(part_lblock(i-1),MPI_ADDRESS_KIND) + end do + ! Create and commit the new type + call MPI_Type_create_struct(part_nblock,part_lblock,disp,part_tblock,MPI_PART_TMP,ierr) + call MPI_Type_get_extent(MPI_PART_TMP,lb,extent,ierr) + call MPI_Type_create_resized(MPI_PART_TMP,lb,extent,MPI_PART,ierr) + call MPI_Type_commit(MPI_PART,ierr) + ! If a problem was encountered, say it + if (ierr.ne.0) call die('[lss prepare_mpi_part] MPI Particle type creation failed') + ! Get the size of this type + call MPI_type_size(MPI_PART,MPI_PART_SIZE,ierr) + end subroutine prepare_mpi_part + + + !> Share particles across processor boundaries + subroutine share(this,nover) + use mpi_f08 + use messager, only: warn,die + implicit none + class(lss), intent(inout) :: this + integer, optional :: nover + type(part), dimension(:), allocatable :: tosend + type(part), dimension(:), allocatable :: torecv + integer :: no,nsend,nrecv + type(MPI_Status) :: status + integer :: icnt,isrc,idst,ierr + integer :: i,n + + ! Check overlap size + if (present(nover)) then + no=nover + if (no.gt.this%cfg%no) then + call warn('[lss share] Specified overlap is larger than that of cfg - reducing no') + no=this%cfg%no + else if (no.le.0) then + call die('[lss share] Specified overlap cannot be less or equal to zero') + end if + else + no=1 + end if + + ! Clean up ghost array + call this%resize_ghost(n=0); this%ng_=0 + + ! Share ghost particles in -x (no ghosts are sent here) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(1).lt.this%cfg%imin_+no) nsend=nsend+1 + end do + allocate(tosend(nsend)) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(1).lt.this%cfg%imin_+no) then + nsend=nsend+1 + tosend(nsend)=this%p(n) + if (this%cfg%xper.and.tosend(nsend)%ind(1).lt.this%cfg%imin+no) then + tosend(nsend)%pos(1)=tosend(nsend)%pos(1)+this%cfg%xL + tosend(nsend)%ind(1)=tosend(nsend)%ind(1)+this%cfg%nx + end if + end if + end do + nrecv=0 + call MPI_CART_SHIFT(this%cfg%comm,0,-1,isrc,idst,ierr) + call MPI_SENDRECV(nsend,1,MPI_INTEGER,idst,0,nrecv,1,MPI_INTEGER,isrc,0,this%cfg%comm,status,ierr) + allocate(torecv(nrecv)) + call MPI_SENDRECV(tosend,nsend,MPI_PART,idst,0,torecv,nrecv,MPI_PART,isrc,0,this%cfg%comm,status,ierr) + call this%resize_ghost(this%ng_+nrecv) + this%g(this%ng_+1:this%ng_+nrecv)=torecv + this%ng_=this%ng_+nrecv + if (allocated(tosend)) deallocate(tosend) + if (allocated(torecv)) deallocate(torecv) + + ! Share ghost particles in +x (no ghosts are sent here) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(1).gt.this%cfg%imax_-no) nsend=nsend+1 + end do + allocate(tosend(nsend)) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(1).gt.this%cfg%imax_-no) then + nsend=nsend+1 + tosend(nsend)=this%p(n) + if (this%cfg%xper.and.tosend(nsend)%ind(1).gt.this%cfg%imax-no) then + tosend(nsend)%pos(1)=tosend(nsend)%pos(1)-this%cfg%xL + tosend(nsend)%ind(1)=tosend(nsend)%ind(1)-this%cfg%nx + end if + end if + end do + nrecv=0 + call MPI_CART_SHIFT(this%cfg%comm,0,+1,isrc,idst,ierr) + call MPI_SENDRECV(nsend,1,MPI_INTEGER,idst,0,nrecv,1,MPI_INTEGER,isrc,0,this%cfg%comm,status,ierr) + allocate(torecv(nrecv)) + call MPI_SENDRECV(tosend,nsend,MPI_PART,idst,0,torecv,nrecv,MPI_PART,isrc,0,this%cfg%comm,status,ierr) + call this%resize_ghost(this%ng_+nrecv) + this%g(this%ng_+1:this%ng_+nrecv)=torecv + this%ng_=this%ng_+nrecv + if (allocated(tosend)) deallocate(tosend) + if (allocated(torecv)) deallocate(torecv) + + ! Share ghost particles in -y (ghosts need to be sent now) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(2).lt.this%cfg%jmin_+no) nsend=nsend+1 + end do + do n=1,this%ng_ + if (this%g(n)%ind(2).lt.this%cfg%jmin_+no) nsend=nsend+1 + end do + allocate(tosend(nsend)) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(2).lt.this%cfg%jmin_+no) then + nsend=nsend+1 + tosend(nsend)=this%p(n) + if (this%cfg%yper.and.tosend(nsend)%ind(2).lt.this%cfg%jmin+no) then + tosend(nsend)%pos(2)=tosend(nsend)%pos(2)+this%cfg%yL + tosend(nsend)%ind(2)=tosend(nsend)%ind(2)+this%cfg%ny + end if + end if + end do + do n=1,this%ng_ + if (this%g(n)%ind(2).lt.this%cfg%jmin_+no) then + nsend=nsend+1 + tosend(nsend)=this%g(n) + if (this%cfg%yper.and.tosend(nsend)%ind(2).lt.this%cfg%jmin+no) then + tosend(nsend)%pos(2)=tosend(nsend)%pos(2)+this%cfg%yL + tosend(nsend)%ind(2)=tosend(nsend)%ind(2)+this%cfg%ny + end if + end if + end do + nrecv=0 + call MPI_CART_SHIFT(this%cfg%comm,1,-1,isrc,idst,ierr) + call MPI_SENDRECV(nsend,1,MPI_INTEGER,idst,0,nrecv,1,MPI_INTEGER,isrc,0,this%cfg%comm,status,ierr) + allocate(torecv(nrecv)) + call MPI_SENDRECV(tosend,nsend,MPI_PART,idst,0,torecv,nrecv,MPI_PART,isrc,0,this%cfg%comm,status,ierr) + call this%resize_ghost(this%ng_+nrecv) + this%g(this%ng_+1:this%ng_+nrecv)=torecv + this%ng_=this%ng_+nrecv + if (allocated(tosend)) deallocate(tosend) + if (allocated(torecv)) deallocate(torecv) + + ! Share ghost particles in +y (ghosts need to be sent now - but not newly received ghosts!) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(2).gt.this%cfg%jmax_-no) nsend=nsend+1 + end do + do n=1,this%ng_-nrecv + if (this%g(n)%ind(2).gt.this%cfg%jmax_-no) nsend=nsend+1 + end do + allocate(tosend(nsend)) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(2).gt.this%cfg%jmax_-no) then + nsend=nsend+1 + tosend(nsend)=this%p(n) + if (this%cfg%yper.and.tosend(nsend)%ind(2).gt.this%cfg%jmax-no) then + tosend(nsend)%pos(2)=tosend(nsend)%pos(2)-this%cfg%yL + tosend(nsend)%ind(2)=tosend(nsend)%ind(2)-this%cfg%ny + end if + end if + end do + do n=1,this%ng_-nrecv + if (this%g(n)%ind(2).gt.this%cfg%jmax_-no) then + nsend=nsend+1 + tosend(nsend)=this%g(n) + if (this%cfg%yper.and.tosend(nsend)%ind(2).gt.this%cfg%jmax-no) then + tosend(nsend)%pos(2)=tosend(nsend)%pos(2)-this%cfg%yL + tosend(nsend)%ind(2)=tosend(nsend)%ind(2)-this%cfg%ny + end if + end if + end do + nrecv=0 + call MPI_CART_SHIFT(this%cfg%comm,1,+1,isrc,idst,ierr) + call MPI_SENDRECV(nsend,1,MPI_INTEGER,idst,0,nrecv,1,MPI_INTEGER,isrc,0,this%cfg%comm,status,ierr) + allocate(torecv(nrecv)) + call MPI_SENDRECV(tosend,nsend,MPI_PART,idst,0,torecv,nrecv,MPI_PART,isrc,0,this%cfg%comm,status,ierr) + call this%resize_ghost(this%ng_+nrecv) + this%g(this%ng_+1:this%ng_+nrecv)=torecv + this%ng_=this%ng_+nrecv + if (allocated(tosend)) deallocate(tosend) + if (allocated(torecv)) deallocate(torecv) + + ! Share ghost particles in -z (ghosts need to be sent now) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(3).lt.this%cfg%kmin_+no) nsend=nsend+1 + end do + do n=1,this%ng_ + if (this%g(n)%ind(3).lt.this%cfg%kmin_+no) nsend=nsend+1 + end do + allocate(tosend(nsend)) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(3).lt.this%cfg%kmin_+no) then + nsend=nsend+1 + tosend(nsend)=this%p(n) + if (this%cfg%zper.and.tosend(nsend)%ind(3).lt.this%cfg%kmin+no) then + tosend(nsend)%pos(3)=tosend(nsend)%pos(3)+this%cfg%zL + tosend(nsend)%ind(3)=tosend(nsend)%ind(3)+this%cfg%nz + end if + end if + end do + do n=1,this%ng_ + if (this%g(n)%ind(3).lt.this%cfg%kmin_+no) then + nsend=nsend+1 + tosend(nsend)=this%g(n) + if (this%cfg%zper.and.tosend(nsend)%ind(3).lt.this%cfg%kmin+no) then + tosend(nsend)%pos(3)=tosend(nsend)%pos(3)+this%cfg%zL + tosend(nsend)%ind(3)=tosend(nsend)%ind(3)+this%cfg%nz + end if + end if + end do + nrecv=0 + call MPI_CART_SHIFT(this%cfg%comm,2,-1,isrc,idst,ierr) + call MPI_SENDRECV(nsend,1,MPI_INTEGER,idst,0,nrecv,1,MPI_INTEGER,isrc,0,this%cfg%comm,status,ierr) + allocate(torecv(nrecv)) + call MPI_SENDRECV(tosend,nsend,MPI_PART,idst,0,torecv,nrecv,MPI_PART,isrc,0,this%cfg%comm,status,ierr) + call this%resize_ghost(this%ng_+nrecv) + this%g(this%ng_+1:this%ng_+nrecv)=torecv + this%ng_=this%ng_+nrecv + if (allocated(tosend)) deallocate(tosend) + if (allocated(torecv)) deallocate(torecv) + + ! Share ghost particles in +z (ghosts need to be sent now - but not newly received ghosts!) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(3).gt.this%cfg%kmax_-no) nsend=nsend+1 + end do + do n=1,this%ng_-nrecv + if (this%g(n)%ind(3).gt.this%cfg%kmax_-no) nsend=nsend+1 + end do + allocate(tosend(nsend)) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(3).gt.this%cfg%kmax_-no) then + nsend=nsend+1 + tosend(nsend)=this%p(n) + if (this%cfg%zper.and.tosend(nsend)%ind(3).gt.this%cfg%kmax-no) then + tosend(nsend)%pos(3)=tosend(nsend)%pos(3)-this%cfg%zL + tosend(nsend)%ind(3)=tosend(nsend)%ind(3)-this%cfg%nz + end if + end if + end do + do n=1,this%ng_-nrecv + if (this%g(n)%ind(3).gt.this%cfg%kmax_-no) then + nsend=nsend+1 + tosend(nsend)=this%g(n) + if (this%cfg%zper.and.tosend(nsend)%ind(3).gt.this%cfg%kmax-no) then + tosend(nsend)%pos(3)=tosend(nsend)%pos(3)-this%cfg%zL + tosend(nsend)%ind(3)=tosend(nsend)%ind(3)-this%cfg%nz + end if + end if + end do + nrecv=0 + call MPI_CART_SHIFT(this%cfg%comm,2,+1,isrc,idst,ierr) + call MPI_SENDRECV(nsend,1,MPI_INTEGER,idst,0,nrecv,1,MPI_INTEGER,isrc,0,this%cfg%comm,status,ierr) + allocate(torecv(nrecv)) + call MPI_SENDRECV(tosend,nsend,MPI_PART,idst,0,torecv,nrecv,MPI_PART,isrc,0,this%cfg%comm,status,ierr) + call this%resize_ghost(this%ng_+nrecv) + this%g(this%ng_+1:this%ng_+nrecv)=torecv + this%ng_=this%ng_+nrecv + if (allocated(tosend)) deallocate(tosend) + if (allocated(torecv)) deallocate(torecv) + + end subroutine share + + + !> Synchronize particle arrays across processors + subroutine sync(this) + use mpi_f08 + implicit none + class(lss), intent(inout) :: this + integer, dimension(0:this%cfg%nproc-1) :: nsend_proc,nrecv_proc + integer, dimension(0:this%cfg%nproc-1) :: nsend_disp,nrecv_disp + integer :: n,prank,ierr + type(part), dimension(:), allocatable :: buf_send + ! Recycle first to minimize communication load + call this%recycle() + ! Prepare information about what to send + nsend_proc=0 + do n=1,this%np_ + prank=this%cfg%get_rank(this%p(n)%ind) + nsend_proc(prank)=nsend_proc(prank)+1 + end do + nsend_proc(this%cfg%rank)=0 + ! Inform processors of what they will receive + call MPI_ALLtoALL(nsend_proc,1,MPI_INTEGER,nrecv_proc,1,MPI_INTEGER,this%cfg%comm,ierr) + ! Prepare displacements for all-to-all + nsend_disp(0)=0 + nrecv_disp(0)=this%np_ !< Directly add particles at the end of main array + do n=1,this%cfg%nproc-1 + nsend_disp(n)=nsend_disp(n-1)+nsend_proc(n-1) + nrecv_disp(n)=nrecv_disp(n-1)+nrecv_proc(n-1) + end do + ! Allocate buffer to send particles + allocate(buf_send(sum(nsend_proc))) + ! Pack the particles in the send buffer + nsend_proc=0 + do n=1,this%np_ + ! Get the rank + prank=this%cfg%get_rank(this%p(n)%ind) + ! Skip particles still inside + if (prank.eq.this%cfg%rank) cycle + ! Pack up for sending + nsend_proc(prank)=nsend_proc(prank)+1 + buf_send(nsend_disp(prank)+nsend_proc(prank))=this%p(n) + ! Flag particle for removal + this%p(n)%flag=1 + end do + ! Allocate buffer for receiving particles + call this%resize(this%np_+sum(nrecv_proc)) + ! Perform communication + call MPI_ALLtoALLv(buf_send,nsend_proc,nsend_disp,MPI_PART,this%p,nrecv_proc,nrecv_disp,MPI_PART,this%cfg%comm,ierr) + ! Deallocate buffer + deallocate(buf_send) + ! Recycle to remove duplicate particles + call this%recycle() + end subroutine sync + + + !> Adaptation of particle array size + subroutine resize(this,n) + implicit none + class(lss), intent(inout) :: this + integer, intent(in) :: n + type(part), dimension(:), allocatable :: tmp + integer :: size_now,size_new + ! Resize particle array to size n + if (.not.allocated(this%p)) then + ! Allocate directly to size n + allocate(this%p(n)) + this%p(1:n)%flag=1 + else + ! Update from a non-zero size to another non-zero size + size_now=size(this%p,dim=1) + if (n.gt.size_now) then + size_new=max(n,int(real(size_now,WP)*coeff_up)) + allocate(tmp(size_new)) + tmp(1:size_now)=this%p + tmp(size_now+1:)%flag=1 + call move_alloc(tmp,this%p) + else if (n.lt.int(real(size_now,WP)*coeff_dn)) then + allocate(tmp(n)) + tmp(1:n)=this%p(1:n) + call move_alloc(tmp,this%p) + end if + end if + end subroutine resize + + + !> Adaptation of ghost array size + subroutine resize_ghost(this,n) + implicit none + class(lss), intent(inout) :: this + integer, intent(in) :: n + type(part), dimension(:), allocatable :: tmp + integer :: size_now,size_new + ! Resize ghost array to size n + if (.not.allocated(this%g)) then + ! Allocate directly to size n + allocate(this%g(n)) + this%g(1:n)%flag=1 + else + ! Update from a non-zero size to another non-zero size + size_now=size(this%g,dim=1) + if (n.gt.size_now) then + size_new=max(n,int(real(size_now,WP)*coeff_up)) + allocate(tmp(size_new)) + tmp(1:size_now)=this%g + tmp(size_now+1:)%flag=1 + call move_alloc(tmp,this%g) + else if (n.lt.int(real(size_now,WP)*coeff_dn)) then + allocate(tmp(n)) + tmp(1:n)=this%g(1:n) + call move_alloc(tmp,this%g) + end if + end if + end subroutine resize_ghost + + + !> Clean-up of particle array by removing flag=1 particles + subroutine recycle(this) + implicit none + class(lss), intent(inout) :: this + integer :: new_size,i,ierr + ! Compact all active particles at the beginning of the array + new_size=0 + if (allocated(this%p)) then + do i=1,size(this%p,dim=1) + if (this%p(i)%flag.ne.1) then + new_size=new_size+1 + if (i.ne.new_size) then + this%p(new_size)=this%p(i) + this%p(i)%flag=1 + end if + end if + end do + end if + ! Resize to new size + call this%resize(new_size) + ! Update number of particles + this%np_=new_size + call MPI_ALLGATHER(this%np_,1,MPI_INTEGER,this%np_proc,1,MPI_INTEGER,this%cfg%comm,ierr) + this%np=sum(this%np_proc) + end subroutine recycle + + + !> Parallel write particles to file + subroutine write(this,filename) + use mpi_f08 + use messager, only: die + use parallel, only: info_mpiio + implicit none + class(lss), intent(inout) :: this + character(len=*), intent(in) :: filename + type(MPI_File) :: ifile + type(MPI_Status):: status + integer(kind=MPI_OFFSET_KIND) :: offset + integer :: i,ierr,iunit + + ! Root serial-writes the file header + if (this%cfg%amRoot) then + ! Open the file + open(newunit=iunit,file=trim(filename),form='unformatted',status='replace',access='stream',iostat=ierr) + if (ierr.ne.0) call die('[lss write] Problem encountered while serial-opening data file: '//trim(filename)) + ! Number of particles and particle object size + write(iunit) this%np,MPI_PART_SIZE + ! Done with the header + close(iunit) + end if + + ! The rest is done in parallel + call MPI_FILE_OPEN(this%cfg%comm,trim(filename),IOR(MPI_MODE_WRONLY,MPI_MODE_APPEND),info_mpiio,ifile,ierr) + if (ierr.ne.0) call die('[lss write] Problem encountered while parallel-opening data file: '//trim(filename)) + + ! Get current position + call MPI_FILE_GET_POSITION(ifile,offset,ierr) + + ! Compute the offset and write + do i=1,this%cfg%rank + offset=offset+int(this%np_proc(i),MPI_OFFSET_KIND)*int(MPI_PART_SIZE,MPI_OFFSET_KIND) + end do + if (this%np_.gt.0) call MPI_FILE_WRITE_AT(ifile,offset,this%p,this%np_,MPI_PART,status,ierr) + + ! Close the file + call MPI_FILE_CLOSE(ifile,ierr) + + ! Log/screen output + logging: block + use, intrinsic :: iso_fortran_env, only: output_unit + use param, only: verbose + use messager, only: log + use string, only: str_long + character(len=str_long) :: message + if (this%cfg%amRoot) then + write(message,'("[lss write] Wrote ",i0," particles to file [",a,"] on partitioned grid [",a,"]")') this%np,trim(filename),trim(this%cfg%name) + if (verbose.gt.2) write(output_unit,'(a)') trim(message) + if (verbose.gt.1) call log(message) + end if + end block logging + + end subroutine write + + + !> Parallel read particles to file + subroutine read(this,filename) + use mpi_f08 + use messager, only: die + use parallel, only: info_mpiio + implicit none + class(lss), intent(inout) :: this + character(len=*), intent(in) :: filename + type(MPI_File) :: ifile + type(MPI_Status):: status + integer(kind=MPI_OFFSET_KIND) :: offset,header_offset + integer :: i,j,ierr,npadd,psize,nchunk,cnt + integer, dimension(:,:), allocatable :: ppp + + ! First open the file in parallel + call MPI_FILE_OPEN(this%cfg%comm,trim(filename),MPI_MODE_RDONLY,info_mpiio,ifile,ierr) + if (ierr.ne.0) call die('[lss read] Problem encountered while reading data file: '//trim(filename)) + + ! Read file header first + call MPI_FILE_READ_ALL(ifile,npadd,1,MPI_INTEGER,status,ierr) + call MPI_FILE_READ_ALL(ifile,psize,1,MPI_INTEGER,status,ierr) + + ! Remember current position + call MPI_FILE_GET_POSITION(ifile,header_offset,ierr) + + ! Check compatibility of particle type + if (psize.ne.MPI_PART_SIZE) call die('[lss read] Particle type unreadable') + + ! Naively share reading task among all processors + nchunk=int(npadd/(this%cfg%nproc*part_chunk_size))+1 + allocate(ppp(this%cfg%nproc,nchunk)) + ppp=int(npadd/(this%cfg%nproc*nchunk)) + cnt=0 + out:do j=1,nchunk + do i=1,this%cfg%nproc + cnt=cnt+1 + if (cnt.gt.mod(npadd,this%cfg%nproc*nchunk)) exit out + ppp(i,j)=ppp(i,j)+1 + end do + end do out + + ! Read by chunk + do j=1,nchunk + ! Find offset + offset=header_offset+int(MPI_PART_SIZE,MPI_OFFSET_KIND)*int(sum(ppp(1:this%cfg%rank,:))+sum(ppp(this%cfg%rank+1,1:j-1)),MPI_OFFSET_KIND) + ! Resize particle array + call this%resize(this%np_+ppp(this%cfg%rank+1,j)) + ! Read this file + call MPI_FILE_READ_AT(ifile,offset,this%p(this%np_+1:this%np_+ppp(this%cfg%rank+1,j)),ppp(this%cfg%rank+1,j),MPI_PART,status,ierr) + ! Most general case: relocate every droplet + do i=this%np_+1,this%np_+ppp(this%cfg%rank+1,j) + this%p(i)%ind=this%cfg%get_ijk_global(this%p(i)%pos,this%p(i)%ind) + end do + ! Exchange all that + call this%sync() + end do + + ! Close the file + call MPI_FILE_CLOSE(ifile,ierr) + + ! Log/screen output + logging: block + use, intrinsic :: iso_fortran_env, only: output_unit + use param, only: verbose + use messager, only: log + use string, only: str_long + character(len=str_long) :: message + if (this%cfg%amRoot) then + write(message,'("[lss read] Read ",i0," particles from file [",a,"] on partitioned grid [",a,"]")') npadd,trim(filename),trim(this%cfg%name) + if (verbose.gt.2) write(output_unit,'(a)') trim(message) + if (verbose.gt.1) call log(message) + end if + end block logging + + end subroutine read + + +end module lss_class diff --git a/examples/cylinder_NOSB/src/simulation.f90 b/examples/cylinder_NOSB/src/simulation.f90 new file mode 100644 index 000000000..7fc007c9a --- /dev/null +++ b/examples/cylinder_NOSB/src/simulation.f90 @@ -0,0 +1,644 @@ +!> Various definitions and tools for running an NGA2 simulation +module simulation + use precision, only: WP + use geometry, only: cfg + use fft2d_class, only: fft2d + use ddadi_class, only: ddadi + use incomp_class, only: incomp + use lss_class, only: lss + use timetracker_class, only: timetracker + use ensight_class, only: ensight + use partmesh_class, only: partmesh + use event_class, only: event + use monitor_class, only: monitor + implicit none + private + + !> Get a couple linear solvers, an incompressible flow solver and corresponding time tracker + type(fft2d), public :: ps + type(ddadi), public :: vs + type(incomp), public :: fs + type(lss), public :: ls + type(partmesh), public :: pmesh + type(timetracker), public :: time + + !> Ensight postprocessing + + type(ensight) :: ens_out + type(event) :: ens_evt + + !> Simulation monitor file + type(monitor) :: mfile,cflfile,sfile + + public :: simulation_init,simulation_run,simulation_final + + !> Private work arrays + real(WP), dimension(:,:,:), allocatable :: div_x,div_y,div_z + real(WP), dimension(:,:,:), allocatable :: resU,resV,resW + real(WP), dimension(:,:,:), allocatable :: Ui,Vi,Wi + real(WP), dimension(:,:,:), allocatable :: Uib,Vib,Wib,srcM + real(WP), dimension(:,:,:,:,:), allocatable :: gradU + + !> Max timestep size for solid solver + real(WP) :: ls_dt,ls_dt_max + + +contains + + + !> Function that localizes the left (x-) of the domain + function left_of_domain(pg,i,j,k) result(isIn) + use pgrid_class, only: pgrid + implicit none + class(pgrid), intent(in) :: pg + integer, intent(in) :: i,j,k + logical :: isIn + isIn=.false. + if (i.eq.pg%imin) isIn=.true. + end function left_of_domain + + + !> Function that localizes the right (x+) of the domain + function right_of_domain(pg,i,j,k) result(isIn) + use pgrid_class, only: pgrid + implicit none + class(pgrid), intent(in) :: pg + integer, intent(in) :: i,j,k + logical :: isIn + isIn=.false. + if (i.eq.pg%imax+1) isIn=.true. + end function right_of_domain + + + !> Initialization of problem solver + subroutine simulation_init + use param, only: param_read + implicit none + + + ! Allocate work arrays + allocate_work_arrays: block + allocate(div_x(cfg%imino_:cfg%imaxo_,cfg%jmino_:cfg%jmaxo_,cfg%kmino_:cfg%kmaxo_)) + allocate(div_y(cfg%imino_:cfg%imaxo_,cfg%jmino_:cfg%jmaxo_,cfg%kmino_:cfg%kmaxo_)) + allocate(div_z(cfg%imino_:cfg%imaxo_,cfg%jmino_:cfg%jmaxo_,cfg%kmino_:cfg%kmaxo_)) + allocate(resU(cfg%imino_:cfg%imaxo_,cfg%jmino_:cfg%jmaxo_,cfg%kmino_:cfg%kmaxo_)) + allocate(resV(cfg%imino_:cfg%imaxo_,cfg%jmino_:cfg%jmaxo_,cfg%kmino_:cfg%kmaxo_)) + allocate(resW(cfg%imino_:cfg%imaxo_,cfg%jmino_:cfg%jmaxo_,cfg%kmino_:cfg%kmaxo_)) + allocate(Ui (cfg%imino_:cfg%imaxo_,cfg%jmino_:cfg%jmaxo_,cfg%kmino_:cfg%kmaxo_)) + allocate(Vi (cfg%imino_:cfg%imaxo_,cfg%jmino_:cfg%jmaxo_,cfg%kmino_:cfg%kmaxo_)) + allocate(Wi (cfg%imino_:cfg%imaxo_,cfg%jmino_:cfg%jmaxo_,cfg%kmino_:cfg%kmaxo_)) + allocate(Uib (cfg%imino_:cfg%imaxo_,cfg%jmino_:cfg%jmaxo_,cfg%kmino_:cfg%kmaxo_)) + allocate(Vib (cfg%imino_:cfg%imaxo_,cfg%jmino_:cfg%jmaxo_,cfg%kmino_:cfg%kmaxo_)) + allocate(Wib (cfg%imino_:cfg%imaxo_,cfg%jmino_:cfg%jmaxo_,cfg%kmino_:cfg%kmaxo_)) + allocate(srcM(cfg%imino_:cfg%imaxo_,cfg%jmino_:cfg%jmaxo_,cfg%kmino_:cfg%kmaxo_)) + allocate(gradU(1:3,1:3,cfg%imino_:cfg%imaxo_,cfg%jmino_:cfg%jmaxo_,cfg%kmino_:cfg%kmaxo_)) + end block allocate_work_arrays + + + ! Initialize time tracker with 2 subiterations + initialize_timetracker: block + time=timetracker(amRoot=cfg%amRoot) + call param_read('Max timestep size',time%dtmax) + call param_read('Max cfl number',time%cflmax) + call param_read('Max time',time%tmax) + time%dt=time%dtmax + time%itmax=2 + end block initialize_timetracker + + ! Initialize Lagrangian solid solver + initialize_lss: block + use mpi_f08, only: MPI_ALLREDUCE,MPI_MAX,MPI_INTEGER + real(WP) :: dx,mu,kk,max_stretch,Lx,Ly,Lz,R,x,y,z,load_rate + real(WP) :: xmin,xmax,ymin,ymax,zmin,zmax,ratio,dist + integer :: np,nt,nx,ny,nz,ierr,global_index,N + type triangle_type + real(WP), dimension(3) :: norm + real(WP), dimension(3) :: v1 + real(WP), dimension(3) :: v2 + real(WP), dimension(3) :: v3 + end type triangle_type + type(triangle_type), dimension(:), allocatable :: t + + ! Create solver + ls=lss(cfg=cfg,name='solid') + + ! Set material properties + call param_read('Elastic Modulus',ls%elastic_modulus) + call param_read('Poisson Ratio',ls%poisson_ratio) + call param_read('Solid density',ls%rho) + call param_read('Critical Energy Release Rate',ls%crit_energy) + + ! Maximum timestep size used for particles + call param_read('Particle timestep size',ls_dt_max,default=huge(1.0_WP)) + ls_dt=min(ls_dt_max,time%dtmax) + + ! Discretization + ! ls%delta=fs%cfg%min_meshsize*1.01 + ! Load',P_load) + call param_read('Lx',Lx) + call param_read('Ly',Ly) + call param_read('Lz',Lz) + call param_read('R',R) + call param_read('Solid Spacing',dist) + + nx = ceiling(2.0_WP*R/dist) + ny=nx + nz= floor(Lz/dist) + dist = Lz/nz + print *, "dist: ", dist + + call param_read('Horizon Ratio',ratio) + ls%delta = dist*ratio + + ! Output some info on stretch + mu=ls%elastic_modulus/(2.0_WP+2.0_WP*ls%poisson_ratio) + kk=ls%elastic_modulus/(3.0_WP-6.0_WP*ls%poisson_ratio) + max_stretch=sqrt(ls%crit_energy/((3.0_WP*mu+(kk-5.0_WP*mu/3.0_WP)*0.75_WP**4)*ls%delta)) + + ! Only root process initializes solid particles + if (ls%cfg%amRoot) then + ! Read the STL file and get domain extents and levelset + read_bin: block + use messager, only: die + integer :: p,iunit,ierr, wall_np, i, j, k + real(WP) :: net_vol + net_vol = 0.0_WP + ! Read in grid definition + wall_np = (ny)*(nz)*(nx) + ceiling(1.5_WP*R/dist) * nz + call ls%resize(wall_np) + p=0 + do i=1,nx + do j=1,ny + do k=1,nz + + x = (i-1) * dist - (R)! - dist/2.0_WP); + y = (j-1) * dist - (R)! - dist/2.0_WP); + z = (k-1) * dist - Lz/2.0_WP + dist/2.0_WP; + ! print *, "looping" + ! print *, "dist: ", ((x)*(x) + y*y + z*z) + if (((x)*(x) + y*y).ge.R*R) cycle; ! Forming a sphere here + p = p+1 + ls%p(p)%pos(1) = x + ls%p(p)%pos(2) = y + ls%p(p)%pos(3) = z + ls%p(p)%ipos=ls%p(p)%pos + ls%p(p)%displacement=0.0_WP + ls%p(p)%vol = dist*dist*dist + ls%p(p)%id=-1 + ls%p(p)%vel=[0.0_WP,0.0_WP,0.0_WP] + net_vol=net_vol+ls%p(p)%vol + ! Zero out force + ls%p(p)%Abond=0.0_WP + ls%p(p)%Afluid=0.0_WP + ! Locate the particle on the mesh + ls%p(p)%ind=ls%cfg%get_ijk_global(ls%p(p)%pos,[ls%cfg%imin,ls%cfg%jmin,ls%cfg%kmin]) + ! Assign a unique integer to particle + ls%p(p)%i=p + ! Activate the particle + ls%p(p)%flag=0 + end do + end do + end do + + ! ! Add a rectangular flap extending in +x direction behind the cylinder + ! nx = ceiling(4.0_WP*R/dist) + ! do i=1,nx + ! do j=1,3 + ! do k=1,nz + ! x = (i-1) * dist + (R) + ! y = (j-2) * dist + ! z = (k-1) * dist - Lz/2.0_WP + ! p = p+1 + ! ls%p(p)%pos(1) = x + ! ls%p(p)%pos(2) = y + ! ls%p(p)%pos(3) = z + ! ls%p(p)%ipos = ls%p(p)%pos + ! ls%p(p)%displacement= 0.0_WP + ! ls%p(p)%vol = dist*dist*dist + ! ls%p(p)%id = 1 + ! ls%p(p)%vel = [0.0_WP,0.0_WP,0.0_WP] + ! net_vol = net_vol + ls%p(p)%vol + ! ls%p(p)%Abond = 0.0_WP + ! ls%p(p)%Afluid = 0.0_WP + ! ls%p(p)%ind = ls%cfg%get_ijk_global(ls%p(p)%pos,[ls%cfg%imin,ls%cfg%jmin,ls%cfg%kmin]) + ! ls%p(p)%i = p + ! ls%p(p)%flag = 0 + ! end do + ! end do + ! end do + np = p + print*, "Nx: ", nx + print*, "Ny: ", ny + print*, "Nz: ", nz + print*, "Net Force Volume", net_vol + end block read_bin + end if + + ! Communicate particles + call ls%sync() + + + + + + ! Get initial volume fraction + call ls%update_VF() + + ! Initalize bonds + call ls%bond_init() + call ls%get_bond_force() + call ls%sync() + + if (ls%cfg%amRoot) then + print*,"===== Solid Setup Description =====" + print*,'Number of particles', np + print*,'Maximum stretching =',max_stretch + end if + + end block initialize_lss + + ! Create partmesh object for visualizing Lagrangian particles + create_pmesh: block + use lss_class, only: max_bond + integer :: i,n,nbond + pmesh=partmesh(nvar=5,nvec=7,name='solid') + pmesh%varname(1)='failfrac' + pmesh%varname(2)='id' + pmesh%varname(3)='nbond' + pmesh%varname(4)='von-Mises' + pmesh%varname(5)='correcMag' + + + pmesh%vecname(1)='velocity' + pmesh%vecname(2)='bond_force' + pmesh%vecname(3)='disp' + pmesh%vecname(4)='t1' + pmesh%vecname(5)='t2' + pmesh%vecname(6)='tc' + pmesh%vecname(7)='Afluid' + + call ls%update_partmesh(pmesh) + do i=1,ls%np_ + pmesh%var(1,i)=0.0_WP + nbond=0 + do n=1,max_bond + if (ls%p(i)%ibond(n).gt.0) nbond=nbond+1 + end do + if (ls%p(i)%nbond.gt.0) then + pmesh%var(1,i)=1.0_WP-real(nbond,WP)/real(ls%p(i)%nbond,WP) + else + pmesh%var(1,i)=0.0_WP + end if + pmesh%var(2,i) =ls%p(i)%id + pmesh%vec(:,1,i)=ls%p(i)%vel + pmesh%vec(:,2,i)=ls%p(i)%Abond*ls%rho*ls%p(i)%vol + pmesh%var(3,i) =ls%p(i)%nbond + pmesh%var(4,i) =ls%p(i)%vonMises + pmesh%var(5,i) =ls%p(i)%correcMag + pmesh%vec(:,3,i) =ls%p(i)%displacement + pmesh%vec(:,4,i) =ls%p(i)%t1 + pmesh%vec(:,5,i) =ls%p(i)%t2 + pmesh%vec(:,6,i) =ls%p(i)%tc + pmesh%vec(:,7,i) =ls%p(i)%Afluid + + + end do + end block create_pmesh + + + ! Create a flow solver with inflow-outflow + create_flow_solver: block + use incomp_class, only: dirichlet,clipped_neumann + real(WP) :: visc + ! Create flow solver + fs=incomp(cfg=cfg,name='Incompressible NS') + ! Set the flow properties + call param_read('Density',fs%rho) + call param_read('Dynamic viscosity',visc); fs%visc=visc + ! Define boundary conditions + call fs%add_bcond(name='inflow', type=dirichlet ,locator=left_of_domain ,face='x',dir=-1,canCorrect=.false.) + call fs%add_bcond(name='outflow',type=clipped_neumann,locator=right_of_domain,face='x',dir=+1,canCorrect=.true. ) + ! Configure pressure solver + ps=fft2d(cfg=cfg,name='Pressure',nst=7) + ! Configure implicit velocity solver + vs=ddadi(cfg=cfg,name='Velocity',nst=7) + ! Setup the solver + call fs%setup(pressure_solver=ps,implicit_solver=vs) + end block create_flow_solver + + + ! Initialize our velocity field + initialize_velocity: block + use random, only: random_normal + use incomp_class, only: bcond + type(bcond), pointer :: mybc + integer :: n,i,j,k + real(WP) :: Uin + ! Read inflow velocity + call param_read('Inlet velocity',Uin) + ! IB arrays + Uib=0.0_WP; Vib=0.0_WP; Wib=0.0_WP; srcM=0.0_WP + ! Make initial velocity field random to trigger transition + do k=fs%cfg%kmin_,fs%cfg%kmax_ + do j=fs%cfg%jmin_,fs%cfg%jmax_ + do i=fs%cfg%imin_,fs%cfg%imax_ + fs%U(i,j,k)=0.0_WP + fs%V(i,j,k)=0.0_WP + fs%W(i,j,k)=0.0_WP + end do + end do + end do + call fs%cfg%sync(fs%U) + call fs%cfg%sync(fs%V) + call fs%cfg%sync(fs%W) + ! Set inflow velocity + call fs%get_bcond('inflow',mybc) + do n=1,mybc%itr%no_ + i=mybc%itr%map(1,n); j=mybc%itr%map(2,n); k=mybc%itr%map(3,n) + fs%U(i,j,k)=Uin + end do + ! Compute MFR through all boundary conditions + call fs%get_mfr() + ! Adjust MFR for global mass balance + call fs%correct_mfr(src=srcM) + ! Compute cell-centered velocity + call fs%interp_vel(Ui,Vi,Wi) + ! Compute divergence + resU=srcM/fs%rho !< Careful, we need to provide + call fs%get_div(src=resU) !< a volume source term to div + + end block initialize_velocity + + + ! Add Ensight output + create_ensight: block + ! Create Ensight output from cfg + ens_out=ensight(cfg=cfg,name='cylinder') + ! Create event for Ensight output + ens_evt=event(time=time,name='Ensight output') + call param_read('Ensight output period',ens_evt%tper) + ! Add variables to output + call ens_out%add_particle('particles',pmesh) + call ens_out%add_scalar('divergence',fs%div) + call ens_out%add_vector('velocity',Ui,Vi,Wi) + call ens_out%add_vector('velocity_s',Uib,Vib,Wib) + call ens_out%add_scalar('pressure',fs%P) + call ens_out%add_scalar('VFs',ls%VF) + ! Output to ensight + if (ens_evt%occurs()) call ens_out%write_data(time%t) + end block create_ensight + + + ! Create a monitor file + create_monitor: block + ! Prepare some info about fields + call fs%get_cfl(time%dt,time%cfl) + call fs%get_max() + ! Create simulation monitor + mfile=monitor(fs%cfg%amRoot,'simulation') + call mfile%add_column(time%n,'Timestep number') + call mfile%add_column(time%t,'Time') + call mfile%add_column(time%dt,'Timestep size') + call mfile%add_column(time%cfl,'Maximum CFL') + call mfile%add_column(fs%Umax,'Umax') + call mfile%add_column(fs%Vmax,'Vmax') + call mfile%add_column(fs%Wmax,'Wmax') + call mfile%add_column(fs%Pmax,'Pmax') + call mfile%add_column(fs%divmax,'Maximum divergence') + call mfile%add_column(fs%psolv%it,'Pressure iteration') + call mfile%add_column(fs%psolv%rerr,'Pressure error') + call mfile%write() + ! Create CFL monitor + cflfile=monitor(fs%cfg%amRoot,'cfl') + call cflfile%add_column(time%n,'Timestep number') + call cflfile%add_column(time%t,'Time') + call cflfile%add_column(fs%CFLc_x,'Convective xCFL') + call cflfile%add_column(fs%CFLc_y,'Convective yCFL') + call cflfile%add_column(fs%CFLc_z,'Convective zCFL') + call cflfile%add_column(fs%CFLv_x,'Viscous xCFL') + call cflfile%add_column(fs%CFLv_y,'Viscous yCFL') + call cflfile%add_column(fs%CFLv_z,'Viscous zCFL') + call cflfile%write() + ! Create solid monitor + sfile=monitor(ls%cfg%amRoot,'solid') + call sfile%add_column(time%n,'Timestep number') + call sfile%add_column(time%t,'Time') + call sfile%add_column(ls_dt,'Particle dt') + call sfile%add_column(time%cfl,'Maximum CFL') + call sfile%add_column(ls%np,'Particle number') + call sfile%add_column(ls%VFmax,'VFmax') + call sfile%add_column(ls%Umin,'Particle Umin') + call sfile%add_column(ls%Umax,'Particle Umax') + call sfile%add_column(ls%Vmin,'Particle Vmin') + call sfile%add_column(ls%Vmax,'Particle Vmax') + call sfile%add_column(ls%Wmin,'Particle Wmin') + call sfile%add_column(ls%Wmax,'Particle Wmax') + call sfile%add_column(ls%ibmForce(1),'Particle Fx') + call sfile%add_column(ls%ibmForce(2),'Particle Fy') + call sfile%add_column(ls%ibmForce(3),'Particle Fz') + call sfile%write() + end block create_monitor + + + end subroutine simulation_init + + + !> Perform an NGA2 simulation - this mimicks NGA's old time integration for multiphase + subroutine simulation_run + implicit none + real(WP) :: cfl + + ! Perform time integration + do while (.not.time%done()) + + ! Increment time + call ls%get_cfl(time%dt,time%cfl) + call fs%get_cfl(time%dt,cfl) + call fs%get_cfl(time%dt,cfl); time%cfl=max(time%cfl,cfl) + call time%adjust_dt() + call time%increment() + + ! Advance solid solver + solid: block + real(WP) :: dt_done,mydt + ! Compute divergence of fluid stress + call fs%get_div_stress(divx=div_x(:,:,:),divy=div_y(:,:,:),divz=div_z(:,:,:)) + ! Sub-iteratore + call ls%get_cfl(ls_dt,cfl=cfl) + if (cfl.gt.0.0_WP) ls_dt=min(ls_dt*time%cflmax/cfl,ls_dt_max) + dt_done=0.0_WP + do while (dt_done.lt.time%dtmid) + ! Decide the timestep size + mydt=min(ls_dt,time%dtmid-dt_done) + ! Advance particles + call ls%advance(dt =mydt, & + & stress_x=div_x(:,:,:),& + & stress_y=div_y(:,:,:),& + & stress_z=div_z(:,:,:)) + ! Increment + dt_done=dt_done+mydt + end do + end block solid + + + ! Evaluate IB velocity and mass source + calc_ib_velocity: block + integer :: i,j,k + do k=fs%cfg%kmin_,fs%cfg%kmax_ + do j=fs%cfg%jmin_,fs%cfg%jmax_ + do i=fs%cfg%imin_,fs%cfg%imax_ + ! VF based velocity + Uib(i,j,k)=ls%VFU(i,j,k)/(sum(fs%itpr_x(:,i,j,k)*cfg%VF(i-1:i,j,k))+epsilon(1.0_WP)) + Vib(i,j,k)=ls%VFV(i,j,k)/(sum(fs%itpr_y(:,i,j,k)*cfg%VF(i,j-1:j,k))+epsilon(1.0_WP)) + Wib(i,j,k)=ls%VFW(i,j,k)/(sum(fs%itpr_z(:,i,j,k)*cfg%VF(i,j,k-1:k))+epsilon(1.0_WP)) + end do + end do + end do + call cfg%sync(Uib) + call cfg%sync(Vib) + call cfg%sync(Wib) + ! Compute IB mass source + do k=fs%cfg%kmin_,fs%cfg%kmax_ + do j=fs%cfg%jmin_,fs%cfg%jmax_ + do i=fs%cfg%imin_,fs%cfg%imax_ + srcM(i,j,k)=fs%rho*(ls%VF(i,j,k)*sum(fs%divp_x(:,i,j,k)*Uib(i:i+1,j,k))+& + & sum(fs%divp_y(:,i,j,k)*Vib(i,j:j+1,k))+& + & sum(fs%divp_z(:,i,j,k)*Wib(i,j,k:k+1))) + end do + end do + end do + call cfg%sync(srcM) + end block calc_ib_velocity + + + ! Remember old velocity + fs%Uold=fs%U + fs%Vold=fs%V + fs%Wold=fs%W + + ! Perform sub-iterations + do while (time%it.le.time%itmax) + + ! Build mid-time velocity + fs%U=0.5_WP*(fs%U+fs%Uold) + fs%V=0.5_WP*(fs%V+fs%Vold) + fs%W=0.5_WP*(fs%W+fs%Wold) + + ! Explicit calculation of drho*u/dt from NS + call fs%get_dmomdt(resU,resV,resW) + + ! Assemble explicit residual + resU=-2.0_WP*(fs%rho*fs%U-fs%rho*fs%Uold)+time%dt*resU + resV=-2.0_WP*(fs%rho*fs%V-fs%rho*fs%Vold)+time%dt*resV + resW=-2.0_WP*(fs%rho*fs%W-fs%rho*fs%Wold)+time%dt*resW + + ! Form implicit residuals + call fs%solve_implicit(time%dt,resU,resV,resW) + + ! Apply these residuals + fs%U=2.0_WP*fs%U-fs%Uold+resU + fs%V=2.0_WP*fs%V-fs%Vold+resV + fs%W=2.0_WP*fs%W-fs%Wold+resW + + ! Apply direct IB forcing + ibforcing: block + integer :: i,j,k + do k=fs%cfg%kmin_,fs%cfg%kmax_; do j=fs%cfg%jmin_,fs%cfg%jmax_; do i=fs%cfg%imin_,fs%cfg%imax_ + fs%U(i,j,k)=(1.0_WP-sum(fs%itpr_x(:,i,j,k)*ls%VF(i-1:i,j,k)))*fs%U(i,j,k)+ls%VFU(i,j,k) + fs%V(i,j,k)=(1.0_WP-sum(fs%itpr_y(:,i,j,k)*ls%VF(i,j-1:j,k)))*fs%V(i,j,k)+ls%VFV(i,j,k) + fs%W(i,j,k)=(1.0_WP-sum(fs%itpr_z(:,i,j,k)*ls%VF(i,j,k-1:k)))*fs%W(i,j,k)+ls%VFW(i,j,k) + end do; end do; end do + call fs%cfg%sync(fs%U) + call fs%cfg%sync(fs%V) + call fs%cfg%sync(fs%W) + end block ibforcing + + ! Apply other boundary conditions + call fs%apply_bcond(time%t,time%dt) + + ! Solve Poisson equation + call fs%correct_mfr(src=srcM) + resU=srcM/fs%rho !< Careful, we need to provide + call fs%get_div(src=resU) !< a volume source term to div + fs%psolv%rhs=-fs%cfg%vol*fs%div*fs%rho/time%dt + fs%psolv%sol=0.0_WP + call fs%psolv%solve() + call fs%shift_p(fs%psolv%sol) + + ! Correct velocity + call fs%get_pgrad(fs%psolv%sol,resU,resV,resW) + fs%P=fs%P+fs%psolv%sol + fs%U=fs%U-time%dt*resU/fs%rho + fs%V=fs%V-time%dt*resV/fs%rho + fs%W=fs%W-time%dt*resW/fs%rho + + ! Increment sub-iteration counter + time%it=time%it+1 + + end do + + ! Recompute interpolated velocity and divergence + call fs%interp_vel(Ui,Vi,Wi) + resU=srcM/fs%rho !< Careful, we need to provide + call fs%get_div(src=resU) !< a volume source term to div + + ! Output to ensight + if (ens_evt%occurs()) then + update_pmesh: block + use lss_class, only: max_bond + integer :: i,n,nbond + call ls%update_partmesh(pmesh) + do i=1,ls%np_ + nbond=0 + do n=1,max_bond + if (ls%p(i)%ibond(n).gt.0) nbond=nbond+1 + end do + if (ls%p(i)%nbond.gt.0) then + pmesh%var(1,i)=1.0_WP-real(nbond,WP)/real(ls%p(i)%nbond,WP) + else + pmesh%var(1,i)=0.0_WP + end if + pmesh%var(2,i) =ls%p(i)%id + pmesh%vec(:,1,i)=ls%p(i)%vel + pmesh%vec(:,2,i)=ls%p(i)%Abond*ls%rho*ls%p(i)%vol + pmesh%var(3,i) =ls%p(i)%nbond + pmesh%var(4,i) =ls%p(i)%vonMises + pmesh%var(5,i) =ls%p(i)%correcMag + pmesh%vec(:,3,i) =ls%p(i)%displacement + pmesh%vec(:,4,i) =ls%p(i)%t1 + pmesh%vec(:,5,i) =ls%p(i)%t2 + pmesh%vec(:,6,i) =ls%p(i)%tc + pmesh%vec(:,7,i) =ls%p(i)%Afluid + end do + end block update_pmesh + call ens_out%write_data(time%t) + end if + + ! Perform and output monitoring + call fs%get_max() + call mfile%write() + call cflfile%write() + call sfile%write() + + end do + + end subroutine simulation_run + + + !> Finalize the NGA2 simulation + subroutine simulation_final + implicit none + + ! Get rid of all objects - need destructors + ! monitor + ! ensight + ! bcond + ! timetracker + + ! Deallocate work arrays + deallocate(div_x,div_y,div_z,resU,resV,resW,Ui,Vi,Wi,Uib,Vib,Wib,srcM,gradU) + + end subroutine simulation_final + + +end module simulation diff --git a/examples/peridynamics_shock/GNUmakefile b/examples/peridynamics_shock/GNUmakefile index cdfff2dfd..23c4d3dba 100644 --- a/examples/peridynamics_shock/GNUmakefile +++ b/examples/peridynamics_shock/GNUmakefile @@ -1,12 +1,13 @@ # NGA location if not yet defined -NGA_HOME ?= ../.. +NGA_HOME ?= ~/nga2/Repositories/nga2 # Compilation parameters PRECISION = DOUBLE USE_MPI = TRUE -USE_FFTW = FALSE -USE_HYPRE = FALSE -USE_LAPACK= FALSE +USE_HYPRE = TRUE +USE_LAPACK= TRUE +USE_FFTW = TRUE +USE_IRL = FALSE PROFILE = FALSE DEBUG = FALSE COMP = gnu @@ -23,13 +24,14 @@ INCLUDE_LOCATIONS += $(Ulocs) VPATH_LOCATIONS += $(Ulocs) # External libraries are defined in .profile/.bashrc/.zshrc, but could be defined here as well +HYPRE_DIR=/Users/imauser/nga2/Repositories/hypre/src/hypre +FFTW_DIR=/opt/homebrew/Cellar/fftw/3.3.10_2 # NGA compilation definitions include $(NGA_HOME)/tools/GNUMake/Make.defs # Include NGA base code -Bdirs := core data solver config grid libraries -#Bdirs := core data config grid libraries +Bdirs := constant_density particles core data transform solver config grid libraries Bpack += $(foreach dir, $(Bdirs), $(NGA_HOME)/src/$(dir)/Make.package) include $(Bpack) diff --git a/examples/peridynamics_shock/README b/examples/peridynamics_shock/README index 4ed9dd2bb..a82a2a789 100644 --- a/examples/peridynamics_shock/README +++ b/examples/peridynamics_shock/README @@ -1 +1,3 @@ -Coupling peridynamics with the compressible solver to simulate shock-induced breakup. +(6/30/26 8:09 PM: +Switched it over to RK4, was RK2. +Have previously run with element.bin files, probably should change this over to be using a uniform grid. diff --git a/examples/peridynamics_shock/input b/examples/peridynamics_shock/input index ac58a741e..3abb56f93 100644 --- a/examples/peridynamics_shock/input +++ b/examples/peridynamics_shock/input @@ -1,33 +1,37 @@ # Parallelization -Partition : 2 2 1 +Partition : 2 2 2 # Mesh definition Lx : 10 Ly : 6 -Lz : 3 -nx : 200 -ny : 120 +Lz : 6 +nx : 100 +ny : 60 nz : 60 -# Time integration -Max timestep size : 1e-2 -Max cfl number : 0.9 -Max time : 100 +# Case definition +Cylinder radius : 0.5 +# STL file : sphere.stl +Particle file: element_data_10.bin # Adimensional flow parameters Gamma : 1.4 Prandtl number : 0.71 -Shock Mach number : 3 -Shock location : -0.5 -Reynolds number : 5000 +Shock Mach number : 1.22 +Shock location : -1.5 +Reynolds number : 4.99e5 # Solid properties -Initial Solid Angle : 20 -Particle timestep size : 1e-2 -Elastic Modulus : 20 +Solid dx : 0.037750 +Elastic Modulus : 1000 Poisson Ratio : 0.25 -Solid density : 10 -Critical Energy Release Rate : .01 +Solid density : 1000 +Critical Energy Release Rate : 0.125 + +# Time integration +Max timestep size : 2e-3 +Max cfl number : 0.9 +Max time : 2.125 # Ensight output -Ensight output period : 0.1 \ No newline at end of file +Ensight output period : 0.125 diff --git a/examples/peridynamics_shock/src/geometry.f90 b/examples/peridynamics_shock/src/geometry.f90 index b05c308c1..396fd49e3 100644 --- a/examples/peridynamics_shock/src/geometry.f90 +++ b/examples/peridynamics_shock/src/geometry.f90 @@ -35,7 +35,7 @@ subroutine geometry_init ! Create simple rectilinear grid do i=1,nx+1 - x(i)=real(i-1,WP)/real(nx,WP)*Lx-0.25_WP*Lx + x(i)=real(i-1,WP)/real(nx,WP)*Lx-0.5_WP*Lx end do do j=1,ny+1 y(j)=real(j-1,WP)/real(ny,WP)*Ly-0.5_WP*Ly @@ -44,7 +44,7 @@ subroutine geometry_init z(k)=real(k-1,WP)/real(nz,WP)*Lz-0.5_WP*Lz end do - ! General serial grid object + ! General serial grid object (no=3 needed to support ghost/image point interpolation/extrapolation) grid=sgrid(coord=cartesian,no=2,x=x,y=y,z=z,xper=.false.,yper=.true.,zper=.true.,name='box') end block create_grid diff --git a/examples/peridynamics_shock/src/lss_class.f90 b/examples/peridynamics_shock/src/lss_class.f90 index 99a8348a7..1c990fc06 100644 --- a/examples/peridynamics_shock/src/lss_class.f90 +++ b/examples/peridynamics_shock/src/lss_class.f90 @@ -712,9 +712,9 @@ subroutine advance(this,dt,stress_x,stress_y,stress_z) ! Advance velocity only based on new force do n=1,this%np_ ! Advance with Verlet scheme - if (this%p(n)%id.le.-1) cycle stress=this%cfg%get_velocity(pos=this%p(n)%pos,i0=this%p(n)%ind(1),j0=this%p(n)%ind(2),k0=this%p(n)%ind(3),U=stress_x,V=stress_y,W=stress_z) this%p(n)%Afluid=stress/this%rho + if (this%p(n)%id.le.-1) cycle this%p(n)%vel=this%p(n)%vel+0.5_WP*dt*(this%gravity+this%p(n)%Abond+this%p(n)%Afluid) end do diff --git a/examples/peridynamics_shock/src/simulation.f90 b/examples/peridynamics_shock/src/simulation.f90 index a8e113451..54f22c2f0 100644 --- a/examples/peridynamics_shock/src/simulation.f90 +++ b/examples/peridynamics_shock/src/simulation.f90 @@ -28,8 +28,8 @@ module simulation public :: simulation_init,simulation_run,simulation_final !> Private work arrays - real(WP), dimension(:,:,:,:), allocatable :: dQdt - real(WP), dimension(:,:,:) , allocatable :: Ui,Vi,Wi,Ma,beta,visc,visc_t,div + real(WP), dimension(:,:,:,:,:), allocatable :: dQdt + real(WP), dimension(:,:,:) , allocatable :: Ui,Vi,Wi,Ma,beta,visc,visc_t,div !> Post-shock viscosity and temperature real(WP) :: visc0,T0 @@ -44,7 +44,6 @@ module simulation real(WP) :: Re !> Max timestep size for solid solver - integer :: ls_it real(WP) :: ls_dt,ls_dt_max contains @@ -292,7 +291,7 @@ subroutine simulation_init ! Allocate work arrays allocate_work_arrays: block - allocate(dQdt (cfg%imino_:cfg%imaxo_,cfg%jmino_:cfg%jmaxo_,cfg%kmino_:cfg%kmaxo_,1:fs%nQ)) + allocate(dQdt (cfg%imino_:cfg%imaxo_,cfg%jmino_:cfg%jmaxo_,cfg%kmino_:cfg%kmaxo_,1:fs%nQ,1:4)) allocate(Ui (cfg%imino_:cfg%imaxo_,cfg%jmino_:cfg%jmaxo_,cfg%kmino_:cfg%kmaxo_)) allocate(Vi (cfg%imino_:cfg%imaxo_,cfg%jmino_:cfg%jmaxo_,cfg%kmino_:cfg%kmaxo_)) allocate(Wi (cfg%imino_:cfg%imaxo_,cfg%jmino_:cfg%jmaxo_,cfg%kmino_:cfg%kmaxo_)) @@ -304,6 +303,57 @@ subroutine simulation_init end block allocate_work_arrays + ! Initialize eos and flow parameters + initialize_parameters: block + use string, only: str_long + use messager, only: log + use param, only: param_read + character(str_long) :: message + ! Set Pinf to zero + Pinf=0.0_WP + ! Read in Gamma + call param_read('Gamma',Gamma) + ! Read in Prandtl number + call param_read('Prandtl number',Prandtl) + ! Read in shock Mach number and location + call param_read('Shock Mach number',Ms) + call param_read('Shock location',Xs) + ! First generate static shock with normalized pre-shock conditions + M1=Ms + rho1=1.0_WP + rho2=rho1*(Gamma+1.0_WP)*M1**2/((Gamma-1.0_WP)*M1**2+2.0_WP) + p1=0.25_WP*rho1/Gamma*((Gamma+1.0_WP)*M1/(M1**2-1.0_WP))**2 ! Ensures that |u2-u1|=1 + p2=p1*(2.0_WP*Gamma/(Gamma+1.0_WP)*(M1**2-1.0_WP)+1.0_WP) + u1=M1*sqrt(Gamma*p1/rho1) + u2=u1*rho1/rho2 + ! Now shift frame of reference to obtain moving shock + u2=abs(u2-u1); M2=u2/sqrt(Gamma*p2/rho2); u1=0.0_WP; M1=u1/sqrt(Gamma*p1/rho1) + ! Set heat capacities corresponding to a normalized pre-shock + Cv=(p1+Pinf)/(rho1*(Gamma-1.0_WP)) + ! Get reference temperature based on post-shock conditions + T0=get_T(rho2,p2) + ! Define viscosity based on post-shock Reynolds number + call param_read('Cylinder radius',Rcyl) + call param_read('Reynolds number',Re); visc0=rho2*2.0_WP*Rcyl*u2/Re + ! Output case info + if (cfg%amRoot) then + write(message,'("[Gas EOS] => Gamma=",es12.5)') Gamma; call log(message) + write(message,'("[Gas EOS] => Cv=",es12.5)') Cv; call log(message) + write(message,'("[Shock Mach number] => Ms=",es12.5)') Ms; call log(message) + write(message,'("[Pre -shock conditions] => rho1=",es12.5)') rho1; call log(message) + write(message,'("[Pre -shock conditions] => p1=",es12.5)') p1; call log(message) + write(message,'("[Pre -shock conditions] => u1=",es12.5)') u1; call log(message) + write(message,'("[Pre -shock conditions] => M1=",es12.5)') M1; call log(message) + write(message,'("[Post-shock conditions] => rho2=",es12.5)') rho2; call log(message) + write(message,'("[Post-shock conditions] => p2=",es12.5)') p2; call log(message) + write(message,'("[Post-shock conditions] => u2=",es12.5)') u2; call log(message) + write(message,'("[Post-shock conditions] => M2=",es12.5)') M2; call log(message) + write(message,'("[Gas Reynolds] => Re=",es12.5)') Re; call log(message) + write(message,'("[Gas viscosity] => mu=",es12.5)') visc0; call log(message) + end if + end block initialize_parameters + + ! Initialize time tracker with 2 subiterations initialize_timetracker: block time=timetracker(amRoot=cfg%amRoot) @@ -317,9 +367,9 @@ subroutine simulation_init ! Initialize Lagrangian solid solver initialize_lss: block - use mathtools, only: Pi - real(WP) :: mu,kk,max_stretch,dx,theta - integer :: np + real(WP) :: dx,mu,kk,max_stretch,Lx,Ly,Lz + real(WP) :: xmin,xmax,ymin,ymax,zmin,zmax + integer :: np,nt type triangle_type real(WP), dimension(3) :: norm real(WP), dimension(3) :: v1 @@ -336,91 +386,50 @@ subroutine simulation_init call param_read('Poisson Ratio',ls%poisson_ratio) call param_read('Solid density',ls%rho) call param_read('Critical Energy Release Rate',ls%crit_energy) - call param_read('Initial Solid Angle',theta,default=0.0_WP) ! Maximum timestep size used for particles call param_read('Particle timestep size',ls_dt_max,default=huge(1.0_WP)) ls_dt=min(ls_dt_max,time%dtmax) - ls_it=0 ! Discretization - !ls%delta=fs%cfg%min_meshsize - - ! Discretization - dx=fs%cfg%min_meshsize/3.0_WP - ls%delta=3.0_WP*dx + ls%delta=fs%cfg%min_meshsize ! Output some info on stretch mu=ls%elastic_modulus/(2.0_WP+2.0_WP*ls%poisson_ratio) kk=ls%elastic_modulus/(3.0_WP-6.0_WP*ls%poisson_ratio) - if (fs%cfg%nx.eq.1.or.fs%cfg%ny.eq.1.or.fs%cfg%nz.eq.1) then - max_stretch=sqrt(ls%crit_energy/((6.0_WP*mu/Pi+16.0_WP/(9.0_WP*Pi**2)*(kk-2.0_WP*mu))*ls%delta)) - else - max_stretch=sqrt(ls%crit_energy/((3.0_WP*mu+(kk-5.0_WP*mu/3.0_WP)*0.75_WP**4)*ls%delta)) - end if + max_stretch=sqrt(ls%crit_energy/((3.0_WP*mu+(kk-5.0_WP*mu/3.0_WP)*0.75_WP**4)*ls%delta)) - ! First object ===================== - object1: block - use mpi_f08, only: MPI_BCAST - use parallel, only: MPI_REAL_WP - integer :: i,j,k,nx,ny,nz,iunit,ierr - real(WP) :: Lx,Ly,Lz,xr,yr - real(WP), dimension(:), allocatable :: x,y,z - if (ls%cfg%amRoot) then - ! Object size - Lx=0.5_WP; Ly=0.5_WP; Lz=0.5_WP - Rcyl=Lx - ! Create simple rectilinear grid - nx=int(Lx/dx) - ny=int(Ly/dx) - nz=int(Lz/dx) - allocate(x(1:nx),y(1:ny),z(1:nz)) - do i=1,nx - x(i)=real(i-1,WP)*dx+0.5_WP*dx - end do - do j=1,ny - y(j)=real(j-1,WP)*dx-0.5_WP*Ly+0.5_WP*dx - end do - do k=1,nz - z(k)=real(k-1,WP)*dx-0.5_WP*Lz+0.5_WP*dx - end do - ! Set angle of cube - theta=theta*Pi/180.0_WP - ! Loop over mesh and create particles - np=0 - do k=1,nz - do j=1,ny - do i=1,nx - ! Increment particle - np=np+1 - call ls%resize(np) - ! Set position - xr=x(i)*cos(theta)-y(j)*sin(theta) - yr=x(i)*sin(theta)+y(j)*cos(theta) - ls%p(np)%pos=[xr,yr,z(k)] - ! Set object id and velocity - ls%p(np)%id=1 - ls%p(np)%vel=0.0_WP - ! Set object volume - ls%p(np)%vol=dx**3 - ! Zero out force - ls%p(np)%Abond=0.0_WP - ls%p(np)%Afluid=0.0_WP - ! Locate the particle on the mesh - ls%p(np)%ind=ls%cfg%get_ijk_global(ls%p(np)%pos,[ls%cfg%imin,ls%cfg%jmin,ls%cfg%kmin]) - ! Assign a unique integer to particle - ls%p(np)%i=np - ! Activate the particle - ls%p(np)%flag=0 - end do - end do + ! Only root process initializes solid particles + if (ls%cfg%amRoot) then + ! Read the STL file and get domain extents and levelset + read_bin: block + use messager, only: die + integer :: p,iunit,ierr + character(len=80) :: partfile + call param_read('Particle file',partfile) + open(newunit=iunit,file=trim(partfile),access="stream",form="unformatted",action="read",status="old",iostat=ierr) + if(ierr.ne.0) call die('[read_stl] Could not open file: '//trim(partfile)) + read(iunit) np + call ls%resize(np) + do p=1,np + read(iunit) ls%p(p)%pos(1), ls%p(p)%pos(2), ls%p(p)%pos(3), ls%p(p)%vol + ! Set object id and velocity + ls%p(p)%id=-2 + ls%p(p)%vel=0.0_WP + ! Zero out force + ls%p(p)%Abond=0.0_WP + ls%p(p)%Afluid=0.0_WP + ! Locate the particle on the mesh + ls%p(p)%ind=ls%cfg%get_ijk_global(ls%p(p)%pos,[ls%cfg%imin,ls%cfg%jmin,ls%cfg%kmin]) + ! Assign a unique integer to particle + ls%p(p)%i=p + ! Activate the particle + ls%p(p)%flag=0 end do - deallocate(x,y,z) - end if - ! Communicate radius - call MPI_BCAST(Rcyl,1,MPI_REAL_WP,0,cfg%comm,ierr) - end block object1 - + close(iunit) + end block read_bin + end if + ! Communicate particles call ls%sync() @@ -433,63 +442,12 @@ subroutine simulation_init if (ls%cfg%amRoot) then print*,"===== Solid Setup Description =====" print*,'Number of particles', np - print*,'Maximum stretching',max_stretch - print*,'Min particle spacing',ls%min_dist + print*,'Maximum stretching =',max_stretch end if end block initialize_lss - ! Initialize eos and flow parameters - initialize_parameters: block - use string, only: str_long - use messager, only: log - use param, only: param_read - character(str_long) :: message - ! Set Pinf to zero - Pinf=0.0_WP - ! Read in Gamma - call param_read('Gamma',Gamma) - ! Read in Prandtl number - call param_read('Prandtl number',Prandtl) - ! Read in shock Mach number and location - call param_read('Shock Mach number',Ms) - call param_read('Shock location',Xs) - ! First generate static shock with normalized pre-shock conditions - M1=Ms - rho1=1.0_WP - rho2=rho1*(Gamma+1.0_WP)*M1**2/((Gamma-1.0_WP)*M1**2+2.0_WP) - p1=0.25_WP*rho1/Gamma*((Gamma+1.0_WP)*M1/(M1**2-1.0_WP))**2 ! Ensures that |u2-u1|=1 - p2=p1*(2.0_WP*Gamma/(Gamma+1.0_WP)*(M1**2-1.0_WP)+1.0_WP) - u1=M1*sqrt(Gamma*p1/rho1) - u2=u1*rho1/rho2 - ! Now shift frame of reference to obtain moving shock - u2=abs(u2-u1); M2=u2/sqrt(Gamma*p2/rho2); u1=0.0_WP; M1=u1/sqrt(Gamma*p1/rho1) - ! Set heat capacities corresponding to a normalized pre-shock - Cv=(p1+Pinf)/(rho1*(Gamma-1.0_WP)) - ! Get reference temperature based on post-shock conditions - T0=get_T(rho2,p2) - ! Define viscosity based on post-shock Reynolds number - call param_read('Reynolds number',Re); visc0=rho2*2.0_WP*Rcyl*u2/Re - ! Output case info - if (cfg%amRoot) then - write(message,'("[Gas EOS] => Gamma=",es12.5)') Gamma; call log(message) - write(message,'("[Gas EOS] => Cv=",es12.5)') Cv; call log(message) - write(message,'("[Shock Mach number] => Ms=",es12.5)') Ms; call log(message) - write(message,'("[Pre -shock conditions] => rho1=",es12.5)') rho1; call log(message) - write(message,'("[Pre -shock conditions] => p1=",es12.5)') p1; call log(message) - write(message,'("[Pre -shock conditions] => u1=",es12.5)') u1; call log(message) - write(message,'("[Pre -shock conditions] => M1=",es12.5)') M1; call log(message) - write(message,'("[Post-shock conditions] => rho2=",es12.5)') rho2; call log(message) - write(message,'("[Post-shock conditions] => p2=",es12.5)') p2; call log(message) - write(message,'("[Post-shock conditions] => u2=",es12.5)') u2; call log(message) - write(message,'("[Post-shock conditions] => M2=",es12.5)') M2; call log(message) - write(message,'("[Gas Reynolds] => Re=",es12.5)') Re; call log(message) - write(message,'("[Gas viscosity] => mu=",es12.5)') visc0; call log(message) - end if - end block initialize_parameters - - ! Create partmesh object for visualizing Lagrangian particles create_pmesh: block use lss_class, only: max_bond @@ -497,7 +455,7 @@ subroutine simulation_init pmesh=partmesh(nvar=3,nvec=2,name='solid') pmesh%varname(1)='failfrac' pmesh%varname(2)='dilatation' - pmesh%varname(3)='volume' + pmesh%varname(3)='flag' pmesh%vecname(1)='velocity' pmesh%vecname(2)='bond_force' call ls%update_partmesh(pmesh) @@ -513,7 +471,7 @@ subroutine simulation_init pmesh%var(1,i)=0.0_WP end if pmesh%var(2,i) =ls%p(i)%dil - pmesh%var(3,i) =ls%p(i)%vol + pmesh%var(3,i) =ls%p(i)%flag pmesh%vec(:,1,i)=ls%p(i)%vel pmesh%vec(:,2,i)=ls%p(i)%Abond end do @@ -549,8 +507,6 @@ subroutine simulation_init Ma=sqrt(Ui**2+Vi**2+Wi**2)/fs%C ! Compute dilatation call get_div() - ! Compute viscosities - call prepare_viscosities() end block initialize_variables @@ -564,7 +520,6 @@ subroutine simulation_init ! Add variables to output call ens_out%add_particle('particles',pmesh) call ens_out%add_vector('velocity',Ui,Vi,Wi) - call ens_out%add_vector('velocity_s',ls%VFU,ls%VFV,ls%VFW) call ens_out%add_scalar('P',fs%P) call ens_out%add_scalar('T',fs%T) call ens_out%add_scalar('Mach',Ma) @@ -615,10 +570,6 @@ subroutine simulation_init call cflfile%add_column(fs%CFLv_x,'Viscous xCFL') call cflfile%add_column(fs%CFLv_y,'Viscous yCFL') call cflfile%add_column(fs%CFLv_z,'Viscous zCFL') - call cflfile%add_column(ls%CFLp_x,'Particle xCFL') - call cflfile%add_column(ls%CFLp_y,'Particle yCFL') - call cflfile%add_column(ls%CFLp_z,'Particle zCFL') - call cflfile%add_column(ls%CFLp_a,'Particle aCFL') call cflfile%write() ! Create conservation monitor consfile=monitor(fs%cfg%amRoot,'conservation') @@ -637,7 +588,6 @@ subroutine simulation_init call sfile%add_column(time%n,'Timestep number') call sfile%add_column(time%t,'Time') call sfile%add_column(ls_dt,'Particle dt') - call sfile%add_column(ls_it,'Particle sub-iter') call sfile%add_column(time%cfl,'Maximum CFL') call sfile%add_column(ls%np,'Particle number') call sfile%add_column(ls%VFmax,'VFmax') @@ -665,7 +615,8 @@ subroutine simulation_run do while (.not.time%done()) ! Increment time - call fs%get_cfl(time%dt,time%cfl) + call ls%get_cfl(time%dt,time%cfl) + call fs%get_cfl(time%dt,cfl); time%cfl=max(time%cfl,cfl) call time%adjust_dt() call time%increment() @@ -673,23 +624,21 @@ subroutine simulation_run solid: block real(WP) :: dt_done,mydt ! Compute divergence of fluid stress - call fs%get_div_stress(divx=dQdt(:,:,:,1),divy=dQdt(:,:,:,2),divz=dQdt(:,:,:,3)) + call fs%get_div_stress(divx=dQdt(:,:,:,1,1),divy=dQdt(:,:,:,2,1),divz=dQdt(:,:,:,3,1)) ! Sub-iteratore call ls%get_cfl(ls_dt,cfl=cfl) if (cfl.gt.0.0_WP) ls_dt=min(ls_dt*time%cflmax/cfl,ls_dt_max) dt_done=0.0_WP - ls_it=0 do while (dt_done.lt.time%dtmid) ! Decide the timestep size mydt=min(ls_dt,time%dtmid-dt_done) ! Advance particles - call ls%advance(dt =mydt, & - & stress_x=dQdt(:,:,:,1),& - & stress_y=dQdt(:,:,:,2),& - & stress_z=dQdt(:,:,:,3)) + call ls%advance(dt =mydt, & + & stress_x=dQdt(:,:,:,1,1),& + & stress_y=dQdt(:,:,:,2,1),& + & stress_z=dQdt(:,:,:,3,1)) ! Increment dt_done=dt_done+mydt - ls_it=ls_it+1 end do end block solid @@ -699,17 +648,49 @@ subroutine simulation_run ! Prepare SGS viscosity models call prepare_viscosities() + ! ! First RK step ==================================================================================== + ! ! Get non-SL RHS and increment + ! call fs%rhs(dQdt(:,:,:,:,1)) + ! fs%Q=fs%Qold+0.5_WP*time%dt*dQdt(:,:,:,:,1) + ! ! Apply IBM + ! call apply_ibm() + + ! ! Second RK step =================================================================================== + ! ! Get non-SL RHS and increment at midpoint + ! call fs%rhs(dQdt(:,:,:,:,2)) + ! fs%Q=fs%Qold+time%dt*dQdt(:,:,:,:,2) + ! ! Apply IBM + ! call apply_ibm() + ! First RK step ==================================================================================== - ! Get RHS and increment - call fs%rhs(dQdt) - fs%Q=fs%Qold+0.5_WP*time%dt*dQdt + ! Get non-SL RHS and increment + call fs%rhs(dQdt(:,:,:,:,1)) + ! Advance + fs%Q=fs%Qold+0.5_WP*time%dt*dQdt(:,:,:,:,1) ! Apply IBM call apply_ibm() ! Second RK step =================================================================================== - ! Get RHS and increment at midpoint - call fs%rhs(dQdt) - fs%Q=fs%Qold+time%dt*dQdt + ! Get non-SL RHS and increment + call fs%rhs(dQdt(:,:,:,:,2)) + ! Advance + fs%Q=fs%Qold+0.5_WP*time%dt*dQdt(:,:,:,:,2) + ! Apply IBM + call apply_ibm() + + ! Third RK step ==================================================================================== + ! Get non-SL RHS and increment + call fs%rhs(dQdt=dQdt(:,:,:,:,3)) + ! Advance + fs%Q=fs%Qold+1.0_WP*time%dt*dQdt(:,:,:,:,3) + ! Apply IBM + call apply_ibm() + + ! Fourth RK step =================================================================================== + ! Get non-SL RHS and increment + call fs%rhs(dQdt(:,:,:,:,4)) + ! Advance + fs%Q=fs%Qold+time%dt/6.0_WP*(dQdt(:,:,:,:,1)+2.0_WP*dQdt(:,:,:,:,2)+2.0_WP*dQdt(:,:,:,:,3)+dQdt(:,:,:,:,4)) ! Apply IBM call apply_ibm() @@ -750,7 +731,7 @@ subroutine simulation_run pmesh%var(1,i)=0.0_WP end if pmesh%var(2,i) =ls%p(i)%dil - pmesh%var(3,i) =ls%p(i)%vol + pmesh%var(3,i) =ls%p(i)%flag pmesh%vec(:,1,i)=ls%p(i)%vel pmesh%vec(:,2,i)=ls%p(i)%Abond end do diff --git a/examples/peridynamics_shock_orig_DELETE/GNUmakefile b/examples/peridynamics_shock_orig_DELETE/GNUmakefile new file mode 100644 index 000000000..cdfff2dfd --- /dev/null +++ b/examples/peridynamics_shock_orig_DELETE/GNUmakefile @@ -0,0 +1,47 @@ +# NGA location if not yet defined +NGA_HOME ?= ../.. + +# Compilation parameters +PRECISION = DOUBLE +USE_MPI = TRUE +USE_FFTW = FALSE +USE_HYPRE = FALSE +USE_LAPACK= FALSE +PROFILE = FALSE +DEBUG = FALSE +COMP = gnu +EXEBASE = nga + +# Directories that contain user-defined code +Udirs := src + +# Include user-defined sources +Upack += $(foreach dir, $(Udirs), $(wildcard $(dir)/Make.package)) +Ulocs += $(foreach dir, $(Udirs), $(wildcard $(dir))) +include $(Upack) +INCLUDE_LOCATIONS += $(Ulocs) +VPATH_LOCATIONS += $(Ulocs) + +# External libraries are defined in .profile/.bashrc/.zshrc, but could be defined here as well + +# NGA compilation definitions +include $(NGA_HOME)/tools/GNUMake/Make.defs + +# Include NGA base code +Bdirs := core data solver config grid libraries +#Bdirs := core data config grid libraries +Bpack += $(foreach dir, $(Bdirs), $(NGA_HOME)/src/$(dir)/Make.package) +include $(Bpack) + +# Inform user of Make.packages used +ifdef Ulocs + $(info Taking user code from: $(Ulocs)) +endif +$(info Taking base code from: $(Bdirs)) + +# Target definition +all: $(executable) + @echo COMPILATION SUCCESSFUL + +# NGA compilation rules +include $(NGA_HOME)/tools/GNUMake/Make.rules diff --git a/examples/peridynamics_shock_orig_DELETE/README b/examples/peridynamics_shock_orig_DELETE/README new file mode 100644 index 000000000..4ed9dd2bb --- /dev/null +++ b/examples/peridynamics_shock_orig_DELETE/README @@ -0,0 +1 @@ +Coupling peridynamics with the compressible solver to simulate shock-induced breakup. diff --git a/examples/peridynamics_shock_orig_DELETE/input b/examples/peridynamics_shock_orig_DELETE/input new file mode 100644 index 000000000..863e9edde --- /dev/null +++ b/examples/peridynamics_shock_orig_DELETE/input @@ -0,0 +1,34 @@ +# Parallelization +Partition : 2 2 1 + +# Mesh definition +Lx : 10 +Ly : 6 +Lz : 3 +nx : 200 +ny : 120 +nz : 60 + +# Time integration +Max timestep size : 1e-2 +Max cfl number : 0.9 +Max time : 100 + +# Adimensional flow parameters +Gamma : 1.4 +Prandtl number : 0.71 +Shock Mach number : 3 +Shock location : -0.5 +Reynolds number : 5000 + +# Solid properties +Initial Solid Angle : 20 +Particle file : element_data.bin +Particle timestep size : 1e-2 +Elastic Modulus : 20 +Poisson Ratio : 0.25 +Solid density : 10 +Critical Energy Release Rate : .01 + +# Ensight output +Ensight output period : 0.1 \ No newline at end of file diff --git a/examples/peridynamics_shock_orig_DELETE/src/Make.package b/examples/peridynamics_shock_orig_DELETE/src/Make.package new file mode 100644 index 000000000..ddc060c7d --- /dev/null +++ b/examples/peridynamics_shock_orig_DELETE/src/Make.package @@ -0,0 +1,2 @@ +# List here the extra files here +f90EXE_sources += simulation.f90 geometry.f90 lss_class.f90 spcomp_class.f90 diff --git a/examples/peridynamics_shock_orig_DELETE/src/geometry.f90 b/examples/peridynamics_shock_orig_DELETE/src/geometry.f90 new file mode 100644 index 000000000..b05c308c1 --- /dev/null +++ b/examples/peridynamics_shock_orig_DELETE/src/geometry.f90 @@ -0,0 +1,73 @@ +!> Various definitions and tools for initializing NGA2 config +module geometry + use config_class, only: config + use precision, only: WP + implicit none + private + + !> Single config + type(config), public :: cfg + + public :: geometry_init + +contains + + + !> Initialization of problem geometry + subroutine geometry_init + use sgrid_class, only: sgrid + use param, only: param_read + implicit none + type(sgrid) :: grid + + + ! Create a grid from input params + create_grid: block + use sgrid_class, only: cartesian + integer :: i,j,k,nx,ny,nz + real(WP) :: Lx,Ly,Lz + real(WP), dimension(:), allocatable :: x,y,z + + ! Read in grid definition + call param_read('Lx',Lx); call param_read('nx',nx); allocate(x(nx+1)) + call param_read('Ly',Ly); call param_read('ny',ny); allocate(y(ny+1)) + call param_read('Lz',Lz); call param_read('nz',nz); allocate(z(nz+1)) + + ! Create simple rectilinear grid + do i=1,nx+1 + x(i)=real(i-1,WP)/real(nx,WP)*Lx-0.25_WP*Lx + end do + do j=1,ny+1 + y(j)=real(j-1,WP)/real(ny,WP)*Ly-0.5_WP*Ly + end do + do k=1,nz+1 + z(k)=real(k-1,WP)/real(nz,WP)*Lz-0.5_WP*Lz + end do + + ! General serial grid object + grid=sgrid(coord=cartesian,no=2,x=x,y=y,z=z,xper=.false.,yper=.true.,zper=.true.,name='box') + + end block create_grid + + + ! Create a config from that grid on our entire group + create_cfg: block + use parallel, only: group + integer, dimension(3) :: partition + ! Read in partition + call param_read('Partition',partition,short='p') + ! Create partitioned grid + cfg=config(grp=group,decomp=partition,grid=grid) + end block create_cfg + + + ! Create walls for this config + create_walls: block + cfg%VF=1.0_WP + end block create_walls + + + end subroutine geometry_init + + +end module geometry diff --git a/examples/peridynamics_shock_orig_DELETE/src/lss_class.f90 b/examples/peridynamics_shock_orig_DELETE/src/lss_class.f90 new file mode 100644 index 000000000..99a8348a7 --- /dev/null +++ b/examples/peridynamics_shock_orig_DELETE/src/lss_class.f90 @@ -0,0 +1,1507 @@ +!> Lagrangian solid solver object +!> Implements peridynamics equations +module lss_class + use precision, only: WP + use string, only: str_medium + use config_class, only: config + use ddadi_class, only: ddadi + use mpi_f08, only: MPI_Datatype,MPI_INTEGER8,MPI_INTEGER,MPI_DOUBLE_PRECISION + implicit none + private + + + ! Expose type/constructor/methods + public :: lss + + + !> Memory adaptation parameter + real(WP), parameter :: coeff_up=1.3_WP !< Particle array size increase factor + real(WP), parameter :: coeff_dn=0.7_WP !< Particle array size decrease factor + + + !> I/O chunk size to read at a time + integer, parameter :: part_chunk_size=1000 !< Read 1000 particles at a time before redistributing + + + !> Maximum number of bonds per particle + integer, parameter, public :: max_bond=200 !< Assumes something like a 7x7x7 stencil in 3D + + + !> Bonded solid particle definition + type :: part + !> MPI_DOUBLE_PRECISION data + real(WP) :: mw !< Weighted volume + real(WP) :: dil !< Element dilatation + real(WP) :: vol !< Particle volume + real(WP), dimension(max_bond) :: dbond !< Length of initial bonds + real(WP), dimension(3) :: pos !< Particle center coordinates + real(WP), dimension(3) :: vel !< Velocity of particle + real(WP), dimension(3) :: Abond !< Bond acceleration for particle + real(WP), dimension(3) :: Afluid !< Fluid acceleration for particle + !> MPI_INTEGER data + integer :: id !< ID the object is associated with + integer :: i !< Unique index of particle (assumed >0) + integer :: nbond !< Number of initial bonds + integer, dimension(max_bond) :: ibond !< Indices of initially bonded particles (0 values ignored) + integer , dimension(3) :: ind !< Index of cell containing particle center + integer :: flag !< Control parameter (0=normal, 1=done->will be removed) + end type part + !> Number of blocks, block length, and block types in a particle + integer, parameter :: part_nblock=2 + integer , dimension(part_nblock) :: part_lblock=[15+max_bond,7+max_bond] + type(MPI_Datatype), dimension(part_nblock) :: part_tblock=[MPI_DOUBLE_PRECISION,MPI_INTEGER] + !> MPI_PART derived datatype and size + type(MPI_Datatype) :: MPI_PART + integer :: MPI_PART_SIZE + + + !> Lagrangian solid solver object definition + type :: lss + + ! This config is used for parallelization and for calculating bond/collision forces + class(config), pointer :: cfg + + type(ddadi) :: implicit !< Implicit solver for filtering + + ! This is the name of the solver + character(len=str_medium) :: name='UNNAMED_LSS' + + ! Solid material properties + real(WP) :: elastic_modulus !< Elastic modulus of the material + real(WP) :: poisson_ratio !< Poisson's ratio of the material + real(WP) :: rho !< Density of the material + real(WP) :: crit_energy !< Critical energy release + + ! Bonding parameters + real(WP) :: delta !< Bonding horizon (distance) + real(WP) :: min_dist !< Minimum bonding distance + integer :: nb !< Cell-based horizon + + ! Global and local particle data + integer :: np !< Global number of particles + integer :: np_ !< Local number of particles + integer, dimension(:), allocatable :: np_proc !< Number of particles on each processor + type(part), dimension(:), allocatable :: p !< Array of particles of type part + + ! Overlap particle (i.e., ghost) data + integer :: ng_ !< Local number of ghosts + type(part), dimension(:), allocatable :: g !< Array of ghosts of type part + + ! Gravitational acceleration + real(WP), dimension(3) :: gravity=0.0_WP + + ! Solid volume fraction and momentum + real(WP), dimension(:,:,:), allocatable :: VF !< Volume fraction, cell-centered + real(WP), dimension(:,:,:), allocatable :: VFU !< Solid velocity, U-face + real(WP), dimension(:,:,:), allocatable :: VFV !< Solid velocity, V-face + real(WP), dimension(:,:,:), allocatable :: VFW !< Solid velocity, W-face + + ! CFL numbers + real(WP) :: CFLp_x,CFLp_y,CFLp_z,CFLp_a + + ! Number of substeps for time integrator + real(WP) :: nstep=1 + + ! Monitoring info + real(WP) :: Umin,Umax,Umean !< U velocity info + real(WP) :: Vmin,Vmax,Vmean !< V velocity info + real(WP) :: Wmin,Wmax,Wmean !< W velocity info + real(WP) :: VFmax !< Volume fraction info + real(WP), dimension(3) :: ibmForce !< Total force due to IBM + integer :: np_out !< Number of particles leaving the domain + + ! Filtering operation + real(WP) :: filter_width !< Characteristic filter width + real(WP), dimension(:,:,:,:), allocatable :: div_x,div_y,div_z !< Divergence operator + real(WP), dimension(:,:,:,:), allocatable :: grd_x,grd_y,grd_z !< Gradient operator + + contains + procedure :: bond_init !< Setup initial interparticle bonds + procedure :: get_bond_force !< Compute interparticle bond force + procedure :: advance !< Step forward the particle ODEs + procedure :: get_cfl !< Calculate maximum CFL + procedure :: get_max !< Extract various monitoring data + procedure :: update_partmesh !< Update a partmesh object using current particles + procedure :: share !< Share particles across interprocessor boundaries + procedure :: sync !< Synchronize particles across interprocessor boundaries + procedure :: resize !< Resize particle array to given size + procedure :: resize_ghost !< Resize ghost array to given size + procedure :: recycle !< Recycle particle array by removing flagged particles + procedure :: write !< Parallel write particles to file + procedure :: read !< Parallel read particles from file + procedure :: update_VF !< Compute volume fraction + procedure :: filter !< Apply volume filtering to field + end type lss + + + !> Declare lss constructor + interface lss + procedure constructor + end interface lss + +contains + + + ! Quasi-Gaussian weighting function - h is the cut-off + real(WP) function wgauss(d,h) + implicit none + real(WP), intent(in) :: d,h + real(WP), parameter :: coeff=2.6_WP + real(WP) :: hh + hh=coeff*h + if (d.ge.hh) then + wgauss=0.0_WP + else + wgauss=(1.0_WP+4.0_WP*d/hh)*(1.0_WP-d/hh)**4 + end if + end function wgauss + + + !> Default constructor for Lagrangian solid solver + function constructor(cfg,name) result(self) + implicit none + type(lss) :: self + class(config), target, intent(in) :: cfg + character(len=*), optional :: name + integer :: i,j,k + + ! Set the name for the solver + if (present(name)) self%name=trim(adjustl(name)) + + ! Point to pgrid object + self%cfg=>cfg + + ! Set default bonding horizon based on underlying mesh + self%delta=self%cfg%min_meshsize + self%nb=1 + self%min_dist=huge(1.0_WP) + + ! Allocate variables + allocate(self%np_proc(1:self%cfg%nproc)); self%np_proc=0 + self%np_=0; self%np=0 + call self%resize(0) + + ! Initialize MPI derived datatype for a particle + call prepare_mpi_part() + + ! Allocate VF array on cfg mesh + allocate(self%VF(self%cfg%imino_:self%cfg%imaxo_,self%cfg%jmino_:self%cfg%jmaxo_,self%cfg%kmino_:self%cfg%kmaxo_)); self%VF=0.0_WP + allocate(self%VFU(self%cfg%imino_:self%cfg%imaxo_,self%cfg%jmino_:self%cfg%jmaxo_,self%cfg%kmino_:self%cfg%kmaxo_)); self%VFU=0.0_WP + allocate(self%VFV(self%cfg%imino_:self%cfg%imaxo_,self%cfg%jmino_:self%cfg%jmaxo_,self%cfg%kmino_:self%cfg%kmaxo_)); self%VFV=0.0_WP + allocate(self%VFW(self%cfg%imino_:self%cfg%imaxo_,self%cfg%jmino_:self%cfg%jmaxo_,self%cfg%kmino_:self%cfg%kmaxo_)); self%VFW=0.0_WP + + ! Allocate finite volume divergence operators + allocate(self%div_x(0:+1,self%cfg%imin_:self%cfg%imax_,self%cfg%jmin_:self%cfg%jmax_,self%cfg%kmin_:self%cfg%kmax_)) !< Cell-centered + allocate(self%div_y(0:+1,self%cfg%imin_:self%cfg%imax_,self%cfg%jmin_:self%cfg%jmax_,self%cfg%kmin_:self%cfg%kmax_)) !< Cell-centered + allocate(self%div_z(0:+1,self%cfg%imin_:self%cfg%imax_,self%cfg%jmin_:self%cfg%jmax_,self%cfg%kmin_:self%cfg%kmax_)) !< Cell-centered + ! Create divergence operator to cell center [xm,ym,zm] + do k=self%cfg%kmin_,self%cfg%kmax_ + do j=self%cfg%jmin_,self%cfg%jmax_ + do i=self%cfg%imin_,self%cfg%imax_ + self%div_x(:,i,j,k)=self%cfg%dxi(i)*[-1.0_WP,+1.0_WP] !< Divergence from [x ,ym,zm] + self%div_y(:,i,j,k)=self%cfg%dyi(j)*[-1.0_WP,+1.0_WP] !< Divergence from [xm,y ,zm] + self%div_z(:,i,j,k)=self%cfg%dzi(k)*[-1.0_WP,+1.0_WP] !< Divergence from [xm,ym,z ] + end do + end do + end do + + ! Allocate finite difference velocity gradient operators + allocate(self%grd_x(-1:0,self%cfg%imin_:self%cfg%imax_+1,self%cfg%jmin_:self%cfg%jmax_+1,self%cfg%kmin_:self%cfg%kmax_+1)) !< X-face-centered + allocate(self%grd_y(-1:0,self%cfg%imin_:self%cfg%imax_+1,self%cfg%jmin_:self%cfg%jmax_+1,self%cfg%kmin_:self%cfg%kmax_+1)) !< Y-face-centered + allocate(self%grd_z(-1:0,self%cfg%imin_:self%cfg%imax_+1,self%cfg%jmin_:self%cfg%jmax_+1,self%cfg%kmin_:self%cfg%kmax_+1)) !< Z-face-centered + ! Create gradient coefficients to cell faces + do k=self%cfg%kmin_,self%cfg%kmax_+1 + do j=self%cfg%jmin_,self%cfg%jmax_+1 + do i=self%cfg%imin_,self%cfg%imax_+1 + self%grd_x(:,i,j,k)=self%cfg%dxmi(i)*[-1.0_WP,+1.0_WP] !< Gradient in x from [xm,ym,zm] to [x,ym,zm] + self%grd_y(:,i,j,k)=self%cfg%dymi(j)*[-1.0_WP,+1.0_WP] !< Gradient in y from [xm,ym,zm] to [xm,y,zm] + self%grd_z(:,i,j,k)=self%cfg%dzmi(k)*[-1.0_WP,+1.0_WP] !< Gradient in z from [xm,ym,zm] to [xm,ym,z] + end do + end do + end do + + ! Loop over the domain and zero divergence in walls + do k=self%cfg%kmin_,self%cfg%kmax_ + do j=self%cfg%jmin_,self%cfg%jmax_ + do i=self%cfg%imin_,self%cfg%imax_ + if (self%cfg%VF(i,j,k).eq.0.0_WP) then + self%div_x(:,i,j,k)=0.0_WP + self%div_y(:,i,j,k)=0.0_WP + self%div_z(:,i,j,k)=0.0_WP + end if + end do + end do + end do + + ! Zero out gradient to wall faces + do k=self%cfg%kmin_,self%cfg%kmax_+1 + do j=self%cfg%jmin_,self%cfg%jmax_+1 + do i=self%cfg%imin_,self%cfg%imax_+1 + if (self%cfg%VF(i,j,k).eq.0.0_WP.or.self%cfg%VF(i-1,j,k).eq.0.0_WP) self%grd_x(:,i,j,k)=0.0_WP + if (self%cfg%VF(i,j,k).eq.0.0_WP.or.self%cfg%VF(i,j-1,k).eq.0.0_WP) self%grd_y(:,i,j,k)=0.0_WP + if (self%cfg%VF(i,j,k).eq.0.0_WP.or.self%cfg%VF(i,j,k-1).eq.0.0_WP) self%grd_z(:,i,j,k)=0.0_WP + end do + end do + end do + + ! Adjust metrics to account for lower dimensionality + if (self%cfg%nx.eq.1) then + self%div_x=0.0_WP + self%grd_x=0.0_WP + end if + if (self%cfg%ny.eq.1) then + self%div_y=0.0_WP + self%grd_y=0.0_WP + end if + if (self%cfg%nz.eq.1) then + self%div_z=0.0_WP + self%grd_z=0.0_WP + end if + + ! Create implicit solver object for filtering + self%implicit=ddadi(cfg=self%cfg,name='Filter',nst=7) + self%implicit%stc(1,:)=[ 0, 0, 0] + self%implicit%stc(2,:)=[+1, 0, 0] + self%implicit%stc(3,:)=[-1, 0, 0] + self%implicit%stc(4,:)=[ 0,+1, 0] + self%implicit%stc(5,:)=[ 0,-1, 0] + self%implicit%stc(6,:)=[ 0, 0,+1] + self%implicit%stc(7,:)=[ 0, 0,-1] + call self%implicit%init() + + ! Set default filter width + self%filter_width=2.0_WP*self%cfg%min_meshsize + + ! Log/screen output + logging: block + use, intrinsic :: iso_fortran_env, only: output_unit + use param, only: verbose + use messager, only: log + use string, only: str_long + character(len=str_long) :: message + if (self%cfg%amRoot) then + write(message,'("LSS object [",a,"] on partitioned grid [",a,"]")') trim(self%name),trim(self%cfg%name) + if (verbose.gt.1) write(output_unit,'(a)') trim(message) + if (verbose.gt.0) call log(message) + end if + end block logging + + end function constructor + + + !> Initialize bond force between particles + subroutine bond_init(this) + use messager, only: die + implicit none + class(lss), intent(inout) :: this + integer, dimension(:,:,:), allocatable :: npic !< Number of particle in cell + integer, dimension(:,:,:,:), allocatable :: ipic !< Index of particle in cell + + ! Communicate particles in ghost cells + call this%share() + + ! We can now assemble particle-in-cell information + pic_prep: block + use mpi_f08 + integer :: i,ip,jp,kp,ierr + integer :: mymax_npic,max_npic + + ! Allocate number of particle in cell + allocate(npic(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)); npic=0 + + ! Count particles and ghosts per cell + do i=1,this%np_ + ip=this%p(i)%ind(1); jp=this%p(i)%ind(2); kp=this%p(i)%ind(3) + npic(ip,jp,kp)=npic(ip,jp,kp)+1 + end do + do i=1,this%ng_ + ip=this%g(i)%ind(1); jp=this%g(i)%ind(2); kp=this%g(i)%ind(3) + npic(ip,jp,kp)=npic(ip,jp,kp)+1 + end do + + ! Get maximum number of particle in cell + mymax_npic=maxval(npic); call MPI_ALLREDUCE(mymax_npic,max_npic,1,MPI_INTEGER,MPI_MAX,this%cfg%comm,ierr) + + ! Allocate pic map + allocate(ipic(1:max_npic,this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)); ipic=0 + + ! Assemble pic map + npic=0 + do i=1,this%np_ + ip=this%p(i)%ind(1); jp=this%p(i)%ind(2); kp=this%p(i)%ind(3) + npic(ip,jp,kp)=npic(ip,jp,kp)+1 + ipic(npic(ip,jp,kp),ip,jp,kp)=+i + end do + do i=1,this%ng_ + ip=this%g(i)%ind(1); jp=this%g(i)%ind(2); kp=this%g(i)%ind(3) + npic(ip,jp,kp)=npic(ip,jp,kp)+1 + ipic(npic(ip,jp,kp),ip,jp,kp)=-i + end do + + end block pic_prep + + ! Establish initial bonds + create_bonds: block + use mpi_f08, only: MPI_ALLREDUCE,MPI_MIN,MPI_IN_PLACE + use parallel, only: MPI_REAL_WP + use mathtools, only: Pi + integer :: i,j,k,n1,nn,n2,ierr + type(part) :: p1,p2 + real(WP), dimension(3) :: rpos + real(WP) :: dist + ! Reset minimum bond distance + this%min_dist=huge(1.0_WP) + ! Loop over particles + do n1=1,this%np_ + ! Create copy of our particle + p1=this%p(n1) + ! Zero out weighted volume + p1%mw=0.0_WP + ! Zero out bonds + p1%ibond=0 + p1%nbond=0 + ! Loop over neighbor cells + do k=p1%ind(3)-this%nb,p1%ind(3)+this%nb + do j=p1%ind(2)-this%nb,p1%ind(2)+this%nb + do i=p1%ind(1)-this%nb,p1%ind(1)+this%nb + ! Loop over particles in that cell + do nn=1,npic(i,j,k) + ! Create copy of our neighbor + n2=ipic(nn,i,j,k) + if (n2.gt.0) then + p2=this%p(+n2) + else if (n2.lt.0) then + p2=this%g(-n2) + end if + ! Cannot self-bond + if (p1%i.eq.p2%i) cycle + ! Cannot bond with different id except <=0 (<=0 bonds with everyone) + if (p1%id.ne.p2%id.and.p1%id.ge.0.and.p2%id.ge.0) cycle + ! Check interparticle distance + rpos=p2%pos-p1%pos + dist=sqrt(dot_product(rpos,rpos)) + if (dist.lt.this%delta) then + ! This particle is in horizon, create a bond + p1%nbond=p1%nbond+1 + if (p1%nbond.gt.max_bond) call die('[lss_class bond_init] Number of detected bonds is larger than max allowed') + p1%ibond(p1%nbond)=p2%i + p1%dbond(p1%nbond)=dist + ! Increment weighted volume + p1%mw=p1%mw+wgauss(dist,this%delta)*dist**2*p1%vol + ! Determine minimum bond distance + this%min_dist=min(this%min_dist,dist) + end if + end do + end do + end do + end do + ! Zero out initial dilatation + p1%dil=0.0_WP + ! Copy back the particle + this%p(n1)=p1 + end do + ! Get global minimum + call MPI_ALLREDUCE(MPI_IN_PLACE,this%min_dist,1,MPI_REAL_WP,MPI_MIN,this%cfg%comm,ierr) + end block create_bonds + + ! Clean up + if (allocated(npic)) deallocate(npic) + if (allocated(ipic)) deallocate(ipic) + + end subroutine bond_init + + + !> Calculate bond force between particles + subroutine get_bond_force(this) + implicit none + class(lss), intent(inout) :: this + integer, dimension(:,:,:), allocatable :: npic !< Number of particle in cell + integer, dimension(:,:,:,:), allocatable :: ipic !< Index of particle in cell + logical :: is2D + + ! Need to modify parameters in 2D + is2D=this%cfg%nx.eq.1.or.this%cfg%ny.eq.1.or.this%cfg%nz.eq.1 + + ! Communicate particles in ghost cells + call this%share() + + ! We can now assemble particle-in-cell information + pic_prep: block + use mpi_f08 + integer :: i,ip,jp,kp,ierr + integer :: mymax_npic,max_npic + + ! Allocate number of particle in cell + allocate(npic(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)); npic=0 + + ! Count particles and ghosts per cell + do i=1,this%np_ + ip=this%p(i)%ind(1); jp=this%p(i)%ind(2); kp=this%p(i)%ind(3) + npic(ip,jp,kp)=npic(ip,jp,kp)+1 + end do + do i=1,this%ng_ + ip=this%g(i)%ind(1); jp=this%g(i)%ind(2); kp=this%g(i)%ind(3) + npic(ip,jp,kp)=npic(ip,jp,kp)+1 + end do + + ! Get maximum number of particle in cell + mymax_npic=maxval(npic); call MPI_ALLREDUCE(mymax_npic,max_npic,1,MPI_INTEGER,MPI_MAX,this%cfg%comm,ierr) + + ! Allocate pic map + allocate(ipic(1:max_npic,this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)); ipic=0 + + ! Assemble pic map + npic=0 + do i=1,this%np_ + ip=this%p(i)%ind(1); jp=this%p(i)%ind(2); kp=this%p(i)%ind(3) + npic(ip,jp,kp)=npic(ip,jp,kp)+1 + ipic(npic(ip,jp,kp),ip,jp,kp)=+i + end do + do i=1,this%ng_ + ip=this%g(i)%ind(1); jp=this%g(i)%ind(2); kp=this%g(i)%ind(3) + npic(ip,jp,kp)=npic(ip,jp,kp)+1 + ipic(npic(ip,jp,kp),ip,jp,kp)=-i + end do + + end block pic_prep + + ! Update weighted volume and dilatation + update_weighted_vol_and_dilatation: block + integer :: i,j,k,n1,nn,n2 + type(part) :: p1,p2 + integer :: nb,nbond + real(WP), dimension(3) :: rpos + real(WP) :: dist + ! Loop over particles + do n1=1,this%np_ + ! Create copy of our particle + p1=this%p(n1) + ! Zero out weighted volume and dilatation + p1%mw=0.0_WP + p1%dil=0.0_WP + ! Loop over neighbor cells + do k=p1%ind(3)-this%nb,p1%ind(3)+this%nb + do j=p1%ind(2)-this%nb,p1%ind(2)+this%nb + do i=p1%ind(1)-this%nb,p1%ind(1)+this%nb + ! Loop over particles in that cell + do nn=1,npic(i,j,k) + ! Create copy of our neighbor + n2=ipic(nn,i,j,k) + if (n2.gt.0) then + p2=this%p(+n2) + else if (n2.lt.0) then + p2=this%g(-n2) + end if + ! Check if a bond exists + do nb=1,max_bond + if (p1%ibond(nb).eq.p2%i) then + ! Increment weighted volume + p1%mw=p1%mw+wgauss(p1%dbond(nb),this%delta)*p1%dbond(nb)**2*p2%vol + ! Get current distance + rpos=p2%pos-p1%pos + dist=sqrt(dot_product(rpos,rpos)) + ! Increment dilatation + p1%dil=p1%dil+wgauss(p1%dbond(nb),this%delta)*p1%dbond(nb)*(dist-p1%dbond(nb))*p2%vol + end if + end do + end do + end do + end do + end do + ! Rescale dilatation + if (p1%mw.gt.epsilon(1.0_WP)) then + if (is2D) then + ! 2D plane strain + p1%dil=p1%dil*2.0_WP/p1%mw + else + ! 3D + p1%dil=p1%dil*3.0_WP/p1%mw + end if + else + p1%dil=0.0_WP + end if + ! Copy back the particle + this%p(n1)=p1 + end do + end block update_weighted_vol_and_dilatation + + ! Re-communicate particles in ghost cells to update dil and mw + call this%share() + + ! Update bond force, including collision force + update_bond_force: block + use mpi_f08, only: MPI_ALLREDUCE,MPI_MIN,MPI_IN_PLACE + use parallel, only: MPI_REAL_WP + use mathtools, only: Pi + integer :: i,j,k,n1,nn,n2,ierr + type(part) :: p1,p2 + real(WP), dimension(3) :: rpos,t12,t21 + real(WP) :: dist,beta,alpha,ed,t + real(WP) :: stretch,max_stretch,mu,kk + real(WP) :: nc,rc,kc + integer :: nb,nbond + logical :: found_bond + ! Recompute a few physical parameters + mu=this%elastic_modulus/(2.0_WP+2.0_WP*this%poisson_ratio) + kk=this%elastic_modulus/(3.0_WP-6.0_WP*this%poisson_ratio) + if (is2D) then + if (this%cfg%nx.eq.1) t=this%cfg%xL + if (this%cfg%ny.eq.1) t=this%cfg%yL + if (this%cfg%nz.eq.1) t=this%cfg%zL + max_stretch=sqrt(this%crit_energy/((6.0_WP*mu/Pi+16.0_WP/(9.0_WP*Pi**2)*(kk-2.0_WP*mu))*this%delta)) + kc=15.0_WP*48.0_WP*this%elastic_modulus/(Pi*5.0_WP*t*this%delta**3) + else + max_stretch=sqrt(this%crit_energy/((3.0_WP*mu+(kk-5.0_WP*mu/3.0_WP)*0.75_WP**4)*this%delta)) + kc=15.0_WP*12.0_WP*this%elastic_modulus/(Pi*this%delta**4) + end if + nc=1.0_WP + this%min_dist=huge(1.0_WP) + ! Loop over particles + do n1=1,this%np_ + ! Particles marked 0 do not update their forces + if (this%p(n1)%id.eq.0) cycle + ! Create copy of our particle + p1=this%p(n1) + ! Zero out bond force + p1%Abond=0.0_WP + ! Loop over neighbor cells + do k=p1%ind(3)-this%nb,p1%ind(3)+this%nb + do j=p1%ind(2)-this%nb,p1%ind(2)+this%nb + do i=p1%ind(1)-this%nb,p1%ind(1)+this%nb + ! Loop over particles in that cell + do nn=1,npic(i,j,k) + ! Create copy of our neighbor + n2=ipic(nn,i,j,k) + if (n2.gt.0) then + p2=this%p(+n2) + else if (n2.lt.0) then + p2=this%g(-n2) + end if + ! Current distance + rpos=p2%pos-p1%pos + dist=sqrt(dot_product(rpos,rpos)) + ! Check if a bond exists + found_bond=.false. + do nb=1,max_bond + if (p1%ibond(nb).eq.p2%i) then + ! Check for breakage first + stretch=(dist-p1%dbond(nb))/p1%dbond(nb) + if (stretch.gt.max_stretch) then + ! Remove the bond and flag as surface particle + p1%ibond(nb)=0 + p1%dbond(nb)=0.0_WP + cycle + end if + ! Particle 1 + if (is2D) then + ! 2D plane strain + beta = 2.0_WP * kk * p1%dil + alpha = 8.0_WP * mu / p1%mw + ed = dist - p1%dbond(nb) * (1.0_WP + p1%dil / 2.0_WP) + else + ! 3D + beta = 3.0_WP * kk * p1%dil + alpha = 15.0_WP * mu / p1%mw + ed = dist - p1%dbond(nb) * (1.0_WP + p1%dil / 3.0_WP) + end if + ! Force density 1->2 + t12=+wgauss(p1%dbond(nb),this%delta)*(beta/p1%mw*p1%dbond(nb)+alpha*ed)*rpos/dist + ! Particle 2 + if (is2D) then + ! 2D plane strain + beta = 2.0_WP * kk * p2%dil + alpha = 8.0_WP * mu / p2%mw + ed = dist - p1%dbond(nb) * (1.0_WP + p2%dil / 2.0_WP) + else + ! 3D + beta = 3.0_WP * kk * p2%dil + alpha = 15.0_WP * mu / p2%mw + ed = dist - p1%dbond(nb) * (1.0_WP + p2%dil / 3.0_WP) + end if + ! Force density 2->1 + t21=-wgauss(p1%dbond(nb),this%delta)*(beta/p2%mw*p1%dbond(nb)+alpha*ed)*rpos/dist + ! Increment bond force + p1%Abond=p1%Abond+(t12-t21)*p1%vol/this%rho + ! If still here, we have an active bond + found_bond=.true. + ! Determine minimum bond distance + this%min_dist=min(this%min_dist,dist) + cycle + end if + end do + ! Add collision force now + if (is2D) then + rc=p1%vol**(1.0_WP/2.0_WP) + else + rc=p1%vol**(1.0_WP/3.0_WP) + end if + if (.not.found_bond.and.p1%i.ne.p2%i.and.dist.lt.rc) then + p1%Abond=p1%Abond-max(kc*((rc/dist)**nc-1.0_WP),0.0_WP)*(rpos/dist)*p1%vol/this%rho + end if + end do + end do + end do + end do + ! Deal with dimensionality + if (this%cfg%nx.eq.1) p1%Abond(1)=0.0_WP + if (this%cfg%ny.eq.1) p1%Abond(2)=0.0_WP + if (this%cfg%nz.eq.1) p1%Abond(3)=0.0_WP + ! Copy back the particle + this%p(n1)=p1 + end do + ! Get global minimum + call MPI_ALLREDUCE(MPI_IN_PLACE,this%min_dist,1,MPI_REAL_WP,MPI_MIN,this%cfg%comm,ierr) + end block update_bond_force + + ! Clean up + if (allocated(npic)) deallocate(npic) + if (allocated(ipic)) deallocate(ipic) + + end subroutine get_bond_force + + + !> Advance the particle equations by a specified time step dt + !> p%id=-2 => do not solve for position nor velocity + !> p%id=-1 => do not solve for velocity + !> p%id= 0 => do not update force + subroutine advance(this,dt,stress_x,stress_y,stress_z) + use mpi_f08, only : MPI_SUM,MPI_INTEGER,MPI_IN_PLACE + use mathtools, only: Pi + implicit none + class(lss), intent(inout) :: this + real(WP), intent(inout) :: dt !< Timestep size over which to advance + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(inout) :: stress_x !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(inout) :: stress_y !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(inout) :: stress_z !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + integer :: n,ierr + real(WP), dimension(3) :: stress + + ! Zero out number of particles removed + this%np_out=0 + + ! Advance velocity based on old force and position based on mid-velocity + do n=1,this%np_ + ! Advance with Verlet scheme + if (this%p(n)%id.gt.-1) this%p(n)%vel=this%p(n)%vel+0.5_WP*dt*(this%gravity+this%p(n)%Abond+this%p(n)%Afluid) + if (this%p(n)%id.gt.-2) this%p(n)%pos=this%p(n)%pos+dt*this%p(n)%vel + ! Relocalize + this%p(n)%ind=this%cfg%get_ijk_global(this%p(n)%pos,this%p(n)%ind) + ! Correct the position to take into account periodicity + if (this%cfg%xper) this%p(n)%pos(1)=this%cfg%x(this%cfg%imin)+modulo(this%p(n)%pos(1)-this%cfg%x(this%cfg%imin),this%cfg%xL) + if (this%cfg%yper) this%p(n)%pos(2)=this%cfg%y(this%cfg%jmin)+modulo(this%p(n)%pos(2)-this%cfg%y(this%cfg%jmin),this%cfg%yL) + if (this%cfg%zper) this%p(n)%pos(3)=this%cfg%z(this%cfg%kmin)+modulo(this%p(n)%pos(3)-this%cfg%z(this%cfg%kmin),this%cfg%zL) + ! Handle particles that have left the domain + if (this%p(n)%pos(1).lt.this%cfg%x(this%cfg%imin).or.this%p(n)%pos(1).gt.this%cfg%x(this%cfg%imax+1)) this%p(n)%flag=1 + if (this%p(n)%pos(2).lt.this%cfg%y(this%cfg%jmin).or.this%p(n)%pos(2).gt.this%cfg%y(this%cfg%jmax+1)) this%p(n)%flag=1 + if (this%p(n)%pos(3).lt.this%cfg%z(this%cfg%kmin).or.this%p(n)%pos(3).gt.this%cfg%z(this%cfg%kmax+1)) this%p(n)%flag=1 + ! Relocalize the particle + this%p(n)%ind=this%cfg%get_ijk_global(this%p(n)%pos,this%p(n)%ind) + ! Count number of particles removed + if (this%p(n)%flag.eq.1) this%np_out=this%np_out+1 + end do + + ! Communicate particles + call this%sync() + + ! Sum up particles removed + call MPI_ALLREDUCE(this%np_out,n,1,MPI_INTEGER,MPI_SUM,this%cfg%comm,ierr); this%np_out=n + + ! Calculate bond force + call this%get_bond_force() + + ! Advance velocity only based on new force + do n=1,this%np_ + ! Advance with Verlet scheme + if (this%p(n)%id.le.-1) cycle + stress=this%cfg%get_velocity(pos=this%p(n)%pos,i0=this%p(n)%ind(1),j0=this%p(n)%ind(2),k0=this%p(n)%ind(3),U=stress_x,V=stress_y,W=stress_z) + this%p(n)%Afluid=stress/this%rho + this%p(n)%vel=this%p(n)%vel+0.5_WP*dt*(this%gravity+this%p(n)%Abond+this%p(n)%Afluid) + end do + + ! Recompute volume fraction + call this%update_VF() + + ! Log/screen output + logging: block + use, intrinsic :: iso_fortran_env, only: output_unit + use param, only: verbose + use messager, only: log + use string, only: str_long + character(len=str_long) :: message + if (this%cfg%amRoot) then + write(message,'("Particle solver [",a,"] on partitioned grid [",a,"]: ",i0," particles were advanced")') trim(this%name),trim(this%cfg%name),this%np + if (verbose.gt.1) write(output_unit,'(a)') trim(message) + if (verbose.gt.0) call log(message) + end if + end block logging + + end subroutine advance + + + !> Update particle volume fraction using our current particles + subroutine update_VF(this) + implicit none + class(lss), intent(inout) :: this + integer :: i + ! Reset volume fraction and momentum + this%VF=0.0_WP; this%VFU=0.0_WP; this%VFV=0.0_WP; this%VFW=0.0_WP + ! Transfer particle volume + do i=1,this%np_ + ! Skip inactive particle + if (this%p(i)%flag.eq.1) cycle + ! Transfer volume to mesh + call this%cfg%set_scalar(Sp=this%p(i)%vol, pos=this%p(i)%pos,i0=this%p(i)%ind(1),j0=this%p(i)%ind(2),k0=this%p(i)%ind(3),S=this%VF ,bc='n') + call this%cfg%set_scalar(Sp=this%p(i)%vol*this%p(i)%vel(1),pos=this%p(i)%pos,i0=this%p(i)%ind(1),j0=this%p(i)%ind(2),k0=this%p(i)%ind(3),S=this%VFU,bc='n') + call this%cfg%set_scalar(Sp=this%p(i)%vol*this%p(i)%vel(2),pos=this%p(i)%pos,i0=this%p(i)%ind(1),j0=this%p(i)%ind(2),k0=this%p(i)%ind(3),S=this%VFV,bc='n') + call this%cfg%set_scalar(Sp=this%p(i)%vol*this%p(i)%vel(3),pos=this%p(i)%pos,i0=this%p(i)%ind(1),j0=this%p(i)%ind(2),k0=this%p(i)%ind(3),S=this%VFW,bc='n') + end do + this%VF =this%VF /this%cfg%vol + this%VFU=this%VFU/this%cfg%vol + this%VFV=this%VFV/this%cfg%vol + this%VFW=this%VFW/this%cfg%vol + ! Sum at boundaries + call this%cfg%syncsum(this%VF ) + call this%cfg%syncsum(this%VFU) + call this%cfg%syncsum(this%VFV) + call this%cfg%syncsum(this%VFW) + ! Apply volume filter + call this%filter(this%VF ) + call this%filter(this%VFU) + call this%filter(this%VFV) + call this%filter(this%VFW) + ! Clip + where (this%VF.lt.0.0_WP) this%VF=0.0_WP + this%VF=min(this%VF,1.0_WP-epsilon(1.0_WP)) + + end subroutine update_VF + + + !> Laplacian filtering operation + subroutine filter(this,A) + implicit none + class(lss), intent(inout) :: this + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(inout) :: A !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + real(WP) :: filter_coeff + integer :: i,j,k,n,nstep + real(WP), dimension(:,:,:), allocatable :: FX,FY,FZ + + ! Recompute filter coefficient + filter_coeff=max(this%filter_width**2-this%cfg%min_meshsize**2,0.0_WP)/(16.0_WP*log(2.0_WP)) + if (filter_coeff.le.0.0_WP) return + + ! Allocate flux arrays + allocate(FX(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + allocate(FY(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + allocate(FZ(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + + if (.not.this%implicit%setup_done) then + ! Prepare diffusive operator (only need to do this once) + do k=this%cfg%kmin_,this%cfg%kmax_ + do j=this%cfg%jmin_,this%cfg%jmax_ + do i=this%cfg%imin_,this%cfg%imax_ + this%implicit%opr(1,i,j,k)=1.0_WP-(this%div_x(+1,i,j,k)*filter_coeff*this%grd_x(-1,i+1,j,k)+& + & this%div_x( 0,i,j,k)*filter_coeff*this%grd_x( 0,i ,j,k)+& + & this%div_y(+1,i,j,k)*filter_coeff*this%grd_y(-1,i,j+1,k)+& + & this%div_y( 0,i,j,k)*filter_coeff*this%grd_y( 0,i,j ,k)+& + & this%div_z(+1,i,j,k)*filter_coeff*this%grd_z(-1,i,j,k+1)+& + & this%div_z( 0,i,j,k)*filter_coeff*this%grd_z( 0,i,j,k )) + this%implicit%opr(2,i,j,k)= -(this%div_x(+1,i,j,k)*filter_coeff*this%grd_x( 0,i+1,j,k)) + this%implicit%opr(3,i,j,k)= -(this%div_x( 0,i,j,k)*filter_coeff*this%grd_x(-1,i ,j,k)) + this%implicit%opr(4,i,j,k)= -(this%div_y(+1,i,j,k)*filter_coeff*this%grd_y( 0,i,j+1,k)) + this%implicit%opr(5,i,j,k)= -(this%div_y( 0,i,j,k)*filter_coeff*this%grd_y(-1,i,j ,k)) + this%implicit%opr(6,i,j,k)= -(this%div_z(+1,i,j,k)*filter_coeff*this%grd_z( 0,i,j,k+1)) + this%implicit%opr(7,i,j,k)= -(this%div_z( 0,i,j,k)*filter_coeff*this%grd_z(-1,i,j,k )) + end do + end do + end do + end if + ! Explicit step + do k=this%cfg%kmin_,this%cfg%kmax_+1 + do j=this%cfg%jmin_,this%cfg%jmax_+1 + do i=this%cfg%imin_,this%cfg%imax_+1 + FX(i,j,k)=filter_coeff*sum(this%grd_x(:,i,j,k)*A(i-1:i,j,k)) + FY(i,j,k)=filter_coeff*sum(this%grd_y(:,i,j,k)*A(i,j-1:j,k)) + FZ(i,j,k)=filter_coeff*sum(this%grd_z(:,i,j,k)*A(i,j,k-1:k)) + end do + end do + end do + do k=this%cfg%kmin_,this%cfg%kmax_ + do j=this%cfg%jmin_,this%cfg%jmax_ + do i=this%cfg%imin_,this%cfg%imax_ + this%implicit%rhs(i,j,k)=sum(this%div_x(:,i,j,k)*FX(i:i+1,j,k))+sum(this%div_y(:,i,j,k)*FY(i,j:j+1,k))+sum(this%div_z(:,i,j,k)*FZ(i,j,k:k+1)) + end do + end do + end do + ! Implicit step + call this%implicit%setup() + this%implicit%sol=0.0_WP + call this%implicit%solve() + A=A+this%implicit%sol + call this%cfg%sync(A) + + ! Deallocate flux arrays + deallocate(FX,FY,FZ) + + end subroutine filter + + + !> Calculate the CFL + subroutine get_cfl(this,dt,cfl) + use mpi_f08, only: MPI_ALLREDUCE,MPI_MAX + use parallel, only: MPI_REAL_WP + implicit none + class(lss), intent(inout) :: this + real(WP), intent(in) :: dt + real(WP), intent(out) :: cfl + integer :: i,ierr + real(WP) :: my_CFLp_x,my_CFLp_y,my_CFLp_z,kk,mu,a + + ! Set the CFLs to zero + my_CFLp_x=0.0_WP; my_CFLp_y=0.0_WP; my_CFLp_z=0.0_WP + do i=1,this%np_ + my_CFLp_x=max(my_CFLp_x,abs(this%p(i)%vel(1))*this%cfg%dxi(this%p(i)%ind(1))) + my_CFLp_y=max(my_CFLp_y,abs(this%p(i)%vel(2))*this%cfg%dyi(this%p(i)%ind(2))) + my_CFLp_z=max(my_CFLp_z,abs(this%p(i)%vel(3))*this%cfg%dzi(this%p(i)%ind(3))) + end do + my_CFLp_x=my_CFLp_x*dt; my_CFLp_y=my_CFLp_y*dt; my_CFLp_z=my_CFLp_z*dt + + ! Get the parallel max + call MPI_ALLREDUCE(my_CFLp_x,this%CFLp_x,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + call MPI_ALLREDUCE(my_CFLp_y,this%CFLp_y,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + call MPI_ALLREDUCE(my_CFLp_z,this%CFLp_z,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + + ! CFL based on elastic wave speed in material + kk=this%elastic_modulus/(3.0_WP-6.0_WP*this%poisson_ratio) + mu=this%elastic_modulus/(2.0_WP+2.0_WP*this%poisson_ratio) + a=sqrt((kk+4.0_WP*mu/3.0_WP)/this%rho) + this%CFLp_a=dt*a/this%delta + + ! Return the maximum CFL + cfl=max(this%CFLp_x,this%CFLp_y,this%CFLp_z,this%CFLp_a) + + end subroutine get_cfl + + + !> Extract various monitoring data from particle field + subroutine get_max(this) + use mpi_f08, only: MPI_ALLREDUCE,MPI_MAX,MPI_MIN,MPI_SUM + use parallel, only: MPI_REAL_WP + implicit none + class(lss), intent(inout) :: this + real(WP) :: buf,safe_np + real(WP), dimension(3) :: buf3D + integer :: i,j,k,ierr + + ! Create safe np + safe_np=real(max(this%np,1),WP) + + ! Velocity min/max/mean + this%Umin=huge(1.0_WP); this%Umax=-huge(1.0_WP); this%Umean=0.0_WP + this%Vmin=huge(1.0_WP); this%Vmax=-huge(1.0_WP); this%Vmean=0.0_WP + this%Wmin=huge(1.0_WP); this%Wmax=-huge(1.0_WP); this%Wmean=0.0_WP + this%ibmForce=0.0_WP + do i=1,this%np_ + this%Umin=min(this%Umin,this%p(i)%vel(1)); this%Umax=max(this%Umax,this%p(i)%vel(1)); this%Umean=this%Umean+this%p(i)%vel(1) + this%Vmin=min(this%Vmin,this%p(i)%vel(2)); this%Vmax=max(this%Vmax,this%p(i)%vel(2)); this%Vmean=this%Vmean+this%p(i)%vel(2) + this%Wmin=min(this%Wmin,this%p(i)%vel(3)); this%Wmax=max(this%Wmax,this%p(i)%vel(3)); this%Wmean=this%Wmean+this%p(i)%vel(3) + this%ibmForce=this%ibmForce+this%p(i)%Afluid*this%p(i)%vol*this%rho + end do + call MPI_ALLREDUCE(this%Umin ,buf,1,MPI_REAL_WP,MPI_MIN,this%cfg%comm,ierr); this%Umin =buf + call MPI_ALLREDUCE(this%Umax ,buf,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr); this%Umax =buf + call MPI_ALLREDUCE(this%Umean,buf,1,MPI_REAL_WP,MPI_SUM,this%cfg%comm,ierr); this%Umean=buf/safe_np + call MPI_ALLREDUCE(this%Vmin ,buf,1,MPI_REAL_WP,MPI_MIN,this%cfg%comm,ierr); this%Vmin =buf + call MPI_ALLREDUCE(this%Vmax ,buf,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr); this%Vmax =buf + call MPI_ALLREDUCE(this%Vmean,buf,1,MPI_REAL_WP,MPI_SUM,this%cfg%comm,ierr); this%Vmean=buf/safe_np + call MPI_ALLREDUCE(this%Wmin ,buf,1,MPI_REAL_WP,MPI_MIN,this%cfg%comm,ierr); this%Wmin =buf + call MPI_ALLREDUCE(this%Wmax ,buf,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr); this%Wmax =buf + call MPI_ALLREDUCE(this%Wmean,buf,1,MPI_REAL_WP,MPI_SUM,this%cfg%comm,ierr); this%Wmean=buf/safe_np + call MPI_ALLREDUCE(this%ibmForce,buf3D,3,MPI_REAL_WP,MPI_SUM,this%cfg%comm,ierr); this%ibmForce=buf3D + + ! Get max volume fraction + this%VFmax =-huge(1.0_WP) + do k=this%cfg%kmin_,this%cfg%kmax_ + do j=this%cfg%jmin_,this%cfg%jmax_ + do i=this%cfg%imin_,this%cfg%imax_ + this%VFmax=max(this%VFmax,this%VF(i,j,k)) + end do + end do + end do + call MPI_ALLREDUCE(this%VFmax,buf,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr); this%VFmax=buf + + end subroutine get_max + + + !> Update particle mesh using our current particles + subroutine update_partmesh(this,pmesh) + use partmesh_class, only: partmesh + implicit none + class(lss), intent(inout) :: this + class(partmesh), intent(inout) :: pmesh + integer :: i + ! Reset particle mesh storage + call pmesh%reset() + ! Nothing else to do if no particle is present + if (this%np_.eq.0) return + ! Copy particle info + call pmesh%set_size(this%np_) + do i=1,this%np_ + pmesh%pos(:,i)=this%p(i)%pos + end do + end subroutine update_partmesh + + + !> Creation of the MPI datatype for particle + subroutine prepare_mpi_part() + use mpi_f08 + use messager, only: die + implicit none + integer(MPI_ADDRESS_KIND), dimension(part_nblock) :: disp + integer(MPI_ADDRESS_KIND) :: lb,extent + type(MPI_Datatype) :: MPI_PART_TMP + integer :: i,mysize,ierr + ! Prepare the displacement array + disp(1)=0 + do i=2,part_nblock + call MPI_Type_size(part_tblock(i-1),mysize,ierr) + disp(i)=disp(i-1)+int(mysize,MPI_ADDRESS_KIND)*int(part_lblock(i-1),MPI_ADDRESS_KIND) + end do + ! Create and commit the new type + call MPI_Type_create_struct(part_nblock,part_lblock,disp,part_tblock,MPI_PART_TMP,ierr) + call MPI_Type_get_extent(MPI_PART_TMP,lb,extent,ierr) + call MPI_Type_create_resized(MPI_PART_TMP,lb,extent,MPI_PART,ierr) + call MPI_Type_commit(MPI_PART,ierr) + ! If a problem was encountered, say it + if (ierr.ne.0) call die('[lss prepare_mpi_part] MPI Particle type creation failed') + ! Get the size of this type + call MPI_type_size(MPI_PART,MPI_PART_SIZE,ierr) + end subroutine prepare_mpi_part + + + !> Share particles across processor boundaries + subroutine share(this,nover) + use mpi_f08 + use messager, only: warn,die + implicit none + class(lss), intent(inout) :: this + integer, optional :: nover + type(part), dimension(:), allocatable :: tosend + type(part), dimension(:), allocatable :: torecv + integer :: no,nsend,nrecv + type(MPI_Status) :: status + integer :: icnt,isrc,idst,ierr + integer :: i,n + + ! Check overlap size + if (present(nover)) then + no=nover + if (no.gt.this%cfg%no) then + call warn('[lss share] Specified overlap is larger than that of cfg - reducing no') + no=this%cfg%no + else if (no.le.0) then + call die('[lss share] Specified overlap cannot be less or equal to zero') + end if + else + no=1 + end if + + ! Clean up ghost array + call this%resize_ghost(n=0); this%ng_=0 + + ! Share ghost particles in -x (no ghosts are sent here) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(1).lt.this%cfg%imin_+no) nsend=nsend+1 + end do + allocate(tosend(nsend)) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(1).lt.this%cfg%imin_+no) then + nsend=nsend+1 + tosend(nsend)=this%p(n) + if (this%cfg%xper.and.tosend(nsend)%ind(1).lt.this%cfg%imin+no) then + tosend(nsend)%pos(1)=tosend(nsend)%pos(1)+this%cfg%xL + tosend(nsend)%ind(1)=tosend(nsend)%ind(1)+this%cfg%nx + end if + end if + end do + nrecv=0 + call MPI_CART_SHIFT(this%cfg%comm,0,-1,isrc,idst,ierr) + call MPI_SENDRECV(nsend,1,MPI_INTEGER,idst,0,nrecv,1,MPI_INTEGER,isrc,0,this%cfg%comm,status,ierr) + allocate(torecv(nrecv)) + call MPI_SENDRECV(tosend,nsend,MPI_PART,idst,0,torecv,nrecv,MPI_PART,isrc,0,this%cfg%comm,status,ierr) + call this%resize_ghost(this%ng_+nrecv) + this%g(this%ng_+1:this%ng_+nrecv)=torecv + this%ng_=this%ng_+nrecv + if (allocated(tosend)) deallocate(tosend) + if (allocated(torecv)) deallocate(torecv) + + ! Share ghost particles in +x (no ghosts are sent here) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(1).gt.this%cfg%imax_-no) nsend=nsend+1 + end do + allocate(tosend(nsend)) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(1).gt.this%cfg%imax_-no) then + nsend=nsend+1 + tosend(nsend)=this%p(n) + if (this%cfg%xper.and.tosend(nsend)%ind(1).gt.this%cfg%imax-no) then + tosend(nsend)%pos(1)=tosend(nsend)%pos(1)-this%cfg%xL + tosend(nsend)%ind(1)=tosend(nsend)%ind(1)-this%cfg%nx + end if + end if + end do + nrecv=0 + call MPI_CART_SHIFT(this%cfg%comm,0,+1,isrc,idst,ierr) + call MPI_SENDRECV(nsend,1,MPI_INTEGER,idst,0,nrecv,1,MPI_INTEGER,isrc,0,this%cfg%comm,status,ierr) + allocate(torecv(nrecv)) + call MPI_SENDRECV(tosend,nsend,MPI_PART,idst,0,torecv,nrecv,MPI_PART,isrc,0,this%cfg%comm,status,ierr) + call this%resize_ghost(this%ng_+nrecv) + this%g(this%ng_+1:this%ng_+nrecv)=torecv + this%ng_=this%ng_+nrecv + if (allocated(tosend)) deallocate(tosend) + if (allocated(torecv)) deallocate(torecv) + + ! Share ghost particles in -y (ghosts need to be sent now) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(2).lt.this%cfg%jmin_+no) nsend=nsend+1 + end do + do n=1,this%ng_ + if (this%g(n)%ind(2).lt.this%cfg%jmin_+no) nsend=nsend+1 + end do + allocate(tosend(nsend)) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(2).lt.this%cfg%jmin_+no) then + nsend=nsend+1 + tosend(nsend)=this%p(n) + if (this%cfg%yper.and.tosend(nsend)%ind(2).lt.this%cfg%jmin+no) then + tosend(nsend)%pos(2)=tosend(nsend)%pos(2)+this%cfg%yL + tosend(nsend)%ind(2)=tosend(nsend)%ind(2)+this%cfg%ny + end if + end if + end do + do n=1,this%ng_ + if (this%g(n)%ind(2).lt.this%cfg%jmin_+no) then + nsend=nsend+1 + tosend(nsend)=this%g(n) + if (this%cfg%yper.and.tosend(nsend)%ind(2).lt.this%cfg%jmin+no) then + tosend(nsend)%pos(2)=tosend(nsend)%pos(2)+this%cfg%yL + tosend(nsend)%ind(2)=tosend(nsend)%ind(2)+this%cfg%ny + end if + end if + end do + nrecv=0 + call MPI_CART_SHIFT(this%cfg%comm,1,-1,isrc,idst,ierr) + call MPI_SENDRECV(nsend,1,MPI_INTEGER,idst,0,nrecv,1,MPI_INTEGER,isrc,0,this%cfg%comm,status,ierr) + allocate(torecv(nrecv)) + call MPI_SENDRECV(tosend,nsend,MPI_PART,idst,0,torecv,nrecv,MPI_PART,isrc,0,this%cfg%comm,status,ierr) + call this%resize_ghost(this%ng_+nrecv) + this%g(this%ng_+1:this%ng_+nrecv)=torecv + this%ng_=this%ng_+nrecv + if (allocated(tosend)) deallocate(tosend) + if (allocated(torecv)) deallocate(torecv) + + ! Share ghost particles in +y (ghosts need to be sent now - but not newly received ghosts!) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(2).gt.this%cfg%jmax_-no) nsend=nsend+1 + end do + do n=1,this%ng_-nrecv + if (this%g(n)%ind(2).gt.this%cfg%jmax_-no) nsend=nsend+1 + end do + allocate(tosend(nsend)) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(2).gt.this%cfg%jmax_-no) then + nsend=nsend+1 + tosend(nsend)=this%p(n) + if (this%cfg%yper.and.tosend(nsend)%ind(2).gt.this%cfg%jmax-no) then + tosend(nsend)%pos(2)=tosend(nsend)%pos(2)-this%cfg%yL + tosend(nsend)%ind(2)=tosend(nsend)%ind(2)-this%cfg%ny + end if + end if + end do + do n=1,this%ng_-nrecv + if (this%g(n)%ind(2).gt.this%cfg%jmax_-no) then + nsend=nsend+1 + tosend(nsend)=this%g(n) + if (this%cfg%yper.and.tosend(nsend)%ind(2).gt.this%cfg%jmax-no) then + tosend(nsend)%pos(2)=tosend(nsend)%pos(2)-this%cfg%yL + tosend(nsend)%ind(2)=tosend(nsend)%ind(2)-this%cfg%ny + end if + end if + end do + nrecv=0 + call MPI_CART_SHIFT(this%cfg%comm,1,+1,isrc,idst,ierr) + call MPI_SENDRECV(nsend,1,MPI_INTEGER,idst,0,nrecv,1,MPI_INTEGER,isrc,0,this%cfg%comm,status,ierr) + allocate(torecv(nrecv)) + call MPI_SENDRECV(tosend,nsend,MPI_PART,idst,0,torecv,nrecv,MPI_PART,isrc,0,this%cfg%comm,status,ierr) + call this%resize_ghost(this%ng_+nrecv) + this%g(this%ng_+1:this%ng_+nrecv)=torecv + this%ng_=this%ng_+nrecv + if (allocated(tosend)) deallocate(tosend) + if (allocated(torecv)) deallocate(torecv) + + ! Share ghost particles in -z (ghosts need to be sent now) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(3).lt.this%cfg%kmin_+no) nsend=nsend+1 + end do + do n=1,this%ng_ + if (this%g(n)%ind(3).lt.this%cfg%kmin_+no) nsend=nsend+1 + end do + allocate(tosend(nsend)) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(3).lt.this%cfg%kmin_+no) then + nsend=nsend+1 + tosend(nsend)=this%p(n) + if (this%cfg%zper.and.tosend(nsend)%ind(3).lt.this%cfg%kmin+no) then + tosend(nsend)%pos(3)=tosend(nsend)%pos(3)+this%cfg%zL + tosend(nsend)%ind(3)=tosend(nsend)%ind(3)+this%cfg%nz + end if + end if + end do + do n=1,this%ng_ + if (this%g(n)%ind(3).lt.this%cfg%kmin_+no) then + nsend=nsend+1 + tosend(nsend)=this%g(n) + if (this%cfg%zper.and.tosend(nsend)%ind(3).lt.this%cfg%kmin+no) then + tosend(nsend)%pos(3)=tosend(nsend)%pos(3)+this%cfg%zL + tosend(nsend)%ind(3)=tosend(nsend)%ind(3)+this%cfg%nz + end if + end if + end do + nrecv=0 + call MPI_CART_SHIFT(this%cfg%comm,2,-1,isrc,idst,ierr) + call MPI_SENDRECV(nsend,1,MPI_INTEGER,idst,0,nrecv,1,MPI_INTEGER,isrc,0,this%cfg%comm,status,ierr) + allocate(torecv(nrecv)) + call MPI_SENDRECV(tosend,nsend,MPI_PART,idst,0,torecv,nrecv,MPI_PART,isrc,0,this%cfg%comm,status,ierr) + call this%resize_ghost(this%ng_+nrecv) + this%g(this%ng_+1:this%ng_+nrecv)=torecv + this%ng_=this%ng_+nrecv + if (allocated(tosend)) deallocate(tosend) + if (allocated(torecv)) deallocate(torecv) + + ! Share ghost particles in +z (ghosts need to be sent now - but not newly received ghosts!) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(3).gt.this%cfg%kmax_-no) nsend=nsend+1 + end do + do n=1,this%ng_-nrecv + if (this%g(n)%ind(3).gt.this%cfg%kmax_-no) nsend=nsend+1 + end do + allocate(tosend(nsend)) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(3).gt.this%cfg%kmax_-no) then + nsend=nsend+1 + tosend(nsend)=this%p(n) + if (this%cfg%zper.and.tosend(nsend)%ind(3).gt.this%cfg%kmax-no) then + tosend(nsend)%pos(3)=tosend(nsend)%pos(3)-this%cfg%zL + tosend(nsend)%ind(3)=tosend(nsend)%ind(3)-this%cfg%nz + end if + end if + end do + do n=1,this%ng_-nrecv + if (this%g(n)%ind(3).gt.this%cfg%kmax_-no) then + nsend=nsend+1 + tosend(nsend)=this%g(n) + if (this%cfg%zper.and.tosend(nsend)%ind(3).gt.this%cfg%kmax-no) then + tosend(nsend)%pos(3)=tosend(nsend)%pos(3)-this%cfg%zL + tosend(nsend)%ind(3)=tosend(nsend)%ind(3)-this%cfg%nz + end if + end if + end do + nrecv=0 + call MPI_CART_SHIFT(this%cfg%comm,2,+1,isrc,idst,ierr) + call MPI_SENDRECV(nsend,1,MPI_INTEGER,idst,0,nrecv,1,MPI_INTEGER,isrc,0,this%cfg%comm,status,ierr) + allocate(torecv(nrecv)) + call MPI_SENDRECV(tosend,nsend,MPI_PART,idst,0,torecv,nrecv,MPI_PART,isrc,0,this%cfg%comm,status,ierr) + call this%resize_ghost(this%ng_+nrecv) + this%g(this%ng_+1:this%ng_+nrecv)=torecv + this%ng_=this%ng_+nrecv + if (allocated(tosend)) deallocate(tosend) + if (allocated(torecv)) deallocate(torecv) + + end subroutine share + + + !> Synchronize particle arrays across processors + subroutine sync(this) + use mpi_f08 + implicit none + class(lss), intent(inout) :: this + integer, dimension(0:this%cfg%nproc-1) :: nsend_proc,nrecv_proc + integer, dimension(0:this%cfg%nproc-1) :: nsend_disp,nrecv_disp + integer :: n,prank,ierr + type(part), dimension(:), allocatable :: buf_send + ! Recycle first to minimize communication load + call this%recycle() + ! Prepare information about what to send + nsend_proc=0 + do n=1,this%np_ + prank=this%cfg%get_rank(this%p(n)%ind) + nsend_proc(prank)=nsend_proc(prank)+1 + end do + nsend_proc(this%cfg%rank)=0 + ! Inform processors of what they will receive + call MPI_ALLtoALL(nsend_proc,1,MPI_INTEGER,nrecv_proc,1,MPI_INTEGER,this%cfg%comm,ierr) + ! Prepare displacements for all-to-all + nsend_disp(0)=0 + nrecv_disp(0)=this%np_ !< Directly add particles at the end of main array + do n=1,this%cfg%nproc-1 + nsend_disp(n)=nsend_disp(n-1)+nsend_proc(n-1) + nrecv_disp(n)=nrecv_disp(n-1)+nrecv_proc(n-1) + end do + ! Allocate buffer to send particles + allocate(buf_send(sum(nsend_proc))) + ! Pack the particles in the send buffer + nsend_proc=0 + do n=1,this%np_ + ! Get the rank + prank=this%cfg%get_rank(this%p(n)%ind) + ! Skip particles still inside + if (prank.eq.this%cfg%rank) cycle + ! Pack up for sending + nsend_proc(prank)=nsend_proc(prank)+1 + buf_send(nsend_disp(prank)+nsend_proc(prank))=this%p(n) + ! Flag particle for removal + this%p(n)%flag=1 + end do + ! Allocate buffer for receiving particles + call this%resize(this%np_+sum(nrecv_proc)) + ! Perform communication + call MPI_ALLtoALLv(buf_send,nsend_proc,nsend_disp,MPI_PART,this%p,nrecv_proc,nrecv_disp,MPI_PART,this%cfg%comm,ierr) + ! Deallocate buffer + deallocate(buf_send) + ! Recycle to remove duplicate particles + call this%recycle() + end subroutine sync + + + !> Adaptation of particle array size + subroutine resize(this,n) + implicit none + class(lss), intent(inout) :: this + integer, intent(in) :: n + type(part), dimension(:), allocatable :: tmp + integer :: size_now,size_new + ! Resize particle array to size n + if (.not.allocated(this%p)) then + ! Allocate directly to size n + allocate(this%p(n)) + this%p(1:n)%flag=1 + else + ! Update from a non-zero size to another non-zero size + size_now=size(this%p,dim=1) + if (n.gt.size_now) then + size_new=max(n,int(real(size_now,WP)*coeff_up)) + allocate(tmp(size_new)) + tmp(1:size_now)=this%p + tmp(size_now+1:)%flag=1 + call move_alloc(tmp,this%p) + else if (n.lt.int(real(size_now,WP)*coeff_dn)) then + allocate(tmp(n)) + tmp(1:n)=this%p(1:n) + call move_alloc(tmp,this%p) + end if + end if + end subroutine resize + + + !> Adaptation of ghost array size + subroutine resize_ghost(this,n) + implicit none + class(lss), intent(inout) :: this + integer, intent(in) :: n + type(part), dimension(:), allocatable :: tmp + integer :: size_now,size_new + ! Resize ghost array to size n + if (.not.allocated(this%g)) then + ! Allocate directly to size n + allocate(this%g(n)) + this%g(1:n)%flag=1 + else + ! Update from a non-zero size to another non-zero size + size_now=size(this%g,dim=1) + if (n.gt.size_now) then + size_new=max(n,int(real(size_now,WP)*coeff_up)) + allocate(tmp(size_new)) + tmp(1:size_now)=this%g + tmp(size_now+1:)%flag=1 + call move_alloc(tmp,this%g) + else if (n.lt.int(real(size_now,WP)*coeff_dn)) then + allocate(tmp(n)) + tmp(1:n)=this%g(1:n) + call move_alloc(tmp,this%g) + end if + end if + end subroutine resize_ghost + + + !> Clean-up of particle array by removing flag=1 particles + subroutine recycle(this) + implicit none + class(lss), intent(inout) :: this + integer :: new_size,i,ierr + ! Compact all active particles at the beginning of the array + new_size=0 + if (allocated(this%p)) then + do i=1,size(this%p,dim=1) + if (this%p(i)%flag.ne.1) then + new_size=new_size+1 + if (i.ne.new_size) then + this%p(new_size)=this%p(i) + this%p(i)%flag=1 + end if + end if + end do + end if + ! Resize to new size + call this%resize(new_size) + ! Update number of particles + this%np_=new_size + call MPI_ALLGATHER(this%np_,1,MPI_INTEGER,this%np_proc,1,MPI_INTEGER,this%cfg%comm,ierr) + this%np=sum(this%np_proc) + end subroutine recycle + + + !> Parallel write particles to file + subroutine write(this,filename) + use mpi_f08 + use messager, only: die + use parallel, only: info_mpiio + implicit none + class(lss), intent(inout) :: this + character(len=*), intent(in) :: filename + type(MPI_File) :: ifile + type(MPI_Status):: status + integer(kind=MPI_OFFSET_KIND) :: offset + integer :: i,ierr,iunit + + ! Root serial-writes the file header + if (this%cfg%amRoot) then + ! Open the file + open(newunit=iunit,file=trim(filename),form='unformatted',status='replace',access='stream',iostat=ierr) + if (ierr.ne.0) call die('[lss write] Problem encountered while serial-opening data file: '//trim(filename)) + ! Number of particles and particle object size + write(iunit) this%np,MPI_PART_SIZE + ! Done with the header + close(iunit) + end if + + ! The rest is done in parallel + call MPI_FILE_OPEN(this%cfg%comm,trim(filename),IOR(MPI_MODE_WRONLY,MPI_MODE_APPEND),info_mpiio,ifile,ierr) + if (ierr.ne.0) call die('[lss write] Problem encountered while parallel-opening data file: '//trim(filename)) + + ! Get current position + call MPI_FILE_GET_POSITION(ifile,offset,ierr) + + ! Compute the offset and write + do i=1,this%cfg%rank + offset=offset+int(this%np_proc(i),MPI_OFFSET_KIND)*int(MPI_PART_SIZE,MPI_OFFSET_KIND) + end do + if (this%np_.gt.0) call MPI_FILE_WRITE_AT(ifile,offset,this%p,this%np_,MPI_PART,status,ierr) + + ! Close the file + call MPI_FILE_CLOSE(ifile,ierr) + + ! Log/screen output + logging: block + use, intrinsic :: iso_fortran_env, only: output_unit + use param, only: verbose + use messager, only: log + use string, only: str_long + character(len=str_long) :: message + if (this%cfg%amRoot) then + write(message,'("[lss write] Wrote ",i0," particles to file [",a,"] on partitioned grid [",a,"]")') this%np,trim(filename),trim(this%cfg%name) + if (verbose.gt.2) write(output_unit,'(a)') trim(message) + if (verbose.gt.1) call log(message) + end if + end block logging + + end subroutine write + + + !> Parallel read particles to file + subroutine read(this,filename) + use mpi_f08 + use messager, only: die + use parallel, only: info_mpiio + implicit none + class(lss), intent(inout) :: this + character(len=*), intent(in) :: filename + type(MPI_File) :: ifile + type(MPI_Status):: status + integer(kind=MPI_OFFSET_KIND) :: offset,header_offset + integer :: i,j,ierr,npadd,psize,nchunk,cnt + integer, dimension(:,:), allocatable :: ppp + + ! First open the file in parallel + call MPI_FILE_OPEN(this%cfg%comm,trim(filename),MPI_MODE_RDONLY,info_mpiio,ifile,ierr) + if (ierr.ne.0) call die('[lss read] Problem encountered while reading data file: '//trim(filename)) + + ! Read file header first + call MPI_FILE_READ_ALL(ifile,npadd,1,MPI_INTEGER,status,ierr) + call MPI_FILE_READ_ALL(ifile,psize,1,MPI_INTEGER,status,ierr) + + ! Remember current position + call MPI_FILE_GET_POSITION(ifile,header_offset,ierr) + + ! Check compatibility of particle type + if (psize.ne.MPI_PART_SIZE) call die('[lss read] Particle type unreadable') + + ! Naively share reading task among all processors + nchunk=int(npadd/(this%cfg%nproc*part_chunk_size))+1 + allocate(ppp(this%cfg%nproc,nchunk)) + ppp=int(npadd/(this%cfg%nproc*nchunk)) + cnt=0 + out:do j=1,nchunk + do i=1,this%cfg%nproc + cnt=cnt+1 + if (cnt.gt.mod(npadd,this%cfg%nproc*nchunk)) exit out + ppp(i,j)=ppp(i,j)+1 + end do + end do out + + ! Read by chunk + do j=1,nchunk + ! Find offset + offset=header_offset+int(MPI_PART_SIZE,MPI_OFFSET_KIND)*int(sum(ppp(1:this%cfg%rank,:))+sum(ppp(this%cfg%rank+1,1:j-1)),MPI_OFFSET_KIND) + ! Resize particle array + call this%resize(this%np_+ppp(this%cfg%rank+1,j)) + ! Read this file + call MPI_FILE_READ_AT(ifile,offset,this%p(this%np_+1:this%np_+ppp(this%cfg%rank+1,j)),ppp(this%cfg%rank+1,j),MPI_PART,status,ierr) + ! Most general case: relocate every droplet + do i=this%np_+1,this%np_+ppp(this%cfg%rank+1,j) + this%p(i)%ind=this%cfg%get_ijk_global(this%p(i)%pos,this%p(i)%ind) + end do + ! Exchange all that + call this%sync() + end do + + ! Close the file + call MPI_FILE_CLOSE(ifile,ierr) + + ! Log/screen output + logging: block + use, intrinsic :: iso_fortran_env, only: output_unit + use param, only: verbose + use messager, only: log + use string, only: str_long + character(len=str_long) :: message + if (this%cfg%amRoot) then + write(message,'("[lss read] Read ",i0," particles from file [",a,"] on partitioned grid [",a,"]")') npadd,trim(filename),trim(this%cfg%name) + if (verbose.gt.2) write(output_unit,'(a)') trim(message) + if (verbose.gt.1) call log(message) + end if + end block logging + + end subroutine read + + +end module lss_class diff --git a/examples/peridynamics_shock_orig_DELETE/src/simulation.f90 b/examples/peridynamics_shock_orig_DELETE/src/simulation.f90 new file mode 100644 index 000000000..a8e113451 --- /dev/null +++ b/examples/peridynamics_shock_orig_DELETE/src/simulation.f90 @@ -0,0 +1,782 @@ +!> Various definitions and tools for running an NGA2 simulation +module simulation + use precision, only: WP,SP + use geometry, only: cfg + use spcomp_class, only: spcomp + use lss_class, only: lss + use timetracker_class, only: timetracker + use ensight_class, only: ensight + use partmesh_class, only: partmesh + use event_class, only: event + use monitor_class, only: monitor + implicit none + private + + !> Get a couple linear solvers, an incompressible flow solver and corresponding time tracker + type(spcomp), public :: fs + type(lss), public :: ls + type(timetracker), public :: time + + !> Ensight postprocessing + type(partmesh) :: pmesh + type(ensight) :: ens_out + type(event) :: ens_evt + + !> Simulation monitor file + type(monitor) :: mfile,cflfile,consfile,sfile + + public :: simulation_init,simulation_run,simulation_final + + !> Private work arrays + real(WP), dimension(:,:,:,:), allocatable :: dQdt + real(WP), dimension(:,:,:) , allocatable :: Ui,Vi,Wi,Ma,beta,visc,visc_t,div + + !> Post-shock viscosity and temperature + real(WP) :: visc0,T0 + + !> Equations of state + real(WP) :: Pinf,Gamma,Cv,Prandtl + + !> Flow parameters + real(WP) :: Ms,Xs,Rcyl + real(WP) :: rho1,p1,u1,M1 + real(WP) :: rho2,p2,u2,M2 + real(WP) :: Re + + !> Max timestep size for solid solver + integer :: ls_it + real(WP) :: ls_dt,ls_dt_max + + contains + + + !> Function that returns a smooth Heaviside of thickness delta + real(WP) function Hshock(x,delta) + real(WP), intent(in) :: x,delta + ! Goes from 0 to 1 as x goes from begative to positive + Hshock=1.0_WP/(1.0_WP+exp(-x/delta)) + end function Hshock + + + !> P=EOS(RHO,I) + pure real(WP) function get_P(RHO,I) + implicit none + real(WP), intent(in) :: RHO,I + get_P=RHO*I*(Gamma-1.0_WP)-Gamma*Pinf + end function get_P + !> T=f(RHO,P) + pure real(WP) function get_T(RHO,P) + implicit none + real(WP), intent(in) :: RHO,P + get_T=(P+Pinf)/(Cv*RHO*(Gamma-1.0_WP)) + end function get_T + !> RHO=f(T,P) + pure real(WP) function get_RHO(T,P) + implicit none + real(WP), intent(in) :: T,P + get_RHO=(P+Pinf)/(Cv*T*(Gamma-1.0_WP)) + end function get_RHO + !> I=EOS(RHO,P) + pure real(WP) function get_I(RHO,P) + implicit none + real(WP), intent(in) :: RHO,P + get_I=(P+Gamma*Pinf)/(RHO*(Gamma-1.0_WP)) + end function get_I + !> C=f(RHO,P) + pure real(WP) function get_C(RHO,P) + implicit none + real(WP), intent(in) :: RHO,P + get_C=sqrt(Gamma*(P+Pinf)/RHO) + end function get_C + !> S=f(RHO,P) + pure real(WP) function get_S(RHO,P) + implicit none + real(WP), intent(in) :: RHO,P + get_S=Cv*log((P+Pinf)/RHO**Gamma) + end function get_S + + + !> Calculate viscosities + subroutine prepare_viscosities() + implicit none + integer :: i,j,k + real(WP) :: S + ! Get viscosity from Sutherland's law + S=110.4_WP/273.15_WP*T0 + do k=fs%cfg%kmino_,fs%cfg%kmaxo_ + do j=fs%cfg%jmino_,fs%cfg%jmaxo_ + do i=fs%cfg%imino_,fs%cfg%imaxo_ + visc(i,j,k)=visc0*(T0+S)/(fs%T(i,j,k)+S)*(fs%T(i,j,k)/T0)**1.5_WP + end do + end do + end do + ! Get LAD + call fs%get_viscartif(dt=time%dt,beta=beta); fs%BETA=fs%Q(:,:,:,1)*beta + ! Get eddy viscosity + call fs%get_vreman (dt=time%dt,visc=visc_t); fs%VISC=fs%Q(:,:,:,1)*visc_t+visc + ! Recompute thermal conductivity + fs%diff=Gamma*Cv*fs%visc/Prandtl + ! Add LAD + fs%VISC=fs%VISC+0.002_WP*fs%BETA + end subroutine prepare_viscosities + + + !> Calculate velocity divergence + subroutine get_div() + implicit none + integer :: i,j,k + do k=fs%cfg%kmino_,fs%cfg%kmaxo_-1; do j=fs%cfg%jmino_,fs%cfg%jmaxo_-1; do i=fs%cfg%imino_,fs%cfg%imaxo_-1 + div(i,j,k)=fs%dxi*(fs%U(i+1,j,k)-fs%U(i,j,k))+fs%dyi*(fs%V(i,j+1,k)-fs%V(i,j,k))+fs%dzi*(fs%W(i,j,k+1)-fs%W(i,j,k)) + end do; end do; end do + call fs%cfg%sync(div) + if (.not.fs%cfg%xper.and.fs%cfg%iproc.eq.fs%cfg%npx) div(fs%cfg%imaxo,:,:)=div(fs%cfg%imaxo-1,:,:) + if (.not.fs%cfg%yper.and.fs%cfg%jproc.eq.fs%cfg%npy) div(:,fs%cfg%jmaxo,:)=div(:,fs%cfg%jmaxo-1,:) + if (.not.fs%cfg%zper.and.fs%cfg%kproc.eq.fs%cfg%npz) div(:,:,fs%cfg%kmaxo)=div(:,:,fs%cfg%kmaxo-1) + end subroutine get_div + + + !> Overwrite conserved variables using volume-of-solid IBM + subroutine apply_ibm() + implicit none + integer :: i,j,k,ii,jj,kk + real(WP) :: sum_VF,sum_VFQ1,sum_VFQ2 + real(WP), dimension(:,:,:), allocatable :: Q1old,Q2old + allocate(Q1old(fs%cfg%imino_:fs%cfg%imaxo_,fs%cfg%jmino_:fs%cfg%jmaxo_,fs%cfg%kmino_:fs%cfg%kmaxo_)); Q1old=fs%Q(:,:,:,1) + allocate(Q2old(fs%cfg%imino_:fs%cfg%imaxo_,fs%cfg%jmino_:fs%cfg%jmaxo_,fs%cfg%kmino_:fs%cfg%kmaxo_)); Q2old=fs%Q(:,:,:,2) + do k=cfg%kmin_,cfg%kmax_ + do j=cfg%jmin_,cfg%jmax_ + do i=cfg%imin_,cfg%imax_ + if (ls%VF(i,j,k).eq.0.0_WP) cycle + ! Neumann: VF-weighted neighbor average for Q(1) and Q(2) + sum_VF=0.0_WP; sum_VFQ1=0.0_WP; sum_VFQ2=0.0_WP + do kk=-1,1; do jj=-1,1; do ii=-1,1 + if (ii.eq.0.and.jj.eq.0.and.kk.eq.0) cycle + sum_VF =sum_VF +(1.0_WP-ls%VF(i+ii,j+jj,k+kk)) + sum_VFQ1=sum_VFQ1+(1.0_WP-ls%VF(i+ii,j+jj,k+kk))*Q1old(i+ii,j+jj,k+kk) + sum_VFQ2=sum_VFQ2+(1.0_WP-ls%VF(i+ii,j+jj,k+kk))*Q2old(i+ii,j+jj,k+kk) + end do; end do; end do + if (sum_VF.gt.0.0_WP) then + fs%Q(i,j,k,1)=(1.0_WP-ls%VF(i,j,k))*fs%Q(i,j,k,1)+ls%VF(i,j,k)*sum_VFQ1/sum_VF + fs%Q(i,j,k,2)=(1.0_WP-ls%VF(i,j,k))*fs%Q(i,j,k,2)+ls%VF(i,j,k)*sum_VFQ2/sum_VF + end if + ! No-slip now that density is determined + fs%Q(i,j,k,3)=(1.0_WP-0.5_WP*(ls%VF(i-1,j,k)+ls%VF(i,j,k)))*fs%Q(i,j,k,3)+0.5_WP*(fs%Q(i-1,j,k,1)+fs%Q(i,j,k,1))*0.5_WP*(ls%VFU(i-1,j,k)+ls%VFU(i,j,k)) + fs%Q(i,j,k,4)=(1.0_WP-0.5_WP*(ls%VF(i,j-1,k)+ls%VF(i,j,k)))*fs%Q(i,j,k,4)+0.5_WP*(fs%Q(i,j-1,k,1)+fs%Q(i,j,k,1))*0.5_WP*(ls%VFV(i,j-1,k)+ls%VFV(i,j,k)) + fs%Q(i,j,k,5)=(1.0_WP-0.5_WP*(ls%VF(i,j,k-1)+ls%VF(i,j,k)))*fs%Q(i,j,k,5)+0.5_WP*(fs%Q(i,j,k-1,1)+fs%Q(i,j,k,1))*0.5_WP*(ls%VFW(i,j,k-1)+ls%VFW(i,j,k)) + end do + end do + end do + ! Communicate + call fs%cfg%sync(fs%Q(:,:,:,1)) + call fs%cfg%sync(fs%Q(:,:,:,2)) + call fs%cfg%sync(fs%Q(:,:,:,3)) + call fs%cfg%sync(fs%Q(:,:,:,4)) + call fs%cfg%sync(fs%Q(:,:,:,5)) + ! Rebuild primitive variables + call fs%get_primitive() + end subroutine apply_ibm + + + !> Apply boundary conditions + subroutine apply_bconds() + implicit none + integer :: i,j,k + + ! Apply clipped Neumann on primitive variables in x+ + if (.not.fs%cfg%xper.and.fs%cfg%iproc.eq.fs%cfg%npx) then + do k=fs%cfg%kmino_,fs%cfg%kmaxo_; do j=fs%cfg%jmino_,fs%cfg%jmaxo_ + ! Copy over from imax to imax+1 and above + do i=fs%cfg%imax+1,fs%cfg%imaxo + ! Copy primitive variables + ls%VF(i,j,k)=ls%VF(fs%cfg%imax,j,k) + fs%Q(i,j,k,1)=fs%Q(fs%cfg%imax,j,k,1) + fs%P(i,j,k)=fs%P(fs%cfg%imax,j,k) + fs%I(i,j,k)=fs%I(fs%cfg%imax,j,k) + fs%U(i,j,k)=max(fs%U(fs%cfg%imax,j,k),0.0_WP) + fs%V(i,j,k)=fs%V(fs%cfg%imax,j,k) + fs%W(i,j,k)=fs%W(fs%cfg%imax,j,k) + end do + end do; end do + end if + + ! Apply clipped Neumann on primitive variables in y+ + if (.not.fs%cfg%yper.and.fs%cfg%jproc.eq.fs%cfg%npy) then + do k=fs%cfg%kmino_,fs%cfg%kmaxo_; do i=fs%cfg%imino_,fs%cfg%imaxo_ + ! Copy over from jmax to jmax+1 and above + do j=fs%cfg%jmax+1,fs%cfg%jmaxo + ! Copy primitive variables + ls%VF(i,j,k)=ls%VF(i,fs%cfg%jmax,k) + fs%Q(i,j,k,1)=fs%Q(i,fs%cfg%jmax,k,1) + fs%P(i,j,k)=fs%P(i,fs%cfg%jmax,k) + fs%I(i,j,k)=fs%I(i,fs%cfg%jmax,k) + fs%U(i,j,k)=fs%U(i,fs%cfg%jmax,k) + fs%V(i,j,k)=max(fs%V(i,fs%cfg%jmax,k),0.0_WP) + fs%W(i,j,k)=fs%W(i,fs%cfg%jmax,k) + end do + end do; end do + end if + + ! Apply clipped Neumann on primitive variables in y- + if (.not.fs%cfg%yper.and.fs%cfg%jproc.eq.1) then + do k=fs%cfg%kmino_,fs%cfg%kmaxo_; do i=fs%cfg%imino_,fs%cfg%imaxo_ + ! First copy over V from jmin+1 to jmin + fs%V(i,fs%cfg%jmin,k)=min(fs%V(i,fs%cfg%jmin+1,k),0.0_WP) + ! Then copy over from jmin to jmin-1 and below + do j=fs%cfg%jmino,fs%cfg%jmin-1 + ! Copy primitive variables + ls%VF(i,j,k)=ls%VF(i,fs%cfg%jmin,k) + fs%Q(i,j,k,1)=fs%Q(i,fs%cfg%jmin,k,1) + fs%P(i,j,k)=fs%P(i,fs%cfg%jmin,k) + fs%I(i,j,k)=fs%I(i,fs%cfg%jmin,k) + fs%U(i,j,k)=fs%U(i,fs%cfg%jmin,k) + fs%V(i,j,k)=min(fs%V(i,fs%cfg%jmin,k),0.0_WP) + fs%W(i,j,k)=fs%W(i,fs%cfg%jmin,k) + end do + end do; end do + end if + + ! Apply clipped Neumann on primitive variables in z+ + if (.not.fs%cfg%zper.and.fs%cfg%kproc.eq.fs%cfg%npz) then + do j=fs%cfg%jmino_,fs%cfg%jmaxo_; do i=fs%cfg%imino_,fs%cfg%imaxo_ + ! Copy over from kmax to kmax+1 and above + do k=fs%cfg%kmax+1,fs%cfg%kmaxo + ! Copy primitive variables + ls%VF(i,j,k)=ls%VF(i,j,fs%cfg%kmax) + fs%Q(i,j,k,1)=fs%Q(i,j,fs%cfg%kmax,1) + fs%P(i,j,k)=fs%P(i,j,fs%cfg%kmax) + fs%I(i,j,k)=fs%I(i,j,fs%cfg%kmax) + fs%U(i,j,k)=fs%U(i,j,fs%cfg%kmax) + fs%V(i,j,k)=fs%V(i,j,fs%cfg%kmax) + fs%W(i,j,k)=max(fs%W(i,j,fs%cfg%kmax),0.0_WP) + end do + end do; end do + end if + + ! Apply clipped Neumann on primitive variables in z- + if (.not.fs%cfg%zper.and.fs%cfg%kproc.eq.1) then + do j=fs%cfg%jmino_,fs%cfg%jmaxo_; do i=fs%cfg%imino_,fs%cfg%imaxo_ + ! First copy over W from kmin+1 to kmin + fs%W(i,j,fs%cfg%kmin)=min(fs%W(i,j,fs%cfg%kmin+1),0.0_WP) + ! Then copy over from kmin to kmin-1 and below + do k=fs%cfg%kmino,fs%cfg%kmin-1 + ! Copy primitive variables + ls%VF(i,j,k)=ls%VF(i,j,fs%cfg%kmin) + fs%Q(i,j,k,1)=fs%Q(i,j,fs%cfg%kmin,1) + fs%P(i,j,k)=fs%P(i,j,fs%cfg%kmin) + fs%I(i,j,k)=fs%I(i,j,fs%cfg%kmin) + fs%U(i,j,k)=fs%U(i,j,fs%cfg%kmin) + fs%V(i,j,k)=fs%V(i,j,fs%cfg%kmin) + fs%W(i,j,k)=min(fs%W(i,j,fs%cfg%kmin),0.0_WP) + end do + end do; end do + end if + + ! Rebuild conserved quantities + fs%Q(:,:,:,2)=fs%Q(:,:,:,1)*fs%I + call fs%get_momentum() + + end subroutine apply_bconds + + + !> Initialization of problem solver + subroutine simulation_init + use param, only: param_read,param_exists + implicit none + + + ! Create compressible flow solver + create_flow_solver: block + call fs%initialize(cfg=cfg,name='Compressible NS') + end block create_flow_solver + + + ! Allocate work arrays + allocate_work_arrays: block + allocate(dQdt (cfg%imino_:cfg%imaxo_,cfg%jmino_:cfg%jmaxo_,cfg%kmino_:cfg%kmaxo_,1:fs%nQ)) + allocate(Ui (cfg%imino_:cfg%imaxo_,cfg%jmino_:cfg%jmaxo_,cfg%kmino_:cfg%kmaxo_)) + allocate(Vi (cfg%imino_:cfg%imaxo_,cfg%jmino_:cfg%jmaxo_,cfg%kmino_:cfg%kmaxo_)) + allocate(Wi (cfg%imino_:cfg%imaxo_,cfg%jmino_:cfg%jmaxo_,cfg%kmino_:cfg%kmaxo_)) + allocate(Ma (cfg%imino_:cfg%imaxo_,cfg%jmino_:cfg%jmaxo_,cfg%kmino_:cfg%kmaxo_)) + allocate(beta (cfg%imino_:cfg%imaxo_,cfg%jmino_:cfg%jmaxo_,cfg%kmino_:cfg%kmaxo_)) + allocate(visc (cfg%imino_:cfg%imaxo_,cfg%jmino_:cfg%jmaxo_,cfg%kmino_:cfg%kmaxo_)) + allocate(visc_t(cfg%imino_:cfg%imaxo_,cfg%jmino_:cfg%jmaxo_,cfg%kmino_:cfg%kmaxo_)) + allocate(div (cfg%imino_:cfg%imaxo_,cfg%jmino_:cfg%jmaxo_,cfg%kmino_:cfg%kmaxo_)) + end block allocate_work_arrays + + + ! Initialize time tracker with 2 subiterations + initialize_timetracker: block + time=timetracker(amRoot=cfg%amRoot) + call param_read('Max timestep size',time%dtmax) + call param_read('Max cfl number',time%cflmax) + call param_read('Max time',time%tmax) + time%dt=time%dtmax + time%itmax=2 + end block initialize_timetracker + + + ! Initialize Lagrangian solid solver + initialize_lss: block + use mathtools, only: Pi + real(WP) :: mu,kk,max_stretch,dx,theta + integer :: np + type triangle_type + real(WP), dimension(3) :: norm + real(WP), dimension(3) :: v1 + real(WP), dimension(3) :: v2 + real(WP), dimension(3) :: v3 + end type triangle_type + type(triangle_type), dimension(:), allocatable :: t + + ! Create solver + ls=lss(cfg=cfg,name='solid') + + ! Set material properties + call param_read('Elastic Modulus',ls%elastic_modulus) + call param_read('Poisson Ratio',ls%poisson_ratio) + call param_read('Solid density',ls%rho) + call param_read('Critical Energy Release Rate',ls%crit_energy) + call param_read('Initial Solid Angle',theta,default=0.0_WP) + + ! Maximum timestep size used for particles + call param_read('Particle timestep size',ls_dt_max,default=huge(1.0_WP)) + ls_dt=min(ls_dt_max,time%dtmax) + ls_it=0 + + ! Discretization + !ls%delta=fs%cfg%min_meshsize + + ! Discretization + dx=fs%cfg%min_meshsize/3.0_WP + ls%delta=3.0_WP*dx + + ! Output some info on stretch + mu=ls%elastic_modulus/(2.0_WP+2.0_WP*ls%poisson_ratio) + kk=ls%elastic_modulus/(3.0_WP-6.0_WP*ls%poisson_ratio) + if (fs%cfg%nx.eq.1.or.fs%cfg%ny.eq.1.or.fs%cfg%nz.eq.1) then + max_stretch=sqrt(ls%crit_energy/((6.0_WP*mu/Pi+16.0_WP/(9.0_WP*Pi**2)*(kk-2.0_WP*mu))*ls%delta)) + else + max_stretch=sqrt(ls%crit_energy/((3.0_WP*mu+(kk-5.0_WP*mu/3.0_WP)*0.75_WP**4)*ls%delta)) + end if + + ! First object ===================== + object1: block + use mpi_f08, only: MPI_BCAST + use parallel, only: MPI_REAL_WP + integer :: i,j,k,nx,ny,nz,iunit,ierr + real(WP) :: Lx,Ly,Lz,xr,yr + real(WP), dimension(:), allocatable :: x,y,z + if (ls%cfg%amRoot) then + ! Object size + Lx=0.5_WP; Ly=0.5_WP; Lz=0.5_WP + Rcyl=Lx + ! Create simple rectilinear grid + nx=int(Lx/dx) + ny=int(Ly/dx) + nz=int(Lz/dx) + allocate(x(1:nx),y(1:ny),z(1:nz)) + do i=1,nx + x(i)=real(i-1,WP)*dx+0.5_WP*dx + end do + do j=1,ny + y(j)=real(j-1,WP)*dx-0.5_WP*Ly+0.5_WP*dx + end do + do k=1,nz + z(k)=real(k-1,WP)*dx-0.5_WP*Lz+0.5_WP*dx + end do + ! Set angle of cube + theta=theta*Pi/180.0_WP + ! Loop over mesh and create particles + np=0 + do k=1,nz + do j=1,ny + do i=1,nx + ! Increment particle + np=np+1 + call ls%resize(np) + ! Set position + xr=x(i)*cos(theta)-y(j)*sin(theta) + yr=x(i)*sin(theta)+y(j)*cos(theta) + ls%p(np)%pos=[xr,yr,z(k)] + ! Set object id and velocity + ls%p(np)%id=1 + ls%p(np)%vel=0.0_WP + ! Set object volume + ls%p(np)%vol=dx**3 + ! Zero out force + ls%p(np)%Abond=0.0_WP + ls%p(np)%Afluid=0.0_WP + ! Locate the particle on the mesh + ls%p(np)%ind=ls%cfg%get_ijk_global(ls%p(np)%pos,[ls%cfg%imin,ls%cfg%jmin,ls%cfg%kmin]) + ! Assign a unique integer to particle + ls%p(np)%i=np + ! Activate the particle + ls%p(np)%flag=0 + end do + end do + end do + deallocate(x,y,z) + end if + ! Communicate radius + call MPI_BCAST(Rcyl,1,MPI_REAL_WP,0,cfg%comm,ierr) + end block object1 + + ! Communicate particles + call ls%sync() + + ! Get initial volume fraction + call ls%update_VF() + + ! Initalize bonds + call ls%bond_init() + + if (ls%cfg%amRoot) then + print*,"===== Solid Setup Description =====" + print*,'Number of particles', np + print*,'Maximum stretching',max_stretch + print*,'Min particle spacing',ls%min_dist + end if + + end block initialize_lss + + + ! Initialize eos and flow parameters + initialize_parameters: block + use string, only: str_long + use messager, only: log + use param, only: param_read + character(str_long) :: message + ! Set Pinf to zero + Pinf=0.0_WP + ! Read in Gamma + call param_read('Gamma',Gamma) + ! Read in Prandtl number + call param_read('Prandtl number',Prandtl) + ! Read in shock Mach number and location + call param_read('Shock Mach number',Ms) + call param_read('Shock location',Xs) + ! First generate static shock with normalized pre-shock conditions + M1=Ms + rho1=1.0_WP + rho2=rho1*(Gamma+1.0_WP)*M1**2/((Gamma-1.0_WP)*M1**2+2.0_WP) + p1=0.25_WP*rho1/Gamma*((Gamma+1.0_WP)*M1/(M1**2-1.0_WP))**2 ! Ensures that |u2-u1|=1 + p2=p1*(2.0_WP*Gamma/(Gamma+1.0_WP)*(M1**2-1.0_WP)+1.0_WP) + u1=M1*sqrt(Gamma*p1/rho1) + u2=u1*rho1/rho2 + ! Now shift frame of reference to obtain moving shock + u2=abs(u2-u1); M2=u2/sqrt(Gamma*p2/rho2); u1=0.0_WP; M1=u1/sqrt(Gamma*p1/rho1) + ! Set heat capacities corresponding to a normalized pre-shock + Cv=(p1+Pinf)/(rho1*(Gamma-1.0_WP)) + ! Get reference temperature based on post-shock conditions + T0=get_T(rho2,p2) + ! Define viscosity based on post-shock Reynolds number + call param_read('Reynolds number',Re); visc0=rho2*2.0_WP*Rcyl*u2/Re + ! Output case info + if (cfg%amRoot) then + write(message,'("[Gas EOS] => Gamma=",es12.5)') Gamma; call log(message) + write(message,'("[Gas EOS] => Cv=",es12.5)') Cv; call log(message) + write(message,'("[Shock Mach number] => Ms=",es12.5)') Ms; call log(message) + write(message,'("[Pre -shock conditions] => rho1=",es12.5)') rho1; call log(message) + write(message,'("[Pre -shock conditions] => p1=",es12.5)') p1; call log(message) + write(message,'("[Pre -shock conditions] => u1=",es12.5)') u1; call log(message) + write(message,'("[Pre -shock conditions] => M1=",es12.5)') M1; call log(message) + write(message,'("[Post-shock conditions] => rho2=",es12.5)') rho2; call log(message) + write(message,'("[Post-shock conditions] => p2=",es12.5)') p2; call log(message) + write(message,'("[Post-shock conditions] => u2=",es12.5)') u2; call log(message) + write(message,'("[Post-shock conditions] => M2=",es12.5)') M2; call log(message) + write(message,'("[Gas Reynolds] => Re=",es12.5)') Re; call log(message) + write(message,'("[Gas viscosity] => mu=",es12.5)') visc0; call log(message) + end if + end block initialize_parameters + + + ! Create partmesh object for visualizing Lagrangian particles + create_pmesh: block + use lss_class, only: max_bond + integer :: i,n,nbond + pmesh=partmesh(nvar=3,nvec=2,name='solid') + pmesh%varname(1)='failfrac' + pmesh%varname(2)='dilatation' + pmesh%varname(3)='volume' + pmesh%vecname(1)='velocity' + pmesh%vecname(2)='bond_force' + call ls%update_partmesh(pmesh) + do i=1,ls%np_ + pmesh%var(1,i)=0.0_WP + nbond=0 + do n=1,max_bond + if (ls%p(i)%ibond(n).gt.0) nbond=nbond+1 + end do + if (ls%p(i)%nbond.gt.0) then + pmesh%var(1,i)=1.0_WP-real(nbond,WP)/real(ls%p(i)%nbond,WP) + else + pmesh%var(1,i)=0.0_WP + end if + pmesh%var(2,i) =ls%p(i)%dil + pmesh%var(3,i) =ls%p(i)%vol + pmesh%vec(:,1,i)=ls%p(i)%vel + pmesh%vec(:,2,i)=ls%p(i)%Abond + end do + end block create_pmesh + + + ! Initialize variables + initialize_variables: block + integer :: i,j,k + ! Provide thermodynamic model + fs%getP=>get_P; fs%getC=>get_C; fs%getS=>get_S; fs%getT=>get_T + ! Initialize primary variables to normal shock + do k=cfg%kmino_,cfg%kmaxo_ + do j=cfg%jmino_,cfg%jmaxo_ + do i=cfg%imino_,cfg%imaxo_ + fs%U(i,j,k) =u2*Hshock(Xs-fs%cfg%x(i),delta=0.5_WP*fs%dx) + fs%V(i,j,k) =0.0_WP + fs%W(i,j,k) =0.0_WP + fs%Q(i,j,k,1)=rho1+(rho2-rho1)*Hshock(Xs-fs%cfg%xm(i),delta=0.5_WP*fs%dx) + fs%P(i,j,k) =p1 +(p2 -p1 )*Hshock(Xs-fs%cfg%xm(i),delta=0.5_WP*fs%dx) + fs%I(i,j,k) =get_I(fs%Q(i,j,k,1),fs%P(i,j,k)) + end do + end do + end do + ! Initialize conserved variables + fs%Q(:,:,:,2)=fs%Q(:,:,:,1)*fs%I + call fs%get_momentum() + ! Rebuild primitive variables + call fs%get_primitive() + ! Interpolate velocity + call fs%interp_vel(Ui,Vi,Wi) + ! Compute local Mach number + Ma=sqrt(Ui**2+Vi**2+Wi**2)/fs%C + ! Compute dilatation + call get_div() + ! Compute viscosities + call prepare_viscosities() + end block initialize_variables + + + ! Add Ensight output + create_ensight: block + ! Create Ensight output from cfg + ens_out=ensight(cfg=cfg,name='shock') + ! Create event for Ensight output + ens_evt=event(time=time,name='Ensight output') + call param_read('Ensight output period',ens_evt%tper) + ! Add variables to output + call ens_out%add_particle('particles',pmesh) + call ens_out%add_vector('velocity',Ui,Vi,Wi) + call ens_out%add_vector('velocity_s',ls%VFU,ls%VFV,ls%VFW) + call ens_out%add_scalar('P',fs%P) + call ens_out%add_scalar('T',fs%T) + call ens_out%add_scalar('Mach',Ma) + call ens_out%add_scalar('beta',beta) + call ens_out%add_scalar('visc',visc) + call ens_out%add_scalar('visc_t',visc_t) + call ens_out%add_scalar('div',div) + call ens_out%add_scalar('VFs',ls%VF) + ! Output to ensight + if (ens_evt%occurs()) call ens_out%write_data(time%t) + end block create_ensight + + + ! Create monitor files + create_monitor: block + real(WP) :: cfl + ! Prepare some info about fields + call ls%get_cfl(time%dt,time%cfl) + call fs%get_cfl(time%dt,cfl); time%cfl=max(cfl,time%cfl) + call fs%get_info() + call ls%get_max() + ! Create simulation monitor + mfile=monitor(fs%cfg%amRoot,'simulation') + call mfile%add_column(time%n,'Timestep number') + call mfile%add_column(time%t,'Time') + call mfile%add_column(time%dt,'Timestep size') + call mfile%add_column(time%cfl,'Maximum CFL') + call mfile%add_column(fs%Umax,'Umax') + call mfile%add_column(fs%Vmax,'Vmax') + call mfile%add_column(fs%Wmax,'Wmax') + call mfile%add_column(fs%RHOmax,'max(RHO)') + call mfile%add_column(fs%RHOmin,'min(RHO)') + call mfile%add_column(fs%Pmax ,'max(P)' ) + call mfile%add_column(fs%Pmin ,'min(P)' ) + call mfile%add_column(fs%Tmax ,'max(T)' ) + call mfile%add_column(fs%Tmin ,'min(T)' ) + call mfile%write() + ! Create CFL monitor + cflfile=monitor(fs%cfg%amRoot,'cfl') + call cflfile%add_column(time%n,'Timestep number') + call cflfile%add_column(time%t,'Time') + call cflfile%add_column(fs%CFLc_x,'Convective xCFL') + call cflfile%add_column(fs%CFLc_y,'Convective yCFL') + call cflfile%add_column(fs%CFLc_z,'Convective zCFL') + call cflfile%add_column(fs%CFLa_x,'Acoustic xCFL') + call cflfile%add_column(fs%CFLa_y,'Acoustic yCFL') + call cflfile%add_column(fs%CFLa_z,'Acoustic zCFL') + call cflfile%add_column(fs%CFLv_x,'Viscous xCFL') + call cflfile%add_column(fs%CFLv_y,'Viscous yCFL') + call cflfile%add_column(fs%CFLv_z,'Viscous zCFL') + call cflfile%add_column(ls%CFLp_x,'Particle xCFL') + call cflfile%add_column(ls%CFLp_y,'Particle yCFL') + call cflfile%add_column(ls%CFLp_z,'Particle zCFL') + call cflfile%add_column(ls%CFLp_a,'Particle aCFL') + call cflfile%write() + ! Create conservation monitor + consfile=monitor(fs%cfg%amRoot,'conservation') + call consfile%add_column(time%n,'Timestep number') + call consfile%add_column(time%t,'Time') + call consfile%add_column(fs%Qint(1),'Mass') + call consfile%add_column(fs%Qint(2),'Energy') + call consfile%add_column(fs%Qint(3),'U Momentum') + call consfile%add_column(fs%Qint(4),'V Momentum') + call consfile%add_column(fs%Qint(5),'W Momentum') + call consfile%add_column(fs%RHOKint,'Kinetic Energy') + call consfile%add_column(fs%RHOSint,'Entropy') + call consfile%write() + ! Create solid monitor + sfile=monitor(ls%cfg%amRoot,'solid') + call sfile%add_column(time%n,'Timestep number') + call sfile%add_column(time%t,'Time') + call sfile%add_column(ls_dt,'Particle dt') + call sfile%add_column(ls_it,'Particle sub-iter') + call sfile%add_column(time%cfl,'Maximum CFL') + call sfile%add_column(ls%np,'Particle number') + call sfile%add_column(ls%VFmax,'VFmax') + call sfile%add_column(ls%Umin,'Particle Umin') + call sfile%add_column(ls%Umax,'Particle Umax') + call sfile%add_column(ls%Vmin,'Particle Vmin') + call sfile%add_column(ls%Vmax,'Particle Vmax') + call sfile%add_column(ls%Wmin,'Particle Wmin') + call sfile%add_column(ls%Wmax,'Particle Wmax') + call sfile%add_column(ls%ibmForce(1),'Particle Fx') + call sfile%add_column(ls%ibmForce(2),'Particle Fy') + call sfile%add_column(ls%ibmForce(3),'Particle Fz') + call sfile%write() + end block create_monitor + + end subroutine simulation_init + + + !> Perform an NGA2 simulation + subroutine simulation_run + implicit none + real(WP) :: cfl + + ! Perform time integration + do while (.not.time%done()) + + ! Increment time + call fs%get_cfl(time%dt,time%cfl) + call time%adjust_dt() + call time%increment() + + ! Advance solid solver + solid: block + real(WP) :: dt_done,mydt + ! Compute divergence of fluid stress + call fs%get_div_stress(divx=dQdt(:,:,:,1),divy=dQdt(:,:,:,2),divz=dQdt(:,:,:,3)) + ! Sub-iteratore + call ls%get_cfl(ls_dt,cfl=cfl) + if (cfl.gt.0.0_WP) ls_dt=min(ls_dt*time%cflmax/cfl,ls_dt_max) + dt_done=0.0_WP + ls_it=0 + do while (dt_done.lt.time%dtmid) + ! Decide the timestep size + mydt=min(ls_dt,time%dtmid-dt_done) + ! Advance particles + call ls%advance(dt =mydt, & + & stress_x=dQdt(:,:,:,1),& + & stress_y=dQdt(:,:,:,2),& + & stress_z=dQdt(:,:,:,3)) + ! Increment + dt_done=dt_done+mydt + ls_it=ls_it+1 + end do + end block solid + + ! Remember conserved variables + fs%Qold=fs%Q + + ! Prepare SGS viscosity models + call prepare_viscosities() + + ! First RK step ==================================================================================== + ! Get RHS and increment + call fs%rhs(dQdt) + fs%Q=fs%Qold+0.5_WP*time%dt*dQdt + ! Apply IBM + call apply_ibm() + + ! Second RK step =================================================================================== + ! Get RHS and increment at midpoint + call fs%rhs(dQdt) + fs%Q=fs%Qold+time%dt*dQdt + ! Apply IBM + call apply_ibm() + + ! Apply boundary conditions + call apply_bconds() + + ! Interpolate velocity + call fs%interp_vel(Ui,Vi,Wi) + + ! Compute local Mach number + Ma=sqrt(Ui**2+Vi**2+Wi**2)/fs%C + + ! Compute dilatation + call get_div() + + !> Perform and output monitoring + call fs%get_info() + call ls%get_max() + call mfile%write() + call cflfile%write() + call consfile%write() + call sfile%write() + + ! Output to ensight + if (ens_evt%occurs()) then + update_pmesh: block + use lss_class, only: max_bond + integer :: i,n,nbond + call ls%update_partmesh(pmesh) + do i=1,ls%np_ + nbond=0 + do n=1,max_bond + if (ls%p(i)%ibond(n).gt.0) nbond=nbond+1 + end do + if (ls%p(i)%nbond.gt.0) then + pmesh%var(1,i)=1.0_WP-real(nbond,WP)/real(ls%p(i)%nbond,WP) + else + pmesh%var(1,i)=0.0_WP + end if + pmesh%var(2,i) =ls%p(i)%dil + pmesh%var(3,i) =ls%p(i)%vol + pmesh%vec(:,1,i)=ls%p(i)%vel + pmesh%vec(:,2,i)=ls%p(i)%Abond + end do + end block update_pmesh + call ens_out%write_data(time%t) + end if + + end do + + end subroutine simulation_run + + + !> Finalize the NGA2 simulation + subroutine simulation_final + implicit none + + ! Get rid of all objects - need destructors + ! monitor + ! ensight + ! bcond + ! timetracker + + ! Deallocate work arrays + deallocate(dQdt,Ui,Vi,Wi,Ma,beta,visc,visc_t,div) + + end subroutine simulation_final + + +end module simulation diff --git a/examples/peridynamics_shock_orig_DELETE/src/spcomp_class.f90 b/examples/peridynamics_shock_orig_DELETE/src/spcomp_class.f90 new file mode 100644 index 000000000..00ec1fe25 --- /dev/null +++ b/examples/peridynamics_shock_orig_DELETE/src/spcomp_class.f90 @@ -0,0 +1,942 @@ +!> Single phase compressible flow solver class: +!> Provides support for RHS calculation only +module spcomp_class + use precision, only: WP + use string, only: str_medium + use config_class, only: config + use timer_class, only: timer + implicit none + private + + ! Expose type + public :: spcomp + + !> Single phase compressible solver object definition + type :: spcomp + + ! This is the config around which solver is built + class(config), pointer :: cfg + + ! Solver name + character(len=str_medium) :: name='UNNAMED_SPCOMP' + + ! Pointers to functions to evaluate P(RHO,E), T(RHO,P), and C(RHO,P) + procedure(Pfunc_type), pointer, nopass :: getP=>NULL() + procedure(Tfunc_type), pointer, nopass :: getT=>NULL() + procedure(Cfunc_type), pointer, nopass :: getC=>NULL() + procedure(Sfunc_type), pointer, nopass :: getS=>NULL() + + ! Conserved variables: 1=RHO, 2=RHO*I, 3=RHO*U, 4=RHO*V, 5=RHO*W + integer :: nQ + real(WP), dimension(:,:,:,:), allocatable :: Q,Qold + + ! Flow velocity + real(WP), dimension(:,:,:), allocatable :: U,V,W + + ! Internal energy + real(WP), dimension(:,:,:), allocatable :: I + + ! Pressure + real(WP), dimension(:,:,:), allocatable :: P + + ! Temperature + real(WP), dimension(:,:,:), allocatable :: T + + ! Speed of sound + real(WP), dimension(:,:,:), allocatable :: C + + ! Viscosities and heat diffusivity + real(WP), dimension(:,:,:), allocatable :: VISC,BETA,DIFF + + ! Gravitational acceleration + real(WP), dimension(3) :: gravity=0.0_WP + + ! Store mesh info + real(WP) :: dx,dy,dz,dxi,dyi,dzi,vol + + ! CFL numbers + real(WP) :: CFLc_x,CFLc_y,CFLc_z !< Convective CFL numbers + real(WP) :: CFLa_x,CFLa_y,CFLa_z !< Acoustic CFL numbers + real(WP) :: CFLv_x,CFLv_y,CFLv_z !< Viscous CFL numbers + + ! Monitoring quantities for conserved variables + real(WP), dimension(:), allocatable :: Qmin,Qmax,Qint + real(WP) :: RHOKint + real(WP) :: RHOSint + + ! Monitoring quantities for primitive variables + real(WP) :: Umax,Vmax,Wmax !< Velocity stats + real(WP) :: RHOmin,RHOmax !< Density stats + real(WP) :: Imin,Imax !< Internal energy stats + real(WP) :: Pmin,Pmax !< Pressure stats + real(WP) :: Tmin,Tmax !< Temperature stats + + ! Timer + type(timer) :: trhs !< Timer for RHS calculation + + contains + procedure :: print=>spcomp_print !< Output solver to the screen + procedure :: initialize !< Initialize the flow solver + procedure :: finalize !< Finalize the flow solver + procedure :: get_div_stress !< Compute divergence of stress for LSS solver + procedure :: rhs !< Compute rhs of our equations using standard fluxes + procedure :: get_primitive !< Calculate primitive variables from conserved variables + procedure :: get_viscartif !< Calculate artifical bulk kinematic viscosity + procedure :: get_vreman !< Get kinematic eddy viscosity using Vreman's model + procedure :: get_velocity !< Calculate velocity from momentum + procedure :: get_ke !< Calculate kinetic energy per unit mass from velocity + procedure :: get_momentum !< Calculate momentum from velocity + procedure :: interp_vel !< Calculate interpolated velocity + procedure :: get_cfl !< Calculate maximum CFL + procedure :: get_info !< Calculate maximum field values + end type spcomp + + !> Interfaces for user-defined function + abstract interface + !> P=P(RHO,I) + pure real(WP) function Pfunc_type(RHO,I) + import :: WP + implicit none + real(WP), intent(in) :: RHO + real(WP), intent(in) :: I + end function Pfunc_type + !> T=T(RHO,P) + pure real(WP) function Tfunc_type(RHO,P) + import :: WP + implicit none + real(WP), intent(in) :: RHO + real(WP), intent(in) :: P + end function Tfunc_type + !> C=C(RHO,P) + pure real(WP) function Cfunc_type(RHO,P) + import :: WP + implicit none + real(WP), intent(in) :: RHO + real(WP), intent(in) :: P + end function Cfunc_type + !> S=S(RHO,P) + pure real(WP) function Sfunc_type(RHO,P) + import :: WP + implicit none + real(WP), intent(in) :: RHO + real(WP), intent(in) :: P + end function Sfunc_type + end interface + +contains + + + !> Initialization for compressible flow solver + subroutine initialize(this,cfg,name) + use messager, only: die + implicit none + class(spcomp) :: this + class(config), target, intent(in) :: cfg + character(len=*), optional :: name + + ! Set the name for the solver + if (present(name)) this%name=trim(adjustl(name)) + + ! Point to config object + this%cfg=>cfg + + ! Check that config is uniform with at least 2 cells of overlap + if (this%cfg%no.lt.2) call die('[spcomp initialize] spcomp solver requires at least 2 cells of overlap') + if (.not.all([this%cfg%uniform_x,this%cfg%uniform_y,this%cfg%uniform_z])) call die('[spcomp initialize] spcomp solver requires a uniform mesh') + + ! Store constant cell size and its inverse, handle 2D conditions, store cell volume + this%dx=this%cfg%dx(this%cfg%imin_); this%dxi=1.0_WP/this%dx; if (this%cfg%nx.eq.1) this%dxi=0.0_WP + this%dy=this%cfg%dy(this%cfg%jmin_); this%dyi=1.0_WP/this%dy; if (this%cfg%ny.eq.1) this%dyi=0.0_WP + this%dz=this%cfg%dz(this%cfg%kmin_); this%dzi=1.0_WP/this%dz; if (this%cfg%nz.eq.1) this%dzi=0.0_WP + this%vol=this%dx*this%dy*this%dz + + ! Allocate and zero out conserved variables + this%nQ=5 + allocate(this%Q (this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_,1:this%nQ)); this%Q =0.0_WP + allocate(this%Qold(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_,1:this%nQ)); this%Qold=0.0_WP + + ! Conserved variables monitoring + allocate(this%Qmin(1:this%nQ),this%Qmax(1:this%nQ),this%Qint(1:this%nQ)) + + ! Flow velocity + allocate(this%U(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)); this%U=0.0_WP + allocate(this%V(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)); this%V=0.0_WP + allocate(this%W(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)); this%W=0.0_WP + + ! Internal energy + allocate(this%I(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)); this%I=0.0_WP + + ! Pressure + allocate(this%P(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)); this%P=0.0_WP + + ! Temperature + allocate(this%T(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)); this%T=0.0_WP + + ! Speed of sound + allocate(this%C(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)); this%C=0.0_WP + + ! Viscosities and heat diffusivity + allocate(this%VISC(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)); this%VISC=0.0_WP + allocate(this%BETA(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)); this%BETA=0.0_WP + allocate(this%DIFF(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)); this%DIFF=0.0_WP + + ! Create timers + this%trhs=timer(comm=this%cfg%comm,name='RHS') + + end subroutine initialize + + + !> Obtain RHS for all equations + subroutine rhs(this,dQdt) + implicit none + class(spcomp), intent(inout) :: this + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:,1:), intent(out) :: dQdt !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_,1:nVAR) + real(WP), dimension(:,:,:,:), allocatable :: FQx,FQy,FQz + integer :: i,j,k,n + real(WP) :: w,div + real(WP), parameter :: eps=1.0e-15_WP + real(WP), dimension(-2: 0) :: wenop + real(WP), dimension(-1:+1) :: wenom + + ! Start rhs timer + call this%trhs%start() + + ! Zero out RHS + dQdt=0.0_WP + + ! ================================================================ ! + ! ======================== INVISID FLUXES ======================== ! + ! ================================================================ ! + + ! Allocate fluxes of conserved variables + allocate(FQx(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_,1:this%nQ)); FQx=0.0_WP + allocate(FQy(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_,1:this%nQ)); FQy=0.0_WP + allocate(FQz(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_,1:this%nQ)); FQz=0.0_WP + + ! Calculate standard fluxes + do k=this%cfg%kmin_,this%cfg%kmax_+1 + do j=this%cfg%jmin_,this%cfg%jmax_+1 + do i=this%cfg%imin_,this%cfg%imax_+1 + ! X fluxes + ! WENO mass flux + w=weno_weight((abs(this%Q(i-1,j,k,1)-this%Q(i-2,j,k,1))+eps)/(abs(this%Q(i,j,k,1)-this%Q(i-1,j,k,1))+eps)); wenop=0.5_WP*[ -w,1.0_WP+2.0_WP*w,1.0_WP-w] + w=weno_weight((abs(this%Q(i+1,j,k,1)-this%Q(i ,j,k,1))+eps)/(abs(this%Q(i,j,k,1)-this%Q(i-1,j,k,1))+eps)); wenom=0.5_WP*[1.0_WP-w,1.0_WP+2.0_WP*w, -w] + FQx(i,j,k,1)=-0.5_WP*(this%U(i,j,k)+abs(this%U(i,j,k)))*sum(wenop*this%Q(i-2:i ,j,k,1))& + & -0.5_WP*(this%U(i,j,k)-abs(this%U(i,j,k)))*sum(wenom*this%Q(i-1:i+1,j,k,1)) + ! Centered mass flux + !FQx(i,j,k,1)=-this%U(i,j,k)*0.5_WP*sum(this%Q(i-1:i,j,k,1)) + ! WENO internal energy flux + w=weno_weight((abs(this%I(i-1,j,k)-this%I(i-2,j,k))+eps)/(abs(this%I(i,j,k)-this%I(i-1,j,k))+eps)); wenop=0.5_WP*[ -w,1.0_WP+2.0_WP*w,1.0_WP-w] + w=weno_weight((abs(this%I(i+1,j,k)-this%I(i ,j,k))+eps)/(abs(this%I(i,j,k)-this%I(i-1,j,k))+eps)); wenom=0.5_WP*[1.0_WP-w,1.0_WP+2.0_WP*w, -w] + FQx(i,j,k,2)=0.5_WP*(FQx(i,j,k,1)-abs(-FQx(i,j,k,1)))*sum(wenop*this%I(i-2:i ,j,k))& + & +0.5_WP*(FQx(i,j,k,1)+abs(-FQx(i,j,k,1)))*sum(wenom*this%I(i-1:i+1,j,k)) + ! Centered internal energy flux + !FQx(i,j,k,2)=FQx(i,j,k,1)*0.5_WP*sum(this%I(i-1:i,j,k)) + ! Heat flux + FQx(i,j,k,2)=FQx(i,j,k,2)+0.5_WP*(this%DIFF(i-1,j,k)+this%DIFF(i,j,k))*this%dxi*(this%T(i,j,k)-this%T(i-1,j,k)) + ! Y fluxes + ! WENO mass flux + w=weno_weight((abs(this%Q(i,j-1,k,1)-this%Q(i,j-2,k,1))+eps)/(abs(this%Q(i,j,k,1)-this%Q(i,j-1,k,1))+eps)); wenop=0.5_WP*[ -w,1.0_WP+2.0_WP*w,1.0_WP-w] + w=weno_weight((abs(this%Q(i,j+1,k,1)-this%Q(i,j ,k,1))+eps)/(abs(this%Q(i,j,k,1)-this%Q(i,j-1,k,1))+eps)); wenom=0.5_WP*[1.0_WP-w,1.0_WP+2.0_WP*w, -w] + FQy(i,j,k,1)=-0.5_WP*(this%V(i,j,k)+abs(this%V(i,j,k)))*sum(wenop*this%Q(i,j-2:j ,k,1))& + & -0.5_WP*(this%V(i,j,k)-abs(this%V(i,j,k)))*sum(wenom*this%Q(i,j-1:j+1,k,1)) + ! Centered mass flux + !FQy(i,j,k,1)=-this%V(i,j,k)*0.5_WP*sum(this%Q(i,j-1:j,k,1)) + ! WENO internal energy flux + w=weno_weight((abs(this%I(i,j-1,k)-this%I(i,j-2,k))+eps)/(abs(this%I(i,j,k)-this%I(i,j-1,k))+eps)); wenop=0.5_WP*[ -w,1.0_WP+2.0_WP*w,1.0_WP-w] + w=weno_weight((abs(this%I(i,j+1,k)-this%I(i,j ,k))+eps)/(abs(this%I(i,j,k)-this%I(i,j-1,k))+eps)); wenom=0.5_WP*[1.0_WP-w,1.0_WP+2.0_WP*w, -w] + FQy(i,j,k,2)=0.5_WP*(FQy(i,j,k,1)-abs(-FQy(i,j,k,1)))*sum(wenop*this%I(i,j-2:j ,k))& + & +0.5_WP*(FQy(i,j,k,1)+abs(-FQy(i,j,k,1)))*sum(wenom*this%I(i,j-1:j+1,k)) + ! Centered internal energy flux + !FQy(i,j,k,2)=FQy(i,j,k,1)*0.5_WP*sum(this%I(i,j-1:j,k)) + ! Heat flux + FQy(i,j,k,2)=FQy(i,j,k,2)+0.5_WP*(this%DIFF(i,j-1,k)+this%DIFF(i,j,k))*this%dyi*(this%T(i,j,k)-this%T(i,j-1,k)) + ! Z fluxes + ! WENO mass flux + w=weno_weight((abs(this%Q(i,j,k-1,1)-this%Q(i,j,k-2,1))+eps)/(abs(this%Q(i,j,k,1)-this%Q(i,j,k-1,1))+eps)); wenop=0.5_WP*[ -w,1.0_WP+2.0_WP*w,1.0_WP-w] + w=weno_weight((abs(this%Q(i,j,k+1,1)-this%Q(i,j,k ,1))+eps)/(abs(this%Q(i,j,k,1)-this%Q(i,j,k-1,1))+eps)); wenom=0.5_WP*[1.0_WP-w,1.0_WP+2.0_WP*w, -w] + FQz(i,j,k,1)=-0.5_WP*(this%W(i,j,k)+abs(this%W(i,j,k)))*sum(wenop*this%Q(i,j,k-2:k ,1))& + & -0.5_WP*(this%W(i,j,k)-abs(this%W(i,j,k)))*sum(wenom*this%Q(i,j,k-1:k+1,1)) + ! Centered mass flux + !FQz(i,j,k,1)=-this%W(i,j,k)*0.5_WP*sum(this%Q(i,j,k-1:k,1)) + ! WENO internal energy flux + w=weno_weight((abs(this%I(i,j,k-1)-this%I(i,j,k-2))+eps)/(abs(this%I(i,j,k)-this%I(i,j,k-1))+eps)); wenop=0.5_WP*[ -w,1.0_WP+2.0_WP*w,1.0_WP-w] + w=weno_weight((abs(this%I(i,j,k+1)-this%I(i,j,k ))+eps)/(abs(this%I(i,j,k)-this%I(i,j,k-1))+eps)); wenom=0.5_WP*[1.0_WP-w,1.0_WP+2.0_WP*w, -w] + FQz(i,j,k,2)=0.5_WP*(FQz(i,j,k,1)-abs(-FQz(i,j,k,1)))*sum(wenop*this%I(i,j,k-2:k ))& + & +0.5_WP*(FQz(i,j,k,1)+abs(-FQz(i,j,k,1)))*sum(wenom*this%I(i,j,k-1:k+1)) + ! Centered internal energy flux + !FQz(i,j,k,2)=FQz(i,j,k,1)*0.5_WP*sum(this%I(i,j,k-1:k)) + ! Heat flux + FQz(i,j,k,2)=FQz(i,j,k,2)+0.5_WP*(this%DIFF(i,j,k-1)+this%DIFF(i,j,k))*this%dzi*(this%T(i,j,k)-this%T(i,j,k-1)) + end do + end do + end do + + ! Mass fluxes will be used to build momentum fluxes, they need to be extended by one cell on the left because of staggering + call this%cfg%sync(FQx(:,:,:,1)); if (.not.this%cfg%xper.and.this%cfg%iproc.eq.1) FQx(this%cfg%imin-1,:,:,1)=FQx(this%cfg%imin,:,:,1) + call this%cfg%sync(FQy(:,:,:,1)); if (.not.this%cfg%yper.and.this%cfg%jproc.eq.1) FQy(:,this%cfg%jmin-1,:,1)=FQy(:,this%cfg%jmin,:,1) + call this%cfg%sync(FQz(:,:,:,1)); if (.not.this%cfg%zper.and.this%cfg%kproc.eq.1) FQz(:,:,this%cfg%kmin-1,1)=FQz(:,:,this%cfg%kmin,1) + + ! Calculate cell-centered momentum fluxes with extra cell on the left due to staggering + do k=this%cfg%kmin_-1,this%cfg%kmax_ + do j=this%cfg%jmin_-1,this%cfg%jmax_ + do i=this%cfg%imin_-1,this%cfg%imax_ + FQx(i,j,k,3)=0.25_WP*sum(FQx(i:i+1,j,k,1))*sum(this%U(i:i+1,j,k))-this%P(i,j,k) + FQy(i,j,k,4)=0.25_WP*sum(FQy(i,j:j+1,k,1))*sum(this%V(i,j:j+1,k))-this%P(i,j,k) + FQz(i,j,k,5)=0.25_WP*sum(FQz(i,j,k:k+1,1))*sum(this%W(i,j,k:k+1))-this%P(i,j,k) + end do + end do + end do + + ! Calculate edge-centered momentum fluxes + do k=this%cfg%kmin_,this%cfg%kmax_+1 + do j=this%cfg%jmin_,this%cfg%jmax_+1 + do i=this%cfg%imin_,this%cfg%imax_+1 + FQy(i,j,k,3)=0.25_WP*sum(FQy(i-1:i,j,k,1))*sum(this%U(i,j-1:j,k)) + FQz(i,j,k,3)=0.25_WP*sum(FQz(i-1:i,j,k,1))*sum(this%U(i,j,k-1:k)) + FQx(i,j,k,4)=0.25_WP*sum(FQx(i,j-1:j,k,1))*sum(this%V(i-1:i,j,k)) + FQz(i,j,k,4)=0.25_WP*sum(FQz(i,j-1:j,k,1))*sum(this%V(i,j,k-1:k)) + FQx(i,j,k,5)=0.25_WP*sum(FQx(i,j,k-1:k,1))*sum(this%W(i-1:i,j,k)) + FQy(i,j,k,5)=0.25_WP*sum(FQy(i,j,k-1:k,1))*sum(this%W(i,j-1:j,k)) + end do + end do + end do + + ! Assemble time derivative for conserved variables + do k=this%cfg%kmin_,this%cfg%kmax_ + do j=this%cfg%jmin_,this%cfg%jmax_ + do i=this%cfg%imin_,this%cfg%imax_ + ! Mass and internal energy advection + dQdt(i,j,k,1)=this%dxi*(FQx(i+1,j,k,1)-FQx(i,j,k,1))+this%dyi*(FQy(i,j+1,k,1)-FQy(i,j,k,1))+this%dzi*(FQz(i,j,k+1,1)-FQz(i,j,k,1)) + dQdt(i,j,k,2)=this%dxi*(FQx(i+1,j,k,2)-FQx(i,j,k,2))+this%dyi*(FQy(i,j+1,k,2)-FQy(i,j,k,2))+this%dzi*(FQz(i,j,k+1,2)-FQz(i,j,k,2)) + ! Momentum advection and pressure stress + dQdt(i,j,k,3)=this%dxi*(FQx(i ,j,k,3)-FQx(i-1,j,k,3))+this%dyi*(FQy(i,j+1,k,3)-FQy(i,j ,k,3))+this%dzi*(FQz(i,j,k+1,3)-FQz(i,j,k ,3)) + dQdt(i,j,k,4)=this%dxi*(FQx(i+1,j,k,4)-FQx(i ,j,k,4))+this%dyi*(FQy(i,j ,k,4)-FQy(i,j-1,k,4))+this%dzi*(FQz(i,j,k+1,4)-FQz(i,j,k ,4)) + dQdt(i,j,k,5)=this%dxi*(FQx(i+1,j,k,5)-FQx(i ,j,k,5))+this%dyi*(FQy(i,j+1,k,5)-FQy(i,j ,k,5))+this%dzi*(FQz(i,j,k ,5)-FQz(i,j,k-1,5)) + ! Pressure dilatation term + dQdt(i,j,k,2)=dQdt(i,j,k,2)-this%P(i,j,k)*(this%dxi*(this%U(i+1,j,k)-this%U(i,j,k))+this%dyi*(this%V(i,j+1,k)-this%V(i,j,k))+this%dzi*(this%W(i,j,k+1)-this%W(i,j,k))) + end do + end do + end do + + ! ================================================================ ! + ! ======================== VISCOUS FLUXES ======================= ! + ! ================================================================ ! + + ! Zero out fluxes + FQx=0.0_WP; FQy=0.0_WP; FQz=0.0_WP + + ! Compute cell-centered momentum viscous fluxes + do k=this%cfg%kmin_-1,this%cfg%kmax_ + do j=this%cfg%jmin_-1,this%cfg%jmax_ + do i=this%cfg%imin_-1,this%cfg%imax_ + div=this%dxi*(this%U(i+1,j,k)-this%U(i,j,k))+this%dyi*(this%V(i,j+1,k)-this%V(i,j,k))+this%dzi*(this%W(i,j,k+1)-this%W(i,j,k)) + FQx(i,j,k,3)=2.0_WP*this%VISC(i,j,k)*this%dxi*(this%U(i+1,j,k)-this%U(i,j,k))+(this%BETA(i,j,k)-2.0_WP*this%VISC(i,j,k)/3.0_WP)*div + FQy(i,j,k,4)=2.0_WP*this%VISC(i,j,k)*this%dyi*(this%V(i,j+1,k)-this%V(i,j,k))+(this%BETA(i,j,k)-2.0_WP*this%VISC(i,j,k)/3.0_WP)*div + FQz(i,j,k,5)=2.0_WP*this%VISC(i,j,k)*this%dzi*(this%W(i,j,k+1)-this%W(i,j,k))+(this%BETA(i,j,k)-2.0_WP*this%VISC(i,j,k)/3.0_WP)*div + end do + end do + end do + + ! Compute edge-centered momentum viscous fluxes and corresponding viscous heating + do k=this%cfg%kmin_,this%cfg%kmax_+1 + do j=this%cfg%jmin_,this%cfg%jmax_+1 + do i=this%cfg%imin_,this%cfg%imax_+1 + FQy(i,j,k,3)=0.25_WP*sum(this%VISC(i-1:i,j-1:j,k))*(this%dyi*(this%U(i,j,k)-this%U(i,j-1,k))+this%dxi*(this%V(i,j,k)-this%V(i-1,j,k))); FQx(i,j,k,4)=FQy(i,j,k,3) + FQz(i,j,k,2)=FQy(i,j,k,3)*(this%dyi*(this%U(i,j,k)-this%U(i,j-1,k))+this%dxi*(this%V(i,j,k)-this%V(i-1,j,k))) + FQz(i,j,k,4)=0.25_WP*sum(this%VISC(i,j-1:j,k-1:k))*(this%dzi*(this%V(i,j,k)-this%V(i,j,k-1))+this%dyi*(this%W(i,j,k)-this%W(i,j-1,k))); FQy(i,j,k,5)=FQz(i,j,k,4) + FQx(i,j,k,2)=FQz(i,j,k,4)*(this%dzi*(this%V(i,j,k)-this%V(i,j,k-1))+this%dyi*(this%W(i,j,k)-this%W(i,j-1,k))) + FQx(i,j,k,5)=0.25_WP*sum(this%VISC(i-1:i,j,k-1:k))*(this%dxi*(this%W(i,j,k)-this%W(i-1,j,k))+this%dzi*(this%U(i,j,k)-this%U(i,j,k-1))); FQz(i,j,k,3)=FQx(i,j,k,5) + FQy(i,j,k,2)=FQx(i,j,k,5)*(this%dxi*(this%W(i,j,k)-this%W(i-1,j,k))+this%dzi*(this%U(i,j,k)-this%U(i,j,k-1))) + end do + end do + end do + + ! Assemble time derivative for conserved variables + do k=this%cfg%kmin_,this%cfg%kmax_ + do j=this%cfg%jmin_,this%cfg%jmax_ + do i=this%cfg%imin_,this%cfg%imax_ + ! Viscous momentum transport + dQdt(i,j,k,3)=dQdt(i,j,k,3)+this%dxi*(FQx(i ,j,k,3)-FQx(i-1,j,k,3))+this%dyi*(FQy(i,j+1,k,3)-FQy(i,j ,k,3))+this%dzi*(FQz(i,j,k+1,3)-FQz(i,j,k ,3)) + dQdt(i,j,k,4)=dQdt(i,j,k,4)+this%dxi*(FQx(i+1,j,k,4)-FQx(i ,j,k,4))+this%dyi*(FQy(i,j ,k,4)-FQy(i,j-1,k,4))+this%dzi*(FQz(i,j,k+1,4)-FQz(i,j,k ,4)) + dQdt(i,j,k,5)=dQdt(i,j,k,5)+this%dxi*(FQx(i+1,j,k,5)-FQx(i ,j,k,5))+this%dyi*(FQy(i,j+1,k,5)-FQy(i,j ,k,5))+this%dzi*(FQz(i,j,k ,5)-FQz(i,j,k-1,5)) + ! Viscous heating term + dQdt(i,j,k,2)=dQdt(i,j,k,2)+FQx(i,j,k,3)*this%dxi*(this%U(i+1,j,k)-this%U(i,j,k))+FQy(i,j,k,4)*this%dyi*(this%V(i,j+1,k)-this%V(i,j,k))+FQz(i,j,k,5)*this%dzi*(this%W(i,j,k+1)-this%W(i,j,k))+0.25_WP*sum(FQz(i:i+1,j:j+1,k,2))+0.25_WP*sum(FQx(i,j:j+1,k:k+1,2))+0.25_WP*sum(FQy(i:i+1,j,k:k+1,2)) + end do + end do + end do + + ! Deallocate flux arrays + deallocate(FQx,FQy,FQz) + + ! Synchronize all dQdt fields + do n=1,this%nQ; call this%cfg%sync(dQdt(:,:,:,n)); end do + + ! Stop rhs timer + call this%trhs%stop() + + contains + !> WENO switch function + real(WP) function weno_weight(ratio) + implicit none + real(WP), intent(in) :: ratio + real(WP), parameter :: lambda=0.13_WP ! Switching parameter + real(WP), parameter :: delta=0.01_WP ! Switching thickness + weno_weight=(1.0_WP-tanh((ratio-lambda)/delta))/3.0_WP+(1.0_WP-tanh((ratio-1.0_WP/lambda)/delta))/6.0_WP + end function weno_weight + end subroutine rhs + + + !> Calculate divergence of stress for LPT solver + subroutine get_div_stress(this,divx,divy,divz) + implicit none + class(spcomp), intent(inout) :: this + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(out) :: divx !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(out) :: divy !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(out) :: divz !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + real(WP), dimension(:,:,:,:), allocatable :: FQx,FQy,FQz + integer :: i,j,k + real(WP) :: div + + ! Zero out divergence of stresses + divx=0.0_WP + divy=0.0_WP + divz=0.0_WP + + ! Allocate fluxes of conserved variables + allocate(FQx(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_,1:3)); FQx=0.0_WP + allocate(FQy(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_,1:3)); FQy=0.0_WP + allocate(FQz(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_,1:3)); FQz=0.0_WP + + ! Compute cell-centered momentum fluxes + do k=this%cfg%kmin_-1,this%cfg%kmax_ + do j=this%cfg%jmin_-1,this%cfg%jmax_ + do i=this%cfg%imin_-1,this%cfg%imax_ + div=this%dxi*(this%U(i+1,j,k)-this%U(i,j,k))+this%dyi*(this%V(i,j+1,k)-this%V(i,j,k))+this%dzi*(this%W(i,j,k+1)-this%W(i,j,k)) + FQx(i,j,k,1)=2.0_WP*this%VISC(i,j,k)*this%dxi*(this%U(i+1,j,k)-this%U(i,j,k))+(this%BETA(i,j,k)-2.0_WP*this%VISC(i,j,k)/3.0_WP)*div-this%P(i,j,k) + FQy(i,j,k,2)=2.0_WP*this%VISC(i,j,k)*this%dyi*(this%V(i,j+1,k)-this%V(i,j,k))+(this%BETA(i,j,k)-2.0_WP*this%VISC(i,j,k)/3.0_WP)*div-this%P(i,j,k) + FQz(i,j,k,3)=2.0_WP*this%VISC(i,j,k)*this%dzi*(this%W(i,j,k+1)-this%W(i,j,k))+(this%BETA(i,j,k)-2.0_WP*this%VISC(i,j,k)/3.0_WP)*div-this%P(i,j,k) + end do + end do + end do + + ! Compute edge-centered momentum viscous fluxes and corresponding viscous heating + do k=this%cfg%kmin_,this%cfg%kmax_+1 + do j=this%cfg%jmin_,this%cfg%jmax_+1 + do i=this%cfg%imin_,this%cfg%imax_+1 + ! Momentum fluxes + FQy(i,j,k,1)=0.25_WP*sum(this%VISC(i-1:i,j-1:j,k))*(this%dyi*(this%U(i,j,k)-this%U(i,j-1,k))+this%dxi*(this%V(i,j,k)-this%V(i-1,j,k))); FQx(i,j,k,2)=FQy(i,j,k,1) + FQz(i,j,k,2)=0.25_WP*sum(this%VISC(i,j-1:j,k-1:k))*(this%dzi*(this%V(i,j,k)-this%V(i,j,k-1))+this%dyi*(this%W(i,j,k)-this%W(i,j-1,k))); FQy(i,j,k,3)=FQz(i,j,k,2) + FQx(i,j,k,3)=0.25_WP*sum(this%VISC(i-1:i,j,k-1:k))*(this%dxi*(this%W(i,j,k)-this%W(i-1,j,k))+this%dzi*(this%U(i,j,k)-this%U(i,j,k-1))); FQz(i,j,k,1)=FQx(i,j,k,3) + end do + end do + end do + + do i=1,3 + call this%cfg%sync(FQx(:,:,:,i)) + call this%cfg%sync(FQy(:,:,:,i)) + call this%cfg%sync(FQz(:,:,:,i)) + end do + + ! Assemble time derivative for conserved variables + do k=this%cfg%kmin_,this%cfg%kmax_ + do j=this%cfg%jmin_,this%cfg%jmax_ + do i=this%cfg%imin_,this%cfg%imax_ + ! Viscous momentum transport + divx(i,j,k)=this%dxi*(FQx(i ,j,k,1)-FQx(i-1,j,k,1))+this%dyi*(FQy(i,j+1,k,1)-FQy(i,j ,k,1))+this%dzi*(FQz(i,j,k+1,1)-FQz(i,j,k ,1)) + divy(i,j,k)=this%dxi*(FQx(i+1,j,k,2)-FQx(i ,j,k,2))+this%dyi*(FQy(i,j ,k,2)-FQy(i,j-1,k,2))+this%dzi*(FQz(i,j,k+1,2)-FQz(i,j,k ,2)) + divz(i,j,k)=this%dxi*(FQx(i+1,j,k,3)-FQx(i ,j,k,3))+this%dyi*(FQy(i,j+1,k,3)-FQy(i,j ,k,3))+this%dzi*(FQz(i,j,k ,3)-FQz(i,j,k-1,3)) + end do + end do + end do + + ! Deallocate flux arrays + deallocate(FQx,FQy,FQz) + + ! Synchronize + call this%cfg%sync(divx) + call this%cfg%sync(divy) + call this%cfg%sync(divz) + + end subroutine get_div_stress + + + !> Calculate all primitive variables from updated conserved variables + subroutine get_primitive(this) + implicit none + class(spcomp), intent(inout) :: this + integer :: i,j,k + ! Get velocity + call this%get_velocity() + ! Get primitive variables + do k=this%cfg%kmino_,this%cfg%kmaxo_; do j=this%cfg%jmino_,this%cfg%jmaxo_; do i=this%cfg%imino_,this%cfg%imaxo_ + this%I(i,j,k)=this%Q(i,j,k,2)/this%Q(i,j,k,1) + this%P(i,j,k)=this%getP(this%Q(i,j,k,1),this%I(i,j,k)) + this%C(i,j,k)=this%getC(this%Q(i,j,k,1),this%P(i,j,k)) + end do; end do; end do + ! Get temperature + if (associated(this%getT)) then + do k=this%cfg%kmino_,this%cfg%kmaxo_; do j=this%cfg%jmino_,this%cfg%jmaxo_; do i=this%cfg%imino_,this%cfg%imaxo_ + this%T(i,j,k)=this%getT(this%Q(i,j,k,1),this%P(i,j,k)) + end do; end do; end do + end if + end subroutine get_primitive + + + !> Calculate velocity from momentum and density + subroutine get_velocity(this) + implicit none + class(spcomp), intent(inout) :: this + integer :: i,j,k + ! Calculate velocity as far as possible + do k=this%cfg%kmino_+1,this%cfg%kmaxo_ + do j=this%cfg%jmino_+1,this%cfg%jmaxo_ + do i=this%cfg%imino_+1,this%cfg%imaxo_ + this%U(i,j,k)=2.0_WP*this%Q(i,j,k,3)/sum(this%Q(i-1:i,j,k,1)) + this%V(i,j,k)=2.0_WP*this%Q(i,j,k,4)/sum(this%Q(i,j-1:j,k,1)) + this%W(i,j,k)=2.0_WP*this%Q(i,j,k,5)/sum(this%Q(i,j,k-1:k,1)) + end do + end do + end do + ! Sync velocity + call this%cfg%sync(this%U) + call this%cfg%sync(this%V) + call this%cfg%sync(this%W) + ! Add last layer in each direction + if (.not.this%cfg%xper.and.this%cfg%iproc.eq.1) then + this%U(this%cfg%imino,:,:)=this%Q(this%cfg%imino,:,:,3)/(this%Q(this%cfg%imino,:,:,1)) + this%V(this%cfg%imino,:,:)=this%Q(this%cfg%imino,:,:,4)/(this%Q(this%cfg%imino,:,:,1)) + this%W(this%cfg%imino,:,:)=this%Q(this%cfg%imino,:,:,5)/(this%Q(this%cfg%imino,:,:,1)) + end if + if (.not.this%cfg%yper.and.this%cfg%jproc.eq.1) then + this%U(:,this%cfg%jmino,:)=this%Q(:,this%cfg%jmino,:,3)/(this%Q(:,this%cfg%jmino,:,1)) + this%V(:,this%cfg%jmino,:)=this%Q(:,this%cfg%jmino,:,4)/(this%Q(:,this%cfg%jmino,:,1)) + this%W(:,this%cfg%jmino,:)=this%Q(:,this%cfg%jmino,:,5)/(this%Q(:,this%cfg%jmino,:,1)) + end if + if (.not.this%cfg%zper.and.this%cfg%kproc.eq.1) then + this%U(:,:,this%cfg%kmino)=this%Q(:,:,this%cfg%kmino,3)/(this%Q(:,:,this%cfg%kmino,1)) + this%V(:,:,this%cfg%kmino)=this%Q(:,:,this%cfg%kmino,4)/(this%Q(:,:,this%cfg%kmino,1)) + this%W(:,:,this%cfg%kmino)=this%Q(:,:,this%cfg%kmino,5)/(this%Q(:,:,this%cfg%kmino,1)) + end if + end subroutine get_velocity + + + !> Calculate kinetic energy per unit mass from pre-calculated velocity + !> Need to redo this better + subroutine get_ke(this,KE) + implicit none + class(spcomp), intent(inout) :: this + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(out) :: KE !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + integer :: i,j,k + do k=this%cfg%kmino_,this%cfg%kmaxo_-1 + do j=this%cfg%jmino_,this%cfg%jmaxo_-1 + do i=this%cfg%imino_,this%cfg%imaxo_-1 + KE(i,j,k)=0.5_WP*sum(this%U(i:i+1,j,k)**2+this%V(i,j:j+1,k)**2+this%W(i,j,k:k+1)**2) + end do + end do + end do + call this%cfg%sync(KE) + if (.not.this%cfg%xper.and.this%cfg%iproc.eq.this%cfg%npx) KE(this%cfg%imaxo,:,:)=KE(this%cfg%imaxo-1,:,:) + if (.not.this%cfg%yper.and.this%cfg%jproc.eq.this%cfg%npy) KE(:,this%cfg%jmaxo,:)=KE(:,this%cfg%jmaxo-1,:) + if (.not.this%cfg%zper.and.this%cfg%kproc.eq.this%cfg%npz) KE(:,:,this%cfg%kmaxo)=KE(:,:,this%cfg%kmaxo-1) + end subroutine get_ke + + + !> Calculate momentum from velocity and density + subroutine get_momentum(this) + implicit none + class(spcomp), intent(inout) :: this + integer :: i,j,k + ! Calculate momentum as far as possible + do k=this%cfg%kmino_+1,this%cfg%kmaxo_ + do j=this%cfg%jmino_+1,this%cfg%jmaxo_ + do i=this%cfg%imino_+1,this%cfg%imaxo_ + this%Q(i,j,k,3)=0.5_WP*sum(this%Q(i-1:i,j,k,1))*this%U(i,j,k) + this%Q(i,j,k,4)=0.5_WP*sum(this%Q(i,j-1:j,k,1))*this%V(i,j,k) + this%Q(i,j,k,5)=0.5_WP*sum(this%Q(i,j,k-1:k,1))*this%W(i,j,k) + end do + end do + end do + ! Sync momentum + call this%cfg%sync(this%Q(:,:,:,3)) + call this%cfg%sync(this%Q(:,:,:,4)) + call this%cfg%sync(this%Q(:,:,:,5)) + ! Add last layer in each direction + if (.not.this%cfg%xper.and.this%cfg%iproc.eq.1) then + this%Q(this%cfg%imino,:,:,3)=this%Q(this%cfg%imino,:,:,1)*this%U(this%cfg%imino,:,:) + this%Q(this%cfg%imino,:,:,4)=this%Q(this%cfg%imino,:,:,1)*this%V(this%cfg%imino,:,:) + this%Q(this%cfg%imino,:,:,5)=this%Q(this%cfg%imino,:,:,1)*this%W(this%cfg%imino,:,:) + end if + if (.not.this%cfg%yper.and.this%cfg%jproc.eq.1) then + this%Q(:,this%cfg%jmino,:,3)=this%Q(:,this%cfg%jmino,:,1)*this%U(:,this%cfg%jmino,:) + this%Q(:,this%cfg%jmino,:,4)=this%Q(:,this%cfg%jmino,:,1)*this%V(:,this%cfg%jmino,:) + this%Q(:,this%cfg%jmino,:,5)=this%Q(:,this%cfg%jmino,:,1)*this%W(:,this%cfg%jmino,:) + end if + if (.not.this%cfg%zper.and.this%cfg%kproc.eq.1) then + this%Q(:,:,this%cfg%kmino,3)=this%Q(:,:,this%cfg%kmino,1)*this%U(:,:,this%cfg%kmino) + this%Q(:,:,this%cfg%kmino,4)=this%Q(:,:,this%cfg%kmino,1)*this%V(:,:,this%cfg%kmino) + this%Q(:,:,this%cfg%kmino,5)=this%Q(:,:,this%cfg%kmino,1)*this%W(:,:,this%cfg%kmino) + end if + end subroutine get_momentum + + + !> Interpolate velocity to cell-center, including overlap and ghosts + subroutine interp_vel(this,Ui,Vi,Wi) + implicit none + class(spcomp), intent(inout) :: this + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(out) :: Ui !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(out) :: Vi !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(out) :: Wi !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + integer :: i,j,k + ! Calculate interpolated velocity as far as possible + do k=this%cfg%kmino_,this%cfg%kmaxo_-1 + do j=this%cfg%jmino_,this%cfg%jmaxo_-1 + do i=this%cfg%imino_,this%cfg%imaxo_-1 + Ui(i,j,k)=0.5_WP*sum(this%U(i:i+1,j,k)) + Vi(i,j,k)=0.5_WP*sum(this%V(i,j:j+1,k)) + Wi(i,j,k)=0.5_WP*sum(this%W(i,j,k:k+1)) + end do + end do + end do + ! Sync interpolated velocity + call this%cfg%sync(Ui) + call this%cfg%sync(Vi) + call this%cfg%sync(Wi) + ! Add last layer in each direction + if (.not.this%cfg%xper.and.this%cfg%iproc.eq.this%cfg%npx) then + Ui(this%cfg%imaxo,:,:)=this%U(this%cfg%imaxo,:,:) + Vi(this%cfg%imaxo,:,:)=this%V(this%cfg%imaxo,:,:) + Wi(this%cfg%imaxo,:,:)=this%W(this%cfg%imaxo,:,:) + end if + if (.not.this%cfg%yper.and.this%cfg%jproc.eq.this%cfg%npy) then + Ui(:,this%cfg%jmaxo,:)=this%U(:,this%cfg%jmaxo,:) + Vi(:,this%cfg%jmaxo,:)=this%V(:,this%cfg%jmaxo,:) + Wi(:,this%cfg%jmaxo,:)=this%W(:,this%cfg%jmaxo,:) + end if + if (.not.this%cfg%zper.and.this%cfg%kproc.eq.this%cfg%npz) then + Ui(:,:,this%cfg%kmaxo)=this%U(:,:,this%cfg%kmaxo) + Vi(:,:,this%cfg%kmaxo)=this%V(:,:,this%cfg%kmaxo) + Wi(:,:,this%cfg%kmaxo)=this%W(:,:,this%cfg%kmaxo) + end if + end subroutine interp_vel + + + !> Get artifical bulk kinematic viscosity + subroutine get_viscartif(this,dt,beta) + implicit none + class(spcomp), intent(inout) :: this + real(WP), intent(in) :: dt + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(out) :: beta + integer :: i,j,k,si,sj,sk,n + integer, parameter :: nfilter=1 + real(WP) :: max_beta,dudy,dudz,dvdx,dvdz,dwdx,dwdy,vort,grad_div,H + real(WP), parameter :: max_cfl=0.5_WP + real(WP), parameter :: Cartif=2.0_WP + real(WP), parameter :: Cartif_vort=100.0_WP + real(WP), dimension(:,:,:), allocatable :: div + real(WP), dimension(-1:+1), parameter :: filter=[1.0_WP/6.0_WP,2.0_WP/3.0_WP,1.0_WP/6.0_WP] + ! Calculate max beta permissible + max_beta=max_cfl*min(this%dx**2,this%dy**2,this%dz**2)/(4.0_WP*dt) + ! Zero out array + beta=0.0_WP + ! Compute velocity divergence + allocate(div(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + do k=this%cfg%kmino_,this%cfg%kmaxo_-1; do j=this%cfg%jmino_,this%cfg%jmaxo_-1; do i=this%cfg%imino_,this%cfg%imaxo_-1 + div(i,j,k)=this%dxi*(this%U(i+1,j,k)-this%U(i,j,k))+this%dyi*(this%V(i,j+1,k)-this%V(i,j,k))+this%dzi*(this%W(i,j,k+1)-this%W(i,j,k)) + end do; end do; end do + call this%cfg%sync(div) + if (.not.this%cfg%xper.and.this%cfg%iproc.eq.this%cfg%npx) div(this%cfg%imaxo,:,:)=div(this%cfg%imaxo-1,:,:) + if (.not.this%cfg%yper.and.this%cfg%jproc.eq.this%cfg%npy) div(:,this%cfg%jmaxo,:)=div(:,this%cfg%jmaxo-1,:) + if (.not.this%cfg%zper.and.this%cfg%kproc.eq.this%cfg%npz) div(:,:,this%cfg%kmaxo)=div(:,:,this%cfg%kmaxo-1) + ! Compute artificial bulk viscosity based on gradU provided + do k=this%cfg%kmin_,this%cfg%kmax_; do j=this%cfg%jmin_,this%cfg%jmax_; do i=this%cfg%imin_,this%cfg%imax_ + ! Only work in compression regions + if (div(i,j,k).ge.0.0_WP) cycle + ! Compute local vorticity + dudy=0.25_WP*this%dyi*sum(this%U(i:i+1,j:j+1,k)-this%U(i:i+1,j-1:j,k)) + dudz=0.25_WP*this%dzi*sum(this%U(i:i+1,j,k:k+1)-this%U(i:i+1,j,k-1:k)) + dvdx=0.25_WP*this%dxi*sum(this%V(i:i+1,j:j+1,k)-this%V(i-1:i,j:j+1,k)) + dvdz=0.25_WP*this%dzi*sum(this%V(i,j:j+1,k:k+1)-this%V(i,j:j+1,k-1:k)) + dwdx=0.25_WP*this%dxi*sum(this%W(i:i+1,j,k:k+1)-this%W(i-1:i,j,k:k+1)) + dwdy=0.25_WP*this%dyi*sum(this%W(i,j:j+1,k:k+1)-this%W(i,j-1:j,k:k+1)) + vort=(dwdy-dvdz)**2+(dudz-dwdx)**2+(dvdx-dudy)**2 + ! Compute |grad(div)| + grad_div=max(abs(div(i+1,j,k)-div(i,j,k)),abs(div(i,j,k)-div(i-1,j,k)))*this%dx**2& + & +max(abs(div(i,j+1,k)-div(i,j,k)),abs(div(i,j,k)-div(i,j-1,k)))*this%dy**2& + & +max(abs(div(i,j,k+1)-div(i,j,k)),abs(div(i,j,k)-div(i,j,k-1)))*this%dz**2 + ! Estimate artificial kinematic viscosity using grad(div) + !beta(i,j,k)=Cartif*grad_div*div(i,j,k)**2/(div(i,j,k)**2+Cartif_vort*vort+1.0e-15_WP) + + ! Sensor originally proposed by Ducros et al. (1999) and later improved by + ! Hendrickson, T. R., Kartha, A., & Candler, G. V. (2018) + vort=max(vort,(0.05_WP*this%C(i,j,k)/min(this%dx,this%dy))**2) + beta(i,j,k)=Cartif*grad_div*min(4.0_WP/3.0_WP*div(i,j,k)**2/(div(i,j,k)**2+vort+epsilon(1.0_WP)),1.0_WP) + ! Clip it so CFL Get kinematic eddy viscosity using Vreman's model + subroutine get_vreman(this,dt,visc) + implicit none + class(spcomp), intent(inout) :: this + real(WP), intent(in) :: dt + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(out) :: visc + real(WP), parameter :: Cs_ref=0.17_WP + real(WP), parameter :: max_cfl=0.5_WP + real(WP) :: max_visc,A,B,C + real(WP), dimension(1:3,1:3) :: beta,gradU + real(WP), dimension(:,:,:), allocatable :: tmp + real(WP), dimension(-1:+1), parameter :: filter=[1.0_WP/6.0_WP,2.0_WP/3.0_WP,1.0_WP/6.0_WP] + integer :: i,j,k,si,sj,sk,n + integer, parameter :: nfilter=1 + ! Model constant is c=2.5*Cs_ref**2 - Vreman uses c=0.07 which corresponds to Cs_ref=0.17 + C=2.5_WP*Cs_ref**2 + ! Calculate max visc permissible + max_visc=max_cfl*min(this%dx**2,this%dy**2,this%dz**2)/(4.0_WP*dt) + ! Zero out array + visc=0.0_WP + ! Compute the eddy viscosity + do k=this%cfg%kmin_,this%cfg%kmax_; do j=this%cfg%jmin_,this%cfg%jmax_; do i=this%cfg%imin_,this%cfg%imax_ + ! Compute velocity gradient tensor + gradU(1,1)=this%dxi*(this%U(i+1,j,k)-this%U(i,j,k)) + gradU(2,1)=0.25_WP*this%dyi*sum(this%U(i:i+1,j:j+1,k)-this%U(i:i+1,j-1:j,k)) + gradU(3,1)=0.25_WP*this%dzi*sum(this%U(i:i+1,j,k:k+1)-this%U(i:i+1,j,k-1:k)) + gradU(1,2)=0.25_WP*this%dxi*sum(this%V(i:i+1,j:j+1,k)-this%V(i-1:i,j:j+1,k)) + gradU(2,2)=this%dyi*(this%V(i,j+1,k)-this%V(i,j,k)) + gradU(3,2)=0.25_WP*this%dzi*sum(this%V(i,j:j+1,k:k+1)-this%V(i,j:j+1,k-1:k)) + gradU(1,3)=0.25_WP*this%dxi*sum(this%W(i:i+1,j,k:k+1)-this%W(i-1:i,j,k:k+1)) + gradU(2,3)=0.25_WP*this%dyi*sum(this%W(i,j:j+1,k:k+1)-this%W(i,j-1:j,k:k+1)) + gradU(3,3)=this%dzi*(this%W(i,j,k+1)-this%W(i,j,k)) + ! Compute A=gradu_ij*gradu_ij invariant + A=sum(gradU**2) + ! Compute beta_ij=dx_m*dx_m*gradu_mi*gradu_mj + do sj=1,3; do si=1,3; beta(si,sj)=this%dx**2*gradU(1,si)*gradU(1,sj)+this%dy**2*gradU(2,si)*gradU(2,sj)+this%dz**2*gradU(3,si)*gradU(3,sj); end do; end do + ! Compute B invariant + B=beta(1,1)*beta(2,2)-beta(1,2)**2+beta(1,1)*beta(3,3)-beta(1,3)**2+beta(2,2)*beta(3,3)-beta(2,3)**2 + ! Assemble algebraic eddy viscosity model + if (B.lt.1.0e-8_WP) then + visc(i,j,k)=0.0_WP + else + visc(i,j,k)=C*sqrt(B/A) + end if + ! Clip it so CFL Calculate the CFL + subroutine get_cfl(this,dt,cfl) + use mpi_f08, only: MPI_ALLREDUCE,MPI_MAX,MPI_IN_PLACE + use parallel, only: MPI_REAL_WP + implicit none + class(spcomp), intent(inout) :: this + real(WP), intent(in) :: dt + real(WP), intent(out) :: cfl + integer :: ierr + real(WP) :: maxvisc,maxC + ! Compute convective+acoustic CFLs + this%CFLc_x=maxval(abs(this%U)+abs(this%C))*dt*this%dxi; call MPI_ALLREDUCE(MPI_IN_PLACE,this%CFLc_x,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + this%CFLc_y=maxval(abs(this%V)+abs(this%C))*dt*this%dyi; call MPI_ALLREDUCE(MPI_IN_PLACE,this%CFLc_y,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + this%CFLc_z=maxval(abs(this%W)+abs(this%C))*dt*this%dzi; call MPI_ALLREDUCE(MPI_IN_PLACE,this%CFLc_z,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + ! Compute acoustic CFLs + maxC=maxval(this%C); call MPI_ALLREDUCE(MPI_IN_PLACE,maxC,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + this%CFLa_x=maxC*dt*this%dxi + this%CFLa_y=maxC*dt*this%dyi + this%CFLa_z=maxC*dt*this%dzi + ! Compute viscous CFLs + maxvisc=maxval((this%VISC+this%BETA)/this%Q(:,:,:,1)); call MPI_ALLREDUCE(MPI_IN_PLACE,maxvisc,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + this%CFLv_x=4.0_WP*maxvisc*dt*this%dxi**2 + this%CFLv_y=4.0_WP*maxvisc*dt*this%dyi**2 + this%CFLv_z=4.0_WP*maxvisc*dt*this%dzi**2 + ! Return the maximum overall CFL + cfl=max(this%CFLc_x,this%CFLc_y,this%CFLc_z,& + & this%CFLa_x,this%CFLa_y,this%CFLa_z,& + & this%CFLv_x,this%CFLv_y,this%CFLv_z) + end subroutine get_cfl + + + !> Calculate info about our fields + subroutine get_info(this) + use mpi_f08, only: MPI_ALLREDUCE,MPI_MIN,MPI_MAX,MPI_IN_PLACE + use parallel, only: MPI_REAL_WP + implicit none + class(spcomp), intent(inout) :: this + integer :: n,i,j,k,ierr + real(WP), dimension(:,:,:), allocatable :: tmp + + ! Compute integrals and extrema of conserved variables + do n=1,this%nQ + call this%cfg%integrate(this%Q(:,:,:,n),integral=this%Qint(n)) + end do + this%Qmin=+huge(1.0_WP) + this%Qmax=-huge(1.0_WP) + do k=this%cfg%kmin_,this%cfg%kmax_; do j=this%cfg%jmin_,this%cfg%jmax_; do i=this%cfg%imin_,this%cfg%imax_ + do n=1,this%nQ + this%Qmin(n)=min(this%Qmin(n),this%Q(i,j,k,n)) + this%Qmax(n)=max(this%Qmax(n),this%Q(i,j,k,n)) + end do + end do; end do; end do + call MPI_ALLREDUCE(MPI_IN_PLACE,this%Qmin,this%nQ,MPI_REAL_WP,MPI_MIN,this%cfg%comm,ierr) + call MPI_ALLREDUCE(MPI_IN_PLACE,this%Qmax,this%nQ,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + + ! Also compute integral of KE and entropy + allocate(tmp(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + call this%get_ke(tmp); tmp=this%Q(:,:,:,1)*tmp; call this%cfg%integrate(tmp,integral=this%RHOKint) + this%RHOSint=0.0_WP + if (associated(this%getS)) then + do k=this%cfg%kmin_,this%cfg%kmax_; do j=this%cfg%jmin_,this%cfg%jmax_; do i=this%cfg%imin_,this%cfg%imax_ + tmp(i,j,k)=this%Q(i,j,k,1)*this%getS(this%Q(i,j,k,1),this%P(i,j,k)) + end do; end do; end do + call this%cfg%integrate(tmp,integral=this%RHOSint) + end if + deallocate(tmp) + + ! Calculate extrema of primitive fields + this%RHOmin=+huge(1.0_WP); this%RHOmax=-huge(1.0_WP) + this%Imin =+huge(1.0_WP); this%Imax =-huge(1.0_WP) + this%Pmin =+huge(1.0_WP); this%Pmax =-huge(1.0_WP) + this%Tmin =+huge(1.0_WP); this%Tmax =-huge(1.0_WP) + this%Umax=0.0_WP; this%Vmax=0.0_WP; this%Wmax=0.0_WP + do k=this%cfg%kmin_,this%cfg%kmax_; do j=this%cfg%jmin_,this%cfg%jmax_; do i=this%cfg%imin_,this%cfg%imax_ + this%RHOmin=min(this%RHOmin,this%Q(i,j,k,1)); this%RHOmax=max(this%RHOmax,this%Q(i,j,k,1)) + this%Imin =min(this%Imin ,this%I (i,j,k)); this%Imax =max(this%Imax ,this%I (i,j,k)) + this%Pmin =min(this%Pmin ,this%P (i,j,k)); this%Pmax =max(this%Pmax ,this%P (i,j,k)) + this%Tmin =min(this%Tmin ,this%T (i,j,k)); this%Tmax =max(this%Tmax ,this%T (i,j,k)) + this%Umax=max(this%Umax,abs(this%U(i,j,k))) + this%Vmax=max(this%Vmax,abs(this%V(i,j,k))) + this%Wmax=max(this%Wmax,abs(this%W(i,j,k))) + end do; end do; end do + call MPI_ALLREDUCE(MPI_IN_PLACE,this%RHOmin,1,MPI_REAL_WP,MPI_MIN,this%cfg%comm,ierr) + call MPI_ALLREDUCE(MPI_IN_PLACE,this%RHOmax,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + call MPI_ALLREDUCE(MPI_IN_PLACE,this%Imin ,1,MPI_REAL_WP,MPI_MIN,this%cfg%comm,ierr) + call MPI_ALLREDUCE(MPI_IN_PLACE,this%Imax ,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + call MPI_ALLREDUCE(MPI_IN_PLACE,this%Pmin ,1,MPI_REAL_WP,MPI_MIN,this%cfg%comm,ierr) + call MPI_ALLREDUCE(MPI_IN_PLACE,this%Pmax ,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + call MPI_ALLREDUCE(MPI_IN_PLACE,this%Tmin ,1,MPI_REAL_WP,MPI_MIN,this%cfg%comm,ierr) + call MPI_ALLREDUCE(MPI_IN_PLACE,this%Tmax ,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + call MPI_ALLREDUCE(MPI_IN_PLACE,this%Umax ,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + call MPI_ALLREDUCE(MPI_IN_PLACE,this%Vmax ,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + call MPI_ALLREDUCE(MPI_IN_PLACE,this%Wmax ,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + + end subroutine get_info + + + !> Print out info for spcomp flow solver + subroutine spcomp_print(this) + use, intrinsic :: iso_fortran_env, only: output_unit + implicit none + class(spcomp), intent(in) :: this + if (this%cfg%amRoot) write(output_unit,'("spcomp solver [",a,"] for config [",a,"]")') trim(this%name),trim(this%cfg%name) + end subroutine spcomp_print + + + !> Finalize spcomp flow solver + subroutine finalize(this) + implicit none + class(spcomp), intent(inout) :: this + nullify(this%cfg) + this%name='UNNAMED_SPCOMP' + nullify(this%getP) + nullify(this%getT) + nullify(this%getC) + nullify(this%getS) + this%nQ=0 + if (allocated(this%Q)) deallocate(this%Q) + if (allocated(this%Qold)) deallocate(this%Qold) + if (allocated(this%U)) deallocate(this%U) + if (allocated(this%V)) deallocate(this%V) + if (allocated(this%W)) deallocate(this%W) + if (allocated(this%I)) deallocate(this%I) + if (allocated(this%P)) deallocate(this%P) + if (allocated(this%T)) deallocate(this%T) + if (allocated(this%C)) deallocate(this%C) + if (allocated(this%VISC)) deallocate(this%VISC) + if (allocated(this%BETA)) deallocate(this%BETA) + if (allocated(this%DIFF)) deallocate(this%DIFF) + if (allocated(this%Qmin)) deallocate(this%Qmin) + if (allocated(this%Qmax)) deallocate(this%Qmax) + if (allocated(this%Qint)) deallocate(this%Qint) + call this%trhs%finalize() + end subroutine finalize + + +end module spcomp_class diff --git a/examples/plate_with_hole/GNUmakefile b/examples/plate_with_hole/GNUmakefile new file mode 100644 index 000000000..23c4d3dba --- /dev/null +++ b/examples/plate_with_hole/GNUmakefile @@ -0,0 +1,49 @@ +# NGA location if not yet defined +NGA_HOME ?= ~/nga2/Repositories/nga2 + +# Compilation parameters +PRECISION = DOUBLE +USE_MPI = TRUE +USE_HYPRE = TRUE +USE_LAPACK= TRUE +USE_FFTW = TRUE +USE_IRL = FALSE +PROFILE = FALSE +DEBUG = FALSE +COMP = gnu +EXEBASE = nga + +# Directories that contain user-defined code +Udirs := src + +# Include user-defined sources +Upack += $(foreach dir, $(Udirs), $(wildcard $(dir)/Make.package)) +Ulocs += $(foreach dir, $(Udirs), $(wildcard $(dir))) +include $(Upack) +INCLUDE_LOCATIONS += $(Ulocs) +VPATH_LOCATIONS += $(Ulocs) + +# External libraries are defined in .profile/.bashrc/.zshrc, but could be defined here as well +HYPRE_DIR=/Users/imauser/nga2/Repositories/hypre/src/hypre +FFTW_DIR=/opt/homebrew/Cellar/fftw/3.3.10_2 + +# NGA compilation definitions +include $(NGA_HOME)/tools/GNUMake/Make.defs + +# Include NGA base code +Bdirs := constant_density particles core data transform solver config grid libraries +Bpack += $(foreach dir, $(Bdirs), $(NGA_HOME)/src/$(dir)/Make.package) +include $(Bpack) + +# Inform user of Make.packages used +ifdef Ulocs + $(info Taking user code from: $(Ulocs)) +endif +$(info Taking base code from: $(Bdirs)) + +# Target definition +all: $(executable) + @echo COMPILATION SUCCESSFUL + +# NGA compilation rules +include $(NGA_HOME)/tools/GNUMake/Make.rules diff --git a/examples/plate_with_hole/input b/examples/plate_with_hole/input new file mode 100644 index 000000000..438d91796 --- /dev/null +++ b/examples/plate_with_hole/input @@ -0,0 +1,28 @@ +# Parallelization +Partition : 2 2 2 + + +# Beam Shape +Lx : 0.1 +Ly : 0.08 +Lz : 0.015 +R : 0.01 +Particle file: element_data.bin + +# Solid properties +Subdivisions : 33 +Elastic Modulus : 200e9 +Poisson Ratio : 0.30 +Solid density : 7850 +Critical Energy Release Rate : 100000 +Horizon Ratio : 3.015 +Solid Spacing: 0.00125 +Mean Particle Spacing : 0.00125 + +# Time integration +Max timestep size : 2.0e-7 +Max cfl number : 1.1 +Max time : 0.01 + +# Ensight output +Ensight output period : 2e-5 diff --git a/examples/plate_with_hole/src/Make.package b/examples/plate_with_hole/src/Make.package new file mode 100644 index 000000000..ddc060c7d --- /dev/null +++ b/examples/plate_with_hole/src/Make.package @@ -0,0 +1,2 @@ +# List here the extra files here +f90EXE_sources += simulation.f90 geometry.f90 lss_class.f90 spcomp_class.f90 diff --git a/examples/plate_with_hole/src/geometry copy.f90 b/examples/plate_with_hole/src/geometry copy.f90 new file mode 100644 index 000000000..d32d69565 --- /dev/null +++ b/examples/plate_with_hole/src/geometry copy.f90 @@ -0,0 +1,136 @@ +!> Various definitions and tools for initializing NGA2 config +module geometry + use config_class, only: config + use precision, only: WP + implicit none + private + + !> Single config + type(config), public :: cfg + + public :: geometry_init + +contains + + + !> Initialization of problem geometry + subroutine geometry_init + use sgrid_class, only: sgrid + use param, only: param_read + implicit none + type(sgrid) :: grid + + + ! Create a grid from input params + create_grid: block + use sgrid_class, only: cartesian + integer :: i,j,k,nx,ny,nz + real(WP) :: Lx,Ly,Lz,dist,dx,R + real(WP), dimension(:), allocatable :: x,y,z + + call param_read('Lx',Lx) + call param_read('Ly',Ly) + call param_read('Lz',Lz) + call param_read('R',R) + call param_read('Solid Spacing',dist) + ! Lx = 1.0_WP ! beam length + ! Ly = 1.0_WP ! beam length + + ! dist = 0.01_WP ! Space between particles + + Lx = Lx + 6.03_WP * dist ! total length of the beam + ! Ly = Ly + 3.0_WP * dist ! total length of the beam + + dx = 3.015_WP*dist ! grid spacing + + nx = ceiling(Lx/dx)+2 ! number of division in x + ny = ceiling(Ly/dx) + nz = ceiling(Lz/dx) + + allocate(x(nx+1)) + allocate(y(ny+1)) + allocate(z(nz+1)) + + ! Create simple rectilinear grid + do i=1,nx+1 + x(i)=real(i-2,WP)*dx - Lx/2.0_WP - 1.5_WP*dist + end do + do j=1,ny+1 + y(j)=real(j-1,WP)*dx - Ly/2.0_WP - 1.5_WP*dist + end do + do k=1,nz+1 + z(k)=real(k-1,WP)*dx - Lz/2.0_WP - 1.5_WP*dist + end do + ! General serial grid object (no=3 needed to support ghost/image point interpolation/extrapolation) + grid=sgrid(coord=cartesian,no=3,x=x,y=y,z=z,xper=.false.,yper=.false.,zper=.false.,name='box') + + end block create_grid + + ! create_grid: block + ! use sgrid_class, only: cartesian + ! integer :: i,j,k,nx,ny,nz + ! real(WP) :: Lx,Ly,Lz,dist + ! real(WP), dimension(:), allocatable :: x,y,z + + ! ! Read in grid definition + ! call param_read('Lx',Lx); Lx=Lx + ! call param_read('Ly',Ly); Ly=Ly + ! call param_read('Lz',Lz); Lz=Lz + ! call param_read('Subdivisions',ny) + ! dist = 3.0_WP * Ly / real(ny,WP) + ! Lx = Lx + 3.0_WP * dist + ! nx = ceiling(Lx / dist) + 4 + ! ny = ceiling(Ly / dist) + 2 + ! nz = ceiling(Lz / dist) + 2 + + ! Lx = real(nx,WP) * dist + ! Ly = real(ny,WP) * dist + ! Lz = real(nz,WP) * dist + + + ! allocate(x(nx)) + ! allocate(y(ny+1)) + ! allocate(z(nz+1)) + + + ! ! Create simple rectilinear grid + ! do i=1,nx + ! x(i)=real(i-2,WP)*dist + ! end do + ! do j=1,ny+1 + ! y(j)=real(j-1,WP)*dist-0.5_WP*Ly + ! end do + ! do k=1,nz+1 + ! z(k)=real(k-1,WP)*dist-0.5_WP*Lz + ! end do + + + + + ! ! General serial grid object (no=3 needed to support ghost/image point interpolation/extrapolation) + ! grid=sgrid(coord=cartesian,no=2,x=x,y=y,z=z,xper=.false.,yper=.false.,zper=.false.,name='box') + + ! end block create_grid + + + ! Create a config from that grid on our entire group + create_cfg: block + use parallel, only: group + integer, dimension(3) :: partition + ! Read in partition + call param_read('Partition',partition,short='p') + ! Create partitioned grid + cfg=config(grp=group,decomp=partition,grid=grid) + end block create_cfg + + + ! Create walls for this config + create_walls: block + cfg%VF=1.0_WP + end block create_walls + + + end subroutine geometry_init + + +end module geometry diff --git a/examples/plate_with_hole/src/geometry.f90 b/examples/plate_with_hole/src/geometry.f90 new file mode 100644 index 000000000..489b56b99 --- /dev/null +++ b/examples/plate_with_hole/src/geometry.f90 @@ -0,0 +1,137 @@ +!> Various definitions and tools for initializing NGA2 config +module geometry + use config_class, only: config + use precision, only: WP + implicit none + private + + !> Single config + type(config), public :: cfg + + public :: geometry_init + +contains + + + !> Initialization of problem geometry + subroutine geometry_init + use sgrid_class, only: sgrid + use param, only: param_read + implicit none + type(sgrid) :: grid + + + ! Create a grid from input params + create_grid: block + use sgrid_class, only: cartesian + integer :: i,j,k,nx,ny,nz + real(WP) :: Lx,Ly,Lz,dist,dx,R + real(WP), dimension(:), allocatable :: x,y,z + + call param_read('Lx',Lx) + call param_read('Ly',Ly) + call param_read('Lz',Lz) + call param_read('R',R) + call param_read('Solid Spacing',dist) + ! Lx = 1.0_WP ! beam length + ! Ly = 1.0_WP ! beam length + + ! dist = 0.01_WP ! Space between particles + + Lx = Lx + 6.03_WP * dist ! total length of the beam + ! Ly = Ly + 3.0_WP * dist ! total length of the beam + + dx = 3.015_WP*dist ! grid spacing + print*, "Grid Spacing : ", dx + + nx = ceiling(Lx/dx)+2 ! number of division in x + ny = ceiling(Ly/dx) + nz = ceiling(Lz/dx)+2 + + allocate(x(nx+1)) + allocate(y(ny+1)) + allocate(z(nz+1)) + + ! Create simple rectilinear grid + do i=1,nx+1 + x(i)=real(i-2,WP)*dx - Lx/2.0_WP - 1.5_WP*dist + end do + do j=1,ny+1 + y(j)=real(j-1,WP)*dx - Ly/2.0_WP - 1.5_WP*dist + end do + do k=1,nz+1 + z(k)=real(k-2,WP)*dx - Lz/2.0_WP - 1.5_WP*dist + end do + ! General serial grid object (no=3 needed to support ghost/image point interpolation/extrapolation) + grid=sgrid(coord=cartesian,no=3,x=x,y=y,z=z,xper=.false.,yper=.false.,zper=.false.,name='box') + + end block create_grid + + ! create_grid: block + ! use sgrid_class, only: cartesian + ! integer :: i,j,k,nx,ny,nz + ! real(WP) :: Lx,Ly,Lz,dist + ! real(WP), dimension(:), allocatable :: x,y,z + + ! ! Read in grid definition + ! call param_read('Lx',Lx); Lx=Lx + ! call param_read('Ly',Ly); Ly=Ly + ! call param_read('Lz',Lz); Lz=Lz + ! call param_read('Subdivisions',ny) + ! dist = 3.0_WP * Ly / real(ny,WP) + ! Lx = Lx + 3.0_WP * dist + ! nx = ceiling(Lx / dist) + 4 + ! ny = ceiling(Ly / dist) + 2 + ! nz = ceiling(Lz / dist) + 2 + + ! Lx = real(nx,WP) * dist + ! Ly = real(ny,WP) * dist + ! Lz = real(nz,WP) * dist + + + ! allocate(x(nx)) + ! allocate(y(ny+1)) + ! allocate(z(nz+1)) + + + ! ! Create simple rectilinear grid + ! do i=1,nx + ! x(i)=real(i-2,WP)*dist + ! end do + ! do j=1,ny+1 + ! y(j)=real(j-1,WP)*dist-0.5_WP*Ly + ! end do + ! do k=1,nz+1 + ! z(k)=real(k-1,WP)*dist-0.5_WP*Lz + ! end do + + + + + ! ! General serial grid object (no=3 needed to support ghost/image point interpolation/extrapolation) + ! grid=sgrid(coord=cartesian,no=2,x=x,y=y,z=z,xper=.false.,yper=.false.,zper=.false.,name='box') + + ! end block create_grid + + + ! Create a config from that grid on our entire group + create_cfg: block + use parallel, only: group + integer, dimension(3) :: partition + ! Read in partition + call param_read('Partition',partition,short='p') + ! Create partitioned grid + cfg=config(grp=group,decomp=partition,grid=grid) + end block create_cfg + + + ! Create walls for this config + create_walls: block + cfg%VF=1.0_WP + end block create_walls + + + end subroutine geometry_init + + +end module geometry diff --git a/examples/plate_with_hole/src/lss_class.f90 b/examples/plate_with_hole/src/lss_class.f90 new file mode 100644 index 000000000..2b9fee7f5 --- /dev/null +++ b/examples/plate_with_hole/src/lss_class.f90 @@ -0,0 +1,1594 @@ +!> Lagrangian solid solver object +!> Implements peridynamics equations +module lss_class + use precision, only: WP + use string, only: str_medium + use config_class, only: config + use mpi_f08, only: MPI_Datatype,MPI_INTEGER8,MPI_INTEGER,MPI_DOUBLE_PRECISION + implicit none + private + + + ! Expose type/constructor/methods + public :: lss + + + !> Memory adaptation parameter + real(WP), parameter :: coeff_up=1.3_WP !< Particle array size increase factor + real(WP), parameter :: coeff_dn=0.7_WP !< Particle array size decrease factor + + + !> I/O chunk size to read at a time + integer, parameter :: part_chunk_size=1000 !< Read 1000 particles at a time before redistributing + + + !> Maximum number of bonds per particle + integer, parameter, public :: max_bond=400 !< Assumes something like a 7x7x7 stencil in 3D + + + !> Bonded solid particle definition + type :: part + !> MPI_DOUBLE_PRECISION data + real(WP) :: mw !< Weighted volume + real(WP) :: dil !< Element dilatation + real(WP) :: vonMises !< Element dilatation + real(WP) :: vol !< Particle volume + real(WP), dimension(max_bond) :: dbond !< Length of initial bonds + real(WP), dimension(3) :: pos !< Particle center coordinates + real(WP), dimension(3) :: vel !< Velocity of particle + real(WP), dimension(3) :: Abond !< Bond acceleration for particle + real(WP), dimension(3) :: Afluid !< Fluid acceleration for particle + real(WP), dimension(3) :: ipos !< Initial position + real(WP), dimension(3) :: displacement !< Displacement + real(WP), dimension(3) :: gd !< + real(WP), dimension(3) :: gb !< + real(WP), dimension(6) :: sigma !< Cauchy stress tensor + !> MPI_INTEGER data + integer :: id !< ID the object is associated with + integer :: i !< Unique index of particle (assumed >0) + integer :: nbond !< Number of initial bonds + integer, dimension(max_bond) :: ibond !< Indices of initially bonded particles (0 values ignored) + integer , dimension(3) :: ind !< Index of cell containing particle center + integer :: flag !< Control parameter (0=normal, 1=done->will be removed) + end type part + !> Number of blocks, block length, and block types in a particle + integer, parameter :: part_nblock=2 + integer , dimension(part_nblock) :: part_lblock=[34+max_bond,7+max_bond] + type(MPI_Datatype), dimension(part_nblock) :: part_tblock=[MPI_DOUBLE_PRECISION,MPI_INTEGER] + !> MPI_PART derived datatype and size + type(MPI_Datatype) :: MPI_PART + integer :: MPI_PART_SIZE + + + !> Lagrangian solid solver object definition + type :: lss + + ! This config is used for parallelization and for calculating bond/collision forces + class(config), pointer :: cfg + + ! This is the name of the solver + character(len=str_medium) :: name='UNNAMED_LSS' + + ! Solid material properties + real(WP) :: elastic_modulus !< Elastic modulus of the material + real(WP) :: poisson_ratio !< Poisson's ratio of the material + real(WP) :: rho !< Density of the material + real(WP) :: crit_energy !< Critical energy release + + ! Bonding parameters + real(WP) :: delta !< Bonding horizon (distance) + real(WP) :: min_dist !< Minimum bonding distance + integer :: nb !< Cell-based horizon + + ! Global and local particle data + integer :: np !< Global number of particles + integer :: np_ !< Local number of particles + integer, dimension(:), allocatable :: np_proc !< Number of particles on each processor + type(part), dimension(:), allocatable :: p !< Array of particles of type part + + ! Overlap particle (i.e., ghost) data + integer :: ng_ !< Local number of ghosts + type(part), dimension(:), allocatable :: g !< Array of ghosts of type part + + ! Gravitational acceleration + real(WP), dimension(3) :: gravity=[0.0_WP,0.0_WP,0.0_WP] + + ! Solid volume fraction and momentum + real(WP), dimension(:,:,:), allocatable :: VF !< Volume fraction, cell-centered + real(WP), dimension(:,:,:), allocatable :: VFU !< Solid velocity, U-face + real(WP), dimension(:,:,:), allocatable :: VFV !< Solid velocity, V-face + real(WP), dimension(:,:,:), allocatable :: VFW !< Solid velocity, W-face + + ! CFL numbers + real(WP) :: CFLp_x,CFLp_y,CFLp_z,CFLp_a + + ! Number of substeps for time integrator + real(WP) :: nstep=1 + + ! Monitoring info + real(WP) :: Umin,Umax,Umean !< U velocity info + real(WP) :: Vmin,Vmax,Vmean !< V velocity info + real(WP) :: Wmin,Wmax,Wmean !< W velocity info + real(WP) :: VFmax !< Volume fraction info + real(WP), dimension(3) :: ibmForce !< Total force due to IBM + integer :: np_out !< Number of particles leaving the domain + + contains + procedure :: bond_init !< Setup initial interparticle bonds + procedure :: get_bond_force !< Compute interparticle bond force + procedure :: advance !< Step forward the particle ODEs + procedure :: get_cfl !< Calculate maximum CFL + procedure :: get_max !< Extract various monitoring data + procedure :: update_partmesh !< Update a partmesh object using current particles + procedure :: share !< Share particles across interprocessor boundaries + procedure :: sync !< Synchronize particles across interprocessor boundaries + procedure :: resize !< Resize particle array to given size + procedure :: resize_ghost !< Resize ghost array to given size + procedure :: recycle !< Recycle particle array by removing flagged particles + procedure :: write !< Parallel write particles to file + procedure :: read !< Parallel read particles from file + procedure :: update_VF !< Compute volume fraction + procedure :: get_delta !< Compute regularized delta function + procedure :: interpolate !< Interpolation routine from mesh=>marker + procedure :: extrapolate !< Extrapolation routine from marker=>mesh + procedure :: stretch + end type lss + + + !> Declare lss constructor + interface lss + procedure constructor + end interface lss + +contains + + + ! Quasi-Gaussian weighting function - h is the cut-off + real(WP) function wgauss(d,h) + implicit none + real(WP), intent(in) :: d,h + real(WP), parameter :: coeff=2.6_WP + real(WP) :: hh + hh=coeff*h + if (d.ge.hh) then + wgauss=0.0_WP + else + wgauss=(1.0_WP+4.0_WP*d/hh)*(1.0_WP-d/hh)**4 + end if + end function wgauss + + + !> Default constructor for Lagrangian solid solver + function constructor(cfg,name) result(self) + implicit none + type(lss) :: self + class(config), target, intent(in) :: cfg + character(len=*), optional :: name + integer :: i,j,k + + ! Set the name for the solver + if (present(name)) self%name=trim(adjustl(name)) + + ! Point to pgrid object + self%cfg=>cfg + + ! Set default bonding horizon based on underlying mesh + self%delta=self%cfg%min_meshsize + self%nb=2 + self%min_dist=huge(1.0_WP) + + ! Allocate variables + allocate(self%np_proc(1:self%cfg%nproc)); self%np_proc=0 + self%np_=0; self%np=0 + call self%resize(0) + + ! Initialize MPI derived datatype for a particle + call prepare_mpi_part() + + ! Allocate VF array on cfg mesh + allocate(self%VF(self%cfg%imino_:self%cfg%imaxo_,self%cfg%jmino_:self%cfg%jmaxo_,self%cfg%kmino_:self%cfg%kmaxo_)); self%VF=0.0_WP + allocate(self%VFU(self%cfg%imino_:self%cfg%imaxo_,self%cfg%jmino_:self%cfg%jmaxo_,self%cfg%kmino_:self%cfg%kmaxo_)); self%VFU=0.0_WP + allocate(self%VFV(self%cfg%imino_:self%cfg%imaxo_,self%cfg%jmino_:self%cfg%jmaxo_,self%cfg%kmino_:self%cfg%kmaxo_)); self%VFV=0.0_WP + allocate(self%VFW(self%cfg%imino_:self%cfg%imaxo_,self%cfg%jmino_:self%cfg%jmaxo_,self%cfg%kmino_:self%cfg%kmaxo_)); self%VFW=0.0_WP + + ! Log/screen output + logging: block + use, intrinsic :: iso_fortran_env, only: output_unit + use param, only: verbose + use messager, only: log + use string, only: str_long + character(len=str_long) :: message + if (self%cfg%amRoot) then + write(message,'("LSS object [",a,"] on partitioned grid [",a,"]")') trim(self%name),trim(self%cfg%name) + if (verbose.gt.1) write(output_unit,'(a)') trim(message) + if (verbose.gt.0) call log(message) + end if + end block logging + + end function constructor + + + !> Initialize bond force between particles + subroutine bond_init(this) + use messager, only: die + implicit none + class(lss), intent(inout) :: this + integer, dimension(:,:,:), allocatable :: npic !< Number of particle in cell + integer, dimension(:,:,:,:), allocatable :: ipic !< Index of particle in cell + + ! Communicate particles in ghost cells + call this%share() + + ! We can now assemble particle-in-cell information + pic_prep: block + use mpi_f08 + integer :: i,ip,jp,kp,ierr + integer :: mymax_npic,max_npic + + ! Allocate number of particle in cell + allocate(npic(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)); npic=0 + + ! Count particles and ghosts per cell + do i=1,this%np_ + ip=this%p(i)%ind(1); jp=this%p(i)%ind(2); kp=this%p(i)%ind(3) + npic(ip,jp,kp)=npic(ip,jp,kp)+1 + end do + do i=1,this%ng_ + ip=this%g(i)%ind(1); jp=this%g(i)%ind(2); kp=this%g(i)%ind(3) + npic(ip,jp,kp)=npic(ip,jp,kp)+1 + end do + + ! Get maximum number of particle in cell + mymax_npic=maxval(npic); call MPI_ALLREDUCE(mymax_npic,max_npic,1,MPI_INTEGER,MPI_MAX,this%cfg%comm,ierr) + + ! Allocate pic map + allocate(ipic(1:max_npic,this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)); ipic=0 + + ! Assemble pic map + npic=0 + do i=1,this%np_ + ip=this%p(i)%ind(1); jp=this%p(i)%ind(2); kp=this%p(i)%ind(3) + npic(ip,jp,kp)=npic(ip,jp,kp)+1 + ipic(npic(ip,jp,kp),ip,jp,kp)=+i + end do + do i=1,this%ng_ + ip=this%g(i)%ind(1); jp=this%g(i)%ind(2); kp=this%g(i)%ind(3) + npic(ip,jp,kp)=npic(ip,jp,kp)+1 + ipic(npic(ip,jp,kp),ip,jp,kp)=-i + end do + + end block pic_prep + + ! Establish initial bonds + create_bonds: block + use mpi_f08, only: MPI_ALLREDUCE,MPI_MIN,MPI_IN_PLACE + use parallel, only: MPI_REAL_WP + use mathtools, only: Pi + integer :: i,j,k,n1,nn,n2,ierr + type(part) :: p1,p2 + real(WP), dimension(3) :: rpos + real(WP) :: dist + ! Reset minimum bond distance + this%min_dist=huge(1.0_WP) + ! Loop over particles + do n1=1,this%np_ + ! Create copy of our particle + p1=this%p(n1) + ! Zero out weighted volume + p1%mw=0.0_WP + ! Zero out bonds + p1%ibond=0 + p1%nbond=0 + ! Loop over neighbor cells + do k=p1%ind(3)-this%nb,p1%ind(3)+this%nb + do j=p1%ind(2)-this%nb,p1%ind(2)+this%nb + do i=p1%ind(1)-this%nb,p1%ind(1)+this%nb + ! Loop over particles in that cell + do nn=1,npic(i,j,k) + ! Create copy of our neighbor + n2=ipic(nn,i,j,k) + if (n2.gt.0) then + p2=this%p(+n2) + else if (n2.lt.0) then + p2=this%g(-n2) + end if + ! Cannot self-bond + if (p1%i.eq.p2%i) cycle + ! Cannot bond with different id except <=0 (<=0 bonds with everyone) + if (p1%id.ne.p2%id.and.p1%id.ge.0.and.p2%id.ge.0) cycle + ! Check interparticle distance + rpos=p2%pos-p1%pos + dist=sqrt(dot_product(rpos,rpos)) + if (dist.lt.this%delta) then + ! This particle is in horizon, create a bond + p1%nbond=p1%nbond+1 + if (p1%nbond.gt.max_bond) call die('[lss_class bond_init] Number of detected bonds is larger than max allowed') + p1%ibond(p1%nbond)=p2%i + p1%dbond(p1%nbond)=dist + ! Increment weighted volume + p1%mw=p1%mw+wgauss(dist,this%delta)*dist**2*p1%vol + ! Determine minimum bond distance + this%min_dist=min(this%min_dist,dist) + end if + end do + end do + end do + end do + ! Zero out initial dilatation + p1%dil=0.0_WP + ! Copy back the particle + this%p(n1)=p1 + end do + ! Get global minimum + call MPI_ALLREDUCE(MPI_IN_PLACE,this%min_dist,1,MPI_REAL_WP,MPI_MIN,this%cfg%comm,ierr) + end block create_bonds + + ! Clean up + if (allocated(npic)) deallocate(npic) + if (allocated(ipic)) deallocate(ipic) + + end subroutine bond_init + + + !> Calculate bond force between particles + subroutine get_bond_force(this) + implicit none + class(lss), intent(inout) :: this + integer, dimension(:,:,:), allocatable :: npic !< Number of particle in cell + integer, dimension(:,:,:,:), allocatable :: ipic !< Index of particle in cell + logical :: is2D + + ! Need to modify parameters in 2D + is2D=this%cfg%nx.eq.1.or.this%cfg%ny.eq.1.or.this%cfg%nz.eq.1 + + ! Communicate particles in ghost cells + call this%share() + + ! We can now assemble particle-in-cell information + pic_prep: block + use mpi_f08 + integer :: i,ip,jp,kp,ierr + integer :: mymax_npic,max_npic + + ! Allocate number of particle in cell + allocate(npic(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)); npic=0 + + ! Count particles and ghosts per cell + do i=1,this%np_ + ip=this%p(i)%ind(1); jp=this%p(i)%ind(2); kp=this%p(i)%ind(3) + npic(ip,jp,kp)=npic(ip,jp,kp)+1 + end do + do i=1,this%ng_ + ip=this%g(i)%ind(1); jp=this%g(i)%ind(2); kp=this%g(i)%ind(3) + npic(ip,jp,kp)=npic(ip,jp,kp)+1 + end do + + ! Get maximum number of particle in cell + mymax_npic=maxval(npic); call MPI_ALLREDUCE(mymax_npic,max_npic,1,MPI_INTEGER,MPI_MAX,this%cfg%comm,ierr) + + ! Allocate pic map + allocate(ipic(1:max_npic,this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)); ipic=0 + + ! Assemble pic map + npic=0 + do i=1,this%np_ + ip=this%p(i)%ind(1); jp=this%p(i)%ind(2); kp=this%p(i)%ind(3) + npic(ip,jp,kp)=npic(ip,jp,kp)+1 + ipic(npic(ip,jp,kp),ip,jp,kp)=+i + end do + do i=1,this%ng_ + ip=this%g(i)%ind(1); jp=this%g(i)%ind(2); kp=this%g(i)%ind(3) + npic(ip,jp,kp)=npic(ip,jp,kp)+1 + ipic(npic(ip,jp,kp),ip,jp,kp)=-i + end do + + end block pic_prep + + ! Update weighted volume and dilatation + update_weighted_vol_and_dilatation: block + integer :: i,j,k,n1,nn,n2 + type(part) :: p1,p2 + integer :: nb,nbond + real(WP), dimension(3) :: rpos, Gd_vec + real(WP) :: dist, Gd_mag + ! Loop over particles + do n1=1,this%np_ + ! Create copy of our particle + p1=this%p(n1) + ! Zero out weighted volume and dilatation + p1%mw=0.0_WP + p1%dil=0.0_WP + ! Loop over neighbor cells + do k=p1%ind(3)-this%nb,p1%ind(3)+this%nb + do j=p1%ind(2)-this%nb,p1%ind(2)+this%nb + do i=p1%ind(1)-this%nb,p1%ind(1)+this%nb + ! Loop over particles in that cell + do nn=1,npic(i,j,k) + ! Create copy of our neighbor + n2=ipic(nn,i,j,k) + if (n2.gt.0) then + p2=this%p(+n2) + else if (n2.lt.0) then + p2=this%g(-n2) + end if + ! Check if a bond exists + do nb=1,max_bond + if (p1%ibond(nb).eq.p2%i) then + ! Increment weighted volume + p1%mw=p1%mw+wgauss(p1%dbond(nb),this%delta)*p1%dbond(nb)**2*p2%vol + ! Get current distance + rpos=p2%pos-p1%pos + dist=sqrt(dot_product(rpos,rpos)) + ! compute average G correction for dilitation + Gd_vec = (p2%gd + p1%gd)/2.0_WP + + Gd_mag = sqrt(1.0_WP/(((rpos(1)/dist)/Gd_vec(1))**2 + ((rpos(2)/dist)/Gd_vec(2))**2 + ((rpos(3)/dist)/Gd_vec(3))**2 )) + ! Increment dilatation + p1%dil=p1%dil+wgauss(p1%dbond(nb),this%delta)*p1%dbond(nb)*(dist-p1%dbond(nb))*p2%vol*Gd_mag + end if + end do + end do + end do + end do + end do + ! Rescale dilatation + if (p1%mw.gt.epsilon(1.0_WP)) then + if (is2D) then + ! 2D plane strain + p1%dil=p1%dil*2.0_WP/p1%mw + else + ! 3D + p1%dil=p1%dil*3.0_WP/p1%mw + end if + else + p1%dil=0.0_WP + end if + ! Copy back the particle + this%p(n1)=p1 + end do + end block update_weighted_vol_and_dilatation + + ! Re-communicate particles in ghost cells to update dil and mw + call this%share() + + ! Update bond force, including collision force, and SED + update_bond_force: block + use mpi_f08, only: MPI_ALLREDUCE,MPI_MIN,MPI_IN_PLACE + use parallel, only: MPI_REAL_WP + use mathtools, only: Pi + integer :: i,j,k,n1,nn,n2,ierr + type(part) :: p1,p2 + real(WP), dimension(3) :: rpos,t12,t21,Gd_vec,f + real(WP) :: dist,beta,alpha,ed,t,Gd_mag + real(WP) :: stretch,max_stretch,mu,kk + real(WP) :: nc,rc,kc + integer :: nb,nbond + logical :: found_bond + ! Recompute a few physical parameters + mu=this%elastic_modulus/(2.0_WP+2.0_WP*this%poisson_ratio) + kk=this%elastic_modulus/(3.0_WP-6.0_WP*this%poisson_ratio) + if (is2D) then + if (this%cfg%nx.eq.1) t=this%cfg%xL + if (this%cfg%ny.eq.1) t=this%cfg%yL + if (this%cfg%nz.eq.1) t=this%cfg%zL + max_stretch=sqrt(this%crit_energy/((6.0_WP*mu/Pi+16.0_WP/(9.0_WP*Pi**2)*(kk-2.0_WP*mu))*this%delta)) + kc=15.0_WP*48.0_WP*this%elastic_modulus/(Pi*5.0_WP*t*this%delta**3) + else + max_stretch=sqrt(this%crit_energy/((3.0_WP*mu+(kk-5.0_WP*mu/3.0_WP)*0.75_WP**4)*this%delta)) + kc=15.0_WP*12.0_WP*this%elastic_modulus/(Pi*this%delta**4) + end if + nc=1.0_WP + this%min_dist=huge(1.0_WP) + ! Loop over particles + do n1=1,this%np_ + ! Particles marked 0 do not update their forces + if (this%p(n1)%id.eq.0) cycle + ! Create copy of our particle + p1=this%p(n1) + ! Zero out bond force + p1%Abond=0.0_WP + p1%sigma=0.0_WP + p1%vonMises=0.0_WP + ! Loop over neighbor cells + do k=p1%ind(3)-this%nb,p1%ind(3)+this%nb + do j=p1%ind(2)-this%nb,p1%ind(2)+this%nb + do i=p1%ind(1)-this%nb,p1%ind(1)+this%nb + ! Loop over particles in that cell + do nn=1,npic(i,j,k) + ! Create copy of our neighbor + n2=ipic(nn,i,j,k) + if (n2.gt.0) then + p2=this%p(+n2) + else if (n2.lt.0) then + p2=this%g(-n2) + end if + ! Current distance + rpos=p2%pos-p1%pos + dist=sqrt(dot_product(rpos,rpos)) + ! Check if a bond exists + found_bond=.false. + do nb=1,max_bond + if (p1%ibond(nb).eq.p2%i) then + ! Check for breakage first + stretch=(dist-p1%dbond(nb))/p1%dbond(nb) + if (stretch.gt.max_stretch) then + ! Remove the bond and flag as surface particle + p1%ibond(nb)=0 + p1%dbond(nb)=0.0_WP + cycle + end if + ! Particle 1 + if (is2D) then + ! 2D plane strain + beta = 2.0_WP * kk * p1%dil + alpha = 8.0_WP * mu / p1%mw + ed = dist - p1%dbond(nb) * (1.0_WP + p1%dil / 2.0_WP) + else + ! 3D + beta = 3.0_WP * kk * p1%dil + alpha = 15.0_WP * mu / p1%mw + ed = dist - p1%dbond(nb) * (1.0_WP + p1%dil / 3.0_WP) + end if + ! Force density 1->2 + ! t12=+wgauss(p1%dbond(nb),this%delta)*(beta/p1%mw*p1%dbond(nb)+alpha*ed)*rpos/dist + ! t12=+wgauss(p1%dbond(nb),this%delta)*((3.0_WP*kk - 15.0_WP*mu/3.0_WP)*(p1%dil*p1%dbond(nb)/p1%mw) + 15*mu*dist/p1%mw)*rpos/dist + Gd_vec = (p2%gd + p1%gd)/2.0_WP + Gd_mag = sqrt(1.0_WP/(((rpos(1)/dist)/Gd_vec(1))**2 + ((rpos(2)/dist)/Gd_vec(2))**2 + ((rpos(3)/dist)/Gd_vec(3))**2 )) + t12=+wgauss(p1%dbond(nb),this%delta)*((3.0_WP*kk - 15.0_WP*mu/3.0_WP)*(Gd_mag*p1%dil*p1%dbond(nb)/p1%mw) + (15.0_WP*mu/p1%mw)*(dist - p1%dbond(nb)) )*rpos/dist + ! Particle 2 + p1%vonMises =p1%vonMises + p1%mw/(wgauss(p1%dbond(nb),this%delta)*5.0_WP) * ((alpha * wgauss(p1%dbond(nb),this%delta) * ed)**2) * p2%vol + if (is2D) then + ! 2D plane strain + beta = 2.0_WP * kk * p2%dil + alpha = 8.0_WP * mu / p2%mw + ed = dist - p1%dbond(nb) * (1.0_WP + p2%dil / 2.0_WP) + else + ! 3D + beta = 3.0_WP * kk * p2%dil + alpha = 15.0_WP * mu / p2%mw + ed = dist - p1%dbond(nb) * (1.0_WP + p2%dil / 3.0_WP) + end if + ! Force density 2->1 + ! t21=-wgauss(p1%dbond(nb),this%delta)*(beta/p2%mw*p1%dbond(nb)+alpha*ed)*rpos/dist + t21=-wgauss(p1%dbond(nb),this%delta)*((3.0_WP*kk - 15.0_WP*mu/3.0_WP)*(Gd_mag*p2%dil*p1%dbond(nb)/p2%mw)+ (15.0_WP*mu/p2%mw)*(dist - p1%dbond(nb)) )*rpos/dist ! Increment bond force + p1%Abond=p1%Abond+(t12-t21)*p2%vol/this%rho + f = t12-t21 + p1%sigma(1)=p1%sigma(1) + 0.5_WP*f(1)*rpos(1)*p2%vol + p1%sigma(2)=p1%sigma(2) + 0.5_WP*f(2)*rpos(2)*p2%vol + p1%sigma(3)=p1%sigma(3) + 0.5_WP*f(3)*rpos(3)*p2%vol + p1%sigma(4)=p1%sigma(4) + 0.25_WP*(f(1)*rpos(2) + f(2)*rpos(1))*p2%vol + p1%sigma(5)=p1%sigma(5) + 0.25_WP*(f(1)*rpos(3) + f(3)*rpos(1))*p2%vol + p1%sigma(6)=p1%sigma(6) + 0.25_WP*(f(2)*rpos(3) + f(3)*rpos(2))*p2%vol + ! If still here, we have an active bond + found_bond=.true. + ! Determine minimum bond distance + this%min_dist=min(this%min_dist,dist) + cycle + end if + end do + ! Add collision force now + ! if (is2D) then + ! rc=p1%vol**(1.0_WP/2.0_WP) + ! else + ! rc=p1%vol**(1.0_WP/3.0_WP) + ! end if + ! if (.not.found_bond.and.p1%i.ne.p2%i.and.dist.lt.rc) then + ! p1%Abond=p1%Abond-max(kc*((rc/dist)**nc-1.0_WP),0.0_WP)*(rpos/dist)*p1%vol/this%rho + ! p1%flag = -2 + ! end if + end do + end do + end do + end do + ! Deal with dimensionality + if (this%cfg%nx.eq.1) p1%Abond(1)=0.0_WP + if (this%cfg%ny.eq.1) p1%Abond(2)=0.0_WP + if (this%cfg%nz.eq.1) p1%Abond(3)=0.0_WP + + p1%sigma=p1%sigma/p1%vol + !p1%vonMises=sqrt(((p1%sigma(1)-p1%sigma(2))**2 + (p1%sigma(1)-p1%sigma(3))**2 + (p1%sigma(3)-p1%sigma(2))**2 + 6.0_WP*(p1%sigma(4)**2 + p1%sigma(5)**2 + p1%sigma(6)**2))/2.0_WP) + p1%vonMises = sqrt(p1%vonMises) + ! Copy back the particle + this%p(n1)=p1 + end do + ! Get global minimum + call MPI_ALLREDUCE(MPI_IN_PLACE,this%min_dist,1,MPI_REAL_WP,MPI_MIN,this%cfg%comm,ierr) + end block update_bond_force + + ! Clean up + if (allocated(npic)) deallocate(npic) + if (allocated(ipic)) deallocate(ipic) + + end subroutine get_bond_force + + + !> Advance the particle equations by a specified time step dt + !> p%id=-2 => do not solve for position nor velocity + !> p%id=-1 => do not solve for velocity + !> p%id= 0 => do not update force + + subroutine advance(this,dt)!,stress_x,stress_y,stress_z) + use mpi_f08, only : MPI_SUM,MPI_INTEGER,MPI_IN_PLACE + use mathtools, only: Pi + implicit none + class(lss), intent(inout) :: this + real(WP), intent(inout) :: dt !< Timestep size over which to advance + ! real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(inout) :: stress_x !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + ! real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(inout) :: stress_y !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + ! real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(inout) :: stress_z !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + integer :: n,ierr + ! real(WP), dimension(3) :: stress + + ! Zero out number of particles removed + this%np_out=0 + + ! Advance velocity based on old force and position based on mid-velocity + do n=1,this%np_ + ! Advance with Verlet scheme + if (this%p(n)%id.gt.-1) this%p(n)%vel=this%p(n)%vel+0.5_WP*dt*(this%gravity+this%p(n)%Abond+this%p(n)%Afluid) + if (this%p(n)%id.gt.-2) this%p(n)%pos=this%p(n)%pos+dt*this%p(n)%vel + this%p(n)%displacement=this%p(n)%pos-this%p(n)%ipos + ! Relocalize + this%p(n)%ind=this%cfg%get_ijk_global(this%p(n)%pos,this%p(n)%ind) + ! Correct the position to take into account periodicity + if (this%cfg%xper) this%p(n)%pos(1)=this%cfg%x(this%cfg%imin)+modulo(this%p(n)%pos(1)-this%cfg%x(this%cfg%imin),this%cfg%xL) + if (this%cfg%yper) this%p(n)%pos(2)=this%cfg%y(this%cfg%jmin)+modulo(this%p(n)%pos(2)-this%cfg%y(this%cfg%jmin),this%cfg%yL) + if (this%cfg%zper) this%p(n)%pos(3)=this%cfg%z(this%cfg%kmin)+modulo(this%p(n)%pos(3)-this%cfg%z(this%cfg%kmin),this%cfg%zL) + ! Handle particles that have left the domain + if (this%p(n)%pos(1).lt.this%cfg%x(this%cfg%imin).or.this%p(n)%pos(1).gt.this%cfg%x(this%cfg%imax+1)) this%p(n)%flag=1 + if (this%p(n)%pos(2).lt.this%cfg%y(this%cfg%jmin).or.this%p(n)%pos(2).gt.this%cfg%y(this%cfg%jmax+1)) this%p(n)%flag=1 + if (this%p(n)%pos(3).lt.this%cfg%z(this%cfg%kmin).or.this%p(n)%pos(3).gt.this%cfg%z(this%cfg%kmax+1)) this%p(n)%flag=1 + ! Relocalize the particle + this%p(n)%ind=this%cfg%get_ijk_global(this%p(n)%pos,this%p(n)%ind) + ! Count number of particles removed + if (this%p(n)%flag.eq.1) this%np_out=this%np_out+1 + end do + + ! Communicate particles + call this%sync() + + ! Sum up particles removed + call MPI_ALLREDUCE(this%np_out,n,1,MPI_INTEGER,MPI_SUM,this%cfg%comm,ierr); this%np_out=n + + ! Calculate bond force + call this%get_bond_force() + + ! Advance velocity only based on new force + do n=1,this%np_ + ! Advance with Verlet scheme + if (this%p(n)%id.le.-1) cycle + ! stress=this%cfg%get_velocity(pos=this%p(n)%pos,i0=this%p(n)%ind(1),j0=this%p(n)%ind(2),k0=this%p(n)%ind(3),U=stress_x,V=stress_y,W=stress_z) + ! this%p(n)%Afluid=stress/this%rho + this%p(n)%Afluid=0.0_WP + this%p(n)%vel=this%p(n)%vel+0.5_WP*dt*(this%gravity+this%p(n)%Abond+this%p(n)%Afluid) + end do + + ! Recompute volume fraction + ! call this%update_VF() + + ! Log/screen output + logging: block + use, intrinsic :: iso_fortran_env, only: output_unit + use param, only: verbose + use messager, only: log + use string, only: str_long + character(len=str_long) :: message + if (this%cfg%amRoot) then + write(message,'("Particle solver [",a,"] on partitioned grid [",a,"]: ",i0," particles were advanced")') trim(this%name),trim(this%cfg%name),this%np + if (verbose.gt.1) write(output_unit,'(a)') trim(message) + if (verbose.gt.0) call log(message) + end if + end block logging + + end subroutine advance + + subroutine stretch(this,dt)!,stress_x,stress_y,stress_z) + use mpi_f08, only : MPI_SUM,MPI_INTEGER,MPI_IN_PLACE + use mathtools, only: Pi + implicit none + class(lss), intent(inout) :: this + real(WP), intent(inout) :: dt !< Timestep size over which to advance + real(WP) :: mu + integer :: n,ierr + real(WP), dimension(:,:), allocatable :: temp_gd + + allocate(temp_gd(this%np_, 3)) + !======================================================================================== + ! X-Axis Stretch: + ! Zero out number of particles removed + this%np_out=0 + do n=1,this%np_ + ! Stretch the beam along the x axis with a uniform strain-rate of 0.001 + this%p(n)%pos(1)=this%p(n)%pos(1)*1.001_WP + end do + + ! Communicate particles + call this%sync() + + ! Calculate bond force + call this%get_bond_force() + + mu=this%elastic_modulus/(2.0_WP+2.0_WP*this%poisson_ratio) + + do n=1,this%np_ + temp_gd(n,1)=0.001_WP/this%p(n)%dil + end do + + !======================================================================================== + ! Y-Axis Stretch: + ! Zero out number of particles removed + this%np_out=0 + do n=1,this%np_ + ! Stretch the beam along the x axis with a uniform strain-rate of 0.001 + this%p(n)%pos(1)=this%p(n)%pos(1)/1.001_WP + this%p(n)%pos(2)=this%p(n)%pos(2)*1.001_WP + end do + + ! Communicate particles + call this%sync() + + ! Calculate bond force + call this%get_bond_force() + + mu=this%elastic_modulus/(2.0_WP+2.0_WP*this%poisson_ratio) + + do n=1,this%np_ + temp_gd(n,2)=0.001_WP/this%p(n)%dil + end do + + !======================================================================================== + ! Z-Axis Stretch: + ! Zero out number of particles removed + this%np_out=0 + do n=1,this%np_ + ! Stretch the beam along the x axis with a uniform strain-rate of 0.001 + this%p(n)%pos(2)=this%p(n)%pos(2)/1.001_WP + this%p(n)%pos(3)=this%p(n)%pos(3)*1.001_WP + end do + + ! Communicate particles + call this%sync() + + ! Calculate bond force + call this%get_bond_force() + + mu=this%elastic_modulus/(2.0_WP+2.0_WP*this%poisson_ratio) + + do n=1,this%np_ + temp_gd(n,3)=0.001_WP/this%p(n)%dil + end do + + ! Put the particle back where it was + do n=1,this%np_ + this%p(n)%pos(3)=this%p(n)%pos(3)/1.001_WP + end do + + !====================================================================================== + + ! Now stretch particle for the first time step + + do n=1,this%np_ + ! Stretch the beam along the x axis with a uniform strain-rate of 0.001 + this%p(n)%gd=temp_gd(n,:) + end do + + ! Communicate particles + call this%sync() + + ! Calculate bond force + call this%get_bond_force() + + deallocate(temp_gd) + + + end subroutine stretch + + !> Update particle volume fraction using our current particles + subroutine update_VF(this) + implicit none + class(lss), intent(inout) :: this + integer :: i + ! Reset volume fraction and momentum + this%VF=0.0_WP; this%VFU=0.0_WP; this%VFV=0.0_WP; this%VFW=0.0_WP + ! Transfer particle volume + do i=1,this%np_ + ! Skip inactive particle + if (this%p(i)%flag.eq.1) cycle + ! Transfer volume to mesh + call this%extrapolate(Ap=this%p(i)%vol,xp=this%p(i)%pos(1),yp=this%p(i)%pos(2),zp=this%p(i)%pos(3),ip=this%p(i)%ind(1),jp=this%p(i)%ind(2),kp=this%p(i)%ind(3),A=this%VF,dir='SC') + call this%extrapolate(Ap=this%p(i)%vol*this%p(i)%vel(1),xp=this%p(i)%pos(1),yp=this%p(i)%pos(2),zp=this%p(i)%pos(3),ip=this%p(i)%ind(1),jp=this%p(i)%ind(2),kp=this%p(i)%ind(3),A=this%VFU,dir='U') + call this%extrapolate(Ap=this%p(i)%vol*this%p(i)%vel(2),xp=this%p(i)%pos(1),yp=this%p(i)%pos(2),zp=this%p(i)%pos(3),ip=this%p(i)%ind(1),jp=this%p(i)%ind(2),kp=this%p(i)%ind(3),A=this%VFV,dir='V') + call this%extrapolate(Ap=this%p(i)%vol*this%p(i)%vel(3),xp=this%p(i)%pos(1),yp=this%p(i)%pos(2),zp=this%p(i)%pos(3),ip=this%p(i)%ind(1),jp=this%p(i)%ind(2),kp=this%p(i)%ind(3),A=this%VFW,dir='W') + end do + ! Sum at boundaries + call this%cfg%syncsum(this%VF) + call this%cfg%syncsum(this%VFU) + call this%cfg%syncsum(this%VFV) + call this%cfg%syncsum(this%VFW) + ! Clip + where (this%VF.gt.1.0_WP) this%VF=1.0_WP + where (this%VF.lt.0.0_WP) this%VF=0.0_WP + end subroutine update_VF + + + !> Compute regularized delta function + subroutine get_delta(this,delta,ic,jc,kc,xp,yp,zp,dir) + implicit none + class(lss), intent(inout) :: this + real(WP), intent(out) :: delta !< Return delta function + integer, intent(in) :: ic,jc,kc !< Cell index + real(WP), intent(in) :: xp,yp,zp !< Position of marker + character(len=*) :: dir + real(WP) :: deltax,deltay,deltaz,r + + ! Compute in X + if (trim(adjustl(dir)).eq.'U') then + r=(xp-this%cfg%x(ic))*this%cfg%dxmi(ic) + deltax=roma_kernel(r)*this%cfg%dxmi(ic) + else + r=(xp-this%cfg%xm(ic))*this%cfg%dxi(ic) + deltax=roma_kernel(r)*this%cfg%dxi(ic) + end if + + ! Compute in Y + if (trim(adjustl(dir)).eq.'V') then + r=(yp-this%cfg%y(jc))*this%cfg%dymi(jc) + deltay=roma_kernel(r)*this%cfg%dymi(jc) + else + r=(yp-this%cfg%ym(jc))*this%cfg%dyi(jc) + deltay=roma_kernel(r)*this%cfg%dyi(jc) + end if + + ! Compute in Z + if (trim(adjustl(dir)).eq.'W') then + r=(zp-this%cfg%z(kc))*this%cfg%dzmi(kc) + deltaz=roma_kernel(r)*this%cfg%dzmi(kc) + else + r=(zp-this%cfg%zm(kc))*this%cfg%dzi(kc) + deltaz=roma_kernel(r)*this%cfg%dzi(kc) + end if + !else + + ! Put it all together + delta=deltax*deltay*deltaz + + contains + ! Mollification kernel + ! Roma A, Peskin C and Berger M 1999 J. Comput. Phys. 153 509–534 + function roma_kernel(r) result(phi) + implicit none + real(WP), intent(in) :: r + real(WP) :: phi + if (abs(r).le.0.5_WP) then + phi=1.0_WP/3.0_WP*(1.0_WP+sqrt(-3.0_WP*r**2+1.0_WP)) + else if (abs(r).gt.0.5_WP .and. abs(r).le.1.5_WP) then + phi=1.0_WP/6.0_WP*(5.0_WP-3.0_WP*abs(r)-sqrt(-3.0_WP*(1.0_WP-abs(r))**2+1.0_WP)) + else + phi=0.0_WP + end if + end function roma_kernel + + end subroutine get_delta + + + !> Interpolation routine + function interpolate(this,A,xp,yp,zp,ip,jp,kp,dir) result(Ap) + implicit none + class(lss), intent(inout) :: this + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(in) :: A !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + real(WP), intent(in) :: xp,yp,zp + integer, intent(in) :: ip,jp,kp + character(len=*) :: dir + real(WP) :: Ap + integer :: di,dj,dk + integer :: i1,i2,j1,j2,k1,k2 + real(WP), dimension(-2:+2,-2:+2,-2:+2) :: delta + ! Get the interpolation points + i1=ip-2; i2=ip+2 + j1=jp-2; j2=jp+2 + k1=kp-2; k2=kp+2 + ! Loop over neighboring cells and compute regularized delta function + do dk=-2,+2 + do dj=-2,+2 + do di=-2,+2 + call this%get_delta(delta=delta(di,dj,dk),ic=ip+di,jc=jp+dj,kc=kp+dk,xp=xp,yp=yp,zp=zp,dir=trim(dir)) + end do + end do + end do + ! Perform the actual interpolation on Ap + Ap = sum(delta*A(i1:i2,j1:j2,k1:k2))*this%cfg%vol(ip,jp,kp) + end function interpolate + + + !> Extrapolation routine + subroutine extrapolate(this,Ap,xp,yp,zp,ip,jp,kp,A,dir) + use messager, only: die + implicit none + class(lss), intent(inout) :: this + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:) :: A !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + real(WP), intent(in) :: xp,yp,zp + integer, intent(in) :: ip,jp,kp + real(WP), intent(in) :: Ap + character(len=*) :: dir + real(WP), dimension(-2:+2,-2:+2,-2:+2) :: delta + integer :: di,dj,dk + ! If particle has left processor domain or reached last ghost cell, kill job + if ( ip.lt.this%cfg%imin_-1.or.ip.gt.this%cfg%imax_+1.or.& + & jp.lt.this%cfg%jmin_-1.or.jp.gt.this%cfg%jmax_+1.or.& + & kp.lt.this%cfg%kmin_-1.or.kp.gt.this%cfg%kmax_+1) then + write(*,*) ip,jp,kp,xp,yp,zp + call die('[df extrapolate] Particle has left the domain') + end if + ! Loop over neighboring cells and compute regularized delta function + do dk=-2,+2 + do dj=-2,+2 + do di=-2,+2 + call this%get_delta(delta=delta(di,dj,dk),ic=ip+di,jc=jp+dj,kc=kp+dk,xp=xp,yp=yp,zp=zp,dir=trim(dir)) + end do + end do + end do + ! Perform the actual extrapolation on A + A(ip-2:ip+2,jp-2:jp+2,kp-2:kp+2)=A(ip-2:ip+2,jp-2:jp+2,kp-2:kp+2)+delta*Ap + end subroutine extrapolate + + + !> Calculate the CFL + subroutine get_cfl(this,dt,cfl) + use mpi_f08, only: MPI_ALLREDUCE,MPI_MAX + use parallel, only: MPI_REAL_WP + implicit none + class(lss), intent(inout) :: this + real(WP), intent(in) :: dt + real(WP), intent(out) :: cfl + integer :: i,ierr + real(WP) :: my_CFLp_x,my_CFLp_y,my_CFLp_z,kk,mu,a + + ! Set the CFLs to zero + my_CFLp_x=0.0_WP; my_CFLp_y=0.0_WP; my_CFLp_z=0.0_WP + do i=1,this%np_ + my_CFLp_x=max(my_CFLp_x,abs(this%p(i)%vel(1))*this%cfg%dxi(this%p(i)%ind(1))) + my_CFLp_y=max(my_CFLp_y,abs(this%p(i)%vel(2))*this%cfg%dyi(this%p(i)%ind(2))) + my_CFLp_z=max(my_CFLp_z,abs(this%p(i)%vel(3))*this%cfg%dzi(this%p(i)%ind(3))) + end do + my_CFLp_x=my_CFLp_x*dt; my_CFLp_y=my_CFLp_y*dt; my_CFLp_z=my_CFLp_z*dt + + ! Get the parallel max + call MPI_ALLREDUCE(my_CFLp_x,this%CFLp_x,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + call MPI_ALLREDUCE(my_CFLp_y,this%CFLp_y,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + call MPI_ALLREDUCE(my_CFLp_z,this%CFLp_z,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + + ! CFL based on elastic wave speed in material + kk=this%elastic_modulus/(3.0_WP-6.0_WP*this%poisson_ratio) + mu=this%elastic_modulus/(2.0_WP+2.0_WP*this%poisson_ratio) + a=sqrt((kk+4.0_WP*mu/3.0_WP)/this%rho) + this%CFLp_a=dt*a*3/this%delta + + ! Return the maximum CFL + cfl=max(this%CFLp_x,this%CFLp_y,this%CFLp_z,this%CFLp_a) + + end subroutine get_cfl + + + !> Extract various monitoring data from particle field + subroutine get_max(this) + use mpi_f08, only: MPI_ALLREDUCE,MPI_MAX,MPI_MIN,MPI_SUM + use parallel, only: MPI_REAL_WP + implicit none + class(lss), intent(inout) :: this + real(WP) :: buf,safe_np + real(WP), dimension(3) :: buf3D + integer :: i,j,k,ierr + + ! Create safe np + safe_np=real(max(this%np,1),WP) + + ! Velocity min/max/mean + this%Umin=huge(1.0_WP); this%Umax=-huge(1.0_WP); this%Umean=0.0_WP + this%Vmin=huge(1.0_WP); this%Vmax=-huge(1.0_WP); this%Vmean=0.0_WP + this%Wmin=huge(1.0_WP); this%Wmax=-huge(1.0_WP); this%Wmean=0.0_WP + this%ibmForce=0.0_WP + do i=1,this%np_ + this%Umin=min(this%Umin,this%p(i)%vel(1)); this%Umax=max(this%Umax,this%p(i)%vel(1)); this%Umean=this%Umean+this%p(i)%vel(1) + this%Vmin=min(this%Vmin,this%p(i)%vel(2)); this%Vmax=max(this%Vmax,this%p(i)%vel(2)); this%Vmean=this%Vmean+this%p(i)%vel(2) + this%Wmin=min(this%Wmin,this%p(i)%vel(3)); this%Wmax=max(this%Wmax,this%p(i)%vel(3)); this%Wmean=this%Wmean+this%p(i)%vel(3) + this%ibmForce=this%ibmForce+this%p(i)%Afluid*this%p(i)%vol*this%rho + end do + call MPI_ALLREDUCE(this%Umin ,buf,1,MPI_REAL_WP,MPI_MIN,this%cfg%comm,ierr); this%Umin =buf + call MPI_ALLREDUCE(this%Umax ,buf,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr); this%Umax =buf + call MPI_ALLREDUCE(this%Umean,buf,1,MPI_REAL_WP,MPI_SUM,this%cfg%comm,ierr); this%Umean=buf/safe_np + call MPI_ALLREDUCE(this%Vmin ,buf,1,MPI_REAL_WP,MPI_MIN,this%cfg%comm,ierr); this%Vmin =buf + call MPI_ALLREDUCE(this%Vmax ,buf,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr); this%Vmax =buf + call MPI_ALLREDUCE(this%Vmean,buf,1,MPI_REAL_WP,MPI_SUM,this%cfg%comm,ierr); this%Vmean=buf/safe_np + call MPI_ALLREDUCE(this%Wmin ,buf,1,MPI_REAL_WP,MPI_MIN,this%cfg%comm,ierr); this%Wmin =buf + call MPI_ALLREDUCE(this%Wmax ,buf,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr); this%Wmax =buf + call MPI_ALLREDUCE(this%Wmean,buf,1,MPI_REAL_WP,MPI_SUM,this%cfg%comm,ierr); this%Wmean=buf/safe_np + call MPI_ALLREDUCE(this%ibmForce,buf3D,3,MPI_REAL_WP,MPI_SUM,this%cfg%comm,ierr); this%ibmForce=buf3D + + ! Get max volume fraction + this%VFmax =-huge(1.0_WP) + do k=this%cfg%kmin_,this%cfg%kmax_ + do j=this%cfg%jmin_,this%cfg%jmax_ + do i=this%cfg%imin_,this%cfg%imax_ + this%VFmax=max(this%VFmax,this%VF(i,j,k)) + end do + end do + end do + call MPI_ALLREDUCE(this%VFmax,buf,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr); this%VFmax=buf + + end subroutine get_max + + + !> Update particle mesh using our current particles + subroutine update_partmesh(this,pmesh) + use partmesh_class, only: partmesh + implicit none + class(lss), intent(inout) :: this + class(partmesh), intent(inout) :: pmesh + integer :: i + ! Reset particle mesh storage + call pmesh%reset() + ! Nothing else to do if no particle is present + if (this%np_.eq.0) return + ! Copy particle info + call pmesh%set_size(this%np_) + do i=1,this%np_ + pmesh%pos(:,i)=this%p(i)%pos + end do + end subroutine update_partmesh + + + !> Creation of the MPI datatype for particle + subroutine prepare_mpi_part() + use mpi_f08 + use messager, only: die + implicit none + integer(MPI_ADDRESS_KIND), dimension(part_nblock) :: disp + integer(MPI_ADDRESS_KIND) :: lb,extent + type(MPI_Datatype) :: MPI_PART_TMP + integer :: i,mysize,ierr + ! Prepare the displacement array + disp(1)=0 + do i=2,part_nblock + call MPI_Type_size(part_tblock(i-1),mysize,ierr) + disp(i)=disp(i-1)+int(mysize,MPI_ADDRESS_KIND)*int(part_lblock(i-1),MPI_ADDRESS_KIND) + end do + ! Create and commit the new type + call MPI_Type_create_struct(part_nblock,part_lblock,disp,part_tblock,MPI_PART_TMP,ierr) + call MPI_Type_get_extent(MPI_PART_TMP,lb,extent,ierr) + call MPI_Type_create_resized(MPI_PART_TMP,lb,extent,MPI_PART,ierr) + call MPI_Type_commit(MPI_PART,ierr) + ! If a problem was encountered, say it + if (ierr.ne.0) call die('[lss prepare_mpi_part] MPI Particle type creation failed') + ! Get the size of this type + call MPI_type_size(MPI_PART,MPI_PART_SIZE,ierr) + end subroutine prepare_mpi_part + + + !> Share particles across processor boundaries + subroutine share(this,nover) + use mpi_f08 + use messager, only: warn,die + implicit none + class(lss), intent(inout) :: this + integer, optional :: nover + type(part), dimension(:), allocatable :: tosend + type(part), dimension(:), allocatable :: torecv + integer :: no,nsend,nrecv + type(MPI_Status) :: status + integer :: icnt,isrc,idst,ierr + integer :: i,n + + ! Check overlap size + if (present(nover)) then + no=nover + if (no.gt.this%cfg%no) then + call warn('[lss share] Specified overlap is larger than that of cfg - reducing no') + no=this%cfg%no + else if (no.le.0) then + call die('[lss share] Specified overlap cannot be less or equal to zero') + end if + else + no=1 + end if + + ! Clean up ghost array + call this%resize_ghost(n=0); this%ng_=0 + + ! Share ghost particles in -x (no ghosts are sent here) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(1).lt.this%cfg%imin_+no) nsend=nsend+1 + end do + allocate(tosend(nsend)) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(1).lt.this%cfg%imin_+no) then + nsend=nsend+1 + tosend(nsend)=this%p(n) + if (this%cfg%xper.and.tosend(nsend)%ind(1).lt.this%cfg%imin+no) then + tosend(nsend)%pos(1)=tosend(nsend)%pos(1)+this%cfg%xL + tosend(nsend)%ind(1)=tosend(nsend)%ind(1)+this%cfg%nx + end if + end if + end do + nrecv=0 + call MPI_CART_SHIFT(this%cfg%comm,0,-1,isrc,idst,ierr) + call MPI_SENDRECV(nsend,1,MPI_INTEGER,idst,0,nrecv,1,MPI_INTEGER,isrc,0,this%cfg%comm,status,ierr) + allocate(torecv(nrecv)) + call MPI_SENDRECV(tosend,nsend,MPI_PART,idst,0,torecv,nrecv,MPI_PART,isrc,0,this%cfg%comm,status,ierr) + call this%resize_ghost(this%ng_+nrecv) + this%g(this%ng_+1:this%ng_+nrecv)=torecv + this%ng_=this%ng_+nrecv + if (allocated(tosend)) deallocate(tosend) + if (allocated(torecv)) deallocate(torecv) + + ! Share ghost particles in +x (no ghosts are sent here) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(1).gt.this%cfg%imax_-no) nsend=nsend+1 + end do + allocate(tosend(nsend)) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(1).gt.this%cfg%imax_-no) then + nsend=nsend+1 + tosend(nsend)=this%p(n) + if (this%cfg%xper.and.tosend(nsend)%ind(1).gt.this%cfg%imax-no) then + tosend(nsend)%pos(1)=tosend(nsend)%pos(1)-this%cfg%xL + tosend(nsend)%ind(1)=tosend(nsend)%ind(1)-this%cfg%nx + end if + end if + end do + nrecv=0 + call MPI_CART_SHIFT(this%cfg%comm,0,+1,isrc,idst,ierr) + call MPI_SENDRECV(nsend,1,MPI_INTEGER,idst,0,nrecv,1,MPI_INTEGER,isrc,0,this%cfg%comm,status,ierr) + allocate(torecv(nrecv)) + call MPI_SENDRECV(tosend,nsend,MPI_PART,idst,0,torecv,nrecv,MPI_PART,isrc,0,this%cfg%comm,status,ierr) + call this%resize_ghost(this%ng_+nrecv) + this%g(this%ng_+1:this%ng_+nrecv)=torecv + this%ng_=this%ng_+nrecv + if (allocated(tosend)) deallocate(tosend) + if (allocated(torecv)) deallocate(torecv) + + ! Share ghost particles in -y (ghosts need to be sent now) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(2).lt.this%cfg%jmin_+no) nsend=nsend+1 + end do + do n=1,this%ng_ + if (this%g(n)%ind(2).lt.this%cfg%jmin_+no) nsend=nsend+1 + end do + allocate(tosend(nsend)) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(2).lt.this%cfg%jmin_+no) then + nsend=nsend+1 + tosend(nsend)=this%p(n) + if (this%cfg%yper.and.tosend(nsend)%ind(2).lt.this%cfg%jmin+no) then + tosend(nsend)%pos(2)=tosend(nsend)%pos(2)+this%cfg%yL + tosend(nsend)%ind(2)=tosend(nsend)%ind(2)+this%cfg%ny + end if + end if + end do + do n=1,this%ng_ + if (this%g(n)%ind(2).lt.this%cfg%jmin_+no) then + nsend=nsend+1 + tosend(nsend)=this%g(n) + if (this%cfg%yper.and.tosend(nsend)%ind(2).lt.this%cfg%jmin+no) then + tosend(nsend)%pos(2)=tosend(nsend)%pos(2)+this%cfg%yL + tosend(nsend)%ind(2)=tosend(nsend)%ind(2)+this%cfg%ny + end if + end if + end do + nrecv=0 + call MPI_CART_SHIFT(this%cfg%comm,1,-1,isrc,idst,ierr) + call MPI_SENDRECV(nsend,1,MPI_INTEGER,idst,0,nrecv,1,MPI_INTEGER,isrc,0,this%cfg%comm,status,ierr) + allocate(torecv(nrecv)) + call MPI_SENDRECV(tosend,nsend,MPI_PART,idst,0,torecv,nrecv,MPI_PART,isrc,0,this%cfg%comm,status,ierr) + call this%resize_ghost(this%ng_+nrecv) + this%g(this%ng_+1:this%ng_+nrecv)=torecv + this%ng_=this%ng_+nrecv + if (allocated(tosend)) deallocate(tosend) + if (allocated(torecv)) deallocate(torecv) + + ! Share ghost particles in +y (ghosts need to be sent now - but not newly received ghosts!) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(2).gt.this%cfg%jmax_-no) nsend=nsend+1 + end do + do n=1,this%ng_-nrecv + if (this%g(n)%ind(2).gt.this%cfg%jmax_-no) nsend=nsend+1 + end do + allocate(tosend(nsend)) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(2).gt.this%cfg%jmax_-no) then + nsend=nsend+1 + tosend(nsend)=this%p(n) + if (this%cfg%yper.and.tosend(nsend)%ind(2).gt.this%cfg%jmax-no) then + tosend(nsend)%pos(2)=tosend(nsend)%pos(2)-this%cfg%yL + tosend(nsend)%ind(2)=tosend(nsend)%ind(2)-this%cfg%ny + end if + end if + end do + do n=1,this%ng_-nrecv + if (this%g(n)%ind(2).gt.this%cfg%jmax_-no) then + nsend=nsend+1 + tosend(nsend)=this%g(n) + if (this%cfg%yper.and.tosend(nsend)%ind(2).gt.this%cfg%jmax-no) then + tosend(nsend)%pos(2)=tosend(nsend)%pos(2)-this%cfg%yL + tosend(nsend)%ind(2)=tosend(nsend)%ind(2)-this%cfg%ny + end if + end if + end do + nrecv=0 + call MPI_CART_SHIFT(this%cfg%comm,1,+1,isrc,idst,ierr) + call MPI_SENDRECV(nsend,1,MPI_INTEGER,idst,0,nrecv,1,MPI_INTEGER,isrc,0,this%cfg%comm,status,ierr) + allocate(torecv(nrecv)) + call MPI_SENDRECV(tosend,nsend,MPI_PART,idst,0,torecv,nrecv,MPI_PART,isrc,0,this%cfg%comm,status,ierr) + call this%resize_ghost(this%ng_+nrecv) + this%g(this%ng_+1:this%ng_+nrecv)=torecv + this%ng_=this%ng_+nrecv + if (allocated(tosend)) deallocate(tosend) + if (allocated(torecv)) deallocate(torecv) + + ! Share ghost particles in -z (ghosts need to be sent now) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(3).lt.this%cfg%kmin_+no) nsend=nsend+1 + end do + do n=1,this%ng_ + if (this%g(n)%ind(3).lt.this%cfg%kmin_+no) nsend=nsend+1 + end do + allocate(tosend(nsend)) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(3).lt.this%cfg%kmin_+no) then + nsend=nsend+1 + tosend(nsend)=this%p(n) + if (this%cfg%zper.and.tosend(nsend)%ind(3).lt.this%cfg%kmin+no) then + tosend(nsend)%pos(3)=tosend(nsend)%pos(3)+this%cfg%zL + tosend(nsend)%ind(3)=tosend(nsend)%ind(3)+this%cfg%nz + end if + end if + end do + do n=1,this%ng_ + if (this%g(n)%ind(3).lt.this%cfg%kmin_+no) then + nsend=nsend+1 + tosend(nsend)=this%g(n) + if (this%cfg%zper.and.tosend(nsend)%ind(3).lt.this%cfg%kmin+no) then + tosend(nsend)%pos(3)=tosend(nsend)%pos(3)+this%cfg%zL + tosend(nsend)%ind(3)=tosend(nsend)%ind(3)+this%cfg%nz + end if + end if + end do + nrecv=0 + call MPI_CART_SHIFT(this%cfg%comm,2,-1,isrc,idst,ierr) + call MPI_SENDRECV(nsend,1,MPI_INTEGER,idst,0,nrecv,1,MPI_INTEGER,isrc,0,this%cfg%comm,status,ierr) + allocate(torecv(nrecv)) + call MPI_SENDRECV(tosend,nsend,MPI_PART,idst,0,torecv,nrecv,MPI_PART,isrc,0,this%cfg%comm,status,ierr) + call this%resize_ghost(this%ng_+nrecv) + this%g(this%ng_+1:this%ng_+nrecv)=torecv + this%ng_=this%ng_+nrecv + if (allocated(tosend)) deallocate(tosend) + if (allocated(torecv)) deallocate(torecv) + + ! Share ghost particles in +z (ghosts need to be sent now - but not newly received ghosts!) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(3).gt.this%cfg%kmax_-no) nsend=nsend+1 + end do + do n=1,this%ng_-nrecv + if (this%g(n)%ind(3).gt.this%cfg%kmax_-no) nsend=nsend+1 + end do + allocate(tosend(nsend)) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(3).gt.this%cfg%kmax_-no) then + nsend=nsend+1 + tosend(nsend)=this%p(n) + if (this%cfg%zper.and.tosend(nsend)%ind(3).gt.this%cfg%kmax-no) then + tosend(nsend)%pos(3)=tosend(nsend)%pos(3)-this%cfg%zL + tosend(nsend)%ind(3)=tosend(nsend)%ind(3)-this%cfg%nz + end if + end if + end do + do n=1,this%ng_-nrecv + if (this%g(n)%ind(3).gt.this%cfg%kmax_-no) then + nsend=nsend+1 + tosend(nsend)=this%g(n) + if (this%cfg%zper.and.tosend(nsend)%ind(3).gt.this%cfg%kmax-no) then + tosend(nsend)%pos(3)=tosend(nsend)%pos(3)-this%cfg%zL + tosend(nsend)%ind(3)=tosend(nsend)%ind(3)-this%cfg%nz + end if + end if + end do + nrecv=0 + call MPI_CART_SHIFT(this%cfg%comm,2,+1,isrc,idst,ierr) + call MPI_SENDRECV(nsend,1,MPI_INTEGER,idst,0,nrecv,1,MPI_INTEGER,isrc,0,this%cfg%comm,status,ierr) + allocate(torecv(nrecv)) + call MPI_SENDRECV(tosend,nsend,MPI_PART,idst,0,torecv,nrecv,MPI_PART,isrc,0,this%cfg%comm,status,ierr) + call this%resize_ghost(this%ng_+nrecv) + this%g(this%ng_+1:this%ng_+nrecv)=torecv + this%ng_=this%ng_+nrecv + if (allocated(tosend)) deallocate(tosend) + if (allocated(torecv)) deallocate(torecv) + + end subroutine share + + + !> Synchronize particle arrays across processors + subroutine sync(this) + use mpi_f08 + implicit none + class(lss), intent(inout) :: this + integer, dimension(0:this%cfg%nproc-1) :: nsend_proc,nrecv_proc + integer, dimension(0:this%cfg%nproc-1) :: nsend_disp,nrecv_disp + integer :: n,prank,ierr + type(part), dimension(:), allocatable :: buf_send + ! Recycle first to minimize communication load + call this%recycle() + ! Prepare information about what to send + nsend_proc=0 + do n=1,this%np_ + prank=this%cfg%get_rank(this%p(n)%ind) + nsend_proc(prank)=nsend_proc(prank)+1 + end do + nsend_proc(this%cfg%rank)=0 + ! Inform processors of what they will receive + call MPI_ALLtoALL(nsend_proc,1,MPI_INTEGER,nrecv_proc,1,MPI_INTEGER,this%cfg%comm,ierr) + ! Prepare displacements for all-to-all + nsend_disp(0)=0 + nrecv_disp(0)=this%np_ !< Directly add particles at the end of main array + do n=1,this%cfg%nproc-1 + nsend_disp(n)=nsend_disp(n-1)+nsend_proc(n-1) + nrecv_disp(n)=nrecv_disp(n-1)+nrecv_proc(n-1) + end do + ! Allocate buffer to send particles + allocate(buf_send(sum(nsend_proc))) + ! Pack the particles in the send buffer + nsend_proc=0 + do n=1,this%np_ + ! Get the rank + prank=this%cfg%get_rank(this%p(n)%ind) + ! Skip particles still inside + if (prank.eq.this%cfg%rank) cycle + ! Pack up for sending + nsend_proc(prank)=nsend_proc(prank)+1 + buf_send(nsend_disp(prank)+nsend_proc(prank))=this%p(n) + ! Flag particle for removal + this%p(n)%flag=1 + end do + ! Allocate buffer for receiving particles + call this%resize(this%np_+sum(nrecv_proc)) + ! Perform communication + call MPI_ALLtoALLv(buf_send,nsend_proc,nsend_disp,MPI_PART,this%p,nrecv_proc,nrecv_disp,MPI_PART,this%cfg%comm,ierr) + ! Deallocate buffer + deallocate(buf_send) + ! Recycle to remove duplicate particles + call this%recycle() + end subroutine sync + + + !> Adaptation of particle array size + subroutine resize(this,n) + implicit none + class(lss), intent(inout) :: this + integer, intent(in) :: n + type(part), dimension(:), allocatable :: tmp + integer :: size_now,size_new + ! Resize particle array to size n + if (.not.allocated(this%p)) then + ! Allocate directly to size n + allocate(this%p(n)) + this%p(1:n)%flag=1 + else + ! Update from a non-zero size to another non-zero size + size_now=size(this%p,dim=1) + if (n.gt.size_now) then + size_new=max(n,int(real(size_now,WP)*coeff_up)) + allocate(tmp(size_new)) + tmp(1:size_now)=this%p + tmp(size_now+1:)%flag=1 + call move_alloc(tmp,this%p) + else if (n.lt.int(real(size_now,WP)*coeff_dn)) then + allocate(tmp(n)) + tmp(1:n)=this%p(1:n) + call move_alloc(tmp,this%p) + end if + end if + end subroutine resize + + + !> Adaptation of ghost array size + subroutine resize_ghost(this,n) + implicit none + class(lss), intent(inout) :: this + integer, intent(in) :: n + type(part), dimension(:), allocatable :: tmp + integer :: size_now,size_new + ! Resize ghost array to size n + if (.not.allocated(this%g)) then + ! Allocate directly to size n + allocate(this%g(n)) + this%g(1:n)%flag=1 + else + ! Update from a non-zero size to another non-zero size + size_now=size(this%g,dim=1) + if (n.gt.size_now) then + size_new=max(n,int(real(size_now,WP)*coeff_up)) + allocate(tmp(size_new)) + tmp(1:size_now)=this%g + tmp(size_now+1:)%flag=1 + call move_alloc(tmp,this%g) + else if (n.lt.int(real(size_now,WP)*coeff_dn)) then + allocate(tmp(n)) + tmp(1:n)=this%g(1:n) + call move_alloc(tmp,this%g) + end if + end if + end subroutine resize_ghost + + + !> Clean-up of particle array by removing flag=1 particles + subroutine recycle(this) + implicit none + class(lss), intent(inout) :: this + integer :: new_size,i,ierr + ! Compact all active particles at the beginning of the array + new_size=0 + if (allocated(this%p)) then + do i=1,size(this%p,dim=1) + if (this%p(i)%flag.ne.1) then + new_size=new_size+1 + if (i.ne.new_size) then + this%p(new_size)=this%p(i) + this%p(i)%flag=1 + end if + end if + end do + end if + ! Resize to new size + call this%resize(new_size) + ! Update number of particles + this%np_=new_size + call MPI_ALLGATHER(this%np_,1,MPI_INTEGER,this%np_proc,1,MPI_INTEGER,this%cfg%comm,ierr) + this%np=sum(this%np_proc) + end subroutine recycle + + + !> Parallel write particles to file + subroutine write(this,filename) + use mpi_f08 + use messager, only: die + use parallel, only: info_mpiio + implicit none + class(lss), intent(inout) :: this + character(len=*), intent(in) :: filename + type(MPI_File) :: ifile + type(MPI_Status):: status + integer(kind=MPI_OFFSET_KIND) :: offset + integer :: i,ierr,iunit + + ! Root serial-writes the file header + if (this%cfg%amRoot) then + ! Open the file + open(newunit=iunit,file=trim(filename),form='unformatted',status='replace',access='stream',iostat=ierr) + if (ierr.ne.0) call die('[lss write] Problem encountered while serial-opening data file: '//trim(filename)) + ! Number of particles and particle object size + write(iunit) this%np,MPI_PART_SIZE + ! Done with the header + close(iunit) + end if + + ! The rest is done in parallel + call MPI_FILE_OPEN(this%cfg%comm,trim(filename),IOR(MPI_MODE_WRONLY,MPI_MODE_APPEND),info_mpiio,ifile,ierr) + if (ierr.ne.0) call die('[lss write] Problem encountered while parallel-opening data file: '//trim(filename)) + + ! Get current position + call MPI_FILE_GET_POSITION(ifile,offset,ierr) + + ! Compute the offset and write + do i=1,this%cfg%rank + offset=offset+int(this%np_proc(i),MPI_OFFSET_KIND)*int(MPI_PART_SIZE,MPI_OFFSET_KIND) + end do + if (this%np_.gt.0) call MPI_FILE_WRITE_AT(ifile,offset,this%p,this%np_,MPI_PART,status,ierr) + + ! Close the file + call MPI_FILE_CLOSE(ifile,ierr) + + ! Log/screen output + logging: block + use, intrinsic :: iso_fortran_env, only: output_unit + use param, only: verbose + use messager, only: log + use string, only: str_long + character(len=str_long) :: message + if (this%cfg%amRoot) then + write(message,'("[lss write] Wrote ",i0," particles to file [",a,"] on partitioned grid [",a,"]")') this%np,trim(filename),trim(this%cfg%name) + if (verbose.gt.2) write(output_unit,'(a)') trim(message) + if (verbose.gt.1) call log(message) + end if + end block logging + + end subroutine write + + + !> Parallel read particles to file + subroutine read(this,filename) + use mpi_f08 + use messager, only: die + use parallel, only: info_mpiio + implicit none + class(lss), intent(inout) :: this + character(len=*), intent(in) :: filename + type(MPI_File) :: ifile + type(MPI_Status):: status + integer(kind=MPI_OFFSET_KIND) :: offset,header_offset + integer :: i,j,ierr,npadd,psize,nchunk,cnt + integer, dimension(:,:), allocatable :: ppp + + ! First open the file in parallel + call MPI_FILE_OPEN(this%cfg%comm,trim(filename),MPI_MODE_RDONLY,info_mpiio,ifile,ierr) + if (ierr.ne.0) call die('[lss read] Problem encountered while reading data file: '//trim(filename)) + + ! Read file header first + call MPI_FILE_READ_ALL(ifile,npadd,1,MPI_INTEGER,status,ierr) + call MPI_FILE_READ_ALL(ifile,psize,1,MPI_INTEGER,status,ierr) + + ! Remember current position + call MPI_FILE_GET_POSITION(ifile,header_offset,ierr) + + ! Check compatibility of particle type + if (psize.ne.MPI_PART_SIZE) call die('[lss read] Particle type unreadable') + + ! Naively share reading task among all processors + nchunk=int(npadd/(this%cfg%nproc*part_chunk_size))+1 + allocate(ppp(this%cfg%nproc,nchunk)) + ppp=int(npadd/(this%cfg%nproc*nchunk)) + cnt=0 + out:do j=1,nchunk + do i=1,this%cfg%nproc + cnt=cnt+1 + if (cnt.gt.mod(npadd,this%cfg%nproc*nchunk)) exit out + ppp(i,j)=ppp(i,j)+1 + end do + end do out + + ! Read by chunk + do j=1,nchunk + ! Find offset + offset=header_offset+int(MPI_PART_SIZE,MPI_OFFSET_KIND)*int(sum(ppp(1:this%cfg%rank,:))+sum(ppp(this%cfg%rank+1,1:j-1)),MPI_OFFSET_KIND) + ! Resize particle array + call this%resize(this%np_+ppp(this%cfg%rank+1,j)) + ! Read this file + call MPI_FILE_READ_AT(ifile,offset,this%p(this%np_+1:this%np_+ppp(this%cfg%rank+1,j)),ppp(this%cfg%rank+1,j),MPI_PART,status,ierr) + ! Most general case: relocate every droplet + do i=this%np_+1,this%np_+ppp(this%cfg%rank+1,j) + this%p(i)%ind=this%cfg%get_ijk_global(this%p(i)%pos,this%p(i)%ind) + end do + ! Exchange all that + call this%sync() + end do + + ! Close the file + call MPI_FILE_CLOSE(ifile,ierr) + + ! Log/screen output + logging: block + use, intrinsic :: iso_fortran_env, only: output_unit + use param, only: verbose + use messager, only: log + use string, only: str_long + character(len=str_long) :: message + if (this%cfg%amRoot) then + write(message,'("[lss read] Read ",i0," particles from file [",a,"] on partitioned grid [",a,"]")') npadd,trim(filename),trim(this%cfg%name) + if (verbose.gt.2) write(output_unit,'(a)') trim(message) + if (verbose.gt.1) call log(message) + end if + end block logging + + end subroutine read + + +end module lss_class diff --git a/examples/plate_with_hole/src/lss_class_3_axis.f90 b/examples/plate_with_hole/src/lss_class_3_axis.f90 new file mode 100644 index 000000000..1650239f7 --- /dev/null +++ b/examples/plate_with_hole/src/lss_class_3_axis.f90 @@ -0,0 +1,1637 @@ +!> Lagrangian solid solver object +!> Implements peridynamics equations +module lss_class + use precision, only: WP + use string, only: str_medium + use config_class, only: config + use mpi_f08, only: MPI_Datatype,MPI_INTEGER8,MPI_INTEGER,MPI_DOUBLE_PRECISION + implicit none + private + + + ! Expose type/constructor/methods + public :: lss + + + !> Memory adaptation parameter + real(WP), parameter :: coeff_up=1.3_WP !< Particle array size increase factor + real(WP), parameter :: coeff_dn=0.7_WP !< Particle array size decrease factor + + + !> I/O chunk size to read at a time + integer, parameter :: part_chunk_size=1000 !< Read 1000 particles at a time before redistributing + + + !> Maximum number of bonds per particle + integer, parameter, public :: max_bond=400 !< Assumes something like a 7x7x7 stencil in 3D + + + !> Bonded solid particle definition + type :: part + !> MPI_DOUBLE_PRECISION data + real(WP) :: mw !< Weighted volume + real(WP) :: dil !< Element dilatation + real(WP) :: ste !< Element dilatation + real(WP) :: vol !< Particle volume + real(WP), dimension(max_bond) :: dbond !< Length of initial bonds + real(WP), dimension(3) :: pos !< Particle center coordinates + real(WP), dimension(3) :: vel !< Velocity of particle + real(WP), dimension(3) :: Abond !< Bond acceleration for particle + real(WP), dimension(3) :: Afluid !< Fluid acceleration for particle + real(WP), dimension(3) :: gd !< Dilitation corrections + real(WP), dimension(3) :: gb !< Shear corrections + !> MPI_INTEGER data + integer :: id !< ID the object is associated with + integer :: i !< Unique index of particle (assumed >0) + integer :: nbond !< Number of initial bonds + integer, dimension(max_bond) :: ibond !< Indices of initially bonded particles (0 values ignored) + integer , dimension(3) :: ind !< Index of cell containing particle center + integer :: flag !< Control parameter (0=normal, 1=done->will be removed) + end type part + !> Number of blocks, block length, and block types in a particle + integer, parameter :: part_nblock=2 + integer , dimension(part_nblock) :: part_lblock=[22+max_bond,7+max_bond] + type(MPI_Datatype), dimension(part_nblock) :: part_tblock=[MPI_DOUBLE_PRECISION,MPI_INTEGER] + !> MPI_PART derived datatype and size + type(MPI_Datatype) :: MPI_PART + integer :: MPI_PART_SIZE + + + !> Lagrangian solid solver object definition + type :: lss + + ! This config is used for parallelization and for calculating bond/collision forces + class(config), pointer :: cfg + + ! This is the name of the solver + character(len=str_medium) :: name='UNNAMED_LSS' + + ! Solid material properties + real(WP) :: elastic_modulus !< Elastic modulus of the material + real(WP) :: poisson_ratio !< Poisson's ratio of the material + real(WP) :: rho !< Density of the material + real(WP) :: crit_energy !< Critical energy release + + ! Bonding parameters + real(WP) :: delta !< Bonding horizon (distance) + real(WP) :: min_dist !< Minimum bonding distance + integer :: nb !< Cell-based horizon + + ! Global and local particle data + integer :: np !< Global number of particles + integer :: np_ !< Local number of particles + integer, dimension(:), allocatable :: np_proc !< Number of particles on each processor + type(part), dimension(:), allocatable :: p !< Array of particles of type part + + ! Overlap particle (i.e., ghost) data + integer :: ng_ !< Local number of ghosts + type(part), dimension(:), allocatable :: g !< Array of ghosts of type part + + ! Gravitational acceleration + real(WP), dimension(3) :: gravity=[0.0_WP,0.0_WP,0.0_WP] + + ! Solid volume fraction and momentum + real(WP), dimension(:,:,:), allocatable :: VF !< Volume fraction, cell-centered + real(WP), dimension(:,:,:), allocatable :: VFU !< Solid velocity, U-face + real(WP), dimension(:,:,:), allocatable :: VFV !< Solid velocity, V-face + real(WP), dimension(:,:,:), allocatable :: VFW !< Solid velocity, W-face + + ! CFL numbers + real(WP) :: CFLp_x,CFLp_y,CFLp_z,CFLp_a + + ! Number of substeps for time integrator + real(WP) :: nstep=1 + + ! Monitoring info + real(WP) :: Umin,Umax,Umean !< U velocity info + real(WP) :: Vmin,Vmax,Vmean !< V velocity info + real(WP) :: Wmin,Wmax,Wmean !< W velocity info + real(WP) :: VFmax !< Volume fraction info + real(WP), dimension(3) :: ibmForce !< Total force due to IBM + integer :: np_out !< Number of particles leaving the domain + + contains + procedure :: bond_init !< Setup initial interparticle bonds + procedure :: get_bond_force !< Compute interparticle bond force + procedure :: advance !< Step forward the particle ODEs + procedure :: get_cfl !< Calculate maximum CFL + procedure :: get_max !< Extract various monitoring data + procedure :: update_partmesh !< Update a partmesh object using current particles + procedure :: share !< Share particles across interprocessor boundaries + procedure :: sync !< Synchronize particles across interprocessor boundaries + procedure :: resize !< Resize particle array to given size + procedure :: resize_ghost !< Resize ghost array to given size + procedure :: recycle !< Recycle particle array by removing flagged particles + procedure :: write !< Parallel write particles to file + procedure :: read !< Parallel read particles from file + procedure :: update_VF !< Compute volume fraction + procedure :: get_delta !< Compute regularized delta function + procedure :: interpolate !< Interpolation routine from mesh=>marker + procedure :: extrapolate !< Extrapolation routine from marker=>mesh + procedure :: stretch + end type lss + + + !> Declare lss constructor + interface lss + procedure constructor + end interface lss + +contains + + + ! Quasi-Gaussian weighting function - h is the cut-off + real(WP) function wgauss(d,h) + implicit none + real(WP), intent(in) :: d,h + real(WP), parameter :: coeff=2.6_WP + real(WP) :: hh + hh=coeff*h + if (d.ge.hh) then + wgauss=0.0_WP + else + wgauss=(1.0_WP+4.0_WP*d/hh)*(1.0_WP-d/hh)**4 + end if + end function wgauss + + + !> Default constructor for Lagrangian solid solver + function constructor(cfg,name) result(self) + implicit none + type(lss) :: self + class(config), target, intent(in) :: cfg + character(len=*), optional :: name + integer :: i,j,k + + ! Set the name for the solver + if (present(name)) self%name=trim(adjustl(name)) + + ! Point to pgrid object + self%cfg=>cfg + + ! Set default bonding horizon based on underlying mesh + self%delta=self%cfg%min_meshsize + self%nb=1 + self%min_dist=huge(1.0_WP) + + ! Allocate variables + allocate(self%np_proc(1:self%cfg%nproc)); self%np_proc=0 + self%np_=0; self%np=0 + call self%resize(0) + + ! Initialize MPI derived datatype for a particle + call prepare_mpi_part() + + ! Allocate VF array on cfg mesh + allocate(self%VF(self%cfg%imino_:self%cfg%imaxo_,self%cfg%jmino_:self%cfg%jmaxo_,self%cfg%kmino_:self%cfg%kmaxo_)); self%VF=0.0_WP + allocate(self%VFU(self%cfg%imino_:self%cfg%imaxo_,self%cfg%jmino_:self%cfg%jmaxo_,self%cfg%kmino_:self%cfg%kmaxo_)); self%VFU=0.0_WP + allocate(self%VFV(self%cfg%imino_:self%cfg%imaxo_,self%cfg%jmino_:self%cfg%jmaxo_,self%cfg%kmino_:self%cfg%kmaxo_)); self%VFV=0.0_WP + allocate(self%VFW(self%cfg%imino_:self%cfg%imaxo_,self%cfg%jmino_:self%cfg%jmaxo_,self%cfg%kmino_:self%cfg%kmaxo_)); self%VFW=0.0_WP + + ! Log/screen output + logging: block + use, intrinsic :: iso_fortran_env, only: output_unit + use param, only: verbose + use messager, only: log + use string, only: str_long + character(len=str_long) :: message + if (self%cfg%amRoot) then + write(message,'("LSS object [",a,"] on partitioned grid [",a,"]")') trim(self%name),trim(self%cfg%name) + if (verbose.gt.1) write(output_unit,'(a)') trim(message) + if (verbose.gt.0) call log(message) + end if + end block logging + + end function constructor + + + !> Initialize bond force between particles + subroutine bond_init(this) + use messager, only: die + implicit none + class(lss), intent(inout) :: this + integer, dimension(:,:,:), allocatable :: npic !< Number of particle in cell + integer, dimension(:,:,:,:), allocatable :: ipic !< Index of particle in cell + + ! Communicate particles in ghost cells + call this%share() + + ! We can now assemble particle-in-cell information + pic_prep: block + use mpi_f08 + integer :: i,ip,jp,kp,ierr + integer :: mymax_npic,max_npic + + ! Allocate number of particle in cell + allocate(npic(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)); npic=0 + + ! Count particles and ghosts per cell + do i=1,this%np_ + ip=this%p(i)%ind(1); jp=this%p(i)%ind(2); kp=this%p(i)%ind(3) + npic(ip,jp,kp)=npic(ip,jp,kp)+1 + end do + do i=1,this%ng_ + ip=this%g(i)%ind(1); jp=this%g(i)%ind(2); kp=this%g(i)%ind(3) + npic(ip,jp,kp)=npic(ip,jp,kp)+1 + end do + + ! Get maximum number of particle in cell + mymax_npic=maxval(npic); call MPI_ALLREDUCE(mymax_npic,max_npic,1,MPI_INTEGER,MPI_MAX,this%cfg%comm,ierr) + + ! Allocate pic map + allocate(ipic(1:max_npic,this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)); ipic=0 + + ! Assemble pic map + npic=0 + do i=1,this%np_ + ip=this%p(i)%ind(1); jp=this%p(i)%ind(2); kp=this%p(i)%ind(3) + npic(ip,jp,kp)=npic(ip,jp,kp)+1 + ipic(npic(ip,jp,kp),ip,jp,kp)=+i + end do + do i=1,this%ng_ + ip=this%g(i)%ind(1); jp=this%g(i)%ind(2); kp=this%g(i)%ind(3) + npic(ip,jp,kp)=npic(ip,jp,kp)+1 + ipic(npic(ip,jp,kp),ip,jp,kp)=-i + end do + + end block pic_prep + + ! Establish initial bonds + create_bonds: block + use mpi_f08, only: MPI_ALLREDUCE,MPI_MIN,MPI_IN_PLACE + use parallel, only: MPI_REAL_WP + use mathtools, only: Pi + integer :: i,j,k,n1,nn,n2,ierr + type(part) :: p1,p2 + real(WP), dimension(3) :: rpos + real(WP) :: dist + ! Reset minimum bond distance + this%min_dist=huge(1.0_WP) + ! Loop over particles + do n1=1,this%np_ + ! Create copy of our particle + p1=this%p(n1) + ! Zero out weighted volume + p1%mw=0.0_WP + ! Zero out bonds + p1%ibond=0 + p1%nbond=0 + ! Loop over neighbor cells + do k=p1%ind(3)-this%nb,p1%ind(3)+this%nb + do j=p1%ind(2)-this%nb,p1%ind(2)+this%nb + do i=p1%ind(1)-this%nb,p1%ind(1)+this%nb + ! Loop over particles in that cell + do nn=1,npic(i,j,k) + ! Create copy of our neighbor + n2=ipic(nn,i,j,k) + if (n2.gt.0) then + p2=this%p(+n2) + else if (n2.lt.0) then + p2=this%g(-n2) + end if + ! Cannot self-bond + if (p1%i.eq.p2%i) cycle + ! Cannot bond with different id except <=0 (<=0 bonds with everyone) + if (p1%id.ne.p2%id.and.p1%id.ge.0.and.p2%id.ge.0) cycle + ! Check interparticle distance + rpos=p2%pos-p1%pos + dist=sqrt(dot_product(rpos,rpos)) + if (dist.lt.this%delta) then + ! This particle is in horizon, create a bond + p1%nbond=p1%nbond+1 + if (p1%nbond.gt.max_bond) call die('[lss_class bond_init] Number of detected bonds is larger than max allowed') + p1%ibond(p1%nbond)=p2%i + p1%dbond(p1%nbond)=dist + ! Increment weighted volume + p1%mw=p1%mw+wgauss(dist,this%delta)*dist**2*p1%vol + ! Determine minimum bond distance + this%min_dist=min(this%min_dist,dist) + end if + end do + end do + end do + end do + ! Zero out initial dilatation + p1%dil=0.0_WP + ! Copy back the particle + this%p(n1)=p1 + end do + ! Get global minimum + call MPI_ALLREDUCE(MPI_IN_PLACE,this%min_dist,1,MPI_REAL_WP,MPI_MIN,this%cfg%comm,ierr) + end block create_bonds + + ! Clean up + if (allocated(npic)) deallocate(npic) + if (allocated(ipic)) deallocate(ipic) + + end subroutine bond_init + + + !> Calculate bond force between particles + subroutine get_bond_force(this) + implicit none + class(lss), intent(inout) :: this + integer, dimension(:,:,:), allocatable :: npic !< Number of particle in cell + integer, dimension(:,:,:,:), allocatable :: ipic !< Index of particle in cell + logical :: is2D + + ! Need to modify parameters in 2D + is2D=this%cfg%nx.eq.1.or.this%cfg%ny.eq.1.or.this%cfg%nz.eq.1 + + ! Communicate particles in ghost cells + call this%share() + + ! We can now assemble particle-in-cell information + pic_prep: block + use mpi_f08 + integer :: i,ip,jp,kp,ierr + integer :: mymax_npic,max_npic + + ! Allocate number of particle in cell + allocate(npic(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)); npic=0 + + ! Count particles and ghosts per cell + do i=1,this%np_ + ip=this%p(i)%ind(1); jp=this%p(i)%ind(2); kp=this%p(i)%ind(3) + npic(ip,jp,kp)=npic(ip,jp,kp)+1 + end do + do i=1,this%ng_ + ip=this%g(i)%ind(1); jp=this%g(i)%ind(2); kp=this%g(i)%ind(3) + npic(ip,jp,kp)=npic(ip,jp,kp)+1 + end do + + ! Get maximum number of particle in cell + mymax_npic=maxval(npic); call MPI_ALLREDUCE(mymax_npic,max_npic,1,MPI_INTEGER,MPI_MAX,this%cfg%comm,ierr) + + ! Allocate pic map + allocate(ipic(1:max_npic,this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)); ipic=0 + + ! Assemble pic map + npic=0 + do i=1,this%np_ + ip=this%p(i)%ind(1); jp=this%p(i)%ind(2); kp=this%p(i)%ind(3) + npic(ip,jp,kp)=npic(ip,jp,kp)+1 + ipic(npic(ip,jp,kp),ip,jp,kp)=+i + end do + do i=1,this%ng_ + ip=this%g(i)%ind(1); jp=this%g(i)%ind(2); kp=this%g(i)%ind(3) + npic(ip,jp,kp)=npic(ip,jp,kp)+1 + ipic(npic(ip,jp,kp),ip,jp,kp)=-i + end do + + end block pic_prep + + ! Update weighted volume and dilatation + update_weighted_vol_and_dilatation: block + integer :: i,j,k,n1,nn,n2 + type(part) :: p1,p2 + integer :: nb,nbond + real(WP), dimension(3) :: rpos, Gd_vec + real(WP) :: dist, Gd_mag + ! Loop over particles + do n1=1,this%np_ + ! Create copy of our particle + p1=this%p(n1) + ! Zero out weighted volume and dilatation + p1%mw=0.0_WP + p1%dil=0.0_WP + ! Loop over neighbor cells + do k=p1%ind(3)-this%nb,p1%ind(3)+this%nb + do j=p1%ind(2)-this%nb,p1%ind(2)+this%nb + do i=p1%ind(1)-this%nb,p1%ind(1)+this%nb + ! Loop over particles in that cell + do nn=1,npic(i,j,k) + ! Create copy of our neighbor + n2=ipic(nn,i,j,k) + if (n2.gt.0) then + p2=this%p(+n2) + else if (n2.lt.0) then + p2=this%g(-n2) + end if + ! Check if a bond exists + do nb=1,max_bond + if (p1%ibond(nb).eq.p2%i) then + ! Increment weighted volume + p1%mw=p1%mw+wgauss(p1%dbond(nb),this%delta)*p1%dbond(nb)**2*p2%vol + ! Get current distance + rpos=p2%pos-p1%pos + dist=sqrt(dot_product(rpos,rpos)) + ! compute average G correction for dilitation + Gd_vec = (p2%gd + p1%gd)/2.0_WP + + Gd_mag = sqrt(1.0_WP/(((rpos(1)/dist)/Gd_vec(1))**2 + ((rpos(2)/dist)/Gd_vec(2))**2 + ((rpos(3)/dist)/Gd_vec(3))**2 )) + ! Increment dilatation + p1%dil=p1%dil+wgauss(p1%dbond(nb),this%delta)*p1%dbond(nb)*(dist-p1%dbond(nb))*p2%vol*Gd_mag + end if + end do + end do + end do + end do + end do + ! Rescale dilatation + if (p1%mw.gt.epsilon(1.0_WP)) then + if (is2D) then + ! 2D plane strain + p1%dil=p1%dil*2.0_WP/p1%mw + else + ! 3D + p1%dil=p1%dil*3.0_WP/p1%mw + end if + else + p1%dil=0.0_WP + end if + ! Copy back the particle + this%p(n1)=p1 + end do + end block update_weighted_vol_and_dilatation + + ! Re-communicate particles in ghost cells to update dil and mw + call this%share() + + ! Update bond force, including collision force, and SED + update_bond_force: block + use mpi_f08, only: MPI_ALLREDUCE,MPI_MIN,MPI_IN_PLACE + use parallel, only: MPI_REAL_WP + use mathtools, only: Pi + integer :: i,j,k,n1,nn,n2,ierr + type(part) :: p1,p2 + real(WP), dimension(3) :: rpos,t12,t21,Gd_vec + real(WP) :: dist,beta,alpha,ed,t,Gd_mag + real(WP) :: stretch,max_stretch,mu,kk + real(WP) :: nc,rc,kc + integer :: nb,nbond + logical :: found_bond + ! Recompute a few physical parameters + mu=this%elastic_modulus/(2.0_WP+2.0_WP*this%poisson_ratio) + kk=this%elastic_modulus/(3.0_WP-6.0_WP*this%poisson_ratio) + if (is2D) then + if (this%cfg%nx.eq.1) t=this%cfg%xL + if (this%cfg%ny.eq.1) t=this%cfg%yL + if (this%cfg%nz.eq.1) t=this%cfg%zL + max_stretch=sqrt(this%crit_energy/((6.0_WP*mu/Pi+16.0_WP/(9.0_WP*Pi**2)*(kk-2.0_WP*mu))*this%delta)) + kc=15.0_WP*48.0_WP*this%elastic_modulus/(Pi*5.0_WP*t*this%delta**3) + else + max_stretch=sqrt(this%crit_energy/((3.0_WP*mu+(kk-5.0_WP*mu/3.0_WP)*0.75_WP**4)*this%delta)) + kc=15.0_WP*12.0_WP*this%elastic_modulus/(Pi*this%delta**4) + end if + nc=1.0_WP + this%min_dist=huge(1.0_WP) + ! Loop over particles + do n1=1,this%np_ + ! Particles marked 0 do not update their forces + if (this%p(n1)%id.eq.0) cycle + ! Create copy of our particle + p1=this%p(n1) + ! Zero out bond force + p1%Abond=0.0_WP + ! Loop over neighbor cells + do k=p1%ind(3)-this%nb,p1%ind(3)+this%nb + do j=p1%ind(2)-this%nb,p1%ind(2)+this%nb + do i=p1%ind(1)-this%nb,p1%ind(1)+this%nb + ! Loop over particles in that cell + do nn=1,npic(i,j,k) + ! Create copy of our neighbor + n2=ipic(nn,i,j,k) + if (n2.gt.0) then + p2=this%p(+n2) + else if (n2.lt.0) then + p2=this%g(-n2) + end if + ! Current distance + rpos=p2%pos-p1%pos + dist=sqrt(dot_product(rpos,rpos)) + ! Check if a bond exists + found_bond=.false. + do nb=1,max_bond + if (p1%ibond(nb).eq.p2%i) then + ! Check for breakage first + stretch=(dist-p1%dbond(nb))/p1%dbond(nb) + if (stretch.gt.max_stretch) then + ! Remove the bond and flag as surface particle + p1%ibond(nb)=0 + p1%dbond(nb)=0.0_WP + cycle + end if + ! Particle 1 + if (is2D) then + ! 2D plane strain + beta = 2.0_WP * kk * p1%dil + alpha = 8.0_WP * mu / p1%mw + ed = dist - p1%dbond(nb) * (1.0_WP + p1%dil / 2.0_WP) + else + ! 3D + beta = 3.0_WP * kk * p1%dil + alpha = 15.0_WP * mu / p1%mw + ed = dist - p1%dbond(nb) * (1.0_WP + p1%dil / 3.0_WP) + end if + ! Force density 1->2 + ! t12=+wgauss(p1%dbond(nb),this%delta)*(beta/p1%mw*p1%dbond(nb)+alpha*ed)*rpos/dist + ! t12=+wgauss(p1%dbond(nb),this%delta)*((3.0_WP*kk - 15.0_WP*mu/3.0_WP)*(p1%dil*p1%dbond(nb)/p1%mw) + 15*mu*dist/p1%mw)*rpos/dist + Gd_vec = (p2%gd + p1%gd)/2.0_WP + + Gd_mag = sqrt(1.0_WP/(((rpos(1)/dist)/Gd_vec(1))**2 + ((rpos(2)/dist)/Gd_vec(2))**2 + ((rpos(3)/dist)/Gd_vec(3))**2 )) + t12=+wgauss(p1%dbond(nb),this%delta)*((3.0_WP*kk - 15.0_WP*mu/3.0_WP)*(Gd_mag*p1%dil*p1%dbond(nb)/p1%mw) + (15.0_WP*mu/p1%mw)*(dist - p1%dbond(nb)) )*rpos/dist + ! Particle 2 + if (is2D) then + ! 2D plane strain + beta = 2.0_WP * kk * p2%dil + alpha = 8.0_WP * mu / p2%mw + ed = dist - p1%dbond(nb) * (1.0_WP + p2%dil / 2.0_WP) + else + ! 3D + beta = 3.0_WP * kk * p2%dil + alpha = 15.0_WP * mu / p2%mw + ed = dist - p1%dbond(nb) * (1.0_WP + p2%dil / 3.0_WP) + end if + ! Force density 2->1 + ! t21=-wgauss(p1%dbond(nb),this%delta)*(beta/p2%mw*p1%dbond(nb)+alpha*ed)*rpos/dist + t21=-wgauss(p1%dbond(nb),this%delta)*((3.0_WP*kk - 15.0_WP*mu/3.0_WP)*(Gd_mag*p2%dil*p1%dbond(nb)/p2%mw)+ (15.0_WP*mu/p2%mw)*(dist - p1%dbond(nb)) )*rpos/dist ! Increment bond force + p1%Abond=p1%Abond+(t12-t21)*p2%vol/this%rho + ! Incremend SED + p1%ste=p1%ste+alpha/2.0_WP*(wgauss(p1%dbond(nb),this%delta)*((dist-p1%dbond(nb)))*p2%vol) + ! If still here, we have an active bond + found_bond=.true. + ! Determine minimum bond distance + this%min_dist=min(this%min_dist,dist) + cycle + end if + end do + ! Add collision force now + ! if (is2D) then + ! rc=p1%vol**(1.0_WP/2.0_WP) + ! else + ! rc=p1%vol**(1.0_WP/3.0_WP) + ! end if + ! if (.not.found_bond.and.p1%i.ne.p2%i.and.dist.lt.rc) then + ! p1%Abond=p1%Abond-max(kc*((rc/dist)**nc-1.0_WP),0.0_WP)*(rpos/dist)*p1%vol/this%rho + ! p1%flag = -2 + ! end if + end do + end do + end do + end do + ! Deal with dimensionality + if (this%cfg%nx.eq.1) p1%Abond(1)=0.0_WP + if (this%cfg%ny.eq.1) p1%Abond(2)=0.0_WP + if (this%cfg%nz.eq.1) p1%Abond(3)=0.0_WP + ! Copy back the particle + this%p(n1)=p1 + end do + ! Get global minimum + call MPI_ALLREDUCE(MPI_IN_PLACE,this%min_dist,1,MPI_REAL_WP,MPI_MIN,this%cfg%comm,ierr) + end block update_bond_force + + ! Clean up + if (allocated(npic)) deallocate(npic) + if (allocated(ipic)) deallocate(ipic) + + end subroutine get_bond_force + + + !> Advance the particle equations by a specified time step dt + !> p%id=-2 => do not solve for position nor velocity + !> p%id=-1 => do not solve for velocity + !> p%id= 0 => do not update force + + subroutine advance(this,dt)!,stress_x,stress_y,stress_z) + use mpi_f08, only : MPI_SUM,MPI_INTEGER,MPI_IN_PLACE + use mathtools, only: Pi + implicit none + class(lss), intent(inout) :: this + real(WP), intent(inout) :: dt !< Timestep size over which to advance + ! real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(inout) :: stress_x !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + ! real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(inout) :: stress_y !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + ! real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(inout) :: stress_z !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + integer :: n,ierr + ! real(WP), dimension(3) :: stress + + ! Zero out number of particles removed + this%np_out=0 + + ! Advance velocity based on old force and position based on mid-velocity + do n=1,this%np_ + ! Advance with Verlet scheme + if (this%p(n)%id.gt.-1) this%p(n)%vel=this%p(n)%vel+0.5_WP*dt*(this%gravity+this%p(n)%Abond+this%p(n)%Afluid) + if (this%p(n)%id.gt.-2) this%p(n)%pos=this%p(n)%pos+dt*this%p(n)%vel + ! Relocalize + this%p(n)%ind=this%cfg%get_ijk_global(this%p(n)%pos,this%p(n)%ind) + ! Correct the position to take into account periodicity + if (this%cfg%xper) this%p(n)%pos(1)=this%cfg%x(this%cfg%imin)+modulo(this%p(n)%pos(1)-this%cfg%x(this%cfg%imin),this%cfg%xL) + if (this%cfg%yper) this%p(n)%pos(2)=this%cfg%y(this%cfg%jmin)+modulo(this%p(n)%pos(2)-this%cfg%y(this%cfg%jmin),this%cfg%yL) + if (this%cfg%zper) this%p(n)%pos(3)=this%cfg%z(this%cfg%kmin)+modulo(this%p(n)%pos(3)-this%cfg%z(this%cfg%kmin),this%cfg%zL) + ! Handle particles that have left the domain + if (this%p(n)%pos(1).lt.this%cfg%x(this%cfg%imin).or.this%p(n)%pos(1).gt.this%cfg%x(this%cfg%imax+1)) this%p(n)%flag=1 + if (this%p(n)%pos(2).lt.this%cfg%y(this%cfg%jmin).or.this%p(n)%pos(2).gt.this%cfg%y(this%cfg%jmax+1)) this%p(n)%flag=1 + if (this%p(n)%pos(3).lt.this%cfg%z(this%cfg%kmin).or.this%p(n)%pos(3).gt.this%cfg%z(this%cfg%kmax+1)) this%p(n)%flag=1 + ! Relocalize the particle + this%p(n)%ind=this%cfg%get_ijk_global(this%p(n)%pos,this%p(n)%ind) + ! Count number of particles removed + if (this%p(n)%flag.eq.1) this%np_out=this%np_out+1 + end do + + ! Communicate particles + call this%sync() + + ! Sum up particles removed + call MPI_ALLREDUCE(this%np_out,n,1,MPI_INTEGER,MPI_SUM,this%cfg%comm,ierr); this%np_out=n + + ! Calculate bond force + call this%get_bond_force() + + ! Advance velocity only based on new force + do n=1,this%np_ + ! Advance with Verlet scheme + if (this%p(n)%id.le.-1) cycle + ! stress=this%cfg%get_velocity(pos=this%p(n)%pos,i0=this%p(n)%ind(1),j0=this%p(n)%ind(2),k0=this%p(n)%ind(3),U=stress_x,V=stress_y,W=stress_z) + ! this%p(n)%Afluid=stress/this%rho + this%p(n)%Afluid=0.0_WP + this%p(n)%vel=this%p(n)%vel+0.5_WP*dt*(this%gravity+this%p(n)%Abond+this%p(n)%Afluid) + end do + + ! Recompute volume fraction + ! call this%update_VF() + + ! Log/screen output + logging: block + use, intrinsic :: iso_fortran_env, only: output_unit + use param, only: verbose + use messager, only: log + use string, only: str_long + character(len=str_long) :: message + if (this%cfg%amRoot) then + write(message,'("Particle solver [",a,"] on partitioned grid [",a,"]: ",i0," particles were advanced")') trim(this%name),trim(this%cfg%name),this%np + if (verbose.gt.1) write(output_unit,'(a)') trim(message) + if (verbose.gt.0) call log(message) + end if + end block logging + + end subroutine advance + + subroutine stretch(this,dt)!,stress_x,stress_y,stress_z) + use mpi_f08, only : MPI_SUM,MPI_INTEGER,MPI_IN_PLACE + use mathtools, only: Pi + implicit none + class(lss), intent(inout) :: this + real(WP), intent(inout) :: dt !< Timestep size over which to advance + real(WP) :: mu + integer :: n,ierr + !======================================================================================== + ! X-Axis Stretch: + ! Zero out number of particles removed + this%np_out=0 + do n=1,this%np_ + ! Stretch the beam along the x axis with a uniform strain-rate of 0.001 + if (this%p(n)%id.gt.-2) this%p(n)%pos(1)=this%p(n)%pos(1)*1.001_WP + end do + + ! Communicate particles + call this%sync() + + ! Calculate bond force + call this%get_bond_force() + + mu=this%elastic_modulus/(2.0_WP+2.0_WP*this%poisson_ratio) + + do n=1,this%np_ + if (this%p(n)%id.gt.-2) this%p(n)%gd(1)=0.001_WP/this%p(n)%dil + end do + + !======================================================================================== + ! Y-Axis Stretch: + ! Zero out number of particles removed + this%np_out=0 + do n=1,this%np_ + ! Stretch the beam along the x axis with a uniform strain-rate of 0.001 + if (this%p(n)%id.gt.-2) this%p(n)%pos(1)=this%p(n)%pos(1)/1.001_WP + if (this%p(n)%id.gt.-2) this%p(n)%pos(2)=this%p(n)%pos(2)*1.001_WP + end do + + ! Communicate particles + call this%sync() + + ! Calculate bond force + call this%get_bond_force() + + mu=this%elastic_modulus/(2.0_WP+2.0_WP*this%poisson_ratio) + + do n=1,this%np_ + if (this%p(n)%id.gt.-2) this%p(n)%gd(2)=0.001_WP/this%p(n)%dil + end do + + !======================================================================================== + ! Z-Axis Stretch: + ! Zero out number of particles removed + this%np_out=0 + do n=1,this%np_ + ! Stretch the beam along the x axis with a uniform strain-rate of 0.001 + if (this%p(n)%id.gt.-2) this%p(n)%pos(2)=this%p(n)%pos(2)/1.001_WP + if (this%p(n)%id.gt.-2) this%p(n)%pos(3)=this%p(n)%pos(3)*1.001_WP + end do + + ! Communicate particles + call this%sync() + + ! Calculate bond force + call this%get_bond_force() + + mu=this%elastic_modulus/(2.0_WP+2.0_WP*this%poisson_ratio) + + do n=1,this%np_ + this%p(n)%gd(3)=0.001_WP/this%p(n)%dil + end do + + ! Put the particle back where it was + do n=1,this%np_ + if (this%p(n)%id.gt.-2) this%p(n)%pos(3)=this%p(n)%pos(3)/1.001_WP + end do + + !====================================================================================== + + ! Now stretch particle for the first time step + + do n=1,this%np_ + ! Stretch the beam along the x axis with a uniform strain-rate of 0.001 + if (this%p(n)%id.gt.-2) this%p(n)%pos(1)=this%p(n)%pos(1)*1.001_WP + end do + + ! Communicate particles + call this%sync() + + ! Calculate bond force + call this%get_bond_force() + + + + + end subroutine stretch + + subroutine get_correction_coeffs(this,dt)!,stress_x,stress_y,stress_z) + use mpi_f08, only : MPI_SUM,MPI_INTEGER,MPI_IN_PLACE + use mathtools, only: Pi + implicit none + class(lss), intent(inout) :: this + real(WP), intent(inout) :: dt !< Timestep size over which to advance + real(WP) :: mu + integer :: n,ierr + ! Zero out number of particles removed + this%np_out=0 + do n=1,this%np_ + ! Stretch the beam along the x axis with a uniform strain-rate of 0.001 + if (this%p(n)%id.gt.-2) this%p(n)%pos(1)=this%p(n)%pos(1) + this%p(n)%pos(1)*0.001_WP + ! Relocalize + this%p(n)%ind=this%cfg%get_ijk_global(this%p(n)%pos,this%p(n)%ind) + ! Correct the position to take into account periodicity + if (this%cfg%xper) this%p(n)%pos(1)=this%cfg%x(this%cfg%imin)+modulo(this%p(n)%pos(1)-this%cfg%x(this%cfg%imin),this%cfg%xL) + if (this%cfg%yper) this%p(n)%pos(2)=this%cfg%y(this%cfg%jmin)+modulo(this%p(n)%pos(2)-this%cfg%y(this%cfg%jmin),this%cfg%yL) + if (this%cfg%zper) this%p(n)%pos(3)=this%cfg%z(this%cfg%kmin)+modulo(this%p(n)%pos(3)-this%cfg%z(this%cfg%kmin),this%cfg%zL) + ! Handle particles that have left the domain + if (this%p(n)%pos(1).lt.this%cfg%x(this%cfg%imin).or.this%p(n)%pos(1).gt.this%cfg%x(this%cfg%imax+1)) this%p(n)%flag=1 + if (this%p(n)%pos(2).lt.this%cfg%y(this%cfg%jmin).or.this%p(n)%pos(2).gt.this%cfg%y(this%cfg%jmax+1)) this%p(n)%flag=1 + if (this%p(n)%pos(3).lt.this%cfg%z(this%cfg%kmin).or.this%p(n)%pos(3).gt.this%cfg%z(this%cfg%kmax+1)) this%p(n)%flag=1 + ! Relocalize the particle + this%p(n)%ind=this%cfg%get_ijk_global(this%p(n)%pos,this%p(n)%ind) + ! Count number of particles removed + end do + + ! Communicate particles + call this%sync() + + ! Sum up particles removed + call MPI_ALLREDUCE(this%np_out,n,1,MPI_INTEGER,MPI_SUM,this%cfg%comm,ierr); this%np_out=n + + ! Calculate bond force + call this%get_bond_force() + + mu=this%elastic_modulus/(2.0_WP+2.0_WP*this%poisson_ratio) + + do n=1,this%np_ + this%p(n)%gd=0.001_WP/this%p(n)%dil + this%p(n)%Gb=0.5_WP*mu*(0.001_WP*0.001_WP)/this%p(n)%ste + end do + + ! Log/screen output + logging: block + use, intrinsic :: iso_fortran_env, only: output_unit + use param, only: verbose + use messager, only: log + use string, only: str_long + character(len=str_long) :: message + if (this%cfg%amRoot) then + write(message,'("Particle solver [",a,"] on partitioned grid [",a,"]: ",i0," particles were advanced")') trim(this%name),trim(this%cfg%name),this%np + if (verbose.gt.1) write(output_unit,'(a)') trim(message) + if (verbose.gt.0) call log(message) + end if + end block logging + + end subroutine get_correction_coeffs + + + !> Update particle volume fraction using our current particles + subroutine update_VF(this) + implicit none + class(lss), intent(inout) :: this + integer :: i + ! Reset volume fraction and momentum + this%VF=0.0_WP; this%VFU=0.0_WP; this%VFV=0.0_WP; this%VFW=0.0_WP + ! Transfer particle volume + do i=1,this%np_ + ! Skip inactive particle + if (this%p(i)%flag.eq.1) cycle + ! Transfer volume to mesh + call this%extrapolate(Ap=this%p(i)%vol,xp=this%p(i)%pos(1),yp=this%p(i)%pos(2),zp=this%p(i)%pos(3),ip=this%p(i)%ind(1),jp=this%p(i)%ind(2),kp=this%p(i)%ind(3),A=this%VF,dir='SC') + call this%extrapolate(Ap=this%p(i)%vol*this%p(i)%vel(1),xp=this%p(i)%pos(1),yp=this%p(i)%pos(2),zp=this%p(i)%pos(3),ip=this%p(i)%ind(1),jp=this%p(i)%ind(2),kp=this%p(i)%ind(3),A=this%VFU,dir='U') + call this%extrapolate(Ap=this%p(i)%vol*this%p(i)%vel(2),xp=this%p(i)%pos(1),yp=this%p(i)%pos(2),zp=this%p(i)%pos(3),ip=this%p(i)%ind(1),jp=this%p(i)%ind(2),kp=this%p(i)%ind(3),A=this%VFV,dir='V') + call this%extrapolate(Ap=this%p(i)%vol*this%p(i)%vel(3),xp=this%p(i)%pos(1),yp=this%p(i)%pos(2),zp=this%p(i)%pos(3),ip=this%p(i)%ind(1),jp=this%p(i)%ind(2),kp=this%p(i)%ind(3),A=this%VFW,dir='W') + end do + ! Sum at boundaries + call this%cfg%syncsum(this%VF) + call this%cfg%syncsum(this%VFU) + call this%cfg%syncsum(this%VFV) + call this%cfg%syncsum(this%VFW) + ! Clip + where (this%VF.gt.1.0_WP) this%VF=1.0_WP + where (this%VF.lt.0.0_WP) this%VF=0.0_WP + end subroutine update_VF + + + !> Compute regularized delta function + subroutine get_delta(this,delta,ic,jc,kc,xp,yp,zp,dir) + implicit none + class(lss), intent(inout) :: this + real(WP), intent(out) :: delta !< Return delta function + integer, intent(in) :: ic,jc,kc !< Cell index + real(WP), intent(in) :: xp,yp,zp !< Position of marker + character(len=*) :: dir + real(WP) :: deltax,deltay,deltaz,r + + ! Compute in X + if (trim(adjustl(dir)).eq.'U') then + r=(xp-this%cfg%x(ic))*this%cfg%dxmi(ic) + deltax=roma_kernel(r)*this%cfg%dxmi(ic) + else + r=(xp-this%cfg%xm(ic))*this%cfg%dxi(ic) + deltax=roma_kernel(r)*this%cfg%dxi(ic) + end if + + ! Compute in Y + if (trim(adjustl(dir)).eq.'V') then + r=(yp-this%cfg%y(jc))*this%cfg%dymi(jc) + deltay=roma_kernel(r)*this%cfg%dymi(jc) + else + r=(yp-this%cfg%ym(jc))*this%cfg%dyi(jc) + deltay=roma_kernel(r)*this%cfg%dyi(jc) + end if + + ! Compute in Z + if (trim(adjustl(dir)).eq.'W') then + r=(zp-this%cfg%z(kc))*this%cfg%dzmi(kc) + deltaz=roma_kernel(r)*this%cfg%dzmi(kc) + else + r=(zp-this%cfg%zm(kc))*this%cfg%dzi(kc) + deltaz=roma_kernel(r)*this%cfg%dzi(kc) + end if + !else + + ! Put it all together + delta=deltax*deltay*deltaz + + contains + ! Mollification kernel + ! Roma A, Peskin C and Berger M 1999 J. Comput. Phys. 153 509–534 + function roma_kernel(r) result(phi) + implicit none + real(WP), intent(in) :: r + real(WP) :: phi + if (abs(r).le.0.5_WP) then + phi=1.0_WP/3.0_WP*(1.0_WP+sqrt(-3.0_WP*r**2+1.0_WP)) + else if (abs(r).gt.0.5_WP .and. abs(r).le.1.5_WP) then + phi=1.0_WP/6.0_WP*(5.0_WP-3.0_WP*abs(r)-sqrt(-3.0_WP*(1.0_WP-abs(r))**2+1.0_WP)) + else + phi=0.0_WP + end if + end function roma_kernel + + end subroutine get_delta + + + !> Interpolation routine + function interpolate(this,A,xp,yp,zp,ip,jp,kp,dir) result(Ap) + implicit none + class(lss), intent(inout) :: this + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(in) :: A !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + real(WP), intent(in) :: xp,yp,zp + integer, intent(in) :: ip,jp,kp + character(len=*) :: dir + real(WP) :: Ap + integer :: di,dj,dk + integer :: i1,i2,j1,j2,k1,k2 + real(WP), dimension(-2:+2,-2:+2,-2:+2) :: delta + ! Get the interpolation points + i1=ip-2; i2=ip+2 + j1=jp-2; j2=jp+2 + k1=kp-2; k2=kp+2 + ! Loop over neighboring cells and compute regularized delta function + do dk=-2,+2 + do dj=-2,+2 + do di=-2,+2 + call this%get_delta(delta=delta(di,dj,dk),ic=ip+di,jc=jp+dj,kc=kp+dk,xp=xp,yp=yp,zp=zp,dir=trim(dir)) + end do + end do + end do + ! Perform the actual interpolation on Ap + Ap = sum(delta*A(i1:i2,j1:j2,k1:k2))*this%cfg%vol(ip,jp,kp) + end function interpolate + + + !> Extrapolation routine + subroutine extrapolate(this,Ap,xp,yp,zp,ip,jp,kp,A,dir) + use messager, only: die + implicit none + class(lss), intent(inout) :: this + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:) :: A !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + real(WP), intent(in) :: xp,yp,zp + integer, intent(in) :: ip,jp,kp + real(WP), intent(in) :: Ap + character(len=*) :: dir + real(WP), dimension(-2:+2,-2:+2,-2:+2) :: delta + integer :: di,dj,dk + ! If particle has left processor domain or reached last ghost cell, kill job + if ( ip.lt.this%cfg%imin_-1.or.ip.gt.this%cfg%imax_+1.or.& + & jp.lt.this%cfg%jmin_-1.or.jp.gt.this%cfg%jmax_+1.or.& + & kp.lt.this%cfg%kmin_-1.or.kp.gt.this%cfg%kmax_+1) then + write(*,*) ip,jp,kp,xp,yp,zp + call die('[df extrapolate] Particle has left the domain') + end if + ! Loop over neighboring cells and compute regularized delta function + do dk=-2,+2 + do dj=-2,+2 + do di=-2,+2 + call this%get_delta(delta=delta(di,dj,dk),ic=ip+di,jc=jp+dj,kc=kp+dk,xp=xp,yp=yp,zp=zp,dir=trim(dir)) + end do + end do + end do + ! Perform the actual extrapolation on A + A(ip-2:ip+2,jp-2:jp+2,kp-2:kp+2)=A(ip-2:ip+2,jp-2:jp+2,kp-2:kp+2)+delta*Ap + end subroutine extrapolate + + + !> Calculate the CFL + subroutine get_cfl(this,dt,cfl) + use mpi_f08, only: MPI_ALLREDUCE,MPI_MAX + use parallel, only: MPI_REAL_WP + implicit none + class(lss), intent(inout) :: this + real(WP), intent(in) :: dt + real(WP), intent(out) :: cfl + integer :: i,ierr + real(WP) :: my_CFLp_x,my_CFLp_y,my_CFLp_z,kk,mu,a + + ! Set the CFLs to zero + my_CFLp_x=0.0_WP; my_CFLp_y=0.0_WP; my_CFLp_z=0.0_WP + do i=1,this%np_ + my_CFLp_x=max(my_CFLp_x,abs(this%p(i)%vel(1))*this%cfg%dxi(this%p(i)%ind(1))) + my_CFLp_y=max(my_CFLp_y,abs(this%p(i)%vel(2))*this%cfg%dyi(this%p(i)%ind(2))) + my_CFLp_z=max(my_CFLp_z,abs(this%p(i)%vel(3))*this%cfg%dzi(this%p(i)%ind(3))) + end do + my_CFLp_x=my_CFLp_x*dt; my_CFLp_y=my_CFLp_y*dt; my_CFLp_z=my_CFLp_z*dt + + ! Get the parallel max + call MPI_ALLREDUCE(my_CFLp_x,this%CFLp_x,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + call MPI_ALLREDUCE(my_CFLp_y,this%CFLp_y,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + call MPI_ALLREDUCE(my_CFLp_z,this%CFLp_z,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + + ! CFL based on elastic wave speed in material + kk=this%elastic_modulus/(3.0_WP-6.0_WP*this%poisson_ratio) + mu=this%elastic_modulus/(2.0_WP+2.0_WP*this%poisson_ratio) + a=sqrt((kk+4.0_WP*mu/3.0_WP)/this%rho) + this%CFLp_a=dt*a*3/this%delta + + ! Return the maximum CFL + cfl=max(this%CFLp_x,this%CFLp_y,this%CFLp_z,this%CFLp_a) + + end subroutine get_cfl + + + !> Extract various monitoring data from particle field + subroutine get_max(this) + use mpi_f08, only: MPI_ALLREDUCE,MPI_MAX,MPI_MIN,MPI_SUM + use parallel, only: MPI_REAL_WP + implicit none + class(lss), intent(inout) :: this + real(WP) :: buf,safe_np + real(WP), dimension(3) :: buf3D + integer :: i,j,k,ierr + + ! Create safe np + safe_np=real(max(this%np,1),WP) + + ! Velocity min/max/mean + this%Umin=huge(1.0_WP); this%Umax=-huge(1.0_WP); this%Umean=0.0_WP + this%Vmin=huge(1.0_WP); this%Vmax=-huge(1.0_WP); this%Vmean=0.0_WP + this%Wmin=huge(1.0_WP); this%Wmax=-huge(1.0_WP); this%Wmean=0.0_WP + this%ibmForce=0.0_WP + do i=1,this%np_ + this%Umin=min(this%Umin,this%p(i)%vel(1)); this%Umax=max(this%Umax,this%p(i)%vel(1)); this%Umean=this%Umean+this%p(i)%vel(1) + this%Vmin=min(this%Vmin,this%p(i)%vel(2)); this%Vmax=max(this%Vmax,this%p(i)%vel(2)); this%Vmean=this%Vmean+this%p(i)%vel(2) + this%Wmin=min(this%Wmin,this%p(i)%vel(3)); this%Wmax=max(this%Wmax,this%p(i)%vel(3)); this%Wmean=this%Wmean+this%p(i)%vel(3) + this%ibmForce=this%ibmForce+this%p(i)%Afluid*this%p(i)%vol*this%rho + end do + call MPI_ALLREDUCE(this%Umin ,buf,1,MPI_REAL_WP,MPI_MIN,this%cfg%comm,ierr); this%Umin =buf + call MPI_ALLREDUCE(this%Umax ,buf,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr); this%Umax =buf + call MPI_ALLREDUCE(this%Umean,buf,1,MPI_REAL_WP,MPI_SUM,this%cfg%comm,ierr); this%Umean=buf/safe_np + call MPI_ALLREDUCE(this%Vmin ,buf,1,MPI_REAL_WP,MPI_MIN,this%cfg%comm,ierr); this%Vmin =buf + call MPI_ALLREDUCE(this%Vmax ,buf,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr); this%Vmax =buf + call MPI_ALLREDUCE(this%Vmean,buf,1,MPI_REAL_WP,MPI_SUM,this%cfg%comm,ierr); this%Vmean=buf/safe_np + call MPI_ALLREDUCE(this%Wmin ,buf,1,MPI_REAL_WP,MPI_MIN,this%cfg%comm,ierr); this%Wmin =buf + call MPI_ALLREDUCE(this%Wmax ,buf,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr); this%Wmax =buf + call MPI_ALLREDUCE(this%Wmean,buf,1,MPI_REAL_WP,MPI_SUM,this%cfg%comm,ierr); this%Wmean=buf/safe_np + call MPI_ALLREDUCE(this%ibmForce,buf3D,3,MPI_REAL_WP,MPI_SUM,this%cfg%comm,ierr); this%ibmForce=buf3D + + ! Get max volume fraction + this%VFmax =-huge(1.0_WP) + do k=this%cfg%kmin_,this%cfg%kmax_ + do j=this%cfg%jmin_,this%cfg%jmax_ + do i=this%cfg%imin_,this%cfg%imax_ + this%VFmax=max(this%VFmax,this%VF(i,j,k)) + end do + end do + end do + call MPI_ALLREDUCE(this%VFmax,buf,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr); this%VFmax=buf + + end subroutine get_max + + + !> Update particle mesh using our current particles + subroutine update_partmesh(this,pmesh) + use partmesh_class, only: partmesh + implicit none + class(lss), intent(inout) :: this + class(partmesh), intent(inout) :: pmesh + integer :: i + ! Reset particle mesh storage + call pmesh%reset() + ! Nothing else to do if no particle is present + if (this%np_.eq.0) return + ! Copy particle info + call pmesh%set_size(this%np_) + do i=1,this%np_ + pmesh%pos(:,i)=this%p(i)%pos + end do + end subroutine update_partmesh + + + !> Creation of the MPI datatype for particle + subroutine prepare_mpi_part() + use mpi_f08 + use messager, only: die + implicit none + integer(MPI_ADDRESS_KIND), dimension(part_nblock) :: disp + integer(MPI_ADDRESS_KIND) :: lb,extent + type(MPI_Datatype) :: MPI_PART_TMP + integer :: i,mysize,ierr + ! Prepare the displacement array + disp(1)=0 + do i=2,part_nblock + call MPI_Type_size(part_tblock(i-1),mysize,ierr) + disp(i)=disp(i-1)+int(mysize,MPI_ADDRESS_KIND)*int(part_lblock(i-1),MPI_ADDRESS_KIND) + end do + ! Create and commit the new type + call MPI_Type_create_struct(part_nblock,part_lblock,disp,part_tblock,MPI_PART_TMP,ierr) + call MPI_Type_get_extent(MPI_PART_TMP,lb,extent,ierr) + call MPI_Type_create_resized(MPI_PART_TMP,lb,extent,MPI_PART,ierr) + call MPI_Type_commit(MPI_PART,ierr) + ! If a problem was encountered, say it + if (ierr.ne.0) call die('[lss prepare_mpi_part] MPI Particle type creation failed') + ! Get the size of this type + call MPI_type_size(MPI_PART,MPI_PART_SIZE,ierr) + end subroutine prepare_mpi_part + + + !> Share particles across processor boundaries + subroutine share(this,nover) + use mpi_f08 + use messager, only: warn,die + implicit none + class(lss), intent(inout) :: this + integer, optional :: nover + type(part), dimension(:), allocatable :: tosend + type(part), dimension(:), allocatable :: torecv + integer :: no,nsend,nrecv + type(MPI_Status) :: status + integer :: icnt,isrc,idst,ierr + integer :: i,n + + ! Check overlap size + if (present(nover)) then + no=nover + if (no.gt.this%cfg%no) then + call warn('[lss share] Specified overlap is larger than that of cfg - reducing no') + no=this%cfg%no + else if (no.le.0) then + call die('[lss share] Specified overlap cannot be less or equal to zero') + end if + else + no=1 + end if + + ! Clean up ghost array + call this%resize_ghost(n=0); this%ng_=0 + + ! Share ghost particles in -x (no ghosts are sent here) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(1).lt.this%cfg%imin_+no) nsend=nsend+1 + end do + allocate(tosend(nsend)) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(1).lt.this%cfg%imin_+no) then + nsend=nsend+1 + tosend(nsend)=this%p(n) + if (this%cfg%xper.and.tosend(nsend)%ind(1).lt.this%cfg%imin+no) then + tosend(nsend)%pos(1)=tosend(nsend)%pos(1)+this%cfg%xL + tosend(nsend)%ind(1)=tosend(nsend)%ind(1)+this%cfg%nx + end if + end if + end do + nrecv=0 + call MPI_CART_SHIFT(this%cfg%comm,0,-1,isrc,idst,ierr) + call MPI_SENDRECV(nsend,1,MPI_INTEGER,idst,0,nrecv,1,MPI_INTEGER,isrc,0,this%cfg%comm,status,ierr) + allocate(torecv(nrecv)) + call MPI_SENDRECV(tosend,nsend,MPI_PART,idst,0,torecv,nrecv,MPI_PART,isrc,0,this%cfg%comm,status,ierr) + call this%resize_ghost(this%ng_+nrecv) + this%g(this%ng_+1:this%ng_+nrecv)=torecv + this%ng_=this%ng_+nrecv + if (allocated(tosend)) deallocate(tosend) + if (allocated(torecv)) deallocate(torecv) + + ! Share ghost particles in +x (no ghosts are sent here) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(1).gt.this%cfg%imax_-no) nsend=nsend+1 + end do + allocate(tosend(nsend)) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(1).gt.this%cfg%imax_-no) then + nsend=nsend+1 + tosend(nsend)=this%p(n) + if (this%cfg%xper.and.tosend(nsend)%ind(1).gt.this%cfg%imax-no) then + tosend(nsend)%pos(1)=tosend(nsend)%pos(1)-this%cfg%xL + tosend(nsend)%ind(1)=tosend(nsend)%ind(1)-this%cfg%nx + end if + end if + end do + nrecv=0 + call MPI_CART_SHIFT(this%cfg%comm,0,+1,isrc,idst,ierr) + call MPI_SENDRECV(nsend,1,MPI_INTEGER,idst,0,nrecv,1,MPI_INTEGER,isrc,0,this%cfg%comm,status,ierr) + allocate(torecv(nrecv)) + call MPI_SENDRECV(tosend,nsend,MPI_PART,idst,0,torecv,nrecv,MPI_PART,isrc,0,this%cfg%comm,status,ierr) + call this%resize_ghost(this%ng_+nrecv) + this%g(this%ng_+1:this%ng_+nrecv)=torecv + this%ng_=this%ng_+nrecv + if (allocated(tosend)) deallocate(tosend) + if (allocated(torecv)) deallocate(torecv) + + ! Share ghost particles in -y (ghosts need to be sent now) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(2).lt.this%cfg%jmin_+no) nsend=nsend+1 + end do + do n=1,this%ng_ + if (this%g(n)%ind(2).lt.this%cfg%jmin_+no) nsend=nsend+1 + end do + allocate(tosend(nsend)) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(2).lt.this%cfg%jmin_+no) then + nsend=nsend+1 + tosend(nsend)=this%p(n) + if (this%cfg%yper.and.tosend(nsend)%ind(2).lt.this%cfg%jmin+no) then + tosend(nsend)%pos(2)=tosend(nsend)%pos(2)+this%cfg%yL + tosend(nsend)%ind(2)=tosend(nsend)%ind(2)+this%cfg%ny + end if + end if + end do + do n=1,this%ng_ + if (this%g(n)%ind(2).lt.this%cfg%jmin_+no) then + nsend=nsend+1 + tosend(nsend)=this%g(n) + if (this%cfg%yper.and.tosend(nsend)%ind(2).lt.this%cfg%jmin+no) then + tosend(nsend)%pos(2)=tosend(nsend)%pos(2)+this%cfg%yL + tosend(nsend)%ind(2)=tosend(nsend)%ind(2)+this%cfg%ny + end if + end if + end do + nrecv=0 + call MPI_CART_SHIFT(this%cfg%comm,1,-1,isrc,idst,ierr) + call MPI_SENDRECV(nsend,1,MPI_INTEGER,idst,0,nrecv,1,MPI_INTEGER,isrc,0,this%cfg%comm,status,ierr) + allocate(torecv(nrecv)) + call MPI_SENDRECV(tosend,nsend,MPI_PART,idst,0,torecv,nrecv,MPI_PART,isrc,0,this%cfg%comm,status,ierr) + call this%resize_ghost(this%ng_+nrecv) + this%g(this%ng_+1:this%ng_+nrecv)=torecv + this%ng_=this%ng_+nrecv + if (allocated(tosend)) deallocate(tosend) + if (allocated(torecv)) deallocate(torecv) + + ! Share ghost particles in +y (ghosts need to be sent now - but not newly received ghosts!) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(2).gt.this%cfg%jmax_-no) nsend=nsend+1 + end do + do n=1,this%ng_-nrecv + if (this%g(n)%ind(2).gt.this%cfg%jmax_-no) nsend=nsend+1 + end do + allocate(tosend(nsend)) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(2).gt.this%cfg%jmax_-no) then + nsend=nsend+1 + tosend(nsend)=this%p(n) + if (this%cfg%yper.and.tosend(nsend)%ind(2).gt.this%cfg%jmax-no) then + tosend(nsend)%pos(2)=tosend(nsend)%pos(2)-this%cfg%yL + tosend(nsend)%ind(2)=tosend(nsend)%ind(2)-this%cfg%ny + end if + end if + end do + do n=1,this%ng_-nrecv + if (this%g(n)%ind(2).gt.this%cfg%jmax_-no) then + nsend=nsend+1 + tosend(nsend)=this%g(n) + if (this%cfg%yper.and.tosend(nsend)%ind(2).gt.this%cfg%jmax-no) then + tosend(nsend)%pos(2)=tosend(nsend)%pos(2)-this%cfg%yL + tosend(nsend)%ind(2)=tosend(nsend)%ind(2)-this%cfg%ny + end if + end if + end do + nrecv=0 + call MPI_CART_SHIFT(this%cfg%comm,1,+1,isrc,idst,ierr) + call MPI_SENDRECV(nsend,1,MPI_INTEGER,idst,0,nrecv,1,MPI_INTEGER,isrc,0,this%cfg%comm,status,ierr) + allocate(torecv(nrecv)) + call MPI_SENDRECV(tosend,nsend,MPI_PART,idst,0,torecv,nrecv,MPI_PART,isrc,0,this%cfg%comm,status,ierr) + call this%resize_ghost(this%ng_+nrecv) + this%g(this%ng_+1:this%ng_+nrecv)=torecv + this%ng_=this%ng_+nrecv + if (allocated(tosend)) deallocate(tosend) + if (allocated(torecv)) deallocate(torecv) + + ! Share ghost particles in -z (ghosts need to be sent now) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(3).lt.this%cfg%kmin_+no) nsend=nsend+1 + end do + do n=1,this%ng_ + if (this%g(n)%ind(3).lt.this%cfg%kmin_+no) nsend=nsend+1 + end do + allocate(tosend(nsend)) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(3).lt.this%cfg%kmin_+no) then + nsend=nsend+1 + tosend(nsend)=this%p(n) + if (this%cfg%zper.and.tosend(nsend)%ind(3).lt.this%cfg%kmin+no) then + tosend(nsend)%pos(3)=tosend(nsend)%pos(3)+this%cfg%zL + tosend(nsend)%ind(3)=tosend(nsend)%ind(3)+this%cfg%nz + end if + end if + end do + do n=1,this%ng_ + if (this%g(n)%ind(3).lt.this%cfg%kmin_+no) then + nsend=nsend+1 + tosend(nsend)=this%g(n) + if (this%cfg%zper.and.tosend(nsend)%ind(3).lt.this%cfg%kmin+no) then + tosend(nsend)%pos(3)=tosend(nsend)%pos(3)+this%cfg%zL + tosend(nsend)%ind(3)=tosend(nsend)%ind(3)+this%cfg%nz + end if + end if + end do + nrecv=0 + call MPI_CART_SHIFT(this%cfg%comm,2,-1,isrc,idst,ierr) + call MPI_SENDRECV(nsend,1,MPI_INTEGER,idst,0,nrecv,1,MPI_INTEGER,isrc,0,this%cfg%comm,status,ierr) + allocate(torecv(nrecv)) + call MPI_SENDRECV(tosend,nsend,MPI_PART,idst,0,torecv,nrecv,MPI_PART,isrc,0,this%cfg%comm,status,ierr) + call this%resize_ghost(this%ng_+nrecv) + this%g(this%ng_+1:this%ng_+nrecv)=torecv + this%ng_=this%ng_+nrecv + if (allocated(tosend)) deallocate(tosend) + if (allocated(torecv)) deallocate(torecv) + + ! Share ghost particles in +z (ghosts need to be sent now - but not newly received ghosts!) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(3).gt.this%cfg%kmax_-no) nsend=nsend+1 + end do + do n=1,this%ng_-nrecv + if (this%g(n)%ind(3).gt.this%cfg%kmax_-no) nsend=nsend+1 + end do + allocate(tosend(nsend)) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(3).gt.this%cfg%kmax_-no) then + nsend=nsend+1 + tosend(nsend)=this%p(n) + if (this%cfg%zper.and.tosend(nsend)%ind(3).gt.this%cfg%kmax-no) then + tosend(nsend)%pos(3)=tosend(nsend)%pos(3)-this%cfg%zL + tosend(nsend)%ind(3)=tosend(nsend)%ind(3)-this%cfg%nz + end if + end if + end do + do n=1,this%ng_-nrecv + if (this%g(n)%ind(3).gt.this%cfg%kmax_-no) then + nsend=nsend+1 + tosend(nsend)=this%g(n) + if (this%cfg%zper.and.tosend(nsend)%ind(3).gt.this%cfg%kmax-no) then + tosend(nsend)%pos(3)=tosend(nsend)%pos(3)-this%cfg%zL + tosend(nsend)%ind(3)=tosend(nsend)%ind(3)-this%cfg%nz + end if + end if + end do + nrecv=0 + call MPI_CART_SHIFT(this%cfg%comm,2,+1,isrc,idst,ierr) + call MPI_SENDRECV(nsend,1,MPI_INTEGER,idst,0,nrecv,1,MPI_INTEGER,isrc,0,this%cfg%comm,status,ierr) + allocate(torecv(nrecv)) + call MPI_SENDRECV(tosend,nsend,MPI_PART,idst,0,torecv,nrecv,MPI_PART,isrc,0,this%cfg%comm,status,ierr) + call this%resize_ghost(this%ng_+nrecv) + this%g(this%ng_+1:this%ng_+nrecv)=torecv + this%ng_=this%ng_+nrecv + if (allocated(tosend)) deallocate(tosend) + if (allocated(torecv)) deallocate(torecv) + + end subroutine share + + + !> Synchronize particle arrays across processors + subroutine sync(this) + use mpi_f08 + implicit none + class(lss), intent(inout) :: this + integer, dimension(0:this%cfg%nproc-1) :: nsend_proc,nrecv_proc + integer, dimension(0:this%cfg%nproc-1) :: nsend_disp,nrecv_disp + integer :: n,prank,ierr + type(part), dimension(:), allocatable :: buf_send + ! Recycle first to minimize communication load + call this%recycle() + ! Prepare information about what to send + nsend_proc=0 + do n=1,this%np_ + prank=this%cfg%get_rank(this%p(n)%ind) + nsend_proc(prank)=nsend_proc(prank)+1 + end do + nsend_proc(this%cfg%rank)=0 + ! Inform processors of what they will receive + call MPI_ALLtoALL(nsend_proc,1,MPI_INTEGER,nrecv_proc,1,MPI_INTEGER,this%cfg%comm,ierr) + ! Prepare displacements for all-to-all + nsend_disp(0)=0 + nrecv_disp(0)=this%np_ !< Directly add particles at the end of main array + do n=1,this%cfg%nproc-1 + nsend_disp(n)=nsend_disp(n-1)+nsend_proc(n-1) + nrecv_disp(n)=nrecv_disp(n-1)+nrecv_proc(n-1) + end do + ! Allocate buffer to send particles + allocate(buf_send(sum(nsend_proc))) + ! Pack the particles in the send buffer + nsend_proc=0 + do n=1,this%np_ + ! Get the rank + prank=this%cfg%get_rank(this%p(n)%ind) + ! Skip particles still inside + if (prank.eq.this%cfg%rank) cycle + ! Pack up for sending + nsend_proc(prank)=nsend_proc(prank)+1 + buf_send(nsend_disp(prank)+nsend_proc(prank))=this%p(n) + ! Flag particle for removal + this%p(n)%flag=1 + end do + ! Allocate buffer for receiving particles + call this%resize(this%np_+sum(nrecv_proc)) + ! Perform communication + call MPI_ALLtoALLv(buf_send,nsend_proc,nsend_disp,MPI_PART,this%p,nrecv_proc,nrecv_disp,MPI_PART,this%cfg%comm,ierr) + ! Deallocate buffer + deallocate(buf_send) + ! Recycle to remove duplicate particles + call this%recycle() + end subroutine sync + + + !> Adaptation of particle array size + subroutine resize(this,n) + implicit none + class(lss), intent(inout) :: this + integer, intent(in) :: n + type(part), dimension(:), allocatable :: tmp + integer :: size_now,size_new + ! Resize particle array to size n + if (.not.allocated(this%p)) then + ! Allocate directly to size n + allocate(this%p(n)) + this%p(1:n)%flag=1 + else + ! Update from a non-zero size to another non-zero size + size_now=size(this%p,dim=1) + if (n.gt.size_now) then + size_new=max(n,int(real(size_now,WP)*coeff_up)) + allocate(tmp(size_new)) + tmp(1:size_now)=this%p + tmp(size_now+1:)%flag=1 + call move_alloc(tmp,this%p) + else if (n.lt.int(real(size_now,WP)*coeff_dn)) then + allocate(tmp(n)) + tmp(1:n)=this%p(1:n) + call move_alloc(tmp,this%p) + end if + end if + end subroutine resize + + + !> Adaptation of ghost array size + subroutine resize_ghost(this,n) + implicit none + class(lss), intent(inout) :: this + integer, intent(in) :: n + type(part), dimension(:), allocatable :: tmp + integer :: size_now,size_new + ! Resize ghost array to size n + if (.not.allocated(this%g)) then + ! Allocate directly to size n + allocate(this%g(n)) + this%g(1:n)%flag=1 + else + ! Update from a non-zero size to another non-zero size + size_now=size(this%g,dim=1) + if (n.gt.size_now) then + size_new=max(n,int(real(size_now,WP)*coeff_up)) + allocate(tmp(size_new)) + tmp(1:size_now)=this%g + tmp(size_now+1:)%flag=1 + call move_alloc(tmp,this%g) + else if (n.lt.int(real(size_now,WP)*coeff_dn)) then + allocate(tmp(n)) + tmp(1:n)=this%g(1:n) + call move_alloc(tmp,this%g) + end if + end if + end subroutine resize_ghost + + + !> Clean-up of particle array by removing flag=1 particles + subroutine recycle(this) + implicit none + class(lss), intent(inout) :: this + integer :: new_size,i,ierr + ! Compact all active particles at the beginning of the array + new_size=0 + if (allocated(this%p)) then + do i=1,size(this%p,dim=1) + if (this%p(i)%flag.ne.1) then + new_size=new_size+1 + if (i.ne.new_size) then + this%p(new_size)=this%p(i) + this%p(i)%flag=1 + end if + end if + end do + end if + ! Resize to new size + call this%resize(new_size) + ! Update number of particles + this%np_=new_size + call MPI_ALLGATHER(this%np_,1,MPI_INTEGER,this%np_proc,1,MPI_INTEGER,this%cfg%comm,ierr) + this%np=sum(this%np_proc) + end subroutine recycle + + + !> Parallel write particles to file + subroutine write(this,filename) + use mpi_f08 + use messager, only: die + use parallel, only: info_mpiio + implicit none + class(lss), intent(inout) :: this + character(len=*), intent(in) :: filename + type(MPI_File) :: ifile + type(MPI_Status):: status + integer(kind=MPI_OFFSET_KIND) :: offset + integer :: i,ierr,iunit + + ! Root serial-writes the file header + if (this%cfg%amRoot) then + ! Open the file + open(newunit=iunit,file=trim(filename),form='unformatted',status='replace',access='stream',iostat=ierr) + if (ierr.ne.0) call die('[lss write] Problem encountered while serial-opening data file: '//trim(filename)) + ! Number of particles and particle object size + write(iunit) this%np,MPI_PART_SIZE + ! Done with the header + close(iunit) + end if + + ! The rest is done in parallel + call MPI_FILE_OPEN(this%cfg%comm,trim(filename),IOR(MPI_MODE_WRONLY,MPI_MODE_APPEND),info_mpiio,ifile,ierr) + if (ierr.ne.0) call die('[lss write] Problem encountered while parallel-opening data file: '//trim(filename)) + + ! Get current position + call MPI_FILE_GET_POSITION(ifile,offset,ierr) + + ! Compute the offset and write + do i=1,this%cfg%rank + offset=offset+int(this%np_proc(i),MPI_OFFSET_KIND)*int(MPI_PART_SIZE,MPI_OFFSET_KIND) + end do + if (this%np_.gt.0) call MPI_FILE_WRITE_AT(ifile,offset,this%p,this%np_,MPI_PART,status,ierr) + + ! Close the file + call MPI_FILE_CLOSE(ifile,ierr) + + ! Log/screen output + logging: block + use, intrinsic :: iso_fortran_env, only: output_unit + use param, only: verbose + use messager, only: log + use string, only: str_long + character(len=str_long) :: message + if (this%cfg%amRoot) then + write(message,'("[lss write] Wrote ",i0," particles to file [",a,"] on partitioned grid [",a,"]")') this%np,trim(filename),trim(this%cfg%name) + if (verbose.gt.2) write(output_unit,'(a)') trim(message) + if (verbose.gt.1) call log(message) + end if + end block logging + + end subroutine write + + + !> Parallel read particles to file + subroutine read(this,filename) + use mpi_f08 + use messager, only: die + use parallel, only: info_mpiio + implicit none + class(lss), intent(inout) :: this + character(len=*), intent(in) :: filename + type(MPI_File) :: ifile + type(MPI_Status):: status + integer(kind=MPI_OFFSET_KIND) :: offset,header_offset + integer :: i,j,ierr,npadd,psize,nchunk,cnt + integer, dimension(:,:), allocatable :: ppp + + ! First open the file in parallel + call MPI_FILE_OPEN(this%cfg%comm,trim(filename),MPI_MODE_RDONLY,info_mpiio,ifile,ierr) + if (ierr.ne.0) call die('[lss read] Problem encountered while reading data file: '//trim(filename)) + + ! Read file header first + call MPI_FILE_READ_ALL(ifile,npadd,1,MPI_INTEGER,status,ierr) + call MPI_FILE_READ_ALL(ifile,psize,1,MPI_INTEGER,status,ierr) + + ! Remember current position + call MPI_FILE_GET_POSITION(ifile,header_offset,ierr) + + ! Check compatibility of particle type + if (psize.ne.MPI_PART_SIZE) call die('[lss read] Particle type unreadable') + + ! Naively share reading task among all processors + nchunk=int(npadd/(this%cfg%nproc*part_chunk_size))+1 + allocate(ppp(this%cfg%nproc,nchunk)) + ppp=int(npadd/(this%cfg%nproc*nchunk)) + cnt=0 + out:do j=1,nchunk + do i=1,this%cfg%nproc + cnt=cnt+1 + if (cnt.gt.mod(npadd,this%cfg%nproc*nchunk)) exit out + ppp(i,j)=ppp(i,j)+1 + end do + end do out + + ! Read by chunk + do j=1,nchunk + ! Find offset + offset=header_offset+int(MPI_PART_SIZE,MPI_OFFSET_KIND)*int(sum(ppp(1:this%cfg%rank,:))+sum(ppp(this%cfg%rank+1,1:j-1)),MPI_OFFSET_KIND) + ! Resize particle array + call this%resize(this%np_+ppp(this%cfg%rank+1,j)) + ! Read this file + call MPI_FILE_READ_AT(ifile,offset,this%p(this%np_+1:this%np_+ppp(this%cfg%rank+1,j)),ppp(this%cfg%rank+1,j),MPI_PART,status,ierr) + ! Most general case: relocate every droplet + do i=this%np_+1,this%np_+ppp(this%cfg%rank+1,j) + this%p(i)%ind=this%cfg%get_ijk_global(this%p(i)%pos,this%p(i)%ind) + end do + ! Exchange all that + call this%sync() + end do + + ! Close the file + call MPI_FILE_CLOSE(ifile,ierr) + + ! Log/screen output + logging: block + use, intrinsic :: iso_fortran_env, only: output_unit + use param, only: verbose + use messager, only: log + use string, only: str_long + character(len=str_long) :: message + if (this%cfg%amRoot) then + write(message,'("[lss read] Read ",i0," particles from file [",a,"] on partitioned grid [",a,"]")') npadd,trim(filename),trim(this%cfg%name) + if (verbose.gt.2) write(output_unit,'(a)') trim(message) + if (verbose.gt.1) call log(message) + end if + end block logging + + end subroutine read + + +end module lss_class diff --git a/examples/plate_with_hole/src/lss_class_stl.f90 b/examples/plate_with_hole/src/lss_class_stl.f90 new file mode 100644 index 000000000..584855c36 --- /dev/null +++ b/examples/plate_with_hole/src/lss_class_stl.f90 @@ -0,0 +1,1636 @@ +!> Lagrangian solid solver object +!> Implements peridynamics equations +module lss_class + use precision, only: WP + use string, only: str_medium + use config_class, only: config + use mpi_f08, only: MPI_Datatype,MPI_INTEGER8,MPI_INTEGER,MPI_DOUBLE_PRECISION + implicit none + private + + + ! Expose type/constructor/methods + public :: lss + + + !> Memory adaptation parameter + real(WP), parameter :: coeff_up=1.3_WP !< Particle array size increase factor + real(WP), parameter :: coeff_dn=0.7_WP !< Particle array size decrease factor + + + !> I/O chunk size to read at a time + integer, parameter :: part_chunk_size=1000 !< Read 1000 particles at a time before redistributing + + + !> Maximum number of bonds per particle + integer, parameter, public :: max_bond=400 !< Assumes something like a 7x7x7 stencil in 3D + + + !> Bonded solid particle definition + type :: part + !> MPI_DOUBLE_PRECISION data + real(WP) :: mw !< Weighted volume + real(WP) :: dil !< Element dilatation + real(WP) :: ste !< Element dilatation + real(WP) :: vol !< Particle volume + real(WP), dimension(max_bond) :: dbond !< Length of initial bonds + real(WP), dimension(3) :: pos !< Particle center coordinates + real(WP), dimension(3) :: vel !< Velocity of particle + real(WP), dimension(3) :: Abond !< Bond acceleration for particle + real(WP), dimension(3) :: Afluid !< Fluid acceleration for particle + real(WP), dimension(3) :: gd !< Dilitation corrections + real(WP), dimension(3) :: gb !< Shear corrections + !> MPI_INTEGER data + integer :: id !< ID the object is associated with + integer :: i !< Unique index of particle (assumed >0) + integer :: nbond !< Number of initial bonds + integer, dimension(max_bond) :: ibond !< Indices of initially bonded particles (0 values ignored) + integer , dimension(3) :: ind !< Index of cell containing particle center + integer :: flag !< Control parameter (0=normal, 1=done->will be removed) + end type part + !> Number of blocks, block length, and block types in a particle + integer, parameter :: part_nblock=2 + integer , dimension(part_nblock) :: part_lblock=[22+max_bond,7+max_bond] + type(MPI_Datatype), dimension(part_nblock) :: part_tblock=[MPI_DOUBLE_PRECISION,MPI_INTEGER] + !> MPI_PART derived datatype and size + type(MPI_Datatype) :: MPI_PART + integer :: MPI_PART_SIZE + + + !> Lagrangian solid solver object definition + type :: lss + + ! This config is used for parallelization and for calculating bond/collision forces + class(config), pointer :: cfg + + ! This is the name of the solver + character(len=str_medium) :: name='UNNAMED_LSS' + + ! Solid material properties + real(WP) :: elastic_modulus !< Elastic modulus of the material + real(WP) :: poisson_ratio !< Poisson's ratio of the material + real(WP) :: rho !< Density of the material + real(WP) :: crit_energy !< Critical energy release + + ! Bonding parameters + real(WP) :: delta !< Bonding horizon (distance) + real(WP) :: min_dist !< Minimum bonding distance + integer :: nb !< Cell-based horizon + + ! Global and local particle data + integer :: np !< Global number of particles + integer :: np_ !< Local number of particles + integer, dimension(:), allocatable :: np_proc !< Number of particles on each processor + type(part), dimension(:), allocatable :: p !< Array of particles of type part + + ! Overlap particle (i.e., ghost) data + integer :: ng_ !< Local number of ghosts + type(part), dimension(:), allocatable :: g !< Array of ghosts of type part + + ! Gravitational acceleration + real(WP), dimension(3) :: gravity=[0.0_WP,0.0_WP,0.0_WP] + + ! Solid volume fraction and momentum + real(WP), dimension(:,:,:), allocatable :: VF !< Volume fraction, cell-centered + real(WP), dimension(:,:,:), allocatable :: VFU !< Solid velocity, U-face + real(WP), dimension(:,:,:), allocatable :: VFV !< Solid velocity, V-face + real(WP), dimension(:,:,:), allocatable :: VFW !< Solid velocity, W-face + + ! CFL numbers + real(WP) :: CFLp_x,CFLp_y,CFLp_z,CFLp_a + + ! Number of substeps for time integrator + real(WP) :: nstep=1 + + ! Monitoring info + real(WP) :: Umin,Umax,Umean !< U velocity info + real(WP) :: Vmin,Vmax,Vmean !< V velocity info + real(WP) :: Wmin,Wmax,Wmean !< W velocity info + real(WP) :: VFmax !< Volume fraction info + real(WP), dimension(3) :: ibmForce !< Total force due to IBM + integer :: np_out !< Number of particles leaving the domain + + contains + procedure :: bond_init !< Setup initial interparticle bonds + procedure :: get_bond_force !< Compute interparticle bond force + procedure :: advance !< Step forward the particle ODEs + procedure :: get_cfl !< Calculate maximum CFL + procedure :: get_max !< Extract various monitoring data + procedure :: update_partmesh !< Update a partmesh object using current particles + procedure :: share !< Share particles across interprocessor boundaries + procedure :: sync !< Synchronize particles across interprocessor boundaries + procedure :: resize !< Resize particle array to given size + procedure :: resize_ghost !< Resize ghost array to given size + procedure :: recycle !< Recycle particle array by removing flagged particles + procedure :: write !< Parallel write particles to file + procedure :: read !< Parallel read particles from file + procedure :: update_VF !< Compute volume fraction + procedure :: get_delta !< Compute regularized delta function + procedure :: interpolate !< Interpolation routine from mesh=>marker + procedure :: extrapolate !< Extrapolation routine from marker=>mesh + procedure :: stretch + end type lss + + + !> Declare lss constructor + interface lss + procedure constructor + end interface lss + +contains + + + ! Quasi-Gaussian weighting function - h is the cut-off + real(WP) function wgauss(d,h) + implicit none + real(WP), intent(in) :: d,h + real(WP), parameter :: coeff=2.6_WP + real(WP) :: hh + hh=coeff*h + if (d.ge.hh) then + wgauss=0.0_WP + else + wgauss=(1.0_WP+4.0_WP*d/hh)*(1.0_WP-d/hh)**4 + end if + end function wgauss + + + !> Default constructor for Lagrangian solid solver + function constructor(cfg,name) result(self) + implicit none + type(lss) :: self + class(config), target, intent(in) :: cfg + character(len=*), optional :: name + integer :: i,j,k + + ! Set the name for the solver + if (present(name)) self%name=trim(adjustl(name)) + + ! Point to pgrid object + self%cfg=>cfg + + ! Set default bonding horizon based on underlying mesh + self%delta=self%cfg%min_meshsize + self%nb=1 + self%min_dist=huge(1.0_WP) + + ! Allocate variables + allocate(self%np_proc(1:self%cfg%nproc)); self%np_proc=0 + self%np_=0; self%np=0 + call self%resize(0) + + ! Initialize MPI derived datatype for a particle + call prepare_mpi_part() + + ! Allocate VF array on cfg mesh + allocate(self%VF(self%cfg%imino_:self%cfg%imaxo_,self%cfg%jmino_:self%cfg%jmaxo_,self%cfg%kmino_:self%cfg%kmaxo_)); self%VF=0.0_WP + allocate(self%VFU(self%cfg%imino_:self%cfg%imaxo_,self%cfg%jmino_:self%cfg%jmaxo_,self%cfg%kmino_:self%cfg%kmaxo_)); self%VFU=0.0_WP + allocate(self%VFV(self%cfg%imino_:self%cfg%imaxo_,self%cfg%jmino_:self%cfg%jmaxo_,self%cfg%kmino_:self%cfg%kmaxo_)); self%VFV=0.0_WP + allocate(self%VFW(self%cfg%imino_:self%cfg%imaxo_,self%cfg%jmino_:self%cfg%jmaxo_,self%cfg%kmino_:self%cfg%kmaxo_)); self%VFW=0.0_WP + + ! Log/screen output + logging: block + use, intrinsic :: iso_fortran_env, only: output_unit + use param, only: verbose + use messager, only: log + use string, only: str_long + character(len=str_long) :: message + if (self%cfg%amRoot) then + write(message,'("LSS object [",a,"] on partitioned grid [",a,"]")') trim(self%name),trim(self%cfg%name) + if (verbose.gt.1) write(output_unit,'(a)') trim(message) + if (verbose.gt.0) call log(message) + end if + end block logging + + end function constructor + + + !> Initialize bond force between particles + subroutine bond_init(this) + use messager, only: die + implicit none + class(lss), intent(inout) :: this + integer, dimension(:,:,:), allocatable :: npic !< Number of particle in cell + integer, dimension(:,:,:,:), allocatable :: ipic !< Index of particle in cell + + ! Communicate particles in ghost cells + call this%share() + + ! We can now assemble particle-in-cell information + pic_prep: block + use mpi_f08 + integer :: i,ip,jp,kp,ierr + integer :: mymax_npic,max_npic + + ! Allocate number of particle in cell + allocate(npic(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)); npic=0 + + ! Count particles and ghosts per cell + do i=1,this%np_ + ip=this%p(i)%ind(1); jp=this%p(i)%ind(2); kp=this%p(i)%ind(3) + npic(ip,jp,kp)=npic(ip,jp,kp)+1 + end do + do i=1,this%ng_ + ip=this%g(i)%ind(1); jp=this%g(i)%ind(2); kp=this%g(i)%ind(3) + npic(ip,jp,kp)=npic(ip,jp,kp)+1 + end do + + ! Get maximum number of particle in cell + mymax_npic=maxval(npic); call MPI_ALLREDUCE(mymax_npic,max_npic,1,MPI_INTEGER,MPI_MAX,this%cfg%comm,ierr) + + ! Allocate pic map + allocate(ipic(1:max_npic,this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)); ipic=0 + + ! Assemble pic map + npic=0 + do i=1,this%np_ + ip=this%p(i)%ind(1); jp=this%p(i)%ind(2); kp=this%p(i)%ind(3) + npic(ip,jp,kp)=npic(ip,jp,kp)+1 + ipic(npic(ip,jp,kp),ip,jp,kp)=+i + end do + do i=1,this%ng_ + ip=this%g(i)%ind(1); jp=this%g(i)%ind(2); kp=this%g(i)%ind(3) + npic(ip,jp,kp)=npic(ip,jp,kp)+1 + ipic(npic(ip,jp,kp),ip,jp,kp)=-i + end do + + end block pic_prep + + ! Establish initial bonds + create_bonds: block + use mpi_f08, only: MPI_ALLREDUCE,MPI_MIN,MPI_IN_PLACE + use parallel, only: MPI_REAL_WP + use mathtools, only: Pi + integer :: i,j,k,n1,nn,n2,ierr + type(part) :: p1,p2 + real(WP), dimension(3) :: rpos + real(WP) :: dist + ! Reset minimum bond distance + this%min_dist=huge(1.0_WP) + ! Loop over particles + do n1=1,this%np_ + ! Create copy of our particle + p1=this%p(n1) + ! Zero out weighted volume + p1%mw=0.0_WP + ! Zero out bonds + p1%ibond=0 + p1%nbond=0 + ! Loop over neighbor cells + do k=p1%ind(3)-this%nb,p1%ind(3)+this%nb + do j=p1%ind(2)-this%nb,p1%ind(2)+this%nb + do i=p1%ind(1)-this%nb,p1%ind(1)+this%nb + ! Loop over particles in that cell + do nn=1,npic(i,j,k) + ! Create copy of our neighbor + n2=ipic(nn,i,j,k) + if (n2.gt.0) then + p2=this%p(+n2) + else if (n2.lt.0) then + p2=this%g(-n2) + end if + ! Cannot self-bond + if (p1%i.eq.p2%i) cycle + ! Cannot bond with different id except <=0 (<=0 bonds with everyone) + if (p1%id.ne.p2%id.and.p1%id.ge.0.and.p2%id.ge.0) cycle + ! Check interparticle distance + rpos=p2%pos-p1%pos + dist=sqrt(dot_product(rpos,rpos)) + if (dist.lt.this%delta) then + ! This particle is in horizon, create a bond + p1%nbond=p1%nbond+1 + if (p1%nbond.gt.max_bond) call die('[lss_class bond_init] Number of detected bonds is larger than max allowed') + p1%ibond(p1%nbond)=p2%i + p1%dbond(p1%nbond)=dist + ! Increment weighted volume + p1%mw=p1%mw+wgauss(dist,this%delta)*dist**2*p1%vol + ! Determine minimum bond distance + this%min_dist=min(this%min_dist,dist) + end if + end do + end do + end do + end do + ! Zero out initial dilatation + p1%dil=0.0_WP + ! Copy back the particle + this%p(n1)=p1 + end do + ! Get global minimum + call MPI_ALLREDUCE(MPI_IN_PLACE,this%min_dist,1,MPI_REAL_WP,MPI_MIN,this%cfg%comm,ierr) + end block create_bonds + + ! Clean up + if (allocated(npic)) deallocate(npic) + if (allocated(ipic)) deallocate(ipic) + + end subroutine bond_init + + + !> Calculate bond force between particles + subroutine get_bond_force(this) + implicit none + class(lss), intent(inout) :: this + integer, dimension(:,:,:), allocatable :: npic !< Number of particle in cell + integer, dimension(:,:,:,:), allocatable :: ipic !< Index of particle in cell + logical :: is2D + + ! Need to modify parameters in 2D + is2D=this%cfg%nx.eq.1.or.this%cfg%ny.eq.1.or.this%cfg%nz.eq.1 + + ! Communicate particles in ghost cells + call this%share() + + ! We can now assemble particle-in-cell information + pic_prep: block + use mpi_f08 + integer :: i,ip,jp,kp,ierr + integer :: mymax_npic,max_npic + + ! Allocate number of particle in cell + allocate(npic(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)); npic=0 + + ! Count particles and ghosts per cell + do i=1,this%np_ + ip=this%p(i)%ind(1); jp=this%p(i)%ind(2); kp=this%p(i)%ind(3) + npic(ip,jp,kp)=npic(ip,jp,kp)+1 + end do + do i=1,this%ng_ + ip=this%g(i)%ind(1); jp=this%g(i)%ind(2); kp=this%g(i)%ind(3) + npic(ip,jp,kp)=npic(ip,jp,kp)+1 + end do + + ! Get maximum number of particle in cell + mymax_npic=maxval(npic); call MPI_ALLREDUCE(mymax_npic,max_npic,1,MPI_INTEGER,MPI_MAX,this%cfg%comm,ierr) + + ! Allocate pic map + allocate(ipic(1:max_npic,this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)); ipic=0 + + ! Assemble pic map + npic=0 + do i=1,this%np_ + ip=this%p(i)%ind(1); jp=this%p(i)%ind(2); kp=this%p(i)%ind(3) + npic(ip,jp,kp)=npic(ip,jp,kp)+1 + ipic(npic(ip,jp,kp),ip,jp,kp)=+i + end do + do i=1,this%ng_ + ip=this%g(i)%ind(1); jp=this%g(i)%ind(2); kp=this%g(i)%ind(3) + npic(ip,jp,kp)=npic(ip,jp,kp)+1 + ipic(npic(ip,jp,kp),ip,jp,kp)=-i + end do + + end block pic_prep + + ! Update weighted volume and dilatation + update_weighted_vol_and_dilatation: block + integer :: i,j,k,n1,nn,n2 + type(part) :: p1,p2 + integer :: nb,nbond + real(WP), dimension(3) :: rpos, Gd_vec + real(WP) :: dist, Gd_mag + ! Loop over particles + do n1=1,this%np_ + ! Create copy of our particle + p1=this%p(n1) + ! Zero out weighted volume and dilatation + p1%mw=0.0_WP + p1%dil=0.0_WP + ! Loop over neighbor cells + do k=p1%ind(3)-this%nb,p1%ind(3)+this%nb + do j=p1%ind(2)-this%nb,p1%ind(2)+this%nb + do i=p1%ind(1)-this%nb,p1%ind(1)+this%nb + ! Loop over particles in that cell + do nn=1,npic(i,j,k) + ! Create copy of our neighbor + n2=ipic(nn,i,j,k) + if (n2.gt.0) then + p2=this%p(+n2) + else if (n2.lt.0) then + p2=this%g(-n2) + end if + ! Check if a bond exists + do nb=1,max_bond + if (p1%ibond(nb).eq.p2%i) then + ! Increment weighted volume + p1%mw=p1%mw+wgauss(p1%dbond(nb),this%delta)*p1%dbond(nb)**2*p2%vol + ! Get current distance + rpos=p2%pos-p1%pos + dist=sqrt(dot_product(rpos,rpos)) + ! compute average G correction for dilitation + Gd_vec = (p2%gd + p1%gd)/2.0_WP + + Gd_mag = sqrt(1.0_WP/(((rpos(1)/dist)/Gd_vec(1))**2 + ((rpos(2)/dist)/Gd_vec(2))**2 + ((rpos(3)/dist)/Gd_vec(3))**2 )) + ! Increment dilatation + p1%dil=p1%dil+wgauss(p1%dbond(nb),this%delta)*p1%dbond(nb)*(dist-p1%dbond(nb))*p2%vol*Gd_mag + end if + end do + end do + end do + end do + end do + ! Rescale dilatation + if (p1%mw.gt.epsilon(1.0_WP)) then + if (is2D) then + ! 2D plane strain + p1%dil=p1%dil*2.0_WP/p1%mw + else + ! 3D + p1%dil=p1%dil*3.0_WP/p1%mw + end if + else + p1%dil=0.0_WP + end if + ! Copy back the particle + this%p(n1)=p1 + end do + end block update_weighted_vol_and_dilatation + + ! Re-communicate particles in ghost cells to update dil and mw + call this%share() + + ! Update bond force, including collision force, and SED + update_bond_force: block + use mpi_f08, only: MPI_ALLREDUCE,MPI_MIN,MPI_IN_PLACE + use parallel, only: MPI_REAL_WP + use mathtools, only: Pi + integer :: i,j,k,n1,nn,n2,ierr + type(part) :: p1,p2 + real(WP), dimension(3) :: rpos,t12,t21,Gd_vec + real(WP) :: dist,beta,alpha,ed,t,Gd_mag + real(WP) :: stretch,max_stretch,mu,kk + real(WP) :: nc,rc,kc + integer :: nb,nbond + logical :: found_bond + ! Recompute a few physical parameters + mu=this%elastic_modulus/(2.0_WP+2.0_WP*this%poisson_ratio) + kk=this%elastic_modulus/(3.0_WP-6.0_WP*this%poisson_ratio) + if (is2D) then + if (this%cfg%nx.eq.1) t=this%cfg%xL + if (this%cfg%ny.eq.1) t=this%cfg%yL + if (this%cfg%nz.eq.1) t=this%cfg%zL + max_stretch=sqrt(this%crit_energy/((6.0_WP*mu/Pi+16.0_WP/(9.0_WP*Pi**2)*(kk-2.0_WP*mu))*this%delta)) + kc=15.0_WP*48.0_WP*this%elastic_modulus/(Pi*5.0_WP*t*this%delta**3) + else + max_stretch=sqrt(this%crit_energy/((3.0_WP*mu+(kk-5.0_WP*mu/3.0_WP)*0.75_WP**4)*this%delta)) + kc=15.0_WP*12.0_WP*this%elastic_modulus/(Pi*this%delta**4) + end if + nc=1.0_WP + this%min_dist=huge(1.0_WP) + ! Loop over particles + do n1=1,this%np_ + ! Particles marked 0 do not update their forces + if (this%p(n1)%id.eq.0) cycle + ! Create copy of our particle + p1=this%p(n1) + ! Zero out bond force + p1%Abond=0.0_WP + ! Loop over neighbor cells + do k=p1%ind(3)-this%nb,p1%ind(3)+this%nb + do j=p1%ind(2)-this%nb,p1%ind(2)+this%nb + do i=p1%ind(1)-this%nb,p1%ind(1)+this%nb + ! Loop over particles in that cell + do nn=1,npic(i,j,k) + ! Create copy of our neighbor + n2=ipic(nn,i,j,k) + if (n2.gt.0) then + p2=this%p(+n2) + else if (n2.lt.0) then + p2=this%g(-n2) + end if + ! Current distance + rpos=p2%pos-p1%pos + dist=sqrt(dot_product(rpos,rpos)) + ! Check if a bond exists + found_bond=.false. + do nb=1,max_bond + if (p1%ibond(nb).eq.p2%i) then + ! Check for breakage first + stretch=(dist-p1%dbond(nb))/p1%dbond(nb) + if (stretch.gt.max_stretch) then + ! Remove the bond and flag as surface particle + p1%ibond(nb)=0 + p1%dbond(nb)=0.0_WP + cycle + end if + ! Particle 1 + if (is2D) then + ! 2D plane strain + beta = 2.0_WP * kk * p1%dil + alpha = 8.0_WP * mu / p1%mw + ed = dist - p1%dbond(nb) * (1.0_WP + p1%dil / 2.0_WP) + else + ! 3D + beta = 3.0_WP * kk * p1%dil + alpha = 15.0_WP * mu / p1%mw + ed = dist - p1%dbond(nb) * (1.0_WP + p1%dil / 3.0_WP) + end if + ! Force density 1->2 + ! t12=+wgauss(p1%dbond(nb),this%delta)*(beta/p1%mw*p1%dbond(nb)+alpha*ed)*rpos/dist + Gd_vec = (p2%gd + p1%gd)/2.0_WP + + Gd_mag = sqrt(1.0_WP/(((rpos(1)/dist)/Gd_vec(1))**2 + ((rpos(2)/dist)/Gd_vec(2))**2 + ((rpos(3)/dist)/Gd_vec(3))**2 )) + t12=+wgauss(p1%dbond(nb),this%delta)*((3.0_WP*kk - 15.0_WP*mu/3.0_WP)*(Gd_mag*p1%dil*p1%dbond(nb)/p1%mw) + (15.0_WP*mu/p1%mw)*(dist - p1%dbond(nb)) )*rpos/dist + ! Particle 2 + if (is2D) then + ! 2D plane strain + beta = 2.0_WP * kk * p2%dil + alpha = 8.0_WP * mu / p2%mw + ed = dist - p1%dbond(nb) * (1.0_WP + p2%dil / 2.0_WP) + else + ! 3D + beta = 3.0_WP * kk * p2%dil + alpha = 15.0_WP * mu / p2%mw + ed = dist - p1%dbond(nb) * (1.0_WP + p2%dil / 3.0_WP) + end if + ! Force density 2->1 + ! t21=-wgauss(p1%dbond(nb),this%delta)*(beta/p2%mw*p1%dbond(nb)+alpha*ed)*rpos/dist + t21=-wgauss(p1%dbond(nb),this%delta)*((3.0_WP*kk - 15.0_WP*mu/3.0_WP)*(Gd_mag*p2%dil*p1%dbond(nb)/p2%mw)+ (15.0_WP*mu/p2%mw)*(dist - p1%dbond(nb)) )*rpos/dist ! Increment bond force + p1%Abond=p1%Abond+(t12-t21)*p2%vol/this%rho + ! Incremend SED + p1%ste=p1%ste+alpha/2.0_WP*(wgauss(p1%dbond(nb),this%delta)*((dist-p1%dbond(nb)))*p2%vol) + ! If still here, we have an active bond + found_bond=.true. + ! Determine minimum bond distance + this%min_dist=min(this%min_dist,dist) + cycle + end if + end do + ! Add collision force now + ! if (is2D) then + ! rc=p1%vol**(1.0_WP/2.0_WP) + ! else + ! rc=p1%vol**(1.0_WP/3.0_WP) + ! end if + ! if (.not.found_bond.and.p1%i.ne.p2%i.and.dist.lt.rc) then + ! p1%Abond=p1%Abond-max(kc*((rc/dist)**nc-1.0_WP),0.0_WP)*(rpos/dist)*p1%vol/this%rho + ! p1%flag = -2 + ! end if + end do + end do + end do + end do + ! Deal with dimensionality + if (this%cfg%nx.eq.1) p1%Abond(1)=0.0_WP + if (this%cfg%ny.eq.1) p1%Abond(2)=0.0_WP + if (this%cfg%nz.eq.1) p1%Abond(3)=0.0_WP + ! Copy back the particle + this%p(n1)=p1 + end do + ! Get global minimum + call MPI_ALLREDUCE(MPI_IN_PLACE,this%min_dist,1,MPI_REAL_WP,MPI_MIN,this%cfg%comm,ierr) + end block update_bond_force + + ! Clean up + if (allocated(npic)) deallocate(npic) + if (allocated(ipic)) deallocate(ipic) + + end subroutine get_bond_force + + + !> Advance the particle equations by a specified time step dt + !> p%id=-2 => do not solve for position nor velocity + !> p%id=-1 => do not solve for velocity + !> p%id= 0 => do not update force + + subroutine advance(this,dt)!,stress_x,stress_y,stress_z) + use mpi_f08, only : MPI_SUM,MPI_INTEGER,MPI_IN_PLACE + use mathtools, only: Pi + implicit none + class(lss), intent(inout) :: this + real(WP), intent(inout) :: dt !< Timestep size over which to advance + ! real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(inout) :: stress_x !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + ! real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(inout) :: stress_y !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + ! real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(inout) :: stress_z !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + integer :: n,ierr + ! real(WP), dimension(3) :: stress + + ! Zero out number of particles removed + this%np_out=0 + + ! Advance velocity based on old force and position based on mid-velocity + do n=1,this%np_ + ! Advance with Verlet scheme + if (this%p(n)%id.gt.-1) this%p(n)%vel=this%p(n)%vel+0.5_WP*dt*(this%gravity+this%p(n)%Abond+this%p(n)%Afluid) + if (this%p(n)%id.gt.-2) this%p(n)%pos=this%p(n)%pos+dt*this%p(n)%vel + ! Relocalize + this%p(n)%ind=this%cfg%get_ijk_global(this%p(n)%pos,this%p(n)%ind) + ! Correct the position to take into account periodicity + if (this%cfg%xper) this%p(n)%pos(1)=this%cfg%x(this%cfg%imin)+modulo(this%p(n)%pos(1)-this%cfg%x(this%cfg%imin),this%cfg%xL) + if (this%cfg%yper) this%p(n)%pos(2)=this%cfg%y(this%cfg%jmin)+modulo(this%p(n)%pos(2)-this%cfg%y(this%cfg%jmin),this%cfg%yL) + if (this%cfg%zper) this%p(n)%pos(3)=this%cfg%z(this%cfg%kmin)+modulo(this%p(n)%pos(3)-this%cfg%z(this%cfg%kmin),this%cfg%zL) + ! Handle particles that have left the domain + if (this%p(n)%pos(1).lt.this%cfg%x(this%cfg%imin).or.this%p(n)%pos(1).gt.this%cfg%x(this%cfg%imax+1)) this%p(n)%flag=1 + if (this%p(n)%pos(2).lt.this%cfg%y(this%cfg%jmin).or.this%p(n)%pos(2).gt.this%cfg%y(this%cfg%jmax+1)) this%p(n)%flag=1 + if (this%p(n)%pos(3).lt.this%cfg%z(this%cfg%kmin).or.this%p(n)%pos(3).gt.this%cfg%z(this%cfg%kmax+1)) this%p(n)%flag=1 + ! Relocalize the particle + this%p(n)%ind=this%cfg%get_ijk_global(this%p(n)%pos,this%p(n)%ind) + ! Count number of particles removed + if (this%p(n)%flag.eq.1) this%np_out=this%np_out+1 + end do + + ! Communicate particles + call this%sync() + + ! Sum up particles removed + call MPI_ALLREDUCE(this%np_out,n,1,MPI_INTEGER,MPI_SUM,this%cfg%comm,ierr); this%np_out=n + + ! Calculate bond force + call this%get_bond_force() + + ! Advance velocity only based on new force + do n=1,this%np_ + ! Advance with Verlet scheme + if (this%p(n)%id.le.-1) cycle + ! stress=this%cfg%get_velocity(pos=this%p(n)%pos,i0=this%p(n)%ind(1),j0=this%p(n)%ind(2),k0=this%p(n)%ind(3),U=stress_x,V=stress_y,W=stress_z) + ! this%p(n)%Afluid=stress/this%rho + this%p(n)%Afluid=0.0_WP + this%p(n)%vel=this%p(n)%vel+0.5_WP*dt*(this%gravity+this%p(n)%Abond+this%p(n)%Afluid) + end do + + ! Recompute volume fraction + ! call this%update_VF() + + ! Log/screen output + logging: block + use, intrinsic :: iso_fortran_env, only: output_unit + use param, only: verbose + use messager, only: log + use string, only: str_long + character(len=str_long) :: message + if (this%cfg%amRoot) then + write(message,'("Particle solver [",a,"] on partitioned grid [",a,"]: ",i0," particles were advanced")') trim(this%name),trim(this%cfg%name),this%np + if (verbose.gt.1) write(output_unit,'(a)') trim(message) + if (verbose.gt.0) call log(message) + end if + end block logging + + end subroutine advance + + subroutine stretch(this,dt)!,stress_x,stress_y,stress_z) + use mpi_f08, only : MPI_SUM,MPI_INTEGER,MPI_IN_PLACE + use mathtools, only: Pi + implicit none + class(lss), intent(inout) :: this + real(WP), intent(inout) :: dt !< Timestep size over which to advance + real(WP) :: mu + integer :: n,ierr + !======================================================================================== + ! X-Axis Stretch: + ! Zero out number of particles removed + this%np_out=0 + do n=1,this%np_ + ! Stretch the beam along the x axis with a uniform strain-rate of 0.001 + if (this%p(n)%id.gt.-2) this%p(n)%pos(1)=this%p(n)%pos(1)*1.001_WP + end do + + ! Communicate particles + call this%sync() + + ! Calculate bond force + call this%get_bond_force() + + mu=this%elastic_modulus/(2.0_WP+2.0_WP*this%poisson_ratio) + + do n=1,this%np_ + if (this%p(n)%id.gt.-2) this%p(n)%gd(1)=0.001_WP/this%p(n)%dil + end do + + !======================================================================================== + ! Y-Axis Stretch: + ! Zero out number of particles removed + this%np_out=0 + do n=1,this%np_ + ! Stretch the beam along the x axis with a uniform strain-rate of 0.001 + if (this%p(n)%id.gt.-2) this%p(n)%pos(1)=this%p(n)%pos(1)/1.001_WP + if (this%p(n)%id.gt.-2) this%p(n)%pos(2)=this%p(n)%pos(2)*1.001_WP + end do + + ! Communicate particles + call this%sync() + + ! Calculate bond force + call this%get_bond_force() + + mu=this%elastic_modulus/(2.0_WP+2.0_WP*this%poisson_ratio) + + do n=1,this%np_ + if (this%p(n)%id.gt.-2) this%p(n)%gd(2)=0.001_WP/this%p(n)%dil + end do + + !======================================================================================== + ! Z-Axis Stretch: + ! Zero out number of particles removed + this%np_out=0 + do n=1,this%np_ + ! Stretch the beam along the x axis with a uniform strain-rate of 0.001 + if (this%p(n)%id.gt.-2) this%p(n)%pos(2)=this%p(n)%pos(2)/1.001_WP + if (this%p(n)%id.gt.-2) this%p(n)%pos(3)=this%p(n)%pos(3)*1.001_WP + end do + + ! Communicate particles + call this%sync() + + ! Calculate bond force + call this%get_bond_force() + + mu=this%elastic_modulus/(2.0_WP+2.0_WP*this%poisson_ratio) + + do n=1,this%np_ + if (this%p(n)%id.gt.-2) this%p(n)%gd(3)=0.001_WP/this%p(n)%dil + end do + + ! Put the particle back where it was + do n=1,this%np_ + if (this%p(n)%id.gt.-2) this%p(n)%pos(3)=this%p(n)%pos(3)/1.001_WP + end do + + !====================================================================================== + + ! Now stretch particle for the first time step + + do n=1,this%np_ + ! Stretch the beam along the x axis with a uniform strain-rate of 0.001 + if (this%p(n)%id.gt.-2) this%p(n)%pos(1)=this%p(n)%pos(1)*1.001_WP + end do + + ! Communicate particles + call this%sync() + + ! Calculate bond force + call this%get_bond_force() + + + + + end subroutine stretch + + subroutine get_correction_coeffs(this,dt)!,stress_x,stress_y,stress_z) + use mpi_f08, only : MPI_SUM,MPI_INTEGER,MPI_IN_PLACE + use mathtools, only: Pi + implicit none + class(lss), intent(inout) :: this + real(WP), intent(inout) :: dt !< Timestep size over which to advance + real(WP) :: mu + integer :: n,ierr + ! Zero out number of particles removed + this%np_out=0 + do n=1,this%np_ + ! Stretch the beam along the x axis with a uniform strain-rate of 0.001 + if (this%p(n)%id.gt.-2) this%p(n)%pos(1)=this%p(n)%pos(1) + this%p(n)%pos(1)*0.001_WP + ! Relocalize + this%p(n)%ind=this%cfg%get_ijk_global(this%p(n)%pos,this%p(n)%ind) + ! Correct the position to take into account periodicity + if (this%cfg%xper) this%p(n)%pos(1)=this%cfg%x(this%cfg%imin)+modulo(this%p(n)%pos(1)-this%cfg%x(this%cfg%imin),this%cfg%xL) + if (this%cfg%yper) this%p(n)%pos(2)=this%cfg%y(this%cfg%jmin)+modulo(this%p(n)%pos(2)-this%cfg%y(this%cfg%jmin),this%cfg%yL) + if (this%cfg%zper) this%p(n)%pos(3)=this%cfg%z(this%cfg%kmin)+modulo(this%p(n)%pos(3)-this%cfg%z(this%cfg%kmin),this%cfg%zL) + ! Handle particles that have left the domain + if (this%p(n)%pos(1).lt.this%cfg%x(this%cfg%imin).or.this%p(n)%pos(1).gt.this%cfg%x(this%cfg%imax+1)) this%p(n)%flag=1 + if (this%p(n)%pos(2).lt.this%cfg%y(this%cfg%jmin).or.this%p(n)%pos(2).gt.this%cfg%y(this%cfg%jmax+1)) this%p(n)%flag=1 + if (this%p(n)%pos(3).lt.this%cfg%z(this%cfg%kmin).or.this%p(n)%pos(3).gt.this%cfg%z(this%cfg%kmax+1)) this%p(n)%flag=1 + ! Relocalize the particle + this%p(n)%ind=this%cfg%get_ijk_global(this%p(n)%pos,this%p(n)%ind) + ! Count number of particles removed + end do + + ! Communicate particles + call this%sync() + + ! Sum up particles removed + call MPI_ALLREDUCE(this%np_out,n,1,MPI_INTEGER,MPI_SUM,this%cfg%comm,ierr); this%np_out=n + + ! Calculate bond force + call this%get_bond_force() + + mu=this%elastic_modulus/(2.0_WP+2.0_WP*this%poisson_ratio) + + do n=1,this%np_ + this%p(n)%gd=0.001_WP/this%p(n)%dil + this%p(n)%Gb=0.5_WP*mu*(0.001_WP*0.001_WP)/this%p(n)%ste + end do + + ! Log/screen output + logging: block + use, intrinsic :: iso_fortran_env, only: output_unit + use param, only: verbose + use messager, only: log + use string, only: str_long + character(len=str_long) :: message + if (this%cfg%amRoot) then + write(message,'("Particle solver [",a,"] on partitioned grid [",a,"]: ",i0," particles were advanced")') trim(this%name),trim(this%cfg%name),this%np + if (verbose.gt.1) write(output_unit,'(a)') trim(message) + if (verbose.gt.0) call log(message) + end if + end block logging + + end subroutine get_correction_coeffs + + + !> Update particle volume fraction using our current particles + subroutine update_VF(this) + implicit none + class(lss), intent(inout) :: this + integer :: i + ! Reset volume fraction and momentum + this%VF=0.0_WP; this%VFU=0.0_WP; this%VFV=0.0_WP; this%VFW=0.0_WP + ! Transfer particle volume + do i=1,this%np_ + ! Skip inactive particle + if (this%p(i)%flag.eq.1) cycle + ! Transfer volume to mesh + call this%extrapolate(Ap=this%p(i)%vol,xp=this%p(i)%pos(1),yp=this%p(i)%pos(2),zp=this%p(i)%pos(3),ip=this%p(i)%ind(1),jp=this%p(i)%ind(2),kp=this%p(i)%ind(3),A=this%VF,dir='SC') + call this%extrapolate(Ap=this%p(i)%vol*this%p(i)%vel(1),xp=this%p(i)%pos(1),yp=this%p(i)%pos(2),zp=this%p(i)%pos(3),ip=this%p(i)%ind(1),jp=this%p(i)%ind(2),kp=this%p(i)%ind(3),A=this%VFU,dir='U') + call this%extrapolate(Ap=this%p(i)%vol*this%p(i)%vel(2),xp=this%p(i)%pos(1),yp=this%p(i)%pos(2),zp=this%p(i)%pos(3),ip=this%p(i)%ind(1),jp=this%p(i)%ind(2),kp=this%p(i)%ind(3),A=this%VFV,dir='V') + call this%extrapolate(Ap=this%p(i)%vol*this%p(i)%vel(3),xp=this%p(i)%pos(1),yp=this%p(i)%pos(2),zp=this%p(i)%pos(3),ip=this%p(i)%ind(1),jp=this%p(i)%ind(2),kp=this%p(i)%ind(3),A=this%VFW,dir='W') + end do + ! Sum at boundaries + call this%cfg%syncsum(this%VF) + call this%cfg%syncsum(this%VFU) + call this%cfg%syncsum(this%VFV) + call this%cfg%syncsum(this%VFW) + ! Clip + where (this%VF.gt.1.0_WP) this%VF=1.0_WP + where (this%VF.lt.0.0_WP) this%VF=0.0_WP + end subroutine update_VF + + + !> Compute regularized delta function + subroutine get_delta(this,delta,ic,jc,kc,xp,yp,zp,dir) + implicit none + class(lss), intent(inout) :: this + real(WP), intent(out) :: delta !< Return delta function + integer, intent(in) :: ic,jc,kc !< Cell index + real(WP), intent(in) :: xp,yp,zp !< Position of marker + character(len=*) :: dir + real(WP) :: deltax,deltay,deltaz,r + + ! Compute in X + if (trim(adjustl(dir)).eq.'U') then + r=(xp-this%cfg%x(ic))*this%cfg%dxmi(ic) + deltax=roma_kernel(r)*this%cfg%dxmi(ic) + else + r=(xp-this%cfg%xm(ic))*this%cfg%dxi(ic) + deltax=roma_kernel(r)*this%cfg%dxi(ic) + end if + + ! Compute in Y + if (trim(adjustl(dir)).eq.'V') then + r=(yp-this%cfg%y(jc))*this%cfg%dymi(jc) + deltay=roma_kernel(r)*this%cfg%dymi(jc) + else + r=(yp-this%cfg%ym(jc))*this%cfg%dyi(jc) + deltay=roma_kernel(r)*this%cfg%dyi(jc) + end if + + ! Compute in Z + if (trim(adjustl(dir)).eq.'W') then + r=(zp-this%cfg%z(kc))*this%cfg%dzmi(kc) + deltaz=roma_kernel(r)*this%cfg%dzmi(kc) + else + r=(zp-this%cfg%zm(kc))*this%cfg%dzi(kc) + deltaz=roma_kernel(r)*this%cfg%dzi(kc) + end if + !else + + ! Put it all together + delta=deltax*deltay*deltaz + + contains + ! Mollification kernel + ! Roma A, Peskin C and Berger M 1999 J. Comput. Phys. 153 509–534 + function roma_kernel(r) result(phi) + implicit none + real(WP), intent(in) :: r + real(WP) :: phi + if (abs(r).le.0.5_WP) then + phi=1.0_WP/3.0_WP*(1.0_WP+sqrt(-3.0_WP*r**2+1.0_WP)) + else if (abs(r).gt.0.5_WP .and. abs(r).le.1.5_WP) then + phi=1.0_WP/6.0_WP*(5.0_WP-3.0_WP*abs(r)-sqrt(-3.0_WP*(1.0_WP-abs(r))**2+1.0_WP)) + else + phi=0.0_WP + end if + end function roma_kernel + + end subroutine get_delta + + + !> Interpolation routine + function interpolate(this,A,xp,yp,zp,ip,jp,kp,dir) result(Ap) + implicit none + class(lss), intent(inout) :: this + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(in) :: A !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + real(WP), intent(in) :: xp,yp,zp + integer, intent(in) :: ip,jp,kp + character(len=*) :: dir + real(WP) :: Ap + integer :: di,dj,dk + integer :: i1,i2,j1,j2,k1,k2 + real(WP), dimension(-2:+2,-2:+2,-2:+2) :: delta + ! Get the interpolation points + i1=ip-2; i2=ip+2 + j1=jp-2; j2=jp+2 + k1=kp-2; k2=kp+2 + ! Loop over neighboring cells and compute regularized delta function + do dk=-2,+2 + do dj=-2,+2 + do di=-2,+2 + call this%get_delta(delta=delta(di,dj,dk),ic=ip+di,jc=jp+dj,kc=kp+dk,xp=xp,yp=yp,zp=zp,dir=trim(dir)) + end do + end do + end do + ! Perform the actual interpolation on Ap + Ap = sum(delta*A(i1:i2,j1:j2,k1:k2))*this%cfg%vol(ip,jp,kp) + end function interpolate + + + !> Extrapolation routine + subroutine extrapolate(this,Ap,xp,yp,zp,ip,jp,kp,A,dir) + use messager, only: die + implicit none + class(lss), intent(inout) :: this + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:) :: A !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + real(WP), intent(in) :: xp,yp,zp + integer, intent(in) :: ip,jp,kp + real(WP), intent(in) :: Ap + character(len=*) :: dir + real(WP), dimension(-2:+2,-2:+2,-2:+2) :: delta + integer :: di,dj,dk + ! If particle has left processor domain or reached last ghost cell, kill job + if ( ip.lt.this%cfg%imin_-1.or.ip.gt.this%cfg%imax_+1.or.& + & jp.lt.this%cfg%jmin_-1.or.jp.gt.this%cfg%jmax_+1.or.& + & kp.lt.this%cfg%kmin_-1.or.kp.gt.this%cfg%kmax_+1) then + write(*,*) ip,jp,kp,xp,yp,zp + call die('[df extrapolate] Particle has left the domain') + end if + ! Loop over neighboring cells and compute regularized delta function + do dk=-2,+2 + do dj=-2,+2 + do di=-2,+2 + call this%get_delta(delta=delta(di,dj,dk),ic=ip+di,jc=jp+dj,kc=kp+dk,xp=xp,yp=yp,zp=zp,dir=trim(dir)) + end do + end do + end do + ! Perform the actual extrapolation on A + A(ip-2:ip+2,jp-2:jp+2,kp-2:kp+2)=A(ip-2:ip+2,jp-2:jp+2,kp-2:kp+2)+delta*Ap + end subroutine extrapolate + + + !> Calculate the CFL + subroutine get_cfl(this,dt,cfl) + use mpi_f08, only: MPI_ALLREDUCE,MPI_MAX + use parallel, only: MPI_REAL_WP + implicit none + class(lss), intent(inout) :: this + real(WP), intent(in) :: dt + real(WP), intent(out) :: cfl + integer :: i,ierr + real(WP) :: my_CFLp_x,my_CFLp_y,my_CFLp_z,kk,mu,a + + ! Set the CFLs to zero + my_CFLp_x=0.0_WP; my_CFLp_y=0.0_WP; my_CFLp_z=0.0_WP + do i=1,this%np_ + my_CFLp_x=max(my_CFLp_x,abs(this%p(i)%vel(1))*this%cfg%dxi(this%p(i)%ind(1))) + my_CFLp_y=max(my_CFLp_y,abs(this%p(i)%vel(2))*this%cfg%dyi(this%p(i)%ind(2))) + my_CFLp_z=max(my_CFLp_z,abs(this%p(i)%vel(3))*this%cfg%dzi(this%p(i)%ind(3))) + end do + my_CFLp_x=my_CFLp_x*dt; my_CFLp_y=my_CFLp_y*dt; my_CFLp_z=my_CFLp_z*dt + + ! Get the parallel max + call MPI_ALLREDUCE(my_CFLp_x,this%CFLp_x,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + call MPI_ALLREDUCE(my_CFLp_y,this%CFLp_y,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + call MPI_ALLREDUCE(my_CFLp_z,this%CFLp_z,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + + ! CFL based on elastic wave speed in material + kk=this%elastic_modulus/(3.0_WP-6.0_WP*this%poisson_ratio) + mu=this%elastic_modulus/(2.0_WP+2.0_WP*this%poisson_ratio) + a=sqrt((kk+4.0_WP*mu/3.0_WP)/this%rho) + this%CFLp_a=dt*a*3/this%delta + + ! Return the maximum CFL + cfl=max(this%CFLp_x,this%CFLp_y,this%CFLp_z,this%CFLp_a) + + end subroutine get_cfl + + + !> Extract various monitoring data from particle field + subroutine get_max(this) + use mpi_f08, only: MPI_ALLREDUCE,MPI_MAX,MPI_MIN,MPI_SUM + use parallel, only: MPI_REAL_WP + implicit none + class(lss), intent(inout) :: this + real(WP) :: buf,safe_np + real(WP), dimension(3) :: buf3D + integer :: i,j,k,ierr + + ! Create safe np + safe_np=real(max(this%np,1),WP) + + ! Velocity min/max/mean + this%Umin=huge(1.0_WP); this%Umax=-huge(1.0_WP); this%Umean=0.0_WP + this%Vmin=huge(1.0_WP); this%Vmax=-huge(1.0_WP); this%Vmean=0.0_WP + this%Wmin=huge(1.0_WP); this%Wmax=-huge(1.0_WP); this%Wmean=0.0_WP + this%ibmForce=0.0_WP + do i=1,this%np_ + this%Umin=min(this%Umin,this%p(i)%vel(1)); this%Umax=max(this%Umax,this%p(i)%vel(1)); this%Umean=this%Umean+this%p(i)%vel(1) + this%Vmin=min(this%Vmin,this%p(i)%vel(2)); this%Vmax=max(this%Vmax,this%p(i)%vel(2)); this%Vmean=this%Vmean+this%p(i)%vel(2) + this%Wmin=min(this%Wmin,this%p(i)%vel(3)); this%Wmax=max(this%Wmax,this%p(i)%vel(3)); this%Wmean=this%Wmean+this%p(i)%vel(3) + this%ibmForce=this%ibmForce+this%p(i)%Afluid*this%p(i)%vol*this%rho + end do + call MPI_ALLREDUCE(this%Umin ,buf,1,MPI_REAL_WP,MPI_MIN,this%cfg%comm,ierr); this%Umin =buf + call MPI_ALLREDUCE(this%Umax ,buf,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr); this%Umax =buf + call MPI_ALLREDUCE(this%Umean,buf,1,MPI_REAL_WP,MPI_SUM,this%cfg%comm,ierr); this%Umean=buf/safe_np + call MPI_ALLREDUCE(this%Vmin ,buf,1,MPI_REAL_WP,MPI_MIN,this%cfg%comm,ierr); this%Vmin =buf + call MPI_ALLREDUCE(this%Vmax ,buf,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr); this%Vmax =buf + call MPI_ALLREDUCE(this%Vmean,buf,1,MPI_REAL_WP,MPI_SUM,this%cfg%comm,ierr); this%Vmean=buf/safe_np + call MPI_ALLREDUCE(this%Wmin ,buf,1,MPI_REAL_WP,MPI_MIN,this%cfg%comm,ierr); this%Wmin =buf + call MPI_ALLREDUCE(this%Wmax ,buf,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr); this%Wmax =buf + call MPI_ALLREDUCE(this%Wmean,buf,1,MPI_REAL_WP,MPI_SUM,this%cfg%comm,ierr); this%Wmean=buf/safe_np + call MPI_ALLREDUCE(this%ibmForce,buf3D,3,MPI_REAL_WP,MPI_SUM,this%cfg%comm,ierr); this%ibmForce=buf3D + + ! Get max volume fraction + this%VFmax =-huge(1.0_WP) + do k=this%cfg%kmin_,this%cfg%kmax_ + do j=this%cfg%jmin_,this%cfg%jmax_ + do i=this%cfg%imin_,this%cfg%imax_ + this%VFmax=max(this%VFmax,this%VF(i,j,k)) + end do + end do + end do + call MPI_ALLREDUCE(this%VFmax,buf,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr); this%VFmax=buf + + end subroutine get_max + + + !> Update particle mesh using our current particles + subroutine update_partmesh(this,pmesh) + use partmesh_class, only: partmesh + implicit none + class(lss), intent(inout) :: this + class(partmesh), intent(inout) :: pmesh + integer :: i + ! Reset particle mesh storage + call pmesh%reset() + ! Nothing else to do if no particle is present + if (this%np_.eq.0) return + ! Copy particle info + call pmesh%set_size(this%np_) + do i=1,this%np_ + pmesh%pos(:,i)=this%p(i)%pos + end do + end subroutine update_partmesh + + + !> Creation of the MPI datatype for particle + subroutine prepare_mpi_part() + use mpi_f08 + use messager, only: die + implicit none + integer(MPI_ADDRESS_KIND), dimension(part_nblock) :: disp + integer(MPI_ADDRESS_KIND) :: lb,extent + type(MPI_Datatype) :: MPI_PART_TMP + integer :: i,mysize,ierr + ! Prepare the displacement array + disp(1)=0 + do i=2,part_nblock + call MPI_Type_size(part_tblock(i-1),mysize,ierr) + disp(i)=disp(i-1)+int(mysize,MPI_ADDRESS_KIND)*int(part_lblock(i-1),MPI_ADDRESS_KIND) + end do + ! Create and commit the new type + call MPI_Type_create_struct(part_nblock,part_lblock,disp,part_tblock,MPI_PART_TMP,ierr) + call MPI_Type_get_extent(MPI_PART_TMP,lb,extent,ierr) + call MPI_Type_create_resized(MPI_PART_TMP,lb,extent,MPI_PART,ierr) + call MPI_Type_commit(MPI_PART,ierr) + ! If a problem was encountered, say it + if (ierr.ne.0) call die('[lss prepare_mpi_part] MPI Particle type creation failed') + ! Get the size of this type + call MPI_type_size(MPI_PART,MPI_PART_SIZE,ierr) + end subroutine prepare_mpi_part + + + !> Share particles across processor boundaries + subroutine share(this,nover) + use mpi_f08 + use messager, only: warn,die + implicit none + class(lss), intent(inout) :: this + integer, optional :: nover + type(part), dimension(:), allocatable :: tosend + type(part), dimension(:), allocatable :: torecv + integer :: no,nsend,nrecv + type(MPI_Status) :: status + integer :: icnt,isrc,idst,ierr + integer :: i,n + + ! Check overlap size + if (present(nover)) then + no=nover + if (no.gt.this%cfg%no) then + call warn('[lss share] Specified overlap is larger than that of cfg - reducing no') + no=this%cfg%no + else if (no.le.0) then + call die('[lss share] Specified overlap cannot be less or equal to zero') + end if + else + no=1 + end if + + ! Clean up ghost array + call this%resize_ghost(n=0); this%ng_=0 + + ! Share ghost particles in -x (no ghosts are sent here) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(1).lt.this%cfg%imin_+no) nsend=nsend+1 + end do + allocate(tosend(nsend)) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(1).lt.this%cfg%imin_+no) then + nsend=nsend+1 + tosend(nsend)=this%p(n) + if (this%cfg%xper.and.tosend(nsend)%ind(1).lt.this%cfg%imin+no) then + tosend(nsend)%pos(1)=tosend(nsend)%pos(1)+this%cfg%xL + tosend(nsend)%ind(1)=tosend(nsend)%ind(1)+this%cfg%nx + end if + end if + end do + nrecv=0 + call MPI_CART_SHIFT(this%cfg%comm,0,-1,isrc,idst,ierr) + call MPI_SENDRECV(nsend,1,MPI_INTEGER,idst,0,nrecv,1,MPI_INTEGER,isrc,0,this%cfg%comm,status,ierr) + allocate(torecv(nrecv)) + call MPI_SENDRECV(tosend,nsend,MPI_PART,idst,0,torecv,nrecv,MPI_PART,isrc,0,this%cfg%comm,status,ierr) + call this%resize_ghost(this%ng_+nrecv) + this%g(this%ng_+1:this%ng_+nrecv)=torecv + this%ng_=this%ng_+nrecv + if (allocated(tosend)) deallocate(tosend) + if (allocated(torecv)) deallocate(torecv) + + ! Share ghost particles in +x (no ghosts are sent here) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(1).gt.this%cfg%imax_-no) nsend=nsend+1 + end do + allocate(tosend(nsend)) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(1).gt.this%cfg%imax_-no) then + nsend=nsend+1 + tosend(nsend)=this%p(n) + if (this%cfg%xper.and.tosend(nsend)%ind(1).gt.this%cfg%imax-no) then + tosend(nsend)%pos(1)=tosend(nsend)%pos(1)-this%cfg%xL + tosend(nsend)%ind(1)=tosend(nsend)%ind(1)-this%cfg%nx + end if + end if + end do + nrecv=0 + call MPI_CART_SHIFT(this%cfg%comm,0,+1,isrc,idst,ierr) + call MPI_SENDRECV(nsend,1,MPI_INTEGER,idst,0,nrecv,1,MPI_INTEGER,isrc,0,this%cfg%comm,status,ierr) + allocate(torecv(nrecv)) + call MPI_SENDRECV(tosend,nsend,MPI_PART,idst,0,torecv,nrecv,MPI_PART,isrc,0,this%cfg%comm,status,ierr) + call this%resize_ghost(this%ng_+nrecv) + this%g(this%ng_+1:this%ng_+nrecv)=torecv + this%ng_=this%ng_+nrecv + if (allocated(tosend)) deallocate(tosend) + if (allocated(torecv)) deallocate(torecv) + + ! Share ghost particles in -y (ghosts need to be sent now) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(2).lt.this%cfg%jmin_+no) nsend=nsend+1 + end do + do n=1,this%ng_ + if (this%g(n)%ind(2).lt.this%cfg%jmin_+no) nsend=nsend+1 + end do + allocate(tosend(nsend)) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(2).lt.this%cfg%jmin_+no) then + nsend=nsend+1 + tosend(nsend)=this%p(n) + if (this%cfg%yper.and.tosend(nsend)%ind(2).lt.this%cfg%jmin+no) then + tosend(nsend)%pos(2)=tosend(nsend)%pos(2)+this%cfg%yL + tosend(nsend)%ind(2)=tosend(nsend)%ind(2)+this%cfg%ny + end if + end if + end do + do n=1,this%ng_ + if (this%g(n)%ind(2).lt.this%cfg%jmin_+no) then + nsend=nsend+1 + tosend(nsend)=this%g(n) + if (this%cfg%yper.and.tosend(nsend)%ind(2).lt.this%cfg%jmin+no) then + tosend(nsend)%pos(2)=tosend(nsend)%pos(2)+this%cfg%yL + tosend(nsend)%ind(2)=tosend(nsend)%ind(2)+this%cfg%ny + end if + end if + end do + nrecv=0 + call MPI_CART_SHIFT(this%cfg%comm,1,-1,isrc,idst,ierr) + call MPI_SENDRECV(nsend,1,MPI_INTEGER,idst,0,nrecv,1,MPI_INTEGER,isrc,0,this%cfg%comm,status,ierr) + allocate(torecv(nrecv)) + call MPI_SENDRECV(tosend,nsend,MPI_PART,idst,0,torecv,nrecv,MPI_PART,isrc,0,this%cfg%comm,status,ierr) + call this%resize_ghost(this%ng_+nrecv) + this%g(this%ng_+1:this%ng_+nrecv)=torecv + this%ng_=this%ng_+nrecv + if (allocated(tosend)) deallocate(tosend) + if (allocated(torecv)) deallocate(torecv) + + ! Share ghost particles in +y (ghosts need to be sent now - but not newly received ghosts!) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(2).gt.this%cfg%jmax_-no) nsend=nsend+1 + end do + do n=1,this%ng_-nrecv + if (this%g(n)%ind(2).gt.this%cfg%jmax_-no) nsend=nsend+1 + end do + allocate(tosend(nsend)) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(2).gt.this%cfg%jmax_-no) then + nsend=nsend+1 + tosend(nsend)=this%p(n) + if (this%cfg%yper.and.tosend(nsend)%ind(2).gt.this%cfg%jmax-no) then + tosend(nsend)%pos(2)=tosend(nsend)%pos(2)-this%cfg%yL + tosend(nsend)%ind(2)=tosend(nsend)%ind(2)-this%cfg%ny + end if + end if + end do + do n=1,this%ng_-nrecv + if (this%g(n)%ind(2).gt.this%cfg%jmax_-no) then + nsend=nsend+1 + tosend(nsend)=this%g(n) + if (this%cfg%yper.and.tosend(nsend)%ind(2).gt.this%cfg%jmax-no) then + tosend(nsend)%pos(2)=tosend(nsend)%pos(2)-this%cfg%yL + tosend(nsend)%ind(2)=tosend(nsend)%ind(2)-this%cfg%ny + end if + end if + end do + nrecv=0 + call MPI_CART_SHIFT(this%cfg%comm,1,+1,isrc,idst,ierr) + call MPI_SENDRECV(nsend,1,MPI_INTEGER,idst,0,nrecv,1,MPI_INTEGER,isrc,0,this%cfg%comm,status,ierr) + allocate(torecv(nrecv)) + call MPI_SENDRECV(tosend,nsend,MPI_PART,idst,0,torecv,nrecv,MPI_PART,isrc,0,this%cfg%comm,status,ierr) + call this%resize_ghost(this%ng_+nrecv) + this%g(this%ng_+1:this%ng_+nrecv)=torecv + this%ng_=this%ng_+nrecv + if (allocated(tosend)) deallocate(tosend) + if (allocated(torecv)) deallocate(torecv) + + ! Share ghost particles in -z (ghosts need to be sent now) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(3).lt.this%cfg%kmin_+no) nsend=nsend+1 + end do + do n=1,this%ng_ + if (this%g(n)%ind(3).lt.this%cfg%kmin_+no) nsend=nsend+1 + end do + allocate(tosend(nsend)) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(3).lt.this%cfg%kmin_+no) then + nsend=nsend+1 + tosend(nsend)=this%p(n) + if (this%cfg%zper.and.tosend(nsend)%ind(3).lt.this%cfg%kmin+no) then + tosend(nsend)%pos(3)=tosend(nsend)%pos(3)+this%cfg%zL + tosend(nsend)%ind(3)=tosend(nsend)%ind(3)+this%cfg%nz + end if + end if + end do + do n=1,this%ng_ + if (this%g(n)%ind(3).lt.this%cfg%kmin_+no) then + nsend=nsend+1 + tosend(nsend)=this%g(n) + if (this%cfg%zper.and.tosend(nsend)%ind(3).lt.this%cfg%kmin+no) then + tosend(nsend)%pos(3)=tosend(nsend)%pos(3)+this%cfg%zL + tosend(nsend)%ind(3)=tosend(nsend)%ind(3)+this%cfg%nz + end if + end if + end do + nrecv=0 + call MPI_CART_SHIFT(this%cfg%comm,2,-1,isrc,idst,ierr) + call MPI_SENDRECV(nsend,1,MPI_INTEGER,idst,0,nrecv,1,MPI_INTEGER,isrc,0,this%cfg%comm,status,ierr) + allocate(torecv(nrecv)) + call MPI_SENDRECV(tosend,nsend,MPI_PART,idst,0,torecv,nrecv,MPI_PART,isrc,0,this%cfg%comm,status,ierr) + call this%resize_ghost(this%ng_+nrecv) + this%g(this%ng_+1:this%ng_+nrecv)=torecv + this%ng_=this%ng_+nrecv + if (allocated(tosend)) deallocate(tosend) + if (allocated(torecv)) deallocate(torecv) + + ! Share ghost particles in +z (ghosts need to be sent now - but not newly received ghosts!) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(3).gt.this%cfg%kmax_-no) nsend=nsend+1 + end do + do n=1,this%ng_-nrecv + if (this%g(n)%ind(3).gt.this%cfg%kmax_-no) nsend=nsend+1 + end do + allocate(tosend(nsend)) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(3).gt.this%cfg%kmax_-no) then + nsend=nsend+1 + tosend(nsend)=this%p(n) + if (this%cfg%zper.and.tosend(nsend)%ind(3).gt.this%cfg%kmax-no) then + tosend(nsend)%pos(3)=tosend(nsend)%pos(3)-this%cfg%zL + tosend(nsend)%ind(3)=tosend(nsend)%ind(3)-this%cfg%nz + end if + end if + end do + do n=1,this%ng_-nrecv + if (this%g(n)%ind(3).gt.this%cfg%kmax_-no) then + nsend=nsend+1 + tosend(nsend)=this%g(n) + if (this%cfg%zper.and.tosend(nsend)%ind(3).gt.this%cfg%kmax-no) then + tosend(nsend)%pos(3)=tosend(nsend)%pos(3)-this%cfg%zL + tosend(nsend)%ind(3)=tosend(nsend)%ind(3)-this%cfg%nz + end if + end if + end do + nrecv=0 + call MPI_CART_SHIFT(this%cfg%comm,2,+1,isrc,idst,ierr) + call MPI_SENDRECV(nsend,1,MPI_INTEGER,idst,0,nrecv,1,MPI_INTEGER,isrc,0,this%cfg%comm,status,ierr) + allocate(torecv(nrecv)) + call MPI_SENDRECV(tosend,nsend,MPI_PART,idst,0,torecv,nrecv,MPI_PART,isrc,0,this%cfg%comm,status,ierr) + call this%resize_ghost(this%ng_+nrecv) + this%g(this%ng_+1:this%ng_+nrecv)=torecv + this%ng_=this%ng_+nrecv + if (allocated(tosend)) deallocate(tosend) + if (allocated(torecv)) deallocate(torecv) + + end subroutine share + + + !> Synchronize particle arrays across processors + subroutine sync(this) + use mpi_f08 + implicit none + class(lss), intent(inout) :: this + integer, dimension(0:this%cfg%nproc-1) :: nsend_proc,nrecv_proc + integer, dimension(0:this%cfg%nproc-1) :: nsend_disp,nrecv_disp + integer :: n,prank,ierr + type(part), dimension(:), allocatable :: buf_send + ! Recycle first to minimize communication load + call this%recycle() + ! Prepare information about what to send + nsend_proc=0 + do n=1,this%np_ + prank=this%cfg%get_rank(this%p(n)%ind) + nsend_proc(prank)=nsend_proc(prank)+1 + end do + nsend_proc(this%cfg%rank)=0 + ! Inform processors of what they will receive + call MPI_ALLtoALL(nsend_proc,1,MPI_INTEGER,nrecv_proc,1,MPI_INTEGER,this%cfg%comm,ierr) + ! Prepare displacements for all-to-all + nsend_disp(0)=0 + nrecv_disp(0)=this%np_ !< Directly add particles at the end of main array + do n=1,this%cfg%nproc-1 + nsend_disp(n)=nsend_disp(n-1)+nsend_proc(n-1) + nrecv_disp(n)=nrecv_disp(n-1)+nrecv_proc(n-1) + end do + ! Allocate buffer to send particles + allocate(buf_send(sum(nsend_proc))) + ! Pack the particles in the send buffer + nsend_proc=0 + do n=1,this%np_ + ! Get the rank + prank=this%cfg%get_rank(this%p(n)%ind) + ! Skip particles still inside + if (prank.eq.this%cfg%rank) cycle + ! Pack up for sending + nsend_proc(prank)=nsend_proc(prank)+1 + buf_send(nsend_disp(prank)+nsend_proc(prank))=this%p(n) + ! Flag particle for removal + this%p(n)%flag=1 + end do + ! Allocate buffer for receiving particles + call this%resize(this%np_+sum(nrecv_proc)) + ! Perform communication + call MPI_ALLtoALLv(buf_send,nsend_proc,nsend_disp,MPI_PART,this%p,nrecv_proc,nrecv_disp,MPI_PART,this%cfg%comm,ierr) + ! Deallocate buffer + deallocate(buf_send) + ! Recycle to remove duplicate particles + call this%recycle() + end subroutine sync + + + !> Adaptation of particle array size + subroutine resize(this,n) + implicit none + class(lss), intent(inout) :: this + integer, intent(in) :: n + type(part), dimension(:), allocatable :: tmp + integer :: size_now,size_new + ! Resize particle array to size n + if (.not.allocated(this%p)) then + ! Allocate directly to size n + allocate(this%p(n)) + this%p(1:n)%flag=1 + else + ! Update from a non-zero size to another non-zero size + size_now=size(this%p,dim=1) + if (n.gt.size_now) then + size_new=max(n,int(real(size_now,WP)*coeff_up)) + allocate(tmp(size_new)) + tmp(1:size_now)=this%p + tmp(size_now+1:)%flag=1 + call move_alloc(tmp,this%p) + else if (n.lt.int(real(size_now,WP)*coeff_dn)) then + allocate(tmp(n)) + tmp(1:n)=this%p(1:n) + call move_alloc(tmp,this%p) + end if + end if + end subroutine resize + + + !> Adaptation of ghost array size + subroutine resize_ghost(this,n) + implicit none + class(lss), intent(inout) :: this + integer, intent(in) :: n + type(part), dimension(:), allocatable :: tmp + integer :: size_now,size_new + ! Resize ghost array to size n + if (.not.allocated(this%g)) then + ! Allocate directly to size n + allocate(this%g(n)) + this%g(1:n)%flag=1 + else + ! Update from a non-zero size to another non-zero size + size_now=size(this%g,dim=1) + if (n.gt.size_now) then + size_new=max(n,int(real(size_now,WP)*coeff_up)) + allocate(tmp(size_new)) + tmp(1:size_now)=this%g + tmp(size_now+1:)%flag=1 + call move_alloc(tmp,this%g) + else if (n.lt.int(real(size_now,WP)*coeff_dn)) then + allocate(tmp(n)) + tmp(1:n)=this%g(1:n) + call move_alloc(tmp,this%g) + end if + end if + end subroutine resize_ghost + + + !> Clean-up of particle array by removing flag=1 particles + subroutine recycle(this) + implicit none + class(lss), intent(inout) :: this + integer :: new_size,i,ierr + ! Compact all active particles at the beginning of the array + new_size=0 + if (allocated(this%p)) then + do i=1,size(this%p,dim=1) + if (this%p(i)%flag.ne.1) then + new_size=new_size+1 + if (i.ne.new_size) then + this%p(new_size)=this%p(i) + this%p(i)%flag=1 + end if + end if + end do + end if + ! Resize to new size + call this%resize(new_size) + ! Update number of particles + this%np_=new_size + call MPI_ALLGATHER(this%np_,1,MPI_INTEGER,this%np_proc,1,MPI_INTEGER,this%cfg%comm,ierr) + this%np=sum(this%np_proc) + end subroutine recycle + + + !> Parallel write particles to file + subroutine write(this,filename) + use mpi_f08 + use messager, only: die + use parallel, only: info_mpiio + implicit none + class(lss), intent(inout) :: this + character(len=*), intent(in) :: filename + type(MPI_File) :: ifile + type(MPI_Status):: status + integer(kind=MPI_OFFSET_KIND) :: offset + integer :: i,ierr,iunit + + ! Root serial-writes the file header + if (this%cfg%amRoot) then + ! Open the file + open(newunit=iunit,file=trim(filename),form='unformatted',status='replace',access='stream',iostat=ierr) + if (ierr.ne.0) call die('[lss write] Problem encountered while serial-opening data file: '//trim(filename)) + ! Number of particles and particle object size + write(iunit) this%np,MPI_PART_SIZE + ! Done with the header + close(iunit) + end if + + ! The rest is done in parallel + call MPI_FILE_OPEN(this%cfg%comm,trim(filename),IOR(MPI_MODE_WRONLY,MPI_MODE_APPEND),info_mpiio,ifile,ierr) + if (ierr.ne.0) call die('[lss write] Problem encountered while parallel-opening data file: '//trim(filename)) + + ! Get current position + call MPI_FILE_GET_POSITION(ifile,offset,ierr) + + ! Compute the offset and write + do i=1,this%cfg%rank + offset=offset+int(this%np_proc(i),MPI_OFFSET_KIND)*int(MPI_PART_SIZE,MPI_OFFSET_KIND) + end do + if (this%np_.gt.0) call MPI_FILE_WRITE_AT(ifile,offset,this%p,this%np_,MPI_PART,status,ierr) + + ! Close the file + call MPI_FILE_CLOSE(ifile,ierr) + + ! Log/screen output + logging: block + use, intrinsic :: iso_fortran_env, only: output_unit + use param, only: verbose + use messager, only: log + use string, only: str_long + character(len=str_long) :: message + if (this%cfg%amRoot) then + write(message,'("[lss write] Wrote ",i0," particles to file [",a,"] on partitioned grid [",a,"]")') this%np,trim(filename),trim(this%cfg%name) + if (verbose.gt.2) write(output_unit,'(a)') trim(message) + if (verbose.gt.1) call log(message) + end if + end block logging + + end subroutine write + + + !> Parallel read particles to file + subroutine read(this,filename) + use mpi_f08 + use messager, only: die + use parallel, only: info_mpiio + implicit none + class(lss), intent(inout) :: this + character(len=*), intent(in) :: filename + type(MPI_File) :: ifile + type(MPI_Status):: status + integer(kind=MPI_OFFSET_KIND) :: offset,header_offset + integer :: i,j,ierr,npadd,psize,nchunk,cnt + integer, dimension(:,:), allocatable :: ppp + + ! First open the file in parallel + call MPI_FILE_OPEN(this%cfg%comm,trim(filename),MPI_MODE_RDONLY,info_mpiio,ifile,ierr) + if (ierr.ne.0) call die('[lss read] Problem encountered while reading data file: '//trim(filename)) + + ! Read file header first + call MPI_FILE_READ_ALL(ifile,npadd,1,MPI_INTEGER,status,ierr) + call MPI_FILE_READ_ALL(ifile,psize,1,MPI_INTEGER,status,ierr) + + ! Remember current position + call MPI_FILE_GET_POSITION(ifile,header_offset,ierr) + + ! Check compatibility of particle type + if (psize.ne.MPI_PART_SIZE) call die('[lss read] Particle type unreadable') + + ! Naively share reading task among all processors + nchunk=int(npadd/(this%cfg%nproc*part_chunk_size))+1 + allocate(ppp(this%cfg%nproc,nchunk)) + ppp=int(npadd/(this%cfg%nproc*nchunk)) + cnt=0 + out:do j=1,nchunk + do i=1,this%cfg%nproc + cnt=cnt+1 + if (cnt.gt.mod(npadd,this%cfg%nproc*nchunk)) exit out + ppp(i,j)=ppp(i,j)+1 + end do + end do out + + ! Read by chunk + do j=1,nchunk + ! Find offset + offset=header_offset+int(MPI_PART_SIZE,MPI_OFFSET_KIND)*int(sum(ppp(1:this%cfg%rank,:))+sum(ppp(this%cfg%rank+1,1:j-1)),MPI_OFFSET_KIND) + ! Resize particle array + call this%resize(this%np_+ppp(this%cfg%rank+1,j)) + ! Read this file + call MPI_FILE_READ_AT(ifile,offset,this%p(this%np_+1:this%np_+ppp(this%cfg%rank+1,j)),ppp(this%cfg%rank+1,j),MPI_PART,status,ierr) + ! Most general case: relocate every droplet + do i=this%np_+1,this%np_+ppp(this%cfg%rank+1,j) + this%p(i)%ind=this%cfg%get_ijk_global(this%p(i)%pos,this%p(i)%ind) + end do + ! Exchange all that + call this%sync() + end do + + ! Close the file + call MPI_FILE_CLOSE(ifile,ierr) + + ! Log/screen output + logging: block + use, intrinsic :: iso_fortran_env, only: output_unit + use param, only: verbose + use messager, only: log + use string, only: str_long + character(len=str_long) :: message + if (this%cfg%amRoot) then + write(message,'("[lss read] Read ",i0," particles from file [",a,"] on partitioned grid [",a,"]")') npadd,trim(filename),trim(this%cfg%name) + if (verbose.gt.2) write(output_unit,'(a)') trim(message) + if (verbose.gt.1) call log(message) + end if + end block logging + + end subroutine read + + +end module lss_class diff --git a/examples/plate_with_hole/src/lss_class_working.f90 b/examples/plate_with_hole/src/lss_class_working.f90 new file mode 100644 index 000000000..f3a66b852 --- /dev/null +++ b/examples/plate_with_hole/src/lss_class_working.f90 @@ -0,0 +1,1637 @@ +!> Lagrangian solid solver object +!> Implements peridynamics equations +module lss_class + use precision, only: WP + use string, only: str_medium + use config_class, only: config + use mpi_f08, only: MPI_Datatype,MPI_INTEGER8,MPI_INTEGER,MPI_DOUBLE_PRECISION + implicit none + private + + + ! Expose type/constructor/methods + public :: lss + + + !> Memory adaptation parameter + real(WP), parameter :: coeff_up=1.3_WP !< Particle array size increase factor + real(WP), parameter :: coeff_dn=0.7_WP !< Particle array size decrease factor + + + !> I/O chunk size to read at a time + integer, parameter :: part_chunk_size=1000 !< Read 1000 particles at a time before redistributing + + + !> Maximum number of bonds per particle + integer, parameter, public :: max_bond=400 !< Assumes something like a 7x7x7 stencil in 3D + + + !> Bonded solid particle definition + type :: part + !> MPI_DOUBLE_PRECISION data + real(WP) :: mw !< Weighted volume + real(WP) :: dil !< Element dilatation + real(WP) :: ste !< Element dilatation + real(WP) :: vol !< Particle volume + real(WP), dimension(max_bond) :: dbond !< Length of initial bonds + real(WP), dimension(3) :: pos !< Particle center coordinates + real(WP), dimension(3) :: vel !< Velocity of particle + real(WP), dimension(3) :: Abond !< Bond acceleration for particle + real(WP), dimension(3) :: Afluid !< Fluid acceleration for particle + real(WP), dimension(3) :: gd !< Dilitation corrections + real(WP), dimension(3) :: gb !< Shear corrections + !> MPI_INTEGER data + integer :: id !< ID the object is associated with + integer :: i !< Unique index of particle (assumed >0) + integer :: nbond !< Number of initial bonds + integer, dimension(max_bond) :: ibond !< Indices of initially bonded particles (0 values ignored) + integer , dimension(3) :: ind !< Index of cell containing particle center + integer :: flag !< Control parameter (0=normal, 1=done->will be removed) + end type part + !> Number of blocks, block length, and block types in a particle + integer, parameter :: part_nblock=2 + integer , dimension(part_nblock) :: part_lblock=[22+max_bond,7+max_bond] + type(MPI_Datatype), dimension(part_nblock) :: part_tblock=[MPI_DOUBLE_PRECISION,MPI_INTEGER] + !> MPI_PART derived datatype and size + type(MPI_Datatype) :: MPI_PART + integer :: MPI_PART_SIZE + + + !> Lagrangian solid solver object definition + type :: lss + + ! This config is used for parallelization and for calculating bond/collision forces + class(config), pointer :: cfg + + ! This is the name of the solver + character(len=str_medium) :: name='UNNAMED_LSS' + + ! Solid material properties + real(WP) :: elastic_modulus !< Elastic modulus of the material + real(WP) :: poisson_ratio !< Poisson's ratio of the material + real(WP) :: rho !< Density of the material + real(WP) :: crit_energy !< Critical energy release + + ! Bonding parameters + real(WP) :: delta !< Bonding horizon (distance) + real(WP) :: min_dist !< Minimum bonding distance + integer :: nb !< Cell-based horizon + + ! Global and local particle data + integer :: np !< Global number of particles + integer :: np_ !< Local number of particles + integer, dimension(:), allocatable :: np_proc !< Number of particles on each processor + type(part), dimension(:), allocatable :: p !< Array of particles of type part + + ! Overlap particle (i.e., ghost) data + integer :: ng_ !< Local number of ghosts + type(part), dimension(:), allocatable :: g !< Array of ghosts of type part + + ! Gravitational acceleration + real(WP), dimension(3) :: gravity=[0.0_WP,0.0_WP,0.0_WP] + + ! Solid volume fraction and momentum + real(WP), dimension(:,:,:), allocatable :: VF !< Volume fraction, cell-centered + real(WP), dimension(:,:,:), allocatable :: VFU !< Solid velocity, U-face + real(WP), dimension(:,:,:), allocatable :: VFV !< Solid velocity, V-face + real(WP), dimension(:,:,:), allocatable :: VFW !< Solid velocity, W-face + + ! CFL numbers + real(WP) :: CFLp_x,CFLp_y,CFLp_z,CFLp_a + + ! Number of substeps for time integrator + real(WP) :: nstep=1 + + ! Monitoring info + real(WP) :: Umin,Umax,Umean !< U velocity info + real(WP) :: Vmin,Vmax,Vmean !< V velocity info + real(WP) :: Wmin,Wmax,Wmean !< W velocity info + real(WP) :: VFmax !< Volume fraction info + real(WP), dimension(3) :: ibmForce !< Total force due to IBM + integer :: np_out !< Number of particles leaving the domain + + contains + procedure :: bond_init !< Setup initial interparticle bonds + procedure :: get_bond_force !< Compute interparticle bond force + procedure :: advance !< Step forward the particle ODEs + procedure :: get_cfl !< Calculate maximum CFL + procedure :: get_max !< Extract various monitoring data + procedure :: update_partmesh !< Update a partmesh object using current particles + procedure :: share !< Share particles across interprocessor boundaries + procedure :: sync !< Synchronize particles across interprocessor boundaries + procedure :: resize !< Resize particle array to given size + procedure :: resize_ghost !< Resize ghost array to given size + procedure :: recycle !< Recycle particle array by removing flagged particles + procedure :: write !< Parallel write particles to file + procedure :: read !< Parallel read particles from file + procedure :: update_VF !< Compute volume fraction + procedure :: get_delta !< Compute regularized delta function + procedure :: interpolate !< Interpolation routine from mesh=>marker + procedure :: extrapolate !< Extrapolation routine from marker=>mesh + procedure :: stretch + end type lss + + + !> Declare lss constructor + interface lss + procedure constructor + end interface lss + +contains + + + ! Quasi-Gaussian weighting function - h is the cut-off + real(WP) function wgauss(d,h) + implicit none + real(WP), intent(in) :: d,h + real(WP), parameter :: coeff=2.6_WP + real(WP) :: hh + hh=coeff*h + if (d.ge.hh) then + wgauss=0.0_WP + else + wgauss=(1.0_WP+4.0_WP*d/hh)*(1.0_WP-d/hh)**4 + end if + end function wgauss + + + !> Default constructor for Lagrangian solid solver + function constructor(cfg,name) result(self) + implicit none + type(lss) :: self + class(config), target, intent(in) :: cfg + character(len=*), optional :: name + integer :: i,j,k + + ! Set the name for the solver + if (present(name)) self%name=trim(adjustl(name)) + + ! Point to pgrid object + self%cfg=>cfg + + ! Set default bonding horizon based on underlying mesh + self%delta=self%cfg%min_meshsize + self%nb=1 + self%min_dist=huge(1.0_WP) + + ! Allocate variables + allocate(self%np_proc(1:self%cfg%nproc)); self%np_proc=0 + self%np_=0; self%np=0 + call self%resize(0) + + ! Initialize MPI derived datatype for a particle + call prepare_mpi_part() + + ! Allocate VF array on cfg mesh + allocate(self%VF(self%cfg%imino_:self%cfg%imaxo_,self%cfg%jmino_:self%cfg%jmaxo_,self%cfg%kmino_:self%cfg%kmaxo_)); self%VF=0.0_WP + allocate(self%VFU(self%cfg%imino_:self%cfg%imaxo_,self%cfg%jmino_:self%cfg%jmaxo_,self%cfg%kmino_:self%cfg%kmaxo_)); self%VFU=0.0_WP + allocate(self%VFV(self%cfg%imino_:self%cfg%imaxo_,self%cfg%jmino_:self%cfg%jmaxo_,self%cfg%kmino_:self%cfg%kmaxo_)); self%VFV=0.0_WP + allocate(self%VFW(self%cfg%imino_:self%cfg%imaxo_,self%cfg%jmino_:self%cfg%jmaxo_,self%cfg%kmino_:self%cfg%kmaxo_)); self%VFW=0.0_WP + + ! Log/screen output + logging: block + use, intrinsic :: iso_fortran_env, only: output_unit + use param, only: verbose + use messager, only: log + use string, only: str_long + character(len=str_long) :: message + if (self%cfg%amRoot) then + write(message,'("LSS object [",a,"] on partitioned grid [",a,"]")') trim(self%name),trim(self%cfg%name) + if (verbose.gt.1) write(output_unit,'(a)') trim(message) + if (verbose.gt.0) call log(message) + end if + end block logging + + end function constructor + + + !> Initialize bond force between particles + subroutine bond_init(this) + use messager, only: die + implicit none + class(lss), intent(inout) :: this + integer, dimension(:,:,:), allocatable :: npic !< Number of particle in cell + integer, dimension(:,:,:,:), allocatable :: ipic !< Index of particle in cell + + ! Communicate particles in ghost cells + call this%share() + + ! We can now assemble particle-in-cell information + pic_prep: block + use mpi_f08 + integer :: i,ip,jp,kp,ierr + integer :: mymax_npic,max_npic + + ! Allocate number of particle in cell + allocate(npic(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)); npic=0 + + ! Count particles and ghosts per cell + do i=1,this%np_ + ip=this%p(i)%ind(1); jp=this%p(i)%ind(2); kp=this%p(i)%ind(3) + npic(ip,jp,kp)=npic(ip,jp,kp)+1 + end do + do i=1,this%ng_ + ip=this%g(i)%ind(1); jp=this%g(i)%ind(2); kp=this%g(i)%ind(3) + npic(ip,jp,kp)=npic(ip,jp,kp)+1 + end do + + ! Get maximum number of particle in cell + mymax_npic=maxval(npic); call MPI_ALLREDUCE(mymax_npic,max_npic,1,MPI_INTEGER,MPI_MAX,this%cfg%comm,ierr) + + ! Allocate pic map + allocate(ipic(1:max_npic,this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)); ipic=0 + + ! Assemble pic map + npic=0 + do i=1,this%np_ + ip=this%p(i)%ind(1); jp=this%p(i)%ind(2); kp=this%p(i)%ind(3) + npic(ip,jp,kp)=npic(ip,jp,kp)+1 + ipic(npic(ip,jp,kp),ip,jp,kp)=+i + end do + do i=1,this%ng_ + ip=this%g(i)%ind(1); jp=this%g(i)%ind(2); kp=this%g(i)%ind(3) + npic(ip,jp,kp)=npic(ip,jp,kp)+1 + ipic(npic(ip,jp,kp),ip,jp,kp)=-i + end do + + end block pic_prep + + ! Establish initial bonds + create_bonds: block + use mpi_f08, only: MPI_ALLREDUCE,MPI_MIN,MPI_IN_PLACE + use parallel, only: MPI_REAL_WP + use mathtools, only: Pi + integer :: i,j,k,n1,nn,n2,ierr + type(part) :: p1,p2 + real(WP), dimension(3) :: rpos + real(WP) :: dist + ! Reset minimum bond distance + this%min_dist=huge(1.0_WP) + ! Loop over particles + do n1=1,this%np_ + ! Create copy of our particle + p1=this%p(n1) + ! Zero out weighted volume + p1%mw=0.0_WP + ! Zero out bonds + p1%ibond=0 + p1%nbond=0 + ! Loop over neighbor cells + do k=p1%ind(3)-this%nb,p1%ind(3)+this%nb + do j=p1%ind(2)-this%nb,p1%ind(2)+this%nb + do i=p1%ind(1)-this%nb,p1%ind(1)+this%nb + ! Loop over particles in that cell + do nn=1,npic(i,j,k) + ! Create copy of our neighbor + n2=ipic(nn,i,j,k) + if (n2.gt.0) then + p2=this%p(+n2) + else if (n2.lt.0) then + p2=this%g(-n2) + end if + ! Cannot self-bond + if (p1%i.eq.p2%i) cycle + ! Cannot bond with different id except <=0 (<=0 bonds with everyone) + if (p1%id.ne.p2%id.and.p1%id.ge.0.and.p2%id.ge.0) cycle + ! Check interparticle distance + rpos=p2%pos-p1%pos + dist=sqrt(dot_product(rpos,rpos)) + if (dist.lt.this%delta) then + ! This particle is in horizon, create a bond + p1%nbond=p1%nbond+1 + if (p1%nbond.gt.max_bond) call die('[lss_class bond_init] Number of detected bonds is larger than max allowed') + p1%ibond(p1%nbond)=p2%i + p1%dbond(p1%nbond)=dist + ! Increment weighted volume + p1%mw=p1%mw+wgauss(dist,this%delta)*dist**2*p1%vol + ! Determine minimum bond distance + this%min_dist=min(this%min_dist,dist) + end if + end do + end do + end do + end do + ! Zero out initial dilatation + p1%dil=0.0_WP + ! Copy back the particle + this%p(n1)=p1 + end do + ! Get global minimum + call MPI_ALLREDUCE(MPI_IN_PLACE,this%min_dist,1,MPI_REAL_WP,MPI_MIN,this%cfg%comm,ierr) + end block create_bonds + + ! Clean up + if (allocated(npic)) deallocate(npic) + if (allocated(ipic)) deallocate(ipic) + + end subroutine bond_init + + + !> Calculate bond force between particles + subroutine get_bond_force(this) + implicit none + class(lss), intent(inout) :: this + integer, dimension(:,:,:), allocatable :: npic !< Number of particle in cell + integer, dimension(:,:,:,:), allocatable :: ipic !< Index of particle in cell + logical :: is2D + + ! Need to modify parameters in 2D + is2D=this%cfg%nx.eq.1.or.this%cfg%ny.eq.1.or.this%cfg%nz.eq.1 + + ! Communicate particles in ghost cells + call this%share() + + ! We can now assemble particle-in-cell information + pic_prep: block + use mpi_f08 + integer :: i,ip,jp,kp,ierr + integer :: mymax_npic,max_npic + + ! Allocate number of particle in cell + allocate(npic(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)); npic=0 + + ! Count particles and ghosts per cell + do i=1,this%np_ + ip=this%p(i)%ind(1); jp=this%p(i)%ind(2); kp=this%p(i)%ind(3) + npic(ip,jp,kp)=npic(ip,jp,kp)+1 + end do + do i=1,this%ng_ + ip=this%g(i)%ind(1); jp=this%g(i)%ind(2); kp=this%g(i)%ind(3) + npic(ip,jp,kp)=npic(ip,jp,kp)+1 + end do + + ! Get maximum number of particle in cell + mymax_npic=maxval(npic); call MPI_ALLREDUCE(mymax_npic,max_npic,1,MPI_INTEGER,MPI_MAX,this%cfg%comm,ierr) + + ! Allocate pic map + allocate(ipic(1:max_npic,this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)); ipic=0 + + ! Assemble pic map + npic=0 + do i=1,this%np_ + ip=this%p(i)%ind(1); jp=this%p(i)%ind(2); kp=this%p(i)%ind(3) + npic(ip,jp,kp)=npic(ip,jp,kp)+1 + ipic(npic(ip,jp,kp),ip,jp,kp)=+i + end do + do i=1,this%ng_ + ip=this%g(i)%ind(1); jp=this%g(i)%ind(2); kp=this%g(i)%ind(3) + npic(ip,jp,kp)=npic(ip,jp,kp)+1 + ipic(npic(ip,jp,kp),ip,jp,kp)=-i + end do + + end block pic_prep + + ! Update weighted volume and dilatation + update_weighted_vol_and_dilatation: block + integer :: i,j,k,n1,nn,n2 + type(part) :: p1,p2 + integer :: nb,nbond + real(WP), dimension(3) :: rpos, Gd_vec + real(WP) :: dist, Gd_mag + ! Loop over particles + do n1=1,this%np_ + ! Create copy of our particle + p1=this%p(n1) + ! Zero out weighted volume and dilatation + p1%mw=0.0_WP + p1%dil=0.0_WP + ! Loop over neighbor cells + do k=p1%ind(3)-this%nb,p1%ind(3)+this%nb + do j=p1%ind(2)-this%nb,p1%ind(2)+this%nb + do i=p1%ind(1)-this%nb,p1%ind(1)+this%nb + ! Loop over particles in that cell + do nn=1,npic(i,j,k) + ! Create copy of our neighbor + n2=ipic(nn,i,j,k) + if (n2.gt.0) then + p2=this%p(+n2) + else if (n2.lt.0) then + p2=this%g(-n2) + end if + ! Check if a bond exists + do nb=1,max_bond + if (p1%ibond(nb).eq.p2%i) then + ! Increment weighted volume + p1%mw=p1%mw+wgauss(p1%dbond(nb),this%delta)*p1%dbond(nb)**2*p2%vol + ! Get current distance + rpos=p2%pos-p1%pos + dist=sqrt(dot_product(rpos,rpos)) + ! compute average G correction for dilitation + Gd_vec = (p2%gd + p1%gd)/2.0_WP + + Gd_mag = sqrt(1.0_WP/(((rpos(1)/dist)/Gd_vec(1))**2 + ((rpos(2)/dist)/Gd_vec(2))**2 + ((rpos(3)/dist)/Gd_vec(3))**2 )) + ! Increment dilatation + p1%dil=p1%dil+wgauss(p1%dbond(nb),this%delta)*p1%dbond(nb)*(dist-p1%dbond(nb))*p2%vol*Gd_mag + end if + end do + end do + end do + end do + end do + ! Rescale dilatation + if (p1%mw.gt.epsilon(1.0_WP)) then + if (is2D) then + ! 2D plane strain + p1%dil=p1%dil*2.0_WP/p1%mw + else + ! 3D + p1%dil=p1%dil*3.0_WP/p1%mw + end if + else + p1%dil=0.0_WP + end if + ! Copy back the particle + this%p(n1)=p1 + end do + end block update_weighted_vol_and_dilatation + + ! Re-communicate particles in ghost cells to update dil and mw + call this%share() + + ! Update bond force, including collision force, and SED + update_bond_force: block + use mpi_f08, only: MPI_ALLREDUCE,MPI_MIN,MPI_IN_PLACE + use parallel, only: MPI_REAL_WP + use mathtools, only: Pi + integer :: i,j,k,n1,nn,n2,ierr + type(part) :: p1,p2 + real(WP), dimension(3) :: rpos,t12,t21,Gd_vec + real(WP) :: dist,beta,alpha,ed,t,Gd_mag + real(WP) :: stretch,max_stretch,mu,kk + real(WP) :: nc,rc,kc + integer :: nb,nbond + logical :: found_bond + ! Recompute a few physical parameters + mu=this%elastic_modulus/(2.0_WP+2.0_WP*this%poisson_ratio) + kk=this%elastic_modulus/(3.0_WP-6.0_WP*this%poisson_ratio) + if (is2D) then + if (this%cfg%nx.eq.1) t=this%cfg%xL + if (this%cfg%ny.eq.1) t=this%cfg%yL + if (this%cfg%nz.eq.1) t=this%cfg%zL + max_stretch=sqrt(this%crit_energy/((6.0_WP*mu/Pi+16.0_WP/(9.0_WP*Pi**2)*(kk-2.0_WP*mu))*this%delta)) + kc=15.0_WP*48.0_WP*this%elastic_modulus/(Pi*5.0_WP*t*this%delta**3) + else + max_stretch=sqrt(this%crit_energy/((3.0_WP*mu+(kk-5.0_WP*mu/3.0_WP)*0.75_WP**4)*this%delta)) + kc=15.0_WP*12.0_WP*this%elastic_modulus/(Pi*this%delta**4) + end if + nc=1.0_WP + this%min_dist=huge(1.0_WP) + ! Loop over particles + do n1=1,this%np_ + ! Particles marked 0 do not update their forces + if (this%p(n1)%id.eq.0) cycle + ! Create copy of our particle + p1=this%p(n1) + ! Zero out bond force + p1%Abond=0.0_WP + ! Loop over neighbor cells + do k=p1%ind(3)-this%nb,p1%ind(3)+this%nb + do j=p1%ind(2)-this%nb,p1%ind(2)+this%nb + do i=p1%ind(1)-this%nb,p1%ind(1)+this%nb + ! Loop over particles in that cell + do nn=1,npic(i,j,k) + ! Create copy of our neighbor + n2=ipic(nn,i,j,k) + if (n2.gt.0) then + p2=this%p(+n2) + else if (n2.lt.0) then + p2=this%g(-n2) + end if + ! Current distance + rpos=p2%pos-p1%pos + dist=sqrt(dot_product(rpos,rpos)) + ! Check if a bond exists + found_bond=.false. + do nb=1,max_bond + if (p1%ibond(nb).eq.p2%i) then + ! Check for breakage first + stretch=(dist-p1%dbond(nb))/p1%dbond(nb) + if (stretch.gt.max_stretch) then + ! Remove the bond and flag as surface particle + p1%ibond(nb)=0 + p1%dbond(nb)=0.0_WP + cycle + end if + ! Particle 1 + if (is2D) then + ! 2D plane strain + beta = 2.0_WP * kk * p1%dil + alpha = 8.0_WP * mu / p1%mw + ed = dist - p1%dbond(nb) * (1.0_WP + p1%dil / 2.0_WP) + else + ! 3D + beta = 3.0_WP * kk * p1%dil + alpha = 15.0_WP * mu / p1%mw + ed = dist - p1%dbond(nb) * (1.0_WP + p1%dil / 3.0_WP) + end if + ! Force density 1->2 + ! t12=+wgauss(p1%dbond(nb),this%delta)*(beta/p1%mw*p1%dbond(nb)+alpha*ed)*rpos/dist + ! t12=+wgauss(p1%dbond(nb),this%delta)*((3.0_WP*kk - 15.0_WP*mu/3.0_WP)*(p1%dil*p1%dbond(nb)/p1%mw) + 15*mu*dist/p1%mw)*rpos/dist + Gd_vec = (p2%gd + p1%gd)/2.0_WP + + Gd_mag = sqrt(1.0_WP/(((rpos(1)/dist)/Gd_vec(1))**2 + ((rpos(2)/dist)/Gd_vec(2))**2 + ((rpos(3)/dist)/Gd_vec(3))**2 )) + t12=+wgauss(p1%dbond(nb),this%delta)*((3.0_WP*kk - 15.0_WP*mu/3.0_WP)*(Gd_mag*p1%dil*p1%dbond(nb)/p1%mw) + (15.0_WP*mu/p1%mw)*(dist - p1%dbond(nb)) )*rpos/dist + ! Particle 2 + if (is2D) then + ! 2D plane strain + beta = 2.0_WP * kk * p2%dil + alpha = 8.0_WP * mu / p2%mw + ed = dist - p1%dbond(nb) * (1.0_WP + p2%dil / 2.0_WP) + else + ! 3D + beta = 3.0_WP * kk * p2%dil + alpha = 15.0_WP * mu / p2%mw + ed = dist - p1%dbond(nb) * (1.0_WP + p2%dil / 3.0_WP) + end if + ! Force density 2->1 + ! t21=-wgauss(p1%dbond(nb),this%delta)*(beta/p2%mw*p1%dbond(nb)+alpha*ed)*rpos/dist + t21=-wgauss(p1%dbond(nb),this%delta)*((3.0_WP*kk - 15.0_WP*mu/3.0_WP)*(Gd_mag*p2%dil*p1%dbond(nb)/p2%mw)+ (15.0_WP*mu/p2%mw)*(dist - p1%dbond(nb)) )*rpos/dist ! Increment bond force + p1%Abond=p1%Abond+(t12-t21)*p2%vol/this%rho + ! Incremend SED + p1%ste=p1%ste+alpha/2.0_WP*(wgauss(p1%dbond(nb),this%delta)*((dist-p1%dbond(nb)))*p2%vol) + ! If still here, we have an active bond + found_bond=.true. + ! Determine minimum bond distance + this%min_dist=min(this%min_dist,dist) + cycle + end if + end do + ! Add collision force now + ! if (is2D) then + ! rc=p1%vol**(1.0_WP/2.0_WP) + ! else + ! rc=p1%vol**(1.0_WP/3.0_WP) + ! end if + ! if (.not.found_bond.and.p1%i.ne.p2%i.and.dist.lt.rc) then + ! p1%Abond=p1%Abond-max(kc*((rc/dist)**nc-1.0_WP),0.0_WP)*(rpos/dist)*p1%vol/this%rho + ! p1%flag = -2 + ! end if + end do + end do + end do + end do + ! Deal with dimensionality + if (this%cfg%nx.eq.1) p1%Abond(1)=0.0_WP + if (this%cfg%ny.eq.1) p1%Abond(2)=0.0_WP + if (this%cfg%nz.eq.1) p1%Abond(3)=0.0_WP + ! Copy back the particle + this%p(n1)=p1 + end do + ! Get global minimum + call MPI_ALLREDUCE(MPI_IN_PLACE,this%min_dist,1,MPI_REAL_WP,MPI_MIN,this%cfg%comm,ierr) + end block update_bond_force + + ! Clean up + if (allocated(npic)) deallocate(npic) + if (allocated(ipic)) deallocate(ipic) + + end subroutine get_bond_force + + + !> Advance the particle equations by a specified time step dt + !> p%id=-2 => do not solve for position nor velocity + !> p%id=-1 => do not solve for velocity + !> p%id= 0 => do not update force + + subroutine advance(this,dt)!,stress_x,stress_y,stress_z) + use mpi_f08, only : MPI_SUM,MPI_INTEGER,MPI_IN_PLACE + use mathtools, only: Pi + implicit none + class(lss), intent(inout) :: this + real(WP), intent(inout) :: dt !< Timestep size over which to advance + ! real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(inout) :: stress_x !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + ! real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(inout) :: stress_y !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + ! real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(inout) :: stress_z !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + integer :: n,ierr + ! real(WP), dimension(3) :: stress + + ! Zero out number of particles removed + this%np_out=0 + + ! Advance velocity based on old force and position based on mid-velocity + do n=1,this%np_ + ! Advance with Verlet scheme + if (this%p(n)%id.gt.-1) this%p(n)%vel=this%p(n)%vel+0.5_WP*dt*(this%gravity+this%p(n)%Abond+this%p(n)%Afluid) + if (this%p(n)%id.gt.-2) this%p(n)%pos=this%p(n)%pos+dt*this%p(n)%vel + ! Relocalize + this%p(n)%ind=this%cfg%get_ijk_global(this%p(n)%pos,this%p(n)%ind) + ! Correct the position to take into account periodicity + if (this%cfg%xper) this%p(n)%pos(1)=this%cfg%x(this%cfg%imin)+modulo(this%p(n)%pos(1)-this%cfg%x(this%cfg%imin),this%cfg%xL) + if (this%cfg%yper) this%p(n)%pos(2)=this%cfg%y(this%cfg%jmin)+modulo(this%p(n)%pos(2)-this%cfg%y(this%cfg%jmin),this%cfg%yL) + if (this%cfg%zper) this%p(n)%pos(3)=this%cfg%z(this%cfg%kmin)+modulo(this%p(n)%pos(3)-this%cfg%z(this%cfg%kmin),this%cfg%zL) + ! Handle particles that have left the domain + if (this%p(n)%pos(1).lt.this%cfg%x(this%cfg%imin).or.this%p(n)%pos(1).gt.this%cfg%x(this%cfg%imax+1)) this%p(n)%flag=1 + if (this%p(n)%pos(2).lt.this%cfg%y(this%cfg%jmin).or.this%p(n)%pos(2).gt.this%cfg%y(this%cfg%jmax+1)) this%p(n)%flag=1 + if (this%p(n)%pos(3).lt.this%cfg%z(this%cfg%kmin).or.this%p(n)%pos(3).gt.this%cfg%z(this%cfg%kmax+1)) this%p(n)%flag=1 + ! Relocalize the particle + this%p(n)%ind=this%cfg%get_ijk_global(this%p(n)%pos,this%p(n)%ind) + ! Count number of particles removed + if (this%p(n)%flag.eq.1) this%np_out=this%np_out+1 + end do + + ! Communicate particles + call this%sync() + + ! Sum up particles removed + call MPI_ALLREDUCE(this%np_out,n,1,MPI_INTEGER,MPI_SUM,this%cfg%comm,ierr); this%np_out=n + + ! Calculate bond force + call this%get_bond_force() + + ! Advance velocity only based on new force + do n=1,this%np_ + ! Advance with Verlet scheme + if (this%p(n)%id.le.-1) cycle + ! stress=this%cfg%get_velocity(pos=this%p(n)%pos,i0=this%p(n)%ind(1),j0=this%p(n)%ind(2),k0=this%p(n)%ind(3),U=stress_x,V=stress_y,W=stress_z) + ! this%p(n)%Afluid=stress/this%rho + this%p(n)%Afluid=0.0_WP + this%p(n)%vel=this%p(n)%vel+0.5_WP*dt*(this%gravity+this%p(n)%Abond+this%p(n)%Afluid) + end do + + ! Recompute volume fraction + ! call this%update_VF() + + ! Log/screen output + logging: block + use, intrinsic :: iso_fortran_env, only: output_unit + use param, only: verbose + use messager, only: log + use string, only: str_long + character(len=str_long) :: message + if (this%cfg%amRoot) then + write(message,'("Particle solver [",a,"] on partitioned grid [",a,"]: ",i0," particles were advanced")') trim(this%name),trim(this%cfg%name),this%np + if (verbose.gt.1) write(output_unit,'(a)') trim(message) + if (verbose.gt.0) call log(message) + end if + end block logging + + end subroutine advance + + subroutine stretch(this,dt)!,stress_x,stress_y,stress_z) + use mpi_f08, only : MPI_SUM,MPI_INTEGER,MPI_IN_PLACE + use mathtools, only: Pi + implicit none + class(lss), intent(inout) :: this + real(WP), intent(inout) :: dt !< Timestep size over which to advance + real(WP) :: mu + integer :: n,ierr + !======================================================================================== + ! X-Axis Stretch: + ! Zero out number of particles removed + this%np_out=0 + do n=1,this%np_ + ! Stretch the beam along the x axis with a uniform strain-rate of 0.001 + if (this%p(n)%id.gt.-2) this%p(n)%pos(1)=this%p(n)%pos(1)*1.001_WP + end do + + ! Communicate particles + call this%sync() + + ! Calculate bond force + call this%get_bond_force() + + mu=this%elastic_modulus/(2.0_WP+2.0_WP*this%poisson_ratio) + + do n=1,this%np_ + if (this%p(n)%id.gt.-2) this%p(n)%gd(1)=0.001_WP/this%p(n)%dil + end do + + !======================================================================================== + ! Y-Axis Stretch: + ! Zero out number of particles removed + this%np_out=0 + do n=1,this%np_ + ! Stretch the beam along the x axis with a uniform strain-rate of 0.001 + if (this%p(n)%id.gt.-2) this%p(n)%pos(1)=this%p(n)%pos(1)/1.001_WP + if (this%p(n)%id.gt.-2) this%p(n)%pos(2)=this%p(n)%pos(2)*1.001_WP + end do + + ! Communicate particles + call this%sync() + + ! Calculate bond force + call this%get_bond_force() + + mu=this%elastic_modulus/(2.0_WP+2.0_WP*this%poisson_ratio) + + do n=1,this%np_ + if (this%p(n)%id.gt.-2) this%p(n)%gd(2)=0.001_WP/this%p(n)%dil + end do + + !======================================================================================== + ! Z-Axis Stretch: + ! Zero out number of particles removed + this%np_out=0 + do n=1,this%np_ + ! Stretch the beam along the x axis with a uniform strain-rate of 0.001 + if (this%p(n)%id.gt.-2) this%p(n)%pos(2)=this%p(n)%pos(2)/1.001_WP + if (this%p(n)%id.gt.-2) this%p(n)%pos(3)=this%p(n)%pos(3)*1.001_WP + end do + + ! Communicate particles + call this%sync() + + ! Calculate bond force + call this%get_bond_force() + + mu=this%elastic_modulus/(2.0_WP+2.0_WP*this%poisson_ratio) + + do n=1,this%np_ + if (this%p(n)%id.gt.-2) this%p(n)%gd(3)=0.001_WP/this%p(n)%dil + end do + + ! Put the particle back where it was + do n=1,this%np_ + if (this%p(n)%id.gt.-2) this%p(n)%pos(3)=this%p(n)%pos(3)/1.001_WP + end do + + !====================================================================================== + + ! Now stretch particle for the first time step + + do n=1,this%np_ + ! Stretch the beam along the x axis with a uniform strain-rate of 0.001 + if (this%p(n)%id.gt.-2) this%p(n)%pos(1)=this%p(n)%pos(1)*1.001_WP + end do + + ! Communicate particles + call this%sync() + + ! Calculate bond force + call this%get_bond_force() + + + + + end subroutine stretch + + subroutine get_correction_coeffs(this,dt)!,stress_x,stress_y,stress_z) + use mpi_f08, only : MPI_SUM,MPI_INTEGER,MPI_IN_PLACE + use mathtools, only: Pi + implicit none + class(lss), intent(inout) :: this + real(WP), intent(inout) :: dt !< Timestep size over which to advance + real(WP) :: mu + integer :: n,ierr + ! Zero out number of particles removed + this%np_out=0 + do n=1,this%np_ + ! Stretch the beam along the x axis with a uniform strain-rate of 0.001 + if (this%p(n)%id.gt.-2) this%p(n)%pos(1)=this%p(n)%pos(1) + this%p(n)%pos(1)*0.001_WP + ! Relocalize + this%p(n)%ind=this%cfg%get_ijk_global(this%p(n)%pos,this%p(n)%ind) + ! Correct the position to take into account periodicity + if (this%cfg%xper) this%p(n)%pos(1)=this%cfg%x(this%cfg%imin)+modulo(this%p(n)%pos(1)-this%cfg%x(this%cfg%imin),this%cfg%xL) + if (this%cfg%yper) this%p(n)%pos(2)=this%cfg%y(this%cfg%jmin)+modulo(this%p(n)%pos(2)-this%cfg%y(this%cfg%jmin),this%cfg%yL) + if (this%cfg%zper) this%p(n)%pos(3)=this%cfg%z(this%cfg%kmin)+modulo(this%p(n)%pos(3)-this%cfg%z(this%cfg%kmin),this%cfg%zL) + ! Handle particles that have left the domain + if (this%p(n)%pos(1).lt.this%cfg%x(this%cfg%imin).or.this%p(n)%pos(1).gt.this%cfg%x(this%cfg%imax+1)) this%p(n)%flag=1 + if (this%p(n)%pos(2).lt.this%cfg%y(this%cfg%jmin).or.this%p(n)%pos(2).gt.this%cfg%y(this%cfg%jmax+1)) this%p(n)%flag=1 + if (this%p(n)%pos(3).lt.this%cfg%z(this%cfg%kmin).or.this%p(n)%pos(3).gt.this%cfg%z(this%cfg%kmax+1)) this%p(n)%flag=1 + ! Relocalize the particle + this%p(n)%ind=this%cfg%get_ijk_global(this%p(n)%pos,this%p(n)%ind) + ! Count number of particles removed + end do + + ! Communicate particles + call this%sync() + + ! Sum up particles removed + call MPI_ALLREDUCE(this%np_out,n,1,MPI_INTEGER,MPI_SUM,this%cfg%comm,ierr); this%np_out=n + + ! Calculate bond force + call this%get_bond_force() + + mu=this%elastic_modulus/(2.0_WP+2.0_WP*this%poisson_ratio) + + do n=1,this%np_ + this%p(n)%gd=0.001_WP/this%p(n)%dil + this%p(n)%Gb=0.5_WP*mu*(0.001_WP*0.001_WP)/this%p(n)%ste + end do + + ! Log/screen output + logging: block + use, intrinsic :: iso_fortran_env, only: output_unit + use param, only: verbose + use messager, only: log + use string, only: str_long + character(len=str_long) :: message + if (this%cfg%amRoot) then + write(message,'("Particle solver [",a,"] on partitioned grid [",a,"]: ",i0," particles were advanced")') trim(this%name),trim(this%cfg%name),this%np + if (verbose.gt.1) write(output_unit,'(a)') trim(message) + if (verbose.gt.0) call log(message) + end if + end block logging + + end subroutine get_correction_coeffs + + + !> Update particle volume fraction using our current particles + subroutine update_VF(this) + implicit none + class(lss), intent(inout) :: this + integer :: i + ! Reset volume fraction and momentum + this%VF=0.0_WP; this%VFU=0.0_WP; this%VFV=0.0_WP; this%VFW=0.0_WP + ! Transfer particle volume + do i=1,this%np_ + ! Skip inactive particle + if (this%p(i)%flag.eq.1) cycle + ! Transfer volume to mesh + call this%extrapolate(Ap=this%p(i)%vol,xp=this%p(i)%pos(1),yp=this%p(i)%pos(2),zp=this%p(i)%pos(3),ip=this%p(i)%ind(1),jp=this%p(i)%ind(2),kp=this%p(i)%ind(3),A=this%VF,dir='SC') + call this%extrapolate(Ap=this%p(i)%vol*this%p(i)%vel(1),xp=this%p(i)%pos(1),yp=this%p(i)%pos(2),zp=this%p(i)%pos(3),ip=this%p(i)%ind(1),jp=this%p(i)%ind(2),kp=this%p(i)%ind(3),A=this%VFU,dir='U') + call this%extrapolate(Ap=this%p(i)%vol*this%p(i)%vel(2),xp=this%p(i)%pos(1),yp=this%p(i)%pos(2),zp=this%p(i)%pos(3),ip=this%p(i)%ind(1),jp=this%p(i)%ind(2),kp=this%p(i)%ind(3),A=this%VFV,dir='V') + call this%extrapolate(Ap=this%p(i)%vol*this%p(i)%vel(3),xp=this%p(i)%pos(1),yp=this%p(i)%pos(2),zp=this%p(i)%pos(3),ip=this%p(i)%ind(1),jp=this%p(i)%ind(2),kp=this%p(i)%ind(3),A=this%VFW,dir='W') + end do + ! Sum at boundaries + call this%cfg%syncsum(this%VF) + call this%cfg%syncsum(this%VFU) + call this%cfg%syncsum(this%VFV) + call this%cfg%syncsum(this%VFW) + ! Clip + where (this%VF.gt.1.0_WP) this%VF=1.0_WP + where (this%VF.lt.0.0_WP) this%VF=0.0_WP + end subroutine update_VF + + + !> Compute regularized delta function + subroutine get_delta(this,delta,ic,jc,kc,xp,yp,zp,dir) + implicit none + class(lss), intent(inout) :: this + real(WP), intent(out) :: delta !< Return delta function + integer, intent(in) :: ic,jc,kc !< Cell index + real(WP), intent(in) :: xp,yp,zp !< Position of marker + character(len=*) :: dir + real(WP) :: deltax,deltay,deltaz,r + + ! Compute in X + if (trim(adjustl(dir)).eq.'U') then + r=(xp-this%cfg%x(ic))*this%cfg%dxmi(ic) + deltax=roma_kernel(r)*this%cfg%dxmi(ic) + else + r=(xp-this%cfg%xm(ic))*this%cfg%dxi(ic) + deltax=roma_kernel(r)*this%cfg%dxi(ic) + end if + + ! Compute in Y + if (trim(adjustl(dir)).eq.'V') then + r=(yp-this%cfg%y(jc))*this%cfg%dymi(jc) + deltay=roma_kernel(r)*this%cfg%dymi(jc) + else + r=(yp-this%cfg%ym(jc))*this%cfg%dyi(jc) + deltay=roma_kernel(r)*this%cfg%dyi(jc) + end if + + ! Compute in Z + if (trim(adjustl(dir)).eq.'W') then + r=(zp-this%cfg%z(kc))*this%cfg%dzmi(kc) + deltaz=roma_kernel(r)*this%cfg%dzmi(kc) + else + r=(zp-this%cfg%zm(kc))*this%cfg%dzi(kc) + deltaz=roma_kernel(r)*this%cfg%dzi(kc) + end if + !else + + ! Put it all together + delta=deltax*deltay*deltaz + + contains + ! Mollification kernel + ! Roma A, Peskin C and Berger M 1999 J. Comput. Phys. 153 509–534 + function roma_kernel(r) result(phi) + implicit none + real(WP), intent(in) :: r + real(WP) :: phi + if (abs(r).le.0.5_WP) then + phi=1.0_WP/3.0_WP*(1.0_WP+sqrt(-3.0_WP*r**2+1.0_WP)) + else if (abs(r).gt.0.5_WP .and. abs(r).le.1.5_WP) then + phi=1.0_WP/6.0_WP*(5.0_WP-3.0_WP*abs(r)-sqrt(-3.0_WP*(1.0_WP-abs(r))**2+1.0_WP)) + else + phi=0.0_WP + end if + end function roma_kernel + + end subroutine get_delta + + + !> Interpolation routine + function interpolate(this,A,xp,yp,zp,ip,jp,kp,dir) result(Ap) + implicit none + class(lss), intent(inout) :: this + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(in) :: A !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + real(WP), intent(in) :: xp,yp,zp + integer, intent(in) :: ip,jp,kp + character(len=*) :: dir + real(WP) :: Ap + integer :: di,dj,dk + integer :: i1,i2,j1,j2,k1,k2 + real(WP), dimension(-2:+2,-2:+2,-2:+2) :: delta + ! Get the interpolation points + i1=ip-2; i2=ip+2 + j1=jp-2; j2=jp+2 + k1=kp-2; k2=kp+2 + ! Loop over neighboring cells and compute regularized delta function + do dk=-2,+2 + do dj=-2,+2 + do di=-2,+2 + call this%get_delta(delta=delta(di,dj,dk),ic=ip+di,jc=jp+dj,kc=kp+dk,xp=xp,yp=yp,zp=zp,dir=trim(dir)) + end do + end do + end do + ! Perform the actual interpolation on Ap + Ap = sum(delta*A(i1:i2,j1:j2,k1:k2))*this%cfg%vol(ip,jp,kp) + end function interpolate + + + !> Extrapolation routine + subroutine extrapolate(this,Ap,xp,yp,zp,ip,jp,kp,A,dir) + use messager, only: die + implicit none + class(lss), intent(inout) :: this + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:) :: A !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + real(WP), intent(in) :: xp,yp,zp + integer, intent(in) :: ip,jp,kp + real(WP), intent(in) :: Ap + character(len=*) :: dir + real(WP), dimension(-2:+2,-2:+2,-2:+2) :: delta + integer :: di,dj,dk + ! If particle has left processor domain or reached last ghost cell, kill job + if ( ip.lt.this%cfg%imin_-1.or.ip.gt.this%cfg%imax_+1.or.& + & jp.lt.this%cfg%jmin_-1.or.jp.gt.this%cfg%jmax_+1.or.& + & kp.lt.this%cfg%kmin_-1.or.kp.gt.this%cfg%kmax_+1) then + write(*,*) ip,jp,kp,xp,yp,zp + call die('[df extrapolate] Particle has left the domain') + end if + ! Loop over neighboring cells and compute regularized delta function + do dk=-2,+2 + do dj=-2,+2 + do di=-2,+2 + call this%get_delta(delta=delta(di,dj,dk),ic=ip+di,jc=jp+dj,kc=kp+dk,xp=xp,yp=yp,zp=zp,dir=trim(dir)) + end do + end do + end do + ! Perform the actual extrapolation on A + A(ip-2:ip+2,jp-2:jp+2,kp-2:kp+2)=A(ip-2:ip+2,jp-2:jp+2,kp-2:kp+2)+delta*Ap + end subroutine extrapolate + + + !> Calculate the CFL + subroutine get_cfl(this,dt,cfl) + use mpi_f08, only: MPI_ALLREDUCE,MPI_MAX + use parallel, only: MPI_REAL_WP + implicit none + class(lss), intent(inout) :: this + real(WP), intent(in) :: dt + real(WP), intent(out) :: cfl + integer :: i,ierr + real(WP) :: my_CFLp_x,my_CFLp_y,my_CFLp_z,kk,mu,a + + ! Set the CFLs to zero + my_CFLp_x=0.0_WP; my_CFLp_y=0.0_WP; my_CFLp_z=0.0_WP + do i=1,this%np_ + my_CFLp_x=max(my_CFLp_x,abs(this%p(i)%vel(1))*this%cfg%dxi(this%p(i)%ind(1))) + my_CFLp_y=max(my_CFLp_y,abs(this%p(i)%vel(2))*this%cfg%dyi(this%p(i)%ind(2))) + my_CFLp_z=max(my_CFLp_z,abs(this%p(i)%vel(3))*this%cfg%dzi(this%p(i)%ind(3))) + end do + my_CFLp_x=my_CFLp_x*dt; my_CFLp_y=my_CFLp_y*dt; my_CFLp_z=my_CFLp_z*dt + + ! Get the parallel max + call MPI_ALLREDUCE(my_CFLp_x,this%CFLp_x,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + call MPI_ALLREDUCE(my_CFLp_y,this%CFLp_y,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + call MPI_ALLREDUCE(my_CFLp_z,this%CFLp_z,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + + ! CFL based on elastic wave speed in material + kk=this%elastic_modulus/(3.0_WP-6.0_WP*this%poisson_ratio) + mu=this%elastic_modulus/(2.0_WP+2.0_WP*this%poisson_ratio) + a=sqrt((kk+4.0_WP*mu/3.0_WP)/this%rho) + this%CFLp_a=dt*a*3/this%delta + + ! Return the maximum CFL + cfl=max(this%CFLp_x,this%CFLp_y,this%CFLp_z,this%CFLp_a) + + end subroutine get_cfl + + + !> Extract various monitoring data from particle field + subroutine get_max(this) + use mpi_f08, only: MPI_ALLREDUCE,MPI_MAX,MPI_MIN,MPI_SUM + use parallel, only: MPI_REAL_WP + implicit none + class(lss), intent(inout) :: this + real(WP) :: buf,safe_np + real(WP), dimension(3) :: buf3D + integer :: i,j,k,ierr + + ! Create safe np + safe_np=real(max(this%np,1),WP) + + ! Velocity min/max/mean + this%Umin=huge(1.0_WP); this%Umax=-huge(1.0_WP); this%Umean=0.0_WP + this%Vmin=huge(1.0_WP); this%Vmax=-huge(1.0_WP); this%Vmean=0.0_WP + this%Wmin=huge(1.0_WP); this%Wmax=-huge(1.0_WP); this%Wmean=0.0_WP + this%ibmForce=0.0_WP + do i=1,this%np_ + this%Umin=min(this%Umin,this%p(i)%vel(1)); this%Umax=max(this%Umax,this%p(i)%vel(1)); this%Umean=this%Umean+this%p(i)%vel(1) + this%Vmin=min(this%Vmin,this%p(i)%vel(2)); this%Vmax=max(this%Vmax,this%p(i)%vel(2)); this%Vmean=this%Vmean+this%p(i)%vel(2) + this%Wmin=min(this%Wmin,this%p(i)%vel(3)); this%Wmax=max(this%Wmax,this%p(i)%vel(3)); this%Wmean=this%Wmean+this%p(i)%vel(3) + this%ibmForce=this%ibmForce+this%p(i)%Afluid*this%p(i)%vol*this%rho + end do + call MPI_ALLREDUCE(this%Umin ,buf,1,MPI_REAL_WP,MPI_MIN,this%cfg%comm,ierr); this%Umin =buf + call MPI_ALLREDUCE(this%Umax ,buf,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr); this%Umax =buf + call MPI_ALLREDUCE(this%Umean,buf,1,MPI_REAL_WP,MPI_SUM,this%cfg%comm,ierr); this%Umean=buf/safe_np + call MPI_ALLREDUCE(this%Vmin ,buf,1,MPI_REAL_WP,MPI_MIN,this%cfg%comm,ierr); this%Vmin =buf + call MPI_ALLREDUCE(this%Vmax ,buf,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr); this%Vmax =buf + call MPI_ALLREDUCE(this%Vmean,buf,1,MPI_REAL_WP,MPI_SUM,this%cfg%comm,ierr); this%Vmean=buf/safe_np + call MPI_ALLREDUCE(this%Wmin ,buf,1,MPI_REAL_WP,MPI_MIN,this%cfg%comm,ierr); this%Wmin =buf + call MPI_ALLREDUCE(this%Wmax ,buf,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr); this%Wmax =buf + call MPI_ALLREDUCE(this%Wmean,buf,1,MPI_REAL_WP,MPI_SUM,this%cfg%comm,ierr); this%Wmean=buf/safe_np + call MPI_ALLREDUCE(this%ibmForce,buf3D,3,MPI_REAL_WP,MPI_SUM,this%cfg%comm,ierr); this%ibmForce=buf3D + + ! Get max volume fraction + this%VFmax =-huge(1.0_WP) + do k=this%cfg%kmin_,this%cfg%kmax_ + do j=this%cfg%jmin_,this%cfg%jmax_ + do i=this%cfg%imin_,this%cfg%imax_ + this%VFmax=max(this%VFmax,this%VF(i,j,k)) + end do + end do + end do + call MPI_ALLREDUCE(this%VFmax,buf,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr); this%VFmax=buf + + end subroutine get_max + + + !> Update particle mesh using our current particles + subroutine update_partmesh(this,pmesh) + use partmesh_class, only: partmesh + implicit none + class(lss), intent(inout) :: this + class(partmesh), intent(inout) :: pmesh + integer :: i + ! Reset particle mesh storage + call pmesh%reset() + ! Nothing else to do if no particle is present + if (this%np_.eq.0) return + ! Copy particle info + call pmesh%set_size(this%np_) + do i=1,this%np_ + pmesh%pos(:,i)=this%p(i)%pos + end do + end subroutine update_partmesh + + + !> Creation of the MPI datatype for particle + subroutine prepare_mpi_part() + use mpi_f08 + use messager, only: die + implicit none + integer(MPI_ADDRESS_KIND), dimension(part_nblock) :: disp + integer(MPI_ADDRESS_KIND) :: lb,extent + type(MPI_Datatype) :: MPI_PART_TMP + integer :: i,mysize,ierr + ! Prepare the displacement array + disp(1)=0 + do i=2,part_nblock + call MPI_Type_size(part_tblock(i-1),mysize,ierr) + disp(i)=disp(i-1)+int(mysize,MPI_ADDRESS_KIND)*int(part_lblock(i-1),MPI_ADDRESS_KIND) + end do + ! Create and commit the new type + call MPI_Type_create_struct(part_nblock,part_lblock,disp,part_tblock,MPI_PART_TMP,ierr) + call MPI_Type_get_extent(MPI_PART_TMP,lb,extent,ierr) + call MPI_Type_create_resized(MPI_PART_TMP,lb,extent,MPI_PART,ierr) + call MPI_Type_commit(MPI_PART,ierr) + ! If a problem was encountered, say it + if (ierr.ne.0) call die('[lss prepare_mpi_part] MPI Particle type creation failed') + ! Get the size of this type + call MPI_type_size(MPI_PART,MPI_PART_SIZE,ierr) + end subroutine prepare_mpi_part + + + !> Share particles across processor boundaries + subroutine share(this,nover) + use mpi_f08 + use messager, only: warn,die + implicit none + class(lss), intent(inout) :: this + integer, optional :: nover + type(part), dimension(:), allocatable :: tosend + type(part), dimension(:), allocatable :: torecv + integer :: no,nsend,nrecv + type(MPI_Status) :: status + integer :: icnt,isrc,idst,ierr + integer :: i,n + + ! Check overlap size + if (present(nover)) then + no=nover + if (no.gt.this%cfg%no) then + call warn('[lss share] Specified overlap is larger than that of cfg - reducing no') + no=this%cfg%no + else if (no.le.0) then + call die('[lss share] Specified overlap cannot be less or equal to zero') + end if + else + no=1 + end if + + ! Clean up ghost array + call this%resize_ghost(n=0); this%ng_=0 + + ! Share ghost particles in -x (no ghosts are sent here) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(1).lt.this%cfg%imin_+no) nsend=nsend+1 + end do + allocate(tosend(nsend)) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(1).lt.this%cfg%imin_+no) then + nsend=nsend+1 + tosend(nsend)=this%p(n) + if (this%cfg%xper.and.tosend(nsend)%ind(1).lt.this%cfg%imin+no) then + tosend(nsend)%pos(1)=tosend(nsend)%pos(1)+this%cfg%xL + tosend(nsend)%ind(1)=tosend(nsend)%ind(1)+this%cfg%nx + end if + end if + end do + nrecv=0 + call MPI_CART_SHIFT(this%cfg%comm,0,-1,isrc,idst,ierr) + call MPI_SENDRECV(nsend,1,MPI_INTEGER,idst,0,nrecv,1,MPI_INTEGER,isrc,0,this%cfg%comm,status,ierr) + allocate(torecv(nrecv)) + call MPI_SENDRECV(tosend,nsend,MPI_PART,idst,0,torecv,nrecv,MPI_PART,isrc,0,this%cfg%comm,status,ierr) + call this%resize_ghost(this%ng_+nrecv) + this%g(this%ng_+1:this%ng_+nrecv)=torecv + this%ng_=this%ng_+nrecv + if (allocated(tosend)) deallocate(tosend) + if (allocated(torecv)) deallocate(torecv) + + ! Share ghost particles in +x (no ghosts are sent here) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(1).gt.this%cfg%imax_-no) nsend=nsend+1 + end do + allocate(tosend(nsend)) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(1).gt.this%cfg%imax_-no) then + nsend=nsend+1 + tosend(nsend)=this%p(n) + if (this%cfg%xper.and.tosend(nsend)%ind(1).gt.this%cfg%imax-no) then + tosend(nsend)%pos(1)=tosend(nsend)%pos(1)-this%cfg%xL + tosend(nsend)%ind(1)=tosend(nsend)%ind(1)-this%cfg%nx + end if + end if + end do + nrecv=0 + call MPI_CART_SHIFT(this%cfg%comm,0,+1,isrc,idst,ierr) + call MPI_SENDRECV(nsend,1,MPI_INTEGER,idst,0,nrecv,1,MPI_INTEGER,isrc,0,this%cfg%comm,status,ierr) + allocate(torecv(nrecv)) + call MPI_SENDRECV(tosend,nsend,MPI_PART,idst,0,torecv,nrecv,MPI_PART,isrc,0,this%cfg%comm,status,ierr) + call this%resize_ghost(this%ng_+nrecv) + this%g(this%ng_+1:this%ng_+nrecv)=torecv + this%ng_=this%ng_+nrecv + if (allocated(tosend)) deallocate(tosend) + if (allocated(torecv)) deallocate(torecv) + + ! Share ghost particles in -y (ghosts need to be sent now) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(2).lt.this%cfg%jmin_+no) nsend=nsend+1 + end do + do n=1,this%ng_ + if (this%g(n)%ind(2).lt.this%cfg%jmin_+no) nsend=nsend+1 + end do + allocate(tosend(nsend)) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(2).lt.this%cfg%jmin_+no) then + nsend=nsend+1 + tosend(nsend)=this%p(n) + if (this%cfg%yper.and.tosend(nsend)%ind(2).lt.this%cfg%jmin+no) then + tosend(nsend)%pos(2)=tosend(nsend)%pos(2)+this%cfg%yL + tosend(nsend)%ind(2)=tosend(nsend)%ind(2)+this%cfg%ny + end if + end if + end do + do n=1,this%ng_ + if (this%g(n)%ind(2).lt.this%cfg%jmin_+no) then + nsend=nsend+1 + tosend(nsend)=this%g(n) + if (this%cfg%yper.and.tosend(nsend)%ind(2).lt.this%cfg%jmin+no) then + tosend(nsend)%pos(2)=tosend(nsend)%pos(2)+this%cfg%yL + tosend(nsend)%ind(2)=tosend(nsend)%ind(2)+this%cfg%ny + end if + end if + end do + nrecv=0 + call MPI_CART_SHIFT(this%cfg%comm,1,-1,isrc,idst,ierr) + call MPI_SENDRECV(nsend,1,MPI_INTEGER,idst,0,nrecv,1,MPI_INTEGER,isrc,0,this%cfg%comm,status,ierr) + allocate(torecv(nrecv)) + call MPI_SENDRECV(tosend,nsend,MPI_PART,idst,0,torecv,nrecv,MPI_PART,isrc,0,this%cfg%comm,status,ierr) + call this%resize_ghost(this%ng_+nrecv) + this%g(this%ng_+1:this%ng_+nrecv)=torecv + this%ng_=this%ng_+nrecv + if (allocated(tosend)) deallocate(tosend) + if (allocated(torecv)) deallocate(torecv) + + ! Share ghost particles in +y (ghosts need to be sent now - but not newly received ghosts!) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(2).gt.this%cfg%jmax_-no) nsend=nsend+1 + end do + do n=1,this%ng_-nrecv + if (this%g(n)%ind(2).gt.this%cfg%jmax_-no) nsend=nsend+1 + end do + allocate(tosend(nsend)) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(2).gt.this%cfg%jmax_-no) then + nsend=nsend+1 + tosend(nsend)=this%p(n) + if (this%cfg%yper.and.tosend(nsend)%ind(2).gt.this%cfg%jmax-no) then + tosend(nsend)%pos(2)=tosend(nsend)%pos(2)-this%cfg%yL + tosend(nsend)%ind(2)=tosend(nsend)%ind(2)-this%cfg%ny + end if + end if + end do + do n=1,this%ng_-nrecv + if (this%g(n)%ind(2).gt.this%cfg%jmax_-no) then + nsend=nsend+1 + tosend(nsend)=this%g(n) + if (this%cfg%yper.and.tosend(nsend)%ind(2).gt.this%cfg%jmax-no) then + tosend(nsend)%pos(2)=tosend(nsend)%pos(2)-this%cfg%yL + tosend(nsend)%ind(2)=tosend(nsend)%ind(2)-this%cfg%ny + end if + end if + end do + nrecv=0 + call MPI_CART_SHIFT(this%cfg%comm,1,+1,isrc,idst,ierr) + call MPI_SENDRECV(nsend,1,MPI_INTEGER,idst,0,nrecv,1,MPI_INTEGER,isrc,0,this%cfg%comm,status,ierr) + allocate(torecv(nrecv)) + call MPI_SENDRECV(tosend,nsend,MPI_PART,idst,0,torecv,nrecv,MPI_PART,isrc,0,this%cfg%comm,status,ierr) + call this%resize_ghost(this%ng_+nrecv) + this%g(this%ng_+1:this%ng_+nrecv)=torecv + this%ng_=this%ng_+nrecv + if (allocated(tosend)) deallocate(tosend) + if (allocated(torecv)) deallocate(torecv) + + ! Share ghost particles in -z (ghosts need to be sent now) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(3).lt.this%cfg%kmin_+no) nsend=nsend+1 + end do + do n=1,this%ng_ + if (this%g(n)%ind(3).lt.this%cfg%kmin_+no) nsend=nsend+1 + end do + allocate(tosend(nsend)) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(3).lt.this%cfg%kmin_+no) then + nsend=nsend+1 + tosend(nsend)=this%p(n) + if (this%cfg%zper.and.tosend(nsend)%ind(3).lt.this%cfg%kmin+no) then + tosend(nsend)%pos(3)=tosend(nsend)%pos(3)+this%cfg%zL + tosend(nsend)%ind(3)=tosend(nsend)%ind(3)+this%cfg%nz + end if + end if + end do + do n=1,this%ng_ + if (this%g(n)%ind(3).lt.this%cfg%kmin_+no) then + nsend=nsend+1 + tosend(nsend)=this%g(n) + if (this%cfg%zper.and.tosend(nsend)%ind(3).lt.this%cfg%kmin+no) then + tosend(nsend)%pos(3)=tosend(nsend)%pos(3)+this%cfg%zL + tosend(nsend)%ind(3)=tosend(nsend)%ind(3)+this%cfg%nz + end if + end if + end do + nrecv=0 + call MPI_CART_SHIFT(this%cfg%comm,2,-1,isrc,idst,ierr) + call MPI_SENDRECV(nsend,1,MPI_INTEGER,idst,0,nrecv,1,MPI_INTEGER,isrc,0,this%cfg%comm,status,ierr) + allocate(torecv(nrecv)) + call MPI_SENDRECV(tosend,nsend,MPI_PART,idst,0,torecv,nrecv,MPI_PART,isrc,0,this%cfg%comm,status,ierr) + call this%resize_ghost(this%ng_+nrecv) + this%g(this%ng_+1:this%ng_+nrecv)=torecv + this%ng_=this%ng_+nrecv + if (allocated(tosend)) deallocate(tosend) + if (allocated(torecv)) deallocate(torecv) + + ! Share ghost particles in +z (ghosts need to be sent now - but not newly received ghosts!) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(3).gt.this%cfg%kmax_-no) nsend=nsend+1 + end do + do n=1,this%ng_-nrecv + if (this%g(n)%ind(3).gt.this%cfg%kmax_-no) nsend=nsend+1 + end do + allocate(tosend(nsend)) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(3).gt.this%cfg%kmax_-no) then + nsend=nsend+1 + tosend(nsend)=this%p(n) + if (this%cfg%zper.and.tosend(nsend)%ind(3).gt.this%cfg%kmax-no) then + tosend(nsend)%pos(3)=tosend(nsend)%pos(3)-this%cfg%zL + tosend(nsend)%ind(3)=tosend(nsend)%ind(3)-this%cfg%nz + end if + end if + end do + do n=1,this%ng_-nrecv + if (this%g(n)%ind(3).gt.this%cfg%kmax_-no) then + nsend=nsend+1 + tosend(nsend)=this%g(n) + if (this%cfg%zper.and.tosend(nsend)%ind(3).gt.this%cfg%kmax-no) then + tosend(nsend)%pos(3)=tosend(nsend)%pos(3)-this%cfg%zL + tosend(nsend)%ind(3)=tosend(nsend)%ind(3)-this%cfg%nz + end if + end if + end do + nrecv=0 + call MPI_CART_SHIFT(this%cfg%comm,2,+1,isrc,idst,ierr) + call MPI_SENDRECV(nsend,1,MPI_INTEGER,idst,0,nrecv,1,MPI_INTEGER,isrc,0,this%cfg%comm,status,ierr) + allocate(torecv(nrecv)) + call MPI_SENDRECV(tosend,nsend,MPI_PART,idst,0,torecv,nrecv,MPI_PART,isrc,0,this%cfg%comm,status,ierr) + call this%resize_ghost(this%ng_+nrecv) + this%g(this%ng_+1:this%ng_+nrecv)=torecv + this%ng_=this%ng_+nrecv + if (allocated(tosend)) deallocate(tosend) + if (allocated(torecv)) deallocate(torecv) + + end subroutine share + + + !> Synchronize particle arrays across processors + subroutine sync(this) + use mpi_f08 + implicit none + class(lss), intent(inout) :: this + integer, dimension(0:this%cfg%nproc-1) :: nsend_proc,nrecv_proc + integer, dimension(0:this%cfg%nproc-1) :: nsend_disp,nrecv_disp + integer :: n,prank,ierr + type(part), dimension(:), allocatable :: buf_send + ! Recycle first to minimize communication load + call this%recycle() + ! Prepare information about what to send + nsend_proc=0 + do n=1,this%np_ + prank=this%cfg%get_rank(this%p(n)%ind) + nsend_proc(prank)=nsend_proc(prank)+1 + end do + nsend_proc(this%cfg%rank)=0 + ! Inform processors of what they will receive + call MPI_ALLtoALL(nsend_proc,1,MPI_INTEGER,nrecv_proc,1,MPI_INTEGER,this%cfg%comm,ierr) + ! Prepare displacements for all-to-all + nsend_disp(0)=0 + nrecv_disp(0)=this%np_ !< Directly add particles at the end of main array + do n=1,this%cfg%nproc-1 + nsend_disp(n)=nsend_disp(n-1)+nsend_proc(n-1) + nrecv_disp(n)=nrecv_disp(n-1)+nrecv_proc(n-1) + end do + ! Allocate buffer to send particles + allocate(buf_send(sum(nsend_proc))) + ! Pack the particles in the send buffer + nsend_proc=0 + do n=1,this%np_ + ! Get the rank + prank=this%cfg%get_rank(this%p(n)%ind) + ! Skip particles still inside + if (prank.eq.this%cfg%rank) cycle + ! Pack up for sending + nsend_proc(prank)=nsend_proc(prank)+1 + buf_send(nsend_disp(prank)+nsend_proc(prank))=this%p(n) + ! Flag particle for removal + this%p(n)%flag=1 + end do + ! Allocate buffer for receiving particles + call this%resize(this%np_+sum(nrecv_proc)) + ! Perform communication + call MPI_ALLtoALLv(buf_send,nsend_proc,nsend_disp,MPI_PART,this%p,nrecv_proc,nrecv_disp,MPI_PART,this%cfg%comm,ierr) + ! Deallocate buffer + deallocate(buf_send) + ! Recycle to remove duplicate particles + call this%recycle() + end subroutine sync + + + !> Adaptation of particle array size + subroutine resize(this,n) + implicit none + class(lss), intent(inout) :: this + integer, intent(in) :: n + type(part), dimension(:), allocatable :: tmp + integer :: size_now,size_new + ! Resize particle array to size n + if (.not.allocated(this%p)) then + ! Allocate directly to size n + allocate(this%p(n)) + this%p(1:n)%flag=1 + else + ! Update from a non-zero size to another non-zero size + size_now=size(this%p,dim=1) + if (n.gt.size_now) then + size_new=max(n,int(real(size_now,WP)*coeff_up)) + allocate(tmp(size_new)) + tmp(1:size_now)=this%p + tmp(size_now+1:)%flag=1 + call move_alloc(tmp,this%p) + else if (n.lt.int(real(size_now,WP)*coeff_dn)) then + allocate(tmp(n)) + tmp(1:n)=this%p(1:n) + call move_alloc(tmp,this%p) + end if + end if + end subroutine resize + + + !> Adaptation of ghost array size + subroutine resize_ghost(this,n) + implicit none + class(lss), intent(inout) :: this + integer, intent(in) :: n + type(part), dimension(:), allocatable :: tmp + integer :: size_now,size_new + ! Resize ghost array to size n + if (.not.allocated(this%g)) then + ! Allocate directly to size n + allocate(this%g(n)) + this%g(1:n)%flag=1 + else + ! Update from a non-zero size to another non-zero size + size_now=size(this%g,dim=1) + if (n.gt.size_now) then + size_new=max(n,int(real(size_now,WP)*coeff_up)) + allocate(tmp(size_new)) + tmp(1:size_now)=this%g + tmp(size_now+1:)%flag=1 + call move_alloc(tmp,this%g) + else if (n.lt.int(real(size_now,WP)*coeff_dn)) then + allocate(tmp(n)) + tmp(1:n)=this%g(1:n) + call move_alloc(tmp,this%g) + end if + end if + end subroutine resize_ghost + + + !> Clean-up of particle array by removing flag=1 particles + subroutine recycle(this) + implicit none + class(lss), intent(inout) :: this + integer :: new_size,i,ierr + ! Compact all active particles at the beginning of the array + new_size=0 + if (allocated(this%p)) then + do i=1,size(this%p,dim=1) + if (this%p(i)%flag.ne.1) then + new_size=new_size+1 + if (i.ne.new_size) then + this%p(new_size)=this%p(i) + this%p(i)%flag=1 + end if + end if + end do + end if + ! Resize to new size + call this%resize(new_size) + ! Update number of particles + this%np_=new_size + call MPI_ALLGATHER(this%np_,1,MPI_INTEGER,this%np_proc,1,MPI_INTEGER,this%cfg%comm,ierr) + this%np=sum(this%np_proc) + end subroutine recycle + + + !> Parallel write particles to file + subroutine write(this,filename) + use mpi_f08 + use messager, only: die + use parallel, only: info_mpiio + implicit none + class(lss), intent(inout) :: this + character(len=*), intent(in) :: filename + type(MPI_File) :: ifile + type(MPI_Status):: status + integer(kind=MPI_OFFSET_KIND) :: offset + integer :: i,ierr,iunit + + ! Root serial-writes the file header + if (this%cfg%amRoot) then + ! Open the file + open(newunit=iunit,file=trim(filename),form='unformatted',status='replace',access='stream',iostat=ierr) + if (ierr.ne.0) call die('[lss write] Problem encountered while serial-opening data file: '//trim(filename)) + ! Number of particles and particle object size + write(iunit) this%np,MPI_PART_SIZE + ! Done with the header + close(iunit) + end if + + ! The rest is done in parallel + call MPI_FILE_OPEN(this%cfg%comm,trim(filename),IOR(MPI_MODE_WRONLY,MPI_MODE_APPEND),info_mpiio,ifile,ierr) + if (ierr.ne.0) call die('[lss write] Problem encountered while parallel-opening data file: '//trim(filename)) + + ! Get current position + call MPI_FILE_GET_POSITION(ifile,offset,ierr) + + ! Compute the offset and write + do i=1,this%cfg%rank + offset=offset+int(this%np_proc(i),MPI_OFFSET_KIND)*int(MPI_PART_SIZE,MPI_OFFSET_KIND) + end do + if (this%np_.gt.0) call MPI_FILE_WRITE_AT(ifile,offset,this%p,this%np_,MPI_PART,status,ierr) + + ! Close the file + call MPI_FILE_CLOSE(ifile,ierr) + + ! Log/screen output + logging: block + use, intrinsic :: iso_fortran_env, only: output_unit + use param, only: verbose + use messager, only: log + use string, only: str_long + character(len=str_long) :: message + if (this%cfg%amRoot) then + write(message,'("[lss write] Wrote ",i0," particles to file [",a,"] on partitioned grid [",a,"]")') this%np,trim(filename),trim(this%cfg%name) + if (verbose.gt.2) write(output_unit,'(a)') trim(message) + if (verbose.gt.1) call log(message) + end if + end block logging + + end subroutine write + + + !> Parallel read particles to file + subroutine read(this,filename) + use mpi_f08 + use messager, only: die + use parallel, only: info_mpiio + implicit none + class(lss), intent(inout) :: this + character(len=*), intent(in) :: filename + type(MPI_File) :: ifile + type(MPI_Status):: status + integer(kind=MPI_OFFSET_KIND) :: offset,header_offset + integer :: i,j,ierr,npadd,psize,nchunk,cnt + integer, dimension(:,:), allocatable :: ppp + + ! First open the file in parallel + call MPI_FILE_OPEN(this%cfg%comm,trim(filename),MPI_MODE_RDONLY,info_mpiio,ifile,ierr) + if (ierr.ne.0) call die('[lss read] Problem encountered while reading data file: '//trim(filename)) + + ! Read file header first + call MPI_FILE_READ_ALL(ifile,npadd,1,MPI_INTEGER,status,ierr) + call MPI_FILE_READ_ALL(ifile,psize,1,MPI_INTEGER,status,ierr) + + ! Remember current position + call MPI_FILE_GET_POSITION(ifile,header_offset,ierr) + + ! Check compatibility of particle type + if (psize.ne.MPI_PART_SIZE) call die('[lss read] Particle type unreadable') + + ! Naively share reading task among all processors + nchunk=int(npadd/(this%cfg%nproc*part_chunk_size))+1 + allocate(ppp(this%cfg%nproc,nchunk)) + ppp=int(npadd/(this%cfg%nproc*nchunk)) + cnt=0 + out:do j=1,nchunk + do i=1,this%cfg%nproc + cnt=cnt+1 + if (cnt.gt.mod(npadd,this%cfg%nproc*nchunk)) exit out + ppp(i,j)=ppp(i,j)+1 + end do + end do out + + ! Read by chunk + do j=1,nchunk + ! Find offset + offset=header_offset+int(MPI_PART_SIZE,MPI_OFFSET_KIND)*int(sum(ppp(1:this%cfg%rank,:))+sum(ppp(this%cfg%rank+1,1:j-1)),MPI_OFFSET_KIND) + ! Resize particle array + call this%resize(this%np_+ppp(this%cfg%rank+1,j)) + ! Read this file + call MPI_FILE_READ_AT(ifile,offset,this%p(this%np_+1:this%np_+ppp(this%cfg%rank+1,j)),ppp(this%cfg%rank+1,j),MPI_PART,status,ierr) + ! Most general case: relocate every droplet + do i=this%np_+1,this%np_+ppp(this%cfg%rank+1,j) + this%p(i)%ind=this%cfg%get_ijk_global(this%p(i)%pos,this%p(i)%ind) + end do + ! Exchange all that + call this%sync() + end do + + ! Close the file + call MPI_FILE_CLOSE(ifile,ierr) + + ! Log/screen output + logging: block + use, intrinsic :: iso_fortran_env, only: output_unit + use param, only: verbose + use messager, only: log + use string, only: str_long + character(len=str_long) :: message + if (this%cfg%amRoot) then + write(message,'("[lss read] Read ",i0," particles from file [",a,"] on partitioned grid [",a,"]")') npadd,trim(filename),trim(this%cfg%name) + if (verbose.gt.2) write(output_unit,'(a)') trim(message) + if (verbose.gt.1) call log(message) + end if + end block logging + + end subroutine read + + +end module lss_class diff --git a/examples/plate_with_hole/src/simulation.f90 b/examples/plate_with_hole/src/simulation.f90 new file mode 100644 index 000000000..b5584ed0a --- /dev/null +++ b/examples/plate_with_hole/src/simulation.f90 @@ -0,0 +1,775 @@ +!> Various definitions and tools for running an NGA2 simulation +module simulation + use precision, only: WP,SP + use geometry, only: cfg + use spcomp_class, only: spcomp + use lss_class, only: lss + use timetracker_class, only: timetracker + use ensight_class, only: ensight + use partmesh_class, only: partmesh + use event_class, only: event + use monitor_class, only: monitor + implicit none + private + + !> Get a couple linear solvers, an incompressible flow solver and corresponding time tracker + type(spcomp), public :: fs + type(lss), public :: ls + type(timetracker), public :: time + + !> Ensight postprocessing + type(partmesh) :: pmesh + type(ensight) :: ens_out + type(event) :: ens_evt + + !> Simulation monitor file + type(monitor) :: mfile,cflfile,consfile,sfile,dispfile + + public :: simulation_init,simulation_run,simulation_final + + !> Private work arrays + real(WP), dimension(:,:,:,:,:), allocatable :: dQdt + real(WP), dimension(:,:,:) , allocatable :: Ui,Vi,Wi,Ma,beta,visc,visc_t,div + !> Post-shock viscosity and temperature + real(WP) :: visc0,T0 + + !> Equations of state + real(WP) :: Pinf,Gamma,Cv,Prandtl + + !> Flow parameters + real(WP) :: Ms,Xs,Rcyl + real(WP) :: rho1,p1,u1,M1 + real(WP) :: rho2,p2,u2,M2 + real(WP) :: Re + + !> Max timestep size for solid solver + real(WP) :: ls_dt,ls_dt_max + + integer :: target_index + real(WP), dimension(3) :: target_position + + + contains + + + !> Function that returns a smooth Heaviside of thickness delta + real(WP) function Hshock(x,delta) + real(WP), intent(in) :: x,delta + ! Goes from 0 to 1 as x goes from begative to positive + Hshock=1.0_WP/(1.0_WP+exp(-x/delta)) + end function Hshock + + !> P=EOS(RHO,I) + pure real(WP) function get_P(RHO,I) + implicit none + real(WP), intent(in) :: RHO,I + get_P=RHO*I*(Gamma-1.0_WP)-Gamma*Pinf + end function get_P + !> T=f(RHO,P) + pure real(WP) function get_T(RHO,P) + implicit none + real(WP), intent(in) :: RHO,P + get_T=(P+Pinf)/(Cv*RHO*(Gamma-1.0_WP)) + end function get_T + !> RHO=f(T,P) + pure real(WP) function get_RHO(T,P) + implicit none + real(WP), intent(in) :: T,P + get_RHO=(P+Pinf)/(Cv*T*(Gamma-1.0_WP)) + end function get_RHO + !> I=EOS(RHO,P) + pure real(WP) function get_I(RHO,P) + implicit none + real(WP), intent(in) :: RHO,P + get_I=(P+Gamma*Pinf)/(RHO*(Gamma-1.0_WP)) + end function get_I + !> C=f(RHO,P) + pure real(WP) function get_C(RHO,P) + implicit none + real(WP), intent(in) :: RHO,P + get_C=sqrt(Gamma*(P+Pinf)/RHO) + end function get_C + !> S=f(RHO,P) + pure real(WP) function get_S(RHO,P) + implicit none + real(WP), intent(in) :: RHO,P + get_S=Cv*log((P+Pinf)/RHO**Gamma) + end function get_S + + subroutine get_tracked_particle() + use mpi_f08 + implicit none + integer :: i, ierr + real(WP) :: local_pos(3), global_pos(3) + + local_pos = 0.0_WP + + do i=1,ls%np_ + if (ls%p(i)%i.eq.target_index) then + local_pos = ls%p(i)%pos + end if + end do + call MPI_ALLREDUCE(local_pos, global_pos, 3, MPI_DOUBLE_PRECISION, MPI_SUM, ls%cfg%comm, ierr) + + target_position = global_pos + end subroutine + + !> Calculate viscosities + subroutine prepare_viscosities() + implicit none + integer :: i,j,k + real(WP) :: S + ! Get viscosity from Sutherland's law + S=110.4_WP/273.15_WP*T0 + do k=fs%cfg%kmino_,fs%cfg%kmaxo_ + do j=fs%cfg%jmino_,fs%cfg%jmaxo_ + do i=fs%cfg%imino_,fs%cfg%imaxo_ + visc(i,j,k)=visc0*(T0+S)/(fs%T(i,j,k)+S)*(fs%T(i,j,k)/T0)**1.5_WP + end do + end do + end do + ! Get LAD + call fs%get_viscartif(dt=time%dt,beta=beta); fs%BETA=fs%Q(:,:,:,1)*beta + ! Get eddy viscosity + call fs%get_vreman (dt=time%dt,visc=visc_t); fs%VISC=fs%Q(:,:,:,1)*visc_t+visc + ! Recompute thermal conductivity + fs%diff=Gamma*Cv*fs%visc/Prandtl + ! Add LAD + fs%VISC=fs%VISC+0.002_WP*fs%BETA + end subroutine prepare_viscosities + + + !> Calculate velocity divergence + subroutine get_div() + implicit none + integer :: i,j,k + do k=fs%cfg%kmino_,fs%cfg%kmaxo_-1; do j=fs%cfg%jmino_,fs%cfg%jmaxo_-1; do i=fs%cfg%imino_,fs%cfg%imaxo_-1 + div(i,j,k)=fs%dxi*(fs%U(i+1,j,k)-fs%U(i,j,k))+fs%dyi*(fs%V(i,j+1,k)-fs%V(i,j,k))+fs%dzi*(fs%W(i,j,k+1)-fs%W(i,j,k)) + end do; end do; end do + call fs%cfg%sync(div) + if (.not.fs%cfg%xper.and.fs%cfg%iproc.eq.fs%cfg%npx) div(fs%cfg%imaxo,:,:)=div(fs%cfg%imaxo-1,:,:) + if (.not.fs%cfg%yper.and.fs%cfg%jproc.eq.fs%cfg%npy) div(:,fs%cfg%jmaxo,:)=div(:,fs%cfg%jmaxo-1,:) + if (.not.fs%cfg%zper.and.fs%cfg%kproc.eq.fs%cfg%npz) div(:,:,fs%cfg%kmaxo)=div(:,:,fs%cfg%kmaxo-1) + end subroutine get_div + + + !> Overwrite cosnerved variables using volume-of-solid IBM + subroutine apply_ibm() + implicit none + integer :: i,j,k,ii,jj,kk + real(WP) :: sum_VF,sum_VFQ1,sum_VFQ2 + do k=cfg%kmin_,cfg%kmax_ + do j=cfg%jmin_,cfg%jmax_ + do i=cfg%imin_,cfg%imax_ + if (ls%VF(i,j,k).eq.0.0_WP) cycle + ! Neumann: VF-weighted neighbor average for Q(1) and Q(2) + sum_VF=0.0_WP; sum_VFQ1=0.0_WP; sum_VFQ2=0.0_WP + do kk=-1,1; do jj=-1,1; do ii=-1,1 + if (ii.eq.0.and.jj.eq.0.and.kk.eq.0) cycle + sum_VF =sum_VF +(1.0_WP-ls%VF(i+ii,j+jj,k+kk)) + sum_VFQ1=sum_VFQ1+(1.0_WP-ls%VF(i+ii,j+jj,k+kk))*fs%Q(i+ii,j+jj,k+kk,1) + sum_VFQ2=sum_VFQ2+(1.0_WP-ls%VF(i+ii,j+jj,k+kk))*fs%Q(i+ii,j+jj,k+kk,2) + end do; end do; end do + if (sum_VF.gt.0.0_WP) then + fs%Q(i,j,k,1)=(1.0_WP-ls%VF(i,j,k))*fs%Q(i,j,k,1)+ls%VF(i,j,k)*sum_VFQ1/sum_VF + fs%Q(i,j,k,2)=(1.0_WP-ls%VF(i,j,k))*fs%Q(i,j,k,2)+ls%VF(i,j,k)*sum_VFQ2/sum_VF + end if + ! No-slip now that density is determined + fs%Q(i,j,k,3)=(1.0_WP-0.5_WP*(ls%VF(i-1,j,k)+ls%VF(i,j,k)))*fs%Q(i,j,k,3)+0.5_WP*(fs%Q(i-1,j,k,1)+fs%Q(i,j,k,1))*ls%VFU(i,j,k) + fs%Q(i,j,k,4)=(1.0_WP-0.5_WP*(ls%VF(i,j-1,k)+ls%VF(i,j,k)))*fs%Q(i,j,k,4)+0.5_WP*(fs%Q(i,j-1,k,1)+fs%Q(i,j,k,1))*ls%VFV(i,j,k) + fs%Q(i,j,k,5)=(1.0_WP-0.5_WP*(ls%VF(i,j,k-1)+ls%VF(i,j,k)))*fs%Q(i,j,k,5)+0.5_WP*(fs%Q(i,j,k-1,1)+fs%Q(i,j,k,1))*ls%VFW(i,j,k) + end do + end do + end do + ! Communicate + call fs%cfg%sync(fs%Q(:,:,:,1)) + call fs%cfg%sync(fs%Q(:,:,:,2)) + call fs%cfg%sync(fs%Q(:,:,:,3)) + call fs%cfg%sync(fs%Q(:,:,:,4)) + call fs%cfg%sync(fs%Q(:,:,:,5)) + ! Rebuild primitive variables + call fs%get_primitive() + end subroutine apply_ibm + + + !> Apply boundary conditions + subroutine apply_bconds() + implicit none + integer :: i,j,k + + ! Apply clipped Neumann on primitive variables in x+ + if (.not.fs%cfg%xper.and.fs%cfg%iproc.eq.fs%cfg%npx) then + do k=fs%cfg%kmino_,fs%cfg%kmaxo_; do j=fs%cfg%jmino_,fs%cfg%jmaxo_ + ! Copy over from imax to imax+1 and above + do i=fs%cfg%imax+1,fs%cfg%imaxo + ! Copy primitive variables + ls%VF(i,j,k)=ls%VF(fs%cfg%imax,j,k) + fs%Q(i,j,k,1)=fs%Q(fs%cfg%imax,j,k,1) + fs%P(i,j,k)=fs%P(fs%cfg%imax,j,k) + fs%I(i,j,k)=fs%I(fs%cfg%imax,j,k) + fs%U(i,j,k)=max(fs%U(fs%cfg%imax,j,k),0.0_WP) + fs%V(i,j,k)=fs%V(fs%cfg%imax,j,k) + fs%W(i,j,k)=fs%W(fs%cfg%imax,j,k) + end do + end do; end do + end if + + ! Apply clipped Neumann on primitive variables in y+ + if (.not.fs%cfg%yper.and.fs%cfg%jproc.eq.fs%cfg%npy) then + do k=fs%cfg%kmino_,fs%cfg%kmaxo_; do i=fs%cfg%imino_,fs%cfg%imaxo_ + ! Copy over from jmax to jmax+1 and above + do j=fs%cfg%jmax+1,fs%cfg%jmaxo + ! Copy primitive variables + ls%VF(i,j,k)=ls%VF(i,fs%cfg%jmax,k) + fs%Q(i,j,k,1)=fs%Q(i,fs%cfg%jmax,k,1) + fs%P(i,j,k)=fs%P(i,fs%cfg%jmax,k) + fs%I(i,j,k)=fs%I(i,fs%cfg%jmax,k) + fs%U(i,j,k)=fs%U(i,fs%cfg%jmax,k) + fs%V(i,j,k)=max(fs%V(i,fs%cfg%jmax,k),0.0_WP) + fs%W(i,j,k)=fs%W(i,fs%cfg%jmax,k) + end do + end do; end do + end if + + ! Apply clipped Neumann on primitive variables in y- + if (.not.fs%cfg%yper.and.fs%cfg%jproc.eq.1) then + do k=fs%cfg%kmino_,fs%cfg%kmaxo_; do i=fs%cfg%imino_,fs%cfg%imaxo_ + ! First copy over V from jmin+1 to jmin + fs%V(i,fs%cfg%jmin,k)=min(fs%V(i,fs%cfg%jmin+1,k),0.0_WP) + ! Then copy over from jmin to jmin-1 and below + do j=fs%cfg%jmino,fs%cfg%jmin-1 + ! Copy primitive variables + ls%VF(i,j,k)=ls%VF(i,fs%cfg%jmin,k) + fs%Q(i,j,k,1)=fs%Q(i,fs%cfg%jmin,k,1) + fs%P(i,j,k)=fs%P(i,fs%cfg%jmin,k) + fs%I(i,j,k)=fs%I(i,fs%cfg%jmin,k) + fs%U(i,j,k)=fs%U(i,fs%cfg%jmin,k) + fs%V(i,j,k)=min(fs%V(i,fs%cfg%jmin,k),0.0_WP) + fs%W(i,j,k)=fs%W(i,fs%cfg%jmin,k) + end do + end do; end do + end if + + ! Apply clipped Neumann on primitive variables in z+ + if (.not.fs%cfg%zper.and.fs%cfg%kproc.eq.fs%cfg%npz) then + do j=fs%cfg%jmino_,fs%cfg%jmaxo_; do i=fs%cfg%imino_,fs%cfg%imaxo_ + ! Copy over from kmax to kmax+1 and above + do k=fs%cfg%kmax+1,fs%cfg%kmaxo + ! Copy primitive variables + ls%VF(i,j,k)=ls%VF(i,j,fs%cfg%kmax) + fs%Q(i,j,k,1)=fs%Q(i,j,fs%cfg%kmax,1) + fs%P(i,j,k)=fs%P(i,j,fs%cfg%kmax) + fs%I(i,j,k)=fs%I(i,j,fs%cfg%kmax) + fs%U(i,j,k)=fs%U(i,j,fs%cfg%kmax) + fs%V(i,j,k)=fs%V(i,j,fs%cfg%kmax) + fs%W(i,j,k)=max(fs%W(i,j,fs%cfg%kmax),0.0_WP) + end do + end do; end do + end if + + ! Apply clipped Neumann on primitive variables in z- + if (.not.fs%cfg%zper.and.fs%cfg%kproc.eq.1) then + do j=fs%cfg%jmino_,fs%cfg%jmaxo_; do i=fs%cfg%imino_,fs%cfg%imaxo_ + ! First copy over W from kmin+1 to kmin + fs%W(i,j,fs%cfg%kmin)=min(fs%W(i,j,fs%cfg%kmin+1),0.0_WP) + ! Then copy over from kmin to kmin-1 and below + do k=fs%cfg%kmino,fs%cfg%kmin-1 + ! Copy primitive variables + ls%VF(i,j,k)=ls%VF(i,j,fs%cfg%kmin) + fs%Q(i,j,k,1)=fs%Q(i,j,fs%cfg%kmin,1) + fs%P(i,j,k)=fs%P(i,j,fs%cfg%kmin) + fs%I(i,j,k)=fs%I(i,j,fs%cfg%kmin) + fs%U(i,j,k)=fs%U(i,j,fs%cfg%kmin) + fs%V(i,j,k)=fs%V(i,j,fs%cfg%kmin) + fs%W(i,j,k)=min(fs%W(i,j,fs%cfg%kmin),0.0_WP) + end do + end do; end do + end if + + ! Rebuild conserved quantities + fs%Q(:,:,:,2)=fs%Q(:,:,:,1)*fs%I + call fs%get_momentum() + + end subroutine apply_bconds + + + !> Initialization of problem solver + subroutine simulation_init + + use param, only: param_read,param_exists + implicit none + + ! Allocate work arrays + allocate_work_arrays: block + allocate(dQdt (cfg%imino_:cfg%imaxo_,cfg%jmino_:cfg%jmaxo_,cfg%kmino_:cfg%kmaxo_,1:5,1:4)) + end block allocate_work_arrays + + ! Initialize time tracker with 2 subiterations + initialize_timetracker: block + time=timetracker(amRoot=cfg%amRoot) + call param_read('Max timestep size',time%dtmax) + call param_read('Max cfl number',time%cflmax) + call param_read('Max time',time%tmax) + time%dt=time%dtmax + time%itmax=2 + end block initialize_timetracker + + + + ! ! Initialize Lagrangian solid solver + ! initialize_lss: block + ! use mpi_f08, only: MPI_ALLREDUCE,MPI_MAX,MPI_INTEGER + ! real(WP) :: dx,mu,kk,max_stretch,Lx,Ly,Lz + ! real(WP) :: xmin,xmax,ymin,ymax,zmin,zmax,ratio,P_load + ! integer :: np,nt,nx,ny,nz,ierr,global_index + ! type triangle_type + ! real(WP), dimension(3) :: norm + ! real(WP), dimension(3) :: v1 + ! real(WP), dimension(3) :: v2 + ! real(WP), dimension(3) :: v3 + ! end type triangle_type + ! type(triangle_type), dimension(:), allocatable :: t + + + ! ! Create solver + ! ls=lss(cfg=cfg,name='solid') + ! !call fs%initialize(cfg=cfg,name='Compressible NS') + + + ! ! Set material properties + ! call param_read('Elastic Modulus',ls%elastic_modulus) + ! call param_read('Poisson Ratio',ls%poisson_ratio) + ! call param_read('Solid density',ls%rho) + ! call param_read('Critical Energy Release Rate',ls%crit_energy) + + ! ! Maximum timestep size used for particles + ! call param_read('Particle timestep size',ls_dt_max,default=huge(1.0_WP)) + ! ls_dt=min(ls_dt_max,time%dtmax) + + ! ! Discretization + ! ! ls%delta=fs%cfg%min_meshsize*1.01 + ! ! Load',P_load) + ! call param_read('Lx',Lx) + ! call param_read('Ly',Ly) + ! call param_read('Lz',Lz) + ! call param_read('Subdivisions',ny) + ! nz = ny + ! nx = NINT(Lx/Lz)*ny + ! call param_read('Horizon Ratio',ratio) + ! ls%delta = Ly/real(ny,WP)*ratio + ! ! Output some info on stretch + ! mu=ls%elastic_modulus/(2.0_WP+2.0_WP*ls%poisson_ratio) + ! kk=ls%elastic_modulus/(3.0_WP-6.0_WP*ls%poisson_ratio) + ! max_stretch=sqrt(ls%crit_energy/((3.0_WP*mu+(kk-5.0_WP*mu/3.0_WP)*0.75_WP**4)*ls%delta)) + + ! ! Only root process initializes solid particles + ! if (ls%cfg%amRoot) then + ! ! Read the STL file and get domain extents and levelset + ! print*, Lx * Ly * Lz / real(ny*nz*nx,WP) + ! read_bin: block + + ! use messager, only: die + ! integer :: p,iunit,ierr, wall_np, i, j, k + ! global_index = 0 + ! target_index = 0 + + ! ! Read in grid definition + ! wall_np = ny*nz*(nx+3) + ! ! call ls%resize(np+wall_np) + ! call ls%resize(wall_np) + ! p=0 + ! do i=1,nx+3 + ! do j=1,ny + ! do k=1,nz + ! p = p+1 + ! ls%p(p)%pos(1) = (i-1) * (Lx/real(nx,WP)) + ! ls%p(p)%pos(2) = (j) * (Ly/real(ny,WP)) - Ly/2.0_WP + ! ls%p(p)%pos(3) = (k) * (Lz/real(nz,WP)) - Lz/2.0_WP + ! ls%p(p)%vol = Lx * Ly * Lz / real(ny*nz*nx,WP) + ! ls%p(p)%id=1 + ! if(i.le.3) ls%p(p)%id=-2 + + ! ls%p(p)%vel=[0.0_WP,0.0_WP,0.0_WP] + ! ! Zero out force + ! ls%p(p)%Abond=0.0_WP + ! ! Zero out fluid unless end, using this for the load + ! ls%p(p)%Afluid=0.0_WP + ! !if(i.eq.nx+3) ls%p(p)%Afluid=[(P_load*Ly*Lz)/(ls%rho*ls%p(p)%vol),0.0_WP,0.0_WP] + ! ! Locate the particle on the mesh + ! ls%p(p)%ind=ls%cfg%get_ijk_global(ls%p(p)%pos,[ls%cfg%imin,ls%cfg%jmin,ls%cfg%kmin]) + ! ! Assign a unique integer to particle + ! ls%p(p)%i=p + ! ! Activate the particle + ! ls%p(p)%flag=0 + ! if(i.eq.(nx/2+1).and.j.eq.(ny/2+1).and.k.eq.(nz/2+1)) target_index = p + ! end do + ! end do + ! end do + + ! np = wall_np + ! end block read_bin + ! end if + + ! ! Allreduce with MPI_MAX ensures the nonzero index propagates to all + ! call MPI_ALLREDUCE(target_index, global_index, 1, MPI_INTEGER, MPI_MAX, ls%cfg%comm, ierr) + + ! ! Update target_index globally + ! target_index = global_index + + + ! ! Communicate particles + ! call ls%sync() + + ! call get_tracked_particle() + + ! ! Get initial volume fraction + ! ! call ls%update_VF() + + ! ! Initalize bonds + ! call ls%bond_init() + + ! if (ls%cfg%amRoot) then + ! print*,"===== Solid Setup Description =====" + ! print*,'Number of particles', np + ! print*,'Maximum stretching =',max_stretch + ! end if + + ! end block initialize_lss + + initialize_lss: block + use mpi_f08, only: MPI_ALLREDUCE,MPI_MAX,MPI_INTEGER + real(WP) :: dx,mu,kk,max_stretch,Lx,Ly,Lz,R,x,y,z + real(WP) :: xmin,xmax,ymin,ymax,zmin,zmax,ratio,dist + integer :: np,nt,nx,ny,nz,ierr,global_index + type triangle_type + real(WP), dimension(3) :: norm + real(WP), dimension(3) :: v1 + real(WP), dimension(3) :: v2 + real(WP), dimension(3) :: v3 + end type triangle_type + type(triangle_type), dimension(:), allocatable :: t + + + + + ! Create solver + ls=lss(cfg=cfg,name='solid') + !call fs%initialize(cfg=cfg,name='Compressible NS') + + + ! Set material properties + call param_read('Elastic Modulus',ls%elastic_modulus) + call param_read('Poisson Ratio',ls%poisson_ratio) + call param_read('Solid density',ls%rho) + call param_read('Critical Energy Release Rate',ls%crit_energy) + + ! Maximum timestep size used for particles + call param_read('Particle timestep size',ls_dt_max,default=huge(1.0_WP)) + ls_dt=min(ls_dt_max,time%dtmax) + + ! Discretization + ! ls%delta=fs%cfg%min_meshsize*1.01 + ! Load',P_load) + call param_read('Lx',Lx) + call param_read('Ly',Ly) + call param_read('Lz',Lz) + call param_read('R',R) + call param_read('Solid Spacing',dist) + ! Lx = 1.0_WP + ! Ly = 1.0_WP + ! dist = 0.01_WP ! Space between particles + Lx = Lx + 3.0_WP * dist + ! Ly = Ly + 3.0_WP * dist + + ny = ceiling(Ly/dist) + nz = ceiling(Lz/dist) + nx = ceiling(Lx/dist) + call param_read('Horizon Ratio',ratio) + ls%delta = dist*ratio + print*, ls%delta + ! Output some info on stretch + mu=ls%elastic_modulus/(2.0_WP+2.0_WP*ls%poisson_ratio) + kk=ls%elastic_modulus/(3.0_WP-6.0_WP*ls%poisson_ratio) + max_stretch=sqrt(ls%crit_energy/((3.0_WP*mu+(kk-5.0_WP*mu/3.0_WP)*0.75_WP**4)*ls%delta)) + + ! Only root process initializes solid particles + if (ls%cfg%amRoot) then + ! Read the STL fiprint*, "here" + read_bin: block + + use messager, only: die + integer :: p,iunit,ierr, wall_np, i, j, k + real(WP) :: net_vol + net_vol = 0.0_WP + global_index = 0 + target_index = 0 + ! Read in grid definition + wall_np = (ny)*(nz)*(nx) + ! call ls%resize(np+wall_np) + call ls%resize(wall_np) + p=0 + do i=1,nx + do j=1,ny + do k=1,nz + x = (i-1) * dist - Lx/2.0_WP; + y = (j-1) * (dist) - Ly/2.0_WP + z = (k-1) * (dist) - Lz/2.0_WP - dist + if ((x*x + y*y).lt.R*R) cycle; + p = p+1 + + ls%p(p)%pos(1) = x + ls%p(p)%pos(2) = y + ls%p(p)%pos(3) = z + ls%p(p)%ipos=ls%p(p)%pos + ls%p(p)%displacement=0.0_WP + ls%p(p)%vol = dist*dist*dist + ls%p(p)%gd = 1.0_WP + ls%p(p)%gb = 1.0_WP + ls%p(p)%id=1 + if(i.le.3) ls%p(p)%id=-1 + if(i.ge.nx-2) ls%p(p)%id=-1 + + ls%p(p)%vel=[0.0_WP,0.0_WP,0.0_WP] + if(ls%p(p)%id.eq.-1.and.ls%p(p)%pos(1).gt.0) ls%p(p)%vel=[0.01_WP,0.0_WP,0.0_WP] + if(ls%p(p)%id.eq.-1.and.ls%p(p)%pos(1).lt.0) ls%p(p)%id=-2 + ! if(i.gt.3) net_vol=net_vol+ls%p(p)%vol + ! Zero out force + ls%p(p)%Abond=0.0_WP + ! Zero out fluid unless end, using this for the load + ls%p(p)%Afluid=0.0_WP + !if(i.eq.nx+3) ls%p(p)%Afluid=[(P_load*Ly*Lz)/(ls%rho*ls%p(p)%vol),0.0_WP,0.0_WP] + ! Locate the particle on the mesh + ls%p(p)%ind=ls%cfg%get_ijk_global(ls%p(p)%pos,[ls%cfg%imin,ls%cfg%jmin,ls%cfg%kmin]) + ! Assign a unique integer to particle + ls%p(p)%i=p + ! Activate the particle + ls%p(p)%flag=0 + if(i.eq.(nx/2+2).and.j.eq.(5).and.k.eq.(5)) target_index = p + end do + end do + end do + + np = wall_np + print*, "Net Volume: ", net_vol + end block read_bin + end if + + ! Allreduce with MPI_MAX ensures the nonzero index propagates to all + call MPI_ALLREDUCE(target_index, global_index, 1, MPI_INTEGER, MPI_MAX, ls%cfg%comm, ierr) + + ! Update target_index globally + target_index = global_index + + + ! Communicate particles + call ls%sync() + + call get_tracked_particle() + + ! Get initial volume fraction + ! call ls%update_VF() + + ! Initalize bonds + call ls%bond_init() + + if (ls%cfg%amRoot) then + print*,"===== Solid Setup Description =====" + print*,'Number of particles', np + print*,'Maximum stretching =',max_stretch + end if + + end block initialize_lss + + + ! Create partmesh object for visualizing Lagrangian particles + create_pmesh: block + use lss_class, only: max_bond + integer :: i,n,nbond + pmesh=partmesh(nvar=5,nvec=3,name='solid') + pmesh%varname(1)='failfrac' + pmesh%varname(2)='dilatation' + pmesh%varname(3)='id' + pmesh%varname(4)='nbond' + pmesh%varname(5)='von-Mises' + + pmesh%vecname(1)='velocity' + pmesh%vecname(2)='bond_force' + pmesh%vecname(3)='disp' + call ls%update_partmesh(pmesh) + do i=1,ls%np_ + pmesh%var(1,i)=0.0_WP + nbond=0 + do n=1,max_bond + if (ls%p(i)%ibond(n).gt.0) nbond=nbond+1 + end do + if (ls%p(i)%nbond.gt.0) then + pmesh%var(1,i)=1.0_WP-real(nbond,WP)/real(ls%p(i)%nbond,WP) + else + pmesh%var(1,i)=0.0_WP + end if + pmesh%var(2,i) =ls%p(i)%dil + pmesh%var(3,i) =ls%p(i)%id + pmesh%vec(:,1,i)=ls%p(i)%vel + pmesh%vec(:,2,i)=ls%p(i)%Abond + pmesh%var(4,i) =ls%p(i)%nbond + pmesh%var(5,i) =ls%p(i)%vonMises + pmesh%vec(:,3,i) =ls%p(i)%displacement + end do + end block create_pmesh + + ! Add Ensight output + create_ensight: block + ! Create Ensight output from cfg + ens_out=ensight(cfg=cfg,name='shock') + ! Create event for Ensight output + ens_evt=event(time=time,name='Ensight output') + call param_read('Ensight output period',ens_evt%tper) + ! Add variables to output + call ens_out%add_particle('particles',pmesh) + ! Output to ensight + if (ens_evt%occurs()) call ens_out%write_data(time%t) + end block create_ensight + + + ! Create monitor files + create_monitor: block + real(WP) :: cfl + ! Prepare some info about fields + call ls%get_cfl(time%dt,time%cfl) + call ls%get_max() + ! Create solid monitor + sfile=monitor(ls%cfg%amRoot,'solid') + call sfile%add_column(time%n,'Timestep number') + call sfile%add_column(time%t,'Time') + call sfile%add_column(ls_dt,'Particle dt') + call sfile%add_column(time%cfl,'Maximum CFL') + call sfile%add_column(ls%np,'Particle number') + call sfile%add_column(ls%VFmax,'VFmax') + call sfile%add_column(ls%Umin,'Particle Umin') + call sfile%add_column(ls%Umax,'Particle Umax') + call sfile%add_column(ls%Vmin,'Particle Vmin') + call sfile%add_column(ls%Vmax,'Particle Vmax') + call sfile%add_column(ls%Wmin,'Particle Wmin') + call sfile%add_column(ls%Wmax,'Particle Wmax') + call sfile%add_column(ls%ibmForce(1),'Particle Fx') + call sfile%add_column(ls%ibmForce(2),'Particle Fy') + call sfile%add_column(ls%ibmForce(3),'Particle Fz') + call sfile%write() + dispfile=monitor(ls%cfg%amRoot,'displacement') + call dispfile%add_column(time%n,'Timestep number') + call dispfile%add_column(time%t,'Time') + call dispfile%add_column(ls_dt,'Particle dt') + call dispfile%add_column(target_position(1),'X') + call dispfile%add_column(target_position(2),'Y') + call dispfile%add_column(target_position(3),'Z') + call dispfile%write() + end block create_monitor + + end subroutine simulation_init + + + !> Perform an NGA2 simulation + subroutine simulation_run + implicit none + real(WP) :: cfl + logical :: first_time + + first_time = .true. + ! Perform time integration + do while (.not.time%done()) + + ! Increment time + call ls%get_cfl(time%dt,time%cfl) + ! call fs%get_cfl(time%dt,cfl); time%cfl=max(time%cfl,cfl) + call time%adjust_dt() + call time%increment() + + ! Advance solid solver + solid: block + real(WP) :: dt_done,mydt + ! Sub-iteratore + call ls%get_cfl(ls_dt,cfl=cfl) + if (cfl.gt.0.0_WP) ls_dt=min(ls_dt*time%cflmax/cfl,ls_dt_max) + dt_done=0.0_WP + do while (dt_done.lt.time%dtmid) + ! Decide the timestep size + if(first_time) then + call ls%stretch(dt =mydt) + first_time=.false. + dt_done=dt_done+mydt + else + mydt=min(ls_dt,time%dtmid-dt_done) + ! ! Advance particles + call ls%advance(dt =mydt) + ! ! Increment + dt_done=dt_done+mydt + end if + + + ! mydt=min(ls_dt,time%dtmid-dt_done) + ! ! Advance particles + ! call ls%advance(dt =mydt) + ! ! ! Increment + ! dt_done=dt_done+mydt + + end do + end block solid + + !> Perform and output monitoring + call ls%get_max() + call get_tracked_particle() + call sfile%write() + call dispfile%write() + + + ! Output to ensight + if (ens_evt%occurs()) then + update_pmesh: block + use lss_class, only: max_bond + integer :: i,n,nbond + call ls%update_partmesh(pmesh) + do i=1,ls%np_ + nbond=0 + do n=1,max_bond + if (ls%p(i)%ibond(n).gt.0) nbond=nbond+1 + end do + if (ls%p(i)%nbond.gt.0) then + pmesh%var(1,i)=1.0_WP-real(nbond,WP)/real(ls%p(i)%nbond,WP) + else + pmesh%var(1,i)=0.0_WP + end if + pmesh%var(2,i) =ls%p(i)%dil + pmesh%var(3,i) =ls%p(i)%id + pmesh%vec(:,1,i)=ls%p(i)%vel + pmesh%vec(:,2,i)=ls%p(i)%Abond + pmesh%var(4,i) =ls%p(i)%nbond + pmesh%var(5,i) =ls%p(i)%vonMises + pmesh%vec(:,3,i) =ls%p(i)%displacement + + + end do + end block update_pmesh + call ens_out%write_data(time%t) + end if + + end do + + end subroutine simulation_run + + + !> Finalize the NGA2 simulation + subroutine simulation_final + implicit none + + ! Get rid of all objects - need destructors + ! monitor + ! ensight + ! bcond + ! timetracker + + ! Deallocate work arrays + deallocate(dQdt) + end subroutine simulation_final + + +end module simulation diff --git a/examples/plate_with_hole/src/simulation_stl.f90 b/examples/plate_with_hole/src/simulation_stl.f90 new file mode 100644 index 000000000..2cf330826 --- /dev/null +++ b/examples/plate_with_hole/src/simulation_stl.f90 @@ -0,0 +1,753 @@ +!> Various definitions and tools for running an NGA2 simulation +module simulation + use precision, only: WP,SP + use geometry, only: cfg + use spcomp_class, only: spcomp + use lss_class, only: lss + use timetracker_class, only: timetracker + use ensight_class, only: ensight + use partmesh_class, only: partmesh + use event_class, only: event + use monitor_class, only: monitor + implicit none + private + + !> Get a couple linear solvers, an incompressible flow solver and corresponding time tracker + type(spcomp), public :: fs + type(lss), public :: ls + type(timetracker), public :: time + + !> Ensight postprocessing + type(partmesh) :: pmesh + type(ensight) :: ens_out + type(event) :: ens_evt + + !> Simulation monitor file + type(monitor) :: mfile,cflfile,consfile,sfile,dispfile + + public :: simulation_init,simulation_run,simulation_final + + !> Private work arrays + real(WP), dimension(:,:,:,:,:), allocatable :: dQdt + real(WP), dimension(:,:,:) , allocatable :: Ui,Vi,Wi,Ma,beta,visc,visc_t,div + !> Post-shock viscosity and temperature + real(WP) :: visc0,T0 + + !> Equations of state + real(WP) :: Pinf,Gamma,Cv,Prandtl + + !> Flow parameters + real(WP) :: Ms,Xs,Rcyl + real(WP) :: rho1,p1,u1,M1 + real(WP) :: rho2,p2,u2,M2 + real(WP) :: Re + + !> Max timestep size for solid solver + real(WP) :: ls_dt,ls_dt_max + + integer :: target_index + real(WP), dimension(3) :: target_position + + + contains + + + !> Function that returns a smooth Heaviside of thickness delta + real(WP) function Hshock(x,delta) + real(WP), intent(in) :: x,delta + ! Goes from 0 to 1 as x goes from begative to positive + Hshock=1.0_WP/(1.0_WP+exp(-x/delta)) + end function Hshock + + !> P=EOS(RHO,I) + pure real(WP) function get_P(RHO,I) + implicit none + real(WP), intent(in) :: RHO,I + get_P=RHO*I*(Gamma-1.0_WP)-Gamma*Pinf + end function get_P + !> T=f(RHO,P) + pure real(WP) function get_T(RHO,P) + implicit none + real(WP), intent(in) :: RHO,P + get_T=(P+Pinf)/(Cv*RHO*(Gamma-1.0_WP)) + end function get_T + !> RHO=f(T,P) + pure real(WP) function get_RHO(T,P) + implicit none + real(WP), intent(in) :: T,P + get_RHO=(P+Pinf)/(Cv*T*(Gamma-1.0_WP)) + end function get_RHO + !> I=EOS(RHO,P) + pure real(WP) function get_I(RHO,P) + implicit none + real(WP), intent(in) :: RHO,P + get_I=(P+Gamma*Pinf)/(RHO*(Gamma-1.0_WP)) + end function get_I + !> C=f(RHO,P) + pure real(WP) function get_C(RHO,P) + implicit none + real(WP), intent(in) :: RHO,P + get_C=sqrt(Gamma*(P+Pinf)/RHO) + end function get_C + !> S=f(RHO,P) + pure real(WP) function get_S(RHO,P) + implicit none + real(WP), intent(in) :: RHO,P + get_S=Cv*log((P+Pinf)/RHO**Gamma) + end function get_S + + subroutine get_tracked_particle() + use mpi_f08 + implicit none + integer :: i, ierr + real(WP) :: local_pos(3), global_pos(3) + + local_pos = 0.0_WP + + do i=1,ls%np_ + if (ls%p(i)%i.eq.target_index) then + local_pos = ls%p(i)%pos + end if + end do + call MPI_ALLREDUCE(local_pos, global_pos, 3, MPI_DOUBLE_PRECISION, MPI_SUM, ls%cfg%comm, ierr) + + target_position = global_pos + end subroutine + + !> Calculate viscosities + subroutine prepare_viscosities() + implicit none + integer :: i,j,k + real(WP) :: S + ! Get viscosity from Sutherland's law + S=110.4_WP/273.15_WP*T0 + do k=fs%cfg%kmino_,fs%cfg%kmaxo_ + do j=fs%cfg%jmino_,fs%cfg%jmaxo_ + do i=fs%cfg%imino_,fs%cfg%imaxo_ + visc(i,j,k)=visc0*(T0+S)/(fs%T(i,j,k)+S)*(fs%T(i,j,k)/T0)**1.5_WP + end do + end do + end do + ! Get LAD + call fs%get_viscartif(dt=time%dt,beta=beta); fs%BETA=fs%Q(:,:,:,1)*beta + ! Get eddy viscosity + call fs%get_vreman (dt=time%dt,visc=visc_t); fs%VISC=fs%Q(:,:,:,1)*visc_t+visc + ! Recompute thermal conductivity + fs%diff=Gamma*Cv*fs%visc/Prandtl + ! Add LAD + fs%VISC=fs%VISC+0.002_WP*fs%BETA + end subroutine prepare_viscosities + + + !> Calculate velocity divergence + subroutine get_div() + implicit none + integer :: i,j,k + do k=fs%cfg%kmino_,fs%cfg%kmaxo_-1; do j=fs%cfg%jmino_,fs%cfg%jmaxo_-1; do i=fs%cfg%imino_,fs%cfg%imaxo_-1 + div(i,j,k)=fs%dxi*(fs%U(i+1,j,k)-fs%U(i,j,k))+fs%dyi*(fs%V(i,j+1,k)-fs%V(i,j,k))+fs%dzi*(fs%W(i,j,k+1)-fs%W(i,j,k)) + end do; end do; end do + call fs%cfg%sync(div) + if (.not.fs%cfg%xper.and.fs%cfg%iproc.eq.fs%cfg%npx) div(fs%cfg%imaxo,:,:)=div(fs%cfg%imaxo-1,:,:) + if (.not.fs%cfg%yper.and.fs%cfg%jproc.eq.fs%cfg%npy) div(:,fs%cfg%jmaxo,:)=div(:,fs%cfg%jmaxo-1,:) + if (.not.fs%cfg%zper.and.fs%cfg%kproc.eq.fs%cfg%npz) div(:,:,fs%cfg%kmaxo)=div(:,:,fs%cfg%kmaxo-1) + end subroutine get_div + + + !> Overwrite cosnerved variables using volume-of-solid IBM + subroutine apply_ibm() + implicit none + integer :: i,j,k,ii,jj,kk + real(WP) :: sum_VF,sum_VFQ1,sum_VFQ2 + do k=cfg%kmin_,cfg%kmax_ + do j=cfg%jmin_,cfg%jmax_ + do i=cfg%imin_,cfg%imax_ + if (ls%VF(i,j,k).eq.0.0_WP) cycle + ! Neumann: VF-weighted neighbor average for Q(1) and Q(2) + sum_VF=0.0_WP; sum_VFQ1=0.0_WP; sum_VFQ2=0.0_WP + do kk=-1,1; do jj=-1,1; do ii=-1,1 + if (ii.eq.0.and.jj.eq.0.and.kk.eq.0) cycle + sum_VF =sum_VF +(1.0_WP-ls%VF(i+ii,j+jj,k+kk)) + sum_VFQ1=sum_VFQ1+(1.0_WP-ls%VF(i+ii,j+jj,k+kk))*fs%Q(i+ii,j+jj,k+kk,1) + sum_VFQ2=sum_VFQ2+(1.0_WP-ls%VF(i+ii,j+jj,k+kk))*fs%Q(i+ii,j+jj,k+kk,2) + end do; end do; end do + if (sum_VF.gt.0.0_WP) then + fs%Q(i,j,k,1)=(1.0_WP-ls%VF(i,j,k))*fs%Q(i,j,k,1)+ls%VF(i,j,k)*sum_VFQ1/sum_VF + fs%Q(i,j,k,2)=(1.0_WP-ls%VF(i,j,k))*fs%Q(i,j,k,2)+ls%VF(i,j,k)*sum_VFQ2/sum_VF + end if + ! No-slip now that density is determined + fs%Q(i,j,k,3)=(1.0_WP-0.5_WP*(ls%VF(i-1,j,k)+ls%VF(i,j,k)))*fs%Q(i,j,k,3)+0.5_WP*(fs%Q(i-1,j,k,1)+fs%Q(i,j,k,1))*ls%VFU(i,j,k) + fs%Q(i,j,k,4)=(1.0_WP-0.5_WP*(ls%VF(i,j-1,k)+ls%VF(i,j,k)))*fs%Q(i,j,k,4)+0.5_WP*(fs%Q(i,j-1,k,1)+fs%Q(i,j,k,1))*ls%VFV(i,j,k) + fs%Q(i,j,k,5)=(1.0_WP-0.5_WP*(ls%VF(i,j,k-1)+ls%VF(i,j,k)))*fs%Q(i,j,k,5)+0.5_WP*(fs%Q(i,j,k-1,1)+fs%Q(i,j,k,1))*ls%VFW(i,j,k) + end do + end do + end do + ! Communicate + call fs%cfg%sync(fs%Q(:,:,:,1)) + call fs%cfg%sync(fs%Q(:,:,:,2)) + call fs%cfg%sync(fs%Q(:,:,:,3)) + call fs%cfg%sync(fs%Q(:,:,:,4)) + call fs%cfg%sync(fs%Q(:,:,:,5)) + ! Rebuild primitive variables + call fs%get_primitive() + end subroutine apply_ibm + + + !> Apply boundary conditions + subroutine apply_bconds() + implicit none + integer :: i,j,k + + ! Apply clipped Neumann on primitive variables in x+ + if (.not.fs%cfg%xper.and.fs%cfg%iproc.eq.fs%cfg%npx) then + do k=fs%cfg%kmino_,fs%cfg%kmaxo_; do j=fs%cfg%jmino_,fs%cfg%jmaxo_ + ! Copy over from imax to imax+1 and above + do i=fs%cfg%imax+1,fs%cfg%imaxo + ! Copy primitive variables + ls%VF(i,j,k)=ls%VF(fs%cfg%imax,j,k) + fs%Q(i,j,k,1)=fs%Q(fs%cfg%imax,j,k,1) + fs%P(i,j,k)=fs%P(fs%cfg%imax,j,k) + fs%I(i,j,k)=fs%I(fs%cfg%imax,j,k) + fs%U(i,j,k)=max(fs%U(fs%cfg%imax,j,k),0.0_WP) + fs%V(i,j,k)=fs%V(fs%cfg%imax,j,k) + fs%W(i,j,k)=fs%W(fs%cfg%imax,j,k) + end do + end do; end do + end if + + ! Apply clipped Neumann on primitive variables in y+ + if (.not.fs%cfg%yper.and.fs%cfg%jproc.eq.fs%cfg%npy) then + do k=fs%cfg%kmino_,fs%cfg%kmaxo_; do i=fs%cfg%imino_,fs%cfg%imaxo_ + ! Copy over from jmax to jmax+1 and above + do j=fs%cfg%jmax+1,fs%cfg%jmaxo + ! Copy primitive variables + ls%VF(i,j,k)=ls%VF(i,fs%cfg%jmax,k) + fs%Q(i,j,k,1)=fs%Q(i,fs%cfg%jmax,k,1) + fs%P(i,j,k)=fs%P(i,fs%cfg%jmax,k) + fs%I(i,j,k)=fs%I(i,fs%cfg%jmax,k) + fs%U(i,j,k)=fs%U(i,fs%cfg%jmax,k) + fs%V(i,j,k)=max(fs%V(i,fs%cfg%jmax,k),0.0_WP) + fs%W(i,j,k)=fs%W(i,fs%cfg%jmax,k) + end do + end do; end do + end if + + ! Apply clipped Neumann on primitive variables in y- + if (.not.fs%cfg%yper.and.fs%cfg%jproc.eq.1) then + do k=fs%cfg%kmino_,fs%cfg%kmaxo_; do i=fs%cfg%imino_,fs%cfg%imaxo_ + ! First copy over V from jmin+1 to jmin + fs%V(i,fs%cfg%jmin,k)=min(fs%V(i,fs%cfg%jmin+1,k),0.0_WP) + ! Then copy over from jmin to jmin-1 and below + do j=fs%cfg%jmino,fs%cfg%jmin-1 + ! Copy primitive variables + ls%VF(i,j,k)=ls%VF(i,fs%cfg%jmin,k) + fs%Q(i,j,k,1)=fs%Q(i,fs%cfg%jmin,k,1) + fs%P(i,j,k)=fs%P(i,fs%cfg%jmin,k) + fs%I(i,j,k)=fs%I(i,fs%cfg%jmin,k) + fs%U(i,j,k)=fs%U(i,fs%cfg%jmin,k) + fs%V(i,j,k)=min(fs%V(i,fs%cfg%jmin,k),0.0_WP) + fs%W(i,j,k)=fs%W(i,fs%cfg%jmin,k) + end do + end do; end do + end if + + ! Apply clipped Neumann on primitive variables in z+ + if (.not.fs%cfg%zper.and.fs%cfg%kproc.eq.fs%cfg%npz) then + do j=fs%cfg%jmino_,fs%cfg%jmaxo_; do i=fs%cfg%imino_,fs%cfg%imaxo_ + ! Copy over from kmax to kmax+1 and above + do k=fs%cfg%kmax+1,fs%cfg%kmaxo + ! Copy primitive variables + ls%VF(i,j,k)=ls%VF(i,j,fs%cfg%kmax) + fs%Q(i,j,k,1)=fs%Q(i,j,fs%cfg%kmax,1) + fs%P(i,j,k)=fs%P(i,j,fs%cfg%kmax) + fs%I(i,j,k)=fs%I(i,j,fs%cfg%kmax) + fs%U(i,j,k)=fs%U(i,j,fs%cfg%kmax) + fs%V(i,j,k)=fs%V(i,j,fs%cfg%kmax) + fs%W(i,j,k)=max(fs%W(i,j,fs%cfg%kmax),0.0_WP) + end do + end do; end do + end if + + ! Apply clipped Neumann on primitive variables in z- + if (.not.fs%cfg%zper.and.fs%cfg%kproc.eq.1) then + do j=fs%cfg%jmino_,fs%cfg%jmaxo_; do i=fs%cfg%imino_,fs%cfg%imaxo_ + ! First copy over W from kmin+1 to kmin + fs%W(i,j,fs%cfg%kmin)=min(fs%W(i,j,fs%cfg%kmin+1),0.0_WP) + ! Then copy over from kmin to kmin-1 and below + do k=fs%cfg%kmino,fs%cfg%kmin-1 + ! Copy primitive variables + ls%VF(i,j,k)=ls%VF(i,j,fs%cfg%kmin) + fs%Q(i,j,k,1)=fs%Q(i,j,fs%cfg%kmin,1) + fs%P(i,j,k)=fs%P(i,j,fs%cfg%kmin) + fs%I(i,j,k)=fs%I(i,j,fs%cfg%kmin) + fs%U(i,j,k)=fs%U(i,j,fs%cfg%kmin) + fs%V(i,j,k)=fs%V(i,j,fs%cfg%kmin) + fs%W(i,j,k)=min(fs%W(i,j,fs%cfg%kmin),0.0_WP) + end do + end do; end do + end if + + ! Rebuild conserved quantities + fs%Q(:,:,:,2)=fs%Q(:,:,:,1)*fs%I + call fs%get_momentum() + + end subroutine apply_bconds + + + !> Initialization of problem solver + subroutine simulation_init + use param, only: param_read,param_exists + implicit none + + ! Allocate work arrays + allocate_work_arrays: block + allocate(dQdt (cfg%imino_:cfg%imaxo_,cfg%jmino_:cfg%jmaxo_,cfg%kmino_:cfg%kmaxo_,1:5,1:4)) + end block allocate_work_arrays + + ! Initialize time tracker with 2 subiterations + initialize_timetracker: block + time=timetracker(amRoot=cfg%amRoot) + call param_read('Max timestep size',time%dtmax) + call param_read('Max cfl number',time%cflmax) + call param_read('Max time',time%tmax) + time%dt=time%dtmax + time%itmax=2 + end block initialize_timetracker + + + + ! ! Initialize Lagrangian solid solver + ! initialize_lss: block + ! use mpi_f08, only: MPI_ALLREDUCE,MPI_MAX,MPI_INTEGER + ! real(WP) :: dx,mu,kk,max_stretch,Lx,Ly,Lz + ! real(WP) :: xmin,xmax,ymin,ymax,zmin,zmax,ratio,P_load + ! integer :: np,nt,nx,ny,nz,ierr,global_index + ! type triangle_type + ! real(WP), dimension(3) :: norm + ! real(WP), dimension(3) :: v1 + ! real(WP), dimension(3) :: v2 + ! real(WP), dimension(3) :: v3 + ! end type triangle_type + ! type(triangle_type), dimension(:), allocatable :: t + + + ! ! Create solver + ! ls=lss(cfg=cfg,name='solid') + ! !call fs%initialize(cfg=cfg,name='Compressible NS') + + + ! ! Set material properties + ! call param_read('Elastic Modulus',ls%elastic_modulus) + ! call param_read('Poisson Ratio',ls%poisson_ratio) + ! call param_read('Solid density',ls%rho) + ! call param_read('Critical Energy Release Rate',ls%crit_energy) + + ! ! Maximum timestep size used for particles + ! call param_read('Particle timestep size',ls_dt_max,default=huge(1.0_WP)) + ! ls_dt=min(ls_dt_max,time%dtmax) + + ! ! Discretization + ! ! ls%delta=fs%cfg%min_meshsize*1.01 + ! ! Load',P_load) + ! call param_read('Lx',Lx) + ! call param_read('Ly',Ly) + ! call param_read('Lz',Lz) + ! call param_read('Subdivisions',ny) + ! nz = ny + ! nx = NINT(Lx/Lz)*ny + ! call param_read('Horizon Ratio',ratio) + ! ls%delta = Ly/real(ny,WP)*ratio + ! ! Output some info on stretch + ! mu=ls%elastic_modulus/(2.0_WP+2.0_WP*ls%poisson_ratio) + ! kk=ls%elastic_modulus/(3.0_WP-6.0_WP*ls%poisson_ratio) + ! max_stretch=sqrt(ls%crit_energy/((3.0_WP*mu+(kk-5.0_WP*mu/3.0_WP)*0.75_WP**4)*ls%delta)) + + ! ! Only root process initializes solid particles + ! if (ls%cfg%amRoot) then + ! ! Read the STL file and get domain extents and levelset + ! print*, Lx * Ly * Lz / real(ny*nz*nx,WP) + ! read_bin: block + + ! use messager, only: die + ! integer :: p,iunit,ierr, wall_np, i, j, k + ! global_index = 0 + ! target_index = 0 + + ! ! Read in grid definition + ! wall_np = ny*nz*(nx+3) + ! ! call ls%resize(np+wall_np) + ! call ls%resize(wall_np) + ! p=0 + ! do i=1,nx+3 + ! do j=1,ny + ! do k=1,nz + ! p = p+1 + ! ls%p(p)%pos(1) = (i-1) * (Lx/real(nx,WP)) + ! ls%p(p)%pos(2) = (j) * (Ly/real(ny,WP)) - Ly/2.0_WP + ! ls%p(p)%pos(3) = (k) * (Lz/real(nz,WP)) - Lz/2.0_WP + ! ls%p(p)%vol = Lx * Ly * Lz / real(ny*nz*nx,WP) + ! ls%p(p)%id=1 + ! if(i.le.3) ls%p(p)%id=-2 + + ! ls%p(p)%vel=[0.0_WP,0.0_WP,0.0_WP] + ! ! Zero out force + ! ls%p(p)%Abond=0.0_WP + ! ! Zero out fluid unless end, using this for the load + ! ls%p(p)%Afluid=0.0_WP + ! !if(i.eq.nx+3) ls%p(p)%Afluid=[(P_load*Ly*Lz)/(ls%rho*ls%p(p)%vol),0.0_WP,0.0_WP] + ! ! Locate the particle on the mesh + ! ls%p(p)%ind=ls%cfg%get_ijk_global(ls%p(p)%pos,[ls%cfg%imin,ls%cfg%jmin,ls%cfg%kmin]) + ! ! Assign a unique integer to particle + ! ls%p(p)%i=p + ! ! Activate the particle + ! ls%p(p)%flag=0 + ! if(i.eq.(nx/2+1).and.j.eq.(ny/2+1).and.k.eq.(nz/2+1)) target_index = p + ! end do + ! end do + ! end do + + ! np = wall_np + ! end block read_bin + ! end if + + ! ! Allreduce with MPI_MAX ensures the nonzero index propagates to all + ! call MPI_ALLREDUCE(target_index, global_index, 1, MPI_INTEGER, MPI_MAX, ls%cfg%comm, ierr) + + ! ! Update target_index globally + ! target_index = global_index + + + ! ! Communicate particles + ! call ls%sync() + + ! call get_tracked_particle() + + ! ! Get initial volume fraction + ! ! call ls%update_VF() + + ! ! Initalize bonds + ! call ls%bond_init() + + ! if (ls%cfg%amRoot) then + ! print*,"===== Solid Setup Description =====" + ! print*,'Number of particles', np + ! print*,'Maximum stretching =',max_stretch + ! end if + + ! end block initialize_lss + + initialize_lss: block + use mpi_f08, only: MPI_ALLREDUCE,MPI_MAX,MPI_INTEGER + real(WP) :: dx,mu,kk,max_stretch,Lx,Ly,Lz + real(WP) :: xmin,xmax,ymin,ymax,zmin,zmax,ratio,dist,net_vol,center_dist,prev_center_dist + real(WP), dimension(3) :: location + integer :: np,nt,nx,ny,nz,ierr,global_index + type triangle_type + real(WP), dimension(3) :: norm + real(WP), dimension(3) :: v1 + real(WP), dimension(3) :: v2 + real(WP), dimension(3) :: v3 + end type triangle_type + type(triangle_type), dimension(:), allocatable :: t + + + location=[0.5_WP,0.03_WP,0.03_WP] + prev_center_dist=huge(1.0_WP) + + ! Create solver + ls=lss(cfg=cfg,name='solid') + !call fs%initialize(cfg=cfg,name='Compressible NS') + + + ! Set material properties + call param_read('Elastic Modulus',ls%elastic_modulus) + call param_read('Poisson Ratio',ls%poisson_ratio) + call param_read('Solid density',ls%rho) + call param_read('Critical Energy Release Rate',ls%crit_energy) + + ! Maximum timestep size used for particles + call param_read('Particle timestep size',ls_dt_max,default=huge(1.0_WP)) + ls_dt=min(ls_dt_max,time%dtmax) + + ! Discretization + ! ls%delta=fs%cfg%min_meshsize*1.01 + ! Load',P_load) + call param_read('Horizon Ratio',ratio) + call param_read('Mean Particle Spacing',dist) + call param_read('Lx',Lx) + Lx = Lx + 3.015_WP * dist + call param_read('Lz',Lz) + ! print *, Lz + + ls%delta = dist*ratio + print*, "Delta :", ls%delta + print*, "Required Bond Horizon Distance :", 3.0_WP*ls%delta + ! Output some info on stretch + mu=ls%elastic_modulus/(2.0_WP+2.0_WP*ls%poisson_ratio) + kk=ls%elastic_modulus/(3.0_WP-6.0_WP*ls%poisson_ratio) + max_stretch=sqrt(ls%crit_energy/((3.0_WP*mu+(kk-5.0_WP*mu/3.0_WP)*0.75_WP**4)*ls%delta)) + + ! Only root process initializes solid particles + if (ls%cfg%amRoot) then + ! Read the STL file and get domain extents and levelset + read_bin: block + use messager, only: die + integer :: p,iunit,ierr + character(len=80) :: partfile + call param_read('Particle file',partfile) + open(newunit=iunit,file=trim(partfile),access="stream",form="unformatted",action="read",status="old",iostat=ierr) + if(ierr.ne.0) call die('[read_stl] Could not open file: '//trim(partfile)) + read(iunit) np + call ls%resize(np) + do p=1,np + center_dist = 0.0_WP + read(iunit) ls%p(p)%pos(1), ls%p(p)%pos(2), ls%p(p)%pos(3), ls%p(p)%vol + ls%p(p)%id=1 + if(ls%p(p)%pos(1)<=epsilon(1.0_WP)) ls%p(p)%id=-2 + if(ls%p(p)%pos(1)>=(0.1_WP-epsilon(1.0_WP))) ls%p(p)%id=-1 + ls%p(p)%pos(1)=ls%p(p)%pos(1)-Lx/2.0_WP + ! ! print*, -Lz/2.0_WP + ls%p(p)%pos(3)=ls%p(p)%pos(3)-0.00175_WP + ls%p(p)%ipos=ls%p(p)%pos + ls%p(p)%displacement=0.0_WP + ! Set object id and velocity + ls%p(p)%gd = 1.0_WP + ls%p(p)%gb = 1.0_WP + + ls%p(p)%vel=[0.0_WP,0.0_WP,0.0_WP] + if(ls%p(p)%id.eq.-1 ) ls%p(p)%vel=[0.01_WP,0.0_WP,0.0_WP] + + net_vol=net_vol+ls%p(p)%vol + ! Zero out force + ls%p(p)%Abond=0.0_WP + ! Zero out fluid unless end, using this for the load + ls%p(p)%Afluid=0.0_WP + !if(i.eq.nx+3) ls%p(p)%Afluid=[(P_load*Ly*Lz)/(ls%rho*ls%p(p)%vol),0.0_WP,0.0_WP] + ! Locate the particle on the mesh + ls%p(p)%ind=ls%cfg%get_ijk_global(ls%p(p)%pos,[ls%cfg%imin,ls%cfg%jmin,ls%cfg%kmin]) + ! Assign a unique integer to particle + ls%p(p)%i=p + ! Activate the particle + ls%p(p)%flag=0 + center_dist=sqrt(dot_product((ls%p(p)%pos - location),(ls%p(p)%pos - location))) + if(center_dist < prev_center_dist) then + target_index = p + prev_center_dist=center_dist + end if + end do + close(iunit) + print*, "Net Volume: ", net_vol + end block read_bin + end if + + ! Allreduce with MPI_MAX ensures the nonzero index propagates to all + call MPI_ALLREDUCE(target_index, global_index, 1, MPI_INTEGER, MPI_MAX, ls%cfg%comm, ierr) + + ! Update target_index globally + target_index = global_index + + + ! Communicate particles + call ls%sync() + + call get_tracked_particle() + + ! Get initial volume fraction + ! call ls%update_VF() + + ! Initalize bonds + call ls%bond_init() + + if (ls%cfg%amRoot) then + print*,"===== Solid Setup Description =====" + print*,'Number of particles', np + print*,'Maximum stretching =',max_stretch + end if + + end block initialize_lss + + + ! Create partmesh object for visualizing Lagrangian particles + create_pmesh: block + use lss_class, only: max_bond + integer :: i,n,nbond + pmesh=partmesh(nvar=5,nvec=3,name='solid') + pmesh%varname(1)='failfrac' + pmesh%varname(2)='dilatation' + pmesh%varname(3)='id' + pmesh%varname(4)='nbond' + pmesh%varname(5)='von-Mises' + + pmesh%vecname(1)='velocity' + pmesh%vecname(2)='bond_force' + pmesh%vecname(3)='disp' + call ls%update_partmesh(pmesh) + do i=1,ls%np_ + pmesh%var(1,i)=0.0_WP + nbond=0 + do n=1,max_bond + if (ls%p(i)%ibond(n).gt.0) nbond=nbond+1 + end do + if (ls%p(i)%nbond.gt.0) then + pmesh%var(1,i)=1.0_WP-real(nbond,WP)/real(ls%p(i)%nbond,WP) + else + pmesh%var(1,i)=0.0_WP + end if + pmesh%var(2,i) =ls%p(i)%dil + pmesh%var(3,i) =ls%p(i)%id + pmesh%vec(:,1,i)=ls%p(i)%vel + pmesh%vec(:,2,i)=ls%p(i)%Abond + pmesh%var(4,i) =ls%p(i)%nbond + pmesh%var(5,i) =ls%p(i)%vonMises + pmesh%vec(:,3,i) =ls%p(i)%displacement + end do + end block create_pmesh + + ! Add Ensight output + create_ensight: block + ! Create Ensight output from cfg + ens_out=ensight(cfg=cfg,name='shock') + ! Create event for Ensight output + ens_evt=event(time=time,name='Ensight output') + call param_read('Ensight output period',ens_evt%tper) + ! Add variables to output + call ens_out%add_particle('particles',pmesh) + ! Output to ensight + if (ens_evt%occurs()) call ens_out%write_data(time%t) + end block create_ensight + + + ! Create monitor files + create_monitor: block + real(WP) :: cfl + ! Prepare some info about fields + call ls%get_cfl(time%dt,time%cfl) + call ls%get_max() + ! Create solid monitor + sfile=monitor(ls%cfg%amRoot,'solid') + call sfile%add_column(time%n,'Timestep number') + call sfile%add_column(time%t,'Time') + call sfile%add_column(ls_dt,'Particle dt') + call sfile%add_column(time%cfl,'Maximum CFL') + call sfile%add_column(ls%np,'Particle number') + call sfile%add_column(ls%VFmax,'VFmax') + call sfile%add_column(ls%Umin,'Particle Umin') + call sfile%add_column(ls%Umax,'Particle Umax') + call sfile%add_column(ls%Vmin,'Particle Vmin') + call sfile%add_column(ls%Vmax,'Particle Vmax') + call sfile%add_column(ls%Wmin,'Particle Wmin') + call sfile%add_column(ls%Wmax,'Particle Wmax') + call sfile%add_column(ls%ibmForce(1),'Particle Fx') + call sfile%add_column(ls%ibmForce(2),'Particle Fy') + call sfile%add_column(ls%ibmForce(3),'Particle Fz') + call sfile%write() + dispfile=monitor(ls%cfg%amRoot,'displacement') + call dispfile%add_column(time%n,'Timestep number') + call dispfile%add_column(time%t,'Time') + call dispfile%add_column(ls_dt,'Particle dt') + call dispfile%add_column(target_position(1),'X') + call dispfile%add_column(target_position(2),'Y') + call dispfile%add_column(target_position(3),'Z') + call dispfile%write() + end block create_monitor + + end subroutine simulation_init + + + !> Perform an NGA2 simulation + subroutine simulation_run + implicit none + real(WP) :: cfl + logical :: first_time + + first_time = .true. + ! Perform time integration + do while (.not.time%done()) + + ! Increment time + call ls%get_cfl(time%dt,time%cfl) + ! call fs%get_cfl(time%dt,cfl); time%cfl=max(time%cfl,cfl) + call time%adjust_dt() + call time%increment() + + ! Advance solid solver + solid: block + real(WP) :: dt_done,mydt + ! Sub-iteratore + call ls%get_cfl(ls_dt,cfl=cfl) + if (cfl.gt.0.0_WP) ls_dt=min(ls_dt*time%cflmax/cfl,ls_dt_max) + dt_done=0.0_WP + do while (dt_done.lt.time%dtmid) + ! Decide the timestep size + if(first_time) then + call ls%stretch(dt =mydt) + first_time=.false. + dt_done=dt_done+mydt + else + mydt=min(ls_dt,time%dtmid-dt_done) + ! ! Advance particles + call ls%advance(dt =mydt) + ! ! Increment + dt_done=dt_done+mydt + end if + + end do + end block solid + + !> Perform and output monitoring + call ls%get_max() + call get_tracked_particle() + call sfile%write() + call dispfile%write() + + + ! Output to ensight + if (ens_evt%occurs()) then + update_pmesh: block + use lss_class, only: max_bond + integer :: i,n,nbond + call ls%update_partmesh(pmesh) + do i=1,ls%np_ + nbond=0 + do n=1,max_bond + if (ls%p(i)%ibond(n).gt.0) nbond=nbond+1 + end do + if (ls%p(i)%nbond.gt.0) then + pmesh%var(1,i)=1.0_WP-real(nbond,WP)/real(ls%p(i)%nbond,WP) + else + pmesh%var(1,i)=0.0_WP + end if + pmesh%var(2,i) =ls%p(i)%dil + pmesh%var(3,i) =ls%p(i)%id + pmesh%vec(:,1,i)=ls%p(i)%vel + pmesh%vec(:,2,i)=ls%p(i)%Abond + pmesh%var(4,i) =ls%p(i)%nbond + pmesh%var(5,i) =ls%p(i)%vonMises + pmesh%vec(:,3,i) =ls%p(i)%displacement + + + end do + end block update_pmesh + call ens_out%write_data(time%t) + end if + + end do + + end subroutine simulation_run + + + !> Finalize the NGA2 simulation + subroutine simulation_final + implicit none + + ! Get rid of all objects - need destructors + ! monitor + ! ensight + ! bcond + ! timetracker + + ! Deallocate work arrays + deallocate(dQdt) + end subroutine simulation_final + + +end module simulation diff --git a/examples/plate_with_hole/src/simulation_working.f90 b/examples/plate_with_hole/src/simulation_working.f90 new file mode 100644 index 000000000..b5584ed0a --- /dev/null +++ b/examples/plate_with_hole/src/simulation_working.f90 @@ -0,0 +1,775 @@ +!> Various definitions and tools for running an NGA2 simulation +module simulation + use precision, only: WP,SP + use geometry, only: cfg + use spcomp_class, only: spcomp + use lss_class, only: lss + use timetracker_class, only: timetracker + use ensight_class, only: ensight + use partmesh_class, only: partmesh + use event_class, only: event + use monitor_class, only: monitor + implicit none + private + + !> Get a couple linear solvers, an incompressible flow solver and corresponding time tracker + type(spcomp), public :: fs + type(lss), public :: ls + type(timetracker), public :: time + + !> Ensight postprocessing + type(partmesh) :: pmesh + type(ensight) :: ens_out + type(event) :: ens_evt + + !> Simulation monitor file + type(monitor) :: mfile,cflfile,consfile,sfile,dispfile + + public :: simulation_init,simulation_run,simulation_final + + !> Private work arrays + real(WP), dimension(:,:,:,:,:), allocatable :: dQdt + real(WP), dimension(:,:,:) , allocatable :: Ui,Vi,Wi,Ma,beta,visc,visc_t,div + !> Post-shock viscosity and temperature + real(WP) :: visc0,T0 + + !> Equations of state + real(WP) :: Pinf,Gamma,Cv,Prandtl + + !> Flow parameters + real(WP) :: Ms,Xs,Rcyl + real(WP) :: rho1,p1,u1,M1 + real(WP) :: rho2,p2,u2,M2 + real(WP) :: Re + + !> Max timestep size for solid solver + real(WP) :: ls_dt,ls_dt_max + + integer :: target_index + real(WP), dimension(3) :: target_position + + + contains + + + !> Function that returns a smooth Heaviside of thickness delta + real(WP) function Hshock(x,delta) + real(WP), intent(in) :: x,delta + ! Goes from 0 to 1 as x goes from begative to positive + Hshock=1.0_WP/(1.0_WP+exp(-x/delta)) + end function Hshock + + !> P=EOS(RHO,I) + pure real(WP) function get_P(RHO,I) + implicit none + real(WP), intent(in) :: RHO,I + get_P=RHO*I*(Gamma-1.0_WP)-Gamma*Pinf + end function get_P + !> T=f(RHO,P) + pure real(WP) function get_T(RHO,P) + implicit none + real(WP), intent(in) :: RHO,P + get_T=(P+Pinf)/(Cv*RHO*(Gamma-1.0_WP)) + end function get_T + !> RHO=f(T,P) + pure real(WP) function get_RHO(T,P) + implicit none + real(WP), intent(in) :: T,P + get_RHO=(P+Pinf)/(Cv*T*(Gamma-1.0_WP)) + end function get_RHO + !> I=EOS(RHO,P) + pure real(WP) function get_I(RHO,P) + implicit none + real(WP), intent(in) :: RHO,P + get_I=(P+Gamma*Pinf)/(RHO*(Gamma-1.0_WP)) + end function get_I + !> C=f(RHO,P) + pure real(WP) function get_C(RHO,P) + implicit none + real(WP), intent(in) :: RHO,P + get_C=sqrt(Gamma*(P+Pinf)/RHO) + end function get_C + !> S=f(RHO,P) + pure real(WP) function get_S(RHO,P) + implicit none + real(WP), intent(in) :: RHO,P + get_S=Cv*log((P+Pinf)/RHO**Gamma) + end function get_S + + subroutine get_tracked_particle() + use mpi_f08 + implicit none + integer :: i, ierr + real(WP) :: local_pos(3), global_pos(3) + + local_pos = 0.0_WP + + do i=1,ls%np_ + if (ls%p(i)%i.eq.target_index) then + local_pos = ls%p(i)%pos + end if + end do + call MPI_ALLREDUCE(local_pos, global_pos, 3, MPI_DOUBLE_PRECISION, MPI_SUM, ls%cfg%comm, ierr) + + target_position = global_pos + end subroutine + + !> Calculate viscosities + subroutine prepare_viscosities() + implicit none + integer :: i,j,k + real(WP) :: S + ! Get viscosity from Sutherland's law + S=110.4_WP/273.15_WP*T0 + do k=fs%cfg%kmino_,fs%cfg%kmaxo_ + do j=fs%cfg%jmino_,fs%cfg%jmaxo_ + do i=fs%cfg%imino_,fs%cfg%imaxo_ + visc(i,j,k)=visc0*(T0+S)/(fs%T(i,j,k)+S)*(fs%T(i,j,k)/T0)**1.5_WP + end do + end do + end do + ! Get LAD + call fs%get_viscartif(dt=time%dt,beta=beta); fs%BETA=fs%Q(:,:,:,1)*beta + ! Get eddy viscosity + call fs%get_vreman (dt=time%dt,visc=visc_t); fs%VISC=fs%Q(:,:,:,1)*visc_t+visc + ! Recompute thermal conductivity + fs%diff=Gamma*Cv*fs%visc/Prandtl + ! Add LAD + fs%VISC=fs%VISC+0.002_WP*fs%BETA + end subroutine prepare_viscosities + + + !> Calculate velocity divergence + subroutine get_div() + implicit none + integer :: i,j,k + do k=fs%cfg%kmino_,fs%cfg%kmaxo_-1; do j=fs%cfg%jmino_,fs%cfg%jmaxo_-1; do i=fs%cfg%imino_,fs%cfg%imaxo_-1 + div(i,j,k)=fs%dxi*(fs%U(i+1,j,k)-fs%U(i,j,k))+fs%dyi*(fs%V(i,j+1,k)-fs%V(i,j,k))+fs%dzi*(fs%W(i,j,k+1)-fs%W(i,j,k)) + end do; end do; end do + call fs%cfg%sync(div) + if (.not.fs%cfg%xper.and.fs%cfg%iproc.eq.fs%cfg%npx) div(fs%cfg%imaxo,:,:)=div(fs%cfg%imaxo-1,:,:) + if (.not.fs%cfg%yper.and.fs%cfg%jproc.eq.fs%cfg%npy) div(:,fs%cfg%jmaxo,:)=div(:,fs%cfg%jmaxo-1,:) + if (.not.fs%cfg%zper.and.fs%cfg%kproc.eq.fs%cfg%npz) div(:,:,fs%cfg%kmaxo)=div(:,:,fs%cfg%kmaxo-1) + end subroutine get_div + + + !> Overwrite cosnerved variables using volume-of-solid IBM + subroutine apply_ibm() + implicit none + integer :: i,j,k,ii,jj,kk + real(WP) :: sum_VF,sum_VFQ1,sum_VFQ2 + do k=cfg%kmin_,cfg%kmax_ + do j=cfg%jmin_,cfg%jmax_ + do i=cfg%imin_,cfg%imax_ + if (ls%VF(i,j,k).eq.0.0_WP) cycle + ! Neumann: VF-weighted neighbor average for Q(1) and Q(2) + sum_VF=0.0_WP; sum_VFQ1=0.0_WP; sum_VFQ2=0.0_WP + do kk=-1,1; do jj=-1,1; do ii=-1,1 + if (ii.eq.0.and.jj.eq.0.and.kk.eq.0) cycle + sum_VF =sum_VF +(1.0_WP-ls%VF(i+ii,j+jj,k+kk)) + sum_VFQ1=sum_VFQ1+(1.0_WP-ls%VF(i+ii,j+jj,k+kk))*fs%Q(i+ii,j+jj,k+kk,1) + sum_VFQ2=sum_VFQ2+(1.0_WP-ls%VF(i+ii,j+jj,k+kk))*fs%Q(i+ii,j+jj,k+kk,2) + end do; end do; end do + if (sum_VF.gt.0.0_WP) then + fs%Q(i,j,k,1)=(1.0_WP-ls%VF(i,j,k))*fs%Q(i,j,k,1)+ls%VF(i,j,k)*sum_VFQ1/sum_VF + fs%Q(i,j,k,2)=(1.0_WP-ls%VF(i,j,k))*fs%Q(i,j,k,2)+ls%VF(i,j,k)*sum_VFQ2/sum_VF + end if + ! No-slip now that density is determined + fs%Q(i,j,k,3)=(1.0_WP-0.5_WP*(ls%VF(i-1,j,k)+ls%VF(i,j,k)))*fs%Q(i,j,k,3)+0.5_WP*(fs%Q(i-1,j,k,1)+fs%Q(i,j,k,1))*ls%VFU(i,j,k) + fs%Q(i,j,k,4)=(1.0_WP-0.5_WP*(ls%VF(i,j-1,k)+ls%VF(i,j,k)))*fs%Q(i,j,k,4)+0.5_WP*(fs%Q(i,j-1,k,1)+fs%Q(i,j,k,1))*ls%VFV(i,j,k) + fs%Q(i,j,k,5)=(1.0_WP-0.5_WP*(ls%VF(i,j,k-1)+ls%VF(i,j,k)))*fs%Q(i,j,k,5)+0.5_WP*(fs%Q(i,j,k-1,1)+fs%Q(i,j,k,1))*ls%VFW(i,j,k) + end do + end do + end do + ! Communicate + call fs%cfg%sync(fs%Q(:,:,:,1)) + call fs%cfg%sync(fs%Q(:,:,:,2)) + call fs%cfg%sync(fs%Q(:,:,:,3)) + call fs%cfg%sync(fs%Q(:,:,:,4)) + call fs%cfg%sync(fs%Q(:,:,:,5)) + ! Rebuild primitive variables + call fs%get_primitive() + end subroutine apply_ibm + + + !> Apply boundary conditions + subroutine apply_bconds() + implicit none + integer :: i,j,k + + ! Apply clipped Neumann on primitive variables in x+ + if (.not.fs%cfg%xper.and.fs%cfg%iproc.eq.fs%cfg%npx) then + do k=fs%cfg%kmino_,fs%cfg%kmaxo_; do j=fs%cfg%jmino_,fs%cfg%jmaxo_ + ! Copy over from imax to imax+1 and above + do i=fs%cfg%imax+1,fs%cfg%imaxo + ! Copy primitive variables + ls%VF(i,j,k)=ls%VF(fs%cfg%imax,j,k) + fs%Q(i,j,k,1)=fs%Q(fs%cfg%imax,j,k,1) + fs%P(i,j,k)=fs%P(fs%cfg%imax,j,k) + fs%I(i,j,k)=fs%I(fs%cfg%imax,j,k) + fs%U(i,j,k)=max(fs%U(fs%cfg%imax,j,k),0.0_WP) + fs%V(i,j,k)=fs%V(fs%cfg%imax,j,k) + fs%W(i,j,k)=fs%W(fs%cfg%imax,j,k) + end do + end do; end do + end if + + ! Apply clipped Neumann on primitive variables in y+ + if (.not.fs%cfg%yper.and.fs%cfg%jproc.eq.fs%cfg%npy) then + do k=fs%cfg%kmino_,fs%cfg%kmaxo_; do i=fs%cfg%imino_,fs%cfg%imaxo_ + ! Copy over from jmax to jmax+1 and above + do j=fs%cfg%jmax+1,fs%cfg%jmaxo + ! Copy primitive variables + ls%VF(i,j,k)=ls%VF(i,fs%cfg%jmax,k) + fs%Q(i,j,k,1)=fs%Q(i,fs%cfg%jmax,k,1) + fs%P(i,j,k)=fs%P(i,fs%cfg%jmax,k) + fs%I(i,j,k)=fs%I(i,fs%cfg%jmax,k) + fs%U(i,j,k)=fs%U(i,fs%cfg%jmax,k) + fs%V(i,j,k)=max(fs%V(i,fs%cfg%jmax,k),0.0_WP) + fs%W(i,j,k)=fs%W(i,fs%cfg%jmax,k) + end do + end do; end do + end if + + ! Apply clipped Neumann on primitive variables in y- + if (.not.fs%cfg%yper.and.fs%cfg%jproc.eq.1) then + do k=fs%cfg%kmino_,fs%cfg%kmaxo_; do i=fs%cfg%imino_,fs%cfg%imaxo_ + ! First copy over V from jmin+1 to jmin + fs%V(i,fs%cfg%jmin,k)=min(fs%V(i,fs%cfg%jmin+1,k),0.0_WP) + ! Then copy over from jmin to jmin-1 and below + do j=fs%cfg%jmino,fs%cfg%jmin-1 + ! Copy primitive variables + ls%VF(i,j,k)=ls%VF(i,fs%cfg%jmin,k) + fs%Q(i,j,k,1)=fs%Q(i,fs%cfg%jmin,k,1) + fs%P(i,j,k)=fs%P(i,fs%cfg%jmin,k) + fs%I(i,j,k)=fs%I(i,fs%cfg%jmin,k) + fs%U(i,j,k)=fs%U(i,fs%cfg%jmin,k) + fs%V(i,j,k)=min(fs%V(i,fs%cfg%jmin,k),0.0_WP) + fs%W(i,j,k)=fs%W(i,fs%cfg%jmin,k) + end do + end do; end do + end if + + ! Apply clipped Neumann on primitive variables in z+ + if (.not.fs%cfg%zper.and.fs%cfg%kproc.eq.fs%cfg%npz) then + do j=fs%cfg%jmino_,fs%cfg%jmaxo_; do i=fs%cfg%imino_,fs%cfg%imaxo_ + ! Copy over from kmax to kmax+1 and above + do k=fs%cfg%kmax+1,fs%cfg%kmaxo + ! Copy primitive variables + ls%VF(i,j,k)=ls%VF(i,j,fs%cfg%kmax) + fs%Q(i,j,k,1)=fs%Q(i,j,fs%cfg%kmax,1) + fs%P(i,j,k)=fs%P(i,j,fs%cfg%kmax) + fs%I(i,j,k)=fs%I(i,j,fs%cfg%kmax) + fs%U(i,j,k)=fs%U(i,j,fs%cfg%kmax) + fs%V(i,j,k)=fs%V(i,j,fs%cfg%kmax) + fs%W(i,j,k)=max(fs%W(i,j,fs%cfg%kmax),0.0_WP) + end do + end do; end do + end if + + ! Apply clipped Neumann on primitive variables in z- + if (.not.fs%cfg%zper.and.fs%cfg%kproc.eq.1) then + do j=fs%cfg%jmino_,fs%cfg%jmaxo_; do i=fs%cfg%imino_,fs%cfg%imaxo_ + ! First copy over W from kmin+1 to kmin + fs%W(i,j,fs%cfg%kmin)=min(fs%W(i,j,fs%cfg%kmin+1),0.0_WP) + ! Then copy over from kmin to kmin-1 and below + do k=fs%cfg%kmino,fs%cfg%kmin-1 + ! Copy primitive variables + ls%VF(i,j,k)=ls%VF(i,j,fs%cfg%kmin) + fs%Q(i,j,k,1)=fs%Q(i,j,fs%cfg%kmin,1) + fs%P(i,j,k)=fs%P(i,j,fs%cfg%kmin) + fs%I(i,j,k)=fs%I(i,j,fs%cfg%kmin) + fs%U(i,j,k)=fs%U(i,j,fs%cfg%kmin) + fs%V(i,j,k)=fs%V(i,j,fs%cfg%kmin) + fs%W(i,j,k)=min(fs%W(i,j,fs%cfg%kmin),0.0_WP) + end do + end do; end do + end if + + ! Rebuild conserved quantities + fs%Q(:,:,:,2)=fs%Q(:,:,:,1)*fs%I + call fs%get_momentum() + + end subroutine apply_bconds + + + !> Initialization of problem solver + subroutine simulation_init + + use param, only: param_read,param_exists + implicit none + + ! Allocate work arrays + allocate_work_arrays: block + allocate(dQdt (cfg%imino_:cfg%imaxo_,cfg%jmino_:cfg%jmaxo_,cfg%kmino_:cfg%kmaxo_,1:5,1:4)) + end block allocate_work_arrays + + ! Initialize time tracker with 2 subiterations + initialize_timetracker: block + time=timetracker(amRoot=cfg%amRoot) + call param_read('Max timestep size',time%dtmax) + call param_read('Max cfl number',time%cflmax) + call param_read('Max time',time%tmax) + time%dt=time%dtmax + time%itmax=2 + end block initialize_timetracker + + + + ! ! Initialize Lagrangian solid solver + ! initialize_lss: block + ! use mpi_f08, only: MPI_ALLREDUCE,MPI_MAX,MPI_INTEGER + ! real(WP) :: dx,mu,kk,max_stretch,Lx,Ly,Lz + ! real(WP) :: xmin,xmax,ymin,ymax,zmin,zmax,ratio,P_load + ! integer :: np,nt,nx,ny,nz,ierr,global_index + ! type triangle_type + ! real(WP), dimension(3) :: norm + ! real(WP), dimension(3) :: v1 + ! real(WP), dimension(3) :: v2 + ! real(WP), dimension(3) :: v3 + ! end type triangle_type + ! type(triangle_type), dimension(:), allocatable :: t + + + ! ! Create solver + ! ls=lss(cfg=cfg,name='solid') + ! !call fs%initialize(cfg=cfg,name='Compressible NS') + + + ! ! Set material properties + ! call param_read('Elastic Modulus',ls%elastic_modulus) + ! call param_read('Poisson Ratio',ls%poisson_ratio) + ! call param_read('Solid density',ls%rho) + ! call param_read('Critical Energy Release Rate',ls%crit_energy) + + ! ! Maximum timestep size used for particles + ! call param_read('Particle timestep size',ls_dt_max,default=huge(1.0_WP)) + ! ls_dt=min(ls_dt_max,time%dtmax) + + ! ! Discretization + ! ! ls%delta=fs%cfg%min_meshsize*1.01 + ! ! Load',P_load) + ! call param_read('Lx',Lx) + ! call param_read('Ly',Ly) + ! call param_read('Lz',Lz) + ! call param_read('Subdivisions',ny) + ! nz = ny + ! nx = NINT(Lx/Lz)*ny + ! call param_read('Horizon Ratio',ratio) + ! ls%delta = Ly/real(ny,WP)*ratio + ! ! Output some info on stretch + ! mu=ls%elastic_modulus/(2.0_WP+2.0_WP*ls%poisson_ratio) + ! kk=ls%elastic_modulus/(3.0_WP-6.0_WP*ls%poisson_ratio) + ! max_stretch=sqrt(ls%crit_energy/((3.0_WP*mu+(kk-5.0_WP*mu/3.0_WP)*0.75_WP**4)*ls%delta)) + + ! ! Only root process initializes solid particles + ! if (ls%cfg%amRoot) then + ! ! Read the STL file and get domain extents and levelset + ! print*, Lx * Ly * Lz / real(ny*nz*nx,WP) + ! read_bin: block + + ! use messager, only: die + ! integer :: p,iunit,ierr, wall_np, i, j, k + ! global_index = 0 + ! target_index = 0 + + ! ! Read in grid definition + ! wall_np = ny*nz*(nx+3) + ! ! call ls%resize(np+wall_np) + ! call ls%resize(wall_np) + ! p=0 + ! do i=1,nx+3 + ! do j=1,ny + ! do k=1,nz + ! p = p+1 + ! ls%p(p)%pos(1) = (i-1) * (Lx/real(nx,WP)) + ! ls%p(p)%pos(2) = (j) * (Ly/real(ny,WP)) - Ly/2.0_WP + ! ls%p(p)%pos(3) = (k) * (Lz/real(nz,WP)) - Lz/2.0_WP + ! ls%p(p)%vol = Lx * Ly * Lz / real(ny*nz*nx,WP) + ! ls%p(p)%id=1 + ! if(i.le.3) ls%p(p)%id=-2 + + ! ls%p(p)%vel=[0.0_WP,0.0_WP,0.0_WP] + ! ! Zero out force + ! ls%p(p)%Abond=0.0_WP + ! ! Zero out fluid unless end, using this for the load + ! ls%p(p)%Afluid=0.0_WP + ! !if(i.eq.nx+3) ls%p(p)%Afluid=[(P_load*Ly*Lz)/(ls%rho*ls%p(p)%vol),0.0_WP,0.0_WP] + ! ! Locate the particle on the mesh + ! ls%p(p)%ind=ls%cfg%get_ijk_global(ls%p(p)%pos,[ls%cfg%imin,ls%cfg%jmin,ls%cfg%kmin]) + ! ! Assign a unique integer to particle + ! ls%p(p)%i=p + ! ! Activate the particle + ! ls%p(p)%flag=0 + ! if(i.eq.(nx/2+1).and.j.eq.(ny/2+1).and.k.eq.(nz/2+1)) target_index = p + ! end do + ! end do + ! end do + + ! np = wall_np + ! end block read_bin + ! end if + + ! ! Allreduce with MPI_MAX ensures the nonzero index propagates to all + ! call MPI_ALLREDUCE(target_index, global_index, 1, MPI_INTEGER, MPI_MAX, ls%cfg%comm, ierr) + + ! ! Update target_index globally + ! target_index = global_index + + + ! ! Communicate particles + ! call ls%sync() + + ! call get_tracked_particle() + + ! ! Get initial volume fraction + ! ! call ls%update_VF() + + ! ! Initalize bonds + ! call ls%bond_init() + + ! if (ls%cfg%amRoot) then + ! print*,"===== Solid Setup Description =====" + ! print*,'Number of particles', np + ! print*,'Maximum stretching =',max_stretch + ! end if + + ! end block initialize_lss + + initialize_lss: block + use mpi_f08, only: MPI_ALLREDUCE,MPI_MAX,MPI_INTEGER + real(WP) :: dx,mu,kk,max_stretch,Lx,Ly,Lz,R,x,y,z + real(WP) :: xmin,xmax,ymin,ymax,zmin,zmax,ratio,dist + integer :: np,nt,nx,ny,nz,ierr,global_index + type triangle_type + real(WP), dimension(3) :: norm + real(WP), dimension(3) :: v1 + real(WP), dimension(3) :: v2 + real(WP), dimension(3) :: v3 + end type triangle_type + type(triangle_type), dimension(:), allocatable :: t + + + + + ! Create solver + ls=lss(cfg=cfg,name='solid') + !call fs%initialize(cfg=cfg,name='Compressible NS') + + + ! Set material properties + call param_read('Elastic Modulus',ls%elastic_modulus) + call param_read('Poisson Ratio',ls%poisson_ratio) + call param_read('Solid density',ls%rho) + call param_read('Critical Energy Release Rate',ls%crit_energy) + + ! Maximum timestep size used for particles + call param_read('Particle timestep size',ls_dt_max,default=huge(1.0_WP)) + ls_dt=min(ls_dt_max,time%dtmax) + + ! Discretization + ! ls%delta=fs%cfg%min_meshsize*1.01 + ! Load',P_load) + call param_read('Lx',Lx) + call param_read('Ly',Ly) + call param_read('Lz',Lz) + call param_read('R',R) + call param_read('Solid Spacing',dist) + ! Lx = 1.0_WP + ! Ly = 1.0_WP + ! dist = 0.01_WP ! Space between particles + Lx = Lx + 3.0_WP * dist + ! Ly = Ly + 3.0_WP * dist + + ny = ceiling(Ly/dist) + nz = ceiling(Lz/dist) + nx = ceiling(Lx/dist) + call param_read('Horizon Ratio',ratio) + ls%delta = dist*ratio + print*, ls%delta + ! Output some info on stretch + mu=ls%elastic_modulus/(2.0_WP+2.0_WP*ls%poisson_ratio) + kk=ls%elastic_modulus/(3.0_WP-6.0_WP*ls%poisson_ratio) + max_stretch=sqrt(ls%crit_energy/((3.0_WP*mu+(kk-5.0_WP*mu/3.0_WP)*0.75_WP**4)*ls%delta)) + + ! Only root process initializes solid particles + if (ls%cfg%amRoot) then + ! Read the STL fiprint*, "here" + read_bin: block + + use messager, only: die + integer :: p,iunit,ierr, wall_np, i, j, k + real(WP) :: net_vol + net_vol = 0.0_WP + global_index = 0 + target_index = 0 + ! Read in grid definition + wall_np = (ny)*(nz)*(nx) + ! call ls%resize(np+wall_np) + call ls%resize(wall_np) + p=0 + do i=1,nx + do j=1,ny + do k=1,nz + x = (i-1) * dist - Lx/2.0_WP; + y = (j-1) * (dist) - Ly/2.0_WP + z = (k-1) * (dist) - Lz/2.0_WP - dist + if ((x*x + y*y).lt.R*R) cycle; + p = p+1 + + ls%p(p)%pos(1) = x + ls%p(p)%pos(2) = y + ls%p(p)%pos(3) = z + ls%p(p)%ipos=ls%p(p)%pos + ls%p(p)%displacement=0.0_WP + ls%p(p)%vol = dist*dist*dist + ls%p(p)%gd = 1.0_WP + ls%p(p)%gb = 1.0_WP + ls%p(p)%id=1 + if(i.le.3) ls%p(p)%id=-1 + if(i.ge.nx-2) ls%p(p)%id=-1 + + ls%p(p)%vel=[0.0_WP,0.0_WP,0.0_WP] + if(ls%p(p)%id.eq.-1.and.ls%p(p)%pos(1).gt.0) ls%p(p)%vel=[0.01_WP,0.0_WP,0.0_WP] + if(ls%p(p)%id.eq.-1.and.ls%p(p)%pos(1).lt.0) ls%p(p)%id=-2 + ! if(i.gt.3) net_vol=net_vol+ls%p(p)%vol + ! Zero out force + ls%p(p)%Abond=0.0_WP + ! Zero out fluid unless end, using this for the load + ls%p(p)%Afluid=0.0_WP + !if(i.eq.nx+3) ls%p(p)%Afluid=[(P_load*Ly*Lz)/(ls%rho*ls%p(p)%vol),0.0_WP,0.0_WP] + ! Locate the particle on the mesh + ls%p(p)%ind=ls%cfg%get_ijk_global(ls%p(p)%pos,[ls%cfg%imin,ls%cfg%jmin,ls%cfg%kmin]) + ! Assign a unique integer to particle + ls%p(p)%i=p + ! Activate the particle + ls%p(p)%flag=0 + if(i.eq.(nx/2+2).and.j.eq.(5).and.k.eq.(5)) target_index = p + end do + end do + end do + + np = wall_np + print*, "Net Volume: ", net_vol + end block read_bin + end if + + ! Allreduce with MPI_MAX ensures the nonzero index propagates to all + call MPI_ALLREDUCE(target_index, global_index, 1, MPI_INTEGER, MPI_MAX, ls%cfg%comm, ierr) + + ! Update target_index globally + target_index = global_index + + + ! Communicate particles + call ls%sync() + + call get_tracked_particle() + + ! Get initial volume fraction + ! call ls%update_VF() + + ! Initalize bonds + call ls%bond_init() + + if (ls%cfg%amRoot) then + print*,"===== Solid Setup Description =====" + print*,'Number of particles', np + print*,'Maximum stretching =',max_stretch + end if + + end block initialize_lss + + + ! Create partmesh object for visualizing Lagrangian particles + create_pmesh: block + use lss_class, only: max_bond + integer :: i,n,nbond + pmesh=partmesh(nvar=5,nvec=3,name='solid') + pmesh%varname(1)='failfrac' + pmesh%varname(2)='dilatation' + pmesh%varname(3)='id' + pmesh%varname(4)='nbond' + pmesh%varname(5)='von-Mises' + + pmesh%vecname(1)='velocity' + pmesh%vecname(2)='bond_force' + pmesh%vecname(3)='disp' + call ls%update_partmesh(pmesh) + do i=1,ls%np_ + pmesh%var(1,i)=0.0_WP + nbond=0 + do n=1,max_bond + if (ls%p(i)%ibond(n).gt.0) nbond=nbond+1 + end do + if (ls%p(i)%nbond.gt.0) then + pmesh%var(1,i)=1.0_WP-real(nbond,WP)/real(ls%p(i)%nbond,WP) + else + pmesh%var(1,i)=0.0_WP + end if + pmesh%var(2,i) =ls%p(i)%dil + pmesh%var(3,i) =ls%p(i)%id + pmesh%vec(:,1,i)=ls%p(i)%vel + pmesh%vec(:,2,i)=ls%p(i)%Abond + pmesh%var(4,i) =ls%p(i)%nbond + pmesh%var(5,i) =ls%p(i)%vonMises + pmesh%vec(:,3,i) =ls%p(i)%displacement + end do + end block create_pmesh + + ! Add Ensight output + create_ensight: block + ! Create Ensight output from cfg + ens_out=ensight(cfg=cfg,name='shock') + ! Create event for Ensight output + ens_evt=event(time=time,name='Ensight output') + call param_read('Ensight output period',ens_evt%tper) + ! Add variables to output + call ens_out%add_particle('particles',pmesh) + ! Output to ensight + if (ens_evt%occurs()) call ens_out%write_data(time%t) + end block create_ensight + + + ! Create monitor files + create_monitor: block + real(WP) :: cfl + ! Prepare some info about fields + call ls%get_cfl(time%dt,time%cfl) + call ls%get_max() + ! Create solid monitor + sfile=monitor(ls%cfg%amRoot,'solid') + call sfile%add_column(time%n,'Timestep number') + call sfile%add_column(time%t,'Time') + call sfile%add_column(ls_dt,'Particle dt') + call sfile%add_column(time%cfl,'Maximum CFL') + call sfile%add_column(ls%np,'Particle number') + call sfile%add_column(ls%VFmax,'VFmax') + call sfile%add_column(ls%Umin,'Particle Umin') + call sfile%add_column(ls%Umax,'Particle Umax') + call sfile%add_column(ls%Vmin,'Particle Vmin') + call sfile%add_column(ls%Vmax,'Particle Vmax') + call sfile%add_column(ls%Wmin,'Particle Wmin') + call sfile%add_column(ls%Wmax,'Particle Wmax') + call sfile%add_column(ls%ibmForce(1),'Particle Fx') + call sfile%add_column(ls%ibmForce(2),'Particle Fy') + call sfile%add_column(ls%ibmForce(3),'Particle Fz') + call sfile%write() + dispfile=monitor(ls%cfg%amRoot,'displacement') + call dispfile%add_column(time%n,'Timestep number') + call dispfile%add_column(time%t,'Time') + call dispfile%add_column(ls_dt,'Particle dt') + call dispfile%add_column(target_position(1),'X') + call dispfile%add_column(target_position(2),'Y') + call dispfile%add_column(target_position(3),'Z') + call dispfile%write() + end block create_monitor + + end subroutine simulation_init + + + !> Perform an NGA2 simulation + subroutine simulation_run + implicit none + real(WP) :: cfl + logical :: first_time + + first_time = .true. + ! Perform time integration + do while (.not.time%done()) + + ! Increment time + call ls%get_cfl(time%dt,time%cfl) + ! call fs%get_cfl(time%dt,cfl); time%cfl=max(time%cfl,cfl) + call time%adjust_dt() + call time%increment() + + ! Advance solid solver + solid: block + real(WP) :: dt_done,mydt + ! Sub-iteratore + call ls%get_cfl(ls_dt,cfl=cfl) + if (cfl.gt.0.0_WP) ls_dt=min(ls_dt*time%cflmax/cfl,ls_dt_max) + dt_done=0.0_WP + do while (dt_done.lt.time%dtmid) + ! Decide the timestep size + if(first_time) then + call ls%stretch(dt =mydt) + first_time=.false. + dt_done=dt_done+mydt + else + mydt=min(ls_dt,time%dtmid-dt_done) + ! ! Advance particles + call ls%advance(dt =mydt) + ! ! Increment + dt_done=dt_done+mydt + end if + + + ! mydt=min(ls_dt,time%dtmid-dt_done) + ! ! Advance particles + ! call ls%advance(dt =mydt) + ! ! ! Increment + ! dt_done=dt_done+mydt + + end do + end block solid + + !> Perform and output monitoring + call ls%get_max() + call get_tracked_particle() + call sfile%write() + call dispfile%write() + + + ! Output to ensight + if (ens_evt%occurs()) then + update_pmesh: block + use lss_class, only: max_bond + integer :: i,n,nbond + call ls%update_partmesh(pmesh) + do i=1,ls%np_ + nbond=0 + do n=1,max_bond + if (ls%p(i)%ibond(n).gt.0) nbond=nbond+1 + end do + if (ls%p(i)%nbond.gt.0) then + pmesh%var(1,i)=1.0_WP-real(nbond,WP)/real(ls%p(i)%nbond,WP) + else + pmesh%var(1,i)=0.0_WP + end if + pmesh%var(2,i) =ls%p(i)%dil + pmesh%var(3,i) =ls%p(i)%id + pmesh%vec(:,1,i)=ls%p(i)%vel + pmesh%vec(:,2,i)=ls%p(i)%Abond + pmesh%var(4,i) =ls%p(i)%nbond + pmesh%var(5,i) =ls%p(i)%vonMises + pmesh%vec(:,3,i) =ls%p(i)%displacement + + + end do + end block update_pmesh + call ens_out%write_data(time%t) + end if + + end do + + end subroutine simulation_run + + + !> Finalize the NGA2 simulation + subroutine simulation_final + implicit none + + ! Get rid of all objects - need destructors + ! monitor + ! ensight + ! bcond + ! timetracker + + ! Deallocate work arrays + deallocate(dQdt) + end subroutine simulation_final + + +end module simulation diff --git a/examples/plate_with_hole/src/spcomp_class.f90 b/examples/plate_with_hole/src/spcomp_class.f90 new file mode 100644 index 000000000..00ec1fe25 --- /dev/null +++ b/examples/plate_with_hole/src/spcomp_class.f90 @@ -0,0 +1,942 @@ +!> Single phase compressible flow solver class: +!> Provides support for RHS calculation only +module spcomp_class + use precision, only: WP + use string, only: str_medium + use config_class, only: config + use timer_class, only: timer + implicit none + private + + ! Expose type + public :: spcomp + + !> Single phase compressible solver object definition + type :: spcomp + + ! This is the config around which solver is built + class(config), pointer :: cfg + + ! Solver name + character(len=str_medium) :: name='UNNAMED_SPCOMP' + + ! Pointers to functions to evaluate P(RHO,E), T(RHO,P), and C(RHO,P) + procedure(Pfunc_type), pointer, nopass :: getP=>NULL() + procedure(Tfunc_type), pointer, nopass :: getT=>NULL() + procedure(Cfunc_type), pointer, nopass :: getC=>NULL() + procedure(Sfunc_type), pointer, nopass :: getS=>NULL() + + ! Conserved variables: 1=RHO, 2=RHO*I, 3=RHO*U, 4=RHO*V, 5=RHO*W + integer :: nQ + real(WP), dimension(:,:,:,:), allocatable :: Q,Qold + + ! Flow velocity + real(WP), dimension(:,:,:), allocatable :: U,V,W + + ! Internal energy + real(WP), dimension(:,:,:), allocatable :: I + + ! Pressure + real(WP), dimension(:,:,:), allocatable :: P + + ! Temperature + real(WP), dimension(:,:,:), allocatable :: T + + ! Speed of sound + real(WP), dimension(:,:,:), allocatable :: C + + ! Viscosities and heat diffusivity + real(WP), dimension(:,:,:), allocatable :: VISC,BETA,DIFF + + ! Gravitational acceleration + real(WP), dimension(3) :: gravity=0.0_WP + + ! Store mesh info + real(WP) :: dx,dy,dz,dxi,dyi,dzi,vol + + ! CFL numbers + real(WP) :: CFLc_x,CFLc_y,CFLc_z !< Convective CFL numbers + real(WP) :: CFLa_x,CFLa_y,CFLa_z !< Acoustic CFL numbers + real(WP) :: CFLv_x,CFLv_y,CFLv_z !< Viscous CFL numbers + + ! Monitoring quantities for conserved variables + real(WP), dimension(:), allocatable :: Qmin,Qmax,Qint + real(WP) :: RHOKint + real(WP) :: RHOSint + + ! Monitoring quantities for primitive variables + real(WP) :: Umax,Vmax,Wmax !< Velocity stats + real(WP) :: RHOmin,RHOmax !< Density stats + real(WP) :: Imin,Imax !< Internal energy stats + real(WP) :: Pmin,Pmax !< Pressure stats + real(WP) :: Tmin,Tmax !< Temperature stats + + ! Timer + type(timer) :: trhs !< Timer for RHS calculation + + contains + procedure :: print=>spcomp_print !< Output solver to the screen + procedure :: initialize !< Initialize the flow solver + procedure :: finalize !< Finalize the flow solver + procedure :: get_div_stress !< Compute divergence of stress for LSS solver + procedure :: rhs !< Compute rhs of our equations using standard fluxes + procedure :: get_primitive !< Calculate primitive variables from conserved variables + procedure :: get_viscartif !< Calculate artifical bulk kinematic viscosity + procedure :: get_vreman !< Get kinematic eddy viscosity using Vreman's model + procedure :: get_velocity !< Calculate velocity from momentum + procedure :: get_ke !< Calculate kinetic energy per unit mass from velocity + procedure :: get_momentum !< Calculate momentum from velocity + procedure :: interp_vel !< Calculate interpolated velocity + procedure :: get_cfl !< Calculate maximum CFL + procedure :: get_info !< Calculate maximum field values + end type spcomp + + !> Interfaces for user-defined function + abstract interface + !> P=P(RHO,I) + pure real(WP) function Pfunc_type(RHO,I) + import :: WP + implicit none + real(WP), intent(in) :: RHO + real(WP), intent(in) :: I + end function Pfunc_type + !> T=T(RHO,P) + pure real(WP) function Tfunc_type(RHO,P) + import :: WP + implicit none + real(WP), intent(in) :: RHO + real(WP), intent(in) :: P + end function Tfunc_type + !> C=C(RHO,P) + pure real(WP) function Cfunc_type(RHO,P) + import :: WP + implicit none + real(WP), intent(in) :: RHO + real(WP), intent(in) :: P + end function Cfunc_type + !> S=S(RHO,P) + pure real(WP) function Sfunc_type(RHO,P) + import :: WP + implicit none + real(WP), intent(in) :: RHO + real(WP), intent(in) :: P + end function Sfunc_type + end interface + +contains + + + !> Initialization for compressible flow solver + subroutine initialize(this,cfg,name) + use messager, only: die + implicit none + class(spcomp) :: this + class(config), target, intent(in) :: cfg + character(len=*), optional :: name + + ! Set the name for the solver + if (present(name)) this%name=trim(adjustl(name)) + + ! Point to config object + this%cfg=>cfg + + ! Check that config is uniform with at least 2 cells of overlap + if (this%cfg%no.lt.2) call die('[spcomp initialize] spcomp solver requires at least 2 cells of overlap') + if (.not.all([this%cfg%uniform_x,this%cfg%uniform_y,this%cfg%uniform_z])) call die('[spcomp initialize] spcomp solver requires a uniform mesh') + + ! Store constant cell size and its inverse, handle 2D conditions, store cell volume + this%dx=this%cfg%dx(this%cfg%imin_); this%dxi=1.0_WP/this%dx; if (this%cfg%nx.eq.1) this%dxi=0.0_WP + this%dy=this%cfg%dy(this%cfg%jmin_); this%dyi=1.0_WP/this%dy; if (this%cfg%ny.eq.1) this%dyi=0.0_WP + this%dz=this%cfg%dz(this%cfg%kmin_); this%dzi=1.0_WP/this%dz; if (this%cfg%nz.eq.1) this%dzi=0.0_WP + this%vol=this%dx*this%dy*this%dz + + ! Allocate and zero out conserved variables + this%nQ=5 + allocate(this%Q (this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_,1:this%nQ)); this%Q =0.0_WP + allocate(this%Qold(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_,1:this%nQ)); this%Qold=0.0_WP + + ! Conserved variables monitoring + allocate(this%Qmin(1:this%nQ),this%Qmax(1:this%nQ),this%Qint(1:this%nQ)) + + ! Flow velocity + allocate(this%U(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)); this%U=0.0_WP + allocate(this%V(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)); this%V=0.0_WP + allocate(this%W(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)); this%W=0.0_WP + + ! Internal energy + allocate(this%I(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)); this%I=0.0_WP + + ! Pressure + allocate(this%P(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)); this%P=0.0_WP + + ! Temperature + allocate(this%T(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)); this%T=0.0_WP + + ! Speed of sound + allocate(this%C(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)); this%C=0.0_WP + + ! Viscosities and heat diffusivity + allocate(this%VISC(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)); this%VISC=0.0_WP + allocate(this%BETA(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)); this%BETA=0.0_WP + allocate(this%DIFF(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)); this%DIFF=0.0_WP + + ! Create timers + this%trhs=timer(comm=this%cfg%comm,name='RHS') + + end subroutine initialize + + + !> Obtain RHS for all equations + subroutine rhs(this,dQdt) + implicit none + class(spcomp), intent(inout) :: this + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:,1:), intent(out) :: dQdt !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_,1:nVAR) + real(WP), dimension(:,:,:,:), allocatable :: FQx,FQy,FQz + integer :: i,j,k,n + real(WP) :: w,div + real(WP), parameter :: eps=1.0e-15_WP + real(WP), dimension(-2: 0) :: wenop + real(WP), dimension(-1:+1) :: wenom + + ! Start rhs timer + call this%trhs%start() + + ! Zero out RHS + dQdt=0.0_WP + + ! ================================================================ ! + ! ======================== INVISID FLUXES ======================== ! + ! ================================================================ ! + + ! Allocate fluxes of conserved variables + allocate(FQx(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_,1:this%nQ)); FQx=0.0_WP + allocate(FQy(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_,1:this%nQ)); FQy=0.0_WP + allocate(FQz(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_,1:this%nQ)); FQz=0.0_WP + + ! Calculate standard fluxes + do k=this%cfg%kmin_,this%cfg%kmax_+1 + do j=this%cfg%jmin_,this%cfg%jmax_+1 + do i=this%cfg%imin_,this%cfg%imax_+1 + ! X fluxes + ! WENO mass flux + w=weno_weight((abs(this%Q(i-1,j,k,1)-this%Q(i-2,j,k,1))+eps)/(abs(this%Q(i,j,k,1)-this%Q(i-1,j,k,1))+eps)); wenop=0.5_WP*[ -w,1.0_WP+2.0_WP*w,1.0_WP-w] + w=weno_weight((abs(this%Q(i+1,j,k,1)-this%Q(i ,j,k,1))+eps)/(abs(this%Q(i,j,k,1)-this%Q(i-1,j,k,1))+eps)); wenom=0.5_WP*[1.0_WP-w,1.0_WP+2.0_WP*w, -w] + FQx(i,j,k,1)=-0.5_WP*(this%U(i,j,k)+abs(this%U(i,j,k)))*sum(wenop*this%Q(i-2:i ,j,k,1))& + & -0.5_WP*(this%U(i,j,k)-abs(this%U(i,j,k)))*sum(wenom*this%Q(i-1:i+1,j,k,1)) + ! Centered mass flux + !FQx(i,j,k,1)=-this%U(i,j,k)*0.5_WP*sum(this%Q(i-1:i,j,k,1)) + ! WENO internal energy flux + w=weno_weight((abs(this%I(i-1,j,k)-this%I(i-2,j,k))+eps)/(abs(this%I(i,j,k)-this%I(i-1,j,k))+eps)); wenop=0.5_WP*[ -w,1.0_WP+2.0_WP*w,1.0_WP-w] + w=weno_weight((abs(this%I(i+1,j,k)-this%I(i ,j,k))+eps)/(abs(this%I(i,j,k)-this%I(i-1,j,k))+eps)); wenom=0.5_WP*[1.0_WP-w,1.0_WP+2.0_WP*w, -w] + FQx(i,j,k,2)=0.5_WP*(FQx(i,j,k,1)-abs(-FQx(i,j,k,1)))*sum(wenop*this%I(i-2:i ,j,k))& + & +0.5_WP*(FQx(i,j,k,1)+abs(-FQx(i,j,k,1)))*sum(wenom*this%I(i-1:i+1,j,k)) + ! Centered internal energy flux + !FQx(i,j,k,2)=FQx(i,j,k,1)*0.5_WP*sum(this%I(i-1:i,j,k)) + ! Heat flux + FQx(i,j,k,2)=FQx(i,j,k,2)+0.5_WP*(this%DIFF(i-1,j,k)+this%DIFF(i,j,k))*this%dxi*(this%T(i,j,k)-this%T(i-1,j,k)) + ! Y fluxes + ! WENO mass flux + w=weno_weight((abs(this%Q(i,j-1,k,1)-this%Q(i,j-2,k,1))+eps)/(abs(this%Q(i,j,k,1)-this%Q(i,j-1,k,1))+eps)); wenop=0.5_WP*[ -w,1.0_WP+2.0_WP*w,1.0_WP-w] + w=weno_weight((abs(this%Q(i,j+1,k,1)-this%Q(i,j ,k,1))+eps)/(abs(this%Q(i,j,k,1)-this%Q(i,j-1,k,1))+eps)); wenom=0.5_WP*[1.0_WP-w,1.0_WP+2.0_WP*w, -w] + FQy(i,j,k,1)=-0.5_WP*(this%V(i,j,k)+abs(this%V(i,j,k)))*sum(wenop*this%Q(i,j-2:j ,k,1))& + & -0.5_WP*(this%V(i,j,k)-abs(this%V(i,j,k)))*sum(wenom*this%Q(i,j-1:j+1,k,1)) + ! Centered mass flux + !FQy(i,j,k,1)=-this%V(i,j,k)*0.5_WP*sum(this%Q(i,j-1:j,k,1)) + ! WENO internal energy flux + w=weno_weight((abs(this%I(i,j-1,k)-this%I(i,j-2,k))+eps)/(abs(this%I(i,j,k)-this%I(i,j-1,k))+eps)); wenop=0.5_WP*[ -w,1.0_WP+2.0_WP*w,1.0_WP-w] + w=weno_weight((abs(this%I(i,j+1,k)-this%I(i,j ,k))+eps)/(abs(this%I(i,j,k)-this%I(i,j-1,k))+eps)); wenom=0.5_WP*[1.0_WP-w,1.0_WP+2.0_WP*w, -w] + FQy(i,j,k,2)=0.5_WP*(FQy(i,j,k,1)-abs(-FQy(i,j,k,1)))*sum(wenop*this%I(i,j-2:j ,k))& + & +0.5_WP*(FQy(i,j,k,1)+abs(-FQy(i,j,k,1)))*sum(wenom*this%I(i,j-1:j+1,k)) + ! Centered internal energy flux + !FQy(i,j,k,2)=FQy(i,j,k,1)*0.5_WP*sum(this%I(i,j-1:j,k)) + ! Heat flux + FQy(i,j,k,2)=FQy(i,j,k,2)+0.5_WP*(this%DIFF(i,j-1,k)+this%DIFF(i,j,k))*this%dyi*(this%T(i,j,k)-this%T(i,j-1,k)) + ! Z fluxes + ! WENO mass flux + w=weno_weight((abs(this%Q(i,j,k-1,1)-this%Q(i,j,k-2,1))+eps)/(abs(this%Q(i,j,k,1)-this%Q(i,j,k-1,1))+eps)); wenop=0.5_WP*[ -w,1.0_WP+2.0_WP*w,1.0_WP-w] + w=weno_weight((abs(this%Q(i,j,k+1,1)-this%Q(i,j,k ,1))+eps)/(abs(this%Q(i,j,k,1)-this%Q(i,j,k-1,1))+eps)); wenom=0.5_WP*[1.0_WP-w,1.0_WP+2.0_WP*w, -w] + FQz(i,j,k,1)=-0.5_WP*(this%W(i,j,k)+abs(this%W(i,j,k)))*sum(wenop*this%Q(i,j,k-2:k ,1))& + & -0.5_WP*(this%W(i,j,k)-abs(this%W(i,j,k)))*sum(wenom*this%Q(i,j,k-1:k+1,1)) + ! Centered mass flux + !FQz(i,j,k,1)=-this%W(i,j,k)*0.5_WP*sum(this%Q(i,j,k-1:k,1)) + ! WENO internal energy flux + w=weno_weight((abs(this%I(i,j,k-1)-this%I(i,j,k-2))+eps)/(abs(this%I(i,j,k)-this%I(i,j,k-1))+eps)); wenop=0.5_WP*[ -w,1.0_WP+2.0_WP*w,1.0_WP-w] + w=weno_weight((abs(this%I(i,j,k+1)-this%I(i,j,k ))+eps)/(abs(this%I(i,j,k)-this%I(i,j,k-1))+eps)); wenom=0.5_WP*[1.0_WP-w,1.0_WP+2.0_WP*w, -w] + FQz(i,j,k,2)=0.5_WP*(FQz(i,j,k,1)-abs(-FQz(i,j,k,1)))*sum(wenop*this%I(i,j,k-2:k ))& + & +0.5_WP*(FQz(i,j,k,1)+abs(-FQz(i,j,k,1)))*sum(wenom*this%I(i,j,k-1:k+1)) + ! Centered internal energy flux + !FQz(i,j,k,2)=FQz(i,j,k,1)*0.5_WP*sum(this%I(i,j,k-1:k)) + ! Heat flux + FQz(i,j,k,2)=FQz(i,j,k,2)+0.5_WP*(this%DIFF(i,j,k-1)+this%DIFF(i,j,k))*this%dzi*(this%T(i,j,k)-this%T(i,j,k-1)) + end do + end do + end do + + ! Mass fluxes will be used to build momentum fluxes, they need to be extended by one cell on the left because of staggering + call this%cfg%sync(FQx(:,:,:,1)); if (.not.this%cfg%xper.and.this%cfg%iproc.eq.1) FQx(this%cfg%imin-1,:,:,1)=FQx(this%cfg%imin,:,:,1) + call this%cfg%sync(FQy(:,:,:,1)); if (.not.this%cfg%yper.and.this%cfg%jproc.eq.1) FQy(:,this%cfg%jmin-1,:,1)=FQy(:,this%cfg%jmin,:,1) + call this%cfg%sync(FQz(:,:,:,1)); if (.not.this%cfg%zper.and.this%cfg%kproc.eq.1) FQz(:,:,this%cfg%kmin-1,1)=FQz(:,:,this%cfg%kmin,1) + + ! Calculate cell-centered momentum fluxes with extra cell on the left due to staggering + do k=this%cfg%kmin_-1,this%cfg%kmax_ + do j=this%cfg%jmin_-1,this%cfg%jmax_ + do i=this%cfg%imin_-1,this%cfg%imax_ + FQx(i,j,k,3)=0.25_WP*sum(FQx(i:i+1,j,k,1))*sum(this%U(i:i+1,j,k))-this%P(i,j,k) + FQy(i,j,k,4)=0.25_WP*sum(FQy(i,j:j+1,k,1))*sum(this%V(i,j:j+1,k))-this%P(i,j,k) + FQz(i,j,k,5)=0.25_WP*sum(FQz(i,j,k:k+1,1))*sum(this%W(i,j,k:k+1))-this%P(i,j,k) + end do + end do + end do + + ! Calculate edge-centered momentum fluxes + do k=this%cfg%kmin_,this%cfg%kmax_+1 + do j=this%cfg%jmin_,this%cfg%jmax_+1 + do i=this%cfg%imin_,this%cfg%imax_+1 + FQy(i,j,k,3)=0.25_WP*sum(FQy(i-1:i,j,k,1))*sum(this%U(i,j-1:j,k)) + FQz(i,j,k,3)=0.25_WP*sum(FQz(i-1:i,j,k,1))*sum(this%U(i,j,k-1:k)) + FQx(i,j,k,4)=0.25_WP*sum(FQx(i,j-1:j,k,1))*sum(this%V(i-1:i,j,k)) + FQz(i,j,k,4)=0.25_WP*sum(FQz(i,j-1:j,k,1))*sum(this%V(i,j,k-1:k)) + FQx(i,j,k,5)=0.25_WP*sum(FQx(i,j,k-1:k,1))*sum(this%W(i-1:i,j,k)) + FQy(i,j,k,5)=0.25_WP*sum(FQy(i,j,k-1:k,1))*sum(this%W(i,j-1:j,k)) + end do + end do + end do + + ! Assemble time derivative for conserved variables + do k=this%cfg%kmin_,this%cfg%kmax_ + do j=this%cfg%jmin_,this%cfg%jmax_ + do i=this%cfg%imin_,this%cfg%imax_ + ! Mass and internal energy advection + dQdt(i,j,k,1)=this%dxi*(FQx(i+1,j,k,1)-FQx(i,j,k,1))+this%dyi*(FQy(i,j+1,k,1)-FQy(i,j,k,1))+this%dzi*(FQz(i,j,k+1,1)-FQz(i,j,k,1)) + dQdt(i,j,k,2)=this%dxi*(FQx(i+1,j,k,2)-FQx(i,j,k,2))+this%dyi*(FQy(i,j+1,k,2)-FQy(i,j,k,2))+this%dzi*(FQz(i,j,k+1,2)-FQz(i,j,k,2)) + ! Momentum advection and pressure stress + dQdt(i,j,k,3)=this%dxi*(FQx(i ,j,k,3)-FQx(i-1,j,k,3))+this%dyi*(FQy(i,j+1,k,3)-FQy(i,j ,k,3))+this%dzi*(FQz(i,j,k+1,3)-FQz(i,j,k ,3)) + dQdt(i,j,k,4)=this%dxi*(FQx(i+1,j,k,4)-FQx(i ,j,k,4))+this%dyi*(FQy(i,j ,k,4)-FQy(i,j-1,k,4))+this%dzi*(FQz(i,j,k+1,4)-FQz(i,j,k ,4)) + dQdt(i,j,k,5)=this%dxi*(FQx(i+1,j,k,5)-FQx(i ,j,k,5))+this%dyi*(FQy(i,j+1,k,5)-FQy(i,j ,k,5))+this%dzi*(FQz(i,j,k ,5)-FQz(i,j,k-1,5)) + ! Pressure dilatation term + dQdt(i,j,k,2)=dQdt(i,j,k,2)-this%P(i,j,k)*(this%dxi*(this%U(i+1,j,k)-this%U(i,j,k))+this%dyi*(this%V(i,j+1,k)-this%V(i,j,k))+this%dzi*(this%W(i,j,k+1)-this%W(i,j,k))) + end do + end do + end do + + ! ================================================================ ! + ! ======================== VISCOUS FLUXES ======================= ! + ! ================================================================ ! + + ! Zero out fluxes + FQx=0.0_WP; FQy=0.0_WP; FQz=0.0_WP + + ! Compute cell-centered momentum viscous fluxes + do k=this%cfg%kmin_-1,this%cfg%kmax_ + do j=this%cfg%jmin_-1,this%cfg%jmax_ + do i=this%cfg%imin_-1,this%cfg%imax_ + div=this%dxi*(this%U(i+1,j,k)-this%U(i,j,k))+this%dyi*(this%V(i,j+1,k)-this%V(i,j,k))+this%dzi*(this%W(i,j,k+1)-this%W(i,j,k)) + FQx(i,j,k,3)=2.0_WP*this%VISC(i,j,k)*this%dxi*(this%U(i+1,j,k)-this%U(i,j,k))+(this%BETA(i,j,k)-2.0_WP*this%VISC(i,j,k)/3.0_WP)*div + FQy(i,j,k,4)=2.0_WP*this%VISC(i,j,k)*this%dyi*(this%V(i,j+1,k)-this%V(i,j,k))+(this%BETA(i,j,k)-2.0_WP*this%VISC(i,j,k)/3.0_WP)*div + FQz(i,j,k,5)=2.0_WP*this%VISC(i,j,k)*this%dzi*(this%W(i,j,k+1)-this%W(i,j,k))+(this%BETA(i,j,k)-2.0_WP*this%VISC(i,j,k)/3.0_WP)*div + end do + end do + end do + + ! Compute edge-centered momentum viscous fluxes and corresponding viscous heating + do k=this%cfg%kmin_,this%cfg%kmax_+1 + do j=this%cfg%jmin_,this%cfg%jmax_+1 + do i=this%cfg%imin_,this%cfg%imax_+1 + FQy(i,j,k,3)=0.25_WP*sum(this%VISC(i-1:i,j-1:j,k))*(this%dyi*(this%U(i,j,k)-this%U(i,j-1,k))+this%dxi*(this%V(i,j,k)-this%V(i-1,j,k))); FQx(i,j,k,4)=FQy(i,j,k,3) + FQz(i,j,k,2)=FQy(i,j,k,3)*(this%dyi*(this%U(i,j,k)-this%U(i,j-1,k))+this%dxi*(this%V(i,j,k)-this%V(i-1,j,k))) + FQz(i,j,k,4)=0.25_WP*sum(this%VISC(i,j-1:j,k-1:k))*(this%dzi*(this%V(i,j,k)-this%V(i,j,k-1))+this%dyi*(this%W(i,j,k)-this%W(i,j-1,k))); FQy(i,j,k,5)=FQz(i,j,k,4) + FQx(i,j,k,2)=FQz(i,j,k,4)*(this%dzi*(this%V(i,j,k)-this%V(i,j,k-1))+this%dyi*(this%W(i,j,k)-this%W(i,j-1,k))) + FQx(i,j,k,5)=0.25_WP*sum(this%VISC(i-1:i,j,k-1:k))*(this%dxi*(this%W(i,j,k)-this%W(i-1,j,k))+this%dzi*(this%U(i,j,k)-this%U(i,j,k-1))); FQz(i,j,k,3)=FQx(i,j,k,5) + FQy(i,j,k,2)=FQx(i,j,k,5)*(this%dxi*(this%W(i,j,k)-this%W(i-1,j,k))+this%dzi*(this%U(i,j,k)-this%U(i,j,k-1))) + end do + end do + end do + + ! Assemble time derivative for conserved variables + do k=this%cfg%kmin_,this%cfg%kmax_ + do j=this%cfg%jmin_,this%cfg%jmax_ + do i=this%cfg%imin_,this%cfg%imax_ + ! Viscous momentum transport + dQdt(i,j,k,3)=dQdt(i,j,k,3)+this%dxi*(FQx(i ,j,k,3)-FQx(i-1,j,k,3))+this%dyi*(FQy(i,j+1,k,3)-FQy(i,j ,k,3))+this%dzi*(FQz(i,j,k+1,3)-FQz(i,j,k ,3)) + dQdt(i,j,k,4)=dQdt(i,j,k,4)+this%dxi*(FQx(i+1,j,k,4)-FQx(i ,j,k,4))+this%dyi*(FQy(i,j ,k,4)-FQy(i,j-1,k,4))+this%dzi*(FQz(i,j,k+1,4)-FQz(i,j,k ,4)) + dQdt(i,j,k,5)=dQdt(i,j,k,5)+this%dxi*(FQx(i+1,j,k,5)-FQx(i ,j,k,5))+this%dyi*(FQy(i,j+1,k,5)-FQy(i,j ,k,5))+this%dzi*(FQz(i,j,k ,5)-FQz(i,j,k-1,5)) + ! Viscous heating term + dQdt(i,j,k,2)=dQdt(i,j,k,2)+FQx(i,j,k,3)*this%dxi*(this%U(i+1,j,k)-this%U(i,j,k))+FQy(i,j,k,4)*this%dyi*(this%V(i,j+1,k)-this%V(i,j,k))+FQz(i,j,k,5)*this%dzi*(this%W(i,j,k+1)-this%W(i,j,k))+0.25_WP*sum(FQz(i:i+1,j:j+1,k,2))+0.25_WP*sum(FQx(i,j:j+1,k:k+1,2))+0.25_WP*sum(FQy(i:i+1,j,k:k+1,2)) + end do + end do + end do + + ! Deallocate flux arrays + deallocate(FQx,FQy,FQz) + + ! Synchronize all dQdt fields + do n=1,this%nQ; call this%cfg%sync(dQdt(:,:,:,n)); end do + + ! Stop rhs timer + call this%trhs%stop() + + contains + !> WENO switch function + real(WP) function weno_weight(ratio) + implicit none + real(WP), intent(in) :: ratio + real(WP), parameter :: lambda=0.13_WP ! Switching parameter + real(WP), parameter :: delta=0.01_WP ! Switching thickness + weno_weight=(1.0_WP-tanh((ratio-lambda)/delta))/3.0_WP+(1.0_WP-tanh((ratio-1.0_WP/lambda)/delta))/6.0_WP + end function weno_weight + end subroutine rhs + + + !> Calculate divergence of stress for LPT solver + subroutine get_div_stress(this,divx,divy,divz) + implicit none + class(spcomp), intent(inout) :: this + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(out) :: divx !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(out) :: divy !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(out) :: divz !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + real(WP), dimension(:,:,:,:), allocatable :: FQx,FQy,FQz + integer :: i,j,k + real(WP) :: div + + ! Zero out divergence of stresses + divx=0.0_WP + divy=0.0_WP + divz=0.0_WP + + ! Allocate fluxes of conserved variables + allocate(FQx(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_,1:3)); FQx=0.0_WP + allocate(FQy(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_,1:3)); FQy=0.0_WP + allocate(FQz(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_,1:3)); FQz=0.0_WP + + ! Compute cell-centered momentum fluxes + do k=this%cfg%kmin_-1,this%cfg%kmax_ + do j=this%cfg%jmin_-1,this%cfg%jmax_ + do i=this%cfg%imin_-1,this%cfg%imax_ + div=this%dxi*(this%U(i+1,j,k)-this%U(i,j,k))+this%dyi*(this%V(i,j+1,k)-this%V(i,j,k))+this%dzi*(this%W(i,j,k+1)-this%W(i,j,k)) + FQx(i,j,k,1)=2.0_WP*this%VISC(i,j,k)*this%dxi*(this%U(i+1,j,k)-this%U(i,j,k))+(this%BETA(i,j,k)-2.0_WP*this%VISC(i,j,k)/3.0_WP)*div-this%P(i,j,k) + FQy(i,j,k,2)=2.0_WP*this%VISC(i,j,k)*this%dyi*(this%V(i,j+1,k)-this%V(i,j,k))+(this%BETA(i,j,k)-2.0_WP*this%VISC(i,j,k)/3.0_WP)*div-this%P(i,j,k) + FQz(i,j,k,3)=2.0_WP*this%VISC(i,j,k)*this%dzi*(this%W(i,j,k+1)-this%W(i,j,k))+(this%BETA(i,j,k)-2.0_WP*this%VISC(i,j,k)/3.0_WP)*div-this%P(i,j,k) + end do + end do + end do + + ! Compute edge-centered momentum viscous fluxes and corresponding viscous heating + do k=this%cfg%kmin_,this%cfg%kmax_+1 + do j=this%cfg%jmin_,this%cfg%jmax_+1 + do i=this%cfg%imin_,this%cfg%imax_+1 + ! Momentum fluxes + FQy(i,j,k,1)=0.25_WP*sum(this%VISC(i-1:i,j-1:j,k))*(this%dyi*(this%U(i,j,k)-this%U(i,j-1,k))+this%dxi*(this%V(i,j,k)-this%V(i-1,j,k))); FQx(i,j,k,2)=FQy(i,j,k,1) + FQz(i,j,k,2)=0.25_WP*sum(this%VISC(i,j-1:j,k-1:k))*(this%dzi*(this%V(i,j,k)-this%V(i,j,k-1))+this%dyi*(this%W(i,j,k)-this%W(i,j-1,k))); FQy(i,j,k,3)=FQz(i,j,k,2) + FQx(i,j,k,3)=0.25_WP*sum(this%VISC(i-1:i,j,k-1:k))*(this%dxi*(this%W(i,j,k)-this%W(i-1,j,k))+this%dzi*(this%U(i,j,k)-this%U(i,j,k-1))); FQz(i,j,k,1)=FQx(i,j,k,3) + end do + end do + end do + + do i=1,3 + call this%cfg%sync(FQx(:,:,:,i)) + call this%cfg%sync(FQy(:,:,:,i)) + call this%cfg%sync(FQz(:,:,:,i)) + end do + + ! Assemble time derivative for conserved variables + do k=this%cfg%kmin_,this%cfg%kmax_ + do j=this%cfg%jmin_,this%cfg%jmax_ + do i=this%cfg%imin_,this%cfg%imax_ + ! Viscous momentum transport + divx(i,j,k)=this%dxi*(FQx(i ,j,k,1)-FQx(i-1,j,k,1))+this%dyi*(FQy(i,j+1,k,1)-FQy(i,j ,k,1))+this%dzi*(FQz(i,j,k+1,1)-FQz(i,j,k ,1)) + divy(i,j,k)=this%dxi*(FQx(i+1,j,k,2)-FQx(i ,j,k,2))+this%dyi*(FQy(i,j ,k,2)-FQy(i,j-1,k,2))+this%dzi*(FQz(i,j,k+1,2)-FQz(i,j,k ,2)) + divz(i,j,k)=this%dxi*(FQx(i+1,j,k,3)-FQx(i ,j,k,3))+this%dyi*(FQy(i,j+1,k,3)-FQy(i,j ,k,3))+this%dzi*(FQz(i,j,k ,3)-FQz(i,j,k-1,3)) + end do + end do + end do + + ! Deallocate flux arrays + deallocate(FQx,FQy,FQz) + + ! Synchronize + call this%cfg%sync(divx) + call this%cfg%sync(divy) + call this%cfg%sync(divz) + + end subroutine get_div_stress + + + !> Calculate all primitive variables from updated conserved variables + subroutine get_primitive(this) + implicit none + class(spcomp), intent(inout) :: this + integer :: i,j,k + ! Get velocity + call this%get_velocity() + ! Get primitive variables + do k=this%cfg%kmino_,this%cfg%kmaxo_; do j=this%cfg%jmino_,this%cfg%jmaxo_; do i=this%cfg%imino_,this%cfg%imaxo_ + this%I(i,j,k)=this%Q(i,j,k,2)/this%Q(i,j,k,1) + this%P(i,j,k)=this%getP(this%Q(i,j,k,1),this%I(i,j,k)) + this%C(i,j,k)=this%getC(this%Q(i,j,k,1),this%P(i,j,k)) + end do; end do; end do + ! Get temperature + if (associated(this%getT)) then + do k=this%cfg%kmino_,this%cfg%kmaxo_; do j=this%cfg%jmino_,this%cfg%jmaxo_; do i=this%cfg%imino_,this%cfg%imaxo_ + this%T(i,j,k)=this%getT(this%Q(i,j,k,1),this%P(i,j,k)) + end do; end do; end do + end if + end subroutine get_primitive + + + !> Calculate velocity from momentum and density + subroutine get_velocity(this) + implicit none + class(spcomp), intent(inout) :: this + integer :: i,j,k + ! Calculate velocity as far as possible + do k=this%cfg%kmino_+1,this%cfg%kmaxo_ + do j=this%cfg%jmino_+1,this%cfg%jmaxo_ + do i=this%cfg%imino_+1,this%cfg%imaxo_ + this%U(i,j,k)=2.0_WP*this%Q(i,j,k,3)/sum(this%Q(i-1:i,j,k,1)) + this%V(i,j,k)=2.0_WP*this%Q(i,j,k,4)/sum(this%Q(i,j-1:j,k,1)) + this%W(i,j,k)=2.0_WP*this%Q(i,j,k,5)/sum(this%Q(i,j,k-1:k,1)) + end do + end do + end do + ! Sync velocity + call this%cfg%sync(this%U) + call this%cfg%sync(this%V) + call this%cfg%sync(this%W) + ! Add last layer in each direction + if (.not.this%cfg%xper.and.this%cfg%iproc.eq.1) then + this%U(this%cfg%imino,:,:)=this%Q(this%cfg%imino,:,:,3)/(this%Q(this%cfg%imino,:,:,1)) + this%V(this%cfg%imino,:,:)=this%Q(this%cfg%imino,:,:,4)/(this%Q(this%cfg%imino,:,:,1)) + this%W(this%cfg%imino,:,:)=this%Q(this%cfg%imino,:,:,5)/(this%Q(this%cfg%imino,:,:,1)) + end if + if (.not.this%cfg%yper.and.this%cfg%jproc.eq.1) then + this%U(:,this%cfg%jmino,:)=this%Q(:,this%cfg%jmino,:,3)/(this%Q(:,this%cfg%jmino,:,1)) + this%V(:,this%cfg%jmino,:)=this%Q(:,this%cfg%jmino,:,4)/(this%Q(:,this%cfg%jmino,:,1)) + this%W(:,this%cfg%jmino,:)=this%Q(:,this%cfg%jmino,:,5)/(this%Q(:,this%cfg%jmino,:,1)) + end if + if (.not.this%cfg%zper.and.this%cfg%kproc.eq.1) then + this%U(:,:,this%cfg%kmino)=this%Q(:,:,this%cfg%kmino,3)/(this%Q(:,:,this%cfg%kmino,1)) + this%V(:,:,this%cfg%kmino)=this%Q(:,:,this%cfg%kmino,4)/(this%Q(:,:,this%cfg%kmino,1)) + this%W(:,:,this%cfg%kmino)=this%Q(:,:,this%cfg%kmino,5)/(this%Q(:,:,this%cfg%kmino,1)) + end if + end subroutine get_velocity + + + !> Calculate kinetic energy per unit mass from pre-calculated velocity + !> Need to redo this better + subroutine get_ke(this,KE) + implicit none + class(spcomp), intent(inout) :: this + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(out) :: KE !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + integer :: i,j,k + do k=this%cfg%kmino_,this%cfg%kmaxo_-1 + do j=this%cfg%jmino_,this%cfg%jmaxo_-1 + do i=this%cfg%imino_,this%cfg%imaxo_-1 + KE(i,j,k)=0.5_WP*sum(this%U(i:i+1,j,k)**2+this%V(i,j:j+1,k)**2+this%W(i,j,k:k+1)**2) + end do + end do + end do + call this%cfg%sync(KE) + if (.not.this%cfg%xper.and.this%cfg%iproc.eq.this%cfg%npx) KE(this%cfg%imaxo,:,:)=KE(this%cfg%imaxo-1,:,:) + if (.not.this%cfg%yper.and.this%cfg%jproc.eq.this%cfg%npy) KE(:,this%cfg%jmaxo,:)=KE(:,this%cfg%jmaxo-1,:) + if (.not.this%cfg%zper.and.this%cfg%kproc.eq.this%cfg%npz) KE(:,:,this%cfg%kmaxo)=KE(:,:,this%cfg%kmaxo-1) + end subroutine get_ke + + + !> Calculate momentum from velocity and density + subroutine get_momentum(this) + implicit none + class(spcomp), intent(inout) :: this + integer :: i,j,k + ! Calculate momentum as far as possible + do k=this%cfg%kmino_+1,this%cfg%kmaxo_ + do j=this%cfg%jmino_+1,this%cfg%jmaxo_ + do i=this%cfg%imino_+1,this%cfg%imaxo_ + this%Q(i,j,k,3)=0.5_WP*sum(this%Q(i-1:i,j,k,1))*this%U(i,j,k) + this%Q(i,j,k,4)=0.5_WP*sum(this%Q(i,j-1:j,k,1))*this%V(i,j,k) + this%Q(i,j,k,5)=0.5_WP*sum(this%Q(i,j,k-1:k,1))*this%W(i,j,k) + end do + end do + end do + ! Sync momentum + call this%cfg%sync(this%Q(:,:,:,3)) + call this%cfg%sync(this%Q(:,:,:,4)) + call this%cfg%sync(this%Q(:,:,:,5)) + ! Add last layer in each direction + if (.not.this%cfg%xper.and.this%cfg%iproc.eq.1) then + this%Q(this%cfg%imino,:,:,3)=this%Q(this%cfg%imino,:,:,1)*this%U(this%cfg%imino,:,:) + this%Q(this%cfg%imino,:,:,4)=this%Q(this%cfg%imino,:,:,1)*this%V(this%cfg%imino,:,:) + this%Q(this%cfg%imino,:,:,5)=this%Q(this%cfg%imino,:,:,1)*this%W(this%cfg%imino,:,:) + end if + if (.not.this%cfg%yper.and.this%cfg%jproc.eq.1) then + this%Q(:,this%cfg%jmino,:,3)=this%Q(:,this%cfg%jmino,:,1)*this%U(:,this%cfg%jmino,:) + this%Q(:,this%cfg%jmino,:,4)=this%Q(:,this%cfg%jmino,:,1)*this%V(:,this%cfg%jmino,:) + this%Q(:,this%cfg%jmino,:,5)=this%Q(:,this%cfg%jmino,:,1)*this%W(:,this%cfg%jmino,:) + end if + if (.not.this%cfg%zper.and.this%cfg%kproc.eq.1) then + this%Q(:,:,this%cfg%kmino,3)=this%Q(:,:,this%cfg%kmino,1)*this%U(:,:,this%cfg%kmino) + this%Q(:,:,this%cfg%kmino,4)=this%Q(:,:,this%cfg%kmino,1)*this%V(:,:,this%cfg%kmino) + this%Q(:,:,this%cfg%kmino,5)=this%Q(:,:,this%cfg%kmino,1)*this%W(:,:,this%cfg%kmino) + end if + end subroutine get_momentum + + + !> Interpolate velocity to cell-center, including overlap and ghosts + subroutine interp_vel(this,Ui,Vi,Wi) + implicit none + class(spcomp), intent(inout) :: this + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(out) :: Ui !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(out) :: Vi !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(out) :: Wi !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + integer :: i,j,k + ! Calculate interpolated velocity as far as possible + do k=this%cfg%kmino_,this%cfg%kmaxo_-1 + do j=this%cfg%jmino_,this%cfg%jmaxo_-1 + do i=this%cfg%imino_,this%cfg%imaxo_-1 + Ui(i,j,k)=0.5_WP*sum(this%U(i:i+1,j,k)) + Vi(i,j,k)=0.5_WP*sum(this%V(i,j:j+1,k)) + Wi(i,j,k)=0.5_WP*sum(this%W(i,j,k:k+1)) + end do + end do + end do + ! Sync interpolated velocity + call this%cfg%sync(Ui) + call this%cfg%sync(Vi) + call this%cfg%sync(Wi) + ! Add last layer in each direction + if (.not.this%cfg%xper.and.this%cfg%iproc.eq.this%cfg%npx) then + Ui(this%cfg%imaxo,:,:)=this%U(this%cfg%imaxo,:,:) + Vi(this%cfg%imaxo,:,:)=this%V(this%cfg%imaxo,:,:) + Wi(this%cfg%imaxo,:,:)=this%W(this%cfg%imaxo,:,:) + end if + if (.not.this%cfg%yper.and.this%cfg%jproc.eq.this%cfg%npy) then + Ui(:,this%cfg%jmaxo,:)=this%U(:,this%cfg%jmaxo,:) + Vi(:,this%cfg%jmaxo,:)=this%V(:,this%cfg%jmaxo,:) + Wi(:,this%cfg%jmaxo,:)=this%W(:,this%cfg%jmaxo,:) + end if + if (.not.this%cfg%zper.and.this%cfg%kproc.eq.this%cfg%npz) then + Ui(:,:,this%cfg%kmaxo)=this%U(:,:,this%cfg%kmaxo) + Vi(:,:,this%cfg%kmaxo)=this%V(:,:,this%cfg%kmaxo) + Wi(:,:,this%cfg%kmaxo)=this%W(:,:,this%cfg%kmaxo) + end if + end subroutine interp_vel + + + !> Get artifical bulk kinematic viscosity + subroutine get_viscartif(this,dt,beta) + implicit none + class(spcomp), intent(inout) :: this + real(WP), intent(in) :: dt + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(out) :: beta + integer :: i,j,k,si,sj,sk,n + integer, parameter :: nfilter=1 + real(WP) :: max_beta,dudy,dudz,dvdx,dvdz,dwdx,dwdy,vort,grad_div,H + real(WP), parameter :: max_cfl=0.5_WP + real(WP), parameter :: Cartif=2.0_WP + real(WP), parameter :: Cartif_vort=100.0_WP + real(WP), dimension(:,:,:), allocatable :: div + real(WP), dimension(-1:+1), parameter :: filter=[1.0_WP/6.0_WP,2.0_WP/3.0_WP,1.0_WP/6.0_WP] + ! Calculate max beta permissible + max_beta=max_cfl*min(this%dx**2,this%dy**2,this%dz**2)/(4.0_WP*dt) + ! Zero out array + beta=0.0_WP + ! Compute velocity divergence + allocate(div(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + do k=this%cfg%kmino_,this%cfg%kmaxo_-1; do j=this%cfg%jmino_,this%cfg%jmaxo_-1; do i=this%cfg%imino_,this%cfg%imaxo_-1 + div(i,j,k)=this%dxi*(this%U(i+1,j,k)-this%U(i,j,k))+this%dyi*(this%V(i,j+1,k)-this%V(i,j,k))+this%dzi*(this%W(i,j,k+1)-this%W(i,j,k)) + end do; end do; end do + call this%cfg%sync(div) + if (.not.this%cfg%xper.and.this%cfg%iproc.eq.this%cfg%npx) div(this%cfg%imaxo,:,:)=div(this%cfg%imaxo-1,:,:) + if (.not.this%cfg%yper.and.this%cfg%jproc.eq.this%cfg%npy) div(:,this%cfg%jmaxo,:)=div(:,this%cfg%jmaxo-1,:) + if (.not.this%cfg%zper.and.this%cfg%kproc.eq.this%cfg%npz) div(:,:,this%cfg%kmaxo)=div(:,:,this%cfg%kmaxo-1) + ! Compute artificial bulk viscosity based on gradU provided + do k=this%cfg%kmin_,this%cfg%kmax_; do j=this%cfg%jmin_,this%cfg%jmax_; do i=this%cfg%imin_,this%cfg%imax_ + ! Only work in compression regions + if (div(i,j,k).ge.0.0_WP) cycle + ! Compute local vorticity + dudy=0.25_WP*this%dyi*sum(this%U(i:i+1,j:j+1,k)-this%U(i:i+1,j-1:j,k)) + dudz=0.25_WP*this%dzi*sum(this%U(i:i+1,j,k:k+1)-this%U(i:i+1,j,k-1:k)) + dvdx=0.25_WP*this%dxi*sum(this%V(i:i+1,j:j+1,k)-this%V(i-1:i,j:j+1,k)) + dvdz=0.25_WP*this%dzi*sum(this%V(i,j:j+1,k:k+1)-this%V(i,j:j+1,k-1:k)) + dwdx=0.25_WP*this%dxi*sum(this%W(i:i+1,j,k:k+1)-this%W(i-1:i,j,k:k+1)) + dwdy=0.25_WP*this%dyi*sum(this%W(i,j:j+1,k:k+1)-this%W(i,j-1:j,k:k+1)) + vort=(dwdy-dvdz)**2+(dudz-dwdx)**2+(dvdx-dudy)**2 + ! Compute |grad(div)| + grad_div=max(abs(div(i+1,j,k)-div(i,j,k)),abs(div(i,j,k)-div(i-1,j,k)))*this%dx**2& + & +max(abs(div(i,j+1,k)-div(i,j,k)),abs(div(i,j,k)-div(i,j-1,k)))*this%dy**2& + & +max(abs(div(i,j,k+1)-div(i,j,k)),abs(div(i,j,k)-div(i,j,k-1)))*this%dz**2 + ! Estimate artificial kinematic viscosity using grad(div) + !beta(i,j,k)=Cartif*grad_div*div(i,j,k)**2/(div(i,j,k)**2+Cartif_vort*vort+1.0e-15_WP) + + ! Sensor originally proposed by Ducros et al. (1999) and later improved by + ! Hendrickson, T. R., Kartha, A., & Candler, G. V. (2018) + vort=max(vort,(0.05_WP*this%C(i,j,k)/min(this%dx,this%dy))**2) + beta(i,j,k)=Cartif*grad_div*min(4.0_WP/3.0_WP*div(i,j,k)**2/(div(i,j,k)**2+vort+epsilon(1.0_WP)),1.0_WP) + ! Clip it so CFL Get kinematic eddy viscosity using Vreman's model + subroutine get_vreman(this,dt,visc) + implicit none + class(spcomp), intent(inout) :: this + real(WP), intent(in) :: dt + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(out) :: visc + real(WP), parameter :: Cs_ref=0.17_WP + real(WP), parameter :: max_cfl=0.5_WP + real(WP) :: max_visc,A,B,C + real(WP), dimension(1:3,1:3) :: beta,gradU + real(WP), dimension(:,:,:), allocatable :: tmp + real(WP), dimension(-1:+1), parameter :: filter=[1.0_WP/6.0_WP,2.0_WP/3.0_WP,1.0_WP/6.0_WP] + integer :: i,j,k,si,sj,sk,n + integer, parameter :: nfilter=1 + ! Model constant is c=2.5*Cs_ref**2 - Vreman uses c=0.07 which corresponds to Cs_ref=0.17 + C=2.5_WP*Cs_ref**2 + ! Calculate max visc permissible + max_visc=max_cfl*min(this%dx**2,this%dy**2,this%dz**2)/(4.0_WP*dt) + ! Zero out array + visc=0.0_WP + ! Compute the eddy viscosity + do k=this%cfg%kmin_,this%cfg%kmax_; do j=this%cfg%jmin_,this%cfg%jmax_; do i=this%cfg%imin_,this%cfg%imax_ + ! Compute velocity gradient tensor + gradU(1,1)=this%dxi*(this%U(i+1,j,k)-this%U(i,j,k)) + gradU(2,1)=0.25_WP*this%dyi*sum(this%U(i:i+1,j:j+1,k)-this%U(i:i+1,j-1:j,k)) + gradU(3,1)=0.25_WP*this%dzi*sum(this%U(i:i+1,j,k:k+1)-this%U(i:i+1,j,k-1:k)) + gradU(1,2)=0.25_WP*this%dxi*sum(this%V(i:i+1,j:j+1,k)-this%V(i-1:i,j:j+1,k)) + gradU(2,2)=this%dyi*(this%V(i,j+1,k)-this%V(i,j,k)) + gradU(3,2)=0.25_WP*this%dzi*sum(this%V(i,j:j+1,k:k+1)-this%V(i,j:j+1,k-1:k)) + gradU(1,3)=0.25_WP*this%dxi*sum(this%W(i:i+1,j,k:k+1)-this%W(i-1:i,j,k:k+1)) + gradU(2,3)=0.25_WP*this%dyi*sum(this%W(i,j:j+1,k:k+1)-this%W(i,j-1:j,k:k+1)) + gradU(3,3)=this%dzi*(this%W(i,j,k+1)-this%W(i,j,k)) + ! Compute A=gradu_ij*gradu_ij invariant + A=sum(gradU**2) + ! Compute beta_ij=dx_m*dx_m*gradu_mi*gradu_mj + do sj=1,3; do si=1,3; beta(si,sj)=this%dx**2*gradU(1,si)*gradU(1,sj)+this%dy**2*gradU(2,si)*gradU(2,sj)+this%dz**2*gradU(3,si)*gradU(3,sj); end do; end do + ! Compute B invariant + B=beta(1,1)*beta(2,2)-beta(1,2)**2+beta(1,1)*beta(3,3)-beta(1,3)**2+beta(2,2)*beta(3,3)-beta(2,3)**2 + ! Assemble algebraic eddy viscosity model + if (B.lt.1.0e-8_WP) then + visc(i,j,k)=0.0_WP + else + visc(i,j,k)=C*sqrt(B/A) + end if + ! Clip it so CFL Calculate the CFL + subroutine get_cfl(this,dt,cfl) + use mpi_f08, only: MPI_ALLREDUCE,MPI_MAX,MPI_IN_PLACE + use parallel, only: MPI_REAL_WP + implicit none + class(spcomp), intent(inout) :: this + real(WP), intent(in) :: dt + real(WP), intent(out) :: cfl + integer :: ierr + real(WP) :: maxvisc,maxC + ! Compute convective+acoustic CFLs + this%CFLc_x=maxval(abs(this%U)+abs(this%C))*dt*this%dxi; call MPI_ALLREDUCE(MPI_IN_PLACE,this%CFLc_x,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + this%CFLc_y=maxval(abs(this%V)+abs(this%C))*dt*this%dyi; call MPI_ALLREDUCE(MPI_IN_PLACE,this%CFLc_y,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + this%CFLc_z=maxval(abs(this%W)+abs(this%C))*dt*this%dzi; call MPI_ALLREDUCE(MPI_IN_PLACE,this%CFLc_z,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + ! Compute acoustic CFLs + maxC=maxval(this%C); call MPI_ALLREDUCE(MPI_IN_PLACE,maxC,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + this%CFLa_x=maxC*dt*this%dxi + this%CFLa_y=maxC*dt*this%dyi + this%CFLa_z=maxC*dt*this%dzi + ! Compute viscous CFLs + maxvisc=maxval((this%VISC+this%BETA)/this%Q(:,:,:,1)); call MPI_ALLREDUCE(MPI_IN_PLACE,maxvisc,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + this%CFLv_x=4.0_WP*maxvisc*dt*this%dxi**2 + this%CFLv_y=4.0_WP*maxvisc*dt*this%dyi**2 + this%CFLv_z=4.0_WP*maxvisc*dt*this%dzi**2 + ! Return the maximum overall CFL + cfl=max(this%CFLc_x,this%CFLc_y,this%CFLc_z,& + & this%CFLa_x,this%CFLa_y,this%CFLa_z,& + & this%CFLv_x,this%CFLv_y,this%CFLv_z) + end subroutine get_cfl + + + !> Calculate info about our fields + subroutine get_info(this) + use mpi_f08, only: MPI_ALLREDUCE,MPI_MIN,MPI_MAX,MPI_IN_PLACE + use parallel, only: MPI_REAL_WP + implicit none + class(spcomp), intent(inout) :: this + integer :: n,i,j,k,ierr + real(WP), dimension(:,:,:), allocatable :: tmp + + ! Compute integrals and extrema of conserved variables + do n=1,this%nQ + call this%cfg%integrate(this%Q(:,:,:,n),integral=this%Qint(n)) + end do + this%Qmin=+huge(1.0_WP) + this%Qmax=-huge(1.0_WP) + do k=this%cfg%kmin_,this%cfg%kmax_; do j=this%cfg%jmin_,this%cfg%jmax_; do i=this%cfg%imin_,this%cfg%imax_ + do n=1,this%nQ + this%Qmin(n)=min(this%Qmin(n),this%Q(i,j,k,n)) + this%Qmax(n)=max(this%Qmax(n),this%Q(i,j,k,n)) + end do + end do; end do; end do + call MPI_ALLREDUCE(MPI_IN_PLACE,this%Qmin,this%nQ,MPI_REAL_WP,MPI_MIN,this%cfg%comm,ierr) + call MPI_ALLREDUCE(MPI_IN_PLACE,this%Qmax,this%nQ,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + + ! Also compute integral of KE and entropy + allocate(tmp(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + call this%get_ke(tmp); tmp=this%Q(:,:,:,1)*tmp; call this%cfg%integrate(tmp,integral=this%RHOKint) + this%RHOSint=0.0_WP + if (associated(this%getS)) then + do k=this%cfg%kmin_,this%cfg%kmax_; do j=this%cfg%jmin_,this%cfg%jmax_; do i=this%cfg%imin_,this%cfg%imax_ + tmp(i,j,k)=this%Q(i,j,k,1)*this%getS(this%Q(i,j,k,1),this%P(i,j,k)) + end do; end do; end do + call this%cfg%integrate(tmp,integral=this%RHOSint) + end if + deallocate(tmp) + + ! Calculate extrema of primitive fields + this%RHOmin=+huge(1.0_WP); this%RHOmax=-huge(1.0_WP) + this%Imin =+huge(1.0_WP); this%Imax =-huge(1.0_WP) + this%Pmin =+huge(1.0_WP); this%Pmax =-huge(1.0_WP) + this%Tmin =+huge(1.0_WP); this%Tmax =-huge(1.0_WP) + this%Umax=0.0_WP; this%Vmax=0.0_WP; this%Wmax=0.0_WP + do k=this%cfg%kmin_,this%cfg%kmax_; do j=this%cfg%jmin_,this%cfg%jmax_; do i=this%cfg%imin_,this%cfg%imax_ + this%RHOmin=min(this%RHOmin,this%Q(i,j,k,1)); this%RHOmax=max(this%RHOmax,this%Q(i,j,k,1)) + this%Imin =min(this%Imin ,this%I (i,j,k)); this%Imax =max(this%Imax ,this%I (i,j,k)) + this%Pmin =min(this%Pmin ,this%P (i,j,k)); this%Pmax =max(this%Pmax ,this%P (i,j,k)) + this%Tmin =min(this%Tmin ,this%T (i,j,k)); this%Tmax =max(this%Tmax ,this%T (i,j,k)) + this%Umax=max(this%Umax,abs(this%U(i,j,k))) + this%Vmax=max(this%Vmax,abs(this%V(i,j,k))) + this%Wmax=max(this%Wmax,abs(this%W(i,j,k))) + end do; end do; end do + call MPI_ALLREDUCE(MPI_IN_PLACE,this%RHOmin,1,MPI_REAL_WP,MPI_MIN,this%cfg%comm,ierr) + call MPI_ALLREDUCE(MPI_IN_PLACE,this%RHOmax,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + call MPI_ALLREDUCE(MPI_IN_PLACE,this%Imin ,1,MPI_REAL_WP,MPI_MIN,this%cfg%comm,ierr) + call MPI_ALLREDUCE(MPI_IN_PLACE,this%Imax ,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + call MPI_ALLREDUCE(MPI_IN_PLACE,this%Pmin ,1,MPI_REAL_WP,MPI_MIN,this%cfg%comm,ierr) + call MPI_ALLREDUCE(MPI_IN_PLACE,this%Pmax ,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + call MPI_ALLREDUCE(MPI_IN_PLACE,this%Tmin ,1,MPI_REAL_WP,MPI_MIN,this%cfg%comm,ierr) + call MPI_ALLREDUCE(MPI_IN_PLACE,this%Tmax ,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + call MPI_ALLREDUCE(MPI_IN_PLACE,this%Umax ,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + call MPI_ALLREDUCE(MPI_IN_PLACE,this%Vmax ,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + call MPI_ALLREDUCE(MPI_IN_PLACE,this%Wmax ,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + + end subroutine get_info + + + !> Print out info for spcomp flow solver + subroutine spcomp_print(this) + use, intrinsic :: iso_fortran_env, only: output_unit + implicit none + class(spcomp), intent(in) :: this + if (this%cfg%amRoot) write(output_unit,'("spcomp solver [",a,"] for config [",a,"]")') trim(this%name),trim(this%cfg%name) + end subroutine spcomp_print + + + !> Finalize spcomp flow solver + subroutine finalize(this) + implicit none + class(spcomp), intent(inout) :: this + nullify(this%cfg) + this%name='UNNAMED_SPCOMP' + nullify(this%getP) + nullify(this%getT) + nullify(this%getC) + nullify(this%getS) + this%nQ=0 + if (allocated(this%Q)) deallocate(this%Q) + if (allocated(this%Qold)) deallocate(this%Qold) + if (allocated(this%U)) deallocate(this%U) + if (allocated(this%V)) deallocate(this%V) + if (allocated(this%W)) deallocate(this%W) + if (allocated(this%I)) deallocate(this%I) + if (allocated(this%P)) deallocate(this%P) + if (allocated(this%T)) deallocate(this%T) + if (allocated(this%C)) deallocate(this%C) + if (allocated(this%VISC)) deallocate(this%VISC) + if (allocated(this%BETA)) deallocate(this%BETA) + if (allocated(this%DIFF)) deallocate(this%DIFF) + if (allocated(this%Qmin)) deallocate(this%Qmin) + if (allocated(this%Qmax)) deallocate(this%Qmax) + if (allocated(this%Qint)) deallocate(this%Qint) + call this%trhs%finalize() + end subroutine finalize + + +end module spcomp_class diff --git a/examples/sphere_peri/GNUmakefile b/examples/sphere_peri/GNUmakefile new file mode 100644 index 000000000..23c4d3dba --- /dev/null +++ b/examples/sphere_peri/GNUmakefile @@ -0,0 +1,49 @@ +# NGA location if not yet defined +NGA_HOME ?= ~/nga2/Repositories/nga2 + +# Compilation parameters +PRECISION = DOUBLE +USE_MPI = TRUE +USE_HYPRE = TRUE +USE_LAPACK= TRUE +USE_FFTW = TRUE +USE_IRL = FALSE +PROFILE = FALSE +DEBUG = FALSE +COMP = gnu +EXEBASE = nga + +# Directories that contain user-defined code +Udirs := src + +# Include user-defined sources +Upack += $(foreach dir, $(Udirs), $(wildcard $(dir)/Make.package)) +Ulocs += $(foreach dir, $(Udirs), $(wildcard $(dir))) +include $(Upack) +INCLUDE_LOCATIONS += $(Ulocs) +VPATH_LOCATIONS += $(Ulocs) + +# External libraries are defined in .profile/.bashrc/.zshrc, but could be defined here as well +HYPRE_DIR=/Users/imauser/nga2/Repositories/hypre/src/hypre +FFTW_DIR=/opt/homebrew/Cellar/fftw/3.3.10_2 + +# NGA compilation definitions +include $(NGA_HOME)/tools/GNUMake/Make.defs + +# Include NGA base code +Bdirs := constant_density particles core data transform solver config grid libraries +Bpack += $(foreach dir, $(Bdirs), $(NGA_HOME)/src/$(dir)/Make.package) +include $(Bpack) + +# Inform user of Make.packages used +ifdef Ulocs + $(info Taking user code from: $(Ulocs)) +endif +$(info Taking base code from: $(Bdirs)) + +# Target definition +all: $(executable) + @echo COMPILATION SUCCESSFUL + +# NGA compilation rules +include $(NGA_HOME)/tools/GNUMake/Make.rules diff --git a/examples/sphere_peri/input b/examples/sphere_peri/input new file mode 100644 index 000000000..e9be5299c --- /dev/null +++ b/examples/sphere_peri/input @@ -0,0 +1,36 @@ +# Parallelization +Partition : 2 2 2 + +# Mesh definition +Lx : 10 +Ly : 6 +Lz : 6 +nx : 100 +ny : 60 +nz : 60 + +# Case definition +Cylinder radius : 0.5 +# STL file : sphere.stl + +# Adimensional flow parameters +Gamma : 1.4 +Prandtl number : 0.71 +Shock Mach number : 1.2 +Shock location : -1 +Reynolds number : 4.99e5 + +# Solid properties +Solid dx : 0.037750 +Elastic Modulus : 1000 +Poisson Ratio : 0.25 +Solid density : 1000 +Critical Energy Release Rate : 0.05 + +# Time integration +Max timestep size : 2e-3 +Max cfl number : 0.9 +Max time : 100 + +# Ensight output +Ensight output period : 2e-3 diff --git a/examples/sphere_peri/src/Make.package b/examples/sphere_peri/src/Make.package new file mode 100644 index 000000000..ddc060c7d --- /dev/null +++ b/examples/sphere_peri/src/Make.package @@ -0,0 +1,2 @@ +# List here the extra files here +f90EXE_sources += simulation.f90 geometry.f90 lss_class.f90 spcomp_class.f90 diff --git a/examples/sphere_peri/src/geometry.f90 b/examples/sphere_peri/src/geometry.f90 new file mode 100644 index 000000000..7f3d82d5c --- /dev/null +++ b/examples/sphere_peri/src/geometry.f90 @@ -0,0 +1,73 @@ +!> Various definitions and tools for initializing NGA2 config +module geometry + use config_class, only: config + use precision, only: WP + implicit none + private + + !> Single config + type(config), public :: cfg + + public :: geometry_init + +contains + + + !> Initialization of problem geometry + subroutine geometry_init + use sgrid_class, only: sgrid + use param, only: param_read + implicit none + type(sgrid) :: grid + + + ! Create a grid from input params + create_grid: block + use sgrid_class, only: cartesian + integer :: i,j,k,nx,ny,nz + real(WP) :: Lx,Ly,Lz + real(WP), dimension(:), allocatable :: x,y,z + + ! Read in grid definition + call param_read('Lx',Lx); call param_read('nx',nx); allocate(x(nx+1)) + call param_read('Ly',Ly); call param_read('ny',ny); allocate(y(ny+1)) + call param_read('Lz',Lz); call param_read('nz',nz); allocate(z(nz+1)) + + ! Create simple rectilinear grid + do i=1,nx+1 + x(i)=real(i-1,WP)/real(nx,WP)*Lx-0.25_WP*Lx + end do + do j=1,ny+1 + y(j)=real(j-1,WP)/real(ny,WP)*Ly-0.5_WP*Ly + end do + do k=1,nz+1 + z(k)=real(k-1,WP)/real(nz,WP)*Lz-0.5_WP*Lz + end do + + ! General serial grid object (no=3 needed to support ghost/image point interpolation/extrapolation) + grid=sgrid(coord=cartesian,no=3,x=x,y=y,z=z,xper=.false.,yper=.true.,zper=.true.,name='box') + + end block create_grid + + + ! Create a config from that grid on our entire group + create_cfg: block + use parallel, only: group + integer, dimension(3) :: partition + ! Read in partition + call param_read('Partition',partition,short='p') + ! Create partitioned grid + cfg=config(grp=group,decomp=partition,grid=grid) + end block create_cfg + + + ! Create walls for this config + create_walls: block + cfg%VF=1.0_WP + end block create_walls + + + end subroutine geometry_init + + +end module geometry diff --git a/examples/sphere_peri/src/lss_class.f90 b/examples/sphere_peri/src/lss_class.f90 new file mode 100644 index 000000000..85e669c00 --- /dev/null +++ b/examples/sphere_peri/src/lss_class.f90 @@ -0,0 +1,1733 @@ +!> Lagrangian solid solver object +!> Implements peridynamics equations +module lss_class + use precision, only: WP + use string, only: str_medium + use config_class, only: config + use mpi_f08, only: MPI_Datatype,MPI_INTEGER8,MPI_INTEGER,MPI_DOUBLE_PRECISION + implicit none + private + + + ! Expose type/constructor/methods + public :: lss + + + !> Memory adaptation parameter + real(WP), parameter :: coeff_up=1.3_WP !< Particle array size increase factor + real(WP), parameter :: coeff_dn=0.7_WP !< Particle array size decrease factor + + + !> I/O chunk size to read at a time + integer, parameter :: part_chunk_size=1000 !< Read 1000 particles at a time before redistributing + + + !> Maximum number of bonds per particle + integer, parameter, public :: max_bond=200 !< Assumes something like a 7x7x7 stencil in 3D + + + !> Bonded solid particle definition + type :: part + !> MPI_DOUBLE_PRECISION data + real(WP) :: mw !< Weighted volume + real(WP) :: dil !< Element dilatation + real(WP), dimension(max_bond) :: dbond !< Length of initial bonds + real(WP), dimension(3) :: pos !< Particle center coordinates + real(WP), dimension(3) :: vel !< Velocity of particle + real(WP), dimension(3) :: Abond !< Bond acceleration for particle + real(WP), dimension(3) :: drag !< Fluid force from IBM + real(WP), dimension(3) :: normal !< Normal direction for surface particle + !> MPI_INTEGER data + integer :: id !< ID the object is associated with + integer :: i !< Unique index of particle (assumed >0) + integer :: nbond !< Number of initial bonds + integer, dimension(max_bond) :: ibond !< Indices of initially bonded particles (0 values ignored) + integer , dimension(3) :: ind !< Index of cell containing particle center + integer :: flag !< Control parameter (0=normal, 1=done->will be removed, 2=surface particle) + end type part + !> Number of blocks, block length, and block types in a particle + integer, parameter :: part_nblock=2 + integer , dimension(part_nblock) :: part_lblock=[17+max_bond,7+max_bond] + type(MPI_Datatype), dimension(part_nblock) :: part_tblock=[MPI_DOUBLE_PRECISION,MPI_INTEGER] + !> MPI_PART derived datatype and size + type(MPI_Datatype) :: MPI_PART + integer :: MPI_PART_SIZE + + + !> Lagrangian solid solver object definition + type :: lss + + ! This config is used for parallelization and for calculating bond/collision forces + class(config), pointer :: cfg + + ! This is the name of the solver + character(len=str_medium) :: name='UNNAMED_LSS' + + ! Solid material properties + real(WP) :: elastic_modulus !< Elastic modulus of the material + real(WP) :: poisson_ratio !< Poisson's ratio of the material + real(WP) :: rho !< Density of the material + real(WP) :: crit_energy !< Critical energy release + real(WP) :: dV !< Element volume + + ! Bonding parameters + real(WP) :: delta !< Bonding horizon (distance) + integer :: nb !< Cell-based horizon + + ! Global and local particle data + integer :: np !< Global number of particles + integer :: np_ !< Local number of particles + integer, dimension(:), allocatable :: np_proc !< Number of particles on each processor + type(part), dimension(:), allocatable :: p !< Array of particles of type part + type(part), dimension(:), allocatable :: pold !< Array of temporary particles for RK4 + type(part), dimension(:), allocatable :: pbuf !< Array of temporary particles for RK4 + + ! Overlap particle (i.e., ghost) data + integer :: ng_ !< Local number of ghosts + type(part), dimension(:), allocatable :: g !< Array of ghosts of type part + + ! Gravitational acceleration + real(WP), dimension(3) :: gravity=0.0_WP + + ! Volume fraction and normal vector associated with IBM projection + real(WP), dimension(:,:,:), allocatable :: VF !< Volume fraction, cell-centered + real(WP), dimension(:,:,:,:), allocatable :: norm !< Normal vector + integer, dimension(:,:,:), allocatable :: phase !< 1 if particles present in cell, 0 otherwise + + ! CFL numbers + real(WP) :: CFLp_x,CFLp_y,CFLp_z + + ! Number of substeps for time integrator + real(WP) :: nstep=1 + + ! Monitoring info + real(WP) :: Umin,Umax,Umean !< U velocity info + real(WP) :: Vmin,Vmax,Vmean !< V velocity info + real(WP) :: Wmin,Wmax,Wmean !< W velocity info + real(WP) :: VFmax !< Volume fraction info + real(WP), dimension(3) :: ibmForce !< Total force due to IBM + integer :: np_out !< Number of particles leaving the domain + + contains + procedure :: bond_init !< Setup initial interparticle bonds + procedure :: get_bond_force !< Compute interparticle bond force + procedure :: substep_rk4 !< RK4 integration of particle ODEs + procedure :: get_source !< Compute IBM source terms + procedure :: get_cfl !< Calculate maximum CFL + procedure :: get_max !< Extract various monitoring data + procedure :: update_partmesh !< Update a partmesh object using current particles + procedure :: share !< Share particles across interprocessor boundaries + procedure :: sync !< Synchronize particles across interprocessor boundaries + procedure :: resize !< Resize particle array to given size + procedure :: resize_ghost !< Resize ghost array to given size + procedure :: recycle !< Recycle particle array by removing flagged particles + procedure :: write !< Parallel write particles to file + procedure :: read !< Parallel read particles from file + procedure :: update_VF !< Compute volume fraction + procedure :: calculate_normal !< Compute normal vector from volume fraction + procedure :: get_delta !< Compute regularized delta function + procedure :: interpolate !< Interpolation routine from mesh=>marker + procedure :: extrapolate !< Extrapolation routine from marker=>mesh + end type lss + + + !> Declare lss constructor + interface lss + procedure constructor + end interface lss + +contains + + + ! Quasi-Gaussian weighting function - h is the cut-off + real(WP) function wgauss(d,h) + implicit none + real(WP), intent(in) :: d,h + real(WP), parameter :: coeff=2.6_WP + real(WP) :: hh + hh=coeff*h + if (d.ge.hh) then + wgauss=0.0_WP + else + wgauss=(1.0_WP+4.0_WP*d/hh)*(1.0_WP-d/hh)**4 + end if + end function wgauss + + + !> Default constructor for Lagrangian solid solver + function constructor(cfg,name) result(self) + implicit none + type(lss) :: self + class(config), target, intent(in) :: cfg + character(len=*), optional :: name + integer :: i,j,k + + ! Set the name for the solver + if (present(name)) self%name=trim(adjustl(name)) + + ! Point to pgrid object + self%cfg=>cfg + + ! Set default bonding horizon based on underlying mesh + self%delta=self%cfg%min_meshsize + self%nb=1 + + ! Allocate variables + allocate(self%np_proc(1:self%cfg%nproc)); self%np_proc=0 + self%np_=0; self%np=0 + call self%resize(0) + + ! Initialize MPI derived datatype for a particle + call prepare_mpi_part() + + ! Allocate VF and norm arrays on cfg mesh + allocate(self%VF(self%cfg%imino_:self%cfg%imaxo_,self%cfg%jmino_:self%cfg%jmaxo_,self%cfg%kmino_:self%cfg%kmaxo_)); self%VF=0.0_WP + allocate(self%norm(1:3,self%cfg%imino_:self%cfg%imaxo_,self%cfg%jmino_:self%cfg%jmaxo_,self%cfg%kmino_:self%cfg%kmaxo_)); self%norm=0.0_WP + allocate(self%phase(self%cfg%imino_:self%cfg%imaxo_,self%cfg%jmino_:self%cfg%jmaxo_,self%cfg%kmino_:self%cfg%kmaxo_)); self%phase=0 + + ! Log/screen output + logging: block + use, intrinsic :: iso_fortran_env, only: output_unit + use param, only: verbose + use messager, only: log + use string, only: str_long + character(len=str_long) :: message + if (self%cfg%amRoot) then + write(message,'("LSS object [",a,"] on partitioned grid [",a,"]")') trim(self%name),trim(self%cfg%name) + if (verbose.gt.1) write(output_unit,'(a)') trim(message) + if (verbose.gt.0) call log(message) + end if + end block logging + + end function constructor + + + !> Initialize bond force between particles + subroutine bond_init(this) + use messager, only: die + implicit none + class(lss), intent(inout) :: this + integer, dimension(:,:,:), allocatable :: npic !< Number of particle in cell + integer, dimension(:,:,:,:), allocatable :: ipic !< Index of particle in cell + + ! Communicate particles in ghost cells + call this%share() + + ! We can now assemble particle-in-cell information + pic_prep: block + use mpi_f08 + integer :: i,ip,jp,kp,ierr + integer :: mymax_npic,max_npic + + ! Allocate number of particle in cell + allocate(npic(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)); npic=0 + + ! Count particles and ghosts per cell + do i=1,this%np_ + ip=this%p(i)%ind(1); jp=this%p(i)%ind(2); kp=this%p(i)%ind(3) + npic(ip,jp,kp)=npic(ip,jp,kp)+1 + end do + do i=1,this%ng_ + ip=this%g(i)%ind(1); jp=this%g(i)%ind(2); kp=this%g(i)%ind(3) + npic(ip,jp,kp)=npic(ip,jp,kp)+1 + end do + + ! Get maximum number of particle in cell + mymax_npic=maxval(npic); call MPI_ALLREDUCE(mymax_npic,max_npic,1,MPI_INTEGER,MPI_MAX,this%cfg%comm,ierr) + + ! Allocate pic map + allocate(ipic(1:max_npic,this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)); ipic=0 + + ! Assemble pic map + npic=0 + do i=1,this%np_ + ip=this%p(i)%ind(1); jp=this%p(i)%ind(2); kp=this%p(i)%ind(3) + npic(ip,jp,kp)=npic(ip,jp,kp)+1 + ipic(npic(ip,jp,kp),ip,jp,kp)=+i + end do + do i=1,this%ng_ + ip=this%g(i)%ind(1); jp=this%g(i)%ind(2); kp=this%g(i)%ind(3) + npic(ip,jp,kp)=npic(ip,jp,kp)+1 + ipic(npic(ip,jp,kp),ip,jp,kp)=-i + end do + + end block pic_prep + + ! Establish initial bonds + create_bonds: block + use mathtools, only: Pi + integer :: i,j,k,n1,nn,n2,nbond_surf + type(part) :: p1,p2 + real(WP), dimension(3) :: rpos + real(WP) :: dist + + ! Number of bonds associated with surface particle (this could be better) + nbond_surf=ceiling(4.0_WP/3.0_WP*Pi*this%delta**3/this%dV*0.6_WP) + + ! Loop over particles + do n1=1,this%np_ + ! Create copy of our particle + p1=this%p(n1) + ! Zero out weighted volume + p1%mw=0.0_WP + ! Zero out bonds + p1%ibond=0 + p1%nbond=0 + ! Loop over neighbor cells + do k=p1%ind(3)-this%nb,p1%ind(3)+this%nb + do j=p1%ind(2)-this%nb,p1%ind(2)+this%nb + do i=p1%ind(1)-this%nb,p1%ind(1)+this%nb + ! Loop over particles in that cell + do nn=1,npic(i,j,k) + ! Create copy of our neighbor + n2=ipic(nn,i,j,k) + if (n2.gt.0) then + p2=this%p(+n2) + else if (n2.lt.0) then + p2=this%g(-n2) + end if + ! Cannot self-bond + if (p1%i.eq.p2%i) cycle + ! Cannot bond with different id except <=0 (<=0 bonds with everyone) + if (p1%id.ne.p2%id.and.p1%id.ge.0.and.p2%id.ge.0) cycle + ! Check interparticle distance + rpos=p2%pos-p1%pos + dist=sqrt(dot_product(rpos,rpos)) + if (dist.lt.this%delta) then + ! This particle is in horizon, create a bond + p1%nbond=p1%nbond+1 + if (p1%nbond.gt.max_bond) call die('[lss_class bond_init] Number of detected bonds is larger than max allowed') + p1%ibond(p1%nbond)=p2%i + p1%dbond(p1%nbond)=dist + ! Increment weighted volume + p1%mw=p1%mw+wgauss(dist,this%delta)*dist**2*this%dV + end if + end do + end do + end do + end do + ! Zero out initial dilatation + p1%dil=0.0_WP + ! Copy back the particle + this%p(n1)=p1 + ! Flag surface particles based on nbond + if (this%p(n1)%nbond.lt.nbond_surf) this%p(n1)%flag=2 + end do + end block create_bonds + + ! Clean up + if (allocated(npic)) deallocate(npic) + if (allocated(ipic)) deallocate(ipic) + + end subroutine bond_init + + + !> Calculate bond force between particles + subroutine get_bond_force(this) + implicit none + class(lss), intent(inout) :: this + integer, dimension(:,:,:), allocatable :: npic !< Number of particle in cell + integer, dimension(:,:,:,:), allocatable :: ipic !< Index of particle in cell + + ! Communicate particles in ghost cells + call this%share() + + ! We can now assemble particle-in-cell information + pic_prep: block + use mpi_f08 + integer :: i,ip,jp,kp,ierr + integer :: mymax_npic,max_npic + + ! Allocate number of particle in cell + allocate(npic(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)); npic=0 + + ! Count particles and ghosts per cell + do i=1,this%np_ + ip=this%p(i)%ind(1); jp=this%p(i)%ind(2); kp=this%p(i)%ind(3) + npic(ip,jp,kp)=npic(ip,jp,kp)+1 + end do + do i=1,this%ng_ + ip=this%g(i)%ind(1); jp=this%g(i)%ind(2); kp=this%g(i)%ind(3) + npic(ip,jp,kp)=npic(ip,jp,kp)+1 + end do + + ! Get maximum number of particle in cell + mymax_npic=maxval(npic); call MPI_ALLREDUCE(mymax_npic,max_npic,1,MPI_INTEGER,MPI_MAX,this%cfg%comm,ierr) + + ! Allocate pic map + allocate(ipic(1:max_npic,this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)); ipic=0 + + ! Assemble pic map + npic=0 + do i=1,this%np_ + ip=this%p(i)%ind(1); jp=this%p(i)%ind(2); kp=this%p(i)%ind(3) + npic(ip,jp,kp)=npic(ip,jp,kp)+1 + ipic(npic(ip,jp,kp),ip,jp,kp)=+i + end do + do i=1,this%ng_ + ip=this%g(i)%ind(1); jp=this%g(i)%ind(2); kp=this%g(i)%ind(3) + npic(ip,jp,kp)=npic(ip,jp,kp)+1 + ipic(npic(ip,jp,kp),ip,jp,kp)=-i + end do + + end block pic_prep + + ! Update weighted volume and dilatation + update_weighted_vol_and_dilatation: block + integer :: i,j,k,n1,nn,n2 + type(part) :: p1,p2 + integer :: nb,nbond + real(WP), dimension(3) :: rpos + real(WP) :: dist + + ! Loop over particles + do n1=1,this%np_ + ! Create copy of our particle + p1=this%p(n1) + ! Zero out weighted volume and dilatation + p1%mw=0.0_WP + p1%dil=0.0_WP + ! Loop over neighbor cells + do k=p1%ind(3)-this%nb,p1%ind(3)+this%nb + do j=p1%ind(2)-this%nb,p1%ind(2)+this%nb + do i=p1%ind(1)-this%nb,p1%ind(1)+this%nb + ! Loop over particles in that cell + do nn=1,npic(i,j,k) + ! Create copy of our neighbor + n2=ipic(nn,i,j,k) + if (n2.gt.0) then + p2=this%p(+n2) + else if (n2.lt.0) then + p2=this%g(-n2) + end if + ! Check if a bond exists + do nb=1,max_bond + if (p1%ibond(nb).eq.p2%i) then + ! Increment weighted volume + p1%mw=p1%mw+wgauss(p1%dbond(nb),this%delta)*p1%dbond(nb)**2*this%dV + ! Get current distance + rpos=p2%pos-p1%pos + dist=sqrt(dot_product(rpos,rpos)) + ! Increment dilatation + p1%dil=p1%dil+wgauss(p1%dbond(nb),this%delta)*p1%dbond(nb)*(dist-p1%dbond(nb))*this%dV + end if + end do + end do + end do + end do + end do + ! Rescale dilatation + p1%dil=p1%dil*3.0_WP/p1%mw + ! Copy back the particle + this%p(n1)=p1 + end do + end block update_weighted_vol_and_dilatation + + ! Re-communicate particles in ghost cells to update dil and mw + call this%share() + + ! Update bond force, including collision force + update_bond_force: block + use mathtools, only: Pi + integer :: i,j,k,n1,nn,n2 + type(part) :: p1,p2 + real(WP), dimension(3) :: rpos,t12,t21 + real(WP) :: dist,beta,alpha,ed + real(WP) :: stretch,max_stretch,mu,kk + real(WP) :: nc,rc,kc + integer :: nb,nbond + logical :: found_bond + + ! Recompute a few physical parameters + mu=this%elastic_modulus/(2.0_WP+2.0_WP*this%poisson_ratio) + kk=this%elastic_modulus/(3.0_WP-6.0_WP*this%poisson_ratio) + max_stretch=sqrt(this%crit_energy/((3.0_WP*mu+(kk-5.0_WP*mu/3.0_WP)*0.75_WP**4)*this%delta)) + rc=this%dV**(1.0_WP/3.0_WP) + nc=1.0_WP + kc=15.0_WP*12.0_WP*this%elastic_modulus/(Pi*this%delta**4) + + ! Loop over particles + do n1=1,this%np_ + ! Particles marked 0 do not update their forces + if (this%p(n1)%id.eq.0) cycle + ! Create copy of our particle + p1=this%p(n1) + ! Zero out bond force + p1%Abond=0.0_WP + ! Loop over neighbor cells + do k=p1%ind(3)-this%nb,p1%ind(3)+this%nb + do j=p1%ind(2)-this%nb,p1%ind(2)+this%nb + do i=p1%ind(1)-this%nb,p1%ind(1)+this%nb + ! Loop over particles in that cell + do nn=1,npic(i,j,k) + ! Create copy of our neighbor + n2=ipic(nn,i,j,k) + if (n2.gt.0) then + p2=this%p(+n2) + else if (n2.lt.0) then + p2=this%g(-n2) + end if + ! Current distance + rpos=p2%pos-p1%pos + dist=sqrt(dot_product(rpos,rpos)) + ! Check if a bond exists + found_bond=.false. + do nb=1,max_bond + if (p1%ibond(nb).eq.p2%i) then + ! Check for breakage first + stretch=(dist-p1%dbond(nb))/p1%dbond(nb) + if (stretch.gt.max_stretch) then + ! Remove the bond and flag as surface particle + p1%ibond(nb)=0 + p1%dbond(nb)=0.0_WP + p1%flag=2 + cycle + end if + ! Beta1 + beta=3.0_WP*kk*p1%dil + ! Alpha1 + alpha=15.0_WP*mu/p1%mw + ! Extension1 + ed=dist-p1%dbond(nb)*(1.0_WP+p1%dil/3.0_WP) + ! Force density 1->2 + t12=+wgauss(p1%dbond(nb),this%delta)*(beta/p1%mw*p1%dbond(nb)+alpha*ed)*rpos/dist + ! Beta2 + beta=3.0_WP*kk*p2%dil + ! Alpha2 + alpha=15.0_WP*mu/p2%mw + ! Extension2 + ed=dist-p1%dbond(nb)*(1.0_WP+p2%dil/3.0_WP) + ! Force density 2->1 + t21=-wgauss(p1%dbond(nb),this%delta)*(beta/p2%mw*p1%dbond(nb)+alpha*ed)*rpos/dist + ! Increment bond force + p1%Abond=p1%Abond+(t12-t21)*this%dV/this%rho + ! If still here, we have an active bond + found_bond=.true. + cycle + end if + end do + ! Add collision force now + if (.not.found_bond.and.p1%i.ne.p2%i.and.dist.lt.rc) then + p1%Abond=p1%Abond-kc*((rc/dist)**nc-1.0_WP)*(rpos/dist)*this%dV/this%rho + end if + end do + end do + end do + end do + ! Copy back the particle + this%p(n1)=p1 + end do + end block update_bond_force + + ! Clean up + if (allocated(npic)) deallocate(npic) + if (allocated(ipic)) deallocate(ipic) + + end subroutine get_bond_force + + + !> Advance the particle equations in a stage of RK4 + !> p%id=-2 => do not solve for position nor velocity + !> p%id=-1 => do not solve for velocity + !> p%id= 0 => do not update force + subroutine substep_rk4(this,stage,dt,Gamma,Pinf,U,V,W,P,RHO,srcRHO,srcI,srcU,srcV,srcW) + use mpi_f08, only: MPI_ALLREDUCE,MPI_SUM,MPI_MAX,MPI_INTEGER,MPI_IN_PLACE + use parallel, only: MPI_REAL_WP + use mathtools, only: Pi + implicit none + class(lss), intent(inout) :: this + integer, intent(in) :: stage !< RK stage + real(WP), intent(inout) :: dt !< Timestep size over which to advance + real(WP), intent(inout) :: Gamma !< Adiabatic index + real(WP), intent(inout) :: Pinf !< Reference pressure + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(inout) :: U !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(inout) :: V !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(inout) :: W !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(inout) :: P !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(inout) :: RHO !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(inout), optional :: srcRHO !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(inout), optional :: srcI !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(inout), optional :: srcU !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(inout), optional :: srcV !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(inout), optional :: srcW !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + integer :: i,j,k,ierr + real(WP) :: dti,rho_,srcRHO_,srcI_ + integer, dimension(3) :: ind_gp + real(WP), dimension(3) :: srcvel_,vel,acc,dxdt,dudt,pos_gp + real(WP), parameter :: oneHalf=1.0_WP/2.0_WP + real(WP), parameter :: oneThird=1.0_WP/3.0_WP + real(WP), parameter :: oneSixth=1.0_WP/6.0_WP + logical :: apply_neumann + + ! Zero out source term arrays + srcRHO=0.0_WP + srcI=0.0_WP + srcU=0.0_WP + srcV=0.0_WP + srcW=0.0_WP + dti=1.0_WP/dt + + select case (stage) + case (1) + ! First RK step ==================================================================================== + ! Zero out number of particles removed + this%np_out=0 + + ! Calculate bond force + call this%get_bond_force() + + ! Prepare temporary particle varrays + if (allocated(this%pold)) deallocate(this%pold) + if (allocated(this%pbuf)) deallocate(this%pbuf) + allocate(this%pold(this%np_)) + allocate(this%pbuf(this%np_)) + this%pold=this%p + + ! Take a substep + do i=1,this%np_ + if (this%p(i)%id.eq.0) cycle + call this%get_source(dti=dti,& + & Gamma=Gamma,& + & Pinf=Pinf,& + & U=U,& + & V=V,& + & W=W,& + & P=P,& + & RHO=RHO,& + & p1=this%p(i),& + & tag=apply_neumann,& + & pos_gp=pos_gp,& + & ind_gp=ind_gp,& + & srcRHO=srcRHO_,& + & srcI=srcI_,& + & srcvel=srcvel_) + ! Send momentum source terms back to the mesh using particle coordinate + if (this%cfg%nx.gt.1) call this%extrapolate(Ap=srcvel_(1),xp=this%p(i)%pos(1),yp=this%p(i)%pos(2),zp=this%p(i)%pos(3),ip=this%p(i)%ind(1),jp=this%p(i)%ind(2),kp=this%p(i)%ind(3),A=srcU,dir='U') + if (this%cfg%ny.gt.1) call this%extrapolate(Ap=srcvel_(2),xp=this%p(i)%pos(1),yp=this%p(i)%pos(2),zp=this%p(i)%pos(3),ip=this%p(i)%ind(1),jp=this%p(i)%ind(2),kp=this%p(i)%ind(3),A=srcV,dir='V') + if (this%cfg%nz.gt.1) call this%extrapolate(Ap=srcvel_(3),xp=this%p(i)%pos(1),yp=this%p(i)%pos(2),zp=this%p(i)%pos(3),ip=this%p(i)%ind(1),jp=this%p(i)%ind(2),kp=this%p(i)%ind(3),A=srcW,dir='W') + ! Send density/energy source terms back to the mesh using ghost point coordinate + if (apply_neumann) then + call this%extrapolate(Ap=srcRHO_,xp=pos_gp(1),yp=pos_gp(2),zp=pos_gp(3),ip=ind_gp(1),jp=ind_gp(2),kp=ind_gp(3),A=srcRHO,dir='SC') + call this%extrapolate(Ap=srcI_,xp=pos_gp(1),yp=pos_gp(2),zp=pos_gp(3),ip=ind_gp(1),jp=ind_gp(2),kp=ind_gp(3),A=srcI,dir='SC') + end if + ! Get right-hand side terms + this%p(i)%drag=-srcvel_ + acc=this%p(i)%drag/(this%rho*this%dV) + dxdt=this%p(i)%vel + dudt=this%gravity+this%p(i)%Abond+acc + ! Update particle position + if (this%p(i)%id.gt.-2) this%pbuf(i)%pos = this%pold(i)%pos + dt*dxdt*oneSixth + if (this%p(i)%id.gt.-2) this%p(i)%pos = this%pold(i)%pos + dt*dxdt*oneHalf + ! Update particle velocity + if (this%p(i)%id.gt.-1) this%pbuf(i)%vel = this%pold(i)%vel + dt*dudt*oneSixth + if (this%p(i)%id.gt.-1) this%p(i)%vel = this%pold(i)%vel + dt*dudt*oneHalf + ! Correct the position to take into account periodicity + if (this%cfg%xper) this%p(i)%pos(1)=this%cfg%x(this%cfg%imin)+modulo(this%p(i)%pos(1)-this%cfg%x(this%cfg%imin),this%cfg%xL) + if (this%cfg%yper) this%p(i)%pos(2)=this%cfg%y(this%cfg%jmin)+modulo(this%p(i)%pos(2)-this%cfg%y(this%cfg%jmin),this%cfg%yL) + if (this%cfg%zper) this%p(i)%pos(3)=this%cfg%z(this%cfg%kmin)+modulo(this%p(i)%pos(3)-this%cfg%z(this%cfg%kmin),this%cfg%zL) + ! Handle particles that have left the domain + if (this%p(i)%pos(1).lt.this%cfg%x(this%cfg%imin).or.this%p(i)%pos(1).gt.this%cfg%x(this%cfg%imax+1)) this%p(i)%flag=1 + if (this%p(i)%pos(2).lt.this%cfg%y(this%cfg%jmin).or.this%p(i)%pos(2).gt.this%cfg%y(this%cfg%jmax+1)) this%p(i)%flag=1 + if (this%p(i)%pos(3).lt.this%cfg%z(this%cfg%kmin).or.this%p(i)%pos(3).gt.this%cfg%z(this%cfg%kmax+1)) this%p(i)%flag=1 + ! Relocalize the particle + this%p(i)%ind=this%cfg%get_ijk_global(this%p(i)%pos,this%p(i)%ind) + end do + + case (2) + ! Second RK step ==================================================================================== + do i=1,this%np_ + if (this%p(i)%id.eq.0) cycle + call this%get_source(dti=dti,& + & Gamma=Gamma,& + & Pinf=Pinf,& + & U=U,& + & V=V,& + & W=W,& + & P=P,& + & RHO=RHO,& + & p1=this%p(i),& + & tag=apply_neumann,& + & pos_gp=pos_gp,& + & ind_gp=ind_gp,& + & srcRHO=srcRHO_,& + & srcI=srcI_,& + & srcvel=srcvel_) + ! Send momentum source terms back to the mesh using particle coordinate + if (this%cfg%nx.gt.1) call this%extrapolate(Ap=srcvel_(1),xp=this%p(i)%pos(1),yp=this%p(i)%pos(2),zp=this%p(i)%pos(3),ip=this%p(i)%ind(1),jp=this%p(i)%ind(2),kp=this%p(i)%ind(3),A=srcU,dir='U') + if (this%cfg%ny.gt.1) call this%extrapolate(Ap=srcvel_(2),xp=this%p(i)%pos(1),yp=this%p(i)%pos(2),zp=this%p(i)%pos(3),ip=this%p(i)%ind(1),jp=this%p(i)%ind(2),kp=this%p(i)%ind(3),A=srcV,dir='V') + if (this%cfg%nz.gt.1) call this%extrapolate(Ap=srcvel_(3),xp=this%p(i)%pos(1),yp=this%p(i)%pos(2),zp=this%p(i)%pos(3),ip=this%p(i)%ind(1),jp=this%p(i)%ind(2),kp=this%p(i)%ind(3),A=srcW,dir='W') + ! Send density/energy source terms back to the mesh using ghost point coordinate + if (apply_neumann) then + call this%extrapolate(Ap=srcRHO_,xp=pos_gp(1),yp=pos_gp(2),zp=pos_gp(3),ip=ind_gp(1),jp=ind_gp(2),kp=ind_gp(3),A=srcRHO,dir='SC') + call this%extrapolate(Ap=srcI_,xp=pos_gp(1),yp=pos_gp(2),zp=pos_gp(3),ip=ind_gp(1),jp=ind_gp(2),kp=ind_gp(3),A=srcI,dir='SC') + end if + ! Get right-hand side terms + this%p(i)%drag=-srcvel_ + acc=this%p(i)%drag/(this%rho*this%dV) + dxdt=this%p(i)%vel + dudt=this%gravity+this%p(i)%Abond+acc + ! Update particle position + if (this%p(i)%id.gt.-2) this%pbuf(i)%pos = this%pbuf(i)%pos + dt*dxdt*oneThird + if (this%p(i)%id.gt.-2) this%p(i)%pos = this%pold(i)%pos + dt*dxdt*oneHalf + ! Update particle velocity + if (this%p(i)%id.gt.-1) this%pbuf(i)%vel = this%pbuf(i)%vel + dt*dudt*oneThird + if (this%p(i)%id.gt.-1) this%p(i)%vel = this%pold(i)%vel + dt*dudt*oneHalf + ! Correct the position to take into account periodicity + if (this%cfg%xper) this%p(i)%pos(1)=this%cfg%x(this%cfg%imin)+modulo(this%p(i)%pos(1)-this%cfg%x(this%cfg%imin),this%cfg%xL) + if (this%cfg%yper) this%p(i)%pos(2)=this%cfg%y(this%cfg%jmin)+modulo(this%p(i)%pos(2)-this%cfg%y(this%cfg%jmin),this%cfg%yL) + if (this%cfg%zper) this%p(i)%pos(3)=this%cfg%z(this%cfg%kmin)+modulo(this%p(i)%pos(3)-this%cfg%z(this%cfg%kmin),this%cfg%zL) + ! Handle particles that have left the domain + if (this%p(i)%pos(1).lt.this%cfg%x(this%cfg%imin).or.this%p(i)%pos(1).gt.this%cfg%x(this%cfg%imax+1)) this%p(i)%flag=1 + if (this%p(i)%pos(2).lt.this%cfg%y(this%cfg%jmin).or.this%p(i)%pos(2).gt.this%cfg%y(this%cfg%jmax+1)) this%p(i)%flag=1 + if (this%p(i)%pos(3).lt.this%cfg%z(this%cfg%kmin).or.this%p(i)%pos(3).gt.this%cfg%z(this%cfg%kmax+1)) this%p(i)%flag=1 + ! Relocalize the particle + this%p(i)%ind=this%cfg%get_ijk_global(this%p(i)%pos,this%p(i)%ind) + end do + + case (3) + ! Third RK step ==================================================================================== + do i=1,this%np_ + if (this%p(i)%id.eq.0) cycle + call this%get_source(dti=dti,& + & Gamma=Gamma,& + & Pinf=Pinf,& + & U=U,& + & V=V,& + & W=W,& + & P=P,& + & RHO=RHO,& + & p1=this%p(i),& + & tag=apply_neumann,& + & pos_gp=pos_gp,& + & ind_gp=ind_gp,& + & srcRHO=srcRHO_,& + & srcI=srcI_,& + & srcvel=srcvel_) + ! Send momentum source terms back to the mesh using particle coordinate + if (this%cfg%nx.gt.1) call this%extrapolate(Ap=srcvel_(1),xp=this%p(i)%pos(1),yp=this%p(i)%pos(2),zp=this%p(i)%pos(3),ip=this%p(i)%ind(1),jp=this%p(i)%ind(2),kp=this%p(i)%ind(3),A=srcU,dir='U') + if (this%cfg%ny.gt.1) call this%extrapolate(Ap=srcvel_(2),xp=this%p(i)%pos(1),yp=this%p(i)%pos(2),zp=this%p(i)%pos(3),ip=this%p(i)%ind(1),jp=this%p(i)%ind(2),kp=this%p(i)%ind(3),A=srcV,dir='V') + if (this%cfg%nz.gt.1) call this%extrapolate(Ap=srcvel_(3),xp=this%p(i)%pos(1),yp=this%p(i)%pos(2),zp=this%p(i)%pos(3),ip=this%p(i)%ind(1),jp=this%p(i)%ind(2),kp=this%p(i)%ind(3),A=srcW,dir='W') + ! Send density/energy source terms back to the mesh using ghost point coordinate + if (apply_neumann) then + call this%extrapolate(Ap=srcRHO_,xp=pos_gp(1),yp=pos_gp(2),zp=pos_gp(3),ip=ind_gp(1),jp=ind_gp(2),kp=ind_gp(3),A=srcRHO,dir='SC') + call this%extrapolate(Ap=srcI_,xp=pos_gp(1),yp=pos_gp(2),zp=pos_gp(3),ip=ind_gp(1),jp=ind_gp(2),kp=ind_gp(3),A=srcI,dir='SC') + end if + ! Get right-hand side terms + this%p(i)%drag=-srcvel_ + acc=this%p(i)%drag/(this%rho*this%dV) + dxdt=this%p(i)%vel + dudt=this%gravity+this%p(i)%Abond+acc + ! Update particle position + if (this%p(i)%id.gt.-2) this%pbuf(i)%pos = this%pbuf(i)%pos + dt*dxdt*oneThird + if (this%p(i)%id.gt.-2) this%p(i)%pos = this%pold(i)%pos + dt*dxdt + ! Update particle velocity + if (this%p(i)%id.gt.-1) this%pbuf(i)%vel = this%pbuf(i)%vel + dt*dudt*oneThird + if (this%p(i)%id.gt.-1) this%p(i)%vel = this%pold(i)%vel + dt*dudt + ! Correct the position to take into account periodicity + if (this%cfg%xper) this%p(i)%pos(1)=this%cfg%x(this%cfg%imin)+modulo(this%p(i)%pos(1)-this%cfg%x(this%cfg%imin),this%cfg%xL) + if (this%cfg%yper) this%p(i)%pos(2)=this%cfg%y(this%cfg%jmin)+modulo(this%p(i)%pos(2)-this%cfg%y(this%cfg%jmin),this%cfg%yL) + if (this%cfg%zper) this%p(i)%pos(3)=this%cfg%z(this%cfg%kmin)+modulo(this%p(i)%pos(3)-this%cfg%z(this%cfg%kmin),this%cfg%zL) + ! Handle particles that have left the domain + if (this%p(i)%pos(1).lt.this%cfg%x(this%cfg%imin).or.this%p(i)%pos(1).gt.this%cfg%x(this%cfg%imax+1)) this%p(i)%flag=1 + if (this%p(i)%pos(2).lt.this%cfg%y(this%cfg%jmin).or.this%p(i)%pos(2).gt.this%cfg%y(this%cfg%jmax+1)) this%p(i)%flag=1 + if (this%p(i)%pos(3).lt.this%cfg%z(this%cfg%kmin).or.this%p(i)%pos(3).gt.this%cfg%z(this%cfg%kmax+1)) this%p(i)%flag=1 + ! Relocalize the particle + this%p(i)%ind=this%cfg%get_ijk_global(this%p(i)%pos,this%p(i)%ind) + end do + + case (4) + ! Fourth RK step ==================================================================================== + do i=1,this%np_ + if (this%p(i)%id.eq.0) cycle + call this%get_source(dti=dti,& + & Gamma=Gamma,& + & Pinf=Pinf,& + & U=U,& + & V=V,& + & W=W,& + & P=P,& + & RHO=RHO,& + & p1=this%p(i),& + & tag=apply_neumann,& + & pos_gp=pos_gp,& + & ind_gp=ind_gp,& + & srcRHO=srcRHO_,& + & srcI=srcI_,& + & srcvel=srcvel_) + ! Send momentum source terms back to the mesh using particle coordinate + if (this%cfg%nx.gt.1) call this%extrapolate(Ap=srcvel_(1),xp=this%p(i)%pos(1),yp=this%p(i)%pos(2),zp=this%p(i)%pos(3),ip=this%p(i)%ind(1),jp=this%p(i)%ind(2),kp=this%p(i)%ind(3),A=srcU,dir='U') + if (this%cfg%ny.gt.1) call this%extrapolate(Ap=srcvel_(2),xp=this%p(i)%pos(1),yp=this%p(i)%pos(2),zp=this%p(i)%pos(3),ip=this%p(i)%ind(1),jp=this%p(i)%ind(2),kp=this%p(i)%ind(3),A=srcV,dir='V') + if (this%cfg%nz.gt.1) call this%extrapolate(Ap=srcvel_(3),xp=this%p(i)%pos(1),yp=this%p(i)%pos(2),zp=this%p(i)%pos(3),ip=this%p(i)%ind(1),jp=this%p(i)%ind(2),kp=this%p(i)%ind(3),A=srcW,dir='W') + ! Send density/energy source terms back to the mesh using ghost point coordinate + if (apply_neumann) then + call this%extrapolate(Ap=srcRHO_,xp=pos_gp(1),yp=pos_gp(2),zp=pos_gp(3),ip=ind_gp(1),jp=ind_gp(2),kp=ind_gp(3),A=srcRHO,dir='SC') + call this%extrapolate(Ap=srcI_,xp=pos_gp(1),yp=pos_gp(2),zp=pos_gp(3),ip=ind_gp(1),jp=ind_gp(2),kp=ind_gp(3),A=srcI,dir='SC') + end if + ! Get right-hand side terms + this%p(i)%drag=-srcvel_ + acc=this%p(i)%drag/(this%rho*this%dV) + dxdt=this%p(i)%vel + dudt=this%gravity+this%p(i)%Abond+acc + ! Update particle position + if (this%p(i)%id.gt.-2) this%p(i)%pos = this%pbuf(i)%pos + dt*dxdt*oneSixth + ! Update particle velocity + if (this%p(i)%id.gt.-1) this%p(i)%vel = this%pbuf(i)%vel + dt*dudt*oneSixth + ! Correct the position to take into account periodicity + if (this%cfg%xper) this%p(i)%pos(1)=this%cfg%x(this%cfg%imin)+modulo(this%p(i)%pos(1)-this%cfg%x(this%cfg%imin),this%cfg%xL) + if (this%cfg%yper) this%p(i)%pos(2)=this%cfg%y(this%cfg%jmin)+modulo(this%p(i)%pos(2)-this%cfg%y(this%cfg%jmin),this%cfg%yL) + if (this%cfg%zper) this%p(i)%pos(3)=this%cfg%z(this%cfg%kmin)+modulo(this%p(i)%pos(3)-this%cfg%z(this%cfg%kmin),this%cfg%zL) + ! Handle particles that have left the domain + if (this%p(i)%pos(1).lt.this%cfg%x(this%cfg%imin).or.this%p(i)%pos(1).gt.this%cfg%x(this%cfg%imax+1)) this%p(i)%flag=1 + if (this%p(i)%pos(2).lt.this%cfg%y(this%cfg%jmin).or.this%p(i)%pos(2).gt.this%cfg%y(this%cfg%jmax+1)) this%p(i)%flag=1 + if (this%p(i)%pos(3).lt.this%cfg%z(this%cfg%kmin).or.this%p(i)%pos(3).gt.this%cfg%z(this%cfg%kmax+1)) this%p(i)%flag=1 + ! Relocalize the particle + this%p(i)%ind=this%cfg%get_ijk_global(this%p(i)%pos,this%p(i)%ind) + ! Count number of particles removed + if (this%p(i)%flag.eq.1) then + this%np_out=this%np_out+1 + end if + end do + ! Communicate particles + call this%sync() + ! Sum up particles removed + call MPI_ALLREDUCE(MPI_IN_PLACE,this%np_out,1,MPI_INTEGER,MPI_SUM,this%cfg%comm,ierr) + + end select + + ! Sum at boundaries + call this%cfg%syncsum(srcRHO) + call this%cfg%syncsum(srcI) + call this%cfg%syncsum(srcU) + call this%cfg%syncsum(srcV) + call this%cfg%syncsum(srcW) + + ! Recompute volume fraction + call this%update_VF() + + ! Log/screen output + logging: block + use, intrinsic :: iso_fortran_env, only: output_unit + use param, only: verbose + use messager, only: log + use string, only: str_long + character(len=str_long) :: message + if (this%cfg%amRoot) then + write(message,'("Solid solver [",a,"] on partitioned grid [",a,"]: ",i0," particles were advanced")') trim(this%name),trim(this%cfg%name),this%np + if (verbose.gt.1) write(output_unit,'(a)') trim(message) + if (verbose.gt.0) call log(message) + end if + end block logging + + end subroutine substep_rk4 + + + !> Compute direct forcing source by a specified time step dt + subroutine get_source(this,dti,Gamma,Pinf,U,V,W,P,RHO,p1,tag,pos_gp,ind_gp,srcRHO,srcI,srcvel) + implicit none + class(lss), intent(inout) :: this + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(inout) :: U !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(inout) :: V !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(inout) :: W !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(inout) :: P !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(inout) :: RHO !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + real(WP), intent(in) :: dti,Gamma,Pinf + type(part), intent(inout) :: p1 + logical, intent(out) :: tag + real(WP), intent(out) :: srcRHO,srcI + real(WP), dimension(3), intent(out) :: pos_gp,srcvel + integer, dimension(3), intent(out) :: ind_gp + real(WP) :: P_IP,RHO_IP,fRHO,RHO_GP,I_GP,P_GP,RHO_tar,I_tar + integer, dimension(3) :: ind_ip + real(WP), dimension(3) :: fvel,pos_ip,norm + + tag=.false. + + ! Interpolate fluid quantities to the particle location + fvel=0.0_WP + if (this%cfg%nx.gt.1) fvel(1)=this%interpolate(A=U,xp=p1%pos(1),yp=p1%pos(2),zp=p1%pos(3),ip=p1%ind(1),jp=p1%ind(2),kp=p1%ind(3),dir='U') + if (this%cfg%ny.gt.1) fvel(2)=this%interpolate(A=V,xp=p1%pos(1),yp=p1%pos(2),zp=p1%pos(3),ip=p1%ind(1),jp=p1%ind(2),kp=p1%ind(3),dir='V') + if (this%cfg%nz.gt.1) fvel(3)=this%interpolate(A=W,xp=p1%pos(1),yp=p1%pos(2),zp=p1%pos(3),ip=p1%ind(1),jp=p1%ind(2),kp=p1%ind(3),dir='W') + fRHO=this%interpolate(A=rho,xp=p1%pos(1),yp=p1%pos(2),zp=p1%pos(3),ip=p1%ind(1),jp=p1%ind(2),kp=p1%ind(3),dir='SC') + + ! Momentum source term computed at every particle + srcvel=fRHO*(p1%vel-fvel)*dti*this%dV + ! Surface particles handle ghost/image points for Neumann BC + if (p1%flag.eq.2) then + ! Interpolate norm to particle + norm=this%cfg%get_velocity(pos=p1%pos,i0=p1%ind(1),j0=p1%ind(2),k0=p1%ind(3),U=this%norm(1,:,:,:),V=this%norm(2,:,:,:),W=this%norm(3,:,:,:)) + ! Get ghost/image point coordinates + p1%normal=norm/norm2(norm) + pos_ip=p1%pos+this%cfg%min_meshsize*norm + ind_ip=this%cfg%get_ijk_local(pos_ip,p1%ind) + if (this%phase(ind_ip(1),ind_ip(2),ind_ip(3)).eq.0) then + ! Image point lies within fluid, we are at the surface + tag=.true. + pos_gp=p1%pos-this%cfg%min_meshsize*norm + ind_gp=this%cfg%get_ijk_local(pos_gp,p1%ind) + ! Interpolate fluid quantities to image points + P_IP=this%interpolate(A=P,xp=pos_ip(1),yp=pos_ip(2),zp=pos_ip(3),ip=ind_ip(1),jp=ind_ip(2),kp=ind_ip(3),dir='SC') + RHO_IP=this%interpolate(A=RHO,xp=pos_ip(1),yp=pos_ip(2),zp=pos_ip(3),ip=ind_ip(1),jp=ind_ip(2),kp=ind_ip(3),dir='SC') + ! Interpolate fluid quantities to the ghost point + P_GP=this%interpolate(A=P,xp=pos_gp(1),yp=pos_gp(2),zp=pos_gp(3),ip=ind_gp(1),jp=ind_gp(2),kp=ind_gp(3),dir='SC') + RHO_GP=this%interpolate(A=RHO,xp=pos_gp(1),yp=pos_gp(2),zp=pos_gp(3),ip=ind_gp(1),jp=ind_gp(2),kp=ind_gp(3),dir='SC') + ! Reconstruct conserved variables at the ghost point using ideal gas + I_GP=(P_GP+Gamma*Pinf)/(RHO_GP*(Gamma-1.0_WP)) + ! Set target conserved variables to enforce adiabatic BC + RHO_tar=RHO_IP + I_tar=(P_IP+Gamma*Pinf)/(RHO_IP*(Gamma-1.0_WP)) + ! Source terms to enforce adiabatic + srcRHO=(RHO_tar-RHO_GP)*dti*this%dV + srcI=(I_tar-I_GP)*dti*this%dV + end if + end if + + end subroutine get_source + + !> Update particle volume fraction using our current particles + subroutine update_VF(this) + implicit none + class(lss), intent(inout) :: this + integer :: i + ! Reset volume fraction + this%VF=0.0_WP + this%phase=0 + ! Transfer particle volume + do i=1,this%np_ + ! Skip inactive particle + if (this%p(i)%flag.eq.1) cycle + ! Transfer volume to mesh + call this%extrapolate(Ap=this%dV,xp=this%p(i)%pos(1),yp=this%p(i)%pos(2),zp=this%p(i)%pos(3),ip=this%p(i)%ind(1),jp=this%p(i)%ind(2),kp=this%p(i)%ind(3),A=this%VF,dir='SC') + ! This cell is not empty + this%phase(this%p(i)%ind(1),this%p(i)%ind(2),this%p(i)%ind(3))=1 + end do + ! Sum at boundaries + call this%cfg%syncsum(this%VF) + ! Synchronize it + call this%cfg%sync(this%phase) + ! Compute the normal vector based on VF + call this%calculate_normal() + end subroutine update_VF + + + !> Calculate normal vector from the volume fraction + subroutine calculate_normal(this) + implicit none + class(lss), intent(inout) :: this + integer :: i,j,k + real(WP) :: buf + do k=this%cfg%kmino_+1,this%cfg%kmaxo_ + do j=this%cfg%jmino_+1,this%cfg%jmaxo_ + do i=this%cfg%imino_+1,this%cfg%imaxo_ + this%norm(1,i,j,k)=(this%VF(i,j,k)-this%VF(i-1,j ,k ))*this%cfg%dxmi(i) + this%norm(2,i,j,k)=(this%VF(i,j,k)-this%VF(i ,j-1,k ))*this%cfg%dymi(j) + this%norm(3,i,j,k)=(this%VF(i,j,k)-this%VF(i ,j ,k-1))*this%cfg%dzmi(k) + buf=norm2(this%norm(:,i,j,k)) + if (buf.gt.0.0_WP) then + this%norm(:,i,j,k)=-this%norm(:,i,j,k)/buf + else + this%norm(:,i,j,k)=0.0_WP + end if + end do + end do + end do + ! Synchronize it + call this%cfg%sync(this%norm) + ! Extend to non-periodic edges + if (.not.this%cfg%xper) then + if (this%cfg%iproc.eq.1) then + this%norm(:,this%cfg%imino,:,:)=this%norm(:,this%cfg%imino+1,:,:) + else if (this%cfg%iproc.eq.this%cfg%npx) then + this%norm(:,this%cfg%imaxo,:,:)=this%norm(:,this%cfg%imaxo-1,:,:) + end if + end if + if (.not.this%cfg%yper) then + if (this%cfg%jproc.eq.1) then + this%norm(:,:,this%cfg%jmino,:)=this%norm(:,:,this%cfg%jmino+1,:) + else if (this%cfg%jproc.eq.this%cfg%npy) then + this%norm(:,:,this%cfg%jmaxo,:)=this%norm(:,:,this%cfg%jmaxo-1,:) + end if + end if + if (.not.this%cfg%zper) then + if (this%cfg%kproc.eq.1) then + this%norm(:,:,:,this%cfg%kmino)=this%norm(:,:,:,this%cfg%kmino+1) + else if (this%cfg%kproc.eq.this%cfg%npz) then + this%norm(:,:,:,this%cfg%kmaxo)=this%norm(:,:,:,this%cfg%kmaxo-1) + end if + end if + end subroutine calculate_normal + + + !> Compute regularized delta function + subroutine get_delta(this,delta,ic,jc,kc,xp,yp,zp,dir) + implicit none + class(lss), intent(inout) :: this + real(WP), intent(out) :: delta !< Return delta function + integer, intent(in) :: ic,jc,kc !< Cell index + real(WP), intent(in) :: xp,yp,zp !< Position of marker + character(len=*) :: dir + real(WP) :: deltax,deltay,deltaz,r + + ! Compute in X + if (trim(adjustl(dir)).eq.'U') then + r=(xp-this%cfg%x(ic))*this%cfg%dxmi(ic) + deltax=roma_kernel(r)*this%cfg%dxmi(ic) + else + r=(xp-this%cfg%xm(ic))*this%cfg%dxi(ic) + deltax=roma_kernel(r)*this%cfg%dxi(ic) + end if + + ! Compute in Y + if (trim(adjustl(dir)).eq.'V') then + r=(yp-this%cfg%y(jc))*this%cfg%dymi(jc) + deltay=roma_kernel(r)*this%cfg%dymi(jc) + else + r=(yp-this%cfg%ym(jc))*this%cfg%dyi(jc) + deltay=roma_kernel(r)*this%cfg%dyi(jc) + end if + + ! Compute in Z + if (trim(adjustl(dir)).eq.'W') then + r=(zp-this%cfg%z(kc))*this%cfg%dzmi(kc) + deltaz=roma_kernel(r)*this%cfg%dzmi(kc) + else + r=(zp-this%cfg%zm(kc))*this%cfg%dzi(kc) + deltaz=roma_kernel(r)*this%cfg%dzi(kc) + end if + + ! Put it all together + delta=deltax*deltay*deltaz + + contains + ! Mollification kernel + ! Roma A, Peskin C and Berger M 1999 J. Comput. Phys. 153 509–534 + function roma_kernel(r) result(phi) + implicit none + real(WP), intent(in) :: r + real(WP) :: phi + if (abs(r).le.0.5_WP) then + phi=1.0_WP/3.0_WP*(1.0_WP+sqrt(-3.0_WP*r**2+1.0_WP)) + else if (abs(r).gt.0.5_WP .and. abs(r).le.1.5_WP) then + phi=1.0_WP/6.0_WP*(5.0_WP-3.0_WP*abs(r)-sqrt(-3.0_WP*(1.0_WP-abs(r))**2+1.0_WP)) + else + phi=0.0_WP + end if + end function roma_kernel + + end subroutine get_delta + + + !> Interpolation routine + function interpolate(this,A,xp,yp,zp,ip,jp,kp,dir) result(Ap) + implicit none + class(lss), intent(inout) :: this + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(in) :: A !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + real(WP), intent(in) :: xp,yp,zp + integer, intent(in) :: ip,jp,kp + character(len=*) :: dir + real(WP) :: Ap + integer :: di,dj,dk + integer :: i1,i2,j1,j2,k1,k2 + real(WP), dimension(-2:+2,-2:+2,-2:+2) :: delta + ! Get the interpolation points + i1=ip-2; i2=ip+2 + j1=jp-2; j2=jp+2 + k1=kp-2; k2=kp+2 + ! Loop over neighboring cells and compute regularized delta function + do dk=-2,+2 + do dj=-2,+2 + do di=-2,+2 + call this%get_delta(delta=delta(di,dj,dk),ic=ip+di,jc=jp+dj,kc=kp+dk,xp=xp,yp=yp,zp=zp,dir=trim(dir)) + end do + end do + end do + ! Perform the actual interpolation on Ap + Ap = sum(delta*A(i1:i2,j1:j2,k1:k2))*this%cfg%vol(ip,jp,kp) + end function interpolate + + + !> Extrapolation routine + subroutine extrapolate(this,Ap,xp,yp,zp,ip,jp,kp,A,dir) + use messager, only: die + implicit none + class(lss), intent(inout) :: this + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:) :: A !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + real(WP), intent(in) :: xp,yp,zp + integer, intent(in) :: ip,jp,kp + real(WP), intent(in) :: Ap + character(len=*) :: dir + real(WP), dimension(-2:+2,-2:+2,-2:+2) :: delta + integer :: di,dj,dk + ! If particle has left processor domain or reached last ghost cell, kill job + if ( ip.lt.this%cfg%imin_-1.or.ip.gt.this%cfg%imax_+1.or.& + & jp.lt.this%cfg%jmin_-1.or.jp.gt.this%cfg%jmax_+1.or.& + & kp.lt.this%cfg%kmin_-1.or.kp.gt.this%cfg%kmax_+1) then + write(*,*) ip,jp,kp,xp,yp,zp + call die('[df extrapolate] Particle has left the domain') + end if + ! Loop over neighboring cells and compute regularized delta function + do dk=-2,+2 + do dj=-2,+2 + do di=-2,+2 + call this%get_delta(delta=delta(di,dj,dk),ic=ip+di,jc=jp+dj,kc=kp+dk,xp=xp,yp=yp,zp=zp,dir=trim(dir)) + end do + end do + end do + ! Perform the actual extrapolation on A + A(ip-2:ip+2,jp-2:jp+2,kp-2:kp+2)=A(ip-2:ip+2,jp-2:jp+2,kp-2:kp+2)+delta*Ap + end subroutine extrapolate + + + !> Calculate the CFL + subroutine get_cfl(this,dt,cfl) + use mpi_f08, only: MPI_ALLREDUCE,MPI_MAX + use parallel, only: MPI_REAL_WP + implicit none + class(lss), intent(inout) :: this + real(WP), intent(in) :: dt + real(WP), intent(out) :: cfl + integer :: i,ierr + real(WP) :: my_CFLp_x,my_CFLp_y,my_CFLp_z + + ! Set the CFLs to zero + my_CFLp_x=0.0_WP; my_CFLp_y=0.0_WP; my_CFLp_z=0.0_WP + do i=1,this%np_ + my_CFLp_x=max(my_CFLp_x,abs(this%p(i)%vel(1))*this%cfg%dxi(this%p(i)%ind(1))) + my_CFLp_y=max(my_CFLp_y,abs(this%p(i)%vel(2))*this%cfg%dyi(this%p(i)%ind(2))) + my_CFLp_z=max(my_CFLp_z,abs(this%p(i)%vel(3))*this%cfg%dzi(this%p(i)%ind(3))) + end do + my_CFLp_x=my_CFLp_x*dt; my_CFLp_y=my_CFLp_y*dt; my_CFLp_z=my_CFLp_z*dt + + ! Get the parallel max + call MPI_ALLREDUCE(my_CFLp_x,this%CFLp_x,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + call MPI_ALLREDUCE(my_CFLp_y,this%CFLp_y,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + call MPI_ALLREDUCE(my_CFLp_z,this%CFLp_z,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + + ! Return the maximum CFL + cfl=max(this%CFLp_x,this%CFLp_y,this%CFLp_z) + + end subroutine get_cfl + + + !> Extract various monitoring data from particle field + subroutine get_max(this) + use mpi_f08, only: MPI_ALLREDUCE,MPI_MAX,MPI_MIN,MPI_SUM + use parallel, only: MPI_REAL_WP + implicit none + class(lss), intent(inout) :: this + real(WP) :: buf,safe_np + real(WP), dimension(3) :: buf3D + integer :: i,j,k,ierr + + ! Create safe np + safe_np=real(max(this%np,1),WP) + + ! Velocity min/max/mean + this%Umin=huge(1.0_WP); this%Umax=-huge(1.0_WP); this%Umean=0.0_WP + this%Vmin=huge(1.0_WP); this%Vmax=-huge(1.0_WP); this%Vmean=0.0_WP + this%Wmin=huge(1.0_WP); this%Wmax=-huge(1.0_WP); this%Wmean=0.0_WP + this%ibmForce=0.0_WP + do i=1,this%np_ + this%Umin=min(this%Umin,this%p(i)%vel(1)); this%Umax=max(this%Umax,this%p(i)%vel(1)); this%Umean=this%Umean+this%p(i)%vel(1) + this%Vmin=min(this%Vmin,this%p(i)%vel(2)); this%Vmax=max(this%Vmax,this%p(i)%vel(2)); this%Vmean=this%Vmean+this%p(i)%vel(2) + this%Wmin=min(this%Wmin,this%p(i)%vel(3)); this%Wmax=max(this%Wmax,this%p(i)%vel(3)); this%Wmean=this%Wmean+this%p(i)%vel(3) + this%ibmForce=this%ibmForce+this%p(i)%drag + end do + call MPI_ALLREDUCE(this%Umin ,buf,1,MPI_REAL_WP,MPI_MIN,this%cfg%comm,ierr); this%Umin =buf + call MPI_ALLREDUCE(this%Umax ,buf,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr); this%Umax =buf + call MPI_ALLREDUCE(this%Umean,buf,1,MPI_REAL_WP,MPI_SUM,this%cfg%comm,ierr); this%Umean=buf/safe_np + call MPI_ALLREDUCE(this%Vmin ,buf,1,MPI_REAL_WP,MPI_MIN,this%cfg%comm,ierr); this%Vmin =buf + call MPI_ALLREDUCE(this%Vmax ,buf,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr); this%Vmax =buf + call MPI_ALLREDUCE(this%Vmean,buf,1,MPI_REAL_WP,MPI_SUM,this%cfg%comm,ierr); this%Vmean=buf/safe_np + call MPI_ALLREDUCE(this%Wmin ,buf,1,MPI_REAL_WP,MPI_MIN,this%cfg%comm,ierr); this%Wmin =buf + call MPI_ALLREDUCE(this%Wmax ,buf,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr); this%Wmax =buf + call MPI_ALLREDUCE(this%Wmean,buf,1,MPI_REAL_WP,MPI_SUM,this%cfg%comm,ierr); this%Wmean=buf/safe_np + call MPI_ALLREDUCE(this%ibmForce,buf3D,3,MPI_REAL_WP,MPI_SUM,this%cfg%comm,ierr); this%ibmForce=buf3D + + ! Get max volume fraction + this%VFmax =-huge(1.0_WP) + do k=this%cfg%kmin_,this%cfg%kmax_ + do j=this%cfg%jmin_,this%cfg%jmax_ + do i=this%cfg%imin_,this%cfg%imax_ + this%VFmax=max(this%VFmax,this%VF(i,j,k)) + end do + end do + end do + call MPI_ALLREDUCE(this%VFmax,buf,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr); this%VFmax=buf + + end subroutine get_max + + + !> Update particle mesh using our current particles + subroutine update_partmesh(this,pmesh) + use partmesh_class, only: partmesh + implicit none + class(lss), intent(inout) :: this + class(partmesh), intent(inout) :: pmesh + integer :: i + ! Reset particle mesh storage + call pmesh%reset() + ! Nothing else to do if no particle is present + if (this%np_.eq.0) return + ! Copy particle info + call pmesh%set_size(this%np_) + do i=1,this%np_ + pmesh%pos(:,i)=this%p(i)%pos + end do + end subroutine update_partmesh + + + !> Creation of the MPI datatype for particle + subroutine prepare_mpi_part() + use mpi_f08 + use messager, only: die + implicit none + integer(MPI_ADDRESS_KIND), dimension(part_nblock) :: disp + integer(MPI_ADDRESS_KIND) :: lb,extent + type(MPI_Datatype) :: MPI_PART_TMP + integer :: i,mysize,ierr + ! Prepare the displacement array + disp(1)=0 + do i=2,part_nblock + call MPI_Type_size(part_tblock(i-1),mysize,ierr) + disp(i)=disp(i-1)+int(mysize,MPI_ADDRESS_KIND)*int(part_lblock(i-1),MPI_ADDRESS_KIND) + end do + ! Create and commit the new type + call MPI_Type_create_struct(part_nblock,part_lblock,disp,part_tblock,MPI_PART_TMP,ierr) + call MPI_Type_get_extent(MPI_PART_TMP,lb,extent,ierr) + call MPI_Type_create_resized(MPI_PART_TMP,lb,extent,MPI_PART,ierr) + call MPI_Type_commit(MPI_PART,ierr) + ! If a problem was encountered, say it + if (ierr.ne.0) call die('[lss prepare_mpi_part] MPI Particle type creation failed') + ! Get the size of this type + call MPI_type_size(MPI_PART,MPI_PART_SIZE,ierr) + end subroutine prepare_mpi_part + + + !> Share particles across processor boundaries + subroutine share(this,nover) + use mpi_f08 + use messager, only: warn,die + implicit none + class(lss), intent(inout) :: this + integer, optional :: nover + type(part), dimension(:), allocatable :: tosend + type(part), dimension(:), allocatable :: torecv + integer :: no,nsend,nrecv + type(MPI_Status) :: status + integer :: icnt,isrc,idst,ierr + integer :: i,n + + ! Check overlap size + if (present(nover)) then + no=nover + if (no.gt.this%cfg%no) then + call warn('[lss share] Specified overlap is larger than that of cfg - reducing no') + no=this%cfg%no + else if (no.le.0) then + call die('[lss share] Specified overlap cannot be less or equal to zero') + end if + else + no=1 + end if + + ! Clean up ghost array + call this%resize_ghost(n=0); this%ng_=0 + + ! Share ghost particles in -x (no ghosts are sent here) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(1).lt.this%cfg%imin_+no) nsend=nsend+1 + end do + allocate(tosend(nsend)) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(1).lt.this%cfg%imin_+no) then + nsend=nsend+1 + tosend(nsend)=this%p(n) + if (this%cfg%xper.and.tosend(nsend)%ind(1).lt.this%cfg%imin+no) then + tosend(nsend)%pos(1)=tosend(nsend)%pos(1)+this%cfg%xL + tosend(nsend)%ind(1)=tosend(nsend)%ind(1)+this%cfg%nx + end if + end if + end do + nrecv=0 + call MPI_CART_SHIFT(this%cfg%comm,0,-1,isrc,idst,ierr) + call MPI_SENDRECV(nsend,1,MPI_INTEGER,idst,0,nrecv,1,MPI_INTEGER,isrc,0,this%cfg%comm,status,ierr) + allocate(torecv(nrecv)) + call MPI_SENDRECV(tosend,nsend,MPI_PART,idst,0,torecv,nrecv,MPI_PART,isrc,0,this%cfg%comm,status,ierr) + call this%resize_ghost(this%ng_+nrecv) + this%g(this%ng_+1:this%ng_+nrecv)=torecv + this%ng_=this%ng_+nrecv + if (allocated(tosend)) deallocate(tosend) + if (allocated(torecv)) deallocate(torecv) + + ! Share ghost particles in +x (no ghosts are sent here) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(1).gt.this%cfg%imax_-no) nsend=nsend+1 + end do + allocate(tosend(nsend)) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(1).gt.this%cfg%imax_-no) then + nsend=nsend+1 + tosend(nsend)=this%p(n) + if (this%cfg%xper.and.tosend(nsend)%ind(1).gt.this%cfg%imax-no) then + tosend(nsend)%pos(1)=tosend(nsend)%pos(1)-this%cfg%xL + tosend(nsend)%ind(1)=tosend(nsend)%ind(1)-this%cfg%nx + end if + end if + end do + nrecv=0 + call MPI_CART_SHIFT(this%cfg%comm,0,+1,isrc,idst,ierr) + call MPI_SENDRECV(nsend,1,MPI_INTEGER,idst,0,nrecv,1,MPI_INTEGER,isrc,0,this%cfg%comm,status,ierr) + allocate(torecv(nrecv)) + call MPI_SENDRECV(tosend,nsend,MPI_PART,idst,0,torecv,nrecv,MPI_PART,isrc,0,this%cfg%comm,status,ierr) + call this%resize_ghost(this%ng_+nrecv) + this%g(this%ng_+1:this%ng_+nrecv)=torecv + this%ng_=this%ng_+nrecv + if (allocated(tosend)) deallocate(tosend) + if (allocated(torecv)) deallocate(torecv) + + ! Share ghost particles in -y (ghosts need to be sent now) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(2).lt.this%cfg%jmin_+no) nsend=nsend+1 + end do + do n=1,this%ng_ + if (this%g(n)%ind(2).lt.this%cfg%jmin_+no) nsend=nsend+1 + end do + allocate(tosend(nsend)) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(2).lt.this%cfg%jmin_+no) then + nsend=nsend+1 + tosend(nsend)=this%p(n) + if (this%cfg%yper.and.tosend(nsend)%ind(2).lt.this%cfg%jmin+no) then + tosend(nsend)%pos(2)=tosend(nsend)%pos(2)+this%cfg%yL + tosend(nsend)%ind(2)=tosend(nsend)%ind(2)+this%cfg%ny + end if + end if + end do + do n=1,this%ng_ + if (this%g(n)%ind(2).lt.this%cfg%jmin_+no) then + nsend=nsend+1 + tosend(nsend)=this%g(n) + if (this%cfg%yper.and.tosend(nsend)%ind(2).lt.this%cfg%jmin+no) then + tosend(nsend)%pos(2)=tosend(nsend)%pos(2)+this%cfg%yL + tosend(nsend)%ind(2)=tosend(nsend)%ind(2)+this%cfg%ny + end if + end if + end do + nrecv=0 + call MPI_CART_SHIFT(this%cfg%comm,1,-1,isrc,idst,ierr) + call MPI_SENDRECV(nsend,1,MPI_INTEGER,idst,0,nrecv,1,MPI_INTEGER,isrc,0,this%cfg%comm,status,ierr) + allocate(torecv(nrecv)) + call MPI_SENDRECV(tosend,nsend,MPI_PART,idst,0,torecv,nrecv,MPI_PART,isrc,0,this%cfg%comm,status,ierr) + call this%resize_ghost(this%ng_+nrecv) + this%g(this%ng_+1:this%ng_+nrecv)=torecv + this%ng_=this%ng_+nrecv + if (allocated(tosend)) deallocate(tosend) + if (allocated(torecv)) deallocate(torecv) + + ! Share ghost particles in +y (ghosts need to be sent now - but not newly received ghosts!) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(2).gt.this%cfg%jmax_-no) nsend=nsend+1 + end do + do n=1,this%ng_-nrecv + if (this%g(n)%ind(2).gt.this%cfg%jmax_-no) nsend=nsend+1 + end do + allocate(tosend(nsend)) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(2).gt.this%cfg%jmax_-no) then + nsend=nsend+1 + tosend(nsend)=this%p(n) + if (this%cfg%yper.and.tosend(nsend)%ind(2).gt.this%cfg%jmax-no) then + tosend(nsend)%pos(2)=tosend(nsend)%pos(2)-this%cfg%yL + tosend(nsend)%ind(2)=tosend(nsend)%ind(2)-this%cfg%ny + end if + end if + end do + do n=1,this%ng_-nrecv + if (this%g(n)%ind(2).gt.this%cfg%jmax_-no) then + nsend=nsend+1 + tosend(nsend)=this%g(n) + if (this%cfg%yper.and.tosend(nsend)%ind(2).gt.this%cfg%jmax-no) then + tosend(nsend)%pos(2)=tosend(nsend)%pos(2)-this%cfg%yL + tosend(nsend)%ind(2)=tosend(nsend)%ind(2)-this%cfg%ny + end if + end if + end do + nrecv=0 + call MPI_CART_SHIFT(this%cfg%comm,1,+1,isrc,idst,ierr) + call MPI_SENDRECV(nsend,1,MPI_INTEGER,idst,0,nrecv,1,MPI_INTEGER,isrc,0,this%cfg%comm,status,ierr) + allocate(torecv(nrecv)) + call MPI_SENDRECV(tosend,nsend,MPI_PART,idst,0,torecv,nrecv,MPI_PART,isrc,0,this%cfg%comm,status,ierr) + call this%resize_ghost(this%ng_+nrecv) + this%g(this%ng_+1:this%ng_+nrecv)=torecv + this%ng_=this%ng_+nrecv + if (allocated(tosend)) deallocate(tosend) + if (allocated(torecv)) deallocate(torecv) + + ! Share ghost particles in -z (ghosts need to be sent now) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(3).lt.this%cfg%kmin_+no) nsend=nsend+1 + end do + do n=1,this%ng_ + if (this%g(n)%ind(3).lt.this%cfg%kmin_+no) nsend=nsend+1 + end do + allocate(tosend(nsend)) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(3).lt.this%cfg%kmin_+no) then + nsend=nsend+1 + tosend(nsend)=this%p(n) + if (this%cfg%zper.and.tosend(nsend)%ind(3).lt.this%cfg%kmin+no) then + tosend(nsend)%pos(3)=tosend(nsend)%pos(3)+this%cfg%zL + tosend(nsend)%ind(3)=tosend(nsend)%ind(3)+this%cfg%nz + end if + end if + end do + do n=1,this%ng_ + if (this%g(n)%ind(3).lt.this%cfg%kmin_+no) then + nsend=nsend+1 + tosend(nsend)=this%g(n) + if (this%cfg%zper.and.tosend(nsend)%ind(3).lt.this%cfg%kmin+no) then + tosend(nsend)%pos(3)=tosend(nsend)%pos(3)+this%cfg%zL + tosend(nsend)%ind(3)=tosend(nsend)%ind(3)+this%cfg%nz + end if + end if + end do + nrecv=0 + call MPI_CART_SHIFT(this%cfg%comm,2,-1,isrc,idst,ierr) + call MPI_SENDRECV(nsend,1,MPI_INTEGER,idst,0,nrecv,1,MPI_INTEGER,isrc,0,this%cfg%comm,status,ierr) + allocate(torecv(nrecv)) + call MPI_SENDRECV(tosend,nsend,MPI_PART,idst,0,torecv,nrecv,MPI_PART,isrc,0,this%cfg%comm,status,ierr) + call this%resize_ghost(this%ng_+nrecv) + this%g(this%ng_+1:this%ng_+nrecv)=torecv + this%ng_=this%ng_+nrecv + if (allocated(tosend)) deallocate(tosend) + if (allocated(torecv)) deallocate(torecv) + + ! Share ghost particles in +z (ghosts need to be sent now - but not newly received ghosts!) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(3).gt.this%cfg%kmax_-no) nsend=nsend+1 + end do + do n=1,this%ng_-nrecv + if (this%g(n)%ind(3).gt.this%cfg%kmax_-no) nsend=nsend+1 + end do + allocate(tosend(nsend)) + nsend=0 + do n=1,this%np_ + if (this%p(n)%ind(3).gt.this%cfg%kmax_-no) then + nsend=nsend+1 + tosend(nsend)=this%p(n) + if (this%cfg%zper.and.tosend(nsend)%ind(3).gt.this%cfg%kmax-no) then + tosend(nsend)%pos(3)=tosend(nsend)%pos(3)-this%cfg%zL + tosend(nsend)%ind(3)=tosend(nsend)%ind(3)-this%cfg%nz + end if + end if + end do + do n=1,this%ng_-nrecv + if (this%g(n)%ind(3).gt.this%cfg%kmax_-no) then + nsend=nsend+1 + tosend(nsend)=this%g(n) + if (this%cfg%zper.and.tosend(nsend)%ind(3).gt.this%cfg%kmax-no) then + tosend(nsend)%pos(3)=tosend(nsend)%pos(3)-this%cfg%zL + tosend(nsend)%ind(3)=tosend(nsend)%ind(3)-this%cfg%nz + end if + end if + end do + nrecv=0 + call MPI_CART_SHIFT(this%cfg%comm,2,+1,isrc,idst,ierr) + call MPI_SENDRECV(nsend,1,MPI_INTEGER,idst,0,nrecv,1,MPI_INTEGER,isrc,0,this%cfg%comm,status,ierr) + allocate(torecv(nrecv)) + call MPI_SENDRECV(tosend,nsend,MPI_PART,idst,0,torecv,nrecv,MPI_PART,isrc,0,this%cfg%comm,status,ierr) + call this%resize_ghost(this%ng_+nrecv) + this%g(this%ng_+1:this%ng_+nrecv)=torecv + this%ng_=this%ng_+nrecv + if (allocated(tosend)) deallocate(tosend) + if (allocated(torecv)) deallocate(torecv) + + end subroutine share + + + !> Synchronize particle arrays across processors + subroutine sync(this) + use mpi_f08 + implicit none + class(lss), intent(inout) :: this + integer, dimension(0:this%cfg%nproc-1) :: nsend_proc,nrecv_proc + integer, dimension(0:this%cfg%nproc-1) :: nsend_disp,nrecv_disp + integer :: n,prank,ierr + type(part), dimension(:), allocatable :: buf_send + ! Recycle first to minimize communication load + call this%recycle() + ! Prepare information about what to send + nsend_proc=0 + do n=1,this%np_ + prank=this%cfg%get_rank(this%p(n)%ind) + nsend_proc(prank)=nsend_proc(prank)+1 + end do + nsend_proc(this%cfg%rank)=0 + ! Inform processors of what they will receive + call MPI_ALLtoALL(nsend_proc,1,MPI_INTEGER,nrecv_proc,1,MPI_INTEGER,this%cfg%comm,ierr) + ! Prepare displacements for all-to-all + nsend_disp(0)=0 + nrecv_disp(0)=this%np_ !< Directly add particles at the end of main array + do n=1,this%cfg%nproc-1 + nsend_disp(n)=nsend_disp(n-1)+nsend_proc(n-1) + nrecv_disp(n)=nrecv_disp(n-1)+nrecv_proc(n-1) + end do + ! Allocate buffer to send particles + allocate(buf_send(sum(nsend_proc))) + ! Pack the particles in the send buffer + nsend_proc=0 + do n=1,this%np_ + ! Get the rank + prank=this%cfg%get_rank(this%p(n)%ind) + ! Skip particles still inside + if (prank.eq.this%cfg%rank) cycle + ! Pack up for sending + nsend_proc(prank)=nsend_proc(prank)+1 + buf_send(nsend_disp(prank)+nsend_proc(prank))=this%p(n) + ! Flag particle for removal + this%p(n)%flag=1 + end do + ! Allocate buffer for receiving particles + call this%resize(this%np_+sum(nrecv_proc)) + ! Perform communication + call MPI_ALLtoALLv(buf_send,nsend_proc,nsend_disp,MPI_PART,this%p,nrecv_proc,nrecv_disp,MPI_PART,this%cfg%comm,ierr) + ! Deallocate buffer + deallocate(buf_send) + ! Recycle to remove duplicate particles + call this%recycle() + end subroutine sync + + + !> Adaptation of particle array size + subroutine resize(this,n) + implicit none + class(lss), intent(inout) :: this + integer, intent(in) :: n + type(part), dimension(:), allocatable :: tmp + integer :: size_now,size_new + ! Resize particle array to size n + if (.not.allocated(this%p)) then + ! Allocate directly to size n + allocate(this%p(n)) + this%p(1:n)%flag=1 + else + ! Update from a non-zero size to another non-zero size + size_now=size(this%p,dim=1) + if (n.gt.size_now) then + size_new=max(n,int(real(size_now,WP)*coeff_up)) + allocate(tmp(size_new)) + tmp(1:size_now)=this%p + tmp(size_now+1:)%flag=1 + call move_alloc(tmp,this%p) + else if (n.lt.int(real(size_now,WP)*coeff_dn)) then + allocate(tmp(n)) + tmp(1:n)=this%p(1:n) + call move_alloc(tmp,this%p) + end if + end if + end subroutine resize + + + !> Adaptation of ghost array size + subroutine resize_ghost(this,n) + implicit none + class(lss), intent(inout) :: this + integer, intent(in) :: n + type(part), dimension(:), allocatable :: tmp + integer :: size_now,size_new + ! Resize ghost array to size n + if (.not.allocated(this%g)) then + ! Allocate directly to size n + allocate(this%g(n)) + this%g(1:n)%flag=1 + else + ! Update from a non-zero size to another non-zero size + size_now=size(this%g,dim=1) + if (n.gt.size_now) then + size_new=max(n,int(real(size_now,WP)*coeff_up)) + allocate(tmp(size_new)) + tmp(1:size_now)=this%g + tmp(size_now+1:)%flag=1 + call move_alloc(tmp,this%g) + else if (n.lt.int(real(size_now,WP)*coeff_dn)) then + allocate(tmp(n)) + tmp(1:n)=this%g(1:n) + call move_alloc(tmp,this%g) + end if + end if + end subroutine resize_ghost + + + !> Clean-up of particle array by removing flag=1 particles + subroutine recycle(this) + implicit none + class(lss), intent(inout) :: this + integer :: new_size,i,ierr + ! Compact all active particles at the beginning of the array + new_size=0 + if (allocated(this%p)) then + do i=1,size(this%p,dim=1) + if (this%p(i)%flag.ne.1) then + new_size=new_size+1 + if (i.ne.new_size) then + this%p(new_size)=this%p(i) + this%p(i)%flag=1 + end if + end if + end do + end if + ! Resize to new size + call this%resize(new_size) + ! Update number of particles + this%np_=new_size + call MPI_ALLGATHER(this%np_,1,MPI_INTEGER,this%np_proc,1,MPI_INTEGER,this%cfg%comm,ierr) + this%np=sum(this%np_proc) + end subroutine recycle + + + !> Parallel write particles to file + subroutine write(this,filename) + use mpi_f08 + use messager, only: die + use parallel, only: info_mpiio + implicit none + class(lss), intent(inout) :: this + character(len=*), intent(in) :: filename + type(MPI_File) :: ifile + type(MPI_Status):: status + integer(kind=MPI_OFFSET_KIND) :: offset + integer :: i,ierr,iunit + + ! Root serial-writes the file header + if (this%cfg%amRoot) then + ! Open the file + open(newunit=iunit,file=trim(filename),form='unformatted',status='replace',access='stream',iostat=ierr) + if (ierr.ne.0) call die('[lss write] Problem encountered while serial-opening data file: '//trim(filename)) + ! Number of particles and particle object size + write(iunit) this%np,MPI_PART_SIZE + ! Done with the header + close(iunit) + end if + + ! The rest is done in parallel + call MPI_FILE_OPEN(this%cfg%comm,trim(filename),IOR(MPI_MODE_WRONLY,MPI_MODE_APPEND),info_mpiio,ifile,ierr) + if (ierr.ne.0) call die('[lss write] Problem encountered while parallel-opening data file: '//trim(filename)) + + ! Get current position + call MPI_FILE_GET_POSITION(ifile,offset,ierr) + + ! Compute the offset and write + do i=1,this%cfg%rank + offset=offset+int(this%np_proc(i),MPI_OFFSET_KIND)*int(MPI_PART_SIZE,MPI_OFFSET_KIND) + end do + if (this%np_.gt.0) call MPI_FILE_WRITE_AT(ifile,offset,this%p,this%np_,MPI_PART,status,ierr) + + ! Close the file + call MPI_FILE_CLOSE(ifile,ierr) + + ! Log/screen output + logging: block + use, intrinsic :: iso_fortran_env, only: output_unit + use param, only: verbose + use messager, only: log + use string, only: str_long + character(len=str_long) :: message + if (this%cfg%amRoot) then + write(message,'("[lss write] Wrote ",i0," particles to file [",a,"] on partitioned grid [",a,"]")') this%np,trim(filename),trim(this%cfg%name) + if (verbose.gt.2) write(output_unit,'(a)') trim(message) + if (verbose.gt.1) call log(message) + end if + end block logging + + end subroutine write + + + !> Parallel read particles to file + subroutine read(this,filename) + use mpi_f08 + use messager, only: die + use parallel, only: info_mpiio + implicit none + class(lss), intent(inout) :: this + character(len=*), intent(in) :: filename + type(MPI_File) :: ifile + type(MPI_Status):: status + integer(kind=MPI_OFFSET_KIND) :: offset,header_offset + integer :: i,j,ierr,npadd,psize,nchunk,cnt + integer, dimension(:,:), allocatable :: ppp + + ! First open the file in parallel + call MPI_FILE_OPEN(this%cfg%comm,trim(filename),MPI_MODE_RDONLY,info_mpiio,ifile,ierr) + if (ierr.ne.0) call die('[lss read] Problem encountered while reading data file: '//trim(filename)) + + ! Read file header first + call MPI_FILE_READ_ALL(ifile,npadd,1,MPI_INTEGER,status,ierr) + call MPI_FILE_READ_ALL(ifile,psize,1,MPI_INTEGER,status,ierr) + + ! Remember current position + call MPI_FILE_GET_POSITION(ifile,header_offset,ierr) + + ! Check compatibility of particle type + if (psize.ne.MPI_PART_SIZE) call die('[lss read] Particle type unreadable') + + ! Naively share reading task among all processors + nchunk=int(npadd/(this%cfg%nproc*part_chunk_size))+1 + allocate(ppp(this%cfg%nproc,nchunk)) + ppp=int(npadd/(this%cfg%nproc*nchunk)) + cnt=0 + out:do j=1,nchunk + do i=1,this%cfg%nproc + cnt=cnt+1 + if (cnt.gt.mod(npadd,this%cfg%nproc*nchunk)) exit out + ppp(i,j)=ppp(i,j)+1 + end do + end do out + + ! Read by chunk + do j=1,nchunk + ! Find offset + offset=header_offset+int(MPI_PART_SIZE,MPI_OFFSET_KIND)*int(sum(ppp(1:this%cfg%rank,:))+sum(ppp(this%cfg%rank+1,1:j-1)),MPI_OFFSET_KIND) + ! Resize particle array + call this%resize(this%np_+ppp(this%cfg%rank+1,j)) + ! Read this file + call MPI_FILE_READ_AT(ifile,offset,this%p(this%np_+1:this%np_+ppp(this%cfg%rank+1,j)),ppp(this%cfg%rank+1,j),MPI_PART,status,ierr) + ! Most general case: relocate every droplet + do i=this%np_+1,this%np_+ppp(this%cfg%rank+1,j) + this%p(i)%ind=this%cfg%get_ijk_global(this%p(i)%pos,this%p(i)%ind) + end do + ! Exchange all that + call this%sync() + end do + + ! Close the file + call MPI_FILE_CLOSE(ifile,ierr) + + ! Log/screen output + logging: block + use, intrinsic :: iso_fortran_env, only: output_unit + use param, only: verbose + use messager, only: log + use string, only: str_long + character(len=str_long) :: message + if (this%cfg%amRoot) then + write(message,'("[lss read] Read ",i0," particles from file [",a,"] on partitioned grid [",a,"]")') npadd,trim(filename),trim(this%cfg%name) + if (verbose.gt.2) write(output_unit,'(a)') trim(message) + if (verbose.gt.1) call log(message) + end if + end block logging + + end subroutine read + + +end module lss_class diff --git a/examples/sphere_peri/src/simulation.f90 b/examples/sphere_peri/src/simulation.f90 new file mode 100644 index 000000000..0a9e61c23 --- /dev/null +++ b/examples/sphere_peri/src/simulation.f90 @@ -0,0 +1,854 @@ +!> Various definitions and tools for running an NGA2 simulation +module simulation + use precision, only: WP,SP + use geometry, only: cfg + use spcomp_class, only: spcomp + use lss_class, only: lss + use timetracker_class, only: timetracker + use ensight_class, only: ensight + use partmesh_class, only: partmesh + use event_class, only: event + use monitor_class, only: monitor + implicit none + private + + !> Get a couple linear solvers, an incompressible flow solver and corresponding time tracker + type(spcomp), public :: fs + type(lss), public :: ls + type(timetracker), public :: time + + !> Ensight postprocessing + type(partmesh) :: pmesh + type(ensight) :: ens_out + type(event) :: ens_evt + + !> Simulation monitor file + type(monitor) :: mfile,cflfile,consfile,sfile + + public :: simulation_init,simulation_run,simulation_final + + !> Private work arrays + real(WP), dimension(:,:,:,:,:), allocatable :: dQdt + real(WP), dimension(:,:,:,:) , allocatable :: srcQ + real(WP), dimension(:,:,:) , allocatable :: Ui,Vi,Wi,Ma,beta,visc,visc_t,div + + !> Post-shock viscosity and temperature + real(WP) :: visc0,T0 + + !> Equations of state + real(WP) :: Pinf,Gamma,Cv,Prandtl + + !> Flow parameters + real(WP) :: Ms,Xs,Rcyl + real(WP) :: rho1,p1,u1,M1 + real(WP) :: rho2,p2,u2,M2 + real(WP) :: Re + + contains + + + !> Function that returns a smooth Heaviside of thickness delta + real(WP) function Hshock(x,delta) + real(WP), intent(in) :: x,delta + ! Goes from 0 to 1 as x goes from begative to positive + Hshock=1.0_WP/(1.0_WP+exp(-x/delta)) + end function Hshock + + + !> P=EOS(RHO,I) + pure real(WP) function get_P(RHO,I) + implicit none + real(WP), intent(in) :: RHO,I + get_P=RHO*I*(Gamma-1.0_WP)-Gamma*Pinf + end function get_P + !> T=f(RHO,P) + pure real(WP) function get_T(RHO,P) + implicit none + real(WP), intent(in) :: RHO,P + get_T=(P+Pinf)/(Cv*RHO*(Gamma-1.0_WP)) + end function get_T + !> RHO=f(T,P) + pure real(WP) function get_RHO(T,P) + implicit none + real(WP), intent(in) :: T,P + get_RHO=(P+Pinf)/(Cv*T*(Gamma-1.0_WP)) + end function get_RHO + !> I=EOS(RHO,P) + pure real(WP) function get_I(RHO,P) + implicit none + real(WP), intent(in) :: RHO,P + get_I=(P+Gamma*Pinf)/(RHO*(Gamma-1.0_WP)) + end function get_I + !> C=f(RHO,P) + pure real(WP) function get_C(RHO,P) + implicit none + real(WP), intent(in) :: RHO,P + get_C=sqrt(Gamma*(P+Pinf)/RHO) + end function get_C + !> S=f(RHO,P) + pure real(WP) function get_S(RHO,P) + implicit none + real(WP), intent(in) :: RHO,P + get_S=Cv*log((P+Pinf)/RHO**Gamma) + end function get_S + + + !> Calculate viscosities + subroutine prepare_viscosities() + implicit none + integer :: i,j,k + real(WP) :: S + ! Get viscosity from Sutherland's law + S=110.4_WP/273.15_WP*T0 + do k=fs%cfg%kmino_,fs%cfg%kmaxo_ + do j=fs%cfg%jmino_,fs%cfg%jmaxo_ + do i=fs%cfg%imino_,fs%cfg%imaxo_ + visc(i,j,k)=visc0*(T0+S)/(fs%T(i,j,k)+S)*(fs%T(i,j,k)/T0)**1.5_WP + end do + end do + end do + ! Get LAD + call fs%get_viscartif(dt=time%dt,beta=beta); fs%BETA=fs%Q(:,:,:,1)*beta + ! Get eddy viscosity + call fs%get_vreman (dt=time%dt,visc=visc_t); fs%VISC=fs%Q(:,:,:,1)*visc_t+visc + ! Recompute thermal conductivity + fs%diff=Gamma*Cv*fs%visc/Prandtl + ! Add LAD + fs%VISC=fs%VISC+0.002_WP*fs%BETA + end subroutine prepare_viscosities + + + !> Calculate velocity divergence + subroutine get_div() + implicit none + integer :: i,j,k + do k=fs%cfg%kmino_,fs%cfg%kmaxo_-1; do j=fs%cfg%jmino_,fs%cfg%jmaxo_-1; do i=fs%cfg%imino_,fs%cfg%imaxo_-1 + div(i,j,k)=fs%dxi*(fs%U(i+1,j,k)-fs%U(i,j,k))+fs%dyi*(fs%V(i,j+1,k)-fs%V(i,j,k))+fs%dzi*(fs%W(i,j,k+1)-fs%W(i,j,k)) + end do; end do; end do + call fs%cfg%sync(div) + if (.not.fs%cfg%xper.and.fs%cfg%iproc.eq.fs%cfg%npx) div(fs%cfg%imaxo,:,:)=div(fs%cfg%imaxo-1,:,:) + if (.not.fs%cfg%yper.and.fs%cfg%jproc.eq.fs%cfg%npy) div(:,fs%cfg%jmaxo,:)=div(:,fs%cfg%jmaxo-1,:) + if (.not.fs%cfg%zper.and.fs%cfg%kproc.eq.fs%cfg%npz) div(:,:,fs%cfg%kmaxo)=div(:,:,fs%cfg%kmaxo-1) + end subroutine get_div + + + !> Apply boundary conditions + subroutine apply_bconds() + implicit none + integer :: i,j,k + + ! Apply clipped Neumann on primitive variables in x+ + if (.not.fs%cfg%xper.and.fs%cfg%iproc.eq.fs%cfg%npx) then + do k=fs%cfg%kmino_,fs%cfg%kmaxo_; do j=fs%cfg%jmino_,fs%cfg%jmaxo_ + ! Copy over from imax to imax+1 and above + do i=fs%cfg%imax+1,fs%cfg%imaxo + ! Copy primitive variables + ls%VF(i,j,k)=ls%VF(fs%cfg%imax,j,k) + fs%Q(i,j,k,1)=fs%Q(fs%cfg%imax,j,k,1) + fs%P(i,j,k)=fs%P(fs%cfg%imax,j,k) + fs%I(i,j,k)=fs%I(fs%cfg%imax,j,k) + fs%U(i,j,k)=max(fs%U(fs%cfg%imax,j,k),0.0_WP) + fs%V(i,j,k)=fs%V(fs%cfg%imax,j,k) + fs%W(i,j,k)=fs%W(fs%cfg%imax,j,k) + end do + end do; end do + end if + + ! Apply clipped Neumann on primitive variables in y+ + if (.not.fs%cfg%yper.and.fs%cfg%jproc.eq.fs%cfg%npy) then + do k=fs%cfg%kmino_,fs%cfg%kmaxo_; do i=fs%cfg%imino_,fs%cfg%imaxo_ + ! Copy over from jmax to jmax+1 and above + do j=fs%cfg%jmax+1,fs%cfg%jmaxo + ! Copy primitive variables + ls%VF(i,j,k)=ls%VF(i,fs%cfg%jmax,k) + fs%Q(i,j,k,1)=fs%Q(i,fs%cfg%jmax,k,1) + fs%P(i,j,k)=fs%P(i,fs%cfg%jmax,k) + fs%I(i,j,k)=fs%I(i,fs%cfg%jmax,k) + fs%U(i,j,k)=fs%U(i,fs%cfg%jmax,k) + fs%V(i,j,k)=max(fs%V(i,fs%cfg%jmax,k),0.0_WP) + fs%W(i,j,k)=fs%W(i,fs%cfg%jmax,k) + end do + end do; end do + end if + + ! Apply clipped Neumann on primitive variables in y- + if (.not.fs%cfg%yper.and.fs%cfg%jproc.eq.1) then + do k=fs%cfg%kmino_,fs%cfg%kmaxo_; do i=fs%cfg%imino_,fs%cfg%imaxo_ + ! First copy over V from jmin+1 to jmin + fs%V(i,fs%cfg%jmin,k)=min(fs%V(i,fs%cfg%jmin+1,k),0.0_WP) + ! Then copy over from jmin to jmin-1 and below + do j=fs%cfg%jmino,fs%cfg%jmin-1 + ! Copy primitive variables + ls%VF(i,j,k)=ls%VF(i,fs%cfg%jmin,k) + fs%Q(i,j,k,1)=fs%Q(i,fs%cfg%jmin,k,1) + fs%P(i,j,k)=fs%P(i,fs%cfg%jmin,k) + fs%I(i,j,k)=fs%I(i,fs%cfg%jmin,k) + fs%U(i,j,k)=fs%U(i,fs%cfg%jmin,k) + fs%V(i,j,k)=min(fs%V(i,fs%cfg%jmin,k),0.0_WP) + fs%W(i,j,k)=fs%W(i,fs%cfg%jmin,k) + end do + end do; end do + end if + + ! Apply clipped Neumann on primitive variables in z+ + if (.not.fs%cfg%zper.and.fs%cfg%kproc.eq.fs%cfg%npz) then + do j=fs%cfg%jmino_,fs%cfg%jmaxo_; do i=fs%cfg%imino_,fs%cfg%imaxo_ + ! Copy over from kmax to kmax+1 and above + do k=fs%cfg%kmax+1,fs%cfg%kmaxo + ! Copy primitive variables + ls%VF(i,j,k)=ls%VF(i,j,fs%cfg%kmax) + fs%Q(i,j,k,1)=fs%Q(i,j,fs%cfg%kmax,1) + fs%P(i,j,k)=fs%P(i,j,fs%cfg%kmax) + fs%I(i,j,k)=fs%I(i,j,fs%cfg%kmax) + fs%U(i,j,k)=fs%U(i,j,fs%cfg%kmax) + fs%V(i,j,k)=fs%V(i,j,fs%cfg%kmax) + fs%W(i,j,k)=max(fs%W(i,j,fs%cfg%kmax),0.0_WP) + end do + end do; end do + end if + + ! Apply clipped Neumann on primitive variables in z- + if (.not.fs%cfg%zper.and.fs%cfg%kproc.eq.1) then + do j=fs%cfg%jmino_,fs%cfg%jmaxo_; do i=fs%cfg%imino_,fs%cfg%imaxo_ + ! First copy over W from kmin+1 to kmin + fs%W(i,j,fs%cfg%kmin)=min(fs%W(i,j,fs%cfg%kmin+1),0.0_WP) + ! Then copy over from kmin to kmin-1 and below + do k=fs%cfg%kmino,fs%cfg%kmin-1 + ! Copy primitive variables + ls%VF(i,j,k)=ls%VF(i,j,fs%cfg%kmin) + fs%Q(i,j,k,1)=fs%Q(i,j,fs%cfg%kmin,1) + fs%P(i,j,k)=fs%P(i,j,fs%cfg%kmin) + fs%I(i,j,k)=fs%I(i,j,fs%cfg%kmin) + fs%U(i,j,k)=fs%U(i,j,fs%cfg%kmin) + fs%V(i,j,k)=fs%V(i,j,fs%cfg%kmin) + fs%W(i,j,k)=min(fs%W(i,j,fs%cfg%kmin),0.0_WP) + end do + end do; end do + end if + + ! Rebuild conserved quantities + fs%Q(:,:,:,2)=fs%Q(:,:,:,1)*fs%I + call fs%get_momentum() + + end subroutine apply_bconds + + + !> Initialization of problem solver + subroutine simulation_init + use param, only: param_read,param_exists + implicit none + + + ! Create compressible flow solver + create_flow_solver: block + call fs%initialize(cfg=cfg,name='Compressible NS') + end block create_flow_solver + + + ! Allocate work arrays + allocate_work_arrays: block + allocate(dQdt (cfg%imino_:cfg%imaxo_,cfg%jmino_:cfg%jmaxo_,cfg%kmino_:cfg%kmaxo_,1:fs%nQ,1:4)) + allocate(srcQ (cfg%imino_:cfg%imaxo_,cfg%jmino_:cfg%jmaxo_,cfg%kmino_:cfg%kmaxo_,1:fs%nQ)) + allocate(Ui (cfg%imino_:cfg%imaxo_,cfg%jmino_:cfg%jmaxo_,cfg%kmino_:cfg%kmaxo_)) + allocate(Vi (cfg%imino_:cfg%imaxo_,cfg%jmino_:cfg%jmaxo_,cfg%kmino_:cfg%kmaxo_)) + allocate(Wi (cfg%imino_:cfg%imaxo_,cfg%jmino_:cfg%jmaxo_,cfg%kmino_:cfg%kmaxo_)) + allocate(Ma (cfg%imino_:cfg%imaxo_,cfg%jmino_:cfg%jmaxo_,cfg%kmino_:cfg%kmaxo_)) + allocate(beta (cfg%imino_:cfg%imaxo_,cfg%jmino_:cfg%jmaxo_,cfg%kmino_:cfg%kmaxo_)) + allocate(visc (cfg%imino_:cfg%imaxo_,cfg%jmino_:cfg%jmaxo_,cfg%kmino_:cfg%kmaxo_)) + allocate(visc_t(cfg%imino_:cfg%imaxo_,cfg%jmino_:cfg%jmaxo_,cfg%kmino_:cfg%kmaxo_)) + allocate(div (cfg%imino_:cfg%imaxo_,cfg%jmino_:cfg%jmaxo_,cfg%kmino_:cfg%kmaxo_)) + end block allocate_work_arrays + + + ! Initialize eos and flow parameters + initialize_parameters: block + use string, only: str_long + use messager, only: log + use param, only: param_read + character(str_long) :: message + ! Set Pinf to zero + Pinf=0.0_WP + ! Read in Gamma + call param_read('Gamma',Gamma) + ! Read in Prandtl number + call param_read('Prandtl number',Prandtl) + ! Read in shock Mach number and location + call param_read('Shock Mach number',Ms) + call param_read('Shock location',Xs) + ! First generate static shock with normalized pre-shock conditions + M1=Ms + rho1=1.0_WP + rho2=rho1*(Gamma+1.0_WP)*M1**2/((Gamma-1.0_WP)*M1**2+2.0_WP) + p1=0.25_WP*rho1/Gamma*((Gamma+1.0_WP)*M1/(M1**2-1.0_WP))**2 ! Ensures that |u2-u1|=1 + p2=p1*(2.0_WP*Gamma/(Gamma+1.0_WP)*(M1**2-1.0_WP)+1.0_WP) + u1=M1*sqrt(Gamma*p1/rho1) + u2=u1*rho1/rho2 + ! Now shift frame of reference to obtain moving shock + u2=abs(u2-u1); M2=u2/sqrt(Gamma*p2/rho2); u1=0.0_WP; M1=u1/sqrt(Gamma*p1/rho1) + ! Set heat capacities corresponding to a normalized pre-shock + Cv=(p1+Pinf)/(rho1*(Gamma-1.0_WP)) + ! Get reference temperature based on post-shock conditions + T0=get_T(rho2,p2) + ! Define viscosity based on post-shock Reynolds number + call param_read('Cylinder radius',Rcyl) + call param_read('Reynolds number',Re); visc0=rho2*2.0_WP*Rcyl*u2/Re + ! Output case info + if (cfg%amRoot) then + write(message,'("[Gas EOS] => Gamma=",es12.5)') Gamma; call log(message) + write(message,'("[Gas EOS] => Cv=",es12.5)') Cv; call log(message) + write(message,'("[Shock Mach number] => Ms=",es12.5)') Ms; call log(message) + write(message,'("[Pre -shock conditions] => rho1=",es12.5)') rho1; call log(message) + write(message,'("[Pre -shock conditions] => p1=",es12.5)') p1; call log(message) + write(message,'("[Pre -shock conditions] => u1=",es12.5)') u1; call log(message) + write(message,'("[Pre -shock conditions] => M1=",es12.5)') M1; call log(message) + write(message,'("[Post-shock conditions] => rho2=",es12.5)') rho2; call log(message) + write(message,'("[Post-shock conditions] => p2=",es12.5)') p2; call log(message) + write(message,'("[Post-shock conditions] => u2=",es12.5)') u2; call log(message) + write(message,'("[Post-shock conditions] => M2=",es12.5)') M2; call log(message) + write(message,'("[Gas Reynolds] => Re=",es12.5)') Re; call log(message) + write(message,'("[Gas viscosity] => mu=",es12.5)') visc0; call log(message) + end if + end block initialize_parameters + + + ! Initialize time tracker with 2 subiterations + initialize_timetracker: block + time=timetracker(amRoot=cfg%amRoot) + call param_read('Max timestep size',time%dtmax) + call param_read('Max cfl number',time%cflmax) + call param_read('Max time',time%tmax) + time%dt=time%dtmax + time%itmax=2 + end block initialize_timetracker + + + ! Initialize Lagrangian solid solver + initialize_lss: block + real(WP) :: dx,mu,kk,max_stretch,Lx,Ly,Lz + real(WP) :: xmin,xmax,ymin,ymax,zmin,zmax + integer :: np,nt + logical :: useSTL + type triangle_type + real(WP), dimension(3) :: norm + real(WP), dimension(3) :: v1 + real(WP), dimension(3) :: v2 + real(WP), dimension(3) :: v3 + end type triangle_type + type(triangle_type), dimension(:), allocatable :: t + + ! Create solver + ls=lss(cfg=cfg,name='solid') + + ! Set material properties + call param_read('Elastic Modulus',ls%elastic_modulus) + call param_read('Poisson Ratio',ls%poisson_ratio) + call param_read('Solid density',ls%rho) + call param_read('Critical Energy Release Rate',ls%crit_energy) + + ! Discretization + call param_read('Solid dx',dx) + ls%dV=dx**3 + ls%delta=3.0_WP*dx + + ! Output some info on stretch + mu=ls%elastic_modulus/(2.0_WP+2.0_WP*ls%poisson_ratio) + kk=ls%elastic_modulus/(3.0_WP-6.0_WP*ls%poisson_ratio) + max_stretch=sqrt(ls%crit_energy/((3.0_WP*mu+(kk-5.0_WP*mu/3.0_WP)*0.75_WP**4)*ls%delta)) + + ! Only root process initializes solid particles + if (ls%cfg%amRoot) then + ! Read the STL file and get domain extents and levelset + read_stl: block + use messager, only: die + use mathtools, only: normalize + integer :: i,iunit,ierr + real(WP), parameter :: scaling=1.0_WP + real(SP) :: rbuf + character(len=80) :: stlfile,cbuf + character(len= 2) :: padding + ! Open the file + useSTL=param_exists('STL file') + if (useSTL) then + call param_read('STL file',stlfile) + open(newunit=iunit,file=trim(stlfile),status="old",action="read",access="stream",iostat=ierr) + if (ierr.ne.0) call die('[read_stl] Could not open file: '//trim(stlfile)) + ! Read the header + read(iunit) cbuf + read(iunit) nt + ! Read the triangle data and scale to meters + allocate(t(nt)) + do i=1,nt + read(iunit) rbuf; t(i)%norm(1)=real(rbuf,WP) + read(iunit) rbuf; t(i)%norm(2)=real(rbuf,WP) + read(iunit) rbuf; t(i)%norm(3)=real(rbuf,WP) + read(iunit) rbuf; t(i)%v1(1)=real(rbuf,WP) + read(iunit) rbuf; t(i)%v1(2)=real(rbuf,WP) + read(iunit) rbuf; t(i)%v1(3)=real(rbuf,WP) + read(iunit) rbuf; t(i)%v2(1)=real(rbuf,WP) + read(iunit) rbuf; t(i)%v2(2)=real(rbuf,WP) + read(iunit) rbuf; t(i)%v2(3)=real(rbuf,WP) + read(iunit) rbuf; t(i)%v3(1)=real(rbuf,WP) + read(iunit) rbuf; t(i)%v3(2)=real(rbuf,WP) + read(iunit) rbuf; t(i)%v3(3)=real(rbuf,WP) + read(iunit) padding + end do + ! Close the file + close(iunit) + ! Scale + do i=1,nt + t(i)%v1=t(i)%v1*scaling + t(i)%v2=t(i)%v2*scaling + t(i)%v3=t(i)%v3*scaling + t(i)%norm=normalize(t(i)%norm*scaling) + end do + ! Get extents + xmin=minval(t(:)%v1(1)); xmin=min(xmin,minval(t(:)%v2(1))); xmin=min(xmin,minval(t(:)%v3(1))) + xmax=maxval(t(:)%v1(1)); xmax=max(xmin,maxval(t(:)%v2(1))); xmax=max(xmax,maxval(t(:)%v3(1))) + ymin=minval(t(:)%v1(2)); ymin=min(ymin,minval(t(:)%v2(2))); ymin=min(ymin,minval(t(:)%v3(2))) + ymax=maxval(t(:)%v1(2)); ymax=max(ymin,maxval(t(:)%v2(2))); ymax=max(ymax,maxval(t(:)%v3(2))) + zmin=minval(t(:)%v1(3)); zmin=min(zmin,minval(t(:)%v2(3))); zmin=min(zmin,minval(t(:)%v3(3))) + zmax=maxval(t(:)%v1(3)); zmax=max(zmin,maxval(t(:)%v2(3))); zmax=max(zmax,maxval(t(:)%v3(3))) + Lx=xmax-xmin; Ly=ymax-ymin; Lz=zmax-zmin + print *, Lx,Ly,Lz,2.0_WP*Rcyl + else + nt=0 + Lx=2.0_WP*Rcyl + Ly=2.0_WP*Rcyl + Lz=2.0_WP*Rcyl + end if + end block read_stl + + ! First object ===================== + object: block + integer :: p,i,j,k,nx,ny,nz,np_ + real(WP) :: x,y,z,A,B,C,S + real(WP), dimension(:,:), allocatable :: pos + ! Create simple rectilinear grid, remove particles outside Rcyl + nx=int(Lx/dx) + ny=int(Ly/dx) + nz=int(Lz/dx) + np=nx*ny*nz+nt + allocate(pos(3,np)) + np_=0 + do p=1,np + if (p.le.nt) then + np_=np_+1 + ! Give it a position on surface using STL info + pos(1,np_)=(t(np_)%V1(1)+t(np_)%V2(1)+t(np_)%V3(1))/3.0_WP + pos(2,np_)=(t(np_)%V1(2)+t(np_)%V2(2)+t(np_)%V3(2))/3.0_WP + pos(3,np_)=(t(np_)%V1(3)+t(np_)%V2(3)+t(np_)%V3(3))/3.0_WP + else + ! Give temporary position + i = (p-nt-1)/(ny*nz) + j = (p-nt-1-ny*nz*i)/nz + k = p-nt-1-ny*nz*i-nz*j + x = -Rcyl+(real(i,WP)+0.5_WP)*dx + y = -Rcyl+(real(j,WP)+0.5_WP)*dx + z = max(-Rcyl,ls%cfg%z(ls%cfg%kmin))+(real(k,WP)+0.5_WP)*dx + if (ls%cfg%nz.eq.1) z = 0.0_WP + if (sqrt(x**2+y**2+z**2).lt.Rcyl) then + np_=np_+1 + pos(1,np_) = x + pos(2,np_) = y + pos(3,np_) = z + end if + end if + end do + np=np_ + call ls%resize(np) + do p=1,np + ! Set position + ls%p(p)%pos=pos(:,p) + ! Set object id and velocity + ls%p(p)%id=-2 + ls%p(p)%vel=0.0_WP + ! Zero out force + ls%p(p)%Abond=0.0_WP + ! Zero out normal + ls%p(p)%normal=0.0_WP + ! Locate the particle on the mesh + ls%p(p)%ind=ls%cfg%get_ijk_global(ls%p(p)%pos,[ls%cfg%imin,ls%cfg%jmin,ls%cfg%kmin]) + ! Assign a unique integer to particle + ls%p(p)%i=p + ! Activate the particle + if (p.le.nt) then + ls%p(p)%flag=2 + else + ls%p(p)%flag=0 + end if + end do + deallocate(pos) + end block object + end if + + ! Communicate particles + call ls%sync() + + ! Update volume + ls%dV=4.0_WP/3.0_WP*(3.14159)*Rcyl**3/real(ls%np,WP) + + ! Get initial volume fraction + call ls%update_VF() + + ! Initalize bonds + call ls%bond_init() + + if (ls%cfg%amRoot) then + print*,"===== Solid Setup Description =====" + print*,'Number of particles', np + print*,'Maximum stretching =',max_stretch + end if + + end block initialize_lss + + + ! Create partmesh object for visualizing Lagrangian particles + create_pmesh: block + use lss_class, only: max_bond + integer :: i,n,nbond + pmesh=partmesh(nvar=3,nvec=3,name='solid') + pmesh%varname(1)='failfrac' + pmesh%varname(2)='dilatation' + pmesh%varname(3)='flag' + pmesh%vecname(1)='velocity' + pmesh%vecname(2)='bond_force' + pmesh%vecname(3)='normals' + call ls%update_partmesh(pmesh) + do i=1,ls%np_ + pmesh%var(1,i)=0.0_WP + nbond=0 + do n=1,max_bond + if (ls%p(i)%ibond(n).gt.0) nbond=nbond+1 + end do + if (ls%p(i)%nbond.gt.0) then + pmesh%var(1,i)=1.0_WP-real(nbond,WP)/real(ls%p(i)%nbond,WP) + else + pmesh%var(1,i)=0.0_WP + end if + pmesh%var(2,i) =ls%p(i)%dil + pmesh%var(3,i) =ls%p(i)%flag + pmesh%vec(:,1,i)=ls%p(i)%vel + pmesh%vec(:,2,i)=ls%p(i)%Abond + pmesh%vec(:,3,i)=ls%p(i)%normal + end do + end block create_pmesh + + + ! Initialize variables + initialize_variables: block + integer :: i,j,k + ! Provide thermodynamic model + fs%getP=>get_P; fs%getC=>get_C; fs%getS=>get_S; fs%getT=>get_T + ! Initialize primary variables to normal shock + do k=cfg%kmino_,cfg%kmaxo_ + do j=cfg%jmino_,cfg%jmaxo_ + do i=cfg%imino_,cfg%imaxo_ + fs%U(i,j,k) =u2*Hshock(Xs-fs%cfg%x(i),delta=0.5_WP*fs%dx) + fs%V(i,j,k) =0.0_WP + fs%W(i,j,k) =0.0_WP + fs%Q(i,j,k,1)=rho1+(rho2-rho1)*Hshock(Xs-fs%cfg%xm(i),delta=0.5_WP*fs%dx) + fs%P(i,j,k) =p1 +(p2 -p1 )*Hshock(Xs-fs%cfg%xm(i),delta=0.5_WP*fs%dx) + fs%I(i,j,k) =get_I(fs%Q(i,j,k,1),fs%P(i,j,k)) + end do + end do + end do + ! Initialize conserved variables + fs%Q(:,:,:,2)=fs%Q(:,:,:,1)*fs%I + call fs%get_momentum() + ! Rebuild primitive variables + call fs%get_primitive() + ! Interpolate velocity + call fs%interp_vel(Ui,Vi,Wi) + ! Compute local Mach number + Ma=sqrt(Ui**2+Vi**2+Wi**2)/fs%C + ! Compute dilatation + call get_div() + end block initialize_variables + + + ! Add Ensight output + create_ensight: block + ! Create Ensight output from cfg + ens_out=ensight(cfg=cfg,name='shock') + ! Create event for Ensight output + ens_evt=event(time=time,name='Ensight output') + call param_read('Ensight output period',ens_evt%tper) + ! Add variables to output + call ens_out%add_particle('particles',pmesh) + call ens_out%add_vector('velocity',Ui,Vi,Wi) + call ens_out%add_vector('norm',ls%norm(1,:,:,:),ls%norm(2,:,:,:),ls%norm(3,:,:,:)) + call ens_out%add_scalar('P',fs%P) + call ens_out%add_scalar('T',fs%T) + call ens_out%add_scalar('Mach',Ma) + call ens_out%add_scalar('beta',beta) + call ens_out%add_scalar('visc',visc) + call ens_out%add_scalar('visc_t',visc_t) + call ens_out%add_scalar('div',div) + call ens_out%add_scalar('VFs',ls%VF) + ! Output to ensight + if (ens_evt%occurs()) call ens_out%write_data(time%t) + end block create_ensight + + + ! Create monitor files + create_monitor: block + real(WP) :: cfl + ! Prepare some info about fields + call ls%get_cfl(time%dt,time%cfl) + call fs%get_cfl(time%dt,cfl); time%cfl=max(cfl,time%cfl) + call fs%get_info() + call ls%get_max() + ! Create simulation monitor + mfile=monitor(fs%cfg%amRoot,'simulation') + call mfile%add_column(time%n,'Timestep number') + call mfile%add_column(time%t,'Time') + call mfile%add_column(time%dt,'Timestep size') + call mfile%add_column(time%cfl,'Maximum CFL') + call mfile%add_column(fs%Umax,'Umax') + call mfile%add_column(fs%Vmax,'Vmax') + call mfile%add_column(fs%Wmax,'Wmax') + call mfile%add_column(fs%RHOmax,'max(RHO)') + call mfile%add_column(fs%RHOmin,'min(RHO)') + call mfile%add_column(fs%Pmax ,'max(P)' ) + call mfile%add_column(fs%Pmin ,'min(P)' ) + call mfile%add_column(fs%Tmax ,'max(T)' ) + call mfile%add_column(fs%Tmin ,'min(T)' ) + call mfile%write() + ! Create CFL monitor + cflfile=monitor(fs%cfg%amRoot,'cfl') + call cflfile%add_column(time%n,'Timestep number') + call cflfile%add_column(time%t,'Time') + call cflfile%add_column(fs%CFLc_x,'Convective xCFL') + call cflfile%add_column(fs%CFLc_y,'Convective yCFL') + call cflfile%add_column(fs%CFLc_z,'Convective zCFL') + call cflfile%add_column(fs%CFLa_x,'Acoustic xCFL') + call cflfile%add_column(fs%CFLa_y,'Acoustic yCFL') + call cflfile%add_column(fs%CFLa_z,'Acoustic zCFL') + call cflfile%add_column(fs%CFLv_x,'Viscous xCFL') + call cflfile%add_column(fs%CFLv_y,'Viscous yCFL') + call cflfile%add_column(fs%CFLv_z,'Viscous zCFL') + call cflfile%write() + ! Create conservation monitor + consfile=monitor(fs%cfg%amRoot,'conservation') + call consfile%add_column(time%n,'Timestep number') + call consfile%add_column(time%t,'Time') + call consfile%add_column(fs%Qint(1),'Mass') + call consfile%add_column(fs%Qint(2),'Energy') + call consfile%add_column(fs%Qint(3),'U Momentum') + call consfile%add_column(fs%Qint(4),'V Momentum') + call consfile%add_column(fs%Qint(5),'W Momentum') + call consfile%add_column(fs%RHOKint,'Kinetic Energy') + call consfile%add_column(fs%RHOSint,'Entropy') + call consfile%write() + ! Create solid monitor + sfile=monitor(ls%cfg%amRoot,'solid') + call sfile%add_column(time%n,'Timestep number') + call sfile%add_column(time%t,'Time') + call sfile%add_column(time%dt,'Timestep size') + call sfile%add_column(time%cfl,'Maximum CFL') + call sfile%add_column(ls%np,'Particle number') + call sfile%add_column(ls%VFmax,'VFmax') + call sfile%add_column(ls%Umin,'Particle Umin') + call sfile%add_column(ls%Umax,'Particle Umax') + call sfile%add_column(ls%Vmin,'Particle Vmin') + call sfile%add_column(ls%Vmax,'Particle Vmax') + call sfile%add_column(ls%Wmin,'Particle Wmin') + call sfile%add_column(ls%Wmax,'Particle Wmax') + call sfile%add_column(ls%ibmForce(1),'Particle Fx') + call sfile%add_column(ls%ibmForce(2),'Particle Fy') + call sfile%add_column(ls%ibmForce(3),'Particle Fz') + call sfile%write() + end block create_monitor + + end subroutine simulation_init + + + !> Perform an NGA2 simulation + subroutine simulation_run + implicit none + real(WP) :: cfl + + ! Perform time integration + do while (.not.time%done()) + + ! Increment time + call ls%get_cfl(time%dt,time%cfl) + call fs%get_cfl(time%dt,cfl); time%cfl=max(time%cfl,cfl) + call time%adjust_dt() + call time%increment() + + ! Remember conserved variables + fs%Qold=fs%Q + + ! Prepare SGS viscosity models + call prepare_viscosities() + + ! First RK step ==================================================================================== + ! Advance particles + call ls%substep_rk4(stage =1,& + & dt =time%dt,& + & gamma =Gamma,& + & Pinf =Pinf,& + & U =fs%U,& + & V =fs%V,& + & W =fs%W,& + & P =fs%P,& + & RHO =fs%Q(:,:,:,1),& + & srcRHO=srcQ(:,:,:,1),& + & srcI =srcQ(:,:,:,2),& + & srcU =srcQ(:,:,:,3),& + & srcV =srcQ(:,:,:,4),& + & srcW =srcQ(:,:,:,5)) + ! Get non-SL RHS and increment + call fs%rhs(dQdt(:,:,:,:,1)) + ! IBM source + dQdt(:,:,:,:,1)=dQdt(:,:,:,:,1)+srcQ + ! Advance + fs%Q=fs%Qold+0.5_WP*time%dt*dQdt(:,:,:,:,1) + ! Recompute primitive variables + call fs%get_primitive() + + ! Second RK step =================================================================================== + ! Advance particles + call ls%substep_rk4(stage =2,& + & dt =time%dt,& + & gamma =Gamma,& + & Pinf =Pinf,& + & U =fs%U,& + & V =fs%V,& + & W =fs%W,& + & P =fs%P,& + & RHO =fs%Q(:,:,:,1),& + & srcRHO=srcQ(:,:,:,1),& + & srcI =srcQ(:,:,:,2),& + & srcU =srcQ(:,:,:,3),& + & srcV =srcQ(:,:,:,4),& + & srcW =srcQ(:,:,:,5)) + ! Get non-SL RHS and increment + call fs%rhs(dQdt(:,:,:,:,2)) + ! IBM source + dQdt(:,:,:,:,2)=dQdt(:,:,:,:,2)+srcQ + ! Advance + fs%Q=fs%Qold+0.5_WP*time%dt*dQdt(:,:,:,:,2) + ! Recompute primitive variables + call fs%get_primitive() + + ! Third RK step ==================================================================================== + ! Advance particles + call ls%substep_rk4(stage =3,& + & dt =time%dt,& + & gamma =Gamma,& + & Pinf =Pinf,& + & U =fs%U,& + & V =fs%V,& + & W =fs%W,& + & P =fs%P,& + & RHO =fs%Q(:,:,:,1),& + & srcRHO=srcQ(:,:,:,1),& + & srcI =srcQ(:,:,:,2),& + & srcU =srcQ(:,:,:,3),& + & srcV =srcQ(:,:,:,4),& + & srcW =srcQ(:,:,:,5)) + ! Get non-SL RHS and increment + call fs%rhs(dQdt=dQdt(:,:,:,:,3)) + ! IBM source + dQdt(:,:,:,:,3)=dQdt(:,:,:,:,3)+srcQ + ! Advance + fs%Q=fs%Qold+1.0_WP*time%dt*dQdt(:,:,:,:,3) + ! Recompute primitive variables + call fs%get_primitive() + + ! Fourth RK step =================================================================================== + ! Advance particles + call ls%substep_rk4(stage =4,& + & dt =time%dt,& + & gamma =Gamma,& + & Pinf =Pinf,& + & U =fs%U,& + & V =fs%V,& + & W =fs%W,& + & P =fs%P,& + & RHO =fs%Q(:,:,:,1),& + & srcRHO=srcQ(:,:,:,1),& + & srcI =srcQ(:,:,:,2),& + & srcU =srcQ(:,:,:,3),& + & srcV =srcQ(:,:,:,4),& + & srcW =srcQ(:,:,:,5)) + ! Get non-SL RHS and increment + call fs%rhs(dQdt(:,:,:,:,4)) + ! IBM source + dQdt(:,:,:,:,4)=dQdt(:,:,:,:,4)+srcQ + ! Advance + fs%Q=fs%Qold+time%dt/6.0_WP*(dQdt(:,:,:,:,1)+2.0_WP*dQdt(:,:,:,:,2)+2.0_WP*dQdt(:,:,:,:,3)+dQdt(:,:,:,:,4)) + ! Recompute primitive variables + call fs%get_primitive() + + ! Apply boundary conditions + call apply_bconds() + + ! Interpolate velocity + call fs%interp_vel(Ui,Vi,Wi) + + ! Compute local Mach number + Ma=sqrt(Ui**2+Vi**2+Wi**2)/fs%C + + ! Compute dilatation + call get_div() + + !> Perform and output monitoring + call fs%get_info() + call ls%get_max() + call mfile%write() + call cflfile%write() + call consfile%write() + call sfile%write() + + ! Output to ensight + if (ens_evt%occurs()) then + update_pmesh: block + use lss_class, only: max_bond + integer :: i,n,nbond + call ls%update_partmesh(pmesh) + do i=1,ls%np_ + nbond=0 + do n=1,max_bond + if (ls%p(i)%ibond(n).gt.0) nbond=nbond+1 + end do + if (ls%p(i)%nbond.gt.0) then + pmesh%var(1,i)=1.0_WP-real(nbond,WP)/real(ls%p(i)%nbond,WP) + else + pmesh%var(1,i)=0.0_WP + end if + pmesh%var(2,i) =ls%p(i)%dil + pmesh%var(3,i) =ls%p(i)%flag + pmesh%vec(:,1,i)=ls%p(i)%vel + pmesh%vec(:,2,i)=ls%p(i)%Abond + !print*, ls%p(i)%normal + pmesh%vec(:,3,i)=ls%p(i)%normal + end do + end block update_pmesh + call ens_out%write_data(time%t) + end if + + end do + + end subroutine simulation_run + + + !> Finalize the NGA2 simulation + subroutine simulation_final + implicit none + + ! Get rid of all objects - need destructors + ! monitor + ! ensight + ! bcond + ! timetracker + + ! Deallocate work arrays + deallocate(dQdt,Ui,Vi,Wi,Ma,beta,visc,visc_t,div,srcQ) + + end subroutine simulation_final + + +end module simulation diff --git a/examples/sphere_peri/src/spcomp_class.f90 b/examples/sphere_peri/src/spcomp_class.f90 new file mode 100644 index 000000000..5c1538e5d --- /dev/null +++ b/examples/sphere_peri/src/spcomp_class.f90 @@ -0,0 +1,867 @@ +!> Single phase compressible flow solver class: +!> Provides support for RHS calculation only +module spcomp_class + use precision, only: WP + use string, only: str_medium + use config_class, only: config + use timer_class, only: timer + implicit none + private + + ! Expose type + public :: spcomp + + !> Single phase compressible solver object definition + type :: spcomp + + ! This is the config around which solver is built + class(config), pointer :: cfg + + ! Solver name + character(len=str_medium) :: name='UNNAMED_SPCOMP' + + ! Pointers to functions to evaluate P(RHO,E), T(RHO,P), and C(RHO,P) + procedure(Pfunc_type), pointer, nopass :: getP=>NULL() + procedure(Tfunc_type), pointer, nopass :: getT=>NULL() + procedure(Cfunc_type), pointer, nopass :: getC=>NULL() + procedure(Sfunc_type), pointer, nopass :: getS=>NULL() + + ! Conserved variables: 1=RHO, 2=RHO*I, 3=RHO*U, 4=RHO*V, 5=RHO*W + integer :: nQ + real(WP), dimension(:,:,:,:), allocatable :: Q,Qold + + ! Flow velocity + real(WP), dimension(:,:,:), allocatable :: U,V,W + + ! Internal energy + real(WP), dimension(:,:,:), allocatable :: I + + ! Pressure + real(WP), dimension(:,:,:), allocatable :: P + + ! Temperature + real(WP), dimension(:,:,:), allocatable :: T + + ! Speed of sound + real(WP), dimension(:,:,:), allocatable :: C + + ! Viscosities and heat diffusivity + real(WP), dimension(:,:,:), allocatable :: VISC,BETA,DIFF + + ! Gravitational acceleration + real(WP), dimension(3) :: gravity=0.0_WP + + ! Store mesh info + real(WP) :: dx,dy,dz,dxi,dyi,dzi,vol + + ! CFL numbers + real(WP) :: CFLc_x,CFLc_y,CFLc_z !< Convective CFL numbers + real(WP) :: CFLa_x,CFLa_y,CFLa_z !< Acoustic CFL numbers + real(WP) :: CFLv_x,CFLv_y,CFLv_z !< Viscous CFL numbers + + ! Monitoring quantities for conserved variables + real(WP), dimension(:), allocatable :: Qmin,Qmax,Qint + real(WP) :: RHOKint + real(WP) :: RHOSint + + ! Monitoring quantities for primitive variables + real(WP) :: Umax,Vmax,Wmax !< Velocity stats + real(WP) :: RHOmin,RHOmax !< Density stats + real(WP) :: Imin,Imax !< Internal energy stats + real(WP) :: Pmin,Pmax !< Pressure stats + real(WP) :: Tmin,Tmax !< Temperature stats + + ! Timer + type(timer) :: trhs !< Timer for RHS calculation + + contains + procedure :: print=>spcomp_print !< Output solver to the screen + procedure :: initialize !< Initialize the flow solver + procedure :: finalize !< Finalize the flow solver + procedure :: rhs !< Compute rhs of our equations using standard fluxes + procedure :: get_primitive !< Calculate primitive variables from conserved variables + procedure :: get_viscartif !< Calculate artifical bulk kinematic viscosity + procedure :: get_vreman !< Get kinematic eddy viscosity using Vreman's model + procedure :: get_velocity !< Calculate velocity from momentum + procedure :: get_ke !< Calculate kinetic energy per unit mass from velocity + procedure :: get_momentum !< Calculate momentum from velocity + procedure :: interp_vel !< Calculate interpolated velocity + procedure :: get_cfl !< Calculate maximum CFL + procedure :: get_info !< Calculate maximum field values + end type spcomp + + !> Interfaces for user-defined function + abstract interface + !> P=P(RHO,I) + pure real(WP) function Pfunc_type(RHO,I) + import :: WP + implicit none + real(WP), intent(in) :: RHO + real(WP), intent(in) :: I + end function Pfunc_type + !> T=T(RHO,P) + pure real(WP) function Tfunc_type(RHO,P) + import :: WP + implicit none + real(WP), intent(in) :: RHO + real(WP), intent(in) :: P + end function Tfunc_type + !> C=C(RHO,P) + pure real(WP) function Cfunc_type(RHO,P) + import :: WP + implicit none + real(WP), intent(in) :: RHO + real(WP), intent(in) :: P + end function Cfunc_type + !> S=S(RHO,P) + pure real(WP) function Sfunc_type(RHO,P) + import :: WP + implicit none + real(WP), intent(in) :: RHO + real(WP), intent(in) :: P + end function Sfunc_type + end interface + +contains + + + !> Initialization for compressible flow solver + subroutine initialize(this,cfg,name) + use messager, only: die + implicit none + class(spcomp) :: this + class(config), target, intent(in) :: cfg + character(len=*), optional :: name + + ! Set the name for the solver + if (present(name)) this%name=trim(adjustl(name)) + + ! Point to config object + this%cfg=>cfg + + ! Check that config is uniform with at least 2 cells of overlap + if (this%cfg%no.lt.2) call die('[spcomp initialize] spcomp solver requires at least 2 cells of overlap') + if (.not.all([this%cfg%uniform_x,this%cfg%uniform_y,this%cfg%uniform_z])) call die('[spcomp initialize] spcomp solver requires a uniform mesh') + + ! Store constant cell size and its inverse, handle 2D conditions, store cell volume + this%dx=this%cfg%dx(this%cfg%imin_); this%dxi=1.0_WP/this%dx; if (this%cfg%nx.eq.1) this%dxi=0.0_WP + this%dy=this%cfg%dy(this%cfg%jmin_); this%dyi=1.0_WP/this%dy; if (this%cfg%ny.eq.1) this%dyi=0.0_WP + this%dz=this%cfg%dz(this%cfg%kmin_); this%dzi=1.0_WP/this%dz; if (this%cfg%nz.eq.1) this%dzi=0.0_WP + this%vol=this%dx*this%dy*this%dz + + ! Allocate and zero out conserved variables + this%nQ=5 + allocate(this%Q (this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_,1:this%nQ)); this%Q =0.0_WP + allocate(this%Qold(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_,1:this%nQ)); this%Qold=0.0_WP + + ! Conserved variables monitoring + allocate(this%Qmin(1:this%nQ),this%Qmax(1:this%nQ),this%Qint(1:this%nQ)) + + ! Flow velocity + allocate(this%U(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)); this%U=0.0_WP + allocate(this%V(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)); this%V=0.0_WP + allocate(this%W(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)); this%W=0.0_WP + + ! Internal energy + allocate(this%I(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)); this%I=0.0_WP + + ! Pressure + allocate(this%P(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)); this%P=0.0_WP + + ! Temperature + allocate(this%T(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)); this%T=0.0_WP + + ! Speed of sound + allocate(this%C(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)); this%C=0.0_WP + + ! Viscosities and heat diffusivity + allocate(this%VISC(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)); this%VISC=0.0_WP + allocate(this%BETA(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)); this%BETA=0.0_WP + allocate(this%DIFF(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)); this%DIFF=0.0_WP + + ! Create timers + this%trhs=timer(comm=this%cfg%comm,name='RHS') + + end subroutine initialize + + + !> Obtain RHS for all equations + subroutine rhs(this,dQdt) + implicit none + class(spcomp), intent(inout) :: this + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:,1:), intent(out) :: dQdt !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_,1:nVAR) + real(WP), dimension(:,:,:,:), allocatable :: FQx,FQy,FQz + integer :: i,j,k,n + real(WP) :: w,div + real(WP), parameter :: eps=1.0e-15_WP + real(WP), dimension(-2: 0) :: wenop + real(WP), dimension(-1:+1) :: wenom + + ! Start rhs timer + call this%trhs%start() + + ! Zero out RHS + dQdt=0.0_WP + + ! ================================================================ ! + ! ======================== INVISID FLUXES ======================== ! + ! ================================================================ ! + + ! Allocate fluxes of conserved variables + allocate(FQx(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_,1:this%nQ)); FQx=0.0_WP + allocate(FQy(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_,1:this%nQ)); FQy=0.0_WP + allocate(FQz(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_,1:this%nQ)); FQz=0.0_WP + + ! Calculate standard fluxes + do k=this%cfg%kmin_,this%cfg%kmax_+1 + do j=this%cfg%jmin_,this%cfg%jmax_+1 + do i=this%cfg%imin_,this%cfg%imax_+1 + ! X fluxes + ! WENO mass flux + w=weno_weight((abs(this%Q(i-1,j,k,1)-this%Q(i-2,j,k,1))+eps)/(abs(this%Q(i,j,k,1)-this%Q(i-1,j,k,1))+eps)); wenop=0.5_WP*[ -w,1.0_WP+2.0_WP*w,1.0_WP-w] + w=weno_weight((abs(this%Q(i+1,j,k,1)-this%Q(i ,j,k,1))+eps)/(abs(this%Q(i,j,k,1)-this%Q(i-1,j,k,1))+eps)); wenom=0.5_WP*[1.0_WP-w,1.0_WP+2.0_WP*w, -w] + FQx(i,j,k,1)=-0.5_WP*(this%U(i,j,k)+abs(this%U(i,j,k)))*sum(wenop*this%Q(i-2:i ,j,k,1))& + & -0.5_WP*(this%U(i,j,k)-abs(this%U(i,j,k)))*sum(wenom*this%Q(i-1:i+1,j,k,1)) + ! Centered mass flux + !FQx(i,j,k,1)=-this%U(i,j,k)*0.5_WP*sum(this%Q(i-1:i,j,k,1)) + ! WENO internal energy flux + w=weno_weight((abs(this%I(i-1,j,k)-this%I(i-2,j,k))+eps)/(abs(this%I(i,j,k)-this%I(i-1,j,k))+eps)); wenop=0.5_WP*[ -w,1.0_WP+2.0_WP*w,1.0_WP-w] + w=weno_weight((abs(this%I(i+1,j,k)-this%I(i ,j,k))+eps)/(abs(this%I(i,j,k)-this%I(i-1,j,k))+eps)); wenom=0.5_WP*[1.0_WP-w,1.0_WP+2.0_WP*w, -w] + FQx(i,j,k,2)=0.5_WP*(FQx(i,j,k,1)-abs(-FQx(i,j,k,1)))*sum(wenop*this%I(i-2:i ,j,k))& + & +0.5_WP*(FQx(i,j,k,1)+abs(-FQx(i,j,k,1)))*sum(wenom*this%I(i-1:i+1,j,k)) + ! Centered internal energy flux + !FQx(i,j,k,2)=FQx(i,j,k,1)*0.5_WP*sum(this%I(i-1:i,j,k)) + ! Heat flux + FQx(i,j,k,2)=FQx(i,j,k,2)+0.5_WP*(this%DIFF(i-1,j,k)+this%DIFF(i,j,k))*this%dxi*(this%T(i,j,k)-this%T(i-1,j,k)) + ! Y fluxes + ! WENO mass flux + w=weno_weight((abs(this%Q(i,j-1,k,1)-this%Q(i,j-2,k,1))+eps)/(abs(this%Q(i,j,k,1)-this%Q(i,j-1,k,1))+eps)); wenop=0.5_WP*[ -w,1.0_WP+2.0_WP*w,1.0_WP-w] + w=weno_weight((abs(this%Q(i,j+1,k,1)-this%Q(i,j ,k,1))+eps)/(abs(this%Q(i,j,k,1)-this%Q(i,j-1,k,1))+eps)); wenom=0.5_WP*[1.0_WP-w,1.0_WP+2.0_WP*w, -w] + FQy(i,j,k,1)=-0.5_WP*(this%V(i,j,k)+abs(this%V(i,j,k)))*sum(wenop*this%Q(i,j-2:j ,k,1))& + & -0.5_WP*(this%V(i,j,k)-abs(this%V(i,j,k)))*sum(wenom*this%Q(i,j-1:j+1,k,1)) + ! Centered mass flux + !FQy(i,j,k,1)=-this%V(i,j,k)*0.5_WP*sum(this%Q(i,j-1:j,k,1)) + ! WENO internal energy flux + w=weno_weight((abs(this%I(i,j-1,k)-this%I(i,j-2,k))+eps)/(abs(this%I(i,j,k)-this%I(i,j-1,k))+eps)); wenop=0.5_WP*[ -w,1.0_WP+2.0_WP*w,1.0_WP-w] + w=weno_weight((abs(this%I(i,j+1,k)-this%I(i,j ,k))+eps)/(abs(this%I(i,j,k)-this%I(i,j-1,k))+eps)); wenom=0.5_WP*[1.0_WP-w,1.0_WP+2.0_WP*w, -w] + FQy(i,j,k,2)=0.5_WP*(FQy(i,j,k,1)-abs(-FQy(i,j,k,1)))*sum(wenop*this%I(i,j-2:j ,k))& + & +0.5_WP*(FQy(i,j,k,1)+abs(-FQy(i,j,k,1)))*sum(wenom*this%I(i,j-1:j+1,k)) + ! Centered internal energy flux + !FQy(i,j,k,2)=FQy(i,j,k,1)*0.5_WP*sum(this%I(i,j-1:j,k)) + ! Heat flux + FQy(i,j,k,2)=FQy(i,j,k,2)+0.5_WP*(this%DIFF(i,j-1,k)+this%DIFF(i,j,k))*this%dyi*(this%T(i,j,k)-this%T(i,j-1,k)) + ! Z fluxes + ! WENO mass flux + w=weno_weight((abs(this%Q(i,j,k-1,1)-this%Q(i,j,k-2,1))+eps)/(abs(this%Q(i,j,k,1)-this%Q(i,j,k-1,1))+eps)); wenop=0.5_WP*[ -w,1.0_WP+2.0_WP*w,1.0_WP-w] + w=weno_weight((abs(this%Q(i,j,k+1,1)-this%Q(i,j,k ,1))+eps)/(abs(this%Q(i,j,k,1)-this%Q(i,j,k-1,1))+eps)); wenom=0.5_WP*[1.0_WP-w,1.0_WP+2.0_WP*w, -w] + FQz(i,j,k,1)=-0.5_WP*(this%W(i,j,k)+abs(this%W(i,j,k)))*sum(wenop*this%Q(i,j,k-2:k ,1))& + & -0.5_WP*(this%W(i,j,k)-abs(this%W(i,j,k)))*sum(wenom*this%Q(i,j,k-1:k+1,1)) + ! Centered mass flux + !FQz(i,j,k,1)=-this%W(i,j,k)*0.5_WP*sum(this%Q(i,j,k-1:k,1)) + ! WENO internal energy flux + w=weno_weight((abs(this%I(i,j,k-1)-this%I(i,j,k-2))+eps)/(abs(this%I(i,j,k)-this%I(i,j,k-1))+eps)); wenop=0.5_WP*[ -w,1.0_WP+2.0_WP*w,1.0_WP-w] + w=weno_weight((abs(this%I(i,j,k+1)-this%I(i,j,k ))+eps)/(abs(this%I(i,j,k)-this%I(i,j,k-1))+eps)); wenom=0.5_WP*[1.0_WP-w,1.0_WP+2.0_WP*w, -w] + FQz(i,j,k,2)=0.5_WP*(FQz(i,j,k,1)-abs(-FQz(i,j,k,1)))*sum(wenop*this%I(i,j,k-2:k ))& + & +0.5_WP*(FQz(i,j,k,1)+abs(-FQz(i,j,k,1)))*sum(wenom*this%I(i,j,k-1:k+1)) + ! Centered internal energy flux + !FQz(i,j,k,2)=FQz(i,j,k,1)*0.5_WP*sum(this%I(i,j,k-1:k)) + ! Heat flux + FQz(i,j,k,2)=FQz(i,j,k,2)+0.5_WP*(this%DIFF(i,j,k-1)+this%DIFF(i,j,k))*this%dzi*(this%T(i,j,k)-this%T(i,j,k-1)) + end do + end do + end do + + ! Mass fluxes will be used to build momentum fluxes, they need to be extended by one cell on the left because of staggering + call this%cfg%sync(FQx(:,:,:,1)); if (.not.this%cfg%xper.and.this%cfg%iproc.eq.1) FQx(this%cfg%imin-1,:,:,1)=FQx(this%cfg%imin,:,:,1) + call this%cfg%sync(FQy(:,:,:,1)); if (.not.this%cfg%yper.and.this%cfg%jproc.eq.1) FQy(:,this%cfg%jmin-1,:,1)=FQy(:,this%cfg%jmin,:,1) + call this%cfg%sync(FQz(:,:,:,1)); if (.not.this%cfg%zper.and.this%cfg%kproc.eq.1) FQz(:,:,this%cfg%kmin-1,1)=FQz(:,:,this%cfg%kmin,1) + + ! Calculate cell-centered momentum fluxes with extra cell on the left due to staggering + do k=this%cfg%kmin_-1,this%cfg%kmax_ + do j=this%cfg%jmin_-1,this%cfg%jmax_ + do i=this%cfg%imin_-1,this%cfg%imax_ + FQx(i,j,k,3)=0.25_WP*sum(FQx(i:i+1,j,k,1))*sum(this%U(i:i+1,j,k))-this%P(i,j,k) + FQy(i,j,k,4)=0.25_WP*sum(FQy(i,j:j+1,k,1))*sum(this%V(i,j:j+1,k))-this%P(i,j,k) + FQz(i,j,k,5)=0.25_WP*sum(FQz(i,j,k:k+1,1))*sum(this%W(i,j,k:k+1))-this%P(i,j,k) + end do + end do + end do + + ! Calculate edge-centered momentum fluxes + do k=this%cfg%kmin_,this%cfg%kmax_+1 + do j=this%cfg%jmin_,this%cfg%jmax_+1 + do i=this%cfg%imin_,this%cfg%imax_+1 + FQy(i,j,k,3)=0.25_WP*sum(FQy(i-1:i,j,k,1))*sum(this%U(i,j-1:j,k)) + FQz(i,j,k,3)=0.25_WP*sum(FQz(i-1:i,j,k,1))*sum(this%U(i,j,k-1:k)) + FQx(i,j,k,4)=0.25_WP*sum(FQx(i,j-1:j,k,1))*sum(this%V(i-1:i,j,k)) + FQz(i,j,k,4)=0.25_WP*sum(FQz(i,j-1:j,k,1))*sum(this%V(i,j,k-1:k)) + FQx(i,j,k,5)=0.25_WP*sum(FQx(i,j,k-1:k,1))*sum(this%W(i-1:i,j,k)) + FQy(i,j,k,5)=0.25_WP*sum(FQy(i,j,k-1:k,1))*sum(this%W(i,j-1:j,k)) + end do + end do + end do + + ! Assemble time derivative for conserved variables + do k=this%cfg%kmin_,this%cfg%kmax_ + do j=this%cfg%jmin_,this%cfg%jmax_ + do i=this%cfg%imin_,this%cfg%imax_ + ! Mass and internal energy advection + dQdt(i,j,k,1)=this%dxi*(FQx(i+1,j,k,1)-FQx(i,j,k,1))+this%dyi*(FQy(i,j+1,k,1)-FQy(i,j,k,1))+this%dzi*(FQz(i,j,k+1,1)-FQz(i,j,k,1)) + dQdt(i,j,k,2)=this%dxi*(FQx(i+1,j,k,2)-FQx(i,j,k,2))+this%dyi*(FQy(i,j+1,k,2)-FQy(i,j,k,2))+this%dzi*(FQz(i,j,k+1,2)-FQz(i,j,k,2)) + ! Momentum advection and pressure stress + dQdt(i,j,k,3)=this%dxi*(FQx(i ,j,k,3)-FQx(i-1,j,k,3))+this%dyi*(FQy(i,j+1,k,3)-FQy(i,j ,k,3))+this%dzi*(FQz(i,j,k+1,3)-FQz(i,j,k ,3)) + dQdt(i,j,k,4)=this%dxi*(FQx(i+1,j,k,4)-FQx(i ,j,k,4))+this%dyi*(FQy(i,j ,k,4)-FQy(i,j-1,k,4))+this%dzi*(FQz(i,j,k+1,4)-FQz(i,j,k ,4)) + dQdt(i,j,k,5)=this%dxi*(FQx(i+1,j,k,5)-FQx(i ,j,k,5))+this%dyi*(FQy(i,j+1,k,5)-FQy(i,j ,k,5))+this%dzi*(FQz(i,j,k ,5)-FQz(i,j,k-1,5)) + ! Pressure dilatation term + dQdt(i,j,k,2)=dQdt(i,j,k,2)-this%P(i,j,k)*(this%dxi*(this%U(i+1,j,k)-this%U(i,j,k))+this%dyi*(this%V(i,j+1,k)-this%V(i,j,k))+this%dzi*(this%W(i,j,k+1)-this%W(i,j,k))) + end do + end do + end do + + ! ================================================================ ! + ! ======================== VISCOUS FLUXES ======================= ! + ! ================================================================ ! + + ! Zero out fluxes + FQx=0.0_WP; FQy=0.0_WP; FQz=0.0_WP + + ! Compute cell-centered momentum viscous fluxes + do k=this%cfg%kmin_-1,this%cfg%kmax_ + do j=this%cfg%jmin_-1,this%cfg%jmax_ + do i=this%cfg%imin_-1,this%cfg%imax_ + div=this%dxi*(this%U(i+1,j,k)-this%U(i,j,k))+this%dyi*(this%V(i,j+1,k)-this%V(i,j,k))+this%dzi*(this%W(i,j,k+1)-this%W(i,j,k)) + FQx(i,j,k,3)=2.0_WP*this%VISC(i,j,k)*this%dxi*(this%U(i+1,j,k)-this%U(i,j,k))+(this%BETA(i,j,k)-2.0_WP*this%VISC(i,j,k)/3.0_WP)*div + FQy(i,j,k,4)=2.0_WP*this%VISC(i,j,k)*this%dyi*(this%V(i,j+1,k)-this%V(i,j,k))+(this%BETA(i,j,k)-2.0_WP*this%VISC(i,j,k)/3.0_WP)*div + FQz(i,j,k,5)=2.0_WP*this%VISC(i,j,k)*this%dzi*(this%W(i,j,k+1)-this%W(i,j,k))+(this%BETA(i,j,k)-2.0_WP*this%VISC(i,j,k)/3.0_WP)*div + end do + end do + end do + + ! Compute edge-centered momentum viscous fluxes and corresponding viscous heating + do k=this%cfg%kmin_,this%cfg%kmax_+1 + do j=this%cfg%jmin_,this%cfg%jmax_+1 + do i=this%cfg%imin_,this%cfg%imax_+1 + FQy(i,j,k,3)=0.25_WP*sum(this%VISC(i-1:i,j-1:j,k))*(this%dyi*(this%U(i,j,k)-this%U(i,j-1,k))+this%dxi*(this%V(i,j,k)-this%V(i-1,j,k))); FQx(i,j,k,4)=FQy(i,j,k,3) + FQz(i,j,k,2)=FQy(i,j,k,3)*(this%dyi*(this%U(i,j,k)-this%U(i,j-1,k))+this%dxi*(this%V(i,j,k)-this%V(i-1,j,k))) + FQz(i,j,k,4)=0.25_WP*sum(this%VISC(i,j-1:j,k-1:k))*(this%dzi*(this%V(i,j,k)-this%V(i,j,k-1))+this%dyi*(this%W(i,j,k)-this%W(i,j-1,k))); FQy(i,j,k,5)=FQz(i,j,k,4) + FQx(i,j,k,2)=FQz(i,j,k,4)*(this%dzi*(this%V(i,j,k)-this%V(i,j,k-1))+this%dyi*(this%W(i,j,k)-this%W(i,j-1,k))) + FQx(i,j,k,5)=0.25_WP*sum(this%VISC(i-1:i,j,k-1:k))*(this%dxi*(this%W(i,j,k)-this%W(i-1,j,k))+this%dzi*(this%U(i,j,k)-this%U(i,j,k-1))); FQz(i,j,k,3)=FQx(i,j,k,5) + FQy(i,j,k,2)=FQx(i,j,k,5)*(this%dxi*(this%W(i,j,k)-this%W(i-1,j,k))+this%dzi*(this%U(i,j,k)-this%U(i,j,k-1))) + end do + end do + end do + + ! Assemble time derivative for conserved variables + do k=this%cfg%kmin_,this%cfg%kmax_ + do j=this%cfg%jmin_,this%cfg%jmax_ + do i=this%cfg%imin_,this%cfg%imax_ + ! Viscous momentum transport + dQdt(i,j,k,3)=dQdt(i,j,k,3)+this%dxi*(FQx(i ,j,k,3)-FQx(i-1,j,k,3))+this%dyi*(FQy(i,j+1,k,3)-FQy(i,j ,k,3))+this%dzi*(FQz(i,j,k+1,3)-FQz(i,j,k ,3)) + dQdt(i,j,k,4)=dQdt(i,j,k,4)+this%dxi*(FQx(i+1,j,k,4)-FQx(i ,j,k,4))+this%dyi*(FQy(i,j ,k,4)-FQy(i,j-1,k,4))+this%dzi*(FQz(i,j,k+1,4)-FQz(i,j,k ,4)) + dQdt(i,j,k,5)=dQdt(i,j,k,5)+this%dxi*(FQx(i+1,j,k,5)-FQx(i ,j,k,5))+this%dyi*(FQy(i,j+1,k,5)-FQy(i,j ,k,5))+this%dzi*(FQz(i,j,k ,5)-FQz(i,j,k-1,5)) + ! Viscous heating term + dQdt(i,j,k,2)=dQdt(i,j,k,2)+FQx(i,j,k,3)*this%dxi*(this%U(i+1,j,k)-this%U(i,j,k))+FQy(i,j,k,4)*this%dyi*(this%V(i,j+1,k)-this%V(i,j,k))+FQz(i,j,k,5)*this%dzi*(this%W(i,j,k+1)-this%W(i,j,k))+0.25_WP*sum(FQz(i:i+1,j:j+1,k,2))+0.25_WP*sum(FQx(i,j:j+1,k:k+1,2))+0.25_WP*sum(FQy(i:i+1,j,k:k+1,2)) + end do + end do + end do + + ! Deallocate flux arrays + deallocate(FQx,FQy,FQz) + + ! Synchronize all dQdt fields + do n=1,this%nQ; call this%cfg%sync(dQdt(:,:,:,n)); end do + + ! Stop rhs timer + call this%trhs%stop() + + contains + !> WENO switch function + real(WP) function weno_weight(ratio) + implicit none + real(WP), intent(in) :: ratio + real(WP), parameter :: lambda=0.13_WP ! Switching parameter + real(WP), parameter :: delta=0.01_WP ! Switching thickness + weno_weight=(1.0_WP-tanh((ratio-lambda)/delta))/3.0_WP+(1.0_WP-tanh((ratio-1.0_WP/lambda)/delta))/6.0_WP + end function weno_weight + end subroutine rhs + + + !> Calculate all primitive variables from updated conserved variables + subroutine get_primitive(this) + implicit none + class(spcomp), intent(inout) :: this + integer :: i,j,k + ! Get velocity + call this%get_velocity() + ! Get primitive variables + do k=this%cfg%kmino_,this%cfg%kmaxo_; do j=this%cfg%jmino_,this%cfg%jmaxo_; do i=this%cfg%imino_,this%cfg%imaxo_ + this%I(i,j,k)=this%Q(i,j,k,2)/this%Q(i,j,k,1) + this%P(i,j,k)=this%getP(this%Q(i,j,k,1),this%I(i,j,k)) + this%C(i,j,k)=this%getC(this%Q(i,j,k,1),this%P(i,j,k)) + end do; end do; end do + ! Get temperature + if (associated(this%getT)) then + do k=this%cfg%kmino_,this%cfg%kmaxo_; do j=this%cfg%jmino_,this%cfg%jmaxo_; do i=this%cfg%imino_,this%cfg%imaxo_ + this%T(i,j,k)=this%getT(this%Q(i,j,k,1),this%P(i,j,k)) + end do; end do; end do + end if + end subroutine get_primitive + + + !> Calculate velocity from momentum and density + subroutine get_velocity(this) + implicit none + class(spcomp), intent(inout) :: this + integer :: i,j,k + ! Calculate velocity as far as possible + do k=this%cfg%kmino_+1,this%cfg%kmaxo_ + do j=this%cfg%jmino_+1,this%cfg%jmaxo_ + do i=this%cfg%imino_+1,this%cfg%imaxo_ + this%U(i,j,k)=2.0_WP*this%Q(i,j,k,3)/sum(this%Q(i-1:i,j,k,1)) + this%V(i,j,k)=2.0_WP*this%Q(i,j,k,4)/sum(this%Q(i,j-1:j,k,1)) + this%W(i,j,k)=2.0_WP*this%Q(i,j,k,5)/sum(this%Q(i,j,k-1:k,1)) + end do + end do + end do + ! Sync velocity + call this%cfg%sync(this%U) + call this%cfg%sync(this%V) + call this%cfg%sync(this%W) + ! Add last layer in each direction + if (.not.this%cfg%xper.and.this%cfg%iproc.eq.1) then + this%U(this%cfg%imino,:,:)=this%Q(this%cfg%imino,:,:,3)/(this%Q(this%cfg%imino,:,:,1)) + this%V(this%cfg%imino,:,:)=this%Q(this%cfg%imino,:,:,4)/(this%Q(this%cfg%imino,:,:,1)) + this%W(this%cfg%imino,:,:)=this%Q(this%cfg%imino,:,:,5)/(this%Q(this%cfg%imino,:,:,1)) + end if + if (.not.this%cfg%yper.and.this%cfg%jproc.eq.1) then + this%U(:,this%cfg%jmino,:)=this%Q(:,this%cfg%jmino,:,3)/(this%Q(:,this%cfg%jmino,:,1)) + this%V(:,this%cfg%jmino,:)=this%Q(:,this%cfg%jmino,:,4)/(this%Q(:,this%cfg%jmino,:,1)) + this%W(:,this%cfg%jmino,:)=this%Q(:,this%cfg%jmino,:,5)/(this%Q(:,this%cfg%jmino,:,1)) + end if + if (.not.this%cfg%zper.and.this%cfg%kproc.eq.1) then + this%U(:,:,this%cfg%kmino)=this%Q(:,:,this%cfg%kmino,3)/(this%Q(:,:,this%cfg%kmino,1)) + this%V(:,:,this%cfg%kmino)=this%Q(:,:,this%cfg%kmino,4)/(this%Q(:,:,this%cfg%kmino,1)) + this%W(:,:,this%cfg%kmino)=this%Q(:,:,this%cfg%kmino,5)/(this%Q(:,:,this%cfg%kmino,1)) + end if + end subroutine get_velocity + + + !> Calculate kinetic energy per unit mass from pre-calculated velocity + !> Need to redo this better + subroutine get_ke(this,KE) + implicit none + class(spcomp), intent(inout) :: this + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(out) :: KE !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + integer :: i,j,k + do k=this%cfg%kmino_,this%cfg%kmaxo_-1 + do j=this%cfg%jmino_,this%cfg%jmaxo_-1 + do i=this%cfg%imino_,this%cfg%imaxo_-1 + KE(i,j,k)=0.5_WP*sum(this%U(i:i+1,j,k)**2+this%V(i,j:j+1,k)**2+this%W(i,j,k:k+1)**2) + end do + end do + end do + call this%cfg%sync(KE) + if (.not.this%cfg%xper.and.this%cfg%iproc.eq.this%cfg%npx) KE(this%cfg%imaxo,:,:)=KE(this%cfg%imaxo-1,:,:) + if (.not.this%cfg%yper.and.this%cfg%jproc.eq.this%cfg%npy) KE(:,this%cfg%jmaxo,:)=KE(:,this%cfg%jmaxo-1,:) + if (.not.this%cfg%zper.and.this%cfg%kproc.eq.this%cfg%npz) KE(:,:,this%cfg%kmaxo)=KE(:,:,this%cfg%kmaxo-1) + end subroutine get_ke + + + !> Calculate momentum from velocity and density + subroutine get_momentum(this) + implicit none + class(spcomp), intent(inout) :: this + integer :: i,j,k + ! Calculate momentum as far as possible + do k=this%cfg%kmino_+1,this%cfg%kmaxo_ + do j=this%cfg%jmino_+1,this%cfg%jmaxo_ + do i=this%cfg%imino_+1,this%cfg%imaxo_ + this%Q(i,j,k,3)=0.5_WP*sum(this%Q(i-1:i,j,k,1))*this%U(i,j,k) + this%Q(i,j,k,4)=0.5_WP*sum(this%Q(i,j-1:j,k,1))*this%V(i,j,k) + this%Q(i,j,k,5)=0.5_WP*sum(this%Q(i,j,k-1:k,1))*this%W(i,j,k) + end do + end do + end do + ! Sync momentum + call this%cfg%sync(this%Q(:,:,:,3)) + call this%cfg%sync(this%Q(:,:,:,4)) + call this%cfg%sync(this%Q(:,:,:,5)) + ! Add last layer in each direction + if (.not.this%cfg%xper.and.this%cfg%iproc.eq.1) then + this%Q(this%cfg%imino,:,:,3)=this%Q(this%cfg%imino,:,:,1)*this%U(this%cfg%imino,:,:) + this%Q(this%cfg%imino,:,:,4)=this%Q(this%cfg%imino,:,:,1)*this%V(this%cfg%imino,:,:) + this%Q(this%cfg%imino,:,:,5)=this%Q(this%cfg%imino,:,:,1)*this%W(this%cfg%imino,:,:) + end if + if (.not.this%cfg%yper.and.this%cfg%jproc.eq.1) then + this%Q(:,this%cfg%jmino,:,3)=this%Q(:,this%cfg%jmino,:,1)*this%U(:,this%cfg%jmino,:) + this%Q(:,this%cfg%jmino,:,4)=this%Q(:,this%cfg%jmino,:,1)*this%V(:,this%cfg%jmino,:) + this%Q(:,this%cfg%jmino,:,5)=this%Q(:,this%cfg%jmino,:,1)*this%W(:,this%cfg%jmino,:) + end if + if (.not.this%cfg%zper.and.this%cfg%kproc.eq.1) then + this%Q(:,:,this%cfg%kmino,3)=this%Q(:,:,this%cfg%kmino,1)*this%U(:,:,this%cfg%kmino) + this%Q(:,:,this%cfg%kmino,4)=this%Q(:,:,this%cfg%kmino,1)*this%V(:,:,this%cfg%kmino) + this%Q(:,:,this%cfg%kmino,5)=this%Q(:,:,this%cfg%kmino,1)*this%W(:,:,this%cfg%kmino) + end if + end subroutine get_momentum + + + !> Interpolate velocity to cell-center, including overlap and ghosts + subroutine interp_vel(this,Ui,Vi,Wi) + implicit none + class(spcomp), intent(inout) :: this + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(out) :: Ui !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(out) :: Vi !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(out) :: Wi !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) + integer :: i,j,k + ! Calculate interpolated velocity as far as possible + do k=this%cfg%kmino_,this%cfg%kmaxo_-1 + do j=this%cfg%jmino_,this%cfg%jmaxo_-1 + do i=this%cfg%imino_,this%cfg%imaxo_-1 + Ui(i,j,k)=0.5_WP*sum(this%U(i:i+1,j,k)) + Vi(i,j,k)=0.5_WP*sum(this%V(i,j:j+1,k)) + Wi(i,j,k)=0.5_WP*sum(this%W(i,j,k:k+1)) + end do + end do + end do + ! Sync interpolated velocity + call this%cfg%sync(Ui) + call this%cfg%sync(Vi) + call this%cfg%sync(Wi) + ! Add last layer in each direction + if (.not.this%cfg%xper.and.this%cfg%iproc.eq.this%cfg%npx) then + Ui(this%cfg%imaxo,:,:)=this%U(this%cfg%imaxo,:,:) + Vi(this%cfg%imaxo,:,:)=this%V(this%cfg%imaxo,:,:) + Wi(this%cfg%imaxo,:,:)=this%W(this%cfg%imaxo,:,:) + end if + if (.not.this%cfg%yper.and.this%cfg%jproc.eq.this%cfg%npy) then + Ui(:,this%cfg%jmaxo,:)=this%U(:,this%cfg%jmaxo,:) + Vi(:,this%cfg%jmaxo,:)=this%V(:,this%cfg%jmaxo,:) + Wi(:,this%cfg%jmaxo,:)=this%W(:,this%cfg%jmaxo,:) + end if + if (.not.this%cfg%zper.and.this%cfg%kproc.eq.this%cfg%npz) then + Ui(:,:,this%cfg%kmaxo)=this%U(:,:,this%cfg%kmaxo) + Vi(:,:,this%cfg%kmaxo)=this%V(:,:,this%cfg%kmaxo) + Wi(:,:,this%cfg%kmaxo)=this%W(:,:,this%cfg%kmaxo) + end if + end subroutine interp_vel + + + !> Get artifical bulk kinematic viscosity + subroutine get_viscartif(this,dt,beta) + implicit none + class(spcomp), intent(inout) :: this + real(WP), intent(in) :: dt + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(out) :: beta + integer :: i,j,k,si,sj,sk,n + integer, parameter :: nfilter=1 + real(WP) :: max_beta,dudy,dudz,dvdx,dvdz,dwdx,dwdy,vort,grad_div,H + real(WP), parameter :: max_cfl=0.5_WP + real(WP), parameter :: Cartif=2.0_WP + real(WP), parameter :: Cartif_vort=100.0_WP + real(WP), dimension(:,:,:), allocatable :: div + real(WP), dimension(-1:+1), parameter :: filter=[1.0_WP/6.0_WP,2.0_WP/3.0_WP,1.0_WP/6.0_WP] + ! Calculate max beta permissible + max_beta=max_cfl*min(this%dx**2,this%dy**2,this%dz**2)/(4.0_WP*dt) + ! Zero out array + beta=0.0_WP + ! Compute velocity divergence + allocate(div(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + do k=this%cfg%kmino_,this%cfg%kmaxo_-1; do j=this%cfg%jmino_,this%cfg%jmaxo_-1; do i=this%cfg%imino_,this%cfg%imaxo_-1 + div(i,j,k)=this%dxi*(this%U(i+1,j,k)-this%U(i,j,k))+this%dyi*(this%V(i,j+1,k)-this%V(i,j,k))+this%dzi*(this%W(i,j,k+1)-this%W(i,j,k)) + end do; end do; end do + call this%cfg%sync(div) + if (.not.this%cfg%xper.and.this%cfg%iproc.eq.this%cfg%npx) div(this%cfg%imaxo,:,:)=div(this%cfg%imaxo-1,:,:) + if (.not.this%cfg%yper.and.this%cfg%jproc.eq.this%cfg%npy) div(:,this%cfg%jmaxo,:)=div(:,this%cfg%jmaxo-1,:) + if (.not.this%cfg%zper.and.this%cfg%kproc.eq.this%cfg%npz) div(:,:,this%cfg%kmaxo)=div(:,:,this%cfg%kmaxo-1) + ! Compute artificial bulk viscosity based on gradU provided + do k=this%cfg%kmin_,this%cfg%kmax_; do j=this%cfg%jmin_,this%cfg%jmax_; do i=this%cfg%imin_,this%cfg%imax_ + ! Only work in compression regions + if (div(i,j,k).ge.0.0_WP) cycle + ! Compute local vorticity + dudy=0.25_WP*this%dyi*sum(this%U(i:i+1,j:j+1,k)-this%U(i:i+1,j-1:j,k)) + dudz=0.25_WP*this%dzi*sum(this%U(i:i+1,j,k:k+1)-this%U(i:i+1,j,k-1:k)) + dvdx=0.25_WP*this%dxi*sum(this%V(i:i+1,j:j+1,k)-this%V(i-1:i,j:j+1,k)) + dvdz=0.25_WP*this%dzi*sum(this%V(i,j:j+1,k:k+1)-this%V(i,j:j+1,k-1:k)) + dwdx=0.25_WP*this%dxi*sum(this%W(i:i+1,j,k:k+1)-this%W(i-1:i,j,k:k+1)) + dwdy=0.25_WP*this%dyi*sum(this%W(i,j:j+1,k:k+1)-this%W(i,j-1:j,k:k+1)) + vort=(dwdy-dvdz)**2+(dudz-dwdx)**2+(dvdx-dudy)**2 + ! Compute |grad(div)| + grad_div=max(abs(div(i+1,j,k)-div(i,j,k)),abs(div(i,j,k)-div(i-1,j,k)))*this%dx**2& + & +max(abs(div(i,j+1,k)-div(i,j,k)),abs(div(i,j,k)-div(i,j-1,k)))*this%dy**2& + & +max(abs(div(i,j,k+1)-div(i,j,k)),abs(div(i,j,k)-div(i,j,k-1)))*this%dz**2 + ! Estimate artificial kinematic viscosity using grad(div) + !beta(i,j,k)=Cartif*grad_div*div(i,j,k)**2/(div(i,j,k)**2+Cartif_vort*vort+1.0e-15_WP) + + ! Sensor originally proposed by Ducros et al. (1999) and later improved by + ! Hendrickson, T. R., Kartha, A., & Candler, G. V. (2018) + vort=max(vort,(0.05_WP*this%C(i,j,k)/min(this%dx,this%dy))**2) + beta(i,j,k)=Cartif*grad_div*min(4.0_WP/3.0_WP*div(i,j,k)**2/(div(i,j,k)**2+vort+epsilon(1.0_WP)),1.0_WP) + ! Clip it so CFL Get kinematic eddy viscosity using Vreman's model + subroutine get_vreman(this,dt,visc) + implicit none + class(spcomp), intent(inout) :: this + real(WP), intent(in) :: dt + real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(out) :: visc + real(WP), parameter :: Cs_ref=0.17_WP + real(WP), parameter :: max_cfl=0.5_WP + real(WP) :: max_visc,A,B,C + real(WP), dimension(1:3,1:3) :: beta,gradU + real(WP), dimension(:,:,:), allocatable :: tmp + real(WP), dimension(-1:+1), parameter :: filter=[1.0_WP/6.0_WP,2.0_WP/3.0_WP,1.0_WP/6.0_WP] + integer :: i,j,k,si,sj,sk,n + integer, parameter :: nfilter=1 + ! Model constant is c=2.5*Cs_ref**2 - Vreman uses c=0.07 which corresponds to Cs_ref=0.17 + C=2.5_WP*Cs_ref**2 + ! Calculate max visc permissible + max_visc=max_cfl*min(this%dx**2,this%dy**2,this%dz**2)/(4.0_WP*dt) + ! Zero out array + visc=0.0_WP + ! Compute the eddy viscosity + do k=this%cfg%kmin_,this%cfg%kmax_; do j=this%cfg%jmin_,this%cfg%jmax_; do i=this%cfg%imin_,this%cfg%imax_ + ! Compute velocity gradient tensor + gradU(1,1)=this%dxi*(this%U(i+1,j,k)-this%U(i,j,k)) + gradU(2,1)=0.25_WP*this%dyi*sum(this%U(i:i+1,j:j+1,k)-this%U(i:i+1,j-1:j,k)) + gradU(3,1)=0.25_WP*this%dzi*sum(this%U(i:i+1,j,k:k+1)-this%U(i:i+1,j,k-1:k)) + gradU(1,2)=0.25_WP*this%dxi*sum(this%V(i:i+1,j:j+1,k)-this%V(i-1:i,j:j+1,k)) + gradU(2,2)=this%dyi*(this%V(i,j+1,k)-this%V(i,j,k)) + gradU(3,2)=0.25_WP*this%dzi*sum(this%V(i,j:j+1,k:k+1)-this%V(i,j:j+1,k-1:k)) + gradU(1,3)=0.25_WP*this%dxi*sum(this%W(i:i+1,j,k:k+1)-this%W(i-1:i,j,k:k+1)) + gradU(2,3)=0.25_WP*this%dyi*sum(this%W(i,j:j+1,k:k+1)-this%W(i,j-1:j,k:k+1)) + gradU(3,3)=this%dzi*(this%W(i,j,k+1)-this%W(i,j,k)) + ! Compute A=gradu_ij*gradu_ij invariant + A=sum(gradU**2) + ! Compute beta_ij=dx_m*dx_m*gradu_mi*gradu_mj + do sj=1,3; do si=1,3; beta(si,sj)=this%dx**2*gradU(1,si)*gradU(1,sj)+this%dy**2*gradU(2,si)*gradU(2,sj)+this%dz**2*gradU(3,si)*gradU(3,sj); end do; end do + ! Compute B invariant + B=beta(1,1)*beta(2,2)-beta(1,2)**2+beta(1,1)*beta(3,3)-beta(1,3)**2+beta(2,2)*beta(3,3)-beta(2,3)**2 + ! Assemble algebraic eddy viscosity model + if (B.lt.1.0e-8_WP) then + visc(i,j,k)=0.0_WP + else + visc(i,j,k)=C*sqrt(B/A) + end if + ! Clip it so CFL Calculate the CFL + subroutine get_cfl(this,dt,cfl) + use mpi_f08, only: MPI_ALLREDUCE,MPI_MAX,MPI_IN_PLACE + use parallel, only: MPI_REAL_WP + implicit none + class(spcomp), intent(inout) :: this + real(WP), intent(in) :: dt + real(WP), intent(out) :: cfl + integer :: ierr + real(WP) :: maxvisc,maxC + ! Compute convective+acoustic CFLs + this%CFLc_x=maxval(abs(this%U)+abs(this%C))*dt*this%dxi; call MPI_ALLREDUCE(MPI_IN_PLACE,this%CFLc_x,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + this%CFLc_y=maxval(abs(this%V)+abs(this%C))*dt*this%dyi; call MPI_ALLREDUCE(MPI_IN_PLACE,this%CFLc_y,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + this%CFLc_z=maxval(abs(this%W)+abs(this%C))*dt*this%dzi; call MPI_ALLREDUCE(MPI_IN_PLACE,this%CFLc_z,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + ! Compute acoustic CFLs + maxC=maxval(this%C); call MPI_ALLREDUCE(MPI_IN_PLACE,maxC,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + this%CFLa_x=maxC*dt*this%dxi + this%CFLa_y=maxC*dt*this%dyi + this%CFLa_z=maxC*dt*this%dzi + ! Compute viscous CFLs + maxvisc=maxval((this%VISC+this%BETA)/this%Q(:,:,:,1)); call MPI_ALLREDUCE(MPI_IN_PLACE,maxvisc,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + this%CFLv_x=4.0_WP*maxvisc*dt*this%dxi**2 + this%CFLv_y=4.0_WP*maxvisc*dt*this%dyi**2 + this%CFLv_z=4.0_WP*maxvisc*dt*this%dzi**2 + ! Return the maximum overall CFL + cfl=max(this%CFLc_x,this%CFLc_y,this%CFLc_z,& + & this%CFLa_x,this%CFLa_y,this%CFLa_z,& + & this%CFLv_x,this%CFLv_y,this%CFLv_z) + end subroutine get_cfl + + + !> Calculate info about our fields + subroutine get_info(this) + use mpi_f08, only: MPI_ALLREDUCE,MPI_MIN,MPI_MAX,MPI_IN_PLACE + use parallel, only: MPI_REAL_WP + implicit none + class(spcomp), intent(inout) :: this + integer :: n,i,j,k,ierr + real(WP), dimension(:,:,:), allocatable :: tmp + + ! Compute integrals and extrema of conserved variables + do n=1,this%nQ + call this%cfg%integrate(this%Q(:,:,:,n),integral=this%Qint(n)) + end do + this%Qmin=+huge(1.0_WP) + this%Qmax=-huge(1.0_WP) + do k=this%cfg%kmin_,this%cfg%kmax_; do j=this%cfg%jmin_,this%cfg%jmax_; do i=this%cfg%imin_,this%cfg%imax_ + do n=1,this%nQ + this%Qmin(n)=min(this%Qmin(n),this%Q(i,j,k,n)) + this%Qmax(n)=max(this%Qmax(n),this%Q(i,j,k,n)) + end do + end do; end do; end do + call MPI_ALLREDUCE(MPI_IN_PLACE,this%Qmin,this%nQ,MPI_REAL_WP,MPI_MIN,this%cfg%comm,ierr) + call MPI_ALLREDUCE(MPI_IN_PLACE,this%Qmax,this%nQ,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + + ! Also compute integral of KE and entropy + allocate(tmp(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + call this%get_ke(tmp); tmp=this%Q(:,:,:,1)*tmp; call this%cfg%integrate(tmp,integral=this%RHOKint) + this%RHOSint=0.0_WP + if (associated(this%getS)) then + do k=this%cfg%kmin_,this%cfg%kmax_; do j=this%cfg%jmin_,this%cfg%jmax_; do i=this%cfg%imin_,this%cfg%imax_ + tmp(i,j,k)=this%Q(i,j,k,1)*this%getS(this%Q(i,j,k,1),this%P(i,j,k)) + end do; end do; end do + call this%cfg%integrate(tmp,integral=this%RHOSint) + end if + deallocate(tmp) + + ! Calculate extrema of primitive fields + this%RHOmin=+huge(1.0_WP); this%RHOmax=-huge(1.0_WP) + this%Imin =+huge(1.0_WP); this%Imax =-huge(1.0_WP) + this%Pmin =+huge(1.0_WP); this%Pmax =-huge(1.0_WP) + this%Tmin =+huge(1.0_WP); this%Tmax =-huge(1.0_WP) + this%Umax=0.0_WP; this%Vmax=0.0_WP; this%Wmax=0.0_WP + do k=this%cfg%kmin_,this%cfg%kmax_; do j=this%cfg%jmin_,this%cfg%jmax_; do i=this%cfg%imin_,this%cfg%imax_ + this%RHOmin=min(this%RHOmin,this%Q(i,j,k,1)); this%RHOmax=max(this%RHOmax,this%Q(i,j,k,1)) + this%Imin =min(this%Imin ,this%I (i,j,k)); this%Imax =max(this%Imax ,this%I (i,j,k)) + this%Pmin =min(this%Pmin ,this%P (i,j,k)); this%Pmax =max(this%Pmax ,this%P (i,j,k)) + this%Tmin =min(this%Tmin ,this%T (i,j,k)); this%Tmax =max(this%Tmax ,this%T (i,j,k)) + this%Umax=max(this%Umax,abs(this%U(i,j,k))) + this%Vmax=max(this%Vmax,abs(this%V(i,j,k))) + this%Wmax=max(this%Wmax,abs(this%W(i,j,k))) + end do; end do; end do + call MPI_ALLREDUCE(MPI_IN_PLACE,this%RHOmin,1,MPI_REAL_WP,MPI_MIN,this%cfg%comm,ierr) + call MPI_ALLREDUCE(MPI_IN_PLACE,this%RHOmax,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + call MPI_ALLREDUCE(MPI_IN_PLACE,this%Imin ,1,MPI_REAL_WP,MPI_MIN,this%cfg%comm,ierr) + call MPI_ALLREDUCE(MPI_IN_PLACE,this%Imax ,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + call MPI_ALLREDUCE(MPI_IN_PLACE,this%Pmin ,1,MPI_REAL_WP,MPI_MIN,this%cfg%comm,ierr) + call MPI_ALLREDUCE(MPI_IN_PLACE,this%Pmax ,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + call MPI_ALLREDUCE(MPI_IN_PLACE,this%Tmin ,1,MPI_REAL_WP,MPI_MIN,this%cfg%comm,ierr) + call MPI_ALLREDUCE(MPI_IN_PLACE,this%Tmax ,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + call MPI_ALLREDUCE(MPI_IN_PLACE,this%Umax ,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + call MPI_ALLREDUCE(MPI_IN_PLACE,this%Vmax ,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + call MPI_ALLREDUCE(MPI_IN_PLACE,this%Wmax ,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr) + + end subroutine get_info + + + !> Print out info for spcomp flow solver + subroutine spcomp_print(this) + use, intrinsic :: iso_fortran_env, only: output_unit + implicit none + class(spcomp), intent(in) :: this + if (this%cfg%amRoot) write(output_unit,'("spcomp solver [",a,"] for config [",a,"]")') trim(this%name),trim(this%cfg%name) + end subroutine spcomp_print + + + !> Finalize spcomp flow solver + subroutine finalize(this) + implicit none + class(spcomp), intent(inout) :: this + nullify(this%cfg) + this%name='UNNAMED_SPCOMP' + nullify(this%getP) + nullify(this%getT) + nullify(this%getC) + nullify(this%getS) + this%nQ=0 + if (allocated(this%Q)) deallocate(this%Q) + if (allocated(this%Qold)) deallocate(this%Qold) + if (allocated(this%U)) deallocate(this%U) + if (allocated(this%V)) deallocate(this%V) + if (allocated(this%W)) deallocate(this%W) + if (allocated(this%I)) deallocate(this%I) + if (allocated(this%P)) deallocate(this%P) + if (allocated(this%T)) deallocate(this%T) + if (allocated(this%C)) deallocate(this%C) + if (allocated(this%VISC)) deallocate(this%VISC) + if (allocated(this%BETA)) deallocate(this%BETA) + if (allocated(this%DIFF)) deallocate(this%DIFF) + if (allocated(this%Qmin)) deallocate(this%Qmin) + if (allocated(this%Qmax)) deallocate(this%Qmax) + if (allocated(this%Qint)) deallocate(this%Qint) + call this%trhs%finalize() + end subroutine finalize + + +end module spcomp_class diff --git a/src/amrpd/Make.package b/src/amrpd/Make.package new file mode 100644 index 000000000..a4a1ecd88 --- /dev/null +++ b/src/amrpd/Make.package @@ -0,0 +1,4 @@ +f90EXE_sources += pdhash_class.f90 pdhalo_class.f90 pdsolver_class.f90 + +INCLUDE_LOCATIONS += $(NGA_HOME)/src/amrpd +VPATH_LOCATIONS += $(NGA_HOME)/src/amrpd diff --git a/src/amrpd/amrpd_class.f90 b/src/amrpd/amrpd_class.f90 new file mode 100644 index 000000000..31adb0a5b --- /dev/null +++ b/src/amrpd/amrpd_class.f90 @@ -0,0 +1,1141 @@ +!> Grid-side extension of the PD solver: an amrpd IS a pdsolver (extends it) +!> plus an AMReX particle mirror of its nodes (the "face"), distributed by +!> position over the fluid grid's boxes so every grid-facing operation runs +!> where the cells live: volume-fraction and velocity deposits, field +!> interpolation at particle positions (F_fluid), VF-driven AMR tagging, +!> and plotfile visualization. +!> +!> Usage tiers (amrpd EXTENDS pdsolver: one object is the solid solver AND +!> its grid face -- assign material/damage/contact fields, then call handoff): +!> 1. pdsolver alone -- grid-free solid dynamics (no visualization) +!> 2. amrpd -- adds viz, solid VF on the mesh, AMR refinement, +!> seeding, and the face<->solver exchange +!> 3. ... + a flow solver -- two-way FSI (driver deposits IB forcing; the +!> fluid load returns via exchange_solid) +module amrpd_class + use precision, only: WP,I8 + use string, only: str_medium + use amrgrid_class, only: amrgrid + use amrdata_class, only: amrdata + use pdsolver_class, only: pdsolver,pd_partition,PD_WALL,PDC_IS_DEAD + use iso_c_binding + implicit none + private + + ! Public exports + public :: amrpd,part,part_gid + + ! Particle motion-control bit flags (composed by bit-OR into idata[0]) + ! Standard cases: + ! Free particle = PART_MOVES + PART_INTEGRATES + PART_BONDS (= 7) + ! Clamped fixed = PART_BONDS (= 4) + ! Velocity-prescribed = PART_MOVES + PART_BONDS (= 5) + ! Witness/probe = PART_MOVES (= 1) + ! Inactive (recycled) = PART_IS_DEAD (= 0) + integer(c_int), parameter, public :: PART_IS_DEAD = 0 !< Inactive; recycled out by AMReX + integer(c_int), parameter, public :: PART_MOVES = 1 !< pos += dt*vel during advance + integer(c_int), parameter, public :: PART_INTEGRATES = 2 !< vel += (dt/2)*acc during Verlet half-kick + integer(c_int), parameter, public :: PART_BONDS = 4 !< Eligible for bond-network participation + + ! Struct layout constants -- MUST match #defines in amrpd_wrapper.cpp + integer, parameter, public :: AMRPD_NREAL_PART = 15 + integer, parameter, public :: AMRPD_NINT_PART = 1 + integer, parameter, public :: AMRPD_NREAL_BOND = 4 + integer, parameter, public :: AMRPD_NINT_BOND = 5 + + !> Solid particle struct -- must match C++ Particle<15,1> memory layout: + !> pos[3], rdata[15], idcpu, idata[1]. Physics lives in pdsolver; only + !> pos/vel/F_fluid/damage are meaningful here (rest is legacy layout). + type, bind(C), public :: part + real(c_double) :: pos(3) !< AMReX-managed position + real(c_double) :: vel(3) !< rdata[0..2] + real(c_double) :: F_bond(3) !< rdata[3..5] (unused) + real(c_double) :: F_fluid(3) !< rdata[6..8] fluid load interpolated by the driver + real(c_double) :: mw !< rdata[9] (unused) + real(c_double) :: dil !< rdata[10] (unused) + real(c_double) :: damage !< rdata[11] broken-bond fraction in [0,1] + real(c_double) :: nb0 !< rdata[12] (unused) + real(c_double) :: td2 !< rdata[13] (unused) + real(c_double) :: td2a !< rdata[14] (unused) + integer(c_int64_t), private :: idcpu !< AMReX packed id+cpu + integer(c_int) :: flag !< idata[0]: PART_* flags at seeding; owner routing tag (7+8*owner) after handoff + end type part + + + + !> C interface bindings to amrpd_wrapper.cpp + interface + + ! Lifecycle + subroutine amrpd_new_pcp(pc,amrcore) bind(c) + import :: c_ptr + type(c_ptr) :: pc + type(c_ptr), value :: amrcore + end subroutine + subroutine amrpd_delete_pcp(pc) bind(c) + import :: c_ptr + type(c_ptr), value :: pc + end subroutine + + ! Redistribute + subroutine amrpd_redistribute_p(pc,lev_min,lev_max,ng) bind(c) + import :: c_ptr,c_int + type(c_ptr), value :: pc + integer(c_int), value :: lev_min,lev_max,ng + end subroutine + + + ! MFIter accessors -- particles + subroutine amrpd_get_particles_mfi(pc,lev,mfi,dp,np) bind(c) + import :: c_ptr,c_int,c_int64_t + type(c_ptr), value :: pc,mfi + integer(c_int), value :: lev + type(c_ptr) :: dp + integer(c_int64_t) :: np + end subroutine + + + ! Single-element insertion (initialization) + subroutine amrpd_add_particle_i(pc,lev,grid,tile,p) bind(c) + import :: c_ptr,c_int + type(c_ptr), value :: pc,p + integer(c_int), value :: lev,grid,tile + end subroutine + + ! Bulk append at level 0 (collective; ranks with n=0 pass raw=NULL) + subroutine amrpd_append_particles(pc,raw,n) bind(c) + import :: c_ptr,c_int64_t + type(c_ptr), value :: pc + type(c_ptr), value :: raw + integer(c_int64_t), value :: n + end subroutine + subroutine amrpd_append_particles_gid(pc,raw,n,gids) bind(c) + import :: c_ptr,c_int64_t + type(c_ptr), value :: pc + type(c_ptr), value :: raw + integer(c_int64_t), value :: n + type(c_ptr), value :: gids + end subroutine + + ! BoxArray / DistributionMap accessors + subroutine amrpd_get_particle_boxarray_p(pc,lev,ba) bind(c) + import :: c_ptr,c_int + type(c_ptr), value :: pc + integer(c_int), value :: lev + type(c_ptr) :: ba + end subroutine + subroutine amrpd_get_particle_distromap_p(pc,lev,dm) bind(c) + import :: c_ptr,c_int + type(c_ptr), value :: pc + integer(c_int), value :: lev + type(c_ptr) :: dm + end subroutine + subroutine amrpd_set_particle_boxarray_p(pc,lev,ba) bind(c) + import :: c_ptr,c_int + type(c_ptr), value :: pc + integer(c_int), value :: lev + type(c_ptr), value :: ba + end subroutine + subroutine amrpd_set_particle_distromap_p(pc,lev,dm) bind(c) + import :: c_ptr,c_int + type(c_ptr), value :: pc + integer(c_int), value :: lev + type(c_ptr), value :: dm + end subroutine + + ! ID/CPU counters and accessors + subroutine amrpd_get_next_id_p(id) bind(c) + import :: c_int64_t + integer(c_int64_t) :: id + end subroutine + subroutine amrpd_set_next_id_p(id) bind(c) + import :: c_int64_t + integer(c_int64_t), value :: id + end subroutine + subroutine amrpd_get_cpu(cpu) bind(c) + import :: c_int + integer(c_int) :: cpu + end subroutine + subroutine amrpd_get_particle_id(id,p) bind(c) + import :: c_int64_t,c_ptr + integer(c_int64_t) :: id + type(c_ptr), value :: p + end subroutine + subroutine amrpd_set_particle_id(id,p) bind(c) + import :: c_int64_t,c_ptr + integer(c_int64_t), value :: id + type(c_ptr), value :: p + end subroutine + subroutine amrpd_get_particle_cpu(cpu,p) bind(c) + import :: c_int,c_ptr + integer(c_int) :: cpu + type(c_ptr), value :: p + end subroutine + subroutine amrpd_set_particle_cpu(cpu,p) bind(c) + import :: c_int,c_ptr + integer(c_int), value :: cpu + type(c_ptr), value :: p + end subroutine + + + ! Global counts + subroutine amrpd_total_np(pc,np) bind(c) + import :: c_ptr,c_int64_t + type(c_ptr), value :: pc + integer(c_int64_t) :: np + end subroutine + + ! Checkpoint I/O: caller composes fullpath (e.g. /particles) + subroutine amrpd_checkpoint_p(pc,path) bind(c) + import :: c_ptr,c_char + type(c_ptr), value :: pc + character(kind=c_char) :: path(*) + end subroutine + subroutine amrpd_restart_p(pc,path) bind(c) + import :: c_ptr,c_char + type(c_ptr), value :: pc + character(kind=c_char) :: path(*) + end subroutine + + end interface + + + !> Grid-side extension of the PD solver: an amrpd IS a pdsolver, plus an + !> AMReX particle mirror of its nodes (the "face") distributed by position + !> over the fluid grid's boxes for deposits, interpolation, tagging, and viz + type, extends(pdsolver) :: amrpd + + !> Associated AMR grid + class(amrgrid), pointer :: amr => null() + + !> Opaque AMReX container handle + type(c_ptr) :: pcp = c_null_ptr !< Particle container + + !> Face load-balance metrics across ranks (grid decomposition; the + !> solver's own Morton partition is balanced by construction) + integer(I8) :: np_loc = 0 !< This rank's face particle count + integer(I8) :: np_min = 0 !< Min across ranks + integer(I8) :: np_max = 0 !< Max across ranks + real(WP) :: np_eff = 0.0_WP !< Load efficiency = mean/max + + !> Maximum AMR level particles are allowed on (cap passed to AMReX + !> Redistribute as lev_max). Particles span levels [0, maxlvl] and + !> AMReX places each at the finest level covering its position. + !> Defaults to amr%maxlvl in initialize. + integer :: maxlvl = 0 + + !> Overlap (ghost cell) width. Must be a multiple of the AMR refinement + !> ratio (2 in standard AMReX setups) because amrdata's process_deposit + !> uses sum_fine_to_coarse, which asserts nGrow % ratio == 0. Matches + !> amrlpt's default. + integer :: nover = 2 + + + !> Particle volume fraction on the Eulerian AMR mesh. Cell-centered scalar + !> (one component), one ghost layer. Updated each advance step by + !> update_VF: trilinear deposition of each particle's volume dV onto the + !> 8 surrounding cell centers, then average-down + optional smoothing. + !> Drives the AMR tagging callback when VF_tag > 0. + type(amrdata) :: VF + real(WP) :: VF_tag = -1.0_WP !< Refinement threshold (<=0 disables VF-driven tagging) + real(WP) :: filter_width = 0.0_WP !< Gaussian-equivalent filter width for VF; 0 disables + real(WP) :: VF_snap = 0.1_WP !< Deposit-moire amplitude: VF is rescaled by 1/(1-VF_snap) and clipped, + !< so a fully packed interior reads exactly 1. 0 disables. + real(WP) :: VFmin=0.0_WP,VFmax=0.0_WP,VFmean=0.0_WP !< VF statistics + + !> Optional user-supplied tagging callback. Called AFTER the built-in VF + !> tagging. Use to add custom refinement criteria (e.g., damage > 0.3). + procedure(pd_tagging_iface), pointer, pass :: user_pd_tagging => null() + + contains + ! Lifecycle + procedure :: initialize + procedure :: finalize + ! Container utilities + procedure :: redistribute + procedure :: get_info !< Global counts + min/max/mean velocities + load-balance metrics + procedure :: set_particle_ba_p + procedure :: set_particle_dm_p + ! Particle population + procedure :: append + procedure :: append_with_gids + ! Solver coupling (grid face <-> contained pdsolver) + procedure :: handoff + procedure :: exchange_solid + procedure :: rebuild_face + ! MFIter helpers (particle container's BA/DM) + procedure :: mfiter_build + procedure :: mfiter_destroy + procedure :: get_particles + ! AMR callbacks + procedure :: post_regrid + procedure :: tagging + ! Particle volume fraction + AMR tagging + procedure :: update_VF !< Compute VF from particle positions (trilinear deposit) + procedure :: process_deposit !< Post-process a deposited field (extensive -> intensive + C/F transfers; public: also used on driver-deposited fields) + procedure :: filter !< Explicit-diffusion smoothing of a cell-centered amrdata (public: also used on driver-deposited fields) + ! Physics -- STUBBED in skeleton + procedure :: interp !< Trilinear cell-centered interpolation (used by compute_contact for IB) + ! Checkpoint I/O + procedure :: write + procedure :: read + ! Diagnostics + procedure :: print + end type amrpd + + + !> Abstract interface for user-overridable tagging callback. Invoked AFTER + !> the built-in VF-based tagging by the registered AMReX tagging dispatch. + abstract interface + subroutine pd_tagging_iface(solver,lvl,time,tags) + import :: amrpd,c_ptr,WP + class(amrpd), intent(inout) :: solver + integer, intent(in) :: lvl + real(WP), intent(in) :: time + type(c_ptr), intent(in) :: tags + end subroutine pd_tagging_iface + end interface + + +contains + + + !> Public accessor for a particle's unique 64-bit GID key (its AMReX idcpu). + !> The idcpu component is private to protect the AMReX layout; the graph-core + !> handoff and parity tooling need the key for gid-matched state exchange. + function part_gid(p) result(gid) + implicit none + type(part), intent(in) :: p + integer(I8) :: gid + gid=p%idcpu + end function part_gid + + + ! ============================================================================ + ! DISPATCHERS (module-level) -- recover concrete amrpd type from c_ptr ctx + ! ============================================================================ + + !> Dispatch post_regrid: calls type-bound method + subroutine amrpd_postregrid_dispatch(ctx,lbase,time) + use iso_c_binding, only: c_ptr,c_f_pointer + implicit none + type(c_ptr), intent(in) :: ctx + integer, intent(in) :: lbase + real(WP), intent(in) :: time + type(amrpd), pointer :: this + call c_f_pointer(ctx,this) + call this%post_regrid(lbase,time) + end subroutine amrpd_postregrid_dispatch + + !> Dispatch tagging: calls type-bound method, then user override (if any) + subroutine amrpd_tagging_dispatch(ctx,lvl,time,tags) + use iso_c_binding, only: c_ptr,c_f_pointer + implicit none + type(c_ptr), intent(in) :: ctx + integer, intent(in) :: lvl + real(WP), intent(in) :: time + type(c_ptr), intent(in) :: tags + type(amrpd), pointer :: this + call c_f_pointer(ctx,this) + call this%tagging(lvl,time,tags) + if (associated(this%user_pd_tagging)) call this%user_pd_tagging(lvl,time,tags) + end subroutine amrpd_tagging_dispatch + + + ! ============================================================================ + ! LIFECYCLE + ! ============================================================================ + + !> Initialize amrpd solver: create particle container, register AMR callbacks + subroutine initialize(this,amr,name) + use amrex_amr_module, only: amrex_bc_foextrap + implicit none + class(amrpd), intent(inout) :: this + class(amrgrid), target, intent(in) :: amr + character(len=*), optional :: name + ! Set solver name + if (present(name)) this%name = trim(adjustl(name)) + ! Point to associated AMR grid + this%amr => amr + ! Default level cap: allow particles up to the AMR grid's max refinement + this%maxlvl = amr%maxlvl + ! Default deposit-smoothing width + this%filter_width = 2.0_WP*this%amr%min_meshsize(this%amr%maxlvl) + ! Create AMReX particle container + call amrpd_new_pcp(this%pcp,this%amr%amrcore) + ! Stamp the solver's domain geometry from the grid (material, damage, + ! and contact fields are driver-assigned) + this%Ldom=[amr%xhi-amr%xlo,amr%yhi-amr%ylo,amr%zhi-amr%zlo] + this%per=[amr%xper,amr%yper,amr%zper] + this%collapsed=[amr%nx.eq.1,amr%ny.eq.1,amr%nz.eq.1] + this%dom_lo=[amr%xlo,amr%ylo,amr%zlo] + this%dom_hi=[amr%xhi,amr%yhi,amr%zhi] + ! Particle volume fraction field (cell-centered, 1 ghost layer; foextrap + ! on non-periodic faces matches amrlpt's convention) + call this%VF%initialize(amr=amr,name='VF',ncomp=1,ng=this%nover); call this%VF%register() + if (.not.this%amr%xper) then; this%VF%lo_bc(1,1)=amrex_bc_foextrap; this%VF%hi_bc(1,1)=amrex_bc_foextrap; end if + if (.not.this%amr%yper) then; this%VF%lo_bc(2,1)=amrex_bc_foextrap; this%VF%hi_bc(2,1)=amrex_bc_foextrap; end if + if (.not.this%amr%zper) then; this%VF%lo_bc(3,1)=amrex_bc_foextrap; this%VF%hi_bc(3,1)=amrex_bc_foextrap; end if + ! Register AMR callbacks (post_regrid + tagging) so containers stay in sync + select type (this) + type is (amrpd) + call this%amr%add_postregrid(amrpd_postregrid_dispatch,c_loc(this)) + call this%amr%add_tagging (amrpd_tagging_dispatch, c_loc(this)) + end select + ! Print solver info + call this%print() + end subroutine initialize + + !> Finalize: destroy face and container, then the parent solver + subroutine finalize(this) + implicit none + class(amrpd), intent(inout) :: this + ! Drop user tagging hook + nullify(this%user_pd_tagging) + ! Tear down the volume-fraction field + call this%VF%finalize() + if (c_associated(this%pcp)) then + call amrpd_delete_pcp(this%pcp); this%pcp = c_null_ptr + end if + nullify(this%amr) + ! Tear down the solver state + call this%pdsolver%finalize() + end subroutine finalize + + + ! ============================================================================ + ! CONTAINER UTILITIES + ! ============================================================================ + + !> Redistribute the particle container across ranks (finest covering level + !> per position; lev_max=-1 avoids the lev_max>finestLevel() assert before + !> all levels exist). Matches amrlpt's default. + subroutine redistribute(this) + implicit none + class(amrpd), intent(inout) :: this + call amrpd_redistribute_p(this%pcp,0,-1,0) + end subroutine redistribute + + + + + + + + + + + + + !> Collective info: runs the solver's get_info (np, velocity extrema, bond + !> censuses, timers), then adds the FACE load-balance metrics -- particles + !> per rank across the grid decomposition (the solver's own partition is + !> balanced by construction; this measures the position-based mirror). + subroutine get_info(this) + implicit none + class(amrpd), intent(inout) :: this + integer(I8) :: np_sum + + ! Solver-side info + call this%pdsolver%get_info() + + ! Face census: live particles owned by this rank across all levels + local_pass: block + use amrex_amr_module, only: amrex_mfiter + type(amrex_mfiter) :: mfi + type(part), dimension(:), pointer :: p + integer(I8) :: np_,n + integer :: lvl + this%np_loc=0_I8 + do lvl=0,this%amr%clvl() + call this%mfiter_build(lvl,mfi) + do while (mfi%next()) + call this%get_particles(lvl,mfi,p,np_) + do n=1,np_ + if (p(n)%flag.eq.PART_IS_DEAD) cycle + this%np_loc=this%np_loc+1_I8 + end do + end do + call this%mfiter_destroy(mfi) + end do + end block local_pass + + ! Load-balance reductions + global_reduce: block + use mpi_f08, only: MPI_ALLREDUCE,MPI_SUM,MPI_MIN,MPI_MAX,MPI_IN_PLACE,MPI_INTEGER8 + integer :: ierr + this%np_min=this%np_loc; this%np_max=this%np_loc; np_sum=this%np_loc; this%np_eff=0.0_WP + call MPI_ALLREDUCE(MPI_IN_PLACE,this%np_min,1,MPI_INTEGER8,MPI_MIN,this%amr%comm,ierr) + call MPI_ALLREDUCE(MPI_IN_PLACE,this%np_max,1,MPI_INTEGER8,MPI_MAX,this%amr%comm,ierr) + call MPI_ALLREDUCE(MPI_IN_PLACE,np_sum, 1,MPI_INTEGER8,MPI_SUM,this%amr%comm,ierr) + if (this%np_max.gt.0_I8) this%np_eff=real(np_sum,WP)/real(this%np_max,WP)/real(this%amr%nproc,WP) + end block global_reduce + + end subroutine get_info + + + !> Set particle-container BoxArray for a given level + subroutine set_particle_ba_p(this,lvl,ba) + use amrex_amr_module, only: amrex_boxarray + implicit none + class(amrpd), intent(inout) :: this + integer, intent(in) :: lvl + type(amrex_boxarray), intent(in) :: ba + call amrpd_set_particle_boxarray_p(this%pcp,lvl,ba%p) + end subroutine set_particle_ba_p + + !> Set particle-container DistributionMapping for a given level + subroutine set_particle_dm_p(this,lvl,dm) + use amrex_amr_module, only: amrex_distromap + implicit none + class(amrpd), intent(inout) :: this + integer, intent(in) :: lvl + type(amrex_distromap), intent(in) :: dm + call amrpd_set_particle_distromap_p(this%pcp,lvl,dm%p) + end subroutine set_particle_dm_p + + + + !> Build an MFIter over the particle container's BA/DM at level lvl. + subroutine mfiter_build(this,lvl,mfi,tiling) + use amrex_amr_module, only: amrex_boxarray,amrex_distromap,amrex_mfiter,amrex_mfiter_build + implicit none + class(amrpd), intent(inout) :: this + integer, intent(in) :: lvl + type(amrex_mfiter), intent(out) :: mfi + logical, intent(in), optional :: tiling + type(amrex_boxarray) :: ba + type(amrex_distromap) :: dm + logical :: use_tiling + use_tiling=.false.; if (present(tiling)) use_tiling=tiling + call amrpd_get_particle_boxarray_p (this%pcp,lvl,ba%p) + call amrpd_get_particle_distromap_p(this%pcp,lvl,dm%p) + call amrex_mfiter_build(mfi,ba,dm,tiling=use_tiling) + end subroutine mfiter_build + + !> Destroy an MFIter built via mfiter_build. + subroutine mfiter_destroy(this,mfi) + use amrex_amr_module, only: amrex_mfiter,amrex_mfiter_destroy + implicit none + class(amrpd), intent(inout) :: this + type(amrex_mfiter), intent(inout) :: mfi + call amrex_mfiter_destroy(mfi) + end subroutine mfiter_destroy + + !> Return a Fortran pointer to the valid particle array on the current tile + !> (ghost particles excluded). np is the number of valid particles. + subroutine get_particles(this,lvl,mfi,p,np) + use amrex_amr_module, only: amrex_mfiter + implicit none + class(amrpd), intent(inout) :: this + integer, intent(in) :: lvl + type(amrex_mfiter), intent(in) :: mfi + type(part), dimension(:), pointer, intent(out) :: p + integer(I8), intent(out) :: np + type(c_ptr) :: dp + integer(c_int64_t) :: np_c + call amrpd_get_particles_mfi(this%pcp,lvl,mfi%p,dp,np_c) + np=int(np_c,I8) + if (np.gt.0_I8) then + call c_f_pointer(dp,p,[np]) + else + nullify(p) + end if + end subroutine get_particles + + + + + !> Bulk-append Fortran particle array into the container at level 0. + !> Collective: every rank must call; ranks with nothing to add pass n=0. + !> AMReX assigns unique (id,cpu) to each appended particle and + !> AddParticlesAtLevel internally redistributes by position. + subroutine append(this,plist,n) + use messager, only: die + implicit none + class(amrpd), intent(inout) :: this + type(part), dimension(:), allocatable, target, intent(in) :: plist + integer(I8), intent(in) :: n + type(c_ptr) :: raw + raw=c_null_ptr + if (n.gt.0_I8.and.allocated(plist)) then + if (int(size(plist),I8).lt.n) call die('[amrpd append] plist array smaller than n') + raw=c_loc(plist(1)) + end if + call amrpd_append_particles(this%pcp,raw,int(n,c_int64_t)) + end subroutine append + + !> Bulk-append with PRESERVED identities: each particle takes the (id,cpu) + !> packed in gids (the part_gid key). Used to rebuild the grid-side face + !> from a pdsolver checkpoint so identities match the solver's node gids. + !> Collective; AddParticlesAtLevel redistributes by position. + subroutine append_with_gids(this,plist,n,gids) + use messager, only: die + implicit none + class(amrpd), intent(inout) :: this + type(part), dimension(:), allocatable, target, intent(in) :: plist + integer(I8), intent(in) :: n + integer(I8), dimension(:), target, intent(in) :: gids + type(c_ptr) :: raw,graw + raw=c_null_ptr; graw=c_null_ptr + if (n.gt.0_I8.and.allocated(plist)) then + if (int(size(plist),I8).lt.n) call die('[amrpd append_with_gids] plist smaller than n') + raw=c_loc(plist(1)); graw=c_loc(gids(1)) + end if + call amrpd_append_particles_gid(this%pcp,raw,int(n,c_int64_t),graw) + end subroutine append_with_gids + + + ! ============================================================================ + ! SOLVER COUPLING (grid face <-> contained pdsolver) + ! ============================================================================ + + !> Hand the seeded face population to the solver: extract nodes, Morton- + !> partition them (balanced, motion-invariant), detect families, and stamp + !> each face particle's flag with its solver owner rank (flag = 7+8*owner). + !> The driver must have assigned the material/damage/contact fields first. + subroutine handoff(this) + use amrex_amr_module, only: amrex_mfiter + implicit none + class(amrpd), intent(inout) :: this + type(amrex_mfiter) :: mfi + type(part), dimension(:), pointer :: p + integer(I8), allocatable :: gids(:),rgid(:) + real(WP), allocatable :: pos(:,:),vel(:,:),voll(:),rpos(:,:),rvel(:,:),rvol(:) + integer, allocatable :: flags(:),owner(:),rflag(:) + integer(I8) :: np_,n + integer :: lvl,nn,i,nr + ! Extract this rank's owned particles + nn=0 + do lvl=0,this%amr%clvl() + call this%mfiter_build(lvl,mfi) + do while (mfi%next()) + call this%get_particles(lvl,mfi,p,np_) + nn=nn+int(np_) + end do + call this%mfiter_destroy(mfi) + end do + allocate(gids(max(nn,1)),pos(3,max(nn,1)),vel(3,max(nn,1)),flags(max(nn,1)),voll(max(nn,1)),owner(max(nn,1))) + i=0 + do lvl=0,this%amr%clvl() + call this%mfiter_build(lvl,mfi) + do while (mfi%next()) + call this%get_particles(lvl,mfi,p,np_) + do n=1_I8,np_ + i=i+1 + gids(i) =part_gid(p(n)) + pos(:,i)=p(n)%pos + vel(:,i)=p(n)%vel + flags(i)=p(n)%flag + voll(i) =this%dV + end do + end do + call this%mfiter_destroy(mfi) + end do + ! Balanced static partition of the reference configuration + call pd_partition(nn,gids,pos,vel,flags,voll,owner,nr,rgid,rpos,rvel,rflag,rvol) + call this%set_nodes(nr,rgid,rpos,rvel,rflag,rvol) + call this%detect_families() + ! Stamp owner routing tags on the grid face (same walk order as the + ! extraction above, so owner(i) lines up) + i=0 + do lvl=0,this%amr%clvl() + call this%mfiter_build(lvl,mfi) + do while (mfi%next()) + call this%get_particles(lvl,mfi,p,np_) + do n=1_I8,np_ + i=i+1 + p(n)%flag=7+8*owner(i) + end do + end do + call this%mfiter_destroy(mfi) + end do + deallocate(gids,pos,vel,flags,voll,owner,rgid,rpos,rvel,rflag,rvol) + end subroutine handoff + + !> Face <-> solver exchange (collective; call once per coupling step): push + !> each face particle's interpolated F_fluid to its solver owner; pull back + !> the owner's current (pos, vel, damage, alive). Dead solver nodes (exited + !> an open face) get an outside-domain position written back, so the next + !> redistribute drops the tombstone. + subroutine exchange_solid(this) + use amrex_amr_module, only: amrex_mfiter + implicit none + class(amrpd), intent(inout) :: this + type(amrex_mfiter) :: mfi + type(part), dimension(:), pointer :: p + integer(I8), allocatable :: mgid(:) + integer, allocatable :: mown(:) + real(WP), allocatable :: mff(:,:),mpos(:,:),mvel(:,:),mdmg(:),malive(:) + integer(I8) :: np_,n + integer :: lvl,nm,i + ! Count live face particles + nm=0 + do lvl=0,this%amr%clvl() + call this%mfiter_build(lvl,mfi) + do while (mfi%next()) + call this%get_particles(lvl,mfi,p,np_) + do n=1_I8,np_ + if (p(n)%flag.eq.PART_IS_DEAD) cycle + nm=nm+1 + end do + end do + call this%mfiter_destroy(mfi) + end do + allocate(mgid(max(nm,1)),mown(max(nm,1)),mff(3,max(nm,1))) + allocate(mpos(3,max(nm,1)),mvel(3,max(nm,1)),mdmg(max(nm,1)),malive(max(nm,1))) + ! Pack (gid, owner tag, F_fluid) + i=0 + do lvl=0,this%amr%clvl() + call this%mfiter_build(lvl,mfi) + do while (mfi%next()) + call this%get_particles(lvl,mfi,p,np_) + do n=1_I8,np_ + if (p(n)%flag.eq.PART_IS_DEAD) cycle + i=i+1 + mgid(i)=part_gid(p(n)) + mown(i)=p(n)%flag/8 + mff(:,i)=p(n)%F_fluid + end do + end do + call this%mfiter_destroy(mfi) + end do + ! Collective round-trip with the solver + call this%exchange(nm,mgid,mown,mff,mpos,mvel,mdmg,malive) + ! Write the solver state back onto the grid face (same walk order) + i=0 + do lvl=0,this%amr%clvl() + call this%mfiter_build(lvl,mfi) + do while (mfi%next()) + call this%get_particles(lvl,mfi,p,np_) + do n=1_I8,np_ + if (p(n)%flag.eq.PART_IS_DEAD) cycle + i=i+1 + p(n)%pos=mpos(:,i) + p(n)%vel=mvel(:,i) + p(n)%damage=mdmg(i) + if (malive(i).lt.0.5_WP) p(n)%flag=PART_IS_DEAD + end do + end do + call this%mfiter_destroy(mfi) + end do + deallocate(mgid,mown,mff,mpos,mvel,mdmg,malive) + end subroutine exchange_solid + + !> Rebuild the grid face from the (restored) solver state: one particle per + !> owned live node with PRESERVED identity (gid -> id,cpu), current + !> position/velocity/damage, and the owner routing tag = this rank. + subroutine rebuild_face(this) + use parallel, only: rank + implicit none + class(amrpd), intent(inout) :: this + type(part), dimension(:), allocatable, target :: plist + integer(I8), dimension(:), allocatable, target :: gl + integer(I8) :: n + integer :: i,m + allocate(plist(max(this%nown,1)),gl(max(this%nown,1))) + m=0 + do i=1,this%nown + if (this%flag(i).eq.PDC_IS_DEAD) cycle ! exited nodes stay dead + m=m+1 + plist(m)%pos =this%y(:,i) + plist(m)%vel =this%v(:,i) + plist(m)%F_bond =0.0_WP + plist(m)%F_fluid=0.0_WP + plist(m)%mw =0.0_WP + plist(m)%dil =0.0_WP + plist(m)%damage =this%damage(i) + plist(m)%nb0 =0.0_WP + plist(m)%td2 =0.0_WP + plist(m)%td2a =0.0_WP + plist(m)%flag =7+8*rank + gl(m)=this%gid(i) + end do + n=int(m,I8) + call this%append_with_gids(plist,n,gl) + call this%redistribute() + deallocate(plist,gl) + end subroutine rebuild_face + + + ! ============================================================================ + ! AMR CALLBACKS + ! ============================================================================ + + !> Post-regrid: re-sync particle and bond containers' BA/DM, redistribute. + !> Particles span levels + !> [0, maxlvl] and the BA/DM sync walks all current levels so the containers + !> track AMR. + subroutine post_regrid(this,lbase,time) + implicit none + class(amrpd), intent(inout) :: this + integer, intent(in) :: lbase + real(WP), intent(in) :: time + integer :: lvl + + ! Re-sync both containers to the fluid grid's BA/DM. This sets the + ! AmrParGDB's per-level particle BA/DM caches. Keeping these in sync + ! and matches the pattern used in amrlpt. + sync_to_amrgrid: block + do lvl=0,this%amr%clvl() + call this%set_particle_ba_p(lvl,this%amr%get_boxarray(lvl)) + call this%set_particle_dm_p(lvl,this%amr%get_distromap(lvl)) + end do + end block sync_to_amrgrid + + ! First settle particles onto the freshly-synced BA/DM before we can + ! count them per box for the knapsack weighting below + call this%redistribute() + + ! Recompute particle VF on the (new) mesh. AMReX fills new fine cells via + ! amrdata's coarse-to-fine interpolation during regrid, but that's a + ! guess; a fresh deposit from the redistributed particles is the truth. + ! Matches amrlpt%post_regrid. + call this%update_VF() + end subroutine post_regrid + + !> Tag cells for refinement where particle VF exceeds VF_tag. Disabled if + !> VF_tag <= 0. Mirrors amrlpt%tagging. + subroutine tagging(this,lvl,time,tags) + use amrex_amr_module, only: amrex_tagboxarray,amrex_box,amrex_mfiter,amrex_mfiter_build,amrex_mfiter_destroy + use amrgrid_class, only: SETtag + implicit none + class(amrpd), intent(inout) :: this + integer, intent(in) :: lvl + real(WP), intent(in) :: time + type(c_ptr), intent(in) :: tags + type(amrex_tagboxarray) :: tba + type(amrex_mfiter) :: mfi + type(amrex_box) :: bx + character(kind=c_char), dimension(:,:,:,:), contiguous, pointer :: tagarr + real(WP), dimension(:,:,:,:), contiguous, pointer :: pVF + integer :: i,j,k + ! Skip if VF tagging is disabled + if (this%VF_tag.le.0.0_WP) return + ! Resolve tagboxarray pointer + tba=tags + ! Loop over tiles and tag + call amrex_mfiter_build(mfi,this%VF%mf(lvl)) + do while (mfi%next()) + tagarr=>tba%dataPtr(mfi) + pVF=>this%VF%mf(lvl)%dataptr(mfi) + bx=mfi%tilebox() + do k=bx%lo(3),bx%hi(3); do j=bx%lo(2),bx%hi(2); do i=bx%lo(1),bx%hi(1) + if (pVF(i,j,k,1).gt.this%VF_tag) tagarr(i,j,k,1)=SETtag + end do; end do; end do + end do + call amrex_mfiter_destroy(mfi) + end subroutine tagging + + !> Compute particle volume fraction on the Eulerian AMR mesh: trilinear + !> deposit of each particle's volume dV onto the 8 surrounding cell centers, + !> then convert extensive->intensive (divide by cell_vol), propagate across + !> C/F boundaries, average down, fill ghosts, and optionally smooth. + subroutine update_VF(this) + use amrex_amr_module, only: amrex_mfiter,amrex_multifab,amrex_multifab_build,amrex_multifab_destroy + use amrex_distromap_module, only: operator(.eq.) + implicit none + class(amrpd), intent(inout) :: this + type(amrex_mfiter) :: mfi + type(part), dimension(:), pointer :: p + real(WP), dimension(:,:,:,:), contiguous, pointer :: pVF + integer(I8) :: np_,i + integer :: lvl,ii,jj,kk + real(WP) :: dxi,dyi,dzi,wx,wy,wz,Vp + type(amrex_multifab) :: tmpVF + logical :: dual_dm + + ! Zero VF on all levels + call this%VF%setval(0.0_WP) + Vp=this%dV + + do lvl=0,this%amr%clvl() + dxi=1.0_WP/this%amr%dx(lvl) + dyi=1.0_WP/this%amr%dy(lvl) + dzi=1.0_WP/this%amr%dz(lvl) + + ! Particles may live on a different DM than VF -- deposit on the + ! particle DM into a scratch mfab, then parallel_copy to VF + dual_dm=(.not.(this%VF%mf(lvl)%dm.eq.get_pdm())) + if (dual_dm) then + call amrex_multifab_build(mf=tmpVF,ba=this%amr%ba(lvl),dm=get_pdm(),nc=this%VF%mf(lvl)%ncomp(),ng=this%VF%mf(lvl)%nghost(),nodal=this%VF%nodal) + call tmpVF%setval(0.0_WP) + end if + + call this%mfiter_build(lvl,mfi) + do while (mfi%next()) + if (dual_dm) then + pVF=>tmpVF%dataptr(mfi) + else + pVF=>this%VF%mf(lvl)%dataptr(mfi) + end if + call this%get_particles(lvl,mfi,p,np_) + do i=1_I8,np_ + if (p(i)%flag.eq.PART_IS_DEAD) cycle + ii=floor((p(i)%pos(1)-this%amr%xlo)*dxi-0.5_WP); wx=(p(i)%pos(1)-this%amr%xlo)*dxi-0.5_WP-real(ii,WP) + jj=floor((p(i)%pos(2)-this%amr%ylo)*dyi-0.5_WP); wy=(p(i)%pos(2)-this%amr%ylo)*dyi-0.5_WP-real(jj,WP) + kk=floor((p(i)%pos(3)-this%amr%zlo)*dzi-0.5_WP); wz=(p(i)%pos(3)-this%amr%zlo)*dzi-0.5_WP-real(kk,WP) + ! Clamp 8-cell stencil at WALL faces (mirrors amrlpt) + if (this%lo_bc(1).eq.PD_WALL.and.ii .lt.this%amr%geom(lvl)%domain%lo(1)) then; ii=this%amr%geom(lvl)%domain%lo(1) ; wx=0.0_WP; end if + if (this%hi_bc(1).eq.PD_WALL.and.ii+1.gt.this%amr%geom(lvl)%domain%hi(1)) then; ii=this%amr%geom(lvl)%domain%hi(1)-1; wx=1.0_WP; end if + if (this%lo_bc(2).eq.PD_WALL.and.jj .lt.this%amr%geom(lvl)%domain%lo(2)) then; jj=this%amr%geom(lvl)%domain%lo(2) ; wy=0.0_WP; end if + if (this%hi_bc(2).eq.PD_WALL.and.jj+1.gt.this%amr%geom(lvl)%domain%hi(2)) then; jj=this%amr%geom(lvl)%domain%hi(2)-1; wy=1.0_WP; end if + if (this%lo_bc(3).eq.PD_WALL.and.kk .lt.this%amr%geom(lvl)%domain%lo(3)) then; kk=this%amr%geom(lvl)%domain%lo(3) ; wz=0.0_WP; end if + if (this%hi_bc(3).eq.PD_WALL.and.kk+1.gt.this%amr%geom(lvl)%domain%hi(3)) then; kk=this%amr%geom(lvl)%domain%hi(3)-1; wz=1.0_WP; end if + pVF(ii:ii+1,jj:jj+1,kk:kk+1,1)=pVF(ii:ii+1,jj:jj+1,kk:kk+1,1)+Vp*reshape([(1.0_WP-wx)*(1.0_WP-wy)*(1.0_WP-wz),wx*(1.0_WP-wy)*(1.0_WP-wz),(1.0_WP-wx)*wy*(1.0_WP-wz),wx*wy*(1.0_WP-wz),(1.0_WP-wx)*(1.0_WP-wy)*wz,wx*(1.0_WP-wy)*wz,(1.0_WP-wx)*wy*wz,wx*wy*wz],[2,2,2]) + end do + end do + call this%mfiter_destroy(mfi) + + if (dual_dm) then + call this%VF%mf(lvl)%parallel_copy(tmpVF,1,1,this%VF%mf(lvl)%ncomp(),this%VF%mf(lvl)%nghost(),this%VF%mf(lvl)%nghost(),this%amr%geom(lvl)) + call amrex_multifab_destroy(tmpVF) + end if + end do + + ! Convert extensive -> intensive (VF) and reconcile across C/F + call this%process_deposit(this%VF) + ! Fill ghost cells via amrdata's standard machinery + call this%VF%fill(time=0.0_WP) + ! Optional smoothing (zero filter_width disables) + call this%filter(this%VF) + ! Snap out the deposit moire: the particle lattice is incommensurate with the + ! grid (and moves), so a fully packed interior deposits VF slightly below 1. + ! Rescale+clip so it reads exactly 1; continuous, so no jump is introduced. + if (this%VF_snap.gt.0.0_WP) then + do lvl=0,this%amr%clvl() + call this%VF%mf(lvl)%mult(1.0_WP/(1.0_WP-this%VF_snap),1,1,this%VF%ng) + end do + call this%VF%clip(0.0_WP,1.0_WP) + call this%VF%fill(time=0.0_WP) + end if + + contains + + !> Helper: get the particle distribution map for this level. Returns the + !> DM that the particle container is currently using (which may differ + !> from the Eulerian DM). + function get_pdm() result(dm) + use amrex_distromap_module, only: amrex_distromap + type(amrex_distromap) :: dm + call amrpd_get_particle_distromap_p(this%pcp,lvl,dm%p) + dm%owner=.false. + end function get_pdm + end subroutine update_VF + + !> Post-process an extensive deposit (sum of particle volumes per cell) into + !> an intensive field (VF = sum/cell_vol), with cross-level transfers to + !> avoid double-counting on covered cells. Verbatim port of amrlpt's + !> process_deposit. + subroutine process_deposit(this,A) + use amrex_amr_module, only: amrex_multifab,amrex_multifab_destroy + use amrex_interface, only: amrmfab_sum_downto,amrmfab_interp_from_coarse + implicit none + class(amrpd), intent(inout) :: this + type(amrdata), intent(inout) :: A + type(amrex_multifab), dimension(:), allocatable :: tmp + integer :: lvl + ! Convert extensive deposits to intensive + do lvl=0,this%amr%clvl() + call A%mf(lvl)%mult(1.0_WP/this%amr%cell_vol(lvl),1,A%ncomp,A%ng) + end do + ! Scratch mfabs for coarse->fine interpolation + allocate(tmp(0:this%amr%clvl())) + do lvl=0,this%amr%clvl() + call this%amr%mfab_build(lvl,tmp(lvl),ncomp=A%ncomp,nover=0); call tmp(lvl)%setval(0.0_WP) + end do + ! Forward pass (coarse to fine) + do lvl=0,this%amr%clvl() + call A%syncsum_lvl(lvl) + if (lvl.lt.this%amr%clvl()) then + call amrmfab_interp_from_coarse(tmp(lvl+1),A%mf(lvl),[this%amr%rrefx(lvl),this%amr%rrefy(lvl),this%amr%rrefz(lvl)],cgeom=this%amr%geom(lvl),fgeom=this%amr%geom(lvl+1),scomp=1,ncomp=A%ncomp) + end if + if (lvl.gt.0) then + call amrmfab_sum_downto(A%mf(lvl),A%mf(lvl-1),[this%amr%rrefx(lvl-1),this%amr%rrefy(lvl-1),this%amr%rrefz(lvl-1)],cgeom=this%amr%geom(lvl-1),fgeom=this%amr%geom(lvl)) + end if + call A%mf(lvl)%add(tmp(lvl),1,1,A%ncomp,0) + end do + ! Backward pass: average down to fix double-counted covered cells + do lvl=this%amr%clvl()-1,0,-1 + call A%average_downto(lvl) + end do + do lvl=0,this%amr%clvl() + call amrex_multifab_destroy(tmp(lvl)) + end do + deallocate(tmp) + end subroutine process_deposit + + !> Explicit-diffusion (Gaussian-equivalent) smoothing of a cell-centered + !> amrdata field. Skips if filter_width<=mesh-size. Verbatim port of amrlpt. + subroutine filter(this,A) + use amrex_amr_module, only: amrex_box,amrex_mfiter,amrex_mfiter_build,amrex_mfiter_destroy,amrex_multifab,amrex_multifab_destroy + use amrex_interface, only: amrmfab_average_down_face + implicit none + class(amrpd), intent(inout) :: this + type(amrdata), intent(inout) :: A + real(WP) :: alpha,alpha_step,dxi,dyi,dzi + integer :: nstep,n,nc,lvl,i,j,k + type(amrex_mfiter) :: mfi + type(amrex_box) :: bx + type(amrex_multifab), dimension(:), allocatable :: Fx,Fy,Fz + real(WP), dimension(:,:,:,:), contiguous, pointer :: pA,pFx,pFy,pFz + + alpha=max(this%filter_width**2-this%amr%min_meshsize(this%amr%clvl())**2,0.0_WP)/(16.0_WP*log(2.0_WP)) + if (alpha.le.0.0_WP) return + + nstep=ceiling(6.0_WP*alpha/this%amr%min_meshsize(this%amr%clvl())**2) + alpha_step=alpha/real(nstep,WP) + + allocate(Fx(0:this%amr%maxlvl),Fy(0:this%amr%maxlvl),Fz(0:this%amr%maxlvl)) + do lvl=0,this%amr%clvl() + call this%amr%mfab_build(lvl,Fx(lvl),ncomp=A%ncomp,nover=0,atface=[.true., .false.,.false.]); call Fx(lvl)%setval(0.0_WP) + call this%amr%mfab_build(lvl,Fy(lvl),ncomp=A%ncomp,nover=0,atface=[.false.,.true., .false.]); call Fy(lvl)%setval(0.0_WP) + call this%amr%mfab_build(lvl,Fz(lvl),ncomp=A%ncomp,nover=0,atface=[.false.,.false.,.true. ]); call Fz(lvl)%setval(0.0_WP) + end do + + do n=1,nstep + do lvl=0,this%amr%clvl() + dxi=1.0_WP/this%amr%dx(lvl) + dyi=1.0_WP/this%amr%dy(lvl) + dzi=1.0_WP/this%amr%dz(lvl) + call amrex_mfiter_build(mfi,A%mf(lvl),tiling=.false.) + do while (mfi%next()) + pA =>A%mf(lvl)%dataptr(mfi) + pFx=>Fx(lvl)%dataptr(mfi); pFy=>Fy(lvl)%dataptr(mfi); pFz=>Fz(lvl)%dataptr(mfi) + bx=mfi%nodaltilebox(1) + do nc=1,A%ncomp; do k=bx%lo(3),bx%hi(3); do j=bx%lo(2),bx%hi(2); do i=bx%lo(1),bx%hi(1) + pFx(i,j,k,nc)=alpha_step*(pA(i,j,k,nc)-pA(i-1,j,k,nc))*dxi + end do; end do; end do; end do + bx=mfi%nodaltilebox(2) + do nc=1,A%ncomp; do k=bx%lo(3),bx%hi(3); do j=bx%lo(2),bx%hi(2); do i=bx%lo(1),bx%hi(1) + pFy(i,j,k,nc)=alpha_step*(pA(i,j,k,nc)-pA(i,j-1,k,nc))*dyi + end do; end do; end do; end do + bx=mfi%nodaltilebox(3) + do nc=1,A%ncomp; do k=bx%lo(3),bx%hi(3); do j=bx%lo(2),bx%hi(2); do i=bx%lo(1),bx%hi(1) + pFz(i,j,k,nc)=alpha_step*(pA(i,j,k,nc)-pA(i,j,k-1,nc))*dzi + end do; end do; end do; end do + end do + call amrex_mfiter_destroy(mfi) + end do + do lvl=this%amr%clvl(),1,-1 + call amrmfab_average_down_face(fmf=Fx(lvl),cmf=Fx(lvl-1),rr=[this%amr%rrefx(lvl-1),this%amr%rrefy(lvl-1),this%amr%rrefz(lvl-1)],cgeom=this%amr%geom(lvl-1)) + call amrmfab_average_down_face(fmf=Fy(lvl),cmf=Fy(lvl-1),rr=[this%amr%rrefx(lvl-1),this%amr%rrefy(lvl-1),this%amr%rrefz(lvl-1)],cgeom=this%amr%geom(lvl-1)) + call amrmfab_average_down_face(fmf=Fz(lvl),cmf=Fz(lvl-1),rr=[this%amr%rrefx(lvl-1),this%amr%rrefy(lvl-1),this%amr%rrefz(lvl-1)],cgeom=this%amr%geom(lvl-1)) + end do + do lvl=0,this%amr%clvl() + dxi=1.0_WP/this%amr%dx(lvl) + dyi=1.0_WP/this%amr%dy(lvl) + dzi=1.0_WP/this%amr%dz(lvl) + call amrex_mfiter_build(mfi,A%mf(lvl),tiling=.false.) + do while (mfi%next()) + pA =>A%mf(lvl)%dataptr(mfi) + pFx=>Fx(lvl)%dataptr(mfi); pFy=>Fy(lvl)%dataptr(mfi); pFz=>Fz(lvl)%dataptr(mfi) + bx=mfi%tilebox() + do nc=1,A%ncomp; do k=bx%lo(3),bx%hi(3); do j=bx%lo(2),bx%hi(2); do i=bx%lo(1),bx%hi(1) + pA(i,j,k,nc)=pA(i,j,k,nc)+dxi*(pFx(i+1,j,k,nc)-pFx(i,j,k,nc))+dyi*(pFy(i,j+1,k,nc)-pFy(i,j,k,nc))+dzi*(pFz(i,j,k+1,nc)-pFz(i,j,k,nc)) + end do; end do; end do; end do + end do + call amrex_mfiter_destroy(mfi) + end do + call A%average_down() + call A%fill(time=0.0_WP) + end do + + do lvl=0,this%amr%clvl() + call amrex_multifab_destroy(Fx(lvl)) + call amrex_multifab_destroy(Fy(lvl)) + call amrex_multifab_destroy(Fz(lvl)) + end do + deallocate(Fx,Fy,Fz) + end subroutine filter + + + ! ============================================================================ + ! FIELD INTERPOLATION + ! ============================================================================ + + + + !> Trilinear cell-centered interpolation of a multifab data array at a 3D + !> position (drivers use it to sample fields at particle positions). + function interp(this,lvl,pos,arr,comp) result(val) + implicit none + class(amrpd), intent(in) :: this + integer, intent(in) :: lvl + real(WP), dimension(3), intent(in) :: pos + real(WP), dimension(:,:,:,:), contiguous, pointer, intent(in) :: arr + integer, intent(in) :: comp + real(WP) :: val,wx,wy,wz + integer :: ii,jj,kk + ii=floor((pos(1)-this%amr%xlo)/this%amr%dx(lvl)-0.5_WP); wx=(pos(1)-this%amr%xlo)/this%amr%dx(lvl)-0.5_WP-real(ii,WP) + jj=floor((pos(2)-this%amr%ylo)/this%amr%dy(lvl)-0.5_WP); wy=(pos(2)-this%amr%ylo)/this%amr%dy(lvl)-0.5_WP-real(jj,WP) + kk=floor((pos(3)-this%amr%zlo)/this%amr%dz(lvl)-0.5_WP); wz=(pos(3)-this%amr%zlo)/this%amr%dz(lvl)-0.5_WP-real(kk,WP) + val=(1.0_WP-wx)*(1.0_WP-wy)*(1.0_WP-wz)*arr(ii ,jj ,kk ,comp) & + & + wx *(1.0_WP-wy)*(1.0_WP-wz)*arr(ii+1,jj ,kk ,comp) & + & +(1.0_WP-wx)* wy *(1.0_WP-wz)*arr(ii ,jj+1,kk ,comp) & + & + wx * wy *(1.0_WP-wz)*arr(ii+1,jj+1,kk ,comp) & + & +(1.0_WP-wx)*(1.0_WP-wy)* wz *arr(ii ,jj ,kk+1,comp) & + & + wx *(1.0_WP-wy)* wz *arr(ii+1,jj ,kk+1,comp) & + & +(1.0_WP-wx)* wy * wz *arr(ii ,jj+1,kk+1,comp) & + & + wx * wy * wz *arr(ii+1,jj+1,kk+1,comp) + end function interp + + + + + + ! ============================================================================ + ! CHECKPOINT I/O + ! ============================================================================ + + !> Write the particle-container checkpoint under /particles. + !> Caller is responsible for creating . + subroutine write(this,dirname) + implicit none + class(amrpd), intent(inout) :: this + character(len=*), intent(in) :: dirname + call amrpd_checkpoint_p(this%pcp,trim(dirname)//'/particles'//c_null_char) + end subroutine write + + !> Restore the particle container from a checkpoint written by write. The + !> amrgrid must already be rebuilt; syncs BA/DM, restarts, redistributes. + subroutine read(this,dirname) + implicit none + class(amrpd), intent(inout) :: this + character(len=*), intent(in) :: dirname + integer :: lvl + ! Sync the container to the restored grid's BA/DM + do lvl=0,this%amr%clvl() + call this%set_particle_ba_p(lvl,this%amr%get_boxarray(lvl)) + call this%set_particle_dm_p(lvl,this%amr%get_distromap(lvl)) + end do + ! AMReX Restart + call amrpd_restart_p(this%pcp,trim(dirname)//'/particles'//c_null_char) + ! Settle and refresh + call this%redistribute() + call this%get_info() + end subroutine read + + + ! ============================================================================ + ! DIAGNOSTICS + ! ============================================================================ + + !> Log solver info on root + subroutine print(this) + use, intrinsic :: iso_fortran_env, only: output_unit + use param, only: verbose + use messager, only: log + use string, only: str_long + implicit none + class(amrpd), intent(inout) :: this + character(len=str_long) :: message + if (this%amr%amRoot) then + write(message,'("AMRPD solver [",a,"] on AMR grid [",a,"]")') trim(this%name),trim(this%amr%name) + if (verbose .gt. 1) write(output_unit,'(a)') trim(message) + if (verbose .gt. 0) call log(message) + end if + end subroutine print + + +end module amrpd_class diff --git a/src/amrpd/amrpd_wrapper.cpp b/src/amrpd/amrpd_wrapper.cpp new file mode 100644 index 000000000..4a5bc2b6a --- /dev/null +++ b/src/amrpd/amrpd_wrapper.cpp @@ -0,0 +1,324 @@ +// amrpd_wrapper.cpp +// C++ bridge between Fortran amrpd_class and AMReX particle containers. +// +// Two containers: +// - AMRPDPC: plain ParticleContainer<15,1> holding the grid-side copy of +// a pdsolver solid (positions/velocities/damage) for deposits, interp, +// tagging, viz, and particle checkpoints. No physics, no ghosts. +// +// Bonds are one-sided: each physical bond is stored once, with bond.pos anchored +// at the position of its lower-GID endpoint. AMReX's position-based Redistribute +// then keeps bond and lower-GID particle co-located without an explicit GID->rank +// map. The higher-GID endpoint is accessed via the particle ghost layer. + +#include +#include +#include +#include +#include +#include +#include +#include + +using namespace amrex; + +// Layout constants -- MUST match Fortran AMRPD_NREAL_PART/NINT_PART/NREAL_BOND/NINT_BOND +#define AMRPD_NREAL_PART 15 +#define AMRPD_NINT_PART 1 + +namespace { + +// ----------------------------------------------------------------------- +// Particle container: plain AMReX ParticleContainer -- the grid-side face of +// a pdsolver solid. No neighbor/ghost machinery: physics lives in pdsolver. +// ----------------------------------------------------------------------- +class AMRPDPC : public ParticleContainer +{ +public: + using Base = ParticleContainer; + using ParticleType = Base::ParticleType; + explicit AMRPDPC(AmrCore* amrcore) : Base(amrcore->GetParGDB()) {} +}; + +using PCP = AMRPDPC; +using PTP = PCP::ParticleType; + +} // namespace + +extern "C" { + +// ----------------------------------------------------------------------- +// Lifecycle +// ----------------------------------------------------------------------- + +void amrpd_new_pcp(PCP*& pc, void* amrcore_raw) +{ + pc = new PCP(static_cast(amrcore_raw)); +} + +void amrpd_delete_pcp(PCP* pc) +{ + delete pc; +} + + + +// ----------------------------------------------------------------------- +// Redistribute (AMR-aware position-based migration) +// ----------------------------------------------------------------------- + +void amrpd_redistribute_p(PCP* pc, int lev_min, int lev_max, int ng) +{ + pc->Redistribute(lev_min, lev_max, ng); +} + + +// ----------------------------------------------------------------------- + + + + +// ----------------------------------------------------------------------- + + + + +// ----------------------------------------------------------------------- +// MFIter accessors -- particles (real, ghost, combined) +// ----------------------------------------------------------------------- + +void amrpd_get_particles_mfi(PCP* pc, int lev, MFIter* mfi, + PTP*& dp, long long& np) +{ + if (lev >= static_cast(pc->GetParticles().size())) { + np = 0; dp = nullptr; return; + } + const int grid = mfi->index(); + const int tile = mfi->LocalTileIndex(); + auto& plev = pc->GetParticles(lev); + auto it = plev.find(std::make_pair(grid, tile)); + if (it != plev.end()) { + auto& ptile = it->second; + np = static_cast(ptile.numRealParticles()); + dp = (np > 0) ? ptile.GetArrayOfStructs().data() : nullptr; + } else { + np = 0; dp = nullptr; + } +} + + + +// ----------------------------------------------------------------------- +// MFIter accessor -- bonds +// ----------------------------------------------------------------------- + + +// ----------------------------------------------------------------------- +// Add a single particle or bond to a specific (level, grid, tile) +// ----------------------------------------------------------------------- + +void amrpd_add_particle_i(PCP* pc, int lev, int grid, int tile, PTP* p) +{ + if (lev >= static_cast(pc->GetParticles().size())) return; + auto& plev = pc->GetParticles(lev); + plev[std::make_pair(grid, tile)].push_back(*p); +} + + +// ----------------------------------------------------------------------- +// Bulk append an array of particles to the container at level 0. +// Collective: all ranks must call. Ranks with nothing to add pass n=0 +// and raw=nullptr. Each appended particle gets a fresh AMReX (id,cpu) +// and AddParticlesAtLevel internally redistributes by spatial position. +// ----------------------------------------------------------------------- + +void amrpd_append_particles(PCP* pc, const void* raw, long long n) +{ + PCP::ParticleTileType ptile; + + if (n > 0 && raw != nullptr) { + const PTP* src = reinterpret_cast(raw); + ptile.resize(static_cast(n)); + auto& aos = ptile.GetArrayOfStructs(); + for (long long i = 0; i < n; ++i) { + PTP p = src[i]; // copy pos + rdata + idata + p.id() = PTP::NextID(); // unique AMReX identity + p.cpu() = ParallelDescriptor::MyProc(); + aos[static_cast(i)] = p; + } + } + + pc->AddParticlesAtLevel(ptile, 0); // collective: level 0 redistribute inside +} + +// Append particles PRESERVING caller-provided identities: gids[i] is the RAW +// packed AMReX idcpu (valid bit | id | cpu) exactly as part_gid exposes it -- +// restored verbatim, no decode. Used to rebuild the grid-side face from a +// pdsolver checkpoint, where identities must match the solver's node gids for +// exchange routing. NextID is bumped past the local max id so any later +// append cannot collide. +void amrpd_append_particles_gid(PCP* pc, const void* raw, long long n, + const long long* gids) +{ + PCP::ParticleTileType ptile; + long long maxid = 0; + if (n > 0 && raw != nullptr) { + const PTP* src = reinterpret_cast(raw); + ptile.resize(static_cast(n)); + auto& aos = ptile.GetArrayOfStructs(); + for (long long i = 0; i < n; ++i) { + PTP p = src[i]; + p.m_idcpu = static_cast(gids[i]); + const long long idv = p.id(); + if (idv > maxid) maxid = idv; + aos[static_cast(i)] = p; + } + } + if (maxid >= PTP::NextID()) PTP::NextID(maxid + 1); + pc->AddParticlesAtLevel(ptile, 0); +} + + +// ----------------------------------------------------------------------- +// BoxArray / DistributionMap accessors (for post-regrid sync) +// ----------------------------------------------------------------------- + +void amrpd_get_particle_boxarray_p(PCP* pc, int lev, void** ba_ptr) +{ + *ba_ptr = const_cast(&(pc->ParticleBoxArray(lev))); +} + +void amrpd_get_particle_distromap_p(PCP* pc, int lev, void** dm_ptr) +{ + *dm_ptr = const_cast(&(pc->ParticleDistributionMap(lev))); +} + +void amrpd_set_particle_boxarray_p(PCP* pc, int lev, void* ba_ptr) +{ + pc->SetParticleBoxArray(lev, *static_cast(ba_ptr)); +} + +void amrpd_set_particle_distromap_p(PCP* pc, int lev, void* dm_ptr) +{ + pc->SetParticleDistributionMap(lev, *static_cast(dm_ptr)); +} + + + + + +// ----------------------------------------------------------------------- +// ID and CPU counters / accessors +// ----------------------------------------------------------------------- + +void amrpd_get_next_id_p(long long& id) { id = PTP::NextID(); } +void amrpd_set_next_id_p(long long id) { PTP::NextID(id); } + +void amrpd_get_cpu(int& cpu) { cpu = ParallelDescriptor::MyProc(); } + +void amrpd_get_particle_id(long long& id, const PTP* p) { id = p->id(); } +void amrpd_set_particle_id(long long id, PTP* p) { p->id() = id; } +void amrpd_get_particle_cpu(int& cpu, const PTP* p) { cpu = p->cpu(); } +void amrpd_set_particle_cpu(int cpu, PTP* p) { p->cpu() = cpu; } + + + +// ----------------------------------------------------------------------- +// Total counts (global, across all ranks and levels) +// ----------------------------------------------------------------------- + +void amrpd_total_np(PCP* pc, long long& np) { np = pc->TotalNumberOfParticles(); } + +// ----------------------------------------------------------------------- +// Checkpoint I/O (one subdirectory per container under a shared checkpoint +// directory: /particles/ and /bonds/). Caller is responsible for +// creating ; AMReX's Checkpoint() builds the subdirectory. +// ----------------------------------------------------------------------- + +// Split a single fullpath into (parent, leaf) the same way amrlpt does, so the +// Fortran caller passes one composed path argument per call. +static inline void split_path(const char* fullpath, + std::string& parent, std::string& leaf) +{ + std::string path(fullpath); + while (!path.empty() && path.back() == '/') path.pop_back(); + auto pos = path.rfind('/'); + parent = (pos != std::string::npos) ? path.substr(0, pos) : std::string("."); + leaf = (pos != std::string::npos) ? path.substr(pos+1) : path; +} + +void amrpd_checkpoint_p(PCP* pc, const char* fullpath) +{ + std::string parent, leaf; + split_path(fullpath, parent, leaf); + pc->Checkpoint(parent, leaf, true); +} + +void amrpd_restart_p(PCP* pc, const char* fullpath) +{ + std::string parent, leaf; + split_path(fullpath, parent, leaf); + pc->Restart(parent, leaf); +} + + + +// ----------------------------------------------------------------------- +// Visualization plotfile for the PARTICLE container (bonds not written; we +// can add a separate bond writer if and when we need bond visualization). +// +// write_real[AMRPD_NREAL_PART]: bitmask (1=write, 0=skip) per extra real. +// write_int[AMRPD_NINT_PART]: bitmask per extra int. +// Component names are hardcoded here to match the Fortran part struct layout: +// rdata[0..2] vel -> vx, vy, vz +// rdata[3..5] F_bond -> fbx, fby, fbz +// rdata[6..8] F_fluid -> ffx, ffy, ffz +// rdata[9] mw +// rdata[10] dil +// rdata[11] damage +// rdata[12] nb0 +// rdata[13] td2 +// rdata[14] td2a +// idata[0] flag +// Position (pos[3]) is always written by AMReX (baked into the particle format). +// ----------------------------------------------------------------------- + +void amrpd_write_plotfile(PCP* pc, const char* basedir, const char* pname, + const int* write_real, const int* write_int, double time) +{ + static const Vector rnames = { + "vx", "vy", "vz", + "fbx", "fby", "fbz", + "ffx", "ffy", "ffz", + "mw", "dil", "damage", "nb0", "td2", "td2a" + }; + static const Vector inames = { "flag" }; + + Vector wr(write_real, write_real + AMRPD_NREAL_PART); + Vector wi(write_int, write_int + AMRPD_NINT_PART); + + pc->WritePlotFile(std::string(basedir), std::string(pname), + wr, wi, rnames, inames); + + // Store simulation time inside the plotfile directory (IOProcessor only). + // Used by amrpd_read_plotfile_time on restart to recover the time series. + if (ParallelDescriptor::IOProcessor()) { + std::ofstream tf(std::string(basedir) + "/time"); + tf << std::setprecision(17) << time << '\n'; + } +} + +// ----------------------------------------------------------------------- +// Read back the simulation time stored by amrpd_write_plotfile. +// Returns -1.0 if the file does not exist or cannot be read. +// ----------------------------------------------------------------------- + +double amrpd_read_plotfile_time(const char* basedir) +{ + std::ifstream tf(std::string(basedir) + "/time"); + double t = -1.0; + if (tf.good()) tf >> t; + return t; +} + +} // extern "C" diff --git a/src/amrpd/amrpdviz_class.f90 b/src/amrpd/amrpdviz_class.f90 new file mode 100644 index 000000000..5049e5488 --- /dev/null +++ b/src/amrpd/amrpdviz_class.f90 @@ -0,0 +1,262 @@ +!> AMR peridynamics particle visualization handler +!> +!> Writes the particle container to AMReX plotfiles for ParaView/VisIt viewing. +!> Bond visualization is intentionally NOT supported yet — we expect particle- +!> only views to be sufficient for a long while; bonds are a heavy and rarely +!> needed view, and can be added as a parallel writer later. +!> +!> Usage: +!> type(amrpdviz) :: pviz +!> call pviz%initialize(pd, name='particles') +!> call pviz%select_comp('vel', on=.true. ) ! write velocity +!> call pviz%select_comp('F_bond', on=.true. ) ! write internal force +!> ! In time loop: +!> call pviz%write(time) +module amrpdviz_class + use precision, only: WP + use string, only: str_medium,str_long + use iso_c_binding + use amrpd_class, only: amrpd,AMRPD_NREAL_PART,AMRPD_NINT_PART + implicit none + private + + public :: amrpdviz + + ! C interface -- WritePlotFile wrapper in amrpd_wrapper.cpp + interface + subroutine amrpd_write_plotfile(pc,basedir,pname,write_real,write_int,time) bind(c) + import + type(c_ptr), value :: pc + character(kind=c_char) :: basedir(*),pname(*) + integer(c_int), intent(in) :: write_real(*),write_int(*) + real(c_double), value :: time + end subroutine + function amrpd_read_plotfile_time(basedir) result(t) bind(c) + import + character(kind=c_char) :: basedir(*) + real(c_double) :: t + end function + end interface + + ! Component layout (0-based C indices, matching part struct in amrpd_class): + ! rdata[0..2] vel -> vx, vy, vz + ! rdata[3..5] F_bond -> fbx, fby, fbz + ! rdata[6..8] F_fluid -> ffx, ffy, ffz + ! rdata[9] mw + ! rdata[10] dil + ! rdata[11] damage + ! rdata[12] nb0 + ! idata[0] flag + + type :: amrpdviz + + !> Associated peridynamics solver (non-owning pointer) + class(amrpd), pointer :: pd => null() + + !> Output subdirectory name (inside amrviz/) + character(len=str_medium) :: name='UNNAMED_AMRPDVIZ' + + !> Time-series tracking (matches amrviz / amrlptviz pattern) + integer :: ntime=0 + real(WP), allocatable :: time(:) + + !> Component bitmasks: 1=write, 0=skip (Fortran 1-based; index n corresponds to rdata[n-1] / idata[n-1]) + integer(c_int) :: write_real(AMRPD_NREAL_PART)=0 + integer(c_int) :: write_int (AMRPD_NINT_PART) =0 + + contains + procedure :: initialize !< Set up output dir, restore time series on restart + procedure :: select_comp !< Toggle a named field group on/off + procedure :: write !< Write one plotfile snapshot + procedure :: finalize !< Clean up + end type amrpdviz + +contains + + !> Initialize: create output directory, restore time series on restart. + !> Reads all existing plotfile times from disk (sequentially numbered). + !> Rewind/truncation based on the restart time happens in write(). + subroutine initialize(this,pd,name) + use filesys, only: makedir,isdir + use parallel, only: MPI_REAL_WP + use mpi_f08, only: MPI_BCAST,MPI_INTEGER + implicit none + class(amrpdviz), intent(inout) :: this + class(amrpd), target, intent(in) :: pd + character(len=*), intent(in) :: name + + character(len=str_long) :: pltdir + integer :: ierr,n + real(c_double) :: file_time + + this%pd => pd + this%name = trim(adjustl(name)) + this%ntime = 0 + + ! Default selection: write velocity (3 reals). Skip forces, mw, dil, flag. + ! Position is always written by AMReX. Caller can override via select_comp. + this%write_real = 0 + this%write_real(1:3) = 1 ! vel + this%write_int = 0 + + ! Create output directory + if (pd%amr%amRoot) then + if (.not.isdir('amrviz')) call makedir('amrviz') + if (.not.isdir('amrviz/'//trim(this%name))) & + call makedir('amrviz/'//trim(this%name)) + end if + + ! Root probes for existing plotfiles via C++ function (mirrors amrviz pattern). + ! amrpd_read_plotfile_time returns -1.0 when directory/time file is absent. + if (pd%amr%amRoot) then + n = 0 + find_files: do + n = n + 1 + write(pltdir,'("amrviz/",a,"/plt.part.",i6.6)') trim(this%name),n + file_time = amrpd_read_plotfile_time(trim(pltdir)//c_null_char) + if (file_time.lt.0.0_c_double) exit find_files + end do find_files + this%ntime = n - 1 + if (this%ntime.gt.0) then + allocate(this%time(this%ntime)) + do n = 1, this%ntime + write(pltdir,'("amrviz/",a,"/plt.part.",i6.6)') trim(this%name),n + this%time(n) = real(amrpd_read_plotfile_time(trim(pltdir)//c_null_char),WP) + end do + end if + end if + + ! Broadcast ntime and time array to all ranks + call MPI_BCAST(this%ntime,1,MPI_INTEGER,0,pd%amr%comm,ierr) + if (this%ntime.gt.0) then + if (.not.pd%amr%amRoot) allocate(this%time(this%ntime)) + call MPI_BCAST(this%time,this%ntime,MPI_REAL_WP,0,pd%amr%comm,ierr) + end if + + end subroutine initialize + + + !> Toggle a named field group on or off. + !> Group names: 'vel', 'F_bond', 'F_fluid', 'mw', 'dil', 'damage', 'nb0', 'td2', 'td2a', 'flag' + !> Individual components: 'vx','vy','vz','fbx','fby','fbz','ffx','ffy','ffz' + !> Convenience: 'all', 'position_only' + subroutine select_comp(this,name,on) + implicit none + class(amrpdviz), intent(inout) :: this + character(len=*), intent(in) :: name + logical, intent(in) :: on + integer :: val + + val = merge(1, 0, on) + + select case(trim(name)) + ! Velocity (rdata[0..2]) + case('vel'); this%write_real(1:3) = val + case('vx'); this%write_real(1) = val + case('vy'); this%write_real(2) = val + case('vz'); this%write_real(3) = val + ! Bond force (rdata[3..5]) + case('F_bond'); this%write_real(4:6) = val + case('fbx'); this%write_real(4) = val + case('fby'); this%write_real(5) = val + case('fbz'); this%write_real(6) = val + ! Fluid force (rdata[6..8]) + case('F_fluid'); this%write_real(7:9) = val + case('ffx'); this%write_real(7) = val + case('ffy'); this%write_real(8) = val + case('ffz'); this%write_real(9) = val + ! Scalar state (rdata[9..14]) + case('mw'); this%write_real(10) = val + case('dil'); this%write_real(11) = val + case('damage'); this%write_real(12) = val + case('nb0'); this%write_real(13) = val + case('td2'); this%write_real(14) = val + case('td2a'); this%write_real(15) = val + ! Integer (idata[0]) + case('flag'); this%write_int(1) = val + ! Convenience groups + case('all') + this%write_real = val + this%write_int = val + case('position_only') + this%write_real = 0 + this%write_int = 0 + end select + + end subroutine select_comp + + + !> Write one particle plotfile snapshot. + !> Directory: amrviz//plt.part.NNNNNN (6-digit zero-padded) + subroutine write(this,time) + use iso_c_binding, only: c_null_char,c_double + implicit none + class(amrpdviz), intent(inout) :: this + real(WP), intent(in) :: time + + character(len=str_long) :: pltdir + real(WP), allocatable :: tmp(:) + integer :: i,n + + ! Update time array (same rewind logic as amrviz/amrlptviz: if new time is + ! less than existing ones, truncate the series at the appropriate point) + if (this%ntime.eq.0) then + this%ntime = 1 + if (allocated(this%time)) deallocate(this%time) + allocate(this%time(1)) + this%time(1) = time + else + n = 1 + rewind: do i = this%ntime, 1, -1 + if (this%time(i).lt.time - 1.0e-6_WP) then + n = i + 1; exit rewind + end if + end do rewind + this%ntime = n + allocate(tmp(this%ntime)) + tmp = [this%time(1:this%ntime-1), time] + call move_alloc(tmp, this%time) + end if + + ! Construct output directory + write(pltdir,'("amrviz/",a,"/plt.part.",i6.6)') trim(this%name), this%ntime + + ! Write via C++ wrapper + call amrpd_write_plotfile(this%pd%pcp, & + & trim(pltdir)//c_null_char, & + & 'particles'//c_null_char, & + & this%write_real, this%write_int, & + & real(time, c_double)) + + ! Write/rewrite JSON .series file for ParaView time association + if (this%pd%amr%amRoot) then + open(newunit=n,file='amrviz/'//trim(this%name)//'/plt.part.series', & + & status='replace',action='write') + write(n,'(a)') '{ "file-series-version": "1.0",' + write(n,'(a)') ' "files": [' + do i = 1, this%ntime + write(pltdir,'("plt.part.",i6.6)') i + if (i.lt.this%ntime) then + write(n,'(4x,a,a,a,es24.17,a)') '{ "name": "', trim(pltdir), '", "time": ', this%time(i), ' },' + else + write(n,'(4x,a,a,a,es24.17,a)') '{ "name": "', trim(pltdir), '", "time": ', this%time(i), ' }' + end if + end do + write(n,'(a)') ' ]' + write(n,'(a)') '}' + close(n) + end if + + end subroutine write + + + !> Finalize: clean up allocations + subroutine finalize(this) + implicit none + class(amrpdviz), intent(inout) :: this + if (allocated(this%time)) deallocate(this%time) + nullify(this%pd) + this%ntime = 0 + end subroutine finalize + +end module amrpdviz_class diff --git a/src/amrpd/pdhalo_class.f90 b/src/amrpd/pdhalo_class.f90 new file mode 100644 index 000000000..7a8b88239 --- /dev/null +++ b/src/amrpd/pdhalo_class.f90 @@ -0,0 +1,555 @@ +!> Persistent graph-halo communication for the peridynamics solver (pdsolver). +!> +!> Two objects: +!> pddir -- distributed GID directory. Owner-rank resolution for arbitrary +!> global ids via a hashed home-rank protocol (Fibonacci-mixed: +!> raw mod collapses on structured idcpu keys). +!> Built once at init, used during plan construction, then discarded. +!> pdhalo -- persistent halo exchange plan. A halo SLOT is a (gid, image-offset) +!> pair: a node bonded to two periodic images of the same partner +!> gets two slots with different shifts. Shifts are applied at +!> unpack time on the receiver, so send buffers are pure copies and +!> the same owned node can serve any number of slots/images. +!> Two operations per substep: +!> update(field) -- owner values -> halo slots (positions get +shift) +!> reduce(field) -- halo-slot accumulations -> add back into owners +!> Both are nonblocking isend/irecv with fixed, deterministic +!> pack/unpack order (neighbor rank ascending, slot order within). +!> +!> Self-rank "neighbors" (periodic self-images or same-rank image bonds) are +!> handled uniformly through MPI self-messages -- no special-case code path. +module pdhalo_class + use precision, only: WP,I8 + use mpi_f08 + implicit none + private + + public :: pddir,pdhalo,sort3_perm,PDHALO_KEY0 + + !> Packed zero image offset ((0+128) + (0+128)*256 + (0+128)*65536), + !> matching amrpd's hist1 convention. + integer, parameter :: PDHALO_KEY0=8421504 + + !> Distributed GID directory (hashed home-rank protocol) + type :: pddir + integer :: n=0 !< number of gids homed on this rank + integer(I8), allocatable :: keys(:) !< gids homed on this rank (sorted) + integer, allocatable :: owner(:) !< owner rank per homed gid (aligned with keys) + contains + procedure :: register + procedure :: query + procedure :: finalize => dir_finalize + end type pddir + + !> Persistent halo plan + exchange buffers + type :: pdhalo + integer :: nown=0 !< owned nodes (halo slots are indexed nown+1..nown+nhalo) + integer :: nhalo=0 !< halo slot count + ! Receive side: whom I receive halo data from (= owners of my slots) + integer :: nrecv=0 + integer, allocatable :: nbr_recv(:) !< source ranks, ascending + integer, allocatable :: recv_ptr(:) !< (nrecv+1) slot group offsets + ! Send side: whom I send owned data to (= ranks holding slots of my nodes) + integer :: nsend=0 + integer, allocatable :: nbr_send(:) !< destination ranks, ascending + integer, allocatable :: send_ptr(:) !< (nsend+1) entry group offsets + integer, allocatable :: send_idx(:) !< owned node index per send entry (duplicates allowed: one per remote slot) + ! Per-slot image shift (added to position components at unpack) + real(WP), allocatable :: shift(:,:) !< (3,nhalo) + ! Persistent message buffers (grown on demand) + real(WP), allocatable :: sbuf(:),rbuf(:) + contains + procedure :: build + procedure :: update + procedure :: update1 + procedure :: reduce + procedure :: finalize => halo_finalize + end type pdhalo + +contains + + + ! =========================================================================== + ! Sorting utility: recursive quicksort of a permutation over a triple key + ! (a int, g int64, k int), ordered lexicographically. Used for deterministic + ! halo-slot and CSR ordering. a is typically an owner rank or a node index. + ! =========================================================================== + recursive subroutine sort3_perm(a,g,k,perm,lo,hi) + implicit none + integer, intent(in) :: a(:) + integer(I8), intent(in) :: g(:) + integer, intent(in) :: k(:) + integer, intent(inout) :: perm(:) + integer, intent(in) :: lo,hi + integer :: i,j,tp,pv + if (lo.ge.hi) return + pv=perm((lo+hi)/2) + i=lo; j=hi + do + do while (less3(perm(i),pv)); i=i+1; end do + do while (less3(pv,perm(j))); j=j-1; end do + if (i.le.j) then + tp=perm(i); perm(i)=perm(j); perm(j)=tp + i=i+1; j=j-1 + end if + if (i.gt.j) exit + end do + call sort3_perm(a,g,k,perm,lo,j) + call sort3_perm(a,g,k,perm,i,hi) + contains + logical function less3(p,q) + integer, intent(in) :: p,q + if (a(p).ne.a(q)) then + less3=a(p).lt.a(q) + else if (g(p).ne.g(q)) then + less3=g(p).lt.g(q) + else + less3=k(p).lt.k(q) + end if + end function less3 + end subroutine sort3_perm + + + ! =========================================================================== + ! PDDIR -- distributed GID directory + ! =========================================================================== + + !> Register this rank's owned gids with their home ranks. Collective. + subroutine register(this,n,gids) + use parallel, only: comm,rank,nproc + use pdhash_class, only: gid_hash + implicit none + class(pddir), intent(inout) :: this + integer, intent(in) :: n + integer(I8), intent(in) :: gids(:) + integer, dimension(0:nproc-1) :: sc,rc,sd,rd + integer(I8), allocatable :: sg(:),rg(:) + integer, allocatable :: pos(:) + integer :: i,h,nr,r,ierr + ! Count per home rank + sc=0 + do i=1,n + h=home(gids(i)); sc(h)=sc(h)+1 + end do + call MPI_ALLTOALL(sc,1,MPI_INTEGER,rc,1,MPI_INTEGER,comm,ierr) + sd(0)=0; rd(0)=0 + do r=1,nproc-1 + sd(r)=sd(r-1)+sc(r-1); rd(r)=rd(r-1)+rc(r-1) + end do + ! Pack and exchange gids + allocate(sg(max(n,1)),pos(0:nproc-1)) + pos=sd + do i=1,n + h=home(gids(i)); pos(h)=pos(h)+1; sg(pos(h))=gids(i) + end do + nr=sum(rc) + allocate(rg(max(nr,1))) + call MPI_ALLTOALLV(sg,sc,sd,MPI_INTEGER8,rg,rc,rd,MPI_INTEGER8,comm,ierr) + deallocate(sg,pos) + ! Store: owner of each received gid = the rank it arrived from + this%n=nr + allocate(this%keys(max(nr,1)),this%owner(max(nr,1))) + this%keys(1:nr)=rg(1:nr) + do r=0,nproc-1 + do i=rd(r)+1,rd(r)+rc(r) + this%owner(i)=r + end do + end do + ! Sort keys with the owner array following (simple perm sort) + sort_dir: block + integer, allocatable :: perm(:),zk(:),ow(:) + integer(I8), allocatable :: kk(:) + integer :: m + m=nr + if (m.gt.0) then + allocate(perm(m),zk(m),ow(m),kk(m)) + do i=1,m + perm(i)=i + end do + zk=0 + call sort3_perm(zk,this%keys(1:m),zk,perm,1,m) + kk=this%keys(1:m); ow=this%owner(1:m) + do i=1,m + this%keys(i) =kk(perm(i)) + this%owner(i)=ow(perm(i)) + end do + deallocate(perm,zk,ow,kk) + end if + end block sort_dir + deallocate(rg) + end subroutine register + + !> Resolve owner ranks for m gids. Collective. Dies on unknown gid. + subroutine query(this,m,gids,owners) + use parallel, only: comm,nproc + use messager, only: die + implicit none + class(pddir), intent(in) :: this + integer, intent(in) :: m + integer(I8), intent(in) :: gids(:) + integer, intent(out) :: owners(:) + integer, dimension(0:nproc-1) :: sc,rc,sd,rd + integer(I8), allocatable :: sg(:),rg(:) + integer, allocatable :: pos(:),qpos(:),rans(:),reply(:) + integer :: i,h,nr,r,idx,ierr + ! Count and pack queries by home rank; remember each query's packed slot + sc=0 + do i=1,m + h=home(gids(i)); sc(h)=sc(h)+1 + end do + call MPI_ALLTOALL(sc,1,MPI_INTEGER,rc,1,MPI_INTEGER,comm,ierr) + sd(0)=0; rd(0)=0 + do r=1,nproc-1 + sd(r)=sd(r-1)+sc(r-1); rd(r)=rd(r-1)+rc(r-1) + end do + allocate(sg(max(m,1)),pos(0:nproc-1),qpos(max(m,1))) + pos=sd + do i=1,m + h=home(gids(i)); pos(h)=pos(h)+1; sg(pos(h))=gids(i); qpos(i)=pos(h) + end do + nr=sum(rc) + allocate(rg(max(nr,1))) + call MPI_ALLTOALLV(sg,sc,sd,MPI_INTEGER8,rg,rc,rd,MPI_INTEGER8,comm,ierr) + ! Answer each received query by binary search of the sorted directory + allocate(rans(max(nr,1))) + do i=1,nr + idx=dir_lookup(this,rg(i)) + if (idx.lt.1) call die('[pddir query] gid not found in directory') + rans(i)=this%owner(idx) + end do + ! Send answers back along the reverse route (counts swapped) + allocate(reply(max(m,1))) + call MPI_ALLTOALLV(rans,rc,rd,MPI_INTEGER,reply,sc,sd,MPI_INTEGER,comm,ierr) + do i=1,m + owners(i)=reply(qpos(i)) + end do + deallocate(sg,rg,pos,qpos,rans,reply) + end subroutine query + + !> Binary search of the sorted directory keys. Returns index or -1. + pure function dir_lookup(this,key) result(idx) + implicit none + class(pddir), intent(in) :: this + integer(I8), intent(in) :: key + integer :: idx,lo,hi,mid + idx=-1 + if (.not.allocated(this%keys).or.this%n.eq.0) return + lo=1; hi=this%n + do while (lo.le.hi) + mid=(lo+hi)/2 + if (this%keys(mid).lt.key) then + lo=mid+1 + else if (this%keys(mid).gt.key) then + hi=mid-1 + else + idx=mid + return + end if + end do + end function dir_lookup + + !> Release directory storage + subroutine dir_finalize(this) + implicit none + class(pddir), intent(inout) :: this + if (allocated(this%keys)) deallocate(this%keys) + if (allocated(this%owner)) deallocate(this%owner) + this%n=0 + end subroutine dir_finalize + + !> Home rank of a gid. Keys are STRUCTURED (AMReX idcpu = id<<24|cpu: raw + !> mod collapses onto few ranks -- all of them rank 0 for power-of-two + !> nproc when cpu=0), so mix the bits first (Fibonacci hash; the multiply + !> wraps by design, and the logical shift keeps the result nonnegative). + pure function home(gid) result(h) + use parallel, only: nproc + implicit none + integer(I8), intent(in) :: gid + integer :: h + integer(I8) :: k + k=gid*(-7046029254386353131_I8) + h=int(mod(ishft(k,-40),int(nproc,I8))) + end function home + + + ! =========================================================================== + ! PDHALO -- persistent halo plan + ! =========================================================================== + + !> Build the halo plan. Collective. + !> nown : owned node count (slots index from nown+1) + !> ohash : gid->owned-index hash over this rank's owned gids + !> nreq : number of UNIQUE remote references (gid, image-key) pairs + !> rgid/rkey: the references (key packs the image offset, amrpd hist1 style) + !> rowner : owner rank of each reference's gid (from pddir%query) + !> Ldom/per : domain lengths and periodicity (for shift vectors) + !> slot : OUT -- final halo slot (1..nhalo) of each input reference + subroutine build(this,nown,ohash,nreq,rgid,rkey,rowner,Ldom,per,slot) + use parallel, only: comm,nproc + use messager, only: die + use pdhash_class, only: gid_hash + implicit none + class(pdhalo), intent(inout) :: this + integer, intent(in) :: nown,nreq + type(gid_hash), intent(in) :: ohash + integer(I8), intent(in) :: rgid(:) + integer, intent(in) :: rkey(:),rowner(:) + real(WP), intent(in) :: Ldom(3) + logical, intent(in) :: per(3) + integer, intent(out) :: slot(:) + integer, allocatable :: perm(:) + integer, dimension(0:nproc-1) :: sc,rc,sd,rd + integer :: i,s,r,n1,n2,n3,ierr,nr,lid + integer(I8), allocatable :: sg(:),rg(:) + + this%nown=nown + this%nhalo=nreq + + ! Deterministic slot order: sort references by (owner, gid, key) + allocate(perm(max(nreq,1))) + do i=1,nreq + perm(i)=i + end do + if (nreq.gt.1) call sort3_perm(rowner,rgid,rkey,perm,1,nreq) + do s=1,nreq + slot(perm(s))=s + end do + + ! Receive groups (one per distinct owner, ascending by construction) + count_recv: block + integer :: prev + this%nrecv=0; prev=-1 + do s=1,nreq + if (rowner(perm(s)).ne.prev) then + this%nrecv=this%nrecv+1; prev=rowner(perm(s)) + end if + end do + allocate(this%nbr_recv(max(this%nrecv,1)),this%recv_ptr(this%nrecv+1)) + this%nrecv=0; prev=-1 + do s=1,nreq + if (rowner(perm(s)).ne.prev) then + this%nrecv=this%nrecv+1; prev=rowner(perm(s)) + this%nbr_recv(this%nrecv)=prev + this%recv_ptr(this%nrecv)=s + end if + end do + this%recv_ptr(this%nrecv+1)=nreq+1 + end block count_recv + + ! Per-slot shift vectors from the packed image key + allocate(this%shift(3,max(nreq,1))) + do s=1,nreq + i=perm(s) + n1=mod(rkey(i),256)-128; n2=mod(rkey(i)/256,256)-128; n3=rkey(i)/65536-128 + if ((n1.ne.0.and..not.per(1)).or.(n2.ne.0.and..not.per(2)).or.(n3.ne.0.and..not.per(3))) & + & call die('[pdhalo build] nonzero image offset along a non-periodic direction') + this%shift(1,s)=real(n1,WP)*Ldom(1) + this%shift(2,s)=real(n2,WP)*Ldom(2) + this%shift(3,s)=real(n3,WP)*Ldom(3) + end do + + ! Tell every owner which of its nodes we need (gids in slot order). + ! Payload order within each destination = our slot order, and MPI + ! preserves per-pair message order, so the owner's send list built in + ! arrival order matches our slot order exactly. + sc=0 + do s=1,nreq + sc(rowner(perm(s)))=sc(rowner(perm(s)))+1 + end do + call MPI_ALLTOALL(sc,1,MPI_INTEGER,rc,1,MPI_INTEGER,comm,ierr) + sd(0)=0; rd(0)=0 + do r=1,nproc-1 + sd(r)=sd(r-1)+sc(r-1); rd(r)=rd(r-1)+rc(r-1) + end do + allocate(sg(max(nreq,1))) + do s=1,nreq + sg(s)=rgid(perm(s)) ! grouped by owner because slots are owner-sorted + end do + nr=sum(rc) + allocate(rg(max(nr,1))) + call MPI_ALLTOALLV(sg,sc,sd,MPI_INTEGER8,rg,rc,rd,MPI_INTEGER8,comm,ierr) + + ! Send groups: ranks that requested nodes from me + count_send: block + integer :: g + this%nsend=count(rc.gt.0) + allocate(this%nbr_send(max(this%nsend,1)),this%send_ptr(this%nsend+1)) + allocate(this%send_idx(max(nr,1))) + g=0; this%send_ptr(1)=1 + do r=0,nproc-1 + if (rc(r).gt.0) then + g=g+1 + this%nbr_send(g)=r + this%send_ptr(g+1)=this%send_ptr(g)+rc(r) + do i=rd(r)+1,rd(r)+rc(r) + lid=ohash%lookup(rg(i)) + if (lid.lt.1) call die('[pdhalo build] halo request for a gid this rank does not own') + this%send_idx(this%send_ptr(g)+(i-rd(r)-1))=lid + end do + end if + end do + end block count_send + + deallocate(perm,sg,rg) + end subroutine build + + !> Refresh halo slots with current owner values: field(:,1:nown) -> slots. + !> field is (ncomp, nown+nhalo). If shifted, per-slot image shifts are added + !> to components 1:3 (positions). Deterministic unpack order. + subroutine update(this,field,ncomp,shifted) + use parallel, only: comm,MPI_REAL_WP + use messager, only: die + implicit none + class(pdhalo), intent(inout) :: this + real(WP), intent(inout) :: field(:,:) + integer, intent(in) :: ncomp + logical, intent(in) :: shifted + type(MPI_Request), allocatable :: reqs(:) + integer :: i,g,s,off,cnt,nrq,ierr + integer :: nsend_tot + if (shifted.and.ncomp.lt.3) call die('[pdhalo update] shifted update requires ncomp>=3') + nsend_tot=this%send_ptr(this%nsend+1)-1 + call ensure_buffers(this,ncomp*max(nsend_tot,1),ncomp*max(this%nhalo,1)) + allocate(reqs(this%nrecv+this%nsend)) + nrq=0 + ! Post receives (one message per source rank) + do g=1,this%nrecv + off=ncomp*(this%recv_ptr(g)-1) + cnt=ncomp*(this%recv_ptr(g+1)-this%recv_ptr(g)) + nrq=nrq+1 + call MPI_IRECV(this%rbuf(off+1:off+cnt),cnt,MPI_REAL_WP,this%nbr_recv(g),101,comm,reqs(nrq),ierr) + end do + ! Pack and send (one message per destination rank) + do g=1,this%nsend + off=ncomp*(this%send_ptr(g)-1) + do i=this%send_ptr(g),this%send_ptr(g+1)-1 + this%sbuf(off+ncomp*(i-this%send_ptr(g))+1:off+ncomp*(i-this%send_ptr(g))+ncomp)=field(1:ncomp,this%send_idx(i)) + end do + cnt=ncomp*(this%send_ptr(g+1)-this%send_ptr(g)) + nrq=nrq+1 + call MPI_ISEND(this%sbuf(off+1:off+cnt),cnt,MPI_REAL_WP,this%nbr_send(g),101,comm,reqs(nrq),ierr) + end do + call MPI_WAITALL(nrq,reqs,MPI_STATUSES_IGNORE,ierr) + ! Unpack into halo slots (slot s lives at field index nown+s) + do s=1,this%nhalo + field(1:ncomp,this%nown+s)=this%rbuf(ncomp*(s-1)+1:ncomp*(s-1)+ncomp) + end do + if (shifted) then + do s=1,this%nhalo + field(1:3,this%nown+s)=field(1:3,this%nown+s)+this%shift(1:3,s) + end do + end if + deallocate(reqs) + end subroutine update + + !> Scalar-field variant of update (no shift): owner values -> halo slots. + !> Used for static per-node scalars (e.g., nodal volume) filled once at init. + subroutine update1(this,field) + use parallel, only: comm,MPI_REAL_WP + implicit none + class(pdhalo), intent(inout) :: this + real(WP), intent(inout) :: field(:) + type(MPI_Request), allocatable :: reqs(:) + integer :: i,g,s,off,cnt,nrq,ierr + integer :: nsend_tot + nsend_tot=this%send_ptr(this%nsend+1)-1 + call ensure_buffers(this,max(nsend_tot,1),max(this%nhalo,1)) + allocate(reqs(this%nrecv+this%nsend)) + nrq=0 + do g=1,this%nrecv + off=this%recv_ptr(g)-1 + cnt=this%recv_ptr(g+1)-this%recv_ptr(g) + nrq=nrq+1 + call MPI_IRECV(this%rbuf(off+1:off+cnt),cnt,MPI_REAL_WP,this%nbr_recv(g),103,comm,reqs(nrq),ierr) + end do + do g=1,this%nsend + off=this%send_ptr(g)-1 + do i=this%send_ptr(g),this%send_ptr(g+1)-1 + this%sbuf(i)=field(this%send_idx(i)) + end do + cnt=this%send_ptr(g+1)-this%send_ptr(g) + nrq=nrq+1 + call MPI_ISEND(this%sbuf(off+1:off+cnt),cnt,MPI_REAL_WP,this%nbr_send(g),103,comm,reqs(nrq),ierr) + end do + call MPI_WAITALL(nrq,reqs,MPI_STATUSES_IGNORE,ierr) + do s=1,this%nhalo + field(this%nown+s)=this%rbuf(s) + end do + deallocate(reqs) + end subroutine update1 + + !> Add halo-slot accumulations back into their owners: slots -> field(:,1:nown). + !> Reverse of update: slot data flows to the owner, which adds it into the + !> owned entries listed in send_idx. Deterministic add order (group order, + !> then entry order within group). + subroutine reduce(this,field,ncomp) + use parallel, only: comm,MPI_REAL_WP + implicit none + class(pdhalo), intent(inout) :: this + real(WP), intent(inout) :: field(:,:) + integer, intent(in) :: ncomp + type(MPI_Request), allocatable :: reqs(:) + integer :: i,g,s,off,cnt,nrq,ierr + integer :: nsend_tot + nsend_tot=this%send_ptr(this%nsend+1)-1 + ! Buffers: sending nhalo slots, receiving nsend_tot contributions + call ensure_buffers(this,ncomp*max(this%nhalo,1),ncomp*max(nsend_tot,1)) + allocate(reqs(this%nrecv+this%nsend)) + nrq=0 + ! Post receives along the send-plan links (contributions to my owned nodes) + do g=1,this%nsend + off=ncomp*(this%send_ptr(g)-1) + cnt=ncomp*(this%send_ptr(g+1)-this%send_ptr(g)) + nrq=nrq+1 + call MPI_IRECV(this%rbuf(off+1:off+cnt),cnt,MPI_REAL_WP,this%nbr_send(g),102,comm,reqs(nrq),ierr) + end do + ! Pack halo slots and send to their owners along the recv-plan links + do g=1,this%nrecv + off=ncomp*(this%recv_ptr(g)-1) + do s=this%recv_ptr(g),this%recv_ptr(g+1)-1 + this%sbuf(off+ncomp*(s-this%recv_ptr(g))+1:off+ncomp*(s-this%recv_ptr(g))+ncomp)=field(1:ncomp,this%nown+s) + end do + cnt=ncomp*(this%recv_ptr(g+1)-this%recv_ptr(g)) + nrq=nrq+1 + call MPI_ISEND(this%sbuf(off+1:off+cnt),cnt,MPI_REAL_WP,this%nbr_recv(g),102,comm,reqs(nrq),ierr) + end do + call MPI_WAITALL(nrq,reqs,MPI_STATUSES_IGNORE,ierr) + ! Accumulate received contributions into owned nodes + do i=1,nsend_tot + field(1:ncomp,this%send_idx(i))=field(1:ncomp,this%send_idx(i))+this%rbuf(ncomp*(i-1)+1:ncomp*(i-1)+ncomp) + end do + deallocate(reqs) + end subroutine reduce + + !> Grow persistent buffers on demand + subroutine ensure_buffers(this,ns,nr) + implicit none + class(pdhalo), intent(inout) :: this + integer, intent(in) :: ns,nr + if (allocated(this%sbuf)) then + if (size(this%sbuf).lt.ns) deallocate(this%sbuf) + end if + if (.not.allocated(this%sbuf)) allocate(this%sbuf(ns)) + if (allocated(this%rbuf)) then + if (size(this%rbuf).lt.nr) deallocate(this%rbuf) + end if + if (.not.allocated(this%rbuf)) allocate(this%rbuf(nr)) + end subroutine ensure_buffers + + !> Release plan storage + subroutine halo_finalize(this) + implicit none + class(pdhalo), intent(inout) :: this + if (allocated(this%nbr_recv)) deallocate(this%nbr_recv) + if (allocated(this%recv_ptr)) deallocate(this%recv_ptr) + if (allocated(this%nbr_send)) deallocate(this%nbr_send) + if (allocated(this%send_ptr)) deallocate(this%send_ptr) + if (allocated(this%send_idx)) deallocate(this%send_idx) + if (allocated(this%shift)) deallocate(this%shift) + if (allocated(this%sbuf)) deallocate(this%sbuf) + if (allocated(this%rbuf)) deallocate(this%rbuf) + this%nown=0; this%nhalo=0; this%nrecv=0; this%nsend=0 + end subroutine halo_finalize + + +end module pdhalo_class diff --git a/src/amrpd/pdhash_class.f90 b/src/amrpd/pdhash_class.f90 new file mode 100644 index 000000000..7d7e4d197 --- /dev/null +++ b/src/amrpd/pdhash_class.f90 @@ -0,0 +1,155 @@ +!> GID -> LID hash (sorted array + binary search; build O(N log N), lookup +!> O(log N)). Used by pdsolver for owned-node gid resolution and halo-plan +!> construction. +module pdhash_class + use iso_c_binding, only: c_int64_t + implicit none + private + + public :: gid_hash + + !> Sorted (key, val) pairs. Key is a unique int64 GID; val is the 1-based + !> local index into the source particle array. + type :: gid_hash + integer(c_int64_t), allocatable :: keys(:) + integer, allocatable :: vals(:) + integer :: n = 0 + contains + procedure :: build + procedure :: lookup + procedure :: lookup_range !< For periodic-image disambiguation: returns ALL duplicates of a key + procedure :: finalize + end type gid_hash + +contains + + !> Build a sorted hash from an array of keys. Values are assigned 1..n + !> (the LIDs in the source array). Caller supplies the key array; this + !> routine copies and sorts. + subroutine build(this,n,keys) + implicit none + class(gid_hash), intent(inout) :: this + integer, intent(in) :: n + integer(c_int64_t), intent(in) :: keys(n) + integer :: i + call this%finalize() + this%n = n + if (n.gt.0) then + allocate(this%keys(n),this%vals(n)) + this%keys = keys + do i = 1, n + this%vals(i) = i + end do + call quicksort_pair(this%keys,this%vals,1,n) + end if + end subroutine build + + !> Look up a key. Returns the 1-based LID on hit, -1 on miss. + pure function lookup(this,key) result(lid) + implicit none + class(gid_hash), intent(in) :: this + integer(c_int64_t), intent(in) :: key + integer :: lid + integer :: lo,hi,mid + lid = -1 + if (this%n.eq.0) return + lo = 1; hi = this%n + do while (lo.le.hi) + mid = (lo + hi) / 2 + if (this%keys(mid).lt.key) then + lo = mid + 1 + else if (this%keys(mid).gt.key) then + hi = mid - 1 + else + lid = this%vals(mid) + return + end if + end do + end function lookup + + !> Find the contiguous bracket of duplicates for a given key in the sorted + !> array. Returns first_idx (1-based) and n_dup. On miss, n_dup = 0. + !> + !> Use case: periodic-image disambiguation. When the hash is built from a + !> particle array that contains both an owned particle and its periodic- + !> image ghost copy (which share the same idcpu = key), multiple entries + !> exist. The caller walks the bracket [first_idx .. first_idx+n_dup-1] + !> in self%vals to get all candidate LIDs, then picks the right image by + !> minimum-image distance to an anchor position. + !> + !> Common case (no duplicates): n_dup = 1, self%vals(first_idx) is the LID. + pure subroutine lookup_range(this,key,first_idx,n_dup) + implicit none + class(gid_hash), intent(in) :: this + integer(c_int64_t), intent(in) :: key + integer, intent(out) :: first_idx,n_dup + integer :: lo,hi,mid,i,j + first_idx = -1; n_dup = 0 + if (this%n.eq.0) return + ! Binary search for any matching index + lo = 1; hi = this%n + mid = -1 + do while (lo.le.hi) + mid = (lo + hi) / 2 + if (this%keys(mid).lt.key) then + lo = mid + 1 + else if (this%keys(mid).gt.key) then + hi = mid - 1 + else + exit + end if + end do + if (mid.lt.1.or.mid.gt.this%n) return + if (this%keys(mid).ne.key) return + ! Scan left and right for duplicates (sorted -> contiguous) + i = mid + do while (i.gt.1) + if (this%keys(i-1).ne.key) exit + i = i - 1 + end do + j = mid + do while (j.lt.this%n) + if (this%keys(j+1).ne.key) exit + j = j + 1 + end do + first_idx = i + n_dup = j - i + 1 + end subroutine lookup_range + + !> Release allocated storage. + subroutine finalize(this) + implicit none + class(gid_hash), intent(inout) :: this + if (allocated(this%keys)) deallocate(this%keys) + if (allocated(this%vals)) deallocate(this%vals) + this%n = 0 + end subroutine finalize + + + !> Recursive Hoare-partition quicksort on (key, val) pairs, sorted by key. + !> Private module helper. + recursive subroutine quicksort_pair(keys,vals,lo,hi) + implicit none + integer(c_int64_t), intent(inout) :: keys(:) + integer, intent(inout) :: vals(:) + integer, intent(in) :: lo,hi + integer :: i,j,tv + integer(c_int64_t) :: pivot,tk + if (lo.ge.hi) return + pivot = keys((lo + hi) / 2) + i = lo; j = hi + do + do while (keys(i).lt.pivot); i = i + 1; end do + do while (keys(j).gt.pivot); j = j - 1; end do + if (i.le.j) then + tk = keys(i); keys(i) = keys(j); keys(j) = tk + tv = vals(i); vals(i) = vals(j); vals(j) = tv + i = i + 1; j = j - 1 + end if + if (i.gt.j) exit + end do + call quicksort_pair(keys,vals,lo,j) + call quicksort_pair(keys,vals,i,hi) + end subroutine quicksort_pair + +end module pdhash_class diff --git a/src/amrpd/pdsolver_class.f90 b/src/amrpd/pdsolver_class.f90 new file mode 100644 index 000000000..91f4e692e --- /dev/null +++ b/src/amrpd/pdsolver_class.f90 @@ -0,0 +1,2173 @@ +!> Peridynamics solver: node-centered, CSR-based solid dynamics on flat +!> per-field arrays with persistent graph-halo communication. GRID-FREE: +!> no AMReX anywhere -- ownership follows the reference configuration +!> (Morton partition, motion-invariant), neighborhoods and communication +!> plans are built once and reused every substep. +!> +!> Physics: linear peridynamic solid (LPS, dimension-aware coefficients, +!> influence function hard-coded in omega() with derived quantities +!> generalized through its moments), brittle stretch damage, per-side +!> viscoelastic/viscoplastic flow with J2 (Mitchell OSB) yield, soft-sphere +!> contact (walls + particle-particle via a displacement-triggered spatial +!> service), velocity-Verlet integration. +!> Checkpoint/restart is gid-space and rank-count portable, including all +!> bond damage and plastic history. +!> +!> Usage tiers (amrpd EXTENDS pdsolver -- see amrpd_class): +!> 1. pdsolver alone -- standalone solid dynamics (this module only) +!> 2. amrpd -- adds viz, mesh VF, AMR refinement, seeding +!> 3. ... + a flow solver -- two-way FSI via amrpd%exchange_solid +!> +!> Configuration style: assign the public fields (material, damage, contact), +!> then build the network (detect_families/connect/read_state) -- derived +!> quantities resolve there via derive_config, uniformly for fresh and restart. +!> +!> Layout: owned nodes 1..nown; halo slots nown+1..ntot, keyed (gid, periodic +!> image offset) with shifts applied at exchange time. Each physical bond is +!> two CSR half-entries (one per endpoint row, Peridigm convention): kernels +!> compute each row's own force state -- ghost dilatation is never +!> communicated -- and a single halo reduce assembles cross-rank pairs. +!> Kernels are pure loops over owned nodes with no mutable module-level +!> state (OpenMP-ready by construction; threads deferred). +module pdsolver_class + use precision, only: WP,I8 + use string, only: str_medium + use pdhalo_class, only: pddir,pdhalo,sort3_perm,PDHALO_KEY0 + use pdhash_class, only: gid_hash + implicit none + private + + public :: pdsolver,pd_partition + public :: PDC_IS_DEAD,PDC_MOVES,PDC_INTEGRATES,PDC_BONDS + public :: PD_OPEN,PD_WALL + + ! Motion-control bit flags -- values MUST match amrpd's PART_* constants + ! (handoff copies amrpd flags verbatim) + integer, parameter :: PDC_IS_DEAD =0 + integer, parameter :: PDC_MOVES =1 + integer, parameter :: PDC_INTEGRATES=2 + integer, parameter :: PDC_BONDS =4 + + ! Domain-face BC values for lo_bc/hi_bc + integer, parameter :: PD_OPEN=0 + integer, parameter :: PD_WALL=1 + + !> Graph-core PD solver + type :: pdsolver + character(len=str_medium) :: name='UNNAMED_PDSOLVER' + + ! Sizes + integer :: nown=0 !< owned nodes on this rank + integer :: nhalo=0 !< halo slots + integer :: ntot=0 !< nown+nhalo + integer(I8) :: np=0 !< global node count (get_info) + integer(I8) :: nbond=0 !< global bond count (half-entries/2, get_info) + + ! Material / discretization + real(WP) :: rho =0.0_WP !< density + real(WP) :: elastic_modulus=0.0_WP !< Young's modulus + real(WP) :: poisson_ratio =0.0_WP !< Poisson's ratio + real(WP) :: delta =0.0_WP !< horizon + real(WP) :: dV =0.0_WP !< nominal element volume (CFL length scale; kernels use per-node V) + real(WP) :: s0 =huge(1.0_WP) !< critical bond stretch (huge = no damage) + real(WP) :: fail_stretch =huge(1.0_WP) !< direct s0 override (takes precedence over crit_energy) + real(WP) :: crit_energy =huge(1.0_WP) !< critical energy release rate G_c (-> s0 when fail_stretch unset) + real(WP) :: dtcrit =0.0_WP !< Silling-Askari critical dt (diagnostic, stamped at connect) + ! Viscoelastic / viscoplastic flow (PER-SIDE form: each half-entry evolves + ! its own e_v with its own endpoint's dilatation and yield factor -- + ! exactly Peridigm's elastic_plastic.cxx, verified term-by-term against + ! amrpd's J2 2026-07-14. This is the one INTENDED delta from amrpd, which + ! averages the endpoints into a single per-bond e_v.) + real(WP) :: tau =huge(1.0_WP) !< Maxwell deviatoric relaxation time (huge = purely elastic) + real(WP) :: visc_lambda =1.0_WP !< SLS relaxing fraction [0,1] + real(WP) :: yield_stretch =0.0_WP !< legacy per-bond Perzyna yield strain (0 = pure Maxwell) + real(WP) :: sigma_yield =0.0_WP !< J2 yield stress (Mitchell OSB family norm; overrides yield_stretch) + real(WP) :: hard_mod =0.0_WP !< linear isotropic hardening modulus H: flow stress = sigma_yield + H*lam_p (0 = perfectly plastic) + real(WP), dimension(3) :: gravity=0.0_WP !< body acceleration + logical, dimension(3) :: collapsed=.false. !< collapsed (n==1) directions: velocity locked + real(WP), dimension(3) :: Ldom=0.0_WP !< domain lengths (image shifts) + logical, dimension(3) :: per=.false. !< periodicity per direction + real(WP), dimension(3) :: dom_lo=0.0_WP !< domain lower bounds (wall contact) + real(WP), dimension(3) :: dom_hi=0.0_WP !< domain upper bounds (wall contact) + + ! Short-range soft-sphere contact (soft-sphere penalty + damping). + ! Contact is a pure SPATIAL service, fully separate from the bond graph: + ! candidates are (owned nodes + contact-halo slots) discovered by a + ! displacement-triggered broad phase; the graph halo is never binned, so + ! bonded remote partners arrive as contact slots when in range and + ! double-counting is structurally impossible. The narrow phase is + ! gather-only (each owned node accumulates from its candidates -- the + ! partner gets its share from its own row), so no force reduction. + logical :: use_contact =.false. + real(WP) :: contact_dist =0.0_WP !< d_c (p-p d_eff; wall d_eff = 0.5*d_c) + real(WP) :: tau_col =0.0_WP !< collision duration (<=0 -> auto 5*dt) + real(WP) :: e_n=0.7_WP,e_w=0.7_WP !< restitution (p-p, wall) + real(WP) :: clip_col =0.2_WP !< overlap clip fraction + integer, dimension(3) :: lo_bc=PD_OPEN,hi_bc=PD_OPEN !< per-face: PD_OPEN or PD_WALL + real(WP) :: cskin =0.0_WP !< broad-phase skin (<=0 -> auto 0.5*contact_dist) + type(pdhalo) :: chalo !< contact halo (rebuilt at trigger cadence; nown=ntot) + integer :: nchalo=0 !< contact slots (y/v extended to ntot+nchalo) + integer, allocatable :: cptr(:),clst(:) !< candidate CSR (owned rows; entries index owned+contact slots) + real(WP), allocatable :: ylast(:,:) !< (3,nown) positions at last broad-phase build + + ! Node state -- flat per-field arrays; owned first, halo slots appended. + ! (3,:) fields are xyz-interleaved per node (Fortran-natural gather layout). + integer(I8), allocatable :: gid(:) !< (ntot) global id (halo slots carry partner gid) + real(WP), allocatable :: x0(:,:) !< (3,ntot) reference position; halo PRE-SHIFTED + real(WP), allocatable :: y(:,:) !< (3,ntot) current position; halo shifted at update + real(WP), allocatable :: v(:,:) !< (3,nown) velocity + real(WP), allocatable :: f(:,:) !< (3,ntot) bond force density (halo = scatter buffer) + real(WP), allocatable :: ff(:,:) !< (3,nown) external (fluid) force density + real(WP), allocatable :: vol(:) !< (ntot) per-node volume (reference; halo slots filled at connect) + real(WP), allocatable :: mw(:) !< (nown) weighted volume (reference, set at connect) + real(WP), allocatable :: theta(:) !< (nown) dilatation (recomputed each substep) + real(WP), allocatable :: damage(:) !< (nown) accumulated damage fraction (broken/reference bonds) + real(WP), allocatable :: lam_p(:) !< (nown) accumulated equivalent plastic strain (J2 path; drives hardening, free diagnostic when hard_mod=0) + real(WP), allocatable :: alive(:) !< (ntot) 1=alive, 0=dead (exit through open face); halo-exchanged on death events only + integer, allocatable :: flag(:) !< (nown) motion-control flags + logical :: watch_exit=.false. !< exit detection active (set at connect: domain set + any open non-periodic face) + + ! CSR families (built once at connect) + integer, allocatable :: ptr(:) !< (nown+1) row offsets + integer, allocatable :: lst(:) !< neighbor index (1..ntot) per half-entry + integer(1), allocatable :: dmg(:) !< per half-entry: 0 intact, 1 broken (irreversible) + real(WP), allocatable :: e_v(:) !< per half-entry: inelastic deviatoric stretch (per-side history) + real(WP), allocatable :: td2(:),td2a(:) !< (nown) J2 family deviatoric norm^2: previous substep / accumulator. + !< Node-centered => pure own-row gather, NO communication (amrpd + !< needed sum_ghosts_td2 + ghost refresh for the same quantity). + + ! Parallel machinery + type(gid_hash) :: ohash !< gid -> owned index (built at set_nodes) + type(pddir) :: dir !< persistent gid directory (owner lookups; registered at connect/read_state) + type(pdhalo) :: halo !< persistent halo plan + real(WP), allocatable :: rextra_tmp(:,:) !< read_state scratch (restart-field overlay across assemble) + + ! Monitoring + real(WP) :: Umin=0.0_WP,Umax=0.0_WP !< signed per-component velocity extrema + real(WP) :: Vmin=0.0_WP,Vmax=0.0_WP !< over live nodes (get_info) + real(WP) :: Wmin=0.0_WP,Wmax=0.0_WP + real(WP) :: EPmax=0.0_WP !< max accumulated equivalent plastic strain (get_info) + real(WP) :: CFLe=0.0_WP,CFLp=0.0_WP !< elastic-wave / convective CFL (get_cfl) + integer(I8) :: nbroken=0 !< global broken half-entry count (internal) + integer(I8) :: nb_broken=0 !< global broken BOND count (exact census, get_info) + integer(I8) :: nb=0 !< global bond count (exact census, stamped at assemble) + integer(I8) :: nrebuild=0 !< broad-phase rebuild count (cumulative) + integer(I8) :: nchalo_glob=0 !< global contact-slot count (get_info) + integer(I8) :: ncand_glob=0 !< global contact-candidate count (get_info) + + ! Per-rank phase timers (accumulated in advance; reduced+reset in get_info) + real(WP) :: wt_kick=0.0_WP,wt_halo=0.0_WP,wt_dil=0.0_WP,wt_force=0.0_WP,wt_reduce=0.0_WP + real(WP) :: wt_contact=0.0_WP,wt_broad=0.0_WP + real(WP) :: wtmax_kick=0.0_WP,wtmax_halo=0.0_WP,wtmax_dil=0.0_WP,wtmax_force=0.0_WP,wtmax_reduce=0.0_WP + real(WP) :: wtmax_contact=0.0_WP,wtmax_broad=0.0_WP + real(WP) :: wtmin_dil=0.0_WP,wtmin_force=0.0_WP + + contains + procedure :: set_nodes + procedure :: connect + procedure :: detect_families + procedure :: advance + procedure :: exchange + procedure :: query_owners + procedure :: write_state + procedure :: read_state + procedure :: get_cfl + procedure :: get_info + procedure :: finalize + procedure, private :: derive_config + procedure, private :: lps_coefs + procedure, private :: compute_mw + procedure, private :: contact_broadphase + procedure, private :: contact_narrow + procedure, private :: assemble + end type pdsolver + +contains + + + !> Resolve derived configuration: s0 from fail_stretch/crit_energy, contact + !> reach default. Called by every network-building entry point (connect, + !> detect_families, read_state) so fresh init and restart share one path. + subroutine derive_config(this) + use messager, only: die + implicit none + class(pdsolver), intent(inout) :: this + real(WP) :: K_bulk + if (this%rho.le.0.0_WP.or.this%elastic_modulus.le.0.0_WP.or. & + & this%delta.le.0.0_WP.or.this%dV.le.0.0_WP) & + & call die('[pdsolver] material/discretization not configured (need rho, elastic_modulus, delta, dV > 0)') + if (this%fail_stretch.lt.huge(1.0_WP)) then + this%s0=this%fail_stretch + else if (this%crit_energy.gt.0.0_WP.and.this%crit_energy.lt.huge(1.0_WP)) then + ! Silling-Askari bond-energy argument, generalized to the active + ! influence function: G_c = (9/4)*K*s0^2*Iw4/Iw3 (w=1 recovers the + ! classical s0 = sqrt(5*G_c/(9*K*delta))) + K_bulk=this%elastic_modulus/(3.0_WP*(1.0_WP-2.0_WP*this%poisson_ratio)) + this%s0=sqrt(4.0_WP*this%crit_energy*wmoment(this%delta,3,1)/(9.0_WP*K_bulk*wmoment(this%delta,4,1))) + end if + if (this%use_contact.and.this%contact_dist.le.0.0_WP) this%contact_dist=0.9_WP*this%dV**(1.0_WP/3.0_WP) + end subroutine derive_config + + !> Load this rank's owned nodes (any distribution; it becomes the static + !> partition). Builds the gid->index hash used by connect and the halo plan. + !> vol is the per-node volume (pass a constant-filled array for a uniform + !> lattice; kernels use it per neighbor, Peridigm-style). + subroutine set_nodes(this,n,gids,pos,vel,flags,vol) + implicit none + class(pdsolver), intent(inout) :: this + integer, intent(in) :: n + integer(I8), intent(in) :: gids(:) + real(WP), intent(in) :: pos(:,:),vel(:,:) + integer, intent(in) :: flags(:) + real(WP), intent(in) :: vol(:) + integer :: i + this%nown=n + this%nhalo=0 + this%ntot=n + allocate(this%gid(max(n,1)),this%x0(3,max(n,1)),this%y(3,max(n,1))) + allocate(this%v(3,max(n,1)),this%f(3,max(n,1)),this%ff(3,max(n,1))) + allocate(this%mw(max(n,1)),this%theta(max(n,1)),this%flag(max(n,1))) + allocate(this%vol(max(n,1)),this%damage(max(n,1)),this%lam_p(max(n,1))) + do i=1,n + this%gid(i) =gids(i) + this%x0(:,i)=pos(:,i) + this%y(:,i) =pos(:,i) + this%v(:,i) =vel(:,i) + this%flag(i)=flags(i) + this%vol(i) =vol(i) + end do + this%f=0.0_WP; this%ff=0.0_WP; this%mw=0.0_WP; this%theta=0.0_WP; this%damage=0.0_WP; this%lam_p=0.0_WP + call this%ohash%build(n,gids(1:n)) + end subroutine set_nodes + + !> Build the static CSR families and the halo plan from a distributed bond + !> list (this rank passes the bonds it holds; any distribution is fine -- + !> half-entries are routed to their node's owner through the gid directory). + !> Collective. bkey packs the periodic image offset of the HI endpoint in + !> amrpd's hist1 convention. Self-image bonds (gid_lo==gid_hi) yield ONE + !> half-entry (the opposite-image bond exists separately in the input, exactly + !> as amrpd stores them). + subroutine connect(this,nb,bgid_lo,bgid_hi,bkey) + use parallel, only: comm,nproc + use messager, only: die + use mpi_f08 + implicit none + class(pdsolver), intent(inout) :: this + integer, intent(in) :: nb + integer(I8), intent(in) :: bgid_lo(:),bgid_hi(:) + integer, intent(in) :: bkey(:) + integer(I8), allocatable :: hnode(:),hnbr(:),rnode(:),rnbr(:) + integer, allocatable :: hkey(:),howner(:),rkey(:) + real(WP), allocatable :: rev(:) + integer(1), allocatable :: rdmg(:) + integer :: nhe,rn,i,ib,ierr + + ! Resolve derived configuration (restart-safe shared path) + call this%derive_config() + + ! Distributed gid directory over the node partition (persistent: also + ! serves owner queries for face-tag restamping after restart) + call this%dir%finalize() + call this%dir%register(this%nown,this%gid(1:this%nown)) + + ! Expand bonds into half-entries (one per endpoint row; one total for + ! self-image bonds -- see header) + nhe=0 + do ib=1,nb + nhe=nhe+1 + if (bgid_lo(ib).ne.bgid_hi(ib)) nhe=nhe+1 + end do + allocate(hnode(max(nhe,1)),hnbr(max(nhe,1)),hkey(max(nhe,1)),howner(max(nhe,1))) + nhe=0 + do ib=1,nb + nhe=nhe+1 + hnode(nhe)=bgid_lo(ib); hnbr(nhe)=bgid_hi(ib); hkey(nhe)=bkey(ib) + if (bgid_lo(ib).ne.bgid_hi(ib)) then + nhe=nhe+1 + hnode(nhe)=bgid_hi(ib); hnbr(nhe)=bgid_lo(ib); hkey(nhe)=negkey(bkey(ib)) + end if + end do + + ! Route each half-entry to the rank owning its node + call this%dir%query(nhe,hnode,howner) + route_entries: block + integer, dimension(0:nproc-1) :: sc,rc,sd,rd + integer, allocatable :: pos(:) + integer(I8), allocatable :: s8(:) + integer, allocatable :: s4(:) + integer :: r,h + sc=0 + do i=1,nhe + sc(howner(i))=sc(howner(i))+1 + end do + call MPI_ALLTOALL(sc,1,MPI_INTEGER,rc,1,MPI_INTEGER,comm,ierr) + sd(0)=0; rd(0)=0 + do r=1,nproc-1 + sd(r)=sd(r-1)+sc(r-1); rd(r)=rd(r-1)+rc(r-1) + end do + rn=sum(rc) + allocate(rnode(max(rn,1)),rnbr(max(rn,1)),rkey(max(rn,1))) + allocate(pos(0:nproc-1),s8(max(nhe,1)),s4(max(nhe,1))) + ! node gids + pos=sd + do i=1,nhe + h=howner(i); pos(h)=pos(h)+1; s8(pos(h))=hnode(i) + end do + call MPI_ALLTOALLV(s8,sc,sd,MPI_INTEGER8,rnode,rc,rd,MPI_INTEGER8,comm,ierr) + ! neighbor gids + pos=sd + do i=1,nhe + h=howner(i); pos(h)=pos(h)+1; s8(pos(h))=hnbr(i) + end do + call MPI_ALLTOALLV(s8,sc,sd,MPI_INTEGER8,rnbr,rc,rd,MPI_INTEGER8,comm,ierr) + ! image keys + pos=sd + do i=1,nhe + h=howner(i); pos(h)=pos(h)+1; s4(pos(h))=hkey(i) + end do + call MPI_ALLTOALLV(s4,sc,sd,MPI_INTEGER,rkey,rc,rd,MPI_INTEGER,comm,ierr) + deallocate(pos,s8,s4) + end block route_entries + deallocate(hnode,hnbr,hkey,howner) + + ! Fresh bonds carry zero inelastic state + allocate(rev(max(rn,1)),rdmg(max(rn,1))) + rev=0.0_WP; rdmg=0_1 + call this%assemble(rn,rnode,rnbr,rkey,rev,rdmg) + deallocate(rnode,rnbr,rkey,rev,rdmg) + end subroutine connect + + + !> Build the bond families directly from the REFERENCE configuration -- no + !> amrpd bond container, no bond expansion: distributed neighbor discovery + !> at radius delta (bounds allgather + per-(rank,image-offset) offers of + !> shifted x0, contact-broadphase pattern), then each owned row's + !> half-entries are generated straight from the binned candidates and fed + !> to assemble with zero inelastic state. Acceptance test r2 <= delta^2 + !> matches amrpd bond_init exactly. Collective; call after set_nodes. + subroutine detect_families(this) + use parallel, only: comm,rank,nproc,amRoot,MPI_REAL_WP + use messager, only: log,die + use string, only: str_long + use mpi_f08 + implicit none + class(pdsolver), intent(inout) :: this + real(WP), dimension(3) :: bl,bh,shift,pos_s,gl,hcell + real(WP), allocatable :: allb(:,:),opos(:,:),rpos(:,:),cpos(:,:) + integer(I8), allocatable :: ogid(:),rgid(:),cgid(:),hnode(:),hnbr(:) + integer, allocatable :: okey(:),rkey(:),ckey(:),hkey(:),head(:),nxt(:) + real(WP), allocatable :: rev(:) + integer(1), allocatable :: rdmg(:) + integer, dimension(0:nproc-1) :: sc,rc,sd,rd,sc3,rc3,sd3,rd3 + integer, dimension(3) :: nmax,nc + integer :: d,r,n1,n2,n3,i,k,m,noff,nrecv,ncand,nhe,pass,ic,jc,kc,c1,c2,c3,ierr + character(len=str_long) :: message + + ! Resolve derived configuration (restart-safe shared path) + call this%derive_config() + + ! Directory over the node partition (persistent) + call this%dir%finalize() + call this%dir%register(this%nown,this%gid(1:this%nown)) + + ! Owned reference bounds, exchanged globally + bl=huge(1.0_WP); bh=-huge(1.0_WP) + do i=1,this%nown + bl=min(bl,this%x0(:,i)); bh=max(bh,this%x0(:,i)) + end do + allocate(allb(6,0:nproc-1)) + call MPI_ALLGATHER([bl,bh],6,MPI_REAL_WP,allb,6,MPI_REAL_WP,comm,ierr) + do d=1,3 + nmax(d)=0 + if (this%per(d).and.this%Ldom(d).gt.0.0_WP) nmax(d)=min(4,int(this%delta/this%Ldom(d))+1) + end do + + ! Offers of shifted reference positions (two passes: count, fill) + do pass=1,2 + sc=0 + do r=0,nproc-1 + do n3=-nmax(3),nmax(3); do n2=-nmax(2),nmax(2); do n1=-nmax(1),nmax(1) + if (r.eq.rank.and.n1.eq.0.and.n2.eq.0.and.n3.eq.0) cycle + shift=[real(n1,WP)*this%Ldom(1),real(n2,WP)*this%Ldom(2),real(n3,WP)*this%Ldom(3)] + if (any(bl+shift-this%delta.gt.allb(4:6,r)).or.any(bh+shift+this%delta.lt.allb(1:3,r))) cycle + do i=1,this%nown + pos_s=this%x0(:,i)+shift + if (any(pos_s.lt.allb(1:3,r)-this%delta).or.any(pos_s.gt.allb(4:6,r)+this%delta)) cycle + sc(r)=sc(r)+1 + if (pass.eq.2) then + ogid(sd(r)+sc(r))=this%gid(i) + okey(sd(r)+sc(r))=(n1+128)+(n2+128)*256+(n3+128)*65536 + opos(:,sd(r)+sc(r))=pos_s + end if + end do + end do; end do; end do + end do + if (pass.eq.1) then + sd(0)=0 + do r=1,nproc-1 + sd(r)=sd(r-1)+sc(r-1) + end do + noff=sum(sc) + allocate(ogid(max(noff,1)),okey(max(noff,1)),opos(3,max(noff,1))) + end if + end do + call MPI_ALLTOALL(sc,1,MPI_INTEGER,rc,1,MPI_INTEGER,comm,ierr) + rd(0)=0 + do r=1,nproc-1 + rd(r)=rd(r-1)+rc(r-1) + end do + nrecv=sum(rc) + allocate(rgid(max(nrecv,1)),rkey(max(nrecv,1)),rpos(3,max(nrecv,1))) + call MPI_ALLTOALLV(ogid,sc,sd,MPI_INTEGER8,rgid,rc,rd,MPI_INTEGER8,comm,ierr) + call MPI_ALLTOALLV(okey,sc,sd,MPI_INTEGER, rkey,rc,rd,MPI_INTEGER, comm,ierr) + sc3=3*sc; sd3=3*sd; rc3=3*rc; rd3=3*rd + call MPI_ALLTOALLV(opos,sc3,sd3,MPI_REAL_WP,rpos,rc3,rd3,MPI_REAL_WP,comm,ierr) + deallocate(ogid,okey,opos) + + ! Candidate set = owned nodes (zero offset) + received offers + ncand=this%nown+nrecv + allocate(cgid(max(ncand,1)),ckey(max(ncand,1)),cpos(3,max(ncand,1))) + do i=1,this%nown + cgid(i)=this%gid(i); ckey(i)=PDHALO_KEY0; cpos(:,i)=this%x0(:,i) + end do + do i=1,nrecv + cgid(this%nown+i)=rgid(i); ckey(this%nown+i)=rkey(i); cpos(:,this%nown+i)=rpos(:,i) + end do + deallocate(rgid,rkey,rpos) + + ! Bin candidates; generate each owned row directly (two passes) + bl=huge(1.0_WP); bh=-huge(1.0_WP) + do m=1,ncand + bl=min(bl,cpos(:,m)); bh=max(bh,cpos(:,m)) + end do + call setup_bins(bl,bh,this%delta,gl,hcell,nc) + allocate(head(nc(1)*nc(2)*nc(3)),nxt(max(ncand,1))) + head=0 + do m=1,ncand + k=cell_of(cpos(:,m),gl,hcell,nc) + nxt(m)=head(k); head(k)=m + end do + do pass=1,2 + nhe=0 + do i=1,this%nown + ic=min(nc(1),max(1,int((this%x0(1,i)-gl(1))/hcell(1))+1)) + jc=min(nc(2),max(1,int((this%x0(2,i)-gl(2))/hcell(2))+1)) + kc=min(nc(3),max(1,int((this%x0(3,i)-gl(3))/hcell(3))+1)) + do c3=max(1,kc-1),min(nc(3),kc+1); do c2=max(1,jc-1),min(nc(2),jc+1); do c1=max(1,ic-1),min(nc(1),ic+1) + m=head(c1+nc(1)*(c2-1)+nc(1)*nc(2)*(c3-1)) + do while (m.gt.0) + if (m.ne.i) then + if (sum((cpos(:,m)-this%x0(:,i))**2).le.this%delta**2) then + nhe=nhe+1 + if (pass.eq.2) then + hnode(nhe)=this%gid(i) + hnbr(nhe) =cgid(m) + hkey(nhe) =ckey(m) + end if + end if + end if + m=nxt(m) + end do + end do; end do; end do + end do + if (pass.eq.1) allocate(hnode(max(nhe,1)),hnbr(max(nhe,1)),hkey(max(nhe,1))) + end do + deallocate(cgid,ckey,cpos,head,nxt,allb) + + ! Assemble with zero inelastic state (entries are already local rows) + allocate(rev(max(nhe,1)),rdmg(max(nhe,1))) + rev=0.0_WP; rdmg=0_1 + call this%assemble(nhe,hnode,hnbr,hkey,rev,rdmg) + deallocate(hnode,hnbr,hkey,rev,rdmg) + if (amRoot) then + write(message,'("[",a,"] detect_families: ",i0," half-entries (~2x bonds)")') trim(this%name),this%nbond + call log(message) + end if + end subroutine detect_families + + !> Assemble the CSR families, halo plan, and reference state from LOCAL + !> half-entry arrays (already routed to this rank: every entry's node gid is + !> owned here). Per-entry inelastic state (dmg, e_v) travels with the + !> entries -- zeros for a fresh connect, loaded values on restart. Shared by + !> connect and read_state; collective. + subroutine assemble(this,rn,rnode,rnbr,rkey,rev,rdmg) + use parallel, only: comm,nproc + use messager, only: die + use mpi_f08 + implicit none + class(pdsolver), intent(inout) :: this + integer, intent(in) :: rn + integer(I8), intent(in) :: rnode(:),rnbr(:) + integer, intent(in) :: rkey(:) + real(WP), intent(in) :: rev(:) + integer(1), intent(in) :: rdmg(:) + integer, allocatable :: ridx(:),perm(:) + integer :: i,s,ierr + + if (allocated(this%ptr)) deallocate(this%ptr) + if (allocated(this%lst)) deallocate(this%lst) + if (allocated(this%dmg)) deallocate(this%dmg) + if (allocated(this%e_v)) deallocate(this%e_v) + if (allocated(this%td2)) deallocate(this%td2) + if (allocated(this%td2a)) deallocate(this%td2a) + + ! Resolve each received entry's node to an owned index + allocate(ridx(max(rn,1)),perm(max(rn,1))) + do i=1,rn + ridx(i)=this%ohash%lookup(rnode(i)) + if (ridx(i).lt.1) call die('[pdsolver assemble] half-entry routed to a rank that does not own its node') + perm(i)=i + end do + + ! Deterministic CSR order: sort by (node index, neighbor gid, image key) + if (rn.gt.1) call sort3_perm(ridx,rnbr,rkey,perm,1,rn) + + ! Row pointers + allocate(this%ptr(this%nown+1)) + row_pointers: block + integer, allocatable :: cnt(:) + allocate(cnt(this%nown)); cnt=0 + do i=1,rn + cnt(ridx(i))=cnt(ridx(i))+1 + end do + this%ptr(1)=1 + do i=1,this%nown + this%ptr(i+1)=this%ptr(i)+cnt(i) + end do + deallocate(cnt) + end block row_pointers + + ! Classify entries (owned direct vs halo reference), dedupe references, + ! build the halo plan, and finalize the CSR neighbor indices + build_refs_and_halo: block + integer(I8), allocatable :: refgid(:),ugid(:) + integer, allocatable :: refkey(:),refpos(:),rperm(:),zeros(:) + integer, allocatable :: ukey(:),uowner(:),uslot(:) + integer :: nref,nuniq,lid,u + allocate(this%lst(max(rn,1))) + allocate(this%dmg(max(rn,1))); this%dmg=0_1 + allocate(this%e_v(max(rn,1))); this%e_v=0.0_WP + ! Per-entry inelastic state follows the deterministic CSR order + do s=1,rn + this%dmg(s)=rdmg(perm(s)) + this%e_v(s)=rev(perm(s)) + end do + allocate(this%td2(max(this%nown,1)),this%td2a(max(this%nown,1))) + this%td2=0.0_WP; this%td2a=0.0_WP + allocate(refgid(max(rn,1)),refkey(max(rn,1)),refpos(max(rn,1))) + nref=0 + do s=1,rn + i=perm(s) + if (rkey(i).eq.PDHALO_KEY0) then + lid=this%ohash%lookup(rnbr(i)) + if (lid.ge.1) then + this%lst(s)=lid ! owned, zero image offset: direct index + cycle + end if + end if + nref=nref+1 + refgid(nref)=rnbr(i); refkey(nref)=rkey(i); refpos(nref)=s + end do + ! Unique (gid,key) references, deterministic order + allocate(rperm(max(nref,1)),zeros(max(nref,1))) + zeros=0 + do i=1,nref + rperm(i)=i + end do + if (nref.gt.1) call sort3_perm(zeros,refgid,refkey,rperm,1,nref) + allocate(ugid(max(nref,1)),ukey(max(nref,1))) + nuniq=0 + do s=1,nref + i=rperm(s) + if (s.eq.1) then + nuniq=1; ugid(1)=refgid(i); ukey(1)=refkey(i) + else if (refgid(i).ne.refgid(rperm(s-1)).or.refkey(i).ne.refkey(rperm(s-1))) then + nuniq=nuniq+1; ugid(nuniq)=refgid(i); ukey(nuniq)=refkey(i) + end if + this%lst(refpos(i))=-nuniq ! provisional: -(unique ref id) + end do + ! Owners of the unique references, then the persistent halo plan + allocate(uowner(max(nuniq,1)),uslot(max(nuniq,1))) + call this%dir%query(nuniq,ugid,uowner) + call this%halo%build(this%nown,this%ohash,nuniq,ugid,ukey,uowner,this%Ldom,this%per,uslot) + this%nhalo=this%halo%nhalo + this%ntot=this%nown+this%nhalo + ! Finalize CSR: provisional negatives -> halo slot indices + do s=1,rn + if (this%lst(s).lt.0) this%lst(s)=this%nown+uslot(-this%lst(s)) + end do + ! Extend node arrays to include halo slots; stamp halo gids + extend_arrays: block + integer(I8), allocatable :: g2(:) + real(WP), allocatable :: a2(:,:) + allocate(g2(max(this%ntot,1))); g2(1:this%nown)=this%gid(1:this%nown) + do u=1,nuniq + g2(this%nown+uslot(u))=ugid(u) + end do + call move_alloc(g2,this%gid) + allocate(a2(3,max(this%ntot,1))); a2=0.0_WP; a2(:,1:this%nown)=this%x0(:,1:this%nown) + call move_alloc(a2,this%x0) + allocate(a2(3,max(this%ntot,1))); a2=0.0_WP; a2(:,1:this%nown)=this%y(:,1:this%nown) + call move_alloc(a2,this%y) + allocate(a2(3,max(this%ntot,1))); a2=0.0_WP; a2(:,1:this%nown)=this%f(:,1:this%nown) + call move_alloc(a2,this%f) + extend_volume: block + real(WP), allocatable :: v2(:) + allocate(v2(max(this%ntot,1))); v2=0.0_WP; v2(1:this%nown)=this%vol(1:this%nown) + call move_alloc(v2,this%vol) + end block extend_volume + end block extend_arrays + deallocate(refgid,refkey,refpos,rperm,zeros,ugid,ukey,uowner,uslot) + end block build_refs_and_halo + deallocate(ridx,perm) + + ! Fill halo reference positions ONCE, pre-shifted by the image offsets + ! (x0 is static; this is the only x0 exchange of the entire run), and + ! the halo per-node volumes (also static) + call this%halo%update(this%x0,3,shifted=.true.) + call this%halo%update1(this%vol) + this%y(:,this%nown+1:this%ntot)=this%x0(:,this%nown+1:this%ntot) + + ! Life status (exit-through-open-face handling). Exchanged over the halo + ! ONLY on substeps where a death occurs somewhere; steady state is free. + if (allocated(this%alive)) deallocate(this%alive) + allocate(this%alive(max(this%ntot,1))); this%alive=1.0_WP + this%watch_exit=(this%dom_hi(1).gt.this%dom_lo(1)).and. & + & any((.not.this%per).and.(this%lo_bc.eq.0.or.this%hi_bc.eq.0)) + + ! Stamp the reference weighted volume + call this%compute_mw() + + ! Silling-Askari critical time step (Peridigm form, 3D bond-based + ! micromodulus c(z) = c0*w(z), c0 = 9K/(2*pi*Iw3); w=1 recovers the + ! classical 18K/(pi*delta^4)): + ! dt_crit_i = sqrt(2*rho / sum_family(V_j * c(zeta) / zeta)), global min. + ! DIAGNOSTIC only for now -- reported at init, does not bind dt. The + ! micromodulus constant is 3D-based; in quasi-2D slabs treat it as + ! indicative. + critical_dt: block + use mathtools, only: Pi + use messager, only: log + use string, only: str_long + use parallel, only: amRoot,MPI_REAL_WP + real(WP) :: K_bulk,c0,denom,zeta,dtc + character(len=str_long) :: message + integer :: i,e,j + K_bulk=this%elastic_modulus/(3.0_WP*(1.0_WP-2.0_WP*this%poisson_ratio)) + c0=9.0_WP*K_bulk/(2.0_WP*Pi*wmoment(this%delta,3,1)) + dtc=huge(1.0_WP) + do i=1,this%nown + denom=0.0_WP + do e=this%ptr(i),this%ptr(i+1)-1 + j=this%lst(e) + zeta=sqrt(sum((this%x0(:,j)-this%x0(:,i))**2)) + if (zeta.gt.0.0_WP) denom=denom+this%vol(j)*c0*omega(zeta,this%delta)/zeta + end do + if (denom.gt.0.0_WP) dtc=min(dtc,sqrt(2.0_WP*this%rho/denom)) + end do + call MPI_ALLREDUCE(MPI_IN_PLACE,dtc,1,MPI_REAL_WP,MPI_MIN,comm,ierr) + this%dtcrit=dtc + if (amRoot) then + write(message,'("[",a,"] Silling-Askari critical dt = ",es12.5," (diagnostic)")') trim(this%name),this%dtcrit + call log(message) + end if + end block critical_dt + + ! Global half-entry count for logging (= 2*bonds - self-image bonds) + count_bonds: block + use parallel, only: comm + integer(I8) :: nhe8 + nhe8=int(rn,I8) + call MPI_ALLREDUCE(MPI_IN_PLACE,nhe8,1,MPI_INTEGER8,MPI_SUM,comm,ierr) + this%nbond=nhe8 ! total half-entries; = 2*bonds - self-image bonds + ! Exact bond census (lower-gid rule; positive-offset self-images) + count_nb: block + integer :: i2,e2,j2 + this%nb=0_I8 + do i2=1,this%nown + do e2=this%ptr(i2),this%ptr(i2+1)-1 + j2=this%lst(e2) + if (this%gid(i2).lt.this%gid(j2)) then + this%nb=this%nb+1_I8 + else if (this%gid(i2).eq.this%gid(j2).and.j2.gt.this%nown) then + if (shift_positive(this%halo%shift(:,j2-this%nown))) this%nb=this%nb+1_I8 + end if + end do + end do + call MPI_ALLREDUCE(MPI_IN_PLACE,this%nb,1,MPI_INTEGER8,MPI_SUM,comm,ierr) + end block count_nb + end block count_bonds + end subroutine assemble + + !> Weighted volume: mw_i = sum_family w(zeta)*zeta^2*V_j (reference state; + !> never updated by damage) + subroutine compute_mw(this) + implicit none + class(pdsolver), intent(inout) :: this + integer :: i,e,j + real(WP) :: zeta + do i=1,this%nown + this%mw(i)=0.0_WP + do e=this%ptr(i),this%ptr(i+1)-1 + j=this%lst(e) + zeta=sqrt(sum((this%x0(:,j)-this%x0(:,i))**2)) + this%mw(i)=this%mw(i)+omega(zeta,this%delta)*zeta**2*this%vol(j) + end do + end do + end subroutine compute_mw + + !> Dimension-aware LPS constitutive coefficients (omega-independent: mw + !> absorbs the influence function). psi_fac sets the J2 yield threshold on + !> the family deviatoric force-state norm -- yield when + !> ||t_dev||^2 > psi_fac*sigma_yield^2/mw (Mitchell OSB) -- and DOES depend + !> on omega: since td ~ w, the norm scales by the w^2/w moment ratio + !> (int w^2 z^p / int w z^p, p=4 in 3D, 3 in 2D; ratio = 1 for w=1). + subroutine lps_coefs(this,fdim,coef_vol,coef_dev,psi_fac) + implicit none + class(pdsolver), intent(in) :: this + real(WP), intent(out) :: fdim,coef_vol,coef_dev + real(WP), intent(out), optional :: psi_fac + real(WP) :: K_bulk,mu_shear + integer :: ndim + ndim=3-count(this%collapsed) + K_bulk =this%elastic_modulus/(3.0_WP*(1.0_WP-2.0_WP*this%poisson_ratio)) + mu_shear=this%elastic_modulus/(2.0_WP*(1.0_WP+this%poisson_ratio)) + select case (ndim) + case (3) + fdim=3.0_WP; coef_vol=3.0_WP*K_bulk; coef_dev=15.0_WP*mu_shear + if (present(psi_fac)) psi_fac=5.0_WP*wmoment(this%delta,4,2)/wmoment(this%delta,4,1) + case (2) + fdim=2.0_WP; coef_vol=2.0_WP*(K_bulk+mu_shear/3.0_WP); coef_dev= 8.0_WP*mu_shear + if (present(psi_fac)) psi_fac=8.0_WP/3.0_WP*wmoment(this%delta,3,2)/wmoment(this%delta,3,1) + case default + fdim=1.0_WP; coef_vol=this%elastic_modulus; coef_dev= 0.0_WP + if (present(psi_fac)) psi_fac=0.0_WP + end select + end subroutine lps_coefs + + !> Velocity-Verlet step: half-kick + drift, halo position update, + !> dilatation gather, node-centered force sweep, halo force reduce, + !> contact, second half-kick. + subroutine advance(this,dt) + use parallel, only: parallel_time + implicit none + class(pdsolver), intent(inout) :: this + real(WP), intent(in) :: dt + real(WP) :: rho_inv,fdim,cvol,cdev,t0 + real(WP) :: zeta,dY,e_b,t,w + real(WP) :: psi_fac,decay,e_d,td,beta,e_e,over + real(WP) :: sYe2,strial,mu3i + logical :: plastic,do_j2 + real(WP), dimension(3) :: acc,dxv,fx + integer :: i,e,j + + rho_inv=1.0_WP/this%rho + call this%lps_coefs(fdim,cvol,cdev,psi_fac) + ! Viscoplastic setup: decay is loop-invariant (exact exponential update, + ! unconditionally stable -- no viscous CFL) + plastic=(this%tau.gt.0.0_WP.and.this%tau.lt.huge(1.0_WP)) + do_j2=(this%sigma_yield.gt.0.0_WP) + decay=0.0_WP + if (plastic) decay=exp(-dt/this%tau) + mu3i=2.0_WP*(1.0_WP+this%poisson_ratio)/(3.0_WP*this%elastic_modulus) ! 1/(3*mu_shear) + + ! First half-kick and drift (owned nodes) + t0=parallel_time() + do i=1,this%nown + if (this%flag(i).eq.PDC_IS_DEAD) cycle + acc=this%gravity+(this%f(:,i)+this%ff(:,i))*rho_inv + if (iand(this%flag(i),PDC_INTEGRATES).ne.0) this%v(:,i)=this%v(:,i)+0.5_WP*dt*acc + if (this%collapsed(1)) this%v(1,i)=0.0_WP + if (this%collapsed(2)) this%v(2,i)=0.0_WP + if (this%collapsed(3)) this%v(3,i)=0.0_WP + if (iand(this%flag(i),PDC_MOVES).ne.0) this%y(:,i)=this%y(:,i)+dt*this%v(:,i) + end do + this%wt_kick=this%wt_kick+(parallel_time()-t0) + + ! Exit handling: nodes drifting out through an OPEN non-periodic face die + ! (amrpd drops them at Redistribute; here they are flagged and muted). + ! The death-count allreduce runs only when exits are possible at all, and + ! the mute propagation only on substeps where a death actually occurred. + if (this%watch_exit) then + death_watch: block + use parallel, only: comm + use mpi_f08, only: MPI_ALLREDUCE,MPI_IN_PLACE,MPI_SUM,MPI_INTEGER + integer :: nd,d,e,ierr + logical :: out + nd=0 + do i=1,this%nown + if (this%flag(i).eq.PDC_IS_DEAD) cycle + out=.false. + do d=1,3 + if (this%per(d)) cycle + if (this%lo_bc(d).eq.0.and.this%y(d,i).lt.this%dom_lo(d)) out=.true. + if (this%hi_bc(d).eq.0.and.this%y(d,i).gt.this%dom_hi(d)) out=.true. + end do + if (out) then + this%flag(i)=PDC_IS_DEAD + this%v(:,i)=0.0_WP + this%alive(i)=0.0_WP + nd=nd+1 + end if + end do + call MPI_ALLREDUCE(MPI_IN_PLACE,nd,1,MPI_INTEGER,MPI_SUM,comm,ierr) + if (nd.gt.0) then + ! Propagate life status to halo slots, then permanently mute + ! every entry touching a dead node (dmg=2: distinct from broken, + ! so damage statistics stay honest -- amrpd does not count + ! dropped-particle bonds as damage either) + call this%halo%update1(this%alive) + do i=1,this%nown + if (this%flag(i).eq.PDC_IS_DEAD) then + do e=this%ptr(i),this%ptr(i+1)-1 + if (this%dmg(e).eq.0_1) this%dmg(e)=2_1 + end do + else + do e=this%ptr(i),this%ptr(i+1)-1 + if (this%dmg(e).eq.0_1.and.this%alive(this%lst(e)).lt.0.5_WP) this%dmg(e)=2_1 + end do + end if + end do + ! Force a contact broad-phase rebuild so no candidate list + ! references a corpse (dead nodes are excluded from offers/bins) + if (this%use_contact.and.allocated(this%ylast)) deallocate(this%ylast) + end if + end block death_watch + end if + + ! Refresh halo positions (owner y -> slots, with image shifts) + t0=parallel_time() + call this%halo%update(this%y,3,shifted=.true.) + this%wt_halo=this%wt_halo+(parallel_time()-t0) + + ! Contact service: displacement-triggered broad phase (rebuilds contact + ! halo + candidate list when cumulative drift exhausts the skin), then + ! per-substep refresh of contact-slot positions AND velocities (the only + ! place velocity crosses ranks; the graph halo never carries it) + if (this%use_contact) then + t0=parallel_time() + call this%contact_broadphase() + this%wt_broad=this%wt_broad+(parallel_time()-t0) + t0=parallel_time() + call this%chalo%update(this%y,3,shifted=.true.) + call this%chalo%update(this%v,3,shifted=.false.) + this%wt_halo=this%wt_halo+(parallel_time()-t0) + end if + + ! Dilatation (pure gather; own family only; broken entries excluded -- + ! breaks happen in the force sweep AFTER this, matching amrpd's ordering) + t0=parallel_time() + do i=1,this%nown + this%theta(i)=0.0_WP + do e=this%ptr(i),this%ptr(i+1)-1 + if (this%dmg(e).ne.0_1) cycle + j=this%lst(e) + zeta=sqrt(sum((this%x0(:,j)-this%x0(:,i))**2)) + dY =sqrt(sum((this%y(:,j) -this%y(:,i) )**2)) + e_b=dY-zeta + this%theta(i)=this%theta(i)+omega(zeta,this%delta)*zeta*e_b*this%vol(j) + end do + if (this%mw(i).gt.0.0_WP) then + this%theta(i)=fdim*this%theta(i)/this%mw(i) + else + this%theta(i)=0.0_WP + end if + end do + this%wt_dil=this%wt_dil+(parallel_time()-t0) + + ! Node-centered force sweep: each row computes its OWN force state t + ! (own theta, own mw) and scatters +t/-t; the neighbor's t arrives from + ! the neighbor's own row (locally or via the halo reduce below). + t0=parallel_time() + this%f=0.0_WP + do i=1,this%nown + if (this%mw(i).le.0.0_WP) cycle + ! Per-node J2 return factor from the LAGGED family norm. With + ! hardening (hard_mod>0) the surface radius grows with the node's + ! accumulated equivalent plastic strain lam_p (surface lagged one + ! substep like the norm: exact to O(H/3mu) per substep, and H<<3mu + ! for metals; stress-space equivalent of Peridigm's + ! elastic_plastic_hardening). The increment uses (1-beta)*strial = + ! the trial-stress excess, so the rate-independent limit matches the + ! classical radial return; (1-decay) is the Perzyna-realized + ! fraction. lam_p accumulates even at hard_mod=0 (free plastic- + ! strain diagnostic; forces unchanged there, bit-exact w/ flat yield). + beta=1.0_WP + if (plastic.and.do_j2) then + sYe2=(this%sigma_yield+this%hard_mod*this%lam_p(i))**2 + if (this%td2(i)*this%mw(i).gt.psi_fac*sYe2) then + beta=sqrt(psi_fac*sYe2/(this%td2(i)*this%mw(i))) + strial=sqrt(this%td2(i)*this%mw(i)/psi_fac) + this%lam_p(i)=this%lam_p(i)+(1.0_WP-beta)*(1.0_WP-decay)*strial*mu3i + end if + end if + do e=this%ptr(i),this%ptr(i+1)-1 + if (this%dmg(e).ne.0_1) cycle + j=this%lst(e) + zeta=sqrt(sum((this%x0(:,j)-this%x0(:,i))**2)) + dxv=this%y(:,j)-this%y(:,i) + dY=sqrt(sum(dxv**2)) + if (dY.le.0.0_WP) cycle + e_b=dY-zeta + ! Brittle break on total stretch (e > s0*zeta), irreversible. + ! Each row breaks its OWN half-entry and increments its OWN node's + ! damage by 1/nb0 (nb0 = reference row length); the counterpart row + ! breaks its half independently -- the criterion is symmetric in + ! the endpoints, so both halves break in the same substep (for + ! image bonds, up to shift-association roundoff: a 1-ulp-marginal + ! bond may break one substep apart, a benign local transient -- + ! the intact half still applies its +/- pair, conserving momentum). + if (e_b.gt.this%s0*zeta) then + this%dmg(e)=1_1 + this%damage(i)=this%damage(i)+1.0_WP/real(this%ptr(i+1)-this%ptr(i),WP) + cycle + end if + w=omega(zeta,this%delta) + ! Deviatoric split: e_d carries this HALF-ENTRY's inelastic stretch + ! e_v (per-side history: own theta, own mw -- Peridigm form; e_v=0 + ! recovers canonical elastic LPS bit-for-bit) + e_d=e_b-this%theta(i)*zeta/fdim + td=w/this%mw(i)*cdev*(e_d-this%visc_lambda*this%e_v(e)) + t =w/this%mw(i)*cvol*this%theta(i)*zeta+td + ! J2 family norm: pure own-row gather (no communication) + if (do_j2) this%td2a(i)=this%td2a(i)+td*td*this%vol(j) + ! Pair contribution from THIS row's force state (Peridigm volumes: + ! +t*V_j to self, -t*V_i to the neighbor) + fx=t*dxv/dY + this%f(:,i)=this%f(:,i)+fx*this%vol(j) + this%f(:,j)=this%f(:,j)-fx*this%vol(i) + ! Per-side viscoplastic flow of e_v (exact exponential). Two yield + ! criteria, as in amrpd: + ! sigma_yield>0: J2 radial return (per-node beta computed at the + ! row head above, incl. isotropic hardening), Perzyna- + ! regularized by (1-decay); tau->0 recovers Peridigm's + ! rate-independent return. + ! else: per-bond overstress (yield_stretch=0 -> pure Maxwell). + if (plastic) then + if (do_j2) then + this%e_v(e)=this%e_v(e)+(1.0_WP-beta)*(e_d-this%e_v(e))*(1.0_WP-decay) + else + e_e=e_d-this%e_v(e) + over=abs(e_e)-this%yield_stretch*zeta + if (over.gt.0.0_WP) this%e_v(e)=this%e_v(e)+sign(over*(1.0_WP-decay),e_e) + end if + end if + end do + end do + ! Publish this substep's J2 norm (read by the NEXT substep's return) + if (do_j2) then + this%td2(1:this%nown)=this%td2a(1:this%nown) + this%td2a(1:this%nown)=0.0_WP + end if + this%wt_force=this%wt_force+(parallel_time()-t0) + + ! Assemble cross-rank pair forces (halo slots -> owners, add) + t0=parallel_time() + call this%halo%reduce(this%f,3) + this%wt_reduce=this%wt_reduce+(parallel_time()-t0) + + ! Short-range contact (walls + particle-particle), gather-only: adds + ! into owned f, no reduction (amrpd ordering: after the bond force) + if (this%use_contact) then + t0=parallel_time() + call this%contact_narrow(dt) + this%wt_contact=this%wt_contact+(parallel_time()-t0) + end if + + ! Second half-kick with the fresh force + t0=parallel_time() + do i=1,this%nown + if (this%flag(i).eq.PDC_IS_DEAD) cycle + if (iand(this%flag(i),PDC_INTEGRATES).ne.0) then + acc=this%gravity+(this%f(:,i)+this%ff(:,i))*rho_inv + this%v(:,i)=this%v(:,i)+0.5_WP*dt*acc + end if + if (this%collapsed(1)) this%v(1,i)=0.0_WP + if (this%collapsed(2)) this%v(2,i)=0.0_WP + if (this%collapsed(3)) this%v(3,i)=0.0_WP + end do + this%wt_kick=this%wt_kick+(parallel_time()-t0) + end subroutine advance + + !> Contact broad phase: displacement-triggered rebuild of the contact halo + !> and the candidate CSR. The trigger is one scalar allreduce per substep so + !> the (collective) rebuild decision is rank-consistent. rbuild = + !> 1.2*contact_dist + 2*cskin: engagement reach is bounded by d_eff*(1+0.2) + !> (the r_influ clip) and two nodes drifting cskin each can close 2*cskin + !> between rebuilds, so the candidate set provably contains every pair that + !> can produce force before the next rebuild. + !> + !> Discovery: allgather of per-rank owned-node bounds; for each (rank, + !> periodic-image offset) whose shifted bounds approach mine within rbuild, + !> OFFER my owned nodes in range as (gid, image key, shifted position). The + !> receiver keeps offers with an owned node within rbuild (binned test) and + !> builds the contact halo from the kept references via the standard pdhalo + !> protocol (chalo%nown = ntot, so contact slots append after graph slots). + !> Candidates are then binned over OWNED + CONTACT slots only -- the graph + !> halo is never binned, so bonded remote partners arrive as contact slots + !> when in range and double-counting is structurally impossible. + subroutine contact_broadphase(this) + use parallel, only: comm,rank,nproc,MPI_REAL_WP + use mpi_f08 + use messager, only: die + implicit none + class(pdsolver), intent(inout) :: this + real(WP) :: rbuild,drift + integer :: i,ierr + + if (this%contact_dist.le.0.0_WP) call die('[pdsolver contact] use_contact requires contact_dist > 0') + if (this%cskin.le.0.0_WP) this%cskin=0.5_WP*this%contact_dist + rbuild=1.2_WP*this%contact_dist+2.0_WP*this%cskin + + ! Displacement trigger (collective decision) + if (allocated(this%ylast)) then + drift=0.0_WP + do i=1,this%nown + drift=max(drift,sum((this%y(:,i)-this%ylast(:,i))**2)) + end do + drift=sqrt(drift) + else + drift=huge(1.0_WP) + end if + call MPI_ALLREDUCE(MPI_IN_PLACE,drift,1,MPI_REAL_WP,MPI_MAX,comm,ierr) + if (drift.le.this%cskin) return + this%nrebuild=this%nrebuild+1_I8 + + rebuild: block + real(WP), dimension(3) :: bl,bh,shift,pos_s + real(WP), allocatable :: allb(:,:),opos(:,:),rpos(:,:),kpos(:,:) + integer(I8), allocatable :: ogid(:),rgid(:),kgid(:) + integer, allocatable :: okey(:),rkey(:),kkey(:),kowner(:),slot(:) + integer, dimension(0:nproc-1) :: sc,rc,sd,rd + integer, dimension(0:nproc-1) :: sc3,rc3,sd3,rd3 + integer :: nmax(3),d,r,n1,n2,n3,noff,nrecv,nkeep,k,pass + ! Binning workspace (owned nodes for offer filtering, then combined + ! set for the candidate CSR) + real(WP), dimension(3) :: gl,hcell + integer, dimension(3) :: nc + integer, allocatable :: head(:),nxt(:) + + ! Owned bounds and their global exchange + bl=huge(1.0_WP); bh=-huge(1.0_WP) + do i=1,this%nown + bl=min(bl,this%y(:,i)); bh=max(bh,this%y(:,i)) + end do + allocate(allb(6,0:nproc-1)) + call MPI_ALLGATHER([bl,bh],6,MPI_REAL_WP,allb,6,MPI_REAL_WP,comm,ierr) + + ! Admissible periodic-image offsets for contact range + do d=1,3 + nmax(d)=0 + if (this%per(d).and.this%Ldom(d).gt.0.0_WP) nmax(d)=min(4,int(rbuild/this%Ldom(d))+1) + end do + + ! Offers: two passes (count, then fill), grouped by destination rank + do pass=1,2 + sc=0 + do r=0,nproc-1 + do n3=-nmax(3),nmax(3); do n2=-nmax(2),nmax(2); do n1=-nmax(1),nmax(1) + if (r.eq.rank.and.n1.eq.0.and.n2.eq.0.and.n3.eq.0) cycle + shift=[real(n1,WP)*this%Ldom(1),real(n2,WP)*this%Ldom(2),real(n3,WP)*this%Ldom(3)] + ! Shifted-bounds proximity prefilter + if (any(bl+shift-rbuild.gt.allb(4:6,r)).or.any(bh+shift+rbuild.lt.allb(1:3,r))) cycle + do i=1,this%nown + if (this%flag(i).eq.PDC_IS_DEAD) cycle + pos_s=this%y(:,i)+shift + if (any(pos_s.lt.allb(1:3,r)-rbuild).or.any(pos_s.gt.allb(4:6,r)+rbuild)) cycle + sc(r)=sc(r)+1 + if (pass.eq.2) then + ogid(sd(r)+sc(r))=this%gid(i) + okey(sd(r)+sc(r))=(n1+128)+(n2+128)*256+(n3+128)*65536 + opos(:,sd(r)+sc(r))=pos_s + end if + end do + end do; end do; end do + end do + if (pass.eq.1) then + sd(0)=0 + do r=1,nproc-1 + sd(r)=sd(r-1)+sc(r-1) + end do + noff=sum(sc) + allocate(ogid(max(noff,1)),okey(max(noff,1)),opos(3,max(noff,1))) + end if + end do + + ! Exchange offers (gid, key, shifted position) + call MPI_ALLTOALL(sc,1,MPI_INTEGER,rc,1,MPI_INTEGER,comm,ierr) + rd(0)=0 + do r=1,nproc-1 + rd(r)=rd(r-1)+rc(r-1) + end do + nrecv=sum(rc) + allocate(rgid(max(nrecv,1)),rkey(max(nrecv,1)),rpos(3,max(nrecv,1))) + call MPI_ALLTOALLV(ogid,sc,sd,MPI_INTEGER8,rgid,rc,rd,MPI_INTEGER8,comm,ierr) + call MPI_ALLTOALLV(okey,sc,sd,MPI_INTEGER, rkey,rc,rd,MPI_INTEGER, comm,ierr) + sc3=3*sc; sd3=3*sd; rc3=3*rc; rd3=3*rd + call MPI_ALLTOALLV(opos,sc3,sd3,MPI_REAL_WP,rpos,rc3,rd3,MPI_REAL_WP,comm,ierr) + deallocate(ogid,okey,opos) + + ! Filter offers: keep those with an owned node within rbuild. + ! Bin owned nodes (cell size >= rbuild so a +/-1 cell sweep suffices; + ! dims clamped so degenerate/huge extents stay bounded). + call setup_bins(bl,bh,rbuild,gl,hcell,nc) + allocate(head(nc(1)*nc(2)*nc(3)),nxt(max(this%nown,1))) + head=0 + do i=1,this%nown + if (this%flag(i).eq.PDC_IS_DEAD) cycle + k=cell_of(this%y(:,i),gl,hcell,nc) + nxt(i)=head(k); head(k)=i + end do + allocate(kgid(max(nrecv,1)),kkey(max(nrecv,1)),kowner(max(nrecv,1)),kpos(3,max(nrecv,1))) + nkeep=0 + do r=0,nproc-1 + do i=rd(r)+1,rd(r)+rc(r) + if (near_owned(rpos(:,i),rbuild,gl,hcell,nc,head,nxt)) then + nkeep=nkeep+1 + kgid(nkeep)=rgid(i); kkey(nkeep)=rkey(i); kowner(nkeep)=r; kpos(:,nkeep)=rpos(:,i) + end if + end do + end do + deallocate(rgid,rkey,rpos,head,nxt) + + ! Rebuild the contact halo (slots append after graph slots: nown=ntot) + call this%chalo%finalize() + allocate(slot(max(nkeep,1))) + call this%chalo%build(this%ntot,this%ohash,nkeep,kgid,kkey,kowner,this%Ldom,this%per,slot) + this%nchalo=this%chalo%nhalo + + ! Extend y and v to cover contact slots; stamp slot positions from the + ! kept offers (current values -- chalo%update refreshes each substep) + resize_state: block + real(WP), allocatable :: a2(:,:) + integer :: ntc + ntc=this%ntot+this%nchalo + allocate(a2(3,max(ntc,1))); a2=0.0_WP + a2(:,1:this%ntot)=this%y(:,1:this%ntot) + call move_alloc(a2,this%y) + allocate(a2(3,max(ntc,1))); a2=0.0_WP + a2(:,1:this%nown)=this%v(:,1:this%nown) + call move_alloc(a2,this%v) + do k=1,nkeep + this%y(:,this%ntot+slot(k))=kpos(:,k) + end do + end block resize_state + deallocate(kgid,kkey,kowner,kpos,slot) + + ! Candidate CSR over the contact-visible set: owned nodes (indices + ! 1..nown) + contact slots (ntot+1..ntot+nchalo). Two passes. + candidates: block + integer :: ns,m,jj,cnt,ic,jc,kc,c1,c2,c3 + integer, allocatable :: midx(:) + real(WP), dimension(3) :: blc,bhc + ns=this%nown+this%nchalo + allocate(midx(max(ns,1))) + do m=1,this%nown + midx(m)=m + end do + do m=1,this%nchalo + midx(this%nown+m)=this%ntot+m + end do + blc=bl; bhc=bh + do m=this%nown+1,ns + blc=min(blc,this%y(:,midx(m))); bhc=max(bhc,this%y(:,midx(m))) + end do + call setup_bins(blc,bhc,rbuild,gl,hcell,nc) + allocate(head(nc(1)*nc(2)*nc(3)),nxt(max(ns,1))) + head=0 + do m=1,ns + if (m.le.this%nown) then + if (this%flag(m).eq.PDC_IS_DEAD) cycle + end if + k=cell_of(this%y(:,midx(m)),gl,hcell,nc) + nxt(m)=head(k); head(k)=m + end do + if (allocated(this%cptr)) deallocate(this%cptr) + if (allocated(this%clst)) deallocate(this%clst) + allocate(this%cptr(this%nown+1)) + do pass=1,2 + do i=1,this%nown + cnt=0 + if (this%flag(i).eq.PDC_IS_DEAD) then + if (pass.eq.1) this%cptr(i+1)=0 + cycle + end if + ic=min(nc(1),max(1,int((this%y(1,i)-gl(1))/hcell(1))+1)) + jc=min(nc(2),max(1,int((this%y(2,i)-gl(2))/hcell(2))+1)) + kc=min(nc(3),max(1,int((this%y(3,i)-gl(3))/hcell(3))+1)) + do c3=max(1,kc-1),min(nc(3),kc+1); do c2=max(1,jc-1),min(nc(2),jc+1); do c1=max(1,ic-1),min(nc(1),ic+1) + m=head(c1+nc(1)*(c2-1)+nc(1)*nc(2)*(c3-1)) + do while (m.gt.0) + jj=midx(m) + if (jj.ne.i) then + if (sum((this%y(:,jj)-this%y(:,i))**2).le.rbuild**2) then + cnt=cnt+1 + if (pass.eq.2) this%clst(this%cptr(i)+cnt-1)=jj + end if + end if + m=nxt(m) + end do + end do; end do; end do + if (pass.eq.1) this%cptr(i+1)=cnt ! provisional count + end do + if (pass.eq.1) then + this%cptr(1)=1 + do i=1,this%nown + this%cptr(i+1)=this%cptr(i)+this%cptr(i+1) + end do + allocate(this%clst(max(this%cptr(this%nown+1)-1,1))) + end if + end do + deallocate(midx,head,nxt) + end block candidates + + ! Snapshot positions for the drift trigger + if (allocated(this%ylast)) deallocate(this%ylast) + allocate(this%ylast(3,max(this%nown,1))) + this%ylast(:,1:this%nown)=this%y(:,1:this%nown) + deallocate(allb) + end block rebuild + + contains + + !> Any owned node within r of position p? (binned +/-1 cell sweep) + function near_owned(p,r,gl,h,nc,head,nxt) result(hit) + real(WP), dimension(3), intent(in) :: p,gl,h + real(WP), intent(in) :: r + integer, dimension(3), intent(in) :: nc + integer, intent(in) :: head(:),nxt(:) + logical :: hit + integer :: c(3),d,c1,c2,c3,m + hit=.false. + do d=1,3 + c(d)=min(nc(d),max(1,int((p(d)-gl(d))/h(d))+1)) + end do + do c3=max(1,c(3)-1),min(nc(3),c(3)+1); do c2=max(1,c(2)-1),min(nc(2),c(2)+1); do c1=max(1,c(1)-1),min(nc(1),c(1)+1) + m=head(c1+nc(1)*(c2-1)+nc(1)*nc(2)*(c3-1)) + do while (m.gt.0) + if (sum((this%y(:,m)-p)**2).le.r**2) then + hit=.true. + return + end if + m=nxt(m) + end do + end do; end do; end do + end function near_owned + + end subroutine contact_broadphase + + !> Contact narrow phase: soft-sphere walls + particle-particle over the + !> candidate CSR, gather-only (soft-sphere penalty ported from amrlpt's collision model; + !> IB contact arrives with the coupling layer). Adds force/volume into owned + !> f. Walls use e_w with d_eff = 0.5*contact_dist and m_eff = m1; pairs use + !> e_n with d_eff = contact_dist and m_eff = 0.5*m1 (m1 = rho*vol(i), + !> matching amrpd's uniform rho*dV on a uniform lattice). + subroutine contact_narrow(this,dt) + use mathtools, only: Pi + implicit none + class(pdsolver), intent(inout) :: this + real(WP), intent(in) :: dt + real(WP) :: tau,k_n,eta_n,k_w,eta_w,d_eff_w,m1 + real(WP), dimension(3) :: r1,v1,floc,r2 + real(WP), dimension(3), parameter :: vzero=[0.0_WP,0.0_WP,0.0_WP] + integer :: i,k,j + if (this%contact_dist.le.0.0_WP.or.dt.le.0.0_WP) return + if (this%e_n.le.0.0_WP.or.this%e_w.le.0.0_WP) return + if (this%tau_col.gt.0.0_WP) then + tau=this%tau_col + else + tau=5.0_WP*dt + end if + k_n =(Pi**2+log(this%e_n)**2)/tau**2 + eta_n=-2.0_WP*log(this%e_n)/tau + k_w =(Pi**2+log(this%e_w)**2)/tau**2 + eta_w=-2.0_WP*log(this%e_w)/tau + d_eff_w=0.5_WP*this%contact_dist + do i=1,this%nown + if (this%flag(i).eq.PDC_IS_DEAD) cycle + m1=this%rho*this%vol(i) + r1=this%y(:,i); v1=this%v(:,i) + floc=0.0_WP + ! Wall collisions on faces flagged as walls (virtual partner on the + ! wall directly normal to the node) + if (this%lo_bc(1).eq.1) then; r2=[this%dom_lo(1),r1(2),r1(3)]; call apply_col(k_w,eta_w,d_eff_w,m1,r2,vzero); end if + if (this%hi_bc(1).eq.1) then; r2=[this%dom_hi(1),r1(2),r1(3)]; call apply_col(k_w,eta_w,d_eff_w,m1,r2,vzero); end if + if (this%lo_bc(2).eq.1) then; r2=[r1(1),this%dom_lo(2),r1(3)]; call apply_col(k_w,eta_w,d_eff_w,m1,r2,vzero); end if + if (this%hi_bc(2).eq.1) then; r2=[r1(1),this%dom_hi(2),r1(3)]; call apply_col(k_w,eta_w,d_eff_w,m1,r2,vzero); end if + if (this%lo_bc(3).eq.1) then; r2=[r1(1),r1(2),this%dom_lo(3)]; call apply_col(k_w,eta_w,d_eff_w,m1,r2,vzero); end if + if (this%hi_bc(3).eq.1) then; r2=[r1(1),r1(2),this%dom_hi(3)]; call apply_col(k_w,eta_w,d_eff_w,m1,r2,vzero); end if + ! Particle-particle via the candidate CSR + do k=this%cptr(i),this%cptr(i+1)-1 + j=this%clst(k) + call apply_col(k_n,eta_n,this%contact_dist,0.5_WP*m1,this%y(:,j),this%v(:,j)) + end do + ! Accumulate as force/volume (matches bond force units) + this%f(:,i)=this%f(:,i)+floc/this%vol(i) + end do + + contains + + !> Soft-sphere normal force from virtual partner (r2_in, v2_in) onto i. + !> Host-associated r1, v1, dt, floc. + subroutine apply_col(kk,ee,d_eff,m_eff,r2_in,v2_in) + real(WP), intent(in) :: kk,ee,d_eff,m_eff + real(WP), dimension(3), intent(in) :: r2_in,v2_in + real(WP) :: d12,rnv,r_influ,delta_n + real(WP), dimension(3) :: n12,v12,f_n + d12=norm2(r2_in-r1) + if (d12.lt.10.0_WP*epsilon(d12)) return ! self-overlap guard + n12=(r2_in-r1)/d12 + v12=v1-v2_in + rnv=dot_product(v12,n12) + r_influ=min(abs(rnv)*dt,0.2_WP*d_eff) + delta_n=min(d_eff+r_influ-d12,this%clip_col*d_eff) + if (delta_n.le.0.0_WP) return + f_n=(-m_eff*kk*delta_n-m_eff*ee*rnv)*n12 + floc=floc+f_n + end subroutine apply_col + + end subroutine contact_narrow + + !> Binding CFL: elastic wave + scaled convective (limits 0.5 / 0.1) + subroutine get_cfl(this,dt,cfl) + use parallel, only: comm,MPI_REAL_WP + use mpi_f08, only: MPI_ALLREDUCE,MPI_MAX,MPI_IN_PLACE + implicit none + class(pdsolver), intent(inout) :: this + real(WP), intent(in) :: dt + real(WP), intent(out) :: cfl + real(WP), parameter :: CFL_scale_conv=5.0_WP + real(WP) :: K_bulk,mu_shear,c_p,dp_inv,vmax + integer :: i,ierr + K_bulk =this%elastic_modulus/(3.0_WP*(1.0_WP-2.0_WP*this%poisson_ratio)) + mu_shear=this%elastic_modulus/(2.0_WP*(1.0_WP+this%poisson_ratio)) + c_p =sqrt((K_bulk+4.0_WP*mu_shear/3.0_WP)/this%rho) + dp_inv =1.0_WP/this%dV**(1.0_WP/3.0_WP) + this%CFLe=c_p*dp_inv*dt + this%CFLp=0.0_WP + do i=1,this%nown + if (this%flag(i).eq.PDC_IS_DEAD) cycle + vmax=max(abs(this%v(1,i)),abs(this%v(2,i)),abs(this%v(3,i))) + this%CFLp=max(this%CFLp,vmax*dp_inv) + end do + call MPI_ALLREDUCE(MPI_IN_PLACE,this%CFLp,1,MPI_REAL_WP,MPI_MAX,comm,ierr) + this%CFLp=this%CFLp*dt + cfl=max(CFL_scale_conv*this%CFLp,this%CFLe) + end subroutine get_cfl + + !> Global counts, velocity max, and timer reduction (+reset). Collective. + subroutine get_info(this) + use parallel, only: comm,MPI_REAL_WP + use mpi_f08, only: MPI_ALLREDUCE,MPI_MAX,MPI_MIN,MPI_SUM,MPI_IN_PLACE,MPI_INTEGER8 + implicit none + class(pdsolver), intent(inout) :: this + integer :: i,ierr + integer(I8) :: np_loc + real(WP), dimension(3) :: vmin,vmax + np_loc=0_I8 + vmin=huge(1.0_WP); vmax=-huge(1.0_WP) + this%EPmax=0.0_WP + do i=1,this%nown + if (this%flag(i).eq.PDC_IS_DEAD) cycle + np_loc=np_loc+1_I8 + vmin=min(vmin,this%v(:,i)); vmax=max(vmax,this%v(:,i)) + this%EPmax=max(this%EPmax,this%lam_p(i)) + end do + this%np=np_loc + call MPI_ALLREDUCE(MPI_IN_PLACE,this%np,1,MPI_INTEGER8,MPI_SUM,comm,ierr) + call MPI_ALLREDUCE(MPI_IN_PLACE,this%EPmax,1,MPI_REAL_WP,MPI_MAX,comm,ierr) + call MPI_ALLREDUCE(MPI_IN_PLACE,vmin,3,MPI_REAL_WP,MPI_MIN,comm,ierr) + call MPI_ALLREDUCE(MPI_IN_PLACE,vmax,3,MPI_REAL_WP,MPI_MAX,comm,ierr) + if (this%np.eq.0_I8) then + vmin=0.0_WP; vmax=0.0_WP + end if + this%Umin=vmin(1); this%Umax=vmax(1) + this%Vmin=vmin(2); this%Vmax=vmax(2) + this%Wmin=vmin(3); this%Wmax=vmax(3) + ! Broken half-entry census (each broken bond counts twice, except + ! self-image bonds which have a single half-entry) + count_broken: block + integer(I8) :: nb_loc + integer :: e,i2,j2 + ! Half-entry count (internal) and EXACT broken-bond census: each bond + ! is counted at exactly one of its two half-entries -- the one whose + ! node gid is lower (ties = self-image bonds, counted at the + ! positive-offset image so each appears once) + nb_loc=0_I8; this%nb_broken=0_I8 + do i2=1,this%nown + do e=this%ptr(i2),this%ptr(i2+1)-1 + if (this%dmg(e).eq.0_1) cycle + nb_loc=nb_loc+1_I8 + j2=this%lst(e) + if (this%gid(i2).lt.this%gid(j2)) then + this%nb_broken=this%nb_broken+1_I8 + else if (this%gid(i2).eq.this%gid(j2)) then + if (j2.gt.this%nown) then + if (shift_positive(this%halo%shift(:,j2-this%nown))) this%nb_broken=this%nb_broken+1_I8 + end if + end if + end do + end do + this%nbroken=nb_loc + call MPI_ALLREDUCE(MPI_IN_PLACE,this%nbroken,1,MPI_INTEGER8,MPI_SUM,comm,ierr) + call MPI_ALLREDUCE(MPI_IN_PLACE,this%nb_broken,1,MPI_INTEGER8,MPI_SUM,comm,ierr) + end block count_broken + ! Timers: max (and min for the compute-heavy phases) across ranks, then reset + call MPI_ALLREDUCE(this%wt_kick, this%wtmax_kick, 1,MPI_REAL_WP,MPI_MAX,comm,ierr) + call MPI_ALLREDUCE(this%wt_halo, this%wtmax_halo, 1,MPI_REAL_WP,MPI_MAX,comm,ierr) + call MPI_ALLREDUCE(this%wt_dil, this%wtmax_dil, 1,MPI_REAL_WP,MPI_MAX,comm,ierr) + call MPI_ALLREDUCE(this%wt_dil, this%wtmin_dil, 1,MPI_REAL_WP,MPI_MIN,comm,ierr) + call MPI_ALLREDUCE(this%wt_force, this%wtmax_force, 1,MPI_REAL_WP,MPI_MAX,comm,ierr) + call MPI_ALLREDUCE(this%wt_force, this%wtmin_force, 1,MPI_REAL_WP,MPI_MIN,comm,ierr) + call MPI_ALLREDUCE(this%wt_reduce,this%wtmax_reduce,1,MPI_REAL_WP,MPI_MAX,comm,ierr) + call MPI_ALLREDUCE(this%wt_contact,this%wtmax_contact,1,MPI_REAL_WP,MPI_MAX,comm,ierr) + call MPI_ALLREDUCE(this%wt_broad, this%wtmax_broad, 1,MPI_REAL_WP,MPI_MAX,comm,ierr) + this%wt_kick=0.0_WP; this%wt_halo=0.0_WP; this%wt_dil=0.0_WP; this%wt_force=0.0_WP; this%wt_reduce=0.0_WP + this%wt_contact=0.0_WP; this%wt_broad=0.0_WP + ! Contact-service size census (visibility into the fragmentation-driven + ! degradation mode of the static graph partition) + contact_census: block + integer(I8) :: tmp + this%nchalo_glob=int(this%nchalo,I8) + call MPI_ALLREDUCE(MPI_IN_PLACE,this%nchalo_glob,1,MPI_INTEGER8,MPI_SUM,comm,ierr) + tmp=0_I8 + if (allocated(this%cptr)) tmp=int(this%cptr(this%nown+1)-1,I8) + this%ncand_glob=tmp + call MPI_ALLREDUCE(MPI_IN_PLACE,this%ncand_glob,1,MPI_INTEGER8,MPI_SUM,comm,ierr) + end block contact_census + end subroutine get_info + + !> Release all storage + subroutine finalize(this) + implicit none + class(pdsolver), intent(inout) :: this + if (allocated(this%gid)) deallocate(this%gid) + if (allocated(this%x0)) deallocate(this%x0) + if (allocated(this%y)) deallocate(this%y) + if (allocated(this%v)) deallocate(this%v) + if (allocated(this%f)) deallocate(this%f) + if (allocated(this%ff)) deallocate(this%ff) + if (allocated(this%vol)) deallocate(this%vol) + if (allocated(this%mw)) deallocate(this%mw) + if (allocated(this%theta)) deallocate(this%theta) + if (allocated(this%damage))deallocate(this%damage) + if (allocated(this%lam_p)) deallocate(this%lam_p) + if (allocated(this%alive)) deallocate(this%alive) + if (allocated(this%flag)) deallocate(this%flag) + if (allocated(this%ptr)) deallocate(this%ptr) + if (allocated(this%lst)) deallocate(this%lst) + if (allocated(this%dmg)) deallocate(this%dmg) + if (allocated(this%e_v)) deallocate(this%e_v) + if (allocated(this%td2)) deallocate(this%td2) + if (allocated(this%td2a)) deallocate(this%td2a) + if (allocated(this%cptr)) deallocate(this%cptr) + if (allocated(this%clst)) deallocate(this%clst) + if (allocated(this%ylast)) deallocate(this%ylast) + if (allocated(this%rextra_tmp)) deallocate(this%rextra_tmp) + call this%ohash%finalize() + call this%dir%finalize() + call this%halo%finalize() + call this%chalo%finalize() + this%nown=0; this%nhalo=0; this%ntot=0; this%nchalo=0 + end subroutine finalize + + + !> Mirror synchronization (the coupling bridge). Collective, once per FLUID + !> step. The caller walks its face particles (AMReX container on the + !> fluid decomposition) and passes per particle: gid, core owner rank (read + !> from the face particle's repurposed flag tag), and the F_fluid it interpolated + !> from the grid. This routine routes F_fluid to the owning nodes (held in + !> ff across the subsequent PD subcycles) and replies with each node's + !> current (pos, vel, damage, alive), returned aligned with the caller's + !> input order for direct write-back into the face particles. + subroutine exchange(this,nm,mgid,mowner,mff,mpos,mvel,mdmg,malive) + use parallel, only: comm,nproc,MPI_REAL_WP + use messager, only: die + use mpi_f08 + implicit none + class(pdsolver), intent(inout) :: this + integer, intent(in) :: nm + integer(I8), intent(in) :: mgid(:) + integer, intent(in) :: mowner(:) + real(WP), intent(in) :: mff(:,:) + real(WP), intent(out) :: mpos(:,:),mvel(:,:) + real(WP), intent(out) :: mdmg(:),malive(:) + integer, dimension(0:nproc-1) :: sc,rc,sd,rd + integer, dimension(0:nproc-1) :: scw,rcw,sdw,rdw + integer, allocatable :: pos(:),qpos(:) + integer(I8), allocatable :: sg(:),rg(:) + real(WP), allocatable :: sff(:,:),rff(:,:),srep(:,:),rrep(:,:) + integer :: i,r,nr,idx,ierr + + ! Count and pack by owner, remembering each entry's packed slot + sc=0 + do i=1,nm + sc(mowner(i))=sc(mowner(i))+1 + end do + call MPI_ALLTOALL(sc,1,MPI_INTEGER,rc,1,MPI_INTEGER,comm,ierr) + sd(0)=0; rd(0)=0 + do r=1,nproc-1 + sd(r)=sd(r-1)+sc(r-1); rd(r)=rd(r-1)+rc(r-1) + end do + allocate(pos(0:nproc-1),qpos(max(nm,1))) + allocate(sg(max(nm,1)),sff(3,max(nm,1))) + pos=sd + do i=1,nm + r=mowner(i); pos(r)=pos(r)+1 + sg(pos(r))=mgid(i); sff(:,pos(r))=mff(:,i); qpos(i)=pos(r) + end do + nr=sum(rc) + allocate(rg(max(nr,1)),rff(3,max(nr,1))) + call MPI_ALLTOALLV(sg,sc,sd,MPI_INTEGER8,rg,rc,rd,MPI_INTEGER8,comm,ierr) + scw=3*sc; sdw=3*sd; rcw=3*rc; rdw=3*rd + call MPI_ALLTOALLV(sff,scw,sdw,MPI_REAL_WP,rff,rcw,rdw,MPI_REAL_WP,comm,ierr) + + ! Owner side: ingest F_fluid, build the state reply in arrival order + allocate(rrep(8,max(nr,1))) + do i=1,nr + idx=this%ohash%lookup(rg(i)) + if (idx.lt.1) call die('[pdsolver exchange] face gid not owned by tagged rank') + this%ff(:,idx)=rff(:,i) + rrep(1:3,i)=this%y(:,idx) + rrep(4:6,i)=this%v(:,idx) + rrep(7,i) =this%damage(idx) + rrep(8,i) =this%alive(idx) + end do + + ! Reply along the reverse route; unpack to the caller's original order + allocate(srep(8,max(nm,1))) + scw=8*rc; sdw=8*rd; rcw=8*sc; rdw=8*sd + call MPI_ALLTOALLV(rrep,scw,sdw,MPI_REAL_WP,srep,rcw,rdw,MPI_REAL_WP,comm,ierr) + do i=1,nm + mpos(:,i) =srep(1:3,qpos(i)) + mvel(:,i) =srep(4:6,qpos(i)) + mdmg(i) =srep(7,qpos(i)) + malive(i) =srep(8,qpos(i)) + end do + deallocate(pos,qpos,sg,sff,rg,rff,rrep,srep) + end subroutine exchange + + + !> Owner-rank lookup for arbitrary node gids via the persistent directory. + !> Collective. Drivers use it to re-stamp face routing tags after restart. + subroutine query_owners(this,n,gids,owners) + implicit none + class(pdsolver), intent(inout) :: this + integer, intent(in) :: n + integer(I8), intent(in) :: gids(:) + integer, intent(out) :: owners(:) + call this%dir%query(n,gids,owners) + end subroutine query_owners + + !> Checkpoint the core under /: per-rank stream files + root + !> header. Records are GID-SPACE (no local indices, no partition info) -- + !> nodes: (gid, flag, x0, y, v, f, vol, damage, td2, lam_p); half-entries: + !> (node_gid, nbr_gid, image_key, dmg, e_v), the image key reconstructed + !> from the halo slot's shift. Rank-count portable on read. Format v2 + !> (v1 = pre-hardening, no lam_p record; read_state accepts both). + subroutine write_state(this,dirname) + use parallel, only: rank,nproc,amRoot + use messager, only: die + use string, only: str_medium + implicit none + class(pdsolver), intent(inout) :: this + character(len=*), intent(in) :: dirname + character(len=str_medium) :: fname + integer :: iunit,ios,i,e,j,nhe + integer, allocatable :: hkey(:) + integer(I8), allocatable :: hnode(:),hnbr(:) + ! Half-entries in gid space + nhe=this%ptr(this%nown+1)-1 + allocate(hnode(max(nhe,1)),hnbr(max(nhe,1)),hkey(max(nhe,1))) + do i=1,this%nown + do e=this%ptr(i),this%ptr(i+1)-1 + j=this%lst(e) + hnode(e)=this%gid(i) + hnbr(e) =this%gid(j) + if (j.le.this%nown) then + hkey(e)=PDHALO_KEY0 + else + hkey(e)=key_of_shift(this%halo%shift(:,j-this%nown),this%Ldom) + end if + end do + end do + ! Per-rank stream file + ! All solid state lives under /pd/ (root creates it) + make_dir: block + use parallel, only: comm + use mpi_f08, only: MPI_BARRIER + integer :: ierr2 + if (amRoot) call execute_command_line('mkdir -p '//trim(dirname)//'/pd') + call MPI_BARRIER(comm,ierr2) + end block make_dir + write(fname,'(a,"/pd/pd_",i7.7,".bin")') trim(dirname),rank + open(newunit=iunit,file=trim(fname),form='unformatted',access='stream',status='replace',iostat=ios) + if (ios.ne.0) call die('[pdsolver write_state] cannot open '//trim(fname)) + write(iunit) this%nown,nhe + write(iunit) this%gid(1:this%nown) + write(iunit) this%flag(1:this%nown) + write(iunit) this%x0(:,1:this%nown) + write(iunit) this%y(:,1:this%nown) + write(iunit) this%v(:,1:this%nown) + write(iunit) this%f(:,1:this%nown) + write(iunit) this%vol(1:this%nown) + write(iunit) this%damage(1:this%nown) + write(iunit) this%td2(1:this%nown) + write(iunit) this%lam_p(1:this%nown) + write(iunit) hnode(1:nhe) + write(iunit) hnbr(1:nhe) + write(iunit) hkey(1:nhe) + write(iunit) this%dmg(1:nhe) + write(iunit) this%e_v(1:nhe) + close(iunit) + deallocate(hnode,hnbr,hkey) + ! Root header (file count for portable round-robin reads) + if (amRoot) then + open(newunit=iunit,file=trim(dirname)//'/pd/header',form='formatted',status='replace',iostat=ios) + if (ios.ne.0) call die('[pdsolver write_state] cannot open header') + write(iunit,'(a)') 'pdsolver checkpoint v2' + write(iunit,'(i0)') nproc + close(iunit) + end if + contains + !> Reconstruct the packed image key from a slot shift vector + pure function key_of_shift(s,L) result(k) + implicit none + real(WP), dimension(3), intent(in) :: s,L + integer :: k,n1,n2,n3 + n1=0; n2=0; n3=0 + if (L(1).gt.0.0_WP) n1=nint(s(1)/L(1)) + if (L(2).gt.0.0_WP) n2=nint(s(2)/L(2)) + if (L(3).gt.0.0_WP) n3=nint(s(3)/L(3)) + k=(n1+128)+(n2+128)*256+(n3+128)*65536 + end function key_of_shift + end subroutine write_state + + !> Restore the core from a checkpoint written by write_state. Collective; + !> rank-count portable: files read round-robin, nodes re-partitioned by + !> Morton order of the reference configuration, half-entries routed to + !> their owners, CSR/halo rebuilt via assemble with the loaded per-entry + !> state. The caller must configure the solver (initialize + material/ + !> contact/plastic component assignments) BEFORE calling this. + subroutine read_state(this,dirname) + use parallel, only: comm,rank,nproc,MPI_REAL_WP + use messager, only: die + use string, only: str_medium + use mpi_f08 + implicit none + class(pdsolver), intent(inout) :: this + character(len=*), intent(in) :: dirname + character(len=str_medium) :: fname,line + integer :: nfiles,iunit,ios,f,i,r,ierr,iver + integer :: nn,nhe,nf,nhf + integer(I8), allocatable :: gid(:),hnode(:),hnbr(:) + integer, allocatable :: flag(:),hkey(:),owner(:) + real(WP), allocatable :: x0(:,:),yy(:,:),vv(:,:),ffb(:,:),vol(:),dmgn(:),td2n(:),lamn(:) + real(WP), allocatable :: hev(:) + integer(1), allocatable :: hdmg(:) + + ! Resolve derived configuration (restart-safe shared path) + call this%derive_config() + + ! Header: number of files written + format version (v1 = no lam_p record) + nfiles=0; iver=1 + if (rank.eq.0) then + open(newunit=iunit,file=trim(dirname)//'/pd/header',form='formatted',status='old',iostat=ios) + if (ios.ne.0) call die('[pdsolver read_state] no pd/header under '//trim(dirname)) + read(iunit,'(a)') line + if (index(line,'v2').gt.0) iver=2 + read(iunit,*) nfiles + close(iunit) + end if + call MPI_BCAST(nfiles,1,MPI_INTEGER,0,comm,ierr) + call MPI_BCAST(iver,1,MPI_INTEGER,0,comm,ierr) + + ! Read my round-robin share of the files, concatenating records + nn=0; nhe=0 + do f=rank,nfiles-1,nproc + write(fname,'(a,"/pd/pd_",i7.7,".bin")') trim(dirname),f + open(newunit=iunit,file=trim(fname),form='unformatted',access='stream',status='old',iostat=ios) + if (ios.ne.0) call die('[pdsolver read_state] cannot open '//trim(fname)) + read(iunit) nf,nhf + call grow_i8(gid,nn,nf); call grow_i4(flag,nn,nf) + call grow_r2(x0,nn,nf); call grow_r2(yy,nn,nf) + call grow_r2(vv,nn,nf); call grow_r2(ffb,nn,nf) + call grow_r1(vol,nn,nf); call grow_r1(dmgn,nn,nf); call grow_r1(td2n,nn,nf) + call grow_r1(lamn,nn,nf) + read(iunit) gid(nn+1:nn+nf) + read(iunit) flag(nn+1:nn+nf) + read(iunit) x0(:,nn+1:nn+nf) + read(iunit) yy(:,nn+1:nn+nf) + read(iunit) vv(:,nn+1:nn+nf) + read(iunit) ffb(:,nn+1:nn+nf) + read(iunit) vol(nn+1:nn+nf) + read(iunit) dmgn(nn+1:nn+nf) + read(iunit) td2n(nn+1:nn+nf) + if (iver.ge.2) then + read(iunit) lamn(nn+1:nn+nf) + else + lamn(nn+1:nn+nf)=0.0_WP + end if + call grow_i8(hnode,nhe,nhf); call grow_i8(hnbr,nhe,nhf) + call grow_i4(hkey,nhe,nhf); call grow_i1(hdmg,nhe,nhf); call grow_r1(hev,nhe,nhf) + read(iunit) hnode(nhe+1:nhe+nhf) + read(iunit) hnbr(nhe+1:nhe+nhf) + read(iunit) hkey(nhe+1:nhe+nhf) + read(iunit) hdmg(nhe+1:nhe+nhf) + read(iunit) hev(nhe+1:nhe+nhf) + close(iunit) + nn=nn+nf; nhe=nhe+nhf + end do + if (.not.allocated(gid)) then ! ranks with no files still join collectives + allocate(gid(1),flag(1),x0(3,1),yy(3,1),vv(3,1),ffb(3,1),vol(1),dmgn(1),td2n(1),lamn(1)) + allocate(hnode(1),hnbr(1),hkey(1),hdmg(1),hev(1)) + end if + + ! Re-partition nodes by Morton order of the REFERENCE configuration and + ! route the full records (pd_partition routes the set_nodes payload; the + ! remaining fields ride a second, identically-ordered exchange) + repartition: block + integer(I8), allocatable :: rgid(:) + real(WP), allocatable :: rx0(:,:),rvv(:,:),rvol(:),extra(:,:) + integer, allocatable :: rflag(:) + integer, dimension(0:nproc-1) :: sc,rc,sd,rd,scw,rcw,sdw,rdw + integer, allocatable :: pos(:) + integer :: nr + allocate(owner(max(nn,1))) + call pd_partition(nn,gid,x0,vv,flag,vol,owner,nr,rgid,rx0,rvv,rflag,rvol) + ! Second exchange: (y, f, damage, td2) = 8 reals, packed in the same + ! per-destination input order as pd_partition's own packing + sc=0 + do i=1,nn + sc(owner(i))=sc(owner(i))+1 + end do + call MPI_ALLTOALL(sc,1,MPI_INTEGER,rc,1,MPI_INTEGER,comm,ierr) + sd(0)=0; rd(0)=0 + do r=1,nproc-1 + sd(r)=sd(r-1)+sc(r-1); rd(r)=rd(r-1)+rc(r-1) + end do + allocate(pos(0:nproc-1),extra(9,max(nn,1)),this%rextra_tmp(9,max(nr,1))) + pos=sd + do i=1,nn + r=owner(i); pos(r)=pos(r)+1 + extra(1:3,pos(r))=yy(:,i) + extra(4:6,pos(r))=ffb(:,i) + extra(7,pos(r)) =dmgn(i) + extra(8,pos(r)) =td2n(i) + extra(9,pos(r)) =lamn(i) + end do + scw=9*sc; sdw=9*sd; rcw=9*rc; rdw=9*rd + call MPI_ALLTOALLV(extra,scw,sdw,MPI_REAL_WP,this%rextra_tmp,rcw,rdw,MPI_REAL_WP,comm,ierr) + ! Load the routed nodes, then overlay the restart-only fields + call this%set_nodes(nr,rgid,rx0,rvv,rflag,rvol) + do i=1,nr + this%y(:,i) =this%rextra_tmp(1:3,i) + this%f(:,i) =this%rextra_tmp(4:6,i) + this%damage(i)=this%rextra_tmp(7,i) + end do + deallocate(pos,extra,rgid,rx0,rvv,rflag,rvol) + end block repartition + + ! Register the directory over the new partition, route half-entries to + ! their owners (state travels along), and rebuild CSR/halo/reference + route_and_assemble: block + integer(I8), allocatable :: rnode(:),rnbr(:) + integer, allocatable :: rkey(:),howner(:) + real(WP), allocatable :: rev(:) + integer(1), allocatable :: rdmg(:) + integer, dimension(0:nproc-1) :: sc,rc,sd,rd + integer, allocatable :: pos(:) + integer(I8), allocatable :: s8(:) + integer, allocatable :: s4(:) + real(WP), allocatable :: sr(:) + integer(1), allocatable :: s1(:) + integer :: rn,h + call this%dir%finalize() + call this%dir%register(this%nown,this%gid(1:this%nown)) + allocate(howner(max(nhe,1))) + call this%dir%query(nhe,hnode,howner) + sc=0 + do i=1,nhe + sc(howner(i))=sc(howner(i))+1 + end do + call MPI_ALLTOALL(sc,1,MPI_INTEGER,rc,1,MPI_INTEGER,comm,ierr) + sd(0)=0; rd(0)=0 + do r=1,nproc-1 + sd(r)=sd(r-1)+sc(r-1); rd(r)=rd(r-1)+rc(r-1) + end do + rn=sum(rc) + allocate(rnode(max(rn,1)),rnbr(max(rn,1)),rkey(max(rn,1)),rev(max(rn,1)),rdmg(max(rn,1))) + allocate(pos(0:nproc-1),s8(max(nhe,1)),s4(max(nhe,1)),sr(max(nhe,1)),s1(max(nhe,1))) + pos=sd + do i=1,nhe + h=howner(i); pos(h)=pos(h)+1; s8(pos(h))=hnode(i) + end do + call MPI_ALLTOALLV(s8,sc,sd,MPI_INTEGER8,rnode,rc,rd,MPI_INTEGER8,comm,ierr) + pos=sd + do i=1,nhe + h=howner(i); pos(h)=pos(h)+1; s8(pos(h))=hnbr(i) + end do + call MPI_ALLTOALLV(s8,sc,sd,MPI_INTEGER8,rnbr,rc,rd,MPI_INTEGER8,comm,ierr) + pos=sd + do i=1,nhe + h=howner(i); pos(h)=pos(h)+1; s4(pos(h))=hkey(i) + end do + call MPI_ALLTOALLV(s4,sc,sd,MPI_INTEGER,rkey,rc,rd,MPI_INTEGER,comm,ierr) + pos=sd + do i=1,nhe + h=howner(i); pos(h)=pos(h)+1; sr(pos(h))=hev(i) + end do + call MPI_ALLTOALLV(sr,sc,sd,MPI_REAL_WP,rev,rc,rd,MPI_REAL_WP,comm,ierr) + pos=sd + do i=1,nhe + h=howner(i); pos(h)=pos(h)+1; s1(pos(h))=hdmg(i) + end do + call MPI_ALLTOALLV(s1,sc,sd,MPI_INTEGER1,rdmg,rc,rd,MPI_INTEGER1,comm,ierr) + call this%assemble(rn,rnode,rnbr,rkey,rev,rdmg) + deallocate(rnode,rnbr,rkey,rev,rdmg,pos,s8,s4,sr,s1,howner) + end block route_and_assemble + + ! Overlay td2/lam_p (assemble/set_nodes zero them) and life status + do i=1,this%nown + this%td2(i) =this%rextra_tmp(8,i) + this%lam_p(i)=this%rextra_tmp(9,i) + if (this%flag(i).eq.PDC_IS_DEAD) this%alive(i)=0.0_WP + end do + deallocate(this%rextra_tmp) + call this%halo%update1(this%alive) + deallocate(gid,flag,x0,yy,vv,ffb,vol,dmgn,td2n,lamn,hnode,hnbr,hkey,hdmg,hev,owner) + + contains + + subroutine grow_i8(a,n,add) + integer(I8), allocatable, intent(inout) :: a(:) + integer, intent(in) :: n,add + integer(I8), allocatable :: t(:) + allocate(t(n+add)); if (n.gt.0) t(1:n)=a(1:n) + call move_alloc(t,a) + end subroutine grow_i8 + subroutine grow_i4(a,n,add) + integer, allocatable, intent(inout) :: a(:) + integer, intent(in) :: n,add + integer, allocatable :: t(:) + allocate(t(n+add)); if (n.gt.0) t(1:n)=a(1:n) + call move_alloc(t,a) + end subroutine grow_i4 + subroutine grow_i1(a,n,add) + integer(1), allocatable, intent(inout) :: a(:) + integer, intent(in) :: n,add + integer(1), allocatable :: t(:) + allocate(t(n+add)); if (n.gt.0) t(1:n)=a(1:n) + call move_alloc(t,a) + end subroutine grow_i1 + subroutine grow_r1(a,n,add) + real(WP), allocatable, intent(inout) :: a(:) + integer, intent(in) :: n,add + real(WP), allocatable :: t(:) + allocate(t(n+add)); if (n.gt.0) t(1:n)=a(1:n) + call move_alloc(t,a) + end subroutine grow_r1 + subroutine grow_r2(a,n,add) + real(WP), allocatable, intent(inout) :: a(:,:) + integer, intent(in) :: n,add + real(WP), allocatable :: t(:,:) + allocate(t(3,n+add)); if (n.gt.0) t(:,1:n)=a(:,1:n) + call move_alloc(t,a) + end subroutine grow_r2 + + end subroutine read_state + + + !> Static load-balancing partition of the reference configuration. + !> Collective; called once at handoff, BEFORE set_nodes. Nodes are ordered + !> by the Morton key of their reference position and split into equal-count + !> contiguous ranges: on a uniform lattice family size is ~constant, so node + !> count ~ bond work (a family-weighted split can substitute later), and + !> bond work is motion-invariant -- this balance holds for the entire run + !> regardless of deformation or flight, using ALL ranks even when the solid + !> occupies a corner of the fluid domain. + !> Inputs: this rank's extracted nodes (any distribution). Outputs: the + !> nodes assigned to this rank, plus each INPUT node's assigned owner (for + !> stamping the face particles' routing tags). + subroutine pd_partition(n_in,gid_in,pos_in,vel_in,flag_in,vol_in,owner_out, & + & n_out,gid_out,pos_out,vel_out,flag_out,vol_out) + use parallel, only: comm,rank,nproc,amRoot,MPI_REAL_WP + use pdhalo_class, only: sort3_perm + use mpi_f08 + implicit none + integer, intent(in) :: n_in + integer(I8), intent(in) :: gid_in(:) + real(WP), intent(in) :: pos_in(:,:),vel_in(:,:) + integer, intent(in) :: flag_in(:) + real(WP), intent(in) :: vol_in(:) + integer, intent(out) :: owner_out(:) + integer, intent(out) :: n_out + integer(I8), allocatable, intent(out) :: gid_out(:) + real(WP), allocatable, intent(out) :: pos_out(:,:),vel_out(:,:),vol_out(:) + integer, allocatable, intent(out) :: flag_out(:) + real(WP), dimension(3) :: blo,bhi,inv + integer(I8), allocatable :: keys(:),splitters(:) + integer :: i,r,d,ierr + + ! Global reference bounds + blo=huge(1.0_WP); bhi=-huge(1.0_WP) + do i=1,n_in + blo=min(blo,pos_in(:,i)); bhi=max(bhi,pos_in(:,i)) + end do + call MPI_ALLREDUCE(MPI_IN_PLACE,blo,3,MPI_REAL_WP,MPI_MIN,comm,ierr) + call MPI_ALLREDUCE(MPI_IN_PLACE,bhi,3,MPI_REAL_WP,MPI_MAX,comm,ierr) + do d=1,3 + inv(d)=0.0_WP + if (bhi(d).gt.blo(d)) inv(d)=2097151.0_WP/(bhi(d)-blo(d)) + end do + + ! Morton keys of this rank's nodes + allocate(keys(max(n_in,1))) + do i=1,n_in + keys(i)=morton(pos_in(:,i),blo,inv) + end do + + ! Equal-weight splitters by SAMPLE SORT: each rank contributes a few + ! evenly-spaced samples of its locally sorted keys, weighted by its node + ! count -- root memory is O(nproc*S), not O(N_global), so this scales to + ! very large rank counts (the old gather-all-keys approach walled at + ! root memory and int32 N_global). + allocate(splitters(max(nproc-1,1))) + sample_splitters: block + integer, parameter :: S=16 + integer(I8), allocatable :: lsamp(:),gsamp(:),gw(:) + real(WP), allocatable :: w(:) + integer, allocatable :: perm(:),zk(:),scnt(:),sdis(:) + integer(I8) :: wtot,wcum,wtarg + integer :: ns,j,r2,gtot + ! Locally sort keys (permutation) and draw samples + allocate(perm(max(n_in,1)),zk(max(n_in,1))) + do i=1,n_in + perm(i)=i + end do + zk=0 + if (n_in.gt.1) call sort3_perm(zk,keys(1:n_in),zk,perm,1,n_in) + ns=min(S,n_in) + allocate(lsamp(max(ns,1))) + do j=1,ns + lsamp(j)=keys(perm(min(n_in,int((real(j,WP)-0.5_WP)*real(n_in,WP)/real(ns,WP))+1))) + end do + deallocate(perm,zk) + ! Gather samples (+ per-rank sample counts and node counts) on root + allocate(scnt(nproc),sdis(nproc)) + call MPI_GATHER(ns,1,MPI_INTEGER,scnt,1,MPI_INTEGER,0,comm,ierr) + gtot=0 + if (amRoot) then + sdis(1)=0 + do r2=2,nproc + sdis(r2)=sdis(r2-1)+scnt(r2-1) + end do + gtot=sum(scnt) + end if + allocate(gsamp(max(gtot,1)),gw(nproc)) + call MPI_GATHERV(lsamp,ns,MPI_INTEGER8,gsamp,scnt,sdis,MPI_INTEGER8,0,comm,ierr) + call MPI_GATHER(int(n_in,I8),1,MPI_INTEGER8,gw,1,MPI_INTEGER8,0,comm,ierr) + if (amRoot.and.gtot.gt.0) then + root_split: block + integer, allocatable :: p2(:),z2(:) + real(WP), allocatable :: sw(:) + ! Weight each sample by (its rank's node count)/(its rank's samples) + allocate(sw(gtot),p2(gtot),z2(gtot)) + do r2=1,nproc + do j=sdis(r2)+1,sdis(r2)+scnt(r2) + sw(j)=real(gw(r2),WP)/real(max(scnt(r2),1),WP) + end do + end do + do j=1,gtot + p2(j)=j + end do + z2=0 + call sort3_perm(z2,gsamp(1:gtot),z2,p2,1,gtot) + ! Single cumulative-weight pass placing all nproc-1 splitters + wtot=sum(gw) + wcum=0_I8; r2=1 + do j=1,gtot + if (r2.gt.nproc-1) exit + wcum=wcum+int(sw(p2(j)),I8) + do while (r2.le.nproc-1.and.wcum.ge.(int(r2,I8)*wtot)/int(nproc,I8)) + splitters(r2)=gsamp(p2(j)) + r2=r2+1 + end do + end do + do while (r2.le.nproc-1) + splitters(r2)=huge(1_I8) ! degenerate tail: empty upper buckets + r2=r2+1 + end do + deallocate(sw,p2,z2) + end block root_split + end if + deallocate(lsamp,gsamp,gw,scnt,sdis) + end block sample_splitters + if (nproc.gt.1) call MPI_BCAST(splitters,nproc-1,MPI_INTEGER8,0,comm,ierr) + + ! Assign owners: bucket = number of splitters <= key + do i=1,n_in + owner_out(i)=0 + do r=1,nproc-1 + if (keys(i).ge.splitters(r)) owner_out(i)=r + end do + end do + deallocate(keys,splitters) + + ! Route node payloads to their owners + route_nodes: block + integer, dimension(0:nproc-1) :: sc,rc,sd,rd,scw,rcw,sdw,rdw + integer, allocatable :: pos(:),sflag(:) + integer(I8), allocatable :: sgid(:) + real(WP), allocatable :: sdat(:,:),rdat(:,:) + sc=0 + do i=1,n_in + sc(owner_out(i))=sc(owner_out(i))+1 + end do + call MPI_ALLTOALL(sc,1,MPI_INTEGER,rc,1,MPI_INTEGER,comm,ierr) + sd(0)=0; rd(0)=0 + do r=1,nproc-1 + sd(r)=sd(r-1)+sc(r-1); rd(r)=rd(r-1)+rc(r-1) + end do + n_out=sum(rc) + allocate(pos(0:nproc-1),sgid(max(n_in,1)),sflag(max(n_in,1)),sdat(7,max(n_in,1))) + pos=sd + do i=1,n_in + r=owner_out(i); pos(r)=pos(r)+1 + sgid(pos(r))=gid_in(i) + sflag(pos(r))=flag_in(i) + sdat(1:3,pos(r))=pos_in(:,i) + sdat(4:6,pos(r))=vel_in(:,i) + sdat(7,pos(r)) =vol_in(i) + end do + allocate(gid_out(max(n_out,1)),flag_out(max(n_out,1)),rdat(7,max(n_out,1))) + allocate(pos_out(3,max(n_out,1)),vel_out(3,max(n_out,1)),vol_out(max(n_out,1))) + call MPI_ALLTOALLV(sgid,sc,sd,MPI_INTEGER8,gid_out,rc,rd,MPI_INTEGER8,comm,ierr) + call MPI_ALLTOALLV(sflag,sc,sd,MPI_INTEGER,flag_out,rc,rd,MPI_INTEGER,comm,ierr) + scw=7*sc; sdw=7*sd; rcw=7*rc; rdw=7*rd + call MPI_ALLTOALLV(sdat,scw,sdw,MPI_REAL_WP,rdat,rcw,rdw,MPI_REAL_WP,comm,ierr) + do i=1,n_out + pos_out(:,i)=rdat(1:3,i) + vel_out(:,i)=rdat(4:6,i) + vol_out(i) =rdat(7,i) + end do + deallocate(pos,sgid,sflag,sdat,rdat) + end block route_nodes + + contains + + !> 63-bit Morton key: 21 bits per dimension, bit-interleaved + pure function morton(p,lo,inv) result(key) + implicit none + real(WP), dimension(3), intent(in) :: p,lo,inv + integer(I8) :: key + integer(I8), dimension(3) :: ix + integer :: b,d + do d=1,3 + ix(d)=int(min(max((p(d)-lo(d))*inv(d),0.0_WP),2097151.0_WP),I8) + end do + key=0_I8 + do b=0,20 + do d=1,3 + if (btest(ix(d),b)) key=ibset(key,3*b+d-1) + end do + end do + end function morton + + end subroutine pd_partition + + + !> Bin geometry: cell size >= the search radius (so +/-1 cell sweeps are complete), + !> dims clamped to keep total cell count bounded on huge/degenerate extents + subroutine setup_bins(lo,hi,r,gl,h,nc) + real(WP), dimension(3), intent(in) :: lo,hi + real(WP), intent(in) :: r + real(WP), dimension(3), intent(out) :: gl,h + integer, dimension(3), intent(out) :: nc + integer :: d + do d=1,3 + gl(d)=lo(d)-0.5_WP*r + nc(d)=max(1,min(256,int((hi(d)-lo(d)+r)/r))) + h(d)=max((hi(d)+0.5_WP*r-gl(d))/real(nc(d),WP),r) + end do + end subroutine setup_bins + + !> Flattened cell index of a position (clamped into the grid) + pure function cell_of(p,gl,h,nc) result(k) + real(WP), dimension(3), intent(in) :: p,gl,h + integer, dimension(3), intent(in) :: nc + integer :: k,c(3),d + do d=1,3 + c(d)=min(nc(d),max(1,int((p(d)-gl(d))/h(d))+1)) + end do + k=c(1)+nc(1)*(c(2)-1)+nc(1)*nc(2)*(c(3)-1) + end function cell_of + + + !> Influence function w(zeta) (Peridigm forms). ONE form active, hard-coded; + !> flip by (un)commenting -- s0-from-G_c, psi_fac, and the critical-dt + !> diagnostic all generalize through wmoment(), so nothing else changes. + pure function omega(d,h) result(w) + implicit none + real(WP), intent(in) :: d,h + real(WP) :: w + real(WP) :: s + ! Parabolic decay (ACTIVE): 1 in the core, C1 taper to 0 at the horizon + s=d/h + if (s.lt.0.5_WP) then + w=1.0_WP + else + w=max(4.0_WP*s*(1.0_WP-s),0.0_WP) + end if + ! Constant (Peridigm default; pre-2026-07-16 behavior) + !w=1.0_WP + ! Gaussian + !w=exp(-(d/(0.4_WP*h))**2) + end function omega + + !> Moment of the influence function: int_0^delta w(z)^wpow * z^zpow dz + !> (midpoint quadrature through omega(), so any form change propagates) + pure function wmoment(delta,zpow,wpow) result(m) + implicit none + real(WP), intent(in) :: delta + integer, intent(in) :: zpow,wpow + real(WP) :: m + integer, parameter :: NQ=2048 + integer :: i + real(WP) :: z,dz + dz=delta/real(NQ,WP) + m=0.0_WP + do i=1,NQ + z=(real(i,WP)-0.5_WP)*dz + m=m+omega(z,delta)**wpow*z**zpow + end do + m=m*dz + end function wmoment + + !> Lexicographic sign of an image shift: .true. for the "positive" member + !> of a self-image pair (first nonzero component positive), so each + !> self-image bond is census-counted exactly once. + pure function shift_positive(s) result(p) + implicit none + real(WP), dimension(3), intent(in) :: s + logical :: p + integer :: d + p=.false. + do d=1,3 + if (abs(s(d)).gt.0.0_WP) then + p=(s(d).gt.0.0_WP) + return + end if + end do + end function shift_positive + + !> Negate a packed periodic image offset (amrpd hist1 convention) + pure function negkey(key) result(nk) + implicit none + integer, intent(in) :: key + integer :: nk,n1,n2,n3 + n1=mod(key,256)-128; n2=mod(key/256,256)-128; n3=key/65536-128 + nk=(-n1+128)+(-n2+128)*256+(-n3+128)*65536 + end function negkey + +end module pdsolver_class diff --git a/src/config/ibconfig_class.f90 b/src/config/ibconfig_class.f90 index 86494bc8a..71060e7e6 100644 --- a/src/config/ibconfig_class.f90 +++ b/src/config/ibconfig_class.f90 @@ -22,7 +22,7 @@ module ibconfig_class type, extends(config) :: ibconfig real(WP), dimension(:,:,:), allocatable :: Gib !< Level set function, negative in fluid and positive in solid - real(WP), dimension(:,:,:,:), allocatable :: Nib !< IB normal vector, oriented into the solid + real(WP), dimension(:,:,:,:), allocatable :: Nib !< IB normal vector, oriented into the solid !output Nib(1,:,:,:), Nib(2,:,:,:) real(WP), dimension(:,:,:), allocatable :: SD !< Surface density of wall in the cell contains diff --git a/src/immersed/gp_class.f90 b/src/immersed/gp_class.f90 index 26f7fbb9d..398f455dc 100644 --- a/src/immersed/gp_class.f90 +++ b/src/immersed/gp_class.f90 @@ -43,6 +43,9 @@ module gp_class type(ghost), dimension(:), allocatable :: gpy !< Array of ghost points at Y-face type(ghost), dimension(:), allocatable :: gpz !< Array of ghost points at Z-face real(WP), dimension(:,:,:), allocatable :: label !< Integer array used for labeling ghost/image points + real(WP), dimension(:,:,:), allocatable :: label_x + real(WP), dimension(:,:,:), allocatable :: label_y + real(WP), dimension(:,:,:), allocatable :: label_z contains @@ -83,6 +86,9 @@ function constructor(cfg,no) result(self) ! Allocate label array (0=fluid cell, +1=ghost point, -1=image point) allocate(self%label(self%cfg%imino_:self%cfg%imaxo_,self%cfg%jmino_:self%cfg%jmaxo_,self%cfg%kmino_:self%cfg%kmaxo_)); self%label=0.0_WP + allocate(self%label_x(self%cfg%imino_:self%cfg%imaxo_,self%cfg%jmino_:self%cfg%jmaxo_,self%cfg%kmino_:self%cfg%kmaxo_)); self%label_x=0.0_WP + allocate(self%label_y(self%cfg%imino_:self%cfg%imaxo_,self%cfg%jmino_:self%cfg%jmaxo_,self%cfg%kmino_:self%cfg%kmaxo_)); self%label_y=0.0_WP + allocate(self%label_z(self%cfg%imino_:self%cfg%imaxo_,self%cfg%jmino_:self%cfg%jmaxo_,self%cfg%kmino_:self%cfg%kmaxo_)); self%label_z=0.0_WP end function constructor @@ -290,6 +296,10 @@ subroutine update(this) end do call this%cfg%syncsum(this%label) + + + + ! X-face !======================================================================================== ! Identify ghost points @@ -413,6 +423,15 @@ subroutine update(this) end do end do + this%label_x=0.0_WP + do n=1,this%ngpx + i=this%gpx(n)%ind(1); j=this%gpx(n)%ind(2); k=this%gpx(n)%ind(3) + this%label_x(i,j,k)=+1.0_WP !< Ghost point + i=this%gpx(n)%im%ind(1); j=this%gpx(n)%im%ind(2); k=this%gpx(n)%im%ind(3) + this%label_x(i,j,k)=-1.0_WP !< Image points + end do + call this%cfg%syncsum(this%label_x) + ! Y-face !======================================================================================== ! Identify ghost points @@ -537,6 +556,15 @@ subroutine update(this) end do end do + this%label_y=0.0_WP + do n=1,this%ngpy + i=this%gpy(n)%ind(1); j=this%gpy(n)%ind(2); k=this%gpy(n)%ind(3) + this%label_y(i,j,k)=+1.0_WP !< Ghost point + i=this%gpy(n)%im%ind(1); j=this%gpy(n)%im%ind(2); k=this%gpy(n)%im%ind(3) + this%label_y(i,j,k)=-1.0_WP !< Image points + end do + call this%cfg%syncsum(this%label_y) + ! Z-face !======================================================================================== ! Identify ghost points @@ -660,6 +688,15 @@ subroutine update(this) end do end do + this%label_z=0.0_WP + do n=1,this%ngpz + i=this%gpz(n)%ind(1); j=this%gpz(n)%ind(2); k=this%gpz(n)%ind(3) + this%label_z(i,j,k)=+1.0_WP !< Ghost point + i=this%gpz(n)%im%ind(1); j=this%gpz(n)%im%ind(2); k=this%gpz(n)%im%ind(3) + this%label_z(i,j,k)=-1.0_WP !< Image points + end do + call this%cfg%syncsum(this%label_z) + ! Clean up deallocate(Gx,Gy,Gz,Nx,Ny,Nz,itpr_x,itpr_y,itpr_z)