kappa_shear_vertex_kernel Subroutine

   pure subroutine kappa_shear_vertex_kernel(this, nx, ny, nz, dt, h_layer, &
                                             u_face, v_face, hT, hS, &
                                             wet_t, wet_u, wet_v)
      !! Per-CORNER JHL08 solve (MOM6 vertex form, Pass B).  One
      !! `do concurrent (jc, ic)` over the interior corners
      !! [2,nx]x[2,ny] — the set whose full 2x2 cell patch exists
      !! in-array, which covers every corner any owned tracer cell
      !! needs (nghost >= 1).  Ring corners stay 0.
      !!
      !! Per corner: activity test = ANY adjacent velocity face open
      !! (NOT the 4-cell corner mask — a coastline corner with 1-3 wet
      !! cells IS solved, from the mask-weighted average of the wet
      !! cells); gather (`ks_gather_corner`); non-finite guard (an
      !! unfilled OBC ghost corner must yield kd=0, not a laundered
      !! clamp value); floor-or-merge exactly as the column path; the
      !! SAME shared column solve (`ks_precompute` + `ks_solve_column`);
      !! scatter into `kd_corner` with the surface-down -> bottom-up
      !! flip.  f^2 is taken straight at the corner (no averaging).
      type(ocean_kappa_shear_t), intent(inout) :: this
      integer, intent(in) :: nx, ny, nz
      real(wp), intent(in) :: dt
      real(wp), intent(in) :: h_layer(nx, ny, nz)
      real(wp), intent(in) :: u_face(nx + 1, ny, nz)
      real(wp), intent(in) :: v_face(nx, ny + 1, nz)
      real(wp), intent(in) :: hT(nx, ny, nz)
      real(wp), intent(in) :: hS(nx, ny, nz)
      real(wp), intent(in) :: wet_t(nx, ny)
      real(wp), intent(in) :: wet_u(nx + 1, ny)
      real(wp), intent(in) :: wet_v(nx, ny + 1)

      integer :: ic, jc, k, kg, nzc
      real(wp) :: f2_val
      logical :: merge_on, do_merge, col_ok
      ! gathered surface-down corner column
      real(wp) :: h_sd(NZL), u_sd(NZL), v_sd(NZL), t_sd(NZL), s_sd(NZL)
      ! precomputed interface/layer grids
      real(wp) :: idz_s(NZL), idz_int_s(NZLI), hint_s(NZLI), il2_s(NZLI)
      real(wp) :: kappa_avg_sd(NZLI), tke_avg_sd(NZLI)
      ! D4 massless-merge per-column scratch (same set as the column kernel)
      real(wp) :: hc(NZL), uc(NZL), vc(NZL), tc(NZL), sc(NZL)
      real(wp) :: kappa_c(NZLI), tke_c(NZLI), kf(NZL + 1)
      integer :: kc(NZL + 1)

      merge_on = this%massless_merge

      do concurrent(jc=2:ny, ic=2:nx) &
         local(k, kg, nzc, f2_val, do_merge, col_ok, &
               h_sd, u_sd, v_sd, t_sd, s_sd, &
               idz_s, idz_int_s, hint_s, il2_s, &
               kappa_avg_sd, tke_avg_sd, &
               hc, uc, vc, tc, sc, kappa_c, tke_c, kc, kf)

         ! ---- Default outputs (kept for inactive / non-finite corners) ----
         do k = 1, nz + 1
            kappa_avg_sd(k) = 0.0_wp
            tke_avg_sd(k) = 0.0_wp
         end do

         ! ---- Activity test: any adjacent velocity face open ----
         if ((wet_u(ic, jc - 1) + wet_u(ic, jc)) + &
             (wet_v(ic - 1, jc) + wet_v(ic, jc)) > 0.0_wp) then

            call ks_gather_corner(nx, ny, nz, ic, jc, h_layer, u_face, &
                                  v_face, hT, hS, wet_t, wet_u, wet_v, &
                                  h_sd, u_sd, v_sd, t_sd, s_sd)

            ! ---- Non-finite guard (OBC ghost-corner armour).  max()
            ! and comparisons LAUNDER/skip NaN under relaxed FP, so an
            ! explicit finite check is the only reliable gate; a corrupt
            ! gather yields kd=0 for this corner, never a plausible
            ! laundered value. ----
            col_ok = .true.
            do k = 1, nz
               if (.not. (ieee_is_finite(h_sd(k)) .and. &
                          ieee_is_finite(u_sd(k)) .and. &
                          ieee_is_finite(v_sd(k)) .and. &
                          ieee_is_finite(t_sd(k)) .and. &
                          ieee_is_finite(s_sd(k)))) col_ok = .false.
            end do

            if (col_ok) then
               ! ---- I1 precheck: merge only when the knob is on AND the
               ! corner column actually carries a vanished layer.
               do_merge = .false.
               if (merge_on) then
                  do k = 1, nz
                     if (h_sd(k) < H_VANISHED) then
                        do_merge = .true.
                        exit
                     end if
                  end do
               end if

               ! f^2 straight at the corner — f is natively a corner
               ! quantity on the C-grid (signed; square it).
               f2_val = this%f_corner(ic, jc)*this%f_corner(ic, jc)

               if (do_merge) then
                  call massless_build_maps(h_sd, nz, H_VANISHED, nzc, hc, kc, kf)
                  call massless_merge_fields(h_sd, kc, nz, nzc, &
                                             u_sd, v_sd, t_sd, s_sd, &
                                             uc, vc, tc, sc)
                  call ks_precompute(nzc, this%lz_rescale, hc, &
                                     idz_s, idz_int_s, hint_s, il2_s)
                  call ks_solve_column(nzc, dt, f2_val, this%rho0, &
                                       this%ri_crit, this%shearmix_rate, &
                                       this%fri_curvature, this%c_n, this%c_s, &
                                       this%lambda, this%kappa_0, this%kappa_seed, &
                                       this%kappa_trunc, this%tke_bg, this%tol_err, &
                                       this%max_inner_it, this%max_substep_it, &
                                       this%src_max_chg, this%vel_underflow, &
                                       this%eos, &
                                       hc, uc, vc, tc, sc, &
                                       idz_s, idz_int_s, hint_s, il2_s, &
                                       kappa_c, tke_c)
                  call massless_interp_back(kappa_c, kc, kf, nz, kappa_avg_sd)
                  call massless_interp_back(tke_c, kc, kf, nz, tke_avg_sd)
               else
                  ! Blunt gather floor at H_VANISHED, solve on nz —
                  ! mirrors the column path (T,S need no back-out: the
                  ! gather already returns layer values).
                  do k = 1, nz
                     h_sd(k) = max(h_sd(k), H_VANISHED)
                  end do
                  call ks_precompute(nz, this%lz_rescale, h_sd, &
                                     idz_s, idz_int_s, hint_s, il2_s)
                  call ks_solve_column(nz, dt, f2_val, this%rho0, &
                                       this%ri_crit, this%shearmix_rate, &
                                       this%fri_curvature, this%c_n, this%c_s, &
                                       this%lambda, this%kappa_0, this%kappa_seed, &
                                       this%kappa_trunc, this%tke_bg, this%tol_err, &
                                       this%max_inner_it, this%max_substep_it, &
                                       this%src_max_chg, this%vel_underflow, &
                                       this%eos, &
                                       h_sd, u_sd, v_sd, t_sd, s_sd, &
                                       idz_s, idz_int_s, hint_s, il2_s, &
                                       kappa_avg_sd, tke_avg_sd)
               end if
            end if
         end if

         ! ---- Scatter with the flip; force exact 0 at bed + surface.
         ! No mask multiply here (the non-bug store): land is handled by
         ! the activity test, and Pass C masks the tracer-point output. ----
         do k = 1, nz + 1
            kg = nz + 2 - k
            this%kd_corner(ic, jc, kg) = kappa_avg_sd(k)
         end do
         this%kd_corner(ic, jc, 1) = 0.0_wp
         this%kd_corner(ic, jc, nz + 1) = 0.0_wp
      end do
   end subroutine kappa_shear_vertex_kernel