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
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
|
! { dg-do run }
!
! Tests the fix for PR68846 in which compiler generated temporaries were
! receiving the attributes of dummy arguments. This test is the original.
! The simplified versions by Gerhard Steinmetz are gratefully acknowledged.
!
! Contributed by Mirco Valentini <mirco.valentini@polimi.it>
!
MODULE grid
IMPLICIT NONE
PRIVATE
REAL(KIND=8), DIMENSION(100,100), TARGET :: WORKSPACE
TYPE, PUBLIC :: grid_t
REAL(KIND=8), DIMENSION(:,:), POINTER :: P => NULL ()
END TYPE
PUBLIC :: INIT
CONTAINS
SUBROUTINE INIT (DAT)
IMPLICIT NONE
TYPE(grid_t), INTENT(INOUT) :: DAT
INTEGER :: I, J
DAT%P => WORKSPACE
DO I = 1, 100
DO J = 1, 100
DAT%P(I,J) = REAL ((I-1)*100+J-1)
END DO
ENDDO
END SUBROUTINE INIT
END MODULE grid
MODULE subgrid
USE :: grid, ONLY: grid_t
IMPLICIT NONE
PRIVATE
TYPE, PUBLIC :: subgrid_t
INTEGER, DIMENSION(4) :: range
CLASS(grid_t), POINTER :: grd => NULL ()
CONTAINS
PROCEDURE, PASS :: INIT => LVALUE_INIT
PROCEDURE, PASS :: JMP => LVALUE_JMP
END TYPE
CONTAINS
SUBROUTINE LVALUE_INIT (HOBJ, P, D)
IMPLICIT NONE
CLASS(subgrid_t), INTENT(INOUT) :: HOBJ
TYPE(grid_t), POINTER, INTENT(INOUT) :: P
INTEGER, DIMENSION(4), INTENT(IN) :: D
HOBJ%range = D
HOBJ%grd => P
END SUBROUTINE LVALUE_INIT
FUNCTION LVALUE_JMP(HOBJ, I, J) RESULT(P)
IMPLICIT NONE
CLASS(subgrid_t), INTENT(INOUT) :: HOBJ
INTEGER, INTENT(IN) :: I, J
REAL(KIND=8), POINTER :: P
P => HOBJ%grd%P(HOBJ%range(1)+I-1, HOBJ%range(3)+J-1)
END FUNCTION LVALUE_JMP
END MODULE subgrid
MODULE geom
IMPLICIT NONE
CONTAINS
SUBROUTINE fillgeom_03( subgrid, value )
USE :: subgrid, ONLY: subgrid_t
IMPLICIT NONE
TYPE(subgrid_T), intent(inout) :: subgrid
REAL(kind=8), intent(in) :: value
INTEGER :: I, J
DO i = 1, 3
DO J = 1, 4
subgrid%jmp(i,j) = value ! Dummy argument '_F.DA0' with INTENT(IN)
! in pointer association context or ICE
! in trans_decl.c, depending on INTENT of
! 'VALUE'
ENDDO
ENDDO
END SUBROUTINE fillgeom_03
END MODULE geom
PROGRAM test_lvalue
USE :: grid
USE :: subgrid
USE :: geom
IMPLICIT NONE
TYPE(grid_t), POINTER :: GRD => NULL()
TYPE(subgrid_t) :: STENCIL
REAL(KIND=8), POINTER :: real_tmp_ptr
REAL(KIND=8), DIMENSION(10,10), TARGET :: AA
REAL(KIND=8), DIMENSION(3,4) :: VAL
INTEGER :: I, J, chksum
integer, parameter :: r1 = 50
integer, parameter :: r2 = 52
integer, parameter :: r3 = 50
integer, parameter :: r4 = 53
DO I = 1, 3
DO J = 1, 4
VAL(I,J) = dble(I)*dble(J)
ENDDO
ENDDO
ALLOCATE (GRD)
CALL INIT (GRD)
chksum = sum([([((i-1)*100 + j -1, j=1,100)], i = 1,100)])
if (int(sum(grd%p)) .ne. chksum) stop 1
CALL STENCIL%INIT (GRD, [r1, r2, r3, r4])
if (.not.associated (stencil%grd, grd)) stop 2
if (int(sum(grd%p)) .ne. chksum) stop 3
CALL fillgeom_03(stencil, 42.0_8)
if (any (int (grd%p(r1:r2,r3:r4)) .ne. 42)) stop 4
chksum = chksum - sum([([((i - 1) * 100 + j -1, j=r3,r4)], i = r1,r2)]) &
+ (r4 - r3 + 1) * (r2 - r1 +1) * 42
if (int(sum(grd%p)) .ne. chksum) stop 5
deallocate (grd)
END PROGRAM test_lvalue
|
