fdurastante
/
psblas3
mirror of https://github.com/sfilippone/psblas3.git
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity

psblas3:

Browse Source 
base/modules/psb_base_mat_mod.f90
 base/modules/psb_c_base_mat_mod.f90
 base/modules/psb_c_csc_mat_mod.f90
 base/modules/psb_c_csr_mat_mod.f90
 base/modules/psb_c_mat_mod.f90
 base/modules/psb_d_base_mat_mod.f90
 base/modules/psb_d_csc_mat_mod.f90
 base/modules/psb_d_csr_mat_mod.f90
 base/modules/psb_d_mat_mod.f90
 base/modules/psb_i_comm_mod.f90
 base/modules/psb_s_base_mat_mod.f90
 base/modules/psb_s_csc_mat_mod.f90
 base/modules/psb_s_csr_mat_mod.f90
 base/modules/psb_s_mat_mod.f90
 base/modules/psb_z_base_mat_mod.f90
 base/modules/psb_z_csc_mat_mod.f90
 base/modules/psb_z_csr_mat_mod.f90
 base/modules/psb_z_mat_mod.f90
 base/serial/impl/psb_c_base_mat_impl.F90
 base/serial/impl/psb_c_coo_impl.f90
 base/serial/impl/psb_c_csc_impl.f90
 base/serial/impl/psb_c_csr_impl.f90
 base/serial/impl/psb_c_mat_impl.F90
 base/serial/impl/psb_d_base_mat_impl.F90
 base/serial/impl/psb_d_coo_impl.f90
 base/serial/impl/psb_d_csc_impl.f90
 base/serial/impl/psb_d_csr_impl.f90
 base/serial/impl/psb_d_mat_impl.F90
 base/serial/impl/psb_s_base_mat_impl.F90
 base/serial/impl/psb_s_coo_impl.f90
 base/serial/impl/psb_s_csc_impl.f90
 base/serial/impl/psb_s_csr_impl.f90
 base/serial/impl/psb_s_mat_impl.F90
 base/serial/impl/psb_z_base_mat_impl.F90
 base/serial/impl/psb_z_coo_impl.f90
 base/serial/impl/psb_z_csc_impl.f90
 base/serial/impl/psb_z_csr_impl.f90
 base/serial/impl/psb_z_mat_impl.F90


Rework copy and clone interfaces
psblas3-final
Salvatore Filippone 12 years ago
parent a3ce4ed45f
commit 0c06188538
38 changed files with 2120 additions and 1156 deletions
Show Stats Download Patch File Download Diff File

94
base/modules/psb_base_mat_mod.f90
Unescape Escape View File

@ -177,6 +177,7 @@ module psb_base_mat_mod
! == = ================================= ! == = =================================
procedure, pass(a) :: get_neigh => psb_base_get_neigh procedure, pass(a) :: get_neigh => psb_base_get_neigh
procedure, pass(a) :: free => psb_base_free procedure, pass(a) :: free => psb_base_free
procedure, pass(a) :: copy => psb_base_copy
procedure, pass(a) :: trim => psb_base_trim procedure, pass(a) :: trim => psb_base_trim
procedure, pass(a) :: reinit => psb_base_reinit procedure, pass(a) :: reinit => psb_base_reinit
procedure, pass(a) :: allocate_mnnz => psb_base_allocate_mnnz procedure, pass(a) :: allocate_mnnz => psb_base_allocate_mnnz
@ -187,10 +188,10 @@ module psb_base_mat_mod
generic, public :: csget => csgetptn generic, public :: csget => csgetptn
procedure, pass(a) :: print => psb_base_sparse_print procedure, pass(a) :: print => psb_base_sparse_print
procedure, pass(a) :: sizeof => psb_base_sizeof procedure, pass(a) :: sizeof => psb_base_sizeof
procedure, pass(a) :: psb_base_cp_from !!$ procedure, pass(a) :: psb_base_cp_from
generic, public :: cp_from => psb_base_cp_from !!$ generic, public :: cp_from => psb_base_cp_from
procedure, pass(a) :: psb_base_mv_from !!$ procedure, pass(a) :: psb_base_mv_from
generic, public :: mv_from => 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_1mat => psb_base_transp_1mat
procedure, pass(a) :: transp_2mat => psb_base_transp_2mat procedure, pass(a) :: transp_2mat => psb_base_transp_2mat
generic, public :: transp => transp_1mat, transp_2mat generic, public :: transp => transp_1mat, transp_2mat
@ -653,46 +654,65 @@ contains
end function psb_base_is_sorted end function psb_base_is_sorted
! !!$ !
! MV|CP_FROM: at base level they are the same. !!$ ! MV|CP_FROM: at base level they are the same.
! !!$ !
! !!$ !
!!$
subroutine psb_base_mv_from(a,b) !!$ subroutine psb_base_mv_from(a,b)
implicit none !!$ implicit none
!!$
class(psb_base_sparse_mat), intent(out) :: a !!$ class(psb_base_sparse_mat), intent(out) :: a
type(psb_base_sparse_mat), intent(inout) :: b !!$ type(psb_base_sparse_mat), intent(inout) :: b
!!$
a%m = b%m !!$ a%m = b%m
a%n = b%n !!$ a%n = b%n
a%state = b%state !!$ a%state = b%state
a%duplicate = b%duplicate !!$ a%duplicate = b%duplicate
a%triangle = b%triangle !!$ a%triangle = b%triangle
a%unitd = b%unitd !!$ a%unitd = b%unitd
a%upper = b%upper !!$ a%upper = b%upper
a%sorted = b%sorted !!$ a%sorted = b%sorted
!!$
end subroutine psb_base_mv_from !!$ end subroutine psb_base_mv_from
subroutine psb_base_cp_from(a,b) subroutine psb_base_copy(a,b,info)
implicit none implicit none
class(psb_base_sparse_mat), intent(out) :: a class(psb_base_sparse_mat), intent(in) :: a
type(psb_base_sparse_mat), intent(in) :: b class(psb_base_sparse_mat), intent(inout) :: b
integer(psb_ipk_), intent(out) :: info
a%m = b%m info = 0
a%n = b%n b%m = a%m
a%state = b%state b%n = a%n
a%duplicate = b%duplicate b%state = a%state
a%triangle = b%triangle b%duplicate = a%duplicate
a%unitd = b%unitd b%triangle = a%triangle
a%upper = b%upper b%unitd = a%unitd
a%sorted = b%sorted b%upper = a%upper
b%sorted = a%sorted
end subroutine psb_base_cp_from 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. ! TRANSP: note sorted=.false.
! better invoke a fix() too many than ! better invoke a fix() too many than

99
base/modules/psb_c_base_mat_mod.f90
Unescape Escape View File

@ -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_from_coo => psb_c_base_mv_from_coo
procedure, pass(a) :: mv_to_fmt => psb_c_base_mv_to_fmt 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) :: 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) :: mold => psb_c_base_mold
procedure, pass(a) :: copy => psb_c_base_copy
procedure, pass(a) :: clone => psb_c_base_clone 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 procedure, pass(a) :: aclsum => psb_c_base_aclsum
end type psb_c_base_sparse_mat 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 !> \namespace psb_base_mod \class psb_c_coo_sparse_mat
!! \extends psb_c_base_mat_mod::psb_c_base_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) :: print => psb_c_coo_print
procedure, pass(a) :: free => c_coo_free procedure, pass(a) :: free => c_coo_free
procedure, pass(a) :: mold => psb_c_coo_mold procedure, pass(a) :: mold => psb_c_coo_mold
procedure, pass(a) :: psb_c_coo_cp_from procedure, pass(a) :: copy => psb_c_coo_copy
generic, public :: cp_from => psb_c_coo_cp_from !!$ procedure, pass(a) :: clone => psb_c_coo_clone
procedure, pass(a) :: psb_c_coo_mv_from
generic, public :: mv_from => psb_c_coo_mv_from
! !
! This is COO specific ! This is COO specific
! !
@ -413,11 +405,30 @@ module psb_c_base_mat_mod
subroutine psb_c_base_mold(a,b,info) subroutine psb_c_base_mold(a,b,info)
import :: psb_ipk_, psb_c_base_sparse_mat, psb_long_int_k_ 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(in) :: a
class(psb_c_base_sparse_mat), intent(out), allocatable :: b class(psb_c_base_sparse_mat), intent(inout), allocatable :: b
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
end subroutine psb_c_base_mold end subroutine psb_c_base_mold
end interface 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: !> Function clone:
!! \memberof psb_c_base_sparse_mat !! \memberof psb_c_base_sparse_mat
@ -425,6 +436,8 @@ module psb_c_base_mat_mod
!! same dynamic type as the input. !! same dynamic type as the input.
!! This is equivalent to allocate( source= ) except that !! This is equivalent to allocate( source= ) except that
!! it should guarantee a deep copy wherever needed. !! 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 b The output variable
!! \param info return code !! \param info return code
! !
@ -1131,20 +1144,41 @@ module psb_c_base_mat_mod
end subroutine psb_c_coo_allocate_mnnz end subroutine psb_c_coo_allocate_mnnz
end interface end interface
!
!> !> \memberof psb_c_coo_sparse_mat
!! \memberof psb_c_coo_sparse_mat !| \see psb_base_mat_mod::psb_base_mold
!! \see psb_c_base_mat_mod::psb_c_base_mold
!
interface interface
subroutine psb_c_coo_mold(a,b,info) 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_ 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_coo_sparse_mat), intent(in) :: a
class(psb_c_base_sparse_mat), intent(out), allocatable :: b class(psb_c_base_sparse_mat), intent(inout), allocatable :: b
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
end subroutine psb_c_coo_mold end subroutine psb_c_coo_mold
end interface 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
! !
!> Function print. !> Function print.
@ -1585,35 +1619,6 @@ module psb_c_base_mat_mod
contains 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
! == ================================== ! == ==================================
! !

18
base/modules/psb_c_csc_mat_mod.f90
Unescape Escape View File

@ -97,10 +97,7 @@ module psb_c_csc_mat_mod
procedure, pass(a) :: print => psb_c_csc_print procedure, pass(a) :: print => psb_c_csc_print
procedure, pass(a) :: free => c_csc_free procedure, pass(a) :: free => c_csc_free
procedure, pass(a) :: mold => psb_c_csc_mold procedure, pass(a) :: mold => psb_c_csc_mold
procedure, pass(a) :: psb_c_csc_cp_from procedure, pass(a) :: copy => psb_c_csc_copy
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
end type psb_c_csc_sparse_mat end type psb_c_csc_sparse_mat
@ -142,11 +139,22 @@ module psb_c_csc_mat_mod
subroutine psb_c_csc_mold(a,b,info) 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_ 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_csc_sparse_mat), intent(in) :: a
class(psb_c_base_sparse_mat), intent(out), allocatable :: b class(psb_c_base_sparse_mat), intent(inout), allocatable :: b
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
end subroutine psb_c_csc_mold end subroutine psb_c_csc_mold
end interface 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 !> \memberof psb_c_csc_sparse_mat
!| \see psb_base_mat_mod::psb_base_allocate_mnnz !| \see psb_base_mat_mod::psb_base_allocate_mnnz

17
base/modules/psb_c_csr_mat_mod.f90
Unescape Escape View File

@ -98,10 +98,7 @@ module psb_c_csr_mat_mod
procedure, pass(a) :: print => psb_c_csr_print procedure, pass(a) :: print => psb_c_csr_print
procedure, pass(a) :: free => c_csr_free procedure, pass(a) :: free => c_csr_free
procedure, pass(a) :: mold => psb_c_csr_mold procedure, pass(a) :: mold => psb_c_csr_mold
procedure, pass(a) :: psb_c_csr_cp_from procedure, pass(a) :: copy => psb_c_csr_copy
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
end type psb_c_csr_sparse_mat end type psb_c_csr_sparse_mat
@ -144,11 +141,21 @@ module psb_c_csr_mat_mod
subroutine psb_c_csr_mold(a,b,info) 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_ 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_csr_sparse_mat), intent(in) :: a
class(psb_c_base_sparse_mat), intent(out), allocatable :: b class(psb_c_base_sparse_mat), intent(inout), allocatable :: b
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
end subroutine psb_c_csr_mold end subroutine psb_c_csr_mold
end interface 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 !> \memberof psb_c_csr_sparse_mat
!| \see psb_base_mat_mod::psb_base_allocate_mnnz !| \see psb_base_mat_mod::psb_base_allocate_mnnz

10
base/modules/psb_c_mat_mod.f90
Unescape Escape View File

@ -154,6 +154,7 @@ module psb_c_mat_mod
procedure, pass(a) :: cscnv_ip => psb_c_cscnv_ip procedure, pass(a) :: cscnv_ip => psb_c_cscnv_ip
procedure, pass(a) :: cscnv_base => psb_c_cscnv_base procedure, pass(a) :: cscnv_base => psb_c_cscnv_base
generic, public :: cscnv => cscnv_np, cscnv_ip, 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 procedure, pass(a) :: clone => psb_cspmat_clone
! Computational routines ! Computational routines
@ -609,6 +610,15 @@ module psb_c_mat_mod
end subroutine psb_cspmat_type_move end subroutine psb_cspmat_type_move
end interface 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 interface
subroutine psb_cspmat_clone(a,b,info) subroutine psb_cspmat_clone(a,b,info)
import :: psb_ipk_, psb_cspmat_type import :: psb_ipk_, psb_cspmat_type

99
base/modules/psb_d_base_mat_mod.f90
Unescape Escape View File

