1! { dg-do compile }
2! Tests the fix for PR30407, in which operator assignments did not work
3! in WHERE blocks or simple WHERE statements. This tests that the character
4! lengths are transmitted OK.
5!
6! Contributed by Paul Thomas <pault@gcc.gnu.org>
7!******************************************************************************
8module global
9  type :: a
10    integer :: b
11    character(8):: c
12  end type a
13  interface assignment(=)
14    module procedure a_to_a, c_to_a, a_to_c
15  end interface
16  interface operator(.ne.)
17    module procedure a_ne_a
18  end interface
19
20  type(a) :: x(4), y(4)
21  logical :: l1(4), t = .true., f= .false.
22contains
23!******************************************************************************
24  elemental subroutine a_to_a (m, n)
25    type(a), intent(in) :: n
26    type(a), intent(out) :: m
27    m%b = len ( trim(n%c))
28    m%c = n%c
29  end subroutine a_to_a
30  elemental subroutine c_to_a (m, n)
31    character(8), intent(in) :: n
32    type(a), intent(out) :: m
33    m%b = m%b + 1
34    m%c = n
35  end subroutine c_to_a
36  elemental subroutine a_to_c (m, n)
37    type(a), intent(in) :: n
38    character(8), intent(out) :: m
39    m = n%c
40  end subroutine a_to_c
41!******************************************************************************
42  elemental logical function a_ne_a (m, n)
43    type(a), intent(in) :: n
44    type(a), intent(in) :: m
45    a_ne_a = (m%b .ne. n%b) .or. (m%c .ne. n%c)
46  end function a_ne_a
47!******************************************************************************
48  elemental function foo (m)
49    type(a) :: foo
50    type(a), intent(in) :: m
51    foo%b = 0
52    foo%c = m%c
53  end function foo
54end module global
55!******************************************************************************
56program test
57  use global
58  x = (/a (0, "one"),a (0, "two"),a (0, "three"),a (0, "four")/)
59  y = x
60  l1 = (/t,f,f,t/)
61
62  call test_where_char1
63  call test_where_char2
64  if (any(y .ne. &
65    (/a(4, "null"), a(8, "non-null"), a(8, "non-null"), a(4, "null")/))) call abort ()
66contains
67  subroutine test_where_char1   ! Test a WHERE blocks
68    where (l1)
69      y = a (0, "null")
70    elsewhere
71      y = x
72    end where
73  end subroutine test_where_char1
74  subroutine test_where_char2   ! Test a WHERE blocks
75    where (y%c .ne. "null")
76      y = a (99, "non-null")
77    endwhere
78  end subroutine test_where_char2
79end program test
80