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/Makefile
 base/modules/README.F2003
 base/modules/psb_base_mat_mod.f03
 base/modules/psb_d_base_mat_mod.f03
 base/modules/psb_d_csr_mat_mod.f03
 base/modules/psb_d_mat_mod.f03
 base/modules/psb_mat_mod.f03
 base/serial/f03/psbn_d_coo_impl.f03
 base/serial/f03/psbn_d_csr_impl.f03
 test/pargen/psb_d_csc_impl.f03
 test/pargen/psb_d_csc_mat_mod.f03

Fixed mv_from and cp_from with access to ancestor type.
psblas3-type-indexed
Salvatore Filippone 16 years ago
parent 720fbd161a
commit 196539d626
11 changed files with 2577 additions and 2180 deletions
Show Stats Download Patch File Download Diff File

5
base/modules/Makefile
Unescape Escape View File

@ -8,7 +8,7 @@ UTIL_MODS = psb_string_mod.o psb_spmat_type.o \
psi_serial_mod.o psi_mod.o psb_ip_reord_mod.o\ psi_serial_mod.o psi_mod.o psb_ip_reord_mod.o\
psb_check_mod.o psb_gps_mod.o psb_linmap_mod.o psb_hash_mod.o\ psb_check_mod.o psb_gps_mod.o psb_linmap_mod.o psb_hash_mod.o\
psb_base_mat_mod.o psb_d_base_mat_mod.o psb_mat_mod.o\ psb_base_mat_mod.o psb_d_base_mat_mod.o psb_mat_mod.o\
psb_d_csr_mat_mod.o psb_d_csr_mat_mod.o psb_d_mat_mod.o
MODULES=$(BASIC_MODS) $(UTIL_MODS) MODULES=$(BASIC_MODS) $(UTIL_MODS)
@ -28,7 +28,8 @@ lib: $(BASIC_MODS) blacsmod $(UTIL_MODS) $(OBJS) $(LIBMOD)
psb_base_mat_mod.o: psb_string_mod.o psb_sort_mod.o psb_ip_reord_mod.o psb_error_mod.o psb_base_mat_mod.o: psb_string_mod.o psb_sort_mod.o psb_ip_reord_mod.o psb_error_mod.o
psb_d_base_mat_mod.o: psb_base_mat_mod.o psb_d_base_mat_mod.o: psb_base_mat_mod.o
psb_mat_mod.o: psb_d_base_mat_mod.o psb_d_csr_mat_mod.o psb_d_mat_mod.o: psb_d_base_mat_mod.o psb_d_csr_mat_mod.o
psb_mat_mod.o: psb_d_mat_mod.o
psb_realloc_mod.o : psb_error_mod.o psb_realloc_mod.o : psb_error_mod.o
psb_spmat_type.o : psb_realloc_mod.o psb_error_mod.o psb_const_mod.o psb_string_mod.o psb_sort_mod.o psb_spmat_type.o : psb_realloc_mod.o psb_error_mod.o psb_const_mod.o psb_string_mod.o psb_sort_mod.o
psb_error_mod.o: psb_const_mod.o psb_error_mod.o: psb_const_mod.o

2
base/modules/README.F2003
Unescape Escape View File

@ -98,8 +98,6 @@ Design principles for this directory.
AND IT'S DONE! Nothing else in the library requires the explicit AND IT'S DONE! Nothing else in the library requires the explicit
knowledge of type of MOLD. knowledge of type of MOLD.
User exercise: start by adding CSR in this way.
(waiting for a couple of bug fixes from NAG to actually test this.)

26
base/modules/psb_base_mat_mod.f03
Unescape Escape View File

