diff --git a/base/modules/psb_base_mat_mod.f90 b/base/modules/psb_base_mat_mod.f90 index 4d2a9dde..24802140 100644 --- a/base/modules/psb_base_mat_mod.f90 +++ b/base/modules/psb_base_mat_mod.f90 @@ -177,6 +177,7 @@ module psb_base_mat_mod ! == = ================================= procedure, pass(a) :: get_neigh => psb_base_get_neigh procedure, pass(a) :: free => psb_base_free + procedure, pass(a) :: copy => psb_base_copy procedure, pass(a) :: trim => psb_base_trim procedure, pass(a) :: reinit => psb_base_reinit procedure, pass(a) :: allocate_mnnz => psb_base_allocate_mnnz @@ -187,10 +188,10 @@ module psb_base_mat_mod generic, public :: csget => csgetptn procedure, pass(a) :: print => psb_base_sparse_print procedure, pass(a) :: sizeof => psb_base_sizeof - procedure, pass(a) :: psb_base_cp_from - generic, public :: cp_from => psb_base_cp_from - procedure, pass(a) :: psb_base_mv_from - generic, public :: mv_from => psb_base_mv_from +!!$ procedure, pass(a) :: psb_base_cp_from +!!$ generic, public :: cp_from => psb_base_cp_from +!!$ procedure, pass(a) :: psb_base_mv_from +!!$ generic, public :: mv_from => psb_base_mv_from procedure, pass(a) :: transp_1mat => psb_base_transp_1mat procedure, pass(a) :: transp_2mat => psb_base_transp_2mat generic, public :: transp => transp_1mat, transp_2mat @@ -653,46 +654,65 @@ contains end function psb_base_is_sorted - ! - ! MV|CP_FROM: at base level they are the same. - ! - ! - - subroutine psb_base_mv_from(a,b) - implicit none - - class(psb_base_sparse_mat), intent(out) :: a - type(psb_base_sparse_mat), intent(inout) :: b - - a%m = b%m - a%n = b%n - a%state = b%state - a%duplicate = b%duplicate - a%triangle = b%triangle - a%unitd = b%unitd - a%upper = b%upper - a%sorted = b%sorted - - end subroutine psb_base_mv_from +!!$ ! +!!$ ! MV|CP_FROM: at base level they are the same. +!!$ ! +!!$ ! +!!$ +!!$ subroutine psb_base_mv_from(a,b) +!!$ implicit none +!!$ +!!$ class(psb_base_sparse_mat), intent(out) :: a +!!$ type(psb_base_sparse_mat), intent(inout) :: b +!!$ +!!$ a%m = b%m +!!$ a%n = b%n +!!$ a%state = b%state +!!$ a%duplicate = b%duplicate +!!$ a%triangle = b%triangle +!!$ a%unitd = b%unitd +!!$ a%upper = b%upper +!!$ a%sorted = b%sorted +!!$ +!!$ end subroutine psb_base_mv_from - subroutine psb_base_cp_from(a,b) - implicit none - - class(psb_base_sparse_mat), intent(out) :: a - type(psb_base_sparse_mat), intent(in) :: b - - a%m = b%m - a%n = b%n - a%state = b%state - a%duplicate = b%duplicate - a%triangle = b%triangle - a%unitd = b%unitd - a%upper = b%upper - a%sorted = b%sorted - - end subroutine psb_base_cp_from - + subroutine psb_base_copy(a,b,info) + implicit none + + class(psb_base_sparse_mat), intent(in) :: a + class(psb_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + info = 0 + b%m = a%m + b%n = a%n + b%state = a%state + b%duplicate = a%duplicate + b%triangle = a%triangle + b%unitd = a%unitd + b%upper = a%upper + b%sorted = a%sorted + + end subroutine psb_base_copy + +!!$ subroutine psb_base_cp_from(a,b) +!!$ implicit none +!!$ +!!$ class(psb_base_sparse_mat), intent(out) :: a +!!$ type(psb_base_sparse_mat), intent(in) :: b +!!$ +!!$ a%m = b%m +!!$ a%n = b%n +!!$ a%state = b%state +!!$ a%duplicate = b%duplicate +!!$ a%triangle = b%triangle +!!$ a%unitd = b%unitd +!!$ a%upper = b%upper +!!$ a%sorted = b%sorted +!!$ +!!$ end subroutine psb_base_cp_from +!!$ ! ! TRANSP: note sorted=.false. ! better invoke a fix() too many than diff --git a/base/modules/psb_c_base_mat_mod.f90 b/base/modules/psb_c_base_mat_mod.f90 index 8c8a60a9..9924fb0c 100644 --- a/base/modules/psb_c_base_mat_mod.f90 +++ b/base/modules/psb_c_base_mat_mod.f90 @@ -71,11 +71,8 @@ module psb_c_base_mat_mod procedure, pass(a) :: mv_from_coo => psb_c_base_mv_from_coo procedure, pass(a) :: mv_to_fmt => psb_c_base_mv_to_fmt procedure, pass(a) :: mv_from_fmt => psb_c_base_mv_from_fmt - procedure, pass(a) :: c_base_cp_from - generic, public :: cp_from => c_base_cp_from - procedure, pass(a) :: c_base_mv_from - generic, public :: mv_from => c_base_mv_from procedure, pass(a) :: mold => psb_c_base_mold + procedure, pass(a) :: copy => psb_c_base_copy procedure, pass(a) :: clone => psb_c_base_clone ! @@ -113,9 +110,6 @@ module psb_c_base_mat_mod procedure, pass(a) :: aclsum => psb_c_base_aclsum end type psb_c_base_sparse_mat - private :: c_base_cp_from, c_base_mv_from - - !> \namespace psb_base_mod \class psb_c_coo_sparse_mat !! \extends psb_c_base_mat_mod::psb_c_base_sparse_mat !! @@ -164,10 +158,8 @@ module psb_c_base_mat_mod procedure, pass(a) :: print => psb_c_coo_print procedure, pass(a) :: free => c_coo_free procedure, pass(a) :: mold => psb_c_coo_mold - procedure, pass(a) :: psb_c_coo_cp_from - generic, public :: cp_from => psb_c_coo_cp_from - procedure, pass(a) :: psb_c_coo_mv_from - generic, public :: mv_from => psb_c_coo_mv_from + procedure, pass(a) :: copy => psb_c_coo_copy +!!$ procedure, pass(a) :: clone => psb_c_coo_clone ! ! This is COO specific ! @@ -412,19 +404,40 @@ module psb_c_base_mat_mod interface subroutine psb_c_base_mold(a,b,info) import :: psb_ipk_, psb_c_base_sparse_mat, psb_long_int_k_ - class(psb_c_base_sparse_mat), intent(in) :: a - class(psb_c_base_sparse_mat), intent(out), allocatable :: b - integer(psb_ipk_), intent(out) :: info + class(psb_c_base_sparse_mat), intent(in) :: a + class(psb_c_base_sparse_mat), intent(inout), allocatable :: b + integer(psb_ipk_), intent(out) :: info end subroutine psb_c_base_mold end interface + ! + !> Function copy: + !! \memberof psb_c_base_sparse_mat + !! \brief Copy a class(psb_c_base_sparse_mat) + !! but only if it is the same dynamic type as the input. + !! \param b The output variable + !! \param info return code + ! + interface + subroutine psb_c_base_copy(a,b, info) + import :: psb_ipk_, psb_c_base_sparse_mat, psb_long_int_k_ + implicit none + class(psb_c_base_sparse_mat), intent(in) :: a + class(psb_c_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_c_base_copy + end interface + + ! !> Function clone: !! \memberof psb_c_base_sparse_mat !! \brief Allocate and clone a class(psb_c_base_sparse_mat) with the - !! same dynamic type as the input. + !! same dynamic type as the input. !! This is equivalent to allocate( source= ) except that !! it should guarantee a deep copy wherever needed. + !! Should also be equivalent to calling mold and then copy, + !! but it can also be implemented by default using cp_to_fmt. !! \param b The output variable !! \param info return code ! @@ -434,7 +447,7 @@ module psb_c_base_mat_mod implicit none class(psb_c_base_sparse_mat), intent(inout) :: a class(psb_c_base_sparse_mat), allocatable, intent(inout) :: b - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info end subroutine psb_c_base_clone end interface @@ -1131,19 +1144,40 @@ module psb_c_base_mat_mod end subroutine psb_c_coo_allocate_mnnz end interface - ! - !> - !! \memberof psb_c_coo_sparse_mat - !! \see psb_c_base_mat_mod::psb_c_base_mold - ! + + !> \memberof psb_c_coo_sparse_mat + !| \see psb_base_mat_mod::psb_base_mold interface subroutine psb_c_coo_mold(a,b,info) import :: psb_ipk_, psb_c_coo_sparse_mat, psb_c_base_sparse_mat, psb_long_int_k_ - class(psb_c_coo_sparse_mat), intent(in) :: a - class(psb_c_base_sparse_mat), intent(out), allocatable :: b - integer(psb_ipk_), intent(out) :: info + class(psb_c_coo_sparse_mat), intent(in) :: a + class(psb_c_base_sparse_mat), intent(inout), allocatable :: b + integer(psb_ipk_), intent(out) :: info end subroutine psb_c_coo_mold end interface + + !> \memberof psb_c_coo_sparse_mat + !| \see psb_base_mat_mod::psb_base_copy + interface + subroutine psb_c_coo_copy(a,b,info) + import :: psb_ipk_, psb_c_coo_sparse_mat, psb_c_base_sparse_mat, psb_long_int_k_ + class(psb_c_coo_sparse_mat), intent(in) :: a + class(psb_c_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_c_coo_copy + end interface + +!!$ !> \memberof psb_c_coo_sparse_mat +!!$ !| \see psb_base_mat_mod::psb_base_copy +!!$ interface +!!$ subroutine psb_c_coo_clone(a,b,info) +!!$ import :: psb_ipk_, psb_c_coo_sparse_mat, psb_c_base_sparse_mat, psb_long_int_k_ +!!$ class(psb_c_coo_sparse_mat), intent(inout) :: a +!!$ class(psb_c_base_sparse_mat), intent(inout), allocatable :: b +!!$ integer(psb_ipk_), intent(out) :: info +!!$ end subroutine psb_c_coo_clone +!!$ end interface + ! @@ -1584,35 +1618,6 @@ module psb_c_base_mat_mod contains - - subroutine c_base_mv_from(a,b) - - implicit none - - class(psb_c_base_sparse_mat), intent(out) :: a - type(psb_c_base_sparse_mat), intent(inout) :: b - - - ! No new things here, very easy - call a%psb_base_sparse_mat%mv_from(b%psb_base_sparse_mat) - - return - - end subroutine c_base_mv_from - - subroutine c_base_cp_from(a,b) - implicit none - - class(psb_c_base_sparse_mat), intent(out) :: a - type(psb_c_base_sparse_mat), intent(in) :: b - - ! No new things here, very easy - call a%psb_base_sparse_mat%cp_from(b%psb_base_sparse_mat) - - return - - end subroutine c_base_cp_from - ! == ================================== diff --git a/base/modules/psb_c_csc_mat_mod.f90 b/base/modules/psb_c_csc_mat_mod.f90 index 1c22d4db..9821a181 100644 --- a/base/modules/psb_c_csc_mat_mod.f90 +++ b/base/modules/psb_c_csc_mat_mod.f90 @@ -97,10 +97,7 @@ module psb_c_csc_mat_mod procedure, pass(a) :: print => psb_c_csc_print procedure, pass(a) :: free => c_csc_free procedure, pass(a) :: mold => psb_c_csc_mold - procedure, pass(a) :: psb_c_csc_cp_from - generic, public :: cp_from => psb_c_csc_cp_from - procedure, pass(a) :: psb_c_csc_mv_from - generic, public :: mv_from => psb_c_csc_mv_from + procedure, pass(a) :: copy => psb_c_csc_copy end type psb_c_csc_sparse_mat @@ -141,12 +138,23 @@ module psb_c_csc_mat_mod interface subroutine psb_c_csc_mold(a,b,info) import :: psb_ipk_, psb_c_csc_sparse_mat, psb_c_base_sparse_mat, psb_long_int_k_ - class(psb_c_csc_sparse_mat), intent(in) :: a - class(psb_c_base_sparse_mat), intent(out), allocatable :: b - integer(psb_ipk_), intent(out) :: info + class(psb_c_csc_sparse_mat), intent(in) :: a + class(psb_c_base_sparse_mat), intent(inout), allocatable :: b + integer(psb_ipk_), intent(out) :: info end subroutine psb_c_csc_mold end interface - + + !> \memberof psb_c_csc_sparse_mat + !| \see psb_base_mat_mod::psb_base_copy + interface + subroutine psb_c_csc_copy(a,b,info) + import :: psb_ipk_, psb_c_csc_sparse_mat, psb_c_base_sparse_mat, psb_long_int_k_ + class(psb_c_csc_sparse_mat), intent(in) :: a + class(psb_c_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_c_csc_copy + end interface + !> \memberof psb_c_csc_sparse_mat !| \see psb_base_mat_mod::psb_base_allocate_mnnz diff --git a/base/modules/psb_c_csr_mat_mod.f90 b/base/modules/psb_c_csr_mat_mod.f90 index 1f6c44e9..2fe1e2b0 100644 --- a/base/modules/psb_c_csr_mat_mod.f90 +++ b/base/modules/psb_c_csr_mat_mod.f90 @@ -98,10 +98,7 @@ module psb_c_csr_mat_mod procedure, pass(a) :: print => psb_c_csr_print procedure, pass(a) :: free => c_csr_free procedure, pass(a) :: mold => psb_c_csr_mold - procedure, pass(a) :: psb_c_csr_cp_from - generic, public :: cp_from => psb_c_csr_cp_from - procedure, pass(a) :: psb_c_csr_mv_from - generic, public :: mv_from => psb_c_csr_mv_from + procedure, pass(a) :: copy => psb_c_csr_copy end type psb_c_csr_sparse_mat @@ -143,13 +140,23 @@ module psb_c_csr_mat_mod interface subroutine psb_c_csr_mold(a,b,info) import :: psb_ipk_, psb_c_csr_sparse_mat, psb_c_base_sparse_mat, psb_long_int_k_ - class(psb_c_csr_sparse_mat), intent(in) :: a - class(psb_c_base_sparse_mat), intent(out), allocatable :: b - integer(psb_ipk_), intent(out) :: info + class(psb_c_csr_sparse_mat), intent(in) :: a + class(psb_c_base_sparse_mat), intent(inout), allocatable :: b + integer(psb_ipk_), intent(out) :: info end subroutine psb_c_csr_mold end interface - - + + !> \memberof psb_c_csr_sparse_mat + !| \see psb_base_mat_mod::psb_base_copy + interface + subroutine psb_c_csr_copy(a,b,info) + import :: psb_ipk_, psb_c_csr_sparse_mat, psb_c_base_sparse_mat, psb_long_int_k_ + class(psb_c_csr_sparse_mat), intent(in) :: a + class(psb_c_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_c_csr_copy + end interface + !> \memberof psb_c_csr_sparse_mat !| \see psb_base_mat_mod::psb_base_allocate_mnnz interface diff --git a/base/modules/psb_c_mat_mod.f90 b/base/modules/psb_c_mat_mod.f90 index aa623bef..19c0d322 100644 --- a/base/modules/psb_c_mat_mod.f90 +++ b/base/modules/psb_c_mat_mod.f90 @@ -154,6 +154,7 @@ module psb_c_mat_mod procedure, pass(a) :: cscnv_ip => psb_c_cscnv_ip procedure, pass(a) :: cscnv_base => psb_c_cscnv_base generic, public :: cscnv => cscnv_np, cscnv_ip, cscnv_base + procedure, pass(a) :: copy => psb_cspmat_copy procedure, pass(a) :: clone => psb_cspmat_clone ! Computational routines @@ -609,6 +610,15 @@ module psb_c_mat_mod end subroutine psb_cspmat_type_move end interface + interface + subroutine psb_cspmat_copy(a,b,info) + import :: psb_ipk_, psb_cspmat_type + class(psb_cspmat_type), intent(inout) :: a + class(psb_cspmat_type), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_cspmat_copy + end interface + interface subroutine psb_cspmat_clone(a,b,info) import :: psb_ipk_, psb_cspmat_type diff --git a/base/modules/psb_d_base_mat_mod.f90 b/base/modules/psb_d_base_mat_mod.f90 index 828a52ef..80ccc4e3 100644 --- a/base/modules/psb_d_base_mat_mod.f90 +++ b/base/modules/psb_d_base_mat_mod.f90 @@ -71,11 +71,8 @@ module psb_d_base_mat_mod procedure, pass(a) :: mv_from_coo => psb_d_base_mv_from_coo procedure, pass(a) :: mv_to_fmt => psb_d_base_mv_to_fmt procedure, pass(a) :: mv_from_fmt => psb_d_base_mv_from_fmt - procedure, pass(a) :: d_base_cp_from - generic, public :: cp_from => d_base_cp_from - procedure, pass(a) :: d_base_mv_from - generic, public :: mv_from => d_base_mv_from procedure, pass(a) :: mold => psb_d_base_mold + procedure, pass(a) :: copy => psb_d_base_copy procedure, pass(a) :: clone => psb_d_base_clone ! @@ -113,9 +110,6 @@ module psb_d_base_mat_mod procedure, pass(a) :: aclsum => psb_d_base_aclsum end type psb_d_base_sparse_mat - private :: d_base_cp_from, d_base_mv_from - - !> \namespace psb_base_mod \class psb_d_coo_sparse_mat !! \extends psb_d_base_mat_mod::psb_d_base_sparse_mat !! @@ -164,10 +158,8 @@ module psb_d_base_mat_mod procedure, pass(a) :: print => psb_d_coo_print procedure, pass(a) :: free => d_coo_free procedure, pass(a) :: mold => psb_d_coo_mold - procedure, pass(a) :: psb_d_coo_cp_from - generic, public :: cp_from => psb_d_coo_cp_from - procedure, pass(a) :: psb_d_coo_mv_from - generic, public :: mv_from => psb_d_coo_mv_from + procedure, pass(a) :: copy => psb_d_coo_copy +!!$ procedure, pass(a) :: clone => psb_d_coo_clone ! ! This is COO specific ! @@ -412,19 +404,40 @@ module psb_d_base_mat_mod interface subroutine psb_d_base_mold(a,b,info) import :: psb_ipk_, psb_d_base_sparse_mat, psb_long_int_k_ - class(psb_d_base_sparse_mat), intent(in) :: a - class(psb_d_base_sparse_mat), intent(out), allocatable :: b - integer(psb_ipk_), intent(out) :: info + class(psb_d_base_sparse_mat), intent(in) :: a + class(psb_d_base_sparse_mat), intent(inout), allocatable :: b + integer(psb_ipk_), intent(out) :: info end subroutine psb_d_base_mold end interface + ! + !> Function copy: + !! \memberof psb_d_base_sparse_mat + !! \brief Copy a class(psb_d_base_sparse_mat) + !! but only if it is the same dynamic type as the input. + !! \param b The output variable + !! \param info return code + ! + interface + subroutine psb_d_base_copy(a,b, info) + import :: psb_ipk_, psb_d_base_sparse_mat, psb_long_int_k_ + implicit none + class(psb_d_base_sparse_mat), intent(in) :: a + class(psb_d_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_d_base_copy + end interface + + ! !> Function clone: !! \memberof psb_d_base_sparse_mat !! \brief Allocate and clone a class(psb_d_base_sparse_mat) with the - !! same dynamic type as the input. + !! same dynamic type as the input. !! This is equivalent to allocate( source= ) except that !! it should guarantee a deep copy wherever needed. + !! Should also be equivalent to calling mold and then copy, + !! but it can also be implemented by default using cp_to_fmt. !! \param b The output variable !! \param info return code ! @@ -434,7 +447,7 @@ module psb_d_base_mat_mod implicit none class(psb_d_base_sparse_mat), intent(inout) :: a class(psb_d_base_sparse_mat), allocatable, intent(inout) :: b - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info end subroutine psb_d_base_clone end interface @@ -1131,19 +1144,40 @@ module psb_d_base_mat_mod end subroutine psb_d_coo_allocate_mnnz end interface - ! - !> - !! \memberof psb_d_coo_sparse_mat - !! \see psb_d_base_mat_mod::psb_d_base_mold - ! + + !> \memberof psb_d_coo_sparse_mat + !| \see psb_base_mat_mod::psb_base_mold interface subroutine psb_d_coo_mold(a,b,info) import :: psb_ipk_, psb_d_coo_sparse_mat, psb_d_base_sparse_mat, psb_long_int_k_ - class(psb_d_coo_sparse_mat), intent(in) :: a - class(psb_d_base_sparse_mat), intent(out), allocatable :: b - integer(psb_ipk_), intent(out) :: info + class(psb_d_coo_sparse_mat), intent(in) :: a + class(psb_d_base_sparse_mat), intent(inout), allocatable :: b + integer(psb_ipk_), intent(out) :: info end subroutine psb_d_coo_mold end interface + + !> \memberof psb_d_coo_sparse_mat + !| \see psb_base_mat_mod::psb_base_copy + interface + subroutine psb_d_coo_copy(a,b,info) + import :: psb_ipk_, psb_d_coo_sparse_mat, psb_d_base_sparse_mat, psb_long_int_k_ + class(psb_d_coo_sparse_mat), intent(in) :: a + class(psb_d_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_d_coo_copy + end interface + +!!$ !> \memberof psb_d_coo_sparse_mat +!!$ !| \see psb_base_mat_mod::psb_base_copy +!!$ interface +!!$ subroutine psb_d_coo_clone(a,b,info) +!!$ import :: psb_ipk_, psb_d_coo_sparse_mat, psb_d_base_sparse_mat, psb_long_int_k_ +!!$ class(psb_d_coo_sparse_mat), intent(inout) :: a +!!$ class(psb_d_base_sparse_mat), intent(inout), allocatable :: b +!!$ integer(psb_ipk_), intent(out) :: info +!!$ end subroutine psb_d_coo_clone +!!$ end interface + ! @@ -1584,35 +1618,6 @@ module psb_d_base_mat_mod contains - - subroutine d_base_mv_from(a,b) - - implicit none - - class(psb_d_base_sparse_mat), intent(out) :: a - type(psb_d_base_sparse_mat), intent(inout) :: b - - - ! No new things here, very easy - call a%psb_base_sparse_mat%mv_from(b%psb_base_sparse_mat) - - return - - end subroutine d_base_mv_from - - subroutine d_base_cp_from(a,b) - implicit none - - class(psb_d_base_sparse_mat), intent(out) :: a - type(psb_d_base_sparse_mat), intent(in) :: b - - ! No new things here, very easy - call a%psb_base_sparse_mat%cp_from(b%psb_base_sparse_mat) - - return - - end subroutine d_base_cp_from - ! == ================================== diff --git a/base/modules/psb_d_csc_mat_mod.f90 b/base/modules/psb_d_csc_mat_mod.f90 index 4649ab91..0d7ceb6c 100644 --- a/base/modules/psb_d_csc_mat_mod.f90 +++ b/base/modules/psb_d_csc_mat_mod.f90 @@ -97,10 +97,7 @@ module psb_d_csc_mat_mod procedure, pass(a) :: print => psb_d_csc_print procedure, pass(a) :: free => d_csc_free procedure, pass(a) :: mold => psb_d_csc_mold - procedure, pass(a) :: psb_d_csc_cp_from - generic, public :: cp_from => psb_d_csc_cp_from - procedure, pass(a) :: psb_d_csc_mv_from - generic, public :: mv_from => psb_d_csc_mv_from + procedure, pass(a) :: copy => psb_d_csc_copy end type psb_d_csc_sparse_mat @@ -141,12 +138,23 @@ module psb_d_csc_mat_mod interface subroutine psb_d_csc_mold(a,b,info) import :: psb_ipk_, psb_d_csc_sparse_mat, psb_d_base_sparse_mat, psb_long_int_k_ - class(psb_d_csc_sparse_mat), intent(in) :: a - class(psb_d_base_sparse_mat), intent(out), allocatable :: b - integer(psb_ipk_), intent(out) :: info + class(psb_d_csc_sparse_mat), intent(in) :: a + class(psb_d_base_sparse_mat), intent(inout), allocatable :: b + integer(psb_ipk_), intent(out) :: info end subroutine psb_d_csc_mold end interface - + + !> \memberof psb_d_csc_sparse_mat + !| \see psb_base_mat_mod::psb_base_copy + interface + subroutine psb_d_csc_copy(a,b,info) + import :: psb_ipk_, psb_d_csc_sparse_mat, psb_d_base_sparse_mat, psb_long_int_k_ + class(psb_d_csc_sparse_mat), intent(in) :: a + class(psb_d_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_d_csc_copy + end interface + !> \memberof psb_d_csc_sparse_mat !| \see psb_base_mat_mod::psb_base_allocate_mnnz diff --git a/base/modules/psb_d_csr_mat_mod.f90 b/base/modules/psb_d_csr_mat_mod.f90 index 8c39ca5a..893ab9ad 100644 --- a/base/modules/psb_d_csr_mat_mod.f90 +++ b/base/modules/psb_d_csr_mat_mod.f90 @@ -98,10 +98,7 @@ module psb_d_csr_mat_mod procedure, pass(a) :: print => psb_d_csr_print procedure, pass(a) :: free => d_csr_free procedure, pass(a) :: mold => psb_d_csr_mold - procedure, pass(a) :: psb_d_csr_cp_from - generic, public :: cp_from => psb_d_csr_cp_from - procedure, pass(a) :: psb_d_csr_mv_from - generic, public :: mv_from => psb_d_csr_mv_from + procedure, pass(a) :: copy => psb_d_csr_copy end type psb_d_csr_sparse_mat @@ -143,13 +140,23 @@ module psb_d_csr_mat_mod interface subroutine psb_d_csr_mold(a,b,info) import :: psb_ipk_, psb_d_csr_sparse_mat, psb_d_base_sparse_mat, psb_long_int_k_ - class(psb_d_csr_sparse_mat), intent(in) :: a - class(psb_d_base_sparse_mat), intent(out), allocatable :: b - integer(psb_ipk_), intent(out) :: info + class(psb_d_csr_sparse_mat), intent(in) :: a + class(psb_d_base_sparse_mat), intent(inout), allocatable :: b + integer(psb_ipk_), intent(out) :: info end subroutine psb_d_csr_mold end interface - - + + !> \memberof psb_d_csr_sparse_mat + !| \see psb_base_mat_mod::psb_base_copy + interface + subroutine psb_d_csr_copy(a,b,info) + import :: psb_ipk_, psb_d_csr_sparse_mat, psb_d_base_sparse_mat, psb_long_int_k_ + class(psb_d_csr_sparse_mat), intent(in) :: a + class(psb_d_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_d_csr_copy + end interface + !> \memberof psb_d_csr_sparse_mat !| \see psb_base_mat_mod::psb_base_allocate_mnnz interface diff --git a/base/modules/psb_d_mat_mod.f90 b/base/modules/psb_d_mat_mod.f90 index 6b141744..f0b16844 100644 --- a/base/modules/psb_d_mat_mod.f90 +++ b/base/modules/psb_d_mat_mod.f90 @@ -154,6 +154,7 @@ module psb_d_mat_mod procedure, pass(a) :: cscnv_ip => psb_d_cscnv_ip procedure, pass(a) :: cscnv_base => psb_d_cscnv_base generic, public :: cscnv => cscnv_np, cscnv_ip, cscnv_base + procedure, pass(a) :: copy => psb_dspmat_copy procedure, pass(a) :: clone => psb_dspmat_clone ! Computational routines @@ -609,6 +610,15 @@ module psb_d_mat_mod end subroutine psb_dspmat_type_move end interface + interface + subroutine psb_dspmat_copy(a,b,info) + import :: psb_ipk_, psb_dspmat_type + class(psb_dspmat_type), intent(inout) :: a + class(psb_dspmat_type), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_dspmat_copy + end interface + interface subroutine psb_dspmat_clone(a,b,info) import :: psb_ipk_, psb_dspmat_type diff --git a/base/modules/psb_i_comm_mod.f90 b/base/modules/psb_i_comm_mod.f90 index f0048cee..1d405196 100644 --- a/base/modules/psb_i_comm_mod.f90 +++ b/base/modules/psb_i_comm_mod.f90 @@ -115,16 +115,16 @@ module psb_i_comm_mod interface psb_gather !!$ subroutine psb_isp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keeploc) -! !$ use psb_desc_mod -! !$ use psb_mat_mod -! !$ implicit none -! !$ type(psb_ispmat_type), intent(inout) :: loca -! !$ type(psb_ispmat_type), intent(out) :: globa -! !$ type(psb_desc_type), intent(in) :: desc_a -! !$ integer(psb_ipk_), intent(out) :: info -! !$ integer(psb_ipk_), intent(in), optional :: root,dupl -! !$ logical, intent(in), optional :: keepnum,keeploc -! !$ end subroutine psb_isp_allgather +!!$ use psb_desc_mod +!!$ use psb_mat_mod +!!$ implicit none +!!$ type(psb_ispmat_type), intent(inout) :: loca +!!$ type(psb_ispmat_type), intent(out) :: globa +!!$ type(psb_desc_type), intent(in) :: desc_a +!!$ integer(psb_ipk_), intent(out) :: info +!!$ integer(psb_ipk_), intent(in), optional :: root,dupl +!!$ logical, intent(in), optional :: keepnum,keeploc +!!$ end subroutine psb_isp_allgather subroutine psb_igatherm(globx, locx, desc_a, info, root) use psb_desc_mod integer(psb_ipk_), intent(in) :: locx(:,:) diff --git a/base/modules/psb_s_base_mat_mod.f90 b/base/modules/psb_s_base_mat_mod.f90 index c6f441d5..1eebdf84 100644 --- a/base/modules/psb_s_base_mat_mod.f90 +++ b/base/modules/psb_s_base_mat_mod.f90 @@ -71,11 +71,8 @@ module psb_s_base_mat_mod procedure, pass(a) :: mv_from_coo => psb_s_base_mv_from_coo procedure, pass(a) :: mv_to_fmt => psb_s_base_mv_to_fmt procedure, pass(a) :: mv_from_fmt => psb_s_base_mv_from_fmt - procedure, pass(a) :: s_base_cp_from - generic, public :: cp_from => s_base_cp_from - procedure, pass(a) :: s_base_mv_from - generic, public :: mv_from => s_base_mv_from procedure, pass(a) :: mold => psb_s_base_mold + procedure, pass(a) :: copy => psb_s_base_copy procedure, pass(a) :: clone => psb_s_base_clone ! @@ -113,9 +110,6 @@ module psb_s_base_mat_mod procedure, pass(a) :: aclsum => psb_s_base_aclsum end type psb_s_base_sparse_mat - private :: s_base_cp_from, s_base_mv_from - - !> \namespace psb_base_mod \class psb_s_coo_sparse_mat !! \extends psb_s_base_mat_mod::psb_s_base_sparse_mat !! @@ -164,10 +158,8 @@ module psb_s_base_mat_mod procedure, pass(a) :: print => psb_s_coo_print procedure, pass(a) :: free => s_coo_free procedure, pass(a) :: mold => psb_s_coo_mold - procedure, pass(a) :: psb_s_coo_cp_from - generic, public :: cp_from => psb_s_coo_cp_from - procedure, pass(a) :: psb_s_coo_mv_from - generic, public :: mv_from => psb_s_coo_mv_from + procedure, pass(a) :: copy => psb_s_coo_copy +!!$ procedure, pass(a) :: clone => psb_s_coo_clone ! ! This is COO specific ! @@ -412,19 +404,40 @@ module psb_s_base_mat_mod interface subroutine psb_s_base_mold(a,b,info) import :: psb_ipk_, psb_s_base_sparse_mat, psb_long_int_k_ - class(psb_s_base_sparse_mat), intent(in) :: a - class(psb_s_base_sparse_mat), intent(out), allocatable :: b - integer(psb_ipk_), intent(out) :: info + class(psb_s_base_sparse_mat), intent(in) :: a + class(psb_s_base_sparse_mat), intent(inout), allocatable :: b + integer(psb_ipk_), intent(out) :: info end subroutine psb_s_base_mold end interface + ! + !> Function copy: + !! \memberof psb_s_base_sparse_mat + !! \brief Copy a class(psb_s_base_sparse_mat) + !! but only if it is the same dynamic type as the input. + !! \param b The output variable + !! \param info return code + ! + interface + subroutine psb_s_base_copy(a,b, info) + import :: psb_ipk_, psb_s_base_sparse_mat, psb_long_int_k_ + implicit none + class(psb_s_base_sparse_mat), intent(in) :: a + class(psb_s_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_s_base_copy + end interface + + ! !> Function clone: !! \memberof psb_s_base_sparse_mat !! \brief Allocate and clone a class(psb_s_base_sparse_mat) with the - !! same dynamic type as the input. + !! same dynamic type as the input. !! This is equivalent to allocate( source= ) except that !! it should guarantee a deep copy wherever needed. + !! Should also be equivalent to calling mold and then copy, + !! but it can also be implemented by default using cp_to_fmt. !! \param b The output variable !! \param info return code ! @@ -434,7 +447,7 @@ module psb_s_base_mat_mod implicit none class(psb_s_base_sparse_mat), intent(inout) :: a class(psb_s_base_sparse_mat), allocatable, intent(inout) :: b - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info end subroutine psb_s_base_clone end interface @@ -1131,19 +1144,40 @@ module psb_s_base_mat_mod end subroutine psb_s_coo_allocate_mnnz end interface - ! - !> - !! \memberof psb_s_coo_sparse_mat - !! \see psb_s_base_mat_mod::psb_s_base_mold - ! + + !> \memberof psb_s_coo_sparse_mat + !| \see psb_base_mat_mod::psb_base_mold interface subroutine psb_s_coo_mold(a,b,info) import :: psb_ipk_, psb_s_coo_sparse_mat, psb_s_base_sparse_mat, psb_long_int_k_ - class(psb_s_coo_sparse_mat), intent(in) :: a - class(psb_s_base_sparse_mat), intent(out), allocatable :: b - integer(psb_ipk_), intent(out) :: info + class(psb_s_coo_sparse_mat), intent(in) :: a + class(psb_s_base_sparse_mat), intent(inout), allocatable :: b + integer(psb_ipk_), intent(out) :: info end subroutine psb_s_coo_mold end interface + + !> \memberof psb_s_coo_sparse_mat + !| \see psb_base_mat_mod::psb_base_copy + interface + subroutine psb_s_coo_copy(a,b,info) + import :: psb_ipk_, psb_s_coo_sparse_mat, psb_s_base_sparse_mat, psb_long_int_k_ + class(psb_s_coo_sparse_mat), intent(in) :: a + class(psb_s_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_s_coo_copy + end interface + +!!$ !> \memberof psb_s_coo_sparse_mat +!!$ !| \see psb_base_mat_mod::psb_base_copy +!!$ interface +!!$ subroutine psb_s_coo_clone(a,b,info) +!!$ import :: psb_ipk_, psb_s_coo_sparse_mat, psb_s_base_sparse_mat, psb_long_int_k_ +!!$ class(psb_s_coo_sparse_mat), intent(inout) :: a +!!$ class(psb_s_base_sparse_mat), intent(inout), allocatable :: b +!!$ integer(psb_ipk_), intent(out) :: info +!!$ end subroutine psb_s_coo_clone +!!$ end interface + ! @@ -1584,35 +1618,6 @@ module psb_s_base_mat_mod contains - - subroutine s_base_mv_from(a,b) - - implicit none - - class(psb_s_base_sparse_mat), intent(out) :: a - type(psb_s_base_sparse_mat), intent(inout) :: b - - - ! No new things here, very easy - call a%psb_base_sparse_mat%mv_from(b%psb_base_sparse_mat) - - return - - end subroutine s_base_mv_from - - subroutine s_base_cp_from(a,b) - implicit none - - class(psb_s_base_sparse_mat), intent(out) :: a - type(psb_s_base_sparse_mat), intent(in) :: b - - ! No new things here, very easy - call a%psb_base_sparse_mat%cp_from(b%psb_base_sparse_mat) - - return - - end subroutine s_base_cp_from - ! == ================================== diff --git a/base/modules/psb_s_csc_mat_mod.f90 b/base/modules/psb_s_csc_mat_mod.f90 index 41a7a5ae..57be449f 100644 --- a/base/modules/psb_s_csc_mat_mod.f90 +++ b/base/modules/psb_s_csc_mat_mod.f90 @@ -97,10 +97,7 @@ module psb_s_csc_mat_mod procedure, pass(a) :: print => psb_s_csc_print procedure, pass(a) :: free => s_csc_free procedure, pass(a) :: mold => psb_s_csc_mold - procedure, pass(a) :: psb_s_csc_cp_from - generic, public :: cp_from => psb_s_csc_cp_from - procedure, pass(a) :: psb_s_csc_mv_from - generic, public :: mv_from => psb_s_csc_mv_from + procedure, pass(a) :: copy => psb_s_csc_copy end type psb_s_csc_sparse_mat @@ -141,12 +138,23 @@ module psb_s_csc_mat_mod interface subroutine psb_s_csc_mold(a,b,info) import :: psb_ipk_, psb_s_csc_sparse_mat, psb_s_base_sparse_mat, psb_long_int_k_ - class(psb_s_csc_sparse_mat), intent(in) :: a - class(psb_s_base_sparse_mat), intent(out), allocatable :: b - integer(psb_ipk_), intent(out) :: info + class(psb_s_csc_sparse_mat), intent(in) :: a + class(psb_s_base_sparse_mat), intent(inout), allocatable :: b + integer(psb_ipk_), intent(out) :: info end subroutine psb_s_csc_mold end interface - + + !> \memberof psb_s_csc_sparse_mat + !| \see psb_base_mat_mod::psb_base_copy + interface + subroutine psb_s_csc_copy(a,b,info) + import :: psb_ipk_, psb_s_csc_sparse_mat, psb_s_base_sparse_mat, psb_long_int_k_ + class(psb_s_csc_sparse_mat), intent(in) :: a + class(psb_s_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_s_csc_copy + end interface + !> \memberof psb_s_csc_sparse_mat !| \see psb_base_mat_mod::psb_base_allocate_mnnz diff --git a/base/modules/psb_s_csr_mat_mod.f90 b/base/modules/psb_s_csr_mat_mod.f90 index d5992f22..3deb6bb9 100644 --- a/base/modules/psb_s_csr_mat_mod.f90 +++ b/base/modules/psb_s_csr_mat_mod.f90 @@ -98,10 +98,7 @@ module psb_s_csr_mat_mod procedure, pass(a) :: print => psb_s_csr_print procedure, pass(a) :: free => s_csr_free procedure, pass(a) :: mold => psb_s_csr_mold - procedure, pass(a) :: psb_s_csr_cp_from - generic, public :: cp_from => psb_s_csr_cp_from - procedure, pass(a) :: psb_s_csr_mv_from - generic, public :: mv_from => psb_s_csr_mv_from + procedure, pass(a) :: copy => psb_s_csr_copy end type psb_s_csr_sparse_mat @@ -143,13 +140,23 @@ module psb_s_csr_mat_mod interface subroutine psb_s_csr_mold(a,b,info) import :: psb_ipk_, psb_s_csr_sparse_mat, psb_s_base_sparse_mat, psb_long_int_k_ - class(psb_s_csr_sparse_mat), intent(in) :: a - class(psb_s_base_sparse_mat), intent(out), allocatable :: b - integer(psb_ipk_), intent(out) :: info + class(psb_s_csr_sparse_mat), intent(in) :: a + class(psb_s_base_sparse_mat), intent(inout), allocatable :: b + integer(psb_ipk_), intent(out) :: info end subroutine psb_s_csr_mold end interface - - + + !> \memberof psb_s_csr_sparse_mat + !| \see psb_base_mat_mod::psb_base_copy + interface + subroutine psb_s_csr_copy(a,b,info) + import :: psb_ipk_, psb_s_csr_sparse_mat, psb_s_base_sparse_mat, psb_long_int_k_ + class(psb_s_csr_sparse_mat), intent(in) :: a + class(psb_s_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_s_csr_copy + end interface + !> \memberof psb_s_csr_sparse_mat !| \see psb_base_mat_mod::psb_base_allocate_mnnz interface diff --git a/base/modules/psb_s_mat_mod.f90 b/base/modules/psb_s_mat_mod.f90 index 420ec535..10a9464c 100644 --- a/base/modules/psb_s_mat_mod.f90 +++ b/base/modules/psb_s_mat_mod.f90 @@ -154,6 +154,7 @@ module psb_s_mat_mod procedure, pass(a) :: cscnv_ip => psb_s_cscnv_ip procedure, pass(a) :: cscnv_base => psb_s_cscnv_base generic, public :: cscnv => cscnv_np, cscnv_ip, cscnv_base + procedure, pass(a) :: copy => psb_sspmat_copy procedure, pass(a) :: clone => psb_sspmat_clone ! Computational routines @@ -609,6 +610,15 @@ module psb_s_mat_mod end subroutine psb_sspmat_type_move end interface + interface + subroutine psb_sspmat_copy(a,b,info) + import :: psb_ipk_, psb_sspmat_type + class(psb_sspmat_type), intent(inout) :: a + class(psb_sspmat_type), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_sspmat_copy + end interface + interface subroutine psb_sspmat_clone(a,b,info) import :: psb_ipk_, psb_sspmat_type diff --git a/base/modules/psb_z_base_mat_mod.f90 b/base/modules/psb_z_base_mat_mod.f90 index 33803f80..144b3e27 100644 --- a/base/modules/psb_z_base_mat_mod.f90 +++ b/base/modules/psb_z_base_mat_mod.f90 @@ -71,11 +71,8 @@ module psb_z_base_mat_mod procedure, pass(a) :: mv_from_coo => psb_z_base_mv_from_coo procedure, pass(a) :: mv_to_fmt => psb_z_base_mv_to_fmt procedure, pass(a) :: mv_from_fmt => psb_z_base_mv_from_fmt - procedure, pass(a) :: z_base_cp_from - generic, public :: cp_from => z_base_cp_from - procedure, pass(a) :: z_base_mv_from - generic, public :: mv_from => z_base_mv_from procedure, pass(a) :: mold => psb_z_base_mold + procedure, pass(a) :: copy => psb_z_base_copy procedure, pass(a) :: clone => psb_z_base_clone ! @@ -113,9 +110,6 @@ module psb_z_base_mat_mod procedure, pass(a) :: aclsum => psb_z_base_aclsum end type psb_z_base_sparse_mat - private :: z_base_cp_from, z_base_mv_from - - !> \namespace psb_base_mod \class psb_z_coo_sparse_mat !! \extends psb_z_base_mat_mod::psb_z_base_sparse_mat !! @@ -164,10 +158,8 @@ module psb_z_base_mat_mod procedure, pass(a) :: print => psb_z_coo_print procedure, pass(a) :: free => z_coo_free procedure, pass(a) :: mold => psb_z_coo_mold - procedure, pass(a) :: psb_z_coo_cp_from - generic, public :: cp_from => psb_z_coo_cp_from - procedure, pass(a) :: psb_z_coo_mv_from - generic, public :: mv_from => psb_z_coo_mv_from + procedure, pass(a) :: copy => psb_z_coo_copy +!!$ procedure, pass(a) :: clone => psb_z_coo_clone ! ! This is COO specific ! @@ -412,19 +404,40 @@ module psb_z_base_mat_mod interface subroutine psb_z_base_mold(a,b,info) import :: psb_ipk_, psb_z_base_sparse_mat, psb_long_int_k_ - class(psb_z_base_sparse_mat), intent(in) :: a - class(psb_z_base_sparse_mat), intent(out), allocatable :: b - integer(psb_ipk_), intent(out) :: info + class(psb_z_base_sparse_mat), intent(in) :: a + class(psb_z_base_sparse_mat), intent(inout), allocatable :: b + integer(psb_ipk_), intent(out) :: info end subroutine psb_z_base_mold end interface + ! + !> Function copy: + !! \memberof psb_z_base_sparse_mat + !! \brief Copy a class(psb_z_base_sparse_mat) + !! but only if it is the same dynamic type as the input. + !! \param b The output variable + !! \param info return code + ! + interface + subroutine psb_z_base_copy(a,b, info) + import :: psb_ipk_, psb_z_base_sparse_mat, psb_long_int_k_ + implicit none + class(psb_z_base_sparse_mat), intent(in) :: a + class(psb_z_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_z_base_copy + end interface + + ! !> Function clone: !! \memberof psb_z_base_sparse_mat !! \brief Allocate and clone a class(psb_z_base_sparse_mat) with the - !! same dynamic type as the input. + !! same dynamic type as the input. !! This is equivalent to allocate( source= ) except that !! it should guarantee a deep copy wherever needed. + !! Should also be equivalent to calling mold and then copy, + !! but it can also be implemented by default using cp_to_fmt. !! \param b The output variable !! \param info return code ! @@ -434,7 +447,7 @@ module psb_z_base_mat_mod implicit none class(psb_z_base_sparse_mat), intent(inout) :: a class(psb_z_base_sparse_mat), allocatable, intent(inout) :: b - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info end subroutine psb_z_base_clone end interface @@ -1131,19 +1144,40 @@ module psb_z_base_mat_mod end subroutine psb_z_coo_allocate_mnnz end interface - ! - !> - !! \memberof psb_z_coo_sparse_mat - !! \see psb_z_base_mat_mod::psb_z_base_mold - ! + + !> \memberof psb_z_coo_sparse_mat + !| \see psb_base_mat_mod::psb_base_mold interface subroutine psb_z_coo_mold(a,b,info) import :: psb_ipk_, psb_z_coo_sparse_mat, psb_z_base_sparse_mat, psb_long_int_k_ - class(psb_z_coo_sparse_mat), intent(in) :: a - class(psb_z_base_sparse_mat), intent(out), allocatable :: b - integer(psb_ipk_), intent(out) :: info + class(psb_z_coo_sparse_mat), intent(in) :: a + class(psb_z_base_sparse_mat), intent(inout), allocatable :: b + integer(psb_ipk_), intent(out) :: info end subroutine psb_z_coo_mold end interface + + !> \memberof psb_z_coo_sparse_mat + !| \see psb_base_mat_mod::psb_base_copy + interface + subroutine psb_z_coo_copy(a,b,info) + import :: psb_ipk_, psb_z_coo_sparse_mat, psb_z_base_sparse_mat, psb_long_int_k_ + class(psb_z_coo_sparse_mat), intent(in) :: a + class(psb_z_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_z_coo_copy + end interface + +!!$ !> \memberof psb_z_coo_sparse_mat +!!$ !| \see psb_base_mat_mod::psb_base_copy +!!$ interface +!!$ subroutine psb_z_coo_clone(a,b,info) +!!$ import :: psb_ipk_, psb_z_coo_sparse_mat, psb_z_base_sparse_mat, psb_long_int_k_ +!!$ class(psb_z_coo_sparse_mat), intent(inout) :: a +!!$ class(psb_z_base_sparse_mat), intent(inout), allocatable :: b +!!$ integer(psb_ipk_), intent(out) :: info +!!$ end subroutine psb_z_coo_clone +!!$ end interface + ! @@ -1584,35 +1618,6 @@ module psb_z_base_mat_mod contains - - subroutine z_base_mv_from(a,b) - - implicit none - - class(psb_z_base_sparse_mat), intent(out) :: a - type(psb_z_base_sparse_mat), intent(inout) :: b - - - ! No new things here, very easy - call a%psb_base_sparse_mat%mv_from(b%psb_base_sparse_mat) - - return - - end subroutine z_base_mv_from - - subroutine z_base_cp_from(a,b) - implicit none - - class(psb_z_base_sparse_mat), intent(out) :: a - type(psb_z_base_sparse_mat), intent(in) :: b - - ! No new things here, very easy - call a%psb_base_sparse_mat%cp_from(b%psb_base_sparse_mat) - - return - - end subroutine z_base_cp_from - ! == ================================== diff --git a/base/modules/psb_z_csc_mat_mod.f90 b/base/modules/psb_z_csc_mat_mod.f90 index b18f58e1..598312ac 100644 --- a/base/modules/psb_z_csc_mat_mod.f90 +++ b/base/modules/psb_z_csc_mat_mod.f90 @@ -97,10 +97,7 @@ module psb_z_csc_mat_mod procedure, pass(a) :: print => psb_z_csc_print procedure, pass(a) :: free => z_csc_free procedure, pass(a) :: mold => psb_z_csc_mold - procedure, pass(a) :: psb_z_csc_cp_from - generic, public :: cp_from => psb_z_csc_cp_from - procedure, pass(a) :: psb_z_csc_mv_from - generic, public :: mv_from => psb_z_csc_mv_from + procedure, pass(a) :: copy => psb_z_csc_copy end type psb_z_csc_sparse_mat @@ -141,12 +138,23 @@ module psb_z_csc_mat_mod interface subroutine psb_z_csc_mold(a,b,info) import :: psb_ipk_, psb_z_csc_sparse_mat, psb_z_base_sparse_mat, psb_long_int_k_ - class(psb_z_csc_sparse_mat), intent(in) :: a - class(psb_z_base_sparse_mat), intent(out), allocatable :: b - integer(psb_ipk_), intent(out) :: info + class(psb_z_csc_sparse_mat), intent(in) :: a + class(psb_z_base_sparse_mat), intent(inout), allocatable :: b + integer(psb_ipk_), intent(out) :: info end subroutine psb_z_csc_mold end interface - + + !> \memberof psb_z_csc_sparse_mat + !| \see psb_base_mat_mod::psb_base_copy + interface + subroutine psb_z_csc_copy(a,b,info) + import :: psb_ipk_, psb_z_csc_sparse_mat, psb_z_base_sparse_mat, psb_long_int_k_ + class(psb_z_csc_sparse_mat), intent(in) :: a + class(psb_z_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_z_csc_copy + end interface + !> \memberof psb_z_csc_sparse_mat !| \see psb_base_mat_mod::psb_base_allocate_mnnz diff --git a/base/modules/psb_z_csr_mat_mod.f90 b/base/modules/psb_z_csr_mat_mod.f90 index a5e68d02..090b73dd 100644 --- a/base/modules/psb_z_csr_mat_mod.f90 +++ b/base/modules/psb_z_csr_mat_mod.f90 @@ -98,10 +98,7 @@ module psb_z_csr_mat_mod procedure, pass(a) :: print => psb_z_csr_print procedure, pass(a) :: free => z_csr_free procedure, pass(a) :: mold => psb_z_csr_mold - procedure, pass(a) :: psb_z_csr_cp_from - generic, public :: cp_from => psb_z_csr_cp_from - procedure, pass(a) :: psb_z_csr_mv_from - generic, public :: mv_from => psb_z_csr_mv_from + procedure, pass(a) :: copy => psb_z_csr_copy end type psb_z_csr_sparse_mat @@ -143,13 +140,23 @@ module psb_z_csr_mat_mod interface subroutine psb_z_csr_mold(a,b,info) import :: psb_ipk_, psb_z_csr_sparse_mat, psb_z_base_sparse_mat, psb_long_int_k_ - class(psb_z_csr_sparse_mat), intent(in) :: a - class(psb_z_base_sparse_mat), intent(out), allocatable :: b - integer(psb_ipk_), intent(out) :: info + class(psb_z_csr_sparse_mat), intent(in) :: a + class(psb_z_base_sparse_mat), intent(inout), allocatable :: b + integer(psb_ipk_), intent(out) :: info end subroutine psb_z_csr_mold end interface - - + + !> \memberof psb_z_csr_sparse_mat + !| \see psb_base_mat_mod::psb_base_copy + interface + subroutine psb_z_csr_copy(a,b,info) + import :: psb_ipk_, psb_z_csr_sparse_mat, psb_z_base_sparse_mat, psb_long_int_k_ + class(psb_z_csr_sparse_mat), intent(in) :: a + class(psb_z_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_z_csr_copy + end interface + !> \memberof psb_z_csr_sparse_mat !| \see psb_base_mat_mod::psb_base_allocate_mnnz interface diff --git a/base/modules/psb_z_mat_mod.f90 b/base/modules/psb_z_mat_mod.f90 index f53d2143..f2b36c5b 100644 --- a/base/modules/psb_z_mat_mod.f90 +++ b/base/modules/psb_z_mat_mod.f90 @@ -154,6 +154,7 @@ module psb_z_mat_mod procedure, pass(a) :: cscnv_ip => psb_z_cscnv_ip procedure, pass(a) :: cscnv_base => psb_z_cscnv_base generic, public :: cscnv => cscnv_np, cscnv_ip, cscnv_base + procedure, pass(a) :: copy => psb_zspmat_copy procedure, pass(a) :: clone => psb_zspmat_clone ! Computational routines @@ -609,6 +610,15 @@ module psb_z_mat_mod end subroutine psb_zspmat_type_move end interface + interface + subroutine psb_zspmat_copy(a,b,info) + import :: psb_ipk_, psb_zspmat_type + class(psb_zspmat_type), intent(inout) :: a + class(psb_zspmat_type), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + end subroutine psb_zspmat_copy + end interface + interface subroutine psb_zspmat_clone(a,b,info) import :: psb_ipk_, psb_zspmat_type diff --git a/base/serial/impl/psb_c_base_mat_impl.F90 b/base/serial/impl/psb_c_base_mat_impl.F90 index 3e56ed01..57ebd0b3 100644 --- a/base/serial/impl/psb_c_base_mat_impl.F90 +++ b/base/serial/impl/psb_c_base_mat_impl.F90 @@ -584,12 +584,12 @@ subroutine psb_c_base_mold(a,b,info) use psb_c_base_mat_mod, psb_protect_name => psb_c_base_mold use psb_error_mod implicit none - class(psb_c_base_sparse_mat), intent(in) :: a - class(psb_c_base_sparse_mat), intent(out), allocatable :: b + class(psb_c_base_sparse_mat), intent(in) :: a + class(psb_c_base_sparse_mat), intent(inout), allocatable :: b integer(psb_ipk_), intent(out) :: info integer(psb_ipk_) :: err_act integer(psb_ipk_) :: ierr(5) - character(len=20) :: name='reallocate_nz' + character(len=20) :: name='base_mold' logical, parameter :: debug=.false. call psb_get_erraction(err_act) @@ -606,6 +606,43 @@ subroutine psb_c_base_mold(a,b,info) end subroutine psb_c_base_mold +subroutine psb_c_base_copy(a,b,info) + use psb_c_base_mat_mod, psb_protect_name => psb_c_base_copy + use psb_error_mod + implicit none + class(psb_c_base_sparse_mat), intent(in) :: a + class(psb_c_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: err_act + integer(psb_ipk_) :: ierr(5) + character(len=20) :: name='base_copy' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = 0 + + call a%psb_base_sparse_mat%copy(b%psb_base_sparse_mat,info) + + if (info /= 0) then + info = psb_err_internal_error_ + call psb_errpush(info,name) + goto 9999 + end if + call psb_erractionrestore(err_act) + + return +9999 continue + if (err_act /= psb_act_ret_) then + call psb_error() + end if + + return + +end subroutine psb_c_base_copy + subroutine psb_c_base_transp_2mat(a,b) use psb_c_base_mat_mod, psb_protect_name => psb_c_base_transp_2mat use psb_error_mod diff --git a/base/serial/impl/psb_c_coo_impl.f90 b/base/serial/impl/psb_c_coo_impl.f90 index 6b000d1b..1ac957b3 100644 --- a/base/serial/impl/psb_c_coo_impl.f90 +++ b/base/serial/impl/psb_c_coo_impl.f90 @@ -225,19 +225,24 @@ subroutine psb_c_coo_mold(a,b,info) use psb_c_base_mat_mod, psb_protect_name => psb_c_coo_mold use psb_error_mod implicit none - class(psb_c_coo_sparse_mat), intent(in) :: a - class(psb_c_base_sparse_mat), intent(out), allocatable :: b + class(psb_c_coo_sparse_mat), intent(in) :: a + class(psb_c_base_sparse_mat), intent(inout), allocatable :: b integer(psb_ipk_), intent(out) :: info integer(psb_ipk_) :: err_act integer(psb_ipk_) :: ierr(5) - character(len=20) :: name='reallocate_nz' + character(len=20) :: name='coo_mold' logical, parameter :: debug=.false. call psb_get_erraction(err_act) - allocate(psb_c_coo_sparse_mat :: b, stat=info) + info = 0 + if (allocated(b)) then + call b%free() + deallocate(b,stat=info) + end if + if (info == 0) allocate(psb_c_coo_sparse_mat :: b, stat=info) - if (info /= psb_success_) then + if (info /= 0) then info = psb_err_alloc_dealloc_ call psb_errpush(info, name) goto 9999 @@ -251,6 +256,45 @@ subroutine psb_c_coo_mold(a,b,info) end subroutine psb_c_coo_mold +subroutine psb_c_coo_copy(a,b,info) + use psb_c_base_mat_mod, psb_protect_name => psb_c_coo_copy + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_c_coo_sparse_mat), intent(in) :: a + class(psb_c_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: err_act + integer(psb_ipk_) :: ierr(5) + character(len=20) :: name='coo_copy' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + + info = 0 + + select type(b) + type is (psb_c_coo_sparse_mat) + call a%psb_c_base_sparse_mat%copy(b%psb_c_base_sparse_mat,info) + if (info == 0) call psb_safe_cpy( a%ia, b%ia, info) + if (info == 0) call psb_safe_cpy( a%ja, b%ja, info) + if (info == 0) call psb_safe_cpy( a%val, b%val, info) + if (info == 0) call b%fix(info) + + if (info /= psb_success_) goto 9999 + class default + info = psb_err_internal_error_ + goto 9999 + end select + + return +9999 continue + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_c_coo_copy subroutine psb_c_coo_reinit(a,clear) use psb_c_base_mat_mod, psb_protect_name => psb_c_coo_reinit @@ -2920,7 +2964,7 @@ subroutine psb_c_cp_coo_to_coo(a,b,info) call psb_erractionsave(err_act) info = psb_success_ - call b%psb_c_base_sparse_mat%cp_from(a%psb_c_base_sparse_mat) + call a%psb_c_base_sparse_mat%copy(b%psb_c_base_sparse_mat,info) nz = a%get_nzeros() call b%set_nzeros(nz) @@ -2966,7 +3010,8 @@ subroutine psb_c_cp_coo_from_coo(a,b,info) call psb_erractionsave(err_act) info = psb_success_ - call a%psb_c_base_sparse_mat%cp_from(b%psb_c_base_sparse_mat) + call b%psb_c_base_sparse_mat%copy(a%psb_c_base_sparse_mat,info) + nz = b%get_nzeros() call a%set_nzeros(nz) call a%reallocate(nz) @@ -3085,7 +3130,7 @@ subroutine psb_c_mv_coo_to_coo(a,b,info) call psb_erractionsave(err_act) info = psb_success_ - call b%psb_c_base_sparse_mat%mv_from(a%psb_c_base_sparse_mat) + call a%psb_c_base_sparse_mat%copy(b%psb_c_base_sparse_mat, info) call b%set_nzeros(a%get_nzeros()) call b%reallocate(a%get_nzeros()) @@ -3130,7 +3175,7 @@ subroutine psb_c_mv_coo_from_coo(a,b,info) call psb_erractionsave(err_act) info = psb_success_ - call a%psb_c_base_sparse_mat%mv_from(b%psb_c_base_sparse_mat) + call b%psb_c_base_sparse_mat%copy(a%psb_c_base_sparse_mat, info) call a%set_nzeros(b%get_nzeros()) call a%reallocate(b%get_nzeros()) diff --git a/base/serial/impl/psb_c_csc_impl.f90 b/base/serial/impl/psb_c_csc_impl.f90 index 20acfdca..567830a0 100644 --- a/base/serial/impl/psb_c_csc_impl.f90 +++ b/base/serial/impl/psb_c_csc_impl.f90 @@ -2263,7 +2263,7 @@ subroutine psb_c_cp_csc_to_coo(a,b,info) nza = a%get_nzeros() call b%allocate(nr,nc,nza) - call b%psb_c_base_sparse_mat%cp_from(a%psb_c_base_sparse_mat) + call a%psb_c_base_sparse_mat%copy(b%psb_c_base_sparse_mat, info) do i=1, nc do j=a%icp(i),a%icp(i+1)-1 @@ -2305,7 +2305,7 @@ subroutine psb_c_mv_csc_to_coo(a,b,info) nc = a%get_ncols() nza = a%get_nzeros() - call b%psb_c_base_sparse_mat%mv_from(a%psb_c_base_sparse_mat) + call a%psb_c_base_sparse_mat%copy(b%psb_c_base_sparse_mat, info) call b%set_nzeros(a%get_nzeros()) call move_alloc(a%ia,b%ia) call move_alloc(a%val,b%val) @@ -2355,7 +2355,7 @@ subroutine psb_c_mv_csc_from_coo(a,b,info) nc = b%get_ncols() nza = b%get_nzeros() - call a%psb_c_base_sparse_mat%mv_from(b%psb_c_base_sparse_mat) + call b%psb_c_base_sparse_mat%copy(a%psb_c_base_sparse_mat, info) ! Dirty trick: call move_alloc to have the new data allocated just once. call move_alloc(b%ja,itemp) @@ -2443,7 +2443,7 @@ subroutine psb_c_mv_csc_to_fmt(a,b,info) call a%mv_to_coo(b,info) ! Need to fix trivial copies! type is (psb_c_csc_sparse_mat) - call b%psb_c_base_sparse_mat%mv_from(a%psb_c_base_sparse_mat) + call a%psb_c_base_sparse_mat%copy(b%psb_c_base_sparse_mat, info) call move_alloc(a%icp, b%icp) call move_alloc(a%ia, b%ia) call move_alloc(a%val, b%val) @@ -2484,10 +2484,10 @@ subroutine psb_c_cp_csc_to_fmt(a,b,info) call a%cp_to_coo(b,info) type is (psb_c_csc_sparse_mat) - call b%psb_c_base_sparse_mat%cp_from(a%psb_c_base_sparse_mat) - call psb_safe_cpy( a%icp, b%icp , info) - call psb_safe_cpy( a%ia , b%ia , info) - call psb_safe_cpy( a%val, b%val , info) + call a%psb_c_base_sparse_mat%copy(b%psb_c_base_sparse_mat,info) + if (info == 0) call psb_safe_cpy( a%icp, b%icp , info) + if (info == 0) call psb_safe_cpy( a%ia , b%ia , info) + if (info == 0) call psb_safe_cpy( a%val, b%val , info) class default call a%cp_to_coo(tmp,info) @@ -2523,7 +2523,7 @@ subroutine psb_c_mv_csc_from_fmt(a,b,info) call a%mv_from_coo(b,info) type is (psb_c_csc_sparse_mat) - call a%psb_c_base_sparse_mat%mv_from(b%psb_c_base_sparse_mat) + call b%psb_c_base_sparse_mat%copy(a%psb_c_base_sparse_mat, info) call move_alloc(b%icp, a%icp) call move_alloc(b%ia, a%ia) call move_alloc(b%val, a%val) @@ -2564,34 +2564,41 @@ subroutine psb_c_cp_csc_from_fmt(a,b,info) call a%cp_from_coo(b,info) type is (psb_c_csc_sparse_mat) - call a%psb_c_base_sparse_mat%cp_from(b%psb_c_base_sparse_mat) - call psb_safe_cpy( b%icp, a%icp , info) - call psb_safe_cpy( b%ia , a%ia , info) - call psb_safe_cpy( b%val, a%val , info) + call b%psb_c_base_sparse_mat%copy(a%psb_c_base_sparse_mat, info) + if (info == 0) call psb_safe_cpy( b%icp, a%icp , info) + if (info == 0) call psb_safe_cpy( b%ia , a%ia , info) + if (info == 0) call psb_safe_cpy( b%val, a%val , info) class default call b%cp_to_coo(tmp,info) if (info == psb_success_) call a%mv_from_coo(tmp,info) end select + end subroutine psb_c_cp_csc_from_fmt + subroutine psb_c_csc_mold(a,b,info) use psb_c_csc_mat_mod, psb_protect_name => psb_c_csc_mold use psb_error_mod implicit none - class(psb_c_csc_sparse_mat), intent(in) :: a - class(psb_c_base_sparse_mat), intent(out), allocatable :: b + class(psb_c_csc_sparse_mat), intent(in) :: a + class(psb_c_base_sparse_mat), intent(inout), allocatable :: b integer(psb_ipk_), intent(out) :: info integer(psb_ipk_) :: err_act integer(psb_ipk_) :: ierr(5) - character(len=20) :: name='reallocate_nz' + character(len=20) :: name='csc_mold' logical, parameter :: debug=.false. call psb_get_erraction(err_act) - allocate(psb_c_csc_sparse_mat :: b, stat=info) + info = 0 + if (allocated(b)) then + call b%free() + deallocate(b,stat=info) + end if + if (info == 0) allocate(psb_c_csc_sparse_mat :: b, stat=info) - if (info /= psb_success_) then + if (info /= 0) then info = psb_err_alloc_dealloc_ call psb_errpush(info, name) goto 9999 @@ -2605,6 +2612,44 @@ subroutine psb_c_csc_mold(a,b,info) end subroutine psb_c_csc_mold +subroutine psb_c_csc_copy(a,b,info) + use psb_c_csc_mat_mod, psb_protect_name => psb_c_csc_copy + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_c_csc_sparse_mat), intent(in) :: a + class(psb_c_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: err_act + integer(psb_ipk_) :: ierr(5) + character(len=20) :: name='csc_copy' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + + info = 0 + + select type(b) + type is (psb_c_csc_sparse_mat) + call a%psb_c_base_sparse_mat%copy(b%psb_c_base_sparse_mat, info) + if (info == 0) call psb_safe_cpy( a%icp, b%icp , info) + if (info == 0) call psb_safe_cpy( a%ia , b%ia , info) + if (info == 0) call psb_safe_cpy( a%val, b%val , info) + if (info /= psb_success_) goto 9999 + + class default + info = psb_err_internal_error_ + goto 9999 + end select + + return +9999 continue + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_c_csc_copy subroutine psb_c_csc_reallocate_nz(nz,a) use psb_error_mod @@ -2929,83 +2974,83 @@ subroutine psb_c_csc_print(iout,a,iv,head,ivr,ivc) end subroutine psb_c_csc_print -subroutine psb_c_csc_cp_from(a,b) - use psb_error_mod - use psb_realloc_mod - use psb_c_csc_mat_mod, psb_protect_name => psb_c_csc_cp_from - implicit none - - class(psb_c_csc_sparse_mat), intent(inout) :: a - type(psb_c_csc_sparse_mat), intent(in) :: b - - - integer(psb_ipk_) :: err_act, info - integer(psb_ipk_) :: ierr(5) - character(len=20) :: name='cp_from' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - - info = psb_success_ - - call a%allocate(b%get_nrows(),b%get_ncols(),b%get_nzeros()) - call a%psb_c_base_sparse_mat%cp_from(b%psb_c_base_sparse_mat) - call psb_safe_cpy( b%icp, a%icp , info) - call psb_safe_cpy( b%ia , a%ia , info) - call psb_safe_cpy( b%val, a%val , info) - - if (info /= psb_success_) goto 9999 - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - call psb_errpush(info,name) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - -end subroutine psb_c_csc_cp_from - -subroutine psb_c_csc_mv_from(a,b) - use psb_error_mod - use psb_c_csc_mat_mod, psb_protect_name => psb_c_csc_mv_from - implicit none - - class(psb_c_csc_sparse_mat), intent(inout) :: a - type(psb_c_csc_sparse_mat), intent(inout) :: b - - - integer(psb_ipk_) :: err_act, info - integer(psb_ipk_) :: ierr(5) - character(len=20) :: name='mv_from' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = psb_success_ - call a%psb_c_base_sparse_mat%mv_from(b%psb_c_base_sparse_mat) - call move_alloc(b%icp, a%icp) - call move_alloc(b%ia, a%ia) - call move_alloc(b%val, a%val) - call b%free() - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - call psb_errpush(info,name) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - -end subroutine psb_c_csc_mv_from - +!!$subroutine psb_c_csc_cp_from(a,b) +!!$ use psb_error_mod +!!$ use psb_realloc_mod +!!$ use psb_c_csc_mat_mod, psb_protect_name => psb_c_csc_cp_from +!!$ implicit none +!!$ +!!$ class(psb_c_csc_sparse_mat), intent(inout) :: a +!!$ type(psb_c_csc_sparse_mat), intent(in) :: b +!!$ +!!$ +!!$ integer(psb_ipk_) :: err_act, info +!!$ integer(psb_ipk_) :: ierr(5) +!!$ character(len=20) :: name='cp_from' +!!$ logical, parameter :: debug=.false. +!!$ +!!$ call psb_erractionsave(err_act) +!!$ +!!$ info = psb_success_ +!!$ +!!$ call a%allocate(b%get_nrows(),b%get_ncols(),b%get_nzeros()) +!!$ call b%psb_c_base_sparse_mat%copy(a%psb_c_base_sparse_mat, info) +!!$ if (info == 0) call psb_safe_cpy( b%icp, a%icp , info) +!!$ if (info == 0) call psb_safe_cpy( b%ia , a%ia , info) +!!$ if (info == 0) call psb_safe_cpy( b%val, a%val , info) +!!$ +!!$ if (info /= psb_success_) goto 9999 +!!$ call psb_erractionrestore(err_act) +!!$ return +!!$ +!!$9999 continue +!!$ call psb_erractionrestore(err_act) +!!$ +!!$ call psb_errpush(info,name) +!!$ +!!$ if (err_act /= psb_act_ret_) then +!!$ call psb_error() +!!$ end if +!!$ return +!!$ +!!$end subroutine psb_c_csc_cp_from +!!$ +!!$subroutine psb_c_csc_mv_from(a,b) +!!$ use psb_error_mod +!!$ use psb_c_csc_mat_mod, psb_protect_name => psb_c_csc_mv_from +!!$ implicit none +!!$ +!!$ class(psb_c_csc_sparse_mat), intent(inout) :: a +!!$ type(psb_c_csc_sparse_mat), intent(inout) :: b +!!$ +!!$ +!!$ integer(psb_ipk_) :: err_act, info +!!$ integer(psb_ipk_) :: ierr(5) +!!$ character(len=20) :: name='mv_from' +!!$ logical, parameter :: debug=.false. +!!$ +!!$ call psb_erractionsave(err_act) +!!$ info = psb_success_ +!!$ call b%psb_c_base_sparse_mat%copy(a%psb_c_base_sparse_mat, info) +!!$ if (info == 0) call move_alloc(b%icp, a%icp) +!!$ if (info == 0) call move_alloc(b%ia, a%ia) +!!$ if (info == 0) call move_alloc(b%val, a%val) +!!$ call b%free() +!!$ +!!$ call psb_erractionrestore(err_act) +!!$ return +!!$ +!!$9999 continue +!!$ call psb_erractionrestore(err_act) +!!$ +!!$ call psb_errpush(info,name) +!!$ +!!$ if (err_act /= psb_act_ret_) then +!!$ call psb_error() +!!$ end if +!!$ return +!!$ +!!$end subroutine psb_c_csc_mv_from +!!$ diff --git a/base/serial/impl/psb_c_csr_impl.f90 b/base/serial/impl/psb_c_csr_impl.f90 index b7f4c2b9..3c64e22f 100644 --- a/base/serial/impl/psb_c_csr_impl.f90 +++ b/base/serial/impl/psb_c_csr_impl.f90 @@ -1785,19 +1785,24 @@ subroutine psb_c_csr_mold(a,b,info) use psb_c_csr_mat_mod, psb_protect_name => psb_c_csr_mold use psb_error_mod implicit none - class(psb_c_csr_sparse_mat), intent(in) :: a - class(psb_c_base_sparse_mat), intent(out), allocatable :: b + class(psb_c_csr_sparse_mat), intent(in) :: a + class(psb_c_base_sparse_mat), intent(inout), allocatable :: b integer(psb_ipk_), intent(out) :: info integer(psb_ipk_) :: err_act integer(psb_ipk_) :: ierr(5) - character(len=20) :: name='reallocate_nz' + character(len=20) :: name='csr_mold' logical, parameter :: debug=.false. call psb_get_erraction(err_act) - allocate(psb_c_csr_sparse_mat :: b, stat=info) + info = 0 + if (allocated(b)) then + call b%free() + deallocate(b,stat=info) + end if + if (info == 0) allocate(psb_c_csr_sparse_mat :: b, stat=info) - if (info /= psb_success_) then + if (info /= 0) then info = psb_err_alloc_dealloc_ call psb_errpush(info, name) goto 9999 @@ -1811,6 +1816,45 @@ subroutine psb_c_csr_mold(a,b,info) end subroutine psb_c_csr_mold +subroutine psb_c_csr_copy(a,b,info) + use psb_c_csr_mat_mod, psb_protect_name => psb_c_csr_copy + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_c_csr_sparse_mat), intent(in) :: a + class(psb_c_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: err_act + integer(psb_ipk_) :: ierr(5) + character(len=20) :: name='csr_copy' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + + info = 0 + + select type(b) + type is (psb_c_csr_sparse_mat) + call a%psb_c_base_sparse_mat%copy(b%psb_c_base_sparse_mat, info) + if (info == 0) call psb_safe_cpy( a%irp, b%irp , info) + if (info == 0) call psb_safe_cpy( a%ja , b%ja , info) + if (info == 0) call psb_safe_cpy( a%val, b%val , info) + if (info /= psb_success_) goto 9999 + + class default + info = psb_err_internal_error_ + goto 9999 + end select + + return +9999 continue + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_c_csr_copy + subroutine psb_c_csr_allocate_mnnz(m,n,a,nz) use psb_error_mod use psb_realloc_mod @@ -2799,7 +2843,7 @@ subroutine psb_c_cp_csr_to_coo(a,b,info) nza = a%get_nzeros() call b%allocate(nr,nc,nza) - call b%psb_c_base_sparse_mat%cp_from(a%psb_c_base_sparse_mat) + call a%psb_c_base_sparse_mat%copy(b%psb_c_base_sparse_mat, info) do i=1, nr do j=a%irp(i),a%irp(i+1)-1 @@ -2840,7 +2884,7 @@ subroutine psb_c_mv_csr_to_coo(a,b,info) nc = a%get_ncols() nza = a%get_nzeros() - call b%psb_c_base_sparse_mat%mv_from(a%psb_c_base_sparse_mat) + call a%psb_c_base_sparse_mat%copy(b%psb_c_base_sparse_mat, info) call b%set_nzeros(a%get_nzeros()) call move_alloc(a%ja,b%ja) call move_alloc(a%val,b%val) @@ -2891,7 +2935,7 @@ subroutine psb_c_mv_csr_from_coo(a,b,info) nc = b%get_ncols() nza = b%get_nzeros() - call a%psb_c_base_sparse_mat%mv_from(b%psb_c_base_sparse_mat) + call b%psb_c_base_sparse_mat%copy(a%psb_c_base_sparse_mat, info) ! Dirty trick: call move_alloc to have the new data allocated just once. call move_alloc(b%ia,itemp) @@ -2978,7 +3022,7 @@ subroutine psb_c_mv_csr_to_fmt(a,b,info) call a%mv_to_coo(b,info) ! Need to fix trivial copies! type is (psb_c_csr_sparse_mat) - call b%psb_c_base_sparse_mat%mv_from(a%psb_c_base_sparse_mat) + call a%psb_c_base_sparse_mat%copy(b%psb_c_base_sparse_mat, info) call move_alloc(a%irp, b%irp) call move_alloc(a%ja, b%ja) call move_alloc(a%val, b%val) @@ -3019,10 +3063,10 @@ subroutine psb_c_cp_csr_to_fmt(a,b,info) call a%cp_to_coo(b,info) type is (psb_c_csr_sparse_mat) - call b%psb_c_base_sparse_mat%cp_from(a%psb_c_base_sparse_mat) - call psb_safe_cpy( a%irp, b%irp , info) - call psb_safe_cpy( a%ja , b%ja , info) - call psb_safe_cpy( a%val, b%val , info) + call a%psb_c_base_sparse_mat%copy(b%psb_c_base_sparse_mat, info) + if (info == 0) call psb_safe_cpy( a%irp, b%irp , info) + if (info == 0) call psb_safe_cpy( a%ja , b%ja , info) + if (info == 0) call psb_safe_cpy( a%val, b%val , info) class default call a%cp_to_coo(tmp,info) @@ -3057,7 +3101,7 @@ subroutine psb_c_mv_csr_from_fmt(a,b,info) call a%mv_from_coo(b,info) type is (psb_c_csr_sparse_mat) - call a%psb_c_base_sparse_mat%mv_from(b%psb_c_base_sparse_mat) + call b%psb_c_base_sparse_mat%copy(a%psb_c_base_sparse_mat, info) call move_alloc(b%irp, a%irp) call move_alloc(b%ja, a%ja) call move_alloc(b%val, a%val) @@ -3098,10 +3142,10 @@ subroutine psb_c_cp_csr_from_fmt(a,b,info) call a%cp_from_coo(b,info) type is (psb_c_csr_sparse_mat) - call a%psb_c_base_sparse_mat%cp_from(b%psb_c_base_sparse_mat) - call psb_safe_cpy( b%irp, a%irp , info) - call psb_safe_cpy( b%ja , a%ja , info) - call psb_safe_cpy( b%val, a%val , info) + call b%psb_c_base_sparse_mat%copy(a%psb_c_base_sparse_mat, info) + if (info == 0) call psb_safe_cpy( b%irp, a%irp , info) + if (info == 0) call psb_safe_cpy( b%ja , a%ja , info) + if (info == 0) call psb_safe_cpy( b%val, a%val , info) class default call b%cp_to_coo(tmp,info) @@ -3109,83 +3153,83 @@ subroutine psb_c_cp_csr_from_fmt(a,b,info) end select end subroutine psb_c_cp_csr_from_fmt - -subroutine psb_c_csr_cp_from(a,b) - use psb_error_mod - use psb_realloc_mod - use psb_c_csr_mat_mod, psb_protect_name => psb_c_csr_cp_from - implicit none - - class(psb_c_csr_sparse_mat), intent(inout) :: a - type(psb_c_csr_sparse_mat), intent(in) :: b - - - integer(psb_ipk_) :: err_act, info - integer(psb_ipk_) :: ierr(5) - character(len=20) :: name='cp_from' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - - info = psb_success_ - - call a%allocate(b%get_nrows(),b%get_ncols(),b%get_nzeros()) - call a%psb_c_base_sparse_mat%cp_from(b%psb_c_base_sparse_mat) - call psb_safe_cpy( b%irp, a%irp , info) - call psb_safe_cpy( b%ja , a%ja , info) - call psb_safe_cpy( b%val, a%val , info) - - if (info /= psb_success_) goto 9999 - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - call psb_errpush(info,name) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - -end subroutine psb_c_csr_cp_from - -subroutine psb_c_csr_mv_from(a,b) - use psb_error_mod - use psb_c_csr_mat_mod, psb_protect_name => psb_c_csr_mv_from - implicit none - - class(psb_c_csr_sparse_mat), intent(inout) :: a - type(psb_c_csr_sparse_mat), intent(inout) :: b - - - integer(psb_ipk_) :: err_act, info - integer(psb_ipk_) :: ierr(5) - character(len=20) :: name='mv_from' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = psb_success_ - call a%psb_c_base_sparse_mat%mv_from(b%psb_c_base_sparse_mat) - call move_alloc(b%irp, a%irp) - call move_alloc(b%ja, a%ja) - call move_alloc(b%val, a%val) - call b%free() - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - call psb_errpush(info,name) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - -end subroutine psb_c_csr_mv_from - - +!!$ +!!$subroutine psb_c_csr_cp_from(a,b) +!!$ use psb_error_mod +!!$ use psb_realloc_mod +!!$ use psb_c_csr_mat_mod, psb_protect_name => psb_c_csr_cp_from +!!$ implicit none +!!$ +!!$ class(psb_c_csr_sparse_mat), intent(inout) :: a +!!$ type(psb_c_csr_sparse_mat), intent(in) :: b +!!$ +!!$ +!!$ integer(psb_ipk_) :: err_act, info +!!$ integer(psb_ipk_) :: ierr(5) +!!$ character(len=20) :: name='cp_from' +!!$ logical, parameter :: debug=.false. +!!$ +!!$ call psb_erractionsave(err_act) +!!$ +!!$ info = psb_success_ +!!$ +!!$ call a%allocate(b%get_nrows(),b%get_ncols(),b%get_nzeros()) +!!$ call b%psb_c_base_sparse_mat%copy(a%psb_c_base_sparse_mat, info) +!!$ if (info == 0) call psb_safe_cpy( b%irp, a%irp , info) +!!$ if (info == 0) call psb_safe_cpy( b%ja , a%ja , info) +!!$ if (info == 0) call psb_safe_cpy( b%val, a%val , info) +!!$ +!!$ if (info /= psb_success_) goto 9999 +!!$ call psb_erractionrestore(err_act) +!!$ return +!!$ +!!$9999 continue +!!$ call psb_erractionrestore(err_act) +!!$ +!!$ call psb_errpush(info,name) +!!$ +!!$ if (err_act /= psb_act_ret_) then +!!$ call psb_error() +!!$ end if +!!$ return +!!$ +!!$end subroutine psb_c_csr_cp_from +!!$ +!!$subroutine psb_c_csr_mv_from(a,b) +!!$ use psb_error_mod +!!$ use psb_c_csr_mat_mod, psb_protect_name => psb_c_csr_mv_from +!!$ implicit none +!!$ +!!$ class(psb_c_csr_sparse_mat), intent(inout) :: a +!!$ type(psb_c_csr_sparse_mat), intent(inout) :: b +!!$ +!!$ +!!$ integer(psb_ipk_) :: err_act, info +!!$ integer(psb_ipk_) :: ierr(5) +!!$ character(len=20) :: name='mv_from' +!!$ logical, parameter :: debug=.false. +!!$ +!!$ call psb_erractionsave(err_act) +!!$ info = psb_success_ +!!$ call a%psb_c_base_sparse_mat%mv_from(b%psb_c_base_sparse_mat) +!!$ call move_alloc(b%irp, a%irp) +!!$ call move_alloc(b%ja, a%ja) +!!$ call move_alloc(b%val, a%val) +!!$ call b%free() +!!$ +!!$ call psb_erractionrestore(err_act) +!!$ return +!!$ +!!$9999 continue +!!$ call psb_erractionrestore(err_act) +!!$ +!!$ call psb_errpush(info,name) +!!$ +!!$ if (err_act /= psb_act_ret_) then +!!$ call psb_error() +!!$ end if +!!$ return +!!$ +!!$end subroutine psb_c_csr_mv_from +!!$ +!!$ diff --git a/base/serial/impl/psb_c_mat_impl.F90 b/base/serial/impl/psb_c_mat_impl.F90 index 817171f8..63ef37c0 100644 --- a/base/serial/impl/psb_c_mat_impl.F90 +++ b/base/serial/impl/psb_c_mat_impl.F90 @@ -1574,6 +1574,41 @@ subroutine psb_cspmat_clone(a,b,info) end subroutine psb_cspmat_clone +subroutine psb_cspmat_copy(a,b,info) + use psb_error_mod + use psb_string_mod + use psb_c_mat_mod, psb_protect_name => psb_cspmat_copy + implicit none + class(psb_cspmat_type), intent(inout) :: a + class(psb_cspmat_type), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='copy' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + call b%free() + if (allocated(a%a)) then + call a%a%clone(b%a,info) + end if + if (info /= psb_success_) 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 + +end subroutine psb_cspmat_copy + + subroutine psb_c_transp_1mat(a) use psb_error_mod diff --git a/base/serial/impl/psb_d_base_mat_impl.F90 b/base/serial/impl/psb_d_base_mat_impl.F90 index cccf18af..dfebb308 100644 --- a/base/serial/impl/psb_d_base_mat_impl.F90 +++ b/base/serial/impl/psb_d_base_mat_impl.F90 @@ -584,12 +584,12 @@ subroutine psb_d_base_mold(a,b,info) use psb_d_base_mat_mod, psb_protect_name => psb_d_base_mold use psb_error_mod implicit none - class(psb_d_base_sparse_mat), intent(in) :: a - class(psb_d_base_sparse_mat), intent(out), allocatable :: b + class(psb_d_base_sparse_mat), intent(in) :: a + class(psb_d_base_sparse_mat), intent(inout), allocatable :: b integer(psb_ipk_), intent(out) :: info integer(psb_ipk_) :: err_act integer(psb_ipk_) :: ierr(5) - character(len=20) :: name='reallocate_nz' + character(len=20) :: name='base_mold' logical, parameter :: debug=.false. call psb_get_erraction(err_act) @@ -606,6 +606,43 @@ subroutine psb_d_base_mold(a,b,info) end subroutine psb_d_base_mold +subroutine psb_d_base_copy(a,b,info) + use psb_d_base_mat_mod, psb_protect_name => psb_d_base_copy + use psb_error_mod + implicit none + class(psb_d_base_sparse_mat), intent(in) :: a + class(psb_d_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: err_act + integer(psb_ipk_) :: ierr(5) + character(len=20) :: name='base_copy' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = 0 + + call a%psb_base_sparse_mat%copy(b%psb_base_sparse_mat,info) + + if (info /= 0) then + info = psb_err_internal_error_ + call psb_errpush(info,name) + goto 9999 + end if + call psb_erractionrestore(err_act) + + return +9999 continue + if (err_act /= psb_act_ret_) then + call psb_error() + end if + + return + +end subroutine psb_d_base_copy + subroutine psb_d_base_transp_2mat(a,b) use psb_d_base_mat_mod, psb_protect_name => psb_d_base_transp_2mat use psb_error_mod diff --git a/base/serial/impl/psb_d_coo_impl.f90 b/base/serial/impl/psb_d_coo_impl.f90 index 35f84b51..25b61d63 100644 --- a/base/serial/impl/psb_d_coo_impl.f90 +++ b/base/serial/impl/psb_d_coo_impl.f90 @@ -225,19 +225,24 @@ subroutine psb_d_coo_mold(a,b,info) use psb_d_base_mat_mod, psb_protect_name => psb_d_coo_mold use psb_error_mod implicit none - class(psb_d_coo_sparse_mat), intent(in) :: a - class(psb_d_base_sparse_mat), intent(out), allocatable :: b + class(psb_d_coo_sparse_mat), intent(in) :: a + class(psb_d_base_sparse_mat), intent(inout), allocatable :: b integer(psb_ipk_), intent(out) :: info integer(psb_ipk_) :: err_act integer(psb_ipk_) :: ierr(5) - character(len=20) :: name='reallocate_nz' + character(len=20) :: name='coo_mold' logical, parameter :: debug=.false. call psb_get_erraction(err_act) - allocate(psb_d_coo_sparse_mat :: b, stat=info) + info = 0 + if (allocated(b)) then + call b%free() + deallocate(b,stat=info) + end if + if (info == 0) allocate(psb_d_coo_sparse_mat :: b, stat=info) - if (info /= psb_success_) then + if (info /= 0) then info = psb_err_alloc_dealloc_ call psb_errpush(info, name) goto 9999 @@ -251,6 +256,45 @@ subroutine psb_d_coo_mold(a,b,info) end subroutine psb_d_coo_mold +subroutine psb_d_coo_copy(a,b,info) + use psb_d_base_mat_mod, psb_protect_name => psb_d_coo_copy + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_d_coo_sparse_mat), intent(in) :: a + class(psb_d_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: err_act + integer(psb_ipk_) :: ierr(5) + character(len=20) :: name='coo_copy' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + + info = 0 + + select type(b) + type is (psb_d_coo_sparse_mat) + call a%psb_d_base_sparse_mat%copy(b%psb_d_base_sparse_mat,info) + if (info == 0) call psb_safe_cpy( a%ia, b%ia, info) + if (info == 0) call psb_safe_cpy( a%ja, b%ja, info) + if (info == 0) call psb_safe_cpy( a%val, b%val, info) + if (info == 0) call b%fix(info) + + if (info /= psb_success_) goto 9999 + class default + info = psb_err_internal_error_ + goto 9999 + end select + + return +9999 continue + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_d_coo_copy subroutine psb_d_coo_reinit(a,clear) use psb_d_base_mat_mod, psb_protect_name => psb_d_coo_reinit @@ -2920,7 +2964,7 @@ subroutine psb_d_cp_coo_to_coo(a,b,info) call psb_erractionsave(err_act) info = psb_success_ - call b%psb_d_base_sparse_mat%cp_from(a%psb_d_base_sparse_mat) + call a%psb_d_base_sparse_mat%copy(b%psb_d_base_sparse_mat,info) nz = a%get_nzeros() call b%set_nzeros(nz) @@ -2966,7 +3010,8 @@ subroutine psb_d_cp_coo_from_coo(a,b,info) call psb_erractionsave(err_act) info = psb_success_ - call a%psb_d_base_sparse_mat%cp_from(b%psb_d_base_sparse_mat) + call b%psb_d_base_sparse_mat%copy(a%psb_d_base_sparse_mat,info) + nz = b%get_nzeros() call a%set_nzeros(nz) call a%reallocate(nz) @@ -3085,7 +3130,7 @@ subroutine psb_d_mv_coo_to_coo(a,b,info) call psb_erractionsave(err_act) info = psb_success_ - call b%psb_d_base_sparse_mat%mv_from(a%psb_d_base_sparse_mat) + call a%psb_d_base_sparse_mat%copy(b%psb_d_base_sparse_mat, info) call b%set_nzeros(a%get_nzeros()) call b%reallocate(a%get_nzeros()) @@ -3130,7 +3175,7 @@ subroutine psb_d_mv_coo_from_coo(a,b,info) call psb_erractionsave(err_act) info = psb_success_ - call a%psb_d_base_sparse_mat%mv_from(b%psb_d_base_sparse_mat) + call b%psb_d_base_sparse_mat%copy(a%psb_d_base_sparse_mat, info) call a%set_nzeros(b%get_nzeros()) call a%reallocate(b%get_nzeros()) diff --git a/base/serial/impl/psb_d_csc_impl.f90 b/base/serial/impl/psb_d_csc_impl.f90 index c1660e7f..a4ec6d16 100644 --- a/base/serial/impl/psb_d_csc_impl.f90 +++ b/base/serial/impl/psb_d_csc_impl.f90 @@ -2263,7 +2263,7 @@ subroutine psb_d_cp_csc_to_coo(a,b,info) nza = a%get_nzeros() call b%allocate(nr,nc,nza) - call b%psb_d_base_sparse_mat%cp_from(a%psb_d_base_sparse_mat) + call a%psb_d_base_sparse_mat%copy(b%psb_d_base_sparse_mat, info) do i=1, nc do j=a%icp(i),a%icp(i+1)-1 @@ -2305,7 +2305,7 @@ subroutine psb_d_mv_csc_to_coo(a,b,info) nc = a%get_ncols() nza = a%get_nzeros() - call b%psb_d_base_sparse_mat%mv_from(a%psb_d_base_sparse_mat) + call a%psb_d_base_sparse_mat%copy(b%psb_d_base_sparse_mat, info) call b%set_nzeros(a%get_nzeros()) call move_alloc(a%ia,b%ia) call move_alloc(a%val,b%val) @@ -2355,7 +2355,7 @@ subroutine psb_d_mv_csc_from_coo(a,b,info) nc = b%get_ncols() nza = b%get_nzeros() - call a%psb_d_base_sparse_mat%mv_from(b%psb_d_base_sparse_mat) + call b%psb_d_base_sparse_mat%copy(a%psb_d_base_sparse_mat, info) ! Dirty trick: call move_alloc to have the new data allocated just once. call move_alloc(b%ja,itemp) @@ -2443,7 +2443,7 @@ subroutine psb_d_mv_csc_to_fmt(a,b,info) call a%mv_to_coo(b,info) ! Need to fix trivial copies! type is (psb_d_csc_sparse_mat) - call b%psb_d_base_sparse_mat%mv_from(a%psb_d_base_sparse_mat) + call a%psb_d_base_sparse_mat%copy(b%psb_d_base_sparse_mat, info) call move_alloc(a%icp, b%icp) call move_alloc(a%ia, b%ia) call move_alloc(a%val, b%val) @@ -2484,10 +2484,10 @@ subroutine psb_d_cp_csc_to_fmt(a,b,info) call a%cp_to_coo(b,info) type is (psb_d_csc_sparse_mat) - call b%psb_d_base_sparse_mat%cp_from(a%psb_d_base_sparse_mat) - call psb_safe_cpy( a%icp, b%icp , info) - call psb_safe_cpy( a%ia , b%ia , info) - call psb_safe_cpy( a%val, b%val , info) + call a%psb_d_base_sparse_mat%copy(b%psb_d_base_sparse_mat,info) + if (info == 0) call psb_safe_cpy( a%icp, b%icp , info) + if (info == 0) call psb_safe_cpy( a%ia , b%ia , info) + if (info == 0) call psb_safe_cpy( a%val, b%val , info) class default call a%cp_to_coo(tmp,info) @@ -2523,7 +2523,7 @@ subroutine psb_d_mv_csc_from_fmt(a,b,info) call a%mv_from_coo(b,info) type is (psb_d_csc_sparse_mat) - call a%psb_d_base_sparse_mat%mv_from(b%psb_d_base_sparse_mat) + call b%psb_d_base_sparse_mat%copy(a%psb_d_base_sparse_mat, info) call move_alloc(b%icp, a%icp) call move_alloc(b%ia, a%ia) call move_alloc(b%val, a%val) @@ -2564,34 +2564,41 @@ subroutine psb_d_cp_csc_from_fmt(a,b,info) call a%cp_from_coo(b,info) type is (psb_d_csc_sparse_mat) - call a%psb_d_base_sparse_mat%cp_from(b%psb_d_base_sparse_mat) - call psb_safe_cpy( b%icp, a%icp , info) - call psb_safe_cpy( b%ia , a%ia , info) - call psb_safe_cpy( b%val, a%val , info) + call b%psb_d_base_sparse_mat%copy(a%psb_d_base_sparse_mat, info) + if (info == 0) call psb_safe_cpy( b%icp, a%icp , info) + if (info == 0) call psb_safe_cpy( b%ia , a%ia , info) + if (info == 0) call psb_safe_cpy( b%val, a%val , info) class default call b%cp_to_coo(tmp,info) if (info == psb_success_) call a%mv_from_coo(tmp,info) end select + end subroutine psb_d_cp_csc_from_fmt + subroutine psb_d_csc_mold(a,b,info) use psb_d_csc_mat_mod, psb_protect_name => psb_d_csc_mold use psb_error_mod implicit none - class(psb_d_csc_sparse_mat), intent(in) :: a - class(psb_d_base_sparse_mat), intent(out), allocatable :: b + class(psb_d_csc_sparse_mat), intent(in) :: a + class(psb_d_base_sparse_mat), intent(inout), allocatable :: b integer(psb_ipk_), intent(out) :: info integer(psb_ipk_) :: err_act integer(psb_ipk_) :: ierr(5) - character(len=20) :: name='reallocate_nz' + character(len=20) :: name='csc_mold' logical, parameter :: debug=.false. call psb_get_erraction(err_act) - allocate(psb_d_csc_sparse_mat :: b, stat=info) + info = 0 + if (allocated(b)) then + call b%free() + deallocate(b,stat=info) + end if + if (info == 0) allocate(psb_d_csc_sparse_mat :: b, stat=info) - if (info /= psb_success_) then + if (info /= 0) then info = psb_err_alloc_dealloc_ call psb_errpush(info, name) goto 9999 @@ -2605,6 +2612,44 @@ subroutine psb_d_csc_mold(a,b,info) end subroutine psb_d_csc_mold +subroutine psb_d_csc_copy(a,b,info) + use psb_d_csc_mat_mod, psb_protect_name => psb_d_csc_copy + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_d_csc_sparse_mat), intent(in) :: a + class(psb_d_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: err_act + integer(psb_ipk_) :: ierr(5) + character(len=20) :: name='csc_copy' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + + info = 0 + + select type(b) + type is (psb_d_csc_sparse_mat) + call a%psb_d_base_sparse_mat%copy(b%psb_d_base_sparse_mat, info) + if (info == 0) call psb_safe_cpy( a%icp, b%icp , info) + if (info == 0) call psb_safe_cpy( a%ia , b%ia , info) + if (info == 0) call psb_safe_cpy( a%val, b%val , info) + if (info /= psb_success_) goto 9999 + + class default + info = psb_err_internal_error_ + goto 9999 + end select + + return +9999 continue + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_d_csc_copy subroutine psb_d_csc_reallocate_nz(nz,a) use psb_error_mod @@ -2929,83 +2974,83 @@ subroutine psb_d_csc_print(iout,a,iv,head,ivr,ivc) end subroutine psb_d_csc_print -subroutine psb_d_csc_cp_from(a,b) - use psb_error_mod - use psb_realloc_mod - use psb_d_csc_mat_mod, psb_protect_name => psb_d_csc_cp_from - implicit none - - class(psb_d_csc_sparse_mat), intent(inout) :: a - type(psb_d_csc_sparse_mat), intent(in) :: b - - - integer(psb_ipk_) :: err_act, info - integer(psb_ipk_) :: ierr(5) - character(len=20) :: name='cp_from' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - - info = psb_success_ - - call a%allocate(b%get_nrows(),b%get_ncols(),b%get_nzeros()) - call a%psb_d_base_sparse_mat%cp_from(b%psb_d_base_sparse_mat) - call psb_safe_cpy( b%icp, a%icp , info) - call psb_safe_cpy( b%ia , a%ia , info) - call psb_safe_cpy( b%val, a%val , info) - - if (info /= psb_success_) goto 9999 - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - call psb_errpush(info,name) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - -end subroutine psb_d_csc_cp_from - -subroutine psb_d_csc_mv_from(a,b) - use psb_error_mod - use psb_d_csc_mat_mod, psb_protect_name => psb_d_csc_mv_from - implicit none - - class(psb_d_csc_sparse_mat), intent(inout) :: a - type(psb_d_csc_sparse_mat), intent(inout) :: b - - - integer(psb_ipk_) :: err_act, info - integer(psb_ipk_) :: ierr(5) - character(len=20) :: name='mv_from' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = psb_success_ - call a%psb_d_base_sparse_mat%mv_from(b%psb_d_base_sparse_mat) - call move_alloc(b%icp, a%icp) - call move_alloc(b%ia, a%ia) - call move_alloc(b%val, a%val) - call b%free() - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - call psb_errpush(info,name) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - -end subroutine psb_d_csc_mv_from - +!!$subroutine psb_d_csc_cp_from(a,b) +!!$ use psb_error_mod +!!$ use psb_realloc_mod +!!$ use psb_d_csc_mat_mod, psb_protect_name => psb_d_csc_cp_from +!!$ implicit none +!!$ +!!$ class(psb_d_csc_sparse_mat), intent(inout) :: a +!!$ type(psb_d_csc_sparse_mat), intent(in) :: b +!!$ +!!$ +!!$ integer(psb_ipk_) :: err_act, info +!!$ integer(psb_ipk_) :: ierr(5) +!!$ character(len=20) :: name='cp_from' +!!$ logical, parameter :: debug=.false. +!!$ +!!$ call psb_erractionsave(err_act) +!!$ +!!$ info = psb_success_ +!!$ +!!$ call a%allocate(b%get_nrows(),b%get_ncols(),b%get_nzeros()) +!!$ call b%psb_d_base_sparse_mat%copy(a%psb_d_base_sparse_mat, info) +!!$ if (info == 0) call psb_safe_cpy( b%icp, a%icp , info) +!!$ if (info == 0) call psb_safe_cpy( b%ia , a%ia , info) +!!$ if (info == 0) call psb_safe_cpy( b%val, a%val , info) +!!$ +!!$ if (info /= psb_success_) goto 9999 +!!$ call psb_erractionrestore(err_act) +!!$ return +!!$ +!!$9999 continue +!!$ call psb_erractionrestore(err_act) +!!$ +!!$ call psb_errpush(info,name) +!!$ +!!$ if (err_act /= psb_act_ret_) then +!!$ call psb_error() +!!$ end if +!!$ return +!!$ +!!$end subroutine psb_d_csc_cp_from +!!$ +!!$subroutine psb_d_csc_mv_from(a,b) +!!$ use psb_error_mod +!!$ use psb_d_csc_mat_mod, psb_protect_name => psb_d_csc_mv_from +!!$ implicit none +!!$ +!!$ class(psb_d_csc_sparse_mat), intent(inout) :: a +!!$ type(psb_d_csc_sparse_mat), intent(inout) :: b +!!$ +!!$ +!!$ integer(psb_ipk_) :: err_act, info +!!$ integer(psb_ipk_) :: ierr(5) +!!$ character(len=20) :: name='mv_from' +!!$ logical, parameter :: debug=.false. +!!$ +!!$ call psb_erractionsave(err_act) +!!$ info = psb_success_ +!!$ call b%psb_d_base_sparse_mat%copy(a%psb_d_base_sparse_mat, info) +!!$ if (info == 0) call move_alloc(b%icp, a%icp) +!!$ if (info == 0) call move_alloc(b%ia, a%ia) +!!$ if (info == 0) call move_alloc(b%val, a%val) +!!$ call b%free() +!!$ +!!$ call psb_erractionrestore(err_act) +!!$ return +!!$ +!!$9999 continue +!!$ call psb_erractionrestore(err_act) +!!$ +!!$ call psb_errpush(info,name) +!!$ +!!$ if (err_act /= psb_act_ret_) then +!!$ call psb_error() +!!$ end if +!!$ return +!!$ +!!$end subroutine psb_d_csc_mv_from +!!$ diff --git a/base/serial/impl/psb_d_csr_impl.f90 b/base/serial/impl/psb_d_csr_impl.f90 index e91523aa..5d177e7e 100644 --- a/base/serial/impl/psb_d_csr_impl.f90 +++ b/base/serial/impl/psb_d_csr_impl.f90 @@ -1785,19 +1785,24 @@ subroutine psb_d_csr_mold(a,b,info) use psb_d_csr_mat_mod, psb_protect_name => psb_d_csr_mold use psb_error_mod implicit none - class(psb_d_csr_sparse_mat), intent(in) :: a - class(psb_d_base_sparse_mat), intent(out), allocatable :: b + class(psb_d_csr_sparse_mat), intent(in) :: a + class(psb_d_base_sparse_mat), intent(inout), allocatable :: b integer(psb_ipk_), intent(out) :: info integer(psb_ipk_) :: err_act integer(psb_ipk_) :: ierr(5) - character(len=20) :: name='reallocate_nz' + character(len=20) :: name='csr_mold' logical, parameter :: debug=.false. call psb_get_erraction(err_act) - allocate(psb_d_csr_sparse_mat :: b, stat=info) + info = 0 + if (allocated(b)) then + call b%free() + deallocate(b,stat=info) + end if + if (info == 0) allocate(psb_d_csr_sparse_mat :: b, stat=info) - if (info /= psb_success_) then + if (info /= 0) then info = psb_err_alloc_dealloc_ call psb_errpush(info, name) goto 9999 @@ -1811,6 +1816,45 @@ subroutine psb_d_csr_mold(a,b,info) end subroutine psb_d_csr_mold +subroutine psb_d_csr_copy(a,b,info) + use psb_d_csr_mat_mod, psb_protect_name => psb_d_csr_copy + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_d_csr_sparse_mat), intent(in) :: a + class(psb_d_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: err_act + integer(psb_ipk_) :: ierr(5) + character(len=20) :: name='csr_copy' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + + info = 0 + + select type(b) + type is (psb_d_csr_sparse_mat) + call a%psb_d_base_sparse_mat%copy(b%psb_d_base_sparse_mat, info) + if (info == 0) call psb_safe_cpy( a%irp, b%irp , info) + if (info == 0) call psb_safe_cpy( a%ja , b%ja , info) + if (info == 0) call psb_safe_cpy( a%val, b%val , info) + if (info /= psb_success_) goto 9999 + + class default + info = psb_err_internal_error_ + goto 9999 + end select + + return +9999 continue + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_d_csr_copy + subroutine psb_d_csr_allocate_mnnz(m,n,a,nz) use psb_error_mod use psb_realloc_mod @@ -2799,7 +2843,7 @@ subroutine psb_d_cp_csr_to_coo(a,b,info) nza = a%get_nzeros() call b%allocate(nr,nc,nza) - call b%psb_d_base_sparse_mat%cp_from(a%psb_d_base_sparse_mat) + call a%psb_d_base_sparse_mat%copy(b%psb_d_base_sparse_mat, info) do i=1, nr do j=a%irp(i),a%irp(i+1)-1 @@ -2840,7 +2884,7 @@ subroutine psb_d_mv_csr_to_coo(a,b,info) nc = a%get_ncols() nza = a%get_nzeros() - call b%psb_d_base_sparse_mat%mv_from(a%psb_d_base_sparse_mat) + call a%psb_d_base_sparse_mat%copy(b%psb_d_base_sparse_mat, info) call b%set_nzeros(a%get_nzeros()) call move_alloc(a%ja,b%ja) call move_alloc(a%val,b%val) @@ -2891,7 +2935,7 @@ subroutine psb_d_mv_csr_from_coo(a,b,info) nc = b%get_ncols() nza = b%get_nzeros() - call a%psb_d_base_sparse_mat%mv_from(b%psb_d_base_sparse_mat) + call b%psb_d_base_sparse_mat%copy(a%psb_d_base_sparse_mat, info) ! Dirty trick: call move_alloc to have the new data allocated just once. call move_alloc(b%ia,itemp) @@ -2978,7 +3022,7 @@ subroutine psb_d_mv_csr_to_fmt(a,b,info) call a%mv_to_coo(b,info) ! Need to fix trivial copies! type is (psb_d_csr_sparse_mat) - call b%psb_d_base_sparse_mat%mv_from(a%psb_d_base_sparse_mat) + call a%psb_d_base_sparse_mat%copy(b%psb_d_base_sparse_mat, info) call move_alloc(a%irp, b%irp) call move_alloc(a%ja, b%ja) call move_alloc(a%val, b%val) @@ -3019,10 +3063,10 @@ subroutine psb_d_cp_csr_to_fmt(a,b,info) call a%cp_to_coo(b,info) type is (psb_d_csr_sparse_mat) - call b%psb_d_base_sparse_mat%cp_from(a%psb_d_base_sparse_mat) - call psb_safe_cpy( a%irp, b%irp , info) - call psb_safe_cpy( a%ja , b%ja , info) - call psb_safe_cpy( a%val, b%val , info) + call a%psb_d_base_sparse_mat%copy(b%psb_d_base_sparse_mat, info) + if (info == 0) call psb_safe_cpy( a%irp, b%irp , info) + if (info == 0) call psb_safe_cpy( a%ja , b%ja , info) + if (info == 0) call psb_safe_cpy( a%val, b%val , info) class default call a%cp_to_coo(tmp,info) @@ -3057,7 +3101,7 @@ subroutine psb_d_mv_csr_from_fmt(a,b,info) call a%mv_from_coo(b,info) type is (psb_d_csr_sparse_mat) - call a%psb_d_base_sparse_mat%mv_from(b%psb_d_base_sparse_mat) + call b%psb_d_base_sparse_mat%copy(a%psb_d_base_sparse_mat, info) call move_alloc(b%irp, a%irp) call move_alloc(b%ja, a%ja) call move_alloc(b%val, a%val) @@ -3098,10 +3142,10 @@ subroutine psb_d_cp_csr_from_fmt(a,b,info) call a%cp_from_coo(b,info) type is (psb_d_csr_sparse_mat) - call a%psb_d_base_sparse_mat%cp_from(b%psb_d_base_sparse_mat) - call psb_safe_cpy( b%irp, a%irp , info) - call psb_safe_cpy( b%ja , a%ja , info) - call psb_safe_cpy( b%val, a%val , info) + call b%psb_d_base_sparse_mat%copy(a%psb_d_base_sparse_mat, info) + if (info == 0) call psb_safe_cpy( b%irp, a%irp , info) + if (info == 0) call psb_safe_cpy( b%ja , a%ja , info) + if (info == 0) call psb_safe_cpy( b%val, a%val , info) class default call b%cp_to_coo(tmp,info) @@ -3109,83 +3153,83 @@ subroutine psb_d_cp_csr_from_fmt(a,b,info) end select end subroutine psb_d_cp_csr_from_fmt - -subroutine psb_d_csr_cp_from(a,b) - use psb_error_mod - use psb_realloc_mod - use psb_d_csr_mat_mod, psb_protect_name => psb_d_csr_cp_from - implicit none - - class(psb_d_csr_sparse_mat), intent(inout) :: a - type(psb_d_csr_sparse_mat), intent(in) :: b - - - integer(psb_ipk_) :: err_act, info - integer(psb_ipk_) :: ierr(5) - character(len=20) :: name='cp_from' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - - info = psb_success_ - - call a%allocate(b%get_nrows(),b%get_ncols(),b%get_nzeros()) - call a%psb_d_base_sparse_mat%cp_from(b%psb_d_base_sparse_mat) - call psb_safe_cpy( b%irp, a%irp , info) - call psb_safe_cpy( b%ja , a%ja , info) - call psb_safe_cpy( b%val, a%val , info) - - if (info /= psb_success_) goto 9999 - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - call psb_errpush(info,name) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - -end subroutine psb_d_csr_cp_from - -subroutine psb_d_csr_mv_from(a,b) - use psb_error_mod - use psb_d_csr_mat_mod, psb_protect_name => psb_d_csr_mv_from - implicit none - - class(psb_d_csr_sparse_mat), intent(inout) :: a - type(psb_d_csr_sparse_mat), intent(inout) :: b - - - integer(psb_ipk_) :: err_act, info - integer(psb_ipk_) :: ierr(5) - character(len=20) :: name='mv_from' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = psb_success_ - call a%psb_d_base_sparse_mat%mv_from(b%psb_d_base_sparse_mat) - call move_alloc(b%irp, a%irp) - call move_alloc(b%ja, a%ja) - call move_alloc(b%val, a%val) - call b%free() - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - call psb_errpush(info,name) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - -end subroutine psb_d_csr_mv_from - - +!!$ +!!$subroutine psb_d_csr_cp_from(a,b) +!!$ use psb_error_mod +!!$ use psb_realloc_mod +!!$ use psb_d_csr_mat_mod, psb_protect_name => psb_d_csr_cp_from +!!$ implicit none +!!$ +!!$ class(psb_d_csr_sparse_mat), intent(inout) :: a +!!$ type(psb_d_csr_sparse_mat), intent(in) :: b +!!$ +!!$ +!!$ integer(psb_ipk_) :: err_act, info +!!$ integer(psb_ipk_) :: ierr(5) +!!$ character(len=20) :: name='cp_from' +!!$ logical, parameter :: debug=.false. +!!$ +!!$ call psb_erractionsave(err_act) +!!$ +!!$ info = psb_success_ +!!$ +!!$ call a%allocate(b%get_nrows(),b%get_ncols(),b%get_nzeros()) +!!$ call b%psb_d_base_sparse_mat%copy(a%psb_d_base_sparse_mat, info) +!!$ if (info == 0) call psb_safe_cpy( b%irp, a%irp , info) +!!$ if (info == 0) call psb_safe_cpy( b%ja , a%ja , info) +!!$ if (info == 0) call psb_safe_cpy( b%val, a%val , info) +!!$ +!!$ if (info /= psb_success_) goto 9999 +!!$ call psb_erractionrestore(err_act) +!!$ return +!!$ +!!$9999 continue +!!$ call psb_erractionrestore(err_act) +!!$ +!!$ call psb_errpush(info,name) +!!$ +!!$ if (err_act /= psb_act_ret_) then +!!$ call psb_error() +!!$ end if +!!$ return +!!$ +!!$end subroutine psb_d_csr_cp_from +!!$ +!!$subroutine psb_d_csr_mv_from(a,b) +!!$ use psb_error_mod +!!$ use psb_d_csr_mat_mod, psb_protect_name => psb_d_csr_mv_from +!!$ implicit none +!!$ +!!$ class(psb_d_csr_sparse_mat), intent(inout) :: a +!!$ type(psb_d_csr_sparse_mat), intent(inout) :: b +!!$ +!!$ +!!$ integer(psb_ipk_) :: err_act, info +!!$ integer(psb_ipk_) :: ierr(5) +!!$ character(len=20) :: name='mv_from' +!!$ logical, parameter :: debug=.false. +!!$ +!!$ call psb_erractionsave(err_act) +!!$ info = psb_success_ +!!$ call a%psb_d_base_sparse_mat%mv_from(b%psb_d_base_sparse_mat) +!!$ call move_alloc(b%irp, a%irp) +!!$ call move_alloc(b%ja, a%ja) +!!$ call move_alloc(b%val, a%val) +!!$ call b%free() +!!$ +!!$ call psb_erractionrestore(err_act) +!!$ return +!!$ +!!$9999 continue +!!$ call psb_erractionrestore(err_act) +!!$ +!!$ call psb_errpush(info,name) +!!$ +!!$ if (err_act /= psb_act_ret_) then +!!$ call psb_error() +!!$ end if +!!$ return +!!$ +!!$end subroutine psb_d_csr_mv_from +!!$ +!!$ diff --git a/base/serial/impl/psb_d_mat_impl.F90 b/base/serial/impl/psb_d_mat_impl.F90 index 7a035ba3..6d90c18d 100644 --- a/base/serial/impl/psb_d_mat_impl.F90 +++ b/base/serial/impl/psb_d_mat_impl.F90 @@ -1574,6 +1574,41 @@ subroutine psb_dspmat_clone(a,b,info) end subroutine psb_dspmat_clone +subroutine psb_dspmat_copy(a,b,info) + use psb_error_mod + use psb_string_mod + use psb_d_mat_mod, psb_protect_name => psb_dspmat_copy + implicit none + class(psb_dspmat_type), intent(inout) :: a + class(psb_dspmat_type), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='copy' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + call b%free() + if (allocated(a%a)) then + call a%a%clone(b%a,info) + end if + if (info /= psb_success_) 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 + +end subroutine psb_dspmat_copy + + subroutine psb_d_transp_1mat(a) use psb_error_mod diff --git a/base/serial/impl/psb_s_base_mat_impl.F90 b/base/serial/impl/psb_s_base_mat_impl.F90 index 427cb29c..41901447 100644 --- a/base/serial/impl/psb_s_base_mat_impl.F90 +++ b/base/serial/impl/psb_s_base_mat_impl.F90 @@ -584,12 +584,12 @@ subroutine psb_s_base_mold(a,b,info) use psb_s_base_mat_mod, psb_protect_name => psb_s_base_mold use psb_error_mod implicit none - class(psb_s_base_sparse_mat), intent(in) :: a - class(psb_s_base_sparse_mat), intent(out), allocatable :: b + class(psb_s_base_sparse_mat), intent(in) :: a + class(psb_s_base_sparse_mat), intent(inout), allocatable :: b integer(psb_ipk_), intent(out) :: info integer(psb_ipk_) :: err_act integer(psb_ipk_) :: ierr(5) - character(len=20) :: name='reallocate_nz' + character(len=20) :: name='base_mold' logical, parameter :: debug=.false. call psb_get_erraction(err_act) @@ -606,6 +606,43 @@ subroutine psb_s_base_mold(a,b,info) end subroutine psb_s_base_mold +subroutine psb_s_base_copy(a,b,info) + use psb_s_base_mat_mod, psb_protect_name => psb_s_base_copy + use psb_error_mod + implicit none + class(psb_s_base_sparse_mat), intent(in) :: a + class(psb_s_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: err_act + integer(psb_ipk_) :: ierr(5) + character(len=20) :: name='base_copy' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = 0 + + call a%psb_base_sparse_mat%copy(b%psb_base_sparse_mat,info) + + if (info /= 0) then + info = psb_err_internal_error_ + call psb_errpush(info,name) + goto 9999 + end if + call psb_erractionrestore(err_act) + + return +9999 continue + if (err_act /= psb_act_ret_) then + call psb_error() + end if + + return + +end subroutine psb_s_base_copy + subroutine psb_s_base_transp_2mat(a,b) use psb_s_base_mat_mod, psb_protect_name => psb_s_base_transp_2mat use psb_error_mod diff --git a/base/serial/impl/psb_s_coo_impl.f90 b/base/serial/impl/psb_s_coo_impl.f90 index 72c1ff14..6548b08c 100644 --- a/base/serial/impl/psb_s_coo_impl.f90 +++ b/base/serial/impl/psb_s_coo_impl.f90 @@ -225,19 +225,24 @@ subroutine psb_s_coo_mold(a,b,info) use psb_s_base_mat_mod, psb_protect_name => psb_s_coo_mold use psb_error_mod implicit none - class(psb_s_coo_sparse_mat), intent(in) :: a - class(psb_s_base_sparse_mat), intent(out), allocatable :: b + class(psb_s_coo_sparse_mat), intent(in) :: a + class(psb_s_base_sparse_mat), intent(inout), allocatable :: b integer(psb_ipk_), intent(out) :: info integer(psb_ipk_) :: err_act integer(psb_ipk_) :: ierr(5) - character(len=20) :: name='reallocate_nz' + character(len=20) :: name='coo_mold' logical, parameter :: debug=.false. call psb_get_erraction(err_act) - allocate(psb_s_coo_sparse_mat :: b, stat=info) + info = 0 + if (allocated(b)) then + call b%free() + deallocate(b,stat=info) + end if + if (info == 0) allocate(psb_s_coo_sparse_mat :: b, stat=info) - if (info /= psb_success_) then + if (info /= 0) then info = psb_err_alloc_dealloc_ call psb_errpush(info, name) goto 9999 @@ -251,6 +256,45 @@ subroutine psb_s_coo_mold(a,b,info) end subroutine psb_s_coo_mold +subroutine psb_s_coo_copy(a,b,info) + use psb_s_base_mat_mod, psb_protect_name => psb_s_coo_copy + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_s_coo_sparse_mat), intent(in) :: a + class(psb_s_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: err_act + integer(psb_ipk_) :: ierr(5) + character(len=20) :: name='coo_copy' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + + info = 0 + + select type(b) + type is (psb_s_coo_sparse_mat) + call a%psb_s_base_sparse_mat%copy(b%psb_s_base_sparse_mat,info) + if (info == 0) call psb_safe_cpy( a%ia, b%ia, info) + if (info == 0) call psb_safe_cpy( a%ja, b%ja, info) + if (info == 0) call psb_safe_cpy( a%val, b%val, info) + if (info == 0) call b%fix(info) + + if (info /= psb_success_) goto 9999 + class default + info = psb_err_internal_error_ + goto 9999 + end select + + return +9999 continue + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_s_coo_copy subroutine psb_s_coo_reinit(a,clear) use psb_s_base_mat_mod, psb_protect_name => psb_s_coo_reinit @@ -2920,7 +2964,7 @@ subroutine psb_s_cp_coo_to_coo(a,b,info) call psb_erractionsave(err_act) info = psb_success_ - call b%psb_s_base_sparse_mat%cp_from(a%psb_s_base_sparse_mat) + call a%psb_s_base_sparse_mat%copy(b%psb_s_base_sparse_mat,info) nz = a%get_nzeros() call b%set_nzeros(nz) @@ -2966,7 +3010,8 @@ subroutine psb_s_cp_coo_from_coo(a,b,info) call psb_erractionsave(err_act) info = psb_success_ - call a%psb_s_base_sparse_mat%cp_from(b%psb_s_base_sparse_mat) + call b%psb_s_base_sparse_mat%copy(a%psb_s_base_sparse_mat,info) + nz = b%get_nzeros() call a%set_nzeros(nz) call a%reallocate(nz) @@ -3085,7 +3130,7 @@ subroutine psb_s_mv_coo_to_coo(a,b,info) call psb_erractionsave(err_act) info = psb_success_ - call b%psb_s_base_sparse_mat%mv_from(a%psb_s_base_sparse_mat) + call a%psb_s_base_sparse_mat%copy(b%psb_s_base_sparse_mat, info) call b%set_nzeros(a%get_nzeros()) call b%reallocate(a%get_nzeros()) @@ -3130,7 +3175,7 @@ subroutine psb_s_mv_coo_from_coo(a,b,info) call psb_erractionsave(err_act) info = psb_success_ - call a%psb_s_base_sparse_mat%mv_from(b%psb_s_base_sparse_mat) + call b%psb_s_base_sparse_mat%copy(a%psb_s_base_sparse_mat, info) call a%set_nzeros(b%get_nzeros()) call a%reallocate(b%get_nzeros()) diff --git a/base/serial/impl/psb_s_csc_impl.f90 b/base/serial/impl/psb_s_csc_impl.f90 index 70a78109..eecf1739 100644 --- a/base/serial/impl/psb_s_csc_impl.f90 +++ b/base/serial/impl/psb_s_csc_impl.f90 @@ -2263,7 +2263,7 @@ subroutine psb_s_cp_csc_to_coo(a,b,info) nza = a%get_nzeros() call b%allocate(nr,nc,nza) - call b%psb_s_base_sparse_mat%cp_from(a%psb_s_base_sparse_mat) + call a%psb_s_base_sparse_mat%copy(b%psb_s_base_sparse_mat, info) do i=1, nc do j=a%icp(i),a%icp(i+1)-1 @@ -2305,7 +2305,7 @@ subroutine psb_s_mv_csc_to_coo(a,b,info) nc = a%get_ncols() nza = a%get_nzeros() - call b%psb_s_base_sparse_mat%mv_from(a%psb_s_base_sparse_mat) + call a%psb_s_base_sparse_mat%copy(b%psb_s_base_sparse_mat, info) call b%set_nzeros(a%get_nzeros()) call move_alloc(a%ia,b%ia) call move_alloc(a%val,b%val) @@ -2355,7 +2355,7 @@ subroutine psb_s_mv_csc_from_coo(a,b,info) nc = b%get_ncols() nza = b%get_nzeros() - call a%psb_s_base_sparse_mat%mv_from(b%psb_s_base_sparse_mat) + call b%psb_s_base_sparse_mat%copy(a%psb_s_base_sparse_mat, info) ! Dirty trick: call move_alloc to have the new data allocated just once. call move_alloc(b%ja,itemp) @@ -2443,7 +2443,7 @@ subroutine psb_s_mv_csc_to_fmt(a,b,info) call a%mv_to_coo(b,info) ! Need to fix trivial copies! type is (psb_s_csc_sparse_mat) - call b%psb_s_base_sparse_mat%mv_from(a%psb_s_base_sparse_mat) + call a%psb_s_base_sparse_mat%copy(b%psb_s_base_sparse_mat, info) call move_alloc(a%icp, b%icp) call move_alloc(a%ia, b%ia) call move_alloc(a%val, b%val) @@ -2484,10 +2484,10 @@ subroutine psb_s_cp_csc_to_fmt(a,b,info) call a%cp_to_coo(b,info) type is (psb_s_csc_sparse_mat) - call b%psb_s_base_sparse_mat%cp_from(a%psb_s_base_sparse_mat) - call psb_safe_cpy( a%icp, b%icp , info) - call psb_safe_cpy( a%ia , b%ia , info) - call psb_safe_cpy( a%val, b%val , info) + call a%psb_s_base_sparse_mat%copy(b%psb_s_base_sparse_mat,info) + if (info == 0) call psb_safe_cpy( a%icp, b%icp , info) + if (info == 0) call psb_safe_cpy( a%ia , b%ia , info) + if (info == 0) call psb_safe_cpy( a%val, b%val , info) class default call a%cp_to_coo(tmp,info) @@ -2523,7 +2523,7 @@ subroutine psb_s_mv_csc_from_fmt(a,b,info) call a%mv_from_coo(b,info) type is (psb_s_csc_sparse_mat) - call a%psb_s_base_sparse_mat%mv_from(b%psb_s_base_sparse_mat) + call b%psb_s_base_sparse_mat%copy(a%psb_s_base_sparse_mat, info) call move_alloc(b%icp, a%icp) call move_alloc(b%ia, a%ia) call move_alloc(b%val, a%val) @@ -2564,34 +2564,41 @@ subroutine psb_s_cp_csc_from_fmt(a,b,info) call a%cp_from_coo(b,info) type is (psb_s_csc_sparse_mat) - call a%psb_s_base_sparse_mat%cp_from(b%psb_s_base_sparse_mat) - call psb_safe_cpy( b%icp, a%icp , info) - call psb_safe_cpy( b%ia , a%ia , info) - call psb_safe_cpy( b%val, a%val , info) + call b%psb_s_base_sparse_mat%copy(a%psb_s_base_sparse_mat, info) + if (info == 0) call psb_safe_cpy( b%icp, a%icp , info) + if (info == 0) call psb_safe_cpy( b%ia , a%ia , info) + if (info == 0) call psb_safe_cpy( b%val, a%val , info) class default call b%cp_to_coo(tmp,info) if (info == psb_success_) call a%mv_from_coo(tmp,info) end select + end subroutine psb_s_cp_csc_from_fmt + subroutine psb_s_csc_mold(a,b,info) use psb_s_csc_mat_mod, psb_protect_name => psb_s_csc_mold use psb_error_mod implicit none - class(psb_s_csc_sparse_mat), intent(in) :: a - class(psb_s_base_sparse_mat), intent(out), allocatable :: b + class(psb_s_csc_sparse_mat), intent(in) :: a + class(psb_s_base_sparse_mat), intent(inout), allocatable :: b integer(psb_ipk_), intent(out) :: info integer(psb_ipk_) :: err_act integer(psb_ipk_) :: ierr(5) - character(len=20) :: name='reallocate_nz' + character(len=20) :: name='csc_mold' logical, parameter :: debug=.false. call psb_get_erraction(err_act) - allocate(psb_s_csc_sparse_mat :: b, stat=info) + info = 0 + if (allocated(b)) then + call b%free() + deallocate(b,stat=info) + end if + if (info == 0) allocate(psb_s_csc_sparse_mat :: b, stat=info) - if (info /= psb_success_) then + if (info /= 0) then info = psb_err_alloc_dealloc_ call psb_errpush(info, name) goto 9999 @@ -2605,6 +2612,44 @@ subroutine psb_s_csc_mold(a,b,info) end subroutine psb_s_csc_mold +subroutine psb_s_csc_copy(a,b,info) + use psb_s_csc_mat_mod, psb_protect_name => psb_s_csc_copy + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_s_csc_sparse_mat), intent(in) :: a + class(psb_s_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: err_act + integer(psb_ipk_) :: ierr(5) + character(len=20) :: name='csc_copy' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + + info = 0 + + select type(b) + type is (psb_s_csc_sparse_mat) + call a%psb_s_base_sparse_mat%copy(b%psb_s_base_sparse_mat, info) + if (info == 0) call psb_safe_cpy( a%icp, b%icp , info) + if (info == 0) call psb_safe_cpy( a%ia , b%ia , info) + if (info == 0) call psb_safe_cpy( a%val, b%val , info) + if (info /= psb_success_) goto 9999 + + class default + info = psb_err_internal_error_ + goto 9999 + end select + + return +9999 continue + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_s_csc_copy subroutine psb_s_csc_reallocate_nz(nz,a) use psb_error_mod @@ -2929,83 +2974,83 @@ subroutine psb_s_csc_print(iout,a,iv,head,ivr,ivc) end subroutine psb_s_csc_print -subroutine psb_s_csc_cp_from(a,b) - use psb_error_mod - use psb_realloc_mod - use psb_s_csc_mat_mod, psb_protect_name => psb_s_csc_cp_from - implicit none - - class(psb_s_csc_sparse_mat), intent(inout) :: a - type(psb_s_csc_sparse_mat), intent(in) :: b - - - integer(psb_ipk_) :: err_act, info - integer(psb_ipk_) :: ierr(5) - character(len=20) :: name='cp_from' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - - info = psb_success_ - - call a%allocate(b%get_nrows(),b%get_ncols(),b%get_nzeros()) - call a%psb_s_base_sparse_mat%cp_from(b%psb_s_base_sparse_mat) - call psb_safe_cpy( b%icp, a%icp , info) - call psb_safe_cpy( b%ia , a%ia , info) - call psb_safe_cpy( b%val, a%val , info) - - if (info /= psb_success_) goto 9999 - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - call psb_errpush(info,name) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - -end subroutine psb_s_csc_cp_from - -subroutine psb_s_csc_mv_from(a,b) - use psb_error_mod - use psb_s_csc_mat_mod, psb_protect_name => psb_s_csc_mv_from - implicit none - - class(psb_s_csc_sparse_mat), intent(inout) :: a - type(psb_s_csc_sparse_mat), intent(inout) :: b - - - integer(psb_ipk_) :: err_act, info - integer(psb_ipk_) :: ierr(5) - character(len=20) :: name='mv_from' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = psb_success_ - call a%psb_s_base_sparse_mat%mv_from(b%psb_s_base_sparse_mat) - call move_alloc(b%icp, a%icp) - call move_alloc(b%ia, a%ia) - call move_alloc(b%val, a%val) - call b%free() - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - call psb_errpush(info,name) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - -end subroutine psb_s_csc_mv_from - +!!$subroutine psb_s_csc_cp_from(a,b) +!!$ use psb_error_mod +!!$ use psb_realloc_mod +!!$ use psb_s_csc_mat_mod, psb_protect_name => psb_s_csc_cp_from +!!$ implicit none +!!$ +!!$ class(psb_s_csc_sparse_mat), intent(inout) :: a +!!$ type(psb_s_csc_sparse_mat), intent(in) :: b +!!$ +!!$ +!!$ integer(psb_ipk_) :: err_act, info +!!$ integer(psb_ipk_) :: ierr(5) +!!$ character(len=20) :: name='cp_from' +!!$ logical, parameter :: debug=.false. +!!$ +!!$ call psb_erractionsave(err_act) +!!$ +!!$ info = psb_success_ +!!$ +!!$ call a%allocate(b%get_nrows(),b%get_ncols(),b%get_nzeros()) +!!$ call b%psb_s_base_sparse_mat%copy(a%psb_s_base_sparse_mat, info) +!!$ if (info == 0) call psb_safe_cpy( b%icp, a%icp , info) +!!$ if (info == 0) call psb_safe_cpy( b%ia , a%ia , info) +!!$ if (info == 0) call psb_safe_cpy( b%val, a%val , info) +!!$ +!!$ if (info /= psb_success_) goto 9999 +!!$ call psb_erractionrestore(err_act) +!!$ return +!!$ +!!$9999 continue +!!$ call psb_erractionrestore(err_act) +!!$ +!!$ call psb_errpush(info,name) +!!$ +!!$ if (err_act /= psb_act_ret_) then +!!$ call psb_error() +!!$ end if +!!$ return +!!$ +!!$end subroutine psb_s_csc_cp_from +!!$ +!!$subroutine psb_s_csc_mv_from(a,b) +!!$ use psb_error_mod +!!$ use psb_s_csc_mat_mod, psb_protect_name => psb_s_csc_mv_from +!!$ implicit none +!!$ +!!$ class(psb_s_csc_sparse_mat), intent(inout) :: a +!!$ type(psb_s_csc_sparse_mat), intent(inout) :: b +!!$ +!!$ +!!$ integer(psb_ipk_) :: err_act, info +!!$ integer(psb_ipk_) :: ierr(5) +!!$ character(len=20) :: name='mv_from' +!!$ logical, parameter :: debug=.false. +!!$ +!!$ call psb_erractionsave(err_act) +!!$ info = psb_success_ +!!$ call b%psb_s_base_sparse_mat%copy(a%psb_s_base_sparse_mat, info) +!!$ if (info == 0) call move_alloc(b%icp, a%icp) +!!$ if (info == 0) call move_alloc(b%ia, a%ia) +!!$ if (info == 0) call move_alloc(b%val, a%val) +!!$ call b%free() +!!$ +!!$ call psb_erractionrestore(err_act) +!!$ return +!!$ +!!$9999 continue +!!$ call psb_erractionrestore(err_act) +!!$ +!!$ call psb_errpush(info,name) +!!$ +!!$ if (err_act /= psb_act_ret_) then +!!$ call psb_error() +!!$ end if +!!$ return +!!$ +!!$end subroutine psb_s_csc_mv_from +!!$ diff --git a/base/serial/impl/psb_s_csr_impl.f90 b/base/serial/impl/psb_s_csr_impl.f90 index ac59ce55..70f38297 100644 --- a/base/serial/impl/psb_s_csr_impl.f90 +++ b/base/serial/impl/psb_s_csr_impl.f90 @@ -1785,19 +1785,24 @@ subroutine psb_s_csr_mold(a,b,info) use psb_s_csr_mat_mod, psb_protect_name => psb_s_csr_mold use psb_error_mod implicit none - class(psb_s_csr_sparse_mat), intent(in) :: a - class(psb_s_base_sparse_mat), intent(out), allocatable :: b + class(psb_s_csr_sparse_mat), intent(in) :: a + class(psb_s_base_sparse_mat), intent(inout), allocatable :: b integer(psb_ipk_), intent(out) :: info integer(psb_ipk_) :: err_act integer(psb_ipk_) :: ierr(5) - character(len=20) :: name='reallocate_nz' + character(len=20) :: name='csr_mold' logical, parameter :: debug=.false. call psb_get_erraction(err_act) - allocate(psb_s_csr_sparse_mat :: b, stat=info) + info = 0 + if (allocated(b)) then + call b%free() + deallocate(b,stat=info) + end if + if (info == 0) allocate(psb_s_csr_sparse_mat :: b, stat=info) - if (info /= psb_success_) then + if (info /= 0) then info = psb_err_alloc_dealloc_ call psb_errpush(info, name) goto 9999 @@ -1811,6 +1816,45 @@ subroutine psb_s_csr_mold(a,b,info) end subroutine psb_s_csr_mold +subroutine psb_s_csr_copy(a,b,info) + use psb_s_csr_mat_mod, psb_protect_name => psb_s_csr_copy + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_s_csr_sparse_mat), intent(in) :: a + class(psb_s_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: err_act + integer(psb_ipk_) :: ierr(5) + character(len=20) :: name='csr_copy' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + + info = 0 + + select type(b) + type is (psb_s_csr_sparse_mat) + call a%psb_s_base_sparse_mat%copy(b%psb_s_base_sparse_mat, info) + if (info == 0) call psb_safe_cpy( a%irp, b%irp , info) + if (info == 0) call psb_safe_cpy( a%ja , b%ja , info) + if (info == 0) call psb_safe_cpy( a%val, b%val , info) + if (info /= psb_success_) goto 9999 + + class default + info = psb_err_internal_error_ + goto 9999 + end select + + return +9999 continue + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_s_csr_copy + subroutine psb_s_csr_allocate_mnnz(m,n,a,nz) use psb_error_mod use psb_realloc_mod @@ -2799,7 +2843,7 @@ subroutine psb_s_cp_csr_to_coo(a,b,info) nza = a%get_nzeros() call b%allocate(nr,nc,nza) - call b%psb_s_base_sparse_mat%cp_from(a%psb_s_base_sparse_mat) + call a%psb_s_base_sparse_mat%copy(b%psb_s_base_sparse_mat, info) do i=1, nr do j=a%irp(i),a%irp(i+1)-1 @@ -2840,7 +2884,7 @@ subroutine psb_s_mv_csr_to_coo(a,b,info) nc = a%get_ncols() nza = a%get_nzeros() - call b%psb_s_base_sparse_mat%mv_from(a%psb_s_base_sparse_mat) + call a%psb_s_base_sparse_mat%copy(b%psb_s_base_sparse_mat, info) call b%set_nzeros(a%get_nzeros()) call move_alloc(a%ja,b%ja) call move_alloc(a%val,b%val) @@ -2891,7 +2935,7 @@ subroutine psb_s_mv_csr_from_coo(a,b,info) nc = b%get_ncols() nza = b%get_nzeros() - call a%psb_s_base_sparse_mat%mv_from(b%psb_s_base_sparse_mat) + call b%psb_s_base_sparse_mat%copy(a%psb_s_base_sparse_mat, info) ! Dirty trick: call move_alloc to have the new data allocated just once. call move_alloc(b%ia,itemp) @@ -2978,7 +3022,7 @@ subroutine psb_s_mv_csr_to_fmt(a,b,info) call a%mv_to_coo(b,info) ! Need to fix trivial copies! type is (psb_s_csr_sparse_mat) - call b%psb_s_base_sparse_mat%mv_from(a%psb_s_base_sparse_mat) + call a%psb_s_base_sparse_mat%copy(b%psb_s_base_sparse_mat, info) call move_alloc(a%irp, b%irp) call move_alloc(a%ja, b%ja) call move_alloc(a%val, b%val) @@ -3019,10 +3063,10 @@ subroutine psb_s_cp_csr_to_fmt(a,b,info) call a%cp_to_coo(b,info) type is (psb_s_csr_sparse_mat) - call b%psb_s_base_sparse_mat%cp_from(a%psb_s_base_sparse_mat) - call psb_safe_cpy( a%irp, b%irp , info) - call psb_safe_cpy( a%ja , b%ja , info) - call psb_safe_cpy( a%val, b%val , info) + call a%psb_s_base_sparse_mat%copy(b%psb_s_base_sparse_mat, info) + if (info == 0) call psb_safe_cpy( a%irp, b%irp , info) + if (info == 0) call psb_safe_cpy( a%ja , b%ja , info) + if (info == 0) call psb_safe_cpy( a%val, b%val , info) class default call a%cp_to_coo(tmp,info) @@ -3057,7 +3101,7 @@ subroutine psb_s_mv_csr_from_fmt(a,b,info) call a%mv_from_coo(b,info) type is (psb_s_csr_sparse_mat) - call a%psb_s_base_sparse_mat%mv_from(b%psb_s_base_sparse_mat) + call b%psb_s_base_sparse_mat%copy(a%psb_s_base_sparse_mat, info) call move_alloc(b%irp, a%irp) call move_alloc(b%ja, a%ja) call move_alloc(b%val, a%val) @@ -3098,10 +3142,10 @@ subroutine psb_s_cp_csr_from_fmt(a,b,info) call a%cp_from_coo(b,info) type is (psb_s_csr_sparse_mat) - call a%psb_s_base_sparse_mat%cp_from(b%psb_s_base_sparse_mat) - call psb_safe_cpy( b%irp, a%irp , info) - call psb_safe_cpy( b%ja , a%ja , info) - call psb_safe_cpy( b%val, a%val , info) + call b%psb_s_base_sparse_mat%copy(a%psb_s_base_sparse_mat, info) + if (info == 0) call psb_safe_cpy( b%irp, a%irp , info) + if (info == 0) call psb_safe_cpy( b%ja , a%ja , info) + if (info == 0) call psb_safe_cpy( b%val, a%val , info) class default call b%cp_to_coo(tmp,info) @@ -3109,83 +3153,83 @@ subroutine psb_s_cp_csr_from_fmt(a,b,info) end select end subroutine psb_s_cp_csr_from_fmt - -subroutine psb_s_csr_cp_from(a,b) - use psb_error_mod - use psb_realloc_mod - use psb_s_csr_mat_mod, psb_protect_name => psb_s_csr_cp_from - implicit none - - class(psb_s_csr_sparse_mat), intent(inout) :: a - type(psb_s_csr_sparse_mat), intent(in) :: b - - - integer(psb_ipk_) :: err_act, info - integer(psb_ipk_) :: ierr(5) - character(len=20) :: name='cp_from' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - - info = psb_success_ - - call a%allocate(b%get_nrows(),b%get_ncols(),b%get_nzeros()) - call a%psb_s_base_sparse_mat%cp_from(b%psb_s_base_sparse_mat) - call psb_safe_cpy( b%irp, a%irp , info) - call psb_safe_cpy( b%ja , a%ja , info) - call psb_safe_cpy( b%val, a%val , info) - - if (info /= psb_success_) goto 9999 - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - call psb_errpush(info,name) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - -end subroutine psb_s_csr_cp_from - -subroutine psb_s_csr_mv_from(a,b) - use psb_error_mod - use psb_s_csr_mat_mod, psb_protect_name => psb_s_csr_mv_from - implicit none - - class(psb_s_csr_sparse_mat), intent(inout) :: a - type(psb_s_csr_sparse_mat), intent(inout) :: b - - - integer(psb_ipk_) :: err_act, info - integer(psb_ipk_) :: ierr(5) - character(len=20) :: name='mv_from' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = psb_success_ - call a%psb_s_base_sparse_mat%mv_from(b%psb_s_base_sparse_mat) - call move_alloc(b%irp, a%irp) - call move_alloc(b%ja, a%ja) - call move_alloc(b%val, a%val) - call b%free() - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - call psb_errpush(info,name) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - -end subroutine psb_s_csr_mv_from - - +!!$ +!!$subroutine psb_s_csr_cp_from(a,b) +!!$ use psb_error_mod +!!$ use psb_realloc_mod +!!$ use psb_s_csr_mat_mod, psb_protect_name => psb_s_csr_cp_from +!!$ implicit none +!!$ +!!$ class(psb_s_csr_sparse_mat), intent(inout) :: a +!!$ type(psb_s_csr_sparse_mat), intent(in) :: b +!!$ +!!$ +!!$ integer(psb_ipk_) :: err_act, info +!!$ integer(psb_ipk_) :: ierr(5) +!!$ character(len=20) :: name='cp_from' +!!$ logical, parameter :: debug=.false. +!!$ +!!$ call psb_erractionsave(err_act) +!!$ +!!$ info = psb_success_ +!!$ +!!$ call a%allocate(b%get_nrows(),b%get_ncols(),b%get_nzeros()) +!!$ call b%psb_s_base_sparse_mat%copy(a%psb_s_base_sparse_mat, info) +!!$ if (info == 0) call psb_safe_cpy( b%irp, a%irp , info) +!!$ if (info == 0) call psb_safe_cpy( b%ja , a%ja , info) +!!$ if (info == 0) call psb_safe_cpy( b%val, a%val , info) +!!$ +!!$ if (info /= psb_success_) goto 9999 +!!$ call psb_erractionrestore(err_act) +!!$ return +!!$ +!!$9999 continue +!!$ call psb_erractionrestore(err_act) +!!$ +!!$ call psb_errpush(info,name) +!!$ +!!$ if (err_act /= psb_act_ret_) then +!!$ call psb_error() +!!$ end if +!!$ return +!!$ +!!$end subroutine psb_s_csr_cp_from +!!$ +!!$subroutine psb_s_csr_mv_from(a,b) +!!$ use psb_error_mod +!!$ use psb_s_csr_mat_mod, psb_protect_name => psb_s_csr_mv_from +!!$ implicit none +!!$ +!!$ class(psb_s_csr_sparse_mat), intent(inout) :: a +!!$ type(psb_s_csr_sparse_mat), intent(inout) :: b +!!$ +!!$ +!!$ integer(psb_ipk_) :: err_act, info +!!$ integer(psb_ipk_) :: ierr(5) +!!$ character(len=20) :: name='mv_from' +!!$ logical, parameter :: debug=.false. +!!$ +!!$ call psb_erractionsave(err_act) +!!$ info = psb_success_ +!!$ call a%psb_s_base_sparse_mat%mv_from(b%psb_s_base_sparse_mat) +!!$ call move_alloc(b%irp, a%irp) +!!$ call move_alloc(b%ja, a%ja) +!!$ call move_alloc(b%val, a%val) +!!$ call b%free() +!!$ +!!$ call psb_erractionrestore(err_act) +!!$ return +!!$ +!!$9999 continue +!!$ call psb_erractionrestore(err_act) +!!$ +!!$ call psb_errpush(info,name) +!!$ +!!$ if (err_act /= psb_act_ret_) then +!!$ call psb_error() +!!$ end if +!!$ return +!!$ +!!$end subroutine psb_s_csr_mv_from +!!$ +!!$ diff --git a/base/serial/impl/psb_s_mat_impl.F90 b/base/serial/impl/psb_s_mat_impl.F90 index 1ee1561a..f93747aa 100644 --- a/base/serial/impl/psb_s_mat_impl.F90 +++ b/base/serial/impl/psb_s_mat_impl.F90 @@ -1574,6 +1574,41 @@ subroutine psb_sspmat_clone(a,b,info) end subroutine psb_sspmat_clone +subroutine psb_sspmat_copy(a,b,info) + use psb_error_mod + use psb_string_mod + use psb_s_mat_mod, psb_protect_name => psb_sspmat_copy + implicit none + class(psb_sspmat_type), intent(inout) :: a + class(psb_sspmat_type), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='copy' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + call b%free() + if (allocated(a%a)) then + call a%a%clone(b%a,info) + end if + if (info /= psb_success_) 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 + +end subroutine psb_sspmat_copy + + subroutine psb_s_transp_1mat(a) use psb_error_mod diff --git a/base/serial/impl/psb_z_base_mat_impl.F90 b/base/serial/impl/psb_z_base_mat_impl.F90 index 63b77d7c..8169c9d8 100644 --- a/base/serial/impl/psb_z_base_mat_impl.F90 +++ b/base/serial/impl/psb_z_base_mat_impl.F90 @@ -584,12 +584,12 @@ subroutine psb_z_base_mold(a,b,info) use psb_z_base_mat_mod, psb_protect_name => psb_z_base_mold use psb_error_mod implicit none - class(psb_z_base_sparse_mat), intent(in) :: a - class(psb_z_base_sparse_mat), intent(out), allocatable :: b + class(psb_z_base_sparse_mat), intent(in) :: a + class(psb_z_base_sparse_mat), intent(inout), allocatable :: b integer(psb_ipk_), intent(out) :: info integer(psb_ipk_) :: err_act integer(psb_ipk_) :: ierr(5) - character(len=20) :: name='reallocate_nz' + character(len=20) :: name='base_mold' logical, parameter :: debug=.false. call psb_get_erraction(err_act) @@ -606,6 +606,43 @@ subroutine psb_z_base_mold(a,b,info) end subroutine psb_z_base_mold +subroutine psb_z_base_copy(a,b,info) + use psb_z_base_mat_mod, psb_protect_name => psb_z_base_copy + use psb_error_mod + implicit none + class(psb_z_base_sparse_mat), intent(in) :: a + class(psb_z_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: err_act + integer(psb_ipk_) :: ierr(5) + character(len=20) :: name='base_copy' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + ! This is the base version. If we get here + ! it means the derived class is incomplete, + ! so we throw an error. + info = 0 + + call a%psb_base_sparse_mat%copy(b%psb_base_sparse_mat,info) + + if (info /= 0) then + info = psb_err_internal_error_ + call psb_errpush(info,name) + goto 9999 + end if + call psb_erractionrestore(err_act) + + return +9999 continue + if (err_act /= psb_act_ret_) then + call psb_error() + end if + + return + +end subroutine psb_z_base_copy + subroutine psb_z_base_transp_2mat(a,b) use psb_z_base_mat_mod, psb_protect_name => psb_z_base_transp_2mat use psb_error_mod diff --git a/base/serial/impl/psb_z_coo_impl.f90 b/base/serial/impl/psb_z_coo_impl.f90 index 4505db30..305203de 100644 --- a/base/serial/impl/psb_z_coo_impl.f90 +++ b/base/serial/impl/psb_z_coo_impl.f90 @@ -225,19 +225,24 @@ subroutine psb_z_coo_mold(a,b,info) use psb_z_base_mat_mod, psb_protect_name => psb_z_coo_mold use psb_error_mod implicit none - class(psb_z_coo_sparse_mat), intent(in) :: a - class(psb_z_base_sparse_mat), intent(out), allocatable :: b + class(psb_z_coo_sparse_mat), intent(in) :: a + class(psb_z_base_sparse_mat), intent(inout), allocatable :: b integer(psb_ipk_), intent(out) :: info integer(psb_ipk_) :: err_act integer(psb_ipk_) :: ierr(5) - character(len=20) :: name='reallocate_nz' + character(len=20) :: name='coo_mold' logical, parameter :: debug=.false. call psb_get_erraction(err_act) - allocate(psb_z_coo_sparse_mat :: b, stat=info) + info = 0 + if (allocated(b)) then + call b%free() + deallocate(b,stat=info) + end if + if (info == 0) allocate(psb_z_coo_sparse_mat :: b, stat=info) - if (info /= psb_success_) then + if (info /= 0) then info = psb_err_alloc_dealloc_ call psb_errpush(info, name) goto 9999 @@ -251,6 +256,45 @@ subroutine psb_z_coo_mold(a,b,info) end subroutine psb_z_coo_mold +subroutine psb_z_coo_copy(a,b,info) + use psb_z_base_mat_mod, psb_protect_name => psb_z_coo_copy + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_z_coo_sparse_mat), intent(in) :: a + class(psb_z_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: err_act + integer(psb_ipk_) :: ierr(5) + character(len=20) :: name='coo_copy' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + + info = 0 + + select type(b) + type is (psb_z_coo_sparse_mat) + call a%psb_z_base_sparse_mat%copy(b%psb_z_base_sparse_mat,info) + if (info == 0) call psb_safe_cpy( a%ia, b%ia, info) + if (info == 0) call psb_safe_cpy( a%ja, b%ja, info) + if (info == 0) call psb_safe_cpy( a%val, b%val, info) + if (info == 0) call b%fix(info) + + if (info /= psb_success_) goto 9999 + class default + info = psb_err_internal_error_ + goto 9999 + end select + + return +9999 continue + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_z_coo_copy subroutine psb_z_coo_reinit(a,clear) use psb_z_base_mat_mod, psb_protect_name => psb_z_coo_reinit @@ -2920,7 +2964,7 @@ subroutine psb_z_cp_coo_to_coo(a,b,info) call psb_erractionsave(err_act) info = psb_success_ - call b%psb_z_base_sparse_mat%cp_from(a%psb_z_base_sparse_mat) + call a%psb_z_base_sparse_mat%copy(b%psb_z_base_sparse_mat,info) nz = a%get_nzeros() call b%set_nzeros(nz) @@ -2966,7 +3010,8 @@ subroutine psb_z_cp_coo_from_coo(a,b,info) call psb_erractionsave(err_act) info = psb_success_ - call a%psb_z_base_sparse_mat%cp_from(b%psb_z_base_sparse_mat) + call b%psb_z_base_sparse_mat%copy(a%psb_z_base_sparse_mat,info) + nz = b%get_nzeros() call a%set_nzeros(nz) call a%reallocate(nz) @@ -3085,7 +3130,7 @@ subroutine psb_z_mv_coo_to_coo(a,b,info) call psb_erractionsave(err_act) info = psb_success_ - call b%psb_z_base_sparse_mat%mv_from(a%psb_z_base_sparse_mat) + call a%psb_z_base_sparse_mat%copy(b%psb_z_base_sparse_mat, info) call b%set_nzeros(a%get_nzeros()) call b%reallocate(a%get_nzeros()) @@ -3130,7 +3175,7 @@ subroutine psb_z_mv_coo_from_coo(a,b,info) call psb_erractionsave(err_act) info = psb_success_ - call a%psb_z_base_sparse_mat%mv_from(b%psb_z_base_sparse_mat) + call b%psb_z_base_sparse_mat%copy(a%psb_z_base_sparse_mat, info) call a%set_nzeros(b%get_nzeros()) call a%reallocate(b%get_nzeros()) diff --git a/base/serial/impl/psb_z_csc_impl.f90 b/base/serial/impl/psb_z_csc_impl.f90 index 1c6d1638..2b45e23d 100644 --- a/base/serial/impl/psb_z_csc_impl.f90 +++ b/base/serial/impl/psb_z_csc_impl.f90 @@ -2263,7 +2263,7 @@ subroutine psb_z_cp_csc_to_coo(a,b,info) nza = a%get_nzeros() call b%allocate(nr,nc,nza) - call b%psb_z_base_sparse_mat%cp_from(a%psb_z_base_sparse_mat) + call a%psb_z_base_sparse_mat%copy(b%psb_z_base_sparse_mat, info) do i=1, nc do j=a%icp(i),a%icp(i+1)-1 @@ -2305,7 +2305,7 @@ subroutine psb_z_mv_csc_to_coo(a,b,info) nc = a%get_ncols() nza = a%get_nzeros() - call b%psb_z_base_sparse_mat%mv_from(a%psb_z_base_sparse_mat) + call a%psb_z_base_sparse_mat%copy(b%psb_z_base_sparse_mat, info) call b%set_nzeros(a%get_nzeros()) call move_alloc(a%ia,b%ia) call move_alloc(a%val,b%val) @@ -2355,7 +2355,7 @@ subroutine psb_z_mv_csc_from_coo(a,b,info) nc = b%get_ncols() nza = b%get_nzeros() - call a%psb_z_base_sparse_mat%mv_from(b%psb_z_base_sparse_mat) + call b%psb_z_base_sparse_mat%copy(a%psb_z_base_sparse_mat, info) ! Dirty trick: call move_alloc to have the new data allocated just once. call move_alloc(b%ja,itemp) @@ -2443,7 +2443,7 @@ subroutine psb_z_mv_csc_to_fmt(a,b,info) call a%mv_to_coo(b,info) ! Need to fix trivial copies! type is (psb_z_csc_sparse_mat) - call b%psb_z_base_sparse_mat%mv_from(a%psb_z_base_sparse_mat) + call a%psb_z_base_sparse_mat%copy(b%psb_z_base_sparse_mat, info) call move_alloc(a%icp, b%icp) call move_alloc(a%ia, b%ia) call move_alloc(a%val, b%val) @@ -2484,10 +2484,10 @@ subroutine psb_z_cp_csc_to_fmt(a,b,info) call a%cp_to_coo(b,info) type is (psb_z_csc_sparse_mat) - call b%psb_z_base_sparse_mat%cp_from(a%psb_z_base_sparse_mat) - call psb_safe_cpy( a%icp, b%icp , info) - call psb_safe_cpy( a%ia , b%ia , info) - call psb_safe_cpy( a%val, b%val , info) + call a%psb_z_base_sparse_mat%copy(b%psb_z_base_sparse_mat,info) + if (info == 0) call psb_safe_cpy( a%icp, b%icp , info) + if (info == 0) call psb_safe_cpy( a%ia , b%ia , info) + if (info == 0) call psb_safe_cpy( a%val, b%val , info) class default call a%cp_to_coo(tmp,info) @@ -2523,7 +2523,7 @@ subroutine psb_z_mv_csc_from_fmt(a,b,info) call a%mv_from_coo(b,info) type is (psb_z_csc_sparse_mat) - call a%psb_z_base_sparse_mat%mv_from(b%psb_z_base_sparse_mat) + call b%psb_z_base_sparse_mat%copy(a%psb_z_base_sparse_mat, info) call move_alloc(b%icp, a%icp) call move_alloc(b%ia, a%ia) call move_alloc(b%val, a%val) @@ -2564,34 +2564,41 @@ subroutine psb_z_cp_csc_from_fmt(a,b,info) call a%cp_from_coo(b,info) type is (psb_z_csc_sparse_mat) - call a%psb_z_base_sparse_mat%cp_from(b%psb_z_base_sparse_mat) - call psb_safe_cpy( b%icp, a%icp , info) - call psb_safe_cpy( b%ia , a%ia , info) - call psb_safe_cpy( b%val, a%val , info) + call b%psb_z_base_sparse_mat%copy(a%psb_z_base_sparse_mat, info) + if (info == 0) call psb_safe_cpy( b%icp, a%icp , info) + if (info == 0) call psb_safe_cpy( b%ia , a%ia , info) + if (info == 0) call psb_safe_cpy( b%val, a%val , info) class default call b%cp_to_coo(tmp,info) if (info == psb_success_) call a%mv_from_coo(tmp,info) end select + end subroutine psb_z_cp_csc_from_fmt + subroutine psb_z_csc_mold(a,b,info) use psb_z_csc_mat_mod, psb_protect_name => psb_z_csc_mold use psb_error_mod implicit none - class(psb_z_csc_sparse_mat), intent(in) :: a - class(psb_z_base_sparse_mat), intent(out), allocatable :: b + class(psb_z_csc_sparse_mat), intent(in) :: a + class(psb_z_base_sparse_mat), intent(inout), allocatable :: b integer(psb_ipk_), intent(out) :: info integer(psb_ipk_) :: err_act integer(psb_ipk_) :: ierr(5) - character(len=20) :: name='reallocate_nz' + character(len=20) :: name='csc_mold' logical, parameter :: debug=.false. call psb_get_erraction(err_act) - allocate(psb_z_csc_sparse_mat :: b, stat=info) + info = 0 + if (allocated(b)) then + call b%free() + deallocate(b,stat=info) + end if + if (info == 0) allocate(psb_z_csc_sparse_mat :: b, stat=info) - if (info /= psb_success_) then + if (info /= 0) then info = psb_err_alloc_dealloc_ call psb_errpush(info, name) goto 9999 @@ -2605,6 +2612,44 @@ subroutine psb_z_csc_mold(a,b,info) end subroutine psb_z_csc_mold +subroutine psb_z_csc_copy(a,b,info) + use psb_z_csc_mat_mod, psb_protect_name => psb_z_csc_copy + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_z_csc_sparse_mat), intent(in) :: a + class(psb_z_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: err_act + integer(psb_ipk_) :: ierr(5) + character(len=20) :: name='csc_copy' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + + info = 0 + + select type(b) + type is (psb_z_csc_sparse_mat) + call a%psb_z_base_sparse_mat%copy(b%psb_z_base_sparse_mat, info) + if (info == 0) call psb_safe_cpy( a%icp, b%icp , info) + if (info == 0) call psb_safe_cpy( a%ia , b%ia , info) + if (info == 0) call psb_safe_cpy( a%val, b%val , info) + if (info /= psb_success_) goto 9999 + + class default + info = psb_err_internal_error_ + goto 9999 + end select + + return +9999 continue + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_z_csc_copy subroutine psb_z_csc_reallocate_nz(nz,a) use psb_error_mod @@ -2929,83 +2974,83 @@ subroutine psb_z_csc_print(iout,a,iv,head,ivr,ivc) end subroutine psb_z_csc_print -subroutine psb_z_csc_cp_from(a,b) - use psb_error_mod - use psb_realloc_mod - use psb_z_csc_mat_mod, psb_protect_name => psb_z_csc_cp_from - implicit none - - class(psb_z_csc_sparse_mat), intent(inout) :: a - type(psb_z_csc_sparse_mat), intent(in) :: b - - - integer(psb_ipk_) :: err_act, info - integer(psb_ipk_) :: ierr(5) - character(len=20) :: name='cp_from' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - - info = psb_success_ - - call a%allocate(b%get_nrows(),b%get_ncols(),b%get_nzeros()) - call a%psb_z_base_sparse_mat%cp_from(b%psb_z_base_sparse_mat) - call psb_safe_cpy( b%icp, a%icp , info) - call psb_safe_cpy( b%ia , a%ia , info) - call psb_safe_cpy( b%val, a%val , info) - - if (info /= psb_success_) goto 9999 - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - call psb_errpush(info,name) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - -end subroutine psb_z_csc_cp_from - -subroutine psb_z_csc_mv_from(a,b) - use psb_error_mod - use psb_z_csc_mat_mod, psb_protect_name => psb_z_csc_mv_from - implicit none - - class(psb_z_csc_sparse_mat), intent(inout) :: a - type(psb_z_csc_sparse_mat), intent(inout) :: b - - - integer(psb_ipk_) :: err_act, info - integer(psb_ipk_) :: ierr(5) - character(len=20) :: name='mv_from' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = psb_success_ - call a%psb_z_base_sparse_mat%mv_from(b%psb_z_base_sparse_mat) - call move_alloc(b%icp, a%icp) - call move_alloc(b%ia, a%ia) - call move_alloc(b%val, a%val) - call b%free() - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - call psb_errpush(info,name) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - -end subroutine psb_z_csc_mv_from - +!!$subroutine psb_z_csc_cp_from(a,b) +!!$ use psb_error_mod +!!$ use psb_realloc_mod +!!$ use psb_z_csc_mat_mod, psb_protect_name => psb_z_csc_cp_from +!!$ implicit none +!!$ +!!$ class(psb_z_csc_sparse_mat), intent(inout) :: a +!!$ type(psb_z_csc_sparse_mat), intent(in) :: b +!!$ +!!$ +!!$ integer(psb_ipk_) :: err_act, info +!!$ integer(psb_ipk_) :: ierr(5) +!!$ character(len=20) :: name='cp_from' +!!$ logical, parameter :: debug=.false. +!!$ +!!$ call psb_erractionsave(err_act) +!!$ +!!$ info = psb_success_ +!!$ +!!$ call a%allocate(b%get_nrows(),b%get_ncols(),b%get_nzeros()) +!!$ call b%psb_z_base_sparse_mat%copy(a%psb_z_base_sparse_mat, info) +!!$ if (info == 0) call psb_safe_cpy( b%icp, a%icp , info) +!!$ if (info == 0) call psb_safe_cpy( b%ia , a%ia , info) +!!$ if (info == 0) call psb_safe_cpy( b%val, a%val , info) +!!$ +!!$ if (info /= psb_success_) goto 9999 +!!$ call psb_erractionrestore(err_act) +!!$ return +!!$ +!!$9999 continue +!!$ call psb_erractionrestore(err_act) +!!$ +!!$ call psb_errpush(info,name) +!!$ +!!$ if (err_act /= psb_act_ret_) then +!!$ call psb_error() +!!$ end if +!!$ return +!!$ +!!$end subroutine psb_z_csc_cp_from +!!$ +!!$subroutine psb_z_csc_mv_from(a,b) +!!$ use psb_error_mod +!!$ use psb_z_csc_mat_mod, psb_protect_name => psb_z_csc_mv_from +!!$ implicit none +!!$ +!!$ class(psb_z_csc_sparse_mat), intent(inout) :: a +!!$ type(psb_z_csc_sparse_mat), intent(inout) :: b +!!$ +!!$ +!!$ integer(psb_ipk_) :: err_act, info +!!$ integer(psb_ipk_) :: ierr(5) +!!$ character(len=20) :: name='mv_from' +!!$ logical, parameter :: debug=.false. +!!$ +!!$ call psb_erractionsave(err_act) +!!$ info = psb_success_ +!!$ call b%psb_z_base_sparse_mat%copy(a%psb_z_base_sparse_mat, info) +!!$ if (info == 0) call move_alloc(b%icp, a%icp) +!!$ if (info == 0) call move_alloc(b%ia, a%ia) +!!$ if (info == 0) call move_alloc(b%val, a%val) +!!$ call b%free() +!!$ +!!$ call psb_erractionrestore(err_act) +!!$ return +!!$ +!!$9999 continue +!!$ call psb_erractionrestore(err_act) +!!$ +!!$ call psb_errpush(info,name) +!!$ +!!$ if (err_act /= psb_act_ret_) then +!!$ call psb_error() +!!$ end if +!!$ return +!!$ +!!$end subroutine psb_z_csc_mv_from +!!$ diff --git a/base/serial/impl/psb_z_csr_impl.f90 b/base/serial/impl/psb_z_csr_impl.f90 index f0606683..46f3b5dc 100644 --- a/base/serial/impl/psb_z_csr_impl.f90 +++ b/base/serial/impl/psb_z_csr_impl.f90 @@ -1785,19 +1785,24 @@ subroutine psb_z_csr_mold(a,b,info) use psb_z_csr_mat_mod, psb_protect_name => psb_z_csr_mold use psb_error_mod implicit none - class(psb_z_csr_sparse_mat), intent(in) :: a - class(psb_z_base_sparse_mat), intent(out), allocatable :: b + class(psb_z_csr_sparse_mat), intent(in) :: a + class(psb_z_base_sparse_mat), intent(inout), allocatable :: b integer(psb_ipk_), intent(out) :: info integer(psb_ipk_) :: err_act integer(psb_ipk_) :: ierr(5) - character(len=20) :: name='reallocate_nz' + character(len=20) :: name='csr_mold' logical, parameter :: debug=.false. call psb_get_erraction(err_act) - allocate(psb_z_csr_sparse_mat :: b, stat=info) + info = 0 + if (allocated(b)) then + call b%free() + deallocate(b,stat=info) + end if + if (info == 0) allocate(psb_z_csr_sparse_mat :: b, stat=info) - if (info /= psb_success_) then + if (info /= 0) then info = psb_err_alloc_dealloc_ call psb_errpush(info, name) goto 9999 @@ -1811,6 +1816,45 @@ subroutine psb_z_csr_mold(a,b,info) end subroutine psb_z_csr_mold +subroutine psb_z_csr_copy(a,b,info) + use psb_z_csr_mat_mod, psb_protect_name => psb_z_csr_copy + use psb_error_mod + use psb_realloc_mod + implicit none + class(psb_z_csr_sparse_mat), intent(in) :: a + class(psb_z_base_sparse_mat), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: err_act + integer(psb_ipk_) :: ierr(5) + character(len=20) :: name='csr_copy' + logical, parameter :: debug=.false. + + call psb_get_erraction(err_act) + + info = 0 + + select type(b) + type is (psb_z_csr_sparse_mat) + call a%psb_z_base_sparse_mat%copy(b%psb_z_base_sparse_mat, info) + if (info == 0) call psb_safe_cpy( a%irp, b%irp , info) + if (info == 0) call psb_safe_cpy( a%ja , b%ja , info) + if (info == 0) call psb_safe_cpy( a%val, b%val , info) + if (info /= psb_success_) goto 9999 + + class default + info = psb_err_internal_error_ + goto 9999 + end select + + return +9999 continue + if (err_act /= psb_act_ret_) then + call psb_error() + end if + return + +end subroutine psb_z_csr_copy + subroutine psb_z_csr_allocate_mnnz(m,n,a,nz) use psb_error_mod use psb_realloc_mod @@ -2799,7 +2843,7 @@ subroutine psb_z_cp_csr_to_coo(a,b,info) nza = a%get_nzeros() call b%allocate(nr,nc,nza) - call b%psb_z_base_sparse_mat%cp_from(a%psb_z_base_sparse_mat) + call a%psb_z_base_sparse_mat%copy(b%psb_z_base_sparse_mat, info) do i=1, nr do j=a%irp(i),a%irp(i+1)-1 @@ -2840,7 +2884,7 @@ subroutine psb_z_mv_csr_to_coo(a,b,info) nc = a%get_ncols() nza = a%get_nzeros() - call b%psb_z_base_sparse_mat%mv_from(a%psb_z_base_sparse_mat) + call a%psb_z_base_sparse_mat%copy(b%psb_z_base_sparse_mat, info) call b%set_nzeros(a%get_nzeros()) call move_alloc(a%ja,b%ja) call move_alloc(a%val,b%val) @@ -2891,7 +2935,7 @@ subroutine psb_z_mv_csr_from_coo(a,b,info) nc = b%get_ncols() nza = b%get_nzeros() - call a%psb_z_base_sparse_mat%mv_from(b%psb_z_base_sparse_mat) + call b%psb_z_base_sparse_mat%copy(a%psb_z_base_sparse_mat, info) ! Dirty trick: call move_alloc to have the new data allocated just once. call move_alloc(b%ia,itemp) @@ -2978,7 +3022,7 @@ subroutine psb_z_mv_csr_to_fmt(a,b,info) call a%mv_to_coo(b,info) ! Need to fix trivial copies! type is (psb_z_csr_sparse_mat) - call b%psb_z_base_sparse_mat%mv_from(a%psb_z_base_sparse_mat) + call a%psb_z_base_sparse_mat%copy(b%psb_z_base_sparse_mat, info) call move_alloc(a%irp, b%irp) call move_alloc(a%ja, b%ja) call move_alloc(a%val, b%val) @@ -3019,10 +3063,10 @@ subroutine psb_z_cp_csr_to_fmt(a,b,info) call a%cp_to_coo(b,info) type is (psb_z_csr_sparse_mat) - call b%psb_z_base_sparse_mat%cp_from(a%psb_z_base_sparse_mat) - call psb_safe_cpy( a%irp, b%irp , info) - call psb_safe_cpy( a%ja , b%ja , info) - call psb_safe_cpy( a%val, b%val , info) + call a%psb_z_base_sparse_mat%copy(b%psb_z_base_sparse_mat, info) + if (info == 0) call psb_safe_cpy( a%irp, b%irp , info) + if (info == 0) call psb_safe_cpy( a%ja , b%ja , info) + if (info == 0) call psb_safe_cpy( a%val, b%val , info) class default call a%cp_to_coo(tmp,info) @@ -3057,7 +3101,7 @@ subroutine psb_z_mv_csr_from_fmt(a,b,info) call a%mv_from_coo(b,info) type is (psb_z_csr_sparse_mat) - call a%psb_z_base_sparse_mat%mv_from(b%psb_z_base_sparse_mat) + call b%psb_z_base_sparse_mat%copy(a%psb_z_base_sparse_mat, info) call move_alloc(b%irp, a%irp) call move_alloc(b%ja, a%ja) call move_alloc(b%val, a%val) @@ -3098,10 +3142,10 @@ subroutine psb_z_cp_csr_from_fmt(a,b,info) call a%cp_from_coo(b,info) type is (psb_z_csr_sparse_mat) - call a%psb_z_base_sparse_mat%cp_from(b%psb_z_base_sparse_mat) - call psb_safe_cpy( b%irp, a%irp , info) - call psb_safe_cpy( b%ja , a%ja , info) - call psb_safe_cpy( b%val, a%val , info) + call b%psb_z_base_sparse_mat%copy(a%psb_z_base_sparse_mat, info) + if (info == 0) call psb_safe_cpy( b%irp, a%irp , info) + if (info == 0) call psb_safe_cpy( b%ja , a%ja , info) + if (info == 0) call psb_safe_cpy( b%val, a%val , info) class default call b%cp_to_coo(tmp,info) @@ -3109,83 +3153,83 @@ subroutine psb_z_cp_csr_from_fmt(a,b,info) end select end subroutine psb_z_cp_csr_from_fmt - -subroutine psb_z_csr_cp_from(a,b) - use psb_error_mod - use psb_realloc_mod - use psb_z_csr_mat_mod, psb_protect_name => psb_z_csr_cp_from - implicit none - - class(psb_z_csr_sparse_mat), intent(inout) :: a - type(psb_z_csr_sparse_mat), intent(in) :: b - - - integer(psb_ipk_) :: err_act, info - integer(psb_ipk_) :: ierr(5) - character(len=20) :: name='cp_from' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - - info = psb_success_ - - call a%allocate(b%get_nrows(),b%get_ncols(),b%get_nzeros()) - call a%psb_z_base_sparse_mat%cp_from(b%psb_z_base_sparse_mat) - call psb_safe_cpy( b%irp, a%irp , info) - call psb_safe_cpy( b%ja , a%ja , info) - call psb_safe_cpy( b%val, a%val , info) - - if (info /= psb_success_) goto 9999 - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - call psb_errpush(info,name) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - -end subroutine psb_z_csr_cp_from - -subroutine psb_z_csr_mv_from(a,b) - use psb_error_mod - use psb_z_csr_mat_mod, psb_protect_name => psb_z_csr_mv_from - implicit none - - class(psb_z_csr_sparse_mat), intent(inout) :: a - type(psb_z_csr_sparse_mat), intent(inout) :: b - - - integer(psb_ipk_) :: err_act, info - integer(psb_ipk_) :: ierr(5) - character(len=20) :: name='mv_from' - logical, parameter :: debug=.false. - - call psb_erractionsave(err_act) - info = psb_success_ - call a%psb_z_base_sparse_mat%mv_from(b%psb_z_base_sparse_mat) - call move_alloc(b%irp, a%irp) - call move_alloc(b%ja, a%ja) - call move_alloc(b%val, a%val) - call b%free() - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - call psb_errpush(info,name) - - if (err_act /= psb_act_ret_) then - call psb_error() - end if - return - -end subroutine psb_z_csr_mv_from - - +!!$ +!!$subroutine psb_z_csr_cp_from(a,b) +!!$ use psb_error_mod +!!$ use psb_realloc_mod +!!$ use psb_z_csr_mat_mod, psb_protect_name => psb_z_csr_cp_from +!!$ implicit none +!!$ +!!$ class(psb_z_csr_sparse_mat), intent(inout) :: a +!!$ type(psb_z_csr_sparse_mat), intent(in) :: b +!!$ +!!$ +!!$ integer(psb_ipk_) :: err_act, info +!!$ integer(psb_ipk_) :: ierr(5) +!!$ character(len=20) :: name='cp_from' +!!$ logical, parameter :: debug=.false. +!!$ +!!$ call psb_erractionsave(err_act) +!!$ +!!$ info = psb_success_ +!!$ +!!$ call a%allocate(b%get_nrows(),b%get_ncols(),b%get_nzeros()) +!!$ call b%psb_z_base_sparse_mat%copy(a%psb_z_base_sparse_mat, info) +!!$ if (info == 0) call psb_safe_cpy( b%irp, a%irp , info) +!!$ if (info == 0) call psb_safe_cpy( b%ja , a%ja , info) +!!$ if (info == 0) call psb_safe_cpy( b%val, a%val , info) +!!$ +!!$ if (info /= psb_success_) goto 9999 +!!$ call psb_erractionrestore(err_act) +!!$ return +!!$ +!!$9999 continue +!!$ call psb_erractionrestore(err_act) +!!$ +!!$ call psb_errpush(info,name) +!!$ +!!$ if (err_act /= psb_act_ret_) then +!!$ call psb_error() +!!$ end if +!!$ return +!!$ +!!$end subroutine psb_z_csr_cp_from +!!$ +!!$subroutine psb_z_csr_mv_from(a,b) +!!$ use psb_error_mod +!!$ use psb_z_csr_mat_mod, psb_protect_name => psb_z_csr_mv_from +!!$ implicit none +!!$ +!!$ class(psb_z_csr_sparse_mat), intent(inout) :: a +!!$ type(psb_z_csr_sparse_mat), intent(inout) :: b +!!$ +!!$ +!!$ integer(psb_ipk_) :: err_act, info +!!$ integer(psb_ipk_) :: ierr(5) +!!$ character(len=20) :: name='mv_from' +!!$ logical, parameter :: debug=.false. +!!$ +!!$ call psb_erractionsave(err_act) +!!$ info = psb_success_ +!!$ call a%psb_z_base_sparse_mat%mv_from(b%psb_z_base_sparse_mat) +!!$ call move_alloc(b%irp, a%irp) +!!$ call move_alloc(b%ja, a%ja) +!!$ call move_alloc(b%val, a%val) +!!$ call b%free() +!!$ +!!$ call psb_erractionrestore(err_act) +!!$ return +!!$ +!!$9999 continue +!!$ call psb_erractionrestore(err_act) +!!$ +!!$ call psb_errpush(info,name) +!!$ +!!$ if (err_act /= psb_act_ret_) then +!!$ call psb_error() +!!$ end if +!!$ return +!!$ +!!$end subroutine psb_z_csr_mv_from +!!$ +!!$ diff --git a/base/serial/impl/psb_z_mat_impl.F90 b/base/serial/impl/psb_z_mat_impl.F90 index 2e3e2819..f308e468 100644 --- a/base/serial/impl/psb_z_mat_impl.F90 +++ b/base/serial/impl/psb_z_mat_impl.F90 @@ -1574,6 +1574,41 @@ subroutine psb_zspmat_clone(a,b,info) end subroutine psb_zspmat_clone +subroutine psb_zspmat_copy(a,b,info) + use psb_error_mod + use psb_string_mod + use psb_z_mat_mod, psb_protect_name => psb_zspmat_copy + implicit none + class(psb_zspmat_type), intent(inout) :: a + class(psb_zspmat_type), intent(inout) :: b + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: err_act + character(len=20) :: name='copy' + logical, parameter :: debug=.false. + + call psb_erractionsave(err_act) + info = psb_success_ + call b%free() + if (allocated(a%a)) then + call a%a%clone(b%a,info) + end if + if (info /= psb_success_) 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 + +end subroutine psb_zspmat_copy + + subroutine psb_z_transp_1mat(a) use psb_error_mod