! { 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 !============================================================================== 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