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