2 ! Tests the fix for PR30407, in which operator assignments did not work
3 ! in WHERE blocks or simple WHERE statements. This is the test provided
6 ! Contributed by Dominique d'Humieres <dominiq@lps.ens.fr>
7 !==============================================================================
15 INTEGER, PUBLIC
, PARAMETER :: I4
=SELECTED_INT_KIND(9)
16 INTEGER, PUBLIC
, PARAMETER :: TF
=KIND(.TRUE
._I4
)
20 !==============================================================================
24 USE kind_mod
, ONLY
: I4
31 INTEGER(I4
), POINTER, DIMENSION(:) :: vect
34 INTERFACE ASSIGNMENT(=)
35 MODULE PROCEDURE p_to_p
38 PUBLIC
:: ASSIGNMENT(=)
42 !---------------------------------------------------------------------------
44 PURE ELEMENTAL
SUBROUTINE p_to_p(a1
, a2
)
46 TYPE(pvt
), INTENT(OUT
) :: a1
47 TYPE(pvt
), INTENT(IN
) :: a2
51 !---------------------------------------------------------------------------
53 END MODULE pointer_mod
55 !==============================================================================
59 USE pointer_mod
, ONLY
: pvt
, ASSIGNMENT(=)
61 USE kind_mod
, ONLY
: I4
, TF
65 INTEGER(I4
), DIMENSION(12_I4
), TARGET
:: ia
66 LOGICAL(TF
), DIMENSION(2_I4
,3_I4
) :: la
67 TYPE(pvt
), DIMENSION(6_I4
) :: pv
71 la(:,1_I4
:3_I4
:2_I4
)=.TRUE
._TF
75 pv(i
)%vect
=> ia((2_I4
*i
-1_I4
):(2_I4
*i
))
81 WHERE(la((/1_I4
,2_I4
/),i
))
82 pv((2_I4
*i
-1_I4
):(2_I4
*i
))= iaef((/(2_I4
*i
-1_I4
),(2_I4
*i
)/))
84 pv((2_I4
*i
-1_I4
):(2_I4
*i
))= iaef((/0_I4
,0_I4
/))
88 if (any (ia
.ne
. (/1,-1,2,-2,0,0,0,0,5,-5,6,-6/))) STOP 1
92 TYPE(pvt
) ELEMENTAL
FUNCTION iaef(index
) RESULT(ans
)
94 USE kind_mod
, ONLY
: I4
95 USE pointer_mod
, ONLY
: pvt
, ASSIGNMENT(=)
99 INTEGER(I4
), INTENT(IN
) :: index
101 ALLOCATE(ans
%vect(2_I4
))
102 ans
%vect
=(/index
,-index
/)
106 END PROGRAM test_prog