libgomp/testsuite/libgomp.oacc-fortran/declare-5.f90

   1 ! { dg-do run }
   2 ! { dg-xfail-run-if "PR92790 - acc declare device_resident - Fortran common blocks not handled" { *-*-* } { "*" } { "-DACC_DEVICE_TYPE_host=1" } }
   3
   4 module vars
   5   implicit none
   6   real b
   7   !$acc declare device_resident (b)
   8
   9   integer :: x, y, z
  10   common /block/ x, y, z
  11   !$acc declare device_resident (/block/)
  12 end module vars
  13
  14 subroutine set()
  15   use openacc
  16   implicit none
  17   integer :: a(5), b(1), c, vals(7)
  18   common /another/ a, b, c
  19   !$acc declare device_resident (/another/)
  20   if (.not. acc_is_present (a)) stop 10
  21   if (.not. acc_is_present (b)) stop 11
  22   if (.not. acc_is_present (c)) stop 12
  23
  24   vals = 99
  25   ! NOTE: The current (Nov 2019) implementation requires the 'present'
  26   ! as it tries to otherwises map the device_resident variables;
  27   ! following OpenMP 4.0 semantic: 'a' + 'b' are 'copy' (map fromto) and
  28   ! 'c' is firstprivate.
  29   !$acc parallel copyout(vals) present(a, b, c)
  30     a = [11,12,13,14,15]
  31     b = 16
  32     c = 47
  33     vals(1:5) = a
  34     vals(6:6) = b
  35     vals(7) = c
  36   !$acc end parallel
  37
  38   if (.not. acc_is_present (a)) stop 13
  39   if (.not. acc_is_present (b)) stop 14
  40   if (.not. acc_is_present (c)) stop 15
  41
  42   if (any (vals /= [11,12,13,14,15,16,47])) stop 16
  43 end subroutine set
  44
  45 subroutine check()
  46   use openacc
  47   implicit none
  48   integer :: g, h(3), i(3)
  49   common /another/ g, h, i
  50   integer :: val(7)
  51   !$acc declare device_resident (/another/)
  52   if (.not. acc_is_present (g)) stop 20
  53   if (.not. acc_is_present (h)) stop 21
  54   if (.not. acc_is_present (i)) stop 22
  55
  56   val = 99
  57   !$acc parallel copyout(val) present(g, h, i)
  58     val(5:7) = i
  59     val(1) = g
  60     val(2:4) = h
  61   !$acc end parallel
  62
  63   if (.not. acc_is_present (g)) stop 23
  64   if (.not. acc_is_present (h)) stop 24
  65   if (.not. acc_is_present (i)) stop 25
  66
  67
  68   !print *, val
  69   if (any (val /= [11,12,13,14,15,16,47])) stop 26
  70 end subroutine check
  71
  72
  73 program test
  74   use vars
  75   use openacc
  76   implicit none
  77   real a
  78   integer :: k
  79
  80   call set()
  81   call check()
  82
  83   if (.not. acc_is_present (b)) stop 1
  84   if (.not. acc_is_present (x)) stop 2
  85   if (.not. acc_is_present (y)) stop 3
  86   if (.not. acc_is_present (z)) stop 4
  87
  88   a = 2.0
  89   k = 42
  90
  91   !$acc parallel copy (a, k)
  92     b = a
  93     a = 1.0
  94     a = a + b
  95     x = k
  96     y = 7*k - 2*x
  97     z = 3*y
  98     k = k - z + y
  99    !$acc end parallel
 100
 101   if (.not. acc_is_present (b)) stop 5
 102   if (.not. acc_is_present (x)) stop 6
 103   if (.not. acc_is_present (y)) stop 7
 104   if (.not. acc_is_present (z)) stop 8
 105
 106   if (a /= 3.0) stop 30
 107   if (k /= -378) stop 31
 108 end program test