1program main
2  use omp_lib
3  use ISO_C_Binding
4  implicit none (external, type)
5
6  type (omp_alloctrait) :: traits(3)
7  integer (omp_allocator_handle_kind) :: a
8
9  traits = [omp_alloctrait (omp_atk_alignment, 64), &
10            omp_alloctrait (omp_atk_fallback, omp_atv_null_fb), &
11            omp_alloctrait (omp_atk_pool_size, 4096)]
12  a = omp_init_allocator (omp_default_mem_space, 3, traits)
13  if (a == omp_null_allocator) stop 1
14
15  !$omp parallel num_threads(4)
16  block
17    integer :: n
18    real(8) :: r
19    type(c_ptr) :: cp, cq
20    real(8), pointer, volatile :: p(:), q(:)
21
22    n = omp_get_thread_num ()
23    if (mod (n, 2) /= 0) then
24      call omp_set_default_allocator (a)
25    else
26      call omp_set_default_allocator (omp_default_mem_alloc)
27    endif
28    cp = omp_alloc (1696_c_size_t, omp_null_allocator)
29    if (.not. c_associated (cp)) stop 2
30    call c_f_pointer (cp, p, [1696 / c_sizeof (r)])
31    p(1) = 1.0
32    p(1696 / c_sizeof (r)) = 2.0
33    !$omp barrier
34    if (mod (n, 2) /= 0) then
35      call omp_set_default_allocator (omp_default_mem_alloc)
36    else
37      call omp_set_default_allocator (a)
38    endif
39    cq = omp_alloc (1696_c_size_t, omp_null_allocator)
40    if (mod (n, 2) /= 0) then
41      if (.not. c_associated (cq)) stop 3
42      call c_f_pointer (cq, q, [1696 / c_sizeof (r)])
43      q(1) = 3.0
44      q(1696 / c_sizeof (r)) = 4.0
45    else if (c_associated (cq)) then
46      stop 4
47    end if
48    !$omp barrier
49    call omp_free (cp, omp_null_allocator)
50    call omp_free (cq, omp_null_allocator)
51    call omp_set_default_allocator (omp_default_mem_alloc)
52  end block
53  !$omp end parallel
54  call omp_destroy_allocator (a)
55end program main
56