gcc/testsuite/gfortran.dg/elemental_optional_args_5.f03

   1 ! { dg-do run }
   2 !
   3 ! PR fortran/50981
   4 ! Test the handling of optional, polymorphic and non-polymorphic arguments
   5 ! to elemental procedures.
   6 !
   7 ! Original testcase by Tobias Burnus <burnus@net-b.de>
   8
   9 implicit none
  10 type t
  11   integer :: a
  12 end type t
  13
  14 type t2
  15   integer, allocatable :: a
  16   integer, allocatable :: a2(:)
  17   integer, pointer :: p => null()
  18   integer, pointer :: p2(:) => null()
  19 end type t2
  20
  21 type(t), allocatable :: ta, taa(:)
  22 type(t), pointer :: tp, tpa(:)
  23 class(t), allocatable :: ca, caa(:)
  24 class(t), pointer :: cp, cpa(:)
  25
  26 type(t2) :: x
  27
  28 integer :: s, v(2)
  29
  30 tp => null()
  31 tpa => null()
  32 cp => null()
  33 cpa => null()
  34
  35 ! =============== sub1 ==================
  36 ! SCALAR COMPONENTS: Non alloc/assoc
  37
  38 s = 3
  39 v = [9, 33]
  40
  41 call sub1 (s, x%a, .false.)
  42 call sub1 (v, x%a, .false.)
  43 !print *, s, v
  44 if (s /= 3) call abort()
  45 if (any (v /= [9, 33])) call abort()
  46
  47 call sub1 (s, x%p, .false.)
  48 call sub1 (v, x%p, .false.)
  49 !print *, s, v
  50 if (s /= 3) call abort()
  51 if (any (v /= [9, 33])) call abort()
  52
  53
  54 ! SCALAR COMPONENTS: alloc/assoc
  55
  56 allocate (x%a, x%p)
  57 x%a = 4
  58 x%p = 5
  59 call sub1 (s, x%a, .true.)
  60 call sub1 (v, x%a, .true.)
  61 !print *, s, v
  62 if (s /= 4*2) call abort()
  63 if (any (v /= [4*2, 4*2])) call abort()
  64
  65 call sub1 (s, x%p, .true.)
  66 call sub1 (v, x%p, .true.)
  67 !print *, s, v
  68 if (s /= 5*2) call abort()
  69 if (any (v /= [5*2, 5*2])) call abort()
  70
  71
  72
  73 contains
  74
  75   elemental subroutine sub1 (x, y, alloc)
  76     integer, intent(inout) :: x
  77     integer, intent(in), optional :: y
  78     logical, intent(in) :: alloc
  79     if (alloc .neqv. present (y)) &
  80       x = -99
  81     if (present(y)) &
  82       x = y*2
  83   end subroutine sub1
  84
  85 end
  86