libgomp/testsuite/libgomp.fortran/use_device_addr-2.f90

   1 ! { dg-do run }
   2 ! Comprehensive run-time test for use_device_addr
   3 !
   4 ! Differs from use_device_addr-1.f90 by using a 4-byte variable (c_float)
   5 !
   6 ! This test case assumes that a 'var' appearing in 'use_device_addr' is
   7 ! only used as 'c_loc(var)' - such that only the actual data is used/usable
   8 ! on the device - and not meta data ((dynamic) type information, 'present()'
   9 ! status, array shape).
  10 !
  11 ! Untested in this test case are:
  12 ! - arrays with array descriptor
  13 ! - polymorphic variables
  14 ! - absent optional arguments
  15 !
  16 module target_procs
  17   use iso_c_binding
  18   implicit none (type, external)
  19   private
  20   public :: copy3_array, copy3_scalar
  21 contains
  22   subroutine copy3_array_int(from_ptr, to_ptr, N)
  23     !$omp declare target
  24     real(c_float) :: from_ptr(:)
  25     real(c_float) :: to_ptr(:)
  26     integer, value :: N
  27     integer :: i
  28
  29     !$omp parallel do
  30     do i = 1, N
  31       to_ptr(i) = 3 * from_ptr(i)
  32     end do
  33     !$omp end parallel do
  34   end subroutine copy3_array_int
  35
  36   subroutine copy3_scalar_int(from, to)
  37     !$omp declare target
  38     real(c_float) :: from, to
  39
  40     to = 3 * from
  41   end subroutine copy3_scalar_int
  42
  43
  44   subroutine copy3_array(from, to, N)
  45     type(c_ptr), value :: from, to
  46     integer, value :: N
  47     real(c_float), pointer :: from_ptr(:), to_ptr(:)
  48
  49     call c_f_pointer(from, from_ptr, shape=[N])
  50     call c_f_pointer(to, to_ptr, shape=[N])
  51
  52     call do_offload_scalar(from_ptr,to_ptr)
  53   contains
  54     subroutine do_offload_scalar(from_r, to_r)
  55       real(c_float), target :: from_r(:), to_r(:)
  56       ! The extra function is needed as is_device_ptr
  57       ! requires non-value, non-pointer dummy arguments
  58
  59       !$omp target is_device_ptr(from_r, to_r)
  60       call copy3_array_int(from_r, to_r, N)
  61       !$omp end target
  62     end subroutine do_offload_scalar
  63   end subroutine copy3_array
  64
  65   subroutine copy3_scalar(from, to)
  66     type(c_ptr), value, target :: from, to
  67     real(c_float), pointer :: from_ptr(:), to_ptr(:)
  68
  69     ! Standard-conform detour of using an array as at time of writing
  70     ! is_device_ptr below does not handle scalars
  71     call c_f_pointer(from, from_ptr, shape=[1])
  72     call c_f_pointer(to, to_ptr, shape=[1])
  73
  74     call do_offload_scalar(from_ptr,to_ptr)
  75   contains
  76     subroutine do_offload_scalar(from_r, to_r)
  77       real(c_float), target :: from_r(:), to_r(:)
  78       ! The extra function is needed as is_device_ptr
  79       ! requires non-value, non-pointer dummy arguments
  80
  81       !$omp target is_device_ptr(from_r, to_r)
  82       call copy3_scalar_int(from_r(1), to_r(1))
  83       !$omp end target
  84     end subroutine do_offload_scalar
  85   end subroutine copy3_scalar
  86 end module target_procs
  87
  88
  89
  90 ! Test local dummy arguments (w/o optional)
  91 module test_dummies
  92   use iso_c_binding
  93   use target_procs
  94   implicit none (type, external)
  95   private
  96   public :: test_dummy_call_1, test_dummy_call_2
  97 contains
  98   subroutine test_dummy_call_1()
  99      integer, parameter :: N = 1000
 100
 101      ! scalars
 102      real(c_float), target :: aa, bb
 103      real(c_float), target, allocatable :: cc, dd
 104      real(c_float), pointer :: ee, ff
 105
 106      ! non-descriptor arrays
 107      real(c_float), target :: gg(N), hh(N)
 108
 109      allocate(cc, dd, ee, ff)
 110
 111      aa = 11.0_c_float
 112      bb = 22.0_c_float
 113      cc = 33.0_c_float
 114      dd = 44.0_c_float
 115      ee = 55.0_c_float
 116      ff = 66.0_c_float
 117      gg = 77.0_c_float
 118      hh = 88.0_c_float
 119
 120      call test_dummy_callee_1(aa, bb, cc, dd, ee, ff, gg, hh, N)
 121      deallocate(ee, ff) ! pointers, only
 122   end subroutine test_dummy_call_1
 123
 124   subroutine test_dummy_callee_1(aa, bb, cc, dd, ee, ff, gg, hh, N)
 125      ! scalars
 126      real(c_float), target :: aa, bb
 127      real(c_float), target, allocatable :: cc, dd
 128      real(c_float), pointer :: ee, ff
 129
 130      ! non-descriptor arrays
 131      real(c_float), target :: gg(N), hh(N)
 132      integer, value :: N
 133
 134      !$omp target data map(to:aa) map(from:bb) use_device_addr(aa,bb)
 135      call copy3_scalar(c_loc(aa), c_loc(bb))
 136      !$omp end target data
 137      if (abs(aa - 11.0_c_float) > 10.0_c_float * epsilon(aa)) stop 1
 138      if (abs(3.0_c_float * aa - bb) > 10.0_c_float * epsilon(aa)) stop 2
 139
 140      !$omp target data map(to:cc) map(from:dd) use_device_addr(cc,dd)
 141      call copy3_scalar(c_loc(cc), c_loc(dd))
 142      !$omp end target data
 143      if (abs(cc - 33.0_c_float) > 10.0_c_float * epsilon(cc)) stop 3
 144      if (abs(3.0_c_float * cc - dd) > 10.0_c_float * epsilon(cc)) stop 4
 145
 146      !$omp target data map(to:ee) map(from:ff) use_device_addr(ee,ff)
 147      call copy3_scalar(c_loc(ee), c_loc(ff))
 148      !$omp end target data
 149      if (abs(ee - 55.0_c_float) > 10.0_c_float * epsilon(ee)) stop 5
 150      if (abs(3.0_c_float * ee - ff) > 10.0_c_float * epsilon(ee)) stop 6
 151
 152
 153      !$omp target data map(to:gg) map(from:hh) use_device_addr(gg,hh)
 154      call copy3_array(c_loc(gg), c_loc(hh), N)
 155      !$omp end target data
 156      if (any(abs(gg - 77.0_c_float) > 10.0_c_float * epsilon(gg))) stop 7
 157      if (any(abs(3.0_c_float * gg - hh) > 10.0_c_float * epsilon(gg))) stop 8
 158   end subroutine test_dummy_callee_1
 159
 160   ! Save device ptr - and recall pointer
 161   subroutine test_dummy_call_2()
 162      integer, parameter :: N = 1000
 163
 164      ! scalars
 165      real(c_float), target :: aa, bb
 166      real(c_float), target, allocatable :: cc, dd
 167      real(c_float), pointer :: ee, ff
 168
 169      ! non-descriptor arrays
 170      real(c_float), target :: gg(N), hh(N)
 171
 172      type(c_ptr) :: c_aptr, c_bptr, c_cptr, c_dptr, c_eptr, c_fptr, c_gptr, c_hptr
 173      real(c_float), pointer :: aptr, bptr, cptr, dptr, eptr, fptr
 174      real(c_float), pointer :: gptr(:), hptr(:)
 175
 176      allocate(cc, dd, ee, ff)
 177      call test_dummy_callee_2(aa, bb, cc, dd, ee, ff, gg, hh, &
 178                                c_aptr, c_bptr, c_cptr, c_dptr, c_eptr, c_fptr, c_gptr, c_hptr, &
 179                                aptr, bptr, cptr, dptr, eptr, fptr, gptr, hptr, &
 180                                N)
 181      deallocate(ee, ff)
 182   end subroutine test_dummy_call_2
 183
 184   subroutine test_dummy_callee_2(aa, bb, cc, dd, ee, ff, gg, hh, &
 185                                   c_aptr, c_bptr, c_cptr, c_dptr, c_eptr, c_fptr, c_gptr, c_hptr, &
 186                                   aptr, bptr, cptr, dptr, eptr, fptr, gptr, hptr, &
 187                                   N)
 188      ! scalars
 189      real(c_float), target :: aa, bb
 190      real(c_float), target, allocatable :: cc, dd
 191      real(c_float), pointer :: ee, ff
 192
 193      ! non-descriptor arrays
 194      real(c_float), target :: gg(N), hh(N)
 195
 196      type(c_ptr) :: c_aptr, c_bptr, c_cptr, c_dptr, c_eptr, c_fptr, c_gptr, c_hptr
 197      real(c_float), pointer :: aptr, bptr, cptr, dptr, eptr, fptr
 198      real(c_float), pointer :: gptr(:), hptr(:)
 199
 200      integer, value :: N
 201
 202      real(c_float) :: dummy
 203
 204      aa = 111.0_c_float
 205      bb = 222.0_c_float
 206      cc = 333.0_c_float
 207      dd = 444.0_c_float
 208      ee = 555.0_c_float
 209      ff = 666.0_c_float
 210      gg = 777.0_c_float
 211      hh = 888.0_c_float
 212
 213      !$omp target data map(to:aa) map(from:bb)
 214      !$omp target data map(alloc:dummy) use_device_addr(aa,bb)
 215      c_aptr = c_loc(aa)
 216      c_bptr = c_loc(bb)
 217      aptr => aa
 218      bptr => bb
 219      !$omp end target data
 220
 221      ! check c_loc ptr once
 222      call copy3_scalar(c_aptr, c_bptr)
 223      !$omp target update from(bb)
 224      if (abs(aa - 111.0_c_float) > 10.0_c_float * epsilon(aa)) stop 9
 225      if (abs(3.0_c_float * aa - bb) > 10.0_c_float * epsilon(aa)) stop 10
 226
 227      ! check c_loc ptr again after target-value modification
 228      aa = 1111.0_c_float
 229      !$omp target update to(aa)
 230      call copy3_scalar(c_aptr, c_bptr)
 231      !$omp target update from(bb)
 232      if (abs(aa - 1111.0_c_float) > 10.0_c_float * epsilon(aa)) stop 11
 233      if (abs(3.0_c_float * aa - bb) > 10.0_c_float * epsilon(aa)) stop 12
 234
 235      ! check Fortran pointer after target-value modification
 236      aa = 11111.0_c_float
 237      !$omp target update to(aa)
 238      call copy3_scalar(c_loc(aptr), c_loc(bptr))
 239      !$omp target update from(bb)
 240      if (abs(aa - 11111.0_c_float) > 10.0_c_float * epsilon(aa)) stop 13
 241      if (abs(3.0_c_float * aa - bb) > 10.0_c_float * epsilon(aa)) stop 14
 242      !$omp end target data
 243
 244      if (abs(aa - 11111.0_c_float) > 10.0_c_float * epsilon(aa)) stop 15
 245      if (abs(3.0_c_float * aa - bb) > 10.0_c_float * epsilon(aa)) stop 16
 246
 247
 248      !$omp target data map(to:cc) map(from:dd)
 249      !$omp target data map(alloc:dummy) use_device_addr(cc,dd)
 250      c_cptr = c_loc(cc)
 251      c_dptr = c_loc(dd)
 252      cptr => cc
 253      dptr => dd
 254      !$omp end target data
 255
 256      ! check c_loc ptr once
 257      call copy3_scalar(c_cptr, c_dptr)
 258      !$omp target update from(dd)
 259      if (abs(cc - 333.0_c_float) > 10.0_c_float * epsilon(cc)) stop 17
 260      if (abs(3.0_c_float * cc - dd) > 10.0_c_float * epsilon(cc)) stop 18
 261
 262      ! check c_loc ptr again after target-value modification
 263      cc = 3333.0_c_float
 264      !$omp target update to(cc)
 265      call copy3_scalar(c_cptr, c_dptr)
 266      !$omp target update from(dd)
 267      if (abs(cc - 3333.0_c_float) > 10.0_c_float * epsilon(cc)) stop 19
 268      if (abs(3.0_c_float * cc - dd) > 10.0_c_float * epsilon(cc)) stop 20
 269
 270      ! check Fortran pointer after target-value modification
 271      cc = 33333.0_c_float
 272      !$omp target update to(cc)
 273      call copy3_scalar(c_loc(cptr), c_loc(dptr))
 274      !$omp target update from(dd)
 275      if (abs(cc - 33333.0_c_float) > 10.0_c_float * epsilon(cc)) stop 21
 276      if (abs(3.0_c_float * cc - dd) > 10.0_c_float * epsilon(cc)) stop 22
 277      !$omp end target data
 278
 279      if (abs(cc - 33333.0_c_float) > 10.0_c_float * epsilon(dd)) stop 23
 280      if (abs(3.0_c_float * cc - dd) > 10.0_c_float * epsilon(dd)) stop 24
 281
 282
 283      !$omp target data map(to:ee) map(from:ff)
 284      !$omp target data map(alloc:dummy) use_device_addr(ee,ff)
 285      c_eptr = c_loc(ee)
 286      c_fptr = c_loc(ff)
 287      eptr => ee
 288      fptr => ff
 289      !$omp end target data
 290
 291      ! check c_loc ptr once
 292      call copy3_scalar(c_eptr, c_fptr)
 293      !$omp target update from(ff)
 294      if (abs(ee - 555.0_c_float) > 10.0_c_float * epsilon(ee)) stop 25
 295      if (abs(3.0_c_float * ee - ff) > 10.0_c_float * epsilon(ee)) stop 26
 296
 297      ! check c_loc ptr again after target-value modification
 298      ee = 5555.0_c_float
 299      !$omp target update to(ee)
 300      call copy3_scalar(c_eptr, c_fptr)
 301      !$omp target update from(ff)
 302      if (abs(ee - 5555.0_c_float) > 10.0_c_float * epsilon(ee)) stop 27
 303      if (abs(3.0_c_float * ee - ff) > 10.0_c_float * epsilon(ee)) stop 28
 304
 305      ! check Fortran pointer after target-value modification
 306      ee = 55555.0_c_float
 307      !$omp target update to(ee)
 308      call copy3_scalar(c_loc(eptr), c_loc(fptr))
 309      !$omp target update from(ff)
 310      if (abs(ee - 55555.0_c_float) > 10.0_c_float * epsilon(ee)) stop 29
 311      if (abs(3.0_c_float * ee - ff) > 10.0_c_float * epsilon(ff)) stop 30
 312      !$omp end target data
 313
 314      if (abs(ee - 55555.0_c_float) > 10.0_c_float * epsilon(ee)) stop 31
 315      if (abs(3.0_c_float * ee - ff) > 10.0_c_float * epsilon(ee)) stop 32
 316
 317
 318      !$omp target data map(to:gg) map(from:hh)
 319      !$omp target data map(alloc:dummy) use_device_addr(gg,hh)
 320      c_gptr = c_loc(gg)
 321      c_hptr = c_loc(hh)
 322      gptr => gg
 323      hptr => hh
 324      !$omp end target data
 325
 326      ! check c_loc ptr once
 327      call copy3_array(c_gptr, c_hptr, N)
 328      !$omp target update from(hh)
 329      if (any(abs(gg - 777.0_c_float) > 10.0_c_float * epsilon(gg))) stop 33
 330      if (any(abs(3.0_c_float * gg - hh) > 10.0_c_float * epsilon(hh))) stop 34
 331
 332      ! check c_loc ptr again after target-value modification
 333      gg = 7777.0_c_float
 334      !$omp target update to(gg)
 335      call copy3_array(c_gptr, c_hptr, N)
 336      !$omp target update from(hh)
 337      if (any(abs(gg - 7777.0_c_float) > 10.0_c_float * epsilon(gg))) stop 35
 338      if (any(abs(3.0_c_float * gg - hh) > 10.0_c_float * epsilon(gg))) stop 36
 339
 340      ! check Fortran pointer after target-value modification
 341      gg = 77777.0_c_float
 342      !$omp target update to(gg)
 343      call copy3_array(c_loc(gptr), c_loc(hptr), N)
 344      !$omp target update from(hh)
 345      if (any(abs(gg - 77777.0_c_float) > 10.0_c_float * epsilon(gg))) stop 37
 346      if (any(abs(3.0_c_float * gg - hh) > 10.0_c_float * epsilon(gg))) stop 38
 347      !$omp end target data
 348
 349      if (any(abs(gg - 77777.0_c_float) > 10.0_c_float * epsilon(gg))) stop 39
 350      if (any(abs(3.0_c_float * gg - hh) > 10.0_c_float * epsilon(gg))) stop 40
 351   end subroutine test_dummy_callee_2
 352 end module test_dummies
 353
 354
 355
 356 ! Test local dummy arguments + VALUE (w/o optional)
 357 module test_dummies_value
 358   use iso_c_binding
 359   use target_procs
 360   implicit none (type, external)
 361   private
 362   public :: test_dummy_val_call_1, test_dummy_val_call_2
 363 contains
 364   subroutine test_dummy_val_call_1()
 365      ! scalars - with value, neither allocatable nor pointer no dimension permitted
 366      real(c_float), target :: aa, bb
 367
 368      aa = 11.0_c_float
 369      bb = 22.0_c_float
 370
 371      call test_dummy_val_callee_1(aa, bb)
 372   end subroutine test_dummy_val_call_1
 373
 374   subroutine test_dummy_val_callee_1(aa, bb)
 375      ! scalars
 376      real(c_float), value, target :: aa, bb
 377
 378      !$omp target data map(to:aa) map(from:bb) use_device_addr(aa,bb)
 379      call copy3_scalar(c_loc(aa), c_loc(bb))
 380      !$omp end target data
 381      if (abs(aa - 11.0_c_float) > 10.0_c_float * epsilon(aa)) stop 41
 382      if (abs(3.0_c_float * aa - bb) > 10.0_c_float * epsilon(aa)) stop 42
 383   end subroutine test_dummy_val_callee_1
 384
 385   ! Save device ptr - and recall pointer
 386   subroutine test_dummy_val_call_2()
 387      ! scalars - with value, neither allocatable nor pointer no dimension permitted
 388      real(c_float), target :: aa, bb
 389      type(c_ptr) :: c_aptr, c_bptr
 390      real(c_float), pointer :: aptr, bptr
 391
 392      call test_dummy_val_callee_2(aa, bb, c_aptr, c_bptr, aptr, bptr)
 393   end subroutine test_dummy_val_call_2
 394
 395   subroutine test_dummy_val_callee_2(aa, bb, c_aptr, c_bptr, aptr, bptr)
 396      real(c_float), value, target :: aa, bb
 397      type(c_ptr), value :: c_aptr, c_bptr
 398      real(c_float), pointer :: aptr, bptr
 399
 400      real(c_float) :: dummy
 401
 402      aa = 111.0_c_float
 403      bb = 222.0_c_float
 404
 405      !$omp target data map(to:aa) map(from:bb)
 406      !$omp target data map(alloc:dummy) use_device_addr(aa,bb)
 407      c_aptr = c_loc(aa)
 408      c_bptr = c_loc(bb)
 409      aptr => aa
 410      bptr => bb
 411      !$omp end target data
 412
 413      ! check c_loc ptr once
 414      call copy3_scalar(c_aptr, c_bptr)
 415      !$omp target update from(bb)
 416      if (abs(aa - 111.0_c_float) > 10.0_c_float * epsilon(aa)) stop 43
 417      if (abs(3.0_c_float * aa - bb) > 10.0_c_float * epsilon(aa)) stop 44
 418
 419      ! check c_loc ptr again after target-value modification
 420      aa = 1111.0_c_float
 421      !$omp target update to(aa)
 422      call copy3_scalar(c_aptr, c_bptr)
 423      !$omp target update from(bb)
 424      if (abs(aa - 1111.0_c_float) > 10.0_c_float * epsilon(aa)) stop 45
 425      if (abs(3.0_c_float * aa - bb) > 10.0_c_float * epsilon(aa)) stop 46
 426
 427      ! check Fortran pointer after target-value modification
 428      aa = 11111.0_c_float
 429      !$omp target update to(aa)
 430      call copy3_scalar(c_loc(aptr), c_loc(bptr))
 431      !$omp target update from(bb)
 432      if (abs(aa - 11111.0_c_float) > 10.0_c_float * epsilon(aa)) stop 47
 433      if (abs(3.0_c_float * aa - bb) > 10.0_c_float * epsilon(aa)) stop 48
 434      !$omp end target data
 435
 436      if (abs(aa - 11111.0_c_float) > 10.0_c_float * epsilon(aa)) stop 49
 437      if (abs(3.0_c_float * aa - bb) > 10.0_c_float * epsilon(aa)) stop 50
 438   end subroutine test_dummy_val_callee_2
 439 end module test_dummies_value
 440
 441
 442
 443 ! Test local dummy arguments + OPTIONAL
 444 ! Values present and ptr associated to nonzero
 445 module test_dummies_opt
 446   use iso_c_binding
 447   use target_procs
 448   implicit none (type, external)
 449   private
 450   public :: test_dummy_opt_call_1, test_dummy_opt_call_2
 451 contains
 452   subroutine test_dummy_opt_call_1()
 453      integer, parameter :: N = 1000
 454
 455      ! scalars
 456      real(c_float), target :: aa, bb
 457      real(c_float), target, allocatable :: cc, dd
 458      real(c_float), pointer :: ee, ff
 459
 460      ! non-descriptor arrays
 461      real(c_float), target :: gg(N), hh(N)
 462
 463      allocate(cc, dd, ee, ff)
 464
 465      aa = 11.0_c_float
 466      bb = 22.0_c_float
 467      cc = 33.0_c_float
 468      dd = 44.0_c_float
 469      ee = 55.0_c_float
 470      ff = 66.0_c_float
 471      gg = 77.0_c_float
 472      hh = 88.0_c_float
 473
 474      call test_dummy_opt_callee_1(aa, bb, cc, dd, ee, ff, gg, hh, N)
 475      call test_dummy_opt_callee_1_absent(N=N)
 476      deallocate(ee, ff) ! pointers, only
 477   end subroutine test_dummy_opt_call_1
 478
 479   subroutine test_dummy_opt_callee_1(aa, bb, cc, dd, ee, ff, gg, hh, N)
 480      ! scalars
 481      real(c_float), optional, target :: aa, bb
 482      real(c_float), optional, target, allocatable :: cc, dd
 483      real(c_float), optional, pointer :: ee, ff
 484
 485      ! non-descriptor arrays
 486      real(c_float), optional, target :: gg(N), hh(N)
 487      integer, value :: N
 488
 489      ! All shall be present - and pointing to non-NULL
 490      if (.not.present(aa) .or. .not.present(bb)) stop 51
 491      if (.not.present(cc) .or. .not.present(dd)) stop 52
 492      if (.not.present(ee) .or. .not.present(ff)) stop 53
 493      if (.not.present(gg) .or. .not.present(hh)) stop 54
 494
 495      if (.not.associated(ee) .or. .not.associated(ff)) stop 55
 496
 497      !$omp target data map(to:aa) map(from:bb) use_device_addr(aa,bb)
 498      if (.not.present(aa) .or. .not.present(bb)) stop 56
 499      if (.not.c_associated(c_loc(aa)) .or. .not.c_associated(c_loc(bb))) stop 57
 500      call copy3_scalar(c_loc(aa), c_loc(bb))
 501      !$omp end target data
 502      if (abs(aa - 11.0_c_float) > 10.0_c_float * epsilon(aa)) stop 58
 503      if (abs(3.0_c_float * aa - bb) > 10.0_c_float * epsilon(aa)) stop 59
 504
 505      !$omp target data map(to:cc) map(from:dd) use_device_addr(cc,dd)
 506      if (.not.present(cc) .or. .not.present(dd)) stop 60
 507      if (.not.c_associated(c_loc(cc)) .or. .not.c_associated(c_loc(dd))) stop 61
 508      call copy3_scalar(c_loc(cc), c_loc(dd))
 509      !$omp end target data
 510      if (abs(cc - 33.0_c_float) > 10.0_c_float * epsilon(cc)) stop 62
 511      if (abs(3.0_c_float * cc - dd) > 10.0_c_float * epsilon(cc)) stop 63
 512
 513      !$omp target data map(to:ee) map(from:ff) use_device_addr(ee,ff)
 514      if (.not.present(ee) .or. .not.present(ff)) stop 64
 515      if (.not.associated(ee) .or. .not.associated(ff)) stop 65
 516      if (.not.c_associated(c_loc(ee)) .or. .not.c_associated(c_loc(ff))) stop 66
 517      call copy3_scalar(c_loc(ee), c_loc(ff))
 518      !$omp end target data
 519      if (abs(ee - 55.0_c_float) > 10.0_c_float * epsilon(ee)) stop 67
 520      if (abs(3.0_c_float * ee - ff) > 10.0_c_float * epsilon(ee)) stop 68
 521
 522      !$omp target data map(to:gg) map(from:hh) use_device_addr(gg,hh)
 523      if (.not.present(gg) .or. .not.present(hh)) stop 69
 524      if (.not.c_associated(c_loc(gg)) .or. .not.c_associated(c_loc(hh))) stop 70
 525      call copy3_array(c_loc(gg), c_loc(hh), N)
 526      !$omp end target data
 527      if (any(abs(gg - 77.0_c_float) > 10.0_c_float * epsilon(gg))) stop 71
 528      if (any(abs(3.0_c_float * gg - hh) > 10.0_c_float * epsilon(gg))) stop 72
 529   end subroutine test_dummy_opt_callee_1
 530
 531   subroutine test_dummy_opt_callee_1_absent(aa, bb, cc, dd, ee, ff, gg, hh, N)
 532      ! scalars
 533      real(c_float), optional, target :: aa, bb
 534      real(c_float), optional, target, allocatable :: cc, dd
 535      real(c_float), optional, pointer :: ee, ff
 536
 537      ! non-descriptor arrays
 538      real(c_float), optional, target :: gg(N), hh(N)
 539      integer, value :: N
 540
 541      integer :: err
 542
 543      ! All shall be absent
 544      if (present(aa) .or. present(bb)) stop 243
 545      if (present(cc) .or. present(dd)) stop 244
 546      if (present(ee) .or. present(ff)) stop 245
 547      if (present(gg) .or. present(hh)) stop 246
 548
 549      !$omp target data map(to:aa) map(from:bb) use_device_addr(aa,bb)
 550      if (present(aa) .or. present(bb)) stop 247
 551      !$omp end target data
 552
 553      !$omp target data map(to:cc) map(from:dd) use_device_addr(cc,dd)
 554      if (present(cc) .or. present(dd)) stop 248
 555      !$omp end target data
 556
 557      !$omp target data map(to:ee) map(from:ff) use_device_addr(ee,ff)
 558      if (present(ee) .or. present(ff)) stop 249
 559      !$omp end target data
 560
 561      !$omp target data map(to:gg) map(from:hh) use_device_addr(gg,hh)
 562      if (present(gg) .or. present(hh)) stop 250
 563      !$omp end target data
 564   end subroutine test_dummy_opt_callee_1_absent
 565
 566   ! Save device ptr - and recall pointer
 567   subroutine test_dummy_opt_call_2()
 568      integer, parameter :: N = 1000
 569
 570      ! scalars
 571      real(c_float), target :: aa, bb
 572      real(c_float), target, allocatable :: cc, dd
 573      real(c_float), pointer :: ee, ff
 574
 575      ! non-descriptor arrays
 576      real(c_float), target :: gg(N), hh(N)
 577
 578      type(c_ptr) :: c_aptr, c_bptr, c_cptr, c_dptr, c_eptr, c_fptr, c_gptr, c_hptr
 579      real(c_float), pointer :: aptr, bptr, cptr, dptr, eptr, fptr
 580      real(c_float), pointer :: gptr(:), hptr(:)
 581
 582      allocate(cc, dd, ee, ff)
 583      call test_dummy_opt_callee_2(aa, bb, cc, dd, ee, ff, gg, hh, &
 584                                    c_aptr, c_bptr, c_cptr, c_dptr, c_eptr, c_fptr, c_gptr, c_hptr, &
 585                                    aptr, bptr, cptr, dptr, eptr, fptr, gptr, hptr, &
 586                                    N)
 587      deallocate(ee, ff)
 588   end subroutine test_dummy_opt_call_2
 589
 590   subroutine test_dummy_opt_callee_2(aa, bb, cc, dd, ee, ff, gg, hh, &
 591                                       c_aptr, c_bptr, c_cptr, c_dptr, c_eptr, c_fptr, c_gptr, c_hptr, &
 592                                       aptr, bptr, cptr, dptr, eptr, fptr, gptr, hptr, &
 593                                       N)
 594      ! scalars
 595      real(c_float), optional, target :: aa, bb
 596      real(c_float), optional, target, allocatable :: cc, dd
 597      real(c_float), optional, pointer :: ee, ff
 598
 599      ! non-descriptor arrays
 600      real(c_float), optional, target :: gg(N), hh(N)
 601
 602      type(c_ptr) :: c_aptr, c_bptr, c_cptr, c_dptr, c_eptr, c_fptr, c_gptr, c_hptr
 603      real(c_float), optional, pointer :: aptr, bptr, cptr, dptr, eptr, fptr
 604      real(c_float), optional, pointer :: gptr(:), hptr(:)
 605
 606      integer, value :: N
 607
 608      real(c_float) :: dummy
 609
 610      ! All shall be present - and pointing to non-NULL
 611      if (.not.present(aa) .or. .not.present(bb)) stop 73
 612      if (.not.present(cc) .or. .not.present(dd)) stop 74
 613      if (.not.present(ee) .or. .not.present(ff)) stop 75
 614      if (.not.present(gg) .or. .not.present(hh)) stop 76
 615
 616      if (.not.associated(ee) .or. .not.associated(ff)) stop 77
 617
 618      aa = 111.0_c_float
 619      bb = 222.0_c_float
 620      cc = 333.0_c_float
 621      dd = 444.0_c_float
 622      ee = 555.0_c_float
 623      ff = 666.0_c_float
 624      gg = 777.0_c_float
 625      hh = 888.0_c_float
 626
 627      !$omp target data map(to:aa) map(from:bb)
 628      !$omp target data map(alloc:dummy) use_device_addr(aa,bb)
 629      if (.not.present(aa) .or. .not.present(bb)) stop 78
 630      if (.not.c_associated(c_loc(aa)) .or. .not.c_associated(c_loc(bb))) stop 79
 631      c_aptr = c_loc(aa)
 632      c_bptr = c_loc(bb)
 633      aptr => aa
 634      bptr => bb
 635      if (.not.c_associated(c_aptr) .or. .not.c_associated(c_bptr)) stop 80
 636      if (.not.associated(aptr) .or. .not.associated(bptr)) stop 81
 637      !$omp end target data
 638
 639      if (.not.present(aa) .or. .not.present(bb)) stop 82
 640      if (.not.c_associated(c_loc(aa)) .or. .not.c_associated(c_loc(bb))) stop 83
 641      if (.not.c_associated(c_aptr) .or. .not.c_associated(c_bptr)) stop 84
 642      if (.not.associated(aptr) .or. .not.associated(bptr)) stop 85
 643
 644      ! check c_loc ptr once
 645      call copy3_scalar(c_aptr, c_bptr)
 646      !$omp target update from(bb)
 647      if (abs(aa - 111.0_c_float) > 10.0_c_float * epsilon(aa)) stop 86
 648      if (abs(3.0_c_float * aa - bb) > 10.0_c_float * epsilon(aa)) stop 87
 649
 650      ! check c_loc ptr again after target-value modification
 651      aa = 1111.0_c_float
 652      !$omp target update to(aa)
 653      call copy3_scalar(c_aptr, c_bptr)
 654      !$omp target update from(bb)
 655      if (abs(aa - 1111.0_c_float) > 10.0_c_float * epsilon(aa)) stop 88
 656      if (abs(3.0_c_float * aa - bb) > 10.0_c_float * epsilon(aa)) stop 89
 657
 658      ! check Fortran pointer after target-value modification
 659      aa = 11111.0_c_float
 660      !$omp target update to(aa)
 661      call copy3_scalar(c_loc(aptr), c_loc(bptr))
 662      !$omp target update from(bb)
 663      if (abs(aa - 11111.0_c_float) > 10.0_c_float * epsilon(aa)) stop 90
 664      if (abs(3.0_c_float * aa - bb) > 10.0_c_float * epsilon(aa)) stop 91
 665      !$omp end target data
 666
 667      if (abs(aa - 11111.0_c_float) > 10.0_c_float * epsilon(aa)) stop 92
 668      if (abs(3.0_c_float * aa - bb) > 10.0_c_float * epsilon(aa)) stop 93
 669
 670
 671      !$omp target data map(to:cc) map(from:dd)
 672      !$omp target data map(alloc:dummy) use_device_addr(cc,dd)
 673      if (.not.present(cc) .or. .not.present(dd)) stop 94
 674      if (.not.c_associated(c_loc(cc)) .or. .not.c_associated(c_loc(dd))) stop 95
 675      c_cptr = c_loc(cc)
 676      c_dptr = c_loc(dd)
 677      cptr => cc
 678      dptr => dd
 679      if (.not.c_associated(c_cptr) .or. .not.c_associated(c_dptr)) stop 96
 680      if (.not.associated(cptr) .or. .not.associated(dptr)) stop 97
 681      !$omp end target data
 682      if (.not.present(cc) .or. .not.present(dd)) stop 98
 683      if (.not.c_associated(c_loc(cc)) .or. .not.c_associated(c_loc(dd))) stop 99
 684      if (.not.c_associated(c_cptr) .or. .not.c_associated(c_dptr)) stop 100
 685      if (.not.associated(cptr) .or. .not.associated(dptr)) stop 101
 686
 687      ! check c_loc ptr once
 688      call copy3_scalar(c_cptr, c_dptr)
 689      !$omp target update from(dd)
 690      if (abs(cc - 333.0_c_float) > 10.0_c_float * epsilon(cc)) stop 102
 691      if (abs(3.0_c_float * cc - dd) > 10.0_c_float * epsilon(cc)) stop 103
 692
 693      ! check c_loc ptr again after target-value modification
 694      cc = 3333.0_c_float
 695      !$omp target update to(cc)
 696      call copy3_scalar(c_cptr, c_dptr)
 697      !$omp target update from(dd)
 698      if (abs(cc - 3333.0_c_float) > 10.0_c_float * epsilon(cc)) stop 104
 699      if (abs(3.0_c_float * cc - dd) > 10.0_c_float * epsilon(cc)) stop 105
 700
 701      ! check Fortran pointer after target-value modification
 702      cc = 33333.0_c_float
 703      !$omp target update to(cc)
 704      call copy3_scalar(c_loc(cptr), c_loc(dptr))
 705      !$omp target update from(dd)
 706      if (abs(cc - 33333.0_c_float) > 10.0_c_float * epsilon(cc)) stop 106
 707      if (abs(3.0_c_float * cc - dd) > 10.0_c_float * epsilon(cc)) stop 107
 708      !$omp end target data
 709
 710      if (abs(cc - 33333.0_c_float) > 10.0_c_float * epsilon(dd)) stop 108
 711      if (abs(3.0_c_float * cc - dd) > 10.0_c_float * epsilon(dd)) stop 109
 712
 713
 714      !$omp target data map(to:ee) map(from:ff)
 715      !$omp target data map(alloc:dummy) use_device_addr(ee,ff)
 716      if (.not.present(ee) .or. .not.present(ff)) stop 110
 717      if (.not.associated(ee) .or. .not.associated(ff)) stop 111
 718      if (.not.c_associated(c_loc(ee)) .or. .not.c_associated(c_loc(ff))) stop 112
 719      c_eptr = c_loc(ee)
 720      c_fptr = c_loc(ff)
 721      eptr => ee
 722      fptr => ff
 723      if (.not.c_associated(c_eptr) .or. .not.c_associated(c_fptr)) stop 113
 724      if (.not.associated(eptr) .or. .not.associated(fptr)) stop 114
 725      !$omp end target data
 726      if (.not.present(ee) .or. .not.present(ff)) stop 115
 727      if (.not.associated(ee) .or. .not.associated(ff)) stop 116
 728      if (.not.c_associated(c_loc(ee)) .or. .not.c_associated(c_loc(ff))) stop 117
 729      if (.not.c_associated(c_eptr) .or. .not.c_associated(c_fptr)) stop 118
 730      if (.not.associated(eptr) .or. .not.associated(fptr)) stop 119
 731
 732      ! check c_loc ptr once
 733      call copy3_scalar(c_eptr, c_fptr)
 734      !$omp target update from(ff)
 735      if (abs(ee - 555.0_c_float) > 10.0_c_float * epsilon(ee)) stop 120
 736      if (abs(3.0_c_float * ee - ff) > 10.0_c_float * epsilon(ee)) stop 121
 737
 738      ! check c_loc ptr again after target-value modification
 739      ee = 5555.0_c_float
 740      !$omp target update to(ee)
 741      call copy3_scalar(c_eptr, c_fptr)
 742      !$omp target update from(ff)
 743      if (abs(ee - 5555.0_c_float) > 10.0_c_float * epsilon(ee)) stop 122
 744      if (abs(3.0_c_float * ee - ff) > 10.0_c_float * epsilon(ee)) stop 123
 745
 746      ! check Fortran pointer after target-value modification
 747      ee = 55555.0_c_float
 748      !$omp target update to(ee)
 749      call copy3_scalar(c_loc(eptr), c_loc(fptr))
 750      !$omp target update from(ff)
 751      if (abs(ee - 55555.0_c_float) > 10.0_c_float * epsilon(ee)) stop 124
 752      if (abs(3.0_c_float * ee - ff) > 10.0_c_float * epsilon(ff)) stop 125
 753      !$omp end target data
 754
 755      if (abs(ee - 55555.0_c_float) > 10.0_c_float * epsilon(ee)) stop 126
 756      if (abs(3.0_c_float * ee - ff) > 10.0_c_float * epsilon(ee)) stop 127
 757
 758
 759      !$omp target data map(to:gg) map(from:hh)
 760      !$omp target data map(alloc:dummy) use_device_addr(gg,hh)
 761      if (.not.present(gg) .or. .not.present(hh)) stop 128
 762      if (.not.c_associated(c_loc(gg)) .or. .not.c_associated(c_loc(hh))) stop 129
 763      c_gptr = c_loc(gg)
 764      c_hptr = c_loc(hh)
 765      gptr => gg
 766      hptr => hh
 767      if (.not.c_associated(c_gptr) .or. .not.c_associated(c_hptr)) stop 130
 768      if (.not.associated(gptr) .or. .not.associated(hptr)) stop 131
 769      !$omp end target data
 770      if (.not.present(gg) .or. .not.present(hh)) stop 132
 771      if (.not.c_associated(c_loc(gg)) .or. .not.c_associated(c_loc(hh))) stop 133
 772      if (.not.c_associated(c_gptr) .or. .not.c_associated(c_hptr)) stop 134
 773      if (.not.associated(gptr) .or. .not.associated(hptr)) stop 135
 774
 775      ! check c_loc ptr once
 776      call copy3_array(c_gptr, c_hptr, N)
 777      !$omp target update from(hh)
 778      if (any(abs(gg - 777.0_c_float) > 10.0_c_float * epsilon(gg))) stop 136
 779      if (any(abs(3.0_c_float * gg - hh) > 10.0_c_float * epsilon(hh))) stop 137
 780
 781      ! check c_loc ptr again after target-value modification
 782      gg = 7777.0_c_float
 783      !$omp target update to(gg)
 784      call copy3_array(c_gptr, c_hptr, N)
 785      !$omp target update from(hh)
 786      if (any(abs(gg - 7777.0_c_float) > 10.0_c_float * epsilon(gg))) stop 138
 787      if (any(abs(3.0_c_float * gg - hh) > 10.0_c_float * epsilon(gg))) stop 139
 788
 789      ! check Fortran pointer after target-value modification
 790      gg = 77777.0_c_float
 791      !$omp target update to(gg)
 792      call copy3_array(c_loc(gptr), c_loc(hptr), N)
 793      !$omp target update from(hh)
 794      if (any(abs(gg - 77777.0_c_float) > 10.0_c_float * epsilon(gg))) stop 140
 795      if (any(abs(3.0_c_float * gg - hh) > 10.0_c_float * epsilon(gg))) stop 141
 796      !$omp end target data
 797
 798      if (any(abs(gg - 77777.0_c_float) > 10.0_c_float * epsilon(gg))) stop 142
 799      if (any(abs(3.0_c_float * gg - hh) > 10.0_c_float * epsilon(gg))) stop 143
 800   end subroutine test_dummy_opt_callee_2
 801 end module test_dummies_opt
 802
 803
 804
 805 ! Test local dummy arguments + OPTIONAL + VALUE
 806 ! Values present
 807 module test_dummies_opt_value
 808   use iso_c_binding
 809   use target_procs
 810   implicit none (type, external)
 811   private
 812   public :: test_dummy_opt_val_call_1, test_dummy_opt_val_call_2
 813 contains
 814   subroutine test_dummy_opt_val_call_1()
 815      ! scalars - with value, neither allocatable nor pointer no dimension permitted
 816      real(c_float), target :: aa, bb
 817
 818      aa = 11.0_c_float
 819      bb = 22.0_c_float
 820
 821      call test_dummy_opt_val_callee_1(aa, bb)
 822   end subroutine test_dummy_opt_val_call_1
 823
 824   subroutine test_dummy_opt_val_callee_1(aa, bb)
 825      ! scalars
 826      real(c_float), optional, value, target :: aa, bb
 827
 828      if (.not.present(aa) .or. .not.present(bb)) stop 144
 829
 830      !$omp target data map(to:aa) map(from:bb) use_device_addr(aa,bb)
 831      if (.not.present(aa) .or. .not.present(bb)) stop 145
 832      if (.not.c_associated(c_loc(aa)) .or. .not.c_associated(c_loc(bb))) stop 146
 833      call copy3_scalar(c_loc(aa), c_loc(bb))
 834      !$omp end target data
 835      if (abs(aa - 11.0_c_float) > 10.0_c_float * epsilon(aa)) stop 147
 836      if (abs(3.0_c_float * aa - bb) > 10.0_c_float * epsilon(aa)) stop 148
 837   end subroutine test_dummy_opt_val_callee_1
 838
 839   ! Save device ptr - and recall pointer
 840   subroutine test_dummy_opt_val_call_2()
 841      ! scalars - with value, neither allocatable nor pointer no dimension permitted
 842      real(c_float), target :: aa, bb
 843      type(c_ptr) :: c_aptr, c_bptr
 844      real(c_float), pointer :: aptr, bptr
 845
 846      call test_dummy_opt_val_callee_2(aa, bb, c_aptr, c_bptr, aptr, bptr)
 847   end subroutine test_dummy_opt_val_call_2
 848
 849   subroutine test_dummy_opt_val_callee_2(aa, bb, c_aptr, c_bptr, aptr, bptr)
 850      real(c_float), optional, value, target :: aa, bb
 851      type(c_ptr), optional, value :: c_aptr, c_bptr
 852      real(c_float), optional, pointer :: aptr, bptr
 853
 854      real(c_float) :: dummy
 855
 856      if (.not.present(aa) .or. .not.present(bb)) stop 149
 857      if (.not.present(c_aptr) .or. .not.present(c_bptr)) stop 150
 858      if (.not.present(aptr) .or. .not.present(bptr)) stop 151
 859
 860      aa = 111.0_c_float
 861      bb = 222.0_c_float
 862
 863      !$omp target data map(to:aa) map(from:bb)
 864      if (.not.present(aa) .or. .not.present(bb)) stop 152
 865      if (.not.present(c_aptr) .or. .not.present(c_bptr)) stop 153
 866      if (.not.present(aptr) .or. .not.present(bptr)) stop 154
 867
 868      !$omp target data map(alloc:dummy) use_device_addr(aa,bb)
 869      if (.not.present(aa) .or. .not.present(bb)) stop 155
 870      if (.not.present(c_aptr) .or. .not.present(c_bptr)) stop 156
 871      if (.not.present(aptr) .or. .not.present(bptr)) stop 157
 872
 873      c_aptr = c_loc(aa)
 874      c_bptr = c_loc(bb)
 875      aptr => aa
 876      bptr => bb
 877      if (.not.c_associated(c_aptr) .or. .not.c_associated(c_bptr)) stop 158
 878      if (.not.associated(aptr) .or. .not.associated(bptr)) stop 159
 879      !$omp end target data
 880
 881      ! check c_loc ptr once
 882      call copy3_scalar(c_aptr, c_bptr)
 883      !$omp target update from(bb)
 884      if (abs(aa - 111.0_c_float) > 10.0_c_float * epsilon(aa)) stop 160
 885      if (abs(3.0_c_float * aa - bb) > 10.0_c_float * epsilon(aa)) stop 161
 886
 887      ! check c_loc ptr again after target-value modification
 888      aa = 1111.0_c_float
 889      !$omp target update to(aa)
 890      call copy3_scalar(c_aptr, c_bptr)
 891      !$omp target update from(bb)
 892      if (abs(aa - 1111.0_c_float) > 10.0_c_float * epsilon(aa)) stop 162
 893      if (abs(3.0_c_float * aa - bb) > 10.0_c_float * epsilon(aa)) stop 163
 894
 895      ! check Fortran pointer after target-value modification
 896      aa = 11111.0_c_float
 897      !$omp target update to(aa)
 898      call copy3_scalar(c_loc(aptr), c_loc(bptr))
 899      !$omp target update from(bb)
 900      if (abs(aa - 11111.0_c_float) > 10.0_c_float * epsilon(aa)) stop 164
 901      if (abs(3.0_c_float * aa - bb) > 10.0_c_float * epsilon(aa)) stop 165
 902      !$omp end target data
 903
 904      if (abs(aa - 11111.0_c_float) > 10.0_c_float * epsilon(aa)) stop 166
 905      if (abs(3.0_c_float * aa - bb) > 10.0_c_float * epsilon(aa)) stop 167
 906   end subroutine test_dummy_opt_val_callee_2
 907 end module test_dummies_opt_value
 908
 909
 910
 911 ! Test nullptr
 912 module test_nullptr
 913   use iso_c_binding
 914   implicit none (type, external)
 915   private
 916   public :: test_nullptr_1
 917 contains
 918   subroutine test_nullptr_1()
 919      ! scalars
 920      real(c_float), pointer :: aa, bb
 921      real(c_float), pointer :: ee, ff
 922
 923      real(c_float), allocatable, target :: gg, hh
 924
 925      type(c_ptr) :: c_aptr, c_bptr, c_eptr, c_fptr, c_gptr, c_hptr
 926      real(c_float), pointer :: aptr, bptr, eptr, fptr, gptr, hptr
 927
 928      aa => null()
 929      bb => null()
 930      ee => null()
 931      ff => null()
 932
 933      if (associated(aa) .or. associated(bb)) stop 168
 934      !$omp target data map(to:aa) map(from:bb) use_device_addr(aa,bb)
 935      if (c_associated(c_loc(aa)) .or. c_associated(c_loc(bb))) stop 169
 936      c_aptr = c_loc(aa)
 937      c_bptr = c_loc(bb)
 938      aptr => aa
 939      bptr => bb
 940      if (c_associated(c_aptr) .or. c_associated(c_bptr)) stop 170
 941      if (associated(aptr) .or. associated(bptr, bb)) stop 171
 942      !$omp end target data
 943      if (c_associated(c_aptr) .or. c_associated(c_bptr)) stop 172
 944      if (associated(aptr) .or. associated(bptr, bb)) stop 173
 945
 946      if (allocated(gg)) stop 174
 947      !$omp target data map(tofrom:gg) use_device_addr(gg)
 948      if (c_associated(c_loc(gg))) stop 175
 949      c_gptr = c_loc(gg)
 950      gptr => gg
 951      if (c_associated(c_gptr)) stop 176
 952      if (associated(gptr)) stop 177
 953      if (allocated(gg)) stop 178
 954      !$omp end target data
 955      if (c_associated(c_gptr)) stop 179
 956      if (associated(gptr)) stop 180
 957      if (allocated(gg)) stop 181
 958
 959      call test_dummy_opt_nullptr_callee_1(ee, ff, hh, c_eptr, c_fptr, c_hptr, eptr, fptr, hptr)
 960   end subroutine test_nullptr_1
 961
 962   subroutine test_dummy_opt_nullptr_callee_1(ee, ff, hh, c_eptr, c_fptr, c_hptr, eptr, fptr, hptr)
 963      ! scalars
 964      real(c_float), optional, pointer :: ee, ff
 965      real(c_float), optional, allocatable, target :: hh
 966
 967      type(c_ptr), optional :: c_eptr, c_fptr, c_hptr
 968      real(c_float), optional, pointer :: eptr, fptr, hptr
 969
 970      if (.not.present(ee) .or. .not.present(ff)) stop 182
 971      if (associated(ee) .or. associated(ff)) stop 183
 972
 973      !$omp target data map(to:ee) map(from:ff) use_device_addr(ee,ff)
 974      if (.not.present(ee) .or. .not.present(ff)) stop 184
 975      if (associated(ee) .or. associated(ff)) stop 185
 976      if (c_associated(c_loc(ee)) .or. c_associated(c_loc(ff))) stop 186
 977      c_eptr = c_loc(ee)
 978      c_fptr = c_loc(ff)
 979      eptr => ee
 980      fptr => ff
 981      if (c_associated(c_eptr) .or. c_associated(c_fptr)) stop 187
 982      if (associated(eptr) .or. associated(fptr)) stop 188
 983      !$omp end target data
 984
 985      if (c_associated(c_eptr) .or. c_associated(c_fptr)) stop 189
 986      if (associated(eptr) .or. associated(fptr)) stop 190
 987      if (associated(ee) .or. associated(ff)) stop 191
 988
 989
 990      if (.not.present(hh)) stop 192
 991      if (allocated(hh)) stop 193
 992
 993      !$omp target data map(tofrom:hh) use_device_addr(hh)
 994      if (.not.present(hh)) stop 194
 995      if (allocated(hh)) stop 195
 996      if (c_associated(c_loc(hh))) stop 196
 997      c_hptr = c_loc(hh)
 998      hptr => hh
 999      if (c_associated(c_hptr)) stop 197