@ -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_from_coo => psb_d_base_mv_from_coo
procedure, pass(a) :: mv_to_fmt => psb_d_base_mv_to_fmt 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) :: 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) :: mold => psb_d_base_mold
procedure, pass(a) :: copy => psb_d_base_copy
procedure, pass(a) :: clone => psb_d_base_clone 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 procedure, pass(a) :: aclsum => psb_d_base_aclsum
end type psb_d_base_sparse_mat 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 !> \namespace psb_base_mod \class psb_d_coo_sparse_mat
!! \extends psb_d_base_mat_mod::psb_d_base_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) :: print => psb_d_coo_print
procedure, pass(a) :: free => d_coo_free procedure, pass(a) :: free => d_coo_free
procedure, pass(a) :: mold => psb_d_coo_mold procedure, pass(a) :: mold => psb_d_coo_mold
procedure, pass(a) :: psb_d_coo_cp_from procedure, pass(a) :: copy => psb_d_coo_copy
generic, public :: cp_from => psb_d_coo_cp_from !!$ procedure, pass(a) :: clone => psb_d_coo_clone
procedure, pass(a) :: psb_d_coo_mv_from
generic, public :: mv_from => psb_d_coo_mv_from
! !
! This is COO specific ! This is COO specific
! !
@ -413,11 +405,30 @@ module psb_d_base_mat_mod
subroutine psb_d_base_mold(a,b,info) subroutine psb_d_base_mold(a,b,info)
import :: psb_ipk_, psb_d_base_sparse_mat, psb_long_int_k_ 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(in) :: a
class(psb_d_base_sparse_mat), intent(out), allocatable :: b class(psb_d_base_sparse_mat), intent(inout), allocatable :: b
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
end subroutine psb_d_base_mold end subroutine psb_d_base_mold
end interface 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: !> Function clone:
!! \memberof psb_d_base_sparse_mat !! \memberof psb_d_base_sparse_mat
@ -425,6 +436,8 @@ module psb_d_base_mat_mod
!! same dynamic type as the input. !! same dynamic type as the input.
!! This is equivalent to allocate( source= ) except that !! This is equivalent to allocate( source= ) except that
!! it should guarantee a deep copy wherever needed. !! 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 b The output variable
!! \param info return code !! \param info return code
! !
@ -1131,20 +1144,41 @@ module psb_d_base_mat_mod
end subroutine psb_d_coo_allocate_mnnz end subroutine psb_d_coo_allocate_mnnz
end interface end interface
!
!> !> \memberof psb_d_coo_sparse_mat
!! \memberof psb_d_coo_sparse_mat !| \see psb_base_mat_mod::psb_base_mold
!! \see psb_d_base_mat_mod::psb_d_base_mold
!
interface interface
subroutine psb_d_coo_mold(a,b,info) 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_ 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_coo_sparse_mat), intent(in) :: a
class(psb_d_base_sparse_mat), intent(out), allocatable :: b class(psb_d_base_sparse_mat), intent(inout), allocatable :: b
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
end subroutine psb_d_coo_mold end subroutine psb_d_coo_mold
end interface 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
! !
!> Function print. !> Function print.
@ -1585,35 +1619,6 @@ module psb_d_base_mat_mod
contains 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
! == ================================== ! == ==================================
! !

18
base/modules/psb_d_csc_mat_mod.f90
Unescape Escape View File

@ -97,10 +97,7 @@ module psb_d_csc_mat_mod
procedure, pass(a) :: print => psb_d_csc_print procedure, pass(a) :: print => psb_d_csc_print
procedure, pass(a) :: free => d_csc_free procedure, pass(a) :: free => d_csc_free
procedure, pass(a) :: mold => psb_d_csc_mold procedure, pass(a) :: mold => psb_d_csc_mold
procedure, pass(a) :: psb_d_csc_cp_from procedure, pass(a) :: copy => psb_d_csc_copy
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
end type psb_d_csc_sparse_mat end type psb_d_csc_sparse_mat
@ -142,11 +139,22 @@ module psb_d_csc_mat_mod
subroutine psb_d_csc_mold(a,b,info) 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_ 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_csc_sparse_mat), intent(in) :: a
class(psb_d_base_sparse_mat), intent(out), allocatable :: b class(psb_d_base_sparse_mat), intent(inout), allocatable :: b
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
end subroutine psb_d_csc_mold end subroutine psb_d_csc_mold
end interface 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 !> \memberof psb_d_csc_sparse_mat
!| \see psb_base_mat_mod::psb_base_allocate_mnnz !| \see psb_base_mat_mod::psb_base_allocate_mnnz

17
base/modules/psb_d_csr_mat_mod.f90
Unescape Escape View File

@ -98,10 +98,7 @@ module psb_d_csr_mat_mod
procedure, pass(a) :: print => psb_d_csr_print procedure, pass(a) :: print => psb_d_csr_print
procedure, pass(a) :: free => d_csr_free procedure, pass(a) :: free => d_csr_free
procedure, pass(a) :: mold => psb_d_csr_mold procedure, pass(a) :: mold => psb_d_csr_mold
procedure, pass(a) :: psb_d_csr_cp_from procedure, pass(a) :: copy => psb_d_csr_copy
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
end type psb_d_csr_sparse_mat end type psb_d_csr_sparse_mat
@ -144,11 +141,21 @@ module psb_d_csr_mat_mod
subroutine psb_d_csr_mold(a,b,info) 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_ 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_csr_sparse_mat), intent(in) :: a
class(psb_d_base_sparse_mat), intent(out), allocatable :: b class(psb_d_base_sparse_mat), intent(inout), allocatable :: b
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
end subroutine psb_d_csr_mold end subroutine psb_d_csr_mold
end interface 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 !> \memberof psb_d_csr_sparse_mat
!| \see psb_base_mat_mod::psb_base_allocate_mnnz !| \see psb_base_mat_mod::psb_base_allocate_mnnz

10
base/modules/psb_d_mat_mod.f90
Unescape Escape View File

@ -154,6 +154,7 @@ module psb_d_mat_mod
procedure, pass(a) :: cscnv_ip => psb_d_cscnv_ip procedure, pass(a) :: cscnv_ip => psb_d_cscnv_ip
procedure, pass(a) :: cscnv_base => psb_d_cscnv_base procedure, pass(a) :: cscnv_base => psb_d_cscnv_base
generic, public :: cscnv => cscnv_np, cscnv_ip, 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 procedure, pass(a) :: clone => psb_dspmat_clone
! Computational routines ! Computational routines
@ -609,6 +610,15 @@ module psb_d_mat_mod
end subroutine psb_dspmat_type_move end subroutine psb_dspmat_type_move
end interface 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 interface
subroutine psb_dspmat_clone(a,b,info) subroutine psb_dspmat_clone(a,b,info)
import :: psb_ipk_, psb_dspmat_type import :: psb_ipk_, psb_dspmat_type

20
base/modules/psb_i_comm_mod.f90
Unescape Escape View File

@ -115,16 +115,16 @@ module psb_i_comm_mod
interface psb_gather interface psb_gather
!!$ subroutine psb_isp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keeploc) !!$ subroutine psb_isp_allgather(globa, loca, desc_a, info, root, dupl,keepnum,keeploc)
! !$ use psb_desc_mod !!$ use psb_desc_mod
! !$ use psb_mat_mod !!$ use psb_mat_mod
! !$ implicit none !!$ implicit none
! !$ type(psb_ispmat_type), intent(inout) :: loca !!$ type(psb_ispmat_type), intent(inout) :: loca
! !$ type(psb_ispmat_type), intent(out) :: globa !!$ type(psb_ispmat_type), intent(out) :: globa
! !$ type(psb_desc_type), intent(in) :: desc_a !!$ type(psb_desc_type), intent(in) :: desc_a
! !$ integer(psb_ipk_), intent(out) :: info !!$ integer(psb_ipk_), intent(out) :: info
! !$ integer(psb_ipk_), intent(in), optional :: root,dupl !!$ integer(psb_ipk_), intent(in), optional :: root,dupl
! !$ logical, intent(in), optional :: keepnum,keeploc !!$ logical, intent(in), optional :: keepnum,keeploc
! !$ end subroutine psb_isp_allgather !!$ end subroutine psb_isp_allgather
subroutine psb_igatherm(globx, locx, desc_a, info, root) subroutine psb_igatherm(globx, locx, desc_a, info, root)
use psb_desc_mod use psb_desc_mod
integer(psb_ipk_), intent(in) :: locx(:,:) integer(psb_ipk_), intent(in) :: locx(:,:)

99
base/modules/psb_s_base_mat_mod.f90
Unescape Escape View File

@ -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_from_coo => psb_s_base_mv_from_coo
procedure, pass(a) :: mv_to_fmt => psb_s_base_mv_to_fmt 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) :: 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) :: mold => psb_s_base_mold
procedure, pass(a) :: copy => psb_s_base_copy
procedure, pass(a) :: clone => psb_s_base_clone 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 procedure, pass(a) :: aclsum => psb_s_base_aclsum
end type psb_s_base_sparse_mat 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 !> \namespace psb_base_mod \class psb_s_coo_sparse_mat
!! \extends psb_s_base_mat_mod::psb_s_base_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) :: print => psb_s_coo_print
procedure, pass(a) :: free => s_coo_free procedure, pass(a) :: free => s_coo_free
procedure, pass(a) :: mold => psb_s_coo_mold procedure, pass(a) :: mold => psb_s_coo_mold
procedure, pass(a) :: psb_s_coo_cp_from procedure, pass(a) :: copy => psb_s_coo_copy
generic, public :: cp_from => psb_s_coo_cp_from !!$ procedure, pass(a) :: clone => psb_s_coo_clone
procedure, pass(a) :: psb_s_coo_mv_from
generic, public :: mv_from => psb_s_coo_mv_from
! !
! This is COO specific ! This is COO specific
! !
@ -413,11 +405,30 @@ module psb_s_base_mat_mod
subroutine psb_s_base_mold(a,b,info) subroutine psb_s_base_mold(a,b,info)
import :: psb_ipk_, psb_s_base_sparse_mat, psb_long_int_k_ 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(in) :: a
class(psb_s_base_sparse_mat), intent(out), allocatable :: b class(psb_s_base_sparse_mat), intent(inout), allocatable :: b
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
end subroutine psb_s_base_mold end subroutine psb_s_base_mold
end interface 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: !> Function clone:
!! \memberof psb_s_base_sparse_mat !! \memberof psb_s_base_sparse_mat
@ -425,6 +436,8 @@ module psb_s_base_mat_mod
!! same dynamic type as the input. !! same dynamic type as the input.
!! This is equivalent to allocate( source= ) except that !! This is equivalent to allocate( source= ) except that
!! it should guarantee a deep copy wherever needed. !! 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 b The output variable
!! \param info return code !! \param info return code
! !
@ -1131,20 +1144,41 @@ module psb_s_base_mat_mod
end subroutine psb_s_coo_allocate_mnnz end subroutine psb_s_coo_allocate_mnnz
end interface end interface
!
!> !> \memberof psb_s_coo_sparse_mat
!! \memberof psb_s_coo_sparse_mat !| \see psb_base_mat_mod::psb_base_mold
!! \see psb_s_base_mat_mod::psb_s_base_mold
!
interface interface
subroutine psb_s_coo_mold(a,b,info) 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_ 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_coo_sparse_mat), intent(in) :: a
class(psb_s_base_sparse_mat), intent(out), allocatable :: b class(psb_s_base_sparse_mat), intent(inout), allocatable :: b
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
end subroutine psb_s_coo_mold end subroutine psb_s_coo_mold
end interface 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
! !
!> Function print. !> Function print.
@ -1585,35 +1619,6 @@ module psb_s_base_mat_mod
contains 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
! == ================================== ! == ==================================
! !

18
base/modules/psb_s_csc_mat_mod.f90
Unescape Escape View File

@ -97,10 +97,7 @@ module psb_s_csc_mat_mod
procedure, pass(a) :: print => psb_s_csc_print procedure, pass(a) :: print => psb_s_csc_print
procedure, pass(a) :: free => s_csc_free procedure, pass(a) :: free => s_csc_free
procedure, pass(a) :: mold => psb_s_csc_mold procedure, pass(a) :: mold => psb_s_csc_mold
procedure, pass(a) :: psb_s_csc_cp_from procedure, pass(a) :: copy => psb_s_csc_copy
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
end type psb_s_csc_sparse_mat end type psb_s_csc_sparse_mat
@ -142,11 +139,22 @@ module psb_s_csc_mat_mod
subroutine psb_s_csc_mold(a,b,info) 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_ 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_csc_sparse_mat), intent(in) :: a
class(psb_s_base_sparse_mat), intent(out), allocatable :: b class(psb_s_base_sparse_mat), intent(inout), allocatable :: b
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
end subroutine psb_s_csc_mold end subroutine psb_s_csc_mold
end interface 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 !> \memberof psb_s_csc_sparse_mat
!| \see psb_base_mat_mod::psb_base_allocate_mnnz !| \see psb_base_mat_mod::psb_base_allocate_mnnz

17
base/modules/psb_s_csr_mat_mod.f90
Unescape Escape View File

@ -98,10 +98,7 @@ module psb_s_csr_mat_mod
procedure, pass(a) :: print => psb_s_csr_print procedure, pass(a) :: print => psb_s_csr_print
procedure, pass(a) :: free => s_csr_free procedure, pass(a) :: free => s_csr_free
procedure, pass(a) :: mold => psb_s_csr_mold procedure, pass(a) :: mold => psb_s_csr_mold
procedure, pass(a) :: psb_s_csr_cp_from procedure, pass(a) :: copy => psb_s_csr_copy
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
end type psb_s_csr_sparse_mat end type psb_s_csr_sparse_mat
@ -144,11 +141,21 @@ module psb_s_csr_mat_mod
subroutine psb_s_csr_mold(a,b,info) 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_ 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_csr_sparse_mat), intent(in) :: a
class(psb_s_base_sparse_mat), intent(out), allocatable :: b class(psb_s_base_sparse_mat), intent(inout), allocatable :: b
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
end subroutine psb_s_csr_mold end subroutine psb_s_csr_mold
end interface 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 !> \memberof psb_s_csr_sparse_mat
!| \see psb_base_mat_mod::psb_base_allocate_mnnz !| \see psb_base_mat_mod::psb_base_allocate_mnnz

10
base/modules/psb_s_mat_mod.f90
Unescape Escape View File

@ -154,6 +154,7 @@ module psb_s_mat_mod
procedure, pass(a) :: cscnv_ip => psb_s_cscnv_ip procedure, pass(a) :: cscnv_ip => psb_s_cscnv_ip
procedure, pass(a) :: cscnv_base => psb_s_cscnv_base procedure, pass(a) :: cscnv_base => psb_s_cscnv_base
generic, public :: cscnv => cscnv_np, cscnv_ip, 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 procedure, pass(a) :: clone => psb_sspmat_clone
! Computational routines ! Computational routines
@ -609,6 +610,15 @@ module psb_s_mat_mod
end subroutine psb_sspmat_type_move end subroutine psb_sspmat_type_move
end interface 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 interface
subroutine psb_sspmat_clone(a,b,info) subroutine psb_sspmat_clone(a,b,info)
import :: psb_ipk_, psb_sspmat_type import :: psb_ipk_, psb_sspmat_type

99
base/modules/psb_z_base_mat_mod.f90
Unescape Escape View File

