gs_device.F90

Go to the documentation of this file.

! Copyright (c) 2021-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 gs_device
  use num_types, only : rp, c_rp
  use gs_bcknd, only : gs_bcknd_t
  use device, only : device_map, device_memcpy, device_memset, &
       device_free, device_event_destroy, device_event_create, &
       device_event_record, device_get_ptr, glb_cmd_queue, &
       device_sync, host_to_device, device_to_host
  use utils, only : neko_error
  use, intrinsic :: iso_c_binding, only : c_ptr, c_int, c_null_ptr, &
       c_associated, c_sizeof, c_size_t
  implicit none
  private
 
  type, public, extends(gs_bcknd_t) :: gs_device_t
     type(c_ptr) :: local_gs_d = c_null_ptr 
     type(c_ptr) :: local_dof_gs_d = c_null_ptr 
     type(c_ptr) :: local_gs_dof_d = c_null_ptr 
     type(c_ptr) :: shared_gs_d = c_null_ptr 
     type(c_ptr) :: shared_dof_gs_d = c_null_ptr 
     type(c_ptr) :: shared_gs_dof_d = c_null_ptr 
     type(c_ptr) :: local_blk_len_d = c_null_ptr 
     type(c_ptr) :: shared_blk_len_d = c_null_ptr
     type(c_ptr) :: local_blk_off_d = c_null_ptr 
     type(c_ptr) :: shared_blk_off_d = c_null_ptr
     integer :: nlocal
     integer :: nshared
   contains
     procedure, pass(this) :: init => gs_device_init
     procedure, pass(this) :: free => gs_device_free
     procedure, pass(this) :: gather => gs_gather_device
     procedure, pass(this) :: scatter => gs_scatter_device
  end type gs_device_t
 
#ifdef HAVE_HIP
  interface
     subroutine hip_gather_kernel(v, m, o, dg, u, n, gd, nb, b, bo, op, strm) &
          bind(c, name = 'hip_gather_kernel')
       use, intrinsic :: iso_c_binding
       implicit none
       integer(c_int) :: m, n, nb, o, op
       type(c_ptr), value :: v, u, dg, gd, b, bo, strm
     end subroutine hip_gather_kernel
  end interface
 
  interface
     subroutine hip_scatter_kernel(v, m, dg, u, n, gd, nb, b, bo, strm) &
          bind(c, name = 'hip_scatter_kernel')
       use, intrinsic :: iso_c_binding
       implicit none
       integer(c_int) :: m, n, nb
       type(c_ptr), value :: v, u, dg, gd, b, bo, strm
     end subroutine hip_scatter_kernel
  end interface
 
#elif HAVE_CUDA
  interface
     subroutine cuda_gather_kernel(v, m, o, dg, u, n, gd, nb, b, bo, op, strm) &
          bind(c, name = 'cuda_gather_kernel')
       use, intrinsic :: iso_c_binding
       implicit none
       integer(c_int) :: m, n, nb, o, op
       type(c_ptr), value :: v, u, dg, gd, b, bo, strm
     end subroutine cuda_gather_kernel
  end interface
 
  interface
     subroutine cuda_scatter_kernel(v, m, dg, u, n, gd, nb, b, bo, strm) &
          bind(c, name = 'cuda_scatter_kernel')
       use, intrinsic :: iso_c_binding
       implicit none
       integer(c_int) :: m, n, nb
       type(c_ptr), value :: v, u, dg, gd, b, bo, strm
     end subroutine cuda_scatter_kernel
  end interface
#elif HAVE_OPENCL
  interface
     subroutine opencl_gather_kernel(v, m, o, dg, u, n, gd, nb, b, bo, op, &
          strm) bind(c, name = 'opencl_gather_kernel')
       use, intrinsic :: iso_c_binding
       implicit none
       integer(c_int) :: m, n, nb, o, op
       type(c_ptr), value :: v, u, dg, gd, b, bo, strm
     end subroutine opencl_gather_kernel
  end interface
 
  interface
     subroutine opencl_scatter_kernel(v, m, dg, u, n, gd, nb, b, bo, strm) &
          bind(c, name = 'opencl_scatter_kernel')
       use, intrinsic :: iso_c_binding
       implicit none
       integer(c_int) :: m, n, nb
       type(c_ptr), value :: v, u, dg, gd, b, bo, strm
     end subroutine opencl_scatter_kernel
  end interface
