device.F90

Go to the documentation of this file.

! Copyright (c) 2021-2025, 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 device
  use num_types, only : i8
  use opencl_intf
  use cuda_intf
  use hip_intf
  use neko_config, only: neko_bcknd_device
  use htable, only : htable_cptr_t, h_cptr_t
  use utils, only : neko_error
  use opencl_prgm_lib
  use, intrinsic :: iso_c_binding
  implicit none
  private
 
  integer, public, parameter :: host_to_device = 1, device_to_host = 2, &
       device_to_device = 3
 
  type(c_ptr), public, bind(c) :: glb_cmd_queue = c_null_ptr
 
  type(c_ptr), public, bind(c) :: aux_cmd_queue = c_null_ptr
 
  type(c_ptr), public, bind(c) :: glb_cmd_event
 
  integer, public :: strm_high_prio
 
  integer, public :: strm_low_prio
 
  interface device_memcpy
     module procedure device_memcpy_r1, device_memcpy_r2, &
          device_memcpy_r3, device_memcpy_r4, device_memcpy_cptr
  end interface device_memcpy
 
  interface device_map
     module procedure device_map_r1, device_map_r2, &
          device_map_r3, device_map_r4
  end interface device_map
 
  interface device_associate
     module procedure device_associate_r1, device_associate_r2, &
          device_associate_r3, device_associate_r4
  end interface device_associate
 
  interface device_associated
     module procedure device_associated_r1, device_associated_r2, &
          device_associated_r3, device_associated_r4
  end interface device_associated
 
  interface device_deassociate
     module procedure device_deassociate_r1, device_deassociate_r2, &
          device_deassociate_r3, device_deassociate_r4
  end interface device_deassociate
 
  interface device_get_ptr
     module procedure device_get_ptr_r1, device_get_ptr_r2, &
          device_get_ptr_r3, device_get_ptr_r4
  end interface device_get_ptr
 
  interface device_sync
     module procedure device_sync_device, device_sync_stream
  end interface device_sync
 
  type(htable_cptr_t), private :: device_addrtbl
 
  public :: device_memcpy, device_map, device_associate, device_associated, &
       device_deassociate, device_get_ptr, device_sync, device_free, &
       device_sync_stream, device_stream_create, device_stream_destroy, &
       device_profiler_start, device_profiler_stop, device_alloc, &
       device_init, device_name, device_event_create, device_event_destroy, &
       device_event_record, device_event_sync, device_finalize, &
       device_stream_wait_event, device_count, device_memset, &
       device_stream_create_with_priority
 
  private :: device_memcpy_common
 
contains
 
  subroutine device_init
#if defined(HAVE_HIP) || defined(HAVE_CUDA) || defined(HAVE_OPENCL)
    call device_addrtbl%init(64)
 
#ifdef HAVE_HIP
    call hip_init(glb_cmd_queue, aux_cmd_queue, strm_high_prio, strm_low_prio)
#elif HAVE_CUDA
    call cuda_init(glb_cmd_queue, aux_cmd_queue, strm_high_prio, strm_low_prio)
#elif HAVE_OPENCL
    call opencl_init(glb_cmd_queue, aux_cmd_queue)
#endif
    call device_event_create(glb_cmd_event, 2)
#endif
 
    ! Check the device count against the number of MPI ranks
    if (neko_bcknd_device .eq. 1) then
       if (device_count() .ne. 1) then
          call neko_error('Only one device is supported per MPI rank')
       end if
    end if
  end subroutine device_init
 
  subroutine device_finalize
#if defined(HAVE_HIP) || defined(HAVE_CUDA) || defined(HAVE_OPENCL)
    call device_addrtbl%free()
 
#ifdef HAVE_HIP
    call hip_finalize(glb_cmd_queue, aux_cmd_queue)
#elif HAVE_CUDA
    call cuda_finalize(glb_cmd_queue, aux_cmd_queue)
#elif HAVE_OPENCL
    call opencl_prgm_lib_release
    call opencl_finalize(glb_cmd_queue, aux_cmd_queue)
#endif
    call device_event_destroy(glb_cmd_event)
#endif
  end subroutine device_finalize
 
  subroutine device_name(name)
    character(len=*), intent(inout) :: name
 
#ifdef HAVE_HIP
    call hip_device_name(name)
#elif HAVE_CUDA
    call cuda_device_name(name)
#elif HAVE_OPENCL
    call opencl_device_name(name)
#endif
  end subroutine device_name
 
  integer function device_count()
#ifdef HAVE_HIP
    device_count = hip_device_count()
#elif HAVE_CUDA
    device_count = cuda_device_count()
#elif HAVE_OPENCL
    device_count = opencl_device_count()
#else
    device_count = 0
#endif
  end function device_count
 
  subroutine device_alloc(x_d, s)
    type(c_ptr), intent(inout) :: x_d
    integer(c_size_t) :: s
    integer :: ierr
 
    if (s .eq. 0) then
       call device_sync()
       x_d = c_null_ptr
       return
    end if
#ifdef HAVE_HIP
    if (hipmalloc(x_d, s) .ne. hipsuccess) then
       call neko_error('Memory allocation on device failed')
    end if
#elif HAVE_CUDA
    if (cudamalloc(x_d, s) .ne. cudasuccess) then
       call neko_error('Memory allocation on device failed')
    end if