@ -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_from_coo => psb_z_base_mv_from_coo
procedure, pass(a) :: mv_to_fmt => psb_z_base_mv_to_fmt 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) :: 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) :: mold => psb_z_base_mold
procedure, pass(a) :: copy => psb_z_base_copy
procedure, pass(a) :: clone => psb_z_base_clone 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 procedure, pass(a) :: aclsum => psb_z_base_aclsum
end type psb_z_base_sparse_mat 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 !> \namespace psb_base_mod \class psb_z_coo_sparse_mat
!! \extends psb_z_base_mat_mod::psb_z_base_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) :: print => psb_z_coo_print
procedure, pass(a) :: free => z_coo_free procedure, pass(a) :: free => z_coo_free
procedure, pass(a) :: mold => psb_z_coo_mold procedure, pass(a) :: mold => psb_z_coo_mold
procedure, pass(a) :: psb_z_coo_cp_from procedure, pass(a) :: copy => psb_z_coo_copy
generic, public :: cp_from => psb_z_coo_cp_from !!$ procedure, pass(a) :: clone => psb_z_coo_clone
procedure, pass(a) :: psb_z_coo_mv_from
generic, public :: mv_from => psb_z_coo_mv_from
! !
! This is COO specific ! This is COO specific
! !
@ -413,11 +405,30 @@ module psb_z_base_mat_mod
subroutine psb_z_base_mold(a,b,info) subroutine psb_z_base_mold(a,b,info)
import :: psb_ipk_, psb_z_base_sparse_mat, psb_long_int_k_ 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(in) :: a
class(psb_z_base_sparse_mat), intent(out), allocatable :: b class(psb_z_base_sparse_mat), intent(inout), allocatable :: b
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
end subroutine psb_z_base_mold end subroutine psb_z_base_mold
end interface 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: !> Function clone:
!! \memberof psb_z_base_sparse_mat !! \memberof psb_z_base_sparse_mat
@ -425,6 +436,8 @@ module psb_z_base_mat_mod
!! same dynamic type as the input. !! same dynamic type as the input.
!! This is equivalent to allocate( source= ) except that !! This is equivalent to allocate( source= ) except that
!! it should guarantee a deep copy wherever needed. !! 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 b The output variable
!! \param info return code !! \param info return code
! !
@ -1131,20 +1144,41 @@ module psb_z_base_mat_mod
end subroutine psb_z_coo_allocate_mnnz end subroutine psb_z_coo_allocate_mnnz
end interface end interface
!
!> !> \memberof psb_z_coo_sparse_mat
!! \memberof psb_z_coo_sparse_mat !| \see psb_base_mat_mod::psb_base_mold
!! \see psb_z_base_mat_mod::psb_z_base_mold
!
interface interface
subroutine psb_z_coo_mold(a,b,info) 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_ 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_coo_sparse_mat), intent(in) :: a
class(psb_z_base_sparse_mat), intent(out), allocatable :: b class(psb_z_base_sparse_mat), intent(inout), allocatable :: b
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
end subroutine psb_z_coo_mold end subroutine psb_z_coo_mold
end interface 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
! !
!> Function print. !> Function print.
@ -1585,35 +1619,6 @@ module psb_z_base_mat_mod
contains 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
! == ================================== ! == ==================================
! !

18
base/modules/psb_z_csc_mat_mod.f90
Unescape Escape View File

@ -97,10 +97,7 @@ module psb_z_csc_mat_mod
procedure, pass(a) :: print => psb_z_csc_print procedure, pass(a) :: print => psb_z_csc_print
procedure, pass(a) :: free => z_csc_free procedure, pass(a) :: free => z_csc_free
procedure, pass(a) :: mold => psb_z_csc_mold procedure, pass(a) :: mold => psb_z_csc_mold
procedure, pass(a) :: psb_z_csc_cp_from procedure, pass(a) :: copy => psb_z_csc_copy
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
end type psb_z_csc_sparse_mat end type psb_z_csc_sparse_mat
@ -142,11 +139,22 @@ module psb_z_csc_mat_mod
subroutine psb_z_csc_mold(a,b,info) 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_ 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_csc_sparse_mat), intent(in) :: a
class(psb_z_base_sparse_mat), intent(out), allocatable :: b class(psb_z_base_sparse_mat), intent(inout), allocatable :: b
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
end subroutine psb_z_csc_mold end subroutine psb_z_csc_mold
end interface 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 !> \memberof psb_z_csc_sparse_mat
!| \see psb_base_mat_mod::psb_base_allocate_mnnz !| \see psb_base_mat_mod::psb_base_allocate_mnnz

17
base/modules/psb_z_csr_mat_mod.f90
Unescape Escape View File

@ -98,10 +98,7 @@ module psb_z_csr_mat_mod
procedure, pass(a) :: print => psb_z_csr_print procedure, pass(a) :: print => psb_z_csr_print
procedure, pass(a) :: free => z_csr_free procedure, pass(a) :: free => z_csr_free
procedure, pass(a) :: mold => psb_z_csr_mold procedure, pass(a) :: mold => psb_z_csr_mold
procedure, pass(a) :: psb_z_csr_cp_from procedure, pass(a) :: copy => psb_z_csr_copy
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
end type psb_z_csr_sparse_mat end type psb_z_csr_sparse_mat
@ -144,11 +141,21 @@ module psb_z_csr_mat_mod
subroutine psb_z_csr_mold(a,b,info) 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_ 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_csr_sparse_mat), intent(in) :: a
class(psb_z_base_sparse_mat), intent(out), allocatable :: b class(psb_z_base_sparse_mat), intent(inout), allocatable :: b
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
end subroutine psb_z_csr_mold end subroutine psb_z_csr_mold
end interface 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 !> \memberof psb_z_csr_sparse_mat
!| \see psb_base_mat_mod::psb_base_allocate_mnnz !| \see psb_base_mat_mod::psb_base_allocate_mnnz

10
base/modules/psb_z_mat_mod.f90
Unescape Escape View File

@ -154,6 +154,7 @@ module psb_z_mat_mod
procedure, pass(a) :: cscnv_ip => psb_z_cscnv_ip procedure, pass(a) :: cscnv_ip => psb_z_cscnv_ip
procedure, pass(a) :: cscnv_base => psb_z_cscnv_base procedure, pass(a) :: cscnv_base => psb_z_cscnv_base
generic, public :: cscnv => cscnv_np, cscnv_ip, 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 procedure, pass(a) :: clone => psb_zspmat_clone
! Computational routines ! Computational routines
@ -609,6 +610,15 @@ module psb_z_mat_mod
end subroutine psb_zspmat_type_move end subroutine psb_zspmat_type_move
end interface 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 interface
subroutine psb_zspmat_clone(a,b,info) subroutine psb_zspmat_clone(a,b,info)
import :: psb_ipk_, psb_zspmat_type import :: psb_ipk_, psb_zspmat_type

41
base/serial/impl/psb_c_base_mat_impl.F90
Unescape Escape View File

@ -585,11 +585,11 @@ subroutine psb_c_base_mold(a,b,info)
use psb_error_mod use psb_error_mod
implicit none implicit none
class(psb_c_base_sparse_mat), intent(in) :: a 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(inout), allocatable :: b
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5) integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='reallocate_nz' character(len=20) :: name='base_mold'
logical, parameter :: debug=.false. logical, parameter :: debug=.false.
call psb_get_erraction(err_act) call psb_get_erraction(err_act)
@ -606,6 +606,43 @@ subroutine psb_c_base_mold(a,b,info)
end subroutine psb_c_base_mold 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) subroutine psb_c_base_transp_2mat(a,b)
use psb_c_base_mat_mod, psb_protect_name => psb_c_base_transp_2mat use psb_c_base_mat_mod, psb_protect_name => psb_c_base_transp_2mat
use psb_error_mod use psb_error_mod

61
base/serial/impl/psb_c_coo_impl.f90
Unescape Escape View File

@ -226,18 +226,23 @@ subroutine psb_c_coo_mold(a,b,info)
use psb_error_mod use psb_error_mod
implicit none implicit none
class(psb_c_coo_sparse_mat), intent(in) :: a class(psb_c_coo_sparse_mat), intent(in) :: a
class(psb_c_base_sparse_mat), intent(out), allocatable :: b class(psb_c_base_sparse_mat), intent(inout), allocatable :: b
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5) integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='reallocate_nz' character(len=20) :: name='coo_mold'
logical, parameter :: debug=.false. logical, parameter :: debug=.false.
call psb_get_erraction(err_act) 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_ info = psb_err_alloc_dealloc_
call psb_errpush(info, name) call psb_errpush(info, name)
goto 9999 goto 9999
@ -251,6 +256,45 @@ subroutine psb_c_coo_mold(a,b,info)
end subroutine psb_c_coo_mold 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) subroutine psb_c_coo_reinit(a,clear)
use psb_c_base_mat_mod, psb_protect_name => psb_c_coo_reinit 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) call psb_erractionsave(err_act)
info = psb_success_ 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() nz = a%get_nzeros()
call b%set_nzeros(nz) call b%set_nzeros(nz)
@ -2966,7 +3010,8 @@ subroutine psb_c_cp_coo_from_coo(a,b,info)
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
info = psb_success_ 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() nz = b%get_nzeros()
call a%set_nzeros(nz) call a%set_nzeros(nz)
call a%reallocate(nz) call a%reallocate(nz)
@ -3085,7 +3130,7 @@ subroutine psb_c_mv_coo_to_coo(a,b,info)
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
info = psb_success_ 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%set_nzeros(a%get_nzeros())
call b%reallocate(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) call psb_erractionsave(err_act)
info = psb_success_ 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%set_nzeros(b%get_nzeros())
call a%reallocate(b%get_nzeros()) call a%reallocate(b%get_nzeros())

235
base/serial/impl/psb_c_csc_impl.f90
Unescape Escape View File

@ -2263,7 +2263,7 @@ subroutine psb_c_cp_csc_to_coo(a,b,info)
nza = a%get_nzeros() nza = a%get_nzeros()
call b%allocate(nr,nc,nza) 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 i=1, nc
do j=a%icp(i),a%icp(i+1)-1 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() nc = a%get_ncols()
nza = a%get_nzeros() 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 b%set_nzeros(a%get_nzeros())
call move_alloc(a%ia,b%ia) call move_alloc(a%ia,b%ia)
call move_alloc(a%val,b%val) 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() nc = b%get_ncols()
nza = b%get_nzeros() 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. ! Dirty trick: call move_alloc to have the new data allocated just once.
call move_alloc(b%ja,itemp) 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) call a%mv_to_coo(b,info)
! Need to fix trivial copies! ! Need to fix trivial copies!
type is (psb_c_csc_sparse_mat) 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%icp, b%icp)
call move_alloc(a%ia, b%ia) call move_alloc(a%ia, b%ia)
call move_alloc(a%val, b%val) 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) call a%cp_to_coo(b,info)
type is (psb_c_csc_sparse_mat) type is (psb_c_csc_sparse_mat)
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)
call psb_safe_cpy( a%icp, b%icp , info) if (info == 0) call psb_safe_cpy( a%icp, b%icp , info)
call psb_safe_cpy( a%ia , b%ia , info) if (info == 0) call psb_safe_cpy( a%ia , b%ia , info)
call psb_safe_cpy( a%val, b%val , info) if (info == 0) call psb_safe_cpy( a%val, b%val , info)
class default class default
call a%cp_to_coo(tmp,info) 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) call a%mv_from_coo(b,info)
type is (psb_c_csc_sparse_mat) 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%icp, a%icp)
call move_alloc(b%ia, a%ia) call move_alloc(b%ia, a%ia)
call move_alloc(b%val, a%val) 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) call a%cp_from_coo(b,info)
type is (psb_c_csc_sparse_mat) type is (psb_c_csc_sparse_mat)
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)
call psb_safe_cpy( b%icp, a%icp , info) if (info == 0) call psb_safe_cpy( b%icp, a%icp , info)
call psb_safe_cpy( b%ia , a%ia , info) if (info == 0) call psb_safe_cpy( b%ia , a%ia , info)
call psb_safe_cpy( b%val, a%val , info) if (info == 0) call psb_safe_cpy( b%val, a%val , info)
class default class default
call b%cp_to_coo(tmp,info) call b%cp_to_coo(tmp,info)
if (info == psb_success_) call a%mv_from_coo(tmp,info) if (info == psb_success_) call a%mv_from_coo(tmp,info)
end select end select
end subroutine psb_c_cp_csc_from_fmt end subroutine psb_c_cp_csc_from_fmt
subroutine psb_c_csc_mold(a,b,info) subroutine psb_c_csc_mold(a,b,info)
use psb_c_csc_mat_mod, psb_protect_name => psb_c_csc_mold use psb_c_csc_mat_mod, psb_protect_name => psb_c_csc_mold
use psb_error_mod use psb_error_mod
implicit none implicit none
class(psb_c_csc_sparse_mat), intent(in) :: a class(psb_c_csc_sparse_mat), intent(in) :: a
class(psb_c_base_sparse_mat), intent(out), allocatable :: b class(psb_c_base_sparse_mat), intent(inout), allocatable :: b
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5) integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='reallocate_nz' character(len=20) :: name='csc_mold'
logical, parameter :: debug=.false. logical, parameter :: debug=.false.
call psb_get_erraction(err_act) 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_ info = psb_err_alloc_dealloc_
call psb_errpush(info, name) call psb_errpush(info, name)
goto 9999 goto 9999
@ -2605,6 +2612,44 @@ subroutine psb_c_csc_mold(a,b,info)
end subroutine psb_c_csc_mold 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) subroutine psb_c_csc_reallocate_nz(nz,a)
use psb_error_mod 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 end subroutine psb_c_csc_print
subroutine psb_c_csc_cp_from(a,b) !!$subroutine psb_c_csc_cp_from(a,b)
use psb_error_mod !!$ use psb_error_mod
use psb_realloc_mod !!$ use psb_realloc_mod
use psb_c_csc_mat_mod, psb_protect_name => psb_c_csc_cp_from !!$ use psb_c_csc_mat_mod, psb_protect_name => psb_c_csc_cp_from
implicit none !!$ implicit none
!!$
class(psb_c_csc_sparse_mat), intent(inout) :: a !!$ class(psb_c_csc_sparse_mat), intent(inout) :: a
type(psb_c_csc_sparse_mat), intent(in) :: b !!$ type(psb_c_csc_sparse_mat), intent(in) :: b
!!$
!!$
integer(psb_ipk_) :: err_act, info !!$ integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5) !!$ integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='cp_from' !!$ character(len=20) :: name='cp_from'
logical, parameter :: debug=.false. !!$ logical, parameter :: debug=.false.
!!$
call psb_erractionsave(err_act) !!$ call psb_erractionsave(err_act)
!!$
info = psb_success_ !!$ info = psb_success_
!!$
call a%allocate(b%get_nrows(),b%get_ncols(),b%get_nzeros()) !!$ 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 b%psb_c_base_sparse_mat%copy(a%psb_c_base_sparse_mat, info)
call psb_safe_cpy( b%icp, a%icp , info) !!$ if (info == 0) call psb_safe_cpy( b%icp, a%icp , info)
call psb_safe_cpy( b%ia , a%ia , info) !!$ if (info == 0) call psb_safe_cpy( b%ia , a%ia , info)
call psb_safe_cpy( b%val, a%val , info) !!$ if (info == 0) call psb_safe_cpy( b%val, a%val , info)
!!$
if (info /= psb_success_) goto 9999 !!$ if (info /= psb_success_) goto 9999
call psb_erractionrestore(err_act) !!$ call psb_erractionrestore(err_act)
return !!$ return
!!$
9999 continue !!$9999 continue
call psb_erractionrestore(err_act) !!$ call psb_erractionrestore(err_act)
!!$
call psb_errpush(info,name) !!$ call psb_errpush(info,name)
!!$
if (err_act /= psb_act_ret_) then !!$ if (err_act /= psb_act_ret_) then
call psb_error() !!$ call psb_error()
end if !!$ end if
return !!$ return
!!$
end subroutine psb_c_csc_cp_from !!$end subroutine psb_c_csc_cp_from
!!$
subroutine psb_c_csc_mv_from(a,b) !!$subroutine psb_c_csc_mv_from(a,b)
use psb_error_mod !!$ use psb_error_mod
use psb_c_csc_mat_mod, psb_protect_name => psb_c_csc_mv_from !!$ use psb_c_csc_mat_mod, psb_protect_name => psb_c_csc_mv_from
implicit none !!$ implicit none
!!$
class(psb_c_csc_sparse_mat), intent(inout) :: a !!$ class(psb_c_csc_sparse_mat), intent(inout) :: a
type(psb_c_csc_sparse_mat), intent(inout) :: b !!$ type(psb_c_csc_sparse_mat), intent(inout) :: b
!!$
!!$
integer(psb_ipk_) :: err_act, info !!$ integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5) !!$ integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='mv_from' !!$ character(len=20) :: name='mv_from'
logical, parameter :: debug=.false. !!$ logical, parameter :: debug=.false.
!!$
call psb_erractionsave(err_act) !!$ call psb_erractionsave(err_act)
info = psb_success_ !!$ 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 move_alloc(b%icp, a%icp) !!$ if (info == 0) call move_alloc(b%icp, a%icp)
call move_alloc(b%ia, a%ia) !!$ if (info == 0) call move_alloc(b%ia, a%ia)
call move_alloc(b%val, a%val) !!$ if (info == 0) call move_alloc(b%val, a%val)
call b%free() !!$ call b%free()
!!$
call psb_erractionrestore(err_act) !!$ call psb_erractionrestore(err_act)
return !!$ return
!!$
9999 continue !!$9999 continue
call psb_erractionrestore(err_act) !!$ call psb_erractionrestore(err_act)
!!$
call psb_errpush(info,name) !!$ call psb_errpush(info,name)
!!$
if (err_act /= psb_act_ret_) then !!$ if (err_act /= psb_act_ret_) then
call psb_error() !!$ call psb_error()
end if !!$ end if
return !!$ return
!!$
end subroutine psb_c_csc_mv_from !!$end subroutine psb_c_csc_mv_from
!!$

