fdurastante/psblas3
1
0
Fork 0
mirror of https://github.com/sfilippone/psblas3.git synced 2026-10-20 21:02:26 +00:00
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.
This commit is contained in:
Salvatore Filippone
2009-09-23 15:30:52 +00:00
parent 720fbd161a
commit 196539d626
11 changed files with 2577 additions and 2180 deletions
Download Patch File Download Diff File Expand all files Collapse all files
base/modules/Makefile
+3 -2
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\
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_d_csr_mat_mod.o
psb_d_csr_mat_mod.o psb_d_mat_mod.o
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_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_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
base/modules/README.F2003
-2
View File
@@ -98,8 +98,6 @@ Design principles for this directory.
AND IT'S DONE! Nothing else in the library requires the explicit
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.)
base/modules/psb_base_mat_mod.f03
+11 -17
View File
@@ -3,9 +3,9 @@ module psb_base_mat_mod
use psb_const_mod
type :: psb_base_sparse_mat
integer :: m, n
integer :: state, duplicate
logical :: triangle, unitd, upper, sorted
integer, private :: m, n
integer, private :: state, duplicate
logical, private :: triangle, unitd, upper, sorted
! This is a different animal: it's a kitchen sink for
! any additional parameters that may be needed
! when converting to/from COO. Why here?
@@ -64,7 +64,6 @@ module psb_base_mat_mod
! Data management
!
! ====================================
procedure, pass(a) :: get_neigh
procedure, pass(a) :: allocate_mnnz
procedure, pass(a) :: reallocate_nz
@@ -76,9 +75,11 @@ module psb_base_mat_mod
procedure, pass(a) :: csgetptn
generic, public :: csget => csgetptn
procedure, pass(a) :: print => sparse_print
procedure, pass(a) :: sizeof
!!$ procedure, pass(a) :: base_cp_from
!!$ procedure, pass(a) :: base_mv_from
procedure, pass(a) :: sizeof
procedure, pass(a) :: base_cp_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
@@ -89,14 +90,7 @@ module psb_base_mat_mod
& is_upd, is_asb, is_sorted, is_upper, is_lower, is_triangle, &
& is_unit, get_neigh, allocate_mn, allocate_mnnz, reallocate_nz, &
& free, sparse_print, get_fmt, trim, sizeof, reinit, csgetptn, &
& get_nz_row, get_aux, set_aux
!!$, 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
& get_nz_row, get_aux, set_aux, base_cp_from, base_mv_from
contains
@@ -449,7 +443,7 @@ contains
use psb_error_mod
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
a%m = b%m
@@ -470,7 +464,7 @@ contains
use psb_error_mod
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
a%m = b%m
base/modules/psb_d_base_mat_mod.f03
+106 -112
View File
@@ -32,25 +32,17 @@ module psb_d_base_mat_mod
procedure, pass(a) :: mv_from_coo
procedure, pass(a) :: mv_to_fmt
procedure, pass(a) :: mv_from_fmt
!!$ procedure, pass(a) :: base_cp_from => d_base_cp_from
!!$ procedure, pass(a) :: base_mv_from => d_base_mv_from
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
end type psb_d_base_sparse_mat
private :: d_base_csmv, d_base_csmm, d_base_cssv, d_base_cssm,&
& d_scals, d_scal, csnmi, csput, d_csgetrow, d_csgetblk, &
& cp_to_coo, cp_from_coo, cp_to_fmt, cp_from_fmt, &
& mv_to_coo, mv_from_coo, mv_to_fmt, mv_from_fmt, &
& get_diag, csclip, d_cssv, d_cssm
!!$, &
!!$ & 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
& get_diag, csclip, d_cssv, d_cssm, base_cp_from, base_mv_from
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) :: sizeof => d_coo_sizeof
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
@@ -102,7 +98,8 @@ module psb_d_base_mat_mod
& d_cp_coo_to_coo, d_cp_coo_from_coo, &
& d_cp_coo_to_fmt, d_cp_coo_from_fmt, &
& 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
@@ -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)
use psb_error_mod
use psb_realloc_mod
@@ -570,6 +534,36 @@ contains
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)
use psb_error_mod
@@ -1658,71 +1652,71 @@ contains
end subroutine d_mv_coo_from_coo
!!$
!!$ subroutine d_coo_cp_from(a,b)
!!$ use psb_error_mod
!!$ implicit none
!!$
!!$ class(psb_d_coo_sparse_mat), intent(out) :: a
!!$ type(psb_d_coo_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 d_cp_coo_from_coo_impl(a,b,info)
!!$ 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_coo_cp_from
!!$
!!$ subroutine d_coo_mv_from(a,b)
!!$ use psb_error_mod
!!$ implicit none
!!$
!!$ class(psb_d_coo_sparse_mat), intent(out) :: a
!!$ type(psb_d_coo_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 d_mv_coo_from_coo_impl(a,b,info)
!!$ 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_coo_mv_from
!!$
subroutine d_coo_cp_from(a,b)
use psb_error_mod
implicit none
class(psb_d_coo_sparse_mat), intent(out) :: a
type(psb_d_coo_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 d_cp_coo_from_coo_impl(a,b,info)
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_coo_cp_from
subroutine d_coo_mv_from(a,b)
use psb_error_mod
implicit none
class(psb_d_coo_sparse_mat), intent(out) :: a
type(psb_d_coo_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 d_mv_coo_from_coo_impl(a,b,info)
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_coo_mv_from
subroutine d_mv_coo_to_fmt(a,b,info)
use psb_error_mod
base/modules/psb_d_csr_mat_mod.f03
+79 -76
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_to_fmt => d_mv_csr_to_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) :: d_csgetrow => d_csr_csgetrow
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) :: sizeof => d_csr_sizeof
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
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_free, d_csr_print, d_csr_get_fmt, d_csr_csnmi, get_diag, &
@@ -1179,80 +1182,80 @@ contains
end subroutine d_csr_print
!!$
!!$ subroutine d_csr_cp_from(a,b)
!!$ use psb_error_mod
!!$ implicit none
!!$
!!$ class(psb_d_csr_sparse_mat), intent(out) :: a
!!$ class(psb_d_csr_sparse_mat), intent(inout) :: 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())
!!$ a%psb_d_base_sparse_mat = b%psb_d_base_sparse_mat
!!$ a%irp = b%irp
!!$ a%ja = b%ja
!!$ 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_csr_cp_from
!!$
!!$ subroutine d_csr_mv_from(a,b)
!!$ use psb_error_mod
!!$ implicit none
!!$
!!$ class(psb_d_csr_sparse_mat), intent(out) :: a
!!$ class(psb_d_csr_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%irp, a%irp)
!!$ call move_alloc(b%ja, a%ja)
!!$ call move_alloc(b%val, a%val)
!!$ call b%free()
!!$
!!$ call psb_erractionrestore(err_act)
!!$ return
!!$
!!$9999 continue
!!$ call psb_erractionrestore(err_act)
!!$
!!$ call psb_errpush(info,name)
!!$
!!$ if (err_act /= psb_act_ret_) then
!!$ call psb_error()
!!$ end if
!!$ return
!!$
!!$ end subroutine d_csr_mv_from
!!$
subroutine d_csr_cp_from(a,b)
use psb_error_mod
implicit none
class(psb_d_csr_sparse_mat), intent(out) :: a
type(psb_d_csr_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%irp = b%irp
a%ja = b%ja
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_csr_cp_from
subroutine d_csr_mv_from(a,b)
use psb_error_mod
implicit none
class(psb_d_csr_sparse_mat), intent(out) :: a
type(psb_d_csr_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%irp, a%irp)
call move_alloc(b%ja, a%ja)
call move_alloc(b%val, a%val)
call b%free()
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
call psb_errpush(info,name)
if (err_act /= psb_act_ret_) then
call psb_error()
end if
return
end subroutine d_csr_mv_from
!=====================================
base/modules/psb_d_mat_mod.f03
+1924
View File
File diff suppressed because it is too large Load Diff
base/modules/psb_mat_mod.f03
-1926
View File
File diff suppressed because it is too large Load Diff
base/serial/f03/psbn_d_coo_impl.f03
+4 -4
View File
@@ -1849,7 +1849,7 @@ subroutine d_cp_coo_to_coo_impl(a,b,info)
call psb_erractionsave(err_act)
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%reallocate(a%get_nzeros())
@@ -1894,7 +1894,7 @@ subroutine d_cp_coo_from_coo_impl(a,b,info)
call psb_erractionsave(err_act)
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%reallocate(b%get_nzeros())
@@ -2311,7 +2311,7 @@ subroutine d_mv_coo_to_coo_impl(a,b,info)
call psb_erractionsave(err_act)
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%reallocate(a%get_nzeros())
@@ -2356,7 +2356,7 @@ subroutine d_mv_coo_from_coo_impl(a,b,info)
call psb_erractionsave(err_act)
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%reallocate(b%get_nzeros())
base/serial/f03/psbn_d_csr_impl.f03
+6 -6
View File
@@ -1708,7 +1708,7 @@ subroutine d_cp_csr_to_coo_impl(a,b,info)
nza = a%get_nzeros()
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 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()
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 move_alloc(a%ja,b%ja)
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()
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.
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)
! Need to fix trivial copies!
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%ja, b%ja)
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)
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%ja, a%ja)
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)
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%ja = b%ja
a%val = b%val
test/pargen/psb_d_csc_impl.f03
+229 -32
View File
@@ -14,6 +14,7 @@
subroutine d_csc_csmv_impl(alpha,a,x,beta,y,info,trans)
use psb_error_mod
use psb_string_mod
use psb_d_csc_mat_mod, psb_protect_name => d_csc_csmv_impl
implicit none
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
tra = ((trans_=='T').or.(trans_=='t'))
tra = (psb_toupper(trans_)=='T').or.(psb_toupper(trans_)=='C')
if (tra) then
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)
use psb_error_mod
use psb_string_mod
use psb_d_csc_mat_mod, psb_protect_name => d_csc_csmm_impl
implicit none
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'
end if
tra = ((trans_=='T').or.(trans_=='t'))
tra = (psb_toupper(trans_)=='T').or.(psb_toupper(trans_)=='C')
if (.not.a%is_asb()) then
info = 1121
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)
use psb_error_mod
use psb_string_mod
use psb_d_csc_mat_mod, psb_protect_name => d_csc_cssv_impl
implicit none
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
endif
tra = ((trans_=='T').or.(trans_=='t'))
tra = (psb_toupper(trans_)=='T').or.(psb_toupper(trans_)=='C')
m = a%get_nrows()
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)
use psb_error_mod
use psb_string_mod
use psb_d_csc_mat_mod, psb_protect_name => d_csc_cssm_impl
implicit none
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
tra = ((trans_=='T').or.(trans_=='t'))
tra = (psb_toupper(trans_)=='T').or.(psb_toupper(trans_)=='C')
m = a%get_nrows()
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,&
& 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()
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 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
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)
@@ -1569,15 +1754,8 @@ subroutine d_mv_csc_to_coo_impl(a,b,info)
nc = a%get_ncols()
nza = a%get_nzeros()
call b%psb_d_base_sparse_mat%mv_from(a%psb_d_base_sparse_mat)
call 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%val,b%val)
call psb_realloc(nza,b%ja,info)
@@ -1621,14 +1799,9 @@ subroutine d_mv_csc_from_coo_impl(a,b,info)
nr = b%get_nrows()
nc = b%get_ncols()
nza = b%get_nzeros()
call a%psb_d_base_sparse_mat%mv_from(b%psb_d_base_sparse_mat)
call a%set_nrows(b%get_nrows())
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.
call move_alloc(b%ja,itemp)
call move_alloc(b%ia,a%ia)
@@ -1711,11 +1884,16 @@ subroutine d_mv_csc_to_fmt_impl(a,b,info)
info = 0
select type (b)
class is (psb_d_coo_sparse_mat)
type is (psb_d_coo_sparse_mat)
call a%mv_to_coo(b,info)
! Need to fix trivial copies!
! !$ class is (psb_d_csc_sparse_mat)
! !$ call a%mv_to_coo(b,info)
type is (psb_d_csc_sparse_mat)
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
call tmp%mv_from_fmt(a,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)
class is (psb_d_coo_sparse_mat)
type is (psb_d_coo_sparse_mat)
call a%cp_to_coo(b,info)
type is (psb_d_csc_sparse_mat)
b = a
class default
call tmp%cp_from_fmt(a,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
select type (b)
class is (psb_d_coo_sparse_mat)
type is (psb_d_coo_sparse_mat)
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
call tmp%mv_from_fmt(b,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
select type (b)
class is (psb_d_coo_sparse_mat)
type is (psb_d_coo_sparse_mat)
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
call tmp%cp_from_fmt(b,info)
if (info == 0) call a%mv_from_coo(tmp,info)
test/pargen/psb_d_csc_mat_mod.f03
+215 -3
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_to_fmt => d_mv_csc_to_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) :: get_size => d_csc_get_size
procedure, pass(a) :: free => d_csc_free
procedure, pass(a) :: trim => d_csc_trim
procedure, pass(a) :: print => d_csc_print
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
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_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_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_sizeof
& d_csc_sizeof, d_csc_csgetptn, d_csc_get_nz_row, d_csc_reinit
interface
@@ -149,6 +156,25 @@ module psb_d_csc_mat_mod
end subroutine d_csc_csput_impl
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
subroutine d_csc_csgetrow_impl(imin,imax,a,nz,ia,ja,val,info,&
& jmin,jmax,iren,append,nzin,rscale,cscale)
@@ -259,7 +285,7 @@ contains
implicit none
class(psb_d_csc_sparse_mat), intent(in) :: a
integer :: res
res = a%icp(a%m+1)-1
res = a%icp(a%get_ncols()+1)-1
end function d_csc_get_nzeros
function d_csc_get_size(a) result(res)
@@ -286,6 +312,26 @@ contains
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)
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
call psb_errpush(4000,name)
goto 9999
@@ -396,6 +442,49 @@ contains
return
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,&
& jmin,jmax,iren,append,nzin,rscale,cscale)
! Output is always in COO format
@@ -605,6 +694,54 @@ contains
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)
use psb_realloc_mod
use psb_error_mod
@@ -1038,6 +1175,81 @@ contains
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
!=====================================
!
!