1! { dg-do run }
2!
3! PR fortran/37336
4!
5! Check the scalarizer/array packing with strides
6! in the finalization wrapper
7!
8module m
9  implicit none
10
11  type t1
12    integer :: i
13  contains
14    final :: fini_elem
15  end type t1
16
17  type, extends(t1) :: t1e
18    integer :: j
19  contains
20    final :: fini_elem2
21  end type t1e
22
23  type t2
24    integer :: i
25  contains
26    final :: fini_shape
27  end type t2
28
29  type, extends(t2) :: t2e
30    integer :: j
31  contains
32    final :: fini_shape2
33  end type t2e
34
35  type t3
36    integer :: i
37  contains
38    final :: fini_explicit
39  end type t3
40
41  type, extends(t3) :: t3e
42    integer :: j
43  contains
44    final :: fini_explicit2
45  end type t3e
46
47  integer :: cnt1, cnt1e, cnt2, cnt2e, cnt3, cnt3e
48
49contains
50
51  impure elemental subroutine fini_elem(x)
52    type(t1), intent(inout) :: x
53    integer :: i, j, i2, j2
54
55    if (cnt1e /= 5*4) call abort ()
56    j = mod (cnt1,5)+1
57    i = cnt1/5 + 1
58    i2 = (i-1)*3 + 1
59    j2 = (j-1)*2 + 1
60    if (x%i /= j2 + 100*i2) call abort ()
61    x%i = x%i * (-13)
62    cnt1 = cnt1 + 1
63  end subroutine fini_elem
64
65  impure elemental subroutine fini_elem2(x)
66    type(t1e), intent(inout) :: x
67    integer :: i, j, i2, j2
68
69    j = mod (cnt1e,5)+1
70    i = cnt1e/5 + 1
71    i2 = (i-1)*3 + 1
72    j2 = (j-1)*2 + 1
73    if (x%i /= j2 + 100*i2) call abort ()
74    if (x%j /= (j2 + 100*i2)*100) call abort ()
75    x%j = x%j * (-13)
76    cnt1e = cnt1e + 1
77  end subroutine fini_elem2
78
79  subroutine fini_shape(x)
80    type(t2) :: x(:,:)
81    if (cnt2e /= 1 .or. cnt2 /= 0) call abort ()
82    call check_var_sec(x%i, 1)
83    x%i = x%i * (-13)
84    cnt2 = cnt2 + 1
85  end subroutine fini_shape
86
87  subroutine fini_shape2(x)
88    type(t2e) :: x(:,:)
89    call check_var_sec(x%i, 1)
90    call check_var_sec(x%j, 100)
91    x%j = x%j * (-13)
92    cnt2e = cnt2e + 1
93  end subroutine fini_shape2
94
95  subroutine fini_explicit(x)
96    type(t3) :: x(5,4)
97    if (cnt3e /= 1 .or. cnt3 /= 0) call abort ()
98    call check_var_sec(x%i, 1)
99    x%i = x%i * (-13)
100    cnt3 = cnt3 + 1
101  end subroutine fini_explicit
102
103  subroutine fini_explicit2(x)
104    type(t3e) :: x(5,4)
105    call check_var_sec(x%i, 1)
106    call check_var_sec(x%j, 100)
107    x%j = x%j * (-13)
108    cnt3e = cnt3e + 1
109  end subroutine fini_explicit2
110
111  subroutine fin_test_1(x)
112    class(t1), intent(out) :: x(5,4)
113  end subroutine fin_test_1
114
115  subroutine fin_test_2(x)
116    class(t2), intent(out) :: x(:,:)
117  end subroutine fin_test_2
118
119  subroutine fin_test_3(x)
120    class(t3), intent(out) :: x(:,:)
121    if (any (shape(x) /= [5,4])) call abort ()
122  end subroutine fin_test_3
123
124  subroutine check_var_sec(x, factor)
125    integer :: x(:,:)
126    integer, value :: factor
127    integer :: i, j, i2, j2
128
129    do i = 1, 4
130      i2 = (i-1)*3 + 1
131      do j = 1, 5
132        j2 = (j-1)*2 + 1
133        if (x(j,i) /= (j2 + 100*i2)*factor) call abort ()
134      end do
135    end do
136  end subroutine check_var_sec
137end module m
138
139
140program test
141  use m
142  implicit none
143
144  class(t1), allocatable :: x(:,:)
145  class(t2), allocatable :: y(:,:)
146  class(t3), allocatable :: z(:,:)
147  integer :: i, j
148
149  cnt1 = 0; cnt1e = 0; cnt2 = 0; cnt2e = 0;  cnt3 = 0; cnt3e = 0
150
151  allocate (t1e :: x(10,10))
152  allocate (t2e :: y(10,10))
153  allocate (t3e :: z(10,10))
154
155  select type(x)
156    type is (t1e)
157      do i = 1, 10
158        do j = 1, 10
159          x(j,i)%i = j + 100*i
160          x(j,i)%j = (j + 100*i)*100
161        end do
162      end do
163  end select
164
165  select type(y)
166    type is (t2e)
167      do i = 1, 10
168        do j = 1, 10
169          y(j,i)%i = j + 100*i
170          y(j,i)%j = (j + 100*i)*100
171        end do
172      end do
173  end select
174
175  select type(z)
176    type is (t3e)
177      do i = 1, 10
178        do j = 1, 10
179          z(j,i)%i = j + 100*i
180          z(j,i)%j = (j + 100*i)*100
181        end do
182      end do
183  end select
184
185  if (cnt1 + cnt1e + cnt2 + cnt2e + cnt3 + cnt3e /= 0) call abort()
186
187  call fin_test_1(x(::2,::3))
188  if (cnt1 /= 5*4) call abort ()
189  if (cnt1e /= 5*4) call abort ()
190  cnt1 = 0; cnt1e = 0
191  if (cnt2 + cnt2e + cnt3 + cnt3e /= 0) call abort()
192
193  call fin_test_2(y(::2,::3))
194  if (cnt2 /= 1) call abort ()
195  if (cnt2e /= 1) call abort ()
196  cnt2 = 0; cnt2e = 0
197  if (cnt1 + cnt1e + cnt3 + cnt3e /= 0) call abort()
198
199  call fin_test_3(z(::2,::3))
200  if (cnt3 /= 1) call abort ()
201  if (cnt3e /= 1) call abort ()
202  cnt3 = 0; cnt3e = 0
203  if (cnt1 + cnt1e + cnt2 + cnt2e /= 0) call abort()
204
205  select type(x)
206    type is (t1e)
207      call check_val(x%i, 1)
208      call check_val(x%j, 100)
209  end select
210
211  select type(y)
212    type is (t2e)
213      call check_val(y%i, 1)
214      call check_val(y%j, 100)
215  end select
216
217  select type(z)
218    type is (t3e)
219      call check_val(z%i, 1)
220      call check_val(z%j, 100)
221  end select
222
223contains
224  subroutine check_val(x, factor)
225    integer :: x(:,:)
226    integer, value :: factor
227    integer :: i, j
228    do i = 1, 10
229      do j = 1, 10
230        if (mod (j-1, 2) == 0 .and. mod (i-1, 3) == 0) then
231          if (x(j,i) /= (j + 100*i)*factor*(-13)) call abort ()
232        else
233          if (x(j,i) /= (j + 100*i)*factor) call abort ()
234        end if
235      end do
236    end do
237  end subroutine check_val
238end program test
239