238
base/serial/impl/psb_c_csr_impl.f90
Unescape Escape View File

@ -1786,18 +1786,23 @@ subroutine psb_c_csr_mold(a,b,info)
use psb_error_mod use psb_error_mod
implicit none implicit none
class(psb_c_csr_sparse_mat), intent(in) :: a class(psb_c_csr_sparse_mat), intent(in) :: a
class(psb_c_base_sparse_mat), intent(out), allocatable :: b class(psb_c_base_sparse_mat), intent(inout), allocatable :: b
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5) integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='reallocate_nz' character(len=20) :: name='csr_mold'
logical, parameter :: debug=.false. logical, parameter :: debug=.false.
call psb_get_erraction(err_act) 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_ info = psb_err_alloc_dealloc_
call psb_errpush(info, name) call psb_errpush(info, name)
goto 9999 goto 9999
@ -1811,6 +1816,45 @@ subroutine psb_c_csr_mold(a,b,info)
end subroutine psb_c_csr_mold 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) subroutine psb_c_csr_allocate_mnnz(m,n,a,nz)
use psb_error_mod use psb_error_mod
use psb_realloc_mod use psb_realloc_mod
@ -2799,7 +2843,7 @@ subroutine psb_c_cp_csr_to_coo(a,b,info)
nza = a%get_nzeros() nza = a%get_nzeros()
call b%allocate(nr,nc,nza) 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 i=1, nr
do j=a%irp(i),a%irp(i+1)-1 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() nc = a%get_ncols()
nza = a%get_nzeros() 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 b%set_nzeros(a%get_nzeros())
call move_alloc(a%ja,b%ja) call move_alloc(a%ja,b%ja)
call move_alloc(a%val,b%val) 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() nc = b%get_ncols()
nza = b%get_nzeros() 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. ! Dirty trick: call move_alloc to have the new data allocated just once.
call move_alloc(b%ia,itemp) 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) call a%mv_to_coo(b,info)
! Need to fix trivial copies! ! Need to fix trivial copies!
type is (psb_c_csr_sparse_mat) 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%irp, b%irp)
call move_alloc(a%ja, b%ja) call move_alloc(a%ja, b%ja)
call move_alloc(a%val, b%val) 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) call a%cp_to_coo(b,info)
type is (psb_c_csr_sparse_mat) type is (psb_c_csr_sparse_mat)
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)
call psb_safe_cpy( a%irp, b%irp , info) if (info == 0) call psb_safe_cpy( a%irp, b%irp , info)
call psb_safe_cpy( a%ja , b%ja , info) if (info == 0) call psb_safe_cpy( a%ja , b%ja , info)
call psb_safe_cpy( a%val, b%val , info) if (info == 0) call psb_safe_cpy( a%val, b%val , info)
class default class default
call a%cp_to_coo(tmp,info) 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) call a%mv_from_coo(b,info)
type is (psb_c_csr_sparse_mat) 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%irp, a%irp)
call move_alloc(b%ja, a%ja) call move_alloc(b%ja, a%ja)
call move_alloc(b%val, a%val) 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) call a%cp_from_coo(b,info)
type is (psb_c_csr_sparse_mat) type is (psb_c_csr_sparse_mat)
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)
call psb_safe_cpy( b%irp, a%irp , info) if (info == 0) call psb_safe_cpy( b%irp, a%irp , info)
call psb_safe_cpy( b%ja , a%ja , info) if (info == 0) call psb_safe_cpy( b%ja , a%ja , info)
call psb_safe_cpy( b%val, a%val , info) if (info == 0) call psb_safe_cpy( b%val, a%val , info)
class default class default
call b%cp_to_coo(tmp,info) call b%cp_to_coo(tmp,info)
@ -3109,83 +3153,83 @@ subroutine psb_c_cp_csr_from_fmt(a,b,info)
end select end select
end subroutine psb_c_cp_csr_from_fmt end subroutine psb_c_cp_csr_from_fmt
!!$
subroutine psb_c_csr_cp_from(a,b) !!$subroutine psb_c_csr_cp_from(a,b)
use psb_error_mod !!$ use psb_error_mod
use psb_realloc_mod !!$ use psb_realloc_mod
use psb_c_csr_mat_mod, psb_protect_name => psb_c_csr_cp_from !!$ use psb_c_csr_mat_mod, psb_protect_name => psb_c_csr_cp_from
implicit none !!$ implicit none
!!$
class(psb_c_csr_sparse_mat), intent(inout) :: a !!$ class(psb_c_csr_sparse_mat), intent(inout) :: a
type(psb_c_csr_sparse_mat), intent(in) :: b !!$ type(psb_c_csr_sparse_mat), intent(in) :: b
!!$
!!$
integer(psb_ipk_) :: err_act, info !!$ integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5) !!$ integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='cp_from' !!$ character(len=20) :: name='cp_from'
logical, parameter :: debug=.false. !!$ logical, parameter :: debug=.false.
!!$
call psb_erractionsave(err_act) !!$ call psb_erractionsave(err_act)
!!$
info = psb_success_ !!$ info = psb_success_
!!$
call a%allocate(b%get_nrows(),b%get_ncols(),b%get_nzeros()) !!$ 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 b%psb_c_base_sparse_mat%copy(a%psb_c_base_sparse_mat, info)
call psb_safe_cpy( b%irp, a%irp , info) !!$ if (info == 0) call psb_safe_cpy( b%irp, a%irp , info)
call psb_safe_cpy( b%ja , a%ja , info) !!$ if (info == 0) call psb_safe_cpy( b%ja , a%ja , info)
call psb_safe_cpy( b%val, a%val , info) !!$ if (info == 0) call psb_safe_cpy( b%val, a%val , info)
!!$
if (info /= psb_success_) goto 9999 !!$ if (info /= psb_success_) goto 9999
call psb_erractionrestore(err_act) !!$ call psb_erractionrestore(err_act)
return !!$ return
!!$
9999 continue !!$9999 continue
call psb_erractionrestore(err_act) !!$ call psb_erractionrestore(err_act)
!!$
call psb_errpush(info,name) !!$ call psb_errpush(info,name)
!!$
if (err_act /= psb_act_ret_) then !!$ if (err_act /= psb_act_ret_) then
call psb_error() !!$ call psb_error()
end if !!$ end if
return !!$ return
!!$
end subroutine psb_c_csr_cp_from !!$end subroutine psb_c_csr_cp_from
!!$
subroutine psb_c_csr_mv_from(a,b) !!$subroutine psb_c_csr_mv_from(a,b)
use psb_error_mod !!$ use psb_error_mod
use psb_c_csr_mat_mod, psb_protect_name => psb_c_csr_mv_from !!$ use psb_c_csr_mat_mod, psb_protect_name => psb_c_csr_mv_from
implicit none !!$ implicit none
!!$
class(psb_c_csr_sparse_mat), intent(inout) :: a !!$ class(psb_c_csr_sparse_mat), intent(inout) :: a
type(psb_c_csr_sparse_mat), intent(inout) :: b !!$ type(psb_c_csr_sparse_mat), intent(inout) :: b
!!$
!!$
integer(psb_ipk_) :: err_act, info !!$ integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5) !!$ integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='mv_from' !!$ character(len=20) :: name='mv_from'
logical, parameter :: debug=.false. !!$ logical, parameter :: debug=.false.
!!$
call psb_erractionsave(err_act) !!$ call psb_erractionsave(err_act)
info = psb_success_ !!$ info = psb_success_
call a%psb_c_base_sparse_mat%mv_from(b%psb_c_base_sparse_mat) !!$ 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%irp, a%irp)
call move_alloc(b%ja, a%ja) !!$ call move_alloc(b%ja, a%ja)
call move_alloc(b%val, a%val) !!$ call move_alloc(b%val, a%val)
call b%free() !!$ call b%free()
!!$
call psb_erractionrestore(err_act) !!$ call psb_erractionrestore(err_act)
return !!$ return
!!$
9999 continue !!$9999 continue
call psb_erractionrestore(err_act) !!$ call psb_erractionrestore(err_act)
!!$
call psb_errpush(info,name) !!$ call psb_errpush(info,name)
!!$
if (err_act /= psb_act_ret_) then !!$ if (err_act /= psb_act_ret_) then
call psb_error() !!$ call psb_error()
end if !!$ end if
return !!$ return
!!$
end subroutine psb_c_csr_mv_from !!$end subroutine psb_c_csr_mv_from
!!$
!!$

35
base/serial/impl/psb_c_mat_impl.F90
Unescape Escape View File

@ -1574,6 +1574,41 @@ subroutine psb_cspmat_clone(a,b,info)
end subroutine psb_cspmat_clone 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) subroutine psb_c_transp_1mat(a)
use psb_error_mod use psb_error_mod

41
base/serial/impl/psb_d_base_mat_impl.F90
Unescape Escape View File

@ -585,11 +585,11 @@ subroutine psb_d_base_mold(a,b,info)
use psb_error_mod use psb_error_mod
implicit none implicit none
class(psb_d_base_sparse_mat), intent(in) :: a 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(inout), allocatable :: b
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5) integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='reallocate_nz' character(len=20) :: name='base_mold'
logical, parameter :: debug=.false. logical, parameter :: debug=.false.
call psb_get_erraction(err_act) call psb_get_erraction(err_act)
@ -606,6 +606,43 @@ subroutine psb_d_base_mold(a,b,info)
end subroutine psb_d_base_mold 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) subroutine psb_d_base_transp_2mat(a,b)
use psb_d_base_mat_mod, psb_protect_name => psb_d_base_transp_2mat use psb_d_base_mat_mod, psb_protect_name => psb_d_base_transp_2mat
use psb_error_mod use psb_error_mod

61
base/serial/impl/psb_d_coo_impl.f90
Unescape Escape View File

@ -226,18 +226,23 @@ subroutine psb_d_coo_mold(a,b,info)
use psb_error_mod use psb_error_mod
implicit none implicit none
class(psb_d_coo_sparse_mat), intent(in) :: a class(psb_d_coo_sparse_mat), intent(in) :: a
class(psb_d_base_sparse_mat), intent(out), allocatable :: b class(psb_d_base_sparse_mat), intent(inout), allocatable :: b
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5) integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='reallocate_nz' character(len=20) :: name='coo_mold'
logical, parameter :: debug=.false. logical, parameter :: debug=.false.
call psb_get_erraction(err_act) 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_ info = psb_err_alloc_dealloc_
call psb_errpush(info, name) call psb_errpush(info, name)
goto 9999 goto 9999
@ -251,6 +256,45 @@ subroutine psb_d_coo_mold(a,b,info)
end subroutine psb_d_coo_mold 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) subroutine psb_d_coo_reinit(a,clear)
use psb_d_base_mat_mod, psb_protect_name => psb_d_coo_reinit 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) call psb_erractionsave(err_act)
info = psb_success_ 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() nz = a%get_nzeros()
call b%set_nzeros(nz) call b%set_nzeros(nz)
@ -2966,7 +3010,8 @@ subroutine psb_d_cp_coo_from_coo(a,b,info)
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
info = psb_success_ 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() nz = b%get_nzeros()
call a%set_nzeros(nz) call a%set_nzeros(nz)
call a%reallocate(nz) call a%reallocate(nz)
@ -3085,7 +3130,7 @@ subroutine psb_d_mv_coo_to_coo(a,b,info)
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
info = psb_success_ 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%set_nzeros(a%get_nzeros())
call b%reallocate(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) call psb_erractionsave(err_act)
info = psb_success_ 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%set_nzeros(b%get_nzeros())
call a%reallocate(b%get_nzeros()) call a%reallocate(b%get_nzeros())