@ -3,9 +3,9 @@ module psb_base_mat_mod
use psb_const_mod use psb_const_mod
type :: psb_base_sparse_mat type :: psb_base_sparse_mat
integer :: m, n integer, private :: m, n
integer :: state, duplicate integer, private :: state, duplicate
logical :: triangle, unitd, upper, sorted logical, private :: triangle, unitd, upper, sorted
! This is a different animal: it's a kitchen sink for ! This is a different animal: it's a kitchen sink for
! any additional parameters that may be needed ! any additional parameters that may be needed
! when converting to/from COO. Why here? ! when converting to/from COO. Why here?
@ -64,7 +64,6 @@ module psb_base_mat_mod
! Data management ! Data management
! !
! ==================================== ! ====================================
procedure, pass(a) :: get_neigh procedure, pass(a) :: get_neigh
procedure, pass(a) :: allocate_mnnz procedure, pass(a) :: allocate_mnnz
procedure, pass(a) :: reallocate_nz procedure, pass(a) :: reallocate_nz
@ -77,8 +76,10 @@ module psb_base_mat_mod
generic, public :: csget => csgetptn generic, public :: csget => csgetptn
procedure, pass(a) :: print => sparse_print procedure, pass(a) :: print => sparse_print
procedure, pass(a) :: sizeof procedure, pass(a) :: sizeof
!!$ procedure, pass(a) :: base_cp_from procedure, pass(a) :: base_cp_from
!!$ procedure, pass(a) :: base_mv_from generic, public :: cp_from => base_cp_from
procedure, pass(a) :: base_mv_from
generic, public :: mv_from => base_mv_from
end type psb_base_sparse_mat end type psb_base_sparse_mat
@ -89,14 +90,7 @@ module psb_base_mat_mod
& is_upd, is_asb, is_sorted, is_upper, is_lower, is_triangle, & & is_upd, is_asb, is_sorted, is_upper, is_lower, is_triangle, &
& is_unit, get_neigh, allocate_mn, allocate_mnnz, reallocate_nz, & & is_unit, get_neigh, allocate_mn, allocate_mnnz, reallocate_nz, &
& free, sparse_print, get_fmt, trim, sizeof, reinit, csgetptn, & & free, sparse_print, get_fmt, trim, sizeof, reinit, csgetptn, &
& get_nz_row, get_aux, set_aux & get_nz_row, get_aux, set_aux, base_cp_from, base_mv_from
!!$, base_mv_from, base_cp_from
interface cp_from
module procedure base_cp_from
end interface
interface mv_from
module procedure base_mv_from
end interface
contains contains
@ -449,7 +443,7 @@ contains
use psb_error_mod use psb_error_mod
implicit none implicit none
type(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
@ -470,7 +464,7 @@ contains
use psb_error_mod use psb_error_mod
implicit none implicit none
type(psb_base_sparse_mat), intent(out) :: a class(psb_base_sparse_mat), intent(out) :: a
type(psb_base_sparse_mat), intent(in) :: b type(psb_base_sparse_mat), intent(in) :: b
a%m = b%m a%m = b%m

218
base/modules/psb_d_base_mat_mod.f03
Unescape Escape View File

@ -32,25 +32,17 @@ module psb_d_base_mat_mod
procedure, pass(a) :: mv_from_coo procedure, pass(a) :: mv_from_coo
procedure, pass(a) :: mv_to_fmt procedure, pass(a) :: mv_to_fmt
procedure, pass(a) :: mv_from_fmt procedure, pass(a) :: mv_from_fmt
!!$ procedure, pass(a) :: base_cp_from => d_base_cp_from procedure, pass(a) :: d_base_cp_from
!!$ procedure, pass(a) :: base_mv_from => d_base_mv_from generic, public :: cp_from => d_base_cp_from
procedure, pass(a) :: d_base_mv_from
generic, public :: mv_from => d_base_mv_from
end type psb_d_base_sparse_mat end type psb_d_base_sparse_mat
private :: d_base_csmv, d_base_csmm, d_base_cssv, d_base_cssm,& private :: d_base_csmv, d_base_csmm, d_base_cssv, d_base_cssm,&
& d_scals, d_scal, csnmi, csput, d_csgetrow, d_csgetblk, & & d_scals, d_scal, csnmi, csput, d_csgetrow, d_csgetblk, &
& cp_to_coo, cp_from_coo, cp_to_fmt, cp_from_fmt, & & cp_to_coo, cp_from_coo, cp_to_fmt, cp_from_fmt, &
& mv_to_coo, mv_from_coo, mv_to_fmt, mv_from_fmt, & & mv_to_coo, mv_from_coo, mv_to_fmt, mv_from_fmt, &
& get_diag, csclip, d_cssv, d_cssm & get_diag, csclip, d_cssv, d_cssm, base_cp_from, base_mv_from
!!$, &
!!$ & d_base_mv_from, d_base_cp_from
interface cp_from
module procedure d_base_cp_from
end interface
interface mv_from
module procedure d_base_mv_from
end interface
type, extends(psb_d_base_sparse_mat) :: psb_d_coo_sparse_mat type, extends(psb_d_base_sparse_mat) :: psb_d_coo_sparse_mat
@ -92,6 +84,10 @@ module psb_d_base_mat_mod
procedure, pass(a) :: get_nz_row => d_coo_get_nz_row procedure, pass(a) :: get_nz_row => d_coo_get_nz_row
procedure, pass(a) :: sizeof => d_coo_sizeof procedure, pass(a) :: sizeof => d_coo_sizeof
procedure, pass(a) :: reinit => d_coo_reinit procedure, pass(a) :: reinit => d_coo_reinit
procedure, pass(a) :: d_coo_cp_from
generic, public :: cp_from => d_coo_cp_from
procedure, pass(a) :: d_coo_mv_from
generic, public :: mv_from => d_coo_mv_from
end type psb_d_coo_sparse_mat end type psb_d_coo_sparse_mat
@ -102,7 +98,8 @@ module psb_d_base_mat_mod
& d_cp_coo_to_coo, d_cp_coo_from_coo, & & d_cp_coo_to_coo, d_cp_coo_from_coo, &
& d_cp_coo_to_fmt, d_cp_coo_from_fmt, & & d_cp_coo_to_fmt, d_cp_coo_from_fmt, &
& d_coo_scals, d_coo_scal, d_coo_csgetrow, d_coo_sizeof, & & d_coo_scals, d_coo_scal, d_coo_csgetrow, d_coo_sizeof, &
& d_coo_csgetptn, d_coo_get_nz_row, d_coo_reinit & d_coo_csgetptn, d_coo_get_nz_row, d_coo_reinit,&
& d_coo_cp_from, d_coo_mv_from
interface interface
@ -326,39 +323,6 @@ contains
! !
!==================================== !====================================
!
! For the time being we do not have anything beyond
! the base components, but you never know.
!
subroutine d_base_mv_from(a,b)
use psb_error_mod
implicit none
type(psb_d_base_sparse_mat), intent(out) :: a
type(psb_d_base_sparse_mat), intent(inout) :: b
!!$ call a%psb_base_sparse_mat%base_mv_from(b%psb_base_sparse_mat)
call mv_from(a%psb_base_sparse_mat,b%psb_base_sparse_mat)
return
end subroutine d_base_mv_from
subroutine d_base_cp_from(a,b)
use psb_error_mod
implicit none
type(psb_d_base_sparse_mat), intent(out) :: a
type(psb_d_base_sparse_mat), intent(in) :: b
call cp_from(a%psb_base_sparse_mat,b%psb_base_sparse_mat)
return
end subroutine d_base_cp_from
subroutine cp_to_coo(a,b,info) subroutine cp_to_coo(a,b,info)
use psb_error_mod use psb_error_mod
use psb_realloc_mod use psb_realloc_mod
@ -570,6 +534,36 @@ contains
end subroutine mv_from_fmt end subroutine mv_from_fmt
subroutine d_base_mv_from(a,b)
use psb_error_mod
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)
use psb_error_mod
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
subroutine csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) subroutine csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
use psb_error_mod use psb_error_mod
@ -1658,71 +1652,71 @@ contains
end subroutine d_mv_coo_from_coo end subroutine d_mv_coo_from_coo
!!$
!!$ subroutine d_coo_cp_from(a,b) subroutine d_coo_cp_from(a,b)
!!$ use psb_error_mod use psb_error_mod
!!$ implicit none implicit none
!!$
!!$ class(psb_d_coo_sparse_mat), intent(out) :: a class(psb_d_coo_sparse_mat), intent(out) :: a
!!$ type(psb_d_coo_sparse_mat), intent(inout) :: b type(psb_d_coo_sparse_mat), intent(in) :: b
!!$
!!$
!!$ Integer :: err_act, info Integer :: err_act, info
!!$ character(len=20) :: name='mv_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 = 0 info = 0
!!$ call d_cp_coo_from_coo_impl(a,b,info) call d_cp_coo_from_coo_impl(a,b,info)
!!$ if (info /= 0) goto 9999 if (info /= 0) 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 d_coo_cp_from end subroutine d_coo_cp_from
!!$
!!$ subroutine d_coo_mv_from(a,b) subroutine d_coo_mv_from(a,b)
!!$ use psb_error_mod use psb_error_mod
!!$ implicit none implicit none
!!$
!!$ class(psb_d_coo_sparse_mat), intent(out) :: a class(psb_d_coo_sparse_mat), intent(out) :: a
!!$ type(psb_d_coo_sparse_mat), intent(inout) :: b type(psb_d_coo_sparse_mat), intent(inout) :: b
!!$
!!$
!!$ Integer :: err_act, info Integer :: err_act, info
!!$ 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 = 0 info = 0
!!$ call d_mv_coo_from_coo_impl(a,b,info) call d_mv_coo_from_coo_impl(a,b,info)
!!$ if (info /= 0) goto 9999 if (info /= 0) 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 d_coo_mv_from end subroutine d_coo_mv_from
!!$
subroutine d_mv_coo_to_fmt(a,b,info) subroutine d_mv_coo_to_fmt(a,b,info)
use psb_error_mod use psb_error_mod

