1! { dg-do run }
2!
3! PR fortran/37336
4!
5module m
6  implicit none
7  type t
8    integer :: i
9  contains
10    final :: fini3, fini2, fini_elm
11  end type t
12
13  type, extends(t) :: t2
14    integer :: j
15  contains
16    final :: f2ini2, f2ini_elm
17  end type t2
18
19  logical :: elem_call
20  logical :: rank2_call
21  logical :: rank3_call
22  integer :: cnt, cnt2
23  integer :: fini_call
24
25contains
26  subroutine fini2 (x)
27    type(t), intent(in), contiguous :: x(:,:)
28    if (.not. rank2_call) call abort ()
29    if (size(x,1) /= 2 .or. size(x,2) /= 3) call abort()
30    !print *, 'fini2:', x%i
31    if (any (x%i /= reshape([11, 12, 21, 22, 31, 32], [2,3]))) call abort()
32    fini_call = fini_call + 1
33  end subroutine
34
35  subroutine fini3 (x)
36    type(t), intent(in) :: x(2,2,*)
37    integer :: i,j,k
38    if (.not. elem_call) call abort ()
39    if (.not. rank3_call) call abort ()
40    if (cnt2 /= 9) call abort()
41    if (cnt /= 1) call abort()
42      do i = 1, 2
43        do j = 1, 2
44          do k = 1, 2
45            !print *, k,j,i,x(k,j,i)%i
46            if (x(k,j,i)%i /= k+10*j+100*i) call abort()
47          end do
48        end do
49      end do
50    fini_call = fini_call + 1
51  end subroutine
52
53  impure elemental subroutine fini_elm (x)
54    type(t), intent(in) :: x
55    if (.not. elem_call) call abort ()
56    if (rank3_call) call abort ()
57    if (cnt2 /= 6) call abort()
58    if (cnt /= x%i) call abort()
59    !print *, 'fini_elm:', cnt, x%i
60    fini_call = fini_call + 1
61    cnt = cnt + 1
62  end subroutine
63
64  subroutine f2ini2 (x)
65    type(t2), intent(in), target :: x(:,:)
66    if (.not. rank2_call) call abort ()
67    if (size(x,1) /= 2 .or. size(x,2) /= 3) call abort()
68    !print *, 'f2ini2:', x%i
69    !print *, 'f2ini2:', x%j
70    if (any (x%i /= reshape([11, 12, 21, 22, 31, 32], [2,3]))) call abort()
71    if (any (x%j /= 100*reshape([11, 12, 21, 22, 31, 32], [2,3]))) call abort()
72    fini_call = fini_call + 1
73  end subroutine
74
75  impure elemental subroutine f2ini_elm (x)
76    type(t2), intent(in) :: x
77    integer, parameter :: exprected(*) &
78            = [111, 112, 121, 122, 211, 212, 221, 222]
79
80    if (.not. elem_call) call abort ()
81    !print *, 'f2ini_elm:', cnt2, x%i, x%j
82    if (rank3_call) then
83      if (x%i /= exprected(cnt2)) call abort ()
84      if (x%j /= 1000*exprected(cnt2)) call abort ()
85    else
86      if (cnt2 /= x%i .or. cnt2*10 /= x%j) call abort()
87    end if
88    cnt2 = cnt2 + 1
89    fini_call = fini_call + 1
90  end subroutine
91end module m
92
93
94program test
95  use m
96  implicit none
97  class(t), save, allocatable :: y(:), z(:,:), zz(:,:,:)
98  target :: z, zz
99  integer :: i,j,k
100
101  elem_call = .false.
102  rank2_call = .false.
103  rank3_call = .false.
104  allocate (t2 :: y(5))
105  select type (y)
106    type is (t2)
107      do i = 1, 5
108        y(i)%i = i
109        y(i)%j = i*10
110      end do
111  end select
112  cnt = 1
113  cnt2 = 1
114  fini_call = 0
115  elem_call = .true.
116  deallocate (y)
117  if (fini_call /= 10) call abort ()
118
119  elem_call = .false.
120  rank2_call = .false.
121  rank3_call = .false.
122  allocate (t2 :: z(2,3))
123  select type (z)
124    type is (t2)
125      do i = 1, 3
126        do j = 1, 2
127          z(j,i)%i = j+10*i
128          z(j,i)%j = (j+10*i)*100
129        end do
130      end do
131  end select
132  cnt = 1
133  cnt2 = 1
134  fini_call = 0
135  rank2_call = .true.
136  deallocate (z)
137  if (fini_call /= 2) call abort ()
138
139  elem_call = .false.
140  rank2_call = .false.
141  rank3_call = .false.
142  allocate (t2 :: zz(2,2,2))
143  select type (zz)
144    type is (t2)
145      do i = 1, 2
146        do j = 1, 2
147          do k = 1, 2
148            zz(k,j,i)%i = k+10*j+100*i
149            zz(k,j,i)%j = (k+10*j+100*i)*1000
150          end do
151        end do
152      end do
153  end select
154  cnt = 1
155  cnt2 = 1
156  fini_call = 0
157  rank3_call = .true.
158  elem_call = .true.
159  deallocate (zz)
160  if (fini_call /= 2*2*2+1) call abort ()
161end program test
162