#elif HAVE_OPENCL
    x_d = clcreatebuffer(glb_ctx, cl_mem_read_write, s, c_null_ptr, ierr)
    if (ierr .ne. cl_success) then
       call neko_error('Memory allocation on device failed')
    end if
#endif
  end subroutine device_alloc
 
  subroutine device_free(x_d)
    type(c_ptr), intent(inout) :: x_d
#ifdef HAVE_HIP
    if (hipfree(x_d) .ne. hipsuccess) then
       call neko_error('Memory deallocation on device failed')
    end if
#elif HAVE_CUDA
    if (cudafree(x_d) .ne. cudasuccess) then
       call neko_error('Memory deallocation on device failed')
    end if
#elif HAVE_OPENCL
    if (clreleasememobject(x_d) .ne. cl_success) then
       call neko_error('Memory deallocation on device failed')
    end if
#endif
    x_d = c_null_ptr
  end subroutine device_free
 
  subroutine device_memset(x_d, v, s, sync, strm)
    type(c_ptr), intent(inout) :: x_d
    integer(c_int), target, value :: v
    integer(c_size_t), intent(in) :: s
    logical, optional :: sync
    type(c_ptr), optional :: strm
    type(c_ptr) :: stream
    logical :: sync_device
 
    if (present(sync)) then
       sync_device = sync
    else
       sync_device = .false.
    end if
 
    if (present(strm)) then
       stream = strm
    else
       stream = glb_cmd_queue
    end if
 
#ifdef HAVE_HIP
    if (hipmemsetasync(x_d, v, s, stream) .ne. hipsuccess) then
       call neko_error('Device memset async failed')
    end if
#elif HAVE_CUDA
    if (cudamemsetasync(x_d, v, s, stream) .ne. cudasuccess) then
       call neko_error('Device memset async failed')
    end if
#elif HAVE_OPENCL
    if (clenqueuefillbuffer(stream, x_d, c_loc(v), c_sizeof(v), 0_i8, &
         s, 0, c_null_ptr, c_null_ptr) .ne. cl_success) then
       call neko_error('Device memset async failed')
    end if
#endif
 
    if (sync_device) then
       call device_sync_stream(stream)
    end if
 
  end subroutine device_memset
 
  subroutine device_memcpy_r1(x, x_d, n, dir, sync, strm)
    integer, intent(in) :: n
    class(*), intent(inout), target :: x(:)
    type(c_ptr), intent(inout) :: x_d
    integer, intent(in), value :: dir
    logical :: sync
    type(c_ptr), optional :: strm
    type(c_ptr) :: ptr_h, copy_stream
    integer(c_size_t) :: s
 
    if (present(strm)) then
       copy_stream = strm
    else
       copy_stream = glb_cmd_queue
    end if
 
    select type (x)
    type is (integer)
       s = n * int(4, c_size_t)
       ptr_h = c_loc(x)
    type is (integer(i8))
       s = n * int(8, c_size_t)
       ptr_h = c_loc(x)
    type is (real)
       s = n * int(4, c_size_t)
       ptr_h = c_loc(x)
    type is (double precision)
       s = n * int(8, c_size_t)
       ptr_h = c_loc(x)
    class default
       call neko_error('Unknown Fortran type')
    end select
 
    call device_memcpy_common(ptr_h, x_d, s, dir, sync, copy_stream)
 
  end subroutine device_memcpy_r1
 
  subroutine device_memcpy_r2(x, x_d, n, dir, sync, strm)
    integer, intent(in) :: n
    class(*), intent(inout), target :: x(:,:)
    type(c_ptr), intent(inout) :: x_d
    integer, intent(in), value :: dir
    logical :: sync
    type(c_ptr), optional :: strm
    type(c_ptr) :: ptr_h, copy_stream
    integer(c_size_t) :: s
 
    if (present(strm)) then
       copy_stream = strm
    else
       copy_stream = glb_cmd_queue
    end if
 
    select type (x)
    type is (integer)
       s = n * int(4, c_size_t)
       ptr_h = c_loc(x)
    type is (integer(i8))
       s = n * int(8, c_size_t)
       ptr_h = c_loc(x)
    type is (real)
       s = n * int(4, c_size_t)
       ptr_h = c_loc(x)
    type is (double precision)
       s = n * int(8, c_size_t)
       ptr_h = c_loc(x)
    class default
       call neko_error('Unknown Fortran type')
    end select
 
    call device_memcpy_common(ptr_h, x_d, s, dir, sync, copy_stream)
 
  end subroutine device_memcpy_r2
 
  subroutine device_memcpy_r3(x, x_d, n, dir, sync, strm)
    integer, intent(in) :: n
    class(*), intent(inout), target :: x(:,:,:)
    type(c_ptr), intent(inout) :: x_d
    integer, intent(in), value :: dir
    logical :: sync
    type(c_ptr), optional :: strm
    type(c_ptr) :: ptr_h, copy_stream
    integer(c_size_t) :: s
 
    if (present(strm)) then
       copy_stream = strm
    else
       copy_stream = glb_cmd_queue
    end if
 
    select type (x)
    type is (integer)
       s = n * int(4, c_size_t)
       ptr_h = c_loc(x)
    type is (integer(i8))
       s = n * int(8, c_size_t)
       ptr_h = c_loc(x)
    type is (real)
       s = n * int(4, c_size_t)
       ptr_h = c_loc(x)
    type is (double precision)
       s = n * int(8, c_size_t)
       ptr_h = c_loc(x)
    class default
       call neko_error('Unknown Fortran type')
    end select
 
    call device_memcpy_common(ptr_h, x_d, s, dir, sync, copy_stream)
 
  end subroutine device_memcpy_r3
 
  subroutine device_memcpy_r4(x, x_d, n, dir, sync, strm)
    integer, intent(in) :: n
    class(*), intent(inout), target :: x(:,:,:,:)
    type(c_ptr), intent(inout) :: x_d
    integer, intent(in), value :: dir
    logical :: sync
    type(c_ptr), optional :: strm
    type(c_ptr) :: ptr_h, copy_stream
    integer(c_size_t) :: s
 
    if (present(strm)) then
       copy_stream = strm
    else
       copy_stream = glb_cmd_queue
    end if
 
    select type (x)
    type is (integer)
       s = n * int(4, c_size_t)
       ptr_h = c_loc(x)
    type is (integer(i8))
       s = n * int(8, c_size_t)
       ptr_h = c_loc(x)
    type is (real)
       s = n * int(4, c_size_t)
       ptr_h = c_loc(x)
    type is (double precision)
       s = n * int(8, c_size_t)
       ptr_h = c_loc(x)
    class default
       call neko_error('Unknown Fortran type')
    end select
 
    call device_memcpy_common(ptr_h, x_d, s, dir, sync, copy_stream)
 
  end subroutine device_memcpy_r4
 
  subroutine device_memcpy_cptr(dst, src, s, dir, sync, strm)
    type(c_ptr), intent(inout) :: dst
    type(c_ptr), intent(inout) :: src
    integer(c_size_t), intent(in) :: s
    integer, intent(in), value :: dir
    logical, optional :: sync
    type(c_ptr), optional :: strm
    type(c_ptr) :: copy_stream
    logical :: sync_device
 
    if (present(sync)) then
       sync_device = sync
    else
       sync_device = .false.
    end if
 
    if (present(strm)) then
       copy_stream = strm
    else
       copy_stream = glb_cmd_queue
    end if
 
    call device_memcpy_common(dst, src, s, dir, sync_device, copy_stream)
 
  end subroutine device_memcpy_cptr
 
  subroutine device_memcpy_common(ptr_h, x_d, s, dir, sync_device, stream)
    type(c_ptr), intent(inout) :: ptr_h
    type(c_ptr), intent(inout) :: x_d
    integer(c_size_t), intent(in) :: s
    integer, intent(in), value :: dir
    logical, intent(in) :: sync_device
    type(c_ptr), intent(inout) :: stream
 
    if (s .eq. 0) then
       if (sync_device) then
          call device_sync_stream(stream)
       end if
       return
    end if
 
