1! { dg-do run }
2!
3! Check PDT type extension and simple OOP.
4!
5module vars
6  integer :: d_dim = 4
7  integer :: mat_dim = 256
8  integer, parameter :: ftype = kind(0.0d0)
9end module
10
11  use vars
12  implicit none
13  integer :: i
14  type :: mytype (a,b)
15    integer, kind :: a = kind(0.0e0)
16    integer, LEN :: b = 4
17    integer :: i
18    real(kind = a) :: d(b, b)
19  end type
20
21  type, extends(mytype) :: thytype(h)
22    integer, kind :: h
23    integer(kind = h) :: j
24  end type
25
26  type x (q, r, s)
27    integer, kind :: q
28    integer, kind :: r
29    integer, LEN :: s
30    integer(kind = q) :: idx_mat(2,2)  ! check these do not get treated as pdt_arrays.
31    type (mytype (b=s)) :: mat1
32    type (mytype (b=s*2)) :: mat2
33  end type x
34
35  real, allocatable :: matrix (:,:)
36  type(thytype(ftype, 4, 4)) :: w
37  type(x(8,4,256)) :: q
38  class(mytype(ftype, :)), allocatable :: cz
39
40  w%d = reshape ([(real(i), i = 1, d_dim*d_dim)],[d_dim,d_dim])
41
42! Make sure that the type extension is ordering the parameters correctly.
43  if (w%a .ne. ftype) STOP 1
44  if (w%b .ne. 4) STOP 2
45  if (w%h .ne. 4) STOP 3
46  if (size (w%d) .ne. 16) STOP 4
47  if (int (w%d(2,4)) .ne. 14) STOP 5
48  if (kind (w%j) .ne. w%h) STOP 6
49
50! As a side issue, ensure PDT components are OK
51  if (q%mat1%b .ne. q%s) STOP 7
52  if (q%mat2%b .ne. q%s*2) STOP 8
53  if (size (q%mat1%d) .ne. mat_dim**2) STOP 9
54  if (size (q%mat2%d) .ne. 4*mat_dim**2) STOP 10
55
56! Now check some basic OOP with PDTs
57  matrix = w%d
58
59! TODO - for some reason, using w%d directly in the source causes a seg fault.
60  allocate (cz, source = mytype(ftype, d_dim, 0, matrix))
61  select type (cz)
62    type is (mytype(ftype, *))
63      if (int (sum (cz%d)) .ne. 136) STOP 11
64    type is (thytype(ftype, *, 8))
65      STOP 12
66  end select
67  deallocate (cz)
68
69  allocate (thytype(ftype, d_dim*2, 8) :: cz)
70  cz%d = reshape ([(i*10, i = 1, cz%b**2)], [cz%b,cz%b])
71  select type (cz)
72    type is (mytype(ftype, *))
73      STOP 13
74    type is (thytype(ftype, *, 8))
75      if (int (sum (cz%d)) .ne. 20800) STOP 14
76  end select
77
78  deallocate (cz)
79end
80