From 57d418ff157399abc056bc4cce61632ba43502ca Mon Sep 17 00:00:00 2001 From: Salvatore Filippone Date: Fri, 28 Aug 2009 10:08:56 +0000 Subject: [PATCH] psblas3: Makefile psbn_base_mat_mod.f03 psbn_d_base_mat_mod.f03 psbn_mat_mod.f03 Implementd many basic methods. Reviewed visibility, make names of subroutines/functions always private (thus only accessible via the object). --- base/newserial/Makefile | 2 +- base/newserial/psbn_base_mat_mod.f03 | 7 ++ base/newserial/psbn_d_base_mat_mod.f03 | 129 +++++++++++++++++++ base/newserial/psbn_mat_mod.f03 | 165 +++++++++++++++++++++---- 4 files changed, 279 insertions(+), 24 deletions(-) diff --git a/base/newserial/Makefile b/base/newserial/Makefile index 5d0398c9..06b297f8 100644 --- a/base/newserial/Makefile +++ b/base/newserial/Makefile @@ -1,6 +1,6 @@ include ../../Make.inc -MODULES = psbn_base_mat_mod.o psbn_d_base_mat_mod.o psbn_d_coo_impl.o +MODULES = psbn_base_mat_mod.o psbn_d_base_mat_mod.o psbn_d_coo_impl.o psbn_mat_mod.o # psbn_csr_mat.o diff --git a/base/newserial/psbn_base_mat_mod.f03 b/base/newserial/psbn_base_mat_mod.f03 index 159a4d95..2bda5c0d 100644 --- a/base/newserial/psbn_base_mat_mod.f03 +++ b/base/newserial/psbn_base_mat_mod.f03 @@ -71,6 +71,13 @@ module psbn_base_mat_mod generic, public :: reallocate => reallocate_nz end type psbn_base_sparse_mat + private :: set_nrows, set_ncols, set_dupl, set_state, & + & set_null, set_bld, set_upd, set_asb, set_sorted, set_upper, & + & set_lower, set_triangle, set_unit, get_nrows, get_ncols, & + & get_nzeros, get_size, get_state, get_dupl, is_null, is_bld, & + & is_upd, is_asb, is_sorted, is_upper, is_lower, is_triangle, & + & is_unit, get_neigh, allocate_mn, allocate_mnnz, reallocate_nz, & + & free contains diff --git a/base/newserial/psbn_d_base_mat_mod.f03 b/base/newserial/psbn_d_base_mat_mod.f03 index 14a7f18d..19df5303 100644 --- a/base/newserial/psbn_d_base_mat_mod.f03 +++ b/base/newserial/psbn_d_base_mat_mod.f03 @@ -16,6 +16,9 @@ module psbn_d_base_mat_mod procedure, pass(a) :: from_coo end type psbn_d_base_sparse_mat + private :: d_base_csmv, d_base_csmm, d_base_cssv, d_base_cssm,& + & csins, to_coo, from_coo + type, extends(psbn_d_base_sparse_mat) :: psbn_d_coo_sparse_mat @@ -33,11 +36,19 @@ module psbn_d_base_mat_mod procedure, pass(a) :: d_base_cssv => d_coo_cssv procedure, pass(a) :: csins => d_coo_csins procedure, pass(a) :: reallocate_nz => d_coo_reallocate_nz + procedure, pass(a) :: allocate_mnnz => d_coo_allocate_mnnz + procedure, pass(a) :: allocate_mn => d_coo_allocate_mn procedure, pass(a) :: to_coo => d_coo_to_coo procedure, pass(a) :: from_coo => d_coo_from_coo procedure, pass(a) :: fix => d_fix_coo + procedure, pass(a) :: free => d_coo_free end type psbn_d_coo_sparse_mat + private :: d_coo_get_nzeros, d_coo_set_nzeros, & + & d_coo_csmm, d_coo_csmv, d_coo_cssm, d_coo_cssv, & + & d_coo_csins, d_coo_reallocate_nz, d_coo_allocate_mnnz, & + & d_coo_allocate_mn, d_coo_to_coo, d_coo_from_coo, & + & d_fix_coo, d_coo_free interface @@ -707,6 +718,124 @@ contains end subroutine d_coo_cssm + subroutine d_coo_free(a) + + class(psbn_d_coo_sparse_mat), intent(inout) :: a + + if (allocated(a%ia)) deallocate(a%ia) + if (allocated(a%ja)) deallocate(a%ja) + if (allocated(a%val)) deallocate(a%val) + call a%set_null() + call a%set_nrows(0) + call a%set_ncols(0) + + return + + end subroutine d_coo_free + + subroutine d_coo_allocate_mnnz(m,n,nz,a) + use psb_error_mod + use psb_realloc_mod + integer, intent(in) :: m,n,nz + class(psbn_d_coo_sparse_mat), intent(inout) :: a + Integer :: err_act, info + character(len=20) :: name='allocate_mnz' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = 0 + if (m < 0) then + info = 10 + call psb_errpush(info,name,i_err=(/1,0,0,0,0/)) + goto 9999 + endif + if (n < 0) then + info = 10 + call psb_errpush(info,name,i_err=(/2,0,0,0,0/)) + goto 9999 + endif + if (nz < 0) then + info = 10 + call psb_errpush(info,name,i_err=(/3,0,0,0,0/)) + goto 9999 + endif + + if (info == 0) call psb_realloc(nz,a%ia,info) + if (info == 0) call psb_realloc(nz,a%ja,info) + if (info == 0) call psb_realloc(nz,a%val,info) + if (info == 0) 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.) + end if + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + + end subroutine d_coo_allocate_mnnz + + + subroutine d_coo_allocate_mn(m,n,a) + use psb_error_mod + use psb_realloc_mod + integer, intent(in) :: m,n + class(psbn_d_coo_sparse_mat), intent(inout) :: a + Integer :: err_act, info, nz + character(len=20) :: name='allocate_mn' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = 0 + if (m < 0) then + info = 10 + call psb_errpush(info,name,i_err=(/1,0,0,0,0/)) + goto 9999 + endif + if (n < 0) then + info = 10 + call psb_errpush(info,name,i_err=(/2,0,0,0,0/)) + goto 9999 + endif + + nz = max(7*m,7*n,1) + + if (info == 0) call psb_realloc(nz,a%ia,info) + if (info == 0) call psb_realloc(nz,a%ja,info) + if (info == 0) call psb_realloc(nz,a%val,info) + if (info == 0) 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.) + end if + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if + return + + end subroutine d_coo_allocate_mn + + end module psbn_d_base_mat_mod diff --git a/base/newserial/psbn_mat_mod.f03 b/base/newserial/psbn_mat_mod.f03 index 67e2f401..090c20a6 100644 --- a/base/newserial/psbn_mat_mod.f03 +++ b/base/newserial/psbn_mat_mod.f03 @@ -43,6 +43,12 @@ module psbn_d_mat_mod end type psbn_d_sparse_mat + private :: get_nrows, get_ncols, get_nzeros, get_size, & + & get_state, get_dupl, is_null, is_bld, is_upd, & + & is_asb, is_sorted, is_upper, is_lower, is_triangle, & + & is_unit, get_neigh, allocate_mn, allocate_mnnz, & + & reallocate_nz, free, d_csmv, d_csmm, d_cssv, d_cssm + contains function get_dupl(a) result(res) @@ -51,7 +57,7 @@ contains integer :: res if (allocated(a%a)) then - res = a%a%get_dupl + res = a%a%get_dupl() else res = psbn_invalid_ end if @@ -304,48 +310,140 @@ contains end subroutine get_neigh - subroutine allocate_mn(m,n,a) + subroutine allocate_mn(m,n,a,type,mold) use psb_error_mod + use psb_string_mod integer, intent(in) :: m,n class(psbn_d_sparse_mat), intent(inout) :: a + character(len=*), intent(in), optional :: type + class(psbn_d_base_sparse_mat), intent(in), optional :: mold - Integer :: err_act + Integer :: err_act, info character(len=20) :: name='allocate_mn' + character(len=8) :: type_ logical, parameter :: debug=.false. call psb_erractionsave(err_act) - ! This is the base version. If we get here - ! it means the derived class is incomplete, - ! so we throw an error. - call psb_errpush(700,name) + info = 0 + if (allocated(a%a)) then + call a%a%free() + deallocate(a%a) + end if + + if (present(mold)) then + allocate(a%a, source=mold, stat=info) + + else + + if (present(type)) then + type_ = psb_toupper(type) + else + type_ = 'COO' + end if + + select case(type) + case('COO') + allocate(psbn_d_coo_sparse_mat :: a%a, stat=info) +! Add here a few other data structures inplemented by default. + +!!$ case('CSR') +!!$ allocate(psbn_d_csr_sparse_mat :: a%a, stat=info) + + case default + allocate(psbn_d_coo_sparse_mat :: a%a, stat=info) + end select + + end if + + if (info /= 0) then + info = 4010 + goto 9999 + end if + + call a%a%allocate(m,n) - if (err_act /= psb_act_ret_) then + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then call psb_error() + return end if return + end subroutine allocate_mn - subroutine allocate_mnnz(m,n,nz,a) + subroutine allocate_mnnz(m,n,nz,a,type,mold) use psb_error_mod + use psb_string_mod integer, intent(in) :: m,n,nz class(psbn_d_sparse_mat), intent(inout) :: a - Integer :: err_act - character(len=20) :: name='allocate_mnz' + character(len=*), intent(in), optional :: type + class(psbn_d_base_sparse_mat), intent(in), optional :: mold + + Integer :: err_act, info + character(len=20) :: name='allocate_mnnz' + character(len=8) :: type_ logical, parameter :: debug=.false. + call psb_erractionsave(err_act) - ! This is the base version. If we get here - ! it means the derived class is incomplete, - ! so we throw an error. - call psb_errpush(700,name) + info = 0 + if (allocated(a%a)) then + call a%a%free() + deallocate(a%a) + end if + + if (present(mold)) then + allocate(a%a, source=mold, stat=info) + + else + + if (present(type)) then + type_ = psb_toupper(type) + else + type_ = 'COO' + end if + + select case(type) + case('COO') + allocate(psbn_d_coo_sparse_mat :: a%a, stat=info) +! Add here a few other data structures inplemented by default. + +!!$ case('CSR') +!!$ allocate(psbn_d_csr_sparse_mat :: a%a, stat=info) + + case default + allocate(psbn_d_coo_sparse_mat :: a%a, stat=info) + end select + + end if + + if (info /= 0) then + info = 4010 + goto 9999 + end if + + call a%a%allocate(m,n,nz) - if (err_act /= psb_act_ret_) then + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then call psb_error() + return end if return + end subroutine allocate_mnnz subroutine reallocate_nz(nz,a) @@ -356,14 +454,25 @@ contains character(len=20) :: name='reallocate_nz' logical, parameter :: debug=.false. - call psb_erractionsave(err_act) - ! This is the base version. If we get here - ! it means the derived class is incomplete, - ! so we throw an error. - call psb_errpush(700,name) - - if (err_act /= psb_act_ret_) then + if (.not.allocated(a%a)) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + call a%a%reallocate(nz) + + if (info /= 0) goto 9999 + + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then call psb_error() + return end if return @@ -385,6 +494,16 @@ contains call a%a%free() + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_erractionrestore(err_act) + + if (err_act == psb_act_abort_) then + call psb_error() + return + end if return end subroutine free