1000      if (associated(hptr)) stop 198
1001      if (allocated(hh)) stop 199
1002      !$omp end target data
1003
1004      if (c_associated(c_hptr)) stop 200
1005      if (associated(hptr)) stop 201
1006      if (allocated(hh)) stop 202
1007   end subroutine test_dummy_opt_nullptr_callee_1
1008 end module test_nullptr
1009
1010
1011
1012 ! Test local variables
1013 module tests
1014   use iso_c_binding
1015   use target_procs
1016   implicit none (type, external)
1017   private
1018   public :: test_main_1, test_main_2
1019 contains
1020    ! map + use_device_addr + c_loc
1021    subroutine test_main_1()
1022      integer, parameter :: N = 1000
1023
1024      ! scalars
1025      real(c_float), target :: aa, bb
1026      real(c_float), target, allocatable :: cc, dd
1027      real(c_float), pointer :: ee, ff
1028
1029      ! non-descriptor arrays
1030      real(c_float), target :: gg(N), hh(N)
1031
1032      allocate(cc, dd, ee, ff)
1033
1034
1035      aa = 11.0_c_float
1036      bb = 22.0_c_float
1037      cc = 33.0_c_float
1038      dd = 44.0_c_float
1039      ee = 55.0_c_float
1040      ff = 66.0_c_float
1041      gg = 77.0_c_float
1042      hh = 88.0_c_float
1043
1044      !$omp target data map(to:aa) map(from:bb) use_device_addr(aa,bb)
1045      call copy3_scalar(c_loc(aa), c_loc(bb))
1046      !$omp end target data
1047      if (abs(aa - 11.0_c_float) > 10.0_c_float * epsilon(aa)) stop 203
1048      if (abs(3.0_c_float * aa - bb) > 10.0_c_float * epsilon(aa)) stop 204
1049
1050      !$omp target data map(to:cc) map(from:dd) use_device_addr(cc,dd)
1051      call copy3_scalar(c_loc(cc), c_loc(dd))
1052      !$omp end target data
1053      if (abs(cc - 33.0_c_float) > 10.0_c_float * epsilon(cc)) stop 205
1054      if (abs(3.0_c_float * cc - dd) > 10.0_c_float * epsilon(cc)) stop 206
1055
1056      !$omp target data map(to:ee) map(from:ff) use_device_addr(ee,ff)
1057      call copy3_scalar(c_loc(ee), c_loc(ff))
1058      !$omp end target data
1059      if (abs(ee - 55.0_c_float) > 10.0_c_float * epsilon(ee)) stop 207
1060      if (abs(3.0_c_float * ee - ff) > 10.0_c_float * epsilon(ee)) stop 208
1061
1062
1063      !$omp target data map(to:gg) map(from:hh) use_device_addr(gg,hh)
1064      call copy3_array(c_loc(gg), c_loc(hh), N)
1065      !$omp end target data
1066      if (any(abs(gg - 77.0_c_float) > 10.0_c_float * epsilon(gg))) stop 209
1067      if (any(abs(3.0_c_float * gg - hh) > 10.0_c_float * epsilon(gg))) stop 210
1068
1069      deallocate(ee, ff) ! pointers, only
1070    end subroutine test_main_1
1071
1072    ! Save device ptr - and recall pointer
1073    subroutine test_main_2
1074      integer, parameter :: N = 1000
1075
1076      ! scalars
1077      real(c_float), target :: aa, bb
1078      real(c_float), target, allocatable :: cc, dd
1079      real(c_float), pointer :: ee, ff
1080
1081      ! non-descriptor arrays
1082      real(c_float), target :: gg(N), hh(N)
1083
1084      real(c_float) :: dummy
1085      type(c_ptr) :: c_aptr, c_bptr, c_cptr, c_dptr, c_eptr, c_fptr, c_gptr, c_hptr
1086      real(c_float), pointer :: aptr, bptr, cptr, dptr, eptr, fptr
1087      real(c_float), pointer :: gptr(:), hptr(:)
1088
1089      allocate(cc, dd, ee, ff)
1090
1091      aa = 111.0_c_float
1092      bb = 222.0_c_float
1093      cc = 333.0_c_float
1094      dd = 444.0_c_float
1095      ee = 555.0_c_float
1096      ff = 666.0_c_float
1097      gg = 777.0_c_float
1098      hh = 888.0_c_float
1099
1100      !$omp target data map(to:aa) map(from:bb)
1101      !$omp target data map(alloc:dummy) use_device_addr(aa,bb)
1102      c_aptr = c_loc(aa)
1103      c_bptr = c_loc(bb)
1104      aptr => aa
1105      bptr => bb
1106      !$omp end target data
1107
1108      ! check c_loc ptr once
1109      call copy3_scalar(c_aptr, c_bptr)
1110      !$omp target update from(bb)
1111      if (abs(aa - 111.0_c_float) > 10.0_c_float * epsilon(aa)) stop 211
1112      if (abs(3.0_c_float * aa - bb) > 10.0_c_float * epsilon(aa)) stop 212
1113
1114      ! check c_loc ptr again after target-value modification
1115      aa = 1111.0_c_float
1116      !$omp target update to(aa)
1117      call copy3_scalar(c_aptr, c_bptr)
1118      !$omp target update from(bb)
1119      if (abs(aa - 1111.0_c_float) > 10.0_c_float * epsilon(aa)) stop 213
1120      if (abs(3.0_c_float * aa - bb) > 10.0_c_float * epsilon(aa)) stop 214
1121
1122      ! check Fortran pointer after target-value modification
1123      aa = 11111.0_c_float
1124      !$omp target update to(aa)
1125      call copy3_scalar(c_loc(aptr), c_loc(bptr))
1126      !$omp target update from(bb)
1127      if (abs(aa - 11111.0_c_float) > 10.0_c_float * epsilon(aa)) stop 215
1128      if (abs(3.0_c_float * aa - bb) > 10.0_c_float * epsilon(aa)) stop 216
1129      !$omp end target data
1130
1131      if (abs(aa - 11111.0_c_float) > 10.0_c_float * epsilon(aa)) stop 217
1132      if (abs(3.0_c_float * aa - bb) > 10.0_c_float * epsilon(aa)) stop 218
1133
1134
1135      !$omp target data map(to:cc) map(from:dd)
1136      !$omp target data map(alloc:dummy) use_device_addr(cc,dd)
1137      c_cptr = c_loc(cc)
1138      c_dptr = c_loc(dd)
1139      cptr => cc
1140      dptr => dd
1141      !$omp end target data
1142
1143      ! check c_loc ptr once
1144      call copy3_scalar(c_cptr, c_dptr)
1145      !$omp target update from(dd)
1146      if (abs(cc - 333.0_c_float) > 10.0_c_float * epsilon(cc)) stop 219
1147      if (abs(3.0_c_float * cc - dd) > 10.0_c_float * epsilon(cc)) stop 220
1148
1149      ! check c_loc ptr again after target-value modification
1150      cc = 3333.0_c_float
1151      !$omp target update to(cc)
1152      call copy3_scalar(c_cptr, c_dptr)
1153      !$omp target update from(dd)
1154      if (abs(cc - 3333.0_c_float) > 10.0_c_float * epsilon(cc)) stop 221
1155      if (abs(3.0_c_float * cc - dd) > 10.0_c_float * epsilon(cc)) stop 222
1156
1157      ! check Fortran pointer after target-value modification
1158      cc = 33333.0_c_float
1159      !$omp target update to(cc)
1160      call copy3_scalar(c_loc(cptr), c_loc(dptr))
1161      !$omp target update from(dd)
1162      if (abs(cc - 33333.0_c_float) > 10.0_c_float * epsilon(cc)) stop 223
1163      if (abs(3.0_c_float * cc - dd) > 10.0_c_float * epsilon(cc)) stop 224
1164      !$omp end target data
1165
1166      if (abs(cc - 33333.0_c_float) > 10.0_c_float * epsilon(dd)) stop 225
1167      if (abs(3.0_c_float * cc - dd) > 10.0_c_float * epsilon(dd)) stop 226
1168
1169
1170      !$omp target data map(to:ee) map(from:ff)
1171      !$omp target data map(alloc:dummy) use_device_addr(ee,ff)
1172      c_eptr = c_loc(ee)
1173      c_fptr = c_loc(ff)
1174      eptr => ee
1175      fptr => ff
1176      !$omp end target data
1177
1178      ! check c_loc ptr once
1179      call copy3_scalar(c_eptr, c_fptr)
1180      !$omp target update from(ff)
1181      if (abs(ee - 555.0_c_float) > 10.0_c_float * epsilon(ee)) stop 227
1182      if (abs(3.0_c_float * ee - ff) > 10.0_c_float * epsilon(ee)) stop 228
1183
1184      ! check c_loc ptr again after target-value modification
1185      ee = 5555.0_c_float
1186      !$omp target update to(ee)
1187      call copy3_scalar(c_eptr, c_fptr)
1188      !$omp target update from(ff)
1189      if (abs(ee - 5555.0_c_float) > 10.0_c_float * epsilon(ee)) stop 229
1190      if (abs(3.0_c_float * ee - ff) > 10.0_c_float * epsilon(ee)) stop 230
1191
1192      ! check Fortran pointer after target-value modification
1193      ee = 55555.0_c_float
1194      !$omp target update to(ee)
1195      call copy3_scalar(c_loc(eptr), c_loc(fptr))
1196      !$omp target update from(ff)
1197      if (abs(ee - 55555.0_c_float) > 10.0_c_float * epsilon(ee)) stop 231
1198      if (abs(3.0_c_float * ee - ff) > 10.0_c_float * epsilon(ff)) stop 232
1199      !$omp end target data
1200
1201      if (abs(ee - 55555.0_c_float) > 10.0_c_float * epsilon(ee)) stop 233
1202      if (abs(3.0_c_float * ee - ff) > 10.0_c_float * epsilon(ee)) stop 234
1203
1204
1205      !$omp target data map(to:gg) map(from:hh)
1206      !$omp target data map(alloc:dummy) use_device_addr(gg,hh)
1207      c_gptr = c_loc(gg)
1208      c_hptr = c_loc(hh)
1209      gptr => gg
1210      hptr => hh
1211      !$omp end target data
1212
1213      ! check c_loc ptr once
1214      call copy3_array(c_gptr, c_hptr, N)
1215      !$omp target update from(hh)
1216      if (any(abs(gg - 777.0_c_float) > 10.0_c_float * epsilon(gg))) stop 235
1217      if (any(abs(3.0_c_float * gg - hh) > 10.0_c_float * epsilon(hh))) stop 236
1218
1219      ! check c_loc ptr again after target-value modification
1220      gg = 7777.0_c_float
1221      !$omp target update to(gg)
1222      call copy3_array(c_gptr, c_hptr, N)
1223      !$omp target update from(hh)
1224      if (any(abs(gg - 7777.0_c_float) > 10.0_c_float * epsilon(gg))) stop 237
1225      if (any(abs(3.0_c_float * gg - hh) > 10.0_c_float * epsilon(gg))) stop 238
1226
1227      ! check Fortran pointer after target-value modification
1228      gg = 77777.0_c_float
1229      !$omp target update to(gg)
1230      call copy3_array(c_loc(gptr), c_loc(hptr), N)
1231      !$omp target update from(hh)
1232      if (any(abs(gg - 77777.0_c_float) > 10.0_c_float * epsilon(gg))) stop 239
1233      if (any(abs(3.0_c_float * gg - hh) > 10.0_c_float * epsilon(gg))) stop 240
1234      !$omp end target data
1235
1236      if (any(abs(gg - 77777.0_c_float) > 10.0_c_float * epsilon(gg))) stop 241
1237      if (any(abs(3.0_c_float * gg - hh) > 10.0_c_float * epsilon(gg))) stop 242
1238
1239      deallocate(ee, ff)
1240    end subroutine test_main_2
1241 end module tests
1242
1243
1244 program omp_device_addr
1245   use tests
1246   use test_dummies
1247   use test_dummies_value
1248   use test_dummies_opt
1249   use test_dummies_opt_value
1250   use test_nullptr
1251   implicit none (type, external)
1252
1253   call test_main_1()
1254   call test_main_2()
1255
1256   call test_dummy_call_1()
1257   call test_dummy_call_2()
1258
1259   call test_dummy_val_call_1()
1260   call test_dummy_val_call_2()
1261
1262   call test_dummy_opt_call_1()
1263   call test_dummy_opt_call_2()
1264
1265   call test_dummy_opt_val_call_1()
1266   call test_dummy_opt_val_call_2()
1267
1268   call test_nullptr_1()
1269 end program omp_device_addr