1! { dg-do run } 2! 3! Test functionality of pointer class arrays: 4! ALLOCATE with source, ASSOCIATED, 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), pointer, 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 (associated (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])) STOP 1 25 26 if (associated (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])) STOP 2 32 33 if (associated (x)) deallocate (x) 34 35contains 36 subroutine display(x, lower, upper, t1, t2) 37 class(type1), pointer, dimension (:) :: x 38 integer, dimension (:) :: lower, upper 39 type(type1), optional, dimension(:) :: t1 40 type(type2), optional, dimension(:) :: t2 41 select type (x) 42 type is (type1) 43 if (present (t1)) then 44 if (any (x%i .ne. t1%i)) STOP 3 45 else 46 STOP 4 47 end if 48 x(2)%i = 99 49 type is (type2) 50 if (present (t2)) then 51 if (any (x%i .ne. t2%i)) STOP 5 52 if (any (x%r .ne. t2%r)) STOP 6 53 else 54 STOP 7 55 end if 56 x%i = 111 57 x%r = 99.0 58 end select 59 call bounds (x, lower, upper) 60 end subroutine 61 subroutine bounds (x, lower, upper) 62 class(type1), pointer, dimension (:) :: x 63 integer, dimension (:) :: lower, upper 64 if (any (lower .ne. lbound (x))) STOP 8 65 if (any (upper .ne. ubound (x))) STOP 9 66 end subroutine 67 elemental function disp(y) result(ans) 68 class(type1), intent(in) :: y 69 real :: ans 70 select type (y) 71 type is (type1) 72 ans = 0.0 73 type is (type2) 74 ans = y%r 75 end select 76 end function 77end 78 79