#ifdef HAVE_HIP
    if (dir .eq. host_to_device) then
       if (hipmemcpyasync(x_d, ptr_h, s, &
            hipmemcpyhosttodevice, stream) .ne. hipsuccess) then
          call neko_error('Device memcpy async (host-to-device) failed')
       end if
    else if (dir .eq. device_to_host) then
       if (hipmemcpyasync(ptr_h, x_d, s, &
            hipmemcpydevicetohost, stream) .ne. hipsuccess) then
          call neko_error('Device memcpy async (device-to-host) failed')
       end if
    else if (dir .eq. device_to_device) then
       if (hipmemcpyasync(ptr_h, x_d, s, hipmemcpydevicetodevice, stream) &
            .ne. hipsuccess) then
          call neko_error('Device memcpy async (device-to-device) failed')
       end if
    else
       call neko_error('Device memcpy failed (invalid direction')
    end if
    if (sync_device) then
       call device_sync_stream(stream)
    end if
#elif HAVE_CUDA
    if (dir .eq. host_to_device) then
       if (cudamemcpyasync(x_d, ptr_h, s, cudamemcpyhosttodevice, stream) &
            .ne. cudasuccess) then
          call neko_error('Device memcpy async (host-to-device) failed')
       end if
    else if (dir .eq. device_to_host) then
       if (cudamemcpyasync(ptr_h, x_d, s, cudamemcpydevicetohost, stream) &
            .ne. cudasuccess) then
          call neko_error('Device memcpy async (device-to-host) failed')
       end if
    else if (dir .eq. device_to_device) then
       if (cudamemcpyasync(ptr_h, x_d, s, cudamemcpydevicetodevice, stream) &
            .ne. cudasuccess) then
          call neko_error('Device memcpy async (device-to-device) failed')
       end if
    else
       call neko_error('Device memcpy failed (invalid direction')
    end if
    if (sync_device) then
       call device_sync_stream(stream)
    end if
