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