remap_column_plm Subroutine

public pure subroutine remap_column_plm(nz, dz_old, dz_new, q_old, q_new, bnd_extrap, nonunif)

Piecewise-linear (minmod-limited) remap. Monotone (no new extrema). Per old layer k: q_hat(xi) = q(k) + slope(k)(2xi - 1), xi in [0,1], slope(k) = 0.5*minmod(q(k+1)-q(k), q(k)-q(k-1)). bnd_extrap (absent/.false. = default) closes the boundary cells with boundary_half_jump instead of the PCM flatten — see remap_column. nonunif (absent/.false. = default) replaces the minmod half-difference — which assumes EQUAL source thicknesses — with the thickness-weighted CW84 (1.7)/(1.8) slope; see plm_slope_nonuniform.

Arguments

Type IntentOptional Attributes Name
integer, intent(in) :: nz
real(kind=wp), intent(in) :: dz_old(nz)

Old layer thicknesses

real(kind=wp), intent(in) :: dz_new(nz)

New layer thicknesses

real(kind=wp), intent(in) :: q_old(nz)

Old cell-average scalar values

real(kind=wp), intent(out) :: q_new(nz)

New cell-average scalar values (conservative)

logical, intent(in), optional :: bnd_extrap

Linear-exact boundary-cell closure (MOM6 BOUNDARY_EXTRAPOLATION).

logical, intent(in), optional :: nonunif

Non-uniform-grid slope weights (CW84 1.7/1.8).


Calls

proc~~remap_column_plm~~CallsGraph proc~remap_column_plm remap_column_plm proc~boundary_half_jump boundary_half_jump proc~remap_column_plm->proc~boundary_half_jump proc~plm_slope_nonuniform plm_slope_nonuniform proc~remap_column_plm->proc~plm_slope_nonuniform

Called by

proc~~remap_column_plm~~CalledByGraph proc~remap_column_plm remap_column_plm proc~remap_column remap_column proc~remap_column->proc~remap_column_plm proc~remap_column_ppm remap_column_ppm proc~remap_column->proc~remap_column_ppm proc~remap_column_ppm_h4 remap_column_ppm_h4 proc~remap_column->proc~remap_column_ppm_h4 proc~remap_column_pqm remap_column_pqm proc~remap_column->proc~remap_column_pqm proc~remap_column_ppm->proc~remap_column_plm proc~remap_column_ppm_h4->proc~remap_column_plm proc~ocean_remap_tracer_column ocean_remap_tracer_column proc~ocean_remap_tracer_column->proc~remap_column proc~ocean_remap_tracer_field ocean_remap_tracer_field proc~ocean_remap_tracer_field->proc~remap_column proc~remap_column_pqm->proc~remap_column_ppm proc~remap_layer_to_density_impl remap_layer_to_density_impl proc~remap_layer_to_density_impl->proc~remap_column proc~remap_layer_to_vcoord_impl remap_layer_to_vcoord_impl proc~remap_layer_to_vcoord_impl->proc~remap_column proc~remap_tracer_grounded remap_tracer_grounded proc~remap_tracer_grounded->proc~remap_column proc~remap_x_face_grounded remap_x_face_grounded proc~remap_x_face_grounded->proc~remap_column proc~remap_x_face_velocity remap_x_face_velocity proc~remap_x_face_velocity->proc~remap_column proc~remap_y_face_grounded remap_y_face_grounded proc~remap_y_face_grounded->proc~remap_column proc~remap_y_face_velocity remap_y_face_velocity proc~remap_y_face_velocity->proc~remap_column proc~ocean_apply_ale_remap_centres ocean_apply_ale_remap_centres proc~ocean_apply_ale_remap_centres->proc~ocean_remap_tracer_field proc~ocean_apply_ale_remap_faces ocean_apply_ale_remap_faces proc~ocean_apply_ale_remap_faces->proc~remap_x_face_velocity proc~ocean_apply_ale_remap_faces->proc~remap_y_face_velocity proc~ocean_apply_ale_remap_step ocean_apply_ale_remap_step proc~ocean_apply_ale_remap_step->proc~ocean_remap_tracer_field proc~ocean_apply_ale_remap_step->proc~remap_x_face_velocity proc~ocean_apply_ale_remap_step->proc~remap_y_face_velocity proc~ocean_apply_conservative_min_thickness ocean_apply_conservative_min_thickness proc~ocean_apply_conservative_min_thickness->proc~remap_tracer_grounded proc~ocean_apply_conservative_min_thickness->proc~remap_x_face_grounded proc~ocean_apply_conservative_min_thickness->proc~remap_y_face_grounded proc~remap_layer_to_density remap_layer_to_density proc~remap_layer_to_density->proc~remap_layer_to_density_impl proc~remap_layer_to_sigma remap_layer_to_sigma proc~remap_layer_to_sigma->proc~remap_layer_to_vcoord_impl proc~remap_layer_to_z remap_layer_to_z proc~remap_layer_to_z->proc~remap_layer_to_vcoord_impl proc~remap_layer_to_zstar remap_layer_to_zstar proc~remap_layer_to_zstar->proc~remap_layer_to_vcoord_impl proc~ocean_dyn_step_split ocean_dyn_step_split proc~ocean_dyn_step_split->proc~ocean_apply_ale_remap_step proc~run_continuity_chain run_continuity_chain proc~run_continuity_chain->proc~ocean_apply_conservative_min_thickness proc~engine_step engine_step proc~engine_step->proc~ocean_dyn_step_split proc~run_stage_split run_stage_split proc~run_stage_split->proc~run_continuity_chain

Variables

