opencl_intf.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 opencl_intf
  use num_types, only : i8
  use utils, only : neko_error
  use, intrinsic :: iso_c_binding
  implicit none
 
#ifdef HAVE_OPENCL
 
  type(c_ptr), bind(c) :: glb_ctx = c_null_ptr
 
  type(c_ptr), bind(c), target :: glb_device_id = c_null_ptr
 
  enum, bind(c)
    enumerator :: cl_success = 0
    enumerator :: cl_device_not_found = -1
    enumerator :: cl_device_not_available = -2
    enumerator :: cl_compiler_not_available = -3
    enumerator :: cl_mem_object_allocation_failure = -4
    enumerator :: cl_out_of_resources = -5
    enumerator :: cl_out_of_host_memory = -6
    enumerator :: cl_profiling_info_not_available = -7
    enumerator :: cl_mem_copy_overlap = -8
    enumerator :: cl_image_format_mismatch = -9
    enumerator :: cl_image_format_not_supported = -10
    enumerator :: cl_build_program_failure = -11
    enumerator :: cl_map_failure = -12
  end enum
 
  enum, bind(c)
    enumerator :: cl_mem_read_write = 1
    enumerator :: cl_mem_write_only = 2
    enumerator :: cl_mem_read_only = 4
    enumerator :: cl_mem_use_host_ptr = 8
    enumerator :: cl_mem_alloc_host_ptr = 16
    enumerator :: cl_mem_host_write_only = 128
    enumerator :: cl_mem_host_read_only = 256
    enumerator :: cl_mem_host_no_access = 512
  end enum
 
  enum, bind(c)
    enumerator :: cl_complete = 0
    enumerator :: cl_running = 1
    enumerator :: cl_submitted = 2
    enumerator :: cl_queued = 3
  end enum
 
  enum, bind(c)
    enumerator :: cl_false = 0
    enumerator :: cl_true = 1
  end enum
 
  enum, bind(c)
    enumerator :: cl_context_platform = int(z'1084')
  end enum
 
  enum, bind(c)
    enumerator :: cl_device_name = 4139
  end enum
 
  integer(c_int64_t), parameter :: cl_device_type_default = 1
  integer(c_int64_t), parameter :: cl_device_type_cpu = 2
  integer(c_int64_t), parameter :: cl_device_type_gpu = 4
  integer(c_int64_t), parameter :: cl_device_type_accelerator = 8
  integer(c_int64_t), parameter :: cl_device_type_custom = 16
  integer(c_int64_t), parameter :: cl_device_type_all = int(z'FFFFFFFF', i8)
 
  integer(c_int64_t), parameter :: cl_queue_out_of_order_exec_mode_enable = 1
  integer(c_int64_t), parameter :: cl_queue_profiling_enable = 2
 
  interface
     integer(c_int) function clgetplatformids(num_entries, platforms, &
          num_platforms) bind(c, name = 'clGetPlatformIDs')
       use, intrinsic :: iso_c_binding
       implicit none
       integer(c_int), value :: num_entries
       type(c_ptr), value :: platforms
       integer(c_int) :: num_platforms
     end function clgetplatformids
  end interface
 
  interface
     integer(c_int) function clgetdeviceids(platform, device_type, &
          num_entries, devices, num_devices) bind(c, name = 'clGetDeviceIDs')
       use, intrinsic :: iso_c_binding
       implicit none
       type(c_ptr), value :: platform
       integer(c_int64_t), value :: device_type
       integer(c_int), value :: num_entries
       type(c_ptr), value :: devices
       integer(c_int) :: num_devices
     end function clgetdeviceids
  end interface
 
  interface
     type (c_ptr) function clcreatecontext(properties, num_devices, devices, &
          pfn_notify, user_data, ierr) bind(c, name = 'clCreateContext')
       use, intrinsic :: iso_c_binding
       implicit none
       type(c_ptr), value :: properties
       integer(c_int), value :: num_devices
       type(c_ptr), value :: devices
       type(c_funptr), value :: pfn_notify
       type(c_ptr), value :: user_data
       integer(c_int) :: ierr
     end function clcreatecontext
  end interface
 
  interface
     type(c_ptr) function clcreatecommandqueue(context, device, &
          properties, ierr) bind(c, name = 'clCreateCommandQueue')
       use, intrinsic :: iso_c_binding
       implicit none
       type(c_ptr), value :: context
       type(c_ptr), value :: device
       integer(c_int64_t), value :: properties
       integer(c_int) :: ierr
     end function clcreatecommandqueue
  end interface
 
  interface
     type(c_ptr) function clcreatebuffer(context, flags, size, host_ptr, ierr) &
          bind(c, name = 'clCreateBuffer')
       use, intrinsic :: iso_c_binding
       implicit none
       type(c_ptr), value :: context
       integer(c_int), value :: flags
       integer(c_size_t), value :: size
       type(c_ptr), value :: host_ptr
       integer(c_int) :: ierr
     end function clcreatebuffer
  end interface
 
  interface
     type(c_ptr) function clcreateuserevent(context, ierr) &
          bind(c, name = 'clCreateUserEvent')
       use, intrinsic :: iso_c_binding
       implicit none
       type(c_ptr), value :: context
       integer(c_int) :: ierr
     end function clcreateuserevent
  end interface
 
  interface
     integer(c_int) function clenqueuereadbuffer(queue, buffer, blocking_read, &
          offset, size, ptr, num_events_in_wait_list, event_wait_list, event) &
          bind(c, name = 'clEnqueueReadBuffer')
       use, intrinsic :: iso_c_binding
       implicit none
       type(c_ptr), value :: queue
       type(c_ptr), value :: buffer
       integer(c_int), value :: blocking_read
       integer(c_size_t), value :: offset
       integer(c_size_t), value :: size
       type(c_ptr), value :: ptr
       integer(c_int), value :: num_events_in_wait_list
       type(c_ptr), value :: event_wait_list
       type(c_ptr), value :: event
     end function clenqueuereadbuffer
  end interface
 
  interface
     integer(c_int) function clenqueuewritebuffer(queue, buffer, &
          blocking_write, offset, size, ptr, num_events_in_wait_list, &
          event_wait_list, event) bind(c, name = 'clEnqueueWriteBuffer')
       use, intrinsic :: iso_c_binding
       implicit none
       type(c_ptr), value :: queue
       type(c_ptr), value :: buffer
       integer(c_int), value :: blocking_write
       integer(c_size_t), value :: offset
       integer(c_size_t), value :: size
       type(c_ptr), value :: ptr
       integer(c_int), value :: num_events_in_wait_list
       type(c_ptr), value :: event_wait_list
       type(c_ptr), value :: event
     end function clenqueuewritebuffer
  end interface
 
  interface
     integer(c_int) function clenqueuecopybuffer(queue, src_buffer, &
          dst_buffer, src_offset, dst_offset, size, num_events_in_wait_list, &
          event_wait_list, event) bind(c, name = 'clEnqueueCopyBuffer')
       use, intrinsic :: iso_c_binding
       implicit none
       type(c_ptr), value :: queue
       type(c_ptr), value :: src_buffer
       type(c_ptr), value :: dst_buffer
       integer(c_size_t), value :: src_offset
       integer(c_size_t), value :: dst_offset
       integer(c_size_t), value :: size
       integer(c_int), value :: num_events_in_wait_list
       type(c_ptr), value :: event_wait_list
       type(c_ptr), value :: event
     end function clenqueuecopybuffer
  end interface
 
  interface
     integer(c_int) function clenqueuefillbuffer(queue, buffer, &
          pattern, pattern_size, offset, size, num_events_in_wait_list, &
          event_wait_list, event) bind(c, name = 'clEnqueueFillBuffer')
       use, intrinsic :: iso_c_binding
       implicit none
       type(c_ptr), value :: queue
       type(c_ptr), value :: buffer
       type(c_ptr), value :: pattern
       integer(c_size_t), value :: pattern_size
       integer(c_size_t), value :: offset
       integer(c_size_t), value :: size
       integer(c_int), value :: num_events_in_wait_list
       type(c_ptr), value :: event_wait_list
       type(c_ptr), value :: event
     end function clenqueuefillbuffer
  end interface
 
  interface
     integer(c_int) function clenqueuemarkerwithwaitlist &
          (queue, num_events_in_wait_list, event_wait_list, event) &
          bind(c, name = 'clEnqueueMarkerWithWaitList')
       use, intrinsic :: iso_c_binding
       implicit none
       type(c_ptr), value :: queue
       integer(c_int), value :: num_events_in_wait_list
       type(c_ptr), value :: event_wait_list
       type(c_ptr), value :: event
     end function clenqueuemarkerwithwaitlist
  end interface
 
  interface
     integer(c_int) function clenqueuemarker(cmd_queue, event) &
          bind(c, name = 'clEnqueueMarker')
       use, intrinsic :: iso_c_binding
       implicit none
       type(c_ptr), value :: cmd_queue
       type(c_ptr), value :: event
     end function clenqueuemarker
  end interface
 
  interface
     integer(c_int) function clenqueuebarrier(cmd_queue) &
          bind(c, name = 'clEnqueueBarrier')
       use, intrinsic :: iso_c_binding
       implicit none
       type(c_ptr), value :: cmd_queue
     end function clenqueuebarrier
  end interface
 
  interface
     integer(c_int) function clenqueuewaitforevents(queue, &
          num_events, event_list) bind(c, name = 'clEnqueueWaitForEvents')
       use, intrinsic :: iso_c_binding
       implicit none
       type(c_ptr), value :: queue
       integer(c_int), value :: num_events
       type(c_ptr), value :: event_list
     end function clenqueuewaitforevents
  end interface
 
  interface
     integer(c_int) function clwaitforevents(num_events, event_list) &
          bind(c, name = 'clWaitForEvents')
       use, intrinsic :: iso_c_binding
       implicit none
       integer(c_int), value :: num_events
       type(c_ptr), value :: event_list
     end function clwaitforevents
  end interface
 
  interface
     integer(c_int) function clsetusereventstatus(event, status) &
          bind(c, name = 'clSetUserEventStatus')
       use, intrinsic :: iso_c_binding
       implicit none
       type(c_ptr), value :: event
       integer(c_int), value :: status
     end function clsetusereventstatus
  end interface
 
  interface
     integer(c_int) function clgetdeviceinfo(device, param_name, &
          param_value_size, param_value, param_value_size_ret) &
          bind(c, name = 'clGetDeviceInfo')
       use, intrinsic :: iso_c_binding
       implicit none
       type(c_ptr), value :: device
       integer(c_int), value :: param_name
       integer(c_size_t), value :: param_value_size
       type(c_ptr), value :: param_value
       type(c_ptr), value :: param_value_size_ret
     end function clgetdeviceinfo
  end interface
 
  interface
     integer(c_int) function clreleasecontext(context) &
          bind(c, name = 'clReleaseContext')
       use, intrinsic :: iso_c_binding
       implicit none
       type(c_ptr), value :: context
     end function clreleasecontext
  end interface
 
  interface
     integer(c_int) function clreleasecommandqueue(queue) &
          bind(c, name = 'clReleaseCommandQueue')
       use, intrinsic :: iso_c_binding
       implicit none
       type(c_ptr), value :: queue
     end function clreleasecommandqueue
  end interface
 
  interface
     integer(c_int) function clreleasedevice(device) &
          bind(c, name = 'clReleaseDevice')
       use, intrinsic :: iso_c_binding
       implicit none
       type(c_ptr), value :: device
     end function clreleasedevice
  end interface
 
  interface
     integer(c_int) function clreleaseprogram(prgm) &
          bind(c, name = 'clReleaseProgram')
       use, intrinsic :: iso_c_binding
       implicit none
       type(c_ptr), value :: prgm
     end function clreleaseprogram
  end interface
 
  interface
     integer(c_int) function clreleasememobject(ptr_d) &
          bind(c, name = 'clReleaseMemObject')
       use, intrinsic :: iso_c_binding
       implicit none
       type(c_ptr), value :: ptr_d
     end function clreleasememobject
  end interface
 
  interface
     integer(c_int) function clreleaseevent(event) &
          bind(c, name = 'clReleaseEvent')
       use, intrinsic :: iso_c_binding
       implicit none
       type(c_ptr), value :: event
     end function clreleaseevent
  end interface
 
  interface
     integer(c_int) function clflush(cmd_queue) &
          bind(c, name = 'clFlush')
       use, intrinsic :: iso_c_binding
       implicit none
       type(c_ptr), value :: cmd_queue
     end function clflush
  end interface
 
  interface
     integer(c_int) function clfinish(cmd_queue) &
          bind(c, name = 'clFinish')
       use, intrinsic :: iso_c_binding
       implicit none
       type(c_ptr), value :: cmd_queue
     end function clfinish
  end interface
 
