gcc/testsuite/gfortran.dg/select_type_7.f03

   1 ! { dg-do run }
   2 !
   3 ! PR 41766: [OOP] SELECT TYPE selector as actual argument with INTENT(INOUT)
   4 !
   5 ! Contributed by Janus Weil <janus@gcc.gnu.org>
   6
   7  implicit none
   8
   9  type t1
  10    integer :: a
  11  end type
  12
  13  type, extends(t1) :: t2
  14    integer :: b
  15  end type
  16
  17  class(t1),allocatable :: cp
  18
  19  allocate(t2 :: cp)
  20
  21  select type (cp)
  22    type is (t2)
  23      cp%a = 98
  24      cp%b = 76
  25      call s(cp)
  26      print *,cp%a,cp%b
  27      if (cp%a /= cp%b) STOP 1
  28    class default
  29      STOP 2
  30  end select
  31
  32 contains
  33
  34   subroutine s(f)
  35     type(t2), intent(inout) :: f
  36     f%a = 3
  37     f%b = 3
  38   end subroutine
  39
  40 end