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