gcc/testsuite/gfortran.dg/elemental_optional_args_5.f03

! { dg-do run }
!
! PR fortran/50981
! Test the handling of optional, polymorphic and non-polymorphic arguments
! to elemental procedures. 
!
! Original testcase by Tobias Burnus <burnus@net-b.de>

implicit none
type t
  integer :: a
end type t

type t2
  integer, allocatable :: a
  integer, allocatable :: a2(:)
  integer, pointer :: p => null()
  integer, pointer :: p2(:) => null()
end type t2

type(t), allocatable :: ta, taa(:)
type(t), pointer :: tp, tpa(:)
class(t), allocatable :: ca, caa(:)
class(t), pointer :: cp, cpa(:)

type(t2) :: x

integer :: s, v(2)

tp => null()
tpa => null()
cp => null()
cpa => null()

! =============== sub1 ==================
! SCALAR COMPONENTS: Non alloc/assoc

s = 3
v = [9, 33]

call sub1 (s, x%a, .false.)
call sub1 (v, x%a, .false.)
!print *, s, v
if (s /= 3) STOP 1
if (any (v /= [9, 33])) STOP 2

call sub1 (s, x%p, .false.)
call sub1 (v, x%p, .false.)
!print *, s, v
if (s /= 3) STOP 3
if (any (v /= [9, 33])) STOP 4


! SCALAR COMPONENTS: alloc/assoc

allocate (x%a, x%p)
x%a = 4
x%p = 5
call sub1 (s, x%a, .true.)
call sub1 (v, x%a, .true.)
!print *, s, v
if (s /= 4*2) STOP 5
if (any (v /= [4*2, 4*2])) STOP 6

call sub1 (s, x%p, .true.)
call sub1 (v, x%p, .true.)
!print *, s, v
if (s /= 5*2) STOP 7
if (any (v /= [5*2, 5*2])) STOP 8


! ARRAY COMPONENTS: Non alloc/assoc

v = [9, 33]

call sub1 (v, x%a2, .false.)
!print *, v
if (any (v /= [9, 33])) STOP 9

call sub1 (v, x%p2, .false.)
!print *, v
if (any (v /= [9, 33])) STOP 10


! ARRAY COMPONENTS: alloc/assoc

allocate (x%a2(2), x%p2(2))
x%a2(:) = [84, 82]
x%p2    = [35, 58]

call sub1 (v, x%a2, .true.)
!print *, v
if (any (v /= [84*2, 82*2])) STOP 11

call sub1 (v, x%p2, .true.)
!print *, v
if (any (v /= [35*2, 58*2])) STOP 12


! =============== sub_t ==================
! SCALAR DT: Non alloc/assoc

s = 3
v = [9, 33]

call sub_t (s, ta, .false.)
call sub_t (v, ta, .false.)
!print *, s, v
if (s /= 3) STOP 13
if (any (v /= [9, 33])) STOP 14

call sub_t (s, tp, .false.)
call sub_t (v, tp, .false.)
!print *, s, v
if (s /= 3) STOP 15
if (any (v /= [9, 33])) STOP 16

call sub_t (s, ca, .false.)
call sub_t (v, ca, .false.)
!print *, s, v
if (s /= 3) STOP 17
if (any (v /= [9, 33])) STOP 18

call sub_t (s, cp, .false.)
call sub_t (v, cp, .false.)
!print *, s, v
if (s /= 3) STOP 19
if (any (v /= [9, 33])) STOP 20

! SCALAR COMPONENTS: alloc/assoc

allocate (ta, tp, ca, cp)
ta%a = 4
tp%a = 5
ca%a = 6
cp%a = 7

call sub_t (s, ta, .true.)
call sub_t (v, ta, .true.)
!print *, s, v
if (s /= 4*2) STOP 21
if (any (v /= [4*2, 4*2])) STOP 22

call sub_t (s, tp, .true.)
call sub_t (v, tp, .true.)
!print *, s, v
if (s /= 5*2) STOP 23
if (any (v /= [5*2, 5*2])) STOP 24

call sub_t (s, ca, .true.)
call sub_t (v, ca, .true.)
!print *, s, v
if (s /= 6*2) STOP 25
if (any (v /= [6*2, 6*2])) STOP 26

call sub_t (s, cp, .true.)
call sub_t (v, cp, .true.)
!print *, s, v
if (s /= 7*2) STOP 27
if (any (v /= [7*2, 7*2])) STOP 28

! ARRAY COMPONENTS: Non alloc/assoc

v = [9, 33]

call sub_t (v, taa, .false.)
!print *, v
if (any (v /= [9, 33])) STOP 29

call sub_t (v, tpa, .false.)
!print *, v
if (any (v /= [9, 33])) STOP 30

call sub_t (v, caa, .false.)
!print *, v
if (any (v /= [9, 33])) STOP 31

call sub_t (v, cpa, .false.)
!print *, v
if (any (v /= [9, 33])) STOP 32

deallocate(ta, tp, ca, cp)


! ARRAY COMPONENTS: alloc/assoc

allocate (taa(2), tpa(2))
taa(1:2)%a = [44, 444]
tpa(1:2)%a = [55, 555]
allocate (caa(2), source=[t(66), t(666)])
allocate (cpa(2), source=[t(77), t(777)])

select type (caa)
type is (t)
  if (any (caa(:)%a /= [66, 666])) STOP 33
end select

select type (cpa)
type is (t)
  if (any (cpa(:)%a /= [77, 777])) STOP 34
end select

call sub_t (v, taa, .true.)
!print *, v
if (any (v /= [44*2, 444*2])) STOP 35

call sub_t (v, tpa, .true.)
!print *, v
if (any (v /= [55*2, 555*2])) STOP 36


call sub_t (v, caa, .true.)
!print *, v
if (any (v /= [66*2, 666*2])) STOP 37

call sub_t (v, cpa, .true.)
!print *, v
if (any (v /= [77*2, 777*2])) STOP 38

deallocate (taa, tpa, caa, cpa)


contains

  elemental subroutine sub1 (x, y, alloc)
    integer, intent(inout) :: x
    integer, intent(in), optional :: y
    logical, intent(in) :: alloc
    if (alloc .neqv. present (y)) &
      x = -99
    if (present(y)) &
      x = y*2
  end subroutine sub1

  elemental subroutine sub_t(x, y, alloc)
    integer, intent(inout) :: x
    type(t), intent(in), optional :: y
    logical, intent(in) :: alloc
    if (alloc .neqv. present (y)) &
      x = -99
    if (present(y)) &
      x = y%a*2
  end subroutine sub_t

end