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