scratch_registry.f90

Go to the documentation of this file.

! Copyright (c) 2025-2026, The Neko Authors
! All rights reserved.
!
! Redistribution and use in source and binary forms, with or without
! modification, are permitted provided that the following conditions
! are met:
!
!   * Redistributions of source code must retain the above copyright
!     notice, this list of conditions and the following disclaimer.
!
!   * Redistributions in binary form must reproduce the above
!     copyright notice, this list of conditions and the following
!     disclaimer in the documentation and/or other materials provided
!     with the distribution.
!
!   * Neither the name of the authors nor the names of its
!     contributors may be used to endorse or promote products derived
!     from this software without specific prior written permission.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
! "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
! LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
! FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
! COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
! INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
! BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
! LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
! CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
! LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
! ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
! POSSIBILITY OF SUCH DAMAGE.
!
module scratch_registry
  use num_types, only : rp
  use registry_entry, only : registry_entry_t
  use host_array, only : host_array_t
  use device_array, only : device_array_t
  use field, only : field_t
  use vector, only : vector_t
  use matrix, only : matrix_t
  use tensor3, only : tensor3_t
  use tensor4, only : tensor4_t
 
  use math, only : rzero
  use device_math, only : device_rzero
  use field_math, only : field_rzero
  use vector_math, only : vector_rzero
  use matrix_math, only : matrix_rzero
 
  use dofmap, only : dofmap_t
  use utils, only : neko_error
  use neko_config, only : neko_bcknd_device
  use, intrinsic :: iso_c_binding, only : c_ptr
  implicit none
  private
 
  type, public :: scratch_registry_t
     type(registry_entry_t), private, allocatable :: entries(:)
     logical, private, allocatable :: inuse(:)
     integer, private :: n_entries = 0
     integer, private :: expansion_size = 10
     type(dofmap_t), private, pointer :: dof => null()
   contains
 
     ! ----------------------------------------------------------------------- !
     ! Public generic procedures for the scratch registry
 
     procedure, pass(this) :: init => scratch_registry_init
     procedure, pass(this) :: free => scratch_registry_free
 
     procedure, pass(this) :: set_dofmap => scratch_registry_set_dofmap
     procedure, pass(this) :: set_expansion_size => &
          scratch_registry_set_expansion_size
 
     procedure, pass(this) :: get_n_entries
     procedure, pass(this) :: get_n_inuse
     procedure, pass(this) :: get_expansion_size
     procedure, pass(this) :: get_size
     procedure, pass(this) :: get_inuse
 
     ! ----------------------------------------------------------------------- !
     ! Type specific procedures for the scratch registry
 
     procedure, pass(this) :: request_host_array
     procedure, pass(this) :: relinquish_host_array_single
     procedure, pass(this) :: relinquish_host_array_multiple
     generic :: relinquish_host_array => relinquish_host_array_single, &
          relinquish_host_array_multiple
 
     procedure, pass(this) :: request_device_array
     procedure, pass(this) :: relinquish_device_array_single
     procedure, pass(this) :: relinquish_device_array_multiple
     generic :: relinquish_device_array => relinquish_device_array_single, &
          relinquish_device_array_multiple
 
     procedure, pass(this) :: request_vector
     procedure, pass(this) :: relinquish_vector_single
     procedure, pass(this) :: relinquish_vector_multiple
     generic :: relinquish_vector => relinquish_vector_single, &
          relinquish_vector_multiple
 
     procedure, pass(this) :: request_matrix
     procedure, pass(this) :: relinquish_matrix_single
     procedure, pass(this) :: relinquish_matrix_multiple
     generic :: relinquish_matrix => relinquish_matrix_single, &
          relinquish_matrix_multiple
 
     procedure, pass(this) :: request_tensor3
     procedure, pass(this) :: relinquish_tensor3_single
     procedure, pass(this) :: relinquish_tensor3_multiple
     generic :: relinquish_tensor3 => relinquish_tensor3_single, &
          relinquish_tensor3_multiple
 
     procedure, pass(this) :: request_tensor4
     procedure, pass(this) :: relinquish_tensor4_single
     procedure, pass(this) :: relinquish_tensor4_multiple
     generic :: relinquish_tensor4 => relinquish_tensor4_single, &
          relinquish_tensor4_multiple
 
     procedure, pass(this) :: request_field_stored_dof
     procedure, pass(this) :: request_field_free_dof
     procedure, pass(this) :: relinquish_field_single
     procedure, pass(this) :: relinquish_field_multiple
     generic :: request_field => request_field_stored_dof, &
          request_field_free_dof
     generic :: relinquish_field => relinquish_field_single, &
          relinquish_field_multiple
 
     ! ----------------------------------------------------------------------- !
     ! Type generic procedures for the scratch registry
 
     generic :: request => request_host_array, request_device_array, &
          request_vector, request_matrix, request_tensor3, request_tensor4, &
          request_field_stored_dof, request_field_free_dof
 
     procedure, pass(this) :: relinquish_single
     procedure, pass(this) :: relinquish_multiple
     generic :: relinquish => relinquish_single, relinquish_multiple
 
     ! ----------------------------------------------------------------------- !
     ! Private helper procedures
 
     procedure, pass(this), private :: relinquish_type
     procedure, private, pass(this) :: expand
 
  end type scratch_registry_t
 
  type(scratch_registry_t), public, target :: neko_scratch_registry
 
