diff --git a/.testing/Makefile b/.testing/Makefile index a8a5ea3e68..eb17c10e0f 100644 --- a/.testing/Makefile +++ b/.testing/Makefile @@ -267,16 +267,16 @@ $(BUILD)/timing/Makefile: MOM_ACFLAGS += --with-driver=timing_tests # Build executables .NOTPARALLEL:$(foreach e,$(UNIT_EXECS),$(BUILD)/unit/$(e)) $(BUILD)/unit/test_%: $(BUILD)/unit/Makefile FORCE - cd $(@D) && $(TIME) $(MAKE) $(@F) -j + cd $(@D) && $(TIME) $(MAKE) $(@F) $(BUILD)/unit/Makefile: $(foreach e,$(UNIT_EXECS),../config_src/drivers/unit_tests/$(e).F90) .NOTPARALLEL:$(foreach e,$(TIMING_EXECS),$(BUILD)/timing/$(e)) $(BUILD)/timing/time_%: $(BUILD)/timing/Makefile FORCE - cd $(@D) && $(TIME) $(MAKE) $(@F) -j + cd $(@D) && $(TIME) $(MAKE) $(@F) $(BUILD)/timing/Makefile: $(foreach e,$(TIMING_EXECS),../config_src/drivers/timing_tests/$(e).F90) $(BUILD)/%/MOM6: $(BUILD)/%/Makefile FORCE - cd $(@D) && $(TIME) $(MAKE) $(@F) -j + cd $(@D) && $(TIME) $(MAKE) $(@F) # Target codebase should use its own build system $(BUILD)/target/MOM6: $(BUILD)/target FORCE | $(TARGET_CODEBASE) diff --git a/config_src/drivers/timing_tests/time_MOM_remapping.F90 b/config_src/drivers/timing_tests/time_MOM_remapping.F90 index e4bea9d94f..e752686040 100644 --- a/config_src/drivers/timing_tests/time_MOM_remapping.F90 +++ b/config_src/drivers/timing_tests/time_MOM_remapping.F90 @@ -9,8 +9,30 @@ program time_MOM_remapping implicit none type(remapping_CS) :: CS -integer, parameter :: nk=75, nij=20*20, nits=10, nsamp=100, nschemes = 2 -character(len=10) :: scheme_labels(nschemes) +integer, parameter :: nk=75, nij=20*20, nits=10, nsamp=100, nschemes = 22 +character(len=16) :: scheme_labels(nschemes) = [ character(len=16) :: & + 'PCM', & + 'C_PCM', & + 'PLM', & + 'C_MPLM_WA', & + 'C_EMPLM_WA', & + 'C_PLM_HYBGEN', & + 'C_PLM_CW', & + 'C_PLM_CWK', & + 'C_MPLM_WA_POLY', & + 'C_EMPLM_WA_POLY', & + 'C_MPLM_CWK', & + 'PPM_H4', & + 'PPM_IH4', & + 'PQM_IH4IH3', & + 'PPM_CW', & + 'PPM_HYBGEN', & + 'C_PPM_H4_2018', & + 'C_PPM_H4_2019', & + 'C_PPM_HYBGEN', & + 'C_PPM_CW', & + 'C_PPM_CWK', & + 'C_EPPM_CWK' ] real, dimension(nschemes) :: timings ! Time for nits of nij calls for each scheme [s] real, dimension(nschemes) :: tmean ! Mean time for a call [s] real, dimension(nschemes) :: tstd ! Standard deviation of time for a call [s] @@ -31,9 +53,6 @@ program time_MOM_remapping seed(:) = 102030405 call random_seed(put=seed) -scheme_labels(1) = 'PCM' -scheme_labels(2) = 'PLM' - ! Set up some test data (note: using k,i indexing rather than i,k) allocate( u0(nk,nij), h0(nk,nij), u1(nk,nij), h1(nk,nij) ) call random_number(u0) ! In range 0-1 @@ -61,8 +80,8 @@ program time_MOM_remapping do isamp = 1, nsamp ! Time reconstruction + remapping do ischeme = 1, nschemes - call initialize_remapping(CS, remapping_scheme=trim(scheme_labels(ischeme)), & - h_neglect=h_neglect, h_neglect_edge=h_neglect) + call initialize_remapping(CS, remapping_scheme=trim(scheme_labels(ischeme)), nk=nk, & + h_neglect=h_neglect, h_neglect_edge=h_neglect) call cpu_time(start) do iter = 1, nits ! Make many passes to reduce sampling error do ij = 1, nij ! Calling nij times to make similar to cost in MOM_ALE() diff --git a/config_src/drivers/unit_tests/test_MOM_remapping.F90 b/config_src/drivers/unit_tests/test_MOM_remapping.F90 index e62b779bd6..4c6fe4f750 100644 --- a/config_src/drivers/unit_tests/test_MOM_remapping.F90 +++ b/config_src/drivers/unit_tests/test_MOM_remapping.F90 @@ -2,6 +2,18 @@ program test_MOM_remapping use MOM_remapping, only : remapping_unit_tests -if (remapping_unit_tests(.true.)) stop 1 +integer :: n !< Number of arguments, or tests +character(len=12) :: cmd_ln_arg !< Command line argument (if any) + +n = command_argument_count() + +if (n==1) then + call get_command_argument(1, cmd_ln_arg) + read(cmd_ln_arg,*) n +else + n = 3000 ! Fallback value if no argument provided +endif + +if (remapping_unit_tests(.true., num_comp_samp=n)) stop 1 end program test_MOM_remapping diff --git a/config_src/drivers/unit_tests/test_numerical_testing_type.F90 b/config_src/drivers/unit_tests/test_numerical_testing_type.F90 new file mode 100644 index 0000000000..374c83f0c7 --- /dev/null +++ b/config_src/drivers/unit_tests/test_numerical_testing_type.F90 @@ -0,0 +1,7 @@ +program test_numerical_testing_type + +use numerical_testing_type, only : testing_type_unit_test + +if (testing_type_unit_test(.true.)) stop 1 + +end program test_numerical_testing_type diff --git a/docs/discrete_space.rst b/docs/discrete_space.rst index 08a41a5f2d..64a3ad36c7 100644 --- a/docs/discrete_space.rst +++ b/docs/discrete_space.rst @@ -17,4 +17,5 @@ algorithm. api/generated/pages/Discrete_Coriolis api/generated/pages/Discrete_PG api/generated/pages/Energetic_Consistency + api/generated/pages/Vertical_Reconstruction api/generated/pages/Discrete_OBC diff --git a/docs/zotero.bib b/docs/zotero.bib index bbd2e30478..01fe2c6185 100644 --- a/docs/zotero.bib +++ b/docs/zotero.bib @@ -2946,3 +2946,17 @@ @article{Young1994 pages={1812--1826}, year={1994} } + +@article{van_leer_1977, + title = {Towards the ultimate conservative difference scheme. {IV}. {A} new approach to numerical convection}, + volume = {23}, + issn = {0021-9991}, + doi = {10.1016/0021-9991(77)90095-X}, + number = {3}, + journal = {Journal of Computational Physics}, + author = {Van Leer, Bram}, + month = mar, + year = {1977}, + pages = {276--299}, +} + diff --git a/src/ALE/MOM_ALE.F90 b/src/ALE/MOM_ALE.F90 index bc3099d68d..923c542c78 100644 --- a/src/ALE/MOM_ALE.F90 +++ b/src/ALE/MOM_ALE.F90 @@ -257,7 +257,7 @@ subroutine ALE_init( param_file, GV, US, max_depth, CS) h_neglect = GV%kg_m2_to_H * 1.0e-30 ; h_neglect_edge = GV%kg_m2_to_H * 1.0e-10 endif - call initialize_remapping( CS%remapCS, string, & + call initialize_remapping( CS%remapCS, string, nk=GV%ke, & boundary_extrapolation=init_boundary_extrap, & check_reconstruction=check_reconstruction, & check_remapping=check_remapping, & @@ -265,7 +265,7 @@ subroutine ALE_init( param_file, GV, US, max_depth, CS) om4_remap_via_sub_cells=om4_remap_via_sub_cells, & answer_date=CS%answer_date, & h_neglect=h_neglect, h_neglect_edge=h_neglect_edge) - call initialize_remapping( CS%vel_remapCS, vel_string, & + call initialize_remapping( CS%vel_remapCS, vel_string, nk=GV%ke, & boundary_extrapolation=init_boundary_extrap, & check_reconstruction=check_reconstruction, & check_remapping=check_remapping, & diff --git a/src/ALE/MOM_remapping.F90 b/src/ALE/MOM_remapping.F90 index 3c2c0af6df..7257319edb 100644 --- a/src/ALE/MOM_remapping.F90 +++ b/src/ALE/MOM_remapping.F90 @@ -6,11 +6,11 @@ module MOM_remapping use MOM_error_handler, only : MOM_error, FATAL use MOM_string_functions, only : uppercase +use numerical_testing_type, only : testing use regrid_edge_values, only : edge_values_explicit_h4, edge_values_implicit_h4 use regrid_edge_values, only : edge_values_explicit_h4cw use regrid_edge_values, only : edge_values_implicit_h4, edge_values_implicit_h6 use regrid_edge_values, only : edge_slopes_implicit_h3, edge_slopes_implicit_h5 -use remapping_attic, only : remapping_attic_unit_tests use PCM_functions, only : PCM_reconstruction use PLM_functions, only : PLM_reconstruction, PLM_boundary_extrapolation use PPM_functions, only : PPM_reconstruction, PPM_boundary_extrapolation @@ -18,6 +18,24 @@ module MOM_remapping use PQM_functions, only : PQM_reconstruction, PQM_boundary_extrapolation_v1 use MOM_hybgen_remap, only : hybgen_plm_coefs, hybgen_ppm_coefs, hybgen_weno_coefs +use Recon1d_type, only : Recon1d +use Recon1d_PCM, only : PCM +use Recon1d_PLM_CW, only : PLM_CW +use Recon1d_PLM_hybgen, only : PLM_hybgen +use Recon1d_PLM_CWK, only : PLM_CWK +use Recon1d_MPLM_CWK, only : MPLM_CWK +use Recon1d_EMPLM_CWK, only : EMPLM_CWK +use Recon1d_MPLM_WA, only : MPLM_WA +use Recon1d_EMPLM_WA, only : EMPLM_WA +use Recon1d_MPLM_WA_poly, only : MPLM_WA_poly +use Recon1d_EMPLM_WA_poly, only : EMPLM_WA_poly +use Recon1d_PPM_CW, only : PPM_CW +use Recon1d_PPM_hybgen, only : PPM_hybgen +use Recon1d_PPM_CWK, only : PPM_CWK +use Recon1d_EPPM_CWK, only : EPPM_CWK +use Recon1d_PPM_H4_2019, only : PPM_H4_2019 +use Recon1d_PPM_H4_2018, only : PPM_H4_2018 + implicit none ; private !> Container for remapping parameters @@ -34,6 +52,12 @@ module MOM_remapping logical :: check_remapping = .false. !> If true, the intermediate values used in remapping are forced to be bounded. logical :: force_bounds_in_subcell = .false. + !> If true, impose bounds on the remapping from sub-cells to target grid + logical :: force_bounds_in_target = .true. + !> If true, impose bounds on the remapping from non-vanished sub-cells to target grid + logical :: better_force_bounds_in_target = .false. + !> If true, calculate and use an offset when summing sub-cells to the target grid + logical :: offset_tgt_summation = .false. !> The vintage of the expressions to use for remapping. Values below 20190101 result !! in the use of older, less accurate expressions. integer :: answer_date = 99991231 @@ -47,37 +71,12 @@ module MOM_remapping !> A negligibly small width for the purpose of edge value calculations in the same units !! as the h0 argument to remapping_core_h [H] real :: h_neglect_edge -end type -!> Class to assist in unit tests -type :: testing - private - !> True if any fail has been encountered since instantiation of "testing" - logical :: state = .false. - !> Count of tests checked - integer :: num_tests_checked = 0 - !> Count of tests failed - integer :: num_tests_failed = 0 - !> If true, be verbose and write results to stdout. Default True. - logical :: verbose = .true. - !> Error channel - integer :: stderr = 0 - !> Standard output channel - integer :: stdout = 6 - !> If true, stop instantly - logical :: stop_instantly = .false. - !> Record instances that fail - integer :: ifailed(100) = 0. - !> Record label of first instance that failed - character(len=:), allocatable :: label_first_fail - - contains - procedure :: test => test !< Update the testing state - procedure :: set => set !< Set attributes - procedure :: outcome => outcome !< Return current outcome - procedure :: summarize => summarize !< Summarize testing state - procedure :: real_arr => real_arr !< Compare array of reals - procedure :: int_arr => int_arr !< Compare array of integers + !> If true, do some debugging as operations proceed + logical :: debug = .false. + + !> The instance of the actual equation of state + class(Recon1d), pointer :: reconstruction => Null() end type ! The following routines are visible to the outside world @@ -97,6 +96,7 @@ module MOM_remapping integer, parameter :: REMAPPING_WENO_HYBGEN= 7 !< O(h^3) remapping scheme integer, parameter :: REMAPPING_PQM_IH4IH3 = 8 !< O(h^4) remapping scheme integer, parameter :: REMAPPING_PQM_IH6IH5 = 9 !< O(h^5) remapping scheme +integer, parameter :: REMAPPING_VIA_CLASS =99 !< Scheme is controlled by Recon1d class integer, parameter :: INTEGRATION_PCM = 0 !< Piecewise Constant Method integer, parameter :: INTEGRATION_PLM = 1 !< Piecewise Linear Method @@ -121,7 +121,8 @@ module MOM_remapping !> Set parameters within remapping object subroutine remapping_set_param(CS, remapping_scheme, boundary_extrapolation, & check_reconstruction, check_remapping, force_bounds_in_subcell, & - om4_remap_via_sub_cells, answers_2018, answer_date, & + force_bounds_in_target, better_force_bounds_in_target, offset_tgt_summation, & + om4_remap_via_sub_cells, answers_2018, answer_date, nk, & h_neglect, h_neglect_edge) type(remapping_CS), intent(inout) :: CS !< Remapping control structure character(len=*), optional, intent(in) :: remapping_scheme !< Remapping scheme to use @@ -129,6 +130,9 @@ subroutine remapping_set_param(CS, remapping_scheme, boundary_extrapolation, & logical, optional, intent(in) :: check_reconstruction !< Indicate to check reconstructions logical, optional, intent(in) :: check_remapping !< Indicate to check results of remapping logical, optional, intent(in) :: force_bounds_in_subcell !< Force subcells values to be bounded + logical, optional, intent(in) :: force_bounds_in_target !< Force target values to be bounded + logical, optional, intent(in) :: better_force_bounds_in_target !< Force target values to be bounded + logical, optional, intent(in) :: offset_tgt_summation !< Use an offset when summing sub-cells logical, optional, intent(in) :: om4_remap_via_sub_cells !< If true, use OM4 remapping algorithm logical, optional, intent(in) :: answers_2018 !< If true use older, less accurate expressions. integer, optional, intent(in) :: answer_date !< The vintage of the expressions to use @@ -138,9 +142,18 @@ subroutine remapping_set_param(CS, remapping_scheme, boundary_extrapolation, & real, optional, intent(in) :: h_neglect_edge !< A negligibly small width for the purpose of edge !! value calculations in the same units as as the h0 !! argument to remapping_core_h [H] + integer, optional, intent(in) :: nk !< Number of levels to initialize reconstruction class with if (present(remapping_scheme)) then call setReconstructionType( remapping_scheme, CS ) + if (index(trim(remapping_scheme),'C_')>0) then + if (present(nk)) then + call CS%reconstruction%init(nk, h_neglect=h_neglect) + else + call MOM_error( FATAL, 'MOM_remapping, remapping_set_param: '//& + 'Using the Recon1d class for remapping requires nk to be passed' ) + endif + endif endif if (present(boundary_extrapolation)) then CS%boundary_extrapolation = boundary_extrapolation @@ -154,6 +167,15 @@ subroutine remapping_set_param(CS, remapping_scheme, boundary_extrapolation, & if (present(force_bounds_in_subcell)) then CS%force_bounds_in_subcell = force_bounds_in_subcell endif + if (present(force_bounds_in_target)) then + CS%force_bounds_in_target = force_bounds_in_target + endif + if (present(better_force_bounds_in_target)) then + CS%better_force_bounds_in_target = better_force_bounds_in_target + endif + if (present(offset_tgt_summation)) then + CS%offset_tgt_summation = offset_tgt_summation + endif if (present(om4_remap_via_sub_cells)) then CS%om4_remap_via_sub_cells = om4_remap_via_sub_cells endif @@ -177,7 +199,8 @@ subroutine remapping_set_param(CS, remapping_scheme, boundary_extrapolation, & end subroutine remapping_set_param subroutine extract_member_remapping_CS(CS, remapping_scheme, degree, boundary_extrapolation, check_reconstruction, & - check_remapping, force_bounds_in_subcell) + check_remapping, force_bounds_in_subcell, force_bounds_in_target, & + better_force_bounds_in_target, offset_tgt_summation) type(remapping_CS), intent(in) :: CS !< Control structure for remapping module integer, optional, intent(out) :: remapping_scheme !< Determines which reconstruction scheme to use integer, optional, intent(out) :: degree !< Degree of polynomial reconstruction @@ -187,6 +210,9 @@ subroutine extract_member_remapping_CS(CS, remapping_scheme, degree, boundary_ex !! for conservation and bounds. logical, optional, intent(out) :: force_bounds_in_subcell !< If true, the intermediate values used in !! remapping are forced to be bounded. + logical, optional, intent(out) :: force_bounds_in_target !< Force target values to be bounded + logical, optional, intent(out) :: better_force_bounds_in_target !< Force target values to be bounded + logical, optional, intent(out) :: offset_tgt_summation !< Use an offset when summing sub-cells if (present(remapping_scheme)) remapping_scheme = CS%remapping_scheme if (present(degree)) degree = CS%degree @@ -194,10 +220,14 @@ subroutine extract_member_remapping_CS(CS, remapping_scheme, degree, boundary_ex if (present(check_reconstruction)) check_reconstruction = CS%check_reconstruction if (present(check_remapping)) check_remapping = CS%check_remapping if (present(force_bounds_in_subcell)) force_bounds_in_subcell = CS%force_bounds_in_subcell + if (present(force_bounds_in_target)) force_bounds_in_target = CS%force_bounds_in_target + if (present(better_force_bounds_in_target)) better_force_bounds_in_target = CS%better_force_bounds_in_target + if (present(offset_tgt_summation)) offset_tgt_summation = CS%offset_tgt_summation end subroutine extract_member_remapping_CS -!> Remaps column of values u0 on grid h0 to grid h1 assuming the top edge is aligned. +!> Remaps column of values u0 on grid h0 to grid h1 assuming the top edge is aligned and using the OM4 +!! reconstruction methods !! !! \todo Remove h_neglect argument by moving into remapping_CS !! \todo Remove PCM_cell argument by adding new method in Recon1D class @@ -212,7 +242,6 @@ subroutine remapping_core_h(CS, n0, h0, u0, n1, h1, u1, net_err, PCM_cell) real, optional, intent(out) :: net_err !< Error in total column [A H] logical, dimension(n0), optional, intent(in) :: PCM_cell !< If present, use PCM remapping for !! cells in the source grid where this is true. - ! Local variables real, dimension(n0+n1+1) :: h_sub ! Width of each each sub-cell [H] real, dimension(n0+n1+1) :: uh_sub ! Integral of u*h over each sub-cell [A H] @@ -225,7 +254,6 @@ subroutine remapping_core_h(CS, n0, h0, u0, n1, h1, u1, net_err, PCM_cell) integer, dimension(n1) :: itgt_start ! Index of first sub-cell within each target cell integer, dimension(n1) :: itgt_end ! Index of last sub-cell within each target cell ! For error checking/debugging - logical, parameter :: force_bounds_in_target = .true. ! To fix round-off issues real :: u02_err ! Integrated reconstruction error estimates [H A] real, dimension(n0,2) :: ppoly_r_E ! Edge value of polynomial [A] real, dimension(n0,2) :: ppoly_r_S ! Edge slope of polynomial [A H-1] @@ -233,62 +261,76 @@ subroutine remapping_core_h(CS, n0, h0, u0, n1, h1, u1, net_err, PCM_cell) real :: uh_err ! A bound on the error in the sum of u*h, as estimated by the remapping code [A H] integer :: iMethod ! An integer indicating the integration method used - call build_reconstructions_1d( CS, n0, h0, u0, ppoly_r_coefs, ppoly_r_E, ppoly_r_S, iMethod, & - CS%h_neglect, CS%h_neglect_edge, PCM_cell ) + ! Calculate sub-layer thicknesses and indices connecting sub-layers to source and target grids + ! Sets: h_sub, h0_eff, isrc_start, isrc_end, isrc_max, isub_src, itgt_start, itgt_end + call intersect_src_tgt_grids(n0, h0, n1, h1, h_sub, h0_eff, & + isrc_start, isrc_end, isrc_max, itgt_start, itgt_end, isub_src) - if (CS%om4_remap_via_sub_cells) then + if (CS%remapping_scheme == REMAPPING_VIA_CLASS) then - if (CS%check_reconstruction) call check_reconstructions_1d(n0, h0, u0, CS%degree, & - CS%boundary_extrapolation, ppoly_r_coefs, ppoly_r_E) +! if (CS%debug) call CS%reconstruction%set_debug() ! Sets an internal flag - ! Calculate sub-layer thicknesses and indices connecting sub-layers to source and target grids - call intersect_src_tgt_grids( n0, h0, n1, h1, h_sub, h0_eff, & - isrc_start, isrc_end, isrc_max, itgt_start, itgt_end, isub_src ) + call CS%reconstruction%reconstruct(h0, u0) + + ! Adjust h_sub so that the Hallberg conservation trick works properly +! call adjust_h_sub( n0, h0, n1, isrc_start, isrc_end, isrc_max, h_sub ) ! Loop over each sub-cell to calculate average/integral values within each sub-cell. - ! Uses: h_sub, h0_eff, isub_src + ! Uses: h_sub, isrc_start, isrc_end, isrc_max, isub_src ! Sets: u_sub, uh_sub - call remap_src_to_sub_grid_om4(n0, h0, u0, ppoly_r_E, ppoly_r_coefs, n1, h_sub, & - h0_eff, isrc_start, isrc_end, isrc_max, isub_src, & - iMethod, CS%force_bounds_in_subcell, u_sub, uh_sub, u02_err) + call CS%reconstruction%remap_to_sub_grid(h0, u0, n1, h_sub, & + isrc_start, isrc_end, isrc_max, isub_src, & + u_sub, uh_sub, u02_err) ! Loop over each target cell summing the integrals from sub-cells within the target cell. ! Uses: itgt_start, itgt_end, h1, h_sub, uh_sub, u_sub ! Sets: u1, uh_err call remap_sub_to_tgt_grid(n0, n1, h1, h_sub, u_sub, uh_sub, itgt_start, itgt_end, & - force_bounds_in_target, u1, uh_err) + CS%force_bounds_in_target, CS%offset_tgt_summation, & + CS%better_force_bounds_in_target, u1, uh_err) ! Include the error remapping from source to sub-cells in the estimate of total remapping error uh_err = uh_err + u02_err - if (CS%check_remapping) call check_remapped_values(n0, h0, u0, ppoly_r_E, CS%degree, ppoly_r_coefs, & - n1, h1, u1, iMethod, uh_err, "remapping_core_h") + else ! Uses the OM4-era reconstruction functions - else ! i.e. if (CS%om4_remap_via_sub_cells == .false.) + call build_reconstructions_1d(CS, n0, h0, u0, ppoly_r_coefs, ppoly_r_E, ppoly_r_S, iMethod, & + CS%h_neglect, CS%h_neglect_edge, PCM_cell, debug=CS%debug) - ! Calculate sub-layer thicknesses and indices connecting sub-layers to source and target grids - call intersect_src_tgt_grids( n0, h0, n1, h1, h_sub, h0_eff, & - isrc_start, isrc_end, isrc_max, itgt_start, itgt_end, isub_src ) + if (CS%check_reconstruction) call check_reconstructions_1d(n0, h0, u0, CS%degree, & + CS%boundary_extrapolation, ppoly_r_coefs, ppoly_r_E) ! Loop over each sub-cell to calculate average/integral values within each sub-cell. ! Uses: h_sub, h0_eff, isub_src ! Sets: u_sub, uh_sub - call remap_src_to_sub_grid(n0, h0, u0, ppoly_r_E, ppoly_r_coefs, n1, h_sub, & - isrc_start, isrc_end, isrc_max, isub_src, & - iMethod, CS%force_bounds_in_subcell, u_sub, uh_sub, u02_err) + if (CS%om4_remap_via_sub_cells) then ! Uses the version from OM4 with a bug at the bottom + + call remap_src_to_sub_grid_om4(n0, h0, u0, ppoly_r_E, ppoly_r_coefs, n1, h_sub, & + h0_eff, isrc_start, isrc_end, isrc_max, isub_src, & + iMethod, CS%force_bounds_in_subcell, u_sub, uh_sub, u02_err) + + else ! i.e. if (CS%om4_remap_via_sub_cells == .false.) + + call remap_src_to_sub_grid(n0, h0, u0, ppoly_r_E, ppoly_r_coefs, n1, h_sub, & + isrc_start, isrc_end, isrc_max, isub_src, & + iMethod, CS%force_bounds_in_subcell, u_sub, uh_sub, u02_err) + + endif ! Loop over each target cell summing the integrals from sub-cells within the target cell. ! Uses: itgt_start, itgt_end, h1, h_sub, uh_sub, u_sub ! Sets: u1, uh_err - call remap_sub_to_tgt_grid(n0, n1, h1, h_sub, u_sub, uh_sub, itgt_start, itgt_end, & - force_bounds_in_target, u1, uh_err) - + call remap_sub_to_tgt_grid_om4(n0, n1, h1, h_sub, u_sub, uh_sub, itgt_start, itgt_end, & + CS%force_bounds_in_target, u1, uh_err) ! Include the error remapping from source to sub-cells in the estimate of total remapping error uh_err = uh_err + u02_err + if (CS%check_remapping) call check_remapped_values(n0, h0, u0, ppoly_r_E, CS%degree, ppoly_r_coefs, & + n1, h1, u1, iMethod, uh_err, "remapping_core_h") + endif - if (present(net_err)) net_err = uh_err + if (present(net_err)) net_err = uh_err end subroutine remapping_core_h @@ -315,7 +357,6 @@ subroutine remapping_core_w( CS, n0, h0, u0, n1, dx, u1) integer, dimension(n1) :: itgt_start ! Index of first sub-cell within each target cell integer, dimension(n1) :: itgt_end ! Index of last sub-cell within each target cell ! For error checking/debugging - logical, parameter :: force_bounds_in_target = .true. ! To fix round-off issues real :: u02_err ! Integrated reconstruction error estimates [H A] real, dimension(n0,2) :: ppoly_r_E ! Edge value of polynomial [A] real, dimension(n0,2) :: ppoly_r_S ! Edge slope of polynomial [A H-1] @@ -354,8 +395,8 @@ subroutine remapping_core_w( CS, n0, h0, u0, n1, dx, u1) ! Loop over each target cell summing the integrals from sub-cells within the target cell. ! Uses: itgt_start, itgt_end, h1, h_sub, uh_sub, u_sub ! Sets: u1, uh_err - call remap_sub_to_tgt_grid(n0, n1, h1, h_sub, u_sub, uh_sub, itgt_start, itgt_end, & - force_bounds_in_target, u1, uh_err) + call remap_sub_to_tgt_grid_om4(n0, n1, h1, h_sub, u_sub, uh_sub, itgt_start, itgt_end, & + CS%force_bounds_in_target, u1, uh_err) ! Include the error remapping from source to sub-cells in the estimate of total remapping error uh_err = uh_err + u02_err @@ -368,7 +409,7 @@ end subroutine remapping_core_w !> Creates polynomial reconstructions of u0 on the source grid h0. subroutine build_reconstructions_1d( CS, n0, h0, u0, ppoly_r_coefs, & ppoly_r_E, ppoly_r_S, iMethod, h_neglect, & - h_neglect_edge, PCM_cell ) + h_neglect_edge, PCM_cell, debug ) type(remapping_CS), intent(in) :: CS !< Remapping control structure integer, intent(in) :: n0 !< Number of cells on source grid real, dimension(n0), intent(in) :: h0 !< Cell widths on source grid [H] @@ -386,12 +427,16 @@ subroutine build_reconstructions_1d( CS, n0, h0, u0, ppoly_r_coefs, & !! The default is h_neglect. logical, optional, intent(in) :: PCM_cell(n0) !< If present, use PCM remapping for !! cells from the source grid where this is true. + logical, optional, intent(in) :: debug !< If true, enable debugging ! Local variables real :: h_neg_edge ! A negligibly small width for the purpose of edge value ! calculations in the same units as h0 [H] integer :: local_remapping_scheme integer :: k, n + logical :: deb ! Do debugging + + deb=.false.; if (present(debug)) deb=debug h_neg_edge = h_neglect ; if (present(h_neglect_edge)) h_neg_edge = h_neglect_edge @@ -484,6 +529,9 @@ subroutine build_reconstructions_1d( CS, n0, h0, u0, ppoly_r_coefs, & ppoly_r_coefs, h_neglect ) endif iMethod = INTEGRATION_PQM + case ( REMAPPING_VIA_CLASS ) + call MOM_error( FATAL, 'MOM_remapping, build_reconstructions_1d: '//& + 'Should not reach this point if using Recon1d class for remapping' ) case default call MOM_error( FATAL, 'MOM_remapping, build_reconstructions_1d: '//& 'The selected remapping method is invalid' ) @@ -617,15 +665,9 @@ subroutine intersect_src_tgt_grids( n0, h0, n1, h1, h_sub, h0_eff, & real :: dh ! The width of the sub-cell [H] real :: dh0_eff ! Running sum of source cell thickness [H] ! For error checking/debugging - integer :: i0_last_thick_cell logical :: src_has_volume !< True if h0 has not been consumed logical :: tgt_has_volume !< True if h1 has not been consumed - i0_last_thick_cell = 0 - do i0 = 1, n0 - if (h0(i0)>0.) i0_last_thick_cell = i0 - enddo - ! Initialize algorithm h0_supply = h0(1) h1_supply = h1(1) @@ -752,8 +794,50 @@ subroutine intersect_src_tgt_grids( n0, h0, n1, h1, h_sub, h0_eff, & endif enddo + end subroutine intersect_src_tgt_grids +!> Adjust h_sub to ensure accurate conservation +!! +!! Loop over each source cell substituting the thickest sub-cell (within the source cell) with the +!! residual of the source cell thickness minus the sum of other sub-cells +!! aka a genius algorithm for accurate conservation when remapping from Robert Hallberg (\@Hallberg-NOAA). +!subroutine adjust_h_sub( n0, h0, n1, isrc_start, isrc_end, isrc_max, h_sub ) +! integer, intent(in) :: n0 !< Number of cells in source grid +! real, intent(in) :: h0(n0) !< Source grid widths (size n0) [H] +! integer, intent(in) :: n1 !< Number of cells in target grid +! integer, intent(in) :: isrc_start(n0) !< Index of first sub-cell within each source cell +! integer, intent(in) :: isrc_end(n0) !< Index of last sub-cell within each source cell +! integer, intent(in) :: isrc_max(n0) !< Index of thickest sub-cell within each source cell +! real, intent(inout) :: h_sub(n0+n1+1) !< Overlapping sub-cell thicknesses, h_sub [H] +! ! Local variables +! integer :: i_sub ! Index of sub-cell +! integer :: i0 ! Index into h0(1:n0), source column +! integer :: i_max ! Used to record which sub-cell is the largest contribution of a source cell +! real :: dh_max ! Used to record which sub-cell is the largest contribution of a source cell [H] +! real :: dh ! The width of the sub-cell [H] +! integer :: i0_last_thick_cell ! Last h0 cell with finite thickness +! +! i0_last_thick_cell = 0 +! do i0 = 1, n0 +! if (h0(i0)>0.) i0_last_thick_cell = i0 +! enddo +! +! do i0 = 1, i0_last_thick_cell +! i_max = isrc_max(i0) +! dh_max = h_sub(i_max) +! if (dh_max > 0.) then +! ! dh will be the sum of sub-cell thicknesses within the source cell except for the thickest sub-cell. +! dh = 0. +! do i_sub = isrc_start(i0), isrc_end(i0) +! if (i_sub /= i_max) dh = dh + h_sub(i_sub) +! enddo +! h_sub(i_max) = h0(i0) - dh +! endif +! enddo +! +!end subroutine adjust_h_sub + !> Remaps column of n0 values u0 on grid h0 to subgrid h_sub !! !! This includes an error for the scenario where the source grid is much thicker than @@ -854,9 +938,9 @@ subroutine remap_src_to_sub_grid_om4(n0, h0, u0, ppoly0_E, ppoly0_coefs, n1, h_s if (adjust_thickest_subcell) then ! Loop over each source cell substituting the integral/average for the thickest sub-cell (within ! the source cell) with the residual of the source cell integral minus the other sub-cell integrals - ! aka a genius algorithm for accurate conservation when remapping from Robert Hallberg (@Hallberg-NOAA). + ! aka a genius algorithm for accurate conservation when remapping from Robert Hallberg (\@Hallberg-NOAA). ! Uses: i0_last_thick_cell, isrc_max, h_sub, isrc_start, isrc_end, uh_sub, u0, h0 - ! Updates: uh_sub + ! Updates: uh_sub, u_sub do i0 = 1, i0_last_thick_cell i_max = isrc_max(i0) dh_max = h_sub(i_max) @@ -903,7 +987,7 @@ subroutine remap_src_to_sub_grid(n0, h0, u0, ppoly0_E, ppoly0_coefs, n1, h_sub, real :: dh ! The width of the sub-cell [H] real :: duh ! The total amount of accumulated stuff (u*h) [A H] real :: dh0_eff ! Running sum of source cell thickness [H] - real :: u0_min(n0), u0_max(n0) !< Min/max of u0 for each source cell [A] + real :: u0_min(n0), u0_max(n0) ! Min/max of u0 for each source cell [A] ! For error checking/debugging logical, parameter :: adjust_thickest_subcell = .true. ! To fix round-off conservation issues integer :: i0_last_thick_cell @@ -965,7 +1049,6 @@ subroutine remap_src_to_sub_grid(n0, h0, u0, ppoly0_E, ppoly0_coefs, n1, h_sub, i_sub = n0+n1+1 ! Sub-cell thickness from loop above dh = h_sub(i_sub) - ! Source cell i0 = isub_src(i_sub) @@ -995,7 +1078,7 @@ subroutine remap_src_to_sub_grid(n0, h0, u0, ppoly0_E, ppoly0_coefs, n1, h_sub, if (adjust_thickest_subcell) then ! Loop over each source cell substituting the integral/average for the thickest sub-cell (within ! the source cell) with the residual of the source cell integral minus the other sub-cell integrals - ! aka a genius algorithm for accurate conservation when remapping from Robert Hallberg (@Hallberg-NOAA). + ! aka a genius algorithm for accurate conservation when remapping from Robert Hallberg (\@Hallberg-NOAA). ! Uses: i0_last_thick_cell, isrc_max, h_sub, isrc_start, isrc_end, uh_sub, u0, h0 ! Updates: uh_sub do i0 = 1, i0_last_thick_cell @@ -1016,7 +1099,8 @@ subroutine remap_src_to_sub_grid(n0, h0, u0, ppoly0_E, ppoly0_coefs, n1, h_sub, end subroutine remap_src_to_sub_grid !> Remaps column of n0+n1+1 values usub on sub-grid h_sub to targets on grid h1 -subroutine remap_sub_to_tgt_grid(n0, n1, h1, h_sub, u_sub, uh_sub, & +!! using the OM4-era algorithm +subroutine remap_sub_to_tgt_grid_om4(n0, n1, h1, h_sub, u_sub, uh_sub, & itgt_start, itgt_end, force_bounds_in_target, u1, uh_err) integer, intent(in) :: n0 !< Number of cells in source grid integer, intent(in) :: n1 !< Number of cells in target grid @@ -1076,6 +1160,87 @@ subroutine remap_sub_to_tgt_grid(n0, n1, h1, h_sub, u_sub, uh_sub, & endif enddo +end subroutine remap_sub_to_tgt_grid_om4 + +!> Remaps column of n0+n1+1 values usub on sub-grid h_sub to targets on grid h1 +subroutine remap_sub_to_tgt_grid(n0, n1, h1, h_sub, u_sub, uh_sub, & + itgt_start, itgt_end, force_bounds_in_target, & + better_force_bounds_in_target, offset_summation, u1, uh_err) + integer, intent(in) :: n0 !< Number of cells in source grid + integer, intent(in) :: n1 !< Number of cells in target grid + real, intent(in) :: h1(n1) !< Target grid widths (size n1) [H] + real, intent(in) :: h_sub(n0+n1+1) !< Overlapping sub-cell thicknesses, h_sub [H] + real, intent(in) :: u_sub(n0+n1+1) !< Sub-cell cell averages (size n1) [A] + real, intent(in) :: uh_sub(n0+n1+1) !< Sub-cell cell integrals (size n1) [A H] + integer, intent(in) :: itgt_start(n1) !< Index of first sub-cell within each target cell + integer, intent(in) :: itgt_end(n1) !< Index of last sub-cell within each target cell + logical, intent(in) :: force_bounds_in_target !< Force sub-cell values to be bounded + logical, intent(in) :: better_force_bounds_in_target !< Force sub-cell values to be bounded + logical, intent(in) :: offset_summation !< Offset values in summation for accuracy + real, intent(out) :: u1(n1) !< Target cell averages (size n1) [A] + real, intent(out) :: uh_err !< Estimate of bound on error in sum of u*h [A H] + ! Local variables + integer :: i1 ! tgt loop index + integer :: i_sub ! index to sub-layer + real :: dh ! The width of the sub-cell [H] + real :: duh ! The total amount of accumulated stuff (u*h) [A H] + real :: u1min, u1max ! Minimum and maximum values of reconstructions [A] + real :: u_orig ! The original value of the reconstruction in a cell prior to bounding [A] + real :: u_ref ! A value to offest the summation to gain accuracy [A] + real :: h_max ! Thickest cell encountered [H] + + u1min = 0. ! Not necessary, but avoids an overzealous compiler ... + u1max = 0. ! ... warning about uninitialized variables + u_ref = 0. ! An offset of 0. should do no harm + h_max = 0. + + ! Loop over each target cell summing the integrals from sub-cells within the target cell. + ! Uses: itgt_start, itgt_end, h_sub, uh_sub, u_sub + ! Sets: u1, uh_err + uh_err = 0. + do i1 = 1, n1 + if (h1(i1) > 0.) then + duh = 0. ; dh = 0. + i_sub = itgt_start(i1) + if (force_bounds_in_target) then + u1min = u_sub(i_sub) + u1max = u_sub(i_sub) + endif + if (offset_summation) then + u_ref = 0. ! An offset of 0. should do no harm + h_max = 0. + do i_sub = itgt_start(i1), itgt_end(i1) + if (h_sub(i_sub) > h_max) then + u_ref = u_sub(i_sub) + h_max = h_sub(i_sub) + endif + enddo + endif + do i_sub = itgt_start(i1), itgt_end(i1) + if (force_bounds_in_target .or. better_force_bounds_in_target .and. h_sub(i_sub)>0.) then + u1min = min(u1min, u_sub(i_sub)) + u1max = max(u1max, u_sub(i_sub)) + endif + dh = dh + h_sub(i_sub) + ! Ideally u_ref would be already be substracted in uh_sub + duh = duh + ( uh_sub(i_sub) - h_sub(i_sub) * u_ref ) + ! This accumulates the contribution to the error bound for the sum of u*h + uh_err = uh_err + max(abs(duh),abs(uh_sub(i_sub)))*epsilon(duh) + enddo + u1(i1) = duh / dh + u_ref + ! This is the contribution from the division to the error bound for the sum of u*h + uh_err = uh_err + abs(duh)*epsilon(duh) + if (force_bounds_in_target) then + u_orig = u1(i1) + u1(i1) = max(u1min, min(u1max, u1(i1))) + ! Adjusting to be bounded contributes to the error for the sum of u*h + uh_err = uh_err + dh*abs( u1(i1)-u_orig ) + endif + else + u1(i1) = u_sub(itgt_start(i1)) + endif + enddo + end subroutine remap_sub_to_tgt_grid !> Linearly interpolate interface data, u_src, from grid h_src to a grid h_dest @@ -1488,7 +1653,8 @@ end subroutine dzFromH1H2 !> Constructor for remapping control structure subroutine initialize_remapping( CS, remapping_scheme, boundary_extrapolation, & check_reconstruction, check_remapping, force_bounds_in_subcell, & - om4_remap_via_sub_cells, answers_2018, answer_date, & + force_bounds_in_target, better_force_bounds_in_target, offset_tgt_summation, & + om4_remap_via_sub_cells, answers_2018, answer_date, nk, & h_neglect, h_neglect_edge) ! Arguments type(remapping_CS), intent(inout) :: CS !< Remapping control structure @@ -1497,6 +1663,9 @@ subroutine initialize_remapping( CS, remapping_scheme, boundary_extrapolation, & logical, optional, intent(in) :: check_reconstruction !< Indicate to check reconstructions logical, optional, intent(in) :: check_remapping !< Indicate to check results of remapping logical, optional, intent(in) :: force_bounds_in_subcell !< Force subcells values to be bounded + logical, optional, intent(in) :: force_bounds_in_target !< Force target values to be bounded + logical, optional, intent(in) :: better_force_bounds_in_target !< Force target values to be bounded + logical, optional, intent(in) :: offset_tgt_summation !< Use an offset when summing sub-cells logical, optional, intent(in) :: om4_remap_via_sub_cells !< If true, use OM4 remapping algorithm logical, optional, intent(in) :: answers_2018 !< If true use older, less accurate expressions. integer, optional, intent(in) :: answer_date !< The vintage of the expressions to use @@ -1504,13 +1673,24 @@ subroutine initialize_remapping( CS, remapping_scheme, boundary_extrapolation, & !! reconstructions in the same units as h0 [H] real, optional, intent(in) :: h_neglect_edge !< A negligibly small width for the purpose of edge !! value calculations in the same units as h0 [H]. + integer, optional, intent(in) :: nk !< Number of levels to initialize reconstruction class with ! Note that remapping_scheme is mandatory for initialize_remapping() - call remapping_set_param(CS, remapping_scheme=remapping_scheme, boundary_extrapolation=boundary_extrapolation, & - check_reconstruction=check_reconstruction, check_remapping=check_remapping, & + call remapping_set_param(CS, & + remapping_scheme=remapping_scheme, & + boundary_extrapolation=boundary_extrapolation, & + check_reconstruction=check_reconstruction, & + check_remapping=check_remapping, & force_bounds_in_subcell=force_bounds_in_subcell, & - om4_remap_via_sub_cells=om4_remap_via_sub_cells, answers_2018=answers_2018, answer_date=answer_date, & - h_neglect=h_neglect, h_neglect_edge=h_neglect_edge) + om4_remap_via_sub_cells=om4_remap_via_sub_cells, & + force_bounds_in_target=force_bounds_in_target, & + better_force_bounds_in_target=better_force_bounds_in_target, & + offset_tgt_summation=offset_tgt_summation, & + answers_2018=answers_2018, & + answer_date=answer_date, & + nk=nk, & + h_neglect=h_neglect, & + h_neglect_edge=h_neglect_edge) end subroutine initialize_remapping @@ -1524,6 +1704,15 @@ subroutine setReconstructionType(string,CS) ! Local variables integer :: degree degree = -99 + if (associated(CS%reconstruction)) then + ! We have a choice of being careless and allowing easy re-use (e.g. when testing) + CS%remapping_scheme = -911 + call CS%reconstruction%destroy() + deallocate( CS%reconstruction ) + ! or being careful and make sure we've properly clean up... + ! call MOM_error(FATAL, "setReconstructionType: "//& + ! "Recon1d type is already associated when initializing.") + endif select case ( uppercase(trim(string)) ) case ("PCM") CS%remapping_scheme = REMAPPING_PCM @@ -1555,6 +1744,54 @@ subroutine setReconstructionType(string,CS) case ("PQM_IH6IH5") CS%remapping_scheme = REMAPPING_PQM_IH6IH5 degree = 4 + case ("C_PCM") + allocate( PCM :: CS%reconstruction ) + CS%remapping_scheme = REMAPPING_VIA_CLASS + case ("C_PLM_CW") + allocate( PLM_CW :: CS%reconstruction ) + CS%remapping_scheme = REMAPPING_VIA_CLASS + case ("C_PLM_HYBGEN") + allocate( PLM_hybgen :: CS%reconstruction ) + CS%remapping_scheme = REMAPPING_VIA_CLASS + case ("C_MPLM_WA") + allocate( MPLM_WA :: CS%reconstruction ) + CS%remapping_scheme = REMAPPING_VIA_CLASS + case ("C_EMPLM_WA") + allocate( EMPLM_WA :: CS%reconstruction ) + CS%remapping_scheme = REMAPPING_VIA_CLASS + case ("C_MPLM_WA_POLY") + allocate( MPLM_WA_poly :: CS%reconstruction ) + CS%remapping_scheme = REMAPPING_VIA_CLASS + case ("C_EMPLM_WA_POLY") + allocate( EMPLM_WA_poly :: CS%reconstruction ) + CS%remapping_scheme = REMAPPING_VIA_CLASS + case ("C_PLM_CWK") + allocate( PLM_CWK :: CS%reconstruction ) + CS%remapping_scheme = REMAPPING_VIA_CLASS + case ("C_MPLM_CWK") + allocate( MPLM_CWK :: CS%reconstruction ) + CS%remapping_scheme = REMAPPING_VIA_CLASS + case ("C_EMPLM_CWK") + allocate( EMPLM_CWK :: CS%reconstruction ) + CS%remapping_scheme = REMAPPING_VIA_CLASS + case ("C_PPM_CW") + allocate( PPM_CW :: CS%reconstruction ) + CS%remapping_scheme = REMAPPING_VIA_CLASS + case ("C_PPM_HYBGEN") + allocate( PPM_hybgen :: CS%reconstruction ) + CS%remapping_scheme = REMAPPING_VIA_CLASS + case ("C_PPM_CWK") + allocate( PPM_CWK :: CS%reconstruction ) + CS%remapping_scheme = REMAPPING_VIA_CLASS + case ("C_EPPM_CWK") + allocate( EPPM_CWK :: CS%reconstruction ) + CS%remapping_scheme = REMAPPING_VIA_CLASS + case ("C_PPM_H4_2019") + allocate( PPM_H4_2019 :: CS%reconstruction ) + CS%remapping_scheme = REMAPPING_VIA_CLASS + case ("C_PPM_H4_2018") + allocate( PPM_H4_2018 :: CS%reconstruction ) + CS%remapping_scheme = REMAPPING_VIA_CLASS case default call MOM_error(FATAL, "setReconstructionType: "//& "Unrecognized choice for REMAPPING_SCHEME ("//trim(string)//").") @@ -1572,17 +1809,276 @@ subroutine end_remapping(CS) end subroutine end_remapping +!> Test if interpolate_column() produces the wrong answer +subroutine test_interp(test, msg, nsrc, h_src, u_src, ndest, h_dest, u_true) + type(testing), intent(inout) :: test !< Unit testing convenience functions + character(len=*), intent(in) :: msg !< Message to label test + integer, intent(in) :: nsrc !< Number of source cells + real, dimension(nsrc), intent(in) :: h_src !< Thickness of source cells [H] + real, dimension(nsrc+1), intent(in) :: u_src !< Values at source cell interfaces [A] + integer, intent(in) :: ndest !< Number of destination cells + real, dimension(ndest), intent(in) :: h_dest !< Thickness of destination cells [H] + real, dimension(ndest+1), intent(in) :: u_true !< Correct value at destination cell interfaces [A] + ! Local variables + real, dimension(ndest+1) :: u_dest ! Interpolated value at destination cell interfaces [A] + + ! Interpolate from src to dest + call interpolate_column(nsrc, h_src, u_src, ndest, h_dest, u_dest, .true.) + call test%real_arr(ndest, u_dest, u_true, msg) +end subroutine test_interp + +!> Test if reintegrate_column() produces the wrong answer +subroutine test_reintegrate(test, msg, nsrc, h_src, uh_src, ndest, h_dest, uh_true) + type(testing), intent(inout) :: test !< Unit testing convenience functions + character(len=*), intent(in) :: msg !< Message to label test + integer, intent(in) :: nsrc !< Number of source cells + real, dimension(nsrc), intent(in) :: h_src !< Thickness of source cells [H] + real, dimension(nsrc), intent(in) :: uh_src !< Values of source cell stuff [A H] + integer, intent(in) :: ndest !< Number of destination cells + real, dimension(ndest), intent(in) :: h_dest !< Thickness of destination cells [H] + real, dimension(ndest), intent(in) :: uh_true !< Correct value of destination cell stuff [A H] + ! Local variables + real, dimension(ndest) :: uh_dest ! Reintegrated value on destination cells [A H] + + ! Interpolate from src to dest + call reintegrate_column(nsrc, h_src, uh_src, ndest, h_dest, uh_dest) + call test%real_arr(ndest, uh_dest, uh_true, msg) + +end subroutine test_reintegrate + +!> Test class-based remapping for internal consistency on random data +subroutine test_recon_consistency(test, scheme, n0, niter, h_neglect) + type(testing), intent(inout) :: test !< Unit testing convenience functions + character(len=*), intent(in) :: scheme !< Name of scheme to use + integer, intent(in) :: n0 !< Number of source cells + integer, intent(in) :: niter !< Number of randomized columns to try + real, intent(in) :: h_neglect !< A negligibly small width used in cell reconstructions [H] + ! Local + type(remapping_CS) :: remapCS !< Remapping control structure + real :: h0(n0) ! Source grid [H but really nondim] + real :: u0(n0) ! Source values [A] + logical :: error ! Indicates a divergence + integer :: iter ! Loop counter + integer :: seed_size ! Number of integers used by seed + integer, allocatable :: seed(:) ! Random number seed + character(len=8) :: label ! Generated label + + call initialize_remapping(remapCS, scheme, nk=n0, h_neglect=h_neglect, & + force_bounds_in_subcell=.false. ) + + call random_seed(size=seed_size) + allocate( seed(seed_Size) ) + seed(:) = 102030405 ! Repeatable sequences + call random_seed(put=seed) + + error = .false. + do iter = 1, niter + call random_number( h0 ) ! In range 0-1 + h0(:) = max(0., h0(:) - 0.05) ! Make 5% of values equal to zero + call random_number( u0 ) ! In range 0-1 + + call remapCS%reconstruction%reconstruct(h0, u0) + if ( remapCS%reconstruction%check_reconstruction(h0, u0) ) then + if ( .not. error ) then ! Only dump first error + print *,'iter=',iter + print *,'h0',h0 + print *,'u0',u0 + endif + error = .true. + endif + + enddo + + write(label(1:8),'(i8)') niter + call test%test( error, trim(adjustl(label))//' consistency tests of '//scheme ) + + call remapCS%reconstruction%destroy() + +end subroutine test_recon_consistency + +!> Test that remapping a uniform field remains uniform +subroutine test_preserve_uniform(test, scheme, n0, niter, h_neglect) + type(testing), intent(inout) :: test !< Unit testing convenience functions + character(len=*), intent(in) :: scheme !< Name of scheme to use + integer, intent(in) :: n0 !< Number of source cells + integer, intent(in) :: niter !< Number of randomized columns to try + real, intent(in) :: h_neglect !< A negligibly small width used in cell reconstructions [H] + ! Local + type(remapping_CS) :: remapCS !< Remapping control structure + real :: h0(n0), h1(n0) ! Source and target grids [H but really nondim] + real :: u0(n0), u1(n0) ! Source and target values [A] + logical :: error ! Indicates a divergence + integer :: iter ! Loop counter + integer :: seed_size ! Number of integers used by seed + integer, allocatable :: seed(:) ! Random number seed + character(len=8) :: label ! Generated label + + call initialize_remapping(remapCS, scheme, nk=n0, h_neglect=h_neglect, & + force_bounds_in_subcell=.true., & + force_bounds_in_target=.true., & + better_force_bounds_in_target=.true., & + offset_tgt_summation=.false., & + om4_remap_via_sub_cells=.false.) + + call random_seed(size=seed_size) + allocate( seed(seed_Size) ) + seed(:) = 102030405 ! Repeatable sequences + call random_seed(put=seed) + + error = .false. + do iter = 1, niter + call random_number( h0 ) ! In range 0-1 + h0(:) = max(0., h0(:) - 0.05) ! Make 5% of values equal to zero + call random_number( h1 ) ! In range 0-1 + h1(:) = max(0., h1(:) - 0.05) ! Make 5% of values equal to zero + call random_number( u0(1) ) ! In range 0-1 + u0(:) = u0(1) ! Make u0 uniform + + call remapping_core_h( remapCS, n0, h0, u0, n0, h1, u1 ) + if ( maxval( abs( u1(:) - u0(1) ) ) > 0. ) then + if ( .not. error ) then ! Only dump first error + print *,'iter=',iter + print *,'u0(1)',u0(1) + print *,'u1',u1 + print *,'u1-u0(1)',u1 - u0(1) + endif + error = .true. + endif + + enddo + + write(label(1:8),'(i8)') niter + call test%test( error, trim(adjustl(label))//' uniformity tests of '//scheme ) + +end subroutine test_preserve_uniform + +!> Test that remapping to the same grid preserves answers +!! +!! Notes: +!! 1) this test is currently imperfect since occasionally we see round-off +!! implying that ( A * B ) / A != B +!! 2) this test does not work for vanished layers +subroutine test_unchanged_grid(test, scheme, n0, niter, h_neglect) + type(testing), intent(inout) :: test !< Unit testing convenience functions + character(len=*), intent(in) :: scheme !< Name of scheme to use + integer, intent(in) :: n0 !< Number of source cells + integer, intent(in) :: niter !< Number of randomized columns to try + real, intent(in) :: h_neglect !< A negligibly small width used in cell reconstructions [H] + ! Local + type(remapping_CS) :: remapCS !< Remapping control structure + real :: h0(n0), h1(n0) ! Source and target grids [H but really nondim] + real :: u0(n0), u1(n0) ! Source and target values [A] + logical :: error ! Indicates a divergence + integer :: iter ! Loop counter + character(len=8) :: label ! Generated label + + call initialize_remapping(remapCS, scheme, nk=n0, h_neglect=h_neglect, & + force_bounds_in_subcell=.true., & + force_bounds_in_target=.false., & + better_force_bounds_in_target=.true., & + offset_tgt_summation=.true., & + om4_remap_via_sub_cells=.false.) + + error = .false. + do iter = 1, niter + call random_number( h0 ) ! In range 0-1 + h0(:) = max(0., h0(:) - 0.00) ! Note we do NOT test with vanished layers + h1(:) = h0(:) ! Exact copy + call random_number( u0 ) ! In range 0-1 + + call remapping_core_h( remapCS, n0, h0, u0, n0, h1, u1 ) + if ( maxval( abs( u1(:) - u0(:) ) ) > epsilon(h0(1)) * maxval( abs( u0 ) ) ) then + if ( .not. error ) then ! Only dump first error + print *,'iter=',iter + print *,'h0',h0 + print *,'u0',u0 + print *,'u1',u1 + print *,'u1-u0',u1 - u0 + endif + error = .true. + endif + + enddo + + write(label(1:8),'(i8)') niter + call test%test( error, trim(adjustl(label))//' unchanged grid tests of '//scheme ) + + call remapCS%reconstruction%destroy() + +end subroutine test_unchanged_grid + +!> Test class-based remapping bitwise reproduces original implementation +subroutine compare_two_schemes(test, CS1, CS2, n0, n1, niter, msg) + type(testing), intent(inout) :: test !< Unit testing convenience functions + type(remapping_CS), intent(inout) :: CS1 !< Remapping control structure configured for + !! original implementation + type(remapping_CS), intent(inout) :: CS2 !< Remapping control structure configured for + !! class-based implementation + integer, intent(in) :: n0 !< Number of source cells + integer, intent(in) :: n1 !< Number of destination cells + integer, intent(in) :: niter !< Number of randomized columns to try + character(len=*), intent(in) :: msg !< Message to label test + ! Local + real :: h0(n0), h1(n1) ! Source and target grids [H but really nondim] + real :: u0(n0), u1(n1), u2(n1) ! Source and two target values [A] + logical :: error ! Indicates a divergence + integer :: iter ! Loop counter + integer :: seed_size ! Number of integers used by seed + integer, allocatable :: seed(:) ! Random number seed + character(len=8) :: label ! Generated label + + call random_seed(size=seed_size) + allocate( seed(seed_Size) ) + seed(:) = 102030405 ! Repeatable sequences + call random_seed(put=seed) + + error = .false. + do iter = 1, niter + call random_number( h0 ) ! In range 0-1 + h0(:) = max(0., h0(:) - 0.00) ! Make 5% of values equal to zero + h0(:) = h0(:) / sum( h0 ) ! Approximately normalize to total depth of 1 + call random_number(h1) ! In range 0-1 + h1(:) = max(0., h1(:) - 0.00) ! Make 5% of values equal to zero + h1(:) = h1(:) / sum( h1 ) ! Approximately normalize to total depth of 1 + call random_number( u0 ) ! In range 0-1 + + call remapping_core_h( CS1, n0, h0, u0, n1, h1, u1 ) + call remapping_core_h( CS2, n0, h0, u0, n1, h1, u2 ) + error = sum( abs( u2(:) - u1(:) ) ) > 0. + if (error) then + print *,'iter=',iter + print *,'h1',h1 + print *,'h0',h0 + print *,'u0',u0 + print *,'u1',u1 + print *,'u2',u2 + print *,'e',u2-u1 + ! CS1%debug = .true. + ! call remapping_core_h( CS1, n0, h0, u0, n1, h1, u1 ) + ! CS2%debug = .true. + ! call remapping_core_h( CS2, n0, h0, u0, n1, h1, u2 ) + exit + endif + enddo + + write(label(1:8),'(i8)') niter + call test%test( error, trim(adjustl(label))//' comparisons of '//msg ) + +end subroutine compare_two_schemes + !> Runs unit tests on remapping functions. !! Should only be called from a single/root thread !! Returns True if a test fails, otherwise False -logical function remapping_unit_tests(verbose) +logical function remapping_unit_tests(verbose, num_comp_samp) logical, intent(in) :: verbose !< If true, write results to stdout + integer, optional, intent(in) :: num_comp_samp !< If present, number of samples to + !! try comparing class-based cade against OM4 code ! Local variables integer :: n0, n1, n2 real, allocatable :: h0(:), h1(:), h2(:) ! Thicknesses for test columns [H] real, allocatable :: u0(:), u1(:), u2(:) ! Values for test profiles [A] real, allocatable :: dx1(:) ! Change in interface position [H] - type(remapping_CS) :: CS !< Remapping control structure + type(remapping_CS) :: CS, CS2 !< Remapping control structures real, allocatable, dimension(:,:) :: ppoly0_E ! Edge values of polynomials [A] real, allocatable, dimension(:,:) :: ppoly0_S ! Edge slopes of polynomials [A H-1] real, allocatable, dimension(:,:) :: ppoly0_coefs ! Coefficients of polynomials [A] @@ -1593,11 +2089,31 @@ logical function remapping_unit_tests(verbose) integer :: answer_date ! The vintage of the expressions to test real :: err ! Errors in the remapped thicknesses [H] or values [A] real :: h_neglect, h_neglect_edge ! Tiny thicknesses used in remapping [H] + integer :: seed_size ! Number of integers used by seed + integer, allocatable :: seed(:) ! Random number seed type(testing) :: test ! Unit testing convenience functions - integer :: i, om4 - character(len=4) :: om4_tag + integer :: om4 ! Loop parameter, 0 or 1 + integer :: ntests ! Number of iterations when brute force testing + character(len=4) :: om4_tag ! Generated label + type(PCM) :: PCM + type(PLM_CW) :: PLM_CW + type(PLM_hybgen) :: PLM_hybgen + type(MPLM_WA) :: MPLM_WA + type(EMPLM_WA) :: EMPLM_WA + type(MPLM_WA_poly) :: MPLM_WA_poly + type(EMPLM_WA_poly) :: EMPLM_WA_poly + type(PLM_CWK) :: PLM_CWK + type(MPLM_CWK) :: MPLM_CWK + type(EMPLM_CWK) :: EMPLM_CWK + type(PPM_H4_2019) :: PPM_H4_2019 + type(PPM_H4_2018) :: PPM_H4_2018 + type(PPM_CW) :: PPM_CW + type(PPM_hybgen) :: PPM_hybgen + type(PPM_CWK) :: PPM_CWK + type(EPPM_CWK) :: EPPM_CWK call test%set( verbose=verbose ) ! Sets the verbosity flag in test +! call test%set( stop_instantly=.true. ) ! While debugging answer_date = 20190101 ! 20181231 h_neglect = 1.0e-30 @@ -1605,9 +2121,6 @@ logical function remapping_unit_tests(verbose) if (verbose) write(test%stdout,*) ' ===== MOM_remapping: remapping_unit_tests =================' - ! This line carries out tests on some older remapping schemes. - call test%test( remapping_attic_unit_tests(verbose), 'attic remapping unit tests' ) - if (verbose) write(test%stdout,*) ' - - - - - 1st generation tests - - - - -' call initialize_remapping(CS, 'PPM_H4', answer_date=answer_date, & @@ -1849,10 +2362,10 @@ logical function remapping_unit_tests(verbose) ! h_tgt = |<- 2 ->|<- 2 ->|<- 2 ->| ! u_tgt = | 2 | 4 | 6 | call remap_sub_to_tgt_grid(n0, n1, h1, h_sub, u_sub, uh_sub, itgt_start, itgt_end, & - .false., u1, u02_err) + .false., .false., .false., u1, u02_err) call test%real_arr(3, u1, (/2.,4.,6./), 'u1') call remap_sub_to_tgt_grid(n0, n1, h1, h_sub, u_sub, uh_sub, itgt_start, itgt_end, & - .true., u1, u02_err) + .true., .false., .false., u1, u02_err) call test%real_arr(3, u1, (/2.,4.,6./), 'u1.b') deallocate( ppoly0_coefs, ppoly0_E, ppoly0_S, u_sub, uh_sub, h0, u0, h1, u1) deallocate( h_sub, h0_eff, isrc_start, isrc_end, isrc_max, itgt_start, itgt_end, isub_src ) @@ -1955,10 +2468,10 @@ logical function remapping_unit_tests(verbose) ! h_tgt = |<- 2 ->|<- 4 ->| ! u_tgt = | 2 | 4 7/8 | call remap_sub_to_tgt_grid(n0, n1, h1, h_sub, u_sub, uh_sub, itgt_start, itgt_end, & - .false., u1, u02_err) + .false., .false., .false., u1, u02_err) call test%real_arr(2, u1, (/2.,4.875/), 'u1') call remap_sub_to_tgt_grid(n0, n1, h1, h_sub, u_sub, uh_sub, itgt_start, itgt_end, & - .true., u1, u02_err) + .true., .false., .false., u1, u02_err) call test%real_arr(2, u1, (/2.,4.875/), 'u1.b') deallocate( ppoly0_coefs, ppoly0_E, ppoly0_S, u_sub, uh_sub, h0, u0, h1, u1) deallocate( h_sub, h0_eff, isrc_start, isrc_end, isrc_max, itgt_start, itgt_end, isub_src ) @@ -2015,10 +2528,10 @@ logical function remapping_unit_tests(verbose) ! h_tgt = |<- 1 ->|0|<- 1 ->|0|<- 2 ->| ! u_tgt = | 1.5 |2| 2.5 |3| 4 | call remap_sub_to_tgt_grid(n0, n1, h1, h_sub, u_sub, uh_sub, itgt_start, itgt_end, & - .false., u1, u02_err) + .false., .false., .false., u1, u02_err) call test%real_arr(5, u1, (/1.5,2.,2.5,3.,4./), 'u1') call remap_sub_to_tgt_grid(n0, n1, h1, h_sub, u_sub, uh_sub, itgt_start, itgt_end, & - .true., u1, u02_err) + .true., .false., .false., u1, u02_err) call test%real_arr(5, u1, (/1.5,2.,2.5,3.,4./), 'u1.b') deallocate( ppoly0_coefs, ppoly0_E, ppoly0_S, u_sub, uh_sub, h0, u0, h1, u1) deallocate( h_sub, h0_eff, isrc_start, isrc_end, isrc_max, itgt_start, itgt_end, isub_src ) @@ -2210,193 +2723,223 @@ logical function remapping_unit_tests(verbose) 3, (/0.,0.,0./), (/0.,0.,0./), & 3, (/0.,0.,0./), (/0.,0.,0./) ) - remapping_unit_tests = test%summarize('remapping_unit_tests') + if (verbose) write(test%stdout,*) '- - - - - - - - - - Recon1d PCM tests - - - - - - - - -' + call test%test( PCM%unit_tests(verbose, test%stdout, test%stderr), 'PCM unit test') + call test%test( MPLM_WA%unit_tests(verbose, test%stdout, test%stderr), 'MPLM_WA unit test') + call test%test( EMPLM_WA%unit_tests(verbose, test%stdout, test%stderr), 'EMPLM_WA unit test') + call test%test( MPLM_WA_poly%unit_tests(verbose, test%stdout, test%stderr), 'MPLM_WA_poly unit test') + call test%test( EMPLM_WA_poly%unit_tests(verbose, test%stdout, test%stderr), 'EMPLM_WA_poly unit test') + call test%test( PLM_hybgen%unit_tests(verbose, test%stdout, test%stderr), 'PLM_hybgen unit test') + call test%test( PLM_CW%unit_tests(verbose, test%stdout, test%stderr), 'PLM_CW unit test') + call test%test( PLM_CWK%unit_tests(verbose, test%stdout, test%stderr), 'PLM_CWK unit test') + call test%test( MPLM_CWK%unit_tests(verbose, test%stdout, test%stderr), 'MPLM_CWK unit test') + call test%test( EMPLM_CWK%unit_tests(verbose, test%stdout, test%stderr), 'EMPLM_CWK unit test') + call test%test( PPM_H4_2019%unit_tests(verbose, test%stdout, test%stderr), 'PPM_H4_2019 unit test') + call test%test( PPM_H4_2018%unit_tests(verbose, test%stdout, test%stderr), 'PPM_H4_2018 unit test') + call test%test( PPM_hybgen%unit_tests(verbose, test%stdout, test%stderr), 'PPM_hybgen unit test') + call test%test( PPM_CW%unit_tests(verbose, test%stdout, test%stderr), 'PPM_CW unit test') + call test%test( PPM_CWK%unit_tests(verbose, test%stdout, test%stderr), 'PPM_CWK unit test') + call test%test( EPPM_CWK%unit_tests(verbose, test%stdout, test%stderr), 'EPPM_CWK unit test') + + ! Randomized, brute force tests + ntests = 3000 + if (present(num_comp_samp)) ntests = num_comp_samp + + call random_seed(size=seed_size) + allocate( seed(seed_Size) ) + seed(:) = 102030405 + call random_seed(put=seed) + + n0 = 9 + + ! Internal consistency + call test_recon_consistency(test, 'C_PCM', n0, ntests, h_neglect) + call test_recon_consistency(test, 'C_PLM_CW', n0, ntests, h_neglect) + call test_recon_consistency(test, 'C_PLM_HYBGEN', n0, ntests, h_neglect) + call test_recon_consistency(test, 'C_MPLM_WA', n0, ntests, h_neglect) + call test_recon_consistency(test, 'C_EMPLM_WA', n0, ntests, h_neglect) + call test_recon_consistency(test, 'C_MPLM_WA_poly', n0, ntests, h_neglect) + call test_recon_consistency(test, 'C_EMPLM_WA_poly', n0, ntests, h_neglect) + call test_recon_consistency(test, 'C_PLM_CWK', n0, ntests, h_neglect) + call test_recon_consistency(test, 'C_MPLM_CWK', n0, ntests, h_neglect) + call test_recon_consistency(test, 'C_EMPLM_CWK', n0, ntests, h_neglect) + call test_recon_consistency(test, 'C_PPM_H4_2018', n0, ntests, h_neglect) + call test_recon_consistency(test, 'C_PPM_H4_2019', n0, ntests, h_neglect) + call test_recon_consistency(test, 'C_PPM_HYBGEN', n0, ntests, h_neglect) + call test_recon_consistency(test, 'C_PPM_CW', n0, ntests, h_neglect) + call test_recon_consistency(test, 'C_PPM_CWK', n0, ntests, h_neglect) + call test_recon_consistency(test, 'C_EPPM_CWK', n0, ntests, h_neglect) + + call test_preserve_uniform(test, 'PCM', n0, ntests, h_neglect) + call test_preserve_uniform(test, 'C_PCM', n0, ntests, h_neglect) +! call test_preserve_uniform(test, 'PLM', n0, ntests, h_neglect) ! Fails +! call test_preserve_uniform(test, 'PLM_HYBGEN', n0, ntests, h_neglect) ! Fails +! call test_preserve_uniform(test, 'PPM_H4', n0, ntests, h_neglect) ! Fails +! call test_preserve_uniform(test, 'PPM_IH4', n0, ntests, h_neglect) ! Fails +! call test_preserve_uniform(test, 'PPM_HYBGEN', n0, ntests, h_neglect) ! Fails +! call test_preserve_uniform(test, 'PPM_CW', n0, ntests, h_neglect) ! Fails +! call test_preserve_uniform(test, 'WENO_HYBGEN', n0, ntests, h_neglect) ! Fails +! call test_preserve_uniform(test, 'PQM_IH4IH3', n0, ntests, h_neglect) ! Fails + call test_preserve_uniform(test, 'C_PLM_CW', n0, ntests, h_neglect) + call test_preserve_uniform(test, 'C_PLM_HYBGEN', n0, ntests, h_neglect) + call test_preserve_uniform(test, 'C_MPLM_WA', n0, ntests, h_neglect) + call test_preserve_uniform(test, 'C_EMPLM_WA', n0, ntests, h_neglect) + call test_preserve_uniform(test, 'C_MPLM_WA_poly', n0, ntests, h_neglect) ! Surprised this passes -AJA +! call test_preserve_uniform(test, 'C_EMPLM_WA_poly', n0, ntests, h_neglect) ! This is known to fail + call test_preserve_uniform(test, 'C_PLM_CWK', n0, ntests, h_neglect) + call test_preserve_uniform(test, 'C_MPLM_CWK', n0, ntests, h_neglect) + call test_preserve_uniform(test, 'C_EMPLM_CWK', n0, ntests, h_neglect) + call test_preserve_uniform(test, 'C_PPM_H4_2019', n0, ntests, h_neglect) + call test_preserve_uniform(test, 'C_PPM_H4_2018', n0, ntests, h_neglect) + call test_preserve_uniform(test, 'C_PPM_HYBGEN', n0, ntests, h_neglect) + call test_preserve_uniform(test, 'C_PPM_CW', n0, ntests, h_neglect) + call test_preserve_uniform(test, 'C_PPM_CWK', n0, ntests, h_neglect) + call test_preserve_uniform(test, 'C_EPPM_CWK', n0, ntests, h_neglect) + + call test_unchanged_grid(test, 'C_PCM', n0, ntests, h_neglect) + call test_unchanged_grid(test, 'C_PLM_CW', n0, ntests, h_neglect) + call test_unchanged_grid(test, 'C_PLM_HYBGEN', n0, ntests, h_neglect) + call test_unchanged_grid(test, 'C_PLM_CWK', n0, ntests, h_neglect) + call test_unchanged_grid(test, 'C_MPLM_CWK', n0, ntests, h_neglect) + call test_unchanged_grid(test, 'C_EMPLM_CWK', n0, ntests, h_neglect) + call test_unchanged_grid(test, 'C_PPM_HYBGEN', n0, ntests, h_neglect) + call test_unchanged_grid(test, 'C_PPM_CW', n0, ntests, h_neglect) + call test_unchanged_grid(test, 'C_PPM_CWK', n0, ntests, h_neglect) + call test_unchanged_grid(test, 'C_EPPM_CWK', n0, ntests, h_neglect) + + ! Check that remapping to the exact same grid leaves values unchanged + allocate( h0(8), u0(8) ) + h0 = (/0.0, 1.0, 1.0, 1.0, 1.0, 1.0, 0.0, 0.0/) + u0 = (/1.0, 1.5, 2.5, 3.5, 4.5, 5.5, 6.0, 6.0/) + allocate( u1(8) ) + call initialize_remapping(CS, 'C_PLM_CW', nk=8) + call remapping_core_h( CS, 8, h0, u0, 8, [0.,1.,1.,1.,1.,1.,0.,0.], u1 ) + call test%real_arr(8, u1, u0, 'remapping_core to unchanged grid with class') -end function remapping_unit_tests + call end_remapping(CS) + deallocate( h0, u0, u1 ) -!> Test if interpolate_column() produces the wrong answer -subroutine test_interp(test, msg, nsrc, h_src, u_src, ndest, h_dest, u_true) - type(testing), intent(inout) :: test !< Unit testing convenience functions - character(len=*), intent(in) :: msg !< Message to label test - integer, intent(in) :: nsrc !< Number of source cells - real, dimension(nsrc), intent(in) :: h_src !< Thickness of source cells [H] - real, dimension(nsrc+1), intent(in) :: u_src !< Values at source cell interfaces [A] - integer, intent(in) :: ndest !< Number of destination cells - real, dimension(ndest), intent(in) :: h_dest !< Thickness of destination cells [H] - real, dimension(ndest+1), intent(in) :: u_true !< Correct value at destination cell interfaces [A] - ! Local variables - real, dimension(ndest+1) :: u_dest ! Interpolated value at destination cell interfaces [A] + ! Brute force test that we have bitwise identical answers with the new classes + n0 = 7 + n1 = 4 - ! Interpolate from src to dest - call interpolate_column(nsrc, h_src, u_src, ndest, h_dest, u_dest, .true.) - call test%real_arr(ndest, u_dest, u_true, msg) -end subroutine test_interp + ! PPM_CW and PPM_HYBGEN are identical, but are different options in build_reconstructions_1d() + call initialize_remapping(CS, 'PPM_CW', answer_date=99990101, boundary_extrapolation=.false., & + om4_remap_via_sub_cells=.false., force_bounds_in_subcell=.false., & + h_neglect=h_neglect, h_neglect_edge=h_neglect_edge) + call initialize_remapping(CS2, 'PPM_HYBGEN', answer_date=99990101, boundary_extrapolation=.false., & + om4_remap_via_sub_cells=.false., force_bounds_in_subcell=.false., & + h_neglect=h_neglect, h_neglect_edge=h_neglect_edge) + call compare_two_schemes(test, CS, CS2, n0, n1, ntests, 'PPM_CW <-> PPM_HYBGEN') -!> Test if reintegrate_column() produces the wrong answer -subroutine test_reintegrate(test, msg, nsrc, h_src, uh_src, ndest, h_dest, uh_true) - type(testing), intent(inout) :: test !< Unit testing convenience functions - character(len=*), intent(in) :: msg !< Message to label test - integer, intent(in) :: nsrc !< Number of source cells - real, dimension(nsrc), intent(in) :: h_src !< Thickness of source cells [H] - real, dimension(nsrc), intent(in) :: uh_src !< Values of source cell stuff [A H] - integer, intent(in) :: ndest !< Number of destination cells - real, dimension(ndest), intent(in) :: h_dest !< Thickness of destination cells [H] - real, dimension(ndest), intent(in) :: uh_true !< Correct value of destination cell stuff [A H] - ! Local variables - real, dimension(ndest) :: uh_dest ! Reintegrated value on destination cells [A H] + ! PPM_CW <-> PPM_HYBGEN, as above but with OM4 subcells + call initialize_remapping(CS, 'PPM_CW', answer_date=99990101, boundary_extrapolation=.false., & + om4_remap_via_sub_cells=.true., force_bounds_in_subcell=.false., & + h_neglect=h_neglect, h_neglect_edge=h_neglect_edge) + call initialize_remapping(CS2, 'PPM_HYBGEN', answer_date=99990101, boundary_extrapolation=.false., & + om4_remap_via_sub_cells=.true., force_bounds_in_subcell=.false., & + h_neglect=h_neglect, h_neglect_edge=h_neglect_edge) + call compare_two_schemes(test, CS, CS2, n0, n1, ntests, 'PPM_CW <-> PPM_HYBGEN OM4') - ! Interpolate from src to dest - call reintegrate_column(nsrc, h_src, uh_src, ndest, h_dest, uh_dest) - call test%real_arr(ndest, uh_dest, uh_true, msg) + ! PPM_CW <-> PPM_HYBGEN, as above but with extrapolation + call initialize_remapping(CS, 'PPM_CW', answer_date=99990101, boundary_extrapolation=.true., & + om4_remap_via_sub_cells=.false., force_bounds_in_subcell=.false., & + h_neglect=h_neglect, h_neglect_edge=h_neglect_edge) + call initialize_remapping(CS2, 'PPM_HYBGEN', answer_date=99990101, boundary_extrapolation=.true., & + om4_remap_via_sub_cells=.false., force_bounds_in_subcell=.false., & + h_neglect=h_neglect, h_neglect_edge=h_neglect_edge) + call compare_two_schemes(test, CS, CS2, n0, n1, ntests, 'PPM_CW <-> PPM_HYBGEN Extrap') -end subroutine test_reintegrate + ! PPM_CW <-> PPM_HYBGEN, as above but with OM4 subcells and subcell bounds + call initialize_remapping(CS, 'PPM_CW', answer_date=99990101, boundary_extrapolation=.false., & + om4_remap_via_sub_cells=.true., force_bounds_in_subcell=.true., & + h_neglect=h_neglect, h_neglect_edge=h_neglect_edge) + call initialize_remapping(CS2, 'PPM_HYBGEN', answer_date=99990101, boundary_extrapolation=.false., & + om4_remap_via_sub_cells=.true., force_bounds_in_subcell=.true., & + h_neglect=h_neglect, h_neglect_edge=h_neglect_edge) + call compare_two_schemes(test, CS, CS2, n0, n1, ntests, 'PPM_CW <-> PPM_HYBGEN') -! ========================================================================================= -! The following provide the function for the testing_type helper class - -!> Update the state with "test" -subroutine test(this, state, label) - class(testing), intent(inout) :: this !< This testing class - logical, intent(in) :: state !< True to indicate a fail, false otherwise - character(len=*), intent(in) :: label !< Message - - this%num_tests_checked = this%num_tests_checked + 1 - if (state) then - this%state = .true. - this%num_tests_failed = this%num_tests_failed + 1 - this%ifailed( this%num_tests_failed ) = this%num_tests_checked - if (this%num_tests_failed == 1) this%label_first_fail = label - endif - if (this%stop_instantly .and. this%state) stop 1 -end subroutine test - -!> Set attributes -subroutine set(this, verbose, stdout, stderr, stop_instantly) - class(testing), intent(inout) :: this !< This testing class - logical, optional, intent(in) :: verbose !< True or false setting to assign to verbosity - integer, optional, intent(in) :: stdout !< The stdout channel to use - integer, optional, intent(in) :: stderr !< The stderr channel to use - logical, optional, intent(in) :: stop_instantly !< If true, stop immediately on error detection - - if (present(verbose)) then - this%verbose = verbose - endif - if (present(stdout)) then - this%stdout = stdout - endif - if (present(stderr)) then - this%stderr = stderr - endif - if (present(stop_instantly)) then - this%stop_instantly = stop_instantly - endif -end subroutine set - -!> Returns state -logical function outcome(this) - class(testing), intent(inout) :: this !< This testing class - outcome = this%state -end function outcome - -!> Summarize results -logical function summarize(this, label) - class(testing), intent(inout) :: this !< This testing class - character(len=*), intent(in) :: label !< Message - integer :: i - - if (this%state) then - write(this%stdout,'(a," : ",a,", ",i4," failed of ",i4," tested")') & - 'FAIL', trim(label), this%num_tests_failed, this%num_tests_checked - write(this%stdout,'(a,100i4)') 'Failed tests:',(this%ifailed(i),i=1,this%num_tests_failed) - write(this%stdout,'(a,a)') 'First failed test: ',trim(this%label_first_fail) - write(this%stderr,'(a,100i4)') 'Failed tests:',(this%ifailed(i),i=1,this%num_tests_failed) - write(this%stderr,'(a,a)') 'First failed test: ',trim(this%label_first_fail) - write(this%stderr,'(a," : ",a)') trim(label),'FAILED' - else - write(this%stdout,'(a," : ",a,", all ",i4," tests passed")') & - 'Pass', trim(label), this%num_tests_checked - endif - summarize = this%state -end function summarize + ! PCM <-> C_PCM + call initialize_remapping(CS, 'PCM', answer_date=99990101, om4_remap_via_sub_cells=.false., & + force_bounds_in_subcell=.false.) + call initialize_remapping(CS2, 'C_PCM', nk=n0, h_neglect=h_neglect) + call compare_two_schemes(test, CS, CS2, n0, n1, ntests, 'PCM <-> C_PCM') -!> Compare u_test to u_true, report, and return true if a difference larger than tol is measured -!! -!! If in verbose mode, display results to stdout -!! If a difference is measured, display results to stdout and stderr -subroutine real_arr(this, n, u_test, u_true, label, tol) - class(testing), intent(inout) :: this !< This testing class - integer, intent(in) :: n !< Number of cells in u - real, dimension(n), intent(in) :: u_test !< Values to test [A] - real, dimension(n), intent(in) :: u_true !< Values to test against (correct answer) [A] - character(len=*), intent(in) :: label !< Message - real, optional, intent(in) :: tol !< The tolerance for differences between u and u_true [A] - ! Local variables - integer :: k - logical :: this_test - real :: tolerance, err ! Tolerance for differences, and error [A] + ! PLM <-> C_MPLM_WA_POLY + call initialize_remapping(CS, 'PLM', answer_date=99990101, boundary_extrapolation=.false., & + om4_remap_via_sub_cells=.false., force_bounds_in_subcell=.false., & + h_neglect=h_neglect, h_neglect_edge=h_neglect_edge) + call initialize_remapping(CS2, 'C_MPLM_WA_POLY', nk=n0, h_neglect=h_neglect) + call compare_two_schemes(test, CS, CS2, n0, n1, ntests, 'PLM <-> C_MPLM_WA_poly') - tolerance = 0.0 - if (present(tol)) tolerance = tol - this_test = .false. + ! PLM (with subcell bounds) <-> C_MPLM_WA_POLY + call initialize_remapping(CS, 'PLM', answer_date=99990101, boundary_extrapolation=.false., & + om4_remap_via_sub_cells=.false., force_bounds_in_subcell=.true., & + h_neglect=h_neglect, h_neglect_edge=h_neglect_edge) + call initialize_remapping(CS2, 'C_MPLM_WA_POLY', nk=n0, h_neglect=h_neglect) + call compare_two_schemes(test, CS, CS2, n0, n1, ntests, 'PLM bounded <-> C_MPLM_WA_poly') - ! Scan for any mismatch between u_test and u_true - do k = 1, n - if (abs(u_test(k) - u_true(k)) > tolerance) this_test = .true. - enddo + ! PLM + extrapolation <-> C_EMPLM_WA_POLY + call initialize_remapping(CS, 'PLM', answer_date=99990101, boundary_extrapolation=.true., & + om4_remap_via_sub_cells=.false., force_bounds_in_subcell=.false., & + h_neglect=h_neglect, h_neglect_edge=h_neglect_edge) + call initialize_remapping(CS2, 'C_EMPLM_WA_POLY', nk=n0, h_neglect=h_neglect) + call compare_two_schemes(test, CS, CS2, n0, n1, ntests, 'PLM <-> C_EMPLM_WA_poly') - ! If either being verbose, or an error was measured then display results - if (this_test .or. this%verbose) then - write(this%stdout,'(a4,2a24,1x,a)') 'k','Calculated value','Correct value',label - if (this_test) write(this%stderr,'(a4,2a24,1x,a)') 'k','Calculated value','Correct value',label - do k = 1, n - err = u_test(k) - u_true(k) - if (abs(err) > tolerance) then - write(this%stdout,'(i4,1p2e24.16,a,1pe24.16,a)') k, u_test(k), u_true(k), & - ' err=', err, ' <--- WRONG' - write(this%stderr,'(i4,1p2e24.16,a,1pe24.16,a)') k, u_test(k), u_true(k), & - ' err=', err, ' <--- WRONG' - else - write(this%stdout,'(i4,1p2e24.16)') k, u_test(k), u_true(k) - endif - enddo - endif + ! PLM + extrapolation (with subcell bounds) <-> C_EMPLM_WA_POLY + call initialize_remapping(CS, 'PLM', answer_date=99990101, boundary_extrapolation=.true., & + om4_remap_via_sub_cells=.false., force_bounds_in_subcell=.true., & + h_neglect=h_neglect, h_neglect_edge=h_neglect_edge) + call initialize_remapping(CS2, 'C_EMPLM_WA_POLY', nk=n0, h_neglect=h_neglect) + call compare_two_schemes(test, CS, CS2, n0, n1, ntests, 'PLM bounded <-> C_EMPLM_WA_poly') - call this%test( this_test, label ) ! Updates state and counters in this -end subroutine real_arr + ! PPM_H4 (2018 answers) <-> C_PPM_H4_2018 + call initialize_remapping(CS, 'PPM_H4', answer_date=20180101, boundary_extrapolation=.false., & + om4_remap_via_sub_cells=.false., force_bounds_in_subcell=.false., & + h_neglect=h_neglect, h_neglect_edge=h_neglect_edge) + call initialize_remapping(CS2, 'C_PPM_H4_2018', nk=n0, h_neglect=h_neglect) + call compare_two_schemes(test, CS, CS2, n0, n1, ntests, 'PPM_H4 2018 <-> C_PPM_H4_2018') -!> Compare i_test to i_true and report and return true if a difference is found -!! -!! If in verbose mode, display results to stdout -!! If a difference is measured, display results to stdout and stderr -subroutine int_arr(this, n, i_test, i_true, label) - class(testing), intent(inout) :: this !< This testing class - integer, intent(in) :: n !< Number of cells in u - integer, dimension(n), intent(in) :: i_test !< Values to test [A] - integer, dimension(n), intent(in) :: i_true !< Values to test against (correct answer) [A] - character(len=*), intent(in) :: label !< Message - ! Local variables - integer :: k - logical :: this_test + ! PPM_H4 (2018 answers with subcell bounds) <-> C_PPM_H4_2018 + call initialize_remapping(CS, 'PPM_H4', answer_date=20180101, boundary_extrapolation=.false., & + om4_remap_via_sub_cells=.false., force_bounds_in_subcell=.true., & + h_neglect=h_neglect, h_neglect_edge=h_neglect_edge) + call initialize_remapping(CS2, 'C_PPM_H4_2018', nk=n0, h_neglect=h_neglect) + call compare_two_schemes(test, CS, CS2, n0, n1, ntests, 'PPM_H4 2018 bounded <-> C_PPM_H4_2018') + + ! PPM_H4 (latest answers) <-> C_PPM_H4_2019 + call initialize_remapping(CS, 'PPM_H4', answer_date=99990101, boundary_extrapolation=.false., & + om4_remap_via_sub_cells=.false., force_bounds_in_subcell=.false., & + h_neglect=h_neglect, h_neglect_edge=h_neglect_edge) + call initialize_remapping(CS2, 'C_PPM_H4_2019', nk=n0, h_neglect=h_neglect) + call compare_two_schemes(test, CS, CS2, n0, n1, ntests, 'PPM_H4 <-> C_PPM_H4_2019') - this_test = .false. + ! PPM_H4 (latest answers with subcell bounds) <-> C_PPM_H4_2019 + call initialize_remapping(CS, 'PPM_H4', answer_date=99990101, boundary_extrapolation=.false., & + om4_remap_via_sub_cells=.false., force_bounds_in_subcell=.true., & + h_neglect=h_neglect, h_neglect_edge=h_neglect_edge) + call initialize_remapping(CS2, 'C_PPM_H4_2019', nk=n0, h_neglect=h_neglect) + call compare_two_schemes(test, CS, CS2, n0, n1, ntests, 'PPM_H4 bounded <-> C_PPM_H4_2019') - ! Scan for any mismatch between u_test and u_true - do k = 1, n - if (i_test(k) .ne. i_true(k)) this_test = .true. - enddo + ! PLM_HYBGEN (latest answers with subcell bounds) <-> C_PLM_hybgen + call initialize_remapping(CS, 'PLM_HYBGEN', answer_date=99990101, boundary_extrapolation=.false., & + om4_remap_via_sub_cells=.false., force_bounds_in_subcell=.true., & + h_neglect=h_neglect, h_neglect_edge=h_neglect_edge) + call initialize_remapping(CS2, 'C_PLM_hybgen', nk=n0, h_neglect=h_neglect) + call compare_two_schemes(test, CS, CS2, n0, n1, ntests, 'PLM_HYBGEN bounded <-> C_PLM_hygen') - if (this%verbose) then - write(this%stdout,'(a12," : calculated =",30i3)') label, i_test - write(this%stdout,'(12x," correct =",30i3)') i_true - if (this_test) write(this%stdout,'(3x,a,8x,"error =",30i3)') 'FAIL --->', i_test(:) - i_true(:) - endif - if (this_test) then - write(this%stderr,'(a12," : calculated =",30i3)') label, i_test - write(this%stderr,'(12x," correct =",30i3)') i_true - write(this%stderr,'(" FAIL ---> error =",30i3)') i_test(:) - i_true(:) - endif - - call this%test( this_test, label ) ! Updates state and counters in this -end subroutine int_arr + ! PPM_HYBGEN (latest answers with subcell bounds) <-> C_PPM_hybgen + call initialize_remapping(CS, 'PPM_HYBGEN', answer_date=99990101, boundary_extrapolation=.false., & + om4_remap_via_sub_cells=.false., force_bounds_in_subcell=.true., & + h_neglect=h_neglect, h_neglect_edge=h_neglect_edge) + call initialize_remapping(CS2, 'C_PPM_HYBGEN', nk=n0, h_neglect=h_neglect) + call compare_two_schemes(test, CS, CS2, n0, n1, ntests, 'PPM_HYBGEN bounded <-> C_PPM_HYGEN') + + call end_remapping(CS) + call end_remapping(CS2) + + remapping_unit_tests = test%summarize('remapping_unit_tests') + +end function remapping_unit_tests end module MOM_remapping diff --git a/src/ALE/Recon1d_EMPLM_CWK.F90 b/src/ALE/Recon1d_EMPLM_CWK.F90 new file mode 100644 index 0000000000..01d97058a9 --- /dev/null +++ b/src/ALE/Recon1d_EMPLM_CWK.F90 @@ -0,0 +1,148 @@ +!> Piecewise Linear Method 1D reconstruction in index space and boundary extrapolation +!! +!! This implementation of PLM follows Colella and Woodward, 1984 \cite colella1984, except for assuming +!! uniform resolution so that the method is independent of grid spacing. The cell-wise reconstructions +!! are limited so that the edge values (which are also the extrema in a cell) are bounded by the neighbors. +!! The slope of the first and last cells are set so that the first interior edge values match the interior +!! cell (i.e. extrapolates from the interior). +module Recon1d_EMPLM_CWK + +! This file is part of MOM6. See LICENSE.md for the license. + +use Recon1d_type, only : testing +use Recon1d_MPLM_CWK, only : MPLM_CWK + +implicit none ; private + +public EMPLM_CWK, testing + +!> PLM reconstruction following Colella and Woodward, 1984 +!! +!! Implemented by extending recon1d_mplm_cwk. +!! +!! The source for the methods ultimately used by this class are: +!! - init() -> recon1d_mplm_cwk -> recon1d_plm_cw.init() +!! - reconstruct() *locally defined +!! - average() -> recon1d_mplm_cwk -> recon1d_plm_cw.average() +!! - f() -> recon1d_mplm_cwk -> recon1d_plm_cw.f() +!! - dfdx() -> recon1d_mplm_cwk -> recon1d_plm_cw.dfdx() +!! - check_reconstruction() -> recon1d_mplm_cwk.check_reconstruction() +!! - unit_tests() *locally defined +!! - destroy() -> recon1d_mplm_cwk -> recon1d_plm_cw.destroy() +!! - remap_to_sub_grid() -> recon1d_type.remap_to_sub_grid() +!! - init_parent() -> init() +!! - reconstruct_parent() -> recon1d_mplm_cwk.reconstruct() +type, extends (MPLM_CWK) :: EMPLM_CWK + +contains + !> Implementation of the EMPLM_CWK reconstruction + procedure :: reconstruct => reconstruct + !> Implementation of unit tests for the EMPLM_CWK reconstruction + procedure :: unit_tests => unit_tests + +end type EMPLM_CWK + +contains + +!> Calculate a 1D PLM reconstructions based on h(:) and u(:) +subroutine reconstruct(this, h, u) + class(EMPLM_CWK), intent(inout) :: this !< This reconstruction + real, intent(in) :: h(*) !< Grid spacing (thickness) [typically H] + real, intent(in) :: u(*) !< Cell mean values [A] + ! Local variables + real :: slp ! The PLM slopes (difference across cell) [A] + real :: sigma_l, sigma_c, sigma_r ! Left, central and right slope estimates as + ! differences across the cell [A] + real :: u_min, u_max ! Minimum and maximum value across cell [A] + real :: u_l, u_r, u_c ! Left, right, and center values [A] + real :: u_e(this%n+1) ! Average of edge values [A] + integer :: k, n + + n = this%n + + call this%reconstruct_parent(h, u) + + this%ur(1) = this%ul(2) + this%ul(1) = u(1) + ( u(1) - this%ur(1) ) + + this%ul(n) = this%ur(n-1) + this%ur(n) = u(n) + ( u(n) - this%ul(n) ) + +end subroutine reconstruct + +!> Runs PLM reconstruction unit tests and returns True for any fails, False otherwise +logical function unit_tests(this, verbose, stdout, stderr) + class(EMPLM_CWK), intent(inout) :: this !< This reconstruction + logical, intent(in) :: verbose !< True, if verbose + integer, intent(in) :: stdout !< I/O channel for stdout + integer, intent(in) :: stderr !< I/O channel for stderr + ! Local variables + real, allocatable :: ul(:), ur(:), um(:) ! test values [A] + real, allocatable :: ull(:), urr(:) ! test values [A] + type(testing) :: test ! convenience functions + integer :: k + + call test%set( stdout=stdout ) ! Sets the stdout channel in test + call test%set( stderr=stderr ) ! Sets the stderr channel in test + call test%set( verbose=verbose ) ! Sets the verbosity flag in test + + call this%init(3) + call test%test( this%n /= 3, 'Setting number of levels') + allocate( um(3), ul(3), ur(3), ull(3), urr(3) ) + + call this%reconstruct( (/2.,2.,2./), (/1.,3.,5./) ) + call test%real_arr(3, this%u_mean, (/1.,3.,5./), 'Setting cell values') + + do k = 1, 3 + ul(k) = this%f(k, 0.) + um(k) = this%f(k, 0.5) + ur(k) = this%f(k, 1.) + enddo + call test%real_arr(3, ul, (/0.,2.,4./), 'Evaluation on left edge') + call test%real_arr(3, um, (/1.,3.,5./), 'Evaluation in center') + call test%real_arr(3, ur, (/2.,4.,6./), 'Evaluation on right edge') + + do k = 1, 3 + ul(k) = this%dfdx(k, 0.) + um(k) = this%dfdx(k, 0.5) + ur(k) = this%dfdx(k, 1.) + enddo + call test%real_arr(3, ul, (/2.,2.,2./), 'dfdx on left edge') + call test%real_arr(3, um, (/2.,2.,2./), 'dfdx in center') + call test%real_arr(3, ur, (/2.,2.,2./), 'dfdx on right edge') + + do k = 1, 3 + um(k) = this%average(k, 0.25, 0.75) ! Average from x=0.25 to 0.75 in each cell + enddo + call test%real_arr(3, um, (/1.,3.,5./), 'Return interval average') + + call this%destroy() + deallocate( um, ul, ur, ull, urr ) + + allocate( um(4), ul(4), ur(4) ) + call this%init(4) + + ! These values lead to non-monotonic reconstuctions which are + ! valid for transport problems but not always appropriate for + ! remapping to arbitrary resolution grids. + ! The O(h^2) slopes are -, 2, 2, - and the limited + ! slopes are 0, 1, 1, 0 so the everywhere the reconstructions + ! are bounded by neighbors but ur(2) and ul(3) are out-of-order. + call this%reconstruct( (/1.,1.,1.,1./), (/0.,3.,4.,7./) ) + do k = 1, 4 + ul(k) = this%f(k, 0.) + ur(k) = this%f(k, 1.) + enddo + call test%real_arr(4, ul, (/-2.5,2.5,3.5,4.5/), 'Evaluation on left edge') + call test%real_arr(4, ur, (/2.5,3.5,4.5,9.5/), 'Evaluation on right edge') + + deallocate( um, ul, ur ) + + unit_tests = test%summarize('EMPLM_CWK:unit_tests') + +end function unit_tests + +!> \namespace recon1d_emplm_cwk +!! + +end module Recon1d_EMPLM_CWK diff --git a/src/ALE/Recon1d_EMPLM_WA.F90 b/src/ALE/Recon1d_EMPLM_WA.F90 new file mode 100644 index 0000000000..fc46cf74f6 --- /dev/null +++ b/src/ALE/Recon1d_EMPLM_WA.F90 @@ -0,0 +1,172 @@ +!> Extrapolated-Monotonized Piecewise Linear Method 1D reconstruction +!! +!! This extends MPLM_WA, following White and Adcroft, 2008 \cite white2008, by extrapolating for the slopes of the +!! first and last cells. This extrapolation is used by White et al., 2009, during grid-generation. +module Recon1d_EMPLM_WA + +! This file is part of MOM6. See LICENSE.md for the license. + +use Recon1d_MPLM_WA, only : MPLM_WA, testing + +implicit none ; private + +public EMPLM_WA + +!> Extraplated Monotonic PLM reconstruction of White and Adcroft, 2008 +!! +!! The source for the methods ultimately used by this class are: +!! - init() -> recon1d_mplm_wa -> recon1d_plm_cw.init() +!! - reconstruct() *locally defined +!! - average() -> recon1d_mplm_wa -> recon1d_plm_cw.average() +!! - f() -> recon1d_mplm_wa -> recon1d_plm_cw.f() +!! - dfdx() -> recon1d_mplm_wa -> recon1d_plm_cw.dfdx() +!! - check_reconstruction() -> recon1d_mplm_wa.check_reconstruction() +!! - unit_tests() *locally defined +!! - destroy() -> recon1d_mplm_wa -> recon1d_plm_cw.destroy() +!! - remap_to_sub_grid() -> recon1d_mplm_wa -> recon1d_plm_cw -> recon1d_type.remap_to_sub_grid() +!! - init_parent() -> recon1d_mplm_wa -> recon1d_plm_cw.init() +!! - reconstruct_parent() -> recon1d_mplm_wa.reconstruct() +type, extends (MPLM_WA) :: EMPLM_WA + +contains + !> Implementation of the EMPLM_WA reconstruction with boundary extrapolation + procedure :: reconstruct => reconstruct + !> Implementation of unit tests for the EMPLM_WA reconstruction + procedure :: unit_tests => unit_tests + +end type EMPLM_WA + +contains + +!> Calculate a 1D PLM reconstruction based on h(:) and u(:) +subroutine reconstruct(this, h, u) + class(EMPLM_WA), intent(inout) :: this !< This reconstruction + real, intent(in) :: h(*) !< Grid spacing (thickness) [typically H] + real, intent(in) :: u(*) !< Cell mean values [A] + ! Local variables + integer :: n + real :: slope ! Difference of u across cell [A] + real :: edge_h2 ! Edge value found by linear interpolation [A] + real :: slope_h2 ! Twice the difference between cell center and 2nd order edge value [A] + real :: slope_e ! Twice the difference between cell center and neighbor edge value [A] + real :: hn, hc ! Neighbor and central cell thicknesses adjusted by h_neglect [H] + real :: u_min, u_max ! Working values for bounding edge values [A] + + ! Use parent (MPLM_WA) reconstruction + call this%reconstruct_parent(h, u) + + ! Fix reconstruction for first cell + ! Avoid division by zero for vanished cells + hn = h(2) + this%h_neglect + hc = h(1) + this%h_neglect + edge_h2 = ( u(2) * hc + u(1) * hn ) / ( hn + hc ) + slope_h2 = 2.0 * ( edge_h2 - u(1) ) + slope_e = 2.0 * ( this%ul(2) - u(1) ) + slope = sign( min( abs(slope_h2), abs(slope_e) ), u(2) - u(1) ) + edge_h2 = u(1) + 0.5 * slope + u_min = min( this%ul(2), u(1) ) + u_max = max( this%ul(2), u(1) ) + this%ur(1) = max( u_min, min( u_max, edge_h2 ) ) + this%ul(1) = u(1) - 0.5 * slope +! slope = - PLM_extrapolate_slope( h(2), h(1), this%h_neglect, this%ul(2), u(1) ) +! this%ul(1) = u(1) - 0.5 * slope +! this%ur(1) = u(1) + 0.5 * slope + + ! Fix reconstruction for last cell + n = this%n + ! Avoid division by zero for vanished cells + hn = h(n-1) + this%h_neglect + hc = h(n) + this%h_neglect + edge_h2 = ( u(n-1) * hc + u(n) * hn ) / ( hn + hc ) + slope_h2 = 2.0 * ( u(n) - edge_h2 ) + slope_e = 2.0 * ( u(n) - this%ur(n-1) ) + slope = sign( min( abs(slope_h2), abs(slope_e) ), u(n) - u(n-1) ) + edge_h2 = u(n) - 0.5 * slope + u_min = min( this%ur(n-1), u(n) ) + u_max = max( this%ur(n-1), u(n) ) + this%ul(n) = max( u_min, min( u_max, edge_h2 ) ) + this%ur(n) = u(n) + 0.5 * slope +! slope = PLM_extrapolate_slope( h(n-1), h(n), this%h_neglect, this%ur(n-1), u(n) ) +! this%ul(n) = u(n) - 0.5 * slope +! this%ur(n) = u(n) + 0.5 * slope + +end subroutine reconstruct + +!> Returns a PLM slope using h2 extrapolation from a cell to the left, in the same +!! arbitrary units as the input values [A]. +!! Use the negative to extrapolate from the cell to the right. +real elemental pure function PLM_extrapolate_slope(h_l, h_c, h_neglect, u_l, u_c) + real, intent(in) :: h_l !< Thickness of left cell in arbitrary grid thickness units [H] + real, intent(in) :: h_c !< Thickness of center cell in arbitrary grid thickness units [H] + real, intent(in) :: h_neglect !< A negligible thickness [H] + real, intent(in) :: u_l !< Value of left cell in arbitrary units [A] + real, intent(in) :: u_c !< Value of center cell in arbitrary units [A] + ! Local variables + real :: left_edge ! Left edge value [A] + real :: hl, hc ! Left and central cell thicknesses [H] + + ! Avoid division by zero for vanished cells + hl = h_l + h_neglect + hc = h_c + h_neglect + + ! The h2 scheme is used to compute the left edge value + left_edge = (u_l*hc + u_c*hl) / (hl + hc) + + PLM_extrapolate_slope = 2.0 * ( u_c - left_edge ) + +end function PLM_extrapolate_slope + +!> Runs PLM reconstruction unit tests and returns True for any fails, False otherwise +logical function unit_tests(this, verbose, stdout, stderr) + class(EMPLM_WA), intent(inout) :: this !< This reconstruction + logical, intent(in) :: verbose !< True, if verbose + integer, intent(in) :: stdout !< I/O channel for stdout + integer, intent(in) :: stderr !< I/O channel for stderr + ! Local variables + real, allocatable :: ul(:), ur(:), um(:) ! test values [A] + real, allocatable :: ull(:), urr(:) ! test values [A] + type(testing) :: test ! convenience functions + integer :: k + + call test%set( stdout=stdout ) ! Sets the stdout channel in test + call test%set( stderr=stderr ) ! Sets the stderr channel in test + call test%set( verbose=verbose ) ! Sets the verbosity flag in test + + call this%init(3) + call test%test( this%n /= 3, 'Setting number of levels') + allocate( um(3), ul(3), ur(3), ull(3), urr(3) ) + + call this%reconstruct( (/2.,2.,2./), (/1.,3.,5./) ) + call test%real_arr(3, this%u_mean, (/1.,3.,5./), 'Setting cell values') + + do k = 1, 3 + ul(k) = this%f(k, 0.) + um(k) = this%f(k, 0.5) + ur(k) = this%f(k, 1.) + enddo + call test%real_arr(3, ul, (/0.,2.,4./), 'Evaluation on left edge') + call test%real_arr(3, um, (/1.,3.,5./), 'Evaluation in center') + call test%real_arr(3, ur, (/2.,4.,6./), 'Evaluation on right edge') + + do k = 1, 3 + ul(k) = this%dfdx(k, 0.) + um(k) = this%dfdx(k, 0.5) + ur(k) = this%dfdx(k, 1.) + enddo + call test%real_arr(3, ul, (/2.,2.,2./), 'dfdx on left edge') + call test%real_arr(3, um, (/2.,2.,2./), 'dfdx in center') + call test%real_arr(3, ur, (/2.,2.,2./), 'dfdx on right edge') + + do k = 1, 3 + um(k) = this%average(k, 0.5, 0.75) ! Average from x=0.25 to 0.75 in each cell + enddo + call test%real_arr(3, um, (/1.25,3.25,5.25/), 'Return interval average') + + unit_tests = test%summarize('EMPLM_WA:unit_tests') + +end function unit_tests + +!> \namespace recon1d_emplm_wa +!! + +end module Recon1d_EMPLM_WA diff --git a/src/ALE/Recon1d_EMPLM_WA_poly.F90 b/src/ALE/Recon1d_EMPLM_WA_poly.F90 new file mode 100644 index 0000000000..bcfc398cf9 --- /dev/null +++ b/src/ALE/Recon1d_EMPLM_WA_poly.F90 @@ -0,0 +1,200 @@ +!> Extrapolated-Monotonized Piecewise Linear Method 1D reconstruction +!! +!! This extends MPLM_poly, following White and Adcroft, 2008 \cite white2008, by extraplating for the slopes of the +!! first and last cells. This extrapolation is used by White et al., 2009, during grid-generation. +!! +!! This stores and evaluates the reconstruction using a polynomial representation which is not preferred +!! but was the form used in OM4. +module Recon1d_EMPLM_WA_poly + +! This file is part of MOM6. See LICENSE.md for the license. + +use Recon1d_MPLM_WA_poly, only : MPLM_WA_poly, testing + +implicit none ; private + +public EMPLM_WA_poly + +!> Extrapolation Limited Monotonic PLM reconstruction following White and Adcroft, 2008 +!! +!! The source for the methods ultimately used by this class are: +!! - init() -> recon1d_mplm_wa_poly.init() +!! - reconstruct() -> recon1d_mplm_wa_poly.reconstruct() +!! - average() -> recon1d_mplm_wa_poly.average() +!! - f() -> recon1d_mplm_wa_poly -> recon1d_mplm_wa -> recon1d_plm_cw.f() +!! - dfdx() -> recon1d_mplm_wa_poly -> recon1d_mplm_wa -> recon1d_plm_cw.dfdx() +!! - check_reconstruction() *locally defined +!! - unit_tests() *locally defined +!! - destroy() -> recon1d_mplm_wa_poly -> recon1d_mplm_wa -> recon1d_plm_cw.destroy() +!! - remap_to_sub_grid() *locally defined +!! - init_parent() -> recon1d_mplm_wa_poly -> recon1d_mplm_wa.init() +!! - reconstruct_parent() -> recon1d_mplm_wa_poly -> recon1d_mplm_wa.reconstruct() +type, extends (MPLM_WA_poly) :: EMPLM_WA_poly + +contains + !> Implementation of the EMPLM_WA_poly reconstruction with boundary extrapolation + procedure :: reconstruct => reconstruct + !> Implementation of check reconstruction for the EMPLM_WA_poly reconstruction + procedure :: check_reconstruction => check_reconstruction + !> Implementation of unit tests for the EMPLM_WA_poly reconstruction + procedure :: unit_tests => unit_tests + +end type EMPLM_WA_poly + +contains + +!> Calculate a 1D PLM reconstruction based on h(:) and u(:) +subroutine reconstruct(this, h, u) + class(EMPLM_WA_poly), intent(inout) :: this !< This reconstruction + real, intent(in) :: h(*) !< Grid spacing (thickness) [typically H] + real, intent(in) :: u(*) !< Cell mean values [A] + ! Local variables + integer :: n + real :: slope ! Difference of u across cell [A] + + ! Use parent (MPLM_WA) reconstruction + call this%reconstruct_parent(h, u) + + n = this%n + + ! Fix reconstruction for first cell + slope = - PLM_extrapolate_slope( h(2), h(1), this%h_neglect, u(2), u(1) ) + this%ul(1) = u(1) - 0.5 * slope + this%ur(1) = u(1) + 0.5 * slope + this%poly_coef(1,1) = this%ul(1) + this%poly_coef(1,2) = this%ur(1) - this%ul(1) + + ! Fix reconstruction for last cell + slope = PLM_extrapolate_slope( h(n-1), h(n), this%h_neglect, u(n-1), u(n) ) + this%ul(n) = u(n) - 0.5 * slope + this%ur(n) = u(n) + 0.5 * slope + this%poly_coef(n,1) = this%ul(n) + this%poly_coef(n,2) = this%ur(n) - this%ul(n) + +end subroutine reconstruct + +!> Returns a PLM slope using h2 extrapolation from a cell to the left, in the same +!! arbitrary units as the input values [A]. +!! Use the negative to extrapolate from the cell to the right. +real elemental pure function PLM_extrapolate_slope(h_l, h_c, h_neglect, u_l, u_c) + real, intent(in) :: h_l !< Thickness of left cell in arbitrary grid thickness units [H] + real, intent(in) :: h_c !< Thickness of center cell in arbitrary grid thickness units [H] + real, intent(in) :: h_neglect !< A negligible thickness [H] + real, intent(in) :: u_l !< Value of left cell in arbitrary units [A] + real, intent(in) :: u_c !< Value of center cell in arbitrary units [A] + ! Local variables + real :: left_edge ! Left edge value [A] + real :: hl, hc ! Left and central cell thicknesses [H] + + ! Avoid division by zero for vanished cells + hl = h_l + h_neglect + hc = h_c + h_neglect + + ! The h2 scheme is used to compute the left edge value + left_edge = (u_l*hc + u_c*hl) / (hl + hc) + + PLM_extrapolate_slope = 2.0 * ( u_c - left_edge ) + +end function PLM_extrapolate_slope + +!> Checks the EMPLM_WA_poly reconstruction for consistency +logical function check_reconstruction(this, h, u) + class(EMPLM_WA_poly), intent(in) :: this !< This reconstruction + real, intent(in) :: h(*) !< Grid spacing (thickness) [typically H] + real, intent(in) :: u(*) !< Cell mean values [A] + ! Local variables + integer :: k + + check_reconstruction = .false. + + do k = 1, this%n + if ( abs( this%u_mean(k) - u(k) ) > 0. ) check_reconstruction = .true. + enddo + + ! Check implied curvature + do k = 1, this%n + if ( ( this%u_mean(k) - this%ul(k) ) * ( this%ur(k) - this%u_mean(k) ) < 0. ) check_reconstruction = .true. + enddo + + ! These two checks fail MOM_remapping:test_recon_consistency in the presence of vanished layers + ! e.g. intel/2023.2.0 on gaea at iter=26 + +! ! Check bounding of right edges, w.r.t. the cell means +! do K = 1, this%n-1 +! if ( ( this%ur(k) - this%u_mean(k) ) * ( this%u_mean(k+1) - this%ur(k) ) < 0. ) check_reconstruction = .true. +! enddo + +! ! Check bounding of left edges, w.r.t. the cell means +! do K = 2, this%n +! if ( ( this%u_mean(k) - this%ul(k) ) * ( this%ul(k) - this%u_mean(k-1) ) < 0. ) check_reconstruction = .true. +! enddo + + ! Check order of u, ur, ul + ! Note that in the OM4-era implementation, we were not consistent for top and bottom layers due + ! extrapolation using cell means rather than edge values, hence reduced range for K + do K = 2, this%n-2 + if ( ( this%ur(k) - this%u_mean(k) ) * ( this%ul(k+1) - this%ur(k) ) < 0. ) check_reconstruction = .true. + enddo + + ! Check bounding of left edges, w.r.t. this cell mean and the previous cell right edge + do K = 3, this%n-1 + if ( ( this%u_mean(k) - this%ul(k) ) * ( this%ul(k) - this%ur(k-1) ) < 0. ) check_reconstruction = .true. + enddo + +end function check_reconstruction + + +!> Runs PLM reconstruction unit tests and returns True for any fails, False otherwise +logical function unit_tests(this, verbose, stdout, stderr) + class(EMPLM_WA_poly), intent(inout) :: this !< This reconstruction + logical, intent(in) :: verbose !< True, if verbose + integer, intent(in) :: stdout !< I/O channel for stdout + integer, intent(in) :: stderr !< I/O channel for stderr + ! Local variables + real, allocatable :: ul(:), ur(:), um(:) ! test values [A] + real, allocatable :: ull(:), urr(:) ! test values [A] + type(testing) :: test ! convenience functions + integer :: k + + call test%set( stdout=stdout ) ! Sets the stdout channel in test + call test%set( stderr=stderr ) ! Sets the stderr channel in test + call test%set( verbose=verbose ) ! Sets the verbosity flag in test + + call this%init(3) + call test%test( this%n /= 3, 'Setting number of levels') + allocate( um(3), ul(3), ur(3), ull(3), urr(3) ) + + call this%reconstruct( (/2.,2.,2./), (/1.,3.,5./) ) + call test%real_arr(3, this%u_mean, (/1.,3.,5./), 'Setting cell values') + + do k = 1, 3 + ul(k) = this%f(k, 0.) + um(k) = this%f(k, 0.5) + ur(k) = this%f(k, 1.) + enddo + call test%real_arr(3, ul, (/0.,2.,4./), 'Evaluation on left edge') + call test%real_arr(3, um, (/1.,3.,5./), 'Evaluation in center') + call test%real_arr(3, ur, (/2.,4.,6./), 'Evaluation on right edge') + + do k = 1, 3 + ul(k) = this%dfdx(k, 0.) + um(k) = this%dfdx(k, 0.5) + ur(k) = this%dfdx(k, 1.) + enddo + call test%real_arr(3, ul, (/2.,2.,2./), 'dfdx on left edge') + call test%real_arr(3, um, (/2.,2.,2./), 'dfdx in center') + call test%real_arr(3, ur, (/2.,2.,2./), 'dfdx on right edge') + + do k = 1, 3 + um(k) = this%average(k, 0.5, 0.75) ! Average from x=0.25 to 0.75 in each cell + enddo + call test%real_arr(3, um, (/1.25,3.25,5.25/), 'Return interval average') + + unit_tests = test%summarize('EMPLM_WA_poly:unit_tests') + +end function unit_tests + +!> \namespace recon1d_emplm_wa_poly +!! + +end module Recon1d_EMPLM_WA_poly diff --git a/src/ALE/Recon1d_EPPM_CWK.F90 b/src/ALE/Recon1d_EPPM_CWK.F90 new file mode 100644 index 0000000000..2b9ed9853d --- /dev/null +++ b/src/ALE/Recon1d_EPPM_CWK.F90 @@ -0,0 +1,175 @@ +!> Piecewise Parabolic Method 1D reconstruction in model index space with linear +!! extrapolation for first and last cells +!! +!! This implementation of PPM follows Colella and Woodward, 1984, using uniform thickness +!! and with cells resorting to PCM for local extrema. First and last cells use a PLM +!! representation with slope set by matching the edge of the first interior cell. +module Recon1d_EPPM_CWK + +! This file is part of MOM6. See LICENSE.md for the license. + +use Recon1d_type, only : Recon1d, testing +use Recon1d_PPM_CWK, only : PPM_CWK + +implicit none ; private + +public EPPM_CWK, testing + +!> PPM reconstruction in index space (no grid dependence) with linear extrapolation +!! for first and last cells. +!! +!! Implemented by extending recon1d_ppm_cwk. +!! +!! The source for the methods ultimately used by this class are: +!! - init() -> recon1d_ppm_cwk.init() +!! - reconstruct() *locally defined +!! - average() -> recon1d_ppm_cwk.average() +!! - f() -> recon1d_ppm_cwk.f() +!! - dfdx() -> recon1d_ppm_cwk.dfdx() +!! - check_reconstruction() -> recon1d_ppm_cwk.check_reconstruction() +!! - unit_tests() *locally defined +!! - destroy() -> recon1d_ppm_cwk.destroy() +!! - remap_to_sub_grid() -> recon1d_type.remap_to_sub_grid() +!! - init_parent() -> recon1d_ppm_cwk.init() +!! - reconstruct_parent() -> recon1d_ppm_cwk.reconstruct() +type, extends (PPM_CWK) :: EPPM_CWK + +contains + !> Implementation of the EPPM_CWK reconstruction + procedure :: reconstruct => reconstruct + !> Implementation of unit tests for the EPPM_CWK reconstruction + procedure :: unit_tests => unit_tests + +end type EPPM_CWK + +contains + +!> Calculate a 1D EPPM_CWK reconstructions based on h(:) and u(:) +subroutine reconstruct(this, h, u) + class(EPPM_CWK), intent(inout) :: this !< This reconstruction + real, intent(in) :: h(*) !< Grid spacing (thickness) [typically H] + real, intent(in) :: u(*) !< Cell mean values [A] + ! Local variables + real :: dul, dur ! Left and right cell PLM slopes [A] + real :: u0, u1, u2 ! Far left, left, and right cell values [A] + real :: edge ! Edge value between cell k-1 and k [A] + real :: u_min, u_max ! Minimum and maximum value across edge [A] + real :: a6 ! Colella and Woodward curvature [A] + real :: du ! Difference between edges across cell [A] + real :: slp(this%n) ! PLM slope [A] + real, parameter :: one_sixth = 1. / 6. ! 1/6 [nondim] + integer :: k, n + + n = this%n + + call this%reconstruct_parent( h, u ) + + ! Extrapolate in first cell + this%ur(1) = this%ul(2) ! Assume ur=ul on right edge + this%ul(1) = u(1) + ( u(1) - this%ur(1) ) ! Linearly extrapolat across cell + + ! Extrapolate in last cell + this%ul(n) = this%ur(n-1) ! Assume ul=ur on left edge + this%ur(n) = u(n) + ( u(n) - this%ul(n) ) ! Linearly extrapolat across cell + +end subroutine reconstruct + +!> Runs EPPM_CWK reconstruction unit tests and returns True for any fails, False otherwise +logical function unit_tests(this, verbose, stdout, stderr) + class(EPPM_CWK), intent(inout) :: this !< This reconstruction + logical, intent(in) :: verbose !< True, if verbose + integer, intent(in) :: stdout !< I/O channel for stdout + integer, intent(in) :: stderr !< I/O channel for stderr + ! Local variables + real, allocatable :: ul(:), ur(:), um(:) ! test values [A] + real, allocatable :: ull(:), urr(:) ! test values [A] + type(testing) :: test ! convenience functions + integer :: k + + call test%set( stdout=stdout ) ! Sets the stdout channel in test + call test%set( stderr=stderr ) ! Sets the stderr channel in test + call test%set( verbose=verbose ) ! Sets the verbosity flag in test + + if (verbose) write(stdout,'(a)') 'EPPM_CWK:unit_tests testing with linear fn' + + call this%init(5) + call test%test( this%n /= 5, 'Setting number of levels') + allocate( um(5), ul(5), ur(5), ull(5), urr(5) ) + + ! Straight line, f(x) = x , or f(K) = 2*K + call this%reconstruct( (/2.,2.,2.,2.,2./), (/1.,4.,7.,10.,13./) ) + call test%real_arr(5, this%u_mean, (/1.,4.,7.,10.,13./), 'Setting cell values') + call test%real_arr(5, this%ul, (/-0.5,2.5,5.5,8.5,11.5/), 'Left edge values') + call test%real_arr(5, this%ur, (/2.5,5.5,8.5,11.5,14.5/), 'Right edge values') + + do k = 1, 5 + ul(k) = this%f(k, 0.) + um(k) = this%f(k, 0.5) + ur(k) = this%f(k, 1.) + enddo + call test%real_arr(5, ul, this%ul, 'Evaluation on left edge') + call test%real_arr(5, um, (/1.,4.,7.,10.,13./), 'Evaluation in center') + call test%real_arr(5, ur, this%ur, 'Evaluation on right edge') + + do k = 1, 5 + ul(k) = this%dfdx(k, 0.) + um(k) = this%dfdx(k, 0.5) + ur(k) = this%dfdx(k, 1.) + enddo + ! Most of these values are affected by the PLM boundary cells + call test%real_arr(5, ul, (/3.,3.,3.,3.,3./), 'dfdx on left edge') + call test%real_arr(5, um, (/3.,3.,3.,3.,3./), 'dfdx in center') + call test%real_arr(5, ur, (/3.,3.,3.,3.,3./), 'dfdx on right edge') + + do k = 1, 5 + um(k) = this%average(k, 0.5, 0.75) ! Average from x=0.25 to 0.75 in each cell + enddo + ! Most of these values are affected by the PLM boundary cells + call test%real_arr(5, um, (/1.375,4.375,7.375,10.375,13.375/), 'Return interval average') + + if (verbose) write(stdout,'(a)') 'EPPM_CWK:unit_tests testing with parabola' + + ! x = 2 i i=0 at origin + ! f(x) = 3/4 x^2 = (2 i)^2 + ! f[i] = 3/4 ( 2 i - 1 )^2 on centers + ! f[I] = 3/4 ( 2 I )^2 on edges + ! f[i] = 1/8 [ x^3 ] for means + ! edges: 0, 1, 12, 27, 48, 75 + ! means: 1, 7, 19, 37, 61 + ! centers: 0.75, 6.75, 18.75, 36.75, 60.75 + call this%reconstruct( (/2.,2.,2.,2.,2./), (/1.,7.,19.,37.,61./) ) + do k = 1, 5 + ul(k) = this%f(k, 0.) + um(k) = this%f(k, 0.5) + ur(k) = this%f(k, 1.) + enddo + call test%real_arr(5, ul, (/-1.,3.,12.,27.,48./), 'Return left edge') + call test%real_arr(5, um, (/1.,6.75,18.75,36.75,61./), 'Return center') + call test%real_arr(5, ur, (/3.,12.,27.,48.,74./), 'Return right edge') + + ! x = 3 i i=0 at origin + ! f(x) = x^2 / 3 = 3 i^2 + ! f[i] = [ ( 3 i )^3 - ( 3 i - 3 )^3 ] i=1,2,3,4,5 + ! means: 1, 7, 19, 37, 61 + ! edges: 0, 3, 12, 27, 48, 75 + call this%reconstruct( (/3.,3.,3.,3.,3./), (/1.,7.,19.,37.,61./) ) + do k = 1, 5 + ul(k) = this%f(k, 0.) + um(k) = this%f(k, 0.5) + ur(k) = this%f(k, 1.) + enddo + call test%real_arr(5, ul, (/-1.,3.,12.,27.,48./), 'Return left edge') + call test%real_arr(5, um, (/1.,6.75,18.75,36.75,61./), 'Return center') + call test%real_arr(5, ur, (/3.,12.,27.,48.,74./), 'Return right edge') + + call this%destroy() + deallocate( um, ul, ur, ull, urr ) + + unit_tests = test%summarize('EPPM_CWK:unit_tests') + +end function unit_tests + +!> \namespace recon1d_eppm_cwk +!! + +end module Recon1d_EPPM_CWK diff --git a/src/ALE/Recon1d_MPLM_CWK.F90 b/src/ALE/Recon1d_MPLM_CWK.F90 new file mode 100644 index 0000000000..dc401a8440 --- /dev/null +++ b/src/ALE/Recon1d_MPLM_CWK.F90 @@ -0,0 +1,292 @@ +!> Piecewise Linear Method 1D reconstruction in index space +!! +!! This implementation of PLM follows Colella and Woodward, 1984 \cite colella1984, except for assuming +!! uniform resolution so that the method is independent of grid spacing. The cell-wise reconstructions +!! are limited so that the edge values (which are also the extrema in a cell) are bounded by the neighbors. +!! The first and last cells are always limited to PCM. +module Recon1d_MPLM_CWK + +! This file is part of MOM6. See LICENSE.md for the license. + +use Recon1d_type, only : testing +use Recon1d_PLM_CWK, only : PLM_CWK + +implicit none ; private + +public MPLM_CWK, testing + +!> PLM reconstruction following Colella and Woodward, 1984 +!! +!! Implemented by extending recon1d_plm_cwk. +!! +!! The source for the methods ultimately used by this class are: +!! - init() -> recon1d_plm_cwk -> recon1d_plm_cw.init() +!! - reconstruct() *locally defined +!! - average() -> recon1d_plm_cwk -> recon1d_plm_cw.average() +!! - f() -> recon1d_plm_cwk -> recon1d_plm_cw.f() +!! - dfdx() -> recon1d_plm_cwk -> recon1d_plm_cw.dfdx() +!! - check_reconstruction() *locally defined +!! - unit_tests() *locally defined +!! - destroy() -> recon1d_plm_cwk -> recon1d_plm_cw.destroy() +!! - remap_to_sub_grid() -> recon1d_type.remap_to_sub_grid() +!! - init_parent() -> init() +!! - reconstruct_parent() -> reconstruct() +type, extends (PLM_CWK) :: MPLM_CWK + +contains + !> Implementation of the MPLM_CWK reconstruction + procedure :: reconstruct => reconstruct + !> Implementation of check reconstruction for the MPLM_CWK reconstruction + procedure :: check_reconstruction => check_reconstruction + !> Implementation of unit tests for the MPLM_CWK reconstruction + procedure :: unit_tests => unit_tests + + !> Duplicate interface to reconstruct() + procedure :: reconstruct_parent => reconstruct +end type MPLM_CWK + +contains + +!> Calculate a 1D PLM reconstructions based on h(:) and u(:) +subroutine reconstruct(this, h, u) + class(MPLM_CWK), intent(inout) :: this !< This reconstruction + real, intent(in) :: h(*) !< Grid spacing (thickness) [typically H] + real, intent(in) :: u(*) !< Cell mean values [A] + ! Local variables + real :: slp ! The PLM slopes (difference across cell) [A] + real :: sigma_l, sigma_c, sigma_r ! Left, central and right slope estimates as + ! differences across the cell [A] + real :: u_min, u_max ! Minimum and maximum value across cell [A] + real :: u_l, u_r, u_c ! Left, right, and center values [A] + real :: u_e(this%n+1) ! Average of edge values [A] + integer :: k, n + + n = this%n + + ! Loop over all cells + do k = 1, n + this%u_mean(k) = u(k) + enddo + + ! Boundary cells use PCM + this%ul(1) = u(1) + this%ur(1) = u(1) + + ! Loop over interior cells + do k = 2, n-1 + u_l = u(k-1) + u_c = u(k) + u_r = u(k+1) + + ! Side differences + sigma_r = u_r - u_c + sigma_l = u_c - u_l + + ! This is the second order slope given by equation 1.7 of + ! Piecewise Parabolic Method, Colella and Woodward (1984), + ! http://dx.doi.org/10.1016/0021-991(84)90143-8. + ! For uniform resolution it simplifies to ( u_r - u_l )/2 . + sigma_c = 0.5 * ( u_r - u_l ) + + ! Limit slope so that reconstructions are bounded by neighbors + u_min = min( u_l, u_c, u_r ) + u_max = max( u_l, u_c, u_r ) + + if ( (sigma_l * sigma_r) > 0.0 ) then + ! This limits the slope so that the edge values are bounded by the two cell averages spanning the edge + slp = sign( min( abs(sigma_c), 2.*min( u_c - u_min, u_max - u_c ) ), sigma_c ) + else + ! Extrema in the mean values require a PCM reconstruction + slp = 0.0 + endif + + ! Left edge + u_min = min( u_c, u_l ) + u_max = max( u_c, u_l ) + u_l = u_c - 0.5 * slp + this%ul(k) = max( min( u_l, u_max), u_min ) + + ! Right edge + u_min = min( u_c, u_r ) + u_max = max( u_c, u_r ) + u_r = u_c + 0.5 * slp + this%ur(k) = max( min( u_r, u_max), u_min ) + enddo + + ! Boundary cells use PCM + this%ul(n) = u(n) + this%ur(n) = u(n) + + ! Average edge values + u_e(1) = this%ul(1) + do K = 2, n + u_e(K) = 0.5 * ( this%ur(k-1) + this%ul(k) ) + enddo + u_e(n+1) = this%ur(n) + + ! Loop over interior cells, redo PLM slope limiting using average edge as neighbor cell values + do k = 2, n-1 + u_l = u_e(k) + u_c = u(k) + u_r = u_e(k+1) + + ! Side differences + sigma_r = u_r - u_c + sigma_l = u_c - u_l + + ! This is the second order slope given by equation 1.7 of + ! Piecewise Parabolic Method, Colella and Woodward (1984), + ! http://dx.doi.org/10.1016/0021-991(84)90143-8. + ! For uniform resolution it simplifies to ( u_r - u_l )/2 . + sigma_c = this%ur(k) - this%ul(k) + + ! Limit slope so that reconstructions are bounded by neighbors + u_min = min( u_l, u_c, u_r ) + u_max = max( u_l, u_c, u_r ) + + if ( (sigma_l * sigma_r) > 0.0 ) then + ! This limits the slope so that the edge values are bounded by the two cell averages spanning the edge + slp = sign( min( abs(sigma_c), 2.*min( u_c - u_min, u_max - u_c ) ), sigma_c ) + else + ! Extrema in the mean values require a PCM reconstruction + slp = 0.0 + endif + + ! Left edge + u_min = min( u_c, u_l ) + u_max = max( u_c, u_l ) + u_l = u_c - 0.5 * slp + this%ul(k) = max( min( u_l, u_max), u_min ) + + ! Right edge + u_min = min( u_c, u_r ) + u_max = max( u_c, u_r ) + u_r = u_c + 0.5 * slp + this%ur(k) = max( min( u_r, u_max), u_min ) + enddo + +end subroutine reconstruct + +!> Checks the MPLM_CWK reconstruction for consistency +logical function check_reconstruction(this, h, u) + class(MPLM_CWK), intent(in) :: this !< This reconstruction + real, intent(in) :: h(*) !< Grid spacing (thickness) [typically H] + real, intent(in) :: u(*) !< Cell mean values [A] + ! Local variables + integer :: k + + check_reconstruction = .false. + + do k = 1, this%n + if ( abs( this%u_mean(k) - u(k) ) > 0. ) check_reconstruction = .true. + enddo + + ! Check the cell reconstruction is monotonic within each cell (it should be as a straight line) + do k = 1, this%n + if ( ( this%u_mean(k) - this%ul(k) ) * ( this%ur(k) - this%u_mean(k) ) < 0. ) check_reconstruction = .true. + enddo + + ! Check the cell is a straight line (to within machine precision) + do k = 1, this%n + if ( abs(2. * this%u_mean(k) - ( this%ul(k) + this%ur(k) )) > epsilon(this%u_mean(1)) * & + max(abs(2. * this%u_mean(k)), abs(this%ul(k)), abs(this%ur(k))) ) check_reconstruction = .true. + enddo + + ! Check bounding of right edges, w.r.t. the cell means + do K = 1, this%n-1 + if ( ( this%ur(k) - this%u_mean(k) ) * ( this%u_mean(k+1) - this%ur(k) ) < 0. ) check_reconstruction = .true. + enddo + + ! Check bounding of left edges, w.r.t. the cell means + do K = 2, this%n + if ( ( this%u_mean(k) - this%ul(k) ) * ( this%ul(k) - this%u_mean(k-1) ) < 0. ) check_reconstruction = .true. + enddo + + ! Check bounding of right edges, w.r.t. this cell mean and the next cell left edge + do K = 1, this%n-1 + if ( ( this%ur(k) - this%u_mean(k) ) * ( this%ul(k+1) - this%ur(k) ) < 0. ) check_reconstruction = .true. + enddo + + ! Check bounding of left edges, w.r.t. this cell mean and the previous cell right edge + do K = 2, this%n + if ( ( this%u_mean(k) - this%ul(k) ) * ( this%ul(k) - this%ur(k-1) ) < 0. ) check_reconstruction = .true. + enddo + +end function check_reconstruction + +!> Runs PLM reconstruction unit tests and returns True for any fails, False otherwise +logical function unit_tests(this, verbose, stdout, stderr) + class(MPLM_CWK), intent(inout) :: this !< This reconstruction + logical, intent(in) :: verbose !< True, if verbose + integer, intent(in) :: stdout !< I/O channel for stdout + integer, intent(in) :: stderr !< I/O channel for stderr + ! Local variables + real, allocatable :: ul(:), ur(:), um(:) ! test values [A] + real, allocatable :: ull(:), urr(:) ! test values [A] + type(testing) :: test ! convenience functions + integer :: k + + call test%set( stdout=stdout ) ! Sets the stdout channel in test + call test%set( stderr=stderr ) ! Sets the stderr channel in test + call test%set( verbose=verbose ) ! Sets the verbosity flag in test + + call this%init(3) + call test%test( this%n /= 3, 'Setting number of levels') + allocate( um(3), ul(3), ur(3), ull(3), urr(3) ) + + call this%reconstruct( (/2.,2.,2./), (/1.,3.,5./) ) + call test%real_arr(3, this%u_mean, (/1.,3.,5./), 'Setting cell values') + + do k = 1, 3 + ul(k) = this%f(k, 0.) + um(k) = this%f(k, 0.5) + ur(k) = this%f(k, 1.) + enddo + call test%real_arr(3, ul, (/1.,2.,5./), 'Evaluation on left edge') + call test%real_arr(3, um, (/1.,3.,5./), 'Evaluation in center') + call test%real_arr(3, ur, (/1.,4.,5./), 'Evaluation on right edge') + + do k = 1, 3 + ul(k) = this%dfdx(k, 0.) + um(k) = this%dfdx(k, 0.5) + ur(k) = this%dfdx(k, 1.) + enddo + call test%real_arr(3, ul, (/0.,2.,0./), 'dfdx on left edge') + call test%real_arr(3, um, (/0.,2.,0./), 'dfdx in center') + call test%real_arr(3, ur, (/0.,2.,0./), 'dfdx on right edge') + + do k = 1, 3 + um(k) = this%average(k, 0.5, 0.75) ! Average from x=0.25 to 0.75 in each cell + enddo + call test%real_arr(3, um, (/1.,3.25,5./), 'Return interval average') + + call this%destroy() + deallocate( um, ul, ur, ull, urr ) + + allocate( um(4), ul(4), ur(4) ) + call this%init(4) + + ! These values lead to non-monotonic reconstuctions which are + ! valid for transport problems but not always appropriate for + ! remapping to arbitrary resolution grids. + ! The O(h^2) slopes are -, 2, 2, - and the limited + ! slopes are 0, 1, 1, 0 so the everywhere the reconstructions + ! are bounded by neighbors but ur(2) and ul(3) are out-of-order. + call this%reconstruct( (/1.,1.,1.,1./), (/0.,3.,4.,7./) ) + do k = 1, 4 + ul(k) = this%f(k, 0.) + ur(k) = this%f(k, 1.) + enddo + call test%real_arr(4, ul, (/0.,2.5,3.5,7./), 'Evaluation on left edge') + call test%real_arr(4, ur, (/0.,3.5,4.5,7./), 'Evaluation on right edge') + + deallocate( um, ul, ur ) + + unit_tests = test%summarize('MPLM_CWK:unit_tests') + +end function unit_tests + +!> \namespace recon1d_mplm_cwk +!! + +end module Recon1d_MPLM_CWK diff --git a/src/ALE/Recon1d_MPLM_WA.F90 b/src/ALE/Recon1d_MPLM_WA.F90 new file mode 100644 index 0000000000..b9fa635063 --- /dev/null +++ b/src/ALE/Recon1d_MPLM_WA.F90 @@ -0,0 +1,285 @@ +!> Monotonized Piecewise Linear Method 1D reconstruction +!! +!! This implementation of PLM follows White and Adcroft, 2008 \cite white2008. +!! The PLM slopes are first limited following Colella and Woodward, 1984, but are then +!! further limited to ensure the edge values moving across cell boundaries are monotone. +!! The first and last cells are always limited to PCM. +!! +!! This differs from recon1d_mplm_wa_poly in the internally not polynomial representations +!! are referred to. +module Recon1d_MPLM_WA + +! This file is part of MOM6. See LICENSE.md for the license. + +use Recon1d_PLM_CW, only : PLM_CW, testing + +implicit none ; private + +public MPLM_WA, testing + +!> Limited Monotonic PLM reconstruction following White and Adcroft, 2008 +!! +!! The source for the methods ultimately used by this class are: +!! - init() -> recon1d_plm_cw.init() +!! - reconstruct() *locally defined +!! - average() -> recon1d_plm_cw.average() +!! - f() -> recon1d_plm_cw.f() +!! - dfdx() -> recon1d_plm_cw.dfdx() +!! - check_reconstruction() *locally defined +!! - unit_tests() *locally defined +!! - destroy() -> recon1d_plm_cw.destroy() +!! - remap_to_sub_grid() -> recon1d_plm_cw -> recon1d_type.remap_to_sub_grid() +!! - init_parent() -> recon1d_plm_cw.init() +!! - reconstruct_parent() -> reconstruct() +type, extends (PLM_CW) :: MPLM_WA + +contains + !> Implementation of the MPLM_WA reconstruction + procedure :: reconstruct => reconstruct + !> Implementation of check reconstruction for the MPLM_WA reconstruction + procedure :: check_reconstruction => check_reconstruction + !> Implementation of unit tests for the MPLM_WA reconstruction + procedure :: unit_tests => unit_tests + + !> Duplicate interface to reconstruct() + procedure :: reconstruct_parent => reconstruct + +end type MPLM_WA + +contains + +!> Calculate a 1D PLM reconstructions based on h(:) and u(:) +subroutine reconstruct(this, h, u) + class(MPLM_WA), intent(inout) :: this !< This reconstruction + real, intent(in) :: h(*) !< Grid spacing (thickness) [typically H] + real, intent(in) :: u(*) !< Cell mean values [A] + ! Local variables + real :: slp(this%n) ! The PLM slopes (difference across cell) [A] + real :: mslp(this%n) ! The monotonized PLM slopes [A] + integer :: k, n + real :: u_tmp, u_min, u_max ! Working values of cells [A] + + n = this%n + + ! Loop over all cells + do k = 1, n + this%u_mean(k) = u(k) + enddo + + ! Loop on interior cells + do k = 2, n-1 + slp(k) = PLM_slope_wa(h(k-1), h(k), h(k+1), this%h_neglect, u(k-1), u(k), u(k+1)) + enddo ! end loop on interior cells + + ! Boundary cells use PCM. Extrapolation is handled after monotonization. + slp(1) = 0. + slp(n) = 0. + + ! This loop adjusts the slope so that edge values are monotonic. + do k = 2, n-1 + mslp(k) = PLM_monotonized_slope( u(k-1), u(k), u(k+1), slp(k-1), slp(k), slp(k+1) ) + enddo ! end loop on interior cells + mslp(1) = 0. + mslp(n) = 0. + + ! Store edge values + this%ul(1) = u(1) + this%ur(1) = u(1) + do k = 2, n-1 + u_tmp = u(k-1) + 0.5 * mslp(k-1) ! Right edge value of cell k-1 + u_min = min( u(k), u_tmp ) + u_max = max( u(k), u_tmp ) + u_tmp = u(k) - 0.5 * mslp(k) ! Left edge value of cell k + this%ul(k) = max( min( u_tmp, u_max), u_min ) ! Bounded to handle roundoff + u_tmp = u(k+1) - 0.5 * mslp(k-1) ! Left edge value of cell k+1 + u_min = min( u(k), u_tmp ) + u_max = max( u(k), u_tmp ) + u_tmp = u(k) + 0.5 * mslp(k) ! Right edge value of cell k + this%ur(k) = max( min( u_tmp, u_max), u_min ) ! Bounded to handle roundoff + enddo + this%ul(n) = u(n) + this%ur(n) = u(n) + +end subroutine reconstruct + +!> Returns a limited PLM slope following White and Adcroft, 2008, in the same arbitrary +!! units [A] as the input values. +!! Note that this is not the same as the Colella and Woodward method. +real elemental pure function PLM_slope_wa(h_l, h_c, h_r, h_neglect, u_l, u_c, u_r) + real, intent(in) :: h_l !< Thickness of left cell in arbitrary grid thickness units [H] + real, intent(in) :: h_c !< Thickness of center cell in arbitrary grid thickness units [H] + real, intent(in) :: h_r !< Thickness of right cell in arbitrary grid thickness units [H] + real, intent(in) :: h_neglect !< A negligible thickness [H] + real, intent(in) :: u_l !< Value of left cell in arbitrary units [A] + real, intent(in) :: u_c !< Value of center cell in arbitrary units [A] + real, intent(in) :: u_r !< Value of right cell in arbitrary units [A] + ! Local variables + real :: sigma_l, sigma_c, sigma_r ! Left, central and right slope estimates as + ! differences across the cell [A] + real :: u_min, u_max ! Minimum and maximum value across cell [A] + + ! Side differences + sigma_r = u_r - u_c + sigma_l = u_c - u_l + + ! Quasi-second order difference + sigma_c = 2.0 * ( u_r - u_l ) * ( h_c / ( h_l + 2.0*h_c + h_r + h_neglect) ) + + ! Limit slope so that reconstructions are bounded by neighbors + u_min = min( u_l, u_c, u_r ) + u_max = max( u_l, u_c, u_r ) + if ( (sigma_l * sigma_r) > 0.0 ) then + ! This limits the slope so that the edge values are bounded by the + ! two cell averages spanning the edge. + PLM_slope_wa = sign( min( abs(sigma_c), 2.*min( u_c - u_min, u_max - u_c ) ), sigma_c ) + else + ! Extrema in the mean values require a PCM reconstruction avoid generating + ! larger extreme values. + PLM_slope_wa = 0.0 + endif + +end function PLM_slope_wa + +!> Returns a limited PLM slope following Colella and Woodward 1984, in the same +!! arbitrary units as the input values [A]. +real elemental pure function PLM_monotonized_slope(u_l, u_c, u_r, s_l, s_c, s_r) + real, intent(in) :: u_l !< Value of left cell in arbitrary units [A] + real, intent(in) :: u_c !< Value of center cell in arbitrary units [A] + real, intent(in) :: u_r !< Value of right cell in arbitrary units [A] + real, intent(in) :: s_l !< PLM slope of left cell [A] + real, intent(in) :: s_c !< PLM slope of center cell [A] + real, intent(in) :: s_r !< PLM slope of right cell [A] + ! Local variables + real :: neighbor_edge ! Edge value of nieghbor cell [A] + real :: this_edge ! Edge value of this cell [A] + real :: slp ! Magnitude of PLM central slope [A] + + ! Comparison are made assuming +ve slopes + slp = abs(s_c) + + ! Check that left edge is between right edge of cell to the left and this cell mean + neighbor_edge = u_l + 0.5 * s_l + this_edge = u_c - 0.5 * s_c + if ( ( this_edge - neighbor_edge ) * ( u_c - this_edge ) < 0. ) then + ! Using the midpoint works because the neighbor is similarly adjusted + this_edge = 0.5 * ( this_edge + neighbor_edge ) + slp = min( slp, abs( this_edge - u_c ) * 2. ) + endif + + ! Check that right edge is between left edge of cell to the right and this cell mean + neighbor_edge = u_r - 0.5 * s_r + this_edge = u_c + 0.5 * s_c + if ( ( this_edge - u_c ) * ( neighbor_edge - this_edge ) < 0. ) then + ! Using the midpoint works because the neighbor is similarly adjusted + this_edge = 0.5 * ( this_edge + neighbor_edge ) + slp = min( slp, abs( this_edge - u_c ) * 2. ) + endif + + PLM_monotonized_slope = sign( slp, s_c ) + +end function PLM_monotonized_slope + +!> Checks the MPLM_WA reconstruction for consistency +logical function check_reconstruction(this, h, u) + class(MPLM_WA), intent(in) :: this !< This reconstruction + real, intent(in) :: h(*) !< Grid spacing (thickness) [typically H] + real, intent(in) :: u(*) !< Cell mean values [A] + ! Local variables + integer :: k + + check_reconstruction = .false. + + do k = 1, this%n + if ( abs( this%u_mean(k) - u(k) ) > 0. ) check_reconstruction = .true. + enddo + + ! Check the cell reconstruction is monotonic within each cell (it should be as a straight line) + do k = 1, this%n + if ( ( this%u_mean(k) - this%ul(k) ) * ( this%ur(k) - this%u_mean(k) ) < 0. ) check_reconstruction = .true. + enddo + + ! This next test fails abysmally! + ! Using intel/2023.2.0 on gaea, MOM_remapping:test_recon_consistency iter=6 + ! um~0.581492556923472 ul~0.402083491713151 ur~0.749082615698503 + ! Check the cell is a straight line (to within machine precision) +! do k = 1, this%n +! if ( abs(2. * this%u_mean(k) - ( this%ul(k) + this%ur(k) )) > epsilon(this%u_mean(1)) * & +! max(abs(2. * this%u_mean(k)), abs(this%ul(k)), abs(this%ur(k))) ) check_reconstruction = .true. +! enddo + + ! Check bounding of right edges, w.r.t. the cell means + do K = 1, this%n-1 + if ( ( this%ur(k) - this%u_mean(k) ) * ( this%u_mean(k+1) - this%ur(k) ) < 0. ) check_reconstruction = .true. + enddo + + ! Check bounding of left edges, w.r.t. the cell means + do K = 2, this%n + if ( ( this%u_mean(k) - this%ul(k) ) * ( this%ul(k) - this%u_mean(k-1) ) < 0. ) check_reconstruction = .true. + enddo + + ! Check order of u, ur, ul + do K = 1, this%n-1 + if ( ( this%ur(k) - this%u_mean(k) ) * ( this%ul(k+1) - this%ur(k) ) < 0. ) check_reconstruction = .true. + enddo + + ! Check bounding of left edges, w.r.t. this cell mean and the previous cell right edge + do K = 2, this%n + if ( ( this%u_mean(k) - this%ul(k) ) * ( this%ul(k) - this%ur(k-1) ) < 0. ) check_reconstruction = .true. + enddo + +end function check_reconstruction + +!> Runs PLM reconstruction unit tests and returns True for any fails, False otherwise +logical function unit_tests(this, verbose, stdout, stderr) + class(MPLM_WA), intent(inout) :: this !< This reconstruction + logical, intent(in) :: verbose !< True, if verbose + integer, intent(in) :: stdout !< I/O channel for stdout + integer, intent(in) :: stderr !< I/O channel for stderr + ! Local variables + real, allocatable :: ul(:), ur(:), um(:) ! test values [A] + real, allocatable :: ull(:), urr(:) ! test values [A] + type(testing) :: test ! convenience functions + integer :: k + + call test%set( stdout=stdout ) ! Sets the stdout channel in test + call test%set( stderr=stderr ) ! Sets the stderr channel in test + call test%set( verbose=verbose ) ! Sets the verbosity flag in test + + call this%init(3) + call test%test( this%n /= 3, 'Setting number of levels') + allocate( um(3), ul(3), ur(3), ull(3), urr(3) ) + + call this%reconstruct( (/2.,2.,2./), (/1.,3.,5./) ) + call test%real_arr(3, this%u_mean, (/1.,3.,5./), 'Setting cell values') + + do k = 1, 3 + ul(k) = this%f(k, 0.) + um(k) = this%f(k, 0.5) + ur(k) = this%f(k, 1.) + enddo + call test%real_arr(3, ul, (/1.,2.,5./), 'Evaluation on left edge') + call test%real_arr(3, um, (/1.,3.,5./), 'Evaluation in center') + call test%real_arr(3, ur, (/1.,4.,5./), 'Evaluation on right edge') + + do k = 1, 3 + ul(k) = this%dfdx(k, 0.) + um(k) = this%dfdx(k, 0.5) + ur(k) = this%dfdx(k, 1.) + enddo + call test%real_arr(3, ul, (/0.,2.,0./), 'dfdx on left edge') + call test%real_arr(3, um, (/0.,2.,0./), 'dfdx in center') + call test%real_arr(3, ur, (/0.,2.,0./), 'dfdx on right edge') + + do k = 1, 3 + um(k) = this%average(k, 0.5, 0.75) ! Average from x=0.25 to 0.75 in each cell + enddo + call test%real_arr(3, um, (/1.,3.25,5./), 'Return interval average') + + unit_tests = test%summarize('MPLM_WA:unit_tests') + +end function unit_tests + +!> \namespace recon1d_mplm_wa +!! + +end module Recon1d_MPLM_WA diff --git a/src/ALE/Recon1d_MPLM_WA_poly.F90 b/src/ALE/Recon1d_MPLM_WA_poly.F90 new file mode 100644 index 0000000000..4a4bdc95bb --- /dev/null +++ b/src/ALE/Recon1d_MPLM_WA_poly.F90 @@ -0,0 +1,490 @@ +!> Monotonized Piecewise Linear Method 1D reconstruction using polynomial representation +!! +!! This implementation of PLM follows White and Adcroft, 2008 \cite white2008. +!! The PLM slopes are first limited following Colella and Woodward, 1984, but are then +!! further limited to ensure the edge values moving across cell boundaries are monotone. +!! The first and last cells are always limited to PCM. +!! +!! This stores and evaluates the reconstruction using a polynomial representation which is +!! not preferred but was the form used in OM4. +module Recon1d_MPLM_WA_poly + +! This file is part of MOM6. See LICENSE.md for the license. + +use Recon1d_MPLM_WA, only : MPLM_WA, testing + +implicit none ; private + +public MPLM_WA_poly, testing + +!> Limited Monotonic PLM reconstruction following White and Adcroft, 2008 +!! +!! The source for the methods ultimately used by this class are: +!! - init() *locally defined +!! - reconstruct() *locally defined +!! - average() *locally defined +!! - f() -> recon1d_mplm_wa -> recon1d_plm_cw.f() +!! - dfdx() -> recon1d_mplm_wa -> recon1d_plm_cw.dfdx() +!! - check_reconstruction() *locally defined +!! - unit_tests() *locally defined +!! - destroy() -> recon1d_mplm_wa -> recon1d_plm_cw.destroy() +!! - remap_to_sub_grid() *locally defined +!! - init_parent() -> init() +!! - reconstruct_parent() -> reconstruct() +type, extends (MPLM_WA) :: MPLM_WA_poly + + ! Legacy representation + integer :: degree !< Degree of polynomial used in legacy representation + real, allocatable, dimension(:,:) :: poly_coef !< Polynomial coefficients in legacy representation + +contains + !> Implementation of the MPLM_WA_poly initialization + procedure :: init => init + !> Implementation of the MPLM_WA_poly reconstruction + procedure :: reconstruct => reconstruct + !> Implementation of the MPLM_WA_poly average over an interval [A] + procedure :: average => average + !> Implementation of check reconstruction for the MPLM_WA_poly reconstruction + procedure :: check_reconstruction => check_reconstruction + !> Implementation of unit tests for the MPLM_WA_poly reconstruction + procedure :: unit_tests => unit_tests + + !> Duplicate interface to init() + procedure :: init_parent => init + !> Duplicate interface to reconstruct() + procedure :: reconstruct_parent => reconstruct + +#undef USE_BASE_CLASS_REMAP +#ifndef USE_BASE_CLASS_REMAP +! This block is here to test whether the compiler can do better if we have local copies of +! the remapping functions. + !> Remaps the column to subgrid h_sub + procedure :: remap_to_sub_grid => remap_to_sub_grid +#endif + +end type MPLM_WA_poly + +contains + +!> Initialize a 1D PLM reconstruction for n cells +subroutine init(this, n, h_neglect, check) + class(MPLM_WA_poly), intent(out) :: this !< This reconstruction + integer, intent(in) :: n !< Number of cells in this column + real, optional, intent(in) :: h_neglect !< A negligibly small width used in cell reconstructions [H] + logical, optional, intent(in) :: check !< If true, enable some consistency checking + + this%n = n + + allocate( this%u_mean(n) ) + allocate( this%ul(n) ) + allocate( this%ur(n) ) + + this%h_neglect = tiny( this%u_mean(1) ) + if (present(h_neglect)) this%h_neglect = h_neglect + this%check = .false. + if (present(check)) this%check = check + + this%degree = 2 + allocate( this%poly_coef(n,2) ) + +end subroutine init + +!> Calculate a 1D MPLM_WA_poly reconstructions based on h(:) and u(:) +subroutine reconstruct(this, h, u) + class(MPLM_WA_poly), intent(inout) :: this !< This reconstruction + real, intent(in) :: h(*) !< Grid spacing (thickness) [typically H] + real, intent(in) :: u(*) !< Cell mean values [A] + ! Local variables + real :: slp(this%n) ! The PLM slopes (difference across cell) [A] + real :: mslp(this%n) ! The monotonized PLM slopes [A] + real :: e_r, edge ! Edge values [A] + real :: almost_one ! A value that is slightly smaller than 1 [nondim] + integer :: k, n + + n = this%n + + ! Loop over all cells + do k = 1, n + this%u_mean(k) = u(k) + enddo + + ! Loop on interior cells + do k = 2, n-1 + slp(k) = PLM_slope_wa(h(k-1), h(k), h(k+1), this%h_neglect, u(k-1), u(k), u(k+1)) + enddo ! end loop on interior cells + + ! Boundary cells use PCM. Extrapolation is handled after monotonization. + slp(1) = 0. + slp(n) = 0. + + ! This loop adjusts the slope so that edge values are monotonic. + do k = 2, n-1 + mslp(k) = PLM_monotonized_slope( u(k-1), u(k), u(k+1), slp(k-1), slp(k), slp(k+1) ) + enddo ! end loop on interior cells + mslp(1) = 0. + mslp(n) = 0. + + ! Store and return edge values and polynomial coefficients. + almost_one = 1. - epsilon(e_r) + this%ul(1) = u(1) + this%ur(1) = u(1) + this%poly_coef(1,1) = u(1) + this%poly_coef(1,2) = 0. + do k = 2, n-1 + this%ul(k) = u(k) - 0.5 * mslp(k) ! Left edge value of cell k + this%ur(k) = u(k) + 0.5 * mslp(k) ! Right edge value of cell k + + this%poly_coef(k,1) = this%ul(k) + this%poly_coef(k,2) = this%ur(k) - this%ul(k) + ! Check to see if this evaluation of the polynomial at x=1 would be + ! monotonic w.r.t. the next cell's edge value. If not, scale back! + edge = this%poly_coef(k,2) + this%poly_coef(k,1) + e_r = u(k+1) - 0.5 * sign( mslp(k+1), slp(k+1) ) + if ( (edge-u(k))*(e_r-edge)<0.) then + this%poly_coef(k,2) = this%poly_coef(k,2) * almost_one + endif + enddo + this%ul(n) = u(n) + this%ur(n) = u(n) + this%poly_coef(n,1) = u(n) + this%poly_coef(n,2) = 0. + +end subroutine reconstruct + +!> Returns a limited PLM slope following White and Adcroft, 2008, in the same arbitrary +!! units [A] as the input values. +!! Note that this is not the same as the Colella and Woodward method. +real elemental pure function PLM_slope_wa(h_l, h_c, h_r, h_neglect, u_l, u_c, u_r) + real, intent(in) :: h_l !< Thickness of left cell in arbitrary grid thickness units [H] + real, intent(in) :: h_c !< Thickness of center cell in arbitrary grid thickness units [H] + real, intent(in) :: h_r !< Thickness of right cell in arbitrary grid thickness units [H] + real, intent(in) :: h_neglect !< A negligible thickness [H] + real, intent(in) :: u_l !< Value of left cell in arbitrary units [A] + real, intent(in) :: u_c !< Value of center cell in arbitrary units [A] + real, intent(in) :: u_r !< Value of right cell in arbitrary units [A] + ! Local variables + real :: sigma_l, sigma_c, sigma_r ! Left, central and right slope estimates as + ! differences across the cell [A] + real :: u_min, u_max ! Minimum and maximum value across cell [A] + + ! Side differences + sigma_r = u_r - u_c + sigma_l = u_c - u_l + + ! Quasi-second order difference + sigma_c = 2.0 * ( u_r - u_l ) * ( h_c / ( h_l + 2.0*h_c + h_r + h_neglect) ) + + ! Limit slope so that reconstructions are bounded by neighbors + u_min = min( u_l, u_c, u_r ) + u_max = max( u_l, u_c, u_r ) + if ( (sigma_l * sigma_r) > 0.0 ) then + ! This limits the slope so that the edge values are bounded by the + ! two cell averages spanning the edge. + PLM_slope_wa = sign( min( abs(sigma_c), 2.*min( u_c - u_min, u_max - u_c ) ), sigma_c ) + else + ! Extrema in the mean values require a PCM reconstruction avoid generating + ! larger extreme values. + PLM_slope_wa = 0.0 + endif + + ! This block tests to see if roundoff causes edge values to be out of bounds + if (u_c - 0.5*abs(PLM_slope_wa) < u_min .or. u_c + 0.5*abs(PLM_slope_wa) > u_max) then + PLM_slope_wa = PLM_slope_wa * ( 1. - epsilon(PLM_slope_wa) ) + endif + + ! An attempt to avoid inconsistency when the values become unrepresentable. + ! ### The following 1.E-140 is dimensionally inconsistent. A newer version of + ! PLM is progress that will avoid the need for such rounding. + if (abs(PLM_slope_wa) < 1.E-140) PLM_slope_wa = 0. + +end function PLM_slope_wa + +!> Returns a limited PLM slope following Colella and Woodward 1984, in the same +!! arbitrary units as the input values [A]. +real elemental pure function PLM_monotonized_slope(u_l, u_c, u_r, s_l, s_c, s_r) + real, intent(in) :: u_l !< Value of left cell in arbitrary units [A] + real, intent(in) :: u_c !< Value of center cell in arbitrary units [A] + real, intent(in) :: u_r !< Value of right cell in arbitrary units [A] + real, intent(in) :: s_l !< PLM slope of left cell [A] + real, intent(in) :: s_c !< PLM slope of center cell [A] + real, intent(in) :: s_r !< PLM slope of right cell [A] + ! Local variables + real :: e_r, e_l, edge ! Right, left and temporary edge values [A] + real :: almost_two ! The number 2, almost [nondim] + real :: slp ! Magnitude of PLM central slope [A] + + almost_two = 2. * ( 1. - epsilon(s_c) ) + + ! Edge values of neighbors abutting this cell + e_r = u_l + 0.5*s_l + e_l = u_r - 0.5*s_r + slp = abs(s_c) + + ! Check that left edge is between right edge of cell to the left and this cell mean + edge = u_c - 0.5 * s_c + if ( ( edge - e_r ) * ( u_c - edge ) < 0. ) then + edge = 0.5 * ( edge + e_r ) + slp = min( slp, abs( edge - u_c ) * almost_two ) + endif + + ! Check that right edge is between left edge of cell to the right and this cell mean + edge = u_c + 0.5 * s_c + if ( ( edge - u_c ) * ( e_l - edge ) < 0. ) then + edge = 0.5 * ( edge + e_l ) + slp = min( slp, abs( edge - u_c ) * almost_two ) + endif + + PLM_monotonized_slope = sign( slp, s_c ) + +end function PLM_monotonized_slope + +!> Average between xa and xb for cell k of a 1D PLM reconstruction [A] +!! Note: this uses the simple polynomial form a + b * x on x E (0,1) +!! which can overshoot at x=1 +real function average(this, k, xa, xb) + class(MPLM_WA_poly), intent(in) :: this !< This reconstruction + integer, intent(in) :: k !< Cell number + real, intent(in) :: xa !< Start of averaging interval on element (0 to 1) + real, intent(in) :: xb !< End of averaging interval on element (0 to 1) + + average = this%poly_coef(k,1) & + + this%poly_coef(k,2) * 0.5 * ( xb + xa ) + +end function average + +#ifndef USE_BASE_CLASS_REMAP +! This block is needed to enable the "bounded" to test whether the compiler can do better if we have local copies of +! the remapping functions. + +!> Remaps the column to subgrid h_sub +!! +!! It is assumed that h_sub is a perfect sub-grid of h0, meaning each h0 cell +!! can be constructed by joining a contiguous set of h_sub cells. The integer +!! indices isrc_start, isrc_end, isub_src provide this mapping, and are +!! calculated in MOM_remapping +subroutine remap_to_sub_grid(this, h0, u0, n1, h_sub, & + isrc_start, isrc_end, isrc_max, isub_src, & + u_sub, uh_sub, u02_err) + class(MPLM_WA_poly), intent(in) :: this !< 1-D reconstruction type + real, intent(in) :: h0(*) !< Source grid widths (size n0) [H] + real, intent(in) :: u0(*) !< Source grid widths (size n0) [H] + integer, intent(in) :: n1 !< Number of cells in target grid + real, intent(in) :: h_sub(*) !< Overlapping sub-cell thicknesses, h_sub [H] + integer, intent(in) :: isrc_start(*) !< Index of first sub-cell within each source cell + integer, intent(in) :: isrc_end(*) !< Index of last sub-cell within each source cell + integer, intent(in) :: isrc_max(*) !< Index of thickest sub-cell within each source cell + integer, intent(in) :: isub_src(*) !< Index of source cell for each sub-cell + real, intent(out) :: u_sub(*) !< Sub-cell cell averages (size n1) [A] + real, intent(out) :: uh_sub(*) !< Sub-cell cell integrals (size n1) [A H] + real, intent(out) :: u02_err !< Integrated reconstruction error estimates [A H] + ! Local variables + integer :: i_sub ! Index of sub-cell + integer :: i0 ! Index into h0(1:n0), source column + integer :: i_max ! Used to record which sub-cell is the largest contribution of a source cell + real :: dh_max ! Used to record which sub-cell is the largest contribution of a source cell [H] + real :: xa, xb ! Non-dimensional position within a source cell (0..1) [nondim] + real :: dh ! The width of the sub-cell [H] + real :: duh ! The total amount of accumulated stuff (u*h) [A H] + real :: dh0_eff ! Running sum of source cell thickness [H] + integer :: i0_last_thick_cell, n0 + real :: u0_min(this%n), u0_max(this%n) ! Min/max of u0 for each source cell [A] + real :: ul, ur ! left/right edge values of cell i0 + + n0 = this%n + + i0_last_thick_cell = 0 + do i0 = 1, n0 + ul = this%ul(i0) + ur = this%ur(i0) + u0_min(i0) = min(ul, ur) + u0_max(i0) = max(ul, ur) + if (h0(i0)>0.) i0_last_thick_cell = i0 + enddo + + ! Loop over each sub-cell to calculate average/integral values within each sub-cell. + ! Uses: h_sub, isub_src, h0_eff + ! Sets: u_sub, uh_sub + xa = 0. + dh0_eff = 0. + u02_err = 0. + do i_sub = 1, n0+n1 + + ! Sub-cell thickness from loop above + dh = h_sub(i_sub) + + ! Source cell + i0 = isub_src(i_sub) + + ! Evaluate average and integral for sub-cell i_sub. + ! Integral is over distance dh but expressed in terms of non-dimensional + ! positions with source cell from xa to xb (0 <= xa <= xb <= 1). + dh0_eff = dh0_eff + dh ! Cumulative thickness within the source cell + if (h0(i0)>0.) then + xb = dh0_eff / h0(i0) ! This expression yields xa <= xb <= 1.0 + xb = min(1., xb) ! This is only needed when the total target column is wider than the source column + u_sub(i_sub) = this%average( i0, xa, xb ) + else ! Vanished cell + xb = 1. + u_sub(i_sub) = u0(i0) + endif + uh_sub(i_sub) = dh * u_sub(i_sub) + u_sub(i_sub) = max( u_sub(i_sub), u0_min(i0) ) + u_sub(i_sub) = min( u_sub(i_sub), u0_max(i0) ) + + if (isub_src(i_sub+1) /= i0) then + ! If the next sub-cell is in a different source cell, reset the position counters + dh0_eff = 0. + xa = 0. + else + xa = xb ! Next integral will start at end of last + endif + + enddo + i_sub = n0+n1+1 + ! Sub-cell thickness from loop above + dh = h_sub(i_sub) + ! Source cell + i0 = isub_src(i_sub) + + ! Evaluate average and integral for sub-cell i_sub. + ! Integral is over distance dh but expressed in terms of non-dimensional + ! positions with source cell from xa to xb (0 <= xa <= xb <= 1). + dh0_eff = dh0_eff + dh ! Cumulative thickness within the source cell + if (h0(i0)>0.) then + xb = dh0_eff / h0(i0) ! This expression yields xa <= xb <= 1.0 + xb = min(1., xb) ! This is only needed when the total target column is wider than the source column + u_sub(i_sub) = this%average( i0, xa, xb ) + else ! Vanished cell + xb = 1. + u_sub(i_sub) = u0(i0) + endif + u_sub(i_sub) = max( u_sub(i_sub), u0_min(i0) ) + u_sub(i_sub) = min( u_sub(i_sub), u0_max(i0) ) + uh_sub(i_sub) = dh * u_sub(i_sub) + + ! Loop over each source cell substituting the integral/average for the thickest sub-cell (within + ! the source cell) with the residual of the source cell integral minus the other sub-cell integrals + ! aka a genius algorithm for accurate conservation when remapping from Robert Hallberg (\@Hallberg-NOAA). + ! Uses: i0_last_thick_cell, isrc_max, h_sub, isrc_start, isrc_end, uh_sub, u0, h0 + ! Updates: uh_sub + do i0 = 1, i0_last_thick_cell + i_max = isrc_max(i0) + dh_max = h_sub(i_max) + if (dh_max > 0.) then + ! duh will be the sum of sub-cell integrals within the source cell except for the thickest sub-cell. + duh = 0. + do i_sub = isrc_start(i0), isrc_end(i0) + if (i_sub /= i_max) duh = duh + uh_sub(i_sub) + enddo + uh_sub(i_max) = u0(i0)*h0(i0) - duh + u02_err = u02_err + max( abs(uh_sub(i_max)), abs(u0(i0)*h0(i0)), abs(duh) ) + endif + enddo + + ! This should not generally be used + if (this%check) then + if ( this%check_reconstruction(h0, u0) ) stop 912 ! A debugger is required to understand why this failed + endif + +end subroutine remap_to_sub_grid +#endif + +!> Checks the MPLM_WA_poly reconstruction for consistency +logical function check_reconstruction(this, h, u) + class(MPLM_WA_poly), intent(in) :: this !< This reconstruction + real, intent(in) :: h(*) !< Grid spacing (thickness) [typically H] + real, intent(in) :: u(*) !< Cell mean values [A] + ! Local variables + integer :: k + + check_reconstruction = .false. + + do k = 1, this%n + if ( abs( this%u_mean(k) - u(k) ) > 0. ) check_reconstruction = .true. + enddo + + ! Check the cell reconstruction is monotonic within each cell (it should be as a straight line) + do k = 1, this%n + if ( ( this%u_mean(k) - this%ul(k) ) * ( this%ur(k) - this%u_mean(k) ) < 0. ) check_reconstruction = .true. + enddo + + ! Check the cell is a straight line (to within machine precision) + do k = 1, this%n + if ( abs(2. * this%u_mean(k) - ( this%ul(k) + this%ur(k) )) > epsilon(this%u_mean(1)) * & + max(abs(2. * this%u_mean(k)), abs(this%ul(k)), abs(this%ur(k))) ) check_reconstruction = .true. + enddo + + ! Check bounding of right edges, w.r.t. the cell means + do K = 1, this%n-1 + if ( ( this%ur(k) - this%u_mean(k) ) * ( this%u_mean(k+1) - this%ur(k) ) < 0. ) check_reconstruction = .true. + enddo + + ! Check bounding of left edges, w.r.t. the cell means + do K = 2, this%n + if ( ( this%u_mean(k) - this%ul(k) ) * ( this%ul(k) - this%u_mean(k-1) ) < 0. ) check_reconstruction = .true. + enddo + + ! Check bounding of left edges, w.r.t. this cell mean and the previous cell right edge + ! Check order of u, ur, ul + ! Note that in OM4 implementation, we were not consistent for top and bottom layers due + ! extrapolation using cell means rather than edge values + do K = 2, this%n-2 + if ( ( this%ur(k) - this%u_mean(k) ) * ( this%ul(k+1) - this%ur(k) ) < 0. ) check_reconstruction = .true. + enddo + +end function check_reconstruction + +!> Runs PLM reconstruction unit tests and returns True for any fails, False otherwise +logical function unit_tests(this, verbose, stdout, stderr) + class(MPLM_WA_poly), intent(inout) :: this !< This reconstruction + logical, intent(in) :: verbose !< True, if verbose + integer, intent(in) :: stdout !< I/O channel for stdout + integer, intent(in) :: stderr !< I/O channel for stderr + ! Local variables + real, allocatable :: ul(:), ur(:), um(:) ! test values [A] + real, allocatable :: ull(:), urr(:) ! test values [A] + type(testing) :: test ! convenience functions + integer :: k + + call test%set( stdout=stdout ) ! Sets the stdout channel in test + call test%set( stderr=stderr ) ! Sets the stderr channel in test + call test%set( verbose=verbose ) ! Sets the verbosity flag in test + + call this%init(3) + call test%test( this%n /= 3, 'Setting number of levels') + allocate( um(3), ul(3), ur(3), ull(3), urr(3) ) + + call this%reconstruct( (/2.,2.,2./), (/1.,3.,5./) ) + call test%real_arr(3, this%u_mean, (/1.,3.,5./), 'Setting cell values') + + do k = 1, 3 + ul(k) = this%f(k, 0.) + um(k) = this%f(k, 0.5) + ur(k) = this%f(k, 1.) + enddo + call test%real_arr(3, ul, (/1.,2.,5./), 'Evaluation on left edge') + call test%real_arr(3, um, (/1.,3.,5./), 'Evaluation in center') + call test%real_arr(3, ur, (/1.,4.,5./), 'Evaluation on right edge') + + do k = 1, 3 + ul(k) = this%dfdx(k, 0.) + um(k) = this%dfdx(k, 0.5) + ur(k) = this%dfdx(k, 1.) + enddo + call test%real_arr(3, ul, (/0.,2.,0./), 'dfdx on left edge') + call test%real_arr(3, um, (/0.,2.,0./), 'dfdx in center') + call test%real_arr(3, ur, (/0.,2.,0./), 'dfdx on right edge') + + do k = 1, 3 + um(k) = this%average(k, 0.5, 0.75) ! Average from x=0.25 to 0.75 in each cell + enddo + call test%real_arr(3, um, (/1.,3.25,5./), 'Return interval average') + + unit_tests = test%summarize('MPLM_WA_poly:unit_tests') + +end function unit_tests + +!> \namespace recon1d_mplm_wa_poly +!! + +end module Recon1d_MPLM_WA_poly diff --git a/src/ALE/Recon1d_PCM.F90 b/src/ALE/Recon1d_PCM.F90 new file mode 100644 index 0000000000..3b64844983 --- /dev/null +++ b/src/ALE/Recon1d_PCM.F90 @@ -0,0 +1,196 @@ +!> 1D reconstructions using the Piecewise Constant Method (PCM) +module Recon1d_PCM + +! This file is part of MOM6. See LICENSE.md for the license. + +use Recon1d_type, only : Recon1d, testing + +implicit none ; private + +public PCM + +!> PCM (piecewise constant) reconstruction +!! +!! The source for the methods ultimately used by this class are: +!! init() *locally defined +!! reconstruct() *locally defined +!! average() *locally defined +!! f() *locally defined +!! dfdx() *locally defined +!! check_reconstruction() *locally defined +!! unit_tests() *locally defined +!! destroy() *locally defined +!! remap_to_sub_grid() -> Recon1d%remap_to_sub_grid() +!! init_parent() -> init() +!! reconstruct_parent() -> parent() +type, extends (Recon1d) :: PCM + +contains + !> Implementation of the PCM initialization + procedure :: init => init + !> Implementation of the PCM reconstruction + procedure :: reconstruct => reconstruct + !> Implementation of the PCM average over an interval [A] + procedure :: average => average + !> Implementation of evaluating the PCM reconstruction at a point [A] + procedure :: f => f + !> Implementation of the derivative of the PCM reconstruction at a point [A] + procedure :: dfdx => dfdx + !> Implementation of deallocation for PCM + procedure :: destroy => destroy + !> Implementation of check reconstruction for the PCM reconstruction + procedure :: check_reconstruction => check_reconstruction + !> Implementation of unit tests for the PCM reconstruction + procedure :: unit_tests => unit_tests + + !> Duplicate interface to init() + procedure :: init_parent => init + !> Duplicate interface to reconstruct() + procedure :: reconstruct_parent => reconstruct + +end type PCM + +contains + +!> Initialize a 1D PCM reconstruction for n cells +subroutine init(this, n, h_neglect, check) + class(PCM), intent(out) :: this !< This reconstruction + integer, intent(in) :: n !< Number of cells in this column + real, optional, intent(in) :: h_neglect !< A negligibly small width used in cell reconstructions [H]. + !! Not used by PCM. + logical, optional, intent(in) :: check !< If true, enable some consistency checking + + if (present(h_neglect)) this%n = n ! no-op to avoid compiler warning about unused dummy argument + if (present(check)) this%check = check + + this%n = n + + allocate( this%u_mean(n) ) + +end subroutine init + +!> Calculate a 1D PCM reconstructions based on h(:) and u(:) +subroutine reconstruct(this, h, u) + class(PCM), intent(inout) :: this !< This reconstruction + real, intent(in) :: h(*) !< Grid spacing (thickness) [typically H] + real, intent(in) :: u(*) !< Cell mean values [A] + ! Local variables + integer :: k + + this%u_mean(1) = h(1) ! no-op to avoid compiler warning about unused dummy argument + + do k = 1, this%n + this%u_mean(k) = u(k) + enddo + +end subroutine reconstruct + +!> Value of PCM reconstruction at a point in cell k [A] +real function f(this, k, x) + class(PCM), intent(in) :: this !< This reconstruction + integer, intent(in) :: k !< Cell number + real, intent(in) :: x !< Non-dimensional position within element [nondim] + + f = this%u_mean(k) + +end function f + +!> Derivative of PCM reconstruction at a point in cell k [A] +real function dfdx(this, k, x) + class(PCM), intent(in) :: this !< This reconstruction + integer, intent(in) :: k !< Cell number + real, intent(in) :: x !< Non-dimensional position within element [nondim] + + dfdx = 0. + +end function dfdx + +!> Average between xa and xb for cell k of a 1D PCM reconstruction [A] +real function average(this, k, xa, xb) + class(PCM), intent(in) :: this !< This reconstruction + integer, intent(in) :: k !< Cell number + real, intent(in) :: xa !< Start of averaging interval on element (0 to 1) + real, intent(in) :: xb !< End of averaging interval on element (0 to 1) + + average = xb + xa ! no-op to avoid compiler warnings about unused dummy argument + average = this%u_mean(k) + +end function average + +!> Deallocate the PCM reconstruction +subroutine destroy(this) + class(PCM), intent(inout) :: this !< This reconstruction + + deallocate( this%u_mean ) + +end subroutine destroy + +!> Checks the PCM reconstruction for consistency +logical function check_reconstruction(this, h, u) + class(PCM), intent(in) :: this !< This reconstruction + real, intent(in) :: h(*) !< Grid spacing (thickness) [typically H] + real, intent(in) :: u(*) !< Cell mean values [A] + ! Local variables + integer :: k + + check_reconstruction = .false. + + do k = 1, this%n + if ( abs( this%u_mean(k) - u(k) ) > 0. ) check_reconstruction = .true. + enddo + +end function check_reconstruction + +!> Runs PCM reconstruction unit tests and returns True for any fails, False otherwise +logical function unit_tests(this, verbose, stdout, stderr) + class(PCM), intent(inout) :: this !< This reconstruction + logical, intent(in) :: verbose !< True, if verbose + integer, intent(in) :: stdout !< I/O channel for stdout + integer, intent(in) :: stderr !< I/O channel for stderr + ! Local variables + real, allocatable :: ul(:), ur(:), um(:) ! test values [A] + type(testing) :: test ! convenience functions + integer :: k + + call test%set( stdout=stdout ) ! Sets the stdout channel in test + call test%set( stderr=stderr ) ! Sets the stderr channel in test + call test%set( verbose=verbose ) ! Sets the verbosity flag in test + + call this%init(3) + call test%test( this%n /= 3, 'Setting number of levels') + allocate( um(3), ul(3), ur(3) ) + + call this%reconstruct( (/2.,2.,2./), (/1.,3.,5./) ) + call test%real_arr(3, this%u_mean, (/1.,3.,5./), 'Setting cell values') + + do k = 1, 3 + ul(k) = this%f(k, 0.) + um(k) = this%f(k, 0.5) + ur(k) = this%f(k, 1.) + enddo + call test%real_arr(3, ul, (/1.,3.,5./), 'Evaluation on left edge') + call test%real_arr(3, um, (/1.,3.,5./), 'Evaluation in center') + call test%real_arr(3, ur, (/1.,3.,5./), 'Evaluation on right edge') + + do k = 1, 3 + ul(k) = this%dfdx(k, 0.) + um(k) = this%dfdx(k, 0.5) + ur(k) = this%dfdx(k, 1.) + enddo + call test%real_arr(3, ul, (/0.,0.,0./), 'dfdx on left edge') + call test%real_arr(3, um, (/0.,0.,0./), 'dfdx in center') + call test%real_arr(3, ur, (/0.,0.,0./), 'dfdx on right edge') + + do k = 1, 3 + um(k) = this%average(k, 0.5, 0.75) + enddo + call test%real_arr(3, um, (/1.,3.,5./), 'Return interval average') + + unit_tests = test%summarize('PCM:unit_tests') + +end function unit_tests + +!> \namespace recon1d_pcm +!! + +end module Recon1d_PCM diff --git a/src/ALE/Recon1d_PLM_CW.F90 b/src/ALE/Recon1d_PLM_CW.F90 new file mode 100644 index 0000000000..0c53246286 --- /dev/null +++ b/src/ALE/Recon1d_PLM_CW.F90 @@ -0,0 +1,371 @@ +!> Piecewise Linear Method 1D reconstruction +!! +!! This implementation of PLM follows Colella and Woodward, 1984 \cite colella1984, with cells +!! resorting to PCM for extrema including the first and last cells in column. +!! The cell-wise reconstructions are limited so that the edge values (which are also the extrema +!! in a cell) are bounded by the neighboring cell means. +!! This does not yield monotonic profiles for the general remapping problem. +module Recon1d_PLM_CW + +! This file is part of MOM6. See LICENSE.md for the license. + +use Recon1d_type, only : Recon1d, testing + +implicit none ; private + +public PLM_CW, testing + +!> PLM reconstruction following Colella and Woodward, 1984 +!! +!! The source for the methods ultimately used by this class are: +!! - init() *locally defined +!! - reconstruct() *locally defined +!! - average() *locally defined +!! - f() *locally defined +!! - dfdx() *locally defined +!! - check_reconstruction() *locally defined +!! - unit_tests() *locally defined +!! - destroy() *locally defined +!! - remap_to_sub_grid() -> recon1d_type.remap_to_sub_grid() +!! - init_parent() -> init() +!! - reconstruct_parent() -> reconstruct() +type, extends (Recon1d) :: PLM_CW + + real, allocatable :: ul(:) !< Left edge value [A] + real, allocatable :: ur(:) !< Right edge value [A] + +contains + !> Implementation of the PLM_CW initialization + procedure :: init => init + !> Implementation of the PLM_CW reconstruction + procedure :: reconstruct => reconstruct + !> Implementation of the PLM_CW average over an interval [A] + procedure :: average => average + !> Implementation of evaluating the PLM_CW reconstruction at a point [A] + procedure :: f => f + !> Implementation of the derivative of the PLM_CW reconstruction at a point [A] + procedure :: dfdx => dfdx + !> Implementation of deallocation for PLM_CW + procedure :: destroy => destroy + !> Implementation of check reconstruction for the PLM_CW reconstruction + procedure :: check_reconstruction => check_reconstruction + !> Implementation of unit tests for the PLM_CW reconstruction + procedure :: unit_tests => unit_tests + + !> Duplicate interface to init() + procedure :: init_parent => init + !> Duplicate interface to reconstruct() + procedure :: reconstruct_parent => reconstruct + +end type PLM_CW + +contains + +!> Initialize a 1D PLM reconstruction for n cells +subroutine init(this, n, h_neglect, check) + class(PLM_CW), intent(out) :: this !< This reconstruction + integer, intent(in) :: n !< Number of cells in this column + real, optional, intent(in) :: h_neglect !< A negligibly small width used in cell reconstructions [H] + logical, optional, intent(in) :: check !< If true, enable some consistency checking + + this%n = n + + allocate( this%u_mean(n) ) + allocate( this%ul(n) ) + allocate( this%ur(n) ) + + this%h_neglect = tiny( this%u_mean(1) ) + if (present(h_neglect)) this%h_neglect = h_neglect + this%check = .false. + if (present(check)) this%check = check + +end subroutine init + +!> Calculate a 1D PLM reconstructions based on h(:) and u(:) +subroutine reconstruct(this, h, u) + class(PLM_CW), intent(inout) :: this !< This reconstruction + real, intent(in) :: h(*) !< Grid spacing (thickness) [typically H] + real, intent(in) :: u(*) !< Cell mean values [A] + ! Local variables + real :: slp ! The PLM slopes (difference across cell) [A] + real :: sigma_l, sigma_c, sigma_r ! Left, central and right slope estimates as + ! differences across the cell [A] + real :: u_min, u_max ! Minimum and maximum value across cell [A] + real :: u_l, u_r, u_c ! Left, right, and center values [A] + real :: h_l, h_c, h_r ! Thickness of left, center and right cells [H] + real :: h_c0 ! Thickness of center with h_neglect added [H] + integer :: k, n + + n = this%n + + ! Loop over all cells + do k = 1, n + this%u_mean(k) = u(k) + enddo + + ! Boundary cells use PCM + this%ul(1) = u(1) + this%ur(1) = u(1) + + ! Loop over interior cells + do k = 2, n-1 + u_l = u(k-1) + u_c = u(k) + u_r = u(k+1) + + ! Side differences + sigma_r = u_r - u_c + sigma_l = u_c - u_l + + h_l = h(k-1) + h_c = h(k) + h_r = h(k+1) + ! Avoids division by zero + h_c0 = h_c + this%h_neglect + + ! This is the second order slope given by equation 1.7 of + ! Piecewise Parabolic Method, Colella and Woodward (1984), + ! http://dx.doi.org/10.1016/0021-991(84)90143-8. + ! For uniform resolution it simplifies to ( u_r - u_l )/2 . + sigma_c = ( h_c / ( h_c0 + ( h_l + h_r ) ) ) * ( & + ( 2.*h_l + h_c ) / ( h_r + h_c0 ) * sigma_r & + + ( 2.*h_r + h_c ) / ( h_l + h_c0 ) * sigma_l ) + + ! Limit slope so that reconstructions are bounded by neighbors + u_min = min( u_l, u_c, u_r ) + u_max = max( u_l, u_c, u_r ) + + if ( (sigma_l * sigma_r) > 0.0 ) then + ! This limits the slope so that the edge values are bounded by the two cell averages spanning the edge + slp = sign( min( abs(sigma_c), 2.*min( u_c - u_min, u_max - u_c ) ), sigma_c ) + else + ! Extrema in the mean values require a PCM reconstruction + slp = 0.0 + endif + + ! Left edge + u_min = min( u_c, u_l ) + u_max = max( u_c, u_l ) + u_l = u_c - 0.5 * slp + this%ul(k) = max( min( u_l, u_max), u_min ) + + ! Right edge + u_min = min( u_c, u_r ) + u_max = max( u_c, u_r ) + u_r = u_c + 0.5 * slp + this%ur(k) = max( min( u_r, u_max), u_min ) + enddo + + ! Boundary cells use PCM + this%ul(n) = u(n) + this%ur(n) = u(n) + +end subroutine reconstruct + +!> Value of PLM_CW reconstruction at a point in cell k [A] +real function f(this, k, x) + class(PLM_CW), intent(in) :: this !< This reconstruction + integer, intent(in) :: k !< Cell number + real, intent(in) :: x !< Non-dimensional position within element [nondim] + real :: xc ! Bounded version of x [nondim] + real :: du ! Difference across cell [A] + real :: u_a, u_b ! Two estimate of f [A] + + du = this%ur(k) - this%ul(k) + xc = max( 0., min( 1., x ) ) + + ! This expression for u_a can overshoot u_r but is good for x<<1 + u_a = this%ul(k) + du * xc + ! This expression for u_b can overshoot u_l but is good for 1-x<<1 + u_b = this%ur(k) + du * ( xc - 1. ) + + ! Since u_a and u_b are both bounded, this will perserve uniformity + f = 0.5 * ( u_a + u_b ) + +end function f + +!> Derivative of PLM_CW reconstruction at a point in cell k [A] +real function dfdx(this, k, x) + class(PLM_CW), intent(in) :: this !< This reconstruction + integer, intent(in) :: k !< Cell number + real, intent(in) :: x !< Non-dimensional position within element [nondim] + + dfdx = this%ur(k) - this%ul(k) + +end function dfdx + +!> Average between xa and xb for cell k of a 1D PLM reconstruction [A] +real function average(this, k, xa, xb) + class(PLM_CW), intent(in) :: this !< This reconstruction + integer, intent(in) :: k !< Cell number + real, intent(in) :: xa !< Start of averaging interval on element (0 to 1) + real, intent(in) :: xb !< End of averaging interval on element (0 to 1) + real :: xmab ! Mid-point between xa and xb (0 to 1) + real :: u_a, u_b ! Values at xa and xb [A] + + ! This form is not guaranteed to be bounded by {ul,ur} +! u_a = this%ul(k) * ( 1. - xa ) + this%ur(k) * xa +! u_b = this%ul(k) * ( 1. - xb ) + this%ur(k) * xb +! average = 0.5 * ( u_a + u_b ) + + ! Mid-point between xa and xb + xmab = 0.5 * ( xa + xb ) + + ! The following expression is exact at xmab=0 and xmab=1, + ! i.e. gives the numerically correct values. + ! It is not obvious that the expression is monotonic but according to + ! https://math.stackexchange.com/questions/907329/accurate-floating-point-linear-interpolation + ! it will be for the default rounding behavior. Otherwise is it + ! then possible this expression can be outside the range of ul and ur? +! average = this%ul(k) * ( 1. - xmab ) + this%ur(k) * xmab + ! Emperically it fails the uniform value test + + ! The following is more complicated but seems to ensure being within bounds. + ! This expression for u_a can overshoot u_r but is good for xmab<<1 + u_a = this%ul(k) + ( this%ur(k) - this%ul(k) ) * xmab + ! This expression for u_b can overshoot u_l but is good for 1-xmab<<1 + u_b = this%ur(k) + ( this%ul(k) - this%ur(k) ) * ( 1. - xmab ) + ! Replace xmab with -1 for xmab<0.5, 1 for xmab>=0.5 +! xmab = sign(1., xmab-0.5) + ! Select either u_a or u_b, depending whether mid-point of xa, xb is smaller/larger than 0.5 +! average = xmab * u_b + ( 1. - xmab ) * u_a + + ! Since u_a and u_b are both bounded, this will perserve uniformity but will the + ! sum be bounded? Emperically it seems to work... + average = 0.5 * ( u_a + u_b ) + +end function average + +!> Deallocate the PLM reconstruction +subroutine destroy(this) + class(PLM_CW), intent(inout) :: this !< This reconstruction + + deallocate( this%u_mean, this%ul, this%ur ) + +end subroutine destroy + +!> Checks the PLM_CW reconstruction for consistency +logical function check_reconstruction(this, h, u) + class(PLM_CW), intent(in) :: this !< This reconstruction + real, intent(in) :: h(*) !< Grid spacing (thickness) [typically H] + real, intent(in) :: u(*) !< Cell mean values [A] + ! Local variables + integer :: k + + check_reconstruction = .false. + + do k = 1, this%n + if ( abs( this%u_mean(k) - u(k) ) > 0. ) check_reconstruction = .true. + enddo + + ! Check the cell reconstruction is monotonic within each cell (it should be as a straight line) + do k = 1, this%n + if ( ( this%u_mean(k) - this%ul(k) ) * ( this%ur(k) - this%u_mean(k) ) < 0. ) check_reconstruction = .true. + enddo + + ! Check the cell is a straight line (to within machine precision) + do k = 1, this%n + if ( abs(2. * this%u_mean(k) - ( this%ul(k) + this%ur(k) )) > epsilon(this%u_mean(1)) * & + max(abs(2. * this%u_mean(k)), abs(this%ul(k)), abs(this%ur(k))) ) check_reconstruction = .true. + enddo + + ! Check bounding of right edges, w.r.t. the cell means + do K = 1, this%n-1 + if ( ( this%ur(k) - this%u_mean(k) ) * ( this%u_mean(k+1) - this%ur(k) ) < 0. ) check_reconstruction = .true. + enddo + + ! Check bounding of left edges, w.r.t. the cell means + do K = 2, this%n + if ( ( this%u_mean(k) - this%ul(k) ) * ( this%ul(k) - this%u_mean(k-1) ) < 0. ) check_reconstruction = .true. + enddo + + ! PLM is not globally monotonic (expected) + +! ! Check bounding of right edges, w.r.t. this cell mean and the next cell left edge +! do K = 1, this%n-1 +! if ( ( this%ur(k) - this%u_mean(k) ) * ( this%ul(k+1) - this%ur(k) ) < 0. ) check_reconstruction = .true. +! enddo + +! ! Check bounding of left edges, w.r.t. this cell mean and the previous cell right edge +! do K = 2, this%n +! if ( ( this%u_mean(k) - this%ul(k) ) * ( this%ul(k) - this%ur(k-1) ) < 0. ) check_reconstruction = .true. +! enddo + +end function check_reconstruction + +!> Runs PLM reconstruction unit tests and returns True for any fails, False otherwise +logical function unit_tests(this, verbose, stdout, stderr) + class(PLM_CW), intent(inout) :: this !< This reconstruction + logical, intent(in) :: verbose !< True, if verbose + integer, intent(in) :: stdout !< I/O channel for stdout + integer, intent(in) :: stderr !< I/O channel for stderr + ! Local variables + real, allocatable :: ul(:), ur(:), um(:) ! test values [A] + real, allocatable :: ull(:), urr(:) ! test values [A] + type(testing) :: test ! convenience functions + integer :: k + + call test%set( stdout=stdout ) ! Sets the stdout channel in test + call test%set( stderr=stderr ) ! Sets the stderr channel in test + call test%set( verbose=verbose ) ! Sets the verbosity flag in test + + call this%init(3) + call test%test( this%n /= 3, 'Setting number of levels') + allocate( um(3), ul(3), ur(3), ull(3), urr(3) ) + + call this%reconstruct( (/2.,2.,2./), (/1.,3.,5./) ) + call test%real_arr(3, this%u_mean, (/1.,3.,5./), 'Setting cell values') + + do k = 1, 3 + ul(k) = this%f(k, 0.) + um(k) = this%f(k, 0.5) + ur(k) = this%f(k, 1.) + enddo + call test%real_arr(3, ul, (/1.,2.,5./), 'Evaluation on left edge') + call test%real_arr(3, um, (/1.,3.,5./), 'Evaluation in center') + call test%real_arr(3, ur, (/1.,4.,5./), 'Evaluation on right edge') + + do k = 1, 3 + ul(k) = this%dfdx(k, 0.) + um(k) = this%dfdx(k, 0.5) + ur(k) = this%dfdx(k, 1.) + enddo + call test%real_arr(3, ul, (/0.,2.,0./), 'dfdx on left edge') + call test%real_arr(3, um, (/0.,2.,0./), 'dfdx in center') + call test%real_arr(3, ur, (/0.,2.,0./), 'dfdx on right edge') + + do k = 1, 3 + um(k) = this%average(k, 0.5, 0.75) ! Average from x=0.25 to 0.75 in each cell + enddo + call test%real_arr(3, um, (/1.,3.25,5./), 'Return interval average') + + call this%destroy() + deallocate( um, ul, ur, ull, urr ) + + allocate( um(4), ul(4), ur(4) ) + call this%init(4) + + ! These values lead to non-monotonic reconstuctions which are + ! valid for transport problems but not always appropriate for + ! remapping to arbitrary resolution grids. + ! The O(h^2) slopes are -, 2, 2, - and the limited + ! slopes are 0, 1, 1, 0 so the everywhere the reconstructions + ! are bounded by neighbors but ur(2) and ul(3) are out-of-order. + call this%reconstruct( (/1.,1.,1.,1./), (/0.,3.,4.,7./) ) + do k = 1, 4 + ul(k) = this%f(k, 0.) + ur(k) = this%f(k, 1.) + enddo + call test%real_arr(4, ul, (/0.,2.,3.,7./), 'Evaluation on left edge') + call test%real_arr(4, ur, (/0.,4.,5.,7./), 'Evaluation on right edge') + + deallocate( um, ul, ur ) + + unit_tests = test%summarize('PLM_CW:unit_tests') + +end function unit_tests + +!> \namespace recon1d_plm_cw +!! + +end module Recon1d_PLM_CW diff --git a/src/ALE/Recon1d_PLM_CWK.F90 b/src/ALE/Recon1d_PLM_CWK.F90 new file mode 100644 index 0000000000..b30af80aa1 --- /dev/null +++ b/src/ALE/Recon1d_PLM_CWK.F90 @@ -0,0 +1,121 @@ +!> Piecewise Linear Method 1D reconstruction +!! +!! This implementation of PLM follows Colella and Woodward, 1984, except for assuming +!! uniform cell thicknesses. Cells resort to PCM for extrema including first and last cells in column. +!! The cell-wise reconstructions are limited so that the edge values (which are also the +!! extrema in a cell) are bounded by the neighbor cell means. However, this does not yield +!! monotonic profiles for the whole column. +!! +!! Note that internally the edge values, rather than the PLM slope, are stored to ensure +!! resulting calculations are properly bounded. +module Recon1d_PLM_CWK + +! This file is part of MOM6. See LICENSE.md for the license. + +use Recon1d_type, only : testing +use Recon1d_PLM_CW, only : PLM_CW + +implicit none ; private + +public PLM_CWK, testing + +!> PLM reconstruction following Colella and Woodward, 1984 +!! +!! Implemented by extending recon1d_plm_cw. +!! +!! The source for the methods ultimately used by this class are: +!! - init() -> recon1d_plm_cw.init() +!! - reconstruct() *locally defined +!! - average() -> recon1d_plm_cw.average() +!! - f() -> recon1d_plm_cw.f() +!! - dfdx() -> recon1d_plm_cw.dfdx() +!! - check_reconstruction() -> recon1d_plm_cw.check_reconstruction() +!! - unit_tests() -> recon1d_plm_cw.unit_tests() +!! - destroy() -> recon1d_plm_cw.destroy() +!! - remap_to_sub_grid() -> recon1d_type.remap_to_sub_grid() +!! - init_parent() -> init() +!! - reconstruct_parent() -> reconstruct() +type, extends (PLM_CW) :: PLM_CWK + +contains + !> Implementation of the PLM_CWK reconstruction + procedure :: reconstruct => reconstruct + +end type PLM_CWK + +contains + +!> Calculate a 1D PLM reconstructions based on h(:) and u(:) +subroutine reconstruct(this, h, u) + class(PLM_CWK), intent(inout) :: this !< This reconstruction + real, intent(in) :: h(*) !< Grid spacing (thickness) [typically H] + real, intent(in) :: u(*) !< Cell mean values [A] + ! Local variables + real :: slp ! The PLM slopes (difference across cell) [A] + real :: sigma_l, sigma_c, sigma_r ! Left, central and right slope estimates as + ! differences across the cell [A] + real :: u_min, u_max ! Minimum and maximum value across cell [A] + real :: u_l, u_r, u_c ! Left, right, and center values [A] + integer :: k, n + + n = this%n + + ! Loop over all cells + do k = 1, n + this%u_mean(k) = u(k) + enddo + + ! Boundary cells use PCM + this%ul(1) = u(1) + this%ur(1) = u(1) + + ! Loop over interior cells + do k = 2, n-1 + u_l = u(k-1) + u_c = u(k) + u_r = u(k+1) + + ! Side differences + sigma_r = u_r - u_c + sigma_l = u_c - u_l + + ! This is the second order slope given by equation 1.7 of + ! Piecewise Parabolic Method, Colella and Woodward (1984), + ! but for uniform resolution. + sigma_c = 0.5 * ( u_r - u_l ) + + ! Limit slope so that reconstructions are bounded by neighbors + u_min = min( u_l, u_c, u_r ) + u_max = max( u_l, u_c, u_r ) + + if ( (sigma_l * sigma_r) > 0.0 ) then + ! This limits the slope so that the edge values are bounded by the two cell averages spanning the edge + slp = sign( min( abs(sigma_c), 2.*min( u_c - u_min, u_max - u_c ) ), sigma_c ) + else + ! Extrema in the mean values require a PCM reconstruction + slp = 0.0 + endif + + ! Left edge + u_min = min( u_c, u_l ) + u_max = max( u_c, u_l ) + u_l = u_c - 0.5 * slp + this%ul(k) = max( min( u_l, u_max), u_min ) + + ! Right edge + u_min = min( u_c, u_r ) + u_max = max( u_c, u_r ) + u_r = u_c + 0.5 * slp + this%ur(k) = max( min( u_r, u_max), u_min ) + enddo + + ! Boundary cells use PCM + this%ul(n) = u(n) + this%ur(n) = u(n) + +end subroutine reconstruct + +!> \namespace recon1d_plm_cwk +!! + +end module Recon1d_PLM_CWK diff --git a/src/ALE/Recon1d_PLM_hybgen.F90 b/src/ALE/Recon1d_PLM_hybgen.F90 new file mode 100644 index 0000000000..0cf2e8e001 --- /dev/null +++ b/src/ALE/Recon1d_PLM_hybgen.F90 @@ -0,0 +1,395 @@ +!> Piecewise Linear Method 1D reconstruction ported from "hybgen" module in Hycom. +!! +!! This implementation of PLM follows Colella and Woodward, 1984, with cells resorting to PCM for +!! extrema including first and last cells in column. The cell-wise reconstructions are limited so +!! that the edge values (which are also the extrema in a cell) are bounded by the neighbors. The +!! limiter yields monotonicity for the CFL<1 transport problem where parts of a cell can only move +!! to a neighboring cell, but does not yield monotonic profiles for the general remapping problem. +!! The first and last cells are always limited to PCM. +!! +!! The mom_hybgen_remap.hybgen_plm_coefs() function calculates PLM coefficients numerically +!! equiavalent to the recon1d_plm_hybgen module (this implementation). +module Recon1d_PLM_hybgen + +! This file is part of MOM6. See LICENSE.md for the license. + +use Recon1d_type, only : Recon1d, testing + +implicit none ; private + +public PLM_hybgen, testing + +!> PLM reconstruction following "hybgen". +!! +!! This implementation is a refactor of hybgen_plm_coefs() from mom_hybgen_remap. +!! +!! The source for the methods ultimately used by this class are: +!! - init() *locally defined +!! - reconstruct() *locally defined +!! - average() *locally defined +!! - f() *locally defined +!! - dfdx() *locally defined +!! - check_reconstruction() *locally defined +!! - unit_tests() *locally defined +!! - destroy() *locally defined +!! - remap_to_sub_grid() -> recon1d_type.remap_to_sub_grid() +!! - init_parent() -> init() +!! - reconstruct_parent() -> reconstruct() +type, extends (Recon1d) :: PLM_hybgen + + real, allocatable :: ul(:) !< Left edge value [A] + real, allocatable :: ur(:) !< Right edge value [A] + real, allocatable :: slp(:) !< Right minus left edge values [A] + +contains + !> Implementation of the PLM_hybgen initialization + procedure :: init => init + !> Implementation of the PLM_hybgen reconstruction + procedure :: reconstruct => reconstruct + !> Implementation of the PLM_hybgen average over an interval [A] + procedure :: average => average + !> Implementation of evaluating the PLM_hybgen reconstruction at a point [A] + procedure :: f => f + !> Implementation of the derivative of the PLM_hybgen reconstruction at a point [A] + procedure :: dfdx => dfdx + !> Implementation of deallocation for PLM_hybgen + procedure :: destroy => destroy + !> Implementation of check reconstruction for the PLM_hybgen reconstruction + procedure :: check_reconstruction => check_reconstruction + !> Implementation of unit tests for the PLM_hybgen reconstruction + procedure :: unit_tests => unit_tests + + !> Duplicate interface to init() + procedure :: init_parent => init + !> Duplicate interface to reconstruct() + procedure :: reconstruct_parent => reconstruct + +end type PLM_hybgen + +contains + +!> Initialize a 1D PLM reconstruction for n cells +subroutine init(this, n, h_neglect, check) + class(PLM_hybgen), intent(out) :: this !< This reconstruction + integer, intent(in) :: n !< Number of cells in this column + real, optional, intent(in) :: h_neglect !< A negligibly small width used in cell reconstructions [H] + logical, optional, intent(in) :: check !< If true, enable some consistency checking + + this%n = n + + allocate( this%u_mean(n) ) + allocate( this%ul(n) ) + allocate( this%ur(n) ) + allocate( this%slp(n) ) + + this%h_neglect = tiny( this%u_mean(1) ) + if (present(h_neglect)) this%h_neglect = h_neglect + this%check = .false. + if (present(check)) this%check = check + +end subroutine init + +!> Calculate a 1D PLM reconstructions based on h(:) and u(:) +subroutine reconstruct(this, h, u) + class(PLM_hybgen), intent(inout) :: this !< This reconstruction + real, intent(in) :: h(*) !< Grid spacing (thickness) [typically H] + real, intent(in) :: u(*) !< Cell mean values [A] + ! Local variables + real :: slp ! The PLM slopes (difference across cell) [A] + real :: sigma_l, sigma_c, sigma_r ! Left, central and right slope estimates as + ! differences across the cell [A] + real :: u_min, u_max ! Minimum and maximum value across cell [A] + real :: u_l, u_r, u_c ! Left, right, and center values [A] + real :: h_l, h_c, h_r ! Thickness of left, center and right cells [H] + real :: h_c0 ! Thickness of center with h_neglect added [H] + integer :: k, n + + n = this%n + + ! Loop over all cells + do k = 1, n + this%u_mean(k) = u(k) + enddo + + ! Boundary cells use PCM + this%ul(1) = u(1) + this%ur(1) = u(1) + this%slp(1) = 0. + + ! Loop over interior cells + do k = 2, n-1 + u_l = u(k-1) + u_c = u(k) + u_r = u(k+1) + + ! Side differences + sigma_r = u_r - u_c + sigma_l = u_c - u_l + + h_l = h(k-1) + h_c = h(k) + h_r = h(k+1) + ! Avoids division by zero + h_c0 = h_c + this%h_neglect + + ! This is the second order slope given by equation 1.7 of + ! Piecewise Parabolic Method, Colella and Woodward (1984), + ! http://dx.doi.org/10.1016/0021-991(84)90143-8. + ! For uniform resolution it simplifies to ( u_r - u_l )/2 . + sigma_c = ( h_c / ( h_c0 + ( h_l + h_r ) ) ) * ( & + ( 2.*h_l + h_c ) / ( h_r + h_c0 ) * sigma_r & + + ( 2.*h_r + h_c ) / ( h_l + h_c0 ) * sigma_l ) + if (h_c <= this%h_neglect) then + sigma_c = 0. + else + sigma_c = ( h_c / ( h_c + 0.5 * ( h_l + h_r ) ) ) * ( u_r - u_l ) + endif + + ! Limit slope so that reconstructions are bounded by neighbors + u_min = min( u_l, u_c, u_r ) + u_max = max( u_l, u_c, u_r ) + + if ( (sigma_l * sigma_r) > 0.0 ) then + ! This limits the slope so that the edge values are bounded by the two cell averages spanning the edge + slp = sign( min( abs(sigma_c), 2.*min( u_c - u_min, u_max - u_c ) ), sigma_c ) +! slp = sign( min( abs(sigma_c), 2. * abs(u_c - u_l), 2. * abs(u_r - u_c) ), sigma_c ) + else + ! Extrema in the mean values require a PCM reconstruction + slp = 0.0 + endif + this%slp(k) = slp + + ! Left edge + u_min = min( u_c, u_l ) + u_max = max( u_c, u_l ) + u_l = u_c - 0.5 * slp + this%ul(k) = max( min( u_l, u_max), u_min ) + this%ul(k) = u_l + + ! Right edge + u_min = min( u_c, u_r ) + u_max = max( u_c, u_r ) + u_r = u_c + 0.5 * slp + this%ur(k) = max( min( u_r, u_max), u_min ) + this%ur(k) = u_r + enddo + + ! Boundary cells use PCM + this%ul(n) = u(n) + this%ur(n) = u(n) + this%slp(n) = 0. + +end subroutine reconstruct + +!> Value of PLM_hybgen reconstruction at a point in cell k [A] +real function f(this, k, x) + class(PLM_hybgen), intent(in) :: this !< This reconstruction + integer, intent(in) :: k !< Cell number + real, intent(in) :: x !< Non-dimensional position within element [nondim] + real :: xc ! Bounded version of x [nondim] + real :: du ! Difference across cell [A] + real :: u_a, u_b ! Two estimate of f [A] + + du = this%ur(k) - this%ul(k) + xc = max( 0., min( 1., x ) ) + + ! This expression for u_a can overshoot u_r but is good for x<<1 + u_a = this%ul(k) + du * xc + ! This expression for u_b can overshoot u_l but is good for 1-x<<1 + u_b = this%ur(k) + du * ( xc - 1. ) + + ! Since u_a and u_b are both bounded, this will perserve uniformity + f = 0.5 * ( u_a + u_b ) + +end function f + +!> Derivative of PLM_hybgen reconstruction at a point in cell k [A] +real function dfdx(this, k, x) + class(PLM_hybgen), intent(in) :: this !< This reconstruction + integer, intent(in) :: k !< Cell number + real, intent(in) :: x !< Non-dimensional position within element [nondim] + + dfdx = this%ur(k) - this%ul(k) + +end function dfdx + +!> Average between xa and xb for cell k of a 1D PLM reconstruction [A] +real function average(this, k, xa, xb) + class(PLM_hybgen), intent(in) :: this !< This reconstruction + integer, intent(in) :: k !< Cell number + real, intent(in) :: xa !< Start of averaging interval on element (0 to 1) + real, intent(in) :: xb !< End of averaging interval on element (0 to 1) + real :: xmab ! Mid-point between xa and xb (0 to 1) +! real :: u_a, u_b ! Values at xa and xb [A] + + ! This form is not guaranteed to be bounded by {ul,ur} +! u_a = this%ul(k) * ( 1. - xa ) + this%ur(k) * xa +! u_b = this%ul(k) * ( 1. - xb ) + this%ur(k) * xb +! average = 0.5 * ( u_a + u_b ) + + ! Mid-point between xa and xb + xmab = 0.5 * ( xa + xb ) + + ! The following expression is exact at xmab=0 and xmab=1, + ! i.e. gives the numerically correct values. + ! It is not obvious that the expression is monotonic but according to + ! https://math.stackexchange.com/questions/907329/accurate-floating-point-linear-interpolation + ! it will be for the default rounding behavior. Otherwise is it + ! then possible this expression can be outside the range of ul and ur? +! average = this%ul(k) * ( 1. - xmab ) + this%ur(k) * xmab + ! Emperically it fails the uniform value test + + ! The following is more complicated but seems to ensure being within bounds. + ! This expression for u_a can overshoot u_r but is good for xmab<<1 +! u_a = this%ul(k) + ( this%ur(k) - this%ul(k) ) * xmab + ! This expression for u_b can overshoot u_l but is good for 1-xmab<<1 +! u_b = this%ur(k) + ( this%ul(k) - this%ur(k) ) * ( 1. - xmab ) + ! Replace xmab with -1 for xmab<0.5, 1 for xmab>=0.5 +! xmab = sign(1., xmab-0.5) + ! Select either u_a or u_b, depending whether mid-point of xa, xb is smaller/larger than 0.5 +! average = xmab * u_b + ( 1. - xmab ) * u_a + + ! Since u_a and u_b are both bounded, this will perserve uniformity but will the + ! sum be bounded? Emperically it seems to work... +! average = 0.5 * ( u_a + u_b ) + + ! This expression is equivalent to integrating the polynomial form of the PLM reconstruction + average = this%ul(k) + xmab * this%slp(k) + +end function average + +!> Deallocate the PLM reconstruction +subroutine destroy(this) + class(PLM_hybgen), intent(inout) :: this !< This reconstruction + + deallocate( this%u_mean, this%ul, this%ur ) + +end subroutine destroy + +!> Checks the PLM_hybgen reconstruction for consistency +logical function check_reconstruction(this, h, u) + class(PLM_hybgen), intent(in) :: this !< This reconstruction + real, intent(in) :: h(*) !< Grid spacing (thickness) [typically H] + real, intent(in) :: u(*) !< Cell mean values [A] + ! Local variables + integer :: k + + check_reconstruction = .false. + + do k = 1, this%n + if ( abs( this%u_mean(k) - u(k) ) > 0. ) check_reconstruction = .true. + enddo + + ! Check the cell reconstruction is monotonic within each cell (it should be as a straight line) + do k = 1, this%n + if ( ( this%u_mean(k) - this%ul(k) ) * ( this%ur(k) - this%u_mean(k) ) < 0. ) check_reconstruction = .true. + enddo + + ! Check the cell is a straight line (to within machine precision) + do k = 1, this%n + if ( abs(2. * this%u_mean(k) - ( this%ul(k) + this%ur(k) )) > epsilon(this%u_mean(1)) * & + max(abs(2. * this%u_mean(k)), abs(this%ul(k)), abs(this%ur(k))) ) check_reconstruction = .true. + enddo + +! The following test fails MOM_remapping:test_recon_consistency with Intel/2023.2.0 on gaea at iter=84 +! ! Check bounding of right edges, w.r.t. the cell means +! do K = 1, this%n-1 +! if ( ( this%ur(k) - this%u_mean(k) ) * ( this%u_mean(k+1) - this%ur(k) ) < 0. ) check_reconstruction = .true. +! enddo + +! The following test fails MOM_remapping:test_recon_consistency with Intel/2023.2.0 on gaea at iter=161 +! ! Check bounding of left edges, w.r.t. the cell means +! do K = 2, this%n +! if ( ( this%u_mean(k) - this%ul(k) ) * ( this%ul(k) - this%u_mean(k-1) ) < 0. ) check_reconstruction = .true. +! enddo + + ! PLM is not globally monotonic so the following are expected to fail + +! ! Check bounding of right edges, w.r.t. this cell mean and the next cell left edge +! do K = 1, this%n-1 +! if ( ( this%ur(k) - this%u_mean(k) ) * ( this%ul(k+1) - this%ur(k) ) < 0. ) check_reconstruction = .true. +! enddo + +! ! Check bounding of left edges, w.r.t. this cell mean and the previous cell right edge +! do K = 2, this%n +! if ( ( this%u_mean(k) - this%ul(k) ) * ( this%ul(k) - this%ur(k-1) ) < 0. ) check_reconstruction = .true. +! enddo + +end function check_reconstruction + +!> Runs PLM reconstruction unit tests and returns True for any fails, False otherwise +logical function unit_tests(this, verbose, stdout, stderr) + class(PLM_hybgen), intent(inout) :: this !< This reconstruction + logical, intent(in) :: verbose !< True, if verbose + integer, intent(in) :: stdout !< I/O channel for stdout + integer, intent(in) :: stderr !< I/O channel for stderr + ! Local variables + real, allocatable :: ul(:), ur(:), um(:) ! test values [A] + real, allocatable :: ull(:), urr(:) ! test values [A] + type(testing) :: test ! convenience functions + integer :: k + + call test%set( stdout=stdout ) ! Sets the stdout channel in test + call test%set( stderr=stderr ) ! Sets the stderr channel in test + call test%set( verbose=verbose ) ! Sets the verbosity flag in test + + call this%init(3) + call test%test( this%n /= 3, 'Setting number of levels') + allocate( um(3), ul(3), ur(3), ull(3), urr(3) ) + + call this%reconstruct( (/2.,2.,2./), (/1.,3.,5./) ) + call test%real_arr(3, this%u_mean, (/1.,3.,5./), 'Setting cell values') + + do k = 1, 3 + ul(k) = this%f(k, 0.) + um(k) = this%f(k, 0.5) + ur(k) = this%f(k, 1.) + enddo + call test%real_arr(3, ul, (/1.,2.,5./), 'Evaluation on left edge') + call test%real_arr(3, um, (/1.,3.,5./), 'Evaluation in center') + call test%real_arr(3, ur, (/1.,4.,5./), 'Evaluation on right edge') + + do k = 1, 3 + ul(k) = this%dfdx(k, 0.) + um(k) = this%dfdx(k, 0.5) + ur(k) = this%dfdx(k, 1.) + enddo + call test%real_arr(3, ul, (/0.,2.,0./), 'dfdx on left edge') + call test%real_arr(3, um, (/0.,2.,0./), 'dfdx in center') + call test%real_arr(3, ur, (/0.,2.,0./), 'dfdx on right edge') + + do k = 1, 3 + um(k) = this%average(k, 0.5, 0.75) ! Average from x=0.25 to 0.75 in each cell + enddo + call test%real_arr(3, um, (/1.,3.25,5./), 'Return interval average') + + call this%destroy() + deallocate( um, ul, ur, ull, urr ) + + allocate( um(4), ul(4), ur(4) ) + call this%init(4) + + ! These values lead to non-monotonic reconstuctions which are + ! valid for transport problems but not always appropriate for + ! remapping to arbitrary resolution grids. + ! The O(h^2) slopes are -, 2, 2, - and the limited + ! slopes are 0, 1, 1, 0 so the everywhere the reconstructions + ! are bounded by neighbors but ur(2) and ul(3) are out-of-order. + call this%reconstruct( (/1.,1.,1.,1./), (/0.,3.,4.,7./) ) + do k = 1, 4 + ul(k) = this%f(k, 0.) + ur(k) = this%f(k, 1.) + enddo + call test%real_arr(4, ul, (/0.,2.,3.,7./), 'Evaluation on left edge') + call test%real_arr(4, ur, (/0.,4.,5.,7./), 'Evaluation on right edge') + + deallocate( um, ul, ur ) + + unit_tests = test%summarize('PLM_hybgen:unit_tests') + +end function unit_tests + +!> \namespace recon1d_plm_hybgen +!! + +end module Recon1d_PLM_hybgen diff --git a/src/ALE/Recon1d_PPM_CW.F90 b/src/ALE/Recon1d_PPM_CW.F90 new file mode 100644 index 0000000000..9523ad46ea --- /dev/null +++ b/src/ALE/Recon1d_PPM_CW.F90 @@ -0,0 +1,420 @@ +!> Piecewise Parabolic Method 1D reconstruction following Colella and Woodward, 1984 +!! +!! This is a near faithful implementation of PPM following Colella and Woodward, 1984, with +!! cells resorting to PCM for extrema including first and last cells in column. The +!! only exception is that the PLM slopes used for edge interpolation are not set to zero +!! for the first and last cells, but are side-differenced. This improves accuracy of edge +!! values near boundaries and reduces the adverse influence of the boundaries on the +!! interior reconstructions. The final PPM reconstruction in the first and last cells are +!! set to PCM. The reconstructions are grid-spacing dependent, and so quasi-forth order in h. +module Recon1d_PPM_CW + +! This file is part of MOM6. See LICENSE.md for the license. + +use Recon1d_type, only : Recon1d, testing +use Recon1d_PLM_CW, only : PLM_CW + +implicit none ; private + +public PPM_CW, testing + +!> PPM reconstruction following Colella and Woordward, 1984. +!! +!! The source for the methods ultimately used by this class are: +!! - init() *locally defined +!! - reconstruct() *locally defined +!! - average() *locally defined +!! - f() *locally defined +!! - dfdx() *locally defined +!! - check_reconstruction() *locally defined +!! - unit_tests() *locally defined +!! - destroy() *locally defined +!! - remap_to_sub_grid() -> recon1d_type.remap_to_sub_grid() +!! - init_parent() -> init() +!! - reconstruct_parent() -> reconstruct() +type, extends (Recon1d) :: PPM_CW + + real, allocatable :: ul(:) !< Left edge value [A] + real, allocatable :: ur(:) !< Right edge value [A] + type(PLM_CW) :: PLM !< The PLM reconstruction used to estimate edge values + +contains + !> Implementation of the PPM_CW initialization + procedure :: init => init + !> Implementation of the PPM_CW reconstruction + procedure :: reconstruct => reconstruct + !> Implementation of the PPM_CW average over an interval [A] + procedure :: average => average + !> Implementation of evaluating the PPM_CW reconstruction at a point [A] + procedure :: f => f + !> Implementation of the derivative of the PPM_CW reconstruction at a point [A] + procedure :: dfdx => dfdx + !> Implementation of deallocation for PPM_CW + procedure :: destroy => destroy + !> Implementation of check reconstruction for the PPM_CW reconstruction + procedure :: check_reconstruction => check_reconstruction + !> Implementation of unit tests for the PPM_CW reconstruction + procedure :: unit_tests => unit_tests + + !> Duplicate interface to init() + procedure :: init_parent => init + !> Duplicate interface to reconstruct() + procedure :: reconstruct_parent => reconstruct + +end type PPM_CW + +contains + +!> Initialize a 1D PPM_CW reconstruction for n cells +subroutine init(this, n, h_neglect, check) + class(PPM_CW), intent(out) :: this !< This reconstruction + integer, intent(in) :: n !< Number of cells in this column + real, optional, intent(in) :: h_neglect !< A negligibly small width used in cell reconstructions [H] + logical, optional, intent(in) :: check !< If true, enable some consistency checking + + this%n = n + + allocate( this%u_mean(n) ) + allocate( this%ul(n) ) + allocate( this%ur(n) ) + + ! This incurs an extra store of u_mean but by using PCM_CW + ! we avoid duplicating and testing more code + call this%PLM%init( n, h_neglect=h_neglect, check=check ) + + this%h_neglect = tiny( this%u_mean(1) ) + if (present(h_neglect)) this%h_neglect = h_neglect + this%check = .false. + if (present(check)) this%check = check + +end subroutine init + +!> Calculate a 1D PPM_CW reconstructions based on h(:) and u(:) +subroutine reconstruct(this, h, u) + class(PPM_CW), intent(inout) :: this !< This reconstruction + real, intent(in) :: h(*) !< Grid spacing (thickness) [typically H] + real, intent(in) :: u(*) !< Cell mean values [A] + ! Local variables + real :: h0, h1, h2, h3 ! Cell thickness h(k-2), h(k-1), h(k), h(k+1) in K loop [H] + real :: d12 ! h1 + h2 but used in the denominator so include h_neglect [H] + real :: h01_h112, h23_h122 ! Approximately 2/3 [nondim] + real :: ddh ! Approximately 0 [nondim] + real :: I_h12, I_h0123 ! Reciprocals of d12 and sum(h) [H-1] + real :: dul, dur ! Left and right cell PLM slopes [A] + real :: u0, u1, u2 ! Far left, left, and right cell values [A] + real :: edge ! Edge value between cell k-1 and k [A] + real :: u_min, u_max ! Minimum and maximum value across edge [A] + real :: a6 ! Colella and Woodward curvature [A] + real :: du ! Difference between edges across cell [A] + real :: slp(this%n) ! PLM slope [A] + integer :: k, n + + n = this%n + + ! First populate the PLM reconstructions + call this%PLM%reconstruct( h, u ) + do k = 1, n + slp(k) = this%PLM%ur(k) - this%PLM%ul(k) + enddo + ! Extrapolate from interior for boundary PLM slopes + ! Note: this is not conventional but helps retain accuracy near top/bottom + ! boundaries and reduces the adverse influence of the boundaries in the interior + ! reconstructions. The final PPM reconstruction is still bounded to PCM. + slp(1) = 2.0 * ( this%PLM%ul(2) - u(1) ) + slp(n) = 2.0 * ( u(n) - this%PLM%ur(n-1) ) + + do K = 2, n ! K=2 is interface between cells 1 and 2 + h0 = h( max( 1, k-2 ) ) ! This treatment implies a virtual mirror cell at k=0 + h1 = h(k-1) + h2 = h(k) + h3 = h( min( n, k+1 ) ) ! This treatment implies a virtual mirror cell at k=n+1 + d12 = ( h1 + h2 ) + this%h_neglect ! d12 is only ever used in the denominator + h01_h112 = ( h0 + h1 ) / ( h1 + d12 ) ! When uniform -> 2/3 + h23_h122 = ( h2 + h3 ) / ( d12 + h2 ) ! When uniform -> 2/3 + ddh = h01_h112 - h23_h122 ! When uniform -> 0 + I_h12 = 1.0 / d12 ! When uniform -> 1/(2h) + I_h0123 = 1.0 / ( d12 + ( h0 + h3 ) ) ! When uniform -> 1/(4h) + dul = slp(k-1) + dur = slp(k) + u2 = u(k) + u1 = u(k-1) + edge = I_h12 * ( h2 * u1 + h1 * u2 ) & ! 1/2 u1 + 1/2 u2 + + I_h0123 * ( 2.0 * h1 * h2 * I_h12 * ddh * ( u2 - u1 ) & ! 0 + + ( h2 * h23_h122 * dul - h1 * h01_h112 * dur ) ) ! 1/6 dul - 1/6 dur + u_min = min( u1, u2 ) + u_max = max( u1, u2 ) + edge = max( min( edge, u_max), u_min ) ! Unclear if we need this bounding in the interior + this%ur(k-1) = edge + this%ul(k) = edge + enddo + this%ul(1) = u(1) ! PCM + this%ur(1) = u(1) ! PCM + this%ur(n) = u(n) ! PCM + this%ul(n) = u(n) ! PCM + + do K = 2, n ! K=2 is interface between cells 1 and 2 + u0 = u(k-1) + u1 = u(k) + u2 = u(k+1) + a6 = 3.0 * ( ( u1 - this%ul(k) ) + ( u1 - this%ur(k) ) ) + du = this%ur(k) - this%ul(k) + if ( ( u2 - u1 ) * ( u1 - u0 ) <- 0.0 ) then ! Large scale extrema + this%ul(k) = u1 + this%ur(k) = u1 + elseif ( du * a6 > du * du ) then ! Extrema on right + ! edge = 3.0 * u1 - 2.0 * this%ur(k) ! OM4 era expressions is subject to round off + edge = u1 + 2.0 * ( u1 - this%ur(k) ) ! Passes consistency tests - AJA + ! The following bounds were applied in OM4 era schemes but are not needed now + ! u_min = min( u0, u1 ) + ! u_max = max( u0, u1 ) + ! edge = max( min( edge, u_max), u_min ) + this%ul(k) = edge + elseif ( du * a6 < - du * du ) then ! Extrema on left + ! edge = 3.0 * u1 - 2.0 * this%ul(k) ! OM4 era expressions is subject to round off + edge = u1 + 2.0 * ( u1 - this%ul(k) ) ! Passes consistency tests - AJA + ! The following bounds were applied in OM4 era schemes but are not needed now + ! u_min = min( u1, u2 ) + ! u_max = max( u1, u2 ) + ! edge = max( min( edge, u_max), u_min ) + this%ur(k) = edge + endif + enddo + + ! After the limiter, are ur and ul bounded???? -AJA + + ! Store mean + do k = 1, n + this%u_mean(k) = u(k) + enddo + +end subroutine reconstruct + +!> Value of PPM_CW reconstruction at a point in cell k [A] +real function f(this, k, x) + class(PPM_CW), intent(in) :: this !< This reconstruction + integer, intent(in) :: k !< Cell number + real, intent(in) :: x !< Non-dimensional position within element [nondim] + real :: xc ! Bounded version of x [nondim] + real :: du ! Difference across cell [A] + real :: a6 ! Collela and Woordward curvature parameter [A] + real :: u_a, u_b ! Two estimate of f [A] + real :: lmx ! 1 - x [nondim] + real :: wb ! Weight based on x [nondim] + + du = this%ur(k) - this%ul(k) + a6 = 3.0 * ( ( this%u_mean(k) - this%ul(k) ) + ( this%u_mean(k) - this%ur(k) ) ) + xc = max( 0., min( 1., x ) ) + lmx = 1.0 - xc + + ! This expression for u_a can overshoot u_r but is good for x<<1 + u_a = this%ul(k) + xc * ( du + a6 * lmx ) + ! This expression for u_b can overshoot u_l but is good for 1-x<<1 + u_b = this%ur(k) + lmx * ( - du + a6 * xc ) + + ! Since u_a and u_b are both side-bounded, using weights=0 or 1 will preserve uniformity + wb = 0.5 + sign(0.5, xc - 0.5 ) ! = 1 @ x=0, = 0 @ x=1 + f = ( ( 1. - wb ) * u_a ) + ( wb * u_b ) + +end function f + +!> Derivative of PPM_CW reconstruction at a point in cell k [A] +real function dfdx(this, k, x) + class(PPM_CW), intent(in) :: this !< This reconstruction + integer, intent(in) :: k !< Cell number + real, intent(in) :: x !< Non-dimensional position within element [nondim] + real :: xc ! Bounded version of x [nondim] + real :: du ! Difference across cell [A] + real :: a6 ! Collela and Woordward curvature parameter [A] + + du = this%ur(k) - this%ul(k) + a6 = 3.0 * ( ( this%u_mean(k) - this%ul(k) ) + ( this%u_mean(k) - this%ur(k) ) ) + xc = max( 0., min( 1., x ) ) + + dfdx = du + a6 * ( 2.0 * xc - 1.0 ) + +end function dfdx + +!> Average between xa and xb for cell k of a 1D PPM reconstruction [A] +real function average(this, k, xa, xb) + class(PPM_CW), intent(in) :: this !< This reconstruction + integer, intent(in) :: k !< Cell number + real, intent(in) :: xa !< Start of averaging interval on element (0 to 1) + real, intent(in) :: xb !< End of averaging interval on element (0 to 1) + real :: xapxb ! A sum of fracional positions [nondim] + real :: mx, Ya, Yb, my ! Various fractional positions [nondim] + real :: u_a, u_b ! Values at xa and xb [A] + real :: xa2pxb2, xa2b2ab, Ya2b2ab ! Sums of squared fractional positions [nondim] + real :: a_L, a_R, u_c, a_c ! Values of the polynomial at various locations [A] + + mx = 0.5 * ( xa + xb ) + a_L = this%ul(k) + a_R = this%ur(k) + u_c = this%u_mean(k) + a_c = 0.5 * ( ( u_c - a_L ) + ( u_c - a_R ) ) ! a_6 / 6 + if (mx<0.5) then + ! This integration of the PPM reconstruction is expressed in distances from the left edge + xa2b2ab = (xa * xa + xb * xb) + xa * xb + average = a_L + ( ( a_R - a_L ) * mx & + + a_c * ( 3. * ( xb + xa ) - 2. * xa2b2ab ) ) + else + ! This integration of the PPM reconstruction is expressed in distances from the right edge + Ya = 1. - xa + Yb = 1. - xb + my = 0.5 * ( Ya + Yb ) + Ya2b2ab = (Ya * Ya + Yb * Yb) + Ya * Yb + average = a_R + ( ( a_L - a_R ) * my & + + a_c * ( 3. * ( Yb + Ya ) - 2. * Ya2b2ab ) ) + endif + +end function average + +!> Deallocate the PPM_CW reconstruction +subroutine destroy(this) + class(PPM_CW), intent(inout) :: this !< This reconstruction + + deallocate( this%u_mean, this%ul, this%ur ) + +end subroutine destroy + +!> Checks the PPM_CW reconstruction for consistency +logical function check_reconstruction(this, h, u) + class(PPM_CW), intent(in) :: this !< This reconstruction + real, intent(in) :: h(*) !< Grid spacing (thickness) [typically H] + real, intent(in) :: u(*) !< Cell mean values [A] + ! Local variables + integer :: k + + check_reconstruction = .false. + + ! Simply checks the internal copy of "u" is exactly equal to "u" + do k = 1, this%n + if ( abs( this%u_mean(k) - u(k) ) > 0. ) check_reconstruction = .true. + enddo + + ! If (u - ul) has the opposite sign from (ur - u), then this cell has an interior extremum + do k = 1, this%n + if ( ( this%u_mean(k) - this%ul(k) ) * ( this%ur(k) - this%u_mean(k) ) < 0. ) check_reconstruction = .true. + enddo + + ! Check bounding of right edges, w.r.t. the cell means + do K = 1, this%n-1 + if ( ( this%ur(k) - this%u_mean(k) ) * ( this%u_mean(k+1) - this%ur(k) ) < 0. ) check_reconstruction = .true. + enddo + + ! Check bounding of left edges, w.r.t. the cell means + do K = 2, this%n + if ( ( this%u_mean(k) - this%ul(k) ) * ( this%ul(k) - this%u_mean(k-1) ) < 0. ) check_reconstruction = .true. + enddo + + ! Check bounding of right edges, w.r.t. this cell mean and the next cell left edge + do K = 1, this%n-1 + if ( ( this%ur(k) - this%u_mean(k) ) * ( this%ul(k+1) - this%ur(k) ) < 0. ) check_reconstruction = .true. + enddo + + ! Check bounding of left edges, w.r.t. this cell mean and the previous cell right edge + do K = 2, this%n + if ( ( this%u_mean(k) - this%ul(k) ) * ( this%ul(k) - this%ur(k-1) ) < 0. ) check_reconstruction = .true. + enddo + +end function check_reconstruction + +!> Runs PPM_CW reconstruction unit tests and returns True for any fails, False otherwise +logical function unit_tests(this, verbose, stdout, stderr) + class(PPM_CW), intent(inout) :: this !< This reconstruction + logical, intent(in) :: verbose !< True, if verbose + integer, intent(in) :: stdout !< I/O channel for stdout + integer, intent(in) :: stderr !< I/O channel for stderr + ! Local variables + real, allocatable :: ul(:), ur(:), um(:) ! test values [A] + real, allocatable :: ull(:), urr(:) ! test values [A] + type(testing) :: test ! convenience functions + integer :: k + + call test%set( stdout=stdout ) ! Sets the stdout channel in test + call test%set( stderr=stderr ) ! Sets the stderr channel in test + call test%set( verbose=verbose ) ! Sets the verbosity flag in test + + if (verbose) write(stdout,'(a)') 'PPM_CW:unit_tests testing with linear fn' + + call this%init(5) + call test%test( this%n /= 5, 'Setting number of levels') + allocate( um(5), ul(5), ur(5), ull(5), urr(5) ) + + ! Straight line, f(x) = x , or f(K) = 2*K + call this%reconstruct( (/2.,2.,2.,2.,2./), (/1.,4.,7.,10.,13./) ) + call test%real_arr(5, this%u_mean, (/1.,4.,7.,10.,13./), 'Setting cell values') + ! Without PLM extrapolation we get l(2)=2 and r(4)=12 due to PLM=0 in boundary cells. -AJA + call test%real_arr(5, this%ul, (/1.,2.5,5.5,8.5,13./), 'Left edge values') + call test%real_arr(5, this%ur, (/1.,5.5,8.5,11.5,13./), 'Right edge values') + + do k = 1, 5 + ul(k) = this%f(k, 0.) + um(k) = this%f(k, 0.5) + ur(k) = this%f(k, 1.) + enddo + call test%real_arr(5, ul, this%ul, 'Evaluation on left edge') + call test%real_arr(5, um, (/1.,4.,7.,10.,13./), 'Evaluation in center') + call test%real_arr(5, ur, this%ur, 'Evaluation on right edge') + + do k = 1, 5 + ul(k) = this%dfdx(k, 0.) + um(k) = this%dfdx(k, 0.5) + ur(k) = this%dfdx(k, 1.) + enddo + ! Most of these values are affected by the PLM boundary cells + call test%real_arr(5, ul, (/0.,3.,3.,3.,0./), 'dfdx on left edge') + call test%real_arr(5, um, (/0.,3.,3.,3.,0./), 'dfdx in center') + call test%real_arr(5, ur, (/0.,3.,3.,3.,0./), 'dfdx on right edge') + + do k = 1, 5 + um(k) = this%average(k, 0.5, 0.75) ! Average from x=0.25 to 0.75 in each cell + enddo + ! Most of these values are affected by the PLM boundary cells + call test%real_arr(5, um, (/1.,4.375,7.375,10.375,13./), 'Return interval average') + + if (verbose) write(stdout,'(a)') 'PPM_CW:unit_tests testing with parabola' + + ! x = 2 i i=0 at origin + ! f(x) = 3/4 x^2 = (2 i)^2 + ! f[i] = 3/4 ( 2 i - 1 )^2 on centers + ! f[I] = 3/4 ( 2 I )^2 on edges + ! f[i] = 1/8 [ x^3 ] for means + ! edges: 0, 1, 12, 27, 48, 75 + ! means: 1, 7, 19, 37, 61 + ! centers: 0.75, 6.75, 18.75, 36.75, 60.75 + call this%reconstruct( (/2.,2.,2.,2.,2./), (/1.,7.,19.,37.,61./) ) + do k = 1, 5 + ul(k) = this%f(k, 0.) + um(k) = this%f(k, 0.5) + ur(k) = this%f(k, 1.) + enddo + call test%real_arr(5, ul, (/1.,3.,12.,27.,61./), 'Return left edge') + call test%real_arr(5, um, (/1.,6.75,18.75,36.75,61./), 'Return center') + call test%real_arr(5, ur, (/1.,12.,27.,48.,61./), 'Return right edge') + + ! x = 3 i i=0 at origin + ! f(x) = x^2 / 3 = 3 i^2 + ! f[i] = [ ( 3 i )^3 - ( 3 i - 3 )^3 ] i=1,2,3,4,5 + ! means: 1, 7, 19, 37, 61 + ! edges: 0, 3, 12, 27, 48, 75 + call this%reconstruct( (/3.,3.,3.,3.,3./), (/1.,7.,19.,37.,61./) ) + do k = 1, 5 + ul(k) = this%f(k, 0.) + um(k) = this%f(k, 0.5) + ur(k) = this%f(k, 1.) + enddo + call test%real_arr(5, ul, (/1.,3.,12.,27.,61./), 'Return left edge') + call test%real_arr(5, um, (/1.,0.25*(6*7-15),0.25*(6*19-39),0.25*(6*37-75),61./), 'Return center') + call test%real_arr(5, ur, (/1.,12.,27.,48.,61./), 'Return right edge') + + call this%destroy() + deallocate( um, ul, ur, ull, urr ) + + unit_tests = test%summarize('PPM_CW:unit_tests') + +end function unit_tests + +!> \namespace recon1d_ppm_cw +!! + +end module Recon1d_PPM_CW diff --git a/src/ALE/Recon1d_PPM_CWK.F90 b/src/ALE/Recon1d_PPM_CWK.F90 new file mode 100644 index 0000000000..a0cbce5877 --- /dev/null +++ b/src/ALE/Recon1d_PPM_CWK.F90 @@ -0,0 +1,401 @@ +!> Piecewise Parabolic Method 1D reconstruction in model index space +!! +!! This implementation of PPM follows Colella and Woodward, 1984, using uniform thickness +!! and with cells resorting to PCM for local extrema including the first and last cells. +!! +!! "Fourth order" estimates of edge values use PLM also calculated in index space +!! (i.e. with no grid dependence). First and last PLM slopes are extrapolated. +!! Limiting follows Colella and Woodward thereafter. The high accuracy of this scheme is +!! realized only when the grid-spacing is exactly uniform. This scheme deviates from CW84 +!! when the grid spacing is variable. +module Recon1d_PPM_CWK + +! This file is part of MOM6. See LICENSE.md for the license. + +use Recon1d_type, only : Recon1d, testing +use Recon1d_PLM_CWK, only : PLM_CWK + +implicit none ; private + +public PPM_CWK, testing + +!> PPM reconstruction in index space (no grid dependence). +!! +!! The source for the methods ultimately used by this class are: +!! - init() *locally defined +!! - reconstruct() *locally defined +!! - average() *locally defined +!! - f() *locally defined +!! - dfdx() *locally defined +!! - check_reconstruction() *locally defined +!! - unit_tests() *locally defined +!! - destroy() *locally defined +!! - remap_to_sub_grid() -> recon1d_type.remap_to_sub_grid() +!! - init_parent() -> init() +!! - reconstruct_parent() -> reconstruct() +type, extends (Recon1d) :: PPM_CWK + + real, allocatable :: ul(:) !< Left edge value [A] + real, allocatable :: ur(:) !< Right edge value [A] + type(PLM_CWK) :: PLM !< The PLM reconstruction used to estimate edge values + +contains + !> Implementation of the PPM_CWK initialization + procedure :: init => init + !> Implementation of the PPM_CWK reconstruction + procedure :: reconstruct => reconstruct + !> Implementation of the PPM_CWK average over an interval [A] + procedure :: average => average + !> Implementation of evaluating the PPM_CWK reconstruction at a point [A] + procedure :: f => f + !> Implementation of the derivative of the PPM_CWK reconstruction at a point [A] + procedure :: dfdx => dfdx + !> Implementation of deallocation for PPM_CWK + procedure :: destroy => destroy + !> Implementation of check reconstruction for the PPM_CWK reconstruction + procedure :: check_reconstruction => check_reconstruction + !> Implementation of unit tests for the PPM_CWK reconstruction + procedure :: unit_tests => unit_tests + + !> Duplicate interface to init() + procedure :: init_parent => init + !> Duplicate interface to reconstruct() + procedure :: reconstruct_parent => reconstruct + +end type PPM_CWK + +contains + +!> Initialize a 1D PPM_CWK reconstruction for n cells +subroutine init(this, n, h_neglect, check) + class(PPM_CWK), intent(out) :: this !< This reconstruction + integer, intent(in) :: n !< Number of cells in this column + real, optional, intent(in) :: h_neglect !< A negligibly small width used in cell reconstructions [H] + logical, optional, intent(in) :: check !< If true, enable some consistency checking + + this%n = n + + allocate( this%u_mean(n) ) + allocate( this%ul(n) ) + allocate( this%ur(n) ) + + ! This incurs an extra store of u_mean but by using PCM_CW + ! we avoid duplicating and testing more code + call this%PLM%init( n, h_neglect=h_neglect, check=check ) + + this%h_neglect = tiny( this%u_mean(1) ) + if (present(h_neglect)) this%h_neglect = h_neglect + this%check = .false. + if (present(check)) this%check = check + +end subroutine init + +!> Calculate a 1D PPM_CWK reconstructions based on h(:) and u(:) +subroutine reconstruct(this, h, u) + class(PPM_CWK), intent(inout) :: this !< This reconstruction + real, intent(in) :: h(*) !< Grid spacing (thickness) [typically H] + real, intent(in) :: u(*) !< Cell mean values [A] + ! Local variables + real :: dul, dur ! Left and right cell PLM slopes [A] + real :: u0, u1, u2 ! Far left, left, and right cell values [A] + real :: edge ! Edge value between cell k-1 and k [A] + real :: u_min, u_max ! Minimum and maximum value across edge [A] + real :: a6 ! Colella and Woodward curvature [A] + real :: du ! Difference between edges across cell [A] + real :: slp(this%n) ! PLM slope [A] + real, parameter :: one_sixth = 1. / 6. ! 1/6 [nondim] + integer :: k, n + + n = this%n + + ! First populate the PLM (k-space) reconstructions + call this%PLM%reconstruct( h, u ) + do k = 1, n + slp(k) = this%PLM%ur(k) - this%PLM%ul(k) + enddo + ! Extrapolate from interior for boundary PLM slopes + ! Note: this is not conventional but helps retain accuracy near top/bottom + ! boudaries and reduces the adverse influence of the boudnaries int he interior + ! reconstructions. The final PPM reconstruction is still bounded to PCM. + slp(1) = 2.0 * ( this%PLM%ul(2) - u(1) ) + slp(n) = 2.0 * ( u(n) - this%PLM%ur(n-1) ) + + do K = 2, n ! K=2 is interface between cells 1 and 2 + dul = slp(k-1) + dur = slp(k) + u2 = u(k) + u1 = u(k-1) + edge = 0.5 * ( u1 + u2 ) + one_sixth * ( dul - dur ) ! Eq. 1.6 with uniform h + u_min = min( u1, u2 ) + u_max = max( u1, u2 ) + edge = max( min( edge, u_max), u_min ) ! Unclear if we need this bounding in the interior + this%ur(k-1) = edge + this%ul(k) = edge + enddo + this%ul(1) = u(1) ! PCM + this%ur(1) = u(1) ! PCM + this%ur(n) = u(n) ! PCM + this%ul(n) = u(n) ! PCM + + do K = 2, n ! K=2 is interface between cells 1 and 2 + u0 = u(k-1) + u1 = u(k) + u2 = u(k+1) + a6 = 3.0 * ( ( u1 - this%ul(k) ) + ( u1 - this%ur(k) ) ) + du = this%ur(k) - this%ul(k) + if ( ( u2 - u1 ) * ( u1 - u0 ) <- 0.0 ) then ! Large scale extrema + this%ul(k) = u1 + this%ur(k) = u1 + elseif ( du * a6 > du * du ) then ! Extrema on right + edge = u1 + 2.0 * ( u1 - this%ur(k) ) + ! u_min = min( u0, u1 ) + ! u_max = max( u0, u1 ) + ! edge = max( min( edge, u_max), u_min ) + this%ul(k) = edge + elseif ( du * a6 < - du * du ) then ! Extrema on left + edge = u1 + 2.0 * ( u1 - this%ul(k) ) + ! u_min = min( u1, u2 ) + ! u_max = max( u1, u2 ) + ! edge = max( min( edge, u_max), u_min ) + this%ur(k) = edge + endif + enddo + + ! After the limiter, are ur and ul bounded???? -AJA + + ! Store mean + do k = 1, n + this%u_mean(k) = u(k) + enddo + +end subroutine reconstruct + +!> Value of PPM_CWK reconstruction at a point in cell k [A] +real function f(this, k, x) + class(PPM_CWK), intent(in) :: this !< This reconstruction + integer, intent(in) :: k !< Cell number + real, intent(in) :: x !< Non-dimensional position within element [nondim] + real :: xc ! Bounded version of x [nondim] + real :: du ! Difference across cell [A] + real :: a6 ! Collela and Woordward curvature parameter [A] + real :: u_a, u_b ! Two estimate of f [A] + real :: lmx ! 1 - x [nondim] + real :: wb ! Weight based on x [nondim] + + du = this%ur(k) - this%ul(k) + a6 = 3.0 * ( ( this%u_mean(k) - this%ul(k) ) + ( this%u_mean(k) - this%ur(k) ) ) + xc = max( 0., min( 1., x ) ) + lmx = 1.0 - xc + + ! This expression for u_a can overshoot u_r but is good for x<<1 + u_a = this%ul(k) + xc * ( du + a6 * lmx ) + ! This expression for u_b can overshoot u_l but is good for 1-x<<1 + u_b = this%ur(k) + lmx * ( - du + a6 * xc ) + + ! Since u_a and u_b are both side-bounded, using weights=0 or 1 will preserve uniformity + wb = 0.5 + sign(0.5, xc - 0.5 ) ! = 1 @ x=0, = 0 @ x=1 + f = ( ( 1. - wb ) * u_a ) + ( wb * u_b ) + +end function f + +!> Derivative of PPM_CWK reconstruction at a point in cell k [A] +real function dfdx(this, k, x) + class(PPM_CWK), intent(in) :: this !< This reconstruction + integer, intent(in) :: k !< Cell number + real, intent(in) :: x !< Non-dimensional position within element [nondim] + real :: xc ! Bounded version of x [nondim] + real :: du ! Difference across cell [A] + real :: a6 ! Collela and Woordward curvature parameter [A] + + du = this%ur(k) - this%ul(k) + a6 = 3.0 * ( ( this%u_mean(k) - this%ul(k) ) + ( this%u_mean(k) - this%ur(k) ) ) + xc = max( 0., min( 1., x ) ) + + dfdx = du + a6 * ( 2.0 * xc - 1.0 ) + +end function dfdx + +!> Average between xa and xb for cell k of a 1D PPM reconstruction [A] +real function average(this, k, xa, xb) + class(PPM_CWK), intent(in) :: this !< This reconstruction + integer, intent(in) :: k !< Cell number + real, intent(in) :: xa !< Start of averaging interval on element (0 to 1) + real, intent(in) :: xb !< End of averaging interval on element (0 to 1) + real :: xapxb ! A sum of fracional positions [nondim] + real :: mx, Ya, Yb, my ! Various fractional positions [nondim] + real :: u_a, u_b ! Values at xa and xb [A] + real :: xa2pxb2, xa2b2ab, Ya2b2ab ! Sums of squared fractional positions [nondim] + real :: a_L, a_R, u_c, a_c ! Values of the polynomial at various locations [A] + + mx = 0.5 * ( xa + xb ) + a_L = this%ul(k) + a_R = this%ur(k) + u_c = this%u_mean(k) + a_c = 0.5 * ( ( u_c - a_L ) + ( u_c - a_R ) ) ! a_6 / 6 + if (mx<0.5) then + ! This integration of the PPM reconstruction is expressed in distances from the left edge + xa2b2ab = (xa * xa + xb * xb) + xa * xb + average = a_L + ( ( a_R - a_L ) * mx & + + a_c * ( 3. * ( xb + xa ) - 2. * xa2b2ab ) ) + else + ! This integration of the PPM reconstruction is expressed in distances from the right edge + Ya = 1. - xa + Yb = 1. - xb + my = 0.5 * ( Ya + Yb ) + Ya2b2ab = (Ya * Ya + Yb * Yb) + Ya * Yb + average = a_R + ( ( a_L - a_R ) * my & + + a_c * ( 3. * ( Yb + Ya ) - 2. * Ya2b2ab ) ) + endif + +end function average + +!> Deallocate the PPM_CWK reconstruction +subroutine destroy(this) + class(PPM_CWK), intent(inout) :: this !< This reconstruction + + deallocate( this%u_mean, this%ul, this%ur ) + +end subroutine destroy + +!> Checks the PPM_CWK reconstruction for consistency +logical function check_reconstruction(this, h, u) + class(PPM_CWK), intent(in) :: this !< This reconstruction + real, intent(in) :: h(*) !< Grid spacing (thickness) [typically H] + real, intent(in) :: u(*) !< Cell mean values [A] + ! Local variables + integer :: k + + check_reconstruction = .false. + + ! Simply checks the internal copy of "u" is exactly equal to "u" + do k = 1, this%n + if ( abs( this%u_mean(k) - u(k) ) > 0. ) check_reconstruction = .true. + enddo + + ! If (u - ul) has the opposite sign from (ur - u), then this cell has an interior extremum + do k = 1, this%n + if ( ( this%u_mean(k) - this%ul(k) ) * ( this%ur(k) - this%u_mean(k) ) < 0. ) check_reconstruction = .true. + enddo + + ! Check bounding of right edges, w.r.t. the cell means + do K = 1, this%n-1 + if ( ( this%ur(k) - this%u_mean(k) ) * ( this%u_mean(k+1) - this%ur(k) ) < 0. ) check_reconstruction = .true. + enddo + + ! Check bounding of left edges, w.r.t. the cell means + do K = 2, this%n + if ( ( this%u_mean(k) - this%ul(k) ) * ( this%ul(k) - this%u_mean(k-1) ) < 0. ) check_reconstruction = .true. + enddo + + ! Check bounding of right edges, w.r.t. this cell mean and the next cell left edge + do K = 1, this%n-1 + if ( ( this%ur(k) - this%u_mean(k) ) * ( this%ul(k+1) - this%ur(k) ) < 0. ) check_reconstruction = .true. + enddo + + ! Check bounding of left edges, w.r.t. this cell mean and the previous cell right edge + do K = 2, this%n + if ( ( this%u_mean(k) - this%ul(k) ) * ( this%ul(k) - this%ur(k-1) ) < 0. ) check_reconstruction = .true. + enddo + +end function check_reconstruction + +!> Runs PPM_CWK reconstruction unit tests and returns True for any fails, False otherwise +logical function unit_tests(this, verbose, stdout, stderr) + class(PPM_CWK), intent(inout) :: this !< This reconstruction + logical, intent(in) :: verbose !< True, if verbose + integer, intent(in) :: stdout !< I/O channel for stdout + integer, intent(in) :: stderr !< I/O channel for stderr + ! Local variables + real, allocatable :: ul(:), ur(:), um(:) ! test values [A] + real, allocatable :: ull(:), urr(:) ! test values [A] + type(testing) :: test ! convenience functions + integer :: k + + call test%set( stdout=stdout ) ! Sets the stdout channel in test + call test%set( stderr=stderr ) ! Sets the stderr channel in test + call test%set( verbose=verbose ) ! Sets the verbosity flag in test + + if (verbose) write(stdout,'(a)') 'PPM_CWK:unit_tests testing with linear fn' + + call this%init(5) + call test%test( this%n /= 5, 'Setting number of levels') + allocate( um(5), ul(5), ur(5), ull(5), urr(5) ) + + ! Straight line, f(x) = x , or f(K) = 2*K + call this%reconstruct( (/2.,2.,2.,2.,2./), (/1.,4.,7.,10.,13./) ) + call test%real_arr(5, this%u_mean, (/1.,4.,7.,10.,13./), 'Setting cell values') + ! Without PLM extrapolation we get l(2)=2 and r(4)=12 due to PLM=0 in boundary cells. -AJA + call test%real_arr(5, this%ul, (/1.,2.5,5.5,8.5,13./), 'Left edge values') + call test%real_arr(5, this%ur, (/1.,5.5,8.5,11.5,13./), 'Right edge values') + + do k = 1, 5 + ul(k) = this%f(k, 0.) + um(k) = this%f(k, 0.5) + ur(k) = this%f(k, 1.) + enddo + call test%real_arr(5, ul, this%ul, 'Evaluation on left edge') + call test%real_arr(5, um, (/1.,4.,7.,10.,13./), 'Evaluation in center') + call test%real_arr(5, ur, this%ur, 'Evaluation on right edge') + + do k = 1, 5 + ul(k) = this%dfdx(k, 0.) + um(k) = this%dfdx(k, 0.5) + ur(k) = this%dfdx(k, 1.) + enddo + ! Most of these values are affected by the PLM boundary cells + call test%real_arr(5, ul, (/0.,3.,3.,3.,0./), 'dfdx on left edge') + call test%real_arr(5, um, (/0.,3.,3.,3.,0./), 'dfdx in center') + call test%real_arr(5, ur, (/0.,3.,3.,3.,0./), 'dfdx on right edge') + + do k = 1, 5 + um(k) = this%average(k, 0.5, 0.75) ! Average from x=0.25 to 0.75 in each cell + enddo + ! Most of these values are affected by the PLM boundary cells + call test%real_arr(5, um, (/1.,4.375,7.375,10.375,13./), 'Return interval average') + + if (verbose) write(stdout,'(a)') 'PPM_CWK:unit_tests testing with parabola' + + ! x = 2 i i=0 at origin + ! f(x) = 3/4 x^2 = (2 i)^2 + ! f[i] = 3/4 ( 2 i - 1 )^2 on centers + ! f[I] = 3/4 ( 2 I )^2 on edges + ! f[i] = 1/8 [ x^3 ] for means + ! edges: 0, 1, 12, 27, 48, 75 + ! means: 1, 7, 19, 37, 61 + ! centers: 0.75, 6.75, 18.75, 36.75, 60.75 + call this%reconstruct( (/2.,2.,2.,2.,2./), (/1.,7.,19.,37.,61./) ) + do k = 1, 5 + ul(k) = this%f(k, 0.) + um(k) = this%f(k, 0.5) + ur(k) = this%f(k, 1.) + enddo + call test%real_arr(5, ul, (/1.,3.,12.,27.,61./), 'Return left edge') + call test%real_arr(5, um, (/1.,6.75,18.75,36.75,61./), 'Return center') + call test%real_arr(5, ur, (/1.,12.,27.,48.,61./), 'Return right edge') + + ! x = 3 i i=0 at origin + ! f(x) = x^2 / 3 = 3 i^2 + ! f[i] = [ ( 3 i )^3 - ( 3 i - 3 )^3 ] i=1,2,3,4,5 + ! means: 1, 7, 19, 37, 61 + ! edges: 0, 3, 12, 27, 48, 75 + call this%reconstruct( (/3.,3.,3.,3.,3./), (/1.,7.,19.,37.,61./) ) + do k = 1, 5 + ul(k) = this%f(k, 0.) + um(k) = this%f(k, 0.5) + ur(k) = this%f(k, 1.) + enddo + call test%real_arr(5, ul, (/1.,3.,12.,27.,61./), 'Return left edge') + call test%real_arr(5, um, (/1.,6.75,18.75,36.75,61./), 'Return center') + call test%real_arr(5, ur, (/1.,12.,27.,48.,61./), 'Return right edge') + + call this%destroy() + deallocate( um, ul, ur, ull, urr ) + + unit_tests = test%summarize('PPM_CWK:unit_tests') + +end function unit_tests + +!> \namespace recon1d_ppm_cwk +!! + +end module Recon1d_PPM_CWK diff --git a/src/ALE/Recon1d_PPM_H4_2018.F90 b/src/ALE/Recon1d_PPM_H4_2018.F90 new file mode 100644 index 0000000000..d668b70ace --- /dev/null +++ b/src/ALE/Recon1d_PPM_H4_2018.F90 @@ -0,0 +1,303 @@ +!> Piecewise Parabolic Method 1D reconstruction with h4 interpolation for edges (2018 version) +!! +!! This implementation of PPM follows White and Adcroft 2008 \cite white2008, with cells +!! resorting to PCM for extrema including first and last cells in column. +!! This scheme differs from Colella and Woodward, 1984 \cite colella1984, in the method +!! of first estimating the fourth-order accurate edge values. +!! This uses numerical expressions that predate a 2019 refactoring. +!! The first and last cells are always limited to PCM. +module Recon1d_PPM_H4_2018 + +! This file is part of MOM6. See LICENSE.md for the license. + +use Recon1d_PPM_H4_2019, only : PPM_H4_2019, testing +use regrid_edge_values, only : bound_edge_values, check_discontinuous_edge_values +use regrid_solvers, only : solve_linear_system + +implicit none ; private + +public PPM_H4_2018, testing + +!> PPM reconstruction following White and Adcroft, 2008 +!! +!! Implemented by extending recon1d_ppm_h4_2019. +!! +!! The source for the methods ultimately used by this class are: +!! - init() -> recon1d_ppm_h4_2019.init() +!! - reconstruct() *locally defined +!! - average() -> recon1d_ppm_h4_2019.average() +!! - f() -> recon1d_ppm_h4_2019.f() +!! - dfdx() -> recon1d_ppm_h4_2019.dfdx() +!! - check_reconstruction() -> recon1d_ppm_h4_2019.check_reconstruction() +!! - unit_tests() *locally defined +!! - destroy() -> recon1d_ppm_h4_2019.destroy() +!! - remap_to_sub_grid() -> recon1d_type.remap_to_sub_grid() +!! - init_parent() -> recon1d_ppm_h4_2019.init() +!! - reconstruct_parent() -> recon1d_ppm_h4_2019.reconstruct() +type, extends (PPM_H4_2019) :: PPM_H4_2018 + +contains + !> Implementation of the PPM_H4_2018 reconstruction + procedure :: reconstruct => reconstruct + !> Implementation of unit tests for the PPM_H4_2018 reconstruction + procedure :: unit_tests => unit_tests + +end type PPM_H4_2018 + +contains + +!> Calculate a 1D PPM_H4_2018 reconstructions based on h(:) and u(:) +subroutine reconstruct(this, h, u) + class(PPM_H4_2018), intent(inout) :: this !< This reconstruction + real, intent(in) :: h(*) !< Grid spacing (thickness) [typically H] + real, intent(in) :: u(*) !< Cell mean values [A] + ! Local variables + real :: slp ! The PLM slopes (difference across cell) [A] + real :: u_l, u_r, u_c ! Left, right, and center values [A] + real :: h_l, h_c, h_r ! Thickness of left, center and right cells [H] + real :: h0, h1, h2, h3 ! temporary thicknesses [H] + real :: h_min ! A minimal cell width [H] + real :: f1 ! An auxiliary variable [H] + real :: f2 ! An auxiliary variable [A H] + real :: f3 ! An auxiliary variable [H-1] + real :: et1, et2, et3 ! terms the expression for edge values [A H] + real :: dx ! Difference of successive values of x [H] + real :: f ! value of polynomial at x in arbitrary units [A] + real :: edge_l, edge_r ! Edge values (left and right) [A] + real :: expr1, expr2 ! Temporary expressions [A2] + real, parameter :: hMinFrac = 1.e-5 !< A minimum fraction for min(h)/sum(h) [nondim] + real, dimension(5) :: x ! Coordinate system with 0 at edges [H] + real :: edge_values(this%n,2) ! Edge values [A] + real :: ppoly_coef(this%n,3) ! Polynomial coefficients [A] + real, dimension(4,4) :: A ! Differences in successive positions raised to various powers, + ! in units that vary with the second (j) index as [H^j] + real, dimension(4) :: B ! The right hand side of the system to solve for C [A H] + real, dimension(4) :: C ! The coefficients of a fit polynomial in units that vary + ! with the index (j) as [A H^(j-1)] + integer :: k, n, j + + n = this%n + + ! Loop on interior cells + do K = 3, n-1 + + h0 = h(k-2) + h1 = h(k-1) + h2 = h(k) + h3 = h(k+1) + + ! Avoid singularities when consecutive pairs of h vanish + if (h0+h1==0.0 .or. h1+h2==0.0 .or. h2+h3==0.0) then + h_min = hMinFrac*max( this%h_neglect, h0+h1+h2+h3 ) + h0 = max( h_min, h(k-2) ) + h1 = max( h_min, h(k-1) ) + h2 = max( h_min, h(k) ) + h3 = max( h_min, h(k+1) ) + endif + + f1 = (h0+h1) * (h2+h3) / (h1+h2) + f2 = h2 * u(k-1) + h1 * u(k) + f3 = 1.0 / (h0+h1+h2) + 1.0 / (h1+h2+h3) + et1 = f1 * f2 * f3 + et2 = ( h2 * (h2+h3) / ( (h0+h1+h2)*(h0+h1) ) ) * & + ((h0+2.0*h1) * u(k-1) - h1 * u(k-2)) + et3 = ( h1 * (h0+h1) / ( (h1+h2+h3)*(h2+h3) ) ) * & + ((2.0*h2+h3) * u(k) - h2 * u(k+1)) + edge_values(k,1) = (et1 + et2 + et3) / ( h0 + h1 + h2 + h3) + edge_values(k-1,2) = edge_values(k,1) + + enddo ! end loop on interior cells + + ! Determine first two edge values + h_min = max( this%h_neglect, hMinFrac*sum(h(1:4)) ) + x(1) = 0.0 + do k = 1,4 + dx = max(h_min, h(k) ) + x(k+1) = x(k) + dx + do j = 1,4 ; A(k,j) = ( (x(k+1)**j) - (x(k)**j) ) / real(j) ; enddo + B(k) = u(k) * dx + enddo + + call solve_linear_system( A, B, C, 4 ) + + ! Set the edge values of the first cell + f = 0.0 + do k = 1, 4 + f = f + C(k) * ( x(1)**(k-1) ) + enddo + edge_values(1,1) = f + f = 0.0 + do k = 1, 4 + f = f + C(k) * ( x(2)**(k-1) ) + enddo + edge_values(1,2) = f + edge_values(2,1) = edge_values(1,2) + + ! Determine two edge values of the last cell + h_min = max( this%h_neglect, hMinFrac*sum(h(n-3:n)) ) + x(1) = 0.0 + do k = 1,4 + dx = max(h_min, h(n-4+k) ) + x(k+1) = x(k) + dx + do j = 1,4 ; A(k,j) = ( (x(k+1)**j) - (x(k)**j) ) / real(j) ; enddo + B(k) = u(n-4+k) * dx + enddo + + call solve_linear_system( A, B, C, 4 ) + + ! Set the last and second to last edge values + f = 0.0 + do k = 1, 4 + f = f + C(k) * ( x(5)**(k-1) ) + enddo + edge_values(n,2) = f + f = 0.0 + do k = 1, 4 + f = f + C(k) * ( x(4)**(k-1) ) + enddo + edge_values(n,1) = f + edge_values(n-1,2) = edge_values(n,1) + + ! Bound edge values + call bound_edge_values( n, h, u, edge_values, this%h_neglect, answer_date=20180101 ) + + ! Make discontinuous edge values monotonic + call check_discontinuous_edge_values( n, u, edge_values ) + + ! Loop on interior cells to apply the standard + ! PPM limiter (Colella & Woodward, JCP 84) + do k = 2,n-1 + + ! Get cell averages + u_l = u(k-1) + u_c = u(k) + u_r = u(k+1) + + edge_l = edge_values(k,1) + edge_r = edge_values(k,2) + + if ( (u_r - u_c)*(u_c - u_l) <= 0.0) then + ! Flatten extremum + edge_l = u_c + edge_r = u_c + else + expr1 = 3.0 * (edge_r - edge_l) * ( (u_c - edge_l) + (u_c - edge_r)) + expr2 = (edge_r - edge_l) * (edge_r - edge_l) + if ( expr1 > expr2 ) then + ! Place extremum at right edge of cell by adjusting left edge value + edge_l = u_c + 2.0 * ( u_c - edge_r ) + edge_l = max( min( edge_l, max(u_l, u_c) ), min(u_l, u_c) ) ! In case of round off + elseif ( expr1 < -expr2 ) then + ! Place extremum at left edge of cell by adjusting right edge value + edge_r = u_c + 2.0 * ( u_c - edge_l ) + edge_r = max( min( edge_r, max(u_r, u_c) ), min(u_r, u_c) ) ! In case of round off + endif + endif + ! This checks that the difference in edge values is representable + ! and avoids overshoot problems due to round off. + !### The 1.e-60 needs to have units of [A], so this dimensionally inconsistent. + if ( abs( edge_r - edge_l ) Runs PPM_H4_2018 reconstruction unit tests and returns True for any fails, False otherwise +logical function unit_tests(this, verbose, stdout, stderr) + class(PPM_H4_2018), intent(inout) :: this !< This reconstruction + logical, intent(in) :: verbose !< True, if verbose + integer, intent(in) :: stdout !< I/O channel for stdout + integer, intent(in) :: stderr !< I/O channel for stderr + ! Local variables + real, allocatable :: ul(:), ur(:), um(:) ! test values [A] + real, allocatable :: ull(:), urr(:) ! test values [A] + type(testing) :: test ! convenience functions + integer :: k + + call test%set( stdout=stdout ) ! Sets the stdout channel in test + call test%set( stderr=stderr ) ! Sets the stderr channel in test + call test%set( verbose=verbose ) ! Sets the verbosity flag in test + + if (verbose) write(stdout,'(a)') 'PPM_H4_2018:unit_tests testing with linear fn' + + call this%init(5) + call test%test( this%n /= 5, 'Setting number of levels') + allocate( um(5), ul(5), ur(5), ull(5), urr(5) ) + + ! Straight line, f(x) = x , or f(K) = 2*K + call this%reconstruct( (/2.,2.,2.,2.,2./), (/1.,3.,5.,7.,9./) ) + call test%real_arr(5, this%u_mean, (/1.,3.,5.,7.,9./), 'Setting cell values') + call test%real_arr(5, this%ul, (/1.,2.,4.,6.,9./), 'Left edge values', robits=2) + call test%real_arr(5, this%ur, (/1.,4.,6.,8.,9./), 'Right edge values', robits=1) + do k = 1, 5 + um(k) = this%u_mean(k) + enddo + call test%real_arr(5, um, (/1.,3.,5.,7.,9./), 'Return cell mean') + + do k = 1, 5 + ul(k) = this%f(k, 0.) + um(k) = this%f(k, 0.5) + ur(k) = this%f(k, 1.) + enddo + call test%real_arr(5, ul, this%ul, 'Evaluation on left edge') + call test%real_arr(5, um, (/1.,3.,5.,7.,9./), 'Evaluation in center') + call test%real_arr(5, ur, this%ur, 'Evaluation on right edge') + + do k = 1, 5 + ul(k) = this%dfdx(k, 0.) + um(k) = this%dfdx(k, 0.5) + ur(k) = this%dfdx(k, 1.) + enddo + call test%real_arr(5, ul, (/0.,2.,2.,2.,0./), 'dfdx on left edge', robits=4) + call test%real_arr(5, um, (/0.,2.,2.,2.,0./), 'dfdx in center', robits=2) + call test%real_arr(5, ur, (/0.,2.,2.,2.,0./), 'dfdx on right edge', robits=6) + + do k = 1, 5 + um(k) = this%average(k, 0.5, 0.75) ! Average from x=0.25 to 0.75 in each cell + enddo + call test%real_arr(5, um, (/1.,3.25,5.25,7.25,9./), 'Return interval average') + + if (verbose) write(stdout,'(a)') 'PPM_H4_2018:unit_tests testing with parabola' + + ! x = 3 i i=0 at origin + ! f(x) = x^2 / 3 = 3 i^2 + ! f[i] = [ ( 3 i )^3 - ( 3 i - 3 )^3 ] i=1,2,3,4,5 + ! means: 1, 7, 19, 37, 61 + ! edges: 0, 3, 12, 27, 48, 75 + call this%reconstruct( (/3.,3.,3.,3.,3./), (/1.,7.,19.,37.,61./) ) + do k = 1, 5 + ul(k) = this%f(k, 0.) + um(k) = this%f(k, 0.5) + ur(k) = this%f(k, 1.) + enddo + call test%real_arr(5, ul, (/1.,3.,12.,27.,61./), 'Return left edge', robits=2) + call test%real_arr(5, ur, (/1.,12.,27.,48.,61./), 'Return right edge', robits=1) + + call this%destroy() + deallocate( um, ul, ur, ull, urr ) + + unit_tests = test%summarize('PPM_H4_2018:unit_tests') + +end function unit_tests + +!> \namespace recon1d_ppm_h4_2018 +!! + +end module Recon1d_PPM_H4_2018 diff --git a/src/ALE/Recon1d_PPM_H4_2019.F90 b/src/ALE/Recon1d_PPM_H4_2019.F90 new file mode 100644 index 0000000000..d01ff3fb2b --- /dev/null +++ b/src/ALE/Recon1d_PPM_H4_2019.F90 @@ -0,0 +1,585 @@ +!> Piecewise Parabolic Method 1D reconstruction with h4 interpolation for edges +!! +!! This implementation of PPM follows White and Adcroft 2008 \cite white2008, with cells +!! resorting to PCM for extrema including first and last cells in column. +!! This scheme differs from Colella and Woodward, 1984 \cite colella1984, in the method +!! of first estimating the fourth-order accurate edge values. +!! This uses numerical expressions refactored at the beginning of 2019. +!! The first and last cells are always limited to PCM. +module Recon1d_PPM_H4_2019 + +! This file is part of MOM6. See LICENSE.md for the license. + +use Recon1d_type, only : Recon1d, testing + +implicit none ; private + +public PPM_H4_2019, testing + +!> PPM reconstruction following White and Adcroft, 2008 +!! +!! The source for the methods ultimately used by this class are: +!! - init() *locally defined +!! - reconstruct() *locally defined +!! - average() *locally defined +!! - f() *locally defined +!! - dfdx() *locally defined +!! - check_reconstruction() *locally defined +!! - unit_tests() *locally defined +!! - destroy() *locally defined +!! - remap_to_sub_grid() -> recon1d_type.remap_to_sub_grid() +!! - init_parent() -> init() +!! - reconstruct_parent() -> reconstruct() +type, extends (Recon1d) :: PPM_H4_2019 + + real, allocatable :: ul(:) !< Left edge value [A] + real, allocatable :: ur(:) !< Right edge value [A] + +contains + !> Implementation of the PPM_H4_2019 initialization + procedure :: init => init + !> Implementation of the PPM_H4_2019 reconstruction + procedure :: reconstruct => reconstruct + !> Implementation of the PPM_H4_2019 average over an interval [A] + procedure :: average => average + !> Implementation of evaluating the PPM_H4_2019 reconstruction at a point [A] + procedure :: f => f + !> Implementation of the derivative of the PPM_H4_2019 reconstruction at a point [A] + procedure :: dfdx => dfdx + !> Implementation of deallocation for PPM_H4_2019 + procedure :: destroy => destroy + !> Implementation of check reconstruction for the PPM_H4_2019 reconstruction + procedure :: check_reconstruction => check_reconstruction + !> Implementation of unit tests for the PPM_H4_2019 reconstruction + procedure :: unit_tests => unit_tests + + !> Duplicate interface to init() + procedure :: init_parent => init + !> Duplicate interface to reconstruct() + procedure :: reconstruct_parent => reconstruct + +end type PPM_H4_2019 + +contains + +!> Initialize a 1D PPM_H4_2019 reconstruction for n cells +subroutine init(this, n, h_neglect, check) + class(PPM_H4_2019), intent(out) :: this !< This reconstruction + integer, intent(in) :: n !< Number of cells in this column + real, optional, intent(in) :: h_neglect !< A negligibly small width used in cell reconstructions [H] + logical, optional, intent(in) :: check !< If true, enable some consistency checking + + this%n = n + + allocate( this%u_mean(n) ) + allocate( this%ul(n) ) + allocate( this%ur(n) ) + + this%h_neglect = tiny( this%u_mean(1) ) + if (present(h_neglect)) this%h_neglect = h_neglect + this%check = .false. + if (present(check)) this%check = check + +end subroutine init + +!> Calculate a 1D PPM_H4_2019 reconstructions based on h(:) and u(:) +subroutine reconstruct(this, h, u) + class(PPM_H4_2019), intent(inout) :: this !< This reconstruction + real, intent(in) :: h(*) !< Grid spacing (thickness) [typically H] + real, intent(in) :: u(*) !< Cell mean values [A] + ! Local variables + real :: slp ! The PLM slopes (difference across cell) [A] + real :: sigma_l, sigma_c, sigma_r ! Left, central and right slope estimates as + ! differences across the cell [A] + real :: u_min, u_max ! Minimum and maximum value across cell [A] + real :: u_l, u_r, u_c ! Left, right, and center values [A] + real :: h_l, h_c, h_r ! Thickness of left, center and right cells [H] + real :: h_c0 ! Thickness of center with h_neglect added [H] + real :: h0, h1, h2, h3 ! temporary thicknesses [H] + real :: h_min ! A minimal cell width [H] + real :: f1 ! An auxiliary variable [H] + real :: f2 ! An auxiliary variable [A H] + real :: f3 ! An auxiliary variable [H-1] + real :: et1, et2, et3 ! terms the expression for edge values [A H] + real :: I_h12 ! The inverse of the sum of the two central thicknesses [H-1] + real :: I_h012, I_h123 ! Inverses of sums of three successive thicknesses [H-1] + real :: I_den_et2, I_den_et3 ! Inverses of denominators in edge value terms [H-2] + real :: dx ! Difference of successive values of x [H] + real :: f ! value of polynomial at x in arbitrary units [A] + real :: edge_l, edge_r ! Edge values (left and right) [A] + real :: expr1, expr2 ! Temporary expressions [A2] + real :: slope_x_h ! retained PLM slope times half grid step [A] + real :: u0_avg ! avg value at given edge [A] + real, parameter :: hMinFrac = 1.e-5 !< A minimum fraction for min(h)/sum(h) [nondim] + real :: edge_values(this%n,2) ! Edge values [A] + real :: ppoly_coef(this%n,3) ! Polynomial coefficients [A] + real :: dz(4) ! A temporary array of limited layer thicknesses [H] + real :: u_tmp(4) ! A temporary array of cell average properties [A] + real :: A(4,4) ! Differences in successive positions raised to various powers, + ! in units that vary with the second (j) index as [H^j] + real :: B(4) ! The right hand side of the system to solve for C [A H] + real :: C(4) ! The coefficients of a fit polynomial in units that vary + ! with the index (j) as [A H^(j-1)] + integer :: k, n, km1, kp1 + + n = this%n + + ! Loop on interior cells + do K = 3, n-1 + + h0 = h(k-2) + h1 = h(k-1) + h2 = h(k) + h3 = h(k+1) + + ! Avoid singularities when consecutive pairs of h vanish + if (h0+h1==0.0 .or. h1+h2==0.0 .or. h2+h3==0.0) then + h_min = hMinFrac*max( this%h_neglect, (h0+h1)+(h2+h3) ) + h0 = max( h_min, h0 ) + h1 = max( h_min, h1 ) + h2 = max( h_min, h2 ) + h3 = max( h_min, h3 ) + endif + + I_h12 = 1.0 / (h1+h2) + I_den_et2 = 1.0 / ( ((h0+h1)+h2)*(h0+h1) ) ; I_h012 = (h0+h1) * I_den_et2 + I_den_et3 = 1.0 / ( (h1+(h2+h3))*(h2+h3) ) ; I_h123 = (h2+h3) * I_den_et3 + + et1 = ( 1.0 + (h1 * I_h012 + (h0+h1) * I_h123) ) * I_h12 * (h2*(h2+h3)) * u(k-1) + & + ( 1.0 + (h2 * I_h123 + (h2+h3) * I_h012) ) * I_h12 * (h1*(h0+h1)) * u(k) + et2 = ( h1 * (h2*(h2+h3)) * I_den_et2 ) * (u(k-1)-u(k-2)) + et3 = ( h2 * (h1*(h0+h1)) * I_den_et3 ) * (u(k) - u(k+1)) + edge_values(k,1) = (et1 + (et2 + et3)) / ((h0 + h1) + (h2 + h3)) + edge_values(k-1,2) = edge_values(k,1) + + enddo ! end loop on interior cells + + ! Determine first two edge values + do k=1,4 ; dz(k) = max(this%h_neglect, h(k) ) ; u_tmp(k) = u(k) ; enddo + call end_value_h4(dz, u_tmp, C) + + ! Set the edge values of the first cell + edge_values(1,1) = C(1) + edge_values(1,2) = C(1) + dz(1) * ( C(2) + dz(1) * ( C(3) + dz(1) * C(4) ) ) + edge_values(2,1) = edge_values(1,2) + + ! Determine two edge values of the last cell + do k=1,4 ; dz(k) = max(this%h_neglect, h(n+1-k) ) ; u_tmp(k) = u(n+1-k) ; enddo + call end_value_h4(dz, u_tmp, C) + + ! Set the last and second to last edge values + edge_values(n,2) = C(1) + edge_values(n,1) = C(1) + dz(1) * ( C(2) + dz(1) * ( C(3) + dz(1) * C(4) ) ) + edge_values(n-1,2) = edge_values(n,1) + + ! Loop on cells to bound edge value + do k = 1, n + + ! For the sake of bounding boundary edge values, the left neighbor of the left boundary cell + ! is assumed to be the same as the left boundary cell and the right neighbor of the right + ! boundary cell is assumed to be the same as the right boundary cell. This effectively makes + ! boundary cells look like extrema. + km1 = max(1,k-1) ; kp1 = min(k+1,N) + + slope_x_h = 0.0 + sigma_l = ( u(k) - u(km1) ) + if ( (h(km1) + h(kp1)) + 2.0*h(k) > 0. ) then + sigma_c = ( u(kp1) - u(km1) ) * ( h(k) / ((h(km1) + h(kp1)) + 2.0*h(k)) ) + else + sigma_c = 0. + endif + sigma_r = ( u(kp1) - u(k) ) + + ! The limiter is used in the local coordinate system to each cell, so for convenience store + ! the slope times a half grid spacing. (See White and Adcroft JCP 2008 Eqs 19 and 20) + if ( (sigma_l * sigma_r) > 0.0 ) & + slope_x_h = sign( min(abs(sigma_l),abs(sigma_c),abs(sigma_r)), sigma_c ) + + ! Limit the edge values + if ( (u(km1)-edge_values(k,1)) * (edge_values(k,1)-u(k)) < 0.0 ) then + edge_values(k,1) = u(k) - sign( min( abs(slope_x_h), abs(edge_values(k,1)-u(k)) ), slope_x_h ) + endif + + if ( (u(kp1)-edge_values(k,2)) * (edge_values(k,2)-u(k)) < 0.0 ) then + edge_values(k,2) = u(k) + sign( min( abs(slope_x_h), abs(edge_values(k,2)-u(k)) ), slope_x_h ) + endif + + ! Finally bound by neighboring cell means in case of roundoff + edge_values(k,1) = max( min( edge_values(k,1), max(u(km1), u(k)) ), min(u(km1), u(k)) ) + edge_values(k,2) = max( min( edge_values(k,2), max(u(kp1), u(k)) ), min(u(kp1), u(k)) ) + + enddo ! loop on interior edges + + do k = 1, n-1 + if ( (edge_values(k+1,1) - edge_values(k,2)) * (u(k+1) - u(k)) < 0.0 ) then + u0_avg = 0.5 * ( edge_values(k,2) + edge_values(k+1,1) ) + u0_avg = max( min( u0_avg, max(u(k), u(k+1)) ), min(u(k), u(k+1)) ) + edge_values(k,2) = u0_avg + edge_values(k+1,1) = u0_avg + endif + enddo ! end loop on interior edges + + ! Loop on interior cells to apply the standard + ! PPM limiter (Colella & Woodward, JCP 84) + do k = 2,N-1 + + ! Get cell averages + u_l = u(k-1) + u_c = u(k) + u_r = u(k+1) + + edge_l = edge_values(k,1) + edge_r = edge_values(k,2) + + if ( (u_r - u_c)*(u_c - u_l) <= 0.0) then + ! Flatten extremum + edge_l = u_c + edge_r = u_c + else + expr1 = 3.0 * (edge_r - edge_l) * ( (u_c - edge_l) + (u_c - edge_r)) + expr2 = (edge_r - edge_l) * (edge_r - edge_l) + if ( expr1 > expr2 ) then + ! Place extremum at right edge of cell by adjusting left edge value + edge_l = u_c + 2.0 * ( u_c - edge_r ) + edge_l = max( min( edge_l, max(u_l, u_c) ), min(u_l, u_c) ) ! In case of round off + elseif ( expr1 < -expr2 ) then + ! Place extremum at left edge of cell by adjusting right edge value + edge_r = u_c + 2.0 * ( u_c - edge_l ) + edge_r = max( min( edge_r, max(u_r, u_c) ), min(u_r, u_c) ) ! In case of round off + endif + endif + ! This checks that the difference in edge values is representable + ! and avoids overshoot problems due to round off. + !### The 1.e-60 needs to have units of [A], so this dimensionally inconsistent. + if ( abs( edge_r - edge_l ) Determine a one-sided 4th order polynomial fit of u to the data points for the purposes of specifying +!! edge values, as described in the appendix of White and Adcroft JCP 2008. +subroutine end_value_h4(dz, u, Csys) + real, intent(in) :: dz(4) !< The thicknesses of 4 layers, starting at the edge [H]. + !! The values of dz must be positive. + real, intent(in) :: u(4) !< The average properties of 4 layers, starting at the edge [A] + real, intent(out) :: Csys(4) !< The four coefficients of a 4th order polynomial fit + !! of u as a function of z [A H-(n-1)] + + ! Local variables + real :: Wt(3,4) ! The weights of successive u differences in the 4 closed form expressions. + ! The units of Wt vary with the second index as [H-(n-1)]. + real :: h1, h2, h3, h4 ! Copies of the layer thicknesses [H] + real :: h12, h23, h34 ! Sums of two successive thicknesses [H] + real :: h123, h234 ! Sums of three successive thicknesses [H] + real :: h1234 ! Sums of all four thicknesses [H] + ! real :: I_h1 ! The inverse of the a thickness [H-1] + real :: I_h12, I_h23, I_h34 ! The inverses of sums of two thicknesses [H-1] + real :: I_h123, I_h234 ! The inverse of the sum of three thicknesses [H-1] + real :: I_h1234 ! The inverse of the sum of all four thicknesses [H-1] + real :: I_denom ! The inverse of the denominator some expressions [H-3] + real :: I_denB3 ! The inverse of the product of three sums of thicknesses [H-3] + real :: min_frac = 1.0e-6 ! The square of min_frac should be much larger than roundoff [nondim] + real, parameter :: C1_3 = 1.0 / 3.0 ! A rational parameter [nondim] + + ! if ((dz(1) == dz(2)) .and. (dz(1) == dz(3)) .and. (dz(1) == dz(4))) then + ! ! There are simple closed-form expressions in this case + ! I_h1 = 0.0 ; if (dz(1) > 0.0) I_h1 = 1.0 / dz(1) + ! Csys(1) = u(1) + (-13.0 * (u(2)-u(1)) + 10.0 * (u(3)-u(2)) - 3.0 * (u(4)-u(3))) * (0.25*C1_3) + ! Csys(2) = (35.0 * (u(2)-u(1)) - 34.0 * (u(3)-u(2)) + 11.0 * (u(4)-u(3))) * (0.25*C1_3 * I_h1) + ! Csys(3) = (-5.0 * (u(2)-u(1)) + 8.0 * (u(3)-u(2)) - 3.0 * (u(4)-u(3))) * (0.25 * I_h1**2) + ! Csys(4) = ((u(2)-u(1)) - 2.0 * (u(3)-u(2)) + (u(4)-u(3))) * (0.5*C1_3) + ! else + + ! Express the coefficients as sums of the differences between properties of successive layers. + + h1 = dz(1) ; h2 = dz(2) ; h3 = dz(3) ; h4 = dz(4) + ! Some of the weights used below are proportional to (h1/(h2+h3))**2 or (h1/(h2+h3))*(h2/(h3+h4)) + ! so h2 and h3 should be adjusted to ensure that these ratios are not so large that property + ! differences at the level of roundoff are amplified to be of order 1. + if ((h2+h3) < min_frac*h1) h3 = min_frac*h1 - h2 + if ((h3+h4) < min_frac*h1) h4 = min_frac*h1 - h3 + + h12 = h1+h2 ; h23 = h2+h3 ; h34 = h3+h4 + h123 = h12 + h3 ; h234 = h2 + h34 ; h1234 = h12 + h34 + ! Find 3 reciprocals with a single division for efficiency. + I_denB3 = 1.0 / (h123 * h12 * h23) + I_h12 = (h123 * h23) * I_denB3 + I_h23 = (h12 * h123) * I_denB3 + I_h123 = (h12 * h23) * I_denB3 + I_denom = 1.0 / ( h1234 * (h234 * h34) ) + I_h34 = (h1234 * h234) * I_denom + I_h234 = (h1234 * h34) * I_denom + I_h1234 = (h234 * h34) * I_denom + + ! Calculation coefficients in the four equations + + ! The expressions for Csys(3) and Csys(4) come from reducing the 4x4 matrix problem into the following 2x2 + ! matrix problem, then manipulating the analytic solution to avoid any subtraction and simplifying. + ! (C1_3 * h123 * h23) * Csys(3) + (0.25 * h123 * h23 * (h3 + 2.0*h2 + 3.0*h1)) * Csys(4) = + ! (u(3)-u(1)) - (u(2)-u(1)) * (h12 + h23) * I_h12 + ! (C1_3 * ((h23 + h34) * h1234 + h23 * h3)) * Csys(3) + + ! (0.25 * ((h1234 + h123 + h12 + h1) * h23 * h3 + (h1234 + h12 + h1) * (h23 + h34) * h1234)) * Csys(4) = + ! (u(4)-u(1)) - (u(2)-u(1)) * (h123 + h234) * I_h12 + ! The final expressions for Csys(1) and Csys(2) were derived by algebraically manipulating the following expressions: + ! Csys(1) = (C1_3 * h1 * h12 * Csys(3) + 0.25 * h1 * h12 * (2.0*h1+h2) * Csys(4)) - & + ! (h1*I_h12)*(u(2)-u(1)) + u(1) + ! Csys(2) = (-2.0*C1_3 * (2.0*h1+h2) * Csys(3) - 0.5 * (h1**2 + h12 * (2.0*h1+h2)) * Csys(4)) + & + ! 2.0*I_h12 * (u(2)-u(1)) + ! These expressions are typically evaluated at x=0 and x=h1, so it is important that these are well behaved + ! for these values, suggesting that h1/h23 and h1/h34 should not be allowed to be too large. + + Wt(1,1) = -h1 * (I_h1234 + I_h123 + I_h12) ! > -3 + Wt(2,1) = h1 * h12 * ( I_h234 * I_h1234 + I_h23 * (I_h234 + I_h123) ) ! < (h1/h234) + (h1/h23)*(2+(h1/h234)) + Wt(3,1) = -h1 * h12 * h123 * I_denom ! > -(h1/h34)*(1+(h1/h234)) + + Wt(1,2) = 2.0 * (I_h12*(1.0 + (h1+h12) * (I_h1234 + I_h123)) + h1 * I_h1234*I_h123) ! < 10/h12 + Wt(2,2) = -2.0 * ((h1 * h12 * I_h1234) * (I_h23 * (I_h234 + I_h123)) + & ! > -(10+6*(h1/h234))/h23 + (h1+h12) * ( I_h1234*I_h234 + I_h23 * (I_h234 + I_h123) ) ) + Wt(3,2) = 2.0 * ((h1+h12) * h123 + h1*h12 ) * I_denom ! < (2+(6*h1/h234)) / h34 + + Wt(1,3) = -3.0 * I_h12 * I_h123* ( 1.0 + I_h1234 * ((h1+h12)+h123) ) ! > -12 / (h12*h123) + Wt(2,3) = 3.0 * I_h23 * ( I_h123 + I_h1234 * ((h1+h12)+h123) * (I_h123 + I_h234) ) ! < 12 / (h23^2) + Wt(3,3) = -3.0 * ((h1+h12)+h123) * I_denom ! > -9 / (h234*h23) + + Wt(1,4) = 4.0 * I_h1234 * I_h123 * I_h12 ! Wt*h1^3 < 4 + Wt(2,4) = -4.0 * I_h1234 * (I_h23 * (I_h123 + I_h234)) ! Wt*h1^3 > -4* (h1/h23)*(1+h1/h234) + Wt(3,4) = 4.0 * I_denom ! = 4.0*I_h1234 * I_h234 * I_h34 ! Wt*h1^3 < 4 * (h1/h234)*(h1/h34) + + Csys(1) = ((u(1) + Wt(1,1) * (u(2)-u(1))) + Wt(2,1) * (u(3)-u(2))) + Wt(3,1) * (u(4)-u(3)) + Csys(2) = (Wt(1,2) * (u(2)-u(1)) + Wt(2,2) * (u(3)-u(2))) + Wt(3,2) * (u(4)-u(3)) + Csys(3) = (Wt(1,3) * (u(2)-u(1)) + Wt(2,3) * (u(3)-u(2))) + Wt(3,3) * (u(4)-u(3)) + Csys(4) = (Wt(1,4) * (u(2)-u(1)) + Wt(2,4) * (u(3)-u(2))) + Wt(3,4) * (u(4)-u(3)) + + ! endif ! End of non-uniform layer thickness branch. + +end subroutine end_value_h4 + +!> Value of PPM_H4_2019 reconstruction at a point in cell k [A] +real function f(this, k, x) + class(PPM_H4_2019), intent(in) :: this !< This reconstruction + integer, intent(in) :: k !< Cell number + real, intent(in) :: x !< Non-dimensional position within element [nondim] + real :: xc ! Bounded version of x [nondim] + real :: du ! Difference across cell [A] + real :: a6 ! Collela and Woordward curvature parameter [A] + real :: u_a, u_b ! Two estimate of f [A] + real :: lmx ! 1 - x [nondim] + real :: wb ! Weight based on x [nondim] + + du = this%ur(k) - this%ul(k) + a6 = 3.0 * ( ( this%u_mean(k) - this%ul(k) ) + ( this%u_mean(k) - this%ur(k) ) ) + xc = max( 0., min( 1., x ) ) + lmx = 1.0 - xc + + ! This expression for u_a can overshoot u_r but is good for x<<1 + u_a = this%ul(k) + xc * ( du + a6 * lmx ) + ! This expression for u_b can overshoot u_l but is good for 1-x<<1 + u_b = this%ur(k) + lmx * ( - du + a6 * xc ) + + ! Since u_a and u_b are both side-bounded, using weights=0 or 1 will preserve uniformity + wb = 0.5 + sign(0.5, xc - 0.5 ) ! = 1 @ x=0, = 0 @ x=1 + f = ( ( 1. - wb ) * u_a ) + ( wb * u_b ) + +end function f + +!> Derivative of PPM_H4_2019 reconstruction at a point in cell k [A] +real function dfdx(this, k, x) + class(PPM_H4_2019), intent(in) :: this !< This reconstruction + integer, intent(in) :: k !< Cell number + real, intent(in) :: x !< Non-dimensional position within element [nondim] + real :: xc ! Bounded version of x [nondim] + real :: du ! Difference across cell [A] + real :: a6 ! Collela and Woordward curvature parameter [A] + + du = this%ur(k) - this%ul(k) + a6 = 3.0 * ( ( this%u_mean(k) - this%ul(k) ) + ( this%u_mean(k) - this%ur(k) ) ) + xc = max( 0., min( 1., x ) ) + + dfdx = du + a6 * ( 2.0 * xc - 1.0 ) + +end function dfdx + +!> Average between xa and xb for cell k of a 1D PPM reconstruction [A] +real function average(this, k, xa, xb) + class(PPM_H4_2019), intent(in) :: this !< This reconstruction + integer, intent(in) :: k !< Cell number + real, intent(in) :: xa !< Start of averaging interval on element (0 to 1) + real, intent(in) :: xb !< End of averaging interval on element (0 to 1) + real :: xapxb ! A sum of fracional positions [nondim] + real :: mx, Ya, Yb, my ! Various fractional positions [nondim] + real :: u_a, u_b ! Values at xa and xb [A] + real :: xa2pxb2, xa2b2ab, Ya2b2ab ! Sums of squared fractional positions [nondim] + real :: a_L, a_R, u_c, a_c ! Values of the polynomial at various locations [A] + + mx = 0.5 * ( xa + xb ) + a_L = this%ul(k) + a_R = this%ur(k) + u_c = this%u_mean(k) + a_c = 0.5 * ( ( u_c - a_L ) + ( u_c - a_R ) ) ! a_6 / 6 + if (mx<0.5) then + ! This integration of the PPM reconstruction is expressed in distances from the left edge + xa2b2ab = (xa*xa+xb*xb)+xa*xb + average = a_L + ( ( a_R - a_L ) * mx & + + a_c * ( 3. * ( xb + xa ) - 2.*xa2b2ab ) ) + else + ! This integration of the PPM reconstruction is expressed in distances from the right edge + Ya = 1. - xa + Yb = 1. - xb + my = 0.5 * ( Ya + Yb ) + Ya2b2ab = (Ya*Ya+Yb*Yb)+Ya*Yb + average = a_R + ( ( a_L - a_R ) * my & + + a_c * ( 3. * ( Yb + Ya ) - 2.*Ya2b2ab ) ) + endif + +end function average + +!> Deallocate the PPM_H4_2019 reconstruction +subroutine destroy(this) + class(PPM_H4_2019), intent(inout) :: this !< This reconstruction + + deallocate( this%u_mean, this%ul, this%ur ) + +end subroutine destroy + +!> Checks the PPM_H4_2019 reconstruction for consistency +logical function check_reconstruction(this, h, u) + class(PPM_H4_2019), intent(in) :: this !< This reconstruction + real, intent(in) :: h(*) !< Grid spacing (thickness) [typically H] + real, intent(in) :: u(*) !< Cell mean values [A] + ! Local variables + integer :: k + + check_reconstruction = .false. + + ! Simply checks the internal copy of "u" is exactly equal to "u" + do k = 1, this%n + if ( abs( this%u_mean(k) - u(k) ) > 0. ) check_reconstruction = .true. + enddo + + ! If (u - ul) has the opposite sign from (ur - u), then this cell has an interior extremum + do k = 1, this%n + if ( ( this%u_mean(k) - this%ul(k) ) * ( this%ur(k) - this%u_mean(k) ) < 0. ) check_reconstruction = .true. + enddo + + ! Check bounding of right edges, w.r.t. the cell means + do K = 1, this%n-1 + if ( ( this%ur(k) - this%u_mean(k) ) * ( this%u_mean(k+1) - this%ur(k) ) < 0. ) check_reconstruction = .true. + enddo + + ! Check bounding of left edges, w.r.t. the cell means + do K = 2, this%n + if ( ( this%u_mean(k) - this%ul(k) ) * ( this%ul(k) - this%u_mean(k-1) ) < 0. ) check_reconstruction = .true. + enddo + + ! Check bounding of right edges, w.r.t. this cell mean and the next cell left edge + do K = 1, this%n-1 + if ( ( this%ur(k) - this%u_mean(k) ) * ( this%ul(k+1) - this%ur(k) ) < 0. ) check_reconstruction = .true. + enddo + + ! Check bounding of left edges, w.r.t. this cell mean and the previous cell right edge + do K = 2, this%n + if ( ( this%u_mean(k) - this%ul(k) ) * ( this%ul(k) - this%ur(k-1) ) < 0. ) check_reconstruction = .true. + enddo + +end function check_reconstruction + +!> Runs PPM_H4_2019 reconstruction unit tests and returns True for any fails, False otherwise +logical function unit_tests(this, verbose, stdout, stderr) + class(PPM_H4_2019), intent(inout) :: this !< This reconstruction + logical, intent(in) :: verbose !< True, if verbose + integer, intent(in) :: stdout !< I/O channel for stdout + integer, intent(in) :: stderr !< I/O channel for stderr + ! Local variables + real, allocatable :: ul(:), ur(:), um(:) ! test values [A] + real, allocatable :: ull(:), urr(:) ! test values [A] + type(testing) :: test ! convenience functions + integer :: k + + call test%set( stdout=stdout ) ! Sets the stdout channel in test + call test%set( stderr=stderr ) ! Sets the stderr channel in test + call test%set( verbose=verbose ) ! Sets the verbosity flag in test + + if (verbose) write(stdout,'(a)') 'PPM_H4_2019:unit_tests testing with linear fn' + + call this%init(5) + call test%test( this%n /= 5, 'Setting number of levels') + allocate( um(5), ul(5), ur(5), ull(5), urr(5) ) + + ! Straight line, f(x) = x , or f(K) = 2*K + call this%reconstruct( (/2.,2.,2.,2.,2./), (/1.,3.,5.,7.,9./) ) + call test%real_arr(5, this%u_mean, (/1.,3.,5.,7.,9./), 'Setting cell values') + call test%real_arr(5, this%ul, (/1.,2.,4.,6.,9./), 'Left edge values', robits=2) + call test%real_arr(5, this%ur, (/1.,4.,6.,8.,9./), 'Right edge values') + do k = 1, 5 + um(k) = this%u_mean(k) + enddo + call test%real_arr(5, um, (/1.,3.,5.,7.,9./), 'Return cell mean') + + do k = 1, 5 + ul(k) = this%f(k, 0.) + um(k) = this%f(k, 0.5) + ur(k) = this%f(k, 1.) + enddo + call test%real_arr(5, ul, this%ul, 'Evaluation on left edge') + call test%real_arr(5, um, (/1.,3.,5.,7.,9./), 'Evaluation in center') + call test%real_arr(5, ur, this%ur, 'Evaluation on right edge') + + do k = 1, 5 + ul(k) = this%dfdx(k, 0.) + um(k) = this%dfdx(k, 0.5) + ur(k) = this%dfdx(k, 1.) + enddo + call test%real_arr(5, ul, (/0.,2.,2.,2.,0./), 'dfdx on left edge', robits=3) + call test%real_arr(5, um, (/0.,2.,2.,2.,0./), 'dfdx in center', robits=2) + call test%real_arr(5, ur, (/0.,2.,2.,2.,0./), 'dfdx on right edge', robits=6) + + do k = 1, 5 + um(k) = this%average(k, 0.5, 0.75) ! Average from x=0.25 to 0.75 in each cell + enddo + call test%real_arr(5, um, (/1.,3.25,5.25,7.25,9./), 'Return interval average') + + if (verbose) write(stdout,'(a)') 'PPM_H4_2019:unit_tests testing with parabola' + + ! x = 3 i i=0 at origin + ! f(x) = x^2 / 3 = 3 i^2 + ! f[i] = [ ( 3 i )^3 - ( 3 i - 3 )^3 ] i=1,2,3,4,5 + ! means: 1, 7, 19, 37, 61 + ! edges: 0, 3, 12, 27, 48, 75 + call this%reconstruct( (/3.,3.,3.,3.,3./), (/1.,7.,19.,37.,61./) ) + do k = 1, 5 + ul(k) = this%f(k, 0.) + um(k) = this%f(k, 0.5) + ur(k) = this%f(k, 1.) + enddo + call test%real_arr(5, ul, (/1.,3.,12.,27.,61./), 'Return left edge', robits=2) + call test%real_arr(5, ur, (/1.,12.,27.,48.,61./), 'Return right edge', robits=1) + + call this%destroy() + deallocate( um, ul, ur, ull, urr ) + + unit_tests = test%summarize('PPM_H4_2019:unit_tests') + +end function unit_tests + +!> \namespace recon1d_ppm_c4_2019 +!! + +end module Recon1d_PPM_H4_2019 diff --git a/src/ALE/Recon1d_PPM_hybgen.F90 b/src/ALE/Recon1d_PPM_hybgen.F90 new file mode 100644 index 0000000000..2978dd9269 --- /dev/null +++ b/src/ALE/Recon1d_PPM_hybgen.F90 @@ -0,0 +1,403 @@ +!> Piecewise Parabolic Method 1D reconstruction following Colella and Woodward, 1984 +!! +!! This implementation of PPM follows Colella and Woodward, 1984 \cite colella1984, with +!! cells resorting to PCM for extrema including first and last cells in column. The algorithm was +!! first ported from Hycom as hybgen_ppm_coefs() in the mom_hybgen_remap module. This module is +!! a refactor to facilitate more complete testing and evaluation. +!! +!! The mom_hybgen_remap.hybgen_ppm_coefs() function (reached with "PPM_HYGEN"), +!! regrid_edge_values.edge_values_explicit_h4cw() function followed by ppm_functions.ppm_reconstruction() +!! (reached with "PPM_CW"), are equivalent. Similarly recon1d_ppm_hybgen (this implementation) is equivalent also. +module Recon1d_PPM_hybgen + +! This file is part of MOM6. See LICENSE.md for the license. + +use Recon1d_type, only : testing +use Recon1d_PPM_CW, only : PPM_CW + +implicit none ; private + +public PPM_hybgen, testing + +!> PPM reconstruction following White and Adcroft, 2008 +!! +!! Implemented by extending recon1d_ppm_cwk. +!! +!! The source for the methods ultimately used by this class are: +!! - init() -> recon1d_ppm_cw.init() +!! - reconstruct() *locally defined +!! - average() -> recon1d_ppm_cw.average() +!! - f() -> recon1d_ppm_cw.f() +!! - dfdx() -> recon1d_ppm_cw.dfdx() +!! - check_reconstruction() *locally defined +!! - unit_tests() -> recon1d_ppm_cw.unit_tests() +!! - destroy() -> recon1d_ppm_cw.destroy() +!! - remap_to_sub_grid() -> recon1d_type.remap_to_sub_grid() +!! - init_parent() -> init() +!! - reconstruct_parent() -> reconstruct() +type, extends (PPM_CW) :: PPM_hybgen + +contains + !> Implementation of the PPM_hybgen reconstruction + procedure :: reconstruct => reconstruct + !> Implementation of check reconstruction for the PPM_hybgen reconstruction + procedure :: check_reconstruction => check_reconstruction + !> Implementation of unit tests for the PPM_hybgen reconstruction + procedure :: unit_tests => unit_tests + +end type PPM_hybgen + +contains + +!> Calculate a 1D PPM_hybgen reconstructions based on h(:) and u(:) +subroutine reconstruct(this, h, u) + class(PPM_hybgen), intent(inout) :: this !< This reconstruction + real, intent(in) :: h(*) !< Grid spacing (thickness) [typically H] + real, intent(in) :: u(*) !< Cell mean values [A] + ! Local variables + real :: h0, h1, h2, h3 ! Cell thickness h(k-2), h(k-1), h(k), h(k+1) in K loop [H] + real :: h01_h112, h23_h122 ! Approximately 2/3 [nondim] + real :: h112, h122 ! Approximately 3 h [H] + real :: ddh ! Approximately 0 [nondim] + real :: I_h12, I_h01, I_h0123 ! Reciprocals of d12 and sum(h) [H-1] + real :: dul, dur ! Left and right cell PLM slopes [A] + real :: u0, u1, u2 ! Far left, left, and right cell values [A] + real :: edge ! Edge value between cell k-1 and k [A] + real :: u_min, u_max ! Minimum and maximum value across edge [A] + real :: a6 ! Colella and Woodward curvature [A] + real :: du, duc ! Difference between edges across cell [A] + real :: slp(this%n) ! PLM slope [A] + real :: sigma_l, sigma_c, sigma_r ! Left, central and right slope estimates as + ! differences across the cell [A] + real :: slope_x_h ! retained PLM slope times half grid step [A] + real :: edge_l, edge_r ! Edge values (left and right) [A] + real :: expr1, expr2 ! Temporary expressions [A2] + real :: u0_avg ! avg value at given edge [A] + integer :: k, n, km1, kp1 + + n = this%n + + ! First populate the PLM reconstructions + slp(1) = 0. + do k = 2, n-1 + h0 = max( this%h_neglect, h(k-1) ) + h1 = max( this%h_neglect, h(k) ) + h2 = max( this%h_neglect, h(k+1) ) + dul = u(k) - u(k-1) + dur = u(k+1) - u(k) + h112 = ( 2.0 * h0 + h1 ) + h122 = ( h1 + 2.0 * h2 ) + I_h01 = 1. / ( h0 + h1 ) + I_h12 = 1. / ( h1 + h2 ) + h01_h112 = ( 2.0 * h0 + h1 ) / ( h0 + h1 ) ! When uniform -> 3/2 + h23_h122 = ( 2.0 * h2 + h1 ) / ( h2 + h1 ) ! When uniform -> 3/2 + if ( dul * dur > 0.) then + du = ( h1 / ( h1 + ( h0 + h2 ) ) ) * ( h112 * dur * I_h12 + h122 * dul * I_h01 ) + slp(k) = sign( min( abs(2.0 * dul), abs(du), abs(2.0 * dur) ), du) + else + slp(k) = 0. + endif + enddo + slp(n) = 0. + + this%ul(1) = u(1) ! PCM + this%ur(1) = u(1) ! PCM + this%ul(2) = u(1) ! PCM + do K = 3, n-1 ! K=3 is interface between cells 2 and 3 + h0 = max( this%h_neglect, h(k-2) ) + h1 = max( this%h_neglect, h(k-1) ) + h2 = max( this%h_neglect, h(k) ) + h3 = max( this%h_neglect, h(k+1) ) + h01_h112 = ( h0 + h1 ) / ( 2. * h1 + h2 ) ! When uniform -> 2/3 + h23_h122 = ( h2 + h3 ) / ( h1 + 2. * h2 ) ! When uniform -> 2/3 + ddh = h01_h112 - h23_h122 ! When uniform -> 0 + I_h12 = 1.0 / ( h1 + h2 ) ! When uniform -> 1/(2h) + I_h0123 = 1.0 / ( ( h0 + h1 ) + ( h2 + h3 ) ) ! When uniform -> 1/(4h) + dul = slp(k-1) + dur = slp(k) + u1 = u(k-1) + u2 = u(k) + edge = I_h12 * ( h2 * u1 + h1 * u2 ) & ! 1/2 u1 + 1/2 u2 + + I_h0123 * ( 2.0 * h1 * h2 * I_h12 * ( u2 - u1 ) * ddh & ! 0 + + ( h2 * dul * h23_h122 - h1 * dur * h01_h112 ) ) ! 1/6 dul - 1/6 dur + this%ur(k-1) = edge + this%ul(k) = edge + enddo + this%ur(n-1) = u(n) ! PCM + this%ur(n) = u(n) ! PCM + this%ul(n) = u(n) ! PCM + + do K = 2, n ! K=2 is interface between cells 1 and 2 + u0 = u(k-1) + u1 = u(k) + u2 = u(k+1) + a6 = 3.0 * ( ( u1 - this%ul(k) ) + ( u1 - this%ur(k) ) ) + a6 = 6.0 * u1 - 3.0 * ( this%ul(k) + this%ur(k) ) + du = this%ur(k) - this%ul(k) + if ( ( u2 - u1 ) * ( u1 - u0 ) <- 0.0 ) then ! Large scale extrema + this%ul(k) = u1 + this%ur(k) = u1 + elseif ( du * a6 > du * du ) then ! Extrema on right + edge = 3.0 * u1 - 2.0 * this%ur(k) ! Subject to round off + ! u_min = min( u0, u1 ) + ! u_max = max( u0, u1 ) + ! edge = max( min( edge, u_max), u_min ) + this%ul(k) = edge + elseif ( du * a6 < - du * du ) then ! Extrema on left + edge = 3.0 * u1 - 2.0 * this%ul(k) ! Subject to round off + ! u_min = min( u1, u2 ) + ! u_max = max( u1, u2 ) + ! edge = max( min( edge, u_max), u_min ) + this%ur(k) = edge + endif + enddo + + ! ### Note that the PPM_HYBGEM option calculated the CW PPM coefficients and then + ! invoked the OM4-era limiters afterwards, effectively doing the limiters twice. + ! This second pass does change answers! + + ! Loop on cells to bound edge value + do k = 1, n + + ! For the sake of bounding boundary edge values, the left neighbor of the left boundary cell + ! is assumed to be the same as the left boundary cell and the right neighbor of the right + ! boundary cell is assumed to be the same as the right boundary cell. This effectively makes + ! boundary cells look like extrema. + km1 = max(1,k-1) ; kp1 = min(k+1,N) + + slope_x_h = 0.0 + sigma_l = ( u(k) - u(km1) ) + if ( (h(km1) + h(kp1)) + 2.0*h(k) > 0. ) then + sigma_c = ( u(kp1) - u(km1) ) * ( h(k) / ((h(km1) + h(kp1)) + 2.0*h(k)) ) + else + sigma_c = 0. + endif + sigma_r = ( u(kp1) - u(k) ) + + ! The limiter is used in the local coordinate system to each cell, so for convenience store + ! the slope times a half grid spacing. (See White and Adcroft JCP 2008 Eqs 19 and 20) + if ( (sigma_l * sigma_r) > 0.0 ) & + slope_x_h = sign( min(abs(sigma_l),abs(sigma_c),abs(sigma_r)), sigma_c ) + + ! Limit the edge values + if ( (u(km1)-this%ul(k)) * (this%ul(k)-u(k)) < 0.0 ) then + this%ul(k) = u(k) - sign( min( abs(slope_x_h), abs(this%ul(k)-u(k)) ), slope_x_h ) + endif + + if ( (u(kp1)-this%ur(k)) * (this%ur(k)-u(k)) < 0.0 ) then + this%ur(k) = u(k) + sign( min( abs(slope_x_h), abs(this%ur(k)-u(k)) ), slope_x_h ) + endif + + ! Finally bound by neighboring cell means in case of roundoff + this%ul(k) = max( min( this%ul(k), max(u(km1), u(k)) ), min(u(km1), u(k)) ) + this%ur(k) = max( min( this%ur(k), max(u(kp1), u(k)) ), min(u(kp1), u(k)) ) + + enddo ! loop on interior edges + + do k = 1, n-1 + if ( (this%ul(k+1) - this%ur(k)) * (u(k+1) - u(k)) < 0.0 ) then + u0_avg = 0.5 * ( this%ur(k) + this%ul(k+1) ) + u0_avg = max( min( u0_avg, max(u(k), u(k+1)) ), min(u(k), u(k+1)) ) + this%ur(k) = u0_avg + this%ul(k+1) = u0_avg + endif + enddo ! end loop on interior edges + + ! Loop on interior cells to apply the standard + ! PPM limiter (Colella & Woodward, JCP 84) + do k = 2, n-1 + + ! Get cell averages + u0 = u(k-1) + u1 = u(k) + u2 = u(k+1) + + edge_l = this%ul(k) + edge_r = this%ur(k) + + if ( (u2 - u1)*(u1 - u0) <= 0.0) then + ! Flatten extremum + edge_l = u1 + edge_r = u1 + else + expr1 = 3.0 * (edge_r - edge_l) * ( (u1 - edge_l) + (u1 - edge_r)) + expr2 = (edge_r - edge_l) * (edge_r - edge_l) + if ( expr1 > expr2 ) then + ! Place extremum at right edge of cell by adjusting left edge value + edge_l = u1 + 2.0 * ( u1 - edge_r ) + edge_l = max( min( edge_l, max(u0, u1) ), min(u0, u1) ) ! In case of round off + elseif ( expr1 < -expr2 ) then + ! Place extremum at left edge of cell by adjusting right edge value + edge_r = u1 + 2.0 * ( u1 - edge_l ) + edge_r = max( min( edge_r, max(u2, u1) ), min(u2, u1) ) ! In case of round off + endif + endif + ! This checks that the difference in edge values is representable + ! and avoids overshoot problems due to round off. + !### The 1.e-60 needs to have units of [A], so this dimensionally inconsistent. + if ( abs( edge_r - edge_l ) Checks the PPM_hybgen reconstruction for consistency +logical function check_reconstruction(this, h, u) + class(PPM_hybgen), intent(in) :: this !< This reconstruction + real, intent(in) :: h(*) !< Grid spacing (thickness) [typically H] + real, intent(in) :: u(*) !< Cell mean values [A] + ! Local variables + integer :: k + + check_reconstruction = .false. + + ! Simply checks the internal copy of "u" is exactly equal to "u" + do k = 1, this%n + if ( abs( this%u_mean(k) - u(k) ) > 0. ) check_reconstruction = .true. + enddo + + ! If (u - ul) has the opposite sign from (ur - u), then this cell has an interior extremum + do k = 1, this%n + if ( ( this%u_mean(k) - this%ul(k) ) * ( this%ur(k) - this%u_mean(k) ) < 0. ) check_reconstruction = .true. + enddo + + ! The following consistency checks would fail for this implementation of PPM CW, + ! due to round off in the final limiter violating the monotonicity of edge values, + ! but actually passes due to the second pass of the limiters with explicit bounding. + ! i.e. This implementation cheats! + + ! Check bounding of right edges, w.r.t. the cell means + do K = 1, this%n-1 + if ( ( this%ur(k) - this%u_mean(k) ) * ( this%u_mean(k+1) - this%ur(k) ) < 0. ) check_reconstruction = .true. + enddo + + ! Check bounding of left edges, w.r.t. the cell means + do K = 2, this%n + if ( ( this%u_mean(k) - this%ul(k) ) * ( this%ul(k) - this%u_mean(k-1) ) < 0. ) check_reconstruction = .true. + enddo + + ! Check bounding of right edges, w.r.t. this cell mean and the next cell left edge + do K = 1, this%n-1 + if ( ( this%ur(k) - this%u_mean(k) ) * ( this%ul(k+1) - this%ur(k) ) < 0. ) check_reconstruction = .true. + enddo + + ! Check bounding of left edges, w.r.t. this cell mean and the previous cell right edge + do K = 2, this%n + if ( ( this%u_mean(k) - this%ul(k) ) * ( this%ul(k) - this%ur(k-1) ) < 0. ) check_reconstruction = .true. + enddo + +end function check_reconstruction + +!> Runs PPM_hybgen reconstruction unit tests and returns True for any fails, False otherwise +logical function unit_tests(this, verbose, stdout, stderr) + class(PPM_hybgen), intent(inout) :: this !< This reconstruction + logical, intent(in) :: verbose !< True, if verbose + integer, intent(in) :: stdout !< I/O channel for stdout + integer, intent(in) :: stderr !< I/O channel for stderr + ! Local variables + real, allocatable :: ul(:), ur(:), um(:) ! test values [A] + real, allocatable :: ull(:), urr(:) ! test values [A] + type(testing) :: test ! convenience functions + integer :: k + + call test%set( stdout=stdout ) ! Sets the stdout channel in test + call test%set( stderr=stderr ) ! Sets the stderr channel in test + call test%set( verbose=verbose ) ! Sets the verbosity flag in test + + if (verbose) write(stdout,'(a)') 'PPM_hybgen:unit_tests testing with linear fn' + + call this%init(5) + call test%test( this%n /= 5, 'Setting number of levels') + allocate( um(5), ul(5), ur(5), ull(5), urr(5) ) + + ! Straight line, f(x) = x , or f(K) = 2*K + call this%reconstruct( (/2.,2.,2.,2.,2./), (/1.,4.,7.,10.,13./) ) + call test%real_arr(5, this%u_mean, (/1.,4.,7.,10.,13./), 'Setting cell values') + ! Without PLM extrapolation we get l(2)=2 and r(4)=12 due to PLM=0 in boundary cells. -AJA + call test%real_arr(5, this%ul, (/1.,1.,5.5,8.5,13./), 'Left edge values') + call test%real_arr(5, this%ur, (/1.,5.5,8.5,13.,13./), 'Right edge values') + + do k = 1, 5 + ul(k) = this%f(k, 0.) + um(k) = this%f(k, 0.5) + ur(k) = this%f(k, 1.) + enddo + call test%real_arr(5, ul, this%ul, 'Evaluation on left edge') + call test%real_arr(5, um, (/1.,4.375,7.,9.625,13./), 'Evaluation in center') + call test%real_arr(5, ur, this%ur, 'Evaluation on right edge') + + do k = 1, 5 + ul(k) = this%dfdx(k, 0.) + um(k) = this%dfdx(k, 0.5) + ur(k) = this%dfdx(k, 1.) + enddo + ! Most of these values are affected by the PLM boundary cells + call test%real_arr(5, ul, (/0.,0.,3.,9.,0./), 'dfdx on left edge') + call test%real_arr(5, um, (/0.,4.5,3.,4.5,0./), 'dfdx in center') + call test%real_arr(5, ur, (/0.,9.,3.,0.,0./), 'dfdx on right edge') + + do k = 1, 5 + um(k) = this%average(k, 0.5, 0.75) ! Average from x=0.25 to 0.75 in each cell + enddo + ! Most of these values are affected by the PLM boundary cells + call test%real_arr(5, um, (/1.,4.84375,7.375,10.28125,13./), 'Return interval average') + + if (verbose) write(stdout,'(a)') 'PPM_hybgen:unit_tests testing with parabola' + + ! x = 2 i i=0 at origin + ! f(x) = 3/4 x^2 = (2 i)^2 + ! f[i] = 3/4 ( 2 i - 1 )^2 on centers + ! f[I] = 3/4 ( 2 I )^2 on edges + ! f[i] = 1/8 [ x^3 ] for means + ! edges: 0, 1, 12, 27, 48, 75 + ! means: 1, 7, 19, 37, 61 + ! cengters: 0.75, 6.75, 18.75, 36.75, 60.75 + call this%reconstruct( (/2.,2.,2.,2.,2./), (/1.,7.,19.,37.,61./) ) + do k = 1, 5 + ul(k) = this%f(k, 0.) + um(k) = this%f(k, 0.5) + ur(k) = this%f(k, 1.) + enddo + call test%real_arr(5, ul, (/1.,1.,12.,27.,61./), 'Return left edge') + call test%real_arr(5, um, (/1.,7.25,18.75,34.5,61./), 'Return center') + call test%real_arr(5, ur, (/1.,12.,27.,57.,61./), 'Return right edge') + + ! x = 3 i i=0 at origin + ! f(x) = x^2 / 3 = 3 i^2 + ! f[i] = [ ( 3 i )^3 - ( 3 i - 3 )^3 ] i=1,2,3,4,5 + ! means: 1, 7, 19, 37, 61 + ! edges: 0, 3, 12, 27, 48, 75 + call this%reconstruct( (/3.,3.,3.,3.,3./), (/1.,7.,19.,37.,61./) ) + do k = 1, 5 + ul(k) = this%f(k, 0.) + um(k) = this%f(k, 0.5) + ur(k) = this%f(k, 1.) + enddo + call test%real_arr(5, ul, (/1.,1.,12.,27.,61./), 'Return left edge') + call test%real_arr(5, ur, (/1.,12.,27.,57.,61./), 'Return right edge') + + call this%destroy() + deallocate( um, ul, ur, ull, urr ) + + unit_tests = test%summarize('PPM_hybgen:unit_tests') + +end function unit_tests + +!> \namespace recon1d_ppm_hybgen +!! + +end module Recon1d_PPM_hybgen diff --git a/src/ALE/Recon1d_type.F90 b/src/ALE/Recon1d_type.F90 new file mode 100644 index 0000000000..4411e1288e --- /dev/null +++ b/src/ALE/Recon1d_type.F90 @@ -0,0 +1,324 @@ +!> A generic type for vertical 1D reconstructions +module Recon1d_type + +! This file is part of MOM6. See LICENSE.md for the license. + +use numerical_testing_type, only : testing + +implicit none ; private + +public Recon1d +public testing + +!> The base class for implementations of 1D reconstructions +type, abstract :: Recon1d + + integer :: n = 0 !< Number of cells in column + real, allocatable, dimension(:) :: u_mean !< Cell mean [A] + real :: h_neglect = 0. !< A negligibly small width used in cell reconstructions [same as h, H] + logical :: check = .false. !< If true, enable some consistency checking + + logical :: debug = .false. !< If true, dump info as calculations are made (do not enable) +contains + + ! The following functions/subroutines are deferred and must be provided specifically by each scheme + + !> Deferred implementation of initialization + procedure(i_init), deferred :: init + !> Deferred implementation of reconstruction function + procedure(i_reconstruct), deferred :: reconstruct + !> Deferred implementation of the average over an interval + procedure(i_average), deferred :: average + !> Deferred implementation of evaluating the reconstruction at a point + procedure(i_f), deferred :: f + !> Deferred implementation of the derivative of the reconstruction at a point + procedure(i_dfdx), deferred :: dfdx + !> Deferred implementation of check_reconstruction + !! + !! Returns True if a check fails. Returns False if all checks pass. + !! Checks are about internal, or inferred, state for arbitrary inputs. + !! Checks should cover all the expected properties of a reconstruction. + procedure(i_check_reconstruction), deferred :: check_reconstruction + !> Deferred implementation of unit tests for the reconstruction + !! + !! Returns True if a test fails. Returns False if all tests pass. + !! Tests in unit_tests() are usually checks against known (e.g. analytic) solutions. + procedure(i_unit_tests), deferred :: unit_tests + !> Deferred implementation of deallocation + procedure(i_destroy), deferred :: destroy + + ! The following functions/subroutines are shared across all reconstructions and provided by this module + ! unless replaced for the purpose of optimization + + !> Remaps the column to subgrid h_sub + procedure :: remap_to_sub_grid => remap_to_sub_grid + !> Set debugging + procedure :: set_debug => a_set_debug + + ! The following functions usually point to the same implementation as above but + ! for derived secondary children these allow invocation of the parent class function. + + !> Second interface to init(), used to reach the primary class if derived from a primary implementation + procedure(i_init_parent), deferred :: init_parent + !> Second interface to reconstruct(), used to reach the primary class if derived from a primary implementation + procedure(i_reconstruct_parent), deferred :: reconstruct_parent + +end type Recon1d + +interface + + !> Initialize a 1D reconstruction for n cells + subroutine i_init(this, n, h_neglect, check) + import :: Recon1d + class(Recon1d), intent(out) :: this !< This reconstruction + integer, intent(in) :: n !< Number of cells in this column + real, optional, intent(in) :: h_neglect !< A negligibly small width used in cell reconstructions [H] + logical, optional, intent(in) :: check !< If true, enable some consistency checking + end subroutine i_init + + !> Calculate a 1D reconstructions based on h(:) and u(:) + subroutine i_reconstruct(this, h, u) + import :: Recon1d + class(Recon1d), intent(inout) :: this !< This reconstruction + real, intent(in) :: h(*) !< Grid spacing (thickness) [typically H] + real, intent(in) :: u(*) !< Cell mean values [A] + end subroutine i_reconstruct + + !> Average between xa and xb for cell k of a 1D reconstruction [A] + !! + !! It is assumed that 0<=xa<=1, 0<=xb<=1, and xa<=xb + real function i_average(this, k, xa, xb) + import :: Recon1d + class(Recon1d), intent(in) :: this !< This reconstruction + integer, intent(in) :: k !< Cell number + real, intent(in) :: xa !< Start of averaging interval on element (0 to 1) + real, intent(in) :: xb !< End of averaging interval on element (0 to 1) + end function i_average + + !> Point-wise value of reconstruction [A] + !! + !! THe function is only valid for 0 <= x <= 1. x is effectively clipped to this range. + real function i_f(this, k, x) + import :: Recon1d + class(Recon1d), intent(in) :: this !< This reconstruction + integer, intent(in) :: k !< Cell number + real, intent(in) :: x !< Non-dimensional position within element [nondim] + end function i_f + + !> Point-wise value of derivative reconstruction [A] + !! + !! THe function is only valid for 0 <= x <= 1. x is effectively clipped to this range. + real function i_dfdx(this, k, x) + import :: Recon1d + class(Recon1d), intent(in) :: this !< This reconstruction + integer, intent(in) :: k !< Cell number + real, intent(in) :: x !< Non-dimensional position within element [nondim] + end function i_dfdx + + !> Returns true if some inconsistency is detected, false otherwise + !! + !! The nature of "consistency" is defined by the implementations + !! and might be no-ops. + logical function i_check_reconstruction(this, h, u) + import :: Recon1d + class(Recon1d), intent(in) :: this !< This reconstruction + real, intent(in) :: h(*) !< Grid spacing (thickness) [typically H] + real, intent(in) :: u(*) !< Cell mean values [A] + end function i_check_reconstruction + + !> Deallocate a 1D reconstruction + subroutine i_destroy(this) + import :: Recon1d + class(Recon1d), intent(inout) :: this !< This reconstruction + end subroutine i_destroy + + !> Second interface to init(), or to parent init() + subroutine i_init_parent(this, n, h_neglect, check) + import :: Recon1d + class(Recon1d), intent(out) :: this !< This reconstruction + integer, intent(in) :: n !< Number of cells in this column + real, optional, intent(in) :: h_neglect !< A negligibly small width used in cell reconstructions [H] + logical, optional, intent(in) :: check !< If true, enable some consistency checking + end subroutine i_init_parent + + !> Second interface to reconstruct(), or to parent reconstruct() + subroutine i_reconstruct_parent(this, h, u) + import :: Recon1d + class(Recon1d), intent(inout) :: this !< This reconstruction + real, intent(in) :: h(*) !< Grid spacing (thickness) [typically H] + real, intent(in) :: u(*) !< Cell mean values [A] + end subroutine i_reconstruct_parent + + !> Runs reconstruction unit tests and returns True for any fails, False otherwise + !! + !! Assumes single process/thread context + logical function i_unit_tests(this, verbose, stdout, stderr) + import :: Recon1d + class(Recon1d), intent(inout) :: this !< This reconstruction + logical, intent(in) :: verbose !< True, if verbose + integer, intent(in) :: stdout !< I/O channel for stdout + integer, intent(in) :: stderr !< I/O channel for stderr + end function i_unit_tests + +end interface + +contains + +!> Remaps the column to subgrid h_sub +!! +!! It is assumed that h_sub is a perfect sub-grid of h0, meaning each h0 cell +!! can be constructed by joining a contiguous set of h_sub cells. The integer +!! indices isrc_start, isrc_end, isub_src provide this mapping, and are +!! calculated in MOM_remapping +subroutine remap_to_sub_grid(this, h0, u0, n1, h_sub, & + isrc_start, isrc_end, isrc_max, isub_src, & + u_sub, uh_sub, u02_err) + class(Recon1d), intent(in) :: this !< 1-D reconstruction type + real, intent(in) :: h0(*) !< Source grid widths (size n0) [H] + real, intent(in) :: u0(*) !< Source grid widths (size n0) [H] + integer, intent(in) :: n1 !< Number of cells in target grid + real, intent(in) :: h_sub(*) !< Overlapping sub-cell thicknesses, h_sub [H] + integer, intent(in) :: isrc_start(*) !< Index of first sub-cell within each source cell + integer, intent(in) :: isrc_end(*) !< Index of last sub-cell within each source cell + integer, intent(in) :: isrc_max(*) !< Index of thickest sub-cell within each source cell + integer, intent(in) :: isub_src(*) !< Index of source cell for each sub-cell + real, intent(out) :: u_sub(*) !< Sub-cell cell averages (size n1) [A] + real, intent(out) :: uh_sub(*) !< Sub-cell cell integrals (size n1) [A H] + real, intent(out) :: u02_err !< Integrated reconstruction error estimates [A H] + ! Local variables + integer :: i_sub ! Index of sub-cell + integer :: i0 ! Index into h0(1:n0), source column + integer :: i_max ! Used to record which sub-cell is the largest contribution of a source cell + real :: dh_max ! Used to record which sub-cell is the largest contribution of a source cell [H] + real :: xa, xb ! Non-dimensional position within a source cell (0..1) [nondim] + real :: dh ! The width of the sub-cell [H] + real :: duh ! The total amount of accumulated stuff (u*h) [A H] + real :: dh0_eff ! Running sum of source cell thickness [H] + integer :: i0_last_thick_cell, n0 +! real :: u0_min(this%n), u0_max(this%n) ! Min/max of u0 for each source cell [A] +! real :: ul,ur ! Left/right edge values [A] + + n0 = this%n + + i0_last_thick_cell = 0 + do i0 = 1, n0 +! ul = this%f(i0, 0.) +! ur = this%f(i0, 1.) +! u0_min(i0) = min(ul, ur) +! u0_max(i0) = max(ul, ur) + if (h0(i0)>0.) i0_last_thick_cell = i0 + enddo + + ! Loop over each sub-cell to calculate average/integral values within each sub-cell. + ! Uses: h_sub, isub_src, h0_eff + ! Sets: u_sub, uh_sub + xa = 0. + dh0_eff = 0. + u02_err = 0. + do i_sub = 1, n0+n1 + + ! Sub-cell thickness from loop above + dh = h_sub(i_sub) + + ! Source cell + i0 = isub_src(i_sub) + + ! Evaluate average and integral for sub-cell i_sub. + ! Integral is over distance dh but expressed in terms of non-dimensional + ! positions with source cell from xa to xb (0 <= xa <= xb <= 1). + dh0_eff = dh0_eff + dh ! Cumulative thickness within the source cell + if (h0(i0)>0.) then + xb = dh0_eff / h0(i0) ! This expression yields xa <= xb <= 1.0 + xb = min(1., xb) ! This is only needed when the total target column is wider than the source column + u_sub(i_sub) = this%average( i0, xa, xb ) + else ! Vanished cell + xb = 1. + u_sub(i_sub) = u0(i0) + endif +! u_sub(i_sub) = max( u_sub(i_sub), u0_min(i0) ) +! u_sub(i_sub) = min( u_sub(i_sub), u0_max(i0) ) + uh_sub(i_sub) = dh * u_sub(i_sub) + + if (isub_src(i_sub+1) /= i0) then + ! If the next sub-cell is in a different source cell, reset the position counters + dh0_eff = 0. + xa = 0. + else + xa = xb ! Next integral will start at end of last + endif + + enddo + i_sub = n0+n1+1 + ! Sub-cell thickness from loop above + dh = h_sub(i_sub) + ! Source cell + i0 = isub_src(i_sub) + + ! Evaluate average and integral for sub-cell i_sub. + ! Integral is over distance dh but expressed in terms of non-dimensional + ! positions with source cell from xa to xb (0 <= xa <= xb <= 1). + dh0_eff = dh0_eff + dh ! Cumulative thickness within the source cell + if (h0(i0)>0.) then + xb = dh0_eff / h0(i0) ! This expression yields xa <= xb <= 1.0 + xb = min(1., xb) ! This is only needed when the total target column is wider than the source column + u_sub(i_sub) = this%average( i0, xa, xb ) + else ! Vanished cell + xb = 1. + u_sub(i_sub) = u0(i0) + endif +! u_sub(i_sub) = max( u_sub(i_sub), u0_min(i0) ) +! u_sub(i_sub) = min( u_sub(i_sub), u0_max(i0) ) + uh_sub(i_sub) = dh * u_sub(i_sub) + + ! Loop over each source cell substituting the integral/average for the thickest sub-cell (within + ! the source cell) with the residual of the source cell integral minus the other sub-cell integrals + ! aka a genius algorithm for accurate conservation when remapping from Robert Hallberg (\@Hallberg-NOAA). + ! Uses: i0_last_thick_cell, isrc_max, h_sub, isrc_start, isrc_end, uh_sub, u0, h0 + ! Updates: uh_sub + do i0 = 1, i0_last_thick_cell + i_max = isrc_max(i0) + dh_max = h_sub(i_max) + if (dh_max > 0.) then + ! duh will be the sum of sub-cell integrals within the source cell except for the thickest sub-cell. + duh = 0. + do i_sub = isrc_start(i0), isrc_end(i0) + if (i_sub /= i_max) duh = duh + uh_sub(i_sub) + enddo + uh_sub(i_max) = u0(i0)*h0(i0) - duh + u02_err = u02_err + max( abs(uh_sub(i_max)), abs(u0(i0)*h0(i0)), abs(duh) ) + endif + enddo + + ! This should not generally be used + if (this%check) then + if ( this%check_reconstruction(h0, u0) ) stop 910 ! A debugger is required to understand why this failed + endif + +end subroutine remap_to_sub_grid + +!> Turns on debugging +subroutine a_set_debug(this) + class(Recon1d), intent(inout) :: this !< 1-D reconstruction type + + this%debug = .true. + +end subroutine a_set_debug + +!> \namespace recon1d_type +!! +!! \section section_recon1d_type Generic vertical reconstruction type +!! +!! A class to describe generic reconstruction in 1-D. This module has no implementations +!! but defines the interfaces for members that implement a reconstruction. +!! +!! e.g. a chain of derived reconstructions might look like +!! Recon1d_type <- Recond1d_XYZ <- Recon1d_XYZ_v2 +!! where +!! Recon1d_type - defines the interfaces (this module) +!! Recon1d_XYZ - extends Recon1d_type, implements the XYZ reconstruction in reconstruct(), +!! and reconstruc_parent() -> reconstruct() of the same Recon1d_XYZ module +!! Recon1d_XYZ_v2 - implements a slight variant of Recon1d_XYZ via reconstruct() +!! but reconstruc_parent() is not redefined so that it still is defined by Recon1d_XYZ +!! +!! The schemes that use this structure are described in \ref Vertical_Reconstruction +end module Recon1d_type diff --git a/src/ALE/_Vertical_Reconstruction.dox b/src/ALE/_Vertical_Reconstruction.dox new file mode 100644 index 0000000000..4db5261b16 --- /dev/null +++ b/src/ALE/_Vertical_Reconstruction.dox @@ -0,0 +1,92 @@ +/*! \page Vertical_Reconstruction Vertical Reconstruction + +\section section_vertical_reconstruction Vertical Reconstruction Methods + +Within the ALE or Lagrangian Remap Method (LRM), the structure of fields within cells (or layers in the case of MOM6) are reconstructed from the resolved cell means (i.e. the model variables). +The most widely used reconstructions use a piecewise polynomial representation for the reconstruction within each cell. +The simplest of these is the Piecewise Constant Method (PCM) which simply uses the cell mean value as a constant value throughout the cell. +The reconstructed fields may be discontinuous across cell boundaries, which is inherently the case for PCM. +PCM is a first order method and considered too diffusive for ALE, although it is the implicit representation in the traditional "layered" mode. +A second order reconstruction if the Piecewise Linear Method (PLM) of Van Leer, 1977 \cite van_leer_1977. +Higher order reconstructions are the Piecwise Parabloic Method (PPM) of Colella and Woodward, 1984 \cite colella1984, and the Piecwise Quartic Method (PQM) of White and Adcroft, 2008 \cite white2008. + +\section section_vertical_reconstruction_implementation Implementation + +The original implementations of vertical reconstructions are available in the `src/ALE` directory via modules such as plm_functions, ppm_functions, regrid_edge_values, etc. +These versions were used in OM4 \cite Adcroft2019 but later found to have inaccuracies with regard to round-off errors that could lead to non-monotonic behaviors. +A revision of the schemes was made available after comparing and porting from Hycom and are available via modules such as mom_hybgen_remap. +A recent refactoring of reconstructions for remapping was implemented via classes derived from the recon1d_type (also in `src/ALE` directory). + +The following table summarizes the OM4-era and Hycom-ported methods and routines, all selected by the runtime parameter `REMAPPING_SCHEME`. +The branch points (`select case`) in the code are in mom_remapping::build_reconstructions_1d(). + +REMAPPING_SCHEME | Description | Functions invoked (from MOM_remapping::build_reconstructions_1d()) +:--------------: | :---------- | :----------------------------------------------------------------- +PCM | Piecewise Constant Method | pcm_functions::pcm_reconstruction() +PLM | Monotonized Piecewise Linear Method \cite white2008 | plm_functions::plm_reconstruction() (calls plm_functions::plm_slope_wa() and plm_functions::plm_monotonized_slope()) (opt. plm_functions::plm_boundary_extrapolation()) +PLM_HYBGEN | Piecewise Linear Method, ported from Hycom \cite colella1984 | mom_hybgen_remap::hybgen_plm_coefs() (opt. plm_functions::plm_boundary_extrapolation()) +PPM_H4 | Piecewise Parabolic Method with explicit 4th order edge values \cite white2008 | regrid_edge_values::edge_values_explicit_h4() ppm_functions::ppm_reconstruction() (opt. ppm_functions::ppm_boundary_extrapolation()) +PPM_IH4 | Piecewise Parabolic Method with implicit 4th order edge values \cite white2008 | regrid_edge_values::edge_values_implicit_h4() ppm_functions::ppm_reconstruction() (opt. ppm_functions::ppm_boundary_extrapolation()) +PPM_HYBGEN | Piecewise Parabolic Method with quasi-4th order edge values using PLM \cite colella1984 | mom_hybgen_remap::hybgen_ppm_coefs() (opt. ppm_functions::ppm_boundary_extrapolation()) +PPM_CW | (should be equivalent to PPM_HYBGEN) | regrid_edge_values::edge_values_explicit_h4cw() ppm_functions::ppm_monotonicity() ppm_functions::ppm_reconstruction() (calls ppm_functions::ppm_limiter_standard()) (opt. ppm_functions::ppm_boundary_extrapolation()) +WENO_HYBGEN | Piecewise Parabolic Method with WENO edge values, ported from Hycom | mom_hybgen_remap::hybgen_weno_coefs() ppm_functions::ppm_reconstruction() (calls ppm_functions::ppm_limiter_standard()) (opt. ppm_functions::ppm_boundary_extrapolation()) +PQM_IH4IH3 | Piecewise Quartic Method with implicit quasi-4th order edge values and 3rd order edge slopes \cite white2008 | regrid_edge_values::edge_values_implicit_h4() regrid_edge_values::edge_slopes_implicit_h3() pqm_functions::pqm_reconstruction() (calls pqm_functions::pqm_limiter()) (opt. pqm_functions::pqm_boundary_extrapolation_v1()) +PQM_IH6IH5 | Piecewise Quartic Method with implicit quasi-6th order edge values and 5rd order edge slopes \cite white2008 | regrid_edge_values::edge_values_implicit_h6() regrid_edge_values::edge_slopes_implicit_h5() pqm_functions::pqm_reconstruction() (calls pqm_functions::pqm_limiter()) (opt. pqm_functions::pqm_boundary_extrapolation_v1()) + +The following table summarizes the newly refactored methods based on the class recon1d_type::recon1d. +These are also controlled by the runtime parameter `REMAPPING_SCHEME` but the branch point is in the form of a type allocation during initialization in mom_remapping::setreconstructiontype(). + +REMAPPING_SCHEME | Description | Module +:--------------: | :---------- | :----- +C_PCM | Piecewise Constant Method (equivalent to PCM) | recon1d_pcm +C_PLM_CW | Piecewise Linear Method (faithful to Colella and Woodward \cite colella1984) | recon1d_plm_cw +C_PLM_HYBGEN | PLM (equivalent to PLM_HYBGEN) | recon1d_plm_hybgen +C_MPLM_WA | Monotonized Piecewise Linear Method (faithful to White and Adcroft \cite white2008) | recon1d_mplm_wa +C_MPLM_WA_POLY | MPLM using polynomial representation (euivalent to PLM) | recon1d_mplm_wa_poly +C_EMPLM_WA | Boundary extrapolation of MPLM_WA (faithful to White and Adcroft \cite white2008) | recon1d_emplm_wa +C_EMPLM_WA_POLY | Boundary extrapolation of MPLM using polynomial repesentation (equivalent to PLM) | recon1d_emplm_wa_poly +C_PLM_CWK | Piecewise Linear Method in index space (grid independent) | recon1d_plm_cwk +C_MPLM_CWK | Monotonized Piecewise Linear Method in index space (grid independent) | recon1d_mplm_cwk +C_EMPLM_CWK | Boundary extrapolatino of Monotonized Piecewise Linear Method in index space (grid independent) | recon1d_emplm_cwk +C_PPM_CW | Piecewise Linear Method (faithful to Colella and Woodward \cite colella1984) | recon1d_ppm_cw +C_PPM_HYBGEN | PPM (equivalent to PPM_HYBGEN) | recon1d_ppm_hybgen +C_PPM_H4_2018 | (equivalent to PPM_H4 with answers circa 2018) | recon1d_ppm_h4_2018 +C_PPM_H4_2019 | (equivalent to PPM_H4 with answers post 2019) | recon1d_ppm_h4_2019 +C_PPM_CWK | Piecewise Parabolic Method in index space (grid independent) | recon1d_ppm_cwk +C_EPPM_CWK | Piecewise Parabolic Method in index space (grid independent) | recon1d_eppm_cwk (extends recon1d_ppm_cwk) + +The motivation for some of the schemes in the last table was to recover certain numerical of computationsl properties, summarized in the next table. + +REMAPPING_SCHEME | Representation | Globally monotonic | Consistent | Grid dependent | Uniform test +:--------------: | :------------- | :----------------- | :--------- | :------------- | :----------- +PCM | Single scalar | Yes | Yes | No | Pass +PLM | Polynomial | Forced | | Yes | Fail +PLM_HYBGEN | Polynomial | No | | Yes | Fail +PPM_H4 | Edge values | | | Yes | Fail +PPM_IH4 | Edge values | | | Yes | Fail +PPM_HYBGEN | Edge values | | | Yes | Fail +PPM_CW | Edge values | | | Yes | Fail +WENO_HYBGEN | Edge values | | | Yes | Fail +PQM_IH4IH3 | Polynomial | | | Yes | Fail +PQM_IH6IH5 | Polynomial | | | Yes | Fail +C_PCM | Single scalar | Yes | Yes | No | Pass +C_PLM_CW | Edge values | No | Yes | Yes | Pass +C_PLM_HYBGEN | Edge values | No | Yes | Yes | Pass +C_MPLM_WA | Edge values | Yes | No | Yes | Pass +C_MPLM_WA_POLY | Polynomial | Yes | * | Yes | Pass +C_EMPLM_WA | Edge values | Yes | No | Yes | Pass +C_EMPLM_WA_POLY | Polynomial | No | | Yes | Pass +C_PLM_CWK | Edge values | Yes | Yes | No | Pass +C_MPLM_CWK | Edge values | Yes | Yes | No | Pass +C_EMPLM_CWK | Edge values | Yes | Yes | No | Pass +C_PPM_CW | Edge values | Yes | Yes | Yes | Pass +C_PPM_HYBGEN | Edge values | * forced | Yes | Yes | Pass +C_PPM_H4_2018 | Edge values | * forced | | Yes | Pass +C_PPM_H4_2019 | Edge values | * forced | Yes | Yes | Pass +C_PPM_CWK | Edge values | Yes | Yes | No | Pass +C_EPPM_CWK | Edge values | Yes | Yes | No | Pass + +The OM4-era schemes calculate values via the function mom_remapping::average_value_ppoly() which uses reconstructions stored as the corresponding polynomial coefficients for PLM and PQM, but uses edge values for PPM. +The newer class-based schemes use edge values to store the reconstructions for all schemes (except where replicating the OM4-era schemes). + +*/ diff --git a/src/ALE/remapping_attic.F90 b/src/ALE/remapping_attic.F90 deleted file mode 100644 index ab345dc53e..0000000000 --- a/src/ALE/remapping_attic.F90 +++ /dev/null @@ -1,653 +0,0 @@ -!> Retains older versions of column-wise vertical remapping functions that are -!! no longer used in MOM6, but may be useful later for documenting the development -!! of the schemes that are used in MOM6. -module remapping_attic - -! This file is part of MOM6. See LICENSE.md for the license. -! Original module written by Laurent White, 2008.06.09 - -use MOM_error_handler, only : MOM_error, FATAL -use MOM_io, only : stdout -use PPM_functions, only : PPM_reconstruction, PPM_boundary_extrapolation -use regrid_edge_values, only : edge_values_explicit_h4 - -implicit none ; private - -! The following routines are visible to the outside world -public remapping_attic_unit_tests, remapByProjection, remapByDeltaZ -public isPosSumErrSignificant - -! The following are private parameter constants -integer, parameter :: INTEGRATION_PCM = 0 !< Piecewise Constant Method -integer, parameter :: INTEGRATION_PLM = 1 !< Piecewise Linear Method -integer, parameter :: INTEGRATION_PPM = 3 !< Piecewise Parabolic Method -integer, parameter :: INTEGRATION_PQM = 5 !< Piecewise Quartic Method - -! This CPP macro turns on/off bounding of integrations limits so that they are -! always within the cell. Roundoff can lead to the non-dimensional bounds being -! outside of the range 0 to 1. -#define __USE_ROUNDOFF_SAFE_ADJUSTMENTS__ - -contains - -!> Compare two summation estimates of positive data and judge if due to more -!! than round-off. -!! When two sums are calculated from different vectors that should add up to -!! the same value, the results can differ by round off. The round off error -!! can be bounded to be proportional to the number of operations. -!! This function returns true if the difference between sum1 and sum2 is -!! larger than than the estimated round off bound. -!! \note This estimate/function is only valid for summation of positive data. -function isPosSumErrSignificant(n1, sum1, n2, sum2) - integer, intent(in) :: n1 !< Number of values in sum1 - integer, intent(in) :: n2 !< Number of values in sum2 - real, intent(in) :: sum1 !< Sum of n1 values in arbitrary units [A] - real, intent(in) :: sum2 !< Sum of n2 values [A] - logical :: isPosSumErrSignificant !< True if difference in sums is large - ! Local variables - real :: sumErr ! The absolutde difference in the sums [A] - real :: allowedErr ! The tolerance for the integrated reconstruction [A] - real :: eps ! A tiny fractional error [nondim] - - if (sum1<0.) call MOM_error(FATAL,'isPosSumErrSignificant: sum1<0 is not allowed!') - if (sum2<0.) call MOM_error(FATAL,'isPosSumErrSignificant: sum2<0 is not allowed!') - sumErr = abs(sum1-sum2) - eps = epsilon(sum1) - allowedErr = eps*0.5*(real(n1-1)*sum1+real(n2-1)*sum2) - if (sumErr>allowedErr) then - write(0,*) 'isPosSumErrSignificant: sum1,sum2=',sum1,sum2 - write(0,*) 'isPosSumErrSignificant: eps=',eps - write(0,*) 'isPosSumErrSignificant: err,n*eps=',sumErr,allowedErr - write(0,*) 'isPosSumErrSignificant: err/eps,n1,n2,n1+n2=',sumErr/eps,n1,n2,n1+n2 - isPosSumErrSignificant = .true. - else - isPosSumErrSignificant = .false. - endif -end function isPosSumErrSignificant - -!> Remaps column of values u0 on grid h0 to grid h1 by integrating -!! over the projection of each h1 cell onto the h0 grid. -subroutine remapByProjection( n0, h0, u0, ppoly0_E, ppoly0_coefs, & - n1, h1, method, u1, h_neglect ) - integer, intent(in) :: n0 !< Number of cells in source grid - real, intent(in) :: h0(:) !< Source grid widths (size n0) in thickness units [H] - real, intent(in) :: u0(:) !< Source cell averages (size n0) in arbitrary units [A] - real, intent(in) :: ppoly0_E(:,:) !< Edge value of polynomial [A] - real, intent(in) :: ppoly0_coefs(:,:) !< Coefficients of polynomial [A] - integer, intent(in) :: n1 !< Number of cells in target grid - real, intent(in) :: h1(:) !< Target grid widths (size n1) [H] - integer, intent(in) :: method !< Remapping scheme to use - real, intent(out) :: u1(:) !< Target cell averages (size n1) [A] - real, intent(in) :: h_neglect !< A negligibly small width for the - !! purpose of cell reconstructions - !! in the same units as h [H]. - ! Local variables - integer :: iTarget - real :: xL, xR ! coordinates of target cell edges [H] - integer :: jStart ! Used by integrateReconOnInterval() - real :: xStart ! Used by integrateReconOnInterval() [H] - - ! Loop on cells in target grid (grid1). For each target cell, we need to find - ! in which source cells the target cell edges lie. The associated indexes are - ! noted j0 and j1. - xR = 0. ! Left boundary is at x=0 - jStart = 1 - xStart = 0. - do iTarget = 1,n1 - ! Determine the coordinates of the target cell edges - xL = xR - xR = xL + h1(iTarget) - - call integrateReconOnInterval( n0, h0, u0, ppoly0_E, ppoly0_coefs, method, & - xL, xR, h1(iTarget), u1(iTarget), jStart, xStart, h_neglect ) - - enddo ! end iTarget loop on target grid cells - -end subroutine remapByProjection - -!> Remaps column of values u0 on grid h0 to implied grid h1 -!! where the interfaces of h1 differ from those of h0 by dx. -!! The new grid is defined relative to the original grid by change -!! dx1(:) = xNew(:) - xOld(:) -!! and the remapping calculated so that -!! hNew(k) qNew(k) = hOld(k) qOld(k) + F(k+1) - F(k) -!! where -!! F(k) = dx1(k) qAverage -!! and where qAverage is the average qOld in the region zOld(k) to zNew(k). -subroutine remapByDeltaZ( n0, h0, u0, ppoly0_E, ppoly0_coefs, n1, dx1, & - method, u1, h1, h_neglect ) - integer, intent(in) :: n0 !< Number of cells in source grid - real, dimension(:), intent(in) :: h0 !< Source grid sizes (size n0) in thickness units [H] - real, dimension(:), intent(in) :: u0 !< Source cell averages (size n0) in arbitrary units [A] - real, dimension(:,:), intent(in) :: ppoly0_E !< Edge value of polynomial [A] - real, dimension(:,:), intent(in) :: ppoly0_coefs !< Coefficients of polynomial [A] - integer, intent(in) :: n1 !< Number of cells in target grid - real, dimension(:), intent(in) :: dx1 !< Target grid edge positions (size n1+1) [H] - integer, intent(in) :: method !< Remapping scheme to use - real, dimension(:), intent(out) :: u1 !< Target cell averages (size n1) [A] - real, dimension(:), & - optional, intent(out) :: h1 !< Target grid widths (size n1) [H] - real, intent(in) :: h_neglect !< A negligibly small width for the - !! purpose of cell reconstructions - !! in the same units as h [H]. - ! Local variables - integer :: iTarget - real :: xL, xR ! Coordinates of target cell edges [H] - real :: xOld, xNew ! Edge positions on the old and new grids [H] - real :: hOld, hNew ! Cell thicknesses on the old and new grids [H] - real :: uOld ! A source cell average of u [A] - real :: h_err ! An estimate of the error in the reconstructed thicknesses [H] - real :: uhNew ! Cell integrated u on the new grid [A H] - real :: hFlux ! Width of the remapped volume [H] - real :: uAve ! Target cell average of u [A] - real :: fluxL, fluxR ! Fluxes of u through the two cell faces [A H] - integer :: jStart ! Used by integrateReconOnInterval() - real :: xStart ! Used by integrateReconOnInterval() [H] - - ! Loop on cells in target grid. For each cell, iTarget, the left flux is - ! the right flux of the cell to the left, iTarget-1. - ! The left flux is initialized by started at iTarget=0 to calculate the - ! right flux which can take into account the target left boundary being - ! in the interior of the source domain. - fluxR = 0. - h_err = 0. ! For measuring round-off error - jStart = 1 - xStart = 0. - do iTarget = 0,n1 - fluxL = fluxR ! This does nothing for iTarget=0 - - if (iTarget == 0) then - xOld = 0. ! Left boundary is at x=0 - hOld = -1.E30 ! Should not be used for iTarget = 0 - uOld = -1.E30 ! Should not be used for iTarget = 0 - elseif (iTarget <= n0) then - xOld = xOld + h0(iTarget) ! Position of right edge of cell - hOld = h0(iTarget) - uOld = u0(iTarget) - h_err = h_err + epsilon(hOld) * max(hOld, xOld) - else - hOld = 0. ! as if for layers>n0, they were vanished - uOld = 1.E30 ! and the initial value should not matter - endif - xNew = xOld + dx1(iTarget+1) - xL = min( xOld, xNew ) - xR = max( xOld, xNew ) - - ! hFlux is the positive width of the remapped volume - hFlux = abs(dx1(iTarget+1)) - call integrateReconOnInterval( n0, h0, u0, ppoly0_E, ppoly0_coefs, method, & - xL, xR, hFlux, uAve, jStart, xStart, h_neglect ) - ! uAve is the average value of u, independent of sign of dx1 - fluxR = dx1(iTarget+1)*uAve ! Includes sign of dx1 - - if (iTarget>0) then - hNew = hOld + ( dx1(iTarget+1) - dx1(iTarget) ) - hNew = max( 0., hNew ) - uhNew = ( uOld * hOld ) + ( fluxR - fluxL ) - if (hNew>0.) then - u1(iTarget) = uhNew / hNew - else - u1(iTarget) = uAve - endif - if (present(h1)) h1(iTarget) = hNew - endif - - enddo ! end iTarget loop on target grid cells - -end subroutine remapByDeltaZ - -!> Integrate the reconstructed column profile over a single cell -subroutine integrateReconOnInterval( n0, h0, u0, ppoly0_E, ppoly0_coefs, method, & - xL, xR, hC, uAve, jStart, xStart, h_neglect ) - integer, intent(in) :: n0 !< Number of cells in source grid - real, dimension(:), intent(in) :: h0 !< Source grid sizes (size n0) in thickness units [H] - real, dimension(:), intent(in) :: u0 !< Source cell averages in arbitrary units [A] - real, dimension(:,:), intent(in) :: ppoly0_E !< Edge value of polynomial [A] - real, dimension(:,:), intent(in) :: ppoly0_coefs !< Coefficients of polynomial [A] - integer, intent(in) :: method !< Remapping scheme to use - real, intent(in) :: xL !< Left edges of target cell [H] - real, intent(in) :: xR !< Right edges of target cell [H] - real, intent(in) :: hC !< Cell width hC = xR - xL [H] - real, intent(out) :: uAve !< Average value on target cell [A] - integer, intent(inout) :: jStart !< The index of the cell to start searching from - !< On exit, contains index of last cell used - real, intent(inout) :: xStart !< The left edge position of cell jStart [H] - !< On first entry should be 0. - real, intent(in) :: h_neglect !< A negligibly small width for the - !! purpose of cell reconstructions - !! in the same units as h [H] - ! Local variables - integer :: j, k - integer :: jL, jR ! indexes of source cells containing target cell edges - real :: q ! complete integration [A H] - real :: xi0, xi1 ! interval of integration (local -- normalized -- coordinates) [nondim] - real :: x0jLl, x0jLr ! Left/right position of cell jL [H] - real :: x0jRl, x0jRr ! Left/right position of cell jR [H] - real :: hAct ! The distance actually used in the integration - ! (notionally xR - xL) which differs due to roundoff [H]. - real :: x0_2, x1_2 ! Squares of normalized positions used to evaluate polynomials [nondim] - real :: x0px1, x02px12 ! Sums of normalized positions and their squares [nondim] - real, parameter :: r_3 = 1.0/3.0 ! Used in evaluation of integrated polynomials [nondim] - - q = -1.E30 - x0jLl = -1.E30 - x0jRl = -1.E30 - - ! Find the left most cell in source grid spanned by the target cell - jL = -1 - x0jLr = xStart - do j = jStart, n0 - x0jLl = x0jLr - x0jLr = x0jLl + h0(j) - ! Left edge is found in cell j - if ( ( xL >= x0jLl ) .AND. ( xL <= x0jLr ) ) then - jL = j - exit ! once target grid cell is found, exit loop - endif - enddo - jStart = jL - xStart = x0jLl - -! ! HACK to handle round-off problems. Need only at j=n0. -! ! This moves the effective cell boundary outwards a smidgen. -! if (xL>x0jLr) x0jLr = xL - - ! If, at this point, jL is equal to -1, it means the vanished - ! cell lies outside the source grid. In other words, it means that - ! the source and target grids do not cover the same physical domain - ! and there is something very wrong ! - if ( jL == -1 ) call MOM_error(FATAL, & - 'MOM_remapping, integrateReconOnInterval: '//& - 'The location of the left-most cell could not be found') - - - ! ============================================================ - ! Check whether target cell is vanished. If it is, the cell - ! average is simply the interpolated value at the location - ! of the vanished cell. If it isn't, we need to integrate the - ! quantity within the cell and divide by the cell width to - ! determine the cell average. - ! ============================================================ - ! 1. Cell is vanished - !if ( abs(xR - xL) <= epsilon(xR)*max(abs(xR),abs(xL)) ) then - if ( abs(xR - xL) == 0.0 ) then - - ! We check whether the source cell (i.e. the cell in which the - ! vanished target cell lies) is vanished. If it is, the interpolated - ! value is set to be mean of the edge values (which should be the same). - ! If it isn't, we simply interpolate. - if ( h0(jL) == 0.0 ) then - uAve = 0.5 * ( ppoly0_E(jL,1) + ppoly0_E(jL,2) ) - else - ! WHY IS THIS NOT WRITTEN AS xi0 = ( xL - x0jLl ) / h0(jL) ---AJA - xi0 = xL / ( h0(jL) + h_neglect ) - x0jLl / ( h0(jL) + h_neglect ) - - select case ( method ) - case ( INTEGRATION_PCM ) - uAve = ppoly0_coefs(jL,1) - case ( INTEGRATION_PLM ) - uAve = ppoly0_coefs(jL,1) & - + xi0 * ppoly0_coefs(jL,2) - case ( INTEGRATION_PPM ) - uAve = ppoly0_coefs(jL,1) & - + xi0 * ( ppoly0_coefs(jL,2) & - + xi0 * ppoly0_coefs(jL,3) ) - case ( INTEGRATION_PQM ) - uAve = ppoly0_coefs(jL,1) & - + xi0 * ( ppoly0_coefs(jL,2) & - + xi0 * ( ppoly0_coefs(jL,3) & - + xi0 * ( ppoly0_coefs(jL,4) & - + xi0 * ppoly0_coefs(jL,5) ) ) ) - case default - call MOM_error( FATAL,'The selected integration method is invalid' ) - end select - - endif ! end checking whether source cell is vanished - - ! 2. Cell is not vanished - else - - ! Find the right most cell in source grid spanned by the target cell - jR = -1 - x0jRr = xStart - do j = jStart,n0 - x0jRl = x0jRr - x0jRr = x0jRl + h0(j) - ! Right edge is found in cell j - if ( ( xR >= x0jRl ) .AND. ( xR <= x0jRr ) ) then - jR = j - exit ! once target grid cell is found, exit loop - endif - enddo ! end loop on source grid cells - - ! If xR>x0jRr then the previous loop reached j=n0 and the target - ! position, xR, was beyond the right edge of the source grid (h0). - ! This can happen due to roundoff, in which case we set jR=n0. - if (xR>x0jRr) jR = n0 - - ! To integrate, two cases must be considered: (1) the target cell is - ! entirely contained within a cell of the source grid and (2) the target - ! cell spans at least two cells of the source grid. - - if ( jL == jR ) then - ! The target cell is entirely contained within a cell of the source - ! grid. This situation is represented by the following schematic, where - ! the cell in which xL and xR are located has index jL=jR : - ! - ! ----|-----o--------o----------|------------- - ! xL xR - ! - ! Determine normalized coordinates -#ifdef __USE_ROUNDOFF_SAFE_ADJUSTMENTS__ - xi0 = max( 0., min( 1., ( xL - x0jLl ) / ( h0(jL) + h_neglect ) ) ) - xi1 = max( 0., min( 1., ( xR - x0jLl ) / ( h0(jL) + h_neglect ) ) ) -#else - xi0 = xL / h0(jL) - x0jLl / ( h0(jL) + h_neglect ) - xi1 = xR / h0(jL) - x0jLl / ( h0(jL) + h_neglect ) -#endif - - hAct = h0(jL) * ( xi1 - xi0 ) - - ! Depending on which polynomial is used, integrate quantity - ! between xi0 and xi1. Integration is carried out in normalized - ! coordinates, hence: \int_xL^xR p(x) dx = h \int_xi0^xi1 p(xi) dxi - select case ( method ) - case ( INTEGRATION_PCM ) - q = ( xR - xL ) * ppoly0_coefs(jL,1) - case ( INTEGRATION_PLM ) - q = ( xR - xL ) * ( & - ppoly0_coefs(jL,1) & - + ppoly0_coefs(jL,2) * 0.5 * ( xi1 + xi0 ) ) - case ( INTEGRATION_PPM ) - q = ( xR - xL ) * ( & - ppoly0_coefs(jL,1) & - + ( ppoly0_coefs(jL,2) * 0.5 * ( xi1 + xi0 ) & - + ppoly0_coefs(jL,3) * r_3 * ( ( xi1*xi1 + xi0*xi0 ) + xi0*xi1 ) ) ) - case ( INTEGRATION_PQM ) - x0_2 = xi0*xi0 - x1_2 = xi1*xi1 - x02px12 = x0_2 + x1_2 - x0px1 = xi1 + xi0 - q = ( xR - xL ) * ( & - ppoly0_coefs(jL,1) & - + ( ppoly0_coefs(jL,2) * 0.5 * ( xi1 + xi0 ) & - + ( ppoly0_coefs(jL,3) * r_3 * ( x02px12 + xi0*xi1 ) & - + ppoly0_coefs(jL,4) * 0.25* ( x02px12 * x0px1 ) & - + ppoly0_coefs(jL,5) * 0.2 * ( ( xi1*x1_2 + xi0*x0_2 ) * x0px1 + x0_2*x1_2 ) ) ) ) - case default - call MOM_error( FATAL,'The selected integration method is invalid' ) - end select - - else - ! The target cell spans at least two cells of the source grid. - ! This situation is represented by the following schematic, where - ! the cells in which xL and xR are located have indexes jL and jR, - ! respectively : - ! - ! ----|-----o---|--- ... --|---o----------|------------- - ! xL xR - ! - ! We first integrate from xL up to the right boundary of cell jL, then - ! add the integrated amounts of cells located between jL and jR and then - ! integrate from the left boundary of cell jR up to xR - - q = 0.0 - - ! Integrate from xL up to right boundary of cell jL -#ifdef __USE_ROUNDOFF_SAFE_ADJUSTMENTS__ - xi0 = max( 0., min( 1., ( xL - x0jLl ) / ( h0(jL) + h_neglect ) ) ) -#else - xi0 = (xL - x0jLl) / ( h0(jL) + h_neglect ) -#endif - xi1 = 1.0 - - hAct = h0(jL) * ( xi1 - xi0 ) - - select case ( method ) - case ( INTEGRATION_PCM ) - q = q + ( x0jLr - xL ) * ppoly0_coefs(jL,1) - case ( INTEGRATION_PLM ) - q = q + ( x0jLr - xL ) * ( & - ppoly0_coefs(jL,1) & - + ppoly0_coefs(jL,2) * 0.5 * ( xi1 + xi0 ) ) - case ( INTEGRATION_PPM ) - q = q + ( x0jLr - xL ) * ( & - ppoly0_coefs(jL,1) & - + ( ppoly0_coefs(jL,2) * 0.5 * ( xi1 + xi0 ) & - + ppoly0_coefs(jL,3) * r_3 * ( ( xi1*xi1 + xi0*xi0 ) + xi0*xi1 ) ) ) - case ( INTEGRATION_PQM ) - x0_2 = xi0*xi0 - x1_2 = xi1*xi1 - x02px12 = x0_2 + x1_2 - x0px1 = xi1 + xi0 - q = q + ( x0jLr - xL ) * ( & - ppoly0_coefs(jL,1) & - + ( ppoly0_coefs(jL,2) * 0.5 * ( xi1 + xi0 ) & - + ( ppoly0_coefs(jL,3) * r_3 * ( x02px12 + xi0*xi1 ) & - + ppoly0_coefs(jL,4) * 0.25* ( x02px12 * x0px1 ) & - + ppoly0_coefs(jL,5) * 0.2 * ( ( xi1*x1_2 + xi0*x0_2 ) * x0px1 + x0_2*x1_2 ) ) ) ) - case default - call MOM_error( FATAL, 'The selected integration method is invalid' ) - end select - - ! Integrate contents within cells strictly comprised between jL and jR - if ( jR > (jL+1) ) then - do k = jL+1,jR-1 - q = q + h0(k) * u0(k) - hAct = hAct + h0(k) - enddo - endif - - ! Integrate from left boundary of cell jR up to xR - xi0 = 0.0 -#ifdef __USE_ROUNDOFF_SAFE_ADJUSTMENTS__ - xi1 = max( 0., min( 1., ( xR - x0jRl ) / ( h0(jR) + h_neglect ) ) ) -#else - xi1 = (xR - x0jRl) / ( h0(jR) + h_neglect ) -#endif - - hAct = hAct + h0(jR) * ( xi1 - xi0 ) - - select case ( method ) - case ( INTEGRATION_PCM ) - q = q + ( xR - x0jRl ) * ppoly0_coefs(jR,1) - case ( INTEGRATION_PLM ) - q = q + ( xR - x0jRl ) * ( & - ppoly0_coefs(jR,1) & - + ppoly0_coefs(jR,2) * 0.5 * ( xi1 + xi0 ) ) - case ( INTEGRATION_PPM ) - q = q + ( xR - x0jRl ) * ( & - ppoly0_coefs(jR,1) & - + ( ppoly0_coefs(jR,2) * 0.5 * ( xi1 + xi0 ) & - + ppoly0_coefs(jR,3) * r_3 * ( ( xi1*xi1 + xi0*xi0 ) + xi0*xi1 ) ) ) - case ( INTEGRATION_PQM ) - x0_2 = xi0*xi0 - x1_2 = xi1*xi1 - x02px12 = x0_2 + x1_2 - x0px1 = xi1 + xi0 - q = q + ( xR - x0jRl ) * ( & - ppoly0_coefs(jR,1) & - + ( ppoly0_coefs(jR,2) * 0.5 * ( xi1 + xi0 ) & - + ( ppoly0_coefs(jR,3) * r_3 * ( x02px12 + xi0*xi1 ) & - + ppoly0_coefs(jR,4) * 0.25* ( x02px12 * x0px1 ) & - + ppoly0_coefs(jR,5) * 0.2 * ( ( xi1*x1_2 + xi0*x0_2 ) * x0px1 + x0_2*x1_2 ) ) ) ) - case default - call MOM_error( FATAL,'The selected integration method is invalid' ) - end select - - endif ! end integration for non-vanished cells - - ! The cell average is the integrated value divided by the cell width -#ifdef __USE_ROUNDOFF_SAFE_ADJUSTMENTS__ -if (hAct==0.) then - uAve = ppoly0_coefs(jL,1) -else - uAve = q / hAct -endif -#else - uAve = q / hC -#endif - - endif ! endif clause to check if cell is vanished - -end subroutine integrateReconOnInterval - -!> Calculates the change in interface positions based on h1 and h2 -subroutine dzFromH1H2( n1, h1, n2, h2, dx ) - integer, intent(in) :: n1 !< Number of cells on source grid - real, dimension(:), intent(in) :: h1 !< Cell widths of source grid (size n1) [H] - integer, intent(in) :: n2 !< Number of cells on target grid - real, dimension(:), intent(in) :: h2 !< Cell widths of target grid (size n2) [H] - real, dimension(:), intent(out) :: dx !< Change in interface position (size n2+1) [H] - ! Local variables - integer :: k - real :: x1, x2 ! Interface positions [H] - - x1 = 0. - x2 = 0. - dx(1) = 0. - do K = 1, max(n1,n2) - if (k <= n1) x1 = x1 + h1(k) ! Interface k+1, right of source cell k - if (k <= n2) then - x2 = x2 + h2(k) ! Interface k+1, right of target cell k - dx(K+1) = x2 - x1 ! Change of interface k+1, target - source - endif - enddo - -end subroutine dzFromH1H2 - -!> Calculate edge coordinate x from cell width h -subroutine buildGridFromH(nz, h, x) - integer, intent(in) :: nz !< Number of cells - real, dimension(nz), intent(in) :: h !< Cell widths [H] - real, dimension(nz+1), intent(inout) :: x !< Edge coordinates starting at x(1)=0 [H] - ! Local variables - integer :: k - - x(1) = 0.0 - do k = 1,nz - x(k+1) = x(k) + h(k) - enddo - -end subroutine buildGridFromH - -!> Runs unit tests on archaic remapping functions. -!! Should only be called from a single/root thread -!! Returns True if a test fails, otherwise False -logical function remapping_attic_unit_tests(verbose) - logical, intent(in) :: verbose !< If true, write results to stdout - ! Local variables - integer, parameter :: n0 = 4, n1 = 3, n2 = 6 - real :: h0(n0), x0(n0+1) ! Test cell widths and edge coordinates [H] - real :: u0(n0) ! Test values for remapping in arbitrary units [A] - real :: h1(n1), x1(n1+1) ! Test cell widths and edge coordinates [H] - real :: u1(n1) ! Test values for remapping [A] - real :: h2(n2), x2(n2+1) ! Test cell widths and edge coordinates [H] - real :: u2(n2) ! Test values for remapping [A] - real :: hn1(n1), hn2(n2) ! Updated grid thicknesses [H] - real :: dx1(n1+1), dx2(n2+1) ! Differences in interface positions [H] - data u0 /9., 3., -3., -9./ ! Linear profile, 4 at surface to -4 at bottom - data h0 /4*0.75/ ! 4 uniform layers with total depth of 3 - data h1 /3*1./ ! 3 uniform layers with total depth of 3 - data h2 /6*0.5/ ! 6 uniform layers with total depth of 3 - real, allocatable, dimension(:,:) :: ppoly0_E, ppoly0_S ! Polynomial edge values [A] - real, allocatable, dimension(:,:) :: ppoly0_coefs ! Polynomial reconstruction coefficients [A] - integer :: answer_date ! The vintage of the expressions to test - integer :: i, degree - real :: err ! Difference between a remapped value and its expected value [A] - real :: h_neglect, h_neglect_edge ! Negligible thicknesses used in remapping [H] - logical :: thisTest, v - - v = verbose - answer_date = 20190101 ! 20181231 - h_neglect = 1.0E-30 - h_neglect_edge = h_neglect ; if (answer_date < 20190101) h_neglect_edge = 1.0e-10 - - write(stdout,*) '==== remapping_attic: remapping_attic_unit_tests =================' - remapping_attic_unit_tests = .false. ! Normally return false - - call buildGridFromH(n0, h0, x0) - call buildGridFromH(n1, h1, x1) - - thisTest = .false. - degree = 2 - if (verbose) write(stdout,*) 'h0 (test data)' - if (verbose) call dumpGrid(n0,h0,x0,u0) - - call dzFromH1H2( n0, h0, n1, h1, dx1 ) - - thisTest = .false. - allocate(ppoly0_E(n0,2)) - allocate(ppoly0_S(n0,2)) - allocate(ppoly0_coefs(n0,degree+1)) - - ppoly0_E(:,:) = 0.0 - ppoly0_S(:,:) = 0.0 - ppoly0_coefs(:,:) = 0.0 - - call edge_values_explicit_h4( n0, h0, u0, ppoly0_E, h_neglect=1e-10, answer_date=answer_date ) - call PPM_reconstruction( n0, h0, u0, ppoly0_E, ppoly0_coefs, h_neglect, answer_date=answer_date ) - call PPM_boundary_extrapolation( n0, h0, u0, ppoly0_E, ppoly0_coefs, h_neglect ) - u1(:) = 0. - call remapByProjection( n0, h0, u0, ppoly0_E, ppoly0_coefs, & - n1, h1, INTEGRATION_PPM, u1, h_neglect ) - do i=1,n1 - err = u1(i)-8.*(0.5*real(1+n1)-real(i)) - if (abs(err)>2.*epsilon(err)) thisTest = .true. - enddo - if (thisTest) write(stdout,*) 'remapping_attic_unit_tests: Failed remapByProjection()' - remapping_attic_unit_tests = remapping_attic_unit_tests .or. thisTest - - thisTest = .false. - u1(:) = 0. - call remapByDeltaZ( n0, h0, u0, ppoly0_E, ppoly0_coefs, & - n1, x1-x0(1:n1+1), & - INTEGRATION_PPM, u1, hn1, h_neglect ) - if (verbose) write(stdout,*) 'h1 (by delta)' - if (verbose) call dumpGrid(n1,h1,x1,u1) - hn1 = hn1-h1 - do i=1,n1 - err = u1(i)-8.*(0.5*real(1+n1)-real(i)) - if (abs(err)>2.*epsilon(err)) thisTest = .true. - enddo - if (thisTest) write(stdout,*) 'remapping_attic_unit_tests: Failed remapByDeltaZ() 1' - remapping_attic_unit_tests = remapping_attic_unit_tests .or. thisTest - - thisTest = .false. - call buildGridFromH(n2, h2, x2) - dx2(1:n0+1) = x2(1:n0+1) - x0 - dx2(n0+2:n2+1) = x2(n0+2:n2+1) - x0(n0+1) - call remapByDeltaZ( n0, h0, u0, ppoly0_E, ppoly0_coefs, & - n2, dx2, & - INTEGRATION_PPM, u2, hn2, h_neglect ) - if (verbose) write(stdout,*) 'h2' - if (verbose) call dumpGrid(n2,h2,x2,u2) - if (verbose) write(stdout,*) 'hn2' - if (verbose) call dumpGrid(n2,hn2,x2,u2) - - do i=1,n2 - err = u2(i)-8./2.*(0.5*real(1+n2)-real(i)) - if (abs(err)>2.*epsilon(err)) thisTest = .true. - enddo - if (thisTest) write(stdout,*) 'remapping_attic_unit_tests: Failed remapByDeltaZ() 2' - remapping_attic_unit_tests = remapping_attic_unit_tests .or. thisTest - - if (.not. remapping_attic_unit_tests) write(stdout,*) 'Pass' - -end function remapping_attic_unit_tests - -!> Convenience function for printing grid to screen -subroutine dumpGrid(n,h,x,u) - integer, intent(in) :: n !< Number of cells - real, dimension(:), intent(in) :: h !< Cell thickness [H] - real, dimension(:), intent(in) :: x !< Interface delta [H] - real, dimension(:), intent(in) :: u !< Cell average values [A] - integer :: i - write(stdout,'("i=",20i10)') (i,i=1,n+1) - write(stdout,'("x=",20es10.2)') (x(i),i=1,n+1) - write(stdout,'("i=",5x,20i10)') (i,i=1,n) - write(stdout,'("h=",5x,20es10.2)') (h(i),i=1,n) - write(stdout,'("u=",5x,20es10.2)') (u(i),i=1,n) -end subroutine dumpGrid - -end module remapping_attic diff --git a/src/framework/numerical_testing_type.F90 b/src/framework/numerical_testing_type.F90 new file mode 100644 index 0000000000..0947ed3141 --- /dev/null +++ b/src/framework/numerical_testing_type.F90 @@ -0,0 +1,371 @@ +!> A simple type for keeping track of numerical tests +module numerical_testing_type + +! This file is part of MOM6. See LICENSE.md for the license. + +implicit none ; private + +public testing +public testing_type_unit_test + +!> Class to assist in unit tests, not to be used outside of Recon1d types +type :: testing + private + !> True if any fail has been encountered since this instance of "testing" was created + logical :: state = .false. + !> Count of tests checked + integer :: num_tests_checked = 0 + !> Count of tests failed + integer :: num_tests_failed = 0 + !> If true, be verbose and write results to stdout. Default True. + logical :: verbose = .true. + !> Error channel + integer, public :: stderr = 0 + !> Standard output channel + integer, public :: stdout = 6 + !> If true, stop instantly + logical :: stop_instantly = .false. + !> If true, ignore fails until ignore_fail=.false. + logical :: ignore_fail = .false. + !> Record instances that fail + integer :: ifailed(100) = 0. + !> Record label of first instance that failed + character(len=:), allocatable :: label_first_fail + + contains + procedure :: test => test !< Update the testing state + procedure :: set => set !< Set attributes + procedure :: summarize => summarize !< Summarize testing state + procedure :: real_scalar => real_scalar !< Compare two reals + procedure :: real_arr => real_arr !< Compare array of reals + procedure :: int_arr => int_arr !< Compare array of integers +end type + +contains + +!> Update the state with "test" +subroutine test(this, state, label, ignore) + class(testing), intent(inout) :: this !< This testing class + logical, intent(in) :: state !< True to indicate a fail, false otherwise + character(len=*), intent(in) :: label !< Message + logical, optional, intent(in) :: ignore !< If present and true, ignore a fail + ! Local variables + logical :: ignore_this_fail + + ignore_this_fail = this%ignore_fail + if (present(ignore)) ignore_this_fail = ignore + + this%num_tests_checked = this%num_tests_checked + 1 + if (state) then + if (.not. ignore_this_fail) then + this%state = .true. + this%num_tests_failed = this%num_tests_failed + 1 + if (this%num_tests_failed<=100) this%ifailed(this%num_tests_failed) = this%num_tests_checked + if (this%num_tests_failed == 1) this%label_first_fail = label + write(this%stdout, '(2x,3a)') 'Test "',trim(label),'" FAILED!' + write(this%stderr, '(2x,3a)') 'Test "',trim(label),'" FAILED!' + else + write(this%stdout, '(2x,3a)') 'Test "',trim(label),'" IGNORED!' + write(this%stderr, '(2x,3a)') 'Test "',trim(label),'" IGNORED!' + endif + elseif (this%verbose) then + write(this%stdout, '(2x,3a)') 'Test "',trim(label),'" passed' + endif + if (this%stop_instantly .and. this%state .and. .not. ignore_this_fail) stop 1 +end subroutine test + +!> Set attributes +subroutine set(this, verbose, stdout, stderr, stop_instantly, ignore_fail) + class(testing), intent(inout) :: this !< This testing class + logical, optional, intent(in) :: verbose !< True or false setting to assign to verbosity + integer, optional, intent(in) :: stdout !< The stdout channel to use + integer, optional, intent(in) :: stderr !< The stderr channel to use + logical, optional, intent(in) :: stop_instantly !< If true, stop immediately on error detection + logical, optional, intent(in) :: ignore_fail !< If true, ignore fails until this option is set false + + if (present(verbose)) then + this%verbose = verbose + endif + if (present(stdout)) then + this%stdout = stdout + endif + if (present(stderr)) then + this%stderr = stderr + endif + if (present(stop_instantly)) then + this%stop_instantly = stop_instantly + endif + if (present(ignore_fail)) then + this%ignore_fail = ignore_fail + endif +end subroutine set + +!> Summarize results +logical function summarize(this, label) + class(testing), intent(inout) :: this !< This testing class + character(len=*), intent(in) :: label !< Message + integer :: i + + if (this%state) then + write(this%stdout,'(a," : ",a,", ",i4," failed of ",i4," tested")') & + 'FAIL', trim(label), this%num_tests_failed, this%num_tests_checked + write(this%stdout,'(a,100i4)') 'Failed tests:',(this%ifailed(i),i=1,min(100,this%num_tests_failed)) + write(this%stdout,'(a,a)') 'First failed test: ',trim(this%label_first_fail) + write(this%stderr,'(a,100i4)') 'Failed tests:',(this%ifailed(i),i=1,min(100,this%num_tests_failed)) + write(this%stderr,'(a,a)') 'First failed test: ',trim(this%label_first_fail) + write(this%stderr,'(a," : ",a)') trim(label),'FAILED' + else + write(this%stdout,'(a," : ",a,", all ",i4," tests passed")') & + 'Pass', trim(label), this%num_tests_checked + endif + summarize = this%state +end function summarize + +!> Compare u_test to u_true, report, and return true if a difference larger than tol is measured +!! +!! If in verbose mode, display results to stdout +!! If a difference is measured, display results to stdout and stderr +subroutine real_scalar(this, u_test, u_true, label, tol, robits, ignore) + class(testing), intent(inout) :: this !< This testing class + real, intent(in) :: u_test !< Value to test [A] + real, intent(in) :: u_true !< Value to test against (correct answer) [A] + character(len=*), intent(in) :: label !< Message + real, optional, intent(in) :: tol !< The tolerance for differences between u and u_true [A] + integer, optional, intent(in) :: robits !< Number of bits of round-off to allow + logical, optional, intent(in) :: ignore !< If present and true, ignore a fail + ! Local variables + logical :: this_test, ignore_this_fail + real :: tolerance, err ! Tolerance and error [A] + + tolerance = 0.0 + if (present(tol)) tolerance = tol + ignore_this_fail = this%ignore_fail + if (present(ignore)) ignore_this_fail = ignore + this_test = .false. + + ! Scan for any mismatch between u_test and u_true + if (present(robits)) tolerance = abs(u_true) * float(robits) * epsilon(err) + if (abs(u_test - u_true) > tolerance) this_test = .true. + + if (this_test) then + if (ignore_this_fail) then + if (this%verbose) then + write(this%stdout,'(3(a,1p1e24.16,1x),2a)') "Calculated value =",u_test,"Correct value =",u_true, & + "err =",u_test - u_true, label, " <--- IGNORING" + write(this%stderr,'(3(a,1p1e24.16,1x),2a)') "Calculated value =",u_test,"Correct value =",u_true, & + "err =",u_test - u_true, label, " <--- IGNORING" + endif + this_test = .false. + else + write(this%stdout,'(3(a,1p1e24.16,1x),2a)') "Calculated value =",u_test,"Correct value =",u_true, & + "err =",u_test - u_true, label, " <--- WRONG" + write(this%stderr,'(3(a,1p1e24.16,1x),2a)') "Calculated value =",u_test,"Correct value =",u_true, & + "err =",u_test - u_true, label, " <--- WRONG" + endif + elseif (this%verbose) then + write(this%stdout,'(2(a,1p1e24.16,1x),a)') "Calculated value =",u_test,"Correct value =",u_true,label + endif + + call this%test( this_test, label, ignore=ignore_this_fail ) ! Updates state and counters in this +end subroutine real_scalar + +!> Compare u_test to u_true, report, and return true if a difference larger than tol is measured +!! +!! If in verbose mode, display results to stdout +!! If a difference is measured, display results to stdout and stderr +subroutine real_arr(this, n, u_test, u_true, label, tol, robits, ignore) + class(testing), intent(inout) :: this !< This testing class + integer, intent(in) :: n !< Number of cells in u + real, dimension(n), intent(in) :: u_test !< Values to test [A] + real, dimension(n), intent(in) :: u_true !< Values to test against (correct answer) [A] + character(len=*), intent(in) :: label !< Message + real, optional, intent(in) :: tol !< The tolerance for differences between u and u_true [A] + integer, optional, intent(in) :: robits !< Number of bits of round-off to allow + logical, optional, intent(in) :: ignore !< If present and true, ignore a fail + ! Local variables + integer :: k + logical :: this_test, ignore_this_fail + real :: tolerance, err ! Tolerance and error [A] + + tolerance = 0.0 + if (present(tol)) tolerance = tol + ignore_this_fail = this%ignore_fail + if (present(ignore)) ignore_this_fail = ignore + this_test = .false. + + ! Scan for any mismatch between u_test and u_true + do k = 1, n + if (present(robits)) tolerance = abs(u_true(k)) * float(robits) * epsilon(err) + if (abs(u_test(k) - u_true(k)) > tolerance) this_test = .true. + enddo + + ! If either being verbose, or an error was measured then display results + if (this_test .or. this%verbose) then + write(this%stdout,'(a4,2a24,1x,a)') 'k','Calculated value','Correct value',label + if (this_test) write(this%stderr,'(a4,2a24,1x,a)') 'k','Calculated value','Correct value',label + do k = 1, n + if (present(robits)) tolerance = abs(u_true(k)) * float(robits) * epsilon(err) + err = u_test(k) - u_true(k) + if ( ( abs(err) > tolerance .and. ignore_this_fail ) .or. & + ( abs(err) > 0. .and. abs(err) <= tolerance ) ) then + write(this%stdout,'(i4,1p2e24.16,a,1pe24.16,a)') k, u_test(k), u_true(k), & + ' err=', err, ' <--- IGNORING' + elseif (abs(err) > tolerance) then + write(this%stdout,'(i4,1p2e24.16,a,1pe24.16,a)') k, u_test(k), u_true(k), & + ' err=', err, ' <--- WRONG' + write(this%stderr,'(i4,1p2e24.16,a,1pe24.16,a)') k, u_test(k), u_true(k), & + ' err=', err, ' <--- WRONG' + else + write(this%stdout,'(i4,1p2e24.16)') k, u_test(k), u_true(k) + endif + enddo + endif + + call this%test( this_test, label, ignore=ignore_this_fail ) ! Updates state and counters in this +end subroutine real_arr + +!> Compare i_test to i_true and report and return true if a difference is found +!! +!! If in verbose mode, display results to stdout +!! If a difference is measured, display results to stdout and stderr +subroutine int_arr(this, n, i_test, i_true, label, ignore) + class(testing), intent(inout) :: this !< This testing class + integer, intent(in) :: n !< Number of cells in u + integer, dimension(n), intent(in) :: i_test !< Values to test [A] + integer, dimension(n), intent(in) :: i_true !< Values to test against (correct answer) [A] + character(len=*), intent(in) :: label !< Message + logical, optional, intent(in) :: ignore !< If present and true, ignore a fail + ! Local variables + integer :: k + logical :: this_test, ignore_this_fail + + ignore_this_fail = this%ignore_fail + if (present(ignore)) ignore_this_fail = ignore + this_test = .false. + + ! Scan for any mismatch between u_test and u_true + do k = 1, n + if (i_test(k) /= i_true(k)) this_test = .true. + enddo + + if (this%verbose) then + write(this%stdout,'(a14," : calculated =",30i3)') label, i_test + write(this%stdout,'(14x," correct =",30i3)') i_true + if (this_test) then + if (ignore_this_fail) then + write(this%stdout,'(3x,a,8x,"error =",30i3)') 'IGNORE --->', i_test(:) - i_true(:) + else + write(this%stdout,'(3x,a,8x,"error =",30i3)') ' FAIL --->', i_test(:) - i_true(:) + endif + endif + endif + + if (ignore_this_fail) this_test = .false. + + if (this_test) then + write(this%stderr,'(a14," : calculated =",30i3)') label, i_test + write(this%stderr,'(14x," correct =",30i3)') i_true + write(this%stderr,'(" FAIL ---> error =",30i3)') i_test(:) - i_true(:) + endif + + call this%test( this_test, label ) ! Updates state and counters in this +end subroutine int_arr + +!> Tests the testing type itself +logical function testing_type_unit_test(verbose) + logical, intent(in) :: verbose !< If true, write results to stdout + ! Local variables + type(testing) :: test ! The instance to be tested + logical :: tmpflag ! Temporary for return flags + + testing_type_unit_test = .false. ! Assume all is well at the outset + if (verbose) write(test%stdout,*) " ===== testing_type: testing_type_unit_test ============" + + call test%set( verbose=verbose ) ! Sets the verbosity flag in test + call test%set( stderr=0 ) ! Sets stderr + call test%set( stdout=6 ) ! Sets stdout + call test%set( stop_instantly=.false. ) ! Sets stop_instantly + call test%set( ignore_fail=.false. ) ! Sets ignore_fail + + call test%test( .false., "This should pass" ) + if (verbose .and. .not. test%state) then + write(test%stdout,*) " => test(F) passed" + else; testing_type_unit_test = testing_type_unit_test .or. .true. ; endif + + call test%test( .true., "This should fail but be ignored", ignore=.true. ) + if (verbose .and. .not. test%state) then + write(test%stdout,*) " => test(T,ignore) passed" + else; testing_type_unit_test = testing_type_unit_test .or. .true. ; endif + + call test%real_scalar(1., 1., "s == s should pass", robits=0, tol=0.) + if (verbose .and. .not. test%state) then + write(test%stdout,*) " => real(s,s) passed" + else; testing_type_unit_test = testing_type_unit_test .or. .true. ; endif + + call test%real_scalar(1., 2., "s != t but ignored", ignore=.true.) + if (verbose .and. .not. test%state) then + write(test%stdout,*) " => real(s,t,ignore) passed" + else; testing_type_unit_test = testing_type_unit_test .or. .true. ; endif + + call test%real_arr(2, (/1.,2./), (/1.,2./), "a == a should pass", robits=0, tol=0.) + if (verbose .and. .not. test%state) then + write(test%stdout,*) " => real(a,a) passed" + else; testing_type_unit_test = testing_type_unit_test .or. .true. ; endif + + call test%real_arr(2, (/1.,2./), (/3.,4./), "a != b but ignored", ignore=.true.) + if (verbose .and. .not. test%state) then + write(test%stdout,*) " => real(a,b,ignore) passed" + else; testing_type_unit_test = testing_type_unit_test .or. .true. ; endif + + call test%int_arr(2, (/1,2/), (/1,2/), "i == i should pass") + if (verbose .and. .not. test%state) then + write(test%stdout,*) " => int(a,a) passed" + else; testing_type_unit_test = testing_type_unit_test .or. .true. ; endif + + call test%int_arr(2, (/1,2/), (/3,4/), "i != j but ignored", ignore=.true.) + if (verbose .and. .not. test%state) then + write(test%stdout,*) " => int(a,b,ignore) passed" + else; testing_type_unit_test = testing_type_unit_test .or. .true. ; endif + + tmpflag = test%summarize("This summary is for a passing state") + if (verbose .and. .not. tmpflag) then + write(test%stdout,*) " => summarize(F) passed" + else; testing_type_unit_test = testing_type_unit_test .or. .true. ; endif + + ! This following all fail + test%state = .false. ! reset + call test%test( .true., "This should fail" ) + if (verbose .and. test%state) then + write(test%stdout,*) " => test(T) passed" + else; testing_type_unit_test = testing_type_unit_test .or. .true. ; endif + + test%state = .false. ! reset + call test%real_scalar(1., 2., "s != t should fail") + if (verbose .and. test%state) then + write(test%stdout,*) " => real(s,t) passed" + else; testing_type_unit_test = testing_type_unit_test .or. .true. ; endif + + test%state = .false. ! reset + call test%real_arr(2, (/1.,2./), (/3.,4./), "a != b and should fail") + if (verbose .and. test%state) then + write(test%stdout,*) " => real(a,b) passed" + else; testing_type_unit_test = testing_type_unit_test .or. .true. ; endif + + test%state = .false. ! reset + call test%int_arr(2, (/1,2/), (/3,4/), "i != j and should fail") + if (verbose .and. test%state) then + write(test%stdout,*) " => int(a,b) passed" + else; testing_type_unit_test = testing_type_unit_test .or. .true. ; endif + + tmpflag = test%summarize("This summary should have 3 fails") + if (verbose .and. tmpflag) then + write(test%stdout,*) " => summarize(T) passed" + else; testing_type_unit_test = testing_type_unit_test .or. .true. ; endif + + if (verbose .and. .not. testing_type_unit_test) write(test%stdout,*) "testing_type_unit_test passed" + +end function testing_type_unit_test + +!> \namespace numerical_testing_type +!! +end module numerical_testing_type