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