1! { dg-do run }
2! Test the fix for pr22146, where and elemental subroutine with
3! array actual arguments would cause an ICE in gfc_conv_function_call.
4! This test checks that the main uses for elemental subroutines work
5! correctly; namely, as module procedures and as procedures called
6! from elemental functions. The compiler would ICE on the former with
7! the first version of the patch.
8!
9! Contributed by Paul Thomas   <pault@gcc.gnu.org>
10
11module type
12  type itype
13    integer :: i
14    character(1) :: ch
15  end type itype
16end module type
17
18module assign
19  interface assignment (=)
20    module procedure itype_to_int
21  end interface
22contains
23  elemental subroutine itype_to_int (i, it)
24    use type
25    type(itype), intent(in) :: it
26    integer, intent(out) :: i
27    i = it%i
28  end subroutine itype_to_int
29
30  elemental function i_from_itype (it) result (i)
31    use type
32    type(itype), intent(in) :: it
33    integer :: i
34    i = it
35  end function i_from_itype
36
37end module assign
38
39program test_assign
40  use type
41  use assign
42  type(itype) :: x(2, 2)
43  integer :: i(2, 2)
44
45! Test an elemental subroutine call from an elementary function.
46  x = reshape ((/(itype (j, "a"), j = 1,4)/), (/2,2/))
47  forall (j = 1:2, k = 1:2)
48    i(j, k) = i_from_itype (x (j, k))
49  end forall
50  if (any(reshape (i, (/4/)).ne.(/1,2,3,4/))) call abort ()
51
52! Check the interface assignment (not part of the patch).
53  x = reshape ((/(itype (j**2, "b"), j = 1,4)/), (/2,2/))
54  i = x
55  if (any(reshape (i, (/4/)).ne.(/1,4,9,16/))) call abort ()
56
57! Use the interface assignment within a forall block.
58  x = reshape ((/(itype (j**3, "c"), j = 1,4)/), (/2,2/))
59  forall (j = 1:2, k = 1:2)
60    i(j, k) = x (j, k)
61  end forall
62  if (any(reshape (i, (/4/)).ne.(/1,8,27,64/))) call abort ()
63
64end program test_assign
65