#elif HAVE_OPENCL
    if (sync_device) then
       if (dir .eq. host_to_device) then
          if (clenqueuewritebuffer(stream, x_d, cl_true, 0_i8, s, &
               ptr_h, 0, c_null_ptr, c_null_ptr) &
               .ne. cl_success) then
             call neko_error('Device memcpy (host-to-device) failed')
          end if
       else if (dir .eq. device_to_host) then
          if (clenqueuereadbuffer(stream, x_d, cl_true, 0_i8, s, ptr_h, &
               0, c_null_ptr, c_null_ptr) &
               .ne. cl_success) then
             call neko_error('Device memcpy (device-to-host) failed')
          end if
       else if (dir .eq. device_to_device) then
          if (clenqueuecopybuffer(stream, x_d, ptr_h, 0_i8, 0_i8, s, &
               0, c_null_ptr, c_null_ptr) &
               .ne. cl_success) then
             call neko_error('Device memcpy (device-to-device) failed')
          end if
       else
          call neko_error('Device memcpy failed (invalid direction')
       end if
    else
       if (dir .eq. host_to_device) then
          if (clenqueuewritebuffer(stream, x_d, cl_false, 0_i8, s, &
               ptr_h, 0, c_null_ptr, c_null_ptr) &
               .ne. cl_success) then
             call neko_error('Device memcpy (host-to-device) failed')
          end if
       else if (dir .eq. device_to_host) then
          if (clenqueuereadbuffer(stream, x_d, cl_false, 0_i8, s, ptr_h,&
               0, c_null_ptr, c_null_ptr) &
               .ne. cl_success) then
             call neko_error('Device memcpy (device-to-host) failed')
          end if
       else if (dir .eq. device_to_device) then
          if (clenqueuecopybuffer(stream, x_d, ptr_h, 0_i8, 0_i8, s, &
               0, c_null_ptr, c_null_ptr) &
               .ne. cl_success) then
             call neko_error('Device memcpy (device-to-device) failed')
          end if
       else
          call neko_error('Device memcpy failed (invalid direction')
       end if
    end if
