gcc/testsuite/gfortran.dg/realloc_on_assign_7.f03

   1 ! { dg-do run }
   2 ! Check the fix for PR48462 in which the assignments involving matmul
   3 ! seg faulted because a was automatically freed before the assignment.
   4 ! Since it is related, the test for the fix of PR48746 has been added
   5 ! as a subroutine by that name.
   6 !
   7 ! Contributed by John Nedney  <ortp21@gmail.com>
   8 !
   9 program main
  10   implicit none
  11   integer, parameter :: dp = kind(0.0d0)
  12   real(kind=dp), allocatable :: delta(:,:)
  13   real(kind=dp), allocatable, target :: a(:,:)
  14   real(kind=dp), pointer :: aptr(:,:)
  15
  16   allocate(a(3,3))
  17   aptr => a
  18
  19   call foo
  20   if (.not. associated (aptr, a)) STOP 1 ! reallocated to same size - remains associated
  21   call bar
  22   if (.not. associated (aptr, a)) STOP 2 ! reallocated to smaller size - remains associated
  23   call foobar
  24   if (associated (aptr, a)) STOP 3 ! reallocated to larger size - disassociates
  25
  26   call pr48746
  27 contains
  28 !
  29 ! Original reduced version from comment #2
  30   subroutine foo
  31     implicit none
  32     real(kind=dp), allocatable :: b(:,:)
  33
  34     allocate(b(3,3))
  35     allocate(delta(3,3))
  36
  37     a = reshape ([1d0, 2d0, 3d0, 4d0, 5d0, 6d0, 7d0, 8d0, 9d0], [3,3])
  38     b = reshape ([1d0, 0d0, 0d0, 0d0, 1d0, 0d0, 0d0, 0d0, 1d0], [3,3])
  39
  40     a = matmul( matmul( a, b ), b )
  41     delta = (a - reshape ([1d0, 2d0, 3d0, 4d0, 5d0, 6d0, 7d0, 8d0, 9d0], [3,3]))**2
  42     if (any (delta > 1d-12)) STOP 1
  43     if (any (lbound (a) .ne. [1, 1])) STOP 2
  44   end subroutine
  45 !
  46 ! Check that all is well when the shape of 'a' changes.
  47   subroutine bar
  48     implicit none
  49     real(kind=dp), allocatable :: a(:,:)
  50     real(kind=dp), allocatable :: b(:,:)
  51
  52     b = reshape ([1d0, 1d0, 1d0], [3,1])
  53     a = reshape ([1d0, 2d0, 3d0, 4d0, 5d0, 6d0, 7d0, 8d0, 9d0], [3,3])
  54
  55     a = matmul( a, matmul( a, b ) )
  56
  57     delta = (a - reshape ([198d0, 243d0, 288d0], [3,1]))**2
  58     if (any (delta > 1d-12)) STOP 3
  59     if (any (lbound (a) .ne. [1, 1])) STOP 4
  60   end subroutine
  61   subroutine foobar
  62     integer :: i
  63     a = reshape ([(real(i, dp), i = 1, 100)],[10,10])
  64   end subroutine
  65   subroutine pr48746
  66 ! This is a further wrinkle on the original problem and came about
  67 ! because the dtype field of the result argument, passed to matmul,
  68 ! was not being set. This is needed by matmul for the rank.
  69 !
  70 ! Contributed by Thomas Koenig  <tkoenig@gcc.gnu.org>
  71 !
  72     implicit none
  73     integer, parameter :: m=10, n=12, count=4
  74     real :: optmatmul(m, n)
  75     real :: a(m, count), b(count, n), c(m, n)
  76     real, dimension(:,:), allocatable :: tmp
  77     call random_number(a)
  78     call random_number(b)
  79     tmp = matmul(a,b)
  80     if (any (lbound (tmp) .ne. [1,1])) STOP 5
  81     if (any (ubound (tmp) .ne. [10,12])) STOP 6
  82   end subroutine
  83 end program main
  84