1! { dg-do run } 2! { dg-skip-if "Too big for local store" { spu-*-* } { "*" } { "" } } 3! Tests the patch that implements F2003 automatic allocation and 4! reallocation of allocatable arrays on assignment. The tests 5! below were generated in the final stages of the development of 6! this patch. 7! test1 has been corrected for PR47051 8! 9! Contributed by Dominique Dhumieres <dominiq@lps.ens.fr> 10! and Tobias Burnus <burnus@gcc.gnu.org> 11! 12 integer :: nglobal 13 call test1 14 call test2 15 call test3 16 call test4 17 call test5 18 call test6 19 call test7 20 call test8 21contains 22 subroutine test1 23! 24! Check that the bounds are set correctly, when assigning 25! to an array that already has the correct shape. 26! 27 real :: a(10) = 1, b(51:60) = 2 28 real, allocatable :: c(:), d(:) 29 c=a 30 if (lbound (c, 1) .ne. lbound(a, 1)) call abort 31 if (ubound (c, 1) .ne. ubound(a, 1)) call abort 32 c=b 33! 7.4.1.3 "If variable is an allocated allocatable variable, it is 34! deallocated if expr is an array of different shape or any of the 35! corresponding length type parameter values of variable and expr 36! differ." Here the shape is the same so the deallocation does not 37! occur and the bounds are not recalculated. This was corrected 38! for the fix of PR47051. 39 if (lbound (c, 1) .ne. lbound(a, 1)) call abort 40 if (ubound (c, 1) .ne. ubound(a, 1)) call abort 41 d=b 42 if (lbound (d, 1) .ne. lbound(b, 1)) call abort 43 if (ubound (d, 1) .ne. ubound(b, 1)) call abort 44 d=a 45! The other PR47051 correction. 46 if (lbound (d, 1) .ne. lbound(b, 1)) call abort 47 if (ubound (d, 1) .ne. ubound(b, 1)) call abort 48 end subroutine 49 subroutine test2 50! 51! Check that the bounds are set correctly, when making an 52! assignment with an implicit conversion. First with a 53! non-descriptor variable.... 54! 55 integer(4), allocatable :: a(:) 56 integer(8) :: b(5:6) 57 a = b 58 if (lbound (a, 1) .ne. lbound(b, 1)) call abort 59 if (ubound (a, 1) .ne. ubound(b, 1)) call abort 60 end subroutine 61 subroutine test3 62! 63! ...and now a descriptor variable. 64! 65 integer(4), allocatable :: a(:) 66 integer(8), allocatable :: b(:) 67 allocate (b(7:11)) 68 a = b 69 if (lbound (a, 1) .ne. lbound(b, 1)) call abort 70 if (ubound (a, 1) .ne. ubound(b, 1)) call abort 71 end subroutine 72 subroutine test4 73! 74! Check assignments of the kind a = f(...) 75! 76 integer, allocatable :: a(:) 77 integer, allocatable :: c(:) 78 a = f() 79 if (any (a .ne. [1, 2, 3, 4])) call abort 80 c = a + 8 81 a = f (c) 82 if (any ((a - 8) .ne. [1, 2, 3, 4])) call abort 83 deallocate (c) 84 a = f (c) 85 if (any ((a - 4) .ne. [1, 2, 3, 4])) call abort 86 end subroutine 87 function f(b) 88 integer, allocatable, optional :: b(:) 89 integer :: f(4) 90 if (.not.present (b)) then 91 f = [1,2,3,4] 92 elseif (.not.allocated (b)) then 93 f = [5,6,7,8] 94 else 95 f = b 96 end if 97 end function f 98 99 subroutine test5 100! 101! Extracted from rnflow.f90, Polyhedron benchmark suite, 102! http://www.polyhedron.com 103! 104 integer, parameter :: ncls = 233, ival = 16, ipic = 17 105 real, allocatable, dimension (:,:) :: utrsft 106 real, allocatable, dimension (:,:) :: dtrsft 107 real, allocatable, dimension (:,:) :: xwrkt 108 allocate (utrsft(ncls, ncls), dtrsft(ncls, ncls)) 109 nglobal = 0 110 xwrkt = trs2a2 (ival, ipic, ncls) 111 if (any (shape (xwrkt) .ne. [ncls, ncls])) call abort 112 xwrkt = invima (xwrkt, ival, ipic, ncls) 113 if (nglobal .ne. 1) call abort 114 if (sum(xwrkt) .ne. xwrkt(ival, ival)) call abort 115 end subroutine 116 function trs2a2 (j, k, m) 117 real, dimension (1:m,1:m) :: trs2a2 118 integer, intent (in) :: j, k, m 119 nglobal = nglobal + 1 120 trs2a2 = 0.0 121 end function trs2a2 122 function invima (a, j, k, m) 123 real, dimension (1:m,1:m) :: invima 124 real, dimension (1:m,1:m), intent (in) :: a 125 integer, intent (in) :: j, k 126 invima = 0.0 127 invima (j, j) = 1.0 / (1.0 - a (j, j)) 128 end function invima 129 subroutine test6 130 character(kind=1, len=100), allocatable, dimension(:) :: str 131 str = [ "abc" ] 132 if (TRIM(str(1)) .ne. "abc") call abort 133 if (len(str) .ne. 100) call abort 134 end subroutine 135 subroutine test7 136 character(kind=4, len=100), allocatable, dimension(:) :: str 137 character(kind=4, len=3) :: test = "abc" 138 str = [ "abc" ] 139 if (TRIM(str(1)) .ne. test) call abort 140 if (len(str) .ne. 100) call abort 141 end subroutine 142 subroutine test8 143 type t 144 integer, allocatable :: a(:) 145 end type t 146 type(t) :: x 147 x%a= [1,2,3] 148 if (any (x%a .ne. [1,2,3])) call abort 149 x%a = [4] 150 if (any (x%a .ne. [4])) call abort 151 end subroutine 152end 153 154