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
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
|
! { dg-do run }
!
! PR fortran/90608
! Check the correct behaviour of the inline minloc implementation,
! when the dim argument is present.
program p
implicit none
integer, parameter :: data60(*) = (/ 7, 4, 5, 3, 9, 0, 6, 4, 5, 5, &
8, 2, 6, 7, 8, 7, 4, 5, 3, 9, &
0, 6, 4, 5, 5, 8, 2, 6, 7, 8, &
7, 4, 5, 3, 9, 0, 6, 4, 5, 5, &
8, 2, 6, 7, 8, 7, 4, 5, 3, 9, &
0, 6, 4, 5, 5, 8, 2, 6, 7, 8 /)
integer, parameter :: data1(*) = (/ 2, 3, 2, 3, &
1, 2, 3, 2, &
3, 1, 2, 3, &
2, 3, 1, 2, &
3, 2, 3, 1 /)
integer, parameter :: data2(*) = (/ 2, 1, 2, &
3, 2, 3, &
4, 3, 4, &
2, 1, 2, &
1, 2, 1 /)
integer, parameter :: data3(*) = (/ 5, 1, 5, &
1, 2, 1, &
2, 1, 2, &
3, 2, 3 /)
call check_int_const_shape_rank_3
call check_int_const_shape_empty_4
call check_int_alloc_rank_3
call check_int_alloc_empty_4
call check_real_const_shape_rank_3
call check_real_const_shape_empty_4
call check_real_alloc_rank_3
call check_real_alloc_empty_4
call check_lower_bounds
call check_dependencies
contains
subroutine check_int_const_shape_rank_3()
integer :: a(3,4,5)
integer, allocatable :: r(:,:)
a = reshape(data60, shape(a))
r = minloc(a, dim=1)
if (any(shape(r) /= (/ 4, 5 /))) error stop 11
if (any(r /= reshape(data1, (/ 4, 5 /)))) error stop 12
r = minloc(a, dim=2)
if (any(shape(r) /= (/ 3, 5 /))) error stop 13
if (any(r /= reshape(data2, (/ 3, 5 /)))) error stop 14
r = minloc(a, dim=3)
if (any(shape(r) /= (/ 3, 4 /))) error stop 15
if (any(r /= reshape(data3, (/ 3, 4 /)))) error stop 16
end subroutine
subroutine check_int_const_shape_empty_4()
integer :: a(9,3,0,7)
integer, allocatable :: r(:,:,:)
a = reshape((/ integer:: /), shape(a))
r = minloc(a, dim=1)
if (any(shape(r) /= (/ 3, 0, 7 /))) error stop 21
r = minloc(a, dim=2)
if (any(shape(r) /= (/ 9, 0, 7 /))) error stop 22
r = minloc(a, dim=3)
if (any(shape(r) /= (/ 9, 3, 7 /))) error stop 23
if (any(r /= 0)) error stop 24
r = minloc(a, dim=4)
if (any(shape(r) /= (/ 9, 3, 0 /))) error stop 25
end subroutine
subroutine check_int_alloc_rank_3()
integer, allocatable :: a(:,:,:)
integer, allocatable :: r(:,:)
allocate(a(3,4,5))
a(:,:,:) = reshape(data60, shape(a))
r = minloc(a, dim=1)
if (any(shape(r) /= (/ 4, 5 /))) error stop 31
if (any(r /= reshape(data1, (/ 4, 5 /)))) error stop 32
r = minloc(a, dim=2)
if (any(shape(r) /= (/ 3, 5 /))) error stop 33
if (any(r /= reshape(data2, (/ 3, 5 /)))) error stop 34
r = minloc(a, dim=3)
if (any(shape(r) /= (/ 3, 4 /))) error stop 35
if (any(r /= reshape(data3, (/ 3, 4 /)))) error stop 36
end subroutine
subroutine check_int_alloc_empty_4()
integer, allocatable :: a(:,:,:,:)
integer, allocatable :: r(:,:,:)
allocate(a(9,3,0,7))
a(:,:,:,:) = reshape((/ integer:: /), shape(a))
r = minloc(a, dim=1)
if (any(shape(r) /= (/ 3, 0, 7 /))) error stop 41
r = minloc(a, dim=2)
if (any(shape(r) /= (/ 9, 0, 7 /))) error stop 42
r = minloc(a, dim=3)
if (any(shape(r) /= (/ 9, 3, 7 /))) error stop 43
if (any(r /= 0)) error stop 44
r = minloc(a, dim=4)
if (any(shape(r) /= (/ 9, 3, 0 /))) error stop 45
end subroutine
subroutine check_real_const_shape_rank_3()
real :: a(3,4,5)
integer, allocatable :: r(:,:)
a = reshape((/ real:: data60 /), shape(a))
r = minloc(a, dim=1)
if (any(shape(r) /= (/ 4, 5 /))) error stop 51
if (any(r /= reshape((/ real:: data1 /), (/ 4, 5 /)))) error stop 52
r = minloc(a, dim=2)
if (any(shape(r) /= (/ 3, 5 /))) error stop 53
if (any(r /= reshape((/ real:: data2 /), (/ 3, 5 /)))) error stop 54
r = minloc(a, dim=3)
if (any(shape(r) /= (/ 3, 4 /))) error stop 55
if (any(r /= reshape((/ real:: data3 /), (/ 3, 4 /)))) error stop 56
end subroutine
subroutine check_real_const_shape_empty_4()
real :: a(9,3,0,7)
integer, allocatable :: r(:,:,:)
a = reshape((/ real:: /), shape(a))
r = minloc(a, dim=1)
if (any(shape(r) /= (/ 3, 0, 7 /))) error stop 61
r = minloc(a, dim=2)
if (any(shape(r) /= (/ 9, 0, 7 /))) error stop 62
r = minloc(a, dim=3)
if (any(shape(r) /= (/ 9, 3, 7 /))) error stop 63
if (any(r /= 0)) error stop 64
r = minloc(a, dim=4)
if (any(shape(r) /= (/ 9, 3, 0 /))) error stop 65
end subroutine
subroutine check_real_alloc_rank_3()
real, allocatable :: a(:,:,:)
integer, allocatable :: r(:,:)
allocate(a(3,4,5))
a(:,:,:) = reshape((/ real:: data60 /), shape(a))
r = minloc(a, dim=1)
if (any(shape(r) /= (/ 4, 5 /))) error stop 71
if (any(r /= reshape((/ real:: data1 /), shape=(/ 4, 5 /)))) error stop 72
r = minloc(a, dim=2)
if (any(shape(r) /= (/ 3, 5 /))) error stop 73
if (any(r /= reshape((/ real:: data2 /), shape=(/ 3, 5 /)))) error stop 74
r = minloc(a, dim=3)
if (any(shape(r) /= (/ 3, 4 /))) error stop 75
if (any(r /= reshape((/ real:: data3 /), shape=(/ 3, 4 /)))) error stop 76
end subroutine
subroutine check_real_alloc_empty_4()
real, allocatable :: a(:,:,:,:)
integer, allocatable :: r(:,:,:)
allocate(a(9,3,0,7))
a(:,:,:,:) = reshape((/ real:: /), shape(a))
r = minloc(a, dim=1)
if (any(shape(r) /= (/ 3, 0, 7 /))) error stop 81
r = minloc(a, dim=2)
if (any(shape(r) /= (/ 9, 0, 7 /))) error stop 82
r = minloc(a, dim=3)
if (any(shape(r) /= (/ 9, 3, 7 /))) error stop 83
if (any(r /= 0)) error stop 84
r = minloc(a, dim=4)
if (any(shape(r) /= (/ 9, 3, 0 /))) error stop 85
end subroutine
subroutine check_lower_bounds()
real, allocatable :: a(:,:,:)
integer, allocatable :: r(:,:)
allocate(a(3:5,-1:2,5))
a(:,:,:) = reshape((/ real:: data60 /), shape(a))
r = minloc(a, dim=1)
if (any(shape(r) /= (/ 4, 5 /))) error stop 91
if (any(lbound(r) /= 1)) error stop 92
if (any(ubound(r) /= (/ 4, 5 /))) error stop 93
r = minloc(a, dim=2)
if (any(shape(r) /= (/ 3, 5 /))) error stop 94
if (any(lbound(r) /= 1)) error stop 95
if (any(ubound(r) /= (/ 3, 5 /))) error stop 96
r = minloc(a, dim=3)
if (any(shape(r) /= (/ 3, 4 /))) error stop 97
if (any(lbound(r) /= 1)) error stop 98
if (any(ubound(r) /= (/ 3, 4 /))) error stop 99
end subroutine
elemental subroutine set(o, i)
integer, intent(out) :: o
integer, intent(in) :: i
o = i
end subroutine
subroutine check_dependencies()
integer, allocatable :: a(:,:,:)
allocate(a(3,4,5))
a(:,:,:) = reshape(data60, shape(a))
a(1,:,:) = minloc(a, dim=1)
if (any(a(1,:,:) /= reshape(data1, (/ 4, 5 /)))) error stop 111
a(:,:,:) = reshape(data60, shape(a))
a(:,2,:) = minloc(a, dim=2)
if (any(a(:,2,:) /= reshape(data2, (/ 3, 5 /)))) error stop 112
a(:,:,:) = reshape(data60, shape(a))
a(:,:,5) = minloc(a, dim=3)
if (any(a(:,:,5) /= reshape(data3, (/ 3, 4 /)))) error stop 113
a(:,:,:) = reshape(data60, shape(a))
call set(a(1,:,:), minloc(a, dim=1))
if (any(a(1,:,:) /= reshape(data1, (/ 4, 5 /)))) error stop 114
a(:,:,:) = reshape(data60, shape(a))
call set(a(:,2,:), minloc(a, dim=2))
if (any(a(:,2,:) /= reshape(data2, (/ 3, 5 /)))) error stop 115
a(:,:,:) = reshape(data60, shape(a))
call set(a(:,:,5), minloc(a, dim=3))
if (any(a(:,:,5) /= reshape(data3, (/ 3, 4 /)))) error stop 116
end subroutine check_dependencies
end program p
|
