1program main
2  use omp_lib
3  use iso_c_binding
4  implicit none (external, type)
5  integer :: d, id, i, j, k, l
6  logical :: err
7  integer, target :: q(0:127)
8  type(c_ptr) :: p
9
10  integer(kind=c_size_t) :: volume(0:2)
11  integer(kind=c_size_t) :: dst_offsets(0:2)
12  integer(kind=c_size_t) :: src_offsets(0:2)
13  integer(kind=c_size_t) :: dst_dimensions(0:2)
14  integer(kind=c_size_t) :: src_dimensions(0:2)
15  integer(kind=c_size_t) :: empty(1:0)
16
17  err = .false.
18  d = omp_get_default_device ()
19  id = omp_get_initial_device ()
20
21  if (d < 0 .or. d >= omp_get_num_devices ()) &
22    d = id
23
24  q = [(i, i = 0, 127)]
25  p = omp_target_alloc (130 * c_sizeof (q), d)
26  if (.not. c_associated (p)) &
27    stop 0  ! okay
28
29  if (omp_target_memcpy_rect (C_NULL_PTR, C_NULL_PTR, 0_c_size_t, 0, &
30                              empty, empty, empty, empty,  empty, d, id) < 3 &
31      .or. omp_target_memcpy_rect (C_NULL_PTR, C_NULL_PTR, 0_c_size_t, 0, &
32                                   empty, empty, empty, empty, empty, &
33                                   id, d) < 3 &
34      .or. omp_target_memcpy_rect (C_NULL_PTR, C_NULL_PTR, 0_c_size_t, 0, &
35                                   empty, empty, empty, empty, empty, &
36                                   id, id) < 3) &
37    stop 1
38
39  if (omp_target_associate_ptr (c_loc (q), p, 128 * c_sizeof (q(0)), &
40                                c_sizeof (q(0)), d) == 0) then
41    volume = [ 128, 0, 0 ]
42    dst_offsets = [ 0, 0, 0 ]
43    src_offsets = [ 1, 0, 0 ]
44    dst_dimensions = [ 128, 0, 0 ]
45    src_dimensions = [ 128, 0, 0 ]
46
47
48    if (omp_target_associate_ptr (c_loc (q), p, 128 * sizeof (q(0)), &
49                                  sizeof (q(0)), d) /= 0) &
50      stop 2
51
52    if (omp_target_is_present (c_loc (q), d) /= 1 &
53        .or. omp_target_is_present (c_loc (q(32)), d) /= 1 &
54        .or. omp_target_is_present (c_loc (q(127)), d) /= 1) &
55      stop 3
56
57    if (omp_target_memcpy (p, c_loc (q), 128 * sizeof (q(0)), sizeof (q(0)), &
58                           0_c_size_t, d, id) /= 0) &
59      stop 4
60
61    i = 0
62    if (d >= 0) i = d
63    !$omp target if (d >= 0) device (i) map(alloc:q(0:31)) map(from:err)
64      err = .false.
65      do j = 0, 127
66        if (q(j) /= j) then
67          err = .true.
68        else
69          q(j) = q(j) + 4
70        end if
71      end do
72    !$omp end target
73
74    if (err) &
75      stop 5
76
77    if (omp_target_memcpy_rect (c_loc (q), p, sizeof (q(0)), 1, volume, &
78                                dst_offsets, src_offsets, dst_dimensions, &
79                                src_dimensions, id, d) /= 0) &
80      stop 6
81
82    do i = 0, 127
83      if (q(i) /= i + 4) &
84        stop 7
85    end do
86
87    volume(2) = 2
88    volume(1) = 3
89    volume(0) = 6
90    dst_offsets(2) = 1
91    dst_offsets(1) = 0
92    dst_offsets(0) = 0
93    src_offsets(2) = 1
94    src_offsets(1) = 0
95    src_offsets(0) = 3
96    dst_dimensions(2) = 2
97    dst_dimensions(1) = 3
98    dst_dimensions(0) = 6
99    src_dimensions(2) = 3
100    src_dimensions(1) = 4
101    src_dimensions(0) = 6
102
103    if (omp_target_memcpy_rect (p, c_loc (q), sizeof (q(0)), 3, volume, &
104                                dst_offsets, src_offsets, dst_dimensions, &
105                                src_dimensions, d, id) /= 0) &
106      stop 8
107
108    i = 0
109    if (d >= 0) i = d
110    !$omp target if (d >= 0) device (i) map(alloc:q(1:32)) map(from:err)
111      err = .false.
112      do j = 0, 5
113        do k = 0, 2
114          do l = 0, 1
115            if (q(j * 6 + k * 2 + l) /= 3 * 12 + 4 + 1 + l + k * 3 + j * 12) &
116              err = .true.
117          end do
118        end do
119      end do
120    !$omp end target
121
122    if (err) &
123      stop 9
124
125    if (omp_target_memcpy (p, p, 10 * sizeof (q(1)), 51 * sizeof (q(1)), &
126                           111 * sizeof (q(1)), d, d) /= 0) &
127      stop 10
128
129    i = 0
130    if (d >= 0) i = d
131    !$omp target if (d >= 0) device (i) map(alloc:q(0:31)) map(from:err)
132      err = .false.
133      do j = 1, 9
134        if (q(50+j) /= q(110 + j)) &
135          err = .true.
136      end do
137    !$omp end target
138
139    if (err) &
140      stop 11
141
142    if (omp_target_disassociate_ptr (c_loc (q), d) /= 0) &
143      stop 12
144  end if
145
146  call omp_target_free (p, d)
147end program main
148