From c39a5812fe7bcc25a7026966121375c68ac44ca6 Mon Sep 17 00:00:00 2001 From: Mark Owkes Date: Thu, 13 Mar 2025 05:56:00 -0600 Subject: [PATCH 01/70] Started working on fast marching method class --- examples/ligament/GNUmakefile | 2 +- examples/ligament/input | 4 +- examples/ligament/src/ligament_class.f90 | 187 ++++++++++++++++++++++- src/grid/Make.package | 2 +- src/grid/fmm_class.f90 | 71 +++++++++ 5 files changed, 260 insertions(+), 6 deletions(-) create mode 100644 src/grid/fmm_class.f90 diff --git a/examples/ligament/GNUmakefile b/examples/ligament/GNUmakefile index f51ff99ec..af127cb82 100644 --- a/examples/ligament/GNUmakefile +++ b/examples/ligament/GNUmakefile @@ -9,7 +9,7 @@ USE_HYPRE = TRUE USE_LAPACK= TRUE USE_IRL = TRUE PROFILE = FALSE -DEBUG = FALSE +DEBUG = TRUE COMP = gnu EXEBASE = nga diff --git a/examples/ligament/input b/examples/ligament/input index a445af23e..cfedc61f2 100644 --- a/examples/ligament/input +++ b/examples/ligament/input @@ -33,5 +33,5 @@ Ensight output period : 1 Restart output period : 10 # Data restart -Restart from : 3.00000E+01 -HIT restart : hit_128 \ No newline at end of file +#Restart from : 3.00000E+01 +#HIT restart : hit_128 \ No newline at end of file diff --git a/examples/ligament/src/ligament_class.f90 b/examples/ligament/src/ligament_class.f90 index 511ca38ae..6eeee84ea 100644 --- a/examples/ligament/src/ligament_class.f90 +++ b/examples/ligament/src/ligament_class.f90 @@ -14,6 +14,9 @@ module ligament_class use monitor_class, only: monitor use timer_class, only: timer use pardata_class, only: pardata + use cclabel_class, only: cclabel + use fmm_class, only: fmm + use irl_fortran_interface implicit none private @@ -31,6 +34,8 @@ module ligament_class type(hypre_str) :: ps !< Structured Hypre linear solver for pressure !type(ddadi) :: vs !< DDADI solver for velocity type(timetracker) :: time !< Time info + type(cclabel) :: ccl !< CCLabel for local Weber number calculation + type(fmm) :: fmm !< Fast marching method for distance field !> Ensight postprocessing type(surfmesh) :: smesh !< Surface mesh for interface @@ -71,7 +76,6 @@ module ligament_class contains - !> Initialization of ligament simulation subroutine init(this) implicit none @@ -246,7 +250,18 @@ subroutine init(this) ! Compute cell-centered velocity call this%fs%interp_vel(this%Ui,this%Vi,this%Wi) end block create_flow_solver - + + ! Create CCL + create_ccl: block + ! Initialize CCL + call this%ccl%initialize(pg=this%cfg%pgrid,name='ccl') + end block create_ccl + + ! Create FMM + create_fmm: block + ! Initialize FMM + call this%fmm%initialize(pg=this%cfg%pgrid,name='fmm') + end block create_fmm ! Handle restart/saves here handle_restart: block @@ -389,6 +404,7 @@ subroutine init(this) call this%ens_out%add_scalar('curvature',this%vf%curv) call this%ens_out%add_scalar('pressure',this%fs%P) call this%ens_out%add_surface('plic',this%smesh) + call this%ens_out%add_scalar('dist', this%fmm%dist) ! Output to ensight if (this%ens_evt%occurs()) call this%ens_out%write_data(this%time%t) end block create_ensight @@ -634,6 +650,127 @@ subroutine step(this) call MPI_ALLREDUCE(MPI_IN_PLACE,this%vof_removed,1,MPI_REAL_WP,MPI_SUM,this%cfg%comm,ierr) call this%vf%clean_irl_and_band() end block remove_vof + + ! Compute Local Weber number + weber_number: block + use mpi_f08, only: MPI_ALLREDUCE,MPI_SUM,MPI_MAX,MPI_IN_PLACE + use parallel, only: MPI_REAL_WP + use mathtools, only: pi + real(WP), dimension(:) , allocatable :: dvol + real(WP), dimension(:,:) , allocatable :: dpos + real(WP), dimension(:,:) , allocatable :: dvel + real(WP), dimension(:,:,:), allocatable :: dmoi + real(WP), dimension(:) , allocatable :: drem + integer :: n,m,ierr,i,j,k,nmax + real(WP) :: x,y,z,x0,y0,z0,diam,ecc,lmax,lmid,lmin + logical :: transfer + ! Moment of inertia calculation using lapack + real(WP), dimension(:), allocatable, save :: work !< Saved! + integer, save :: lwork !< Saved! + real(WP), dimension(1) :: lwork_query + real(WP), dimension(3) :: d + real(WP), dimension(3,3) :: A + integer :: info + + ! Query optimal work array size + if (.not.allocated(work)) then + call dsyev('V','U',3,A,3,d,lwork_query,-1,info) + lwork=int(lwork_query(1)); allocate(work(lwork)) + end if + + ! Start by performing a CCL + call this%ccl%build(make_label,same_label) + + ! Allocate droplet stats arrays + allocate(dvol(1:this%ccl%nstruct )); dvol=0.0_WP + allocate(dpos(1:this%ccl%nstruct,1:3 )); dpos=0.0_WP + allocate(dvel(1:this%ccl%nstruct,1:3 )); dvel=0.0_WP + allocate(dmoi(1:this%ccl%nstruct,1:3,1:3)); dmoi=0.0_WP + allocate(drem(1:this%ccl%nstruct )); drem=0.0_WP + + ! First pass to accumulate volume, position, and velocity + do n=1,this%ccl%nstruct + ! Loop over cells in structure + do m=1,this%ccl%struct(n)%n_ + ! Get cell indices + i=this%ccl%struct(n)%map(1,m) + j=this%ccl%struct(n)%map(2,m) + k=this%ccl%struct(n)%map(3,m) + ! Get cell position, accounting for periodicity + x=this%vf%cfg%xm(i)-this%ccl%struct(n)%per(1)*this%vf%cfg%xL + y=this%vf%cfg%ym(j)-this%ccl%struct(n)%per(2)*this%vf%cfg%yL + z=this%vf%cfg%zm(k)-this%ccl%struct(n)%per(3)*this%vf%cfg%zL + ! Accumulate volume, position, and velocity + dvol(n )=dvol(n )+this%cfg%vol(i,j,k)*this%vf%VF(i,j,k) + dpos(n,:)=dpos(n,:)+this%cfg%vol(i,j,k)*this%vf%VF(i,j,k)*[x,y,z] + dvel(n,:)=dvel(n,:)+this%cfg%vol(i,j,k)*this%vf%VF(i,j,k)*[this%Ui(i,j,k),this%Vi(i,j,k),this%Wi(i,j,k)] + ! Check if drop touches auto-transfer layer + if (i.ge.this%vf%cfg%imax-this%nlayer.or.& + & j.le.this%vf%cfg%jmin+this%nlayer.or.& + & j.ge.this%vf%cfg%jmax-this%nlayer.or.& + & k.le.this%vf%cfg%kmin+this%nlayer.or.& + & k.ge.this%vf%cfg%kmax-this%nlayer) drem(n)=1.0_WP + end do + end do + call MPI_ALLREDUCE(MPI_IN_PLACE,dvol,1*this%ccl%nstruct,MPI_REAL_WP,MPI_SUM,this%vf%cfg%comm,ierr) + call MPI_ALLREDUCE(MPI_IN_PLACE,dpos,3*this%ccl%nstruct,MPI_REAL_WP,MPI_SUM,this%vf%cfg%comm,ierr) + call MPI_ALLREDUCE(MPI_IN_PLACE,dvel,3*this%ccl%nstruct,MPI_REAL_WP,MPI_SUM,this%vf%cfg%comm,ierr) + call MPI_ALLREDUCE(MPI_IN_PLACE,drem,1*this%ccl%nstruct,MPI_REAL_WP,MPI_MAX,this%vf%cfg%comm,ierr) + + ! Second pass to accumulate moment of inertia + do n=1,this%ccl%nstruct + ! Get drop barycenter + x0=dpos(n,1)/dvol(n) + y0=dpos(n,2)/dvol(n) + z0=dpos(n,3)/dvol(n) + ! Loop over cells in structure + do m=1,this%ccl%struct(n)%n_ + ! Get cell indices + i=this%ccl%struct(n)%map(1,m) + j=this%ccl%struct(n)%map(2,m) + k=this%ccl%struct(n)%map(3,m) + ! Get cell position relative to drop barycenter, accounting for periodicity + x=this%vf%cfg%xm(i)-this%ccl%struct(n)%per(1)*this%vf%cfg%xL-x0 + y=this%vf%cfg%ym(j)-this%ccl%struct(n)%per(2)*this%vf%cfg%yL-y0 + z=this%vf%cfg%zm(k)-this%ccl%struct(n)%per(3)*this%vf%cfg%zL-z0 + ! Accumulate moment of inertia + dmoi(n,1,1)=dmoi(n,1,1)+this%cfg%vol(i,j,k)*this%vf%VF(i,j,k)*(y**2+z**2) + dmoi(n,2,2)=dmoi(n,2,2)+this%cfg%vol(i,j,k)*this%vf%VF(i,j,k)*(z**2+x**2) + dmoi(n,3,3)=dmoi(n,3,3)+this%cfg%vol(i,j,k)*this%vf%VF(i,j,k)*(x**2+y**2) + dmoi(n,1,2)=dmoi(n,1,2)-this%cfg%vol(i,j,k)*this%vf%VF(i,j,k)*(x*y) + dmoi(n,1,3)=dmoi(n,1,3)-this%cfg%vol(i,j,k)*this%vf%VF(i,j,k)*(x*z) + dmoi(n,2,3)=dmoi(n,2,3)-this%cfg%vol(i,j,k)*this%vf%VF(i,j,k)*(y*z) + end do + end do + call MPI_ALLREDUCE(MPI_IN_PLACE,dmoi,9*this%ccl%nstruct,MPI_REAL_WP,MPI_SUM,this%vf%cfg%comm,ierr) + + ! Third pass to generate normalized drop stats + do n=1,this%ccl%nstruct + ! Get drop barycenter, accounting for periodicity + dpos(n,:)=dpos(n,:)/dvol(n) + if (this%vf%cfg%xper.and.dpos(n,1).lt.this%vf%cfg%x(this%vf%cfg%imin)) dpos(n,1)=dpos(n,1)+this%vf%cfg%xL + if (this%vf%cfg%yper.and.dpos(n,2).lt.this%vf%cfg%y(this%vf%cfg%jmin)) dpos(n,2)=dpos(n,2)+this%vf%cfg%yL + if (this%vf%cfg%zper.and.dpos(n,3).lt.this%vf%cfg%z(this%vf%cfg%kmin)) dpos(n,3)=dpos(n,3)+this%vf%cfg%zL + ! Get drop velocity + dvel(n,:)=dvel(n,:)/dvol(n) + end do + + ! Compute signed distance function to gas-liquid interface + call this%fmm%build(distance_init) + + ! Compute dominant gas velocity direction + do n=1,this%ccl%nstruct + ! Loop over cells in structure + do m=1,this%ccl%struct(n)%n_ + ! Get cell indices + i=this%ccl%struct(n)%map(1,m) + j=this%ccl%struct(n)%map(2,m) + k=this%ccl%struct(n)%map(3,m) + + end do + end do + + end block weber_number ! Output to ensight if (this%ens_evt%occurs()) then @@ -730,6 +867,52 @@ subroutine step(this) deallocate(P11,P12,P13,P14,P21,P22,P23,P24) end block save_restart end if + + contains + !> Function that identifies cells that need a label + logical function make_label(i,j,k) + implicit none + integer, intent(in) :: i,j,k + if (this%vf%VF(i,j,k).gt.0.0_WP) then + make_label=.true. + else + make_label=.false. + end if + end function make_label + + !> Function that identifies if cell pairs have same label + logical function same_label(i1,j1,k1,i2,j2,k2) + implicit none + integer, intent(in) :: i1,j1,k1,i2,j2,k2 + same_label=.true. + end function same_label + + !> Function that initializes distance function + subroutine distance_init(i,j,k,G,tag) + implicit none + integer, intent(in) :: i,j,k + real(WP), intent(out) :: G + logical, intent(out) :: tag + integer :: ii,jj,kk,ni + real(WP), dimension(3) :: pos,nearest_pt + if (this%vf%VF(i,j,k).gt.this%vf%VFmin .and. & + this%vf%VF(i,j,k).lt.this%vf%VFmax ) then + pos=[this%cfg%xm(i),this%cfg%ym(j),this%cfg%zm(k)] + G=huge(1.0_WP) + ! Compute distance + do ni=1,getNumberOfPlanes(this%vf%liquid_gas_interface(ii,jj,kk)) + if (getNumberOfVertices(this%vf%interface_polygon(ni,ii,jj,kk)).ne.0) then + nearest_pt=calculateNearestPtOnSurface(this%vf%interface_polygon(ni,ii,jj,kk),pos) + nearest_pt=pos-nearest_pt + G=dot_product(nearest_pt,nearest_pt) + end if + end do + tag=.true. + else + G=0.0_WP + tag=.false. + end if + end subroutine distance_init end subroutine step diff --git a/src/grid/Make.package b/src/grid/Make.package index ab0de4a0f..2664e262a 100644 --- a/src/grid/Make.package +++ b/src/grid/Make.package @@ -1,4 +1,4 @@ -f90EXE_sources += sgrid_class.f90 pgrid_class.f90 iterator_class.f90 surfmesh_class.f90 partmesh_class.f90 coupler_class.f90 cclabel_class.f90 +f90EXE_sources += sgrid_class.f90 pgrid_class.f90 iterator_class.f90 surfmesh_class.f90 partmesh_class.f90 coupler_class.f90 cclabel_class.f90 fmm_class.f90 INCLUDE_LOCATIONS += $(NGA_HOME)/src/grid VPATH_LOCATIONS += $(NGA_HOME)/src/grid diff --git a/src/grid/fmm_class.f90 b/src/grid/fmm_class.f90 new file mode 100644 index 000000000..14409a82b --- /dev/null +++ b/src/grid/fmm_class.f90 @@ -0,0 +1,71 @@ +!> Fast marching method class: +!> Provides support for creating a signed distance field from a vfs solution +module fmm_class + use precision, only: WP + use string, only: str_medium + use pgrid_class, only: pgrid + implicit none + private + + ! Expose type/constructor/methods + public :: fmm, distance_init_ftype + + !> fmm object definition + type :: fmm + ! This is our pgrid + class(pgrid), pointer :: pg + ! This is the name of the CCL + character(len=str_medium) :: name='UNNAMED_FFM' + ! Distance to the interface + real(WP), dimension(:,:,:), allocatable :: dist + ! Tag that is true for cells with defined distance + logical, dimension(:,:,:), allocatable :: tag + contains + procedure :: initialize + procedure :: build + end type fmm + + !> Type of the interface function used to set initial distance + interface + subroutine distance_init_ftype(ind1,ind2,ind3,dist,tag) + use precision, only: WP + integer, intent(in) :: ind1,ind2,ind3 + real(WP), intent(out) :: dist + logical, intent(out) :: tag + end subroutine distance_init_ftype + end interface + +contains + + !> Initialize the fmm class + subroutine initialize(this,pg,name) + implicit none + class(fmm), intent(inout) :: this + class(pgrid), target, intent(in) :: pg + character(len=*), optional :: name + ! Set the name for the object + if (present(name)) this%name=trim(adjustl(name)) + ! Point to pgrid object + this%pg=>pg + ! Allocate and initialize distance array + allocate(this%dist(this%pg%imino_:this%pg%imaxo_,this%pg%jmino_:this%pg%jmaxo_,this%pg%kmino_:this%pg%kmaxo_)); this%dist=0 + allocate(this%tag(this%pg%imino_:this%pg%imaxo_,this%pg%jmino_:this%pg%jmaxo_,this%pg%kmino_:this%pg%kmaxo_)); this%tag=.false. + end subroutine initialize + + !> Build the distance field using the user-set distance_init function + subroutine build(this,distance_init) + implicit none + class(fmm), intent(inout) :: this + procedure(distance_init_ftype) :: distance_init + integer :: i,j,k + ! Loop over the grid and set the distance + do k=this%pg%kmino_,this%pg%kmaxo_ + do j=this%pg%jmino_,this%pg%jmaxo_ + do i=this%pg%imino_,this%pg%imaxo_ + call distance_init(i,j,k,this%dist(i,j,k),this%tag(i,j,k)) + end do + end do + end do + end subroutine build + +end module fmm_class \ No newline at end of file From 938dbe545f864e1aa37b12fc2a5dda2e53ec0f9c Mon Sep 17 00:00:00 2001 From: Mark Owkes Date: Tue, 8 Apr 2025 05:53:27 -0600 Subject: [PATCH 02/70] Fast Marching Method --- examples/ligament/src/ligament_class.f90 | 99 +- src/grid/fmm_class.f90 | 1809 +++++++++++++++++++++- 2 files changed, 1828 insertions(+), 80 deletions(-) diff --git a/examples/ligament/src/ligament_class.f90 b/examples/ligament/src/ligament_class.f90 index 6eeee84ea..b0c59c11e 100644 --- a/examples/ligament/src/ligament_class.f90 +++ b/examples/ligament/src/ligament_class.f90 @@ -35,7 +35,12 @@ module ligament_class !type(ddadi) :: vs !< DDADI solver for velocity type(timetracker) :: time !< Time info type(cclabel) :: ccl !< CCLabel for local Weber number calculation + + !> FMM Method type(fmm) :: fmm !< Fast marching method for distance field + real(WP), dimension(:,:,:), allocatable :: G !< FMM distance + real(WP) :: fmm_ndx=4 !< Number of grid cells to extend distance field + !> Ensight postprocessing type(surfmesh) :: smesh !< Surface mesh for interface @@ -81,7 +86,6 @@ subroutine init(this) implicit none class(ligament), intent(inout) :: this - ! Create the ligament mesh create_config: block use sgrid_class, only: cartesian,sgrid @@ -112,6 +116,7 @@ subroutine init(this) call param_read('Partition',partition,short='p') ! Create partitioned grid without walls this%cfg=config(grp=group,decomp=partition,grid=grid) + end block create_config @@ -135,9 +140,9 @@ subroutine init(this) allocate(this%Ui (this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) allocate(this%Vi (this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) allocate(this%Wi (this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + allocate(this%G (this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) end block allocate_work_arrays - - + ! Initialize our VOF solver and field create_and_initialize_vof: block use vfs_class, only: remap,VFlo,VFhi,plicnet,r2pnet @@ -260,7 +265,7 @@ subroutine init(this) ! Create FMM create_fmm: block ! Initialize FMM - call this%fmm%initialize(pg=this%cfg%pgrid,name='fmm') + call this%fmm%initialize(cfg=this%cfg,name='fmm') end block create_fmm ! Handle restart/saves here @@ -404,7 +409,7 @@ subroutine init(this) call this%ens_out%add_scalar('curvature',this%vf%curv) call this%ens_out%add_scalar('pressure',this%fs%P) call this%ens_out%add_surface('plic',this%smesh) - call this%ens_out%add_scalar('dist', this%fmm%dist) + call this%ens_out%add_scalar('fmm_G',this%G) ! Output to ensight if (this%ens_evt%occurs()) call this%ens_out%write_data(this%time%t) end block create_ensight @@ -467,7 +472,6 @@ subroutine init(this) call this%timefile%add_column(this%tpres%time ,trim(this%tpres%name)) end block create_timing - contains @@ -553,15 +557,15 @@ subroutine step(this) this%fs%Vold=this%fs%V this%fs%Wold=this%fs%W - ! Prepare old staggered density (at n) + ! Prepare old sflaggered density (at n) call this%fs%get_olddensity(vf=this%vf) - + ! VOF solver step call this%tvof%start() ! Start VOF timer call this%vf%advance(dt=this%time%dt,U=this%fs%U,V=this%fs%V,W=this%fs%W) call this%tvof%stop() ! Stop VOF timer - ! Prepare new staggered viscosity (at n+1) + ! Prepare new sflaggered viscosity (at n+1) call this%fs%get_viscosity(vf=this%vf,strat=arithmetic_visc) ! Perform sub-iterations @@ -574,10 +578,10 @@ subroutine step(this) this%fs%U=0.5_WP*(this%fs%U+this%fs%Uold) this%fs%V=0.5_WP*(this%fs%V+this%fs%Vold) this%fs%W=0.5_WP*(this%fs%W+this%fs%Wold) - + ! Preliminary mass and momentum transport step at the interface call this%fs%prepare_advection_upwind(dt=this%time%dt) - + ! Explicit calculation of drho*u/dt from NS call this%fs%get_dmomdt(this%resU,this%resV,this%resW) @@ -588,7 +592,7 @@ subroutine step(this) ! Form implicit residuals call this%fs%solve_implicit(this%time%dt,this%resU,this%resV,this%resW) - + ! Apply these residuals this%fs%U=2.0_WP*this%fs%U-this%fs%Uold+this%resU this%fs%V=2.0_WP*this%fs%V-this%fs%Vold+this%resV @@ -615,9 +619,9 @@ subroutine step(this) ! Correct velocity call this%fs%get_pgrad(this%fs%psolv%sol,this%resU,this%resV,this%resW) this%fs%P=this%fs%P+this%fs%psolv%sol - this%fs%U=this%fs%U-this%time%dt*this%resU/this%fs%rho_U - this%fs%V=this%fs%V-this%time%dt*this%resV/this%fs%rho_V - this%fs%W=this%fs%W-this%time%dt*this%resW/this%fs%rho_W + this%fs%U=this%fs%U-this%time%dt*this%resU/max(epsilon(0.0_WP),this%fs%rho_U) + this%fs%V=this%fs%V-this%time%dt*this%resV/max(epsilon(0.0_WP),this%fs%rho_V) + this%fs%W=this%fs%W-this%time%dt*this%resW/max(epsilon(0.0_WP),this%fs%rho_W) ! Apply boundary conditions call this%fs%apply_bcond(this%time%t,this%time%dt) @@ -756,7 +760,43 @@ subroutine step(this) end do ! Compute signed distance function to gas-liquid interface - call this%fmm%build(distance_init) + fmm_build: block + integer :: i,j,k + real(WP) :: Gmax + integer :: ni + real(WP), dimension(3) :: pos,nearest_pt + ! Compute maximum distance to extend G + call this%cfg%maximum(this%cfg%meshsize,Gmax); Gmax = Gmax * this%fmm_ndx + 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%vf%VF(i,j,k).le.this%vf%VFmin) then + ! Gas + this%G(i,j,k) = -Gmax + elseif (this%vf%VF(i,j,k).ge.this%vf%VFmax) then + ! Liquid + this%G(i,j,k) = +Gmax + else + ! PLIC + pos=[this%cfg%xm(i),this%cfg%ym(j),this%cfg%zm(k)] + this%G(i,j,k)=huge(1.0_WP) + ! Compute distance + do ni=1,getNumberOfPlanes(this%vf%liquid_gas_interface(i,j,k)) + if (getNumberOfVertices(this%vf%interface_polygon(ni,i,j,k)).ne.0) then + nearest_pt=calculateNearestPtOnSurface(this%vf%interface_polygon(ni,i,j,k),pos) + nearest_pt=pos-nearest_pt + this%G(i,j,k)=min(this%G(i,j,k),dot_product(nearest_pt,nearest_pt)) + end if + end do + this%G(i,j,k)=sqrt(this%G(i,j,k)) + ! Check if inside or outside + if (.not.isPtInt(pos,this%vf%liquid_gas_interface(i,j,k))) this%G(i,j,k) = -this%G(i,j,k) + end if + end do + end do + end do + call this%fmm%build(this%G,Gmax) + end block fmm_build ! Compute dominant gas velocity direction do n=1,this%ccl%nstruct @@ -886,33 +926,6 @@ logical function same_label(i1,j1,k1,i2,j2,k2) integer, intent(in) :: i1,j1,k1,i2,j2,k2 same_label=.true. end function same_label - - !> Function that initializes distance function - subroutine distance_init(i,j,k,G,tag) - implicit none - integer, intent(in) :: i,j,k - real(WP), intent(out) :: G - logical, intent(out) :: tag - integer :: ii,jj,kk,ni - real(WP), dimension(3) :: pos,nearest_pt - if (this%vf%VF(i,j,k).gt.this%vf%VFmin .and. & - this%vf%VF(i,j,k).lt.this%vf%VFmax ) then - pos=[this%cfg%xm(i),this%cfg%ym(j),this%cfg%zm(k)] - G=huge(1.0_WP) - ! Compute distance - do ni=1,getNumberOfPlanes(this%vf%liquid_gas_interface(ii,jj,kk)) - if (getNumberOfVertices(this%vf%interface_polygon(ni,ii,jj,kk)).ne.0) then - nearest_pt=calculateNearestPtOnSurface(this%vf%interface_polygon(ni,ii,jj,kk),pos) - nearest_pt=pos-nearest_pt - G=dot_product(nearest_pt,nearest_pt) - end if - end do - tag=.true. - else - G=0.0_WP - tag=.false. - end if - end subroutine distance_init end subroutine step diff --git a/src/grid/fmm_class.f90 b/src/grid/fmm_class.f90 index 14409a82b..6feeb49a1 100644 --- a/src/grid/fmm_class.f90 +++ b/src/grid/fmm_class.f90 @@ -1,71 +1,1806 @@ !> Fast marching method class: -!> Provides support for creating a signed distance field from a vfs solution +!> Provides support for creating a signed distance field to a distance Gmax from parallel (pgrid) array module fmm_class use precision, only: WP use string, only: str_medium - use pgrid_class, only: pgrid + use config_class, only: config implicit none private ! Expose type/constructor/methods - public :: fmm, distance_init_ftype + public :: fmm + + ! Communication frequency + integer, parameter :: local_counter_max = 50 + + type heap_type + real(WP) :: G + integer :: i,j,k + end type heap_type !> fmm object definition type :: fmm - ! This is our pgrid - class(pgrid), pointer :: pg - ! This is the name of the CCL + ! This is our config + class(config), pointer :: cfg + ! This is the name of the fmm character(len=str_medium) :: name='UNNAMED_FFM' - ! Distance to the interface - real(WP), dimension(:,:,:), allocatable :: dist - ! Tag that is true for cells with defined distance - logical, dimension(:,:,:), allocatable :: tag + ! i,j,k's for close nodes + integer :: imin_close,imax_close + integer :: jmin_close,jmax_close + integer :: kmin_close,kmax_close + ! i,j,k's on what needs to send to other procs + integer :: i_passlo,i_passhi + integer :: j_passlo,j_passhi + integer :: k_passlo,k_passhi + ! rank of proc to send to + integer :: rank_x_lo,rank_x_hi + integer :: rank_y_lo,rank_y_hi + integer :: rank_z_lo,rank_z_hi + ! MPI buffering + integer(1), dimension(:), allocatable :: mpi_buffer + integer :: mpi_buffer_size + contains procedure :: initialize procedure :: build end type fmm - !> Type of the interface function used to set initial distance - interface - subroutine distance_init_ftype(ind1,ind2,ind3,dist,tag) - use precision, only: WP - integer, intent(in) :: ind1,ind2,ind3 - real(WP), intent(out) :: dist - logical, intent(out) :: tag - end subroutine distance_init_ftype - end interface - contains !> Initialize the fmm class - subroutine initialize(this,pg,name) + subroutine initialize(this,cfg,name) + use mpi_f08 + use parallel, only: comm implicit none class(fmm), intent(inout) :: this - class(pgrid), target, intent(in) :: pg + class(config), target, intent(in) :: cfg character(len=*), optional :: name + integer :: isource,idest,ierr + ! Set the name for the object if (present(name)) this%name=trim(adjustl(name)) - ! Point to pgrid object - this%pg=>pg - ! Allocate and initialize distance array - allocate(this%dist(this%pg%imino_:this%pg%imaxo_,this%pg%jmino_:this%pg%jmaxo_,this%pg%kmino_:this%pg%kmaxo_)); this%dist=0 - allocate(this%tag(this%pg%imino_:this%pg%imaxo_,this%pg%jmino_:this%pg%jmaxo_,this%pg%kmino_:this%pg%kmaxo_)); this%tag=.false. + + ! Point to cfg object + this%cfg=>cfg + + ! Determine the ranks of the procs that this proc should send to + call MPI_CART_SHIFT(this%cfg%comm,0,-1,isource,idest,ierr); this%rank_x_lo=idest + call MPI_CART_SHIFT(this%cfg%comm,0,+1,isource,idest,ierr); this%rank_x_hi=idest + call MPI_CART_SHIFT(this%cfg%comm,1,-1,isource,idest,ierr); this%rank_y_lo=idest + call MPI_CART_SHIFT(this%cfg%comm,1,+1,isource,idest,ierr); this%rank_y_hi=idest + call MPI_CART_SHIFT(this%cfg%comm,2,-1,isource,idest,ierr); this%rank_z_lo=idest + call MPI_CART_SHIFT(this%cfg%comm,2,+1,isource,idest,ierr); this%rank_z_hi=idest + + ! Set bounds on what nodes to send to other procs + if (this%cfg%nx.gt.1) then + this%i_passlo=this%cfg%imin_+1 + this%i_passhi=this%cfg%imax_-1 + else + this%i_passlo=this%cfg%imin_ + this%i_passhi=this%cfg%imax_ + end if + if (this%cfg%ny.gt.1) then + this%j_passlo=this%cfg%jmin_+1 + this%j_passhi=this%cfg%jmax_-1 + else + this%j_passlo=this%cfg%jmin_ + this%j_passhi=this%cfg%jmax_ + end if + if (this%cfg%nz.gt.1) then + this%k_passlo=this%cfg%kmin_+1 + this%k_passhi=this%cfg%kmax_-1 + else + this%k_passlo=this%cfg%kmin_ + this%k_passhi=this%cfg%kmax_ + end if + + ! Set bounds for the ghost nodes to consider given problem dimensions + if (this%cfg%nx.gt.1) then + this%imin_close=this%cfg%imin_-1 + this%imax_close=this%cfg%imax_+1 + else + this%imin_close=this%cfg%imin_ + this%imax_close=this%cfg%imax_ + end if + if (this%cfg%ny.gt.1) then + this%jmin_close=this%cfg%jmin_-1 + this%jmax_close=this%cfg%jmax_+1 + else + this%jmin_close=this%cfg%jmin_ + this%jmax_close=this%cfg%jmax_ + end if + if (this%cfg%nz.gt.1) then + this%kmin_close=this%cfg%kmin_-1 + this%kmax_close=this%cfg%kmax_+1 + else + this%kmin_close=this%cfg%kmin_ + this%kmax_close=this%cfg%kmax_ + end if + + ! Attach an mpi buffer for parallelization + this%mpi_buffer_size = (4*8+MPI_BSEND_OVERHEAD)*6*max(local_counter_max,20) + allocate(this%mpi_buffer(this%mpi_buffer_size)) + call MPI_BUFFER_ATTACH(this%mpi_buffer,this%mpi_buffer_size,ierr) + end subroutine initialize - !> Build the distance field using the user-set distance_init function - subroutine build(this,distance_init) + !> Update the distance field using estimate provided in G function out to Gmax + subroutine build(this,G,Gmax) + use messager, only: die implicit none class(fmm), intent(inout) :: this - procedure(distance_init_ftype) :: distance_init - integer :: i,j,k - ! Loop over the grid and set the distance - do k=this%pg%kmino_,this%pg%kmaxo_ - do j=this%pg%jmino_,this%pg%jmaxo_ - do i=this%pg%imino_,this%pg%imaxo_ - call distance_init(i,j,k,this%dist(i,j,k),this%tag(i,j,k)) + real(WP), dimension(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_), intent(inout) :: G + real(WP), intent(in) :: Gmax + integer, dimension(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_) :: phi_flag + real(WP), dimension(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_) :: phi_fmm + integer, dimension(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_,3) :: stc_plus,stc_minus + integer, dimension(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_) :: order_fmm + integer :: n_plus,n_minus + integer :: iter + integer :: accepted_count,close_count,close_minus_count,close_plus_count + integer :: fmm_accepted,fmm_close,fmm_far + integer, dimension(this%cfg%nx_*this%cfg%ny_*this%cfg%nz_,3), target :: close_minus_ijk,close_plus_ijk + integer, dimension(:,:), pointer :: close_ijk + integer, dimension(3) :: ijk, ijk_neigh + ! Counter and mapping for accepted nodes + integer :: n_accepted + integer, dimension(:,:), allocatable :: accepted_ijk + ! Combined counter and mapping for all accepted nodes + integer :: n_all_accepted + integer, dimension(:,:), allocatable :: all_accepted_ijk + ! Tags for cell status + integer, parameter :: fmm_far_plus = 1 + integer, parameter :: fmm_far_minus = 2 + integer, parameter :: fmm_close_plus = 3 + integer, parameter :: fmm_close_minus = 4 + integer, parameter :: fmm_accepted_plus = 5 + integer, parameter :: fmm_accepted_minus = 6 + integer, parameter :: fmm_tmp = 7 + ! Heap data + type(heap_type), dimension(:), allocatable :: heap + integer, dimension(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_) :: heap_map + integer :: nheap + ! Communication + integer, dimension(3) :: ibuf + + + ! Initialize the counters + n_plus = 0 + n_minus = 0 + phi_flag = 0 + + ! First tag all nodes and make plus and minus counts + tag_nodes: block + integer :: i,j,k + do k=this%cfg%kmino_,this%cfg%kmaxo_ + do j=this%cfg%jmino_,this%cfg%jmaxo_ + do i=this%cfg%imino_,this%cfg%imaxo_ + ! Cycle if too far or BC + !if (band(i,j,k).eq.0) cycle !!!! without band then the n_plus & n_minus is large!!! + if (this%cfg%VF(i,j,k).eq.0.0_WP) cycle + ! Check with side + if (G(i,j,k).ge.0.0_WP) then + n_plus = n_plus + 1 + phi_flag(i,j,k) = fmm_far_plus + else + n_minus = n_minus + 1 + phi_flag(i,j,k) = fmm_far_minus + end if + end do + end do + end do + end block tag_nodes + + ! Initialize the close counters + close_plus_count = 0 + close_minus_count = 0 + + ! Set up list of initially close nodes + setuplists: block + integer :: n,i,j,k + integer :: ii,jj,kk + do k=this%kmin_close,this%kmax_close + do j=this%jmin_close,this%jmax_close + do i=this%imin_close,this%imax_close + ! Cycle if too far or BC + !if (band(i,j,k).eq.0) cycle + if (this%cfg%VF(i,j,k).eq.0.0_WP) cycle + ! Check 6 direct neighbors + do n=1,6 + select case(n) + case(1) + ii=i-1;jj=j;kk=k + case(2) + ii=i+1;jj=j;kk=k + case(3) + ii=i;jj=j-1;kk=k + case(4) + ii=i;jj=j+1;kk=k + case(5) + ii=i;jj=j;kk=k-1 + case(6) + ii=i;jj=j;kk=k+1 + end select + ! Don't add nodes that are outside the bands or BC + !if (band(ii,jj,kk).eq.0) cycle + if (this%cfg%VF(ii,jj,kk).eq.0.0_WP) cycle + ! Find interface crossing + if ((G(i,j,k)*G(ii,jj,kk)).le.0.0_WP) then + if (G(i,j,k).lt.0.0_WP) then + if (phi_flag(i,j,k).ne.fmm_close_minus) then + phi_flag(i,j,k) = fmm_close_minus + close_minus_count = close_minus_count + 1 + close_minus_ijk(close_minus_count,1) = i + close_minus_ijk(close_minus_count,2) = j + close_minus_ijk(close_minus_count,3) = k + end if + else + if (phi_flag(i,j,k).ne.fmm_close_plus) then + phi_flag(i,j,k) = fmm_close_plus + close_plus_count = close_plus_count + 1 + close_plus_ijk(close_plus_count,1) = i + close_plus_ijk(close_plus_count,2) = j + close_plus_ijk(close_plus_count,3) = k + end if + end if + end if + end do + end do + end do + end do + end block setuplists + + !! Allocate a heap for sorting purposes + nheap = 0 + if (allocated(heap)) deallocate(heap) + allocate(heap(max(n_minus,n_plus))) + + ! Allocate a list of accepted nodes + if (allocated(accepted_ijk)) deallocate(accepted_ijk) + allocate(accepted_ijk(max(n_minus,n_plus),3)) + + ! Allocate a list of all accepted nodes + if (allocated(all_accepted_ijk)) deallocate(all_accepted_ijk) + allocate(all_accepted_ijk(n_minus+n_plus,3)) + + ! Zero the stencils + stc_plus = 0 + stc_minus= 0 + + ! Set up the temp level set field variable + setuptemp: block + integer :: i,j,k + do k=this%cfg%kmino_,this%cfg%kmaxo_ + do j=this%cfg%jmino_,this%cfg%jmaxo_ + do i=this%cfg%imino_,this%cfg%imaxo_ + !phi_fmm(i,j,k) = +1.0e6_WP*Gmax*this%cfg%meshsize(i,j,k) + phi_fmm(i,j,k) = Gmax + end do + end do + end do + end block setuptemp + + ! First negative, then positive side of the front + do iter=2,1,-1 + + ! Use the ibuf to store: + ! 1: count of received messages + ! 2: count of sent messages + ! 3: our current nheap + + ibuf(1:2) = 0 ! clear the message counters + + ! Switch between sides + if (iter.eq.1) then + fmm_accepted = fmm_accepted_plus + fmm_close = fmm_close_plus + fmm_far = fmm_far_plus + close_count = close_plus_count + close_ijk => close_plus_ijk + else + fmm_accepted = fmm_accepted_minus + fmm_close = fmm_close_minus + fmm_far = fmm_far_minus + close_count = close_minus_count + close_ijk => close_minus_ijk + end if + + ! Set up the initial close nodes list + close_nodes: block + integer :: n,i,j,k + integer :: nn,ii,jj,kk + integer :: local_index, n_nbrs + real(WP) :: local_phi + real(WP), dimension(6) :: G_nbrs + real(WP), dimension(3,6) :: dx_nbrs + integer, dimension(6) :: index_nbrs + do nn = 1,close_count + ! Get the index + i = close_ijk(nn,1) + j = close_ijk(nn,2) + k = close_ijk(nn,3) + + ! Zero the number of neighbors + n_nbrs = 0 + ! Loop over neighbors + do n = 1,6 + select case(n) + case(1) + ii=i-1;jj=j;kk=k + local_index = -1 + case(2) + ii=i+1;jj=j;kk=k + local_index = +1 + case(3) + ii=i;jj=j-1;kk=k + local_index = -2 + case(4) + ii=i;jj=j+1;kk=k + local_index = +2 + case(5) + ii=i;jj=j;kk=k-1 + local_index = -3 + case(6) + ii=i;jj=j;kk=k+1 + local_index = +3 + end select + ! Don't add nodes that are outside the bands or BC + !if (band(ii,jj,kk).eq.0) cycle + if (this%cfg%VF(ii,jj,kk).eq.0.0_WP) cycle + ! Form local metrics + if (G(i,j,k)*G(ii,jj,kk).le.0.0_WP) then + if (G(i,j,k).eq.G(ii,jj,kk)) cycle + n_nbrs = n_nbrs + 1 + G_nbrs( n_nbrs) = 0.0_WP + index_nbrs(n_nbrs) = local_index + dx_nbrs(1,n_nbrs) = abs(-G(i,j,k)*(this%cfg%xm(ii)-this%cfg%xm(i))/(G(ii,jj,kk)-G(i,j,k))) + dx_nbrs(2,n_nbrs) = abs(-G(i,j,k)*(this%cfg%ym(jj)-this%cfg%ym(j))/(G(ii,jj,kk)-G(i,j,k))) + dx_nbrs(3,n_nbrs) = abs(-G(i,j,k)*(this%cfg%zm(kk)-this%cfg%zm(k))/(G(ii,jj,kk)-G(i,j,k))) + end if + end do + + ! Reset the front itself + if (n_nbrs.gt.0) then + local_phi = phi_calc(n_nbrs,G_nbrs,index_nbrs,dx_nbrs) + phi_fmm(i,j,k) = min(phi_fmm(i,j,k),local_phi) + end if + ! Add node to the heap + if (abs(phi_fmm(i,j,k)).lt.Gmax) then + nheap = nheap + 1 + heap(nheap)%G = phi_fmm(i,j,k) + heap(nheap)%i = i + heap(nheap)%j = j + heap(nheap)%k = k + heap_map(i,j,k) = nheap + else + phi_fmm(i,j,k) = sign(Gmax,phi_fmm(i,j,k)) + phi_flag(i,j,k) = fmm_far + end if + end do + end block close_nodes + + ! Heapify close nodes + call heapify(nheap) + + ! Start FMM + mainFMM: block + integer :: n_accepted + logical :: global_done,local_done + integer :: local_counter + n_accepted = 0 + global_done = .FALSE. + global_loop: do while (.not.global_done) + local_counter = 0 + local_done = .FALSE. + local_loop: do while (.not.local_done) + + !> Parallel message processing + message_processing: block + integer :: i,j,k + integer :: ii,jj,kk + real(WP) :: this_phi + integer :: iheap + ! Check for new message from other processors + do while (multiphase_fmm_recv(i,j,k,this_phi)) + + if (this_phi.lt.phi_fmm(i,j,k)) then + + ! Check if this value is less than the currently + ! accepted value, and if it is, then roll back. + do while (n_accepted.gt.0) + ii = accepted_ijk(n_accepted,1) + jj = accepted_ijk(n_accepted,2) + kk = accepted_ijk(n_accepted,3) + + ! Check if we have rolled back enough... + if (this_phi.gt.phi_fmm(ii,jj,kk)) then + if (ii.ge.this%cfg%imin_.and.ii.le.this%cfg%imax_) then + if (jj.ge.this%cfg%jmin_.and.jj.le.this%cfg%jmax_) then + if (kk.ge.this%cfg%kmin_.and.kk.le.this%cfg%kmax_) then + exit + end if + end if + end if + end if + + phi_flag(ii,jj,kk) = fmm_close + nheap = nheap + 1 + heap(nheap)%G = phi_fmm(ii,jj,kk) + heap(nheap)%i = ii + heap(nheap)%j = jj + heap(nheap)%k = kk + heap_map(ii,jj,kk) = nheap + call upsift(nheap) + ! ... and reduce the accepted list. + n_accepted = n_accepted - 1 + + end do + + ! Now take the sent value and take action - we must be either + ! far or close. If we were accepted, we should have been rolled back + if (phi_flag(i,j,k).eq.fmm_close) then + ! Reset node value and resort + phi_fmm(i,j,k) = this_phi + iheap = heap_map(i,j,k) + heap(iheap)%G = this_phi + call upsift(iheap) + elseif (phi_flag(i,j,k).eq.fmm_far) then + ! Add as close node and sort + if (abs(this_phi).lt.Gmax) then + phi_fmm(i,j,k) = this_phi + phi_flag(i,j,k) = fmm_close + nheap = nheap + 1 + heap(nheap)%G = this_phi + heap(nheap)%i = i + heap(nheap)%j = j + heap(nheap)%k = k + heap_map(i,j,k) = nheap + call upsift(nheap) + else + phi_fmm(i,j,k) = sign(Gmax,this_phi) + phi_flag(i,j,k) = fmm_far + end if + end if + + end if + ! Add one to recv message counter... + ibuf(1) = ibuf(1) + 1 + end do + end block message_processing + + ! If heap not empty + nonemptyheap: if (nheap.gt.0) then + + ! Accept the closest and add neighbors + accept_closest: block + integer :: i,j,k + integer :: n_already_close,n_new_close + integer, dimension(6) :: already_close + integer, dimension(6) :: new_close + ! Get index + i = heap(1)%i + j = heap(1)%j + k = heap(1)%k + ! Set the closest as accepted + phi_flag(i,j,k) = fmm_accepted + local_counter = local_counter + 1 + n_accepted = n_accepted + 1 + accepted_ijk(n_accepted,1) = i + accepted_ijk(n_accepted,2) = j + accepted_ijk(n_accepted,3) = k + ! Now delete the heap root + call delroot(nheap) + + ! Add neighbors to the heap + add_neighbors: block + integer :: ii,jj,kk + integer :: nn,n_nbrs + integer :: local_index + ! Loop over neighbors + n_already_close = 0 + n_new_close = 0 + n_nbrs = 0 + do nn = 1,6 + select case(nn) + case(1) + ii=max(this%imin_close,i-1);jj=j;kk=k + if (i.eq.ii) cycle + local_index = -1 + case(2) + ii=min(this%imax_close,i+1);jj=j;kk=k + if (i.eq.ii) cycle + local_index = +1 + case(3) + ii=i;jj=max(this%jmin_close,j-1);kk=k + if (j.eq.jj) cycle + local_index = -2 + case(4) + ii=i;jj=min(this%jmax_close,j+1);kk=k + if (j.eq.jj) cycle + local_index = +2 + case(5) + ii=i;jj=j;kk=max(this%kmin_close,k-1) + if (k.eq.kk) cycle + local_index = -3 + case(6) + ii=i;jj=j;kk=min(this%kmax_close,k+1) + if (k.eq.kk) cycle + local_index = +3 + end select + ! Don't add nodes that are outside the bands or BC + !if (band(ii,jj,kk).eq.0) cycle + if (this%cfg%VF(ii,jj,kk).eq.0.0_WP) cycle + ! Count the nodes to be used in extending the distance function + if (phi_flag(ii,jj,kk).eq.fmm_close) then + n_already_close = n_already_close + 1 + already_close(n_already_close) = nn + phi_flag(ii,jj,kk) = fmm_tmp + else if (phi_flag(ii,jj,kk).eq.fmm_far) then + n_new_close = n_new_close + 1 + new_close(n_new_close) = nn + phi_flag(ii,jj,kk) = fmm_tmp + end if + end do + end block add_neighbors + + ! Work on the physical domain only and let other processors + ! know a boundary node has been accepted + if ( i.ge.this%cfg%imin_ .and. i.le.this%cfg%imax_ .and. & + j.ge.this%cfg%jmin_ .and. j.le.this%cfg%jmax_ .and. & + k.ge.this%cfg%kmin_ .and. k.le.this%cfg%kmax_ ) then + call multiphase_fmm_send(i,j,k,phi_fmm(i,j,k),ibuf(2)) + end if + + ! Process already close nodes + process_close_nodes: block + integer :: ii,jj,kk + integer :: nnn,iii,jjj,kkk + integer :: m,nn,n_nbrs + integer :: local_index, radius + real(WP) :: local_phi + real(WP), dimension(6) :: phi_nbrs + real(WP), dimension(3,6) :: dx_nbrs + integer, dimension(6) :: index_nbrs + do nn = 1,n_already_close + m = already_close(nn) + select case(m) + case(1) + ii=max(this%imin_close,i-1);jj=j;kk=k + if (i.eq.ii) cycle + local_index = -1 + case(2) + ii=min(this%imax_close,i+1);jj=j;kk=k + if (i.eq.ii) cycle + local_index = +1 + case(3) + ii=i;jj=max(this%jmin_close,j-1);kk=k + if (j.eq.jj) cycle + local_index = -2 + case(4) + ii=i;jj=min(this%jmax_close,j+1);kk=k + if (j.eq.jj) cycle + local_index = +2 + case(5) + ii=i;jj=j;kk=max(this%kmin_close,k-1) + if (k.eq.kk) cycle + local_index = -3 + case(6) + ii=i;jj=j;kk=min(this%kmax_close,k+1) + if (k.eq.kk) cycle + local_index = +3 + end select + ! Change the flag + phi_flag(ii,jj,kk) = fmm_close + ! Loop over neighbors + n_nbrs = 0 + do nnn = 1,6 + select case(nnn) + case(1) + iii=ii-1;jjj=jj;kkk=kk + local_index = -1 + case(2) + iii=ii+1;jjj=jj;kkk=kk + local_index = +1 + case(3) + iii=ii;jjj=jj-1;kkk=kk + local_index = -2 + case(4) + iii=ii;jjj=jj+1;kkk=kk + local_index = +2 + case(5) + iii=ii;jjj=jj;kkk=kk-1 + local_index = -3 + case(6) + iii=ii;jjj=jj;kkk=kk+1 + local_index = +3 + end select + ! Don't add nodes that are outside the bands or BC + !if (band(iii,jjj,kkk).eq.0) cycle + if (this%cfg%VF(iii,jjj,kkk).eq.0.0_WP) cycle + ! Check for nbrs and look for... + if ((G(ii,jj,kk)*G(iii,jjj,kkk)).le.0.0_WP) then + if (G(ii,jj,kk).eq.G(iii,jjj,kkk)) cycle + ! ... an intersection + n_nbrs = n_nbrs + 1 + phi_nbrs(n_nbrs) = 0.0_WP + index_nbrs(n_nbrs) = local_index + dx_nbrs(1,n_nbrs) = abs(-G(ii,jj,kk)*(this%cfg%xm(iii)-this%cfg%xm(ii))/(G(iii,jjj,kkk)-G(ii,jj,kk))) + dx_nbrs(2,n_nbrs) = abs(-G(ii,jj,kk)*(this%cfg%ym(jjj)-this%cfg%ym(jj))/(G(iii,jjj,kkk)-G(ii,jj,kk))) + dx_nbrs(3,n_nbrs) = abs(-G(ii,jj,kk)*(this%cfg%zm(kkk)-this%cfg%zm(kk))/(G(iii,jjj,kkk)-G(ii,jj,kk))) + else if (phi_flag(iii,jjj,kkk).eq.fmm_accepted) then + ! ... an accepted nbr + n_nbrs = n_nbrs + 1 + phi_nbrs(n_nbrs) = phi_fmm(iii,jjj,kkk) + index_nbrs(n_nbrs) = local_index + dx_nbrs(1,n_nbrs) = abs(this%cfg%xm(iii)-this%cfg%xm(ii)) + dx_nbrs(2,n_nbrs) = abs(this%cfg%ym(jjj)-this%cfg%ym(jj)) + dx_nbrs(3,n_nbrs) = abs(this%cfg%zm(kkk)-this%cfg%zm(kk)) + end if + end do + ! Recompute nodal values + if (n_nbrs.gt.0) then + local_phi = phi_calc(n_nbrs,phi_nbrs,index_nbrs,dx_nbrs) + phi_fmm(ii,jj,kk) = min(phi_fmm(ii,jj,kk),local_phi) + end if + ! Modify the heap + m = heap_map(ii,jj,kk) + if (phi_fmm(ii,jj,kk).gt.heap(m)%G) then + heap(m)%G = phi_fmm(ii,jj,kk) + call downsift(nheap,m) + else + heap(m)%G = phi_fmm(ii,jj,kk) + call upsift(m) + end if + end do + end block process_close_nodes + + ! Process new close nodes + process_new_nodes: block + integer :: ii,jj,kk + integer :: iii,jjj,kkk + integer :: m,nn,nnn,n_nbrs + integer :: local_index, radius + real(WP) :: local_phi + real(WP), dimension(3,6) :: dx_nbrs + real(WP), dimension(6) :: phi_nbrs + integer, dimension(6) :: index_nbrs + do nn = 1,n_new_close + m = new_close(nn) + select case(m) + case(1) + ii=max(this%imin_close,i-1);jj=j;kk=k + if (i.eq.ii) cycle + local_index = -1 + case(2) + ii=min(this%imax_close,i+1);jj=j;kk=k + if (i.eq.ii) cycle + local_index = +1 + case(3) + ii=i;jj=max(this%jmin_close,j-1);kk=k + if (j.eq.jj) cycle + local_index = -2 + case(4) + ii=i;jj=min(this%jmax_close,j+1);kk=k + if (j.eq.jj) cycle + local_index = +2 + case(5) + ii=i;jj=j;kk=max(this%kmin_close,k-1) + if (k.eq.kk) cycle + local_index = -3 + case(6) + ii=i;jj=j;kk=min(this%kmax_close,k+1) + if (k.eq.kk) cycle + local_index = +3 + end select + ! Change the flag + phi_flag(ii,jj,kk) = fmm_close + ! Loop over neighbors + n_nbrs = 0 + do nnn = 1,6 + select case(nnn) + case(1) + iii=ii-1;jjj=jj;kkk=kk + local_index = -1 + case(2) + iii=ii+1;jjj=jj;kkk=kk + local_index = +1 + case(3) + iii=ii;jjj=jj-1;kkk=kk + local_index = -2 + case(4) + iii=ii;jjj=jj+1;kkk=kk + local_index = +2 + case(5) + iii=ii;jjj=jj;kkk=kk-1 + local_index = -3 + case(6) + iii=ii;jjj=jj;kkk=kk+1 + local_index = +3 + end select + ! Don't add nodes that are outside the bands or BC + !if (band(iii,jjj,kkk).eq.0) cycle + if (this%cfg%VF(iii,jjj,kkk).eq.0.0_WP) cycle + ! Check for nbrs and look for... + if ((G(ii,jj,kk)*G(iii,jjj,kkk)).le.0.0_WP) then + if (G(ii,jj,kk).eq.G(iii,jjj,kkk)) cycle + ! ... an intersection + n_nbrs = n_nbrs + 1 + index_nbrs(n_nbrs) = local_index + phi_nbrs(n_nbrs) = 0.0_WP + dx_nbrs(1,n_nbrs) = abs(-G(ii,jj,kk)*(this%cfg%xm(iii)-this%cfg%xm(ii))/(G(iii,jjj,kkk)-G(ii,jj,kk))) + dx_nbrs(2,n_nbrs) = abs(-G(ii,jj,kk)*(this%cfg%ym(jjj)-this%cfg%ym(jj))/(G(iii,jjj,kkk)-G(ii,jj,kk))) + dx_nbrs(3,n_nbrs) = abs(-G(ii,jj,kk)*(this%cfg%zm(kkk)-this%cfg%zm(kk))/(G(iii,jjj,kkk)-G(ii,jj,kk))) + else if (phi_flag(iii,jjj,kkk).eq.fmm_accepted) then + ! ... an accepted nbr + n_nbrs = n_nbrs + 1 + index_nbrs(n_nbrs) = local_index + phi_nbrs(n_nbrs) = phi_fmm(iii,jjj,kkk) + dx_nbrs(1,n_nbrs) = abs(this%cfg%xm(iii)-this%cfg%xm(ii)) + dx_nbrs(2,n_nbrs) = abs(this%cfg%ym(jjj)-this%cfg%ym(jj)) + dx_nbrs(3,n_nbrs) = abs(this%cfg%zm(kkk)-this%cfg%zm(kk)) + end if + end do + ! Recompute nodal value + if (n_nbrs.gt.0) then + local_phi = phi_calc(n_nbrs,phi_nbrs,index_nbrs,dx_nbrs) + phi_fmm(ii,jj,kk) = min(phi_fmm(ii,jj,kk),local_phi) + end if + ! Add to the heap + if (abs(phi_fmm(ii,jj,kk)).lt.Gmax) then + nheap = nheap + 1 + heap(nheap)%G = phi_fmm(ii,jj,kk) + heap(nheap)%i = ii + heap(nheap)%j = jj + heap(nheap)%k = kk + heap_map(ii,jj,kk) = nheap + call upsift(nheap) + else + phi_fmm(ii,jj,kk) = sign(Gmax,phi_fmm(ii,jj,kk)) + phi_flag(ii,jj,kk) = fmm_far + end if + end do + end block process_new_nodes + end block accept_closest + end if nonemptyheap + + local_done = ((nheap.eq.0).or.(local_counter.eq.local_counter_max)) + + end do local_loop + + communcate_messages:block + use mpi_f08, only: MPI_ALLREDUCE, MPI_SUM, MPI_IN_PLACE, MPI_INTEGER + integer :: ierr + ibuf(3) = nheap + call MPI_ALLREDUCE(MPI_IN_PLACE,ibuf,3,MPI_INTEGER,MPI_SUM,this%cfg%comm,ierr) + global_done = ((ibuf(1).eq.ibuf(2)).and.(ibuf(3).eq.0)) + end block communcate_messages + + end do global_loop + + ! Recover the accepted nodes list 1) Positive 2) Negative + recover_accepted: block + select case(iter) + case(1) + all_accepted_ijk(n_all_accepted+1:n_all_accepted+n_accepted,:)=accepted_ijk(1:n_accepted,:) + n_all_accepted=n_all_accepted+n_accepted + case(2) + all_accepted_ijk(1:n_accepted,:)=accepted_ijk(n_accepted:1:-1,:) + n_all_accepted=n_accepted + end select + end block recover_accepted + + end block mainFMM + end do ! sides + + ! Now update level set + update_levelset: block + integer:: i,j,k + 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 (phi_flag(i,j,k).eq.fmm_accepted_plus) then + G(i,j,k) = +phi_fmm(i,j,k) + else if (phi_flag(i,j,k).eq.fmm_accepted_minus) then + G(i,j,k) = -phi_fmm(i,j,k) + end if + end do end do end do - end do + ! Communicate level set + call this%cfg%sync(G) + end block update_levelset + + ! ! Store ordered list + ! do n=1,n_all_accepted + ! ! Get index + ! i=all_accepted_ijk(n,1) + ! j=all_accepted_ijk(n,2) + ! k=all_accepted_ijk(n,3) + ! order_fmm(i,j,k)=n + ! end do + + ! ! Generate the stencils for variable extension + ! do n=1,n_all_accepted + ! ! Get index + ! i=all_accepted_ijk(n,1) + ! j=all_accepted_ijk(n,2) + ! k=all_accepted_ijk(n,3) + ! ! Find useable neighbors in plus direction + ! n_nbrs = 0 + ! do nn = 1,6 + ! select case(nn) + ! case(1) + ! ii=max(imin_close,i-1);jj=j;kk=k + ! if (i.eq.ii) cycle + ! local_index = -1 + ! case(2) + ! ii=min(imax_close,i+1);jj=j;kk=k + ! if (i.eq.ii) cycle + ! local_index = +1 + ! case(3) + ! ii=i;jj=max(jmin_close,j-1);kk=k + ! if (j.eq.jj) cycle + ! local_index = -2 + ! case(4) + ! ii=i;jj=min(jmax_close,j+1);kk=k + ! if (j.eq.jj) cycle + ! local_index = +2 + ! case(5) + ! ii=i;jj=j;kk=max(kmin_close,k-1) + ! if (k.eq.kk) cycle + ! local_index = -3 + ! case(6) + ! ii=i;jj=j;kk=min(kmax_close,k+1) + ! if (k.eq.kk) cycle + ! local_index = +3 + ! end select + ! ! Don't consider BC nodes or outside bands + ! ! if (band(ii,jj,kk).eq.0) cycle + ! if (vol(ii,jj,kk).eq.0.0_WP) cycle + ! ! Check if neighbor is closer + ! if (order_fmm(ii,jj,kk).lt.order_fmm(i,j,k).and.G(ii,jj,kk).lt.G(i,j,k)) then + ! n_nbrs = n_nbrs + 1 + ! phi_nbrs(n_nbrs) = G(ii,jj,kk) + ! index_nbrs(n_nbrs) = local_index + ! dx_nbrs(1,n_nbrs) = abs(xm(ii)-xm(i)) + ! dx_nbrs(2,n_nbrs) = abs(ym(jj)-ym(j)) + ! dx_nbrs(3,n_nbrs) = abs(zm(kk)-zm(k)) + ! end if + ! end do + ! ! Build the stencil + ! if (n_nbrs.gt.0) then + ! ! Check smallest distance + ! if (icyl.eq.1) then + ! radius = abs(ym(j)) + ! else + ! radius = 1.0_WP + ! end if + ! call phi_calc(local_phi,radius) + ! ! Keep only the stencil + ! stc_plus(i,j,k,:) = stc(:) + ! end if + ! ! Find useable neighbors in minus direction + ! n_nbrs = 0 + ! do nn = 1,6 + ! select case(nn) + ! case(1) + ! ii=max(imin_close,i-1);jj=j;kk=k + ! if (i.eq.ii) cycle + ! local_index = -1 + ! case(2) + ! ii=min(imax_close,i+1);jj=j;kk=k + ! if (i.eq.ii) cycle + ! local_index = +1 + ! case(3) + ! ii=i;jj=max(jmin_close,j-1);kk=k + ! if (j.eq.jj) cycle + ! local_index = -2 + ! case(4) + ! ii=i;jj=min(jmax_close,j+1);kk=k + ! if (j.eq.jj) cycle + ! local_index = +2 + ! case(5) + ! ii=i;jj=j;kk=max(kmin_close,k-1) + ! if (k.eq.kk) cycle + ! local_index = -3 + ! case(6) + ! ii=i;jj=j;kk=min(kmax_close,k+1) + ! if (k.eq.kk) cycle + ! local_index = +3 + ! end select + ! ! Don't consider BC nodes or outside bands + ! ! if (band(ii,jj,kk).eq.0) cycle + ! if (vol(ii,jj,kk).eq.0.0_WP) cycle + ! ! Check if neighbor is farther + ! if (order_fmm(ii,jj,kk).gt.order_fmm(i,j,k).and.G(ii,jj,kk).gt.G(i,j,k)) then + ! n_nbrs = n_nbrs + 1 + ! phi_nbrs(n_nbrs) = G(ii,jj,kk) + ! index_nbrs(n_nbrs) = local_index + ! dx_nbrs(1,n_nbrs) = abs(xm(ii)-xm(i)) + ! dx_nbrs(2,n_nbrs) = abs(ym(jj)-ym(j)) + ! dx_nbrs(3,n_nbrs) = abs(zm(kk)-zm(k)) + ! end if + ! end do + ! ! Build the stencil + ! if (n_nbrs.gt.0) then + ! ! Check smallest distance + ! if (icyl.eq.1) then + ! radius = abs(ym(j)) + ! else + ! radius = 1.0_WP + ! end if + ! call phi_calc(local_phi,radius) + ! ! Keep only the stencil + ! stc_minus(i,j,k,:) = stc(:) + ! end if + + ! ! ====================================== ! + ! ! Constant scalar extension based on FMM ! + ! ! ====================================== ! + ! subroutine extend(A,Aflag,dir) + ! use multiphase_fmm + ! use parallel + ! implicit none + + ! ! Input data + ! real(WP), dimension(imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) :: A + ! integer, dimension(imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) :: Aflag + ! character(len=*), intent(in) :: dir + + ! ! Work variables + ! integer :: n,nn,ierr + ! integer :: i,j,k,i0,j0,k0 + ! integer :: ii,jj,kk + ! real(WP) :: radius,local_sc,this_sc + ! integer, dimension(2) :: my_ibuf + ! integer, dimension(2) :: ibuf + + ! ! Initialize + ! my_ibuf=0 + ! ibuf=0 + + ! ! Barrier + ! call MPI_BARRIER(comm,ierr) + + ! ! Select work direction + ! select case (trim(dir)) + ! case ('+') + + ! do n=1,n_all_accepted + + ! ! Get index + ! i=all_accepted_ijk(n,1) + ! j=all_accepted_ijk(n,2) + ! k=all_accepted_ijk(n,3) + + ! ! If already set, skip cell + ! if (Aflag(i,j,k).eq.1) cycle + + ! ! If outside, skip cell + ! if (i.lt.imin_.or.i.gt.imax_.or.j.lt.jmin_.or.j.gt.jmax_.or.k.lt.kmin_.or.k.gt.kmax_) cycle + + ! ! If wall, skip cell + ! if (vol(i,j,k).eq.0.0_WP) cycle + + ! ! Receive messages if present + ! do while (multiphase_fmm_recv(i0,j0,k0,this_sc)) + ! my_ibuf(1)=my_ibuf(1)+1 + ! A(i0,j0,k0)=this_sc + ! Aflag(i0,j0,k0)=1 + ! end do + + ! ! Use the stencil to find neighbors + ! n_nbrs = 0 + ! neighbors_plus: do nn=1,3 + ! select case(stc_plus(i,j,k,nn)) + ! case(-1) + ! ii=i-1;jj=j;kk=k + ! case(+1) + ! ii=i+1;jj=j;kk=k + ! case(-2) + ! ii=i;jj=j-1;kk=k + ! case(+2) + ! ii=i;jj=j+1;kk=k + ! case(-3) + ! ii=i;jj=j;kk=k-1 + ! case(+3) + ! ii=i;jj=j;kk=k+1 + ! case (0) + ! cycle neighbors_plus + ! end select + ! ! Check if the data is available + ! do while (Aflag(ii,jj,kk).eq.0) + ! call multiphase_fmm_brecv(i0,j0,k0,this_sc) + ! my_ibuf(1)=my_ibuf(1)+1 + ! A(i0,j0,k0)=this_sc + ! Aflag(i0,j0,k0)=1 + ! end do + ! n_nbrs = n_nbrs + 1 + ! sc_nbrs(n_nbrs) = A(ii,jj,kk) + ! phi_nbrs(n_nbrs) = G(ii,jj,kk) + ! index_nbrs(n_nbrs) = stc_plus(i,j,k,nn) + ! dx_nbrs(1,n_nbrs) = abs(xm(ii)-xm(i)) + ! dx_nbrs(2,n_nbrs) = abs(ym(jj)-ym(j)) + ! dx_nbrs(3,n_nbrs) = abs(zm(kk)-zm(k)) + ! end do neighbors_plus + + ! ! Extend the quantity + ! phi_me = G(i,j,k) + ! if (icyl.eq.1) then + ! radius = abs(ym(j)) + ! else + ! radius = 1.0_WP + ! end if + ! call sc_calc(local_sc,radius) + ! A(i,j,k) = local_sc + ! Aflag(i,j,k) = 1 + + ! ! Communicate the value if necessary + ! call multiphase_fmm_send(i,j,k,A(i,j,k),my_ibuf(2)) + + ! end do + + ! ! Cleaning up remaining messages + ! call MPI_BARRIER(comm,ierr) + ! call MPI_ALLREDUCE(my_ibuf,ibuf,2,MPI_INTEGER,MPI_SUM,comm,ierr) + ! do while (ibuf(1).ne.ibuf(2)) + ! do while (multiphase_fmm_recv(i0,j0,k0,this_sc)) + ! my_ibuf(1)=my_ibuf(1)+1 + ! A(i0,j0,k0)=this_sc + ! Aflag(i0,j0,k0)=1 + ! end do + ! call MPI_BARRIER(comm,ierr) + ! call MPI_ALLREDUCE(my_ibuf,ibuf,2,MPI_INTEGER,MPI_SUM,comm,ierr) + ! end do + + ! case ('-') + + ! do n=n_all_accepted,1,-1 + + ! ! Get index + ! i=all_accepted_ijk(n,1) + ! j=all_accepted_ijk(n,2) + ! k=all_accepted_ijk(n,3) + + ! ! If already set, skip cell + ! if (Aflag(i,j,k).eq.1) cycle + + ! ! If outside, skip cell + ! if (i.lt.imin_.or.i.gt.imax_.or.j.lt.jmin_.or.j.gt.jmax_.or.k.lt.kmin_.or.k.gt.kmax_) cycle + + ! ! If wall, skip cell + ! if (vol(i,j,k).eq.0.0_WP) cycle + + ! ! Receive messages if present + ! do while (multiphase_fmm_recv(i0,j0,k0,this_sc)) + ! my_ibuf(1)=my_ibuf(1)+1 + ! A(i0,j0,k0)=this_sc + ! Aflag(i0,j0,k0)=1 + ! end do + + ! ! Use the stencil to find neighbors + ! n_nbrs = 0 + ! neighbors_minus: do nn=1,3 + ! select case(stc_minus(i,j,k,nn)) + ! case(-1) + ! ii=i-1;jj=j;kk=k + ! case(+1) + ! ii=i+1;jj=j;kk=k + ! case(-2) + ! ii=i;jj=j-1;kk=k + ! case(+2) + ! ii=i;jj=j+1;kk=k + ! case(-3) + ! ii=i;jj=j;kk=k-1 + ! case(+3) + ! ii=i;jj=j;kk=k+1 + ! case (0) + ! cycle neighbors_minus + ! end select + ! ! Check if the data is available + ! do while (Aflag(ii,jj,kk).eq.0) + ! call multiphase_fmm_brecv(i0,j0,k0,this_sc) + ! my_ibuf(1)=my_ibuf(1)+1 + ! A(i0,j0,k0)=this_sc + ! Aflag(i0,j0,k0)=1 + ! end do + ! n_nbrs = n_nbrs + 1 + ! sc_nbrs(n_nbrs) = A(ii,jj,kk) + ! phi_nbrs(n_nbrs) = G(ii,jj,kk) + ! index_nbrs(n_nbrs) = stc_minus(i,j,k,nn) + ! dx_nbrs(1,n_nbrs) = abs(xm(ii)-xm(i)) + ! dx_nbrs(2,n_nbrs) = abs(ym(jj)-ym(j)) + ! dx_nbrs(3,n_nbrs) = abs(zm(kk)-zm(k)) + ! end do neighbors_minus + + ! ! Extend the quantity + ! phi_me = G(i,j,k) + ! if (icyl.eq.1) then + ! radius = abs(ym(j)) + ! else + ! radius = 1.0_WP + ! end if + ! call sc_calc(local_sc,radius) + ! A(i,j,k) = local_sc + ! Aflag(i,j,k) = 1 + + ! ! Communicate the value if necessary + ! call multiphase_fmm_send(i,j,k,A(i,j,k),my_ibuf(2)) + + ! end do + + ! ! Cleaning up remaining messages + ! call MPI_BARRIER(comm,ierr) + ! call MPI_ALLREDUCE(my_ibuf,ibuf,2,MPI_INTEGER,MPI_SUM,comm,ierr) + ! do while (ibuf(1).ne.ibuf(2)) + ! do while (multiphase_fmm_recv(i0,j0,k0,this_sc)) + ! my_ibuf(1)=my_ibuf(1)+1 + ! A(i0,j0,k0)=this_sc + ! Aflag(i0,j0,k0)=1 + ! end do + ! call MPI_BARRIER(comm,ierr) + ! call MPI_ALLREDUCE(my_ibuf,ibuf,2,MPI_INTEGER,MPI_SUM,comm,ierr) + ! end do + + ! end select + + ! ! Barrier + ! call MPI_BARRIER(comm,ierr) + + ! return + ! end subroutine extend + + contains + + ! ===================================== ! + ! Make the subtree of heap starting in ! + ! parent node fulfil the heap property ! + ! -nh : heap size ! + ! -node: index of subtree of interest ! + ! ! + ! Usage: if parent value has increased, ! + ! it needs to be sifted down ! + ! ===================================== ! + subroutine downsift(nh,node) + implicit none + + integer, intent(in) :: nh,node + integer :: parent,child + type(heap_type) :: myheap + + ! Copy parent to bring down heap + parent=node + myheap=heap(parent) + + ! First child of parent + child=2*parent + + ! Continue until bottom of heap + down_sift: do while (child.le.nh) + + ! Is there a second child? + if (child+1.le.nh) then + ! Pick closest of two children + if (heap(child+1)%G.lt.heap(child)%G) child=child+1 + end if + + ! Check heap property + if (myheap%G.le.heap(child)%G) exit down_sift + + ! Otherwise need to swap child and parent + heap(parent)=heap(child); heap_map(heap(parent)%i,heap(parent)%j,heap(parent)%k)=parent + + ! Child is our new parent + parent=child + + ! First child of new parent + child=2*parent + + end do down_sift + + ! Finish up by putting the start node in place of last child (stored in parent) + heap(parent)=myheap; heap_map(heap(parent)%i,heap(parent)%j,heap(parent)%k)=parent + + return + end subroutine downsift + + ! ======================================= ! + ! Make the child node in heap is at the ! + ! right location by moving it up the tree ! + ! -node: index of node of interest ! + ! ! + ! Usage: if child value has decreased, it ! + ! needs to be sifted up ! + ! ======================================= ! + subroutine upsift(node) + implicit none + + integer, intent(in) :: node + integer :: parent,child + type(heap_type) :: myheap + + ! Copy child to bring up heap + child=node + myheap=heap(child) + + ! Continue until top of heap + up_sift: do while (child.gt.1) + + ! Get parent + parent=child/2 + + ! If parent is smaller than start value minval is already low, so exit + if (heap(parent)%G.le.myheap%G) exit up_sift + + ! Otherwise need to swap child with parent + heap(child)=heap(parent); heap_map(heap(child)%i,heap(child)%j,heap(child)%k)=child + + ! Parent is our new child + child=parent + + end do up_sift + + ! Put the stored start value into whatever parent node swapped with it + heap(child)=myheap + heap_map(heap(child)%i,heap(child)%j,heap(child)%k)=child + + return + end subroutine upsift + + ! ===================== ! + ! Heap creation routine ! + ! ===================== ! + subroutine heapify(nh) + implicit none + + integer, intent(in) :: nh + integer :: i + + ! Traverse the array and build heap + do i=nh/2,1,-1 + call downsift(nh,i) + end do + + return + end subroutine heapify + + ! ===================== ! + ! Root deletion routine ! + ! ===================== ! + subroutine delroot(nh) + implicit none + + integer, intent(inout) :: nh + + ! Check that heap is not empty + if (nh.gt.1) then + + ! Move bottom of heap to top of heap + heap(1)=heap(nh) + + ! Sift top value down the heap + call downsift(nh-1,1) + + end if + + ! Reduce heap size + nh=nh-1 + + return + end subroutine delroot + + !> Compute distance of a close cell to neighboring accepted cells + function phi_calc(n_nbrs,G_nbrs,index_nbrs,dx_nbrs) result(G_loc) + implicit none + integer, intent(in) :: n_nbrs + real(WP), dimension( n_nbrs), intent(in) :: G_nbrs + integer, dimension( n_nbrs), intent(in) :: index_nbrs + real(WP), dimension(3,n_nbrs), intent(in) :: dx_nbrs + integer :: ii,jj,kk + integer :: n,dim,dir + integer, dimension(3) :: ijk, ijk_neigh + real(WP) :: G_loc, G_tmp + integer :: local_1,local_2,local_3,local_4,local_5,local_6 + integer :: loctmp1,loctmp2,loctmp3,loctmp4,loctmp5,loctmp6 + integer, dimension(3) :: stc + + ! Compute distance using the number of accepted neighbors + select case (n_nbrs) + case(0) + ! Do nothing: G_loc already set + + case(1) + G_loc = G_nbrs(1) + sqrt(sum(dx_nbrs(1:3,1)**2)) + stc(1) = index_nbrs(1) + + case(2) ! 2 possible cases - 1) the two nbrs either lie across node from each other or 2) they don't + ! Nbrs on both sides of the node + if (abs(index_nbrs(1)).eq.abs(index_nbrs(2))) then + G_loc = G_nbrs(1) + sqrt(sum(dx_nbrs(1:3,1)**2)) + stc(1) = index_nbrs(1) + G_tmp = G_nbrs(2) + sqrt(sum(dx_nbrs(1:3,2)**2)) + if (G_tmp.lt.G_loc) then + G_loc = G_tmp + stc(1) = index_nbrs(2) + end if + else + ! Nbrs only on one side of the node + call phi_calc_2D(G_nbrs(1),G_nbrs(2),dx_nbrs(1:3,1),dx_nbrs(1:3,2),G_loc) + stc(1) = index_nbrs(1); stc(2) = index_nbrs(2) + end if + + case(3) ! 2 possible cases - 1) any two of the nbrs lie across node from each other or 2) no two nbrs do + ! First check for the crossing cases + if (abs(index_nbrs(1)).eq.abs(index_nbrs(2))) then + ! Two cases + ! #1 -------------------------------------------- + local_1 = 1 + local_2 = 3 + call phi_calc_2D(G_nbrs(local_1),G_nbrs(local_2),dx_nbrs(1:3,local_1),dx_nbrs(1:3,local_2),G_loc) + stc(1) = index_nbrs(local_1); stc(2) = index_nbrs(local_2) + ! #2 -------------------------------------------- + local_1 = 2 + local_2 = 3 + call phi_calc_2D(G_nbrs(local_1),G_nbrs(local_2),dx_nbrs(1:3,local_1),dx_nbrs(1:3,local_2),G_tmp) + if (G_tmp.lt.G_loc) then + G_loc = G_tmp + stc(1) = index_nbrs(local_1); stc(2) = index_nbrs(local_2) + end if + else if (abs(index_nbrs(2)).eq.abs(index_nbrs(3))) then + ! Two cases + ! #1 -------------------------------------------- + local_1 = 1 + local_2 = 2 + call phi_calc_2D(G_nbrs(local_1),G_nbrs(local_2),dx_nbrs(1:3,local_1),dx_nbrs(1:3,local_2),G_loc) + stc(1) = index_nbrs(local_1); stc(2) = index_nbrs(local_2) + ! #2 -------------------------------------------- + local_1 = 1 + local_2 = 3 + call phi_calc_2D(G_nbrs(local_1),G_nbrs(local_2),dx_nbrs(1:3,local_1),dx_nbrs(1:3,local_2),G_tmp) + if (G_tmp.lt.G_loc) then + G_loc = G_tmp + stc(1) = index_nbrs(local_1); stc(2) = index_nbrs(local_2) + end if + else + ! And now the non-crossed case: three nbrs all along different directions + call phi_calc_3D(G_nbrs(1),G_nbrs(2),G_nbrs(3),dx_nbrs(1:3,1),dx_nbrs(1:3,2),dx_nbrs(1:3,3),G_loc) + stc(1) = index_nbrs(1); stc(2) = index_nbrs(2); stc(3) = index_nbrs(3) + end if + + case(4) ! 2 possible cases: either 1) both sets of nbrs lie across node from each other, or 2) only one set of nbrs does + + if (abs(index_nbrs(1)).eq.abs(index_nbrs(2))) then + if (abs(index_nbrs(3)).eq.abs(index_nbrs(4))) then + ! Try 4 different 2D cases + ! #1 -------------------------------------------- + local_1 = 1 + local_2 = 3 + call phi_calc_2D(G_nbrs(local_1),G_nbrs(local_2),dx_nbrs(1:3,local_1),dx_nbrs(1:3,local_2),G_loc) + stc(1) = index_nbrs(local_1); stc(2) = index_nbrs(local_2) + ! #2 -------------------------------------------- + local_1 = 1 + local_2 = 4 + call phi_calc_2D(G_nbrs(local_1),G_nbrs(local_2),dx_nbrs(1:3,local_1),dx_nbrs(1:3,local_2),G_tmp) + if (G_tmp.lt.G_loc) then + G_loc = G_tmp + stc(1) = index_nbrs(local_1); stc(2) = index_nbrs(local_2) + end if + ! #3 -------------------------------------------- + local_1 = 2 + local_2 = 3 + call phi_calc_2D(G_nbrs(local_1),G_nbrs(local_2),dx_nbrs(1:3,local_1),dx_nbrs(1:3,local_2),G_tmp) + if (G_tmp.lt.G_loc) then + G_loc = G_tmp + stc(1) = index_nbrs(local_1); stc(2) = index_nbrs(local_2) + end if + ! #4 -------------------------------------------- + local_1 = 2 + local_2 = 4 + call phi_calc_2D(G_nbrs(local_1),G_nbrs(local_2),dx_nbrs(1:3,local_1),dx_nbrs(1:3,local_2),G_tmp) + if (G_tmp.lt.G_loc) then + G_loc = G_tmp + stc(1) = index_nbrs(local_1); stc(2) = index_nbrs(local_2) + end if + else + ! Try 2 different 3D cases + ! #1 -------------------------------------------- + local_1 = 1 + local_2 = 3 + local_3 = 4 + call phi_calc_3D(G_nbrs(local_1),G_nbrs(local_2),G_nbrs(local_3),dx_nbrs(1:3,local_1),dx_nbrs(1:3,local_2),dx_nbrs(1:3,local_3),G_loc) + stc(1) = index_nbrs(local_1); stc(2) = index_nbrs(local_2); stc(3) = index_nbrs(local_3) + ! #2 -------------------------------------------- + local_1 = 2 + local_2 = 3 + local_3 = 4 + call phi_calc_3D(G_nbrs(local_1),G_nbrs(local_2),G_nbrs(local_3),dx_nbrs(1:3,local_1),dx_nbrs(1:3,local_2),dx_nbrs(1:3,local_3),G_tmp) + if (G_tmp.lt.G_loc) then + G_loc = G_tmp + stc(1) = index_nbrs(local_1); stc(2) = index_nbrs(local_2); stc(3) = index_nbrs(local_3) + end if + end if + else if (abs(index_nbrs(2)).eq.abs(index_nbrs(3))) then + ! Try 2 different 3D cases + ! #1 -------------------------------------------- + local_1 = 1 + local_2 = 2 + local_3 = 4 + call phi_calc_3D(G_nbrs(local_1),G_nbrs(local_2),G_nbrs(local_3),dx_nbrs(1:3,local_1),dx_nbrs(1:3,local_2),dx_nbrs(1:3,local_3),G_loc) + stc(1) = index_nbrs(local_1); stc(2) = index_nbrs(local_2); stc(3) = index_nbrs(local_3) + ! #2 -------------------------------------------- + local_1 = 1 + local_2 = 3 + local_3 = 4 + call phi_calc_3D(G_nbrs(local_1),G_nbrs(local_2),G_nbrs(local_3),dx_nbrs(1:3,local_1),dx_nbrs(1:3,local_2),dx_nbrs(1:3,local_3),G_tmp) + if (G_tmp.lt.G_loc) then + G_loc = G_tmp + stc(1) = index_nbrs(local_1); stc(2) = index_nbrs(local_2); stc(3) = index_nbrs(local_3) + end if + else + ! Try 2 different 3D cases + ! #1 -------------------------------------------- + local_1 = 1 + local_2 = 2 + local_3 = 3 + call phi_calc_3D(G_nbrs(local_1),G_nbrs(local_2),G_nbrs(local_3),dx_nbrs(1:3,local_1),dx_nbrs(1:3,local_2),dx_nbrs(1:3,local_3),G_loc) + stc(1) = index_nbrs(local_1); stc(2) = index_nbrs(local_2); stc(3) = index_nbrs(local_3) + ! #2 -------------------------------------------- + local_1 = 1 + local_2 = 2 + local_3 = 4 + call phi_calc_3D(G_nbrs(local_1),G_nbrs(local_2),G_nbrs(local_3),dx_nbrs(1:3,local_1),dx_nbrs(1:3,local_2),dx_nbrs(1:3,local_3),G_tmp) + if (G_tmp.lt.G_loc) then + G_loc = G_tmp + stc(1) = index_nbrs(local_1); stc(2) = index_nbrs(local_2); stc(3) = index_nbrs(local_3) + end if + end if + + case(5) ! Only 1 case - test using the 4 possible planes and take smallest solution + + ! Renumber so that the 5th node has no one across from him + if (abs(index_nbrs(1)).ne.abs(index_nbrs(2))) then + loctmp1 = 2 + loctmp2 = 3 + loctmp3 = 4 + loctmp4 = 5 + loctmp5 = 1 + else if (abs(index_nbrs(3)).ne.abs(index_nbrs(4))) then + loctmp1 = 4 + loctmp2 = 5 + loctmp3 = 1 + loctmp4 = 2 + loctmp5 = 3 + else + loctmp1 = 1 + loctmp2 = 2 + loctmp3 = 3 + loctmp4 = 4 + loctmp5 = 5 + end if + ! #1 -------------------------------------------- + local_1 = loctmp1 + local_2 = loctmp3 + local_3 = loctmp5 + call phi_calc_3D(G_nbrs(local_1),G_nbrs(local_2),G_nbrs(local_3),dx_nbrs(1:3,local_1),dx_nbrs(1:3,local_2),dx_nbrs(1:3,local_3),G_loc) + stc(1) = index_nbrs(local_1); stc(2) = index_nbrs(local_2); stc(3) = index_nbrs(local_3) + ! #2 -------------------------------------------- + local_1 = loctmp1 + local_2 = loctmp4 + local_3 = loctmp5 + call phi_calc_3D(G_nbrs(local_1),G_nbrs(local_2),G_nbrs(local_3),dx_nbrs(1:3,local_1),dx_nbrs(1:3,local_2),dx_nbrs(1:3,local_3),G_tmp) + if (G_tmp.lt.G_loc) then + G_loc = G_tmp + stc(1) = index_nbrs(local_1); stc(2) = index_nbrs(local_2); stc(3) = index_nbrs(local_3) + end if + ! #3 -------------------------------------------- + local_1 = loctmp2 + local_2 = loctmp3 + local_3 = loctmp5 + call phi_calc_3D(G_nbrs(local_1),G_nbrs(local_2),G_nbrs(local_3),dx_nbrs(1:3,local_1),dx_nbrs(1:3,local_2),dx_nbrs(1:3,local_3),G_tmp) + if (G_tmp.lt.G_loc) then + G_loc = G_tmp + stc(1) = index_nbrs(local_1); stc(2) = index_nbrs(local_2); stc(3) = index_nbrs(local_3) + end if + ! #4 -------------------------------------------- + local_1 = loctmp2 + local_2 = loctmp4 + local_3 = loctmp5 + call phi_calc_3D(G_nbrs(local_1),G_nbrs(local_2),G_nbrs(local_3),dx_nbrs(1:3,local_1),dx_nbrs(1:3,local_2),dx_nbrs(1:3,local_3),G_tmp) + if (G_tmp.lt.G_loc) then + G_loc = G_tmp + stc(1) = index_nbrs(local_1); stc(2) = index_nbrs(local_2); stc(3) = index_nbrs(local_3) + end if + + case(6) ! Only 1 case - test using the 8 possible planes and take smallest solution + + ! #1 -------------------------------------------- + local_1 = 1 + local_2 = 3 + local_3 = 5 + call phi_calc_3D(G_nbrs(local_1),G_nbrs(local_2),G_nbrs(local_3),dx_nbrs(1:3,local_1),dx_nbrs(1:3,local_2),dx_nbrs(1:3,local_3),G_loc) + stc(1) = index_nbrs(local_1); stc(2) = index_nbrs(local_2); stc(3) = index_nbrs(local_3) + ! #2 -------------------------------------------- + local_1 = 1 + local_2 = 3 + local_3 = 6 + call phi_calc_3D(G_nbrs(local_1),G_nbrs(local_2),G_nbrs(local_3),dx_nbrs(1:3,local_1),dx_nbrs(1:3,local_2),dx_nbrs(1:3,local_3),G_tmp) + if (G_tmp.lt.G_loc) then + G_loc = G_tmp + stc(1) = index_nbrs(local_1); stc(2) = index_nbrs(local_2); stc(3) = index_nbrs(local_3) + end if + ! #3 -------------------------------------------- + local_1 = 1 + local_2 = 4 + local_3 = 5 + call phi_calc_3D(G_nbrs(local_1),G_nbrs(local_2),G_nbrs(local_3),dx_nbrs(1:3,local_1),dx_nbrs(1:3,local_2),dx_nbrs(1:3,local_3),G_tmp) + if (G_tmp.lt.G_loc) then + G_loc = G_tmp + stc(1) = index_nbrs(local_1); stc(2) = index_nbrs(local_2); stc(3) = index_nbrs(local_3) + end if + ! #4 -------------------------------------------- + local_1 = 1 + local_2 = 4 + local_3 = 6 + call phi_calc_3D(G_nbrs(local_1),G_nbrs(local_2),G_nbrs(local_3),dx_nbrs(1:3,local_1),dx_nbrs(1:3,local_2),dx_nbrs(1:3,local_3),G_tmp) + if (G_tmp.lt.G_loc) then + G_loc = G_tmp + stc(1) = index_nbrs(local_1); stc(2) = index_nbrs(local_2); stc(3) = index_nbrs(local_3) + end if + ! #5 -------------------------------------------- + local_1 = 2 + local_2 = 3 + local_3 = 5 + call phi_calc_3D(G_nbrs(local_1),G_nbrs(local_2),G_nbrs(local_3),dx_nbrs(1:3,local_1),dx_nbrs(1:3,local_2),dx_nbrs(1:3,local_3),G_tmp) + if (G_tmp.lt.G_loc) then + G_loc = G_tmp + stc(1) = index_nbrs(local_1); stc(2) = index_nbrs(local_2); stc(3) = index_nbrs(local_3) + end if + ! #6 -------------------------------------------- + local_1 = 2 + local_2 = 4 + local_3 = 5 + call phi_calc_3D(G_nbrs(local_1),G_nbrs(local_2),G_nbrs(local_3),dx_nbrs(1:3,local_1),dx_nbrs(1:3,local_2),dx_nbrs(1:3,local_3),G_tmp) + if (G_tmp.lt.G_loc) then + G_loc = G_tmp + stc(1) = index_nbrs(local_1); stc(2) = index_nbrs(local_2); stc(3) = index_nbrs(local_3) + end if + ! #7 -------------------------------------------- + local_1 = 2 + local_2 = 3 + local_3 = 6 + call phi_calc_3D(G_nbrs(local_1),G_nbrs(local_2),G_nbrs(local_3),dx_nbrs(1:3,local_1),dx_nbrs(1:3,local_2),dx_nbrs(1:3,local_3),G_tmp) + if (G_tmp.lt.G_loc) then + G_loc = G_tmp + stc(1) = index_nbrs(local_1); stc(2) = index_nbrs(local_2); stc(3) = index_nbrs(local_3) + end if + ! #8 -------------------------------------------- + local_1 = 2 + local_2 = 4 + local_3 = 6 + call phi_calc_3D(G_nbrs(local_1),G_nbrs(local_2),G_nbrs(local_3),dx_nbrs(1:3,local_1),dx_nbrs(1:3,local_2),dx_nbrs(1:3,local_3),G_tmp) + if (G_tmp.lt.G_loc) then + G_loc = G_tmp + stc(1) = index_nbrs(local_1); stc(2) = index_nbrs(local_2); stc(3) = index_nbrs(local_3) + end if + + end select + + ! Machine accuracy fix to guaranty ordering + do n=1,n_nbrs + if (G_loc.lt.G_nbrs(n)) G_loc=G_nbrs(n) + end do + end function phi_calc + + subroutine phi_calc_2D(G1,G2,dx1,dx2,G_out) + implicit none + real(WP), intent(in) :: G1,G2 + real(WP), dimension(3), intent(in) :: dx1,dx2 + real(WP), intent(out) :: G_out + real(WP) :: a,b,c,d1,d2,root1,root2 + real(WP) :: d1i,d2i + + ! Square of the distance between nodes + d1 = sum(dx1(1:3)**2) + d2 = sum(dx2(1:3)**2) + + ! Take the inverse + d1i = 1.0_WP/d1 + d2i = 1.0_WP/d2 + + ! Value of G given by root of quadratic equation + a = d1i + d2i + b = -2.0_WP*G1*d1i -2.0_WP*G2*d2i + c = (G1**2)*d1i + (G2**2)*d2i - 1.0_WP + + root1 = (-b + sqrt(max(b**2 - 4.0_WP*a*c,0.0_WP)))/(2.0_WP*a) + root2 = (-b - sqrt(max(b**2 - 4.0_WP*a*c,0.0_WP)))/(2.0_WP*a) + + ! Have to be careful about selecting these roots... + ! Don't want negative values + if (root1.le.0.0_WP) root1 = huge(1.0_WP) + if (root2.le.0.0_WP) root2 = huge(1.0_WP) + ! Also don't want values smaller than our original two G values + if (root1.le.G1) root1 = huge(1.0_WP) + if (root1.le.G2) root1 = huge(1.0_WP) + if (root2.le.G1) root2 = huge(1.0_WP) + if (root2.le.G2) root2 = huge(1.0_WP) + + G_out = min(root1,root2) + + return + end subroutine phi_calc_2D + + subroutine phi_calc_3D(G1,G2,G3,dx1,dx2,dx3,G_out) + implicit none + real(WP), intent(in) :: G1,G2,G3 + real(WP), dimension(3), intent(in) :: dx1,dx2,dx3 + real(WP), intent(out) :: G_out + real(WP) :: a,b,c,d1,d2,d3,root1,root2 + + ! Square of the distance between nodes + d1 = sum(dx1(1:3)**2) + d2 = sum(dx2(1:3)**2) + d3 = sum(dx3(1:3)**2) + + ! Take the inverse + d1 = 1.0_WP/d1 + d2 = 1.0_WP/d2 + d3 = 1.0_WP/d3 + + ! Value of G given by root of quadratic eqn + a = d1 + d2 + d3 + b = -2.0_WP*G1*d1 -2.0_WP*G2*d2 -2.0_WP*G3*d3 + c = (G1**2)*d1 + (G2**2)*d2 + (G3**2)*d3 - 1.0_WP + + root1 = (-b + sqrt(max(b**2 - 4.0_WP*a*c,0.0_WP)))/(2.0_WP*a) + root2 = (-b - sqrt(max(b**2 - 4.0_WP*a*c,0.0_WP)))/(2.0_WP*a) + + ! Have to be careful about selecting these roots... + ! Don't want negative values + if (root1.le.0.0_WP) root1 = huge(1.0_WP) + if (root2.le.0.0_WP) root2 = huge(1.0_WP) + ! Also don't want values smaller than our original two G values + if (root1.le.G1) root1 = huge(1.0_WP) + if (root1.le.G2) root1 = huge(1.0_WP) + if (root1.le.G3) root1 = huge(1.0_WP) + if (root2.le.G1) root2 = huge(1.0_WP) + if (root2.le.G2) root2 = huge(1.0_WP) + if (root2.le.G3) root2 = huge(1.0_WP) + + G_out = min(root1,root2) + + return + end subroutine phi_calc_3D + + ! =================================== ! + ! Parallel receive of single quantity ! + ! =================================== ! + function multiphase_fmm_recv(i,j,k,phi_value) result(imessage) + use mpi_f08, only : MPI_Iprobe, MPI_Recv, MPI_ANY_SOURCE, MPI_ANY_TAG, MPI_STATUS, MPI_SOURCE + use parallel, only: MPI_REAL_WP + implicit none + + integer, intent(out) :: i,j,k + real(WP), intent(out) :: phi_value + real(WP), dimension(4) :: val_recv + type(MPI_Status) :: status + integer :: ierr,isource + logical :: imessage + + ! Probe for message + call MPI_Iprobe(MPI_ANY_SOURCE,MPI_ANY_TAG,this%cfg%comm,imessage,status,ierr) + + ! If message is present, receive it + if (imessage) then + isource=status%MPI_SOURCE + call MPI_Recv(val_recv,4,MPI_REAL_WP,isource,0,this%cfg%comm,status,ierr) + i=nint(val_recv(1)) + j=nint(val_recv(2)) + k=nint(val_recv(3)) + phi_value=val_recv(4) + end if + + return + end function multiphase_fmm_recv + + ! ====================================== ! + ! Blocking receive for extension routine ! + ! ====================================== ! + subroutine multiphase_fmm_brecv(i,j,k,phi_value) + use mpi_f08, only: MPI_Recv, MPI_ANY_SOURCE, MPI_ANY_TAG, MPI_Status + use parallel, only: MPI_REAL_WP + implicit none + + integer, intent(out) :: i,j,k + real(WP), intent(out) :: phi_value + real(WP), dimension(4) :: recv_buf + type(MPI_Status) :: status + integer :: ierr + + ! Blocking receive for extension + call MPI_Recv(recv_buf,4,MPI_REAL_WP,MPI_ANY_SOURCE,MPI_ANY_TAG,this%cfg%comm,status,ierr) + i=nint(recv_buf(1)) + j=nint(recv_buf(2)) + k=nint(recv_buf(3)) + phi_value=recv_buf(4) + + return + end subroutine multiphase_fmm_brecv + + + ! ================================ ! + ! Parallel send of single quantity ! + ! ================================ ! + subroutine multiphase_fmm_send(i,j,k,value,counter) + implicit none + + integer, intent(in) :: i,j,k + real(WP), intent(in) :: value + integer :: counter + integer :: i0,j0,k0 + + ! Communicate if necessary + if (this%rank_x_lo.ge.0 .and. i.lt.this%i_passlo) then + i0=i;j0=j;k0=k + if (this%cfg%xper .and.this%cfg%iproc.eq.1 ) i0=i+this%cfg%nx + call multiphase_fmm_parallel_send(this%rank_x_lo,i0,j0,k0,value) + counter=counter+1 + end if + if (this%rank_x_hi.ge.0 .and. i.gt.this%i_passhi) then + i0=i;j0=j;k0=k + if (this%cfg%xper .and. this%cfg%iproc.eq.this%cfg%npx) i0=i-this%cfg%nx + call multiphase_fmm_parallel_send(this%rank_x_hi,i0,j0,k0,value) + counter=counter+1 + end if + if (this%rank_y_lo.ge.0 .and. j.lt.this%j_passlo) then + i0=i;j0=j;k0=k + if (this%cfg%yper .and. this%cfg%jproc.eq.1 ) j0=j+this%cfg%ny + call multiphase_fmm_parallel_send(this%rank_y_lo,i0,j0,k0,value) + counter=counter+1 + end if + if (this%rank_y_hi.ge.0 .and. j.gt.this%j_passhi) then + i0=i;j0=j;k0=k + if (this%cfg%yper .and. this%cfg%jproc.eq.this%cfg%npy) j0=j-this%cfg%ny + call multiphase_fmm_parallel_send(this%rank_y_hi,i0,j0,k0,value) + counter=counter+1 + end if + if (this%rank_z_lo.ge.0 .and. k.lt.this%k_passlo) then + i0=i;j0=j;k0=k + if (this%cfg%zper .and. this%cfg%kproc.eq.1 ) k0=k+this%cfg%nz + call multiphase_fmm_parallel_send(this%rank_z_lo,i0,j0,k0,value) + counter=counter+1 + end if + if (this%rank_z_hi.ge.0 .and. k.gt.this%k_passhi) then + i0=i;j0=j;k0=k + if (this%cfg%zper .and. this%cfg%kproc.eq.this%cfg%npz) k0=k-this%cfg%nz + call multiphase_fmm_parallel_send(this%rank_z_hi,i0,j0,k0,value) + counter=counter+1 + end if + end subroutine multiphase_fmm_send + + + subroutine multiphase_fmm_parallel_send(idest,i,j,k,phi_value) + use mpi_f08, only: MPI_Bsend + use parallel, only: MPI_REAL_WP + implicit none + + integer, intent(in) :: idest + integer, intent(in) :: i,j,k + real(WP), intent(in) :: phi_value + real(WP), dimension(4) :: buffer + integer :: ierr + + buffer(1) = real(i,WP) + buffer(2) = real(j,WP) + buffer(3) = real(k,WP) + buffer(4) = phi_value + + ! Use a buffered send + call MPI_Bsend(buffer,4,MPI_REAL_WP,idest,0,this%cfg%comm,ierr) + + return + end subroutine multiphase_fmm_parallel_send + end subroutine build end module fmm_class \ No newline at end of file From 3bbdd4d397dde59abf2e7c559b5e0fdbd7ddb32b Mon Sep 17 00:00:00 2001 From: Mark Owkes Date: Wed, 9 Apr 2025 08:30:25 -0600 Subject: [PATCH 03/70] Fixed parallelization and cleanup --- src/grid/fmm_class.f90 | 53 +++++++++++++++++------------------------- 1 file changed, 21 insertions(+), 32 deletions(-) diff --git a/src/grid/fmm_class.f90 b/src/grid/fmm_class.f90 index 6feeb49a1..34bbc1c2b 100644 --- a/src/grid/fmm_class.f90 +++ b/src/grid/fmm_class.f90 @@ -50,7 +50,6 @@ module fmm_class !> Initialize the fmm class subroutine initialize(this,cfg,name) use mpi_f08 - use parallel, only: comm implicit none class(fmm), intent(inout) :: this class(config), target, intent(in) :: cfg @@ -134,16 +133,14 @@ subroutine build(this,G,Gmax) integer, dimension(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_) :: phi_flag real(WP), dimension(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_) :: phi_fmm integer, dimension(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_,3) :: stc_plus,stc_minus - integer, dimension(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_) :: order_fmm + !integer, dimension(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_) :: order_fmm integer :: n_plus,n_minus integer :: iter - integer :: accepted_count,close_count,close_minus_count,close_plus_count + integer :: close_count,close_minus_count,close_plus_count integer :: fmm_accepted,fmm_close,fmm_far integer, dimension(this%cfg%nx_*this%cfg%ny_*this%cfg%nz_,3), target :: close_minus_ijk,close_plus_ijk integer, dimension(:,:), pointer :: close_ijk - integer, dimension(3) :: ijk, ijk_neigh ! Counter and mapping for accepted nodes - integer :: n_accepted integer, dimension(:,:), allocatable :: accepted_ijk ! Combined counter and mapping for all accepted nodes integer :: n_all_accepted @@ -161,9 +158,8 @@ subroutine build(this,G,Gmax) integer, dimension(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_) :: heap_map integer :: nheap ! Communication - integer, dimension(3) :: ibuf + integer, dimension(3) :: my_ibuf,ibuf - ! Initialize the counters n_plus = 0 n_minus = 0 @@ -273,7 +269,6 @@ subroutine build(this,G,Gmax) do k=this%cfg%kmino_,this%cfg%kmaxo_ do j=this%cfg%jmino_,this%cfg%jmaxo_ do i=this%cfg%imino_,this%cfg%imaxo_ - !phi_fmm(i,j,k) = +1.0e6_WP*Gmax*this%cfg%meshsize(i,j,k) phi_fmm(i,j,k) = Gmax end do end do @@ -288,7 +283,7 @@ subroutine build(this,G,Gmax) ! 2: count of sent messages ! 3: our current nheap - ibuf(1:2) = 0 ! clear the message counters + my_ibuf(1:2) = 0 ! clear the message counters ! Switch between sides if (iter.eq.1) then @@ -344,8 +339,7 @@ subroutine build(this,G,Gmax) ii=i;jj=j;kk=k+1 local_index = +3 end select - ! Don't add nodes that are outside the bands or BC - !if (band(ii,jj,kk).eq.0) cycle + ! Don't add nodes that are outside the BC if (this%cfg%VF(ii,jj,kk).eq.0.0_WP) cycle ! Form local metrics if (G(i,j,k)*G(ii,jj,kk).le.0.0_WP) then @@ -402,7 +396,7 @@ subroutine build(this,G,Gmax) integer :: iheap ! Check for new message from other processors do while (multiphase_fmm_recv(i,j,k,this_phi)) - + if (this_phi.lt.phi_fmm(i,j,k)) then ! Check if this value is less than the currently @@ -464,7 +458,7 @@ subroutine build(this,G,Gmax) end if ! Add one to recv message counter... - ibuf(1) = ibuf(1) + 1 + my_ibuf(1) = my_ibuf(1) + 1 end do end block message_processing @@ -527,8 +521,7 @@ subroutine build(this,G,Gmax) if (k.eq.kk) cycle local_index = +3 end select - ! Don't add nodes that are outside the bands or BC - !if (band(ii,jj,kk).eq.0) cycle + ! Don't add nodes that are outside the BC if (this%cfg%VF(ii,jj,kk).eq.0.0_WP) cycle ! Count the nodes to be used in extending the distance function if (phi_flag(ii,jj,kk).eq.fmm_close) then @@ -548,7 +541,7 @@ subroutine build(this,G,Gmax) if ( i.ge.this%cfg%imin_ .and. i.le.this%cfg%imax_ .and. & j.ge.this%cfg%jmin_ .and. j.le.this%cfg%jmax_ .and. & k.ge.this%cfg%kmin_ .and. k.le.this%cfg%kmax_ ) then - call multiphase_fmm_send(i,j,k,phi_fmm(i,j,k),ibuf(2)) + call multiphase_fmm_send(i,j,k,phi_fmm(i,j,k),my_ibuf(2)) end if ! Process already close nodes @@ -556,7 +549,7 @@ subroutine build(this,G,Gmax) integer :: ii,jj,kk integer :: nnn,iii,jjj,kkk integer :: m,nn,n_nbrs - integer :: local_index, radius + integer :: local_index real(WP) :: local_phi real(WP), dimension(6) :: phi_nbrs real(WP), dimension(3,6) :: dx_nbrs @@ -614,8 +607,7 @@ subroutine build(this,G,Gmax) iii=ii;jjj=jj;kkk=kk+1 local_index = +3 end select - ! Don't add nodes that are outside the bands or BC - !if (band(iii,jjj,kkk).eq.0) cycle + ! Don't add nodes that are outside the BC if (this%cfg%VF(iii,jjj,kkk).eq.0.0_WP) cycle ! Check for nbrs and look for... if ((G(ii,jj,kk)*G(iii,jjj,kkk)).le.0.0_WP) then @@ -659,7 +651,7 @@ subroutine build(this,G,Gmax) integer :: ii,jj,kk integer :: iii,jjj,kkk integer :: m,nn,nnn,n_nbrs - integer :: local_index, radius + integer :: local_index real(WP) :: local_phi real(WP), dimension(3,6) :: dx_nbrs real(WP), dimension(6) :: phi_nbrs @@ -717,8 +709,7 @@ subroutine build(this,G,Gmax) iii=ii;jjj=jj;kkk=kk+1 local_index = +3 end select - ! Don't add nodes that are outside the bands or BC - !if (band(iii,jjj,kkk).eq.0) cycle + ! Don't add nodes that are outside the BC if (this%cfg%VF(iii,jjj,kkk).eq.0.0_WP) cycle ! Check for nbrs and look for... if ((G(ii,jj,kk)*G(iii,jjj,kkk)).le.0.0_WP) then @@ -766,12 +757,12 @@ subroutine build(this,G,Gmax) local_done = ((nheap.eq.0).or.(local_counter.eq.local_counter_max)) end do local_loop - + communcate_messages:block - use mpi_f08, only: MPI_ALLREDUCE, MPI_SUM, MPI_IN_PLACE, MPI_INTEGER + use mpi_f08, only: MPI_ALLREDUCE, MPI_SUM, MPI_INTEGER integer :: ierr - ibuf(3) = nheap - call MPI_ALLREDUCE(MPI_IN_PLACE,ibuf,3,MPI_INTEGER,MPI_SUM,this%cfg%comm,ierr) + my_ibuf(3) = nheap + call MPI_ALLREDUCE(my_ibuf,ibuf,3,MPI_INTEGER,MPI_SUM,this%cfg%comm,ierr) global_done = ((ibuf(1).eq.ibuf(2)).and.(ibuf(3).eq.0)) end block communcate_messages @@ -1296,12 +1287,10 @@ function phi_calc(n_nbrs,G_nbrs,index_nbrs,dx_nbrs) result(G_loc) real(WP), dimension( n_nbrs), intent(in) :: G_nbrs integer, dimension( n_nbrs), intent(in) :: index_nbrs real(WP), dimension(3,n_nbrs), intent(in) :: dx_nbrs - integer :: ii,jj,kk - integer :: n,dim,dir - integer, dimension(3) :: ijk, ijk_neigh + integer :: n real(WP) :: G_loc, G_tmp - integer :: local_1,local_2,local_3,local_4,local_5,local_6 - integer :: loctmp1,loctmp2,loctmp3,loctmp4,loctmp5,loctmp6 + integer :: local_1,local_2,local_3 + integer :: loctmp1,loctmp2,loctmp3,loctmp4,loctmp5 integer, dimension(3) :: stc ! Compute distance using the number of accepted neighbors @@ -1736,7 +1725,7 @@ subroutine multiphase_fmm_send(i,j,k,value,counter) integer, intent(in) :: i,j,k real(WP), intent(in) :: value - integer :: counter + integer, intent(inout) :: counter integer :: i0,j0,k0 ! Communicate if necessary From a9883e84cb815a43e8aa253952ef0fb5fe2795db Mon Sep 17 00:00:00 2001 From: Mark Owkes Date: Wed, 9 Apr 2025 08:52:34 -0600 Subject: [PATCH 04/70] Turn off debugging --- examples/ligament/GNUmakefile | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/examples/ligament/GNUmakefile b/examples/ligament/GNUmakefile index af127cb82..f51ff99ec 100644 --- a/examples/ligament/GNUmakefile +++ b/examples/ligament/GNUmakefile @@ -9,7 +9,7 @@ USE_HYPRE = TRUE USE_LAPACK= TRUE USE_IRL = TRUE PROFILE = FALSE -DEBUG = TRUE +DEBUG = FALSE COMP = gnu EXEBASE = nga From 14ae3694713c6f2cb37fa9b34c428b5d76abafe0 Mon Sep 17 00:00:00 2001 From: Mark Owkes Date: Wed, 16 Apr 2025 15:10:23 -0600 Subject: [PATCH 05/70] Working on LJCF --- examples/ljcf/GNUmakefile | 47 ++ examples/ljcf/README | 1 + examples/ljcf/input | 40 ++ examples/ljcf/src/Make.package | 2 + examples/ljcf/src/hit_class.f90 | 428 ++++++++++++++++ examples/ljcf/src/ljcf_class.f90 | 824 +++++++++++++++++++++++++++++++ examples/ljcf/src/simulation.f90 | 158 ++++++ 7 files changed, 1500 insertions(+) create mode 100644 examples/ljcf/GNUmakefile create mode 100644 examples/ljcf/README create mode 100644 examples/ljcf/input create mode 100644 examples/ljcf/src/Make.package create mode 100644 examples/ljcf/src/hit_class.f90 create mode 100644 examples/ljcf/src/ljcf_class.f90 create mode 100644 examples/ljcf/src/simulation.f90 diff --git a/examples/ljcf/GNUmakefile b/examples/ljcf/GNUmakefile new file mode 100644 index 000000000..af127cb82 --- /dev/null +++ b/examples/ljcf/GNUmakefile @@ -0,0 +1,47 @@ +# NGA location if not yet defined +NGA_HOME ?= ../.. + +# Compilation parameters +PRECISION = DOUBLE +USE_MPI = TRUE +USE_FFTW = TRUE +USE_HYPRE = TRUE +USE_LAPACK= TRUE +USE_IRL = TRUE +PROFILE = FALSE +DEBUG = TRUE +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 two_phase particles constant_density 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/ljcf/README b/examples/ljcf/README new file mode 100644 index 000000000..5e5f940b6 --- /dev/null +++ b/examples/ljcf/README @@ -0,0 +1 @@ +This case simulates the break-up of a liquid ligament in a turbulent crossflow. \ No newline at end of file diff --git a/examples/ljcf/input b/examples/ljcf/input new file mode 100644 index 000000000..c6ed6157a --- /dev/null +++ b/examples/ljcf/input @@ -0,0 +1,40 @@ +# Parallelization +Partition : 1 1 1 +I/O partition : 1 1 1 + +# Mesh definition +X ljcf : 2 +Lx : 20 !40 +Ly : 10 !20 +Lz : 10 !20 +nx : 128 !512 +ny : 64 !256 +nz : 64 !256 + +# Flow conditions +Jet diameter : 2 +Jet velocity : 1 +Jet location : 0 +Reynolds number : 100 +Weber number : 20 +Viscosity ratio : 50 +Density ratio : 1000 +Target Re_lambda : 45 +Turbulence intensity : 0.05 + +# Time integration +Max timestep size : 5e-2 +Max cfl number : 1.0 +Max time : 200 + +# Pressure solver +Pressure tolerance : 1e-4 +Pressure iteration : 100 + +# Data output +Ensight output period : 1e-3 +Restart output period : 10 + +# Data restart +#Restart from : 3.00000E+01 +#HIT restart : hit_128 \ No newline at end of file diff --git a/examples/ljcf/src/Make.package b/examples/ljcf/src/Make.package new file mode 100644 index 000000000..ac9df0728 --- /dev/null +++ b/examples/ljcf/src/Make.package @@ -0,0 +1,2 @@ +# List here the extra files here +f90EXE_sources += simulation.f90 hit_class.f90 ljcf_class.f90 diff --git a/examples/ljcf/src/hit_class.f90 b/examples/ljcf/src/hit_class.f90 new file mode 100644 index 000000000..2d3e281b3 --- /dev/null +++ b/examples/ljcf/src/hit_class.f90 @@ -0,0 +1,428 @@ +!> Definition for an hit class +module hit_class + use precision, only: WP + use config_class, only: config + use fft3d_class, only: fft3d + use incomp_class, only: incomp + use timetracker_class, only: timetracker + use monitor_class, only: monitor + use pardata_class, only: pardata + use event_class, only: event + implicit none + private + + public :: hit + + !> HIT object + type :: hit + !> Config + type(config) :: cfg !< Mesh for solver + !> Flow solver + type(incomp) :: fs !< Incompressible flow solver + type(fft3d) :: ps !< FFT-based linear solver + type(timetracker) :: time !< Time info + !> Simulation monitor file + type(monitor) :: mfile !< General simulation monitoring + !> Work arrays + real(WP), dimension(:,:,:,:,:), allocatable :: gradU !< Velocity gradient + real(WP), dimension(:,:,:,:), allocatable :: SR !< Strain rate tensor + real(WP), dimension(:,:,:), allocatable :: resU,resV,resW !< Residuals + !> Turbulence parameters + real(WP) :: ti ! Turbulence intensity + real(WP) :: visc,meanU,meanV,meanW + real(WP) :: Urms_tgt,tke_tgt,eps_tgt ! u',k, and dissipation rate + real(WP) :: tko_tgt,eta_tgt ! Kolmogorov time and length scales + real(WP) :: Rel_tgt,Ret_tgt ! Lambda and turbulent Reynolds numbers + real(WP) :: tau_tgt ! Eddy turnover time + real(WP) :: Urms,tke,eps,Ret,Rel,eta,ell ! Current turbulence parameters (ell is large eddy size) + !> Forcing constant + real(WP) :: forcing + !> Provide a pardata object for restarts + logical :: restarted + type(pardata) :: df + type(event) :: save_evt + contains + procedure, private :: compute_stats !< Turbulence information + procedure :: init !< Initialize HIT simulation + procedure :: step !< Advance HIT simulation by one time step + procedure :: final !< Finalize HIT simulation + end type hit + + +contains + + + !> Compute turbulence stats (assumes rho=1) + subroutine compute_stats(this) + use mpi_f08, only: MPI_ALLREDUCE,MPI_SUM + use parallel, only: MPI_REAL_WP + class(hit), intent(inout) :: this + real(WP) :: myTKE,myEPS + integer :: i,j,k,ierr + ! Compute mean velocities + call this%fs%cfg%integrate(A=this%fs%U,integral=this%meanU); this%meanU=this%meanU/this%fs%cfg%vol_total + call this%fs%cfg%integrate(A=this%fs%V,integral=this%meanV); this%meanV=this%meanV/this%fs%cfg%vol_total + call this%fs%cfg%integrate(A=this%fs%W,integral=this%meanW); this%meanW=this%meanW/this%fs%cfg%vol_total + ! Compute strainrate and grad(U) + call this%fs%get_strainrate(SR=this%SR) + call this%fs%get_gradu(gradu=this%gradU) + ! Compute current TKE and dissipation rate + myTKE=0.0_WP + myEPS=0.0_WP + do k=this%fs%cfg%kmin_,this%fs%cfg%kmax_ + do j=this%fs%cfg%jmin_,this%fs%cfg%jmax_ + do i=this%fs%cfg%imin_,this%fs%cfg%imax_ + myTKE=myTKE+0.5_WP*((this%fs%U(i,j,k)-this%meanU)**2+(this%fs%V(i,j,k)-this%meanV)**2+(this%fs%W(i,j,k)-this%meanW)**2)*this%fs%cfg%vol(i,j,k) + myEPS=myEPS+2.0_WP*this%fs%cfg%vol(i,j,k)*(this%SR(1,i,j,k)**2+this%SR(2,i,j,k)**2+this%SR(3,i,j,k)**2+2.0_WP*(this%SR(4,i,j,k)**2+this%SR(5,i,j,k)**2+this%SR(6,i,j,k)**2)) + end do + end do + end do + call MPI_ALLREDUCE(myTKE,this%tke,1,MPI_REAL_WP,MPI_SUM,this%fs%cfg%comm,ierr); this%tke=this%tke/this%fs%cfg%vol_total + call MPI_ALLREDUCE(myEPS,this%eps,1,MPI_REAL_WP,MPI_SUM,this%fs%cfg%comm,ierr); this%eps=this%eps*this%visc/this%fs%cfg%vol_total + ! Compute standard parameters for HIT + this%Urms=sqrt(2.0_WP/3.0_WP*this%tke) + this%Ret=this%tke**2.0_WP/(this%visc*this%eps) + this%Rel=sqrt(20.0_WP*this%Ret/3.0_WP) + this%eta=((this%visc)**3.0_WP/this%eps)**0.25_WP + this%ell=(2.0_WP*this%tke/3.0_WP)**1.5_WP/this%eps + end subroutine compute_stats + + + !> Initialization of HIT simulation + subroutine init(this,group,xend) + use mpi_f08, only: MPI_Group + implicit none + class(hit), intent(inout) :: this + type(MPI_Group), intent(in) :: group + real(WP) :: xend + + ! Create the HIT mesh + create_config: block + use sgrid_class, only: cartesian,sgrid + use param, only: param_read + real(WP), dimension(:), allocatable :: x,y + integer, dimension(3) :: partition + type(sgrid) :: grid + integer :: j,ny + real(WP) :: Ly + ! Read in grid definition + call param_read('Ly',Ly); call param_read('ny',ny); allocate(y(ny+1)); allocate(x(ny+1)) + ! Create simple rectilinear grid in y and z + do j=1,ny+1 + y(j)=real(j-1,WP)/real(ny,WP)*Ly-0.5_WP*Ly + end do + ! Same grid in x, but shifted so it ends at xend + x=y-y(ny+1)+xend + ! General serial grid object + grid=sgrid(coord=cartesian,no=1,x=x,y=y,z=y,xper=.true.,yper=.true.,zper=.true.,name='HIT') + ! Read in partition + call param_read('Partition',partition,short='p'); partition(1)=1 + ! Create partitioned grid without walls + this%cfg=config(grp=group,decomp=partition,grid=grid) + end block create_config + + ! Initialize the work arrays + allocate_work_arrays: block + allocate(this%resU(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + allocate(this%resV(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + allocate(this%resW(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + allocate(this%SR (1:6,this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + allocate(this%gradU(1:3,1:3,this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + end block allocate_work_arrays + + + ! Initialize time tracker with 2 subiterations + initialize_timetracker: block + use param, only: param_read + this%time=timetracker(amRoot=this%cfg%amRoot) + call param_read('Max timestep size',this%time%dtmax) + call param_read('Max cfl number',this%time%cflmax) + this%time%dt=this%time%dtmax + this%time%itmax=2 + end block initialize_timetracker + + + ! Create a single-phase periodic flow solver + create_flow_solver: block + use mathtools, only: Pi + use param, only: param_read + ! Create flow solver + this%fs=incomp(cfg=this%cfg,name='NS solver') + ! Set density to 1.0 + this%fs%rho=1.0_WP + ! Set viscosity from Reynolds number + call param_read('Reynolds number',this%visc); this%visc=1.0_WP/this%visc + this%fs%visc=this%visc + ! Prepare and configure pressure solver + this%ps=fft3d(cfg=this%cfg,name='Pressure',nst=7) + ! Setup the solver + call this%fs%setup(pressure_solver=this%ps) + end block create_flow_solver + + + ! Prepare initial velocity field + initialize_velocity: block + use random, only: random_normal + use mathtools, only: Pi + use param, only: param_read,param_exists + use messager, only: log + use string, only: str_long + character(str_long) :: message + real(WP) :: max_forcing_estimate + integer :: i,j,k + ! Read in turbulence intensity for turbulence injection + call param_read('Turbulence intensity',this%ti) + ! Read in target Re_lambda and convert to target Urms + call param_read('Target Re_lambda',this%Urms_tgt) + this%Urms_tgt=this%visc/(3.0_WP*this%cfg%xL)*this%Urms_tgt**2 + ! Calculate other target quantities assuming l=0.2*xL + this%tke_tgt=1.5_WP*this%Urms_tgt**2 + this%eps_tgt=5.0_WP*this%Urms_tgt**3/this%cfg%xL + this%tko_tgt=sqrt(this%visc/this%eps_tgt) + this%eta_tgt=(this%visc**3/this%eps_tgt)**(0.25_WP) + this%Rel_tgt=sqrt(3.0_WP*this%Urms_tgt*this%cfg%xL/this%visc) + this%Ret_tgt=this%tke_tgt**2/(this%eps_tgt*this%visc) + this%tau_tgt=2.0_WP*this%tke_tgt/(3.0_WP*this%eps_tgt) + ! Read in forcing parameter (we need dt Urms =",es12.5)') this%Urms_tgt; call log(message) + write(message,'("[HIT setup] => Re_lambda =",es12.5)') this%Rel_tgt; call log(message) + write(message,'("[HIT setup] => Re_turb =",es12.5)') this%Ret_tgt; call log(message) + write(message,'("[HIT setup] => Kolmogorov Lscale =",es12.5)') this%eta_tgt; call log(message) + write(message,'("[HIT setup] => Kolmogorov Tscale =",es12.5)') this%tko_tgt; call log(message) + write(message,'("[HIT setup] => Epsilon =",es12.5)') this%eps_tgt; call log(message) + write(message,'("[HIT setup] => Eddyturnover time =",es12.5)') this%tau_tgt; call log(message) + end if + ! Gaussian initial field + do k=this%fs%cfg%kmin_,this%fs%cfg%kmax_ + do j=this%fs%cfg%jmin_,this%fs%cfg%jmax_ + do i=this%fs%cfg%imin_,this%fs%cfg%imax_ + this%fs%U(i,j,k)=random_normal(m=0.0_WP,sd=this%Urms_tgt) + this%fs%V(i,j,k)=random_normal(m=0.0_WP,sd=this%Urms_tgt) + this%fs%W(i,j,k)=random_normal(m=0.0_WP,sd=this%Urms_tgt) + end do + end do + end do + call this%fs%cfg%sync(this%fs%U) + call this%fs%cfg%sync(this%fs%V) + call this%fs%cfg%sync(this%fs%W) + ! Compute mean and remove it from the velocity field to obtain =0 + call this%fs%cfg%integrate(A=this%fs%U,integral=this%meanU); this%meanU=this%meanU/this%fs%cfg%vol_total; this%fs%U=this%fs%U-this%meanU + call this%fs%cfg%integrate(A=this%fs%V,integral=this%meanV); this%meanV=this%meanV/this%fs%cfg%vol_total; this%fs%V=this%fs%V-this%meanV + call this%fs%cfg%integrate(A=this%fs%W,integral=this%meanW); this%meanW=this%meanW/this%fs%cfg%vol_total; this%fs%W=this%fs%W-this%meanW + ! Project to ensure divergence-free + call this%fs%get_div() + this%fs%psolv%rhs=-this%fs%cfg%vol*this%fs%div + this%fs%psolv%sol=0.0_WP + call this%fs%psolv%solve() + call this%fs%shift_p(this%fs%psolv%sol) + call this%fs%get_pgrad(this%fs%psolv%sol,this%resU,this%resV,this%resW) + this%fs%P=this%fs%P+this%fs%psolv%sol + this%fs%U=this%fs%U-this%resU + this%fs%V=this%fs%V-this%resV + this%fs%W=this%fs%W-this%resW + ! Calculate divergence + call this%fs%get_div() + end block initialize_velocity + + + ! Handle restart here + perform_restart: block + use param, only: param_read + use string, only: str_medium + use filesys, only: makedir,isdir + character(len=str_medium) :: filename + integer, dimension(3) :: iopartition + ! Create event for saving restart files + this%save_evt=event(this%time,'HIT restart output') + call param_read('Restart output period',this%save_evt%tper) + ! Read in the partition for I/O + call param_read('I/O partition',iopartition) + ! Check if a restart file was provided + call param_read('HIT restart',filename,default='') + this%restarted=.false.; if (len_trim(filename).gt.0) this%restarted=.true. + ! Perform pardata initialization + if (this%restarted) then + ! Read in the file + call this%df%initialize(pg=this%cfg,iopartition=iopartition,fdata='restart/'//trim(filename)) + ! Put the data at the right place + call this%df%pull(name='U',var=this%fs%U) + call this%df%pull(name='V',var=this%fs%V) + call this%df%pull(name='W',var=this%fs%W) + call this%df%pull(name='P',var=this%fs%P) + ! Update divergence + call this%fs%get_div() + ! Also update time + call this%df%pull(name='t' ,val=this%time%t ) + call this%df%pull(name='dt',val=this%time%dt) + this%time%told=this%time%t-this%time%dt + !this%time%dt=this%time%dtmax !< Force max timestep size anyway + else + ! Prepare a new directory for storing files for restart + if (this%cfg%amRoot) then + if (.not.isdir('restart')) call makedir('restart') + end if + ! If we are not restarting, we will still need a datafile for saving restart files + call this%df%initialize(pg=this%cfg,iopartition=iopartition,filename=trim(this%cfg%name),nval=2,nvar=4) + this%df%valname=['dt','t ']; this%df%varname=['U','V','W','P'] + end if + end block perform_restart + + + ! Create monitoring file + create_monitor: block + ! Prepare some info about turbulence + call this%fs%get_max() + call this%compute_stats() + ! Create simulation monitor + this%mfile=monitor(this%fs%cfg%amRoot,'hit') + call this%mfile%add_column(this%time%n,'Timestep number') + call this%mfile%add_column(this%time%t,'Time') + call this%mfile%add_column(this%time%dt,'Timestep size') + call this%mfile%add_column(this%fs%Umax,'Umax') + call this%mfile%add_column(this%fs%Vmax,'Vmax') + call this%mfile%add_column(this%fs%Wmax,'Wmax') + call this%mfile%add_column(this%Ret,'Re_turb') + call this%mfile%add_column(this%Rel,'Re_lambda') + call this%mfile%add_column(this%Urms,'Urms') + call this%mfile%add_column(this%TKE,'TKE') + call this%mfile%add_column(this%EPS,'Epsilon') + call this%mfile%add_column(this%ell,'Large eddy size') + call this%mfile%add_column(this%eta,'Kolmogorov length') + call this%mfile%write() + end block create_monitor + + + end subroutine init + + + !> Take one time step with specified dt + subroutine step(this,dt) + implicit none + class(hit), intent(inout) :: this + real(WP), intent(in) :: dt + + ! Increment time based on provided dt + this%time%dt=dt; call this%time%increment() + + ! Remember old velocity + this%fs%Uold=this%fs%U + this%fs%Vold=this%fs%V + this%fs%Wold=this%fs%W + + ! Perform sub-iterations + do while (this%time%it.le.this%time%itmax) + + ! Build mid-time velocity + this%fs%U=0.5_WP*(this%fs%U+this%fs%Uold) + this%fs%V=0.5_WP*(this%fs%V+this%fs%Vold) + this%fs%W=0.5_WP*(this%fs%W+this%fs%Wold) + + ! Explicit calculation of drho*u/dt from NS + call this%fs%get_dmomdt(this%resU,this%resV,this%resW) + + ! Assemble explicit residual + this%resU=-2.0_WP*(this%fs%U-this%fs%Uold)+this%time%dt*this%resU + this%resV=-2.0_WP*(this%fs%V-this%fs%Vold)+this%time%dt*this%resV + this%resW=-2.0_WP*(this%fs%W-this%fs%Wold)+this%time%dt*this%resW + + ! Apply HIT forcing + hit_forcing: block + use mpi_f08, only: MPI_ALLREDUCE,MPI_SUM + use parallel, only: MPI_REAL_WP + real(WP) :: myTKE,A,myEPSp,EPSp + integer :: i,j,k,ierr + ! Calculate mean velocity + call this%fs%cfg%integrate(A=this%fs%U,integral=this%meanU); this%meanU=this%meanU/this%fs%cfg%vol_total + call this%fs%cfg%integrate(A=this%fs%V,integral=this%meanV); this%meanV=this%meanV/this%fs%cfg%vol_total + call this%fs%cfg%integrate(A=this%fs%W,integral=this%meanW); this%meanW=this%meanW/this%fs%cfg%vol_total + ! Calculate TKE and pseudo-EPS + call this%fs%get_gradu(gradu=this%gradU) + myTKE=0.0_WP; myEPSp=0.0_WP + do k=this%fs%cfg%kmin_,this%fs%cfg%kmax_ + do j=this%fs%cfg%jmin_,this%fs%cfg%jmax_ + do i=this%fs%cfg%imin_,this%fs%cfg%imax_ + myTKE =myTKE +0.5_WP*((this%fs%U(i,j,k)-this%meanU)**2+(this%fs%V(i,j,k)-this%meanV)**2+(this%fs%W(i,j,k)-this%meanW)**2)*this%fs%cfg%vol(i,j,k) + myEPSp=myEPSp+this%fs%cfg%vol(i,j,k)*(this%gradU(1,1,i,j,k)**2+this%gradU(1,2,i,j,k)**2+this%gradU(1,3,i,j,k)**2+& + & this%gradU(2,1,i,j,k)**2+this%gradU(2,2,i,j,k)**2+this%gradU(2,3,i,j,k)**2+& + & this%gradU(3,1,i,j,k)**2+this%gradU(3,2,i,j,k)**2+this%gradU(3,3,i,j,k)**2) + end do + end do + end do + call MPI_ALLREDUCE(myTKE,this%tke,1,MPI_REAL_WP,MPI_SUM,this%fs%cfg%comm,ierr); this%tke=this%tke/this%fs%cfg%vol_total + call MPI_ALLREDUCE(myEPSp,EPSp,1,MPI_REAL_WP,MPI_SUM,this%fs%cfg%comm,ierr); EPSp=EPSp*this%visc/this%fs%cfg%vol_total + A=(EPSp-this%forcing*(this%tke-this%tke_tgt)/this%tau_tgt)/(2.0_WP*this%tke) + this%resU=this%resU+A*this%time%dt*(this%fs%U-this%meanU) + this%resV=this%resV+A*this%time%dt*(this%fs%V-this%meanV) + this%resW=this%resW+A*this%time%dt*(this%fs%W-this%meanW) + end block hit_forcing + + ! Apply these residuals + this%fs%U=2.0_WP*this%fs%U-this%fs%Uold+this%resU + this%fs%V=2.0_WP*this%fs%V-this%fs%Vold+this%resV + this%fs%W=2.0_WP*this%fs%W-this%fs%Wold+this%resW + + ! Solve Poisson equation + call this%fs%get_div() + this%fs%psolv%rhs=-this%fs%cfg%vol*this%fs%div/this%time%dt + this%fs%psolv%sol=0.0_WP + call this%fs%psolv%solve() + call this%fs%shift_p(this%fs%psolv%sol) + + ! Correct velocity + call this%fs%get_pgrad(this%fs%psolv%sol,this%resU,this%resV,this%resW) + this%fs%P=this%fs%P+this%fs%psolv%sol + this%fs%U=this%fs%U-this%time%dt*this%resU + this%fs%V=this%fs%V-this%time%dt*this%resV + this%fs%W=this%fs%W-this%time%dt*this%resW + + ! Increment sub-iteration counter + this%time%it=this%time%it+1 + + end do + + ! Recompute divergence + call this%fs%get_div() + + ! Perform and output monitoring + call this%fs%get_max() + call this%compute_stats() + call this%mfile%write() + + ! Finally, see if it's time to save restart files + if (this%save_evt%occurs()) then + save_restart: block + use string, only: str_medium + character(len=str_medium) :: timestamp + ! Prefix for files + write(timestamp,'(es12.5)') this%time%t + ! Populate df and write it + call this%df%push(name='t' ,val=this%time%t ) + call this%df%push(name='dt',val=this%time%dt) + call this%df%push(name='U' ,var=this%fs%U ) + call this%df%push(name='V' ,var=this%fs%V ) + call this%df%push(name='W' ,var=this%fs%W ) + call this%df%push(name='P' ,var=this%fs%P ) + call this%df%write(fdata='restart/hit_'//trim(adjustl(timestamp))) + end block save_restart + end if + + end subroutine step + + + !> Finalize nozzle simulation + subroutine final(this) + implicit none + class(hit), intent(inout) :: this + + ! Deallocate work arrays + deallocate(this%resU,this%resV,this%resW,this%gradU,this%SR) + + end subroutine final + + +end module hit_class \ No newline at end of file diff --git a/examples/ljcf/src/ljcf_class.f90 b/examples/ljcf/src/ljcf_class.f90 new file mode 100644 index 000000000..b35a35661 --- /dev/null +++ b/examples/ljcf/src/ljcf_class.f90 @@ -0,0 +1,824 @@ +!> Definition for a ljcf atomization class +module ljcf_class + use precision, only: WP + use config_class, only: config + use iterator_class, only: iterator + use ensight_class, only: ensight + use surfmesh_class, only: surfmesh + use hypre_str_class, only: hypre_str + !use ddadi_class, only: ddadi + use vfs_class, only: vfs + use tpns_class, only: tpns + use timetracker_class, only: timetracker + use event_class, only: event + use monitor_class, only: monitor + use timer_class, only: timer + use pardata_class, only: pardata + use cclabel_class, only: cclabel + use irl_fortran_interface + implicit none + private + + public :: ljcf + + !> ljcf object + type :: ljcf + + !> Config + type(config) :: cfg + + !> Flow solver + type(vfs) :: vf !< Volume fraction solver + type(tpns) :: fs !< Two-phase flow solver + type(hypre_str) :: ps !< Structured Hypre linear solver for pressure + !type(ddadi) :: vs !< DDADI solver for velocity + type(timetracker) :: time !< Time info + type(cclabel) :: ccl !< CCLabel for local Weber number calculation + + !> Ensight postprocessing + type(surfmesh) :: smesh !< Surface mesh for interface + type(ensight) :: ens_out !< Ensight output for flow variables + type(event) :: ens_evt !< Event trigger for Ensight output + + !> Simulation monitor file + type(monitor) :: mfile !< General simulation monitoring + type(monitor) :: cflfile !< CFL monitoring + + !> Work arrays + real(WP), dimension(:,:,:), allocatable :: resU,resV,resW !< Residuals + real(WP), dimension(:,:,:), allocatable :: Ui,Vi,Wi !< Cell-centered velocities + + !> Iterator for VOF removal + type(iterator) :: vof_removal_layer !< Edge of domain where we actively remove VOF + real(WP) :: vof_removed !< Integral of VOF removed + integer :: nlayer=4 !< Size of buffer layer for VOF removal + + !> Timing info + type(monitor) :: timefile !< Timing monitoring + type(timer) :: tstep !< Timer for step + type(timer) :: tvel !< Timer for velocity + type(timer) :: tpres !< Timer for pressure + type(timer) :: tvof !< Timer for VOF + + !> Provide a pardata and an event tracker for saving restarts + type(event) :: save_evt + type(pardata) :: df + logical :: restarted + + !> Problem definition + real(WP) :: djet, Vjet + real(WP), dimension(:), allocatable :: xjet + integer :: relax_model, nwall + + contains + procedure :: init !< Initialize nozzle simulation + procedure :: step !< Advance nozzle simulation by one time step + procedure :: final !< Finalize nozzle simulation + end type ljcf + + +contains + + !> Initialization of ljcf simulation + subroutine init(this) + implicit none + class(ljcf), intent(inout) :: this + + ! Create the ljcf mesh + create_config: block + use sgrid_class, only: cartesian,sgrid + use param, only: param_read + use parallel, only: group + real(WP), dimension(:), allocatable :: x,y,z + integer, dimension(3) :: partition + type(sgrid) :: grid + integer :: i,j,k,nx,ny,nz + real(WP) :: Lx,Ly,Lz,xlig + ! Read in grid definition + call param_read('Lx',Lx); call param_read('nx',nx); allocate(x(nx+1)); call param_read('X ljcf',xlig) + 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-xlig + 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=3,x=x,y=y,z=z,xper=.false.,yper=.false.,zper=.true.,name='ljcf') + ! Read in partition + call param_read('Partition',partition,short='p') + ! Create partitioned grid without walls + this%cfg=config(grp=group,decomp=partition,grid=grid) + + end block create_config + + + ! Initialize time tracker with 2 subiterations + initialize_timetracker: block + use param, only: param_read + this%time=timetracker(amRoot=this%cfg%amRoot) + call param_read('Max timestep size',this%time%dtmax) + call param_read('Max cfl number',this%time%cflmax) + call param_read('Max time',this%time%tmax) + this%time%dt=this%time%dtmax + this%time%itmax=2 + end block initialize_timetracker + + + ! Allocate work arrays + allocate_work_arrays: block + allocate(this%resU(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + allocate(this%resV(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + allocate(this%resW(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + allocate(this%Ui (this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + allocate(this%Vi (this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + allocate(this%Wi (this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + end block allocate_work_arrays + + print*,'init walls' + + ! Set up walls before solvers are initialized + create_walls: block + use param, only: param_read,param_getsize + integer :: i,j,k,njet + ! Initialize liquid jet(s) + call param_read('Jet diameter',this%djet) + njet = param_getsize('Jet location') + allocate(this%xjet(njet)) + call param_read('Jet location',this%xjet) + call param_read('Jet velocity',this%Vjet) + ! Number of wall cells + call param_read('Wall cells in domain', this%nwall, default=1) + 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 (wall(this%cfg%pgrid,i,j,k)) then + this%cfg%VF(i,j,k)=0.0_WP + end if + end do + end do + end do + end block create_walls + + print*,'init vof' + + ! Initialize our VOF solver and field + create_and_initialize_vof: block + use vfs_class, only: remap,VFlo,VFhi,plicnet,r2pnet + use mms_geom, only: cube_refine_vol + use param, only: param_read + integer :: i,j,k,n,si,sj,sk + real(WP), dimension(3,8) :: cube_vertex + real(WP), dimension(3) :: v_cent,a_cent + real(WP) :: vol,area + integer, parameter :: amr_ref_lvl=4 + ! Create a VOF solver + call this%vf%initialize(cfg=this%cfg,reconstruction_method=r2pnet,transport_method=remap,name='VOF') + this%vf%thin_thld_min=0.0_WP + this%vf%flotsam_thld=0.0_WP + this%vf%maxcurv_times_mesh=1.0_WP + ! Initialize the interface to a ljcf + do k=this%vf%cfg%kmino_,this%vf%cfg%kmaxo_ + do j=this%vf%cfg%jmino_,this%vf%cfg%jmaxo_ + do i=this%vf%cfg%imino_,this%vf%cfg%imaxo_ + ! Set cube vertices + n=0 + do sk=0,1 + do sj=0,1 + do si=0,1 + n=n+1; cube_vertex(:,n)=[this%vf%cfg%x(i+si),this%vf%cfg%y(j+sj),this%vf%cfg%z(k+sk)] + end do + end do + end do + ! Call adaptive refinement code to get volume and barycenters recursively + vol=0.0_WP; area=0.0_WP; v_cent=0.0_WP; a_cent=0.0_WP + call cube_refine_vol(cube_vertex,vol,area,v_cent,a_cent,levelset_halfdrop,0.0_WP,amr_ref_lvl) + this%vf%VF(i,j,k)=vol/this%vf%cfg%vol(i,j,k) + if (this%vf%VF(i,j,k).ge.VFlo.and.this%vf%VF(i,j,k).le.VFhi) then + this%vf%Lbary(:,i,j,k)=v_cent + this%vf%Gbary(:,i,j,k)=([this%vf%cfg%xm(i),this%vf%cfg%ym(j),this%vf%cfg%zm(k)]-this%vf%VF(i,j,k)*this%vf%Lbary(:,i,j,k))/(1.0_WP-this%vf%VF(i,j,k)) + else + this%vf%Lbary(:,i,j,k)=[this%vf%cfg%xm(i),this%vf%cfg%ym(j),this%vf%cfg%zm(k)] + this%vf%Gbary(:,i,j,k)=[this%vf%cfg%xm(i),this%vf%cfg%ym(j),this%vf%cfg%zm(k)] + end if + end do + end do + end do + ! Update the band + call this%vf%update_band() + ! Perform interface reconstruction from VOF field + call this%vf%build_interface() + ! Set interface planes at the boundaries + call this%vf%set_full_bcond() + ! Create discontinuous polygon mesh from IRL interface + call this%vf%polygonalize_interface() + ! Calculate distance from polygons + call this%vf%distance_from_polygon() + ! Calculate subcell phasic volumes + call this%vf%subcell_vol() + ! Calculate curvature + call this%vf%get_curvature() + ! Reset moments to guarantee compatibility with interface reconstruction + call this%vf%reset_volume_moments() + end block create_and_initialize_vof + + + ! Create an iterator for removing VOF at edges + create_iterator: block + this%vof_removal_layer=iterator(this%cfg,'VOF removal',vof_removal_layer_locator) + end block create_iterator + + + ! Create a multiphase flow solver with bconds + create_flow_solver: block + use mathtools, only: Pi + use param, only: param_read + use tpns_class, only: dirichlet,clipped_neumann,bcond + use hypre_str_class, only: pcg_pfmg2 + type(bcond), pointer :: mybc + integer :: n,i,j,k + ! Create flow solver + this%fs=tpns(cfg=this%cfg,name='Two-phase NS') + ! Set fluid properties + this%fs%rho_g=1.0_WP; call param_read('Density ratio',this%fs%rho_l) + call param_read('Reynolds number',this%fs%visc_g); this%fs%visc_g=1.0_WP/this%fs%visc_g + call param_read('Viscosity ratio',this%fs%visc_l); this%fs%visc_l=this%fs%visc_g*this%fs%visc_l + call param_read('Weber number',this%fs%sigma); this%fs%sigma=1.0_WP/this%fs%sigma + ! Define inflow boundary condition on the left + call this%fs%add_bcond(name='inflow',type=dirichlet,face='x',dir=-1,canCorrect=.false.,locator=xm_locator) + ! Define outflow boundary condition on the right + call this%fs%add_bcond(name='outflow',type=clipped_neumann,face='x',dir=+1,canCorrect=.true.,locator=xp_locator) + ! Define jet boundary condition on the bottom + call this%fs%add_bcond(name='jet' ,type=dirichlet,face='y',dir=-1,canCorrect=.false.,locator=jet_bdy) + + ! Configure pressure solver + this%ps=hypre_str(cfg=this%cfg,name='Pressure',method=pcg_pfmg2,nst=7) + this%ps%maxlevel=16 + call param_read('Pressure iteration',this%ps%maxit) + call param_read('Pressure tolerance',this%ps%rcvg) + ! Configure implicit velocity solver + !this%vs=ddadi(cfg=this%cfg,name='Velocity',nst=7) + ! Setup the solver + call this%fs%setup(pressure_solver=this%ps)!,implicit_solver=this%vs) + ! Zero initial field + this%fs%U=0.0_WP; this%fs%V=0.0_WP; this%fs%W=0.0_WP + ! Apply convective velocity + call this%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) + this%fs%U(i,j,k)=1.0_WP + end do + ! Apply jet velocity + call this%fs%get_bcond('jet',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) + this%fs%V(i,j,k)=this%Vjet + !this%vf%VF(i,j,k)=1.0_WP !!!!!!!!!!!!!!!!!!!!!!!!!!! Should be based on + end do + ! Apply all other boundary conditions + call this%fs%apply_bcond(this%time%t,this%time%dt) + ! Adjust MFR for global mass balance + call this%fs%correct_mfr() + ! Compute divergence + call this%fs%get_div() + ! Compute cell-centered velocity + call this%fs%interp_vel(this%Ui,this%Vi,this%Wi) + end block create_flow_solver + + ! Create CCL + create_ccl: block + ! Initialize CCL + call this%ccl%initialize(pg=this%cfg%pgrid,name='ccl') + end block create_ccl + + ! Handle restart/saves here + handle_restart: block + use param, only: param_read + use string, only: str_medium + use filesys, only: makedir,isdir + use irl_fortran_interface, only: setNumberOfPlanes,setPlane + character(len=str_medium) :: timestamp + integer, dimension(3) :: iopartition + real(WP), dimension(:,:,:), allocatable :: P11,P12,P13,P14 + real(WP), dimension(:,:,:), allocatable :: P21,P22,P23,P24 + integer :: i,j,k + ! Create event for saving restart files + this%save_evt=event(this%time,'Restart output') + call param_read('Restart output period',this%save_evt%tper) + ! Check if we are restarting + call param_read('Restart from',timestamp,default='') + this%restarted=.false.; if (len_trim(timestamp).gt.0) this%restarted=.true. + ! Read in the I/O partition + call param_read('I/O partition',iopartition) + ! Perform pardata initialization + if (this%restarted) then + ! Read in the file + call this%df%initialize(pg=this%cfg,iopartition=iopartition,fdata='restart/data_'//trim(timestamp)) + ! Read in the planes directly and set the IRL interface + allocate(P11(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)); call this%df%pull(name='P11',var=P11) + allocate(P12(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)); call this%df%pull(name='P12',var=P12) + allocate(P13(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)); call this%df%pull(name='P13',var=P13) + allocate(P14(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)); call this%df%pull(name='P14',var=P14) + allocate(P21(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)); call this%df%pull(name='P21',var=P21) + allocate(P22(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)); call this%df%pull(name='P22',var=P22) + allocate(P23(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)); call this%df%pull(name='P23',var=P23) + allocate(P24(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)); call this%df%pull(name='P24',var=P24) + do k=this%vf%cfg%kmin_,this%vf%cfg%kmax_ + do j=this%vf%cfg%jmin_,this%vf%cfg%jmax_ + do i=this%vf%cfg%imin_,this%vf%cfg%imax_ + ! Check if the second plane is meaningful + if (this%vf%two_planes.and.P21(i,j,k)**2+P22(i,j,k)**2+P23(i,j,k)**2.gt.0.0_WP) then + call setNumberOfPlanes(this%vf%liquid_gas_interface(i,j,k),2) + call setPlane(this%vf%liquid_gas_interface(i,j,k),0,[P11(i,j,k),P12(i,j,k),P13(i,j,k)],P14(i,j,k)) + call setPlane(this%vf%liquid_gas_interface(i,j,k),1,[P21(i,j,k),P22(i,j,k),P23(i,j,k)],P24(i,j,k)) + else + call setNumberOfPlanes(this%vf%liquid_gas_interface(i,j,k),1) + call setPlane(this%vf%liquid_gas_interface(i,j,k),0,[P11(i,j,k),P12(i,j,k),P13(i,j,k)],P14(i,j,k)) + end if + end do + end do + end do + call this%vf%sync_interface() + deallocate(P11,P12,P13,P14,P21,P22,P23,P24) + ! Reset moments + call this%vf%reset_volume_moments() + ! Update the band + call this%vf%update_band() + ! Create discontinuous polygon mesh from IRL interface + call this%vf%polygonalize_interface() + ! Calculate distance from polygons + call this%vf%distance_from_polygon() + ! Calculate subcell phasic volumes + call this%vf%subcell_vol() + ! Calculate curvature + call this%vf%get_curvature() + ! Now read in the velocity solver data + call this%df%pull(name='U',var=this%fs%U) + call this%df%pull(name='V',var=this%fs%V) + call this%df%pull(name='W',var=this%fs%W) + call this%df%pull(name='P',var=this%fs%P) + call this%df%pull(name='Pjx',var=this%fs%Pjx) + call this%df%pull(name='Pjy',var=this%fs%Pjy) + call this%df%pull(name='Pjz',var=this%fs%Pjz) + ! Apply all other boundary conditions + call this%fs%apply_bcond(this%time%t,this%time%dt) + ! Compute MFR through all boundary conditions + call this%fs%get_mfr() + ! Adjust MFR for global mass balance + call this%fs%correct_mfr() + ! Compute cell-centered velocity + call this%fs%interp_vel(this%Ui,this%Vi,this%Wi) + ! Compute divergence + call this%fs%get_div() + ! Also update time + call this%df%pull(name='t' ,val=this%time%t ) + call this%df%pull(name='dt',val=this%time%dt) + this%time%told=this%time%t-this%time%dt + !this%time%dt=this%time%dtmax !< Force max timestep size anyway + else + ! We are not restarting, prepare a new directory for storing restart files + if (this%cfg%amRoot) then + if (.not.isdir('restart')) call makedir('restart') + end if + ! Prepare pardata object for saving restart files + call this%df%initialize(pg=this%cfg,iopartition=iopartition,filename=trim(this%cfg%name),nval=2,nvar=15) + this%df%valname=['t ','dt'] + this%df%varname=['U ','V ','W ','P ','Pjx','Pjy','Pjz','P11','P12','P13','P14','P21','P22','P23','P24'] + end if + end block handle_restart + + + ! Create surfmesh object for interface polygon output + create_smesh: block + use irl_fortran_interface, only: getNumberOfPlanes,getNumberOfVertices + integer :: i,j,k,np,nplane + this%smesh=surfmesh(nvar=2,name='plic') + this%smesh%varname(1)='nplane' + this%smesh%varname(2)='thickness' + ! Transfer polygons to smesh + call this%vf%update_surfmesh(this%smesh) + ! Calculate thickness + call this%vf%get_thickness() + ! Populate nplane and thickness variables + this%smesh%var(1,:)=1.0_WP + np=0 + do k=this%vf%cfg%kmin_,this%vf%cfg%kmax_ + do j=this%vf%cfg%jmin_,this%vf%cfg%jmax_ + do i=this%vf%cfg%imin_,this%vf%cfg%imax_ + if (this%cfg%VF(i,j,k).lt.2.0_WP*epsilon(1.0_WP)) cycle ! Skip cells below VF threshold + do nplane=1,getNumberOfPlanes(this%vf%liquid_gas_interface(i,j,k)) + if (getNumberOfVertices(this%vf%interface_polygon(nplane,i,j,k)).gt.0) then + np=np+1; this%smesh%var(1,np)=real(getNumberOfPlanes(this%vf%liquid_gas_interface(i,j,k)),WP) + this%smesh%var(2,np)=this%vf%thickness(i,j,k) + end if + end do + end do + end do + end do + end block create_smesh + + + ! Add Ensight output + create_ensight: block + use param, only: param_read + ! Create Ensight output from cfg + this%ens_out=ensight(cfg=this%cfg,name='ljcf') + ! Create event for Ensight output + this%ens_evt=event(time=this%time,name='Ensight output') + call param_read('Ensight output period',this%ens_evt%tper) + ! Add variables to output + call this%ens_out%add_vector('velocity',this%Ui,this%Vi,this%Wi) + call this%ens_out%add_scalar('VOF',this%vf%VF) + call this%ens_out%add_scalar('curvature',this%vf%curv) + call this%ens_out%add_scalar('pressure',this%fs%P) + call this%ens_out%add_surface('plic',this%smesh) + ! Output to ensight + if (this%ens_evt%occurs()) call this%ens_out%write_data(this%time%t) + end block create_ensight + + + ! Create a monitor file + create_monitor: block + ! Prepare some info about fields + call this%fs%get_cfl(this%time%dt,this%time%cfl) + call this%fs%get_max() + call this%vf%get_max() + ! Create simulation monitor + this%mfile=monitor(this%fs%cfg%amRoot,'simulation_atom') + call this%mfile%add_column(this%time%n,'Timestep number') + call this%mfile%add_column(this%time%t,'Time') + call this%mfile%add_column(this%time%dt,'Timestep size') + call this%mfile%add_column(this%time%cfl,'Maximum CFL') + call this%mfile%add_column(this%fs%Umax,'Umax') + call this%mfile%add_column(this%fs%Vmax,'Vmax') + call this%mfile%add_column(this%fs%Wmax,'Wmax') + call this%mfile%add_column(this%fs%Pmax,'Pmax') + call this%mfile%add_column(this%vf%VFint,'VOF integral') + call this%mfile%add_column(this%vf%SDint,'SD integral') + call this%mfile%add_column(this%vof_removed,'VOF removed') + call this%mfile%add_column(this%vf%flotsam_error,'Flotsam error') + call this%mfile%add_column(this%vf%thinstruct_error,'Film error') + call this%mfile%add_column(this%fs%divmax,'Maximum divergence') + call this%mfile%add_column(this%fs%psolv%it,'Pressure iteration') + call this%mfile%add_column(this%fs%psolv%rerr,'Pressure error') + call this%mfile%write() + ! Create CFL monitor + this%cflfile=monitor(this%fs%cfg%amRoot,'cfl_atom') + call this%cflfile%add_column(this%time%n,'Timestep number') + call this%cflfile%add_column(this%time%t,'Time') + call this%cflfile%add_column(this%fs%CFLst,'STension CFL') + call this%cflfile%add_column(this%fs%CFLc_x,'Convective xCFL') + call this%cflfile%add_column(this%fs%CFLc_y,'Convective yCFL') + call this%cflfile%add_column(this%fs%CFLc_z,'Convective zCFL') + call this%cflfile%add_column(this%fs%CFLv_x,'Viscous xCFL') + call this%cflfile%add_column(this%fs%CFLv_y,'Viscous yCFL') + call this%cflfile%add_column(this%fs%CFLv_z,'Viscous zCFL') + call this%cflfile%write() + end block create_monitor + + + ! Create a timing monitor + create_timing: block + ! Create timers + this%tstep =timer(comm=this%cfg%comm,name='Timestep') + this%tvof =timer(comm=this%cfg%comm,name='VOFsolve') + this%tvel =timer(comm=this%cfg%comm,name='Velocity') + this%tpres =timer(comm=this%cfg%comm,name='Pressure') + ! Create corresponding monitor file + this%timefile=monitor(this%fs%cfg%amRoot,'timing') + call this%timefile%add_column(this%time%n,'Timestep number') + call this%timefile%add_column(this%time%t,'Time') + call this%timefile%add_column(this%tstep%time ,trim(this%tstep%name)) + call this%timefile%add_column(this%tvof%time ,trim(this%tvof%name)) + call this%timefile%add_column(this%tvel%time ,trim(this%tvel%name)) + call this%timefile%add_column(this%tpres%time ,trim(this%tpres%name)) + end block create_timing + + print*,'done with init' + + contains + + + !> Function that localizes the x- boundary + function xm_locator(pg,i,j,k) result(isIn) + use pgrid_class, only: pgrid + class(pgrid), intent(in) :: pg + integer, intent(in) :: i,j,k + logical :: isIn + isIn=.false. + if (i.eq.pg%imin) isIn=.true. + end function xm_locator + + + !> Function that localizes the x+ boundary + function xp_locator(pg,i,j,k) result(isIn) + use pgrid_class, only: pgrid + 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 xp_locator + + + !> Function that localizes region of VOF removal + function vof_removal_layer_locator(pg,i,j,k) result(isIn) + use pgrid_class, only: pgrid + class(pgrid), intent(in) :: pg + integer, intent(in) :: i,j,k + logical :: isIn + isIn=.false. + if (i.ge.pg%imax-this%nlayer) isIn=.true. + end function vof_removal_layer_locator + + + !> Function that defines a level set function for a half droplet + function levelset_halfdrop(xyz,t) result(G) + implicit none + real(WP), dimension(3),intent(in) :: xyz + real(WP), intent(in) :: t + real(WP) :: G + G=0.5_WP*this%djet-sqrt(xyz(1)**2+(xyz(2)-this%cfg%y(this%cfg%jmin))**2+xyz(3)**2) + end function levelset_halfdrop + + !> Function that localizes the jet(s) initial location + function jet(pg,i,j,k) result(isIn) + use pgrid_class, only: pgrid + implicit none + class(pgrid), intent(in) :: pg + integer, intent(in) :: i,j,k + real(WP), dimension(3) :: xyz + logical :: isIn + isIn=.false. + xyz(1)=pg%xm(i); xyz(2)=pg%ym(j); xyz(3)=pg%zm(k) + if (levelset_halfdrop(xyz,0.0_WP).gt.0.0_WP) isIn=.true. + end function jet + + !> Function that localizes the walls surrounding the jets + function wall(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 (j.le.pg%jmin-1+this%nwall.and.(.not.jet(pg,i,j,k))) isIn=.true. + end function wall + + !> Function that localizes the jet(s) BCs at edge of domain + function jet_bdy(pg,i,j,k) result(isIn) + use pgrid_class, only: pgrid + implicit none + class(pgrid), intent(in) :: pg + integer, intent(in) :: i,j,k + real(WP), dimension(3) :: xyz + logical :: isIn + isIn=.false. + xyz(1)=pg%xm(i); xyz(2)=pg%ym(j); xyz(3)=pg%zm(k) + if (j.eq.pg%jmin.and.jet(pg,i,j,k)) isIn=.true. + end function jet_bdy + + + end subroutine init + + + !> Take one time step + subroutine step(this) + use tpns_class, only: arithmetic_visc + implicit none + class(ljcf), intent(inout) :: this + + ! Reset all timers and start timestep timer + call this%tstep%reset() + call this%tvof%reset() + call this%tvel%reset() + call this%tpres%reset() + call this%tstep%start() + + ! Increment time + call this%fs%get_cfl(this%time%dt,this%time%cfl) + call this%time%adjust_dt() + call this%time%increment() + + ! Remember old VOF + this%vf%VFold=this%vf%VF + + ! Remember old velocity + this%fs%Uold=this%fs%U + this%fs%Vold=this%fs%V + this%fs%Wold=this%fs%W + + ! Prepare old sflaggered density (at n) + call this%fs%get_olddensity(vf=this%vf) + + ! VOF solver step + call this%tvof%start() ! Start VOF timer + call this%vf%advance(dt=this%time%dt,U=this%fs%U,V=this%fs%V,W=this%fs%W) + call this%tvof%stop() ! Stop VOF timer + + ! Prepare new sflaggered viscosity (at n+1) + call this%fs%get_viscosity(vf=this%vf,strat=arithmetic_visc) + + ! Perform sub-iterations + do while (this%time%it.le.this%time%itmax) + + ! Start velocity timer + call this%tvel%start() + + ! Build mid-time velocity + this%fs%U=0.5_WP*(this%fs%U+this%fs%Uold) + this%fs%V=0.5_WP*(this%fs%V+this%fs%Vold) + this%fs%W=0.5_WP*(this%fs%W+this%fs%Wold) + + ! Preliminary mass and momentum transport step at the interface + call this%fs%prepare_advection_upwind(dt=this%time%dt) + + ! Explicit calculation of drho*u/dt from NS + call this%fs%get_dmomdt(this%resU,this%resV,this%resW) + + ! Assemble explicit residual + this%resU=-2.0_WP*this%fs%rho_U*this%fs%U+(this%fs%rho_Uold+this%fs%rho_U)*this%fs%Uold+this%time%dt*this%resU + this%resV=-2.0_WP*this%fs%rho_V*this%fs%V+(this%fs%rho_Vold+this%fs%rho_V)*this%fs%Vold+this%time%dt*this%resV + this%resW=-2.0_WP*this%fs%rho_W*this%fs%W+(this%fs%rho_Wold+this%fs%rho_W)*this%fs%Wold+this%time%dt*this%resW + + ! Form implicit residuals + call this%fs%solve_implicit(this%time%dt,this%resU,this%resV,this%resW) + + ! Apply these residuals + this%fs%U=2.0_WP*this%fs%U-this%fs%Uold+this%resU + this%fs%V=2.0_WP*this%fs%V-this%fs%Vold+this%resV + this%fs%W=2.0_WP*this%fs%W-this%fs%Wold+this%resW + + ! Apply boundary conditions + call this%fs%apply_bcond(this%time%t,this%time%dt) + + ! Stop velocity timer and start pressure timer + call this%tvel%stop() + call this%tpres%start() + + ! Solve Poisson equation + call this%fs%update_laplacian() + call this%fs%correct_mfr() + call this%fs%get_div() + !call this%fs%add_surface_tension_jump(dt=this%time%dt,div=this%fs%div,vf=this%vf) + call this%fs%add_surface_tension_jump_twoVF(dt=this%time%dt,div=this%fs%div,vf=this%vf) + this%fs%psolv%rhs=-this%fs%cfg%vol*this%fs%div/this%time%dt + this%fs%psolv%sol=0.0_WP + call this%fs%psolv%solve() + call this%fs%shift_p(this%fs%psolv%sol) + + ! Correct velocity + call this%fs%get_pgrad(this%fs%psolv%sol,this%resU,this%resV,this%resW) + this%fs%P=this%fs%P+this%fs%psolv%sol + this%fs%U=this%fs%U-this%time%dt*this%resU/max(epsilon(0.0_WP),this%fs%rho_U) + this%fs%V=this%fs%V-this%time%dt*this%resV/max(epsilon(0.0_WP),this%fs%rho_V) + this%fs%W=this%fs%W-this%time%dt*this%resW/max(epsilon(0.0_WP),this%fs%rho_W) + + ! Apply boundary conditions + call this%fs%apply_bcond(this%time%t,this%time%dt) + + ! Stop pressure timer + call this%tpres%stop() + + ! Increment sub-iteration counter + this%time%it=this%time%it+1 + + end do + + ! Recompute interpolated velocity and divergence + call this%fs%interp_vel(this%Ui,this%Vi,this%Wi) + call this%fs%get_div() + + ! Remove VOF at edge of domain + remove_vof: block + use mpi_f08, only: MPI_ALLREDUCE,MPI_SUM,MPI_IN_PLACE + use parallel, only: MPI_REAL_WP + integer :: n,i,j,k,ierr + this%vof_removed=0.0_WP + do n=1,this%vof_removal_layer%no_ + i=this%vof_removal_layer%map(1,n) + j=this%vof_removal_layer%map(2,n) + k=this%vof_removal_layer%map(3,n) + if (n.le.this%vof_removal_layer%n_) this%vof_removed=this%vof_removed+this%cfg%vol(i,j,k)*this%vf%VF(i,j,k) + this%vf%VF(i,j,k)=0.0_WP + end do + call MPI_ALLREDUCE(MPI_IN_PLACE,this%vof_removed,1,MPI_REAL_WP,MPI_SUM,this%cfg%comm,ierr) + call this%vf%clean_irl_and_band() + end block remove_vof + + ! Output to ensight + if (this%ens_evt%occurs()) then + ! Update surface mesh + update_smesh: block + use irl_fortran_interface, only: getNumberOfPlanes,getNumberOfVertices + integer :: i,j,k,np,nplane + ! Transfer polygons to smesh + call this%vf%update_surfmesh(this%smesh) + ! Also populate nplane variable + this%smesh%var(1,:)=1.0_WP + np=0 + do k=this%vf%cfg%kmin_,this%vf%cfg%kmax_ + do j=this%vf%cfg%jmin_,this%vf%cfg%jmax_ + do i=this%vf%cfg%imin_,this%vf%cfg%imax_ + if (this%cfg%VF(i,j,k).lt.2.0_WP*epsilon(1.0_WP)) cycle ! Skip cells below VF threshold + do nplane=1,getNumberOfPlanes(this%vf%liquid_gas_interface(i,j,k)) + if (getNumberOfVertices(this%vf%interface_polygon(nplane,i,j,k)).gt.0) then + np=np+1; this%smesh%var(1,np)=real(getNumberOfPlanes(this%vf%liquid_gas_interface(i,j,k)),WP) + this%smesh%var(2,np)=this%vf%thickness(i,j,k) + end if + end do + end do + end do + end do + end block update_smesh + call this%ens_out%write_data(this%time%t) + end if + + ! Stop timestep timer + call this%tstep%stop() + + ! Perform and output monitoring + call this%fs%get_max() + call this%vf%get_max() + call this%mfile%write() + call this%cflfile%write() + call this%timefile%write() + + ! Finally, see if it's time to save restart files + if (this%save_evt%occurs()) then + save_restart: block + use irl_fortran_interface + use string, only: str_medium + character(len=str_medium) :: timestamp + real(WP), dimension(:,:,:), allocatable :: P11,P12,P13,P14 + real(WP), dimension(:,:,:), allocatable :: P21,P22,P23,P24 + integer :: i,j,k + real(WP), dimension(4) :: plane + ! Handle IRL data + allocate(P11(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + allocate(P12(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + allocate(P13(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + allocate(P14(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + allocate(P21(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + allocate(P22(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + allocate(P23(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + allocate(P24(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + do k=this%vf%cfg%kmino_,this%vf%cfg%kmaxo_ + do j=this%vf%cfg%jmino_,this%vf%cfg%jmaxo_ + do i=this%vf%cfg%imino_,this%vf%cfg%imaxo_ + ! First plane + plane=getPlane(this%vf%liquid_gas_interface(i,j,k),0) + P11(i,j,k)=plane(1); P12(i,j,k)=plane(2); P13(i,j,k)=plane(3); P14(i,j,k)=plane(4) + ! Second plane + plane=0.0_WP + if (getNumberOfPlanes(this%vf%liquid_gas_interface(i,j,k)).eq.2) plane=getPlane(this%vf%liquid_gas_interface(i,j,k),1) + P21(i,j,k)=plane(1); P22(i,j,k)=plane(2); P23(i,j,k)=plane(3); P24(i,j,k)=plane(4) + end do + end do + end do + ! Prefix for files + write(timestamp,'(es12.5)') this%time%t + ! Populate df and write it + call this%df%push(name='t' ,val=this%time%t ) + call this%df%push(name='dt' ,val=this%time%dt) + call this%df%push(name='U' ,var=this%fs%U ) + call this%df%push(name='V' ,var=this%fs%V ) + call this%df%push(name='W' ,var=this%fs%W ) + call this%df%push(name='P' ,var=this%fs%P ) + call this%df%push(name='Pjx',var=this%fs%Pjx ) + call this%df%push(name='Pjy',var=this%fs%Pjy ) + call this%df%push(name='Pjz',var=this%fs%Pjz ) + call this%df%push(name='P11',var=P11 ) + call this%df%push(name='P12',var=P12 ) + call this%df%push(name='P13',var=P13 ) + call this%df%push(name='P14',var=P14 ) + call this%df%push(name='P21',var=P21 ) + call this%df%push(name='P22',var=P22 ) + call this%df%push(name='P23',var=P23 ) + call this%df%push(name='P24',var=P24 ) + call this%df%write(fdata='restart/data_'//trim(adjustl(timestamp))) + ! Deallocate + deallocate(P11,P12,P13,P14,P21,P22,P23,P24) + end block save_restart + end if + + end subroutine step + + + !> Finalize nozzle simulation + subroutine final(this) + implicit none + class(ljcf), intent(inout) :: this + + ! Deallocate work arrays + deallocate(this%resU,this%resV,this%resW,this%Ui,this%Vi,this%Wi) + + end subroutine final + + +end module ljcf_class \ No newline at end of file diff --git a/examples/ljcf/src/simulation.f90 b/examples/ljcf/src/simulation.f90 new file mode 100644 index 000000000..463799071 --- /dev/null +++ b/examples/ljcf/src/simulation.f90 @@ -0,0 +1,158 @@ +!> Various definitions and tools for running an NGA2 simulation +module simulation + use precision, only: WP + use hit_class, only: hit + use ljcf_class, only: ljcf + use coupler_class, only: coupler + implicit none + private + + !> HIT simulation + type(hit) :: turb + logical :: isInHITGrp + + !> LJCF atomization simulation + type(ljcf) :: atom + + !> Coupler from turb to atom + type(coupler) :: xcpl,ycpl,zcpl + + public :: simulation_init,simulation_run,simulation_final + +contains + + + !> Initialization of our simulation + subroutine simulation_init + use mpi_f08, only: MPI_Group + implicit none + type(MPI_Group) :: hit_group + + ! Initialize atomization simulation + call atom%init() + + ! Create an MPI group using leftmost processors only + create_hit_group: block + use parallel, only: group,comm + use mpi_f08, only: MPI_Group_incl + integer, dimension(:), allocatable :: ranks + integer, dimension(3) :: coord + integer :: n,ngrp,ierr,ny,nz + ngrp=atom%cfg%npy*atom%cfg%npz + allocate(ranks(ngrp)) + ngrp=0 + do nz=1,atom%cfg%npz + do ny=1,atom%cfg%npy + ngrp=ngrp+1 + coord=[0,ny-1,nz-1] + call MPI_CART_RANK(atom%cfg%comm,coord,ranks(ngrp),ierr) + end do + end do + call MPI_Group_incl(group,ngrp,ranks,hit_group,ierr) + if (atom%cfg%iproc.eq.1) then + isInHITGrp=.true. + else + isInHITGrp=.false. + end if + end block create_hit_group + + ! Initialize HIT simulation + if (isInHITGrp) call turb%init(group=hit_group,xend=atom%cfg%x(atom%cfg%imin)) + + ! If restarting, the domains could be out of sync, so resync + ! time by forcing HIT to be at same time as jet + if (isInHITGrp) then + turb%time%t=atom%time%t + turb%time%told=turb%time%t-turb%time%dt + end if + + ! Initialize couplers from turb to atom + create_coupler: block + use parallel, only: group + xcpl=coupler(src_grp=hit_group,dst_grp=group,name='turb2atom') + ycpl=coupler(src_grp=hit_group,dst_grp=group,name='turb2atom') + zcpl=coupler(src_grp=hit_group,dst_grp=group,name='turb2atom') + if (isInHITGrp) call xcpl%set_src(turb%cfg,'x') + if (isInHITGrp) call ycpl%set_src(turb%cfg,'y') + if (isInHITGrp) call zcpl%set_src(turb%cfg,'z') + call xcpl%set_dst(atom%cfg,'x'); call xcpl%initialize() + call ycpl%set_dst(atom%cfg,'y'); call ycpl%initialize() + call zcpl%set_dst(atom%cfg,'z'); call zcpl%initialize() + end block create_coupler + + end subroutine simulation_init + + + !> Run the simulation + subroutine simulation_run + implicit none + + ! Atomization drives overall time integration + do while (.not.atom%time%done()) + + ! Advance HIT simulation and transfer velocity info + if (isInHITGrp) then + ! Advance HIT with maximum stable dt until caught up + advance_hit: block + real(WP) :: dt + dt=0.15_WP*turb%cfg%min_meshsize/turb%Urms_tgt + do while (turb%time%t.le.atom%time%t) + call turb%step(dt) + end do + end block advance_hit + end if + + ! Handle coupling between HIT and atomization simulation + coupling: block + ! Push data from HIT simulation + if (isInHITGrp) then + push_velocity: block + real(WP) :: rescaling,tinterp + rescaling=turb%ti/turb%Urms_tgt + tinterp=(turb%time%t-atom%time%t)/(turb%time%t-turb%time%told) + turb%resU=rescaling*((1.0_WP-tinterp)*turb%fs%U+tinterp*turb%fs%Uold); call xcpl%push(turb%resU) + turb%resV=rescaling*((1.0_WP-tinterp)*turb%fs%V+tinterp*turb%fs%Vold); call ycpl%push(turb%resV) + turb%resW=rescaling*((1.0_WP-tinterp)*turb%fs%W+tinterp*turb%fs%Wold); call zcpl%push(turb%resW) + end block push_velocity + end if + ! Transfer and pull + call xcpl%transfer(); call xcpl%pull(atom%resU) + call ycpl%transfer(); call ycpl%pull(atom%resV) + call zcpl%transfer(); call zcpl%pull(atom%resW) + ! Apply time-dependent Dirichlet condition + apply_boundary_condition: block + use tpns_class, only: bcond + type(bcond), pointer :: mybc + integer :: n,i,j,k + call atom%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) + atom%fs%U(i ,j,k)=atom%resU(i ,j,k)+1.0_WP + atom%fs%V(i-1,j,k)=atom%resV(i-1,j,k) + atom%fs%W(i-1,j,k)=atom%resW(i-1,j,k) + end do + end block apply_boundary_condition + end block coupling + + ! Advance atomization simulation + call atom%step() + + end do + + end subroutine simulation_run + + + !> Finalize the NGA2 simulation + subroutine simulation_final + implicit none + + ! Finalize atomization simulation + call atom%final() + + ! Finalize HIT simulation + if (isInHITGrp) call turb%final() + + end subroutine simulation_final + + +end module simulation \ No newline at end of file From 1d4a1f6dc0fbda0143200df8f10f013209e55b77 Mon Sep 17 00:00:00 2001 From: Mark Owkes Date: Wed, 23 Apr 2025 09:53:27 -0600 Subject: [PATCH 06/70] Update to LJCF case --- examples/ljcf/input | 2 +- examples/ljcf/src/ljcf_class.f90 | 30 ++++++++++++++++++------------ 2 files changed, 19 insertions(+), 13 deletions(-) diff --git a/examples/ljcf/input b/examples/ljcf/input index c6ed6157a..16564736a 100644 --- a/examples/ljcf/input +++ b/examples/ljcf/input @@ -12,8 +12,8 @@ ny : 64 !256 nz : 64 !256 # Flow conditions +Gravity : 9.81 Jet diameter : 2 -Jet velocity : 1 Jet location : 0 Reynolds number : 100 Weber number : 20 diff --git a/examples/ljcf/src/ljcf_class.f90 b/examples/ljcf/src/ljcf_class.f90 index b35a35661..044040e52 100644 --- a/examples/ljcf/src/ljcf_class.f90 +++ b/examples/ljcf/src/ljcf_class.f90 @@ -69,6 +69,7 @@ module ljcf_class real(WP) :: djet, Vjet real(WP), dimension(:), allocatable :: xjet integer :: relax_model, nwall + real(WP) :: gravity contains procedure :: init !< Initialize nozzle simulation @@ -140,8 +141,6 @@ subroutine init(this) allocate(this%Wi (this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) end block allocate_work_arrays - print*,'init walls' - ! Set up walls before solvers are initialized create_walls: block use param, only: param_read,param_getsize @@ -151,9 +150,9 @@ subroutine init(this) njet = param_getsize('Jet location') allocate(this%xjet(njet)) call param_read('Jet location',this%xjet) - call param_read('Jet velocity',this%Vjet) + call param_read('Gravity',this%gravity) ! Number of wall cells - call param_read('Wall cells in domain', this%nwall, default=1) + call param_read('Wall cells in domain', this%nwall, default=0) do k=this%cfg%kmino_,this%cfg%kmaxo_ do j=this%cfg%jmino_,this%cfg%jmaxo_ do i=this%cfg%imino_,this%cfg%imaxo_ @@ -164,8 +163,6 @@ subroutine init(this) end do end do end block create_walls - - print*,'init vof' ! Initialize our VOF solver and field create_and_initialize_vof: block @@ -277,8 +274,7 @@ subroutine init(this) call this%fs%get_bcond('jet',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) - this%fs%V(i,j,k)=this%Vjet - !this%vf%VF(i,j,k)=1.0_WP !!!!!!!!!!!!!!!!!!!!!!!!!!! Should be based on + this%fs%V(i,j,k)=0 ! Start with zero velocity this%Vjet end do ! Apply all other boundary conditions call this%fs%apply_bcond(this%time%t,this%time%dt) @@ -301,7 +297,7 @@ subroutine init(this) use param, only: param_read use string, only: str_medium use filesys, only: makedir,isdir - use irl_fortran_interface, only: setNumberOfPlanes,setPlane + use irl_fortran_interface, only: setNumberOfPlanes,setPlane character(len=str_medium) :: timestamp integer, dimension(3) :: iopartition real(WP), dimension(:,:,:), allocatable :: P11,P12,P13,P14 @@ -498,8 +494,6 @@ subroutine init(this) call this%timefile%add_column(this%tvel%time ,trim(this%tvel%name)) call this%timefile%add_column(this%tpres%time ,trim(this%tpres%name)) end block create_timing - - print*,'done with init' contains @@ -579,7 +573,7 @@ function jet_bdy(pg,i,j,k) result(isIn) real(WP), dimension(3) :: xyz logical :: isIn isIn=.false. - xyz(1)=pg%xm(i); xyz(2)=pg%ym(j); xyz(3)=pg%zm(k) + xyz(1)=pg%xm(i); xyz(2)=pg%y(j); xyz(3)=pg%zm(k) if (j.eq.pg%jmin.and.jet(pg,i,j,k)) isIn=.true. end function jet_bdy @@ -612,6 +606,18 @@ subroutine step(this) this%fs%Uold=this%fs%U this%fs%Vold=this%fs%V this%fs%Wold=this%fs%W + + ! Apply jet velocity + apply_bc: block + use tpns_class, only: bcond + type(bcond), pointer :: mybc + integer :: n,i,j,k + call this%fs%get_bcond('jet',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) + this%fs%V(i,j,k)=this%gravity*this%time%t + end do + end block apply_bc ! Prepare old sflaggered density (at n) call this%fs%get_olddensity(vf=this%vf) From 51aa166f39fe31355f072726feaf18bfdf8a9520 Mon Sep 17 00:00:00 2001 From: Mark Owkes Date: Wed, 23 Apr 2025 09:53:48 -0600 Subject: [PATCH 07/70] Dealing with dividing by zero --- src/two_phase/tpns_class.f90 | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/two_phase/tpns_class.f90 b/src/two_phase/tpns_class.f90 index 0fe760b3a..6f28fb04f 100644 --- a/src/two_phase/tpns_class.f90 +++ b/src/two_phase/tpns_class.f90 @@ -3028,9 +3028,9 @@ subroutine solve_implicit(this,dt,resU,resV,resW) ! If no implicit solver available, just divide by density and return if (.not.associated(this%implicit)) then - resU=resU/this%rho_U - resV=resV/this%rho_V - resW=resW/this%rho_W + resU=resU/max(epsilon(0.0_WP),this%rho_U) + resV=resV/max(epsilon(0.0_WP),this%rho_V) + resW=resW/max(epsilon(0.0_WP),this%rho_W) call this%cfg%sync(resU) call this%cfg%sync(resV) call this%cfg%sync(resW) From e4263f1d63578baba1d353b5ac09d7001c84146d Mon Sep 17 00:00:00 2001 From: Mark Owkes Date: Wed, 23 Apr 2025 10:18:12 -0600 Subject: [PATCH 08/70] Added tStop to turn off jet once volume of liquid injection is complete --- examples/ljcf/input | 7 ++++--- examples/ljcf/src/ljcf_class.f90 | 16 +++++++++++++--- 2 files changed, 17 insertions(+), 6 deletions(-) diff --git a/examples/ljcf/input b/examples/ljcf/input index 16564736a..8b619be60 100644 --- a/examples/ljcf/input +++ b/examples/ljcf/input @@ -12,9 +12,10 @@ ny : 64 !256 nz : 64 !256 # Flow conditions -Gravity : 9.81 -Jet diameter : 2 -Jet location : 0 +Gravity : 9.81 +Jet diameter : 0.054 +Liquid Volume : 3.2e-3 +Jet location : 0 Reynolds number : 100 Weber number : 20 Viscosity ratio : 50 diff --git a/examples/ljcf/src/ljcf_class.f90 b/examples/ljcf/src/ljcf_class.f90 index 044040e52..0aa45552e 100644 --- a/examples/ljcf/src/ljcf_class.f90 +++ b/examples/ljcf/src/ljcf_class.f90 @@ -69,7 +69,7 @@ module ljcf_class real(WP) :: djet, Vjet real(WP), dimension(:), allocatable :: xjet integer :: relax_model, nwall - real(WP) :: gravity + real(WP) :: gravity, liqVol contains procedure :: init !< Initialize nozzle simulation @@ -151,6 +151,7 @@ subroutine init(this) allocate(this%xjet(njet)) call param_read('Jet location',this%xjet) call param_read('Gravity',this%gravity) + call param_read('Liquid Volume',this%liqVol) ! Number of wall cells call param_read('Wall cells in domain', this%nwall, default=0) do k=this%cfg%kmino_,this%cfg%kmaxo_ @@ -609,13 +610,22 @@ subroutine step(this) ! Apply jet velocity apply_bc: block - use tpns_class, only: bcond + use tpns_class, only: bcond + use mathtools, only: Pi type(bcond), pointer :: mybc integer :: n,i,j,k + real(WP) :: tStop,AreaJet + ! Compute the time to stop the jet + AreaJet=Pi*this%djet**2/4.0_WP + tStop = sqrt(2*this%liqVol/(this%gravity*AreaJet)) call this%fs%get_bcond('jet',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) - this%fs%V(i,j,k)=this%gravity*this%time%t + if (this%time%t < tStop) then + this%fs%V(i,j,k)=this%gravity*this%time%t ! Velocity increases linearly with time + else + this%fs%V(i,j,k)=0.0_WP ! Velocity stops once volume is reached + end if end do end block apply_bc From 4e2054b2ad612d530b5d59acfa20c0472138089f Mon Sep 17 00:00:00 2001 From: Mark Owkes Date: Mon, 5 May 2025 11:29:31 -0600 Subject: [PATCH 09/70] Updates to LJCF inflow and geometry --- examples/ljcf/input | 14 +++++++------- examples/ljcf/src/ljcf_class.f90 | 26 ++++++++++++++++++++++++++ 2 files changed, 33 insertions(+), 7 deletions(-) diff --git a/examples/ljcf/input b/examples/ljcf/input index 8b619be60..97e2306f5 100644 --- a/examples/ljcf/input +++ b/examples/ljcf/input @@ -3,13 +3,13 @@ Partition : 1 1 1 I/O partition : 1 1 1 # Mesh definition -X ljcf : 2 -Lx : 20 !40 -Ly : 10 !20 -Lz : 10 !20 -nx : 128 !512 -ny : 64 !256 -nz : 64 !256 +X ljcf : 0.1 +Lx : 0.432 !40 +Ly : 0.81 !20 +Lz : 0.216 !20 +nx : 64 !512 +ny : 128 !256 +nz : 32 !256 # Flow conditions Gravity : 9.81 diff --git a/examples/ljcf/src/ljcf_class.f90 b/examples/ljcf/src/ljcf_class.f90 index 0aa45552e..587db2d34 100644 --- a/examples/ljcf/src/ljcf_class.f90 +++ b/examples/ljcf/src/ljcf_class.f90 @@ -213,6 +213,30 @@ subroutine init(this) call this%vf%build_interface() ! Set interface planes at the boundaries call this%vf%set_full_bcond() + ! Now apply Neumann condition on interface at inlet to have proper round injection + neumann_irl: block + use irl_fortran_interface, only: getPlane,new,construct_2pt,RectCub_type,& + & setNumberOfPlanes,setPlane,matchVolumeFraction + real(WP), dimension(1:4) :: plane + type(RectCub_type) :: cell + call new(cell) + if (this%vf%cfg%iproc.eq.1) then + do k=this%vf%cfg%kmino_,this%vf%cfg%kmaxo_ + do j=this%vf%cfg%jmino_,this%vf%cfg%jmaxo_ + do i=this%vf%cfg%imino,this%vf%cfg%imin-1 + ! Extract plane data and copy in overlap + plane=getPlane(this%vf%liquid_gas_interface(this%vf%cfg%imin,j,k),0) + call construct_2pt(cell,[this%vf%cfg%x(i ),this%vf%cfg%y(j ),this%vf%cfg%z(k )],& + & [this%vf%cfg%x(i+1),this%vf%cfg%y(j+1),this%vf%cfg%z(k+1)]) + plane(4)=dot_product(plane(1:3),[this%vf%cfg%xm(i),this%vf%cfg%ym(j),this%vf%cfg%zm(k)]) + call setNumberOfPlanes(this%vf%liquid_gas_interface(i,j,k),1) + call setPlane(this%vf%liquid_gas_interface(i,j,k),0,plane(1:3),plane(4)) + call matchVolumeFraction(cell,this%vf%VF(i,j,k),this%vf%liquid_gas_interface(i,j,k)) + end do + end do + end do + end if + end block neumann_irl ! Create discontinuous polygon mesh from IRL interface call this%vf%polygonalize_interface() ! Calculate distance from polygons @@ -253,6 +277,8 @@ subroutine init(this) call this%fs%add_bcond(name='outflow',type=clipped_neumann,face='x',dir=+1,canCorrect=.true.,locator=xp_locator) ! Define jet boundary condition on the bottom call this%fs%add_bcond(name='jet' ,type=dirichlet,face='y',dir=-1,canCorrect=.false.,locator=jet_bdy) + ! Define gravity as vector for flow solver + this%fs%gravity(2) = this%gravity ! Configure pressure solver this%ps=hypre_str(cfg=this%cfg,name='Pressure',method=pcg_pfmg2,nst=7) From 645c834d6a226d734dbb7631406cd08ab8a45330 Mon Sep 17 00:00:00 2001 From: Mark Owkes Date: Tue, 6 May 2025 11:31:05 -0600 Subject: [PATCH 10/70] Made LJCF non-dimensional and fixed inflow --- examples/ljcf/GNUmakefile | 2 +- examples/ljcf/input | 34 +++++++++++++++--------------- examples/ljcf/src/ljcf_class.f90 | 36 +++++++++++++++++--------------- 3 files changed, 37 insertions(+), 35 deletions(-) diff --git a/examples/ljcf/GNUmakefile b/examples/ljcf/GNUmakefile index af127cb82..f51ff99ec 100644 --- a/examples/ljcf/GNUmakefile +++ b/examples/ljcf/GNUmakefile @@ -9,7 +9,7 @@ USE_HYPRE = TRUE USE_LAPACK= TRUE USE_IRL = TRUE PROFILE = FALSE -DEBUG = TRUE +DEBUG = FALSE COMP = gnu EXEBASE = nga diff --git a/examples/ljcf/input b/examples/ljcf/input index 97e2306f5..80ab85aaf 100644 --- a/examples/ljcf/input +++ b/examples/ljcf/input @@ -3,28 +3,28 @@ Partition : 1 1 1 I/O partition : 1 1 1 # Mesh definition -X ljcf : 0.1 -Lx : 0.432 !40 -Ly : 0.81 !20 -Lz : 0.216 !20 +X ljcf : 2 +Lx : 8 +Ly : 8 #16 +Lz : 4 nx : 64 !512 -ny : 128 !256 +ny : 64 #128 !256 nz : 32 !256 # Flow conditions -Gravity : 9.81 -Jet diameter : 0.054 -Liquid Volume : 3.2e-3 +Jet diameter : 1 +Liquid Volume : 20.322 # Vol/D^3 = 3.2e-3 m^3 / (0.054 m)^3 Jet location : 0 -Reynolds number : 100 -Weber number : 20 -Viscosity ratio : 50 -Density ratio : 1000 +Reynolds number : 4000 #######39600 # rho_g*u*D/mu_g = 1.2 kg/m^3 * 11 m/s * 0.054 m / 1.8e-5 Pa-s +Weber number : 108.9 # rho_g*u^2*D/sigma = 1.2 kg/m^3 * (11 m/s)^2 * 0.054 m / 0.072 N/m +Froude number : 15.12 # u/sqrt(g*D) = 11 m/s / sqrt(9.8 m/s^2 0.054 m) +Viscosity ratio : 55.55 +Density ratio : 833.33 Target Re_lambda : 45 Turbulence intensity : 0.05 # Time integration -Max timestep size : 5e-2 +Max timestep size : 2.5e-2 Max cfl number : 1.0 Max time : 200 @@ -33,9 +33,9 @@ Pressure tolerance : 1e-4 Pressure iteration : 100 # Data output -Ensight output period : 1e-3 -Restart output period : 10 +Ensight output period : 1 +Restart output period : 1 # Data restart -#Restart from : 3.00000E+01 -#HIT restart : hit_128 \ No newline at end of file +#Restart from : 1.00000E+01 +#HIT restart : hit_1.00000E+01 \ No newline at end of file diff --git a/examples/ljcf/src/ljcf_class.f90 b/examples/ljcf/src/ljcf_class.f90 index 587db2d34..9454ee175 100644 --- a/examples/ljcf/src/ljcf_class.f90 +++ b/examples/ljcf/src/ljcf_class.f90 @@ -69,7 +69,7 @@ module ljcf_class real(WP) :: djet, Vjet real(WP), dimension(:), allocatable :: xjet integer :: relax_model, nwall - real(WP) :: gravity, liqVol + real(WP) :: gravity, liqVol, liqVolInjected contains procedure :: init !< Initialize nozzle simulation @@ -150,8 +150,9 @@ subroutine init(this) njet = param_getsize('Jet location') allocate(this%xjet(njet)) call param_read('Jet location',this%xjet) - call param_read('Gravity',this%gravity) + call param_read('Froude number',this%gravity); this%gravity = 1.0_WP/this%gravity**2 call param_read('Liquid Volume',this%liqVol) + this%liqVolInjected = 0.0_WP ! Number of wall cells call param_read('Wall cells in domain', this%nwall, default=0) do k=this%cfg%kmino_,this%cfg%kmaxo_ @@ -195,7 +196,11 @@ subroutine init(this) end do ! Call adaptive refinement code to get volume and barycenters recursively vol=0.0_WP; area=0.0_WP; v_cent=0.0_WP; a_cent=0.0_WP - call cube_refine_vol(cube_vertex,vol,area,v_cent,a_cent,levelset_halfdrop,0.0_WP,amr_ref_lvl) + if (j.lt.this%vf%cfg%jmin) then + call cube_refine_vol(cube_vertex,vol,area,v_cent,a_cent,levelset_halfdrop,0.0_WP,amr_ref_lvl) + else + ! do nothing + end if this%vf%VF(i,j,k)=vol/this%vf%cfg%vol(i,j,k) if (this%vf%VF(i,j,k).ge.VFlo.and.this%vf%VF(i,j,k).le.VFhi) then this%vf%Lbary(:,i,j,k)=v_cent @@ -481,6 +486,7 @@ subroutine init(this) call this%mfile%add_column(this%fs%Vmax,'Vmax') call this%mfile%add_column(this%fs%Wmax,'Wmax') call this%mfile%add_column(this%fs%Pmax,'Pmax') + call this%mfile%add_column(this%liqVolInjected,'Liq Vol Injected') call this%mfile%add_column(this%vf%VFint,'VOF integral') call this%mfile%add_column(this%vf%SDint,'SD integral') call this%mfile%add_column(this%vof_removed,'VOF removed') @@ -625,35 +631,31 @@ subroutine step(this) call this%fs%get_cfl(this%time%dt,this%time%cfl) call this%time%adjust_dt() call this%time%increment() - - ! Remember old VOF - this%vf%VFold=this%vf%VF - - ! Remember old velocity - this%fs%Uold=this%fs%U - this%fs%Vold=this%fs%V - this%fs%Wold=this%fs%W ! Apply jet velocity apply_bc: block use tpns_class, only: bcond - use mathtools, only: Pi type(bcond), pointer :: mybc integer :: n,i,j,k - real(WP) :: tStop,AreaJet - ! Compute the time to stop the jet - AreaJet=Pi*this%djet**2/4.0_WP - tStop = sqrt(2*this%liqVol/(this%gravity*AreaJet)) call this%fs%get_bcond('jet',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) - if (this%time%t < tStop) then + if (this%liqVolInjected .lt. this%liqVol) then this%fs%V(i,j,k)=this%gravity*this%time%t ! Velocity increases linearly with time else this%fs%V(i,j,k)=0.0_WP ! Velocity stops once volume is reached end if + this%liqVolInjected = this%liqVolInjected + this%fs%V(i,j,k)*this%vf%VF(i,j-1,k)*this%cfg%dx(i)*this%cfg%dz(k)*this%time%dt end do end block apply_bc + + ! Remember old VOF + this%vf%VFold=this%vf%VF + + ! Remember old velocity + this%fs%Uold=this%fs%U + this%fs%Vold=this%fs%V + this%fs%Wold=this%fs%W ! Prepare old sflaggered density (at n) call this%fs%get_olddensity(vf=this%vf) From 310d6b93c580eab56a71a9924f5d19bc01b702a1 Mon Sep 17 00:00:00 2001 From: Mark Owkes Date: Thu, 29 May 2025 14:06:38 -0600 Subject: [PATCH 11/70] fmm is based on pgrid with a mask that is passed in. For many problems the mask will be set to cfg%mask but this allows for other fields to be passed in (such as when using IBs) --- examples/ligament/src/ligament_class.f90 | 4 +- src/grid/fmm_class.f90 | 202 ++++++++++++----------- 2 files changed, 104 insertions(+), 102 deletions(-) diff --git a/examples/ligament/src/ligament_class.f90 b/examples/ligament/src/ligament_class.f90 index b0c59c11e..cb1aa507a 100644 --- a/examples/ligament/src/ligament_class.f90 +++ b/examples/ligament/src/ligament_class.f90 @@ -265,7 +265,7 @@ subroutine init(this) ! Create FMM create_fmm: block ! Initialize FMM - call this%fmm%initialize(cfg=this%cfg,name='fmm') + call this%fmm%initialize(pg=this%cfg,name='fmm') end block create_fmm ! Handle restart/saves here @@ -795,7 +795,7 @@ subroutine step(this) end do end do end do - call this%fmm%build(this%G,Gmax) + call this%fmm%build(this%G,Gmax,this%cfg%VF) end block fmm_build ! Compute dominant gas velocity direction diff --git a/src/grid/fmm_class.f90 b/src/grid/fmm_class.f90 index 34bbc1c2b..b1ead09d8 100644 --- a/src/grid/fmm_class.f90 +++ b/src/grid/fmm_class.f90 @@ -3,7 +3,7 @@ module fmm_class use precision, only: WP use string, only: str_medium - use config_class, only: config + use pgrid_class, only: pgrid implicit none private @@ -20,8 +20,8 @@ module fmm_class !> fmm object definition type :: fmm - ! This is our config - class(config), pointer :: cfg + ! This is our pgrid + class(pgrid), pointer :: pg ! This is the name of the fmm character(len=str_medium) :: name='UNNAMED_FFM' ! i,j,k's for close nodes @@ -48,72 +48,72 @@ module fmm_class contains !> Initialize the fmm class - subroutine initialize(this,cfg,name) + subroutine initialize(this,pg,name) use mpi_f08 implicit none class(fmm), intent(inout) :: this - class(config), target, intent(in) :: cfg + class(pgrid), target, intent(in) :: pg character(len=*), optional :: name integer :: isource,idest,ierr ! Set the name for the object if (present(name)) this%name=trim(adjustl(name)) - ! Point to cfg object - this%cfg=>cfg + ! Point to pgrid object + this%pg=>pg ! Determine the ranks of the procs that this proc should send to - call MPI_CART_SHIFT(this%cfg%comm,0,-1,isource,idest,ierr); this%rank_x_lo=idest - call MPI_CART_SHIFT(this%cfg%comm,0,+1,isource,idest,ierr); this%rank_x_hi=idest - call MPI_CART_SHIFT(this%cfg%comm,1,-1,isource,idest,ierr); this%rank_y_lo=idest - call MPI_CART_SHIFT(this%cfg%comm,1,+1,isource,idest,ierr); this%rank_y_hi=idest - call MPI_CART_SHIFT(this%cfg%comm,2,-1,isource,idest,ierr); this%rank_z_lo=idest - call MPI_CART_SHIFT(this%cfg%comm,2,+1,isource,idest,ierr); this%rank_z_hi=idest + call MPI_CART_SHIFT(this%pg%comm,0,-1,isource,idest,ierr); this%rank_x_lo=idest + call MPI_CART_SHIFT(this%pg%comm,0,+1,isource,idest,ierr); this%rank_x_hi=idest + call MPI_CART_SHIFT(this%pg%comm,1,-1,isource,idest,ierr); this%rank_y_lo=idest + call MPI_CART_SHIFT(this%pg%comm,1,+1,isource,idest,ierr); this%rank_y_hi=idest + call MPI_CART_SHIFT(this%pg%comm,2,-1,isource,idest,ierr); this%rank_z_lo=idest + call MPI_CART_SHIFT(this%pg%comm,2,+1,isource,idest,ierr); this%rank_z_hi=idest ! Set bounds on what nodes to send to other procs - if (this%cfg%nx.gt.1) then - this%i_passlo=this%cfg%imin_+1 - this%i_passhi=this%cfg%imax_-1 + if (this%pg%nx.gt.1) then + this%i_passlo=this%pg%imin_+1 + this%i_passhi=this%pg%imax_-1 else - this%i_passlo=this%cfg%imin_ - this%i_passhi=this%cfg%imax_ + this%i_passlo=this%pg%imin_ + this%i_passhi=this%pg%imax_ end if - if (this%cfg%ny.gt.1) then - this%j_passlo=this%cfg%jmin_+1 - this%j_passhi=this%cfg%jmax_-1 + if (this%pg%ny.gt.1) then + this%j_passlo=this%pg%jmin_+1 + this%j_passhi=this%pg%jmax_-1 else - this%j_passlo=this%cfg%jmin_ - this%j_passhi=this%cfg%jmax_ + this%j_passlo=this%pg%jmin_ + this%j_passhi=this%pg%jmax_ end if - if (this%cfg%nz.gt.1) then - this%k_passlo=this%cfg%kmin_+1 - this%k_passhi=this%cfg%kmax_-1 + if (this%pg%nz.gt.1) then + this%k_passlo=this%pg%kmin_+1 + this%k_passhi=this%pg%kmax_-1 else - this%k_passlo=this%cfg%kmin_ - this%k_passhi=this%cfg%kmax_ + this%k_passlo=this%pg%kmin_ + this%k_passhi=this%pg%kmax_ end if ! Set bounds for the ghost nodes to consider given problem dimensions - if (this%cfg%nx.gt.1) then - this%imin_close=this%cfg%imin_-1 - this%imax_close=this%cfg%imax_+1 + if (this%pg%nx.gt.1) then + this%imin_close=this%pg%imin_-1 + this%imax_close=this%pg%imax_+1 else - this%imin_close=this%cfg%imin_ - this%imax_close=this%cfg%imax_ + this%imin_close=this%pg%imin_ + this%imax_close=this%pg%imax_ end if - if (this%cfg%ny.gt.1) then - this%jmin_close=this%cfg%jmin_-1 - this%jmax_close=this%cfg%jmax_+1 + if (this%pg%ny.gt.1) then + this%jmin_close=this%pg%jmin_-1 + this%jmax_close=this%pg%jmax_+1 else - this%jmin_close=this%cfg%jmin_ - this%jmax_close=this%cfg%jmax_ + this%jmin_close=this%pg%jmin_ + this%jmax_close=this%pg%jmax_ end if - if (this%cfg%nz.gt.1) then - this%kmin_close=this%cfg%kmin_-1 - this%kmax_close=this%cfg%kmax_+1 + if (this%pg%nz.gt.1) then + this%kmin_close=this%pg%kmin_-1 + this%kmax_close=this%pg%kmax_+1 else - this%kmin_close=this%cfg%kmin_ - this%kmax_close=this%cfg%kmax_ + this%kmin_close=this%pg%kmin_ + this%kmax_close=this%pg%kmax_ end if ! Attach an mpi buffer for parallelization @@ -124,21 +124,23 @@ subroutine initialize(this,cfg,name) end subroutine initialize !> Update the distance field using estimate provided in G function out to Gmax - subroutine build(this,G,Gmax) + !> cells with mask.eq.0.0_WP are not considered + subroutine build(this,G,Gmax,mask) use messager, only: die implicit none class(fmm), intent(inout) :: this - real(WP), dimension(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_), intent(inout) :: G + real(WP), dimension(this%pg%imino_:this%pg%imaxo_,this%pg%jmino_:this%pg%jmaxo_,this%pg%kmino_:this%pg%kmaxo_), intent(inout) :: G real(WP), intent(in) :: Gmax - integer, dimension(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_) :: phi_flag - real(WP), dimension(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_) :: phi_fmm - integer, dimension(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_,3) :: stc_plus,stc_minus - !integer, dimension(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_) :: order_fmm + real(WP), dimension(this%pg%imino_:this%pg%imaxo_,this%pg%jmino_:this%pg%jmaxo_,this%pg%kmino_:this%pg%kmaxo_), intent(in) :: mask + integer, dimension(this%pg%imino_:this%pg%imaxo_,this%pg%jmino_:this%pg%jmaxo_,this%pg%kmino_:this%pg%kmaxo_) :: phi_flag + real(WP), dimension(this%pg%imino_:this%pg%imaxo_,this%pg%jmino_:this%pg%jmaxo_,this%pg%kmino_:this%pg%kmaxo_) :: phi_fmm + integer, dimension(this%pg%imino_:this%pg%imaxo_,this%pg%jmino_:this%pg%jmaxo_,this%pg%kmino_:this%pg%kmaxo_,3) :: stc_plus,stc_minus + !integer, dimension(this%pg%imino_:this%pg%imaxo_,this%pg%jmino_:this%pg%jmaxo_,this%pg%kmino_:this%pg%kmaxo_) :: order_fmm integer :: n_plus,n_minus integer :: iter integer :: close_count,close_minus_count,close_plus_count integer :: fmm_accepted,fmm_close,fmm_far - integer, dimension(this%cfg%nx_*this%cfg%ny_*this%cfg%nz_,3), target :: close_minus_ijk,close_plus_ijk + integer, dimension(this%pg%nx_*this%pg%ny_*this%pg%nz_,3), target :: close_minus_ijk,close_plus_ijk integer, dimension(:,:), pointer :: close_ijk ! Counter and mapping for accepted nodes integer, dimension(:,:), allocatable :: accepted_ijk @@ -155,7 +157,7 @@ subroutine build(this,G,Gmax) integer, parameter :: fmm_tmp = 7 ! Heap data type(heap_type), dimension(:), allocatable :: heap - integer, dimension(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_) :: heap_map + integer, dimension(this%pg%imino_:this%pg%imaxo_,this%pg%jmino_:this%pg%jmaxo_,this%pg%kmino_:this%pg%kmaxo_) :: heap_map integer :: nheap ! Communication integer, dimension(3) :: my_ibuf,ibuf @@ -168,12 +170,12 @@ subroutine build(this,G,Gmax) ! First tag all nodes and make plus and minus counts tag_nodes: block integer :: i,j,k - do k=this%cfg%kmino_,this%cfg%kmaxo_ - do j=this%cfg%jmino_,this%cfg%jmaxo_ - do i=this%cfg%imino_,this%cfg%imaxo_ + do k=this%pg%kmino_,this%pg%kmaxo_ + do j=this%pg%jmino_,this%pg%jmaxo_ + do i=this%pg%imino_,this%pg%imaxo_ ! Cycle if too far or BC !if (band(i,j,k).eq.0) cycle !!!! without band then the n_plus & n_minus is large!!! - if (this%cfg%VF(i,j,k).eq.0.0_WP) cycle + if (mask(i,j,k).eq.0.0_WP) cycle ! Check with side if (G(i,j,k).ge.0.0_WP) then n_plus = n_plus + 1 @@ -200,7 +202,7 @@ subroutine build(this,G,Gmax) do i=this%imin_close,this%imax_close ! Cycle if too far or BC !if (band(i,j,k).eq.0) cycle - if (this%cfg%VF(i,j,k).eq.0.0_WP) cycle + if (mask(i,j,k).eq.0.0_WP) cycle ! Check 6 direct neighbors do n=1,6 select case(n) @@ -219,7 +221,7 @@ subroutine build(this,G,Gmax) end select ! Don't add nodes that are outside the bands or BC !if (band(ii,jj,kk).eq.0) cycle - if (this%cfg%VF(ii,jj,kk).eq.0.0_WP) cycle + if (mask(ii,jj,kk).eq.0.0_WP) cycle ! Find interface crossing if ((G(i,j,k)*G(ii,jj,kk)).le.0.0_WP) then if (G(i,j,k).lt.0.0_WP) then @@ -266,9 +268,9 @@ subroutine build(this,G,Gmax) ! Set up the temp level set field variable setuptemp: block integer :: i,j,k - do k=this%cfg%kmino_,this%cfg%kmaxo_ - do j=this%cfg%jmino_,this%cfg%jmaxo_ - do i=this%cfg%imino_,this%cfg%imaxo_ + do k=this%pg%kmino_,this%pg%kmaxo_ + do j=this%pg%jmino_,this%pg%jmaxo_ + do i=this%pg%imino_,this%pg%imaxo_ phi_fmm(i,j,k) = Gmax end do end do @@ -340,16 +342,16 @@ subroutine build(this,G,Gmax) local_index = +3 end select ! Don't add nodes that are outside the BC - if (this%cfg%VF(ii,jj,kk).eq.0.0_WP) cycle + if (mask(ii,jj,kk).eq.0.0_WP) cycle ! Form local metrics if (G(i,j,k)*G(ii,jj,kk).le.0.0_WP) then if (G(i,j,k).eq.G(ii,jj,kk)) cycle n_nbrs = n_nbrs + 1 G_nbrs( n_nbrs) = 0.0_WP index_nbrs(n_nbrs) = local_index - dx_nbrs(1,n_nbrs) = abs(-G(i,j,k)*(this%cfg%xm(ii)-this%cfg%xm(i))/(G(ii,jj,kk)-G(i,j,k))) - dx_nbrs(2,n_nbrs) = abs(-G(i,j,k)*(this%cfg%ym(jj)-this%cfg%ym(j))/(G(ii,jj,kk)-G(i,j,k))) - dx_nbrs(3,n_nbrs) = abs(-G(i,j,k)*(this%cfg%zm(kk)-this%cfg%zm(k))/(G(ii,jj,kk)-G(i,j,k))) + dx_nbrs(1,n_nbrs) = abs(-G(i,j,k)*(this%pg%xm(ii)-this%pg%xm(i))/(G(ii,jj,kk)-G(i,j,k))) + dx_nbrs(2,n_nbrs) = abs(-G(i,j,k)*(this%pg%ym(jj)-this%pg%ym(j))/(G(ii,jj,kk)-G(i,j,k))) + dx_nbrs(3,n_nbrs) = abs(-G(i,j,k)*(this%pg%zm(kk)-this%pg%zm(k))/(G(ii,jj,kk)-G(i,j,k))) end if end do @@ -408,9 +410,9 @@ subroutine build(this,G,Gmax) ! Check if we have rolled back enough... if (this_phi.gt.phi_fmm(ii,jj,kk)) then - if (ii.ge.this%cfg%imin_.and.ii.le.this%cfg%imax_) then - if (jj.ge.this%cfg%jmin_.and.jj.le.this%cfg%jmax_) then - if (kk.ge.this%cfg%kmin_.and.kk.le.this%cfg%kmax_) then + if (ii.ge.this%pg%imin_.and.ii.le.this%pg%imax_) then + if (jj.ge.this%pg%jmin_.and.jj.le.this%pg%jmax_) then + if (kk.ge.this%pg%kmin_.and.kk.le.this%pg%kmax_) then exit end if end if @@ -522,7 +524,7 @@ subroutine build(this,G,Gmax) local_index = +3 end select ! Don't add nodes that are outside the BC - if (this%cfg%VF(ii,jj,kk).eq.0.0_WP) cycle + if (mask(ii,jj,kk).eq.0.0_WP) cycle ! Count the nodes to be used in extending the distance function if (phi_flag(ii,jj,kk).eq.fmm_close) then n_already_close = n_already_close + 1 @@ -538,9 +540,9 @@ subroutine build(this,G,Gmax) ! Work on the physical domain only and let other processors ! know a boundary node has been accepted - if ( i.ge.this%cfg%imin_ .and. i.le.this%cfg%imax_ .and. & - j.ge.this%cfg%jmin_ .and. j.le.this%cfg%jmax_ .and. & - k.ge.this%cfg%kmin_ .and. k.le.this%cfg%kmax_ ) then + if ( i.ge.this%pg%imin_ .and. i.le.this%pg%imax_ .and. & + j.ge.this%pg%jmin_ .and. j.le.this%pg%jmax_ .and. & + k.ge.this%pg%kmin_ .and. k.le.this%pg%kmax_ ) then call multiphase_fmm_send(i,j,k,phi_fmm(i,j,k),my_ibuf(2)) end if @@ -608,7 +610,7 @@ subroutine build(this,G,Gmax) local_index = +3 end select ! Don't add nodes that are outside the BC - if (this%cfg%VF(iii,jjj,kkk).eq.0.0_WP) cycle + if (mask(iii,jjj,kkk).eq.0.0_WP) cycle ! Check for nbrs and look for... if ((G(ii,jj,kk)*G(iii,jjj,kkk)).le.0.0_WP) then if (G(ii,jj,kk).eq.G(iii,jjj,kkk)) cycle @@ -616,17 +618,17 @@ subroutine build(this,G,Gmax) n_nbrs = n_nbrs + 1 phi_nbrs(n_nbrs) = 0.0_WP index_nbrs(n_nbrs) = local_index - dx_nbrs(1,n_nbrs) = abs(-G(ii,jj,kk)*(this%cfg%xm(iii)-this%cfg%xm(ii))/(G(iii,jjj,kkk)-G(ii,jj,kk))) - dx_nbrs(2,n_nbrs) = abs(-G(ii,jj,kk)*(this%cfg%ym(jjj)-this%cfg%ym(jj))/(G(iii,jjj,kkk)-G(ii,jj,kk))) - dx_nbrs(3,n_nbrs) = abs(-G(ii,jj,kk)*(this%cfg%zm(kkk)-this%cfg%zm(kk))/(G(iii,jjj,kkk)-G(ii,jj,kk))) + dx_nbrs(1,n_nbrs) = abs(-G(ii,jj,kk)*(this%pg%xm(iii)-this%pg%xm(ii))/(G(iii,jjj,kkk)-G(ii,jj,kk))) + dx_nbrs(2,n_nbrs) = abs(-G(ii,jj,kk)*(this%pg%ym(jjj)-this%pg%ym(jj))/(G(iii,jjj,kkk)-G(ii,jj,kk))) + dx_nbrs(3,n_nbrs) = abs(-G(ii,jj,kk)*(this%pg%zm(kkk)-this%pg%zm(kk))/(G(iii,jjj,kkk)-G(ii,jj,kk))) else if (phi_flag(iii,jjj,kkk).eq.fmm_accepted) then ! ... an accepted nbr n_nbrs = n_nbrs + 1 phi_nbrs(n_nbrs) = phi_fmm(iii,jjj,kkk) index_nbrs(n_nbrs) = local_index - dx_nbrs(1,n_nbrs) = abs(this%cfg%xm(iii)-this%cfg%xm(ii)) - dx_nbrs(2,n_nbrs) = abs(this%cfg%ym(jjj)-this%cfg%ym(jj)) - dx_nbrs(3,n_nbrs) = abs(this%cfg%zm(kkk)-this%cfg%zm(kk)) + dx_nbrs(1,n_nbrs) = abs(this%pg%xm(iii)-this%pg%xm(ii)) + dx_nbrs(2,n_nbrs) = abs(this%pg%ym(jjj)-this%pg%ym(jj)) + dx_nbrs(3,n_nbrs) = abs(this%pg%zm(kkk)-this%pg%zm(kk)) end if end do ! Recompute nodal values @@ -710,7 +712,7 @@ subroutine build(this,G,Gmax) local_index = +3 end select ! Don't add nodes that are outside the BC - if (this%cfg%VF(iii,jjj,kkk).eq.0.0_WP) cycle + if (mask(iii,jjj,kkk).eq.0.0_WP) cycle ! Check for nbrs and look for... if ((G(ii,jj,kk)*G(iii,jjj,kkk)).le.0.0_WP) then if (G(ii,jj,kk).eq.G(iii,jjj,kkk)) cycle @@ -718,17 +720,17 @@ subroutine build(this,G,Gmax) n_nbrs = n_nbrs + 1 index_nbrs(n_nbrs) = local_index phi_nbrs(n_nbrs) = 0.0_WP - dx_nbrs(1,n_nbrs) = abs(-G(ii,jj,kk)*(this%cfg%xm(iii)-this%cfg%xm(ii))/(G(iii,jjj,kkk)-G(ii,jj,kk))) - dx_nbrs(2,n_nbrs) = abs(-G(ii,jj,kk)*(this%cfg%ym(jjj)-this%cfg%ym(jj))/(G(iii,jjj,kkk)-G(ii,jj,kk))) - dx_nbrs(3,n_nbrs) = abs(-G(ii,jj,kk)*(this%cfg%zm(kkk)-this%cfg%zm(kk))/(G(iii,jjj,kkk)-G(ii,jj,kk))) + dx_nbrs(1,n_nbrs) = abs(-G(ii,jj,kk)*(this%pg%xm(iii)-this%pg%xm(ii))/(G(iii,jjj,kkk)-G(ii,jj,kk))) + dx_nbrs(2,n_nbrs) = abs(-G(ii,jj,kk)*(this%pg%ym(jjj)-this%pg%ym(jj))/(G(iii,jjj,kkk)-G(ii,jj,kk))) + dx_nbrs(3,n_nbrs) = abs(-G(ii,jj,kk)*(this%pg%zm(kkk)-this%pg%zm(kk))/(G(iii,jjj,kkk)-G(ii,jj,kk))) else if (phi_flag(iii,jjj,kkk).eq.fmm_accepted) then ! ... an accepted nbr n_nbrs = n_nbrs + 1 index_nbrs(n_nbrs) = local_index phi_nbrs(n_nbrs) = phi_fmm(iii,jjj,kkk) - dx_nbrs(1,n_nbrs) = abs(this%cfg%xm(iii)-this%cfg%xm(ii)) - dx_nbrs(2,n_nbrs) = abs(this%cfg%ym(jjj)-this%cfg%ym(jj)) - dx_nbrs(3,n_nbrs) = abs(this%cfg%zm(kkk)-this%cfg%zm(kk)) + dx_nbrs(1,n_nbrs) = abs(this%pg%xm(iii)-this%pg%xm(ii)) + dx_nbrs(2,n_nbrs) = abs(this%pg%ym(jjj)-this%pg%ym(jj)) + dx_nbrs(3,n_nbrs) = abs(this%pg%zm(kkk)-this%pg%zm(kk)) end if end do ! Recompute nodal value @@ -762,7 +764,7 @@ subroutine build(this,G,Gmax) use mpi_f08, only: MPI_ALLREDUCE, MPI_SUM, MPI_INTEGER integer :: ierr my_ibuf(3) = nheap - call MPI_ALLREDUCE(my_ibuf,ibuf,3,MPI_INTEGER,MPI_SUM,this%cfg%comm,ierr) + call MPI_ALLREDUCE(my_ibuf,ibuf,3,MPI_INTEGER,MPI_SUM,this%pg%comm,ierr) global_done = ((ibuf(1).eq.ibuf(2)).and.(ibuf(3).eq.0)) end block communcate_messages @@ -786,9 +788,9 @@ subroutine build(this,G,Gmax) ! Now update level set update_levelset: block integer:: i,j,k - do k=this%cfg%kmino_,this%cfg%kmaxo_ - do j=this%cfg%jmino_,this%cfg%jmaxo_ - do i=this%cfg%imino_,this%cfg%imaxo_ + do k=this%pg%kmino_,this%pg%kmaxo_ + do j=this%pg%jmino_,this%pg%jmaxo_ + do i=this%pg%imino_,this%pg%imaxo_ if (phi_flag(i,j,k).eq.fmm_accepted_plus) then G(i,j,k) = +phi_fmm(i,j,k) else if (phi_flag(i,j,k).eq.fmm_accepted_minus) then @@ -798,7 +800,7 @@ subroutine build(this,G,Gmax) end do end do ! Communicate level set - call this%cfg%sync(G) + call this%pg%sync(G) end block update_levelset ! ! Store ordered list @@ -1677,12 +1679,12 @@ function multiphase_fmm_recv(i,j,k,phi_value) result(imessage) logical :: imessage ! Probe for message - call MPI_Iprobe(MPI_ANY_SOURCE,MPI_ANY_TAG,this%cfg%comm,imessage,status,ierr) + call MPI_Iprobe(MPI_ANY_SOURCE,MPI_ANY_TAG,this%pg%comm,imessage,status,ierr) ! If message is present, receive it if (imessage) then isource=status%MPI_SOURCE - call MPI_Recv(val_recv,4,MPI_REAL_WP,isource,0,this%cfg%comm,status,ierr) + call MPI_Recv(val_recv,4,MPI_REAL_WP,isource,0,this%pg%comm,status,ierr) i=nint(val_recv(1)) j=nint(val_recv(2)) k=nint(val_recv(3)) @@ -1707,7 +1709,7 @@ subroutine multiphase_fmm_brecv(i,j,k,phi_value) integer :: ierr ! Blocking receive for extension - call MPI_Recv(recv_buf,4,MPI_REAL_WP,MPI_ANY_SOURCE,MPI_ANY_TAG,this%cfg%comm,status,ierr) + call MPI_Recv(recv_buf,4,MPI_REAL_WP,MPI_ANY_SOURCE,MPI_ANY_TAG,this%pg%comm,status,ierr) i=nint(recv_buf(1)) j=nint(recv_buf(2)) k=nint(recv_buf(3)) @@ -1731,37 +1733,37 @@ subroutine multiphase_fmm_send(i,j,k,value,counter) ! Communicate if necessary if (this%rank_x_lo.ge.0 .and. i.lt.this%i_passlo) then i0=i;j0=j;k0=k - if (this%cfg%xper .and.this%cfg%iproc.eq.1 ) i0=i+this%cfg%nx + if (this%pg%xper .and.this%pg%iproc.eq.1 ) i0=i+this%pg%nx call multiphase_fmm_parallel_send(this%rank_x_lo,i0,j0,k0,value) counter=counter+1 end if if (this%rank_x_hi.ge.0 .and. i.gt.this%i_passhi) then i0=i;j0=j;k0=k - if (this%cfg%xper .and. this%cfg%iproc.eq.this%cfg%npx) i0=i-this%cfg%nx + if (this%pg%xper .and. this%pg%iproc.eq.this%pg%npx) i0=i-this%pg%nx call multiphase_fmm_parallel_send(this%rank_x_hi,i0,j0,k0,value) counter=counter+1 end if if (this%rank_y_lo.ge.0 .and. j.lt.this%j_passlo) then i0=i;j0=j;k0=k - if (this%cfg%yper .and. this%cfg%jproc.eq.1 ) j0=j+this%cfg%ny + if (this%pg%yper .and. this%pg%jproc.eq.1 ) j0=j+this%pg%ny call multiphase_fmm_parallel_send(this%rank_y_lo,i0,j0,k0,value) counter=counter+1 end if if (this%rank_y_hi.ge.0 .and. j.gt.this%j_passhi) then i0=i;j0=j;k0=k - if (this%cfg%yper .and. this%cfg%jproc.eq.this%cfg%npy) j0=j-this%cfg%ny + if (this%pg%yper .and. this%pg%jproc.eq.this%pg%npy) j0=j-this%pg%ny call multiphase_fmm_parallel_send(this%rank_y_hi,i0,j0,k0,value) counter=counter+1 end if if (this%rank_z_lo.ge.0 .and. k.lt.this%k_passlo) then i0=i;j0=j;k0=k - if (this%cfg%zper .and. this%cfg%kproc.eq.1 ) k0=k+this%cfg%nz + if (this%pg%zper .and. this%pg%kproc.eq.1 ) k0=k+this%pg%nz call multiphase_fmm_parallel_send(this%rank_z_lo,i0,j0,k0,value) counter=counter+1 end if if (this%rank_z_hi.ge.0 .and. k.gt.this%k_passhi) then i0=i;j0=j;k0=k - if (this%cfg%zper .and. this%cfg%kproc.eq.this%cfg%npz) k0=k-this%cfg%nz + if (this%pg%zper .and. this%pg%kproc.eq.this%pg%npz) k0=k-this%pg%nz call multiphase_fmm_parallel_send(this%rank_z_hi,i0,j0,k0,value) counter=counter+1 end if @@ -1785,7 +1787,7 @@ subroutine multiphase_fmm_parallel_send(idest,i,j,k,phi_value) buffer(4) = phi_value ! Use a buffered send - call MPI_Bsend(buffer,4,MPI_REAL_WP,idest,0,this%cfg%comm,ierr) + call MPI_Bsend(buffer,4,MPI_REAL_WP,idest,0,this%pg%comm,ierr) return end subroutine multiphase_fmm_parallel_send From 1fb2b87c1b721b77b2686b658ab977b497eb3bb4 Mon Sep 17 00:00:00 2001 From: Mark Owkes Date: Thu, 29 May 2025 14:09:00 -0600 Subject: [PATCH 12/70] Added upwinded local Weber number calculation - need to figure out best way to output data. --- examples/ligament/src/ligament_class.f90 | 136 +++++++++++++++++++++-- 1 file changed, 125 insertions(+), 11 deletions(-) diff --git a/examples/ligament/src/ligament_class.f90 b/examples/ligament/src/ligament_class.f90 index cb1aa507a..68f8fdff6 100644 --- a/examples/ligament/src/ligament_class.f90 +++ b/examples/ligament/src/ligament_class.f90 @@ -59,6 +59,10 @@ module ligament_class type(iterator) :: vof_removal_layer !< Edge of domain where we actively remove VOF real(WP) :: vof_removed !< Integral of VOF removed integer :: nlayer=4 !< Size of buffer layer for VOF removal + + !> Weber number calculation parameters + real(WP) :: dth = 0.1_WP !< Distance threshold for Weber number calculation + real(WP), dimension(:), allocatable :: weber !< Weber number for each structure !> Timing info type(monitor) :: timefile !< Timing monitoring @@ -665,6 +669,8 @@ subroutine step(this) real(WP), dimension(:,:) , allocatable :: dvel real(WP), dimension(:,:,:), allocatable :: dmoi real(WP), dimension(:) , allocatable :: drem + real(WP), dimension(:) , allocatable :: dugas,dvgas,dwgas + real(WP), dimension(:) , allocatable :: weights integer :: n,m,ierr,i,j,k,nmax real(WP) :: x,y,z,x0,y0,z0,diam,ecc,lmax,lmid,lmin logical :: transfer @@ -691,7 +697,14 @@ subroutine step(this) allocate(dvel(1:this%ccl%nstruct,1:3 )); dvel=0.0_WP allocate(dmoi(1:this%ccl%nstruct,1:3,1:3)); dmoi=0.0_WP allocate(drem(1:this%ccl%nstruct )); drem=0.0_WP - + allocate(dugas(1:this%ccl%nstruct )); dugas=0.0_WP + allocate(dvgas(1:this%ccl%nstruct )); dvgas=0.0_WP + allocate(dwgas(1:this%ccl%nstruct )); dwgas=0.0_WP + allocate(weights(1:this%ccl%nstruct )); weights=0.0_WP + + if (allocated(this%weber)) deallocate(this%weber) + allocate(this%weber(1:this%ccl%nstruct)) + ! First pass to accumulate volume, position, and velocity do n=1,this%ccl%nstruct ! Loop over cells in structure @@ -798,17 +811,118 @@ subroutine step(this) call this%fmm%build(this%G,Gmax,this%cfg%VF) end block fmm_build - ! Compute dominant gas velocity direction - do n=1,this%ccl%nstruct - ! Loop over cells in structure - do m=1,this%ccl%struct(n)%n_ - ! Get cell indices - i=this%ccl%struct(n)%map(1,m) - j=this%ccl%struct(n)%map(2,m) - k=this%ccl%struct(n)%map(3,m) - + ! Compute average gas velocity around each structure + avg_gas_velocity: block + integer :: n,m,i,j,k,ii,jj,kk + logical, dimension(:,:,:), allocatable :: cell_tag + allocate(cell_tag(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + do n=1,this%ccl%nstruct + cell_tag(:,:,:) = .false. + ! Loop over cells in structure + do m=1,this%ccl%struct(n)%n_ + ! Get cell indices + i=this%ccl%struct(n)%map(1,m) + j=this%ccl%struct(n)%map(2,m) + k=this%ccl%struct(n)%map(3,m) + ! Looping over surrounding cells + do ii = i-2,i+2 + do jj = j-2,j+2 + do kk = k-2,k+2 + ! Ensure not double counting cells + if (cell_tag(ii,jj,kk)) cycle + ! Sum velocity*Gas_vol and Gas_vol + if ((this%vf%VF(ii,jj,kk)).le.0.5_WP) then + dugas(n) = dugas(n) + sum(this%fs%itpu_x(:,i,j,k)*this%fs%U(i:i+1,j,k))*this%cfg%vol(ii,jj,kk)*(1.0_WP-this%vf%VF(ii,jj,kk)) + dvgas(n) = dvgas(n) + sum(this%fs%itpv_y(:,i,j,k)*this%fs%V(i,j:j+1,k))*this%cfg%vol(ii,jj,kk)*(1.0_WP-this%vf%VF(ii,jj,kk)) + dwgas(n) = dwgas(n) + sum(this%fs%itpw_z(:,i,j,k)*this%fs%W(i,j,k:k+1))*this%cfg%vol(ii,jj,kk)*(1.0_WP-this%vf%VF(ii,jj,kk)) + weights(n) = weights(n) + this%cfg%vol(ii,jj,kk)*(1.0_WP-this%vf%VF(ii,jj,kk)) + end if + cell_tag(ii,jj,kk) = .true. + end do + end do + end do + end do end do - end do + call MPI_ALLREDUCE(MPI_IN_PLACE,dugas, this%ccl%nstruct,MPI_REAL_WP,MPI_SUM,this%vf%cfg%comm,ierr) + call MPI_ALLREDUCE(MPI_IN_PLACE,dvgas, this%ccl%nstruct,MPI_REAL_WP,MPI_SUM,this%vf%cfg%comm,ierr) + call MPI_ALLREDUCE(MPI_IN_PLACE,dwgas, this%ccl%nstruct,MPI_REAL_WP,MPI_SUM,this%vf%cfg%comm,ierr) + call MPI_ALLREDUCE(MPI_IN_PLACE,weights,this%ccl%nstruct,MPI_REAL_WP,MPI_SUM,this%vf%cfg%comm,ierr) + ! Normalize by volume + dugas(:) = dugas(:) / weights(:) + dvgas(:) = dvgas(:) / weights(:) + dwgas(:) = dwgas(:) / weights(:) + end block avg_gas_velocity + + ! Compute velocity from upstream sampling location + upstream_velocity: block + real(WP) :: Vmag,Deq,dist + real(WP) :: xdir,ydir,zdir + real(WP) :: xp,yp,zp + real(WP) :: W_location,W_structure + do n=1,this%ccl%nstruct + ! Compute velocity magnitude + Vmag = sqrt((dugas(n))**2.0_WP + (dvgas(n))**2.0_WP + (dwgas(n))**2.0_WP) + + ! Direction is unit vector in negative average velocity direction + xdir = dugas(n) / Vmag + ydir = dvgas(n) / Vmag + zdir = dwgas(n) / Vmag + + ! Calculating equivalent diameter of structure + Deq = ((dvol(n) * 6.0_WP)/Pi)**(1.0_WP/3.0_WP) + + ! Calculating sampling location based on centroid of structure and direction + xp = dpos(n,1) - (Deq * xdir) + yp = dpos(n,2) - (Deq * ydir) + zp = dpos(n,3) - (Deq * zdir) + + ! Reset averages and weight for this structure + dugas(n) = 0.0_WP + dvgas(n) = 0.0_WP + dwgas(n) = 0.0_WP + weights(n) = 0.0_WP + + ! Compute gas velocity at sampling location with + ! Gaussian weighting and distance from structure weighting + do i = this%vf%cfg%imin_,this%vf%cfg%imax_ + do j = this%vf%cfg%jmin_,this%vf%cfg%jmax_ + do k = this%vf%cfg%kmin_,this%vf%cfg%kmax_ + ! Ignore cells with mostly liquid + if (this%vf%VF(i,j,k).gt.0.5_WP) cycle + + !Calculate weights for this cell + dist = sqrt((xp-this%cfg%xm(i))**2 + (yp-this%cfg%ym(j))**2 + (zp-this%cfg%zm(k))**2) + W_location = exp(-(dist**2/(0.5_WP*Deq**2))) ! Gaussian weight from sampling location + W_structure = min(1.0_WP,abs(this%G(i,j,k))/this%dth) ! Weight based on distance to structures + ! Compute average velocity + dugas(n) = dugas(n) + sum(this%fs%itpu_x(:,i,j,k)*this%fs%U(i:i+1,j,k)) * W_location * W_structure + dvgas(n) = dvgas(n) + sum(this%fs%itpv_y(:,i,j,k)*this%fs%V(i,j:j+1,k)) * W_location * W_structure + dwgas(n) = dwgas(n) + sum(this%fs%itpw_z(:,i,j,k)*this%fs%W(i,j,k:k+1)) * W_location * W_structure + weights(n) = weights(n) + W_location * W_structure + end do + end do + end do + end do + call MPI_ALLREDUCE(MPI_IN_PLACE,dugas, this%ccl%nstruct,MPI_REAL_WP,MPI_SUM,this%vf%cfg%comm,ierr) + call MPI_ALLREDUCE(MPI_IN_PLACE,dvgas, this%ccl%nstruct,MPI_REAL_WP,MPI_SUM,this%vf%cfg%comm,ierr) + call MPI_ALLREDUCE(MPI_IN_PLACE,dwgas, this%ccl%nstruct,MPI_REAL_WP,MPI_SUM,this%vf%cfg%comm,ierr) + call MPI_ALLREDUCE(MPI_IN_PLACE,weights,this%ccl%nstruct,MPI_REAL_WP,MPI_SUM,this%vf%cfg%comm,ierr) + ! Calculate weighted velocities + dugas(:) = dugas(:)/weights(:) + dvgas(:) = dvgas(:)/weights(:) + dwgas(:) = dwgas(:)/weights(:) + end block upstream_velocity + + compute_weber: block + real(WP) :: slip_vel, Deq + do n=1,this%ccl%nstruct + slip_vel = sqrt((dugas(n)-dvel(n,1))**2.0_WP + (dvgas(n)-dvel(n,2))**2.0_WP + (dwgas(n)-dvel(n,3))**2.0_WP) + Deq = ((dvol(n) * 6.0_WP)/Pi)**(1.0_WP/3.0_WP) + this%weber(n) = this%fs%rho_g * slip_vel**2 * Deq / this%fs%sigma + + print *, 'Weber number for structure ',n,' = ',this%weber(n) + end do + end block compute_weber end block weber_number From 2ddd51c2b1d235164f1756d52e9eeb0aad92824a Mon Sep 17 00:00:00 2001 From: Mark Owkes Date: Thu, 29 May 2025 14:11:02 -0600 Subject: [PATCH 13/70] Adding avl_tree (binary tree) tester --- examples/avl_tree_tester/GNUmakefile | 45 +++++ examples/avl_tree_tester/README.md | 1 + examples/avl_tree_tester/input | 28 +++ examples/avl_tree_tester/src/Make.package | 2 + examples/avl_tree_tester/src/geometry.f90 | 16 ++ examples/avl_tree_tester/src/simulation.f90 | 187 ++++++++++++++++++++ 6 files changed, 279 insertions(+) create mode 100644 examples/avl_tree_tester/GNUmakefile create mode 100644 examples/avl_tree_tester/README.md create mode 100644 examples/avl_tree_tester/input create mode 100644 examples/avl_tree_tester/src/Make.package create mode 100644 examples/avl_tree_tester/src/geometry.f90 create mode 100644 examples/avl_tree_tester/src/simulation.f90 diff --git a/examples/avl_tree_tester/GNUmakefile b/examples/avl_tree_tester/GNUmakefile new file mode 100644 index 000000000..e84c29d84 --- /dev/null +++ b/examples/avl_tree_tester/GNUmakefile @@ -0,0 +1,45 @@ +# NGA location if not yet defined +NGA_HOME ?= ../.. + +# Compilation parameters +PRECISION = DOUBLE +USE_MPI = TRUE +USE_HYPRE = TRUE +USE_IRL = TRUE +USE_FFTW = TRUE +USE_LAPACK= TRUE +PROFILE = FALSE +DEBUG = TRUE +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) + +# NGA compilation definitions +include $(NGA_HOME)/tools/GNUMake/Make.defs + +# Include NGA base code +Bdirs := core libraries two_phase data transform solver config grid +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/avl_tree_tester/README.md b/examples/avl_tree_tester/README.md new file mode 100644 index 000000000..e4dfc9c6f --- /dev/null +++ b/examples/avl_tree_tester/README.md @@ -0,0 +1 @@ +# Tester for AVL binary tree \ No newline at end of file diff --git a/examples/avl_tree_tester/input b/examples/avl_tree_tester/input new file mode 100644 index 000000000..a33e82ab6 --- /dev/null +++ b/examples/avl_tree_tester/input @@ -0,0 +1,28 @@ +# Parallelization +Partition : 1 1 1 + +# Mesh definition +Lx : 5 +nx : 32 + +# Droplet properties +Number of droplet : 10 +Droplet diameter : 1.3 # for growth test +Droplet diameter : 1.5 +Liquid dynamic viscosity : 1.0 +Gas dynamic viscosity : 1.0 +Liquid density : 1.0 +Gas density : 1.0 +Surface tension coefficient : 1.0 + +# Time integration +Max timestep size : 2.5e-3 +Max cfl number : #0.9 +Max time : 30.0e-3 + +# Ensight output +Ensight output period : 2.5e-3 +Restart output period : 10e-3 + +# Drop analysis +Drop analysis period : 5e-2 diff --git a/examples/avl_tree_tester/src/Make.package b/examples/avl_tree_tester/src/Make.package new file mode 100644 index 000000000..a7a927853 --- /dev/null +++ b/examples/avl_tree_tester/src/Make.package @@ -0,0 +1,2 @@ +# List here the extra files here +f90EXE_sources += geometry.f90 simulation.f90 diff --git a/examples/avl_tree_tester/src/geometry.f90 b/examples/avl_tree_tester/src/geometry.f90 new file mode 100644 index 000000000..9e26843c1 --- /dev/null +++ b/examples/avl_tree_tester/src/geometry.f90 @@ -0,0 +1,16 @@ +!> Various definitions and tools for initializing NGA2 config +module geometry + implicit none + private + + public :: geometry_init + +contains + + + !> Initialization of problem geometry + subroutine geometry_init + end subroutine geometry_init + + +end module geometry diff --git a/examples/avl_tree_tester/src/simulation.f90 b/examples/avl_tree_tester/src/simulation.f90 new file mode 100644 index 000000000..a640c89c5 --- /dev/null +++ b/examples/avl_tree_tester/src/simulation.f90 @@ -0,0 +1,187 @@ +!> Various definitions and tools for running an NGA2 simulation +module simulation + use avl_trees, only: avl_tree_t,avl_insert,avl_retrieve,int_cast,real_cast,avl_delete_all + implicit none + private + + ! AVL Binary Tree + type(avl_tree_t) :: tree + + public :: simulation_init,simulation_run,simulation_final + +contains + + !> Initialization the NGA2 simulation + subroutine simulation_init + use, intrinsic :: iso_fortran_env, only: output_unit + use, non_intrinsic :: avl_trees + + implicit none + + integer, parameter :: keys_count = 20 + + type(avl_tree_t) :: tree + logical :: found + class(*), allocatable :: retval + integer :: the_keys(1:keys_count) + integer :: i, j + + do i = 1, keys_count + the_keys(i) = i + end do + call fisher_yates_shuffle (the_keys, keys_count) + + call avl_check (tree) + do i = 1, keys_count + call avl_insert (lt, the_keys(i), real (the_keys(i)+10), tree) + call avl_check (tree) + if (avl_size (tree) /= i) error stop + do j = 1, keys_count + if (avl_contains (lt, the_keys(j), tree) .neqv. (j <= i)) error stop + end do + do j = 1, keys_count + call avl_retrieve (lt, the_keys(j), tree, found, retval) + if (found .neqv. (j <= i)) error stop + if (found) then + ! This crazy way to write ‘/=’ is to quell those tiresome + ! warnings about using ‘==’ or ‘/=’ with floating point + ! numbers. Floating point numbers can represent integers + ! *exactly*. + !if (0 < abs (real_cast (retval) - real (the_keys(j)))) error stop + print*,real_cast(retval),the_keys(j) + end if + ! if (found) then + ! block + ! character(len = 1), parameter :: ch = '*' + ! ! + ! ! Try replacing the data with a character and then + ! ! restoring the number. + ! ! + ! call avl_insert (lt, the_keys(j), ch, tree) + ! call avl_retrieve (lt, the_keys(j), tree, found, retval) + ! if (.not. found) error stop + ! if (char_cast (retval) /= ch) error stop + ! call avl_insert (lt, the_keys(j), real (the_keys(j)+10), tree) + ! call avl_retrieve (lt, the_keys(j), tree, found, retval) + ! if (.not. found) error stop + ! !if (0 < abs (real_cast (retval) - real (the_keys(j)+10))) error stop + ! end block + ! end if + end do + end do + + write (output_unit, '(70("-"))') + call avl_write (int_real_writer, output_unit, tree) + write (output_unit, '(70("-"))') + call print_contents (output_unit, tree) + write (output_unit, '(70("-"))') + + call fisher_yates_shuffle (the_keys, keys_count) + do i = 1, keys_count + call avl_delete (lt, the_keys(i), tree) + call avl_check (tree) + if (avl_size (tree) /= keys_count - i) error stop + ! Try deleting a second time. + call avl_delete (lt, the_keys(i), tree) + call avl_check (tree) + if (avl_size (tree) /= keys_count - i) error stop + do j = 1, keys_count + if (avl_contains (lt, the_keys(j), tree) .neqv. (i < j)) error stop + end do + do j = 1, keys_count + call avl_retrieve (lt, the_keys(j), tree, found, retval) + if (found .neqv. (i < j)) error stop + if (found) then + !if (0 < abs (real_cast (retval) - real (the_keys(j)))) error stop + end if + end do + end do + + ! Remove all nodes + call avl_delete_all(tree) + + ! Remake the tree + do i = 1, keys_count + call avl_insert (lt, the_keys(i), real (the_keys(i)+100), tree) + end do + + write (output_unit, '(70("-"))') + call print_contents (output_unit, tree) + + contains + + subroutine fisher_yates_shuffle (keys, n) + integer, intent(inout) :: keys(*) + integer, intent(in) :: n + + integer :: i, j + real :: randnum + integer :: tmp + + do i = 1, n - 1 + call random_number (randnum) + j = i + floor (randnum * (n - i + 1)) + tmp = keys(i) + keys(i) = keys(j) + keys(j) = tmp + end do + end subroutine fisher_yates_shuffle + + function lt (u, v) result (u_lt_v) + class(*), intent(in) :: u, v + logical :: u_lt_v + + select type (u) + type is (integer) + select type (v) + type is (integer) + u_lt_v = (u < v) + class default + ! This case is not handled. + error stop + end select + class default + ! This case is not handled. + error stop + end select + end function lt + + subroutine int_real_writer (unit, key, data) + integer, intent(in) :: unit + class(*), intent(in) :: key, data + + write (unit, '("(", I0, ", ", F0.1, ")")', advance = 'no') & + & int_cast(key), real_cast(data) + end subroutine int_real_writer + + subroutine print_contents (unit, tree) + integer, intent(in) :: unit + class(avl_tree_t), intent(in) :: tree + + type(avl_pointer_pair_t), pointer :: ppairs, pp + + write (unit, '("tree size = ", I0)') avl_size (tree) + ppairs => avl_pointer_pairs (tree) + pp => ppairs + do while (associated (pp)) + write (unit, '("(", I0, ", ", F0.1, ")")') & + & int_cast (pp%p_key), real_cast (pp%p_data) + pp => pp%next + end do + if (associated (ppairs)) deallocate (ppairs) + end subroutine print_contents + + end subroutine simulation_init + + + !> Run the NGA2 simulation + subroutine simulation_run + implicit none + end subroutine simulation_run + + !> Finalize the NGA2 simulation + subroutine simulation_final + implicit none + end subroutine simulation_final + +end module simulation From 49965e884b0a355e0987a250c6985321f8a2fbc7 Mon Sep 17 00:00:00 2001 From: Mark Owkes Date: Fri, 30 May 2025 15:12:56 -0600 Subject: [PATCH 14/70] Added code to write output to file --- examples/ligament/src/ligament_class.f90 | 104 ++++++++++++++--------- src/libraries/monitor_class.f90 | 22 ++++- 2 files changed, 81 insertions(+), 45 deletions(-) diff --git a/examples/ligament/src/ligament_class.f90 b/examples/ligament/src/ligament_class.f90 index 68f8fdff6..9bf32664c 100644 --- a/examples/ligament/src/ligament_class.f90 +++ b/examples/ligament/src/ligament_class.f90 @@ -63,6 +63,7 @@ module ligament_class !> Weber number calculation parameters real(WP) :: dth = 0.1_WP !< Distance threshold for Weber number calculation real(WP), dimension(:), allocatable :: weber !< Weber number for each structure + type(monitor) :: weberfile !< Weber number monitor file !> Timing info type(monitor) :: timefile !< Timing monitoring @@ -669,7 +670,7 @@ subroutine step(this) real(WP), dimension(:,:) , allocatable :: dvel real(WP), dimension(:,:,:), allocatable :: dmoi real(WP), dimension(:) , allocatable :: drem - real(WP), dimension(:) , allocatable :: dugas,dvgas,dwgas + real(WP), dimension(:,:) , allocatable :: dgvel real(WP), dimension(:) , allocatable :: weights integer :: n,m,ierr,i,j,k,nmax real(WP) :: x,y,z,x0,y0,z0,diam,ecc,lmax,lmid,lmin @@ -697,9 +698,7 @@ subroutine step(this) allocate(dvel(1:this%ccl%nstruct,1:3 )); dvel=0.0_WP allocate(dmoi(1:this%ccl%nstruct,1:3,1:3)); dmoi=0.0_WP allocate(drem(1:this%ccl%nstruct )); drem=0.0_WP - allocate(dugas(1:this%ccl%nstruct )); dugas=0.0_WP - allocate(dvgas(1:this%ccl%nstruct )); dvgas=0.0_WP - allocate(dwgas(1:this%ccl%nstruct )); dwgas=0.0_WP + allocate(dgvel(1:this%ccl%nstruct,1:3 )); dgvel=0.0_WP allocate(weights(1:this%ccl%nstruct )); weights=0.0_WP if (allocated(this%weber)) deallocate(this%weber) @@ -813,7 +812,7 @@ subroutine step(this) ! Compute average gas velocity around each structure avg_gas_velocity: block - integer :: n,m,i,j,k,ii,jj,kk + integer :: n,m,i,j,k,ii,jj,kk,d logical, dimension(:,:,:), allocatable :: cell_tag allocate(cell_tag(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) do n=1,this%ccl%nstruct @@ -832,10 +831,10 @@ subroutine step(this) if (cell_tag(ii,jj,kk)) cycle ! Sum velocity*Gas_vol and Gas_vol if ((this%vf%VF(ii,jj,kk)).le.0.5_WP) then - dugas(n) = dugas(n) + sum(this%fs%itpu_x(:,i,j,k)*this%fs%U(i:i+1,j,k))*this%cfg%vol(ii,jj,kk)*(1.0_WP-this%vf%VF(ii,jj,kk)) - dvgas(n) = dvgas(n) + sum(this%fs%itpv_y(:,i,j,k)*this%fs%V(i,j:j+1,k))*this%cfg%vol(ii,jj,kk)*(1.0_WP-this%vf%VF(ii,jj,kk)) - dwgas(n) = dwgas(n) + sum(this%fs%itpw_z(:,i,j,k)*this%fs%W(i,j,k:k+1))*this%cfg%vol(ii,jj,kk)*(1.0_WP-this%vf%VF(ii,jj,kk)) - weights(n) = weights(n) + this%cfg%vol(ii,jj,kk)*(1.0_WP-this%vf%VF(ii,jj,kk)) + dgvel(n,1) = dgvel(n,1) + sum(this%fs%itpu_x(:,i,j,k)*this%fs%U(i:i+1,j,k))*this%cfg%vol(ii,jj,kk)*(1.0_WP-this%vf%VF(ii,jj,kk)) + dgvel(n,2) = dgvel(n,2) + sum(this%fs%itpv_y(:,i,j,k)*this%fs%V(i,j:j+1,k))*this%cfg%vol(ii,jj,kk)*(1.0_WP-this%vf%VF(ii,jj,kk)) + dgvel(n,3) = dgvel(n,3) + sum(this%fs%itpw_z(:,i,j,k)*this%fs%W(i,j,k:k+1))*this%cfg%vol(ii,jj,kk)*(1.0_WP-this%vf%VF(ii,jj,kk)) + weights(n) = weights(n) + this%cfg%vol(ii,jj,kk)*(1.0_WP-this%vf%VF(ii,jj,kk)) end if cell_tag(ii,jj,kk) = .true. end do @@ -843,43 +842,35 @@ subroutine step(this) end do end do end do - call MPI_ALLREDUCE(MPI_IN_PLACE,dugas, this%ccl%nstruct,MPI_REAL_WP,MPI_SUM,this%vf%cfg%comm,ierr) - call MPI_ALLREDUCE(MPI_IN_PLACE,dvgas, this%ccl%nstruct,MPI_REAL_WP,MPI_SUM,this%vf%cfg%comm,ierr) - call MPI_ALLREDUCE(MPI_IN_PLACE,dwgas, this%ccl%nstruct,MPI_REAL_WP,MPI_SUM,this%vf%cfg%comm,ierr) + call MPI_ALLREDUCE(MPI_IN_PLACE,dgvel,3*this%ccl%nstruct,MPI_REAL_WP,MPI_SUM,this%vf%cfg%comm,ierr) call MPI_ALLREDUCE(MPI_IN_PLACE,weights,this%ccl%nstruct,MPI_REAL_WP,MPI_SUM,this%vf%cfg%comm,ierr) ! Normalize by volume - dugas(:) = dugas(:) / weights(:) - dvgas(:) = dvgas(:) / weights(:) - dwgas(:) = dwgas(:) / weights(:) + do d=1,3 + dgvel(:,d) = dgvel(:,d) / weights(:) + end do end block avg_gas_velocity ! Compute velocity from upstream sampling location upstream_velocity: block + integer :: d real(WP) :: Vmag,Deq,dist - real(WP) :: xdir,ydir,zdir - real(WP) :: xp,yp,zp + real(WP), dimension(3) :: dir,sloc real(WP) :: W_location,W_structure do n=1,this%ccl%nstruct ! Compute velocity magnitude - Vmag = sqrt((dugas(n))**2.0_WP + (dvgas(n))**2.0_WP + (dwgas(n))**2.0_WP) + Vmag = sqrt((dgvel(n,1))**2.0_WP + (dgvel(n,2))**2.0_WP + (dgvel(n,3))**2.0_WP) ! Direction is unit vector in negative average velocity direction - xdir = dugas(n) / Vmag - ydir = dvgas(n) / Vmag - zdir = dwgas(n) / Vmag - + dir(:) = dgvel(n,:) / Vmag + ! Calculating equivalent diameter of structure Deq = ((dvol(n) * 6.0_WP)/Pi)**(1.0_WP/3.0_WP) ! Calculating sampling location based on centroid of structure and direction - xp = dpos(n,1) - (Deq * xdir) - yp = dpos(n,2) - (Deq * ydir) - zp = dpos(n,3) - (Deq * zdir) + sloc(:) = dpos(n,:) - Deq * dir(:) ! Reset averages and weight for this structure - dugas(n) = 0.0_WP - dvgas(n) = 0.0_WP - dwgas(n) = 0.0_WP + dgvel(n,:) = 0.0_WP weights(n) = 0.0_WP ! Compute gas velocity at sampling location with @@ -891,38 +882,69 @@ subroutine step(this) if (this%vf%VF(i,j,k).gt.0.5_WP) cycle !Calculate weights for this cell - dist = sqrt((xp-this%cfg%xm(i))**2 + (yp-this%cfg%ym(j))**2 + (zp-this%cfg%zm(k))**2) + dist = sqrt((sloc(1)-this%cfg%xm(i))**2 + (sloc(2)-this%cfg%ym(j))**2 + (sloc(3)-this%cfg%zm(k))**2) W_location = exp(-(dist**2/(0.5_WP*Deq**2))) ! Gaussian weight from sampling location W_structure = min(1.0_WP,abs(this%G(i,j,k))/this%dth) ! Weight based on distance to structures ! Compute average velocity - dugas(n) = dugas(n) + sum(this%fs%itpu_x(:,i,j,k)*this%fs%U(i:i+1,j,k)) * W_location * W_structure - dvgas(n) = dvgas(n) + sum(this%fs%itpv_y(:,i,j,k)*this%fs%V(i,j:j+1,k)) * W_location * W_structure - dwgas(n) = dwgas(n) + sum(this%fs%itpw_z(:,i,j,k)*this%fs%W(i,j,k:k+1)) * W_location * W_structure + dgvel(n,1) = dgvel(n,1) + sum(this%fs%itpu_x(:,i,j,k)*this%fs%U(i:i+1,j,k)) * W_location * W_structure + dgvel(n,2) = dgvel(n,2) + sum(this%fs%itpv_y(:,i,j,k)*this%fs%V(i,j:j+1,k)) * W_location * W_structure + dgvel(n,3) = dgvel(n,3) + sum(this%fs%itpw_z(:,i,j,k)*this%fs%W(i,j,k:k+1)) * W_location * W_structure weights(n) = weights(n) + W_location * W_structure end do end do end do end do - call MPI_ALLREDUCE(MPI_IN_PLACE,dugas, this%ccl%nstruct,MPI_REAL_WP,MPI_SUM,this%vf%cfg%comm,ierr) - call MPI_ALLREDUCE(MPI_IN_PLACE,dvgas, this%ccl%nstruct,MPI_REAL_WP,MPI_SUM,this%vf%cfg%comm,ierr) - call MPI_ALLREDUCE(MPI_IN_PLACE,dwgas, this%ccl%nstruct,MPI_REAL_WP,MPI_SUM,this%vf%cfg%comm,ierr) + call MPI_ALLREDUCE(MPI_IN_PLACE,dgvel,3*this%ccl%nstruct,MPI_REAL_WP,MPI_SUM,this%vf%cfg%comm,ierr) call MPI_ALLREDUCE(MPI_IN_PLACE,weights,this%ccl%nstruct,MPI_REAL_WP,MPI_SUM,this%vf%cfg%comm,ierr) ! Calculate weighted velocities - dugas(:) = dugas(:)/weights(:) - dvgas(:) = dvgas(:)/weights(:) - dwgas(:) = dwgas(:)/weights(:) + do d=1,3 + dgvel(:,d) = dgvel(:,d) / weights(:) + end do end block upstream_velocity compute_weber: block real(WP) :: slip_vel, Deq do n=1,this%ccl%nstruct - slip_vel = sqrt((dugas(n)-dvel(n,1))**2.0_WP + (dvgas(n)-dvel(n,2))**2.0_WP + (dwgas(n)-dvel(n,3))**2.0_WP) + slip_vel = sqrt((dgvel(n,1)-dvel(n,1))**2.0_WP + (dgvel(n,2)-dvel(n,2))**2.0_WP + (dgvel(n,3)-dvel(n,3))**2.0_WP) Deq = ((dvol(n) * 6.0_WP)/Pi)**(1.0_WP/3.0_WP) this%weber(n) = this%fs%rho_g * slip_vel**2 * Deq / this%fs%sigma - - print *, 'Weber number for structure ',n,' = ',this%weber(n) end do end block compute_weber + + write_stats: block + use monitor_class, only: iformat,rformat + use string, only: str_medium + character(len=str_medium) :: filename,struct_name + ! Create a file to write Weber numbers + write(filename, rformat) this%time%t + filename = 'structStats_'//trim(adjustl(filename)) + this%weberfile=monitor(this%fs%cfg%amRoot,filename) + ! Add columns to the file + do n=1,this%ccl%nstruct + call this%weberfile%add_column(n,'Structure ID') + call this%weberfile%add_column(this%weber(n),'Weber Number') + call this%weberfile%add_column(dvol(n),'Drop Volume') + call this%weberfile%add_column(dpos(n,1),'X Drop Pos') + call this%weberfile%add_column(dpos(n,2),'Y Drop Pos') + call this%weberfile%add_column(dpos(n,3),'Z Drop Pos') + call this%weberfile%add_column(dvel(n,1),'X Drop Vel') + call this%weberfile%add_column(dvel(n,2),'Y Drop Vel') + call this%weberfile%add_column(dvel(n,3),'Z Drop Vel') + call this%weberfile%add_column(dgvel(n,1),'X Gas Vel') + call this%weberfile%add_column(dgvel(n,2),'Y Gas Vel') + call this%weberfile%add_column(dgvel(n,3),'Z Gas Vel') + call this%weberfile%add_column(dmoi(n,1,1),'Ixx') + call this%weberfile%add_column(dmoi(n,2,2),'Iyy') + call this%weberfile%add_column(dmoi(n,3,3),'Izz') + call this%weberfile%add_column(dmoi(n,1,2),'Ixy') + call this%weberfile%add_column(dmoi(n,1,3),'Ixz') + call this%weberfile%add_column(dmoi(n,2,3),'Iyz') + ! Write the data for this structure + call this%weberfile%write() + end do + ! Close file + call this%weberfile%close() + end block write_stats end block weber_number diff --git a/src/libraries/monitor_class.f90 b/src/libraries/monitor_class.f90 index 2c656616c..1fa86755b 100644 --- a/src/libraries/monitor_class.f90 +++ b/src/libraries/monitor_class.f90 @@ -13,9 +13,9 @@ module monitor_class !> Preset some length and formats for the columns integer, parameter :: col_len=14 - character(len=*), parameter :: aformat='(a12)' - character(len=*), parameter :: iformat='(i12)' - character(len=*), parameter :: rformat='(es12.5)' + character(len=*), public, parameter :: aformat='(a12)' + character(len=*), public, parameter :: iformat='(i12)' + character(len=*), public, parameter :: rformat='(es12.5)' !> Type for column list @@ -43,6 +43,7 @@ module monitor_class generic :: add_column=>add_column_real,add_column_integer !< Add a column to the monitor file procedure, private :: add_column_real,add_column_integer procedure :: write !< Writes the content of the monitor object to a file + procedure :: close !< Closes the monitor file !procedure :: write_header !< Writes the header of the monitor object to a file end type monitor @@ -74,7 +75,20 @@ function constructor(amRoot,name) result(self) ! We haven't yet dumped the file self%isfirst=.true. end function constructor - + + !> Close monitor file + subroutine close(this) + implicit none + class(monitor), intent(inout) :: this + ! Only root works here + if (.not.this%amRoot) return + ! Close the file + close(this%iunit) + ! Reset the first column pointer + this%first_col=>NULL() + ! Reset the number of columns + this%ncol=0 + end subroutine close !> Write out monitor file subroutine write(this) From 7a2a185145453aa745b61222feabf199d7b824c9 Mon Sep 17 00:00:00 2001 From: Mark Owkes Date: Tue, 17 Jun 2025 13:50:49 -0600 Subject: [PATCH 15/70] Added history to .gitignore (Local History Extension) --- .gitignore | 1 + 1 file changed, 1 insertion(+) diff --git a/.gitignore b/.gitignore index e163b0be8..c73decc98 100644 --- a/.gitignore +++ b/.gitignore @@ -18,6 +18,7 @@ # Mac stuff .DS_Store *.dSYM/ +.history/ # Python temporaries _* From 492b2f5bac39831d54fbdbf39e473a40b1a46ef1 Mon Sep 17 00:00:00 2001 From: Mark Owkes Date: Wed, 18 Jun 2025 11:13:49 -0600 Subject: [PATCH 16/70] Working on debugging case --- examples/ljcf/GNUmakefile | 2 +- examples/ljcf/src/ljcf_class.f90 | 42 +++++++++++++++++++++++++++++--- examples/ljcf/src/simulation.f90 | 6 ++--- 3 files changed, 42 insertions(+), 8 deletions(-) diff --git a/examples/ljcf/GNUmakefile b/examples/ljcf/GNUmakefile index f51ff99ec..9e6b93d70 100644 --- a/examples/ljcf/GNUmakefile +++ b/examples/ljcf/GNUmakefile @@ -9,7 +9,7 @@ USE_HYPRE = TRUE USE_LAPACK= TRUE USE_IRL = TRUE PROFILE = FALSE -DEBUG = FALSE +DEBUG = TRUE #FALSE COMP = gnu EXEBASE = nga diff --git a/examples/ljcf/src/ljcf_class.f90 b/examples/ljcf/src/ljcf_class.f90 index 9454ee175..9afe21477 100644 --- a/examples/ljcf/src/ljcf_class.f90 +++ b/examples/ljcf/src/ljcf_class.f90 @@ -20,6 +20,8 @@ module ljcf_class private public :: ljcf + + integer :: ierr !> ljcf object type :: ljcf @@ -43,6 +45,7 @@ module ljcf_class !> Simulation monitor file type(monitor) :: mfile !< General simulation monitoring type(monitor) :: cflfile !< CFL monitoring + type(monitor) :: ljcf_file !< LJCF simulation monitoring !> Work arrays real(WP), dimension(:,:,:), allocatable :: resU,resV,resW !< Residuals @@ -69,7 +72,7 @@ module ljcf_class real(WP) :: djet, Vjet real(WP), dimension(:), allocatable :: xjet integer :: relax_model, nwall - real(WP) :: gravity, liqVol, liqVolInjected + real(WP) :: gravity, liqVol, liqVolInjected, InjectionVelocity contains procedure :: init !< Initialize nozzle simulation @@ -378,7 +381,9 @@ subroutine init(this) ! Update the band call this%vf%update_band() ! Create discontinuous polygon mesh from IRL interface + call MPI_BARRIER(this%cfg%comm,ierr);if (this%cfg%amRoot) print *,'polygonalizing interface...' call this%vf%polygonalize_interface() + call MPI_BARRIER(this%cfg%comm,ierr);if (this%cfg%amRoot) print *,'done polygonalizing interface' ! Calculate distance from polygons call this%vf%distance_from_polygon() ! Calculate subcell phasic volumes @@ -486,7 +491,6 @@ subroutine init(this) call this%mfile%add_column(this%fs%Vmax,'Vmax') call this%mfile%add_column(this%fs%Wmax,'Wmax') call this%mfile%add_column(this%fs%Pmax,'Pmax') - call this%mfile%add_column(this%liqVolInjected,'Liq Vol Injected') call this%mfile%add_column(this%vf%VFint,'VOF integral') call this%mfile%add_column(this%vf%SDint,'SD integral') call this%mfile%add_column(this%vof_removed,'VOF removed') @@ -508,6 +512,13 @@ subroutine init(this) call this%cflfile%add_column(this%fs%CFLv_y,'Viscous yCFL') call this%cflfile%add_column(this%fs%CFLv_z,'Viscous zCFL') call this%cflfile%write() + ! Create LJCF monitor + this%ljcf_file=monitor(this%fs%cfg%amRoot,'ljcf') + call this%ljcf_file%add_column(this%time%n,'Timestep number') + call this%ljcf_file%add_column(this%time%t,'Time') + call this%ljcf_file%add_column(this%liqVolInjected,'Liq Vol Injected') + call this%ljcf_file%add_column(this%InjectionVelocity,'Injection Velocity') + call this%ljcf_file%write() end block create_monitor @@ -619,6 +630,8 @@ subroutine step(this) use tpns_class, only: arithmetic_visc implicit none class(ljcf), intent(inout) :: this + + call MPI_BARRIER(this%cfg%comm,ierr);if (this%cfg%amRoot) print *,'Starting timestep number ',this%time%n ! Reset all timers and start timestep timer call this%tstep%reset() @@ -632,6 +645,8 @@ subroutine step(this) call this%time%adjust_dt() call this%time%increment() + call MPI_BARRIER(this%cfg%comm,ierr);if (this%cfg%amRoot) print *,' Setting jet velocity' + ! Apply jet velocity apply_bc: block use tpns_class, only: bcond @@ -641,14 +656,17 @@ subroutine step(this) do n=1,mybc%itr%no_ i=mybc%itr%map(1,n); j=mybc%itr%map(2,n); k=mybc%itr%map(3,n) if (this%liqVolInjected .lt. this%liqVol) then - this%fs%V(i,j,k)=this%gravity*this%time%t ! Velocity increases linearly with time + this%InjectionVelocity=this%gravity*this%time%t ! Velocity increases linearly with time else - this%fs%V(i,j,k)=0.0_WP ! Velocity stops once volume is reached + this%InjectionVelocity=0.0_WP ! Velocity stops once volume is reached end if + this%fs%V(i,j,k) = this%InjectionVelocity this%liqVolInjected = this%liqVolInjected + this%fs%V(i,j,k)*this%vf%VF(i,j-1,k)*this%cfg%dx(i)*this%cfg%dz(k)*this%time%dt end do end block apply_bc + call MPI_BARRIER(this%cfg%comm,ierr);if (this%cfg%amRoot) print *,'old' + ! Remember old VOF this%vf%VFold=this%vf%VF @@ -660,13 +678,20 @@ subroutine step(this) ! Prepare old sflaggered density (at n) call this%fs%get_olddensity(vf=this%vf) + call MPI_BARRIER(this%cfg%comm,ierr);if (this%cfg%amRoot) print *,'advance' + ! VOF solver step call this%tvof%start() ! Start VOF timer call this%vf%advance(dt=this%time%dt,U=this%fs%U,V=this%fs%V,W=this%fs%W) call this%tvof%stop() ! Stop VOF timer + + call MPI_BARRIER(this%cfg%comm,ierr);if (this%cfg%amRoot) print *,'viscosity' + ! Prepare new sflaggered viscosity (at n+1) call this%fs%get_viscosity(vf=this%vf,strat=arithmetic_visc) + + call MPI_BARRIER(this%cfg%comm,ierr);if (this%cfg%amRoot) print *,'subiters' ! Perform sub-iterations do while (this%time%it.le.this%time%itmax) @@ -733,10 +758,14 @@ subroutine step(this) this%time%it=this%time%it+1 end do + + call MPI_BARRIER(this%cfg%comm,ierr);if (this%cfg%amRoot) print *,'interpolating velocity' ! Recompute interpolated velocity and divergence call this%fs%interp_vel(this%Ui,this%Vi,this%Wi) call this%fs%get_div() + + call MPI_BARRIER(this%cfg%comm,ierr);if (this%cfg%amRoot) print *,'removing VOF at edge of domain' ! Remove VOF at edge of domain remove_vof: block @@ -754,6 +783,8 @@ subroutine step(this) call MPI_ALLREDUCE(MPI_IN_PLACE,this%vof_removed,1,MPI_REAL_WP,MPI_SUM,this%cfg%comm,ierr) call this%vf%clean_irl_and_band() end block remove_vof + + call MPI_BARRIER(this%cfg%comm,ierr);if (this%cfg%amRoot) print *,'output to Ensight' ! Output to ensight if (this%ens_evt%occurs()) then @@ -792,6 +823,9 @@ subroutine step(this) call this%mfile%write() call this%cflfile%write() call this%timefile%write() + call this%ljcf_file%write() + + call MPI_BARRIER(this%cfg%comm,ierr);if (this%cfg%amRoot) print *,'saving restart files' ! Finally, see if it's time to save restart files if (this%save_evt%occurs()) then diff --git a/examples/ljcf/src/simulation.f90 b/examples/ljcf/src/simulation.f90 index 463799071..7e1fd3156 100644 --- a/examples/ljcf/src/simulation.f90 +++ b/examples/ljcf/src/simulation.f90 @@ -127,9 +127,9 @@ subroutine simulation_run call atom%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) - atom%fs%U(i ,j,k)=atom%resU(i ,j,k)+1.0_WP - atom%fs%V(i-1,j,k)=atom%resV(i-1,j,k) - atom%fs%W(i-1,j,k)=atom%resW(i-1,j,k) + atom%fs%U(i ,j,k)=1.0_WP !atom%resU(i ,j,k)+1.0_WP + atom%fs%V(i-1,j,k)=0.0_WP !atom%resV(i-1,j,k) + atom%fs%W(i-1,j,k)=0.0_WP !atom%resW(i-1,j,k) end do end block apply_boundary_condition end block coupling From aa8642d0b2495f59f83468016e2376dc604ade96 Mon Sep 17 00:00:00 2001 From: Mark Owkes Date: Wed, 18 Jun 2025 11:50:04 -0600 Subject: [PATCH 17/70] Fixed parallelization of injection volume --- examples/ljcf/src/ljcf_class.f90 | 21 +++++++++++++++------ 1 file changed, 15 insertions(+), 6 deletions(-) diff --git a/examples/ljcf/src/ljcf_class.f90 b/examples/ljcf/src/ljcf_class.f90 index 9afe21477..7a53f9ccb 100644 --- a/examples/ljcf/src/ljcf_class.f90 +++ b/examples/ljcf/src/ljcf_class.f90 @@ -650,19 +650,28 @@ subroutine step(this) ! Apply jet velocity apply_bc: block use tpns_class, only: bcond + use mpi_f08, only: MPI_ALLREDUCE,MPI_SUM,MPI_IN_PLACE + use parallel, only: MPI_REAL_WP type(bcond), pointer :: mybc + real(WP) :: liqVolInjected_dt integer :: n,i,j,k + ! Compute injection velocity + if (this%liqVolInjected .lt. this%liqVol) then + this%InjectionVelocity=this%gravity*this%time%t ! Velocity increases linearly with time + else + this%InjectionVelocity=0.0_WP ! Velocity stops once volume is reached + end if + ! Apply injection velocity to the jet boundary condition call this%fs%get_bcond('jet',mybc) + liqVolInjected_dt = 0.0_WP do n=1,mybc%itr%no_ i=mybc%itr%map(1,n); j=mybc%itr%map(2,n); k=mybc%itr%map(3,n) - if (this%liqVolInjected .lt. this%liqVol) then - this%InjectionVelocity=this%gravity*this%time%t ! Velocity increases linearly with time - else - this%InjectionVelocity=0.0_WP ! Velocity stops once volume is reached - end if + this%fs%V(i,j,k) = this%InjectionVelocity - this%liqVolInjected = this%liqVolInjected + this%fs%V(i,j,k)*this%vf%VF(i,j-1,k)*this%cfg%dx(i)*this%cfg%dz(k)*this%time%dt + liqVolInjected_dt = liqVolInjected_dt + this%fs%V(i,j,k)*this%vf%VF(i,j-1,k)*this%cfg%dx(i)*this%cfg%dz(k)*this%time%dt end do + call MPI_ALLREDUCE(MPI_IN_PLACE,liqVolInjected_dt,1,MPI_REAL_WP,MPI_SUM,this%cfg%comm,ierr) + this%liqVolInjected = this%liqVolInjected + liqVolInjected_dt end block apply_bc call MPI_BARRIER(this%cfg%comm,ierr);if (this%cfg%amRoot) print *,'old' From 23b702182f6f84c545c5ed49afc3d5d89c96c43f Mon Sep 17 00:00:00 2001 From: Mark Owkes Date: Wed, 2 Jul 2025 10:37:42 -0600 Subject: [PATCH 18/70] Added debug statements to vof advance --- src/two_phase/vfs_class.f90 | 14 +++++++++++++- 1 file changed, 13 insertions(+), 1 deletion(-) diff --git a/src/two_phase/vfs_class.f90 b/src/two_phase/vfs_class.f90 index 46a00af55..cf3bb0b68 100644 --- a/src/two_phase/vfs_class.f90 +++ b/src/two_phase/vfs_class.f90 @@ -806,6 +806,7 @@ end subroutine apply_bcond !> Calculate the new VF based on U/V/W and dt subroutine advance(this,dt,U,V,W) implicit none + integer :: ierr class(vfs), 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) :: U !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) @@ -813,6 +814,7 @@ subroutine advance(this,dt,U,V,W) real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(inout) :: W !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) ! First perform transport + call MPI_BARRIER(this%cfg%comm,ierr);if (this%cfg%amRoot) print *,'transport' select case (this%transport_method) case (flux) call this%transport_flux(dt,U,V,W) @@ -823,39 +825,49 @@ subroutine advance(this,dt,U,V,W) case (remap_storage) call this%transport_remap_storage(dt,U,V,W) end select - + call MPI_BARRIER(this%cfg%comm,ierr);if (this%cfg%amRoot) print *,'advect polygons' ! Advect interface polygons call this%advect_interface(dt,U,V,W) ! Remove flotsams and thin structures if needed + call MPI_BARRIER(this%cfg%comm,ierr);if (this%cfg%amRoot) print *,'remove flotsams and thin structures' call this%remove_flotsams() call this%remove_thinstruct() ! Synchronize and clean-up barycenter fields + call MPI_BARRIER(this%cfg%comm,ierr);if (this%cfg%amRoot) print *,'sync and clean barycenters' call this%sync_and_clean_barycenters() ! Update the band + call MPI_BARRIER(this%cfg%comm,ierr);if (this%cfg%amRoot) print *,'band' call this%update_band() ! Perform interface reconstruction from transported moments + call MPI_BARRIER(this%cfg%comm,ierr);if (this%cfg%amRoot) print *,'build interface' call this%build_interface() ! Create discontinuous polygon mesh from IRL interface + call MPI_BARRIER(this%cfg%comm,ierr);if (this%cfg%amRoot) print *,'polygonalize interface' call this%polygonalize_interface() ! Perform interface sensing + call MPI_BARRIER(this%cfg%comm,ierr);if (this%cfg%amRoot) print *,'sense interface' if (this%two_planes) call this%sense_interface() ! Calculate distance from polygons + call MPI_BARRIER(this%cfg%comm,ierr);if (this%cfg%amRoot) print *,'distance from polygons' call this%distance_from_polygon() ! Calculate subcell phasic volumes + call MPI_BARRIER(this%cfg%comm,ierr);if (this%cfg%amRoot) print *,'subcell volumes' call this%subcell_vol() ! Calculate curvature + call MPI_BARRIER(this%cfg%comm,ierr);if (this%cfg%amRoot) print *,'curvature' call this%get_curvature() ! Reset moments to guarantee compatibility with interface reconstruction + call MPI_BARRIER(this%cfg%comm,ierr);if (this%cfg%amRoot) print *,'reset volume moments' call this%reset_volume_moments() end subroutine advance From 4320f7758e264cfaabc1fd1d153dfc16020b3dce Mon Sep 17 00:00:00 2001 From: Mark Owkes Date: Thu, 3 Jul 2025 07:12:18 -0600 Subject: [PATCH 19/70] more debug statements --- src/two_phase/vfs_class.f90 | 13 ++++++++++++- 1 file changed, 12 insertions(+), 1 deletion(-) diff --git a/src/two_phase/vfs_class.f90 b/src/two_phase/vfs_class.f90 index cf3bb0b68..f1348398f 100644 --- a/src/two_phase/vfs_class.f90 +++ b/src/two_phase/vfs_class.f90 @@ -3814,8 +3814,12 @@ subroutine polygonalize_interface(this) real(WP), dimension(1:3,1:4) :: vert real(WP), dimension(1:3) :: norm + call MPI_BARRIER(this%cfg%comm,ierr);if (this%cfg%amRoot) print *,'in polygonalize_interface' + ! Create a cell object call new(cell) + + call MPI_BARRIER(this%cfg%comm,ierr);if (this%cfg%amRoot) print *,'loop over full domain and form polygon' ! Loop over full domain and form polygon do k=this%cfg%kmino_,this%cfg%kmaxo_ @@ -3837,6 +3841,8 @@ subroutine polygonalize_interface(this) end do end do end do + + call MPI_BARRIER(this%cfg%comm,ierr);if (this%cfg%amRoot) print *,'x-face polygonalization' ! Find inferface between filled and empty cells on x-face do k=this%cfg%kmino_,this%cfg%kmaxo_ @@ -3858,7 +3864,8 @@ subroutine polygonalize_interface(this) end do end do end do - + + call MPI_BARRIER(this%cfg%comm,ierr);if (this%cfg%amRoot) print *,'y-face polygonalization' ! Find inferface between filled and empty cells on y-face do k=this%cfg%kmino_,this%cfg%kmaxo_ do j=this%cfg%jmino_+1,this%cfg%jmaxo_ @@ -3880,6 +3887,7 @@ subroutine polygonalize_interface(this) end do end do + call MPI_BARRIER(this%cfg%comm,ierr);if (this%cfg%amRoot) print *,'z-face polygonalization' ! Find inferface between filled and empty cells on z-face do k=this%cfg%kmino_+1,this%cfg%kmaxo_ do j=this%cfg%jmino_,this%cfg%jmaxo_ @@ -3902,6 +3910,7 @@ subroutine polygonalize_interface(this) end do ! Now compute surface area divided by cell volume + call MPI_BARRIER(this%cfg%comm,ierr);if (this%cfg%amRoot) print *,'calculate surface density' this%SD=0.0_WP do k=this%cfg%kmino_,this%cfg%kmaxo_ do j=this%cfg%jmino_,this%cfg%jmaxo_ @@ -3917,6 +3926,8 @@ subroutine polygonalize_interface(this) end do end do end do + call MPI_BARRIER(this%cfg%comm,ierr);if (this%cfg%amRoot) print *,'done polygonalization of interface' + end subroutine polygonalize_interface From dbdde43b6b360f83780bb18720918cf683496365 Mon Sep 17 00:00:00 2001 From: Mark Owkes Date: Thu, 3 Jul 2025 07:14:00 -0600 Subject: [PATCH 20/70] Forgot to allocate --- src/two_phase/vfs_class.f90 | 1 + 1 file changed, 1 insertion(+) diff --git a/src/two_phase/vfs_class.f90 b/src/two_phase/vfs_class.f90 index f1348398f..bf322cc53 100644 --- a/src/two_phase/vfs_class.f90 +++ b/src/two_phase/vfs_class.f90 @@ -3807,6 +3807,7 @@ end subroutine set_full_bcond !> Here, only mask=1 is skipped (i.e., real walls), so bconds should be handled subroutine polygonalize_interface(this) implicit none + integer :: ierr class(vfs), intent(inout) :: this integer :: i,j,k,n real(WP) :: tsd From 13c9951f1826296e22099d742d6a7c381b2da258 Mon Sep 17 00:00:00 2001 From: Mark Owkes Date: Mon, 16 Feb 2026 09:44:12 -0700 Subject: [PATCH 21/70] Clean-up of print statements --- examples/ljcf/src/ljcf_class.f90 | 23 ----------------------- src/two_phase/vfs_class.f90 | 24 ------------------------ 2 files changed, 47 deletions(-) diff --git a/examples/ljcf/src/ljcf_class.f90 b/examples/ljcf/src/ljcf_class.f90 index 7a53f9ccb..46bf82596 100644 --- a/examples/ljcf/src/ljcf_class.f90 +++ b/examples/ljcf/src/ljcf_class.f90 @@ -381,9 +381,7 @@ subroutine init(this) ! Update the band call this%vf%update_band() ! Create discontinuous polygon mesh from IRL interface - call MPI_BARRIER(this%cfg%comm,ierr);if (this%cfg%amRoot) print *,'polygonalizing interface...' call this%vf%polygonalize_interface() - call MPI_BARRIER(this%cfg%comm,ierr);if (this%cfg%amRoot) print *,'done polygonalizing interface' ! Calculate distance from polygons call this%vf%distance_from_polygon() ! Calculate subcell phasic volumes @@ -630,8 +628,6 @@ subroutine step(this) use tpns_class, only: arithmetic_visc implicit none class(ljcf), intent(inout) :: this - - call MPI_BARRIER(this%cfg%comm,ierr);if (this%cfg%amRoot) print *,'Starting timestep number ',this%time%n ! Reset all timers and start timestep timer call this%tstep%reset() @@ -645,8 +641,6 @@ subroutine step(this) call this%time%adjust_dt() call this%time%increment() - call MPI_BARRIER(this%cfg%comm,ierr);if (this%cfg%amRoot) print *,' Setting jet velocity' - ! Apply jet velocity apply_bc: block use tpns_class, only: bcond @@ -674,8 +668,6 @@ subroutine step(this) this%liqVolInjected = this%liqVolInjected + liqVolInjected_dt end block apply_bc - call MPI_BARRIER(this%cfg%comm,ierr);if (this%cfg%amRoot) print *,'old' - ! Remember old VOF this%vf%VFold=this%vf%VF @@ -687,20 +679,13 @@ subroutine step(this) ! Prepare old sflaggered density (at n) call this%fs%get_olddensity(vf=this%vf) - call MPI_BARRIER(this%cfg%comm,ierr);if (this%cfg%amRoot) print *,'advance' - ! VOF solver step call this%tvof%start() ! Start VOF timer call this%vf%advance(dt=this%time%dt,U=this%fs%U,V=this%fs%V,W=this%fs%W) call this%tvof%stop() ! Stop VOF timer - - call MPI_BARRIER(this%cfg%comm,ierr);if (this%cfg%amRoot) print *,'viscosity' - ! Prepare new sflaggered viscosity (at n+1) call this%fs%get_viscosity(vf=this%vf,strat=arithmetic_visc) - - call MPI_BARRIER(this%cfg%comm,ierr);if (this%cfg%amRoot) print *,'subiters' ! Perform sub-iterations do while (this%time%it.le.this%time%itmax) @@ -767,14 +752,10 @@ subroutine step(this) this%time%it=this%time%it+1 end do - - call MPI_BARRIER(this%cfg%comm,ierr);if (this%cfg%amRoot) print *,'interpolating velocity' ! Recompute interpolated velocity and divergence call this%fs%interp_vel(this%Ui,this%Vi,this%Wi) call this%fs%get_div() - - call MPI_BARRIER(this%cfg%comm,ierr);if (this%cfg%amRoot) print *,'removing VOF at edge of domain' ! Remove VOF at edge of domain remove_vof: block @@ -792,8 +773,6 @@ subroutine step(this) call MPI_ALLREDUCE(MPI_IN_PLACE,this%vof_removed,1,MPI_REAL_WP,MPI_SUM,this%cfg%comm,ierr) call this%vf%clean_irl_and_band() end block remove_vof - - call MPI_BARRIER(this%cfg%comm,ierr);if (this%cfg%amRoot) print *,'output to Ensight' ! Output to ensight if (this%ens_evt%occurs()) then @@ -833,8 +812,6 @@ subroutine step(this) call this%cflfile%write() call this%timefile%write() call this%ljcf_file%write() - - call MPI_BARRIER(this%cfg%comm,ierr);if (this%cfg%amRoot) print *,'saving restart files' ! Finally, see if it's time to save restart files if (this%save_evt%occurs()) then diff --git a/src/two_phase/vfs_class.f90 b/src/two_phase/vfs_class.f90 index bf322cc53..0cbb3e8db 100644 --- a/src/two_phase/vfs_class.f90 +++ b/src/two_phase/vfs_class.f90 @@ -814,7 +814,6 @@ subroutine advance(this,dt,U,V,W) real(WP), dimension(this%cfg%imino_:,this%cfg%jmino_:,this%cfg%kmino_:), intent(inout) :: W !< Needs to be (imino_:imaxo_,jmino_:jmaxo_,kmino_:kmaxo_) ! First perform transport - call MPI_BARRIER(this%cfg%comm,ierr);if (this%cfg%amRoot) print *,'transport' select case (this%transport_method) case (flux) call this%transport_flux(dt,U,V,W) @@ -825,49 +824,38 @@ subroutine advance(this,dt,U,V,W) case (remap_storage) call this%transport_remap_storage(dt,U,V,W) end select - call MPI_BARRIER(this%cfg%comm,ierr);if (this%cfg%amRoot) print *,'advect polygons' ! Advect interface polygons call this%advect_interface(dt,U,V,W) ! Remove flotsams and thin structures if needed - call MPI_BARRIER(this%cfg%comm,ierr);if (this%cfg%amRoot) print *,'remove flotsams and thin structures' call this%remove_flotsams() call this%remove_thinstruct() ! Synchronize and clean-up barycenter fields - call MPI_BARRIER(this%cfg%comm,ierr);if (this%cfg%amRoot) print *,'sync and clean barycenters' call this%sync_and_clean_barycenters() ! Update the band - call MPI_BARRIER(this%cfg%comm,ierr);if (this%cfg%amRoot) print *,'band' call this%update_band() ! Perform interface reconstruction from transported moments - call MPI_BARRIER(this%cfg%comm,ierr);if (this%cfg%amRoot) print *,'build interface' call this%build_interface() ! Create discontinuous polygon mesh from IRL interface - call MPI_BARRIER(this%cfg%comm,ierr);if (this%cfg%amRoot) print *,'polygonalize interface' call this%polygonalize_interface() ! Perform interface sensing - call MPI_BARRIER(this%cfg%comm,ierr);if (this%cfg%amRoot) print *,'sense interface' if (this%two_planes) call this%sense_interface() ! Calculate distance from polygons - call MPI_BARRIER(this%cfg%comm,ierr);if (this%cfg%amRoot) print *,'distance from polygons' call this%distance_from_polygon() ! Calculate subcell phasic volumes - call MPI_BARRIER(this%cfg%comm,ierr);if (this%cfg%amRoot) print *,'subcell volumes' call this%subcell_vol() ! Calculate curvature - call MPI_BARRIER(this%cfg%comm,ierr);if (this%cfg%amRoot) print *,'curvature' call this%get_curvature() ! Reset moments to guarantee compatibility with interface reconstruction - call MPI_BARRIER(this%cfg%comm,ierr);if (this%cfg%amRoot) print *,'reset volume moments' call this%reset_volume_moments() end subroutine advance @@ -2887,7 +2875,6 @@ subroutine smooth_interface(this) ! Collect maximum residual and increment iteration counter call MPI_ALLREDUCE(MPI_IN_PLACE,res,1,MPI_REAL_WP,MPI_MAX,this%cfg%comm,ierr); ite=ite+1 - if (this%cfg%amRoot) print*,'ite=',ite,'residual=',res ! Synchronize across boundaries call this%sync_interface() @@ -3815,12 +3802,8 @@ subroutine polygonalize_interface(this) real(WP), dimension(1:3,1:4) :: vert real(WP), dimension(1:3) :: norm - call MPI_BARRIER(this%cfg%comm,ierr);if (this%cfg%amRoot) print *,'in polygonalize_interface' - ! Create a cell object call new(cell) - - call MPI_BARRIER(this%cfg%comm,ierr);if (this%cfg%amRoot) print *,'loop over full domain and form polygon' ! Loop over full domain and form polygon do k=this%cfg%kmino_,this%cfg%kmaxo_ @@ -3842,8 +3825,6 @@ subroutine polygonalize_interface(this) end do end do end do - - call MPI_BARRIER(this%cfg%comm,ierr);if (this%cfg%amRoot) print *,'x-face polygonalization' ! Find inferface between filled and empty cells on x-face do k=this%cfg%kmino_,this%cfg%kmaxo_ @@ -3866,7 +3847,6 @@ subroutine polygonalize_interface(this) end do end do - call MPI_BARRIER(this%cfg%comm,ierr);if (this%cfg%amRoot) print *,'y-face polygonalization' ! Find inferface between filled and empty cells on y-face do k=this%cfg%kmino_,this%cfg%kmaxo_ do j=this%cfg%jmino_+1,this%cfg%jmaxo_ @@ -3888,7 +3868,6 @@ subroutine polygonalize_interface(this) end do end do - call MPI_BARRIER(this%cfg%comm,ierr);if (this%cfg%amRoot) print *,'z-face polygonalization' ! Find inferface between filled and empty cells on z-face do k=this%cfg%kmino_+1,this%cfg%kmaxo_ do j=this%cfg%jmino_,this%cfg%jmaxo_ @@ -3911,7 +3890,6 @@ subroutine polygonalize_interface(this) end do ! Now compute surface area divided by cell volume - call MPI_BARRIER(this%cfg%comm,ierr);if (this%cfg%amRoot) print *,'calculate surface density' this%SD=0.0_WP do k=this%cfg%kmino_,this%cfg%kmaxo_ do j=this%cfg%jmino_,this%cfg%jmaxo_ @@ -3927,8 +3905,6 @@ subroutine polygonalize_interface(this) end do end do end do - call MPI_BARRIER(this%cfg%comm,ierr);if (this%cfg%amRoot) print *,'done polygonalization of interface' - end subroutine polygonalize_interface From 4fa62a7953625701de1d5a1adc0e085ccf36fab9 Mon Sep 17 00:00:00 2001 From: Mark Owkes Date: Mon, 16 Feb 2026 09:44:46 -0700 Subject: [PATCH 22/70] Maded ljcf opt by default --- examples/ljcf/GNUmakefile | 2 +- examples/ljcf/input | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/examples/ljcf/GNUmakefile b/examples/ljcf/GNUmakefile index 9e6b93d70..f51ff99ec 100644 --- a/examples/ljcf/GNUmakefile +++ b/examples/ljcf/GNUmakefile @@ -9,7 +9,7 @@ USE_HYPRE = TRUE USE_LAPACK= TRUE USE_IRL = TRUE PROFILE = FALSE -DEBUG = TRUE #FALSE +DEBUG = FALSE COMP = gnu EXEBASE = nga diff --git a/examples/ljcf/input b/examples/ljcf/input index 80ab85aaf..89e494ab9 100644 --- a/examples/ljcf/input +++ b/examples/ljcf/input @@ -1,5 +1,5 @@ # Parallelization -Partition : 1 1 1 +Partition : 8 1 1 I/O partition : 1 1 1 # Mesh definition From ec8ec3e470922f8985cd431bb0ddc5b75bca89bd Mon Sep 17 00:00:00 2001 From: Mark Owkes Date: Mon, 16 Feb 2026 12:58:00 -0700 Subject: [PATCH 23/70] Made a LJCF case with dimensional parameters --- examples/ljcf_dimensinal/GNUmakefile | 47 ++ examples/ljcf_dimensinal/README | 1 + examples/ljcf_dimensinal/input | 43 + examples/ljcf_dimensinal/src/Make.package | 2 + examples/ljcf_dimensinal/src/hit_class.f90 | 428 ++++++++++ examples/ljcf_dimensinal/src/ljcf_class.f90 | 883 ++++++++++++++++++++ examples/ljcf_dimensinal/src/simulation.f90 | 161 ++++ 7 files changed, 1565 insertions(+) create mode 100644 examples/ljcf_dimensinal/GNUmakefile create mode 100644 examples/ljcf_dimensinal/README create mode 100644 examples/ljcf_dimensinal/input create mode 100644 examples/ljcf_dimensinal/src/Make.package create mode 100644 examples/ljcf_dimensinal/src/hit_class.f90 create mode 100644 examples/ljcf_dimensinal/src/ljcf_class.f90 create mode 100644 examples/ljcf_dimensinal/src/simulation.f90 diff --git a/examples/ljcf_dimensinal/GNUmakefile b/examples/ljcf_dimensinal/GNUmakefile new file mode 100644 index 000000000..f51ff99ec --- /dev/null +++ b/examples/ljcf_dimensinal/GNUmakefile @@ -0,0 +1,47 @@ +# NGA location if not yet defined +NGA_HOME ?= ../.. + +# Compilation parameters +PRECISION = DOUBLE +USE_MPI = TRUE +USE_FFTW = TRUE +USE_HYPRE = TRUE +USE_LAPACK= TRUE +USE_IRL = TRUE +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 two_phase particles constant_density 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/ljcf_dimensinal/README b/examples/ljcf_dimensinal/README new file mode 100644 index 000000000..5e5f940b6 --- /dev/null +++ b/examples/ljcf_dimensinal/README @@ -0,0 +1 @@ +This case simulates the break-up of a liquid ligament in a turbulent crossflow. \ No newline at end of file diff --git a/examples/ljcf_dimensinal/input b/examples/ljcf_dimensinal/input new file mode 100644 index 000000000..d2defcb28 --- /dev/null +++ b/examples/ljcf_dimensinal/input @@ -0,0 +1,43 @@ +# Parallelization +Partition : 8 1 1 +I/O partition : 1 1 1 + +# Mesh definition +X ljcf : 0.108 # 2D +Lx : 0.432 # 8D +Ly : 0.432 # 8D for testing - should be 0.864 # 16D +Lz : 0.216 # 4D +nx : 64 # 8 cells/D +ny : 64 # Reduced for 8D for testing - should be 128 +nz : 32 + +# Flow conditions +Jet diameter : 0.054 # m +End Injection Time : 0.267 # s sqrt(2*H/g) = sqrt(2*0.35 m / 9.81 m/s^2) = 0.267 s +Jet location : 0 +Liquid density : 1000 # kg/m^3 +Gas density : 1.2 # kg/m^3 +Liquid viscosity : 1e-3 # Pa-s +Gas viscosity : 1.8e-5 # Pa-s +Surface tension : 0.072 # N/m +Gravitational acceleration : 9.81 # m/s^2 +Air velocity : 11 # m/s +Target Re_lambda : 45 +Turbulence intensity : 0.05 + +# Time integration +Max timestep size : 2e-4 # s +Max cfl number : 1.0 +Max time : 0.4 # s + +# Pressure solver +Pressure tolerance : 1e-4 +Pressure iteration : 100 + +# Data output +Ensight output period : 2.5e-3 # s +Restart output period : 0.05 # s + +# Data restart +#Restart from : 1.00000E+01 +#HIT restart : hit_1.00000E+01 diff --git a/examples/ljcf_dimensinal/src/Make.package b/examples/ljcf_dimensinal/src/Make.package new file mode 100644 index 000000000..ac9df0728 --- /dev/null +++ b/examples/ljcf_dimensinal/src/Make.package @@ -0,0 +1,2 @@ +# List here the extra files here +f90EXE_sources += simulation.f90 hit_class.f90 ljcf_class.f90 diff --git a/examples/ljcf_dimensinal/src/hit_class.f90 b/examples/ljcf_dimensinal/src/hit_class.f90 new file mode 100644 index 000000000..792e384df --- /dev/null +++ b/examples/ljcf_dimensinal/src/hit_class.f90 @@ -0,0 +1,428 @@ +!> Definition for an hit class +module hit_class + use precision, only: WP + use config_class, only: config + use fft3d_class, only: fft3d + use incomp_class, only: incomp + use timetracker_class, only: timetracker + use monitor_class, only: monitor + use pardata_class, only: pardata + use event_class, only: event + implicit none + private + + public :: hit + + !> HIT object + type :: hit + !> Config + type(config) :: cfg !< Mesh for solver + !> Flow solver + type(incomp) :: fs !< Incompressible flow solver + type(fft3d) :: ps !< FFT-based linear solver + type(timetracker) :: time !< Time info + !> Simulation monitor file + type(monitor) :: mfile !< General simulation monitoring + !> Work arrays + real(WP), dimension(:,:,:,:,:), allocatable :: gradU !< Velocity gradient + real(WP), dimension(:,:,:,:), allocatable :: SR !< Strain rate tensor + real(WP), dimension(:,:,:), allocatable :: resU,resV,resW !< Residuals + !> Turbulence parameters + real(WP) :: ti ! Turbulence intensity + real(WP) :: visc,meanU,meanV,meanW + real(WP) :: Urms_tgt,tke_tgt,eps_tgt ! u',k, and dissipation rate + real(WP) :: tko_tgt,eta_tgt ! Kolmogorov time and length scales + real(WP) :: Rel_tgt,Ret_tgt ! Lambda and turbulent Reynolds numbers + real(WP) :: tau_tgt ! Eddy turnover time + real(WP) :: Urms,tke,eps,Ret,Rel,eta,ell ! Current turbulence parameters (ell is large eddy size) + !> Forcing constant + real(WP) :: forcing + !> Provide a pardata object for restarts + logical :: restarted + type(pardata) :: df + type(event) :: save_evt + contains + procedure, private :: compute_stats !< Turbulence information + procedure :: init !< Initialize HIT simulation + procedure :: step !< Advance HIT simulation by one time step + procedure :: final !< Finalize HIT simulation + end type hit + + +contains + + + !> Compute turbulence stats (assumes rho=1) + subroutine compute_stats(this) + use mpi_f08, only: MPI_ALLREDUCE,MPI_SUM + use parallel, only: MPI_REAL_WP + class(hit), intent(inout) :: this + real(WP) :: myTKE,myEPS + integer :: i,j,k,ierr + ! Compute mean velocities + call this%fs%cfg%integrate(A=this%fs%U,integral=this%meanU); this%meanU=this%meanU/this%fs%cfg%vol_total + call this%fs%cfg%integrate(A=this%fs%V,integral=this%meanV); this%meanV=this%meanV/this%fs%cfg%vol_total + call this%fs%cfg%integrate(A=this%fs%W,integral=this%meanW); this%meanW=this%meanW/this%fs%cfg%vol_total + ! Compute strainrate and grad(U) + call this%fs%get_strainrate(SR=this%SR) + call this%fs%get_gradu(gradu=this%gradU) + ! Compute current TKE and dissipation rate + myTKE=0.0_WP + myEPS=0.0_WP + do k=this%fs%cfg%kmin_,this%fs%cfg%kmax_ + do j=this%fs%cfg%jmin_,this%fs%cfg%jmax_ + do i=this%fs%cfg%imin_,this%fs%cfg%imax_ + myTKE=myTKE+0.5_WP*((this%fs%U(i,j,k)-this%meanU)**2+(this%fs%V(i,j,k)-this%meanV)**2+(this%fs%W(i,j,k)-this%meanW)**2)*this%fs%cfg%vol(i,j,k) + myEPS=myEPS+2.0_WP*this%fs%cfg%vol(i,j,k)*(this%SR(1,i,j,k)**2+this%SR(2,i,j,k)**2+this%SR(3,i,j,k)**2+2.0_WP*(this%SR(4,i,j,k)**2+this%SR(5,i,j,k)**2+this%SR(6,i,j,k)**2)) + end do + end do + end do + call MPI_ALLREDUCE(myTKE,this%tke,1,MPI_REAL_WP,MPI_SUM,this%fs%cfg%comm,ierr); this%tke=this%tke/this%fs%cfg%vol_total + call MPI_ALLREDUCE(myEPS,this%eps,1,MPI_REAL_WP,MPI_SUM,this%fs%cfg%comm,ierr); this%eps=this%eps*this%visc/this%fs%cfg%vol_total + ! Compute standard parameters for HIT + this%Urms=sqrt(2.0_WP/3.0_WP*this%tke) + this%Ret=this%tke**2.0_WP/(this%visc*this%eps) + this%Rel=sqrt(20.0_WP*this%Ret/3.0_WP) + this%eta=((this%visc)**3.0_WP/this%eps)**0.25_WP + this%ell=(2.0_WP*this%tke/3.0_WP)**1.5_WP/this%eps + end subroutine compute_stats + + + !> Initialization of HIT simulation + subroutine init(this,group,xend) + use mpi_f08, only: MPI_Group + implicit none + class(hit), intent(inout) :: this + type(MPI_Group), intent(in) :: group + real(WP) :: xend + + ! Create the HIT mesh + create_config: block + use sgrid_class, only: cartesian,sgrid + use param, only: param_read + real(WP), dimension(:), allocatable :: x,y + integer, dimension(3) :: partition + type(sgrid) :: grid + integer :: j,ny + real(WP) :: Ly + ! Read in grid definition + call param_read('Ly',Ly); call param_read('ny',ny); allocate(y(ny+1)); allocate(x(ny+1)) + ! Create simple rectilinear grid in y and z + do j=1,ny+1 + y(j)=real(j-1,WP)/real(ny,WP)*Ly-0.5_WP*Ly + end do + ! Same grid in x, but shifted so it ends at xend + x=y-y(ny+1)+xend + ! General serial grid object + grid=sgrid(coord=cartesian,no=1,x=x,y=y,z=y,xper=.true.,yper=.true.,zper=.true.,name='HIT') + ! Read in partition + call param_read('Partition',partition,short='p'); partition(1)=1 + ! Create partitioned grid without walls + this%cfg=config(grp=group,decomp=partition,grid=grid) + end block create_config + + ! Initialize the work arrays + allocate_work_arrays: block + allocate(this%resU(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + allocate(this%resV(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + allocate(this%resW(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + allocate(this%SR (1:6,this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + allocate(this%gradU(1:3,1:3,this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + end block allocate_work_arrays + + + ! Initialize time tracker with 2 subiterations + initialize_timetracker: block + use param, only: param_read + this%time=timetracker(amRoot=this%cfg%amRoot) + call param_read('Max timestep size',this%time%dtmax) + call param_read('Max cfl number',this%time%cflmax) + this%time%dt=this%time%dtmax + this%time%itmax=2 + end block initialize_timetracker + + + ! Create a single-phase periodic flow solver + create_flow_solver: block + use mathtools, only: Pi + use param, only: param_read + ! Create flow solver + this%fs=incomp(cfg=this%cfg,name='NS solver') + ! Set density to 1.0 + this%fs%rho=1.0_WP + ! Set viscosity from Reynolds number + call param_read("Gas viscosity",this%visc); + this%fs%visc=this%visc + ! Prepare and configure pressure solver + this%ps=fft3d(cfg=this%cfg,name='Pressure',nst=7) + ! Setup the solver + call this%fs%setup(pressure_solver=this%ps) + end block create_flow_solver + + + ! Prepare initial velocity field + initialize_velocity: block + use random, only: random_normal + use mathtools, only: Pi + use param, only: param_read,param_exists + use messager, only: log + use string, only: str_long + character(str_long) :: message + real(WP) :: max_forcing_estimate + integer :: i,j,k + ! Read in turbulence intensity for turbulence injection + call param_read('Turbulence intensity',this%ti) + ! Read in target Re_lambda and convert to target Urms + call param_read('Target Re_lambda',this%Urms_tgt) + this%Urms_tgt=this%visc/(3.0_WP*this%cfg%xL)*this%Urms_tgt**2 + ! Calculate other target quantities assuming l=0.2*xL + this%tke_tgt=1.5_WP*this%Urms_tgt**2 + this%eps_tgt=5.0_WP*this%Urms_tgt**3/this%cfg%xL + this%tko_tgt=sqrt(this%visc/this%eps_tgt) + this%eta_tgt=(this%visc**3/this%eps_tgt)**(0.25_WP) + this%Rel_tgt=sqrt(3.0_WP*this%Urms_tgt*this%cfg%xL/this%visc) + this%Ret_tgt=this%tke_tgt**2/(this%eps_tgt*this%visc) + this%tau_tgt=2.0_WP*this%tke_tgt/(3.0_WP*this%eps_tgt) + ! Read in forcing parameter (we need dt Urms =",es12.5)') this%Urms_tgt; call log(message) + write(message,'("[HIT setup] => Re_lambda =",es12.5)') this%Rel_tgt; call log(message) + write(message,'("[HIT setup] => Re_turb =",es12.5)') this%Ret_tgt; call log(message) + write(message,'("[HIT setup] => Kolmogorov Lscale =",es12.5)') this%eta_tgt; call log(message) + write(message,'("[HIT setup] => Kolmogorov Tscale =",es12.5)') this%tko_tgt; call log(message) + write(message,'("[HIT setup] => Epsilon =",es12.5)') this%eps_tgt; call log(message) + write(message,'("[HIT setup] => Eddyturnover time =",es12.5)') this%tau_tgt; call log(message) + end if + ! Gaussian initial field + do k=this%fs%cfg%kmin_,this%fs%cfg%kmax_ + do j=this%fs%cfg%jmin_,this%fs%cfg%jmax_ + do i=this%fs%cfg%imin_,this%fs%cfg%imax_ + this%fs%U(i,j,k)=random_normal(m=0.0_WP,sd=this%Urms_tgt) + this%fs%V(i,j,k)=random_normal(m=0.0_WP,sd=this%Urms_tgt) + this%fs%W(i,j,k)=random_normal(m=0.0_WP,sd=this%Urms_tgt) + end do + end do + end do + call this%fs%cfg%sync(this%fs%U) + call this%fs%cfg%sync(this%fs%V) + call this%fs%cfg%sync(this%fs%W) + ! Compute mean and remove it from the velocity field to obtain =0 + call this%fs%cfg%integrate(A=this%fs%U,integral=this%meanU); this%meanU=this%meanU/this%fs%cfg%vol_total; this%fs%U=this%fs%U-this%meanU + call this%fs%cfg%integrate(A=this%fs%V,integral=this%meanV); this%meanV=this%meanV/this%fs%cfg%vol_total; this%fs%V=this%fs%V-this%meanV + call this%fs%cfg%integrate(A=this%fs%W,integral=this%meanW); this%meanW=this%meanW/this%fs%cfg%vol_total; this%fs%W=this%fs%W-this%meanW + ! Project to ensure divergence-free + call this%fs%get_div() + this%fs%psolv%rhs=-this%fs%cfg%vol*this%fs%div + this%fs%psolv%sol=0.0_WP + call this%fs%psolv%solve() + call this%fs%shift_p(this%fs%psolv%sol) + call this%fs%get_pgrad(this%fs%psolv%sol,this%resU,this%resV,this%resW) + this%fs%P=this%fs%P+this%fs%psolv%sol + this%fs%U=this%fs%U-this%resU + this%fs%V=this%fs%V-this%resV + this%fs%W=this%fs%W-this%resW + ! Calculate divergence + call this%fs%get_div() + end block initialize_velocity + + + ! Handle restart here + perform_restart: block + use param, only: param_read + use string, only: str_medium + use filesys, only: makedir,isdir + character(len=str_medium) :: filename + integer, dimension(3) :: iopartition + ! Create event for saving restart files + this%save_evt=event(this%time,'HIT restart output') + call param_read('Restart output period',this%save_evt%tper) + ! Read in the partition for I/O + call param_read('I/O partition',iopartition) + ! Check if a restart file was provided + call param_read('HIT restart',filename,default='') + this%restarted=.false.; if (len_trim(filename).gt.0) this%restarted=.true. + ! Perform pardata initialization + if (this%restarted) then + ! Read in the file + call this%df%initialize(pg=this%cfg,iopartition=iopartition,fdata='restart/'//trim(filename)) + ! Put the data at the right place + call this%df%pull(name='U',var=this%fs%U) + call this%df%pull(name='V',var=this%fs%V) + call this%df%pull(name='W',var=this%fs%W) + call this%df%pull(name='P',var=this%fs%P) + ! Update divergence + call this%fs%get_div() + ! Also update time + call this%df%pull(name='t' ,val=this%time%t ) + call this%df%pull(name='dt',val=this%time%dt) + this%time%told=this%time%t-this%time%dt + !this%time%dt=this%time%dtmax !< Force max timestep size anyway + else + ! Prepare a new directory for storing files for restart + if (this%cfg%amRoot) then + if (.not.isdir('restart')) call makedir('restart') + end if + ! If we are not restarting, we will still need a datafile for saving restart files + call this%df%initialize(pg=this%cfg,iopartition=iopartition,filename=trim(this%cfg%name),nval=2,nvar=4) + this%df%valname=['dt','t ']; this%df%varname=['U','V','W','P'] + end if + end block perform_restart + + + ! Create monitoring file + create_monitor: block + ! Prepare some info about turbulence + call this%fs%get_max() + call this%compute_stats() + ! Create simulation monitor + this%mfile=monitor(this%fs%cfg%amRoot,'hit') + call this%mfile%add_column(this%time%n,'Timestep number') + call this%mfile%add_column(this%time%t,'Time') + call this%mfile%add_column(this%time%dt,'Timestep size') + call this%mfile%add_column(this%fs%Umax,'Umax') + call this%mfile%add_column(this%fs%Vmax,'Vmax') + call this%mfile%add_column(this%fs%Wmax,'Wmax') + call this%mfile%add_column(this%Ret,'Re_turb') + call this%mfile%add_column(this%Rel,'Re_lambda') + call this%mfile%add_column(this%Urms,'Urms') + call this%mfile%add_column(this%TKE,'TKE') + call this%mfile%add_column(this%EPS,'Epsilon') + call this%mfile%add_column(this%ell,'Large eddy size') + call this%mfile%add_column(this%eta,'Kolmogorov length') + call this%mfile%write() + end block create_monitor + + + end subroutine init + + + !> Take one time step with specified dt + subroutine step(this,dt) + implicit none + class(hit), intent(inout) :: this + real(WP), intent(in) :: dt + + ! Increment time based on provided dt + this%time%dt=dt; call this%time%increment() + + ! Remember old velocity + this%fs%Uold=this%fs%U + this%fs%Vold=this%fs%V + this%fs%Wold=this%fs%W + + ! Perform sub-iterations + do while (this%time%it.le.this%time%itmax) + + ! Build mid-time velocity + this%fs%U=0.5_WP*(this%fs%U+this%fs%Uold) + this%fs%V=0.5_WP*(this%fs%V+this%fs%Vold) + this%fs%W=0.5_WP*(this%fs%W+this%fs%Wold) + + ! Explicit calculation of drho*u/dt from NS + call this%fs%get_dmomdt(this%resU,this%resV,this%resW) + + ! Assemble explicit residual + this%resU=-2.0_WP*(this%fs%U-this%fs%Uold)+this%time%dt*this%resU + this%resV=-2.0_WP*(this%fs%V-this%fs%Vold)+this%time%dt*this%resV + this%resW=-2.0_WP*(this%fs%W-this%fs%Wold)+this%time%dt*this%resW + + ! Apply HIT forcing + hit_forcing: block + use mpi_f08, only: MPI_ALLREDUCE,MPI_SUM + use parallel, only: MPI_REAL_WP + real(WP) :: myTKE,A,myEPSp,EPSp + integer :: i,j,k,ierr + ! Calculate mean velocity + call this%fs%cfg%integrate(A=this%fs%U,integral=this%meanU); this%meanU=this%meanU/this%fs%cfg%vol_total + call this%fs%cfg%integrate(A=this%fs%V,integral=this%meanV); this%meanV=this%meanV/this%fs%cfg%vol_total + call this%fs%cfg%integrate(A=this%fs%W,integral=this%meanW); this%meanW=this%meanW/this%fs%cfg%vol_total + ! Calculate TKE and pseudo-EPS + call this%fs%get_gradu(gradu=this%gradU) + myTKE=0.0_WP; myEPSp=0.0_WP + do k=this%fs%cfg%kmin_,this%fs%cfg%kmax_ + do j=this%fs%cfg%jmin_,this%fs%cfg%jmax_ + do i=this%fs%cfg%imin_,this%fs%cfg%imax_ + myTKE =myTKE +0.5_WP*((this%fs%U(i,j,k)-this%meanU)**2+(this%fs%V(i,j,k)-this%meanV)**2+(this%fs%W(i,j,k)-this%meanW)**2)*this%fs%cfg%vol(i,j,k) + myEPSp=myEPSp+this%fs%cfg%vol(i,j,k)*(this%gradU(1,1,i,j,k)**2+this%gradU(1,2,i,j,k)**2+this%gradU(1,3,i,j,k)**2+& + & this%gradU(2,1,i,j,k)**2+this%gradU(2,2,i,j,k)**2+this%gradU(2,3,i,j,k)**2+& + & this%gradU(3,1,i,j,k)**2+this%gradU(3,2,i,j,k)**2+this%gradU(3,3,i,j,k)**2) + end do + end do + end do + call MPI_ALLREDUCE(myTKE,this%tke,1,MPI_REAL_WP,MPI_SUM,this%fs%cfg%comm,ierr); this%tke=this%tke/this%fs%cfg%vol_total + call MPI_ALLREDUCE(myEPSp,EPSp,1,MPI_REAL_WP,MPI_SUM,this%fs%cfg%comm,ierr); EPSp=EPSp*this%visc/this%fs%cfg%vol_total + A=(EPSp-this%forcing*(this%tke-this%tke_tgt)/this%tau_tgt)/(2.0_WP*this%tke) + this%resU=this%resU+A*this%time%dt*(this%fs%U-this%meanU) + this%resV=this%resV+A*this%time%dt*(this%fs%V-this%meanV) + this%resW=this%resW+A*this%time%dt*(this%fs%W-this%meanW) + end block hit_forcing + + ! Apply these residuals + this%fs%U=2.0_WP*this%fs%U-this%fs%Uold+this%resU + this%fs%V=2.0_WP*this%fs%V-this%fs%Vold+this%resV + this%fs%W=2.0_WP*this%fs%W-this%fs%Wold+this%resW + + ! Solve Poisson equation + call this%fs%get_div() + this%fs%psolv%rhs=-this%fs%cfg%vol*this%fs%div/this%time%dt + this%fs%psolv%sol=0.0_WP + call this%fs%psolv%solve() + call this%fs%shift_p(this%fs%psolv%sol) + + ! Correct velocity + call this%fs%get_pgrad(this%fs%psolv%sol,this%resU,this%resV,this%resW) + this%fs%P=this%fs%P+this%fs%psolv%sol + this%fs%U=this%fs%U-this%time%dt*this%resU + this%fs%V=this%fs%V-this%time%dt*this%resV + this%fs%W=this%fs%W-this%time%dt*this%resW + + ! Increment sub-iteration counter + this%time%it=this%time%it+1 + + end do + + ! Recompute divergence + call this%fs%get_div() + + ! Perform and output monitoring + call this%fs%get_max() + call this%compute_stats() + call this%mfile%write() + + ! Finally, see if it's time to save restart files + if (this%save_evt%occurs()) then + save_restart: block + use string, only: str_medium + character(len=str_medium) :: timestamp + ! Prefix for files + write(timestamp,'(es12.5)') this%time%t + ! Populate df and write it + call this%df%push(name='t' ,val=this%time%t ) + call this%df%push(name='dt',val=this%time%dt) + call this%df%push(name='U' ,var=this%fs%U ) + call this%df%push(name='V' ,var=this%fs%V ) + call this%df%push(name='W' ,var=this%fs%W ) + call this%df%push(name='P' ,var=this%fs%P ) + call this%df%write(fdata='restart/hit_'//trim(adjustl(timestamp))) + end block save_restart + end if + + end subroutine step + + + !> Finalize nozzle simulation + subroutine final(this) + implicit none + class(hit), intent(inout) :: this + + ! Deallocate work arrays + deallocate(this%resU,this%resV,this%resW,this%gradU,this%SR) + + end subroutine final + + +end module hit_class \ No newline at end of file diff --git a/examples/ljcf_dimensinal/src/ljcf_class.f90 b/examples/ljcf_dimensinal/src/ljcf_class.f90 new file mode 100644 index 000000000..63216c940 --- /dev/null +++ b/examples/ljcf_dimensinal/src/ljcf_class.f90 @@ -0,0 +1,883 @@ +!> Definition for a ljcf atomization class +module ljcf_class + use precision, only: WP + use config_class, only: config + use iterator_class, only: iterator + use ensight_class, only: ensight + use surfmesh_class, only: surfmesh + use hypre_str_class, only: hypre_str + !use ddadi_class, only: ddadi + use vfs_class, only: vfs + use tpns_class, only: tpns + use timetracker_class, only: timetracker + use event_class, only: event + use monitor_class, only: monitor + use timer_class, only: timer + use pardata_class, only: pardata + use cclabel_class, only: cclabel + use irl_fortran_interface + implicit none + private + + public :: ljcf + + integer :: ierr + + !> ljcf object + type :: ljcf + + !> Config + type(config) :: cfg + + !> Flow solver + type(vfs) :: vf !< Volume fraction solver + type(tpns) :: fs !< Two-phase flow solver + type(hypre_str) :: ps !< Structured Hypre linear solver for pressure + !type(ddadi) :: vs !< DDADI solver for velocity + type(timetracker) :: time !< Time info + type(cclabel) :: ccl !< CCLabel for local Weber number calculation + + !> Ensight postprocessing + type(surfmesh) :: smesh !< Surface mesh for interface + type(ensight) :: ens_out !< Ensight output for flow variables + type(event) :: ens_evt !< Event trigger for Ensight output + + !> Simulation monitor file + type(monitor) :: mfile !< General simulation monitoring + type(monitor) :: cflfile !< CFL monitoring + type(monitor) :: ljcf_file !< LJCF simulation monitoring + + !> Work arrays + real(WP), dimension(:,:,:), allocatable :: resU,resV,resW !< Residuals + real(WP), dimension(:,:,:), allocatable :: Ui,Vi,Wi !< Cell-centered velocities + + !> Iterator for VOF removal + type(iterator) :: vof_removal_layer !< Edge of domain where we actively remove VOF + real(WP) :: vof_removed !< Integral of VOF removed + integer :: nlayer=4 !< Size of buffer layer for VOF removal + + !> Timing info + type(monitor) :: timefile !< Timing monitoring + type(timer) :: tstep !< Timer for step + type(timer) :: tvel !< Timer for velocity + type(timer) :: tpres !< Timer for pressure + type(timer) :: tvof !< Timer for VOF + + !> Provide a pardata and an event tracker for saving restarts + type(event) :: save_evt + type(pardata) :: df + logical :: restarted + + !> Problem definition + real(WP) :: djet, Vjet + real(WP), dimension(:), allocatable :: xjet + integer :: relax_model, nwall + real(WP) :: gravity, endInjectionTime, InjectionVelocity + + contains + procedure :: init !< Initialize nozzle simulation + procedure :: step !< Advance nozzle simulation by one time step + procedure :: final !< Finalize nozzle simulation + end type ljcf + + +contains + + !> Initialization of ljcf simulation + subroutine init(this) + implicit none + class(ljcf), intent(inout) :: this + + ! Create the ljcf mesh + create_config: block + use sgrid_class, only: cartesian,sgrid + use param, only: param_read + use parallel, only: group + real(WP), dimension(:), allocatable :: x,y,z + integer, dimension(3) :: partition + type(sgrid) :: grid + integer :: i,j,k,nx,ny,nz + real(WP) :: Lx,Ly,Lz,xlig + ! Read in grid definition + call param_read('Lx',Lx); call param_read('nx',nx); allocate(x(nx+1)); call param_read('X ljcf',xlig) + 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-xlig + 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=3,x=x,y=y,z=z,xper=.false.,yper=.false.,zper=.true.,name='ljcf') + ! Read in partition + call param_read('Partition',partition,short='p') + ! Create partitioned grid without walls + this%cfg=config(grp=group,decomp=partition,grid=grid) + + end block create_config + + + ! Initialize time tracker with 2 subiterations + initialize_timetracker: block + use param, only: param_read + this%time=timetracker(amRoot=this%cfg%amRoot) + call param_read('Max timestep size',this%time%dtmax) + call param_read('Max cfl number',this%time%cflmax) + call param_read('Max time',this%time%tmax) + this%time%dt=this%time%dtmax + this%time%itmax=2 + end block initialize_timetracker + + + ! Allocate work arrays + allocate_work_arrays: block + allocate(this%resU(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + allocate(this%resV(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + allocate(this%resW(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + allocate(this%Ui (this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + allocate(this%Vi (this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + allocate(this%Wi (this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + end block allocate_work_arrays + + ! Set up walls before solvers are initialized + create_walls: block + use param, only: param_read,param_getsize + integer :: i,j,k,njet + ! Initialize liquid jet(s) + call param_read('Jet diameter',this%djet) + njet = param_getsize('Jet location') + allocate(this%xjet(njet)) + call param_read('Jet location',this%xjet) + call param_read('Gravitational acceleration',this%gravity) + call param_read('End Injection Time',this%endInjectionTime) + ! Number of wall cells + call param_read('Wall cells in domain', this%nwall, default=0) + 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 (wall(this%cfg%pgrid,i,j,k)) then + this%cfg%VF(i,j,k)=0.0_WP + end if + end do + end do + end do + end block create_walls + + ! Initialize our VOF solver and field + create_and_initialize_vof: block + use vfs_class, only: remap,VFlo,VFhi,plicnet,r2pnet + use mms_geom, only: cube_refine_vol + use param, only: param_read + integer :: i,j,k,n,si,sj,sk + real(WP), dimension(3,8) :: cube_vertex + real(WP), dimension(3) :: v_cent,a_cent + real(WP) :: vol,area + integer, parameter :: amr_ref_lvl=4 + ! Create a VOF solver + call this%vf%initialize(cfg=this%cfg,reconstruction_method=r2pnet,transport_method=remap,name='VOF') + this%vf%thin_thld_min=0.0_WP + this%vf%flotsam_thld=0.0_WP + this%vf%maxcurv_times_mesh=1.0_WP + ! Initialize the interface to a ljcf + do k=this%vf%cfg%kmino_,this%vf%cfg%kmaxo_ + do j=this%vf%cfg%jmino_,this%vf%cfg%jmaxo_ + do i=this%vf%cfg%imino_,this%vf%cfg%imaxo_ + ! Set cube vertices + n=0 + do sk=0,1 + do sj=0,1 + do si=0,1 + n=n+1; cube_vertex(:,n)=[this%vf%cfg%x(i+si),this%vf%cfg%y(j+sj),this%vf%cfg%z(k+sk)] + end do + end do + end do + ! Call adaptive refinement code to get volume and barycenters recursively + vol=0.0_WP; area=0.0_WP; v_cent=0.0_WP; a_cent=0.0_WP + if (j.lt.this%vf%cfg%jmin) then + call cube_refine_vol(cube_vertex,vol,area,v_cent,a_cent,levelset_halfdrop,0.0_WP,amr_ref_lvl) + else + ! do nothing + end if + this%vf%VF(i,j,k)=vol/this%vf%cfg%vol(i,j,k) + if (this%vf%VF(i,j,k).ge.VFlo.and.this%vf%VF(i,j,k).le.VFhi) then + this%vf%Lbary(:,i,j,k)=v_cent + this%vf%Gbary(:,i,j,k)=([this%vf%cfg%xm(i),this%vf%cfg%ym(j),this%vf%cfg%zm(k)]-this%vf%VF(i,j,k)*this%vf%Lbary(:,i,j,k))/(1.0_WP-this%vf%VF(i,j,k)) + else + this%vf%Lbary(:,i,j,k)=[this%vf%cfg%xm(i),this%vf%cfg%ym(j),this%vf%cfg%zm(k)] + this%vf%Gbary(:,i,j,k)=[this%vf%cfg%xm(i),this%vf%cfg%ym(j),this%vf%cfg%zm(k)] + end if + end do + end do + end do + ! Update the band + call this%vf%update_band() + ! Perform interface reconstruction from VOF field + call this%vf%build_interface() + ! Set interface planes at the boundaries + call this%vf%set_full_bcond() + ! Now apply Neumann condition on interface at inlet to have proper round injection + neumann_irl: block + use irl_fortran_interface, only: getPlane,new,construct_2pt,RectCub_type,& + & setNumberOfPlanes,setPlane,matchVolumeFraction + real(WP), dimension(1:4) :: plane + type(RectCub_type) :: cell + call new(cell) + if (this%vf%cfg%iproc.eq.1) then + do k=this%vf%cfg%kmino_,this%vf%cfg%kmaxo_ + do j=this%vf%cfg%jmino_,this%vf%cfg%jmaxo_ + do i=this%vf%cfg%imino,this%vf%cfg%imin-1 + ! Extract plane data and copy in overlap + plane=getPlane(this%vf%liquid_gas_interface(this%vf%cfg%imin,j,k),0) + call construct_2pt(cell,[this%vf%cfg%x(i ),this%vf%cfg%y(j ),this%vf%cfg%z(k )],& + & [this%vf%cfg%x(i+1),this%vf%cfg%y(j+1),this%vf%cfg%z(k+1)]) + plane(4)=dot_product(plane(1:3),[this%vf%cfg%xm(i),this%vf%cfg%ym(j),this%vf%cfg%zm(k)]) + call setNumberOfPlanes(this%vf%liquid_gas_interface(i,j,k),1) + call setPlane(this%vf%liquid_gas_interface(i,j,k),0,plane(1:3),plane(4)) + call matchVolumeFraction(cell,this%vf%VF(i,j,k),this%vf%liquid_gas_interface(i,j,k)) + end do + end do + end do + end if + end block neumann_irl + ! Create discontinuous polygon mesh from IRL interface + call this%vf%polygonalize_interface() + ! Calculate distance from polygons + call this%vf%distance_from_polygon() + ! Calculate subcell phasic volumes + call this%vf%subcell_vol() + ! Calculate curvature + call this%vf%get_curvature() + ! Reset moments to guarantee compatibility with interface reconstruction + call this%vf%reset_volume_moments() + end block create_and_initialize_vof + + + ! Create an iterator for removing VOF at edges + create_iterator: block + this%vof_removal_layer=iterator(this%cfg,'VOF removal',vof_removal_layer_locator) + end block create_iterator + + + ! Create a multiphase flow solver with bconds + create_flow_solver: block + use mathtools, only: Pi + use param, only: param_read + use tpns_class, only: dirichlet,clipped_neumann,bcond + use hypre_str_class, only: pcg_pfmg2 + type(bcond), pointer :: mybc + integer :: n,i,j,k + ! Create flow solver + this%fs=tpns(cfg=this%cfg,name='Two-phase NS') + ! Set fluid properties + call param_read("Liquid density",this%fs%rho_l); + call param_read("Gas density",this%fs%rho_g); + call param_read("Liquid viscosity",this%fs%visc_l); + call param_read("Gas viscosity",this%fs%visc_g); + call param_read("Surface tension",this%fs%sigma); + + ! Define inflow boundary condition on the left + call this%fs%add_bcond(name='inflow',type=dirichlet,face='x',dir=-1,canCorrect=.false.,locator=xm_locator) + ! Define outflow boundary condition on the right + call this%fs%add_bcond(name='outflow',type=clipped_neumann,face='x',dir=+1,canCorrect=.true.,locator=xp_locator) + ! Define jet boundary condition on the bottom + call this%fs%add_bcond(name='jet' ,type=dirichlet,face='y',dir=-1,canCorrect=.false.,locator=jet_bdy) + ! Define gravity as vector for flow solver + this%fs%gravity(2) = this%gravity + + ! Configure pressure solver + this%ps=hypre_str(cfg=this%cfg,name='Pressure',method=pcg_pfmg2,nst=7) + this%ps%maxlevel=16 + call param_read('Pressure iteration',this%ps%maxit) + call param_read('Pressure tolerance',this%ps%rcvg) + ! Configure implicit velocity solver + !this%vs=ddadi(cfg=this%cfg,name='Velocity',nst=7) + ! Setup the solver + call this%fs%setup(pressure_solver=this%ps)!,implicit_solver=this%vs) + ! Zero initial field + this%fs%U=0.0_WP; this%fs%V=0.0_WP; this%fs%W=0.0_WP + ! Apply convective velocity + call this%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) + this%fs%U(i,j,k)=1.0_WP + end do + ! Apply jet velocity + call this%fs%get_bcond('jet',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) + this%fs%V(i,j,k)=0 ! Start with zero velocity this%Vjet + end do + ! Apply all other boundary conditions + call this%fs%apply_bcond(this%time%t,this%time%dt) + ! Adjust MFR for global mass balance + call this%fs%correct_mfr() + ! Compute divergence + call this%fs%get_div() + ! Compute cell-centered velocity + call this%fs%interp_vel(this%Ui,this%Vi,this%Wi) + end block create_flow_solver + + ! Create CCL + create_ccl: block + ! Initialize CCL + call this%ccl%initialize(pg=this%cfg%pgrid,name='ccl') + end block create_ccl + + ! Handle restart/saves here + handle_restart: block + use param, only: param_read + use string, only: str_medium + use filesys, only: makedir,isdir + use irl_fortran_interface, only: setNumberOfPlanes,setPlane + character(len=str_medium) :: timestamp + integer, dimension(3) :: iopartition + real(WP), dimension(:,:,:), allocatable :: P11,P12,P13,P14 + real(WP), dimension(:,:,:), allocatable :: P21,P22,P23,P24 + integer :: i,j,k + ! Create event for saving restart files + this%save_evt=event(this%time,'Restart output') + call param_read('Restart output period',this%save_evt%tper) + ! Check if we are restarting + call param_read('Restart from',timestamp,default='') + this%restarted=.false.; if (len_trim(timestamp).gt.0) this%restarted=.true. + ! Read in the I/O partition + call param_read('I/O partition',iopartition) + ! Perform pardata initialization + if (this%restarted) then + ! Read in the file + call this%df%initialize(pg=this%cfg,iopartition=iopartition,fdata='restart/data_'//trim(timestamp)) + ! Read in the planes directly and set the IRL interface + allocate(P11(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)); call this%df%pull(name='P11',var=P11) + allocate(P12(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)); call this%df%pull(name='P12',var=P12) + allocate(P13(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)); call this%df%pull(name='P13',var=P13) + allocate(P14(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)); call this%df%pull(name='P14',var=P14) + allocate(P21(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)); call this%df%pull(name='P21',var=P21) + allocate(P22(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)); call this%df%pull(name='P22',var=P22) + allocate(P23(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)); call this%df%pull(name='P23',var=P23) + allocate(P24(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)); call this%df%pull(name='P24',var=P24) + do k=this%vf%cfg%kmin_,this%vf%cfg%kmax_ + do j=this%vf%cfg%jmin_,this%vf%cfg%jmax_ + do i=this%vf%cfg%imin_,this%vf%cfg%imax_ + ! Check if the second plane is meaningful + if (this%vf%two_planes.and.P21(i,j,k)**2+P22(i,j,k)**2+P23(i,j,k)**2.gt.0.0_WP) then + call setNumberOfPlanes(this%vf%liquid_gas_interface(i,j,k),2) + call setPlane(this%vf%liquid_gas_interface(i,j,k),0,[P11(i,j,k),P12(i,j,k),P13(i,j,k)],P14(i,j,k)) + call setPlane(this%vf%liquid_gas_interface(i,j,k),1,[P21(i,j,k),P22(i,j,k),P23(i,j,k)],P24(i,j,k)) + else + call setNumberOfPlanes(this%vf%liquid_gas_interface(i,j,k),1) + call setPlane(this%vf%liquid_gas_interface(i,j,k),0,[P11(i,j,k),P12(i,j,k),P13(i,j,k)],P14(i,j,k)) + end if + end do + end do + end do + call this%vf%sync_interface() + deallocate(P11,P12,P13,P14,P21,P22,P23,P24) + ! Reset moments + call this%vf%reset_volume_moments() + ! Update the band + call this%vf%update_band() + ! Create discontinuous polygon mesh from IRL interface + call this%vf%polygonalize_interface() + ! Calculate distance from polygons + call this%vf%distance_from_polygon() + ! Calculate subcell phasic volumes + call this%vf%subcell_vol() + ! Calculate curvature + call this%vf%get_curvature() + ! Now read in the velocity solver data + call this%df%pull(name='U',var=this%fs%U) + call this%df%pull(name='V',var=this%fs%V) + call this%df%pull(name='W',var=this%fs%W) + call this%df%pull(name='P',var=this%fs%P) + call this%df%pull(name='Pjx',var=this%fs%Pjx) + call this%df%pull(name='Pjy',var=this%fs%Pjy) + call this%df%pull(name='Pjz',var=this%fs%Pjz) + ! Apply all other boundary conditions + call this%fs%apply_bcond(this%time%t,this%time%dt) + ! Compute MFR through all boundary conditions + call this%fs%get_mfr() + ! Adjust MFR for global mass balance + call this%fs%correct_mfr() + ! Compute cell-centered velocity + call this%fs%interp_vel(this%Ui,this%Vi,this%Wi) + ! Compute divergence + call this%fs%get_div() + ! Also update time + call this%df%pull(name='t' ,val=this%time%t ) + call this%df%pull(name='dt',val=this%time%dt) + this%time%told=this%time%t-this%time%dt + !this%time%dt=this%time%dtmax !< Force max timestep size anyway + else + ! We are not restarting, prepare a new directory for storing restart files + if (this%cfg%amRoot) then + if (.not.isdir('restart')) call makedir('restart') + end if + ! Prepare pardata object for saving restart files + call this%df%initialize(pg=this%cfg,iopartition=iopartition,filename=trim(this%cfg%name),nval=2,nvar=15) + this%df%valname=['t ','dt'] + this%df%varname=['U ','V ','W ','P ','Pjx','Pjy','Pjz','P11','P12','P13','P14','P21','P22','P23','P24'] + end if + end block handle_restart + + + ! Create surfmesh object for interface polygon output + create_smesh: block + use irl_fortran_interface, only: getNumberOfPlanes,getNumberOfVertices + integer :: i,j,k,np,nplane + this%smesh=surfmesh(nvar=2,name='plic') + this%smesh%varname(1)='nplane' + this%smesh%varname(2)='thickness' + ! Transfer polygons to smesh + call this%vf%update_surfmesh(this%smesh) + ! Calculate thickness + call this%vf%get_thickness() + ! Populate nplane and thickness variables + this%smesh%var(1,:)=1.0_WP + np=0 + do k=this%vf%cfg%kmin_,this%vf%cfg%kmax_ + do j=this%vf%cfg%jmin_,this%vf%cfg%jmax_ + do i=this%vf%cfg%imin_,this%vf%cfg%imax_ + if (this%cfg%VF(i,j,k).lt.2.0_WP*epsilon(1.0_WP)) cycle ! Skip cells below VF threshold + do nplane=1,getNumberOfPlanes(this%vf%liquid_gas_interface(i,j,k)) + if (getNumberOfVertices(this%vf%interface_polygon(nplane,i,j,k)).gt.0) then + np=np+1; this%smesh%var(1,np)=real(getNumberOfPlanes(this%vf%liquid_gas_interface(i,j,k)),WP) + this%smesh%var(2,np)=this%vf%thickness(i,j,k) + end if + end do + end do + end do + end do + end block create_smesh + + + ! Add Ensight output + create_ensight: block + use param, only: param_read + ! Create Ensight output from cfg + this%ens_out=ensight(cfg=this%cfg,name='ljcf') + ! Create event for Ensight output + this%ens_evt=event(time=this%time,name='Ensight output') + call param_read('Ensight output period',this%ens_evt%tper) + ! Add variables to output + call this%ens_out%add_vector('velocity',this%Ui,this%Vi,this%Wi) + call this%ens_out%add_scalar('VOF',this%vf%VF) + call this%ens_out%add_scalar('curvature',this%vf%curv) + call this%ens_out%add_scalar('pressure',this%fs%P) + call this%ens_out%add_surface('plic',this%smesh) + ! Output to ensight + if (this%ens_evt%occurs()) call this%ens_out%write_data(this%time%t) + end block create_ensight + + + ! Create a monitor file + create_monitor: block + ! Prepare some info about fields + call this%fs%get_cfl(this%time%dt,this%time%cfl) + call this%fs%get_max() + call this%vf%get_max() + ! Create simulation monitor + this%mfile=monitor(this%fs%cfg%amRoot,'simulation_atom') + call this%mfile%add_column(this%time%n,'Timestep number') + call this%mfile%add_column(this%time%t,'Time') + call this%mfile%add_column(this%time%dt,'Timestep size') + call this%mfile%add_column(this%time%cfl,'Maximum CFL') + call this%mfile%add_column(this%fs%Umax,'Umax') + call this%mfile%add_column(this%fs%Vmax,'Vmax') + call this%mfile%add_column(this%fs%Wmax,'Wmax') + call this%mfile%add_column(this%fs%Pmax,'Pmax') + call this%mfile%add_column(this%vf%VFint,'VOF integral') + call this%mfile%add_column(this%vf%SDint,'SD integral') + call this%mfile%add_column(this%vof_removed,'VOF removed') + call this%mfile%add_column(this%vf%flotsam_error,'Flotsam error') + call this%mfile%add_column(this%vf%thinstruct_error,'Film error') + call this%mfile%add_column(this%fs%divmax,'Maximum divergence') + call this%mfile%add_column(this%fs%psolv%it,'Pressure iteration') + call this%mfile%add_column(this%fs%psolv%rerr,'Pressure error') + call this%mfile%write() + ! Create CFL monitor + this%cflfile=monitor(this%fs%cfg%amRoot,'cfl_atom') + call this%cflfile%add_column(this%time%n,'Timestep number') + call this%cflfile%add_column(this%time%t,'Time') + call this%cflfile%add_column(this%fs%CFLst,'STension CFL') + call this%cflfile%add_column(this%fs%CFLc_x,'Convective xCFL') + call this%cflfile%add_column(this%fs%CFLc_y,'Convective yCFL') + call this%cflfile%add_column(this%fs%CFLc_z,'Convective zCFL') + call this%cflfile%add_column(this%fs%CFLv_x,'Viscous xCFL') + call this%cflfile%add_column(this%fs%CFLv_y,'Viscous yCFL') + call this%cflfile%add_column(this%fs%CFLv_z,'Viscous zCFL') + call this%cflfile%write() + ! Create LJCF monitor + this%ljcf_file=monitor(this%fs%cfg%amRoot,'ljcf') + call this%ljcf_file%add_column(this%time%n,'Timestep number') + call this%ljcf_file%add_column(this%time%t,'Time') + call this%ljcf_file%add_column(this%InjectionVelocity,'Injection Velocity') + call this%ljcf_file%write() + end block create_monitor + + + ! Create a timing monitor + create_timing: block + ! Create timers + this%tstep =timer(comm=this%cfg%comm,name='Timestep') + this%tvof =timer(comm=this%cfg%comm,name='VOFsolve') + this%tvel =timer(comm=this%cfg%comm,name='Velocity') + this%tpres =timer(comm=this%cfg%comm,name='Pressure') + ! Create corresponding monitor file + this%timefile=monitor(this%fs%cfg%amRoot,'timing') + call this%timefile%add_column(this%time%n,'Timestep number') + call this%timefile%add_column(this%time%t,'Time') + call this%timefile%add_column(this%tstep%time ,trim(this%tstep%name)) + call this%timefile%add_column(this%tvof%time ,trim(this%tvof%name)) + call this%timefile%add_column(this%tvel%time ,trim(this%tvel%name)) + call this%timefile%add_column(this%tpres%time ,trim(this%tpres%name)) + end block create_timing + + contains + + + !> Function that localizes the x- boundary + function xm_locator(pg,i,j,k) result(isIn) + use pgrid_class, only: pgrid + class(pgrid), intent(in) :: pg + integer, intent(in) :: i,j,k + logical :: isIn + isIn=.false. + if (i.eq.pg%imin) isIn=.true. + end function xm_locator + + + !> Function that localizes the x+ boundary + function xp_locator(pg,i,j,k) result(isIn) + use pgrid_class, only: pgrid + 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 xp_locator + + + !> Function that localizes region of VOF removal + function vof_removal_layer_locator(pg,i,j,k) result(isIn) + use pgrid_class, only: pgrid + class(pgrid), intent(in) :: pg + integer, intent(in) :: i,j,k + logical :: isIn + isIn=.false. + if (i.ge.pg%imax-this%nlayer) isIn=.true. + end function vof_removal_layer_locator + + + !> Function that defines a level set function for a half droplet + function levelset_halfdrop(xyz,t) result(G) + implicit none + real(WP), dimension(3),intent(in) :: xyz + real(WP), intent(in) :: t + real(WP) :: G + G=0.5_WP*this%djet-sqrt(xyz(1)**2+(xyz(2)-this%cfg%y(this%cfg%jmin))**2+xyz(3)**2) + end function levelset_halfdrop + + !> Function that localizes the jet(s) initial location + function jet(pg,i,j,k) result(isIn) + use pgrid_class, only: pgrid + implicit none + class(pgrid), intent(in) :: pg + integer, intent(in) :: i,j,k + real(WP), dimension(3) :: xyz + logical :: isIn + isIn=.false. + xyz(1)=pg%xm(i); xyz(2)=pg%ym(j); xyz(3)=pg%zm(k) + if (levelset_halfdrop(xyz,0.0_WP).gt.0.0_WP) isIn=.true. + end function jet + + !> Function that localizes the walls surrounding the jets + function wall(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 (j.le.pg%jmin-1+this%nwall.and.(.not.jet(pg,i,j,k))) isIn=.true. + end function wall + + !> Function that localizes the jet(s) BCs at edge of domain + function jet_bdy(pg,i,j,k) result(isIn) + use pgrid_class, only: pgrid + implicit none + class(pgrid), intent(in) :: pg + integer, intent(in) :: i,j,k + real(WP), dimension(3) :: xyz + logical :: isIn + isIn=.false. + xyz(1)=pg%xm(i); xyz(2)=pg%y(j); xyz(3)=pg%zm(k) + if (j.eq.pg%jmin.and.jet(pg,i,j,k)) isIn=.true. + end function jet_bdy + + + end subroutine init + + + !> Take one time step + subroutine step(this) + use tpns_class, only: arithmetic_visc + implicit none + class(ljcf), intent(inout) :: this + + ! Reset all timers and start timestep timer + call this%tstep%reset() + call this%tvof%reset() + call this%tvel%reset() + call this%tpres%reset() + call this%tstep%start() + + ! Increment time + call this%fs%get_cfl(this%time%dt,this%time%cfl) + call this%time%adjust_dt() + call this%time%increment() + + ! Apply jet velocity + apply_bc: block + use tpns_class, only: bcond + use mpi_f08, only: MPI_ALLREDUCE,MPI_SUM,MPI_IN_PLACE + use parallel, only: MPI_REAL_WP + type(bcond), pointer :: mybc + real(WP) :: liqVolInjected_dt + integer :: n,i,j,k + ! Compute injection velocity + if (this%time%t .lt. this%endInjectionTime) then + this%InjectionVelocity=this%gravity*this%time%t ! Velocity increases linearly with time + else + this%InjectionVelocity=0.0_WP ! Velocity stops once volume is reached + end if + ! Apply injection velocity to the jet boundary condition + call this%fs%get_bcond('jet',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) + this%fs%V(i,j,k) = this%InjectionVelocity + end do + end block apply_bc + + ! Remember old VOF + this%vf%VFold=this%vf%VF + + ! Remember old velocity + this%fs%Uold=this%fs%U + this%fs%Vold=this%fs%V + this%fs%Wold=this%fs%W + + ! Prepare old sflaggered density (at n) + call this%fs%get_olddensity(vf=this%vf) + + ! VOF solver step + call this%tvof%start() ! Start VOF timer + call this%vf%advance(dt=this%time%dt,U=this%fs%U,V=this%fs%V,W=this%fs%W) + call this%tvof%stop() ! Stop VOF timer + + ! Prepare new sflaggered viscosity (at n+1) + call this%fs%get_viscosity(vf=this%vf,strat=arithmetic_visc) + + ! Perform sub-iterations + do while (this%time%it.le.this%time%itmax) + + ! Start velocity timer + call this%tvel%start() + + ! Build mid-time velocity + this%fs%U=0.5_WP*(this%fs%U+this%fs%Uold) + this%fs%V=0.5_WP*(this%fs%V+this%fs%Vold) + this%fs%W=0.5_WP*(this%fs%W+this%fs%Wold) + + ! Preliminary mass and momentum transport step at the interface + call this%fs%prepare_advection_upwind(dt=this%time%dt) + + ! Explicit calculation of drho*u/dt from NS + call this%fs%get_dmomdt(this%resU,this%resV,this%resW) + + ! Assemble explicit residual + this%resU=-2.0_WP*this%fs%rho_U*this%fs%U+(this%fs%rho_Uold+this%fs%rho_U)*this%fs%Uold+this%time%dt*this%resU + this%resV=-2.0_WP*this%fs%rho_V*this%fs%V+(this%fs%rho_Vold+this%fs%rho_V)*this%fs%Vold+this%time%dt*this%resV + this%resW=-2.0_WP*this%fs%rho_W*this%fs%W+(this%fs%rho_Wold+this%fs%rho_W)*this%fs%Wold+this%time%dt*this%resW + + ! Form implicit residuals + call this%fs%solve_implicit(this%time%dt,this%resU,this%resV,this%resW) + + ! Apply these residuals + this%fs%U=2.0_WP*this%fs%U-this%fs%Uold+this%resU + this%fs%V=2.0_WP*this%fs%V-this%fs%Vold+this%resV + this%fs%W=2.0_WP*this%fs%W-this%fs%Wold+this%resW + + ! Apply boundary conditions + call this%fs%apply_bcond(this%time%t,this%time%dt) + + ! Stop velocity timer and start pressure timer + call this%tvel%stop() + call this%tpres%start() + + ! Solve Poisson equation + call this%fs%update_laplacian() + call this%fs%correct_mfr() + call this%fs%get_div() + !call this%fs%add_surface_tension_jump(dt=this%time%dt,div=this%fs%div,vf=this%vf) + call this%fs%add_surface_tension_jump_twoVF(dt=this%time%dt,div=this%fs%div,vf=this%vf) + this%fs%psolv%rhs=-this%fs%cfg%vol*this%fs%div/this%time%dt + this%fs%psolv%sol=0.0_WP + call this%fs%psolv%solve() + call this%fs%shift_p(this%fs%psolv%sol) + + ! Correct velocity + call this%fs%get_pgrad(this%fs%psolv%sol,this%resU,this%resV,this%resW) + this%fs%P=this%fs%P+this%fs%psolv%sol + this%fs%U=this%fs%U-this%time%dt*this%resU/max(epsilon(0.0_WP),this%fs%rho_U) + this%fs%V=this%fs%V-this%time%dt*this%resV/max(epsilon(0.0_WP),this%fs%rho_V) + this%fs%W=this%fs%W-this%time%dt*this%resW/max(epsilon(0.0_WP),this%fs%rho_W) + + ! Apply boundary conditions + call this%fs%apply_bcond(this%time%t,this%time%dt) + + ! Stop pressure timer + call this%tpres%stop() + + ! Increment sub-iteration counter + this%time%it=this%time%it+1 + + end do + + ! Recompute interpolated velocity and divergence + call this%fs%interp_vel(this%Ui,this%Vi,this%Wi) + call this%fs%get_div() + + ! Remove VOF at edge of domain + remove_vof: block + use mpi_f08, only: MPI_ALLREDUCE,MPI_SUM,MPI_IN_PLACE + use parallel, only: MPI_REAL_WP + integer :: n,i,j,k,ierr + this%vof_removed=0.0_WP + do n=1,this%vof_removal_layer%no_ + i=this%vof_removal_layer%map(1,n) + j=this%vof_removal_layer%map(2,n) + k=this%vof_removal_layer%map(3,n) + if (n.le.this%vof_removal_layer%n_) this%vof_removed=this%vof_removed+this%cfg%vol(i,j,k)*this%vf%VF(i,j,k) + this%vf%VF(i,j,k)=0.0_WP + end do + call MPI_ALLREDUCE(MPI_IN_PLACE,this%vof_removed,1,MPI_REAL_WP,MPI_SUM,this%cfg%comm,ierr) + call this%vf%clean_irl_and_band() + end block remove_vof + + ! Output to ensight + if (this%ens_evt%occurs()) then + ! Update surface mesh + update_smesh: block + use irl_fortran_interface, only: getNumberOfPlanes,getNumberOfVertices + integer :: i,j,k,np,nplane + ! Transfer polygons to smesh + call this%vf%update_surfmesh(this%smesh) + ! Also populate nplane variable + this%smesh%var(1,:)=1.0_WP + np=0 + do k=this%vf%cfg%kmin_,this%vf%cfg%kmax_ + do j=this%vf%cfg%jmin_,this%vf%cfg%jmax_ + do i=this%vf%cfg%imin_,this%vf%cfg%imax_ + if (this%cfg%VF(i,j,k).lt.2.0_WP*epsilon(1.0_WP)) cycle ! Skip cells below VF threshold + do nplane=1,getNumberOfPlanes(this%vf%liquid_gas_interface(i,j,k)) + if (getNumberOfVertices(this%vf%interface_polygon(nplane,i,j,k)).gt.0) then + np=np+1; this%smesh%var(1,np)=real(getNumberOfPlanes(this%vf%liquid_gas_interface(i,j,k)),WP) + this%smesh%var(2,np)=this%vf%thickness(i,j,k) + end if + end do + end do + end do + end do + end block update_smesh + call this%ens_out%write_data(this%time%t) + end if + + ! Stop timestep timer + call this%tstep%stop() + + ! Perform and output monitoring + call this%fs%get_max() + call this%vf%get_max() + call this%mfile%write() + call this%cflfile%write() + call this%timefile%write() + call this%ljcf_file%write() + + ! Finally, see if it's time to save restart files + if (this%save_evt%occurs()) then + save_restart: block + use irl_fortran_interface + use string, only: str_medium + character(len=str_medium) :: timestamp + real(WP), dimension(:,:,:), allocatable :: P11,P12,P13,P14 + real(WP), dimension(:,:,:), allocatable :: P21,P22,P23,P24 + integer :: i,j,k + real(WP), dimension(4) :: plane + ! Handle IRL data + allocate(P11(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + allocate(P12(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + allocate(P13(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + allocate(P14(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + allocate(P21(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + allocate(P22(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + allocate(P23(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + allocate(P24(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + do k=this%vf%cfg%kmino_,this%vf%cfg%kmaxo_ + do j=this%vf%cfg%jmino_,this%vf%cfg%jmaxo_ + do i=this%vf%cfg%imino_,this%vf%cfg%imaxo_ + ! First plane + plane=getPlane(this%vf%liquid_gas_interface(i,j,k),0) + P11(i,j,k)=plane(1); P12(i,j,k)=plane(2); P13(i,j,k)=plane(3); P14(i,j,k)=plane(4) + ! Second plane + plane=0.0_WP + if (getNumberOfPlanes(this%vf%liquid_gas_interface(i,j,k)).eq.2) plane=getPlane(this%vf%liquid_gas_interface(i,j,k),1) + P21(i,j,k)=plane(1); P22(i,j,k)=plane(2); P23(i,j,k)=plane(3); P24(i,j,k)=plane(4) + end do + end do + end do + ! Prefix for files + write(timestamp,'(es12.5)') this%time%t + ! Populate df and write it + call this%df%push(name='t' ,val=this%time%t ) + call this%df%push(name='dt' ,val=this%time%dt) + call this%df%push(name='U' ,var=this%fs%U ) + call this%df%push(name='V' ,var=this%fs%V ) + call this%df%push(name='W' ,var=this%fs%W ) + call this%df%push(name='P' ,var=this%fs%P ) + call this%df%push(name='Pjx',var=this%fs%Pjx ) + call this%df%push(name='Pjy',var=this%fs%Pjy ) + call this%df%push(name='Pjz',var=this%fs%Pjz ) + call this%df%push(name='P11',var=P11 ) + call this%df%push(name='P12',var=P12 ) + call this%df%push(name='P13',var=P13 ) + call this%df%push(name='P14',var=P14 ) + call this%df%push(name='P21',var=P21 ) + call this%df%push(name='P22',var=P22 ) + call this%df%push(name='P23',var=P23 ) + call this%df%push(name='P24',var=P24 ) + call this%df%write(fdata='restart/data_'//trim(adjustl(timestamp))) + ! Deallocate + deallocate(P11,P12,P13,P14,P21,P22,P23,P24) + end block save_restart + end if + + end subroutine step + + + !> Finalize nozzle simulation + subroutine final(this) + implicit none + class(ljcf), intent(inout) :: this + + ! Deallocate work arrays + deallocate(this%resU,this%resV,this%resW,this%Ui,this%Vi,this%Wi) + + end subroutine final + + +end module ljcf_class \ No newline at end of file diff --git a/examples/ljcf_dimensinal/src/simulation.f90 b/examples/ljcf_dimensinal/src/simulation.f90 new file mode 100644 index 000000000..15af0a094 --- /dev/null +++ b/examples/ljcf_dimensinal/src/simulation.f90 @@ -0,0 +1,161 @@ +!> Various definitions and tools for running an NGA2 simulation +module simulation + use precision, only: WP + use hit_class, only: hit + use ljcf_class, only: ljcf + use coupler_class, only: coupler + implicit none + private + + !> HIT simulation + type(hit) :: turb + logical :: isInHITGrp + + !> LJCF atomization simulation + type(ljcf) :: atom + + !> Coupler from turb to atom + type(coupler) :: xcpl,ycpl,zcpl + + public :: simulation_init,simulation_run,simulation_final + +contains + + + !> Initialization of our simulation + subroutine simulation_init + use mpi_f08, only: MPI_Group + implicit none + type(MPI_Group) :: hit_group + + ! Initialize atomization simulation + call atom%init() + + ! Create an MPI group using leftmost processors only + create_hit_group: block + use parallel, only: group,comm + use mpi_f08, only: MPI_Group_incl + integer, dimension(:), allocatable :: ranks + integer, dimension(3) :: coord + integer :: n,ngrp,ierr,ny,nz + ngrp=atom%cfg%npy*atom%cfg%npz + allocate(ranks(ngrp)) + ngrp=0 + do nz=1,atom%cfg%npz + do ny=1,atom%cfg%npy + ngrp=ngrp+1 + coord=[0,ny-1,nz-1] + call MPI_CART_RANK(atom%cfg%comm,coord,ranks(ngrp),ierr) + end do + end do + call MPI_Group_incl(group,ngrp,ranks,hit_group,ierr) + if (atom%cfg%iproc.eq.1) then + isInHITGrp=.true. + else + isInHITGrp=.false. + end if + end block create_hit_group + + ! Initialize HIT simulation + if (isInHITGrp) call turb%init(group=hit_group,xend=atom%cfg%x(atom%cfg%imin)) + + ! If restarting, the domains could be out of sync, so resync + ! time by forcing HIT to be at same time as jet + if (isInHITGrp) then + turb%time%t=atom%time%t + turb%time%told=turb%time%t-turb%time%dt + end if + + ! Initialize couplers from turb to atom + create_coupler: block + use parallel, only: group + xcpl=coupler(src_grp=hit_group,dst_grp=group,name='turb2atom') + ycpl=coupler(src_grp=hit_group,dst_grp=group,name='turb2atom') + zcpl=coupler(src_grp=hit_group,dst_grp=group,name='turb2atom') + if (isInHITGrp) call xcpl%set_src(turb%cfg,'x') + if (isInHITGrp) call ycpl%set_src(turb%cfg,'y') + if (isInHITGrp) call zcpl%set_src(turb%cfg,'z') + call xcpl%set_dst(atom%cfg,'x'); call xcpl%initialize() + call ycpl%set_dst(atom%cfg,'y'); call ycpl%initialize() + call zcpl%set_dst(atom%cfg,'z'); call zcpl%initialize() + end block create_coupler + + end subroutine simulation_init + + + !> Run the simulation + subroutine simulation_run + implicit none + + ! Atomization drives overall time integration + do while (.not.atom%time%done()) + + ! Advance HIT simulation and transfer velocity info + if (isInHITGrp) then + ! Advance HIT with maximum stable dt until caught up + advance_hit: block + real(WP) :: dt + dt=0.15_WP*turb%cfg%min_meshsize/turb%Urms_tgt + do while (turb%time%t.le.atom%time%t) + call turb%step(dt) + end do + end block advance_hit + end if + + ! Handle coupling between HIT and atomization simulation + coupling: block + ! Push data from HIT simulation + if (isInHITGrp) then + push_velocity: block + real(WP) :: rescaling,tinterp + rescaling=turb%ti/turb%Urms_tgt + tinterp=(turb%time%t-atom%time%t)/(turb%time%t-turb%time%told) + turb%resU=rescaling*((1.0_WP-tinterp)*turb%fs%U+tinterp*turb%fs%Uold); call xcpl%push(turb%resU) + turb%resV=rescaling*((1.0_WP-tinterp)*turb%fs%V+tinterp*turb%fs%Vold); call ycpl%push(turb%resV) + turb%resW=rescaling*((1.0_WP-tinterp)*turb%fs%W+tinterp*turb%fs%Wold); call zcpl%push(turb%resW) + end block push_velocity + end if + ! Transfer and pull + call xcpl%transfer(); call xcpl%pull(atom%resU) + call ycpl%transfer(); call ycpl%pull(atom%resV) + call zcpl%transfer(); call zcpl%pull(atom%resW) + ! Apply time-dependent Dirichlet condition + apply_boundary_condition: block + use param, only: param_read + use tpns_class, only: bcond + type(bcond), pointer :: mybc + integer :: n,i,j,k + real(WP) :: air_vel + call atom%fs%get_bcond('inflow',mybc) + call param_read("Air velocity",air_vel) + do n=1,mybc%itr%no_ + i=mybc%itr%map(1,n); j=mybc%itr%map(2,n); k=mybc%itr%map(3,n) + atom%fs%U(i ,j,k)=air_vel !atom%resU(i ,j,k)+1.0_WP + atom%fs%V(i-1,j,k)=0.0_WP !atom%resV(i-1,j,k) + atom%fs%W(i-1,j,k)=0.0_WP !atom%resW(i-1,j,k) + end do + end block apply_boundary_condition + end block coupling + + ! Advance atomization simulation + call atom%step() + + end do + + end subroutine simulation_run + + + !> Finalize the NGA2 simulation + subroutine simulation_final + implicit none + + ! Finalize atomization simulation + call atom%final() + + ! Finalize HIT simulation + if (isInHITGrp) call turb%final() + + end subroutine simulation_final + + +end module simulation \ No newline at end of file From 908194bb7646f136fe7db95bbb47fd917aa1be3d Mon Sep 17 00:00:00 2001 From: Mark Owkes Date: Mon, 16 Feb 2026 14:00:32 -0700 Subject: [PATCH 24/70] Swtich ljcf from r2p to plic --- examples/ljcf_dimensinal/src/ljcf_class.f90 | 44 ++++++++++----------- 1 file changed, 22 insertions(+), 22 deletions(-) diff --git a/examples/ljcf_dimensinal/src/ljcf_class.f90 b/examples/ljcf_dimensinal/src/ljcf_class.f90 index 63216c940..b811282b9 100644 --- a/examples/ljcf_dimensinal/src/ljcf_class.f90 +++ b/examples/ljcf_dimensinal/src/ljcf_class.f90 @@ -179,7 +179,7 @@ subroutine init(this) real(WP) :: vol,area integer, parameter :: amr_ref_lvl=4 ! Create a VOF solver - call this%vf%initialize(cfg=this%cfg,reconstruction_method=r2pnet,transport_method=remap,name='VOF') + call this%vf%initialize(cfg=this%cfg,reconstruction_method=plicnet,transport_method=remap,name='VOF') this%vf%thin_thld_min=0.0_WP this%vf%flotsam_thld=0.0_WP this%vf%maxcurv_times_mesh=1.0_WP @@ -434,24 +434,24 @@ subroutine init(this) this%smesh%varname(2)='thickness' ! Transfer polygons to smesh call this%vf%update_surfmesh(this%smesh) - ! Calculate thickness - call this%vf%get_thickness() - ! Populate nplane and thickness variables - this%smesh%var(1,:)=1.0_WP - np=0 - do k=this%vf%cfg%kmin_,this%vf%cfg%kmax_ - do j=this%vf%cfg%jmin_,this%vf%cfg%jmax_ - do i=this%vf%cfg%imin_,this%vf%cfg%imax_ - if (this%cfg%VF(i,j,k).lt.2.0_WP*epsilon(1.0_WP)) cycle ! Skip cells below VF threshold - do nplane=1,getNumberOfPlanes(this%vf%liquid_gas_interface(i,j,k)) - if (getNumberOfVertices(this%vf%interface_polygon(nplane,i,j,k)).gt.0) then - np=np+1; this%smesh%var(1,np)=real(getNumberOfPlanes(this%vf%liquid_gas_interface(i,j,k)),WP) - this%smesh%var(2,np)=this%vf%thickness(i,j,k) - end if - end do - end do - end do - end do + ! ! Calculate thickness + ! call this%vf%get_thickness() + ! ! Populate nplane and thickness variables + ! this%smesh%var(1,:)=1.0_WP + ! np=0 + ! do k=this%vf%cfg%kmin_,this%vf%cfg%kmax_ + ! do j=this%vf%cfg%jmin_,this%vf%cfg%jmax_ + ! do i=this%vf%cfg%imin_,this%vf%cfg%imax_ + ! if (this%cfg%VF(i,j,k).lt.2.0_WP*epsilon(1.0_WP)) cycle ! Skip cells below VF threshold + ! do nplane=1,getNumberOfPlanes(this%vf%liquid_gas_interface(i,j,k)) + ! if (getNumberOfVertices(this%vf%interface_polygon(nplane,i,j,k)).gt.0) then + ! np=np+1; this%smesh%var(1,np)=real(getNumberOfPlanes(this%vf%liquid_gas_interface(i,j,k)),WP) + ! this%smesh%var(2,np)=this%vf%thickness(i,j,k) + ! end if + ! end do + ! end do + ! end do + ! end do end block create_smesh @@ -494,7 +494,7 @@ subroutine init(this) call this%mfile%add_column(this%vf%SDint,'SD integral') call this%mfile%add_column(this%vof_removed,'VOF removed') call this%mfile%add_column(this%vf%flotsam_error,'Flotsam error') - call this%mfile%add_column(this%vf%thinstruct_error,'Film error') + ! call this%mfile%add_column(this%vf%thinstruct_error,'Film error') call this%mfile%add_column(this%fs%divmax,'Maximum divergence') call this%mfile%add_column(this%fs%psolv%it,'Pressure iteration') call this%mfile%add_column(this%fs%psolv%rerr,'Pressure error') @@ -723,8 +723,8 @@ subroutine step(this) call this%fs%update_laplacian() call this%fs%correct_mfr() call this%fs%get_div() - !call this%fs%add_surface_tension_jump(dt=this%time%dt,div=this%fs%div,vf=this%vf) - call this%fs%add_surface_tension_jump_twoVF(dt=this%time%dt,div=this%fs%div,vf=this%vf) + call this%fs%add_surface_tension_jump(dt=this%time%dt,div=this%fs%div,vf=this%vf) + ! call this%fs%add_surface_tension_jump_twoVF(dt=this%time%dt,div=this%fs%div,vf=this%vf) this%fs%psolv%rhs=-this%fs%cfg%vol*this%fs%div/this%time%dt this%fs%psolv%sol=0.0_WP call this%fs%psolv%solve() From 183c8eb144f3952092f831a20c940e2aa072f894 Mon Sep 17 00:00:00 2001 From: Mark Owkes Date: Mon, 16 Feb 2026 15:02:29 -0700 Subject: [PATCH 25/70] more changes for r2p -> plic --- examples/ljcf_dimensinal/src/ljcf_class.f90 | 32 ++++++++++----------- 1 file changed, 16 insertions(+), 16 deletions(-) diff --git a/examples/ljcf_dimensinal/src/ljcf_class.f90 b/examples/ljcf_dimensinal/src/ljcf_class.f90 index b811282b9..eb349a9d8 100644 --- a/examples/ljcf_dimensinal/src/ljcf_class.f90 +++ b/examples/ljcf_dimensinal/src/ljcf_class.f90 @@ -777,22 +777,22 @@ subroutine step(this) integer :: i,j,k,np,nplane ! Transfer polygons to smesh call this%vf%update_surfmesh(this%smesh) - ! Also populate nplane variable - this%smesh%var(1,:)=1.0_WP - np=0 - do k=this%vf%cfg%kmin_,this%vf%cfg%kmax_ - do j=this%vf%cfg%jmin_,this%vf%cfg%jmax_ - do i=this%vf%cfg%imin_,this%vf%cfg%imax_ - if (this%cfg%VF(i,j,k).lt.2.0_WP*epsilon(1.0_WP)) cycle ! Skip cells below VF threshold - do nplane=1,getNumberOfPlanes(this%vf%liquid_gas_interface(i,j,k)) - if (getNumberOfVertices(this%vf%interface_polygon(nplane,i,j,k)).gt.0) then - np=np+1; this%smesh%var(1,np)=real(getNumberOfPlanes(this%vf%liquid_gas_interface(i,j,k)),WP) - this%smesh%var(2,np)=this%vf%thickness(i,j,k) - end if - end do - end do - end do - end do + ! ! Also populate nplane variable + ! this%smesh%var(1,:)=1.0_WP + ! np=0 + ! do k=this%vf%cfg%kmin_,this%vf%cfg%kmax_ + ! do j=this%vf%cfg%jmin_,this%vf%cfg%jmax_ + ! do i=this%vf%cfg%imin_,this%vf%cfg%imax_ + ! if (this%cfg%VF(i,j,k).lt.2.0_WP*epsilon(1.0_WP)) cycle ! Skip cells below VF threshold + ! do nplane=1,getNumberOfPlanes(this%vf%liquid_gas_interface(i,j,k)) + ! if (getNumberOfVertices(this%vf%interface_polygon(nplane,i,j,k)).gt.0) then + ! np=np+1; this%smesh%var(1,np)=real(getNumberOfPlanes(this%vf%liquid_gas_interface(i,j,k)),WP) + ! this%smesh%var(2,np)=this%vf%thickness(i,j,k) + ! end if + ! end do + ! end do + ! end do + ! end do end block update_smesh call this%ens_out%write_data(this%time%t) end if From 75f2cf9b2ba9d252b7a0d118e29852dd31b939fc Mon Sep 17 00:00:00 2001 From: Mark Owkes Date: Tue, 17 Feb 2026 06:55:33 -0700 Subject: [PATCH 26/70] Removed hit simulation from ljcf simulation to try to reduce memory usage --- examples/ljcf_dimensinal/src/simulation.f90 | 142 ++++++++++---------- 1 file changed, 71 insertions(+), 71 deletions(-) diff --git a/examples/ljcf_dimensinal/src/simulation.f90 b/examples/ljcf_dimensinal/src/simulation.f90 index 15af0a094..922e9e4e9 100644 --- a/examples/ljcf_dimensinal/src/simulation.f90 +++ b/examples/ljcf_dimensinal/src/simulation.f90 @@ -32,53 +32,53 @@ subroutine simulation_init call atom%init() ! Create an MPI group using leftmost processors only - create_hit_group: block - use parallel, only: group,comm - use mpi_f08, only: MPI_Group_incl - integer, dimension(:), allocatable :: ranks - integer, dimension(3) :: coord - integer :: n,ngrp,ierr,ny,nz - ngrp=atom%cfg%npy*atom%cfg%npz - allocate(ranks(ngrp)) - ngrp=0 - do nz=1,atom%cfg%npz - do ny=1,atom%cfg%npy - ngrp=ngrp+1 - coord=[0,ny-1,nz-1] - call MPI_CART_RANK(atom%cfg%comm,coord,ranks(ngrp),ierr) - end do - end do - call MPI_Group_incl(group,ngrp,ranks,hit_group,ierr) - if (atom%cfg%iproc.eq.1) then - isInHITGrp=.true. - else - isInHITGrp=.false. - end if - end block create_hit_group + ! create_hit_group: block + ! use parallel, only: group,comm + ! use mpi_f08, only: MPI_Group_incl + ! integer, dimension(:), allocatable :: ranks + ! integer, dimension(3) :: coord + ! integer :: n,ngrp,ierr,ny,nz + ! ngrp=atom%cfg%npy*atom%cfg%npz + ! allocate(ranks(ngrp)) + ! ngrp=0 + ! do nz=1,atom%cfg%npz + ! do ny=1,atom%cfg%npy + ! ngrp=ngrp+1 + ! coord=[0,ny-1,nz-1] + ! call MPI_CART_RANK(atom%cfg%comm,coord,ranks(ngrp),ierr) + ! end do + ! end do + ! call MPI_Group_incl(group,ngrp,ranks,hit_group,ierr) + ! if (atom%cfg%iproc.eq.1) then + ! isInHITGrp=.true. + ! else + ! isInHITGrp=.false. + ! end if + ! end block create_hit_group - ! Initialize HIT simulation - if (isInHITGrp) call turb%init(group=hit_group,xend=atom%cfg%x(atom%cfg%imin)) + ! ! Initialize HIT simulation + ! if (isInHITGrp) call turb%init(group=hit_group,xend=atom%cfg%x(atom%cfg%imin)) - ! If restarting, the domains could be out of sync, so resync - ! time by forcing HIT to be at same time as jet - if (isInHITGrp) then - turb%time%t=atom%time%t - turb%time%told=turb%time%t-turb%time%dt - end if + ! ! If restarting, the domains could be out of sync, so resync + ! ! time by forcing HIT to be at same time as jet + ! if (isInHITGrp) then + ! turb%time%t=atom%time%t + ! turb%time%told=turb%time%t-turb%time%dt + ! end if - ! Initialize couplers from turb to atom - create_coupler: block - use parallel, only: group - xcpl=coupler(src_grp=hit_group,dst_grp=group,name='turb2atom') - ycpl=coupler(src_grp=hit_group,dst_grp=group,name='turb2atom') - zcpl=coupler(src_grp=hit_group,dst_grp=group,name='turb2atom') - if (isInHITGrp) call xcpl%set_src(turb%cfg,'x') - if (isInHITGrp) call ycpl%set_src(turb%cfg,'y') - if (isInHITGrp) call zcpl%set_src(turb%cfg,'z') - call xcpl%set_dst(atom%cfg,'x'); call xcpl%initialize() - call ycpl%set_dst(atom%cfg,'y'); call ycpl%initialize() - call zcpl%set_dst(atom%cfg,'z'); call zcpl%initialize() - end block create_coupler + ! ! Initialize couplers from turb to atom + ! create_coupler: block + ! use parallel, only: group + ! xcpl=coupler(src_grp=hit_group,dst_grp=group,name='turb2atom') + ! ycpl=coupler(src_grp=hit_group,dst_grp=group,name='turb2atom') + ! zcpl=coupler(src_grp=hit_group,dst_grp=group,name='turb2atom') + ! if (isInHITGrp) call xcpl%set_src(turb%cfg,'x') + ! if (isInHITGrp) call ycpl%set_src(turb%cfg,'y') + ! if (isInHITGrp) call zcpl%set_src(turb%cfg,'z') + ! call xcpl%set_dst(atom%cfg,'x'); call xcpl%initialize() + ! call ycpl%set_dst(atom%cfg,'y'); call ycpl%initialize() + ! call zcpl%set_dst(atom%cfg,'z'); call zcpl%initialize() + ! end block create_coupler end subroutine simulation_init @@ -90,35 +90,35 @@ subroutine simulation_run ! Atomization drives overall time integration do while (.not.atom%time%done()) - ! Advance HIT simulation and transfer velocity info - if (isInHITGrp) then - ! Advance HIT with maximum stable dt until caught up - advance_hit: block - real(WP) :: dt - dt=0.15_WP*turb%cfg%min_meshsize/turb%Urms_tgt - do while (turb%time%t.le.atom%time%t) - call turb%step(dt) - end do - end block advance_hit - end if + ! ! Advance HIT simulation and transfer velocity info + ! if (isInHITGrp) then + ! ! Advance HIT with maximum stable dt until caught up + ! advance_hit: block + ! real(WP) :: dt + ! dt=0.15_WP*turb%cfg%min_meshsize/turb%Urms_tgt + ! do while (turb%time%t.le.atom%time%t) + ! call turb%step(dt) + ! end do + ! end block advance_hit + ! end if ! Handle coupling between HIT and atomization simulation coupling: block - ! Push data from HIT simulation - if (isInHITGrp) then - push_velocity: block - real(WP) :: rescaling,tinterp - rescaling=turb%ti/turb%Urms_tgt - tinterp=(turb%time%t-atom%time%t)/(turb%time%t-turb%time%told) - turb%resU=rescaling*((1.0_WP-tinterp)*turb%fs%U+tinterp*turb%fs%Uold); call xcpl%push(turb%resU) - turb%resV=rescaling*((1.0_WP-tinterp)*turb%fs%V+tinterp*turb%fs%Vold); call ycpl%push(turb%resV) - turb%resW=rescaling*((1.0_WP-tinterp)*turb%fs%W+tinterp*turb%fs%Wold); call zcpl%push(turb%resW) - end block push_velocity - end if - ! Transfer and pull - call xcpl%transfer(); call xcpl%pull(atom%resU) - call ycpl%transfer(); call ycpl%pull(atom%resV) - call zcpl%transfer(); call zcpl%pull(atom%resW) + ! ! Push data from HIT simulation + ! if (isInHITGrp) then + ! push_velocity: block + ! real(WP) :: rescaling,tinterp + ! rescaling=turb%ti/turb%Urms_tgt + ! tinterp=(turb%time%t-atom%time%t)/(turb%time%t-turb%time%told) + ! turb%resU=rescaling*((1.0_WP-tinterp)*turb%fs%U+tinterp*turb%fs%Uold); call xcpl%push(turb%resU) + ! turb%resV=rescaling*((1.0_WP-tinterp)*turb%fs%V+tinterp*turb%fs%Vold); call ycpl%push(turb%resV) + ! turb%resW=rescaling*((1.0_WP-tinterp)*turb%fs%W+tinterp*turb%fs%Wold); call zcpl%push(turb%resW) + ! end block push_velocity + ! end if + ! ! Transfer and pull + ! call xcpl%transfer(); call xcpl%pull(atom%resU) + ! call ycpl%transfer(); call ycpl%pull(atom%resV) + ! call zcpl%transfer(); call zcpl%pull(atom%resW) ! Apply time-dependent Dirichlet condition apply_boundary_condition: block use param, only: param_read @@ -153,7 +153,7 @@ subroutine simulation_final call atom%final() ! Finalize HIT simulation - if (isInHITGrp) call turb%final() + ! if (isInHITGrp) call turb%final() end subroutine simulation_final From ce28784d43a44e0b8bbfbc1bb4bd7f746bcc1174 Mon Sep 17 00:00:00 2001 From: Mark Owkes Date: Tue, 24 Feb 2026 20:01:21 -0700 Subject: [PATCH 27/70] Working on improving inflow BC --- examples/ljcf_dimensinal/src/ljcf_class.f90 | 53 +++++++++++++++++---- 1 file changed, 44 insertions(+), 9 deletions(-) diff --git a/examples/ljcf_dimensinal/src/ljcf_class.f90 b/examples/ljcf_dimensinal/src/ljcf_class.f90 index eb349a9d8..b75f93c16 100644 --- a/examples/ljcf_dimensinal/src/ljcf_class.f90 +++ b/examples/ljcf_dimensinal/src/ljcf_class.f90 @@ -198,7 +198,7 @@ subroutine init(this) end do ! Call adaptive refinement code to get volume and barycenters recursively vol=0.0_WP; area=0.0_WP; v_cent=0.0_WP; a_cent=0.0_WP - if (j.lt.this%vf%cfg%jmin) then + if (j.le.this%vf%cfg%jmin) then call cube_refine_vol(cube_vertex,vol,area,v_cent,a_cent,levelset_halfdrop,0.0_WP,amr_ref_lvl) else ! do nothing @@ -214,28 +214,39 @@ subroutine init(this) end do end do end do + + print *, "VOF(14,1,13) = ", this%vf%VF(14,1-1,13), " after initialization" + ! Update the band call this%vf%update_band() ! Perform interface reconstruction from VOF field call this%vf%build_interface() ! Set interface planes at the boundaries call this%vf%set_full_bcond() + + print *, "VOF(14,1,13) = ", this%vf%VF(14,1-1:1,13), " after full_bcond" ! Now apply Neumann condition on interface at inlet to have proper round injection neumann_irl: block use irl_fortran_interface, only: getPlane,new,construct_2pt,RectCub_type,& & setNumberOfPlanes,setPlane,matchVolumeFraction real(WP), dimension(1:4) :: plane + real(WP) :: eps_plane + integer :: nplanes_src type(RectCub_type) :: cell call new(cell) - if (this%vf%cfg%iproc.eq.1) then + if (this%vf%cfg%jproc.eq.1) then do k=this%vf%cfg%kmino_,this%vf%cfg%kmaxo_ - do j=this%vf%cfg%jmino_,this%vf%cfg%jmaxo_ - do i=this%vf%cfg%imino,this%vf%cfg%imin-1 + do j=this%vf%cfg%jmino_,this%vf%cfg%jmin-1 + do i=this%vf%cfg%imino_,this%vf%cfg%imaxo_ ! Extract plane data and copy in overlap - plane=getPlane(this%vf%liquid_gas_interface(this%vf%cfg%imin,j,k),0) + plane=getPlane(this%vf%liquid_gas_interface(i,this%vf%cfg%jmin,k),0) + eps_plane = 1.0e-30_WP + nplanes_src = getNumberOfPlanes(this%vf%liquid_gas_interface(i,this%vf%cfg%jmin,k)) + if (nplanes_src.eq.0) cycle call construct_2pt(cell,[this%vf%cfg%x(i ),this%vf%cfg%y(j ),this%vf%cfg%z(k )],& & [this%vf%cfg%x(i+1),this%vf%cfg%y(j+1),this%vf%cfg%z(k+1)]) plane(4)=dot_product(plane(1:3),[this%vf%cfg%xm(i),this%vf%cfg%ym(j),this%vf%cfg%zm(k)]) + if (sum(plane(1:3)**2) .le. eps_plane) cycle call setNumberOfPlanes(this%vf%liquid_gas_interface(i,j,k),1) call setPlane(this%vf%liquid_gas_interface(i,j,k),0,plane(1:3),plane(4)) call matchVolumeFraction(cell,this%vf%VF(i,j,k),this%vf%liquid_gas_interface(i,j,k)) @@ -244,6 +255,7 @@ subroutine init(this) end do end if end block neumann_irl + ! Create discontinuous polygon mesh from IRL interface call this%vf%polygonalize_interface() ! Calculate distance from polygons @@ -255,8 +267,7 @@ subroutine init(this) ! Reset moments to guarantee compatibility with interface reconstruction call this%vf%reset_volume_moments() end block create_and_initialize_vof - - + ! Create an iterator for removing VOF at edges create_iterator: block this%vof_removal_layer=iterator(this%cfg,'VOF removal',vof_removal_layer_locator) @@ -289,6 +300,17 @@ subroutine init(this) ! Define gravity as vector for flow solver this%fs%gravity(2) = this%gravity + ! testing: block + ! use tpns_class, only: bcond + ! type(bcond), pointer :: mybc + ! print *, 'Testing VOF after initialization' + ! call this%fs%get_bcond('jet',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) + ! print *, 'Testing VOF at i,j,k=', i, j, k, 'VOF below = ', this%vf%VF(i,j-1,k) + ! end do + ! end block testing + ! Configure pressure solver this%ps=hypre_str(cfg=this%cfg,name='Pressure',method=pcg_pfmg2,nst=7) this%ps%maxlevel=16 @@ -588,11 +610,23 @@ function jet(pg,i,j,k) result(isIn) implicit none class(pgrid), intent(in) :: pg integer, intent(in) :: i,j,k + integer :: ii,kk real(WP), dimension(3) :: xyz logical :: isIn + ! isIn=.false. + ! xyz(1)=pg%xm(i); xyz(2)=pg%ym(j); xyz(3)=pg%zm(k) + ! if (levelset_halfdrop(xyz,0.0_WP).gt.0.0_WP) isIn=.true. isIn=.false. - xyz(1)=pg%xm(i); xyz(2)=pg%ym(j); xyz(3)=pg%zm(k) - if (levelset_halfdrop(xyz,0.0_WP).gt.0.0_WP) isIn=.true. + ! Check if any of cell corners are in jet + do ii = i,i+1 + do kk = k,k+1 + xyz(1)=pg%x(ii); xyz(2)=pg%y(pg%jmin); xyz(3)=pg%z(kk) + if (levelset_halfdrop(xyz,0.0_WP).gt.0.0_WP) then + isIn=.true. + return + end if + end do + end do end function jet !> Function that localizes the walls surrounding the jets @@ -660,6 +694,7 @@ subroutine step(this) do n=1,mybc%itr%no_ i=mybc%itr%map(1,n); j=mybc%itr%map(2,n); k=mybc%itr%map(3,n) this%fs%V(i,j,k) = this%InjectionVelocity + ! print *, 'Applied jet velocity of ', this%InjectionVelocity, ' at i,j,k=', i, j, k, 'VOF below = ', this%vf%VF(i,j-1,k) end do end block apply_bc From ec80bdebf19db0f92399beb9b5553490ff78e059 Mon Sep 17 00:00:00 2001 From: Mark Owkes Date: Thu, 5 Mar 2026 12:58:40 -0700 Subject: [PATCH 28/70] Fixed ensight particle write to work with Paraview (still works with VisIt) --- src/data/ensight_class.f90 | 31 ++++++++++++++++++++++++++----- 1 file changed, 26 insertions(+), 5 deletions(-) diff --git a/src/data/ensight_class.f90 b/src/data/ensight_class.f90 index c43b2aad4..5a9344c85 100644 --- a/src/data/ensight_class.f90 +++ b/src/data/ensight_class.f90 @@ -704,10 +704,10 @@ subroutine write_part(this,part) ! Open the case file open(newunit=iunit,file='ensight/'//trim(this%name)//'/'//trim(part%name)//'.case',form='formatted',status='replace',access='stream',iostat=ierr) ! Write all the geometry information - write(iunit,'(a,/,a,/,/,a,/,a,/,a,/)') 'FORMAT','type: ensight gold','GEOMETRY','model: geometry','measured: 1 '//trim(part%name)//'/particle.******' + write(iunit,'(a,/,a,/,/,a,/,a,/)') 'FORMAT','type: ensight gold','GEOMETRY','model: 1 '//trim(part%name)//'/particle.******' ! Write the variables write(iunit,'(a)') 'VARIABLE' - write(iunit,'(a)') 'scalar per element: fvf geometry.fvf' + ! write(iunit,'(a)') 'scalar per element: fvf geometry.fvf' do n=1,part%ptr%nvar write(iunit,'(a)') 'scalar per measured node: 1 '//trim(part%ptr%varname(n))//' '//trim(part%name)//'/'//trim(part%ptr%varname(n))//'.******' end do @@ -734,9 +734,14 @@ subroutine write_part(this,part) ! General geometry header cbuff='C Binary' ; write(iunit) cbuff cbuff=trim(adjustl(part%ptr%name)) ; write(iunit) cbuff - cbuff='particle coordinates' ; write(iunit) cbuff + cbuff='Written by NGA2' ; write(iunit) cbuff + cbuff='node id off' ; write(iunit) cbuff + cbuff='element id off' ; write(iunit) cbuff + cbuff='part' ; write(iunit) cbuff + ibuff=1 ; write(iunit) ibuff + cbuff=trim(adjustl(part%ptr%name)) ; write(iunit) cbuff + cbuff='coordinates' ; write(iunit) cbuff ibuff=npart ; write(iunit) ibuff - write(iunit) (ibuff,ibuff=1,npart) ! Close the file close(iunit) end if @@ -747,13 +752,29 @@ subroutine write_part(this,part) open(newunit=iunit,file=trim(filename),form='unformatted',status='old',access='stream',position='append',iostat=ierr) if (ierr.ne.0) call die('[ensight write part] Could not open file: '//trim(filename)) ! Write part info if it exists on the processor - if (part%ptr%n.gt.0) write(iunit) real(part%ptr%pos,SP) + if (part%ptr%n.gt.0) then + write(iunit) real(part%ptr%pos(1,:),SP) + write(iunit) real(part%ptr%pos(2,:),SP) + write(iunit) real(part%ptr%pos(3,:),SP) + end if ! Close the file close(iunit) end if ! Force synchronization call MPI_BARRIER(this%cfg%comm,ierr) end do + ! Write element type and connectivity + if (this%cfg%amRoot) then + ! Open the file + open(newunit=iunit,file=trim(filename),form='unformatted',status='old',access='stream',position='append',iostat=ierr) + if (ierr.ne.0) call die('[ensight write part] Could not open file: '//trim(filename)) + cbuff='point' ; write(iunit) cbuff + ibuff=npart ; write(iunit) ibuff + do n=1,npart + ibuff=n ; write(iunit) ibuff + end do + close(iunit) + end if ! Generate the particle scalar files do n=1,part%ptr%nvar From b3e2545ee4bee95a1646422cdd276ee331b6bb3d Mon Sep 17 00:00:00 2001 From: Mark Owkes Date: Thu, 5 Mar 2026 12:59:23 -0700 Subject: [PATCH 29/70] Fixed out-of-bounds error (went outside ghost cells) --- src/particles/lpt_class.f90 | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/src/particles/lpt_class.f90 b/src/particles/lpt_class.f90 index 6e9ffef38..6d85b8878 100644 --- a/src/particles/lpt_class.f90 +++ b/src/particles/lpt_class.f90 @@ -268,8 +268,8 @@ function constructor(cfg,name) result(self) do j=self%cfg%jmino_,self%cfg%jmaxo_ do i=self%cfg%imin_,self%cfg%imax_ do l=-1,+2 - if ((self%cfg%VF(i+l-1,j,k).eq.0.0_WP.and.self%cfg%VF(i+l,j,k).eq.1.0_WP).or.& - & (self%cfg%VF(i+l-1,j,k).eq.1.0_WP.and.self%cfg%VF(i+l,j,k).eq.0.0_WP)) then + if ((self%cfg%VF(max(self%cfg%imino_,i+l-1),j,k).eq.0.0_WP.and.self%cfg%VF(min(self%cfg%imaxo_,i+l),j,k).eq.1.0_WP).or.& + & (self%cfg%VF(max(self%cfg%imino_,i+l-1),j,k).eq.1.0_WP.and.self%cfg%VF(min(self%cfg%imaxo_,i+l),j,k).eq.0.0_WP)) then self%xwall(i,j,k)=min(self%xwall(i,j,k),self%cfg%x(i+l)) end if end do @@ -282,8 +282,8 @@ function constructor(cfg,name) result(self) do j=self%cfg%jmin_,self%cfg%jmax_ do i=self%cfg%imino_,self%cfg%imaxo_ do l=-1,+2 - if ((self%cfg%VF(i,j+l-1,k).eq.0.0_WP.and.self%cfg%VF(i,j+l,k).eq.1.0_WP).or.& - & (self%cfg%VF(i,j+l-1,k).eq.1.0_WP.and.self%cfg%VF(i,j+l,k).eq.0.0_WP)) then + if ((self%cfg%VF(i,max(self%cfg%jmino_,j+l-1),k).eq.0.0_WP.and.self%cfg%VF(i,min(self%cfg%jmaxo_,j+l),k).eq.1.0_WP).or.& + & (self%cfg%VF(i,max(self%cfg%jmino_,j+l-1),k).eq.1.0_WP.and.self%cfg%VF(i,min(self%cfg%jmaxo_,j+l),k).eq.0.0_WP)) then self%ywall(i,j,k)=min(self%ywall(i,j,k),self%cfg%y(j+l)) end if end do @@ -296,8 +296,8 @@ function constructor(cfg,name) result(self) do j=self%cfg%jmino_,self%cfg%jmaxo_ do i=self%cfg%imino_,self%cfg%imaxo_ do l=-1,+2 - if ((self%cfg%VF(i,j,k+l-1).eq.0.0_WP.and.self%cfg%VF(i,j,k+l).eq.1.0_WP).or.& - & (self%cfg%VF(i,j,k+l-1).eq.1.0_WP.and.self%cfg%VF(i,j,k+l).eq.0.0_WP)) then + if ((self%cfg%VF(i,j,max(self%cfg%kmino_,k+l-1)).eq.0.0_WP.and.self%cfg%VF(i,j,min(self%cfg%kmaxo_,k+l)).eq.1.0_WP).or.& + & (self%cfg%VF(i,j,max(self%cfg%kmino_,k+l-1)).eq.1.0_WP.and.self%cfg%VF(i,j,min(self%cfg%kmaxo_,k+l)).eq.0.0_WP)) then self%zwall(i,j,k)=min(self%zwall(i,j,k),self%cfg%z(k+l)) end if end do From 78dce140d56394c586930ecd901dfb437af7179e Mon Sep 17 00:00:00 2001 From: Mark Owkes Date: Thu, 5 Mar 2026 12:59:51 -0700 Subject: [PATCH 30/70] Added a Kelvin Helmholtz Instability case --- examples/kelvinHelmholtz/GNUmakefile | 45 ++ examples/kelvinHelmholtz/README | 1 + examples/kelvinHelmholtz/input | 31 ++ examples/kelvinHelmholtz/src/Make.package | 2 + examples/kelvinHelmholtz/src/geometry.f90 | 74 ++++ examples/kelvinHelmholtz/src/simulation.f90 | 438 ++++++++++++++++++++ 6 files changed, 591 insertions(+) create mode 100644 examples/kelvinHelmholtz/GNUmakefile create mode 100644 examples/kelvinHelmholtz/README create mode 100644 examples/kelvinHelmholtz/input create mode 100644 examples/kelvinHelmholtz/src/Make.package create mode 100644 examples/kelvinHelmholtz/src/geometry.f90 create mode 100644 examples/kelvinHelmholtz/src/simulation.f90 diff --git a/examples/kelvinHelmholtz/GNUmakefile b/examples/kelvinHelmholtz/GNUmakefile new file mode 100644 index 000000000..3f4db1481 --- /dev/null +++ b/examples/kelvinHelmholtz/GNUmakefile @@ -0,0 +1,45 @@ +# NGA location if not yet defined +NGA_HOME ?= ../.. + +# Compilation parameters +PRECISION = DOUBLE +USE_MPI = TRUE +USE_FFTW = TRUE +USE_LAPACK= TRUE +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 := particles constant_density data core 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/kelvinHelmholtz/README b/examples/kelvinHelmholtz/README new file mode 100644 index 000000000..0848ce6af --- /dev/null +++ b/examples/kelvinHelmholtz/README @@ -0,0 +1 @@ +Incompressible mixing layer flow problem. diff --git a/examples/kelvinHelmholtz/input b/examples/kelvinHelmholtz/input new file mode 100644 index 000000000..a39a62b8a --- /dev/null +++ b/examples/kelvinHelmholtz/input @@ -0,0 +1,31 @@ +# Parallelization +Partition : 1 1 1 + +# Mesh definition +Lx : 100 +Ly : 50 +Lz : 10 #0.25 +nx : 400 +ny : 200 +nz : 1 + +# Inital profile +Velocity difference : 1 +Vorticity thickness : 1 + +# Fluid properties +Dynamic viscosity : 0.005 +Density : 1 + +# Particle properties +Particle density : 1000 +Particle diameter : 0.01 +Number of particles : 10000 + +# Time integration +Max timestep size : 0.25 +Max cfl number : 0.8 +Max time : 200 + +# Ensight output +Ensight output period : 1 diff --git a/examples/kelvinHelmholtz/src/Make.package b/examples/kelvinHelmholtz/src/Make.package new file mode 100644 index 000000000..a7a927853 --- /dev/null +++ b/examples/kelvinHelmholtz/src/Make.package @@ -0,0 +1,2 @@ +# List here the extra files here +f90EXE_sources += geometry.f90 simulation.f90 diff --git a/examples/kelvinHelmholtz/src/geometry.f90 b/examples/kelvinHelmholtz/src/geometry.f90 new file mode 100644 index 000000000..b8ff33cc2 --- /dev/null +++ b/examples/kelvinHelmholtz/src/geometry.f90 @@ -0,0 +1,74 @@ +!> 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.5_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=1,x=x,y=y,z=z,xper=.true.,yper=.false.,zper=.true.,name='mixing_layer') + + 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 + ! No walls + cfg%VF=1.0_WP + end block create_walls + + + end subroutine geometry_init + + +end module geometry diff --git a/examples/kelvinHelmholtz/src/simulation.f90 b/examples/kelvinHelmholtz/src/simulation.f90 new file mode 100644 index 000000000..9db4be527 --- /dev/null +++ b/examples/kelvinHelmholtz/src/simulation.f90 @@ -0,0 +1,438 @@ +!> Various definitions and tools for running an NGA2 simulation +module simulation + use precision, only: WP + use geometry, only: cfg + use incomp_class, only: incomp + use fft2d_class, only: fft2d + use lpt_class, only: lpt + use timetracker_class, only: timetracker + use partmesh_class, only: partmesh + use ensight_class, only: ensight + use event_class, only: event + use monitor_class, only: monitor + implicit none + private + + !> Single-phase flow solver and particle solver and corresponding time tracker + type(incomp), public :: fs + type(fft2d), public :: ps + type(timetracker), public :: time + type(lpt), public :: lp + + !> Ensight postprocessing + type(partmesh) :: pmesh + type(ensight) :: ens_out + type(event) :: ens_evt + + !> Simulation monitor file + type(monitor) :: mfile,cflfile,lptfile,khfile + + public :: simulation_init,simulation_run,simulation_final + + !> Private work arrays + real(WP), dimension(:,:,:), allocatable :: resU,resV,resW + real(WP), dimension(:,:,:), allocatable :: Ui,Vi,Wi + + !> Problem definition + real(WP) :: visc,delta,Udiff,KEp + integer :: nwaveX,nwaveZ + real(WP), dimension(:), allocatable :: wnumbX,wshiftX,wampX,wnumbZ,wshiftZ,wampZ + + +contains + + + !> Function that localizes the top (y+) of the domain + function yp_locator(pg,i,j,k) result(isIn) + use pgrid_class, only: pgrid + class(pgrid), intent(in) :: pg + integer, intent(in) :: i,j,k + logical :: isIn + isIn=.false. + if (j.eq.pg%jmax+1) isIn=.true. + end function yp_locator + + + !> Function that localizes the bottom (y-) of the domain + function ym_locator(pg,i,j,k) result(isIn) + use pgrid_class, only: pgrid + class(pgrid), intent(in) :: pg + integer, intent(in) :: i,j,k + logical :: isIn + isIn=.false. + if (j.eq.pg%jmin) isIn=.true. + end function ym_locator + + !> Function to define the base flow + function base_flow(y) result(U) + real(WP), intent(in) :: y + real(WP) :: U + U = 0.5_WP*Udiff*tanh(y/(0.5_WP*delta)) + end function base_flow + + !> Function to compute the KE of the perturbations + function get_KEp() result(KEp) + use mpi_f08, only: MPI_ALLREDUCE,MPI_IN_PLACE,MPI_SUM + use parallel, only: MPI_REAL_WP + real(WP) :: KEp + real(WP) :: up,vp + integer :: i,j,k + integer :: ierr + KEp = 0.0_WP + do k=fs%cfg%kmino_,fs%cfg%kmaxo_ + do j=fs%cfg%jmino_,fs%cfg%jmaxo_ + do i=fs%cfg%imino_,fs%cfg%imaxo_ + up = fs%U(i,j,k) - base_flow(fs%cfg%ym(j)) + vp = fs%V(i,j,k) + KEp = KEp + 0.5_WP * (up*up + vp*vp) * fs%cfg%dx(i) * fs%cfg%dy(j) + end do + end do + end do + call MPI_ALLREDUCE(MPI_IN_PLACE,KEp,1,MPI_REAL_WP,MPI_SUM,fs%cfg%comm,ierr) + end function get_KEp + + + !> Initialization of problem solver + subroutine simulation_init + implicit none + + + ! Allocate work arrays + allocate_work_arrays: block + 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_)) + end block allocate_work_arrays + + + ! Initialize time tracker with 2 subiterations + initialize_timetracker: block + use param, only: param_read + 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 + + + ! Create an incompressible flow solver with slip conditions top and bottom + create_flow_solver: block + use param, only: param_read + use incomp_class, only: slip + integer :: i,j,k + ! Create flow solver + fs=incomp(cfg=cfg,name='KH') + ! Read in fluid parameters + call param_read('Density',fs%rho) + call param_read('Dynamic viscosity',visc); fs%visc=visc + ! Add slip conditions top and bottom + call fs%add_bcond(name='ymslip',type=slip,face='y',dir=-1,canCorrect=.false.,locator=ym_locator) + call fs%add_bcond(name='ypslip',type=slip,face='y',dir=+1,canCorrect=.false.,locator=yp_locator) + ! Create pressure solver + ps=fft2d(cfg=cfg,name='Pressure',nst=7) + ! Setup the solver + call fs%setup(pressure_solver=ps) + end block create_flow_solver + + + ! Initialize velocity field + initialize_velocity: block + use param, only: param_read + use parallel, only: MPI_REAL_WP + use random, only: random_uniform + use mathtools, only: twoPi + integer :: i,j,k,n,ierr,nX,nZ + real(WP) :: y0,base,perturb + ! Prepare parameters for perturbed shear layer + nwaveX=6 + allocate(wnumbX(nwaveX),wshiftX(nwaveX),wampX(nwaveX)) + wampX=0.3_WP/real(nwaveX,WP) + wnumbX=[3.0_WP,4.0_WP,5.0_WP,6.0_WP,7.0_WP,8.0_WP]*twoPi/cfg%xL + if (cfg%amRoot) then + do n=1,nwaveX + wshiftX(n)=random_uniform(lo=-0.5_WP*cfg%xL,hi=+0.5_WP*cfg%xL) + end do + end if + call MPI_BCAST(wshiftX,nwaveX,MPI_REAL_WP,0,cfg%comm,ierr) + nwaveZ=6 + allocate(wnumbZ(nwaveZ),wshiftZ(nwaveZ),wampZ(nwaveZ)) + wampZ=0.3_WP/real(nwaveZ,WP) + wnumbZ=[3.0_WP,4.0_WP,5.0_WP,6.0_WP,7.0_WP,8.0_WP]*twoPi/cfg%zL + if (cfg%amRoot) then + do n=1,nwaveZ + wshiftZ(n)=random_uniform(lo=-0.5_WP*cfg%zL,hi=+0.5_WP*cfg%zL) + end do + end if + call MPI_BCAST(wshiftZ,nwaveZ,MPI_REAL_WP,0,cfg%comm,ierr) + ! Set initial velocity field + call param_read('Velocity difference',Udiff) + call param_read('Vorticity thickness',delta) + do k=fs%cfg%kmino_,fs%cfg%kmaxo_ + do j=fs%cfg%jmino_,fs%cfg%jmaxo_ + do i=fs%cfg%imino_,fs%cfg%imaxo_ + y0=fs%cfg%ym(j) + ! Base flow + base=base_flow(y0) + ! Perturbation + perturb = 0.0_WP + do nX=1,nwaveX + do nZ=1,nwaveZ + perturb=perturb+wampX(nX)*cos(wnumbX(nX)*(fs%cfg%xm(i)-wshiftX(nX)))*wampZ(nZ)*cos(wnumbZ(nZ)*(fs%cfg%zm(k)-wshiftZ(nZ))) + end do + end do + fs%U(i,j,k)=base + perturb + end do + end do + end do + ! Calculate cell-centered velocities and divergence + call fs%interp_vel(Ui,Vi,Wi) + call fs%get_div() + end block initialize_velocity + + + ! Initialize LPT solver + initialize_lpt: block + use param, only: param_read + use random, only: random_uniform + real(WP) :: dp + integer :: i,np + ! Create solver + lp=lpt(cfg=cfg,name='LPT') + ! Get drag model from the inpit + call param_read('Drag model',lp%drag_model,default='Schiller-Naumann') + ! Get particle density from the input + call param_read('Particle density',lp%rho) + ! Get particle diameter from the input + call param_read('Particle diameter',dp) + ! Get number of particles + call param_read('Number of particles',np) + ! Root process initializes np particles randomly + if (lp%cfg%amRoot) then + call lp%resize(np) + do i=1,np + ! Give id + lp%p(i)%id=int(i,8) + ! Set the diameter + lp%p(i)%d=dp + ! Assign random position in the bottom half of domain + lp%p(i)%pos=[random_uniform(lp%cfg%x(lp%cfg%imin),lp%cfg%x(lp%cfg%imax+1)),& + & random_uniform(lp%cfg%y(lp%cfg%jmin),0.0_WP),& + & random_uniform(lp%cfg%z(lp%cfg%kmin),lp%cfg%z(lp%cfg%kmax+1))] + if (lp%cfg%nx.eq.1) lp%p(i)%pos(1)=0.0_WP + if (lp%cfg%nz.eq.1) lp%p(i)%pos(3)=0.0_WP + ! Give zero velocity + lp%p(i)%vel=0.0_WP + lp%p(i)%angVel=0.0_WP + ! Zero out collision forces + lp%p(i)%Acol=0.0_WP + lp%p(i)%Tcol=0.0_WP + ! Give zero dt + lp%p(i)%dt=0.0_WP + ! Locate the particle on the mesh + lp%p(i)%ind=lp%cfg%get_ijk_global(lp%p(i)%pos,[lp%cfg%imin,lp%cfg%jmin,lp%cfg%kmin]) + ! Activate the particle + lp%p(i)%flag=0 + end do + end if + ! Distribute particles + call lp%sync() + ! Get initial particle volume fraction + call lp%update_VF() + end block initialize_lpt + + + ! Create partmesh object for Lagrangian particle output + create_pmesh: block + pmesh=partmesh(nvar=0,nvec=0,name='lpt') + call lp%update_partmesh(pmesh) + end block create_pmesh + + + ! Add Ensight output + create_ensight: block + use param, only: param_read + ! Create Ensight output from cfg + ens_out=ensight(cfg=cfg,name='mixing_layer') + ! 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_vector('velocity',Ui,Vi,Wi) + 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 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 LPT monitor + call lp%get_max() + lptfile=monitor(amroot=lp%cfg%amRoot,name='lpt') + call lptfile%add_column(time%n,'Timestep number') + call lptfile%add_column(time%t,'Time') + call lptfile%add_column(lp%np,'Particle number') + call lptfile%add_column(lp%Umin,'Particle Umin') + call lptfile%add_column(lp%Umax,'Particle Umax') + call lptfile%add_column(lp%Vmin,'Particle Vmin') + call lptfile%add_column(lp%Vmax,'Particle Vmax') + call lptfile%add_column(lp%Wmin,'Particle Wmin') + call lptfile%add_column(lp%Wmax,'Particle Wmax') + call lptfile%add_column(lp%dmin,'Particle dmin') + call lptfile%add_column(lp%dmax,'Particle dmax') + call lptfile%write() + ! ! KH monitor + KEp = get_KEp() + khfile=monitor(fs%cfg%amRoot,'KH') + call khfile%add_column(time%t,'Time') + call khfile%add_column(KEp,'KE Perturb') + call khfile%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 + + ! 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 particles by dt + resU=fs%rho; resV=fs%visc + call lp%advance(dt=time%dt,U=fs%U,V=fs%V,W=fs%W,rho=resU,visc=resV) + + ! 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 + + ! Apply these residuals + fs%U=2.0_WP*fs%U-fs%Uold+resU/fs%rho + fs%V=2.0_WP*fs%V-fs%Vold+resV/fs%rho + fs%W=2.0_WP*fs%W-fs%Wold+resW/fs%rho + + ! Apply other boundary conditions on the resulting fields + call fs%apply_bcond(time%t,time%dt) + + ! Solve Poisson equation + call fs%correct_mfr() + call fs%get_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) + call fs%get_div() + + ! Compute KE of perturbation + KEp = get_KEp() + + ! Output to ensight + if (ens_evt%occurs()) then + call lp%update_partmesh(pmesh) + call ens_out%write_data(time%t) + end if + + ! Perform and output monitoring + call fs%get_max() + call lp%get_max() + call mfile%write() + call cflfile%write() + call lptfile%write() + call khfile%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(resU,resV,resW,Ui,Vi,Wi) + + end subroutine simulation_final + + +end module simulation From 7bdc66b7cbd96285df8798d01c88f8a74324f68d Mon Sep 17 00:00:00 2001 From: Mark Owkes Date: Thu, 5 Mar 2026 13:49:50 -0700 Subject: [PATCH 31/70] Reverting particle writing in ensight - you just need to extract a block in Paraview --- src/data/ensight_class.f90 | 31 +++++-------------------------- 1 file changed, 5 insertions(+), 26 deletions(-) diff --git a/src/data/ensight_class.f90 b/src/data/ensight_class.f90 index 5a9344c85..c43b2aad4 100644 --- a/src/data/ensight_class.f90 +++ b/src/data/ensight_class.f90 @@ -704,10 +704,10 @@ subroutine write_part(this,part) ! Open the case file open(newunit=iunit,file='ensight/'//trim(this%name)//'/'//trim(part%name)//'.case',form='formatted',status='replace',access='stream',iostat=ierr) ! Write all the geometry information - write(iunit,'(a,/,a,/,/,a,/,a,/)') 'FORMAT','type: ensight gold','GEOMETRY','model: 1 '//trim(part%name)//'/particle.******' + write(iunit,'(a,/,a,/,/,a,/,a,/,a,/)') 'FORMAT','type: ensight gold','GEOMETRY','model: geometry','measured: 1 '//trim(part%name)//'/particle.******' ! Write the variables write(iunit,'(a)') 'VARIABLE' - ! write(iunit,'(a)') 'scalar per element: fvf geometry.fvf' + write(iunit,'(a)') 'scalar per element: fvf geometry.fvf' do n=1,part%ptr%nvar write(iunit,'(a)') 'scalar per measured node: 1 '//trim(part%ptr%varname(n))//' '//trim(part%name)//'/'//trim(part%ptr%varname(n))//'.******' end do @@ -734,14 +734,9 @@ subroutine write_part(this,part) ! General geometry header cbuff='C Binary' ; write(iunit) cbuff cbuff=trim(adjustl(part%ptr%name)) ; write(iunit) cbuff - cbuff='Written by NGA2' ; write(iunit) cbuff - cbuff='node id off' ; write(iunit) cbuff - cbuff='element id off' ; write(iunit) cbuff - cbuff='part' ; write(iunit) cbuff - ibuff=1 ; write(iunit) ibuff - cbuff=trim(adjustl(part%ptr%name)) ; write(iunit) cbuff - cbuff='coordinates' ; write(iunit) cbuff + cbuff='particle coordinates' ; write(iunit) cbuff ibuff=npart ; write(iunit) ibuff + write(iunit) (ibuff,ibuff=1,npart) ! Close the file close(iunit) end if @@ -752,29 +747,13 @@ subroutine write_part(this,part) open(newunit=iunit,file=trim(filename),form='unformatted',status='old',access='stream',position='append',iostat=ierr) if (ierr.ne.0) call die('[ensight write part] Could not open file: '//trim(filename)) ! Write part info if it exists on the processor - if (part%ptr%n.gt.0) then - write(iunit) real(part%ptr%pos(1,:),SP) - write(iunit) real(part%ptr%pos(2,:),SP) - write(iunit) real(part%ptr%pos(3,:),SP) - end if + if (part%ptr%n.gt.0) write(iunit) real(part%ptr%pos,SP) ! Close the file close(iunit) end if ! Force synchronization call MPI_BARRIER(this%cfg%comm,ierr) end do - ! Write element type and connectivity - if (this%cfg%amRoot) then - ! Open the file - open(newunit=iunit,file=trim(filename),form='unformatted',status='old',access='stream',position='append',iostat=ierr) - if (ierr.ne.0) call die('[ensight write part] Could not open file: '//trim(filename)) - cbuff='point' ; write(iunit) cbuff - ibuff=npart ; write(iunit) ibuff - do n=1,npart - ibuff=n ; write(iunit) ibuff - end do - close(iunit) - end if ! Generate the particle scalar files do n=1,part%ptr%nvar From ade40860381467a9c74f1b4ed983dd2aa3d91924 Mon Sep 17 00:00:00 2001 From: Mark Owkes Date: Wed, 29 Apr 2026 13:58:42 -0600 Subject: [PATCH 32/70] Added droplet stats output to ljcf_dimensinal Co-authored-by: Copilot --- examples/ljcf_dimensinal/input | 1 + examples/ljcf_dimensinal/src/ljcf_class.f90 | 141 ++++++++++++++++++++ 2 files changed, 142 insertions(+) diff --git a/examples/ljcf_dimensinal/input b/examples/ljcf_dimensinal/input index d2defcb28..9cd4b2670 100644 --- a/examples/ljcf_dimensinal/input +++ b/examples/ljcf_dimensinal/input @@ -37,6 +37,7 @@ Pressure iteration : 100 # Data output Ensight output period : 2.5e-3 # s Restart output period : 0.05 # s +Drop stats output period = 2.5e-3 # Data restart #Restart from : 1.00000E+01 diff --git a/examples/ljcf_dimensinal/src/ljcf_class.f90 b/examples/ljcf_dimensinal/src/ljcf_class.f90 index b75f93c16..131ec6175 100644 --- a/examples/ljcf_dimensinal/src/ljcf_class.f90 +++ b/examples/ljcf_dimensinal/src/ljcf_class.f90 @@ -67,6 +67,9 @@ module ljcf_class type(event) :: save_evt type(pardata) :: df logical :: restarted + + !> Drop statistics output event + type(event) :: drops_evt !> Problem definition real(WP) :: djet, Vjet @@ -496,6 +499,20 @@ subroutine init(this) end block create_ensight + ! Create drop statistics output event + create_drops_output: block + use param, only: param_read + use filesys, only: makedir,isdir + ! Create event for drop statistics output + this%drops_evt=event(time=this%time,name='Drop statistics output') + call param_read('Drop stats output period',this%drops_evt%tper,default=this%time%dtmax) + ! Create drop_stats directory if needed + if (this%cfg%amRoot) then + if (.not.isdir('drop_stats')) call makedir('drop_stats') + end if + end block create_drops_output + + ! Create a monitor file create_monitor: block ! Prepare some info about fields @@ -803,6 +820,106 @@ subroutine step(this) call MPI_ALLREDUCE(MPI_IN_PLACE,this%vof_removed,1,MPI_REAL_WP,MPI_SUM,this%cfg%comm,ierr) call this%vf%clean_irl_and_band() end block remove_vof + + ! Analyze drops + analyze_drops: block + use mpi_f08, only: MPI_ALLREDUCE,MPI_SUM,MPI_MAX,MPI_IN_PLACE + use parallel, only: MPI_REAL_WP + use mathtools, only: pi + use string, only: str_medium + real(WP), dimension(:) , allocatable :: dvol + real(WP), dimension(:,:) , allocatable :: dpos + real(WP), dimension(:,:) , allocatable :: dvel + real(WP), dimension(:,:,:), allocatable :: dmoi + real(WP), dimension(:,:) , allocatable :: dgvel + real(WP), dimension(:) , allocatable :: weights + integer :: n,m,ierr,i,j,k,nmax + integer :: iunit + real(WP) :: x,y,z,x0,y0,z0 + character(len=str_medium) :: timestamp + ! Start by performing a CCL + call this%ccl%build(make_label,same_label) + + ! Allocate droplet stats arrays + allocate(dvol(1:this%ccl%nstruct )); dvol=0.0_WP + allocate(dpos(1:this%ccl%nstruct,1:3 )); dpos=0.0_WP + allocate(dvel(1:this%ccl%nstruct,1:3 )); dvel=0.0_WP + allocate(dmoi(1:this%ccl%nstruct,1:3,1:3)); dmoi=0.0_WP + allocate(dgvel(1:this%ccl%nstruct,1:3 )); dgvel=0.0_WP + allocate(weights(1:this%ccl%nstruct )); weights=0.0_WP + + ! First pass to accumulate volume, position, and velocity + do n=1,this%ccl%nstruct + ! Loop over cells in structure + do m=1,this%ccl%struct(n)%n_ + ! Get cell indices + i=this%ccl%struct(n)%map(1,m) + j=this%ccl%struct(n)%map(2,m) + k=this%ccl%struct(n)%map(3,m) + ! Get cell position, accounting for periodicity + x=this%vf%cfg%xm(i)-this%ccl%struct(n)%per(1)*this%vf%cfg%xL + y=this%vf%cfg%ym(j)-this%ccl%struct(n)%per(2)*this%vf%cfg%yL + z=this%vf%cfg%zm(k)-this%ccl%struct(n)%per(3)*this%vf%cfg%zL + ! Accumulate volume, position, and velocity + dvol(n )=dvol(n )+this%cfg%vol(i,j,k)*this%vf%VF(i,j,k) + dpos(n,:)=dpos(n,:)+this%cfg%vol(i,j,k)*this%vf%VF(i,j,k)*[x,y,z] + dvel(n,:)=dvel(n,:)+this%cfg%vol(i,j,k)*this%vf%VF(i,j,k)*[this%Ui(i,j,k),this%Vi(i,j,k),this%Wi(i,j,k)] + end do + end do + call MPI_ALLREDUCE(MPI_IN_PLACE,dvol,1*this%ccl%nstruct,MPI_REAL_WP,MPI_SUM,this%vf%cfg%comm,ierr) + call MPI_ALLREDUCE(MPI_IN_PLACE,dpos,3*this%ccl%nstruct,MPI_REAL_WP,MPI_SUM,this%vf%cfg%comm,ierr) + call MPI_ALLREDUCE(MPI_IN_PLACE,dvel,3*this%ccl%nstruct,MPI_REAL_WP,MPI_SUM,this%vf%cfg%comm,ierr) + + ! Second pass to accumulate moment of inertia + do n=1,this%ccl%nstruct + ! Get drop barycenter + x0=dpos(n,1)/dvol(n) + y0=dpos(n,2)/dvol(n) + z0=dpos(n,3)/dvol(n) + ! Loop over cells in structure + do m=1,this%ccl%struct(n)%n_ + ! Get cell indices + i=this%ccl%struct(n)%map(1,m) + j=this%ccl%struct(n)%map(2,m) + k=this%ccl%struct(n)%map(3,m) + ! Get cell position relative to drop barycenter, accounting for periodicity + x=this%vf%cfg%xm(i)-this%ccl%struct(n)%per(1)*this%vf%cfg%xL-x0 + y=this%vf%cfg%ym(j)-this%ccl%struct(n)%per(2)*this%vf%cfg%yL-y0 + z=this%vf%cfg%zm(k)-this%ccl%struct(n)%per(3)*this%vf%cfg%zL-z0 + ! Accumulate moment of inertia + dmoi(n,1,1)=dmoi(n,1,1)+this%cfg%vol(i,j,k)*this%vf%VF(i,j,k)*(y**2+z**2) + dmoi(n,2,2)=dmoi(n,2,2)+this%cfg%vol(i,j,k)*this%vf%VF(i,j,k)*(z**2+x**2) + dmoi(n,3,3)=dmoi(n,3,3)+this%cfg%vol(i,j,k)*this%vf%VF(i,j,k)*(x**2+y**2) + dmoi(n,1,2)=dmoi(n,1,2)-this%cfg%vol(i,j,k)*this%vf%VF(i,j,k)*(x*y) + dmoi(n,1,3)=dmoi(n,1,3)-this%cfg%vol(i,j,k)*this%vf%VF(i,j,k)*(x*z) + dmoi(n,2,3)=dmoi(n,2,3)-this%cfg%vol(i,j,k)*this%vf%VF(i,j,k)*(y*z) + end do + end do + call MPI_ALLREDUCE(MPI_IN_PLACE,dmoi,9*this%ccl%nstruct,MPI_REAL_WP,MPI_SUM,this%vf%cfg%comm,ierr) + + ! Third pass to generate normalized drop stats + do n=1,this%ccl%nstruct + ! Get drop barycenter, accounting for periodicity + dpos(n,:)=dpos(n,:)/dvol(n) + if (this%vf%cfg%xper.and.dpos(n,1).lt.this%vf%cfg%x(this%vf%cfg%imin)) dpos(n,1)=dpos(n,1)+this%vf%cfg%xL + if (this%vf%cfg%yper.and.dpos(n,2).lt.this%vf%cfg%y(this%vf%cfg%jmin)) dpos(n,2)=dpos(n,2)+this%vf%cfg%yL + if (this%vf%cfg%zper.and.dpos(n,3).lt.this%vf%cfg%z(this%vf%cfg%kmin)) dpos(n,3)=dpos(n,3)+this%vf%cfg%zL + ! Get drop velocity + dvel(n,:)=dvel(n,:)/dvol(n) + end do + + ! Write drop statistics + if (this%drops_evt%occurs().and.this%cfg%amRoot) then + write(timestamp,'(es12.5)') this%time%t + open(newunit=iunit,file='drop_stats/drop_stats_'//trim(adjustl(timestamp))//'.dat',status='replace') + write(iunit,'(A)') '# DropID Volume X Y Z U V W Ixx Iyy Izz Ixy Ixz Iyz' + do n=1,this%ccl%nstruct + write(iunit,'(I6,1X,F12.5,1X,3F12.5,1X,3F12.5,1X,6F12.5,1X,F12.5)') n,dvol(n),dpos(n,1),dpos(n,2),dpos(n,3),& + & dvel(n,1),dvel(n,2),dvel(n,3),dmoi(n,1,1),dmoi(n,2,2),dmoi(n,3,3),dmoi(n,1,2),dmoi(n,1,3),dmoi(n,2,3) + end do + close(iunit) + end if + end block analyze_drops ! Output to ensight if (this%ens_evt%occurs()) then @@ -900,6 +1017,30 @@ subroutine step(this) deallocate(P11,P12,P13,P14,P21,P22,P23,P24) end block save_restart end if + + contains + !> Function that identifies cells that need a label + logical function make_label(i,j,k) + implicit none + integer, intent(in) :: i,j,k + if (this%vf%VF(i,j,k).gt.0.0_WP) then + make_label=.true. + else + make_label=.false. + end if + end function make_label + + !> Function that identifies if cell pairs have same label + logical function same_label(i1,j1,k1,i2,j2,k2) + implicit none + integer, intent(in) :: i1,j1,k1,i2,j2,k2 + if (this%vf%VF(i1,j1,k1).gt.0.0_WP .and. this%vf%VF(i2,j2,k2).gt.0.0_WP) then + same_label=.true. + else + same_label=.false. + end if + same_label=.true. + end function same_label end subroutine step From 1e9fa9dffaa55c37ff048b6b6170fcb4be4a7603 Mon Sep 17 00:00:00 2001 From: Mark Owkes Date: Wed, 29 Apr 2026 14:12:27 -0600 Subject: [PATCH 33/70] Added max steps options to ljcf_dimensinal Co-authored-by: Copilot --- examples/ljcf_dimensinal/src/ljcf_class.f90 | 1 + 1 file changed, 1 insertion(+) diff --git a/examples/ljcf_dimensinal/src/ljcf_class.f90 b/examples/ljcf_dimensinal/src/ljcf_class.f90 index 131ec6175..66c04d76b 100644 --- a/examples/ljcf_dimensinal/src/ljcf_class.f90 +++ b/examples/ljcf_dimensinal/src/ljcf_class.f90 @@ -132,6 +132,7 @@ subroutine init(this) call param_read('Max timestep size',this%time%dtmax) call param_read('Max cfl number',this%time%cflmax) call param_read('Max time',this%time%tmax) + call param_read('Max steps',this%time%nmax, default=this%time%nmax) this%time%dt=this%time%dtmax this%time%itmax=2 end block initialize_timetracker From 71fafc9f47314ae39fd2b0d5363315910d6d1505 Mon Sep 17 00:00:00 2001 From: Mark Owkes Date: Wed, 29 Apr 2026 14:18:52 -0600 Subject: [PATCH 34/70] Cleaned up debug statement --- examples/ljcf_dimensinal/src/ljcf_class.f90 | 2 -- 1 file changed, 2 deletions(-) diff --git a/examples/ljcf_dimensinal/src/ljcf_class.f90 b/examples/ljcf_dimensinal/src/ljcf_class.f90 index 66c04d76b..b9d35bb3b 100644 --- a/examples/ljcf_dimensinal/src/ljcf_class.f90 +++ b/examples/ljcf_dimensinal/src/ljcf_class.f90 @@ -219,8 +219,6 @@ subroutine init(this) end do end do - print *, "VOF(14,1,13) = ", this%vf%VF(14,1-1,13), " after initialization" - ! Update the band call this%vf%update_band() ! Perform interface reconstruction from VOF field From 4963552875bf5743106035e5a8f7498de7179b5c Mon Sep 17 00:00:00 2001 From: Mark Owkes Date: Wed, 29 Apr 2026 14:22:08 -0600 Subject: [PATCH 35/70] Another debug --- examples/ljcf_dimensinal/src/ljcf_class.f90 | 1 - 1 file changed, 1 deletion(-) diff --git a/examples/ljcf_dimensinal/src/ljcf_class.f90 b/examples/ljcf_dimensinal/src/ljcf_class.f90 index b9d35bb3b..a93a08904 100644 --- a/examples/ljcf_dimensinal/src/ljcf_class.f90 +++ b/examples/ljcf_dimensinal/src/ljcf_class.f90 @@ -226,7 +226,6 @@ subroutine init(this) ! Set interface planes at the boundaries call this%vf%set_full_bcond() - print *, "VOF(14,1,13) = ", this%vf%VF(14,1-1:1,13), " after full_bcond" ! Now apply Neumann condition on interface at inlet to have proper round injection neumann_irl: block use irl_fortran_interface, only: getPlane,new,construct_2pt,RectCub_type,& From 181544b8740cff0ea96e37be869015780bc2a20b Mon Sep 17 00:00:00 2001 From: Mark Owkes Date: Wed, 29 Apr 2026 16:58:45 -0600 Subject: [PATCH 36/70] Switched to scientific notation --- examples/ljcf_dimensinal/src/ljcf_class.f90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/examples/ljcf_dimensinal/src/ljcf_class.f90 b/examples/ljcf_dimensinal/src/ljcf_class.f90 index a93a08904..1c2bc487c 100644 --- a/examples/ljcf_dimensinal/src/ljcf_class.f90 +++ b/examples/ljcf_dimensinal/src/ljcf_class.f90 @@ -912,7 +912,7 @@ subroutine step(this) open(newunit=iunit,file='drop_stats/drop_stats_'//trim(adjustl(timestamp))//'.dat',status='replace') write(iunit,'(A)') '# DropID Volume X Y Z U V W Ixx Iyy Izz Ixy Ixz Iyz' do n=1,this%ccl%nstruct - write(iunit,'(I6,1X,F12.5,1X,3F12.5,1X,3F12.5,1X,6F12.5,1X,F12.5)') n,dvol(n),dpos(n,1),dpos(n,2),dpos(n,3),& + write(iunit,'(I6,1X,E12.5,1X,3E12.5,1X,3E12.5,1X,6E12.5,1X,E12.5)') n,dvol(n),dpos(n,1),dpos(n,2),dpos(n,3),& & dvel(n,1),dvel(n,2),dvel(n,3),dmoi(n,1,1),dmoi(n,2,2),dmoi(n,3,3),dmoi(n,1,2),dmoi(n,1,3),dmoi(n,2,3) end do close(iunit) From 12f0a3763e8a32165b955eb16056229b7d87f7ca Mon Sep 17 00:00:00 2001 From: Mark Owkes Date: Fri, 15 May 2026 09:40:18 -0600 Subject: [PATCH 37/70] Added case that uses ibs to represent injector geometry --- examples/ljcf_dimensinal_ib/GNUmakefile | 47 + examples/ljcf_dimensinal_ib/README | 1 + examples/ljcf_dimensinal_ib/input | 49 + examples/ljcf_dimensinal_ib/src/Make.package | 2 + examples/ljcf_dimensinal_ib/src/hit_class.f90 | 428 +++++++ .../ljcf_dimensinal_ib/src/ljcf_class.f90 | 1040 +++++++++++++++++ .../ljcf_dimensinal_ib/src/simulation.f90 | 161 +++ 7 files changed, 1728 insertions(+) create mode 100644 examples/ljcf_dimensinal_ib/GNUmakefile create mode 100644 examples/ljcf_dimensinal_ib/README create mode 100644 examples/ljcf_dimensinal_ib/input create mode 100644 examples/ljcf_dimensinal_ib/src/Make.package create mode 100644 examples/ljcf_dimensinal_ib/src/hit_class.f90 create mode 100644 examples/ljcf_dimensinal_ib/src/ljcf_class.f90 create mode 100644 examples/ljcf_dimensinal_ib/src/simulation.f90 diff --git a/examples/ljcf_dimensinal_ib/GNUmakefile b/examples/ljcf_dimensinal_ib/GNUmakefile new file mode 100644 index 000000000..f51ff99ec --- /dev/null +++ b/examples/ljcf_dimensinal_ib/GNUmakefile @@ -0,0 +1,47 @@ +# NGA location if not yet defined +NGA_HOME ?= ../.. + +# Compilation parameters +PRECISION = DOUBLE +USE_MPI = TRUE +USE_FFTW = TRUE +USE_HYPRE = TRUE +USE_LAPACK= TRUE +USE_IRL = TRUE +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 two_phase particles constant_density 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/ljcf_dimensinal_ib/README b/examples/ljcf_dimensinal_ib/README new file mode 100644 index 000000000..5e5f940b6 --- /dev/null +++ b/examples/ljcf_dimensinal_ib/README @@ -0,0 +1 @@ +This case simulates the break-up of a liquid ligament in a turbulent crossflow. \ No newline at end of file diff --git a/examples/ljcf_dimensinal_ib/input b/examples/ljcf_dimensinal_ib/input new file mode 100644 index 000000000..f164beb4b --- /dev/null +++ b/examples/ljcf_dimensinal_ib/input @@ -0,0 +1,49 @@ +# Parallelization +Partition : 8 1 1 +I/O partition : 1 1 1 + +# Mesh definition +X ljcf : 0.108 # 2D +Lx : 0.432 # 8D +Ly : 0.432 # 8D for testing - should be 0.864 # 16D +Lz : 0.216 # 4D +nx : 128 # 8 cells/D +ny : 128 # Reduced for 8D for testing - should be 128 +nz : 64 + +# Injector geometry +Injector radius 1 : 0.027 # m +Injector radius 2 : 0.025 # m +Injector height 1 : 0.05 # m +Injector height 2 : 0.07 # m + +# Flow conditions +Jet diameter : 0.054 # m +End Injection Time : 0.267 # s sqrt(2*H/g) = sqrt(2*0.35 m / 9.81 m/s^2) = 0.267 s +Jet location : 0 +Liquid density : 1000 # kg/m^3 +Gas density : 1.2 # kg/m^3 +Liquid viscosity : 1e-3 # Pa-s +Gas viscosity : 1.8e-5 # Pa-s +Surface tension : 0.072 # N/m +Gravitational acceleration : 9.81 # m/s^2 +Air velocity : 11 # m/s +Target Re_lambda : 45 +Turbulence intensity : 0.05 + +# Time integration +Max timestep size : 2e-4 # s +Max cfl number : 1.0 +Max time : 0.4 # s + +# Pressure solver +Pressure tolerance : 1e-4 +Pressure iteration : 100 + +# Data output +Ensight output period : 2.5e-3 # s +Restart output period : 0.05 # s + +# Data restart +#Restart from : 1.00000E+01 +#HIT restart : hit_1.00000E+01 diff --git a/examples/ljcf_dimensinal_ib/src/Make.package b/examples/ljcf_dimensinal_ib/src/Make.package new file mode 100644 index 000000000..ac9df0728 --- /dev/null +++ b/examples/ljcf_dimensinal_ib/src/Make.package @@ -0,0 +1,2 @@ +# List here the extra files here +f90EXE_sources += simulation.f90 hit_class.f90 ljcf_class.f90 diff --git a/examples/ljcf_dimensinal_ib/src/hit_class.f90 b/examples/ljcf_dimensinal_ib/src/hit_class.f90 new file mode 100644 index 000000000..792e384df --- /dev/null +++ b/examples/ljcf_dimensinal_ib/src/hit_class.f90 @@ -0,0 +1,428 @@ +!> Definition for an hit class +module hit_class + use precision, only: WP + use config_class, only: config + use fft3d_class, only: fft3d + use incomp_class, only: incomp + use timetracker_class, only: timetracker + use monitor_class, only: monitor + use pardata_class, only: pardata + use event_class, only: event + implicit none + private + + public :: hit + + !> HIT object + type :: hit + !> Config + type(config) :: cfg !< Mesh for solver + !> Flow solver + type(incomp) :: fs !< Incompressible flow solver + type(fft3d) :: ps !< FFT-based linear solver + type(timetracker) :: time !< Time info + !> Simulation monitor file + type(monitor) :: mfile !< General simulation monitoring + !> Work arrays + real(WP), dimension(:,:,:,:,:), allocatable :: gradU !< Velocity gradient + real(WP), dimension(:,:,:,:), allocatable :: SR !< Strain rate tensor + real(WP), dimension(:,:,:), allocatable :: resU,resV,resW !< Residuals + !> Turbulence parameters + real(WP) :: ti ! Turbulence intensity + real(WP) :: visc,meanU,meanV,meanW + real(WP) :: Urms_tgt,tke_tgt,eps_tgt ! u',k, and dissipation rate + real(WP) :: tko_tgt,eta_tgt ! Kolmogorov time and length scales + real(WP) :: Rel_tgt,Ret_tgt ! Lambda and turbulent Reynolds numbers + real(WP) :: tau_tgt ! Eddy turnover time + real(WP) :: Urms,tke,eps,Ret,Rel,eta,ell ! Current turbulence parameters (ell is large eddy size) + !> Forcing constant + real(WP) :: forcing + !> Provide a pardata object for restarts + logical :: restarted + type(pardata) :: df + type(event) :: save_evt + contains + procedure, private :: compute_stats !< Turbulence information + procedure :: init !< Initialize HIT simulation + procedure :: step !< Advance HIT simulation by one time step + procedure :: final !< Finalize HIT simulation + end type hit + + +contains + + + !> Compute turbulence stats (assumes rho=1) + subroutine compute_stats(this) + use mpi_f08, only: MPI_ALLREDUCE,MPI_SUM + use parallel, only: MPI_REAL_WP + class(hit), intent(inout) :: this + real(WP) :: myTKE,myEPS + integer :: i,j,k,ierr + ! Compute mean velocities + call this%fs%cfg%integrate(A=this%fs%U,integral=this%meanU); this%meanU=this%meanU/this%fs%cfg%vol_total + call this%fs%cfg%integrate(A=this%fs%V,integral=this%meanV); this%meanV=this%meanV/this%fs%cfg%vol_total + call this%fs%cfg%integrate(A=this%fs%W,integral=this%meanW); this%meanW=this%meanW/this%fs%cfg%vol_total + ! Compute strainrate and grad(U) + call this%fs%get_strainrate(SR=this%SR) + call this%fs%get_gradu(gradu=this%gradU) + ! Compute current TKE and dissipation rate + myTKE=0.0_WP + myEPS=0.0_WP + do k=this%fs%cfg%kmin_,this%fs%cfg%kmax_ + do j=this%fs%cfg%jmin_,this%fs%cfg%jmax_ + do i=this%fs%cfg%imin_,this%fs%cfg%imax_ + myTKE=myTKE+0.5_WP*((this%fs%U(i,j,k)-this%meanU)**2+(this%fs%V(i,j,k)-this%meanV)**2+(this%fs%W(i,j,k)-this%meanW)**2)*this%fs%cfg%vol(i,j,k) + myEPS=myEPS+2.0_WP*this%fs%cfg%vol(i,j,k)*(this%SR(1,i,j,k)**2+this%SR(2,i,j,k)**2+this%SR(3,i,j,k)**2+2.0_WP*(this%SR(4,i,j,k)**2+this%SR(5,i,j,k)**2+this%SR(6,i,j,k)**2)) + end do + end do + end do + call MPI_ALLREDUCE(myTKE,this%tke,1,MPI_REAL_WP,MPI_SUM,this%fs%cfg%comm,ierr); this%tke=this%tke/this%fs%cfg%vol_total + call MPI_ALLREDUCE(myEPS,this%eps,1,MPI_REAL_WP,MPI_SUM,this%fs%cfg%comm,ierr); this%eps=this%eps*this%visc/this%fs%cfg%vol_total + ! Compute standard parameters for HIT + this%Urms=sqrt(2.0_WP/3.0_WP*this%tke) + this%Ret=this%tke**2.0_WP/(this%visc*this%eps) + this%Rel=sqrt(20.0_WP*this%Ret/3.0_WP) + this%eta=((this%visc)**3.0_WP/this%eps)**0.25_WP + this%ell=(2.0_WP*this%tke/3.0_WP)**1.5_WP/this%eps + end subroutine compute_stats + + + !> Initialization of HIT simulation + subroutine init(this,group,xend) + use mpi_f08, only: MPI_Group + implicit none + class(hit), intent(inout) :: this + type(MPI_Group), intent(in) :: group + real(WP) :: xend + + ! Create the HIT mesh + create_config: block + use sgrid_class, only: cartesian,sgrid + use param, only: param_read + real(WP), dimension(:), allocatable :: x,y + integer, dimension(3) :: partition + type(sgrid) :: grid + integer :: j,ny + real(WP) :: Ly + ! Read in grid definition + call param_read('Ly',Ly); call param_read('ny',ny); allocate(y(ny+1)); allocate(x(ny+1)) + ! Create simple rectilinear grid in y and z + do j=1,ny+1 + y(j)=real(j-1,WP)/real(ny,WP)*Ly-0.5_WP*Ly + end do + ! Same grid in x, but shifted so it ends at xend + x=y-y(ny+1)+xend + ! General serial grid object + grid=sgrid(coord=cartesian,no=1,x=x,y=y,z=y,xper=.true.,yper=.true.,zper=.true.,name='HIT') + ! Read in partition + call param_read('Partition',partition,short='p'); partition(1)=1 + ! Create partitioned grid without walls + this%cfg=config(grp=group,decomp=partition,grid=grid) + end block create_config + + ! Initialize the work arrays + allocate_work_arrays: block + allocate(this%resU(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + allocate(this%resV(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + allocate(this%resW(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + allocate(this%SR (1:6,this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + allocate(this%gradU(1:3,1:3,this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + end block allocate_work_arrays + + + ! Initialize time tracker with 2 subiterations + initialize_timetracker: block + use param, only: param_read + this%time=timetracker(amRoot=this%cfg%amRoot) + call param_read('Max timestep size',this%time%dtmax) + call param_read('Max cfl number',this%time%cflmax) + this%time%dt=this%time%dtmax + this%time%itmax=2 + end block initialize_timetracker + + + ! Create a single-phase periodic flow solver + create_flow_solver: block + use mathtools, only: Pi + use param, only: param_read + ! Create flow solver + this%fs=incomp(cfg=this%cfg,name='NS solver') + ! Set density to 1.0 + this%fs%rho=1.0_WP + ! Set viscosity from Reynolds number + call param_read("Gas viscosity",this%visc); + this%fs%visc=this%visc + ! Prepare and configure pressure solver + this%ps=fft3d(cfg=this%cfg,name='Pressure',nst=7) + ! Setup the solver + call this%fs%setup(pressure_solver=this%ps) + end block create_flow_solver + + + ! Prepare initial velocity field + initialize_velocity: block + use random, only: random_normal + use mathtools, only: Pi + use param, only: param_read,param_exists + use messager, only: log + use string, only: str_long + character(str_long) :: message + real(WP) :: max_forcing_estimate + integer :: i,j,k + ! Read in turbulence intensity for turbulence injection + call param_read('Turbulence intensity',this%ti) + ! Read in target Re_lambda and convert to target Urms + call param_read('Target Re_lambda',this%Urms_tgt) + this%Urms_tgt=this%visc/(3.0_WP*this%cfg%xL)*this%Urms_tgt**2 + ! Calculate other target quantities assuming l=0.2*xL + this%tke_tgt=1.5_WP*this%Urms_tgt**2 + this%eps_tgt=5.0_WP*this%Urms_tgt**3/this%cfg%xL + this%tko_tgt=sqrt(this%visc/this%eps_tgt) + this%eta_tgt=(this%visc**3/this%eps_tgt)**(0.25_WP) + this%Rel_tgt=sqrt(3.0_WP*this%Urms_tgt*this%cfg%xL/this%visc) + this%Ret_tgt=this%tke_tgt**2/(this%eps_tgt*this%visc) + this%tau_tgt=2.0_WP*this%tke_tgt/(3.0_WP*this%eps_tgt) + ! Read in forcing parameter (we need dt Urms =",es12.5)') this%Urms_tgt; call log(message) + write(message,'("[HIT setup] => Re_lambda =",es12.5)') this%Rel_tgt; call log(message) + write(message,'("[HIT setup] => Re_turb =",es12.5)') this%Ret_tgt; call log(message) + write(message,'("[HIT setup] => Kolmogorov Lscale =",es12.5)') this%eta_tgt; call log(message) + write(message,'("[HIT setup] => Kolmogorov Tscale =",es12.5)') this%tko_tgt; call log(message) + write(message,'("[HIT setup] => Epsilon =",es12.5)') this%eps_tgt; call log(message) + write(message,'("[HIT setup] => Eddyturnover time =",es12.5)') this%tau_tgt; call log(message) + end if + ! Gaussian initial field + do k=this%fs%cfg%kmin_,this%fs%cfg%kmax_ + do j=this%fs%cfg%jmin_,this%fs%cfg%jmax_ + do i=this%fs%cfg%imin_,this%fs%cfg%imax_ + this%fs%U(i,j,k)=random_normal(m=0.0_WP,sd=this%Urms_tgt) + this%fs%V(i,j,k)=random_normal(m=0.0_WP,sd=this%Urms_tgt) + this%fs%W(i,j,k)=random_normal(m=0.0_WP,sd=this%Urms_tgt) + end do + end do + end do + call this%fs%cfg%sync(this%fs%U) + call this%fs%cfg%sync(this%fs%V) + call this%fs%cfg%sync(this%fs%W) + ! Compute mean and remove it from the velocity field to obtain =0 + call this%fs%cfg%integrate(A=this%fs%U,integral=this%meanU); this%meanU=this%meanU/this%fs%cfg%vol_total; this%fs%U=this%fs%U-this%meanU + call this%fs%cfg%integrate(A=this%fs%V,integral=this%meanV); this%meanV=this%meanV/this%fs%cfg%vol_total; this%fs%V=this%fs%V-this%meanV + call this%fs%cfg%integrate(A=this%fs%W,integral=this%meanW); this%meanW=this%meanW/this%fs%cfg%vol_total; this%fs%W=this%fs%W-this%meanW + ! Project to ensure divergence-free + call this%fs%get_div() + this%fs%psolv%rhs=-this%fs%cfg%vol*this%fs%div + this%fs%psolv%sol=0.0_WP + call this%fs%psolv%solve() + call this%fs%shift_p(this%fs%psolv%sol) + call this%fs%get_pgrad(this%fs%psolv%sol,this%resU,this%resV,this%resW) + this%fs%P=this%fs%P+this%fs%psolv%sol + this%fs%U=this%fs%U-this%resU + this%fs%V=this%fs%V-this%resV + this%fs%W=this%fs%W-this%resW + ! Calculate divergence + call this%fs%get_div() + end block initialize_velocity + + + ! Handle restart here + perform_restart: block + use param, only: param_read + use string, only: str_medium + use filesys, only: makedir,isdir + character(len=str_medium) :: filename + integer, dimension(3) :: iopartition + ! Create event for saving restart files + this%save_evt=event(this%time,'HIT restart output') + call param_read('Restart output period',this%save_evt%tper) + ! Read in the partition for I/O + call param_read('I/O partition',iopartition) + ! Check if a restart file was provided + call param_read('HIT restart',filename,default='') + this%restarted=.false.; if (len_trim(filename).gt.0) this%restarted=.true. + ! Perform pardata initialization + if (this%restarted) then + ! Read in the file + call this%df%initialize(pg=this%cfg,iopartition=iopartition,fdata='restart/'//trim(filename)) + ! Put the data at the right place + call this%df%pull(name='U',var=this%fs%U) + call this%df%pull(name='V',var=this%fs%V) + call this%df%pull(name='W',var=this%fs%W) + call this%df%pull(name='P',var=this%fs%P) + ! Update divergence + call this%fs%get_div() + ! Also update time + call this%df%pull(name='t' ,val=this%time%t ) + call this%df%pull(name='dt',val=this%time%dt) + this%time%told=this%time%t-this%time%dt + !this%time%dt=this%time%dtmax !< Force max timestep size anyway + else + ! Prepare a new directory for storing files for restart + if (this%cfg%amRoot) then + if (.not.isdir('restart')) call makedir('restart') + end if + ! If we are not restarting, we will still need a datafile for saving restart files + call this%df%initialize(pg=this%cfg,iopartition=iopartition,filename=trim(this%cfg%name),nval=2,nvar=4) + this%df%valname=['dt','t ']; this%df%varname=['U','V','W','P'] + end if + end block perform_restart + + + ! Create monitoring file + create_monitor: block + ! Prepare some info about turbulence + call this%fs%get_max() + call this%compute_stats() + ! Create simulation monitor + this%mfile=monitor(this%fs%cfg%amRoot,'hit') + call this%mfile%add_column(this%time%n,'Timestep number') + call this%mfile%add_column(this%time%t,'Time') + call this%mfile%add_column(this%time%dt,'Timestep size') + call this%mfile%add_column(this%fs%Umax,'Umax') + call this%mfile%add_column(this%fs%Vmax,'Vmax') + call this%mfile%add_column(this%fs%Wmax,'Wmax') + call this%mfile%add_column(this%Ret,'Re_turb') + call this%mfile%add_column(this%Rel,'Re_lambda') + call this%mfile%add_column(this%Urms,'Urms') + call this%mfile%add_column(this%TKE,'TKE') + call this%mfile%add_column(this%EPS,'Epsilon') + call this%mfile%add_column(this%ell,'Large eddy size') + call this%mfile%add_column(this%eta,'Kolmogorov length') + call this%mfile%write() + end block create_monitor + + + end subroutine init + + + !> Take one time step with specified dt + subroutine step(this,dt) + implicit none + class(hit), intent(inout) :: this + real(WP), intent(in) :: dt + + ! Increment time based on provided dt + this%time%dt=dt; call this%time%increment() + + ! Remember old velocity + this%fs%Uold=this%fs%U + this%fs%Vold=this%fs%V + this%fs%Wold=this%fs%W + + ! Perform sub-iterations + do while (this%time%it.le.this%time%itmax) + + ! Build mid-time velocity + this%fs%U=0.5_WP*(this%fs%U+this%fs%Uold) + this%fs%V=0.5_WP*(this%fs%V+this%fs%Vold) + this%fs%W=0.5_WP*(this%fs%W+this%fs%Wold) + + ! Explicit calculation of drho*u/dt from NS + call this%fs%get_dmomdt(this%resU,this%resV,this%resW) + + ! Assemble explicit residual + this%resU=-2.0_WP*(this%fs%U-this%fs%Uold)+this%time%dt*this%resU + this%resV=-2.0_WP*(this%fs%V-this%fs%Vold)+this%time%dt*this%resV + this%resW=-2.0_WP*(this%fs%W-this%fs%Wold)+this%time%dt*this%resW + + ! Apply HIT forcing + hit_forcing: block + use mpi_f08, only: MPI_ALLREDUCE,MPI_SUM + use parallel, only: MPI_REAL_WP + real(WP) :: myTKE,A,myEPSp,EPSp + integer :: i,j,k,ierr + ! Calculate mean velocity + call this%fs%cfg%integrate(A=this%fs%U,integral=this%meanU); this%meanU=this%meanU/this%fs%cfg%vol_total + call this%fs%cfg%integrate(A=this%fs%V,integral=this%meanV); this%meanV=this%meanV/this%fs%cfg%vol_total + call this%fs%cfg%integrate(A=this%fs%W,integral=this%meanW); this%meanW=this%meanW/this%fs%cfg%vol_total + ! Calculate TKE and pseudo-EPS + call this%fs%get_gradu(gradu=this%gradU) + myTKE=0.0_WP; myEPSp=0.0_WP + do k=this%fs%cfg%kmin_,this%fs%cfg%kmax_ + do j=this%fs%cfg%jmin_,this%fs%cfg%jmax_ + do i=this%fs%cfg%imin_,this%fs%cfg%imax_ + myTKE =myTKE +0.5_WP*((this%fs%U(i,j,k)-this%meanU)**2+(this%fs%V(i,j,k)-this%meanV)**2+(this%fs%W(i,j,k)-this%meanW)**2)*this%fs%cfg%vol(i,j,k) + myEPSp=myEPSp+this%fs%cfg%vol(i,j,k)*(this%gradU(1,1,i,j,k)**2+this%gradU(1,2,i,j,k)**2+this%gradU(1,3,i,j,k)**2+& + & this%gradU(2,1,i,j,k)**2+this%gradU(2,2,i,j,k)**2+this%gradU(2,3,i,j,k)**2+& + & this%gradU(3,1,i,j,k)**2+this%gradU(3,2,i,j,k)**2+this%gradU(3,3,i,j,k)**2) + end do + end do + end do + call MPI_ALLREDUCE(myTKE,this%tke,1,MPI_REAL_WP,MPI_SUM,this%fs%cfg%comm,ierr); this%tke=this%tke/this%fs%cfg%vol_total + call MPI_ALLREDUCE(myEPSp,EPSp,1,MPI_REAL_WP,MPI_SUM,this%fs%cfg%comm,ierr); EPSp=EPSp*this%visc/this%fs%cfg%vol_total + A=(EPSp-this%forcing*(this%tke-this%tke_tgt)/this%tau_tgt)/(2.0_WP*this%tke) + this%resU=this%resU+A*this%time%dt*(this%fs%U-this%meanU) + this%resV=this%resV+A*this%time%dt*(this%fs%V-this%meanV) + this%resW=this%resW+A*this%time%dt*(this%fs%W-this%meanW) + end block hit_forcing + + ! Apply these residuals + this%fs%U=2.0_WP*this%fs%U-this%fs%Uold+this%resU + this%fs%V=2.0_WP*this%fs%V-this%fs%Vold+this%resV + this%fs%W=2.0_WP*this%fs%W-this%fs%Wold+this%resW + + ! Solve Poisson equation + call this%fs%get_div() + this%fs%psolv%rhs=-this%fs%cfg%vol*this%fs%div/this%time%dt + this%fs%psolv%sol=0.0_WP + call this%fs%psolv%solve() + call this%fs%shift_p(this%fs%psolv%sol) + + ! Correct velocity + call this%fs%get_pgrad(this%fs%psolv%sol,this%resU,this%resV,this%resW) + this%fs%P=this%fs%P+this%fs%psolv%sol + this%fs%U=this%fs%U-this%time%dt*this%resU + this%fs%V=this%fs%V-this%time%dt*this%resV + this%fs%W=this%fs%W-this%time%dt*this%resW + + ! Increment sub-iteration counter + this%time%it=this%time%it+1 + + end do + + ! Recompute divergence + call this%fs%get_div() + + ! Perform and output monitoring + call this%fs%get_max() + call this%compute_stats() + call this%mfile%write() + + ! Finally, see if it's time to save restart files + if (this%save_evt%occurs()) then + save_restart: block + use string, only: str_medium + character(len=str_medium) :: timestamp + ! Prefix for files + write(timestamp,'(es12.5)') this%time%t + ! Populate df and write it + call this%df%push(name='t' ,val=this%time%t ) + call this%df%push(name='dt',val=this%time%dt) + call this%df%push(name='U' ,var=this%fs%U ) + call this%df%push(name='V' ,var=this%fs%V ) + call this%df%push(name='W' ,var=this%fs%W ) + call this%df%push(name='P' ,var=this%fs%P ) + call this%df%write(fdata='restart/hit_'//trim(adjustl(timestamp))) + end block save_restart + end if + + end subroutine step + + + !> Finalize nozzle simulation + subroutine final(this) + implicit none + class(hit), intent(inout) :: this + + ! Deallocate work arrays + deallocate(this%resU,this%resV,this%resW,this%gradU,this%SR) + + end subroutine final + + +end module hit_class \ No newline at end of file diff --git a/examples/ljcf_dimensinal_ib/src/ljcf_class.f90 b/examples/ljcf_dimensinal_ib/src/ljcf_class.f90 new file mode 100644 index 000000000..6e5d3d05e --- /dev/null +++ b/examples/ljcf_dimensinal_ib/src/ljcf_class.f90 @@ -0,0 +1,1040 @@ +!> Definition for a ljcf atomization class +module ljcf_class + use precision, only: WP + use ibconfig_class, only: ibconfig + use iterator_class, only: iterator + use ensight_class, only: ensight + use surfmesh_class, only: surfmesh + use hypre_str_class, only: hypre_str + !use ddadi_class, only: ddadi + use vfs_class, only: vfs + use tpns_class, only: tpns + use timetracker_class, only: timetracker + use event_class, only: event + use monitor_class, only: monitor + use timer_class, only: timer + use pardata_class, only: pardata + use cclabel_class, only: cclabel + use irl_fortran_interface + implicit none + private + + public :: ljcf + + integer :: ierr + + !> ljcf object + type :: ljcf + + !> Config + type(ibconfig) :: cfg + + !> Flow solver + type(vfs) :: vf !< Volume fraction solver + type(tpns) :: fs !< Two-phase flow solver + type(hypre_str) :: ps !< Structured Hypre linear solver for pressure + !type(ddadi) :: vs !< DDADI solver for velocity + type(timetracker) :: time !< Time info + type(cclabel) :: ccl !< CCLabel for local Weber number calculation + + !> Ensight postprocessing + type(surfmesh) :: smesh !< Surface mesh for interface + type(ensight) :: ens_out !< Ensight output for flow variables + type(event) :: ens_evt !< Event trigger for Ensight output + + !> Simulation monitor file + type(monitor) :: mfile !< General simulation monitoring + type(monitor) :: cflfile !< CFL monitoring + type(monitor) :: ljcf_file !< LJCF simulation monitoring + + !> Work arrays + real(WP), dimension(:,:,:), allocatable :: resU,resV,resW !< Residuals + real(WP), dimension(:,:,:), allocatable :: Ui,Vi,Wi !< Cell-centered velocities + + !> Iterator for VOF removal + type(iterator) :: vof_removal_layer !< Edge of domain where we actively remove VOF + real(WP) :: vof_removed !< Integral of VOF removed + integer :: nlayer=4 !< Size of buffer layer for VOF removal + + !> Timing info + type(monitor) :: timefile !< Timing monitoring + type(timer) :: tstep !< Timer for step + type(timer) :: tvel !< Timer for velocity + type(timer) :: tpres !< Timer for pressure + type(timer) :: tvof !< Timer for VOF + + !> Provide a pardata and an event tracker for saving restarts + type(event) :: save_evt + type(pardata) :: df + logical :: restarted + + !> Problem definition + real(WP) :: djet, Vjet + real(WP), dimension(:), allocatable :: xjet + integer :: relax_model, nwall + real(WP) :: gravity, endInjectionTime, InjectionVelocity + + contains + procedure :: init !< Initialize nozzle simulation + procedure :: step !< Advance nozzle simulation by one time step + procedure :: final !< Finalize nozzle simulation + end type ljcf + + +contains + + !> Initialization of ljcf simulation + subroutine init(this) + implicit none + class(ljcf), intent(inout) :: this + + ! Create the ljcf mesh + create_config: block + use sgrid_class, only: cartesian,sgrid + use param, only: param_read + use parallel, only: group + real(WP), dimension(:), allocatable :: x,y,z + integer, dimension(3) :: partition + type(sgrid) :: grid + integer :: i,j,k,nx,ny,nz + real(WP) :: Lx,Ly,Lz,xlig + ! Read in grid definition + call param_read('Lx',Lx); call param_read('nx',nx); allocate(x(nx+1)); call param_read('X ljcf',xlig) + 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-xlig + 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=3,x=x,y=y,z=z,xper=.false.,yper=.false.,zper=.true.,name='ljcf') + ! Read in partition + call param_read('Partition',partition,short='p') + ! Create partitioned grid without walls + this%cfg=ibconfig(grp=group,decomp=partition,grid=grid) + + + ! Create IB walls for this config + create_walls: block + use mathtools, only: twoPi + use ibconfig_class, only: bigot, sharp + use param, only: param_read + integer :: i,j,k + real(WP) :: r, y, y1, y2 + real(WP) :: G1, G2, Gcap + real(WP) :: R1, R2, h1, h2 + real(WP) :: y0, ycap, d_cyln, d_wall + + ! Read parameters + call param_read('Injector radius 1', R1) + call param_read('Injector radius 2', R2) + call param_read('Injector height 1', h1) + call param_read('Injector height 2', h2) + + ! Reference axial location (start of nozzle) + y0 = this%cfg%y(this%cfg%jmino) + y1 = y0 + h1 + y2 = y0 + h2 + + do k = this%cfg%kmino_, this%cfg%kmaxo_ + do j = this%cfg%jmino_, this%cfg%jmaxo_ + do i = this%cfg%imino_, this%cfg%imaxo_ + + ! Coordinates of this point + y = this%cfg%ym(j) + r = sqrt( this%cfg%xm(i)**2 + this%cfg%zm(k)**2) + + + ! Start with fluid everywhere + this%cfg%Gib(i,j,k) = 0.0 !-huge(1.0) + + ! Lower region (y < y1) + ! -------------------------------------------------- + if (y < y1 ) then + + if (r < R1) then ! Inside cylinder + ! Distance to wall between cylinders + if (r < R2) then ! Inside injector + d_wall = sqrt( (r-R2)**2 + (y-y1)**2 ) + else ! Between cylinders + d_wall = y1 - y + end if + ! Distance to cylinder + d_cyln = R1 - r + this%cfg%Gib(i,j,k) = -min(d_wall, d_cyln) + else ! Outside cylinder + ! Distance to top wall + d_wall = y2 - y + ! Distance to cylinder + d_cyln = r - R1 + this%cfg%Gib(i,j,k) = min(d_wall, d_cyln) + end if + + ! Middle region (y1 < y < y2) + ! -------------------------------------------------- + else if (y < y2) then + if (r < R2) then ! Inside cylinder + this%cfg%Gib(i,j,k) = r - R2 + else ! Outside cylinder + d_wall = y2 - y ! distance to top wall + if (r < R1) then ! Between cylinders + d_wall = min(d_wall, y - y1) + else ! Distance to edge of lower cylinder + d_wall = min(d_wall, sqrt( (r-R1)**2 + (y-y1)**2 ) ) + end if + d_cyln = r - R2 + this%cfg%Gib(i,j,k) = min(d_wall, d_cyln) + end if + + ! Upper region (y > y2) + ! -------------------------------------------------- + else + if (r < R2) then ! Inside injector + this%cfg%Gib(i,j,k) = -sqrt( (r-R2)**2 + (y-y2)**2 ) + else + this%cfg%Gib(i,j,k) = y2-y + end if + end if + + end do + end do + end do + + ! Compute normals + call this%cfg%calculate_normal() + + ! Compute volume fraction + call this%cfg%calculate_vf(method=sharp, allow_zero_vf=.false.) + + end block create_walls + + end block create_config + + + ! Initialize time tracker with 2 subiterations + initialize_timetracker: block + use param, only: param_read + this%time=timetracker(amRoot=this%cfg%amRoot) + call param_read('Max timestep size',this%time%dtmax) + call param_read('Max cfl number',this%time%cflmax) + call param_read('Max time',this%time%tmax) + this%time%dt=this%time%dtmax + this%time%itmax=2 + end block initialize_timetracker + + + ! Allocate work arrays + allocate_work_arrays: block + allocate(this%resU(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + allocate(this%resV(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + allocate(this%resW(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + allocate(this%Ui (this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + allocate(this%Vi (this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + allocate(this%Wi (this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + end block allocate_work_arrays + + ! Set up walls before solvers are initialized + create_walls: block + use param, only: param_read,param_getsize + integer :: i,j,k,njet + ! Initialize liquid jet(s) + call param_read('Jet diameter',this%djet) + njet = param_getsize('Jet location') + allocate(this%xjet(njet)) + call param_read('Jet location',this%xjet) + call param_read('Gravitational acceleration',this%gravity) + call param_read('End Injection Time',this%endInjectionTime) + ! Number of wall cells + call param_read('Wall cells in domain', this%nwall, default=0) + 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 (wall(this%cfg%pgrid,i,j,k)) then + this%cfg%VF(i,j,k)=0.0_WP + end if + end do + end do + end do + end block create_walls + + ! Initialize our VOF solver and field + create_and_initialize_vof: block + use vfs_class, only: remap,VFlo,VFhi,plicnet,r2pnet + use mms_geom, only: cube_refine_vol + use param, only: param_read + integer :: i,j,k,n,si,sj,sk + real(WP), dimension(3,8) :: cube_vertex + real(WP), dimension(3) :: v_cent,a_cent + real(WP) :: vol,area + integer, parameter :: amr_ref_lvl=4 + ! Create a VOF solver + call this%vf%initialize(cfg=this%cfg,reconstruction_method=plicnet,transport_method=remap,name='VOF') + this%vf%thin_thld_min=0.0_WP + this%vf%flotsam_thld=0.0_WP + this%vf%maxcurv_times_mesh=1.0_WP + ! Initialize the interface to a ljcf + do k=this%vf%cfg%kmino_,this%vf%cfg%kmaxo_ + do j=this%vf%cfg%jmino_,this%vf%cfg%jmaxo_ + do i=this%vf%cfg%imino_,this%vf%cfg%imaxo_ + ! Set cube vertices + n=0 + do sk=0,1 + do sj=0,1 + do si=0,1 + n=n+1; cube_vertex(:,n)=[this%vf%cfg%x(i+si),this%vf%cfg%y(j+sj),this%vf%cfg%z(k+sk)] + end do + end do + end do + ! Call adaptive refinement code to get volume and barycenters recursively + vol=0.0_WP; area=0.0_WP; v_cent=0.0_WP; a_cent=0.0_WP + if (j.le.this%vf%cfg%jmin) then + call cube_refine_vol(cube_vertex,vol,area,v_cent,a_cent,levelset_halfdrop,0.0_WP,amr_ref_lvl) + else + ! do nothing + end if + this%vf%VF(i,j,k)=vol/this%vf%cfg%vol(i,j,k) + if (this%vf%VF(i,j,k).ge.VFlo.and.this%vf%VF(i,j,k).le.VFhi) then + this%vf%Lbary(:,i,j,k)=v_cent + this%vf%Gbary(:,i,j,k)=([this%vf%cfg%xm(i),this%vf%cfg%ym(j),this%vf%cfg%zm(k)]-this%vf%VF(i,j,k)*this%vf%Lbary(:,i,j,k))/(1.0_WP-this%vf%VF(i,j,k)) + else + this%vf%Lbary(:,i,j,k)=[this%vf%cfg%xm(i),this%vf%cfg%ym(j),this%vf%cfg%zm(k)] + this%vf%Gbary(:,i,j,k)=[this%vf%cfg%xm(i),this%vf%cfg%ym(j),this%vf%cfg%zm(k)] + end if + end do + end do + end do + ! Update the band + call this%vf%update_band() + ! Perform interface reconstruction from VOF field + call this%vf%build_interface() + ! Set interface planes at the boundaries + call this%vf%set_full_bcond() + + ! Now apply Neumann condition on interface at inlet to have proper round injection + neumann_irl: block + use irl_fortran_interface, only: getPlane,new,construct_2pt,RectCub_type,& + & setNumberOfPlanes,setPlane,matchVolumeFraction + real(WP), dimension(1:4) :: plane + real(WP) :: eps_plane + integer :: nplanes_src + type(RectCub_type) :: cell + call new(cell) + if (this%vf%cfg%jproc.eq.1) then + do k=this%vf%cfg%kmino_,this%vf%cfg%kmaxo_ + do j=this%vf%cfg%jmino_,this%vf%cfg%jmin-1 + do i=this%vf%cfg%imino_,this%vf%cfg%imaxo_ + ! Extract plane data and copy in overlap + plane=getPlane(this%vf%liquid_gas_interface(i,this%vf%cfg%jmin,k),0) + eps_plane = 1.0e-30_WP + nplanes_src = getNumberOfPlanes(this%vf%liquid_gas_interface(i,this%vf%cfg%jmin,k)) + if (nplanes_src.eq.0) cycle + call construct_2pt(cell,[this%vf%cfg%x(i ),this%vf%cfg%y(j ),this%vf%cfg%z(k )],& + & [this%vf%cfg%x(i+1),this%vf%cfg%y(j+1),this%vf%cfg%z(k+1)]) + plane(4)=dot_product(plane(1:3),[this%vf%cfg%xm(i),this%vf%cfg%ym(j),this%vf%cfg%zm(k)]) + if (sum(plane(1:3)**2) .le. eps_plane) cycle + call setNumberOfPlanes(this%vf%liquid_gas_interface(i,j,k),1) + call setPlane(this%vf%liquid_gas_interface(i,j,k),0,plane(1:3),plane(4)) + call matchVolumeFraction(cell,this%vf%VF(i,j,k),this%vf%liquid_gas_interface(i,j,k)) + end do + end do + end do + end if + end block neumann_irl + + ! Create discontinuous polygon mesh from IRL interface + call this%vf%polygonalize_interface() + ! Calculate distance from polygons + call this%vf%distance_from_polygon() + ! Calculate subcell phasic volumes + call this%vf%subcell_vol() + ! Calculate curvature + call this%vf%get_curvature() + ! Reset moments to guarantee compatibility with interface reconstruction + call this%vf%reset_volume_moments() + end block create_and_initialize_vof + + ! Create an iterator for removing VOF at edges + create_iterator: block + this%vof_removal_layer=iterator(this%cfg,'VOF removal',vof_removal_layer_locator) + end block create_iterator + + + ! Create a multiphase flow solver with bconds + create_flow_solver: block + use mathtools, only: Pi + use param, only: param_read + use tpns_class, only: dirichlet,clipped_neumann,bcond + use hypre_str_class, only: pcg_pfmg2 + type(bcond), pointer :: mybc + integer :: n,i,j,k + ! Create flow solver + this%fs=tpns(cfg=this%cfg,name='Two-phase NS') + ! Set fluid properties + call param_read("Liquid density",this%fs%rho_l); + call param_read("Gas density",this%fs%rho_g); + call param_read("Liquid viscosity",this%fs%visc_l); + call param_read("Gas viscosity",this%fs%visc_g); + call param_read("Surface tension",this%fs%sigma); + + ! Define inflow boundary condition on the left + call this%fs%add_bcond(name='inflow',type=dirichlet,face='x',dir=-1,canCorrect=.false.,locator=xm_locator) + ! Define outflow boundary condition on the right + call this%fs%add_bcond(name='outflow',type=clipped_neumann,face='x',dir=+1,canCorrect=.true.,locator=xp_locator) + ! Define jet boundary condition on the bottom + call this%fs%add_bcond(name='jet' ,type=dirichlet,face='y',dir=-1,canCorrect=.false.,locator=jet_bdy) + ! Define gravity as vector for flow solver + this%fs%gravity(2) = this%gravity + + ! Configure pressure solver + this%ps=hypre_str(cfg=this%cfg,name='Pressure',method=pcg_pfmg2,nst=7) + this%ps%maxlevel=16 + call param_read('Pressure iteration',this%ps%maxit) + call param_read('Pressure tolerance',this%ps%rcvg) + ! Configure implicit velocity solver + !this%vs=ddadi(cfg=this%cfg,name='Velocity',nst=7) + ! Setup the solver + call this%fs%setup(pressure_solver=this%ps)!,implicit_solver=this%vs) + ! Zero initial field + this%fs%U=0.0_WP; this%fs%V=0.0_WP; this%fs%W=0.0_WP + ! Apply convective velocity + call this%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) + this%fs%U(i,j,k)=1.0_WP + end do + ! Apply jet velocity + call this%fs%get_bcond('jet',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) + this%fs%V(i,j,k)=0 ! Start with zero velocity this%Vjet + end do + ! Apply all other boundary conditions + call this%fs%apply_bcond(this%time%t,this%time%dt) + ! Adjust MFR for global mass balance + call this%fs%correct_mfr() + ! Compute divergence + call this%fs%get_div() + ! Compute cell-centered velocity + call this%fs%interp_vel(this%Ui,this%Vi,this%Wi) + end block create_flow_solver + + ! Create CCL + create_ccl: block + ! Initialize CCL + call this%ccl%initialize(pg=this%cfg%pgrid,name='ccl') + end block create_ccl + + ! Handle restart/saves here + handle_restart: block + use param, only: param_read + use string, only: str_medium + use filesys, only: makedir,isdir + use irl_fortran_interface, only: setNumberOfPlanes,setPlane + character(len=str_medium) :: timestamp + integer, dimension(3) :: iopartition + real(WP), dimension(:,:,:), allocatable :: P11,P12,P13,P14 + real(WP), dimension(:,:,:), allocatable :: P21,P22,P23,P24 + integer :: i,j,k + ! Create event for saving restart files + this%save_evt=event(this%time,'Restart output') + call param_read('Restart output period',this%save_evt%tper) + ! Check if we are restarting + call param_read('Restart from',timestamp,default='') + this%restarted=.false.; if (len_trim(timestamp).gt.0) this%restarted=.true. + ! Read in the I/O partition + call param_read('I/O partition',iopartition) + ! Perform pardata initialization + if (this%restarted) then + ! Read in the file + call this%df%initialize(pg=this%cfg,iopartition=iopartition,fdata='restart/data_'//trim(timestamp)) + ! Read in the planes directly and set the IRL interface + allocate(P11(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)); call this%df%pull(name='P11',var=P11) + allocate(P12(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)); call this%df%pull(name='P12',var=P12) + allocate(P13(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)); call this%df%pull(name='P13',var=P13) + allocate(P14(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)); call this%df%pull(name='P14',var=P14) + allocate(P21(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)); call this%df%pull(name='P21',var=P21) + allocate(P22(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)); call this%df%pull(name='P22',var=P22) + allocate(P23(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)); call this%df%pull(name='P23',var=P23) + allocate(P24(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)); call this%df%pull(name='P24',var=P24) + do k=this%vf%cfg%kmin_,this%vf%cfg%kmax_ + do j=this%vf%cfg%jmin_,this%vf%cfg%jmax_ + do i=this%vf%cfg%imin_,this%vf%cfg%imax_ + ! Check if the second plane is meaningful + if (this%vf%two_planes.and.P21(i,j,k)**2+P22(i,j,k)**2+P23(i,j,k)**2.gt.0.0_WP) then + call setNumberOfPlanes(this%vf%liquid_gas_interface(i,j,k),2) + call setPlane(this%vf%liquid_gas_interface(i,j,k),0,[P11(i,j,k),P12(i,j,k),P13(i,j,k)],P14(i,j,k)) + call setPlane(this%vf%liquid_gas_interface(i,j,k),1,[P21(i,j,k),P22(i,j,k),P23(i,j,k)],P24(i,j,k)) + else + call setNumberOfPlanes(this%vf%liquid_gas_interface(i,j,k),1) + call setPlane(this%vf%liquid_gas_interface(i,j,k),0,[P11(i,j,k),P12(i,j,k),P13(i,j,k)],P14(i,j,k)) + end if + end do + end do + end do + call this%vf%sync_interface() + deallocate(P11,P12,P13,P14,P21,P22,P23,P24) + ! Reset moments + call this%vf%reset_volume_moments() + ! Update the band + call this%vf%update_band() + ! Create discontinuous polygon mesh from IRL interface + call this%vf%polygonalize_interface() + ! Calculate distance from polygons + call this%vf%distance_from_polygon() + ! Calculate subcell phasic volumes + call this%vf%subcell_vol() + ! Calculate curvature + call this%vf%get_curvature() + ! Now read in the velocity solver data + call this%df%pull(name='U',var=this%fs%U) + call this%df%pull(name='V',var=this%fs%V) + call this%df%pull(name='W',var=this%fs%W) + call this%df%pull(name='P',var=this%fs%P) + call this%df%pull(name='Pjx',var=this%fs%Pjx) + call this%df%pull(name='Pjy',var=this%fs%Pjy) + call this%df%pull(name='Pjz',var=this%fs%Pjz) + ! Apply all other boundary conditions + call this%fs%apply_bcond(this%time%t,this%time%dt) + ! Compute MFR through all boundary conditions + call this%fs%get_mfr() + ! Adjust MFR for global mass balance + call this%fs%correct_mfr() + ! Compute cell-centered velocity + call this%fs%interp_vel(this%Ui,this%Vi,this%Wi) + ! Compute divergence + call this%fs%get_div() + ! Also update time + call this%df%pull(name='t' ,val=this%time%t ) + call this%df%pull(name='dt',val=this%time%dt) + this%time%told=this%time%t-this%time%dt + !this%time%dt=this%time%dtmax !< Force max timestep size anyway + else + ! We are not restarting, prepare a new directory for storing restart files + if (this%cfg%amRoot) then + if (.not.isdir('restart')) call makedir('restart') + end if + ! Prepare pardata object for saving restart files + call this%df%initialize(pg=this%cfg,iopartition=iopartition,filename=trim(this%cfg%name),nval=2,nvar=15) + this%df%valname=['t ','dt'] + this%df%varname=['U ','V ','W ','P ','Pjx','Pjy','Pjz','P11','P12','P13','P14','P21','P22','P23','P24'] + end if + end block handle_restart + + + ! Create surfmesh object for interface polygon output + create_smesh: block + use irl_fortran_interface, only: getNumberOfPlanes,getNumberOfVertices + integer :: i,j,k,np,nplane + this%smesh=surfmesh(nvar=2,name='plic') + this%smesh%varname(1)='nplane' + this%smesh%varname(2)='thickness' + ! Transfer polygons to smesh + call this%vf%update_surfmesh(this%smesh) + ! ! Calculate thickness + ! call this%vf%get_thickness() + ! ! Populate nplane and thickness variables + ! this%smesh%var(1,:)=1.0_WP + ! np=0 + ! do k=this%vf%cfg%kmin_,this%vf%cfg%kmax_ + ! do j=this%vf%cfg%jmin_,this%vf%cfg%jmax_ + ! do i=this%vf%cfg%imin_,this%vf%cfg%imax_ + ! if (this%cfg%VF(i,j,k).lt.2.0_WP*epsilon(1.0_WP)) cycle ! Skip cells below VF threshold + ! do nplane=1,getNumberOfPlanes(this%vf%liquid_gas_interface(i,j,k)) + ! if (getNumberOfVertices(this%vf%interface_polygon(nplane,i,j,k)).gt.0) then + ! np=np+1; this%smesh%var(1,np)=real(getNumberOfPlanes(this%vf%liquid_gas_interface(i,j,k)),WP) + ! this%smesh%var(2,np)=this%vf%thickness(i,j,k) + ! end if + ! end do + ! end do + ! end do + ! end do + end block create_smesh + + + ! Add Ensight output + create_ensight: block + use param, only: param_read + ! Create Ensight output from cfg + this%ens_out=ensight(cfg=this%cfg,name='ljcf') + ! Create event for Ensight output + this%ens_evt=event(time=this%time,name='Ensight output') + call param_read('Ensight output period',this%ens_evt%tper) + ! Add variables to output + call this%ens_out%add_vector('velocity',this%Ui,this%Vi,this%Wi) + call this%ens_out%add_scalar('VOF',this%vf%VF) + call this%ens_out%add_scalar('curvature',this%vf%curv) + call this%ens_out%add_scalar('pressure',this%fs%P) + call this%ens_out%add_surface('plic',this%smesh) + call this%ens_out%add_scalar('Gib',this%cfg%Gib) + ! Output to ensight + if (this%ens_evt%occurs()) call this%ens_out%write_data(this%time%t) + end block create_ensight + + + ! Create a monitor file + create_monitor: block + ! Prepare some info about fields + call this%fs%get_cfl(this%time%dt,this%time%cfl) + call this%fs%get_max() + call this%vf%get_max() + ! Create simulation monitor + this%mfile=monitor(this%fs%cfg%amRoot,'simulation_atom') + call this%mfile%add_column(this%time%n,'Timestep number') + call this%mfile%add_column(this%time%t,'Time') + call this%mfile%add_column(this%time%dt,'Timestep size') + call this%mfile%add_column(this%time%cfl,'Maximum CFL') + call this%mfile%add_column(this%fs%Umax,'Umax') + call this%mfile%add_column(this%fs%Vmax,'Vmax') + call this%mfile%add_column(this%fs%Wmax,'Wmax') + call this%mfile%add_column(this%fs%Pmax,'Pmax') + call this%mfile%add_column(this%vf%VFint,'VOF integral') + call this%mfile%add_column(this%vf%SDint,'SD integral') + call this%mfile%add_column(this%vof_removed,'VOF removed') + call this%mfile%add_column(this%vf%flotsam_error,'Flotsam error') + ! call this%mfile%add_column(this%vf%thinstruct_error,'Film error') + call this%mfile%add_column(this%fs%divmax,'Maximum divergence') + call this%mfile%add_column(this%fs%psolv%it,'Pressure iteration') + call this%mfile%add_column(this%fs%psolv%rerr,'Pressure error') + call this%mfile%write() + ! Create CFL monitor + this%cflfile=monitor(this%fs%cfg%amRoot,'cfl_atom') + call this%cflfile%add_column(this%time%n,'Timestep number') + call this%cflfile%add_column(this%time%t,'Time') + call this%cflfile%add_column(this%fs%CFLst,'STension CFL') + call this%cflfile%add_column(this%fs%CFLc_x,'Convective xCFL') + call this%cflfile%add_column(this%fs%CFLc_y,'Convective yCFL') + call this%cflfile%add_column(this%fs%CFLc_z,'Convective zCFL') + call this%cflfile%add_column(this%fs%CFLv_x,'Viscous xCFL') + call this%cflfile%add_column(this%fs%CFLv_y,'Viscous yCFL') + call this%cflfile%add_column(this%fs%CFLv_z,'Viscous zCFL') + call this%cflfile%write() + ! Create LJCF monitor + this%ljcf_file=monitor(this%fs%cfg%amRoot,'ljcf') + call this%ljcf_file%add_column(this%time%n,'Timestep number') + call this%ljcf_file%add_column(this%time%t,'Time') + call this%ljcf_file%add_column(this%InjectionVelocity,'Injection Velocity') + call this%ljcf_file%write() + end block create_monitor + + + ! Create a timing monitor + create_timing: block + ! Create timers + this%tstep =timer(comm=this%cfg%comm,name='Timestep') + this%tvof =timer(comm=this%cfg%comm,name='VOFsolve') + this%tvel =timer(comm=this%cfg%comm,name='Velocity') + this%tpres =timer(comm=this%cfg%comm,name='Pressure') + ! Create corresponding monitor file + this%timefile=monitor(this%fs%cfg%amRoot,'timing') + call this%timefile%add_column(this%time%n,'Timestep number') + call this%timefile%add_column(this%time%t,'Time') + call this%timefile%add_column(this%tstep%time ,trim(this%tstep%name)) + call this%timefile%add_column(this%tvof%time ,trim(this%tvof%name)) + call this%timefile%add_column(this%tvel%time ,trim(this%tvel%name)) + call this%timefile%add_column(this%tpres%time ,trim(this%tpres%name)) + end block create_timing + + contains + + + !> Function that localizes the x- boundary + function xm_locator(pg,i,j,k) result(isIn) + use pgrid_class, only: pgrid + class(pgrid), intent(in) :: pg + integer, intent(in) :: i,j,k + logical :: isIn + isIn=.false. + if (i.eq.pg%imin) isIn=.true. + end function xm_locator + + + !> Function that localizes the x+ boundary + function xp_locator(pg,i,j,k) result(isIn) + use pgrid_class, only: pgrid + 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 xp_locator + + + !> Function that localizes region of VOF removal + function vof_removal_layer_locator(pg,i,j,k) result(isIn) + use pgrid_class, only: pgrid + class(pgrid), intent(in) :: pg + integer, intent(in) :: i,j,k + logical :: isIn + isIn=.false. + if (i.ge.pg%imax-this%nlayer) isIn=.true. + end function vof_removal_layer_locator + + + !> Function that defines a level set function for a half droplet + function levelset_halfdrop(xyz,t) result(G) + implicit none + real(WP), dimension(3),intent(in) :: xyz + real(WP), intent(in) :: t + real(WP) :: G + G=0.5_WP*this%djet-sqrt(xyz(1)**2+(xyz(2)-this%cfg%y(this%cfg%jmin))**2+xyz(3)**2) + end function levelset_halfdrop + + !> Function that localizes the jet(s) initial location + function jet(pg,i,j,k) result(isIn) + use pgrid_class, only: pgrid + implicit none + class(pgrid), intent(in) :: pg + integer, intent(in) :: i,j,k + integer :: ii,kk + real(WP), dimension(3) :: xyz + logical :: isIn + ! isIn=.false. + ! xyz(1)=pg%xm(i); xyz(2)=pg%ym(j); xyz(3)=pg%zm(k) + ! if (levelset_halfdrop(xyz,0.0_WP).gt.0.0_WP) isIn=.true. + isIn=.false. + ! Check if any of cell corners are in jet + do ii = i,i+1 + do kk = k,k+1 + xyz(1)=pg%x(ii); xyz(2)=pg%y(pg%jmin); xyz(3)=pg%z(kk) + if (levelset_halfdrop(xyz,0.0_WP).gt.0.0_WP) then + isIn=.true. + return + end if + end do + end do + end function jet + + !> Function that localizes the walls surrounding the jets + function wall(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 (j.le.pg%jmin-1+this%nwall.and.(.not.jet(pg,i,j,k))) isIn=.true. + end function wall + + !> Function that localizes the jet(s) BCs at edge of domain + function jet_bdy(pg,i,j,k) result(isIn) + use pgrid_class, only: pgrid + implicit none + class(pgrid), intent(in) :: pg + integer, intent(in) :: i,j,k + real(WP), dimension(3) :: xyz + logical :: isIn + isIn=.false. + xyz(1)=pg%xm(i); xyz(2)=pg%y(j); xyz(3)=pg%zm(k) + if (j.eq.pg%jmin.and.jet(pg,i,j,k)) isIn=.true. + end function jet_bdy + + + end subroutine init + + + !> Take one time step + subroutine step(this) + use tpns_class, only: arithmetic_visc + implicit none + class(ljcf), intent(inout) :: this + + ! Reset all timers and start timestep timer + call this%tstep%reset() + call this%tvof%reset() + call this%tvel%reset() + call this%tpres%reset() + call this%tstep%start() + + ! Increment time + call this%fs%get_cfl(this%time%dt,this%time%cfl) + call this%time%adjust_dt() + call this%time%increment() + + ! Apply jet velocity + apply_bc: block + use tpns_class, only: bcond + use mpi_f08, only: MPI_ALLREDUCE,MPI_SUM,MPI_IN_PLACE + use parallel, only: MPI_REAL_WP + type(bcond), pointer :: mybc + real(WP) :: liqVolInjected_dt + integer :: n,i,j,k + ! Compute injection velocity + if (this%time%t .lt. this%endInjectionTime) then + this%InjectionVelocity=this%gravity*this%time%t ! Velocity increases linearly with time + else + this%InjectionVelocity=0.0_WP ! Velocity stops once volume is reached + end if + ! Apply injection velocity to the jet boundary condition + call this%fs%get_bcond('jet',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) + this%fs%V(i,j,k) = this%InjectionVelocity + end do + end block apply_bc + + ! Remember old VOF + this%vf%VFold=this%vf%VF + + ! Remember old velocity + this%fs%Uold=this%fs%U + this%fs%Vold=this%fs%V + this%fs%Wold=this%fs%W + + ! Prepare old sflaggered density (at n) + call this%fs%get_olddensity(vf=this%vf) + + ! VOF solver step + call this%tvof%start() ! Start VOF timer + call this%vf%advance(dt=this%time%dt,U=this%fs%U,V=this%fs%V,W=this%fs%W) + call this%tvof%stop() ! Stop VOF timer + + ! Prepare new sflaggered viscosity (at n+1) + call this%fs%get_viscosity(vf=this%vf,strat=arithmetic_visc) + + ! Perform sub-iterations + do while (this%time%it.le.this%time%itmax) + + ! Start velocity timer + call this%tvel%start() + + ! Build mid-time velocity + this%fs%U=0.5_WP*(this%fs%U+this%fs%Uold) + this%fs%V=0.5_WP*(this%fs%V+this%fs%Vold) + this%fs%W=0.5_WP*(this%fs%W+this%fs%Wold) + + ! Preliminary mass and momentum transport step at the interface + call this%fs%prepare_advection_upwind(dt=this%time%dt) + + ! Explicit calculation of drho*u/dt from NS + call this%fs%get_dmomdt(this%resU,this%resV,this%resW) + + ! Assemble explicit residual + this%resU=-2.0_WP*this%fs%rho_U*this%fs%U+(this%fs%rho_Uold+this%fs%rho_U)*this%fs%Uold+this%time%dt*this%resU + this%resV=-2.0_WP*this%fs%rho_V*this%fs%V+(this%fs%rho_Vold+this%fs%rho_V)*this%fs%Vold+this%time%dt*this%resV + this%resW=-2.0_WP*this%fs%rho_W*this%fs%W+(this%fs%rho_Wold+this%fs%rho_W)*this%fs%Wold+this%time%dt*this%resW + + ! Form implicit residuals + call this%fs%solve_implicit(this%time%dt,this%resU,this%resV,this%resW) + + ! Apply these residuals + this%fs%U=2.0_WP*this%fs%U-this%fs%Uold+this%resU + this%fs%V=2.0_WP*this%fs%V-this%fs%Vold+this%resV + this%fs%W=2.0_WP*this%fs%W-this%fs%Wold+this%resW + + ! Apply IB forcing to enforce BC at the pipe walls + ibforcing: block + integer :: i,j,k + do k=this%fs%cfg%kmin_,this%fs%cfg%kmax_ + do j=this%fs%cfg%jmin_,this%fs%cfg%jmax_ + do i=this%fs%cfg%imin_,this%fs%cfg%imax_ + this%fs%U(i,j,k)=this%fs%U(i,j,k)*sum(this%fs%itpr_x(:,i,j,k)*this%cfg%VF(i-1:i,j,k)) + this%fs%V(i,j,k)=this%fs%V(i,j,k)*sum(this%fs%itpr_y(:,i,j,k)*this%cfg%VF(i,j-1:j,k)) + this%fs%W(i,j,k)=this%fs%W(i,j,k)*sum(this%fs%itpr_z(:,i,j,k)*this%cfg%VF(i,j,k-1:k)) + end do + end do + end do + call this%fs%cfg%sync(this%fs%U) + call this%fs%cfg%sync(this%fs%V) + call this%fs%cfg%sync(this%fs%W) + end block ibforcing + + ! Apply boundary conditions + call this%fs%apply_bcond(this%time%t,this%time%dt) + + ! Stop velocity timer and start pressure timer + call this%tvel%stop() + call this%tpres%start() + + ! Solve Poisson equation + call this%fs%update_laplacian() + call this%fs%correct_mfr() + call this%fs%get_div() + call this%fs%add_surface_tension_jump(dt=this%time%dt,div=this%fs%div,vf=this%vf) + ! call this%fs%add_surface_tension_jump_twoVF(dt=this%time%dt,div=this%fs%div,vf=this%vf) + this%fs%psolv%rhs=-this%fs%cfg%vol*this%fs%div/this%time%dt + this%fs%psolv%sol=0.0_WP + call this%fs%psolv%solve() + call this%fs%shift_p(this%fs%psolv%sol) + + ! Correct velocity + call this%fs%get_pgrad(this%fs%psolv%sol,this%resU,this%resV,this%resW) + this%fs%P=this%fs%P+this%fs%psolv%sol + this%fs%U=this%fs%U-this%time%dt*this%resU/max(epsilon(0.0_WP),this%fs%rho_U) + this%fs%V=this%fs%V-this%time%dt*this%resV/max(epsilon(0.0_WP),this%fs%rho_V) + this%fs%W=this%fs%W-this%time%dt*this%resW/max(epsilon(0.0_WP),this%fs%rho_W) + + ! Apply boundary conditions + call this%fs%apply_bcond(this%time%t,this%time%dt) + + ! Stop pressure timer + call this%tpres%stop() + + ! Increment sub-iteration counter + this%time%it=this%time%it+1 + + end do + + ! Recompute interpolated velocity and divergence + call this%fs%interp_vel(this%Ui,this%Vi,this%Wi) + call this%fs%get_div() + + ! Remove VOF at edge of domain + remove_vof: block + use mpi_f08, only: MPI_ALLREDUCE,MPI_SUM,MPI_IN_PLACE + use parallel, only: MPI_REAL_WP + integer :: n,i,j,k,ierr + this%vof_removed=0.0_WP + do n=1,this%vof_removal_layer%no_ + i=this%vof_removal_layer%map(1,n) + j=this%vof_removal_layer%map(2,n) + k=this%vof_removal_layer%map(3,n) + if (n.le.this%vof_removal_layer%n_) this%vof_removed=this%vof_removed+this%cfg%vol(i,j,k)*this%vf%VF(i,j,k) + this%vf%VF(i,j,k)=0.0_WP + end do + call MPI_ALLREDUCE(MPI_IN_PLACE,this%vof_removed,1,MPI_REAL_WP,MPI_SUM,this%cfg%comm,ierr) + call this%vf%clean_irl_and_band() + end block remove_vof + + + ! Output to ensight + if (this%ens_evt%occurs()) then + ! Update surface mesh + update_smesh: block + use irl_fortran_interface, only: getNumberOfPlanes,getNumberOfVertices + integer :: i,j,k,np,nplane + ! Transfer polygons to smesh + call this%vf%update_surfmesh(this%smesh) + ! ! Also populate nplane variable + ! this%smesh%var(1,:)=1.0_WP + ! np=0 + ! do k=this%vf%cfg%kmin_,this%vf%cfg%kmax_ + ! do j=this%vf%cfg%jmin_,this%vf%cfg%jmax_ + ! do i=this%vf%cfg%imin_,this%vf%cfg%imax_ + ! if (this%cfg%VF(i,j,k).lt.2.0_WP*epsilon(1.0_WP)) cycle ! Skip cells below VF threshold + ! do nplane=1,getNumberOfPlanes(this%vf%liquid_gas_interface(i,j,k)) + ! if (getNumberOfVertices(this%vf%interface_polygon(nplane,i,j,k)).gt.0) then + ! np=np+1; this%smesh%var(1,np)=real(getNumberOfPlanes(this%vf%liquid_gas_interface(i,j,k)),WP) + ! this%smesh%var(2,np)=this%vf%thickness(i,j,k) + ! end if + ! end do + ! end do + ! end do + ! end do + end block update_smesh + call this%ens_out%write_data(this%time%t) + end if + + ! Stop timestep timer + call this%tstep%stop() + + ! Perform and output monitoring + call this%fs%get_max() + call this%vf%get_max() + call this%mfile%write() + call this%cflfile%write() + call this%timefile%write() + call this%ljcf_file%write() + + ! Finally, see if it's time to save restart files + if (this%save_evt%occurs()) then + save_restart: block + use irl_fortran_interface + use string, only: str_medium + character(len=str_medium) :: timestamp + real(WP), dimension(:,:,:), allocatable :: P11,P12,P13,P14 + real(WP), dimension(:,:,:), allocatable :: P21,P22,P23,P24 + integer :: i,j,k + real(WP), dimension(4) :: plane + ! Handle IRL data + allocate(P11(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + allocate(P12(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + allocate(P13(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + allocate(P14(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + allocate(P21(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + allocate(P22(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + allocate(P23(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + allocate(P24(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) + do k=this%vf%cfg%kmino_,this%vf%cfg%kmaxo_ + do j=this%vf%cfg%jmino_,this%vf%cfg%jmaxo_ + do i=this%vf%cfg%imino_,this%vf%cfg%imaxo_ + ! First plane + plane=getPlane(this%vf%liquid_gas_interface(i,j,k),0) + P11(i,j,k)=plane(1); P12(i,j,k)=plane(2); P13(i,j,k)=plane(3); P14(i,j,k)=plane(4) + ! Second plane + plane=0.0_WP + if (getNumberOfPlanes(this%vf%liquid_gas_interface(i,j,k)).eq.2) plane=getPlane(this%vf%liquid_gas_interface(i,j,k),1) + P21(i,j,k)=plane(1); P22(i,j,k)=plane(2); P23(i,j,k)=plane(3); P24(i,j,k)=plane(4) + end do + end do + end do + ! Prefix for files + write(timestamp,'(es12.5)') this%time%t + ! Populate df and write it + call this%df%push(name='t' ,val=this%time%t ) + call this%df%push(name='dt' ,val=this%time%dt) + call this%df%push(name='U' ,var=this%fs%U ) + call this%df%push(name='V' ,var=this%fs%V ) + call this%df%push(name='W' ,var=this%fs%W ) + call this%df%push(name='P' ,var=this%fs%P ) + call this%df%push(name='Pjx',var=this%fs%Pjx ) + call this%df%push(name='Pjy',var=this%fs%Pjy ) + call this%df%push(name='Pjz',var=this%fs%Pjz ) + call this%df%push(name='P11',var=P11 ) + call this%df%push(name='P12',var=P12 ) + call this%df%push(name='P13',var=P13 ) + call this%df%push(name='P14',var=P14 ) + call this%df%push(name='P21',var=P21 ) + call this%df%push(name='P22',var=P22 ) + call this%df%push(name='P23',var=P23 ) + call this%df%push(name='P24',var=P24 ) + call this%df%write(fdata='restart/data_'//trim(adjustl(timestamp))) + ! Deallocate + deallocate(P11,P12,P13,P14,P21,P22,P23,P24) + end block save_restart + end if + + contains + !> Function that identifies cells that need a label + logical function make_label(i,j,k) + implicit none + integer, intent(in) :: i,j,k + if (this%vf%VF(i,j,k).gt.0.0_WP) then + make_label=.true. + else + make_label=.false. + end if + end function make_label + + !> Function that identifies if cell pairs have same label + logical function same_label(i1,j1,k1,i2,j2,k2) + implicit none + integer, intent(in) :: i1,j1,k1,i2,j2,k2 + if (this%vf%VF(i1,j1,k1).gt.0.0_WP .and. this%vf%VF(i2,j2,k2).gt.0.0_WP) then + same_label=.true. + else + same_label=.false. + end if + same_label=.true. + end function same_label + + end subroutine step + + + !> Finalize nozzle simulation + subroutine final(this) + implicit none + class(ljcf), intent(inout) :: this + + ! Deallocate work arrays + deallocate(this%resU,this%resV,this%resW,this%Ui,this%Vi,this%Wi) + + end subroutine final + + +end module ljcf_class \ No newline at end of file diff --git a/examples/ljcf_dimensinal_ib/src/simulation.f90 b/examples/ljcf_dimensinal_ib/src/simulation.f90 new file mode 100644 index 000000000..5960290a7 --- /dev/null +++ b/examples/ljcf_dimensinal_ib/src/simulation.f90 @@ -0,0 +1,161 @@ +!> Various definitions and tools for running an NGA2 simulation +module simulation + use precision, only: WP + use hit_class, only: hit + use ljcf_class, only: ljcf + use coupler_class, only: coupler + implicit none + private + + !> HIT simulation + type(hit) :: turb + logical :: isInHITGrp + + !> LJCF atomization simulation + type(ljcf) :: atom + + !> Coupler from turb to atom + type(coupler) :: xcpl,ycpl,zcpl + + public :: simulation_init,simulation_run,simulation_final + +contains + + + !> Initialization of our simulation + subroutine simulation_init + use mpi_f08, only: MPI_Group + implicit none + type(MPI_Group) :: hit_group + + ! Initialize atomization simulation + call atom%init() + + ! Create an MPI group using leftmost processors only + ! create_hit_group: block + ! use parallel, only: group,comm + ! use mpi_f08, only: MPI_Group_incl + ! integer, dimension(:), allocatable :: ranks + ! integer, dimension(3) :: coord + ! integer :: n,ngrp,ierr,ny,nz + ! ngrp=atom%cfg%npy*atom%cfg%npz + ! allocate(ranks(ngrp)) + ! ngrp=0 + ! do nz=1,atom%cfg%npz + ! do ny=1,atom%cfg%npy + ! ngrp=ngrp+1 + ! coord=[0,ny-1,nz-1] + ! call MPI_CART_RANK(atom%cfg%comm,coord,ranks(ngrp),ierr) + ! end do + ! end do + ! call MPI_Group_incl(group,ngrp,ranks,hit_group,ierr) + ! if (atom%cfg%iproc.eq.1) then + ! isInHITGrp=.true. + ! else + ! isInHITGrp=.false. + ! end if + ! end block create_hit_group + + ! ! Initialize HIT simulation + ! if (isInHITGrp) call turb%init(group=hit_group,xend=atom%cfg%x(atom%cfg%imin)) + + ! ! If restarting, the domains could be out of sync, so resync + ! ! time by forcing HIT to be at same time as jet + ! if (isInHITGrp) then + ! turb%time%t=atom%time%t + ! turb%time%told=turb%time%t-turb%time%dt + ! end if + + ! ! Initialize couplers from turb to atom + ! create_coupler: block + ! use parallel, only: group + ! xcpl=coupler(src_grp=hit_group,dst_grp=group,name='turb2atom') + ! ycpl=coupler(src_grp=hit_group,dst_grp=group,name='turb2atom') + ! zcpl=coupler(src_grp=hit_group,dst_grp=group,name='turb2atom') + ! if (isInHITGrp) call xcpl%set_src(turb%cfg,'x') + ! if (isInHITGrp) call ycpl%set_src(turb%cfg,'y') + ! if (isInHITGrp) call zcpl%set_src(turb%cfg,'z') + ! call xcpl%set_dst(atom%cfg,'x'); call xcpl%initialize() + ! call ycpl%set_dst(atom%cfg,'y'); call ycpl%initialize() + ! call zcpl%set_dst(atom%cfg,'z'); call zcpl%initialize() + ! end block create_coupler + + end subroutine simulation_init + + + !> Run the simulation + subroutine simulation_run + implicit none + + ! Atomization drives overall time integration + do while (.not.atom%time%done()) + + ! ! Advance HIT simulation and transfer velocity info + ! if (isInHITGrp) then + ! ! Advance HIT with maximum stable dt until caught up + ! advance_hit: block + ! real(WP) :: dt + ! dt=0.15_WP*turb%cfg%min_meshsize/turb%Urms_tgt + ! do while (turb%time%t.le.atom%time%t) + ! call turb%step(dt) + ! end do + ! end block advance_hit + ! end if + + ! Handle coupling between HIT and atomization simulation + coupling: block + ! ! Push data from HIT simulation + ! if (isInHITGrp) then + ! push_velocity: block + ! real(WP) :: rescaling,tinterp + ! rescaling=turb%ti/turb%Urms_tgt + ! tinterp=(turb%time%t-atom%time%t)/(turb%time%t-turb%time%told) + ! turb%resU=rescaling*((1.0_WP-tinterp)*turb%fs%U+tinterp*turb%fs%Uold); call xcpl%push(turb%resU) + ! turb%resV=rescaling*((1.0_WP-tinterp)*turb%fs%V+tinterp*turb%fs%Vold); call ycpl%push(turb%resV) + ! turb%resW=rescaling*((1.0_WP-tinterp)*turb%fs%W+tinterp*turb%fs%Wold); call zcpl%push(turb%resW) + ! end block push_velocity + ! end if + ! ! Transfer and pull + ! call xcpl%transfer(); call xcpl%pull(atom%resU) + ! call ycpl%transfer(); call ycpl%pull(atom%resV) + ! call zcpl%transfer(); call zcpl%pull(atom%resW) + ! Apply time-dependent Dirichlet condition + apply_boundary_condition: block + use param, only: param_read + use tpns_class, only: bcond + type(bcond), pointer :: mybc + integer :: n,i,j,k + real(WP) :: air_vel + call atom%fs%get_bcond('inflow',mybc) + call param_read("Air velocity",air_vel) + do n=1,mybc%itr%no_ + i=mybc%itr%map(1,n); j=mybc%itr%map(2,n); k=mybc%itr%map(3,n) + atom%fs%U(i ,j,k)=air_vel !atom%resU(i ,j,k)+1.0_WP + atom%fs%V(i-1,j,k)=0.0_WP !atom%resV(i-1,j,k) + atom%fs%W(i-1,j,k)=0.0_WP !atom%resW(i-1,j,k) + end do + end block apply_boundary_condition + end block coupling + + ! Advance atomization simulation + call atom%step() + + end do + + end subroutine simulation_run + + + !> Finalize the NGA2 simulation + subroutine simulation_final + implicit none + + ! Finalize atomization simulation + call atom%final() + + ! Finalize HIT simulation + ! if (isInHITGrp) call turb%final() + + end subroutine simulation_final + + +end module simulation \ No newline at end of file From 4850230b7294737391550922db99f3c86c582a8a Mon Sep 17 00:00:00 2001 From: Mark Owkes Date: Mon, 18 May 2026 17:10:57 -0600 Subject: [PATCH 38/70] Made jet inflow = g*time --- examples/amr_ljcf/src/simulation.f90 | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/examples/amr_ljcf/src/simulation.f90 b/examples/amr_ljcf/src/simulation.f90 index 8c4ac4300..8061689da 100644 --- a/examples/amr_ljcf/src/simulation.f90 +++ b/examples/amr_ljcf/src/simulation.f90 @@ -160,6 +160,7 @@ subroutine dirichlet_velocity(solver,lvl,time,face,bx,comp,p) case (1) ! Inflow in X- select case (comp) case ('U') ! Staggered U=Ujet + Ujet = gravity(1)*time do k=bx%lo(3),bx%hi(3); do j=bx%lo(2),bx%hi(2); do i=bx%lo(1),bx%hi(1) rad=sqrt((amr%ylo+(real(j,WP)+0.5_WP)*amr%dy(lvl))**2+(amr%zlo+(real(k,WP)+0.5_WP)*amr%dz(lvl))**2) if (amr%nz.eq.1) rad=sqrt((amr%ylo+(real(j,WP)+0.5_WP)*amr%dy(lvl))**2) @@ -384,7 +385,7 @@ subroutine simulation_init() ! Set densities fs%rhoG=1.0_WP; call param_read('Density ratio',fs%rhoL) ! Read in momentum flux ratio and set liquid velocity - call param_read('Mom flux ratio',Ujet); Ujet=sqrt(Ujet/fs%rhoL) + ! call param_read('Mom flux ratio',Ujet); Ujet=sqrt(Ujet/fs%rhoL) ! Set surface tension coefficient call param_read('Weber number',fs%sigma); fs%sigma=1.0_WP/fs%sigma ! Set molecular viscosities From acb436c17f255cd2c81ea33bfbf44258b6424bc7 Mon Sep 17 00:00:00 2001 From: Mark Owkes Date: Wed, 20 May 2026 13:50:08 -0600 Subject: [PATCH 39/70] Adjusted domain size and non-dimensional parameters to match benchmark case --- examples/amr_ljcf/input | 28 +++++++++++++++++----------- examples/amr_ljcf/src/simulation.f90 | 11 ++++++++--- 2 files changed, 25 insertions(+), 14 deletions(-) diff --git a/examples/amr_ljcf/input b/examples/amr_ljcf/input index fd563e009..b134314ff 100644 --- a/examples/amr_ljcf/input +++ b/examples/amr_ljcf/input @@ -1,27 +1,33 @@ # Mesh parameters -Base nx: 16 +Base nx: 32 Base ny: 16 -Base nz: 16 -Max level: 6 +Base nz: 8 +Max level: 4 + +# Domain +Lx: 16 ! Jet injection direction +Ly: 8 ! Crossflow +Lz: 4 ! Spanwise +Ly offset: 2 ! Distance from edge of domain to jet # Regridding parameters Regrid nsteps: 10 Tagging Reynolds: 20 # Flow parameters -Density ratio: 800 -Mom flux ratio: 50 -Weber number: 100 -Reynolds number: 4e4 -Viscosity ratio: 50 -Froude number: 15 +Density ratio: 833.3 +#Mom flux ratio: 50 +Weber number: 108.9 +Reynolds number: 39600 !4e4 +Viscosity ratio: 55.5 +Froude number: 15.12 # Time integration Max time: 100 Max dt: 2.5e-3 -Max CFL: 0.7 +Max CFL: 0.5 # Output Output period: 0.5 Checkpoint period: 5.0 -Restart from: !restart/jet_3.00024E+01 +Restart from: !restart/jet_3.00024E+01 \ No newline at end of file diff --git a/examples/amr_ljcf/src/simulation.f90 b/examples/amr_ljcf/src/simulation.f90 index 8061689da..518281253 100644 --- a/examples/amr_ljcf/src/simulation.f90 +++ b/examples/amr_ljcf/src/simulation.f90 @@ -326,13 +326,18 @@ subroutine simulation_init() ! Create amrgrid create_amrgrid: block + real(WP) :: Lx,Ly,Lz,Ly_offset amr%name='LJCF' call param_read('Base nx',amr%nx) call param_read('Base ny',amr%ny) call param_read('Base nz',amr%nz) - amr%xlo= 00.0_WP; amr%xhi=+20.0_WP - amr%ylo=-05.0_WP; amr%yhi=+15.0_WP - amr%zlo=-10.0_WP; amr%zhi=+10.0_WP + call param_read("Lx",Lx) + call param_read("Ly",Ly) + call param_read("Lz",Lz) + call param_read("Ly offset",Ly_offset) + amr%xlo= 00.0_WP; amr%xhi=+Lx + amr%ylo=-Ly_offset; amr%yhi=Ly-Ly_offset + amr%zlo=-Lz/2.0_WP; amr%zhi=+Lz/2.0_WP amr%xper=.false.; amr%yper=.false.; amr%zper=.true. call param_read('Max level',amr%maxlvl) ! Handle 2D case From 36a64481bb80894cd5d406475bfb9dc1cd0427c4 Mon Sep 17 00:00:00 2001 From: Mark Owkes Date: Thu, 21 May 2026 15:51:33 -0600 Subject: [PATCH 40/70] Added sponge region near outflow --- examples/amr_ljcf/src/simulation.f90 | 56 ++++++++++++++++++++++++++++ 1 file changed, 56 insertions(+) diff --git a/examples/amr_ljcf/src/simulation.f90 b/examples/amr_ljcf/src/simulation.f90 index 518281253..943e3f652 100644 --- a/examples/amr_ljcf/src/simulation.f90 +++ b/examples/amr_ljcf/src/simulation.f90 @@ -50,6 +50,10 @@ module simulation real(WP) :: viscL_mol,viscG_mol real(WP), dimension(3) :: gravity + ! Sponge layer parameters for outflow damping + real(WP) :: y_spg_start + real(WP) :: L_spg + real(WP) :: max_cfl_spg contains !> Levelset function for sphere @@ -78,6 +82,10 @@ subroutine get_viscosity() type(amrex_box) :: bx real(WP), dimension(:,:,:,:), contiguous, pointer :: pVF,pVisc real(WP), parameter :: myeps=1.0e-15_WP + real(WP) :: blend,mu_spg,y_loc,nu_spg + ! Compute maximum allowable kinematic viscosity in the sponge at finest level + ! This ensures viscous terms satisfy CFL: dt <= CFL*dx^2/(4*nu) => nu <= CFL*dx^2/(4*dt) + nu_spg=max_cfl_spg*amr%min_meshsize(amr%clvl())**2/(4.0_WP*time%dt) ! Loop over levels do lvl=0,amr%clvl() ! Loop over domain @@ -91,12 +99,53 @@ subroutine get_viscosity() do k=bx%lo(3),bx%hi(3); do j=bx%lo(2),bx%hi(2); do i=bx%lo(1),bx%hi(1) ! Use harmonic averaging pVisc(i,j,k,1)=1.0_WP/(pVF(i,j,k,1)/max(viscL_mol,myeps)+(1.0_WP-pVF(i,j,k,1))/max(viscG_mol,myeps)) + ! Apply sponge layer viscosity damping in outflow region (y+ boundary) + y_loc=amr%ylo+(real(j,WP)+0.5_WP)*amr%dy(lvl) + if (y_loc.gt.y_spg_start) then + ! Smooth quadratic blend: 0 at y_spg_start, 1 at y_spg_start+L_spg + blend=min((y_loc-y_spg_start)/L_spg,1.0_WP)**2 + ! Compute sponge viscosity (convert kinematic to dynamic) + mu_spg=nu_spg/(pVF(i,j,k,1)/max(1.0_WP,myeps)+(1.0_WP-pVF(i,j,k,1))/max(1.0_WP,myeps)) + ! Only increase viscosity if beneficial + pVisc(i,j,k,1)=max(pVisc(i,j,k,1),blend*mu_spg) + end if end do; end do; end do end do call amr%mfiter_destroy(mfi) end do end subroutine get_viscosity + !> Clip VOF near outflow to prevent unphysical values and instabilities + subroutine clip_vof_outflow() + use amrex_amr_module, only: amrex_mfiter,amrex_box + integer :: lvl,i,j,k + type(amrex_mfiter) :: mfi + type(amrex_box) :: bx + real(WP), dimension(:,:,:,:), contiguous, pointer :: pVF + real(WP), parameter :: VF_min=1.0e-6_WP,VF_max=1.0_WP-1.0e-6_WP + real(WP) :: dy_loc + ! Loop over levels + do lvl=0,amr%clvl() + ! Loop over domain + call amr%mfiter_build(lvl,mfi) + do while (mfi%next()) + ! Get pointers to data + pVF=>fs%VF%mf(lvl)%dataptr(mfi) + ! Get tilebox (grow for safety, clip only at boundaries) + 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) + ! Check if in sponge layer outflow region (y+ boundary) + dy_loc=amr%ylo+(real(j,WP)+0.5_WP)*amr%dy(lvl) + ! Clip VOF in sponge region to prevent ringing/overshoot + if (dy_loc.gt.y_spg_start) then + pVF(i,j,k,1)=max(min(pVF(i,j,k,1),VF_max),VF_min) + end if + end do; end do; end do + end do + call amr%mfiter_destroy(mfi) + end do + end subroutine clip_vof_outflow + !> Tagger for this case based on velocity gradient magnitude subroutine my_tagger(solver,lvl,time,tags_ptr) use iso_c_binding, only: c_ptr,c_char @@ -398,6 +447,10 @@ subroutine simulation_init() call param_read('Viscosity ratio',viscL_mol); viscL_mol=viscG_mol*viscL_mol ! Set gravity gravity=0.0_WP; call param_read('Froude number',gravity(1),default=1.0e30_WP); gravity(1)=1.0_WP/gravity(1)**2 + ! Set sponge layer parameters (optional for outflow damping at y+ boundary) + call param_read('Sponge y-start',y_spg_start,default=4.0_WP) + call param_read('Sponge thickness',L_spg,default=4.0_WP) + call param_read('Sponge max CFL',max_cfl_spg,default=0.5_WP) ! Set pressure convergence fs%psolver%outer_solver=amrmg_outer_pcg_mlmg fs%psolver%tol_rel=1.0e-5_WP @@ -569,6 +622,9 @@ subroutine simulation_run() call fs%build_plic(time%t) call fs%build_subVF() + ! Clip VOF in outflow region to prevent instabilities + call clip_vof_outflow() + ! Interpolate velocity to the faces call fs%get_face_velocity() From 69715097f574e8ea7ba0029b7b165739dec806f3 Mon Sep 17 00:00:00 2001 From: Mark Owkes Date: Fri, 22 May 2026 05:57:50 -0600 Subject: [PATCH 41/70] Fixed sponge region and vof clipping --- examples/amr_ljcf/src/simulation.f90 | 11 ++++++----- 1 file changed, 6 insertions(+), 5 deletions(-) diff --git a/examples/amr_ljcf/src/simulation.f90 b/examples/amr_ljcf/src/simulation.f90 index 943e3f652..eed31f5b9 100644 --- a/examples/amr_ljcf/src/simulation.f90 +++ b/examples/amr_ljcf/src/simulation.f90 @@ -122,7 +122,6 @@ subroutine clip_vof_outflow() type(amrex_mfiter) :: mfi type(amrex_box) :: bx real(WP), dimension(:,:,:,:), contiguous, pointer :: pVF - real(WP), parameter :: VF_min=1.0e-6_WP,VF_max=1.0_WP-1.0e-6_WP real(WP) :: dy_loc ! Loop over levels do lvl=0,amr%clvl() @@ -136,9 +135,9 @@ subroutine clip_vof_outflow() do k=bx%lo(3),bx%hi(3); do j=bx%lo(2),bx%hi(2); do i=bx%lo(1),bx%hi(1) ! Check if in sponge layer outflow region (y+ boundary) dy_loc=amr%ylo+(real(j,WP)+0.5_WP)*amr%dy(lvl) - ! Clip VOF in sponge region to prevent ringing/overshoot + ! Remove liquid in sponge region to prevent outflow instabilities if (dy_loc.gt.y_spg_start) then - pVF(i,j,k,1)=max(min(pVF(i,j,k,1),VF_max),VF_min) + pVF(i,j,k,1)=0.0_WP end if end do; end do; end do end do @@ -179,6 +178,8 @@ subroutine my_tagger(solver,lvl,time,tags_ptr) ! Prevent maximum Re-driven refinement near wall near_wall=(solver%amr%xlo+(real(i,WP)+0.5_WP)*dx.lt.solver%amr%xlo+2.0_WP*dx) if (near_wall.and.lvl.ge.solver%amr%maxlvl-1) cycle + ! Prevent refinement in outflow sponge region + if (solver%amr%ylo+(real(j,WP)+0.5_WP)*dy.gt.y_spg_start) cycle ! Laplacian of velocity Q=UVW lapU=(pQ(i+1,j,k,1)-2.0_WP*pQ(i,j,k,1)+pQ(i-1,j,k,1))*dxi2+(pQ(i,j+1,k,1)-2.0_WP*pQ(i,j,k,1)+pQ(i,j-1,k,1))*dyi2+(pQ(i,j,k+1,1)-2.0_WP*pQ(i,j,k,1)+pQ(i,j,k-1,1))*dzi2 lapV=(pQ(i+1,j,k,2)-2.0_WP*pQ(i,j,k,2)+pQ(i-1,j,k,2))*dxi2+(pQ(i,j+1,k,2)-2.0_WP*pQ(i,j,k,2)+pQ(i,j-1,k,2))*dyi2+(pQ(i,j,k+1,2)-2.0_WP*pQ(i,j,k,2)+pQ(i,j,k-1,2))*dzi2 @@ -448,7 +449,7 @@ subroutine simulation_init() ! Set gravity gravity=0.0_WP; call param_read('Froude number',gravity(1),default=1.0e30_WP); gravity(1)=1.0_WP/gravity(1)**2 ! Set sponge layer parameters (optional for outflow damping at y+ boundary) - call param_read('Sponge y-start',y_spg_start,default=4.0_WP) + call param_read('Sponge y-start',y_spg_start,default=12.0_WP) call param_read('Sponge thickness',L_spg,default=4.0_WP) call param_read('Sponge max CFL',max_cfl_spg,default=0.5_WP) ! Set pressure convergence @@ -623,7 +624,7 @@ subroutine simulation_run() call fs%build_subVF() ! Clip VOF in outflow region to prevent instabilities - call clip_vof_outflow() + ! call clip_vof_outflow() ! Interpolate velocity to the faces call fs%get_face_velocity() From d619a9e67716051ec127a3ea56e2a582e101e6e4 Mon Sep 17 00:00:00 2001 From: Mark Owkes Date: Wed, 27 May 2026 13:56:21 -0600 Subject: [PATCH 42/70] Updated default domain size with sponge zone. --- examples/amr_ljcf/input | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/examples/amr_ljcf/input b/examples/amr_ljcf/input index b134314ff..51094fa3a 100644 --- a/examples/amr_ljcf/input +++ b/examples/amr_ljcf/input @@ -1,13 +1,13 @@ # Mesh parameters -Base nx: 32 +Base nx: 16 Base ny: 16 -Base nz: 8 -Max level: 4 +Base nz: 8 +Max level: 3 # Domain Lx: 16 ! Jet injection direction -Ly: 8 ! Crossflow -Lz: 4 ! Spanwise +Ly: 16 ! Crossflow +Lz: 8 ! Spanwise Ly offset: 2 ! Distance from edge of domain to jet # Regridding parameters @@ -30,4 +30,4 @@ Max CFL: 0.5 # Output Output period: 0.5 Checkpoint period: 5.0 -Restart from: !restart/jet_3.00024E+01 \ No newline at end of file +Restart from: !restart/jet_4.50006E+01 From 47fc95f206980d92cd19d2461aa219c2b82447ab Mon Sep 17 00:00:00 2001 From: Mark Owkes Date: Wed, 3 Jun 2026 15:10:58 -0600 Subject: [PATCH 43/70] Working on amrcclabel --- examples/amrcclabel_tester/GNUmakefile | 46 + examples/amrcclabel_tester/README.md | 4 + examples/amrcclabel_tester/input | 28 + examples/amrcclabel_tester/src/Make.package | 2 + examples/amrcclabel_tester/src/simulation.f90 | 217 +++++ src/amrbase/Make.package | 2 +- src/amrbase/amrcclabel_class.f90 | 790 ++++++++++++++++++ 7 files changed, 1088 insertions(+), 1 deletion(-) create mode 100644 examples/amrcclabel_tester/GNUmakefile create mode 100644 examples/amrcclabel_tester/README.md create mode 100644 examples/amrcclabel_tester/input create mode 100644 examples/amrcclabel_tester/src/Make.package create mode 100644 examples/amrcclabel_tester/src/simulation.f90 create mode 100644 src/amrbase/amrcclabel_class.f90 diff --git a/examples/amrcclabel_tester/GNUmakefile b/examples/amrcclabel_tester/GNUmakefile new file mode 100644 index 000000000..610cd87b8 --- /dev/null +++ b/examples/amrcclabel_tester/GNUmakefile @@ -0,0 +1,46 @@ +# NGA location if not yet defined +NGA_HOME ?= ../.. + +# Compilation parameters +PRECISION = DOUBLE +USE_MPI = TRUE +use_FFTW = FALSE +USE_HYPRE = TRUE +USE_LAPACK= TRUE +USE_AMREX = TRUE +USE_HDF5 = TRUE +PROFILE = FALSE +DEBUG = TRUE +COMP = gnu +EXEBASE = nga2 + +# 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) + +# NGA compilation definitions +include $(NGA_HOME)/tools/GNUMake/Make.defs + +# Include NGA base code +Bdirs := amrbase amrmpsolvers libraries core +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/amrcclabel_tester/README.md b/examples/amrcclabel_tester/README.md new file mode 100644 index 000000000..50e693fb0 --- /dev/null +++ b/examples/amrcclabel_tester/README.md @@ -0,0 +1,4 @@ +# Tester for amrcclabel_class.f90 + +- Creates droplets +- Computes ID using ccl diff --git a/examples/amrcclabel_tester/input b/examples/amrcclabel_tester/input new file mode 100644 index 000000000..a33e82ab6 --- /dev/null +++ b/examples/amrcclabel_tester/input @@ -0,0 +1,28 @@ +# Parallelization +Partition : 1 1 1 + +# Mesh definition +Lx : 5 +nx : 32 + +# Droplet properties +Number of droplet : 10 +Droplet diameter : 1.3 # for growth test +Droplet diameter : 1.5 +Liquid dynamic viscosity : 1.0 +Gas dynamic viscosity : 1.0 +Liquid density : 1.0 +Gas density : 1.0 +Surface tension coefficient : 1.0 + +# Time integration +Max timestep size : 2.5e-3 +Max cfl number : #0.9 +Max time : 30.0e-3 + +# Ensight output +Ensight output period : 2.5e-3 +Restart output period : 10e-3 + +# Drop analysis +Drop analysis period : 5e-2 diff --git a/examples/amrcclabel_tester/src/Make.package b/examples/amrcclabel_tester/src/Make.package new file mode 100644 index 000000000..b4510a890 --- /dev/null +++ b/examples/amrcclabel_tester/src/Make.package @@ -0,0 +1,2 @@ +# List here the extra files here +f90EXE_sources += simulation.f90 diff --git a/examples/amrcclabel_tester/src/simulation.f90 b/examples/amrcclabel_tester/src/simulation.f90 new file mode 100644 index 000000000..0973f505d --- /dev/null +++ b/examples/amrcclabel_tester/src/simulation.f90 @@ -0,0 +1,217 @@ +!> Various definitions and tools for running an NGA2 simulation +module simulation + use precision, only: WP + use amrviz_class, only: amrviz + use amrgrid_class, only: amrgrid + use amrmpinc_class, only: amrmpinc + use amrdata_class, only: amrdata + use amrio_class, only: amrio + use amrcclabel_class, only: amrcclabel + + implicit none + private + + public :: simulation_init,simulation_run,simulation_final + + ! Grid + type(amrgrid), target :: amr + + ! VOF solver + type(amrvof), target :: vof + + ! Sphere parameters + integer :: nSphere + real(WP), dimension(:,:), allocatable :: sphere_center + real(WP), dimension(:), allocatable :: sphere_radius + + ! Visualization + type(amrviz) :: viz + + ! I/O + type(amrio) :: io + + ! CCLabel + type(amrcclabel) :: cclabel + +contains + + + !> Function that identifies cells within a structure + logical function make_label(pVF,i,j,k) + implicit none + real(WP), dimension(:,:,:,:), contiguous, intent(in) :: pVF + integer, intent(in) :: i,j,k + if (pVF(i,j,k,1).gt.0.0_WP) then + make_label=.true. + else + make_label=.false. + end if + end function make_label + + !> Function that identifies if neighbors are within the same structure + logical function same_label(pVF,i,j,k,ii,jj,kk) + implicit none + real(WP), dimension(:,:,:,:), contiguous, intent(in) :: pVF + integer, intent(in) :: i,j,k,ii,jj,kk + if (pVF(i,j,k,1).gt.0.0_WP .and. pVF(ii,jj,kk,1).gt.0.0_WP) then + same_label=.true. + else + same_label=.false. + end if + end function same_label + + !> Spheres levelset function with periodicity + function spheres_levelset(xyz,t) result(G) + implicit none + real(WP), dimension(3), intent(in) :: xyz + real(WP), intent(in) :: t + real(WP) :: G + real(WP), dimension(3) :: d,L + ! Distance to nearest sphere + do n=1,nSphere + d=xyz-sphere_center(:,n) + L=[amr%xhi-amr%xlo,amr%yhi-amr%ylo,amr%zhi-amr%zlo] + d=d-L*nint(d/L) ! Nearest image + G=min(G,sphere_radius(n)-sqrt(sum(d**2))) + end do + end function spheres_levelset + + !> Initialize VF field with sphere using levelset-based moments + subroutine spheres_init(solver,lvl,time,ba,dm) + use amrex_amr_module, only: amrex_mfiter,amrex_box,amrex_boxarray,amrex_distromap,amrex_mfiter_build,amrex_mfiter_destroy + use mms_geom, only: initialize_volume_moments + class(amrvof), intent(inout) :: solver + integer, intent(in) :: lvl + real(WP), intent(in) :: time + type(amrex_boxarray), intent(in) :: ba + type(amrex_distromap), intent(in) :: dm + type(amrex_mfiter) :: mfi + type(amrex_box) :: bx + real(WP), dimension(:,:,:,:), contiguous, pointer :: pVF,pCL,pCG + real(WP) :: dx,dy,dz + real(WP), dimension(3) :: BL,BG + integer :: i,j,k + integer, parameter :: nref=3 + ! Get mesh size + dx=solver%amr%dx(lvl) + dy=solver%amr%dy(lvl) + dz=solver%amr%dz(lvl) + ! Use passed ba/dm since grid is being constructed + call amrex_mfiter_build(mfi,ba,dm,tiling=.false.) + do while (mfi%next()) + ! Get pointers to data + pVF=>solver%VF%mf(lvl)%dataptr(mfi) + if (lvl.eq.solver%amr%maxlvl) then + pCL=>solver%CL%dataptr(mfi) + pCG=>solver%CG%dataptr(mfi) + end if + ! Get tile box with ghost cells + bx=mfi%growntilebox(solver%nover) + do k=bx%lo(3),bx%hi(3); do j=bx%lo(2),bx%hi(2); do i=bx%lo(1),bx%hi(1) + ! Compute VF and barycenters from levelset with 3 levels of refinement + call initialize_volume_moments(lo=[solver%amr%xlo+real(i ,WP)*dx,solver%amr%ylo+real(j ,WP)*dy,solver%amr%zlo+real(k ,WP)*dz], & + & hi=[solver%amr%xlo+real(i+1,WP)*dx,solver%amr%ylo+real(j+1,WP)*dy,solver%amr%zlo+real(k+1,WP)*dz], & + & levelset=spheres_levelset,time=time,level=nref,VFlo=VFlo,VF=pVF(i,j,k,1),BL=BL,BG=BG) + ! Store barycenters + if (lvl.eq.solver%amr%maxlvl) then + pCL(i,j,k,:)=BL + pCG(i,j,k,:)=BG + end if + end do; end do; end do + end do + call amrex_mfiter_destroy(mfi) + end subroutine spheres_init + + !> Initialization of problem solver + subroutine simulation_init + use param, only: param_read + implicit none + + ! Create amrgrid + create_amrgrid: block + amr%name='vof_advect' + call param_read('Base nx',amr%nx) + call param_read('Base ny',amr%ny) + call param_read('Base nz',amr%nz) + amr%xlo=0.0_WP; amr%xhi=1.0_WP + amr%ylo=0.0_WP; amr%yhi=1.0_WP + amr%zlo=0.0_WP; amr%zhi=1.0_WP + amr%xper=.true.; amr%yper=.true.; amr%zper=.true. + call param_read('Max level',amr%maxlvl) + call amr%initialize() + end block create_amrgrid + + ! Setup spheres parameters + setup_spheres: block + use random, only: random_uniform + call param_read('Sphere diameter',radius); radius=radius/2.0_WP + call param_read('Number of spheres',nSphere); + ! Allocate arrays + allocate(sphere_center(3,nSphere)) + allocate(sphere_radius(nSphere)) + ! Provide seed for random number generator + call random_seed(size=nseed) + allocate(seed(nseed)) + seed(:)=1 + call random_seed(put=seed) + do nD=1,nSphere + center=[random_uniform(amr%xlo, amr%xhi), & + random_uniform(amr%ylo, amr%yhi), & + random_uniform(amr%zlo, amr%zhi) ] + sphere_center(:,nD)=center + sphere_radius(nD)=radius + end do + end block setup_spheres + + ! Initialize our VOF field + create_and_initialize_vof: block + call vof%initialize(amr,name='spheres_vof') + vof%user_vof_init=>spheres_init + end block create_and_initialize_vof + + + ! Initialize regridding + init_regridding: block + ! KnapSack load balancing + amr%lb_strat=1 + ! Fresh start + call amr%init_from_scratch(time=0.0_WP) + ! Build PLIC + call vof%build_plic(time%t) + end block init_regridding + + ! Create visualization + create_visualization: block + ! Create amrviz output + call viz%initialize(amr,'amrcclabel',use_hdf5=.false.) + call viz%add_scalar(vof%VF,1,'VF') + call viz%add_scalar(cclabel%id,1,'ID') + call viz%add_surfmesh(vof%smesh,'plic') + end block create_visualization + + + end subroutine simulation_init + + + !> Time integrate our problem + subroutine simulation_run + + + + ! Write visualization with IDs + call viz%write(time=0.0_WP) + + end subroutine simulation_run + + !> Finalize the NGA2 simulation + subroutine simulation_final + implicit none + + ! Deallocate work arrays + call io%finalize() + call amr%finalize() + call vf%finalize() + + end subroutine simulation_final + +end module simulation diff --git a/src/amrbase/Make.package b/src/amrbase/Make.package index f1558fe4a..f6d136ccc 100644 --- a/src/amrbase/Make.package +++ b/src/amrbase/Make.package @@ -1,5 +1,5 @@ f90EXE_sources += amrex_interface.f90 amrgrid_class.f90 amrdata_class.f90 amrflux_class.f90 amrviz_class.f90 amrio_class.f90 -f90EXE_sources += amrsolver_class.f90 amrmg_class.f90 amrsgs.f90 +f90EXE_sources += amrsolver_class.f90 amrmg_class.f90 amrsgs.f90 amrcclabel_class.f90 CEXE_sources += amrex_wrapper.cpp INCLUDE_LOCATIONS += $(NGA_HOME)/src/amrbase diff --git a/src/amrbase/amrcclabel_class.f90 b/src/amrbase/amrcclabel_class.f90 new file mode 100644 index 000000000..c920fb2a1 --- /dev/null +++ b/src/amrbase/amrcclabel_class.f90 @@ -0,0 +1,790 @@ +!> TODO +! - How to deal with what used to be domain boundaries +! if (this%pg%imin_.ne.this%pg%imin) then ! ?????????????? +! - How to deal with VF? How to access values? +! - How should map be represented? If it should. +! old - i,j,k +! new - level, tile(?), i,j,k + +!> Connected component labeling class: identifies Lagrangian objects from a Eulerian logical field +!> and provides unstructured mapping to traverse these objects +module amrcclabel_class + use precision, only: WP + use string, only: str_medium + use amrdata_class, only: amrdata + use amrsolver_class, only: amrsolver + implicit none + private + + + ! Expose type/constructor/methods + public :: amrcclabel,make_label_ftype,same_label_ftype + + + ! Some parameters for memory management + integer , parameter :: min_struct_size=100 !< Default minimum size of structure storage + real(WP), parameter :: coeff_up=1.5_WP !< When we run out of structure storage, increase by 50% + + !> Map object + type :: map_type + integer :: lvl !< AMR level + integer :: fab !< mfi%index() + integer, dimension(:), allocatable :: i,j,k !< Cell index + end type map_type + + + !> Structure object + type :: struct_type + integer :: parent !< ID of parent struct + integer :: n_ !< Number of local cells contained in struct + type(map_type), dimension(:), allocatable :: map !< List of cells contained in struct + integer, dimension(3) :: per !< Periodicity array - per(dim)=1 if structure is periodic in dim direction + end type struct_type + + + !> amrcclabel object definition + type, extends(amrsolver) :: amrcclabel + ! ID of the structure that contains each cell + type(amrdata) :: id + ! Periodicity treatement + type(amrdata) :: idp + ! Array of structures + integer :: nstruct + type(struct_type), dimension(:), allocatable :: struct + ! Ghost cells + integer :: nover=1 + contains + procedure :: initialize + procedure :: build + procedure :: empty + procedure :: finalize + end type amrcclabel + + !> Type of the make_label function used to generate a structure + interface + logical function make_label_ftype(pVF,i,j,k) + use precision, only: WP + real(WP), dimension(:,:,:,:), contiguous, intent(in) :: pVF + integer, intent(in) :: i,j,k + end function make_label_ftype + end interface + + !> Type of the same_label function used to connect two structures + interface + logical function same_label_ftype(pVF,i,j,k,ii,jj,kk) + use precision, only: WP + real(WP), dimension(:,:,:,:), contiguous, intent(in) :: pVF + integer, intent(in) :: i,j,k,ii,jj,kk + end function same_label_ftype + end interface + + +contains + + + !> Initialization for amrcclabel class + subroutine initialize(this,name) + implicit none + class(amrcclabel) :: this + character(len=*), optional :: name + ! Set the name for the object + if (present(name)) this%name=trim(adjustl(name)) + ! Allocate and initialize ID array + call this%id%initialize(amr,name='id',ncomp=1,ng=this%nover); this%id%parent=>this + call this%id%setval(val=0) + ! Allocate and initialize periodicity array + call this%idp%initialize(amr,name='idp',ncomp=3,ng=this%nover); this%idp%parent=>this + ! Zero structures + this%nstruct=0 + end subroutine initialize + + + !> Build structure using the user-set test functions + subroutine build(this,make_label,same_label) + use amrdata_class, only: amrdata + implicit none + class(amrcclabel), intent(inout) :: this + procedure(make_label_ftype) :: make_label + procedure(same_label_ftype) :: same_label + integer :: nstruct_,stmin,stmax + integer, dimension(:), allocatable :: parent !< Resolving structure id across procs + integer, dimension(:), allocatable :: parent_all !< Resolving structure id across procs + integer, dimension(:), allocatable :: parent_own !< Resolving structure id across procs + + ! Start by cleaning up + call this%empty() + + ! Then allocate struct to a default size + nstruct_=0 + allocate(this%struct(min_struct_size)) + this%struct(:)%parent=0 + this%struct(:)%per(1)=0 + this%struct(:)%per(2)=0 + this%struct(:)%per(3)=0 + this%struct(:)%n_=0 + + ! Allocate periodicity work array + call this%idp%setval(val=0) + + ! Perform a first pass to build proc-local structures and corresponding tree + first_pass: block + use amrex_amr_module, only: amrex_mfiter,amrex_box + integer :: lvl,i,j,k + integer :: ii,jj,kk,dim + integer :: fab + integer, dimension(3) :: pos + type(amrex_mfiter) :: mfi + type(amrex_box) :: bx + real(WP), dimension(:,:,:,:), contiguous, pointer :: pVF + + ! Traverse levels + do lvl=0,this%amr%clvl() + ! Loop over tiles + call this%amr%mfiter_build(lvl,mfi) + do while (mfi%next()) + ! Get pointers to data + pid=>this%id%mf(lvl)%dataptr(mfi) + pidp=>this%idp%mf(lvl)%dataptr(mfi) + pVF=>this%VF%mf(lvl)%dataptr(mfi) + ! Only work on finest level for now + if (lvl.ne.this%amr%finest_level()) cycle + ! Perform local loop + 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) + ! Find next cell in a structure + if (make_label(pVF,i,j,k)) then + ! Loop through one-sided neighbors + do dim=1,3 + pos=0; pos(dim)=-1 + ii=i+pos(1); jj=j+pos(2); kk=k+pos(3) + ! Check if neighbor is labeled + if (pid(ii,jj,kk,1).gt.0) then + ! Neighbor is labeled, but are we? + if (pid(i,j,k,1).ne.0) then + ! We already have a label, perform a union of both labels + if (same_label(pVF,i,j,k,ii,jj,kk)) then + pid(i,j,k,1)=union_struct(pid(i,j,k,1),pid(ii,jj,kk,1)) + end if + else + ! We don't have a label, check if we take the neighbor's label + if (same_label(pVF,i,j,k,ii,jj,kk)) then + pid(i,j,k,1)=pid(ii,jj,kk,1) + else + pid(i,j,k,1)=add() + end if + end if + end if + end do + ! If no neighbor was labeled, we need a new structure + if (pid(i,j,k,1).eq.0) pid(i,j,k,1)=add() + ! Identify periodicity cases + if (this%pg%xper.and.i.eq.this%pg%imax) this%struct(pid(i,j,k,1))%per(1)=1 + if (this%pg%yper.and.j.eq.this%pg%jmax) this%struct(pid(i,j,k,1))%per(2)=1 + if (this%pg%zper.and.k.eq.this%pg%kmax) this%struct(pid(i,j,k,1))%per(3)=1 + pidp(i,j,k,:)=this%struct(pid(i,j,k,1))%per + end if + end do; end do; end do + end do + end do + end block first_pass + + ! Now collapse the tree, count the cells and resolve periodicity in each structure + collapse_tree: block + use amrex_amr_module, only: amrex_mfiter,amrex_box + integer :: i,j,k + type(amrex_mfiter) :: mfi + type(amrex_box) :: bx + do lvl=0,this%amr%clvl() + ! Loop over tiles + call this%amr%mfiter_build(lvl,mfi) + do while (mfi%next()) + ! Get pointers to data + pid=>this%id%mf(lvl)%dataptr(mfi) + pidp=>this%idp%mf(lvl)%dataptr(mfi) + pVF=>this%VF%mf(lvl)%dataptr(mfi) + ! Only work on finest level for now + if (lvl.ne.this%amr%finest_level()) cycle + ! Perform local loop + 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 (pid(i,j,k,1).gt.0) then + pid(i,j,k,1)=rootify_struct(pid(i,j,k,1)) + this%struct(pid(i,j,k,1))%n_=this%struct(pid(i,j,k,1))%n_+1 + pidp(i,j,k,1)=max(pidp(1,i,j,k),this%struct(pid(i,j,k,1))%per(1)) + pidp(i,j,k,2)=max(pidp(2,i,j,k),this%struct(pid(i,j,k,1))%per(2)) + pidp(i,j,k,3)=max(pidp(3,i,j,k),this%struct(pid(i,j,k,1))%per(3)) + this%struct(pid(i,j,k,1))%per=pidp(:,i,j,k) + end if + end do; end do; end do + end do + end do + end block collapse_tree + + ! Compact structure array + compact_tree: block + use mpi_f08, only: MPI_ALLREDUCE,MPI_SUM,MPI_INTEGER + integer :: i,j,k,n,ierr + integer, dimension(:), allocatable :: my_nstruct,all_nstruct,idmap + type(struct_type), dimension(:), allocatable :: tmp + ! Count exact number of local structures + nstruct_=0 + do n=1,size(this%struct,dim=1) + if (this%struct(n)%n_.gt.0) nstruct_=nstruct_+1 + end do + ! Gather this info to ensure unique index + allocate( my_nstruct(0:this%pg%nproc-1)); my_nstruct=0; my_nstruct(this%pg%rank)=nstruct_ + allocate(all_nstruct(0:this%pg%nproc-1)); call MPI_ALLREDUCE(my_nstruct,all_nstruct,this%pg%nproc,MPI_INTEGER,MPI_SUM,this%pg%comm,ierr) + stmin=1 + if (this%pg%rank.gt.0) stmin=stmin+sum(all_nstruct(0:this%pg%rank-1)) + this%nstruct=sum(all_nstruct) + deallocate(my_nstruct,all_nstruct) + stmax=stmin+nstruct_-1 + ! Generate an index map + allocate(idmap(1:size(this%struct,dim=1))); idmap=0 + nstruct_=0 + do n=1,size(this%struct,dim=1) + if (this%struct(n)%n_.gt.0) then + nstruct_=nstruct_+1 + idmap(n)=stmin+nstruct_-1 + end if + end do + ! Update id array to new index + update_id: block + use amrex_amr_module, only: amrex_mfiter,amrex_box + integer :: lvl + type(amrex_mfiter) :: mfi + type(amrex_box) :: bx + ! Traverse levels ! Only work on finest level for now + do lvl=this%amr%finest_level() + ! Loop over tiles + call this%amr%mfiter_build(lvl,mfi) + do while (mfi%next()) + ! Get pointers to data + pid=>this%id%mf(lvl)%dataptr(mfi) + ! Perform local loop + 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 (pid(i,j,k,1).gt.0) pid(i,j,k,1)=idmap(pid(i,j,k,1)) + end do; end do; end do + end do + end do + end block update_id + deallocate(idmap) + ! Finish compacting and renumbering + allocate(tmp(stmin:stmax)) + nstruct_=0 + do n=1,size(this%struct,dim=1) + if (this%struct(n)%n_.gt.0) then + nstruct_=nstruct_+1 + tmp(stmin+nstruct_-1)=this%struct(n) + allocate(tmp(stmin+nstruct_-1)%map(3,tmp(stmin+nstruct_-1)%n_)) + end if + end do + call move_alloc(tmp,this%struct) + end block compact_tree + + ! ! Fill out the node map + ! node_map: block + ! use amrex_amr_module, only: amrex_mfiter,amrex_box + ! integer :: i,j,k + ! integer, dimension(:), allocatable :: counter + ! integer :: lvl + ! type(amrex_mfiter) :: mfi + ! type(amrex_box) :: bx + ! allocate(counter(stmin:stmax)); counter=0 + ! ! Traverse levels ! Only work on finest level for now + ! do lvl=this%amr%finest_level() + ! ! Loop over tiles + ! call this%amr%mfiter_build(lvl,mfi) + ! do while (mfi%next()) + ! ! Get pointers to data + ! pid=>this%id%mf(lvl)%dataptr(mfi) + ! ! Perform local loop + ! 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 (pid(i,j,k,1).gt.0) then + ! counter(pid(i,j,k,1))=counter(pid(i,j,k,1))+1 + ! this%struct(pid(i,j,k,1))%map(:,counter(pid(i,j,k,1))))=[i,j,k] + ! end if + ! end do; end do; end do + ! deallocate(counter) + ! end block node_map + + ! ! Interprocessor treatment of our structures + ! interproc_handling: block + ! use mpi_f08, only: MPI_ALLREDUCE,MPI_MIN,MPI_MAX,MPI_INTEGER + ! integer :: i,j,k,stop_global,stop_,counter,n,m,ierr,find_parent,find_parent_own + ! ! Allocate to total number of structures + ! allocate(parent (this%nstruct)); parent =0 + ! allocate(parent_all(this%nstruct)); parent_all=0 + ! allocate(parent_own(this%nstruct)); parent_own=0 + ! ! Fill global lineage with selves + ! do n=1,this%nstruct + ! parent(n)=n + ! end do + ! ! Synchronize id array + ! call sync_lvl(this%id,this%amr%finest_level()) + ! ! Handle imin_ border + ! if (this%pg%imin_.ne.this%pg%imin) then ! ?????????????? + ! ! Traverse levels ! Only work on finest level for now + ! do lvl=this%amr%finest_level() + ! ! Loop over tiles + ! call this%amr%mfiter_build(lvl,mfi) + ! do while (mfi%next()) + ! ! Get pointers to data + ! pid=>this%id%mf(lvl)%dataptr(mfi) + ! pVF=>this%VF%mf(lvl)%dataptr(mfi) + ! ! Perform local loop + ! bx=mfi%tilebox() + ! do k=bx%lo(3),bx%hi(3); do j=bx%lo(2),bx%hi(2) + ! if (pid(bx%lo(1),j,k,1).gt.0.and(pid(bx%lo(1)-1,j,k,1).gt.0)) then + ! if (same_label(pVF(bx%lo(1),j,k),pVF(bx%lo(1)-1,j,k))) call union_parent(pid(bx%lo(1),j,k),pid(bx%lo(1)-1,j,k)) + ! end if + ! end do; end do + ! end if + ! end do; end do + ! end if + ! ! Handle jmin_ border + ! if (this%pg%jmin_.ne.this%pg%jmin) then ! ????????????? + ! ! Traverse levels ! Only work on finest level for now + ! do lvl=this%amr%finest_level() + ! ! Loop over tiles + ! call this%amr%mfiter_build(lvl,mfi) + ! do while (mfi%next()) + ! ! Get pointers to data + ! pid=>this%id%mf(lvl)%dataptr(mfi) + ! pVF=>this%VF%mf(lvl)%dataptr(mfi) + ! ! Perform local loop + ! bx=mfi%tilebox() + ! do k=bx%lo(3),bx%hi(3); do i=bx%lo(1),bx%hi(1) + ! if (pid(i,bx%lo(2),k,1).gt.0.and(pid(i,bx%lo(2)-1,k,1).gt.0)) then + ! if (same_label(pVF(i,bx%lo(2),k),pVF(i,bx%lo(2)-1,k))) call union_parent(pid(i,bx%lo(2),k),pid(i,bx%lo(2)-1,k)) + ! end if + ! end do; end do + ! end if + ! end do; end do + ! end if + ! ! Handle kmin_ border + ! if (this%pg%kmin_.ne.this%pg%kmin) then ! ????????????? + ! ! Traverse levels ! Only work on finest level for now + ! do lvl=this%amr%finest_level() + ! ! Loop over tiles + ! call this%amr%mfiter_build(lvl,mfi) + ! do while (mfi%next()) + ! ! Get pointers to data + ! pid=>this%id%mf(lvl)%dataptr(mfi) + ! pVF=>this%VF%mf(lvl)%dataptr(mfi) + ! ! Perform local loop + ! bx=mfi%tilebox() + ! do j=bx%lo(2),bx%hi(2); do i=bx%lo(1),bx%hi(1) + ! if (pid(i,j,bx%lo(3),1).gt.0.and(pid(i,j,bx%lo(3)-1,1).gt.0)) then + ! if (same_label(pVF(i,j,bx%lo(3)),pVF(i,j,bx%lo(3)-1))) call union_parent(pid(i,j,bx%lo(3)),pid(i,j,bx%lo(3)-1)) + ! end if + ! end do; end do + ! end if + ! end do; end do + ! end if + ! ! Initialize global stop criterion and counter + ! stop_global=1 + ! counter=0 + ! ! Resolve lineage + ! do while (stop_global.ne.0) + ! ! Initialize local stop flag + ! stop_=0 + ! ! Remember own parents + ! parent_own=parent + ! ! Set self-parents to huge(1) + ! do n=1,this%nstruct + ! if (parent(n).eq.n) parent(n)=huge(1) + ! end do + ! ! Take global min + ! call MPI_ALLREDUCE(parent,parent_all,this%nstruct,MPI_INTEGER,MPI_MIN,this%pg%comm,ierr) + ! ! Set self-parents back to selves + ! do n=1,this%nstruct + ! if (parent_all(n).eq.huge(1)) parent_all(n)=n + ! end do + ! ! Flatten trees + ! do n=1,this%nstruct + ! parent_all(n)=find_all(n) + ! parent_own(n)=find_own(n) + ! end do + ! ! Start with final parent array being equal to parent_all + ! parent=parent_all + ! ! Increment counter + ! counter=counter+1 + ! ! Reconcile conflicts between parent_all and parent_own + ! do n=1,this%nstruct + ! if (parent_own(n).ne.n) then + ! find_parent_own=rootify_parent(parent_own(n)) + ! find_parent =rootify_parent(parent(n)) + ! if (find_parent_own.ne.find_parent) then + ! call union_parent(find_parent,find_parent_own) + ! stop_=1 + ! end if + ! end if + ! end do + ! ! Check if we did some changes + ! call MPI_ALLREDUCE(stop_,stop_global,1,MPI_INTEGER,MPI_MAX,this%pg%comm,ierr) + ! end do + ! ! Update this%struct%parent by pointing all parents to root and update id + ! do n=stmin,stmax + ! this%struct(n)%parent=rootify_parent(parent(n)) + ! do m=1,this%struct(n)%n_ + ! this%id(this%struct(n)%map(1,m),this%struct(n)%map(2,m),this%struct(n)%map(3,m))=this%struct(n)%parent + ! end do + ! end do + ! end block interproc_handling + + ! ! Update periodicity array across processors + ! periodicity_update: block + ! use mpi_f08, only: MPI_ALLGATHER,MPI_MAX,MPI_INTEGER + ! integer, dimension(:,:), allocatable :: ownper,allper + ! integer :: n,m,ierr + ! ! Allocate local and global perodicity arrays + ! allocate(ownper(1:3,this%nstruct)); ownper=0 + ! allocate(allper(1:3,this%nstruct)); allper=0 + ! ! Fill ownper array + ! do n=stmin,stmax + ! ownper(:,n)=this%struct(n)%per + ! end do + ! ! Communicate per + ! call MPI_ALLREDUCE(ownper,allper,3*this%nstruct,MPI_INTEGER,MPI_MAX,this%pg%comm,ierr) + ! ! Update parent per + ! do n=1,this%nstruct + ! allper(:,parent(n))=max(allper(:,parent(n)),allper(:,n)) + ! end do + ! ! Update idp array + ! do n=stmin,stmax + ! do m=1,this%struct(n)%n_ + ! idp(:,this%struct(n)%map(1,m),this%struct(n)%map(2,m),this%struct(n)%map(3,m))=allper(:,this%id(this%struct(n)%map(1,m),this%struct(n)%map(2,m),this%struct(n)%map(3,m))) + ! end do + ! end do + ! ! Clean up + ! deallocate(ownper,allper) + ! end block periodicity_update + + ! ! One more pass for domain boundaries + ! boundary_handling: block + ! use mpi_f08, only: MPI_ALLREDUCE,MPI_MIN,MPI_MAX,MPI_INTEGER + ! integer :: i,j,k,stop_global,stop_,counter,n,m,ierr,find_parent,find_parent_own + ! ! Handle imin border + ! if (this%pg%imin_.eq.this%pg%imin) then + ! do k=this%pg%kmin_,this%pg%kmax_; do j=this%pg%jmin_,this%pg%jmax_ + ! if (this%id(this%pg%imin_,j,k).gt.0.and.this%id(this%pg%imin_-1,j,k).gt.0) then + ! if (same_label(this%pg%imin_,j,k,this%pg%imin_-1,j,k)) call union_parent(this%id(this%pg%imin_,j,k),this%id(this%pg%imin_-1,j,k)) + ! end if + ! end do; end do + ! end if + ! ! Handle jmin border + ! if (this%pg%jmin_.eq.this%pg%jmin) then + ! do k=this%pg%kmin_,this%pg%kmax_; do i=this%pg%imin_,this%pg%imax_ + ! if (this%id(i,this%pg%jmin_,k).gt.0.and.this%id(i,this%pg%jmin_-1,k).gt.0) then + ! if (same_label(i,this%pg%jmin_,k,i,this%pg%jmin_-1,k)) call union_parent(this%id(i,this%pg%jmin_,k),this%id(i,this%pg%jmin_-1,k)) + ! end if + ! end do; end do + ! end if + ! ! Handle kmin border + ! if (this%pg%kmin_.eq.this%pg%kmin) then + ! do j=this%pg%jmin_,this%pg%jmax_; do i=this%pg%imin_,this%pg%imax_ + ! if (this%id(i,j,this%pg%kmin_).gt.0.and.this%id(i,j,this%pg%kmin_-1).gt.0) then + ! if (same_label(i,j,this%pg%kmin_,i,j,this%pg%kmin_-1)) call union_parent(this%id(i,j,this%pg%kmin_),this%id(i,j,this%pg%kmin_-1)) + ! end if + ! end do; end do + ! end if + ! ! Initialize global stop criterion and counter + ! stop_global=1 + ! counter=0 + ! ! Resolve lineage + ! do while (stop_global.ne.0) + ! ! Initialize local stop flag + ! stop_=0 + ! ! Remember own parents + ! parent_own=parent + ! ! Set self-parents to huge(1) + ! do n=1,this%nstruct + ! if (parent(n).eq.n) parent(n)=huge(1) + ! end do + ! ! Take global min + ! call MPI_ALLREDUCE(parent,parent_all,this%nstruct,MPI_INTEGER,MPI_MIN,this%pg%comm,ierr) + ! ! Set self-parents back to selves + ! do n=1,this%nstruct + ! if (parent_all(n).eq.huge(1)) parent_all(n)=n + ! end do + ! ! Flatten trees + ! do n=1,this%nstruct + ! parent_all(n)=find_all_2(n,n) + ! parent_own(n)=find_own(n) + ! end do + ! ! Start with final parent array being equal to parent_all + ! parent=parent_all + ! ! Increment counter + ! counter=counter+1 + ! ! Reconcile conflicts between parent_all and parent_own + ! do n=1,this%nstruct + ! if (parent_own(n).ne.n) then + ! find_parent_own=rootify_parent(parent_own(n)) + ! find_parent =rootify_parent(parent(n)) + ! if (find_parent_own.ne.find_parent) then + ! call union_parent(find_parent,find_parent_own) + ! stop_=1 + ! end if + ! end if + ! end do + ! ! Check if we did some changes + ! call MPI_ALLREDUCE(stop_,stop_global,1,MPI_INTEGER,MPI_MAX,this%pg%comm,ierr) + ! end do + ! ! Update this%struct%parent and point all parents to root and update id + ! do n=stmin,stmax + ! this%struct(n)%parent=rootify_parent(parent(n)) + ! do m=1,this%struct(n)%n_ + ! this%id(this%struct(n)%map(1,m),this%struct(n)%map(2,m),this%struct(n)%map(3,m))=this%struct(n)%parent + ! end do + ! end do + ! ! Update ghost cells + ! call this%pg%sync(this%id) + ! ! Clean up parent info + ! deallocate(parent,parent_all,parent_own) + ! end block boundary_handling + + ! ! Now we need to compact the data based on id only + ! compact_struct: block + ! use mpi_f08, only: MPI_ALLREDUCE,MPI_MAX,MPI_INTEGER + ! integer :: i,j,k,n,nn,ierr,count + ! integer, dimension(:), allocatable :: my_idmap,idmap,counter + ! type(struct_type), dimension(:), allocatable :: tmp + ! ! Prepare global id map + ! allocate(my_idmap(1:this%nstruct)); my_idmap=0 + ! allocate( idmap(1:this%nstruct)); idmap=0 + ! ! Traverse id array and tag used id values + ! do k=this%pg%kmin_,this%pg%kmax_; do j=this%pg%jmin_,this%pg%jmax_; do i=this%pg%imin_,this%pg%imax_ + ! if (this%id(i,j,k).gt.0) my_idmap(this%id(i,j,k))=1 + ! end do; end do; end do + ! call MPI_ALLREDUCE(my_idmap,idmap,this%nstruct,MPI_INTEGER,MPI_MAX,this%pg%comm,ierr) + ! deallocate(my_idmap) + ! ! Count number of used structures and create the map + ! this%nstruct=sum(idmap) + ! count=0 + ! do n=1,size(idmap,dim=1) + ! if (idmap(n).gt.0) then + ! count=count+1 + ! idmap(n)=count + ! end if + ! end do + ! ! Rename all structures + ! do k=this%pg%kmin_,this%pg%kmax_; do j=this%pg%jmin_,this%pg%jmax_; do i=this%pg%imin_,this%pg%imax_ + ! if (this%id(i,j,k).gt.0) this%id(i,j,k)=idmap(this%id(i,j,k)) + ! end do; end do; end do + ! call this%pg%sync(this%id) + ! ! Allocate temporary storage for structure + ! allocate(tmp(this%nstruct)) + ! allocate(counter(this%nstruct)); counter=0 + ! do k=this%pg%kmin_,this%pg%kmax_; do j=this%pg%jmin_,this%pg%jmax_; do i=this%pg%imin_,this%pg%imax_ + ! if (this%id(i,j,k).gt.0) counter(this%id(i,j,k))=counter(this%id(i,j,k))+1 + ! end do; end do; end do + ! do n=1,this%nstruct + ! tmp(n)%parent=n + ! tmp(n)%per=0 + ! tmp(n)%n_=counter(n) + ! allocate(tmp(n)%map(1:3,1:tmp(n)%n_)) + ! end do + ! ! Transfer periodicity info + ! do n=stmin,stmax + ! if (idmap(n).gt.0) then + ! tmp(idmap(n))%per=this%struct(n)%per + ! end if + ! end do + ! deallocate(idmap) + ! ! Store the map + ! counter=0 + ! do k=this%pg%kmin_,this%pg%kmax_; do j=this%pg%jmin_,this%pg%jmax_; do i=this%pg%imin_,this%pg%imax_ + ! if (this%id(i,j,k).gt.0) then + ! counter(this%id(i,j,k))=counter(this%id(i,j,k))+1 + ! tmp(this%id(i,j,k))%map(:,counter(this%id(i,j,k)))=[i,j,k] + ! end if + ! end do; end do; end do + ! deallocate(counter) + ! ! Transfer allocation + ! call move_alloc(tmp,this%struct) + ! ! Final pass to fix periodicity info + ! do n=1,this%nstruct + ! do nn=1,this%struct(n)%n_ + ! i=this%struct(n)%map(1,nn) + ! j=this%struct(n)%map(2,nn) + ! k=this%struct(n)%map(3,nn) + ! this%struct(n)%per(1)=max(this%struct(n)%per(1),idp(1,i,j,k)) + ! this%struct(n)%per(2)=max(this%struct(n)%per(2),idp(2,i,j,k)) + ! this%struct(n)%per(3)=max(this%struct(n)%per(3),idp(3,i,j,k)) + ! end do + ! end do + ! deallocate(idp) + ! end block compact_struct + + ! Extra QOL step to ensure that id=1 is always the largest structure in terms of number of cells + rename_largest_structure: block + use mpi_f08, only: MPI_ALLREDUCE,MPI_SUM,MPI_INTEGER,MPI_IN_PLACE + integer :: ierr,bigid,i,j,k + integer, dimension(:), allocatable :: ncells + type(struct_type) :: tmp + ! Skip if no structure was found + if (this%nstruct.eq.0) exit rename_largest_structure + ! Loop over all structures and count total number of cells to find ID of largest structure + allocate(ncells(1:this%nstruct)); ncells=this%struct(:)%n_ + call MPI_ALLREDUCE(MPI_IN_PLACE,ncells,this%nstruct,MPI_INTEGER,MPI_SUM,this%pg%comm,ierr) + bigid=maxloc(ncells,1) + deallocate(ncells) + ! Swap structures + tmp=this%struct(1); this%struct(1)=this%struct(bigid); this%struct(bigid)=tmp + do k=this%pg%kmino_,this%pg%kmaxo_; do j=this%pg%jmino_,this%pg%jmaxo_; do i=this%pg%imino_,this%pg%imaxo_ + if (this%id(i,j,k).eq.1) then; this%id(i,j,k)=bigid; else if (this%id(i,j,k).eq.bigid) then; this%id(i,j,k)=1; end if + end do; end do; end do + end block rename_largest_structure + + + contains + + !> This recursive function that points the lineage of a structure to its root and returns that root + recursive function rootify_struct(x) result(y) + implicit none + integer, intent(in) :: x + integer :: y + y=x + if (y.ne.this%struct(y)%parent) then + this%struct(y)%parent=rootify_struct(this%struct(y)%parent) + y=this%struct(y)%parent + end if + end function rootify_struct + + !> This function joins two structures at their roots (the smallest root is chosen and returned) + function union_struct(x,y) result(rmin) + implicit none + integer, intent(in) :: x,y + integer :: rx,ry,rmin,rmax + rx=rootify_struct(x); ry=rootify_struct(y) + rmin=min(rx,ry); rmax=max(rx,ry) + this%struct(rmax)%parent=rmin + end function union_struct + + !> This function adds one new root while dynamically handling storage space + function add() result(x) + implicit none + integer :: x + integer :: size_now,size_new + type(struct_type), dimension(:), allocatable :: tmp + ! Check if there is enough room for storing a new structure + size_now=size(this%struct,dim=1) + if (nstruct_.eq.size_now) then + size_new=int(real(size_now,WP)*coeff_up) + allocate(tmp(size_new)) + tmp(1:nstruct_)=this%struct + tmp(nstruct_+1:)%parent=0 + tmp(nstruct_+1:)%per(1)=0 + tmp(nstruct_+1:)%per(2)=0 + tmp(nstruct_+1:)%per(3)=0 + tmp(nstruct_+1:)%n_=0 + call move_alloc(tmp,this%struct) + end if + ! Add new root + nstruct_=nstruct_+1 + this%struct(nstruct_)%parent=nstruct_ + this%struct(nstruct_)%per=0 + this%struct(nstruct_)%n_=0 + x=nstruct_ + end function add + + !> This recursive function points global parent to root and returns that root + recursive function rootify_parent(x) result(y) + implicit none + integer, intent(in) :: x + integer :: y + y=x + if (y.ne.parent(y)) then + parent(y)=rootify_parent(parent(y)) + y=parent(y) + end if + end function rootify_parent + + !> This function joins two branches at their roots (the smallest root is chosen) + subroutine union_parent(x,y) + implicit none + integer, intent(in) :: x,y + integer :: rx,ry,rmin,rmax + rx=rootify_parent(x); ry=rootify_parent(y); rmin=min(rx,ry); rmax=max(rx,ry) + parent(rmax)=rmin + end subroutine union_parent + + !> For parent_all array: this function points the parent to root and returns that root + recursive function find_all(x) result(y) + implicit none + integer, intent(in) :: x + integer :: y + y=x + if (y.ne.parent_all(y)) then + parent_all(y)=find_all(parent_all(y)) + y=parent_all(y) + end if + end function find_all + + !> Version of previous function that stops at the completion of a cycle + recursive function find_all_2(x,x0) result(y) + implicit none + integer, intent(in) :: x,x0 + integer :: y + y=x + if (y.ne.parent_all(y)) then + if (parent_all(y).eq.x0) then + y=parent_all(y) + return + else + parent_all(y)=find_all_2(parent_all(y),x0) + y=parent_all(y) + end if + end if + end function find_all_2 + + !> For parent_own array: this function points the parent to root and returns that root + recursive function find_own(x) result(y) + implicit none + integer, intent(in) :: x + integer :: y + y=x + if (y.ne.parent_own(y)) then + parent_own(y)=find_own(parent_own(y)) + y=parent_own(y) + end if + end function find_own + + end subroutine build + + + !> Empty structure info + subroutine empty(this) + implicit none + class(cclabel), intent(inout) :: this + integer :: n + ! Loop over all structures and deallocate maps + if (allocated(this%struct)) then + do n=1,size(this%struct,dim=1) + if (allocated(this%struct(n)%map)) deallocate(this%struct(n)%map) + end do + ! Deallocate structure array + deallocate(this%struct) + end if + ! Zero structures + this%nstruct=0 + ! Reset id to zero + this%id=0 + end subroutine empty + + + !> Finalize CCL object + subroutine finalize(this) + implicit none + class(cclabel), intent(inout) :: this + call this%empty() + if (allocated(this%id)) deallocate(this%id) + nullify(this%pg) + this%name='UNNAMED_CCL' + end subroutine finalize + + +end module cclabel_class From b7a29000273ad1a63d537224902a41f79f45e4b3 Mon Sep 17 00:00:00 2001 From: Mark Owkes Date: Fri, 5 Jun 2026 13:56:23 -0600 Subject: [PATCH 44/70] working on amrcclabel --- src/amrbase/amrcclabel_class.f90 | 254 ++++++++++++++++--------------- 1 file changed, 132 insertions(+), 122 deletions(-) diff --git a/src/amrbase/amrcclabel_class.f90 b/src/amrbase/amrcclabel_class.f90 index c920fb2a1..eb8931c53 100644 --- a/src/amrbase/amrcclabel_class.f90 +++ b/src/amrbase/amrcclabel_class.f90 @@ -13,6 +13,7 @@ module amrcclabel_class use string, only: str_medium use amrdata_class, only: amrdata use amrsolver_class, only: amrsolver + use amrgrid_class, only: amrgrid implicit none private @@ -43,7 +44,8 @@ module amrcclabel_class !> amrcclabel object definition - type, extends(amrsolver) :: amrcclabel + type :: amrcclabel + character(len=str_medium) :: name = 'UNNAMED_CCLABEL' ! ID of the structure that contains each cell type(amrdata) :: id ! Periodicity treatement @@ -53,6 +55,8 @@ module amrcclabel_class type(struct_type), dimension(:), allocatable :: struct ! Ghost cells integer :: nover=1 + ! Associated amr grid + class(amrgrid), pointer, private :: amr => null() contains procedure :: initialize procedure :: build @@ -64,7 +68,7 @@ module amrcclabel_class interface logical function make_label_ftype(pVF,i,j,k) use precision, only: WP - real(WP), dimension(:,:,:,:), contiguous, intent(in) :: pVF + real(WP), dimension(:,:,:,:), intent(in) :: pVF integer, intent(in) :: i,j,k end function make_label_ftype end interface @@ -73,7 +77,7 @@ end function make_label_ftype interface logical function same_label_ftype(pVF,i,j,k,ii,jj,kk) use precision, only: WP - real(WP), dimension(:,:,:,:), contiguous, intent(in) :: pVF + real(WP), dimension(:,:,:,:), intent(in) :: pVF integer, intent(in) :: i,j,k,ii,jj,kk end function same_label_ftype end interface @@ -83,29 +87,34 @@ end function same_label_ftype !> Initialization for amrcclabel class - subroutine initialize(this,name) + subroutine initialize(this,amr,name) implicit none class(amrcclabel) :: this + class(amrgrid), target, intent(in) :: amr character(len=*), optional :: name ! Set the name for the object if (present(name)) this%name=trim(adjustl(name)) + ! Point cclabel to amr grid + this%amr => amr ! Allocate and initialize ID array - call this%id%initialize(amr,name='id',ncomp=1,ng=this%nover); this%id%parent=>this - call this%id%setval(val=0) + call this%id%initialize(amr,name='id',ncomp=1,ng=this%nover);! this%id%parent=>this + call this%id%register() ! Update with regriding + call this%id%setval(val=0.0_WP) ! Allocate and initialize periodicity array - call this%idp%initialize(amr,name='idp',ncomp=3,ng=this%nover); this%idp%parent=>this + call this%idp%initialize(amr,name='idp',ncomp=3,ng=this%nover);! this%idp%parent=>this ! Zero structures this%nstruct=0 end subroutine initialize !> Build structure using the user-set test functions - subroutine build(this,make_label,same_label) + subroutine build(this,make_label,same_label,data) use amrdata_class, only: amrdata implicit none class(amrcclabel), intent(inout) :: this procedure(make_label_ftype) :: make_label procedure(same_label_ftype) :: same_label + type(amrdata), intent(in) :: data integer :: nstruct_,stmin,stmax integer, dimension(:), allocatable :: parent !< Resolving structure id across procs integer, dimension(:), allocatable :: parent_all !< Resolving structure id across procs @@ -124,7 +133,7 @@ subroutine build(this,make_label,same_label) this%struct(:)%n_=0 ! Allocate periodicity work array - call this%idp%setval(val=0) + call this%idp%setval(val=0.0_WP) ! Perform a first pass to build proc-local structures and corresponding tree first_pass: block @@ -135,24 +144,24 @@ subroutine build(this,make_label,same_label) integer, dimension(3) :: pos type(amrex_mfiter) :: mfi type(amrex_box) :: bx - real(WP), dimension(:,:,:,:), contiguous, pointer :: pVF + real(WP), dimension(:,:,:,:), contiguous, pointer :: pid,pidp,pdata ! Traverse levels - do lvl=0,this%amr%clvl() + do lvl=0,data%amr%clvl() ! Loop over tiles - call this%amr%mfiter_build(lvl,mfi) + call data%amr%mfiter_build(lvl,mfi) do while (mfi%next()) - ! Get pointers to data + ! Get pointers to data arrays pid=>this%id%mf(lvl)%dataptr(mfi) pidp=>this%idp%mf(lvl)%dataptr(mfi) - pVF=>this%VF%mf(lvl)%dataptr(mfi) + pdata=>data%mf(lvl)%dataptr(mfi) ! Only work on finest level for now - if (lvl.ne.this%amr%finest_level()) cycle + if (lvl.ne.data%amr%maxlvl) cycle ! Perform local loop 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) ! Find next cell in a structure - if (make_label(pVF,i,j,k)) then + if (make_label(pdata,i,j,k)) then ! Loop through one-sided neighbors do dim=1,3 pos=0; pos(dim)=-1 @@ -162,12 +171,12 @@ subroutine build(this,make_label,same_label) ! Neighbor is labeled, but are we? if (pid(i,j,k,1).ne.0) then ! We already have a label, perform a union of both labels - if (same_label(pVF,i,j,k,ii,jj,kk)) then - pid(i,j,k,1)=union_struct(pid(i,j,k,1),pid(ii,jj,kk,1)) + if (same_label(pdata,i,j,k,ii,jj,kk)) then + pid(i,j,k,1)=union_struct(int(pid(i,j,k,1)),int(pid(ii,jj,kk,1))) end if else ! We don't have a label, check if we take the neighbor's label - if (same_label(pVF,i,j,k,ii,jj,kk)) then + if (same_label(pdata,i,j,k,ii,jj,kk)) then pid(i,j,k,1)=pid(ii,jj,kk,1) else pid(i,j,k,1)=add() @@ -177,11 +186,11 @@ subroutine build(this,make_label,same_label) end do ! If no neighbor was labeled, we need a new structure if (pid(i,j,k,1).eq.0) pid(i,j,k,1)=add() - ! Identify periodicity cases - if (this%pg%xper.and.i.eq.this%pg%imax) this%struct(pid(i,j,k,1))%per(1)=1 - if (this%pg%yper.and.j.eq.this%pg%jmax) this%struct(pid(i,j,k,1))%per(2)=1 - if (this%pg%zper.and.k.eq.this%pg%kmax) this%struct(pid(i,j,k,1))%per(3)=1 - pidp(i,j,k,:)=this%struct(pid(i,j,k,1))%per + ! ! Identify periodicity cases + ! if (this%pg%xper.and.i.eq.this%pg%imax) this%struct(pid(i,j,k,1))%per(1)=1 + ! if (this%pg%yper.and.j.eq.this%pg%jmax) this%struct(pid(i,j,k,1))%per(2)=1 + ! if (this%pg%zper.and.k.eq.this%pg%kmax) this%struct(pid(i,j,k,1))%per(3)=1 + ! pidp(i,j,k,:)=this%struct(pid(i,j,k,1))%per end if end do; end do; end do end do @@ -191,97 +200,97 @@ subroutine build(this,make_label,same_label) ! Now collapse the tree, count the cells and resolve periodicity in each structure collapse_tree: block use amrex_amr_module, only: amrex_mfiter,amrex_box - integer :: i,j,k + integer :: lvl,i,j,k type(amrex_mfiter) :: mfi type(amrex_box) :: bx - do lvl=0,this%amr%clvl() + real(WP), dimension(:,:,:,:), contiguous, pointer :: pid,pidp + do lvl=0,data%amr%clvl() ! Loop over tiles - call this%amr%mfiter_build(lvl,mfi) + call data%amr%mfiter_build(lvl,mfi) do while (mfi%next()) ! Get pointers to data pid=>this%id%mf(lvl)%dataptr(mfi) pidp=>this%idp%mf(lvl)%dataptr(mfi) - pVF=>this%VF%mf(lvl)%dataptr(mfi) ! Only work on finest level for now - if (lvl.ne.this%amr%finest_level()) cycle + if (lvl.ne.data%amr%maxlvl) cycle ! Perform local loop 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 (pid(i,j,k,1).gt.0) then - pid(i,j,k,1)=rootify_struct(pid(i,j,k,1)) - this%struct(pid(i,j,k,1))%n_=this%struct(pid(i,j,k,1))%n_+1 - pidp(i,j,k,1)=max(pidp(1,i,j,k),this%struct(pid(i,j,k,1))%per(1)) - pidp(i,j,k,2)=max(pidp(2,i,j,k),this%struct(pid(i,j,k,1))%per(2)) - pidp(i,j,k,3)=max(pidp(3,i,j,k),this%struct(pid(i,j,k,1))%per(3)) - this%struct(pid(i,j,k,1))%per=pidp(:,i,j,k) + pid(i,j,k,1)=rootify_struct(int(pid(i,j,k,1))) + this%struct(int(pid(i,j,k,1)))%n_=this%struct(int(pid(i,j,k,1)))%n_+1 + pidp(i,j,k,1)=max(int(pidp(1,i,j,k)),this%struct(int(pid(i,j,k,1)))%per(1)) + pidp(i,j,k,2)=max(int(pidp(2,i,j,k)),this%struct(int(pid(i,j,k,1)))%per(2)) + pidp(i,j,k,3)=max(int(pidp(3,i,j,k)),this%struct(int(pid(i,j,k,1)))%per(3)) + this%struct(int(pid(i,j,k,1)))%per=int(pidp(:,i,j,k)) end if end do; end do; end do end do end do end block collapse_tree - ! Compact structure array - compact_tree: block - use mpi_f08, only: MPI_ALLREDUCE,MPI_SUM,MPI_INTEGER - integer :: i,j,k,n,ierr - integer, dimension(:), allocatable :: my_nstruct,all_nstruct,idmap - type(struct_type), dimension(:), allocatable :: tmp - ! Count exact number of local structures - nstruct_=0 - do n=1,size(this%struct,dim=1) - if (this%struct(n)%n_.gt.0) nstruct_=nstruct_+1 - end do - ! Gather this info to ensure unique index - allocate( my_nstruct(0:this%pg%nproc-1)); my_nstruct=0; my_nstruct(this%pg%rank)=nstruct_ - allocate(all_nstruct(0:this%pg%nproc-1)); call MPI_ALLREDUCE(my_nstruct,all_nstruct,this%pg%nproc,MPI_INTEGER,MPI_SUM,this%pg%comm,ierr) - stmin=1 - if (this%pg%rank.gt.0) stmin=stmin+sum(all_nstruct(0:this%pg%rank-1)) - this%nstruct=sum(all_nstruct) - deallocate(my_nstruct,all_nstruct) - stmax=stmin+nstruct_-1 - ! Generate an index map - allocate(idmap(1:size(this%struct,dim=1))); idmap=0 - nstruct_=0 - do n=1,size(this%struct,dim=1) - if (this%struct(n)%n_.gt.0) then - nstruct_=nstruct_+1 - idmap(n)=stmin+nstruct_-1 - end if - end do - ! Update id array to new index - update_id: block - use amrex_amr_module, only: amrex_mfiter,amrex_box - integer :: lvl - type(amrex_mfiter) :: mfi - type(amrex_box) :: bx - ! Traverse levels ! Only work on finest level for now - do lvl=this%amr%finest_level() - ! Loop over tiles - call this%amr%mfiter_build(lvl,mfi) - do while (mfi%next()) - ! Get pointers to data - pid=>this%id%mf(lvl)%dataptr(mfi) - ! Perform local loop - 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 (pid(i,j,k,1).gt.0) pid(i,j,k,1)=idmap(pid(i,j,k,1)) - end do; end do; end do - end do - end do - end block update_id - deallocate(idmap) - ! Finish compacting and renumbering - allocate(tmp(stmin:stmax)) - nstruct_=0 - do n=1,size(this%struct,dim=1) - if (this%struct(n)%n_.gt.0) then - nstruct_=nstruct_+1 - tmp(stmin+nstruct_-1)=this%struct(n) - allocate(tmp(stmin+nstruct_-1)%map(3,tmp(stmin+nstruct_-1)%n_)) - end if - end do - call move_alloc(tmp,this%struct) - end block compact_tree + ! ! Compact structure array + ! compact_tree: block + ! use mpi_f08, only: MPI_ALLREDUCE,MPI_SUM,MPI_INTEGER + ! integer :: i,j,k,n,ierr + ! integer, dimension(:), allocatable :: my_nstruct,all_nstruct,idmap + ! type(struct_type), dimension(:), allocatable :: tmp + ! ! Count exact number of local structures + ! nstruct_=0 + ! do n=1,size(this%struct,dim=1) + ! if (this%struct(n)%n_.gt.0) nstruct_=nstruct_+1 + ! end do + ! ! Gather this info to ensure unique index + ! allocate( my_nstruct(0:this%pg%nproc-1)); my_nstruct=0; my_nstruct(this%pg%rank)=nstruct_ + ! allocate(all_nstruct(0:this%pg%nproc-1)); call MPI_ALLREDUCE(my_nstruct,all_nstruct,this%pg%nproc,MPI_INTEGER,MPI_SUM,this%pg%comm,ierr) + ! stmin=1 + ! if (this%pg%rank.gt.0) stmin=stmin+sum(all_nstruct(0:this%pg%rank-1)) + ! this%nstruct=sum(all_nstruct) + ! deallocate(my_nstruct,all_nstruct) + ! stmax=stmin+nstruct_-1 + ! ! Generate an index map + ! allocate(idmap(1:size(this%struct,dim=1))); idmap=0 + ! nstruct_=0 + ! do n=1,size(this%struct,dim=1) + ! if (this%struct(n)%n_.gt.0) then + ! nstruct_=nstruct_+1 + ! idmap(n)=stmin+nstruct_-1 + ! end if + ! end do + ! ! Update id array to new index + ! update_id: block + ! use amrex_amr_module, only: amrex_mfiter,amrex_box + ! integer :: lvl + ! type(amrex_mfiter) :: mfi + ! type(amrex_box) :: bx + ! ! Traverse levels ! Only work on finest level for now + ! do lvl=this%amr%finest_level() + ! ! Loop over tiles + ! call this%amr%mfiter_build(lvl,mfi) + ! do while (mfi%next()) + ! ! Get pointers to data + ! pid=>this%id%mf(lvl)%dataptr(mfi) + ! ! Perform local loop + ! 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 (pid(i,j,k,1).gt.0) pid(i,j,k,1)=idmap(pid(i,j,k,1)) + ! end do; end do; end do + ! end do + ! end do + ! end block update_id + ! deallocate(idmap) + ! ! Finish compacting and renumbering + ! allocate(tmp(stmin:stmax)) + ! nstruct_=0 + ! do n=1,size(this%struct,dim=1) + ! if (this%struct(n)%n_.gt.0) then + ! nstruct_=nstruct_+1 + ! tmp(stmin+nstruct_-1)=this%struct(n) + ! allocate(tmp(stmin+nstruct_-1)%map(3,tmp(stmin+nstruct_-1)%n_)) + ! end if + ! end do + ! call move_alloc(tmp,this%struct) + ! end block compact_tree ! ! Fill out the node map ! node_map: block @@ -619,25 +628,25 @@ subroutine build(this,make_label,same_label) ! deallocate(idp) ! end block compact_struct - ! Extra QOL step to ensure that id=1 is always the largest structure in terms of number of cells - rename_largest_structure: block - use mpi_f08, only: MPI_ALLREDUCE,MPI_SUM,MPI_INTEGER,MPI_IN_PLACE - integer :: ierr,bigid,i,j,k - integer, dimension(:), allocatable :: ncells - type(struct_type) :: tmp - ! Skip if no structure was found - if (this%nstruct.eq.0) exit rename_largest_structure - ! Loop over all structures and count total number of cells to find ID of largest structure - allocate(ncells(1:this%nstruct)); ncells=this%struct(:)%n_ - call MPI_ALLREDUCE(MPI_IN_PLACE,ncells,this%nstruct,MPI_INTEGER,MPI_SUM,this%pg%comm,ierr) - bigid=maxloc(ncells,1) - deallocate(ncells) - ! Swap structures - tmp=this%struct(1); this%struct(1)=this%struct(bigid); this%struct(bigid)=tmp - do k=this%pg%kmino_,this%pg%kmaxo_; do j=this%pg%jmino_,this%pg%jmaxo_; do i=this%pg%imino_,this%pg%imaxo_ - if (this%id(i,j,k).eq.1) then; this%id(i,j,k)=bigid; else if (this%id(i,j,k).eq.bigid) then; this%id(i,j,k)=1; end if - end do; end do; end do - end block rename_largest_structure + ! ! Extra QOL step to ensure that id=1 is always the largest structure in terms of number of cells + ! rename_largest_structure: block + ! use mpi_f08, only: MPI_ALLREDUCE,MPI_SUM,MPI_INTEGER,MPI_IN_PLACE + ! integer :: ierr,bigid,i,j,k + ! integer, dimension(:), allocatable :: ncells + ! type(struct_type) :: tmp + ! ! Skip if no structure was found + ! if (this%nstruct.eq.0) exit rename_largest_structure + ! ! Loop over all structures and count total number of cells to find ID of largest structure + ! allocate(ncells(1:this%nstruct)); ncells=this%struct(:)%n_ + ! call MPI_ALLREDUCE(MPI_IN_PLACE,ncells,this%nstruct,MPI_INTEGER,MPI_SUM,this%pg%comm,ierr) + ! bigid=maxloc(ncells,1) + ! deallocate(ncells) + ! ! Swap structures + ! tmp=this%struct(1); this%struct(1)=this%struct(bigid); this%struct(bigid)=tmp + ! do k=this%pg%kmino_,this%pg%kmaxo_; do j=this%pg%jmino_,this%pg%jmaxo_; do i=this%pg%imino_,this%pg%imaxo_ + ! if (this%id(i,j,k).eq.1) then; this%id(i,j,k)=bigid; else if (this%id(i,j,k).eq.bigid) then; this%id(i,j,k)=1; end if + ! end do; end do; end do + ! end block rename_largest_structure contains @@ -759,7 +768,7 @@ end subroutine build !> Empty structure info subroutine empty(this) implicit none - class(cclabel), intent(inout) :: this + class(amrcclabel), intent(inout) :: this integer :: n ! Loop over all structures and deallocate maps if (allocated(this%struct)) then @@ -772,19 +781,20 @@ subroutine empty(this) ! Zero structures this%nstruct=0 ! Reset id to zero - this%id=0 + call this%id%setVal(0.0_WP) end subroutine empty !> Finalize CCL object subroutine finalize(this) implicit none - class(cclabel), intent(inout) :: this + class(amrcclabel), intent(inout) :: this call this%empty() - if (allocated(this%id)) deallocate(this%id) - nullify(this%pg) + call this%id%finalize() + call this%idp%finalize() + ! nullify(this%pg) this%name='UNNAMED_CCL' end subroutine finalize -end module cclabel_class +end module amrcclabel_class From b869d7c3de7f699eddfe93ffacbd65d283d8bed2 Mon Sep 17 00:00:00 2001 From: Mark Owkes Date: Tue, 9 Jun 2026 15:35:49 -0600 Subject: [PATCH 45/70] Switching from spheres to ellipsoids --- examples/amrcclabel_tester/input | 16 +-- examples/amrcclabel_tester/src/simulation.f90 | 129 ++++++++++++------ 2 files changed, 96 insertions(+), 49 deletions(-) diff --git a/examples/amrcclabel_tester/input b/examples/amrcclabel_tester/input index a33e82ab6..71691219a 100644 --- a/examples/amrcclabel_tester/input +++ b/examples/amrcclabel_tester/input @@ -2,18 +2,14 @@ Partition : 1 1 1 # Mesh definition -Lx : 5 -nx : 32 +Base nx : 8 +Base ny : 8 +Base nz : 8 +Max level : 3 # Droplet properties -Number of droplet : 10 -Droplet diameter : 1.3 # for growth test -Droplet diameter : 1.5 -Liquid dynamic viscosity : 1.0 -Gas dynamic viscosity : 1.0 -Liquid density : 1.0 -Gas density : 1.0 -Surface tension coefficient : 1.0 +Random seed : 3 +Number of ellipsoids : 4 # Time integration Max timestep size : 2.5e-3 diff --git a/examples/amrcclabel_tester/src/simulation.f90 b/examples/amrcclabel_tester/src/simulation.f90 index 0973f505d..f936f7758 100644 --- a/examples/amrcclabel_tester/src/simulation.f90 +++ b/examples/amrcclabel_tester/src/simulation.f90 @@ -7,6 +7,8 @@ module simulation use amrdata_class, only: amrdata use amrio_class, only: amrio use amrcclabel_class, only: amrcclabel + use amrvof_class, only: amrvof + use monitor_class, only: monitor implicit none private @@ -19,10 +21,10 @@ module simulation ! VOF solver type(amrvof), target :: vof - ! Sphere parameters - integer :: nSphere - real(WP), dimension(:,:), allocatable :: sphere_center - real(WP), dimension(:), allocatable :: sphere_radius + ! Ellipsoid parameters + integer :: nEllipsoid + real(WP), dimension(:,:), allocatable :: ellipsoid_center + real(WP), dimension(:,:), allocatable :: ellipsoid_radius ! Visualization type(amrviz) :: viz @@ -33,15 +35,23 @@ module simulation ! CCLabel type(amrcclabel) :: cclabel + ! Monitoring + type(monitor) :: gridfile + contains !> Function that identifies cells within a structure - logical function make_label(pVF,i,j,k) + logical function make_label(pVF,lo,i,j,k) implicit none - real(WP), dimension(:,:,:,:), contiguous, intent(in) :: pVF + real(WP), dimension(:,:,:,:), intent(in) :: pVF + integer, dimension(3), intent(in) :: lo integer, intent(in) :: i,j,k - if (pVF(i,j,k,1).gt.0.0_WP) then + integer :: il,jl,kl + il = i - lo(1) + 1 + jl = j - lo(2) + 1 + kl = k - lo(3) + 1 + if (pVF(il,jl,kl,1).gt.0.0_WP) then make_label=.true. else make_label=.false. @@ -49,37 +59,53 @@ logical function make_label(pVF,i,j,k) end function make_label !> Function that identifies if neighbors are within the same structure - logical function same_label(pVF,i,j,k,ii,jj,kk) + logical function same_label(pVF,lo,i,j,k,ii,jj,kk) implicit none - real(WP), dimension(:,:,:,:), contiguous, intent(in) :: pVF + real(WP), dimension(:,:,:,:), intent(in) :: pVF + integer, dimension(3), intent(in) :: lo integer, intent(in) :: i,j,k,ii,jj,kk - if (pVF(i,j,k,1).gt.0.0_WP .and. pVF(ii,jj,kk,1).gt.0.0_WP) then + integer :: il,jl,kl,iil,jjl,kkl + il = i - lo(1) + 1 + jl = j - lo(2) + 1 + kl = k - lo(3) + 1 + iil = ii - lo(1) + 1 + jjl = jj - lo(2) + 1 + kkl = kk - lo(3) + 1 + if (pVF(il,jl,kl,1).gt.0.0_WP .and. pVF(iil,jjl,kkl,1).gt.0.0_WP) then same_label=.true. else same_label=.false. end if end function same_label - !> Spheres levelset function with periodicity - function spheres_levelset(xyz,t) result(G) + !> Ellipsoids levelset function with periodicity + function Ellipsoids_levelset(xyz,t) result(G) implicit none real(WP), dimension(3), intent(in) :: xyz real(WP), intent(in) :: t - real(WP) :: G + real(WP) :: G,phi real(WP), dimension(3) :: d,L - ! Distance to nearest sphere - do n=1,nSphere - d=xyz-sphere_center(:,n) + integer :: n + ! Distance to nearest Ellipsoid + G = -huge(1.0_WP) + do n=1,nEllipsoid + d=xyz-ellipsoid_center(:,n) L=[amr%xhi-amr%xlo,amr%yhi-amr%ylo,amr%zhi-amr%zlo] d=d-L*nint(d/L) ! Nearest image - G=min(G,sphere_radius(n)-sqrt(sum(d**2))) + phi = 1.0_WP - sqrt( & + (d(1)/ellipsoid_radius(1,n))**2 + & + (d(2)/ellipsoid_radius(2,n))**2 + & + (d(3)/ellipsoid_radius(3,n))**2 ) + G=max(G,phi) end do - end function spheres_levelset + end function Ellipsoids_levelset - !> Initialize VF field with sphere using levelset-based moments - subroutine spheres_init(solver,lvl,time,ba,dm) + !> Initialize VF field with Ellipsoids using levelset-based moments + subroutine Ellipsoids_init(solver,lvl,time,ba,dm) use amrex_amr_module, only: amrex_mfiter,amrex_box,amrex_boxarray,amrex_distromap,amrex_mfiter_build,amrex_mfiter_destroy use mms_geom, only: initialize_volume_moments + use amrmpinc_class, only: VFlo,VFhi + implicit none class(amrvof), intent(inout) :: solver integer, intent(in) :: lvl real(WP), intent(in) :: time @@ -111,7 +137,7 @@ subroutine spheres_init(solver,lvl,time,ba,dm) ! Compute VF and barycenters from levelset with 3 levels of refinement call initialize_volume_moments(lo=[solver%amr%xlo+real(i ,WP)*dx,solver%amr%ylo+real(j ,WP)*dy,solver%amr%zlo+real(k ,WP)*dz], & & hi=[solver%amr%xlo+real(i+1,WP)*dx,solver%amr%ylo+real(j+1,WP)*dy,solver%amr%zlo+real(k+1,WP)*dz], & - & levelset=spheres_levelset,time=time,level=nref,VFlo=VFlo,VF=pVF(i,j,k,1),BL=BL,BG=BG) + & levelset=Ellipsoids_levelset,time=time,level=nref,VFlo=VFlo,VF=pVF(i,j,k,1),BL=BL,BG=BG) ! Store barycenters if (lvl.eq.solver%amr%maxlvl) then pCL(i,j,k,:)=BL @@ -120,7 +146,7 @@ subroutine spheres_init(solver,lvl,time,ba,dm) end do; end do; end do end do call amrex_mfiter_destroy(mfi) - end subroutine spheres_init + end subroutine Ellipsoids_init !> Initialization of problem solver subroutine simulation_init @@ -129,7 +155,7 @@ subroutine simulation_init ! Create amrgrid create_amrgrid: block - amr%name='vof_advect' + amr%name='cclabel_tester' call param_read('Base nx',amr%nx) call param_read('Base ny',amr%ny) call param_read('Base nz',amr%nz) @@ -141,34 +167,45 @@ subroutine simulation_init call amr%initialize() end block create_amrgrid - ! Setup spheres parameters - setup_spheres: block + ! Setup Ellipsoids parameters + setup_Ellipsoids: block use random, only: random_uniform - call param_read('Sphere diameter',radius); radius=radius/2.0_WP - call param_read('Number of spheres',nSphere); + integer :: nD,nseed + real(WP), dimension(3) :: center,radius + integer :: myseed + integer, dimension(:), allocatable :: seed + call param_read('Number of ellipsoids',nEllipsoid,default=4) + call param_read('Random seed',myseed,default=1) ! Allocate arrays - allocate(sphere_center(3,nSphere)) - allocate(sphere_radius(nSphere)) + allocate(ellipsoid_center(3,nEllipsoid)) + allocate(ellipsoid_radius(3,nEllipsoid)) ! Provide seed for random number generator call random_seed(size=nseed) allocate(seed(nseed)) - seed(:)=1 + seed(:)=myseed call random_seed(put=seed) - do nD=1,nSphere + do nD=1,nEllipsoid center=[random_uniform(amr%xlo, amr%xhi), & random_uniform(amr%ylo, amr%yhi), & random_uniform(amr%zlo, amr%zhi) ] - sphere_center(:,nD)=center - sphere_radius(nD)=radius + ellipsoid_center(:,nD)=center + radius=[0.5*random_uniform(amr%xlo, amr%xhi), & + 0.5*random_uniform(amr%ylo, amr%yhi), & + 0.5*random_uniform(amr%zlo, amr%zhi) ] + ellipsoid_radius(:,nD)=radius end do - end block setup_spheres + end block setup_Ellipsoids ! Initialize our VOF field create_and_initialize_vof: block - call vof%initialize(amr,name='spheres_vof') - vof%user_vof_init=>spheres_init + call vof%initialize(amr,name='Ellipsoids_vof') + vof%user_vof_init=>Ellipsoids_init end block create_and_initialize_vof + ! Initialize CCLabel + create_and_initialize_cclabel: block + call cclabel%initialize(amr,name='Ellipsoids_cclabel') + end block create_and_initialize_cclabel ! Initialize regridding init_regridding: block @@ -177,7 +214,7 @@ subroutine simulation_init ! Fresh start call amr%init_from_scratch(time=0.0_WP) ! Build PLIC - call vof%build_plic(time%t) + call vof%build_plic(0.0_WP) end block init_regridding ! Create visualization @@ -189,6 +226,19 @@ subroutine simulation_init call viz%add_surfmesh(vof%smesh,'plic') end block create_visualization + ! Create monitor + create_monitor: block + gridfile=monitor(amRoot=amr%amRoot,name='grid') + call gridfile%add_column(amr%nlevels,'Nlvl') + call gridfile%add_column(amr%nboxes,'Nbox') + call gridfile%add_column(amr%ncells,'Ncell') + call gridfile%add_column(amr%compression,'Compression') + call gridfile%add_column(amr%maxRSS,'Maximum RSS') + call gridfile%add_column(amr%minRSS,'Minimum RSS') + call gridfile%add_column(amr%avgRSS,'Average RSS') + call gridfile%write() + end block create_monitor + end subroutine simulation_init @@ -196,7 +246,8 @@ end subroutine simulation_init !> Time integrate our problem subroutine simulation_run - + ! Compute CCLabel + call cclabel%build(make_label,same_label,vof%VF) ! Write visualization with IDs call viz%write(time=0.0_WP) @@ -210,7 +261,7 @@ subroutine simulation_final ! Deallocate work arrays call io%finalize() call amr%finalize() - call vf%finalize() + call vof%finalize() end subroutine simulation_final From c7ff504afa2a176c4fcd4764042653cccfe011e5 Mon Sep 17 00:00:00 2001 From: Mark Owkes Date: Tue, 9 Jun 2026 15:38:07 -0600 Subject: [PATCH 46/70] amrcclabel seems to be working on multiple procs and across domain boundaries. --- src/amrbase/amrcclabel_class.f90 | 438 ++++++++++++++++--------------- 1 file changed, 221 insertions(+), 217 deletions(-) diff --git a/src/amrbase/amrcclabel_class.f90 b/src/amrbase/amrcclabel_class.f90 index eb8931c53..9f8c554b6 100644 --- a/src/amrbase/amrcclabel_class.f90 +++ b/src/amrbase/amrcclabel_class.f90 @@ -38,7 +38,7 @@ module amrcclabel_class type :: struct_type integer :: parent !< ID of parent struct integer :: n_ !< Number of local cells contained in struct - type(map_type), dimension(:), allocatable :: map !< List of cells contained in struct + type(map_type), dimension(:), allocatable :: map !< List of cells contained in struct integer, dimension(3) :: per !< Periodicity array - per(dim)=1 if structure is periodic in dim direction end type struct_type @@ -48,8 +48,6 @@ module amrcclabel_class character(len=str_medium) :: name = 'UNNAMED_CCLABEL' ! ID of the structure that contains each cell type(amrdata) :: id - ! Periodicity treatement - type(amrdata) :: idp ! Array of structures integer :: nstruct type(struct_type), dimension(:), allocatable :: struct @@ -66,18 +64,20 @@ module amrcclabel_class !> Type of the make_label function used to generate a structure interface - logical function make_label_ftype(pVF,i,j,k) + logical function make_label_ftype(pVF,lo,i,j,k) use precision, only: WP real(WP), dimension(:,:,:,:), intent(in) :: pVF + integer, dimension(3), intent(in) :: lo integer, intent(in) :: i,j,k end function make_label_ftype end interface !> Type of the same_label function used to connect two structures interface - logical function same_label_ftype(pVF,i,j,k,ii,jj,kk) + logical function same_label_ftype(pVF,lo,i,j,k,ii,jj,kk) use precision, only: WP real(WP), dimension(:,:,:,:), intent(in) :: pVF + integer, dimension(3), intent(in) :: lo integer, intent(in) :: i,j,k,ii,jj,kk end function same_label_ftype end interface @@ -100,8 +100,6 @@ subroutine initialize(this,amr,name) call this%id%initialize(amr,name='id',ncomp=1,ng=this%nover);! this%id%parent=>this call this%id%register() ! Update with regriding call this%id%setval(val=0.0_WP) - ! Allocate and initialize periodicity array - call this%idp%initialize(amr,name='idp',ncomp=3,ng=this%nover);! this%idp%parent=>this ! Zero structures this%nstruct=0 end subroutine initialize @@ -110,11 +108,13 @@ end subroutine initialize !> Build structure using the user-set test functions subroutine build(this,make_label,same_label,data) use amrdata_class, only: amrdata + use amrdata_class, only: interp_none implicit none class(amrcclabel), intent(inout) :: this procedure(make_label_ftype) :: make_label procedure(same_label_ftype) :: same_label type(amrdata), intent(in) :: data + type(amrdata) :: idp integer :: nstruct_,stmin,stmax integer, dimension(:), allocatable :: parent !< Resolving structure id across procs integer, dimension(:), allocatable :: parent_all !< Resolving structure id across procs @@ -132,15 +132,17 @@ subroutine build(this,make_label,same_label,data) this%struct(:)%per(3)=0 this%struct(:)%n_=0 - ! Allocate periodicity work array - call this%idp%setval(val=0.0_WP) + ! Allocate PCG work arrays as local scratch on the current grid and zero + ! them (reset only builds, leaving memory uninitialized/snan in debug builds) + call idp%initialize(this%amr,name='idp',ncomp=3,ng=1,interp=interp_none) + call idp%reset() + call idp%setval(0.0_WP) ! Perform a first pass to build proc-local structures and corresponding tree first_pass: block use amrex_amr_module, only: amrex_mfiter,amrex_box integer :: lvl,i,j,k integer :: ii,jj,kk,dim - integer :: fab integer, dimension(3) :: pos type(amrex_mfiter) :: mfi type(amrex_box) :: bx @@ -153,7 +155,7 @@ subroutine build(this,make_label,same_label,data) do while (mfi%next()) ! Get pointers to data arrays pid=>this%id%mf(lvl)%dataptr(mfi) - pidp=>this%idp%mf(lvl)%dataptr(mfi) + pidp=>idp%mf(lvl)%dataptr(mfi) pdata=>data%mf(lvl)%dataptr(mfi) ! Only work on finest level for now if (lvl.ne.data%amr%maxlvl) cycle @@ -161,22 +163,22 @@ subroutine build(this,make_label,same_label,data) 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) ! Find next cell in a structure - if (make_label(pdata,i,j,k)) then + if (make_label(pdata,lbound(pdata),i,j,k)) then ! Loop through one-sided neighbors do dim=1,3 pos=0; pos(dim)=-1 ii=i+pos(1); jj=j+pos(2); kk=k+pos(3) ! Check if neighbor is labeled - if (pid(ii,jj,kk,1).gt.0) then + if (pid(ii,jj,kk,1).gt.0.5_WP) then ! Neighbor is labeled, but are we? if (pid(i,j,k,1).ne.0) then ! We already have a label, perform a union of both labels - if (same_label(pdata,i,j,k,ii,jj,kk)) then + if (same_label(pdata,lbound(pdata),i,j,k,ii,jj,kk)) then pid(i,j,k,1)=union_struct(int(pid(i,j,k,1)),int(pid(ii,jj,kk,1))) end if else ! We don't have a label, check if we take the neighbor's label - if (same_label(pdata,i,j,k,ii,jj,kk)) then + if (same_label(pdata,lbound(pdata),i,j,k,ii,jj,kk)) then pid(i,j,k,1)=pid(ii,jj,kk,1) else pid(i,j,k,1)=add() @@ -187,9 +189,9 @@ subroutine build(this,make_label,same_label,data) ! If no neighbor was labeled, we need a new structure if (pid(i,j,k,1).eq.0) pid(i,j,k,1)=add() ! ! Identify periodicity cases - ! if (this%pg%xper.and.i.eq.this%pg%imax) this%struct(pid(i,j,k,1))%per(1)=1 - ! if (this%pg%yper.and.j.eq.this%pg%jmax) this%struct(pid(i,j,k,1))%per(2)=1 - ! if (this%pg%zper.and.k.eq.this%pg%kmax) this%struct(pid(i,j,k,1))%per(3)=1 + ! if (this%amr%xper.and.i.eq.this%pg%imax) this%struct(pid(i,j,k,1))%per(1)=1 + ! if (this%amr%yper.and.j.eq.this%pg%jmax) this%struct(pid(i,j,k,1))%per(2)=1 + ! if (this%amr%zper.and.k.eq.this%pg%kmax) this%struct(pid(i,j,k,1))%per(3)=1 ! pidp(i,j,k,:)=this%struct(pid(i,j,k,1))%per end if end do; end do; end do @@ -210,87 +212,92 @@ subroutine build(this,make_label,same_label,data) do while (mfi%next()) ! Get pointers to data pid=>this%id%mf(lvl)%dataptr(mfi) - pidp=>this%idp%mf(lvl)%dataptr(mfi) + pidp=>idp%mf(lvl)%dataptr(mfi) ! Only work on finest level for now if (lvl.ne.data%amr%maxlvl) cycle ! Perform local loop 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 (pid(i,j,k,1).gt.0) then + if (pid(i,j,k,1).gt.0.5_WP) then pid(i,j,k,1)=rootify_struct(int(pid(i,j,k,1))) this%struct(int(pid(i,j,k,1)))%n_=this%struct(int(pid(i,j,k,1)))%n_+1 - pidp(i,j,k,1)=max(int(pidp(1,i,j,k)),this%struct(int(pid(i,j,k,1)))%per(1)) - pidp(i,j,k,2)=max(int(pidp(2,i,j,k)),this%struct(int(pid(i,j,k,1)))%per(2)) - pidp(i,j,k,3)=max(int(pidp(3,i,j,k)),this%struct(int(pid(i,j,k,1)))%per(3)) - this%struct(int(pid(i,j,k,1)))%per=int(pidp(:,i,j,k)) + ! pidp(i,j,k,1)=max(int(pidp(i,j,k,1)),this%struct(int(pid(i,j,k,1)))%per(1)) + ! pidp(i,j,k,2)=max(int(pidp(i,j,k,2)),this%struct(int(pid(i,j,k,1)))%per(2)) + ! pidp(i,j,k,3)=max(int(pidp(i,j,k,3)),this%struct(int(pid(i,j,k,1)))%per(3)) + ! this%struct(int(pid(i,j,k,1)))%per=int(pidp(:,i,j,k)) end if end do; end do; end do end do end do end block collapse_tree - ! ! Compact structure array - ! compact_tree: block - ! use mpi_f08, only: MPI_ALLREDUCE,MPI_SUM,MPI_INTEGER - ! integer :: i,j,k,n,ierr - ! integer, dimension(:), allocatable :: my_nstruct,all_nstruct,idmap - ! type(struct_type), dimension(:), allocatable :: tmp - ! ! Count exact number of local structures - ! nstruct_=0 - ! do n=1,size(this%struct,dim=1) - ! if (this%struct(n)%n_.gt.0) nstruct_=nstruct_+1 - ! end do - ! ! Gather this info to ensure unique index - ! allocate( my_nstruct(0:this%pg%nproc-1)); my_nstruct=0; my_nstruct(this%pg%rank)=nstruct_ - ! allocate(all_nstruct(0:this%pg%nproc-1)); call MPI_ALLREDUCE(my_nstruct,all_nstruct,this%pg%nproc,MPI_INTEGER,MPI_SUM,this%pg%comm,ierr) - ! stmin=1 - ! if (this%pg%rank.gt.0) stmin=stmin+sum(all_nstruct(0:this%pg%rank-1)) - ! this%nstruct=sum(all_nstruct) - ! deallocate(my_nstruct,all_nstruct) - ! stmax=stmin+nstruct_-1 - ! ! Generate an index map - ! allocate(idmap(1:size(this%struct,dim=1))); idmap=0 - ! nstruct_=0 - ! do n=1,size(this%struct,dim=1) - ! if (this%struct(n)%n_.gt.0) then - ! nstruct_=nstruct_+1 - ! idmap(n)=stmin+nstruct_-1 - ! end if - ! end do - ! ! Update id array to new index - ! update_id: block - ! use amrex_amr_module, only: amrex_mfiter,amrex_box - ! integer :: lvl - ! type(amrex_mfiter) :: mfi - ! type(amrex_box) :: bx - ! ! Traverse levels ! Only work on finest level for now - ! do lvl=this%amr%finest_level() - ! ! Loop over tiles - ! call this%amr%mfiter_build(lvl,mfi) - ! do while (mfi%next()) - ! ! Get pointers to data - ! pid=>this%id%mf(lvl)%dataptr(mfi) - ! ! Perform local loop - ! 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 (pid(i,j,k,1).gt.0) pid(i,j,k,1)=idmap(pid(i,j,k,1)) - ! end do; end do; end do - ! end do - ! end do - ! end block update_id - ! deallocate(idmap) - ! ! Finish compacting and renumbering - ! allocate(tmp(stmin:stmax)) - ! nstruct_=0 - ! do n=1,size(this%struct,dim=1) - ! if (this%struct(n)%n_.gt.0) then - ! nstruct_=nstruct_+1 - ! tmp(stmin+nstruct_-1)=this%struct(n) - ! allocate(tmp(stmin+nstruct_-1)%map(3,tmp(stmin+nstruct_-1)%n_)) - ! end if - ! end do - ! call move_alloc(tmp,this%struct) - ! end block compact_tree + ! Compact structure array + compact_tree: block + use mpi_f08, only: MPI_ALLREDUCE,MPI_SUM,MPI_INTEGER + integer :: i,j,k,n,ierr + integer, dimension(:), allocatable :: my_nstruct,all_nstruct,idmap + type(struct_type), dimension(:), allocatable :: tmp + real(WP), dimension(:,:,:,:), contiguous, pointer :: pid + ! Count exact number of local structures + nstruct_=0 + do n=1,size(this%struct,dim=1) + if (this%struct(n)%n_.gt.0.5_WP) nstruct_=nstruct_+1 + end do + ! Gather this info to ensure unique index + allocate( my_nstruct(0:this%amr%nproc-1)); my_nstruct=0; my_nstruct(this%amr%rank)=nstruct_ + allocate(all_nstruct(0:this%amr%nproc-1)); call MPI_ALLREDUCE(my_nstruct,all_nstruct,this%amr%nproc,MPI_INTEGER,MPI_SUM,this%amr%comm,ierr) + stmin=1 + if (this%amr%rank.gt.0) stmin=stmin+sum(all_nstruct(0:this%amr%rank-1)) + this%nstruct=sum(all_nstruct) + deallocate(my_nstruct,all_nstruct) + stmax=stmin+nstruct_-1 + ! Generate an index map + allocate(idmap(1:size(this%struct,dim=1))); idmap=0 + nstruct_=0 + do n=1,size(this%struct,dim=1) + if (this%struct(n)%n_.gt.0) then + nstruct_=nstruct_+1 + idmap(n)=stmin+nstruct_-1 + end if + end do + ! Update id array to new index + update_id: block + use amrex_amr_module, only: amrex_mfiter,amrex_box + integer :: lvl + type(amrex_mfiter) :: mfi + type(amrex_box) :: bx + ! Traverse levels ! Only work on finest level for now + do lvl=0,data%amr%clvl() + ! Loop over tiles + call this%amr%mfiter_build(lvl,mfi) + do while (mfi%next()) + ! Get pointers to data + pid=>this%id%mf(lvl)%dataptr(mfi) + ! Only work on finest level for now + if (lvl.ne.data%amr%maxlvl) cycle + ! Perform local loop + 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 (pid(i,j,k,1).gt.0.5_WP) then + pid(i,j,k,1)=idmap(int(pid(i,j,k,1))) + end if + end do; end do; end do + end do + end do + end block update_id + deallocate(idmap) + ! Finish compacting and renumbering + allocate(tmp(stmin:stmax)) + nstruct_=0 + do n=1,size(this%struct,dim=1) + if (this%struct(n)%n_.gt.0) then + nstruct_=nstruct_+1 + tmp(stmin+nstruct_-1)=this%struct(n) + allocate(tmp(stmin+nstruct_-1)%map(tmp(stmin+nstruct_-1)%n_)) + end if + end do + call move_alloc(tmp,this%struct) + end block compact_tree ! ! Fill out the node map ! node_map: block @@ -311,7 +318,7 @@ subroutine build(this,make_label,same_label,data) ! ! Perform local loop ! 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 (pid(i,j,k,1).gt.0) then + ! if (pid(i,j,k,.gt.0.5_WP then ! counter(pid(i,j,k,1))=counter(pid(i,j,k,1))+1 ! this%struct(pid(i,j,k,1))%map(:,counter(pid(i,j,k,1))))=[i,j,k] ! end if @@ -319,130 +326,126 @@ subroutine build(this,make_label,same_label,data) ! deallocate(counter) ! end block node_map - ! ! Interprocessor treatment of our structures - ! interproc_handling: block - ! use mpi_f08, only: MPI_ALLREDUCE,MPI_MIN,MPI_MAX,MPI_INTEGER - ! integer :: i,j,k,stop_global,stop_,counter,n,m,ierr,find_parent,find_parent_own - ! ! Allocate to total number of structures - ! allocate(parent (this%nstruct)); parent =0 - ! allocate(parent_all(this%nstruct)); parent_all=0 - ! allocate(parent_own(this%nstruct)); parent_own=0 - ! ! Fill global lineage with selves - ! do n=1,this%nstruct - ! parent(n)=n - ! end do - ! ! Synchronize id array - ! call sync_lvl(this%id,this%amr%finest_level()) - ! ! Handle imin_ border - ! if (this%pg%imin_.ne.this%pg%imin) then ! ?????????????? - ! ! Traverse levels ! Only work on finest level for now - ! do lvl=this%amr%finest_level() - ! ! Loop over tiles - ! call this%amr%mfiter_build(lvl,mfi) - ! do while (mfi%next()) - ! ! Get pointers to data - ! pid=>this%id%mf(lvl)%dataptr(mfi) - ! pVF=>this%VF%mf(lvl)%dataptr(mfi) - ! ! Perform local loop - ! bx=mfi%tilebox() - ! do k=bx%lo(3),bx%hi(3); do j=bx%lo(2),bx%hi(2) - ! if (pid(bx%lo(1),j,k,1).gt.0.and(pid(bx%lo(1)-1,j,k,1).gt.0)) then - ! if (same_label(pVF(bx%lo(1),j,k),pVF(bx%lo(1)-1,j,k))) call union_parent(pid(bx%lo(1),j,k),pid(bx%lo(1)-1,j,k)) - ! end if - ! end do; end do - ! end if - ! end do; end do - ! end if - ! ! Handle jmin_ border - ! if (this%pg%jmin_.ne.this%pg%jmin) then ! ????????????? - ! ! Traverse levels ! Only work on finest level for now - ! do lvl=this%amr%finest_level() - ! ! Loop over tiles - ! call this%amr%mfiter_build(lvl,mfi) - ! do while (mfi%next()) - ! ! Get pointers to data - ! pid=>this%id%mf(lvl)%dataptr(mfi) - ! pVF=>this%VF%mf(lvl)%dataptr(mfi) - ! ! Perform local loop - ! bx=mfi%tilebox() - ! do k=bx%lo(3),bx%hi(3); do i=bx%lo(1),bx%hi(1) - ! if (pid(i,bx%lo(2),k,1).gt.0.and(pid(i,bx%lo(2)-1,k,1).gt.0)) then - ! if (same_label(pVF(i,bx%lo(2),k),pVF(i,bx%lo(2)-1,k))) call union_parent(pid(i,bx%lo(2),k),pid(i,bx%lo(2)-1,k)) - ! end if - ! end do; end do - ! end if - ! end do; end do - ! end if - ! ! Handle kmin_ border - ! if (this%pg%kmin_.ne.this%pg%kmin) then ! ????????????? - ! ! Traverse levels ! Only work on finest level for now - ! do lvl=this%amr%finest_level() - ! ! Loop over tiles - ! call this%amr%mfiter_build(lvl,mfi) - ! do while (mfi%next()) - ! ! Get pointers to data - ! pid=>this%id%mf(lvl)%dataptr(mfi) - ! pVF=>this%VF%mf(lvl)%dataptr(mfi) - ! ! Perform local loop - ! bx=mfi%tilebox() - ! do j=bx%lo(2),bx%hi(2); do i=bx%lo(1),bx%hi(1) - ! if (pid(i,j,bx%lo(3),1).gt.0.and(pid(i,j,bx%lo(3)-1,1).gt.0)) then - ! if (same_label(pVF(i,j,bx%lo(3)),pVF(i,j,bx%lo(3)-1))) call union_parent(pid(i,j,bx%lo(3)),pid(i,j,bx%lo(3)-1)) - ! end if - ! end do; end do - ! end if - ! end do; end do - ! end if - ! ! Initialize global stop criterion and counter - ! stop_global=1 - ! counter=0 - ! ! Resolve lineage - ! do while (stop_global.ne.0) - ! ! Initialize local stop flag - ! stop_=0 - ! ! Remember own parents - ! parent_own=parent - ! ! Set self-parents to huge(1) - ! do n=1,this%nstruct - ! if (parent(n).eq.n) parent(n)=huge(1) - ! end do - ! ! Take global min - ! call MPI_ALLREDUCE(parent,parent_all,this%nstruct,MPI_INTEGER,MPI_MIN,this%pg%comm,ierr) - ! ! Set self-parents back to selves - ! do n=1,this%nstruct - ! if (parent_all(n).eq.huge(1)) parent_all(n)=n - ! end do - ! ! Flatten trees - ! do n=1,this%nstruct - ! parent_all(n)=find_all(n) - ! parent_own(n)=find_own(n) - ! end do - ! ! Start with final parent array being equal to parent_all - ! parent=parent_all - ! ! Increment counter - ! counter=counter+1 - ! ! Reconcile conflicts between parent_all and parent_own - ! do n=1,this%nstruct - ! if (parent_own(n).ne.n) then - ! find_parent_own=rootify_parent(parent_own(n)) - ! find_parent =rootify_parent(parent(n)) - ! if (find_parent_own.ne.find_parent) then - ! call union_parent(find_parent,find_parent_own) - ! stop_=1 - ! end if - ! end if - ! end do - ! ! Check if we did some changes - ! call MPI_ALLREDUCE(stop_,stop_global,1,MPI_INTEGER,MPI_MAX,this%pg%comm,ierr) - ! end do - ! ! Update this%struct%parent by pointing all parents to root and update id - ! do n=stmin,stmax - ! this%struct(n)%parent=rootify_parent(parent(n)) - ! do m=1,this%struct(n)%n_ - ! this%id(this%struct(n)%map(1,m),this%struct(n)%map(2,m),this%struct(n)%map(3,m))=this%struct(n)%parent - ! end do - ! end do - ! end block interproc_handling + ! Interprocessor treatment of our structures + interproc_handling: block + use mpi_f08, only: MPI_ALLREDUCE,MPI_MIN,MPI_MAX,MPI_INTEGER + use amrex_amr_module, only: amrex_mfiter,amrex_box + integer :: lvl,i,j,k + integer :: ii,jj,kk,dim + integer, dimension(3) :: pos + integer ::stop_global,stop_,counter,n,m,ierr,find_parent,find_parent_own + type(amrex_mfiter) :: mfi + type(amrex_box) :: bx + real(WP), dimension(:,:,:,:), contiguous, pointer :: pid,pidp,pdata + ! Allocate to total number of structures + allocate(parent (this%nstruct)); parent =0 + allocate(parent_all(this%nstruct)); parent_all=0 + allocate(parent_own(this%nstruct)); parent_own=0 + ! Fill global lineage with selves + do n=1,this%nstruct + parent(n)=n + end do + ! Synchronize id array + call this%id%sync() + ! Loop over cells and check for connections across periodic boundaries, storing parent connections in parent array + ! Traverse levels ! Only work on finest level for now + do lvl=0,data%amr%clvl() + ! Loop over tiles + call this%amr%mfiter_build(lvl,mfi) + do while (mfi%next()) + ! Get pointers to data + pid=>this%id%mf(lvl)%dataptr(mfi) + pdata=>data%mf(lvl)%dataptr(mfi) + ! Only work on finest level for now + if (lvl.ne.data%amr%maxlvl) cycle + ! Perform local loop + 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) + ! Only work with labeled cells + if (pid(i,j,k,1).lt.0.5_WP) cycle + ! Loop through one-sided neighbors + do dim=1,3 + pos=0; pos(dim)=-1 + ii=i+pos(1); jj=j+pos(2); kk=k+pos(3) + if (pid(ii,jj,kk,1).lt.0.5_WP) cycle + ! Check if we should connect these two cells + if (same_label(pdata,lbound(pdata),i,j,k,ii,jj,kk)) then + ! Update parent array to reflect connection + call union_parent(int(pid(i,j,k,1)),int(pid(ii,jj,kk,1))) + end if + end do + end do; end do; end do + end do + end do + + ! Initialize global stop criterion and counter + stop_global=1 + counter=0 + ! Resolve lineage + do while (stop_global.ne.0) + ! Initialize local stop flag + stop_=0 + ! Remember own parents + parent_own=parent + ! Set self-parents to huge(1) + do n=1,this%nstruct + if (parent(n).eq.n) parent(n)=huge(1) + end do + ! Take global min + call MPI_ALLREDUCE(parent,parent_all,this%nstruct,MPI_INTEGER,MPI_MIN,this%amr%comm,ierr) + ! Set self-parents back to selves + do n=1,this%nstruct + if (parent_all(n).eq.huge(1)) parent_all(n)=n + end do + ! Flatten trees + do n=1,this%nstruct + parent_all(n)=find_all(n) + parent_own(n)=find_own(n) + end do + ! Start with final parent array being equal to parent_all + parent=parent_all + ! Increment counter + counter=counter+1 + ! Reconcile conflicts between parent_all and parent_own + do n=1,this%nstruct + if (parent_own(n).ne.n) then + find_parent_own=rootify_parent(parent_own(n)) + find_parent =rootify_parent(parent(n)) + if (find_parent_own.ne.find_parent) then + call union_parent(find_parent,find_parent_own) + stop_=1 + end if + end if + end do + ! Check if we did some changes + call MPI_ALLREDUCE(stop_,stop_global,1,MPI_INTEGER,MPI_MAX,this%amr%comm,ierr) + end do + ! Update this%struct%parent by pointing all parents to root and update id + ! do n=stmin,stmax + ! this%struct(n)%parent=rootify_parent(parent(n)) + ! do m=1,this%struct(n)%n_ + ! this%id(this%struct(n)%map(m)%i,this%struct(n)%map(m)%j,this%struct(n)%map(m)%k)=this%struct(n)%parent + ! end do + ! end do + ! Traverse levels + do lvl=0,data%amr%clvl() + ! Loop over tiles + call data%amr%mfiter_build(lvl,mfi) + do while (mfi%next()) + ! Get pointers to data arrays + pid=>this%id%mf(lvl)%dataptr(mfi) + ! Only work on finest level for now + if (lvl.ne.data%amr%maxlvl) cycle + ! Perform local loop + 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 (pid(i,j,k,1).gt.0.5_WP) then + pid(i,j,k,1)=rootify_parent(parent(int(pid(i,j,k,1)))) + end if + end do; end do; end do + end do + end do + end block interproc_handling ! ! Update periodicity array across processors ! periodicity_update: block @@ -457,7 +460,7 @@ subroutine build(this,make_label,same_label,data) ! ownper(:,n)=this%struct(n)%per ! end do ! ! Communicate per - ! call MPI_ALLREDUCE(ownper,allper,3*this%nstruct,MPI_INTEGER,MPI_MAX,this%pg%comm,ierr) + ! call MPI_ALLREDUCE(ownper,allper,3*this%nstruct,MPI_INTEGER,MPI_MAX,this%amr%comm,ierr) ! ! Update parent per ! do n=1,this%nstruct ! allper(:,parent(n))=max(allper(:,parent(n)),allper(:,n)) @@ -465,7 +468,7 @@ subroutine build(this,make_label,same_label,data) ! ! Update idp array ! do n=stmin,stmax ! do m=1,this%struct(n)%n_ - ! idp(:,this%struct(n)%map(1,m),this%struct(n)%map(2,m),this%struct(n)%map(3,m))=allper(:,this%id(this%struct(n)%map(1,m),this%struct(n)%map(2,m),this%struct(n)%map(3,m))) + ! idp(:,this%struct(n)%map(m))=allper(:,this%id(this%struct(n)%map(m))) ! end do ! end do ! ! Clean up @@ -514,7 +517,7 @@ subroutine build(this,make_label,same_label,data) ! if (parent(n).eq.n) parent(n)=huge(1) ! end do ! ! Take global min - ! call MPI_ALLREDUCE(parent,parent_all,this%nstruct,MPI_INTEGER,MPI_MIN,this%pg%comm,ierr) + ! call MPI_ALLREDUCE(parent,parent_all,this%nstruct,MPI_INTEGER,MPI_MIN,this%amr%comm,ierr) ! ! Set self-parents back to selves ! do n=1,this%nstruct ! if (parent_all(n).eq.huge(1)) parent_all(n)=n @@ -540,7 +543,7 @@ subroutine build(this,make_label,same_label,data) ! end if ! end do ! ! Check if we did some changes - ! call MPI_ALLREDUCE(stop_,stop_global,1,MPI_INTEGER,MPI_MAX,this%pg%comm,ierr) + ! call MPI_ALLREDUCE(stop_,stop_global,1,MPI_INTEGER,MPI_MAX,this%amr%comm,ierr) ! end do ! ! Update this%struct%parent and point all parents to root and update id ! do n=stmin,stmax @@ -647,7 +650,9 @@ subroutine build(this,make_label,same_label,data) ! if (this%id(i,j,k).eq.1) then; this%id(i,j,k)=bigid; else if (this%id(i,j,k).eq.bigid) then; this%id(i,j,k)=1; end if ! end do; end do; end do ! end block rename_largest_structure - + + ! Release scratch + call idp%finalize() contains @@ -791,7 +796,6 @@ subroutine finalize(this) class(amrcclabel), intent(inout) :: this call this%empty() call this%id%finalize() - call this%idp%finalize() ! nullify(this%pg) this%name='UNNAMED_CCL' end subroutine finalize From cb5656f78cac9ac9d32f4c1ede13ab4c16080ac4 Mon Sep 17 00:00:00 2001 From: Mark Owkes Date: Tue, 9 Jun 2026 16:39:18 -0600 Subject: [PATCH 47/70] Added radius scale for addtional testing. Works when all of liquid is on finest level. --- examples/amrcclabel_tester/src/simulation.f90 | 10 +++++++--- 1 file changed, 7 insertions(+), 3 deletions(-) diff --git a/examples/amrcclabel_tester/src/simulation.f90 b/examples/amrcclabel_tester/src/simulation.f90 index f936f7758..d5bb29045 100644 --- a/examples/amrcclabel_tester/src/simulation.f90 +++ b/examples/amrcclabel_tester/src/simulation.f90 @@ -172,10 +172,12 @@ subroutine simulation_init use random, only: random_uniform integer :: nD,nseed real(WP), dimension(3) :: center,radius + real(WP) :: radius_scale integer :: myseed integer, dimension(:), allocatable :: seed call param_read('Number of ellipsoids',nEllipsoid,default=4) call param_read('Random seed',myseed,default=1) + call param_read('Radius scale',radius_scale,default=0.5_WP) ! Allocate arrays allocate(ellipsoid_center(3,nEllipsoid)) allocate(ellipsoid_radius(3,nEllipsoid)) @@ -188,10 +190,12 @@ subroutine simulation_init center=[random_uniform(amr%xlo, amr%xhi), & random_uniform(amr%ylo, amr%yhi), & random_uniform(amr%zlo, amr%zhi) ] + center=[0.5_WP,0.5_WP,0.5_WP] ! For testing ellipsoid_center(:,nD)=center - radius=[0.5*random_uniform(amr%xlo, amr%xhi), & - 0.5*random_uniform(amr%ylo, amr%yhi), & - 0.5*random_uniform(amr%zlo, amr%zhi) ] + radius=[radius_scale*random_uniform(amr%xlo, amr%xhi), & + radius_scale*random_uniform(amr%ylo, amr%yhi), & + radius_scale*random_uniform(amr%zlo, amr%zhi) ] + radius=[0.4_WP,10.0_WP,0.4_WP] ! For testing ellipsoid_radius(:,nD)=radius end do end block setup_Ellipsoids From dbf00cabb7c3e1be5a9ce29efdee58c3c4870522 Mon Sep 17 00:00:00 2001 From: Mark Owkes Date: Tue, 16 Jun 2026 16:38:44 -0600 Subject: [PATCH 48/70] Not quite working, but should have been committing more often, so committing now. --- examples/amrcclabel_tester/input | 11 +- examples/amrcclabel_tester/src/simulation.f90 | 129 ++- src/amrbase/amrcclabel_class.f90 | 829 ++++++++---------- src/amrbase/amrex_interface.f90 | 17 + src/amrbase/amrex_wrapper.cpp | 105 +++ 5 files changed, 579 insertions(+), 512 deletions(-) diff --git a/examples/amrcclabel_tester/input b/examples/amrcclabel_tester/input index 71691219a..f683868d3 100644 --- a/examples/amrcclabel_tester/input +++ b/examples/amrcclabel_tester/input @@ -2,14 +2,13 @@ Partition : 1 1 1 # Mesh definition -Base nx : 8 -Base ny : 8 -Base nz : 8 +Base nx : 16 +Base ny : 16 +Base nz : 16 Max level : 3 -# Droplet properties -Random seed : 3 -Number of ellipsoids : 4 +# Ellipsoid properties +Droplet case : Cylinder # Random or Cylinder # Time integration Max timestep size : 2.5e-3 diff --git a/examples/amrcclabel_tester/src/simulation.f90 b/examples/amrcclabel_tester/src/simulation.f90 index d5bb29045..7b10ee7f4 100644 --- a/examples/amrcclabel_tester/src/simulation.f90 +++ b/examples/amrcclabel_tester/src/simulation.f90 @@ -40,7 +40,6 @@ module simulation contains - !> Function that identifies cells within a structure logical function make_label(pVF,lo,i,j,k) implicit none @@ -58,27 +57,66 @@ logical function make_label(pVF,lo,i,j,k) end if end function make_label - !> Function that identifies if neighbors are within the same structure + !> Function that identifies if neighbors are within the same structure logical function same_label(pVF,lo,i,j,k,ii,jj,kk) - implicit none - real(WP), dimension(:,:,:,:), intent(in) :: pVF - integer, dimension(3), intent(in) :: lo - integer, intent(in) :: i,j,k,ii,jj,kk - integer :: il,jl,kl,iil,jjl,kkl - il = i - lo(1) + 1 - jl = j - lo(2) + 1 - kl = k - lo(3) + 1 - iil = ii - lo(1) + 1 - jjl = jj - lo(2) + 1 - kkl = kk - lo(3) + 1 - if (pVF(il,jl,kl,1).gt.0.0_WP .and. pVF(iil,jjl,kkl,1).gt.0.0_WP) then - same_label=.true. - else - same_label=.false. - end if + implicit none + real(WP), dimension(:,:,:,:), intent(in) :: pVF + integer, dimension(3), intent(in) :: lo + integer, intent(in) :: i,j,k,ii,jj,kk + integer :: il,jl,kl,iil,jjl,kkl + il = i - lo(1) + 1 + jl = j - lo(2) + 1 + kl = k - lo(3) + 1 + iil = ii - lo(1) + 1 + jjl = jj - lo(2) + 1 + kkl = kk - lo(3) + 1 + if (pVF(il,jl,kl,1).gt.0.0_WP .and. pVF(iil,jjl,kkl,1).gt.0.0_WP) then + same_label=.true. + else + same_label=.false. + end if end function same_label - !> Ellipsoids levelset function with periodicity + !> Function that identifies cells within a structure on coarse level + logical function coarse_make_label(pVF,lo,i,j,k) + use amrmpinc_class, only: VFhi + implicit none + real(WP), dimension(:,:,:,:), intent(in) :: pVF + integer, dimension(3), intent(in) :: lo + integer, intent(in) :: i,j,k + integer :: il,jl,kl + il = i - lo(1) + 1 + jl = j - lo(2) + 1 + kl = k - lo(3) + 1 + if (pVF(il,jl,kl,1).gt.VFhi) then + coarse_make_label=.true. + else + coarse_make_label=.false. + end if + end function coarse_make_label + + !> Function that identifies if neighbors are within the same structure on coarse level + logical function coarse_same_label(pVF,lo,i,j,k,ii,jj,kk) + use amrmpinc_class, only: VFhi + implicit none + real(WP), dimension(:,:,:,:), intent(in) :: pVF + integer, dimension(3), intent(in) :: lo + integer, intent(in) :: i,j,k,ii,jj,kk + integer :: il,jl,kl,iil,jjl,kkl + il = i - lo(1) + 1 + jl = j - lo(2) + 1 + kl = k - lo(3) + 1 + iil = ii - lo(1) + 1 + jjl = jj - lo(2) + 1 + kkl = kk - lo(3) + 1 + if (pVF(il,jl,kl,1).gt.VFhi .and. pVF(iil,jjl,kkl,1).gt.VFhi) then + coarse_same_label=.true. + else + coarse_same_label=.false. + end if + end function coarse_same_label + + !> Ellipsoids levelset function with periodicity function Ellipsoids_levelset(xyz,t) result(G) implicit none real(WP), dimension(3), intent(in) :: xyz @@ -170,32 +208,51 @@ subroutine simulation_init ! Setup Ellipsoids parameters setup_Ellipsoids: block use random, only: random_uniform + use string, only: str_medium + use messager, only: die integer :: nD,nseed real(WP), dimension(3) :: center,radius real(WP) :: radius_scale integer :: myseed integer, dimension(:), allocatable :: seed - call param_read('Number of ellipsoids',nEllipsoid,default=4) - call param_read('Random seed',myseed,default=1) - call param_read('Radius scale',radius_scale,default=0.5_WP) + character(len=str_medium) :: case + call param_read('Droplet case',case,default='Random') + if (case == 'Random') then + call param_read('Number of ellipsoids',nEllipsoid,default=4) + call param_read('Random seed',myseed,default=3) + call param_read('Radius scale',radius_scale,default=0.5_WP) + ! Provide seed for random number generator + call random_seed(size=nseed) + allocate(seed(nseed)) + seed(:)=myseed + call random_seed(put=seed) + else if (case == 'Cylinder') then + nEllipsoid=1 + end if + ! Allocate arrays allocate(ellipsoid_center(3,nEllipsoid)) allocate(ellipsoid_radius(3,nEllipsoid)) - ! Provide seed for random number generator - call random_seed(size=nseed) - allocate(seed(nseed)) - seed(:)=myseed - call random_seed(put=seed) + + ! Define centers and radii of ellipsoids do nD=1,nEllipsoid - center=[random_uniform(amr%xlo, amr%xhi), & - random_uniform(amr%ylo, amr%yhi), & - random_uniform(amr%zlo, amr%zhi) ] - center=[0.5_WP,0.5_WP,0.5_WP] ! For testing + if (case == 'Random') then + ! Random center and radius + center=[random_uniform(amr%xlo, amr%xhi), & + random_uniform(amr%ylo, amr%yhi), & + random_uniform(amr%zlo, amr%zhi) ] + radius=[radius_scale*random_uniform(amr%xlo, amr%xhi), & + radius_scale*random_uniform(amr%ylo, amr%yhi), & + radius_scale*random_uniform(amr%zlo, amr%zhi) ] + else if (case == 'Cylinder') then + ! Large cylinder for testing multiple levels representing one structure + center=[0.5_WP, 0.5_WP,0.5_WP] + radius=[0.4_WP,10.0_WP,0.4_WP] + else + call die('Unknown droplet case') + end if + ellipsoid_center(:,nD)=center - radius=[radius_scale*random_uniform(amr%xlo, amr%xhi), & - radius_scale*random_uniform(amr%ylo, amr%yhi), & - radius_scale*random_uniform(amr%zlo, amr%zhi) ] - radius=[0.4_WP,10.0_WP,0.4_WP] ! For testing ellipsoid_radius(:,nD)=radius end do end block setup_Ellipsoids @@ -251,7 +308,7 @@ end subroutine simulation_init subroutine simulation_run ! Compute CCLabel - call cclabel%build(make_label,same_label,vof%VF) + call cclabel%build(make_label,same_label,coarse_make_label,coarse_same_label,vof%VF) ! Write visualization with IDs call viz%write(time=0.0_WP) diff --git a/src/amrbase/amrcclabel_class.f90 b/src/amrbase/amrcclabel_class.f90 index 9f8c554b6..f0cd69920 100644 --- a/src/amrbase/amrcclabel_class.f90 +++ b/src/amrbase/amrcclabel_class.f90 @@ -1,10 +1,7 @@ !> TODO -! - How to deal with what used to be domain boundaries -! if (this%pg%imin_.ne.this%pg%imin) then ! ?????????????? -! - How to deal with VF? How to access values? -! - How should map be represented? If it should. -! old - i,j,k -! new - level, tile(?), i,j,k +! - restict seems to be working +! - Now need to update cells on a coarse level that are completely liquid - i think. Test with level = 3 or 4? + !> Connected component labeling class: identifies Lagrangian objects from a Eulerian logical field !> and provides unstructured mapping to traverse these objects @@ -25,20 +22,11 @@ module amrcclabel_class ! Some parameters for memory management integer , parameter :: min_struct_size=100 !< Default minimum size of structure storage real(WP), parameter :: coeff_up=1.5_WP !< When we run out of structure storage, increase by 50% - - !> Map object - type :: map_type - integer :: lvl !< AMR level - integer :: fab !< mfi%index() - integer, dimension(:), allocatable :: i,j,k !< Cell index - end type map_type - !> Structure object type :: struct_type integer :: parent !< ID of parent struct integer :: n_ !< Number of local cells contained in struct - type(map_type), dimension(:), allocatable :: map !< List of cells contained in struct integer, dimension(3) :: per !< Periodicity array - per(dim)=1 if structure is periodic in dim direction end type struct_type @@ -55,6 +43,8 @@ module amrcclabel_class integer :: nover=1 ! Associated amr grid class(amrgrid), pointer, private :: amr => null() + ! Temporary arrays for interlevel sync + type(amrdata) :: tmp_id,tmp_conflict contains procedure :: initialize procedure :: build @@ -64,9 +54,9 @@ module amrcclabel_class !> Type of the make_label function used to generate a structure interface - logical function make_label_ftype(pVF,lo,i,j,k) + logical function make_label_ftype(pdata,lo,i,j,k) use precision, only: WP - real(WP), dimension(:,:,:,:), intent(in) :: pVF + real(WP), dimension(:,:,:,:), intent(in) :: pdata integer, dimension(3), intent(in) :: lo integer, intent(in) :: i,j,k end function make_label_ftype @@ -74,20 +64,20 @@ end function make_label_ftype !> Type of the same_label function used to connect two structures interface - logical function same_label_ftype(pVF,lo,i,j,k,ii,jj,kk) + logical function same_label_ftype(pdata,lo,i,j,k,ii,jj,kk) use precision, only: WP - real(WP), dimension(:,:,:,:), intent(in) :: pVF + real(WP), dimension(:,:,:,:), intent(in) :: pdata integer, dimension(3), intent(in) :: lo integer, intent(in) :: i,j,k,ii,jj,kk end function same_label_ftype end interface - contains !> Initialization for amrcclabel class subroutine initialize(this,amr,name) + use amrdata_class, only: interp_none implicit none class(amrcclabel) :: this class(amrgrid), target, intent(in) :: amr @@ -97,68 +87,144 @@ subroutine initialize(this,amr,name) ! Point cclabel to amr grid this%amr => amr ! Allocate and initialize ID array - call this%id%initialize(amr,name='id',ncomp=1,ng=this%nover);! this%id%parent=>this + call this%id%initialize(amr,name='id',ncomp=1,ng=this%nover,interp=interp_none);! this%id%parent=>this call this%id%register() ! Update with regriding call this%id%setval(val=0.0_WP) + ! Allocate temporary arrays for interlevel sync + call this%tmp_id%initialize(amr,name='tmp_id',ncomp=1,ng=this%nover) + call this%tmp_conflict%initialize(amr,name='tmp_conflict',ncomp=1,ng=this%nover) + call this%tmp_id%register() ! Update with regriding + call this%tmp_conflict%register() ! Update with regriding ! Zero structures this%nstruct=0 end subroutine initialize !> Build structure using the user-set test functions - subroutine build(this,make_label,same_label,data) + subroutine build(this,make_label,same_label,coarse_make_label,coarse_same_label,data) use amrdata_class, only: amrdata use amrdata_class, only: interp_none implicit none class(amrcclabel), intent(inout) :: this - procedure(make_label_ftype) :: make_label - procedure(same_label_ftype) :: same_label + procedure(make_label_ftype) :: make_label,coarse_make_label + procedure(same_label_ftype) :: same_label,coarse_same_label type(amrdata), intent(in) :: data type(amrdata) :: idp integer :: nstruct_,stmin,stmax integer, dimension(:), allocatable :: parent !< Resolving structure id across procs integer, dimension(:), allocatable :: parent_all !< Resolving structure id across procs integer, dimension(:), allocatable :: parent_own !< Resolving structure id across procs - - ! Start by cleaning up - call this%empty() - - ! Then allocate struct to a default size - nstruct_=0 - allocate(this%struct(min_struct_size)) - this%struct(:)%parent=0 - this%struct(:)%per(1)=0 - this%struct(:)%per(2)=0 - this%struct(:)%per(3)=0 - this%struct(:)%n_=0 - - ! Allocate PCG work arrays as local scratch on the current grid and zero - ! them (reset only builds, leaving memory uninitialized/snan in debug builds) - call idp%initialize(this%amr,name='idp',ncomp=3,ng=1,interp=interp_none) - call idp%reset() - call idp%setval(0.0_WP) - - ! Perform a first pass to build proc-local structures and corresponding tree - first_pass: block - use amrex_amr_module, only: amrex_mfiter,amrex_box - integer :: lvl,i,j,k - integer :: ii,jj,kk,dim - integer, dimension(3) :: pos - type(amrex_mfiter) :: mfi - type(amrex_box) :: bx - real(WP), dimension(:,:,:,:), contiguous, pointer :: pid,pidp,pdata - ! Traverse levels - do lvl=0,data%amr%clvl() + ! Initialized id to zero on all levels + call this%id%setval(0.0_WP) + + ! Build CCL on finest level + call build_lvl(data%amr%maxlvl,make_label,same_label) + + testing_finest: block + integer :: lvl + do lvl = 0,data%amr%maxlvl + call print_ids(lvl,"after build_lvl(finest)") + end do + end block testing_finest + + ! Create unique IDs for each structure on coarser levels + restrict_unique_id: block + use amrex_interface, only: amrmfab_restrict_unique_id + integer :: lvl + integer, dimension(3) :: ref_ratio + do lvl = data%amr%maxlvl-1, 0, -1 ! finest-1 → coarsest + if (this%amr%amRoot) print *,'Restricting to level ',lvl + + ref_ratio(1)=data%amr%rrefx(lvl) + ref_ratio(2)=data%amr%rrefy(lvl) + ref_ratio(3)=data%amr%rrefz(lvl) + + ! Implemented in C to get access to additional functions + call amrmfab_restrict_unique_id( & + this%id%mf(lvl), & ! coarse + this%id%mf(lvl+1), & ! fine + ref_ratio ) + + testing_after_restrict: block + integer :: lvl + do lvl = 0,data%amr%maxlvl + call print_ids(lvl,"after restrict") + end do + end block testing_after_restrict + + ! Build CCL on coarse level + call build_lvl(lvl,coarse_make_label,coarse_same_label) + + end do + end block restrict_unique_id + + testing_end_build: block + integer :: lvl + do lvl = 0,data%amr%maxlvl + call print_ids(lvl,"after build") + end do + end block testing_end_build + + contains + + !> Build structure on a level using user-set test functions + subroutine build_lvl(lvl,make_label,same_label) + integer, intent(in) :: lvl + procedure(make_label_ftype) :: make_label + procedure(same_label_ftype) :: same_label + + ! Start by cleaning up + call this%empty() + + ! Then allocate struct to a default size + nstruct_=0 + allocate(this%struct(min_struct_size)) + this%struct(:)%parent=0 + this%struct(:)%per(1)=0 + this%struct(:)%per(2)=0 + this%struct(:)%per(3)=0 + this%struct(:)%n_=0 + + ! Add any ids from coarser levels to struct array + previous_ids: block + use amrex_amr_module, only: amrex_mfiter,amrex_box + integer :: i,j,k + type(amrex_mfiter) :: mfi + type(amrex_box) :: bx + real(WP), dimension(:,:,:,:), contiguous, pointer :: pid + ! Loop over tiles + call data%amr%mfiter_build(lvl,mfi) + do while (mfi%next()) + ! Get pointers to data arrays + pid=>this%id%mf(lvl)%dataptr(mfi) + ! Perform local loop + 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 (pid(i,j,k,1).gt.0.5_WP) then + call add_existing(nint(pid(i,j,k,1))) + end if + end do; end do; end do + end do + end block previous_ids + + ! Perform a first pass to build proc-local structures and corresponding tree + first_pass: block + use amrex_amr_module, only: amrex_mfiter,amrex_box + integer :: i,j,k + integer :: ii,jj,kk,dim + integer, dimension(3) :: pos + type(amrex_mfiter) :: mfi + type(amrex_box) :: bx + real(WP), dimension(:,:,:,:), contiguous, pointer :: pid,pdata + ! Loop over tiles call data%amr%mfiter_build(lvl,mfi) do while (mfi%next()) ! Get pointers to data arrays pid=>this%id%mf(lvl)%dataptr(mfi) - pidp=>idp%mf(lvl)%dataptr(mfi) + ! pidp=>idp%mf(lvl)%dataptr(mfi) pdata=>data%mf(lvl)%dataptr(mfi) - ! Only work on finest level for now - if (lvl.ne.data%amr%maxlvl) cycle ! Perform local loop 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) @@ -171,14 +237,15 @@ subroutine build(this,make_label,same_label,data) ! Check if neighbor is labeled if (pid(ii,jj,kk,1).gt.0.5_WP) then ! Neighbor is labeled, but are we? - if (pid(i,j,k,1).ne.0) then + if (pid(i,j,k,1).gt.0.5_WP) then ! We already have a label, perform a union of both labels if (same_label(pdata,lbound(pdata),i,j,k,ii,jj,kk)) then - pid(i,j,k,1)=union_struct(int(pid(i,j,k,1)),int(pid(ii,jj,kk,1))) + pid(i,j,k,1)=union_struct(nint(pid(i,j,k,1)),nint(pid(ii,jj,kk,1))) end if else ! We don't have a label, check if we take the neighbor's label if (same_label(pdata,lbound(pdata),i,j,k,ii,jj,kk)) then + ! print *,'Using neighbor''s label' pid(i,j,k,1)=pid(ii,jj,kk,1) else pid(i,j,k,1)=add() @@ -187,7 +254,9 @@ subroutine build(this,make_label,same_label,data) end if end do ! If no neighbor was labeled, we need a new structure - if (pid(i,j,k,1).eq.0) pid(i,j,k,1)=add() + if (pid(i,j,k,1).eq.0) then + pid(i,j,k,1)=add() + end if ! ! Identify periodicity cases ! if (this%amr%xper.and.i.eq.this%pg%imax) this%struct(pid(i,j,k,1))%per(1)=1 ! if (this%amr%yper.and.j.eq.this%pg%jmax) this%struct(pid(i,j,k,1))%per(2)=1 @@ -196,168 +265,127 @@ subroutine build(this,make_label,same_label,data) end if end do; end do; end do end do - end do - end block first_pass - - ! Now collapse the tree, count the cells and resolve periodicity in each structure - collapse_tree: block - use amrex_amr_module, only: amrex_mfiter,amrex_box - integer :: lvl,i,j,k - type(amrex_mfiter) :: mfi - type(amrex_box) :: bx - real(WP), dimension(:,:,:,:), contiguous, pointer :: pid,pidp - do lvl=0,data%amr%clvl() + end block first_pass + + ! Now collapse the tree, count the cells and resolve periodicity in each structure + collapse_tree: block + use amrex_amr_module, only: amrex_mfiter,amrex_box + integer :: i,j,k + type(amrex_mfiter) :: mfi + type(amrex_box) :: bx + real(WP), dimension(:,:,:,:), contiguous, pointer :: pid,pidp ! Loop over tiles call data%amr%mfiter_build(lvl,mfi) do while (mfi%next()) ! Get pointers to data pid=>this%id%mf(lvl)%dataptr(mfi) - pidp=>idp%mf(lvl)%dataptr(mfi) - ! Only work on finest level for now - if (lvl.ne.data%amr%maxlvl) cycle ! Perform local loop 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 (pid(i,j,k,1).gt.0.5_WP) then - pid(i,j,k,1)=rootify_struct(int(pid(i,j,k,1))) - this%struct(int(pid(i,j,k,1)))%n_=this%struct(int(pid(i,j,k,1)))%n_+1 - ! pidp(i,j,k,1)=max(int(pidp(i,j,k,1)),this%struct(int(pid(i,j,k,1)))%per(1)) - ! pidp(i,j,k,2)=max(int(pidp(i,j,k,2)),this%struct(int(pid(i,j,k,1)))%per(2)) - ! pidp(i,j,k,3)=max(int(pidp(i,j,k,3)),this%struct(int(pid(i,j,k,1)))%per(3)) - ! this%struct(int(pid(i,j,k,1)))%per=int(pidp(:,i,j,k)) + ! if (nint(pid(i,j,k,1)).ne.1) then + ! print *,' collapsing ',pid(i,j,k,1),' into ',rootify_struct(nint(pid(i,j,k,1))) + ! end if + pid(i,j,k,1)=rootify_struct(nint(pid(i,j,k,1))) + this%struct(nint(pid(i,j,k,1)))%n_=this%struct(nint(pid(i,j,k,1)))%n_+1 + ! pidp(i,j,k,1)=max(nint(pidp(i,j,k,1)),this%struct(nint(pid(i,j,k,1)))%per(1)) + ! pidp(i,j,k,2)=max(nint(pidp(i,j,k,2)),this%struct(nint(pid(i,j,k,1)))%per(2)) + ! pidp(i,j,k,3)=max(nint(pidp(i,j,k,3)),this%struct(nint(pid(i,j,k,1)))%per(3)) + ! this%struct(nint(pid(i,j,k,1)))%per=nint(pidp(:,i,j,k)) end if end do; end do; end do end do - end do - end block collapse_tree - - ! Compact structure array - compact_tree: block - use mpi_f08, only: MPI_ALLREDUCE,MPI_SUM,MPI_INTEGER - integer :: i,j,k,n,ierr - integer, dimension(:), allocatable :: my_nstruct,all_nstruct,idmap - type(struct_type), dimension(:), allocatable :: tmp - real(WP), dimension(:,:,:,:), contiguous, pointer :: pid - ! Count exact number of local structures - nstruct_=0 - do n=1,size(this%struct,dim=1) - if (this%struct(n)%n_.gt.0.5_WP) nstruct_=nstruct_+1 - end do - ! Gather this info to ensure unique index - allocate( my_nstruct(0:this%amr%nproc-1)); my_nstruct=0; my_nstruct(this%amr%rank)=nstruct_ - allocate(all_nstruct(0:this%amr%nproc-1)); call MPI_ALLREDUCE(my_nstruct,all_nstruct,this%amr%nproc,MPI_INTEGER,MPI_SUM,this%amr%comm,ierr) - stmin=1 - if (this%amr%rank.gt.0) stmin=stmin+sum(all_nstruct(0:this%amr%rank-1)) - this%nstruct=sum(all_nstruct) - deallocate(my_nstruct,all_nstruct) - stmax=stmin+nstruct_-1 - ! Generate an index map - allocate(idmap(1:size(this%struct,dim=1))); idmap=0 - nstruct_=0 - do n=1,size(this%struct,dim=1) - if (this%struct(n)%n_.gt.0) then - nstruct_=nstruct_+1 - idmap(n)=stmin+nstruct_-1 - end if - end do - ! Update id array to new index - update_id: block - use amrex_amr_module, only: amrex_mfiter,amrex_box - integer :: lvl - type(amrex_mfiter) :: mfi - type(amrex_box) :: bx - ! Traverse levels ! Only work on finest level for now - do lvl=0,data%amr%clvl() + end block collapse_tree + + ! Compact structure array + compact_tree: block + use mpi_f08, only: MPI_ALLREDUCE,MPI_SUM,MPI_INTEGER + integer :: i,j,k,n,ierr + integer, dimension(:), allocatable :: my_nstruct,all_nstruct,idmap + type(struct_type), dimension(:), allocatable :: tmp + real(WP), dimension(:,:,:,:), contiguous, pointer :: pid + ! Count exact number of local structures + nstruct_=0 + do n=1,size(this%struct,dim=1) + if (this%struct(n)%n_.gt.0) nstruct_=nstruct_+1 + end do + ! Gather this info to ensure unique index + allocate( my_nstruct(0:this%amr%nproc-1)); my_nstruct=0; my_nstruct(this%amr%rank)=nstruct_ + allocate(all_nstruct(0:this%amr%nproc-1)); call MPI_ALLREDUCE(my_nstruct,all_nstruct,this%amr%nproc,MPI_INTEGER,MPI_SUM,this%amr%comm,ierr) + stmin=1 + if (this%amr%rank.gt.0) stmin=stmin+sum(all_nstruct(0:this%amr%rank-1)) + this%nstruct=sum(all_nstruct) + deallocate(my_nstruct,all_nstruct) + stmax=stmin+nstruct_-1 + ! Generate an index map + allocate(idmap(1:size(this%struct,dim=1))); idmap=0 + nstruct_=0 + do n=1,size(this%struct,dim=1) + if (this%struct(n)%n_.gt.0) then + nstruct_=nstruct_+1 + idmap(n)=stmin+nstruct_-1 + end if + end do + ! Update id array to new index + update_id: block + use amrex_amr_module, only: amrex_mfiter,amrex_box + type(amrex_mfiter) :: mfi + type(amrex_box) :: bx ! Loop over tiles call this%amr%mfiter_build(lvl,mfi) do while (mfi%next()) ! Get pointers to data pid=>this%id%mf(lvl)%dataptr(mfi) - ! Only work on finest level for now - if (lvl.ne.data%amr%maxlvl) cycle ! Perform local loop 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 (pid(i,j,k,1).gt.0.5_WP) then - pid(i,j,k,1)=idmap(int(pid(i,j,k,1))) + pid(i,j,k,1)=idmap(nint(pid(i,j,k,1))) end if end do; end do; end do end do + end block update_id + deallocate(idmap) + ! Finish compacting and renumbering + allocate(tmp(stmin:stmax)) + nstruct_=0 + do n=1,size(this%struct,dim=1) + if (this%struct(n)%n_.gt.0) then + nstruct_=nstruct_+1 + tmp(stmin+nstruct_-1)=this%struct(n) + end if end do - end block update_id - deallocate(idmap) - ! Finish compacting and renumbering - allocate(tmp(stmin:stmax)) - nstruct_=0 - do n=1,size(this%struct,dim=1) - if (this%struct(n)%n_.gt.0) then - nstruct_=nstruct_+1 - tmp(stmin+nstruct_-1)=this%struct(n) - allocate(tmp(stmin+nstruct_-1)%map(tmp(stmin+nstruct_-1)%n_)) - end if - end do - call move_alloc(tmp,this%struct) - end block compact_tree - - ! ! Fill out the node map - ! node_map: block - ! use amrex_amr_module, only: amrex_mfiter,amrex_box - ! integer :: i,j,k - ! integer, dimension(:), allocatable :: counter - ! integer :: lvl - ! type(amrex_mfiter) :: mfi - ! type(amrex_box) :: bx - ! allocate(counter(stmin:stmax)); counter=0 - ! ! Traverse levels ! Only work on finest level for now - ! do lvl=this%amr%finest_level() - ! ! Loop over tiles - ! call this%amr%mfiter_build(lvl,mfi) - ! do while (mfi%next()) - ! ! Get pointers to data - ! pid=>this%id%mf(lvl)%dataptr(mfi) - ! ! Perform local loop - ! 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 (pid(i,j,k,.gt.0.5_WP then - ! counter(pid(i,j,k,1))=counter(pid(i,j,k,1))+1 - ! this%struct(pid(i,j,k,1))%map(:,counter(pid(i,j,k,1))))=[i,j,k] - ! end if - ! end do; end do; end do - ! deallocate(counter) - ! end block node_map - - ! Interprocessor treatment of our structures - interproc_handling: block - use mpi_f08, only: MPI_ALLREDUCE,MPI_MIN,MPI_MAX,MPI_INTEGER - use amrex_amr_module, only: amrex_mfiter,amrex_box - integer :: lvl,i,j,k - integer :: ii,jj,kk,dim - integer, dimension(3) :: pos - integer ::stop_global,stop_,counter,n,m,ierr,find_parent,find_parent_own - type(amrex_mfiter) :: mfi - type(amrex_box) :: bx - real(WP), dimension(:,:,:,:), contiguous, pointer :: pid,pidp,pdata - ! Allocate to total number of structures - allocate(parent (this%nstruct)); parent =0 - allocate(parent_all(this%nstruct)); parent_all=0 - allocate(parent_own(this%nstruct)); parent_own=0 - ! Fill global lineage with selves - do n=1,this%nstruct - parent(n)=n - end do - ! Synchronize id array - call this%id%sync() - ! Loop over cells and check for connections across periodic boundaries, storing parent connections in parent array - ! Traverse levels ! Only work on finest level for now - do lvl=0,data%amr%clvl() - ! Loop over tiles - call this%amr%mfiter_build(lvl,mfi) - do while (mfi%next()) + call move_alloc(tmp,this%struct) + end block compact_tree + + ! Interprocessor treatment of our structures + interproc_handling: block + use mpi_f08, only: MPI_ALLREDUCE,MPI_MIN,MPI_MAX,MPI_INTEGER + use amrex_amr_module, only: amrex_mfiter,amrex_box + integer :: i,j,k + integer :: ii,jj,kk,dim + integer, dimension(3) :: pos + integer ::stop_global,stop_,counter,n,m,ierr,find_parent,find_parent_own + type(amrex_mfiter) :: mfi + type(amrex_box) :: bx + real(WP), dimension(:,:,:,:), contiguous, pointer :: pid,pidp,pdata + ! Allocate to total number of structures + allocate(parent (this%nstruct)); parent =0 + allocate(parent_all(this%nstruct)); parent_all=0 + allocate(parent_own(this%nstruct)); parent_own=0 + ! Fill global lineage with selves + do n=1,this%nstruct + parent(n)=n + end do + ! Synchronize id array + call this%id%sync() + ! Loop over cells and check for connections across periodic boundaries, storing parent connections in parent array + ! Loop over tiles + call this%amr%mfiter_build(lvl,mfi) + do while (mfi%next()) ! Get pointers to data pid=>this%id%mf(lvl)%dataptr(mfi) pdata=>data%mf(lvl)%dataptr(mfi) - ! Only work on finest level for now - if (lvl.ne.data%amr%maxlvl) cycle ! Perform local loop 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) @@ -371,290 +399,132 @@ subroutine build(this,make_label,same_label,data) ! Check if we should connect these two cells if (same_label(pdata,lbound(pdata),i,j,k,ii,jj,kk)) then ! Update parent array to reflect connection - call union_parent(int(pid(i,j,k,1)),int(pid(ii,jj,kk,1))) + call union_parent(nint(pid(i,j,k,1)),nint(pid(ii,jj,kk,1))) end if end do end do; end do; end do end do - end do - - ! Initialize global stop criterion and counter - stop_global=1 - counter=0 - ! Resolve lineage - do while (stop_global.ne.0) - ! Initialize local stop flag - stop_=0 - ! Remember own parents - parent_own=parent - ! Set self-parents to huge(1) - do n=1,this%nstruct - if (parent(n).eq.n) parent(n)=huge(1) - end do - ! Take global min - call MPI_ALLREDUCE(parent,parent_all,this%nstruct,MPI_INTEGER,MPI_MIN,this%amr%comm,ierr) - ! Set self-parents back to selves - do n=1,this%nstruct - if (parent_all(n).eq.huge(1)) parent_all(n)=n - end do - ! Flatten trees - do n=1,this%nstruct - parent_all(n)=find_all(n) - parent_own(n)=find_own(n) - end do - ! Start with final parent array being equal to parent_all - parent=parent_all - ! Increment counter - counter=counter+1 - ! Reconcile conflicts between parent_all and parent_own - do n=1,this%nstruct - if (parent_own(n).ne.n) then - find_parent_own=rootify_parent(parent_own(n)) - find_parent =rootify_parent(parent(n)) - if (find_parent_own.ne.find_parent) then - call union_parent(find_parent,find_parent_own) - stop_=1 + + ! Initialize global stop criterion and counter + stop_global=1 + counter=0 + ! Resolve lineage + do while (stop_global.ne.0) + ! Initialize local stop flag + stop_=0 + ! Remember own parents + parent_own=parent + ! Set self-parents to huge(1) + do n=1,this%nstruct + if (parent(n).eq.n) parent(n)=huge(1) + end do + ! Take global min + call MPI_ALLREDUCE(parent,parent_all,this%nstruct,MPI_INTEGER,MPI_MIN,this%amr%comm,ierr) + ! Set self-parents back to selves + do n=1,this%nstruct + if (parent_all(n).eq.huge(1)) parent_all(n)=n + end do + ! Flatten trees + do n=1,this%nstruct + parent_all(n)=find_all(n) + parent_own(n)=find_own(n) + end do + ! Start with final parent array being equal to parent_all + parent=parent_all + ! Increment counter + counter=counter+1 + ! Reconcile conflicts between parent_all and parent_own + do n=1,this%nstruct + if (parent_own(n).ne.n) then + find_parent_own=rootify_parent(parent_own(n)) + find_parent =rootify_parent(parent(n)) + if (find_parent_own.ne.find_parent) then + call union_parent(find_parent,find_parent_own) + stop_=1 + end if end if - end if + end do + ! Check if we did some changes + call MPI_ALLREDUCE(stop_,stop_global,1,MPI_INTEGER,MPI_MAX,this%amr%comm,ierr) end do - ! Check if we did some changes - call MPI_ALLREDUCE(stop_,stop_global,1,MPI_INTEGER,MPI_MAX,this%amr%comm,ierr) - end do - ! Update this%struct%parent by pointing all parents to root and update id - ! do n=stmin,stmax - ! this%struct(n)%parent=rootify_parent(parent(n)) - ! do m=1,this%struct(n)%n_ - ! this%id(this%struct(n)%map(m)%i,this%struct(n)%map(m)%j,this%struct(n)%map(m)%k)=this%struct(n)%parent - ! end do - ! end do - ! Traverse levels - do lvl=0,data%amr%clvl() + ! Update this%struct%parent by pointing all parents to root and update id + ! do n=stmin,stmax + ! this%struct(n)%parent=rootify_parent(parent(n)) + ! do m=1,this%struct(n)%n_ + ! this%id(this%struct(n)%map(m)%i,this%struct(n)%map(m)%j,this%struct(n)%map(m)%k)=this%struct(n)%parent + ! end do + ! end do ! Loop over tiles call data%amr%mfiter_build(lvl,mfi) do while (mfi%next()) ! Get pointers to data arrays pid=>this%id%mf(lvl)%dataptr(mfi) - ! Only work on finest level for now - if (lvl.ne.data%amr%maxlvl) cycle ! Perform local loop 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 (pid(i,j,k,1).gt.0.5_WP) then - pid(i,j,k,1)=rootify_parent(parent(int(pid(i,j,k,1)))) + pid(i,j,k,1)=rootify_parent(parent(nint(pid(i,j,k,1)))) end if end do; end do; end do end do - end do - end block interproc_handling - - ! ! Update periodicity array across processors - ! periodicity_update: block - ! use mpi_f08, only: MPI_ALLGATHER,MPI_MAX,MPI_INTEGER - ! integer, dimension(:,:), allocatable :: ownper,allper - ! integer :: n,m,ierr - ! ! Allocate local and global perodicity arrays - ! allocate(ownper(1:3,this%nstruct)); ownper=0 - ! allocate(allper(1:3,this%nstruct)); allper=0 - ! ! Fill ownper array - ! do n=stmin,stmax - ! ownper(:,n)=this%struct(n)%per - ! end do - ! ! Communicate per - ! call MPI_ALLREDUCE(ownper,allper,3*this%nstruct,MPI_INTEGER,MPI_MAX,this%amr%comm,ierr) - ! ! Update parent per - ! do n=1,this%nstruct - ! allper(:,parent(n))=max(allper(:,parent(n)),allper(:,n)) - ! end do - ! ! Update idp array - ! do n=stmin,stmax - ! do m=1,this%struct(n)%n_ - ! idp(:,this%struct(n)%map(m))=allper(:,this%id(this%struct(n)%map(m))) - ! end do - ! end do - ! ! Clean up - ! deallocate(ownper,allper) - ! end block periodicity_update - - ! ! One more pass for domain boundaries - ! boundary_handling: block - ! use mpi_f08, only: MPI_ALLREDUCE,MPI_MIN,MPI_MAX,MPI_INTEGER - ! integer :: i,j,k,stop_global,stop_,counter,n,m,ierr,find_parent,find_parent_own - ! ! Handle imin border - ! if (this%pg%imin_.eq.this%pg%imin) then - ! do k=this%pg%kmin_,this%pg%kmax_; do j=this%pg%jmin_,this%pg%jmax_ - ! if (this%id(this%pg%imin_,j,k).gt.0.and.this%id(this%pg%imin_-1,j,k).gt.0) then - ! if (same_label(this%pg%imin_,j,k,this%pg%imin_-1,j,k)) call union_parent(this%id(this%pg%imin_,j,k),this%id(this%pg%imin_-1,j,k)) - ! end if - ! end do; end do - ! end if - ! ! Handle jmin border - ! if (this%pg%jmin_.eq.this%pg%jmin) then - ! do k=this%pg%kmin_,this%pg%kmax_; do i=this%pg%imin_,this%pg%imax_ - ! if (this%id(i,this%pg%jmin_,k).gt.0.and.this%id(i,this%pg%jmin_-1,k).gt.0) then - ! if (same_label(i,this%pg%jmin_,k,i,this%pg%jmin_-1,k)) call union_parent(this%id(i,this%pg%jmin_,k),this%id(i,this%pg%jmin_-1,k)) - ! end if - ! end do; end do - ! end if - ! ! Handle kmin border - ! if (this%pg%kmin_.eq.this%pg%kmin) then - ! do j=this%pg%jmin_,this%pg%jmax_; do i=this%pg%imin_,this%pg%imax_ - ! if (this%id(i,j,this%pg%kmin_).gt.0.and.this%id(i,j,this%pg%kmin_-1).gt.0) then - ! if (same_label(i,j,this%pg%kmin_,i,j,this%pg%kmin_-1)) call union_parent(this%id(i,j,this%pg%kmin_),this%id(i,j,this%pg%kmin_-1)) - ! end if - ! end do; end do - ! end if - ! ! Initialize global stop criterion and counter - ! stop_global=1 - ! counter=0 - ! ! Resolve lineage - ! do while (stop_global.ne.0) - ! ! Initialize local stop flag - ! stop_=0 - ! ! Remember own parents - ! parent_own=parent - ! ! Set self-parents to huge(1) - ! do n=1,this%nstruct - ! if (parent(n).eq.n) parent(n)=huge(1) - ! end do - ! ! Take global min - ! call MPI_ALLREDUCE(parent,parent_all,this%nstruct,MPI_INTEGER,MPI_MIN,this%amr%comm,ierr) - ! ! Set self-parents back to selves - ! do n=1,this%nstruct - ! if (parent_all(n).eq.huge(1)) parent_all(n)=n - ! end do - ! ! Flatten trees - ! do n=1,this%nstruct - ! parent_all(n)=find_all_2(n,n) - ! parent_own(n)=find_own(n) - ! end do - ! ! Start with final parent array being equal to parent_all - ! parent=parent_all - ! ! Increment counter - ! counter=counter+1 - ! ! Reconcile conflicts between parent_all and parent_own - ! do n=1,this%nstruct - ! if (parent_own(n).ne.n) then - ! find_parent_own=rootify_parent(parent_own(n)) - ! find_parent =rootify_parent(parent(n)) - ! if (find_parent_own.ne.find_parent) then - ! call union_parent(find_parent,find_parent_own) - ! stop_=1 - ! end if - ! end if - ! end do - ! ! Check if we did some changes - ! call MPI_ALLREDUCE(stop_,stop_global,1,MPI_INTEGER,MPI_MAX,this%amr%comm,ierr) - ! end do - ! ! Update this%struct%parent and point all parents to root and update id - ! do n=stmin,stmax - ! this%struct(n)%parent=rootify_parent(parent(n)) - ! do m=1,this%struct(n)%n_ - ! this%id(this%struct(n)%map(1,m),this%struct(n)%map(2,m),this%struct(n)%map(3,m))=this%struct(n)%parent - ! end do - ! end do - ! ! Update ghost cells - ! call this%pg%sync(this%id) - ! ! Clean up parent info - ! deallocate(parent,parent_all,parent_own) - ! end block boundary_handling - - ! ! Now we need to compact the data based on id only - ! compact_struct: block - ! use mpi_f08, only: MPI_ALLREDUCE,MPI_MAX,MPI_INTEGER - ! integer :: i,j,k,n,nn,ierr,count - ! integer, dimension(:), allocatable :: my_idmap,idmap,counter - ! type(struct_type), dimension(:), allocatable :: tmp - ! ! Prepare global id map - ! allocate(my_idmap(1:this%nstruct)); my_idmap=0 - ! allocate( idmap(1:this%nstruct)); idmap=0 - ! ! Traverse id array and tag used id values - ! do k=this%pg%kmin_,this%pg%kmax_; do j=this%pg%jmin_,this%pg%jmax_; do i=this%pg%imin_,this%pg%imax_ - ! if (this%id(i,j,k).gt.0) my_idmap(this%id(i,j,k))=1 - ! end do; end do; end do - ! call MPI_ALLREDUCE(my_idmap,idmap,this%nstruct,MPI_INTEGER,MPI_MAX,this%pg%comm,ierr) - ! deallocate(my_idmap) - ! ! Count number of used structures and create the map - ! this%nstruct=sum(idmap) - ! count=0 - ! do n=1,size(idmap,dim=1) - ! if (idmap(n).gt.0) then - ! count=count+1 - ! idmap(n)=count - ! end if - ! end do - ! ! Rename all structures - ! do k=this%pg%kmin_,this%pg%kmax_; do j=this%pg%jmin_,this%pg%jmax_; do i=this%pg%imin_,this%pg%imax_ - ! if (this%id(i,j,k).gt.0) this%id(i,j,k)=idmap(this%id(i,j,k)) - ! end do; end do; end do - ! call this%pg%sync(this%id) - ! ! Allocate temporary storage for structure - ! allocate(tmp(this%nstruct)) - ! allocate(counter(this%nstruct)); counter=0 - ! do k=this%pg%kmin_,this%pg%kmax_; do j=this%pg%jmin_,this%pg%jmax_; do i=this%pg%imin_,this%pg%imax_ - ! if (this%id(i,j,k).gt.0) counter(this%id(i,j,k))=counter(this%id(i,j,k))+1 - ! end do; end do; end do - ! do n=1,this%nstruct - ! tmp(n)%parent=n - ! tmp(n)%per=0 - ! tmp(n)%n_=counter(n) - ! allocate(tmp(n)%map(1:3,1:tmp(n)%n_)) - ! end do - ! ! Transfer periodicity info - ! do n=stmin,stmax - ! if (idmap(n).gt.0) then - ! tmp(idmap(n))%per=this%struct(n)%per - ! end if - ! end do - ! deallocate(idmap) - ! ! Store the map - ! counter=0 - ! do k=this%pg%kmin_,this%pg%kmax_; do j=this%pg%jmin_,this%pg%jmax_; do i=this%pg%imin_,this%pg%imax_ - ! if (this%id(i,j,k).gt.0) then - ! counter(this%id(i,j,k))=counter(this%id(i,j,k))+1 - ! tmp(this%id(i,j,k))%map(:,counter(this%id(i,j,k)))=[i,j,k] - ! end if - ! end do; end do; end do - ! deallocate(counter) - ! ! Transfer allocation - ! call move_alloc(tmp,this%struct) - ! ! Final pass to fix periodicity info - ! do n=1,this%nstruct - ! do nn=1,this%struct(n)%n_ - ! i=this%struct(n)%map(1,nn) - ! j=this%struct(n)%map(2,nn) - ! k=this%struct(n)%map(3,nn) - ! this%struct(n)%per(1)=max(this%struct(n)%per(1),idp(1,i,j,k)) - ! this%struct(n)%per(2)=max(this%struct(n)%per(2),idp(2,i,j,k)) - ! this%struct(n)%per(3)=max(this%struct(n)%per(3),idp(3,i,j,k)) - ! end do - ! end do - ! deallocate(idp) - ! end block compact_struct - - ! ! Extra QOL step to ensure that id=1 is always the largest structure in terms of number of cells - ! rename_largest_structure: block - ! use mpi_f08, only: MPI_ALLREDUCE,MPI_SUM,MPI_INTEGER,MPI_IN_PLACE - ! integer :: ierr,bigid,i,j,k - ! integer, dimension(:), allocatable :: ncells - ! type(struct_type) :: tmp - ! ! Skip if no structure was found - ! if (this%nstruct.eq.0) exit rename_largest_structure - ! ! Loop over all structures and count total number of cells to find ID of largest structure - ! allocate(ncells(1:this%nstruct)); ncells=this%struct(:)%n_ - ! call MPI_ALLREDUCE(MPI_IN_PLACE,ncells,this%nstruct,MPI_INTEGER,MPI_SUM,this%pg%comm,ierr) - ! bigid=maxloc(ncells,1) - ! deallocate(ncells) - ! ! Swap structures - ! tmp=this%struct(1); this%struct(1)=this%struct(bigid); this%struct(bigid)=tmp - ! do k=this%pg%kmino_,this%pg%kmaxo_; do j=this%pg%jmino_,this%pg%jmaxo_; do i=this%pg%imino_,this%pg%imaxo_ - ! if (this%id(i,j,k).eq.1) then; this%id(i,j,k)=bigid; else if (this%id(i,j,k).eq.bigid) then; this%id(i,j,k)=1; end if - ! end do; end do; end do - ! end block rename_largest_structure + ! Update ghost cells with new ids + call this%id%sync() + end block interproc_handling - ! Release scratch - call idp%finalize() - - contains + ! Release scratch + call idp%finalize() + + ! Deallocate arrays + deallocate(parent,parent_all,parent_own) + + end subroutine build_lvl + + !> Debug function to print id's that exist on a level + subroutine print_ids(lvl,msg) + use amrex_amr_module, only: amrex_mfiter,amrex_box + implicit none + integer, intent(in) :: lvl + character(len=*), intent(in) :: msg + real(WP), dimension(:,:,:,:), contiguous, pointer :: pid + type(amrex_mfiter) :: mfi + type(amrex_box) :: bx + integer, parameter :: max_id = 100000 ! adjust as needed + logical :: seen(0:max_id) + integer :: count(0:max_id) + integer :: id,i,j,k + + seen = .false. + count = 0 + ! Loop over tiles + call data%amr%mfiter_build(lvl,mfi) + do while (mfi%next()) + pid => this%id%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) + id = nint(pid(i,j,k,1)) + if (id <= max_id) then + seen(id) = .true. + count(id) = count(id) + 1 + else + print *, "Warning: ID ", id, " exceeds max_id ", max_id + end if + end do; end do; end do + end do + ! Collect and print unique IDs + communicate: block + use mpi_f08, only: MPI_ALLREDUCE,MPI_IN_PLACE,MPI_Logical,MPI_LOR, MPI_INTEGER, MPI_SUM + integer :: ierr + call MPI_AllREDUCE(MPI_IN_PLACE, seen, max_id+1, MPI_LOGICAL, MPI_LOR, this%amr%comm, ierr) + call MPI_ALLREDUCE(MPI_IN_PLACE, count, max_id+1, MPI_INTEGER, MPI_SUM, this%amr%comm, ierr) + end block communicate + if (this%amr%amRoot) then + print *, "Unique IDs on level ", lvl,' ',msg + do id=0,max_id + if (seen(id)) print *, 'id = ',id,' count = ',count(id) + end do + end if + end subroutine print_ids + !> This recursive function that points the lineage of a structure to its root and returns that root recursive function rootify_struct(x) result(y) @@ -687,7 +557,7 @@ function add() result(x) ! Check if there is enough room for storing a new structure size_now=size(this%struct,dim=1) if (nstruct_.eq.size_now) then - size_new=int(real(size_now,WP)*coeff_up) + size_new=nint(real(size_now,WP)*coeff_up) allocate(tmp(size_new)) tmp(1:nstruct_)=this%struct tmp(nstruct_+1:)%parent=0 @@ -704,6 +574,33 @@ function add() result(x) this%struct(nstruct_)%n_=0 x=nstruct_ end function add + + !> This subroutine adds an existing root while dynamically handling storage space + subroutine add_existing(id) + implicit none + integer, intent(in) :: id + integer :: x + integer :: size_now,size_new + type(struct_type), dimension(:), allocatable :: tmp + ! Check if there is enough room for storing a new structure + size_now=size(this%struct,dim=1) + if (id.gt.size_now) then + size_new=id + allocate(tmp(size_new)) + tmp(1:nstruct_)=this%struct + tmp(nstruct_+1:)%parent=0 + tmp(nstruct_+1:)%per(1)=0 + tmp(nstruct_+1:)%per(2)=0 + tmp(nstruct_+1:)%per(3)=0 + tmp(nstruct_+1:)%n_=0 + call move_alloc(tmp,this%struct) + end if + ! Add new root + nstruct_=nstruct_+1 + this%struct(id)%parent=id + this%struct(id)%per=0 + this%struct(id)%n_=0 + end subroutine add_existing !> This recursive function points global parent to root and returns that root recursive function rootify_parent(x) result(y) @@ -775,18 +672,10 @@ subroutine empty(this) implicit none class(amrcclabel), intent(inout) :: this integer :: n - ! Loop over all structures and deallocate maps - if (allocated(this%struct)) then - do n=1,size(this%struct,dim=1) - if (allocated(this%struct(n)%map)) deallocate(this%struct(n)%map) - end do - ! Deallocate structure array - deallocate(this%struct) - end if + ! Deallocate structure array + if (allocated(this%struct)) deallocate(this%struct) ! Zero structures this%nstruct=0 - ! Reset id to zero - call this%id%setVal(0.0_WP) end subroutine empty diff --git a/src/amrbase/amrex_interface.f90 b/src/amrbase/amrex_interface.f90 index f57f8d2eb..4dbed1166 100644 --- a/src/amrbase/amrex_interface.f90 +++ b/src/amrbase/amrex_interface.f90 @@ -93,6 +93,7 @@ module amrex_interface public :: amrmfab_compute_divergence ! Compute div(u) from face velocities public :: amrmfab_sum_unique ! Sum for face/nodal data (no double-counting) public :: amrmask_make_fine ! Create mask for cells covered by finer level + public :: amrmfab_restrict_unique_id ! Restrict unique ID from fine to coarse (for tracking structures) !===================================================================== ! Per-direction wrappers (bypass AMReX scalar-only Fortran interfaces) @@ -627,6 +628,13 @@ subroutine amrmask_make_fine_c(mask, ba_fine, ref_ratio, covered_val, notcovered integer(c_int), intent(in) :: ref_ratio(3) integer(c_int), value :: covered_val, notcovered_val end subroutine amrmask_make_fine_c + subroutine amrmfab_restrict_unique_id_c(crse,fine,ref_ratio) & + bind(c, name='amrmfab_restrict_unique_id') + import :: c_ptr, c_int + type(c_ptr), value :: crse + type(c_ptr), value :: fine + integer(c_int) :: ref_ratio(3) + end subroutine amrmfab_restrict_unique_id_c end interface @@ -782,6 +790,15 @@ subroutine amrmask_make_fine(mask, ba_fine, ref_ratio, covered_val, notcovered_v call amrmask_make_fine_c(mask%p, ba_fine%p, ref_ratio, covered_val, notcovered_val) end subroutine amrmask_make_fine + !> Restrict unique ID from fine to coarse (for tracking structures) + subroutine amrmfab_restrict_unique_id(crse,fine,ref_ratio) + use amrex_amr_module, only: amrex_multifab + type(amrex_multifab), intent(inout) :: crse + type(amrex_multifab), intent(in) :: fine + integer, intent(in) :: ref_ratio(3) + call amrmfab_restrict_unique_id_c(crse%p, fine%p, ref_ratio) + end subroutine amrmfab_restrict_unique_id + !> Fill coarse patch for 3-component face-centered velocity subroutine amrmfab_fillcoarsepatch_faces(mf_u, mf_v, mf_w, time, & & cmf_u, cmf_v, cmf_w, geom_c, geom_f, & diff --git a/src/amrbase/amrex_wrapper.cpp b/src/amrbase/amrex_wrapper.cpp index af5846e03..eaaf2f5f9 100644 --- a/src/amrbase/amrex_wrapper.cpp +++ b/src/amrbase/amrex_wrapper.cpp @@ -1313,3 +1313,108 @@ void amrmfab_parallel_add(void *dst_ptr, void *src_ptr, } } // extern "C" + + +//----------------------------------------------------------------------------- +// Restriction operator to determine unique id's on coarser levels +//----------------------------------------------------------------------------- + +extern "C" void amrmfab_restrict_unique_id(void *crse_mf_ptr, + void *fine_mf_ptr, + int *ref_ratio) +{ + auto *cmf = static_cast(crse_mf_ptr); + auto *fmf = static_cast(fine_mf_ptr); + + amrex::IntVect ratio(AMREX_D_DECL(ref_ratio[0], + ref_ratio[1], + ref_ratio[2])); + + // -------------------------------------------- + // Gather all local fine FABs (no nested MFIter) + // -------------------------------------------- + std::vector fine_boxes; + std::vector> fine_arrays; + + for (amrex::MFIter mfi_f(*fmf, amrex::TilingIfNotGPU()); mfi_f.isValid(); ++mfi_f) + { + const auto& fab = (*fmf)[mfi_f]; + fine_boxes.push_back(fab.box()); + fine_arrays.push_back(fab.const_array()); + } + + // -------------------------------------------- + // Coarse loop + // -------------------------------------------- + for (amrex::MFIter mfi(*cmf, amrex::TilingIfNotGPU()); mfi.isValid(); ++mfi) + { + const amrex::Box& cbox = mfi.tilebox(); + auto const& carr = cmf->array(mfi); + + // ✅ define fbox (this was missing) + amrex::Box fbox = amrex::refine(cbox, ratio); + + amrex::LoopOnCpu(cbox, + [=, &fine_boxes, &fine_arrays] (int i, int j, int k) noexcept + { + bool found = false; + bool conflict = false; + int id_store = 0; + + const auto& clo = cbox.smallEnd(); + const auto& flo = fbox.smallEnd(); + + // ✅ correct mapping (this fixes your wrong IDs problem) + int fi0 = (i - clo[0]) * ratio[0] + flo[0]; + int fj0 = (j - clo[1]) * ratio[1] + flo[1]; + int fk0 = (k - clo[2]) * ratio[2] + flo[2]; + + for (int n = 0; n < fine_boxes.size(); ++n) + { + const auto& fbx = fine_boxes[n]; + const auto& farr = fine_arrays[n]; + + // Only consider overlapping region + amrex::Box overlap = fbox & fbx; + if (!overlap.ok()) continue; + + for (int kk = 0; kk < ratio[2]; ++kk) + for (int jj = 0; jj < ratio[1]; ++jj) + for (int ii = 0; ii < ratio[0]; ++ii) + { + int fi = fi0 + ii; + int fj = fj0 + jj; + int fk = fk0 + kk; + + // Check if inside this FAB + if (fi >= overlap.smallEnd(0) && fi <= overlap.bigEnd(0) && + fj >= overlap.smallEnd(1) && fj <= overlap.bigEnd(1) && + fk >= overlap.smallEnd(2) && fk <= overlap.bigEnd(2)) + { + amrex::Real val = farr(fi,fj,fk,0); + + if (val > 0.5) + { + int id_val = static_cast(amrex::Math::round(val)); + + if (!found) + { + id_store = id_val; + found = true; + } + else if (id_val != id_store) + { + conflict = true; + } + } + } + } + } + + if (!found || conflict) + carr(i,j,k,0) = 0.0; + else + carr(i,j,k,0) = static_cast(id_store); + }); + } +} \ No newline at end of file From 2bc4239dc807d3b3e642e59b78ef463191930fd9 Mon Sep 17 00:00:00 2001 From: Mark Owkes Date: Wed, 17 Jun 2026 08:09:07 -0600 Subject: [PATCH 49/70] Getting closer --- src/amrbase/amrcclabel_class.f90 | 12 +++++++----- 1 file changed, 7 insertions(+), 5 deletions(-) diff --git a/src/amrbase/amrcclabel_class.f90 b/src/amrbase/amrcclabel_class.f90 index f0cd69920..873eb36e8 100644 --- a/src/amrbase/amrcclabel_class.f90 +++ b/src/amrbase/amrcclabel_class.f90 @@ -595,11 +595,13 @@ subroutine add_existing(id) tmp(nstruct_+1:)%n_=0 call move_alloc(tmp,this%struct) end if - ! Add new root - nstruct_=nstruct_+1 - this%struct(id)%parent=id - this%struct(id)%per=0 - this%struct(id)%n_=0 + ! Add new root if doesn't already exist + if (this%struct(id)%parent.ne.id) then + nstruct_=nstruct_+1 + this%struct(id)%parent=id + this%struct(id)%per=0 + this%struct(id)%n_=0 + end if end subroutine add_existing !> This recursive function points global parent to root and returns that root From 7eba8ff4a1b32d40b412e0b1de63f69e80b9a00c Mon Sep 17 00:00:00 2001 From: Mark Owkes Date: Wed, 17 Jun 2026 09:00:30 -0600 Subject: [PATCH 50/70] Added final renumbering code. --- src/amrbase/amrcclabel_class.f90 | 102 +++++++++++++++++++++++-------- 1 file changed, 78 insertions(+), 24 deletions(-) diff --git a/src/amrbase/amrcclabel_class.f90 b/src/amrbase/amrcclabel_class.f90 index 873eb36e8..4dc5d08a1 100644 --- a/src/amrbase/amrcclabel_class.f90 +++ b/src/amrbase/amrcclabel_class.f90 @@ -121,12 +121,12 @@ subroutine build(this,make_label,same_label,coarse_make_label,coarse_same_label, ! Build CCL on finest level call build_lvl(data%amr%maxlvl,make_label,same_label) - testing_finest: block - integer :: lvl - do lvl = 0,data%amr%maxlvl - call print_ids(lvl,"after build_lvl(finest)") - end do - end block testing_finest + ! testing_finest: block + ! integer :: lvl + ! do lvl = 0,data%amr%maxlvl + ! call print_ids(lvl,"after build_lvl(finest)") + ! end do + ! end block testing_finest ! Create unique IDs for each structure on coarser levels restrict_unique_id: block @@ -146,12 +146,12 @@ subroutine build(this,make_label,same_label,coarse_make_label,coarse_same_label, this%id%mf(lvl+1), & ! fine ref_ratio ) - testing_after_restrict: block - integer :: lvl - do lvl = 0,data%amr%maxlvl - call print_ids(lvl,"after restrict") - end do - end block testing_after_restrict + ! testing_after_restrict: block + ! integer :: lvl + ! do lvl = 0,data%amr%maxlvl + ! call print_ids(lvl,"after restrict") + ! end do + ! end block testing_after_restrict ! Build CCL on coarse level call build_lvl(lvl,coarse_make_label,coarse_same_label) @@ -159,12 +159,12 @@ subroutine build(this,make_label,same_label,coarse_make_label,coarse_same_label, end do end block restrict_unique_id - testing_end_build: block - integer :: lvl - do lvl = 0,data%amr%maxlvl - call print_ids(lvl,"after build") - end do - end block testing_end_build + ! testing_end_build: block + ! integer :: lvl + ! do lvl = 0,data%amr%maxlvl + ! call print_ids(lvl,"after build") + ! end do + ! end block testing_end_build contains @@ -245,7 +245,6 @@ subroutine build_lvl(lvl,make_label,same_label) else ! We don't have a label, check if we take the neighbor's label if (same_label(pdata,lbound(pdata),i,j,k,ii,jj,kk)) then - ! print *,'Using neighbor''s label' pid(i,j,k,1)=pid(ii,jj,kk,1) else pid(i,j,k,1)=add() @@ -380,9 +379,9 @@ subroutine build_lvl(lvl,make_label,same_label) ! Synchronize id array call this%id%sync() ! Loop over cells and check for connections across periodic boundaries, storing parent connections in parent array - ! Loop over tiles - call this%amr%mfiter_build(lvl,mfi) - do while (mfi%next()) + ! Loop over tiles + call this%amr%mfiter_build(lvl,mfi) + do while (mfi%next()) ! Get pointers to data pid=>this%id%mf(lvl)%dataptr(mfi) pdata=>data%mf(lvl)%dataptr(mfi) @@ -471,6 +470,55 @@ subroutine build_lvl(lvl,make_label,same_label) call this%id%sync() end block interproc_handling + ! Now we need to compact the data based on id only + compact_struct: block + use mpi_f08, only: MPI_ALLREDUCE,MPI_MAX,MPI_INTEGER,MPI_IN_PLACE + use amrex_amr_module, only: amrex_mfiter,amrex_box + integer :: i,j,k,n,nn,ierr,count + integer, dimension(:), allocatable :: idmap,counter + type(struct_type), dimension(:), allocatable :: tmp + type(amrex_mfiter) :: mfi + type(amrex_box) :: bx + real(WP), dimension(:,:,:,:), contiguous, pointer :: pid + ! Prepare global id map + allocate( idmap(1:this%nstruct)); idmap=0 + ! Traverse id array and tag used id values + ! Loop over tiles + call this%amr%mfiter_build(lvl,mfi) + do while (mfi%next()) + ! Get pointers to data + pid=>this%id%mf(lvl)%dataptr(mfi) + ! Perform local loop + 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 (pid(i,j,k,1).gt.0) idmap(pid(i,j,k,1))=1 + end do; end do; end do + end do + call MPI_ALLREDUCE(MPI_IN_PLACE,idmap,this%nstruct,MPI_INTEGER,MPI_MAX,this%amr%comm,ierr) + ! Count number of used structures and create the map + this%nstruct=sum(idmap) + count=0 + do n=1,size(idmap,dim=1) + if (idmap(n).gt.0) then + count=count+1 + idmap(n)=count + end if + end do + ! Rename all structures + ! Loop over tiles + call this%amr%mfiter_build(lvl,mfi) + do while (mfi%next()) + ! Get pointers to data + pid=>this%id%mf(lvl)%dataptr(mfi) + ! Perform local loop + 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 (pid(i,j,k,1).gt.0) pid(i,j,k,1)=idmap(pid(i,j,k,1)) + end do; end do; end do + end do + call this%id%sync() + end block compact_struct + ! Release scratch call idp%finalize() @@ -491,7 +539,7 @@ subroutine print_ids(lvl,msg) integer, parameter :: max_id = 100000 ! adjust as needed logical :: seen(0:max_id) integer :: count(0:max_id) - integer :: id,i,j,k + integer :: id,i,j,k,root seen = .false. count = 0 @@ -520,7 +568,13 @@ subroutine print_ids(lvl,msg) if (this%amr%amRoot) then print *, "Unique IDs on level ", lvl,' ',msg do id=0,max_id - if (seen(id)) print *, 'id = ',id,' count = ',count(id) + ! if (seen(id).and.id.gt.0) then + ! print *,'rootifying on ',id + ! root = rootify_struct(id) + ! else + ! root = 0 + ! end if + if (seen(id)) print *, 'id = ',id,' count = ',count(id)!, ' root =',root end do end if end subroutine print_ids From f96dbf6e681ba2056e0be7bb2ea9aa2b4f7079b8 Mon Sep 17 00:00:00 2001 From: Mark Owkes Date: Wed, 17 Jun 2026 19:18:25 -0600 Subject: [PATCH 51/70] Moved restrict to fortran code. CCLabel seems to be working. Still need to compute statistics. --- src/amrbase/amrcclabel_class.f90 | 295 ++++++++++++++++++++++--------- src/amrbase/amrex_interface.f90 | 17 -- src/amrbase/amrex_wrapper.cpp | 107 +---------- 3 files changed, 212 insertions(+), 207 deletions(-) diff --git a/src/amrbase/amrcclabel_class.f90 b/src/amrbase/amrcclabel_class.f90 index 4dc5d08a1..19a2e8eae 100644 --- a/src/amrbase/amrcclabel_class.f90 +++ b/src/amrbase/amrcclabel_class.f90 @@ -121,43 +121,28 @@ subroutine build(this,make_label,same_label,coarse_make_label,coarse_same_label, ! Build CCL on finest level call build_lvl(data%amr%maxlvl,make_label,same_label) - ! testing_finest: block - ! integer :: lvl - ! do lvl = 0,data%amr%maxlvl - ! call print_ids(lvl,"after build_lvl(finest)") - ! end do - ! end block testing_finest - ! Create unique IDs for each structure on coarser levels - restrict_unique_id: block - use amrex_interface, only: amrmfab_restrict_unique_id + build_coarser: block integer :: lvl integer, dimension(3) :: ref_ratio do lvl = data%amr%maxlvl-1, 0, -1 ! finest-1 → coarsest - if (this%amr%amRoot) print *,'Restricting to level ',lvl ref_ratio(1)=data%amr%rrefx(lvl) ref_ratio(2)=data%amr%rrefy(lvl) ref_ratio(3)=data%amr%rrefz(lvl) ! Implemented in C to get access to additional functions - call amrmfab_restrict_unique_id( & + call restrict_unique_id( & this%id%mf(lvl), & ! coarse this%id%mf(lvl+1), & ! fine - ref_ratio ) - - ! testing_after_restrict: block - ! integer :: lvl - ! do lvl = 0,data%amr%maxlvl - ! call print_ids(lvl,"after restrict") - ! end do - ! end block testing_after_restrict + ref_ratio, & + this%amr%geom(lvl+1) ) ! Build CCL on coarse level call build_lvl(lvl,coarse_make_label,coarse_same_label) end do - end block restrict_unique_id + end block build_coarser ! testing_end_build: block ! integer :: lvl @@ -173,6 +158,11 @@ subroutine build_lvl(lvl,make_label,same_label) integer, intent(in) :: lvl procedure(make_label_ftype) :: make_label procedure(same_label_ftype) :: same_label + logical :: finest + + ! Set finest logical + finest=.false. + if (lvl.eq.this%amr%maxlvl) finest=.true. ! Start by cleaning up call this%empty() @@ -186,13 +176,21 @@ subroutine build_lvl(lvl,make_label,same_label) this%struct(:)%per(3)=0 this%struct(:)%n_=0 - ! Add any ids from coarser levels to struct array + ! Add any ids from finer levels to struct array previous_ids: block + use mpi_f08, only: MPI_ALLREDUCE,MPI_INTEGER,MPI_MAX,MPI_IN_PLACE use amrex_amr_module, only: amrex_mfiter,amrex_box - integer :: i,j,k + integer :: i,j,k,ierr type(amrex_mfiter) :: mfi type(amrex_box) :: bx real(WP), dimension(:,:,:,:), contiguous, pointer :: pid + ! Only do if on coarser level + if (finest) exit previous_ids + ! Set structure counter to not overwrite any existing structures + nstruct_=this%id%get_max(lvl) + call MPI_ALLREDUCE(MPI_IN_PLACE,nstruct_,1,MPI_INTEGER,MPI_MAX,this%amr%comm,ierr) + this%nstruct=nstruct_ + ! Loop over tiles call data%amr%mfiter_build(lvl,mfi) do while (mfi%next()) @@ -265,7 +263,7 @@ subroutine build_lvl(lvl,make_label,same_label) end do; end do; end do end do end block first_pass - + ! Now collapse the tree, count the cells and resolve periodicity in each structure collapse_tree: block use amrex_amr_module, only: amrex_mfiter,amrex_box @@ -282,9 +280,6 @@ subroutine build_lvl(lvl,make_label,same_label) 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 (pid(i,j,k,1).gt.0.5_WP) then - ! if (nint(pid(i,j,k,1)).ne.1) then - ! print *,' collapsing ',pid(i,j,k,1),' into ',rootify_struct(nint(pid(i,j,k,1))) - ! end if pid(i,j,k,1)=rootify_struct(nint(pid(i,j,k,1))) this%struct(nint(pid(i,j,k,1)))%n_=this%struct(nint(pid(i,j,k,1)))%n_+1 ! pidp(i,j,k,1)=max(nint(pidp(i,j,k,1)),this%struct(nint(pid(i,j,k,1)))%per(1)) @@ -296,67 +291,77 @@ subroutine build_lvl(lvl,make_label,same_label) end do end block collapse_tree - ! Compact structure array + ! Compact structure array on finest level compact_tree: block - use mpi_f08, only: MPI_ALLREDUCE,MPI_SUM,MPI_INTEGER + use mpi_f08, only: MPI_ALLREDUCE,MPI_SUM,MPI_INTEGER,MPI_MAX integer :: i,j,k,n,ierr integer, dimension(:), allocatable :: my_nstruct,all_nstruct,idmap type(struct_type), dimension(:), allocatable :: tmp real(WP), dimension(:,:,:,:), contiguous, pointer :: pid - ! Count exact number of local structures - nstruct_=0 - do n=1,size(this%struct,dim=1) - if (this%struct(n)%n_.gt.0) nstruct_=nstruct_+1 - end do - ! Gather this info to ensure unique index - allocate( my_nstruct(0:this%amr%nproc-1)); my_nstruct=0; my_nstruct(this%amr%rank)=nstruct_ - allocate(all_nstruct(0:this%amr%nproc-1)); call MPI_ALLREDUCE(my_nstruct,all_nstruct,this%amr%nproc,MPI_INTEGER,MPI_SUM,this%amr%comm,ierr) - stmin=1 - if (this%amr%rank.gt.0) stmin=stmin+sum(all_nstruct(0:this%amr%rank-1)) - this%nstruct=sum(all_nstruct) - deallocate(my_nstruct,all_nstruct) - stmax=stmin+nstruct_-1 - ! Generate an index map - allocate(idmap(1:size(this%struct,dim=1))); idmap=0 - nstruct_=0 - do n=1,size(this%struct,dim=1) - if (this%struct(n)%n_.gt.0) then - nstruct_=nstruct_+1 - idmap(n)=stmin+nstruct_-1 - end if - end do - ! Update id array to new index - update_id: block - use amrex_amr_module, only: amrex_mfiter,amrex_box - type(amrex_mfiter) :: mfi - type(amrex_box) :: bx - ! Loop over tiles - call this%amr%mfiter_build(lvl,mfi) - do while (mfi%next()) - ! Get pointers to data - pid=>this%id%mf(lvl)%dataptr(mfi) - ! Perform local loop - 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 (pid(i,j,k,1).gt.0.5_WP) then - pid(i,j,k,1)=idmap(nint(pid(i,j,k,1))) - end if - end do; end do; end do + + ! If not finest just compute the number of structures + if (.not.finest) then + nstruct_=0 + do n=1,size(this%struct,dim=1) + if (this%struct(n)%n_.gt.0) nstruct_=n end do - end block update_id - deallocate(idmap) - ! Finish compacting and renumbering - allocate(tmp(stmin:stmax)) - nstruct_=0 - do n=1,size(this%struct,dim=1) - if (this%struct(n)%n_.gt.0) then - nstruct_=nstruct_+1 - tmp(stmin+nstruct_-1)=this%struct(n) - end if - end do - call move_alloc(tmp,this%struct) + call MPI_ALLREDUCE(nstruct_,this%nstruct,1,MPI_INTEGER,MPI_MAX,this%amr%comm,ierr) + else + ! Count exact number of local structures + nstruct_=0 + do n=1,size(this%struct,dim=1) + if (this%struct(n)%n_.gt.0) nstruct_=nstruct_+1 + end do + ! Gather this info to ensure unique index + allocate( my_nstruct(0:this%amr%nproc-1)); my_nstruct=0; my_nstruct(this%amr%rank)=nstruct_ + allocate(all_nstruct(0:this%amr%nproc-1)); call MPI_ALLREDUCE(my_nstruct,all_nstruct,this%amr%nproc,MPI_INTEGER,MPI_SUM,this%amr%comm,ierr) + stmin=1 + if (this%amr%rank.gt.0) stmin=stmin+sum(all_nstruct(0:this%amr%rank-1)) + this%nstruct=sum(all_nstruct) + deallocate(my_nstruct,all_nstruct) + stmax=stmin+nstruct_-1 + ! Generate an index map + allocate(idmap(1:size(this%struct,dim=1))); idmap=0 + nstruct_=0 + do n=1,size(this%struct,dim=1) + if (this%struct(n)%n_.gt.0) then + nstruct_=nstruct_+1 + idmap(n)=stmin+nstruct_-1 + end if + end do + ! Update id array to new index + update_id: block + use amrex_amr_module, only: amrex_mfiter,amrex_box + type(amrex_mfiter) :: mfi + type(amrex_box) :: bx + ! Loop over tiles + call this%amr%mfiter_build(lvl,mfi) + do while (mfi%next()) + ! Get pointers to data + pid=>this%id%mf(lvl)%dataptr(mfi) + ! Perform local loop + 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 (pid(i,j,k,1).gt.0.5_WP) then + pid(i,j,k,1)=idmap(nint(pid(i,j,k,1))) + end if + end do; end do; end do + end do + end block update_id + deallocate(idmap) + ! Finish compacting and renumbering + allocate(tmp(stmin:stmax)) + nstruct_=0 + do n=1,size(this%struct,dim=1) + if (this%struct(n)%n_.gt.0) then + nstruct_=nstruct_+1 + tmp(stmin+nstruct_-1)=this%struct(n) + end if + end do + call move_alloc(tmp,this%struct) + end if end block compact_tree - + ! Interprocessor treatment of our structures interproc_handling: block use mpi_f08, only: MPI_ALLREDUCE,MPI_MIN,MPI_MAX,MPI_INTEGER @@ -470,8 +475,8 @@ subroutine build_lvl(lvl,make_label,same_label) call this%id%sync() end block interproc_handling - ! Now we need to compact the data based on id only - compact_struct: block + ! Now we need to compact the data based on id only if on finest level + renumber_ids: block use mpi_f08, only: MPI_ALLREDUCE,MPI_MAX,MPI_INTEGER,MPI_IN_PLACE use amrex_amr_module, only: amrex_mfiter,amrex_box integer :: i,j,k,n,nn,ierr,count @@ -480,6 +485,8 @@ subroutine build_lvl(lvl,make_label,same_label) type(amrex_mfiter) :: mfi type(amrex_box) :: bx real(WP), dimension(:,:,:,:), contiguous, pointer :: pid + ! Only renumber of finest level + if (.not.finest) exit renumber_ids ! Prepare global id map allocate( idmap(1:this%nstruct)); idmap=0 ! Traverse id array and tag used id values @@ -516,8 +523,10 @@ subroutine build_lvl(lvl,make_label,same_label) if (pid(i,j,k,1).gt.0) pid(i,j,k,1)=idmap(pid(i,j,k,1)) end do; end do; end do end do - call this%id%sync() - end block compact_struct + end block renumber_ids + + ! Sync final ids + call this%id%sync() ! Release scratch call idp%finalize() @@ -719,6 +728,124 @@ recursive function find_own(x) result(y) y=parent_own(y) end if end function find_own + + subroutine restrict_unique_id(cmf, fmf, ratio, geom) + use amrex_multifab_module, only : amrex_multifab,amrex_multifab_build,amrex_multifab_destroy + use amrex_amr_module, only : amrex_mfiter, amrex_mfiter_build, amrex_mfiter_destroy + use amrex_amr_module, only : amrex_box, amrex_long, amrex_geometry + use amrex_boxarray_module, only : amrex_boxarray, amrex_boxarray_build, amrex_boxarray_destroy + implicit none + type(amrex_multifab), intent(inout) :: cmf + type(amrex_multifab), intent(in) :: fmf + integer, intent(in) :: ratio(3) + type(amrex_geometry), intent(in) :: geom + + type(amrex_multifab) :: fine_tmp + type(amrex_boxarray) :: fba + type(amrex_mfiter) :: mfi + type(amrex_box) :: bx + + real(WP), contiguous, pointer :: cp(:,:,:,:) => null() + real(WP), contiguous, pointer :: fp(:,:,:,:) => null() + + integer(amrex_long) :: nb, n + integer, allocatable :: bxs(:,:,:) ! (2, 3, nboxes) — lo/hi, dim, box index + + integer, dimension(3) :: clo,chi,flo,fhi + + ! Build refined boxarray by scaling each coarse box's lo/hi + nb = cmf%ba%nboxes() + allocate(bxs(2, 3, nb)) + do n = 1, nb + bx = cmf%ba%get_box(int(n-1)) ! get_box is 0-indexed on the C side + bxs(1,:,n) = bx%lo * ratio + bxs(2,:,n) = (bx%hi + 1) * ratio - 1 + end do + call amrex_boxarray_build(fba, bxs) + deallocate(bxs) + + call amrex_multifab_build(fine_tmp, fba, cmf%dm, 1, 0) + call amrex_boxarray_destroy(fba) + + call fine_tmp%setval(0.0_WP) + call fine_tmp%parallel_copy(fmf, geom) + + call amrex_mfiter_build(mfi, cmf) + do while (mfi%next()) + bx = mfi%validbox() + cp => cmf%dataptr(mfi) + fp => fine_tmp%dataptr(mfi) + + clo = [lbound(cp,1), lbound(cp,2), lbound(cp,3)] + chi = [ubound(cp,1), ubound(cp,2), ubound(cp,3)] + flo = [lbound(fp,1), lbound(fp,2), lbound(fp,3)] + fhi = [ubound(fp,1), ubound(fp,2), ubound(fp,3)] + + + call restrict_kernel(cp(:,:,:,1), clo, chi, & + fp(:,:,:,1), flo, fhi, & + bx%lo, bx%hi, ratio) + + nullify(cp, fp) + end do + call amrex_mfiter_destroy(mfi) + call amrex_multifab_destroy(fine_tmp) + + end subroutine restrict_unique_id + + !--------------------------------------------------------------------------- + ! Private kernel — operates on a single patch + !--------------------------------------------------------------------------- + subroutine restrict_kernel(crse, clo, chi, fine, flo, fhi, lo, hi, ratio) + implicit none + integer, intent(in) :: clo(3), chi(3) + integer, intent(in) :: flo(3), fhi(3) + integer, intent(in) :: lo(3), hi(3), ratio(3) + real(WP), intent(inout) :: crse(clo(1):chi(1), clo(2):chi(2), clo(3):chi(3)) + real(WP), intent(in) :: fine(flo(1):fhi(1), flo(2):fhi(2), flo(3):fhi(3)) + + integer :: i, j, k + integer :: ii, jj, kk + integer :: id_val, id_store + logical :: found, conflict + + do k = lo(3), hi(3) + do j = lo(2), hi(2) + do i = lo(1), hi(1) + + found = .false. + conflict = .false. + id_store = 0 + + do kk = k*ratio(3), k*ratio(3) + ratio(3) - 1 + do jj = j*ratio(2), j*ratio(2) + ratio(2) - 1 + do ii = i*ratio(1), i*ratio(1) + ratio(1) - 1 + + if (abs(fine(ii,jj,kk)) > 0.5_WP) then + id_val = nint(fine(ii,jj,kk)) + if (.not. found) then + id_store = id_val + found = .true. + else if (id_val /= id_store) then + conflict = .true. + end if + end if + + end do + end do + end do + + if (found .and. .not. conflict) then + crse(i,j,k) = real(id_store, WP) + else + crse(i,j,k) = 0.0_WP + end if + + end do + end do + end do + + end subroutine restrict_kernel end subroutine build diff --git a/src/amrbase/amrex_interface.f90 b/src/amrbase/amrex_interface.f90 index 4dbed1166..f57f8d2eb 100644 --- a/src/amrbase/amrex_interface.f90 +++ b/src/amrbase/amrex_interface.f90 @@ -93,7 +93,6 @@ module amrex_interface public :: amrmfab_compute_divergence ! Compute div(u) from face velocities public :: amrmfab_sum_unique ! Sum for face/nodal data (no double-counting) public :: amrmask_make_fine ! Create mask for cells covered by finer level - public :: amrmfab_restrict_unique_id ! Restrict unique ID from fine to coarse (for tracking structures) !===================================================================== ! Per-direction wrappers (bypass AMReX scalar-only Fortran interfaces) @@ -628,13 +627,6 @@ subroutine amrmask_make_fine_c(mask, ba_fine, ref_ratio, covered_val, notcovered integer(c_int), intent(in) :: ref_ratio(3) integer(c_int), value :: covered_val, notcovered_val end subroutine amrmask_make_fine_c - subroutine amrmfab_restrict_unique_id_c(crse,fine,ref_ratio) & - bind(c, name='amrmfab_restrict_unique_id') - import :: c_ptr, c_int - type(c_ptr), value :: crse - type(c_ptr), value :: fine - integer(c_int) :: ref_ratio(3) - end subroutine amrmfab_restrict_unique_id_c end interface @@ -790,15 +782,6 @@ subroutine amrmask_make_fine(mask, ba_fine, ref_ratio, covered_val, notcovered_v call amrmask_make_fine_c(mask%p, ba_fine%p, ref_ratio, covered_val, notcovered_val) end subroutine amrmask_make_fine - !> Restrict unique ID from fine to coarse (for tracking structures) - subroutine amrmfab_restrict_unique_id(crse,fine,ref_ratio) - use amrex_amr_module, only: amrex_multifab - type(amrex_multifab), intent(inout) :: crse - type(amrex_multifab), intent(in) :: fine - integer, intent(in) :: ref_ratio(3) - call amrmfab_restrict_unique_id_c(crse%p, fine%p, ref_ratio) - end subroutine amrmfab_restrict_unique_id - !> Fill coarse patch for 3-component face-centered velocity subroutine amrmfab_fillcoarsepatch_faces(mf_u, mf_v, mf_w, time, & & cmf_u, cmf_v, cmf_w, geom_c, geom_f, & diff --git a/src/amrbase/amrex_wrapper.cpp b/src/amrbase/amrex_wrapper.cpp index eaaf2f5f9..1437a64d4 100644 --- a/src/amrbase/amrex_wrapper.cpp +++ b/src/amrbase/amrex_wrapper.cpp @@ -1312,109 +1312,4 @@ void amrmfab_parallel_add(void *dst_ptr, void *src_ptr, geom->periodicity(), amrex::FabArrayBase::ADD); } -} // extern "C" - - -//----------------------------------------------------------------------------- -// Restriction operator to determine unique id's on coarser levels -//----------------------------------------------------------------------------- - -extern "C" void amrmfab_restrict_unique_id(void *crse_mf_ptr, - void *fine_mf_ptr, - int *ref_ratio) -{ - auto *cmf = static_cast(crse_mf_ptr); - auto *fmf = static_cast(fine_mf_ptr); - - amrex::IntVect ratio(AMREX_D_DECL(ref_ratio[0], - ref_ratio[1], - ref_ratio[2])); - - // -------------------------------------------- - // Gather all local fine FABs (no nested MFIter) - // -------------------------------------------- - std::vector fine_boxes; - std::vector> fine_arrays; - - for (amrex::MFIter mfi_f(*fmf, amrex::TilingIfNotGPU()); mfi_f.isValid(); ++mfi_f) - { - const auto& fab = (*fmf)[mfi_f]; - fine_boxes.push_back(fab.box()); - fine_arrays.push_back(fab.const_array()); - } - - // -------------------------------------------- - // Coarse loop - // -------------------------------------------- - for (amrex::MFIter mfi(*cmf, amrex::TilingIfNotGPU()); mfi.isValid(); ++mfi) - { - const amrex::Box& cbox = mfi.tilebox(); - auto const& carr = cmf->array(mfi); - - // ✅ define fbox (this was missing) - amrex::Box fbox = amrex::refine(cbox, ratio); - - amrex::LoopOnCpu(cbox, - [=, &fine_boxes, &fine_arrays] (int i, int j, int k) noexcept - { - bool found = false; - bool conflict = false; - int id_store = 0; - - const auto& clo = cbox.smallEnd(); - const auto& flo = fbox.smallEnd(); - - // ✅ correct mapping (this fixes your wrong IDs problem) - int fi0 = (i - clo[0]) * ratio[0] + flo[0]; - int fj0 = (j - clo[1]) * ratio[1] + flo[1]; - int fk0 = (k - clo[2]) * ratio[2] + flo[2]; - - for (int n = 0; n < fine_boxes.size(); ++n) - { - const auto& fbx = fine_boxes[n]; - const auto& farr = fine_arrays[n]; - - // Only consider overlapping region - amrex::Box overlap = fbox & fbx; - if (!overlap.ok()) continue; - - for (int kk = 0; kk < ratio[2]; ++kk) - for (int jj = 0; jj < ratio[1]; ++jj) - for (int ii = 0; ii < ratio[0]; ++ii) - { - int fi = fi0 + ii; - int fj = fj0 + jj; - int fk = fk0 + kk; - - // Check if inside this FAB - if (fi >= overlap.smallEnd(0) && fi <= overlap.bigEnd(0) && - fj >= overlap.smallEnd(1) && fj <= overlap.bigEnd(1) && - fk >= overlap.smallEnd(2) && fk <= overlap.bigEnd(2)) - { - amrex::Real val = farr(fi,fj,fk,0); - - if (val > 0.5) - { - int id_val = static_cast(amrex::Math::round(val)); - - if (!found) - { - id_store = id_val; - found = true; - } - else if (id_val != id_store) - { - conflict = true; - } - } - } - } - } - - if (!found || conflict) - carr(i,j,k,0) = 0.0; - else - carr(i,j,k,0) = static_cast(id_store); - }); - } -} \ No newline at end of file +} // extern "C" \ No newline at end of file From e2af4b718b64f21a24f28438b0b52ee742134214 Mon Sep 17 00:00:00 2001 From: Mark Owkes Date: Thu, 18 Jun 2026 09:47:35 -0600 Subject: [PATCH 52/70] Added stats calculation. Need to do cleanup and check how nstruct is defined. --- examples/amrcclabel_tester/src/simulation.f90 | 12 ++ src/amrbase/amrcclabel_class.f90 | 144 +++++++++++++++++- 2 files changed, 151 insertions(+), 5 deletions(-) diff --git a/examples/amrcclabel_tester/src/simulation.f90 b/examples/amrcclabel_tester/src/simulation.f90 index 7b10ee7f4..069cc648e 100644 --- a/examples/amrcclabel_tester/src/simulation.f90 +++ b/examples/amrcclabel_tester/src/simulation.f90 @@ -306,10 +306,22 @@ end subroutine simulation_init !> Time integrate our problem subroutine simulation_run + use amrcclabel_class, only : stats_type + type(stats_type), dimension(:), allocatable :: stats ! Compute CCLabel call cclabel%build(make_label,same_label,coarse_make_label,coarse_same_label,vof%VF) + ! Compute structure statistics + call cclabel%compute_stats(vof%VF,stats) + + print_stats: block + integer :: n + do n=1,cclabel%nstruct + print *, "rank =", amr%rank, "id=",n," vol=",stats(n)%vol," com=",stats(n)%com + end do + end block print_stats + ! Write visualization with IDs call viz%write(time=0.0_WP) diff --git a/src/amrbase/amrcclabel_class.f90 b/src/amrbase/amrcclabel_class.f90 index 19a2e8eae..3ce166955 100644 --- a/src/amrbase/amrcclabel_class.f90 +++ b/src/amrbase/amrcclabel_class.f90 @@ -1,6 +1,5 @@ !> TODO -! - restict seems to be working -! - Now need to update cells on a coarse level that are completely liquid - i think. Test with level = 3 or 4? +! - Be more careful with this%nstruct should be set on finest level and then not touched on coarser levels. !> Connected component labeling class: identifies Lagrangian objects from a Eulerian logical field @@ -16,7 +15,7 @@ module amrcclabel_class ! Expose type/constructor/methods - public :: amrcclabel,make_label_ftype,same_label_ftype + public :: amrcclabel,make_label_ftype,same_label_ftype,stats_type ! Some parameters for memory management @@ -30,6 +29,12 @@ module amrcclabel_class integer, dimension(3) :: per !< Periodicity array - per(dim)=1 if structure is periodic in dim direction end type struct_type + !> Statistics object + type :: stats_type + integer :: id !< ID of structure + real(WP) :: vol !< Volme of structure + real(WP), dimension(3) :: com !< Center of mass of structure + end type stats_type !> amrcclabel object definition type :: amrcclabel @@ -49,6 +54,7 @@ module amrcclabel_class procedure :: initialize procedure :: build procedure :: empty + procedure :: compute_stats procedure :: finalize end type amrcclabel @@ -121,6 +127,7 @@ subroutine build(this,make_label,same_label,coarse_make_label,coarse_same_label, ! Build CCL on finest level call build_lvl(data%amr%maxlvl,make_label,same_label) + ! Create unique IDs for each structure on coarser levels build_coarser: block integer :: lvl @@ -192,7 +199,7 @@ subroutine build_lvl(lvl,make_label,same_label) this%nstruct=nstruct_ ! Loop over tiles - call data%amr%mfiter_build(lvl,mfi) + call this%amr%mfiter_build(lvl,mfi) do while (mfi%next()) ! Get pointers to data arrays pid=>this%id%mf(lvl)%dataptr(mfi) @@ -217,7 +224,7 @@ subroutine build_lvl(lvl,make_label,same_label) real(WP), dimension(:,:,:,:), contiguous, pointer :: pid,pdata ! Loop over tiles - call data%amr%mfiter_build(lvl,mfi) + call this%amr%mfiter_build(lvl,mfi) do while (mfi%next()) ! Get pointers to data arrays pid=>this%id%mf(lvl)%dataptr(mfi) @@ -860,6 +867,133 @@ subroutine empty(this) ! Zero structures this%nstruct=0 end subroutine empty + + + !> Compute common statistics for structures + !> identified by id in this%id and weighted by VF array + subroutine compute_stats(this,VF,stats) + use amrex_fort_module, only : amrex_spacedim + use amrex_multifab_module, only : amrex_multifab, amrex_mfiter, & + amrex_mfiter_build, amrex_mfiter_destroy + use amrex_box_module, only : amrex_box + use amrex_boxarray_module, only : amrex_boxarray, amrex_boxarray_build, amrex_boxarray_destroy + use amrex_geometry_module, only : amrex_geometry + use amrex_box_module, only : amrex_box + use amrex_amr_module, only : amrex_long + use amrex_parallel_module, only : amrex_parallel_reduce_sum + implicit none + class(amrcclabel) :: this + type(amrdata), intent(in) :: VF + type(stats_type), allocatable, dimension(:), intent(out) :: stats + real(WP), allocatable, dimension(:) :: vol_map + real(WP), allocatable, dimension(:,:) :: com_map + logical :: id_seen(this%nstruct) + type(amrex_mfiter) :: mfi + type(amrex_box) :: bx + type(amrex_boxarray) :: fine_ba_crse + type(amrex_box) :: pt_box + real(WP), dimension(:,:,:,:), contiguous, pointer :: pid,pVF + real(WP) :: dx(3), cell_vol, prob_lo(3) + real(WP) :: xc, yc, zc + integer :: lo(3), hi(3), ilo(3), ihi(3) + integer :: i, j, k, lvl, id_val + real(WP) :: VF_val + integer(amrex_long) :: nb, n + integer, allocatable :: bxs(:,:,:) + integer :: ratio(3) + + allocate(vol_map(1:this%nstruct)) + allocate(com_map(1:this%nstruct,3)) + + vol_map = 0.0_WP + com_map = 0.0_WP + prob_lo = [this%amr%xlo, this%amr%ylo, this%amr%zlo] + + do lvl = 0, this%amr%maxlvl + + dx(1) = this%amr%dx(lvl) + dx(2) = this%amr%dy(lvl) + dx(3) = this%amr%dz(lvl) + cell_vol = this%amr%cell_vol(lvl) + + if (lvl < this%amr%maxlvl) then + ratio = [this%amr%rrefx(lvl), this%amr%rrefy(lvl), this%amr%rrefz(lvl)] + nb = this%id%mf(lvl+1)%ba%nboxes() + allocate(bxs(2, 3, nb)) + do n = 1, nb + bx = this%id%mf(lvl+1)%ba%get_box(int(n-1)) + bxs(1,:,n) = bx%lo / ratio + bxs(2,:,n) = bx%hi / ratio + end do + call amrex_boxarray_build(fine_ba_crse, bxs) + deallocate(bxs) + end if + + call this%amr%mfiter_build(lvl,mfi) + do while (mfi%next()) + ! Get pointers to data arrays + pid => this%id%mf(lvl)%dataptr(mfi) + pVF => VF%mf(lvl)%dataptr(mfi) + bx = mfi%validbox() + lo = bx%lo + hi = bx%hi + + ilo = [lbound(pid,1), lbound(pid,2), lbound(pid,3)] + ihi = [ubound(pid,1), ubound(pid,2), ubound(pid,3)] + + accumulate_stats: block + real(WP) :: id_arr(ilo(1):ihi(1), ilo(2):ihi(2), ilo(3):ihi(3)) + + do k = lo(3), hi(3) + do j = lo(2), hi(2) + do i = lo(1), hi(1) + + id_val = nint(pid(i,j,k,1)) + VF_val = pVF(i,j,k,1) + if (id_val <= 0) cycle + + if (lvl < this%amr%maxlvl) then + pt_box%lo = [i, j, k] + pt_box%hi = [i, j, k] + if (fine_ba_crse%intersects(pt_box)) cycle + end if + + xc = prob_lo(1) + (real(i, WP) + 0.5_WP) * dx(1) + yc = prob_lo(2) + (real(j, WP) + 0.5_WP) * dx(2) + zc = prob_lo(3) + (real(k, WP) + 0.5_WP) * dx(3) + + vol_map(id_val ) = vol_map(id_val ) + cell_vol * VF_val + com_map(id_val,1) = com_map(id_val,1) + cell_vol * VF_val * xc + com_map(id_val,2) = com_map(id_val,2) + cell_vol * VF_val * yc + com_map(id_val,3) = com_map(id_val,3) + cell_vol * VF_val * zc + + end do + end do + end do + end block accumulate_stats + + nullify(pid) + nullify(pVF) + end do + call amrex_mfiter_destroy(mfi) + + if (lvl < this%amr%maxlvl) call amrex_boxarray_destroy(fine_ba_crse) + + end do + + call amrex_parallel_reduce_sum(vol_map, this%nstruct) + call amrex_parallel_reduce_sum(com_map(:,1), this%nstruct) + call amrex_parallel_reduce_sum(com_map(:,2), this%nstruct) + call amrex_parallel_reduce_sum(com_map(:,3), this%nstruct) + + allocate(stats(this%nstruct)) + do i = 1, this%nstruct + stats(i)%id = i + stats(i)%vol = vol_map(i) + stats(i)%com = com_map(i,:)/vol_map(i) + end do + + end subroutine compute_stats !> Finalize CCL object From f6242bdcd79feafe5b51d63d84b045a42553decb Mon Sep 17 00:00:00 2001 From: Mark Owkes Date: Thu, 18 Jun 2026 11:08:28 -0600 Subject: [PATCH 53/70] Cleanup print --- examples/amrcclabel_tester/src/simulation.f90 | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/examples/amrcclabel_tester/src/simulation.f90 b/examples/amrcclabel_tester/src/simulation.f90 index 069cc648e..ddd758700 100644 --- a/examples/amrcclabel_tester/src/simulation.f90 +++ b/examples/amrcclabel_tester/src/simulation.f90 @@ -317,9 +317,11 @@ subroutine simulation_run print_stats: block integer :: n - do n=1,cclabel%nstruct - print *, "rank =", amr%rank, "id=",n," vol=",stats(n)%vol," com=",stats(n)%com - end do + if (amr%amRoot) then + do n=1,cclabel%nstruct + print *, "id=",n," vol=",stats(n)%vol," com=",stats(n)%com + end do + end if end block print_stats ! Write visualization with IDs From 6f48dcf329a95f082ca5061b7c4ad27a972fad37 Mon Sep 17 00:00:00 2001 From: Mark Owkes Date: Thu, 18 Jun 2026 11:22:31 -0600 Subject: [PATCH 54/70] Fixed this%nstruct calculation --- src/amrbase/amrcclabel_class.f90 | 43 +++++++++++++------------------- 1 file changed, 18 insertions(+), 25 deletions(-) diff --git a/src/amrbase/amrcclabel_class.f90 b/src/amrbase/amrcclabel_class.f90 index 3ce166955..4cbaf74f3 100644 --- a/src/amrbase/amrcclabel_class.f90 +++ b/src/amrbase/amrcclabel_class.f90 @@ -1,7 +1,3 @@ -!> TODO -! - Be more careful with this%nstruct should be set on finest level and then not touched on coarser levels. - - !> Connected component labeling class: identifies Lagrangian objects from a Eulerian logical field !> and provides unstructured mapping to traverse these objects module amrcclabel_class @@ -166,6 +162,7 @@ subroutine build_lvl(lvl,make_label,same_label) procedure(make_label_ftype) :: make_label procedure(same_label_ftype) :: same_label logical :: finest + integer :: nstruct_work ! Set finest logical finest=.false. @@ -194,10 +191,8 @@ subroutine build_lvl(lvl,make_label,same_label) ! Only do if on coarser level if (finest) exit previous_ids ! Set structure counter to not overwrite any existing structures - nstruct_=this%id%get_max(lvl) - call MPI_ALLREDUCE(MPI_IN_PLACE,nstruct_,1,MPI_INTEGER,MPI_MAX,this%amr%comm,ierr) - this%nstruct=nstruct_ - + nstruct_=this%nstruct + ! Loop over tiles call this%amr%mfiter_build(lvl,mfi) do while (mfi%next()) @@ -298,7 +293,7 @@ subroutine build_lvl(lvl,make_label,same_label) end do end block collapse_tree - ! Compact structure array on finest level + ! Compact structure array compact_tree: block use mpi_f08, only: MPI_ALLREDUCE,MPI_SUM,MPI_INTEGER,MPI_MAX integer :: i,j,k,n,ierr @@ -312,7 +307,7 @@ subroutine build_lvl(lvl,make_label,same_label) do n=1,size(this%struct,dim=1) if (this%struct(n)%n_.gt.0) nstruct_=n end do - call MPI_ALLREDUCE(nstruct_,this%nstruct,1,MPI_INTEGER,MPI_MAX,this%amr%comm,ierr) + call MPI_ALLREDUCE(nstruct_,nstruct_work,1,MPI_INTEGER,MPI_MAX,this%amr%comm,ierr) else ! Count exact number of local structures nstruct_=0 @@ -324,7 +319,7 @@ subroutine build_lvl(lvl,make_label,same_label) allocate(all_nstruct(0:this%amr%nproc-1)); call MPI_ALLREDUCE(my_nstruct,all_nstruct,this%amr%nproc,MPI_INTEGER,MPI_SUM,this%amr%comm,ierr) stmin=1 if (this%amr%rank.gt.0) stmin=stmin+sum(all_nstruct(0:this%amr%rank-1)) - this%nstruct=sum(all_nstruct) + nstruct_work=sum(all_nstruct) deallocate(my_nstruct,all_nstruct) stmax=stmin+nstruct_-1 ! Generate an index map @@ -381,11 +376,11 @@ subroutine build_lvl(lvl,make_label,same_label) type(amrex_box) :: bx real(WP), dimension(:,:,:,:), contiguous, pointer :: pid,pidp,pdata ! Allocate to total number of structures - allocate(parent (this%nstruct)); parent =0 - allocate(parent_all(this%nstruct)); parent_all=0 - allocate(parent_own(this%nstruct)); parent_own=0 + allocate(parent (nstruct_work)); parent =0 + allocate(parent_all(nstruct_work)); parent_all=0 + allocate(parent_own(nstruct_work)); parent_own=0 ! Fill global lineage with selves - do n=1,this%nstruct + do n=1,nstruct_work parent(n)=n end do ! Synchronize id array @@ -426,17 +421,17 @@ subroutine build_lvl(lvl,make_label,same_label) ! Remember own parents parent_own=parent ! Set self-parents to huge(1) - do n=1,this%nstruct + do n=1,nstruct_work if (parent(n).eq.n) parent(n)=huge(1) end do ! Take global min - call MPI_ALLREDUCE(parent,parent_all,this%nstruct,MPI_INTEGER,MPI_MIN,this%amr%comm,ierr) + call MPI_ALLREDUCE(parent,parent_all,nstruct_work,MPI_INTEGER,MPI_MIN,this%amr%comm,ierr) ! Set self-parents back to selves - do n=1,this%nstruct + do n=1,nstruct_work if (parent_all(n).eq.huge(1)) parent_all(n)=n end do ! Flatten trees - do n=1,this%nstruct + do n=1,nstruct_work parent_all(n)=find_all(n) parent_own(n)=find_own(n) end do @@ -445,7 +440,7 @@ subroutine build_lvl(lvl,make_label,same_label) ! Increment counter counter=counter+1 ! Reconcile conflicts between parent_all and parent_own - do n=1,this%nstruct + do n=1,nstruct_work if (parent_own(n).ne.n) then find_parent_own=rootify_parent(parent_own(n)) find_parent =rootify_parent(parent(n)) @@ -495,7 +490,7 @@ subroutine build_lvl(lvl,make_label,same_label) ! Only renumber of finest level if (.not.finest) exit renumber_ids ! Prepare global id map - allocate( idmap(1:this%nstruct)); idmap=0 + allocate( idmap(1:nstruct_work)); idmap=0 ! Traverse id array and tag used id values ! Loop over tiles call this%amr%mfiter_build(lvl,mfi) @@ -508,8 +503,8 @@ subroutine build_lvl(lvl,make_label,same_label) if (pid(i,j,k,1).gt.0) idmap(pid(i,j,k,1))=1 end do; end do; end do end do - call MPI_ALLREDUCE(MPI_IN_PLACE,idmap,this%nstruct,MPI_INTEGER,MPI_MAX,this%amr%comm,ierr) - ! Count number of used structures and create the map + call MPI_ALLREDUCE(MPI_IN_PLACE,idmap,nstruct_work,MPI_INTEGER,MPI_MAX,this%amr%comm,ierr) + ! Count number of used structures, set nstruct, and create map this%nstruct=sum(idmap) count=0 do n=1,size(idmap,dim=1) @@ -864,8 +859,6 @@ subroutine empty(this) integer :: n ! Deallocate structure array if (allocated(this%struct)) deallocate(this%struct) - ! Zero structures - this%nstruct=0 end subroutine empty From cd85919916019b866a164ed4b1cef3a36753a9ac Mon Sep 17 00:00:00 2001 From: Mark Owkes Date: Thu, 18 Jun 2026 11:26:31 -0600 Subject: [PATCH 55/70] clean-up --- src/amrbase/amrcclabel_class.f90 | 29 +++++++++++------------------ 1 file changed, 11 insertions(+), 18 deletions(-) diff --git a/src/amrbase/amrcclabel_class.f90 b/src/amrbase/amrcclabel_class.f90 index 4cbaf74f3..15bb7acca 100644 --- a/src/amrbase/amrcclabel_class.f90 +++ b/src/amrbase/amrcclabel_class.f90 @@ -182,9 +182,9 @@ subroutine build_lvl(lvl,make_label,same_label) ! Add any ids from finer levels to struct array previous_ids: block - use mpi_f08, only: MPI_ALLREDUCE,MPI_INTEGER,MPI_MAX,MPI_IN_PLACE + use mpi_f08, only: MPI_ALLREDUCE,MPI_INTEGER,MPI_MAX use amrex_amr_module, only: amrex_mfiter,amrex_box - integer :: i,j,k,ierr + integer :: i,j,k type(amrex_mfiter) :: mfi type(amrex_box) :: bx real(WP), dimension(:,:,:,:), contiguous, pointer :: pid @@ -272,7 +272,7 @@ subroutine build_lvl(lvl,make_label,same_label) integer :: i,j,k type(amrex_mfiter) :: mfi type(amrex_box) :: bx - real(WP), dimension(:,:,:,:), contiguous, pointer :: pid,pidp + real(WP), dimension(:,:,:,:), contiguous, pointer :: pid ! Loop over tiles call data%amr%mfiter_build(lvl,mfi) do while (mfi%next()) @@ -371,10 +371,10 @@ subroutine build_lvl(lvl,make_label,same_label) integer :: i,j,k integer :: ii,jj,kk,dim integer, dimension(3) :: pos - integer ::stop_global,stop_,counter,n,m,ierr,find_parent,find_parent_own + integer ::stop_global,stop_,counter,n,ierr,find_parent,find_parent_own type(amrex_mfiter) :: mfi type(amrex_box) :: bx - real(WP), dimension(:,:,:,:), contiguous, pointer :: pid,pidp,pdata + real(WP), dimension(:,:,:,:), contiguous, pointer :: pid,pdata ! Allocate to total number of structures allocate(parent (nstruct_work)); parent =0 allocate(parent_all(nstruct_work)); parent_all=0 @@ -481,9 +481,8 @@ subroutine build_lvl(lvl,make_label,same_label) renumber_ids: block use mpi_f08, only: MPI_ALLREDUCE,MPI_MAX,MPI_INTEGER,MPI_IN_PLACE use amrex_amr_module, only: amrex_mfiter,amrex_box - integer :: i,j,k,n,nn,ierr,count - integer, dimension(:), allocatable :: idmap,counter - type(struct_type), dimension(:), allocatable :: tmp + integer :: i,j,k,n,ierr,count + integer, dimension(:), allocatable :: idmap type(amrex_mfiter) :: mfi type(amrex_box) :: bx real(WP), dimension(:,:,:,:), contiguous, pointer :: pid @@ -500,7 +499,7 @@ subroutine build_lvl(lvl,make_label,same_label) ! Perform local loop 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 (pid(i,j,k,1).gt.0) idmap(pid(i,j,k,1))=1 + if (pid(i,j,k,1).gt.0) idmap(nint(pid(i,j,k,1)))=1 end do; end do; end do end do call MPI_ALLREDUCE(MPI_IN_PLACE,idmap,nstruct_work,MPI_INTEGER,MPI_MAX,this%amr%comm,ierr) @@ -522,7 +521,7 @@ subroutine build_lvl(lvl,make_label,same_label) ! Perform local loop 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 (pid(i,j,k,1).gt.0) pid(i,j,k,1)=idmap(pid(i,j,k,1)) + if (pid(i,j,k,1).gt.0) pid(i,j,k,1)=idmap(nint(pid(i,j,k,1))) end do; end do; end do end do end block renumber_ids @@ -547,10 +546,10 @@ subroutine print_ids(lvl,msg) real(WP), dimension(:,:,:,:), contiguous, pointer :: pid type(amrex_mfiter) :: mfi type(amrex_box) :: bx - integer, parameter :: max_id = 100000 ! adjust as needed + integer, parameter :: max_id = 10000 ! adjust as needed logical :: seen(0:max_id) integer :: count(0:max_id) - integer :: id,i,j,k,root + integer :: id,i,j,k seen = .false. count = 0 @@ -644,7 +643,6 @@ end function add subroutine add_existing(id) implicit none integer, intent(in) :: id - integer :: x integer :: size_now,size_new type(struct_type), dimension(:), allocatable :: tmp ! Check if there is enough room for storing a new structure @@ -856,7 +854,6 @@ end subroutine build subroutine empty(this) implicit none class(amrcclabel), intent(inout) :: this - integer :: n ! Deallocate structure array if (allocated(this%struct)) deallocate(this%struct) end subroutine empty @@ -880,7 +877,6 @@ subroutine compute_stats(this,VF,stats) type(stats_type), allocatable, dimension(:), intent(out) :: stats real(WP), allocatable, dimension(:) :: vol_map real(WP), allocatable, dimension(:,:) :: com_map - logical :: id_seen(this%nstruct) type(amrex_mfiter) :: mfi type(amrex_box) :: bx type(amrex_boxarray) :: fine_ba_crse @@ -935,12 +931,9 @@ subroutine compute_stats(this,VF,stats) ihi = [ubound(pid,1), ubound(pid,2), ubound(pid,3)] accumulate_stats: block - real(WP) :: id_arr(ilo(1):ihi(1), ilo(2):ihi(2), ilo(3):ihi(3)) - do k = lo(3), hi(3) do j = lo(2), hi(2) do i = lo(1), hi(1) - id_val = nint(pid(i,j,k,1)) VF_val = pVF(i,j,k,1) if (id_val <= 0) cycle From 4ccaa9309b38846a07bdaa9fe3a6203f587afbbd Mon Sep 17 00:00:00 2001 From: Mark Owkes Date: Thu, 18 Jun 2026 11:27:58 -0600 Subject: [PATCH 56/70] Remove debug print statements. --- src/amrbase/amrcclabel_class.f90 | 60 -------------------------------- 1 file changed, 60 deletions(-) diff --git a/src/amrbase/amrcclabel_class.f90 b/src/amrbase/amrcclabel_class.f90 index 15bb7acca..4d2c4f2ed 100644 --- a/src/amrbase/amrcclabel_class.f90 +++ b/src/amrbase/amrcclabel_class.f90 @@ -147,13 +147,6 @@ subroutine build(this,make_label,same_label,coarse_make_label,coarse_same_label, end do end block build_coarser - ! testing_end_build: block - ! integer :: lvl - ! do lvl = 0,data%amr%maxlvl - ! call print_ids(lvl,"after build") - ! end do - ! end block testing_end_build - contains !> Build structure on a level using user-set test functions @@ -537,59 +530,6 @@ subroutine build_lvl(lvl,make_label,same_label) end subroutine build_lvl - !> Debug function to print id's that exist on a level - subroutine print_ids(lvl,msg) - use amrex_amr_module, only: amrex_mfiter,amrex_box - implicit none - integer, intent(in) :: lvl - character(len=*), intent(in) :: msg - real(WP), dimension(:,:,:,:), contiguous, pointer :: pid - type(amrex_mfiter) :: mfi - type(amrex_box) :: bx - integer, parameter :: max_id = 10000 ! adjust as needed - logical :: seen(0:max_id) - integer :: count(0:max_id) - integer :: id,i,j,k - - seen = .false. - count = 0 - ! Loop over tiles - call data%amr%mfiter_build(lvl,mfi) - do while (mfi%next()) - pid => this%id%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) - id = nint(pid(i,j,k,1)) - if (id <= max_id) then - seen(id) = .true. - count(id) = count(id) + 1 - else - print *, "Warning: ID ", id, " exceeds max_id ", max_id - end if - end do; end do; end do - end do - ! Collect and print unique IDs - communicate: block - use mpi_f08, only: MPI_ALLREDUCE,MPI_IN_PLACE,MPI_Logical,MPI_LOR, MPI_INTEGER, MPI_SUM - integer :: ierr - call MPI_AllREDUCE(MPI_IN_PLACE, seen, max_id+1, MPI_LOGICAL, MPI_LOR, this%amr%comm, ierr) - call MPI_ALLREDUCE(MPI_IN_PLACE, count, max_id+1, MPI_INTEGER, MPI_SUM, this%amr%comm, ierr) - end block communicate - if (this%amr%amRoot) then - print *, "Unique IDs on level ", lvl,' ',msg - do id=0,max_id - ! if (seen(id).and.id.gt.0) then - ! print *,'rootifying on ',id - ! root = rootify_struct(id) - ! else - ! root = 0 - ! end if - if (seen(id)) print *, 'id = ',id,' count = ',count(id)!, ' root =',root - end do - end if - end subroutine print_ids - - !> This recursive function that points the lineage of a structure to its root and returns that root recursive function rootify_struct(x) result(y) implicit none From c18de59b918c2503cdeeb7aaaec8f9239f139f0b Mon Sep 17 00:00:00 2001 From: Mark Owkes Date: Thu, 18 Jun 2026 11:30:48 -0600 Subject: [PATCH 57/70] Updating input to state when testing. --- examples/amrcclabel_tester/input | 11 ++++++----- 1 file changed, 6 insertions(+), 5 deletions(-) diff --git a/examples/amrcclabel_tester/input b/examples/amrcclabel_tester/input index f683868d3..10f6b849a 100644 --- a/examples/amrcclabel_tester/input +++ b/examples/amrcclabel_tester/input @@ -2,13 +2,14 @@ Partition : 1 1 1 # Mesh definition -Base nx : 16 -Base ny : 16 -Base nz : 16 -Max level : 3 +Base nx : 8 +Base ny : 8 +Base nz : 8 +Max level : 4 # Ellipsoid properties -Droplet case : Cylinder # Random or Cylinder +# Droplet case : Cylinder +Droplet case : Random # Time integration Max timestep size : 2.5e-3 From 115b2805cf25e8db08fcc21e0ae28be406051e13 Mon Sep 17 00:00:00 2001 From: Mark Owkes Date: Thu, 18 Jun 2026 13:28:06 -0600 Subject: [PATCH 58/70] Adding reset to id for initialization after grids are setup. And more cleanup. --- src/amrbase/amrcclabel_class.f90 | 11 ++--------- 1 file changed, 2 insertions(+), 9 deletions(-) diff --git a/src/amrbase/amrcclabel_class.f90 b/src/amrbase/amrcclabel_class.f90 index 4d2c4f2ed..908c53410 100644 --- a/src/amrbase/amrcclabel_class.f90 +++ b/src/amrbase/amrcclabel_class.f90 @@ -44,8 +44,6 @@ module amrcclabel_class integer :: nover=1 ! Associated amr grid class(amrgrid), pointer, private :: amr => null() - ! Temporary arrays for interlevel sync - type(amrdata) :: tmp_id,tmp_conflict contains procedure :: initialize procedure :: build @@ -91,12 +89,7 @@ subroutine initialize(this,amr,name) ! Allocate and initialize ID array call this%id%initialize(amr,name='id',ncomp=1,ng=this%nover,interp=interp_none);! this%id%parent=>this call this%id%register() ! Update with regriding - call this%id%setval(val=0.0_WP) - ! Allocate temporary arrays for interlevel sync - call this%tmp_id%initialize(amr,name='tmp_id',ncomp=1,ng=this%nover) - call this%tmp_conflict%initialize(amr,name='tmp_conflict',ncomp=1,ng=this%nover) - call this%tmp_id%register() ! Update with regriding - call this%tmp_conflict%register() ! Update with regriding + call this%id%reset() ! Update with current grids ! Zero structures this%nstruct=0 end subroutine initialize @@ -200,7 +193,7 @@ subroutine build_lvl(lvl,make_label,same_label) end do; end do; end do end do end block previous_ids - + ! Perform a first pass to build proc-local structures and corresponding tree first_pass: block use amrex_amr_module, only: amrex_mfiter,amrex_box From c4a8c7a5f7b89ec59b5177ac61d190cbb416d0ce Mon Sep 17 00:00:00 2001 From: Mark Owkes Date: Thu, 18 Jun 2026 15:56:53 -0600 Subject: [PATCH 59/70] Set an initial id value in initialize --- src/amrbase/amrcclabel_class.f90 | 1 + 1 file changed, 1 insertion(+) diff --git a/src/amrbase/amrcclabel_class.f90 b/src/amrbase/amrcclabel_class.f90 index 908c53410..ede2ee609 100644 --- a/src/amrbase/amrcclabel_class.f90 +++ b/src/amrbase/amrcclabel_class.f90 @@ -90,6 +90,7 @@ subroutine initialize(this,amr,name) call this%id%initialize(amr,name='id',ncomp=1,ng=this%nover,interp=interp_none);! this%id%parent=>this call this%id%register() ! Update with regriding call this%id%reset() ! Update with current grids + call this%id%setval(0.0_WP) ! Zero structures this%nstruct=0 end subroutine initialize From efff07917dcbbef8ac4b6bb2bc6e5afe5c0d4d31 Mon Sep 17 00:00:00 2001 From: Mark Owkes Date: Thu, 18 Jun 2026 15:57:34 -0600 Subject: [PATCH 60/70] Working on adding CCLabel - need better way to write data --- examples/amr_ljcf/input | 1 + examples/amr_ljcf/src/simulation.f90 | 103 +++++++++++++++++++++++++++ 2 files changed, 104 insertions(+) diff --git a/examples/amr_ljcf/input b/examples/amr_ljcf/input index 51094fa3a..99f42b801 100644 --- a/examples/amr_ljcf/input +++ b/examples/amr_ljcf/input @@ -30,4 +30,5 @@ Max CFL: 0.5 # Output Output period: 0.5 Checkpoint period: 5.0 +CCLabel period: 0.1 Restart from: !restart/jet_4.50006E+01 diff --git a/examples/amr_ljcf/src/simulation.f90 b/examples/amr_ljcf/src/simulation.f90 index eed31f5b9..a6712f52e 100644 --- a/examples/amr_ljcf/src/simulation.f90 +++ b/examples/amr_ljcf/src/simulation.f90 @@ -8,6 +8,7 @@ module simulation use amrdata_class, only: amrdata use timetracker_class, only: timetracker use event_class, only: event + use amrcclabel_class, only: amrcclabel,stats_type use monitor_class, only: monitor use messager, only: log use amrio_class, only: amrio @@ -35,6 +36,11 @@ module simulation type(event) :: regrid_evt real(WP) :: Re_tag=huge(1.0_WP) + ! CCLabel + type(event) :: cclabel_evt + type(amrcclabel) :: cclabel + type(stats_type), dimension(:), allocatable :: stats + ! Monitoring type(monitor) :: mfile,cflfile,gridfile @@ -369,6 +375,82 @@ subroutine jet_init(solver,lvl,time,ba,dm) call amrex_mfiter_destroy(mfi) end subroutine jet_init + !> Function that identifies cells within a structure + logical function make_label(pVF,lo,i,j,k) + implicit none + real(WP), dimension(:,:,:,:), intent(in) :: pVF + integer, dimension(3), intent(in) :: lo + integer, intent(in) :: i,j,k + integer :: il,jl,kl + il = i - lo(1) + 1 + jl = j - lo(2) + 1 + kl = k - lo(3) + 1 + if (pVF(il,jl,kl,1).gt.0.0_WP) then + make_label=.true. + else + make_label=.false. + end if + end function make_label + + !> Function that identifies if neighbors are within the same structure + logical function same_label(pVF,lo,i,j,k,ii,jj,kk) + implicit none + real(WP), dimension(:,:,:,:), intent(in) :: pVF + integer, dimension(3), intent(in) :: lo + integer, intent(in) :: i,j,k,ii,jj,kk + integer :: il,jl,kl,iil,jjl,kkl + il = i - lo(1) + 1 + jl = j - lo(2) + 1 + kl = k - lo(3) + 1 + iil = ii - lo(1) + 1 + jjl = jj - lo(2) + 1 + kkl = kk - lo(3) + 1 + if (pVF(il,jl,kl,1).gt.0.0_WP .and. pVF(iil,jjl,kkl,1).gt.0.0_WP) then + same_label=.true. + else + same_label=.false. + end if + end function same_label + + !> Function that identifies cells within a structure on coarse level + logical function coarse_make_label(pVF,lo,i,j,k) + use amrmpinc_class, only: VFhi + implicit none + real(WP), dimension(:,:,:,:), intent(in) :: pVF + integer, dimension(3), intent(in) :: lo + integer, intent(in) :: i,j,k + integer :: il,jl,kl + il = i - lo(1) + 1 + jl = j - lo(2) + 1 + kl = k - lo(3) + 1 + if (pVF(il,jl,kl,1).gt.VFhi) then + coarse_make_label=.true. + else + coarse_make_label=.false. + end if + end function coarse_make_label + + !> Function that identifies if neighbors are within the same structure on coarse level + logical function coarse_same_label(pVF,lo,i,j,k,ii,jj,kk) + use amrmpinc_class, only: VFhi + implicit none + real(WP), dimension(:,:,:,:), intent(in) :: pVF + integer, dimension(3), intent(in) :: lo + integer, intent(in) :: i,j,k,ii,jj,kk + integer :: il,jl,kl,iil,jjl,kkl + il = i - lo(1) + 1 + jl = j - lo(2) + 1 + kl = k - lo(3) + 1 + iil = ii - lo(1) + 1 + jjl = jj - lo(2) + 1 + kkl = kk - lo(3) + 1 + if (pVF(il,jl,kl,1).gt.VFhi .and. pVF(iil,jjl,kkl,1).gt.VFhi) then + coarse_same_label=.true. + else + coarse_same_label=.false. + end if + end function coarse_same_label + !> Initialization hook subroutine simulation_init() use param, only: param_read @@ -520,6 +602,12 @@ subroutine simulation_init() call io%add_scalar(name='dt',value=time%dt) end block init_checkpoint + ! Initialize CClabel + cclabel_evt=event(time=time,name="CCLabel output") + call param_read('CCLabel period',cclabel_evt%tper) + call cclabel%initialize(amr,name='amr_ljcf') + call cclabel%build(make_label,same_label,coarse_make_label,coarse_same_label,fs%VF) + ! Initialize visualization create_visualization: block ! Create visualization object @@ -531,6 +619,7 @@ subroutine simulation_init() call viz%add_scalar(fs%visc,1,'visc') call viz%add_scalar(fs%P,1,'pressure') call viz%add_scalar(fs%VF,1,'VF') + call viz%add_scalar(cclabel%id,1,'ID') call viz%add_surfmesh(fs%smesh,'plic') ! Create visualization output event viz_evt=event(time=time,name='Visualization output') @@ -675,6 +764,20 @@ subroutine simulation_run() ! Compute Umag call Umag%get_magnitude(srcX=fs%Q,srcY=fs%Q,srcZ=fs%Q,compX=1,compY=2,compZ=3) + ! Construct CCLabel and compute stats + if (cclabel_evt%occurs()) then + call cclabel%build(make_label,same_label,coarse_make_label,coarse_same_label,fs%VF) + call cclabel%compute_stats(fs%VF,stats) + print_stats: block + integer :: n + if (amr%amRoot) then + do n=1,cclabel%nstruct + print *, "id=",n," vol=",stats(n)%vol," com=",stats(n)%com + end do + end if + end block print_stats + end if + ! Monitor output call fs%get_info() call mfile%write() From adb90a53c62f65ed9121cf6ef6664aad030c2836 Mon Sep 17 00:00:00 2001 From: Mark Owkes Date: Thu, 18 Jun 2026 16:23:50 -0600 Subject: [PATCH 61/70] Added structure stats monitor files to amr_ljcf case --- examples/amr_ljcf/src/simulation.f90 | 24 ++++++++++++++++++++++++ 1 file changed, 24 insertions(+) diff --git a/examples/amr_ljcf/src/simulation.f90 b/examples/amr_ljcf/src/simulation.f90 index a6712f52e..75618bc18 100644 --- a/examples/amr_ljcf/src/simulation.f90 +++ b/examples/amr_ljcf/src/simulation.f90 @@ -40,6 +40,7 @@ module simulation type(event) :: cclabel_evt type(amrcclabel) :: cclabel type(stats_type), dimension(:), allocatable :: stats + type(monitor) :: cclabel_file ! Monitoring type(monitor) :: mfile,cflfile,gridfile @@ -776,6 +777,29 @@ subroutine simulation_run() end do end if end block print_stats + + write_stats: block + use monitor_class, only: iformat,rformat + use string, only: str_medium + character(len=str_medium) :: filename,struct_name + integer :: n + ! Create a file to write Weber numbers + write(filename, rformat) time%t + filename = 'structStats_'//trim(adjustl(filename)) + cclabel_file=monitor(fs%amr%amRoot,filename) + ! Add columns to the file + do n=1,cclabel%nstruct + call cclabel_file%add_column(n,'Structure ID') + call cclabel_file%add_column(stats(n)%vol,'Drop Volume') + call cclabel_file%add_column(stats(n)%com(1),'X Drop Pos') + call cclabel_file%add_column(stats(n)%com(2),'Y Drop Pos') + call cclabel_file%add_column(stats(n)%com(3),'Z Drop Pos') + ! Write the data for this structure + call cclabel_file%write() + end do + ! Close file + call cclabel_file%close() + end block write_stats end if ! Monitor output From d7c1541838005c3e0046b8525f5d94400d4c6d90 Mon Sep 17 00:00:00 2001 From: Mark Owkes Date: Thu, 18 Jun 2026 17:05:51 -0600 Subject: [PATCH 62/70] Updated compute_stats to include more droplet stats and added write_stats to amr_ljcf example that writes stats to monitor files. --- examples/amr_ljcf/src/simulation.f90 | 33 ++- src/amrbase/amrcclabel_class.f90 | 327 +++++++++++++++++++++------ 2 files changed, 288 insertions(+), 72 deletions(-) diff --git a/examples/amr_ljcf/src/simulation.f90 b/examples/amr_ljcf/src/simulation.f90 index 75618bc18..f145c3bab 100644 --- a/examples/amr_ljcf/src/simulation.f90 +++ b/examples/amr_ljcf/src/simulation.f90 @@ -768,7 +768,7 @@ subroutine simulation_run() ! Construct CCLabel and compute stats if (cclabel_evt%occurs()) then call cclabel%build(make_label,same_label,coarse_make_label,coarse_same_label,fs%VF) - call cclabel%compute_stats(fs%VF,stats) + call cclabel%compute_stats(fs%VF, fs%Q, fs%rhoG, fs%sigma, stats) print_stats: block integer :: n if (amr%amRoot) then @@ -782,19 +782,36 @@ subroutine simulation_run() use monitor_class, only: iformat,rformat use string, only: str_medium character(len=str_medium) :: filename,struct_name + type(stats_type) :: buf ! single-structure buffer monitor points into integer :: n ! Create a file to write Weber numbers write(filename, rformat) time%t filename = 'structStats_'//trim(adjustl(filename)) cclabel_file=monitor(fs%amr%amRoot,filename) - ! Add columns to the file + + ! Register columns with buffer + call cclabel_file%add_column(buf%id, 'Structure ID') + call cclabel_file%add_column(buf%vol, 'Drop Volume') + call cclabel_file%add_column(buf%Deq, 'Equiv Diameter') + call cclabel_file%add_column(buf%com(1), 'X Drop Pos') + call cclabel_file%add_column(buf%com(2), 'Y Drop Pos') + call cclabel_file%add_column(buf%com(3), 'Z Drop Pos') + call cclabel_file%add_column(buf%vel(1), 'X Drop Vel') + call cclabel_file%add_column(buf%vel(2), 'Y Drop Vel') + call cclabel_file%add_column(buf%vel(3), 'Z Drop Vel') + call cclabel_file%add_column(buf%gvel(1), 'X Gas Vel') + call cclabel_file%add_column(buf%gvel(2), 'Y Gas Vel') + call cclabel_file%add_column(buf%gvel(3), 'Z Gas Vel') + call cclabel_file%add_column(buf%moi(1,1),'Ixx') + call cclabel_file%add_column(buf%moi(2,2),'Iyy') + call cclabel_file%add_column(buf%moi(3,3),'Izz') + call cclabel_file%add_column(buf%moi(1,2),'Ixy') + call cclabel_file%add_column(buf%moi(1,3),'Ixz') + call cclabel_file%add_column(buf%moi(2,3),'Iyz') + call cclabel_file%add_column(buf%weber, 'Weber') do n=1,cclabel%nstruct - call cclabel_file%add_column(n,'Structure ID') - call cclabel_file%add_column(stats(n)%vol,'Drop Volume') - call cclabel_file%add_column(stats(n)%com(1),'X Drop Pos') - call cclabel_file%add_column(stats(n)%com(2),'Y Drop Pos') - call cclabel_file%add_column(stats(n)%com(3),'Z Drop Pos') - ! Write the data for this structure + ! Set buffer and write the data for this structure + buf = stats(n) call cclabel_file%write() end do ! Close file diff --git a/src/amrbase/amrcclabel_class.f90 b/src/amrbase/amrcclabel_class.f90 index ede2ee609..7f69ea2d2 100644 --- a/src/amrbase/amrcclabel_class.f90 +++ b/src/amrbase/amrcclabel_class.f90 @@ -27,10 +27,16 @@ module amrcclabel_class !> Statistics object type :: stats_type - integer :: id !< ID of structure - real(WP) :: vol !< Volme of structure - real(WP), dimension(3) :: com !< Center of mass of structure - end type stats_type + integer :: id ! Structure ID + real(WP) :: vol ! Liquid volume + real(WP) :: com(3) ! Center of mass + real(WP) :: vel(3) ! Volume-weighted liquid velocity + real(WP) :: moi(3,3) ! Moment of inertia tensor + real(WP) :: Deq ! Equivalent sphere diameter + real(WP) :: gvel(3) ! Volume-weighted surrounding gas velocity + real(WP) :: weber ! Weber number + logical :: remove ! .true. if structure touches domain boundary +end type stats_type !> amrcclabel object definition type :: amrcclabel @@ -794,128 +800,321 @@ end subroutine empty !> Compute common statistics for structures - !> identified by id in this%id and weighted by VF array - subroutine compute_stats(this,VF,stats) + !> identified by id in this%id + subroutine compute_stats(this, VF, Q, rhoG, sigma, stats) use amrex_fort_module, only : amrex_spacedim use amrex_multifab_module, only : amrex_multifab, amrex_mfiter, & - amrex_mfiter_build, amrex_mfiter_destroy + amrex_mfiter_build, amrex_mfiter_destroy use amrex_box_module, only : amrex_box use amrex_boxarray_module, only : amrex_boxarray, amrex_boxarray_build, amrex_boxarray_destroy - use amrex_geometry_module, only : amrex_geometry - use amrex_box_module, only : amrex_box - use amrex_amr_module, only : amrex_long use amrex_parallel_module, only : amrex_parallel_reduce_sum + use amrex_amr_module, only : amrex_long + use mathtools, only : pi implicit none class(amrcclabel) :: this - type(amrdata), intent(in) :: VF + type(amrdata), intent(in) :: VF ! Volume fraction + type(amrdata), intent(in) :: Q ! Cell-centred velocity (3 components) + real(WP), intent(in) :: rhoG ! Gas density + real(WP), intent(in) :: sigma ! Surface tension coefficient type(stats_type), allocatable, dimension(:), intent(out) :: stats - real(WP), allocatable, dimension(:) :: vol_map - real(WP), allocatable, dimension(:,:) :: com_map + + ! Accumulator arrays + real(WP), allocatable :: vol_map(:) ! (nstruct) + real(WP), allocatable :: com_map(:,:) ! (nstruct, 3) + real(WP), allocatable :: vel_map(:,:) ! (nstruct, 3) liquid velocity + real(WP), allocatable :: moi_map(:,:,:) ! (nstruct, 3, 3) + real(WP), allocatable :: gvel_map(:,:) ! (nstruct, 3) gas velocity + real(WP), allocatable :: gwt_map(:) ! (nstruct) gas velocity weights + real(WP), allocatable :: rem_map(:) ! (nstruct) boundary flag (real for MPI reduce) + type(amrex_mfiter) :: mfi - type(amrex_box) :: bx + type(amrex_box) :: bx, pt_box type(amrex_boxarray) :: fine_ba_crse - type(amrex_box) :: pt_box - real(WP), dimension(:,:,:,:), contiguous, pointer :: pid,pVF + + real(WP), pointer, contiguous :: pid(:,:,:,:), pVF(:,:,:,:), pQ(:,:,:,:) real(WP) :: dx(3), cell_vol, prob_lo(3) - real(WP) :: xc, yc, zc + real(WP) :: xc, yc, zc, VF_val + real(WP) :: xr, yr, zr, x0, y0, z0 + real(WP) :: slip_vel, Deq integer :: lo(3), hi(3), ilo(3), ihi(3) - integer :: i, j, k, lvl, id_val - real(WP) :: VF_val - integer(amrex_long) :: nb, n + integer :: i, j, k, lvl, id_val, ns + integer :: ratio(3) + integer, parameter :: nlayer = 2 ! cells near domain face to flag + integer(amrex_long) :: nb, nn integer, allocatable :: bxs(:,:,:) - integer :: ratio(3) - allocate(vol_map(1:this%nstruct)) - allocate(com_map(1:this%nstruct,3)) + allocate(vol_map (this%nstruct)); vol_map = 0.0_WP + allocate(com_map (this%nstruct, 3)); com_map = 0.0_WP + allocate(vel_map (this%nstruct, 3)); vel_map = 0.0_WP + allocate(moi_map (this%nstruct, 3, 3)); moi_map = 0.0_WP + allocate(gvel_map(this%nstruct, 3)); gvel_map = 0.0_WP + allocate(gwt_map (this%nstruct)); gwt_map = 0.0_WP + allocate(rem_map (this%nstruct)); rem_map = 0.0_WP - vol_map = 0.0_WP - com_map = 0.0_WP prob_lo = [this%amr%xlo, this%amr%ylo, this%amr%zlo] - do lvl = 0, this%amr%maxlvl + ! ========================================================================= + ! PASS 1: volume, CoM, liquid velocity, boundary removal flag + ! ========================================================================= + do lvl = 0, this%amr%clvl() dx(1) = this%amr%dx(lvl) dx(2) = this%amr%dy(lvl) dx(3) = this%amr%dz(lvl) cell_vol = this%amr%cell_vol(lvl) - if (lvl < this%amr%maxlvl) then - ratio = [this%amr%rrefx(lvl), this%amr%rrefy(lvl), this%amr%rrefz(lvl)] - nb = this%id%mf(lvl+1)%ba%nboxes() - allocate(bxs(2, 3, nb)) - do n = 1, nb - bx = this%id%mf(lvl+1)%ba%get_box(int(n-1)) - bxs(1,:,n) = bx%lo / ratio - bxs(2,:,n) = bx%hi / ratio - end do - call amrex_boxarray_build(fine_ba_crse, bxs) - deallocate(bxs) + if (lvl < this%amr%clvl()) then + ratio = [this%amr%rrefx(lvl), this%amr%rrefy(lvl), this%amr%rrefz(lvl)] + nb = this%id%mf(lvl+1)%ba%nboxes() + allocate(bxs(2, 3, nb)) + do nn = 1, nb + bx = this%id%mf(lvl+1)%ba%get_box(int(nn-1)) + bxs(1,:,nn) = bx%lo / ratio + bxs(2,:,nn) = bx%hi / ratio + end do + call amrex_boxarray_build(fine_ba_crse, bxs) + deallocate(bxs) end if - call this%amr%mfiter_build(lvl,mfi) + call this%amr%mfiter_build(lvl, mfi) do while (mfi%next()) - ! Get pointers to data arrays - pid => this%id%mf(lvl)%dataptr(mfi) + pid => this%id%mf(lvl)%dataptr(mfi) pVF => VF%mf(lvl)%dataptr(mfi) + pQ => Q%mf(lvl)%dataptr(mfi) bx = mfi%validbox() - lo = bx%lo - hi = bx%hi - - ilo = [lbound(pid,1), lbound(pid,2), lbound(pid,3)] - ihi = [ubound(pid,1), ubound(pid,2), ubound(pid,3)] + lo = bx%lo; hi = bx%hi - accumulate_stats: block + pass1: block do k = lo(3), hi(3) do j = lo(2), hi(2) do i = lo(1), hi(1) id_val = nint(pid(i,j,k,1)) VF_val = pVF(i,j,k,1) - if (id_val <= 0) cycle + if (id_val <= 0 .or. id_val > this%nstruct) cycle - if (lvl < this%amr%maxlvl) then - pt_box%lo = [i, j, k] - pt_box%hi = [i, j, k] - if (fine_ba_crse%intersects(pt_box)) cycle + if (lvl < this%amr%clvl()) then + pt_box%lo = [i,j,k]; pt_box%hi = [i,j,k] + if (fine_ba_crse%intersects(pt_box)) cycle end if xc = prob_lo(1) + (real(i, WP) + 0.5_WP) * dx(1) yc = prob_lo(2) + (real(j, WP) + 0.5_WP) * dx(2) zc = prob_lo(3) + (real(k, WP) + 0.5_WP) * dx(3) - vol_map(id_val ) = vol_map(id_val ) + cell_vol * VF_val + vol_map(id_val) = vol_map(id_val) + cell_vol * VF_val com_map(id_val,1) = com_map(id_val,1) + cell_vol * VF_val * xc com_map(id_val,2) = com_map(id_val,2) + cell_vol * VF_val * yc com_map(id_val,3) = com_map(id_val,3) + cell_vol * VF_val * zc - + vel_map(id_val,1) = vel_map(id_val,1) + cell_vol * VF_val * pQ(i,j,k,1) + vel_map(id_val,2) = vel_map(id_val,2) + cell_vol * VF_val * pQ(i,j,k,2) + vel_map(id_val,3) = vel_map(id_val,3) + cell_vol * VF_val * pQ(i,j,k,3) + + ! Flag if within nlayer cells of any domain face + if (xc < this%amr%xlo + nlayer*dx(1) .or. & + xc > this%amr%xhi - nlayer*dx(1) .or. & + yc < this%amr%ylo + nlayer*dx(2) .or. & + yc > this%amr%yhi - nlayer*dx(2) .or. & + zc < this%amr%zlo + nlayer*dx(3) .or. & + zc > this%amr%zhi - nlayer*dx(3)) then + rem_map(id_val) = 1.0_WP + end if end do end do end do - end block accumulate_stats + end block pass1 - nullify(pid) - nullify(pVF) + nullify(pid, pVF, pQ) end do call amrex_mfiter_destroy(mfi) - if (lvl < this%amr%maxlvl) call amrex_boxarray_destroy(fine_ba_crse) - + if (lvl < this%amr%clvl()) call amrex_boxarray_destroy(fine_ba_crse) end do - call amrex_parallel_reduce_sum(vol_map, this%nstruct) + ! Reduce pass 1 + call amrex_parallel_reduce_sum(vol_map, this%nstruct) call amrex_parallel_reduce_sum(com_map(:,1), this%nstruct) call amrex_parallel_reduce_sum(com_map(:,2), this%nstruct) call amrex_parallel_reduce_sum(com_map(:,3), this%nstruct) + call amrex_parallel_reduce_sum(vel_map(:,1), this%nstruct) + call amrex_parallel_reduce_sum(vel_map(:,2), this%nstruct) + call amrex_parallel_reduce_sum(vel_map(:,3), this%nstruct) + call amrex_parallel_reduce_sum(rem_map, this%nstruct) + + ! Normalize CoM and velocity + do ns = 1, this%nstruct + if (vol_map(ns) > 0.0_WP) then + com_map(ns,:) = com_map(ns,:) / vol_map(ns) + vel_map(ns,:) = vel_map(ns,:) / vol_map(ns) + end if + end do + ! ========================================================================= + ! PASS 2: moment of inertia + surrounding gas velocity + ! Ghost cells on id%mf are filled by sync() at end of build(), + ! so neighbor IDs are visible across FAB boundaries. + ! ========================================================================= + do lvl = 0, this%amr%clvl() + + dx(1) = this%amr%dx(lvl) + dx(2) = this%amr%dy(lvl) + dx(3) = this%amr%dz(lvl) + cell_vol = this%amr%cell_vol(lvl) + + if (lvl < this%amr%clvl()) then + ratio = [this%amr%rrefx(lvl), this%amr%rrefy(lvl), this%amr%rrefz(lvl)] + nb = this%id%mf(lvl+1)%ba%nboxes() + allocate(bxs(2, 3, nb)) + do nn = 1, nb + bx = this%id%mf(lvl+1)%ba%get_box(int(nn-1)) + bxs(1,:,nn) = bx%lo / ratio + bxs(2,:,nn) = bx%hi / ratio + end do + call amrex_boxarray_build(fine_ba_crse, bxs) + deallocate(bxs) + end if + + call this%amr%mfiter_build(lvl, mfi) + do while (mfi%next()) + pid => this%id%mf(lvl)%dataptr(mfi) + pVF => VF%mf(lvl)%dataptr(mfi) + pQ => Q%mf(lvl)%dataptr(mfi) + bx = mfi%validbox() + lo = bx%lo; hi = bx%hi + ilo = [lbound(pid,1), lbound(pid,2), lbound(pid,3)] + ihi = [ubound(pid,1), ubound(pid,2), ubound(pid,3)] + + pass2: block + real(WP) :: id_arr(ilo(1):ihi(1), ilo(2):ihi(2), ilo(3):ihi(3)) + integer :: unique_ids(6), n_unique, d, nbid, ii, jj, kk + integer, dimension(3,6) :: off + + ! Copy with correct AMReX bounds so neighbor lookup works + id_arr = pid(:,:,:,1) + + off(:,1)=[1,0,0]; off(:,2)=[-1,0,0] + off(:,3)=[0,1,0]; off(:,4)=[0,-1,0] + off(:,5)=[0,0,1]; off(:,6)=[0,0,-1] + + do k = lo(3), hi(3) + do j = lo(2), hi(2) + do i = lo(1), hi(1) + id_val = nint(id_arr(i,j,k)) + VF_val = pVF(i,j,k,1) + + if (lvl < this%amr%clvl()) then + pt_box%lo = [i,j,k]; pt_box%hi = [i,j,k] + if (fine_ba_crse%intersects(pt_box)) cycle + end if + + xc = prob_lo(1) + (real(i, WP) + 0.5_WP) * dx(1) + yc = prob_lo(2) + (real(j, WP) + 0.5_WP) * dx(2) + zc = prob_lo(3) + (real(k, WP) + 0.5_WP) * dx(3) + + ! --- Moment of inertia for liquid cells --- + if (id_val > 0 .and. id_val <= this%nstruct) then + x0 = com_map(id_val,1); xr = xc - x0 + y0 = com_map(id_val,2); yr = yc - y0 + z0 = com_map(id_val,3); zr = zc - z0 + moi_map(id_val,1,1) = moi_map(id_val,1,1) + cell_vol*VF_val*(yr**2+zr**2) + moi_map(id_val,2,2) = moi_map(id_val,2,2) + cell_vol*VF_val*(zr**2+xr**2) + moi_map(id_val,3,3) = moi_map(id_val,3,3) + cell_vol*VF_val*(xr**2+yr**2) + moi_map(id_val,1,2) = moi_map(id_val,1,2) - cell_vol*VF_val*(xr*yr) + moi_map(id_val,1,3) = moi_map(id_val,1,3) - cell_vol*VF_val*(xr*zr) + moi_map(id_val,2,3) = moi_map(id_val,2,3) - cell_vol*VF_val*(yr*zr) + end if + + ! --- Gas velocity: accumulate gas cell adjacent to structures --- + ! Ghost-cell-filled id_arr lets us see neighbor IDs across FABs. + ! Collect unique structure IDs from 6-connected neighbors to avoid + ! double-counting a gas cell that touches multiple cells of the + ! same structure. + if (VF_val < 0.5_WP) then + unique_ids = 0; n_unique = 0 + do d = 1, 6 + ii = i + off(1,d) + jj = j + off(2,d) + kk = k + off(3,d) + if (ii < ilo(1) .or. ii > ihi(1) .or. & + jj < ilo(2) .or. jj > ihi(2) .or. & + kk < ilo(3) .or. kk > ihi(3)) cycle + nbid = nint(id_arr(ii,jj,kk)) + if (nbid <= 0 .or. nbid > this%nstruct) cycle + if (any(unique_ids(1:n_unique) == nbid)) cycle + n_unique = n_unique + 1 + unique_ids(n_unique) = nbid + end do + do d = 1, n_unique + nbid = unique_ids(d) + gvel_map(nbid,1) = gvel_map(nbid,1) + cell_vol*(1.0_WP-VF_val)*pQ(i,j,k,1) + gvel_map(nbid,2) = gvel_map(nbid,2) + cell_vol*(1.0_WP-VF_val)*pQ(i,j,k,2) + gvel_map(nbid,3) = gvel_map(nbid,3) + cell_vol*(1.0_WP-VF_val)*pQ(i,j,k,3) + gwt_map(nbid) = gwt_map(nbid) + cell_vol*(1.0_WP-VF_val) + end do + end if + + end do + end do + end do + end block pass2 + + nullify(pid, pVF, pQ) + end do + call amrex_mfiter_destroy(mfi) + + if (lvl < this%amr%clvl()) call amrex_boxarray_destroy(fine_ba_crse) + end do + + ! Reduce pass 2 + call amrex_parallel_reduce_sum(moi_map(:,1,1), this%nstruct) + call amrex_parallel_reduce_sum(moi_map(:,2,2), this%nstruct) + call amrex_parallel_reduce_sum(moi_map(:,3,3), this%nstruct) + call amrex_parallel_reduce_sum(moi_map(:,1,2), this%nstruct) + call amrex_parallel_reduce_sum(moi_map(:,1,3), this%nstruct) + call amrex_parallel_reduce_sum(moi_map(:,2,3), this%nstruct) + call amrex_parallel_reduce_sum(gvel_map(:,1), this%nstruct) + call amrex_parallel_reduce_sum(gvel_map(:,2), this%nstruct) + call amrex_parallel_reduce_sum(gvel_map(:,3), this%nstruct) + call amrex_parallel_reduce_sum(gwt_map, this%nstruct) + + ! ========================================================================= + ! Pack results + ! ========================================================================= allocate(stats(this%nstruct)) - do i = 1, this%nstruct - stats(i)%id = i - stats(i)%vol = vol_map(i) - stats(i)%com = com_map(i,:)/vol_map(i) + do ns = 1, this%nstruct + stats(ns)%id = ns + stats(ns)%vol = vol_map(ns) + stats(ns)%com = com_map(ns,:) + stats(ns)%vel = vel_map(ns,:) + stats(ns)%remove = (rem_map(ns) > 0.0_WP) + + ! Fill symmetric off-diagonal components + stats(ns)%moi = moi_map(ns,:,:) + stats(ns)%moi(2,1) = moi_map(ns,1,2) + stats(ns)%moi(3,1) = moi_map(ns,1,3) + stats(ns)%moi(3,2) = moi_map(ns,2,3) + + ! Equivalent diameter from liquid volume + Deq = ((vol_map(ns) * 6.0_WP) / pi)**(1.0_WP/3.0_WP) + stats(ns)%Deq = Deq + + ! Surrounding gas velocity + if (gwt_map(ns) > 0.0_WP) then + stats(ns)%gvel = gvel_map(ns,:) / gwt_map(ns) + else + stats(ns)%gvel = 0.0_WP + end if + + ! Weber number: rhoG * |slip|^2 * Deq / sigma + slip_vel = sqrt(sum((stats(ns)%gvel - stats(ns)%vel)**2)) + if (sigma > 0.0_WP) then + stats(ns)%weber = rhoG * slip_vel**2 * Deq / sigma + else + stats(ns)%weber = 0.0_WP + end if end do end subroutine compute_stats - !> Finalize CCL object subroutine finalize(this) implicit none From a8b360c8e5bc545ba6af2b2489d169238c67dd39 Mon Sep 17 00:00:00 2001 From: Mark Owkes Date: Thu, 18 Jun 2026 17:15:49 -0600 Subject: [PATCH 63/70] Removed print since write is working --- examples/amr_ljcf/src/simulation.f90 | 10 +--------- 1 file changed, 1 insertion(+), 9 deletions(-) diff --git a/examples/amr_ljcf/src/simulation.f90 b/examples/amr_ljcf/src/simulation.f90 index f145c3bab..e4ae772de 100644 --- a/examples/amr_ljcf/src/simulation.f90 +++ b/examples/amr_ljcf/src/simulation.f90 @@ -765,18 +765,10 @@ subroutine simulation_run() ! Compute Umag call Umag%get_magnitude(srcX=fs%Q,srcY=fs%Q,srcZ=fs%Q,compX=1,compY=2,compZ=3) - ! Construct CCLabel and compute stats + ! Construct CCLabel then compute & write stats if (cclabel_evt%occurs()) then call cclabel%build(make_label,same_label,coarse_make_label,coarse_same_label,fs%VF) call cclabel%compute_stats(fs%VF, fs%Q, fs%rhoG, fs%sigma, stats) - print_stats: block - integer :: n - if (amr%amRoot) then - do n=1,cclabel%nstruct - print *, "id=",n," vol=",stats(n)%vol," com=",stats(n)%com - end do - end if - end block print_stats write_stats: block use monitor_class, only: iformat,rformat From dbc479930eff50c0d8b38e529ef5b2746b70b679 Mon Sep 17 00:00:00 2001 From: Mark Owkes Date: Thu, 18 Jun 2026 20:35:55 -0600 Subject: [PATCH 64/70] Fixed bug if nstruct_ is larger than id. --- src/amrbase/amrcclabel_class.f90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/amrbase/amrcclabel_class.f90 b/src/amrbase/amrcclabel_class.f90 index 7f69ea2d2..2f22ed42f 100644 --- a/src/amrbase/amrcclabel_class.f90 +++ b/src/amrbase/amrcclabel_class.f90 @@ -588,7 +588,7 @@ subroutine add_existing(id) ! Check if there is enough room for storing a new structure size_now=size(this%struct,dim=1) if (id.gt.size_now) then - size_new=id + size_new = max(id, nstruct_, nint(real(size_now,WP)*coeff_up)) allocate(tmp(size_new)) tmp(1:nstruct_)=this%struct tmp(nstruct_+1:)%parent=0 From 63d98f5731cb034fefb0f54e537d2c0184694564 Mon Sep 17 00:00:00 2001 From: Mark Owkes Date: Thu, 18 Jun 2026 20:41:50 -0600 Subject: [PATCH 65/70] Fixed deeper issue with add_exisiting when there are a lot of exisiting structures. --- src/amrbase/amrcclabel_class.f90 | 16 +++++++--------- 1 file changed, 7 insertions(+), 9 deletions(-) diff --git a/src/amrbase/amrcclabel_class.f90 b/src/amrbase/amrcclabel_class.f90 index 2f22ed42f..8ee5e1744 100644 --- a/src/amrbase/amrcclabel_class.f90 +++ b/src/amrbase/amrcclabel_class.f90 @@ -585,20 +585,18 @@ subroutine add_existing(id) integer, intent(in) :: id integer :: size_now,size_new type(struct_type), dimension(:), allocatable :: tmp - ! Check if there is enough room for storing a new structure size_now=size(this%struct,dim=1) if (id.gt.size_now) then - size_new = max(id, nstruct_, nint(real(size_now,WP)*coeff_up)) + size_new=max(id, nstruct_, nint(real(size_now,WP)*coeff_up)) allocate(tmp(size_new)) - tmp(1:nstruct_)=this%struct - tmp(nstruct_+1:)%parent=0 - tmp(nstruct_+1:)%per(1)=0 - tmp(nstruct_+1:)%per(2)=0 - tmp(nstruct_+1:)%per(3)=0 - tmp(nstruct_+1:)%n_=0 + tmp(1:size_now)=this%struct ! copy only what actually exists + tmp(size_now+1:)%parent=0 ! zero-init everything beyond that + tmp(size_now+1:)%per(1)=0 + tmp(size_now+1:)%per(2)=0 + tmp(size_now+1:)%per(3)=0 + tmp(size_now+1:)%n_=0 call move_alloc(tmp,this%struct) end if - ! Add new root if doesn't already exist if (this%struct(id)%parent.ne.id) then nstruct_=nstruct_+1 this%struct(id)%parent=id From a1a6e841955991e1bc1798ce1892f5741d5a6e7f Mon Sep 17 00:00:00 2001 From: Mark Owkes Date: Thu, 18 Jun 2026 20:59:52 -0600 Subject: [PATCH 66/70] Fixed amrcclabel_tester with new compute_stats routine --- examples/amrcclabel_tester/src/simulation.f90 | 12 +++++++++++- 1 file changed, 11 insertions(+), 1 deletion(-) diff --git a/examples/amrcclabel_tester/src/simulation.f90 b/examples/amrcclabel_tester/src/simulation.f90 index ddd758700..649ad610b 100644 --- a/examples/amrcclabel_tester/src/simulation.f90 +++ b/examples/amrcclabel_tester/src/simulation.f90 @@ -313,7 +313,17 @@ subroutine simulation_run call cclabel%build(make_label,same_label,coarse_make_label,coarse_same_label,vof%VF) ! Compute structure statistics - call cclabel%compute_stats(vof%VF,stats) + compute_stats: block + type(amrdata) :: Q + real(WP) :: rhoG = 1.0_WP + real(WP) :: sigma = 1.0_WP + call Q%initialize(amr,name='Q',ncomp=3,ng=vof%nover);! this%id%parent=>this + call Q%register() ! Update with regriding + call Q%reset() ! Update with current grids + call Q%setval(0.0_WP) + + call cclabel%compute_stats(vof%VF,Q,rhoG,sigma, stats) + end block compute_stats print_stats: block integer :: n From 2df745d9232a022cdf60931f5369cafeb578e46b Mon Sep 17 00:00:00 2001 From: Mark Owkes Date: Thu, 18 Jun 2026 21:02:02 -0600 Subject: [PATCH 67/70] write cclabel stats in init. --- examples/amr_ljcf/src/simulation.f90 | 85 +++++++++++++++------------- 1 file changed, 45 insertions(+), 40 deletions(-) diff --git a/examples/amr_ljcf/src/simulation.f90 b/examples/amr_ljcf/src/simulation.f90 index e4ae772de..d8fe6f343 100644 --- a/examples/amr_ljcf/src/simulation.f90 +++ b/examples/amr_ljcf/src/simulation.f90 @@ -452,6 +452,48 @@ logical function coarse_same_label(pVF,lo,i,j,k,ii,jj,kk) end if end function coarse_same_label + !> Write droplet statistics to monitor files + subroutine write_stats() + use monitor_class, only: iformat,rformat + use string, only: str_medium + implicit none + character(len=str_medium) :: filename,struct_name + type(stats_type) :: buf ! single-structure buffer monitor points into + integer :: n + ! Create a file to write Weber numbers + write(filename, rformat) time%t + filename = 'structStats_'//trim(adjustl(filename)) + cclabel_file=monitor(fs%amr%amRoot,filename) + + ! Register columns with buffer + call cclabel_file%add_column(buf%id, 'Structure ID') + call cclabel_file%add_column(buf%vol, 'Drop Volume') + call cclabel_file%add_column(buf%Deq, 'Equiv Diameter') + call cclabel_file%add_column(buf%com(1), 'X Drop Pos') + call cclabel_file%add_column(buf%com(2), 'Y Drop Pos') + call cclabel_file%add_column(buf%com(3), 'Z Drop Pos') + call cclabel_file%add_column(buf%vel(1), 'X Drop Vel') + call cclabel_file%add_column(buf%vel(2), 'Y Drop Vel') + call cclabel_file%add_column(buf%vel(3), 'Z Drop Vel') + call cclabel_file%add_column(buf%gvel(1), 'X Gas Vel') + call cclabel_file%add_column(buf%gvel(2), 'Y Gas Vel') + call cclabel_file%add_column(buf%gvel(3), 'Z Gas Vel') + call cclabel_file%add_column(buf%moi(1,1),'Ixx') + call cclabel_file%add_column(buf%moi(2,2),'Iyy') + call cclabel_file%add_column(buf%moi(3,3),'Izz') + call cclabel_file%add_column(buf%moi(1,2),'Ixy') + call cclabel_file%add_column(buf%moi(1,3),'Ixz') + call cclabel_file%add_column(buf%moi(2,3),'Iyz') + call cclabel_file%add_column(buf%weber, 'Weber') + do n=1,cclabel%nstruct + ! Set buffer and write the data for this structure + buf = stats(n) + call cclabel_file%write() + end do + ! Close file + call cclabel_file%close() + end subroutine write_stats + !> Initialization hook subroutine simulation_init() use param, only: param_read @@ -608,6 +650,8 @@ subroutine simulation_init() call param_read('CCLabel period',cclabel_evt%tper) call cclabel%initialize(amr,name='amr_ljcf') call cclabel%build(make_label,same_label,coarse_make_label,coarse_same_label,fs%VF) + call cclabel%compute_stats(fs%VF, fs%Q, fs%rhoG, fs%sigma, stats) + call write_stats() ! Initialize visualization create_visualization: block @@ -769,46 +813,7 @@ subroutine simulation_run() if (cclabel_evt%occurs()) then call cclabel%build(make_label,same_label,coarse_make_label,coarse_same_label,fs%VF) call cclabel%compute_stats(fs%VF, fs%Q, fs%rhoG, fs%sigma, stats) - - write_stats: block - use monitor_class, only: iformat,rformat - use string, only: str_medium - character(len=str_medium) :: filename,struct_name - type(stats_type) :: buf ! single-structure buffer monitor points into - integer :: n - ! Create a file to write Weber numbers - write(filename, rformat) time%t - filename = 'structStats_'//trim(adjustl(filename)) - cclabel_file=monitor(fs%amr%amRoot,filename) - - ! Register columns with buffer - call cclabel_file%add_column(buf%id, 'Structure ID') - call cclabel_file%add_column(buf%vol, 'Drop Volume') - call cclabel_file%add_column(buf%Deq, 'Equiv Diameter') - call cclabel_file%add_column(buf%com(1), 'X Drop Pos') - call cclabel_file%add_column(buf%com(2), 'Y Drop Pos') - call cclabel_file%add_column(buf%com(3), 'Z Drop Pos') - call cclabel_file%add_column(buf%vel(1), 'X Drop Vel') - call cclabel_file%add_column(buf%vel(2), 'Y Drop Vel') - call cclabel_file%add_column(buf%vel(3), 'Z Drop Vel') - call cclabel_file%add_column(buf%gvel(1), 'X Gas Vel') - call cclabel_file%add_column(buf%gvel(2), 'Y Gas Vel') - call cclabel_file%add_column(buf%gvel(3), 'Z Gas Vel') - call cclabel_file%add_column(buf%moi(1,1),'Ixx') - call cclabel_file%add_column(buf%moi(2,2),'Iyy') - call cclabel_file%add_column(buf%moi(3,3),'Izz') - call cclabel_file%add_column(buf%moi(1,2),'Ixy') - call cclabel_file%add_column(buf%moi(1,3),'Ixz') - call cclabel_file%add_column(buf%moi(2,3),'Iyz') - call cclabel_file%add_column(buf%weber, 'Weber') - do n=1,cclabel%nstruct - ! Set buffer and write the data for this structure - buf = stats(n) - call cclabel_file%write() - end do - ! Close file - call cclabel_file%close() - end block write_stats + call write_stats() end if ! Monitor output From 58b79de61c3b30600b318012759eb5d651900527 Mon Sep 17 00:00:00 2001 From: Mark Owkes Date: Mon, 22 Jun 2026 14:29:36 -0600 Subject: [PATCH 68/70] Added gravity source term --- examples/ljcf/src/ljcf_class.f90 | 3 +++ 1 file changed, 3 insertions(+) diff --git a/examples/ljcf/src/ljcf_class.f90 b/examples/ljcf/src/ljcf_class.f90 index 46bf82596..7033e66aa 100644 --- a/examples/ljcf/src/ljcf_class.f90 +++ b/examples/ljcf/src/ljcf_class.f90 @@ -703,6 +703,9 @@ subroutine step(this) ! Explicit calculation of drho*u/dt from NS call this%fs%get_dmomdt(this%resU,this%resV,this%resW) + + ! Add momentum source terms + call this%fs%addsrc_gravity(this%resU,this%resV,this%resW) ! Assemble explicit residual this%resU=-2.0_WP*this%fs%rho_U*this%fs%U+(this%fs%rho_Uold+this%fs%rho_U)*this%fs%Uold+this%time%dt*this%resU From 532fb6bb7e1c44248931d82f218c634325ffd75f Mon Sep 17 00:00:00 2001 From: Mark Owkes Date: Mon, 22 Jun 2026 15:00:03 -0600 Subject: [PATCH 69/70] Clean-up ljcf extra cases --- examples/ljcf_dimensinal/GNUmakefile | 47 - examples/ljcf_dimensinal/README | 1 - examples/ljcf_dimensinal/input | 44 - examples/ljcf_dimensinal/src/Make.package | 2 - examples/ljcf_dimensinal/src/hit_class.f90 | 428 ------- examples/ljcf_dimensinal/src/ljcf_class.f90 | 1057 ----------------- examples/ljcf_dimensinal/src/simulation.f90 | 161 --- examples/ljcf_dimensinal_ib/GNUmakefile | 47 - examples/ljcf_dimensinal_ib/README | 1 - examples/ljcf_dimensinal_ib/input | 49 - examples/ljcf_dimensinal_ib/src/Make.package | 2 - examples/ljcf_dimensinal_ib/src/hit_class.f90 | 428 ------- .../ljcf_dimensinal_ib/src/ljcf_class.f90 | 1040 ---------------- .../ljcf_dimensinal_ib/src/simulation.f90 | 161 --- 14 files changed, 3468 deletions(-) delete mode 100644 examples/ljcf_dimensinal/GNUmakefile delete mode 100644 examples/ljcf_dimensinal/README delete mode 100644 examples/ljcf_dimensinal/input delete mode 100644 examples/ljcf_dimensinal/src/Make.package delete mode 100644 examples/ljcf_dimensinal/src/hit_class.f90 delete mode 100644 examples/ljcf_dimensinal/src/ljcf_class.f90 delete mode 100644 examples/ljcf_dimensinal/src/simulation.f90 delete mode 100644 examples/ljcf_dimensinal_ib/GNUmakefile delete mode 100644 examples/ljcf_dimensinal_ib/README delete mode 100644 examples/ljcf_dimensinal_ib/input delete mode 100644 examples/ljcf_dimensinal_ib/src/Make.package delete mode 100644 examples/ljcf_dimensinal_ib/src/hit_class.f90 delete mode 100644 examples/ljcf_dimensinal_ib/src/ljcf_class.f90 delete mode 100644 examples/ljcf_dimensinal_ib/src/simulation.f90 diff --git a/examples/ljcf_dimensinal/GNUmakefile b/examples/ljcf_dimensinal/GNUmakefile deleted file mode 100644 index f51ff99ec..000000000 --- a/examples/ljcf_dimensinal/GNUmakefile +++ /dev/null @@ -1,47 +0,0 @@ -# NGA location if not yet defined -NGA_HOME ?= ../.. - -# Compilation parameters -PRECISION = DOUBLE -USE_MPI = TRUE -USE_FFTW = TRUE -USE_HYPRE = TRUE -USE_LAPACK= TRUE -USE_IRL = TRUE -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 two_phase particles constant_density 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/ljcf_dimensinal/README b/examples/ljcf_dimensinal/README deleted file mode 100644 index 5e5f940b6..000000000 --- a/examples/ljcf_dimensinal/README +++ /dev/null @@ -1 +0,0 @@ -This case simulates the break-up of a liquid ligament in a turbulent crossflow. \ No newline at end of file diff --git a/examples/ljcf_dimensinal/input b/examples/ljcf_dimensinal/input deleted file mode 100644 index 9cd4b2670..000000000 --- a/examples/ljcf_dimensinal/input +++ /dev/null @@ -1,44 +0,0 @@ -# Parallelization -Partition : 8 1 1 -I/O partition : 1 1 1 - -# Mesh definition -X ljcf : 0.108 # 2D -Lx : 0.432 # 8D -Ly : 0.432 # 8D for testing - should be 0.864 # 16D -Lz : 0.216 # 4D -nx : 64 # 8 cells/D -ny : 64 # Reduced for 8D for testing - should be 128 -nz : 32 - -# Flow conditions -Jet diameter : 0.054 # m -End Injection Time : 0.267 # s sqrt(2*H/g) = sqrt(2*0.35 m / 9.81 m/s^2) = 0.267 s -Jet location : 0 -Liquid density : 1000 # kg/m^3 -Gas density : 1.2 # kg/m^3 -Liquid viscosity : 1e-3 # Pa-s -Gas viscosity : 1.8e-5 # Pa-s -Surface tension : 0.072 # N/m -Gravitational acceleration : 9.81 # m/s^2 -Air velocity : 11 # m/s -Target Re_lambda : 45 -Turbulence intensity : 0.05 - -# Time integration -Max timestep size : 2e-4 # s -Max cfl number : 1.0 -Max time : 0.4 # s - -# Pressure solver -Pressure tolerance : 1e-4 -Pressure iteration : 100 - -# Data output -Ensight output period : 2.5e-3 # s -Restart output period : 0.05 # s -Drop stats output period = 2.5e-3 - -# Data restart -#Restart from : 1.00000E+01 -#HIT restart : hit_1.00000E+01 diff --git a/examples/ljcf_dimensinal/src/Make.package b/examples/ljcf_dimensinal/src/Make.package deleted file mode 100644 index ac9df0728..000000000 --- a/examples/ljcf_dimensinal/src/Make.package +++ /dev/null @@ -1,2 +0,0 @@ -# List here the extra files here -f90EXE_sources += simulation.f90 hit_class.f90 ljcf_class.f90 diff --git a/examples/ljcf_dimensinal/src/hit_class.f90 b/examples/ljcf_dimensinal/src/hit_class.f90 deleted file mode 100644 index 792e384df..000000000 --- a/examples/ljcf_dimensinal/src/hit_class.f90 +++ /dev/null @@ -1,428 +0,0 @@ -!> Definition for an hit class -module hit_class - use precision, only: WP - use config_class, only: config - use fft3d_class, only: fft3d - use incomp_class, only: incomp - use timetracker_class, only: timetracker - use monitor_class, only: monitor - use pardata_class, only: pardata - use event_class, only: event - implicit none - private - - public :: hit - - !> HIT object - type :: hit - !> Config - type(config) :: cfg !< Mesh for solver - !> Flow solver - type(incomp) :: fs !< Incompressible flow solver - type(fft3d) :: ps !< FFT-based linear solver - type(timetracker) :: time !< Time info - !> Simulation monitor file - type(monitor) :: mfile !< General simulation monitoring - !> Work arrays - real(WP), dimension(:,:,:,:,:), allocatable :: gradU !< Velocity gradient - real(WP), dimension(:,:,:,:), allocatable :: SR !< Strain rate tensor - real(WP), dimension(:,:,:), allocatable :: resU,resV,resW !< Residuals - !> Turbulence parameters - real(WP) :: ti ! Turbulence intensity - real(WP) :: visc,meanU,meanV,meanW - real(WP) :: Urms_tgt,tke_tgt,eps_tgt ! u',k, and dissipation rate - real(WP) :: tko_tgt,eta_tgt ! Kolmogorov time and length scales - real(WP) :: Rel_tgt,Ret_tgt ! Lambda and turbulent Reynolds numbers - real(WP) :: tau_tgt ! Eddy turnover time - real(WP) :: Urms,tke,eps,Ret,Rel,eta,ell ! Current turbulence parameters (ell is large eddy size) - !> Forcing constant - real(WP) :: forcing - !> Provide a pardata object for restarts - logical :: restarted - type(pardata) :: df - type(event) :: save_evt - contains - procedure, private :: compute_stats !< Turbulence information - procedure :: init !< Initialize HIT simulation - procedure :: step !< Advance HIT simulation by one time step - procedure :: final !< Finalize HIT simulation - end type hit - - -contains - - - !> Compute turbulence stats (assumes rho=1) - subroutine compute_stats(this) - use mpi_f08, only: MPI_ALLREDUCE,MPI_SUM - use parallel, only: MPI_REAL_WP - class(hit), intent(inout) :: this - real(WP) :: myTKE,myEPS - integer :: i,j,k,ierr - ! Compute mean velocities - call this%fs%cfg%integrate(A=this%fs%U,integral=this%meanU); this%meanU=this%meanU/this%fs%cfg%vol_total - call this%fs%cfg%integrate(A=this%fs%V,integral=this%meanV); this%meanV=this%meanV/this%fs%cfg%vol_total - call this%fs%cfg%integrate(A=this%fs%W,integral=this%meanW); this%meanW=this%meanW/this%fs%cfg%vol_total - ! Compute strainrate and grad(U) - call this%fs%get_strainrate(SR=this%SR) - call this%fs%get_gradu(gradu=this%gradU) - ! Compute current TKE and dissipation rate - myTKE=0.0_WP - myEPS=0.0_WP - do k=this%fs%cfg%kmin_,this%fs%cfg%kmax_ - do j=this%fs%cfg%jmin_,this%fs%cfg%jmax_ - do i=this%fs%cfg%imin_,this%fs%cfg%imax_ - myTKE=myTKE+0.5_WP*((this%fs%U(i,j,k)-this%meanU)**2+(this%fs%V(i,j,k)-this%meanV)**2+(this%fs%W(i,j,k)-this%meanW)**2)*this%fs%cfg%vol(i,j,k) - myEPS=myEPS+2.0_WP*this%fs%cfg%vol(i,j,k)*(this%SR(1,i,j,k)**2+this%SR(2,i,j,k)**2+this%SR(3,i,j,k)**2+2.0_WP*(this%SR(4,i,j,k)**2+this%SR(5,i,j,k)**2+this%SR(6,i,j,k)**2)) - end do - end do - end do - call MPI_ALLREDUCE(myTKE,this%tke,1,MPI_REAL_WP,MPI_SUM,this%fs%cfg%comm,ierr); this%tke=this%tke/this%fs%cfg%vol_total - call MPI_ALLREDUCE(myEPS,this%eps,1,MPI_REAL_WP,MPI_SUM,this%fs%cfg%comm,ierr); this%eps=this%eps*this%visc/this%fs%cfg%vol_total - ! Compute standard parameters for HIT - this%Urms=sqrt(2.0_WP/3.0_WP*this%tke) - this%Ret=this%tke**2.0_WP/(this%visc*this%eps) - this%Rel=sqrt(20.0_WP*this%Ret/3.0_WP) - this%eta=((this%visc)**3.0_WP/this%eps)**0.25_WP - this%ell=(2.0_WP*this%tke/3.0_WP)**1.5_WP/this%eps - end subroutine compute_stats - - - !> Initialization of HIT simulation - subroutine init(this,group,xend) - use mpi_f08, only: MPI_Group - implicit none - class(hit), intent(inout) :: this - type(MPI_Group), intent(in) :: group - real(WP) :: xend - - ! Create the HIT mesh - create_config: block - use sgrid_class, only: cartesian,sgrid - use param, only: param_read - real(WP), dimension(:), allocatable :: x,y - integer, dimension(3) :: partition - type(sgrid) :: grid - integer :: j,ny - real(WP) :: Ly - ! Read in grid definition - call param_read('Ly',Ly); call param_read('ny',ny); allocate(y(ny+1)); allocate(x(ny+1)) - ! Create simple rectilinear grid in y and z - do j=1,ny+1 - y(j)=real(j-1,WP)/real(ny,WP)*Ly-0.5_WP*Ly - end do - ! Same grid in x, but shifted so it ends at xend - x=y-y(ny+1)+xend - ! General serial grid object - grid=sgrid(coord=cartesian,no=1,x=x,y=y,z=y,xper=.true.,yper=.true.,zper=.true.,name='HIT') - ! Read in partition - call param_read('Partition',partition,short='p'); partition(1)=1 - ! Create partitioned grid without walls - this%cfg=config(grp=group,decomp=partition,grid=grid) - end block create_config - - ! Initialize the work arrays - allocate_work_arrays: block - allocate(this%resU(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) - allocate(this%resV(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) - allocate(this%resW(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) - allocate(this%SR (1:6,this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) - allocate(this%gradU(1:3,1:3,this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) - end block allocate_work_arrays - - - ! Initialize time tracker with 2 subiterations - initialize_timetracker: block - use param, only: param_read - this%time=timetracker(amRoot=this%cfg%amRoot) - call param_read('Max timestep size',this%time%dtmax) - call param_read('Max cfl number',this%time%cflmax) - this%time%dt=this%time%dtmax - this%time%itmax=2 - end block initialize_timetracker - - - ! Create a single-phase periodic flow solver - create_flow_solver: block - use mathtools, only: Pi - use param, only: param_read - ! Create flow solver - this%fs=incomp(cfg=this%cfg,name='NS solver') - ! Set density to 1.0 - this%fs%rho=1.0_WP - ! Set viscosity from Reynolds number - call param_read("Gas viscosity",this%visc); - this%fs%visc=this%visc - ! Prepare and configure pressure solver - this%ps=fft3d(cfg=this%cfg,name='Pressure',nst=7) - ! Setup the solver - call this%fs%setup(pressure_solver=this%ps) - end block create_flow_solver - - - ! Prepare initial velocity field - initialize_velocity: block - use random, only: random_normal - use mathtools, only: Pi - use param, only: param_read,param_exists - use messager, only: log - use string, only: str_long - character(str_long) :: message - real(WP) :: max_forcing_estimate - integer :: i,j,k - ! Read in turbulence intensity for turbulence injection - call param_read('Turbulence intensity',this%ti) - ! Read in target Re_lambda and convert to target Urms - call param_read('Target Re_lambda',this%Urms_tgt) - this%Urms_tgt=this%visc/(3.0_WP*this%cfg%xL)*this%Urms_tgt**2 - ! Calculate other target quantities assuming l=0.2*xL - this%tke_tgt=1.5_WP*this%Urms_tgt**2 - this%eps_tgt=5.0_WP*this%Urms_tgt**3/this%cfg%xL - this%tko_tgt=sqrt(this%visc/this%eps_tgt) - this%eta_tgt=(this%visc**3/this%eps_tgt)**(0.25_WP) - this%Rel_tgt=sqrt(3.0_WP*this%Urms_tgt*this%cfg%xL/this%visc) - this%Ret_tgt=this%tke_tgt**2/(this%eps_tgt*this%visc) - this%tau_tgt=2.0_WP*this%tke_tgt/(3.0_WP*this%eps_tgt) - ! Read in forcing parameter (we need dt Urms =",es12.5)') this%Urms_tgt; call log(message) - write(message,'("[HIT setup] => Re_lambda =",es12.5)') this%Rel_tgt; call log(message) - write(message,'("[HIT setup] => Re_turb =",es12.5)') this%Ret_tgt; call log(message) - write(message,'("[HIT setup] => Kolmogorov Lscale =",es12.5)') this%eta_tgt; call log(message) - write(message,'("[HIT setup] => Kolmogorov Tscale =",es12.5)') this%tko_tgt; call log(message) - write(message,'("[HIT setup] => Epsilon =",es12.5)') this%eps_tgt; call log(message) - write(message,'("[HIT setup] => Eddyturnover time =",es12.5)') this%tau_tgt; call log(message) - end if - ! Gaussian initial field - do k=this%fs%cfg%kmin_,this%fs%cfg%kmax_ - do j=this%fs%cfg%jmin_,this%fs%cfg%jmax_ - do i=this%fs%cfg%imin_,this%fs%cfg%imax_ - this%fs%U(i,j,k)=random_normal(m=0.0_WP,sd=this%Urms_tgt) - this%fs%V(i,j,k)=random_normal(m=0.0_WP,sd=this%Urms_tgt) - this%fs%W(i,j,k)=random_normal(m=0.0_WP,sd=this%Urms_tgt) - end do - end do - end do - call this%fs%cfg%sync(this%fs%U) - call this%fs%cfg%sync(this%fs%V) - call this%fs%cfg%sync(this%fs%W) - ! Compute mean and remove it from the velocity field to obtain =0 - call this%fs%cfg%integrate(A=this%fs%U,integral=this%meanU); this%meanU=this%meanU/this%fs%cfg%vol_total; this%fs%U=this%fs%U-this%meanU - call this%fs%cfg%integrate(A=this%fs%V,integral=this%meanV); this%meanV=this%meanV/this%fs%cfg%vol_total; this%fs%V=this%fs%V-this%meanV - call this%fs%cfg%integrate(A=this%fs%W,integral=this%meanW); this%meanW=this%meanW/this%fs%cfg%vol_total; this%fs%W=this%fs%W-this%meanW - ! Project to ensure divergence-free - call this%fs%get_div() - this%fs%psolv%rhs=-this%fs%cfg%vol*this%fs%div - this%fs%psolv%sol=0.0_WP - call this%fs%psolv%solve() - call this%fs%shift_p(this%fs%psolv%sol) - call this%fs%get_pgrad(this%fs%psolv%sol,this%resU,this%resV,this%resW) - this%fs%P=this%fs%P+this%fs%psolv%sol - this%fs%U=this%fs%U-this%resU - this%fs%V=this%fs%V-this%resV - this%fs%W=this%fs%W-this%resW - ! Calculate divergence - call this%fs%get_div() - end block initialize_velocity - - - ! Handle restart here - perform_restart: block - use param, only: param_read - use string, only: str_medium - use filesys, only: makedir,isdir - character(len=str_medium) :: filename - integer, dimension(3) :: iopartition - ! Create event for saving restart files - this%save_evt=event(this%time,'HIT restart output') - call param_read('Restart output period',this%save_evt%tper) - ! Read in the partition for I/O - call param_read('I/O partition',iopartition) - ! Check if a restart file was provided - call param_read('HIT restart',filename,default='') - this%restarted=.false.; if (len_trim(filename).gt.0) this%restarted=.true. - ! Perform pardata initialization - if (this%restarted) then - ! Read in the file - call this%df%initialize(pg=this%cfg,iopartition=iopartition,fdata='restart/'//trim(filename)) - ! Put the data at the right place - call this%df%pull(name='U',var=this%fs%U) - call this%df%pull(name='V',var=this%fs%V) - call this%df%pull(name='W',var=this%fs%W) - call this%df%pull(name='P',var=this%fs%P) - ! Update divergence - call this%fs%get_div() - ! Also update time - call this%df%pull(name='t' ,val=this%time%t ) - call this%df%pull(name='dt',val=this%time%dt) - this%time%told=this%time%t-this%time%dt - !this%time%dt=this%time%dtmax !< Force max timestep size anyway - else - ! Prepare a new directory for storing files for restart - if (this%cfg%amRoot) then - if (.not.isdir('restart')) call makedir('restart') - end if - ! If we are not restarting, we will still need a datafile for saving restart files - call this%df%initialize(pg=this%cfg,iopartition=iopartition,filename=trim(this%cfg%name),nval=2,nvar=4) - this%df%valname=['dt','t ']; this%df%varname=['U','V','W','P'] - end if - end block perform_restart - - - ! Create monitoring file - create_monitor: block - ! Prepare some info about turbulence - call this%fs%get_max() - call this%compute_stats() - ! Create simulation monitor - this%mfile=monitor(this%fs%cfg%amRoot,'hit') - call this%mfile%add_column(this%time%n,'Timestep number') - call this%mfile%add_column(this%time%t,'Time') - call this%mfile%add_column(this%time%dt,'Timestep size') - call this%mfile%add_column(this%fs%Umax,'Umax') - call this%mfile%add_column(this%fs%Vmax,'Vmax') - call this%mfile%add_column(this%fs%Wmax,'Wmax') - call this%mfile%add_column(this%Ret,'Re_turb') - call this%mfile%add_column(this%Rel,'Re_lambda') - call this%mfile%add_column(this%Urms,'Urms') - call this%mfile%add_column(this%TKE,'TKE') - call this%mfile%add_column(this%EPS,'Epsilon') - call this%mfile%add_column(this%ell,'Large eddy size') - call this%mfile%add_column(this%eta,'Kolmogorov length') - call this%mfile%write() - end block create_monitor - - - end subroutine init - - - !> Take one time step with specified dt - subroutine step(this,dt) - implicit none - class(hit), intent(inout) :: this - real(WP), intent(in) :: dt - - ! Increment time based on provided dt - this%time%dt=dt; call this%time%increment() - - ! Remember old velocity - this%fs%Uold=this%fs%U - this%fs%Vold=this%fs%V - this%fs%Wold=this%fs%W - - ! Perform sub-iterations - do while (this%time%it.le.this%time%itmax) - - ! Build mid-time velocity - this%fs%U=0.5_WP*(this%fs%U+this%fs%Uold) - this%fs%V=0.5_WP*(this%fs%V+this%fs%Vold) - this%fs%W=0.5_WP*(this%fs%W+this%fs%Wold) - - ! Explicit calculation of drho*u/dt from NS - call this%fs%get_dmomdt(this%resU,this%resV,this%resW) - - ! Assemble explicit residual - this%resU=-2.0_WP*(this%fs%U-this%fs%Uold)+this%time%dt*this%resU - this%resV=-2.0_WP*(this%fs%V-this%fs%Vold)+this%time%dt*this%resV - this%resW=-2.0_WP*(this%fs%W-this%fs%Wold)+this%time%dt*this%resW - - ! Apply HIT forcing - hit_forcing: block - use mpi_f08, only: MPI_ALLREDUCE,MPI_SUM - use parallel, only: MPI_REAL_WP - real(WP) :: myTKE,A,myEPSp,EPSp - integer :: i,j,k,ierr - ! Calculate mean velocity - call this%fs%cfg%integrate(A=this%fs%U,integral=this%meanU); this%meanU=this%meanU/this%fs%cfg%vol_total - call this%fs%cfg%integrate(A=this%fs%V,integral=this%meanV); this%meanV=this%meanV/this%fs%cfg%vol_total - call this%fs%cfg%integrate(A=this%fs%W,integral=this%meanW); this%meanW=this%meanW/this%fs%cfg%vol_total - ! Calculate TKE and pseudo-EPS - call this%fs%get_gradu(gradu=this%gradU) - myTKE=0.0_WP; myEPSp=0.0_WP - do k=this%fs%cfg%kmin_,this%fs%cfg%kmax_ - do j=this%fs%cfg%jmin_,this%fs%cfg%jmax_ - do i=this%fs%cfg%imin_,this%fs%cfg%imax_ - myTKE =myTKE +0.5_WP*((this%fs%U(i,j,k)-this%meanU)**2+(this%fs%V(i,j,k)-this%meanV)**2+(this%fs%W(i,j,k)-this%meanW)**2)*this%fs%cfg%vol(i,j,k) - myEPSp=myEPSp+this%fs%cfg%vol(i,j,k)*(this%gradU(1,1,i,j,k)**2+this%gradU(1,2,i,j,k)**2+this%gradU(1,3,i,j,k)**2+& - & this%gradU(2,1,i,j,k)**2+this%gradU(2,2,i,j,k)**2+this%gradU(2,3,i,j,k)**2+& - & this%gradU(3,1,i,j,k)**2+this%gradU(3,2,i,j,k)**2+this%gradU(3,3,i,j,k)**2) - end do - end do - end do - call MPI_ALLREDUCE(myTKE,this%tke,1,MPI_REAL_WP,MPI_SUM,this%fs%cfg%comm,ierr); this%tke=this%tke/this%fs%cfg%vol_total - call MPI_ALLREDUCE(myEPSp,EPSp,1,MPI_REAL_WP,MPI_SUM,this%fs%cfg%comm,ierr); EPSp=EPSp*this%visc/this%fs%cfg%vol_total - A=(EPSp-this%forcing*(this%tke-this%tke_tgt)/this%tau_tgt)/(2.0_WP*this%tke) - this%resU=this%resU+A*this%time%dt*(this%fs%U-this%meanU) - this%resV=this%resV+A*this%time%dt*(this%fs%V-this%meanV) - this%resW=this%resW+A*this%time%dt*(this%fs%W-this%meanW) - end block hit_forcing - - ! Apply these residuals - this%fs%U=2.0_WP*this%fs%U-this%fs%Uold+this%resU - this%fs%V=2.0_WP*this%fs%V-this%fs%Vold+this%resV - this%fs%W=2.0_WP*this%fs%W-this%fs%Wold+this%resW - - ! Solve Poisson equation - call this%fs%get_div() - this%fs%psolv%rhs=-this%fs%cfg%vol*this%fs%div/this%time%dt - this%fs%psolv%sol=0.0_WP - call this%fs%psolv%solve() - call this%fs%shift_p(this%fs%psolv%sol) - - ! Correct velocity - call this%fs%get_pgrad(this%fs%psolv%sol,this%resU,this%resV,this%resW) - this%fs%P=this%fs%P+this%fs%psolv%sol - this%fs%U=this%fs%U-this%time%dt*this%resU - this%fs%V=this%fs%V-this%time%dt*this%resV - this%fs%W=this%fs%W-this%time%dt*this%resW - - ! Increment sub-iteration counter - this%time%it=this%time%it+1 - - end do - - ! Recompute divergence - call this%fs%get_div() - - ! Perform and output monitoring - call this%fs%get_max() - call this%compute_stats() - call this%mfile%write() - - ! Finally, see if it's time to save restart files - if (this%save_evt%occurs()) then - save_restart: block - use string, only: str_medium - character(len=str_medium) :: timestamp - ! Prefix for files - write(timestamp,'(es12.5)') this%time%t - ! Populate df and write it - call this%df%push(name='t' ,val=this%time%t ) - call this%df%push(name='dt',val=this%time%dt) - call this%df%push(name='U' ,var=this%fs%U ) - call this%df%push(name='V' ,var=this%fs%V ) - call this%df%push(name='W' ,var=this%fs%W ) - call this%df%push(name='P' ,var=this%fs%P ) - call this%df%write(fdata='restart/hit_'//trim(adjustl(timestamp))) - end block save_restart - end if - - end subroutine step - - - !> Finalize nozzle simulation - subroutine final(this) - implicit none - class(hit), intent(inout) :: this - - ! Deallocate work arrays - deallocate(this%resU,this%resV,this%resW,this%gradU,this%SR) - - end subroutine final - - -end module hit_class \ No newline at end of file diff --git a/examples/ljcf_dimensinal/src/ljcf_class.f90 b/examples/ljcf_dimensinal/src/ljcf_class.f90 deleted file mode 100644 index 1c2bc487c..000000000 --- a/examples/ljcf_dimensinal/src/ljcf_class.f90 +++ /dev/null @@ -1,1057 +0,0 @@ -!> Definition for a ljcf atomization class -module ljcf_class - use precision, only: WP - use config_class, only: config - use iterator_class, only: iterator - use ensight_class, only: ensight - use surfmesh_class, only: surfmesh - use hypre_str_class, only: hypre_str - !use ddadi_class, only: ddadi - use vfs_class, only: vfs - use tpns_class, only: tpns - use timetracker_class, only: timetracker - use event_class, only: event - use monitor_class, only: monitor - use timer_class, only: timer - use pardata_class, only: pardata - use cclabel_class, only: cclabel - use irl_fortran_interface - implicit none - private - - public :: ljcf - - integer :: ierr - - !> ljcf object - type :: ljcf - - !> Config - type(config) :: cfg - - !> Flow solver - type(vfs) :: vf !< Volume fraction solver - type(tpns) :: fs !< Two-phase flow solver - type(hypre_str) :: ps !< Structured Hypre linear solver for pressure - !type(ddadi) :: vs !< DDADI solver for velocity - type(timetracker) :: time !< Time info - type(cclabel) :: ccl !< CCLabel for local Weber number calculation - - !> Ensight postprocessing - type(surfmesh) :: smesh !< Surface mesh for interface - type(ensight) :: ens_out !< Ensight output for flow variables - type(event) :: ens_evt !< Event trigger for Ensight output - - !> Simulation monitor file - type(monitor) :: mfile !< General simulation monitoring - type(monitor) :: cflfile !< CFL monitoring - type(monitor) :: ljcf_file !< LJCF simulation monitoring - - !> Work arrays - real(WP), dimension(:,:,:), allocatable :: resU,resV,resW !< Residuals - real(WP), dimension(:,:,:), allocatable :: Ui,Vi,Wi !< Cell-centered velocities - - !> Iterator for VOF removal - type(iterator) :: vof_removal_layer !< Edge of domain where we actively remove VOF - real(WP) :: vof_removed !< Integral of VOF removed - integer :: nlayer=4 !< Size of buffer layer for VOF removal - - !> Timing info - type(monitor) :: timefile !< Timing monitoring - type(timer) :: tstep !< Timer for step - type(timer) :: tvel !< Timer for velocity - type(timer) :: tpres !< Timer for pressure - type(timer) :: tvof !< Timer for VOF - - !> Provide a pardata and an event tracker for saving restarts - type(event) :: save_evt - type(pardata) :: df - logical :: restarted - - !> Drop statistics output event - type(event) :: drops_evt - - !> Problem definition - real(WP) :: djet, Vjet - real(WP), dimension(:), allocatable :: xjet - integer :: relax_model, nwall - real(WP) :: gravity, endInjectionTime, InjectionVelocity - - contains - procedure :: init !< Initialize nozzle simulation - procedure :: step !< Advance nozzle simulation by one time step - procedure :: final !< Finalize nozzle simulation - end type ljcf - - -contains - - !> Initialization of ljcf simulation - subroutine init(this) - implicit none - class(ljcf), intent(inout) :: this - - ! Create the ljcf mesh - create_config: block - use sgrid_class, only: cartesian,sgrid - use param, only: param_read - use parallel, only: group - real(WP), dimension(:), allocatable :: x,y,z - integer, dimension(3) :: partition - type(sgrid) :: grid - integer :: i,j,k,nx,ny,nz - real(WP) :: Lx,Ly,Lz,xlig - ! Read in grid definition - call param_read('Lx',Lx); call param_read('nx',nx); allocate(x(nx+1)); call param_read('X ljcf',xlig) - 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-xlig - 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=3,x=x,y=y,z=z,xper=.false.,yper=.false.,zper=.true.,name='ljcf') - ! Read in partition - call param_read('Partition',partition,short='p') - ! Create partitioned grid without walls - this%cfg=config(grp=group,decomp=partition,grid=grid) - - end block create_config - - - ! Initialize time tracker with 2 subiterations - initialize_timetracker: block - use param, only: param_read - this%time=timetracker(amRoot=this%cfg%amRoot) - call param_read('Max timestep size',this%time%dtmax) - call param_read('Max cfl number',this%time%cflmax) - call param_read('Max time',this%time%tmax) - call param_read('Max steps',this%time%nmax, default=this%time%nmax) - this%time%dt=this%time%dtmax - this%time%itmax=2 - end block initialize_timetracker - - - ! Allocate work arrays - allocate_work_arrays: block - allocate(this%resU(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) - allocate(this%resV(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) - allocate(this%resW(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) - allocate(this%Ui (this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) - allocate(this%Vi (this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) - allocate(this%Wi (this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) - end block allocate_work_arrays - - ! Set up walls before solvers are initialized - create_walls: block - use param, only: param_read,param_getsize - integer :: i,j,k,njet - ! Initialize liquid jet(s) - call param_read('Jet diameter',this%djet) - njet = param_getsize('Jet location') - allocate(this%xjet(njet)) - call param_read('Jet location',this%xjet) - call param_read('Gravitational acceleration',this%gravity) - call param_read('End Injection Time',this%endInjectionTime) - ! Number of wall cells - call param_read('Wall cells in domain', this%nwall, default=0) - 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 (wall(this%cfg%pgrid,i,j,k)) then - this%cfg%VF(i,j,k)=0.0_WP - end if - end do - end do - end do - end block create_walls - - ! Initialize our VOF solver and field - create_and_initialize_vof: block - use vfs_class, only: remap,VFlo,VFhi,plicnet,r2pnet - use mms_geom, only: cube_refine_vol - use param, only: param_read - integer :: i,j,k,n,si,sj,sk - real(WP), dimension(3,8) :: cube_vertex - real(WP), dimension(3) :: v_cent,a_cent - real(WP) :: vol,area - integer, parameter :: amr_ref_lvl=4 - ! Create a VOF solver - call this%vf%initialize(cfg=this%cfg,reconstruction_method=plicnet,transport_method=remap,name='VOF') - this%vf%thin_thld_min=0.0_WP - this%vf%flotsam_thld=0.0_WP - this%vf%maxcurv_times_mesh=1.0_WP - ! Initialize the interface to a ljcf - do k=this%vf%cfg%kmino_,this%vf%cfg%kmaxo_ - do j=this%vf%cfg%jmino_,this%vf%cfg%jmaxo_ - do i=this%vf%cfg%imino_,this%vf%cfg%imaxo_ - ! Set cube vertices - n=0 - do sk=0,1 - do sj=0,1 - do si=0,1 - n=n+1; cube_vertex(:,n)=[this%vf%cfg%x(i+si),this%vf%cfg%y(j+sj),this%vf%cfg%z(k+sk)] - end do - end do - end do - ! Call adaptive refinement code to get volume and barycenters recursively - vol=0.0_WP; area=0.0_WP; v_cent=0.0_WP; a_cent=0.0_WP - if (j.le.this%vf%cfg%jmin) then - call cube_refine_vol(cube_vertex,vol,area,v_cent,a_cent,levelset_halfdrop,0.0_WP,amr_ref_lvl) - else - ! do nothing - end if - this%vf%VF(i,j,k)=vol/this%vf%cfg%vol(i,j,k) - if (this%vf%VF(i,j,k).ge.VFlo.and.this%vf%VF(i,j,k).le.VFhi) then - this%vf%Lbary(:,i,j,k)=v_cent - this%vf%Gbary(:,i,j,k)=([this%vf%cfg%xm(i),this%vf%cfg%ym(j),this%vf%cfg%zm(k)]-this%vf%VF(i,j,k)*this%vf%Lbary(:,i,j,k))/(1.0_WP-this%vf%VF(i,j,k)) - else - this%vf%Lbary(:,i,j,k)=[this%vf%cfg%xm(i),this%vf%cfg%ym(j),this%vf%cfg%zm(k)] - this%vf%Gbary(:,i,j,k)=[this%vf%cfg%xm(i),this%vf%cfg%ym(j),this%vf%cfg%zm(k)] - end if - end do - end do - end do - - ! Update the band - call this%vf%update_band() - ! Perform interface reconstruction from VOF field - call this%vf%build_interface() - ! Set interface planes at the boundaries - call this%vf%set_full_bcond() - - ! Now apply Neumann condition on interface at inlet to have proper round injection - neumann_irl: block - use irl_fortran_interface, only: getPlane,new,construct_2pt,RectCub_type,& - & setNumberOfPlanes,setPlane,matchVolumeFraction - real(WP), dimension(1:4) :: plane - real(WP) :: eps_plane - integer :: nplanes_src - type(RectCub_type) :: cell - call new(cell) - if (this%vf%cfg%jproc.eq.1) then - do k=this%vf%cfg%kmino_,this%vf%cfg%kmaxo_ - do j=this%vf%cfg%jmino_,this%vf%cfg%jmin-1 - do i=this%vf%cfg%imino_,this%vf%cfg%imaxo_ - ! Extract plane data and copy in overlap - plane=getPlane(this%vf%liquid_gas_interface(i,this%vf%cfg%jmin,k),0) - eps_plane = 1.0e-30_WP - nplanes_src = getNumberOfPlanes(this%vf%liquid_gas_interface(i,this%vf%cfg%jmin,k)) - if (nplanes_src.eq.0) cycle - call construct_2pt(cell,[this%vf%cfg%x(i ),this%vf%cfg%y(j ),this%vf%cfg%z(k )],& - & [this%vf%cfg%x(i+1),this%vf%cfg%y(j+1),this%vf%cfg%z(k+1)]) - plane(4)=dot_product(plane(1:3),[this%vf%cfg%xm(i),this%vf%cfg%ym(j),this%vf%cfg%zm(k)]) - if (sum(plane(1:3)**2) .le. eps_plane) cycle - call setNumberOfPlanes(this%vf%liquid_gas_interface(i,j,k),1) - call setPlane(this%vf%liquid_gas_interface(i,j,k),0,plane(1:3),plane(4)) - call matchVolumeFraction(cell,this%vf%VF(i,j,k),this%vf%liquid_gas_interface(i,j,k)) - end do - end do - end do - end if - end block neumann_irl - - ! Create discontinuous polygon mesh from IRL interface - call this%vf%polygonalize_interface() - ! Calculate distance from polygons - call this%vf%distance_from_polygon() - ! Calculate subcell phasic volumes - call this%vf%subcell_vol() - ! Calculate curvature - call this%vf%get_curvature() - ! Reset moments to guarantee compatibility with interface reconstruction - call this%vf%reset_volume_moments() - end block create_and_initialize_vof - - ! Create an iterator for removing VOF at edges - create_iterator: block - this%vof_removal_layer=iterator(this%cfg,'VOF removal',vof_removal_layer_locator) - end block create_iterator - - - ! Create a multiphase flow solver with bconds - create_flow_solver: block - use mathtools, only: Pi - use param, only: param_read - use tpns_class, only: dirichlet,clipped_neumann,bcond - use hypre_str_class, only: pcg_pfmg2 - type(bcond), pointer :: mybc - integer :: n,i,j,k - ! Create flow solver - this%fs=tpns(cfg=this%cfg,name='Two-phase NS') - ! Set fluid properties - call param_read("Liquid density",this%fs%rho_l); - call param_read("Gas density",this%fs%rho_g); - call param_read("Liquid viscosity",this%fs%visc_l); - call param_read("Gas viscosity",this%fs%visc_g); - call param_read("Surface tension",this%fs%sigma); - - ! Define inflow boundary condition on the left - call this%fs%add_bcond(name='inflow',type=dirichlet,face='x',dir=-1,canCorrect=.false.,locator=xm_locator) - ! Define outflow boundary condition on the right - call this%fs%add_bcond(name='outflow',type=clipped_neumann,face='x',dir=+1,canCorrect=.true.,locator=xp_locator) - ! Define jet boundary condition on the bottom - call this%fs%add_bcond(name='jet' ,type=dirichlet,face='y',dir=-1,canCorrect=.false.,locator=jet_bdy) - ! Define gravity as vector for flow solver - this%fs%gravity(2) = this%gravity - - ! testing: block - ! use tpns_class, only: bcond - ! type(bcond), pointer :: mybc - ! print *, 'Testing VOF after initialization' - ! call this%fs%get_bcond('jet',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) - ! print *, 'Testing VOF at i,j,k=', i, j, k, 'VOF below = ', this%vf%VF(i,j-1,k) - ! end do - ! end block testing - - ! Configure pressure solver - this%ps=hypre_str(cfg=this%cfg,name='Pressure',method=pcg_pfmg2,nst=7) - this%ps%maxlevel=16 - call param_read('Pressure iteration',this%ps%maxit) - call param_read('Pressure tolerance',this%ps%rcvg) - ! Configure implicit velocity solver - !this%vs=ddadi(cfg=this%cfg,name='Velocity',nst=7) - ! Setup the solver - call this%fs%setup(pressure_solver=this%ps)!,implicit_solver=this%vs) - ! Zero initial field - this%fs%U=0.0_WP; this%fs%V=0.0_WP; this%fs%W=0.0_WP - ! Apply convective velocity - call this%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) - this%fs%U(i,j,k)=1.0_WP - end do - ! Apply jet velocity - call this%fs%get_bcond('jet',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) - this%fs%V(i,j,k)=0 ! Start with zero velocity this%Vjet - end do - ! Apply all other boundary conditions - call this%fs%apply_bcond(this%time%t,this%time%dt) - ! Adjust MFR for global mass balance - call this%fs%correct_mfr() - ! Compute divergence - call this%fs%get_div() - ! Compute cell-centered velocity - call this%fs%interp_vel(this%Ui,this%Vi,this%Wi) - end block create_flow_solver - - ! Create CCL - create_ccl: block - ! Initialize CCL - call this%ccl%initialize(pg=this%cfg%pgrid,name='ccl') - end block create_ccl - - ! Handle restart/saves here - handle_restart: block - use param, only: param_read - use string, only: str_medium - use filesys, only: makedir,isdir - use irl_fortran_interface, only: setNumberOfPlanes,setPlane - character(len=str_medium) :: timestamp - integer, dimension(3) :: iopartition - real(WP), dimension(:,:,:), allocatable :: P11,P12,P13,P14 - real(WP), dimension(:,:,:), allocatable :: P21,P22,P23,P24 - integer :: i,j,k - ! Create event for saving restart files - this%save_evt=event(this%time,'Restart output') - call param_read('Restart output period',this%save_evt%tper) - ! Check if we are restarting - call param_read('Restart from',timestamp,default='') - this%restarted=.false.; if (len_trim(timestamp).gt.0) this%restarted=.true. - ! Read in the I/O partition - call param_read('I/O partition',iopartition) - ! Perform pardata initialization - if (this%restarted) then - ! Read in the file - call this%df%initialize(pg=this%cfg,iopartition=iopartition,fdata='restart/data_'//trim(timestamp)) - ! Read in the planes directly and set the IRL interface - allocate(P11(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)); call this%df%pull(name='P11',var=P11) - allocate(P12(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)); call this%df%pull(name='P12',var=P12) - allocate(P13(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)); call this%df%pull(name='P13',var=P13) - allocate(P14(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)); call this%df%pull(name='P14',var=P14) - allocate(P21(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)); call this%df%pull(name='P21',var=P21) - allocate(P22(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)); call this%df%pull(name='P22',var=P22) - allocate(P23(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)); call this%df%pull(name='P23',var=P23) - allocate(P24(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)); call this%df%pull(name='P24',var=P24) - do k=this%vf%cfg%kmin_,this%vf%cfg%kmax_ - do j=this%vf%cfg%jmin_,this%vf%cfg%jmax_ - do i=this%vf%cfg%imin_,this%vf%cfg%imax_ - ! Check if the second plane is meaningful - if (this%vf%two_planes.and.P21(i,j,k)**2+P22(i,j,k)**2+P23(i,j,k)**2.gt.0.0_WP) then - call setNumberOfPlanes(this%vf%liquid_gas_interface(i,j,k),2) - call setPlane(this%vf%liquid_gas_interface(i,j,k),0,[P11(i,j,k),P12(i,j,k),P13(i,j,k)],P14(i,j,k)) - call setPlane(this%vf%liquid_gas_interface(i,j,k),1,[P21(i,j,k),P22(i,j,k),P23(i,j,k)],P24(i,j,k)) - else - call setNumberOfPlanes(this%vf%liquid_gas_interface(i,j,k),1) - call setPlane(this%vf%liquid_gas_interface(i,j,k),0,[P11(i,j,k),P12(i,j,k),P13(i,j,k)],P14(i,j,k)) - end if - end do - end do - end do - call this%vf%sync_interface() - deallocate(P11,P12,P13,P14,P21,P22,P23,P24) - ! Reset moments - call this%vf%reset_volume_moments() - ! Update the band - call this%vf%update_band() - ! Create discontinuous polygon mesh from IRL interface - call this%vf%polygonalize_interface() - ! Calculate distance from polygons - call this%vf%distance_from_polygon() - ! Calculate subcell phasic volumes - call this%vf%subcell_vol() - ! Calculate curvature - call this%vf%get_curvature() - ! Now read in the velocity solver data - call this%df%pull(name='U',var=this%fs%U) - call this%df%pull(name='V',var=this%fs%V) - call this%df%pull(name='W',var=this%fs%W) - call this%df%pull(name='P',var=this%fs%P) - call this%df%pull(name='Pjx',var=this%fs%Pjx) - call this%df%pull(name='Pjy',var=this%fs%Pjy) - call this%df%pull(name='Pjz',var=this%fs%Pjz) - ! Apply all other boundary conditions - call this%fs%apply_bcond(this%time%t,this%time%dt) - ! Compute MFR through all boundary conditions - call this%fs%get_mfr() - ! Adjust MFR for global mass balance - call this%fs%correct_mfr() - ! Compute cell-centered velocity - call this%fs%interp_vel(this%Ui,this%Vi,this%Wi) - ! Compute divergence - call this%fs%get_div() - ! Also update time - call this%df%pull(name='t' ,val=this%time%t ) - call this%df%pull(name='dt',val=this%time%dt) - this%time%told=this%time%t-this%time%dt - !this%time%dt=this%time%dtmax !< Force max timestep size anyway - else - ! We are not restarting, prepare a new directory for storing restart files - if (this%cfg%amRoot) then - if (.not.isdir('restart')) call makedir('restart') - end if - ! Prepare pardata object for saving restart files - call this%df%initialize(pg=this%cfg,iopartition=iopartition,filename=trim(this%cfg%name),nval=2,nvar=15) - this%df%valname=['t ','dt'] - this%df%varname=['U ','V ','W ','P ','Pjx','Pjy','Pjz','P11','P12','P13','P14','P21','P22','P23','P24'] - end if - end block handle_restart - - - ! Create surfmesh object for interface polygon output - create_smesh: block - use irl_fortran_interface, only: getNumberOfPlanes,getNumberOfVertices - integer :: i,j,k,np,nplane - this%smesh=surfmesh(nvar=2,name='plic') - this%smesh%varname(1)='nplane' - this%smesh%varname(2)='thickness' - ! Transfer polygons to smesh - call this%vf%update_surfmesh(this%smesh) - ! ! Calculate thickness - ! call this%vf%get_thickness() - ! ! Populate nplane and thickness variables - ! this%smesh%var(1,:)=1.0_WP - ! np=0 - ! do k=this%vf%cfg%kmin_,this%vf%cfg%kmax_ - ! do j=this%vf%cfg%jmin_,this%vf%cfg%jmax_ - ! do i=this%vf%cfg%imin_,this%vf%cfg%imax_ - ! if (this%cfg%VF(i,j,k).lt.2.0_WP*epsilon(1.0_WP)) cycle ! Skip cells below VF threshold - ! do nplane=1,getNumberOfPlanes(this%vf%liquid_gas_interface(i,j,k)) - ! if (getNumberOfVertices(this%vf%interface_polygon(nplane,i,j,k)).gt.0) then - ! np=np+1; this%smesh%var(1,np)=real(getNumberOfPlanes(this%vf%liquid_gas_interface(i,j,k)),WP) - ! this%smesh%var(2,np)=this%vf%thickness(i,j,k) - ! end if - ! end do - ! end do - ! end do - ! end do - end block create_smesh - - - ! Add Ensight output - create_ensight: block - use param, only: param_read - ! Create Ensight output from cfg - this%ens_out=ensight(cfg=this%cfg,name='ljcf') - ! Create event for Ensight output - this%ens_evt=event(time=this%time,name='Ensight output') - call param_read('Ensight output period',this%ens_evt%tper) - ! Add variables to output - call this%ens_out%add_vector('velocity',this%Ui,this%Vi,this%Wi) - call this%ens_out%add_scalar('VOF',this%vf%VF) - call this%ens_out%add_scalar('curvature',this%vf%curv) - call this%ens_out%add_scalar('pressure',this%fs%P) - call this%ens_out%add_surface('plic',this%smesh) - ! Output to ensight - if (this%ens_evt%occurs()) call this%ens_out%write_data(this%time%t) - end block create_ensight - - - ! Create drop statistics output event - create_drops_output: block - use param, only: param_read - use filesys, only: makedir,isdir - ! Create event for drop statistics output - this%drops_evt=event(time=this%time,name='Drop statistics output') - call param_read('Drop stats output period',this%drops_evt%tper,default=this%time%dtmax) - ! Create drop_stats directory if needed - if (this%cfg%amRoot) then - if (.not.isdir('drop_stats')) call makedir('drop_stats') - end if - end block create_drops_output - - - ! Create a monitor file - create_monitor: block - ! Prepare some info about fields - call this%fs%get_cfl(this%time%dt,this%time%cfl) - call this%fs%get_max() - call this%vf%get_max() - ! Create simulation monitor - this%mfile=monitor(this%fs%cfg%amRoot,'simulation_atom') - call this%mfile%add_column(this%time%n,'Timestep number') - call this%mfile%add_column(this%time%t,'Time') - call this%mfile%add_column(this%time%dt,'Timestep size') - call this%mfile%add_column(this%time%cfl,'Maximum CFL') - call this%mfile%add_column(this%fs%Umax,'Umax') - call this%mfile%add_column(this%fs%Vmax,'Vmax') - call this%mfile%add_column(this%fs%Wmax,'Wmax') - call this%mfile%add_column(this%fs%Pmax,'Pmax') - call this%mfile%add_column(this%vf%VFint,'VOF integral') - call this%mfile%add_column(this%vf%SDint,'SD integral') - call this%mfile%add_column(this%vof_removed,'VOF removed') - call this%mfile%add_column(this%vf%flotsam_error,'Flotsam error') - ! call this%mfile%add_column(this%vf%thinstruct_error,'Film error') - call this%mfile%add_column(this%fs%divmax,'Maximum divergence') - call this%mfile%add_column(this%fs%psolv%it,'Pressure iteration') - call this%mfile%add_column(this%fs%psolv%rerr,'Pressure error') - call this%mfile%write() - ! Create CFL monitor - this%cflfile=monitor(this%fs%cfg%amRoot,'cfl_atom') - call this%cflfile%add_column(this%time%n,'Timestep number') - call this%cflfile%add_column(this%time%t,'Time') - call this%cflfile%add_column(this%fs%CFLst,'STension CFL') - call this%cflfile%add_column(this%fs%CFLc_x,'Convective xCFL') - call this%cflfile%add_column(this%fs%CFLc_y,'Convective yCFL') - call this%cflfile%add_column(this%fs%CFLc_z,'Convective zCFL') - call this%cflfile%add_column(this%fs%CFLv_x,'Viscous xCFL') - call this%cflfile%add_column(this%fs%CFLv_y,'Viscous yCFL') - call this%cflfile%add_column(this%fs%CFLv_z,'Viscous zCFL') - call this%cflfile%write() - ! Create LJCF monitor - this%ljcf_file=monitor(this%fs%cfg%amRoot,'ljcf') - call this%ljcf_file%add_column(this%time%n,'Timestep number') - call this%ljcf_file%add_column(this%time%t,'Time') - call this%ljcf_file%add_column(this%InjectionVelocity,'Injection Velocity') - call this%ljcf_file%write() - end block create_monitor - - - ! Create a timing monitor - create_timing: block - ! Create timers - this%tstep =timer(comm=this%cfg%comm,name='Timestep') - this%tvof =timer(comm=this%cfg%comm,name='VOFsolve') - this%tvel =timer(comm=this%cfg%comm,name='Velocity') - this%tpres =timer(comm=this%cfg%comm,name='Pressure') - ! Create corresponding monitor file - this%timefile=monitor(this%fs%cfg%amRoot,'timing') - call this%timefile%add_column(this%time%n,'Timestep number') - call this%timefile%add_column(this%time%t,'Time') - call this%timefile%add_column(this%tstep%time ,trim(this%tstep%name)) - call this%timefile%add_column(this%tvof%time ,trim(this%tvof%name)) - call this%timefile%add_column(this%tvel%time ,trim(this%tvel%name)) - call this%timefile%add_column(this%tpres%time ,trim(this%tpres%name)) - end block create_timing - - contains - - - !> Function that localizes the x- boundary - function xm_locator(pg,i,j,k) result(isIn) - use pgrid_class, only: pgrid - class(pgrid), intent(in) :: pg - integer, intent(in) :: i,j,k - logical :: isIn - isIn=.false. - if (i.eq.pg%imin) isIn=.true. - end function xm_locator - - - !> Function that localizes the x+ boundary - function xp_locator(pg,i,j,k) result(isIn) - use pgrid_class, only: pgrid - 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 xp_locator - - - !> Function that localizes region of VOF removal - function vof_removal_layer_locator(pg,i,j,k) result(isIn) - use pgrid_class, only: pgrid - class(pgrid), intent(in) :: pg - integer, intent(in) :: i,j,k - logical :: isIn - isIn=.false. - if (i.ge.pg%imax-this%nlayer) isIn=.true. - end function vof_removal_layer_locator - - - !> Function that defines a level set function for a half droplet - function levelset_halfdrop(xyz,t) result(G) - implicit none - real(WP), dimension(3),intent(in) :: xyz - real(WP), intent(in) :: t - real(WP) :: G - G=0.5_WP*this%djet-sqrt(xyz(1)**2+(xyz(2)-this%cfg%y(this%cfg%jmin))**2+xyz(3)**2) - end function levelset_halfdrop - - !> Function that localizes the jet(s) initial location - function jet(pg,i,j,k) result(isIn) - use pgrid_class, only: pgrid - implicit none - class(pgrid), intent(in) :: pg - integer, intent(in) :: i,j,k - integer :: ii,kk - real(WP), dimension(3) :: xyz - logical :: isIn - ! isIn=.false. - ! xyz(1)=pg%xm(i); xyz(2)=pg%ym(j); xyz(3)=pg%zm(k) - ! if (levelset_halfdrop(xyz,0.0_WP).gt.0.0_WP) isIn=.true. - isIn=.false. - ! Check if any of cell corners are in jet - do ii = i,i+1 - do kk = k,k+1 - xyz(1)=pg%x(ii); xyz(2)=pg%y(pg%jmin); xyz(3)=pg%z(kk) - if (levelset_halfdrop(xyz,0.0_WP).gt.0.0_WP) then - isIn=.true. - return - end if - end do - end do - end function jet - - !> Function that localizes the walls surrounding the jets - function wall(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 (j.le.pg%jmin-1+this%nwall.and.(.not.jet(pg,i,j,k))) isIn=.true. - end function wall - - !> Function that localizes the jet(s) BCs at edge of domain - function jet_bdy(pg,i,j,k) result(isIn) - use pgrid_class, only: pgrid - implicit none - class(pgrid), intent(in) :: pg - integer, intent(in) :: i,j,k - real(WP), dimension(3) :: xyz - logical :: isIn - isIn=.false. - xyz(1)=pg%xm(i); xyz(2)=pg%y(j); xyz(3)=pg%zm(k) - if (j.eq.pg%jmin.and.jet(pg,i,j,k)) isIn=.true. - end function jet_bdy - - - end subroutine init - - - !> Take one time step - subroutine step(this) - use tpns_class, only: arithmetic_visc - implicit none - class(ljcf), intent(inout) :: this - - ! Reset all timers and start timestep timer - call this%tstep%reset() - call this%tvof%reset() - call this%tvel%reset() - call this%tpres%reset() - call this%tstep%start() - - ! Increment time - call this%fs%get_cfl(this%time%dt,this%time%cfl) - call this%time%adjust_dt() - call this%time%increment() - - ! Apply jet velocity - apply_bc: block - use tpns_class, only: bcond - use mpi_f08, only: MPI_ALLREDUCE,MPI_SUM,MPI_IN_PLACE - use parallel, only: MPI_REAL_WP - type(bcond), pointer :: mybc - real(WP) :: liqVolInjected_dt - integer :: n,i,j,k - ! Compute injection velocity - if (this%time%t .lt. this%endInjectionTime) then - this%InjectionVelocity=this%gravity*this%time%t ! Velocity increases linearly with time - else - this%InjectionVelocity=0.0_WP ! Velocity stops once volume is reached - end if - ! Apply injection velocity to the jet boundary condition - call this%fs%get_bcond('jet',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) - this%fs%V(i,j,k) = this%InjectionVelocity - ! print *, 'Applied jet velocity of ', this%InjectionVelocity, ' at i,j,k=', i, j, k, 'VOF below = ', this%vf%VF(i,j-1,k) - end do - end block apply_bc - - ! Remember old VOF - this%vf%VFold=this%vf%VF - - ! Remember old velocity - this%fs%Uold=this%fs%U - this%fs%Vold=this%fs%V - this%fs%Wold=this%fs%W - - ! Prepare old sflaggered density (at n) - call this%fs%get_olddensity(vf=this%vf) - - ! VOF solver step - call this%tvof%start() ! Start VOF timer - call this%vf%advance(dt=this%time%dt,U=this%fs%U,V=this%fs%V,W=this%fs%W) - call this%tvof%stop() ! Stop VOF timer - - ! Prepare new sflaggered viscosity (at n+1) - call this%fs%get_viscosity(vf=this%vf,strat=arithmetic_visc) - - ! Perform sub-iterations - do while (this%time%it.le.this%time%itmax) - - ! Start velocity timer - call this%tvel%start() - - ! Build mid-time velocity - this%fs%U=0.5_WP*(this%fs%U+this%fs%Uold) - this%fs%V=0.5_WP*(this%fs%V+this%fs%Vold) - this%fs%W=0.5_WP*(this%fs%W+this%fs%Wold) - - ! Preliminary mass and momentum transport step at the interface - call this%fs%prepare_advection_upwind(dt=this%time%dt) - - ! Explicit calculation of drho*u/dt from NS - call this%fs%get_dmomdt(this%resU,this%resV,this%resW) - - ! Assemble explicit residual - this%resU=-2.0_WP*this%fs%rho_U*this%fs%U+(this%fs%rho_Uold+this%fs%rho_U)*this%fs%Uold+this%time%dt*this%resU - this%resV=-2.0_WP*this%fs%rho_V*this%fs%V+(this%fs%rho_Vold+this%fs%rho_V)*this%fs%Vold+this%time%dt*this%resV - this%resW=-2.0_WP*this%fs%rho_W*this%fs%W+(this%fs%rho_Wold+this%fs%rho_W)*this%fs%Wold+this%time%dt*this%resW - - ! Form implicit residuals - call this%fs%solve_implicit(this%time%dt,this%resU,this%resV,this%resW) - - ! Apply these residuals - this%fs%U=2.0_WP*this%fs%U-this%fs%Uold+this%resU - this%fs%V=2.0_WP*this%fs%V-this%fs%Vold+this%resV - this%fs%W=2.0_WP*this%fs%W-this%fs%Wold+this%resW - - ! Apply boundary conditions - call this%fs%apply_bcond(this%time%t,this%time%dt) - - ! Stop velocity timer and start pressure timer - call this%tvel%stop() - call this%tpres%start() - - ! Solve Poisson equation - call this%fs%update_laplacian() - call this%fs%correct_mfr() - call this%fs%get_div() - call this%fs%add_surface_tension_jump(dt=this%time%dt,div=this%fs%div,vf=this%vf) - ! call this%fs%add_surface_tension_jump_twoVF(dt=this%time%dt,div=this%fs%div,vf=this%vf) - this%fs%psolv%rhs=-this%fs%cfg%vol*this%fs%div/this%time%dt - this%fs%psolv%sol=0.0_WP - call this%fs%psolv%solve() - call this%fs%shift_p(this%fs%psolv%sol) - - ! Correct velocity - call this%fs%get_pgrad(this%fs%psolv%sol,this%resU,this%resV,this%resW) - this%fs%P=this%fs%P+this%fs%psolv%sol - this%fs%U=this%fs%U-this%time%dt*this%resU/max(epsilon(0.0_WP),this%fs%rho_U) - this%fs%V=this%fs%V-this%time%dt*this%resV/max(epsilon(0.0_WP),this%fs%rho_V) - this%fs%W=this%fs%W-this%time%dt*this%resW/max(epsilon(0.0_WP),this%fs%rho_W) - - ! Apply boundary conditions - call this%fs%apply_bcond(this%time%t,this%time%dt) - - ! Stop pressure timer - call this%tpres%stop() - - ! Increment sub-iteration counter - this%time%it=this%time%it+1 - - end do - - ! Recompute interpolated velocity and divergence - call this%fs%interp_vel(this%Ui,this%Vi,this%Wi) - call this%fs%get_div() - - ! Remove VOF at edge of domain - remove_vof: block - use mpi_f08, only: MPI_ALLREDUCE,MPI_SUM,MPI_IN_PLACE - use parallel, only: MPI_REAL_WP - integer :: n,i,j,k,ierr - this%vof_removed=0.0_WP - do n=1,this%vof_removal_layer%no_ - i=this%vof_removal_layer%map(1,n) - j=this%vof_removal_layer%map(2,n) - k=this%vof_removal_layer%map(3,n) - if (n.le.this%vof_removal_layer%n_) this%vof_removed=this%vof_removed+this%cfg%vol(i,j,k)*this%vf%VF(i,j,k) - this%vf%VF(i,j,k)=0.0_WP - end do - call MPI_ALLREDUCE(MPI_IN_PLACE,this%vof_removed,1,MPI_REAL_WP,MPI_SUM,this%cfg%comm,ierr) - call this%vf%clean_irl_and_band() - end block remove_vof - - ! Analyze drops - analyze_drops: block - use mpi_f08, only: MPI_ALLREDUCE,MPI_SUM,MPI_MAX,MPI_IN_PLACE - use parallel, only: MPI_REAL_WP - use mathtools, only: pi - use string, only: str_medium - real(WP), dimension(:) , allocatable :: dvol - real(WP), dimension(:,:) , allocatable :: dpos - real(WP), dimension(:,:) , allocatable :: dvel - real(WP), dimension(:,:,:), allocatable :: dmoi - real(WP), dimension(:,:) , allocatable :: dgvel - real(WP), dimension(:) , allocatable :: weights - integer :: n,m,ierr,i,j,k,nmax - integer :: iunit - real(WP) :: x,y,z,x0,y0,z0 - character(len=str_medium) :: timestamp - ! Start by performing a CCL - call this%ccl%build(make_label,same_label) - - ! Allocate droplet stats arrays - allocate(dvol(1:this%ccl%nstruct )); dvol=0.0_WP - allocate(dpos(1:this%ccl%nstruct,1:3 )); dpos=0.0_WP - allocate(dvel(1:this%ccl%nstruct,1:3 )); dvel=0.0_WP - allocate(dmoi(1:this%ccl%nstruct,1:3,1:3)); dmoi=0.0_WP - allocate(dgvel(1:this%ccl%nstruct,1:3 )); dgvel=0.0_WP - allocate(weights(1:this%ccl%nstruct )); weights=0.0_WP - - ! First pass to accumulate volume, position, and velocity - do n=1,this%ccl%nstruct - ! Loop over cells in structure - do m=1,this%ccl%struct(n)%n_ - ! Get cell indices - i=this%ccl%struct(n)%map(1,m) - j=this%ccl%struct(n)%map(2,m) - k=this%ccl%struct(n)%map(3,m) - ! Get cell position, accounting for periodicity - x=this%vf%cfg%xm(i)-this%ccl%struct(n)%per(1)*this%vf%cfg%xL - y=this%vf%cfg%ym(j)-this%ccl%struct(n)%per(2)*this%vf%cfg%yL - z=this%vf%cfg%zm(k)-this%ccl%struct(n)%per(3)*this%vf%cfg%zL - ! Accumulate volume, position, and velocity - dvol(n )=dvol(n )+this%cfg%vol(i,j,k)*this%vf%VF(i,j,k) - dpos(n,:)=dpos(n,:)+this%cfg%vol(i,j,k)*this%vf%VF(i,j,k)*[x,y,z] - dvel(n,:)=dvel(n,:)+this%cfg%vol(i,j,k)*this%vf%VF(i,j,k)*[this%Ui(i,j,k),this%Vi(i,j,k),this%Wi(i,j,k)] - end do - end do - call MPI_ALLREDUCE(MPI_IN_PLACE,dvol,1*this%ccl%nstruct,MPI_REAL_WP,MPI_SUM,this%vf%cfg%comm,ierr) - call MPI_ALLREDUCE(MPI_IN_PLACE,dpos,3*this%ccl%nstruct,MPI_REAL_WP,MPI_SUM,this%vf%cfg%comm,ierr) - call MPI_ALLREDUCE(MPI_IN_PLACE,dvel,3*this%ccl%nstruct,MPI_REAL_WP,MPI_SUM,this%vf%cfg%comm,ierr) - - ! Second pass to accumulate moment of inertia - do n=1,this%ccl%nstruct - ! Get drop barycenter - x0=dpos(n,1)/dvol(n) - y0=dpos(n,2)/dvol(n) - z0=dpos(n,3)/dvol(n) - ! Loop over cells in structure - do m=1,this%ccl%struct(n)%n_ - ! Get cell indices - i=this%ccl%struct(n)%map(1,m) - j=this%ccl%struct(n)%map(2,m) - k=this%ccl%struct(n)%map(3,m) - ! Get cell position relative to drop barycenter, accounting for periodicity - x=this%vf%cfg%xm(i)-this%ccl%struct(n)%per(1)*this%vf%cfg%xL-x0 - y=this%vf%cfg%ym(j)-this%ccl%struct(n)%per(2)*this%vf%cfg%yL-y0 - z=this%vf%cfg%zm(k)-this%ccl%struct(n)%per(3)*this%vf%cfg%zL-z0 - ! Accumulate moment of inertia - dmoi(n,1,1)=dmoi(n,1,1)+this%cfg%vol(i,j,k)*this%vf%VF(i,j,k)*(y**2+z**2) - dmoi(n,2,2)=dmoi(n,2,2)+this%cfg%vol(i,j,k)*this%vf%VF(i,j,k)*(z**2+x**2) - dmoi(n,3,3)=dmoi(n,3,3)+this%cfg%vol(i,j,k)*this%vf%VF(i,j,k)*(x**2+y**2) - dmoi(n,1,2)=dmoi(n,1,2)-this%cfg%vol(i,j,k)*this%vf%VF(i,j,k)*(x*y) - dmoi(n,1,3)=dmoi(n,1,3)-this%cfg%vol(i,j,k)*this%vf%VF(i,j,k)*(x*z) - dmoi(n,2,3)=dmoi(n,2,3)-this%cfg%vol(i,j,k)*this%vf%VF(i,j,k)*(y*z) - end do - end do - call MPI_ALLREDUCE(MPI_IN_PLACE,dmoi,9*this%ccl%nstruct,MPI_REAL_WP,MPI_SUM,this%vf%cfg%comm,ierr) - - ! Third pass to generate normalized drop stats - do n=1,this%ccl%nstruct - ! Get drop barycenter, accounting for periodicity - dpos(n,:)=dpos(n,:)/dvol(n) - if (this%vf%cfg%xper.and.dpos(n,1).lt.this%vf%cfg%x(this%vf%cfg%imin)) dpos(n,1)=dpos(n,1)+this%vf%cfg%xL - if (this%vf%cfg%yper.and.dpos(n,2).lt.this%vf%cfg%y(this%vf%cfg%jmin)) dpos(n,2)=dpos(n,2)+this%vf%cfg%yL - if (this%vf%cfg%zper.and.dpos(n,3).lt.this%vf%cfg%z(this%vf%cfg%kmin)) dpos(n,3)=dpos(n,3)+this%vf%cfg%zL - ! Get drop velocity - dvel(n,:)=dvel(n,:)/dvol(n) - end do - - ! Write drop statistics - if (this%drops_evt%occurs().and.this%cfg%amRoot) then - write(timestamp,'(es12.5)') this%time%t - open(newunit=iunit,file='drop_stats/drop_stats_'//trim(adjustl(timestamp))//'.dat',status='replace') - write(iunit,'(A)') '# DropID Volume X Y Z U V W Ixx Iyy Izz Ixy Ixz Iyz' - do n=1,this%ccl%nstruct - write(iunit,'(I6,1X,E12.5,1X,3E12.5,1X,3E12.5,1X,6E12.5,1X,E12.5)') n,dvol(n),dpos(n,1),dpos(n,2),dpos(n,3),& - & dvel(n,1),dvel(n,2),dvel(n,3),dmoi(n,1,1),dmoi(n,2,2),dmoi(n,3,3),dmoi(n,1,2),dmoi(n,1,3),dmoi(n,2,3) - end do - close(iunit) - end if - end block analyze_drops - - ! Output to ensight - if (this%ens_evt%occurs()) then - ! Update surface mesh - update_smesh: block - use irl_fortran_interface, only: getNumberOfPlanes,getNumberOfVertices - integer :: i,j,k,np,nplane - ! Transfer polygons to smesh - call this%vf%update_surfmesh(this%smesh) - ! ! Also populate nplane variable - ! this%smesh%var(1,:)=1.0_WP - ! np=0 - ! do k=this%vf%cfg%kmin_,this%vf%cfg%kmax_ - ! do j=this%vf%cfg%jmin_,this%vf%cfg%jmax_ - ! do i=this%vf%cfg%imin_,this%vf%cfg%imax_ - ! if (this%cfg%VF(i,j,k).lt.2.0_WP*epsilon(1.0_WP)) cycle ! Skip cells below VF threshold - ! do nplane=1,getNumberOfPlanes(this%vf%liquid_gas_interface(i,j,k)) - ! if (getNumberOfVertices(this%vf%interface_polygon(nplane,i,j,k)).gt.0) then - ! np=np+1; this%smesh%var(1,np)=real(getNumberOfPlanes(this%vf%liquid_gas_interface(i,j,k)),WP) - ! this%smesh%var(2,np)=this%vf%thickness(i,j,k) - ! end if - ! end do - ! end do - ! end do - ! end do - end block update_smesh - call this%ens_out%write_data(this%time%t) - end if - - ! Stop timestep timer - call this%tstep%stop() - - ! Perform and output monitoring - call this%fs%get_max() - call this%vf%get_max() - call this%mfile%write() - call this%cflfile%write() - call this%timefile%write() - call this%ljcf_file%write() - - ! Finally, see if it's time to save restart files - if (this%save_evt%occurs()) then - save_restart: block - use irl_fortran_interface - use string, only: str_medium - character(len=str_medium) :: timestamp - real(WP), dimension(:,:,:), allocatable :: P11,P12,P13,P14 - real(WP), dimension(:,:,:), allocatable :: P21,P22,P23,P24 - integer :: i,j,k - real(WP), dimension(4) :: plane - ! Handle IRL data - allocate(P11(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) - allocate(P12(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) - allocate(P13(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) - allocate(P14(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) - allocate(P21(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) - allocate(P22(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) - allocate(P23(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) - allocate(P24(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) - do k=this%vf%cfg%kmino_,this%vf%cfg%kmaxo_ - do j=this%vf%cfg%jmino_,this%vf%cfg%jmaxo_ - do i=this%vf%cfg%imino_,this%vf%cfg%imaxo_ - ! First plane - plane=getPlane(this%vf%liquid_gas_interface(i,j,k),0) - P11(i,j,k)=plane(1); P12(i,j,k)=plane(2); P13(i,j,k)=plane(3); P14(i,j,k)=plane(4) - ! Second plane - plane=0.0_WP - if (getNumberOfPlanes(this%vf%liquid_gas_interface(i,j,k)).eq.2) plane=getPlane(this%vf%liquid_gas_interface(i,j,k),1) - P21(i,j,k)=plane(1); P22(i,j,k)=plane(2); P23(i,j,k)=plane(3); P24(i,j,k)=plane(4) - end do - end do - end do - ! Prefix for files - write(timestamp,'(es12.5)') this%time%t - ! Populate df and write it - call this%df%push(name='t' ,val=this%time%t ) - call this%df%push(name='dt' ,val=this%time%dt) - call this%df%push(name='U' ,var=this%fs%U ) - call this%df%push(name='V' ,var=this%fs%V ) - call this%df%push(name='W' ,var=this%fs%W ) - call this%df%push(name='P' ,var=this%fs%P ) - call this%df%push(name='Pjx',var=this%fs%Pjx ) - call this%df%push(name='Pjy',var=this%fs%Pjy ) - call this%df%push(name='Pjz',var=this%fs%Pjz ) - call this%df%push(name='P11',var=P11 ) - call this%df%push(name='P12',var=P12 ) - call this%df%push(name='P13',var=P13 ) - call this%df%push(name='P14',var=P14 ) - call this%df%push(name='P21',var=P21 ) - call this%df%push(name='P22',var=P22 ) - call this%df%push(name='P23',var=P23 ) - call this%df%push(name='P24',var=P24 ) - call this%df%write(fdata='restart/data_'//trim(adjustl(timestamp))) - ! Deallocate - deallocate(P11,P12,P13,P14,P21,P22,P23,P24) - end block save_restart - end if - - contains - !> Function that identifies cells that need a label - logical function make_label(i,j,k) - implicit none - integer, intent(in) :: i,j,k - if (this%vf%VF(i,j,k).gt.0.0_WP) then - make_label=.true. - else - make_label=.false. - end if - end function make_label - - !> Function that identifies if cell pairs have same label - logical function same_label(i1,j1,k1,i2,j2,k2) - implicit none - integer, intent(in) :: i1,j1,k1,i2,j2,k2 - if (this%vf%VF(i1,j1,k1).gt.0.0_WP .and. this%vf%VF(i2,j2,k2).gt.0.0_WP) then - same_label=.true. - else - same_label=.false. - end if - same_label=.true. - end function same_label - - end subroutine step - - - !> Finalize nozzle simulation - subroutine final(this) - implicit none - class(ljcf), intent(inout) :: this - - ! Deallocate work arrays - deallocate(this%resU,this%resV,this%resW,this%Ui,this%Vi,this%Wi) - - end subroutine final - - -end module ljcf_class \ No newline at end of file diff --git a/examples/ljcf_dimensinal/src/simulation.f90 b/examples/ljcf_dimensinal/src/simulation.f90 deleted file mode 100644 index 922e9e4e9..000000000 --- a/examples/ljcf_dimensinal/src/simulation.f90 +++ /dev/null @@ -1,161 +0,0 @@ -!> Various definitions and tools for running an NGA2 simulation -module simulation - use precision, only: WP - use hit_class, only: hit - use ljcf_class, only: ljcf - use coupler_class, only: coupler - implicit none - private - - !> HIT simulation - type(hit) :: turb - logical :: isInHITGrp - - !> LJCF atomization simulation - type(ljcf) :: atom - - !> Coupler from turb to atom - type(coupler) :: xcpl,ycpl,zcpl - - public :: simulation_init,simulation_run,simulation_final - -contains - - - !> Initialization of our simulation - subroutine simulation_init - use mpi_f08, only: MPI_Group - implicit none - type(MPI_Group) :: hit_group - - ! Initialize atomization simulation - call atom%init() - - ! Create an MPI group using leftmost processors only - ! create_hit_group: block - ! use parallel, only: group,comm - ! use mpi_f08, only: MPI_Group_incl - ! integer, dimension(:), allocatable :: ranks - ! integer, dimension(3) :: coord - ! integer :: n,ngrp,ierr,ny,nz - ! ngrp=atom%cfg%npy*atom%cfg%npz - ! allocate(ranks(ngrp)) - ! ngrp=0 - ! do nz=1,atom%cfg%npz - ! do ny=1,atom%cfg%npy - ! ngrp=ngrp+1 - ! coord=[0,ny-1,nz-1] - ! call MPI_CART_RANK(atom%cfg%comm,coord,ranks(ngrp),ierr) - ! end do - ! end do - ! call MPI_Group_incl(group,ngrp,ranks,hit_group,ierr) - ! if (atom%cfg%iproc.eq.1) then - ! isInHITGrp=.true. - ! else - ! isInHITGrp=.false. - ! end if - ! end block create_hit_group - - ! ! Initialize HIT simulation - ! if (isInHITGrp) call turb%init(group=hit_group,xend=atom%cfg%x(atom%cfg%imin)) - - ! ! If restarting, the domains could be out of sync, so resync - ! ! time by forcing HIT to be at same time as jet - ! if (isInHITGrp) then - ! turb%time%t=atom%time%t - ! turb%time%told=turb%time%t-turb%time%dt - ! end if - - ! ! Initialize couplers from turb to atom - ! create_coupler: block - ! use parallel, only: group - ! xcpl=coupler(src_grp=hit_group,dst_grp=group,name='turb2atom') - ! ycpl=coupler(src_grp=hit_group,dst_grp=group,name='turb2atom') - ! zcpl=coupler(src_grp=hit_group,dst_grp=group,name='turb2atom') - ! if (isInHITGrp) call xcpl%set_src(turb%cfg,'x') - ! if (isInHITGrp) call ycpl%set_src(turb%cfg,'y') - ! if (isInHITGrp) call zcpl%set_src(turb%cfg,'z') - ! call xcpl%set_dst(atom%cfg,'x'); call xcpl%initialize() - ! call ycpl%set_dst(atom%cfg,'y'); call ycpl%initialize() - ! call zcpl%set_dst(atom%cfg,'z'); call zcpl%initialize() - ! end block create_coupler - - end subroutine simulation_init - - - !> Run the simulation - subroutine simulation_run - implicit none - - ! Atomization drives overall time integration - do while (.not.atom%time%done()) - - ! ! Advance HIT simulation and transfer velocity info - ! if (isInHITGrp) then - ! ! Advance HIT with maximum stable dt until caught up - ! advance_hit: block - ! real(WP) :: dt - ! dt=0.15_WP*turb%cfg%min_meshsize/turb%Urms_tgt - ! do while (turb%time%t.le.atom%time%t) - ! call turb%step(dt) - ! end do - ! end block advance_hit - ! end if - - ! Handle coupling between HIT and atomization simulation - coupling: block - ! ! Push data from HIT simulation - ! if (isInHITGrp) then - ! push_velocity: block - ! real(WP) :: rescaling,tinterp - ! rescaling=turb%ti/turb%Urms_tgt - ! tinterp=(turb%time%t-atom%time%t)/(turb%time%t-turb%time%told) - ! turb%resU=rescaling*((1.0_WP-tinterp)*turb%fs%U+tinterp*turb%fs%Uold); call xcpl%push(turb%resU) - ! turb%resV=rescaling*((1.0_WP-tinterp)*turb%fs%V+tinterp*turb%fs%Vold); call ycpl%push(turb%resV) - ! turb%resW=rescaling*((1.0_WP-tinterp)*turb%fs%W+tinterp*turb%fs%Wold); call zcpl%push(turb%resW) - ! end block push_velocity - ! end if - ! ! Transfer and pull - ! call xcpl%transfer(); call xcpl%pull(atom%resU) - ! call ycpl%transfer(); call ycpl%pull(atom%resV) - ! call zcpl%transfer(); call zcpl%pull(atom%resW) - ! Apply time-dependent Dirichlet condition - apply_boundary_condition: block - use param, only: param_read - use tpns_class, only: bcond - type(bcond), pointer :: mybc - integer :: n,i,j,k - real(WP) :: air_vel - call atom%fs%get_bcond('inflow',mybc) - call param_read("Air velocity",air_vel) - do n=1,mybc%itr%no_ - i=mybc%itr%map(1,n); j=mybc%itr%map(2,n); k=mybc%itr%map(3,n) - atom%fs%U(i ,j,k)=air_vel !atom%resU(i ,j,k)+1.0_WP - atom%fs%V(i-1,j,k)=0.0_WP !atom%resV(i-1,j,k) - atom%fs%W(i-1,j,k)=0.0_WP !atom%resW(i-1,j,k) - end do - end block apply_boundary_condition - end block coupling - - ! Advance atomization simulation - call atom%step() - - end do - - end subroutine simulation_run - - - !> Finalize the NGA2 simulation - subroutine simulation_final - implicit none - - ! Finalize atomization simulation - call atom%final() - - ! Finalize HIT simulation - ! if (isInHITGrp) call turb%final() - - end subroutine simulation_final - - -end module simulation \ No newline at end of file diff --git a/examples/ljcf_dimensinal_ib/GNUmakefile b/examples/ljcf_dimensinal_ib/GNUmakefile deleted file mode 100644 index f51ff99ec..000000000 --- a/examples/ljcf_dimensinal_ib/GNUmakefile +++ /dev/null @@ -1,47 +0,0 @@ -# NGA location if not yet defined -NGA_HOME ?= ../.. - -# Compilation parameters -PRECISION = DOUBLE -USE_MPI = TRUE -USE_FFTW = TRUE -USE_HYPRE = TRUE -USE_LAPACK= TRUE -USE_IRL = TRUE -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 two_phase particles constant_density 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/ljcf_dimensinal_ib/README b/examples/ljcf_dimensinal_ib/README deleted file mode 100644 index 5e5f940b6..000000000 --- a/examples/ljcf_dimensinal_ib/README +++ /dev/null @@ -1 +0,0 @@ -This case simulates the break-up of a liquid ligament in a turbulent crossflow. \ No newline at end of file diff --git a/examples/ljcf_dimensinal_ib/input b/examples/ljcf_dimensinal_ib/input deleted file mode 100644 index f164beb4b..000000000 --- a/examples/ljcf_dimensinal_ib/input +++ /dev/null @@ -1,49 +0,0 @@ -# Parallelization -Partition : 8 1 1 -I/O partition : 1 1 1 - -# Mesh definition -X ljcf : 0.108 # 2D -Lx : 0.432 # 8D -Ly : 0.432 # 8D for testing - should be 0.864 # 16D -Lz : 0.216 # 4D -nx : 128 # 8 cells/D -ny : 128 # Reduced for 8D for testing - should be 128 -nz : 64 - -# Injector geometry -Injector radius 1 : 0.027 # m -Injector radius 2 : 0.025 # m -Injector height 1 : 0.05 # m -Injector height 2 : 0.07 # m - -# Flow conditions -Jet diameter : 0.054 # m -End Injection Time : 0.267 # s sqrt(2*H/g) = sqrt(2*0.35 m / 9.81 m/s^2) = 0.267 s -Jet location : 0 -Liquid density : 1000 # kg/m^3 -Gas density : 1.2 # kg/m^3 -Liquid viscosity : 1e-3 # Pa-s -Gas viscosity : 1.8e-5 # Pa-s -Surface tension : 0.072 # N/m -Gravitational acceleration : 9.81 # m/s^2 -Air velocity : 11 # m/s -Target Re_lambda : 45 -Turbulence intensity : 0.05 - -# Time integration -Max timestep size : 2e-4 # s -Max cfl number : 1.0 -Max time : 0.4 # s - -# Pressure solver -Pressure tolerance : 1e-4 -Pressure iteration : 100 - -# Data output -Ensight output period : 2.5e-3 # s -Restart output period : 0.05 # s - -# Data restart -#Restart from : 1.00000E+01 -#HIT restart : hit_1.00000E+01 diff --git a/examples/ljcf_dimensinal_ib/src/Make.package b/examples/ljcf_dimensinal_ib/src/Make.package deleted file mode 100644 index ac9df0728..000000000 --- a/examples/ljcf_dimensinal_ib/src/Make.package +++ /dev/null @@ -1,2 +0,0 @@ -# List here the extra files here -f90EXE_sources += simulation.f90 hit_class.f90 ljcf_class.f90 diff --git a/examples/ljcf_dimensinal_ib/src/hit_class.f90 b/examples/ljcf_dimensinal_ib/src/hit_class.f90 deleted file mode 100644 index 792e384df..000000000 --- a/examples/ljcf_dimensinal_ib/src/hit_class.f90 +++ /dev/null @@ -1,428 +0,0 @@ -!> Definition for an hit class -module hit_class - use precision, only: WP - use config_class, only: config - use fft3d_class, only: fft3d - use incomp_class, only: incomp - use timetracker_class, only: timetracker - use monitor_class, only: monitor - use pardata_class, only: pardata - use event_class, only: event - implicit none - private - - public :: hit - - !> HIT object - type :: hit - !> Config - type(config) :: cfg !< Mesh for solver - !> Flow solver - type(incomp) :: fs !< Incompressible flow solver - type(fft3d) :: ps !< FFT-based linear solver - type(timetracker) :: time !< Time info - !> Simulation monitor file - type(monitor) :: mfile !< General simulation monitoring - !> Work arrays - real(WP), dimension(:,:,:,:,:), allocatable :: gradU !< Velocity gradient - real(WP), dimension(:,:,:,:), allocatable :: SR !< Strain rate tensor - real(WP), dimension(:,:,:), allocatable :: resU,resV,resW !< Residuals - !> Turbulence parameters - real(WP) :: ti ! Turbulence intensity - real(WP) :: visc,meanU,meanV,meanW - real(WP) :: Urms_tgt,tke_tgt,eps_tgt ! u',k, and dissipation rate - real(WP) :: tko_tgt,eta_tgt ! Kolmogorov time and length scales - real(WP) :: Rel_tgt,Ret_tgt ! Lambda and turbulent Reynolds numbers - real(WP) :: tau_tgt ! Eddy turnover time - real(WP) :: Urms,tke,eps,Ret,Rel,eta,ell ! Current turbulence parameters (ell is large eddy size) - !> Forcing constant - real(WP) :: forcing - !> Provide a pardata object for restarts - logical :: restarted - type(pardata) :: df - type(event) :: save_evt - contains - procedure, private :: compute_stats !< Turbulence information - procedure :: init !< Initialize HIT simulation - procedure :: step !< Advance HIT simulation by one time step - procedure :: final !< Finalize HIT simulation - end type hit - - -contains - - - !> Compute turbulence stats (assumes rho=1) - subroutine compute_stats(this) - use mpi_f08, only: MPI_ALLREDUCE,MPI_SUM - use parallel, only: MPI_REAL_WP - class(hit), intent(inout) :: this - real(WP) :: myTKE,myEPS - integer :: i,j,k,ierr - ! Compute mean velocities - call this%fs%cfg%integrate(A=this%fs%U,integral=this%meanU); this%meanU=this%meanU/this%fs%cfg%vol_total - call this%fs%cfg%integrate(A=this%fs%V,integral=this%meanV); this%meanV=this%meanV/this%fs%cfg%vol_total - call this%fs%cfg%integrate(A=this%fs%W,integral=this%meanW); this%meanW=this%meanW/this%fs%cfg%vol_total - ! Compute strainrate and grad(U) - call this%fs%get_strainrate(SR=this%SR) - call this%fs%get_gradu(gradu=this%gradU) - ! Compute current TKE and dissipation rate - myTKE=0.0_WP - myEPS=0.0_WP - do k=this%fs%cfg%kmin_,this%fs%cfg%kmax_ - do j=this%fs%cfg%jmin_,this%fs%cfg%jmax_ - do i=this%fs%cfg%imin_,this%fs%cfg%imax_ - myTKE=myTKE+0.5_WP*((this%fs%U(i,j,k)-this%meanU)**2+(this%fs%V(i,j,k)-this%meanV)**2+(this%fs%W(i,j,k)-this%meanW)**2)*this%fs%cfg%vol(i,j,k) - myEPS=myEPS+2.0_WP*this%fs%cfg%vol(i,j,k)*(this%SR(1,i,j,k)**2+this%SR(2,i,j,k)**2+this%SR(3,i,j,k)**2+2.0_WP*(this%SR(4,i,j,k)**2+this%SR(5,i,j,k)**2+this%SR(6,i,j,k)**2)) - end do - end do - end do - call MPI_ALLREDUCE(myTKE,this%tke,1,MPI_REAL_WP,MPI_SUM,this%fs%cfg%comm,ierr); this%tke=this%tke/this%fs%cfg%vol_total - call MPI_ALLREDUCE(myEPS,this%eps,1,MPI_REAL_WP,MPI_SUM,this%fs%cfg%comm,ierr); this%eps=this%eps*this%visc/this%fs%cfg%vol_total - ! Compute standard parameters for HIT - this%Urms=sqrt(2.0_WP/3.0_WP*this%tke) - this%Ret=this%tke**2.0_WP/(this%visc*this%eps) - this%Rel=sqrt(20.0_WP*this%Ret/3.0_WP) - this%eta=((this%visc)**3.0_WP/this%eps)**0.25_WP - this%ell=(2.0_WP*this%tke/3.0_WP)**1.5_WP/this%eps - end subroutine compute_stats - - - !> Initialization of HIT simulation - subroutine init(this,group,xend) - use mpi_f08, only: MPI_Group - implicit none - class(hit), intent(inout) :: this - type(MPI_Group), intent(in) :: group - real(WP) :: xend - - ! Create the HIT mesh - create_config: block - use sgrid_class, only: cartesian,sgrid - use param, only: param_read - real(WP), dimension(:), allocatable :: x,y - integer, dimension(3) :: partition - type(sgrid) :: grid - integer :: j,ny - real(WP) :: Ly - ! Read in grid definition - call param_read('Ly',Ly); call param_read('ny',ny); allocate(y(ny+1)); allocate(x(ny+1)) - ! Create simple rectilinear grid in y and z - do j=1,ny+1 - y(j)=real(j-1,WP)/real(ny,WP)*Ly-0.5_WP*Ly - end do - ! Same grid in x, but shifted so it ends at xend - x=y-y(ny+1)+xend - ! General serial grid object - grid=sgrid(coord=cartesian,no=1,x=x,y=y,z=y,xper=.true.,yper=.true.,zper=.true.,name='HIT') - ! Read in partition - call param_read('Partition',partition,short='p'); partition(1)=1 - ! Create partitioned grid without walls - this%cfg=config(grp=group,decomp=partition,grid=grid) - end block create_config - - ! Initialize the work arrays - allocate_work_arrays: block - allocate(this%resU(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) - allocate(this%resV(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) - allocate(this%resW(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) - allocate(this%SR (1:6,this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) - allocate(this%gradU(1:3,1:3,this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) - end block allocate_work_arrays - - - ! Initialize time tracker with 2 subiterations - initialize_timetracker: block - use param, only: param_read - this%time=timetracker(amRoot=this%cfg%amRoot) - call param_read('Max timestep size',this%time%dtmax) - call param_read('Max cfl number',this%time%cflmax) - this%time%dt=this%time%dtmax - this%time%itmax=2 - end block initialize_timetracker - - - ! Create a single-phase periodic flow solver - create_flow_solver: block - use mathtools, only: Pi - use param, only: param_read - ! Create flow solver - this%fs=incomp(cfg=this%cfg,name='NS solver') - ! Set density to 1.0 - this%fs%rho=1.0_WP - ! Set viscosity from Reynolds number - call param_read("Gas viscosity",this%visc); - this%fs%visc=this%visc - ! Prepare and configure pressure solver - this%ps=fft3d(cfg=this%cfg,name='Pressure',nst=7) - ! Setup the solver - call this%fs%setup(pressure_solver=this%ps) - end block create_flow_solver - - - ! Prepare initial velocity field - initialize_velocity: block - use random, only: random_normal - use mathtools, only: Pi - use param, only: param_read,param_exists - use messager, only: log - use string, only: str_long - character(str_long) :: message - real(WP) :: max_forcing_estimate - integer :: i,j,k - ! Read in turbulence intensity for turbulence injection - call param_read('Turbulence intensity',this%ti) - ! Read in target Re_lambda and convert to target Urms - call param_read('Target Re_lambda',this%Urms_tgt) - this%Urms_tgt=this%visc/(3.0_WP*this%cfg%xL)*this%Urms_tgt**2 - ! Calculate other target quantities assuming l=0.2*xL - this%tke_tgt=1.5_WP*this%Urms_tgt**2 - this%eps_tgt=5.0_WP*this%Urms_tgt**3/this%cfg%xL - this%tko_tgt=sqrt(this%visc/this%eps_tgt) - this%eta_tgt=(this%visc**3/this%eps_tgt)**(0.25_WP) - this%Rel_tgt=sqrt(3.0_WP*this%Urms_tgt*this%cfg%xL/this%visc) - this%Ret_tgt=this%tke_tgt**2/(this%eps_tgt*this%visc) - this%tau_tgt=2.0_WP*this%tke_tgt/(3.0_WP*this%eps_tgt) - ! Read in forcing parameter (we need dt Urms =",es12.5)') this%Urms_tgt; call log(message) - write(message,'("[HIT setup] => Re_lambda =",es12.5)') this%Rel_tgt; call log(message) - write(message,'("[HIT setup] => Re_turb =",es12.5)') this%Ret_tgt; call log(message) - write(message,'("[HIT setup] => Kolmogorov Lscale =",es12.5)') this%eta_tgt; call log(message) - write(message,'("[HIT setup] => Kolmogorov Tscale =",es12.5)') this%tko_tgt; call log(message) - write(message,'("[HIT setup] => Epsilon =",es12.5)') this%eps_tgt; call log(message) - write(message,'("[HIT setup] => Eddyturnover time =",es12.5)') this%tau_tgt; call log(message) - end if - ! Gaussian initial field - do k=this%fs%cfg%kmin_,this%fs%cfg%kmax_ - do j=this%fs%cfg%jmin_,this%fs%cfg%jmax_ - do i=this%fs%cfg%imin_,this%fs%cfg%imax_ - this%fs%U(i,j,k)=random_normal(m=0.0_WP,sd=this%Urms_tgt) - this%fs%V(i,j,k)=random_normal(m=0.0_WP,sd=this%Urms_tgt) - this%fs%W(i,j,k)=random_normal(m=0.0_WP,sd=this%Urms_tgt) - end do - end do - end do - call this%fs%cfg%sync(this%fs%U) - call this%fs%cfg%sync(this%fs%V) - call this%fs%cfg%sync(this%fs%W) - ! Compute mean and remove it from the velocity field to obtain =0 - call this%fs%cfg%integrate(A=this%fs%U,integral=this%meanU); this%meanU=this%meanU/this%fs%cfg%vol_total; this%fs%U=this%fs%U-this%meanU - call this%fs%cfg%integrate(A=this%fs%V,integral=this%meanV); this%meanV=this%meanV/this%fs%cfg%vol_total; this%fs%V=this%fs%V-this%meanV - call this%fs%cfg%integrate(A=this%fs%W,integral=this%meanW); this%meanW=this%meanW/this%fs%cfg%vol_total; this%fs%W=this%fs%W-this%meanW - ! Project to ensure divergence-free - call this%fs%get_div() - this%fs%psolv%rhs=-this%fs%cfg%vol*this%fs%div - this%fs%psolv%sol=0.0_WP - call this%fs%psolv%solve() - call this%fs%shift_p(this%fs%psolv%sol) - call this%fs%get_pgrad(this%fs%psolv%sol,this%resU,this%resV,this%resW) - this%fs%P=this%fs%P+this%fs%psolv%sol - this%fs%U=this%fs%U-this%resU - this%fs%V=this%fs%V-this%resV - this%fs%W=this%fs%W-this%resW - ! Calculate divergence - call this%fs%get_div() - end block initialize_velocity - - - ! Handle restart here - perform_restart: block - use param, only: param_read - use string, only: str_medium - use filesys, only: makedir,isdir - character(len=str_medium) :: filename - integer, dimension(3) :: iopartition - ! Create event for saving restart files - this%save_evt=event(this%time,'HIT restart output') - call param_read('Restart output period',this%save_evt%tper) - ! Read in the partition for I/O - call param_read('I/O partition',iopartition) - ! Check if a restart file was provided - call param_read('HIT restart',filename,default='') - this%restarted=.false.; if (len_trim(filename).gt.0) this%restarted=.true. - ! Perform pardata initialization - if (this%restarted) then - ! Read in the file - call this%df%initialize(pg=this%cfg,iopartition=iopartition,fdata='restart/'//trim(filename)) - ! Put the data at the right place - call this%df%pull(name='U',var=this%fs%U) - call this%df%pull(name='V',var=this%fs%V) - call this%df%pull(name='W',var=this%fs%W) - call this%df%pull(name='P',var=this%fs%P) - ! Update divergence - call this%fs%get_div() - ! Also update time - call this%df%pull(name='t' ,val=this%time%t ) - call this%df%pull(name='dt',val=this%time%dt) - this%time%told=this%time%t-this%time%dt - !this%time%dt=this%time%dtmax !< Force max timestep size anyway - else - ! Prepare a new directory for storing files for restart - if (this%cfg%amRoot) then - if (.not.isdir('restart')) call makedir('restart') - end if - ! If we are not restarting, we will still need a datafile for saving restart files - call this%df%initialize(pg=this%cfg,iopartition=iopartition,filename=trim(this%cfg%name),nval=2,nvar=4) - this%df%valname=['dt','t ']; this%df%varname=['U','V','W','P'] - end if - end block perform_restart - - - ! Create monitoring file - create_monitor: block - ! Prepare some info about turbulence - call this%fs%get_max() - call this%compute_stats() - ! Create simulation monitor - this%mfile=monitor(this%fs%cfg%amRoot,'hit') - call this%mfile%add_column(this%time%n,'Timestep number') - call this%mfile%add_column(this%time%t,'Time') - call this%mfile%add_column(this%time%dt,'Timestep size') - call this%mfile%add_column(this%fs%Umax,'Umax') - call this%mfile%add_column(this%fs%Vmax,'Vmax') - call this%mfile%add_column(this%fs%Wmax,'Wmax') - call this%mfile%add_column(this%Ret,'Re_turb') - call this%mfile%add_column(this%Rel,'Re_lambda') - call this%mfile%add_column(this%Urms,'Urms') - call this%mfile%add_column(this%TKE,'TKE') - call this%mfile%add_column(this%EPS,'Epsilon') - call this%mfile%add_column(this%ell,'Large eddy size') - call this%mfile%add_column(this%eta,'Kolmogorov length') - call this%mfile%write() - end block create_monitor - - - end subroutine init - - - !> Take one time step with specified dt - subroutine step(this,dt) - implicit none - class(hit), intent(inout) :: this - real(WP), intent(in) :: dt - - ! Increment time based on provided dt - this%time%dt=dt; call this%time%increment() - - ! Remember old velocity - this%fs%Uold=this%fs%U - this%fs%Vold=this%fs%V - this%fs%Wold=this%fs%W - - ! Perform sub-iterations - do while (this%time%it.le.this%time%itmax) - - ! Build mid-time velocity - this%fs%U=0.5_WP*(this%fs%U+this%fs%Uold) - this%fs%V=0.5_WP*(this%fs%V+this%fs%Vold) - this%fs%W=0.5_WP*(this%fs%W+this%fs%Wold) - - ! Explicit calculation of drho*u/dt from NS - call this%fs%get_dmomdt(this%resU,this%resV,this%resW) - - ! Assemble explicit residual - this%resU=-2.0_WP*(this%fs%U-this%fs%Uold)+this%time%dt*this%resU - this%resV=-2.0_WP*(this%fs%V-this%fs%Vold)+this%time%dt*this%resV - this%resW=-2.0_WP*(this%fs%W-this%fs%Wold)+this%time%dt*this%resW - - ! Apply HIT forcing - hit_forcing: block - use mpi_f08, only: MPI_ALLREDUCE,MPI_SUM - use parallel, only: MPI_REAL_WP - real(WP) :: myTKE,A,myEPSp,EPSp - integer :: i,j,k,ierr - ! Calculate mean velocity - call this%fs%cfg%integrate(A=this%fs%U,integral=this%meanU); this%meanU=this%meanU/this%fs%cfg%vol_total - call this%fs%cfg%integrate(A=this%fs%V,integral=this%meanV); this%meanV=this%meanV/this%fs%cfg%vol_total - call this%fs%cfg%integrate(A=this%fs%W,integral=this%meanW); this%meanW=this%meanW/this%fs%cfg%vol_total - ! Calculate TKE and pseudo-EPS - call this%fs%get_gradu(gradu=this%gradU) - myTKE=0.0_WP; myEPSp=0.0_WP - do k=this%fs%cfg%kmin_,this%fs%cfg%kmax_ - do j=this%fs%cfg%jmin_,this%fs%cfg%jmax_ - do i=this%fs%cfg%imin_,this%fs%cfg%imax_ - myTKE =myTKE +0.5_WP*((this%fs%U(i,j,k)-this%meanU)**2+(this%fs%V(i,j,k)-this%meanV)**2+(this%fs%W(i,j,k)-this%meanW)**2)*this%fs%cfg%vol(i,j,k) - myEPSp=myEPSp+this%fs%cfg%vol(i,j,k)*(this%gradU(1,1,i,j,k)**2+this%gradU(1,2,i,j,k)**2+this%gradU(1,3,i,j,k)**2+& - & this%gradU(2,1,i,j,k)**2+this%gradU(2,2,i,j,k)**2+this%gradU(2,3,i,j,k)**2+& - & this%gradU(3,1,i,j,k)**2+this%gradU(3,2,i,j,k)**2+this%gradU(3,3,i,j,k)**2) - end do - end do - end do - call MPI_ALLREDUCE(myTKE,this%tke,1,MPI_REAL_WP,MPI_SUM,this%fs%cfg%comm,ierr); this%tke=this%tke/this%fs%cfg%vol_total - call MPI_ALLREDUCE(myEPSp,EPSp,1,MPI_REAL_WP,MPI_SUM,this%fs%cfg%comm,ierr); EPSp=EPSp*this%visc/this%fs%cfg%vol_total - A=(EPSp-this%forcing*(this%tke-this%tke_tgt)/this%tau_tgt)/(2.0_WP*this%tke) - this%resU=this%resU+A*this%time%dt*(this%fs%U-this%meanU) - this%resV=this%resV+A*this%time%dt*(this%fs%V-this%meanV) - this%resW=this%resW+A*this%time%dt*(this%fs%W-this%meanW) - end block hit_forcing - - ! Apply these residuals - this%fs%U=2.0_WP*this%fs%U-this%fs%Uold+this%resU - this%fs%V=2.0_WP*this%fs%V-this%fs%Vold+this%resV - this%fs%W=2.0_WP*this%fs%W-this%fs%Wold+this%resW - - ! Solve Poisson equation - call this%fs%get_div() - this%fs%psolv%rhs=-this%fs%cfg%vol*this%fs%div/this%time%dt - this%fs%psolv%sol=0.0_WP - call this%fs%psolv%solve() - call this%fs%shift_p(this%fs%psolv%sol) - - ! Correct velocity - call this%fs%get_pgrad(this%fs%psolv%sol,this%resU,this%resV,this%resW) - this%fs%P=this%fs%P+this%fs%psolv%sol - this%fs%U=this%fs%U-this%time%dt*this%resU - this%fs%V=this%fs%V-this%time%dt*this%resV - this%fs%W=this%fs%W-this%time%dt*this%resW - - ! Increment sub-iteration counter - this%time%it=this%time%it+1 - - end do - - ! Recompute divergence - call this%fs%get_div() - - ! Perform and output monitoring - call this%fs%get_max() - call this%compute_stats() - call this%mfile%write() - - ! Finally, see if it's time to save restart files - if (this%save_evt%occurs()) then - save_restart: block - use string, only: str_medium - character(len=str_medium) :: timestamp - ! Prefix for files - write(timestamp,'(es12.5)') this%time%t - ! Populate df and write it - call this%df%push(name='t' ,val=this%time%t ) - call this%df%push(name='dt',val=this%time%dt) - call this%df%push(name='U' ,var=this%fs%U ) - call this%df%push(name='V' ,var=this%fs%V ) - call this%df%push(name='W' ,var=this%fs%W ) - call this%df%push(name='P' ,var=this%fs%P ) - call this%df%write(fdata='restart/hit_'//trim(adjustl(timestamp))) - end block save_restart - end if - - end subroutine step - - - !> Finalize nozzle simulation - subroutine final(this) - implicit none - class(hit), intent(inout) :: this - - ! Deallocate work arrays - deallocate(this%resU,this%resV,this%resW,this%gradU,this%SR) - - end subroutine final - - -end module hit_class \ No newline at end of file diff --git a/examples/ljcf_dimensinal_ib/src/ljcf_class.f90 b/examples/ljcf_dimensinal_ib/src/ljcf_class.f90 deleted file mode 100644 index 6e5d3d05e..000000000 --- a/examples/ljcf_dimensinal_ib/src/ljcf_class.f90 +++ /dev/null @@ -1,1040 +0,0 @@ -!> Definition for a ljcf atomization class -module ljcf_class - use precision, only: WP - use ibconfig_class, only: ibconfig - use iterator_class, only: iterator - use ensight_class, only: ensight - use surfmesh_class, only: surfmesh - use hypre_str_class, only: hypre_str - !use ddadi_class, only: ddadi - use vfs_class, only: vfs - use tpns_class, only: tpns - use timetracker_class, only: timetracker - use event_class, only: event - use monitor_class, only: monitor - use timer_class, only: timer - use pardata_class, only: pardata - use cclabel_class, only: cclabel - use irl_fortran_interface - implicit none - private - - public :: ljcf - - integer :: ierr - - !> ljcf object - type :: ljcf - - !> Config - type(ibconfig) :: cfg - - !> Flow solver - type(vfs) :: vf !< Volume fraction solver - type(tpns) :: fs !< Two-phase flow solver - type(hypre_str) :: ps !< Structured Hypre linear solver for pressure - !type(ddadi) :: vs !< DDADI solver for velocity - type(timetracker) :: time !< Time info - type(cclabel) :: ccl !< CCLabel for local Weber number calculation - - !> Ensight postprocessing - type(surfmesh) :: smesh !< Surface mesh for interface - type(ensight) :: ens_out !< Ensight output for flow variables - type(event) :: ens_evt !< Event trigger for Ensight output - - !> Simulation monitor file - type(monitor) :: mfile !< General simulation monitoring - type(monitor) :: cflfile !< CFL monitoring - type(monitor) :: ljcf_file !< LJCF simulation monitoring - - !> Work arrays - real(WP), dimension(:,:,:), allocatable :: resU,resV,resW !< Residuals - real(WP), dimension(:,:,:), allocatable :: Ui,Vi,Wi !< Cell-centered velocities - - !> Iterator for VOF removal - type(iterator) :: vof_removal_layer !< Edge of domain where we actively remove VOF - real(WP) :: vof_removed !< Integral of VOF removed - integer :: nlayer=4 !< Size of buffer layer for VOF removal - - !> Timing info - type(monitor) :: timefile !< Timing monitoring - type(timer) :: tstep !< Timer for step - type(timer) :: tvel !< Timer for velocity - type(timer) :: tpres !< Timer for pressure - type(timer) :: tvof !< Timer for VOF - - !> Provide a pardata and an event tracker for saving restarts - type(event) :: save_evt - type(pardata) :: df - logical :: restarted - - !> Problem definition - real(WP) :: djet, Vjet - real(WP), dimension(:), allocatable :: xjet - integer :: relax_model, nwall - real(WP) :: gravity, endInjectionTime, InjectionVelocity - - contains - procedure :: init !< Initialize nozzle simulation - procedure :: step !< Advance nozzle simulation by one time step - procedure :: final !< Finalize nozzle simulation - end type ljcf - - -contains - - !> Initialization of ljcf simulation - subroutine init(this) - implicit none - class(ljcf), intent(inout) :: this - - ! Create the ljcf mesh - create_config: block - use sgrid_class, only: cartesian,sgrid - use param, only: param_read - use parallel, only: group - real(WP), dimension(:), allocatable :: x,y,z - integer, dimension(3) :: partition - type(sgrid) :: grid - integer :: i,j,k,nx,ny,nz - real(WP) :: Lx,Ly,Lz,xlig - ! Read in grid definition - call param_read('Lx',Lx); call param_read('nx',nx); allocate(x(nx+1)); call param_read('X ljcf',xlig) - 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-xlig - 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=3,x=x,y=y,z=z,xper=.false.,yper=.false.,zper=.true.,name='ljcf') - ! Read in partition - call param_read('Partition',partition,short='p') - ! Create partitioned grid without walls - this%cfg=ibconfig(grp=group,decomp=partition,grid=grid) - - - ! Create IB walls for this config - create_walls: block - use mathtools, only: twoPi - use ibconfig_class, only: bigot, sharp - use param, only: param_read - integer :: i,j,k - real(WP) :: r, y, y1, y2 - real(WP) :: G1, G2, Gcap - real(WP) :: R1, R2, h1, h2 - real(WP) :: y0, ycap, d_cyln, d_wall - - ! Read parameters - call param_read('Injector radius 1', R1) - call param_read('Injector radius 2', R2) - call param_read('Injector height 1', h1) - call param_read('Injector height 2', h2) - - ! Reference axial location (start of nozzle) - y0 = this%cfg%y(this%cfg%jmino) - y1 = y0 + h1 - y2 = y0 + h2 - - do k = this%cfg%kmino_, this%cfg%kmaxo_ - do j = this%cfg%jmino_, this%cfg%jmaxo_ - do i = this%cfg%imino_, this%cfg%imaxo_ - - ! Coordinates of this point - y = this%cfg%ym(j) - r = sqrt( this%cfg%xm(i)**2 + this%cfg%zm(k)**2) - - - ! Start with fluid everywhere - this%cfg%Gib(i,j,k) = 0.0 !-huge(1.0) - - ! Lower region (y < y1) - ! -------------------------------------------------- - if (y < y1 ) then - - if (r < R1) then ! Inside cylinder - ! Distance to wall between cylinders - if (r < R2) then ! Inside injector - d_wall = sqrt( (r-R2)**2 + (y-y1)**2 ) - else ! Between cylinders - d_wall = y1 - y - end if - ! Distance to cylinder - d_cyln = R1 - r - this%cfg%Gib(i,j,k) = -min(d_wall, d_cyln) - else ! Outside cylinder - ! Distance to top wall - d_wall = y2 - y - ! Distance to cylinder - d_cyln = r - R1 - this%cfg%Gib(i,j,k) = min(d_wall, d_cyln) - end if - - ! Middle region (y1 < y < y2) - ! -------------------------------------------------- - else if (y < y2) then - if (r < R2) then ! Inside cylinder - this%cfg%Gib(i,j,k) = r - R2 - else ! Outside cylinder - d_wall = y2 - y ! distance to top wall - if (r < R1) then ! Between cylinders - d_wall = min(d_wall, y - y1) - else ! Distance to edge of lower cylinder - d_wall = min(d_wall, sqrt( (r-R1)**2 + (y-y1)**2 ) ) - end if - d_cyln = r - R2 - this%cfg%Gib(i,j,k) = min(d_wall, d_cyln) - end if - - ! Upper region (y > y2) - ! -------------------------------------------------- - else - if (r < R2) then ! Inside injector - this%cfg%Gib(i,j,k) = -sqrt( (r-R2)**2 + (y-y2)**2 ) - else - this%cfg%Gib(i,j,k) = y2-y - end if - end if - - end do - end do - end do - - ! Compute normals - call this%cfg%calculate_normal() - - ! Compute volume fraction - call this%cfg%calculate_vf(method=sharp, allow_zero_vf=.false.) - - end block create_walls - - end block create_config - - - ! Initialize time tracker with 2 subiterations - initialize_timetracker: block - use param, only: param_read - this%time=timetracker(amRoot=this%cfg%amRoot) - call param_read('Max timestep size',this%time%dtmax) - call param_read('Max cfl number',this%time%cflmax) - call param_read('Max time',this%time%tmax) - this%time%dt=this%time%dtmax - this%time%itmax=2 - end block initialize_timetracker - - - ! Allocate work arrays - allocate_work_arrays: block - allocate(this%resU(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) - allocate(this%resV(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) - allocate(this%resW(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) - allocate(this%Ui (this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) - allocate(this%Vi (this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) - allocate(this%Wi (this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) - end block allocate_work_arrays - - ! Set up walls before solvers are initialized - create_walls: block - use param, only: param_read,param_getsize - integer :: i,j,k,njet - ! Initialize liquid jet(s) - call param_read('Jet diameter',this%djet) - njet = param_getsize('Jet location') - allocate(this%xjet(njet)) - call param_read('Jet location',this%xjet) - call param_read('Gravitational acceleration',this%gravity) - call param_read('End Injection Time',this%endInjectionTime) - ! Number of wall cells - call param_read('Wall cells in domain', this%nwall, default=0) - 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 (wall(this%cfg%pgrid,i,j,k)) then - this%cfg%VF(i,j,k)=0.0_WP - end if - end do - end do - end do - end block create_walls - - ! Initialize our VOF solver and field - create_and_initialize_vof: block - use vfs_class, only: remap,VFlo,VFhi,plicnet,r2pnet - use mms_geom, only: cube_refine_vol - use param, only: param_read - integer :: i,j,k,n,si,sj,sk - real(WP), dimension(3,8) :: cube_vertex - real(WP), dimension(3) :: v_cent,a_cent - real(WP) :: vol,area - integer, parameter :: amr_ref_lvl=4 - ! Create a VOF solver - call this%vf%initialize(cfg=this%cfg,reconstruction_method=plicnet,transport_method=remap,name='VOF') - this%vf%thin_thld_min=0.0_WP - this%vf%flotsam_thld=0.0_WP - this%vf%maxcurv_times_mesh=1.0_WP - ! Initialize the interface to a ljcf - do k=this%vf%cfg%kmino_,this%vf%cfg%kmaxo_ - do j=this%vf%cfg%jmino_,this%vf%cfg%jmaxo_ - do i=this%vf%cfg%imino_,this%vf%cfg%imaxo_ - ! Set cube vertices - n=0 - do sk=0,1 - do sj=0,1 - do si=0,1 - n=n+1; cube_vertex(:,n)=[this%vf%cfg%x(i+si),this%vf%cfg%y(j+sj),this%vf%cfg%z(k+sk)] - end do - end do - end do - ! Call adaptive refinement code to get volume and barycenters recursively - vol=0.0_WP; area=0.0_WP; v_cent=0.0_WP; a_cent=0.0_WP - if (j.le.this%vf%cfg%jmin) then - call cube_refine_vol(cube_vertex,vol,area,v_cent,a_cent,levelset_halfdrop,0.0_WP,amr_ref_lvl) - else - ! do nothing - end if - this%vf%VF(i,j,k)=vol/this%vf%cfg%vol(i,j,k) - if (this%vf%VF(i,j,k).ge.VFlo.and.this%vf%VF(i,j,k).le.VFhi) then - this%vf%Lbary(:,i,j,k)=v_cent - this%vf%Gbary(:,i,j,k)=([this%vf%cfg%xm(i),this%vf%cfg%ym(j),this%vf%cfg%zm(k)]-this%vf%VF(i,j,k)*this%vf%Lbary(:,i,j,k))/(1.0_WP-this%vf%VF(i,j,k)) - else - this%vf%Lbary(:,i,j,k)=[this%vf%cfg%xm(i),this%vf%cfg%ym(j),this%vf%cfg%zm(k)] - this%vf%Gbary(:,i,j,k)=[this%vf%cfg%xm(i),this%vf%cfg%ym(j),this%vf%cfg%zm(k)] - end if - end do - end do - end do - ! Update the band - call this%vf%update_band() - ! Perform interface reconstruction from VOF field - call this%vf%build_interface() - ! Set interface planes at the boundaries - call this%vf%set_full_bcond() - - ! Now apply Neumann condition on interface at inlet to have proper round injection - neumann_irl: block - use irl_fortran_interface, only: getPlane,new,construct_2pt,RectCub_type,& - & setNumberOfPlanes,setPlane,matchVolumeFraction - real(WP), dimension(1:4) :: plane - real(WP) :: eps_plane - integer :: nplanes_src - type(RectCub_type) :: cell - call new(cell) - if (this%vf%cfg%jproc.eq.1) then - do k=this%vf%cfg%kmino_,this%vf%cfg%kmaxo_ - do j=this%vf%cfg%jmino_,this%vf%cfg%jmin-1 - do i=this%vf%cfg%imino_,this%vf%cfg%imaxo_ - ! Extract plane data and copy in overlap - plane=getPlane(this%vf%liquid_gas_interface(i,this%vf%cfg%jmin,k),0) - eps_plane = 1.0e-30_WP - nplanes_src = getNumberOfPlanes(this%vf%liquid_gas_interface(i,this%vf%cfg%jmin,k)) - if (nplanes_src.eq.0) cycle - call construct_2pt(cell,[this%vf%cfg%x(i ),this%vf%cfg%y(j ),this%vf%cfg%z(k )],& - & [this%vf%cfg%x(i+1),this%vf%cfg%y(j+1),this%vf%cfg%z(k+1)]) - plane(4)=dot_product(plane(1:3),[this%vf%cfg%xm(i),this%vf%cfg%ym(j),this%vf%cfg%zm(k)]) - if (sum(plane(1:3)**2) .le. eps_plane) cycle - call setNumberOfPlanes(this%vf%liquid_gas_interface(i,j,k),1) - call setPlane(this%vf%liquid_gas_interface(i,j,k),0,plane(1:3),plane(4)) - call matchVolumeFraction(cell,this%vf%VF(i,j,k),this%vf%liquid_gas_interface(i,j,k)) - end do - end do - end do - end if - end block neumann_irl - - ! Create discontinuous polygon mesh from IRL interface - call this%vf%polygonalize_interface() - ! Calculate distance from polygons - call this%vf%distance_from_polygon() - ! Calculate subcell phasic volumes - call this%vf%subcell_vol() - ! Calculate curvature - call this%vf%get_curvature() - ! Reset moments to guarantee compatibility with interface reconstruction - call this%vf%reset_volume_moments() - end block create_and_initialize_vof - - ! Create an iterator for removing VOF at edges - create_iterator: block - this%vof_removal_layer=iterator(this%cfg,'VOF removal',vof_removal_layer_locator) - end block create_iterator - - - ! Create a multiphase flow solver with bconds - create_flow_solver: block - use mathtools, only: Pi - use param, only: param_read - use tpns_class, only: dirichlet,clipped_neumann,bcond - use hypre_str_class, only: pcg_pfmg2 - type(bcond), pointer :: mybc - integer :: n,i,j,k - ! Create flow solver - this%fs=tpns(cfg=this%cfg,name='Two-phase NS') - ! Set fluid properties - call param_read("Liquid density",this%fs%rho_l); - call param_read("Gas density",this%fs%rho_g); - call param_read("Liquid viscosity",this%fs%visc_l); - call param_read("Gas viscosity",this%fs%visc_g); - call param_read("Surface tension",this%fs%sigma); - - ! Define inflow boundary condition on the left - call this%fs%add_bcond(name='inflow',type=dirichlet,face='x',dir=-1,canCorrect=.false.,locator=xm_locator) - ! Define outflow boundary condition on the right - call this%fs%add_bcond(name='outflow',type=clipped_neumann,face='x',dir=+1,canCorrect=.true.,locator=xp_locator) - ! Define jet boundary condition on the bottom - call this%fs%add_bcond(name='jet' ,type=dirichlet,face='y',dir=-1,canCorrect=.false.,locator=jet_bdy) - ! Define gravity as vector for flow solver - this%fs%gravity(2) = this%gravity - - ! Configure pressure solver - this%ps=hypre_str(cfg=this%cfg,name='Pressure',method=pcg_pfmg2,nst=7) - this%ps%maxlevel=16 - call param_read('Pressure iteration',this%ps%maxit) - call param_read('Pressure tolerance',this%ps%rcvg) - ! Configure implicit velocity solver - !this%vs=ddadi(cfg=this%cfg,name='Velocity',nst=7) - ! Setup the solver - call this%fs%setup(pressure_solver=this%ps)!,implicit_solver=this%vs) - ! Zero initial field - this%fs%U=0.0_WP; this%fs%V=0.0_WP; this%fs%W=0.0_WP - ! Apply convective velocity - call this%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) - this%fs%U(i,j,k)=1.0_WP - end do - ! Apply jet velocity - call this%fs%get_bcond('jet',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) - this%fs%V(i,j,k)=0 ! Start with zero velocity this%Vjet - end do - ! Apply all other boundary conditions - call this%fs%apply_bcond(this%time%t,this%time%dt) - ! Adjust MFR for global mass balance - call this%fs%correct_mfr() - ! Compute divergence - call this%fs%get_div() - ! Compute cell-centered velocity - call this%fs%interp_vel(this%Ui,this%Vi,this%Wi) - end block create_flow_solver - - ! Create CCL - create_ccl: block - ! Initialize CCL - call this%ccl%initialize(pg=this%cfg%pgrid,name='ccl') - end block create_ccl - - ! Handle restart/saves here - handle_restart: block - use param, only: param_read - use string, only: str_medium - use filesys, only: makedir,isdir - use irl_fortran_interface, only: setNumberOfPlanes,setPlane - character(len=str_medium) :: timestamp - integer, dimension(3) :: iopartition - real(WP), dimension(:,:,:), allocatable :: P11,P12,P13,P14 - real(WP), dimension(:,:,:), allocatable :: P21,P22,P23,P24 - integer :: i,j,k - ! Create event for saving restart files - this%save_evt=event(this%time,'Restart output') - call param_read('Restart output period',this%save_evt%tper) - ! Check if we are restarting - call param_read('Restart from',timestamp,default='') - this%restarted=.false.; if (len_trim(timestamp).gt.0) this%restarted=.true. - ! Read in the I/O partition - call param_read('I/O partition',iopartition) - ! Perform pardata initialization - if (this%restarted) then - ! Read in the file - call this%df%initialize(pg=this%cfg,iopartition=iopartition,fdata='restart/data_'//trim(timestamp)) - ! Read in the planes directly and set the IRL interface - allocate(P11(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)); call this%df%pull(name='P11',var=P11) - allocate(P12(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)); call this%df%pull(name='P12',var=P12) - allocate(P13(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)); call this%df%pull(name='P13',var=P13) - allocate(P14(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)); call this%df%pull(name='P14',var=P14) - allocate(P21(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)); call this%df%pull(name='P21',var=P21) - allocate(P22(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)); call this%df%pull(name='P22',var=P22) - allocate(P23(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)); call this%df%pull(name='P23',var=P23) - allocate(P24(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)); call this%df%pull(name='P24',var=P24) - do k=this%vf%cfg%kmin_,this%vf%cfg%kmax_ - do j=this%vf%cfg%jmin_,this%vf%cfg%jmax_ - do i=this%vf%cfg%imin_,this%vf%cfg%imax_ - ! Check if the second plane is meaningful - if (this%vf%two_planes.and.P21(i,j,k)**2+P22(i,j,k)**2+P23(i,j,k)**2.gt.0.0_WP) then - call setNumberOfPlanes(this%vf%liquid_gas_interface(i,j,k),2) - call setPlane(this%vf%liquid_gas_interface(i,j,k),0,[P11(i,j,k),P12(i,j,k),P13(i,j,k)],P14(i,j,k)) - call setPlane(this%vf%liquid_gas_interface(i,j,k),1,[P21(i,j,k),P22(i,j,k),P23(i,j,k)],P24(i,j,k)) - else - call setNumberOfPlanes(this%vf%liquid_gas_interface(i,j,k),1) - call setPlane(this%vf%liquid_gas_interface(i,j,k),0,[P11(i,j,k),P12(i,j,k),P13(i,j,k)],P14(i,j,k)) - end if - end do - end do - end do - call this%vf%sync_interface() - deallocate(P11,P12,P13,P14,P21,P22,P23,P24) - ! Reset moments - call this%vf%reset_volume_moments() - ! Update the band - call this%vf%update_band() - ! Create discontinuous polygon mesh from IRL interface - call this%vf%polygonalize_interface() - ! Calculate distance from polygons - call this%vf%distance_from_polygon() - ! Calculate subcell phasic volumes - call this%vf%subcell_vol() - ! Calculate curvature - call this%vf%get_curvature() - ! Now read in the velocity solver data - call this%df%pull(name='U',var=this%fs%U) - call this%df%pull(name='V',var=this%fs%V) - call this%df%pull(name='W',var=this%fs%W) - call this%df%pull(name='P',var=this%fs%P) - call this%df%pull(name='Pjx',var=this%fs%Pjx) - call this%df%pull(name='Pjy',var=this%fs%Pjy) - call this%df%pull(name='Pjz',var=this%fs%Pjz) - ! Apply all other boundary conditions - call this%fs%apply_bcond(this%time%t,this%time%dt) - ! Compute MFR through all boundary conditions - call this%fs%get_mfr() - ! Adjust MFR for global mass balance - call this%fs%correct_mfr() - ! Compute cell-centered velocity - call this%fs%interp_vel(this%Ui,this%Vi,this%Wi) - ! Compute divergence - call this%fs%get_div() - ! Also update time - call this%df%pull(name='t' ,val=this%time%t ) - call this%df%pull(name='dt',val=this%time%dt) - this%time%told=this%time%t-this%time%dt - !this%time%dt=this%time%dtmax !< Force max timestep size anyway - else - ! We are not restarting, prepare a new directory for storing restart files - if (this%cfg%amRoot) then - if (.not.isdir('restart')) call makedir('restart') - end if - ! Prepare pardata object for saving restart files - call this%df%initialize(pg=this%cfg,iopartition=iopartition,filename=trim(this%cfg%name),nval=2,nvar=15) - this%df%valname=['t ','dt'] - this%df%varname=['U ','V ','W ','P ','Pjx','Pjy','Pjz','P11','P12','P13','P14','P21','P22','P23','P24'] - end if - end block handle_restart - - - ! Create surfmesh object for interface polygon output - create_smesh: block - use irl_fortran_interface, only: getNumberOfPlanes,getNumberOfVertices - integer :: i,j,k,np,nplane - this%smesh=surfmesh(nvar=2,name='plic') - this%smesh%varname(1)='nplane' - this%smesh%varname(2)='thickness' - ! Transfer polygons to smesh - call this%vf%update_surfmesh(this%smesh) - ! ! Calculate thickness - ! call this%vf%get_thickness() - ! ! Populate nplane and thickness variables - ! this%smesh%var(1,:)=1.0_WP - ! np=0 - ! do k=this%vf%cfg%kmin_,this%vf%cfg%kmax_ - ! do j=this%vf%cfg%jmin_,this%vf%cfg%jmax_ - ! do i=this%vf%cfg%imin_,this%vf%cfg%imax_ - ! if (this%cfg%VF(i,j,k).lt.2.0_WP*epsilon(1.0_WP)) cycle ! Skip cells below VF threshold - ! do nplane=1,getNumberOfPlanes(this%vf%liquid_gas_interface(i,j,k)) - ! if (getNumberOfVertices(this%vf%interface_polygon(nplane,i,j,k)).gt.0) then - ! np=np+1; this%smesh%var(1,np)=real(getNumberOfPlanes(this%vf%liquid_gas_interface(i,j,k)),WP) - ! this%smesh%var(2,np)=this%vf%thickness(i,j,k) - ! end if - ! end do - ! end do - ! end do - ! end do - end block create_smesh - - - ! Add Ensight output - create_ensight: block - use param, only: param_read - ! Create Ensight output from cfg - this%ens_out=ensight(cfg=this%cfg,name='ljcf') - ! Create event for Ensight output - this%ens_evt=event(time=this%time,name='Ensight output') - call param_read('Ensight output period',this%ens_evt%tper) - ! Add variables to output - call this%ens_out%add_vector('velocity',this%Ui,this%Vi,this%Wi) - call this%ens_out%add_scalar('VOF',this%vf%VF) - call this%ens_out%add_scalar('curvature',this%vf%curv) - call this%ens_out%add_scalar('pressure',this%fs%P) - call this%ens_out%add_surface('plic',this%smesh) - call this%ens_out%add_scalar('Gib',this%cfg%Gib) - ! Output to ensight - if (this%ens_evt%occurs()) call this%ens_out%write_data(this%time%t) - end block create_ensight - - - ! Create a monitor file - create_monitor: block - ! Prepare some info about fields - call this%fs%get_cfl(this%time%dt,this%time%cfl) - call this%fs%get_max() - call this%vf%get_max() - ! Create simulation monitor - this%mfile=monitor(this%fs%cfg%amRoot,'simulation_atom') - call this%mfile%add_column(this%time%n,'Timestep number') - call this%mfile%add_column(this%time%t,'Time') - call this%mfile%add_column(this%time%dt,'Timestep size') - call this%mfile%add_column(this%time%cfl,'Maximum CFL') - call this%mfile%add_column(this%fs%Umax,'Umax') - call this%mfile%add_column(this%fs%Vmax,'Vmax') - call this%mfile%add_column(this%fs%Wmax,'Wmax') - call this%mfile%add_column(this%fs%Pmax,'Pmax') - call this%mfile%add_column(this%vf%VFint,'VOF integral') - call this%mfile%add_column(this%vf%SDint,'SD integral') - call this%mfile%add_column(this%vof_removed,'VOF removed') - call this%mfile%add_column(this%vf%flotsam_error,'Flotsam error') - ! call this%mfile%add_column(this%vf%thinstruct_error,'Film error') - call this%mfile%add_column(this%fs%divmax,'Maximum divergence') - call this%mfile%add_column(this%fs%psolv%it,'Pressure iteration') - call this%mfile%add_column(this%fs%psolv%rerr,'Pressure error') - call this%mfile%write() - ! Create CFL monitor - this%cflfile=monitor(this%fs%cfg%amRoot,'cfl_atom') - call this%cflfile%add_column(this%time%n,'Timestep number') - call this%cflfile%add_column(this%time%t,'Time') - call this%cflfile%add_column(this%fs%CFLst,'STension CFL') - call this%cflfile%add_column(this%fs%CFLc_x,'Convective xCFL') - call this%cflfile%add_column(this%fs%CFLc_y,'Convective yCFL') - call this%cflfile%add_column(this%fs%CFLc_z,'Convective zCFL') - call this%cflfile%add_column(this%fs%CFLv_x,'Viscous xCFL') - call this%cflfile%add_column(this%fs%CFLv_y,'Viscous yCFL') - call this%cflfile%add_column(this%fs%CFLv_z,'Viscous zCFL') - call this%cflfile%write() - ! Create LJCF monitor - this%ljcf_file=monitor(this%fs%cfg%amRoot,'ljcf') - call this%ljcf_file%add_column(this%time%n,'Timestep number') - call this%ljcf_file%add_column(this%time%t,'Time') - call this%ljcf_file%add_column(this%InjectionVelocity,'Injection Velocity') - call this%ljcf_file%write() - end block create_monitor - - - ! Create a timing monitor - create_timing: block - ! Create timers - this%tstep =timer(comm=this%cfg%comm,name='Timestep') - this%tvof =timer(comm=this%cfg%comm,name='VOFsolve') - this%tvel =timer(comm=this%cfg%comm,name='Velocity') - this%tpres =timer(comm=this%cfg%comm,name='Pressure') - ! Create corresponding monitor file - this%timefile=monitor(this%fs%cfg%amRoot,'timing') - call this%timefile%add_column(this%time%n,'Timestep number') - call this%timefile%add_column(this%time%t,'Time') - call this%timefile%add_column(this%tstep%time ,trim(this%tstep%name)) - call this%timefile%add_column(this%tvof%time ,trim(this%tvof%name)) - call this%timefile%add_column(this%tvel%time ,trim(this%tvel%name)) - call this%timefile%add_column(this%tpres%time ,trim(this%tpres%name)) - end block create_timing - - contains - - - !> Function that localizes the x- boundary - function xm_locator(pg,i,j,k) result(isIn) - use pgrid_class, only: pgrid - class(pgrid), intent(in) :: pg - integer, intent(in) :: i,j,k - logical :: isIn - isIn=.false. - if (i.eq.pg%imin) isIn=.true. - end function xm_locator - - - !> Function that localizes the x+ boundary - function xp_locator(pg,i,j,k) result(isIn) - use pgrid_class, only: pgrid - 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 xp_locator - - - !> Function that localizes region of VOF removal - function vof_removal_layer_locator(pg,i,j,k) result(isIn) - use pgrid_class, only: pgrid - class(pgrid), intent(in) :: pg - integer, intent(in) :: i,j,k - logical :: isIn - isIn=.false. - if (i.ge.pg%imax-this%nlayer) isIn=.true. - end function vof_removal_layer_locator - - - !> Function that defines a level set function for a half droplet - function levelset_halfdrop(xyz,t) result(G) - implicit none - real(WP), dimension(3),intent(in) :: xyz - real(WP), intent(in) :: t - real(WP) :: G - G=0.5_WP*this%djet-sqrt(xyz(1)**2+(xyz(2)-this%cfg%y(this%cfg%jmin))**2+xyz(3)**2) - end function levelset_halfdrop - - !> Function that localizes the jet(s) initial location - function jet(pg,i,j,k) result(isIn) - use pgrid_class, only: pgrid - implicit none - class(pgrid), intent(in) :: pg - integer, intent(in) :: i,j,k - integer :: ii,kk - real(WP), dimension(3) :: xyz - logical :: isIn - ! isIn=.false. - ! xyz(1)=pg%xm(i); xyz(2)=pg%ym(j); xyz(3)=pg%zm(k) - ! if (levelset_halfdrop(xyz,0.0_WP).gt.0.0_WP) isIn=.true. - isIn=.false. - ! Check if any of cell corners are in jet - do ii = i,i+1 - do kk = k,k+1 - xyz(1)=pg%x(ii); xyz(2)=pg%y(pg%jmin); xyz(3)=pg%z(kk) - if (levelset_halfdrop(xyz,0.0_WP).gt.0.0_WP) then - isIn=.true. - return - end if - end do - end do - end function jet - - !> Function that localizes the walls surrounding the jets - function wall(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 (j.le.pg%jmin-1+this%nwall.and.(.not.jet(pg,i,j,k))) isIn=.true. - end function wall - - !> Function that localizes the jet(s) BCs at edge of domain - function jet_bdy(pg,i,j,k) result(isIn) - use pgrid_class, only: pgrid - implicit none - class(pgrid), intent(in) :: pg - integer, intent(in) :: i,j,k - real(WP), dimension(3) :: xyz - logical :: isIn - isIn=.false. - xyz(1)=pg%xm(i); xyz(2)=pg%y(j); xyz(3)=pg%zm(k) - if (j.eq.pg%jmin.and.jet(pg,i,j,k)) isIn=.true. - end function jet_bdy - - - end subroutine init - - - !> Take one time step - subroutine step(this) - use tpns_class, only: arithmetic_visc - implicit none - class(ljcf), intent(inout) :: this - - ! Reset all timers and start timestep timer - call this%tstep%reset() - call this%tvof%reset() - call this%tvel%reset() - call this%tpres%reset() - call this%tstep%start() - - ! Increment time - call this%fs%get_cfl(this%time%dt,this%time%cfl) - call this%time%adjust_dt() - call this%time%increment() - - ! Apply jet velocity - apply_bc: block - use tpns_class, only: bcond - use mpi_f08, only: MPI_ALLREDUCE,MPI_SUM,MPI_IN_PLACE - use parallel, only: MPI_REAL_WP - type(bcond), pointer :: mybc - real(WP) :: liqVolInjected_dt - integer :: n,i,j,k - ! Compute injection velocity - if (this%time%t .lt. this%endInjectionTime) then - this%InjectionVelocity=this%gravity*this%time%t ! Velocity increases linearly with time - else - this%InjectionVelocity=0.0_WP ! Velocity stops once volume is reached - end if - ! Apply injection velocity to the jet boundary condition - call this%fs%get_bcond('jet',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) - this%fs%V(i,j,k) = this%InjectionVelocity - end do - end block apply_bc - - ! Remember old VOF - this%vf%VFold=this%vf%VF - - ! Remember old velocity - this%fs%Uold=this%fs%U - this%fs%Vold=this%fs%V - this%fs%Wold=this%fs%W - - ! Prepare old sflaggered density (at n) - call this%fs%get_olddensity(vf=this%vf) - - ! VOF solver step - call this%tvof%start() ! Start VOF timer - call this%vf%advance(dt=this%time%dt,U=this%fs%U,V=this%fs%V,W=this%fs%W) - call this%tvof%stop() ! Stop VOF timer - - ! Prepare new sflaggered viscosity (at n+1) - call this%fs%get_viscosity(vf=this%vf,strat=arithmetic_visc) - - ! Perform sub-iterations - do while (this%time%it.le.this%time%itmax) - - ! Start velocity timer - call this%tvel%start() - - ! Build mid-time velocity - this%fs%U=0.5_WP*(this%fs%U+this%fs%Uold) - this%fs%V=0.5_WP*(this%fs%V+this%fs%Vold) - this%fs%W=0.5_WP*(this%fs%W+this%fs%Wold) - - ! Preliminary mass and momentum transport step at the interface - call this%fs%prepare_advection_upwind(dt=this%time%dt) - - ! Explicit calculation of drho*u/dt from NS - call this%fs%get_dmomdt(this%resU,this%resV,this%resW) - - ! Assemble explicit residual - this%resU=-2.0_WP*this%fs%rho_U*this%fs%U+(this%fs%rho_Uold+this%fs%rho_U)*this%fs%Uold+this%time%dt*this%resU - this%resV=-2.0_WP*this%fs%rho_V*this%fs%V+(this%fs%rho_Vold+this%fs%rho_V)*this%fs%Vold+this%time%dt*this%resV - this%resW=-2.0_WP*this%fs%rho_W*this%fs%W+(this%fs%rho_Wold+this%fs%rho_W)*this%fs%Wold+this%time%dt*this%resW - - ! Form implicit residuals - call this%fs%solve_implicit(this%time%dt,this%resU,this%resV,this%resW) - - ! Apply these residuals - this%fs%U=2.0_WP*this%fs%U-this%fs%Uold+this%resU - this%fs%V=2.0_WP*this%fs%V-this%fs%Vold+this%resV - this%fs%W=2.0_WP*this%fs%W-this%fs%Wold+this%resW - - ! Apply IB forcing to enforce BC at the pipe walls - ibforcing: block - integer :: i,j,k - do k=this%fs%cfg%kmin_,this%fs%cfg%kmax_ - do j=this%fs%cfg%jmin_,this%fs%cfg%jmax_ - do i=this%fs%cfg%imin_,this%fs%cfg%imax_ - this%fs%U(i,j,k)=this%fs%U(i,j,k)*sum(this%fs%itpr_x(:,i,j,k)*this%cfg%VF(i-1:i,j,k)) - this%fs%V(i,j,k)=this%fs%V(i,j,k)*sum(this%fs%itpr_y(:,i,j,k)*this%cfg%VF(i,j-1:j,k)) - this%fs%W(i,j,k)=this%fs%W(i,j,k)*sum(this%fs%itpr_z(:,i,j,k)*this%cfg%VF(i,j,k-1:k)) - end do - end do - end do - call this%fs%cfg%sync(this%fs%U) - call this%fs%cfg%sync(this%fs%V) - call this%fs%cfg%sync(this%fs%W) - end block ibforcing - - ! Apply boundary conditions - call this%fs%apply_bcond(this%time%t,this%time%dt) - - ! Stop velocity timer and start pressure timer - call this%tvel%stop() - call this%tpres%start() - - ! Solve Poisson equation - call this%fs%update_laplacian() - call this%fs%correct_mfr() - call this%fs%get_div() - call this%fs%add_surface_tension_jump(dt=this%time%dt,div=this%fs%div,vf=this%vf) - ! call this%fs%add_surface_tension_jump_twoVF(dt=this%time%dt,div=this%fs%div,vf=this%vf) - this%fs%psolv%rhs=-this%fs%cfg%vol*this%fs%div/this%time%dt - this%fs%psolv%sol=0.0_WP - call this%fs%psolv%solve() - call this%fs%shift_p(this%fs%psolv%sol) - - ! Correct velocity - call this%fs%get_pgrad(this%fs%psolv%sol,this%resU,this%resV,this%resW) - this%fs%P=this%fs%P+this%fs%psolv%sol - this%fs%U=this%fs%U-this%time%dt*this%resU/max(epsilon(0.0_WP),this%fs%rho_U) - this%fs%V=this%fs%V-this%time%dt*this%resV/max(epsilon(0.0_WP),this%fs%rho_V) - this%fs%W=this%fs%W-this%time%dt*this%resW/max(epsilon(0.0_WP),this%fs%rho_W) - - ! Apply boundary conditions - call this%fs%apply_bcond(this%time%t,this%time%dt) - - ! Stop pressure timer - call this%tpres%stop() - - ! Increment sub-iteration counter - this%time%it=this%time%it+1 - - end do - - ! Recompute interpolated velocity and divergence - call this%fs%interp_vel(this%Ui,this%Vi,this%Wi) - call this%fs%get_div() - - ! Remove VOF at edge of domain - remove_vof: block - use mpi_f08, only: MPI_ALLREDUCE,MPI_SUM,MPI_IN_PLACE - use parallel, only: MPI_REAL_WP - integer :: n,i,j,k,ierr - this%vof_removed=0.0_WP - do n=1,this%vof_removal_layer%no_ - i=this%vof_removal_layer%map(1,n) - j=this%vof_removal_layer%map(2,n) - k=this%vof_removal_layer%map(3,n) - if (n.le.this%vof_removal_layer%n_) this%vof_removed=this%vof_removed+this%cfg%vol(i,j,k)*this%vf%VF(i,j,k) - this%vf%VF(i,j,k)=0.0_WP - end do - call MPI_ALLREDUCE(MPI_IN_PLACE,this%vof_removed,1,MPI_REAL_WP,MPI_SUM,this%cfg%comm,ierr) - call this%vf%clean_irl_and_band() - end block remove_vof - - - ! Output to ensight - if (this%ens_evt%occurs()) then - ! Update surface mesh - update_smesh: block - use irl_fortran_interface, only: getNumberOfPlanes,getNumberOfVertices - integer :: i,j,k,np,nplane - ! Transfer polygons to smesh - call this%vf%update_surfmesh(this%smesh) - ! ! Also populate nplane variable - ! this%smesh%var(1,:)=1.0_WP - ! np=0 - ! do k=this%vf%cfg%kmin_,this%vf%cfg%kmax_ - ! do j=this%vf%cfg%jmin_,this%vf%cfg%jmax_ - ! do i=this%vf%cfg%imin_,this%vf%cfg%imax_ - ! if (this%cfg%VF(i,j,k).lt.2.0_WP*epsilon(1.0_WP)) cycle ! Skip cells below VF threshold - ! do nplane=1,getNumberOfPlanes(this%vf%liquid_gas_interface(i,j,k)) - ! if (getNumberOfVertices(this%vf%interface_polygon(nplane,i,j,k)).gt.0) then - ! np=np+1; this%smesh%var(1,np)=real(getNumberOfPlanes(this%vf%liquid_gas_interface(i,j,k)),WP) - ! this%smesh%var(2,np)=this%vf%thickness(i,j,k) - ! end if - ! end do - ! end do - ! end do - ! end do - end block update_smesh - call this%ens_out%write_data(this%time%t) - end if - - ! Stop timestep timer - call this%tstep%stop() - - ! Perform and output monitoring - call this%fs%get_max() - call this%vf%get_max() - call this%mfile%write() - call this%cflfile%write() - call this%timefile%write() - call this%ljcf_file%write() - - ! Finally, see if it's time to save restart files - if (this%save_evt%occurs()) then - save_restart: block - use irl_fortran_interface - use string, only: str_medium - character(len=str_medium) :: timestamp - real(WP), dimension(:,:,:), allocatable :: P11,P12,P13,P14 - real(WP), dimension(:,:,:), allocatable :: P21,P22,P23,P24 - integer :: i,j,k - real(WP), dimension(4) :: plane - ! Handle IRL data - allocate(P11(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) - allocate(P12(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) - allocate(P13(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) - allocate(P14(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) - allocate(P21(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) - allocate(P22(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) - allocate(P23(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) - allocate(P24(this%cfg%imino_:this%cfg%imaxo_,this%cfg%jmino_:this%cfg%jmaxo_,this%cfg%kmino_:this%cfg%kmaxo_)) - do k=this%vf%cfg%kmino_,this%vf%cfg%kmaxo_ - do j=this%vf%cfg%jmino_,this%vf%cfg%jmaxo_ - do i=this%vf%cfg%imino_,this%vf%cfg%imaxo_ - ! First plane - plane=getPlane(this%vf%liquid_gas_interface(i,j,k),0) - P11(i,j,k)=plane(1); P12(i,j,k)=plane(2); P13(i,j,k)=plane(3); P14(i,j,k)=plane(4) - ! Second plane - plane=0.0_WP - if (getNumberOfPlanes(this%vf%liquid_gas_interface(i,j,k)).eq.2) plane=getPlane(this%vf%liquid_gas_interface(i,j,k),1) - P21(i,j,k)=plane(1); P22(i,j,k)=plane(2); P23(i,j,k)=plane(3); P24(i,j,k)=plane(4) - end do - end do - end do - ! Prefix for files - write(timestamp,'(es12.5)') this%time%t - ! Populate df and write it - call this%df%push(name='t' ,val=this%time%t ) - call this%df%push(name='dt' ,val=this%time%dt) - call this%df%push(name='U' ,var=this%fs%U ) - call this%df%push(name='V' ,var=this%fs%V ) - call this%df%push(name='W' ,var=this%fs%W ) - call this%df%push(name='P' ,var=this%fs%P ) - call this%df%push(name='Pjx',var=this%fs%Pjx ) - call this%df%push(name='Pjy',var=this%fs%Pjy ) - call this%df%push(name='Pjz',var=this%fs%Pjz ) - call this%df%push(name='P11',var=P11 ) - call this%df%push(name='P12',var=P12 ) - call this%df%push(name='P13',var=P13 ) - call this%df%push(name='P14',var=P14 ) - call this%df%push(name='P21',var=P21 ) - call this%df%push(name='P22',var=P22 ) - call this%df%push(name='P23',var=P23 ) - call this%df%push(name='P24',var=P24 ) - call this%df%write(fdata='restart/data_'//trim(adjustl(timestamp))) - ! Deallocate - deallocate(P11,P12,P13,P14,P21,P22,P23,P24) - end block save_restart - end if - - contains - !> Function that identifies cells that need a label - logical function make_label(i,j,k) - implicit none - integer, intent(in) :: i,j,k - if (this%vf%VF(i,j,k).gt.0.0_WP) then - make_label=.true. - else - make_label=.false. - end if - end function make_label - - !> Function that identifies if cell pairs have same label - logical function same_label(i1,j1,k1,i2,j2,k2) - implicit none - integer, intent(in) :: i1,j1,k1,i2,j2,k2 - if (this%vf%VF(i1,j1,k1).gt.0.0_WP .and. this%vf%VF(i2,j2,k2).gt.0.0_WP) then - same_label=.true. - else - same_label=.false. - end if - same_label=.true. - end function same_label - - end subroutine step - - - !> Finalize nozzle simulation - subroutine final(this) - implicit none - class(ljcf), intent(inout) :: this - - ! Deallocate work arrays - deallocate(this%resU,this%resV,this%resW,this%Ui,this%Vi,this%Wi) - - end subroutine final - - -end module ljcf_class \ No newline at end of file diff --git a/examples/ljcf_dimensinal_ib/src/simulation.f90 b/examples/ljcf_dimensinal_ib/src/simulation.f90 deleted file mode 100644 index 5960290a7..000000000 --- a/examples/ljcf_dimensinal_ib/src/simulation.f90 +++ /dev/null @@ -1,161 +0,0 @@ -!> Various definitions and tools for running an NGA2 simulation -module simulation - use precision, only: WP - use hit_class, only: hit - use ljcf_class, only: ljcf - use coupler_class, only: coupler - implicit none - private - - !> HIT simulation - type(hit) :: turb - logical :: isInHITGrp - - !> LJCF atomization simulation - type(ljcf) :: atom - - !> Coupler from turb to atom - type(coupler) :: xcpl,ycpl,zcpl - - public :: simulation_init,simulation_run,simulation_final - -contains - - - !> Initialization of our simulation - subroutine simulation_init - use mpi_f08, only: MPI_Group - implicit none - type(MPI_Group) :: hit_group - - ! Initialize atomization simulation - call atom%init() - - ! Create an MPI group using leftmost processors only - ! create_hit_group: block - ! use parallel, only: group,comm - ! use mpi_f08, only: MPI_Group_incl - ! integer, dimension(:), allocatable :: ranks - ! integer, dimension(3) :: coord - ! integer :: n,ngrp,ierr,ny,nz - ! ngrp=atom%cfg%npy*atom%cfg%npz - ! allocate(ranks(ngrp)) - ! ngrp=0 - ! do nz=1,atom%cfg%npz - ! do ny=1,atom%cfg%npy - ! ngrp=ngrp+1 - ! coord=[0,ny-1,nz-1] - ! call MPI_CART_RANK(atom%cfg%comm,coord,ranks(ngrp),ierr) - ! end do - ! end do - ! call MPI_Group_incl(group,ngrp,ranks,hit_group,ierr) - ! if (atom%cfg%iproc.eq.1) then - ! isInHITGrp=.true. - ! else - ! isInHITGrp=.false. - ! end if - ! end block create_hit_group - - ! ! Initialize HIT simulation - ! if (isInHITGrp) call turb%init(group=hit_group,xend=atom%cfg%x(atom%cfg%imin)) - - ! ! If restarting, the domains could be out of sync, so resync - ! ! time by forcing HIT to be at same time as jet - ! if (isInHITGrp) then - ! turb%time%t=atom%time%t - ! turb%time%told=turb%time%t-turb%time%dt - ! end if - - ! ! Initialize couplers from turb to atom - ! create_coupler: block - ! use parallel, only: group - ! xcpl=coupler(src_grp=hit_group,dst_grp=group,name='turb2atom') - ! ycpl=coupler(src_grp=hit_group,dst_grp=group,name='turb2atom') - ! zcpl=coupler(src_grp=hit_group,dst_grp=group,name='turb2atom') - ! if (isInHITGrp) call xcpl%set_src(turb%cfg,'x') - ! if (isInHITGrp) call ycpl%set_src(turb%cfg,'y') - ! if (isInHITGrp) call zcpl%set_src(turb%cfg,'z') - ! call xcpl%set_dst(atom%cfg,'x'); call xcpl%initialize() - ! call ycpl%set_dst(atom%cfg,'y'); call ycpl%initialize() - ! call zcpl%set_dst(atom%cfg,'z'); call zcpl%initialize() - ! end block create_coupler - - end subroutine simulation_init - - - !> Run the simulation - subroutine simulation_run - implicit none - - ! Atomization drives overall time integration - do while (.not.atom%time%done()) - - ! ! Advance HIT simulation and transfer velocity info - ! if (isInHITGrp) then - ! ! Advance HIT with maximum stable dt until caught up - ! advance_hit: block - ! real(WP) :: dt - ! dt=0.15_WP*turb%cfg%min_meshsize/turb%Urms_tgt - ! do while (turb%time%t.le.atom%time%t) - ! call turb%step(dt) - ! end do - ! end block advance_hit - ! end if - - ! Handle coupling between HIT and atomization simulation - coupling: block - ! ! Push data from HIT simulation - ! if (isInHITGrp) then - ! push_velocity: block - ! real(WP) :: rescaling,tinterp - ! rescaling=turb%ti/turb%Urms_tgt - ! tinterp=(turb%time%t-atom%time%t)/(turb%time%t-turb%time%told) - ! turb%resU=rescaling*((1.0_WP-tinterp)*turb%fs%U+tinterp*turb%fs%Uold); call xcpl%push(turb%resU) - ! turb%resV=rescaling*((1.0_WP-tinterp)*turb%fs%V+tinterp*turb%fs%Vold); call ycpl%push(turb%resV) - ! turb%resW=rescaling*((1.0_WP-tinterp)*turb%fs%W+tinterp*turb%fs%Wold); call zcpl%push(turb%resW) - ! end block push_velocity - ! end if - ! ! Transfer and pull - ! call xcpl%transfer(); call xcpl%pull(atom%resU) - ! call ycpl%transfer(); call ycpl%pull(atom%resV) - ! call zcpl%transfer(); call zcpl%pull(atom%resW) - ! Apply time-dependent Dirichlet condition - apply_boundary_condition: block - use param, only: param_read - use tpns_class, only: bcond - type(bcond), pointer :: mybc - integer :: n,i,j,k - real(WP) :: air_vel - call atom%fs%get_bcond('inflow',mybc) - call param_read("Air velocity",air_vel) - do n=1,mybc%itr%no_ - i=mybc%itr%map(1,n); j=mybc%itr%map(2,n); k=mybc%itr%map(3,n) - atom%fs%U(i ,j,k)=air_vel !atom%resU(i ,j,k)+1.0_WP - atom%fs%V(i-1,j,k)=0.0_WP !atom%resV(i-1,j,k) - atom%fs%W(i-1,j,k)=0.0_WP !atom%resW(i-1,j,k) - end do - end block apply_boundary_condition - end block coupling - - ! Advance atomization simulation - call atom%step() - - end do - - end subroutine simulation_run - - - !> Finalize the NGA2 simulation - subroutine simulation_final - implicit none - - ! Finalize atomization simulation - call atom%final() - - ! Finalize HIT simulation - ! if (isInHITGrp) call turb%final() - - end subroutine simulation_final - - -end module simulation \ No newline at end of file From d40d846b53925e75922d84f6093fc12e5075616f Mon Sep 17 00:00:00 2001 From: Mark Owkes Date: Mon, 22 Jun 2026 15:21:10 -0600 Subject: [PATCH 70/70] Updates to coupler calls --- examples/ljcf/src/simulation.f90 | 24 ++++++++++++------------ 1 file changed, 12 insertions(+), 12 deletions(-) diff --git a/examples/ljcf/src/simulation.f90 b/examples/ljcf/src/simulation.f90 index 7e1fd3156..85fbd3cd7 100644 --- a/examples/ljcf/src/simulation.f90 +++ b/examples/ljcf/src/simulation.f90 @@ -72,12 +72,12 @@ subroutine simulation_init xcpl=coupler(src_grp=hit_group,dst_grp=group,name='turb2atom') ycpl=coupler(src_grp=hit_group,dst_grp=group,name='turb2atom') zcpl=coupler(src_grp=hit_group,dst_grp=group,name='turb2atom') - if (isInHITGrp) call xcpl%set_src(turb%cfg,'x') - if (isInHITGrp) call ycpl%set_src(turb%cfg,'y') - if (isInHITGrp) call zcpl%set_src(turb%cfg,'z') - call xcpl%set_dst(atom%cfg,'x'); call xcpl%initialize() - call ycpl%set_dst(atom%cfg,'y'); call ycpl%initialize() - call zcpl%set_dst(atom%cfg,'z'); call zcpl%initialize() + if (isInHITGrp) call xcpl%set_src(turb%cfg) + if (isInHITGrp) call ycpl%set_src(turb%cfg) + if (isInHITGrp) call zcpl%set_src(turb%cfg) + call xcpl%set_dst(atom%cfg); call xcpl%initialize() + call ycpl%set_dst(atom%cfg); call ycpl%initialize() + call zcpl%set_dst(atom%cfg); call zcpl%initialize() end block create_coupler end subroutine simulation_init @@ -110,15 +110,15 @@ subroutine simulation_run real(WP) :: rescaling,tinterp rescaling=turb%ti/turb%Urms_tgt tinterp=(turb%time%t-atom%time%t)/(turb%time%t-turb%time%told) - turb%resU=rescaling*((1.0_WP-tinterp)*turb%fs%U+tinterp*turb%fs%Uold); call xcpl%push(turb%resU) - turb%resV=rescaling*((1.0_WP-tinterp)*turb%fs%V+tinterp*turb%fs%Vold); call ycpl%push(turb%resV) - turb%resW=rescaling*((1.0_WP-tinterp)*turb%fs%W+tinterp*turb%fs%Wold); call zcpl%push(turb%resW) + turb%resU=rescaling*((1.0_WP-tinterp)*turb%fs%U+tinterp*turb%fs%Uold); call xcpl%push(turb%resU,'x') + turb%resV=rescaling*((1.0_WP-tinterp)*turb%fs%V+tinterp*turb%fs%Vold); call ycpl%push(turb%resV,'y') + turb%resW=rescaling*((1.0_WP-tinterp)*turb%fs%W+tinterp*turb%fs%Wold); call zcpl%push(turb%resW,'z') end block push_velocity end if ! Transfer and pull - call xcpl%transfer(); call xcpl%pull(atom%resU) - call ycpl%transfer(); call ycpl%pull(atom%resV) - call zcpl%transfer(); call zcpl%pull(atom%resW) + call xcpl%transfer(); call xcpl%pull(atom%resU,'x') + call ycpl%transfer(); call ycpl%pull(atom%resV,'y') + call zcpl%transfer(); call zcpl%pull(atom%resW,'z') ! Apply time-dependent Dirichlet condition apply_boundary_condition: block use tpns_class, only: bcond