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