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