1! { dg-do run }
2!
3! TS 29113
4! 6.4.1  SHAPE
5!
6! The description of the intrinsic function SHAPE in ISO/IEC 1539-1:2010
7! is changed for an assumed-rank array that is associated with an
8! assumed-size array; an assumed-size array has no shape, but in this
9! case the result has a value equal to
10! [ (SIZE (ARRAY, I, KIND), I=1,RANK (ARRAY)) ]
11! with KIND omitted from SIZE if it was omitted from SHAPE.
12!
13! The idea here is that the main program passes some arrays to a test
14! subroutine with an assumed-size dummy, which in turn passes that to a
15! subroutine with an assumed-rank dummy.
16
17program test
18  implicit none
19  ! Define some arrays for testing.
20  integer, target :: x1(5)
21  integer :: y1(0:9)
22  integer, pointer :: p1(:)
23  integer, allocatable :: a1(:)
24  integer, target :: x3(2,3,4)
25  integer :: y3(0:1,-3:-1,4)
26  integer, pointer :: p3(:,:,:)
27  integer, allocatable :: a3(:,:,:)
28
29  ! Test the 1-dimensional arrays.
30  call test1 (x1)
31  call test1 (y1)
32  p1 => x1
33  call test1 (p1)
34  allocate (a1(5))
35  call test1 (a1)
36
37  ! Test the multi-dimensional arrays.
38  call test3 (x3, 1, 2, 1, 3)
39  call test3 (y3, 0, 1, -3, -1)
40  p3 => x3
41  call test3 (p3, 1, 2, 1, 3)
42  allocate (a3(2,3,4))
43  call test3 (a3, 1, 2, 1, 3)
44
45contains
46
47  subroutine testit (a)
48    integer :: a(..)
49
50    integer :: r
51    r = rank(a)
52
53    block
54      integer :: s(r), i
55      s = shape(a)
56      do i = 1, r
57        if (s(i) .ne. size(a,i)) stop 101
58      end do
59    end block
60
61  end subroutine
62
63  subroutine test1 (a)
64    integer :: a(*)
65
66    call testit (a)
67  end subroutine
68
69  subroutine test3 (a, l1, u1, l2, u2)
70    implicit none
71    integer :: l1, u1, l2, u2
72    integer :: a(l1:u1, l2:u2, *)
73
74    call testit (a)
75  end subroutine
76
77end program
78