| ! { dg-do run } |
| |
| ! PR fortran/96992 |
| |
| ! Contributed by Thomas Koenig <tkoenig@gcc.gnu.org> |
| |
| ! From the standard: |
| ! An actual argument that represents an element sequence and |
| ! corresponds to a dummy argument that is an array is sequence |
| ! associated with the dummy argument. The rank and shape of the |
| ! actual argument need not agree with the rank and shape of the |
| ! dummy argument, but the number of elements in the dummy argument |
| ! shall not exceed the number of elements in the element sequence |
| ! of the actual argument. If the dummy argument is assumed-size, |
| ! the number of elements in the dummy argument is exactly |
| ! the number of elements in the element sequence. |
| |
| ! Check that walking the sequence starts with an initialized stride |
| ! for dim == 0. |
| |
| module foo_mod |
| |
| implicit none |
| |
| type foo |
| integer :: i |
| end type foo |
| |
| contains |
| |
| subroutine d1(x,n) |
| integer, intent(in) :: n |
| integer :: i |
| class (foo), intent(out), dimension(n) :: x |
| |
| x(:)%i = (/ (42 + i, i = 1, n ) /) |
| end subroutine d1 |
| |
| subroutine d2(x,n,sb) |
| integer, intent(in) :: n |
| integer :: i, sb |
| class (foo), intent(in), dimension(n,n,n) :: x |
| |
| if ( any( x%i /= reshape((/ (42 + i, i = 1, n ** 3 ) /), [n, n, n] ))) stop sb + 1 |
| end subroutine d2 |
| |
| subroutine d3(x,n) |
| integer, intent(in) :: n |
| integer :: i |
| class (foo), intent(inout) :: x(n) |
| |
| x%i = -x%i ! Simply negate elements |
| end subroutine d3 |
| |
| subroutine d4(a,n) |
| integer, intent(in) :: n |
| class (foo), intent(inout) :: a(*) |
| |
| call d3(a,n) |
| end subroutine d4 |
| |
| subroutine d1s(x,n, sb) |
| integer, intent(in) :: n, sb |
| integer :: i |
| class (*), intent(out), dimension(n) :: x |
| |
| select type(x) |
| class is(foo) |
| x(:)%i = (/ (42 + i, i = 1, n ) /) |
| class default |
| stop sb + 2 |
| end select |
| end subroutine d1s |
| |
| subroutine d2s(x,n,sb) |
| integer, intent(in) :: n,sb |
| integer :: i |
| class (*), intent(in), dimension(n,n,n) :: x |
| |
| select type (x) |
| class is (foo) |
| if ( any( x%i /= reshape((/ (42 + i, i = 1, n ** 3 ) /), [n, n, n] ))) stop sb + 3 |
| class default |
| stop sb + 4 |
| end select |
| end subroutine d2s |
| |
| subroutine d3s(x,n,sb) |
| integer, intent(in) :: n, sb |
| integer :: i |
| class (*), intent(inout) :: x(n) |
| |
| select type (x) |
| class is (foo) |
| x%i = -x%i ! Simply negate elements |
| class default |
| stop sb + 5 |
| end select |
| end subroutine d3s |
| |
| end module foo_mod |
| |
| program main |
| |
| use foo_mod |
| |
| implicit none |
| |
| type (foo), dimension(:), allocatable :: f |
| type (foo), dimension(27) :: g |
| type (foo), dimension(3, 9) :: td |
| integer :: n,i,np3 |
| |
| n = 3 |
| np3 = n **3 |
| allocate (f(np3)) |
| call d1(f, np3) |
| call d2(f, n, 0) |
| |
| call d1s(f, np3, 0) |
| call d2s(f, n, 0) |
| |
| ! Use negative stride |
| call d1(f(np3:1:-1), np3) |
| if ( any( f%i /= (/ (42 + i, i = np3, 1, -1 ) /) )) stop 6 |
| call d2(f(np3:1:-1), n, 0) |
| call d3(f(1:np3:4), np3/4) |
| if ( any( f%i /= (/ (merge(-(42 + (np3 - i)), & |
| 42 + (np3 - i), & |
| MOD(i, 4) == 0 .AND. i < 21), & |
| i = 0, np3 - 1 ) /) )) & |
| stop 7 |
| call d4(f(1:np3:4), np3/4) |
| if ( any( f%i /= (/ (42 + i, i = np3, 1, -1 ) /) )) stop 8 |
| |
| call d1s(f(np3:1:-1), np3, 0) |
| if ( any( f%i /= (/ (42 + i, i = np3, 1, -1 ) /) )) stop 9 |
| call d2s(f(np3:1:-1), n, 0) |
| call d3s(f(1:np3:4), np3/4, 0) |
| if ( any( f%i /= (/ (merge(-(42 + (np3 - i)), & |
| 42 + (np3 - i), & |
| MOD(i, 4) == 0 .AND. i < 21), & |
| i = 0, np3 - 1 ) /) )) & |
| stop 10 |
| |
| deallocate (f) |
| |
| call d1(g, np3) |
| call d2(g, n, 11) |
| |
| call d1s(g, np3, 11) |
| call d2s(g, n, 11) |
| |
| ! Use negative stride |
| call d1(g(np3:1:-1), np3) |
| if ( any( g%i /= (/ (42 + i, i = np3, 1, -1 ) /) )) stop 17 |
| call d2(g(np3:1:-1), n, 11) |
| call d3(g(1:np3:4), np3/4) |
| if ( any( g%i /= (/ (merge(-(42 + (np3 - i)), & |
| 42 + (np3 - i), & |
| MOD(i, 4) == 0 .AND. i < 21), & |
| i = 0, np3 - 1 ) /) )) & |
| stop 18 |
| |
| call d1s(g(np3:1:-1), np3, 11) |
| if ( any( g%i /= (/ (42 + i, i = np3, 1, -1 ) /) )) stop 19 |
| call d2s(g(np3:1:-1), n, 11) |
| call d3s(g(1:np3:4), np3/4, 11) |
| if ( any( g%i /= (/ (merge(-(42 + (np3 - i)), & |
| 42 + (np3 - i), & |
| MOD(i, 4) == 0 .AND. i < 21), & |
| i = 0, np3 - 1 ) /) )) & |
| stop 20 |
| |
| ! Check for 2D |
| call d1(td, np3) |
| call d2(td, n, 21) |
| |
| call d1s(td, np3, 21) |
| call d2s(td, n, 21) |
| |
| ! Use negative stride |
| call d1(td(3:1:-1,9:1:-1), np3) |
| if ( any( reshape(td%i, [np3]) /= (/ (42 + i, i = np3, 1, -1 ) /) )) stop 26 |
| call d2(td(3:1:-1,9:1:-1), n, 21) |
| call d3(td(2,1:n), n) |
| if ( any( reshape(td%i, [np3]) /= (/ (merge(-(42 + (np3 - i)), & |
| 42 + (np3 - i), & |
| MOD(i, 3) == 1 .AND. i < 9), & |
| i = 0, np3 - 1 ) /) )) & |
| stop 27 |
| |
| end program main |
| |
