ice_adjust_categories_impl Subroutine

private pure subroutine ice_adjust_categories_impl(wet_mask, part_size, m_ice, m_snow, enth_ice, enth_snow, sal_ice, mh_lim, nghost, ncat, nk, nx, ny)

Device kernel: ONE do concurrent(j, i) over PHYSICAL cells (ghosts excluded), wet_mask > 0.5 inner gate (never a masked DC header), serial cat loops inside — each cell touches only its own (i, j, :) slice, race-free. No per-cell gather into local category-sized arrays (avoids register pressure and any compile-time ncat cap, unlike the ICE_NK_MAX-capped PER-LAYER arrays elsewhere in the ice model) — scalar temporaries only, all declared in local(...).

Decl-order: all integer dims declared before the explicit-shape arrays that use them. No locals named after intrinsics.

Arguments

Type IntentOptional Attributes Name
real(kind=wp), intent(in) :: wet_mask(nx,ny)
real(kind=wp), intent(inout) :: part_size(nx,ny,0:ncat)
real(kind=wp), intent(inout) :: m_ice(nx,ny,ncat)
real(kind=wp), intent(inout) :: m_snow(nx,ny,ncat)
real(kind=wp), intent(inout) :: enth_ice(nx,ny,ncat,nk)
real(kind=wp), intent(inout) :: enth_snow(nx,ny,ncat,1)
real(kind=wp), intent(inout) :: sal_ice(nx,ny,ncat,nk)
real(kind=wp), intent(in) :: mh_lim(ncat+1)
integer, intent(in) :: nghost

Grid + category + layer extents (declared first — decl-order).
integer, intent(in) :: ncat

Grid + category + layer extents (declared first — decl-order).
integer, intent(in) :: nk

Grid + category + layer extents (declared first — decl-order).
integer, intent(in) :: nx

Grid + category + layer extents (declared first — decl-order).
integer, intent(in) :: ny

Grid + category + layer extents (declared first — decl-order).

Calls

proc~~ice_adjust_categories_impl~~CallsGraph proc~ice_adjust_categories_impl ice_adjust_categories_impl local local proc~ice_adjust_categories_impl->local

Called by

proc~~ice_adjust_categories_impl~~CalledByGraph proc~ice_adjust_categories_impl ice_adjust_categories_impl proc~ice_adjust_categories ice_adjust_categories proc~ice_adjust_categories->proc~ice_adjust_categories_impl proc~engine_step_ice engine_step_ice proc~engine_step_ice->proc~ice_adjust_categories proc~ice_transport_step ice_transport_step proc~engine_step_ice->proc~ice_transport_step proc~ice_transport_step->proc~ice_adjust_categories proc~driver_run_ocean driver_run_ocean proc~driver_run_ocean->proc~engine_step_ice proc~rdb_ocean_step rdb_ocean_step proc~rdb_ocean_step->proc~engine_step_ice proc~driver_run driver_run proc~driver_run->proc~driver_run_ocean

Variables

Type Visibility Attributes Name Initial
integer, private :: cat
integer, private :: i
integer, private :: i_hi
integer, private :: i_lo
integer, private :: j
integer, private :: j_hi
integer, private :: j_lo
integer, private :: lay
real(kind=wp), private :: mca_ice_dst
real(kind=wp), private :: mca_ice_src
real(kind=wp), private :: mca_snow_dst
real(kind=wp), private :: mca_snow_src
real(kind=wp), private :: mnew
real(kind=wp), private :: msnew
real(kind=wp), private :: part_sum
real(kind=wp), private :: part_trans
logical, private :: resum