contains
 
  ! -------------------------------------------------------------------------- !
  ! Public generic procedures for the scratch registry
 
  subroutine scratch_registry_init(this, size, expansion_size, dof)
    class(scratch_registry_t), intent(inout) :: this
    integer, optional, intent(in) :: size
    integer, optional, intent(in) :: expansion_size
    type(dofmap_t), target, intent(in), optional :: dof
    integer :: initial_size
 
    call this%free()
 
    ! Assign the dofmap and expansion size if provided
    if (present(dof)) this%dof => dof
    if (present(expansion_size)) this%expansion_size = expansion_size
 
    ! Allocate the entries and inuse arrays with the initial size
    initial_size = this%expansion_size
    if (present(size)) initial_size = size
 
    if (initial_size .lt. 0) then
       call neko_error("scratch_registry::init: " // &
            "Initial size must be non-negative.")
    end if
 
    if (this%expansion_size .le. 0) then
       call neko_error("scratch_registry::init: " // &
            "Expansion size must be positive.")
    end if
 
    allocate(this%entries(initial_size))
    allocate(this%inuse(initial_size), source = .false.)
 
  end subroutine scratch_registry_init
 
  subroutine scratch_registry_free(this)
    class(scratch_registry_t), intent(inout):: this
    integer :: i
 
    if (this%get_n_inuse() .ne. 0) then
       call neko_error("scratch_registry::free: " // &
            "Cannot free scratch registry with entries still in use.")
    end if
 
    if (allocated(this%entries)) then
       do i = 1, this%n_entries
          call this%entries(i)%free()
       end do
       deallocate(this%entries)
    end if
 
    if (allocated(this%inuse)) deallocate(this%inuse)
    if (associated(this%dof)) nullify(this%dof)
 
    ! Reset to default values
    this%n_entries = 0
    this%expansion_size = 10
 
  end subroutine scratch_registry_free
 
  subroutine scratch_registry_set_dofmap(this, dof)
    class(scratch_registry_t), intent(inout) :: this
    type(dofmap_t), target, intent(in) :: dof
 
    if (associated(this%dof, dof)) then
       return
    else if (associated(this%dof)) then
       call neko_error("scratch_registry::set_dofmap: "&
            // "Dofmap is already assigned to scratch registry.")
    end if
 
    this%dof => dof
  end subroutine scratch_registry_set_dofmap
 
  subroutine scratch_registry_set_expansion_size(this, expansion_size)
    class(scratch_registry_t), intent(inout) :: this
    integer, intent(in) :: expansion_size
 
    if (expansion_size .le. 0) then
       call neko_error("scratch_registry::set_expansion_size: "&
            // "Expansion size must be positive.")
    end if
 
    this%expansion_size = expansion_size
  end subroutine scratch_registry_set_expansion_size
 
  function get_n_entries(this) result(n)
    class(scratch_registry_t), intent(in) :: this
    integer :: n
 
    !$omp critical (SCRATCH_OMP_LOCK)
    n = this%n_entries
    !$omp end critical (SCRATCH_OMP_LOCK)
  end function get_n_entries
 
  function get_n_inuse(this) result(n)
    class(scratch_registry_t), intent(in) :: this
    integer :: n
 
    !$omp critical (SCRATCH_OMP_LOCK)
    if (allocated(this%inuse)) then
       n = count(this%inuse)
    else
       n = 0
    end if
    !$omp end critical (SCRATCH_OMP_LOCK)
  end function get_n_inuse
 
  function get_size(this) result(n)
    class(scratch_registry_t), intent(in) :: this
    integer :: n
 
    !$omp critical (SCRATCH_OMP_LOCK)
    if (allocated(this%entries)) then
       n = size(this%entries)
    else
       n = 0
    end if
    !$omp end critical (SCRATCH_OMP_LOCK)
  end function get_size
 
  pure function get_expansion_size(this) result(n)
    class(scratch_registry_t), intent(in) :: this
    integer :: n
 
    n = this%expansion_size
  end function get_expansion_size
 
  logical function get_inuse(this, index)
    class(scratch_registry_t), target, intent(in) :: this
    integer, intent(in) :: index
 
    !$omp critical (SCRATCH_OMP_LOCK)
    get_inuse = this%inuse(index)
    !$omp end critical (SCRATCH_OMP_LOCK)
  end function get_inuse
 
  ! -------------------------------------------------------------------------- !
  ! Type specific procedures for the scratch registry
 
  subroutine request_host_array(this, scratch_entry, index, n, clear)
    class(scratch_registry_t), target, intent(inout) :: this
    real(kind=rp), pointer, dimension(:), intent(inout) :: scratch_entry
    integer, intent(inout) :: index
    integer, intent(in) :: n
    logical, intent(in) :: clear
    type(host_array_t), pointer :: ptr
 
    ptr => null()
 
    ! Look for a compatible, unused object in the registry.
    !$omp critical (SCRATCH_OMP_LOCK)
    do index = 1, this%n_entries
 
       ! Find an unused object of the correct type.
       if (this%inuse(index)) cycle
       if (.not. this%entries(index)%is_type('host_array')) cycle
 
       ! Check compatibility of the object size.
       ptr => this%entries(index)%get_host_array()
       if (ptr%size() .eq. n) then
          this%inuse(index) = .true.
          exit
       end if
       nullify(ptr)
    end do
 
    ! If no compatible, unused objects are found, expand and create a new one.
    if (index .gt. this%n_entries) then
       this%n_entries = this%n_entries + 1
 
       if (this%n_entries .gt. size(this%entries)) call this%expand()
       call this%entries(this%n_entries)%init_host_array(n)
       ptr => this%entries(this%n_entries)%get_host_array()
 
       this%inuse(this%n_entries) = .true.
    end if
    !$omp end critical (SCRATCH_OMP_LOCK)
 
    ! Assign the pointer to the entry and clear the values if requested.
    scratch_entry => ptr%x
    if (clear) call rzero(scratch_entry, n)
    nullify(ptr)
 
  end subroutine request_host_array
 
  subroutine relinquish_host_array_single(this, index)
    class(scratch_registry_t), intent(inout) :: this
    integer, intent(in) :: index
 
    call this%relinquish_type(index, 'host_array')
  end subroutine relinquish_host_array_single
 
  subroutine relinquish_host_array_multiple(this, indices)
    class(scratch_registry_t), intent(inout) :: this
    integer, intent(in) :: indices(:)
    integer :: i
 
    do i = 1, size(indices)
       call this%relinquish_type(indices(i), 'host_array')
    end do
  end subroutine relinquish_host_array_multiple
 
  subroutine request_device_array(this, scratch_entry, index, n, clear)
    class(scratch_registry_t), target, intent(inout) :: this
    type(c_ptr), intent(inout) :: scratch_entry
    integer, intent(inout) :: index
    integer, intent(in) :: n
    logical, intent(in) :: clear
    type(device_array_t), pointer :: ptr
 
    ptr => null()
 
    ! Look for a compatible, unused object in the registry.
    !$omp critical (SCRATCH_OMP_LOCK)
    do index = 1, this%n_entries
 
       ! Find an unused object of the correct type.
       if (this%inuse(index)) cycle
       if (.not. this%entries(index)%is_type('device_array')) cycle
 
       ! Check compatibility of the object size.
       ptr => this%entries(index)%get_device_array()
       if (ptr%size() .eq. n) then
          this%inuse(index) = .true.
          exit
       end if
       nullify(ptr)
    end do
 
    ! If no compatible, unused objects are found, expand and create a new one.
    if (index .gt. this%n_entries) then
       this%n_entries = this%n_entries + 1
 
       if (this%n_entries .gt. size(this%entries)) call this%expand()
       call this%entries(this%n_entries)%init_device_array(n)
       ptr => this%entries(this%n_entries)%get_device_array()
 
       this%inuse(this%n_entries) = .true.
    end if
    !$omp end critical (SCRATCH_OMP_LOCK)
 
    ! Assign the pointer to the entry and clear the values if requested.
    scratch_entry = ptr%x_d
    if (clear) call device_rzero(scratch_entry, n)
    nullify(ptr)
 
  end subroutine request_device_array
 
  subroutine relinquish_device_array_single(this, index)
    class(scratch_registry_t), intent(inout) :: this
    integer, intent(in) :: index
 
    call this%relinquish_type(index, 'device_array')
  end subroutine relinquish_device_array_single
 
  subroutine relinquish_device_array_multiple(this, indices)
    class(scratch_registry_t), intent(inout) :: this
    integer, intent(in) :: indices(:)
    integer :: i
 
    do i = 1, size(indices)
       call this%relinquish_type(indices(i), 'device_array')
    end do
  end subroutine relinquish_device_array_multiple
 
  subroutine request_vector(this, scratch_entry, index, n, clear)
    class(scratch_registry_t), target, intent(inout) :: this
    type(vector_t), pointer, intent(inout) :: scratch_entry
    integer, intent(inout) :: index
    integer, intent(in) :: n
    logical, intent(in) :: clear
 
    ! Look for a compatible, unused object in the registry.
    !$omp critical (SCRATCH_OMP_LOCK)
    do index = 1, this%n_entries
 
       ! Find an unused object of the correct type.
       if (this%inuse(index)) cycle
       if (.not. this%entries(index)%is_type('vector')) cycle
 
       ! Check compatibility of the object size.
       scratch_entry => this%entries(index)%get_vector()
       if (scratch_entry%size() .eq. n) then
          this%inuse(index) = .true.
          exit
       end if
       nullify(scratch_entry)
    end do
 
    ! If no compatible, unused objects are found, expand and create a new one.
    if (index .gt. this%n_entries) then
       this%n_entries = this%n_entries + 1
 
       if (this%n_entries .gt. size(this%entries)) call this%expand()
       call this%entries(this%n_entries)%init_vector(n)
       scratch_entry => this%entries(this%n_entries)%get_vector()
 
       this%inuse(this%n_entries) = .true.
    end if
    !$omp end critical (SCRATCH_OMP_LOCK)
 
    ! Assign the pointer to the entry and clear the values if requested.
    if (clear) call vector_rzero(scratch_entry)
 
  end subroutine request_vector
 
  subroutine relinquish_vector_single(this, index)
    class(scratch_registry_t), intent(inout) :: this
    integer, intent(in) :: index
 
    call this%relinquish_type(index, 'vector')
  end subroutine relinquish_vector_single
 
  subroutine relinquish_vector_multiple(this, indices)
    class(scratch_registry_t), intent(inout) :: this
    integer, intent(in) :: indices(:)
    integer :: i
 
    do i = 1, size(indices)
       call this%relinquish_type(indices(i), 'vector')
    end do
  end subroutine relinquish_vector_multiple
 
  subroutine request_matrix(this, scratch_entry, index, nrows, ncols, clear)
    class(scratch_registry_t), target, intent(inout) :: this
    type(matrix_t), pointer, intent(inout) :: scratch_entry
    integer, intent(inout) :: index
    integer, intent(in) :: nrows, ncols
    logical, intent(in) :: clear
 
    ! Look for a compatible, unused object in the registry.
    !$omp critical (SCRATCH_OMP_LOCK)
    do index = 1, this%n_entries
 
       ! Find an unused object of the correct type.
       if (this%inuse(index)) cycle
       if (.not. this%entries(index)%is_type('matrix')) cycle
 
       ! Check compatibility of the object size.
       scratch_entry => this%entries(index)%get_matrix()
       if (all(scratch_entry%get_dims() .eq. [nrows, ncols])) then
          this%inuse(index) = .true.
          exit
       end if
       nullify(scratch_entry)
    end do
 
    ! If no compatible, unused objects are found, expand and create a new one.
    if (index .gt. this%n_entries) then
       this%n_entries = this%n_entries + 1
 
       if (this%n_entries .gt. size(this%entries)) call this%expand()
       call this%entries(this%n_entries)%init_matrix(nrows, ncols)
       scratch_entry => this%entries(this%n_entries)%get_matrix()
 
       this%inuse(this%n_entries) = .true.
    end if
    !$omp end critical (SCRATCH_OMP_LOCK)
 
    ! Assign the pointer to the entry and clear the values if requested.
    if (clear) call matrix_rzero(scratch_entry)
 
  end subroutine request_matrix
 
  subroutine relinquish_matrix_single(this, index)
    class(scratch_registry_t), intent(inout) :: this
    integer, intent(in) :: index
 
    call this%relinquish_type(index, 'matrix')
  end subroutine relinquish_matrix_single
 
  subroutine relinquish_matrix_multiple(this, indices)
    class(scratch_registry_t), intent(inout) :: this
    integer, intent(in) :: indices(:)
    integer :: i
 
    do i = 1, size(indices)
       call this%relinquish_type(indices(i), 'matrix')
    end do
  end subroutine relinquish_matrix_multiple
 
  subroutine request_tensor3(this, scratch_entry, index, n, m, l, clear)
    class(scratch_registry_t), target, intent(inout) :: this
    type(tensor3_t), pointer, intent(inout) :: scratch_entry
    integer, intent(inout) :: index
    integer, intent(in) :: n, m, l
    logical, intent(in) :: clear
 
    ! Look for a compatible, unused object in the registry.
    !$omp critical (SCRATCH_OMP_LOCK)
    do index = 1, this%n_entries
 
       ! Find an unused object of the correct type.
       if (this%inuse(index)) cycle
       if (.not. this%entries(index)%is_type('tensor3')) cycle
 
       ! Check compatibility of the object size.
       scratch_entry => this%entries(index)%get_tensor3()
       if (all(scratch_entry%get_dims() .eq. [n, m, l])) then
          this%inuse(index) = .true.
          exit
       end if
       nullify(scratch_entry)
    end do
 
    ! If no compatible, unused objects are found, expand and create a new one.
    if (index .gt. this%n_entries) then
       this%n_entries = this%n_entries + 1
 
       if (this%n_entries .gt. size(this%entries)) call this%expand()
       call this%entries(this%n_entries)%init_tensor3(n, m, l)
       scratch_entry => this%entries(this%n_entries)%get_tensor3()
 
       this%inuse(this%n_entries) = .true.
    end if
    !$omp end critical (SCRATCH_OMP_LOCK)
 
    ! Assign the pointer to the entry and clear the values if requested.
    if (clear) then
       if (neko_bcknd_device .eq. 1) then
          call device_rzero(scratch_entry%x_d, scratch_entry%size())
       else
          call rzero(scratch_entry%x, scratch_entry%size())
       end if
    end if
 
  end subroutine request_tensor3
 
  subroutine relinquish_tensor3_single(this, index)
    class(scratch_registry_t), intent(inout) :: this
    integer, intent(in) :: index
 
    call this%relinquish_type(index, 'tensor3')
  end subroutine relinquish_tensor3_single
 
  subroutine relinquish_tensor3_multiple(this, indices)
    class(scratch_registry_t), intent(inout) :: this
    integer, intent(in) :: indices(:)
    integer :: i
 
    do i = 1, size(indices)
       call this%relinquish_type(indices(i), 'tensor3')
    end do
  end subroutine relinquish_tensor3_multiple
 
  subroutine request_tensor4(this, scratch_entry, index, n, m, l, k, clear)
    class(scratch_registry_t), target, intent(inout) :: this
    type(tensor4_t), pointer, intent(inout) :: scratch_entry
    integer, intent(inout) :: index
    integer, intent(in) :: n, m, l, k
    logical, intent(in) :: clear
 
    ! Look for a compatible, unused object in the registry.
    !$omp critical (SCRATCH_OMP_LOCK)
    do index = 1, this%n_entries
 
       ! Find an unused object of the correct type.
       if (this%inuse(index)) cycle
       if (.not. this%entries(index)%is_type('tensor4')) cycle
 
       ! Check compatibility of the object size.
       scratch_entry => this%entries(index)%get_tensor4()
       if (all(scratch_entry%get_dims() .eq. [n, m, l, k])) then
          this%inuse(index) = .true.
          exit
       end if
       nullify(scratch_entry)
    end do
 
    ! If no compatible, unused objects are found, expand and create a new one.
    if (index .gt. this%n_entries) then
       this%n_entries = this%n_entries + 1
 
       if (this%n_entries .gt. size(this%entries)) call this%expand()
       call this%entries(this%n_entries)%init_tensor4(n, m, l, k)
       scratch_entry => this%entries(this%n_entries)%get_tensor4()
 
       this%inuse(this%n_entries) = .true.
    end if
    !$omp end critical (SCRATCH_OMP_LOCK)
 
    ! Assign the pointer to the entry and clear the values if requested.
    if (clear) then
       if (neko_bcknd_device .eq. 1) then
          call device_rzero(scratch_entry%x_d, scratch_entry%size())
       else
          call rzero(scratch_entry%x, scratch_entry%size())
       end if
    end if
 
  end subroutine request_tensor4
 
  subroutine relinquish_tensor4_single(this, index)
    class(scratch_registry_t), intent(inout) :: this
    integer, intent(in) :: index
 
    call this%relinquish_type(index, 'tensor4')
  end subroutine relinquish_tensor4_single
 
  subroutine relinquish_tensor4_multiple(this, indices)
    class(scratch_registry_t), intent(inout) :: this
    integer, intent(in) :: indices(:)
    integer :: i
 
    do i = 1, size(indices)
       call this%relinquish_type(indices(i), 'tensor4')
    end do
  end subroutine relinquish_tensor4_multiple
 
  subroutine request_field_stored_dof(this, scratch_entry, index, clear)
    class(scratch_registry_t), target, intent(inout) :: this
    type(field_t), pointer, intent(inout) :: scratch_entry
    integer, intent(inout) :: index
    logical, intent(in) :: clear
    character(len=10) :: name
 
    if (.not. associated(this%dof)) then
       call neko_error("scratch_registry::request_field_stored_dof: " &
            // "No dofmap assigned to scratch registry.")
    end if
 
    ! Look for a compatible, unused object in the registry.
    !$omp critical (SCRATCH_OMP_LOCK)
    do index = 1, this%n_entries
 
       ! Find an unused object of the correct type.
       if (this%inuse(index)) cycle
       if (.not. this%entries(index)%is_type('field')) cycle
 
       ! Check compatibility of the object size.
       scratch_entry => this%entries(index)%get_field()
       if (associated(scratch_entry%dof, this%dof)) then
          this%inuse(index) = .true.
          exit
       end if
       nullify(scratch_entry)
    end do
 
    ! If no compatible, unused objects are found, expand and create a new one.
    if (index .gt. this%n_entries) then
       this%n_entries = this%n_entries + 1
 
       if (this%n_entries .gt. size(this%entries)) call this%expand()
       write(name, "(A3,I0.3)") "wrk", this%n_entries
       call this%entries(this%n_entries)%init_field(this%dof, name)
       scratch_entry => this%entries(this%n_entries)%get_field()
 
       this%inuse(this%n_entries) = .true.
    end if
    !$omp end critical (SCRATCH_OMP_LOCK)
 
    ! Assign the pointer to the entry and clear the values if requested.
    if (clear) call field_rzero(scratch_entry)
 
  end subroutine request_field_stored_dof
 
  subroutine request_field_free_dof(this, scratch_entry, index, dof, clear)
    class(scratch_registry_t), target, intent(inout) :: this
    type(field_t), pointer, intent(inout) :: scratch_entry
    integer, intent(inout) :: index
    type(dofmap_t), target, intent(in) :: dof
    logical, intent(in) :: clear
    character(len=10) :: name
 
    ! Look for a compatible, unused object in the registry.
    !$omp critical (SCRATCH_OMP_LOCK)
    do index = 1, this%n_entries
 
       ! Find an unused object of the correct type.
       if (this%inuse(index)) cycle
       if (.not. this%entries(index)%is_type('field')) cycle
 
       ! Check compatibility of the object size.
       scratch_entry => this%entries(index)%get_field()
       if (associated(scratch_entry%dof, dof)) then
          this%inuse(index) = .true.
          exit
       end if
       nullify(scratch_entry)
    end do
 
    ! If no compatible, unused objects are found, expand and create a new one.
    if (index .gt. this%n_entries) then
       this%n_entries = this%n_entries + 1
 
       if (this%n_entries .gt. size(this%entries)) call this%expand()
       write(name, "(A3,I0.3)") "wrk", this%n_entries
       call this%entries(this%n_entries)%init_field(dof, name)
       scratch_entry => this%entries(this%n_entries)%get_field()
 
       this%inuse(this%n_entries) = .true.
    end if
    !$omp end critical (SCRATCH_OMP_LOCK)
 
    ! Assign the pointer to the entry and clear the values if requested.
    if (clear) call field_rzero(scratch_entry)
  end subroutine request_field_free_dof
 
  subroutine relinquish_field_single(this, index)
    class(scratch_registry_t), intent(inout) :: this
    integer, intent(in) :: index
 
    call this%relinquish_type(index, 'field')
  end subroutine relinquish_field_single
 
  subroutine relinquish_field_multiple(this, indices)
    class(scratch_registry_t), intent(inout) :: this
    integer, intent(in) :: indices(:)
    integer :: i
 
    do i = 1, size(indices)
       call this%relinquish_type(indices(i), 'field')
    end do
  end subroutine relinquish_field_multiple
 
  ! -------------------------------------------------------------------------- !
  ! Type generic procedures for the scratch registry
 
  subroutine relinquish_single(this, index)
    class(scratch_registry_t), intent(inout) :: this
    integer, intent(in) :: index
 
    !$omp critical (SCRATCH_OMP_LOCK)
    this%inuse(index) = .false.
    !$omp end critical (SCRATCH_OMP_LOCK)
 
  end subroutine relinquish_single
 
  subroutine relinquish_multiple(this, indices)
    class(scratch_registry_t), intent(inout) :: this
    integer, intent(in) :: indices(:)
    integer :: i
 
    do i = 1, size(indices)
       call this%relinquish_single(indices(i))
    end do
  end subroutine relinquish_multiple
 
  ! -------------------------------------------------------------------------- !
  ! Private helper procedures
 
  subroutine relinquish_type(this, index, type)
    class(scratch_registry_t), intent(inout) :: this
    integer, intent(in) :: index
    character(len=*), intent(in) :: type
    character(len=256) :: msg
 
    !$omp critical (SCRATCH_OMP_LOCK)
    if (trim(this%entries(index)%get_type()) .ne. type) then
       write(msg, "(A,1X,A,1X,A,A)") "scratch_registry::relinquish:", &
            "Entry is not a", trim(type), "."
       call neko_error(trim(msg))
    end if
 
    this%inuse(index) = .false.
    !$omp end critical (SCRATCH_OMP_LOCK)
  end subroutine relinquish_type
 
  subroutine expand(this)
    class(scratch_registry_t), intent(inout) :: this
    type(registry_entry_t), allocatable :: temp(:)
    logical, allocatable :: temp2(:)
    integer :: i, n
 
    n = size(this%entries)
    if (n .gt. 0) then
       call move_alloc(this%entries, temp)
       call move_alloc(this%inuse, temp2)
    end if
 
    allocate(this%entries(n + this%expansion_size))
    allocate(this%inuse(n + this%expansion_size), source = .false.)
 
    if (n .gt. 0) then
       do i = 1, n
          call this%entries(i)%move_from(temp(i))
          this%inuse(i) = temp2(i)
          call temp(i)%free()
       end do
    end if
 
    if (allocated(temp)) deallocate(temp)
    if (allocated(temp2)) deallocate(temp2)
 
  end subroutine expand
 
end module scratch_registry