235
base/serial/impl/psb_d_csc_impl.f90
Unescape Escape View File

@ -2263,7 +2263,7 @@ subroutine psb_d_cp_csc_to_coo(a,b,info)
nza = a%get_nzeros() nza = a%get_nzeros()
call b%allocate(nr,nc,nza) 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 i=1, nc
do j=a%icp(i),a%icp(i+1)-1 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() nc = a%get_ncols()
nza = a%get_nzeros() 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 b%set_nzeros(a%get_nzeros())
call move_alloc(a%ia,b%ia) call move_alloc(a%ia,b%ia)
call move_alloc(a%val,b%val) 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() nc = b%get_ncols()
nza = b%get_nzeros() 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. ! Dirty trick: call move_alloc to have the new data allocated just once.
call move_alloc(b%ja,itemp) 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) call a%mv_to_coo(b,info)
! Need to fix trivial copies! ! Need to fix trivial copies!
type is (psb_d_csc_sparse_mat) 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%icp, b%icp)
call move_alloc(a%ia, b%ia) call move_alloc(a%ia, b%ia)
call move_alloc(a%val, b%val) 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) call a%cp_to_coo(b,info)
type is (psb_d_csc_sparse_mat) type is (psb_d_csc_sparse_mat)
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)
call psb_safe_cpy( a%icp, b%icp , info) if (info == 0) call psb_safe_cpy( a%icp, b%icp , info)
call psb_safe_cpy( a%ia , b%ia , info) if (info == 0) call psb_safe_cpy( a%ia , b%ia , info)
call psb_safe_cpy( a%val, b%val , info) if (info == 0) call psb_safe_cpy( a%val, b%val , info)
class default class default
call a%cp_to_coo(tmp,info) 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) call a%mv_from_coo(b,info)
type is (psb_d_csc_sparse_mat) 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%icp, a%icp)
call move_alloc(b%ia, a%ia) call move_alloc(b%ia, a%ia)
call move_alloc(b%val, a%val) 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) call a%cp_from_coo(b,info)
type is (psb_d_csc_sparse_mat) type is (psb_d_csc_sparse_mat)
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)
call psb_safe_cpy( b%icp, a%icp , info) if (info == 0) call psb_safe_cpy( b%icp, a%icp , info)
call psb_safe_cpy( b%ia , a%ia , info) if (info == 0) call psb_safe_cpy( b%ia , a%ia , info)
call psb_safe_cpy( b%val, a%val , info) if (info == 0) call psb_safe_cpy( b%val, a%val , info)
class default class default
call b%cp_to_coo(tmp,info) call b%cp_to_coo(tmp,info)
if (info == psb_success_) call a%mv_from_coo(tmp,info) if (info == psb_success_) call a%mv_from_coo(tmp,info)
end select end select
end subroutine psb_d_cp_csc_from_fmt end subroutine psb_d_cp_csc_from_fmt
subroutine psb_d_csc_mold(a,b,info) subroutine psb_d_csc_mold(a,b,info)
use psb_d_csc_mat_mod, psb_protect_name => psb_d_csc_mold use psb_d_csc_mat_mod, psb_protect_name => psb_d_csc_mold
use psb_error_mod use psb_error_mod
implicit none implicit none
class(psb_d_csc_sparse_mat), intent(in) :: a class(psb_d_csc_sparse_mat), intent(in) :: a
class(psb_d_base_sparse_mat), intent(out), allocatable :: b class(psb_d_base_sparse_mat), intent(inout), allocatable :: b
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5) integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='reallocate_nz' character(len=20) :: name='csc_mold'
logical, parameter :: debug=.false. logical, parameter :: debug=.false.
call psb_get_erraction(err_act) 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_ info = psb_err_alloc_dealloc_
call psb_errpush(info, name) call psb_errpush(info, name)
goto 9999 goto 9999
@ -2605,6 +2612,44 @@ subroutine psb_d_csc_mold(a,b,info)
end subroutine psb_d_csc_mold 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) subroutine psb_d_csc_reallocate_nz(nz,a)
use psb_error_mod 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 end subroutine psb_d_csc_print
subroutine psb_d_csc_cp_from(a,b) !!$subroutine psb_d_csc_cp_from(a,b)
use psb_error_mod !!$ use psb_error_mod
use psb_realloc_mod !!$ use psb_realloc_mod
use psb_d_csc_mat_mod, psb_protect_name => psb_d_csc_cp_from !!$ use psb_d_csc_mat_mod, psb_protect_name => psb_d_csc_cp_from
implicit none !!$ implicit none
!!$
class(psb_d_csc_sparse_mat), intent(inout) :: a !!$ class(psb_d_csc_sparse_mat), intent(inout) :: a
type(psb_d_csc_sparse_mat), intent(in) :: b !!$ type(psb_d_csc_sparse_mat), intent(in) :: b
!!$
!!$
integer(psb_ipk_) :: err_act, info !!$ integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5) !!$ integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='cp_from' !!$ character(len=20) :: name='cp_from'
logical, parameter :: debug=.false. !!$ logical, parameter :: debug=.false.
!!$
call psb_erractionsave(err_act) !!$ call psb_erractionsave(err_act)
!!$
info = psb_success_ !!$ info = psb_success_
!!$
call a%allocate(b%get_nrows(),b%get_ncols(),b%get_nzeros()) !!$ 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 b%psb_d_base_sparse_mat%copy(a%psb_d_base_sparse_mat, info)
call psb_safe_cpy( b%icp, a%icp , info) !!$ if (info == 0) call psb_safe_cpy( b%icp, a%icp , info)
call psb_safe_cpy( b%ia , a%ia , info) !!$ if (info == 0) call psb_safe_cpy( b%ia , a%ia , info)
call psb_safe_cpy( b%val, a%val , info) !!$ if (info == 0) call psb_safe_cpy( b%val, a%val , info)
!!$
if (info /= psb_success_) goto 9999 !!$ if (info /= psb_success_) goto 9999
call psb_erractionrestore(err_act) !!$ call psb_erractionrestore(err_act)
return !!$ return
!!$
9999 continue !!$9999 continue
call psb_erractionrestore(err_act) !!$ call psb_erractionrestore(err_act)
!!$
call psb_errpush(info,name) !!$ call psb_errpush(info,name)
!!$
if (err_act /= psb_act_ret_) then !!$ if (err_act /= psb_act_ret_) then
call psb_error() !!$ call psb_error()
end if !!$ end if
return !!$ return
!!$
end subroutine psb_d_csc_cp_from !!$end subroutine psb_d_csc_cp_from
!!$
subroutine psb_d_csc_mv_from(a,b) !!$subroutine psb_d_csc_mv_from(a,b)
use psb_error_mod !!$ use psb_error_mod
use psb_d_csc_mat_mod, psb_protect_name => psb_d_csc_mv_from !!$ use psb_d_csc_mat_mod, psb_protect_name => psb_d_csc_mv_from
implicit none !!$ implicit none
!!$
class(psb_d_csc_sparse_mat), intent(inout) :: a !!$ class(psb_d_csc_sparse_mat), intent(inout) :: a
type(psb_d_csc_sparse_mat), intent(inout) :: b !!$ type(psb_d_csc_sparse_mat), intent(inout) :: b
!!$
!!$
integer(psb_ipk_) :: err_act, info !!$ integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5) !!$ integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='mv_from' !!$ character(len=20) :: name='mv_from'
logical, parameter :: debug=.false. !!$ logical, parameter :: debug=.false.
!!$
call psb_erractionsave(err_act) !!$ call psb_erractionsave(err_act)
info = psb_success_ !!$ 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 move_alloc(b%icp, a%icp) !!$ if (info == 0) call move_alloc(b%icp, a%icp)
call move_alloc(b%ia, a%ia) !!$ if (info == 0) call move_alloc(b%ia, a%ia)
call move_alloc(b%val, a%val) !!$ if (info == 0) call move_alloc(b%val, a%val)
call b%free() !!$ call b%free()
!!$
call psb_erractionrestore(err_act) !!$ call psb_erractionrestore(err_act)
return !!$ return
!!$
9999 continue !!$9999 continue
call psb_erractionrestore(err_act) !!$ call psb_erractionrestore(err_act)
!!$
call psb_errpush(info,name) !!$ call psb_errpush(info,name)
!!$
if (err_act /= psb_act_ret_) then !!$ if (err_act /= psb_act_ret_) then
call psb_error() !!$ call psb_error()
end if !!$ end if
return !!$ return
!!$
end subroutine psb_d_csc_mv_from !!$end subroutine psb_d_csc_mv_from
!!$

238
base/serial/impl/psb_d_csr_impl.f90
Unescape Escape View File

@ -1786,18 +1786,23 @@ subroutine psb_d_csr_mold(a,b,info)
use psb_error_mod use psb_error_mod
implicit none implicit none
class(psb_d_csr_sparse_mat), intent(in) :: a class(psb_d_csr_sparse_mat), intent(in) :: a
class(psb_d_base_sparse_mat), intent(out), allocatable :: b class(psb_d_base_sparse_mat), intent(inout), allocatable :: b
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5) integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='reallocate_nz' character(len=20) :: name='csr_mold'
logical, parameter :: debug=.false. logical, parameter :: debug=.false.
call psb_get_erraction(err_act) 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_ info = psb_err_alloc_dealloc_
call psb_errpush(info, name) call psb_errpush(info, name)
goto 9999 goto 9999
@ -1811,6 +1816,45 @@ subroutine psb_d_csr_mold(a,b,info)
end subroutine psb_d_csr_mold 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) subroutine psb_d_csr_allocate_mnnz(m,n,a,nz)
use psb_error_mod use psb_error_mod
use psb_realloc_mod use psb_realloc_mod
@ -2799,7 +2843,7 @@ subroutine psb_d_cp_csr_to_coo(a,b,info)
nza = a%get_nzeros() nza = a%get_nzeros()
call b%allocate(nr,nc,nza) 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 i=1, nr
do j=a%irp(i),a%irp(i+1)-1 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() nc = a%get_ncols()
nza = a%get_nzeros() 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 b%set_nzeros(a%get_nzeros())
call move_alloc(a%ja,b%ja) call move_alloc(a%ja,b%ja)
call move_alloc(a%val,b%val) 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() nc = b%get_ncols()
nza = b%get_nzeros() 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. ! Dirty trick: call move_alloc to have the new data allocated just once.
call move_alloc(b%ia,itemp) 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) call a%mv_to_coo(b,info)
! Need to fix trivial copies! ! Need to fix trivial copies!
type is (psb_d_csr_sparse_mat) 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%irp, b%irp)
call move_alloc(a%ja, b%ja) call move_alloc(a%ja, b%ja)
call move_alloc(a%val, b%val) 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) call a%cp_to_coo(b,info)
type is (psb_d_csr_sparse_mat) type is (psb_d_csr_sparse_mat)
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)
call psb_safe_cpy( a%irp, b%irp , info) if (info == 0) call psb_safe_cpy( a%irp, b%irp , info)
call psb_safe_cpy( a%ja , b%ja , info) if (info == 0) call psb_safe_cpy( a%ja , b%ja , info)
call psb_safe_cpy( a%val, b%val , info) if (info == 0) call psb_safe_cpy( a%val, b%val , info)
class default class default
call a%cp_to_coo(tmp,info) 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) call a%mv_from_coo(b,info)
type is (psb_d_csr_sparse_mat) 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%irp, a%irp)
call move_alloc(b%ja, a%ja) call move_alloc(b%ja, a%ja)
call move_alloc(b%val, a%val) 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) call a%cp_from_coo(b,info)
type is (psb_d_csr_sparse_mat) type is (psb_d_csr_sparse_mat)
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)
call psb_safe_cpy( b%irp, a%irp , info) if (info == 0) call psb_safe_cpy( b%irp, a%irp , info)
call psb_safe_cpy( b%ja , a%ja , info) if (info == 0) call psb_safe_cpy( b%ja , a%ja , info)
call psb_safe_cpy( b%val, a%val , info) if (info == 0) call psb_safe_cpy( b%val, a%val , info)
class default class default
call b%cp_to_coo(tmp,info) call b%cp_to_coo(tmp,info)
@ -3109,83 +3153,83 @@ subroutine psb_d_cp_csr_from_fmt(a,b,info)
end select end select
end subroutine psb_d_cp_csr_from_fmt end subroutine psb_d_cp_csr_from_fmt
!!$
subroutine psb_d_csr_cp_from(a,b) !!$subroutine psb_d_csr_cp_from(a,b)
use psb_error_mod !!$ use psb_error_mod
use psb_realloc_mod !!$ use psb_realloc_mod
use psb_d_csr_mat_mod, psb_protect_name => psb_d_csr_cp_from !!$ use psb_d_csr_mat_mod, psb_protect_name => psb_d_csr_cp_from
implicit none !!$ implicit none
!!$
class(psb_d_csr_sparse_mat), intent(inout) :: a !!$ class(psb_d_csr_sparse_mat), intent(inout) :: a
type(psb_d_csr_sparse_mat), intent(in) :: b !!$ type(psb_d_csr_sparse_mat), intent(in) :: b
!!$
!!$
integer(psb_ipk_) :: err_act, info !!$ integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5) !!$ integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='cp_from' !!$ character(len=20) :: name='cp_from'
logical, parameter :: debug=.false. !!$ logical, parameter :: debug=.false.
!!$
call psb_erractionsave(err_act) !!$ call psb_erractionsave(err_act)
!!$
info = psb_success_ !!$ info = psb_success_
!!$
call a%allocate(b%get_nrows(),b%get_ncols(),b%get_nzeros()) !!$ 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 b%psb_d_base_sparse_mat%copy(a%psb_d_base_sparse_mat, info)
call psb_safe_cpy( b%irp, a%irp , info) !!$ if (info == 0) call psb_safe_cpy( b%irp, a%irp , info)
call psb_safe_cpy( b%ja , a%ja , info) !!$ if (info == 0) call psb_safe_cpy( b%ja , a%ja , info)
call psb_safe_cpy( b%val, a%val , info) !!$ if (info == 0) call psb_safe_cpy( b%val, a%val , info)
!!$
if (info /= psb_success_) goto 9999 !!$ if (info /= psb_success_) goto 9999
call psb_erractionrestore(err_act) !!$ call psb_erractionrestore(err_act)
return !!$ return
!!$
9999 continue !!$9999 continue
call psb_erractionrestore(err_act) !!$ call psb_erractionrestore(err_act)
!!$
call psb_errpush(info,name) !!$ call psb_errpush(info,name)
!!$
if (err_act /= psb_act_ret_) then !!$ if (err_act /= psb_act_ret_) then
call psb_error() !!$ call psb_error()
end if !!$ end if
return !!$ return
!!$
end subroutine psb_d_csr_cp_from !!$end subroutine psb_d_csr_cp_from
!!$
subroutine psb_d_csr_mv_from(a,b) !!$subroutine psb_d_csr_mv_from(a,b)
use psb_error_mod !!$ use psb_error_mod
use psb_d_csr_mat_mod, psb_protect_name => psb_d_csr_mv_from !!$ use psb_d_csr_mat_mod, psb_protect_name => psb_d_csr_mv_from
implicit none !!$ implicit none
!!$
class(psb_d_csr_sparse_mat), intent(inout) :: a !!$ class(psb_d_csr_sparse_mat), intent(inout) :: a
type(psb_d_csr_sparse_mat), intent(inout) :: b !!$ type(psb_d_csr_sparse_mat), intent(inout) :: b
!!$
!!$
integer(psb_ipk_) :: err_act, info !!$ integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5) !!$ integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='mv_from' !!$ character(len=20) :: name='mv_from'
logical, parameter :: debug=.false. !!$ logical, parameter :: debug=.false.
!!$
call psb_erractionsave(err_act) !!$ call psb_erractionsave(err_act)
info = psb_success_ !!$ info = psb_success_
call a%psb_d_base_sparse_mat%mv_from(b%psb_d_base_sparse_mat) !!$ 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%irp, a%irp)
call move_alloc(b%ja, a%ja) !!$ call move_alloc(b%ja, a%ja)
call move_alloc(b%val, a%val) !!$ call move_alloc(b%val, a%val)
call b%free() !!$ call b%free()
!!$
call psb_erractionrestore(err_act) !!$ call psb_erractionrestore(err_act)
return !!$ return
!!$
9999 continue !!$9999 continue
call psb_erractionrestore(err_act) !!$ call psb_erractionrestore(err_act)
!!$
call psb_errpush(info,name) !!$ call psb_errpush(info,name)
!!$
if (err_act /= psb_act_ret_) then !!$ if (err_act /= psb_act_ret_) then
call psb_error() !!$ call psb_error()
end if !!$ end if
return !!$ return
!!$
end subroutine psb_d_csr_mv_from !!$end subroutine psb_d_csr_mv_from
!!$
!!$

