1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
|
! PR 101309
! { dg-do run }
! { dg-additional-sources "fc-descriptor-7-c.c dump-descriptors.c" }
! { dg-additional-options "-g" }
!
! This program tests passing arrays that may not be contiguous through
! descriptors to C functions as assumed-shape arguments.
program testit
use iso_c_binding
implicit none (type, external)
interface
subroutine ctest (a, is_cont) bind (c)
use iso_c_binding
integer(C_INT) :: a(:,:)
logical(C_Bool), value :: is_cont
end subroutine
subroutine ctest_cont (a, is_cont) bind (c, name="ctest")
use iso_c_binding
integer(C_INT), contiguous :: a(:,:)
logical(C_Bool), value :: is_cont
end subroutine
subroutine ctest_ar (a, is_cont) bind (c, name="ctest")
use iso_c_binding
integer(C_INT) :: a(..)
logical(C_Bool), value :: is_cont
end subroutine
subroutine ctest_ar_cont (a, is_cont) bind (c, name="ctest")
use iso_c_binding
integer(C_INT), contiguous :: a(..)
logical(C_Bool), value :: is_cont
end subroutine
end interface
integer :: i , j
integer(C_INT), target :: aa(10,5)
integer(C_INT), target :: bb(10,10)
! Original array
do j = 1, 5
do i = 1, 10
aa(i,j) = i + 100*j
end do
end do
! Transposed array
do j = 2, 10, 2
do i = 1, 10
bb(j, i) = i + 100*((j-2)/2 + 1)
end do
end do
if (any (transpose (aa) /= bb(2:10:2, :))) error stop 1
! Test both calling the C function directly, and via another function
! that takes an assumed-shape/assumed-rank argument.
call ftest (transpose (aa), is_cont=.true._c_bool) ! Implementation choice: copy in; hence, contiguous
if (any (transpose (aa) /= bb(2:10:2, :))) error stop 1
call ctest (transpose (aa), is_cont=.false._c_bool) ! Implementation choice: noncontigous / sm inversed
if (any (transpose (aa) /= bb(2:10:2, :))) error stop 1
call ctest_cont (transpose (aa), is_cont=.true._c_bool)
if (any (transpose (aa) /= bb(2:10:2, :))) error stop 1
call ctest_ar (transpose (aa), is_cont=.false._c_bool) ! Implementation choice: noncontigous / sm inversed
if (any (transpose (aa) /= bb(2:10:2, :))) error stop 1
call ctest_ar_cont (transpose (aa), is_cont=.true._c_bool)
if (any (transpose (aa) /= bb(2:10:2, :))) error stop 1
call ftest (bb(2:10:2, :), is_cont=.false._c_bool)
if (any (transpose (aa) /= bb(2:10:2, :))) error stop 1
call ctest (bb(2:10:2, :), is_cont=.false._c_bool)
if (any (transpose (aa) /= bb(2:10:2, :))) error stop 1
call ctest_cont (bb(2:10:2, :), is_cont=.true._c_bool)
if (any (transpose (aa) /= bb(2:10:2, :))) error stop 1
call ctest_ar (bb(2:10:2, :), is_cont=.false._c_bool)
if (any (transpose (aa) /= bb(2:10:2, :))) error stop 1
call ctest_ar_cont (bb(2:10:2, :), is_cont=.true._c_bool)
if (any (transpose (aa) /= bb(2:10:2, :))) error stop 1
contains
subroutine ftest (a, is_cont)
use iso_c_binding
integer(C_INT) :: a(:,:)
logical(c_bool), value, intent(in) :: is_cont
if (is_cont .NEQV. is_contiguous (a)) error stop 2
if (any (shape (a) /= [5, 10])) error stop 3
do j = 1, 5
do i = 1, 10
if (a(j, i) /= i + 100*j) error stop 4
if (a(j, i) /= aa(i,j)) error stop
end do
end do
call ctest (a, is_cont)
call ctest_cont (a, is_cont=.true._c_bool)
call ctest_ar (a, is_cont)
call ctest_ar_cont (a, is_cont=.true._c_bool)
end subroutine
subroutine ftest_ar (a, is_cont)
use iso_c_binding
integer(C_INT) :: a(..)
logical(c_bool), value, intent(in) :: is_cont
if (is_cont .NEQV. is_contiguous (a)) error stop 2
if (any (shape (a) /= [5, 10])) error stop 3
select rank (a)
rank(2)
do j = 1, 5
do i = 1, 10
if (a(j, i) /= i + 100*j) error stop 4
if (a(j, i) /= aa(i,j)) error stop
end do
end do
call ctest (a, is_cont)
call ctest_cont (a, is_cont=.true._c_bool)
call ftest_ar_con (a, is_cont=.true._c_bool)
end select
call ctest_ar (a, is_cont)
! call ctest_ar_cont (a, is_cont=.true._c_bool) ! TODO/FIXME: ICE, cf. PR fortran/102729
! call ftest_ar_con (a, is_cont=.true._c_bool) ! TODO/FIXME: ICE, cf. PR fortran/102729
end subroutine
subroutine ftest_ar_con (a, is_cont)
use iso_c_binding
integer(C_INT), contiguous :: a(..)
logical(c_bool), value, intent(in) :: is_cont
if (is_cont .NEQV. is_contiguous (a)) error stop 2
if (any (shape (a) /= [5, 10])) error stop 3
select rank (a)
rank(2)
do j = 1, 5
do i = 1, 10
if (a(j, i) /= i + 100*j) error stop 4
if (a(j, i) /= aa(i,j)) error stop
end do
end do
call ctest (a, is_cont)
call ctest_cont (a, is_cont=.true._c_bool)
end select
call ctest_ar (a, is_cont)
call ctest_ar_cont (a, is_cont=.true._c_bool)
end subroutine
end program
|