155
base/modules/psb_d_csr_mat_mod.f03
Unescape Escape View File

@ -29,8 +29,6 @@ module psb_d_csr_mat_mod
procedure, pass(a) :: mv_from_coo => d_mv_csr_from_coo procedure, pass(a) :: mv_from_coo => d_mv_csr_from_coo
procedure, pass(a) :: mv_to_fmt => d_mv_csr_to_fmt procedure, pass(a) :: mv_to_fmt => d_mv_csr_to_fmt
procedure, pass(a) :: mv_from_fmt => d_mv_csr_from_fmt procedure, pass(a) :: mv_from_fmt => d_mv_csr_from_fmt
!!$ procedure, pass(a) :: mv_from => d_csr_mv_from
!!$ procedure, pass(a) :: cp_from => d_csr_cp_from
procedure, pass(a) :: csgetptn => d_csr_csgetptn procedure, pass(a) :: csgetptn => d_csr_csgetptn
procedure, pass(a) :: d_csgetrow => d_csr_csgetrow procedure, pass(a) :: d_csgetrow => d_csr_csgetrow
procedure, pass(a) :: get_nz_row => d_csr_get_nz_row procedure, pass(a) :: get_nz_row => d_csr_get_nz_row
@ -40,8 +38,13 @@ module psb_d_csr_mat_mod
procedure, pass(a) :: print => d_csr_print procedure, pass(a) :: print => d_csr_print
procedure, pass(a) :: sizeof => d_csr_sizeof procedure, pass(a) :: sizeof => d_csr_sizeof
procedure, pass(a) :: reinit => d_csr_reinit procedure, pass(a) :: reinit => d_csr_reinit
procedure, pass(a) :: d_csr_cp_from
generic, public :: cp_from => d_csr_cp_from
procedure, pass(a) :: d_csr_mv_from
generic, public :: mv_from => d_csr_mv_from
end type psb_d_csr_sparse_mat end type psb_d_csr_sparse_mat
private :: d_csr_get_nzeros, d_csr_csmm, d_csr_csmv, d_csr_cssm, d_csr_cssv, & private :: d_csr_get_nzeros, d_csr_csmm, d_csr_csmv, d_csr_cssm, d_csr_cssv, &
& d_csr_csput, d_csr_reallocate_nz, d_csr_allocate_mnnz, & & d_csr_csput, d_csr_reallocate_nz, d_csr_allocate_mnnz, &
& d_csr_free, d_csr_print, d_csr_get_fmt, d_csr_csnmi, get_diag, & & d_csr_free, d_csr_print, d_csr_get_fmt, d_csr_csnmi, get_diag, &
@ -1179,80 +1182,80 @@ contains
end subroutine d_csr_print end subroutine d_csr_print
!!$
!!$ subroutine d_csr_cp_from(a,b) subroutine d_csr_cp_from(a,b)
!!$ use psb_error_mod use psb_error_mod
!!$ implicit none implicit none
!!$
!!$ class(psb_d_csr_sparse_mat), intent(out) :: a class(psb_d_csr_sparse_mat), intent(out) :: a
!!$ class(psb_d_csr_sparse_mat), intent(inout) :: b type(psb_d_csr_sparse_mat), intent(in) :: b
!!$
!!$
!!$ Integer :: err_act, info Integer :: err_act, info
!!$ 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 = 0 info = 0
!!$
!!$ call a%allocate(b%get_nrows(),b%get_ncols(),b%get_nzeros()) call a%allocate(b%get_nrows(),b%get_ncols(),b%get_nzeros())
!!$ a%psb_d_base_sparse_mat = b%psb_d_base_sparse_mat call a%psb_d_base_sparse_mat%cp_from(b%psb_d_base_sparse_mat)
!!$ a%irp = b%irp a%irp = b%irp
!!$ a%ja = b%ja a%ja = b%ja
!!$ a%val = b%val a%val = b%val
!!$
!!$ if (info /= 0) goto 9999 if (info /= 0) 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 d_csr_cp_from end subroutine d_csr_cp_from
!!$
!!$ subroutine d_csr_mv_from(a,b) subroutine d_csr_mv_from(a,b)
!!$ use psb_error_mod use psb_error_mod
!!$ implicit none implicit none
!!$
!!$ class(psb_d_csr_sparse_mat), intent(out) :: a class(psb_d_csr_sparse_mat), intent(out) :: a
!!$ class(psb_d_csr_sparse_mat), intent(inout) :: b type(psb_d_csr_sparse_mat), intent(inout) :: b
!!$
!!$
!!$ Integer :: err_act, info Integer :: err_act, info
!!$ 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 = 0 info = 0
!!$ 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 d_csr_mv_from end subroutine d_csr_mv_from
!!$
!===================================== !=====================================

