--- /dev/null
+! { 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
+
+! { dg-final { cleanup-modules "base_mat_mod const_mod d_base_mat_mod" } }
projects / platform / upstream / gcc.git / commitdiff