35
base/serial/impl/psb_d_mat_impl.F90
Unescape Escape View File

@ -1574,6 +1574,41 @@ subroutine psb_dspmat_clone(a,b,info)
end subroutine psb_dspmat_clone 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) subroutine psb_d_transp_1mat(a)
use psb_error_mod use psb_error_mod

41
base/serial/impl/psb_s_base_mat_impl.F90
Unescape Escape View File

@ -585,11 +585,11 @@ subroutine psb_s_base_mold(a,b,info)
use psb_error_mod use psb_error_mod
implicit none implicit none
class(psb_s_base_sparse_mat), intent(in) :: a 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(inout), allocatable :: b
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5) integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='reallocate_nz' character(len=20) :: name='base_mold'
logical, parameter :: debug=.false. logical, parameter :: debug=.false.
call psb_get_erraction(err_act) call psb_get_erraction(err_act)
@ -606,6 +606,43 @@ subroutine psb_s_base_mold(a,b,info)
end subroutine psb_s_base_mold 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) subroutine psb_s_base_transp_2mat(a,b)
use psb_s_base_mat_mod, psb_protect_name => psb_s_base_transp_2mat use psb_s_base_mat_mod, psb_protect_name => psb_s_base_transp_2mat
use psb_error_mod use psb_error_mod

61
base/serial/impl/psb_s_coo_impl.f90
Unescape Escape View File

@ -226,18 +226,23 @@ subroutine psb_s_coo_mold(a,b,info)
use psb_error_mod use psb_error_mod
implicit none implicit none
class(psb_s_coo_sparse_mat), intent(in) :: a class(psb_s_coo_sparse_mat), intent(in) :: a
class(psb_s_base_sparse_mat), intent(out), allocatable :: b class(psb_s_base_sparse_mat), intent(inout), allocatable :: b
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5) integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='reallocate_nz' character(len=20) :: name='coo_mold'
logical, parameter :: debug=.false. logical, parameter :: debug=.false.
call psb_get_erraction(err_act) 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_ info = psb_err_alloc_dealloc_
call psb_errpush(info, name) call psb_errpush(info, name)
goto 9999 goto 9999
@ -251,6 +256,45 @@ subroutine psb_s_coo_mold(a,b,info)
end subroutine psb_s_coo_mold 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) subroutine psb_s_coo_reinit(a,clear)
use psb_s_base_mat_mod, psb_protect_name => psb_s_coo_reinit 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) call psb_erractionsave(err_act)
info = psb_success_ 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() nz = a%get_nzeros()
call b%set_nzeros(nz) call b%set_nzeros(nz)
@ -2966,7 +3010,8 @@ subroutine psb_s_cp_coo_from_coo(a,b,info)
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
info = psb_success_ 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() nz = b%get_nzeros()
call a%set_nzeros(nz) call a%set_nzeros(nz)
call a%reallocate(nz) call a%reallocate(nz)
@ -3085,7 +3130,7 @@ subroutine psb_s_mv_coo_to_coo(a,b,info)
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
info = psb_success_ 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%set_nzeros(a%get_nzeros())
call b%reallocate(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) call psb_erractionsave(err_act)
info = psb_success_ 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%set_nzeros(b%get_nzeros())
call a%reallocate(b%get_nzeros()) call a%reallocate(b%get_nzeros())

235
base/serial/impl/psb_s_csc_impl.f90
Unescape Escape View File

@ -2263,7 +2263,7 @@ subroutine psb_s_cp_csc_to_coo(a,b,info)
nza = a%get_nzeros() nza = a%get_nzeros()
call b%allocate(nr,nc,nza) 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 i=1, nc
do j=a%icp(i),a%icp(i+1)-1 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() nc = a%get_ncols()
nza = a%get_nzeros() 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 b%set_nzeros(a%get_nzeros())
call move_alloc(a%ia,b%ia) call move_alloc(a%ia,b%ia)
call move_alloc(a%val,b%val) 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() nc = b%get_ncols()
nza = b%get_nzeros() 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. ! Dirty trick: call move_alloc to have the new data allocated just once.
call move_alloc(b%ja,itemp) 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) call a%mv_to_coo(b,info)
! Need to fix trivial copies! ! Need to fix trivial copies!
type is (psb_s_csc_sparse_mat) 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%icp, b%icp)
call move_alloc(a%ia, b%ia) call move_alloc(a%ia, b%ia)
call move_alloc(a%val, b%val) 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) call a%cp_to_coo(b,info)
type is (psb_s_csc_sparse_mat) type is (psb_s_csc_sparse_mat)
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)
call psb_safe_cpy( a%icp, b%icp , info) if (info == 0) call psb_safe_cpy( a%icp, b%icp , info)
call psb_safe_cpy( a%ia , b%ia , info) if (info == 0) call psb_safe_cpy( a%ia , b%ia , info)
call psb_safe_cpy( a%val, b%val , info) if (info == 0) call psb_safe_cpy( a%val, b%val , info)
class default class default
call a%cp_to_coo(tmp,info) 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) call a%mv_from_coo(b,info)
type is (psb_s_csc_sparse_mat) 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%icp, a%icp)
call move_alloc(b%ia, a%ia) call move_alloc(b%ia, a%ia)
call move_alloc(b%val, a%val) 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) call a%cp_from_coo(b,info)
type is (psb_s_csc_sparse_mat) type is (psb_s_csc_sparse_mat)
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)
call psb_safe_cpy( b%icp, a%icp , info) if (info == 0) call psb_safe_cpy( b%icp, a%icp , info)
call psb_safe_cpy( b%ia , a%ia , info) if (info == 0) call psb_safe_cpy( b%ia , a%ia , info)
call psb_safe_cpy( b%val, a%val , info) if (info == 0) call psb_safe_cpy( b%val, a%val , info)
class default class default
call b%cp_to_coo(tmp,info) call b%cp_to_coo(tmp,info)
if (info == psb_success_) call a%mv_from_coo(tmp,info) if (info == psb_success_) call a%mv_from_coo(tmp,info)
end select end select
end subroutine psb_s_cp_csc_from_fmt end subroutine psb_s_cp_csc_from_fmt
subroutine psb_s_csc_mold(a,b,info) subroutine psb_s_csc_mold(a,b,info)
use psb_s_csc_mat_mod, psb_protect_name => psb_s_csc_mold use psb_s_csc_mat_mod, psb_protect_name => psb_s_csc_mold
use psb_error_mod use psb_error_mod
implicit none implicit none
class(psb_s_csc_sparse_mat), intent(in) :: a class(psb_s_csc_sparse_mat), intent(in) :: a
class(psb_s_base_sparse_mat), intent(out), allocatable :: b class(psb_s_base_sparse_mat), intent(inout), allocatable :: b
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5) integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='reallocate_nz' character(len=20) :: name='csc_mold'
logical, parameter :: debug=.false. logical, parameter :: debug=.false.
call psb_get_erraction(err_act) 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_ info = psb_err_alloc_dealloc_
call psb_errpush(info, name) call psb_errpush(info, name)
goto 9999 goto 9999
@ -2605,6 +2612,44 @@ subroutine psb_s_csc_mold(a,b,info)
end subroutine psb_s_csc_mold 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) subroutine psb_s_csc_reallocate_nz(nz,a)
use psb_error_mod 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 end subroutine psb_s_csc_print
subroutine psb_s_csc_cp_from(a,b) !!$subroutine psb_s_csc_cp_from(a,b)
use psb_error_mod !!$ use psb_error_mod
use psb_realloc_mod !!$ use psb_realloc_mod
use psb_s_csc_mat_mod, psb_protect_name => psb_s_csc_cp_from !!$ use psb_s_csc_mat_mod, psb_protect_name => psb_s_csc_cp_from
implicit none !!$ implicit none
!!$
class(psb_s_csc_sparse_mat), intent(inout) :: a !!$ class(psb_s_csc_sparse_mat), intent(inout) :: a
type(psb_s_csc_sparse_mat), intent(in) :: b !!$ type(psb_s_csc_sparse_mat), intent(in) :: b
!!$
!!$
integer(psb_ipk_) :: err_act, info !!$ integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5) !!$ integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='cp_from' !!$ character(len=20) :: name='cp_from'
logical, parameter :: debug=.false. !!$ logical, parameter :: debug=.false.
!!$
call psb_erractionsave(err_act) !!$ call psb_erractionsave(err_act)
!!$
info = psb_success_ !!$ info = psb_success_
!!$
call a%allocate(b%get_nrows(),b%get_ncols(),b%get_nzeros()) !!$ 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 b%psb_s_base_sparse_mat%copy(a%psb_s_base_sparse_mat, info)
call psb_safe_cpy( b%icp, a%icp , info) !!$ if (info == 0) call psb_safe_cpy( b%icp, a%icp , info)
call psb_safe_cpy( b%ia , a%ia , info) !!$ if (info == 0) call psb_safe_cpy( b%ia , a%ia , info)
call psb_safe_cpy( b%val, a%val , info) !!$ if (info == 0) call psb_safe_cpy( b%val, a%val , info)
!!$
if (info /= psb_success_) goto 9999 !!$ if (info /= psb_success_) goto 9999
call psb_erractionrestore(err_act) !!$ call psb_erractionrestore(err_act)
return !!$ return
!!$
9999 continue !!$9999 continue
call psb_erractionrestore(err_act) !!$ call psb_erractionrestore(err_act)
!!$
call psb_errpush(info,name) !!$ call psb_errpush(info,name)
!!$
if (err_act /= psb_act_ret_) then !!$ if (err_act /= psb_act_ret_) then
call psb_error() !!$ call psb_error()
end if !!$ end if
return !!$ return
!!$
end subroutine psb_s_csc_cp_from !!$end subroutine psb_s_csc_cp_from
!!$
subroutine psb_s_csc_mv_from(a,b) !!$subroutine psb_s_csc_mv_from(a,b)
use psb_error_mod !!$ use psb_error_mod
use psb_s_csc_mat_mod, psb_protect_name => psb_s_csc_mv_from !!$ use psb_s_csc_mat_mod, psb_protect_name => psb_s_csc_mv_from
implicit none !!$ implicit none
!!$
class(psb_s_csc_sparse_mat), intent(inout) :: a !!$ class(psb_s_csc_sparse_mat), intent(inout) :: a
type(psb_s_csc_sparse_mat), intent(inout) :: b !!$ type(psb_s_csc_sparse_mat), intent(inout) :: b
!!$
!!$
integer(psb_ipk_) :: err_act, info !!$ integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5) !!$ integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='mv_from' !!$ character(len=20) :: name='mv_from'
logical, parameter :: debug=.false. !!$ logical, parameter :: debug=.false.
!!$
call psb_erractionsave(err_act) !!$ call psb_erractionsave(err_act)
info = psb_success_ !!$ 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 move_alloc(b%icp, a%icp) !!$ if (info == 0) call move_alloc(b%icp, a%icp)
call move_alloc(b%ia, a%ia) !!$ if (info == 0) call move_alloc(b%ia, a%ia)
call move_alloc(b%val, a%val) !!$ if (info == 0) call move_alloc(b%val, a%val)
call b%free() !!$ call b%free()
!!$
call psb_erractionrestore(err_act) !!$ call psb_erractionrestore(err_act)
return !!$ return
!!$
9999 continue !!$9999 continue
call psb_erractionrestore(err_act) !!$ call psb_erractionrestore(err_act)
!!$
call psb_errpush(info,name) !!$ call psb_errpush(info,name)
!!$
if (err_act /= psb_act_ret_) then !!$ if (err_act /= psb_act_ret_) then
call psb_error() !!$ call psb_error()
end if !!$ end if
return !!$ return
!!$
end subroutine psb_s_csc_mv_from !!$end subroutine psb_s_csc_mv_from
!!$

