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 = 1 13 contains 14 final :: fini_elem 15 end type t1 16 17 type, extends(t1) :: t1e 18 integer :: j = 11 19 contains 20 final :: fini_elem2 21 end type t1e 22 23 type t2 24 integer :: i = 2 25 contains 26 final :: fini_shape 27 end type t2 28 29 type, extends(t2) :: t2e 30 integer :: j = 22 31 contains 32 final :: fini_shape2 33 end type t2e 34 35 type t3 36 integer :: i = 3 37 contains 38 final :: fini_explicit 39 end type t3 40 41 type, extends(t3) :: t3e 42 integer :: j = 33 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) STOP 1 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) STOP 2 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) STOP 3 74 if (x%j /= (j2 + 100*i2)*100) STOP 4 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) STOP 5 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) STOP 6 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])) STOP 7 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) STOP 8 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) STOP 9 186 187 call fin_test_1(x(::2,::3)) 188 if (cnt1 /= 5*4) STOP 10 189 if (cnt1e /= 5*4) STOP 11 190 cnt1 = 0; cnt1e = 0 191 if (cnt2 + cnt2e + cnt3 + cnt3e /= 0) STOP 12 192 193 call fin_test_2(y(::2,::3)) 194 if (cnt2 /= 1) STOP 13 195 if (cnt2e /= 1) STOP 14 196 cnt2 = 0; cnt2e = 0 197 if (cnt1 + cnt1e + cnt3 + cnt3e /= 0) STOP 15 198 199 call fin_test_3(z(::2,::3)) 200 if (cnt3 /= 1) STOP 16 201 if (cnt3e /= 1) STOP 17 202 cnt3 = 0; cnt3e = 0 203 if (cnt1 + cnt1e + cnt2 + cnt2e /= 0) STOP 18 204 205 select type(x) 206 type is (t1e) 207 call check_val(x%i, 1, 1) 208 call check_val(x%j, 100, 11) 209 end select 210 211 select type(y) 212 type is (t2e) 213 call check_val(y%i, 1, 2) 214 call check_val(y%j, 100, 22) 215 end select 216 217 select type(z) 218 type is (t3e) 219 call check_val(z%i, 1, 3) 220 call check_val(z%j, 100, 33) 221 end select 222 223contains 224 subroutine check_val(x, factor, val) 225 integer :: x(:,:) 226 integer, value :: factor, val 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) /= val) STOP 19 232 else 233 if (x(j,i) /= (j + 100*i)*factor) STOP 20 234 end if 235 end do 236 end do 237 end subroutine check_val 238end program test 239