#elif HAVE_METAL
  interface
     subroutine metal_gather_kernel(v, m, o, dg, u, n, gd, nb, b, bo, op, &
          strm) bind(c, name = 'metal_gather_kernel')
       use, intrinsic :: iso_c_binding
       implicit none
       integer(c_int) :: m, n, nb, o, op
       type(c_ptr), value :: v, u, dg, gd, b, bo, strm
     end subroutine metal_gather_kernel
  end interface
 
  interface
     subroutine metal_scatter_kernel(v, m, dg, u, n, gd, nb, b, bo, strm) &
          bind(c, name = 'metal_scatter_kernel')
       use, intrinsic :: iso_c_binding
       implicit none
       integer(c_int) :: m, n, nb
       type(c_ptr), value :: v, u, dg, gd, b, bo, strm
     end subroutine metal_scatter_kernel
  end interface
#endif
 
contains
 
  subroutine gs_device_init(this, nlocal, nshared, nlcl_blks, nshrd_blks)
    class(gs_device_t), intent(inout) :: this
    integer, intent(in) :: nlocal
    integer, intent(in) :: nshared
    integer, intent(in) :: nlcl_blks
    integer, intent(in) :: nshrd_blks
 
    call this%free()
 
    this%nlocal = nlocal
    this%nshared = nshared
 
    this%local_gs_d = c_null_ptr
    this%local_dof_gs_d = c_null_ptr
    this%local_gs_dof_d = c_null_ptr
    this%local_blk_len_d = c_null_ptr
    this%local_blk_off_d = c_null_ptr
    this%shared_gs_d = c_null_ptr
    this%shared_dof_gs_d = c_null_ptr
    this%shared_gs_dof_d = c_null_ptr
    this%shared_blk_len_d = c_null_ptr
    this%shared_blk_off_d = c_null_ptr
 
    this%shared_on_host = .true.
 
#if defined(HAVE_HIP) || defined(HAVE_CUDA) || defined(HAVE_METAL)
    call device_event_create(this%gather_event, 2)
    call device_event_create(this%scatter_event, 2)
#endif
 
    this%gs_stream = glb_cmd_queue
 
  end subroutine gs_device_init
 
  subroutine gs_device_free(this)
    class(gs_device_t), intent(inout) :: this
 
    if (c_associated(this%local_gs_d)) then
       call device_free(this%local_gs_d)
    end if
 
    if (c_associated(this%local_dof_gs_d)) then
       call device_free(this%local_dof_gs_d)
    end if
 
    if (c_associated(this%local_gs_dof_d)) then
       call device_free(this%local_gs_dof_d)
    end if
 
    if (c_associated(this%local_blk_len_d)) then
       call device_free(this%local_blk_len_d)
    end if
 
    if (c_associated(this%shared_blk_len_d)) then
       call device_free(this%shared_blk_len_d)
    end if
 
    if (c_associated(this%local_blk_off_d)) then
       call device_free(this%local_blk_off_d)
    end if
 
    if (c_associated(this%shared_blk_off_d)) then
       call device_free(this%shared_blk_off_d)
    end if
 
    this%nlocal = 0
    this%nshared = 0
 
#if defined(HAVE_HIP) || defined(HAVE_CUDA) || defined(HAVE_METAL)
    if (c_associated(this%gather_event)) then
       call device_event_destroy(this%gather_event)
    end if
 
    if (c_associated(this%scatter_event)) then
       call device_event_destroy(this%scatter_event)
    end if
