1program main
2  use omp_lib
3  use ISO_C_Binding
4  implicit none (external, type)
5
6  interface
7    ! omp_alloc + omp_free part of OpenMP for C/C++
8    ! but not (yet) in the OpenMP spec for Fortran
9    type(c_ptr) function omp_alloc (size, handle) bind(C)
10      import
11      integer (c_size_t), value :: size
12      integer (omp_allocator_handle_kind), value :: handle
13    end function
14
15    subroutine omp_free (ptr, handle) bind(C)
16      import
17      type (c_ptr), value :: ptr
18      integer (omp_allocator_handle_kind), value :: handle
19    end subroutine
20  end interface
21
22  type (omp_alloctrait) :: traits(3)
23  integer (omp_allocator_handle_kind) :: a
24
25  traits = [omp_alloctrait (omp_atk_alignment, 64), &
26            omp_alloctrait (omp_atk_fallback, omp_atv_null_fb), &
27            omp_alloctrait (omp_atk_pool_size, 4096)]
28  a = omp_init_allocator (omp_default_mem_space, 3, traits)
29  if (a == omp_null_allocator) stop 1
30
31  !$omp parallel num_threads(4)
32  block
33    integer :: n
34    real(8) :: r
35    type(c_ptr) :: cp, cq
36    real(8), pointer, volatile :: p(:), q(:)
37
38    n = omp_get_thread_num ()
39    if (mod (n, 2) /= 0) then
40      call omp_set_default_allocator (a)
41    else
42      call omp_set_default_allocator (omp_default_mem_alloc)
43    endif
44    cp = omp_alloc (1696_c_size_t, omp_null_allocator)
45    if (.not. c_associated (cp)) stop 2
46    call c_f_pointer (cp, p, [1696 / c_sizeof (r)])
47    p(1) = 1.0
48    p(1696 / c_sizeof (r)) = 2.0
49    !$omp barrier
50    if (mod (n, 2) /= 0) then
51      call omp_set_default_allocator (omp_default_mem_alloc)
52    else
53      call omp_set_default_allocator (a)
54    endif
55    cq = omp_alloc (1696_c_size_t, omp_null_allocator)
56    if (mod (n, 2) /= 0) then
57      if (.not. c_associated (cq)) stop 3
58      call c_f_pointer (cq, q, [1696 / c_sizeof (r)])
59      q(1) = 3.0
60      q(1696 / c_sizeof (r)) = 4.0
61    else if (c_associated (cq)) then
62      stop 4
63    end if
64    !$omp barrier
65    call omp_free (cp, omp_null_allocator)
66    call omp_free (cq, omp_null_allocator)
67    call omp_set_default_allocator (omp_default_mem_alloc)
68  end block
69  !$omp end parallel
70  call omp_destroy_allocator (a)
71end program main
72