libgomp/testsuite/libgomp.fortran/target-12.f90

   1 program 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) = 3
  97     dst_dimensions(1) = 3
  98     dst_dimensions(0) = 6
  99     src_dimensions(2) = 3
 100     src_dimensions(1) = 4
 101     src_dimensions(0) = 9
 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 * 9 + k * 3 + 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)
 147 end program main