! { dg-do run }
!
! Contributed by Andre Vehreschild
! Check more elaborate class array addressing.

module m1

  type InnerBaseT
    integer, allocatable :: a(:)
  end type InnerBaseT

  type, extends(InnerBaseT) :: InnerT
    integer :: i
  end type InnerT

  type BaseT
    class(InnerT), allocatable :: arr(:,:)
  contains
    procedure P
  end type BaseT

contains

  subroutine indir(this, mat)
    class(BaseT) :: this
    class(InnerT), intent(inout) :: mat(:,:)

    call this%P(mat)
  end subroutine indir

  subroutine P(this, mat)
    class(BaseT) :: this
    class(InnerT), intent(inout) :: mat(:,:)
    integer :: i,j

    mat%i = 42
    do i= 1, ubound(mat, 1)
      do j= 1, ubound(mat, 2)
        if (.not. allocated(mat(i,j)%a)) then
          allocate(mat(i,j)%a(10), source = 72)
        end if
      end do
    end do
    mat(1,1)%i = 9
    mat(1,1)%a(5) = 1
  end subroutine

end module m1

program test
  use m1

  class(BaseT), allocatable, target :: o
  class(InnerT), pointer :: i_p(:,:)
  class(InnerBaseT), allocatable :: i_a(:,:)
  integer i,j,l

  allocate(o)
  allocate(o%arr(2,2))
  allocate(InnerT::i_a(2,2))
  o%arr%i = 1

  i_p => o%arr
  call o%P(i_p)
  if (any(o%arr%i /= reshape([9,42,42,42],[2,2]))) STOP 1
  do l= 1, 10
    do i= 1, 2
      do j= 1,2
        if ((i == 1 .and. j == 1 .and. l == 5 .and. &
             o%arr(i,j)%a(5) /= 1) &
            .or. (.not. (i == 1 .and. j == 1 .and. l == 5) &
              .and. o%arr(i,j)%a(l) /= 72)) STOP 2
      end do
    end do
  end do

  select type (i_a)
    type is (InnerT)
      call o%P(i_a)
      do l= 1, 10
        do i= 1, 2
          do j= 1,2
            if ((i == 1 .and. j == 1 .and. l == 5 .and. &
                 i_a(i,j)%a(5) /= 1) &
                .or. (.not. (i == 1 .and. j == 1 .and. l == 5) &
                  .and. i_a(i,j)%a(l) /= 72)) STOP 3
          end do
        end do
      end do
  end select

  i_p%i = 4
  call indir(o, i_p)
  if (any(o%arr%i /= reshape([9,42,42,42],[2,2]))) STOP 4
end program test

! vim:ts=2:sts=2:cindent:sw=2:tw=80: