1! { dg-do run }
2!
3! TS 29113
4! 7.2 RANK (A)
5! Description. Rank of a data object.
6! Class. Inquiry function.
7! Argument.
8! A shall be a scalar or array of any type.
9! Result Characteristics. Default integer scalar.
10! Result Value. The result is the rank of A.
11
12module m
13
14  type :: base
15    integer :: a, b
16  end type
17
18  type, extends (base) :: derived
19    integer :: c
20  end type
21end module
22
23program test
24  use m
25
26  ! Define some arrays for testing.
27  type(derived), target :: x1(5)
28  type(derived) :: y1(0:9)
29  type(derived), pointer :: p1(:)
30  type(derived), allocatable :: a1(:)
31  type(derived), target :: x3(2,3,4)
32  type(derived) :: y3(0:1,-3:-1,4)
33  type(derived), pointer :: p3(:,:,:)
34  type(derived), allocatable :: a3(:,:,:)
35  type(derived) :: x
36
37  ! Test the 1-dimensional arrays.
38  if (rank (x1) .ne. 1) stop 201
39  call testit (x1, 1)
40  if (rank (y1) .ne. 1) stop 202
41  call testit (y1, 1)
42  if (rank (p1) .ne. 1) stop 203
43  p1 => x1
44  call testit (p1, 1)
45  if (rank (p1) .ne. 1) stop 204
46  if (rank (a1) .ne. 1) stop 205
47  allocate (a1(5))
48  if (rank (a1) .ne. 1) stop 206
49  call testit (a1, 1)
50
51  ! Test the multi-dimensional arrays.
52  if (rank (x3) .ne. 3) stop 207
53  call testit (x3, 3)
54  if (rank (y3) .ne. 3) stop 208
55  if (rank (p3) .ne. 3) stop 209
56  p3 => x3
57  call testit (p3, 3)
58  if (rank (p3) .ne. 3) stop 210
59  if (rank (a3) .ne. 3) stop 211
60  allocate (a3(2,3,4))
61  call testit (a3, 3)
62  if (rank (a3) .ne. 3) stop 212
63
64  ! Test scalars.
65  if (rank (x) .ne. 0) stop 213
66  call testit (x, 0)
67  call test0 (x)
68  if (rank (x1(1)) .ne. 0) stop 215
69  call test0 (x1(1))
70
71contains
72
73  subroutine testit (a, r)
74    use m
75    class(base) :: a(..)
76    integer :: r
77
78    if (r .ne. rank(a))  stop 101
79  end subroutine
80
81  subroutine test0 (a)
82    use m
83    class(base) :: a(..)
84    if (rank (a) .ne. 0) stop 103
85    call testit (a, 0)
86  end subroutine
87
88end program
89