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