gcc/testsuite/gfortran.dg/whole_file_27.f90

! { dg-do compile }
!
! PR fortran/45125
!
! Contributed by Salvatore Filippone and Dominique d'Humieres.
!

module const_mod
  ! This is the default integer
  integer, parameter  :: ndig=8
  integer, parameter  :: int_k_ = selected_int_kind(ndig)
  ! This is an 8-byte  integer, and normally different from default integer. 
  integer, parameter  :: longndig=12
  integer, parameter  :: long_int_k_ = selected_int_kind(longndig)
  !
  ! These must be the kind parameter corresponding to MPI_DOUBLE_PRECISION
  ! and MPI_REAL
  !
  integer, parameter  :: dpk_ = kind(1.d0)
  integer, parameter  :: spk_ = kind(1.e0)
  integer, save       :: sizeof_dp, sizeof_sp
  integer, save       :: sizeof_int, sizeof_long_int
  integer, save       :: mpi_integer

  integer, parameter :: invalid_ = -1 
  integer, parameter :: spmat_null_=0, spmat_bld_=1
  integer, parameter :: spmat_asb_=2, spmat_upd_=4

  !
  ! 
  !     Error constants
  integer, parameter, public :: success_=0
  integer, parameter, public :: err_iarg_neg_=10
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_fmt => base_get_fmt
    procedure, pass(a) :: set_null => base_set_null
    procedure, pass(a) :: allocate_mnnz => base_allocate_mnnz
    generic,   public  :: allocate => allocate_mnnz
  end type base_sparse_mat

  interface 
    subroutine  base_allocate_mnnz(m,n,a,nz) 
      import base_sparse_mat, long_int_k_
      integer, intent(in) :: m,n
      class(base_sparse_mat), intent(inout) :: a
      integer, intent(in), optional  :: nz
    end subroutine base_allocate_mnnz
  end interface

contains

  function base_get_fmt(a) result(res)
    implicit none 
    class(base_sparse_mat), intent(in) :: a
    character(len=5) :: res
    res = 'NULL'
  end function base_get_fmt

  subroutine  base_set_null(a) 
    implicit none 
    class(base_sparse_mat), intent(inout) :: a

    a%state = spmat_null_
  end subroutine base_set_null


end module base_mat_mod

module d_base_mat_mod
  
  use base_mat_mod

  type, extends(base_sparse_mat) :: d_base_sparse_mat
  contains
  end type d_base_sparse_mat
  
  
  
  type, extends(d_base_sparse_mat) :: d_coo_sparse_mat
    
    integer              :: nnz
    integer, allocatable :: ia(:), ja(:)
    real(dpk_), allocatable :: val(:)
    
  contains
    
    procedure, pass(a) :: get_fmt      => d_coo_get_fmt
    procedure, pass(a) :: allocate_mnnz => d_coo_allocate_mnnz
    
  end type d_coo_sparse_mat
  
  
  interface
    subroutine  d_coo_allocate_mnnz(m,n,a,nz) 
      import d_coo_sparse_mat
      integer, intent(in) :: m,n
      class(d_coo_sparse_mat), intent(inout) :: a
      integer, intent(in), optional :: nz
    end subroutine d_coo_allocate_mnnz
  end interface
  
contains 
  
  function d_coo_get_fmt(a) result(res)
    implicit none 
    class(d_coo_sparse_mat), intent(in) :: a
    character(len=5) :: res
    res = 'COO'
  end function d_coo_get_fmt
  
end module d_base_mat_mod

subroutine  base_allocate_mnnz(m,n,a,nz) 
  use base_mat_mod, protect_name => base_allocate_mnnz
  implicit none 
  integer, intent(in) :: m,n
  class(base_sparse_mat), intent(inout) :: a
  integer, intent(in), optional  :: nz
  Integer :: err_act
  character(len=20)  :: name='allocate_mnz', errfmt
  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.
  errfmt=a%get_fmt()
  write(0,*) 'Error: Missing ovverriding impl for allocate in class ',errfmt

  return

end subroutine base_allocate_mnnz

subroutine  d_coo_allocate_mnnz(m,n,a,nz) 
  use d_base_mat_mod, protect_name => d_coo_allocate_mnnz
  implicit none 
  integer, intent(in) :: m,n
  class(d_coo_sparse_mat), intent(inout) :: a
  integer, intent(in), optional :: nz
  Integer :: err_act, info, nz_
  character(len=20)  :: name='allocate_mnz'
  logical, parameter :: debug=.false.

  info = success_
  if (m < 0) then 
    info = err_iarg_neg_
  endif
  if (n < 0) then 
    info = err_iarg_neg_
  endif
  if (present(nz)) then 
    nz_ = nz
  else
    nz_ = max(7*m,7*n,1)
  end if
  if (nz_ < 0) then 
    info = err_iarg_neg_
  endif
! !$  if (info == success_) call realloc(nz_,a%ia,info)
! !$  if (info == success_) call realloc(nz_,a%ja,info)
! !$  if (info == success_) call realloc(nz_,a%val,info)
  if (info == success_) then 
! !$    call a%set_nrows(m)
! !$    call a%set_ncols(n)
! !$    call a%set_nzeros(0)
! !$    call a%set_bld()
! !$    call a%set_triangle(.false.)
! !$    call a%set_unit(.false.)
! !$    call a%set_dupl(dupl_def_)
    write(0,*) 'Allocated COO succesfully, should now set components'
  else 
    write(0,*) 'COO allocation failed somehow. Go figure'
  end if
  return

end subroutine d_coo_allocate_mnnz


program d_coo_err
  use d_base_mat_mod
  implicit none

  integer            :: ictxt, iam, np

  ! solver parameters
  type(d_coo_sparse_mat) :: acoo
  
  ! other variables
  integer nnz, n

  n   = 32
  nnz = n*9
  
  call acoo%set_null()
  call acoo%allocate(n,n,nz=nnz)

  stop
end program d_coo_err