libgomp/testsuite/libgomp.fortran/alloc-4.f90

   1 program 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)
  55 end program main