#endif
  end subroutine device_memcpy_common
 
  subroutine device_associate_r1(x, x_d)
    class(*), intent(inout), target :: x(:)
    type(c_ptr), intent(inout) :: x_d
    type(h_cptr_t) :: htbl_ptr_h, htbl_ptr_d
 
    select type (x)
    type is (integer)
       htbl_ptr_h%ptr = c_loc(x)
    type is (integer(i8))
       htbl_ptr_h%ptr = c_loc(x)
    type is (real)
       htbl_ptr_h%ptr = c_loc(x)
    type is (double precision)
       htbl_ptr_h%ptr = c_loc(x)
    class default
       call neko_error('Unknown Fortran type')
    end select
 
    htbl_ptr_d%ptr = x_d
 
    call device_addrtbl%set(htbl_ptr_h, htbl_ptr_d)
 
  end subroutine device_associate_r1
 
  subroutine device_associate_r2(x, x_d)
    class(*), intent(inout), target :: x(:,:)
    type(c_ptr), intent(inout) :: x_d
    type(h_cptr_t) :: htbl_ptr_h, htbl_ptr_d
 
    select type (x)
    type is (integer)
       htbl_ptr_h%ptr = c_loc(x)
    type is (integer(i8))
       htbl_ptr_h%ptr = c_loc(x)
    type is (real)
       htbl_ptr_h%ptr = c_loc(x)
    type is (double precision)
       htbl_ptr_h%ptr = c_loc(x)
    class default
       call neko_error('Unknown Fortran type')
    end select
 
    htbl_ptr_d%ptr = x_d
 
    call device_addrtbl%set(htbl_ptr_h, htbl_ptr_d)
 
  end subroutine device_associate_r2
 
  subroutine device_associate_r3(x, x_d)
    class(*), intent(inout), target :: x(:,:,:)
    type(c_ptr), intent(inout) :: x_d
    type(h_cptr_t) :: htbl_ptr_h, htbl_ptr_d
 
    select type (x)
    type is (integer)
       htbl_ptr_h%ptr = c_loc(x)
    type is (integer(i8))
       htbl_ptr_h%ptr = c_loc(x)
    type is (real)
       htbl_ptr_h%ptr = c_loc(x)
    type is (double precision)
       htbl_ptr_h%ptr = c_loc(x)
    class default
       call neko_error('Unknown Fortran type')
    end select
 
    htbl_ptr_d%ptr = x_d
 
    call device_addrtbl%set(htbl_ptr_h, htbl_ptr_d)
 
  end subroutine device_associate_r3
 
  subroutine device_associate_r4(x, x_d)
    class(*), intent(inout), target :: x(:,:,:,:)
    type(c_ptr), intent(inout) :: x_d
    type(h_cptr_t) :: htbl_ptr_h, htbl_ptr_d
 
    select type (x)
    type is (integer)
       htbl_ptr_h%ptr = c_loc(x)
    type is (integer(i8))
       htbl_ptr_h%ptr = c_loc(x)
    type is (real)
       htbl_ptr_h%ptr = c_loc(x)
    type is (double precision)
       htbl_ptr_h%ptr = c_loc(x)
    class default
       call neko_error('Unknown Fortran type')
    end select
 
    htbl_ptr_d%ptr = x_d
 
    call device_addrtbl%set(htbl_ptr_h, htbl_ptr_d)
 
  end subroutine device_associate_r4
 
  subroutine device_deassociate_r1(x)
    class(*), intent(inout), target :: x(:)
    type(h_cptr_t) :: htbl_ptr_h, htbl_ptr_d
 
    select type (x)
    type is (integer)
       htbl_ptr_h%ptr = c_loc(x)
    type is (integer(i8))
       htbl_ptr_h%ptr = c_loc(x)
    type is (real)
       htbl_ptr_h%ptr = c_loc(x)
    type is (double precision)
       htbl_ptr_h%ptr = c_loc(x)
    class default
       call neko_error('Unknown Fortran type')
    end select
 
    if (device_addrtbl%get(htbl_ptr_h, htbl_ptr_d) .eq. 0) then
       call device_addrtbl%remove(htbl_ptr_h)
    end if
 
  end subroutine device_deassociate_r1
 
  subroutine device_deassociate_r2(x)
    class(*), intent(inout), target :: x(:,:)
    type(h_cptr_t) :: htbl_ptr_h, htbl_ptr_d
 
    select type (x)
    type is (integer)
       htbl_ptr_h%ptr = c_loc(x)
    type is (integer(i8))
       htbl_ptr_h%ptr = c_loc(x)
    type is (real)
       htbl_ptr_h%ptr = c_loc(x)
    type is (double precision)
       htbl_ptr_h%ptr = c_loc(x)
    class default
       call neko_error('Unknown Fortran type')
    end select
 
    if (device_addrtbl%get(htbl_ptr_h, htbl_ptr_d) .eq. 0) then
       call device_addrtbl%remove(htbl_ptr_h)
    end if
 
  end subroutine device_deassociate_r2
 
  subroutine device_deassociate_r3(x)
    class(*), intent(inout), target :: x(:,:,:)
    type(h_cptr_t) :: htbl_ptr_h, htbl_ptr_d
 
    select type (x)
    type is (integer)
       htbl_ptr_h%ptr = c_loc(x)
    type is (integer(i8))
       htbl_ptr_h%ptr = c_loc(x)
    type is (real)
       htbl_ptr_h%ptr = c_loc(x)
    type is (double precision)
       htbl_ptr_h%ptr = c_loc(x)
    class default
       call neko_error('Unknown Fortran type')
    end select
 
    if (device_addrtbl%get(htbl_ptr_h, htbl_ptr_d) .eq. 0) then
       call device_addrtbl%remove(htbl_ptr_h)
    end if
 
  end subroutine device_deassociate_r3
 
  subroutine device_deassociate_r4(x)
    class(*), intent(inout), target :: x(:,:,:,:)
    type(h_cptr_t) :: htbl_ptr_h, htbl_ptr_d
 
    select type (x)
    type is (integer)
       htbl_ptr_h%ptr = c_loc(x)
    type is (integer(i8))
       htbl_ptr_h%ptr = c_loc(x)
    type is (real)
       htbl_ptr_h%ptr = c_loc(x)
    type is (double precision)
       htbl_ptr_h%ptr = c_loc(x)
    class default
       call neko_error('Unknown Fortran type')
    end select
 
    if (device_addrtbl%get(htbl_ptr_h, htbl_ptr_d) .eq. 0) then
       call device_addrtbl%remove(htbl_ptr_h)
    end if
 
  end subroutine device_deassociate_r4
 
  subroutine device_map_r1(x, x_d, n)
    integer, intent(in) :: n
    class(*), intent(inout), target :: x(:)
    type(c_ptr), intent(inout) :: x_d
    integer(c_size_t) :: s
 
    if (c_associated(x_d)) then
       call neko_error('Device pointer already associated')
    end if
 
    select type (x)
    type is (integer)
       s = n * int(4, c_size_t)
    type is (integer(i8))
       s = n * int(8, c_size_t)
    type is (real)
       s = n * int(4, c_size_t)
    type is (double precision)
       s = n * int(8, c_size_t)
    class default
       call neko_error('Unknown Fortran type')
    end select
 
    call device_alloc(x_d, s)
    call device_associate(x, x_d)
 
  end subroutine device_map_r1
 
  subroutine device_map_r2(x, x_d, n)
    integer, intent(in) :: n
    class(*), intent(inout), target :: x(:,:)
    type(c_ptr), intent(inout) :: x_d
    integer(c_size_t) :: s
 
    if (c_associated(x_d)) then
       call neko_error('Device pointer already associated')
    end if
 
    select type (x)
    type is (integer)
       s = n * int(4, c_size_t)
    type is (integer(i8))
       s = n * int(8, c_size_t)
    type is (real)
       s = n * int(4, c_size_t)
    type is (double precision)
       s = n * int(8, c_size_t)
    class default
       call neko_error('Unknown Fortran type')
    end select
 
    call device_alloc(x_d, s)
    call device_associate(x, x_d)
 
  end subroutine device_map_r2
 
  subroutine device_map_r3(x, x_d, n)
    integer, intent(in) :: n
    class(*), intent(inout), target :: x(:,:,:)
    type(c_ptr), intent(inout) :: x_d
    integer(c_size_t) :: s
 
    if (c_associated(x_d)) then
       call neko_error('Device pointer already associated')
    end if
 
    select type (x)
    type is (integer)
       s = n * int(4, c_size_t)
    type is (integer(i8))
       s = n * int(8, c_size_t)
    type is (real)
       s = n * int(4, c_size_t)
    type is (double precision)
       s = n * int(8, c_size_t)
    class default
       call neko_error('Unknown Fortran type')
    end select
 
    call device_alloc(x_d, s)
    call device_associate(x, x_d)
 
  end subroutine device_map_r3
 
  subroutine device_map_r4(x, x_d, n)
    integer, intent(in) :: n
    class(*), intent(inout), target :: x(:,:,:,:)
    type(c_ptr), intent(inout) :: x_d
    integer(c_size_t) :: s
 
    if (c_associated(x_d)) then
       call neko_error('Device pointer already associated')
    end if
 
    select type (x)
    type is (integer)
       s = n * int(4, c_size_t)
    type is (integer(i8))
       s = n * int(8, c_size_t)
    type is (real)
       s = n * int(4, c_size_t)
    type is (double precision)
       s = n * int(8, c_size_t)
    class default
       call neko_error('Unknown Fortran type')
    end select
 
    call device_alloc(x_d, s)
    call device_associate(x, x_d)
 
  end subroutine device_map_r4
 
  function device_associated_r1(x) result(assoc)
    class(*), intent(inout), target :: x(:)
    type(h_cptr_t) :: htbl_ptr_h, htbl_ptr_d
    logical :: assoc
 
    select type (x)
    type is (integer)
       htbl_ptr_h%ptr = c_loc(x)
    type is (integer(i8))
       htbl_ptr_h%ptr = c_loc(x)
    type is (real)
       htbl_ptr_h%ptr = c_loc(x)
    type is (double precision)
       htbl_ptr_h%ptr = c_loc(x)
    class default
       call neko_error('Unknown Fortran type')
    end select
 
    if (device_addrtbl%get(htbl_ptr_h, htbl_ptr_d) .eq. 0) then
       assoc = .true.
    else
       assoc = .false.
    end if
 
  end function device_associated_r1
 
  function device_associated_r2(x) result(assoc)
    class(*), intent(inout), target :: x(:,:)
    type(h_cptr_t) :: htbl_ptr_h, htbl_ptr_d
    logical :: assoc
 
    select type (x)
    type is (integer)
       htbl_ptr_h%ptr = c_loc(x)
    type is (integer(i8))
       htbl_ptr_h%ptr = c_loc(x)
    type is (real)
       htbl_ptr_h%ptr = c_loc(x)
    type is (double precision)
       htbl_ptr_h%ptr = c_loc(x)
    class default
       call neko_error('Unknown Fortran type')
    end select
 
    if (device_addrtbl%get(htbl_ptr_h, htbl_ptr_d) .eq. 0) then
       assoc = .true.
    else
       assoc = .false.
    end if
 
  end function device_associated_r2
 
  function device_associated_r3(x) result(assoc)
    class(*), intent(inout), target :: x(:,:,:)
    type(h_cptr_t) :: htbl_ptr_h, htbl_ptr_d
    logical :: assoc
 
    select type (x)
    type is (integer)
       htbl_ptr_h%ptr = c_loc(x)
    type is (integer(i8))
       htbl_ptr_h%ptr = c_loc(x)
    type is (real)
       htbl_ptr_h%ptr = c_loc(x)
    type is (double precision)
       htbl_ptr_h%ptr = c_loc(x)
    class default
       call neko_error('Unknown Fortran type')
    end select
 
    if (device_addrtbl%get(htbl_ptr_h, htbl_ptr_d) .eq. 0) then
       assoc = .true.
    else
       assoc = .false.
    end if
 
  end function device_associated_r3
 
  function device_associated_r4(x) result(assoc)
    class(*), intent(inout), target :: x(:,:,:,:)
    type(h_cptr_t) :: htbl_ptr_h, htbl_ptr_d
    logical :: assoc
 
    select type (x)
    type is (integer)
       htbl_ptr_h%ptr = c_loc(x)
    type is (integer(i8))
       htbl_ptr_h%ptr = c_loc(x)
    type is (real)
       htbl_ptr_h%ptr = c_loc(x)
    type is (double precision)
       htbl_ptr_h%ptr = c_loc(x)
    class default
       call neko_error('Unknown Fortran type')
    end select
 
    if (device_addrtbl%get(htbl_ptr_h, htbl_ptr_d) .eq. 0) then
       assoc = .true.
    else
       assoc = .false.
    end if
 
  end function device_associated_r4
 
  function device_get_ptr_r1(x)
    class(*), intent(in), target :: x(:)
    type(h_cptr_t) :: htbl_ptr_h, htbl_ptr_d
    type(c_ptr) :: device_get_ptr_r1
 
    device_get_ptr_r1 = c_null_ptr
 
    select type (x)
    type is (integer)
       htbl_ptr_h%ptr = c_loc(x)
    type is (integer(i8))
       htbl_ptr_h%ptr = c_loc(x)
    type is (real)
       htbl_ptr_h%ptr = c_loc(x)
    type is (double precision)
       htbl_ptr_h%ptr = c_loc(x)
    class default
       call neko_error('Unknown Fortran type')
    end select
 
    if (device_addrtbl%get(htbl_ptr_h, htbl_ptr_d) .eq. 0) then
       device_get_ptr_r1 = htbl_ptr_d%ptr
    else
       call neko_error('Array not associated with device')
    end if
  end function device_get_ptr_r1
 
  function device_get_ptr_r2(x)
    class(*), intent(in), target :: x(:,:)
    type(h_cptr_t) :: htbl_ptr_h, htbl_ptr_d
    type(c_ptr) :: device_get_ptr_r2
 
    device_get_ptr_r2 = c_null_ptr
 
    select type (x)
    type is (integer)
       htbl_ptr_h%ptr = c_loc(x)
    type is (integer(i8))
       htbl_ptr_h%ptr = c_loc(x)
    type is (real)
       htbl_ptr_h%ptr = c_loc(x)
    type is (double precision)
       htbl_ptr_h%ptr = c_loc(x)
    class default
       call neko_error('Unknown Fortran type')
    end select
 
    if (device_addrtbl%get(htbl_ptr_h, htbl_ptr_d) .eq. 0) then
       device_get_ptr_r2 = htbl_ptr_d%ptr
    else
       call neko_error('Array not associated with device')
    end if
  end function device_get_ptr_r2
 
  function device_get_ptr_r3(x)
    class(*), intent(in), target :: x(:,:,:)
    type(h_cptr_t) :: htbl_ptr_h, htbl_ptr_d
    type(c_ptr) :: device_get_ptr_r3
 
    device_get_ptr_r3 = c_null_ptr
 
    select type (x)
    type is (integer)
       htbl_ptr_h%ptr = c_loc(x)
    type is (integer(i8))
       htbl_ptr_h%ptr = c_loc(x)
    type is (real)
       htbl_ptr_h%ptr = c_loc(x)
    type is (double precision)
       htbl_ptr_h%ptr = c_loc(x)
    class default
       call neko_error('Unknown Fortran type')
    end select
 
    if (device_addrtbl%get(htbl_ptr_h, htbl_ptr_d) .eq. 0) then
       device_get_ptr_r3 = htbl_ptr_d%ptr
    else
       call neko_error('Array not associated with device')
    end if
  end function device_get_ptr_r3
 
  function device_get_ptr_r4(x)
    class(*), intent(in), target :: x(:,:,:,:)
    type(h_cptr_t) :: htbl_ptr_h, htbl_ptr_d
    type(c_ptr) :: device_get_ptr_r4
 
    device_get_ptr_r4 = c_null_ptr
 
    select type (x)
    type is (integer)
       htbl_ptr_h%ptr = c_loc(x)
    type is (integer(i8))
       htbl_ptr_h%ptr = c_loc(x)
    type is (real)
       htbl_ptr_h%ptr = c_loc(x)
    type is (double precision)
       htbl_ptr_h%ptr = c_loc(x)
    class default
       call neko_error('Unknown Fortran type')
    end select
 
    if (device_addrtbl%get(htbl_ptr_h, htbl_ptr_d) .eq. 0) then
       device_get_ptr_r4 = htbl_ptr_d%ptr
    else
       call neko_error('Array not associated with device')
    end if
  end function device_get_ptr_r4
 
  subroutine device_sync_device()
