where_operator_assign_1.f90   [plain text]

! { 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" } }