1! { dg-do run } 2! 3! Test functionality of allocatable class arrays: 4! ALLOCATE with source, ALLOCATED, DEALLOCATE, passing as arguments for 5! ELEMENTAL and non-ELEMENTAL procedures, SELECT TYPE and LOWER/UPPER. 6! 7 type :: type1 8 integer :: i 9 end type 10 type, extends(type1) :: type2 11 real :: r 12 end type 13 class(type1), allocatable, dimension (:) :: x 14 15 allocate(x(2), source = type2(42,42.0)) 16 call display(x, [1], [2], t2 = [type2(42,42.0),type2(42,42.0)]) 17 call display(x, [1], [2], t2 = [type2(111,99.0),type2(111,99.0)]) 18 if (allocated (x)) deallocate (x) 19 20 allocate(x(1:4), source = [(type2(i,42.0 + float (i)), i = 1, 4)]) 21 call display(x, [1], [4], t2 = [(type2(i,42.0 + float (i)), i = 1, 4)]) 22 call display(x, [1], [4], t2 = [(type2(111,99.0), i = 1, 4)]) 23 24 if (any (disp (x) .ne. [99.0,99.0,99.0,99.0])) call abort 25 26 if (allocated (x)) deallocate (x) 27 28 allocate(x(1:4), source = type1(42)) 29 call display(x, [1], [4], t1 = [(type1(42), i = 1, 4)]) 30 call display(x, [1], [4], t1 = [type1(42),type1(99),type1(42),type1(42)]) 31 if (any (disp (x) .ne. [0.0,0.0,0.0,0.0])) call abort 32 33contains 34 subroutine display(x, lower, upper, t1, t2) 35 class(type1), allocatable, dimension (:) :: x 36 integer, dimension (:) :: lower, upper 37 type(type1), optional, dimension(:) :: t1 38 type(type2), optional, dimension(:) :: t2 39 select type (x) 40 type is (type1) 41 if (present (t1)) then 42 if (any (x%i .ne. t1%i)) call abort 43 else 44 call abort 45 end if 46 x(2)%i = 99 47 type is (type2) 48 if (present (t2)) then 49 if (any (x%i .ne. t2%i)) call abort 50 if (any (x%r .ne. t2%r)) call abort 51 else 52 call abort 53 end if 54 x%i = 111 55 x%r = 99.0 56 end select 57 call bounds (x, lower, upper) 58 end subroutine 59 subroutine bounds (x, lower, upper) 60 class(type1), allocatable, dimension (:) :: x 61 integer, dimension (:) :: lower, upper 62 if (any (lower .ne. lbound (x))) call abort 63 if (any (upper .ne. ubound (x))) call abort 64 end subroutine 65 elemental function disp(y) result(ans) 66 class(type1), intent(in) :: y 67 real :: ans 68 select type (y) 69 type is (type1) 70 ans = 0.0 71 type is (type2) 72 ans = y%r 73 end select 74 end function 75end 76 77