1! { dg-do run }
2! { dg-options "-fcheck=all" }
3!
4! Basic check of Parameterized Derived Types.
5!
6! -fcheck=all is used here to ensure that when the parameter
7! 'b' of the dummy in 'foo' is assumed, there is no error.
8! Likewise in 'bar' and 'foobar', when 'b' has the correct
9! explicit value.
10!
11  implicit none
12  integer, parameter :: ftype = kind(0.0e0)
13  integer :: pdt_len = 4
14  integer :: i
15  type :: mytype (a,b)
16    integer, kind :: a = kind(0.0d0)
17    integer, LEN :: b
18    integer :: i
19    real(kind = a) :: d(b, b)
20    character (len = b*b) :: chr
21  end type
22
23  type(mytype(b=4)) :: z(2)
24  type(mytype(ftype, 4)) :: z2
25
26  z(1)%i = 1
27  z(2)%i = 2
28  z(1)%d = reshape ([(real(i), i = 1, 16)],[4,4])
29  z(2)%d = 10*z(1)%d
30  z(1)%chr = "hello pdt"
31  z(2)%chr = "goodbye pdt"
32
33  z2%d = z(1)%d * 10 - 1
34  z2%chr = "scalar pdt"
35
36  call foo (z)
37  call bar (z)
38  call foobar (z2)
39contains
40  elemental subroutine foo (arg)
41    type(mytype(8,*)), intent(in) :: arg
42    if (arg%i .eq. 1) then
43      if (trim (arg%chr) .ne. "hello pdt") error stop
44      if (int (sum (arg%d)) .ne. 136) error stop
45    else if (arg%i .eq. 2 ) then
46      if (trim (arg%chr) .ne. "goodbye pdt") error stop
47      if (int (sum (arg%d)) .ne. 1360) error stop
48    else
49      error stop
50    end if
51  end subroutine
52  subroutine bar (arg)
53    type(mytype(b=4)) :: arg(:)
54    if (int (sum (arg(1)%d)) .ne. 136) STOP 1
55    if (trim (arg(2)%chr) .ne. "goodbye pdt") STOP 2
56  end subroutine
57  subroutine foobar (arg)
58    type(mytype(ftype, pdt_len)) :: arg
59    if (int (sum (arg%d)) .ne. 1344) STOP 3
60    if (trim (arg%chr) .ne. "scalar pdt") STOP 4
61  end subroutine
62end
63