Type Visibility Attributes Name Initial
real(kind=wp), private :: dq_l
real(kind=wp), private :: dq_r
real(kind=wp), private :: integral
integer, private :: k
integer, private :: ko
integer, private :: ko_start
logical, private :: nu
real(kind=wp), private :: overlap
real(kind=wp), private :: slope(NZ_STACK_MAX)
real(kind=wp), private :: xi_hi
real(kind=wp), private :: xi_lo
real(kind=wp), private :: z_hi
real(kind=wp), private :: z_lo
real(kind=wp), private :: z_new(0:NZ_STACK_MAX)
real(kind=wp), private :: z_old(0:NZ_STACK_MAX)

Source Code

   pure subroutine remap_column_plm(nz, dz_old, dz_new, q_old, q_new, bnd_extrap, nonunif)
      !$acc routine seq
      !! Piecewise-linear (minmod-limited) remap. Monotone (no new extrema).
      !! Per old layer k: q_hat(xi) = q(k) + slope(k)*(2*xi - 1), xi in [0,1],
      !! slope(k) = 0.5*minmod(q(k+1)-q(k), q(k)-q(k-1)).
      !! `bnd_extrap` (absent/.false. = default) closes the boundary cells
      !! with `boundary_half_jump` instead of the PCM flatten — see
      !! `remap_column`.  `nonunif` (absent/.false. = default) replaces the
      !! minmod half-difference — which assumes EQUAL source thicknesses —
      !! with the thickness-weighted CW84 (1.7)/(1.8) slope; see
      !! `plm_slope_nonuniform`.
      integer, intent(in) :: nz
      real(wp), intent(in) :: dz_old(nz)
         !! Old layer thicknesses
      real(wp), intent(in) :: dz_new(nz)
         !! New layer thicknesses
      real(wp), intent(in) :: q_old(nz)
         !! Old cell-average scalar values
      real(wp), intent(out) :: q_new(nz)
         !! New cell-average scalar values (conservative)
      logical, intent(in), optional :: bnd_extrap
         !! Linear-exact boundary-cell closure (MOM6 BOUNDARY_EXTRAPOLATION).
      logical, intent(in), optional :: nonunif
         !! Non-uniform-grid slope weights (CW84 1.7/1.8).

      real(wp) :: z_old(0:NZ_STACK_MAX), z_new(0:NZ_STACK_MAX)
      real(wp) :: slope(NZ_STACK_MAX)
      real(wp) :: z_lo, z_hi, overlap, integral
      real(wp) :: xi_lo, xi_hi, dq_l, dq_r
      logical :: nu
      integer :: k, ko, ko_start

      nu = .false.
      if (present(nonunif)) nu = nonunif

      ! Single-layer case: identity remap
      if (nz == 1) then
         q_new(1) = q_old(1)
         return
      end if

      ! Build interface positions
      z_old(0) = 0.0_wp
      z_new(0) = 0.0_wp
      do k = 1, nz
         z_old(k) = z_old(k - 1) + dz_old(k)
         z_new(k) = z_new(k - 1) + dz_new(k)
      end do

      ! Compute minmod-limited slopes
      ! slope(k) = half the limited difference across the layer
      slope(1) = 0.0_wp
      if (nu) then
         do k = 2, nz - 1
            call plm_slope_nonuniform(dz_old(k - 1), dz_old(k), dz_old(k + 1), &
                                      q_old(k - 1), q_old(k), q_old(k + 1), slope(k))
         end do
      else
         do k = 2, nz - 1
            dq_l = q_old(k) - q_old(k - 1)
            dq_r = q_old(k + 1) - q_old(k)
            if (dq_l*dq_r > 0.0_wp) then
               slope(k) = 0.5_wp*sign(min(abs(dq_l), abs(dq_r)), dq_l)
            else
               slope(k) = 0.0_wp
            end if
         end do
      end if
      slope(nz) = 0.0_wp
      ! Boundary cells: PCM flatten by default; the linear-exact one-sided
      ! half-jump when boundary extrapolation is requested.
      if (present(bnd_extrap)) then
         if (bnd_extrap) then
            call boundary_half_jump(dz_old(1), dz_old(2), q_old(2) - q_old(1), slope(1))
            call boundary_half_jump(dz_old(nz), dz_old(nz - 1), &
                                    q_old(nz) - q_old(nz - 1), slope(nz))
         end if
      end if

      ! Sweep: for each new layer, integrate PLM from old layers
      ko_start = 1
      do k = 1, nz
         if (dz_new(k) <= 0.0_wp) then
            q_new(k) = 0.0_wp
            cycle
         end if

         integral = 0.0_wp
         do ko = ko_start, nz
            z_lo = max(z_new(k - 1), z_old(ko - 1))
            z_hi = min(z_new(k), z_old(ko))
            overlap = z_hi - z_lo

            if (overlap <= 0.0_wp) then
               if (z_old(ko) > z_new(k)) exit
               cycle
            end if

            if (dz_old(ko) > 0.0_wp) then
               ! Normalised coordinates within old layer ko
               xi_lo = (z_lo - z_old(ko - 1))/dz_old(ko)
               xi_hi = (z_hi - z_old(ko - 1))/dz_old(ko)

               ! Integral of q_hat(xi) = q + slope*(2*xi - 1) over [xi_lo, xi_hi]
               ! = (xi_hi - xi_lo) * (q + slope*(xi_hi + xi_lo - 1))
               ! scaled to physical space: * dz_old(ko)
               integral = integral + overlap* &
                          (q_old(ko) + slope(ko)*(xi_lo + xi_hi - 1.0_wp))
            else
               integral = integral + q_old(ko)*overlap
            end if

            if (z_old(ko) <= z_new(k)) ko_start = ko
         end do

         q_new(k) = integral/dz_new(k)
      end do
   end subroutine remap_column_plm