1! { dg-do run }
2! { dg-options "-fdump-tree-original -fdump-tree-optimized -Warray-temporaries -fbounds-check" }
3
4  implicit none
5
6  integer :: i, j
7
8  integer, parameter :: nx=3, ny=4
9  integer, parameter, dimension(nx,ny) :: p = &
10    & reshape ((/ (i**2, i=1,size(p)) /), shape(p))
11  integer, parameter, dimension(ny,nx) :: q = &
12    & reshape ((/ (((nx*(i-1)+j)**2, i=1,ny), j=1,nx) /), (/ ny, nx /))
13
14  integer, parameter, dimension(nx,nx) :: r = &
15    & reshape ((/ (i*i, i=1,size(r)) /), shape(r))
16  integer, parameter, dimension(nx,nx) :: s = &
17    & reshape ((/ (((nx*(i-1)+j)**2, i=1,nx), j=1,nx) /), (/ nx, nx /))
18
19
20
21  integer, dimension(nx,ny) :: a, b
22  integer, dimension(ny,nx) :: c
23  integer, dimension(nx,nx) :: e, f, g
24
25  character(144) :: u, v
26
27  a = p
28
29  c = transpose(a)
30  if (any(c /= q)) call abort
31
32  write(u,*) transpose(a)
33  write(v,*) q
34  if (u /= v) call abort
35
36
37  e = r
38  f = s
39
40  g = transpose(e+f)
41  if (any(g /= r + s)) call abort
42
43  write(u,*) transpose(e+f)
44  write(v,*) r + s
45  if (u /= v) call abort
46
47
48  e = transpose(e)      ! { dg-warning "Creating array temporary" }
49  if (any(e /= s)) call abort
50
51  write(u,*) transpose(transpose(e))
52  write(v,*) s
53  if (u /= v) call abort
54
55
56  e = transpose(e+f)     ! { dg-warning "Creating array temporary" }
57  if (any(e /= 2*r)) call abort
58
59  write(u,*) transpose(transpose(e+f))-f
60  write(v,*) 2*r
61  if (u /= v) call abort
62
63
64  a = foo(transpose(c))
65  if (any(a /= p+1)) call abort
66
67  write(u,*) foo(transpose(c))    ! { dg-warning "Creating array temporary" }
68  write(v,*) p+1
69  if (u /= v) call abort
70
71
72  c = transpose(foo(a))      ! Unnecessary { dg-warning "Creating array temporary" }
73  if (any(c /= q+2)) call abort
74
75  write(u,*) transpose(foo(a))     ! { dg-warning "Creating array temporary" }
76  write(v,*) q+2
77  if (u /= v) call abort
78
79
80  e = foo(transpose(e))     ! { dg-warning "Creating array temporary" }
81  if (any(e /= 2*s+1)) call abort
82
83  write(u,*) transpose(foo(transpose(e))-1)     ! { dg-warning "Creating array temporary" }
84  write(v,*) 2*s+1
85  if (u /= v) call abort
86
87
88  e = transpose(foo(e))     ! { dg-warning "Creating array temporary" }
89  if (any(e /= 2*r+2)) call abort
90
91  write(u,*) transpose(foo(transpose(e)-1))     ! 2 temps { dg-warning "Creating array temporary" }
92  write(v,*) 2*r+2
93  if (u /= v) call abort
94
95
96  a = bar(transpose(c))
97  if (any(a /= p+4)) call abort
98
99  write(u,*) bar(transpose(c))
100  write(v,*) p+4
101  if (u /= v) call abort
102
103
104  c = transpose(bar(a))
105  if (any(c /= q+6)) call abort
106
107  write(u,*) transpose(bar(a))
108  write(v,*) q+6
109  if (u /= v) call abort
110
111
112  e = bar(transpose(e))     ! { dg-warning "Creating array temporary" }
113  if (any(e /= 2*s+4)) call abort
114
115  write(u,*) transpose(bar(transpose(e)))-2
116  write(v,*) 2*s+4
117  if (u /= v) call abort
118
119
120  e = transpose(bar(e))     ! { dg-warning "Creating array temporary" }
121  if (any(e /= 2*r+6)) call abort
122
123  write(u,*) transpose(transpose(bar(e))-2)
124  write(v,*) 2*r+6
125  if (u /= v) call abort
126
127
128  if (any(a /= transpose(transpose(a)))) call abort     ! optimized away
129
130  write(u,*) a
131  write(v,*) transpose(transpose(a))
132  if (u /= v) call abort
133
134
135  b = a * a
136
137  if (any(transpose(a+b) /= transpose(a)+transpose(b))) call abort      ! optimized away
138
139  write(u,*) transpose(a+b)
140  write(v,*) transpose(a) + transpose(b)
141  if (u /= v) call abort
142
143
144  if (any(transpose(matmul(a,c)) /= matmul(transpose(c), transpose(a)))) call abort      ! 2 temps { dg-warning "Creating array temporary" }
145
146  write(u,*) transpose(matmul(a,c))     ! { dg-warning "Creating array temporary" }
147  write(v,*) matmul(transpose(c), transpose(a))     ! { dg-warning "Creating array temporary" }
148  if (u /= v) call abort
149
150
151  if (any(transpose(matmul(e,a)) /= matmul(transpose(a), transpose(e)))) call abort     ! 2 temps { dg-warning "Creating array temporary" }
152
153  write(u,*) transpose(matmul(e,a))     ! { dg-warning "Creating array temporary" }
154  write(v,*) matmul(transpose(a), transpose(e))     ! { dg-warning "Creating array temporary" }
155  if (u /= v) call abort
156
157
158  call baz (transpose(a))
159
160
161  call toto1 (a, transpose (c))
162  if (any (a /= 2 * p + 12)) call abort
163
164  call toto1 (e, transpose (e))          ! { dg-warning "Creating array temporary" }
165  if (any (e /= 4 * s + 12)) call abort
166
167
168  call toto2 (c, transpose (a))
169  if (any (c /= 2 * q + 13)) call abort
170
171  call toto2 (e, transpose(e))           ! { dg-warning "Creating array temporary" }
172  if (any (e /= 4 * r + 13)) call abort
173
174  call toto2 (e, transpose(transpose(e)))           ! { dg-warning "Creating array temporary" }
175  if (any (e /= 4 * r + 14)) call abort
176
177
178  call toto3 (e, transpose(e))
179  if (any (e /= 4 * r + 14)) call abort
180
181
182  call titi (nx, e, transpose(e))           ! { dg-warning "Creating array temporary" }
183  if (any (e /= 4 * s + 17)) call abort
184
185  contains
186
187  function foo (x)
188    integer, intent(in) :: x(:,:)
189    integer :: foo(size(x,1), size(x,2))
190    foo = x + 1
191  end function foo
192
193  elemental function bar (x)
194    integer, intent(in) :: x
195    integer :: bar
196    bar = x + 2
197  end function bar
198
199  subroutine baz (x)
200    integer, intent(in) :: x(:,:)
201  end subroutine baz
202
203  elemental subroutine toto1 (x, y)
204    integer, intent(out) :: x
205    integer, intent(in)  :: y
206    x = y + y
207  end subroutine toto1
208
209  subroutine toto2 (x, y)
210    integer, dimension(:,:), intent(out) :: x
211    integer, dimension(:,:), intent(in)  :: y
212    x = y + 1
213  end subroutine toto2
214
215  subroutine toto3 (x, y)
216    integer, dimension(:,:), intent(in) :: x, y
217  end subroutine toto3
218
219end
220
221subroutine titi (n, x, y)
222  integer :: n, x(n,n), y(n,n)
223  x = y + 3
224end subroutine titi
225
226! No call to transpose
227! { dg-final { scan-tree-dump-times "_gfortran_transpose" 0 "original" } }
228!
229! 24 temporaries
230! { dg-final { scan-tree-dump-times "struct\[^\\n\]*atmp" 24 "original" } }
231!
232! 2 tests optimized out
233! { dg-final { scan-tree-dump-times "_gfortran_abort" 39 "original" } }
234! { # Commented out as failing at -O0: dg-final { scan-tree-dump-times "_gfortran_abort" 37 "optimized" } }
235!
236! cleanup
237! { dg-final { cleanup-tree-dump "original" } }
238! { dg-final { cleanup-tree-dump "optimized" } }
239