diff --git a/base/modules/psb_error_mod.F90 b/base/modules/psb_error_mod.F90 index bad1b24e..4019065a 100644 --- a/base/modules/psb_error_mod.F90 +++ b/base/modules/psb_error_mod.F90 @@ -474,7 +474,7 @@ contains case(600) write (0,'("Sparse Matrix and descriptors are in an invalid state for this subroutine call: ",i0)')i_e_d(1) case(700) - write (0,'("Base version has been called: the actual derived type is incomplete!")') + write (0,'("Base version has been called; the class implementation for ",a," may be incomplete!")') a_e_d case (1121) write (0,'("Invalid state for sparse matrix A")') diff --git a/base/newserial/Makefile b/base/newserial/Makefile index 77a1dc2c..fc1c1f47 100644 --- a/base/newserial/Makefile +++ b/base/newserial/Makefile @@ -1,7 +1,7 @@ include ../../Make.inc MODULES = psbn_base_mat_mod.o psbn_d_base_mat_mod.o psbn_d_coo_impl.o psbn_mat_mod.o\ - psbn_mat_impl.o psbn_d_csr_mat_mod.o psbn_d_csr_impl.o + psbn_d_csr_mat_mod.o psbn_d_csr_impl.o LIBMOD= diff --git a/base/newserial/psbn_base_mat_mod.f03 b/base/newserial/psbn_base_mat_mod.f03 index dc2bce07..396e9f10 100644 --- a/base/newserial/psbn_base_mat_mod.f03 +++ b/base/newserial/psbn_base_mat_mod.f03 @@ -318,7 +318,7 @@ contains ! 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) + call psb_errpush(700,name,a_err=a%get_fmt()) if (err_act /= psb_act_ret_) then call psb_error() @@ -342,7 +342,7 @@ contains ! 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) + call psb_errpush(700,name,a_err=a%get_fmt()) if (err_act /= psb_act_ret_) then call psb_error() @@ -372,7 +372,7 @@ contains ! 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) + call psb_errpush(700,name,a_err=a%get_fmt()) if (err_act /= psb_act_ret_) then call psb_error() @@ -401,7 +401,7 @@ contains ! 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) + call psb_errpush(700,name,a_err=a%get_fmt()) if (err_act /= psb_act_ret_) then call psb_error() @@ -424,7 +424,7 @@ contains ! 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) + call psb_errpush(700,name,a_err=a%get_fmt()) if (err_act /= psb_act_ret_) then call psb_error() @@ -446,7 +446,7 @@ contains ! 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) + call psb_errpush(700,name,a_err=a%get_fmt()) if (err_act /= psb_act_ret_) then call psb_error() @@ -467,7 +467,7 @@ contains ! 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) + call psb_errpush(700,name,a_err=a%get_fmt()) if (err_act /= psb_act_ret_) then call psb_error() diff --git a/base/newserial/psbn_d_base_mat_mod.f03 b/base/newserial/psbn_d_base_mat_mod.f03 index 82cb7be5..bf3a832d 100644 --- a/base/newserial/psbn_d_base_mat_mod.f03 +++ b/base/newserial/psbn_d_base_mat_mod.f03 @@ -6,11 +6,11 @@ module psbn_d_base_mat_mod contains procedure, pass(a) :: d_base_csmv procedure, pass(a) :: d_base_csmm - generic, public :: psbn_csmm => d_base_csmm, d_base_csmv + generic, public :: csmm => d_base_csmm, d_base_csmv procedure, pass(a) :: d_base_cssv procedure, pass(a) :: d_base_cssm - generic, public :: psbn_cssm => d_base_cssm, d_base_cssv - procedure, pass(a) :: csins + generic, public :: cssm => d_base_cssm, d_base_cssv + procedure, pass(a) :: csput procedure, pass(a) :: cp_to_coo procedure, pass(a) :: cp_from_coo procedure, pass(a) :: cp_to_fmt @@ -21,7 +21,7 @@ module psbn_d_base_mat_mod procedure, pass(a) :: mv_from_fmt end type psbn_d_base_sparse_mat private :: d_base_csmv, d_base_csmm, d_base_cssv, d_base_cssm,& - & csins, cp_to_coo, cp_from_coo, cp_to_fmt, cp_from_fmt, & + & csput, cp_to_coo, cp_from_coo, cp_to_fmt, cp_from_fmt, & & mv_to_coo, mv_from_coo, mv_to_fmt, mv_from_fmt @@ -40,7 +40,7 @@ module psbn_d_base_mat_mod procedure, pass(a) :: d_base_csmv => d_coo_csmv procedure, pass(a) :: d_base_cssm => d_coo_cssm procedure, pass(a) :: d_base_cssv => d_coo_cssv - procedure, pass(a) :: csins => d_coo_csins + procedure, pass(a) :: csput => d_coo_csput procedure, pass(a) :: reallocate_nz => d_coo_reallocate_nz procedure, pass(a) :: allocate_mnnz => d_coo_allocate_mnnz procedure, pass(a) :: cp_to_coo => d_cp_coo_to_coo @@ -59,7 +59,7 @@ module psbn_d_base_mat_mod 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_csput, d_coo_reallocate_nz, d_coo_allocate_mnnz, & & d_fix_coo, d_coo_free, d_coo_print, d_coo_get_fmt, & & d_cp_coo_to_coo, d_cp_coo_from_coo, & & d_cp_coo_to_fmt, d_cp_coo_from_fmt @@ -168,7 +168,7 @@ module psbn_d_base_mat_mod interface - subroutine d_coo_csins_impl(nz,val,ia,ja,a,imin,imax,jmin,jmax,info,gtl) + subroutine d_coo_csput_impl(nz,val,ia,ja,a,imin,imax,jmin,jmax,info,gtl) use psb_const_mod import psbn_d_coo_sparse_mat class(psbn_d_coo_sparse_mat), intent(inout) :: a @@ -176,7 +176,7 @@ module psbn_d_base_mat_mod integer, intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax integer, intent(out) :: info integer, intent(in), optional :: gtl(:) - end subroutine d_coo_csins_impl + end subroutine d_coo_csput_impl end interface interface d_coo_cssm_impl @@ -241,7 +241,7 @@ contains ! it means the derived class is incomplete, ! so we throw an error. info = 700 - call psb_errpush(info,name) + call psb_errpush(info,name,a_err=a%get_fmt()) if (err_act /= psb_act_ret_) then call psb_error() @@ -267,7 +267,7 @@ contains ! it means the derived class is incomplete, ! so we throw an error. info = 700 - call psb_errpush(info,name) + call psb_errpush(info,name,a_err=a%get_fmt()) if (err_act /= psb_act_ret_) then call psb_error() @@ -294,7 +294,7 @@ contains ! it means the derived class is incomplete, ! so we throw an error. info = 700 - call psb_errpush(info,name) + call psb_errpush(info,name,a_err=a%get_fmt()) if (err_act /= psb_act_ret_) then call psb_error() @@ -320,7 +320,7 @@ contains ! it means the derived class is incomplete, ! so we throw an error. info = 700 - call psb_errpush(info,name) + call psb_errpush(info,name,a_err=a%get_fmt()) if (err_act /= psb_act_ret_) then call psb_error() @@ -347,7 +347,7 @@ contains ! it means the derived class is incomplete, ! so we throw an error. info = 700 - call psb_errpush(info,name) + call psb_errpush(info,name,a_err=a%get_fmt()) if (err_act /= psb_act_ret_) then call psb_error() @@ -373,7 +373,7 @@ contains ! it means the derived class is incomplete, ! so we throw an error. info = 700 - call psb_errpush(info,name) + call psb_errpush(info,name,a_err=a%get_fmt()) if (err_act /= psb_act_ret_) then call psb_error() @@ -400,7 +400,7 @@ contains ! it means the derived class is incomplete, ! so we throw an error. info = 700 - call psb_errpush(info,name) + call psb_errpush(info,name,a_err=a%get_fmt()) if (err_act /= psb_act_ret_) then call psb_error() @@ -426,7 +426,7 @@ contains ! it means the derived class is incomplete, ! so we throw an error. info = 700 - call psb_errpush(info,name) + call psb_errpush(info,name,a_err=a%get_fmt()) if (err_act /= psb_act_ret_) then call psb_error() @@ -477,7 +477,7 @@ contains end subroutine d_fix_coo - subroutine csins(nz,val,ia,ja,a,imin,imax,jmin,jmax,info,gtl) + subroutine csput(nz,val,ia,ja,a,imin,imax,jmin,jmax,info,gtl) use psb_error_mod use psb_realloc_mod implicit none @@ -488,7 +488,7 @@ contains integer, intent(in), optional :: gtl(:) Integer :: err_act - character(len=20) :: name='csins' + character(len=20) :: name='csput' logical, parameter :: debug=.false. call psb_erractionsave(err_act) @@ -496,14 +496,14 @@ contains ! it means the derived class is incomplete, ! so we throw an error. info = 700 - call psb_errpush(info,name) + call psb_errpush(info,name,a_err=a%get_fmt()) if (err_act /= psb_act_ret_) then call psb_error() end if return - end subroutine csins + end subroutine csput subroutine d_base_csmm(alpha,a,x,beta,y,info,trans) use psb_error_mod @@ -523,7 +523,7 @@ contains ! it means the derived class is incomplete, ! so we throw an error. info = 700 - call psb_errpush(info,name) + call psb_errpush(info,name,a_err=a%get_fmt()) if (err_act /= psb_act_ret_) then call psb_error() @@ -550,7 +550,7 @@ contains ! it means the derived class is incomplete, ! so we throw an error. info = 700 - call psb_errpush(info,name) + call psb_errpush(info,name,a_err=a%get_fmt()) if (err_act /= psb_act_ret_) then call psb_error() @@ -578,7 +578,7 @@ contains ! it means the derived class is incomplete, ! so we throw an error. info = 700 - call psb_errpush(info,name) + call psb_errpush(info,name,a_err=a%get_fmt()) if (err_act /= psb_act_ret_) then call psb_error() @@ -605,7 +605,7 @@ contains ! it means the derived class is incomplete, ! so we throw an error. info = 700 - call psb_errpush(info,name) + call psb_errpush(info,name,a_err=a%get_fmt()) if (err_act /= psb_act_ret_) then call psb_error() @@ -952,7 +952,7 @@ contains end subroutine d_coo_set_nzeros - subroutine d_coo_csins(nz,val,ia,ja,a,imin,imax,jmin,jmax,info,gtl) + subroutine d_coo_csput(nz,val,ia,ja,a,imin,imax,jmin,jmax,info,gtl) use psb_error_mod use psb_realloc_mod implicit none @@ -964,7 +964,7 @@ contains Integer :: err_act - character(len=20) :: name='d_coo_csins' + character(len=20) :: name='d_coo_csput' logical, parameter :: debug=.false. integer :: nza, i,j,k, nzl, isza, int_err(5) @@ -999,7 +999,7 @@ contains if (nz == 0) return nza = a%get_nzeros() - call d_coo_csins_impl(nz,val,ia,ja,a,imin,imax,jmin,jmax,info,gtl) + call d_coo_csput_impl(nz,val,ia,ja,a,imin,imax,jmin,jmax,info,gtl) if (info /= 0) goto 9999 call psb_erractionrestore(err_act) @@ -1014,7 +1014,7 @@ contains end if return - end subroutine d_coo_csins + end subroutine d_coo_csput subroutine d_coo_csmv(alpha,a,x,beta,y,info,trans) diff --git a/base/newserial/psbn_d_coo_impl.f03 b/base/newserial/psbn_d_coo_impl.f03 index 959c8063..75d6bfe9 100644 --- a/base/newserial/psbn_d_coo_impl.f03 +++ b/base/newserial/psbn_d_coo_impl.f03 @@ -853,10 +853,10 @@ subroutine d_coo_csmm_impl(alpha,a,x,beta,y,info,trans) end subroutine d_coo_csmm_impl -subroutine d_coo_csins_impl(nz,val,ia,ja,a,imin,imax,jmin,jmax,info,gtl) +subroutine d_coo_csput_impl(nz,val,ia,ja,a,imin,imax,jmin,jmax,info,gtl) use psb_error_mod use psb_realloc_mod - use psbn_d_base_mat_mod, psb_protect_name => d_coo_csins_impl + use psbn_d_base_mat_mod, psb_protect_name => d_coo_csput_impl implicit none class(psbn_d_coo_sparse_mat), intent(inout) :: a @@ -867,7 +867,7 @@ subroutine d_coo_csins_impl(nz,val,ia,ja,a,imin,imax,jmin,jmax,info,gtl) Integer :: err_act - character(len=20) :: name='d_coo_csins_impl' + character(len=20) :: name='d_coo_csput_impl' logical, parameter :: debug=.false. integer :: nza, i,j,k, nzl, isza, int_err(5) @@ -905,7 +905,7 @@ subroutine d_coo_csins_impl(nz,val,ia,ja,a,imin,imax,jmin,jmax,info,gtl) nza = a%get_nzeros() isza = a%get_size() -!!$ write(0,*) 'On entry to csins_impl: ',nza +!!$ write(0,*) 'On entry to csput_impl: ',nza if (a%is_bld()) then ! Build phase. Must handle reallocations in a sensible way. if (isza < (nza+nz)) then @@ -1303,7 +1303,7 @@ contains end subroutine d_coo_srch_upd -end subroutine d_coo_csins_impl +end subroutine d_coo_csput_impl subroutine d_cp_coo_to_coo_impl(a,b,info) diff --git a/base/newserial/psbn_d_csr_impl.f03 b/base/newserial/psbn_d_csr_impl.f03 index 5c180c67..32352941 100644 --- a/base/newserial/psbn_d_csr_impl.f03 +++ b/base/newserial/psbn_d_csr_impl.f03 @@ -942,10 +942,10 @@ end subroutine d_csr_cssm_impl -subroutine d_csr_csins_impl(nz,val,ia,ja,a,imin,imax,jmin,jmax,info,gtl) +subroutine d_csr_csput_impl(nz,val,ia,ja,a,imin,imax,jmin,jmax,info,gtl) use psb_error_mod use psb_realloc_mod - use psbn_d_csr_mat_mod, psb_protect_name => d_csr_csins_impl + use psbn_d_csr_mat_mod, psb_protect_name => d_csr_csput_impl implicit none class(psbn_d_csr_sparse_mat), intent(inout) :: a @@ -956,7 +956,7 @@ subroutine d_csr_csins_impl(nz,val,ia,ja,a,imin,imax,jmin,jmax,info,gtl) Integer :: err_act - character(len=20) :: name='d_csr_csins' + character(len=20) :: name='d_csr_csput' logical, parameter :: debug=.false. integer :: nza, i,j,k, nzl, isza, int_err(5) @@ -1193,7 +1193,7 @@ contains end subroutine d_csr_srch_upd -end subroutine d_csr_csins_impl +end subroutine d_csr_csput_impl @@ -1438,22 +1438,27 @@ subroutine d_mv_csr_to_fmt_impl(a,b,info) info = 0 - call tmp%mv_from_fmt(a,info) - call b%mv_from_coo(tmp,info) + select type (b) + class is (psbn_d_coo_sparse_mat) + call a%mv_to_coo(b,info) + class default + call tmp%mv_from_fmt(a,info) + if (info == 0) call b%mv_from_coo(tmp,info) + end select end subroutine d_mv_csr_to_fmt_impl -subroutine d_mv_csr_from_fmt_impl(a,b,info) +subroutine d_cp_csr_to_fmt_impl(a,b,info) use psb_const_mod use psb_realloc_mod use psbn_d_base_mat_mod - use psbn_d_csr_mat_mod, psb_protect_name => d_mv_csr_from_fmt_impl + use psbn_d_csr_mat_mod, psb_protect_name => d_cp_csr_to_fmt_impl implicit none - class(psbn_d_csr_sparse_mat), intent(inout) :: a - class(psbn_d_base_sparse_mat), intent(inout) :: b - integer, intent(out) :: info + class(psbn_d_csr_sparse_mat), intent(in) :: a + class(psbn_d_base_sparse_mat), intent(out) :: b + integer, intent(out) :: info !locals type(psbn_d_coo_sparse_mat) :: tmp @@ -1465,23 +1470,28 @@ subroutine d_mv_csr_from_fmt_impl(a,b,info) info = 0 - call tmp%mv_from_fmt(b,info) - call a%mv_from_coo(tmp,info) -end subroutine d_mv_csr_from_fmt_impl + select type (b) + class is (psbn_d_coo_sparse_mat) + call a%cp_to_coo(b,info) + class default + call tmp%cp_from_fmt(a,info) + if (info == 0) call b%mv_from_coo(tmp,info) + end select +end subroutine d_cp_csr_to_fmt_impl -subroutine d_cp_csr_to_fmt_impl(a,b,info) +subroutine d_mv_csr_from_fmt_impl(a,b,info) use psb_const_mod use psb_realloc_mod use psbn_d_base_mat_mod - use psbn_d_csr_mat_mod, psb_protect_name => d_cp_csr_to_fmt_impl + use psbn_d_csr_mat_mod, psb_protect_name => d_mv_csr_from_fmt_impl implicit none - class(psbn_d_csr_sparse_mat), intent(in) :: a - class(psbn_d_base_sparse_mat), intent(out) :: b - integer, intent(out) :: info + class(psbn_d_csr_sparse_mat), intent(inout) :: a + class(psbn_d_base_sparse_mat), intent(inout) :: b + integer, intent(out) :: info !locals type(psbn_d_coo_sparse_mat) :: tmp @@ -1493,10 +1503,16 @@ subroutine d_cp_csr_to_fmt_impl(a,b,info) info = 0 - call tmp%cp_from_fmt(a,info) - call b%mv_from_coo(tmp,info) + select type (b) + class is (psbn_d_coo_sparse_mat) + call a%mv_from_coo(b,info) + class default + call tmp%mv_from_fmt(b,info) + if (info == 0) call a%mv_from_coo(tmp,info) + end select + +end subroutine d_mv_csr_from_fmt_impl -end subroutine d_cp_csr_to_fmt_impl subroutine d_cp_csr_from_fmt_impl(a,b,info) @@ -1520,8 +1536,12 @@ subroutine d_cp_csr_from_fmt_impl(a,b,info) info = 0 - call tmp%cp_from_fmt(b,info) - call a%mv_from_coo(tmp,info) - + select type (b) + class is (psbn_d_coo_sparse_mat) + call a%cp_from_coo(b,info) + class default + call tmp%cp_from_fmt(b,info) + if (info == 0) call a%mv_from_coo(tmp,info) + end select end subroutine d_cp_csr_from_fmt_impl diff --git a/base/newserial/psbn_d_csr_mat_mod.f03 b/base/newserial/psbn_d_csr_mat_mod.f03 index f186d799..a155e8b8 100644 --- a/base/newserial/psbn_d_csr_mat_mod.f03 +++ b/base/newserial/psbn_d_csr_mat_mod.f03 @@ -14,7 +14,7 @@ module psbn_d_csr_mat_mod procedure, pass(a) :: d_base_cssm => d_csr_cssm procedure, pass(a) :: d_base_cssv => d_csr_cssv procedure, pass(a) :: reallocate_nz => d_csr_reallocate_nz - procedure, pass(a) :: csins => d_csr_csins + procedure, pass(a) :: csput => d_csr_csput procedure, pass(a) :: allocate_mnnz => d_csr_allocate_mnnz procedure, pass(a) :: cp_to_coo => d_cp_csr_to_coo procedure, pass(a) :: cp_from_coo => d_cp_csr_from_coo @@ -29,7 +29,7 @@ module psbn_d_csr_mat_mod procedure, pass(a) :: get_fmt => d_csr_get_fmt end type psbn_d_csr_sparse_mat private :: d_csr_get_nzeros, d_csr_csmm, d_csr_csmv, d_csr_cssm, d_csr_cssv, & - & d_csr_csins, d_csr_reallocate_nz, d_csr_allocate_mnnz, & + & d_csr_csput, d_csr_reallocate_nz, d_csr_allocate_mnnz, & & d_csr_free, d_csr_print, d_csr_get_fmt, & & d_cp_csr_to_coo, d_cp_csr_from_coo, & & d_mv_csr_to_coo, d_mv_csr_from_coo, & @@ -128,7 +128,7 @@ module psbn_d_csr_mat_mod end interface interface - subroutine d_csr_csins_impl(nz,val,ia,ja,a,imin,imax,jmin,jmax,info,gtl) + subroutine d_csr_csput_impl(nz,val,ia,ja,a,imin,imax,jmin,jmax,info,gtl) use psb_const_mod import psbn_d_csr_sparse_mat class(psbn_d_csr_sparse_mat), intent(inout) :: a @@ -136,7 +136,7 @@ module psbn_d_csr_mat_mod integer, intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax integer, intent(out) :: info integer, intent(in), optional :: gtl(:) - end subroutine d_csr_csins_impl + end subroutine d_csr_csput_impl end interface interface d_csr_cssm_impl @@ -235,7 +235,7 @@ contains end function d_csr_get_nzeros - subroutine d_csr_csins(nz,val,ia,ja,a,imin,imax,jmin,jmax,info,gtl) + subroutine d_csr_csput(nz,val,ia,ja,a,imin,imax,jmin,jmax,info,gtl) use psb_const_mod use psb_error_mod implicit none @@ -247,7 +247,7 @@ contains Integer :: err_act - character(len=20) :: name='d_csr_csins' + character(len=20) :: name='d_csr_csput' logical, parameter :: debug=.false. integer :: nza, i,j,k, nzl, isza, int_err(5) @@ -282,7 +282,7 @@ contains if (nz == 0) return - call d_csr_csins_impl(nz,val,ia,ja,a,imin,imax,jmin,jmax,info,gtl) + call d_csr_csput_impl(nz,val,ia,ja,a,imin,imax,jmin,jmax,info,gtl) if (info /= 0) goto 9999 call psb_erractionrestore(err_act) @@ -296,7 +296,7 @@ contains return end if return - end subroutine d_csr_csins + end subroutine d_csr_csput subroutine d_csr_csmv(alpha,a,x,beta,y,info,trans) diff --git a/base/newserial/psbn_mat_impl.f03 b/base/newserial/psbn_mat_impl.f03 index 987c9ae7..4dc44a22 100644 --- a/base/newserial/psbn_mat_impl.f03 +++ b/base/newserial/psbn_mat_impl.f03 @@ -12,16 +12,16 @@ subroutine psbn_d_csall(nr,nc,a,info,nz) info = 0 call a%allocate(nr,nc,nz) - call a%set_state(psbn_spmat_bld_) + call a%set_bld() return end subroutine psbn_d_csall -subroutine psbn_d_csins(nz,val,ia,ja,a,imin,imax,jmin,jmax,info,gtl) +subroutine psbn_d_csput(nz,val,ia,ja,a,imin,imax,jmin,jmax,info,gtl) use psbn_d_base_mat_mod use psb_error_mod - use psbn_d_mat_mod, psb_protect_name => psbn_d_csins + use psbn_d_mat_mod, psb_protect_name => psbn_d_csput implicit none type(psbn_d_sparse_mat), intent(inout) :: a real(psb_dpk_), intent(in) :: val(:) @@ -30,7 +30,7 @@ subroutine psbn_d_csins(nz,val,ia,ja,a,imin,imax,jmin,jmax,info,gtl) integer, intent(in), optional :: gtl(:) Integer :: err_act - character(len=20) :: name='psbn_csins' + character(len=20) :: name='psbn_csput' logical, parameter :: debug=.false. info = 0 @@ -42,7 +42,7 @@ subroutine psbn_d_csins(nz,val,ia,ja,a,imin,imax,jmin,jmax,info,gtl) endif - call a%a%csins(nz,val,ia,ja,imin,imax,jmin,jmax,info,gtl) + call a%a%csput(nz,val,ia,ja,imin,imax,jmin,jmax,info,gtl) if (info /= 0) goto 9999 call psb_erractionrestore(err_act) @@ -56,14 +56,14 @@ subroutine psbn_d_csins(nz,val,ia,ja,a,imin,imax,jmin,jmax,info,gtl) return end if -end subroutine psbn_d_csins +end subroutine psbn_d_csput subroutine psbn_d_spcnv(a,b,info,type,mold,upd,dupl) + use psb_error_mod + use psb_string_mod use psbn_d_mat_mod, psb_protect_name => psbn_d_spcnv - use psb_realloc_mod - use psb_sort_mod implicit none type(psbn_d_sparse_mat), intent(in) :: a type(psbn_d_sparse_mat), intent(out) :: b @@ -73,7 +73,80 @@ subroutine psbn_d_spcnv(a,b,info,type,mold,upd,dupl) class(psbn_d_base_sparse_mat), intent(in), optional :: mold - write(0,*) 'TO BE IMPLEMENTED ' + class(psbn_d_base_sparse_mat), allocatable :: altmp + Integer :: err_act + character(len=20) :: name='psbn_cscnv' + logical, parameter :: debug=.false. + + info = 0 + call psb_erractionsave(err_act) + + if (a%is_null()) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + if (present(dupl)) then + call b%set_dupl(dupl) + else if (a%is_bld()) then + ! Does this make sense at all?? Who knows.. + call b%set_dupl(psbn_dupl_def_) + end if + + if (count( (/present(mold),present(type) /)) > 1) then + info = 583 + call psb_errpush(info,name,a_err='TYPE, MOLD') + goto 9999 + end if + + if (present(mold)) then + + allocate(altmp, source=mold,stat=info) + + else if (present(type)) then + + select case (psb_toupper(type)) + case ('CSR') + allocate(psbn_d_csr_sparse_mat :: altmp, stat=info) + case ('COO') + allocate(psbn_d_coo_sparse_mat :: altmp, stat=info) + case default + info = 136 + call psb_errpush(info,name,a_err=type) + goto 9999 + end select + else + allocate(psbn_d_csr_sparse_mat :: altmp, stat=info) + end if + + if (info /= 0) then + info = 4000 + call psb_errpush(info,name) + goto 9999 + end if + + call altmp%cp_from_fmt(a%a, info) + + if (info /= 0) then + info = 4010 + call psb_errpush(info,name,a_err="mv_from") + goto 9999 + end if + + call move_alloc(altmp,b%a) + call b%set_asb() + + 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 end subroutine psbn_d_spcnv @@ -91,8 +164,6 @@ subroutine psbn_d_spcnv_ip(a,info,type,mold,dupl) class(psbn_d_base_sparse_mat), allocatable :: altmp - class(psbn_d_base_sparse_mat), pointer :: aslct - type(psbn_d_csr_sparse_mat) :: csrtmp Integer :: err_act character(len=20) :: name='psbn_cscnv' logical, parameter :: debug=.false. @@ -108,7 +179,7 @@ subroutine psbn_d_spcnv_ip(a,info,type,mold,dupl) if (present(dupl)) then call a%set_dupl(dupl) - else + else if (a%is_bld()) then call a%set_dupl(psbn_dupl_def_) end if @@ -135,20 +206,20 @@ subroutine psbn_d_spcnv_ip(a,info,type,mold,dupl) goto 9999 end select else - allocate(altmp, source=csrtmp,stat=info) + allocate(psbn_d_csr_sparse_mat :: altmp, stat=info) + end if + + if (info /= 0) then + info = 4000 + call psb_errpush(info,name) + goto 9999 end if - select type ( aa => a%a ) - class is (psbn_d_coo_sparse_mat) - ! Quick route from coo - call altmp%mv_from_coo(aa, info) - class default - call altmp%mv_from_fmt(aa, info) - end select + call altmp%mv_from_fmt(a%a, info) if (info /= 0) then - info = 1121 - call psb_errpush(info,name) + info = 4010 + call psb_errpush(info,name,a_err="mv_from") goto 9999 end if diff --git a/base/newserial/psbn_mat_mod.f03 b/base/newserial/psbn_mat_mod.f03 index 32449b3a..43aea727 100644 --- a/base/newserial/psbn_mat_mod.f03 +++ b/base/newserial/psbn_mat_mod.f03 @@ -7,9 +7,9 @@ module psbn_d_mat_mod type :: psbn_d_sparse_mat class(psbn_d_base_sparse_mat), allocatable :: a - + contains - + ! Setters procedure, pass(a) :: set_nrows procedure, pass(a) :: set_ncols procedure, pass(a) :: set_dupl @@ -23,13 +23,12 @@ module psbn_d_mat_mod procedure, pass(a) :: set_lower procedure, pass(a) :: set_triangle procedure, pass(a) :: set_unit - + ! Getters procedure, pass(a) :: get_nrows procedure, pass(a) :: get_ncols procedure, pass(a) :: get_nzeros procedure, pass(a) :: get_size procedure, pass(a) :: get_state - procedure, pass(a) :: get_dupl procedure, pass(a) :: is_null procedure, pass(a) :: is_bld @@ -40,97 +39,67 @@ module psbn_d_mat_mod procedure, pass(a) :: is_lower procedure, pass(a) :: is_triangle procedure, pass(a) :: is_unit - procedure, pass(a) :: get_neigh - procedure, pass(a) :: allocate_mnnz - procedure, pass(a) :: reallocate_nz - procedure, pass(a) :: free - procedure, pass(a) :: print => sparse_print procedure, pass(a) :: get_fmt => sparse_get_fmt - generic, public :: allocate => allocate_mnnz - generic, public :: reallocate => reallocate_nz + ! Memory/data management + procedure, pass(a) :: csall + procedure, pass(a) :: free + procedure, pass(a) :: csput + procedure, pass(a) :: csget + procedure, pass(a) :: reall => reallocate_nz + procedure, pass(a) :: get_neigh + procedure, pass(a) :: d_cscnv + procedure, pass(a) :: d_cscnv_ip + generic, public :: cscnv => d_cscnv, d_cscnv_ip + procedure, pass(a) :: print => sparse_print + ! Computational routines procedure, pass(a) :: d_csmv procedure, pass(a) :: d_csmm - generic, public :: psbn_csmm => d_csmm, d_csmv + generic, public :: csmm => d_csmm, d_csmv procedure, pass(a) :: d_cssv procedure, pass(a) :: d_cssm - generic, public :: psbn_cssm => d_cssm, d_cssv - + generic, public :: cssm => d_cssm, d_cssv + 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_mnnz, & + & is_unit, get_neigh, csall, csput, csget, d_cscnv, d_cscnv_ip, & & reallocate_nz, free, d_csmv, d_csmm, d_cssv, d_cssm, sparse_print, & & 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 +contains - interface psbn_csall - subroutine psbn_d_csall(nr,nc,a,info,nz) - use psbn_d_base_mat_mod - import psbn_d_sparse_mat - type(psbn_d_sparse_mat), intent(out) :: a - integer, intent(in) :: nr,nc - integer, intent(out) :: info - integer, intent(in), optional :: nz - end subroutine psbn_d_csall - end interface - - interface psbn_csins - subroutine psbn_d_csins(nz,val,ia,ja,a,imin,imax,jmin,jmax,info,gtl) - use psbn_d_base_mat_mod - import psbn_d_sparse_mat - type(psbn_d_sparse_mat), intent(inout) :: a - real(psb_dpk_), intent(in) :: val(:) - integer, intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax - integer, intent(out) :: info - integer, intent(in), optional :: gtl(:) - end subroutine psbn_d_csins - end interface - - interface psbn_cscnv - subroutine psbn_d_spcnv(a,b,info,type,mold,upd,dupl) - use psbn_d_base_mat_mod - import psbn_d_sparse_mat - type(psbn_d_sparse_mat), intent(in) :: a - type(psbn_d_sparse_mat), intent(out) :: b - integer, intent(out) :: info - integer, optional, intent(in) :: dupl, upd - character(len=*), optional, intent(in) :: type - class(psbn_d_base_sparse_mat), intent(in), optional :: mold - - end subroutine psbn_d_spcnv - subroutine psbn_d_spcnv_ip(a,info,type,mold,dupl) - use psbn_d_base_mat_mod - import psbn_d_sparse_mat - type(psbn_d_sparse_mat), intent(inout) :: a - integer, intent(out) :: info - integer,optional, intent(in) :: dupl - character(len=*), optional, intent(in) :: type - class(psbn_d_base_sparse_mat), intent(in), optional :: mold - end subroutine psbn_d_spcnv_ip - end interface +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! + ! + ! + ! Getters + ! + ! + ! + ! + ! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -contains - function sparse_get_fmt(a) result(res) implicit none class(psbn_d_sparse_mat), intent(in) :: a character(len=5) :: res - + if (allocated(a%a)) then res = a%a%get_fmt() else res = 'NULL' end if - + end function sparse_get_fmt @@ -140,32 +109,32 @@ contains implicit none class(psbn_d_sparse_mat), intent(in) :: a integer :: res - + if (allocated(a%a)) then res = a%a%get_dupl() else res = psbn_invalid_ end if end function get_dupl - - + + function get_state(a) result(res) implicit none class(psbn_d_sparse_mat), intent(in) :: a integer :: res - + if (allocated(a%a)) then res = a%a%get_state() else res = psbn_spmat_null_ end if end function get_state - + function get_nrows(a) result(res) implicit none class(psbn_d_sparse_mat), intent(in) :: a integer :: res - + if (allocated(a%a)) then res = a%a%get_nrows() else @@ -243,7 +212,7 @@ contains implicit none class(psbn_d_sparse_mat), intent(in) :: a logical :: res - + if (allocated(a%a)) then res = a%a%is_null() else @@ -304,7 +273,89 @@ contains end function is_sorted - + + + function get_nzeros(a) result(res) + use psb_error_mod + implicit none + class(psbn_d_sparse_mat), intent(in) :: a + integer :: res + + Integer :: err_act, info + character(len=20) :: name='get_nzeros' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + res = a%a%get_nzeros() + + 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 + + end function get_nzeros + + function get_size(a) result(res) + use psb_error_mod + implicit none + class(psbn_d_sparse_mat), intent(in) :: a + integer :: res + + Integer :: err_act, info + character(len=20) :: name='get_size' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + if (.not.allocated(a%a)) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif + + res = a%a%get_size() + + 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 function get_size + + + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! + ! + ! + ! Setters + ! + ! + ! + ! + ! + ! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + subroutine set_nrows(m,a) use psb_error_mod implicit none @@ -447,7 +498,7 @@ contains call psb_errpush(info,name) goto 9999 endif - + call a%a%set_null() call psb_erractionrestore(err_act) @@ -480,7 +531,7 @@ contains endif call a%a%set_bld() - + call psb_erractionrestore(err_act) return @@ -539,7 +590,7 @@ contains call psb_errpush(info,name) goto 9999 endif - + call a%a%set_asb() call psb_erractionrestore(err_act) @@ -570,9 +621,9 @@ contains call psb_errpush(info,name) goto 9999 endif - + call a%a%set_sorted(val) - + call psb_erractionrestore(err_act) return @@ -632,7 +683,7 @@ contains call psb_errpush(info,name) goto 9999 endif - + call a%a%set_unit(val) call psb_erractionrestore(err_act) @@ -711,18 +762,37 @@ contains end subroutine set_upper +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! + ! + ! + ! Data management + ! + ! + ! + ! + ! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - function get_nzeros(a) result(res) + + + subroutine sparse_print(iout,a,iv,eirs,eics,head,ivr,ivc) use psb_error_mod implicit none - class(psbn_d_sparse_mat), intent(in) :: a - integer :: res - + + integer, intent(in) :: iout + class(psbn_d_sparse_mat), intent(in) :: a + integer, intent(in), optional :: iv(:) + integer, intent(in), optional :: eirs,eics + character(len=*), optional :: head + integer, intent(in), optional :: ivr(:), ivc(:) + Integer :: err_act, info - character(len=20) :: name='get_nzeros' + character(len=20) :: name='sparse_print' logical, parameter :: debug=.false. + info = 0 call psb_erractionsave(err_act) if (.not.allocated(a%a)) then info = 1121 @@ -730,7 +800,8 @@ contains goto 9999 endif - res = a%a%get_nzeros() + call a%a%print(iout,iv,eirs,eics,head,ivr,ivc) + call psb_erractionrestore(err_act) return @@ -742,27 +813,37 @@ contains call psb_error() return end if + return - end function get_nzeros + end subroutine sparse_print - function get_size(a) result(res) + + + subroutine get_neigh(a,idx,neigh,n,info,lev) use psb_error_mod implicit none - class(psbn_d_sparse_mat), intent(in) :: a - integer :: res - - Integer :: err_act, info - character(len=20) :: name='get_size' + class(psbn_d_sparse_mat), intent(in) :: a + integer, intent(in) :: idx + integer, intent(out) :: n + integer, allocatable, intent(out) :: neigh(:) + integer, intent(out) :: info + integer, optional, intent(in) :: lev + + Integer :: err_act + character(len=20) :: name='get_neigh' logical, parameter :: debug=.false. + info = 0 call psb_erractionsave(err_act) if (.not.allocated(a%a)) then info = 1121 call psb_errpush(info,name) goto 9999 endif - - res = a%a%get_size() + + call a%a%get_neigh(idx,neigh,n,info,lev) + + if (info /= 0) goto 9999 call psb_erractionrestore(err_act) return @@ -776,33 +857,66 @@ contains end if return - end function get_size + end subroutine get_neigh - subroutine sparse_print(iout,a,iv,eirs,eics,head,ivr,ivc) + + subroutine csall(nr,nc,a,info,nz) + use psbn_d_base_mat_mod use psb_error_mod implicit none + class(psbn_d_sparse_mat), intent(out) :: a + integer, intent(in) :: nr,nc + integer, intent(out) :: info + integer, intent(in), optional :: nz - integer, intent(in) :: iout - class(psbn_d_sparse_mat), intent(in) :: a - integer, intent(in), optional :: iv(:) - integer, intent(in), optional :: eirs,eics - character(len=*), optional :: head - integer, intent(in), optional :: ivr(:), ivc(:) + Integer :: err_act + character(len=20) :: name='csall' + logical, parameter :: debug=.false. + + + call psb_erractionsave(err_act) + info = 0 + allocate(psbn_d_coo_sparse_mat :: a%a, stat=info) + if (info /= 0) then + info = 4000 + call psb_errpush(info, name) + goto 9999 + end if + call a%a%allocate(nr,nc,nz) + call a%set_bld() + + 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 csall + subroutine reallocate_nz(nz,a) + use psb_error_mod + implicit none + integer, intent(in) :: nz + class(psbn_d_sparse_mat), intent(inout) :: a Integer :: err_act, info - character(len=20) :: name='sparse_print' + character(len=20) :: name='reallocate_nz' logical, parameter :: debug=.false. - info = 0 - call psb_erractionsave(err_act) if (.not.allocated(a%a)) then info = 1121 call psb_errpush(info,name) goto 9999 endif - call a%a%print(iout,iv,eirs,eics,head,ivr,ivc) + call a%a%reallocate(nz) + if (info /= 0) goto 9999 call psb_erractionrestore(err_act) return @@ -816,23 +930,16 @@ contains end if return - end subroutine sparse_print + end subroutine reallocate_nz - subroutine get_neigh(a,idx,neigh,n,info,lev) + subroutine free(a) use psb_error_mod implicit none - class(psbn_d_sparse_mat), intent(in) :: a - integer, intent(in) :: idx - integer, intent(out) :: n - integer, allocatable, intent(out) :: neigh(:) - integer, intent(out) :: info - integer, optional, intent(in) :: lev - - Integer :: err_act - character(len=20) :: name='get_neigh' + class(psbn_d_sparse_mat), intent(inout) :: a + Integer :: err_act, info + character(len=20) :: name='free' logical, parameter :: debug=.false. - info = 0 call psb_erractionsave(err_act) if (.not.allocated(a%a)) then info = 1121 @@ -840,9 +947,7 @@ contains goto 9999 endif - call a%a%get_neigh(idx,neigh,n,info,lev) - - if (info /= 0) goto 9999 + call a%a%free() call psb_erractionrestore(err_act) return @@ -856,64 +961,79 @@ contains end if return - end subroutine get_neigh - + end subroutine free - subroutine allocate_mnnz(m,n,a,nz,type,mold) + subroutine csput(nz,val,ia,ja,a,imin,imax,jmin,jmax,info,gtl) + use psbn_d_base_mat_mod use psb_error_mod - use psb_string_mod implicit none - integer, intent(in) :: m,n class(psbn_d_sparse_mat), intent(inout) :: a - integer, intent(in), optional :: nz - character(len=*), intent(in), optional :: type - class(psbn_d_base_sparse_mat), intent(in), optional :: mold + real(psb_dpk_), intent(in) :: val(:) + integer, intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax + integer, intent(out) :: info + integer, intent(in), optional :: gtl(:) - Integer :: err_act, info - character(len=20) :: name='allocate_mnnz' - character(len=8) :: type_ + Integer :: err_act + character(len=20) :: name='csput' logical, parameter :: debug=.false. - + info = 0 call psb_erractionsave(err_act) - info = 0 - if (allocated(a%a)) then - call a%a%free() - deallocate(a%a) - end if + if (.not.a%is_bld()) then + info = 1121 + call psb_errpush(info,name) + goto 9999 + endif - if (present(mold)) then - allocate(a%a, source=mold, stat=info) - else + call a%a%csput(nz,val,ia,ja,imin,imax,jmin,jmax,info,gtl) + if (info /= 0) goto 9999 - if (present(type)) then - type_ = psb_toupper(type) - else - type_ = 'COO' - end if + call psb_erractionrestore(err_act) + return - 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. +9999 continue + call psb_erractionrestore(err_act) -!!$ case('CSR') -!!$ allocate(psbn_d_csr_sparse_mat :: a%a, stat=info) + if (err_act == psb_act_abort_) then + call psb_error() + return + end if - case default - allocate(psbn_d_coo_sparse_mat :: a%a, stat=info) - end select + end subroutine csput - end if + subroutine csget(nz,val,ia,ja,a,imin,imax,jmin,jmax,info,gtl) + use psbn_d_base_mat_mod + use psb_error_mod + implicit none + class(psbn_d_sparse_mat), intent(inout) :: a + real(psb_dpk_), intent(in) :: val(:) + integer, intent(out) :: nz, ia(:), ja(:) + integer, intent(in) :: imin,imax,jmin,jmax + integer, intent(out) :: info + integer, intent(in), optional :: gtl(:) - if (info /= 0) then - info = 4010 + Integer :: err_act + character(len=20) :: name='csput' + logical, parameter :: debug=.false. + + info = 0 + call psb_erractionsave(err_act) + if (a%is_null()) then + info = 1121 + call psb_errpush(info,name) goto 9999 - end if - - call a%a%allocate(m,n,nz) - + endif + + info = 700 + call psb_errpush(info,name,a_err='CSGET') + goto 9999 + + +!!$ +!!$ call a%a%csget(nz,val,ia,ja,imin,imax,jmin,jmax,info,gtl) +!!$ if (info /= 0) goto 9999 + call psb_erractionrestore(err_act) return @@ -924,29 +1044,85 @@ contains call psb_error() return end if - return + end subroutine csget - end subroutine allocate_mnnz - subroutine reallocate_nz(nz,a) + subroutine d_cscnv(a,b,info,type,mold,upd,dupl) use psb_error_mod + use psb_string_mod implicit none - integer, intent(in) :: nz - class(psbn_d_sparse_mat), intent(inout) :: a - Integer :: err_act, info - character(len=20) :: name='reallocate_nz' + class(psbn_d_sparse_mat), intent(in) :: a + class(psbn_d_sparse_mat), intent(out) :: b + integer, intent(out) :: info + integer,optional, intent(in) :: dupl, upd + character(len=*), optional, intent(in) :: type + class(psbn_d_base_sparse_mat), intent(in), optional :: mold + + + class(psbn_d_base_sparse_mat), allocatable :: altmp + Integer :: err_act + character(len=20) :: name='cscnv' logical, parameter :: debug=.false. - if (.not.allocated(a%a)) then + info = 0 + call psb_erractionsave(err_act) + + if (a%is_null()) then info = 1121 call psb_errpush(info,name) goto 9999 endif - call a%a%reallocate(nz) + if (present(dupl)) then + call b%set_dupl(dupl) + else if (a%is_bld()) then + ! Does this make sense at all?? Who knows.. + call b%set_dupl(psbn_dupl_def_) + end if - if (info /= 0) goto 9999 + if (count( (/present(mold),present(type) /)) > 1) then + info = 583 + call psb_errpush(info,name,a_err='TYPE, MOLD') + goto 9999 + end if + + if (present(mold)) then + + allocate(altmp, source=mold,stat=info) + + else if (present(type)) then + + select case (psb_toupper(type)) + case ('CSR') + allocate(psbn_d_csr_sparse_mat :: altmp, stat=info) + case ('COO') + allocate(psbn_d_coo_sparse_mat :: altmp, stat=info) + case default + info = 136 + call psb_errpush(info,name,a_err=type) + goto 9999 + end select + else + allocate(psbn_d_csr_sparse_mat :: altmp, stat=info) + end if + + if (info /= 0) then + info = 4000 + call psb_errpush(info,name) + goto 9999 + end if + + call altmp%cp_from_fmt(a%a, info) + + if (info /= 0) then + info = 4010 + call psb_errpush(info,name,a_err="mv_from") + goto 9999 + end if + + call move_alloc(altmp,b%a) + call b%set_asb() call psb_erractionrestore(err_act) return @@ -958,26 +1134,84 @@ contains call psb_error() return end if - return - end subroutine reallocate_nz + end subroutine d_cscnv - subroutine free(a) + + subroutine d_cscnv_ip(a,info,type,mold,dupl) use psb_error_mod + use psb_string_mod implicit none + class(psbn_d_sparse_mat), intent(inout) :: a - Integer :: err_act, info - character(len=20) :: name='free' + integer, intent(out) :: info + integer,optional, intent(in) :: dupl + character(len=*), optional, intent(in) :: type + class(psbn_d_base_sparse_mat), intent(in), optional :: mold + + + class(psbn_d_base_sparse_mat), allocatable :: altmp + Integer :: err_act + character(len=20) :: name='cscnv_ip' logical, parameter :: debug=.false. + info = 0 call psb_erractionsave(err_act) - if (.not.allocated(a%a)) then + + if (a%is_null()) then info = 1121 call psb_errpush(info,name) goto 9999 endif - call a%a%free() + if (present(dupl)) then + call a%set_dupl(dupl) + else if (a%is_bld()) then + call a%set_dupl(psbn_dupl_def_) + end if + + if (count( (/present(mold),present(type) /)) > 1) then + info = 583 + call psb_errpush(info,name,a_err='TYPE, MOLD') + goto 9999 + end if + + if (present(mold)) then + + allocate(altmp, source=mold,stat=info) + + else if (present(type)) then + + select case (psb_toupper(type)) + case ('CSR') + allocate(psbn_d_csr_sparse_mat :: altmp, stat=info) + case ('COO') + allocate(psbn_d_coo_sparse_mat :: altmp, stat=info) + case default + info = 136 + call psb_errpush(info,name,a_err=type) + goto 9999 + end select + else + allocate(psbn_d_csr_sparse_mat :: altmp, stat=info) + end if + + if (info /= 0) then + info = 4000 + call psb_errpush(info,name) + goto 9999 + end if + + call altmp%mv_from_fmt(a%a, info) + + if (info /= 0) then + info = 4010 + call psb_errpush(info,name,a_err="mv_from") + goto 9999 + end if + + call move_alloc(altmp,a%a) + call a%set_asb() call psb_erractionrestore(err_act) return @@ -989,9 +1223,26 @@ contains call psb_error() return end if - return - end subroutine free + end subroutine d_cscnv_ip + + + + + + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! + ! + ! + ! Computational routines + ! + ! + ! + ! + ! + ! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! subroutine d_csmm(alpha,a,x,beta,y,info,trans) @@ -1014,7 +1265,7 @@ contains goto 9999 endif - call a%a%psbn_csmm(alpha,x,beta,y,info,trans) + call a%a%csmm(alpha,x,beta,y,info,trans) call psb_erractionrestore(err_act) return @@ -1050,7 +1301,7 @@ contains goto 9999 endif - call a%a%psbn_csmm(alpha,x,beta,y,info,trans) + call a%a%csmm(alpha,x,beta,y,info,trans) call psb_erractionrestore(err_act) return @@ -1085,8 +1336,8 @@ contains call psb_errpush(info,name) goto 9999 endif - - call a%a%psbn_cssm(alpha,x,beta,y,info,trans) + + call a%a%cssm(alpha,x,beta,y,info,trans) call psb_erractionrestore(err_act) return @@ -1122,7 +1373,7 @@ contains goto 9999 endif - call a%a%psbn_cssm(alpha,x,beta,y,info,trans) + call a%a%cssm(alpha,x,beta,y,info,trans) call psb_erractionrestore(err_act) diff --git a/test/serial/d_coo_matgen.f03 b/test/serial/d_coo_matgen.f03 index db3c089a..843f5719 100644 --- a/test/serial/d_coo_matgen.f03 +++ b/test/serial/d_coo_matgen.f03 @@ -357,7 +357,7 @@ contains endif end do - call acoo%csins(element-1,val,irow,icol,1,nr,1,nr,info) + call acoo%csput(element-1,val,irow,icol,1,nr,1,nr,info) end do diff --git a/test/serial/d_matgen.f03 b/test/serial/d_matgen.f03 index 8f7365a8..a2a7110d 100644 --- a/test/serial/d_matgen.f03 +++ b/test/serial/d_matgen.f03 @@ -201,7 +201,7 @@ contains t0 = psb_wtime() - call psbn_csall(nr,nr,a_n,info) + call a_n%csall(nr,nr,info) talc = psb_wtime()-t0 @@ -357,7 +357,7 @@ contains endif end do - call psbn_csins(element-1,val,irow,icol,a_n,1,nr,1,nr,info) + call a_n%csput(element-1,val,irow,icol,1,nr,1,nr,info) end do @@ -368,9 +368,9 @@ contains call psb_errpush(info,name,a_err=ch_err) goto 9999 end if - + call a_n%print(19) t1 = psb_wtime() - call psbn_cscnv(a_n,info,mold=acxx) + call a_n%cscnv(info,mold=acsr) if(info /= 0) then info=4010 @@ -380,18 +380,19 @@ contains end if tasb = psb_wtime()-t1 call a_n%print(20) - -!!$ t1 = psb_wtime() -!!$ call psbn_cscnv(a_n,info,mold=acoo) !!$ -!!$ if(info /= 0) then -!!$ info=4010 -!!$ ch_err='asb rout.' -!!$ call psb_errpush(info,name,a_err=ch_err) -!!$ goto 9999 -!!$ end if -!!$ tmov = psb_wtime()-t1 + t1 = psb_wtime() + call a_n%cscnv(info,mold=acxx) + if(info /= 0) then + info=4010 + ch_err='asb rout.' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + tmov = psb_wtime()-t1 + call a_n%print(21) +!!$ if(iam == psb_root_) then write(*,'("The matrix has been generated and is currently in ",a3," format.")')& diff --git a/test/serial/psbn_d_cxx_impl.f03 b/test/serial/psbn_d_cxx_impl.f03 index 3c2822c5..caee3d06 100644 --- a/test/serial/psbn_d_cxx_impl.f03 +++ b/test/serial/psbn_d_cxx_impl.f03 @@ -942,10 +942,10 @@ end subroutine d_cxx_cssm_impl -subroutine d_cxx_csins_impl(nz,val,ia,ja,a,imin,imax,jmin,jmax,info,gtl) +subroutine d_cxx_csput_impl(nz,val,ia,ja,a,imin,imax,jmin,jmax,info,gtl) use psb_error_mod use psb_realloc_mod - use psbn_d_cxx_mat_mod, psb_protect_name => d_cxx_csins_impl + use psbn_d_cxx_mat_mod, psb_protect_name => d_cxx_csput_impl implicit none class(psbn_d_cxx_sparse_mat), intent(inout) :: a @@ -956,7 +956,7 @@ subroutine d_cxx_csins_impl(nz,val,ia,ja,a,imin,imax,jmin,jmax,info,gtl) Integer :: err_act - character(len=20) :: name='d_cxx_csins' + character(len=20) :: name='d_cxx_csput' logical, parameter :: debug=.false. integer :: nza, i,j,k, nzl, isza, int_err(5) @@ -1193,7 +1193,7 @@ contains end subroutine d_cxx_srch_upd -end subroutine d_cxx_csins_impl +end subroutine d_cxx_csput_impl @@ -1438,22 +1438,28 @@ subroutine d_mv_cxx_to_fmt_impl(a,b,info) info = 0 - call tmp%mv_from_fmt(a,info) - call b%mv_from_coo(tmp,info) + select type (b) + class is (psbn_d_coo_sparse_mat) + call a%mv_to_coo(b,info) + class default + call tmp%mv_from_fmt(a,info) + if (info == 0) call b%mv_from_coo(tmp,info) + end select end subroutine d_mv_cxx_to_fmt_impl -subroutine d_mv_cxx_from_fmt_impl(a,b,info) + +subroutine d_cp_cxx_to_fmt_impl(a,b,info) use psb_const_mod use psb_realloc_mod use psbn_d_base_mat_mod - use psbn_d_cxx_mat_mod, psb_protect_name => d_mv_cxx_from_fmt_impl + use psbn_d_cxx_mat_mod, psb_protect_name => d_cp_cxx_to_fmt_impl implicit none - class(psbn_d_cxx_sparse_mat), intent(inout) :: a - class(psbn_d_base_sparse_mat), intent(inout) :: b - integer, intent(out) :: info + class(psbn_d_cxx_sparse_mat), intent(in) :: a + class(psbn_d_base_sparse_mat), intent(out) :: b + integer, intent(out) :: info !locals type(psbn_d_coo_sparse_mat) :: tmp @@ -1465,23 +1471,26 @@ subroutine d_mv_cxx_from_fmt_impl(a,b,info) info = 0 - call tmp%mv_from_fmt(b,info) - call a%mv_from_coo(tmp,info) - -end subroutine d_mv_cxx_from_fmt_impl - + select type (b) + class is (psbn_d_coo_sparse_mat) + call a%cp_to_coo(b,info) + class default + call tmp%cp_from_fmt(a,info) + if (info == 0) call b%mv_from_coo(tmp,info) + end select +end subroutine d_cp_cxx_to_fmt_impl -subroutine d_cp_cxx_to_fmt_impl(a,b,info) +subroutine d_cp_cxx_from_fmt_impl(a,b,info) use psb_const_mod use psb_realloc_mod use psbn_d_base_mat_mod - use psbn_d_cxx_mat_mod, psb_protect_name => d_cp_cxx_to_fmt_impl + use psbn_d_cxx_mat_mod, psb_protect_name => d_cp_cxx_from_fmt_impl implicit none - class(psbn_d_cxx_sparse_mat), intent(in) :: a - class(psbn_d_base_sparse_mat), intent(out) :: b - integer, intent(out) :: info + class(psbn_d_cxx_sparse_mat), intent(inout) :: a + class(psbn_d_base_sparse_mat), intent(in) :: b + integer, intent(out) :: info !locals type(psbn_d_coo_sparse_mat) :: tmp @@ -1493,22 +1502,26 @@ subroutine d_cp_cxx_to_fmt_impl(a,b,info) info = 0 - call tmp%cp_from_fmt(a,info) - call b%mv_from_coo(tmp,info) - -end subroutine d_cp_cxx_to_fmt_impl + select type (b) + class is (psbn_d_coo_sparse_mat) + call a%cp_from_coo(b,info) + class default + call tmp%cp_from_fmt(b,info) + if (info == 0) call a%mv_from_coo(tmp,info) + end select +end subroutine d_cp_cxx_from_fmt_impl -subroutine d_cp_cxx_from_fmt_impl(a,b,info) +subroutine d_mv_cxx_from_fmt_impl(a,b,info) use psb_const_mod use psb_realloc_mod use psbn_d_base_mat_mod - use psbn_d_cxx_mat_mod, psb_protect_name => d_cp_cxx_from_fmt_impl + use psbn_d_cxx_mat_mod, psb_protect_name => d_mv_cxx_from_fmt_impl implicit none - class(psbn_d_cxx_sparse_mat), intent(inout) :: a - class(psbn_d_base_sparse_mat), intent(in) :: b - integer, intent(out) :: info + class(psbn_d_cxx_sparse_mat), intent(inout) :: a + class(psbn_d_base_sparse_mat), intent(inout) :: b + integer, intent(out) :: info !locals type(psbn_d_coo_sparse_mat) :: tmp @@ -1520,8 +1533,12 @@ subroutine d_cp_cxx_from_fmt_impl(a,b,info) info = 0 - call tmp%cp_from_fmt(b,info) - call a%mv_from_coo(tmp,info) - -end subroutine d_cp_cxx_from_fmt_impl + select type (b) + class is (psbn_d_coo_sparse_mat) + call a%mv_from_coo(b,info) + class default + call tmp%mv_from_fmt(b,info) + if (info == 0) call a%mv_from_coo(tmp,info) + end select +end subroutine d_mv_cxx_from_fmt_impl diff --git a/test/serial/psbn_d_cxx_mat_mod.f03 b/test/serial/psbn_d_cxx_mat_mod.f03 index bda4cb0f..ebad3431 100644 --- a/test/serial/psbn_d_cxx_mat_mod.f03 +++ b/test/serial/psbn_d_cxx_mat_mod.f03 @@ -14,7 +14,7 @@ module psbn_d_cxx_mat_mod procedure, pass(a) :: d_base_cssm => d_cxx_cssm procedure, pass(a) :: d_base_cssv => d_cxx_cssv procedure, pass(a) :: reallocate_nz => d_cxx_reallocate_nz - procedure, pass(a) :: csins => d_cxx_csins + procedure, pass(a) :: csput => d_cxx_csput procedure, pass(a) :: allocate_mnnz => d_cxx_allocate_mnnz procedure, pass(a) :: cp_to_coo => d_cp_cxx_to_coo procedure, pass(a) :: cp_from_coo => d_cp_cxx_from_coo @@ -29,7 +29,7 @@ module psbn_d_cxx_mat_mod procedure, pass(a) :: get_fmt => d_cxx_get_fmt end type psbn_d_cxx_sparse_mat private :: d_cxx_get_nzeros, d_cxx_csmm, d_cxx_csmv, d_cxx_cssm, d_cxx_cssv, & - & d_cxx_csins, d_cxx_reallocate_nz, d_cxx_allocate_mnnz, & + & d_cxx_csput, d_cxx_reallocate_nz, d_cxx_allocate_mnnz, & & d_cxx_free, d_cxx_print, d_cxx_get_fmt, & & d_cp_cxx_to_coo, d_cp_cxx_from_coo, & & d_mv_cxx_to_coo, d_mv_cxx_from_coo, & @@ -128,7 +128,7 @@ module psbn_d_cxx_mat_mod end interface interface - subroutine d_cxx_csins_impl(nz,val,ia,ja,a,imin,imax,jmin,jmax,info,gtl) + subroutine d_cxx_csput_impl(nz,val,ia,ja,a,imin,imax,jmin,jmax,info,gtl) use psb_const_mod import psbn_d_cxx_sparse_mat class(psbn_d_cxx_sparse_mat), intent(inout) :: a @@ -136,7 +136,7 @@ module psbn_d_cxx_mat_mod integer, intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax integer, intent(out) :: info integer, intent(in), optional :: gtl(:) - end subroutine d_cxx_csins_impl + end subroutine d_cxx_csput_impl end interface interface d_cxx_cssm_impl @@ -235,7 +235,7 @@ contains end function d_cxx_get_nzeros - subroutine d_cxx_csins(nz,val,ia,ja,a,imin,imax,jmin,jmax,info,gtl) + subroutine d_cxx_csput(nz,val,ia,ja,a,imin,imax,jmin,jmax,info,gtl) use psb_const_mod use psb_error_mod implicit none @@ -247,7 +247,7 @@ contains Integer :: err_act - character(len=20) :: name='d_cxx_csins' + character(len=20) :: name='d_cxx_csput' logical, parameter :: debug=.false. integer :: nza, i,j,k, nzl, isza, int_err(5) @@ -282,7 +282,7 @@ contains if (nz == 0) return - call d_cxx_csins_impl(nz,val,ia,ja,a,imin,imax,jmin,jmax,info,gtl) + call d_cxx_csput_impl(nz,val,ia,ja,a,imin,imax,jmin,jmax,info,gtl) if (info /= 0) goto 9999 call psb_erractionrestore(err_act) @@ -296,7 +296,7 @@ contains return end if return - end subroutine d_cxx_csins + end subroutine d_cxx_csput subroutine d_cxx_csmv(alpha,a,x,beta,y,info,trans) @@ -601,22 +601,22 @@ contains return end subroutine d_cp_cxx_to_fmt - - subroutine d_cp_cxx_from_fmt(a,b,info) + + subroutine d_mv_cxx_to_coo(a,b,info) use psb_error_mod use psb_realloc_mod implicit none class(psbn_d_cxx_sparse_mat), intent(inout) :: a - class(psbn_d_base_sparse_mat), intent(in) :: b - integer, intent(out) :: info + class(psbn_d_coo_sparse_mat), intent(out) :: b + integer, intent(out) :: info Integer :: err_act - character(len=20) :: name='from_fmt' + character(len=20) :: name='to_coo' logical, parameter :: debug=.false. call psb_erractionsave(err_act) info = 0 - call d_cp_cxx_from_fmt_impl(a,b,info) + call d_mv_cxx_to_coo_impl(a,b,info) if (info /= 0) goto 9999 call psb_erractionrestore(err_act) @@ -632,24 +632,24 @@ contains end if return - end subroutine d_cp_cxx_from_fmt - - - subroutine d_mv_cxx_to_coo(a,b,info) + end subroutine d_mv_cxx_to_coo + + + subroutine d_cp_cxx_from_fmt(a,b,info) use psb_error_mod use psb_realloc_mod implicit none class(psbn_d_cxx_sparse_mat), intent(inout) :: a - class(psbn_d_coo_sparse_mat), intent(out) :: b - integer, intent(out) :: info + class(psbn_d_base_sparse_mat), intent(in) :: b + integer, intent(out) :: info Integer :: err_act - character(len=20) :: name='to_coo' + character(len=20) :: name='from_fmt' logical, parameter :: debug=.false. call psb_erractionsave(err_act) info = 0 - call d_mv_cxx_to_coo_impl(a,b,info) + call d_cp_cxx_from_fmt_impl(a,b,info) if (info /= 0) goto 9999 call psb_erractionrestore(err_act) @@ -665,8 +665,8 @@ contains end if return - end subroutine d_mv_cxx_to_coo - + end subroutine d_cp_cxx_from_fmt + subroutine d_mv_cxx_from_coo(a,b,info) use psb_error_mod use psb_realloc_mod