Subversion Repositories openrisc

! { dg-do run }
! Tests the fix for PR4164656 in which the call to a%a%scal failed to compile.
!
! Contributed by Salvatore Filippone <sfilippone@uniroma2.it>
!
module const_mod
  integer, parameter  :: longndig=12
  integer, parameter  :: long_int_k_ = selected_int_kind(longndig)
  integer, parameter  :: dpk_ = kind(1.d0)
  integer, parameter  :: spk_ = kind(1.e0)
end module const_mod

module base_mat_mod  
  use const_mod 
  type  :: base_sparse_mat
    integer, private     :: m, n
    integer, private     :: state, duplicate 
    logical, private     :: triangle, unitd, upper, sorted
  contains 
    procedure, pass(a) :: get_nzeros
  end type base_sparse_mat
  private ::  get_nzeros
contains
  function get_nzeros(a) result(res)
    implicit none 
    class(base_sparse_mat), intent(in) :: a
    integer :: res
    integer :: err_act
    character(len=20)  :: name='base_get_nzeros'
    logical, parameter :: debug=.false.
    res = -1
  end function get_nzeros
end module base_mat_mod

module s_base_mat_mod
  use base_mat_mod
  type, extends(base_sparse_mat) :: s_base_sparse_mat
  contains
    procedure, pass(a) :: s_scals
    procedure, pass(a) :: s_scal
    generic, public    :: scal => s_scals, s_scal 
  end type s_base_sparse_mat
  private :: s_scals, s_scal

  type, extends(s_base_sparse_mat) :: s_coo_sparse_mat
    
    integer              :: nnz
    integer, allocatable :: ia(:), ja(:)
    real(spk_), allocatable :: val(:)
  contains
    procedure, pass(a) :: get_nzeros => s_coo_get_nzeros
    procedure, pass(a) :: s_scals => s_coo_scals
    procedure, pass(a) :: s_scal => s_coo_scal
  end type s_coo_sparse_mat
  private :: s_coo_scals, s_coo_scal, s_coo_get_nzeros
contains 
  subroutine s_scals(d,a,info) 
    implicit none 
    class(s_base_sparse_mat), intent(inout) :: a
    real(spk_), intent(in)      :: d
    integer, intent(out)            :: info

    Integer :: err_act
    character(len=20)  :: name='s_scals'
    logical, parameter :: debug=.false.

    ! This is the base version. If we get here
    ! it means the derived class is incomplete,
    ! so we throw an error.
    info = 700
  end subroutine s_scals


  subroutine s_scal(d,a,info) 
    implicit none 
    class(s_base_sparse_mat), intent(inout) :: a
    real(spk_), intent(in)      :: d(:)
    integer, intent(out)            :: info

    Integer :: err_act
    character(len=20)  :: name='s_scal'
    logical, parameter :: debug=.false.

    ! This is the base version. If we get here
    ! it means the derived class is incomplete,
    ! so we throw an error.
    info = 700
  end subroutine s_scal

  function s_coo_get_nzeros(a) result(res)
    implicit none 
    class(s_coo_sparse_mat), intent(in) :: a
    integer :: res
    res  = a%nnz
  end function s_coo_get_nzeros


  subroutine s_coo_scal(d,a,info) 
    use const_mod
    implicit none 
    class(s_coo_sparse_mat), intent(inout) :: a
    real(spk_), intent(in)      :: d(:)
    integer, intent(out)            :: info

    Integer :: err_act,mnm, i, j, m
    character(len=20)  :: name='scal'
    logical, parameter :: debug=.false.
    info  = 0
    do i=1,a%get_nzeros()
      j        = a%ia(i)
      a%val(i) = a%val(i) * d(j)
    enddo
  end subroutine s_coo_scal

  subroutine s_coo_scals(d,a,info) 
    use const_mod
    implicit none 
    class(s_coo_sparse_mat), intent(inout) :: a
    real(spk_), intent(in)      :: d
    integer, intent(out)            :: info

    Integer :: err_act,mnm, i, j, m
    character(len=20)  :: name='scal'
    logical, parameter :: debug=.false.

    info  = 0
    do i=1,a%get_nzeros()
      a%val(i) = a%val(i) * d
    enddo
  end subroutine s_coo_scals
end module s_base_mat_mod

module s_mat_mod
  use s_base_mat_mod
  type :: s_sparse_mat
    class(s_base_sparse_mat), pointer  :: a
  contains
    procedure, pass(a) :: s_scals
    procedure, pass(a) :: s_scal
    generic, public    :: scal => s_scals, s_scal 
  end type s_sparse_mat
  interface scal
    module procedure s_scals, s_scal
  end interface
contains 
  subroutine s_scal(d,a,info)
    use const_mod
    implicit none 
    class(s_sparse_mat), intent(inout) :: a
    real(spk_), intent(in)              :: d(:)
    integer, intent(out)                    :: info
    integer :: err_act
    character(len=20)  :: name='csnmi'
    logical, parameter :: debug=.false.
    print *, "s_scal"
    call a%a%scal(d,info)
    return
  end subroutine s_scal

  subroutine s_scals(d,a,info)
    use const_mod
    implicit none 
    class(s_sparse_mat), intent(inout) :: a
    real(spk_), intent(in)              :: d
    integer, intent(out)                    :: info
    integer :: err_act
    character(len=20)  :: name='csnmi'
    logical, parameter :: debug=.false.
!    print *, "s_scals"
    info = 0
    call a%a%scal(d,info)
    return
  end subroutine s_scals
end module s_mat_mod

    use s_mat_mod
    class (s_sparse_mat), pointer :: a
    type (s_sparse_mat), target :: b
    type (s_base_sparse_mat), target :: c
    integer info
    b%a => c
    a => b
    call a%scal (1.0_spk_, info)
    if (info .ne. 700) call abort
end
! { dg-final { cleanup-modules "const_mod base_mat_mod s_base_mat_mod s_mat_mod" } }