#endif
 
    if (c_associated(this%gs_stream)) then
       this%gs_stream = c_null_ptr
    end if
 
  end subroutine gs_device_free
 
  subroutine gs_gather_device(this, v, m, o, dg, u, n, gd, nb, b, bo, op, shrd)
    integer, intent(in) :: m
    integer, intent(in) :: n
    integer, intent(in) :: nb
    class(gs_device_t), intent(inout) :: this
    real(kind=rp), dimension(m), intent(inout) :: v
    integer, dimension(m), intent(inout) :: dg
    real(kind=rp), dimension(n), intent(inout) :: u
    integer, dimension(m), intent(inout) :: gd
    integer, dimension(nb), intent(inout) :: b
    integer, dimension(nb), intent(inout) :: bo
    integer, intent(in) :: o
    integer, intent(in) :: op
    logical, intent(in) :: shrd
    integer :: i
    type(c_ptr) :: u_d
 
    u_d = device_get_ptr(u)
 
    if (.not. shrd) then
       associate(v_d => this%local_gs_d, dg_d => this%local_dof_gs_d, &
            gd_d => this%local_gs_dof_d, b_d => this%local_blk_len_d, &
            bo_d => this%local_blk_off_d, strm => this%gs_stream)
 
         if (.not. c_associated(v_d)) then
            call device_map(v, v_d, m)
            block
              real(c_rp) :: rp_dummy
              integer(c_size_t) :: s
              s = c_sizeof(rp_dummy) * m
              call device_memset(v_d, 0, s, strm = strm)
            end block
         end if
 
         if (.not. c_associated(dg_d)) then
            call device_map(dg, dg_d, m)
            call device_memcpy(dg, dg_d, m, host_to_device, &
                 sync = .false., strm = strm)
         end if
 
         if (.not. c_associated(gd_d)) then
            call device_map(gd, gd_d, m)
            call device_memcpy(gd, gd_d, m, host_to_device, &
                 sync = .false., strm = strm)
         end if
 
         if (nb .gt. 0) then
            if (.not. c_associated(b_d)) then
               call device_map(b, b_d, nb)
               call device_memcpy(b, b_d, nb, host_to_device, &
                    sync = .false., strm = strm)
            end if
 
            if (.not. c_associated(bo_d)) then
               call device_map(bo, bo_d, nb)
               call device_memcpy(bo, bo_d, nb, host_to_device, &
                    sync = .false., strm = strm)
            end if
         end if
 
#ifdef HAVE_HIP
         call hip_gather_kernel(v_d, m, o, dg_d, u_d, n, gd_d, &
              nb, b_d, bo_d, op, strm)
#elif HAVE_CUDA
         call cuda_gather_kernel(v_d, m, o, dg_d, u_d, n, gd_d, &
              nb, b_d, bo_d, op, strm)
#elif HAVE_OPENCL
         call opencl_gather_kernel(v_d, m, o, dg_d, u_d, n, gd_d, &
              nb, b_d, bo_d, op, strm)
#elif HAVE_METAL
         call metal_gather_kernel(v_d, m, o, dg_d, u_d, n, gd_d, &
              nb, b_d, bo_d, op, strm)
#else
         call neko_error('No device backend configured')
#endif
 
       end associate
    else if (shrd) then
       associate(v_d => this%shared_gs_d, dg_d => this%shared_dof_gs_d, &
            gd_d => this%shared_gs_dof_d, b_d => this%shared_blk_len_d, &
            bo_d => this%shared_blk_off_d, strm => this%gs_stream)
 
         if (.not. c_associated(v_d)) then
            call device_map(v, v_d, m)
            block
              real(c_rp) :: rp_dummy
              integer(c_size_t) :: s
              s = c_sizeof(rp_dummy) * m
              call device_memset(v_d, 0, s, strm = strm)
            end block
         end if
 
         if (.not. c_associated(dg_d)) then
            call device_map(dg, dg_d, m)
            call device_memcpy(dg, dg_d, m, host_to_device, &
                 sync = .false., strm = strm)
         end if
 
         if (.not. c_associated(gd_d)) then
            call device_map(gd, gd_d, m)
            call device_memcpy(gd, gd_d, m, host_to_device, &
                 sync = .false., strm = strm)
         end if
 
         if (nb .gt. 0) then
            if (.not. c_associated(b_d)) then
               call device_map(b, b_d, nb)
               call device_memcpy(b, b_d, nb, host_to_device, &
                    sync = .false., strm = strm)
            end if
 
            if (.not. c_associated(bo_d)) then
               call device_map(bo, bo_d, nb)
               call device_memcpy(bo, bo_d, nb, host_to_device, &
                    sync = .false., strm = strm)
            end if
         end if
 
 
#ifdef HAVE_HIP
         call hip_gather_kernel(v_d, m, o, dg_d, u_d, n, gd_d, &
              nb, b_d, bo_d, op, strm)
#elif HAVE_CUDA
         call cuda_gather_kernel(v_d, m, o, dg_d, u_d, n, gd_d, &
              nb, b_d, bo_d, op, strm)
