1! { dg-do run }
2!
3! Test the fix for PR81903
4!
5! Contributed by Karl May  <karl.may0@freenet.de>
6!
7Module TestMod_A
8  Type :: TestType_A
9    Real, Allocatable :: a(:,:)
10  End type TestType_A
11End Module TestMod_A
12Module TestMod_B
13  Type :: TestType_B
14   Real, Pointer, contiguous :: a(:,:)
15  End type TestType_B
16End Module TestMod_B
17Module TestMod_C
18  use TestMod_A
19  use TestMod_B
20  Implicit None
21  Type :: TestType_C
22    Class(TestType_A), Pointer :: TT_A(:)
23    Type(TestType_B), Allocatable :: TT_B(:)
24  contains
25    Procedure, Pass :: SetPt => SubSetPt
26  End type TestType_C
27  Interface
28    Module Subroutine SubSetPt(this)
29      class(TestType_C), Intent(InOut), Target :: this
30    End Subroutine
31  End Interface
32End Module TestMod_C
33Submodule(TestMod_C) SetPt
34contains
35  Module Procedure SubSetPt
36    Implicit None
37    integer :: i
38    integer :: sum_a = 0
39    outer:block
40      associate(x=>this%TT_B,y=>this%TT_A)
41        Do i=1,size(x)
42          x(i)%a=>y(i)%a
43          sum_a = sum_a + sum (int (x(i)%a))
44        End Do
45      end associate
46    End block outer
47    if (sum_a .ne. 30) STOP 1
48  End Procedure
49End Submodule SetPt
50Program Test
51  use TestMod_C
52  use TestMod_A
53  Implicit None
54  Type(TestType_C) :: tb
55  Type(TestType_A), allocatable, Target :: ta(:)
56  integer :: i
57  real :: src(2,2) = reshape ([(real(i), i = 1,4)],[2,2])
58  allocate(ta(2),tb%tt_b(2))
59  do i=1,size(ta)
60    allocate(ta(i)%a(2,2), source = src*real(i))
61  End do
62  tb%TT_A=>ta
63  call tb%setpt()
64End Program Test
65