| ! { 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 |