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 (j, j) = 1.0 / (1.0 - a (j, j))
 118   end function invima
 119   subroutine test6
 120     character(kind=1, len=100), allocatable, dimension(:) :: str
 121     str = [ "abc" ]
 122     if (TRIM(str(1)) .ne. "abc") call abort
 123     if (len(str) .ne. 100) call abort
 124   end subroutine
 125   subroutine test7
 126     character(kind=4, len=100), allocatable, dimension(:) :: str
 127     character(kind=4, len=3) :: test = "abc"
 128     str = [ "abc" ]
 129     if (TRIM(str(1)) .ne. test) call abort
 130     if (len(str) .ne. 100) call abort
 131   end subroutine
 132   subroutine test8
 133     type t
 134       integer, allocatable :: a(:)
 135     end type t
 136     type(t) :: x
 137     x%a= [1,2,3]
 138     if (any (x%a .ne. [1,2,3])) call abort
 139     x%a = [4]
 140     if (any (x%a .ne. [4])) call abort
 141   end subroutine
 142 end
 143