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