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