Neko  0.9.99
A portable framework for high-order spectral element flow simulations
opencl_intf.F90
Go to the documentation of this file.
1 ! Copyright (c) 2021-2023, The Neko Authors
2 ! All rights reserved.
3 !
4 ! Redistribution and use in source and binary forms, with or without
5 ! modification, are permitted provided that the following conditions
6 ! are met:
7 !
8 ! * Redistributions of source code must retain the above copyright
9 ! notice, this list of conditions and the following disclaimer.
10 !
11 ! * Redistributions in binary form must reproduce the above
12 ! copyright notice, this list of conditions and the following
13 ! disclaimer in the documentation and/or other materials provided
14 ! with the distribution.
15 !
16 ! * Neither the name of the authors nor the names of its
17 ! contributors may be used to endorse or promote products derived
18 ! from this software without specific prior written permission.
19 !
20 ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
21 ! "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
22 ! LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
23 ! FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
24 ! COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
25 ! INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
26 ! BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
27 ! LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
28 ! CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
29 ! LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
30 ! ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
31 ! POSSIBILITY OF SUCH DAMAGE.
32 !
35  use num_types, only : i8
36  use utils, only : neko_error
37  use, intrinsic :: iso_c_binding
38  implicit none
39 
40 #ifdef HAVE_OPENCL
41 
43  type(c_ptr), bind(c) :: glb_cmd_queue = c_null_ptr
44 
46  type(c_ptr), bind(c) :: aux_cmd_queue = c_null_ptr
47 
49  type(c_ptr), bind(c) :: glb_ctx = c_null_ptr
50 
52  type(c_ptr), bind(c), target :: glb_device_id = c_null_ptr
53 
55  enum, bind(c)
56  enumerator :: cl_success = 0
57  enumerator :: cl_device_not_found = -1
58  enumerator :: cl_device_not_available = -2
59  enumerator :: cl_compiler_not_available = -3
61  enumerator :: cl_out_of_resources = -5
62  enumerator :: cl_out_of_host_memory = -6
64  enumerator :: cl_mem_copy_overlap = -8
65  enumerator :: cl_image_format_mismatch = -9
66  enumerator :: cl_image_format_not_supported = -10
67  enumerator :: cl_build_program_failure = -11
68  enumerator :: cl_map_failure = -12
69  end enum
70 
72  enum, bind(c)
73  enumerator :: cl_mem_read_write = 1
74  enumerator :: cl_mem_write_only = 2
75  enumerator :: cl_mem_read_only = 4
76  enumerator :: cl_mem_use_host_ptr = 8
77  enumerator :: cl_mem_alloc_host_ptr = 16
78  enumerator :: cl_mem_host_write_only = 128
79  enumerator :: cl_mem_host_read_only = 256
80  enumerator :: cl_mem_host_no_access = 512
81  end enum
82 
84  enum, bind(c)
85  enumerator :: cl_complete = 0
86  enumerator :: cl_running = 1
87  enumerator :: cl_submitted = 2
88  enumerator :: cl_queued = 3
89  end enum
90 
92  enum, bind(c)
93  enumerator :: cl_false = 0
94  enumerator :: cl_true = 1
95  end enum
96 
97  enum, bind(c)
98  enumerator :: cl_context_platform = int(z'1084')
99  end enum
100 
102  enum, bind(c)
103  enumerator :: cl_device_name = 4139
104  end enum
105 
107  integer(c_int64_t), parameter :: cl_device_type_default = 1
108  integer(c_int64_t), parameter :: cl_device_type_cpu = 2
109  integer(c_int64_t), parameter :: cl_device_type_gpu = 4
110  integer(c_int64_t), parameter :: cl_device_type_accelerator = 8
111  integer(c_int64_t), parameter :: cl_device_type_custom = 16
112  integer(c_int64_t), parameter :: cl_device_type_all = int(z'FFFFFFFF', i8)
113 
114  interface
115  integer(c_int) function clgetplatformids(num_entries, platforms, &
116  num_platforms) &
117  bind(c, name = 'clGetPlatformIDs')
118  use, intrinsic :: iso_c_binding
119  implicit none
120  integer(c_int), value :: num_entries
121  type(c_ptr), value :: platforms
122  integer(c_int) :: num_platforms
123  end function clgetplatformids
124  end interface
125 
126  interface
127  integer(c_int) function clgetdeviceids(platform, device_type, &
128  num_entries, devices, num_devices) &
129  bind(c, name = 'clGetDeviceIDs')
130  use, intrinsic :: iso_c_binding
131  implicit none
132  type(c_ptr), value :: platform
133  integer(c_int64_t), value :: device_type
134  integer(c_int), value :: num_entries
135  type(c_ptr), value :: devices
136  integer(c_int) :: num_devices
137  end function clgetdeviceids
138  end interface
139 
140  interface
141  type (c_ptr) function clcreatecontext(properties, num_devices, devices, &
142  pfn_notify, user_data, ierr) &
143  bind(c, name = 'clCreateContext')
144  use, intrinsic :: iso_c_binding
145  implicit none
146  type(c_ptr), value :: properties
147  integer(c_int), value :: num_devices
148  type(c_ptr), value :: devices
149  type(c_funptr), value :: pfn_notify
150  type(c_ptr), value :: user_data
151  integer(c_int) :: ierr
152  end function clcreatecontext
153  end interface
154 
155  interface
156  type(c_ptr) function clcreatecommandqueue(context, device, &
157  properties, ierr) &
158  bind(c, name = 'clCreateCommandQueue')
159  use, intrinsic :: iso_c_binding
160  implicit none
161  type(c_ptr), value :: context
162  type(c_ptr), value :: device
163  integer(c_int64_t), value :: properties
164  integer(c_int) :: ierr
165  end function clcreatecommandqueue
166  end interface
167 
168  interface
169  type(c_ptr) function clcreatebuffer(context, flags, size, host_ptr, ierr) &
170  bind(c, name = 'clCreateBuffer')
171  use, intrinsic :: iso_c_binding
172  implicit none
173  type(c_ptr), value :: context
174  integer(c_int), value :: flags
175  integer(c_size_t), value :: size
176  type(c_ptr), value :: host_ptr
177  integer(c_int) :: ierr
178  end function clcreatebuffer
179  end interface
180 
181  interface
182  type(c_ptr) function clcreateuserevent(context, ierr) &
183  bind(c, name = 'clCreateUserEvent')
184  use, intrinsic :: iso_c_binding
185  implicit none
186  type(c_ptr), value :: context
187  integer(c_int) :: ierr
188  end function clcreateuserevent
189  end interface
190 
191  interface
192  integer(c_int) function clenqueuereadbuffer(queue, buffer, blocking_read, &
193  offset, size, ptr, &
194  num_events_in_wait_list, &
195  event_wait_list, event) &
196  bind(c, name = 'clEnqueueReadBuffer')
197  use, intrinsic :: iso_c_binding
198  implicit none
199  type(c_ptr), value :: queue
200  type(c_ptr), value :: buffer
201  integer(c_int), value :: blocking_read
202  integer(c_size_t), value :: offset
203  integer(c_size_t), value :: size
204  type(c_ptr), value :: ptr
205  integer(c_int), value :: num_events_in_wait_list
206  type(c_ptr), value :: event_wait_list
207  type(c_ptr), value :: event
208  end function clenqueuereadbuffer
209  end interface
210 
211  interface
212  integer(c_int) function clenqueuewritebuffer(queue, buffer, &
213  blocking_write, offset, &
214  size, ptr, &
215  num_events_in_wait_list, &
216  event_wait_list, event) &
217  bind(c, name = 'clEnqueueWriteBuffer')
218  use, intrinsic :: iso_c_binding
219  implicit none
220  type(c_ptr), value :: queue
221  type(c_ptr), value :: buffer
222  integer(c_int), value :: blocking_write
223  integer(c_size_t), value :: offset
224  integer(c_size_t), value :: size
225  type(c_ptr), value :: ptr
226  integer(c_int), value :: num_events_in_wait_list
227  type(c_ptr), value :: event_wait_list
228  type(c_ptr), value :: event
229  end function clenqueuewritebuffer
230  end interface
231 
232  interface
233  integer(c_int) function clenqueuecopybuffer(queue, src_buffer, &
234  dst_buffer, src_offset, &
235  dst_offset, size, &
236  num_events_in_wait_list, &
237  event_wait_list, event) &
238  bind(c, name = 'clEnqueueCopyBuffer')
239  use, intrinsic :: iso_c_binding
240  implicit none
241  type(c_ptr), value :: queue
242  type(c_ptr), value :: src_buffer
243  type(c_ptr), value :: dst_buffer
244  integer(c_size_t), value :: src_offset
245  integer(c_size_t), value :: dst_offset
246  integer(c_size_t), value :: size
247  integer(c_int), value :: num_events_in_wait_list
248  type(c_ptr), value :: event_wait_list
249  type(c_ptr), value :: event
250  end function clenqueuecopybuffer
251  end interface
252 
253  interface
254  integer(c_int) function clenqueuemarkerwithwaitlist &
255  (queue, num_events_in_wait_list, event_wait_list, event) &
256  bind(c, name = 'clEnqueueMarkerWithWaitList')
257  use, intrinsic :: iso_c_binding
258  implicit none
259  type(c_ptr), value :: queue
260  integer(c_int), value :: num_events_in_wait_list
261  type(c_ptr), value :: event_wait_list
262  type(c_ptr), value :: event
263  end function clenqueuemarkerwithwaitlist
264  end interface
265 
266  interface
267  integer(c_int) function clenqueuemarker(cmd_queue, event) &
268  bind(c, name = 'clEnqueueMarker')
269  use, intrinsic :: iso_c_binding
270  implicit none
271  type(c_ptr), value :: cmd_queue
272  type(c_ptr), value :: event
273  end function clenqueuemarker
274  end interface
275 
276  interface
277  integer(c_int) function clenqueuebarrier(cmd_queue) &
278  bind(c, name = 'clEnqueueBarrier')
279  use, intrinsic :: iso_c_binding
280  implicit none
281  type(c_ptr), value :: cmd_queue
282  end function clenqueuebarrier
283  end interface
284 
285  interface
286  integer(c_int) function clenqueuewaitforevents(queue, &
287  num_events, event_list) &
288  bind(c, name = 'clEnqueueWaitForEvents')
289  use, intrinsic :: iso_c_binding
290  implicit none
291  type(c_ptr), value :: queue
292  integer(c_int), value :: num_events
293  type(c_ptr), value :: event_list
294  end function clenqueuewaitforevents
295  end interface
296 
297  interface
298  integer(c_int) function clwaitforevents(num_events, event_list) &
299  bind(c, name = 'clWaitForEvents')
300  use, intrinsic :: iso_c_binding
301  implicit none
302  integer(c_int), value :: num_events
303  type(c_ptr), value :: event_list
304  end function clwaitforevents
305  end interface
306 
307  interface
308  integer(c_int) function clsetusereventstatus(event, status) &
309  bind(c, name = 'clSetUserEventStatus')
310  use, intrinsic :: iso_c_binding
311  implicit none
312  type(c_ptr), value :: event
313  integer(c_int), value :: status
314  end function clsetusereventstatus
315  end interface
316 
317  interface
318  integer(c_int) function clgetdeviceinfo(device, param_name, &
319  param_value_size, param_value, &
320  param_value_size_ret) &
321  bind(c, name = 'clGetDeviceInfo')
322  use, intrinsic :: iso_c_binding
323  implicit none
324  type(c_ptr), value :: device
325  integer(c_int), value :: param_name
326  integer(c_size_t), value :: param_value_size
327  type(c_ptr), value :: param_value
328  type(c_ptr), value :: param_value_size_ret
329  end function clgetdeviceinfo
330  end interface
331 
332  interface
333  integer(c_int) function clreleasecontext(context) &
334  bind(c, name = 'clReleaseContext')
335  use, intrinsic :: iso_c_binding
336  implicit none
337  type(c_ptr), value :: context
338  end function clreleasecontext
339  end interface
340 
341  interface
342  integer(c_int) function clreleasecommandqueue(queue) &
343  bind(c, name = 'clReleaseCommandQueue')
344  use, intrinsic :: iso_c_binding
345  implicit none
346  type(c_ptr), value :: queue
347  end function clreleasecommandqueue
348  end interface
349 
350  interface
351  integer(c_int) function clreleasedevice(device) &
352  bind(c, name = 'clReleaseDevice')
353  use, intrinsic :: iso_c_binding
354  implicit none
355  type(c_ptr), value :: device
356  end function clreleasedevice
357  end interface
358 
359  interface
360  integer(c_int) function clreleaseprogram(prgm) &
361  bind(c, name = 'clReleaseProgram')
362  use, intrinsic :: iso_c_binding
363  implicit none
364  type(c_ptr), value :: prgm
365  end function clreleaseprogram
366  end interface
367 
368  interface
369  integer(c_int) function clreleasememobject(ptr_d) &
370  bind(c, name = 'clReleaseMemObject')
371  use, intrinsic :: iso_c_binding
372  implicit none
373  type(c_ptr), value :: ptr_d
374  end function clreleasememobject
375  end interface
376 
377  interface
378  integer(c_int) function clreleaseevent(event) &
379  bind(c, name = 'clReleaseEvent')
380  use, intrinsic :: iso_c_binding
381  implicit none
382  type(c_ptr), value :: event
383  end function clreleaseevent
384  end interface
385 
386  interface
387  integer(c_int) function clflush(cmd_queue) &
388  bind(c, name = 'clFlush')
389  use, intrinsic :: iso_c_binding
390  implicit none
391  type(c_ptr), value :: cmd_queue
392  end function clflush
393  end interface
394 
395  interface
396  integer(c_int) function clfinish(cmd_queue) &
397  bind(c, name = 'clFinish')
398  use, intrinsic :: iso_c_binding
399  implicit none
400  type(c_ptr), value :: cmd_queue
401  end function clfinish
402  end interface
403 
404 contains
405 
406  subroutine opencl_init
407  type(c_ptr), target :: platform_id
408  integer(c_int) :: num_platforms, num_devices, ierr
409  integer(c_intptr_t) :: ctx_prop(3)
410  integer(c_int64_t), parameter :: queue_props = 0
411  integer :: i
412 
413  if (clgetplatformids(1, c_loc(platform_id), &
414  num_platforms) .ne. cl_success) then
415  call neko_error('Failed to get a platform id')
416  end if
417 
418  if (clgetdeviceids(platform_id, cl_device_type_gpu, 1, &
419  c_loc(glb_device_id), num_devices) .ne. cl_success) then
420  call neko_error('Failed to get a device id')
421  end if
422 
423  if (c_associated(glb_ctx)) then
424  if (clreleasecontext(glb_ctx) .ne. cl_success) then
425  call neko_error('Failed to release context')
426  end if
427  end if
428 
429  glb_ctx = clcreatecontext(c_null_ptr, num_devices, c_loc(glb_device_id), &
430  c_null_funptr, c_null_ptr, ierr)
431 
432  if (ierr .ne. cl_success) then
433  call neko_error('Failed to create an OpenCL context')
434  end if
435 
436  if (c_associated(glb_cmd_queue)) then
437  if (clreleasecommandqueue(glb_cmd_queue) .ne. cl_success) then
438  call neko_error('Faield to release command queue')
439  end if
440  end if
441 
442  glb_cmd_queue = clcreatecommandqueue(glb_ctx, glb_device_id, queue_props, &
443  ierr)
444  if (ierr .ne. cl_success) then
445  call neko_error('Failed to create a command queue')
446  end if
447 
448  aux_cmd_queue = clcreatecommandqueue(glb_ctx, glb_device_id, queue_props, &
449  ierr)
450  if (ierr .ne. cl_success) then
451  call neko_error('Failed to create a command queue')
452  end if
453 
454  end subroutine opencl_init
455 
456  subroutine opencl_finalize
457 
458  if (c_associated(glb_ctx)) then
459  if (clreleasecontext(glb_ctx) .ne. cl_success) then
460  call neko_error('Failed to release context')
461  end if
462  glb_ctx = c_null_ptr
463  end if
464 
465  if (c_associated(glb_cmd_queue)) then
466  if (clreleasecommandqueue(glb_cmd_queue) .ne. cl_success) then
467  call neko_error('Faield to release command queue')
468  end if
469  glb_cmd_queue = c_null_ptr
470  end if
471 
472  if (c_associated(glb_device_id)) then
473  if (clreleasedevice(glb_device_id) .ne. cl_success) then
474  call neko_error('Faield to release device')
475  end if
476  end if
477 
478  end subroutine opencl_finalize
479 
480  subroutine opencl_device_name(name)
481  character(len=*), intent(inout) :: name
482  character(kind=c_char, len=1024), target :: c_name
483  integer(c_size_t), target :: name_len
484 
485  if (clgetdeviceinfo(glb_device_id, cl_device_name, int(1024, i8), &
486  c_loc(c_name), c_loc(name_len)) .ne. cl_success) then
487  call neko_error('Failed to query device')
488  end if
489 
490  name(1:name_len) = c_name(1:name_len)
491 
492  end subroutine opencl_device_name
493 
495  integer function opencl_device_count()
496  type(c_ptr), target :: platform_id
497  integer(c_int) :: num_platforms, num_devices
498 
499  if (clgetplatformids(1, c_loc(platform_id), &
500  num_platforms) .ne. cl_success) then
501  call neko_error('Failed to get a platform id')
502  end if
503 
504  if (clgetdeviceids(platform_id, cl_device_type_gpu, 0, &
505  c_null_ptr, num_devices) .ne. cl_success) then
506  call neko_error('Failed to get a device id')
507  end if
508 
509  opencl_device_count = num_devices
510 
511  end function opencl_device_count
512 #endif
513 
514 end module opencl_intf
Device abstraction, common interface for various accelerators.
Definition: device.F90:34
integer, parameter, public i8
Definition: num_types.f90:7
Fortran OpenCL interface.
Definition: opencl_intf.F90:34
integer(c_int64_t), parameter cl_device_type_default
Device types.
subroutine opencl_device_name(name)
integer(c_int64_t), parameter cl_device_type_gpu
type(c_ptr), bind(C) aux_cmd_queue
Aux OpenCL command queue.
Definition: opencl_intf.F90:46
integer function opencl_device_count()
Return the number of OpenCL devices.
subroutine opencl_init
@ cl_mem_host_no_access
Definition: opencl_intf.F90:80
@ cl_mem_host_write_only
Definition: opencl_intf.F90:78
@ cl_mem_alloc_host_ptr
Definition: opencl_intf.F90:77
@ cl_mem_host_read_only
Definition: opencl_intf.F90:79
subroutine opencl_finalize
integer(c_int64_t), parameter cl_device_type_cpu
@ cl_image_format_mismatch
Definition: opencl_intf.F90:65
@ cl_image_format_not_supported
Definition: opencl_intf.F90:66
@ cl_out_of_host_memory
Definition: opencl_intf.F90:62
@ cl_device_not_available
Definition: opencl_intf.F90:58
@ cl_compiler_not_available
Definition: opencl_intf.F90:59
@ cl_mem_object_allocation_failure
Definition: opencl_intf.F90:60
@ cl_build_program_failure
Definition: opencl_intf.F90:67
@ cl_profiling_info_not_available
Definition: opencl_intf.F90:63
integer(c_int64_t), parameter cl_device_type_custom
integer(c_int64_t), parameter cl_device_type_all
integer(c_int64_t), parameter cl_device_type_accelerator
Utilities.
Definition: utils.f90:35