gcc/testsuite/gfortran.dg/select_type_47.f90

   1 ! { dg-do compile }
   2 !
   3 ! PR fortran/87632
   4 !
   5 ! Contributed by Jürgen Reuter
   6 !
   7 module m
   8 type t
   9   integer :: i
  10 end type t
  11 type t2
  12   type(t) :: phs_config
  13 end type t2
  14 end module m
  15
  16 module m2
  17 use m
  18 implicit none
  19 type t3
  20 end type t3
  21
  22 type process_t
  23   private
  24   type(t2), allocatable :: component(:)
  25 contains
  26   procedure :: get_phs_config => process_get_phs_config
  27 end type process_t
  28
  29 contains
  30   subroutine process_extract_resonance_history_set &
  31        (process, include_trivial, i_component)
  32     class(process_t), intent(in), target :: process
  33     logical, intent(in), optional :: include_trivial
  34     integer, intent(in), optional :: i_component
  35     integer :: i
  36     i = 1;  if (present (i_component))  i = i_component
  37     select type (phs_config => process%get_phs_config (i))
  38     class is (t)
  39        call foo()
  40     class default
  41        call bar()
  42     end select
  43   end subroutine process_extract_resonance_history_set
  44
  45   function process_get_phs_config (process, i_component) result (phs_config)
  46     class(t), pointer :: phs_config
  47     class(process_t), intent(in), target :: process
  48     integer, intent(in) :: i_component
  49     if (allocated (process%component)) then
  50        phs_config => process%component(i_component)%phs_config
  51     else
  52        phs_config => null ()
  53     end if
  54   end function process_get_phs_config
  55 end module m2
  56
  57 program main
  58   use m2
  59 end program main