Source Code

   pure subroutine ice_adjust_categories_impl(wet_mask, part_size, m_ice, m_snow, &
                                              enth_ice, enth_snow, sal_ice, mh_lim, &
                                              nghost, ncat, nk, nx, ny)
      !! Device kernel: ONE `do concurrent(j, i)` over PHYSICAL cells
      !! (ghosts excluded), `wet_mask > 0.5` inner gate (never a masked DC
      !! header), serial `cat` loops inside — each cell touches only its
      !! own `(i, j, :)` slice, race-free. No per-cell gather into local
      !! category-sized arrays (avoids register pressure and any
      !! compile-time `ncat` cap, unlike the `ICE_NK_MAX`-capped
      !! PER-LAYER arrays elsewhere in the ice model) — scalar
      !! temporaries only, all declared in `local(...)`.
      !!
      !! Decl-order: all integer dims declared before the explicit-shape
      !! arrays that use them. No locals named after intrinsics.
      integer, intent(in) :: nghost, ncat, nk, nx, ny
         !! Grid + category + layer extents (declared first — decl-order).
      real(wp), intent(in) :: wet_mask(nx, ny)
      real(wp), intent(inout) :: part_size(nx, ny, 0:ncat)
      real(wp), intent(inout) :: m_ice(nx, ny, ncat)
      real(wp), intent(inout) :: m_snow(nx, ny, ncat)
      real(wp), intent(inout) :: enth_ice(nx, ny, ncat, nk)
      real(wp), intent(inout) :: enth_snow(nx, ny, ncat, 1)
      real(wp), intent(inout) :: sal_ice(nx, ny, ncat, nk)
      real(wp), intent(in) :: mh_lim(ncat + 1)

      integer :: i, j, i_lo, i_hi, j_lo, j_hi
      integer :: cat, lay
      logical :: resum
      real(wp) :: part_trans, part_sum
      real(wp) :: mca_ice_src, mca_ice_dst, mca_snow_src, mca_snow_dst, mnew, msnew

      i_lo = nghost + 1
      i_hi = nx - nghost
      j_lo = nghost + 1
      j_hi = ny - nghost

      do concurrent(j=j_lo:j_hi, i=i_lo:i_hi) local(cat, lay, resum, part_trans, part_sum, &
                                                    mca_ice_src, mca_ice_dst, mca_snow_src, &
                                                    mca_snow_dst, mnew, msnew)
         if (wet_mask(i, j) > 0.5_wp) then
            resum = .false.

            ! ---- 1. Massless cleanup (SIS2:664-685) ----
            do cat = 1, ncat
               if (m_ice(i, j, cat) <= 0.0_wp) then
                  if (part_size(i, j, cat) > 0.0_wp) resum = .true.
                  part_size(i, j, cat) = 0.0_wp
               end if
            end do

            ! ---- 2. Upward pass, c = 1..ncat-1 ascending (SIS2:714-767) ----
            do cat = 1, ncat - 1
               if (part_size(i, j, cat)*m_ice(i, j, cat) > 0.0_wp .and. &
                   m_ice(i, j, cat) > mh_lim(cat + 1)) then
                  part_trans = part_size(i, j, cat)
                  mca_snow_src = part_size(i, j, cat)*m_snow(i, j, cat)
                  mca_snow_dst = part_size(i, j, cat + 1)*m_snow(i, j, cat + 1)
                  mca_ice_src = part_trans*m_ice(i, j, cat)
                  mca_ice_dst = part_size(i, j, cat + 1)*m_ice(i, j, cat + 1)

                  m_ice(i, j, cat + 1) = (part_trans*m_ice(i, j, cat) &
                                          + part_size(i, j, cat + 1)*m_ice(i, j, cat + 1)) &
                                         /(part_trans + part_size(i, j, cat + 1))
                  m_ice(i, j, cat) = mh_lim(cat + 1)
                  part_size(i, j, cat + 1) = part_size(i, j, cat + 1) + part_trans
                  part_size(i, j, cat) = part_size(i, j, cat) - part_trans

                  m_snow(i, j, cat) = 0.0_wp
                  if (part_size(i, j, cat + 1) > 0.0_wp) then
                     m_snow(i, j, cat + 1) = (mca_snow_src + mca_snow_dst)/part_size(i, j, cat + 1)
                  else
                     m_snow(i, j, cat + 1) = 0.0_wp
                  end if

                  mnew = mca_ice_src + mca_ice_dst
                  if (mca_ice_src > 0.0_wp .and. mnew > 0.0_wp) then
                     do lay = 1, nk
                        enth_ice(i, j, cat + 1, lay) = (mca_ice_src*enth_ice(i, j, cat, lay) &
                                                        + mca_ice_dst*enth_ice(i, j, cat + 1, lay)) &
                                                       /mnew
                        sal_ice(i, j, cat + 1, lay) = (mca_ice_src*sal_ice(i, j, cat, lay) &
                                                       + mca_ice_dst*sal_ice(i, j, cat + 1, lay)) &
                                                      /mnew
                     end do
                  end if
                  msnew = mca_snow_src + mca_snow_dst
                  if (mca_snow_src > 0.0_wp .and. msnew > 0.0_wp) then
                     enth_snow(i, j, cat + 1, 1) = (mca_snow_src*enth_snow(i, j, cat, 1) &
                                                    + mca_snow_dst*enth_snow(i, j, cat + 1, 1)) &
                                                   /msnew
                  end if
               end if
            end do

            ! ---- 3. Downward pass, c = ncat..2 descending (SIS2:786-839) ----
            do cat = ncat, 2, -1
               if (part_size(i, j, cat)*m_ice(i, j, cat) > 0.0_wp .and. &
                   m_ice(i, j, cat) < mh_lim(cat)) then
                  part_trans = part_size(i, j, cat)
                  mca_snow_src = part_size(i, j, cat)*m_snow(i, j, cat)
                  mca_snow_dst = part_size(i, j, cat - 1)*m_snow(i, j, cat - 1)
                  mca_ice_src = part_trans*m_ice(i, j, cat)
                  mca_ice_dst = part_size(i, j, cat - 1)*m_ice(i, j, cat - 1)

                  m_ice(i, j, cat - 1) = (part_trans*m_ice(i, j, cat) &
                                          + part_size(i, j, cat - 1)*m_ice(i, j, cat - 1)) &
                                         /(part_trans + part_size(i, j, cat - 1))
                  m_ice(i, j, cat) = mh_lim(cat)
                  part_size(i, j, cat - 1) = part_size(i, j, cat - 1) + part_trans
                  part_size(i, j, cat) = part_size(i, j, cat) - part_trans

                  m_snow(i, j, cat) = 0.0_wp
                  if (part_size(i, j, cat - 1) > 0.0_wp) then
                     m_snow(i, j, cat - 1) = (mca_snow_src + mca_snow_dst)/part_size(i, j, cat - 1)
                  else
                     m_snow(i, j, cat - 1) = 0.0_wp
                  end if

                  mnew = mca_ice_src + mca_ice_dst
                  if (mca_ice_src > 0.0_wp .and. mnew > 0.0_wp) then
                     do lay = 1, nk
                        enth_ice(i, j, cat - 1, lay) = (mca_ice_src*enth_ice(i, j, cat, lay) &
                                                        + mca_ice_dst*enth_ice(i, j, cat - 1, lay)) &
                                                       /mnew
                        sal_ice(i, j, cat - 1, lay) = (mca_ice_src*sal_ice(i, j, cat, lay) &
                                                       + mca_ice_dst*sal_ice(i, j, cat - 1, lay)) &
                                                      /mnew
                     end do
                  end if
                  msnew = mca_snow_src + mca_snow_dst
                  if (mca_snow_src > 0.0_wp .and. msnew > 0.0_wp) then
                     enth_snow(i, j, cat - 1, 1) = (mca_snow_src*enth_snow(i, j, cat, 1) &
                                                    + mca_snow_dst*enth_snow(i, j, cat - 1, 1)) &
                                                   /msnew
                  end if
               end if
            end do

            ! ---- 4. Cat-1 minimum-thickness compress (SIS2:850-864) ----
            if (mh_lim(1) > 0.0_wp) then
               if (m_ice(i, j, 1)*part_size(i, j, 1) > 0.0_wp .and. m_ice(i, j, 1) < mh_lim(1)) then
                  part_size(i, j, 1) = part_size(i, j, 1)*(m_ice(i, j, 1)/mh_lim(1))
                  if (m_ice(i, j, 1) > 0.0_wp) then
                     m_snow(i, j, 1) = m_snow(i, j, 1)*(mh_lim(1)/m_ice(i, j, 1))
                  end if
                  m_ice(i, j, 1) = mh_lim(1)
                  resum = .true.
               end if
            end if

            ! ---- 5. Open-water resum (SIS2:874-889) ----
            if (resum) then
               part_sum = 0.0_wp
               do cat = 1, ncat
                  part_sum = part_sum + part_size(i, j, cat)
               end do
               part_size(i, j, 0) = max(1.0_wp - part_sum, 0.0_wp)
            end if
         end if
      end do
   end subroutine ice_adjust_categories_impl