109 lines
2.4 KiB
Fortran
109 lines
2.4 KiB
Fortran
! { 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
|
|
|
|
! { dg-final { cleanup-modules "kind_mod pointer_mod" } }
|