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
|
! { dg-do compile }
! Tests the fix for PR30407, in which operator assignments did not work
! in WHERE blocks or simple WHERE statements. This is the test provided
! by the reporter.
!
! Contributed by Dominique d'Humieres <dominiq@lps.ens.fr>
!==============================================================================
MODULE kind_mod
IMPLICIT NONE
PRIVATE
INTEGER, PUBLIC, PARAMETER :: I4=SELECTED_INT_KIND(9)
INTEGER, PUBLIC, PARAMETER :: TF=KIND(.TRUE._I4)
END MODULE kind_mod
!==============================================================================
MODULE pointer_mod
USE kind_mod, ONLY : I4
IMPLICIT NONE
PRIVATE
TYPE, PUBLIC :: pvt
INTEGER(I4), POINTER, DIMENSION(:) :: vect
END TYPE pvt
INTERFACE ASSIGNMENT(=)
MODULE PROCEDURE p_to_p
END INTERFACE
PUBLIC :: ASSIGNMENT(=)
CONTAINS
!---------------------------------------------------------------------------
PURE ELEMENTAL SUBROUTINE p_to_p(a1, a2)
IMPLICIT NONE
TYPE(pvt), INTENT(OUT) :: a1
TYPE(pvt), INTENT(IN) :: a2
a1%vect = a2%vect
END SUBROUTINE p_to_p
!---------------------------------------------------------------------------
END MODULE pointer_mod
!==============================================================================
PROGRAM test_prog
USE pointer_mod, ONLY : pvt, ASSIGNMENT(=)
USE kind_mod, ONLY : I4, TF
IMPLICIT NONE
INTEGER(I4), DIMENSION(12_I4), TARGET :: ia
LOGICAL(TF), DIMENSION(2_I4,3_I4) :: la
TYPE(pvt), DIMENSION(6_I4) :: pv
INTEGER(I4) :: i
! Initialisation...
la(:,1_I4:3_I4:2_I4)=.TRUE._TF
la(:,2_I4)=.FALSE._TF
DO i=1_I4,6_I4
pv(i)%vect => ia((2_I4*i-1_I4):(2_I4*i))
END DO
ia=0_I4
DO i=1_I4,3_I4
WHERE(la((/1_I4,2_I4/),i))
pv((2_I4*i-1_I4):(2_I4*i))= iaef((/(2_I4*i-1_I4),(2_I4*i)/))
ELSEWHERE
pv((2_I4*i-1_I4):(2_I4*i))= iaef((/0_I4,0_I4/))
END WHERE
END DO
if (any (ia .ne. (/1,-1,2,-2,0,0,0,0,5,-5,6,-6/))) call abort ()
CONTAINS
TYPE(pvt) ELEMENTAL FUNCTION iaef(index) RESULT(ans)
USE kind_mod, ONLY : I4
USE pointer_mod, ONLY : pvt, ASSIGNMENT(=)
IMPLICIT NONE
INTEGER(I4), INTENT(IN) :: index
ALLOCATE(ans%vect(2_I4))
ans%vect=(/index,-index/)
END FUNCTION iaef
END PROGRAM test_prog
|
