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