1924
base/modules/psb_d_mat_mod.f03
View File

File diff suppressed because it is too large Load Diff

1926
base/modules/psb_mat_mod.f03
View File

File diff suppressed because it is too large Load Diff

8
base/serial/f03/psbn_d_coo_impl.f03
Unescape Escape View File

@ -1849,7 +1849,7 @@ subroutine d_cp_coo_to_coo_impl(a,b,info)
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
info = 0 info = 0
call cp_from(b%psb_d_base_sparse_mat,a%psb_d_base_sparse_mat) call b%psb_d_base_sparse_mat%cp_from(a%psb_d_base_sparse_mat)
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())
@ -1894,7 +1894,7 @@ subroutine d_cp_coo_from_coo_impl(a,b,info)
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
info = 0 info = 0
call cp_from(a%psb_d_base_sparse_mat,b%psb_d_base_sparse_mat) call a%psb_d_base_sparse_mat%cp_from(b%psb_d_base_sparse_mat)
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())
@ -2311,7 +2311,7 @@ subroutine d_mv_coo_to_coo_impl(a,b,info)
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
info = 0 info = 0
call mv_from(b%psb_d_base_sparse_mat,a%psb_d_base_sparse_mat) call b%psb_d_base_sparse_mat%mv_from(a%psb_d_base_sparse_mat)
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())
@ -2356,7 +2356,7 @@ subroutine d_mv_coo_from_coo_impl(a,b,info)
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
info = 0 info = 0
call mv_from(a%psb_d_base_sparse_mat,b%psb_d_base_sparse_mat) call a%psb_d_base_sparse_mat%mv_from(b%psb_d_base_sparse_mat)
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())

12
base/serial/f03/psbn_d_csr_impl.f03
Unescape Escape View File

