diff --git a/.testing/Makefile b/.testing/Makefile index f5da44342d..085fea2655 100644 --- a/.testing/Makefile +++ b/.testing/Makefile @@ -265,10 +265,12 @@ $(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 $(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 $(BUILD)/timing/Makefile: $(foreach e,$(TIMING_EXECS),../config_src/drivers/timing_tests/$(e).F90) @@ -649,7 +651,7 @@ $(WORK)/%/restart/ocean.stats: $(BUILD)/symmetric/MOM6 | preproc # Not a true rule; only call this after `make test` to summarize test results. .PHONY: test.summary test.summary: - @./tools/report_test_results.sh $(WORK)/results + ./tools/report_test_results.sh $(WORK)/results #--- diff --git a/.testing/tools/parse_perf.py b/.testing/tools/parse_perf.py index 76c6be5bcb..efcfa13b4f 100755 --- a/.testing/tools/parse_perf.py +++ b/.testing/tools/parse_perf.py @@ -102,7 +102,7 @@ def parse_perf_report(perf_data_path): if tok == '>': bracks -= 1 - if tok == '(': + if tok == ')': parens -= 1 # Strip any whitespace tokens diff --git a/ac/configure.ac b/ac/configure.ac index 8196e2eb01..071f43f5a9 100644 --- a/ac/configure.ac +++ b/ac/configure.ac @@ -81,8 +81,8 @@ AS_IF([test "x$with_driver" != "x"], # Explicitly assume free-form Fortran -AC_LANG(Fortran) -AC_FC_SRCEXT(f90) +AC_LANG([Fortran]) +AC_FC_SRCEXT([f90]) # Determine MPI compiler wrappers diff --git a/ac/deps/configure.fms.ac b/ac/deps/configure.fms.ac index a52533970b..7d68daa3c7 100644 --- a/ac/deps/configure.fms.ac +++ b/ac/deps/configure.fms.ac @@ -10,7 +10,16 @@ AC_INIT( AC_CONFIG_SRCDIR([fms/fms.F90]) AC_CONFIG_MACRO_DIR([m4]) + # C configuration + +# Autoconf assumes that LDFLAGS can be passed to CFLAGS, even though this is +# not valid in some compilers. This can cause basic CC tests to fail. +# Since we do not link with CC, we can safely disable LDFLAGS for AC_PROG_CC. +FC_LDFLAGS="$LDFLAGS" +LDFLAGS="" + +# C compiler verification AC_PROG_CC AX_MPI CC=$MPICC @@ -55,10 +64,13 @@ AC_CHECK_FUNCS([gettid], [], [ # FMS 2019.01.03 uses __APPLE__ to disable Linux CPU affinity calls. AC_CHECK_FUNCS([sched_getaffinity], [], [AC_DEFINE([__APPLE__])]) +# Restore LDFLAGS +LDFLAGS="$FC_LDFLAGS" + # Standard Fortran configuration -AC_LANG(Fortran) -AC_FC_SRCEXT(f90) +AC_LANG([Fortran]) +AC_FC_SRCEXT([f90]) AC_PROG_FC diff --git a/config_src/drivers/timing_tests/time_MOM_remapping.F90 b/config_src/drivers/timing_tests/time_MOM_remapping.F90 new file mode 100644 index 0000000000..5f4c0258ca --- /dev/null +++ b/config_src/drivers/timing_tests/time_MOM_remapping.F90 @@ -0,0 +1,100 @@ +program time_MOM_remapping + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_remapping, only : remapping_CS +use MOM_remapping, only : initialize_remapping +use MOM_remapping, only : remapping_core_h + +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) +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] +real, dimension(nschemes) :: tmin ! Shortest time for a call [s] +real, dimension(nschemes) :: tmax ! Longest time for a call [s] +real, dimension(:,:), allocatable :: u0, u1 ! Source/target values [arbitrary but same units as each other] +real, dimension(:,:), allocatable :: h0, h1 ! Source target thicknesses [0..1] +real :: start, finish ! Times [s] +real :: h0sum, h1sum ! Totals of h0 and h1 [nondim] +integer :: ij, k, isamp, iter, ischeme ! Indices and counters +integer :: seed_size ! Number of integers used by seed +integer, allocatable :: seed(:) ! Random number seed + +! Set seed for random numbers +call random_seed(size=seed_size) +allocate( seed(seed_Size) ) +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 +call random_number(h0) ! In range 0-1 +call random_number(h1) ! In range 0-1 +do ij = 1, nij + h0(:,ij) = max(0., h0(:,ij) - 0.05) ! Make 5% of values equal to zero + h1(:,ij) = max(0., h1(:,ij) - 0.05) ! Make 5% of values equal to zero + h0sum = h0(1,ij) + h1sum = h1(1,ij) + do k = 2, nk + h0sum = h0sum + h0(k,ij) + h1sum = h1sum + h1(k,ij) + enddo + h0(:,ij) = h0(:,ij) / h0sum + h1(:,ij) = h1(:,ij) / h1sum +enddo + +! Loop over many samples of timing loop to collect statistics +tmean(:) = 0. +tstd(:) = 0. +tmin(:) = 1.e9 +tmax(:) = 0. +do isamp = 1, nsamp + ! Time reconstruction + remapping + do ischeme = 1, nschemes + call initialize_remapping(CS, remapping_scheme=trim(scheme_labels(ischeme))) + 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() + call remapping_core_h(CS, nk, h0(:,ij), u0(:,ij), nk, h1(:,ij), u1(:,ij)) + enddo + enddo + call cpu_time(finish) + timings(ischeme) = (finish-start)/real(nits*nij) ! Average time per call + enddo + tmean(:) = tmean(:) + timings(:) + tstd(:) = tstd(:) + timings(:)**2 ! tstd contains sum of squares here + tmin(:) = min( tmin(:), timings(:) ) + tmax(:) = max( tmax(:), timings(:) ) +enddo +tmean(:) = tmean(:) / real(nsamp) ! convert to mean +tstd(:) = tstd(:) / real(nsamp) ! convert to mean of squares +tstd(:) = tstd(:) - tmean(:)**2 ! convert to variance +tstd(:) = sqrt( tstd(:) * real(nsamp) / real(nsamp-1) ) ! convert to standard deviation + + +! Display results in YAML +write(*,'(a)') "{" +do ischeme = 1, nschemes + write(*,"(2x,5a)") '"MOM_remapping remapping_core_h(remapping_scheme=', & + trim(scheme_labels(ischeme)), ')": {' + write(*,"(4x,a,1pe11.4,',')") '"min": ',tmin(ischeme) + write(*,"(4x,a,1pe11.4,',')") '"mean":',tmean(ischeme) + write(*,"(4x,a,1pe11.4,',')") '"std": ',tstd(ischeme) + write(*,"(4x,a,i7,',')") '"n_samples": ',nsamp + if (ischeme.ne.nschemes) then + write(*,"(4x,a,1pe11.4,'},')") '"max": ',tmax(ischeme) + else + write(*,"(4x,a,1pe11.4,'}')") '"max": ',tmax(ischeme) + endif +enddo +write(*,'(a)') "}" + +end program time_MOM_remapping diff --git a/config_src/drivers/unit_tests/test_MOM_remapping.F90 b/config_src/drivers/unit_tests/test_MOM_remapping.F90 new file mode 100644 index 0000000000..e62b779bd6 --- /dev/null +++ b/config_src/drivers/unit_tests/test_MOM_remapping.F90 @@ -0,0 +1,7 @@ +program test_MOM_remapping + +use MOM_remapping, only : remapping_unit_tests + +if (remapping_unit_tests(.true.)) stop 1 + +end program test_MOM_remapping diff --git a/config_src/external/GFDL_ocean_BGC/generic_tracer_utils.F90 b/config_src/external/GFDL_ocean_BGC/generic_tracer_utils.F90 index fec9c80461..5c87c37e70 100644 --- a/config_src/external/GFDL_ocean_BGC/generic_tracer_utils.F90 +++ b/config_src/external/GFDL_ocean_BGC/generic_tracer_utils.F90 @@ -99,8 +99,9 @@ module g_tracer_utils contains !> Unknown - subroutine g_tracer_flux_init(g_tracer) + subroutine g_tracer_flux_init(g_tracer, verbosity) type(g_tracer_type), pointer :: g_tracer !< Pointer to this tracer node + integer, optional, intent(in) :: verbosity !< A 0-9 integer indicating a level of verbosity end subroutine g_tracer_flux_init !> Unknown diff --git a/config_src/external/drifters/MOM_particles_types.F90 b/config_src/external/drifters/MOM_particles_types.F90 index 51e744a186..30fecad7a2 100644 --- a/config_src/external/drifters/MOM_particles_types.F90 +++ b/config_src/external/drifters/MOM_particles_types.F90 @@ -3,6 +3,7 @@ module particles_types_mod ! This file is part of MOM6. See LICENSE.md for the license. +use, intrinsic :: iso_fortran_env, only : int64 use MOM_grid, only : ocean_grid_type use MOM_domains, only: domain2D @@ -75,7 +76,7 @@ module particles_types_mod real :: vvel_old !< Previous meridional velocity component (m/s) integer :: year !< Year of this record integer :: particle_num !< Current particle number - integer(kind=8) :: id = -1 !< Particle Identifier + integer(kind=int64) :: id = -1 !< Particle Identifier type(xyt), pointer :: next=>null() !< Pointer to the next position in the list end type xyt @@ -98,8 +99,8 @@ module particles_types_mod real :: start_day !< origination position (degrees) and day integer :: start_year !< origination year real :: halo_part !< equal to zero for particles on the computational domain, and 1 for particles on the halo - integer(kind=8) :: id !< particle identifier - integer(kind=8) :: drifter_num !< particle identifier + integer(kind=int64) :: id !< particle identifier + integer(kind=int64) :: drifter_num !< particle identifier integer :: ine !< nearest i-index in NE direction (for convenience) integer :: jne !< nearest j-index in NE direction (for convenience) real :: xi !< non-dimensional x-coordinate within current cell (0..1) @@ -147,7 +148,7 @@ module particles_types_mod logical :: ignore_traj=.False. !< If true, then model does not write trajectory data at all logical :: use_new_predictive_corrective =.False. !< Flag to use Bob's predictive corrective particle scheme !Added by Alon - integer(kind=8) :: debug_particle_with_id = -1 !< If positive, monitors a part with this id + integer(kind=int64) :: debug_particle_with_id = -1 !< If positive, monitors a part with this id type(buffer), pointer :: obuffer_n=>null() !< Buffer for outgoing parts to the north type(buffer), pointer :: ibuffer_n=>null() !< Buffer for incoming parts from the north type(buffer), pointer :: obuffer_s=>null() !< Buffer for outgoing parts to the south diff --git a/config_src/infra/FMS1/MOM_diag_manager_infra.F90 b/config_src/infra/FMS1/MOM_diag_manager_infra.F90 index 232986f480..d9be18d33f 100644 --- a/config_src/infra/FMS1/MOM_diag_manager_infra.F90 +++ b/config_src/infra/FMS1/MOM_diag_manager_infra.F90 @@ -8,6 +8,7 @@ module MOM_diag_manager_infra ! This file is part of MOM6. See LICENSE.md for the license. +use, intrinsic :: iso_fortran_env, only : real64 use diag_axis_mod, only : fms_axis_init=>diag_axis_init use diag_axis_mod, only : fms_get_diag_axis_name => get_diag_axis_name use diag_axis_mod, only : EAST, NORTH @@ -359,7 +360,7 @@ end function send_data_infra_3d logical function send_data_infra_2d_r8(diag_field_id, field, is_in, ie_in, js_in, je_in, & time, mask, rmask, weight, err_msg) integer, intent(in) :: diag_field_id !< The diagnostic manager identifier for this field - real(kind=8), dimension(:,:), intent(in) :: field !< A 2-d array of values being recorded + real(kind=real64), dimension(:,:), intent(in) :: field !< A 2-d array of values being recorded integer, optional, intent(in) :: is_in !< The starting i-index for the data being recorded integer, optional, intent(in) :: ie_in !< The end i-index for the data being recorded integer, optional, intent(in) :: js_in !< The starting j-index for the data being recorded @@ -382,7 +383,7 @@ end function send_data_infra_2d_r8 logical function send_data_infra_3d_r8(diag_field_id, field, is_in, ie_in, js_in, je_in, ks_in, ke_in, & time, mask, rmask, weight, err_msg) integer, intent(in) :: diag_field_id !< The diagnostic manager identifier for this field - real(kind=8), dimension(:,:,:), intent(in) :: field !< A rank 1 array of floating point values being recorded + real(kind=real64), dimension(:,:,:), intent(in) :: field !< A rank 1 array of floating point values being recorded integer, optional, intent(in) :: is_in !< The starting i-index for the data being recorded integer, optional, intent(in) :: ie_in !< The end i-index for the data being recorded integer, optional, intent(in) :: js_in !< The starting j-index for the data being recorded diff --git a/config_src/infra/FMS2/MOM_diag_manager_infra.F90 b/config_src/infra/FMS2/MOM_diag_manager_infra.F90 index f05baa4474..57f92c2046 100644 --- a/config_src/infra/FMS2/MOM_diag_manager_infra.F90 +++ b/config_src/infra/FMS2/MOM_diag_manager_infra.F90 @@ -8,6 +8,7 @@ module MOM_diag_manager_infra ! This file is part of MOM6. See LICENSE.md for the license. +use, intrinsic :: iso_fortran_env, only : real64 use diag_axis_mod, only : fms_axis_init=>diag_axis_init use diag_axis_mod, only : fms_get_diag_axis_name => get_diag_axis_name use diag_axis_mod, only : EAST, NORTH @@ -361,7 +362,7 @@ end function send_data_infra_3d logical function send_data_infra_2d_r8(diag_field_id, field, is_in, ie_in, js_in, je_in, & time, mask, rmask, weight, err_msg) integer, intent(in) :: diag_field_id !< The diagnostic manager identifier for this field - real(kind=8), dimension(:,:), intent(in) :: field !< A 2-d array of values being recorded + real(kind=real64), dimension(:,:), intent(in) :: field !< A 2-d array of values being recorded integer, optional, intent(in) :: is_in !< The starting i-index for the data being recorded integer, optional, intent(in) :: ie_in !< The end i-index for the data being recorded integer, optional, intent(in) :: js_in !< The starting j-index for the data being recorded @@ -384,7 +385,7 @@ end function send_data_infra_2d_r8 logical function send_data_infra_3d_r8(diag_field_id, field, is_in, ie_in, js_in, je_in, ks_in, ke_in, & time, mask, rmask, weight, err_msg) integer, intent(in) :: diag_field_id !< The diagnostic manager identifier for this field - real(kind=8), dimension(:,:,:), intent(in) :: field !< A rank 1 array of floating point values being recorded + real(kind=real64), dimension(:,:,:), intent(in) :: field !< A rank 1 array of floating point values being recorded integer, optional, intent(in) :: is_in !< The starting i-index for the data being recorded integer, optional, intent(in) :: ie_in !< The end i-index for the data being recorded integer, optional, intent(in) :: js_in !< The starting j-index for the data being recorded diff --git a/src/ALE/MOM_ALE.F90 b/src/ALE/MOM_ALE.F90 index a083402fde..0ae5fb1e92 100644 --- a/src/ALE/MOM_ALE.F90 +++ b/src/ALE/MOM_ALE.F90 @@ -178,6 +178,7 @@ subroutine ALE_init( param_file, GV, US, max_depth, CS) logical :: local_logical logical :: remap_boundary_extrap logical :: init_boundary_extrap + logical :: om4_remap_via_sub_cells type(hybgen_regrid_CS), pointer :: hybgen_regridCS => NULL() ! Control structure for hybgen regridding ! for sharing parameters. @@ -234,6 +235,11 @@ subroutine ALE_init( param_file, GV, US, max_depth, CS) call get_param(param_file, mdl, "DEFAULT_ANSWER_DATE", default_answer_date, & "This sets the default value for the various _ANSWER_DATE parameters.", & default=99991231) + call get_param(param_file, mdl, "REMAPPING_USE_OM4_SUBCELLS", om4_remap_via_sub_cells, & + "This selects the remapping algorithm used in OM4 that does not use "//& + "the full reconstruction for the top- and lower-most sub-layers, but instead "//& + "assumes they are always vanished (untrue) and so just uses their edge values. "//& + "We recommend setting this option to false.", default=.true.) call get_param(param_file, mdl, "REMAPPING_ANSWER_DATE", CS%answer_date, & "The vintage of the expressions and order of arithmetic to use for remapping. "//& "Values below 20190101 result in the use of older, less accurate expressions "//& @@ -247,12 +253,14 @@ subroutine ALE_init( param_file, GV, US, max_depth, CS) 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, & answer_date=CS%answer_date) call initialize_remapping( CS%vel_remapCS, vel_string, & boundary_extrapolation=init_boundary_extrap, & 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, & answer_date=CS%answer_date) call get_param(param_file, mdl, "PARTIAL_CELL_VELOCITY_REMAP", CS%partial_cell_vel_remap, & @@ -326,6 +334,21 @@ subroutine ALE_set_extrap_boundaries( param_file, CS) call remapping_set_param(CS%remapCS, boundary_extrapolation=remap_boundary_extrap) end subroutine ALE_set_extrap_boundaries +!> Sets the remapping algorithm to that of OM4 +!! +!! The remapping aglorithm used in OM4 made poor assumptions about the reconstructions +!! in the top/bottom layers, namely that they were always vanished and could be +!! represented solely by their upper/lower edge value respectively. +!! Passing .false. here uses the full reconstruction of those top and bottom layers +!! and properly sample those layers. +subroutine ALE_set_OM4_remap_algorithm( CS, om4_remap_via_sub_cells ) + type(ALE_CS), pointer :: CS !< Module control structure + logical, intent(in) :: om4_remap_via_sub_cells !< If true, use OM4 remapping algorithm + + call remapping_set_param(CS%remapCS, om4_remap_via_sub_cells =om4_remap_via_sub_cells ) + +end subroutine ALE_set_OM4_remap_algorithm + !> Initialize diagnostics for the ALE module. subroutine ALE_register_diags(Time, G, GV, US, diag, CS) type(time_type),target, intent(in) :: Time !< Time structure diff --git a/src/ALE/MOM_regridding.F90 b/src/ALE/MOM_regridding.F90 index 8faec6c495..43d3f65a5e 100644 --- a/src/ALE/MOM_regridding.F90 +++ b/src/ALE/MOM_regridding.F90 @@ -211,6 +211,8 @@ subroutine initialize_regridding(CS, GV, US, max_depth, param_file, mdl, coord_m real :: tmpReal ! A temporary variable used in setting other variables [various] real :: P_Ref ! The coordinate variable reference pression [R L2 T-2 ~> Pa] real :: maximum_depth ! The maximum depth of the ocean [m] (not in Z). + real :: dz_extra ! The thickness of an added layer to append to the woa09_dz profile when + ! maximum_depth is large [m] (not in Z). real :: adaptTimeRatio, adaptZoomCoeff ! Temporary variables for input parameters [nondim] real :: adaptBuoyCoeff, adaptAlpha ! Temporary variables for input parameters [nondim] real :: adaptZoom ! The thickness of the near-surface zooming region with the adaptive coordinate [H ~> m or kg m-2] @@ -311,7 +313,7 @@ subroutine initialize_regridding(CS, GV, US, max_depth, param_file, mdl, coord_m param_name = create_coord_param(param_prefix, "DEF", param_suffix) coord_res_param = create_coord_param(param_prefix, "RES", param_suffix) string2 = 'UNIFORM' - if (maximum_depth>3000.) string2='WOA09' ! For convenience + if ((maximum_depth>3000.) .and. (maximum_depth<9250.)) string2='WOA09' ! For convenience endif call get_param(param_file, mdl, param_name, string, & "Determines how to specify the coordinate "//& @@ -458,20 +460,27 @@ subroutine initialize_regridding(CS, GV, US, max_depth, param_file, mdl, coord_m endif elseif (index(trim(string),'WOA09')==1) then if (len_trim(string)==5) then - tmpReal = 0. ; ke = 0 + tmpReal = 0. ; ke = 0 ; dz_extra = 0. do while (tmpReal size(woa09_dz)) then + dz_extra = maximum_depth - tmpReal + exit + endif tmpReal = tmpReal + woa09_dz(ke) enddo elseif (index(trim(string),'WOA09:')==1) then if (len_trim(string)==6) call MOM_error(FATAL,trim(mdl)//', initialize_regridding: '// & 'Expected string of form "WOA09:N" but got "'//trim(string)//'".') ke = extract_integer(string(7:len_trim(string)),'',1) + if (ke>40 .or. ke<1) call MOM_error(FATAL,trim(mdl)//', initialize_regridding: '// & + 'For "WOA05:N" N must 040 .or. ke<1) call MOM_error(FATAL,trim(mdl)//', initialize_regridding: '// & - 'For "WOA05:N" N must 0 size(woa09_dz)) dz(ke) = dz_extra else call MOM_error(FATAL,trim(mdl)//", initialize_regridding: "// & "Unrecognized coordinate configuration"//trim(string)) diff --git a/src/ALE/MOM_remapping.F90 b/src/ALE/MOM_remapping.F90 index 0fdf80bf52..364a322f0f 100644 --- a/src/ALE/MOM_remapping.F90 +++ b/src/ALE/MOM_remapping.F90 @@ -5,7 +5,6 @@ module MOM_remapping ! Original module written by Laurent White, 2008.06.09 use MOM_error_handler, only : MOM_error, FATAL -use MOM_io, only : stdout, stderr use MOM_string_functions, only : uppercase use regrid_edge_values, only : edge_values_explicit_h4, edge_values_implicit_h4 use regrid_edge_values, only : edge_values_explicit_h4cw @@ -38,6 +37,40 @@ module MOM_remapping !> 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 + !> If true, use the OM4 version of the remapping algorithm that makes poor assumptions + !! about the reconstructions in top and bottom layers of the source grid + logical :: om4_remap_via_sub_cells = .false. +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 end type ! The following routines are visible to the outside world @@ -63,8 +96,6 @@ module MOM_remapping integer, parameter :: INTEGRATION_PPM = 3 !< Piecewise Parabolic Method integer, parameter :: INTEGRATION_PQM = 5 !< Piecewise Quartic Method -character(len=40) :: mdl = "MOM_remapping" !< This module's name. - !> Documentation for external callers character(len=360), public :: remappingSchemesDoc = & "PCM (1st-order accurate)\n"//& @@ -82,13 +113,15 @@ 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, answers_2018, answer_date) + check_reconstruction, check_remapping, force_bounds_in_subcell, & + om4_remap_via_sub_cells, answers_2018, answer_date) type(remapping_CS), intent(inout) :: CS !< Remapping control structure character(len=*), optional, intent(in) :: remapping_scheme !< Remapping scheme to use logical, optional, intent(in) :: boundary_extrapolation !< Indicate to extrapolate in boundary cells 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) :: 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 @@ -107,6 +140,9 @@ 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(om4_remap_via_sub_cells)) then + CS%om4_remap_via_sub_cells = om4_remap_via_sub_cells + endif if (present(answers_2018)) then if (answers_2018) then CS%answer_date = 20181231 @@ -141,22 +177,11 @@ subroutine extract_member_remapping_CS(CS, remapping_scheme, degree, boundary_ex end subroutine extract_member_remapping_CS -!> 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 - !> Remaps column of values u0 on grid h0 to grid h1 assuming the top edge is aligned. +!! +!! \todo Remove h_neglect argument by moving into remapping_CS +!! \todo Remove PCM_cell argument by adding new method in Recon1D class +!! \todo Inline the two versions of remap_via_sub_cells() in remapping_core_h() to eliminate remap_via_sub_cells() subroutine remapping_core_h(CS, n0, h0, u0, n1, h1, u1, h_neglect, h_neglect_edge, PCM_cell) type(remapping_CS), intent(in) :: CS !< Remapping control structure integer, intent(in) :: n0 !< Number of cells on source grid @@ -181,22 +206,31 @@ subroutine remapping_core_h(CS, n0, h0, u0, n1, h1, u1, h_neglect, h_neglect_edg real :: uh_err ! A bound on the error in the sum of u*h, as estimated by the remapping code [A H] real :: hNeglect, hNeglect_edge ! Negligibly small cell widths in the same units as h0 [H] integer :: iMethod ! An integer indicating the integration method used - integer :: k hNeglect = 1.0e-30 ; if (present(h_neglect)) hNeglect = h_neglect hNeglect_edge = 1.0e-10 ; if (present(h_neglect_edge)) hNeglect_edge = h_neglect_edge call build_reconstructions_1d( CS, n0, h0, u0, ppoly_r_coefs, ppoly_r_E, ppoly_r_S, iMethod, & - hNeglect, hNeglect_edge, PCM_cell ) + hNeglect, hNeglect_edge, PCM_cell ) - if (CS%check_reconstruction) call check_reconstructions_1d(n0, h0, u0, CS%degree, & - CS%boundary_extrapolation, ppoly_r_coefs, ppoly_r_E, ppoly_r_S) + if (CS%om4_remap_via_sub_cells) then - call remap_via_sub_cells( n0, h0, u0, ppoly_r_E, ppoly_r_coefs, n1, h1, iMethod, & - CS%force_bounds_in_subcell, u1, uh_err ) + if (CS%check_reconstruction) call check_reconstructions_1d(n0, h0, u0, CS%degree, & + CS%boundary_extrapolation, ppoly_r_coefs, ppoly_r_E) - 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") + ! This calls the OM4 version of the remapmping algorithms + call remap_via_sub_cells_om4( n0, h0, u0, ppoly_r_E, ppoly_r_coefs, n1, h1, iMethod, & + CS%force_bounds_in_subcell, u1, uh_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 ! i.e. if (CS%om4_remap_via_sub_cells == .false.) + + call remap_via_sub_cells( n0, h0, u0, ppoly_r_E, ppoly_r_coefs, n1, h1, iMethod, & + CS%force_bounds_in_subcell, u1, uh_err ) + + endif end subroutine remapping_core_h @@ -233,7 +267,7 @@ subroutine remapping_core_w( CS, n0, h0, u0, n1, dx, u1, h_neglect, h_neglect_ed hNeglect, hNeglect_edge ) if (CS%check_reconstruction) call check_reconstructions_1d(n0, h0, u0, CS%degree, & - CS%boundary_extrapolation, ppoly_r_coefs, ppoly_r_E, ppoly_r_S) + CS%boundary_extrapolation, ppoly_r_coefs, ppoly_r_E) ! This is a temporary step prior to switching to remapping_core_h() do k = 1, n1 @@ -387,15 +421,14 @@ end subroutine build_reconstructions_1d !> Checks that edge values and reconstructions satisfy bounds subroutine check_reconstructions_1d(n0, h0, u0, deg, boundary_extrapolation, & - ppoly_r_coefs, ppoly_r_E, ppoly_r_S) + ppoly_r_coefs, ppoly_r_E) integer, intent(in) :: n0 !< Number of cells on source grid real, dimension(n0), intent(in) :: h0 !< Cell widths on source grid [H] real, dimension(n0), intent(in) :: u0 !< Cell averages on source grid [A] integer, intent(in) :: deg !< Degree of polynomial reconstruction logical, intent(in) :: boundary_extrapolation !< Extrapolate at boundaries if true - real, dimension(n0,deg+1),intent(in) :: ppoly_r_coefs !< Coefficients of polynomial [A] - real, dimension(n0,2), intent(in) :: ppoly_r_E !< Edge value of polynomial [A] - real, dimension(n0,2), intent(in) :: ppoly_r_S !< Edge slope of polynomial [A H-1] + real, dimension(n0,deg+1),intent(in) :: ppoly_r_coefs !< Coefficients of polynomial [A] + real, dimension(n0,2), intent(in) :: ppoly_r_E !< Edge value of polynomial [A] ! Local variables integer :: i0, n real :: u_l, u_c, u_r ! Cell averages [A] @@ -460,8 +493,67 @@ end subroutine check_reconstructions_1d !> Remaps column of n0 values u0 on grid h0 to grid h1 with n1 cells by calculating !! the n0+n1+1 sub-integrals of the intersection of h0 and h1, and the summing the !! appropriate integrals into the h1*u1 values. h0 and h1 must have the same units. +!! +!! This uses a buggy remap_via_sub_cells_om4() that produces the wrong value for +!! bottom layers that do not match the same total depth of the water column. +subroutine remap_via_sub_cells_om4(n0, h0, u0, ppoly0_E, ppoly0_coefs, n1, h1, method, & + force_bounds_in_subcell, u1, uh_err) + integer, intent(in) :: n0 !< Number of cells in source grid + real, intent(in) :: h0(n0) !< Source grid widths (size n0) [H] + real, intent(in) :: u0(n0) !< Source cell averages (size n0) [A] + real, intent(in) :: ppoly0_E(n0,2) !< 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(n1) !< Target grid widths (size n1) [H] + integer, intent(in) :: method !< Remapping scheme to use + logical, intent(in) :: force_bounds_in_subcell !< Force sub-cell values to be bounded + 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 + 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] + real, dimension(n0+n1+1) :: u_sub ! Average of u over each sub-cell [A] + integer, dimension(n0+n1+1) :: isub_src ! Index of source cell for each sub-cell + integer, dimension(n0) :: isrc_start ! Index of first sub-cell within each source cell + integer, dimension(n0) :: isrc_end ! Index of last sub-cell within each source cell + integer, dimension(n0) :: isrc_max ! Index of thickest sub-cell within each source cell + real, dimension(n0) :: h0_eff ! Effective thickness of source cells [H] + 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] + + ! 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 ) + + ! 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_om4(n0, h0, u0, ppoly0_E, ppoly0_coefs, n1, h_sub, & + h0_eff, isrc_start, isrc_end, isrc_max, isub_src, & + method, force_bounds_in_subcell, 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) + + ! Include the error remapping from source to sub-cells in the estimate of total remapping error + uh_err = uh_err + u02_err + +end subroutine remap_via_sub_cells_om4 + +!> Remaps column of n0 values u0 on grid h0 to grid h1 with n1 cells by calculating +!! the n0+n1+1 sub-integrals of the intersection of h0 and h1, and the summing the +!! appropriate integrals into the h1*u1 values. h0 and h1 must have the same units. +!! +!! \todo Remove h0_eff which is not needed +!! \todo Undo force_bounds_in_target when switching to Recon1D class subroutine remap_via_sub_cells( n0, h0, u0, ppoly0_E, ppoly0_coefs, n1, h1, method, & - force_bounds_in_subcell, u1, uh_err, ah_sub, aisub_src, aiss, aise ) + force_bounds_in_subcell, u1, uh_err) integer, intent(in) :: n0 !< Number of cells in source grid real, intent(in) :: h0(n0) !< Source grid widths (size n0) [H] real, intent(in) :: u0(n0) !< Source cell averages (size n0) [A] @@ -473,18 +565,7 @@ subroutine remap_via_sub_cells( n0, h0, u0, ppoly0_E, ppoly0_coefs, n1, h1, meth logical, intent(in) :: force_bounds_in_subcell !< Force sub-cell values to be bounded 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] - real, optional, intent(out) :: ah_sub(n0+n1+1) !< Overlapping sub-cell thicknesses, h_sub [H] - integer, optional, intent(out) :: aisub_src(n0+n1+1) !< i_sub_src - integer, optional, intent(out) :: aiss(n0) !< isrc_start - integer, optional, intent(out) :: aise(n0) !< isrc_ens ! Local variables - integer :: i_sub ! Index of sub-cell - integer :: i0 ! Index into h0(1:n0), source column - integer :: i1 ! Index into h1(1:n1), target column - integer :: i_start0 ! Used to record which sub-cells map to source cells - integer :: i_start1 ! Used to record which sub-cells map to target cells - 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, 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] real, dimension(n0+n1+1) :: u_sub ! Average of u over each sub-cell [A] @@ -493,33 +574,85 @@ subroutine remap_via_sub_cells( n0, h0, u0, ppoly0_E, ppoly0_coefs, n1, h1, meth integer, dimension(n0) :: isrc_end ! Index of last sub-cell within each source cell integer, dimension(n0) :: isrc_max ! Index of thickest sub-cell within each source cell real, dimension(n0) :: h0_eff ! Effective thickness of source cells [H] - real, dimension(n0) :: u0_min ! Minimum value of reconstructions in source cell [A] - real, dimension(n0) :: u0_max ! Minimum value of reconstructions in source cell [A] 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 - real :: xa, xb ! Non-dimensional position within a source cell (0..1) [nondim] + ! 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] + + ! 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 ) + + ! 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, ppoly0_E, ppoly0_coefs, n1, h_sub, & + isrc_start, isrc_end, isrc_max, isub_src, & + method, force_bounds_in_subcell, 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) + + ! Include the error remapping from source to sub-cells in the estimate of total remapping error + uh_err = uh_err + u02_err + +end subroutine remap_via_sub_cells + +!> Returns the intersection of source and targets grids along with and auxiliary lists or indices. +!! +!! For source grid with thicknesses h0(1:n0) and target grid with thicknesses h1(1:n1) the intersection +!! or "subgrid" has thicknesses h_sub(1:n0+n1+1). +!! h0 and h1 must have the same units. h_sub will return with the same units as h0 and h1. +!! +!! Notes on the algorithm: +!! Internally, grids are defined by the interfaces (although we describe grids via thicknesses for accuracy). +!! The intersection or union of two grids is thus defined by the super set of both lists of interfaces. +!! Because both source and target grids can contain vanished cells, we do not eliminate repeated +!! interfaces from the union. +!! That is, the total number of interfaces of the sub-cells is equal to the total numer of interfaces of +!! the source grid (n0+1) plus the total number of interfaces of the target grid (n1+1), i.e. n0+n1+2. +!! Whenever target and source interfaces align, then the retention of identical interfaces leads to a +!! vanished subcell. +!! The remapping uses a common point of reference to the left (top) so there is always a vanished subcell +!! at the left (top). +!! If the total column thicknesses are the same, then the right (bottom) interfaces are also aligned and +!! so the last subcell will also be vanished. +subroutine intersect_src_tgt_grids( n0, h0, n1, h1, h_sub, h0_eff, & + isrc_start, isrc_end, isrc_max, itgt_start, itgt_end, isub_src ) + 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 + real, intent(in) :: h1(n1) !< Target grid widths (size n1) [H] + real, intent(out) :: h_sub(n0+n1+1) !< Overlapping sub-cell thicknesses, h_sub [H] + real, intent(out) :: h0_eff(n0) !< Effective thickness of source cells [H] + integer, intent(out) :: isrc_start(n0) !< Index of first sub-cell within each source cell + integer, intent(out) :: isrc_end(n0) !< Index of last sub-cell within each source cell + integer, intent(out) :: isrc_max(n0) !< Index of thickest sub-cell within each source cell + integer, intent(out) :: itgt_start(n1) !< Index of first sub-cell within each target cell + integer, intent(out) :: itgt_end(n1) !< Index of last sub-cell within each target cell + integer, intent(out) :: isub_src(n0+n1+1) !< Index of source cell for each sub-cell + ! Local variables + integer :: i_sub ! Index of sub-cell + integer :: i0 ! Index into h0(1:n0), source column + integer :: i1 ! Index into h1(1:n1), target column + integer :: i_start0 ! Used to record which sub-cells map to source cells + integer :: i_start1 ! Used to record which sub-cells map to target cells + 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 :: h0_supply, h1_supply ! The amount of width available for constructing sub-cells [H] 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] ! For error checking/debugging - logical, parameter :: force_bounds_in_target = .true. ! To fix round-off issues - logical, parameter :: adjust_thickest_subcell = .true. ! To fix round-off conservation issues - logical, parameter :: debug_bounds = .false. ! For debugging overshoots etc. - integer :: k, i0_last_thick_cell - real :: h0tot, h1tot, h2tot ! Summed thicknesses used for debugging [H] - real :: h0err, h1err, h2err ! Estimates of round-off errors used for debugging [H] - real :: u02_err, u0err, u1err, u2err ! Integrated reconstruction error estimates [H A] - real :: u0tot, u1tot, u2tot ! Integrated reconstruction values [H A] - real :: u_orig ! The original value of the reconstruction in a cell [A] - real :: u0min, u0max, u1min, u1max, u2min, u2max ! Minimum and maximum values of reconstructions [A] + 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 - u0_min(i0) = min(ppoly0_E(i0,1), ppoly0_E(i0,2)) - u0_max(i0) = max(ppoly0_E(i0,1), ppoly0_E(i0,2)) if (h0(i0)>0.) i0_last_thick_cell = i0 enddo @@ -649,8 +782,57 @@ subroutine remap_via_sub_cells( n0, h0, u0, ppoly0_E, ppoly0_coefs, n1, h1, meth endif enddo +end subroutine intersect_src_tgt_grids + +!> 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 +!! the target grid and extrapolation is needed. +subroutine remap_src_to_sub_grid_om4(n0, h0, u0, ppoly0_E, ppoly0_coefs, n1, h_sub, & + h0_eff, isrc_start, isrc_end, isrc_max, isub_src, & + method, force_bounds_in_subcell, u_sub, uh_sub, u02_err) + integer, intent(in) :: n0 !< Number of cells in source grid + real, intent(in) :: h0(n0) !< Source grid widths (size n0) [H] + real, intent(in) :: u0(n0) !< Source grid widths (size n0) [H] + real, intent(in) :: ppoly0_E(n0,2) !< 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) :: h_sub(n0+n1+1) !< Overlapping sub-cell thicknesses, h_sub [H] + real, intent(in) :: h0_eff(n0) !< Effective thickness of source cells [H] + 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 + integer, intent(in) :: isub_src(n0+n1+1) !< Index of source cell for each sub-cell + integer, intent(in) :: method !< Remapping scheme to use + logical, intent(in) :: force_bounds_in_subcell !< Force sub-cell values to be bounded + real, intent(out) :: u_sub(n0+n1+1) !< Sub-cell cell averages (size n1) [A] + real, intent(out) :: uh_sub(n0+n1+1) !< 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] + 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 + real :: u_orig ! The original value of the reconstruction in a cell [A] + + i0_last_thick_cell = 0 + do i0 = 1, n0 + u0_min(i0) = min(ppoly0_E(i0,1), ppoly0_E(i0,2)) + u0_max(i0) = max(ppoly0_E(i0,1), ppoly0_E(i0,2)) + 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. uh_sub(1) = 0. @@ -676,19 +858,6 @@ subroutine remap_via_sub_cells( n0, h0, u0, ppoly0_E, ppoly0_coefs, n1, h1, meth xb = 1. u_sub(i_sub) = u0(i0) endif - if (debug_bounds) then - if (method<5 .and.(u_sub(i_sub)u0_max(i0))) then - write(0,*) 'Sub cell average is out of bounds',i_sub,'method=',method - write(0,*) 'xa,xb: ',xa,xb - write(0,*) 'Edge values: ',ppoly0_E(i0,:),'mean',u0(i0) - write(0,*) 'a_c: ',(u0(i0)-ppoly0_E(i0,1))+(u0(i0)-ppoly0_E(i0,2)) - write(0,*) 'Polynomial coeffs: ',ppoly0_coefs(i0,:) - write(0,*) 'Bounds min=',u0_min(i0),'max=',u0_max(i0) - write(0,*) 'Average: ',u_sub(i_sub),'rel to min=',u_sub(i_sub)-u0_min(i0),'rel to max=',u_sub(i_sub)-u0_max(i0) - call MOM_error( FATAL, 'MOM_remapping, remap_via_sub_cells: '//& - 'Sub-cell average is out of bounds!' ) - endif - endif if (force_bounds_in_subcell) then ! These next two lines should not be needed but when using PQM we found roundoff ! can lead to overshoots. These lines sweep issues under the rug which need to be @@ -716,6 +885,8 @@ subroutine remap_via_sub_cells( n0, h0, u0, ppoly0_E, ppoly0_coefs, n1, h1, meth ! 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) @@ -731,7 +902,177 @@ subroutine remap_via_sub_cells( n0, h0, u0, ppoly0_E, ppoly0_coefs, n1, h1, meth enddo endif +end subroutine remap_src_to_sub_grid_om4 + +!> Remaps column of n0 values u0 on grid h0 to subgrid h_sub +subroutine remap_src_to_sub_grid(n0, h0, u0, ppoly0_E, ppoly0_coefs, n1, h_sub, & + isrc_start, isrc_end, isrc_max, isub_src, & + method, force_bounds_in_subcell, u_sub, uh_sub, u02_err) + integer, intent(in) :: n0 !< Number of cells in source grid + real, intent(in) :: h0(n0) !< Source grid widths (size n0) [H] + real, intent(in) :: u0(n0) !< Source grid widths (size n0) [H] + real, intent(in) :: ppoly0_E(n0,2) !< 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) :: h_sub(n0+n1+1) !< Overlapping sub-cell thicknesses, h_sub [H] + 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 + integer, intent(in) :: isub_src(n0+n1+1) !< Index of source cell for each sub-cell + integer, intent(in) :: method !< Remapping scheme to use + logical, intent(in) :: force_bounds_in_subcell !< Force sub-cell values to be bounded + real, intent(out) :: u_sub(n0+n1+1) !< Sub-cell cell averages (size n1) [A] + real, intent(out) :: uh_sub(n0+n1+1) !< 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] + 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 + real :: u_orig ! The original value of the reconstruction in a cell [A] + + i0_last_thick_cell = 0 + do i0 = 1, n0 + u0_min(i0) = min(ppoly0_E(i0,1), ppoly0_E(i0,2)) + u0_max(i0) = max(ppoly0_E(i0,1), ppoly0_E(i0,2)) + 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) = average_value_ppoly( n0, u0, ppoly0_E, ppoly0_coefs, method, i0, xa, xb) + else ! Vanished cell + xb = 1. + u_sub(i_sub) = u0(i0) + endif + if (force_bounds_in_subcell) then + ! These next two lines should not be needed but when using PQM we found roundoff + ! can lead to overshoots. These lines sweep issues under the rug which need to be + ! properly .. later. -AJA + u_orig = 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) ) + u02_err = u02_err + dh*abs( u_sub(i_sub) - u_orig ) + endif + 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) = average_value_ppoly( n0, u0, ppoly0_E, ppoly0_coefs, method, i0, xa, xb) + else ! Vanished cell + xb = 1. + u_sub(i_sub) = u0(i0) + endif + if (force_bounds_in_subcell) then + ! These next two lines should not be needed but when using PQM we found roundoff + ! can lead to overshoots. These lines sweep issues under the rug which need to be + ! properly .. later. -AJA + u_orig = 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) ) + u02_err = u02_err + dh*abs( u_sub(i_sub) - u_orig ) + endif + uh_sub(i_sub) = dh * u_sub(i_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). + ! 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 + endif + +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, & + 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 + 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 + 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] + + u1min = 0. ! Not necessary, but avoids an overzealous compiler ... + u1max = 0. ! ... warning about uninitialized variables + ! 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 @@ -765,91 +1106,7 @@ subroutine remap_via_sub_cells( n0, h0, u0, ppoly0_E, ppoly0_coefs, n1, h1, meth endif enddo - ! Check errors and bounds - if (debug_bounds) then - call measure_input_bounds( n0, h0, u0, ppoly0_E, h0tot, h0err, u0tot, u0err, u0min, u0max ) - call measure_output_bounds( n1, h1, u1, h1tot, h1err, u1tot, u1err, u1min, u1max ) - call measure_output_bounds( n0+n1+1, h_sub, u_sub, h2tot, h2err, u2tot, u2err, u2min, u2max ) - if (method<5) then ! We except PQM until we've debugged it - if ( (abs(u1tot-u0tot)>(u0err+u1err)+uh_err+u02_err .and. abs(h1tot-h0tot)u0err+u2err+u02_err .and. abs(h2tot-h0tot)u0max) ) then - write(0,*) 'method = ',method - write(0,*) 'Source to sub-cells:' - write(0,*) 'H: h0tot=',h0tot,'h2tot=',h2tot,'dh=',h2tot-h0tot,'h0err=',h0err,'h2err=',h2err - if (abs(h2tot-h0tot)>h0err+h2err) & - write(0,*) 'H non-conservation difference=',h2tot-h0tot,'allowed err=',h0err+h2err,' <-----!' - write(0,*) 'UH: u0tot=',u0tot,'u2tot=',u2tot,'duh=',u2tot-u0tot,'u0err=',u0err,'u2err=',u2err,& - 'adjustment err=',u02_err - if (abs(u2tot-u0tot)>u0err+u2err) & - write(0,*) 'U non-conservation difference=',u2tot-u0tot,'allowed err=',u0err+u2err,' <-----!' - write(0,*) 'Sub-cells to target:' - write(0,*) 'H: h2tot=',h2tot,'h1tot=',h1tot,'dh=',h1tot-h2tot,'h2err=',h2err,'h1err=',h1err - if (abs(h1tot-h2tot)>h2err+h1err) & - write(0,*) 'H non-conservation difference=',h1tot-h2tot,'allowed err=',h2err+h1err,' <-----!' - write(0,*) 'UH: u2tot=',u2tot,'u1tot=',u1tot,'duh=',u1tot-u2tot,'u2err=',u2err,'u1err=',u1err,'uh_err=',uh_err - if (abs(u1tot-u2tot)>u2err+u1err) & - write(0,*) 'U non-conservation difference=',u1tot-u2tot,'allowed err=',u2err+u1err,' <-----!' - write(0,*) 'Source to target:' - write(0,*) 'H: h0tot=',h0tot,'h1tot=',h1tot,'dh=',h1tot-h0tot,'h0err=',h0err,'h1err=',h1err - if (abs(h1tot-h0tot)>h0err+h1err) & - write(0,*) 'H non-conservation difference=',h1tot-h0tot,'allowed err=',h0err+h1err,' <-----!' - write(0,*) 'UH: u0tot=',u0tot,'u1tot=',u1tot,'duh=',u1tot-u0tot,'u0err=',u0err,'u1err=',u1err,'uh_err=',uh_err - if (abs(u1tot-u0tot)>(u0err+u1err)+uh_err) & - write(0,*) 'U non-conservation difference=',u1tot-u0tot,'allowed err=',u0err+u1err+uh_err,' <-----!' - write(0,*) 'U: u0min=',u0min,'u1min=',u1min,'u2min=',u2min - if (u1minu0max) write(0,*) 'U2 maximum overshoot=',u2max-u0max,' <-----!' - write(0,'(a3,6a24,2a3)') 'k','h0','left edge','u0','right edge','h1','u1','is','ie' - do k = 1, max(n0,n1) - if (k<=min(n0,n1)) then - write(0,'(i3,1p6e24.16,2i3)') k,h0(k),ppoly0_E(k,1),u0(k),ppoly0_E(k,2),h1(k),u1(k),itgt_start(k),itgt_end(k) - elseif (k>n0) then - write(0,'(i3,96x,1p2e24.16,2i3)') k,h1(k),u1(k),itgt_start(k),itgt_end(k) - else - write(0,'(i3,1p4e24.16)') k,h0(k),ppoly0_E(k,1),u0(k),ppoly0_E(k,2) - endif - enddo - write(0,'(a3,2a24)') 'k','u0','Polynomial coefficients' - do k = 1, n0 - write(0,'(i3,1p6e24.16)') k,u0(k),ppoly0_coefs(k,:) - enddo - write(0,'(a3,3a24,a3,2a24)') 'k','Sub-cell h','Sub-cell u','Sub-cell hu','i0','xa','xb' - xa = 0. - dh0_eff = 0. - do k = 1, n0+n1+1 - dh = h_sub(k) - i0 = isub_src(k) - dh0_eff = dh0_eff + dh ! Cumulative thickness within the source cell - xb = dh0_eff / h0_eff(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 - write(0,'(i3,1p3e24.16,i3,1p2e24.16)') k,h_sub(k),u_sub(k),uh_sub(k),i0,xa,xb - if (k<=n0+n1) then - if (isub_src(k+1) /= i0) then - dh0_eff = 0.; xa = 0. - else - xa = xb - endif - endif - enddo - call MOM_error( FATAL, 'MOM_remapping, remap_via_sub_cells: '//& - 'Remapping result is inconsistent!' ) - endif - endif ! method<5 - endif ! debug_bounds - - ! Include the error remapping from source to sub-cells in the estimate of total remapping error - uh_err = uh_err + u02_err - - if (present(ah_sub)) ah_sub(1:n0+n1+1) = h_sub(1:n0+n1+1) - if (present(aisub_src)) aisub_src(1:n0+n1+1) = isub_src(1:n0+n1+1) - if (present(aiss)) aiss(1:n0) = isrc_start(1:n0) - if (present(aise)) aise(1:n0) = isrc_end(1:n0) - -end subroutine remap_via_sub_cells +end subroutine remap_sub_to_tgt_grid !> Linearly interpolate interface data, u_src, from grid h_src to a grid h_dest subroutine interpolate_column(nsrc, h_src, u_src, ndest, h_dest, u_dest, mask_edges) @@ -942,6 +1199,7 @@ subroutine reintegrate_column(nsrc, h_src, uh_src, ndest, h_dest, uh_dest) k_dest = 0 h_dest_rem = 0. h_src_rem = 0. + uh_src_rem = 0. src_ran_out = .false. do while(.true.) @@ -997,8 +1255,8 @@ end subroutine reintegrate_column !! separation dh. real function average_value_ppoly( n0, u0, ppoly0_E, ppoly0_coefs, method, i0, xa, xb) integer, intent(in) :: n0 !< Number of cells in source grid - real, intent(in) :: u0(:) !< Cell means [A] - real, intent(in) :: ppoly0_E(:,:) !< Edge value of polynomial [A] + real, intent(in) :: u0(n0) !< Cell means [A] + real, intent(in) :: ppoly0_E(n0,2) !< Edge value of polynomial [A] real, intent(in) :: ppoly0_coefs(:,:) !< Coefficients of polynomial [A] integer, intent(in) :: method !< Remapping scheme to use integer, intent(in) :: i0 !< Source cell index @@ -1013,6 +1271,7 @@ real function average_value_ppoly( n0, u0, ppoly0_E, ppoly0_coefs, method, i0, x real :: a_L, a_R, u_c, a_c ! Values of the polynomial at various locations [A] real, parameter :: r_3 = 1.0/3.0 ! Used in evaluation of integrated polynomials [nondim] + u_ave = 0. ! Avoids warnings about "potentially unset values"; u_ave is always calculated for legitimate schemes if (xb > xa) then select case ( method ) case ( INTEGRATION_PCM ) @@ -1091,6 +1350,7 @@ real function average_value_ppoly( n0, u0, ppoly0_E, ppoly0_coefs, method, i0, x + xa * ( ppoly0_coefs(i0,4) & + xa * ppoly0_coefs(i0,5) ) ) ) case default + u_ave = 0. call MOM_error( FATAL,'The selected integration method is invalid' ) end select endif @@ -1257,7 +1517,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, answers_2018, answer_date) + check_reconstruction, check_remapping, force_bounds_in_subcell, & + om4_remap_via_sub_cells, answers_2018, answer_date) ! Arguments type(remapping_CS), intent(inout) :: CS !< Remapping control structure character(len=*), intent(in) :: remapping_scheme !< Remapping scheme to use @@ -1265,13 +1526,15 @@ 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) :: 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 ! 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, & - force_bounds_in_subcell=force_bounds_in_subcell, answers_2018=answers_2018, answer_date=answer_date) + 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) end subroutine initialize_remapping @@ -1339,74 +1602,66 @@ end subroutine end_remapping logical function remapping_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), u0(n0) ! Thicknesses [H], interface heights [H] and values [A] for profile 0 - real :: h1(n1), x1(n1+1), u1(n1) ! Thicknesses [H], interface heights [H] and values [A] for profile 1 - real :: dx1(n1+1) ! Interface height changes for profile 1 [H] - real :: h2(n2), x2(n2+1), u2(n2) ! Thicknesses [H], interface heights [H] and values [A] for profile 2 - data u0 /9., 3., -3., -9./ ! Linear profile, 4 at surface to -4 at bottom [A] - data h0 /4*0.75/ ! 4 uniform layers with total depth of 3 [H] - data h1 /3*1./ ! 3 uniform layers with total depth of 3 [H] - data h2 /6*0.5/ ! 6 uniform layers with total depth of 3 [H] + 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 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] + real, allocatable, dimension(:) :: h_sub, h0_eff ! Subgrid and effective source thicknesses [H] + real, allocatable, dimension(:) :: u_sub, uh_sub ! Subgrid values and totals [A, A H] + real :: u02_err ! Error in remaping [A] + integer, allocatable, dimension(:) :: isrc_start, isrc_end, isrc_max, itgt_start, itgt_end, isub_src ! Indices integer :: answer_date ! The vintage of the expressions to test - integer :: i real, parameter :: hNeglect_dflt = 1.0e-30 ! A thickness [H ~> m or kg m-2] that can be ! added to thicknesses in a denominator without ! changing the numerical result, except where ! a division by zero would otherwise occur. real :: err ! Errors in the remapped thicknesses [H] or values [A] real :: h_neglect, h_neglect_edge ! Tiny thicknesses used in remapping [H] - logical :: thisTest, v, fail + type(testing) :: test ! Unit testing convenience functions + integer :: om4 + character(len=4) :: om4_tag + + call test%set( verbose=verbose ) ! Sets the verbosity flag in test - v = verbose answer_date = 20190101 ! 20181231 h_neglect = hNeglect_dflt h_neglect_edge = hNeglect_dflt ; if (answer_date < 20190101) h_neglect_edge = 1.0e-10 - write(stdout,*) '==== MOM_remapping: remapping_unit_tests =================' - remapping_unit_tests = .false. ! Normally return false + if (verbose) write(test%stdout,*) ' ===== MOM_remapping: remapping_unit_tests =================' - thisTest = .false. - call buildGridFromH(n0, h0, x0) - do i=1,n0+1 - err=x0(i)-0.75*real(i-1) - if (abs(err)>real(i-1)*epsilon(err)) thisTest = .true. - enddo - if (thisTest) write(stdout,*) 'remapping_unit_tests: Failed buildGridFromH() 1' - remapping_unit_tests = remapping_unit_tests .or. thisTest - call buildGridFromH(n1, h1, x1) - do i=1,n1+1 - err=x1(i)-real(i-1) - if (abs(err)>real(i-1)*epsilon(err)) thisTest = .true. - enddo - if (thisTest) write(stdout,*) 'remapping_unit_tests: Failed buildGridFromH() 2' - remapping_unit_tests = remapping_unit_tests .or. thisTest + ! 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 - - - - -' - thisTest = .false. call initialize_remapping(CS, 'PPM_H4', answer_date=answer_date) - if (verbose) write(stdout,*) 'h0 (test data)' - if (verbose) call dumpGrid(n0,h0,x0,u0) + ! Profile 0: 4 layers of thickness 0.75 and total depth 3, with du/dz=8 + n0 = 4 + allocate( h0(n0), u0(n0) ) + h0 = (/0.75, 0.75, 0.75, 0.75/) + u0 = (/9., 3., -3., -9./) + + ! Profile 1: 3 layers of thickness 1.0 and total depth 3 + n1 = 3 + allocate( h1(n1), u1(n1), dx1(n1+1) ) + h1 = (/1.0, 1.0, 1.0/) + + ! Profile 2: 6 layers of thickness 0.5 and total depth 3 + n2 = 6 + allocate( h2(n2), u2(n2) ) + h2 = (/0.5, 0.5, 0.5, 0.5, 0.5, 0.5/) + + ! Mapping u1 from h1 to h2 call dzFromH1H2( n0, h0, n1, h1, dx1 ) call remapping_core_w( CS, n0, h0, u0, n1, dx1, u1, h_neglect, h_neglect_edge) - do i=1,n1 - err=u1(i)-8.*(0.5*real(1+n1)-real(i)) - if (abs(err)>real(n1-1)*epsilon(err)) thisTest = .true. - enddo - if (verbose) write(stdout,*) 'h1 (by projection)' - if (verbose) call dumpGrid(n1,h1,x1,u1) - if (thisTest) write(stdout,*) 'remapping_unit_tests: Failed remapping_core_w()' - remapping_unit_tests = remapping_unit_tests .or. thisTest - - thisTest = .false. - allocate(ppoly0_E(n0,2)) - allocate(ppoly0_S(n0,2)) - allocate(ppoly0_coefs(n0,CS%degree+1)) + call test%real_arr(3, u1, (/8.,0.,-8./), 'remapping_core_w() PPM_H4') + allocate(ppoly0_E(n0,2), ppoly0_S(n0,2), ppoly0_coefs(n0,CS%degree+1)) ppoly0_E(:,:) = 0.0 ppoly0_S(:,:) = 0.0 ppoly0_coefs(:,:) = 0.0 @@ -1415,387 +1670,780 @@ logical function remapping_unit_tests(verbose) 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 ) - thisTest = .false. - call buildGridFromH(n2, h2, x2) - - if (verbose) write(stdout,*) 'Via sub-cells' - thisTest = .false. call remap_via_sub_cells( n0, h0, u0, ppoly0_E, ppoly0_coefs, & n2, h2, INTEGRATION_PPM, .false., u2, err ) - if (verbose) call dumpGrid(n2,h2,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_unit_tests: Failed remap_via_sub_cells() 2' - remapping_unit_tests = remapping_unit_tests .or. thisTest + call test%real_arr(6, u2, (/10.,6.,2.,-2.,-6.,-10./), 'remap_via_sub_cells() 2') call remap_via_sub_cells( n0, h0, u0, ppoly0_E, ppoly0_coefs, & 6, (/.125,.125,.125,.125,.125,.125/), INTEGRATION_PPM, .false., u2, err ) - if (verbose) call dumpGrid(6,h2,x2,u2) + call test%real_arr(6, u2, (/11.5,10.5,9.5,8.5,7.5,6.5/), 'remap_via_sub_cells() 3') call remap_via_sub_cells( n0, h0, u0, ppoly0_E, ppoly0_coefs, & 3, (/2.25,1.5,1./), INTEGRATION_PPM, .false., u2, err ) - if (verbose) call dumpGrid(3,h2,x2,u2) - - if (.not. remapping_unit_tests) write(stdout,*) 'Pass' - - write(stdout,*) '===== MOM_remapping: new remapping_unit_tests ==================' - - deallocate(ppoly0_E, ppoly0_S, ppoly0_coefs) - allocate(ppoly0_coefs(5,6)) - allocate(ppoly0_E(5,2)) - allocate(ppoly0_S(5,2)) - - call PCM_reconstruction(3, (/1.,2.,4./), ppoly0_E(1:3,:), & - ppoly0_coefs(1:3,:) ) - remapping_unit_tests = remapping_unit_tests .or. & - test_answer(v, 3, ppoly0_E(:,1), (/1.,2.,4./), 'PCM: left edges') - remapping_unit_tests = remapping_unit_tests .or. & - test_answer(v, 3, ppoly0_E(:,2), (/1.,2.,4./), 'PCM: right edges') - remapping_unit_tests = remapping_unit_tests .or. & - test_answer(v, 3, ppoly0_coefs(:,1), (/1.,2.,4./), 'PCM: P0') - - call PLM_reconstruction(3, (/1.,1.,1./), (/1.,3.,5./), ppoly0_E(1:3,:), & - ppoly0_coefs(1:3,:), h_neglect ) - remapping_unit_tests = remapping_unit_tests .or. & - test_answer(v, 3, ppoly0_E(:,1), (/1.,2.,5./), 'Unlim PLM: left edges') - remapping_unit_tests = remapping_unit_tests .or. & - test_answer(v, 3, ppoly0_E(:,2), (/1.,4.,5./), 'Unlim PLM: right edges') - remapping_unit_tests = remapping_unit_tests .or. & - test_answer(v, 3, ppoly0_coefs(:,1), (/1.,2.,5./), 'Unlim PLM: P0') - remapping_unit_tests = remapping_unit_tests .or. & - test_answer(v, 3, ppoly0_coefs(:,2), (/0.,2.,0./), 'Unlim PLM: P1') - - call PLM_reconstruction(3, (/1.,1.,1./), (/1.,2.,7./), ppoly0_E(1:3,:), & - ppoly0_coefs(1:3,:), h_neglect ) - remapping_unit_tests = remapping_unit_tests .or. & - test_answer(v, 3, ppoly0_E(:,1), (/1.,1.,7./), 'Left lim PLM: left edges') - remapping_unit_tests = remapping_unit_tests .or. & - test_answer(v, 3, ppoly0_E(:,2), (/1.,3.,7./), 'Left lim PLM: right edges') - remapping_unit_tests = remapping_unit_tests .or. & - test_answer(v, 3, ppoly0_coefs(:,1), (/1.,1.,7./), 'Left lim PLM: P0') - remapping_unit_tests = remapping_unit_tests .or. & - test_answer(v, 3, ppoly0_coefs(:,2), (/0.,2.,0./), 'Left lim PLM: P1') - - call PLM_reconstruction(3, (/1.,1.,1./), (/1.,6.,7./), ppoly0_E(1:3,:), & - ppoly0_coefs(1:3,:), h_neglect ) - remapping_unit_tests = remapping_unit_tests .or. & - test_answer(v, 3, ppoly0_E(:,1), (/1.,5.,7./), 'Right lim PLM: left edges') - remapping_unit_tests = remapping_unit_tests .or. & - test_answer(v, 3, ppoly0_E(:,2), (/1.,7.,7./), 'Right lim PLM: right edges') - remapping_unit_tests = remapping_unit_tests .or. & - test_answer(v, 3, ppoly0_coefs(:,1), (/1.,5.,7./), 'Right lim PLM: P0') - remapping_unit_tests = remapping_unit_tests .or. & - test_answer(v, 3, ppoly0_coefs(:,2), (/0.,2.,0./), 'Right lim PLM: P1') - - call PLM_reconstruction(3, (/1.,2.,3./), (/1.,4.,9./), ppoly0_E(1:3,:), & - ppoly0_coefs(1:3,:), h_neglect ) - remapping_unit_tests = remapping_unit_tests .or. & - test_answer(v, 3, ppoly0_E(:,1), (/1.,2.,9./), 'Non-uniform line PLM: left edges') - remapping_unit_tests = remapping_unit_tests .or. & - test_answer(v, 3, ppoly0_E(:,2), (/1.,6.,9./), 'Non-uniform line PLM: right edges') - remapping_unit_tests = remapping_unit_tests .or. & - test_answer(v, 3, ppoly0_coefs(:,1), (/1.,2.,9./), 'Non-uniform line PLM: P0') - remapping_unit_tests = remapping_unit_tests .or. & - test_answer(v, 3, ppoly0_coefs(:,2), (/0.,4.,0./), 'Non-uniform line PLM: P1') - - call edge_values_explicit_h4( 5, (/1.,1.,1.,1.,1./), (/1.,3.,5.,7.,9./), ppoly0_E, & - h_neglect=1e-10, answer_date=answer_date ) + call test%real_arr(3, u2, (/3.,-10.5,-12./), 'remap_via_sub_cells() 4') + + deallocate(h0, u0, h1, u1, h2, u2, ppoly0_E, ppoly0_S, ppoly0_coefs) + call end_remapping(CS) + + ! =============================================== + ! This section tests the reconstruction functions + ! =============================================== + if (verbose) write(test%stdout,*) ' - - - - - reconstruction tests - - - - -' + + allocate( ppoly0_coefs(5,6), ppoly0_E(5,2), ppoly0_S(5,2), u2(2) ) + + call PCM_reconstruction(3, (/1.,2.,4./), & + ppoly0_E(1:3,:), ppoly0_coefs(1:3,:) ) + call test%real_arr(3, ppoly0_E(:,1), (/1.,2.,4./), 'PCM: left edges') + call test%real_arr(3, ppoly0_E(:,2), (/1.,2.,4./), 'PCM: right edges') + call test%real_arr(3, ppoly0_coefs(:,1), (/1.,2.,4./), 'PCM: P0') + + call PLM_reconstruction(3, (/1.,1.,1./), (/1.,3.,5./), & + ppoly0_E(1:3,:), ppoly0_coefs(1:3,:), h_neglect ) + call test%real_arr(3, ppoly0_E(:,1), (/1.,2.,5./), 'Unlim PLM: left edges') + call test%real_arr(3, ppoly0_E(:,2), (/1.,4.,5./), 'Unlim PLM: right edges') + call test%real_arr(3, ppoly0_coefs(:,1), (/1.,2.,5./), 'Unlim PLM: P0') + call test%real_arr(3, ppoly0_coefs(:,2), (/0.,2.,0./), 'Unlim PLM: P1') + + call PLM_reconstruction(3, (/1.,1.,1./), (/1.,2.,7./), & + ppoly0_E(1:3,:), ppoly0_coefs(1:3,:), h_neglect ) + call test%real_arr(3, ppoly0_E(:,1), (/1.,1.,7./), 'Left lim PLM: left edges') + call test%real_arr(3, ppoly0_E(:,2), (/1.,3.,7./), 'Left lim PLM: right edges') + call test%real_arr(3, ppoly0_coefs(:,1), (/1.,1.,7./), 'Left lim PLM: P0') + call test%real_arr(3, ppoly0_coefs(:,2), (/0.,2.,0./), 'Left lim PLM: P1') + + call PLM_reconstruction(3, (/1.,1.,1./), (/1.,6.,7./), & + ppoly0_E(1:3,:), ppoly0_coefs(1:3,:), h_neglect ) + call test%real_arr(3, ppoly0_E(:,1), (/1.,5.,7./), 'Right lim PLM: left edges') + call test%real_arr(3, ppoly0_E(:,2), (/1.,7.,7./), 'Right lim PLM: right edges') + call test%real_arr(3, ppoly0_coefs(:,1), (/1.,5.,7./), 'Right lim PLM: P0') + call test%real_arr(3, ppoly0_coefs(:,2), (/0.,2.,0./), 'Right lim PLM: P1') + + call PLM_reconstruction(3, (/1.,2.,3./), (/1.,4.,9./), & + ppoly0_E(1:3,:), ppoly0_coefs(1:3,:), h_neglect ) + call test%real_arr(3, ppoly0_E(:,1), (/1.,2.,9./), 'Non-uniform line PLM: left edges') + call test%real_arr(3, ppoly0_E(:,2), (/1.,6.,9./), 'Non-uniform line PLM: right edges') + call test%real_arr(3, ppoly0_coefs(:,1), (/1.,2.,9./), 'Non-uniform line PLM: P0') + call test%real_arr(3, ppoly0_coefs(:,2), (/0.,4.,0./), 'Non-uniform line PLM: P1') + + call edge_values_explicit_h4(5, (/1.,1.,1.,1.,1./), (/1.,3.,5.,7.,9./), & + ppoly0_E, h_neglect=1e-10, answer_date=answer_date ) ! The next two tests currently fail due to roundoff, but pass when given a reasonable tolerance. - thisTest = test_answer(v, 5, ppoly0_E(:,1), (/0.,2.,4.,6.,8./), 'Line H4: left edges', tol=8.0e-15) - remapping_unit_tests = remapping_unit_tests .or. thisTest - thisTest = test_answer(v, 5, ppoly0_E(:,2), (/2.,4.,6.,8.,10./), 'Line H4: right edges', tol=1.0e-14) - remapping_unit_tests = remapping_unit_tests .or. thisTest + call test%real_arr(5, ppoly0_E(:,1), (/0.,2.,4.,6.,8./), 'Line H4: left edges', tol=8.0e-15) + call test%real_arr(5, ppoly0_E(:,2), (/2.,4.,6.,8.,10./), 'Line H4: right edges', tol=1.0e-14) + ppoly0_E(:,1) = (/0.,2.,4.,6.,8./) ppoly0_E(:,2) = (/2.,4.,6.,8.,10./) call PPM_reconstruction(5, (/1.,1.,1.,1.,1./), (/1.,3.,5.,7.,9./), ppoly0_E(1:5,:), & ppoly0_coefs(1:5,:), h_neglect, answer_date=answer_date ) - remapping_unit_tests = remapping_unit_tests .or. & - test_answer(v, 5, ppoly0_coefs(:,1), (/1.,2.,4.,6.,9./), 'Line PPM: P0') - remapping_unit_tests = remapping_unit_tests .or. & - test_answer(v, 5, ppoly0_coefs(:,2), (/0.,2.,2.,2.,0./), 'Line PPM: P1') - remapping_unit_tests = remapping_unit_tests .or. & - test_answer(v, 5, ppoly0_coefs(:,3), (/0.,0.,0.,0.,0./), 'Line PPM: P2') + call test%real_arr(5, ppoly0_coefs(:,1), (/1.,2.,4.,6.,9./), 'Line PPM: P0') + call test%real_arr(5, ppoly0_coefs(:,2), (/0.,2.,2.,2.,0./), 'Line PPM: P1') + call test%real_arr(5, ppoly0_coefs(:,3), (/0.,0.,0.,0.,0./), 'Line PPM: P2') call edge_values_explicit_h4( 5, (/1.,1.,1.,1.,1./), (/1.,1.,7.,19.,37./), ppoly0_E, & h_neglect=1e-10, answer_date=answer_date ) ! The next two tests are now passing when answer_date >= 20190101, but otherwise only work to roundoff. - thisTest = test_answer(v, 5, ppoly0_E(:,1), (/3.,0.,3.,12.,27./), 'Parabola H4: left edges', tol=2.7e-14) - remapping_unit_tests = remapping_unit_tests .or. thisTest - thisTest = test_answer(v, 5, ppoly0_E(:,2), (/0.,3.,12.,27.,48./), 'Parabola H4: right edges', tol=4.8e-14) - remapping_unit_tests = remapping_unit_tests .or. thisTest + call test%real_arr(5, ppoly0_E(:,1), (/3.,0.,3.,12.,27./), 'Parabola H4: left edges', tol=2.7e-14) + call test%real_arr(5, ppoly0_E(:,2), (/0.,3.,12.,27.,48./), 'Parabola H4: right edges', tol=4.8e-14) ppoly0_E(:,1) = (/0.,0.,3.,12.,27./) ppoly0_E(:,2) = (/0.,3.,12.,27.,48./) call PPM_reconstruction(5, (/1.,1.,1.,1.,1./), (/0.,1.,7.,19.,37./), ppoly0_E(1:5,:), & ppoly0_coefs(1:5,:), h_neglect, answer_date=answer_date ) - remapping_unit_tests = remapping_unit_tests .or. & - test_answer(v, 5, ppoly0_E(:,1), (/0.,0.,3.,12.,37./), 'Parabola PPM: left edges') - remapping_unit_tests = remapping_unit_tests .or. & - test_answer(v, 5, ppoly0_E(:,2), (/0.,3.,12.,27.,37./), 'Parabola PPM: right edges') - remapping_unit_tests = remapping_unit_tests .or. & - test_answer(v, 5, ppoly0_coefs(:,1), (/0.,0.,3.,12.,37./), 'Parabola PPM: P0') - remapping_unit_tests = remapping_unit_tests .or. & - test_answer(v, 5, ppoly0_coefs(:,2), (/0.,0.,6.,12.,0./), 'Parabola PPM: P1') - remapping_unit_tests = remapping_unit_tests .or. & - test_answer(v, 5, ppoly0_coefs(:,3), (/0.,3.,3.,3.,0./), 'Parabola PPM: P2') + call test%real_arr(5, ppoly0_E(:,1), (/0.,0.,3.,12.,37./), 'Parabola PPM: left edges') + call test%real_arr(5, ppoly0_E(:,2), (/0.,3.,12.,27.,37./), 'Parabola PPM: right edges') + call test%real_arr(5, ppoly0_coefs(:,1), (/0.,0.,3.,12.,37./), 'Parabola PPM: P0') + call test%real_arr(5, ppoly0_coefs(:,2), (/0.,0.,6.,12.,0./), 'Parabola PPM: P1') + call test%real_arr(5, ppoly0_coefs(:,3), (/0.,3.,3.,3.,0./), 'Parabola PPM: P2') ppoly0_E(:,1) = (/0.,0.,6.,10.,15./) ppoly0_E(:,2) = (/0.,6.,12.,17.,15./) call PPM_reconstruction(5, (/1.,1.,1.,1.,1./), (/0.,5.,7.,16.,15./), ppoly0_E(1:5,:), & ppoly0_coefs(1:5,:), h_neglect, answer_date=answer_date ) - remapping_unit_tests = remapping_unit_tests .or. & - test_answer(v, 5, ppoly0_E(:,1), (/0.,3.,6.,16.,15./), 'Limits PPM: left edges') - remapping_unit_tests = remapping_unit_tests .or. & - test_answer(v, 5, ppoly0_E(:,2), (/0.,6.,9.,16.,15./), 'Limits PPM: right edges') - remapping_unit_tests = remapping_unit_tests .or. & - test_answer(v, 5, ppoly0_coefs(:,1), (/0.,3.,6.,16.,15./), 'Limits PPM: P0') - remapping_unit_tests = remapping_unit_tests .or. & - test_answer(v, 5, ppoly0_coefs(:,2), (/0.,6.,0.,0.,0./), 'Limits PPM: P1') - remapping_unit_tests = remapping_unit_tests .or. & - test_answer(v, 5, ppoly0_coefs(:,3), (/0.,-3.,3.,0.,0./), 'Limits PPM: P2') - - call PLM_reconstruction(4, (/0.,1.,1.,0./), (/5.,4.,2.,1./), ppoly0_E(1:4,:), & - ppoly0_coefs(1:4,:), h_neglect ) - remapping_unit_tests = remapping_unit_tests .or. & - test_answer(v, 4, ppoly0_E(1:4,1), (/5.,5.,3.,1./), 'PPM: left edges h=0110') - remapping_unit_tests = remapping_unit_tests .or. & - test_answer(v, 4, ppoly0_E(1:4,2), (/5.,3.,1.,1./), 'PPM: right edges h=0110') - call remap_via_sub_cells( 4, (/0.,1.,1.,0./), (/5.,4.,2.,1./), ppoly0_E(1:4,:), & - ppoly0_coefs(1:4,:), & - 2, (/1.,1./), INTEGRATION_PLM, .false., u2, err ) - remapping_unit_tests = remapping_unit_tests .or. & - test_answer(v, 2, u2, (/4.,2./), 'PLM: remapped h=0110->h=11') - - deallocate(ppoly0_E, ppoly0_S, ppoly0_coefs) + call test%real_arr(5, ppoly0_E(:,1), (/0.,3.,6.,16.,15./), 'Limits PPM: left edges') + call test%real_arr(5, ppoly0_E(:,2), (/0.,6.,9.,16.,15./), 'Limits PPM: right edges') + call test%real_arr(5, ppoly0_coefs(:,1), (/0.,3.,6.,16.,15./), 'Limits PPM: P0') + call test%real_arr(5, ppoly0_coefs(:,2), (/0.,6.,0.,0.,0./), 'Limits PPM: P1') + call test%real_arr(5, ppoly0_coefs(:,3), (/0.,-3.,3.,0.,0./), 'Limits PPM: P2') + + deallocate(ppoly0_E, ppoly0_S, ppoly0_coefs, u2) + + ! ============================================================== + ! This section tests the components of remap_via_sub_cells() + ! ============================================================== + + if (verbose) write(test%stdout,*) ' - - - - - remapping algororithm tests - - - - -' + + ! Test 1: n0=2, n1=3 Maps uniform grids with one extra target layer and no implicitly-vanished interior sub-layers + ! h_src = | 3 | 3 | + ! h_tgt = | 2 | 2 | 2 | + ! h_sub = |0| 2 | 1 | 1 | 2 |0| + ! isrc_start |1 | 4 | + ! isrc_end | 3 | 5 | + ! isrc_max | 2 | 5 | + ! itgt_start |1 | 3 | 5 | + ! itgt_end | 2 | 4 | 6| + ! isub_src |1| 1 | 1 | 2 | 2 |2| + allocate( h_sub(6), h0_eff(2), isrc_start(2), isrc_end(2), isrc_max(2), itgt_start(3), itgt_end(3), isub_src(6) ) + call intersect_src_tgt_grids( 2, (/3., 3./), & ! n0, h0 + 3, (/2., 2., 2./), & ! n1, h1 + h_sub, h0_eff, & + isrc_start, isrc_end, isrc_max, itgt_start, itgt_end, isub_src ) + if (verbose) write(test%stdout,*) "intersect_src_tgt_grids test 1: n0=2, n1=3" + if (verbose) write(test%stdout,*) " h_src = | 3 | 3 |" + if (verbose) write(test%stdout,*) " h_tgt = | 2 | 2 | 2 |" + call test%real_arr(6, h_sub, (/0.,2.,1.,1.,2.,0./), 'h_sub') + call test%real_arr(2, h0_eff, (/3.,3./), 'h0_eff') + call test%int_arr(2, isrc_start, (/1,4/), 'isrc_start') + call test%int_arr(2, isrc_end, (/3,5/), 'isrc_end') + call test%int_arr(2, isrc_max, (/2,5/), 'isrc_max') + call test%int_arr(3, itgt_start, (/1,3,5/), 'itgt_start') + call test%int_arr(3, itgt_end, (/2,4,6/), 'itgt_end') + call test%int_arr(6, isub_src, (/1,1,1,2,2,2/), 'isub_src') + deallocate( h_sub, h0_eff, isrc_start, isrc_end, isrc_max, itgt_start, itgt_end, isub_src ) + + ! Test 2: n0=3, n1=2 Reverses "test 1" with more source than target layers + ! h_src = | 2 | 2 | 2 | + ! h_tgt = | 3 | 3 | + ! h_sub = |0| 2 | 1 | 1 | 2 |0| + ! isrc_start |1 | 3 | 5 | + ! isrc_end | 2 | 4 | 5 | + ! isrc_max | 2 | 4 | 5 | + ! itgt_start |1 | 4 | + ! itgt_end | 3 | 6| + ! isub_src |1| 1 | 2 | 2 | 3 |3| + allocate( h_sub(6), h0_eff(3), isrc_start(3), isrc_end(3), isrc_max(3), itgt_start(2), itgt_end(2), isub_src(6) ) + call intersect_src_tgt_grids( 3, (/2., 2., 2./), & ! n0, h0 + 2, (/3., 3./), & ! n1, h1 + h_sub, h0_eff, & + isrc_start, isrc_end, isrc_max, itgt_start, itgt_end, isub_src ) + if (verbose) write(test%stdout,*) "intersect_src_tgt_grids test 2: n0=3, n1=2" + if (verbose) write(test%stdout,*) " h_src = | 2 | 2 | 2 |" + if (verbose) write(test%stdout,*) " h_tgt = | 3 | 3 |" + call test%real_arr(6, h_sub, (/0.,2.,1.,1.,2.,0./), 'h_sub') + call test%real_arr(3, h0_eff, (/2.,2.,2./), 'h0_eff') + call test%int_arr(3, isrc_start, (/1,3,5/), 'isrc_start') + call test%int_arr(3, isrc_end, (/2,4,5/), 'isrc_end') + call test%int_arr(3, isrc_max, (/2,4,5/), 'isrc_max') + call test%int_arr(2, itgt_start, (/1,4/), 'itgt_start') + call test%int_arr(2, itgt_end, (/3,6/), 'itgt_end') + call test%int_arr(6, isub_src, (/1,1,2,2,3,3/), 'isub_src') + deallocate( h_sub, h0_eff, isrc_start, isrc_end, isrc_max, itgt_start, itgt_end, isub_src ) + + ! Test 3: n0=2, n1=3 With aligned interfaces that lead to implicitly-vanished interior sub-layers + n0 = 2 ; n1 = 3 + allocate( h0_eff(n0), isrc_start(n0), isrc_end(n0), isrc_max(n0), h0(n0), u0(n0) ) + allocate( itgt_start(n1), itgt_end(n1), h1(n1), u1(n1) ) + allocate( h_sub(n0+n1+1), isub_src(n0+n1+1) ) + u0 = (/ 2. , 5. /) + h0 = (/ 2. , 4. /) + h1 = (/ 2. , 2. , 2. /) + ! h_src = |<- 2 ->|<- 4 ->| + ! h_tgt = |<- 2 ->|<- 2 ->|<- 2 ->| + ! h_sub = |0|<- 2 ->|0|<- 2 ->|<- 2 ->|0| + ! isrc_start |1 |3 | + ! isrc_end | 2 | 5 | + ! isrc_max | 2 | 5 | + ! itgt_start |1 | 4 | 5 | + ! itgt_end | 3| 4 | 6| + ! isub_src |1| 1 |2| 2 | 2 |2| + 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 (verbose) write(test%stdout,*) "intersect_src_tgt_grids test 3: n0=2, n1=3" + if (verbose) write(test%stdout,*) " h_src = | 2 | 4 |" + if (verbose) write(test%stdout,*) " h_tgt = | 2 | 2 | 2 |" + call test%real_arr(6, h_sub, (/0.,2.,0.,2.,2.,0./), 'h_sub') + call test%real_arr(2, h0_eff, (/2.,4./), 'h0_eff') + call test%int_arr(2, isrc_start, (/1,3/), 'isrc_start') + call test%int_arr(2, isrc_end, (/2,5/), 'isrc_end') + call test%int_arr(2, isrc_max, (/2,5/), 'isrc_max') + call test%int_arr(3, itgt_start, (/1,4,5/), 'itgt_start') + call test%int_arr(3, itgt_end, (/3,4,6/), 'itgt_end') + call test%int_arr(6, isub_src, (/1,1,2,2,2,2/), 'isub_src') + allocate(ppoly0_coefs(n0,2), ppoly0_E(n0,2), ppoly0_S(n0,2)) + ! h_src = |<- 2 ->|<- 4 ->| + ! h_sub = |0|<- 2 ->|0|<- 2 ->|<- 2 ->|0| + ! u_src = | 2 | 5 | + ! edge = |1 3|3 7| + ! u_sub = |1| 2 |3| 4 | 6 |7| + call PLM_reconstruction(n0, h0, u0, ppoly0_E, ppoly0_coefs, h_neglect ) + call PLM_boundary_extrapolation(n0, h0, u0, ppoly0_E, ppoly0_coefs, h_neglect) + allocate(u_sub(n0+n1+1), uh_sub(n0+n1+1)) + call remap_src_to_sub_grid_om4(n0, h0, u0, ppoly0_E, ppoly0_coefs, & + n1, h_sub, h0_eff, isrc_start, isrc_end, isrc_max, isub_src, & + INTEGRATION_PLM, .false., u_sub, uh_sub, u02_err) + call test%real_arr(6, u_sub, (/1.,2.,3.,4.,6.,7./), 'u_sub om4') + call remap_src_to_sub_grid(n0, h0, u0, ppoly0_E, ppoly0_coefs, & + n1, h_sub, isrc_start, isrc_end, isrc_max, isub_src, & + INTEGRATION_PLM, .false., u_sub, uh_sub, u02_err) + call test%real_arr(6, u_sub, (/1.,2.,3.,4.,6.,7./), 'u_sub') + ! h_sub = |0|<- 2 ->|0|<- 2 ->|<- 2 ->|0| + ! u_sub = |1| 2 |3| 4 | 6 |7| + ! 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) + 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) + 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 ) + + ! Test 4: n0=2, n1=3 Incomplete target column, sum(h_tgt)|<- 4 ->| + ! h_tgt = |<- 2 ->|<- 2 ->|< 1 >| + ! h_sub = |0|<- 2 ->|0|<- 2 ->|< 1 >|< 1 >| + ! isrc_start |1 |3 | + ! isrc_end | 2 | 6 | + ! isrc_max | 2 | 4 | + ! itgt_start |1 | 4 | 5 | + ! itgt_end | 3| 4 | 5 | + ! isub_src |1| 1 |2| 2 | 2 | 2 | + 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 (verbose) write(test%stdout,*) "intersect_src_tgt_grids test 4: n0=2, n1=3" + if (verbose) write(test%stdout,*) " h_src = | 2 | 4 |" + if (verbose) write(test%stdout,*) " h_tgt = | 2 | 2 | 1 |" + call test%real_arr(6, h_sub, (/0.,2.,0.,2.,1.,1./), 'h_sub') + call test%real_arr(2, h0_eff, (/2.,3./), 'h0_eff') + call test%int_arr(2, isrc_start, (/1,3/), 'isrc_start') + call test%int_arr(2, isrc_end, (/2,6/), 'isrc_end') + call test%int_arr(2, isrc_max, (/2,4/), 'isrc_max') + call test%int_arr(3, itgt_start, (/1,4,5/), 'itgt_start') + call test%int_arr(3, itgt_end, (/3,4,5/), 'itgt_end') + call test%int_arr(6, isub_src, (/1,1,2,2,2,2/), 'isub_src') + allocate(ppoly0_coefs(n0,2), ppoly0_E(n0,2), ppoly0_S(n0,2)) + ! h_src = |<- 2 ->|<- 4 ->| + ! h_sub = |0|<- 2 ->|0|<- 2 ->|<-1->|<-1->| + ! u_src = | 2 | 5 | + ! edge = |1 3|3 7| + ! u_sub = |1| 2 |3| 4 | 5.5 | 6.5 | + call PLM_reconstruction(n0, h0, u0, ppoly0_E, ppoly0_coefs, h_neglect ) + call PLM_boundary_extrapolation(n0, h0, u0, ppoly0_E, ppoly0_coefs, h_neglect) + allocate(u_sub(n0+n1+1), uh_sub(n0+n1+1)) + call remap_src_to_sub_grid(2, (/2.,4./), (/2.,5./), ppoly0_E, ppoly0_coefs, & + 3, h_sub, isrc_start, isrc_end, isrc_max, isub_src, & + INTEGRATION_PLM, .false., u_sub, uh_sub, u02_err) + call test%real_arr(6, u_sub, (/1.,2.,3.,4.,5.5,6.5/), 'u_sub') + 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 ) + + ! Test 5: n0=3, n1=2 Target column exceeds source column, sum(h_tgt)>sum(h_src), useful for diagnostics + n0 = 3 ; n1 = 2 + allocate( h0_eff(n0), isrc_start(n0), isrc_end(n0), isrc_max(n0), h0(n0), u0(n0) ) + allocate( itgt_start(n1), itgt_end(n1), h1(n1), u1(n1) ) + allocate( h_sub(n0+n1+1), isub_src(n0+n1+1) ) + u0 = (/ 2. , 4. , 5.5 /) + h0 = (/ 2. , 2. , 1. /) + h1 = (/ 2. , 4. /) + ! h_src = |<- 2 ->|<- 2 ->|< 1 >| + ! h_tgt = |<- 2 ->|<- 4 ->| + ! h_sub = |0|<- 2 ->|0|<- 2 ->|< 1 >|< 1 >| + ! isrc_start |1 |3 | 5 | + ! isrc_end | 2 | 4 | 5 | + ! isrc_max | 2 | 4 | 5 | + ! itgt_start |1 | 4 | + ! itgt_end | 3| 6 | + ! isub_src |1| 1 |2| 2 | 3 | 3 | + 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 (verbose) write(test%stdout,*) "intersect_src_tgt_grids test 5: n0=3, n1=2" + if (verbose) write(test%stdout,*) " h_src = | 2 | 2 | 1 |" + if (verbose) write(test%stdout,*) " h_tgt = | 2 | 4 |" + call test%real_arr(6, h_sub, (/0.,2.,0.,2.,1.,1./), 'h_sub') + call test%real_arr(3, h0_eff, (/2.,2.,1./), 'h0_eff') + call test%int_arr(3, isrc_start, (/1,3,5/), 'isrc_start') + call test%int_arr(3, isrc_end, (/2,4,5/), 'isrc_end') + call test%int_arr(3, isrc_max, (/2,4,5/), 'isrc_max') + call test%int_arr(2, itgt_start, (/1,4/), 'itgt_start') + call test%int_arr(2, itgt_end, (/3,6/), 'itgt_end') + call test%int_arr(6, isub_src, (/1,1,2,2,3,3/), 'isub_src') + allocate(ppoly0_coefs(n0,2), ppoly0_E(n0,2), ppoly0_S(n0,2)) + ! h_src = |<- 2 ->|<- 2 ->|< 1 >| + ! h_sub = |0|<- 2 ->|0|<- 2 ->|< 1 >|< 1 >| + ! u_src = | 2 | 4 | 5.5 | + ! edge = |1 3|3 5|5 6| + ! u_sub = |1| 2 |3| 4 | 5.5 | 6 | + call PLM_reconstruction(n0, h0, u0, ppoly0_E, ppoly0_coefs, h_neglect ) + call PLM_boundary_extrapolation(n0, h0, u0, ppoly0_E, ppoly0_coefs, h_neglect) + allocate(u_sub(n0+n1+1), uh_sub(n0+n1+1)) + call remap_src_to_sub_grid_om4(n0, h0, u0, ppoly0_E, ppoly0_coefs, & + n1, h_sub, h0_eff, isrc_start, isrc_end, isrc_max, isub_src, & + INTEGRATION_PLM, .false., u_sub, uh_sub, u02_err) + call test%real_arr(6, u_sub, (/1.,2.,3.,4.,5.5,6./), 'u_sub om4') + call remap_src_to_sub_grid(n0, h0, u0, ppoly0_E, ppoly0_coefs, & + n1, h_sub, isrc_start, isrc_end, isrc_max, isub_src, & + INTEGRATION_PLM, .false., u_sub, uh_sub, u02_err) + call test%real_arr(6, u_sub, (/1.,2.,3.,4.,5.5,6./), 'u_sub') + ! h_sub = |0|<- 2 ->|0|<- 2 ->|< 1 >|< 1 >| + ! u_sub = |1| 2 |3| 4 | 5.5 | 6 | + ! 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) + 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) + 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 ) + + ! Test 6: n0=3, n1=5 Source and targets with vanished layers + n0 = 3 ; n1 = 5 + allocate( h0_eff(n0), isrc_start(n0), isrc_end(n0), isrc_max(n0), h0(n0), u0(n0) ) + allocate( itgt_start(n1), itgt_end(n1), h1(n1), u1(n1) ) + allocate( h_sub(n0+n1+1), isub_src(n0+n1+1) ) + u0 = (/ 2. ,3., 4. /) + h0 = (/ 2. ,0., 2. /) + h1 = (/ 1. ,0., 1. ,0., 2. /) + ! h_src = |<- 2 ->|0|<- 2 ->| + ! h_tgt = |<- 1 ->|0|<- 1 ->|0|<- 2 ->| + ! h_sub = |0|< 1 ->|0|< 1 >|0|0|0|<- 2 ->|0| + ! isrc_start |1 |5|6 | + ! isrc_end | 4 |5| 8 | + ! isrc_max | 4 |5| 8 | + ! itgt_start |1 |3| 4 |7| 8 | + ! itgt_end | 2 |3| 6|7| 9| + ! isub_src |1| 1 |1| 1 |2|3|3| 3 |3| + 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 (verbose) write(test%stdout,*) "intersect_src_tgt_grids test 6: n0=3, n1=5" + if (verbose) write(test%stdout,*) " h_src = | 2 |0| 2 |" + if (verbose) write(test%stdout,*) " h_tgt = | 1 |0| 1 |0| 2 |" + call test%real_arr(9, h_sub, (/0.,1.,0.,1.,0.,0.,0.,2.,0./), 'h_sub') + call test%real_arr(3, h0_eff, (/2.,0.,2./), 'h0_eff') + call test%int_arr(3, isrc_start, (/1,5,6/), 'isrc_start') + call test%int_arr(3, isrc_end, (/4,5,8/), 'isrc_end') + call test%int_arr(3, isrc_max, (/4,5,8/), 'isrc_max') + call test%int_arr(5, itgt_start, (/1,3,4,7,8/), 'itgt_start') + call test%int_arr(5, itgt_end, (/2,3,6,7,9/), 'itgt_end') + call test%int_arr(9, isub_src, (/1,1,1,1,2,3,3,3,3/), 'isub_src') + allocate(ppoly0_coefs(n0,2), ppoly0_E(n0,2), ppoly0_S(n0,2)) + ! h_src = |<- 2 ->|0|<- 2 ->| + ! h_sub = |0|< 1 ->|0|< 1 >|0|0|0|<- 2 ->|0| + ! u_src = | 2 |3| 4 | + ! edge = |1 3|3|3 5| + ! u_sub = |1| 1.5 |2| 2.5 |3|3|3| 4 |5| + call PLM_reconstruction(n0, h0, u0, ppoly0_E, ppoly0_coefs, h_neglect ) + call PLM_boundary_extrapolation(n0, h0, u0, ppoly0_E, ppoly0_coefs, h_neglect) + allocate(u_sub(n0+n1+1), uh_sub(n0+n1+1)) + call remap_src_to_sub_grid_om4(n0, h0, u0, ppoly0_E, ppoly0_coefs, & + n1, h_sub, h0_eff, isrc_start, isrc_end, isrc_max, isub_src, & + INTEGRATION_PLM, .false., u_sub, uh_sub, u02_err) + call test%real_arr(9, u_sub, (/1.,1.5,2.,2.5,3.,3.,3.,4.,5./), 'u_sub om4') + call remap_src_to_sub_grid(n0, h0, u0, ppoly0_E, ppoly0_coefs, & + n1, h_sub, isrc_start, isrc_end, isrc_max, isub_src, & + INTEGRATION_PLM, .false., u_sub, uh_sub, u02_err) + call test%real_arr(9, u_sub, (/1.,1.5,2.,2.5,3.,3.,3.,4.,5./), 'u_sub') + ! h_sub = |0|< 1 ->|0|< 1 >|0|0|0|<- 2 ->|0| + ! u_sub = |1| 1.5 |2| 2.5 |3|3|3| 4 |5| + ! 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) + 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) + 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 ) + + ! ============================================================ + ! This section tests remap_via_sub_cells() + ! ============================================================ + if (verbose) write(test%stdout,*) '- - - - - - - - - - remap_via_sub_cells() tests - - - - - - - - -' + + allocate(ppoly0_E(4,2), ppoly0_S(4,2), ppoly0_coefs(4,3), u2(2)) + + ! These tests has vanished top and bottom layers with a linear profile + call PLM_reconstruction(4, (/0.,1.,1.,0./), (/5.,4.,2.,1./), ppoly0_E, ppoly0_coefs, 0.) + ! Reconstruction has piecewise constant 5 and 1 for top and bottom layers respectively + ! but which are vanished so give no wieght to integrals. + ! Interface values are 5, 5, 3, 1, 1. + call test%real_arr(4, ppoly0_E(1:4,1), (/5.,5.,3.,1./), 'PPM: left edges h=0110') + call test%real_arr(4, ppoly0_E(1:4,2), (/5.,3.,1.,1./), 'PPM: right edges h=0110') + + ! Remapping to just the two interior layers yields the same values as u_src(2:3) + call remap_via_sub_cells_om4(4, (/0.,1.,1.,0./), (/5.,4.,2.,1./), ppoly0_E, ppoly0_coefs, & + 2, (/1.,1./), INTEGRATION_PLM, .false., u2, err) + call test%real_arr(2, u2, (/4.,2./), 'PLM: remapped h=0110->h=11 om4') + call remap_via_sub_cells(4, (/0.,1.,1.,0./), (/5.,4.,2.,1./), ppoly0_E, ppoly0_coefs, & + 2, (/1.,1./), INTEGRATION_PLM, .false., u2, err) + call test%real_arr(2, u2, (/4.,2./), 'PLM: remapped h=0110->h=11') + + ! Remapping to two layers that are deeper. For the bottom layer of thickness 4, + ! the first 1/4 has average 2, the remaining 3/4 has the bottom edge value or 1 + ! yield ing and average or 1.25 + call remap_via_sub_cells_om4(4, (/0.,1.,1.,0./), (/5.,4.,2.,1./), ppoly0_E, ppoly0_coefs, & + 2, (/1.,4./), INTEGRATION_PLM, .false., u2, err) + call test%real_arr(2, u2, (/4.,1.25/), 'PLM: remapped h=0110->h=14 om4') + call remap_via_sub_cells(4, (/0.,1.,1.,0./), (/5.,4.,2.,1./), ppoly0_E, ppoly0_coefs, & + 2, (/1.,4./), INTEGRATION_PLM, .false., u2, err) + call test%real_arr(2, u2, (/4.,1.25/), 'PLM: remapped h=0110->h=14') + + ! Remapping to two layers with lowest layer not reach the bottom. + ! Here, the bottom layer samples top half of source yeilding 2.5. + ! Note: OM4 used the value as if the target layer was the same thickness as source. + call remap_via_sub_cells_om4(4, (/0.,4.,4.,0./), (/5.,4.,2.,1./), ppoly0_E, ppoly0_coefs, & + 2, (/4.,2./), INTEGRATION_PLM, .false., u2, err) + call test%real_arr(2, u2, (/4.,2./), 'PLM: remapped h=0440->h=42 om4 (with known bug)') + call remap_via_sub_cells(4, (/0.,4.,4.,0./), (/5.,4.,2.,1./), ppoly0_E, ppoly0_coefs, & + 2, (/4.,2./), INTEGRATION_PLM, .false., u2, err) + call test%real_arr(2, u2, (/4.,2.5/), 'PLM: remapped h=0440->h=42') + + ! Remapping to two layers with no layers sampling the bottom source layer + ! The first layer samples the top half of u1, yielding 4.5 + ! The second layer samples the next quarter of u1, yielding 3.75 + call remap_via_sub_cells_om4(4, (/0.,5.,5.,0./), (/5.,4.,2.,1./), ppoly0_E, ppoly0_coefs, & + 2, (/2.,2./), INTEGRATION_PLM, .false., u2, err) + call test%real_arr(2, u2, (/4.5,3.5/), 'PLM: remapped h=0880->h=21 om4 (with known bug)') + call remap_via_sub_cells(4, (/0.,4.,4.,0./), (/5.,4.,2.,1./), ppoly0_E, ppoly0_coefs, & + 2, (/2.,1./), INTEGRATION_PLM, .false., u2, err) + call test%real_arr(2, u2, (/4.5,3.75/), 'PLM: remapped h=0440->h=21') + + deallocate(ppoly0_E, ppoly0_S, ppoly0_coefs, u2) + + ! ============================================================ + ! This section tests remapping_core_h() + ! ============================================================ + if (verbose) write(test%stdout,*) '- - - - - - - - - - remapping_core_h() tests - - - - - - - - -' + + ! Profile 0: 8 layers, 1x top/2x bottom vanished, and the rest with thickness 1.0, total depth 5, u(z) = 1 + z + n0 = 8 + allocate( h0(n0), u0(n0) ) + 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, 'PLM', answer_date=99990101) + + do om4 = 0, 1 + if ( om4 == 0 ) then + CS%om4_remap_via_sub_cells = .false. + om4_tag(:) = ' ' + else + CS%om4_remap_via_sub_cells = .true. + om4_tag(:) = ' om4' + endif - ! This line carries out tests on some older remapping schemes. - remapping_unit_tests = remapping_unit_tests .or. remapping_attic_unit_tests(verbose) + ! Unchanged grid + call remapping_core_h( CS, n0, h0, u0, 8, [0.,1.,1.,1.,1.,1.,0.,0.], u1, 1.e-17, 1.e-2) + call test%real_arr(8, u1, (/1.0,1.5,2.5,3.5,4.5,5.5,6.0,6.0/), 'PLM: remapped h=01111100->h=01111100'//om4_tag) - if (.not. remapping_unit_tests) write(stdout,*) 'Pass' + ! Removing vanished layers (unchanged values for non-vanished layers, layer centers 0.5, 1.5, 2.5, 3.5, 4.5) + call remapping_core_h( CS, n0, h0, u0, 5, [1.,1.,1.,1.,1.], u1, 1.e-17, 1.e-2) + call test%real_arr(5, u1, (/1.5,2.5,3.5,4.5,5.5/), 'PLM: remapped h=01111100->h=11111'//om4_tag) + + ! Remapping to variable thickness layers (layer centers 0.25, 1.0, 2.25, 4.0) + call remapping_core_h( CS, n0, h0, u0, 4, [0.5,1.,1.5,2.], u1, 1.e-17, 1.e-2) + call test%real_arr(4, u1, (/1.25,2.,3.25,5./), 'PLM: remapped h=01111100->h=h1t2'//om4_tag) + + ! Remapping to variable thickness + vanished layers (layer centers 0.25, 1.0, 1.5, 2.25, 4.0) + call remapping_core_h( CS, n0, h0, u0, 6, [0.5,1.,0.,1.5,2.,0.], u1, 1.e-17, 1.e-2) + call test%real_arr(6, u1, (/1.25,2.,2.5,3.25,5.,6./), 'PLM: remapped h=01111100->h=h10t20'//om4_tag) + + ! Remapping to deeper water column (layer centers 0.75, 2.25, 3., 5., 8.) + call remapping_core_h( CS, n0, h0, u0, 5, [1.5,1.5,0.,4.,2.], u1, 1.e-17, 1.e-2) + call test%real_arr(5, u1, (/1.75,3.25,4.,5.5,6./), 'PLM: remapped h=01111100->h=tt02'//om4_tag) + + ! Remapping to slightly shorter water column (layer centers 0.5, 1.5, 2.5,, 3.5, 4.25) + call remapping_core_h( CS, n0, h0, u0, 5, [1.,1.,1.,1.,0.5], u1, 1.e-17, 1.e-2) + if ( om4 == 0 ) then + call test%real_arr(5, u1, (/1.5,2.5,3.5,4.5,5.25/), 'PLM: remapped h=01111100->h=1111h') + else + call test%real_arr(5, u1, (/1.5,2.5,3.5,4.5,5.5/), 'PLM: remapped h=01111100->h=1111h om4 (known bug)') + endif + + ! Remapping to much shorter water column (layer centers 0.25, 0.5, 1.) + call remapping_core_h( CS, n0, h0, u0, 3, [0.5,0.,1.], u1, 1.e-17, 1.e-2) + if ( om4 == 0 ) then + call test%real_arr(3, u1, (/1.25,1.5,2./), 'PLM: remapped h=01111100->h=h01') + else + call test%real_arr(3, u1, (/1.25,1.5,1.875/), 'PLM: remapped h=01111100->h=h01 om4 (known bug)') + endif - write(stdout,*) '=== MOM_remapping: interpolation and reintegration unit tests ===' - if (verbose) write(stdout,*) '- - - - - - - - - - interpolation tests - - - - - - - - -' + enddo ! om4 - fail = test_interp(verbose, 'Identity: 3 layer', & + call end_remapping(CS) + deallocate( h0, u0, u1 ) + + ! ============================================================ + ! This section tests interpolation and reintegration functions + ! ============================================================ + if (verbose) write(test%stdout,*) '- - - - - - - - - - interpolation tests - - - - - - - - -' + + call test_interp(test, 'Identity: 3 layer', & 3, (/1.,2.,3./), (/1.,2.,3.,4./), & 3, (/1.,2.,3./), (/1.,2.,3.,4./) ) - remapping_unit_tests = remapping_unit_tests .or. fail - fail = test_interp(verbose, 'A: 3 layer to 2', & + call test_interp(test, 'A: 3 layer to 2', & 3, (/1.,1.,1./), (/1.,2.,3.,4./), & 2, (/1.5,1.5/), (/1.,2.5,4./) ) - remapping_unit_tests = remapping_unit_tests .or. fail - fail = test_interp(verbose, 'B: 2 layer to 3', & + call test_interp(test, 'B: 2 layer to 3', & 2, (/1.5,1.5/), (/1.,4.,7./), & 3, (/1.,1.,1./), (/1.,3.,5.,7./) ) - remapping_unit_tests = remapping_unit_tests .or. fail - fail = test_interp(verbose, 'C: 3 layer (vanished middle) to 2', & + call test_interp(test, 'C: 3 layer (vanished middle) to 2', & 3, (/1.,0.,2./), (/1.,2.,2.,3./), & 2, (/1.,2./), (/1.,2.,3./) ) - remapping_unit_tests = remapping_unit_tests .or. fail - fail = test_interp(verbose, 'D: 3 layer (deep) to 3', & + call test_interp(test, 'D: 3 layer (deep) to 3', & 3, (/1.,2.,3./), (/1.,2.,4.,7./), & 2, (/2.,2./), (/1.,3.,5./) ) - remapping_unit_tests = remapping_unit_tests .or. fail - fail = test_interp(verbose, 'E: 3 layer to 3 (deep)', & + call test_interp(test, 'E: 3 layer to 3 (deep)', & 3, (/1.,2.,4./), (/1.,2.,4.,8./), & 3, (/2.,3.,4./), (/1.,3.,6.,8./) ) - remapping_unit_tests = remapping_unit_tests .or. fail - fail = test_interp(verbose, 'F: 3 layer to 4 with vanished top/botton', & + call test_interp(test, 'F: 3 layer to 4 with vanished top/botton', & 3, (/1.,2.,4./), (/1.,2.,4.,8./), & 4, (/0.,2.,5.,0./), (/0.,1.,3.,8.,0./) ) - remapping_unit_tests = remapping_unit_tests .or. fail - fail = test_interp(verbose, 'Fs: 3 layer to 4 with vanished top/botton (shallow)', & + call test_interp(test, 'Fs: 3 layer to 4 with vanished top/botton (shallow)', & 3, (/1.,2.,4./), (/1.,2.,4.,8./), & 4, (/0.,2.,4.,0./), (/0.,1.,3.,7.,0./) ) - remapping_unit_tests = remapping_unit_tests .or. fail - fail = test_interp(verbose, 'Fd: 3 layer to 4 with vanished top/botton (deep)', & + call test_interp(test, 'Fd: 3 layer to 4 with vanished top/botton (deep)', & 3, (/1.,2.,4./), (/1.,2.,4.,8./), & 4, (/0.,2.,6.,0./), (/0.,1.,3.,8.,0./) ) - remapping_unit_tests = remapping_unit_tests .or. fail - if (verbose) write(stdout,*) '- - - - - - - - - - reintegration tests - - - - - - - - -' + if (verbose) write(test%stdout,*) ' - - - - - reintegration tests - - - - -' - fail = test_reintegrate(verbose, 'Identity: 3 layer', & + call test_reintegrate(test, 'Identity: 3 layer', & 3, (/1.,2.,3./), (/-5.,2.,1./), & 3, (/1.,2.,3./), (/-5.,2.,1./) ) - remapping_unit_tests = remapping_unit_tests .or. fail - fail = test_reintegrate(verbose, 'A: 3 layer to 2', & + call test_reintegrate(test, 'A: 3 layer to 2', & 3, (/2.,2.,2./), (/-5.,2.,1./), & 2, (/3.,3./), (/-4.,2./) ) - remapping_unit_tests = remapping_unit_tests .or. fail - fail = test_reintegrate(verbose, 'A: 3 layer to 2 (deep)', & + call test_reintegrate(test, 'A: 3 layer to 2 (deep)', & 3, (/2.,2.,2./), (/-5.,2.,1./), & 2, (/3.,4./), (/-4.,2./) ) - remapping_unit_tests = remapping_unit_tests .or. fail - fail = test_reintegrate(verbose, 'A: 3 layer to 2 (shallow)', & + call test_reintegrate(test, 'A: 3 layer to 2 (shallow)', & 3, (/2.,2.,2./), (/-5.,2.,1./), & 2, (/3.,2./), (/-4.,1.5/) ) - remapping_unit_tests = remapping_unit_tests .or. fail - fail = test_reintegrate(verbose, 'B: 3 layer to 4 with vanished top/bottom', & + call test_reintegrate(test, 'B: 3 layer to 4 with vanished top/bottom', & 3, (/2.,2.,2./), (/-5.,2.,1./), & 4, (/0.,3.,3.,0./), (/0.,-4.,2.,0./) ) - remapping_unit_tests = remapping_unit_tests .or. fail - fail = test_reintegrate(verbose, 'C: 3 layer to 4 with vanished top//middle/bottom', & + call test_reintegrate(test, 'C: 3 layer to 4 with vanished top//middle/bottom', & 3, (/2.,2.,2./), (/-5.,2.,1./), & 5, (/0.,3.,0.,3.,0./), (/0.,-4.,0.,2.,0./) ) - remapping_unit_tests = remapping_unit_tests .or. fail - fail = test_reintegrate(verbose, 'D: 3 layer to 3 (vanished)', & + call test_reintegrate(test, 'D: 3 layer to 3 (vanished)', & 3, (/2.,2.,2./), (/-5.,2.,1./), & 3, (/0.,0.,0./), (/0.,0.,0./) ) - remapping_unit_tests = remapping_unit_tests .or. fail - fail = test_reintegrate(verbose, 'D: 3 layer (vanished) to 3', & + call test_reintegrate(test, 'D: 3 layer (vanished) to 3', & 3, (/0.,0.,0./), (/-5.,2.,1./), & 3, (/2.,2.,2./), (/0., 0., 0./) ) - remapping_unit_tests = remapping_unit_tests .or. fail - fail = test_reintegrate(verbose, 'D: 3 layer (vanished) to 3 (vanished)', & + call test_reintegrate(test, 'D: 3 layer (vanished) to 3 (vanished)', & 3, (/0.,0.,0./), (/-5.,2.,1./), & - 3, (/0.,0.,0./), (/0., 0., 0./) ) - remapping_unit_tests = remapping_unit_tests .or. fail + 3, (/0.,0.,0./), (/0.,0.,0./) ) - fail = test_reintegrate(verbose, 'D: 3 layer (vanished) to 3 (vanished)', & + call test_reintegrate(test, 'D: 3 layer (vanished) to 3 (vanished)', & 3, (/0.,0.,0./), (/0.,0.,0./), & - 3, (/0.,0.,0./), (/0., 0., 0./) ) - remapping_unit_tests = remapping_unit_tests .or. fail + 3, (/0.,0.,0./), (/0.,0.,0./) ) - if (.not. remapping_unit_tests) write(stdout,*) 'Pass' + remapping_unit_tests = test%summarize('remapping_unit_tests') end function remapping_unit_tests -!> Returns true if any cell of u and u_true are not identical. Returns false otherwise. -logical function test_answer(verbose, n, u, u_true, label, tol) - logical, intent(in) :: verbose !< If true, write results to stdout +!> 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 + +! ========================================================================================= +! 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 + +!> 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 !< Values to test [A] + 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 - real :: tolerance ! The tolerance for differences between u and u_true [A] integer :: k + logical :: this_test + real :: tolerance, err ! Tolerance for differences, and error [A] + + tolerance = 0.0 + if (present(tol)) tolerance = tol + this_test = .false. - tolerance = 0.0 ; if (present(tol)) tolerance = tol - test_answer = .false. + ! Scan for any mismatch between u_test and u_true do k = 1, n - if (abs(u(k) - u_true(k)) > tolerance) test_answer = .true. + if (abs(u_test(k) - u_true(k)) > tolerance) this_test = .true. enddo - if (test_answer .or. verbose) then - write(stdout,'(a4,2a24,1x,a)') 'k','Calculated value','Correct value',label + + ! 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 (abs(u(k) - u_true(k)) > tolerance) then - write(stdout,'(i4,1p2e24.16,a,1pe24.16,a)') k,u(k),u_true(k),' err=',u(k)-u_true(k),' < wrong' - write(stderr,'(i4,1p2e24.16,a,1pe24.16,a)') k,u(k),u_true(k),' err=',u(k)-u_true(k),' < wrong' + 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(stdout,'(i4,1p2e24.16)') k,u(k),u_true(k) + write(this%stdout,'(i4,1p2e24.16)') k, u_test(k), u_true(k) endif enddo endif -end function test_answer - -!> Returns true if a test of interpolate_column() produces the wrong answer -logical function test_interp(verbose, msg, nsrc, h_src, u_src, ndest, h_dest, u_true) - logical, intent(in) :: verbose !< If true, write results to stdout - 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] + call this%test( this_test, label ) ! 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) + 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 - real, dimension(ndest+1) :: u_dest ! Interpolated value at destination cell interfaces [A] integer :: k - real :: error ! The difference between the evaluated and expected solutions [A] + logical :: this_test - ! Interpolate from src to dest - call interpolate_column(nsrc, h_src, u_src, ndest, h_dest, u_dest, .true.) + this_test = .false. - test_interp = .false. - do k=1,ndest+1 - if (u_dest(k)/=u_true(k)) test_interp = .true. + ! 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 - if (verbose .or. test_interp) then - write(stdout,'(2a)') ' Test: ',msg - write(stdout,'(a3,3(a24))') 'k','u_result','u_true','error' - do k=1,ndest+1 - error = u_dest(k)-u_true(k) - if (error==0.) then - write(stdout,'(i3,3(1pe24.16))') k,u_dest(k),u_true(k),u_dest(k)-u_true(k) - else - write(stdout,'(i3,3(1pe24.16),1x,a)') k,u_dest(k),u_true(k),u_dest(k)-u_true(k),'<--- WRONG!' - write(stderr,'(i3,3(1pe24.16),1x,a)') k,u_dest(k),u_true(k),u_dest(k)-u_true(k),'<--- WRONG!' - endif - enddo - endif -end function test_interp - -!> Returns true if a test of reintegrate_column() produces the wrong answer -logical function test_reintegrate(verbose, msg, nsrc, h_src, uh_src, ndest, h_dest, uh_true) - logical, intent(in) :: verbose !< If true, write results to stdout - 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] - integer :: k - real :: error ! The difference between the evaluated and expected solutions [A H] - ! Interpolate from src to dest - call reintegrate_column(nsrc, h_src, uh_src, ndest, h_dest, uh_dest) - - test_reintegrate = .false. - do k=1,ndest - if (uh_dest(k)/=uh_true(k)) test_reintegrate = .true. - enddo - if (verbose .or. test_reintegrate) then - write(stdout,'(2a)') ' Test: ',msg - write(stdout,'(a3,3(a24))') 'k','uh_result','uh_true','error' - do k=1,ndest - error = uh_dest(k)-uh_true(k) - if (error==0.) then - write(stdout,'(i3,3(1pe24.16))') k,uh_dest(k),uh_true(k),uh_dest(k)-uh_true(k) - else - write(stdout,'(i3,3(1pe24.16),1x,a)') k,uh_dest(k),uh_true(k),uh_dest(k)-uh_true(k),'<--- WRONG!' - write(stderr,'(i3,3(1pe24.16),1x,a)') k,uh_dest(k),uh_true(k),uh_dest(k)-uh_true(k),'<--- WRONG!' - endif - enddo - endif -end function test_reintegrate - -!> 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 + 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 end module MOM_remapping diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index 397a4e4059..d37f265030 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -624,7 +624,7 @@ subroutine step_MOM(forces_in, fluxes_in, sfc_state, Time_start, time_int_in, CS call rotate_mech_forcing(forces_in, turns, forces) allocate(fluxes) - call allocate_forcing_type(fluxes_in, G, fluxes) + call allocate_forcing_type(fluxes_in, G, fluxes, turns=turns) call rotate_forcing(fluxes_in, fluxes, turns) else forces => forces_in @@ -1044,6 +1044,7 @@ subroutine step_MOM(forces_in, fluxes_in, sfc_state, Time_start, time_int_in, CS ! Do diagnostics that only occur at the end of a complete forcing step. if (cycle_end) then + if (showCallTree) call callTree_waypoint("Do cycle end diagnostics (step_MOM)") if (CS%rotate_index) then allocate(sfc_state_diag) call rotate_surface_state(sfc_state, sfc_state_diag, G, turns) @@ -1063,6 +1064,10 @@ subroutine step_MOM(forces_in, fluxes_in, sfc_state, Time_start, time_int_in, CS endif call disable_averaging(CS%diag) call cpu_clock_end(id_clock_diagnostics) + if (CS%rotate_index) then + call deallocate_surface_state(sfc_state_diag) + endif + if (showCallTree) call callTree_waypoint("Done with end cycle diagnostics (step_MOM)") endif ! Accumulate the surface fluxes for assessing conservation @@ -3710,8 +3715,8 @@ subroutine extract_surface_state(CS, sfc_state_in) if (CS%rotate_index) then allocate(sfc_state) call allocate_surface_state(sfc_state, G, use_temperature, & - do_integrals=.true., omit_frazil=.not.associated(CS%tv%frazil),& - use_iceshelves=use_iceshelves) + do_integrals=.true., omit_frazil=.not.associated(CS%tv%frazil),& + use_iceshelves=use_iceshelves, sfc_state_in=sfc_state_in, turns=turns) else sfc_state => sfc_state_in endif @@ -4213,7 +4218,7 @@ subroutine MOM_end(CS) if (associated(CS%tv%internal_heat)) deallocate(CS%tv%internal_heat) if (associated(CS%tv%TempxPmE)) deallocate(CS%tv%TempxPmE) - DEALLOC_(CS%ave_ssh_ibc) ; DEALLOC_(CS%ssh_rint) + DEALLOC_(CS%ave_ssh_ibc) ; DEALLOC_(CS%ssh_rint) ; DEALLOC_(CS%eta_av_bc) ! TODO: debug_truncations deallocation diff --git a/src/core/MOM_PressureForce_FV.F90 b/src/core/MOM_PressureForce_FV.F90 index 5fb3ade634..5d0f4ff167 100644 --- a/src/core/MOM_PressureForce_FV.F90 +++ b/src/core/MOM_PressureForce_FV.F90 @@ -128,21 +128,22 @@ subroutine PressureForce_FV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_ e_tide_sal, & ! The bottom geopotential anomaly due to harmonic self-attraction and loading ! specific to tides [Z ~> m]. e_sal_tide, & ! The summation of self-attraction and loading and tidal forcing [Z ~> m]. - dM, & ! The barotropic adjustment to the Montgomery potential to + dM ! The barotropic adjustment to the Montgomery potential to ! account for a reduced gravity model [L2 T-2 ~> m2 s-2]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1) :: & za ! The geopotential anomaly (i.e. g*e + alpha_0*pressure) at the - ! interface atop a layer [L2 T-2 ~> m2 s-2]. + ! interfaces [L2 T-2 ~> m2 s-2]. real, dimension(SZI_(G)) :: Rho_cv_BL ! The coordinate potential density in the deepest variable ! density near-surface layer [R ~> kg m-3]. - real, dimension(SZIB_(G),SZJ_(G)) :: & + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1) :: & intx_za ! The zonal integral of the geopotential anomaly along the - ! interface below a layer, divided by the grid spacing [L2 T-2 ~> m2 s-2]. + ! interfaces, divided by the grid spacing [L2 T-2 ~> m2 s-2]. real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)) :: & intx_dza ! The change in intx_za through a layer [L2 T-2 ~> m2 s-2]. - real, dimension(SZI_(G),SZJB_(G)) :: & + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1) :: & inty_za ! The meridional integral of the geopotential anomaly along the - ! interface below a layer, divided by the grid spacing [L2 T-2 ~> m2 s-2]. + ! interfaces, divided by the grid spacing [L2 T-2 ~> m2 s-2]. real, dimension(SZI_(G),SZJB_(G),SZK_(GV)) :: & inty_dza ! The change in inty_za through a layer [L2 T-2 ~> m2 s-2]. real :: p_ref(SZI_(G)) ! The pressure used to calculate the coordinate @@ -305,10 +306,10 @@ subroutine PressureForce_FV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_ !$OMP parallel do default(shared) do j=Jsq,Jeq+1 do i=Isq,Ieq+1 - za(i,j) = alpha_ref*p(i,j,nz+1) - GV%g_Earth*G%bathyT(i,j) + za(i,j,nz+1) = alpha_ref*p(i,j,nz+1) - GV%g_Earth*G%bathyT(i,j) enddo do k=nz,1,-1 ; do i=Isq,Ieq+1 - za(i,j) = za(i,j) + dza(i,j,k) + za(i,j,K) = za(i,j,K+1) + dza(i,j,k) enddo ; enddo enddo @@ -316,7 +317,7 @@ subroutine PressureForce_FV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_ if (CS%calculate_SAL) then !$OMP parallel do default(shared) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - SSH(i,j) = (za(i,j) - alpha_ref*p(i,j,1)) * I_gEarth - G%Z_ref & + SSH(i,j) = (za(i,j,1) - alpha_ref*p(i,j,1)) * I_gEarth - G%Z_ref & - max(-G%bathyT(i,j)-G%Z_ref, 0.0) enddo ; enddo call calc_SAL(SSH, e_sal, G, CS%SAL_CSp, tmp_scale=US%Z_to_m) @@ -324,7 +325,7 @@ subroutine PressureForce_FV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_ if ((CS%tides_answer_date>20230630) .or. (.not.GV%semi_Boussinesq) .or. (.not.CS%tides)) then !$OMP parallel do default(shared) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - za(i,j) = za(i,j) - GV%g_Earth * e_sal(i,j) + za(i,j,1) = za(i,j,1) - GV%g_Earth * e_sal(i,j) enddo ; enddo endif endif @@ -335,7 +336,7 @@ subroutine PressureForce_FV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_ call calc_tidal_forcing(CS%Time, e_tide_eq, e_tide_sal, G, US, CS%tides_CSp) !$OMP parallel do default(shared) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - za(i,j) = za(i,j) - GV%g_Earth * (e_tide_eq(i,j) + e_tide_sal(i,j)) + za(i,j,1) = za(i,j,1) - GV%g_Earth * (e_tide_eq(i,j) + e_tide_sal(i,j)) enddo ; enddo else ! This block recreates older answers with tides. if (.not.CS%calculate_SAL) e_sal(:,:) = 0.0 @@ -343,85 +344,104 @@ subroutine PressureForce_FV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_ G, US, CS%tides_CSp) !$OMP parallel do default(shared) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - za(i,j) = za(i,j) - GV%g_Earth * e_sal_tide(i,j) + za(i,j,1) = za(i,j,1) - GV%g_Earth * e_sal_tide(i,j) enddo ; enddo endif endif - if (CS%GFS_scale < 1.0) then - ! Adjust the Montgomery potential to make this a reduced gravity model. - if (use_EOS) then - !$OMP parallel do default(shared) private(rho_in_situ) - do j=Jsq,Jeq+1 - call calculate_density(tv_tmp%T(:,j,1), tv_tmp%S(:,j,1), p(:,j,1), rho_in_situ, & - tv%eqn_of_state, EOSdom) - - do i=Isq,Ieq+1 - dM(i,j) = (CS%GFS_scale - 1.0) * (p(i,j,1)*(1.0/rho_in_situ(i) - alpha_ref) + za(i,j)) - enddo - enddo - else - !$OMP parallel do default(shared) - do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - dM(i,j) = (CS%GFS_scale - 1.0) * (p(i,j,1)*(1.0/GV%Rlay(1) - alpha_ref) + za(i,j)) - enddo ; enddo - endif -! else -! do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 ; dM(i,j) = 0.0 ; enddo ; enddo - endif + ! Find the height anomalies at the interfaces. If there are no tides and no SAL, + ! there is no need to correct za, but omitting this changes answers at roundoff. + do k=1,nz + !$OMP parallel do default(shared) + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + za(i,j,K+1) = za(i,j,K) - dza(i,j,k) + enddo ; enddo + enddo ! This order of integrating upward and then downward again is necessary with ! a nonlinear equation of state, so that the surface geopotentials will go - ! linearly between the values at thickness points, but the bottom - ! geopotentials will not now be linear at the sub-grid-scale. Doing this - ! ensures no motion with flat isopycnals, even with a nonlinear equation of state. + ! linearly between the values at thickness points, but the bottom geopotentials + ! will not now be linear at the sub-grid-scale. Doing this ensures no motion + ! with flat isopycnals, even with a nonlinear equation of state. + ! With an ice-shelf or icebergs, this linearity condition might need to be applied + ! to a sub-surface interface. !$OMP parallel do default(shared) do j=js,je ; do I=Isq,Ieq - intx_za(I,j) = 0.5*(za(i,j) + za(i+1,j)) + intx_za(I,j,1) = 0.5*(za(i,j,1) + za(i+1,j,1)) enddo ; enddo + do k=1,nz + !$OMP parallel do default(shared) + do j=js,je ; do I=Isq,Ieq + intx_za(I,j,K+1) = intx_za(I,j,K) - intx_dza(I,j,k) + enddo ; enddo + enddo + !$OMP parallel do default(shared) do J=Jsq,Jeq ; do i=is,ie - inty_za(i,J) = 0.5*(za(i,j) + za(i,j+1)) + inty_za(i,J,1) = 0.5*(za(i,j,1) + za(i,j+1,1)) enddo ; enddo do k=1,nz - ! These expressions for the acceleration have been carefully checked in - ! a set of idealized cases, and should be bug-free. !$OMP parallel do default(shared) + do J=Jsq,Jeq ; do i=is,ie + inty_za(i,J,K+1) = inty_za(i,J,K) - inty_dza(i,J,k) + enddo ; enddo + enddo + + !$OMP parallel do default(shared) private(dp) + do k=1,nz do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 dp(i,j) = H_to_RL2_T2 * h(i,j,k) - za(i,j) = za(i,j) - dza(i,j,k) enddo ; enddo - !$OMP parallel do default(shared) + + ! Find the horizontal pressure gradient accelerations. + ! These expressions for the accelerations have been carefully checked in + ! a set of idealized cases, and should be bug-free. do j=js,je ; do I=Isq,Ieq - intx_za(I,j) = intx_za(I,j) - intx_dza(I,j,k) - PFu(I,j,k) = ( ((za(i,j)*dp(i,j) + intp_dza(i,j,k)) - & - (za(i+1,j)*dp(i+1,j) + intp_dza(i+1,j,k))) + & - ((dp(i+1,j) - dp(i,j)) * intx_za(I,j) - & + PFu(I,j,k) = ( ((za(i,j,K+1)*dp(i,j) + intp_dza(i,j,k)) - & + (za(i+1,j,K+1)*dp(i+1,j) + intp_dza(i+1,j,k))) + & + ((dp(i+1,j) - dp(i,j)) * intx_za(I,j,K+1) - & (p(i+1,j,K) - p(i,j,K)) * intx_dza(I,j,k)) ) * & (2.0*G%IdxCu(I,j) / ((dp(i,j) + dp(i+1,j)) + dp_neglect)) enddo ; enddo - !$OMP parallel do default(shared) + do J=Jsq,Jeq ; do i=is,ie - inty_za(i,J) = inty_za(i,J) - inty_dza(i,J,k) - PFv(i,J,k) = (((za(i,j)*dp(i,j) + intp_dza(i,j,k)) - & - (za(i,j+1)*dp(i,j+1) + intp_dza(i,j+1,k))) + & - ((dp(i,j+1) - dp(i,j)) * inty_za(i,J) - & + PFv(i,J,k) = (((za(i,j,K+1)*dp(i,j) + intp_dza(i,j,k)) - & + (za(i,j+1,K+1)*dp(i,j+1) + intp_dza(i,j+1,k))) + & + ((dp(i,j+1) - dp(i,j)) * inty_za(i,J,K+1) - & (p(i,j+1,K) - p(i,j,K)) * inty_dza(i,J,k))) * & (2.0*G%IdyCv(i,J) / ((dp(i,j) + dp(i,j+1)) + dp_neglect)) enddo ; enddo + enddo + + if (CS%GFS_scale < 1.0) then + ! Adjust the Montgomery potential to make this a reduced gravity model. + if (use_EOS) then + !$OMP parallel do default(shared) private(rho_in_situ) + do j=Jsq,Jeq+1 + call calculate_density(tv_tmp%T(:,j,1), tv_tmp%S(:,j,1), p(:,j,1), rho_in_situ, & + tv%eqn_of_state, EOSdom) - if (CS%GFS_scale < 1.0) then - ! Adjust the Montgomery potential to make this a reduced gravity model. + do i=Isq,Ieq+1 + dM(i,j) = (CS%GFS_scale - 1.0) * (p(i,j,1)*(1.0/rho_in_situ(i) - alpha_ref) + za(i,j,1)) + enddo + enddo + else !$OMP parallel do default(shared) + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + dM(i,j) = (CS%GFS_scale - 1.0) * (p(i,j,1)*(1.0/GV%Rlay(1) - alpha_ref) + za(i,j,1)) + enddo ; enddo + endif + + !$OMP parallel do default(shared) + do k=1,nz do j=js,je ; do I=Isq,Ieq PFu(I,j,k) = PFu(I,j,k) - (dM(i+1,j) - dM(i,j)) * G%IdxCu(I,j) enddo ; enddo - !$OMP parallel do default(shared) do J=Jsq,Jeq ; do i=is,ie PFv(i,J,k) = PFv(i,J,k) - (dM(i,j+1) - dM(i,j)) * G%IdyCv(i,J) enddo ; enddo - endif - enddo + enddo + endif if (present(pbce)) then call set_pbce_nonBouss(p, tv_tmp, G, GV, US, CS%GFS_scale, pbce) @@ -493,20 +513,24 @@ subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm Rho_cv_BL ! The coordinate potential density in the deepest variable ! density near-surface layer [R ~> kg m-3]. real, dimension(SZI_(G),SZJ_(G)) :: & - dz_geo, & ! The change in geopotential thickness through a layer [L2 T-2 ~> m2 s-2]. - pa, & ! The pressure anomaly (i.e. pressure + g*RHO_0*e) at the + dz_geo ! The change in geopotential thickness through a layer [L2 T-2 ~> m2 s-2]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1) :: & + pa ! The pressure anomaly (i.e. pressure + g*RHO_0*e) at the ! the interface atop a layer [R L2 T-2 ~> Pa]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: & dpa, & ! The change in pressure anomaly between the top and bottom ! of a layer [R L2 T-2 ~> Pa]. intz_dpa ! The vertical integral in depth of the pressure anomaly less the ! pressure anomaly at the top of the layer [H R L2 T-2 ~> m Pa]. - real, dimension(SZIB_(G),SZJ_(G)) :: & - intx_pa, & ! The zonal integral of the pressure anomaly along the interface + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1) :: & + intx_pa ! The zonal integral of the pressure anomaly along the interface ! atop a layer, divided by the grid spacing [R L2 T-2 ~> Pa]. + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)) :: & intx_dpa ! The change in intx_pa through a layer [R L2 T-2 ~> Pa]. - real, dimension(SZI_(G),SZJB_(G)) :: & - inty_pa, & ! The meridional integral of the pressure anomaly along the + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1) :: & + inty_pa ! The meridional integral of the pressure anomaly along the ! interface atop a layer, divided by the grid spacing [R L2 T-2 ~> Pa]. + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)) :: & inty_dpa ! The change in inty_pa through a layer [R L2 T-2 ~> Pa]. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), target :: & @@ -648,17 +672,15 @@ subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm enddo ; enddo ; enddo if (use_EOS) then -! With a bulk mixed layer, replace the T & S of any layers that are -! lighter than the buffer layer with the properties of the buffer -! layer. These layers will be massless anyway, and it avoids any -! formal calculations with hydrostatically unstable profiles. - if (nkmb>0) then + ! With a bulk mixed layer, replace the T & S of any layers that are lighter than the buffer + ! layer with the properties of the buffer layer. These layers will be massless anyway, and + ! it avoids any formal calculations with hydrostatically unstable profiles. tv_tmp%T => T_tmp ; tv_tmp%S => S_tmp tv_tmp%eqn_of_state => tv%eqn_of_state do i=Isq,Ieq+1 ; p_ref(i) = tv%P_Ref ; enddo - !$OMP parallel do default(shared) private(Rho_cv_BL) + !$OMP parallel do default(shared) private(Rho_cv_BL) do j=Jsq,Jeq+1 do k=1,nkmb ; do i=Isq,Ieq+1 tv_tmp%T(i,j,k) = tv%T(i,j,k) ; tv_tmp%S(i,j,k) = tv%S(i,j,k) @@ -680,31 +702,6 @@ subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm endif endif - if (CS%GFS_scale < 1.0) then - ! Adjust the Montgomery potential to make this a reduced gravity model. - if (use_EOS) then - !$OMP parallel do default(shared) - do j=Jsq,Jeq+1 - if (use_p_atm) then - call calculate_density(tv_tmp%T(:,j,1), tv_tmp%S(:,j,1), p_atm(:,j), rho_in_situ, & - tv%eqn_of_state, EOSdom) - else - call calculate_density(tv_tmp%T(:,j,1), tv_tmp%S(:,j,1), p0, rho_in_situ, & - tv%eqn_of_state, EOSdom) - endif - do i=Isq,Ieq+1 - dM(i,j) = (CS%GFS_scale - 1.0) * (G_Rho0 * rho_in_situ(i)) * (e(i,j,1) - G%Z_ref) - enddo - enddo - else - !$OMP parallel do default(shared) - do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - dM(i,j) = (CS%GFS_scale - 1.0) * (G_Rho0 * GV%Rlay(1)) * (e(i,j,1) - G%Z_ref) - enddo ; enddo - endif - endif - ! I have checked that rho_0 drops out and that the 1-layer case is right. RWH. - ! If regridding is activated, do a linear reconstruction of salinity ! and temperature across each layer. The subscripts 't' and 'b' refer ! to top and bottom values within each layer (these are the only degrees @@ -723,22 +720,14 @@ subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm if (use_p_atm) then !$OMP parallel do default(shared) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - pa(i,j) = (rho_ref*GV%g_Earth)*(e(i,j,1) - G%Z_ref) + p_atm(i,j) + pa(i,j,1) = (rho_ref*GV%g_Earth)*(e(i,j,1) - G%Z_ref) + p_atm(i,j) enddo ; enddo else !$OMP parallel do default(shared) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - pa(i,j) = (rho_ref*GV%g_Earth)*(e(i,j,1) - G%Z_ref) + pa(i,j,1) = (rho_ref*GV%g_Earth)*(e(i,j,1) - G%Z_ref) enddo ; enddo endif - !$OMP parallel do default(shared) - do j=js,je ; do I=Isq,Ieq - intx_pa(I,j) = 0.5*(pa(i,j) + pa(i+1,j)) - enddo ; enddo - !$OMP parallel do default(shared) - do J=Jsq,Jeq ; do i=is,ie - inty_pa(i,J) = 0.5*(pa(i,j) + pa(i,j+1)) - enddo ; enddo do k=1,nz ! Calculate 4 integrals through the layer that are required in the @@ -753,76 +742,131 @@ subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm if ( CS%Recon_Scheme == 1 ) then call int_density_dz_generic_plm(k, tv, T_t, T_b, S_t, S_b, e, & rho_ref, CS%Rho0, GV%g_Earth, dz_neglect, G%bathyT, & - G%HI, GV, tv%eqn_of_state, US, CS%use_stanley_pgf, dpa, intz_dpa, intx_dpa, inty_dpa, & + G%HI, GV, tv%eqn_of_state, US, CS%use_stanley_pgf, dpa(:,:,k), intz_dpa(:,:,k), & + intx_dpa(:,:,k), inty_dpa(:,:,k), & useMassWghtInterp=CS%useMassWghtInterp, & use_inaccurate_form=CS%use_inaccurate_pgf_rho_anom, Z_0p=G%Z_ref) elseif ( CS%Recon_Scheme == 2 ) then call int_density_dz_generic_ppm(k, tv, T_t, T_b, S_t, S_b, e, & rho_ref, CS%Rho0, GV%g_Earth, dz_neglect, G%bathyT, & - G%HI, GV, tv%eqn_of_state, US, CS%use_stanley_pgf, dpa, intz_dpa, intx_dpa, inty_dpa, & + G%HI, GV, tv%eqn_of_state, US, CS%use_stanley_pgf, dpa(:,:,k), intz_dpa(:,:,k), & + intx_dpa(:,:,k), inty_dpa(:,:,k), & useMassWghtInterp=CS%useMassWghtInterp, Z_0p=G%Z_ref) endif else call int_density_dz(tv_tmp%T(:,:,k), tv_tmp%S(:,:,k), e(:,:,K), e(:,:,K+1), & - rho_ref, CS%Rho0, GV%g_Earth, G%HI, tv%eqn_of_state, US, dpa, & - intz_dpa, intx_dpa, inty_dpa, G%bathyT, dz_neglect, CS%useMassWghtInterp, Z_0p=G%Z_ref) + rho_ref, CS%Rho0, GV%g_Earth, G%HI, tv%eqn_of_state, US, dpa(:,:,k), & + intz_dpa(:,:,k), intx_dpa(:,:,k), inty_dpa(:,:,k), G%bathyT, dz_neglect, & + CS%useMassWghtInterp, Z_0p=G%Z_ref) + endif + if (GV%Z_to_H /= 1.0) then + !$OMP parallel do default(shared) + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + intz_dpa(i,j,k) = intz_dpa(i,j,k)*GV%Z_to_H + enddo ; enddo endif - !$OMP parallel do default(shared) - do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - intz_dpa(i,j) = intz_dpa(i,j)*GV%Z_to_H - enddo ; enddo else !$OMP parallel do default(shared) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 dz_geo(i,j) = GV%g_Earth * GV%H_to_Z*h(i,j,k) - dpa(i,j) = (GV%Rlay(k) - rho_ref) * dz_geo(i,j) - intz_dpa(i,j) = 0.5*(GV%Rlay(k) - rho_ref) * dz_geo(i,j)*h(i,j,k) + dpa(i,j,k) = (GV%Rlay(k) - rho_ref) * dz_geo(i,j) + intz_dpa(i,j,k) = 0.5*(GV%Rlay(k) - rho_ref) * dz_geo(i,j)*h(i,j,k) enddo ; enddo !$OMP parallel do default(shared) do j=js,je ; do I=Isq,Ieq - intx_dpa(I,j) = 0.5*(GV%Rlay(k) - rho_ref) * (dz_geo(i,j) + dz_geo(i+1,j)) + intx_dpa(I,j,k) = 0.5*(GV%Rlay(k) - rho_ref) * (dz_geo(i,j) + dz_geo(i+1,j)) enddo ; enddo !$OMP parallel do default(shared) do J=Jsq,Jeq ; do i=is,ie - inty_dpa(i,J) = 0.5*(GV%Rlay(k) - rho_ref) * (dz_geo(i,j) + dz_geo(i,j+1)) + inty_dpa(i,J,k) = 0.5*(GV%Rlay(k) - rho_ref) * (dz_geo(i,j) + dz_geo(i,j+1)) enddo ; enddo endif + enddo - ! Compute pressure gradient in x direction + ! Set the pressure anomalies at the interfaces. + do k=1,nz !$OMP parallel do default(shared) - do j=js,je ; do I=Isq,Ieq - PFu(I,j,k) = (((pa(i,j)*h(i,j,k) + intz_dpa(i,j)) - & - (pa(i+1,j)*h(i+1,j,k) + intz_dpa(i+1,j))) + & - ((h(i+1,j,k) - h(i,j,k)) * intx_pa(I,j) - & - (e(i+1,j,K+1) - e(i,j,K+1)) * intx_dpa(I,j) * GV%Z_to_H)) * & - ((2.0*I_Rho0*G%IdxCu(I,j)) / & - ((h(i,j,k) + h(i+1,j,k)) + h_neglect)) - intx_pa(I,j) = intx_pa(I,j) + intx_dpa(I,j) + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + pa(i,j,K+1) = pa(i,j,K) + dpa(i,j,k) enddo ; enddo - ! Compute pressure gradient in y direction + enddo + + ! Set the surface boundary conditions on the horizontally integrated pressure anomaly, + ! assuming that the surface pressure anomaly varies linearly in x and y. + ! If there is an ice-shelf or icebergs, this linear variation would need to be applied + ! to an interior interface. + !$OMP parallel do default(shared) + do j=js,je ; do I=Isq,Ieq + intx_pa(I,j,1) = 0.5*(pa(i,j,1) + pa(i+1,j,1)) + enddo ; enddo + do k=1,nz !$OMP parallel do default(shared) - do J=Jsq,Jeq ; do i=is,ie - PFv(i,J,k) = (((pa(i,j)*h(i,j,k) + intz_dpa(i,j)) - & - (pa(i,j+1)*h(i,j+1,k) + intz_dpa(i,j+1))) + & - ((h(i,j+1,k) - h(i,j,k)) * inty_pa(i,J) - & - (e(i,j+1,K+1) - e(i,j,K+1)) * inty_dpa(i,J) * GV%Z_to_H)) * & - ((2.0*I_Rho0*G%IdyCv(i,J)) / & - ((h(i,j,k) + h(i,j+1,k)) + h_neglect)) - inty_pa(i,J) = inty_pa(i,J) + inty_dpa(i,J) + do j=js,je ; do I=Isq,Ieq + intx_pa(I,j,K+1) = intx_pa(I,j,K) + intx_dpa(I,j,k) enddo ; enddo + enddo + + !$OMP parallel do default(shared) + do J=Jsq,Jeq ; do i=is,ie + inty_pa(i,J,1) = 0.5*(pa(i,j,1) + pa(i,j+1,1)) + enddo ; enddo + do k=1,nz !$OMP parallel do default(shared) - do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - pa(i,j) = pa(i,j) + dpa(i,j) + do J=Jsq,Jeq ; do i=is,ie + inty_pa(i,J,K+1) = inty_pa(i,J,K) + inty_dpa(i,J,k) enddo ; enddo enddo + ! Compute pressure gradient in x direction + !$OMP parallel do default(shared) + do k=1,nz ; do j=js,je ; do I=Isq,Ieq + PFu(I,j,k) = (((pa(i,j,K)*h(i,j,k) + intz_dpa(i,j,k)) - & + (pa(i+1,j,K)*h(i+1,j,k) + intz_dpa(i+1,j,k))) + & + ((h(i+1,j,k) - h(i,j,k)) * intx_pa(I,j,K) - & + (e(i+1,j,K+1) - e(i,j,K+1)) * intx_dpa(I,j,k) * GV%Z_to_H)) * & + ((2.0*I_Rho0*G%IdxCu(I,j)) / & + ((h(i,j,k) + h(i+1,j,k)) + h_neglect)) + enddo ; enddo ; enddo + + ! Compute pressure gradient in y direction + !$OMP parallel do default(shared) + do k=1,nz ; do J=Jsq,Jeq ; do i=is,ie + PFv(i,J,k) = (((pa(i,j,K)*h(i,j,k) + intz_dpa(i,j,k)) - & + (pa(i,j+1,K)*h(i,j+1,k) + intz_dpa(i,j+1,k))) + & + ((h(i,j+1,k) - h(i,j,k)) * inty_pa(i,J,K) - & + (e(i,j+1,K+1) - e(i,j,K+1)) * inty_dpa(i,J,k) * GV%Z_to_H)) * & + ((2.0*I_Rho0*G%IdyCv(i,J)) / & + ((h(i,j,k) + h(i,j+1,k)) + h_neglect)) + enddo ; enddo ; enddo + if (CS%GFS_scale < 1.0) then - do k=1,nz + ! Adjust the Montgomery potential to make this a reduced gravity model. + if (use_EOS) then !$OMP parallel do default(shared) + do j=Jsq,Jeq+1 + if (use_p_atm) then + call calculate_density(tv_tmp%T(:,j,1), tv_tmp%S(:,j,1), p_atm(:,j), rho_in_situ, & + tv%eqn_of_state, EOSdom) + else + call calculate_density(tv_tmp%T(:,j,1), tv_tmp%S(:,j,1), p0, rho_in_situ, & + tv%eqn_of_state, EOSdom) + endif + do i=Isq,Ieq+1 + dM(i,j) = (CS%GFS_scale - 1.0) * (G_Rho0 * rho_in_situ(i)) * (e(i,j,1) - G%Z_ref) + enddo + enddo + else + !$OMP parallel do default(shared) + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + dM(i,j) = (CS%GFS_scale - 1.0) * (G_Rho0 * GV%Rlay(1)) * (e(i,j,1) - G%Z_ref) + enddo ; enddo + endif + + !$OMP parallel do default(shared) + do k=1,nz do j=js,je ; do I=Isq,Ieq PFu(I,j,k) = PFu(I,j,k) - (dM(i+1,j) - dM(i,j)) * G%IdxCu(I,j) enddo ; enddo - !$OMP parallel do default(shared) do J=Jsq,Jeq ; do i=is,ie PFv(i,J,k) = PFv(i,J,k) - (dM(i,j+1) - dM(i,j)) * G%IdyCv(i,J) enddo ; enddo diff --git a/src/core/MOM_barotropic.F90 b/src/core/MOM_barotropic.F90 index 83bfab0820..2d463b909c 100644 --- a/src/core/MOM_barotropic.F90 +++ b/src/core/MOM_barotropic.F90 @@ -282,6 +282,7 @@ module MOM_barotropic logical :: tidal_sal_flather !< Apply adjustment to external gravity wave speed !! consistent with tidal self-attraction and loading !! used within the barotropic solver + logical :: wt_uv_fix !< If true, use a normalized wt_[uv] for vertical averages. type(time_type), pointer :: Time => NULL() !< A pointer to the ocean models clock. type(diag_ctrl), pointer :: diag => NULL() !< A structure that is used to regulate !! the timing of diagnostic output. @@ -506,6 +507,9 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, real :: wt_v(SZI_(G),SZJB_(G),SZK_(GV)) ! normalized weights to ! be used in calculating barotropic velocities, possibly with ! sums less than one due to viscous losses [nondim] + real :: Iwt_u_tot(SZIB_(G),SZJ_(G)) ! Iwt_u_tot and Iwt_v_tot are the + real :: Iwt_v_tot(SZI_(G),SZJB_(G)) ! inverses of wt_u and wt_v vertical integrals, + ! used to normalize wt_u and wt_v [nondim] real, dimension(SZIB_(G),SZJ_(G)) :: & av_rem_u, & ! The weighted average of visc_rem_u [nondim] tmp_u, & ! A temporary array at u points [L T-2 ~> m s-2] or [nondim] @@ -1052,6 +1056,30 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, wt_v(i,J,k) = CS%frhatv(i,J,k) * visc_rem enddo ; enddo ; enddo + if (CS%wt_uv_fix) then + do j=js,je ; do I=is-1,ie ; Iwt_u_tot(I,j) = wt_u(I,j,1) ; enddo ; enddo + do k=2,nz ; do j=js,je ; do I=is-1,ie + Iwt_u_tot(I,j) = Iwt_u_tot(I,j) + wt_u(I,j,k) + enddo ; enddo ; enddo + do j=js,je ; do I=is-1,ie + if (abs(Iwt_u_tot(I,j)) > 0.0 ) Iwt_u_tot(I,j) = G%mask2dCu(I,j) / Iwt_u_tot(I,j) + enddo ; enddo + do k=1,nz ; do j=js,je ; do I=is-1,ie + wt_u(I,j,k) = wt_u(I,j,k) * Iwt_u_tot(I,j) + enddo ; enddo ; enddo + + do J=js-1,je ; do i=is,ie ; Iwt_v_tot(i,J) = wt_v(i,J,1) ; enddo ; enddo + do k=2,nz ; do J=js-1,je ; do i=is,ie + Iwt_v_tot(i,J) = Iwt_v_tot(i,J) + wt_v(i,J,k) + enddo ; enddo ; enddo + do J=js-1,je ; do i=is,ie + if (abs(Iwt_v_tot(i,J)) > 0.0 ) Iwt_v_tot(i,J) = G%mask2dCv(i,J) / Iwt_v_tot(i,J) + enddo ; enddo + do k=1,nz ; do J=js-1,je ; do i=is,ie + wt_v(i,J,k) = wt_v(i,J,k) * Iwt_v_tot(i,J) + enddo ; enddo ; enddo + endif + ! Use u_Cor and v_Cor as the reference values for the Coriolis terms, ! including the viscous remnant. !$OMP parallel do default(shared) @@ -2443,7 +2471,7 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, do j=js,je ; do i=is,ie if ((eta(i,j) < -GV%Z_to_H*G%bathyT(i,j)) .and. (G%mask2dT(i,j) > 0.0)) then write(mesg,'(ES24.16," vs. ",ES24.16, " at ", ES12.4, ES12.4, i7, i7)') GV%H_to_m*eta(i,j), & - -US%Z_to_m*G%bathyT(i,j), G%geoLonT(i,j), G%geoLatT(i,j), i + G%isd_global, j + G%jsd_global + -US%Z_to_m*G%bathyT(i,j), G%geoLonT(i,j), G%geoLatT(i,j), i + G%HI%idg_offset, j + G%HI%jdg_offset if (err_count < 2) & call MOM_error(WARNING, "btstep: eta has dropped below bathyT: "//trim(mesg), all_print=.true.) err_count = err_count + 1 @@ -4436,6 +4464,7 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, integer :: default_answer_date ! The default setting for the various ANSWER_DATE flags. logical :: use_BT_cont_type logical :: use_tides + logical :: visc_rem_bug ! Stores the value of runtime paramter VISC_REM_BUG. character(len=48) :: thickness_units, flux_units character*(40) :: hvel_str integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz @@ -4580,10 +4609,16 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, call get_param(param_file, mdl, "BAROTROPIC_ANSWER_DATE", CS%answer_date, & "The vintage of the expressions in the barotropic solver. "//& "Values below 20190101 recover the answers from the end of 2018, "//& - "while higher values uuse more efficient or general expressions.", & + "while higher values use more efficient or general expressions.", & default=default_answer_date, do_not_log=.not.GV%Boussinesq) if (.not.GV%Boussinesq) CS%answer_date = max(CS%answer_date, 20230701) + call get_param(param_file, mdl, "VISC_REM_BUG", visc_rem_bug, default=.true., do_not_log=.true.) + call get_param(param_file, mdl, "VISC_REM_BT_WEIGHT_FIX", CS%wt_uv_fix, & + "If true, use a normalized weight function for vertical averages of "//& + "baroclinic velocity and forcing. Default of this flag is set by "//& + "VISC_REM_BUG. This flag should be used with VISC_REM_TIMESTEP_FIX.", & + default=.not.visc_rem_bug) call get_param(param_file, mdl, "TIDES", use_tides, & "If true, apply tidal momentum forcing.", default=.false.) call get_param(param_file, mdl, "CALCULATE_SAL", CS%calculate_SAL, & diff --git a/src/core/MOM_continuity_PPM.F90 b/src/core/MOM_continuity_PPM.F90 index ba8c234bc2..cedcdc573b 100644 --- a/src/core/MOM_continuity_PPM.F90 +++ b/src/core/MOM_continuity_PPM.F90 @@ -64,6 +64,9 @@ module MOM_continuity_PPM !! continuity solver for use as the weights in the !! barotropic solver. Otherwise use the transport !! averaged areas. + logical :: visc_rem_hvel_fix = .False. !< If true, thickness at velocity points + !! h_[uv] (used by barotropic solver) is not multiplied + !! by visc_rem_[uv]. end type continuity_PPM_CS !> A container for loop bounds @@ -806,12 +809,22 @@ subroutine zonal_mass_flux(u, h_in, h_W, h_E, uh, dt, G, GV, US, CS, OBC, por_fa endif if (set_BT_cont) then ; if (allocated(BT_cont%h_u)) then - if (present(u_cor)) then - call zonal_flux_thickness(u_cor, h_in, h_W, h_E, BT_cont%h_u, dt, G, GV, US, LB, & - CS%vol_CFL, CS%marginal_faces, OBC, por_face_areaU, visc_rem_u) + if (CS%visc_rem_hvel_fix) then + if (present(u_cor)) then + call zonal_flux_thickness(u_cor, h_in, h_W, h_E, BT_cont%h_u, dt, G, GV, US, LB, & + CS%vol_CFL, CS%marginal_faces, OBC, por_face_areaU) + else + call zonal_flux_thickness(u, h_in, h_W, h_E, BT_cont%h_u, dt, G, GV, US, LB, & + CS%vol_CFL, CS%marginal_faces, OBC, por_face_areaU) + endif else - call zonal_flux_thickness(u, h_in, h_W, h_E, BT_cont%h_u, dt, G, GV, US, LB, & - CS%vol_CFL, CS%marginal_faces, OBC, por_face_areaU, visc_rem_u) + if (present(u_cor)) then + call zonal_flux_thickness(u_cor, h_in, h_W, h_E, BT_cont%h_u, dt, G, GV, US, LB, & + CS%vol_CFL, CS%marginal_faces, OBC, por_face_areaU, visc_rem_u) + else + call zonal_flux_thickness(u, h_in, h_W, h_E, BT_cont%h_u, dt, G, GV, US, LB, & + CS%vol_CFL, CS%marginal_faces, OBC, por_face_areaU, visc_rem_u) + endif endif endif ; endif @@ -1696,12 +1709,22 @@ subroutine meridional_mass_flux(v, h_in, h_S, h_N, vh, dt, G, GV, US, CS, OBC, p endif if (set_BT_cont) then ; if (allocated(BT_cont%h_v)) then - if (present(v_cor)) then - call meridional_flux_thickness(v_cor, h_in, h_S, h_N, BT_cont%h_v, dt, G, GV, US, LB, & - CS%vol_CFL, CS%marginal_faces, OBC, por_face_areaV, visc_rem_v) + if (CS%visc_rem_hvel_fix) then + if (present(v_cor)) then + call meridional_flux_thickness(v_cor, h_in, h_S, h_N, BT_cont%h_v, dt, G, GV, US, LB, & + CS%vol_CFL, CS%marginal_faces, OBC, por_face_areaV) + else + call meridional_flux_thickness(v, h_in, h_S, h_N, BT_cont%h_v, dt, G, GV, US, LB, & + CS%vol_CFL, CS%marginal_faces, OBC, por_face_areaV) + endif else - call meridional_flux_thickness(v, h_in, h_S, h_N, BT_cont%h_v, dt, G, GV, US, LB, & - CS%vol_CFL, CS%marginal_faces, OBC, por_face_areaV, visc_rem_v) + if (present(v_cor)) then + call meridional_flux_thickness(v_cor, h_in, h_S, h_N, BT_cont%h_v, dt, G, GV, US, LB, & + CS%vol_CFL, CS%marginal_faces, OBC, por_face_areaV, visc_rem_v) + else + call meridional_flux_thickness(v, h_in, h_S, h_N, BT_cont%h_v, dt, G, GV, US, LB, & + CS%vol_CFL, CS%marginal_faces, OBC, por_face_areaV, visc_rem_v) + endif endif endif ; endif @@ -2690,6 +2713,7 @@ subroutine continuity_PPM_init(Time, G, GV, US, param_file, diag, CS) !> This include declares and sets the variable "version". # include "version_variable.h" character(len=40) :: mdl = "MOM_continuity_PPM" ! This module's name. + logical :: visc_rem_bug ! Stores the value of runtime paramter VISC_REM_BUG. CS%initialized = .true. @@ -2750,7 +2774,11 @@ subroutine continuity_PPM_init(Time, G, GV, US, param_file, diag, CS) "If true, use the marginal face areas from the continuity "//& "solver for use as the weights in the barotropic solver. "//& "Otherwise use the transport averaged areas.", default=.true.) - + call get_param(param_file, mdl, "VISC_REM_BUG", visc_rem_bug, default=.true., do_not_log=.true.) + call get_param(param_file, mdl, "VISC_REM_CONT_HVEL_FIX", CS%visc_rem_hvel_fix, & + "If true, velocity cell thickness h_[uv] from the continuity solver "//& + "is not multiplied by visc_rem_[uv]. Default of this flag is set by "//& + "VISC_REM_BUG.", default=.not.visc_rem_bug) CS%diag => diag id_clock_reconstruct = cpu_clock_id('(Ocean continuity reconstruction)', grain=CLOCK_ROUTINE) diff --git a/src/core/MOM_dynamics_split_RK2.F90 b/src/core/MOM_dynamics_split_RK2.F90 index b315916ec5..671f707583 100644 --- a/src/core/MOM_dynamics_split_RK2.F90 +++ b/src/core/MOM_dynamics_split_RK2.F90 @@ -177,6 +177,7 @@ module MOM_dynamics_split_RK2 logical :: debug_OBC !< If true, do debugging calls for open boundary conditions. logical :: fpmix = .false. !< If true, applies profiles of momentum flux magnitude and direction. logical :: module_is_initialized = .false. !< Record whether this module has been initialized. + logical :: visc_rem_dt_fix = .false. !@{ Diagnostic IDs integer :: id_uold = -1, id_vold = -1 @@ -725,7 +726,11 @@ subroutine step_MOM_dyn_split_RK2(u_inst, v_inst, h, tv, visc, Time_local, dt, f call start_group_pass(CS%pass_uvp, G%Domain, clock=id_clock_pass) call cpu_clock_begin(id_clock_vertvisc) endif - call vertvisc_remnant(visc, CS%visc_rem_u, CS%visc_rem_v, dt_pred, G, GV, US, CS%vertvisc_CSp) + if (CS%visc_rem_dt_fix) then + call vertvisc_remnant(visc, CS%visc_rem_u, CS%visc_rem_v, dt, G, GV, US, CS%vertvisc_CSp) + else + call vertvisc_remnant(visc, CS%visc_rem_u, CS%visc_rem_v, dt_pred, G, GV, US, CS%vertvisc_CSp) + endif call cpu_clock_end(id_clock_vertvisc) call do_group_pass(CS%pass_visc_rem, G%Domain, clock=id_clock_pass) @@ -739,8 +744,8 @@ subroutine step_MOM_dyn_split_RK2(u_inst, v_inst, h, tv, visc, Time_local, dt, f ! hp = h + dt * div . uh call cpu_clock_begin(id_clock_continuity) call continuity(up, vp, h, hp, uh, vh, dt, G, GV, US, CS%continuity_CSp, CS%OBC, pbv, & - CS%uhbt, CS%vhbt, CS%visc_rem_u, CS%visc_rem_v, & - u_av, v_av, BT_cont=CS%BT_cont) + uhbt=CS%uhbt, vhbt=CS%vhbt, visc_rem_u=CS%visc_rem_u, visc_rem_v=CS%visc_rem_v, & + u_cor=u_av, v_cor=v_av, BT_cont=CS%BT_cont) call cpu_clock_end(id_clock_continuity) if (showCallTree) call callTree_wayPoint("done with continuity (step_MOM_dyn_split_RK2)") @@ -841,7 +846,7 @@ subroutine step_MOM_dyn_split_RK2(u_inst, v_inst, h, tv, visc, Time_local, dt, f ! diffu = horizontal viscosity terms (u_av) call cpu_clock_begin(id_clock_horvisc) - call horizontal_viscosity(u_av, v_av, h_av, CS%diffu, CS%diffv, & + call horizontal_viscosity(u_av, v_av, h_av, uh, vh, CS%diffu, CS%diffv, & MEKE, Varmix, G, GV, US, CS%hor_visc, tv, dt, & OBC=CS%OBC, BT=CS%barotropic_CSp, TD=thickness_diffuse_CSp, & ADp=CS%ADp, hu_cont=CS%BT_cont%h_u, hv_cont=CS%BT_cont%h_v) @@ -994,7 +999,8 @@ subroutine step_MOM_dyn_split_RK2(u_inst, v_inst, h, tv, visc, Time_local, dt, f ! u_av and v_av adjusted so their mass transports match uhbt and vhbt. call cpu_clock_begin(id_clock_continuity) call continuity(u_inst, v_inst, h, h, uh, vh, dt, G, GV, US, CS%continuity_CSp, CS%OBC, pbv, & - CS%uhbt, CS%vhbt, CS%visc_rem_u, CS%visc_rem_v, u_av, v_av) + uhbt=CS%uhbt, vhbt=CS%vhbt, visc_rem_u=CS%visc_rem_u, visc_rem_v=CS%visc_rem_v, & + u_cor=u_av, v_cor=v_av) call cpu_clock_end(id_clock_continuity) call do_group_pass(CS%pass_h, G%Domain, clock=id_clock_pass) ! Whenever thickness changes let the diag manager know, target grids @@ -1347,6 +1353,7 @@ subroutine initialize_dyn_split_RK2(u, v, h, tv, uh, vh, eta, Time, G, GV, US, p type(group_pass_type) :: pass_av_h_uvh logical :: debug_truncations logical :: read_uv, read_h2 + logical :: visc_rem_bug ! Stores the value of runtime paramter VISC_REM_BUG. integer :: i, j, k, is, ie, js, je, isd, ied, jsd, jed, nz integer :: IsdB, IedB, JsdB, JedB @@ -1414,6 +1421,18 @@ subroutine initialize_dyn_split_RK2(u, v, h, tv, uh, vh, eta, Time, G, GV, US, p call get_param(param_file, mdl, "DEBUG_OBC", CS%debug_OBC, default=.false.) call get_param(param_file, mdl, "DEBUG_TRUNCATIONS", debug_truncations, & default=.false.) + call get_param(param_file, mdl, "VISC_REM_BUG", visc_rem_bug, & + "If true, visc_rem_[uv] in split mode is incorrectly calculated or accounted "//& + "for in three places. This parameter controls the defaults of three individual "//& + "flags, VISC_REM_TIMESTEP_FIX in MOM_dynamics_split_RK2(b), "//& + "VISC_REM_BT_WEIGHT_FIX in MOM_barotropic, and VISC_REM_CONT_HVEL_FIX in "//& + "MOM_continuity_PPM. Eventually, the three individual flags should be removed "//& + "after tests and the default of VISC_REM_BUG should be to False.", default=.true.) + call get_param(param_file, mdl, "VISC_REM_TIMESTEP_FIX", CS%visc_rem_dt_fix, & + "If true, use dt rather than dt_pred in vertvisc_remnant() at the end of "//& + "predictor stage for the following continuity() call and btstep() call "//& + "in the corrector step. This flag should be used with "//& + "VISC_REM_BT_WEIGHT_FIX.", default=.not.visc_rem_bug) allocate(CS%taux_bot(IsdB:IedB,jsd:jed), source=0.0) allocate(CS%tauy_bot(isd:ied,JsdB:JedB), source=0.0) @@ -1511,7 +1530,7 @@ subroutine initialize_dyn_split_RK2(u, v, h, tv, uh, vh, eta, Time, G, GV, US, p if (.not. query_initialized(CS%diffu, "diffu", restart_CS) .or. & .not. query_initialized(CS%diffv, "diffv", restart_CS)) then - call horizontal_viscosity(u, v, h, CS%diffu, CS%diffv, MEKE, VarMix, G, GV, US, CS%hor_visc, & + call horizontal_viscosity(u, v, h, uh, vh, CS%diffu, CS%diffv, MEKE, VarMix, G, GV, US, CS%hor_visc, & tv, dt, OBC=CS%OBC, BT=CS%barotropic_CSp, TD=thickness_diffuse_CSp, & hu_cont=CS%BT_cont%h_u, hv_cont=CS%BT_cont%h_v) call set_initialized(CS%diffu, "diffu", restart_CS) diff --git a/src/core/MOM_dynamics_split_RK2b.F90 b/src/core/MOM_dynamics_split_RK2b.F90 index e55e2e3f96..9c5c248c3c 100644 --- a/src/core/MOM_dynamics_split_RK2b.F90 +++ b/src/core/MOM_dynamics_split_RK2b.F90 @@ -174,6 +174,7 @@ module MOM_dynamics_split_RK2b logical :: debug_OBC !< If true, do debugging calls for open boundary conditions. logical :: fpmix = .false. !< If true, applies profiles of momentum flux magnitude and direction. logical :: module_is_initialized = .false. !< Record whether this module has been initialized. + logical :: visc_rem_dt_fix = .false. !@{ Diagnostic IDs ! integer :: id_uold = -1, id_vold = -1 @@ -552,7 +553,7 @@ subroutine step_MOM_dyn_split_RK2b(u_av, v_av, h, tv, visc, Time_local, dt, forc ! diffu = horizontal viscosity terms (u_av) call cpu_clock_begin(id_clock_horvisc) - call horizontal_viscosity(u_av, v_av, h_av, CS%diffu, CS%diffv, MEKE, Varmix, G, GV, US, CS%hor_visc, & + call horizontal_viscosity(u_av, v_av, h_av, uh, vh, CS%diffu, CS%diffv, MEKE, Varmix, G, GV, US, CS%hor_visc, & tv, dt, OBC=CS%OBC, BT=CS%barotropic_CSp, TD=thickness_diffuse_CSp, ADp=CS%AD_pred) call cpu_clock_end(id_clock_horvisc) if (showCallTree) call callTree_wayPoint("done with predictor horizontal_viscosity (step_MOM_dyn_split_RK2b)") @@ -742,7 +743,11 @@ subroutine step_MOM_dyn_split_RK2b(u_av, v_av, h, tv, visc, Time_local, dt, forc call start_group_pass(CS%pass_uvp, G%Domain, clock=id_clock_pass) call cpu_clock_begin(id_clock_vertvisc) endif - call vertvisc_remnant(visc, CS%visc_rem_u, CS%visc_rem_v, dt_pred, G, GV, US, CS%vertvisc_CSp) + if (CS%visc_rem_dt_fix) then + call vertvisc_remnant(visc, CS%visc_rem_u, CS%visc_rem_v, dt, G, GV, US, CS%vertvisc_CSp) + else + call vertvisc_remnant(visc, CS%visc_rem_u, CS%visc_rem_v, dt_pred, G, GV, US, CS%vertvisc_CSp) + endif call cpu_clock_end(id_clock_vertvisc) call do_group_pass(CS%pass_visc_rem, G%Domain, clock=id_clock_pass) @@ -838,8 +843,8 @@ subroutine step_MOM_dyn_split_RK2b(u_av, v_av, h, tv, visc, Time_local, dt, forc ! diffu = horizontal viscosity terms (u_av) call cpu_clock_begin(id_clock_horvisc) - call horizontal_viscosity(u_av, v_av, h_av, CS%diffu, CS%diffv, MEKE, Varmix, G, GV, US, CS%hor_visc, tv, dt, & - OBC=CS%OBC, BT=CS%barotropic_CSp, TD=thickness_diffuse_CSp, ADp=CS%ADp) + call horizontal_viscosity(u_av, v_av, h_av, uh, vh, CS%diffu, CS%diffv, MEKE, Varmix, G, GV, US, CS%hor_visc, & + tv, dt, OBC=CS%OBC, BT=CS%barotropic_CSp, TD=thickness_diffuse_CSp, ADp=CS%ADp) call cpu_clock_end(id_clock_horvisc) if (showCallTree) call callTree_wayPoint("done with horizontal_viscosity (step_MOM_dyn_split_RK2b)") @@ -1272,6 +1277,7 @@ subroutine initialize_dyn_split_RK2b(u, v, h, tv, uh, vh, eta, Time, G, GV, US, character(len=48) :: thickness_units, flux_units, eta_rest_name logical :: debug_truncations logical :: read_uv, read_h2 + logical :: visc_rem_bug ! Stores the value of runtime paramter VISC_REM_BUG. integer :: i, j, k, is, ie, js, je, isd, ied, jsd, jed, nz integer :: IsdB, IedB, JsdB, JedB @@ -1330,6 +1336,18 @@ subroutine initialize_dyn_split_RK2b(u, v, h, tv, uh, vh, eta, Time, G, GV, US, call get_param(param_file, mdl, "DEBUG_OBC", CS%debug_OBC, default=.false.) call get_param(param_file, mdl, "DEBUG_TRUNCATIONS", debug_truncations, & default=.false.) + call get_param(param_file, mdl, "VISC_REM_BUG", visc_rem_bug, & + "If true, visc_rem_[uv] in split mode is incorrectly calculated or accounted "//& + "for in three places. This parameter controls the defaults of three individual "//& + "flags, VISC_REM_TIMESTEP_FIX in MOM_dynamics_split_RK2(b), "//& + "VISC_REM_BT_WEIGHT_FIX in MOM_barotropic, and VISC_REM_CONT_HVEL_FIX in "//& + "MOM_continuity_PPM. Eventually, the three individual flags should be removed "//& + "after tests and the default of VISC_REM_BUG should be to False.", default=.true.) + call get_param(param_file, mdl, "VISC_REM_TIMESTEP_FIX", CS%visc_rem_dt_fix, & + "If true, use dt rather than dt_pred in vertvisc_remnant() at the end of "//& + "predictor stage for the following continuity() call and btstep() call "//& + "in the corrector step. Default of this flag is set by VISC_REM_BUG. "//& + "This flag should be used with VISC_REM_BT_WEIGHT_FIX.", default=.not.visc_rem_bug) allocate(CS%taux_bot(IsdB:IedB,jsd:jed), source=0.0) allocate(CS%tauy_bot(isd:ied,JsdB:JedB), source=0.0) diff --git a/src/core/MOM_dynamics_unsplit.F90 b/src/core/MOM_dynamics_unsplit.F90 index 579ddead2d..72c7dbe6cd 100644 --- a/src/core/MOM_dynamics_unsplit.F90 +++ b/src/core/MOM_dynamics_unsplit.F90 @@ -263,7 +263,7 @@ subroutine step_MOM_dyn_unsplit(u, v, h, tv, visc, Time_local, dt, forces, & ! diffu = horizontal viscosity terms (u,h) call enable_averages(dt, Time_local, CS%diag) call cpu_clock_begin(id_clock_horvisc) - call horizontal_viscosity(u, v, h, CS%diffu, CS%diffv, MEKE, Varmix, G, GV, US, CS%hor_visc, tv, dt) + call horizontal_viscosity(u, v, h, uh, vh, CS%diffu, CS%diffv, MEKE, Varmix, G, GV, US, CS%hor_visc, tv, dt) call cpu_clock_end(id_clock_horvisc) call disable_averaging(CS%diag) diff --git a/src/core/MOM_dynamics_unsplit_RK2.F90 b/src/core/MOM_dynamics_unsplit_RK2.F90 index 65b3bdf50e..cc37f1c2bc 100644 --- a/src/core/MOM_dynamics_unsplit_RK2.F90 +++ b/src/core/MOM_dynamics_unsplit_RK2.F90 @@ -275,7 +275,7 @@ subroutine step_MOM_dyn_unsplit_RK2(u_in, v_in, h_in, tv, visc, Time_local, dt, ! diffu = horizontal viscosity terms (u,h) call enable_averages(dt,Time_local, CS%diag) call cpu_clock_begin(id_clock_horvisc) - call horizontal_viscosity(u_in, v_in, h_in, CS%diffu, CS%diffv, MEKE, VarMix, & + call horizontal_viscosity(u_in, v_in, h_in, uh, vh, CS%diffu, CS%diffv, MEKE, VarMix, & G, GV, US, CS%hor_visc, tv, dt) call cpu_clock_end(id_clock_horvisc) call disable_averaging(CS%diag) diff --git a/src/core/MOM_forcing_type.F90 b/src/core/MOM_forcing_type.F90 index 1d4389c933..4ceb14fe11 100644 --- a/src/core/MOM_forcing_type.F90 +++ b/src/core/MOM_forcing_type.F90 @@ -6,7 +6,7 @@ module MOM_forcing_type use MOM_array_transform, only : rotate_array, rotate_vector, rotate_array_pair use MOM_coupler_types, only : coupler_2d_bc_type, coupler_type_destructor use MOM_coupler_types, only : coupler_type_increment_data, coupler_type_initialized -use MOM_coupler_types, only : coupler_type_copy_data +use MOM_coupler_types, only : coupler_type_copy_data, coupler_type_spawn use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end, CLOCK_ROUTINE use MOM_debugging, only : hchksum, uvchksum use MOM_diag_mediator, only : post_data, register_diag_field, register_scalar_field @@ -2627,7 +2627,7 @@ subroutine forcing_diagnostics(fluxes_in, sfc_state, G_in, US, time_end, diag, h if (turns /= 0) then G => diag%G allocate(fluxes) - call allocate_forcing_type(fluxes_in, G, fluxes) + call allocate_forcing_type(fluxes_in, G, fluxes, turns=turns) call rotate_forcing(fluxes_in, fluxes, turns) else G => G_in @@ -3308,13 +3308,16 @@ subroutine allocate_forcing_by_group(G, fluxes, water, heat, ustar, press, & end subroutine allocate_forcing_by_group !> Allocate elements of a new forcing type based on their status in an existing type. -subroutine allocate_forcing_by_ref(fluxes_ref, G, fluxes) +subroutine allocate_forcing_by_ref(fluxes_ref, G, fluxes, turns) type(forcing), intent(in) :: fluxes_ref !< Reference fluxes type(ocean_grid_type), intent(in) :: G !< Grid metric of target fluxes type(forcing), intent(out) :: fluxes !< Target fluxes + integer, optional, intent(in) :: turns !< If present, the number of counterclockwise + !! quarter turns to use on the new grid. logical :: do_ustar, do_taumag, do_water, do_heat, do_salt, do_press, do_shelf logical :: do_iceberg, do_heat_added, do_buoy + logical :: even_turns ! True if turns is absent or even call get_forcing_groups(fluxes_ref, do_water, do_heat, do_ustar, do_taumag, do_press, & do_shelf, do_iceberg, do_salt, do_heat_added, do_buoy) @@ -3353,6 +3356,19 @@ subroutine allocate_forcing_by_ref(fluxes_ref, G, fluxes) ! This flag would normally be set by a control flag in allocate_forcing_type. ! Here we copy the flag from the reference forcing. fluxes%gustless_accum_bug = fluxes_ref%gustless_accum_bug + + if (coupler_type_initialized(fluxes_ref%tr_fluxes)) then + ! The data fields in the coupler_2d_bc_type are never rotated. + even_turns = .true. ; if (present(turns)) even_turns = (modulo(turns, 2) == 0) + if (even_turns) then + call coupler_type_spawn(fluxes_ref%tr_fluxes, fluxes%tr_fluxes, & + (/G%isc,G%isc,G%iec,G%iec/), (/G%jsc,G%jsc,G%jec,G%jec/)) + else + call coupler_type_spawn(fluxes_ref%tr_fluxes, fluxes%tr_fluxes, & + (/G%jsc,G%jsc,G%jec,G%jec/), (/G%isc,G%isc,G%iec,G%iec/)) + endif + endif + end subroutine allocate_forcing_by_ref diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index 8394735cb9..3674e63c31 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -441,6 +441,7 @@ subroutine open_boundary_config(G, US, param_file, OBC) real :: Lscale_in, Lscale_out ! parameters controlling tracer values at the boundaries [L ~> m] integer :: default_answer_date ! The default setting for the various ANSWER_DATE flags. logical :: check_reconstruction, check_remapping, force_bounds_in_subcell + logical :: om4_remap_via_sub_cells ! If true, use the OM4 remapping algorithm character(len=64) :: remappingScheme ! This include declares and sets the variable "version". # include "version_variable.h" @@ -695,10 +696,15 @@ subroutine open_boundary_config(G, US, param_file, OBC) "that were in use at the end of 2018. Higher values result in the use of more "//& "robust and accurate forms of mathematically equivalent expressions.", & default=default_answer_date) + call get_param(param_file, mdl, "OBC_REMAPPING_USE_OM4_SUBCELLS", om4_remap_via_sub_cells, & + "If true, use the OM4 remapping-via-subcells algorithm for neutral diffusion. "//& + "See REMAPPING_USE_OM4_SUBCELLS for more details. "//& + "We recommend setting this option to false.", default=.true.) allocate(OBC%remap_CS) call initialize_remapping(OBC%remap_CS, remappingScheme, boundary_extrapolation = .false., & check_reconstruction=check_reconstruction, check_remapping=check_remapping, & + om4_remap_via_sub_cells=om4_remap_via_sub_cells, & force_bounds_in_subcell=force_bounds_in_subcell, answer_date=OBC%remap_answer_date) endif ! OBC%number_of_segments > 0 diff --git a/src/core/MOM_variables.F90 b/src/core/MOM_variables.F90 index d5d20f0400..37c1607826 100644 --- a/src/core/MOM_variables.F90 +++ b/src/core/MOM_variables.F90 @@ -339,14 +339,14 @@ module MOM_variables !! the ocean model. Unused fields are unallocated. subroutine allocate_surface_state(sfc_state, G, use_temperature, do_integrals, & gas_fields_ocn, use_meltpot, use_iceshelves, & - omit_frazil) + omit_frazil, sfc_state_in, turns) type(ocean_grid_type), intent(in) :: G !< ocean grid structure type(surface), intent(inout) :: sfc_state !< ocean surface state type to be allocated. logical, optional, intent(in) :: use_temperature !< If true, allocate the space for thermodynamic variables. logical, optional, intent(in) :: do_integrals !< If true, allocate the space for vertically !! integrated fields. type(coupler_1d_bc_type), & - optional, intent(in) :: gas_fields_ocn !< If present, this type describes the ocean + optional, intent(in) :: gas_fields_ocn !< If present, this type describes the !! ocean and surface-ice fields that will participate !! in the calculation of additional gas or other !! tracer fluxes, and can be used to spawn related @@ -356,9 +356,20 @@ subroutine allocate_surface_state(sfc_state, G, use_temperature, do_integrals, & !! under ice shelves. logical, optional, intent(in) :: omit_frazil !< If present and false, do not allocate the space to !! pass frazil fluxes to the coupler + type(surface), & + optional, intent(in) :: sfc_state_in !< If present and its tr_fields are initialized, + !! this type describes the ocean and surface-ice fields that + !! will participate in the calculation of additional gas or + !! other tracer fluxes, and can be used to spawn related + !! internal variables in the ice model. If gas_fields_ocn + !! is present, it is used and tr_fields_in is ignored. + integer, optional, intent(in) :: turns !< If present, the number of counterclockwise quarter + !! turns to use on the new grid. ! local variables logical :: use_temp, alloc_integ, use_melt_potential, alloc_iceshelves, alloc_frazil + logical :: even_turns ! True if turns is absent or even + integer :: tr_field_i_mem(4), tr_field_j_mem(4) integer :: is, ie, js, je, isd, ied, jsd, jed integer :: isdB, iedB, jsdB, jedB @@ -406,9 +417,22 @@ subroutine allocate_surface_state(sfc_state, G, use_temperature, do_integrals, & allocate(sfc_state%tauy_shelf(isd:ied,JsdB:JedB), source=0.0) endif - if (present(gas_fields_ocn)) & + ! The data fields in the coupler_2d_bc_type are never rotated. + even_turns = .true. ; if (present(turns)) even_turns = (modulo(turns, 2) == 0) + if (even_turns) then + tr_field_i_mem(1:4) = (/is,is,ie,ie/) ; tr_field_j_mem(1:4) = (/js,js,je,je/) + else + tr_field_i_mem(1:4) = (/js,js,je,je/) ; tr_field_j_mem(1:4) = (/is,is,ie,ie/) + endif + if (present(gas_fields_ocn)) then call coupler_type_spawn(gas_fields_ocn, sfc_state%tr_fields, & - (/is,is,ie,ie/), (/js,js,je,je/), as_needed=.true.) + tr_field_i_mem, tr_field_j_mem, as_needed=.true.) + elseif (present(sfc_state_in)) then + if (coupler_type_initialized(sfc_state_in%tr_fields)) then + call coupler_type_spawn(sfc_state_in%tr_fields, sfc_state%tr_fields, & + tr_field_i_mem, tr_field_j_mem, as_needed=.true.) + endif + endif sfc_state%arrays_allocated = .true. @@ -439,10 +463,10 @@ end subroutine deallocate_surface_state !> Rotate the surface state fields from the input to the model indices. subroutine rotate_surface_state(sfc_state_in, sfc_state, G, turns) - type(surface), intent(in) :: sfc_state_in - type(surface), intent(inout) :: sfc_state - type(ocean_grid_type), intent(in) :: G - integer, intent(in) :: turns + type(surface), intent(in) :: sfc_state_in !< The input unrotated surface state type that is the data source. + type(surface), intent(inout) :: sfc_state !< The rotated surface state type whose arrays will be filled in + type(ocean_grid_type), intent(in) :: G !< The ocean grid structure + integer, intent(in) :: turns !< The number of counterclockwise quarter turns to use on the rotated grid. logical :: use_temperature, do_integrals, use_melt_potential, use_iceshelves @@ -455,13 +479,9 @@ subroutine rotate_surface_state(sfc_state_in, sfc_state, G, turns) .and. allocated(sfc_state_in%tauy_shelf) if (.not. sfc_state%arrays_allocated) then - call allocate_surface_state(sfc_state, G, & - use_temperature=use_temperature, & - do_integrals=do_integrals, & - use_meltpot=use_melt_potential, & - use_iceshelves=use_iceshelves & - ) - sfc_state%arrays_allocated = .true. + call allocate_surface_state(sfc_state, G, use_temperature=use_temperature, & + do_integrals=do_integrals, use_meltpot=use_melt_potential, & + use_iceshelves=use_iceshelves, sfc_state_in=sfc_state_in, turns=turns) endif if (use_temperature) then diff --git a/src/diagnostics/MOM_diagnostics.F90 b/src/diagnostics/MOM_diagnostics.F90 index fd8057c38f..e5996826e2 100644 --- a/src/diagnostics/MOM_diagnostics.F90 +++ b/src/diagnostics/MOM_diagnostics.F90 @@ -1580,6 +1580,7 @@ subroutine MOM_diagnostics_init(MIS, ADp, CDp, Time, G, GV, US, param_file, diag logical :: better_speed_est ! If true, use a more robust estimate of the first ! mode wave speed as the starting point for iterations. logical :: split ! True if using the barotropic-baroclinic split algorithm + logical :: om4_remap_via_sub_cells ! Use the OM4-era ramap_via_sub_cells for calculating the EBT structure ! This include declares and sets the variable "version". # include "version_variable.h" character(len=40) :: mdl = "MOM_diagnostics" ! This module's name. @@ -1617,6 +1618,10 @@ subroutine MOM_diagnostics_init(MIS, ADp, CDp, Time, G, GV, US, param_file, diag call get_param(param_file, mdl, "INTERNAL_WAVE_SPEED_BETTER_EST", better_speed_est, & "If true, use a more robust estimate of the first mode wave speed as the "//& "starting point for iterations.", default=.true.) + call get_param(param_file, mdl, "INTWAVE_REMAPPING_USE_OM4_SUBCELLS", om4_remap_via_sub_cells, & + "If true, use the OM4 remapping-via-subcells algorithm for calculating EBT structure. "//& + "See REMAPPING_USE_OM4_SUBCELLS for details. "//& + "We recommend setting this option to false.", default=.true.) call get_param(param_file, mdl, "DEFAULT_ANSWER_DATE", default_answer_date, & "This sets the default value for the various _ANSWER_DATE parameters.", & default=99991231) @@ -1858,7 +1863,7 @@ subroutine MOM_diagnostics_init(MIS, ADp, CDp, Time, G, GV, US, param_file, diag (CS%id_cg_ebt>0) .or. (CS%id_Rd_ebt>0) .or. (CS%id_p_ebt>0)) then call wave_speed_init(CS%wave_speed, remap_answer_date=remap_answer_date, & better_speed_est=better_speed_est, min_speed=wave_speed_min, & - wave_speed_tol=wave_speed_tol) + wave_speed_tol=wave_speed_tol, om4_remap_via_sub_cells=om4_remap_via_sub_cells) endif CS%id_mass_wt = register_diag_field('ocean_model', 'mass_wt', diag%axesT1, Time, & diff --git a/src/diagnostics/MOM_wave_speed.F90 b/src/diagnostics/MOM_wave_speed.F90 index 5caf47a51c..8ee271f315 100644 --- a/src/diagnostics/MOM_wave_speed.F90 +++ b/src/diagnostics/MOM_wave_speed.F90 @@ -1611,7 +1611,8 @@ end subroutine tridiag_det !> Initialize control structure for MOM_wave_speed subroutine wave_speed_init(CS, use_ebt_mode, mono_N2_column_fraction, mono_N2_depth, remap_answers_2018, & - remap_answer_date, better_speed_est, min_speed, wave_speed_tol, c1_thresh) + remap_answer_date, better_speed_est, om4_remap_via_sub_cells, & + min_speed, wave_speed_tol, c1_thresh) type(wave_speed_CS), intent(inout) :: CS !< Wave speed control struct logical, optional, intent(in) :: use_ebt_mode !< If true, use the equivalent !! barotropic mode instead of the first baroclinic mode. @@ -1630,6 +1631,8 @@ subroutine wave_speed_init(CS, use_ebt_mode, mono_N2_column_fraction, mono_N2_de !! forms of the same remapping expressions. logical, optional, intent(in) :: better_speed_est !< If true, use a more robust estimate of the first !! mode speed as the starting point for iterations. + logical, optional, intent(in) :: om4_remap_via_sub_cells !< Use the OM4-era ramap_via_sub_cells + !! for calculating the EBT structure real, optional, intent(in) :: min_speed !< If present, set a floor in the first mode speed !! below which 0 is returned [L T-1 ~> m s-1]. real, optional, intent(in) :: wave_speed_tol !< The fractional tolerance for finding the @@ -1656,6 +1659,7 @@ subroutine wave_speed_init(CS, use_ebt_mode, mono_N2_column_fraction, mono_N2_de ! The remap_answers_2018 argument here is irrelevant, because remapping is hard-coded to use PLM. call initialize_remapping(CS%remapping_CS, 'PLM', boundary_extrapolation=.false., & + om4_remap_via_sub_cells=om4_remap_via_sub_cells, & answer_date=CS%remap_answer_date) end subroutine wave_speed_init diff --git a/src/framework/MOM_coms.F90 b/src/framework/MOM_coms.F90 index e7c38d988d..e4f5235da8 100644 --- a/src/framework/MOM_coms.F90 +++ b/src/framework/MOM_coms.F90 @@ -4,6 +4,7 @@ module MOM_coms ! This file is part of MOM6. See LICENSE.md for the license. +use, intrinsic :: iso_fortran_env, only : int64 use MOM_coms_infra, only : PE_here, root_PE, num_PEs, set_rootPE, Set_PElist, Get_PElist use MOM_coms_infra, only : broadcast, field_chksum, MOM_infra_init, MOM_infra_end use MOM_coms_infra, only : sum_across_PEs, max_across_PEs, min_across_PEs @@ -25,7 +26,7 @@ module MOM_coms ! This module provides interfaces to the non-domain-oriented communication subroutines. -integer(kind=8), parameter :: prec=2_8**46 !< The precision of each integer. +integer(kind=int64), parameter :: prec = (2_int64)**46 !< The precision of each integer. real, parameter :: r_prec=2.0**46 !< A real version of prec [nondim]. real, parameter :: I_prec=1.0/(2.0**46) !< The inverse of prec [nondim]. integer, parameter :: max_count_prec=2**(63-46)-1 @@ -73,7 +74,7 @@ module MOM_coms !! Hallberg, R. & A. Adcroft, 2014: An Order-invariant Real-to-Integer Conversion Sum. !! Parallel Computing, 40(5-6), doi:10.1016/j.parco.2014.04.007. type, public :: EFP_type ; private - integer(kind=8), dimension(ni) :: v !< The value in this type + integer(kind=int64), dimension(ni) :: v !< The value in this type end type EFP_type !> Add two extended-fixed-point numbers @@ -115,8 +116,8 @@ function reproducing_EFP_sum_2d(array, isr, ier, jsr, jer, overflow_check, err, ! of real numbers to give order-invariant sums that will reproduce ! across PE count. This idea comes from R. Hallberg and A. Adcroft. - integer(kind=8), dimension(ni) :: ints_sum - integer(kind=8) :: ival, prec_error + integer(kind=int64), dimension(ni) :: ints_sum + integer(kind=int64) :: ival, prec_error real :: rs ! The remaining value to add, in arbitrary units [a] real :: max_mag_term ! A running maximum magnitude of the values in arbitrary units [a] logical :: over_check, do_sum_across_PEs @@ -127,7 +128,7 @@ function reproducing_EFP_sum_2d(array, isr, ier, jsr, jer, overflow_check, err, "reproducing_sum: Too many processors are being used for the value of "//& "prec. Reduce prec to (2^63-1)/num_PEs.") - prec_error = (2_8**62 + (2_8**62 - 1)) / num_PEs() + prec_error = ((2_int64)**62 + ((2_int64)**62 - 1)) / num_PEs() is = 1 ; ie = size(array,1) ; js = 1 ; je = size(array,2 ) if (present(isr)) then @@ -176,7 +177,7 @@ function reproducing_EFP_sum_2d(array, isr, ier, jsr, jer, overflow_check, err, sgn = 1 ; if (array(i,j)<0.0) sgn = -1 rs = abs(array(i,j)) do n=1,ni - ival = int(rs*I_pr(n), 8) + ival = int(rs*I_pr(n), kind=int64) rs = rs - ival*pr(n) ints_sum(n) = ints_sum(n) + sgn*ival enddo @@ -245,8 +246,8 @@ function reproducing_sum_2d(array, isr, ier, jsr, jer, EFP_sum, reproducing, & ! of real numbers to give order-invariant sums that will reproduce ! across PE count. This idea comes from R. Hallberg and A. Adcroft. - integer(kind=8), dimension(ni) :: ints_sum - integer(kind=8) :: prec_error + integer(kind=int64), dimension(ni) :: ints_sum + integer(kind=int64) :: prec_error real :: rsum(1) ! The running sum, in arbitrary units [a] logical :: repro, do_sum_across_PEs character(len=256) :: mesg @@ -257,7 +258,7 @@ function reproducing_sum_2d(array, isr, ier, jsr, jer, EFP_sum, reproducing, & "reproducing_sum: Too many processors are being used for the value of "//& "prec. Reduce prec to (2^63-1)/num_PEs.") - prec_error = (2_8**62 + (2_8**62 - 1)) / num_PEs() + prec_error = ((2_int64)**62 + ((2_int64)**62 - 1)) / num_PEs() is = 1 ; ie = size(array,1) ; js = 1 ; je = size(array,2 ) if (present(isr)) then @@ -349,9 +350,9 @@ function reproducing_sum_3d(array, isr, ier, jsr, jer, sums, EFP_sum, EFP_lay_su real :: val ! The real number that is extracted in arbitrary units [a] real :: max_mag_term ! A running maximum magnitude of the val's in arbitrary units [a] - integer(kind=8), dimension(ni) :: ints_sum - integer(kind=8), dimension(ni,size(array,3)) :: ints_sums - integer(kind=8) :: prec_error + integer(kind=int64), dimension(ni) :: ints_sum + integer(kind=int64), dimension(ni,size(array,3)) :: ints_sums + integer(kind=int64) :: prec_error character(len=256) :: mesg logical :: do_sum_across_PEs integer :: i, j, k, is, ie, js, je, ke, isz, jsz, n @@ -360,7 +361,7 @@ function reproducing_sum_3d(array, isr, ier, jsr, jer, sums, EFP_sum, EFP_lay_su "reproducing_sum: Too many processors are being used for the value of "//& "prec. Reduce prec to (2^63-1)/num_PEs.") - prec_error = (2_8**62 + (2_8**62 - 1)) / num_PEs() + prec_error = ((2_int64)**62 + ((2_int64)**62 - 1)) / num_PEs() max_mag_term = 0.0 is = 1 ; ie = size(array,1) ; js = 1 ; je = size(array,2) ; ke = size(array,3) @@ -508,23 +509,23 @@ end function reproducing_sum_3d !> Convert a real number into the array of integers constitute its extended-fixed-point representation function real_to_ints(r, prec_error, overflow) result(ints) real, intent(in) :: r !< The real number being converted in arbitrary units [a] - integer(kind=8), optional, intent(in) :: prec_error !< The PE-count dependent precision of the + integer(kind=int64), optional, intent(in) :: prec_error !< The PE-count dependent precision of the !! integers that is safe from overflows during global !! sums. This will be larger than the compile-time !! precision parameter, and is used to detect overflows. logical, optional, intent(inout) :: overflow !< Returns true if the conversion is being !! done on a value that is too large to be represented - integer(kind=8), dimension(ni) :: ints + integer(kind=int64), dimension(ni) :: ints ! This subroutine converts a real number to an equivalent representation ! using several long integers. real :: rs ! The remaining value to add, in arbitrary units [a] character(len=80) :: mesg - integer(kind=8) :: ival, prec_err + integer(kind=int64) :: ival, prec_err integer :: sgn, i prec_err = prec ; if (present(prec_error)) prec_err = prec_error - ints(:) = 0_8 + ints(:) = 0 if ((r >= 1e30) .eqv. (r < 1e30)) then ; NaN_error = .true. ; return ; endif sgn = 1 ; if (r<0.0) sgn = -1 @@ -539,7 +540,7 @@ function real_to_ints(r, prec_error, overflow) result(ints) endif do i=1,ni - ival = int(rs*I_pr(i), 8) + ival = int(rs*I_pr(i), kind=int64) rs = rs - ival*pr(i) ints(i) = sgn*ival enddo @@ -549,7 +550,7 @@ end function real_to_ints !> Convert the array of integers that constitute an extended-fixed-point !! representation into a real number function ints_to_real(ints) result(r) - integer(kind=8), dimension(ni), intent(in) :: ints !< The array of EFP integers + integer(kind=int64), dimension(ni), intent(in) :: ints !< The array of EFP integers real :: r ! The real number that is extracted in arbitrary units [a] ! This subroutine reverses the conversion in real_to_ints. @@ -562,9 +563,9 @@ end function ints_to_real !> Increment an array of integers that constitutes an extended-fixed-point !! representation with a another EFP number subroutine increment_ints(int_sum, int2, prec_error) - integer(kind=8), dimension(ni), intent(inout) :: int_sum !< The array of EFP integers being incremented - integer(kind=8), dimension(ni), intent(in) :: int2 !< The array of EFP integers being added - integer(kind=8), optional, intent(in) :: prec_error !< The PE-count dependent precision of the + integer(kind=int64), dimension(ni), intent(inout) :: int_sum !< The array of EFP integers being incremented + integer(kind=int64), dimension(ni), intent(in) :: int2 !< The array of EFP integers being added + integer(kind=int64), optional, intent(in) :: prec_error !< The PE-count dependent precision of the !! integers that is safe from overflows during global !! sums. This will be larger than the compile-time !! precision parameter, and is used to detect overflows. @@ -596,7 +597,7 @@ end subroutine increment_ints !> Increment an EFP number with a real number without doing any carrying of !! of overflows and using only minimal error checking. subroutine increment_ints_faster(int_sum, r, max_mag_term) - integer(kind=8), dimension(ni), intent(inout) :: int_sum !< The array of EFP integers being incremented + integer(kind=int64), dimension(ni), intent(inout) :: int_sum !< The array of EFP integers being incremented real, intent(in) :: r !< The real number being added in arbitrary units [a] real, intent(inout) :: max_mag_term !< A running maximum magnitude of the r's !! in arbitrary units [a] @@ -605,7 +606,7 @@ subroutine increment_ints_faster(int_sum, r, max_mag_term) ! representation in real_to_ints, but without doing any carrying of overflow. ! The entire operation is embedded in a single call for greater speed. real :: rs ! The remaining value to add, in arbitrary units [a] - integer(kind=8) :: ival + integer(kind=int64) :: ival integer :: sgn, i if ((r >= 1e30) .eqv. (r < 1e30)) then ; NaN_error = .true. ; return ; endif @@ -620,7 +621,7 @@ subroutine increment_ints_faster(int_sum, r, max_mag_term) endif do i=1,ni - ival = int(rs*I_pr(i), 8) + ival = int(rs*I_pr(i), kind=int64) rs = rs - ival*pr(i) int_sum(i) = int_sum(i) + sgn*ival enddo @@ -629,9 +630,9 @@ end subroutine increment_ints_faster !> This subroutine handles carrying of the overflow. subroutine carry_overflow(int_sum, prec_error) - integer(kind=8), dimension(ni), intent(inout) :: int_sum !< The array of EFP integers being + integer(kind=int64), dimension(ni), intent(inout) :: int_sum !< The array of EFP integers being !! modified by carries, but without changing value. - integer(kind=8), intent(in) :: prec_error !< The PE-count dependent precision of the + integer(kind=int64), intent(in) :: prec_error !< The PE-count dependent precision of the !! integers that is safe from overflows during global !! sums. This will be larger than the compile-time !! precision parameter, and is used to detect overflows. @@ -653,7 +654,7 @@ end subroutine carry_overflow !> This subroutine carries the overflow, and then makes sure that !! all integers are of the same sign as the overall value. subroutine regularize_ints(int_sum) - integer(kind=8), dimension(ni), & + integer(kind=int64), dimension(ni), & intent(inout) :: int_sum !< The array of integers being modified to take a !! regular form with all integers of the same sign, !! but without changing value. @@ -799,8 +800,8 @@ subroutine EFP_list_sum_across_PEs(EFPs, nval, errors) ! This subroutine does a sum across PEs of a list of EFP variables, ! returning the sums in place, with all overflows carried. - integer(kind=8), dimension(ni,nval) :: ints - integer(kind=8) :: prec_error + integer(kind=int64), dimension(ni,nval) :: ints + integer(kind=int64) :: prec_error logical :: error_found character(len=256) :: mesg integer :: i, n @@ -809,7 +810,7 @@ subroutine EFP_list_sum_across_PEs(EFPs, nval, errors) "reproducing_sum: Too many processors are being used for the value of "//& "prec. Reduce prec to (2^63-1)/num_PEs.") - prec_error = (2_8**62 + (2_8**62 - 1)) / num_PEs() + prec_error = ((2_int64)**62 + ((2_int64)**62 - 1)) / num_PEs() ! overflow_error is an overflow error flag for the whole module. overflow_error = .false. ; error_found = .false. @@ -846,8 +847,8 @@ subroutine EFP_val_sum_across_PEs(EFP, error) ! This subroutine does a sum across PEs of a list of EFP variables, ! returning the sums in place, with all overflows carried. - integer(kind=8), dimension(ni) :: ints - integer(kind=8) :: prec_error + integer(kind=int64), dimension(ni) :: ints + integer(kind=int64) :: prec_error logical :: error_found character(len=256) :: mesg integer :: n @@ -856,7 +857,7 @@ subroutine EFP_val_sum_across_PEs(EFP, error) "reproducing_sum: Too many processors are being used for the value of "//& "prec. Reduce prec to (2^63-1)/num_PEs.") - prec_error = (2_8**62 + (2_8**62 - 1)) / num_PEs() + prec_error = ((2_int64)**62 + ((2_int64)**62 - 1)) / num_PEs() ! overflow_error is an overflow error flag for the whole module. overflow_error = .false. ; error_found = .false. diff --git a/src/framework/MOM_coupler_types.F90 b/src/framework/MOM_coupler_types.F90 index 1baef24f76..b931a2ddd2 100644 --- a/src/framework/MOM_coupler_types.F90 +++ b/src/framework/MOM_coupler_types.F90 @@ -3,6 +3,7 @@ module MOM_coupler_types ! This file is part of MOM6. See LICENSE.md for the license. +use MOM_array_transform, only : allocate_rotated_array, rotate_array use MOM_couplertype_infra, only : CT_spawn, CT_initialized, CT_destructor, atmos_ocn_coupler_flux use MOM_couplertype_infra, only : CT_set_diags, CT_send_data, CT_write_chksums, CT_data_override use MOM_couplertype_infra, only : CT_copy_data, CT_increment_data, CT_rescale_data @@ -363,7 +364,7 @@ end subroutine coupler_type_data_override !> Extract a 2d field from a coupler_2d_bc_type into a two-dimensional array, using a !! MOM-specific interface. subroutine extract_coupler_type_data(var_in, bc_index, array_out, scale_factor, & - halo_size, idim, jdim, field_index) + halo_size, idim, jdim, field_index, turns) type(coupler_2d_bc_type), intent(in) :: var_in !< BC_type structure with the data to extract !! The internal data has arbitrary units [B]. integer, intent(in) :: bc_index !< The index of the boundary condition @@ -384,13 +385,35 @@ subroutine extract_coupler_type_data(var_in, bc_index, array_out, scale_factor, integer, optional, intent(in) :: field_index !< The index of the field in the boundary !! condition that is being copied, or the !! surface flux by default. - - if (present(field_index)) then - call CT_extract_data(var_in, bc_index, field_index, array_out, & + integer, optional, intent(in) :: turns !< The number of quarter-turns from the unrotated + !! coupler_2d_bt_type to model grid + + ! Local variables + real, allocatable :: array_unrot(:,:) ! Array on the unrotated grid in arbitrary units [A] + integer :: q_turns ! The number of quarter turns through which array_out is to be rotated + integer :: index, is, ie, js, je, halo + + index = ind_flux ; if (present(field_index)) index = field_index + q_turns = 0 ; if (present(turns)) q_turns = modulo(turns, 4) + halo = 0 ; if (present(halo_size)) halo = halo_size + + ! The case with non-trivial grid rotation is complicated by the fact that the data fields + ! in the coupler_2d_bc_type are never rotated, so they need to be handled separately. + if (q_turns == 0) then + call CT_extract_data(var_in, bc_index, index, array_out, & scale_factor=scale_factor, halo_size=halo_size, idim=idim, jdim=jdim) + elseif (present(idim) .and. present(jdim)) then + ! Work only on the computational domain plus symmetric halos. + is = idim(2)-halo ; ie = idim(3)+halo ; js = jdim(2)-halo ; je = jdim(3)+halo + call allocate_rotated_array(array_out(is:ie,js:je), [1,1], -q_turns, array_unrot) + call CT_extract_data(var_in, bc_index, index, array_unrot, scale_factor=scale_factor, halo_size=halo) + call rotate_array(array_unrot, q_turns, array_out(is:ie,js:je)) + deallocate(array_unrot) else - call CT_extract_data(var_in, bc_index, ind_flux, array_out, & - scale_factor=scale_factor, halo_size=halo_size, idim=idim, jdim=jdim) + call allocate_rotated_array(array_out, [1,1], -q_turns, array_unrot) + call CT_extract_data(var_in, bc_index, index, array_unrot, scale_factor=scale_factor, halo_size=halo) + call rotate_array(array_unrot, q_turns, array_out) + deallocate(array_unrot) endif end subroutine extract_coupler_type_data @@ -398,7 +421,7 @@ end subroutine extract_coupler_type_data !> Set single 2d field in coupler_2d_bc_type from a two-dimensional array, using a !! MOM-specific interface. subroutine set_coupler_type_data(array_in, bc_index, var, solubility, scale_factor, & - halo_size, idim, jdim, field_index) + halo_size, idim, jdim, field_index, turns) real, dimension(1:,1:), intent(in) :: array_in !< The source array for the field in !! arbitrary units [A]; the size of this array !! must match the size of the data being copied @@ -422,15 +445,43 @@ subroutine set_coupler_type_data(array_in, bc_index, var, solubility, scale_fact integer, optional, intent(in) :: field_index !< The index of the field in the !! boundary condition that is being set. The !! surface concentration is set by default. + integer, optional, intent(in) :: turns !< The number of quarter-turns from the unrotated + !! coupler_2d_bt_type to model grid + ! Local variables + real, allocatable :: array_unrot(:,:) ! Array on the unrotated grid in the same arbitrary units + ! as array_in [A] integer :: subfield ! An integer indicating which field to set. + integer :: q_turns ! The number of quarter turns through which array_in is rotated + integer :: is, ie, js, je, halo + + q_turns = 0 ; if (present(turns)) q_turns = modulo(turns, 4) subfield = ind_csurf if (present(solubility)) then ; if (solubility) subfield = ind_alpha ; endif if (present(field_index)) subfield = field_index - - call CT_set_data(array_in, bc_index, subfield, var, & - scale_factor=scale_factor, halo_size=halo_size, idim=idim, jdim=jdim) + halo = 0 ; if (present(halo_size)) halo = halo_size + + ! The case with non-trivial grid rotation is complicated by the fact that the data fields + ! in the coupler_2d_bc_type are never rotated, so they need to be handled separately. + if (q_turns == 0) then + call CT_set_data(array_in, bc_index, subfield, var, & + scale_factor=scale_factor, halo_size=halo_size, idim=idim, jdim=jdim) + elseif (present(idim) .and. present(jdim)) then + ! Work only on the computational domain plus symmetric halos. + is = idim(2)-halo ; ie = idim(3)+halo ; js = jdim(2)-halo ; je = jdim(3)+halo + call allocate_rotated_array(array_in(is:ie,js:je), [1,1], -q_turns, array_unrot) + call rotate_array(array_in, -q_turns, array_unrot) + call CT_set_data(array_unrot, bc_index, subfield, var, & + scale_factor=scale_factor, halo_size=halo_size) + deallocate(array_unrot) + else + call allocate_rotated_array(array_in, [1,1], -q_turns, array_unrot) + call rotate_array(array_in, -q_turns, array_unrot) + call CT_set_data(array_in, bc_index, subfield, var, & + scale_factor=scale_factor, halo_size=halo_size) + deallocate(array_unrot) + endif end subroutine set_coupler_type_data diff --git a/src/framework/MOM_diag_mediator.F90 b/src/framework/MOM_diag_mediator.F90 index b3194af3d8..541e349d29 100644 --- a/src/framework/MOM_diag_mediator.F90 +++ b/src/framework/MOM_diag_mediator.F90 @@ -3251,6 +3251,7 @@ subroutine diag_mediator_init(G, GV, US, nz, param_file, diag_cs, doc_file_dir) ! answers from 2018, while higher values use more robust ! forms of the same remapping expressions. integer :: default_answer_date ! The default setting for the various ANSWER_DATE flags. + logical :: om4_remap_via_sub_cells ! Use the OM4-era ramap_via_sub_cells for diagnostics character(len=8) :: this_pe character(len=240) :: doc_file, doc_file_dflt, doc_path character(len=240), allocatable :: diag_coords(:) @@ -3282,6 +3283,10 @@ subroutine diag_mediator_init(G, GV, US, nz, param_file, diag_cs, doc_file_dir) call get_param(param_file, mdl, "DEFAULT_ANSWER_DATE", default_answer_date, & "This sets the default value for the various _ANSWER_DATE parameters.", & default=99991231) + call get_param(param_file, mdl, "DIAG_REMAPPING_USE_OM4_SUBCELLS", om4_remap_via_sub_cells, & + "If true, use the OM4 remapping-via-subcells algorithm for diagnostics. "//& + "See REMAPPING_USE_OM4_SUBCELLS for details. "//& + "We recommend setting this option to false.", default=.true.) call get_param(param_file, mdl, "REMAPPING_ANSWER_DATE", remap_answer_date, & "The vintage of the expressions and order of arithmetic to use for remapping. "//& "Values below 20190101 result in the use of older, less accurate expressions "//& @@ -3311,7 +3316,7 @@ subroutine diag_mediator_init(G, GV, US, nz, param_file, diag_cs, doc_file_dir) allocate(diag_cs%diag_remap_cs(diag_cs%num_diag_coords)) ! Initialize each diagnostic vertical coordinate do i=1, diag_cs%num_diag_coords - call diag_remap_init(diag_cs%diag_remap_cs(i), diag_coords(i), answer_date=remap_answer_date, GV=GV) + call diag_remap_init(diag_cs%diag_remap_cs(i), diag_coords(i), om4_remap_via_sub_cells, remap_answer_date, GV) enddo deallocate(diag_coords) endif diff --git a/src/framework/MOM_diag_remap.F90 b/src/framework/MOM_diag_remap.F90 index bbefa3808b..e8e6a756e9 100644 --- a/src/framework/MOM_diag_remap.F90 +++ b/src/framework/MOM_diag_remap.F90 @@ -92,6 +92,7 @@ module MOM_diag_remap !! vertical extents in [Z ~> m] for remapping extensive variables integer :: interface_axes_id = 0 !< Vertical axes id for remapping at interfaces integer :: layer_axes_id = 0 !< Vertical axes id for remapping on layers + logical :: om4_remap_via_sub_cells !< Use the OM4-era ramap_via_sub_cells integer :: answer_date !< The vintage of the order of arithmetic and expressions !! to use for remapping. Values below 20190101 recover !! the answers from 2018, while higher values use more @@ -102,10 +103,11 @@ module MOM_diag_remap contains !> Initialize a diagnostic remapping type with the given vertical coordinate. -subroutine diag_remap_init(remap_cs, coord_tuple, answer_date, GV) +subroutine diag_remap_init(remap_cs, coord_tuple, om4_remap_via_sub_cells, answer_date, GV) type(diag_remap_ctrl), intent(inout) :: remap_cs !< Diag remapping control structure character(len=*), intent(in) :: coord_tuple !< A string in form of !! MODULE_SUFFIX PARAMETER_SUFFIX COORDINATE_NAME + logical, intent(in) :: om4_remap_via_sub_cells !< Use the OM4-era ramap_via_sub_cells integer, intent(in) :: answer_date !< The vintage of the order of arithmetic and expressions !! to use for remapping. Values below 20190101 recover !! the answers from 2018, while higher values use more @@ -127,6 +129,7 @@ subroutine diag_remap_init(remap_cs, coord_tuple, answer_date, GV) remap_cs%configured = .false. remap_cs%initialized = .false. remap_cs%used = .false. + remap_cs%om4_remap_via_sub_cells = om4_remap_via_sub_cells remap_cs%answer_date = answer_date remap_cs%nz = 0 @@ -309,6 +312,7 @@ subroutine diag_remap_update(remap_cs, G, GV, US, h, T, S, eqn_of_state, h_targe if (.not. remap_cs%initialized) then ! Initialize remapping and regridding on the first call call initialize_remapping(remap_cs%remap_cs, 'PPM_IH4', boundary_extrapolation=.false., & + om4_remap_via_sub_cells=remap_cs%om4_remap_via_sub_cells, & answer_date=remap_cs%answer_date) remap_cs%initialized = .true. endif diff --git a/src/framework/MOM_horizontal_regridding.F90 b/src/framework/MOM_horizontal_regridding.F90 index 1d5eab106d..719eb7d9e4 100644 --- a/src/framework/MOM_horizontal_regridding.F90 +++ b/src/framework/MOM_horizontal_regridding.F90 @@ -44,14 +44,15 @@ module MOM_horizontal_regridding contains !> Write to the terminal some basic statistics about the k-th level of an array -subroutine myStats(array, missing, G, k, mesg, scale, full_halo) +subroutine myStats(array, missing, G, k, mesg, unscale, full_halo) type(ocean_grid_type), intent(in) :: G !< Ocean grid type real, dimension(SZI_(G),SZJ_(G)), & intent(in) :: array !< input array in arbitrary units [A ~> a] real, intent(in) :: missing !< missing value in arbitrary units [A ~> a] integer, intent(in) :: k !< Level to calculate statistics for character(len=*), intent(in) :: mesg !< Label to use in message - real, optional, intent(in) :: scale !< A scaling factor for output [a A-1 ~> 1] + real, optional, intent(in) :: unscale !< A scaling factor for output that countacts + !! any internal dimesional scaling [a A-1 ~> 1] logical, optional, intent(in) :: full_halo !< If present and true, test values on the whole !! array rather than just the computational domain. ! Local variables @@ -62,7 +63,7 @@ subroutine myStats(array, missing, G, k, mesg, scale, full_halo) logical :: found character(len=120) :: lMesg - scl = 1.0 ; if (present(scale)) scl = scale + scl = 1.0 ; if (present(unscale)) scl = unscale minA = 9.E24 / scl ; maxA = -9.E24 / scl ; found = .false. is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec @@ -557,7 +558,7 @@ subroutine horiz_interp_and_extrap_tracer_record(filename, varnam, recnum, G, tr endif if (debug) then - call myStats(tr_inp, missing_value, G, k, 'Tracer from file', scale=I_scale, full_halo=.true.) + call myStats(tr_inp, missing_value, G, k, 'Tracer from file', unscale=I_scale, full_halo=.true.) endif call run_horiz_interp(Interp, tr_inp, tr_out(is:ie,js:je), missing_value=missing_value) @@ -585,7 +586,7 @@ subroutine horiz_interp_and_extrap_tracer_record(filename, varnam, recnum, G, tr call pass_var(good, G%Domain) if (debug) then - call myStats(tr_out, missing_value, G, k, 'variable from horiz_interp()', scale=I_scale) + call myStats(tr_out, missing_value, G, k, 'variable from horiz_interp()', unscale=I_scale) endif ! Horizontally homogenize data to produce perfectly "flat" initial conditions @@ -602,7 +603,7 @@ subroutine horiz_interp_and_extrap_tracer_record(filename, varnam, recnum, G, tr call fill_miss_2d(tr_outf, good2, fill2, tr_prev, G, dtr_iter_stop, answer_date=ans_date) if (debug) then - call myStats(tr_outf, missing_value, G, k, 'field from fill_miss_2d()', scale=I_scale) + call myStats(tr_outf, missing_value, G, k, 'field from fill_miss_2d()', unscale=I_scale) endif tr_z(:,:,k) = tr_outf(:,:) * G%mask2dT(:,:) @@ -874,7 +875,7 @@ subroutine horiz_interp_and_extrap_tracer_fms_id(field, Time, G, tr_z, mask_z, & endif if (debug) then - call myStats(tr_inp, missing_value, G, k, 'Tracer from file', scale=I_scale, full_halo=.true.) + call myStats(tr_inp, missing_value, G, k, 'Tracer from file', unscale=I_scale, full_halo=.true.) endif tr_out(:,:) = 0.0 @@ -902,7 +903,7 @@ subroutine horiz_interp_and_extrap_tracer_fms_id(field, Time, G, tr_z, mask_z, & call pass_var(good, G%Domain) if (debug) then - call myStats(tr_out, missing_value, G, k, 'variable from horiz_interp()', scale=I_scale) + call myStats(tr_out, missing_value, G, k, 'variable from horiz_interp()', unscale=I_scale) endif ! Horizontally homogenize data to produce perfectly "flat" initial conditions @@ -921,7 +922,7 @@ subroutine horiz_interp_and_extrap_tracer_fms_id(field, Time, G, tr_z, mask_z, & ! if (debug) then ! call hchksum(tr_outf, 'field from fill_miss_2d ', G%HI, scale=I_scale) -! call myStats(tr_outf, missing_value, G, k, 'field from fill_miss_2d()', scale=I_scale) +! call myStats(tr_outf, missing_value, G, k, 'field from fill_miss_2d()', unscale=I_scale) ! endif tr_z(:,:,k) = tr_outf(:,:) * G%mask2dT(:,:) diff --git a/src/framework/MOM_intrinsic_functions.F90 b/src/framework/MOM_intrinsic_functions.F90 index 3fd9ace1ad..fdafa8503d 100644 --- a/src/framework/MOM_intrinsic_functions.F90 +++ b/src/framework/MOM_intrinsic_functions.F90 @@ -176,7 +176,7 @@ pure function descale(x, e_a, s_a) result(a) ! Biased exponent of x ! Apply the corrected exponent and sign to x. - xb = transfer(x, 1_8) + xb = transfer(x, 1_int64) e_x = ibits(xb, expbit, explen) call mvbits(e_a + e_x, 0, explen, xb, expbit) call mvbits(s_a, 0, 1, xb, signbit) diff --git a/src/framework/MOM_restart.F90 b/src/framework/MOM_restart.F90 index 06f4abc065..44dee97a76 100644 --- a/src/framework/MOM_restart.F90 +++ b/src/framework/MOM_restart.F90 @@ -3,6 +3,7 @@ module MOM_restart ! This file is part of MOM6. See LICENSE.md for the license. +use, intrinsic :: iso_fortran_env, only : int64 use MOM_checksums, only : chksum => rotated_field_chksum use MOM_domains, only : PE_here, num_PEs, AGRID, BGRID_NE, CGRID_NE use MOM_error_handler, only : MOM_error, FATAL, WARNING, NOTE, is_root_pe @@ -1348,12 +1349,12 @@ subroutine save_restart(directory, time, G, CS, time_stamped, filename, GV, num_ character(len=256) :: restartname ! The restart file name (no dir). character(len=8) :: suffix ! A suffix (like _2) that is appended ! to the name of files after the first. - integer(kind=8) :: var_sz, size_in_file ! The size in bytes of each variable + integer(kind=int64) :: var_sz, size_in_file ! The size in bytes of each variable ! and the variables already in a file. - integer(kind=8), parameter :: max_file_size = 4294967292_8 ! The maximum size in bytes for the + integer(kind=int64), parameter :: max_file_size = 4294967292_int64 ! The maximum size in bytes for the ! starting position of each variable in a file's record, ! based on the use of NetCDF 3.6 or later. For earlier - ! versions of NetCDF, the value was 2147483647_8. + ! versions of NetCDF, the value was 2147483647_int64. integer :: start_var, next_var ! The starting variables of the ! current and next files. type(MOM_infra_file) :: IO_handle ! The I/O handle of the open fileset @@ -1365,7 +1366,7 @@ subroutine save_restart(directory, time, G, CS, time_stamped, filename, GV, num_ real :: restart_time ! The model time at whic the restart file is being written [days] character(len=32) :: filename_appendix = '' ! Appendix to filename for ensemble runs integer :: length ! The length of a text string. - integer(kind=8) :: check_val(CS%max_fields,1) + integer(kind=int64) :: check_val(CS%max_fields,1) integer :: isL, ieL, jsL, jeL, pos integer :: turns integer, parameter :: nmax_extradims = 5 @@ -1570,8 +1571,8 @@ subroutine restore_state(filename, directory, day, G, CS) real, allocatable :: time_vals(:) ! Times from a file extracted with getl_file_times [days] type(MOM_field), allocatable :: fields(:) logical :: is_there_a_checksum ! Is there a valid checksum that should be checked. - integer(kind=8) :: checksum_file ! The checksum value recorded in the input file. - integer(kind=8) :: checksum_data ! The checksum value for the data that was read in. + integer(kind=int64) :: checksum_file ! The checksum value recorded in the input file. + integer(kind=int64) :: checksum_data ! The checksum value for the data that was read in. if (.not.CS%initialized) call MOM_error(FATAL, "MOM_restart " // & "restore_state: Module must be initialized before it is used.") @@ -2182,7 +2183,7 @@ function get_variable_byte_size(hor_grid, z_grid, t_grid, G, num_z) result(var_s character(len=8), intent(in) :: t_grid !< A time string to interpret type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure integer, intent(in) :: num_z !< The number of vertical layers in the grid - integer(kind=8) :: var_sz !< The function result, the size in bytes of a variable + integer(kind=int64) :: var_sz !< The function result, the size in bytes of a variable ! Local variables integer :: var_periods ! The number of entries in a time-periodic axis diff --git a/src/ice_shelf/MOM_ice_shelf.F90 b/src/ice_shelf/MOM_ice_shelf.F90 index 05c70a0ea1..a4b06b6150 100644 --- a/src/ice_shelf/MOM_ice_shelf.F90 +++ b/src/ice_shelf/MOM_ice_shelf.F90 @@ -41,9 +41,9 @@ module MOM_ice_shelf use MOM_transcribe_grid, only : copy_dyngrid_to_MOM_grid, copy_MOM_grid_to_dyngrid use MOM_transcribe_grid, only : rotate_dyngrid use MOM_unit_scaling, only : unit_scale_type, unit_scaling_init, fix_restart_unit_scaling -use MOM_variables, only : surface, allocate_surface_state +use MOM_variables, only : surface, allocate_surface_state, deallocate_surface_state use MOM_variables, only : rotate_surface_state -use MOM_forcing_type, only : forcing, allocate_forcing_type, MOM_forcing_chksum +use MOM_forcing_type, only : forcing, allocate_forcing_type, deallocate_forcing_type, MOM_forcing_chksum use MOM_forcing_type, only : mech_forcing, allocate_mech_forcing, MOM_mech_forcing_chksum use MOM_forcing_type, only : copy_common_forcing_fields, rotate_forcing, rotate_mech_forcing use MOM_get_input, only : directories, Get_MOM_input @@ -378,7 +378,7 @@ subroutine shelf_calc_flux(sfc_state_in, fluxes_in, Time, time_step_in, CS) allocate(sfc_state) call rotate_surface_state(sfc_state_in, sfc_state, CS%Grid, CS%turns) allocate(fluxes) - call allocate_forcing_type(fluxes_in, G, fluxes) + call allocate_forcing_type(fluxes_in, G, fluxes, turns=CS%turns) call rotate_forcing(fluxes_in, fluxes, CS%turns) else sfc_state => sfc_state_in @@ -916,14 +916,17 @@ subroutine shelf_calc_flux(sfc_state_in, fluxes_in, Time, time_step_in, CS) call cpu_clock_end(id_clock_shelf) + if (CS%debug) call MOM_forcing_chksum("End of shelf calc flux", fluxes, G, CS%US, haloshift=0) + if (CS%rotate_index) then ! call rotate_surface_state(sfc_state, sfc_state_in, CS%Grid_in, -CS%turns) - call rotate_forcing(fluxes,fluxes_in,-CS%turns) + call rotate_forcing(fluxes, fluxes_in, -CS%turns) + call deallocate_surface_state(sfc_state) + deallocate(sfc_state) + call deallocate_forcing_type(fluxes) + deallocate(fluxes) endif - - if (CS%debug) call MOM_forcing_chksum("End of shelf calc flux", fluxes, G, CS%US, haloshift=0) - end subroutine shelf_calc_flux subroutine integrate_over_ice_sheet_area(G, ISS, var, var_scale, var_out) @@ -1723,14 +1726,14 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, Time_init, "buoyancy iteration.", units="nondim", default=1.0e-4) if (PRESENT(sfc_state_in)) then - allocate(sfc_state) ! assuming frazil is enabled in ocean. This could break some configurations? call allocate_surface_state(sfc_state_in, CS%Grid_in, use_temperature=.true., & do_integrals=.true., omit_frazil=.false., use_iceshelves=.true.) if (CS%rotate_index) then - call rotate_surface_state(sfc_state_in, sfc_state,CS%Grid, CS%turns) + allocate(sfc_state) + call rotate_surface_state(sfc_state_in, sfc_state, CS%Grid, CS%turns) else - sfc_state=>sfc_state_in + sfc_state => sfc_state_in endif endif @@ -2103,14 +2106,14 @@ subroutine initialize_ice_shelf_fluxes(CS, ocn_grid, US, fluxes_in) else call MOM_mesg("MOM_ice_shelf.F90, initialize_ice_shelf: allocating fluxes in solo mode.") call allocate_forcing_type(CS%Grid_in, fluxes_in, ustar=.true., shelf=.true., & - press=.true., shelf_sfc_accumulation = CS%active_shelf_dynamics, tau_mag=.true.) + press=.true., shelf_sfc_accumulation=CS%active_shelf_dynamics, tau_mag=.true.) endif if (CS%rotate_index) then allocate(fluxes) - call allocate_forcing_type(fluxes_in, CS%Grid, fluxes) + call allocate_forcing_type(fluxes_in, CS%Grid, fluxes, turns=CS%turns) call rotate_forcing(fluxes_in, fluxes, CS%turns) else - fluxes=>fluxes_in + fluxes => fluxes_in endif do j=jsd,jed ; do i=isd,ied @@ -2119,8 +2122,11 @@ subroutine initialize_ice_shelf_fluxes(CS, ocn_grid, US, fluxes_in) if (CS%debug) call hchksum(fluxes%frac_shelf_h, "IS init: frac_shelf_h", G%HI, haloshift=0) call add_shelf_pressure(ocn_grid, US, CS, fluxes) - if (CS%rotate_index) & + if (CS%rotate_index) then call rotate_forcing(fluxes, fluxes_in, -CS%turns) + call deallocate_forcing_type(fluxes) + deallocate(fluxes) + endif end subroutine initialize_ice_shelf_fluxes diff --git a/src/initialization/MOM_state_initialization.F90 b/src/initialization/MOM_state_initialization.F90 index c18752c83d..3e71a98f55 100644 --- a/src/initialization/MOM_state_initialization.F90 +++ b/src/initialization/MOM_state_initialization.F90 @@ -2504,6 +2504,7 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, depth_tot, G, GV, US, PF, just character(len=64) :: remappingScheme real :: tempAvg ! Spatially averaged temperatures on a layer [C ~> degC] real :: saltAvg ! Spatially averaged salinities on a layer [S ~> ppt] + logical :: om4_remap_via_sub_cells ! If true, use the OM4 remapping algorithm (only used if useALEremapping) logical :: do_conv_adj, ignore integer :: nPoints integer :: id_clock_routine, id_clock_ALE @@ -2583,6 +2584,10 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, depth_tot, G, GV, US, PF, just "that were in use at the end of 2018. Higher values result in the use of more "//& "robust and accurate forms of mathematically equivalent expressions.", & default=default_answer_date, do_not_log=just_read.or.(.not.GV%Boussinesq)) + call get_param(PF, mdl, "Z_INIT_REMAPPING_USE_OM4_SUBCELLS", om4_remap_via_sub_cells, & + "If true, use the OM4 remapping-via-subcells algorithm for initialization. "//& + "See REMAPPING_USE_OM4_SUBCELLS for more details. "//& + "We recommend setting this option to false.", default=.true.) if (.not.GV%Boussinesq) remap_answer_date = max(remap_answer_date, 20230701) endif call get_param(PF, mdl, "HOR_REGRID_ANSWER_DATE", hor_regrid_answer_date, & @@ -2753,7 +2758,8 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, depth_tot, G, GV, US, PF, just ! Build the target grid (and set the model thickness to it) call ALE_initRegridding( GV, US, G%max_depth, PF, mdl, regridCS ) ! sets regridCS - call initialize_remapping( remapCS, remappingScheme, boundary_extrapolation=.false., answer_date=remap_answer_date ) + call initialize_remapping( remapCS, remappingScheme, boundary_extrapolation=.false., & + om4_remap_via_sub_cells=om4_remap_via_sub_cells, answer_date=remap_answer_date ) ! Now remap from source grid to target grid, first setting reconstruction parameters if (remap_general) then diff --git a/src/initialization/MOM_tracer_initialization_from_Z.F90 b/src/initialization/MOM_tracer_initialization_from_Z.F90 index cac8a5cd6c..bafa5d8c36 100644 --- a/src/initialization/MOM_tracer_initialization_from_Z.F90 +++ b/src/initialization/MOM_tracer_initialization_from_Z.F90 @@ -96,6 +96,7 @@ subroutine MOM_initialize_tracer_from_Z(h, tr, G, GV, US, PF, src_file, src_var_ ! remapping cell reconstructions [Z ~> m] real :: dz_neglect_edge ! A negligibly small vertical layer extent used in ! remapping edge value calculations [Z ~> m] + logical :: om4_remap_via_sub_cells ! If true, use the OM4 remapping algorithm integer :: nPoints ! The number of valid input data points in a column integer :: id_clock_routine, id_clock_ALE integer :: default_answer_date ! The default setting for the various ANSWER_DATE flags. @@ -137,6 +138,10 @@ subroutine MOM_initialize_tracer_from_Z(h, tr, G, GV, US, PF, src_file, src_var_ "that were in use at the end of 2018. Higher values result in the use of more "//& "robust and accurate forms of mathematically equivalent expressions.", & default=default_answer_date, do_not_log=.not.GV%Boussinesq) + call get_param(PF, mdl, "Z_INIT_REMAPPING_USE_OM4_SUBCELLS", om4_remap_via_sub_cells, & + "If true, use the OM4 remapping-via-subcells algorithm for initialization. "//& + "See REMAPPING_USE_OM4_SUBCELLS for more details. "//& + "We recommend setting this option to false.", default=.true.) if (.not.GV%Boussinesq) remap_answer_date = max(remap_answer_date, 20230701) endif call get_param(PF, mdl, "HOR_REGRID_ANSWER_DATE", hor_regrid_answer_date, & @@ -174,7 +179,8 @@ subroutine MOM_initialize_tracer_from_Z(h, tr, G, GV, US, PF, src_file, src_var_ allocate( dzSrc(isd:ied,jsd:jed,kd) ) allocate( hSrc(isd:ied,jsd:jed,kd) ) ! Set parameters for reconstructions - call initialize_remapping( remapCS, remapScheme, boundary_extrapolation=.false., answer_date=remap_answer_date ) + call initialize_remapping( remapCS, remapScheme, boundary_extrapolation=.false., & + om4_remap_via_sub_cells=om4_remap_via_sub_cells, answer_date=remap_answer_date ) ! Next we initialize the regridding package so that it knows about the target grid do j = js, je ; do i = is, ie diff --git a/src/ocean_data_assim/MOM_oda_driver.F90 b/src/ocean_data_assim/MOM_oda_driver.F90 index 8453ceb497..9275555afc 100644 --- a/src/ocean_data_assim/MOM_oda_driver.F90 +++ b/src/ocean_data_assim/MOM_oda_driver.F90 @@ -183,6 +183,7 @@ subroutine init_oda(Time, G, GV, US, diag_CS, CS) character(len=80) :: remap_scheme character(len=80) :: bias_correction_file, inc_file integer :: default_answer_date ! The default setting for the various ANSWER_DATE flags. + logical :: om4_remap_via_sub_cells ! If true, use the OM4 remapping algorithm if (associated(CS)) call MOM_error(FATAL, 'Calling oda_init with associated control structure') allocate(CS) @@ -320,8 +321,10 @@ subroutine init_oda(Time, G, GV, US, diag_CS, CS) call get_param(PF, 'oda_driver', "REGRIDDING_COORDINATE_MODE", coord_mode, & "Coordinate mode for vertical regridding.", & default="ZSTAR", fail_if_missing=.false.) + call get_param(PF, mdl, "REMAPPING_USE_OM4_SUBCELLS", om4_remap_via_sub_cells, & + do_not_log=.true., default=.true.) call initialize_regridding(CS%regridCS, CS%GV, CS%US, dG%max_depth,PF,'oda_driver',coord_mode,'','') - call initialize_remapping(CS%remapCS,remap_scheme) + call initialize_remapping(CS%remapCS, remap_scheme, om4_remap_via_sub_cells=om4_remap_via_sub_cells) call set_regrid_params(CS%regridCS, min_thickness=0.) isd = G%isd; ied = G%ied; jsd = G%jsd; jed = G%jed diff --git a/src/ocean_data_assim/MOM_oda_incupd.F90 b/src/ocean_data_assim/MOM_oda_incupd.F90 index d54d34506e..94d09554c2 100644 --- a/src/ocean_data_assim/MOM_oda_incupd.F90 +++ b/src/ocean_data_assim/MOM_oda_incupd.F90 @@ -143,6 +143,8 @@ subroutine initialize_oda_incupd( G, GV, US, param_file, CS, data_h, nz_data, re real :: dt, dt_therm ! Model timesteps [T ~> s] character(len=256) :: mesg character(len=64) :: remapScheme + logical :: om4_remap_via_sub_cells ! If true, use the OM4 remapping algorithm + if (.not.associated(CS)) then call MOM_error(WARNING, "initialize_oda_incupd called without an associated "// & "control structure.") @@ -195,6 +197,8 @@ subroutine initialize_oda_incupd( G, GV, US, param_file, CS, data_h, nz_data, re "When defined, the incoming oda_incupd data are "//& "assumed to be on the model horizontal grid " , & default=.true.) + call get_param(param_file, mdl, "REMAPPING_USE_OM4_SUBCELLS", om4_remap_via_sub_cells, & + do_not_log=.true., default=.true.) CS%nz = GV%ke @@ -236,7 +240,7 @@ subroutine initialize_oda_incupd( G, GV, US, param_file, CS, data_h, nz_data, re ! Call the constructor for remapping control structure !### Revisit this hard-coded answer_date. call initialize_remapping(CS%remap_cs, remapScheme, boundary_extrapolation=bndExtrapolation, & - answer_date=20190101) + om4_remap_via_sub_cells=om4_remap_via_sub_cells, answer_date=20190101) end subroutine initialize_oda_incupd diff --git a/src/parameterizations/lateral/MOM_hor_visc.F90 b/src/parameterizations/lateral/MOM_hor_visc.F90 index 2eef171bf5..b9e50f6b80 100644 --- a/src/parameterizations/lateral/MOM_hor_visc.F90 +++ b/src/parameterizations/lateral/MOM_hor_visc.F90 @@ -60,6 +60,12 @@ module MOM_hor_visc !! the viscosity bounds to the theoretical maximum !! for stability without considering other terms [nondim]. !! The default is 0.8. + logical :: backscatter_underbound !< If true, the bounds on the biharmonic viscosity are allowed + !! to increase where the Laplacian viscosity is negative (due to + !! backscatter parameterizations) beyond the largest timestep-dependent + !! stable values of biharmonic viscosity when no Laplacian viscosity is + !! applied. The default is true for historical reasons, but this option + !! probably should not be used as it can lead to numerical instabilities. logical :: Smagorinsky_Kh !< If true, use Smagorinsky nonlinear eddy !! viscosity. KH is the background value. logical :: Smagorinsky_Ah !< If true, use a biharmonic form of Smagorinsky @@ -88,6 +94,8 @@ module MOM_hor_visc !! in setting the corner-point viscosities when USE_KH_BG_2D=True. real :: Kh_bg_min !< The minimum value allowed for Laplacian horizontal !! viscosity [L2 T-1 ~> m2 s-1]. The default is 0.0. + logical :: FrictWork_bug !< If true, retain an answer-changing bug in calculating FrictWork, + !! which cancels the h in thickness flux and the h at velocity point. logical :: use_land_mask !< Use the land mask for the computation of thicknesses !! at velocity locations. This eliminates the dependence on !! arbitrary values over land or outside of the domain. @@ -241,7 +249,7 @@ module MOM_hor_visc !! u(is-2:ie+2,js-2:je+2) !! v(is-2:ie+2,js-2:je+2) !! h(is-1:ie+1,js-1:je+1) or up to h(is-2:ie+2,js-2:je+2) with some Leith options. -subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, & +subroutine horizontal_viscosity(u, v, h, uh, vh, diffu, diffv, MEKE, VarMix, G, GV, US, & CS, tv, dt, OBC, BT, TD, ADp, hu_cont, hv_cont) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. @@ -251,6 +259,10 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, intent(in) :: v !< The meridional velocity [L T-1 ~> m s-1]. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(inout) :: h !< Layer thicknesses [H ~> m or kg m-2]. + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: uh !< The zonal volume transport [H L2 T-1 ~> m3 s-1]. + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + intent(in) :: vh !< The meridional volume transport [H L2 T-1 ~> m3 s-1]. real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & intent(out) :: diffu !< Zonal acceleration due to convergence of !! along-coordinate stress tensor [L T-2 ~> m s-2] @@ -382,6 +394,7 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, real :: h_neglect ! thickness so small it can be lost in roundoff and so neglected [H ~> m or kg m-2] real :: h_neglect3 ! h_neglect^3 [H3 ~> m3 or kg3 m-6] real :: h_min ! Minimum h at the 4 neighboring velocity points [H ~> m] + real :: Kh_max_here ! The local maximum Laplacian viscosity for stability [L2 T-1 ~> m2 s-1] real :: RoScl ! The scaling function for MEKE source term [nondim] real :: FatH ! abs(f) at h-point for MEKE source term [T-1 ~> s-1] real :: local_strain ! Local variable for interpolating computed strain rates [T-1 ~> s-1]. @@ -608,7 +621,7 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, !$OMP parallel do default(none) & !$OMP shared( & - !$OMP CS, G, GV, US, OBC, VarMix, MEKE, u, v, h, & + !$OMP CS, G, GV, US, OBC, VarMix, MEKE, u, v, h, uh, vh, & !$OMP is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz, & !$OMP is_vort, ie_vort, js_vort, je_vort, & !$OMP is_Kh, ie_Kh, js_Kh, je_Kh, & @@ -628,8 +641,8 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, !$OMP vort_xy, vort_xy_dx, vort_xy_dy, div_xx, div_xx_dx, div_xx_dy, & !$OMP grad_div_mag_h, grad_div_mag_q, grad_vort_mag_h, grad_vort_mag_q, & !$OMP grad_vort, grad_vort_qg, grad_vort_mag_h_2d, grad_vort_mag_q_2d, & - !$OMP sh_xx_sq, sh_xy_sq, & - !$OMP meke_res_fn, Shear_mag, Shear_mag_bc, vert_vort_mag, h_min, hrat_min, visc_bound_rem, & + !$OMP sh_xx_sq, sh_xy_sq, meke_res_fn, Shear_mag, Shear_mag_bc, vert_vort_mag, & + !$OMP h_min, hrat_min, visc_bound_rem, Kh_max_here, & !$OMP grid_Ah, grid_Kh, d_Del2u, d_Del2v, d_str, & !$OMP Kh, Ah, AhSm, AhLth, local_strain, Sh_F_pow, & !$OMP dDel2vdx, dDel2udy, Del2vort_q, Del2vort_h, KE, & @@ -1064,12 +1077,6 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, h_min = min(h_u(I,j), h_u(I-1,j), h_v(i,J), h_v(i,J-1)) hrat_min(i,j) = min(1.0, h_min / (h(i,j,k) + h_neglect)) enddo ; enddo - - if (CS%better_bound_Kh) then - do j=js_Kh,je_Kh ; do i=is_Kh,ie_Kh - visc_bound_rem(i,j) = 1.0 - enddo ; enddo - endif endif if (CS%Laplacian) then @@ -1153,15 +1160,21 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, endif ! Newer method of bounding for stability - if (CS%better_bound_Kh) then + if ((CS%better_bound_Kh) .and. (CS%better_bound_Ah)) then do j=js_Kh,je_Kh ; do i=is_Kh,ie_Kh - if (Kh(i,j) >= hrat_min(i,j) * CS%Kh_Max_xx(i,j)) then + visc_bound_rem(i,j) = 1.0 + Kh_max_here = hrat_min(i,j) * CS%Kh_Max_xx(i,j) + if (Kh(i,j) >= Kh_max_here) then visc_bound_rem(i,j) = 0.0 - Kh(i,j) = hrat_min(i,j) * CS%Kh_Max_xx(i,j) - else ! if (Kh(i,j) > 0.0) then !### Change this to avoid a zero denominator. - visc_bound_rem(i,j) = 1.0 - Kh(i,j) / (hrat_min(i,j) * CS%Kh_Max_xx(i,j)) + Kh(i,j) = Kh_max_here + elseif ((Kh(i,j) > 0.0) .or. (CS%backscatter_underbound .and. (Kh_max_here > 0.0))) then + visc_bound_rem(i,j) = 1.0 - Kh(i,j) / Kh_max_here endif enddo ; enddo + elseif (CS%better_bound_Kh) then + do j=js_Kh,je_Kh ; do i=is_Kh,ie_Kh + Kh(i,j) = min(Kh(i,j), hrat_min(i,j) * CS%Kh_Max_xx(i,j)) + enddo ; enddo endif ! In Leith+E parameterization Kh is computed after Ah in the biharmonic loop. @@ -1428,11 +1441,6 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, hrat_min(I,J) = min(1.0, h_min / (hq(I,J) + h_neglect)) enddo ; enddo - if (CS%better_bound_Kh) then - do J=js-1,Jeq ; do I=is-1,Ieq - visc_bound_rem(I,J) = 1.0 - enddo ; enddo - endif endif if (CS%no_slip) then @@ -1543,13 +1551,17 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, Kh(I,J) = Kh(I,J) + CS%Kh_aniso * CS%n1n2_q(I,J)**2 ! Newer method of bounding for stability - if (CS%better_bound_Kh) then - if (Kh(I,J) >= hrat_min(I,J) * CS%Kh_Max_xy(I,J)) then + if ((CS%better_bound_Kh) .and. (CS%better_bound_Ah)) then + visc_bound_rem(I,J) = 1.0 + Kh_max_here = hrat_min(I,J) * CS%Kh_Max_xy(I,J) + if (Kh(I,J) >= Kh_max_here) then visc_bound_rem(I,J) = 0.0 - Kh(I,J) = hrat_min(I,J) * CS%Kh_Max_xy(I,J) - elseif (hrat_min(I,J)*CS%Kh_Max_xy(I,J)>0.) then !### Change to elseif (Kh(I,J) > 0.0) then - visc_bound_rem(I,J) = 1.0 - Kh(I,J) / (hrat_min(I,J) * CS%Kh_Max_xy(I,J)) + Kh(I,J) = Kh_max_here + elseif ((Kh(I,J) > 0.0) .or. (CS%backscatter_underbound .and. (Kh_max_here > 0.0))) then + visc_bound_rem(I,J) = 1.0 - Kh(I,J) / Kh_max_here endif + elseif (CS%better_bound_Kh) then + Kh(I,J) = min(Kh(I,J), hrat_min(I,J) * CS%Kh_Max_xy(I,J)) endif ! Leith+E doesn't recompute Kh at q points, it just interpolates it from h to q points @@ -1781,10 +1793,11 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, enddo endif - if (find_FrictWork) then ; do j=js,je ; do i=is,ie + if (find_FrictWork) then + if (CS%FrictWork_bug) then ; do j=js,je ; do i=is,ie ! Diagnose str_xx*d_x u - str_yy*d_y v + str_xy*(d_y u + d_x v) ! This is the old formulation that includes energy diffusion - FrictWork(i,j,k) = GV%H_to_RZ * ( & + FrictWork(i,j,k) = GV%H_to_RZ * ( & (str_xx(i,j) * (u(I,j,k)-u(I-1,j,k))*G%IdxT(i,j) & - str_xx(i,j) * (v(i,J,k)-v(i,J-1,k))*G%IdyT(i,j)) & + 0.25*((str_xy(I,J) * & @@ -1799,12 +1812,44 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, + str_xy(I,J-1) * & ((u(I,j,k)-u(I,j-1,k))*G%IdyBu(I,J-1) & + (v(i+1,J-1,k)-v(i,J-1,k))*G%IdxBu(I,J-1)) ) ) ) - enddo ; enddo ; endif + enddo ; enddo + else ; do j=js,je ; do i=is,ie + FrictWork(i,j,k) = GV%H_to_RZ * G%IareaT(i,j) * ( & + ((str_xx(i,j)*CS%dy2h(i,j) * ( & + (uh(I,j,k)*G%dxCu(I,j)*G%IdyCu(I,j)*G%IareaCu(I,j)/(h_u(I,j)+h_neglect)) & + - (uh(I-1,j,k)*G%dxCu(I-1,j)*G%IdyCu(I-1,j)*G%IareaCu(I-1,j)/(h_u(I-1,j)+h_neglect)) ) ) & + - (str_xx(i,j)*CS%dx2h(i,j) * ( & + (vh(i,J,k)*G%dyCv(i,J)*G%IdxCv(i,J)*G%IareaCv(i,J)/(h_v(i,J)+h_neglect)) & + - (vh(i,J-1,k)*G%dyCv(i,J-1)*G%IdxCv(i,J-1)*G%IareaCv(i,J-1)/(h_v(i,J-1)+h_neglect)) ) )) & + + (0.25*(((str_xy(I,J)*( & + (CS%dx2q(I,J)*((uh(I,j+1,k)*G%IareaCu(I,j+1)/(h_u(I,j+1)+h_neglect)) & + - (uh(I,j,k)*G%IareaCu(I,j)/(h_u(I,j)+h_neglect)))) & + + (CS%dy2q(I,J)*((vh(i+1,J,k)*G%IareaCv(i+1,J)/(h_v(i+1,J)+h_neglect)) & + - (vh(i,J,k)*G%IareaCv(i,J)/(h_v(i,J)+h_neglect)))) )) & + +(str_xy(I-1,J-1)*( & + (CS%dx2q(I-1,J-1)*((uh(I-1,j,k)*G%IareaCu(I-1,j)/(h_u(I-1,j)+h_neglect)) & + - (uh(I-1,j-1,k)*G%IareaCu(I-1,j-1)/(h_u(I-1,j-1)+h_neglect)))) & + + (CS%dy2q(I-1,J-1)*((vh(i,J-1,k)*G%IareaCv(i,J-1)/(h_v(i,J-1)+h_neglect)) & + - (vh(i-1,J-1,k)*G%IareaCv(i-1,J-1)/(h_v(i-1,J-1)+h_neglect)))) )) ) & + +((str_xy(I-1,J)*( & + (CS%dx2q(I-1,J)*((uh(I-1,j+1,k)*G%IareaCu(I-1,j+1)/(h_u(I-1,j+1)+h_neglect)) & + - (uh(I-1,j,k)*G%IareaCu(I-1,j)/(h_u(I-1,j)+h_neglect)))) & + + (CS%dy2q(I-1,J)*((vh(i,J,k)*G%IareaCv(i,J)/(h_v(i,J)+h_neglect)) & + - (vh(i-1,J,k)*G%IareaCv(i-1,J)/(h_v(i-1,J)+h_neglect)))) )) & + +(str_xy(I,J-1)*( & + (CS%dx2q(I,J-1)*((uh(I,j,k)*G%IareaCu(I,j)/(h_u(I,j)+h_neglect)) & + - (uh(I,j-1,k)*G%IareaCu(I,j-1)/(h_u(I,j-1)+h_neglect)))) & + + (CS%dy2q(I,J-1)*((vh(i+1,J-1,k)*G%IareaCv(i+1,J-1)/(h_v(i+1,J-1)+h_neglect)) & + - (vh(i,J-1,k)*G%IareaCv(i,J-1)/(h_v(i,J-1)+h_neglect)))) )) ) )) ) + enddo ; enddo ; endif + endif - if (CS%use_GME) then ; do j=js,je ; do i=is,ie + + if (CS%use_GME) then + if (CS%FrictWork_bug) then ; do j=js,je ; do i=is,ie ! Diagnose str_xx_GME*d_x u - str_yy_GME*d_y v + str_xy_GME*(d_y u + d_x v) ! This is the old formulation that includes energy diffusion - FrictWork_GME(i,j,k) = GV%H_to_RZ * ( & + FrictWork_GME(i,j,k) = GV%H_to_RZ * ( & (str_xx_GME(i,j)*(u(I,j,k)-u(I-1,j,k))*G%IdxT(i,j) & - str_xx_GME(i,j)*(v(i,J,k)-v(i,J-1,k))*G%IdyT(i,j)) & + 0.25*((str_xy_GME(I,J) * & @@ -1819,7 +1864,38 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, + str_xy_GME(I,J-1) * & ((u(I,j,k)-u(I,j-1,k))*G%IdyBu(I,J-1) & + (v(i+1,J-1,k)-v(i,J-1,k))*G%IdxBu(I,J-1)) ) ) ) - enddo ; enddo ; endif + enddo ; enddo + else ; do j=js,je ; do i=is,ie + FrictWork_GME(i,j,k) = GV%H_to_RZ * G%IareaT(i,j) * ( & + ((str_xx_GME(i,j)*CS%dy2h(i,j) * ( & + (uh(I,j,k)*G%dxCu(I,j)*G%IdyCu(I,j)*G%IareaCu(I,j)/(h_u(I,j)+h_neglect)) & + - (uh(I-1,j,k)*G%dxCu(I-1,j)*G%IdyCu(I-1,j)*G%IareaCu(I-1,j)/(h_u(I-1,j)+h_neglect)) ) ) & + - (str_xx_GME(i,j)*CS%dx2h(i,j) * ( & + (vh(i,J,k)*G%dyCv(i,J)*G%IdxCv(i,J)*G%IareaCv(i,J)/(h_v(i,J)+h_neglect)) & + - (vh(i,J-1,k)*G%dyCv(i,J-1)*G%IdxCv(i,J-1)*G%IareaCv(i,J-1)/(h_v(i,J-1)+h_neglect)) ) )) & + + (0.25*(((str_xy_GME(I,J)*( & + (CS%dx2q(I,J)*((uh(I,j+1,k)*G%IareaCu(I,j+1)/(h_u(I,j+1)+h_neglect)) & + - (uh(I,j,k)*G%IareaCu(I,j)/(h_u(I,j)+h_neglect)))) & + + (CS%dy2q(I,J)*((vh(i+1,J,k)*G%IareaCv(i+1,J)/(h_v(i+1,J)+h_neglect)) & + - (vh(i,J,k)*G%IareaCv(i,J)/(h_v(i,J)+h_neglect)))) )) & + +(str_xy_GME(I-1,J-1)*( & + (CS%dx2q(I-1,J-1)*((uh(I-1,j,k)*G%IareaCu(I-1,j)/(h_u(I-1,j)+h_neglect)) & + - (uh(I-1,j-1,k)*G%IareaCu(I-1,j-1)/(h_u(I-1,j-1)+h_neglect)))) & + + (CS%dy2q(I-1,J-1)*((vh(i,J-1,k)*G%IareaCv(i,J-1)/(h_v(i,J-1)+h_neglect)) & + - (vh(i-1,J-1,k)*G%IareaCv(i-1,J-1)/(h_v(i-1,J-1)+h_neglect)))) )) ) & + +((str_xy_GME(I-1,J)*( & + (CS%dx2q(I-1,J)*((uh(I-1,j+1,k)*G%IareaCu(I-1,j+1)/(h_u(I-1,j+1)+h_neglect)) & + - (uh(I-1,j,k)*G%IareaCu(I-1,j)/(h_u(I-1,j)+h_neglect)))) & + + (CS%dy2q(I-1,J)*((vh(i,J,k)*G%IareaCv(i,J)/(h_v(i,J)+h_neglect)) & + - (vh(i-1,J,k)*G%IareaCv(i-1,J)/(h_v(i-1,J)+h_neglect)))) )) & + +(str_xy_GME(I,J-1)*( & + (CS%dx2q(I,J-1)*((uh(I,j,k)*G%IareaCu(I,j)/(h_u(I,j)+h_neglect)) & + - (uh(I,j-1,k)*G%IareaCu(I,j-1)/(h_u(I,j-1)+h_neglect)))) & + + (CS%dy2q(I,J-1)*((vh(i+1,J-1,k)*G%IareaCv(i+1,J-1)/(h_v(i+1,J-1)+h_neglect)) & + - (vh(i,J-1,k)*G%IareaCv(i,J-1)/(h_v(i,J-1)+h_neglect)))) )) ) )) ) + + enddo ; enddo ; endif + endif ! Make a similar calculation as for FrictWork above but accumulating into ! the vertically integrated MEKE source term, and adjusting for any @@ -2062,7 +2138,7 @@ subroutine hor_visc_init(Time, G, GV, US, param_file, diag, CS, ADp) call get_param(param_file, mdl, "DEBUG", CS%debug, default=.false.) call get_param(param_file, mdl, "USE_CONT_THICKNESS", CS%use_cont_thick, & - "If true, use thickness at velocity points from continuity solver. This option"//& + "If true, use thickness at velocity points from continuity solver. This option "//& "currently only works with split mode.", default=.false.) call get_param(param_file, mdl, "LAPLACIAN", CS%Laplacian, & "If true, use a Laplacian horizontal viscosity.", & @@ -2208,6 +2284,16 @@ subroutine hor_visc_init(Time, G, GV, US, param_file, diag, CS, ADp) "so that the biharmonic Reynolds number is equal to this.", & units="nondim", default=0.0, do_not_log=.not.CS%biharmonic) + call get_param(param_file, mdl, "BACKSCATTER_UNDERBOUND", CS%backscatter_underbound, & + "If true, the bounds on the biharmonic viscosity are allowed to "//& + "increase where the Laplacian viscosity is negative (due to backscatter "//& + "parameterizations) beyond the largest timestep-dependent stable values of "//& + "biharmonic viscosity when no Laplacian viscosity is applied. The default "//& + "is true for historical reasons, but this option probably should not be used "//& + "because it can contribute to numerical instabilities.", & + default=.true., do_not_log=.not.((CS%better_bound_Kh).and.(CS%better_bound_Ah))) + !### The default for BACKSCATTER_UNDERBOUND should be false. + call get_param(param_file, mdl, "SMAG_BI_CONST",Smag_bi_const, & "The nondimensional biharmonic Smagorinsky constant, "//& "typically 0.015 - 0.06.", units="nondim", default=0.0, & @@ -2282,6 +2368,10 @@ subroutine hor_visc_init(Time, G, GV, US, param_file, diag, CS, ADp) "If true, retain an answer-changing horizontal indexing bug in setting "//& "the corner-point viscosities when USE_KH_BG_2D=True. This is "//& "not recommended.", default=.false., do_not_log=.not.CS%use_Kh_bg_2d) + call get_param(param_file, mdl, "FRICTWORK_BUG", CS%FrictWork_bug, & + "If true, retain an answer-changing bug in calculating "//& + "the FrictWork, which cancels the h in thickness flux and the h at velocity point. This is"//& + "not recommended.", default=.true.) call get_param(param_file, mdl, "USE_GME", CS%use_GME, & "If true, use the GM+E backscatter scheme in association \n"//& diff --git a/src/parameterizations/lateral/MOM_internal_tides.F90 b/src/parameterizations/lateral/MOM_internal_tides.F90 index 5b9ce4934c..225781ce0c 100644 --- a/src/parameterizations/lateral/MOM_internal_tides.F90 +++ b/src/parameterizations/lateral/MOM_internal_tides.F90 @@ -2550,6 +2550,7 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) real, dimension(:,:), allocatable :: ridge_temp ! array for temporary storage of flags ! of cells with double-reflecting ridges [nondim] logical :: use_int_tides, use_temperature + logical :: om4_remap_via_sub_cells ! Use the OM4-era ramap_via_sub_cells for calculating the EBT structure real :: IGW_c1_thresh ! A threshold first mode internal wave speed below which all higher ! mode speeds are not calculated but simply assigned a speed of 0 [L T-1 ~> m s-1]. real :: kappa_h2_factor ! A roughness scaling factor [nondim] @@ -2726,6 +2727,10 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) "mode speeds are not calculated but are simply reported as 0. This must be "//& "non-negative for the wave_speeds routine to be used.", & units="m s-1", default=0.01, scale=US%m_s_to_L_T) + call get_param(param_file, mdl, "INTWAVE_REMAPPING_USE_OM4_SUBCELLS", om4_remap_via_sub_cells, & + "If true, use the OM4 remapping-via-subcells algorithm for calculating EBT structure. "//& + "See REMAPPING_USE_OM4_SUBCELLS for details. "//& + "We recommend setting this option to false.", default=.true.) call get_param(param_file, mdl, "UNIFORM_TEST_CG", CS%uniform_test_cg, & "If positive, a uniform group velocity of internal tide for test case", & @@ -3107,7 +3112,8 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) enddo ! Initialize the module that calculates the wave speeds. - call wave_speed_init(CS%wave_speed, c1_thresh=IGW_c1_thresh) + call wave_speed_init(CS%wave_speed, c1_thresh=IGW_c1_thresh, & + om4_remap_via_sub_cells=om4_remap_via_sub_cells) end subroutine internal_tides_init diff --git a/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 b/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 index cd7e235274..7db0dc4e90 100644 --- a/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 +++ b/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 @@ -1190,6 +1190,7 @@ subroutine VarMix_init(Time, G, GV, US, param_file, diag, CS) ! mode wave speed as the starting point for iterations. real :: Stanley_coeff ! Coefficient relating the temperature gradient and sub-gridscale ! temperature variance [nondim] + logical :: om4_remap_via_sub_cells ! Use the OM4-era ramap_via_sub_cells for calculating the EBT structure ! This include declares and sets the variable "version". # include "version_variable.h" character(len=40) :: mdl = "MOM_lateral_mixing_coeffs" ! This module's name. @@ -1593,10 +1594,14 @@ subroutine VarMix_init(Time, G, GV, US, param_file, diag, CS) call get_param(param_file, mdl, "INTERNAL_WAVE_SPEED_BETTER_EST", better_speed_est, & "If true, use a more robust estimate of the first mode wave speed as the "//& "starting point for iterations.", default=.true.) + call get_param(param_file, mdl, "EBT_REMAPPING_USE_OM4_SUBCELLS", om4_remap_via_sub_cells, & + "If true, use the OM4 remapping-via-subcells algorithm for calculating EBT structure. "//& + "See REMAPPING_USE_OM4_SUBCELLS for details. "//& + "We recommend setting this option to false.", default=.true.) call wave_speed_init(CS%wave_speed, use_ebt_mode=CS%Resoln_use_ebt, & mono_N2_depth=N2_filter_depth, remap_answer_date=remap_answer_date, & better_speed_est=better_speed_est, min_speed=wave_speed_min, & - wave_speed_tol=wave_speed_tol) + om4_remap_via_sub_cells=om4_remap_via_sub_cells, wave_speed_tol=wave_speed_tol) endif ! Leith parameters diff --git a/src/parameterizations/vertical/MOM_ALE_sponge.F90 b/src/parameterizations/vertical/MOM_ALE_sponge.F90 index f1739485d6..170265d27a 100644 --- a/src/parameterizations/vertical/MOM_ALE_sponge.F90 +++ b/src/parameterizations/vertical/MOM_ALE_sponge.F90 @@ -190,6 +190,7 @@ subroutine initialize_ALE_sponge_fixed(Iresttime, G, GV, param_file, CS, data_h, logical :: data_h_to_Z logical :: bndExtrapolation = .true. ! If true, extrapolate boundaries integer :: default_answer_date ! The default setting for the various ANSWER_DATE flags. + logical :: om4_remap_via_sub_cells ! If true, use the OM4 remapping algorithm integer :: i, j, k, col, total_sponge_cols, total_sponge_cols_u, total_sponge_cols_v if (associated(CS)) then @@ -234,6 +235,10 @@ subroutine initialize_ALE_sponge_fixed(Iresttime, G, GV, param_file, CS, data_h, "robust and accurate forms of mathematically equivalent expressions.", & default=default_answer_date, do_not_log=.not.GV%Boussinesq) if (.not.GV%Boussinesq) CS%remap_answer_date = max(CS%remap_answer_date, 20230701) + call get_param(param_file, mdl, "SPONGE_REMAPPING_USE_OM4_SUBCELLS", om4_remap_via_sub_cells, & + "If true, use the OM4 remapping-via-subcells algorithm for ALE sponge. "//& + "See REMAPPING_USE_OM4_SUBCELLS for more details. "//& + "We recommend setting this option to false.", default=.true.) call get_param(param_file, mdl, "HOR_REGRID_ANSWER_DATE", CS%hor_regrid_answer_date, & "The vintage of the order of arithmetic for horizontal regridding. "//& @@ -284,6 +289,7 @@ subroutine initialize_ALE_sponge_fixed(Iresttime, G, GV, param_file, CS, data_h, ! Call the constructor for remapping control structure call initialize_remapping(CS%remap_cs, remapScheme, boundary_extrapolation=bndExtrapolation, & + om4_remap_via_sub_cells=om4_remap_via_sub_cells, & answer_date=CS%remap_answer_date) call log_param(param_file, mdl, "!Total sponge columns at h points", total_sponge_cols, & @@ -468,6 +474,7 @@ subroutine initialize_ALE_sponge_varying(Iresttime, G, GV, US, param_file, CS, I logical :: use_sponge logical :: bndExtrapolation = .true. ! If true, extrapolate boundaries integer :: default_answer_date ! The default setting for the various ANSWER_DATE flags. + logical :: om4_remap_via_sub_cells ! If true, use the OM4 remapping algorithm integer :: i, j, col, total_sponge_cols, total_sponge_cols_u, total_sponge_cols_v if (associated(CS)) then @@ -510,6 +517,10 @@ subroutine initialize_ALE_sponge_varying(Iresttime, G, GV, US, param_file, CS, I "that were in use at the end of 2018. Higher values result in the use of more "//& "robust and accurate forms of mathematically equivalent expressions.", & default=default_answer_date) + call get_param(param_file, mdl, "SPONGE_REMAPPING_USE_OM4_SUBCELLS", om4_remap_via_sub_cells, & + "If true, use the OM4 remapping-via-subcells algorithm for ALE sponge. "//& + "See REMAPPING_USE_OM4_SUBCELLS for more details. "//& + "We recommend setting this option to false.", default=.true.) call get_param(param_file, mdl, "HOR_REGRID_ANSWER_DATE", CS%hor_regrid_answer_date, & "The vintage of the order of arithmetic for horizontal regridding. "//& "Dates before 20190101 give the same answers as the code did in late 2018, "//& @@ -549,6 +560,7 @@ subroutine initialize_ALE_sponge_varying(Iresttime, G, GV, US, param_file, CS, I ! Call the constructor for remapping control structure call initialize_remapping(CS%remap_cs, remapScheme, boundary_extrapolation=bndExtrapolation, & + om4_remap_via_sub_cells=om4_remap_via_sub_cells, & answer_date=CS%remap_answer_date) call log_param(param_file, mdl, "!Total sponge columns at h points", total_sponge_cols, & "The total number of columns where sponges are applied at h points.", like_default=.true.) @@ -1303,11 +1315,13 @@ subroutine rotate_ALE_sponge(sponge_in, G_in, sponge, G, GV, US, turns, param_fi ! Second part: Provide rotated fields for which relaxation is applied - sponge%fldno = sponge_in%fldno - if (fixed_sponge) then allocate(sp_val_in(G_in%isd:G_in%ied, G_in%jsd:G_in%jed, nz_data)) allocate(sp_val(G%isd:G%ied, G%jsd:G%jed, nz_data)) + ! For a fixed sponge, sponge%fldno is incremented from 0 in the calls to set_up_ALE_sponge_field. + sponge%fldno = 0 + else + sponge%fldno = sponge_in%fldno endif do n=1,sponge_in%fldno @@ -1360,8 +1374,7 @@ subroutine rotate_ALE_sponge(sponge_in, G_in, sponge, G, GV, US, turns, param_fi ! TODO: var_u and var_v sponge damping is not yet supported. if (associated(sponge_in%var_u%p) .or. associated(sponge_in%var_v%p)) & - call MOM_error(FATAL, "Rotation of ALE sponge velocities is not yet " & - // "implemented.") + call MOM_error(FATAL, "Rotation of ALE sponge velocities is not yet implemented.") ! Transfer any existing diag_CS reference pointer sponge%diag => sponge_in%diag diff --git a/src/parameterizations/vertical/MOM_diabatic_driver.F90 b/src/parameterizations/vertical/MOM_diabatic_driver.F90 index b450127156..89ed3bada9 100644 --- a/src/parameterizations/vertical/MOM_diabatic_driver.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_driver.F90 @@ -1258,9 +1258,6 @@ subroutine diabatic_ALE(u, v, h, tv, BLD, fluxes, visc, ADp, CDp, dt, Time_end, call hchksum(Kd_heat, "after set_diffusivity Kd_heat", G%HI, haloshift=0, scale=GV%HZ_T_to_m2_s) endif - ! Store the diagnosed typical diffusivity at interfaces. - if (CS%id_Kd_int > 0) call post_data(CS%id_Kd_int, Kd_heat, CS%diag) - ! Set diffusivities for heat and salt separately, and possibly change the meaning of Kd_heat. if (CS%double_diffuse) then ! Add contributions from double diffusion @@ -1520,6 +1517,14 @@ subroutine diabatic_ALE(u, v, h, tv, BLD, fluxes, visc, ADp, CDp, dt, Time_end, if (CS%id_Kd_heat > 0) call post_data(CS%id_Kd_heat, Kd_heat, CS%diag) if (CS%id_Kd_salt > 0) call post_data(CS%id_Kd_salt, Kd_salt, CS%diag) if (CS%id_Kd_ePBL > 0) call post_data(CS%id_Kd_ePBL, Kd_ePBL, CS%diag) + if (CS%id_Kd_int > 0) then + if (CS%double_diffuse .or. CS%useKPP) then + do K=1,nz ; do j=js,je ; do i=is,ie + Kd_heat(i,j,k) = min(Kd_heat(i,j,k), Kd_salt(i,j,k)) + enddo ; enddo ; enddo + endif + call post_data(CS%id_Kd_int, Kd_heat, CS%diag) + endif if (CS%id_ea_t > 0) call post_data(CS%id_ea_t, ent_t(:,:,1:nz), CS%diag) if (CS%id_eb_t > 0) call post_data(CS%id_eb_t, ent_t(:,:,2:nz+1), CS%diag) @@ -3275,8 +3280,8 @@ subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, di CS%id_Kd_int = register_diag_field('ocean_model', 'Kd_interface', diag%axesTi, Time, & 'Total diapycnal diffusivity at interfaces', 'm2 s-1', conversion=GV%HZ_T_to_m2_s) if (CS%use_energetic_PBL) then - CS%id_Kd_ePBL = register_diag_field('ocean_model', 'Kd_ePBL', diag%axesTi, Time, & - 'ePBL diapycnal diffusivity at interfaces', 'm2 s-1', conversion=GV%HZ_T_to_m2_s) + CS%id_Kd_ePBL = register_diag_field('ocean_model', 'Kd_ePBL', diag%axesTi, Time, & + 'ePBL diapycnal diffusivity at interfaces', 'm2 s-1', conversion=GV%HZ_T_to_m2_s) endif CS%id_Kd_heat = register_diag_field('ocean_model', 'Kd_heat', diag%axesTi, Time, & diff --git a/src/parameterizations/vertical/MOM_set_diffusivity.F90 b/src/parameterizations/vertical/MOM_set_diffusivity.F90 index ef2e4ed5f6..d78b675c1a 100644 --- a/src/parameterizations/vertical/MOM_set_diffusivity.F90 +++ b/src/parameterizations/vertical/MOM_set_diffusivity.F90 @@ -157,7 +157,12 @@ module MOM_set_diffusivity integer :: answer_date !< The vintage of the order of arithmetic and expressions in this module's !! calculations. Values below 20190101 recover the answers from the !! end of 2018, while higher values use updated and more robust forms - !! of the same expressions. + !! of the same expressions. Values above 20240630 use more accurate + !! expressions for cases where USE_LOTW_BBL_DIFFUSIVITY is true. + integer :: LOTW_BBL_answer_date !< The vintage of the order of arithmetic and expressions + !! in the LOTW_BBL calculations. Values below 20240630 recover the + !! original answers, while higher values use more accurate expressions. + !! This only applies when USE_LOTW_BBL_DIFFUSIVITY is true. character(len=200) :: inputdir !< The directory in which input files are found type(user_change_diff_CS), pointer :: user_change_diff_CSp => NULL() !< Control structure for a child module @@ -1426,6 +1431,7 @@ subroutine add_LOTW_BBL_diffusivity(h, u, v, tv, fluxes, visc, j, N2_int, Rho_bo ! Local variables real :: dz(SZI_(G),SZK_(GV)) ! Height change across layers [Z ~> m] + real :: dz_above(SZK_(GV)+1) ! Distance from each interface to the surface [Z ~> m] real :: TKE_column ! net TKE input into the column [H Z2 T-3 ~> m3 s-3 or W m-2] real :: TKE_remaining ! remaining TKE available for mixing in this layer and above [H Z2 T-3 ~> m3 s-3 or W m-2] real :: TKE_consumed ! TKE used for mixing in this layer [H Z2 T-3 ~> m3 s-3 or W m-2] @@ -1500,7 +1506,15 @@ subroutine add_LOTW_BBL_diffusivity(h, u, v, tv, fluxes, visc, j, N2_int, Rho_bo TKE_column = CS%BBL_effic * TKE_column ! Only use a fraction of the mechanical dissipation for mixing. TKE_remaining = TKE_column - total_depth = ( sum(dz(i,:)) + GV%dz_subroundoff ) ! Total column thickness [Z ~> m]. + if (CS%LOTW_BBL_answer_date > 20240630) then + dz_above(1) = GV%dz_subroundoff ! This could perhaps be 0 instead. + do K=2,GV%ke+1 + dz_above(K) = dz_above(K-1) + dz(i,k-1) + enddo + total_depth = dz_above(GV%ke+1) + else + total_depth = ( sum(dz(i,:)) + GV%dz_subroundoff ) ! Total column thickness [Z ~> m]. + endif ustar_D = ustar * total_depth h_bot = 0. z_bot = 0. @@ -1525,7 +1539,11 @@ subroutine add_LOTW_BBL_diffusivity(h, u, v, tv, fluxes, visc, j, N2_int, Rho_bo z_bot = z_bot + dz(i,k) ! Distance between upper interface of layer and the bottom [Z ~> m]. h_bot = h_bot + h(i,j,k) ! Thickness between upper interface of layer and the bottom [H ~> m or kg m-2]. - D_minus_z = max(total_depth - z_bot, 0.) ! Thickness above layer [H ~> m or kg m-2]. + if (CS%LOTW_BBL_answer_date > 20240630) then + D_minus_z = dz_above(K) + else + D_minus_z = max(total_depth - z_bot, 0.) ! Distance from the interface to the surface [Z ~> m]. + endif ! Diffusivity using law of the wall, limited by rotation, at height z [H Z T-1 ~> m2 s-1 or kg m-1 s-1]. ! This calculation is at the upper interface of the layer @@ -2191,7 +2209,7 @@ subroutine set_diffusivity_init(Time, G, GV, US, param_file, diag, CS, int_tide_ "law of the form c_drag*|u|*u. The velocity magnitude "//& "may be an assumed value or it may be based on the actual "//& "velocity in the bottommost HBBL, depending on LINEAR_DRAG.", default=.true.) - if (CS%bottomdraglaw) then + if (CS%bottomdraglaw) then call get_param(param_file, mdl, "CDRAG", CS%cdrag, & "The drag coefficient relating the magnitude of the "//& "velocity field to the bottom stress. CDRAG is only used "//& @@ -2231,6 +2249,14 @@ subroutine set_diffusivity_init(Time, G, GV, US, param_file, diag, CS, int_tide_ else CS%use_LOTW_BBL_diffusivity = .false. ! This parameterization depends on a u* from viscous BBL endif + call get_param(param_file, mdl, "LOTW_BBL_ANSWER_DATE", CS%LOTW_BBL_answer_date, & + "The vintage of the order of arithmetic and expressions in the LOTW_BBL "//& + "calculations. Values below 20240630 recover the original answers, while "//& + "higher values use more accurate expressions. This only applies when "//& + "USE_LOTW_BBL_DIFFUSIVITY is true.", & + default=20190101, do_not_log=.not.CS%use_LOTW_BBL_diffusivity) + !### Set default as default=default_answer_date, or use SET_DIFF_ANSWER_DATE. + CS%id_Kd_BBL = register_diag_field('ocean_model', 'Kd_BBL', diag%axesTi, Time, & 'Bottom Boundary Layer Diffusivity', 'm2 s-1', conversion=GV%HZ_T_to_m2_s) diff --git a/src/tracer/DOME_tracer.F90 b/src/tracer/DOME_tracer.F90 index e0bd659a60..76546f834c 100644 --- a/src/tracer/DOME_tracer.F90 +++ b/src/tracer/DOME_tracer.F90 @@ -372,7 +372,7 @@ subroutine DOME_tracer_surface_state(sfc_state, h, G, GV, CS) ! This call loads the surface values into the appropriate array in the ! coupler-type structure. call set_coupler_type_data(CS%tr(:,:,1,m), CS%ind_tr(m), sfc_state%tr_fields, & - idim=(/isd, is, ie, ied/), jdim=(/jsd, js, je, jed/) ) + idim=(/isd, is, ie, ied/), jdim=(/jsd, js, je, jed/), turns=G%HI%turns) enddo endif diff --git a/src/tracer/ISOMIP_tracer.F90 b/src/tracer/ISOMIP_tracer.F90 index 64db56b96c..cc4dca16bc 100644 --- a/src/tracer/ISOMIP_tracer.F90 +++ b/src/tracer/ISOMIP_tracer.F90 @@ -331,7 +331,7 @@ subroutine ISOMIP_tracer_surface_state(sfc_state, h, G, GV, CS) ! This call loads the surface values into the appropriate array in the ! coupler-type structure. call set_coupler_type_data(CS%tr(:,:,1,m), CS%ind_tr(m), sfc_state%tr_fields, & - idim=(/isd, is, ie, ied/), jdim=(/jsd, js, je, jed/) ) + idim=(/isd, is, ie, ied/), jdim=(/jsd, js, je, jed/), turns=G%HI%turns) enddo endif diff --git a/src/tracer/MOM_OCMIP2_CFC.F90 b/src/tracer/MOM_OCMIP2_CFC.F90 index 50354b5dc7..7947cc72ed 100644 --- a/src/tracer/MOM_OCMIP2_CFC.F90 +++ b/src/tracer/MOM_OCMIP2_CFC.F90 @@ -453,9 +453,9 @@ subroutine OCMIP2_CFC_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, US ! The -GV%Rho0 changes the sign convention of the flux and with the scaling factors changes ! the units of the flux from [Conc. m s-1] to [Conc. R Z T-1 ~> Conc. kg m-2 s-1]. call extract_coupler_type_data(fluxes%tr_fluxes, CS%ind_cfc_11_flux, CFC11_flux, & - scale_factor=-GV%Rho0*US%m_to_Z*US%T_to_s, idim=idim, jdim=jdim) + scale_factor=-GV%Rho0*US%m_to_Z*US%T_to_s, idim=idim, jdim=jdim, turns=G%HI%turns) call extract_coupler_type_data(fluxes%tr_fluxes, CS%ind_cfc_12_flux, CFC12_flux, & - scale_factor=-GV%Rho0*US%m_to_Z*US%T_to_s, idim=idim, jdim=jdim) + scale_factor=-GV%Rho0*US%m_to_Z*US%T_to_s, idim=idim, jdim=jdim, turns=G%HI%turns) ! Use a tridiagonal solver to determine the concentrations after the ! surface source is applied and diapycnal advection and diffusion occurs. @@ -587,13 +587,13 @@ subroutine OCMIP2_CFC_surface_state(sfc_state, h, G, GV, US, CS) ! These calls load these values into the appropriate arrays in the ! coupler-type structure. call set_coupler_type_data(CFC11_alpha, CS%ind_cfc_11_flux, sfc_state%tr_fields, & - solubility=.true., idim=idim, jdim=jdim) + solubility=.true., idim=idim, jdim=jdim, turns=G%HI%turns) call set_coupler_type_data(CFC11_Csurf, CS%ind_cfc_11_flux, sfc_state%tr_fields, & - idim=idim, jdim=jdim) + idim=idim, jdim=jdim, turns=G%HI%turns) call set_coupler_type_data(CFC12_alpha, CS%ind_cfc_12_flux, sfc_state%tr_fields, & - solubility=.true., idim=idim, jdim=jdim) + solubility=.true., idim=idim, jdim=jdim, turns=G%HI%turns) call set_coupler_type_data(CFC12_Csurf, CS%ind_cfc_12_flux, sfc_state%tr_fields, & - idim=idim, jdim=jdim) + idim=idim, jdim=jdim, turns=G%HI%turns) end subroutine OCMIP2_CFC_surface_state diff --git a/src/tracer/MOM_generic_tracer.F90 b/src/tracer/MOM_generic_tracer.F90 index f430e94515..6168ec1d70 100644 --- a/src/tracer/MOM_generic_tracer.F90 +++ b/src/tracer/MOM_generic_tracer.F90 @@ -67,7 +67,7 @@ module MOM_generic_tracer public end_MOM_generic_tracer, MOM_generic_tracer_get public MOM_generic_tracer_stock public MOM_generic_flux_init - public MOM_generic_tracer_min_max + public MOM_generic_tracer_min_max, array_global_min_max public MOM_generic_tracer_fluxes_accumulate public register_MOM_generic_tracer_segments @@ -206,7 +206,7 @@ function register_MOM_generic_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) !!nnz: MOM field is 3D. Does this affect performance? Need it be override field? tr_ptr => tr_field(:,:,:,1) - ! Register prognastic tracer for horizontal advection, diffusion, and restarts. + ! Register prognostic tracer for horizontal advection, diffusion, and restarts. if (g_tracer_is_prog(g_tracer)) then call register_tracer(tr_ptr, tr_Reg, param_file, HI, GV, & name=g_tracer_name, longname=longname, units=units, & @@ -699,42 +699,49 @@ function MOM_generic_tracer_stock(h, stocks, G, GV, CS, names, units, stock_inde end function MOM_generic_tracer_stock - !> This subroutine find the global min and max of either of all - !! available tracer concentrations, or of a tracer that is being - !! requested specifically, returning the number of tracers it has gone through. - function MOM_generic_tracer_min_max(ind_start, got_minmax, gmin, gmax, xgmin, ygmin, zgmin, & - xgmax, ygmax, zgmax , G, CS, names, units) + !> This subroutine finds the global min and max of either of all available + !! tracer concentrations, or of a tracer that is being requested specifically, + !! returning the number of tracers it has evaluated. + !! It also optionally returns the locations of the extrema. + function MOM_generic_tracer_min_max(ind_start, got_minmax, gmin, gmax, G, CS, names, units, & + xgmin, ygmin, zgmin, xgmax, ygmax, zgmax) integer, intent(in) :: ind_start !< The index of the tracer to start with logical, dimension(:), intent(out) :: got_minmax !< Indicates whether the global min and !! max are found for each tracer - real, dimension(:), intent(out) :: gmin !< Global minimum of each tracer, in kg - !! times concentration units. - real, dimension(:), intent(out) :: gmax !< Global maximum of each tracer, in kg - !! times concentration units. - real, dimension(:), intent(out) :: xgmin !< The x-position of the global minimum - real, dimension(:), intent(out) :: ygmin !< The y-position of the global minimum - real, dimension(:), intent(out) :: zgmin !< The z-position of the global minimum - real, dimension(:), intent(out) :: xgmax !< The x-position of the global maximum - real, dimension(:), intent(out) :: ygmax !< The y-position of the global maximum - real, dimension(:), intent(out) :: zgmax !< The z-position of the global maximum + real, dimension(:), intent(out) :: gmin !< Global minimum of each tracer [conc] + real, dimension(:), intent(out) :: gmax !< Global maximum of each tracer [conc] type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(MOM_generic_tracer_CS), pointer :: CS !< Pointer to the control structure for this module. character(len=*), dimension(:), intent(out) :: names !< The names of the stocks calculated. character(len=*), dimension(:), intent(out) :: units !< The units of the stocks calculated. + real, dimension(:), optional, intent(out) :: xgmin !< The x-position of the global minimum in the + !! units of G%geoLonT, often [degrees_E] or [km] or [m] + real, dimension(:), optional, intent(out) :: ygmin !< The y-position of the global minimum in the + !! units of G%geoLatT, often [degrees_N] or [km] or [m] + real, dimension(:), optional, intent(out) :: zgmin !< The z-position of the global minimum [layer] + real, dimension(:), optional, intent(out) :: xgmax !< The x-position of the global maximum in the + !! units of G%geoLonT, often [degrees_E] or [km] or [m] + real, dimension(:), optional, intent(out) :: ygmax !< The y-position of the global maximum in the + !! units of G%geoLatT, often [degrees_N] or [km] or [m] + real, dimension(:), optional, intent(out) :: zgmax !< The z-position of the global maximum [layer] integer :: MOM_generic_tracer_min_max !< Return value, the !! number of tracers done here. -! Local variables + ! Local variables type(g_tracer_type), pointer :: g_tracer, g_tracer_next - real, dimension(:,:,:,:), pointer :: tr_field - real, dimension(:,:,:), pointer :: tr_ptr + real, dimension(:,:,:,:), pointer :: tr_field ! The tracer array whose extrema are being sought [conc] + real, dimension(:,:,:), pointer :: tr_ptr ! The tracer array whose extrema are being sought [conc] + real :: x_min ! The x-position of the global minimum in the units of G%geoLonT, often [degrees_E] or [km] or [m] + real :: y_min ! The y-position of the global minimum in the units of G%geoLatT, often [degrees_N] or [km] or [m] + real :: z_min ! The z-position of the global minimum [layer] + real :: x_max ! The x-position of the global maximum in the units of G%geoLonT, often [degrees_E] or [km] or [m] + real :: y_max ! The y-position of the global maximum in the units of G%geoLatT, often [degrees_N] or [km] or [m] + real :: z_max ! The z-position of the global maximum [layer] character(len=128), parameter :: sub_name = 'MOM_generic_tracer_min_max' - real, dimension(:,:,:),pointer :: grid_tmask - integer :: isc,iec,jsc,jec,isd,ied,jsd,jed,nk,ntau - + logical :: find_location + integer :: isc, iec, jsc, jec, isd, ied, jsd, jed, nk, ntau integer :: k, is, ie, js, je, m - real, allocatable, dimension(:) :: geo_z is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec @@ -743,19 +750,14 @@ function MOM_generic_tracer_min_max(ind_start, got_minmax, gmin, gmax, xgmin, yg if (.NOT. associated(CS%g_tracer_list)) return ! No stocks. - - call g_tracer_get_common(isc,iec,jsc,jec,isd,ied,jsd,jed,nk,ntau,grid_tmask=grid_tmask) - - ! Because the use of a simple z-coordinate can not be assumed, simply - ! use the layer index as the vertical label. - allocate(geo_z(nk)) - do k=1,nk ; geo_z(k) = real(k) ; enddo + call g_tracer_get_common(isc, iec, jsc, jec, isd, ied, jsd, jed, nk, ntau) + find_location = present(xgmin) .or. present(ygmin) .or. present(zgmin) .or. & + present(xgmax) .or. present(ygmax) .or. present(zgmax) m=ind_start ; g_tracer=>CS%g_tracer_list do call g_tracer_get_alias(g_tracer,names(m)) call g_tracer_get_values(g_tracer,names(m),'units',units(m)) - units(m) = trim(units(m))//" kg" call g_tracer_get_pointer(g_tracer,names(m),'field',tr_field) gmin(m) = -1.0 @@ -763,9 +765,18 @@ function MOM_generic_tracer_min_max(ind_start, got_minmax, gmin, gmax, xgmin, yg tr_ptr => tr_field(:,:,:,1) - call array_global_min_max(tr_ptr, grid_tmask, isd, jsd, isc, iec, jsc, jec, nk, gmin(m), gmax(m), & - G%geoLonT, G%geoLatT, geo_z, xgmin(m), ygmin(m), zgmin(m), & - xgmax(m), ygmax(m), zgmax(m)) + if (find_location) then + call array_global_min_max(tr_ptr, G, nk, gmin(m), gmax(m), & + x_min, y_min, z_min, x_max, y_max, z_max) + if (present(xgmin)) xgmin(m) = x_min + if (present(ygmin)) ygmin(m) = y_min + if (present(zgmin)) zgmin(m) = z_min + if (present(xgmax)) xgmax(m) = x_max + if (present(ygmax)) ygmax(m) = y_max + if (present(zgmax)) zgmax(m) = z_max + else + call array_global_min_max(tr_ptr, G, nk, gmin(m), gmax(m)) + endif got_minmax(m) = .true. @@ -780,133 +791,192 @@ function MOM_generic_tracer_min_max(ind_start, got_minmax, gmin, gmax, xgmin, yg end function MOM_generic_tracer_min_max - !> Find the global maximum and minimum of a tracer array and return the locations of the extrema. - subroutine array_global_min_max(tr_array, tmask, isd, jsd, isc, iec, jsc, jec, nk, g_min, g_max, & - geo_x, geo_y, geo_z, xgmin, ygmin, zgmin, xgmax, ygmax, zgmax) - integer, intent(in) :: isd !< The starting data domain i-index - integer, intent(in) :: jsd !< The starting data domain j-index - real, dimension(isd:,jsd:,:), intent(in) :: tr_array !< The tracer array to search for extrema - real, dimension(isd:,jsd:,:), intent(in) :: tmask !< A mask that is 0 for points to exclude - integer, intent(in) :: isc !< The starting compute domain i-index - integer, intent(in) :: iec !< The ending compute domain i-index - integer, intent(in) :: jsc !< The starting compute domain j-index - integer, intent(in) :: jec !< The ending compute domain j-index +!> Find the global maximum and minimum of a tracer array and return the locations of the extrema. +!! When there multiple cells with the same extreme values, the reported locations are from the +!! uppermost layer where they occur, and then from the logically northernmost and then eastermost +!! such location on the unrotated version of the grid within that layer. Only ocean points (as +!! indicated by a positive value of G%mask2dT) are evaluated, and if there are no ocean points +!! anywhere in the domain, the reported extrema and their locations are all returned as 0. + subroutine array_global_min_max(tr_array, G, nk, g_min, g_max, & + xgmin, ygmin, zgmin, xgmax, ygmax, zgmax, unscale) integer, intent(in) :: nk !< The number of vertical levels - real, intent(out) :: g_min !< The global minimum of tr_array - real, intent(out) :: g_max !< The global maximum of tr_array - real, dimension(isd:,jsd:), intent(in) :: geo_x !< The geographic x-positions of points - real, dimension(isd:,jsd:), intent(in) :: geo_y !< The geographic y-positions of points - real, dimension(:), intent(in) :: geo_z !< The vertical pseudo-positions of points - real, intent(out) :: xgmin !< The x-position of the global minimum - real, intent(out) :: ygmin !< The y-position of the global minimum - real, intent(out) :: zgmin !< The z-position of the global minimum - real, intent(out) :: xgmax !< The x-position of the global maximum - real, intent(out) :: ygmax !< The y-position of the global maximum - real, intent(out) :: zgmax !< The z-position of the global maximum - - ! This subroutine is an exact transcription (bugs and all) of mpp_array_global_min_max() - ! from the version in FMS/mpp/mpp_utilities.F90, but with some whitespace changes to match - ! MOM6 code styles and to use infrastructure routines via the MOM6 framework code, and with - ! added comments to document its arguments.i - - !### The obvious problems with this routine as currently written include: - ! 1. It does not return exactly the maximum and minimum values. - ! 2. The reported maximum and minimum are dependent on PE count and layout. - ! 3. For all-zero arrays, the reported maxima scale with the PE_count - ! 4. For arrays with a large enough offset or scaling, so that the magnitude of values exceed - ! 1e10, the values it returns are simply wrong. - ! 5. The results do not scale appropriately if the argument is rescaled. - ! 6. The extrema and locations are not rotationally invariant. - ! 7. It is inefficient because it uses 8 blocking global reduction calls when it could use just 2 or 3. + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + real, dimension(SZI_(G),SZJ_(G),nk), intent(in) :: tr_array !< The tracer array to search for + !! extrema in arbitrary concentration units [CU ~> conc] + real, intent(out) :: g_min !< The global minimum of tr_array, either in + !! the same units as tr_array [CU ~> conc] or in + !! unscaled units if unscale is present [conc] + real, intent(out) :: g_max !< The global maximum of tr_array, either in + !! the same units as tr_array [CU ~> conc] or in + !! unscaled units if unscale is present [conc] + real, optional, intent(out) :: xgmin !< The x-position of the global minimum in the + !! units of G%geoLonT, often [degrees_E] or [km] or [m] + real, optional, intent(out) :: ygmin !< The y-position of the global minimum in the + !! units of G%geoLatT, often [degrees_N] or [km] or [m] + real, optional, intent(out) :: zgmin !< The z-position of the global minimum [layer] + real, optional, intent(out) :: xgmax !< The x-position of the global maximum in the + !! units of G%geoLonT, often [degrees_E] or [km] or [m] + real, optional, intent(out) :: ygmax !< The y-position of the global maximum in the + !! units of G%geoLatT, often [degrees_N] or [km] or [m] + real, optional, intent(out) :: zgmax !< The z-position of the global maximum [layer] + real, optional, intent(in) :: unscale !< A factor to use to undo any scaling of + !! the input tracer array [conc CU-1 ~> 1] ! Local variables - real :: tmax, tmin ! Maximum and minimum tracer values, in the same units as tr_array - real :: tmax0, tmin0 ! First-guest values of tmax and tmin. + real :: tmax, tmin ! Maximum and minimum tracer values, in the same units as tr_array [CU ~> conc] + integer :: ijk_min_max(2) ! Integers encoding the global grid positions of the global minimum and maximum values + real :: xyz_min_max(6) ! A single array with the x-, y- and z-positions of the minimum and + ! maximum values in units that vary between the array elements [various] + logical :: valid_PE ! True if there are any valid points on the local PE. + logical :: find_location ! If true, report the locations of the extrema + integer :: ijk_loc_max ! An integer encoding the global grid position of the maximum tracer value on this PE + integer :: ijk_loc_min ! An integer encoding the global grid position of the minimum tracer value on this PE + integer :: ijk_loc_here ! An integer encoding the global grid position of the current grid point integer :: itmax, jtmax, ktmax, itmin, jtmin, ktmin - real :: fudge ! A factor that is close to 1 that is used to find the location of the extrema [nondim]. - - ! arrays to enable vectorization - integer :: iminarr(3), imaxarr(3) - - !### These dimensional constant values mean that the results can not be guaranteed to be rescalable. - g_min = -88888888888.0 ; g_max = -999999999.0 - tmax = -1.e10 ; tmin = 1.e10 - itmax = 0 ; jtmax = 0 ; ktmax = 0 - itmin = 0 ; jtmin = 0 ; ktmin = 0 - - if (ANY(tmask(isc:iec,jsc:jec,:) > 0.)) then - ! Vectorized using maxloc() and minloc() intrinsic functions by Russell.Fiedler@csiro.au. - iminarr = minloc(tr_array(isc:iec,jsc:jec,:), (tmask(isc:iec,jsc:jec,:) > 0.)) - imaxarr = maxloc(tr_array(isc:iec,jsc:jec,:), (tmask(isc:iec,jsc:jec,:) > 0.)) - itmin = iminarr(1)+isc-1 - jtmin = iminarr(2)+jsc-1 - ktmin = iminarr(3) - itmax = imaxarr(1)+isc-1 - jtmax = imaxarr(2)+jsc-1 - ktmax = imaxarr(3) - tmin = tr_array(itmin,jtmin,ktmin) - tmax = tr_array(itmax,jtmax,ktmax) - end if - - ! use "fudge" to distinguish processors when tracer extreme is independent of processor - !### This fudge factor is not independent of PE layout, and while it mostly works for finding - ! a positive maximum or a negative minimum, it could miss the true extrema in the opposite - ! cases, for which the fudge factor should be slightly reduced. The fudge factor should - ! be based on global index-space conventions, which are decomposition invariant, and - ! not the PE-number! - fudge = 1.0 + 1.e-12*real(PE_here() ) - tmax = tmax*fudge - tmin = tmin*fudge - if (tmax == 0.0) then - tmax = tmax + 1.e-12*real(PE_here() ) - endif - if (tmin == 0.0) then - tmin = tmin + 1.e-12*real(PE_here() ) + integer :: i, j, k, isc, iec, jsc, jec + + isc = G%isc ; iec = G%iec ; jsc = G%jsc ; jec = G%jec + + find_location = (present(xgmin) .or. present(ygmin) .or. present(zgmin) .or. & + present(xgmax) .or. present(ygmax) .or. present(zgmax)) + + ! The initial values set here are never used if there are any valid points. + tmax = -huge(tmax) ; tmin = huge(tmin) + + if (find_location) then + ! Find the maximum and minimum tracer values on this PE and their locations. + valid_PE = .false. + itmax = 0 ; jtmax = 0 ; ktmax = 0 ; ijk_loc_max = 0 + itmin = 0 ; jtmin = 0 ; ktmin = 0 ; ijk_loc_min = 0 + do k=1,nk ; do j=jsc,jec ; do i=isc,iec ; if (G%mask2dT(i,j) > 0.0) then + valid_PE = .true. + if (tr_array(i,j,k) > tmax) then + tmax = tr_array(i,j,k) + itmax = i ; jtmax = j ; ktmax = k + ijk_loc_max = ijk_loc(i, j, k, nk, G%HI) + elseif ((tr_array(i,j,k) == tmax) .and. (k <= ktmax)) then + ijk_loc_here = ijk_loc(i, j, k, nk, G%HI) + if (ijk_loc_here > ijk_loc_max) then + itmax = i ; jtmax = j ; ktmax = k + ijk_loc_max = ijk_loc_here + endif + endif + if (tr_array(i,j,k) < tmin) then + tmin = tr_array(i,j,k) + itmin = i ; jtmin = j ; ktmin = k + ijk_loc_min = ijk_loc(i, j, k, nk, G%HI) + elseif ((tr_array(i,j,k) == tmin) .and. (k <= ktmin)) then + ijk_loc_here = ijk_loc(i, j, k, nk, G%HI) + if (ijk_loc_here > ijk_loc_min) then + itmin = i ; jtmin = j ; ktmin = k + ijk_loc_min = ijk_loc_here + endif + endif + endif ; enddo ; enddo ; enddo + else + ! Only the maximum and minimum values are needed, and not their positions. + do k=1,nk ; do j=jsc,jec ; do i=isc,iec ; if (G%mask2dT(i,j) > 0.0) then + if (tr_array(i,j,k) > tmax) tmax = tr_array(i,j,k) + if (tr_array(i,j,k) < tmin) tmin = tr_array(i,j,k) + endif ; enddo ; enddo ; enddo endif - tmax0 = tmax ; tmin0 = tmin + ! Find the global maximum and minimum tracer values. + g_max = tmax ; g_min = tmin + call max_across_PEs(g_max) + call min_across_PEs(g_min) - call max_across_PEs(tmax) - call min_across_PEs(tmin) + if (find_location) then + if (g_max < g_min) then + ! This only occurs if there are no unmasked points anywhere in the domain. + xyz_min_max(:) = 0.0 + else + ! Find the global indices of the maximum and minimum locations. This can + ! occur on multiple PEs. + ijk_min_max(1:2) = 0 + if (valid_PE) then + if (g_min == tmin) ijk_min_max(1) = ijk_loc_min + if (g_max == tmax) ijk_min_max(2) = ijk_loc_max + endif + ! If MOM6 supported taking maxima on arrays of integers, these could be combined as: + ! call max_across_PEs(ijk_min_max, 2) + call max_across_PEs(ijk_min_max(1)) + call max_across_PEs(ijk_min_max(2)) + + ! Set the positions of the extrema if they occur on this PE. This will only + ! occur on a single PE. + xyz_min_max(1:6) = -huge(xyz_min_max) ! These huge negative values are never selected by max_across_PEs. + if (valid_PE) then + if (ijk_min_max(1) == ijk_loc_min) then + xyz_min_max(1) = G%geoLonT(itmin,jtmin) + xyz_min_max(2) = G%geoLatT(itmin,jtmin) + xyz_min_max(3) = real(ktmin) + endif + if (ijk_min_max(2) == ijk_loc_max) then + xyz_min_max(4) = G%geoLonT(itmax,jtmax) + xyz_min_max(5) = G%geoLatT(itmax,jtmax) + xyz_min_max(6) = real(ktmax) + endif + endif - g_max = tmax - g_min = tmin + call max_across_PEs(xyz_min_max, 6) + endif - ! Now find the location of the global extrema. - ! - ! Note that the fudge factor above guarantees that the location of max (min) is unique, - ! since tmax0 (tmin0) has slightly different values on each processor. - ! Otherwise, the function tr_array(i,j,k) could be equal to global max (min) at more - ! than one point in space and this would be a much more difficult problem to solve. - ! - !-999 on all current PE's - xgmax = -999. ; ygmax = -999. ; zgmax = -999. - xgmin = -999. ; ygmin = -999. ; zgmin = -999. - - if (tmax0 == tmax) then !This happens ONLY on ONE processor because of fudge factor above. - xgmax = geo_x(itmax,jtmax) - ygmax = geo_y(itmax,jtmax) - zgmax = geo_z(ktmax) + if (present(xgmin)) xgmin = xyz_min_max(1) + if (present(ygmin)) ygmin = xyz_min_max(2) + if (present(zgmin)) zgmin = xyz_min_max(3) + if (present(xgmax)) xgmax = xyz_min_max(4) + if (present(ygmax)) ygmax = xyz_min_max(5) + if (present(zgmax)) zgmax = xyz_min_max(6) endif - !### These three calls and the three calls that follow in about 10 lines should be combined - ! into a single call for efficiency. - call max_across_PEs(xgmax) - call max_across_PEs(ygmax) - call max_across_PEs(zgmax) - - if (tmin0 == tmin) then !This happens ONLY on ONE processor because of fudge factor above. - xgmin = geo_x(itmin,jtmin) - ygmin = geo_y(itmin,jtmin) - zgmin = geo_z(ktmin) + if (g_max < g_min) then + ! There are no unmasked points anywhere in the domain. + g_max = 0.0 ; g_min = 0.0 endif - call max_across_PEs(xgmin) - call max_across_PEs(ygmin) - call max_across_PEs(zgmin) + if (present(unscale)) then + ! Rescale g_min and g_max, perhaps changing their units from [CU ~> conc] to [conc] + g_max = unscale * g_max + g_min = unscale * g_min + endif end subroutine array_global_min_max + ! Return a positive integer encoding the rotationally invariant global position of a tracer cell + function ijk_loc(i, j, k, nk, HI) + integer, intent(in) :: i !< Local i-index + integer, intent(in) :: j !< Local j-index + integer, intent(in) :: k !< Local k-index + integer, intent(in) :: nk !< Range of k-index, used to pick out a low-k position. + type(hor_index_type), intent(in) :: HI !< Horizontal index ranges + integer :: ijk_loc ! An integer encoding the cell position in the global grid. + + ! Local variables + integer :: ig, jg ! Global index values with a global computational domain start value of 1. + integer :: ij_loc ! The encoding of the horizontal position + integer :: qturns ! The number of counter-clockwise quarter turns of the grid that have to be undone + + ! These global i-grid positions run from 1 to HI%niglobal, and analogously for jg. + ig = i + HI%idg_offset + (1 - HI%isg) + jg = j + HI%jdg_offset + (1 - HI%jsg) + + ! Compensate for the rotation of the model grid to give a rotationally invariant encoding. + qturns = modulo(HI%turns, 4) + if (qturns == 0) then + ij_loc = ig + HI%niglobal * jg + elseif (qturns == 1) then + ij_loc = jg + HI%njglobal * ((HI%niglobal+1)-ig) + elseif (qturns == 2) then + ij_loc = ((HI%niglobal+1)-ig) + HI%niglobal * ((HI%njglobal+1)-jg) + elseif (qturns == 3) then + ij_loc = ((HI%njglobal+1)-jg) + HI%njglobal * ig + endif + + ijk_loc = ij_loc + (HI%niglobal*HI%njglobal) * (nk-k) + + end function ijk_loc + !> This subroutine calculates the surface state and sets coupler values for !! those generic tracers that have flux exchange with atmosphere. !! @@ -983,7 +1053,7 @@ subroutine MOM_generic_flux_init(verbosity) g_tracer=>g_tracer_list do - call g_tracer_flux_init(g_tracer) !, verbosity=verbosity) !### Add this after ocean shared is updated. + call g_tracer_flux_init(g_tracer, verbosity=verbosity) ! traverse the linked list till hit NULL call g_tracer_get_next(g_tracer, g_tracer_next) diff --git a/src/tracer/MOM_hor_bnd_diffusion.F90 b/src/tracer/MOM_hor_bnd_diffusion.F90 index 13e91e8973..b6714148ea 100644 --- a/src/tracer/MOM_hor_bnd_diffusion.F90 +++ b/src/tracer/MOM_hor_bnd_diffusion.F90 @@ -89,6 +89,7 @@ logical function hor_bnd_diffusion_init(Time, G, GV, US, param_file, diag, diaba ! local variables character(len=80) :: string ! Temporary strings logical :: boundary_extrap ! controls if boundary extrapolation is used in the HBD code + logical :: om4_remap_via_sub_cells ! Use the OM4-era ramap_via_sub_cells for HBD logical :: debug !< If true, write verbose checksums for debugging purposes if (ASSOCIATED(CS)) then @@ -142,10 +143,15 @@ logical function hor_bnd_diffusion_init(Time, G, GV, US, param_file, diag, diaba "for vertical remapping for all variables. "//& "It can be one of the following schemes: "//& trim(remappingSchemesDoc), default=remappingDefaultScheme) + call get_param(param_file, mdl, "HBD_REMAPPING_USE_OM4_SUBCELLS", om4_remap_via_sub_cells, & + "If true, use the OM4 remapping-via-subcells algorithm for horizontal boundary diffusion. "//& + "See REMAPPING_USE_OM4_SUBCELLS for details. "//& + "We recommend setting this option to false.", default=.true.) ! GMM, TODO: add HBD params to control optional arguments in initialize_remapping. - call initialize_remapping( CS%remap_CS, string, boundary_extrapolation = boundary_extrap ,& - check_reconstruction=.false., check_remapping=.false.) + call initialize_remapping( CS%remap_CS, string, boundary_extrapolation=boundary_extrap, & + om4_remap_via_sub_cells=om4_remap_via_sub_cells, & + check_reconstruction=.false., check_remapping=.false.) call extract_member_remapping_CS(CS%remap_CS, degree=CS%deg) call get_param(param_file, mdl, "DEBUG", debug, default=.false., do_not_log=.true.) call get_param(param_file, mdl, "HBD_DEBUG", CS%debug, & @@ -849,8 +855,9 @@ logical function near_boundary_unit_tests( verbose ) allocate(CS) ! fill required fields in CS CS%linear=.false. - call initialize_remapping( CS%remap_CS, 'PLM', boundary_extrapolation=.true. ,& - check_reconstruction=.true., check_remapping=.true.) + call initialize_remapping( CS%remap_CS, 'PLM', boundary_extrapolation=.true., & + om4_remap_via_sub_cells=.true., & ! ### see fail below when using fixed remapping alg. + check_reconstruction=.true., check_remapping=.true.) call extract_member_remapping_CS(CS%remap_CS, degree=CS%deg) CS%H_subroundoff = 1.0E-20 CS%debug=.false. @@ -1040,6 +1047,7 @@ logical function near_boundary_unit_tests( verbose ) call hbd_grid_test(SURFACE, hbl_L, hbl_R, h_L, h_R, CS) call fluxes_layer_method(SURFACE, nk, hbl_L, hbl_R, h_L, h_R, phi_L, phi_R, & khtr_u, F_layer, 1., 1., CS%hbd_u_kmax(1,1), CS%hbd_grd_u(1,1,:), CS) + ! ### This test fails when om4_remap_via_sub_cells=.false. near_boundary_unit_tests = near_boundary_unit_tests .or. & test_layer_fluxes( verbose, nk, test_name, F_layer, (/-1.0,-4.0/) ) diff --git a/src/tracer/MOM_neutral_diffusion.F90 b/src/tracer/MOM_neutral_diffusion.F90 index 402a008244..6b60769144 100644 --- a/src/tracer/MOM_neutral_diffusion.F90 +++ b/src/tracer/MOM_neutral_diffusion.F90 @@ -152,6 +152,7 @@ logical function neutral_diffusion_init(Time, G, GV, US, param_file, diag, EOS, logical :: debug ! If true, write verbose checksums for debugging purposes. logical :: boundary_extrap ! Indicate whether high-order boundary !! extrapolation should be used within boundary cells. + logical :: om4_remap_via_sub_cells ! If true, use the OM4 remapping algorithm if (associated(CS)) then call MOM_error(FATAL, "neutral_diffusion_init called with associated control structure.") @@ -232,8 +233,13 @@ logical function neutral_diffusion_init(Time, G, GV, US, param_file, diag, EOS, "that were in use at the end of 2018. Higher values result in the use of more "//& "robust and accurate forms of mathematically equivalent expressions.", & default=default_answer_date, do_not_log=.not.GV%Boussinesq) + call get_param(param_file, mdl, "NDIFF_REMAPPING_USE_OM4_SUBCELLS", om4_remap_via_sub_cells, & + "If true, use the OM4 remapping-via-subcells algorithm for neutral diffusion. "//& + "See REMAPPING_USE_OM4_SUBCELLS for more details. "//& + "We recommend setting this option to false.", default=.true.) if (.not.GV%Boussinesq) CS%remap_answer_date = max(CS%remap_answer_date, 20230701) call initialize_remapping( CS%remap_CS, string, boundary_extrapolation=boundary_extrap, & + om4_remap_via_sub_cells=om4_remap_via_sub_cells, & answer_date=CS%remap_answer_date ) call extract_member_remapping_CS(CS%remap_CS, degree=CS%deg) call get_param(param_file, mdl, "NEUTRAL_POS_METHOD", CS%neutral_pos_method, & diff --git a/src/tracer/MOM_tracer_Z_init.F90 b/src/tracer/MOM_tracer_Z_init.F90 index 2cf0ba1efe..c471b61717 100644 --- a/src/tracer/MOM_tracer_Z_init.F90 +++ b/src/tracer/MOM_tracer_Z_init.F90 @@ -464,11 +464,6 @@ subroutine read_Z_edges(filename, tr_name, z_edges, nz_out, has_edges, & end subroutine read_Z_edges -!### `find_overlap` and `find_limited_slope` were previously part of -! MOM_diag_to_Z.F90, and are nearly identical to `find_overlap` in -! `midas_vertmap.F90` with some slight differences. We keep it here for -! reproducibility, but the two should be merged at some point - !> Determines the layers bounded by interfaces e that overlap !! with the depth range between Z_top and Z_bot, and the fractional weights !! of each layer. It also calculates the normalized relative depths of the range @@ -620,15 +615,13 @@ subroutine determine_temperature(temp, salt, R_tgt, EOS, p_ref, niter, k_start, ! This include declares and sets the variable "version". # include "version_variable.h" character(len=40) :: mdl = "determine_temperature" ! This subroutine's name. - logical :: adjust_salt, fit_together + logical :: domore(SZK_(GV)) ! Records which layers need additional iterations + logical :: adjust_salt, fit_together, convergence_bug, do_any integer, dimension(2) :: EOSdom ! The i-computational domain for the equation of state integer :: i, j, k, is, ie, js, je, nz, itt is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke - ! ### The algorithms of determine_temperature subroutine needs to be reexamined. - - call log_version(PF, mdl, version, "") ! We should switch the default to the newer method which simultaneously adjusts @@ -638,7 +631,13 @@ subroutine determine_temperature(temp, salt, R_tgt, EOS, p_ref, niter, k_start, "based on the ratio of the thermal and haline coefficients. Otherwise try to "//& "match the density by only adjusting temperatures within a maximum range before "//& "revising estimates of the salinity.", default=.false., do_not_log=just_read) - ! These hard coded parameters need to be set properly. + call get_param(PF, mdl, "DETERMINE_TEMP_CONVERGENCE_BUG", convergence_bug, & + "If true, use layout-dependent tests on the changes in temperature and salinity "//& + "to determine when the iterations have converged when DETERMINE_TEMP_ADJUST_T_AND_S "//& + "is false. For realistic equations of state and the default values of the "//& + "various tolerances, this bug does not impact the solutions.", & + default=.true., do_not_log=just_read) !### Change the default to false. + call get_param(PF, mdl, "DETERMINE_TEMP_T_MIN", T_min, & "The minimum temperature that can be found by determine_temperature.", & units="degC", default=-2.0, scale=US%degC_to_C, do_not_log=just_read) @@ -653,10 +652,12 @@ subroutine determine_temperature(temp, salt, R_tgt, EOS, p_ref, niter, k_start, units="ppt", default=65.0, scale=US%ppt_to_S, do_not_log=just_read) call get_param(PF, mdl, "DETERMINE_TEMP_T_TOLERANCE", tol_T, & "The convergence tolerance for temperature in determine_temperature.", & - units="degC", default=1.0e-4, scale=US%degC_to_C, do_not_log=just_read) + units="degC", default=1.0e-4, scale=US%degC_to_C, & + do_not_log=just_read.or.(.not.convergence_bug)) call get_param(PF, mdl, "DETERMINE_TEMP_S_TOLERANCE", tol_S, & "The convergence tolerance for temperature in determine_temperature.", & - units="ppt", default=1.0e-4, scale=US%ppt_to_S, do_not_log=just_read) + units="ppt", default=1.0e-4, scale=US%ppt_to_S, & + do_not_log=just_read.or.(.not.convergence_bug)) call get_param(PF, mdl, "DETERMINE_TEMP_RHO_TOLERANCE", tol_rho, & "The convergence tolerance for density in determine_temperature.", & units="kg m-3", default=1.0e-4, scale=US%kg_m3_to_R, do_not_log=just_read) @@ -689,49 +690,69 @@ subroutine determine_temperature(temp, salt, R_tgt, EOS, p_ref, niter, k_start, T(:,:) = temp(:,j,:) S(:,:) = salt(:,j,:) dT(:,:) = 0.0 + domore(:) = .true. adjust_salt = .true. iter_loop: do itt = 1,niter - do k=1,nz + do k=k_start,nz ; if (domore(k)) then + domore(k) = .false. call calculate_density(T(:,k), S(:,k), press, rho(:,k), EOS, EOSdom ) call calculate_density_derivs(T(:,k), S(:,k), press, drho_dT(:,k), drho_dS(:,k), & EOS, EOSdom ) - enddo - do k=k_start,nz ; do i=is,ie -! if (abs(rho(i,k)-R_tgt(k))>tol_rho .and. abs(T(i,k)-land_fill) < epsln) then - if (abs(rho(i,k)-R_tgt(k))>tol_rho) then - if (.not.fit_together) then - dT(i,k) = max(min((R_tgt(k)-rho(i,k)) / drho_dT(i,k), max_t_adj), -max_t_adj) - T(i,k) = max(min(T(i,k)+dT(i,k), T_max), T_min) - else - I_denom = 1.0 / (drho_dS(i,k)**2 + dT_dS_gauge**2*drho_dT(i,k)**2) - dS(i,k) = (R_tgt(k)-rho(i,k)) * drho_dS(i,k) * I_denom - dT(i,k) = (R_tgt(k)-rho(i,k)) * dT_dS_gauge**2*drho_dT(i,k) * I_denom + do i=is,ie +! if (abs(rho(i,k)-R_tgt(k))>tol_rho .and. abs(T(i,k)-land_fill) < epsln) then + if (abs(rho(i,k)-R_tgt(k))>tol_rho) then + domore(k) = .true. + if (.not.fit_together) then + dT(i,k) = max(min((R_tgt(k)-rho(i,k)) / drho_dT(i,k), max_t_adj), -max_t_adj) + T(i,k) = max(min(T(i,k)+dT(i,k), T_max), T_min) + else + I_denom = 1.0 / (drho_dS(i,k)**2 + dT_dS_gauge**2*drho_dT(i,k)**2) + dS(i,k) = (R_tgt(k)-rho(i,k)) * drho_dS(i,k) * I_denom + dT(i,k) = (R_tgt(k)-rho(i,k)) * dT_dS_gauge**2*drho_dT(i,k) * I_denom - T(i,k) = max(min(T(i,k)+dT(i,k), T_max), T_min) - S(i,k) = max(min(S(i,k)+dS(i,k), S_max), S_min) + T(i,k) = max(min(T(i,k)+dT(i,k), T_max), T_min) + S(i,k) = max(min(S(i,k)+dS(i,k), S_max), S_min) + endif endif + enddo + endif ; enddo + if (convergence_bug) then + ! If this test does anything, it is layout-dependent. + if (maxval(abs(dT)) < tol_T) then + adjust_salt = .false. + exit iter_loop endif - enddo ; enddo - if (maxval(abs(dT)) < tol_T) then - adjust_salt = .false. - exit iter_loop endif + + do_any = .false. + do k=k_start,nz ; if (domore(k)) do_any = .true. ; enddo + if (.not.do_any) exit iter_loop ! Further iterations will not change anything. enddo iter_loop if (adjust_salt .and. .not.fit_together) then ; do itt = 1,niter - do k=1,nz + do k=k_start,nz ; if (domore(k)) then + domore(k) = .false. call calculate_density(T(:,k), S(:,k), press, rho(:,k), EOS, EOSdom ) call calculate_density_derivs(T(:,k), S(:,k), press, drho_dT(:,k), drho_dS(:,k), & EOS, EOSdom ) - enddo - do k=k_start,nz ; do i=is,ie -! if (abs(rho(i,k)-R_tgt(k))>tol_rho .and. abs(T(i,k)-land_fill) < epsln ) then - if (abs(rho(i,k)-R_tgt(k)) > tol_rho) then - dS(i,k) = max(min((R_tgt(k)-rho(i,k)) / drho_dS(i,k), max_s_adj), -max_s_adj) - S(i,k) = max(min(S(i,k)+dS(i,k), S_max), S_min) - endif - enddo ; enddo - if (maxval(abs(dS)) < tol_S) exit + do i=is,ie +! if (abs(rho(i,k)-R_tgt(k))>tol_rho .and. abs(T(i,k)-land_fill) < epsln ) then + if (abs(rho(i,k)-R_tgt(k)) > tol_rho) then + dS(i,k) = max(min((R_tgt(k)-rho(i,k)) / drho_dS(i,k), max_s_adj), -max_s_adj) + S(i,k) = max(min(S(i,k)+dS(i,k), S_max), S_min) + domore(k) = .true. + endif + enddo + endif ; enddo + + if (convergence_bug) then + ! If this test does anything, it is layout-dependent. + if (maxval(abs(dS)) < tol_S) exit + endif + + do_any = .false. + do k=k_start,nz ; if (domore(k)) do_any = .true. ; enddo + if (.not.do_any) exit ! Further iterations will not change anything enddo ; endif temp(:,j,:) = T(:,:) diff --git a/src/tracer/MOM_tracer_flow_control.F90 b/src/tracer/MOM_tracer_flow_control.F90 index ca85fc234f..2f1ebd2635 100644 --- a/src/tracer/MOM_tracer_flow_control.F90 +++ b/src/tracer/MOM_tracer_flow_control.F90 @@ -746,9 +746,10 @@ subroutine call_tracer_stocks(h, stock_values, G, GV, US, CS, stock_names, stock call store_stocks("MOM_generic_tracer", ns, names, units, values_EFP, index, stock_val_EFP, & set_pkg_name, max_ns, ns_tot, stock_names, stock_units) nn=ns_tot-ns+1 - nn=MOM_generic_tracer_min_max(nn, got_min_max, global_min, global_max, & - xgmin, ygmin, zgmin, xgmax, ygmax, zgmax ,& - G, CS%MOM_generic_tracer_CSp,names, units) + if (present(got_min_max) .and. present(global_min) .and. present(global_max)) & + nn = MOM_generic_tracer_min_max(nn, got_min_max, global_min, global_max, & + G, CS%MOM_generic_tracer_CSp, names, units, & + xgmin, ygmin, zgmin, xgmax, ygmax, zgmax) endif if (CS%use_pseudo_salt_tracer) then diff --git a/src/tracer/advection_test_tracer.F90 b/src/tracer/advection_test_tracer.F90 index d8eb4d57fb..567c706de0 100644 --- a/src/tracer/advection_test_tracer.F90 +++ b/src/tracer/advection_test_tracer.F90 @@ -329,7 +329,7 @@ subroutine advection_test_tracer_surface_state(sfc_state, h, G, GV, CS) ! This call loads the surface values into the appropriate array in the ! coupler-type structure. call set_coupler_type_data(CS%tr(:,:,1,m), CS%ind_tr(m), sfc_state%tr_fields, & - idim=(/isd, is, ie, ied/), jdim=(/jsd, js, je, jed/) ) + idim=(/isd, is, ie, ied/), jdim=(/jsd, js, je, jed/), turns=G%HI%turns) enddo endif diff --git a/src/tracer/boundary_impulse_tracer.F90 b/src/tracer/boundary_impulse_tracer.F90 index b8ed0632a2..0698d7f9cc 100644 --- a/src/tracer/boundary_impulse_tracer.F90 +++ b/src/tracer/boundary_impulse_tracer.F90 @@ -340,7 +340,7 @@ subroutine boundary_impulse_tracer_surface_state(sfc_state, h, G, GV, CS) ! This call loads the surface values into the appropriate array in the ! coupler-type structure. call set_coupler_type_data(CS%tr(:,:,1,m), CS%ind_tr(m), sfc_state%tr_fields, & - idim=(/isd, is, ie, ied/), jdim=(/jsd, js, je, jed/) ) + idim=(/isd, is, ie, ied/), jdim=(/jsd, js, je, jed/), turns=G%HI%turns) enddo endif diff --git a/src/tracer/dye_example.F90 b/src/tracer/dye_example.F90 index ff2199fc80..2cc4654691 100644 --- a/src/tracer/dye_example.F90 +++ b/src/tracer/dye_example.F90 @@ -395,7 +395,7 @@ subroutine dye_tracer_surface_state(sfc_state, h, G, GV, CS) ! This call loads the surface values into the appropriate array in the ! coupler-type structure. call set_coupler_type_data(CS%tr(:,:,1,m), CS%ind_tr(m), sfc_state%tr_fields, & - idim=(/isd, is, ie, ied/), jdim=(/jsd, js, je, jed/) ) + idim=(/isd, is, ie, ied/), jdim=(/jsd, js, je, jed/), turns=G%HI%turns) enddo endif diff --git a/src/tracer/ideal_age_example.F90 b/src/tracer/ideal_age_example.F90 index 4323479823..cd781169af 100644 --- a/src/tracer/ideal_age_example.F90 +++ b/src/tracer/ideal_age_example.F90 @@ -559,7 +559,7 @@ subroutine ideal_age_tracer_surface_state(sfc_state, h, G, GV, CS) ! This call loads the surface values into the appropriate array in the ! coupler-type structure. call set_coupler_type_data(CS%tr(:,:,1,m), CS%ind_tr(m), sfc_state%tr_fields, & - idim=(/isd, is, ie, ied/), jdim=(/jsd, js, je, jed/) ) + idim=(/isd, is, ie, ied/), jdim=(/jsd, js, je, jed/), turns=G%HI%turns) enddo endif diff --git a/src/tracer/oil_tracer.F90 b/src/tracer/oil_tracer.F90 index 22310b5802..1260711347 100644 --- a/src/tracer/oil_tracer.F90 +++ b/src/tracer/oil_tracer.F90 @@ -466,7 +466,7 @@ subroutine oil_tracer_surface_state(sfc_state, h, G, GV, CS) ! This call loads the surface values into the appropriate array in the ! coupler-type structure. call set_coupler_type_data(CS%tr(:,:,1,m), CS%ind_tr(m), sfc_state%tr_fields, & - idim=(/isd, is, ie, ied/), jdim=(/jsd, js, je, jed/) ) + idim=(/isd, is, ie, ied/), jdim=(/jsd, js, je, jed/), turns=G%HI%turns) enddo endif diff --git a/src/tracer/tracer_example.F90 b/src/tracer/tracer_example.F90 index fa9b978f9c..ff2812b8ee 100644 --- a/src/tracer/tracer_example.F90 +++ b/src/tracer/tracer_example.F90 @@ -427,7 +427,7 @@ subroutine USER_tracer_surface_state(sfc_state, h, G, GV, CS) ! This call loads the surface values into the appropriate array in the ! coupler-type structure. call set_coupler_type_data(CS%tr(:,:,1,m), CS%ind_tr(m), sfc_state%tr_fields, & - idim=(/isd, is, ie, ied/), jdim=(/jsd, js, je, jed/) ) + idim=(/isd, is, ie, ied/), jdim=(/jsd, js, je, jed/), turns=G%HI%turns) enddo endif