libgomp/testsuite/libgomp.fortran/allocate-1.f90

   1 ! { dg-do run }
   2 ! { dg-additional-sources allocate-1.c }
   3 ! { dg-additional-options -Wno-complain-wrong-lang }
   4
   5 module m
   6   use omp_lib
   7   use iso_c_binding
   8   implicit none (type, external)
   9
  10   interface
  11     integer(c_int) function is_64bit_aligned (a) bind(C)
  12       import :: c_int
  13       type(*)  :: a
  14     end
  15   end interface
  16
  17 contains
  18
  19 subroutine foo (x, p, q, h, fl)
  20   use omp_lib
  21   use iso_c_binding
  22   integer  :: x
  23   integer, dimension(4) :: p
  24   integer, dimension(4) :: q
  25   integer (kind=omp_allocator_handle_kind) :: h
  26   integer  :: fl
  27
  28   integer  :: y
  29   integer  :: r, i, i1, i2, i3, i4, i5
  30   integer  :: l, l3, l4, l5, l6
  31   integer  :: n, n2, n3, n4
  32   integer  :: j2, j3, j4
  33   integer, dimension(4) :: l2
  34   integer, dimension(4) :: r2
  35   integer, target  :: xo
  36   integer, target  :: yo
  37   integer, dimension(x) :: v
  38   integer, dimension(x) :: w
  39
  40   type s_type
  41     integer      :: a
  42     integer      :: b
  43   end type
  44
  45   type (s_type) :: s
  46   s%a = 27
  47   s%b = 29
  48   y = 0
  49   r = 0
  50   n = 8
  51   n2 = 9
  52   n3 = 10
  53   n4 = 11
  54   xo = x
  55   yo = y
  56
  57   do i = 1, 4
  58     r2(i) = 0;
  59   end do
  60
  61   do i = 1, 4
  62     p(i) = 0;
  63   end do
  64
  65   do i = 1, 4
  66     q(i) = 0;
  67   end do
  68
  69   do i = 1, x
  70     w(i) = i
  71   end do
  72
  73   !$omp parallel private (y, v) firstprivate (x) allocate (x, y, v)
  74   if (x /= 42) then
  75     stop 1
  76   end if
  77
  78   !$omp barrier
  79   y = 1;
  80   x = x + 1
  81   v(1) = 7
  82   v(42) = 8
  83   !$omp barrier
  84   if (x /= 43 .or. y /= 1) then
  85     stop 3
  86   end if
  87   if (v(1) /= 7 .or. v(42) /= 8) then
  88     stop 4
  89   end if
  90   if ( (and(fl, 2) /= 0) .and.        &
  91      ((is_64bit_aligned(x) == 0) .or. &
  92       (is_64bit_aligned(y) == 0) .or. &
  93       (is_64bit_aligned(v(1)) == 0))) then
  94     stop 2
  95   end if
  96   !$omp end parallel
  97   !$omp teams
  98   !$omp parallel private (y) firstprivate (x, w) allocate (h: x, y, w)
  99
 100   if (x /= 42 .or. w(17) /= 17 .or. w(42) /= 42) then
 101     stop 5
 102   end if
 103   !$omp barrier
 104   y = 1;
 105   x = x + 1
 106   w(19) = w(19) + 1
 107   !$omp barrier
 108   if (x /= 43 .or. y /= 1 .or. w(19) /= 20) then
 109     stop 6
 110   end if
 111   if ( (and(fl, 1) /= 0) .and.          &
 112        ((is_64bit_aligned(x) == 0) .or. &
 113         (is_64bit_aligned(y) == 0) .or. &
 114         (is_64bit_aligned(w(1)) == 0))) then
 115     stop 7
 116   end if
 117   !$omp end parallel
 118   !$omp end teams
 119
 120   !$omp parallel do private (y) firstprivate (x)  reduction(+: r) allocate (h: x, y, r, l, n) lastprivate (l)  linear (n: 16)
 121   do i = 0, 63
 122     if (x /= 42) then
 123       stop 8
 124     end if
 125     y = 1;
 126     l = i;
 127     n = n + y + 15;
 128     r = r + i;
 129     if ( (and(fl, 1) /= 0) .and.          &
 130          ((is_64bit_aligned(x) == 0) .or. &
 131           (is_64bit_aligned(y) == 0) .or. &
 132           (is_64bit_aligned(r) == 0) .or. &
 133           (is_64bit_aligned(l) == 0) .or. &
 134           (is_64bit_aligned(n) == 0))) then
 135       stop 9
 136     end if
 137   end do
 138   !$omp end parallel do
 139
 140   !$omp parallel
 141     !$omp do lastprivate (l2) private (i1) allocate (h: l2, l3, i1) lastprivate (conditional: l3)
 142     do i1 = 0, 63
 143       l2(1) = i1
 144       l2(2) = i1 + 1
 145       l2(3) = i1 + 2
 146       l2(4) = i1 + 3
 147       if (i1 < 37) then
 148         l3 = i1
 149       end if
 150       if ( (and(fl, 1) /= 0) .and.          &
 151            ((is_64bit_aligned(l2(1)) == 0) .or. &
 152             (is_64bit_aligned(l3) == 0) .or. &
 153             (is_64bit_aligned(i1) == 0))) then
 154         stop 10
 155       end if
 156     end do
 157
 158     !$omp do collapse(2) lastprivate(l4, i2, j2) linear (n2:17) allocate (h: n2, l4, i2, j2)
 159     do i2 = 3, 4
 160       do j2 = 17, 22, 2
 161         n2 = n2 + 17
 162         l4 = i2 * 31 + j2
 163         if ( (and(fl, 1) /= 0) .and.          &
 164              ((is_64bit_aligned(l4) == 0) .or. &
 165               (is_64bit_aligned(n2) == 0) .or. &
 166               (is_64bit_aligned(i2) == 0) .or. &
 167               (is_64bit_aligned(j2) == 0))) then
 168           stop 11
 169         end if
 170       end do
 171     end do
 172
 173     !$omp do collapse(2) lastprivate(l5, i3, j3) linear (n3:17) schedule (static, 3) allocate (n3, l5, i3, j3)
 174     do i3 = 3, 4
 175       do j3 = 17, 22, 2
 176           n3 = n3 + 17
 177           l5 = i3 * 31 + j3
 178           if ( (and(fl, 2) /= 0) .and.      &
 179              ((is_64bit_aligned(l5) == 0) .or. &
 180               (is_64bit_aligned(n3) == 0) .or. &
 181               (is_64bit_aligned(i3) == 0) .or. &
 182               (is_64bit_aligned(j3) == 0))) then
 183           stop 12
 184         end if
 185       end do
 186     end do
 187
 188     !$omp do collapse(2) lastprivate(l6, i4, j4) linear (n4:17) schedule (dynamic) allocate (h: n4, l6, i4, j4)
 189     do i4 = 3, 4
 190       do j4 = 17, 22,2
 191           n4 = n4 + 17;
 192           l6 = i4 * 31 + j4;
 193         if ( (and(fl, 1) /= 0) .and.          &
 194             ((is_64bit_aligned(l6) == 0) .or. &
 195              (is_64bit_aligned(n4) == 0) .or. &
 196              (is_64bit_aligned(i4) == 0) .or. &
 197              (is_64bit_aligned(j4) == 0))) then
 198           stop 13
 199         end if
 200       end do
 201     end do
 202
 203     !$omp do lastprivate (i5) allocate (i5)
 204     do i5 = 1, 17, 3
 205       if ( (and(fl, 2) /= 0) .and.          &
 206            (is_64bit_aligned(i5) == 0)) then
 207         stop 14
 208       end if
 209     end do
 210
 211     !$omp do reduction(+:p, q, r2) allocate(h: p, q, r2)
 212     do i = 0, 31
 213         p(3) = p(3) +  i;
 214         p(4) = p(4) + (2 * i)
 215         q(1) = q(1) + (3 * i)
 216         q(3) = q(3) + (4 * i)
 217         r2(1) = r2(1) + (5 * i)
 218         r2(4) = r2(4) + (6 * i)
 219         if ( (and(fl, 1) /= 0) .and.             &
 220              ((is_64bit_aligned(q(1)) == 0) .or. &
 221               (is_64bit_aligned(p(1)) == 0) .or. &
 222               (is_64bit_aligned(r2(1)) == 0) )) then
 223           stop 15
 224         end if
 225     end do
 226
 227     !$omp task private(y) firstprivate(x) allocate(x, y)
 228     if (x /= 42) then
 229       stop 16
 230     end if
 231
 232     if ( (and(fl, 2) /= 0) .and.          &
 233       ((is_64bit_aligned(x) == 0) .or. &
 234       (is_64bit_aligned(y) == 0) )) then
 235       stop 17
 236     end if
 237     !$omp end task
 238
 239     !$omp task private(y) firstprivate(x) allocate(h: x, y)
 240     if (x /= 42) then
 241       stop 16
 242     end if
 243
 244     if ( (and(fl, 1) /= 0) .and.          &
 245       ((is_64bit_aligned(x) == 0) .or. &
 246       (is_64bit_aligned(y) == 0) )) then
 247       stop 17
 248     end if
 249     !$omp end task
 250
 251     !$omp task private(y) firstprivate(s) allocate(s, y)
 252     if (s%a /= 27 .or. s%b /= 29) then
 253       stop 18
 254     end if
 255
 256     if ( (and(fl, 2) /= 0) .and.          &
 257       ((is_64bit_aligned(s%a) == 0) .or. &
 258       (is_64bit_aligned(y) == 0) )) then
 259       stop 19
 260     end if
 261     !$omp end task
 262
 263     !$omp task private(y) firstprivate(s) allocate(h: s, y)
 264     if (s%a /= 27 .or. s%b /= 29) then
 265       stop 18
 266     end if
 267
 268     if ( (and(fl, 1) /= 0) .and.          &
 269       ((is_64bit_aligned(s%a) == 0) .or. &
 270       (is_64bit_aligned(y) == 0) )) then
 271       stop 19
 272     end if
 273     !$omp end task
 274
 275   !$omp end parallel
 276
 277   if (r /= ((64 * 63) / 2) .or. l /= 63 .or. n /= (8 + 16 * 64)) then
 278     stop 20
 279   end if
 280
 281   if (l2(1) /= 63 .or. l2(2) /= 64 .or. l2(3) /= 65 .or. l2(4) /= 66 .or. l3 /= 36) then
 282     stop 21
 283   end if
 284
 285   if (i2 /= 5 .or. j2 /= 23 .or. n2 /= (9 + (17 * 6)) .or. l4 /= (4 * 31 + 21)) then
 286     stop 22
 287   end if
 288
 289   if (i3 /= 5 .or. j3 /= 23 .or. n3 /= (10 + (17 * 6))  .or. l5 /= (4 * 31 + 21)) then
 290     stop 23
 291   end if
 292
 293   if (i4 /= 5 .or. j4 /= 23 .or. n4 /= (11 + (17 * 6))  .or. l6 /= (4 * 31 + 21)) then
 294     stop 24
 295   end if
 296
 297   if (i5 /= 19) then
 298     stop 24
 299   end if
 300
 301   if (p(3) /= ((32 * 31) / 2) .or. p(4) /= (2 * p(3))         &
 302       .or. q(1) /= (3 * p(3)) .or. q(3) /= (4 * p(3))         &
 303       .or. r2(1) /= (5 * p(3)) .or. r2(4) /= (6 * p(3))) then
 304     stop 25
 305   end if
 306 end subroutine
 307 end module m
 308
 309 program main
 310   use omp_lib
 311   use m
 312   implicit none (type, external)
 313   integer, dimension(4) :: p
 314   integer, dimension(4) :: q
 315
 316   type (omp_alloctrait) :: traits(2)
 317   integer (omp_allocator_handle_kind) :: a
 318
 319   traits = [omp_alloctrait (omp_atk_alignment, 64), &
 320             omp_alloctrait (omp_atk_fallback, omp_atv_null_fb)]
 321   a = omp_init_allocator (omp_default_mem_space, 2, traits)
 322   if (a == omp_null_allocator) stop 1
 323
 324   call omp_set_default_allocator (omp_default_mem_alloc);
 325   call foo (42, p, q, a, 0);
 326   call foo (42, p, q, omp_default_mem_alloc, 0);
 327   call foo (42, p, q, a, 1);
 328   call omp_set_default_allocator (a);
 329   call foo (42, p, q, omp_null_allocator, 3);
 330   call foo (42, p, q, omp_default_mem_alloc, 2);
 331   call omp_destroy_allocator (a);
 332 end