gcc/testsuite/gfortran.dg/allocate_with_source_5.f90

   1 ! { dg-do run }
   2 !
   3 ! Contributed by Juergen Reuter
   4 ! Check that pr65548 is fixed.
   5 !
   6
   7 module selectors
   8   type :: selector_t
   9      integer, dimension(:), allocatable :: map
  10      real, dimension(:), allocatable :: weight
  11    contains
  12      procedure :: init => selector_init
  13    end type selector_t
  14
  15 contains
  16
  17   subroutine selector_init (selector, weight)
  18     class(selector_t), intent(out) :: selector
  19     real, dimension(:), intent(in) :: weight
  20     real :: s
  21     integer :: n, i
  22     logical, dimension(:), allocatable :: mask
  23     s = sum (weight)
  24     allocate (mask (size (weight)), source = weight /= 0)
  25     n = count (mask)
  26     if (n > 0) then
  27        allocate (selector%map (n), &
  28             source = pack ([(i, i = 1, size (weight))], mask))
  29        allocate (selector%weight (n), &
  30             source = pack (weight / s, mask))
  31     else
  32        allocate (selector%map (1), source = 1)
  33        allocate (selector%weight (1), source = 0.)
  34     end if
  35   end subroutine selector_init
  36
  37 end module selectors
  38
  39 module phs_base
  40   type :: flavor_t
  41   contains
  42      procedure :: get_mass => flavor_get_mass
  43   end type flavor_t
  44
  45   type :: phs_config_t
  46      integer :: n_in = 0
  47      type(flavor_t), dimension(:,:), allocatable :: flv
  48   end type phs_config_t
  49
  50   type :: phs_t
  51      class(phs_config_t), pointer :: config => null ()
  52      real, dimension(:), allocatable :: m_in
  53   end type phs_t
  54
  55 contains
  56
  57   elemental function flavor_get_mass (flv) result (mass)
  58     real :: mass
  59     class(flavor_t), intent(in) :: flv
  60     mass = 42.0
  61   end function flavor_get_mass
  62
  63   subroutine phs_base_init (phs, phs_config)
  64     class(phs_t), intent(out) :: phs
  65     class(phs_config_t), intent(in), target :: phs_config
  66     phs%config => phs_config
  67     allocate (phs%m_in  (phs%config%n_in), &
  68          source = phs_config%flv(:phs_config%n_in, 1)%get_mass ())
  69   end subroutine phs_base_init
  70
  71 end module phs_base
  72
  73 module foo
  74   type :: t
  75      integer :: n
  76      real, dimension(:,:), allocatable :: val
  77    contains
  78      procedure :: make => t_make
  79      generic :: get_int => get_int_array, get_int_element
  80      procedure :: get_int_array => t_get_int_array
  81      procedure :: get_int_element => t_get_int_element
  82   end type t
  83
  84 contains
  85
  86   subroutine t_make (this)
  87     class(t), intent(inout) :: this
  88     real, dimension(:), allocatable :: int
  89     allocate (int (0:this%n-1), source=this%get_int())
  90   end subroutine t_make
  91
  92   pure function t_get_int_array (this) result (array)
  93     class(t), intent(in) :: this
  94     real, dimension(this%n) :: array
  95     array = this%val (0:this%n-1, 4)
  96   end function t_get_int_array
  97
  98   pure function t_get_int_element (this, set) result (element)
  99     class(t), intent(in) :: this
 100     integer, intent(in) :: set
 101     real :: element
 102     element = this%val (set, 4)
 103   end function t_get_int_element
 104 end module foo
 105 module foo2
 106   type :: t2
 107      integer :: n
 108      character(32), dimension(:), allocatable :: md5
 109    contains
 110      procedure :: init => t2_init
 111   end type t2
 112
 113 contains
 114
 115   subroutine t2_init (this)
 116     class(t2), intent(inout) :: this
 117     character(32), dimension(:), allocatable :: md5
 118     allocate (md5 (this%n), source=this%md5)
 119     if (md5(1) /= "tst                             ") STOP 1
 120     if (md5(2) /= "                                ") STOP 2
 121     if (md5(3) /= "fooblabar                       ") STOP 3
 122   end subroutine t2_init
 123 end module foo2
 124
 125 program test
 126   use selectors
 127   use phs_base
 128   use foo
 129   use foo2
 130
 131   type(selector_t) :: sel
 132   type(phs_t) :: phs
 133   type(phs_config_t) :: phs_config
 134   type(t) :: o
 135   type(t2) :: o2
 136
 137   call sel%init([2., 0., 3., 0., 4.])
 138
 139   if (any(sel%map /= [1, 3, 5])) STOP 4
 140   if (any(abs(sel%weight - [2., 3., 4.] / 9.) > 1E-6)) STOP 5
 141
 142   phs_config%n_in = 2
 143   allocate (phs_config%flv (phs_config%n_in, 1))
 144   call phs_base_init (phs, phs_config)
 145
 146   if (any(abs(phs%m_in - [42.0, 42.0]) > 1E-6)) STOP 6
 147
 148   o%n = 2
 149   allocate (o%val(0:1,4))
 150   call o%make()
 151
 152   o2%n = 3
 153   allocate(o2%md5(o2%n))
 154   o2%md5(1) = "tst"
 155   o2%md5(2) = ""
 156   o2%md5(3) = "fooblabar"
 157   call o2%init()
 158 end program test
 159