1! { dg-do run } 2! { dg-options "-fcoarray=single" } 3! 4! PR fortran/50981 5! PR fortran/54618 6! 7 8 implicit none 9 type t 10 integer, allocatable :: i 11 end type t 12 type, extends (t):: t2 13 integer, allocatable :: j 14 end type t2 15 16 class(t), allocatable :: xa, xa2(:), xac[:], xa2c(:)[:] 17 class(t), pointer :: xp, xp2(:) 18 19 xp => null() 20 xp2 => null() 21 22 call suba(alloc=.false., prsnt=.false.) 23 call suba(xa, alloc=.false., prsnt=.true.) 24 if (.not. allocated (xa)) call abort () 25 if (.not. allocated (xa%i)) call abort () 26 if (xa%i /= 5) call abort () 27 xa%i = -3 28 call suba(xa, alloc=.true., prsnt=.true.) 29 if (allocated (xa)) call abort () 30 31 call suba2(alloc=.false., prsnt=.false.) 32 call suba2(xa2, alloc=.false., prsnt=.true.) 33 if (.not. allocated (xa2)) call abort () 34 if (size (xa2) /= 1) call abort () 35 if (.not. allocated (xa2(1)%i)) call abort () 36 if (xa2(1)%i /= 5) call abort () 37 xa2(1)%i = -3 38 call suba2(xa2, alloc=.true., prsnt=.true.) 39 if (allocated (xa2)) call abort () 40 41 call subp(alloc=.false., prsnt=.false.) 42 call subp(xp, alloc=.false., prsnt=.true.) 43 if (.not. associated (xp)) call abort () 44 if (.not. allocated (xp%i)) call abort () 45 if (xp%i /= 5) call abort () 46 xp%i = -3 47 call subp(xp, alloc=.true., prsnt=.true.) 48 if (associated (xp)) call abort () 49 50 call subp2(alloc=.false., prsnt=.false.) 51 call subp2(xp2, alloc=.false., prsnt=.true.) 52 if (.not. associated (xp2)) call abort () 53 if (size (xp2) /= 1) call abort () 54 if (.not. allocated (xp2(1)%i)) call abort () 55 if (xp2(1)%i /= 5) call abort () 56 xp2(1)%i = -3 57 call subp2(xp2, alloc=.true., prsnt=.true.) 58 if (associated (xp2)) call abort () 59 60 call subac(alloc=.false., prsnt=.false.) 61 call subac(xac, alloc=.false., prsnt=.true.) 62 if (.not. allocated (xac)) call abort () 63 if (.not. allocated (xac%i)) call abort () 64 if (xac%i /= 5) call abort () 65 xac%i = -3 66 call subac(xac, alloc=.true., prsnt=.true.) 67 if (allocated (xac)) call abort () 68 69 call suba2c(alloc=.false., prsnt=.false.) 70 call suba2c(xa2c, alloc=.false., prsnt=.true.) 71 if (.not. allocated (xa2c)) call abort () 72 if (size (xa2c) /= 1) call abort () 73 if (.not. allocated (xa2c(1)%i)) call abort () 74 if (xa2c(1)%i /= 5) call abort () 75 xa2c(1)%i = -3 76 call suba2c(xa2c, alloc=.true., prsnt=.true.) 77 if (allocated (xa2c)) call abort () 78 79contains 80 subroutine suba2c(x, prsnt, alloc) 81 class(t), optional, allocatable :: x(:)[:] 82 logical prsnt, alloc 83 if (present (x) .neqv. prsnt) call abort () 84 if (prsnt) then 85 if (alloc .neqv. allocated(x)) call abort () 86 if (.not. allocated (x)) then 87 allocate (x(1)[*]) 88 x(1)%i = 5 89 else 90 if (x(1)%i /= -3) call abort() 91 deallocate (x) 92 end if 93 end if 94 end subroutine suba2c 95 96 subroutine subac(x, prsnt, alloc) 97 class(t), optional, allocatable :: x[:] 98 logical prsnt, alloc 99 if (present (x) .neqv. prsnt) call abort () 100 if (present (x)) then 101 if (alloc .neqv. allocated(x)) call abort () 102 if (.not. allocated (x)) then 103 allocate (x[*]) 104 x%i = 5 105 else 106 if (x%i /= -3) call abort() 107 deallocate (x) 108 end if 109 end if 110 end subroutine subac 111 112 subroutine suba2(x, prsnt, alloc) 113 class(t), optional, allocatable :: x(:) 114 logical prsnt, alloc 115 if (present (x) .neqv. prsnt) call abort () 116 if (prsnt) then 117 if (alloc .neqv. allocated(x)) call abort () 118 if (.not. allocated (x)) then 119 allocate (x(1)) 120 x(1)%i = 5 121 else 122 if (x(1)%i /= -3) call abort() 123 deallocate (x) 124 end if 125 end if 126 end subroutine suba2 127 128 subroutine suba(x, prsnt, alloc) 129 class(t), optional, allocatable :: x 130 logical prsnt, alloc 131 if (present (x) .neqv. prsnt) call abort () 132 if (present (x)) then 133 if (alloc .neqv. allocated(x)) call abort () 134 if (.not. allocated (x)) then 135 allocate (x) 136 x%i = 5 137 else 138 if (x%i /= -3) call abort() 139 deallocate (x) 140 end if 141 end if 142 end subroutine suba 143 144 subroutine subp2(x, prsnt, alloc) 145 class(t), optional, pointer :: x(:) 146 logical prsnt, alloc 147 if (present (x) .neqv. prsnt) call abort () 148 if (present (x)) then 149 if (alloc .neqv. associated(x)) call abort () 150 if (.not. associated (x)) then 151 allocate (x(1)) 152 x(1)%i = 5 153 else 154 if (x(1)%i /= -3) call abort() 155 deallocate (x) 156 end if 157 end if 158 end subroutine subp2 159 160 subroutine subp(x, prsnt, alloc) 161 class(t), optional, pointer :: x 162 logical prsnt, alloc 163 if (present (x) .neqv. prsnt) call abort () 164 if (present (x)) then 165 if (alloc .neqv. associated(x)) call abort () 166 if (.not. associated (x)) then 167 allocate (x) 168 x%i = 5 169 else 170 if (x%i /= -3) call abort() 171 deallocate (x) 172 end if 173 end if 174 end subroutine subp 175end 176