From 74373c4d4b1314452a95ed8bd561fb3b21be2473 Mon Sep 17 00:00:00 2001 From: Ian Mauser Date: Fri, 21 Nov 2025 14:18:38 -0500 Subject: [PATCH 01/25] Changes to gp_class --- src/config/ibconfig_class.f90 | 2 +- src/immersed/gp_class.f90 | 27 ++++++++++++++++++++++++++- 2 files changed, 27 insertions(+), 2 deletions(-) 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..4a37c31bc 100644 --- a/src/immersed/gp_class.f90 +++ b/src/immersed/gp_class.f90 @@ -43,7 +43,8 @@ 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 contains procedure :: update !< Update ghost point information @@ -83,6 +84,8 @@ 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 end function constructor @@ -290,6 +293,10 @@ subroutine update(this) end do call this%cfg%syncsum(this%label) + + + + ! X-face !======================================================================================== ! Identify ghost points @@ -413,6 +420,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 +553,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 From 439e4a566cb7df74f33a30c73ae1e124ee3e73e0 Mon Sep 17 00:00:00 2001 From: Ian Mauser Date: Wed, 17 Dec 2025 13:53:21 -0500 Subject: [PATCH 02/25] Added a z component to the gp_class ibm labels for 3d cases --- src/immersed/gp_class.f90 | 12 ++++++++++++ 1 file changed, 12 insertions(+) diff --git a/src/immersed/gp_class.f90 b/src/immersed/gp_class.f90 index 4a37c31bc..398f455dc 100644 --- a/src/immersed/gp_class.f90 +++ b/src/immersed/gp_class.f90 @@ -45,6 +45,8 @@ module gp_class 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 procedure :: update !< Update ghost point information @@ -86,6 +88,7 @@ function constructor(cfg,no) result(self) 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 @@ -685,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) From b1a517fb8c88fc7085c205e5edb960cd723ad37f Mon Sep 17 00:00:00 2001 From: ivmauser Date: Mon, 26 Jan 2026 10:36:39 -0500 Subject: [PATCH 03/25] Current instance of the spherical case we are running Current instance of the spherical case we are running --- examples/sphere_peri/GNUmakefile | 49 + examples/sphere_peri/input | 36 + examples/sphere_peri/src/Make.package | 2 + examples/sphere_peri/src/geometry.f90 | 73 + examples/sphere_peri/src/lss_class.f90 | 1733 +++++++++++++++++++++ examples/sphere_peri/src/simulation.f90 | 854 ++++++++++ examples/sphere_peri/src/spcomp_class.f90 | 867 +++++++++++ 7 files changed, 3614 insertions(+) create mode 100644 examples/sphere_peri/GNUmakefile create mode 100644 examples/sphere_peri/input create mode 100644 examples/sphere_peri/src/Make.package create mode 100644 examples/sphere_peri/src/geometry.f90 create mode 100644 examples/sphere_peri/src/lss_class.f90 create mode 100644 examples/sphere_peri/src/simulation.f90 create mode 100644 examples/sphere_peri/src/spcomp_class.f90 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 From 50b446aeb680e9fc16abd13386c72eefa86f07f2 Mon Sep 17 00:00:00 2001 From: ivmauser Date: Tue, 31 Mar 2026 19:37:45 -0400 Subject: [PATCH 04/25] Beam Test Current State --- .gitignore | 2 + examples/beam_test/GNUmakefile | 49 + examples/beam_test/input | 26 + examples/beam_test/src/Make.package | 2 + examples/beam_test/src/geometry.f90 | 128 ++ examples/beam_test/src/lss_class.f90 | 1636 ++++++++++++++++ examples/beam_test/src/lss_class_3_axis.f90 | 1637 +++++++++++++++++ examples/beam_test/src/lss_class_stl.f90 | 1636 ++++++++++++++++ examples/beam_test/src/lss_class_working.f90 | 1637 +++++++++++++++++ examples/beam_test/src/simulation.f90 | 753 ++++++++ examples/beam_test/src/simulation_stl.f90 | 741 ++++++++ examples/beam_test/src/simulation_working.f90 | 753 ++++++++ examples/beam_test/src/spcomp_class.f90 | 942 ++++++++++ 13 files changed, 9942 insertions(+) create mode 100644 examples/beam_test/GNUmakefile create mode 100644 examples/beam_test/input create mode 100644 examples/beam_test/src/Make.package create mode 100644 examples/beam_test/src/geometry.f90 create mode 100644 examples/beam_test/src/lss_class.f90 create mode 100644 examples/beam_test/src/lss_class_3_axis.f90 create mode 100644 examples/beam_test/src/lss_class_stl.f90 create mode 100644 examples/beam_test/src/lss_class_working.f90 create mode 100644 examples/beam_test/src/simulation.f90 create mode 100644 examples/beam_test/src/simulation_stl.f90 create mode 100644 examples/beam_test/src/simulation_working.f90 create mode 100644 examples/beam_test/src/spcomp_class.f90 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/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..2a2ec46dd --- /dev/null +++ b/examples/beam_test/src/lss_class.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 + ! 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_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 From cbcd023a44da713643a1bed6033c5cb7a011fedd Mon Sep 17 00:00:00 2001 From: ivmauser Date: Tue, 31 Mar 2026 21:25:04 -0400 Subject: [PATCH 05/25] Now corrected to find dilatation corrections without compounding effects --- examples/beam_test/src/lss_class.f90 | 38 +++++++++++++++++++++------- 1 file changed, 29 insertions(+), 9 deletions(-) diff --git a/examples/beam_test/src/lss_class.f90 b/examples/beam_test/src/lss_class.f90 index 2a2ec46dd..cb12467ea 100644 --- a/examples/beam_test/src/lss_class.f90 +++ b/examples/beam_test/src/lss_class.f90 @@ -674,13 +674,18 @@ subroutine stretch(this,dt)!,stress_x,stress_y,stress_z) 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 + ! 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 @@ -692,7 +697,8 @@ subroutine stretch(this,dt)!,stress_x,stress_y,stress_z) 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 + !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 !======================================================================================== @@ -701,8 +707,10 @@ subroutine stretch(this,dt)!,stress_x,stress_y,stress_z) 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 + ! 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 @@ -714,7 +722,8 @@ subroutine stretch(this,dt)!,stress_x,stress_y,stress_z) 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 + !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 !======================================================================================== @@ -723,8 +732,10 @@ subroutine stretch(this,dt)!,stress_x,stress_y,stress_z) 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 + ! 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 @@ -736,16 +747,25 @@ subroutine stretch(this,dt)!,stress_x,stress_y,stress_z) 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 + !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 + !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_ From 9133e3ae7f3dc6a67b9e214a9784f6c2e74934c1 Mon Sep 17 00:00:00 2001 From: ivmauser Date: Tue, 7 Apr 2026 14:17:17 -0400 Subject: [PATCH 06/25] Plate With Hole Current --- examples/plate_with_hole/GNUmakefile | 49 + examples/plate_with_hole/input | 27 + examples/plate_with_hole/src/Make.package | 2 + examples/plate_with_hole/src/geometry.f90 | 136 ++ examples/plate_with_hole/src/lss_class.f90 | 1589 ++++++++++++++++ .../plate_with_hole/src/lss_class_3_axis.f90 | 1637 +++++++++++++++++ .../plate_with_hole/src/lss_class_stl.f90 | 1636 ++++++++++++++++ .../plate_with_hole/src/lss_class_working.f90 | 1637 +++++++++++++++++ examples/plate_with_hole/src/simulation.f90 | 773 ++++++++ .../plate_with_hole/src/simulation_stl.f90 | 741 ++++++++ .../src/simulation_working.f90 | 753 ++++++++ examples/plate_with_hole/src/spcomp_class.f90 | 942 ++++++++++ 12 files changed, 9922 insertions(+) create mode 100644 examples/plate_with_hole/GNUmakefile create mode 100644 examples/plate_with_hole/input create mode 100644 examples/plate_with_hole/src/Make.package create mode 100644 examples/plate_with_hole/src/geometry.f90 create mode 100644 examples/plate_with_hole/src/lss_class.f90 create mode 100644 examples/plate_with_hole/src/lss_class_3_axis.f90 create mode 100644 examples/plate_with_hole/src/lss_class_stl.f90 create mode 100644 examples/plate_with_hole/src/lss_class_working.f90 create mode 100644 examples/plate_with_hole/src/simulation.f90 create mode 100644 examples/plate_with_hole/src/simulation_stl.f90 create mode 100644 examples/plate_with_hole/src/simulation_working.f90 create mode 100644 examples/plate_with_hole/src/spcomp_class.f90 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..8ef6ce355 --- /dev/null +++ b/examples/plate_with_hole/input @@ -0,0 +1,27 @@ +# 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 : 10000000 +Horizon Ratio : 3.015 +Solid Spacing: 0.00125 + +# Time integration +Max timestep size : 2e-6 +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.f90 b/examples/plate_with_hole/src/geometry.f90 new file mode 100644 index 000000000..d32d69565 --- /dev/null +++ b/examples/plate_with_hole/src/geometry.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/lss_class.f90 b/examples/plate_with_hole/src/lss_class.f90 new file mode 100644 index 000000000..2da692ce5 --- /dev/null +++ b/examples/plate_with_hole/src/lss_class.f90 @@ -0,0 +1,1589 @@ +!> 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(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=[28+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,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 + ! !======================================================================================== + ! ! 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 + + !> 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..c6f00e0a9 --- /dev/null +++ b/examples/plate_with_hole/src/simulation.f90 @@ -0,0 +1,773 @@ +!> 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..9c7e1c8b1 --- /dev/null +++ b/examples/plate_with_hole/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/plate_with_hole/src/simulation_working.f90 b/examples/plate_with_hole/src/simulation_working.f90 new file mode 100644 index 000000000..cddf0d3e5 --- /dev/null +++ b/examples/plate_with_hole/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/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 From d7853da7b9a36e16111a068236a4ba0e9897d98c Mon Sep 17 00:00:00 2001 From: ivmauser Date: Tue, 14 Apr 2026 10:31:28 -0400 Subject: [PATCH 07/25] Some Updates More agnostic setup for Lengths of plate Geometry is now larger to accomodate the placment and create some extra space Lss now additionally tracky gd and gb again, number of overlap cells is set to 2, not 1, Gd is back on (did not seem to do much), stretch is uncommented and now is checked for every particle, not just moving ones Simulation_stl is setup with proper shifting to keep in bounds and with proepr id tag order (bug fix from before). Does not output ste, does output von-Mises and displacement Simulation working now takes in parameters and peropely adjusts domain to account for intput files, same output stats as simulation_stl --- examples/plate_with_hole/input | 5 +- .../plate_with_hole/src/geometry copy.f90 | 136 +++++++++++++ examples/plate_with_hole/src/geometry.f90 | 5 +- examples/plate_with_hole/src/lss_class.f90 | 183 +++++++++--------- examples/plate_with_hole/src/simulation.f90 | 32 +-- .../plate_with_hole/src/simulation_stl.f90 | 38 ++-- .../src/simulation_working.f90 | 70 ++++--- 7 files changed, 324 insertions(+), 145 deletions(-) create mode 100644 examples/plate_with_hole/src/geometry copy.f90 diff --git a/examples/plate_with_hole/input b/examples/plate_with_hole/input index 8ef6ce355..438d91796 100644 --- a/examples/plate_with_hole/input +++ b/examples/plate_with_hole/input @@ -14,12 +14,13 @@ Subdivisions : 33 Elastic Modulus : 200e9 Poisson Ratio : 0.30 Solid density : 7850 -Critical Energy Release Rate : 10000000 +Critical Energy Release Rate : 100000 Horizon Ratio : 3.015 Solid Spacing: 0.00125 +Mean Particle Spacing : 0.00125 # Time integration -Max timestep size : 2e-6 +Max timestep size : 2.0e-7 Max cfl number : 1.1 Max time : 0.01 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 index d32d69565..489b56b99 100644 --- a/examples/plate_with_hole/src/geometry.f90 +++ b/examples/plate_with_hole/src/geometry.f90 @@ -42,10 +42,11 @@ subroutine geometry_init ! 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) + nz = ceiling(Lz/dx)+2 allocate(x(nx+1)) allocate(y(ny+1)) @@ -59,7 +60,7 @@ subroutine geometry_init 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 + 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') diff --git a/examples/plate_with_hole/src/lss_class.f90 b/examples/plate_with_hole/src/lss_class.f90 index 2da692ce5..2b9fee7f5 100644 --- a/examples/plate_with_hole/src/lss_class.f90 +++ b/examples/plate_with_hole/src/lss_class.f90 @@ -40,6 +40,8 @@ module lss_class 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 @@ -51,7 +53,7 @@ module lss_class 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=[28+max_bond,7+max_bond] + 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 @@ -129,7 +131,7 @@ module lss_class procedure :: get_delta !< Compute regularized delta function procedure :: interpolate !< Interpolation routine from mesh=>marker procedure :: extrapolate !< Extrapolation routine from marker=>mesh - ! procedure :: stretch + procedure :: stretch end type lss @@ -172,7 +174,7 @@ function constructor(cfg,name) result(self) ! Set default bonding horizon based on underlying mesh self%delta=self%cfg%min_meshsize - self%nb=1 + self%nb=2 self%min_dist=huge(1.0_WP) ! Allocate variables @@ -418,11 +420,11 @@ subroutine get_bond_force(this) 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_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 )) + 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 + 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 @@ -528,11 +530,11 @@ subroutine get_bond_force(this) 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)*(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 + 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 @@ -547,8 +549,8 @@ subroutine get_bond_force(this) 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 + ! 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 @@ -680,103 +682,106 @@ subroutine advance(this,dt)!,stress_x,stress_y,stress_z) 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() + 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 - ! ! Calculate bond force - ! call this%get_bond_force() + 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() - ! mu=this%elastic_modulus/(2.0_WP+2.0_WP*this%poisson_ratio) + ! Calculate bond force + call this%get_bond_force() - ! 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 + mu=this%elastic_modulus/(2.0_WP+2.0_WP*this%poisson_ratio) - ! !======================================================================================== - ! ! 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() + do n=1,this%np_ + temp_gd(n,1)=0.001_WP/this%p(n)%dil + end do - ! ! Calculate bond force - ! call this%get_bond_force() + !======================================================================================== + ! 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() - ! mu=this%elastic_modulus/(2.0_WP+2.0_WP*this%poisson_ratio) + ! 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 + 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 - ! 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() + !======================================================================================== + ! 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() + ! Calculate bond force + call this%get_bond_force() - ! mu=this%elastic_modulus/(2.0_WP+2.0_WP*this%poisson_ratio) + 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 + 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_ - ! if (this%p(n)%id.gt.-2) this%p(n)%pos(3)=this%p(n)%pos(3)/1.001_WP - ! 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 + ! 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 + 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() + ! Communicate particles + call this%sync() + ! Calculate bond force + call this%get_bond_force() + deallocate(temp_gd) - ! end subroutine stretch + end subroutine stretch !> Update particle volume fraction using our current particles subroutine update_VF(this) diff --git a/examples/plate_with_hole/src/simulation.f90 b/examples/plate_with_hole/src/simulation.f90 index c6f00e0a9..b5584ed0a 100644 --- a/examples/plate_with_hole/src/simulation.f90 +++ b/examples/plate_with_hole/src/simulation.f90 @@ -523,8 +523,8 @@ subroutine simulation_init 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)%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 @@ -693,22 +693,24 @@ subroutine simulation_run 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 + 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 diff --git a/examples/plate_with_hole/src/simulation_stl.f90 b/examples/plate_with_hole/src/simulation_stl.f90 index 9c7e1c8b1..2cf330826 100644 --- a/examples/plate_with_hole/src/simulation_stl.f90 +++ b/examples/plate_with_hole/src/simulation_stl.f90 @@ -473,8 +473,14 @@ subroutine simulation_init ! 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) @@ -495,13 +501,22 @@ subroutine simulation_init 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)%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 + 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 @@ -555,17 +570,16 @@ subroutine simulation_init create_pmesh: block use lss_class, only: max_bond integer :: i,n,nbond - pmesh=partmesh(nvar=5,nvec=4,name='solid') + 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)='ste' + pmesh%varname(5)='von-Mises' pmesh%vecname(1)='velocity' pmesh%vecname(2)='bond_force' - pmesh%vecname(3)='Gd' - pmesh%vecname(4)='Gb' + pmesh%vecname(3)='disp' call ls%update_partmesh(pmesh) do i=1,ls%np_ pmesh%var(1,i)=0.0_WP @@ -583,9 +597,8 @@ subroutine simulation_init 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 + pmesh%var(5,i) =ls%p(i)%vonMises + pmesh%vec(:,3,i) =ls%p(i)%displacement end do end block create_pmesh @@ -708,9 +721,8 @@ subroutine simulation_run 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 + pmesh%var(5,i) =ls%p(i)%vonMises + pmesh%vec(:,3,i) =ls%p(i)%displacement end do diff --git a/examples/plate_with_hole/src/simulation_working.f90 b/examples/plate_with_hole/src/simulation_working.f90 index cddf0d3e5..b5584ed0a 100644 --- a/examples/plate_with_hole/src/simulation_working.f90 +++ b/examples/plate_with_hole/src/simulation_working.f90 @@ -295,6 +295,7 @@ end subroutine apply_bconds !> Initialization of problem solver subroutine simulation_init + use param, only: param_read,param_exists implicit none @@ -437,7 +438,7 @@ subroutine simulation_init 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) :: 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 @@ -469,11 +470,19 @@ subroutine simulation_init ! Discretization ! ls%delta=fs%cfg%min_meshsize*1.01 ! Load',P_load) - Lx = 1.0_WP - dist = 0.01_WP ! Space between particles + 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 - ny = 3 - nz = 3 + ! 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 @@ -494,27 +503,36 @@ subroutine simulation_init net_vol = 0.0_WP global_index = 0 target_index = 0 - ! Read in grid definition - wall_np = (3*ny)*(3*nz)*(nx) + 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,3*ny - do k=1,3*nz + 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) = (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)%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=-2 + 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(i.gt.3) net_vol=net_vol+ls%p(p)%vol + 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 @@ -567,17 +585,16 @@ subroutine simulation_init create_pmesh: block use lss_class, only: max_bond integer :: i,n,nbond - pmesh=partmesh(nvar=5,nvec=4,name='solid') + 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)='ste' + pmesh%varname(5)='von-Mises' pmesh%vecname(1)='velocity' pmesh%vecname(2)='bond_force' - pmesh%vecname(3)='Gd' - pmesh%vecname(4)='Gb' + pmesh%vecname(3)='disp' call ls%update_partmesh(pmesh) do i=1,ls%np_ pmesh%var(1,i)=0.0_WP @@ -595,9 +612,8 @@ subroutine simulation_init 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 + pmesh%var(5,i) =ls%p(i)%vonMises + pmesh%vec(:,3,i) =ls%p(i)%displacement end do end block create_pmesh @@ -688,6 +704,13 @@ subroutine simulation_run ! ! 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 @@ -720,9 +743,8 @@ subroutine simulation_run 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 + pmesh%var(5,i) =ls%p(i)%vonMises + pmesh%vec(:,3,i) =ls%p(i)%displacement end do From 1bcbcb699a9637e10140b2abd20f17ef2623caab Mon Sep 17 00:00:00 2001 From: ivmauser Date: Wed, 22 Apr 2026 16:35:05 -0400 Subject: [PATCH 08/25] Beam under tension case with artificial damping for steady state --- examples/beam_tension/GNUmakefile | 49 + examples/beam_tension/input | 30 + examples/beam_tension/src/Make.package | 2 + examples/beam_tension/src/geometry copy.f90 | 136 ++ examples/beam_tension/src/geometry.f90 | 137 ++ examples/beam_tension/src/lss_class.f90 | 1606 ++++++++++++++++ .../beam_tension/src/lss_class_3_axis.f90 | 1637 +++++++++++++++++ examples/beam_tension/src/lss_class_stl.f90 | 1636 ++++++++++++++++ .../beam_tension/src/lss_class_working.f90 | 1637 +++++++++++++++++ examples/beam_tension/src/simulation.f90 | 790 ++++++++ examples/beam_tension/src/simulation_stl.f90 | 753 ++++++++ .../beam_tension/src/simulation_working.f90 | 775 ++++++++ examples/beam_tension/src/spcomp_class.f90 | 942 ++++++++++ 13 files changed, 10130 insertions(+) create mode 100644 examples/beam_tension/GNUmakefile create mode 100644 examples/beam_tension/input create mode 100644 examples/beam_tension/src/Make.package create mode 100644 examples/beam_tension/src/geometry copy.f90 create mode 100644 examples/beam_tension/src/geometry.f90 create mode 100644 examples/beam_tension/src/lss_class.f90 create mode 100644 examples/beam_tension/src/lss_class_3_axis.f90 create mode 100644 examples/beam_tension/src/lss_class_stl.f90 create mode 100644 examples/beam_tension/src/lss_class_working.f90 create mode 100644 examples/beam_tension/src/simulation.f90 create mode 100644 examples/beam_tension/src/simulation_stl.f90 create mode 100644 examples/beam_tension/src/simulation_working.f90 create mode 100644 examples/beam_tension/src/spcomp_class.f90 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 From fa1d9b11837987a40c30979f4639c571efe9848c Mon Sep 17 00:00:00 2001 From: ivmauser Date: Thu, 30 Apr 2026 15:32:46 -0400 Subject: [PATCH 09/25] NOSB Initial Implementation --- examples/NOSB/GNUmakefile | 49 + examples/NOSB/input | 30 + examples/NOSB/src/Make.package | 2 + examples/NOSB/src/geometry.f90 | 138 +++ examples/NOSB/src/lss_class.f90 | 1591 ++++++++++++++++++++++++++++ examples/NOSB/src/simulation.f90 | 776 ++++++++++++++ examples/NOSB/src/spcomp_class.f90 | 942 ++++++++++++++++ 7 files changed, 3528 insertions(+) create mode 100644 examples/NOSB/GNUmakefile create mode 100644 examples/NOSB/input create mode 100644 examples/NOSB/src/Make.package create mode 100644 examples/NOSB/src/geometry.f90 create mode 100644 examples/NOSB/src/lss_class.f90 create mode 100644 examples/NOSB/src/simulation.f90 create mode 100644 examples/NOSB/src/spcomp_class.f90 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..953a604a7 --- /dev/null +++ b/examples/NOSB/input @@ -0,0 +1,30 @@ +# Parallelization +Partition : 8 1 1 + + +# 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 +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 : 2 +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..c03a599fb --- /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 + 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/NOSB/src/lss_class.f90 b/examples/NOSB/src/lss_class.f90 new file mode 100644 index 000000000..2d0c0904f --- /dev/null +++ b/examples/NOSB/src/lss_class.f90 @@ -0,0 +1,1591 @@ +!> 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), 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) :: K_inv !< Inverse of shape tensor + real(WP), dimension(3,3) :: P !< First Piola-Kirchoff 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=[47+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) + 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 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 + real(WP), dimension(3,3) :: K_mat,E_mat,I_mat,traceE,S_mat + + 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 + 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 + p1%F=0.0_WP + p1%K_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 + ! 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)) + p1%K_inv(1,1) = (K_mat(2,2)*K_mat(3,3) - K_mat(2,3)*K_mat(3,2))/detK + p1%K_inv(2,1) = -(K_mat(2,1)*K_mat(3,3) - K_mat(2,3)*K_mat(3,1))/detK + p1%K_inv(3,1) = (K_mat(2,1)*K_mat(3,2) - K_mat(2,2)*K_mat(3,1))/detK + p1%K_inv(1,2) = -(K_mat(1,2)*K_mat(3,3) - K_mat(1,3)*K_mat(3,2))/detK + p1%K_inv(2,2) = (K_mat(1,1)*K_mat(3,3) - K_mat(1,3)*K_mat(3,1))/detK + p1%K_inv(3,2) = -(K_mat(1,1)*K_mat(3,2) - K_mat(1,2)*K_mat(3,1))/detK + p1%K_inv(1,3) = (K_mat(1,2)*K_mat(2,3) - K_mat(1,3)*K_mat(2,2))/detK + p1%K_inv(2,3) = -(K_mat(1,1)*K_mat(2,3) - K_mat(1,3)*K_mat(2,1))/detK + p1%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,p1%K_inv) + + ! Compute first Piola-Kirchoff stress tensor + 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%P = MATMUL(p1%F,S_mat) + ! 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(MATMUL(p1%P,p1%K_inv),xi) + ! Force density 2->1 + t2 = w*MATMUL(MATMUL(p2%P,p2%K_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..52776ccac --- /dev/null +++ b/examples/NOSB/src/simulation.f90 @@ -0,0 +1,776 @@ +!> 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 + 8 + 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-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-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+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 * 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=4,nvec=3,name='solid') + pmesh%varname(1)='failfrac' + pmesh%varname(2)='id' + pmesh%varname(3)='nbond' + pmesh%varname(4)='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)%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%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%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 From 9b7fda08e4d41237231e754cf7746ffc5b16d81b Mon Sep 17 00:00:00 2001 From: ivmauser Date: Thu, 30 Apr 2026 15:40:42 -0400 Subject: [PATCH 10/25] Slightly more efficient memory allocation --- examples/NOSB/src/lss_class.f90 | 37 +++++++++++++++++---------------- 1 file changed, 19 insertions(+), 18 deletions(-) diff --git a/examples/NOSB/src/lss_class.f90 b/examples/NOSB/src/lss_class.f90 index 2d0c0904f..d37121ac0 100644 --- a/examples/NOSB/src/lss_class.f90 +++ b/examples/NOSB/src/lss_class.f90 @@ -39,8 +39,7 @@ module lss_class 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) :: K_inv !< Inverse of shape tensor - real(WP), dimension(3,3) :: P !< First Piola-Kirchoff 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) @@ -51,7 +50,7 @@ module lss_class 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=[47+max_bond,7+max_bond] + 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 @@ -388,7 +387,7 @@ subroutine get_bond_force(this) integer :: nb,nbond real(WP), dimension(3) :: rpos, xi real(WP) :: dist,w,mu,kk,detK - real(WP), dimension(3,3) :: K_mat,E_mat,I_mat,traceE,S_mat + real(WP), dimension(3,3) :: K_mat,E_mat,I_mat,traceE,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 @@ -396,6 +395,7 @@ subroutine get_bond_force(this) 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 @@ -406,8 +406,8 @@ subroutine get_bond_force(this) 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%K_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 @@ -448,24 +448,25 @@ subroutine get_bond_force(this) 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)) - p1%K_inv(1,1) = (K_mat(2,2)*K_mat(3,3) - K_mat(2,3)*K_mat(3,2))/detK - p1%K_inv(2,1) = -(K_mat(2,1)*K_mat(3,3) - K_mat(2,3)*K_mat(3,1))/detK - p1%K_inv(3,1) = (K_mat(2,1)*K_mat(3,2) - K_mat(2,2)*K_mat(3,1))/detK - p1%K_inv(1,2) = -(K_mat(1,2)*K_mat(3,3) - K_mat(1,3)*K_mat(3,2))/detK - p1%K_inv(2,2) = (K_mat(1,1)*K_mat(3,3) - K_mat(1,3)*K_mat(3,1))/detK - p1%K_inv(3,2) = -(K_mat(1,1)*K_mat(3,2) - K_mat(1,2)*K_mat(3,1))/detK - p1%K_inv(1,3) = (K_mat(1,2)*K_mat(2,3) - K_mat(1,3)*K_mat(2,2))/detK - p1%K_inv(2,3) = -(K_mat(1,1)*K_mat(2,3) - K_mat(1,3)*K_mat(2,1))/detK - p1%K_inv(3,3) = (K_mat(1,1)*K_mat(2,2) - K_mat(1,2)*K_mat(2,1))/detK + 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,p1%K_inv) + p1%F = MATMUL(p1%F,K_inv) ! Compute first Piola-Kirchoff stress tensor 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%P = MATMUL(p1%F,S_mat) + p1%PK_inv = MATMUL(MATMUL(p1%F,S_mat),K_inv) + ! Copy back the particle this%p(n1)=p1 end do @@ -545,9 +546,9 @@ subroutine get_bond_force(this) w = wgauss(p1%dbond(nb),this%delta) xi = p2%ipos-p1%ipos ! Force density 1->2 - t1 = w*MATMUL(MATMUL(p1%P,p1%K_inv),xi) + t1 = w*MATMUL(p1%PK_inv,xi) ! Force density 2->1 - t2 = w*MATMUL(MATMUL(p2%P,p2%K_inv),xi) + 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 From 41434d87e96f9efbdb1de18e542cd2e9e61f2928 Mon Sep 17 00:00:00 2001 From: ivmauser Date: Thu, 30 Apr 2026 20:40:04 -0400 Subject: [PATCH 11/25] Implemented cubic, also fixed nb (1 is now ok based on sizing?) --- examples/NOSB/input | 2 +- examples/NOSB/src/lss_class.f90 | 6 +++--- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/examples/NOSB/input b/examples/NOSB/input index 953a604a7..b84c3707c 100644 --- a/examples/NOSB/input +++ b/examples/NOSB/input @@ -23,7 +23,7 @@ Solid Damping Constant : 0.015 # Time integration Max timestep size : 3.0e-7 -Max cfl number : 2 +Max cfl number : 1.3 Max time : 10 # Ensight output diff --git a/examples/NOSB/src/lss_class.f90 b/examples/NOSB/src/lss_class.f90 index d37121ac0..4efb6ba4c 100644 --- a/examples/NOSB/src/lss_class.f90 +++ b/examples/NOSB/src/lss_class.f90 @@ -147,13 +147,13 @@ real(WP) function wgauss(d,h) real(WP), intent(in) :: d,h real(WP), parameter :: coeff=2.6_WP real(WP) :: hh - hh=coeff*h + ! 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) + wgauss=(1.0_WP-d/h)**3 end if end function wgauss @@ -174,7 +174,7 @@ function constructor(cfg,name) result(self) ! Set default bonding horizon based on underlying mesh self%delta=self%cfg%min_meshsize - self%nb=2 + self%nb=1 self%min_dist=huge(1.0_WP) ! Allocate variables From 07d4035698be739d8d0b8560db22a81d0a800f3a Mon Sep 17 00:00:00 2001 From: ivmauser Date: Mon, 4 May 2026 14:31:12 -0400 Subject: [PATCH 12/25] Cirrection to how traceE is stored, added comment --- examples/NOSB/src/lss_class.f90 | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/examples/NOSB/src/lss_class.f90 b/examples/NOSB/src/lss_class.f90 index 4efb6ba4c..5ed0ed086 100644 --- a/examples/NOSB/src/lss_class.f90 +++ b/examples/NOSB/src/lss_class.f90 @@ -386,8 +386,8 @@ subroutine get_bond_force(this) type(part) :: p1,p2 integer :: nb,nbond real(WP), dimension(3) :: rpos, xi - real(WP) :: dist,w,mu,kk,detK - real(WP), dimension(3,3) :: K_mat,E_mat,I_mat,traceE,S_mat,K_inv + 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 @@ -461,7 +461,7 @@ subroutine get_bond_force(this) p1%F = MATMUL(p1%F,K_inv) - ! Compute first Piola-Kirchoff stress tensor + ! 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 From 8ecdc041dbcc9d2a89c9cb40a55efd6a032a159d Mon Sep 17 00:00:00 2001 From: ivmauser Date: Tue, 5 May 2026 10:09:25 -0400 Subject: [PATCH 13/25] Now should only apply force on end particle, and maintain length --- examples/NOSB/input | 4 ++-- examples/NOSB/src/geometry.f90 | 2 +- examples/NOSB/src/simulation.f90 | 8 ++++---- 3 files changed, 7 insertions(+), 7 deletions(-) diff --git a/examples/NOSB/input b/examples/NOSB/input index b84c3707c..e74be0075 100644 --- a/examples/NOSB/input +++ b/examples/NOSB/input @@ -1,11 +1,11 @@ # Parallelization -Partition : 8 1 1 +Partition : 9 1 1 # Beam Shape Lz : 0.01 Ly : 0.01 -Lx : 0.1 +Lx : .1 R : 0.000 Particle file: element_data.bin diff --git a/examples/NOSB/src/geometry.f90 b/examples/NOSB/src/geometry.f90 index c03a599fb..6bd8805f9 100644 --- a/examples/NOSB/src/geometry.f90 +++ b/examples/NOSB/src/geometry.f90 @@ -39,7 +39,7 @@ subroutine geometry_init ! dist = 0.01_WP ! Space between particles dist = Ly/N - Lx = Lx + 6.03_WP * dist ! total length of the beam + 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 diff --git a/examples/NOSB/src/simulation.f90 b/examples/NOSB/src/simulation.f90 index 52776ccac..2b8b502b8 100644 --- a/examples/NOSB/src/simulation.f90 +++ b/examples/NOSB/src/simulation.f90 @@ -486,7 +486,7 @@ subroutine simulation_init dist = Ly/N ny = N nz = N - nx = floor(Lx/Ly)*N + 8 + nx = floor(Lx/Ly)*N+6 call param_read('Horizon Ratio',ratio) ls%delta = dist*ratio @@ -528,12 +528,12 @@ subroutine simulation_init 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-2) net_vol=net_vol+ls%p(p)%vol + 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-2) ls%p(p)%Afluid=[(P_load/(dist**3 * ny * nz * 3))/(ls%rho),0.0_WP,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 @@ -550,7 +550,7 @@ subroutine simulation_init print*, "Ny: ", ny print*, "Nz: ", nz print*, "Net Force Volume", net_vol - print*, "Used Volume", (dist**3 * ny * nz * 3) + print*, "Used Volume", (dist**3 * ny * nz * 1) end block read_bin end if From 8ca3882bd0981d317ab93ebad6ae19d07cfa1845 Mon Sep 17 00:00:00 2001 From: ivmauser Date: Tue, 5 May 2026 13:10:49 -0400 Subject: [PATCH 14/25] Correction to ensure middle term --- examples/NOSB/src/lss_class.f90 | 5 ++++- examples/NOSB/src/simulation.f90 | 7 +++++-- 2 files changed, 9 insertions(+), 3 deletions(-) diff --git a/examples/NOSB/src/lss_class.f90 b/examples/NOSB/src/lss_class.f90 index 5ed0ed086..64a5ac46f 100644 --- a/examples/NOSB/src/lss_class.f90 +++ b/examples/NOSB/src/lss_class.f90 @@ -31,6 +31,7 @@ module lss_class !> 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 @@ -50,7 +51,7 @@ module lss_class 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] + 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 @@ -408,6 +409,7 @@ subroutine get_bond_force(this) 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 @@ -438,6 +440,7 @@ subroutine get_bond_force(this) 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 diff --git a/examples/NOSB/src/simulation.f90 b/examples/NOSB/src/simulation.f90 index 2b8b502b8..ce3eef99b 100644 --- a/examples/NOSB/src/simulation.f90 +++ b/examples/NOSB/src/simulation.f90 @@ -540,7 +540,7 @@ subroutine simulation_init 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 + 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 @@ -587,11 +587,12 @@ subroutine simulation_init create_pmesh: block use lss_class, only: max_bond integer :: i,n,nbond - pmesh=partmesh(nvar=4,nvec=3,name='solid') + 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' @@ -614,6 +615,7 @@ subroutine simulation_init 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 @@ -745,6 +747,7 @@ subroutine simulation_run 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 From 8bb7e1981bd3296fd9ff4b9c0f63f19ceb024a12 Mon Sep 17 00:00:00 2001 From: ivmauser Date: Thu, 7 May 2026 10:41:04 -0400 Subject: [PATCH 15/25] NOSB Plate with hole case --- examples/NOSB_plate_with_hole/GNUmakefile | 49 + examples/NOSB_plate_with_hole/input | 31 + .../NOSB_plate_with_hole/src/Make.package | 2 + .../NOSB_plate_with_hole/src/geometry.f90 | 138 ++ .../NOSB_plate_with_hole/src/lss_class.f90 | 1624 +++++++++++++++++ .../NOSB_plate_with_hole/src/simulation.f90 | 779 ++++++++ .../NOSB_plate_with_hole/src/spcomp_class.f90 | 942 ++++++++++ 7 files changed, 3565 insertions(+) create mode 100644 examples/NOSB_plate_with_hole/GNUmakefile create mode 100644 examples/NOSB_plate_with_hole/input create mode 100644 examples/NOSB_plate_with_hole/src/Make.package create mode 100644 examples/NOSB_plate_with_hole/src/geometry.f90 create mode 100644 examples/NOSB_plate_with_hole/src/lss_class.f90 create mode 100644 examples/NOSB_plate_with_hole/src/simulation.f90 create mode 100644 examples/NOSB_plate_with_hole/src/spcomp_class.f90 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..a4a493551 --- /dev/null +++ b/examples/NOSB_plate_with_hole/src/lss_class.f90 @@ -0,0 +1,1624 @@ +!> 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) :: damping_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,damp)!,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) :: damp + ! 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(damp) 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(damp.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..3697f0824 --- /dev/null +++ b/examples/NOSB_plate_with_hole/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,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('Damping time',ls%damping_time) + + ! 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 :: damping_on + + damping_on = .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%damping_time) damping_on = .true. + mydt=min(ls_dt,time%dtmid-dt_done) + ! ! Advance particles + call ls%advance(dt =mydt,damp = damping_on) + ! ! 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 From 17a2cd94876956e1a74af0e07b9adfe4d74a3e44 Mon Sep 17 00:00:00 2001 From: ivmauser Date: Thu, 7 May 2026 10:57:24 -0400 Subject: [PATCH 16/25] Now have separate cooldown and continuous or not for damping --- examples/NOSB_plate_with_hole/src/lss_class.f90 | 13 +++++++------ examples/NOSB_plate_with_hole/src/simulation.f90 | 11 ++++++----- 2 files changed, 13 insertions(+), 11 deletions(-) diff --git a/examples/NOSB_plate_with_hole/src/lss_class.f90 b/examples/NOSB_plate_with_hole/src/lss_class.f90 index a4a493551..b3c2439f0 100644 --- a/examples/NOSB_plate_with_hole/src/lss_class.f90 +++ b/examples/NOSB_plate_with_hole/src/lss_class.f90 @@ -73,7 +73,8 @@ module lss_class real(WP) :: rho !< Density of the material real(WP) :: crit_energy !< Critical energy release real(WP) :: beta !< Damping constant - real(WP) :: damping_time + 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) @@ -622,13 +623,13 @@ end subroutine get_bond_force !> p%id=-1 => do not solve for velocity !> p%id= 0 => do not update force - subroutine advance(this,dt,damp)!,stress_x,stress_y,stress_z) + 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) :: damp + 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_) @@ -638,15 +639,15 @@ subroutine advance(this,dt,damp)!,stress_x,stress_y,stress_z) ! Zero out number of particles removed this%np_out=0 - if(damp) then + 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 + print*, beta do n=1,this%np_ - if(damp.and.this%p(n)%id.eq.-1) this%p(n)%vel = 0.0_WP + 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 diff --git a/examples/NOSB_plate_with_hole/src/simulation.f90 b/examples/NOSB_plate_with_hole/src/simulation.f90 index 3697f0824..b293134fb 100644 --- a/examples/NOSB_plate_with_hole/src/simulation.f90 +++ b/examples/NOSB_plate_with_hole/src/simulation.f90 @@ -463,7 +463,8 @@ subroutine simulation_init 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('Damping time',ls%damping_time) + 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)) @@ -680,9 +681,9 @@ end subroutine simulation_init subroutine simulation_run implicit none real(WP) :: cfl - logical :: damping_on + logical :: cool_down_time - damping_on = .false. + cool_down_time = .false. ! Perform time integration do while (.not.time%done()) @@ -701,10 +702,10 @@ subroutine simulation_run dt_done=0.0_WP do while (dt_done.lt.time%dtmid) ! Decide the timestep size - if (time%t.gt.ls%damping_time) damping_on = .true. + 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,damp = damping_on) + call ls%advance(dt =mydt,cool_down = cool_down_time, continuous = ls%continuous_damping) ! ! Increment dt_done=dt_done+mydt From db7a31e073310b71d01d4542411fa0b814942bec Mon Sep 17 00:00:00 2001 From: ivmauser Date: Thu, 7 May 2026 11:00:14 -0400 Subject: [PATCH 17/25] Removed extra print statement from debugging --- examples/NOSB_plate_with_hole/src/lss_class.f90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/examples/NOSB_plate_with_hole/src/lss_class.f90 b/examples/NOSB_plate_with_hole/src/lss_class.f90 index b3c2439f0..a797e419f 100644 --- a/examples/NOSB_plate_with_hole/src/lss_class.f90 +++ b/examples/NOSB_plate_with_hole/src/lss_class.f90 @@ -645,7 +645,7 @@ subroutine advance(this,dt,cool_down,continuous)!,stress_x,stress_y,stress_z) beta = 0.0_WP end if ! Advance velocity based on old force and position based on mid-velocity - print*, beta + ! 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 From d0d97b662fd24a01fab226f078b1b3518d462410 Mon Sep 17 00:00:00 2001 From: ivmauser Date: Sun, 28 Jun 2026 13:21:53 -0600 Subject: [PATCH 18/25] NOSB Cylinder case (potentially corrected putting particles outside the domain) --- examples/cylinder_NOSB/GNUmakefile | 49 + examples/cylinder_NOSB/README | 1 + examples/cylinder_NOSB/input | 43 + examples/cylinder_NOSB/src/Make.package | 2 + examples/cylinder_NOSB/src/geometry.f90 | 71 + examples/cylinder_NOSB/src/incomp_class.f90 | 2128 +++++++++++++++++++ examples/cylinder_NOSB/src/lss_class.f90 | 1511 +++++++++++++ examples/cylinder_NOSB/src/simulation.f90 | 644 ++++++ 8 files changed, 4449 insertions(+) create mode 100644 examples/cylinder_NOSB/GNUmakefile create mode 100644 examples/cylinder_NOSB/README create mode 100644 examples/cylinder_NOSB/input create mode 100644 examples/cylinder_NOSB/src/Make.package create mode 100644 examples/cylinder_NOSB/src/geometry.f90 create mode 100644 examples/cylinder_NOSB/src/incomp_class.f90 create mode 100644 examples/cylinder_NOSB/src/lss_class.f90 create mode 100644 examples/cylinder_NOSB/src/simulation.f90 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 From def4010d442cb15d5049609299c07456b6fdfbf6 Mon Sep 17 00:00:00 2001 From: ivmauser Date: Tue, 30 Jun 2026 20:14:46 -0600 Subject: [PATCH 19/25] temporary back up of Jesse's original implementation --- .../GNUmakefile | 47 + .../peridynamics_shock_orig_DELETE/README | 1 + examples/peridynamics_shock_orig_DELETE/input | 34 + .../src/Make.package | 2 + .../src/geometry.f90 | 73 + .../src/lss_class.f90 | 1507 +++++++++++++++++ .../src/simulation.f90 | 782 +++++++++ .../src/spcomp_class.f90 | 942 +++++++++++ 8 files changed, 3388 insertions(+) create mode 100644 examples/peridynamics_shock_orig_DELETE/GNUmakefile create mode 100644 examples/peridynamics_shock_orig_DELETE/README create mode 100644 examples/peridynamics_shock_orig_DELETE/input create mode 100644 examples/peridynamics_shock_orig_DELETE/src/Make.package create mode 100644 examples/peridynamics_shock_orig_DELETE/src/geometry.f90 create mode 100644 examples/peridynamics_shock_orig_DELETE/src/lss_class.f90 create mode 100644 examples/peridynamics_shock_orig_DELETE/src/simulation.f90 create mode 100644 examples/peridynamics_shock_orig_DELETE/src/spcomp_class.f90 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 From 3750e19d764d5f42ae4c1d44898e8a0a750a2e4e Mon Sep 17 00:00:00 2001 From: ivmauser Date: Tue, 30 Jun 2026 20:16:02 -0600 Subject: [PATCH 20/25] Updates to simulation.f90 Changes to the simulation file. Copied over from the original Roma implentation that was tested previously with OSB. Will likely change over to use uniform points rather than stl generated points. --- examples/peridynamics_shock/GNUmakefile | 14 +- examples/peridynamics_shock/README | 4 +- examples/peridynamics_shock/input | 38 ++- examples/peridynamics_shock/src/geometry.f90 | 4 +- examples/peridynamics_shock/src/lss_class.f90 | 2 +- .../peridynamics_shock/src/simulation.f90 | 295 ++++++++---------- 6 files changed, 173 insertions(+), 184 deletions(-) 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 From 045b4ca6f976429050039808d6cbdd8c7a26dff9 Mon Sep 17 00:00:00 2001 From: ivmauser Date: Fri, 4 Sep 2026 15:25:32 -0400 Subject: [PATCH 21/25] Some amr and pd for peridigm --- src/amrpd/Make.package | 4 + src/amrpd/amrpd_class.f90 | 1141 ++++++++++++++++++ src/amrpd/amrpd_wrapper.cpp | 324 +++++ src/amrpd/amrpdviz_class.f90 | 262 ++++ src/amrpd/pdhalo_class.f90 | 555 +++++++++ src/amrpd/pdhash_class.f90 | 155 +++ src/amrpd/pdsolver_class.f90 | 2173 ++++++++++++++++++++++++++++++++++ 7 files changed, 4614 insertions(+) create mode 100644 src/amrpd/Make.package create mode 100644 src/amrpd/amrpd_class.f90 create mode 100644 src/amrpd/amrpd_wrapper.cpp create mode 100644 src/amrpd/amrpdviz_class.f90 create mode 100644 src/amrpd/pdhalo_class.f90 create mode 100644 src/amrpd/pdhash_class.f90 create mode 100644 src/amrpd/pdsolver_class.f90 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 From e0ceb2c876c394704c80895c856d819aa52b7a5b Mon Sep 17 00:00:00 2001 From: ivmauser Date: Fri, 4 Sep 2026 15:25:52 -0400 Subject: [PATCH 22/25] work in progress peridigm plate with hole test --- .../NOSB_plate_with_hole_peridigm/GNUmakefile | 49 + examples/NOSB_plate_with_hole_peridigm/README | 3 + examples/NOSB_plate_with_hole_peridigm/input | 42 + .../src/Make.package | 2 + .../src/amrpd_class.f90 | 1141 +++++++++ .../src/geometry.f90 | 73 + .../src/incomp_class.f90 | 2129 ++++++++++++++++ .../src/incomp_class_old.f90 | 2128 ++++++++++++++++ .../src/lss_class.f90 | 1585 ++++++++++++ .../src/lsspd_class.f90 | 456 ++++ .../src/pdhalo_class.f90 | 555 +++++ .../src/pdhash_class.f90 | 155 ++ .../src/pdsolver_class.f90 | 2179 +++++++++++++++++ .../src/simulation.f90 | 563 +++++ 14 files changed, 11060 insertions(+) create mode 100644 examples/NOSB_plate_with_hole_peridigm/GNUmakefile create mode 100644 examples/NOSB_plate_with_hole_peridigm/README create mode 100644 examples/NOSB_plate_with_hole_peridigm/input create mode 100644 examples/NOSB_plate_with_hole_peridigm/src/Make.package create mode 100644 examples/NOSB_plate_with_hole_peridigm/src/amrpd_class.f90 create mode 100644 examples/NOSB_plate_with_hole_peridigm/src/geometry.f90 create mode 100644 examples/NOSB_plate_with_hole_peridigm/src/incomp_class.f90 create mode 100644 examples/NOSB_plate_with_hole_peridigm/src/incomp_class_old.f90 create mode 100644 examples/NOSB_plate_with_hole_peridigm/src/lss_class.f90 create mode 100644 examples/NOSB_plate_with_hole_peridigm/src/lsspd_class.f90 create mode 100644 examples/NOSB_plate_with_hole_peridigm/src/pdhalo_class.f90 create mode 100644 examples/NOSB_plate_with_hole_peridigm/src/pdhash_class.f90 create mode 100644 examples/NOSB_plate_with_hole_peridigm/src/pdsolver_class.f90 create mode 100644 examples/NOSB_plate_with_hole_peridigm/src/simulation.f90 diff --git a/examples/NOSB_plate_with_hole_peridigm/GNUmakefile b/examples/NOSB_plate_with_hole_peridigm/GNUmakefile new file mode 100644 index 000000000..23c4d3dba --- /dev/null +++ b/examples/NOSB_plate_with_hole_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_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..d261bed2e --- /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-7 +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..524ea695a --- /dev/null +++ b/examples/NOSB_plate_with_hole_peridigm/src/Make.package @@ -0,0 +1,2 @@ +# List here the extra files here +f90EXE_sources += 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/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..55886735b --- /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 pdsolver_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..58327af24 --- /dev/null +++ b/examples/NOSB_plate_with_hole_peridigm/src/pdsolver_class.f90 @@ -0,0 +1,2179 @@ +!> 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 + + + + + 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))) + 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 + + 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) + 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) + 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..7018ca86f --- /dev/null +++ b/examples/NOSB_plate_with_hole_peridigm/src/simulation.f90 @@ -0,0 +1,563 @@ +!> 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=17) + 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() + 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() + + 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 From c26ea8eed671198f5407977099ebc4520f063594 Mon Sep 17 00:00:00 2001 From: ivmauser Date: Wed, 9 Sep 2026 17:02:33 -0400 Subject: [PATCH 23/25] Working in serial only, same results as non-peridigm implementation --- .../NOSB_plate_with_hole_peridigm/GNUmakefile | 49 ---- examples/NOSB_plate_with_hole_peridigm/input | 4 +- .../src/pdsolver_class.f90 | 271 ++++++++++++------ .../src/simulation.f90 | 2 +- 4 files changed, 184 insertions(+), 142 deletions(-) delete mode 100644 examples/NOSB_plate_with_hole_peridigm/GNUmakefile diff --git a/examples/NOSB_plate_with_hole_peridigm/GNUmakefile b/examples/NOSB_plate_with_hole_peridigm/GNUmakefile deleted file mode 100644 index 23c4d3dba..000000000 --- a/examples/NOSB_plate_with_hole_peridigm/GNUmakefile +++ /dev/null @@ -1,49 +0,0 @@ -# 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_peridigm/input b/examples/NOSB_plate_with_hole_peridigm/input index d261bed2e..b69c03151 100644 --- a/examples/NOSB_plate_with_hole_peridigm/input +++ b/examples/NOSB_plate_with_hole_peridigm/input @@ -1,5 +1,5 @@ # Parallelization -Partition : 8 1 1 +Partition : 1 1 1 # Mesh definition Lx : 1.0 @@ -29,7 +29,7 @@ Dynamic viscosity : 0.001 Density : 1000 # Time integration -Max timestep size : 6e-7 +Max timestep size : 6e-6 Max cfl number : 0.9 Max time : 25.0e-3 Unfreeze time: 5.0e-3 diff --git a/examples/NOSB_plate_with_hole_peridigm/src/pdsolver_class.f90 b/examples/NOSB_plate_with_hole_peridigm/src/pdsolver_class.f90 index 58327af24..30d4254f1 100644 --- a/examples/NOSB_plate_with_hole_peridigm/src/pdsolver_class.f90 +++ b/examples/NOSB_plate_with_hole_peridigm/src/pdsolver_class.f90 @@ -165,6 +165,10 @@ module pdsolver_class ! Damping rate for steady state real(WP) :: damping_rate=0.0_WP + ! NOSB Tracked parameters + real(WP), allocatable :: F_mat(:,:,:) !< F matrix (:,:,nown) + real(WP), allocatable :: PK_inv(:,:,:) !< P*K^-1 matrix (:,:,nown) + @@ -234,6 +238,7 @@ subroutine set_nodes(this,n,gids,pos,vel,flags,vol) 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) @@ -243,6 +248,7 @@ subroutine set_nodes(this,n,gids,pos,vel,flags,vol) 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 @@ -765,17 +771,23 @@ subroutine pd_advance(this,dt) 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) + ! ! 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() @@ -860,26 +872,77 @@ subroutine pd_advance(this,dt) 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() + ! ! 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 - this%theta(i)=0.0_WP + 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) - 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) + 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 - 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 + + 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 - 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 @@ -887,32 +950,38 @@ subroutine pd_advance(this,dt) 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%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)) + ! 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. @@ -929,42 +998,52 @@ subroutine pd_advance(this,dt) 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 + ! ! 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 + ! ! 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) @@ -2114,21 +2193,33 @@ end function cell_of !> 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) :: 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 + 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 - w=max(4.0_WP*s*(1.0_WP-s),0.0_WP) + ! wgauss=(1.0_WP+4.0_WP*d/hh)*(1.0_WP-d/hh)**4 + w=(1.0_WP-d/h)**3 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 diff --git a/examples/NOSB_plate_with_hole_peridigm/src/simulation.f90 b/examples/NOSB_plate_with_hole_peridigm/src/simulation.f90 index 7018ca86f..b13f2d36b 100644 --- a/examples/NOSB_plate_with_hole_peridigm/src/simulation.f90 +++ b/examples/NOSB_plate_with_hole_peridigm/src/simulation.f90 @@ -122,7 +122,7 @@ subroutine simulation_init 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=17) + 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) From 82ca7a9b85562ff7e8adcfd2ce110efb85f67ec0 Mon Sep 17 00:00:00 2001 From: ivmauser Date: Mon, 14 Sep 2026 10:31:01 -0400 Subject: [PATCH 24/25] WIP, generalization of OSB and NOSB --- .../NOSB_plate_with_hole_peridigm/GNUmakefile | 49 + examples/NOSB_plate_with_hole_peridigm/input | 2 +- .../src/Make.package | 2 +- .../src/NOSB_class.f90 | 2231 +++++++++++++++++ .../src/OSB_class.f90 | 2184 ++++++++++++++++ .../src/lsspd_class.f90 | 2 +- .../src/pdsolver_class.f90 | 15 +- .../src/simulation.f90 | 21 + 8 files changed, 4501 insertions(+), 5 deletions(-) create mode 100644 examples/NOSB_plate_with_hole_peridigm/GNUmakefile create mode 100644 examples/NOSB_plate_with_hole_peridigm/src/NOSB_class.f90 create mode 100644 examples/NOSB_plate_with_hole_peridigm/src/OSB_class.f90 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/input b/examples/NOSB_plate_with_hole_peridigm/input index b69c03151..37e3cc697 100644 --- a/examples/NOSB_plate_with_hole_peridigm/input +++ b/examples/NOSB_plate_with_hole_peridigm/input @@ -1,5 +1,5 @@ # Parallelization -Partition : 1 1 1 +Partition : 8 1 1 # Mesh definition Lx : 1.0 diff --git a/examples/NOSB_plate_with_hole_peridigm/src/Make.package b/examples/NOSB_plate_with_hole_peridigm/src/Make.package index 524ea695a..b2eadf90c 100644 --- a/examples/NOSB_plate_with_hole_peridigm/src/Make.package +++ b/examples/NOSB_plate_with_hole_peridigm/src/Make.package @@ -1,2 +1,2 @@ # List here the extra files here -f90EXE_sources += pdsolver_class.f90 pdhalo_class.f90 pdhash_class.f90 lsspd_class.f90 simulation.f90 geometry.f90 incomp_class.f90 +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/lsspd_class.f90 b/examples/NOSB_plate_with_hole_peridigm/src/lsspd_class.f90 index 55886735b..bf5f01250 100644 --- a/examples/NOSB_plate_with_hole_peridigm/src/lsspd_class.f90 +++ b/examples/NOSB_plate_with_hole_peridigm/src/lsspd_class.f90 @@ -6,7 +6,7 @@ module lsspd_class use config_class, only: config use ddadi_class, only: ddadi use mpi_f08, only: MPI_Datatype,MPI_INTEGER8,MPI_INTEGER,MPI_DOUBLE_PRECISION - use pdsolver_class, only: pdsolver, PDC_IS_DEAD, PDC_BONDS, PDC_INTEGRATES, PDC_MOVES, pd_partition + use NOSB_class, only: pdsolver, PDC_IS_DEAD, PDC_BONDS, PDC_INTEGRATES, PDC_MOVES, pd_partition implicit none private diff --git a/examples/NOSB_plate_with_hole_peridigm/src/pdsolver_class.f90 b/examples/NOSB_plate_with_hole_peridigm/src/pdsolver_class.f90 index 30d4254f1..ea5d6ff70 100644 --- a/examples/NOSB_plate_with_hole_peridigm/src/pdsolver_class.f90 +++ b/examples/NOSB_plate_with_hole_peridigm/src/pdsolver_class.f90 @@ -166,8 +166,8 @@ module pdsolver_class real(WP) :: damping_rate=0.0_WP ! NOSB Tracked parameters - real(WP), allocatable :: F_mat(:,:,:) !< F matrix (:,:,nown) - real(WP), allocatable :: PK_inv(:,:,:) !< P*K^-1 matrix (:,:,nown) + 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 @@ -623,6 +623,11 @@ subroutine assemble(this,rn,rnode,rnbr,rkey,rev,rdmg) 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) @@ -943,6 +948,12 @@ subroutine pd_advance(this,dt) 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 diff --git a/examples/NOSB_plate_with_hole_peridigm/src/simulation.f90 b/examples/NOSB_plate_with_hole_peridigm/src/simulation.f90 index b13f2d36b..9af3ca25d 100644 --- a/examples/NOSB_plate_with_hole_peridigm/src/simulation.f90 +++ b/examples/NOSB_plate_with_hole_peridigm/src/simulation.f90 @@ -363,6 +363,24 @@ subroutine simulation_init 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 ==================' @@ -538,6 +556,9 @@ subroutine simulation_run ! call mfile%write() ! call cflfile%write() ! call sfile%write() + + call ls%get_info() + call mfile%write() end do From b3de659e9dcd40f4b17064f3872c55d6a6cdeeb7 Mon Sep 17 00:00:00 2001 From: ivmauser Date: Wed, 16 Sep 2026 17:07:50 -0400 Subject: [PATCH 25/25] Still ongoing, coupling seems working, testing flow in channel --- examples/NOSB_cylinder_peridigm/GNUmakefile | 49 + examples/NOSB_cylinder_peridigm/README | 3 + examples/NOSB_cylinder_peridigm/input | 40 + .../NOSB_cylinder_peridigm/src/Make.package | 2 + .../NOSB_cylinder_peridigm/src/NOSB_class.f90 | 2231 ++++++++++++++++ .../NOSB_cylinder_peridigm/src/OSB_class.f90 | 2184 ++++++++++++++++ .../src/amrpd_class.f90 | 1141 +++++++++ .../NOSB_cylinder_peridigm/src/geometry.f90 | 100 + .../src/incomp_class.f90 | 2129 +++++++++++++++ .../src/incomp_class_old.f90 | 2128 +++++++++++++++ .../NOSB_cylinder_peridigm/src/lss_class.f90 | 1585 ++++++++++++ .../src/lsspd_class.f90 | 842 ++++++ .../src/pdhalo_class.f90 | 555 ++++ .../src/pdhash_class.f90 | 155 ++ .../src/pdsolver_class.f90 | 2281 +++++++++++++++++ .../NOSB_cylinder_peridigm/src/simulation.f90 | 584 +++++ 16 files changed, 16009 insertions(+) create mode 100644 examples/NOSB_cylinder_peridigm/GNUmakefile create mode 100644 examples/NOSB_cylinder_peridigm/README create mode 100644 examples/NOSB_cylinder_peridigm/input create mode 100644 examples/NOSB_cylinder_peridigm/src/Make.package create mode 100644 examples/NOSB_cylinder_peridigm/src/NOSB_class.f90 create mode 100644 examples/NOSB_cylinder_peridigm/src/OSB_class.f90 create mode 100644 examples/NOSB_cylinder_peridigm/src/amrpd_class.f90 create mode 100644 examples/NOSB_cylinder_peridigm/src/geometry.f90 create mode 100644 examples/NOSB_cylinder_peridigm/src/incomp_class.f90 create mode 100644 examples/NOSB_cylinder_peridigm/src/incomp_class_old.f90 create mode 100644 examples/NOSB_cylinder_peridigm/src/lss_class.f90 create mode 100644 examples/NOSB_cylinder_peridigm/src/lsspd_class.f90 create mode 100644 examples/NOSB_cylinder_peridigm/src/pdhalo_class.f90 create mode 100644 examples/NOSB_cylinder_peridigm/src/pdhash_class.f90 create mode 100644 examples/NOSB_cylinder_peridigm/src/pdsolver_class.f90 create mode 100644 examples/NOSB_cylinder_peridigm/src/simulation.f90 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