contains
 
  subroutine opencl_init(glb_cmd_queue, aux_cmd_queue, prf_cmd_queue)
    type(c_ptr), intent(inout) :: glb_cmd_queue
    type(c_ptr), intent(inout) :: aux_cmd_queue
    type(c_ptr), intent(inout) :: prf_cmd_queue
    type(c_ptr), target :: platform_id
    integer(c_int) :: num_platforms, num_devices, ierr
    integer(c_intptr_t) :: ctx_prop(3)
    integer(c_int64_t), parameter :: queue_props = 0
    integer :: i
 
    if (clgetplatformids(1, c_loc(platform_id), &
                         num_platforms) .ne. cl_success) then
       call neko_error('Failed to get a platform id')
    end if
 
    if (clgetdeviceids(platform_id, cl_device_type_gpu, 1, &
         c_loc(glb_device_id), num_devices) .ne. cl_success) then
       call neko_error('Failed to get a device id')
    end if
 
    if (c_associated(glb_ctx)) then
       if (clreleasecontext(glb_ctx) .ne. cl_success) then
          call neko_error('Failed to release context')
       end if
    end if
 
    glb_ctx = clcreatecontext(c_null_ptr, num_devices, c_loc(glb_device_id), &
         c_null_funptr, c_null_ptr, ierr)
 
    if (ierr .ne. cl_success) then
       call neko_error('Failed to create an OpenCL context')
    end if
 
    if (c_associated(glb_cmd_queue)) then
       if (clreleasecommandqueue(glb_cmd_queue) .ne. cl_success) then
          call neko_error('Faield to release command queue')
       end if
    end if
 
    glb_cmd_queue = clcreatecommandqueue(glb_ctx, glb_device_id, &
         queue_props, ierr)
    if (ierr .ne. cl_success) then
       call neko_error('Failed to create a command queue')
    end if
 
    aux_cmd_queue = clcreatecommandqueue(glb_ctx, glb_device_id, &
         queue_props, ierr)
    if (ierr .ne. cl_success) then
       call neko_error('Failed to create a command queue')
    end if
 
    prf_cmd_queue = clcreatecommandqueue(glb_ctx, glb_device_id, &
         cl_queue_profiling_enable, ierr)
    if (ierr .ne. cl_success) then
       call neko_error('Failed to create a command queue')
    end if
 
  end subroutine opencl_init
 
  subroutine opencl_finalize(glb_cmd_queue, aux_cmd_queue, prf_cmd_queue)
    type(c_ptr), intent(inout) :: glb_cmd_queue
    type(c_ptr), intent(inout) :: aux_cmd_queue
    type(c_ptr), intent(inout) :: prf_cmd_queue
 
    if (c_associated(glb_ctx)) then
       if (clreleasecontext(glb_ctx) .ne. cl_success) then
          call neko_error('Failed to release context')
       end if
       glb_ctx = c_null_ptr
    end if
 
    if (c_associated(glb_cmd_queue)) then
       if (clreleasecommandqueue(glb_cmd_queue) .ne. cl_success) then
          call neko_error('Failed to release command queue')
       end if
       glb_cmd_queue = c_null_ptr
    end if
 
    if (c_associated(aux_cmd_queue)) then
       if (clreleasecommandqueue(aux_cmd_queue) .ne. cl_success) then
          call neko_error('Failed to release command queue')
       end if
       aux_cmd_queue = c_null_ptr
    end if
 
    if (c_associated(prf_cmd_queue)) then
       if (clreleasecommandqueue(prf_cmd_queue) .ne. cl_success) then
          call neko_error('Failed to release command queue')
       end if
       prf_cmd_queue = c_null_ptr
    end if
 
    if (c_associated(glb_device_id)) then
       if (clreleasedevice(glb_device_id) .ne. cl_success) then
          call neko_error('Failed to release device')
       end if
    end if
 
  end subroutine opencl_finalize
 
  subroutine opencl_device_name(name)
    character(len=*), intent(inout) :: name
    character(kind=c_char, len=1024), target :: c_name
    integer(c_size_t), target :: name_len
 
    if (clgetdeviceinfo(glb_device_id, cl_device_name, int(1024, i8), &
         c_loc(c_name), c_loc(name_len)) .ne. cl_success) then
       call neko_error('Failed to query device')
    end if
 
    name(1:name_len) = c_name(1:name_len)
 
  end subroutine opencl_device_name
 
  integer function opencl_device_count()
    type(c_ptr), target :: platform_id
    integer(c_int) :: num_platforms, num_devices
 
    if (clgetplatformids(1, c_loc(platform_id), num_platforms) &
         .ne. cl_success) then
       call neko_error('Failed to get a platform id')
    end if
 
    if (clgetdeviceids(platform_id, cl_device_type_gpu, 0, &
         c_null_ptr, num_devices) .ne. cl_success) then
       call neko_error('Failed to get a device id')
    end if
 
    opencl_device_count = num_devices
 
  end function opencl_device_count
#endif
 
end module opencl_intf