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