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