@ -1708,7 +1708,7 @@ subroutine d_cp_csr_to_coo_impl(a,b,info)
nza = a%get_nzeros() nza = a%get_nzeros()
call b%allocate(nr,nc,nza) call b%allocate(nr,nc,nza)
call cp_from(b%psb_d_base_sparse_mat,a%psb_d_base_sparse_mat) call b%psb_d_base_sparse_mat%cp_from(a%psb_d_base_sparse_mat)
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
@ -1749,7 +1749,7 @@ subroutine d_mv_csr_to_coo_impl(a,b,info)
nc = a%get_ncols() nc = a%get_ncols()
nza = a%get_nzeros() nza = a%get_nzeros()
call mv_from( b%psb_d_base_sparse_mat,a%psb_d_base_sparse_mat) call b%psb_d_base_sparse_mat%mv_from(a%psb_d_base_sparse_mat)
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)
@ -1796,7 +1796,7 @@ subroutine d_mv_csr_from_coo_impl(a,b,info)
nc = b%get_ncols() nc = b%get_ncols()
nza = b%get_nzeros() nza = b%get_nzeros()
call mv_from(a%psb_d_base_sparse_mat,b%psb_d_base_sparse_mat) call a%psb_d_base_sparse_mat%mv_from(b%psb_d_base_sparse_mat)
! 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)
@ -1884,7 +1884,7 @@ subroutine d_mv_csr_to_fmt_impl(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 mv_from(b%psb_d_base_sparse_mat,a%psb_d_base_sparse_mat) call b%psb_d_base_sparse_mat%mv_from(a%psb_d_base_sparse_mat)
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)
@ -1961,7 +1961,7 @@ subroutine d_mv_csr_from_fmt_impl(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 mv_from(a%psb_d_base_sparse_mat,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)
@ -2002,7 +2002,7 @@ subroutine d_cp_csr_from_fmt_impl(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 cp_from(a%psb_d_base_sparse_mat,b%psb_d_base_sparse_mat) call a%psb_d_base_sparse_mat%cp_from(b%psb_d_base_sparse_mat)
a%irp = b%irp a%irp = b%irp
a%ja = b%ja a%ja = b%ja
a%val = b%val a%val = b%val

261
test/pargen/psb_d_csc_impl.f03
Unescape Escape View File

@ -14,6 +14,7 @@
subroutine d_csc_csmv_impl(alpha,a,x,beta,y,info,trans) subroutine d_csc_csmv_impl(alpha,a,x,beta,y,info,trans)
use psb_error_mod use psb_error_mod
use psb_string_mod
use psb_d_csc_mat_mod, psb_protect_name => d_csc_csmv_impl use psb_d_csc_mat_mod, psb_protect_name => d_csc_csmv_impl
implicit none implicit none
class(psb_d_csc_sparse_mat), intent(in) :: a class(psb_d_csc_sparse_mat), intent(in) :: a
@ -46,7 +47,7 @@ subroutine d_csc_csmv_impl(alpha,a,x,beta,y,info,trans)
endif endif
tra = ((trans_=='T').or.(trans_=='t')) tra = (psb_toupper(trans_)=='T').or.(psb_toupper(trans_)=='C')
if (tra) then if (tra) then
m = a%get_ncols() m = a%get_ncols()
@ -277,6 +278,7 @@ end subroutine d_csc_csmv_impl
subroutine d_csc_csmm_impl(alpha,a,x,beta,y,info,trans) subroutine d_csc_csmm_impl(alpha,a,x,beta,y,info,trans)
use psb_error_mod use psb_error_mod
use psb_string_mod
use psb_d_csc_mat_mod, psb_protect_name => d_csc_csmm_impl use psb_d_csc_mat_mod, psb_protect_name => d_csc_csmm_impl
implicit none implicit none
class(psb_d_csc_sparse_mat), intent(in) :: a class(psb_d_csc_sparse_mat), intent(in) :: a
@ -302,7 +304,7 @@ subroutine d_csc_csmm_impl(alpha,a,x,beta,y,info,trans)
trans_ = 'N' trans_ = 'N'
end if end if
tra = ((trans_=='T').or.(trans_=='t')) tra = (psb_toupper(trans_)=='T').or.(psb_toupper(trans_)=='C')
if (.not.a%is_asb()) then if (.not.a%is_asb()) then
info = 1121 info = 1121
call psb_errpush(info,name) call psb_errpush(info,name)
@ -547,6 +549,7 @@ end subroutine d_csc_csmm_impl
subroutine d_csc_cssv_impl(alpha,a,x,beta,y,info,trans) subroutine d_csc_cssv_impl(alpha,a,x,beta,y,info,trans)
use psb_error_mod use psb_error_mod
use psb_string_mod
use psb_d_csc_mat_mod, psb_protect_name => d_csc_cssv_impl use psb_d_csc_mat_mod, psb_protect_name => d_csc_cssv_impl
implicit none implicit none
class(psb_d_csc_sparse_mat), intent(in) :: a class(psb_d_csc_sparse_mat), intent(in) :: a
@ -577,7 +580,7 @@ subroutine d_csc_cssv_impl(alpha,a,x,beta,y,info,trans)
goto 9999 goto 9999
endif endif
tra = ((trans_=='T').or.(trans_=='t')) tra = (psb_toupper(trans_)=='T').or.(psb_toupper(trans_)=='C')
m = a%get_nrows() m = a%get_nrows()
if (.not. (a%is_triangle())) then if (.not. (a%is_triangle())) then
@ -750,6 +753,7 @@ end subroutine d_csc_cssv_impl
subroutine d_csc_cssm_impl(alpha,a,x,beta,y,info,trans) subroutine d_csc_cssm_impl(alpha,a,x,beta,y,info,trans)
use psb_error_mod use psb_error_mod
use psb_string_mod
use psb_d_csc_mat_mod, psb_protect_name => d_csc_cssm_impl use psb_d_csc_mat_mod, psb_protect_name => d_csc_cssm_impl
implicit none implicit none
class(psb_d_csc_sparse_mat), intent(in) :: a class(psb_d_csc_sparse_mat), intent(in) :: a
@ -782,7 +786,7 @@ subroutine d_csc_cssm_impl(alpha,a,x,beta,y,info,trans)
endif endif
tra = ((trans_=='T').or.(trans_=='t')) tra = (psb_toupper(trans_)=='T').or.(psb_toupper(trans_)=='C')
m = a%get_nrows() m = a%get_nrows()
nc = min(size(x,2) , size(y,2)) nc = min(size(x,2) , size(y,2))
@ -1010,6 +1014,193 @@ end function d_csc_csnmi_impl
! !
!===================================== !=====================================
subroutine d_csc_csgetptn_impl(imin,imax,a,nz,ia,ja,info,&
& jmin,jmax,iren,append,nzin,rscale,cscale)
! Output is always in COO format
use psb_error_mod
use psb_const_mod
use psb_error_mod
use psb_d_base_mat_mod
use psb_d_csc_mat_mod, psb_protect_name => d_csc_csgetptn_impl
implicit none
class(psb_d_csc_sparse_mat), intent(in) :: a
integer, intent(in) :: imin,imax
integer, intent(out) :: nz
integer, allocatable, intent(inout) :: ia(:), ja(:)
integer,intent(out) :: info
logical, intent(in), optional :: append
integer, intent(in), optional :: iren(:)
integer, intent(in), optional :: jmin,jmax, nzin
logical, intent(in), optional :: rscale,cscale
logical :: append_, rscale_, cscale_
integer :: nzin_, jmin_, jmax_, err_act, i
character(len=20) :: name='csget'
logical, parameter :: debug=.false.
call psb_erractionsave(err_act)
info = 0
if (present(jmin)) then
jmin_ = jmin
else
jmin_ = 1
endif
if (present(jmax)) then
jmax_ = jmax
else
jmax_ = a%get_ncols()
endif
if ((imax<imin).or.(jmax_<jmin_)) return
if (present(append)) then
append_=append
else
append_=.false.
endif
if ((append_).and.(present(nzin))) then
nzin_ = nzin
else
nzin_ = 0
endif
if (present(rscale)) then
rscale_ = rscale
else
rscale_ = .false.
endif
if (present(cscale)) then
cscale_ = cscale
else
cscale_ = .false.
endif
if ((rscale_.or.cscale_).and.(present(iren))) then
info = 583
call psb_errpush(info,name,a_err='iren (rscale.or.cscale)')
goto 9999
end if
call csc_getptn(imin,imax,jmin_,jmax_,a,nz,ia,ja,nzin_,append_,info,iren)
if (rscale_) then
do i=nzin_+1, nzin_+nz
ia(i) = ia(i) - imin + 1
end do
end if
if (cscale_) then
do i=nzin_+1, nzin_+nz
ja(i) = ja(i) - jmin_ + 1
end do
end if
if (info /= 0) goto 9999
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_abort_) then
call psb_error()
return
end if
return
contains
subroutine csc_getptn(imin,imax,jmin,jmax,a,nz,ia,ja,nzin,append,info,&
& iren)
use psb_const_mod
use psb_error_mod
use psb_realloc_mod
use psb_sort_mod
implicit none
class(psb_d_csc_sparse_mat), intent(in) :: a
integer :: imin,imax,jmin,jmax
integer, intent(out) :: nz
integer, allocatable, intent(inout) :: ia(:), ja(:)
integer, intent(in) :: nzin
logical, intent(in) :: append
integer :: info
integer, optional :: iren(:)
integer :: nzin_, nza, idx,i,j,k, nzt, irw, lrw, icl, lcl,m,isz
integer :: debug_level, debug_unit
character(len=20) :: name='coo_getrow'
debug_unit = psb_get_debug_unit()
debug_level = psb_get_debug_level()
nza = a%get_nzeros()
irw = imin
lrw = min(imax,a%get_nrows())
icl = jmin
lcl = min(jmax,a%get_ncols())
if (irw<0) then
info = 2
return
end if
if (append) then
nzin_ = nzin
else
nzin_ = 0
endif
nzt = min((a%icp(lcl+1)-a%icp(icl)),&
& ((nza*(lcl+1-icl))/a%get_ncols()) )
nz = 0
call psb_ensure_size(nzin_+nzt,ia,info)
if (info==0) call psb_ensure_size(nzin_+nzt,ja,info)
if (info /= 0) return
isz = min(size(ia),size(ja))
if (present(iren)) then
do i=icl, lcl
do j=a%icp(i), a%icp(i+1) - 1
if ((imin <= a%ia(j)).and.(a%ia(j)<=imax)) then
nzin_ = nzin_ + 1
if (nzin_>isz) then
call psb_ensure_size(int(1.25*nzin_)+1,ia,info)
call psb_ensure_size(int(1.25*nzin_)+1,ja,info)
isz = min(size(ia),size(ja))
end if
nz = nz + 1
ia(nzin_) = iren(a%ia(j))
ja(nzin_) = iren(i)
end if
enddo
end do
else
do i=icl, lcl
do j=a%icp(i), a%icp(i+1) - 1
if ((imin <= a%ia(j)).and.(a%ia(j)<=imax)) then
nzin_ = nzin_ + 1
if (nzin_>isz) then
call psb_ensure_size(int(1.25*nzin_)+1,ia,info)
call psb_ensure_size(int(1.25*nzin_)+1,ja,info)
isz = min(size(ia),size(ja))
end if
nz = nz + 1
ia(nzin_) = (a%ia(j))
ja(nzin_) = (i)
end if
enddo
end do
end if
end subroutine csc_getptn
end subroutine d_csc_csgetptn_impl
subroutine d_csc_csgetrow_impl(imin,imax,a,nz,ia,ja,val,info,& subroutine d_csc_csgetrow_impl(imin,imax,a,nz,ia,ja,val,info,&
& jmin,jmax,iren,append,nzin,rscale,cscale) & jmin,jmax,iren,append,nzin,rscale,cscale)
@ -1521,6 +1712,7 @@ subroutine d_cp_csc_to_coo_impl(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)
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
@ -1531,13 +1723,6 @@ subroutine d_cp_csc_to_coo_impl(a,b,info)
end do end do
call b%set_nzeros(a%get_nzeros()) call b%set_nzeros(a%get_nzeros())
call b%set_nrows(a%get_nrows())
call b%set_ncols(a%get_ncols())
call b%set_dupl(a%get_dupl())
call b%set_state(a%get_state())
call b%set_triangle(a%is_triangle())
call b%set_upper(a%is_upper())
call b%set_unit(a%is_unit())
call b%fix(info) call b%fix(info)
@ -1569,15 +1754,8 @@ subroutine d_mv_csc_to_coo_impl(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 b%set_nzeros(a%get_nzeros()) call b%set_nzeros(a%get_nzeros())
call b%set_nrows(a%get_nrows())
call b%set_ncols(a%get_ncols())
call b%set_dupl(a%get_dupl())
call b%set_state(a%get_state())
call b%set_triangle(a%is_triangle())
call b%set_upper(a%is_upper())
call b%set_unit(a%is_unit())
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)
call psb_realloc(nza,b%ja,info) call psb_realloc(nza,b%ja,info)
@ -1622,13 +1800,8 @@ subroutine d_mv_csc_from_coo_impl(a,b,info)
nc = b%get_ncols() nc = b%get_ncols()
nza = b%get_nzeros() nza = b%get_nzeros()
call a%set_nrows(b%get_nrows()) call a%psb_d_base_sparse_mat%mv_from(b%psb_d_base_sparse_mat)
call a%set_ncols(b%get_ncols())
call a%set_dupl(b%get_dupl())
call a%set_state(b%get_state())
call a%set_triangle(b%is_triangle())
call a%set_upper(b%is_upper())
call a%set_unit(b%is_unit())
! 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)
call move_alloc(b%ia,a%ia) call move_alloc(b%ia,a%ia)
@ -1711,11 +1884,16 @@ subroutine d_mv_csc_to_fmt_impl(a,b,info)
info = 0 info = 0
select type (b) select type (b)
class is (psb_d_coo_sparse_mat) type is (psb_d_coo_sparse_mat)
call a%mv_to_coo(b,info) call a%mv_to_coo(b,info)
! Need to fix trivial copies! ! Need to fix trivial copies!
! !$ class is (psb_d_csc_sparse_mat) type is (psb_d_csc_sparse_mat)
! !$ call a%mv_to_coo(b,info) call b%psb_d_base_sparse_mat%mv_from(a%psb_d_base_sparse_mat)
call move_alloc(a%icp, b%icp)
call move_alloc(a%ia, b%ia)
call move_alloc(a%val, b%val)
call a%free()
class default class default
call tmp%mv_from_fmt(a,info) call tmp%mv_from_fmt(a,info)
if (info == 0) call b%mv_from_coo(tmp,info) if (info == 0) call b%mv_from_coo(tmp,info)
@ -1747,8 +1925,12 @@ subroutine d_cp_csc_to_fmt_impl(a,b,info)
select type (b) select type (b)
class is (psb_d_coo_sparse_mat) type is (psb_d_coo_sparse_mat)
call a%cp_to_coo(b,info) call a%cp_to_coo(b,info)
type is (psb_d_csc_sparse_mat)
b = a
class default class default
call tmp%cp_from_fmt(a,info) call tmp%cp_from_fmt(a,info)
if (info == 0) call b%mv_from_coo(tmp,info) if (info == 0) call b%mv_from_coo(tmp,info)
@ -1779,8 +1961,16 @@ subroutine d_mv_csc_from_fmt_impl(a,b,info)
info = 0 info = 0
select type (b) select type (b)
class is (psb_d_coo_sparse_mat) type is (psb_d_coo_sparse_mat)
call a%mv_from_coo(b,info) call a%mv_from_coo(b,info)
type is (psb_d_csc_sparse_mat)
call a%psb_d_base_sparse_mat%mv_from(b%psb_d_base_sparse_mat)
call move_alloc(b%icp, a%icp)
call move_alloc(b%ia, a%ia)
call move_alloc(b%val, a%val)
call b%free()
class default class default
call tmp%mv_from_fmt(b,info) call tmp%mv_from_fmt(b,info)
if (info == 0) call a%mv_from_coo(tmp,info) if (info == 0) call a%mv_from_coo(tmp,info)
@ -1812,8 +2002,15 @@ subroutine d_cp_csc_from_fmt_impl(a,b,info)
info = 0 info = 0
select type (b) select type (b)
class is (psb_d_coo_sparse_mat) type is (psb_d_coo_sparse_mat)
call a%cp_from_coo(b,info) call a%cp_from_coo(b,info)
type is (psb_d_csc_sparse_mat)
call a%psb_d_base_sparse_mat%cp_from(b%psb_d_base_sparse_mat)
a%icp = b%icp
a%ia = b%ia
a%val = b%val
class default class default
call tmp%cp_from_fmt(b,info) call tmp%cp_from_fmt(b,info)
if (info == 0) call a%mv_from_coo(tmp,info) if (info == 0) call a%mv_from_coo(tmp,info)