#ifdef HAVE_HIP
    if (hipdevicesynchronize() .ne. hipsuccess) then
       call neko_error('Error during device sync')
    end if
#elif HAVE_CUDA
    if (cudadevicesynchronize() .ne. cudasuccess) then
       call neko_error('Error during device sync')
    end if
#elif HAVE_OPENCL
    if (clfinish(glb_cmd_queue) .ne. cl_success) then
       call neko_error('Error during device sync')
    end if
#endif
  end subroutine device_sync_device
 
  subroutine device_sync_stream(stream)
    type(c_ptr), intent(in) :: stream
#ifdef HAVE_HIP
    if (hipstreamsynchronize(stream) .ne. hipsuccess) then
       call neko_error('Error during stream sync')
    end if
#elif HAVE_CUDA
    if (cudastreamsynchronize(stream) .ne. cudasuccess) then
       call neko_error('Error during stream sync')
    end if
#elif HAVE_OPENCL
    if (clfinish(stream) .ne. cl_success) then
       call neko_error('Error during stream sync')
    end if
#endif
  end subroutine device_sync_stream
 
  subroutine device_stream_create(stream, flags)
    type(c_ptr), intent(inout) :: stream
    integer, optional :: flags
    integer :: ierr
#ifdef HAVE_HIP
    if (present(flags)) then
       if (hipstreamcreatewithflags(stream, flags) .ne. hipsuccess) then
          call neko_error('Error during stream create (w. flags)')
       end if
    else
       if (hipstreamcreate(stream) .ne. hipsuccess) then
          call neko_error('Error during stream create')
       end if
    end if
