fdurastante/psblas3
1
0
Fork 0
mirror of https://github.com/sfilippone/psblas3.git synced 2026-10-19 20:32:12 +00:00
Code Issues Packages Projects Releases Wiki Activity

psblas3:

Browse Source 
base/newserial/Makefile
 base/newserial/psbn_base_mat_mod.f03
 base/newserial/psbn_d_base_mat_mod.f03
 base/newserial/psbn_d_coo_impl.f03
 base/newserial/psbn_d_csr_impl.f03
 base/newserial/psbn_d_csr_mat_mod.f03
 base/newserial/psbn_mat_impl.f03
 base/newserial/psbn_mat_mod.f03
 base/serial/csr/dcsrsm.f
 test/pargen/runs/ppde.inp
 test/serial
 test/serial/Makefile
 test/serial/d_coo_matgen.f03

Added serial test directory.
First tests of conversion COO-CSR
This commit is contained in:
Salvatore Filippone
2009-09-09 10:04:38 +00:00
parent 9bee709ca3
commit 95aeca09c3
12 changed files with 2538 additions and 895 deletions
Download Patch File Download Diff File Expand all files Collapse all files
base/newserial/Makefile
+2
View File
@@ -19,7 +19,9 @@ lib: $(MODULES) $(OBJS) $(LIBMOD)
psbn_mat_mod.o: psbn_base_mat_mod.o
psbn_coo_mat.o psbn_csr_mat.o: psbn_d_base_mat_mod.o
psbn_d_coo_impl.o: psbn_d_base_mat_mod.o
psbn_d_csr_impl.o: psbn_d_csr_mat_mod.o
psbn_mat_impl.o: psbn_mat_mod.o
clean:
base/newserial/psbn_base_mat_mod.f03
+68 -2
View File
@@ -69,19 +69,23 @@ module psbn_base_mat_mod
procedure, pass(a) :: free
generic, public :: allocate => allocate_mn, allocate_mnnz
generic, public :: reallocate => reallocate_nz
procedure, pass(a) :: print => sparse_print
end type psbn_base_sparse_mat
private :: set_nrows, set_ncols, set_dupl, set_state, &
& set_null, set_bld, set_upd, set_asb, set_sorted, set_upper, &
& set_lower, set_triangle, set_unit, get_nrows, get_ncols, &
& get_nzeros, get_size, get_state, get_dupl, is_null, is_bld, &
& is_upd, is_asb, is_sorted, is_upper, is_lower, is_triangle, &
& is_unit, get_neigh, allocate_mn, allocate_mnnz, reallocate_nz, &
& free
& free, sparse_print
contains
function get_dupl(a) result(res)
implicit none
class(psbn_base_sparse_mat), intent(in) :: a
integer :: res
res = a%duplicate
@@ -89,18 +93,21 @@ contains
function get_state(a) result(res)
implicit none
class(psbn_base_sparse_mat), intent(in) :: a
integer :: res
res = a%state
end function get_state
function get_nrows(a) result(res)
implicit none
class(psbn_base_sparse_mat), intent(in) :: a
integer :: res
res = a%m
end function get_nrows
function get_ncols(a) result(res)
implicit none
class(psbn_base_sparse_mat), intent(in) :: a
integer :: res
res = a%n
@@ -108,12 +115,14 @@ contains
subroutine set_nrows(m,a)
implicit none
class(psbn_base_sparse_mat), intent(inout) :: a
integer, intent(in) :: m
a%m = m
end subroutine set_nrows
subroutine set_ncols(n,a)
implicit none
class(psbn_base_sparse_mat), intent(inout) :: a
integer, intent(in) :: n
a%n = n
@@ -121,6 +130,7 @@ contains
subroutine set_state(n,a)
implicit none
class(psbn_base_sparse_mat), intent(inout) :: a
integer, intent(in) :: n
a%state = n
@@ -128,36 +138,42 @@ contains
subroutine set_dupl(n,a)
implicit none
class(psbn_base_sparse_mat), intent(inout) :: a
integer, intent(in) :: n
a%duplicate = n
end subroutine set_dupl
subroutine set_null(a)
implicit none
class(psbn_base_sparse_mat), intent(inout) :: a
a%state = psbn_spmat_null_
end subroutine set_null
subroutine set_bld(a)
implicit none
class(psbn_base_sparse_mat), intent(inout) :: a
a%state = psbn_spmat_bld_
end subroutine set_bld
subroutine set_upd(a)
implicit none
class(psbn_base_sparse_mat), intent(inout) :: a
a%state = psbn_spmat_upd_
end subroutine set_upd
subroutine set_asb(a)
implicit none
class(psbn_base_sparse_mat), intent(inout) :: a
a%state = psbn_spmat_asb_
end subroutine set_asb
subroutine set_sorted(a,val)
implicit none
class(psbn_base_sparse_mat), intent(inout) :: a
logical, intent(in), optional :: val
@@ -169,6 +185,7 @@ contains
end subroutine set_sorted
subroutine set_triangle(a,val)
implicit none
class(psbn_base_sparse_mat), intent(inout) :: a
logical, intent(in), optional :: val
@@ -180,6 +197,7 @@ contains
end subroutine set_triangle
subroutine set_unit(a,val)
implicit none
class(psbn_base_sparse_mat), intent(inout) :: a
logical, intent(in), optional :: val
@@ -191,6 +209,7 @@ contains
end subroutine set_unit
subroutine set_lower(a,val)
implicit none
class(psbn_base_sparse_mat), intent(inout) :: a
logical, intent(in), optional :: val
@@ -202,6 +221,7 @@ contains
end subroutine set_lower
subroutine set_upper(a,val)
implicit none
class(psbn_base_sparse_mat), intent(inout) :: a
logical, intent(in), optional :: val
@@ -213,54 +233,63 @@ contains
end subroutine set_upper
function is_triangle(a) result(res)
implicit none
class(psbn_base_sparse_mat), intent(in) :: a
logical :: res
res = a%triangle
end function is_triangle
function is_unit(a) result(res)
implicit none
class(psbn_base_sparse_mat), intent(in) :: a
logical :: res
res = a%unitd
end function is_unit
function is_upper(a) result(res)
implicit none
class(psbn_base_sparse_mat), intent(in) :: a
logical :: res
res = a%upper
end function is_upper
function is_lower(a) result(res)
implicit none
class(psbn_base_sparse_mat), intent(in) :: a
logical :: res
res = .not.a%upper
end function is_lower
function is_null(a) result(res)
implicit none
class(psbn_base_sparse_mat), intent(in) :: a
logical :: res
res = (a%state == psbn_spmat_null_)
end function is_null
function is_bld(a) result(res)
implicit none
class(psbn_base_sparse_mat), intent(in) :: a
logical :: res
res = (a%state == psbn_spmat_bld_)
end function is_bld
function is_upd(a) result(res)
implicit none
class(psbn_base_sparse_mat), intent(in) :: a
logical :: res
res = (a%state == psbn_spmat_upd_)
end function is_upd
function is_asb(a) result(res)
implicit none
class(psbn_base_sparse_mat), intent(in) :: a
logical :: res
res = (a%state == psbn_spmat_asb_)
end function is_asb
function is_sorted(a) result(res)
implicit none
class(psbn_base_sparse_mat), intent(in) :: a
logical :: res
res = a%sorted
@@ -269,6 +298,7 @@ contains
function get_nzeros(a) result(res)
use psb_error_mod
implicit none
class(psbn_base_sparse_mat), intent(in) :: a
integer :: res
@@ -292,6 +322,7 @@ contains
function get_size(a) result(res)
use psb_error_mod
implicit none
class(psbn_base_sparse_mat), intent(in) :: a
integer :: res
@@ -313,9 +344,40 @@ contains
end function get_size
subroutine sparse_print(iout,a,iv,eirs,eics,head,ivr,ivc)
use psb_spmat_type
use psb_string_mod
implicit none
integer, intent(in) :: iout
class(psbn_base_sparse_mat), intent(in) :: a
integer, intent(in), optional :: iv(:)
integer, intent(in), optional :: eirs,eics
character(len=*), optional :: head
integer, intent(in), optional :: ivr(:), ivc(:)
Integer :: err_act, info
character(len=20) :: name='sparse_print'
logical, parameter :: debug=.false.
call psb_erractionsave(err_act)
info = 700
! This is the base version. If we get here
! it means the derived class is incomplete,
! so we throw an error.
call psb_errpush(700,name)
if (err_act /= psb_act_ret_) then
call psb_error()
end if
return
end subroutine sparse_print
subroutine get_neigh(a,idx,neigh,n,info,lev)
use psb_error_mod
implicit none
class(psbn_base_sparse_mat), intent(in) :: a
integer, intent(in) :: idx
integer, intent(out) :: n
@@ -343,6 +405,7 @@ contains
subroutine allocate_mn(m,n,a)
use psb_error_mod
implicit none
integer, intent(in) :: m,n
class(psbn_base_sparse_mat), intent(inout) :: a
@@ -365,6 +428,7 @@ contains
subroutine allocate_mnnz(m,n,nz,a)
use psb_error_mod
implicit none
integer, intent(in) :: m,n,nz
class(psbn_base_sparse_mat), intent(inout) :: a
Integer :: err_act
@@ -386,6 +450,7 @@ contains
subroutine reallocate_nz(nz,a)
use psb_error_mod
implicit none
integer, intent(in) :: nz
class(psbn_base_sparse_mat), intent(inout) :: a
Integer :: err_act
@@ -407,6 +472,7 @@ contains
subroutine free(a)
use psb_error_mod
implicit none
class(psbn_base_sparse_mat), intent(inout) :: a
Integer :: err_act
character(len=20) :: name='free'
base/newserial/psbn_d_base_mat_mod.f03
+465 -44
View File
@@ -11,13 +11,18 @@ module psbn_d_base_mat_mod
procedure, pass(a) :: d_base_cssm
generic, public :: psbn_cssm => d_base_cssm, d_base_cssv
procedure, pass(a) :: csins
procedure, pass(a) :: to_coo
procedure, pass(a) :: from_coo
procedure, pass(a) :: to_fmt
procedure, pass(a) :: from_fmt
procedure, pass(a) :: cp_to_coo
procedure, pass(a) :: cp_from_coo
procedure, pass(a) :: cp_to_fmt
procedure, pass(a) :: cp_from_fmt
procedure, pass(a) :: mv_to_coo
procedure, pass(a) :: mv_from_coo
procedure, pass(a) :: mv_to_fmt
procedure, pass(a) :: mv_from_fmt
end type psbn_d_base_sparse_mat
private :: d_base_csmv, d_base_csmm, d_base_cssv, d_base_cssm,&
& csins, to_coo, from_coo, to_fmt, from_fmt
& csins, cp_to_coo, cp_from_coo, cp_to_fmt, cp_from_fmt, &
& mv_to_coo, mv_from_coo, mv_to_fmt, mv_from_fmt
type, extends(psbn_d_base_sparse_mat) :: psbn_d_coo_sparse_mat
@@ -28,6 +33,7 @@ module psbn_d_base_mat_mod
contains
procedure, pass(a) :: get_size => d_coo_get_size
procedure, pass(a) :: get_nzeros => d_coo_get_nzeros
procedure, pass(a) :: set_nzeros => d_coo_set_nzeros
procedure, pass(a) :: d_base_csmm => d_coo_csmm
@@ -38,21 +44,34 @@ module psbn_d_base_mat_mod
procedure, pass(a) :: reallocate_nz => d_coo_reallocate_nz
procedure, pass(a) :: allocate_mnnz => d_coo_allocate_mnnz
procedure, pass(a) :: allocate_mn => d_coo_allocate_mn
procedure, pass(a) :: to_coo => d_coo_to_coo
procedure, pass(a) :: from_coo => d_coo_from_coo
procedure, pass(a) :: to_fmt => d_coo_to_fmt
procedure, pass(a) :: from_fmt => d_coo_from_fmt
procedure, pass(a) :: cp_to_coo => d_cp_coo_to_coo
procedure, pass(a) :: cp_from_coo => d_cp_coo_from_coo
procedure, pass(a) :: cp_to_fmt => d_cp_coo_to_fmt
procedure, pass(a) :: cp_from_fmt => d_cp_coo_from_fmt
procedure, pass(a) :: fix => d_fix_coo
procedure, pass(a) :: free => d_coo_free
procedure, pass(a) :: print => d_coo_print
end type psbn_d_coo_sparse_mat
private :: d_coo_get_nzeros, d_coo_set_nzeros, &
& d_coo_csmm, d_coo_csmv, d_coo_cssm, d_coo_cssv, &
& d_coo_csins, d_coo_reallocate_nz, d_coo_allocate_mnnz, &
& d_coo_allocate_mn, d_coo_to_coo, d_coo_from_coo, &
& d_fix_coo, d_coo_free
& d_coo_allocate_mn, d_fix_coo, d_coo_free, &
& d_cp_coo_to_coo, d_cp_coo_from_coo, &
& d_cp_coo_to_fmt, d_cp_coo_from_fmt
interface
subroutine d_fix_coo_inner(nzin,dupl,ia,ja,val,nzout,info,idir)
use psb_const_mod
integer, intent(in) :: nzin,dupl
integer, intent(inout) :: ia(:), ja(:)
real(psb_dpk_), intent(inout) :: val(:)
integer, intent(out) :: nzout, info
integer, intent(in), optional :: idir
end subroutine d_fix_coo_inner
end interface
interface
subroutine d_fix_coo_impl(a,info,idir)
use psb_const_mod
@@ -64,44 +83,85 @@ module psbn_d_base_mat_mod
end interface
interface
subroutine d_coo_to_coo_impl(a,b,info)
subroutine d_cp_coo_to_coo_impl(a,b,info)
use psb_const_mod
import psbn_d_coo_sparse_mat
class(psbn_d_coo_sparse_mat), intent(in) :: a
class(psbn_d_coo_sparse_mat), intent(out) :: b
integer, intent(out) :: info
end subroutine d_coo_to_coo_impl
end subroutine d_cp_coo_to_coo_impl
end interface
interface
subroutine d_coo_from_coo_impl(a,b,info)
subroutine d_cp_coo_from_coo_impl(a,b,info)
use psb_const_mod
import psbn_d_coo_sparse_mat
class(psbn_d_coo_sparse_mat), intent(inout) :: a
class(psbn_d_coo_sparse_mat), intent(in) :: b
integer, intent(out) :: info
end subroutine d_coo_from_coo_impl
end subroutine d_cp_coo_from_coo_impl
end interface
interface
subroutine d_coo_to_fmt_impl(a,b,info)
subroutine d_cp_coo_to_fmt_impl(a,b,info)
use psb_const_mod
import psbn_d_coo_sparse_mat, psbn_d_base_sparse_mat
class(psbn_d_coo_sparse_mat), intent(in) :: a
class(psbn_d_base_sparse_mat), intent(out) :: b
integer, intent(out) :: info
end subroutine d_coo_to_fmt_impl
end subroutine d_cp_coo_to_fmt_impl
end interface
interface
subroutine d_coo_from_fmt_impl(a,b,info)
subroutine d_cp_coo_from_fmt_impl(a,b,info)
use psb_const_mod
import psbn_d_coo_sparse_mat, psbn_d_base_sparse_mat
class(psbn_d_coo_sparse_mat), intent(inout) :: a
class(psbn_d_base_sparse_mat), intent(in) :: b
integer, intent(out) :: info
end subroutine d_coo_from_fmt_impl
end subroutine d_cp_coo_from_fmt_impl
end interface
interface
subroutine d_mv_coo_to_coo_impl(a,b,info)
use psb_const_mod
import psbn_d_coo_sparse_mat
class(psbn_d_coo_sparse_mat), intent(inout) :: a
class(psbn_d_coo_sparse_mat), intent(out) :: b
integer, intent(out) :: info
end subroutine d_mv_coo_to_coo_impl
end interface
interface
subroutine d_mv_coo_from_coo_impl(a,b,info)
use psb_const_mod
import psbn_d_coo_sparse_mat
class(psbn_d_coo_sparse_mat), intent(inout) :: a
class(psbn_d_coo_sparse_mat), intent(inout) :: b
integer, intent(out) :: info
end subroutine d_mv_coo_from_coo_impl
end interface
interface
subroutine d_mv_coo_to_fmt_impl(a,b,info)
use psb_const_mod
import psbn_d_coo_sparse_mat, psbn_d_base_sparse_mat
class(psbn_d_coo_sparse_mat), intent(inout) :: a
class(psbn_d_base_sparse_mat), intent(out) :: b
integer, intent(out) :: info
end subroutine d_mv_coo_to_fmt_impl
end interface
interface
subroutine d_mv_coo_from_fmt_impl(a,b,info)
use psb_const_mod
import psbn_d_coo_sparse_mat, psbn_d_base_sparse_mat
class(psbn_d_coo_sparse_mat), intent(inout) :: a
class(psbn_d_base_sparse_mat), intent(inout) :: b
integer, intent(out) :: info
end subroutine d_mv_coo_from_fmt_impl
end interface
interface
subroutine d_coo_csins_impl(nz,val,ia,ja,a,imin,imax,jmin,jmax,info,gtl)
@@ -160,10 +220,10 @@ module psbn_d_base_mat_mod
contains
subroutine to_coo(a,b,info)
subroutine cp_to_coo(a,b,info)
use psb_error_mod
use psb_realloc_mod
implicit none
class(psbn_d_base_sparse_mat), intent(in) :: a
class(psbn_d_coo_sparse_mat), intent(out) :: b
integer, intent(out) :: info
@@ -184,11 +244,12 @@ contains
end if
return
end subroutine to_coo
end subroutine cp_to_coo
subroutine from_coo(a,b,info)
subroutine cp_from_coo(a,b,info)
use psb_error_mod
use psb_realloc_mod
implicit none
class(psbn_d_base_sparse_mat), intent(inout) :: a
class(psbn_d_coo_sparse_mat), intent(in) :: b
integer, intent(out) :: info
@@ -209,12 +270,13 @@ contains
end if
return
end subroutine from_coo
end subroutine cp_from_coo
subroutine to_fmt(a,b,info)
subroutine cp_to_fmt(a,b,info)
use psb_error_mod
use psb_realloc_mod
implicit none
class(psbn_d_base_sparse_mat), intent(in) :: a
class(psbn_d_base_sparse_mat), intent(out) :: b
integer, intent(out) :: info
@@ -235,11 +297,12 @@ contains
end if
return
end subroutine to_fmt
end subroutine cp_to_fmt
subroutine from_fmt(a,b,info)
subroutine cp_from_fmt(a,b,info)
use psb_error_mod
use psb_realloc_mod
implicit none
class(psbn_d_base_sparse_mat), intent(inout) :: a
class(psbn_d_base_sparse_mat), intent(in) :: b
integer, intent(out) :: info
@@ -260,13 +323,120 @@ contains
end if
return
end subroutine from_fmt
end subroutine cp_from_fmt
subroutine mv_to_coo(a,b,info)
use psb_error_mod
use psb_realloc_mod
implicit none
class(psbn_d_base_sparse_mat), intent(inout) :: a
class(psbn_d_coo_sparse_mat), intent(out) :: b
integer, intent(out) :: info
Integer :: err_act
character(len=20) :: name='to_coo'
logical, parameter :: debug=.false.
call psb_erractionsave(err_act)
! This is the base version. If we get here
! it means the derived class is incomplete,
! so we throw an error.
info = 700
call psb_errpush(info,name)
if (err_act /= psb_act_ret_) then
call psb_error()
end if
return
end subroutine mv_to_coo
subroutine mv_from_coo(a,b,info)
use psb_error_mod
use psb_realloc_mod
implicit none
class(psbn_d_base_sparse_mat), intent(inout) :: a
class(psbn_d_coo_sparse_mat), intent(inout) :: b
integer, intent(out) :: info
Integer :: err_act
character(len=20) :: name='from_coo'
logical, parameter :: debug=.false.
call psb_erractionsave(err_act)
! This is the base version. If we get here
! it means the derived class is incomplete,
! so we throw an error.
info = 700
call psb_errpush(info,name)
if (err_act /= psb_act_ret_) then
call psb_error()
end if
return
end subroutine mv_from_coo
subroutine mv_to_fmt(a,b,info)
use psb_error_mod
use psb_realloc_mod
implicit none
class(psbn_d_base_sparse_mat), intent(inout) :: a
class(psbn_d_base_sparse_mat), intent(out) :: b
integer, intent(out) :: info
Integer :: err_act
character(len=20) :: name='to_fmt'
logical, parameter :: debug=.false.
call psb_erractionsave(err_act)
! This is the base version. If we get here
! it means the derived class is incomplete,
! so we throw an error.
info = 700
call psb_errpush(info,name)
if (err_act /= psb_act_ret_) then
call psb_error()
end if
return
end subroutine mv_to_fmt
subroutine mv_from_fmt(a,b,info)
use psb_error_mod
use psb_realloc_mod
implicit none
class(psbn_d_base_sparse_mat), intent(inout) :: a
class(psbn_d_base_sparse_mat), intent(inout) :: b
integer, intent(out) :: info
Integer :: err_act
character(len=20) :: name='from_fmt'
logical, parameter :: debug=.false.
call psb_erractionsave(err_act)
! This is the base version. If we get here
! it means the derived class is incomplete,
! so we throw an error.
info = 700
call psb_errpush(info,name)
if (err_act /= psb_act_ret_) then
call psb_error()
end if
return
end subroutine mv_from_fmt
subroutine d_fix_coo(a,info,idir)
use psb_error_mod
use psb_const_mod
implicit none
class(psbn_d_coo_sparse_mat), intent(inout) :: a
integer, intent(out) :: info
integer, intent(in), optional :: idir
@@ -300,6 +470,7 @@ contains
subroutine csins(nz,val,ia,ja,a,imin,imax,jmin,jmax,info,gtl)
use psb_error_mod
use psb_realloc_mod
implicit none
class(psbn_d_base_sparse_mat), intent(inout) :: a
real(psb_dpk_), intent(in) :: val(:)
integer, intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax
@@ -326,6 +497,7 @@ contains
subroutine d_base_csmm(alpha,a,x,beta,y,info,trans)
use psb_error_mod
implicit none
class(psbn_d_base_sparse_mat), intent(in) :: a
real(psb_dpk_), intent(in) :: alpha, beta, x(:,:)
real(psb_dpk_), intent(inout) :: y(:,:)
@@ -352,6 +524,7 @@ contains
subroutine d_base_csmv(alpha,a,x,beta,y,info,trans)
use psb_error_mod
implicit none
class(psbn_d_base_sparse_mat), intent(in) :: a
real(kind(1.d0)), intent(in) :: alpha, beta, x(:)
real(kind(1.d0)), intent(inout) :: y(:)
@@ -379,6 +552,7 @@ contains
subroutine d_base_cssm(alpha,a,x,beta,y,info,trans)
use psb_error_mod
implicit none
class(psbn_d_base_sparse_mat), intent(in) :: a
real(psb_dpk_), intent(in) :: alpha, beta, x(:,:)
real(psb_dpk_), intent(inout) :: y(:,:)
@@ -405,6 +579,7 @@ contains
subroutine d_base_cssv(alpha,a,x,beta,y,info,trans)
use psb_error_mod
implicit none
class(psbn_d_base_sparse_mat), intent(in) :: a
real(psb_dpk_), intent(in) :: alpha, beta, x(:)
real(psb_dpk_), intent(inout) :: y(:)
@@ -431,9 +606,10 @@ contains
end subroutine d_base_cssv
subroutine d_coo_to_coo(a,b,info)
subroutine d_cp_coo_to_coo(a,b,info)
use psb_error_mod
use psb_realloc_mod
implicit none
class(psbn_d_coo_sparse_mat), intent(in) :: a
class(psbn_d_coo_sparse_mat), intent(out) :: b
integer, intent(out) :: info
@@ -444,7 +620,7 @@ contains
call psb_erractionsave(err_act)
info = 0
call d_coo_to_coo_impl(a,b,info)
call d_cp_coo_to_coo_impl(a,b,info)
if (info /= 0) goto 9999
call psb_erractionrestore(err_act)
@@ -460,11 +636,12 @@ contains
end if
return
end subroutine d_coo_to_coo
end subroutine d_cp_coo_to_coo
subroutine d_coo_from_coo(a,b,info)
subroutine d_cp_coo_from_coo(a,b,info)
use psb_error_mod
use psb_realloc_mod
implicit none
class(psbn_d_coo_sparse_mat), intent(inout) :: a
class(psbn_d_coo_sparse_mat), intent(in) :: b
integer, intent(out) :: info
@@ -475,7 +652,7 @@ contains
call psb_erractionsave(err_act)
info = 0
call d_coo_from_coo_impl(a,b,info)
call d_cp_coo_from_coo_impl(a,b,info)
if (info /= 0) goto 9999
call psb_erractionrestore(err_act)
@@ -491,11 +668,12 @@ contains
end if
return
end subroutine d_coo_from_coo
end subroutine d_cp_coo_from_coo
subroutine d_coo_to_fmt(a,b,info)
subroutine d_cp_coo_to_fmt(a,b,info)
use psb_error_mod
use psb_realloc_mod
implicit none
class(psbn_d_coo_sparse_mat), intent(in) :: a
class(psbn_d_base_sparse_mat), intent(out) :: b
integer, intent(out) :: info
@@ -506,7 +684,7 @@ contains
call psb_erractionsave(err_act)
info = 0
call d_coo_to_fmt_impl(a,b,info)
call d_cp_coo_to_fmt_impl(a,b,info)
if (info /= 0) goto 9999
call psb_erractionrestore(err_act)
@@ -522,11 +700,12 @@ contains
end if
return
end subroutine d_coo_to_fmt
end subroutine d_cp_coo_to_fmt
subroutine d_coo_from_fmt(a,b,info)
subroutine d_cp_coo_from_fmt(a,b,info)
use psb_error_mod
use psb_realloc_mod
implicit none
class(psbn_d_coo_sparse_mat), intent(inout) :: a
class(psbn_d_base_sparse_mat), intent(in) :: b
integer, intent(out) :: info
@@ -537,7 +716,7 @@ contains
call psb_erractionsave(err_act)
info = 0
call d_coo_from_fmt_impl(a,b,info)
call d_cp_coo_from_fmt_impl(a,b,info)
if (info /= 0) goto 9999
call psb_erractionrestore(err_act)
@@ -553,20 +732,153 @@ contains
end if
return
end subroutine d_coo_from_fmt
end subroutine d_cp_coo_from_fmt
subroutine d_mv_coo_to_coo(a,b,info)
use psb_error_mod
use psb_realloc_mod
implicit none
class(psbn_d_coo_sparse_mat), intent(inout) :: a
class(psbn_d_coo_sparse_mat), intent(out) :: b
integer, intent(out) :: info
Integer :: err_act
character(len=20) :: name='to_coo'
logical, parameter :: debug=.false.
call psb_erractionsave(err_act)
info = 0
call d_mv_coo_to_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_mv_coo_to_coo
subroutine d_mv_coo_from_coo(a,b,info)
use psb_error_mod
use psb_realloc_mod
implicit none
class(psbn_d_coo_sparse_mat), intent(inout) :: a
class(psbn_d_coo_sparse_mat), intent(inout) :: b
integer, intent(out) :: info
Integer :: err_act
character(len=20) :: name='from_coo'
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_mv_coo_from_coo
subroutine d_mv_coo_to_fmt(a,b,info)
use psb_error_mod
use psb_realloc_mod
implicit none
class(psbn_d_coo_sparse_mat), intent(inout) :: a
class(psbn_d_base_sparse_mat), intent(out) :: b
integer, intent(out) :: info
Integer :: err_act
character(len=20) :: name='to_coo'
logical, parameter :: debug=.false.
call psb_erractionsave(err_act)
info = 0
call d_mv_coo_to_fmt_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_mv_coo_to_fmt
subroutine d_mv_coo_from_fmt(a,b,info)
use psb_error_mod
use psb_realloc_mod
implicit none
class(psbn_d_coo_sparse_mat), intent(inout) :: a
class(psbn_d_base_sparse_mat), intent(inout) :: b
integer, intent(out) :: info
Integer :: err_act
character(len=20) :: name='from_coo'
logical, parameter :: debug=.false.
call psb_erractionsave(err_act)
info = 0
call d_mv_coo_from_fmt_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_mv_coo_from_fmt
subroutine d_coo_reallocate_nz(nz,a)
use psb_error_mod
use psb_realloc_mod
implicit none
integer, intent(in) :: nz
class(psbn_d_coo_sparse_mat), intent(inout) :: a
Integer :: err_act
Integer :: err_act, info
character(len=20) :: name='d_coo_reallocate_nz'
logical, parameter :: debug=.false.
call psb_erractionsave(err_act)
call psb_realloc(nx,a%ia,a%ja,a%val,info)
call psb_realloc(nz,a%ia,a%ja,a%val,info)
if (info /= 0) then
call psb_errpush(4000,name)
@@ -588,7 +900,32 @@ contains
end subroutine d_coo_reallocate_nz
function d_coo_get_size(a) result(res)
implicit none
class(psbn_d_coo_sparse_mat), intent(in) :: a
integer :: res
res = -1
if (allocated(a%ia)) res = size(a%ia)
if (allocated(a%ja)) then
if (res >= 0) then
res = min(res,size(a%ja))
else
res = size(a%ja)
end if
end if
if (allocated(a%val)) then
if (res >= 0) then
res = min(res,size(a%val))
else
res = size(a%val)
end if
end if
end function d_coo_get_size
function d_coo_get_nzeros(a) result(res)
implicit none
class(psbn_d_coo_sparse_mat), intent(in) :: a
integer :: res
res = a%nnz
@@ -596,6 +933,7 @@ contains
subroutine d_coo_set_nzeros(nz,a)
implicit none
integer, intent(in) :: nz
class(psbn_d_coo_sparse_mat), intent(inout) :: a
@@ -607,6 +945,7 @@ contains
subroutine d_coo_csins(nz,val,ia,ja,a,imin,imax,jmin,jmax,info,gtl)
use psb_error_mod
use psb_realloc_mod
implicit none
class(psbn_d_coo_sparse_mat), intent(inout) :: a
real(psb_dpk_), intent(in) :: val(:)
integer, intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax
@@ -649,7 +988,8 @@ contains
end if
if (nz == 0) return
nza = a%get_nzeros()
!!$ write(0,*) 'On entry to csins: ',nza
call d_coo_csins_impl(nz,val,ia,ja,a,imin,imax,jmin,jmax,info,gtl)
if (info /= 0) goto 9999
@@ -670,6 +1010,7 @@ contains
subroutine d_coo_csmv(alpha,a,x,beta,y,info,trans)
use psb_error_mod
implicit none
class(psbn_d_coo_sparse_mat), intent(in) :: a
real(psb_dpk_), intent(in) :: alpha, beta, x(:)
real(psb_dpk_), intent(inout) :: y(:)
@@ -713,6 +1054,7 @@ contains
subroutine d_coo_csmm(alpha,a,x,beta,y,info,trans)
use psb_error_mod
implicit none
class(psbn_d_coo_sparse_mat), intent(in) :: a
real(psb_dpk_), intent(in) :: alpha, beta, x(:,:)
real(psb_dpk_), intent(inout) :: y(:,:)
@@ -752,6 +1094,7 @@ contains
subroutine d_coo_cssv(alpha,a,x,beta,y,info,trans)
use psb_error_mod
implicit none
class(psbn_d_coo_sparse_mat), intent(in) :: a
real(psb_dpk_), intent(in) :: alpha, beta, x(:)
real(psb_dpk_), intent(inout) :: y(:)
@@ -805,6 +1148,7 @@ contains
subroutine d_coo_cssm(alpha,a,x,beta,y,info,trans)
use psb_error_mod
implicit none
class(psbn_d_coo_sparse_mat), intent(in) :: a
real(psb_dpk_), intent(in) :: alpha, beta, x(:,:)
real(psb_dpk_), intent(inout) :: y(:,:)
@@ -854,6 +1198,7 @@ contains
subroutine d_coo_free(a)
implicit none
class(psbn_d_coo_sparse_mat), intent(inout) :: a
@@ -871,6 +1216,7 @@ contains
subroutine d_coo_allocate_mnnz(m,n,nz,a)
use psb_error_mod
use psb_realloc_mod
implicit none
integer, intent(in) :: m,n,nz
class(psbn_d_coo_sparse_mat), intent(inout) :: a
Integer :: err_act, info
@@ -904,8 +1250,9 @@ contains
call a%set_nzeros(0)
call a%set_bld()
call a%set_triangle(.false.)
call a%set_dupl(psbn_dupl_def_)
end if
if (info /= 0) goto 9999
call psb_erractionrestore(err_act)
return
@@ -924,6 +1271,7 @@ contains
subroutine d_coo_allocate_mn(m,n,a)
use psb_error_mod
use psb_realloc_mod
implicit none
integer, intent(in) :: m,n
class(psbn_d_coo_sparse_mat), intent(inout) :: a
Integer :: err_act, info, nz
@@ -959,6 +1307,79 @@ contains
return
end subroutine d_coo_allocate_mn
subroutine d_coo_print(iout,a,iv,eirs,eics,head,ivr,ivc)
use psb_spmat_type
use psb_string_mod
implicit none
integer, intent(in) :: iout
class(psbn_d_coo_sparse_mat), intent(in) :: a
integer, intent(in), optional :: iv(:)
integer, intent(in), optional :: eirs,eics
character(len=*), optional :: head
integer, intent(in), optional :: ivr(:), ivc(:)
Integer :: err_act
character(len=20) :: name='d_coo_print'
logical, parameter :: debug=.false.
character(len=80) :: frmtv
integer :: irs,ics,i,j, nmx, ni, nr, nc, nz
if (present(eirs)) then
irs = eirs
else
irs = 0
endif
if (present(eics)) then
ics = eics
else
ics = 0
endif
if (present(head)) then
write(iout,'(a)') '%%MatrixMarket matrix coordinate real general'
write(iout,'(a,a)') '% ',head
write(iout,'(a)') '%'
write(iout,'(a,a)') '% COO'
endif
nr = a%get_nrows()
nc = a%get_ncols()
nz = a%get_nzeros()
nmx = max(nr,nc,1)
ni = floor(log10(1.0*nmx)) + 1
write(frmtv,'(a,i3.3,a,i3.3,a)') '(2(i',ni,',1x),es26.18,1x,2(i',ni,',1x))'
write(iout,*) nr, nc, nz
if(present(iv)) then
do j=1,a%get_nzeros()
write(iout,frmtv) iv(a%ia(j)),iv(a%ja(j)),a%val(j)
enddo
else
if (present(ivr).and..not.present(ivc)) then
do j=1,a%get_nzeros()
write(iout,frmtv) ivr(a%ia(j)),a%ja(j),a%val(j)
enddo
else if (present(ivr).and.present(ivc)) then
do j=1,a%get_nzeros()
write(iout,frmtv) ivr(a%ia(j)),ivc(a%ja(j)),a%val(j)
enddo
else if (.not.present(ivr).and.present(ivc)) then
do j=1,a%get_nzeros()
write(iout,frmtv) a%ia(j),ivc(a%ja(j)),a%val(j)
enddo
else if (.not.present(ivr).and..not.present(ivc)) then
do j=1,a%get_nzeros()
write(iout,frmtv) a%ia(j),a%ja(j),a%val(j)
enddo
endif
endif
end subroutine d_coo_print
end module psbn_d_base_mat_mod
base/newserial/psbn_d_coo_impl.f03
+757 -531
View File
File diff suppressed because it is too large Load Diff
base/newserial/psbn_d_csr_impl.f03
+307 -294
View File
@@ -2,6 +2,7 @@
subroutine d_csr_csmv_impl(alpha,a,x,beta,y,info,trans)
use psb_error_mod
use psbn_d_csr_mat_mod, psb_protect_name => d_csr_csmv_impl
implicit none
class(psbn_d_csr_sparse_mat), intent(in) :: a
real(psb_dpk_), intent(in) :: alpha, beta, x(:)
real(psb_dpk_), intent(inout) :: y(:)
@@ -63,7 +64,7 @@ subroutine d_csr_csmv_impl(alpha,a,x,beta,y,info,trans)
if (alpha == done) then
do i=1,m
acc = zero
acc = dzero
do j=a%irp(i), a%irp(i+1)-1
acc = acc + a%val(j) * x(a%ja(j))
enddo
@@ -73,7 +74,7 @@ subroutine d_csr_csmv_impl(alpha,a,x,beta,y,info,trans)
else if (alpha == -done) then
do i=1,m
acc = zero
acc = dzero
do j=a%irp(i), a%irp(i+1)-1
acc = acc + a%val(j) * x(a%ja(j))
enddo
@@ -83,7 +84,7 @@ subroutine d_csr_csmv_impl(alpha,a,x,beta,y,info,trans)
else
do i=1,m
acc = zero
acc = dzero
do j=a%irp(i), a%irp(i+1)-1
acc = acc + a%val(j) * x(a%ja(j))
enddo
@@ -97,7 +98,7 @@ subroutine d_csr_csmv_impl(alpha,a,x,beta,y,info,trans)
if (alpha == done) then
do i=1,m
acc = zero
acc = dzero
do j=a%irp(i), a%irp(i+1)-1
acc = acc + a%val(j) * x(a%ja(j))
enddo
@@ -107,7 +108,7 @@ subroutine d_csr_csmv_impl(alpha,a,x,beta,y,info,trans)
else if (alpha == -done) then
do i=1,m
acc = zero
acc = dzero
do j=a%irp(i), a%irp(i+1)-1
acc = acc + a%val(j) * x(a%ja(j))
enddo
@@ -117,7 +118,7 @@ subroutine d_csr_csmv_impl(alpha,a,x,beta,y,info,trans)
else
do i=1,m
acc = zero
acc = dzero
do j=a%irp(i), a%irp(i+1)-1
acc = acc + a%val(j) * x(a%ja(j))
enddo
@@ -130,7 +131,7 @@ subroutine d_csr_csmv_impl(alpha,a,x,beta,y,info,trans)
if (alpha == done) then
do i=1,m
acc = zero
acc = dzero
do j=a%irp(i), a%irp(i+1)-1
acc = acc + a%val(j) * x(a%ja(j))
enddo
@@ -140,7 +141,7 @@ subroutine d_csr_csmv_impl(alpha,a,x,beta,y,info,trans)
else if (alpha == -done) then
do i=1,m
acc = zero
acc = dzero
do j=a%irp(i), a%irp(i+1)-1
acc = acc + a%val(j) * x(a%ja(j))
enddo
@@ -150,7 +151,7 @@ subroutine d_csr_csmv_impl(alpha,a,x,beta,y,info,trans)
else
do i=1,m
acc = zero
acc = dzero
do j=a%irp(i), a%irp(i+1)-1
acc = acc + a%val(j) * x(a%ja(j))
enddo
@@ -163,7 +164,7 @@ subroutine d_csr_csmv_impl(alpha,a,x,beta,y,info,trans)
if (alpha == done) then
do i=1,m
acc = zero
acc = dzero
do j=a%irp(i), a%irp(i+1)-1
acc = acc + a%val(j) * x(a%ja(j))
enddo
@@ -173,7 +174,7 @@ subroutine d_csr_csmv_impl(alpha,a,x,beta,y,info,trans)
else if (alpha == -done) then
do i=1,m
acc = zero
acc = dzero
do j=a%irp(i), a%irp(i+1)-1
acc = acc + a%val(j) * x(a%ja(j))
enddo
@@ -183,7 +184,7 @@ subroutine d_csr_csmv_impl(alpha,a,x,beta,y,info,trans)
else
do i=1,m
acc = zero
acc = dzero
do j=a%irp(i), a%irp(i+1)-1
acc = acc + a%val(j) * x(a%ja(j))
enddo
@@ -265,6 +266,7 @@ end subroutine d_csr_csmv_impl
subroutine d_csr_csmm_impl(alpha,a,x,beta,y,info,trans)
use psb_error_mod
use psbn_d_csr_mat_mod, psb_protect_name => d_csr_csmm_impl
implicit none
class(psbn_d_csr_sparse_mat), intent(in) :: a
real(psb_dpk_), intent(in) :: alpha, beta, x(:,:)
real(psb_dpk_), intent(inout) :: y(:,:)
@@ -279,6 +281,7 @@ subroutine d_csr_csmm_impl(alpha,a,x,beta,y,info,trans)
character(len=20) :: name='d_csr_csmm'
logical, parameter :: debug=.false.
info = 0
call psb_erractionsave(err_act)
if (present(trans)) then
@@ -330,7 +333,7 @@ subroutine d_csr_csmm_impl(alpha,a,x,beta,y,info,trans)
if (alpha == done) then
do i=1,m
acc = zero
acc = dzero
do j=a%irp(i), a%irp(i+1)-1
acc = acc + a%val(j) * x(a%ja(j),:)
enddo
@@ -340,7 +343,7 @@ subroutine d_csr_csmm_impl(alpha,a,x,beta,y,info,trans)
else if (alpha == -done) then
do i=1,m
acc = zero
acc = dzero
do j=a%irp(i), a%irp(i+1)-1
acc = acc + a%val(j) * x(a%ja(j),:)
enddo
@@ -350,7 +353,7 @@ subroutine d_csr_csmm_impl(alpha,a,x,beta,y,info,trans)
else
do i=1,m
acc = zero
acc = dzero
do j=a%irp(i), a%irp(i+1)-1
acc = acc + a%val(j) * x(a%ja(j),:)
enddo
@@ -364,7 +367,7 @@ subroutine d_csr_csmm_impl(alpha,a,x,beta,y,info,trans)
if (alpha == done) then
do i=1,m
acc = zero
acc = dzero
do j=a%irp(i), a%irp(i+1)-1
acc = acc + a%val(j) * x(a%ja(j),:)
enddo
@@ -374,7 +377,7 @@ subroutine d_csr_csmm_impl(alpha,a,x,beta,y,info,trans)
else if (alpha == -done) then
do i=1,m
acc = zero
acc = dzero
do j=a%irp(i), a%irp(i+1)-1
acc = acc + a%val(j) * x(a%ja(j),:)
enddo
@@ -384,7 +387,7 @@ subroutine d_csr_csmm_impl(alpha,a,x,beta,y,info,trans)
else
do i=1,m
acc = zero
acc = dzero
do j=a%irp(i), a%irp(i+1)-1
acc = acc + a%val(j) * x(a%ja(j),:)
enddo
@@ -397,7 +400,7 @@ subroutine d_csr_csmm_impl(alpha,a,x,beta,y,info,trans)
if (alpha == done) then
do i=1,m
acc = zero
acc = dzero
do j=a%irp(i), a%irp(i+1)-1
acc = acc + a%val(j) * x(a%ja(j),:)
enddo
@@ -407,7 +410,7 @@ subroutine d_csr_csmm_impl(alpha,a,x,beta,y,info,trans)
else if (alpha == -done) then
do i=1,m
acc = zero
acc = dzero
do j=a%irp(i), a%irp(i+1)-1
acc = acc + a%val(j) * x(a%ja(j),:)
enddo
@@ -417,7 +420,7 @@ subroutine d_csr_csmm_impl(alpha,a,x,beta,y,info,trans)
else
do i=1,m
acc = zero
acc = dzero
do j=a%irp(i), a%irp(i+1)-1
acc = acc + a%val(j) * x(a%ja(j),:)
enddo
@@ -430,7 +433,7 @@ subroutine d_csr_csmm_impl(alpha,a,x,beta,y,info,trans)
if (alpha == done) then
do i=1,m
acc = zero
acc = dzero
do j=a%irp(i), a%irp(i+1)-1
acc = acc + a%val(j) * x(a%ja(j),:)
enddo
@@ -440,7 +443,7 @@ subroutine d_csr_csmm_impl(alpha,a,x,beta,y,info,trans)
else if (alpha == -done) then
do i=1,m
acc = zero
acc = dzero
do j=a%irp(i), a%irp(i+1)-1
acc = acc + a%val(j) * x(a%ja(j),:)
enddo
@@ -450,7 +453,7 @@ subroutine d_csr_csmm_impl(alpha,a,x,beta,y,info,trans)
else
do i=1,m
acc = zero
acc = dzero
do j=a%irp(i), a%irp(i+1)-1
acc = acc + a%val(j) * x(a%ja(j),:)
enddo
@@ -533,6 +536,7 @@ end subroutine d_csr_csmm_impl
subroutine d_csr_cssv_impl(alpha,a,x,beta,y,info,trans)
use psb_error_mod
use psbn_d_csr_mat_mod, psb_protect_name => d_csr_cssv_impl
implicit none
class(psbn_d_csr_sparse_mat), intent(in) :: a
real(psb_dpk_), intent(in) :: alpha, beta, x(:)
real(psb_dpk_), intent(inout) :: y(:)
@@ -548,6 +552,7 @@ subroutine d_csr_cssv_impl(alpha,a,x,beta,y,info,trans)
character(len=20) :: name='d_csr_cssv'
logical, parameter :: debug=.false.
info = 0
call psb_erractionsave(err_act)
if (present(trans)) then
@@ -617,6 +622,7 @@ subroutine d_csr_cssv_impl(alpha,a,x,beta,y,info,trans)
contains
subroutine inner_csrsv(tra,a,x,y)
implicit none
logical, intent(in) :: tra
class(psbn_d_csr_sparse_mat), intent(in) :: a
real(psb_dpk_), intent(in) :: x(:)
@@ -724,6 +730,7 @@ end subroutine d_csr_cssv_impl
subroutine d_csr_cssm_impl(alpha,a,x,beta,y,info,trans)
use psb_error_mod
use psbn_d_csr_mat_mod, psb_protect_name => d_csr_cssm_impl
implicit none
class(psbn_d_csr_sparse_mat), intent(in) :: a
real(psb_dpk_), intent(in) :: alpha, beta, x(:,:)
real(psb_dpk_), intent(inout) :: y(:,:)
@@ -739,6 +746,7 @@ subroutine d_csr_cssm_impl(alpha,a,x,beta,y,info,trans)
character(len=20) :: name='d_base_csmm'
logical, parameter :: debug=.false.
info = 0
call psb_erractionsave(err_act)
if (present(trans)) then
@@ -821,6 +829,7 @@ subroutine d_csr_cssm_impl(alpha,a,x,beta,y,info,trans)
contains
subroutine inner_csrsm(tra,a,x,y,info)
implicit none
logical, intent(in) :: tra
class(psbn_d_csr_sparse_mat), intent(in) :: a
real(psb_dpk_), intent(in) :: x(:,:)
@@ -829,6 +838,7 @@ contains
integer :: i,j,k,m, ir, jc
real(psb_dpk_), allocatable :: acc(:)
info = 0
allocate(acc(size(x,2)), stat=info)
if(info /= 0) then
info=4010
@@ -936,6 +946,7 @@ subroutine d_csr_csins_impl(nz,val,ia,ja,a,imin,imax,jmin,jmax,info,gtl)
use psb_error_mod
use psb_realloc_mod
use psbn_d_csr_mat_mod, psb_protect_name => d_csr_csins_impl
implicit none
class(psbn_d_csr_sparse_mat), intent(inout) :: a
real(psb_dpk_), intent(in) :: val(:)
@@ -949,7 +960,7 @@ subroutine d_csr_csins_impl(nz,val,ia,ja,a,imin,imax,jmin,jmax,info,gtl)
logical, parameter :: debug=.false.
integer :: nza, i,j,k, nzl, isza, int_err(5)
info = 0
nza = a%get_nzeros()
if (a%is_bld()) then
@@ -957,20 +968,11 @@ subroutine d_csr_csins_impl(nz,val,ia,ja,a,imin,imax,jmin,jmax,info,gtl)
info = 1121
else if (a%is_upd()) then
if (a%is_sorted()) then
call d_csr_srch_upd(nz,ia,ja,val,a,&
& imin,imax,jmin,jmax,info,gtl)
if (info /= 0) then
!!$#ifdef FIXED_NAG_SEGV
!!$ call d_csr_srch_upd(nz,ia,ja,val,a,&
!!$ & imin,imax,jmin,jmax,info,gtl)
!!$#else
call d_csr_srch_upd(nz,ia,ja,val,&
& a%irp,a%ja,a%val,&
& a%get_dupl(),a%get_nzeros(),a%get_nrows(),&
& info,gtl)
!!$#endif
else
info = 1121
end if
@@ -998,255 +1000,40 @@ subroutine d_csr_csins_impl(nz,val,ia,ja,a,imin,imax,jmin,jmax,info,gtl)
contains
subroutine d_csr_srch_upd(nz,ia,ja,val,a,&
& imin,imax,jmin,jmax,info,gtl)
!!$#ifdef FIXED_NAG_SEGV
!!$ subroutine d_csr_srch_upd(nz,ia,ja,val,a,&
!!$ & imin,imax,jmin,jmax,info,gtl)
!!$
!!$ use psb_const_mod
!!$ use psb_realloc_mod
!!$ use psb_string_mod
!!$ use psb_serial_mod
!!$ implicit none
!!$
!!$ class(psbn_d_csr_sparse_mat), intent(inout) :: a
!!$ integer, intent(in) :: nz, imin,imax,jmin,jmax
!!$ integer, intent(in) :: ia(:),ja(:)
!!$ real(psb_dpk_), intent(in) :: val(:)
!!$ integer, intent(out) :: info
!!$ integer, intent(in), optional :: gtl(:)
!!$ integer :: i,ir,ic, ilr, ilc, ip, &
!!$ & i1,i2,nc,nnz,dupl,ng
!!$ integer :: debug_level, debug_unit
!!$ character(len=20) :: name='d_csr_srch_upd'
!!$
!!$ info = 0
!!$ debug_unit = psb_get_debug_unit()
!!$ debug_level = psb_get_debug_level()
!!$
!!$ dupl = a%get_dupl()
!!$
!!$ if (.not.a%is_sorted()) then
!!$ info = -4
!!$ return
!!$ end if
!!$
!!$ ilr = -1
!!$ ilc = -1
!!$ nnz = a%get_nzeros()
!!$
!!$
!!$ if (present(gtl)) then
!!$ ng = size(gtl)
!!$
!!$ select case(dupl)
!!$ case(psbn_dupl_ovwrt_,psbn_dupl_err_)
!!$ ! Overwrite.
!!$ ! Cannot test for error, should have been caught earlier.
!!$ do i=1, nz
!!$ ir = ia(i)
!!$ ic = ja(i)
!!$ if ((ir >=1).and.(ir<=ng).and.(ic>=1).and.(ic<=ng)) then
!!$ ir = gtl(ir)
!!$ if ((ir > 0).and.(ir <= a%m)) then
!!$ ic = gtl(ic)
!!$ if (ir /= ilr) then
!!$ i1 = psb_ibsrch(ir,nnz,a%ia)
!!$ i2 = i1
!!$ do
!!$ if (i2+1 > nnz) exit
!!$ if (a%ia(i2+1) /= a%ia(i2)) exit
!!$ i2 = i2 + 1
!!$ end do
!!$ do
!!$ if (i1-1 < 1) exit
!!$ if (a%ia(i1-1) /= a%ia(i1)) exit
!!$ i1 = i1 - 1
!!$ end do
!!$ ilr = ir
!!$ else
!!$ i1 = 1
!!$ i2 = 1
!!$ end if
!!$ nc = i2-i1+1
!!$ ip = psb_issrch(ic,nc,a%ja(i1:i2))
!!$ if (ip>0) then
!!$ a%val(i1+ip-1) = val(i)
!!$ else
!!$ info = i
!!$ return
!!$ end if
!!$ else
!!$ if (debug_level >= psb_debug_serial_) &
!!$ & write(debug_unit,*) trim(name),&
!!$ & ': Discarding row that does not belong to us.'
!!$ endif
!!$ end if
!!$ end do
!!$ case(psbn_dupl_add_)
!!$ ! Add
!!$ do i=1, nz
!!$ ir = ia(i)
!!$ ic = ja(i)
!!$ if ((ir >=1).and.(ir<=ng).and.(ic>=1).and.(ic<=ng)) then
!!$ ir = gtl(ir)
!!$ ic = gtl(ic)
!!$ if ((ir > 0).and.(ir <= a%m)) then
!!$
!!$ if (ir /= ilr) then
!!$ i1 = psb_ibsrch(ir,nnz,a%ia)
!!$ i2 = i1
!!$ do
!!$ if (i2+1 > nnz) exit
!!$ if (a%ia(i2+1) /= a%ia(i2)) exit
!!$ i2 = i2 + 1
!!$ end do
!!$ do
!!$ if (i1-1 < 1) exit
!!$ if (a%ia(i1-1) /= a%ia(i1)) exit
!!$ i1 = i1 - 1
!!$ end do
!!$ ilr = ir
!!$ else
!!$ i1 = 1
!!$ i2 = 1
!!$ end if
!!$ nc = i2-i1+1
!!$ ip = psb_issrch(ic,nc,a%ja(i1:i2))
!!$ if (ip>0) then
!!$ a%val(i1+ip-1) = a%val(i1+ip-1) + val(i)
!!$ else
!!$ info = i
!!$ return
!!$ end if
!!$ else
!!$ if (debug_level >= psb_debug_serial_) &
!!$ & write(debug_unit,*) trim(name),&
!!$ & ': Discarding row that does not belong to us.'
!!$ end if
!!$ end if
!!$ end do
!!$
!!$ case default
!!$ info = -3
!!$ if (debug_level >= psb_debug_serial_) &
!!$ & write(debug_unit,*) trim(name),&
!!$ & ': Duplicate handling: ',dupl
!!$ end select
!!$
!!$ else
!!$
!!$ select case(dupl)
!!$ case(psbn_dupl_ovwrt_,psbn_dupl_err_)
!!$ ! Overwrite.
!!$ ! Cannot test for error, should have been caught earlier.
!!$ do i=1, nz
!!$ ir = ia(i)
!!$ ic = ja(i)
!!$ if ((ir > 0).and.(ir <= a%m)) then
!!$
!!$ if (ir /= ilr) then
!!$ i1 = psb_ibsrch(ir,nnz,a%ia)
!!$ i2 = i1
!!$ do
!!$ if (i2+1 > nnz) exit
!!$ if (a%ia(i2+1) /= a%ia(i2)) exit
!!$ i2 = i2 + 1
!!$ end do
!!$ do
!!$ if (i1-1 < 1) exit
!!$ if (a%ia(i1-1) /= a%ia(i1)) exit
!!$ i1 = i1 - 1
!!$ end do
!!$ ilr = ir
!!$ else
!!$ i1 = 1
!!$ i2 = 1
!!$ end if
!!$ nc = i2-i1+1
!!$ ip = psb_issrch(ic,nc,a%ja(i1:i2))
!!$ if (ip>0) then
!!$ a%val(i1+ip-1) = val(i)
!!$ else
!!$ info = i
!!$ return
!!$ end if
!!$ end if
!!$ end do
!!$
!!$ case(psbn_dupl_add_)
!!$ ! Add
!!$ do i=1, nz
!!$ ir = ia(i)
!!$ ic = ja(i)
!!$ if ((ir > 0).and.(ir <= a%m)) then
!!$
!!$ if (ir /= ilr) then
!!$ i1 = psb_ibsrch(ir,nnz,a%ia)
!!$ i2 = i1
!!$ do
!!$ if (i2+1 > nnz) exit
!!$ if (a%ia(i2+1) /= a%ia(i2)) exit
!!$ i2 = i2 + 1
!!$ end do
!!$ do
!!$ if (i1-1 < 1) exit
!!$ if (a%ia(i1-1) /= a%ia(i1)) exit
!!$ i1 = i1 - 1
!!$ end do
!!$ ilr = ir
!!$ else
!!$ i1 = 1
!!$ i2 = 1
!!$ end if
!!$ nc = i2-i1+1
!!$ ip = psb_issrch(ic,nc,a%ja(i1:i2))
!!$ if (ip>0) then
!!$ a%val(i1+ip-1) = a%val(i1+ip-1) + val(i)
!!$ else
!!$ info = i
!!$ return
!!$ end if
!!$ end if
!!$ end do
!!$
!!$ case default
!!$ info = -3
!!$ if (debug_level >= psb_debug_serial_) &
!!$ & write(debug_unit,*) trim(name),&
!!$ & ': Duplicate handling: ',dupl
!!$ end select
!!$
!!$ end if
!!$
!!$ end subroutine d_csr_srch_upd
!!$
!!$#else
subroutine d_csr_srch_upd(nz,ia,ja,val,&
& airp,aja,aval,dupl,nza,nra,&
& info,gtl)
use psb_error_mod
use psb_sort_mod
use psb_const_mod
use psb_realloc_mod
use psb_string_mod
use psb_serial_mod
implicit none
integer, intent(inout) :: airp(:),aja(:)
real(psb_dpk_), intent(inout) :: aval(:)
integer, intent(in) :: nz, dupl,nza, nra
class(psbn_d_csr_sparse_mat), intent(inout) :: a
integer, intent(in) :: nz, imin,imax,jmin,jmax
integer, intent(in) :: ia(:),ja(:)
real(psb_dpk_), intent(in) :: val(:)
integer, intent(out) :: info
integer, intent(in), optional :: gtl(:)
integer :: debug_level, debug_unit
character(len=20) :: name='d_csr_srch_upd'
integer :: i,ir,ic, ilr, ilc, ip, &
& i1,i2,nc,lb,ub,m, ng
& i1,i2,nc,nnz,dupl,ng
integer :: debug_level, debug_unit
character(len=20) :: name='d_csr_srch_upd'
info = 0
debug_unit = psb_get_debug_unit()
debug_level = psb_get_debug_level()
dupl = a%get_dupl()
if (.not.a%is_sorted()) then
info = -4
return
end if
ilr = -1
ilc = -1
nnz = a%get_nzeros()
if (present(gtl)) then
ng = size(gtl)
@@ -1265,18 +1052,18 @@ contains
ir = gtl(ir)
ic = gtl(ic)
if ((ir > 0).and.(ir <= a%m)) then
i1 = airp(ir)
i2 = airp(ir+1)
i1 = a%irp(ir)
i2 = a%irp(ir+1)
nc=i2-i1
ip = psb_ibsrch(ic,nc,aja(i1:i2-1))
ip = psb_ibsrch(ic,nc,a%ja(i1:i2-1))
if (ip>0) then
aval(i1+ip-1) = val(i)
a%val(i1+ip-1) = val(i)
else
if (debug_level >= psb_debug_serial_) &
& write(debug_unit,*) trim(name),&
& ': Was searching ',ic,' in: ',i1,i2,&
& ' : ',aja(i1:i2-1)
& ' : ',a%ja(i1:i2-1)
info = i
return
end if
@@ -1301,17 +1088,17 @@ contains
ir = gtl(ir)
ic = gtl(ic)
if ((ir > 0).and.(ir <= a%m)) then
i1 = airp(ir)
i2 = airp(ir+1)
i1 = a%irp(ir)
i2 = a%irp(ir+1)
nc = i2-i1
ip = psb_ibsrch(ic,nc,aja(i1:i2-1))
ip = psb_ibsrch(ic,nc,a%ja(i1:i2-1))
if (ip>0) then
aval(i1+ip-1) = aval(i1+ip-1) + val(i)
a%val(i1+ip-1) = a%val(i1+ip-1) + val(i)
else
if (debug_level >= psb_debug_serial_) &
& write(debug_unit,*) trim(name),&
& ': Was searching ',ic,' in: ',i1,i2,&
& ' : ',aja(i1:i2-1)
& ' : ',a%ja(i1:i2-1)
info = i
return
end if
@@ -1346,18 +1133,18 @@ contains
if ((ir > 0).and.(ir <= a%m)) then
i1 = airp(ir)
i2 = airp(ir+1)
i1 = a%irp(ir)
i2 = a%irp(ir+1)
nc=i2-i1
ip = psb_ibsrch(ic,nc,aja(i1:i2-1))
ip = psb_ibsrch(ic,nc,a%ja(i1:i2-1))
if (ip>0) then
aval(i1+ip-1) = val(i)
a%val(i1+ip-1) = val(i)
else
if (debug_level >= psb_debug_serial_) &
& write(debug_unit,*) trim(name),&
& ': Was searching ',ic,' in: ',i1,i2,&
& ' : ',aja(i1:i2-1)
& ' : ',a%ja(i1:i2-1)
info = i
return
end if
@@ -1378,12 +1165,12 @@ contains
ir = ia(i)
ic = ja(i)
if ((ir > 0).and.(ir <= a%m)) then
i1 = airp(ir)
i2 = airp(ir+1)
i1 = a%irp(ir)
i2 = a%irp(ir+1)
nc = i2-i1
ip = psb_ibsrch(ic,nc,aja(i1:i2-1))
ip = psb_ibsrch(ic,nc,a%ja(i1:i2-1))
if (ip>0) then
aval(i1+ip-1) = aval(i1+ip-1) + val(i)
a%val(i1+ip-1) = a%val(i1+ip-1) + val(i)
else
info = i
return
@@ -1403,6 +1190,232 @@ contains
end select
end if
end subroutine d_csr_srch_upd
!!$#endif
end subroutine d_csr_csins_impl
subroutine d_cp_csr_from_coo_impl(a,b,info)
use psb_const_mod
use psb_realloc_mod
use psbn_d_base_mat_mod
use psbn_d_csr_mat_mod, psb_protect_name => d_cp_csr_from_coo_impl
implicit none
class(psbn_d_csr_sparse_mat), intent(inout) :: a
class(psbn_d_coo_sparse_mat), intent(in) :: b
integer, intent(out) :: info
type(psbn_d_coo_sparse_mat) :: tmp
integer, allocatable :: itemp(:)
!locals
logical :: rwshr_
Integer :: nza, nr, i,j,irw, idl,err_act, nc
Integer, Parameter :: maxtry=8
integer :: debug_level, debug_unit
character(len=20) :: name
info = 0
! This is to have fix_coo called behind the scenes
call tmp%cp_from_coo(b,info)
if (info ==0) call a%mv_from_coo(tmp,info)
end subroutine d_cp_csr_from_coo_impl
subroutine d_cp_csr_to_coo_impl(a,b,info)
use psb_const_mod
use psbn_d_base_mat_mod
use psbn_d_csr_mat_mod, psb_protect_name => d_cp_csr_to_coo_impl
implicit none
class(psbn_d_csr_sparse_mat), intent(in) :: a
class(psbn_d_coo_sparse_mat), intent(out) :: b
integer, intent(out) :: info
integer, allocatable :: itemp(:)
!locals
logical :: rwshr_
Integer :: nza, nr, nc,i,j,irw, idl,err_act
Integer, Parameter :: maxtry=8
integer :: debug_level, debug_unit
character(len=20) :: name
info = 0
nr = a%get_nrows()
nc = a%get_ncols()
nza = a%get_nzeros()
call b%allocate(nr,nr,nza)
do i=1, nr
do j=a%irp(i),a%irp(i+1)-1
b%ia(j) = i
b%ja(j) = a%ja(j)
b%val(j) = a%val(j)
end do
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%fix(info)
end subroutine d_cp_csr_to_coo_impl
subroutine d_mv_csr_from_coo_impl(a,b,info)
use psb_const_mod
use psb_realloc_mod
use psbn_d_base_mat_mod
use psbn_d_csr_mat_mod, psb_protect_name => d_mv_csr_from_coo_impl
implicit none
class(psbn_d_csr_sparse_mat), intent(inout) :: a
class(psbn_d_coo_sparse_mat), intent(inout) :: b
integer, intent(out) :: info
integer, allocatable :: itemp(:)
!locals
logical :: rwshr_
Integer :: nza, nr, i,j,irw, idl,err_act, nc
Integer, Parameter :: maxtry=8
integer :: debug_level, debug_unit
character(len=20) :: name
info = 0
call b%fix(info)
if (info /= 0) return
nr = b%get_nrows()
nc = b%get_ncols()
nza = b%get_nzeros()
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())
! Dirty trick: call move_alloc to have the new data allocated just once.
call move_alloc(b%ia,itemp)
call move_alloc(b%ja,a%ja)
call move_alloc(b%val,a%val)
call psb_realloc(max(nr+1,nc+1),a%irp,info)
call b%free()
if (nza <= 0) then
a%irp(:) = 1
else
a%irp(1) = 1
if (nr < itemp(nza)) then
write(debug_unit,*) trim(name),': RWSHR=.false. : ',&
&nr,itemp(nza),' Expect trouble!'
info = 12
end if
j = 1
i = 1
irw = itemp(j)
outer: do
inner: do
if (i >= irw) exit inner
if (i>nr) then
write(debug_unit,*) trim(name),&
& 'Strange situation: i>nr ',i,nr,j,nza,irw,idl
exit outer
end if
a%irp(i+1) = a%irp(i)
i = i + 1
end do inner
j = j + 1
if (j > nza) exit
if (itemp(j) /= irw) then
a%irp(i+1) = j
irw = itemp(j)
i = i + 1
endif
if (i>nr) exit
enddo outer
!
! Cleanup empty rows at the end
!
if (j /= (nza+1)) then
write(debug_unit,*) trim(name),': Problem from loop :',j,nza
info = 13
endif
do
if (i>nr) exit
a%irp(i+1) = j
i = i + 1
end do
endif
end subroutine d_mv_csr_from_coo_impl
subroutine d_mv_csr_to_coo_impl(a,b,info)
use psb_const_mod
use psb_realloc_mod
use psbn_d_base_mat_mod
use psbn_d_csr_mat_mod, psb_protect_name => d_mv_csr_to_coo_impl
implicit none
class(psbn_d_csr_sparse_mat), intent(inout) :: a
class(psbn_d_coo_sparse_mat), intent(out) :: b
integer, intent(out) :: info
integer, allocatable :: itemp(:)
!locals
logical :: rwshr_
Integer :: nza, nr, i,j,irw, idl,err_act, nc
Integer, Parameter :: maxtry=8
integer :: debug_level, debug_unit
character(len=20) :: name
info = 0
nr = a%get_nrows()
nc = a%get_ncols()
nza = 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())
! Dirty trick: call move_alloc to have the new data allocated just once.
call move_alloc(a%irp,itemp)
call move_alloc(a%ja,b%ja)
call move_alloc(a%val,b%val)
call psb_realloc(nza,b%ia,info)
if (info /= 0) return
if (allocated(itemp)) then
do i=1, nr
do j=itemp(i),itemp(i+1)-1
b%ia(j) = i
end do
end do
end if
call b%fix(info)
end subroutine d_mv_csr_to_coo_impl
base/newserial/psbn_d_csr_mat_mod.f03
+382 -17
View File
@@ -17,36 +17,112 @@ module psbn_d_csr_mat_mod
procedure, pass(a) :: csins => d_csr_csins
procedure, pass(a) :: allocate_mnnz => d_csr_allocate_mnnz
procedure, pass(a) :: allocate_mn => d_csr_allocate_mn
procedure, pass(a) :: to_coo => d_csr_to_coo
procedure, pass(a) :: from_coo => d_csr_from_coo
procedure, pass(a) :: cp_to_coo => d_cp_csr_to_coo
procedure, pass(a) :: cp_from_coo => d_cp_csr_from_coo
procedure, pass(a) :: cp_to_fmt => d_cp_csr_to_fmt
procedure, pass(a) :: cp_from_fmt => d_cp_csr_from_fmt
procedure, pass(a) :: mv_to_coo => d_mv_csr_to_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_from_fmt => d_mv_csr_from_fmt
procedure, pass(a) :: free => d_csr_free
procedure, pass(a) :: print => d_csr_print
end type psbn_d_csr_sparse_mat
private :: d_csr_get_nzeros, d_csr_csmm, d_csr_csmv, d_csr_cssm, d_csr_cssv, &
& d_csr_csins, d_csr_reallocate_nz, d_csr_allocate_mnnz, &
& d_csr_allocate_mn, d_csr_to_coo, d_csr_from_coo, &
& d_csr_free
& d_csr_allocate_mn, d_csr_free, d_csr_print, &
& d_cp_csr_to_coo, d_cp_csr_from_coo, &
& d_mv_csr_to_coo, d_mv_csr_from_coo
interface
subroutine d_csr_to_coo_impl(a,b,info)
subroutine d_cp_csr_to_fmt_impl(a,b,info)
use psb_const_mod
use psbn_d_base_mat_mod
import psbn_d_csr_sparse_mat
class(psbn_d_csr_sparse_mat), intent(in) :: a
class(psbn_d_base_sparse_mat), intent(out) :: b
integer, intent(out) :: info
end subroutine d_cp_csr_to_fmt_impl
end interface
interface
subroutine d_cp_csr_from_fmt_impl(a,b,info)
use psb_const_mod
use psbn_d_base_mat_mod
import psbn_d_csr_sparse_mat
class(psbn_d_csr_sparse_mat), intent(inout) :: a
class(psbn_d_base_sparse_mat), intent(in) :: b
integer, intent(out) :: info
end subroutine d_cp_csr_from_fmt_impl
end interface
interface
subroutine d_cp_csr_to_coo_impl(a,b,info)
use psb_const_mod
use psbn_d_base_mat_mod
import psbn_d_csr_sparse_mat
class(psbn_d_csr_sparse_mat), intent(in) :: a
class(psbn_d_coo_sparse_mat), intent(out) :: b
integer, intent(out) :: info
end subroutine d_csr_to_coo_impl
end subroutine d_cp_csr_to_coo_impl
end interface
interface
subroutine d_csr_from_coo_impl(a,b,info)
subroutine d_cp_csr_from_coo_impl(a,b,info)
use psb_const_mod
use psbn_d_base_mat_mod
import psbn_d_csr_sparse_mat
class(psbn_d_csr_sparse_mat), intent(inout) :: a
class(psbn_d_coo_sparse_mat), intent(in) :: b
integer, intent(out) :: info
end subroutine d_csr_from_coo_impl
end subroutine d_cp_csr_from_coo_impl
end interface
interface
subroutine d_mv_csr_to_fmt_impl(a,b,info)
use psb_const_mod
use psbn_d_base_mat_mod
import psbn_d_csr_sparse_mat
class(psbn_d_csr_sparse_mat), intent(inout) :: a
class(psbn_d_base_sparse_mat), intent(out) :: b
integer, intent(out) :: info
end subroutine d_mv_csr_to_fmt_impl
end interface
interface
subroutine d_mv_csr_from_fmt_impl(a,b,info)
use psb_const_mod
use psbn_d_base_mat_mod
import psbn_d_csr_sparse_mat
class(psbn_d_csr_sparse_mat), intent(inout) :: a
class(psbn_d_base_sparse_mat), intent(inout) :: b
integer, intent(out) :: info
end subroutine d_mv_csr_from_fmt_impl
end interface
interface
subroutine d_mv_csr_to_coo_impl(a,b,info)
use psb_const_mod
use psbn_d_base_mat_mod
import psbn_d_csr_sparse_mat
class(psbn_d_csr_sparse_mat), intent(inout) :: a
class(psbn_d_coo_sparse_mat), intent(out) :: b
integer, intent(out) :: info
end subroutine d_mv_csr_to_coo_impl
end interface
interface
subroutine d_mv_csr_from_coo_impl(a,b,info)
use psb_const_mod
use psbn_d_base_mat_mod
import psbn_d_csr_sparse_mat
class(psbn_d_csr_sparse_mat), intent(inout) :: a
class(psbn_d_coo_sparse_mat), intent(inout) :: b
integer, intent(out) :: info
end subroutine d_mv_csr_from_coo_impl
end interface
interface
@@ -110,6 +186,7 @@ contains
subroutine d_csr_reallocate_nz(nz,a)
use psb_error_mod
use psb_realloc_mod
implicit none
integer, intent(in) :: nz
class(psbn_d_csr_sparse_mat), intent(inout) :: a
Integer :: err_act, info
@@ -118,9 +195,9 @@ contains
call psb_erractionsave(err_act)
call psb_realloc(nx,a%ja,info)
if (info == 0) call psb_realloc(nx,a%val,info)
if (info == 0) call psb_realloc(max(nx,a%m+1,a%n+1),a%irp,info)
call psb_realloc(nz,a%ja,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%irp,info)
if (info /= 0) then
call psb_errpush(4000,name)
goto 9999
@@ -141,6 +218,7 @@ contains
end subroutine d_csr_reallocate_nz
function d_csr_get_nzeros(a) result(res)
implicit none
class(psbn_d_csr_sparse_mat), intent(in) :: a
integer :: res
res = a%irp(a%m+1)-1
@@ -150,6 +228,7 @@ contains
subroutine d_csr_csins(nz,val,ia,ja,a,imin,imax,jmin,jmax,info,gtl)
use psb_const_mod
use psb_error_mod
implicit none
class(psbn_d_csr_sparse_mat), intent(inout) :: a
real(psb_dpk_), intent(in) :: val(:)
integer, intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax
@@ -212,6 +291,7 @@ contains
subroutine d_csr_csmv(alpha,a,x,beta,y,info,trans)
use psb_error_mod
implicit none
class(psbn_d_csr_sparse_mat), intent(in) :: a
real(psb_dpk_), intent(in) :: alpha, beta, x(:)
real(psb_dpk_), intent(inout) :: y(:)
@@ -255,6 +335,7 @@ contains
subroutine d_csr_csmm(alpha,a,x,beta,y,info,trans)
use psb_error_mod
implicit none
class(psbn_d_csr_sparse_mat), intent(in) :: a
real(psb_dpk_), intent(in) :: alpha, beta, x(:,:)
real(psb_dpk_), intent(inout) :: y(:,:)
@@ -294,6 +375,7 @@ contains
subroutine d_csr_cssv(alpha,a,x,beta,y,info,trans)
use psb_error_mod
implicit none
class(psbn_d_csr_sparse_mat), intent(in) :: a
real(psb_dpk_), intent(in) :: alpha, beta, x(:)
real(psb_dpk_), intent(inout) :: y(:)
@@ -347,6 +429,7 @@ contains
subroutine d_csr_cssm(alpha,a,x,beta,y,info,trans)
use psb_error_mod
implicit none
class(psbn_d_csr_sparse_mat), intent(in) :: a
real(psb_dpk_), intent(in) :: alpha, beta, x(:,:)
real(psb_dpk_), intent(inout) :: y(:,:)
@@ -396,6 +479,7 @@ contains
subroutine d_csr_free(a)
implicit none
class(psbn_d_csr_sparse_mat), intent(inout) :: a
@@ -411,9 +495,10 @@ contains
end subroutine d_csr_free
subroutine d_csr_to_coo(a,b,info)
subroutine d_cp_csr_to_coo(a,b,info)
use psb_error_mod
use psb_realloc_mod
implicit none
class(psbn_d_csr_sparse_mat), intent(in) :: a
class(psbn_d_coo_sparse_mat), intent(out) :: b
integer, intent(out) :: info
@@ -424,7 +509,7 @@ contains
call psb_erractionsave(err_act)
info = 0
call d_csr_to_coo_impl(a,b,info)
call d_cp_csr_to_coo_impl(a,b,info)
if (info /= 0) goto 9999
call psb_erractionrestore(err_act)
@@ -440,11 +525,12 @@ contains
end if
return
end subroutine d_csr_to_coo
end subroutine d_cp_csr_to_coo
subroutine d_csr_from_coo(a,b,info)
subroutine d_cp_csr_from_coo(a,b,info)
use psb_error_mod
use psb_realloc_mod
implicit none
class(psbn_d_csr_sparse_mat), intent(inout) :: a
class(psbn_d_coo_sparse_mat), intent(in) :: b
integer, intent(out) :: info
@@ -455,7 +541,7 @@ contains
call psb_erractionsave(err_act)
info = 0
call d_csr_from_coo_impl(a,b,info)
call d_cp_csr_from_coo_impl(a,b,info)
if (info /= 0) goto 9999
call psb_erractionrestore(err_act)
@@ -471,12 +557,208 @@ contains
end if
return
end subroutine d_csr_from_coo
end subroutine d_cp_csr_from_coo
subroutine d_cp_csr_to_fmt(a,b,info)
use psb_error_mod
use psb_realloc_mod
implicit none
class(psbn_d_csr_sparse_mat), intent(in) :: a
class(psbn_d_base_sparse_mat), intent(out) :: b
integer, intent(out) :: info
Integer :: err_act
character(len=20) :: name='to_fmt'
logical, parameter :: debug=.false.
call psb_erractionsave(err_act)
info = 0
!!$ call d_cp_csr_to_fmt_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_cp_csr_to_fmt
subroutine d_cp_csr_from_fmt(a,b,info)
use psb_error_mod
use psb_realloc_mod
implicit none
class(psbn_d_csr_sparse_mat), intent(inout) :: a
class(psbn_d_base_sparse_mat), intent(in) :: b
integer, intent(out) :: info
Integer :: err_act
character(len=20) :: name='from_fmt'
logical, parameter :: debug=.false.
call psb_erractionsave(err_act)
info = 0
!!$ call d_cp_csr_from_fmt_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_cp_csr_from_fmt
subroutine d_mv_csr_to_coo(a,b,info)
use psb_error_mod
use psb_realloc_mod
implicit none
class(psbn_d_csr_sparse_mat), intent(inout) :: a
class(psbn_d_coo_sparse_mat), intent(out) :: b
integer, intent(out) :: info
Integer :: err_act
character(len=20) :: name='to_coo'
logical, parameter :: debug=.false.
call psb_erractionsave(err_act)
info = 0
call d_mv_csr_to_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_mv_csr_to_coo
subroutine d_mv_csr_from_coo(a,b,info)
use psb_error_mod
use psb_realloc_mod
implicit none
class(psbn_d_csr_sparse_mat), intent(inout) :: a
class(psbn_d_coo_sparse_mat), intent(inout) :: b
integer, intent(out) :: info
Integer :: err_act
character(len=20) :: name='from_coo'
logical, parameter :: debug=.false.
call psb_erractionsave(err_act)
info = 0
call d_mv_csr_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_mv_csr_from_coo
subroutine d_mv_csr_to_fmt(a,b,info)
use psb_error_mod
use psb_realloc_mod
implicit none
class(psbn_d_csr_sparse_mat), intent(inout) :: a
class(psbn_d_base_sparse_mat), intent(out) :: b
integer, intent(out) :: info
Integer :: err_act
character(len=20) :: name='to_fmt'
logical, parameter :: debug=.false.
call psb_erractionsave(err_act)
info = 0
!!$ call d_mv_csr_to_fmt_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_mv_csr_to_fmt
subroutine d_mv_csr_from_fmt(a,b,info)
use psb_error_mod
use psb_realloc_mod
implicit none
class(psbn_d_csr_sparse_mat), intent(inout) :: a
class(psbn_d_base_sparse_mat), intent(inout) :: b
integer, intent(out) :: info
Integer :: err_act
character(len=20) :: name='from_fmt'
logical, parameter :: debug=.false.
call psb_erractionsave(err_act)
info = 0
!!$ call d_mv_csr_from_fmt_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_mv_csr_from_fmt
subroutine d_csr_allocate_mnnz(m,n,nz,a)
use psb_error_mod
use psb_realloc_mod
implicit none
integer, intent(in) :: m,n,nz
class(psbn_d_csr_sparse_mat), intent(inout) :: a
Integer :: err_act, info
@@ -530,6 +812,7 @@ contains
subroutine d_csr_allocate_mn(m,n,a)
use psb_error_mod
use psb_realloc_mod
implicit none
integer, intent(in) :: m,n
class(psbn_d_csr_sparse_mat), intent(inout) :: a
Integer :: err_act, info, nz
@@ -566,4 +849,86 @@ contains
end subroutine d_csr_allocate_mn
subroutine d_csr_print(iout,a,iv,eirs,eics,head,ivr,ivc)
use psb_spmat_type
use psb_string_mod
implicit none
integer, intent(in) :: iout
class(psbn_d_csr_sparse_mat), intent(in) :: a
integer, intent(in), optional :: iv(:)
integer, intent(in), optional :: eirs,eics
character(len=*), optional :: head
integer, intent(in), optional :: ivr(:), ivc(:)
Integer :: err_act
character(len=20) :: name='d_csr_print'
logical, parameter :: debug=.false.
character(len=80) :: frmtv
integer :: irs,ics,i,j, nmx, ni, nr, nc, nz
if (present(eirs)) then
irs = eirs
else
irs = 0
endif
if (present(eics)) then
ics = eics
else
ics = 0
endif
if (present(head)) then
write(iout,'(a)') '%%MatrixMarket matrix coordinate real general'
write(iout,'(a,a)') '% ',head
write(iout,'(a)') '%'
write(iout,'(a,a)') '% COO'
endif
nr = a%get_nrows()
nc = a%get_ncols()
nz = a%get_nzeros()
nmx = max(nr,nc,1)
ni = floor(log10(1.0*nmx)) + 1
write(frmtv,'(a,i3.3,a,i3.3,a)') '(2(i',ni,',1x),es26.18,1x,2(i',ni,',1x))'
write(iout,*) nr, nc, nz
if(present(iv)) then
do i=1, nr
do j=a%irp(i),a%irp(i+1)-1
write(iout,frmtv) iv(i),iv(a%ja(j)),a%val(j)
end do
enddo
else
if (present(ivr).and..not.present(ivc)) then
do i=1, nr
do j=a%irp(i),a%irp(i+1)-1
write(iout,frmtv) ivr(i),(a%ja(j)),a%val(j)
end do
enddo
else if (present(ivr).and.present(ivc)) then
do i=1, nr
do j=a%irp(i),a%irp(i+1)-1
write(iout,frmtv) ivr(i),ivc(a%ja(j)),a%val(j)
end do
enddo
else if (.not.present(ivr).and.present(ivc)) then
do i=1, nr
do j=a%irp(i),a%irp(i+1)-1
write(iout,frmtv) (i),ivc(a%ja(j)),a%val(j)
end do
enddo
else if (.not.present(ivr).and..not.present(ivc)) then
do i=1, nr
do j=a%irp(i),a%irp(i+1)-1
write(iout,frmtv) (i),(a%ja(j)),a%val(j)
end do
enddo
endif
endif
end subroutine d_csr_print
end module psbn_d_csr_mat_mod
base/newserial/psbn_mat_impl.f03
+3 -1
View File
@@ -2,6 +2,7 @@ subroutine psbn_d_spcnv(a,b,info,type,mold,upd,dupl)
use psbn_d_mat_mod, psb_protect_name => psbn_d_spcnv
use psb_realloc_mod
use psb_sort_mod
implicit none
type(psbn_d_sparse_mat), intent(in) :: a
type(psbn_d_sparse_mat), intent(out) :: b
integer, intent(out) :: info
@@ -15,7 +16,8 @@ subroutine psbn_d_spcnv_ip(a,info,type,mold,dupl)
use psbn_d_mat_mod, psb_protect_name => psbn_d_spcnv_ip
use psb_realloc_mod
use psb_sort_mod
implicit none
type(psbn_d_sparse_mat), intent(inout) :: a
integer, intent(out) :: info
integer,optional, intent(in) :: dupl
base/newserial/psbn_mat_mod.f03
+33 -4
View File
@@ -77,6 +77,7 @@ contains
function get_dupl(a) result(res)
use psb_error_mod
implicit none
class(psbn_d_sparse_mat), intent(in) :: a
integer :: res
@@ -89,6 +90,7 @@ contains
function get_state(a) result(res)
implicit none
class(psbn_d_sparse_mat), intent(in) :: a
integer :: res
@@ -100,6 +102,7 @@ contains
end function get_state
function get_nrows(a) result(res)
implicit none
class(psbn_d_sparse_mat), intent(in) :: a
integer :: res
@@ -112,6 +115,7 @@ contains
end function get_nrows
function get_ncols(a) result(res)
implicit none
class(psbn_d_sparse_mat), intent(in) :: a
integer :: res
@@ -124,6 +128,7 @@ contains
end function get_ncols
function is_triangle(a) result(res)
implicit none
class(psbn_d_sparse_mat), intent(in) :: a
logical :: res
@@ -136,6 +141,7 @@ contains
end function is_triangle
function is_unit(a) result(res)
implicit none
class(psbn_d_sparse_mat), intent(in) :: a
logical :: res
@@ -148,6 +154,7 @@ contains
end function is_unit
function is_upper(a) result(res)
implicit none
class(psbn_d_sparse_mat), intent(in) :: a
logical :: res
@@ -160,6 +167,7 @@ contains
end function is_upper
function is_lower(a) result(res)
implicit none
class(psbn_d_sparse_mat), intent(in) :: a
logical :: res
@@ -172,6 +180,7 @@ contains
end function is_lower
function is_null(a) result(res)
implicit none
class(psbn_d_sparse_mat), intent(in) :: a
logical :: res
@@ -184,6 +193,7 @@ contains
end function is_null
function is_bld(a) result(res)
implicit none
class(psbn_d_sparse_mat), intent(in) :: a
logical :: res
@@ -196,6 +206,7 @@ contains
end function is_bld
function is_upd(a) result(res)
implicit none
class(psbn_d_sparse_mat), intent(in) :: a
logical :: res
@@ -208,6 +219,7 @@ contains
end function is_upd
function is_asb(a) result(res)
implicit none
class(psbn_d_sparse_mat), intent(in) :: a
logical :: res
@@ -220,6 +232,7 @@ contains
end function is_asb
function is_sorted(a) result(res)
implicit none
class(psbn_d_sparse_mat), intent(in) :: a
logical :: res
@@ -234,10 +247,11 @@ contains
function get_nzeros(a) result(res)
use psb_error_mod
implicit none
class(psbn_d_sparse_mat), intent(in) :: a
integer :: res
Integer :: err_act
Integer :: err_act, info
character(len=20) :: name='get_nzeros'
logical, parameter :: debug=.false.
@@ -265,10 +279,11 @@ contains
function get_size(a) result(res)
use psb_error_mod
implicit none
class(psbn_d_sparse_mat), intent(in) :: a
integer :: res
Integer :: err_act
Integer :: err_act, info
character(len=20) :: name='get_size'
logical, parameter :: debug=.false.
@@ -298,6 +313,7 @@ contains
subroutine get_neigh(a,idx,neigh,n,info,lev)
use psb_error_mod
implicit none
class(psbn_d_sparse_mat), intent(in) :: a
integer, intent(in) :: idx
integer, intent(out) :: n
@@ -309,6 +325,7 @@ contains
character(len=20) :: name='get_neigh'
logical, parameter :: debug=.false.
info = 0
call psb_erractionsave(err_act)
if (.not.allocated(a%a)) then
info = 1121
@@ -337,6 +354,7 @@ contains
subroutine allocate_mn(m,n,a,type,mold)
use psb_error_mod
use psb_string_mod
implicit none
integer, intent(in) :: m,n
class(psbn_d_sparse_mat), intent(inout) :: a
character(len=*), intent(in), optional :: type
@@ -405,6 +423,7 @@ contains
subroutine allocate_mnnz(m,n,nz,a,type,mold)
use psb_error_mod
use psb_string_mod
implicit none
integer, intent(in) :: m,n,nz
class(psbn_d_sparse_mat), intent(inout) :: a
character(len=*), intent(in), optional :: type
@@ -472,9 +491,10 @@ contains
subroutine reallocate_nz(nz,a)
use psb_error_mod
implicit none
integer, intent(in) :: nz
class(psbn_d_sparse_mat), intent(inout) :: a
Integer :: err_act
Integer :: err_act, info
character(len=20) :: name='reallocate_nz'
logical, parameter :: debug=.false.
@@ -504,8 +524,9 @@ contains
subroutine free(a)
use psb_error_mod
implicit none
class(psbn_d_sparse_mat), intent(inout) :: a
Integer :: err_act
Integer :: err_act, info
character(len=20) :: name='free'
logical, parameter :: debug=.false.
@@ -535,6 +556,7 @@ contains
subroutine d_csmm(alpha,a,x,beta,y,info,trans)
use psb_error_mod
implicit none
class(psbn_d_sparse_mat), intent(in) :: a
real(kind(1.d0)), intent(in) :: alpha, beta, x(:,:)
real(kind(1.d0)), intent(inout) :: y(:,:)
@@ -544,6 +566,7 @@ contains
character(len=20) :: name='psbn_csmm'
logical, parameter :: debug=.false.
info = 0
call psb_erractionsave(err_act)
if (.not.allocated(a%a)) then
info = 1121
@@ -569,6 +592,7 @@ contains
subroutine d_csmv(alpha,a,x,beta,y,info,trans)
use psb_error_mod
implicit none
class(psbn_d_sparse_mat), intent(in) :: a
real(kind(1.d0)), intent(in) :: alpha, beta, x(:)
real(kind(1.d0)), intent(inout) :: y(:)
@@ -578,6 +602,7 @@ contains
character(len=20) :: name='psbn_csmv'
logical, parameter :: debug=.false.
info = 0
call psb_erractionsave(err_act)
if (.not.allocated(a%a)) then
info = 1121
@@ -603,6 +628,7 @@ contains
subroutine d_cssm(alpha,a,x,beta,y,info,trans)
use psb_error_mod
implicit none
class(psbn_d_sparse_mat), intent(in) :: a
real(kind(1.d0)), intent(in) :: alpha, beta, x(:,:)
real(kind(1.d0)), intent(inout) :: y(:,:)
@@ -612,6 +638,7 @@ contains
character(len=20) :: name='psbn_cssm'
logical, parameter :: debug=.false.
info = 0
call psb_erractionsave(err_act)
if (.not.allocated(a%a)) then
info = 1121
@@ -637,6 +664,7 @@ contains
subroutine d_cssv(alpha,a,x,beta,y,info,trans)
use psb_error_mod
implicit none
class(psbn_d_sparse_mat), intent(in) :: a
real(kind(1.d0)), intent(in) :: alpha, beta, x(:)
real(kind(1.d0)), intent(inout) :: y(:)
@@ -646,6 +674,7 @@ contains
character(len=20) :: name='psbn_cssv'
logical, parameter :: debug=.false.
info = 0
call psb_erractionsave(err_act)
if (.not.allocated(a%a)) then
info = 1121
base/serial/csr/dcsrsm.f
+1 -1
View File
@@ -60,7 +60,7 @@ C .. Local Arrays ..
CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL)
GOTO 9999
END IF
IF (psb_toupper(DESCRA(3:3)).EQ.'N') DIAG = 'N'
DIAG = 'N'
IF (psb_toupper(DESCRA(3:3)).EQ.'U') DIAG = 'U'
IF(UNITD.EQ.'B') THEN
IERROR=5