238
base/serial/impl/psb_s_csr_impl.f90
Unescape Escape View File

@ -1786,18 +1786,23 @@ subroutine psb_s_csr_mold(a,b,info)
use psb_error_mod use psb_error_mod
implicit none implicit none
class(psb_s_csr_sparse_mat), intent(in) :: a class(psb_s_csr_sparse_mat), intent(in) :: a
class(psb_s_base_sparse_mat), intent(out), allocatable :: b class(psb_s_base_sparse_mat), intent(inout), allocatable :: b
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5) integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='reallocate_nz' character(len=20) :: name='csr_mold'
logical, parameter :: debug=.false. logical, parameter :: debug=.false.
call psb_get_erraction(err_act) 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_ info = psb_err_alloc_dealloc_
call psb_errpush(info, name) call psb_errpush(info, name)
goto 9999 goto 9999
@ -1811,6 +1816,45 @@ subroutine psb_s_csr_mold(a,b,info)
end subroutine psb_s_csr_mold 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) subroutine psb_s_csr_allocate_mnnz(m,n,a,nz)
use psb_error_mod use psb_error_mod
use psb_realloc_mod use psb_realloc_mod
@ -2799,7 +2843,7 @@ subroutine psb_s_cp_csr_to_coo(a,b,info)
nza = a%get_nzeros() nza = a%get_nzeros()
call b%allocate(nr,nc,nza) 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 i=1, nr
do j=a%irp(i),a%irp(i+1)-1 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() nc = a%get_ncols()
nza = a%get_nzeros() 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 b%set_nzeros(a%get_nzeros())
call move_alloc(a%ja,b%ja) call move_alloc(a%ja,b%ja)
call move_alloc(a%val,b%val) 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() nc = b%get_ncols()
nza = b%get_nzeros() 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. ! Dirty trick: call move_alloc to have the new data allocated just once.
call move_alloc(b%ia,itemp) 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) call a%mv_to_coo(b,info)
! Need to fix trivial copies! ! Need to fix trivial copies!
type is (psb_s_csr_sparse_mat) 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%irp, b%irp)
call move_alloc(a%ja, b%ja) call move_alloc(a%ja, b%ja)
call move_alloc(a%val, b%val) 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) call a%cp_to_coo(b,info)
type is (psb_s_csr_sparse_mat) type is (psb_s_csr_sparse_mat)
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)
call psb_safe_cpy( a%irp, b%irp , info) if (info == 0) call psb_safe_cpy( a%irp, b%irp , info)
call psb_safe_cpy( a%ja , b%ja , info) if (info == 0) call psb_safe_cpy( a%ja , b%ja , info)
call psb_safe_cpy( a%val, b%val , info) if (info == 0) call psb_safe_cpy( a%val, b%val , info)
class default class default
call a%cp_to_coo(tmp,info) 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) call a%mv_from_coo(b,info)
type is (psb_s_csr_sparse_mat) 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%irp, a%irp)
call move_alloc(b%ja, a%ja) call move_alloc(b%ja, a%ja)
call move_alloc(b%val, a%val) 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) call a%cp_from_coo(b,info)
type is (psb_s_csr_sparse_mat) type is (psb_s_csr_sparse_mat)
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)
call psb_safe_cpy( b%irp, a%irp , info) if (info == 0) call psb_safe_cpy( b%irp, a%irp , info)
call psb_safe_cpy( b%ja , a%ja , info) if (info == 0) call psb_safe_cpy( b%ja , a%ja , info)
call psb_safe_cpy( b%val, a%val , info) if (info == 0) call psb_safe_cpy( b%val, a%val , info)
class default class default
call b%cp_to_coo(tmp,info) call b%cp_to_coo(tmp,info)
@ -3109,83 +3153,83 @@ subroutine psb_s_cp_csr_from_fmt(a,b,info)
end select end select
end subroutine psb_s_cp_csr_from_fmt end subroutine psb_s_cp_csr_from_fmt
!!$
subroutine psb_s_csr_cp_from(a,b) !!$subroutine psb_s_csr_cp_from(a,b)
use psb_error_mod !!$ use psb_error_mod
use psb_realloc_mod !!$ use psb_realloc_mod
use psb_s_csr_mat_mod, psb_protect_name => psb_s_csr_cp_from !!$ use psb_s_csr_mat_mod, psb_protect_name => psb_s_csr_cp_from
implicit none !!$ implicit none
!!$
class(psb_s_csr_sparse_mat), intent(inout) :: a !!$ class(psb_s_csr_sparse_mat), intent(inout) :: a
type(psb_s_csr_sparse_mat), intent(in) :: b !!$ type(psb_s_csr_sparse_mat), intent(in) :: b
!!$
!!$
integer(psb_ipk_) :: err_act, info !!$ integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5) !!$ integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='cp_from' !!$ character(len=20) :: name='cp_from'
logical, parameter :: debug=.false. !!$ logical, parameter :: debug=.false.
!!$
call psb_erractionsave(err_act) !!$ call psb_erractionsave(err_act)
!!$
info = psb_success_ !!$ info = psb_success_
!!$
call a%allocate(b%get_nrows(),b%get_ncols(),b%get_nzeros()) !!$ 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 b%psb_s_base_sparse_mat%copy(a%psb_s_base_sparse_mat, info)
call psb_safe_cpy( b%irp, a%irp , info) !!$ if (info == 0) call psb_safe_cpy( b%irp, a%irp , info)
call psb_safe_cpy( b%ja , a%ja , info) !!$ if (info == 0) call psb_safe_cpy( b%ja , a%ja , info)
call psb_safe_cpy( b%val, a%val , info) !!$ if (info == 0) call psb_safe_cpy( b%val, a%val , info)
!!$
if (info /= psb_success_) goto 9999 !!$ if (info /= psb_success_) goto 9999
call psb_erractionrestore(err_act) !!$ call psb_erractionrestore(err_act)
return !!$ return
!!$
9999 continue !!$9999 continue
call psb_erractionrestore(err_act) !!$ call psb_erractionrestore(err_act)
!!$
call psb_errpush(info,name) !!$ call psb_errpush(info,name)
!!$
if (err_act /= psb_act_ret_) then !!$ if (err_act /= psb_act_ret_) then
call psb_error() !!$ call psb_error()
end if !!$ end if
return !!$ return
!!$
end subroutine psb_s_csr_cp_from !!$end subroutine psb_s_csr_cp_from
!!$
subroutine psb_s_csr_mv_from(a,b) !!$subroutine psb_s_csr_mv_from(a,b)
use psb_error_mod !!$ use psb_error_mod
use psb_s_csr_mat_mod, psb_protect_name => psb_s_csr_mv_from !!$ use psb_s_csr_mat_mod, psb_protect_name => psb_s_csr_mv_from
implicit none !!$ implicit none
!!$
class(psb_s_csr_sparse_mat), intent(inout) :: a !!$ class(psb_s_csr_sparse_mat), intent(inout) :: a
type(psb_s_csr_sparse_mat), intent(inout) :: b !!$ type(psb_s_csr_sparse_mat), intent(inout) :: b
!!$
!!$
integer(psb_ipk_) :: err_act, info !!$ integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5) !!$ integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='mv_from' !!$ character(len=20) :: name='mv_from'
logical, parameter :: debug=.false. !!$ logical, parameter :: debug=.false.
!!$
call psb_erractionsave(err_act) !!$ call psb_erractionsave(err_act)
info = psb_success_ !!$ info = psb_success_
call a%psb_s_base_sparse_mat%mv_from(b%psb_s_base_sparse_mat) !!$ 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%irp, a%irp)
call move_alloc(b%ja, a%ja) !!$ call move_alloc(b%ja, a%ja)
call move_alloc(b%val, a%val) !!$ call move_alloc(b%val, a%val)
call b%free() !!$ call b%free()
!!$
call psb_erractionrestore(err_act) !!$ call psb_erractionrestore(err_act)
return !!$ return
!!$
9999 continue !!$9999 continue
call psb_erractionrestore(err_act) !!$ call psb_erractionrestore(err_act)
!!$
call psb_errpush(info,name) !!$ call psb_errpush(info,name)
!!$
if (err_act /= psb_act_ret_) then !!$ if (err_act /= psb_act_ret_) then
call psb_error() !!$ call psb_error()
end if !!$ end if
return !!$ return
!!$
end subroutine psb_s_csr_mv_from !!$end subroutine psb_s_csr_mv_from
!!$
!!$

35
base/serial/impl/psb_s_mat_impl.F90
Unescape Escape View File

@ -1574,6 +1574,41 @@ subroutine psb_sspmat_clone(a,b,info)
end subroutine psb_sspmat_clone 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) subroutine psb_s_transp_1mat(a)
use psb_error_mod use psb_error_mod

41
base/serial/impl/psb_z_base_mat_impl.F90
Unescape Escape View File

@ -585,11 +585,11 @@ subroutine psb_z_base_mold(a,b,info)
use psb_error_mod use psb_error_mod
implicit none implicit none
class(psb_z_base_sparse_mat), intent(in) :: a 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(inout), allocatable :: b
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5) integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='reallocate_nz' character(len=20) :: name='base_mold'
logical, parameter :: debug=.false. logical, parameter :: debug=.false.
call psb_get_erraction(err_act) call psb_get_erraction(err_act)
@ -606,6 +606,43 @@ subroutine psb_z_base_mold(a,b,info)
end subroutine psb_z_base_mold 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) subroutine psb_z_base_transp_2mat(a,b)
use psb_z_base_mat_mod, psb_protect_name => psb_z_base_transp_2mat use psb_z_base_mat_mod, psb_protect_name => psb_z_base_transp_2mat
use psb_error_mod use psb_error_mod

61
base/serial/impl/psb_z_coo_impl.f90
Unescape Escape View File

@ -226,18 +226,23 @@ subroutine psb_z_coo_mold(a,b,info)
use psb_error_mod use psb_error_mod
implicit none implicit none
class(psb_z_coo_sparse_mat), intent(in) :: a class(psb_z_coo_sparse_mat), intent(in) :: a
class(psb_z_base_sparse_mat), intent(out), allocatable :: b class(psb_z_base_sparse_mat), intent(inout), allocatable :: b
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5) integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='reallocate_nz' character(len=20) :: name='coo_mold'
logical, parameter :: debug=.false. logical, parameter :: debug=.false.
call psb_get_erraction(err_act) 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_ info = psb_err_alloc_dealloc_
call psb_errpush(info, name) call psb_errpush(info, name)
goto 9999 goto 9999
@ -251,6 +256,45 @@ subroutine psb_z_coo_mold(a,b,info)
end subroutine psb_z_coo_mold 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) subroutine psb_z_coo_reinit(a,clear)
use psb_z_base_mat_mod, psb_protect_name => psb_z_coo_reinit 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) call psb_erractionsave(err_act)
info = psb_success_ 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() nz = a%get_nzeros()
call b%set_nzeros(nz) call b%set_nzeros(nz)
@ -2966,7 +3010,8 @@ subroutine psb_z_cp_coo_from_coo(a,b,info)
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
info = psb_success_ 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() nz = b%get_nzeros()
call a%set_nzeros(nz) call a%set_nzeros(nz)
call a%reallocate(nz) call a%reallocate(nz)
@ -3085,7 +3130,7 @@ subroutine psb_z_mv_coo_to_coo(a,b,info)
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
info = psb_success_ 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%set_nzeros(a%get_nzeros())
call b%reallocate(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) call psb_erractionsave(err_act)
info = psb_success_ 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%set_nzeros(b%get_nzeros())
call a%reallocate(b%get_nzeros()) call a%reallocate(b%get_nzeros())

235
base/serial/impl/psb_z_csc_impl.f90
Unescape Escape View File