#elif HAVE_CUDA
    if (present(flags)) then
       if (cudastreamcreatewithflags(stream, flags) .ne. cudasuccess) then
          call neko_error('Error during stream create (w. flags)')
       end if
    else
       if (cudastreamcreate(stream) .ne. cudasuccess) then
          call neko_error('Error during stream create')
       end if
    end if
#elif HAVE_OPENCL
    stream = clcreatecommandqueue(glb_ctx, glb_device_id, 0_i8, ierr)
    if (ierr .ne. cl_success) then
       call neko_error('Error during stream create')
    end if
#endif
  end subroutine device_stream_create
 
  subroutine device_stream_create_with_priority(stream, flags, prio)
    type(c_ptr), intent(inout) :: stream
    integer, intent(in) :: flags, prio
#ifdef HAVE_HIP
    if (hipstreamcreatewithpriority(stream, flags, prio) .ne. hipsuccess) then
       call neko_error('Error during stream create (w. priority)')
    end if
#elif HAVE_CUDA
    if (cudastreamcreatewithpriority(stream, flags, prio) .ne. cudasuccess) then
       call neko_error('Error during stream create (w. priority)')
    end if
#elif HAVE_OPENCL
    call neko_error('Not implemented yet')
#endif
  end subroutine device_stream_create_with_priority
 
  subroutine device_stream_destroy(stream)
    type(c_ptr), intent(inout) :: stream
