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 !
   5 ! Contributed by John Nedney  <ortp21@gmail.com>
   6 !
   7 program main
   8   implicit none
   9   integer, parameter :: dp = kind(0.0d0)
  10   real(kind=dp), allocatable :: delta(:,:)
  11
  12   call foo
  13   call bar
  14 contains
  15 !
  16 ! Original reduced version from comment #2
  17   subroutine foo
  18     implicit none
  19     real(kind=dp), allocatable :: a(:,:)
  20     real(kind=dp), allocatable :: b(:,:)
  21
  22     allocate(a(3,3))
  23     allocate(b(3,3))
  24     allocate(delta(3,3))
  25
  26     b = reshape ([1d0, 0d0, 0d0, 0d0, 1d0, 0d0, 0d0, 0d0, 1d0], [3,3])
  27     a = reshape ([1d0, 2d0, 3d0, 4d0, 5d0, 6d0, 7d0, 8d0, 9d0], [3,3])
  28
  29     a = matmul( matmul( a, b ), b )
  30     delta = (a - reshape ([1d0, 2d0, 3d0, 4d0, 5d0, 6d0, 7d0, 8d0, 9d0], [3,3]))**2
  31     if (any (delta > 1d-12)) call abort
  32     if (any (lbound (a) .ne. [1, 1])) call abort
  33   end subroutine
  34 !
  35 ! Check that all is well when the shape of 'a' changes.
  36   subroutine bar
  37     implicit none
  38     real(kind=dp), allocatable :: a(:,:)
  39     real(kind=dp), allocatable :: b(:,:)
  40
  41     b = reshape ([1d0, 1d0, 1d0], [3,1])
  42     a = reshape ([1d0, 2d0, 3d0, 4d0, 5d0, 6d0, 7d0, 8d0, 9d0], [3,3])
  43
  44     a = matmul( a, matmul( a, b ) )
  45
  46     delta = (a - reshape ([198d0, 243d0, 288d0], [3,1]))**2
  47     if (any (delta > 1d-12)) call abort
  48     if (any (lbound (a) .ne. [1, 1])) call abort
  49   end subroutine
  50 end program main
  51