@ -2263,7 +2263,7 @@ subroutine psb_z_cp_csc_to_coo(a,b,info)
nza = a%get_nzeros() nza = a%get_nzeros()
call b%allocate(nr,nc,nza) 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 i=1, nc
do j=a%icp(i),a%icp(i+1)-1 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() nc = a%get_ncols()
nza = a%get_nzeros() 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 b%set_nzeros(a%get_nzeros())
call move_alloc(a%ia,b%ia) call move_alloc(a%ia,b%ia)
call move_alloc(a%val,b%val) 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() nc = b%get_ncols()
nza = b%get_nzeros() 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. ! Dirty trick: call move_alloc to have the new data allocated just once.
call move_alloc(b%ja,itemp) 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) call a%mv_to_coo(b,info)
! Need to fix trivial copies! ! Need to fix trivial copies!
type is (psb_z_csc_sparse_mat) 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%icp, b%icp)
call move_alloc(a%ia, b%ia) call move_alloc(a%ia, b%ia)
call move_alloc(a%val, b%val) 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) call a%cp_to_coo(b,info)
type is (psb_z_csc_sparse_mat) type is (psb_z_csc_sparse_mat)
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)
call psb_safe_cpy( a%icp, b%icp , info) if (info == 0) call psb_safe_cpy( a%icp, b%icp , info)
call psb_safe_cpy( a%ia , b%ia , info) if (info == 0) call psb_safe_cpy( a%ia , b%ia , info)
call psb_safe_cpy( a%val, b%val , info) if (info == 0) call psb_safe_cpy( a%val, b%val , info)
class default class default
call a%cp_to_coo(tmp,info) 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) call a%mv_from_coo(b,info)
type is (psb_z_csc_sparse_mat) 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%icp, a%icp)
call move_alloc(b%ia, a%ia) call move_alloc(b%ia, a%ia)
call move_alloc(b%val, a%val) 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) call a%cp_from_coo(b,info)
type is (psb_z_csc_sparse_mat) type is (psb_z_csc_sparse_mat)
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)
call psb_safe_cpy( b%icp, a%icp , info) if (info == 0) call psb_safe_cpy( b%icp, a%icp , info)
call psb_safe_cpy( b%ia , a%ia , info) if (info == 0) call psb_safe_cpy( b%ia , a%ia , info)
call psb_safe_cpy( b%val, a%val , info) if (info == 0) call psb_safe_cpy( b%val, a%val , info)
class default class default
call b%cp_to_coo(tmp,info) call b%cp_to_coo(tmp,info)
if (info == psb_success_) call a%mv_from_coo(tmp,info) if (info == psb_success_) call a%mv_from_coo(tmp,info)
end select end select
end subroutine psb_z_cp_csc_from_fmt end subroutine psb_z_cp_csc_from_fmt
subroutine psb_z_csc_mold(a,b,info) subroutine psb_z_csc_mold(a,b,info)
use psb_z_csc_mat_mod, psb_protect_name => psb_z_csc_mold use psb_z_csc_mat_mod, psb_protect_name => psb_z_csc_mold
use psb_error_mod use psb_error_mod
implicit none implicit none
class(psb_z_csc_sparse_mat), intent(in) :: a class(psb_z_csc_sparse_mat), intent(in) :: a
class(psb_z_base_sparse_mat), intent(out), allocatable :: b class(psb_z_base_sparse_mat), intent(inout), allocatable :: b
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5) integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='reallocate_nz' character(len=20) :: name='csc_mold'
logical, parameter :: debug=.false. logical, parameter :: debug=.false.
call psb_get_erraction(err_act) 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_ info = psb_err_alloc_dealloc_
call psb_errpush(info, name) call psb_errpush(info, name)
goto 9999 goto 9999
@ -2605,6 +2612,44 @@ subroutine psb_z_csc_mold(a,b,info)
end subroutine psb_z_csc_mold 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) subroutine psb_z_csc_reallocate_nz(nz,a)
use psb_error_mod 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 end subroutine psb_z_csc_print
subroutine psb_z_csc_cp_from(a,b) !!$subroutine psb_z_csc_cp_from(a,b)
use psb_error_mod !!$ use psb_error_mod
use psb_realloc_mod !!$ use psb_realloc_mod
use psb_z_csc_mat_mod, psb_protect_name => psb_z_csc_cp_from !!$ use psb_z_csc_mat_mod, psb_protect_name => psb_z_csc_cp_from
implicit none !!$ implicit none
!!$
class(psb_z_csc_sparse_mat), intent(inout) :: a !!$ class(psb_z_csc_sparse_mat), intent(inout) :: a
type(psb_z_csc_sparse_mat), intent(in) :: b !!$ type(psb_z_csc_sparse_mat), intent(in) :: b
!!$
!!$
integer(psb_ipk_) :: err_act, info !!$ integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5) !!$ integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='cp_from' !!$ character(len=20) :: name='cp_from'
logical, parameter :: debug=.false. !!$ logical, parameter :: debug=.false.
!!$
call psb_erractionsave(err_act) !!$ call psb_erractionsave(err_act)
!!$
info = psb_success_ !!$ info = psb_success_
!!$
call a%allocate(b%get_nrows(),b%get_ncols(),b%get_nzeros()) !!$ 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 b%psb_z_base_sparse_mat%copy(a%psb_z_base_sparse_mat, info)
call psb_safe_cpy( b%icp, a%icp , info) !!$ if (info == 0) call psb_safe_cpy( b%icp, a%icp , info)
call psb_safe_cpy( b%ia , a%ia , info) !!$ if (info == 0) call psb_safe_cpy( b%ia , a%ia , info)
call psb_safe_cpy( b%val, a%val , info) !!$ if (info == 0) call psb_safe_cpy( b%val, a%val , info)
!!$
if (info /= psb_success_) goto 9999 !!$ if (info /= psb_success_) goto 9999
call psb_erractionrestore(err_act) !!$ call psb_erractionrestore(err_act)
return !!$ return
!!$
9999 continue !!$9999 continue
call psb_erractionrestore(err_act) !!$ call psb_erractionrestore(err_act)
!!$
call psb_errpush(info,name) !!$ call psb_errpush(info,name)
!!$
if (err_act /= psb_act_ret_) then !!$ if (err_act /= psb_act_ret_) then
call psb_error() !!$ call psb_error()
end if !!$ end if
return !!$ return
!!$
end subroutine psb_z_csc_cp_from !!$end subroutine psb_z_csc_cp_from
!!$
subroutine psb_z_csc_mv_from(a,b) !!$subroutine psb_z_csc_mv_from(a,b)
use psb_error_mod !!$ use psb_error_mod
use psb_z_csc_mat_mod, psb_protect_name => psb_z_csc_mv_from !!$ use psb_z_csc_mat_mod, psb_protect_name => psb_z_csc_mv_from
implicit none !!$ implicit none
!!$
class(psb_z_csc_sparse_mat), intent(inout) :: a !!$ class(psb_z_csc_sparse_mat), intent(inout) :: a
type(psb_z_csc_sparse_mat), intent(inout) :: b !!$ type(psb_z_csc_sparse_mat), intent(inout) :: b
!!$
!!$
integer(psb_ipk_) :: err_act, info !!$ integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5) !!$ integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='mv_from' !!$ character(len=20) :: name='mv_from'
logical, parameter :: debug=.false. !!$ logical, parameter :: debug=.false.
!!$
call psb_erractionsave(err_act) !!$ call psb_erractionsave(err_act)
info = psb_success_ !!$ 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 move_alloc(b%icp, a%icp) !!$ if (info == 0) call move_alloc(b%icp, a%icp)
call move_alloc(b%ia, a%ia) !!$ if (info == 0) call move_alloc(b%ia, a%ia)
call move_alloc(b%val, a%val) !!$ if (info == 0) call move_alloc(b%val, a%val)
call b%free() !!$ call b%free()
!!$
call psb_erractionrestore(err_act) !!$ call psb_erractionrestore(err_act)
return !!$ return
!!$
9999 continue !!$9999 continue
call psb_erractionrestore(err_act) !!$ call psb_erractionrestore(err_act)
!!$
call psb_errpush(info,name) !!$ call psb_errpush(info,name)
!!$
if (err_act /= psb_act_ret_) then !!$ if (err_act /= psb_act_ret_) then
call psb_error() !!$ call psb_error()
end if !!$ end if
return !!$ return
!!$
end subroutine psb_z_csc_mv_from !!$end subroutine psb_z_csc_mv_from
!!$

238
base/serial/impl/psb_z_csr_impl.f90
Unescape Escape View File

@ -1786,18 +1786,23 @@ subroutine psb_z_csr_mold(a,b,info)
use psb_error_mod use psb_error_mod
implicit none implicit none
class(psb_z_csr_sparse_mat), intent(in) :: a class(psb_z_csr_sparse_mat), intent(in) :: a
class(psb_z_base_sparse_mat), intent(out), allocatable :: b class(psb_z_base_sparse_mat), intent(inout), allocatable :: b
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: err_act integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5) integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='reallocate_nz' character(len=20) :: name='csr_mold'
logical, parameter :: debug=.false. logical, parameter :: debug=.false.
call psb_get_erraction(err_act) 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_ info = psb_err_alloc_dealloc_
call psb_errpush(info, name) call psb_errpush(info, name)
goto 9999 goto 9999
@ -1811,6 +1816,45 @@ subroutine psb_z_csr_mold(a,b,info)
end subroutine psb_z_csr_mold 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) subroutine psb_z_csr_allocate_mnnz(m,n,a,nz)
use psb_error_mod use psb_error_mod
use psb_realloc_mod use psb_realloc_mod
@ -2799,7 +2843,7 @@ subroutine psb_z_cp_csr_to_coo(a,b,info)
nza = a%get_nzeros() nza = a%get_nzeros()
call b%allocate(nr,nc,nza) 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 i=1, nr
do j=a%irp(i),a%irp(i+1)-1 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() nc = a%get_ncols()
nza = a%get_nzeros() 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 b%set_nzeros(a%get_nzeros())
call move_alloc(a%ja,b%ja) call move_alloc(a%ja,b%ja)
call move_alloc(a%val,b%val) 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() nc = b%get_ncols()
nza = b%get_nzeros() 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. ! Dirty trick: call move_alloc to have the new data allocated just once.
call move_alloc(b%ia,itemp) 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) call a%mv_to_coo(b,info)
! Need to fix trivial copies! ! Need to fix trivial copies!
type is (psb_z_csr_sparse_mat) 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%irp, b%irp)
call move_alloc(a%ja, b%ja) call move_alloc(a%ja, b%ja)
call move_alloc(a%val, b%val) 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) call a%cp_to_coo(b,info)
type is (psb_z_csr_sparse_mat) type is (psb_z_csr_sparse_mat)
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)
call psb_safe_cpy( a%irp, b%irp , info) if (info == 0) call psb_safe_cpy( a%irp, b%irp , info)
call psb_safe_cpy( a%ja , b%ja , info) if (info == 0) call psb_safe_cpy( a%ja , b%ja , info)
call psb_safe_cpy( a%val, b%val , info) if (info == 0) call psb_safe_cpy( a%val, b%val , info)
class default class default
call a%cp_to_coo(tmp,info) 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) call a%mv_from_coo(b,info)
type is (psb_z_csr_sparse_mat) 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%irp, a%irp)
call move_alloc(b%ja, a%ja) call move_alloc(b%ja, a%ja)
call move_alloc(b%val, a%val) 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) call a%cp_from_coo(b,info)
type is (psb_z_csr_sparse_mat) type is (psb_z_csr_sparse_mat)
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)
call psb_safe_cpy( b%irp, a%irp , info) if (info == 0) call psb_safe_cpy( b%irp, a%irp , info)
call psb_safe_cpy( b%ja , a%ja , info) if (info == 0) call psb_safe_cpy( b%ja , a%ja , info)
call psb_safe_cpy( b%val, a%val , info) if (info == 0) call psb_safe_cpy( b%val, a%val , info)
class default class default
call b%cp_to_coo(tmp,info) call b%cp_to_coo(tmp,info)
@ -3109,83 +3153,83 @@ subroutine psb_z_cp_csr_from_fmt(a,b,info)
end select end select
end subroutine psb_z_cp_csr_from_fmt end subroutine psb_z_cp_csr_from_fmt
!!$
subroutine psb_z_csr_cp_from(a,b) !!$subroutine psb_z_csr_cp_from(a,b)
use psb_error_mod !!$ use psb_error_mod
use psb_realloc_mod !!$ use psb_realloc_mod
use psb_z_csr_mat_mod, psb_protect_name => psb_z_csr_cp_from !!$ use psb_z_csr_mat_mod, psb_protect_name => psb_z_csr_cp_from
implicit none !!$ implicit none
!!$
class(psb_z_csr_sparse_mat), intent(inout) :: a !!$ class(psb_z_csr_sparse_mat), intent(inout) :: a
type(psb_z_csr_sparse_mat), intent(in) :: b !!$ type(psb_z_csr_sparse_mat), intent(in) :: b
!!$
!!$
integer(psb_ipk_) :: err_act, info !!$ integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5) !!$ integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='cp_from' !!$ character(len=20) :: name='cp_from'
logical, parameter :: debug=.false. !!$ logical, parameter :: debug=.false.
!!$
call psb_erractionsave(err_act) !!$ call psb_erractionsave(err_act)
!!$
info = psb_success_ !!$ info = psb_success_
!!$
call a%allocate(b%get_nrows(),b%get_ncols(),b%get_nzeros()) !!$ 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 b%psb_z_base_sparse_mat%copy(a%psb_z_base_sparse_mat, info)
call psb_safe_cpy( b%irp, a%irp , info) !!$ if (info == 0) call psb_safe_cpy( b%irp, a%irp , info)
call psb_safe_cpy( b%ja , a%ja , info) !!$ if (info == 0) call psb_safe_cpy( b%ja , a%ja , info)
call psb_safe_cpy( b%val, a%val , info) !!$ if (info == 0) call psb_safe_cpy( b%val, a%val , info)
!!$
if (info /= psb_success_) goto 9999 !!$ if (info /= psb_success_) goto 9999
call psb_erractionrestore(err_act) !!$ call psb_erractionrestore(err_act)
return !!$ return
!!$
9999 continue !!$9999 continue
call psb_erractionrestore(err_act) !!$ call psb_erractionrestore(err_act)
!!$
call psb_errpush(info,name) !!$ call psb_errpush(info,name)
!!$
if (err_act /= psb_act_ret_) then !!$ if (err_act /= psb_act_ret_) then
call psb_error() !!$ call psb_error()
end if !!$ end if
return !!$ return
!!$
end subroutine psb_z_csr_cp_from !!$end subroutine psb_z_csr_cp_from
!!$
subroutine psb_z_csr_mv_from(a,b) !!$subroutine psb_z_csr_mv_from(a,b)
use psb_error_mod !!$ use psb_error_mod
use psb_z_csr_mat_mod, psb_protect_name => psb_z_csr_mv_from !!$ use psb_z_csr_mat_mod, psb_protect_name => psb_z_csr_mv_from
implicit none !!$ implicit none
!!$
class(psb_z_csr_sparse_mat), intent(inout) :: a !!$ class(psb_z_csr_sparse_mat), intent(inout) :: a
type(psb_z_csr_sparse_mat), intent(inout) :: b !!$ type(psb_z_csr_sparse_mat), intent(inout) :: b
!!$
!!$
integer(psb_ipk_) :: err_act, info !!$ integer(psb_ipk_) :: err_act, info
integer(psb_ipk_) :: ierr(5) !!$ integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='mv_from' !!$ character(len=20) :: name='mv_from'
logical, parameter :: debug=.false. !!$ logical, parameter :: debug=.false.
!!$
call psb_erractionsave(err_act) !!$ call psb_erractionsave(err_act)
info = psb_success_ !!$ info = psb_success_
call a%psb_z_base_sparse_mat%mv_from(b%psb_z_base_sparse_mat) !!$ 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%irp, a%irp)
call move_alloc(b%ja, a%ja) !!$ call move_alloc(b%ja, a%ja)
call move_alloc(b%val, a%val) !!$ call move_alloc(b%val, a%val)
call b%free() !!$ call b%free()
!!$
call psb_erractionrestore(err_act) !!$ call psb_erractionrestore(err_act)
return !!$ return
!!$
9999 continue !!$9999 continue
call psb_erractionrestore(err_act) !!$ call psb_erractionrestore(err_act)
!!$
call psb_errpush(info,name) !!$ call psb_errpush(info,name)
!!$
if (err_act /= psb_act_ret_) then !!$ if (err_act /= psb_act_ret_) then
call psb_error() !!$ call psb_error()
end if !!$ end if
return !!$ return
!!$
end subroutine psb_z_csr_mv_from !!$end subroutine psb_z_csr_mv_from
!!$
!!$

35
base/serial/impl/psb_z_mat_impl.F90
Unescape Escape View File

@ -1574,6 +1574,41 @@ subroutine psb_zspmat_clone(a,b,info)
end subroutine psb_zspmat_clone 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) subroutine psb_z_transp_1mat(a)
use psb_error_mod use psb_error_mod

Write Preview
Loading…
Cancel
Save