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 9implicit none 10type t 11 integer :: a 12end type t 13 14type t2 15 integer, allocatable :: a 16 integer, allocatable :: a2(:) 17 integer, pointer :: p => null() 18 integer, pointer :: p2(:) => null() 19end type t2 20 21type(t), allocatable :: ta, taa(:) 22type(t), pointer :: tp, tpa(:) 23class(t), allocatable :: ca, caa(:) 24class(t), pointer :: cp, cpa(:) 25 26type(t2) :: x 27 28integer :: s, v(2) 29 30tp => null() 31tpa => null() 32cp => null() 33cpa => null() 34 35! =============== sub1 ================== 36! SCALAR COMPONENTS: Non alloc/assoc 37 38s = 3 39v = [9, 33] 40 41call sub1 (s, x%a, .false.) 42call sub1 (v, x%a, .false.) 43!print *, s, v 44if (s /= 3) call abort() 45if (any (v /= [9, 33])) call abort() 46 47call sub1 (s, x%p, .false.) 48call sub1 (v, x%p, .false.) 49!print *, s, v 50if (s /= 3) call abort() 51if (any (v /= [9, 33])) call abort() 52 53 54! SCALAR COMPONENTS: alloc/assoc 55 56allocate (x%a, x%p) 57x%a = 4 58x%p = 5 59call sub1 (s, x%a, .true.) 60call sub1 (v, x%a, .true.) 61!print *, s, v 62if (s /= 4*2) call abort() 63if (any (v /= [4*2, 4*2])) call abort() 64 65call sub1 (s, x%p, .true.) 66call sub1 (v, x%p, .true.) 67!print *, s, v 68if (s /= 5*2) call abort() 69if (any (v /= [5*2, 5*2])) call abort() 70 71 72! ARRAY COMPONENTS: Non alloc/assoc 73 74v = [9, 33] 75 76call sub1 (v, x%a2, .false.) 77!print *, v 78if (any (v /= [9, 33])) call abort() 79 80call sub1 (v, x%p2, .false.) 81!print *, v 82if (any (v /= [9, 33])) call abort() 83 84 85! ARRAY COMPONENTS: alloc/assoc 86 87allocate (x%a2(2), x%p2(2)) 88x%a2(:) = [84, 82] 89x%p2 = [35, 58] 90 91call sub1 (v, x%a2, .true.) 92!print *, v 93if (any (v /= [84*2, 82*2])) call abort() 94 95call sub1 (v, x%p2, .true.) 96!print *, v 97if (any (v /= [35*2, 58*2])) call abort() 98 99 100! =============== sub_t ================== 101! SCALAR DT: Non alloc/assoc 102 103s = 3 104v = [9, 33] 105 106call sub_t (s, ta, .false.) 107call sub_t (v, ta, .false.) 108!print *, s, v 109if (s /= 3) call abort() 110if (any (v /= [9, 33])) call abort() 111 112call sub_t (s, tp, .false.) 113call sub_t (v, tp, .false.) 114!print *, s, v 115if (s /= 3) call abort() 116if (any (v /= [9, 33])) call abort() 117 118call sub_t (s, ca, .false.) 119call sub_t (v, ca, .false.) 120!print *, s, v 121if (s /= 3) call abort() 122if (any (v /= [9, 33])) call abort() 123 124call sub_t (s, cp, .false.) 125call sub_t (v, cp, .false.) 126!print *, s, v 127if (s /= 3) call abort() 128if (any (v /= [9, 33])) call abort() 129 130! SCALAR COMPONENTS: alloc/assoc 131 132allocate (ta, tp, ca, cp) 133ta%a = 4 134tp%a = 5 135ca%a = 6 136cp%a = 7 137 138call sub_t (s, ta, .true.) 139call sub_t (v, ta, .true.) 140!print *, s, v 141if (s /= 4*2) call abort() 142if (any (v /= [4*2, 4*2])) call abort() 143 144call sub_t (s, tp, .true.) 145call sub_t (v, tp, .true.) 146!print *, s, v 147if (s /= 5*2) call abort() 148if (any (v /= [5*2, 5*2])) call abort() 149 150call sub_t (s, ca, .true.) 151call sub_t (v, ca, .true.) 152!print *, s, v 153if (s /= 6*2) call abort() 154if (any (v /= [6*2, 6*2])) call abort() 155 156call sub_t (s, cp, .true.) 157call sub_t (v, cp, .true.) 158!print *, s, v 159if (s /= 7*2) call abort() 160if (any (v /= [7*2, 7*2])) call abort() 161 162! ARRAY COMPONENTS: Non alloc/assoc 163 164v = [9, 33] 165 166call sub_t (v, taa, .false.) 167!print *, v 168if (any (v /= [9, 33])) call abort() 169 170call sub_t (v, tpa, .false.) 171!print *, v 172if (any (v /= [9, 33])) call abort() 173 174call sub_t (v, caa, .false.) 175!print *, v 176if (any (v /= [9, 33])) call abort() 177 178call sub_t (v, cpa, .false.) 179!print *, v 180if (any (v /= [9, 33])) call abort() 181 182deallocate(ta, tp, ca, cp) 183 184 185! ARRAY COMPONENTS: alloc/assoc 186 187allocate (taa(2), tpa(2)) 188taa(1:2)%a = [44, 444] 189tpa(1:2)%a = [55, 555] 190allocate (caa(2), source=[t(66), t(666)]) 191allocate (cpa(2), source=[t(77), t(777)]) 192 193select type (caa) 194type is (t) 195 if (any (caa(:)%a /= [66, 666])) call abort() 196end select 197 198select type (cpa) 199type is (t) 200 if (any (cpa(:)%a /= [77, 777])) call abort() 201end select 202 203call sub_t (v, taa, .true.) 204!print *, v 205if (any (v /= [44*2, 444*2])) call abort() 206 207call sub_t (v, tpa, .true.) 208!print *, v 209if (any (v /= [55*2, 555*2])) call abort() 210 211 212call sub_t (v, caa, .true.) 213!print *, v 214if (any (v /= [66*2, 666*2])) call abort() 215 216call sub_t (v, cpa, .true.) 217!print *, v 218if (any (v /= [77*2, 777*2])) call abort() 219 220deallocate (taa, tpa, caa, cpa) 221 222 223contains 224 225 elemental subroutine sub1 (x, y, alloc) 226 integer, intent(inout) :: x 227 integer, intent(in), optional :: y 228 logical, intent(in) :: alloc 229 if (alloc .neqv. present (y)) & 230 x = -99 231 if (present(y)) & 232 x = y*2 233 end subroutine sub1 234 235 elemental subroutine sub_t(x, y, alloc) 236 integer, intent(inout) :: x 237 type(t), intent(in), optional :: y 238 logical, intent(in) :: alloc 239 if (alloc .neqv. present (y)) & 240 x = -99 241 if (present(y)) & 242 x = y%a*2 243 end subroutine sub_t 244 245end 246 247