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-3.f90 by using a 4-byte variable (c_float)
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_float) :: from_ptr(:)
28    real(c_float) :: 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_float), 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_float), 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_float), target :: aa(N), bb(N)
75     real(c_float), target, allocatable :: cc(:), dd(:)
76     real(c_float), pointer :: ee(:), ff(:)
77
78     allocate(cc(N), dd(N), ee(N), ff(N))
79
80     aa = 11.0_c_float
81     bb = 22.0_c_float
82     cc = 33.0_c_float
83     dd = 44.0_c_float
84     ee = 55.0_c_float
85     ff = 66.0_c_float
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_float), target :: aa(:), bb(:)
93     real(c_float), target, allocatable :: cc(:), dd(:)
94     real(c_float), 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_float) > 10.0_c_float * epsilon(aa))) stop 2
102     if (any(abs(3.0_c_float * aa - bb) > 10.0_c_float * 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_float) > 10.0_c_float * epsilon(cc))) stop 4
108     if (any(abs(3.0_c_float * cc - dd) > 10.0_c_float * 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_float) > 10.0_c_float * epsilon(ee))) stop 6
114     if (any(abs(3.0_c_float * ee - ff) > 10.0_c_float * 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_float), target :: aa(N), bb(N)
122     real(c_float), target, allocatable :: cc(:), dd(:)
123     real(c_float), pointer :: ee(:), ff(:)
124
125     type(c_ptr) :: c_aptr, c_bptr, c_cptr, c_dptr, c_eptr, c_fptr
126     real(c_float), 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_float), target :: aa(:), bb(:)
142     real(c_float), target, allocatable :: cc(:), dd(:)
143     real(c_float), pointer :: ee(:), ff(:)
144
145     type(c_ptr) :: c_aptr, c_bptr, c_cptr, c_dptr, c_eptr, c_fptr
146     real(c_float), pointer :: aptr(:), bptr(:), cptr(:), dptr(:), eptr(:), fptr(:)
147
148     integer, value :: N
149
150     real(c_float) :: dummy
151
152     aa = 111.0_c_float
153     bb = 222.0_c_float
154     cc = 333.0_c_float
155     dd = 444.0_c_float
156     ee = 555.0_c_float
157     ff = 666.0_c_float
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_float) > 10.0_c_float * epsilon(aa))) stop 8
171     if (any(abs(3.0_c_float * aa - bb) > 10.0_c_float * epsilon(aa))) stop 9
172
173     ! check c_loc ptr again after target-value modification
174     aa = 1111.0_c_float
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_float) > 10.0_c_float * epsilon(aa))) stop 10
179     if (any(abs(3.0_c_float * aa - bb) > 10.0_c_float * epsilon(aa))) stop 11
180
181     ! check Fortran pointer after target-value modification
182     aa = 11111.0_c_float
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_float) > 10.0_c_float * epsilon(aa))) stop 12
187     if (any(abs(3.0_c_float * aa - bb) > 10.0_c_float * epsilon(aa))) stop 13
188     !$omp end target data
189
190     if (any(abs(aa - 11111.0_c_float) > 10.0_c_float * epsilon(aa))) stop 14
191     if (any(abs(3.0_c_float * aa - bb) > 10.0_c_float * 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_float) > 10.0_c_float * epsilon(cc))) stop 16
206     if (any(abs(3.0_c_float * cc - dd) > 10.0_c_float * epsilon(cc))) stop 17
207
208     ! check c_loc ptr again after target-value modification
209     cc = 3333.0_c_float
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_float) > 10.0_c_float * epsilon(cc))) stop 18
214     if (any(abs(3.0_c_float * cc - dd) > 10.0_c_float * epsilon(cc))) stop 19
215
216     ! check Fortran pointer after target-value modification
217     cc = 33333.0_c_float
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_float) > 10.0_c_float * epsilon(cc))) stop 20
222     if (any(abs(3.0_c_float * cc - dd) > 10.0_c_float * epsilon(cc))) stop 21
223     !$omp end target data
224
225     if (any(abs(cc - 33333.0_c_float) > 10.0_c_float * epsilon(dd))) stop 22
226     if (any(abs(3.0_c_float * cc - dd) > 10.0_c_float * 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_float) > 10.0_c_float * epsilon(ee))) stop 24
241     if (any(abs(3.0_c_float * ee - ff) > 10.0_c_float * epsilon(ee))) stop 25
242
243     ! check c_loc ptr again after target-value modification
244     ee = 5555.0_c_float
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_float) > 10.0_c_float * epsilon(ee))) stop 26
249     if (any(abs(3.0_c_float * ee - ff) > 10.0_c_float * epsilon(ee))) stop 27
250
251     ! check Fortran pointer after target-value modification
252     ee = 55555.0_c_float
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_float) > 10.0_c_float * epsilon(ee))) stop 28
257     if (any(abs(3.0_c_float * ee - ff) > 10.0_c_float * epsilon(ff))) stop 29
258     !$omp end target data
259
260     if (any(abs(ee - 55555.0_c_float) > 10.0_c_float * epsilon(ee))) stop 30
261     if (any(abs(3.0_c_float * ee - ff) > 10.0_c_float * 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_float), target :: aa(N), bb(N)
280     real(c_float), target, allocatable :: cc(:), dd(:)
281     real(c_float), pointer :: ee(:), ff(:)
282
283     allocate(cc(N), dd(N), ee(N), ff(N))
284
285     aa = 11.0_c_float
286     bb = 22.0_c_float
287     cc = 33.0_c_float
288     dd = 44.0_c_float
289     ee = 55.0_c_float
290     ff = 66.0_c_float
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_float), optional, target :: aa(:), bb(:)
300     real(c_float), optional, target, allocatable :: cc(:), dd(:)
301     real(c_float), 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_float) > 10.0_c_float * epsilon(aa))) stop 39
319     if (any(abs(3.0_c_float * aa - bb) > 10.0_c_float * 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_float) > 10.0_c_float * epsilon(cc))) stop 44
328     if (any(abs(3.0_c_float * cc - dd) > 10.0_c_float * 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_float) > 10.0_c_float * epsilon(ee))) stop 49
337     if (any(abs(3.0_c_float * ee - ff) > 10.0_c_float * 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_float), optional, target :: aa(:), bb(:)
343     real(c_float), optional, target, allocatable :: cc(:), dd(:)
344     real(c_float), 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_float), target :: aa(N), bb(N)
371     real(c_float), target, allocatable :: cc(:), dd(:)
372     real(c_float), pointer :: ee(:), ff(:)
373
374     type(c_ptr) :: c_aptr, c_bptr, c_cptr, c_dptr, c_eptr, c_fptr
375     real(c_float), 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_float), optional, target :: aa(:), bb(:)
391     real(c_float), optional, target, allocatable :: cc(:), dd(:)
392     real(c_float), optional, pointer :: ee(:), ff(:)
393
394     type(c_ptr) :: c_aptr, c_bptr, c_cptr, c_dptr, c_eptr, c_fptr
395     real(c_float), optional, pointer :: aptr(:), bptr(:), cptr(:), dptr(:), eptr(:), fptr(:)
396
397     integer, value :: N
398
399     real(c_float) :: 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_float
410     bb = 222.0_c_float
411     cc = 333.0_c_float
412     dd = 444.0_c_float
413     ee = 555.0_c_float
414     ff = 666.0_c_float
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_float) > 10.0_c_float * epsilon(aa))) stop 70
437     if (any(abs(3.0_c_float * aa - bb) > 10.0_c_float * epsilon(aa))) stop 71
438
439     ! check c_loc ptr again after target-value modification
440     aa = 1111.0_c_float
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_float) > 10.0_c_float * epsilon(aa))) stop 72
445     if (any(abs(3.0_c_float * aa - bb) > 10.0_c_float * epsilon(aa))) stop 73
446
447     ! check Fortran pointer after target-value modification
448     aa = 11111.0_c_float
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_float) > 10.0_c_float * epsilon(aa))) stop 74
453     if (any(abs(3.0_c_float * aa - bb) > 10.0_c_float * epsilon(aa))) stop 75
454     !$omp end target data
455
456     if (any(abs(aa - 11111.0_c_float) > 10.0_c_float * epsilon(aa))) stop 76
457     if (any(abs(3.0_c_float * aa - bb) > 10.0_c_float * 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_float) > 10.0_c_float * epsilon(cc))) stop 87
480     if (any(abs(3.0_c_float * cc - dd) > 10.0_c_float * epsilon(cc))) stop 88
481
482     ! check c_loc ptr again after target-value modification
483     cc = 3333.0_c_float
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_float) > 10.0_c_float * epsilon(cc))) stop 89
488     if (any(abs(3.0_c_float * cc - dd) > 10.0_c_float * epsilon(cc))) stop 90
489
490     ! check Fortran pointer after target-value modification
491     cc = 33333.0_c_float
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_float) > 10.0_c_float * epsilon(cc))) stop 91
496     if (any(abs(3.0_c_float * cc - dd) > 10.0_c_float * epsilon(cc))) stop 92
497     !$omp end target data
498
499     if (any(abs(cc - 33333.0_c_float) > 10.0_c_float * epsilon(dd))) stop 93
500     if (any(abs(3.0_c_float * cc - dd) > 10.0_c_float * 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_float) > 10.0_c_float * epsilon(ee))) stop 105
525     if (any(abs(3.0_c_float * ee - ff) > 10.0_c_float * epsilon(ee))) stop 106
526
527     ! check c_loc ptr again after target-value modification
528     ee = 5555.0_c_float
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_float) > 10.0_c_float * epsilon(ee))) stop 107
533     if (any(abs(3.0_c_float * ee - ff) > 10.0_c_float * epsilon(ee))) stop 108
534
535     ! check Fortran pointer after target-value modification
536     ee = 55555.0_c_float
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_float) > 10.0_c_float * epsilon(ee))) stop 109
541     if (any(abs(3.0_c_float * ee - ff) > 10.0_c_float * epsilon(ff))) stop 110
542     !$omp end target data
543
544     if (any(abs(ee - 55555.0_c_float) > 10.0_c_float * epsilon(ee))) stop 111
545     if (any(abs(3.0_c_float * ee - ff) > 10.0_c_float * 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_float), pointer :: aa(:), bb(:)
560     real(c_float), pointer :: ee(:), ff(:)
561
562     real(c_float), allocatable, target :: gg(:), hh(:)
563
564     type(c_ptr) :: c_aptr, c_bptr, c_eptr, c_fptr, c_gptr, c_hptr
565     real(c_float), 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_float), optional, pointer :: ee(:), ff(:)
606     real(c_float), optional, allocatable, target :: hh(:)
607
608     type(c_ptr), optional :: c_eptr, c_fptr, c_hptr
609     real(c_float), 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_float), target, allocatable :: cc(:), dd(:)
659     real(c_float), pointer :: ee(:), ff(:)
660
661     allocate(cc(N), dd(N), ee(N), ff(N))
662
663     cc = 33.0_c_float
664     dd = 44.0_c_float
665     ee = 55.0_c_float
666     ff = 66.0_c_float
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_float) > 10.0_c_float * epsilon(cc))) stop 146
672     if (any(abs(3.0_c_float * cc - dd) > 10.0_c_float * 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_float) > 10.0_c_float * epsilon(ee))) stop 148
678     if (any(abs(3.0_c_float * ee - ff) > 10.0_c_float * 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_float), target, allocatable :: cc(:), dd(:)
688     real(c_float), pointer :: ee(:), ff(:)
689
690     real(c_float) :: dummy
691     type(c_ptr) :: c_cptr, c_dptr, c_eptr, c_fptr
692     real(c_float), pointer :: cptr(:), dptr(:), eptr(:), fptr(:)
693
694     allocate(cc(N), dd(N), ee(N), ff(N))
695
696     cc = 333.0_c_float
697     dd = 444.0_c_float
698     ee = 555.0_c_float
699     ff = 666.0_c_float
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_float) > 10.0_c_float * epsilon(cc))) stop 150
713     if (any(abs(3.0_c_float * cc - dd) > 10.0_c_float * epsilon(cc))) stop 151
714
715     ! check c_loc ptr again after target-value modification
716     cc = 3333.0_c_float
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_float) > 10.0_c_float * epsilon(cc))) stop 152
721     if (any(abs(3.0_c_float * cc - dd) > 10.0_c_float * epsilon(cc))) stop 153
722
723     ! check Fortran pointer after target-value modification
724     cc = 33333.0_c_float
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_float) > 10.0_c_float * epsilon(cc))) stop 154
729     if (any(abs(3.0_c_float * cc - dd) > 10.0_c_float * epsilon(cc))) stop 155
730     !$omp end target data
731
732     if (any(abs(cc - 33333.0_c_float) > 10.0_c_float * epsilon(dd))) stop 156
733     if (any(abs(3.0_c_float * cc - dd) > 10.0_c_float * 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_float) > 10.0_c_float * epsilon(ee))) stop 158
748     if (any(abs(3.0_c_float * ee - ff) > 10.0_c_float * epsilon(ee))) stop 159
749
750     ! check c_loc ptr again after target-value modification
751     ee = 5555.0_c_float
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_float) > 10.0_c_float * epsilon(ee))) stop 160
756     if (any(abs(3.0_c_float * ee - ff) > 10.0_c_float * epsilon(ee))) stop 161
757
758     ! check Fortran pointer after target-value modification
759     ee = 55555.0_c_float
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_float) > 10.0_c_float * epsilon(ee))) stop 162
764     if (any(abs(3.0_c_float * ee - ff) > 10.0_c_float * epsilon(ff))) stop 163
765     !$omp end target data
766
767     if (any(abs(ee - 55555.0_c_float) > 10.0_c_float * epsilon(ee))) stop 164
768     if (any(abs(3.0_c_float * ee - ff) > 10.0_c_float * 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