gcc/testsuite/gfortran.dg/do_check_15.f90

   1 ! { dg-do compile }
   2 ! PR fortran/96556 - this used to cause an ICE.
   3 ! Test case by Juergen Reuter.
   4 module polarizations
   5
   6   implicit none
   7   private
   8
   9   type :: smatrix_t
  10      private
  11      integer :: dim = 0
  12      integer :: n_entry = 0
  13      integer, dimension(:,:), allocatable :: index
  14    contains
  15      procedure :: write => smatrix_write
  16   end type smatrix_t
  17
  18   type, extends (smatrix_t) :: pmatrix_t
  19      private
  20    contains
  21      procedure :: write => pmatrix_write
  22      procedure :: normalize => pmatrix_normalize
  23   end type pmatrix_t
  24
  25 contains
  26
  27   subroutine msg_error (string)
  28     character(len=*), intent(in), optional :: string
  29   end subroutine msg_error
  30
  31   subroutine smatrix_write (object)
  32     class(smatrix_t), intent(in) :: object
  33   end subroutine smatrix_write
  34
  35   subroutine pmatrix_write (object)
  36     class(pmatrix_t), intent(in) :: object
  37     call object%smatrix_t%write ()
  38   end subroutine pmatrix_write
  39
  40   subroutine pmatrix_normalize (pmatrix)
  41     class(pmatrix_t), intent(inout) :: pmatrix
  42     integer :: i, hmax
  43     logical :: fermion, ok
  44     do i = 1, pmatrix%n_entry
  45        associate (index => pmatrix%index(:,i))
  46          if (index(1) == index(2)) then
  47             call error ("diagonal must be real")
  48          end if
  49        end associate
  50     end do
  51   contains
  52     subroutine error (msg)
  53       character(*), intent(in) :: msg
  54       call pmatrix%write ()
  55     end subroutine error
  56   end subroutine pmatrix_normalize
  57
  58 end module polarizations