1! { dg-do run } 2 3! Comprehensive run-time test for use_device_addr 4! 5! Tests array with array descriptor 6! 7! Differs from use_device_addr-4.f90 by using a 8-byte variable (c_double) 8! 9! This test case assumes that a 'var' appearing in 'use_device_addr' is 10! only used as 'c_loc(var)' - such that only the actual data is used/usable 11! on the device - and not meta data ((dynamic) type information, 'present()' 12! status, array shape). 13! 14! Untested in this test case are: 15! - scalars 16! - polymorphic variables 17! - absent optional arguments 18! 19module target_procs 20 use iso_c_binding 21 implicit none (type, external) 22 private 23 public :: copy3_array 24contains 25 subroutine copy3_array_int(from_ptr, to_ptr, N) 26 !$omp declare target 27 real(c_double) :: from_ptr(:) 28 real(c_double) :: to_ptr(:) 29 integer, value :: N 30 integer :: i 31 32 !$omp parallel do 33 do i = 1, N 34 to_ptr(i) = 3 * from_ptr(i) 35 end do 36 !$omp end parallel do 37 end subroutine copy3_array_int 38 39 subroutine copy3_array(from, to, N) 40 type(c_ptr), value :: from, to 41 integer, value :: N 42 real(c_double), pointer :: from_ptr(:), to_ptr(:) 43 44 call c_f_pointer(from, from_ptr, shape=[N]) 45 call c_f_pointer(to, to_ptr, shape=[N]) 46 47 call do_offload_scalar(from_ptr,to_ptr) 48 contains 49 subroutine do_offload_scalar(from_r, to_r) 50 real(c_double), target :: from_r(:), to_r(:) 51 ! The extra function is needed as is_device_ptr 52 ! requires non-value, non-pointer dummy arguments 53 54 !$omp target is_device_ptr(from_r, to_r) 55 call copy3_array_int(from_r, to_r, N) 56 !$omp end target 57 end subroutine do_offload_scalar 58 end subroutine copy3_array 59end module target_procs 60 61 62 63! Test local dummy arguments (w/o optional) 64module test_dummies 65 use iso_c_binding 66 use target_procs 67 implicit none (type, external) 68 private 69 public :: test_dummy_call_1, test_dummy_call_2 70contains 71 subroutine test_dummy_call_1() 72 integer, parameter :: N = 1000 73 74 real(c_double), target :: aa(N), bb(N) 75 real(c_double), target, allocatable :: cc(:), dd(:) 76 real(c_double), pointer :: ee(:), ff(:) 77 78 allocate(cc(N), dd(N), ee(N), ff(N)) 79 80 aa = 11.0_c_double 81 bb = 22.0_c_double 82 cc = 33.0_c_double 83 dd = 44.0_c_double 84 ee = 55.0_c_double 85 ff = 66.0_c_double 86 87 call test_dummy_callee_1(aa, bb, cc, dd, ee, ff, N) 88 deallocate(ee, ff) ! pointers, only 89 end subroutine test_dummy_call_1 90 91 subroutine test_dummy_callee_1(aa, bb, cc, dd, ee, ff, N) 92 real(c_double), target :: aa(:), bb(:) 93 real(c_double), target, allocatable :: cc(:), dd(:) 94 real(c_double), pointer :: ee(:), ff(:) 95 96 integer, value :: N 97 98 !$omp target data map(to:aa) map(from:bb) use_device_addr(aa,bb) 99 call copy3_array(c_loc(aa), c_loc(bb), N) 100 !$omp end target data 101 if (any(abs(aa - 11.0_c_double) > 10.0_c_double * epsilon(aa))) stop 2 102 if (any(abs(3.0_c_double * aa - bb) > 10.0_c_double * epsilon(aa))) stop 3 103 104 !$omp target data map(to:cc) map(from:dd) use_device_addr(cc,dd) 105 call copy3_array(c_loc(cc), c_loc(dd), N) 106 !$omp end target data 107 if (any(abs(cc - 33.0_c_double) > 10.0_c_double * epsilon(cc))) stop 4 108 if (any(abs(3.0_c_double * cc - dd) > 10.0_c_double * epsilon(cc))) stop 5 109 110 !$omp target data map(to:ee) map(from:ff) use_device_addr(ee,ff) 111 call copy3_array(c_loc(ee), c_loc(ff), N) 112 !$omp end target data 113 if (any(abs(ee - 55.0_c_double) > 10.0_c_double * epsilon(ee))) stop 6 114 if (any(abs(3.0_c_double * ee - ff) > 10.0_c_double * epsilon(ee))) stop 7 115 end subroutine test_dummy_callee_1 116 117 ! Save device ptr - and recall pointer 118 subroutine test_dummy_call_2() 119 integer, parameter :: N = 1000 120 121 real(c_double), target :: aa(N), bb(N) 122 real(c_double), target, allocatable :: cc(:), dd(:) 123 real(c_double), pointer :: ee(:), ff(:) 124 125 type(c_ptr) :: c_aptr, c_bptr, c_cptr, c_dptr, c_eptr, c_fptr 126 real(c_double), pointer :: aptr(:), bptr(:), cptr(:), dptr(:), eptr(:), fptr(:) 127 128 allocate(cc(N), dd(N), ee(N), ff(N)) 129 130 call test_dummy_callee_2(aa, bb, cc, dd, ee, ff, & 131 c_aptr, c_bptr, c_cptr, c_dptr, c_eptr, c_fptr, & 132 aptr, bptr, cptr, dptr, eptr, fptr, & 133 N) 134 deallocate(ee, ff) 135 end subroutine test_dummy_call_2 136 137 subroutine test_dummy_callee_2(aa, bb, cc, dd, ee, ff, & 138 c_aptr, c_bptr, c_cptr, c_dptr, c_eptr, c_fptr, & 139 aptr, bptr, cptr, dptr, eptr, fptr, & 140 N) 141 real(c_double), target :: aa(:), bb(:) 142 real(c_double), target, allocatable :: cc(:), dd(:) 143 real(c_double), pointer :: ee(:), ff(:) 144 145 type(c_ptr) :: c_aptr, c_bptr, c_cptr, c_dptr, c_eptr, c_fptr 146 real(c_double), pointer :: aptr(:), bptr(:), cptr(:), dptr(:), eptr(:), fptr(:) 147 148 integer, value :: N 149 150 real(c_double) :: dummy 151 152 aa = 111.0_c_double 153 bb = 222.0_c_double 154 cc = 333.0_c_double 155 dd = 444.0_c_double 156 ee = 555.0_c_double 157 ff = 666.0_c_double 158 159 !$omp target data map(to:aa) map(from:bb) 160 !$omp target data map(alloc:dummy) use_device_addr(aa,bb) 161 c_aptr = c_loc(aa) 162 c_bptr = c_loc(bb) 163 aptr => aa 164 bptr => bb 165 !$omp end target data 166 167 ! check c_loc ptr once 168 call copy3_array(c_aptr, c_bptr, N) 169 !$omp target update from(bb) 170 if (any(abs(aa - 111.0_c_double) > 10.0_c_double * epsilon(aa))) stop 8 171 if (any(abs(3.0_c_double * aa - bb) > 10.0_c_double * epsilon(aa))) stop 9 172 173 ! check c_loc ptr again after target-value modification 174 aa = 1111.0_c_double 175 !$omp target update to(aa) 176 call copy3_array(c_aptr, c_bptr, N) 177 !$omp target update from(bb) 178 if (any(abs(aa - 1111.0_c_double) > 10.0_c_double * epsilon(aa))) stop 10 179 if (any(abs(3.0_c_double * aa - bb) > 10.0_c_double * epsilon(aa))) stop 11 180 181 ! check Fortran pointer after target-value modification 182 aa = 11111.0_c_double 183 !$omp target update to(aa) 184 call copy3_array(c_loc(aptr), c_loc(bptr), N) 185 !$omp target update from(bb) 186 if (any(abs(aa - 11111.0_c_double) > 10.0_c_double * epsilon(aa))) stop 12 187 if (any(abs(3.0_c_double * aa - bb) > 10.0_c_double * epsilon(aa))) stop 13 188 !$omp end target data 189 190 if (any(abs(aa - 11111.0_c_double) > 10.0_c_double * epsilon(aa))) stop 14 191 if (any(abs(3.0_c_double * aa - bb) > 10.0_c_double * epsilon(aa))) stop 15 192 193 194 !$omp target data map(to:cc) map(from:dd) 195 !$omp target data map(alloc:dummy) use_device_addr(cc,dd) 196 c_cptr = c_loc(cc) 197 c_dptr = c_loc(dd) 198 cptr => cc 199 dptr => dd 200 !$omp end target data 201 202 ! check c_loc ptr once 203 call copy3_array(c_cptr, c_dptr, N) 204 !$omp target update from(dd) 205 if (any(abs(cc - 333.0_c_double) > 10.0_c_double * epsilon(cc))) stop 16 206 if (any(abs(3.0_c_double * cc - dd) > 10.0_c_double * epsilon(cc))) stop 17 207 208 ! check c_loc ptr again after target-value modification 209 cc = 3333.0_c_double 210 !$omp target update to(cc) 211 call copy3_array(c_cptr, c_dptr, N) 212 !$omp target update from(dd) 213 if (any(abs(cc - 3333.0_c_double) > 10.0_c_double * epsilon(cc))) stop 18 214 if (any(abs(3.0_c_double * cc - dd) > 10.0_c_double * epsilon(cc))) stop 19 215 216 ! check Fortran pointer after target-value modification 217 cc = 33333.0_c_double 218 !$omp target update to(cc) 219 call copy3_array(c_loc(cptr), c_loc(dptr), N) 220 !$omp target update from(dd) 221 if (any(abs(cc - 33333.0_c_double) > 10.0_c_double * epsilon(cc))) stop 20 222 if (any(abs(3.0_c_double * cc - dd) > 10.0_c_double * epsilon(cc))) stop 21 223 !$omp end target data 224 225 if (any(abs(cc - 33333.0_c_double) > 10.0_c_double * epsilon(dd))) stop 22 226 if (any(abs(3.0_c_double * cc - dd) > 10.0_c_double * epsilon(dd))) stop 23 227 228 229 !$omp target data map(to:ee) map(from:ff) 230 !$omp target data map(alloc:dummy) use_device_addr(ee,ff) 231 c_eptr = c_loc(ee) 232 c_fptr = c_loc(ff) 233 eptr => ee 234 fptr => ff 235 !$omp end target data 236 237 ! check c_loc ptr once 238 call copy3_array(c_eptr, c_fptr, N) 239 !$omp target update from(ff) 240 if (any(abs(ee - 555.0_c_double) > 10.0_c_double * epsilon(ee))) stop 24 241 if (any(abs(3.0_c_double * ee - ff) > 10.0_c_double * epsilon(ee))) stop 25 242 243 ! check c_loc ptr again after target-value modification 244 ee = 5555.0_c_double 245 !$omp target update to(ee) 246 call copy3_array(c_eptr, c_fptr, N) 247 !$omp target update from(ff) 248 if (any(abs(ee - 5555.0_c_double) > 10.0_c_double * epsilon(ee))) stop 26 249 if (any(abs(3.0_c_double * ee - ff) > 10.0_c_double * epsilon(ee))) stop 27 250 251 ! check Fortran pointer after target-value modification 252 ee = 55555.0_c_double 253 !$omp target update to(ee) 254 call copy3_array(c_loc(eptr), c_loc(fptr), N) 255 !$omp target update from(ff) 256 if (any(abs(ee - 55555.0_c_double) > 10.0_c_double * epsilon(ee))) stop 28 257 if (any(abs(3.0_c_double * ee - ff) > 10.0_c_double * epsilon(ff))) stop 29 258 !$omp end target data 259 260 if (any(abs(ee - 55555.0_c_double) > 10.0_c_double * epsilon(ee))) stop 30 261 if (any(abs(3.0_c_double * ee - ff) > 10.0_c_double * epsilon(ee))) stop 31 262 end subroutine test_dummy_callee_2 263end module test_dummies 264 265 266 267! Test local dummy arguments + OPTIONAL 268! Values present and ptr associated to nonzero 269module test_dummies_opt 270 use iso_c_binding 271 use target_procs 272 implicit none (type, external) 273 private 274 public :: test_dummy_opt_call_1, test_dummy_opt_call_2 275contains 276 subroutine test_dummy_opt_call_1() 277 integer, parameter :: N = 1000 278 279 real(c_double), target :: aa(N), bb(N) 280 real(c_double), target, allocatable :: cc(:), dd(:) 281 real(c_double), pointer :: ee(:), ff(:) 282 283 allocate(cc(N), dd(N), ee(N), ff(N)) 284 285 aa = 11.0_c_double 286 bb = 22.0_c_double 287 cc = 33.0_c_double 288 dd = 44.0_c_double 289 ee = 55.0_c_double 290 ff = 66.0_c_double 291 292 call test_dummy_opt_callee_1(aa, bb, cc, dd, ee, ff, N) 293 call test_dummy_opt_callee_1_absent(N=N) 294 deallocate(ee, ff) ! pointers, only 295 end subroutine test_dummy_opt_call_1 296 297 subroutine test_dummy_opt_callee_1(aa, bb, cc, dd, ee, ff, N) 298 ! scalars 299 real(c_double), optional, target :: aa(:), bb(:) 300 real(c_double), optional, target, allocatable :: cc(:), dd(:) 301 real(c_double), optional, pointer :: ee(:), ff(:) 302 303 integer, value :: N 304 305 ! All shall be present - and pointing to non-NULL 306 if (.not.present(aa) .or. .not.present(bb)) stop 32 307 if (.not.present(cc) .or. .not.present(dd)) stop 33 308 if (.not.present(ee) .or. .not.present(ff)) stop 34 309 310 if (.not.allocated(cc) .or. .not.allocated(dd)) stop 35 311 if (.not.associated(ee) .or. .not.associated(ff)) stop 36 312 313 !$omp target data map(to:aa) map(from:bb) use_device_addr(aa,bb) 314 if (.not.present(aa) .or. .not.present(bb)) stop 37 315 if (.not.c_associated(c_loc(aa)) .or. .not.c_associated(c_loc(bb))) stop 38 316 call copy3_array(c_loc(aa), c_loc(bb), N) 317 !$omp end target data 318 if (any(abs(aa - 11.0_c_double) > 10.0_c_double * epsilon(aa))) stop 39 319 if (any(abs(3.0_c_double * aa - bb) > 10.0_c_double * epsilon(aa))) stop 40 320 321 !$omp target data map(to:cc) map(from:dd) use_device_addr(cc,dd) 322 if (.not.present(cc) .or. .not.present(dd)) stop 41 323 if (.not.allocated(cc) .or. .not.allocated(dd)) stop 42 324 if (.not.c_associated(c_loc(cc)) .or. .not.c_associated(c_loc(dd))) stop 43 325 call copy3_array(c_loc(cc), c_loc(dd), N) 326 !$omp end target data 327 if (any(abs(cc - 33.0_c_double) > 10.0_c_double * epsilon(cc))) stop 44 328 if (any(abs(3.0_c_double * cc - dd) > 10.0_c_double * epsilon(cc))) stop 45 329 330 !$omp target data map(to:ee) map(from:ff) use_device_addr(ee,ff) 331 if (.not.present(ee) .or. .not.present(ff)) stop 46 332 if (.not.associated(ee) .or. .not.associated(ff)) stop 47 333 if (.not.c_associated(c_loc(ee)) .or. .not.c_associated(c_loc(ff))) stop 48 334 call copy3_array(c_loc(ee), c_loc(ff), N) 335 !$omp end target data 336 if (any(abs(ee - 55.0_c_double) > 10.0_c_double * epsilon(ee))) stop 49 337 if (any(abs(3.0_c_double * ee - ff) > 10.0_c_double * epsilon(ee))) stop 50 338 end subroutine test_dummy_opt_callee_1 339 340 subroutine test_dummy_opt_callee_1_absent(aa, bb, cc, dd, ee, ff, N) 341 ! scalars 342 real(c_double), optional, target :: aa(:), bb(:) 343 real(c_double), optional, target, allocatable :: cc(:), dd(:) 344 real(c_double), optional, pointer :: ee(:), ff(:) 345 346 integer, value :: N 347 348 ! All shall be absent 349 if (present(aa) .or. present(bb)) stop 51 350 if (present(cc) .or. present(dd)) stop 52 351 if (present(ee) .or. present(ff)) stop 53 352 353 !$omp target data map(to:aa) map(from:bb) use_device_addr(aa,bb) 354 if (present(aa) .or. present(bb)) stop 54 355 !$omp end target data 356 357 !$omp target data map(to:cc) map(from:dd) use_device_addr(cc,dd) 358 if (present(cc) .or. present(dd)) stop 55 359 !$omp end target data 360 361 !$omp target data map(to:ee) map(from:ff) use_device_addr(ee,ff) 362 if (present(ee) .or. present(ff)) stop 56 363 !$omp end target data 364 end subroutine test_dummy_opt_callee_1_absent 365 366 ! Save device ptr - and recall pointer 367 subroutine test_dummy_opt_call_2() 368 integer, parameter :: N = 1000 369 370 real(c_double), target :: aa(N), bb(N) 371 real(c_double), target, allocatable :: cc(:), dd(:) 372 real(c_double), pointer :: ee(:), ff(:) 373 374 type(c_ptr) :: c_aptr, c_bptr, c_cptr, c_dptr, c_eptr, c_fptr 375 real(c_double), pointer :: aptr(:), bptr(:), cptr(:), dptr(:), eptr(:), fptr(:) 376 377 allocate(cc(N), dd(N), ee(N), ff(N)) 378 call test_dummy_opt_callee_2(aa, bb, cc, dd, ee, ff, & 379 c_aptr, c_bptr, c_cptr, c_dptr, c_eptr, c_fptr, & 380 aptr, bptr, cptr, dptr, eptr, fptr, & 381 N) 382 deallocate(ee, ff) 383 end subroutine test_dummy_opt_call_2 384 385 subroutine test_dummy_opt_callee_2(aa, bb, cc, dd, ee, ff, & 386 c_aptr, c_bptr, c_cptr, c_dptr, c_eptr, c_fptr, & 387 aptr, bptr, cptr, dptr, eptr, fptr, & 388 N) 389 ! scalars 390 real(c_double), optional, target :: aa(:), bb(:) 391 real(c_double), optional, target, allocatable :: cc(:), dd(:) 392 real(c_double), optional, pointer :: ee(:), ff(:) 393 394 type(c_ptr) :: c_aptr, c_bptr, c_cptr, c_dptr, c_eptr, c_fptr 395 real(c_double), optional, pointer :: aptr(:), bptr(:), cptr(:), dptr(:), eptr(:), fptr(:) 396 397 integer, value :: N 398 399 real(c_double) :: dummy 400 401 ! All shall be present - and pointing to non-NULL 402 if (.not.present(aa) .or. .not.present(bb)) stop 57 403 if (.not.present(cc) .or. .not.present(dd)) stop 58 404 if (.not.present(ee) .or. .not.present(ff)) stop 59 405 406 if (.not.allocated(cc) .or. .not.allocated(dd)) stop 60 407 if (.not.associated(ee) .or. .not.associated(ff)) stop 61 408 409 aa = 111.0_c_double 410 bb = 222.0_c_double 411 cc = 333.0_c_double 412 dd = 444.0_c_double 413 ee = 555.0_c_double 414 ff = 666.0_c_double 415 416 !$omp target data map(to:aa) map(from:bb) 417 !$omp target data map(alloc:dummy) use_device_addr(aa,bb) 418 if (.not.present(aa) .or. .not.present(bb)) stop 62 419 if (.not.c_associated(c_loc(aa)) .or. .not.c_associated(c_loc(bb))) stop 63 420 c_aptr = c_loc(aa) 421 c_bptr = c_loc(bb) 422 aptr => aa 423 bptr => bb 424 if (.not.c_associated(c_aptr) .or. .not.c_associated(c_bptr)) stop 64 425 if (.not.associated(aptr) .or. .not.associated(bptr)) stop 65 426 !$omp end target data 427 428 if (.not.present(aa) .or. .not.present(bb)) stop 66 429 if (.not.c_associated(c_loc(aa)) .or. .not.c_associated(c_loc(bb))) stop 67 430 if (.not.c_associated(c_aptr) .or. .not.c_associated(c_bptr)) stop 68 431 if (.not.associated(aptr) .or. .not.associated(bptr)) stop 69 432 433 ! check c_loc ptr once 434 call copy3_array(c_aptr, c_bptr, N) 435 !$omp target update from(bb) 436 if (any(abs(aa - 111.0_c_double) > 10.0_c_double * epsilon(aa))) stop 70 437 if (any(abs(3.0_c_double * aa - bb) > 10.0_c_double * epsilon(aa))) stop 71 438 439 ! check c_loc ptr again after target-value modification 440 aa = 1111.0_c_double 441 !$omp target update to(aa) 442 call copy3_array(c_aptr, c_bptr, N) 443 !$omp target update from(bb) 444 if (any(abs(aa - 1111.0_c_double) > 10.0_c_double * epsilon(aa))) stop 72 445 if (any(abs(3.0_c_double * aa - bb) > 10.0_c_double * epsilon(aa))) stop 73 446 447 ! check Fortran pointer after target-value modification 448 aa = 11111.0_c_double 449 !$omp target update to(aa) 450 call copy3_array(c_loc(aptr), c_loc(bptr), N) 451 !$omp target update from(bb) 452 if (any(abs(aa - 11111.0_c_double) > 10.0_c_double * epsilon(aa))) stop 74 453 if (any(abs(3.0_c_double * aa - bb) > 10.0_c_double * epsilon(aa))) stop 75 454 !$omp end target data 455 456 if (any(abs(aa - 11111.0_c_double) > 10.0_c_double * epsilon(aa))) stop 76 457 if (any(abs(3.0_c_double * aa - bb) > 10.0_c_double * epsilon(aa))) stop 77 458 459 !$omp target data map(to:cc) map(from:dd) 460 !$omp target data map(alloc:dummy) use_device_addr(cc,dd) 461 if (.not.present(cc) .or. .not.present(dd)) stop 78 462 if (.not.allocated(cc) .or. .not.allocated(dd)) stop 79 463 if (.not.c_associated(c_loc(cc)) .or. .not.c_associated(c_loc(dd))) stop 80 464 c_cptr = c_loc(cc) 465 c_dptr = c_loc(dd) 466 cptr => cc 467 dptr => dd 468 if (.not.c_associated(c_cptr) .or. .not.c_associated(c_dptr)) stop 81 469 if (.not.associated(cptr) .or. .not.associated(dptr)) stop 82 470 !$omp end target data 471 if (.not.present(cc) .or. .not.present(dd)) stop 83 472 if (.not.c_associated(c_loc(cc)) .or. .not.c_associated(c_loc(dd))) stop 84 473 if (.not.c_associated(c_cptr) .or. .not.c_associated(c_dptr)) stop 85 474 if (.not.associated(cptr) .or. .not.associated(dptr)) stop 86 475 476 ! check c_loc ptr once 477 call copy3_array(c_cptr, c_dptr, N) 478 !$omp target update from(dd) 479 if (any(abs(cc - 333.0_c_double) > 10.0_c_double * epsilon(cc))) stop 87 480 if (any(abs(3.0_c_double * cc - dd) > 10.0_c_double * epsilon(cc))) stop 88 481 482 ! check c_loc ptr again after target-value modification 483 cc = 3333.0_c_double 484 !$omp target update to(cc) 485 call copy3_array(c_cptr, c_dptr, N) 486 !$omp target update from(dd) 487 if (any(abs(cc - 3333.0_c_double) > 10.0_c_double * epsilon(cc))) stop 89 488 if (any(abs(3.0_c_double * cc - dd) > 10.0_c_double * epsilon(cc))) stop 90 489 490 ! check Fortran pointer after target-value modification 491 cc = 33333.0_c_double 492 !$omp target update to(cc) 493 call copy3_array(c_loc(cptr), c_loc(dptr), N) 494 !$omp target update from(dd) 495 if (any(abs(cc - 33333.0_c_double) > 10.0_c_double * epsilon(cc))) stop 91 496 if (any(abs(3.0_c_double * cc - dd) > 10.0_c_double * epsilon(cc))) stop 92 497 !$omp end target data 498 499 if (any(abs(cc - 33333.0_c_double) > 10.0_c_double * epsilon(dd))) stop 93 500 if (any(abs(3.0_c_double * cc - dd) > 10.0_c_double * epsilon(dd))) stop 94 501 502 503 !$omp target data map(to:ee) map(from:ff) 504 !$omp target data map(alloc:dummy) use_device_addr(ee,ff) 505 if (.not.present(ee) .or. .not.present(ff)) stop 95 506 if (.not.associated(ee) .or. .not.associated(ff)) stop 96 507 if (.not.c_associated(c_loc(ee)) .or. .not.c_associated(c_loc(ff))) stop 97 508 c_eptr = c_loc(ee) 509 c_fptr = c_loc(ff) 510 eptr => ee 511 fptr => ff 512 if (.not.c_associated(c_eptr) .or. .not.c_associated(c_fptr)) stop 98 513 if (.not.associated(eptr) .or. .not.associated(fptr)) stop 99 514 !$omp end target data 515 if (.not.present(ee) .or. .not.present(ff)) stop 100 516 if (.not.associated(ee) .or. .not.associated(ff)) stop 101 517 if (.not.c_associated(c_loc(ee)) .or. .not.c_associated(c_loc(ff))) stop 102 518 if (.not.c_associated(c_eptr) .or. .not.c_associated(c_fptr)) stop 103 519 if (.not.associated(eptr) .or. .not.associated(fptr)) stop 104 520 521 ! check c_loc ptr once 522 call copy3_array(c_eptr, c_fptr, N) 523 !$omp target update from(ff) 524 if (any(abs(ee - 555.0_c_double) > 10.0_c_double * epsilon(ee))) stop 105 525 if (any(abs(3.0_c_double * ee - ff) > 10.0_c_double * epsilon(ee))) stop 106 526 527 ! check c_loc ptr again after target-value modification 528 ee = 5555.0_c_double 529 !$omp target update to(ee) 530 call copy3_array(c_eptr, c_fptr, N) 531 !$omp target update from(ff) 532 if (any(abs(ee - 5555.0_c_double) > 10.0_c_double * epsilon(ee))) stop 107 533 if (any(abs(3.0_c_double * ee - ff) > 10.0_c_double * epsilon(ee))) stop 108 534 535 ! check Fortran pointer after target-value modification 536 ee = 55555.0_c_double 537 !$omp target update to(ee) 538 call copy3_array(c_loc(eptr), c_loc(fptr), N) 539 !$omp target update from(ff) 540 if (any(abs(ee - 55555.0_c_double) > 10.0_c_double * epsilon(ee))) stop 109 541 if (any(abs(3.0_c_double * ee - ff) > 10.0_c_double * epsilon(ff))) stop 110 542 !$omp end target data 543 544 if (any(abs(ee - 55555.0_c_double) > 10.0_c_double * epsilon(ee))) stop 111 545 if (any(abs(3.0_c_double * ee - ff) > 10.0_c_double * epsilon(ee))) stop 112 546 end subroutine test_dummy_opt_callee_2 547end module test_dummies_opt 548 549 550 551! Test nullptr 552module test_nullptr 553 use iso_c_binding 554 implicit none (type, external) 555 private 556 public :: test_nullptr_1 557contains 558 subroutine test_nullptr_1() 559 real(c_double), pointer :: aa(:), bb(:) 560 real(c_double), pointer :: ee(:), ff(:) 561 562 real(c_double), allocatable, target :: gg(:), hh(:) 563 564 type(c_ptr) :: c_aptr, c_bptr, c_eptr, c_fptr, c_gptr, c_hptr 565 real(c_double), pointer :: aptr(:), bptr(:), eptr(:), fptr(:), gptr(:), hptr(:) 566 567 aa => null() 568 bb => null() 569 ee => null() 570 ff => null() 571 572 if (associated(aa) .or. associated(bb)) stop 113 573 !$omp target data map(to:aa) map(from:bb) use_device_addr(aa,bb) 574 if (c_associated(c_loc(aa)) .or. c_associated(c_loc(bb))) stop 114 575 c_aptr = c_loc(aa) 576 c_bptr = c_loc(bb) 577 aptr => aa 578 bptr => bb 579 if (c_associated(c_aptr) .or. c_associated(c_bptr)) stop 115 580 if (associated(aptr) .or. associated(bptr, bb)) stop 116 581 if (associated(aa) .or. associated(bb)) stop 117 582 !$omp end target data 583 if (c_associated(c_aptr) .or. c_associated(c_bptr)) stop 118 584 if (associated(aptr) .or. associated(bptr, bb)) stop 119 585 if (associated(aa) .or. associated(bb)) stop 120 586 587 if (allocated(gg)) stop 121 588 !$omp target data map(tofrom:gg) use_device_addr(gg) 589 if (c_associated(c_loc(gg))) stop 122 590 c_gptr = c_loc(gg) 591 gptr => gg 592 if (c_associated(c_gptr)) stop 123 593 if (associated(gptr)) stop 124 594 if (allocated(gg)) stop 125 595 !$omp end target data 596 if (c_associated(c_gptr)) stop 126 597 if (associated(gptr)) stop 127 598 if (allocated(gg)) stop 128 599 600 call test_dummy_opt_nullptr_callee_1(ee, ff, hh, c_eptr, c_fptr, c_hptr, eptr, fptr, hptr) 601 end subroutine test_nullptr_1 602 603 subroutine test_dummy_opt_nullptr_callee_1(ee, ff, hh, c_eptr, c_fptr, c_hptr, eptr, fptr, hptr) 604 ! scalars 605 real(c_double), optional, pointer :: ee(:), ff(:) 606 real(c_double), optional, allocatable, target :: hh(:) 607 608 type(c_ptr), optional :: c_eptr, c_fptr, c_hptr 609 real(c_double), optional, pointer :: eptr(:), fptr(:), hptr(:) 610 611 if (.not.present(ee) .or. .not.present(ff)) stop 129 612 if (associated(ee) .or. associated(ff)) stop 130 613 614 !$omp target data map(to:ee) map(from:ff) use_device_addr(ee,ff) 615 if (.not.present(ee) .or. .not.present(ff)) stop 131 616 if (associated(ee) .or. associated(ff)) stop 132 617 if (c_associated(c_loc(ee)) .or. c_associated(c_loc(ff))) stop 133 618 c_eptr = c_loc(ee) 619 c_fptr = c_loc(ff) 620 eptr => ee 621 fptr => ff 622 if (c_associated(c_eptr) .or. c_associated(c_fptr)) stop 134 623 if (associated(eptr) .or. associated(fptr)) stop 135 624 !$omp end target data 625 626 if (c_associated(c_eptr) .or. c_associated(c_fptr)) stop 136 627 if (associated(eptr) .or. associated(fptr)) stop 137 628 629 if (allocated(hh)) stop 138 630 !$omp target data map(tofrom:hh) use_device_addr(hh) 631 if (c_associated(c_loc(hh))) stop 139 632 c_hptr = c_loc(hh) 633 hptr => hh 634 if (c_associated(c_hptr)) stop 140 635 if (associated(hptr)) stop 141 636 if (allocated(hh)) stop 142 637 !$omp end target data 638 if (c_associated(c_hptr)) stop 143 639 if (associated(hptr)) stop 144 640 if (allocated(hh)) stop 145 641 end subroutine test_dummy_opt_nullptr_callee_1 642end module test_nullptr 643 644 645 646! Test local variables 647module tests 648 use iso_c_binding 649 use target_procs 650 implicit none (type, external) 651 private 652 public :: test_main_1, test_main_2 653contains 654 ! map + use_device_addr + c_loc 655 subroutine test_main_1() 656 integer, parameter :: N = 1000 657 658 real(c_double), target, allocatable :: cc(:), dd(:) 659 real(c_double), pointer :: ee(:), ff(:) 660 661 allocate(cc(N), dd(N), ee(N), ff(N)) 662 663 cc = 33.0_c_double 664 dd = 44.0_c_double 665 ee = 55.0_c_double 666 ff = 66.0_c_double 667 668 !$omp target data map(to:cc) map(from:dd) use_device_addr(cc,dd) 669 call copy3_array(c_loc(cc), c_loc(dd), N) 670 !$omp end target data 671 if (any(abs(cc - 33.0_c_double) > 10.0_c_double * epsilon(cc))) stop 146 672 if (any(abs(3.0_c_double * cc - dd) > 10.0_c_double * epsilon(cc))) stop 147 673 674 !$omp target data map(to:ee) map(from:ff) use_device_addr(ee,ff) 675 call copy3_array(c_loc(ee), c_loc(ff), N) 676 !$omp end target data 677 if (any(abs(ee - 55.0_c_double) > 10.0_c_double * epsilon(ee))) stop 148 678 if (any(abs(3.0_c_double * ee - ff) > 10.0_c_double * epsilon(ee))) stop 149 679 680 deallocate(ee, ff) ! pointers, only 681 end subroutine test_main_1 682 683 ! Save device ptr - and recall pointer 684 subroutine test_main_2 685 integer, parameter :: N = 1000 686 687 real(c_double), target, allocatable :: cc(:), dd(:) 688 real(c_double), pointer :: ee(:), ff(:) 689 690 real(c_double) :: dummy 691 type(c_ptr) :: c_cptr, c_dptr, c_eptr, c_fptr 692 real(c_double), pointer :: cptr(:), dptr(:), eptr(:), fptr(:) 693 694 allocate(cc(N), dd(N), ee(N), ff(N)) 695 696 cc = 333.0_c_double 697 dd = 444.0_c_double 698 ee = 555.0_c_double 699 ff = 666.0_c_double 700 701 !$omp target data map(to:cc) map(from:dd) 702 !$omp target data map(alloc:dummy) use_device_addr(cc,dd) 703 c_cptr = c_loc(cc) 704 c_dptr = c_loc(dd) 705 cptr => cc 706 dptr => dd 707 !$omp end target data 708 709 ! check c_loc ptr once 710 call copy3_array(c_cptr, c_dptr, N) 711 !$omp target update from(dd) 712 if (any(abs(cc - 333.0_c_double) > 10.0_c_double * epsilon(cc))) stop 150 713 if (any(abs(3.0_c_double * cc - dd) > 10.0_c_double * epsilon(cc))) stop 151 714 715 ! check c_loc ptr again after target-value modification 716 cc = 3333.0_c_double 717 !$omp target update to(cc) 718 call copy3_array(c_cptr, c_dptr, N) 719 !$omp target update from(dd) 720 if (any(abs(cc - 3333.0_c_double) > 10.0_c_double * epsilon(cc))) stop 152 721 if (any(abs(3.0_c_double * cc - dd) > 10.0_c_double * epsilon(cc))) stop 153 722 723 ! check Fortran pointer after target-value modification 724 cc = 33333.0_c_double 725 !$omp target update to(cc) 726 call copy3_array(c_loc(cptr), c_loc(dptr), N) 727 !$omp target update from(dd) 728 if (any(abs(cc - 33333.0_c_double) > 10.0_c_double * epsilon(cc))) stop 154 729 if (any(abs(3.0_c_double * cc - dd) > 10.0_c_double * epsilon(cc))) stop 155 730 !$omp end target data 731 732 if (any(abs(cc - 33333.0_c_double) > 10.0_c_double * epsilon(dd))) stop 156 733 if (any(abs(3.0_c_double * cc - dd) > 10.0_c_double * epsilon(dd))) stop 157 734 735 736 !$omp target data map(to:ee) map(from:ff) 737 !$omp target data map(alloc:dummy) use_device_addr(ee,ff) 738 c_eptr = c_loc(ee) 739 c_fptr = c_loc(ff) 740 eptr => ee 741 fptr => ff 742 !$omp end target data 743 744 ! check c_loc ptr once 745 call copy3_array(c_eptr, c_fptr, N) 746 !$omp target update from(ff) 747 if (any(abs(ee - 555.0_c_double) > 10.0_c_double * epsilon(ee))) stop 158 748 if (any(abs(3.0_c_double * ee - ff) > 10.0_c_double * epsilon(ee))) stop 159 749 750 ! check c_loc ptr again after target-value modification 751 ee = 5555.0_c_double 752 !$omp target update to(ee) 753 call copy3_array(c_eptr, c_fptr, N) 754 !$omp target update from(ff) 755 if (any(abs(ee - 5555.0_c_double) > 10.0_c_double * epsilon(ee))) stop 160 756 if (any(abs(3.0_c_double * ee - ff) > 10.0_c_double * epsilon(ee))) stop 161 757 758 ! check Fortran pointer after target-value modification 759 ee = 55555.0_c_double 760 !$omp target update to(ee) 761 call copy3_array(c_loc(eptr), c_loc(fptr), N) 762 !$omp target update from(ff) 763 if (any(abs(ee - 55555.0_c_double) > 10.0_c_double * epsilon(ee))) stop 162 764 if (any(abs(3.0_c_double * ee - ff) > 10.0_c_double * epsilon(ff))) stop 163 765 !$omp end target data 766 767 if (any(abs(ee - 55555.0_c_double) > 10.0_c_double * epsilon(ee))) stop 164 768 if (any(abs(3.0_c_double * ee - ff) > 10.0_c_double * epsilon(ee))) stop 165 769 770 deallocate(ee, ff) 771 end subroutine test_main_2 772end module tests 773 774 775program omp_device_addr 776 use tests 777 use test_dummies 778 use test_dummies_opt 779 use test_nullptr 780 implicit none (type, external) 781 782 call test_main_1() 783 call test_main_2() 784 785 call test_dummy_call_1() 786 call test_dummy_call_2() 787 788 call test_dummy_opt_call_1() 789 call test_dummy_opt_call_2() 790 791 call test_nullptr_1() 792end program omp_device_addr 793