1! { dg-do run } 2! Comprehensive run-time test for use_device_addr 3! 4! Differs from use_device_addr-2.f90 by using a 8-byte variable (c_double) 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! 16module target_procs 17 use iso_c_binding 18 implicit none (type, external) 19 private 20 public :: copy3_array, copy3_scalar 21contains 22 subroutine copy3_array_int(from_ptr, to_ptr, N) 23 !$omp declare target 24 real(c_double) :: from_ptr(:) 25 real(c_double) :: 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_double) :: 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_double), 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_double), 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_double), 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_double), 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 86end module target_procs 87 88 89 90! Test local dummy arguments (w/o optional) 91module 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 97contains 98 subroutine test_dummy_call_1() 99 integer, parameter :: N = 1000 100 101 ! scalars 102 real(c_double), target :: aa, bb 103 real(c_double), target, allocatable :: cc, dd 104 real(c_double), pointer :: ee, ff 105 106 ! non-descriptor arrays 107 real(c_double), target :: gg(N), hh(N) 108 109 allocate(cc, dd, ee, ff) 110 111 aa = 11.0_c_double 112 bb = 22.0_c_double 113 cc = 33.0_c_double 114 dd = 44.0_c_double 115 ee = 55.0_c_double 116 ff = 66.0_c_double 117 gg = 77.0_c_double 118 hh = 88.0_c_double 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_double), target :: aa, bb 127 real(c_double), target, allocatable :: cc, dd 128 real(c_double), pointer :: ee, ff 129 130 ! non-descriptor arrays 131 real(c_double), 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_double) > 10.0_c_double * epsilon(aa)) stop 1 138 if (abs(3.0_c_double * aa - bb) > 10.0_c_double * 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_double) > 10.0_c_double * epsilon(cc)) stop 3 144 if (abs(3.0_c_double * cc - dd) > 10.0_c_double * 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_double) > 10.0_c_double * epsilon(ee)) stop 5 150 if (abs(3.0_c_double * ee - ff) > 10.0_c_double * 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_double) > 10.0_c_double * epsilon(gg))) stop 7 157 if (any(abs(3.0_c_double * gg - hh) > 10.0_c_double * 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_double), target :: aa, bb 166 real(c_double), target, allocatable :: cc, dd 167 real(c_double), pointer :: ee, ff 168 169 ! non-descriptor arrays 170 real(c_double), 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_double), pointer :: aptr, bptr, cptr, dptr, eptr, fptr 174 real(c_double), 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_double), target :: aa, bb 190 real(c_double), target, allocatable :: cc, dd 191 real(c_double), pointer :: ee, ff 192 193 ! non-descriptor arrays 194 real(c_double), 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_double), pointer :: aptr, bptr, cptr, dptr, eptr, fptr 198 real(c_double), pointer :: gptr(:), hptr(:) 199 200 integer, value :: N 201 202 real(c_double) :: dummy 203 204 aa = 111.0_c_double 205 bb = 222.0_c_double 206 cc = 333.0_c_double 207 dd = 444.0_c_double 208 ee = 555.0_c_double 209 ff = 666.0_c_double 210 gg = 777.0_c_double 211 hh = 888.0_c_double 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_double) > 10.0_c_double * epsilon(aa)) stop 9 225 if (abs(3.0_c_double * aa - bb) > 10.0_c_double * epsilon(aa)) stop 10 226 227 ! check c_loc ptr again after target-value modification 228 aa = 1111.0_c_double 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_double) > 10.0_c_double * epsilon(aa)) stop 11 233 if (abs(3.0_c_double * aa - bb) > 10.0_c_double * epsilon(aa)) stop 12 234 235 ! check Fortran pointer after target-value modification 236 aa = 11111.0_c_double 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_double) > 10.0_c_double * epsilon(aa)) stop 13 241 if (abs(3.0_c_double * aa - bb) > 10.0_c_double * epsilon(aa)) stop 14 242 !$omp end target data 243 244 if (abs(aa - 11111.0_c_double) > 10.0_c_double * epsilon(aa)) stop 15 245 if (abs(3.0_c_double * aa - bb) > 10.0_c_double * 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_double) > 10.0_c_double * epsilon(cc)) stop 17 260 if (abs(3.0_c_double * cc - dd) > 10.0_c_double * epsilon(cc)) stop 18 261 262 ! check c_loc ptr again after target-value modification 263 cc = 3333.0_c_double 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_double) > 10.0_c_double * epsilon(cc)) stop 19 268 if (abs(3.0_c_double * cc - dd) > 10.0_c_double * epsilon(cc)) stop 20 269 270 ! check Fortran pointer after target-value modification 271 cc = 33333.0_c_double 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_double) > 10.0_c_double * epsilon(cc)) stop 21 276 if (abs(3.0_c_double * cc - dd) > 10.0_c_double * epsilon(cc)) stop 22 277 !$omp end target data 278 279 if (abs(cc - 33333.0_c_double) > 10.0_c_double * epsilon(dd)) stop 23 280 if (abs(3.0_c_double * cc - dd) > 10.0_c_double * 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_double) > 10.0_c_double * epsilon(ee)) stop 25 295 if (abs(3.0_c_double * ee - ff) > 10.0_c_double * epsilon(ee)) stop 26 296 297 ! check c_loc ptr again after target-value modification 298 ee = 5555.0_c_double 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_double) > 10.0_c_double * epsilon(ee)) stop 27 303 if (abs(3.0_c_double * ee - ff) > 10.0_c_double * epsilon(ee)) stop 28 304 305 ! check Fortran pointer after target-value modification 306 ee = 55555.0_c_double 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_double) > 10.0_c_double * epsilon(ee)) stop 29 311 if (abs(3.0_c_double * ee - ff) > 10.0_c_double * epsilon(ff)) stop 30 312 !$omp end target data 313 314 if (abs(ee - 55555.0_c_double) > 10.0_c_double * epsilon(ee)) stop 31 315 if (abs(3.0_c_double * ee - ff) > 10.0_c_double * 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_double) > 10.0_c_double * epsilon(gg))) stop 33 330 if (any(abs(3.0_c_double * gg - hh) > 10.0_c_double * epsilon(hh))) stop 34 331 332 ! check c_loc ptr again after target-value modification 333 gg = 7777.0_c_double 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_double) > 10.0_c_double * epsilon(gg))) stop 35 338 if (any(abs(3.0_c_double * gg - hh) > 10.0_c_double * epsilon(gg))) stop 36 339 340 ! check Fortran pointer after target-value modification 341 gg = 77777.0_c_double 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_double) > 10.0_c_double * epsilon(gg))) stop 37 346 if (any(abs(3.0_c_double * gg - hh) > 10.0_c_double * epsilon(gg))) stop 38 347 !$omp end target data 348 349 if (any(abs(gg - 77777.0_c_double) > 10.0_c_double * epsilon(gg))) stop 39 350 if (any(abs(3.0_c_double * gg - hh) > 10.0_c_double * epsilon(gg))) stop 40 351 end subroutine test_dummy_callee_2 352end module test_dummies 353 354 355 356! Test local dummy arguments + VALUE (w/o optional) 357module 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 363contains 364 subroutine test_dummy_val_call_1() 365 ! scalars - with value, neither allocatable nor pointer no dimension permitted 366 real(c_double), target :: aa, bb 367 368 aa = 11.0_c_double 369 bb = 22.0_c_double 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_double), 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_double) > 10.0_c_double * epsilon(aa)) stop 41 382 if (abs(3.0_c_double * aa - bb) > 10.0_c_double * 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_double), target :: aa, bb 389 type(c_ptr) :: c_aptr, c_bptr 390 real(c_double), 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_double), value, target :: aa, bb 397 type(c_ptr), value :: c_aptr, c_bptr 398 real(c_double), pointer :: aptr, bptr 399 400 real(c_double) :: dummy 401 402 aa = 111.0_c_double 403 bb = 222.0_c_double 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_double) > 10.0_c_double * epsilon(aa)) stop 43 417 if (abs(3.0_c_double * aa - bb) > 10.0_c_double * epsilon(aa)) stop 44 418 419 ! check c_loc ptr again after target-value modification 420 aa = 1111.0_c_double 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_double) > 10.0_c_double * epsilon(aa)) stop 45 425 if (abs(3.0_c_double * aa - bb) > 10.0_c_double * epsilon(aa)) stop 46 426 427 ! check Fortran pointer after target-value modification 428 aa = 11111.0_c_double 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_double) > 10.0_c_double * epsilon(aa)) stop 47 433 if (abs(3.0_c_double * aa - bb) > 10.0_c_double * epsilon(aa)) stop 48 434 !$omp end target data 435 436 if (abs(aa - 11111.0_c_double) > 10.0_c_double * epsilon(aa)) stop 49 437 if (abs(3.0_c_double * aa - bb) > 10.0_c_double * epsilon(aa)) stop 50 438 end subroutine test_dummy_val_callee_2 439end module test_dummies_value 440 441 442 443! Test local dummy arguments + OPTIONAL 444! Values present and ptr associated to nonzero 445module 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 451contains 452 subroutine test_dummy_opt_call_1() 453 integer, parameter :: N = 1000 454 455 ! scalars 456 real(c_double), target :: aa, bb 457 real(c_double), target, allocatable :: cc, dd 458 real(c_double), pointer :: ee, ff 459 460 ! non-descriptor arrays 461 real(c_double), target :: gg(N), hh(N) 462 463 allocate(cc, dd, ee, ff) 464 465 aa = 11.0_c_double 466 bb = 22.0_c_double 467 cc = 33.0_c_double 468 dd = 44.0_c_double 469 ee = 55.0_c_double 470 ff = 66.0_c_double 471 gg = 77.0_c_double 472 hh = 88.0_c_double 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_double), optional, target :: aa, bb 482 real(c_double), optional, target, allocatable :: cc, dd 483 real(c_double), optional, pointer :: ee, ff 484 485 ! non-descriptor arrays 486 real(c_double), 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_double) > 10.0_c_double * epsilon(aa)) stop 58 503 if (abs(3.0_c_double * aa - bb) > 10.0_c_double * 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_double) > 10.0_c_double * epsilon(cc)) stop 62 511 if (abs(3.0_c_double * cc - dd) > 10.0_c_double * 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_double) > 10.0_c_double * epsilon(ee)) stop 67 520 if (abs(3.0_c_double * ee - ff) > 10.0_c_double * 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_double) > 10.0_c_double * epsilon(gg))) stop 71 528 if (any(abs(3.0_c_double * gg - hh) > 10.0_c_double * 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_double), optional, target :: aa, bb 534 real(c_double), optional, target, allocatable :: cc, dd 535 real(c_double), optional, pointer :: ee, ff 536 537 ! non-descriptor arrays 538 real(c_double), 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_double), target :: aa, bb 572 real(c_double), target, allocatable :: cc, dd 573 real(c_double), pointer :: ee, ff 574 575 ! non-descriptor arrays 576 real(c_double), 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_double), pointer :: aptr, bptr, cptr, dptr, eptr, fptr 580 real(c_double), 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_double), optional, target :: aa, bb 596 real(c_double), optional, target, allocatable :: cc, dd 597 real(c_double), optional, pointer :: ee, ff 598 599 ! non-descriptor arrays 600 real(c_double), 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_double), optional, pointer :: aptr, bptr, cptr, dptr, eptr, fptr 604 real(c_double), optional, pointer :: gptr(:), hptr(:) 605 606 integer, value :: N 607 608 real(c_double) :: 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_double 619 bb = 222.0_c_double 620 cc = 333.0_c_double 621 dd = 444.0_c_double 622 ee = 555.0_c_double 623 ff = 666.0_c_double 624 gg = 777.0_c_double 625 hh = 888.0_c_double 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_double) > 10.0_c_double * epsilon(aa)) stop 86 648 if (abs(3.0_c_double * aa - bb) > 10.0_c_double * epsilon(aa)) stop 87 649 650 ! check c_loc ptr again after target-value modification 651 aa = 1111.0_c_double 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_double) > 10.0_c_double * epsilon(aa)) stop 88 656 if (abs(3.0_c_double * aa - bb) > 10.0_c_double * epsilon(aa)) stop 89 657 658 ! check Fortran pointer after target-value modification 659 aa = 11111.0_c_double 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_double) > 10.0_c_double * epsilon(aa)) stop 90 664 if (abs(3.0_c_double * aa - bb) > 10.0_c_double * epsilon(aa)) stop 91 665 !$omp end target data 666 667 if (abs(aa - 11111.0_c_double) > 10.0_c_double * epsilon(aa)) stop 92 668 if (abs(3.0_c_double * aa - bb) > 10.0_c_double * 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_double) > 10.0_c_double * epsilon(cc)) stop 102 691 if (abs(3.0_c_double * cc - dd) > 10.0_c_double * epsilon(cc)) stop 103 692 693 ! check c_loc ptr again after target-value modification 694 cc = 3333.0_c_double 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_double) > 10.0_c_double * epsilon(cc)) stop 104 699 if (abs(3.0_c_double * cc - dd) > 10.0_c_double * epsilon(cc)) stop 105 700 701 ! check Fortran pointer after target-value modification 702 cc = 33333.0_c_double 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_double) > 10.0_c_double * epsilon(cc)) stop 106 707 if (abs(3.0_c_double * cc - dd) > 10.0_c_double * epsilon(cc)) stop 107 708 !$omp end target data 709 710 if (abs(cc - 33333.0_c_double) > 10.0_c_double * epsilon(dd)) stop 108 711 if (abs(3.0_c_double * cc - dd) > 10.0_c_double * 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_double) > 10.0_c_double * epsilon(ee)) stop 120 736 if (abs(3.0_c_double * ee - ff) > 10.0_c_double * epsilon(ee)) stop 121 737 738 ! check c_loc ptr again after target-value modification 739 ee = 5555.0_c_double 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_double) > 10.0_c_double * epsilon(ee)) stop 122 744 if (abs(3.0_c_double * ee - ff) > 10.0_c_double * epsilon(ee)) stop 123 745 746 ! check Fortran pointer after target-value modification 747 ee = 55555.0_c_double 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_double) > 10.0_c_double * epsilon(ee)) stop 124 752 if (abs(3.0_c_double * ee - ff) > 10.0_c_double * epsilon(ff)) stop 125 753 !$omp end target data 754 755 if (abs(ee - 55555.0_c_double) > 10.0_c_double * epsilon(ee)) stop 126 756 if (abs(3.0_c_double * ee - ff) > 10.0_c_double * 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_double) > 10.0_c_double * epsilon(gg))) stop 136 779 if (any(abs(3.0_c_double * gg - hh) > 10.0_c_double * epsilon(hh))) stop 137 780 781 ! check c_loc ptr again after target-value modification 782 gg = 7777.0_c_double 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_double) > 10.0_c_double * epsilon(gg))) stop 138 787 if (any(abs(3.0_c_double * gg - hh) > 10.0_c_double * epsilon(gg))) stop 139 788 789 ! check Fortran pointer after target-value modification 790 gg = 77777.0_c_double 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_double) > 10.0_c_double * epsilon(gg))) stop 140 795 if (any(abs(3.0_c_double * gg - hh) > 10.0_c_double * epsilon(gg))) stop 141 796 !$omp end target data 797 798 if (any(abs(gg - 77777.0_c_double) > 10.0_c_double * epsilon(gg))) stop 142 799 if (any(abs(3.0_c_double * gg - hh) > 10.0_c_double * epsilon(gg))) stop 143 800 end subroutine test_dummy_opt_callee_2 801end module test_dummies_opt 802 803 804 805! Test local dummy arguments + OPTIONAL + VALUE 806! Values present 807module 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 813contains 814 subroutine test_dummy_opt_val_call_1() 815 ! scalars - with value, neither allocatable nor pointer no dimension permitted 816 real(c_double), target :: aa, bb 817 818 aa = 11.0_c_double 819 bb = 22.0_c_double 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_double), 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_double) > 10.0_c_double * epsilon(aa)) stop 147 836 if (abs(3.0_c_double * aa - bb) > 10.0_c_double * 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_double), target :: aa, bb 843 type(c_ptr) :: c_aptr, c_bptr 844 real(c_double), 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_double), optional, value, target :: aa, bb 851 type(c_ptr), optional, value :: c_aptr, c_bptr 852 real(c_double), optional, pointer :: aptr, bptr 853 854 real(c_double) :: 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_double 861 bb = 222.0_c_double 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_double) > 10.0_c_double * epsilon(aa)) stop 160 885 if (abs(3.0_c_double * aa - bb) > 10.0_c_double * epsilon(aa)) stop 161 886 887 ! check c_loc ptr again after target-value modification 888 aa = 1111.0_c_double 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_double) > 10.0_c_double * epsilon(aa)) stop 162 893 if (abs(3.0_c_double * aa - bb) > 10.0_c_double * epsilon(aa)) stop 163 894 895 ! check Fortran pointer after target-value modification 896 aa = 11111.0_c_double 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_double) > 10.0_c_double * epsilon(aa)) stop 164 901 if (abs(3.0_c_double * aa - bb) > 10.0_c_double * epsilon(aa)) stop 165 902 !$omp end target data 903 904 if (abs(aa - 11111.0_c_double) > 10.0_c_double * epsilon(aa)) stop 166 905 if (abs(3.0_c_double * aa - bb) > 10.0_c_double * epsilon(aa)) stop 167 906 end subroutine test_dummy_opt_val_callee_2 907end module test_dummies_opt_value 908 909 910 911! Test nullptr 912module test_nullptr 913 use iso_c_binding 914 implicit none (type, external) 915 private 916 public :: test_nullptr_1 917contains 918 subroutine test_nullptr_1() 919 ! scalars 920 real(c_double), pointer :: aa, bb 921 real(c_double), pointer :: ee, ff 922 923 real(c_double), allocatable, target :: gg, hh 924 925 type(c_ptr) :: c_aptr, c_bptr, c_eptr, c_fptr, c_gptr, c_hptr 926 real(c_double), 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_double), optional, pointer :: ee, ff 965 real(c_double), optional, allocatable, target :: hh 966 967 type(c_ptr), optional :: c_eptr, c_fptr, c_hptr 968 real(c_double), 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 1008end module test_nullptr 1009 1010 1011 1012! Test local variables 1013module 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 1019contains 1020 ! map + use_device_addr + c_loc 1021 subroutine test_main_1() 1022 integer, parameter :: N = 1000 1023 1024 ! scalars 1025 real(c_double), target :: aa, bb 1026 real(c_double), target, allocatable :: cc, dd 1027 real(c_double), pointer :: ee, ff 1028 1029 ! non-descriptor arrays 1030 real(c_double), target :: gg(N), hh(N) 1031 1032 allocate(cc, dd, ee, ff) 1033 1034 1035 aa = 11.0_c_double 1036 bb = 22.0_c_double 1037 cc = 33.0_c_double 1038 dd = 44.0_c_double 1039 ee = 55.0_c_double 1040 ff = 66.0_c_double 1041 gg = 77.0_c_double 1042 hh = 88.0_c_double 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_double) > 10.0_c_double * epsilon(aa)) stop 203 1048 if (abs(3.0_c_double * aa - bb) > 10.0_c_double * 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_double) > 10.0_c_double * epsilon(cc)) stop 205 1054 if (abs(3.0_c_double * cc - dd) > 10.0_c_double * 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_double) > 10.0_c_double * epsilon(ee)) stop 207 1060 if (abs(3.0_c_double * ee - ff) > 10.0_c_double * 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_double) > 10.0_c_double * epsilon(gg))) stop 209 1067 if (any(abs(3.0_c_double * gg - hh) > 10.0_c_double * 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_double), target :: aa, bb 1078 real(c_double), target, allocatable :: cc, dd 1079 real(c_double), pointer :: ee, ff 1080 1081 ! non-descriptor arrays 1082 real(c_double), target :: gg(N), hh(N) 1083 1084 real(c_double) :: dummy 1085 type(c_ptr) :: c_aptr, c_bptr, c_cptr, c_dptr, c_eptr, c_fptr, c_gptr, c_hptr 1086 real(c_double), pointer :: aptr, bptr, cptr, dptr, eptr, fptr 1087 real(c_double), pointer :: gptr(:), hptr(:) 1088 1089 allocate(cc, dd, ee, ff) 1090 1091 aa = 111.0_c_double 1092 bb = 222.0_c_double 1093 cc = 333.0_c_double 1094 dd = 444.0_c_double 1095 ee = 555.0_c_double 1096 ff = 666.0_c_double 1097 gg = 777.0_c_double 1098 hh = 888.0_c_double 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_double) > 10.0_c_double * epsilon(aa)) stop 211 1112 if (abs(3.0_c_double * aa - bb) > 10.0_c_double * epsilon(aa)) stop 212 1113 1114 ! check c_loc ptr again after target-value modification 1115 aa = 1111.0_c_double 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_double) > 10.0_c_double * epsilon(aa)) stop 213 1120 if (abs(3.0_c_double * aa - bb) > 10.0_c_double * epsilon(aa)) stop 214 1121 1122 ! check Fortran pointer after target-value modification 1123 aa = 11111.0_c_double 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_double) > 10.0_c_double * epsilon(aa)) stop 215 1128 if (abs(3.0_c_double * aa - bb) > 10.0_c_double * epsilon(aa)) stop 216 1129 !$omp end target data 1130 1131 if (abs(aa - 11111.0_c_double) > 10.0_c_double * epsilon(aa)) stop 217 1132 if (abs(3.0_c_double * aa - bb) > 10.0_c_double * 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_double) > 10.0_c_double * epsilon(cc)) stop 219 1147 if (abs(3.0_c_double * cc - dd) > 10.0_c_double * epsilon(cc)) stop 220 1148 1149 ! check c_loc ptr again after target-value modification 1150 cc = 3333.0_c_double 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_double) > 10.0_c_double * epsilon(cc)) stop 221 1155 if (abs(3.0_c_double * cc - dd) > 10.0_c_double * epsilon(cc)) stop 222 1156 1157 ! check Fortran pointer after target-value modification 1158 cc = 33333.0_c_double 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_double) > 10.0_c_double * epsilon(cc)) stop 223 1163 if (abs(3.0_c_double * cc - dd) > 10.0_c_double * epsilon(cc)) stop 224 1164 !$omp end target data 1165 1166 if (abs(cc - 33333.0_c_double) > 10.0_c_double * epsilon(dd)) stop 225 1167 if (abs(3.0_c_double * cc - dd) > 10.0_c_double * 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_double) > 10.0_c_double * epsilon(ee)) stop 227 1182 if (abs(3.0_c_double * ee - ff) > 10.0_c_double * epsilon(ee)) stop 228 1183 1184 ! check c_loc ptr again after target-value modification 1185 ee = 5555.0_c_double 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_double) > 10.0_c_double * epsilon(ee)) stop 229 1190 if (abs(3.0_c_double * ee - ff) > 10.0_c_double * epsilon(ee)) stop 230 1191 1192 ! check Fortran pointer after target-value modification 1193 ee = 55555.0_c_double 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_double) > 10.0_c_double * epsilon(ee)) stop 231 1198 if (abs(3.0_c_double * ee - ff) > 10.0_c_double * epsilon(ff)) stop 232 1199 !$omp end target data 1200 1201 if (abs(ee - 55555.0_c_double) > 10.0_c_double * epsilon(ee)) stop 233 1202 if (abs(3.0_c_double * ee - ff) > 10.0_c_double * 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_double) > 10.0_c_double * epsilon(gg))) stop 235 1217 if (any(abs(3.0_c_double * gg - hh) > 10.0_c_double * epsilon(hh))) stop 236 1218 1219 ! check c_loc ptr again after target-value modification 1220 gg = 7777.0_c_double 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_double) > 10.0_c_double * epsilon(gg))) stop 237 1225 if (any(abs(3.0_c_double * gg - hh) > 10.0_c_double * epsilon(gg))) stop 238 1226 1227 ! check Fortran pointer after target-value modification 1228 gg = 77777.0_c_double 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_double) > 10.0_c_double * epsilon(gg))) stop 239 1233 if (any(abs(3.0_c_double * gg - hh) > 10.0_c_double * epsilon(gg))) stop 240 1234 !$omp end target data 1235 1236 if (any(abs(gg - 77777.0_c_double) > 10.0_c_double * epsilon(gg))) stop 241 1237 if (any(abs(3.0_c_double * gg - hh) > 10.0_c_double * epsilon(gg))) stop 242 1238 1239 deallocate(ee, ff) 1240 end subroutine test_main_2 1241end module tests 1242 1243 1244program 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() 1269end program omp_device_addr 1270