#ifdef HAVE_HIP
    if (hipstreamdestroy(stream) .ne. hipsuccess) then
       call neko_error('Error during stream destroy')
    end if
#elif HAVE_CUDA
    if (cudastreamdestroy(stream) .ne. cudasuccess) then
       call neko_error('Error during stream destroy')
    end if
#elif HAVE_OPENCL
    if (clreleasecommandqueue(stream) .ne. cl_success) then
       call neko_error('Error during stream destroy')
    end if
#endif
  end subroutine device_stream_destroy
 
  subroutine device_stream_wait_event(stream, event, flags)
    type(c_ptr), intent(in) :: stream
    type(c_ptr), target, intent(in) :: event
    integer :: flags
#ifdef HAVE_HIP
    if (hipstreamwaitevent(stream, event, flags) .ne. hipsuccess) then
       call neko_error('Error during stream sync')
    end if
#elif HAVE_CUDA
    if (cudastreamwaitevent(stream, event, flags) .ne. cudasuccess) then
       call neko_error('Error during stream sync')
    end if
#elif HAVE_OPENCL
    if (clenqueuebarrier(stream) .ne. cl_success) then
       call neko_error('Error during barrier')
    end if
    if (clenqueuewaitforevents(stream, 1, c_loc(event)) .ne. cl_success) then
       call neko_error('Error during stream sync')
    end if
#endif
  end subroutine device_stream_wait_event
 
  subroutine device_profiler_start()
#if HAVE_CUDA
    if (cudaprofilerstart() .ne. cudasuccess) then
       call neko_error('Error starting profiler')
    end if
#endif
  end subroutine device_profiler_start
 
  subroutine device_profiler_stop()
#if HAVE_CUDA
    if (cudaprofilerstop() .ne. cudasuccess) then
       call neko_error('Error stopping profiler')
    end if
#endif
  end subroutine device_profiler_stop
 
  subroutine device_event_create(event, flags)
    type(c_ptr), intent(inout) :: event
    integer, optional :: flags
    integer :: ierr
#ifdef HAVE_HIP
    if (present(flags)) then
       if (hipeventcreatewithflags(event, flags) .ne. hipsuccess) then
          call neko_error('Error during event create (w. flags)')
       end if
    else
       if (hipeventcreate(event) .ne. hipsuccess) then
          call neko_error('Error during event create')
       end if
    end if
#elif HAVE_CUDA
    if (present(flags)) then
       if (cudaeventcreatewithflags(event, flags) .ne. cudasuccess) then
          call neko_error('Error during event create (w. flags)')
       end if
    else
       if (cudaeventcreate(event) .ne. cudasuccess) then
          call neko_error('Error during event create')
       end if
    end if
#elif HAVE_OPENCL
    event = c_null_ptr
#endif
  end subroutine device_event_create
 
  subroutine device_event_destroy(event)
    type(c_ptr), intent(inout) :: event
#ifdef HAVE_HIP
    if (hipeventdestroy(event) .ne. hipsuccess) then
       call neko_error('Error during event destroy')
    end if
#elif HAVE_CUDA
    if (cudaeventdestroy(event) .ne. cudasuccess) then
       call neko_error('Error during event destroy')
    end if
#elif HAVE_OPENCL
    event = c_null_ptr
#endif
  end subroutine device_event_destroy
 
  subroutine device_event_record(event, stream)
    type(c_ptr), target, intent(in) :: event
    type(c_ptr), intent(in) :: stream
#ifdef HAVE_HIP
    if (hipeventrecord(event, stream) .ne. hipsuccess) then
       call neko_error('Error recording an event')
    end if
#elif HAVE_CUDA
    if (cudaeventrecord(event, stream) .ne. cudasuccess) then
       call neko_error('Error recording an event')
    end if
#elif HAVE_OPENCL
    if (clenqueuemarker(stream, c_loc(event)) .ne. cl_success) then
       call neko_error('Error recording an event')
    end if
#endif
  end subroutine device_event_record
 
  subroutine device_event_sync(event)
    type(c_ptr), target, intent(in) :: event
#ifdef HAVE_HIP
    if (hipeventsynchronize(event) .ne. hipsuccess) then
       call neko_error('Error during event sync')
    end if
#elif HAVE_CUDA
    if (cudaeventsynchronize(event) .ne. cudasuccess) then
       call neko_error('Error during event sync')
    end if
#elif HAVE_OPENCL
    if (c_associated(event)) then
       if (clwaitforevents(1, c_loc(event)) .ne. cl_success) then
          call neko_error('Error during event sync')
       end if
    end if
#endif
  end subroutine device_event_sync
 
end module device