#elif HAVE_OPENCL
         call opencl_gather_kernel(v_d, m, o, dg_d, u_d, n, gd_d, &
              nb, b_d, bo_d, op, strm)
#elif HAVE_METAL
         call metal_gather_kernel(v_d, m, o, dg_d, u_d, n, gd_d, &
              nb, b_d, bo_d, op, strm)
#else
         call neko_error('No device backend configured')
#endif
 
#if defined(HAVE_HIP) || defined(HAVE_CUDA) || \
         defined(have_opencl) || defined(have_metal)
         call device_event_record(this%gather_event, strm)
#endif
 
         if (this%shared_on_host) then
            if (this%nshared .eq. m) then
               call device_memcpy(v, v_d, m, device_to_host, &
                    sync = .true., strm = strm)
            end if
         end if
 
       end associate
    end if
 
  end subroutine gs_gather_device
 
  subroutine gs_scatter_device(this, v, m, dg, u, n, gd, nb, b, bo, shrd, event)
    integer, intent(in) :: m
    integer, intent(in) :: n
    integer, intent(in) :: nb
    class(gs_device_t), intent(inout) :: this
    real(kind=rp), dimension(m), intent(inout) :: v
    integer, dimension(m), intent(inout) :: dg
    real(kind=rp), dimension(n), intent(inout) :: u
    integer, dimension(m), intent(inout) :: gd
    integer, dimension(nb), intent(inout) :: b
    integer, dimension(nb), intent(inout) :: bo
    logical, intent(in) :: shrd
    type(c_ptr) :: event
    type(c_ptr) :: u_d
 
    u_d = device_get_ptr(u)
 
    if (.not. shrd) then
       associate(v_d => this%local_gs_d, dg_d => this%local_dof_gs_d, &
            gd_d => this%local_gs_dof_d, b_d => this%local_blk_len_d, &
            bo_d => this%local_blk_off_d, strm => this%gs_stream)
#ifdef HAVE_HIP
         call hip_scatter_kernel(v_d, m, dg_d, u_d, n, gd_d, nb, b_d, bo_d, &
              strm)
#elif HAVE_CUDA
         call cuda_scatter_kernel(v_d, m, dg_d, u_d, n, gd_d, nb, b_d, bo_d, &
              strm)
#elif HAVE_OPENCL
         call opencl_scatter_kernel(v_d, m, dg_d, u_d, n, gd_d, nb, b_d, &
              bo_d, strm)
#elif HAVE_METAL
         call metal_scatter_kernel(v_d, m, dg_d, u_d, n, gd_d, nb, b_d, &
              bo_d, strm)
#else
         call neko_error('No device backend configured')
#endif
       end associate
    else if (shrd) then
       associate(v_d => this%shared_gs_d, dg_d => this%shared_dof_gs_d, &
            gd_d => this%shared_gs_dof_d, b_d => this%shared_blk_len_d, &
            bo_d => this%shared_blk_off_d, strm => this%gs_stream)
 
         if (this%shared_on_host) then
            call device_memcpy(v, v_d, m, host_to_device, &
                 sync = .false., strm = strm)
         end if
 
#ifdef HAVE_HIP
         call hip_scatter_kernel(v_d, m, dg_d, u_d, n, gd_d, nb, b_d, bo_d, &
              strm)
#elif HAVE_CUDA
         call cuda_scatter_kernel(v_d, m, dg_d, u_d, n, gd_d, nb, b_d, bo_d, &
              strm)
#elif HAVE_OPENCL
         call opencl_scatter_kernel(v_d, m, dg_d, u_d, n, gd_d, nb, b_d, &
              bo_d, strm)
#elif HAVE_METAL
         call metal_scatter_kernel(v_d, m, dg_d, u_d, n, gd_d, nb, b_d, &
              bo_d, strm)
#else
         call neko_error('No device backend configured')
#endif
       end associate
    end if
 
#if defined(HAVE_HIP) || defined(HAVE_CUDA) || \
    defined(have_opencl) || defined(have_metal)
    if (c_associated(event)) then
       call device_event_record(event, this%gs_stream)
    else
       call device_sync(this%gs_stream)
    end if
#endif
 
 
  end subroutine gs_scatter_device
 
end module gs_device