gcc/testsuite/gfortran.dg/elemental_subroutine_11.f90

   1 ! { dg-do run }
   2 !
   3 ! Check error of pr65894 are fixed.
   4 ! Contributed by Juergen Reuter  <juergen.reuter@desy.de>
   5 !                Andre Vehreschild  <vehre@gcc.gnu.org>
   6
   7 module simple_string
   8   ! Minimal iso_varying_string implementation needed.
   9   implicit none
  10
  11   type string_t
  12     private
  13     character(len=1), dimension(:), allocatable :: cs
  14   end type string_t
  15
  16 contains
  17   elemental function var_str(c) result (s)
  18     character(*), intent(in) :: c
  19     type(string_t) :: s
  20     integer :: l,i
  21
  22     l = len(c)
  23     allocate(s%cs(l))
  24     forall(i = 1:l)
  25       s%cs(i) = c(i:i)
  26     end forall
  27   end function var_str
  28
  29 end module simple_string
  30 module model_data
  31   use simple_string
  32
  33   implicit none
  34   private
  35
  36   public :: field_data_t
  37   public :: model_data_t
  38
  39   type :: field_data_t
  40      !private
  41      integer :: pdg = 0
  42      type(string_t), dimension(:), allocatable :: name
  43    contains
  44      procedure :: init => field_data_init
  45      procedure :: get_pdg => field_data_get_pdg
  46   end type field_data_t
  47
  48   type :: model_data_t
  49      !private
  50      type(string_t) :: name
  51      type(field_data_t), dimension(:), allocatable :: field
  52    contains
  53      generic :: init => model_data_init
  54      procedure, private :: model_data_init
  55      generic :: get_pdg => &
  56           model_data_get_field_pdg_index
  57      procedure, private :: model_data_get_field_pdg_index
  58      generic :: get_field_ptr => &
  59           model_data_get_field_ptr_pdg
  60      procedure, private :: model_data_get_field_ptr_pdg
  61      procedure :: get_field_ptr_by_index => model_data_get_field_ptr_index
  62      procedure :: init_sm_test => model_data_init_sm_test
  63   end type model_data_t
  64
  65 contains
  66
  67   subroutine field_data_init (prt, pdg)
  68     class(field_data_t), intent(out) :: prt
  69     integer, intent(in) :: pdg
  70     prt%pdg = pdg
  71   end subroutine field_data_init
  72
  73   elemental function field_data_get_pdg (prt) result (pdg)
  74     integer :: pdg
  75     class(field_data_t), intent(in) :: prt
  76     pdg = prt%pdg
  77   end function field_data_get_pdg
  78
  79   subroutine model_data_init (model, name, &
  80        n_field)
  81     class(model_data_t), intent(out) :: model
  82     type(string_t), intent(in) :: name
  83     integer, intent(in) :: n_field
  84     model%name = name
  85     allocate (model%field (n_field))
  86   end subroutine model_data_init
  87
  88   function model_data_get_field_pdg_index (model, i) result (pdg)
  89     class(model_data_t), intent(in) :: model
  90     integer, intent(in) :: i
  91     integer :: pdg
  92     pdg = model%field(i)%get_pdg ()
  93   end function model_data_get_field_pdg_index
  94
  95   function model_data_get_field_ptr_pdg (model, pdg, check) result (ptr)
  96     class(model_data_t), intent(in), target :: model
  97     integer, intent(in) :: pdg
  98     logical, intent(in), optional :: check
  99     type(field_data_t), pointer :: ptr
 100     integer :: i, pdg_abs
 101     if (pdg == 0) then
 102        ptr => null ()
 103        return
 104     end if
 105     pdg_abs = abs (pdg)
 106     if (lbound(model%field, 1) /= 1) STOP 1
 107     if (ubound(model%field, 1) /= 19) STOP 2
 108     do i = 1, size (model%field)
 109        if (model%field(i)%get_pdg () == pdg_abs) then
 110           ptr => model%field(i)
 111           return
 112        end if
 113     end do
 114     ptr => null ()
 115   end function model_data_get_field_ptr_pdg
 116
 117   function model_data_get_field_ptr_index (model, i) result (ptr)
 118     class(model_data_t), intent(in), target :: model
 119     integer, intent(in) :: i
 120     type(field_data_t), pointer :: ptr
 121     if (lbound(model%field, 1) /= 1) STOP 3
 122     if (ubound(model%field, 1) /= 19) STOP 4
 123     ptr => model%field(i)
 124   end function model_data_get_field_ptr_index
 125
 126   subroutine model_data_init_sm_test (model)
 127     class(model_data_t), intent(out) :: model
 128     type(field_data_t), pointer :: field
 129     integer, parameter :: n_field = 19
 130     call model%init (var_str ("SM_test"), &
 131          n_field)
 132     field => model%get_field_ptr_by_index (1)
 133     call field%init (1)
 134   end subroutine model_data_init_sm_test
 135
 136 end module model_data
 137
 138 module flavors
 139   use model_data
 140
 141   implicit none
 142   private
 143
 144   public :: flavor_t
 145
 146   type :: flavor_t
 147      private
 148      integer :: f = 0
 149      type(field_data_t), pointer :: field_data => null ()
 150    contains
 151      generic :: init => &
 152           flavor_init0_model
 153      procedure, private :: flavor_init0_model
 154   end type flavor_t
 155
 156 contains
 157
 158   impure elemental subroutine flavor_init0_model (flv, f, model)
 159     class(flavor_t), intent(inout) :: flv
 160     integer, intent(in) :: f
 161     class(model_data_t), intent(in), target :: model
 162     ! Check the field l/ubound at various stages, because w/o the patch
 163     ! the bounds get mixed up.
 164     if (lbound(model%field, 1) /= 1) STOP 5
 165     if (ubound(model%field, 1) /= 19) STOP 6
 166     flv%f = f
 167     flv%field_data => model%get_field_ptr (f, check=.true.)
 168   end subroutine flavor_init0_model
 169 end module flavors
 170
 171 module beams
 172   use model_data
 173   use flavors
 174   implicit none
 175   private
 176   public :: beam_1
 177   public :: beam_2
 178 contains
 179   subroutine beam_1 (u)
 180     integer, intent(in) :: u
 181     type(flavor_t), dimension(2) :: flv
 182     real, dimension(2) :: pol_f
 183     type(model_data_t), target :: model
 184     call model%init_sm_test ()
 185     call flv%init ([1,-1], model)
 186     pol_f(1) = 0.5
 187   end subroutine beam_1
 188   subroutine beam_2 (u, model)
 189     integer, intent(in) :: u
 190     type(flavor_t), dimension(2) :: flv
 191     real, dimension(2) :: pol_f
 192     class(model_data_t), intent(in), target :: model
 193     call flv%init ([1,-1], model)
 194     pol_f(1) = 0.5
 195   end subroutine beam_2
 196 end module beams
 197
 198 module evaluators
 199   ! This module is just here for a compile check.
 200   implicit none
 201   private
 202   type :: quantum_numbers_mask_t
 203    contains
 204      generic :: operator(.or.) => quantum_numbers_mask_or
 205      procedure, private :: quantum_numbers_mask_or
 206   end type quantum_numbers_mask_t
 207
 208   type :: index_map_t
 209      integer, dimension(:), allocatable :: entry
 210   end type index_map_t
 211   type :: prt_mask_t
 212      logical, dimension(:), allocatable :: entry
 213   end type prt_mask_t
 214   type :: qn_mask_array_t
 215      type(quantum_numbers_mask_t), dimension(:), allocatable :: mask
 216   end type qn_mask_array_t
 217
 218 contains
 219   elemental function quantum_numbers_mask_or (mask1, mask2) result (mask)
 220     type(quantum_numbers_mask_t) :: mask
 221     class(quantum_numbers_mask_t), intent(in) :: mask1, mask2
 222   end function quantum_numbers_mask_or
 223
 224   subroutine make_product_interaction &
 225       (prt_is_connected, qn_mask_in, qn_mask_rest)
 226     type(prt_mask_t), dimension(2), intent(in) :: prt_is_connected
 227     type(qn_mask_array_t), dimension(2), intent(in) :: qn_mask_in
 228     type(quantum_numbers_mask_t), intent(in) :: qn_mask_rest
 229     type(index_map_t), dimension(2) :: prt_index_in
 230     integer :: i
 231     type(quantum_numbers_mask_t), dimension(:), allocatable :: qn_mask
 232     allocate (qn_mask (2))
 233     do i = 1, 2
 234        qn_mask(prt_index_in(i)%entry) = &
 235             pack (qn_mask_in(i)%mask, prt_is_connected(i)%entry) &
 236             .or. qn_mask_rest
 237       ! Without the patch above line produced an ICE.
 238     end do
 239   end subroutine make_product_interaction
 240 end module evaluators
 241 program main
 242   use beams
 243   use model_data
 244   type(model_data_t) :: model
 245   call model%init_sm_test()
 246   call beam_1 (6)
 247   call beam_2 (6, model)
 248 end program main