218
test/pargen/psb_d_csc_mat_mod.f03
Unescape Escape View File

@ -29,13 +29,20 @@ module psb_d_csc_mat_mod
procedure, pass(a) :: mv_from_coo => d_mv_csc_from_coo procedure, pass(a) :: mv_from_coo => d_mv_csc_from_coo
procedure, pass(a) :: mv_to_fmt => d_mv_csc_to_fmt procedure, pass(a) :: mv_to_fmt => d_mv_csc_to_fmt
procedure, pass(a) :: mv_from_fmt => d_mv_csc_from_fmt procedure, pass(a) :: mv_from_fmt => d_mv_csc_from_fmt
procedure, pass(a) :: csgetptn => d_csc_csgetptn
procedure, pass(a) :: d_csgetrow => d_csc_csgetrow procedure, pass(a) :: d_csgetrow => d_csc_csgetrow
procedure, pass(a) :: get_size => d_csc_get_size procedure, pass(a) :: get_size => d_csc_get_size
procedure, pass(a) :: free => d_csc_free procedure, pass(a) :: free => d_csc_free
procedure, pass(a) :: trim => d_csc_trim procedure, pass(a) :: trim => d_csc_trim
procedure, pass(a) :: print => d_csc_print procedure, pass(a) :: print => d_csc_print
procedure, pass(a) :: sizeof => d_csc_sizeof procedure, pass(a) :: sizeof => d_csc_sizeof
procedure, pass(a) :: reinit => d_csc_reinit
procedure, pass(a) :: d_csc_cp_from
generic, public :: cp_from => d_csc_cp_from
procedure, pass(a) :: d_csc_mv_from
generic, public :: mv_from => d_csc_mv_from
end type psb_d_csc_sparse_mat end type psb_d_csc_sparse_mat
private :: d_csc_get_nzeros, d_csc_csmm, d_csc_csmv, d_csc_cssm, d_csc_cssv, & private :: d_csc_get_nzeros, d_csc_csmm, d_csc_csmv, d_csc_cssm, d_csc_cssv, &
& d_csc_csput, d_csc_reallocate_nz, d_csc_allocate_mnnz, & & d_csc_csput, d_csc_reallocate_nz, d_csc_allocate_mnnz, &
& d_csc_free, d_csc_print, d_csc_get_fmt, d_csc_csnmi, get_diag, & & d_csc_free, d_csc_print, d_csc_get_fmt, d_csc_csnmi, get_diag, &
@ -44,7 +51,7 @@ module psb_d_csc_mat_mod
& d_cp_csc_to_fmt, d_cp_csc_from_fmt, & & d_cp_csc_to_fmt, d_cp_csc_from_fmt, &
& d_mv_csc_to_fmt, d_mv_csc_from_fmt, & & d_mv_csc_to_fmt, d_mv_csc_from_fmt, &
& d_csc_scals, d_csc_scal, d_csc_trim, d_csc_csgetrow, d_csc_get_size, & & d_csc_scals, d_csc_scal, d_csc_trim, d_csc_csgetrow, d_csc_get_size, &
& d_csc_sizeof & d_csc_sizeof, d_csc_csgetptn, d_csc_get_nz_row, d_csc_reinit
interface interface
@ -149,6 +156,25 @@ module psb_d_csc_mat_mod
end subroutine d_csc_csput_impl end subroutine d_csc_csput_impl
end interface end interface
interface
subroutine d_csc_csgetptn_impl(imin,imax,a,nz,ia,ja,info,&
& jmin,jmax,iren,append,nzin,rscale,cscale)
use psb_const_mod
import psb_d_csc_sparse_mat
implicit none
class(psb_d_csc_sparse_mat), intent(in) :: a
integer, intent(in) :: imin,imax
integer, intent(out) :: nz
integer, allocatable, intent(inout) :: ia(:), ja(:)
integer,intent(out) :: info
logical, intent(in), optional :: append
integer, intent(in), optional :: iren(:)
integer, intent(in), optional :: jmin,jmax, nzin
logical, intent(in), optional :: rscale,cscale
end subroutine d_csc_csgetptn_impl
end interface
interface interface
subroutine d_csc_csgetrow_impl(imin,imax,a,nz,ia,ja,val,info,& subroutine d_csc_csgetrow_impl(imin,imax,a,nz,ia,ja,val,info,&
& jmin,jmax,iren,append,nzin,rscale,cscale) & jmin,jmax,iren,append,nzin,rscale,cscale)
@ -259,7 +285,7 @@ contains
implicit none implicit none
class(psb_d_csc_sparse_mat), intent(in) :: a class(psb_d_csc_sparse_mat), intent(in) :: a
integer :: res integer :: res
res = a%icp(a%m+1)-1 res = a%icp(a%get_ncols()+1)-1
end function d_csc_get_nzeros end function d_csc_get_nzeros
function d_csc_get_size(a) result(res) function d_csc_get_size(a) result(res)
@ -286,6 +312,26 @@ contains
end function d_csc_get_size end function d_csc_get_size
function d_csc_get_nz_col(idx,a) result(res)
use psb_const_mod
implicit none
class(psb_d_csc_sparse_mat), intent(in) :: a
integer, intent(in) :: idx
integer :: res
res = 0
if ((1<=idx).and.(idx<=a%get_ncols())) then
res = a%icp(idx+1)-a%icp(idx)
end if
end function d_csc_get_nz_col
!===================================== !=====================================
! !
! !
@ -313,7 +359,7 @@ contains
call psb_realloc(nz,a%ia,info) call psb_realloc(nz,a%ia,info)
if (info == 0) call psb_realloc(nz,a%val,info) if (info == 0) call psb_realloc(nz,a%val,info)
if (info == 0) call psb_realloc(max(nz,a%m+1,a%n+1),a%icp,info) if (info == 0) call psb_realloc(max(nz,a%get_nrows()+1,a%get_ncols()+1),a%icp,info)
if (info /= 0) then if (info /= 0) then
call psb_errpush(4000,name) call psb_errpush(4000,name)
goto 9999 goto 9999
@ -396,6 +442,49 @@ contains
return return
end subroutine d_csc_csput end subroutine d_csc_csput
subroutine d_csc_csgetptn(imin,imax,a,nz,ia,ja,info,&
& jmin,jmax,iren,append,nzin,rscale,cscale)
! Output is always in COO format
use psb_error_mod
use psb_const_mod
implicit none
class(psb_d_csc_sparse_mat), intent(in) :: a
integer, intent(in) :: imin,imax
integer, intent(out) :: nz
integer, allocatable, intent(inout) :: ia(:), ja(:)
integer,intent(out) :: info
logical, intent(in), optional :: append
integer, intent(in), optional :: iren(:)
integer, intent(in), optional :: jmin,jmax, nzin
logical, intent(in), optional :: rscale,cscale
Integer :: err_act
character(len=20) :: name='csget'
logical, parameter :: debug=.false.
call psb_erractionsave(err_act)
info = 0
call d_csc_csgetptn_impl(imin,imax,a,nz,ia,ja,info,&
& jmin,jmax,iren,append,nzin,rscale,cscale)
if (info /= 0) goto 9999
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_abort_) then
call psb_error()
return
end if
return
end subroutine d_csc_csgetptn
subroutine d_csc_csgetrow(imin,imax,a,nz,ia,ja,val,info,& subroutine d_csc_csgetrow(imin,imax,a,nz,ia,ja,val,info,&
& jmin,jmax,iren,append,nzin,rscale,cscale) & jmin,jmax,iren,append,nzin,rscale,cscale)
! Output is always in COO format ! Output is always in COO format
@ -605,6 +694,54 @@ contains
end subroutine d_csc_free end subroutine d_csc_free
subroutine d_csc_reinit(a,clear)
use psb_error_mod
implicit none
class(psb_d_csc_sparse_mat), intent(inout) :: a
logical, intent(in), optional :: clear
Integer :: err_act, info
character(len=20) :: name='reinit'
logical :: clear_
logical, parameter :: debug=.false.
call psb_erractionsave(err_act)
info = 0
if (present(clear)) then
clear_ = clear
else
clear_ = .true.
end if
if (a%is_bld() .or. a%is_upd()) then
! do nothing
return
else if (a%is_asb()) then
if (clear_) a%val(:) = dzero
call a%set_upd()
else
info = 1121
call psb_errpush(info,name)
goto 9999
end if
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_abort_) then
call psb_error()
return
end if
return
end subroutine d_csc_reinit
subroutine d_csc_trim(a) subroutine d_csc_trim(a)
use psb_realloc_mod use psb_realloc_mod
use psb_error_mod use psb_error_mod
@ -1038,6 +1175,81 @@ contains
end subroutine d_csc_print end subroutine d_csc_print
subroutine d_csc_cp_from(a,b)
use psb_error_mod
implicit none
class(psb_d_csc_sparse_mat), intent(out) :: a
type(psb_d_csc_sparse_mat), intent(in) :: b
Integer :: err_act, info
character(len=20) :: name='cp_from'
logical, parameter :: debug=.false.
call psb_erractionsave(err_act)
info = 0
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)
a%icp = b%icp
a%ia = b%ia
a%val = b%val
if (info /= 0) goto 9999
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
call psb_errpush(info,name)
if (err_act /= psb_act_ret_) then
call psb_error()
end if
return
end subroutine d_csc_cp_from
subroutine d_csc_mv_from(a,b)
use psb_error_mod
implicit none
class(psb_d_csc_sparse_mat), intent(out) :: a
type(psb_d_csc_sparse_mat), intent(inout) :: b
Integer :: err_act, info
character(len=20) :: name='mv_from'
logical, parameter :: debug=.false.
call psb_erractionsave(err_act)
info = 0
call a%psb_d_base_sparse_mat%mv_from(b%psb_d_base_sparse_mat)
call move_alloc(b%icp, a%icp)
call move_alloc(b%ia, a%ia)
call move_alloc(b%val, a%val)
call b%free()
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
call psb_errpush(info,name)
if (err_act /= psb_act_ret_) then
call psb_error()
end if
return
end subroutine d_csc_mv_from
!===================================== !=====================================
! !
! !

Write Preview
Loading…
Cancel
Save