gcc/testsuite/gfortran.dg/realloc_on_assign_2.f03

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