base/modules/Makefile
 base/modules/psb_base_mat_mod.f03
 base/modules/psb_c_base_mat_mod.f03
 base/modules/psb_c_csc_mat_mod.f03
 base/modules/psb_c_csr_mat_mod.f03
 base/modules/psb_c_mat_mod.f03
 base/modules/psb_d_base_mat_mod.f03
 base/modules/psb_d_csc_mat_mod.f03
 base/modules/psb_d_csr_mat_mod.f03
 base/modules/psb_d_mat_mod.f03
 base/modules/psb_s_base_mat_mod.f03
 base/modules/psb_s_csc_mat_mod.f03
 base/modules/psb_s_csr_mat_mod.f03
 base/modules/psb_s_mat_mod.f03
 base/modules/psb_sort_mod.f90
 base/modules/psb_z_base_mat_mod.f03
 base/modules/psb_z_csc_mat_mod.f03
 base/modules/psb_z_csr_mat_mod.f03
 base/modules/psb_z_mat_mod.f03
 base/modules/psi_mod.f90
 base/modules/psi_serial_mod.f90
 base/psblas/psb_cnrmi.f90
 base/psblas/psb_dnrmi.f90
 base/psblas/psb_snrmi.f90
 base/psblas/psb_znrmi.f90
 base/serial/Makefile
 base/serial/f03/Makefile
 base/serial/f03/psb_base_mat_impl.f03
 base/serial/f03/psb_c_base_mat_impl.f03
 base/serial/f03/psb_c_coo_impl.f03
 base/serial/f03/psb_c_csc_impl.f03
 base/serial/f03/psb_c_csr_impl.f03
 base/serial/f03/psb_c_mat_impl.f03
 base/serial/f03/psb_d_base_mat_impl.f03
 base/serial/f03/psb_d_coo_impl.f03
 base/serial/f03/psb_d_csc_impl.f03
 base/serial/f03/psb_d_csr_impl.f03
 base/serial/f03/psb_d_mat_impl.f03
 base/serial/f03/psb_s_base_mat_impl.f03
 base/serial/f03/psb_s_coo_impl.f03
 base/serial/f03/psb_s_csc_impl.f03
 base/serial/f03/psb_s_csr_impl.f03
 base/serial/f03/psb_s_mat_impl.f03
 base/serial/f03/psb_z_base_mat_impl.f03
 base/serial/f03/psb_z_coo_impl.f03
 base/serial/f03/psb_z_csc_impl.f03
 base/serial/f03/psb_z_csr_impl.f03
 base/serial/f03/psb_z_mat_impl.f03
 base/serial/psb_sort_impl.f90
 base/serial/psi_impl.f90
 base/serial/psi_serial_impl.f90
 test/pargen/runs/ppde.inp
 test/torture
 test/torture/Makefile
 test/torture/psb_mvsv_tester.f90
 test/torture/psbtf.f90
 test/torture/runs
 util/Makefile
 util/psb_hbio_impl.f90
 util/psb_hbio_mod.f90
 util/psb_mat_dist_impl.f90
 util/psb_mat_dist_mod.f90
 util/psb_mmio_impl.f90
 util/psb_mmio_mod.f90

Merged (at r 4082) the XLF-TEST branch, where we have decoupled
interface and implementation for serial stuff.
psblas3-type-indexed
Salvatore Filippone 15 years ago
parent eda6a4941a
commit 56fd1cfbea

@ -44,7 +44,7 @@ psb_c_mat_mod.o: psb_c_base_mat_mod.o psb_c_csr_mat_mod.o psb_c_csc_mat_mod.o
psb_z_mat_mod.o: psb_z_base_mat_mod.o psb_z_csr_mat_mod.o psb_z_csc_mat_mod.o psb_z_mat_mod.o: psb_z_base_mat_mod.o psb_z_csr_mat_mod.o psb_z_csc_mat_mod.o
psb_s_csc_mat_mod.o psb_s_csr_mat_mod.o: psb_s_base_mat_mod.o psb_s_csc_mat_mod.o psb_s_csr_mat_mod.o: psb_s_base_mat_mod.o
psb_d_csc_mat_mod.o psb_d_csr_mat_mod.o: psb_d_base_mat_mod.o psb_d_csc_mat_mod.o psb_d_csr_mat_mod.o: psb_d_base_mat_mod.o
psb_dccsc_mat_mod.o psb_c_csr_mat_mod.o: psb_c_base_mat_mod.o psb_c_csc_mat_mod.o psb_c_csr_mat_mod.o: psb_c_base_mat_mod.o
psb_z_csc_mat_mod.o psb_z_csr_mat_mod.o: psb_z_base_mat_mod.o psb_z_csc_mat_mod.o psb_z_csr_mat_mod.o: psb_z_base_mat_mod.o
psb_mat_mod.o: psb_s_mat_mod.o psb_d_mat_mod.o psb_c_mat_mod.o psb_z_mat_mod.o psb_mat_mod.o: psb_s_mat_mod.o psb_d_mat_mod.o psb_c_mat_mod.o psb_z_mat_mod.o
psb_realloc_mod.o : psb_error_mod.o psb_realloc_mod.o : psb_error_mod.o

@ -20,44 +20,44 @@ module psb_base_mat_mod
! !
! !
! ==================================== ! ====================================
procedure, pass(a) :: get_nrows procedure, pass(a) :: get_nrows => psb_base_get_nrows
procedure, pass(a) :: get_ncols procedure, pass(a) :: get_ncols => psb_base_get_ncols
procedure, pass(a) :: get_nzeros procedure, pass(a) :: get_nzeros => psb_base_get_nzeros
procedure, pass(a) :: get_nz_row procedure, pass(a) :: get_nz_row => psb_base_get_nz_row
procedure, pass(a) :: get_size procedure, pass(a) :: get_size => psb_base_get_size
procedure, pass(a) :: get_state procedure, pass(a) :: get_state => psb_base_get_state
procedure, pass(a) :: get_dupl procedure, pass(a) :: get_dupl => psb_base_get_dupl
procedure, pass(a) :: get_fmt procedure, pass(a) :: get_fmt => psb_base_get_fmt
procedure, pass(a) :: get_aux procedure, pass(a) :: get_aux => psb_base_get_aux
procedure, pass(a) :: is_null procedure, pass(a) :: is_null => psb_base_is_null
procedure, pass(a) :: is_bld procedure, pass(a) :: is_bld => psb_base_is_bld
procedure, pass(a) :: is_upd procedure, pass(a) :: is_upd => psb_base_is_upd
procedure, pass(a) :: is_asb procedure, pass(a) :: is_asb => psb_base_is_asb
procedure, pass(a) :: is_sorted procedure, pass(a) :: is_sorted => psb_base_is_sorted
procedure, pass(a) :: is_upper procedure, pass(a) :: is_upper => psb_base_is_upper
procedure, pass(a) :: is_lower procedure, pass(a) :: is_lower => psb_base_is_lower
procedure, pass(a) :: is_triangle procedure, pass(a) :: is_triangle => psb_base_is_triangle
procedure, pass(a) :: is_unit procedure, pass(a) :: is_unit => psb_base_is_unit
! ==================================== ! ====================================
! !
! Setters ! Setters
! !
! ==================================== ! ====================================
procedure, pass(a) :: set_nrows procedure, pass(a) :: set_nrows => psb_base_set_nrows
procedure, pass(a) :: set_ncols procedure, pass(a) :: set_ncols => psb_base_set_ncols
procedure, pass(a) :: set_dupl procedure, pass(a) :: set_dupl => psb_base_set_dupl
procedure, pass(a) :: set_state procedure, pass(a) :: set_state => psb_base_set_state
procedure, pass(a) :: set_null procedure, pass(a) :: set_null => psb_base_set_null
procedure, pass(a) :: set_bld procedure, pass(a) :: set_bld => psb_base_set_bld
procedure, pass(a) :: set_upd procedure, pass(a) :: set_upd => psb_base_set_upd
procedure, pass(a) :: set_asb procedure, pass(a) :: set_asb => psb_base_set_asb
procedure, pass(a) :: set_sorted procedure, pass(a) :: set_sorted => psb_base_set_sorted
procedure, pass(a) :: set_upper procedure, pass(a) :: set_upper => psb_base_set_upper
procedure, pass(a) :: set_lower procedure, pass(a) :: set_lower => psb_base_set_lower
procedure, pass(a) :: set_triangle procedure, pass(a) :: set_triangle => psb_base_set_triangle
procedure, pass(a) :: set_unit procedure, pass(a) :: set_unit => psb_base_set_unit
procedure, pass(a) :: set_aux procedure, pass(a) :: set_aux => psb_base_set_aux
! ==================================== ! ====================================
@ -65,164 +65,258 @@ module psb_base_mat_mod
! Data management ! Data management
! !
! ==================================== ! ====================================
procedure, pass(a) :: get_neigh procedure, pass(a) :: get_neigh => psb_base_get_neigh
procedure, pass(a) :: allocate_mnnz procedure, pass(a) :: free => psb_base_free
procedure, pass(a) :: reallocate_nz procedure, pass(a) :: trim => psb_base_trim
procedure, pass(a) :: free procedure, pass(a) :: reinit => psb_base_reinit
procedure, pass(a) :: trim procedure, pass(a) :: allocate_mnnz => psb_base_allocate_mnnz
procedure, pass(a) :: reinit procedure, pass(a) :: reallocate_nz => psb_base_reallocate_nz
generic, public :: allocate => allocate_mnnz generic, public :: allocate => allocate_mnnz
generic, public :: reallocate => reallocate_nz generic, public :: reallocate => reallocate_nz
procedure, pass(a) :: csgetptn procedure, pass(a) :: csgetptn => psb_base_csgetptn
generic, public :: csget => csgetptn generic, public :: csget => csgetptn
procedure, pass(a) :: print => sparse_print procedure, pass(a) :: print => psb_base_sparse_print
procedure, pass(a) :: sizeof procedure, pass(a) :: sizeof => psb_base_sizeof
procedure, pass(a) :: base_cp_from procedure, pass(a) :: psb_base_cp_from
generic, public :: cp_from => base_cp_from generic, public :: cp_from => psb_base_cp_from
procedure, pass(a) :: base_mv_from procedure, pass(a) :: psb_base_mv_from
generic, public :: mv_from => base_mv_from generic, public :: mv_from => psb_base_mv_from
procedure, pass(a) :: base_transp_1mat procedure, pass(a) :: transp_1mat => psb_base_transp_1mat
procedure, pass(a) :: base_transp_2mat procedure, pass(a) :: transp_2mat => psb_base_transp_2mat
generic, public :: transp => base_transp_1mat, base_transp_2mat generic, public :: transp => transp_1mat, transp_2mat
procedure, pass(a) :: base_transc_1mat procedure, pass(a) :: transc_1mat => psb_base_transc_1mat
procedure, pass(a) :: base_transc_2mat procedure, pass(a) :: transc_2mat => psb_base_transc_2mat
generic, public :: transc => base_transc_1mat, base_transc_2mat generic, public :: transc => transc_1mat, transc_2mat
end type psb_base_sparse_mat end type psb_base_sparse_mat
private :: set_nrows, set_ncols, set_dupl, set_state, &
& set_null, set_bld, set_upd, set_asb, set_sorted, set_upper, & interface
& set_lower, set_triangle, set_unit, get_nrows, get_ncols, & function psb_base_get_nz_row(idx,a) result(res)
& get_nzeros, get_size, get_state, get_dupl, is_null, is_bld, & import psb_base_sparse_mat, psb_long_int_k_
& is_upd, is_asb, is_sorted, is_upper, is_lower, is_triangle, & integer, intent(in) :: idx
& is_unit, get_neigh, allocate_mn, allocate_mnnz, reallocate_nz, & class(psb_base_sparse_mat), intent(in) :: a
& free, sparse_print, get_fmt, trim, sizeof, reinit, csgetptn, & integer :: res
& get_nz_row, get_aux, set_aux, base_cp_from, base_mv_from, & end function psb_base_get_nz_row
& base_transp_1mat, base_transp_2mat, base_transc_1mat, base_transc_2mat end interface
interface
function psb_base_get_nzeros(a) result(res)
import psb_base_sparse_mat, psb_long_int_k_
class(psb_base_sparse_mat), intent(in) :: a
integer :: res
end function psb_base_get_nzeros
end interface
interface
function psb_base_get_size(a) result(res)
import psb_base_sparse_mat, psb_long_int_k_
class(psb_base_sparse_mat), intent(in) :: a
integer :: res
end function psb_base_get_size
end interface
interface
subroutine psb_base_reinit(a,clear)
import psb_base_sparse_mat, psb_long_int_k_
class(psb_base_sparse_mat), intent(inout) :: a
logical, intent(in), optional :: clear
end subroutine psb_base_reinit
end interface
interface
subroutine psb_base_sparse_print(iout,a,iv,eirs,eics,head,ivr,ivc)
import psb_base_sparse_mat, psb_long_int_k_
integer, intent(in) :: iout
class(psb_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(:)
end subroutine psb_base_sparse_print
end interface
interface
subroutine psb_base_csgetptn(imin,imax,a,nz,ia,ja,info,&
& jmin,jmax,iren,append,nzin,rscale,cscale)
import psb_base_sparse_mat, psb_long_int_k_
class(psb_base_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 psb_base_csgetptn
end interface
interface
subroutine psb_base_get_neigh(a,idx,neigh,n,info,lev)
import psb_base_sparse_mat, psb_long_int_k_
class(psb_base_sparse_mat), intent(in) :: a
integer, intent(in) :: idx
integer, intent(out) :: n
integer, allocatable, intent(out) :: neigh(:)
integer, intent(out) :: info
integer, optional, intent(in) :: lev
end subroutine psb_base_get_neigh
end interface
interface
subroutine psb_base_allocate_mnnz(m,n,a,nz)
import psb_base_sparse_mat, psb_long_int_k_
integer, intent(in) :: m,n
class(psb_base_sparse_mat), intent(inout) :: a
integer, intent(in), optional :: nz
end subroutine psb_base_allocate_mnnz
end interface
interface
subroutine psb_base_reallocate_nz(nz,a)
import psb_base_sparse_mat, psb_long_int_k_
integer, intent(in) :: nz
class(psb_base_sparse_mat), intent(inout) :: a
end subroutine psb_base_reallocate_nz
end interface
interface
subroutine psb_base_free(a)
import psb_base_sparse_mat, psb_long_int_k_
class(psb_base_sparse_mat), intent(inout) :: a
end subroutine psb_base_free
end interface
interface
subroutine psb_base_trim(a)
import psb_base_sparse_mat, psb_long_int_k_
class(psb_base_sparse_mat), intent(inout) :: a
end subroutine psb_base_trim
end interface
contains contains
function sizeof(a) result(res) function psb_base_sizeof(a) result(res)
implicit none implicit none
class(psb_base_sparse_mat), intent(in) :: a class(psb_base_sparse_mat), intent(in) :: a
integer(psb_long_int_k_) :: res integer(psb_long_int_k_) :: res
res = 8 res = 8
end function sizeof end function psb_base_sizeof
function psb_base_get_fmt(a) result(res)
function get_fmt(a) result(res)
implicit none implicit none
class(psb_base_sparse_mat), intent(in) :: a class(psb_base_sparse_mat), intent(in) :: a
character(len=5) :: res character(len=5) :: res
res = 'NULL' res = 'NULL'
end function get_fmt end function psb_base_get_fmt
function get_dupl(a) result(res) function psb_base_get_dupl(a) result(res)
implicit none implicit none
class(psb_base_sparse_mat), intent(in) :: a class(psb_base_sparse_mat), intent(in) :: a
integer :: res integer :: res
res = a%duplicate res = a%duplicate
end function get_dupl end function psb_base_get_dupl
function get_state(a) result(res) function psb_base_get_state(a) result(res)
implicit none implicit none
class(psb_base_sparse_mat), intent(in) :: a class(psb_base_sparse_mat), intent(in) :: a
integer :: res integer :: res
res = a%state res = a%state
end function get_state end function psb_base_get_state
function get_nrows(a) result(res) function psb_base_get_nrows(a) result(res)
implicit none implicit none
class(psb_base_sparse_mat), intent(in) :: a class(psb_base_sparse_mat), intent(in) :: a
integer :: res integer :: res
res = a%m res = a%m
end function get_nrows end function psb_base_get_nrows
function get_ncols(a) result(res) function psb_base_get_ncols(a) result(res)
implicit none implicit none
class(psb_base_sparse_mat), intent(in) :: a class(psb_base_sparse_mat), intent(in) :: a
integer :: res integer :: res
res = a%n res = a%n
end function get_ncols end function psb_base_get_ncols
subroutine set_aux(v,a) subroutine psb_base_set_aux(v,a)
implicit none implicit none
class(psb_base_sparse_mat), intent(inout) :: a class(psb_base_sparse_mat), intent(inout) :: a
integer, intent(in) :: v(:) integer, intent(in) :: v(:)
! TBD ! TBD
write(0,*) 'SET_AUX is empty right now ' write(0,*) 'SET_AUX is empty right now '
end subroutine set_aux end subroutine psb_base_set_aux
subroutine get_aux(v,a) subroutine psb_base_get_aux(v,a)
implicit none implicit none
class(psb_base_sparse_mat), intent(in) :: a class(psb_base_sparse_mat), intent(in) :: a
integer, intent(out), allocatable :: v(:) integer, intent(out), allocatable :: v(:)
! TBD ! TBD
write(0,*) 'GET_AUX is empty right now ' write(0,*) 'GET_AUX is empty right now '
end subroutine get_aux end subroutine psb_base_get_aux
subroutine set_nrows(m,a) subroutine psb_base_set_nrows(m,a)
implicit none implicit none
class(psb_base_sparse_mat), intent(inout) :: a class(psb_base_sparse_mat), intent(inout) :: a
integer, intent(in) :: m integer, intent(in) :: m
a%m = m a%m = m
end subroutine set_nrows end subroutine psb_base_set_nrows
subroutine set_ncols(n,a) subroutine psb_base_set_ncols(n,a)
implicit none implicit none
class(psb_base_sparse_mat), intent(inout) :: a class(psb_base_sparse_mat), intent(inout) :: a
integer, intent(in) :: n integer, intent(in) :: n
a%n = n a%n = n
end subroutine set_ncols end subroutine psb_base_set_ncols
subroutine set_state(n,a) subroutine psb_base_set_state(n,a)
implicit none implicit none
class(psb_base_sparse_mat), intent(inout) :: a class(psb_base_sparse_mat), intent(inout) :: a
integer, intent(in) :: n integer, intent(in) :: n
a%state = n a%state = n
end subroutine set_state end subroutine psb_base_set_state
subroutine set_dupl(n,a) subroutine psb_base_set_dupl(n,a)
implicit none implicit none
class(psb_base_sparse_mat), intent(inout) :: a class(psb_base_sparse_mat), intent(inout) :: a
integer, intent(in) :: n integer, intent(in) :: n
a%duplicate = n a%duplicate = n
end subroutine set_dupl end subroutine psb_base_set_dupl
subroutine set_null(a) subroutine psb_base_set_null(a)
implicit none implicit none
class(psb_base_sparse_mat), intent(inout) :: a class(psb_base_sparse_mat), intent(inout) :: a
a%state = psb_spmat_null_ a%state = psb_spmat_null_
end subroutine set_null end subroutine psb_base_set_null
subroutine set_bld(a) subroutine psb_base_set_bld(a)
implicit none implicit none
class(psb_base_sparse_mat), intent(inout) :: a class(psb_base_sparse_mat), intent(inout) :: a
a%state = psb_spmat_bld_ a%state = psb_spmat_bld_
end subroutine set_bld end subroutine psb_base_set_bld
subroutine set_upd(a) subroutine psb_base_set_upd(a)
implicit none implicit none
class(psb_base_sparse_mat), intent(inout) :: a class(psb_base_sparse_mat), intent(inout) :: a
a%state = psb_spmat_upd_ a%state = psb_spmat_upd_
end subroutine set_upd end subroutine psb_base_set_upd
subroutine set_asb(a) subroutine psb_base_set_asb(a)
implicit none implicit none
class(psb_base_sparse_mat), intent(inout) :: a class(psb_base_sparse_mat), intent(inout) :: a
a%state = psb_spmat_asb_ a%state = psb_spmat_asb_
end subroutine set_asb end subroutine psb_base_set_asb
subroutine set_sorted(a,val) subroutine psb_base_set_sorted(a,val)
implicit none implicit none
class(psb_base_sparse_mat), intent(inout) :: a class(psb_base_sparse_mat), intent(inout) :: a
logical, intent(in), optional :: val logical, intent(in), optional :: val
@ -232,9 +326,9 @@ contains
else else
a%sorted = .true. a%sorted = .true.
end if end if
end subroutine set_sorted end subroutine psb_base_set_sorted
subroutine set_triangle(a,val) subroutine psb_base_set_triangle(a,val)
implicit none implicit none
class(psb_base_sparse_mat), intent(inout) :: a class(psb_base_sparse_mat), intent(inout) :: a
logical, intent(in), optional :: val logical, intent(in), optional :: val
@ -244,9 +338,9 @@ contains
else else
a%triangle = .true. a%triangle = .true.
end if end if
end subroutine set_triangle end subroutine psb_base_set_triangle
subroutine set_unit(a,val) subroutine psb_base_set_unit(a,val)
implicit none implicit none
class(psb_base_sparse_mat), intent(inout) :: a class(psb_base_sparse_mat), intent(inout) :: a
logical, intent(in), optional :: val logical, intent(in), optional :: val
@ -256,9 +350,9 @@ contains
else else
a%unitd = .true. a%unitd = .true.
end if end if
end subroutine set_unit end subroutine psb_base_set_unit
subroutine set_lower(a,val) subroutine psb_base_set_lower(a,val)
implicit none implicit none
class(psb_base_sparse_mat), intent(inout) :: a class(psb_base_sparse_mat), intent(inout) :: a
logical, intent(in), optional :: val logical, intent(in), optional :: val
@ -268,9 +362,9 @@ contains
else else
a%upper = .false. a%upper = .false.
end if end if
end subroutine set_lower end subroutine psb_base_set_lower
subroutine set_upper(a,val) subroutine psb_base_set_upper(a,val)
implicit none implicit none
class(psb_base_sparse_mat), intent(inout) :: a class(psb_base_sparse_mat), intent(inout) :: a
logical, intent(in), optional :: val logical, intent(in), optional :: val
@ -280,175 +374,72 @@ contains
else else
a%upper = .true. a%upper = .true.
end if end if
end subroutine set_upper end subroutine psb_base_set_upper
function is_triangle(a) result(res) function psb_base_is_triangle(a) result(res)
implicit none implicit none
class(psb_base_sparse_mat), intent(in) :: a class(psb_base_sparse_mat), intent(in) :: a
logical :: res logical :: res
res = a%triangle res = a%triangle
end function is_triangle end function psb_base_is_triangle
function is_unit(a) result(res) function psb_base_is_unit(a) result(res)
implicit none implicit none
class(psb_base_sparse_mat), intent(in) :: a class(psb_base_sparse_mat), intent(in) :: a
logical :: res logical :: res
res = a%unitd res = a%unitd
end function is_unit end function psb_base_is_unit
function is_upper(a) result(res) function psb_base_is_upper(a) result(res)
implicit none implicit none
class(psb_base_sparse_mat), intent(in) :: a class(psb_base_sparse_mat), intent(in) :: a
logical :: res logical :: res
res = a%upper res = a%upper
end function is_upper end function psb_base_is_upper
function is_lower(a) result(res) function psb_base_is_lower(a) result(res)
implicit none implicit none
class(psb_base_sparse_mat), intent(in) :: a class(psb_base_sparse_mat), intent(in) :: a
logical :: res logical :: res
res = .not.a%upper res = .not.a%upper
end function is_lower end function psb_base_is_lower
function is_null(a) result(res) function psb_base_is_null(a) result(res)
implicit none implicit none
class(psb_base_sparse_mat), intent(in) :: a class(psb_base_sparse_mat), intent(in) :: a
logical :: res logical :: res
res = (a%state == psb_spmat_null_) res = (a%state == psb_spmat_null_)
end function is_null end function psb_base_is_null
function is_bld(a) result(res) function psb_base_is_bld(a) result(res)
implicit none implicit none
class(psb_base_sparse_mat), intent(in) :: a class(psb_base_sparse_mat), intent(in) :: a
logical :: res logical :: res
res = (a%state == psb_spmat_bld_) res = (a%state == psb_spmat_bld_)
end function is_bld end function psb_base_is_bld
function is_upd(a) result(res) function psb_base_is_upd(a) result(res)
implicit none implicit none
class(psb_base_sparse_mat), intent(in) :: a class(psb_base_sparse_mat), intent(in) :: a
logical :: res logical :: res
res = (a%state == psb_spmat_upd_) res = (a%state == psb_spmat_upd_)
end function is_upd end function psb_base_is_upd
function is_asb(a) result(res) function psb_base_is_asb(a) result(res)
implicit none implicit none
class(psb_base_sparse_mat), intent(in) :: a class(psb_base_sparse_mat), intent(in) :: a
logical :: res logical :: res
res = (a%state == psb_spmat_asb_) res = (a%state == psb_spmat_asb_)
end function is_asb end function psb_base_is_asb
function is_sorted(a) result(res) function psb_base_is_sorted(a) result(res)
implicit none implicit none
class(psb_base_sparse_mat), intent(in) :: a class(psb_base_sparse_mat), intent(in) :: a
logical :: res logical :: res
res = a%sorted res = a%sorted
end function is_sorted end function psb_base_is_sorted
function get_nz_row(idx,a) result(res)
use psb_error_mod
implicit none
integer, intent(in) :: idx
class(psb_base_sparse_mat), intent(in) :: a
integer :: res
Integer :: err_act
character(len=20) :: name='base_get_nz_row'
logical, parameter :: debug=.false.
call psb_get_erraction(err_act)
res = -1
! 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,a_err=a%get_fmt())
if (err_act /= psb_act_ret_) then
call psb_error()
end if
return
end function get_nz_row
function get_nzeros(a) result(res)
use psb_error_mod
implicit none
class(psb_base_sparse_mat), intent(in) :: a
integer :: res
Integer :: err_act
character(len=20) :: name='base_get_nzeros'
logical, parameter :: debug=.false.
call psb_get_erraction(err_act)
res = -1
! 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,a_err=a%get_fmt())
if (err_act /= psb_act_ret_) then
call psb_error()
end if
return
end function get_nzeros
function get_size(a) result(res)
use psb_error_mod
implicit none
class(psb_base_sparse_mat), intent(in) :: a
integer :: res
Integer :: err_act
character(len=20) :: name='get_size'
logical, parameter :: debug=.false.
call psb_get_erraction(err_act) subroutine psb_base_mv_from(a,b)
res = -1
! 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,a_err=a%get_fmt())
if (err_act /= psb_act_ret_) then
call psb_error()
end if
return
end function get_size
subroutine reinit(a,clear)
use psb_error_mod
implicit none
class(psb_base_sparse_mat), intent(inout) :: a
logical, intent(in), optional :: clear
Integer :: err_act, info
character(len=20) :: name='reinit'
logical, parameter :: debug=.false.
call psb_get_erraction(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,a_err=a%get_fmt())
if (err_act /= psb_act_ret_) then
call psb_error()
end if
return
end subroutine reinit
!
!
subroutine base_mv_from(a,b)
use psb_error_mod
implicit none implicit none
class(psb_base_sparse_mat), intent(out) :: a class(psb_base_sparse_mat), intent(out) :: a
@ -464,12 +455,9 @@ contains
a%sorted = b%sorted a%sorted = b%sorted
call move_alloc(b%aux,a%aux) call move_alloc(b%aux,a%aux)
return end subroutine psb_base_mv_from
end subroutine base_mv_from subroutine psb_base_cp_from(a,b)
subroutine base_cp_from(a,b)
use psb_error_mod
implicit none implicit none
class(psb_base_sparse_mat), intent(out) :: a class(psb_base_sparse_mat), intent(out) :: a
@ -487,16 +475,10 @@ contains
allocate(a%aux(size(b%aux))) allocate(a%aux(size(b%aux)))
a%aux(:) = b%aux(:) a%aux(:) = b%aux(:)
end if end if
return
end subroutine base_cp_from
end subroutine psb_base_cp_from
! subroutine psb_base_transp_2mat(a,b)
! Here we go.
!
subroutine base_transp_2mat(a,b)
use psb_error_mod
implicit none implicit none
class(psb_base_sparse_mat), intent(out) :: a class(psb_base_sparse_mat), intent(out) :: a
@ -515,22 +497,18 @@ contains
a%aux(:) = b%aux(:) a%aux(:) = b%aux(:)
end if end if
return end subroutine psb_base_transp_2mat
end subroutine base_transp_2mat
subroutine base_transc_2mat(a,b) subroutine psb_base_transc_2mat(a,b)
use psb_error_mod
implicit none implicit none
class(psb_base_sparse_mat), intent(out) :: a class(psb_base_sparse_mat), intent(out) :: a
class(psb_base_sparse_mat), intent(in) :: b class(psb_base_sparse_mat), intent(in) :: b
call a%transp(b) call a%transp(b)
end subroutine base_transc_2mat end subroutine psb_base_transc_2mat
subroutine base_transp_1mat(a) subroutine psb_base_transp_1mat(a)
use psb_error_mod
implicit none implicit none
class(psb_base_sparse_mat), intent(inout) :: a class(psb_base_sparse_mat), intent(inout) :: a
@ -546,246 +524,15 @@ contains
a%upper = .not.a%upper a%upper = .not.a%upper
a%sorted = .false. a%sorted = .false.
return end subroutine psb_base_transp_1mat
end subroutine base_transp_1mat subroutine psb_base_transc_1mat(a)
subroutine base_transc_1mat(a)
use psb_error_mod
implicit none implicit none
class(psb_base_sparse_mat), intent(inout) :: a class(psb_base_sparse_mat), intent(inout) :: a
call a%transp() call a%transp()
end subroutine base_transc_1mat end subroutine psb_base_transc_1mat
subroutine sparse_print(iout,a,iv,eirs,eics,head,ivr,ivc)
use psb_error_mod
implicit none
integer, intent(in) :: iout
class(psb_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_get_erraction(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,a_err=a%get_fmt())
if (err_act /= psb_act_ret_) then
call psb_error()
end if
return
end subroutine sparse_print
subroutine 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_base_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_get_erraction(err_act)
! This is the base version. If we get here
! it means the derived class is incomplete,
! so we throw an error.
info = 700
call psb_errpush(info,name,a_err=a%get_fmt())
if (err_act /= psb_act_ret_) then
call psb_error()
end if
return
end subroutine csgetptn
subroutine get_neigh(a,idx,neigh,n,info,lev)
use psb_error_mod
use psb_realloc_mod
use psb_sort_mod
implicit none
class(psb_base_sparse_mat), intent(in) :: a
integer, intent(in) :: idx
integer, intent(out) :: n
integer, allocatable, intent(out) :: neigh(:)
integer, intent(out) :: info
integer, optional, intent(in) :: lev
integer :: lev_, i, nl, ifl,ill,&
& n1, err_act, nn, nidx,ntl
integer, allocatable :: ia(:), ja(:)
character(len=20) :: name='get_neigh'
logical, parameter :: debug=.false.
call psb_erractionsave(err_act)
info = 0
if(present(lev)) then
lev_ = lev
else
lev_=1
end if
! Turns out we can write get_neigh at this
! level
n = 0
call a%csget(idx,idx,n,ia,ja,info)
if (info == 0) call psb_realloc(n,neigh,info)
if (info /= 0) then
call psb_errpush(4000,name)
goto 9999
end if
neigh(1:n) = ja(1:n)
ifl = 1
ill = n
do nl = 2, lev_
n1 = ill - ifl + 1
call psb_ensure_size(ill+n1*n1,neigh,info)
if (info /= 0) then
call psb_errpush(4000,name)
goto 9999
end if
ntl = 0
do i=ifl,ill
nidx=neigh(i)
if ((nidx /= idx).and.(nidx > 0).and.(nidx <= a%m)) then
call a%csget(nidx,nidx,nn,ia,ja,info)
if (info==0) call psb_ensure_size(ill+ntl+nn,neigh,info)
if (info /= 0) then
call psb_errpush(4000,name)
goto 9999
end if
neigh(ill+ntl+1:ill+ntl+nn)=ja(1:nn)
ntl = ntl+nn
end if
end do
call psb_msort_unique(neigh(ill+1:ill+ntl),nn)
ifl = ill + 1
ill = ill + nn
end do
call psb_msort_unique(neigh(1:ill),nn,dir=psb_sort_up_)
n = nn
call psb_erractionrestore(err_act)
return
9999 continue
if (err_act /= psb_act_ret_) then
call psb_error()
end if
return
end subroutine get_neigh
subroutine allocate_mnnz(m,n,a,nz)
use psb_error_mod
implicit none
integer, intent(in) :: m,n
class(psb_base_sparse_mat), intent(inout) :: a
integer, intent(in), optional :: nz
Integer :: err_act
character(len=20) :: name='allocate_mnz'
logical, parameter :: debug=.false.
call psb_get_erraction(err_act)
! This is the base version. If we get here
! it means the derived class is incomplete,
! so we throw an error.
call psb_errpush(700,name,a_err=a%get_fmt())
if (err_act /= psb_act_ret_) then
call psb_error()
end if
return
end subroutine allocate_mnnz
subroutine reallocate_nz(nz,a)
use psb_error_mod
implicit none
integer, intent(in) :: nz
class(psb_base_sparse_mat), intent(inout) :: a
Integer :: err_act
character(len=20) :: name='reallocate_nz'
logical, parameter :: debug=.false.
call psb_get_erraction(err_act)
! This is the base version. If we get here
! it means the derived class is incomplete,
! so we throw an error.
call psb_errpush(700,name,a_err=a%get_fmt())
if (err_act /= psb_act_ret_) then
call psb_error()
end if
return
end subroutine reallocate_nz
subroutine free(a)
use psb_error_mod
implicit none
class(psb_base_sparse_mat), intent(inout) :: a
Integer :: err_act
character(len=20) :: name='free'
logical, parameter :: debug=.false.
call psb_get_erraction(err_act)
! This is the base version. If we get here
! it means the derived class is incomplete,
! so we throw an error.
call psb_errpush(700,name,a_err=a%get_fmt())
if (err_act /= psb_act_ret_) then
call psb_error()
end if
return
end subroutine free
subroutine trim(a)
use psb_error_mod
implicit none
class(psb_base_sparse_mat), intent(inout) :: a
Integer :: err_act
character(len=20) :: name='trim'
logical, parameter :: debug=.false.
call psb_get_erraction(err_act)
! This is the base version. If we get here
! it means the derived class is incomplete,
! so we throw an error.
call psb_errpush(700,name,a_err=a%get_fmt())
if (err_act /= psb_act_ret_) then
call psb_error()
end if
return
end subroutine trim
end module psb_base_mat_mod end module psb_base_mat_mod

File diff suppressed because it is too large Load Diff

File diff suppressed because it is too large Load Diff

File diff suppressed because it is too large Load Diff

File diff suppressed because it is too large Load Diff

File diff suppressed because it is too large Load Diff

File diff suppressed because it is too large Load Diff

File diff suppressed because it is too large Load Diff

File diff suppressed because it is too large Load Diff

File diff suppressed because it is too large Load Diff

File diff suppressed because it is too large Load Diff

File diff suppressed because it is too large Load Diff

File diff suppressed because it is too large Load Diff

File diff suppressed because it is too large Load Diff

File diff suppressed because it is too large Load Diff

File diff suppressed because it is too large Load Diff

File diff suppressed because it is too large Load Diff

File diff suppressed because it is too large Load Diff

File diff suppressed because it is too large Load Diff

File diff suppressed because it is too large Load Diff

@ -90,7 +90,7 @@ function psb_cnrmi(a,desc_a,info)
end if end if
if ((m /= 0).and.(n /= 0)) then if ((m /= 0).and.(n /= 0)) then
nrmi = psb_csnmi(a) nrmi = a%csnmi()
if(info /= 0) then if(info /= 0) then
info=4010 info=4010
ch_err='psb_csnmi' ch_err='psb_csnmi'

@ -95,7 +95,7 @@ function psb_dnrmi(a,desc_a,info)
end if end if
if ((m /= 0).and.(n /= 0)) then if ((m /= 0).and.(n /= 0)) then
nrmi = psb_csnmi(a) nrmi = a%csnmi()
if(info /= 0) then if(info /= 0) then
info=4010 info=4010
ch_err='psb_csnmi' ch_err='psb_csnmi'

@ -95,7 +95,7 @@ function psb_snrmi(a,desc_a,info)
end if end if
if ((m /= 0).and.(n /= 0)) then if ((m /= 0).and.(n /= 0)) then
nrmi = psb_csnmi(a) nrmi = a%csnmi()
if(info /= 0) then if(info /= 0) then
info=4010 info=4010
ch_err='psb_csnmi' ch_err='psb_csnmi'

@ -95,7 +95,7 @@ function psb_znrmi(a,desc_a,info)
end if end if
if ((m /= 0).and.(n /= 0)) then if ((m /= 0).and.(n /= 0)) then
nrmi = psb_csnmi(a) nrmi = a%csnmi()
if(info /= 0) then if(info /= 0) then
info=4010 info=4010
ch_err='psb_csnmi' ch_err='psb_csnmi'

@ -1,7 +1,7 @@
include ../../Make.inc include ../../Make.inc
FOBJS = psb_lsame.o \ FOBJS = psb_lsame.o psi_serial_impl.o psi_impl.o psb_sort_impl.o \
psb_ssymbmm.o psb_dsymbmm.o psb_csymbmm.o psb_zsymbmm.o \ psb_ssymbmm.o psb_dsymbmm.o psb_csymbmm.o psb_zsymbmm.o \
psb_snumbmm.o psb_dnumbmm.o psb_cnumbmm.o psb_znumbmm.o \ psb_snumbmm.o psb_dnumbmm.o psb_cnumbmm.o psb_znumbmm.o \
psb_srwextd.o psb_drwextd.o psb_crwextd.o psb_zrwextd.o psb_srwextd.o psb_drwextd.o psb_crwextd.o psb_zrwextd.o

@ -3,11 +3,13 @@ include ../../../Make.inc
# #
# The object files # The object files
# #
FOBJS = psb_s_csr_impl.o psb_c_csr_impl.o psb_d_csr_impl.o psb_z_csr_impl.o\ BOBJS=psb_base_mat_impl.o psb_s_base_mat_impl.o psb_d_base_mat_impl.o psb_c_base_mat_impl.o psb_z_base_mat_impl.o
psb_s_coo_impl.o psb_c_coo_impl.o psb_d_coo_impl.o psb_z_coo_impl.o\ SOBJS=psb_s_csr_impl.o psb_s_coo_impl.o psb_s_csc_impl.o psb_s_mat_impl.o
psb_s_csc_impl.o psb_c_csc_impl.o psb_d_csc_impl.o psb_z_csc_impl.o DOBJS=psb_d_csr_impl.o psb_d_coo_impl.o psb_d_csc_impl.o psb_d_mat_impl.o
COBJS=psb_c_csr_impl.o psb_c_coo_impl.o psb_c_csc_impl.o psb_c_mat_impl.o
ZOBJS=psb_z_csr_impl.o psb_z_coo_impl.o psb_z_csc_impl.o psb_z_mat_impl.o
OBJS=$(FOBJS) OBJS=$(BOBJS) $(SOBJS) $(DOBJS) $(COBJS) $(ZOBJS)
# #
# Where the library should go, and how it is called. # Where the library should go, and how it is called.
@ -30,6 +32,9 @@ lib: $(OBJS)
$(AR) $(LIBDIR)/$(LIBNAME) $(OBJS) $(AR) $(LIBDIR)/$(LIBNAME) $(OBJS)
$(RANLIB) $(LIBDIR)/$(LIBNAME) $(RANLIB) $(LIBDIR)/$(LIBNAME)
# A bit excessive, but safe
$(OBJS): $(MODDIR)/psb_sparse_mod.o
clean: cleanobjs clean: cleanobjs
veryclean: cleanobjs veryclean: cleanobjs

@ -0,0 +1,337 @@
function psb_base_get_nz_row(idx,a) result(res)
use psb_error_mod
use psb_base_mat_mod, psb_protect_name => psb_base_get_nz_row
implicit none
integer, intent(in) :: idx
class(psb_base_sparse_mat), intent(in) :: a
integer :: res
Integer :: err_act
character(len=20) :: name='base_get_nz_row'
logical, parameter :: debug=.false.
call psb_get_erraction(err_act)
res = -1
! 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,a_err=a%get_fmt())
if (err_act /= psb_act_ret_) then
call psb_error()
end if
return
end function psb_base_get_nz_row
function psb_base_get_nzeros(a) result(res)
use psb_base_mat_mod, psb_protect_name => psb_base_get_nzeros
use psb_error_mod
implicit none
class(psb_base_sparse_mat), intent(in) :: a
integer :: res
Integer :: err_act
character(len=20) :: name='base_get_nzeros'
logical, parameter :: debug=.false.
call psb_get_erraction(err_act)
res = -1
! 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,a_err=a%get_fmt())
if (err_act /= psb_act_ret_) then
call psb_error()
end if
return
end function psb_base_get_nzeros
function psb_base_get_size(a) result(res)
use psb_base_mat_mod, psb_protect_name => psb_base_get_size
use psb_error_mod
implicit none
class(psb_base_sparse_mat), intent(in) :: a
integer :: res
Integer :: err_act
character(len=20) :: name='get_size'
logical, parameter :: debug=.false.
call psb_get_erraction(err_act)
res = -1
! 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,a_err=a%get_fmt())
if (err_act /= psb_act_ret_) then
call psb_error()
end if
return
end function psb_base_get_size
subroutine psb_base_reinit(a,clear)
use psb_base_mat_mod, psb_protect_name => psb_base_reinit
use psb_error_mod
implicit none
class(psb_base_sparse_mat), intent(inout) :: a
logical, intent(in), optional :: clear
Integer :: err_act, info
character(len=20) :: name='reinit'
logical, parameter :: debug=.false.
call psb_get_erraction(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,a_err=a%get_fmt())
if (err_act /= psb_act_ret_) then
call psb_error()
end if
return
end subroutine psb_base_reinit
subroutine psb_base_sparse_print(iout,a,iv,eirs,eics,head,ivr,ivc)
use psb_base_mat_mod, psb_protect_name => psb_base_sparse_print
use psb_error_mod
implicit none
integer, intent(in) :: iout
class(psb_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_get_erraction(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,a_err=a%get_fmt())
if (err_act /= psb_act_ret_) then
call psb_error()
end if
return
end subroutine psb_base_sparse_print
subroutine psb_base_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
use psb_base_mat_mod, psb_protect_name => psb_base_csgetptn
implicit none
class(psb_base_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_get_erraction(err_act)
! This is the base version. If we get here
! it means the derived class is incomplete,
! so we throw an error.
info = 700
call psb_errpush(info,name,a_err=a%get_fmt())
if (err_act /= psb_act_ret_) then
call psb_error()
end if
return
end subroutine psb_base_csgetptn
subroutine psb_base_get_neigh(a,idx,neigh,n,info,lev)
use psb_base_mat_mod, psb_protect_name => psb_base_get_neigh
use psb_error_mod
use psb_realloc_mod
use psb_sort_mod
implicit none
class(psb_base_sparse_mat), intent(in) :: a
integer, intent(in) :: idx
integer, intent(out) :: n
integer, allocatable, intent(out) :: neigh(:)
integer, intent(out) :: info
integer, optional, intent(in) :: lev
integer :: lev_, i, nl, ifl,ill,&
& n1, err_act, nn, nidx,ntl,ma
integer, allocatable :: ia(:), ja(:)
character(len=20) :: name='get_neigh'
logical, parameter :: debug=.false.
call psb_erractionsave(err_act)
info = 0
if(present(lev)) then
lev_ = lev
else
lev_=1
end if
! Turns out we can write get_neigh at this
! level
n = 0
ma = a%get_nrows()
call a%csget(idx,idx,n,ia,ja,info)
if (info == 0) call psb_realloc(n,neigh,info)
if (info /= 0) then
call psb_errpush(4000,name)
goto 9999
end if
neigh(1:n) = ja(1:n)
ifl = 1
ill = n
do nl = 2, lev_
n1 = ill - ifl + 1
call psb_ensure_size(ill+n1*n1,neigh,info)
if (info /= 0) then
call psb_errpush(4000,name)
goto 9999
end if
ntl = 0
do i=ifl,ill
nidx=neigh(i)
if ((nidx /= idx).and.(nidx > 0).and.(nidx <= ma)) then
call a%csget(nidx,nidx,nn,ia,ja,info)
if (info==0) call psb_ensure_size(ill+ntl+nn,neigh,info)
if (info /= 0) then
call psb_errpush(4000,name)
goto 9999
end if
neigh(ill+ntl+1:ill+ntl+nn)=ja(1:nn)
ntl = ntl+nn
end if
end do
call psb_msort_unique(neigh(ill+1:ill+ntl),nn)
ifl = ill + 1
ill = ill + nn
end do
call psb_msort_unique(neigh(1:ill),nn,dir=psb_sort_up_)
n = nn
call psb_erractionrestore(err_act)
return
9999 continue
if (err_act /= psb_act_ret_) then
call psb_error()
end if
return
end subroutine psb_base_get_neigh
subroutine psb_base_allocate_mnnz(m,n,a,nz)
use psb_base_mat_mod, psb_protect_name => psb_base_allocate_mnnz
use psb_error_mod
implicit none
integer, intent(in) :: m,n
class(psb_base_sparse_mat), intent(inout) :: a
integer, intent(in), optional :: nz
Integer :: err_act
character(len=20) :: name='allocate_mnz'
logical, parameter :: debug=.false.
call psb_get_erraction(err_act)
! This is the base version. If we get here
! it means the derived class is incomplete,
! so we throw an error.
call psb_errpush(700,name,a_err=a%get_fmt())
if (err_act /= psb_act_ret_) then
call psb_error()
end if
return
end subroutine psb_base_allocate_mnnz
subroutine psb_base_reallocate_nz(nz,a)
use psb_base_mat_mod, psb_protect_name => psb_base_reallocate_nz
use psb_error_mod
implicit none
integer, intent(in) :: nz
class(psb_base_sparse_mat), intent(inout) :: a
Integer :: err_act
character(len=20) :: name='reallocate_nz'
logical, parameter :: debug=.false.
call psb_get_erraction(err_act)
! This is the base version. If we get here
! it means the derived class is incomplete,
! so we throw an error.
call psb_errpush(700,name,a_err=a%get_fmt())
if (err_act /= psb_act_ret_) then
call psb_error()
end if
return
end subroutine psb_base_reallocate_nz
subroutine psb_base_free(a)
use psb_base_mat_mod, psb_protect_name => psb_base_free
use psb_error_mod
implicit none
class(psb_base_sparse_mat), intent(inout) :: a
Integer :: err_act
character(len=20) :: name='free'
logical, parameter :: debug=.false.
call psb_get_erraction(err_act)
! This is the base version. If we get here
! it means the derived class is incomplete,
! so we throw an error.
call psb_errpush(700,name,a_err=a%get_fmt())
if (err_act /= psb_act_ret_) then
call psb_error()
end if
return
end subroutine psb_base_free
subroutine psb_base_trim(a)
use psb_base_mat_mod, psb_protect_name => psb_base_trim
use psb_error_mod
implicit none
class(psb_base_sparse_mat), intent(inout) :: a
Integer :: err_act
character(len=20) :: name='trim'
logical, parameter :: debug=.false.
call psb_get_erraction(err_act)
! This is the base version. If we get here
! it means the derived class is incomplete,
! so we throw an error.
call psb_errpush(700,name,a_err=a%get_fmt())
if (err_act /= psb_act_ret_) then
call psb_error()
end if
return
end subroutine psb_base_trim

File diff suppressed because it is too large Load Diff

File diff suppressed because it is too large Load Diff

File diff suppressed because it is too large Load Diff

File diff suppressed because it is too large Load Diff

File diff suppressed because it is too large Load Diff

File diff suppressed because it is too large Load Diff

File diff suppressed because it is too large Load Diff

File diff suppressed because it is too large Load Diff

@ -12,10 +12,10 @@
! !
!===================================== !=====================================
subroutine d_csr_csmv_impl(alpha,a,x,beta,y,info,trans) subroutine psb_d_csr_csmv(alpha,a,x,beta,y,info,trans)
use psb_error_mod use psb_error_mod
use psb_string_mod use psb_string_mod
use psb_d_csr_mat_mod, psb_protect_name => d_csr_csmv_impl use psb_d_csr_mat_mod, psb_protect_name => psb_d_csr_csmv
implicit none implicit none
class(psb_d_csr_sparse_mat), intent(in) :: a class(psb_d_csr_sparse_mat), intent(in) :: a
real(psb_dpk_), intent(in) :: alpha, beta, x(:) real(psb_dpk_), intent(in) :: alpha, beta, x(:)
@ -57,7 +57,20 @@ subroutine d_csr_csmv_impl(alpha,a,x,beta,y,info,trans)
m = a%get_nrows() m = a%get_nrows()
end if end if
call d_csr_csmv_inner(m,n,alpha,a%irp,a%ja,a%val,& if (size(x,1)<n) then
info = 36
call psb_errpush(info,name,i_err=(/3,n,0,0,0/))
goto 9999
end if
if (size(y,1)<m) then
info = 36
call psb_errpush(info,name,i_err=(/5,m,0,0,0/))
goto 9999
end if
call psb_d_csr_csmv_inner(m,n,alpha,a%irp,a%ja,a%val,&
& a%is_triangle(),a%is_unit(),& & a%is_triangle(),a%is_unit(),&
& x,beta,y,tra) & x,beta,y,tra)
@ -74,7 +87,7 @@ subroutine d_csr_csmv_impl(alpha,a,x,beta,y,info,trans)
return return
contains contains
subroutine d_csr_csmv_inner(m,n,alpha,irp,ja,val,is_triangle,is_unit,& subroutine psb_d_csr_csmv_inner(m,n,alpha,irp,ja,val,is_triangle,is_unit,&
& x,beta,y,tra) & x,beta,y,tra)
integer, intent(in) :: m,n,irp(*),ja(*) integer, intent(in) :: m,n,irp(*),ja(*)
real(psb_dpk_), intent(in) :: alpha, beta, x(*),val(*) real(psb_dpk_), intent(in) :: alpha, beta, x(*),val(*)
@ -292,15 +305,15 @@ contains
end if end if
end subroutine d_csr_csmv_inner end subroutine psb_d_csr_csmv_inner
end subroutine d_csr_csmv_impl end subroutine psb_d_csr_csmv
subroutine d_csr_csmm_impl(alpha,a,x,beta,y,info,trans) subroutine psb_d_csr_csmm(alpha,a,x,beta,y,info,trans)
use psb_error_mod use psb_error_mod
use psb_string_mod use psb_string_mod
use psb_d_csr_mat_mod, psb_protect_name => d_csr_csmm_impl use psb_d_csr_mat_mod, psb_protect_name => psb_d_csr_csmm
implicit none implicit none
class(psb_d_csr_sparse_mat), intent(in) :: a class(psb_d_csr_sparse_mat), intent(in) :: a
real(psb_dpk_), intent(in) :: alpha, beta, x(:,:) real(psb_dpk_), intent(in) :: alpha, beta, x(:,:)
@ -340,6 +353,18 @@ subroutine d_csr_csmm_impl(alpha,a,x,beta,y,info,trans)
m = a%get_nrows() m = a%get_nrows()
end if end if
if (size(x,1)<n) then
info = 36
call psb_errpush(info,name,i_err=(/3,n,0,0,0/))
goto 9999
end if
if (size(y,1)<m) then
info = 36
call psb_errpush(info,name,i_err=(/5,m,0,0,0/))
goto 9999
end if
nc = min(size(x,2) , size(y,2) ) nc = min(size(x,2) , size(y,2) )
allocate(acc(nc), stat=info) allocate(acc(nc), stat=info)
@ -349,7 +374,7 @@ subroutine d_csr_csmm_impl(alpha,a,x,beta,y,info,trans)
goto 9999 goto 9999
end if end if
call d_csr_csmm_inner(m,n,nc,alpha,a%irp,a%ja,a%val, & call psb_d_csr_csmm_inner(m,n,nc,alpha,a%irp,a%ja,a%val, &
& a%is_triangle(),a%is_unit(),x,size(x,1), & & a%is_triangle(),a%is_unit(),x,size(x,1), &
& beta,y,size(y,1),tra,acc) & beta,y,size(y,1),tra,acc)
@ -366,7 +391,7 @@ subroutine d_csr_csmm_impl(alpha,a,x,beta,y,info,trans)
return return
contains contains
subroutine d_csr_csmm_inner(m,n,nc,alpha,irp,ja,val,& subroutine psb_d_csr_csmm_inner(m,n,nc,alpha,irp,ja,val,&
& is_triangle,is_unit,x,ldx,beta,y,ldy,tra,acc) & is_triangle,is_unit,x,ldx,beta,y,ldy,tra,acc)
integer, intent(in) :: m,n,ldx,ldy,nc,irp(*),ja(*) integer, intent(in) :: m,n,ldx,ldy,nc,irp(*),ja(*)
real(psb_dpk_), intent(in) :: alpha, beta, x(ldx,*),val(*) real(psb_dpk_), intent(in) :: alpha, beta, x(ldx,*),val(*)
@ -582,15 +607,15 @@ contains
end do end do
end if end if
end subroutine d_csr_csmm_inner end subroutine psb_d_csr_csmm_inner
end subroutine d_csr_csmm_impl end subroutine psb_d_csr_csmm
subroutine d_csr_cssv_impl(alpha,a,x,beta,y,info,trans) subroutine psb_d_csr_cssv(alpha,a,x,beta,y,info,trans)
use psb_error_mod use psb_error_mod
use psb_string_mod use psb_string_mod
use psb_d_csr_mat_mod, psb_protect_name => d_csr_cssv_impl use psb_d_csr_mat_mod, psb_protect_name => psb_d_csr_cssv
implicit none implicit none
class(psb_d_csr_sparse_mat), intent(in) :: a class(psb_d_csr_sparse_mat), intent(in) :: a
real(psb_dpk_), intent(in) :: alpha, beta, x(:) real(psb_dpk_), intent(in) :: alpha, beta, x(:)
@ -799,14 +824,14 @@ contains
end if end if
end subroutine inner_csrsv end subroutine inner_csrsv
end subroutine d_csr_cssv_impl end subroutine psb_d_csr_cssv
subroutine d_csr_cssm_impl(alpha,a,x,beta,y,info,trans) subroutine psb_d_csr_cssm(alpha,a,x,beta,y,info,trans)
use psb_error_mod use psb_error_mod
use psb_string_mod use psb_string_mod
use psb_d_csr_mat_mod, psb_protect_name => d_csr_cssm_impl use psb_d_csr_mat_mod, psb_protect_name => psb_d_csr_cssm
implicit none implicit none
class(psb_d_csr_sparse_mat), intent(in) :: a class(psb_d_csr_sparse_mat), intent(in) :: a
real(psb_dpk_), intent(in) :: alpha, beta, x(:,:) real(psb_dpk_), intent(in) :: alpha, beta, x(:,:)
@ -1017,11 +1042,11 @@ contains
end if end if
end subroutine inner_csrsm end subroutine inner_csrsm
end subroutine d_csr_cssm_impl end subroutine psb_d_csr_cssm
function d_csr_csnmi_impl(a) result(res) function psb_d_csr_csnmi(a) result(res)
use psb_error_mod use psb_error_mod
use psb_d_csr_mat_mod, psb_protect_name => d_csr_csnmi_impl use psb_d_csr_mat_mod, psb_protect_name => psb_d_csr_csnmi
implicit none implicit none
class(psb_d_csr_sparse_mat), intent(in) :: a class(psb_d_csr_sparse_mat), intent(in) :: a
real(psb_dpk_) :: res real(psb_dpk_) :: res
@ -1044,7 +1069,136 @@ function d_csr_csnmi_impl(a) result(res)
res = max(res,acc) res = max(res,acc)
end do end do
end function d_csr_csnmi_impl end function psb_d_csr_csnmi
subroutine psb_d_csr_get_diag(a,d,info)
use psb_error_mod
use psb_const_mod
use psb_d_csr_mat_mod, psb_protect_name => psb_d_csr_get_diag
implicit none
class(psb_d_csr_sparse_mat), intent(in) :: a
real(psb_dpk_), intent(out) :: d(:)
integer, intent(out) :: info
Integer :: err_act, mnm, i, j, k
character(len=20) :: name='get_diag'
logical, parameter :: debug=.false.
info = 0
call psb_erractionsave(err_act)
mnm = min(a%get_nrows(),a%get_ncols())
if (size(d) < mnm) then
info=35
call psb_errpush(info,name,i_err=(/2,size(d),0,0,0/))
goto 9999
end if
do i=1, mnm
do k=a%irp(i),a%irp(i+1)-1
j=a%ja(k)
if ((j==i) .and.(j <= mnm )) then
d(i) = a%val(k)
endif
enddo
end do
do i=mnm+1,size(d)
d(i) = dzero
end do
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 psb_d_csr_get_diag
subroutine psb_d_csr_scal(d,a,info)
use psb_error_mod
use psb_const_mod
use psb_d_csr_mat_mod, psb_protect_name => psb_d_csr_scal
implicit none
class(psb_d_csr_sparse_mat), intent(inout) :: a
real(psb_dpk_), intent(in) :: d(:)
integer, intent(out) :: info
Integer :: err_act,mnm, i, j, m
character(len=20) :: name='scal'
logical, parameter :: debug=.false.
info = 0
call psb_erractionsave(err_act)
m = a%get_nrows()
if (size(d) < m) then
info=35
call psb_errpush(info,name,i_err=(/2,size(d),0,0,0/))
goto 9999
end if
do i=1, m
do j = a%irp(i), a%irp(i+1) -1
a%val(j) = a%val(j) * d(i)
end do
enddo
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 psb_d_csr_scal
subroutine psb_d_csr_scals(d,a,info)
use psb_error_mod
use psb_const_mod
use psb_d_csr_mat_mod, psb_protect_name => psb_d_csr_scals
implicit none
class(psb_d_csr_sparse_mat), intent(inout) :: a
real(psb_dpk_), intent(in) :: d
integer, intent(out) :: info
Integer :: err_act,mnm, i, j, m
character(len=20) :: name='scal'
logical, parameter :: debug=.false.
info = 0
call psb_erractionsave(err_act)
do i=1,a%get_nzeros()
a%val(i) = a%val(i) * d
enddo
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 psb_d_csr_scals
!===================================== !=====================================
! !
@ -1059,14 +1213,113 @@ end function d_csr_csnmi_impl
!===================================== !=====================================
subroutine d_csr_csgetptn_impl(imin,imax,a,nz,ia,ja,info,& subroutine psb_d_csr_reallocate_nz(nz,a)
use psb_error_mod
use psb_realloc_mod
use psb_d_csr_mat_mod, psb_protect_name => psb_d_csr_reallocate_nz
implicit none
integer, intent(in) :: nz
class(psb_d_csr_sparse_mat), intent(inout) :: a
Integer :: err_act, info
character(len=20) :: name='d_csr_reallocate_nz'
logical, parameter :: debug=.false.
call psb_erractionsave(err_act)
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%get_nrows()+1,a%get_ncols()+1),a%irp,info)
if (info /= 0) then
call psb_errpush(4000,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 psb_d_csr_reallocate_nz
subroutine psb_d_csr_allocate_mnnz(m,n,a,nz)
use psb_error_mod
use psb_realloc_mod
use psb_d_csr_mat_mod, psb_protect_name => psb_d_csr_allocate_mnnz
implicit none
integer, intent(in) :: m,n
class(psb_d_csr_sparse_mat), intent(inout) :: a
integer, intent(in), optional :: nz
Integer :: err_act, info, nz_
character(len=20) :: name='allocate_mnz'
logical, parameter :: debug=.false.
call psb_erractionsave(err_act)
info = 0
if (m < 0) then
info = 10
call psb_errpush(info,name,i_err=(/1,0,0,0,0/))
goto 9999
endif
if (n < 0) then
info = 10
call psb_errpush(info,name,i_err=(/2,0,0,0,0/))
goto 9999
endif
if (present(nz)) then
nz_ = nz
else
nz_ = max(7*m,7*n,1)
end if
if (nz_ < 0) then
info = 10
call psb_errpush(info,name,i_err=(/3,0,0,0,0/))
goto 9999
endif
if (info == 0) call psb_realloc(m+1,a%irp,info)
if (info == 0) call psb_realloc(nz_,a%ja,info)
if (info == 0) call psb_realloc(nz_,a%val,info)
if (info == 0) then
a%irp=0
call a%set_nrows(m)
call a%set_ncols(n)
call a%set_bld()
call a%set_triangle(.false.)
call a%set_unit(.false.)
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 psb_d_csr_allocate_mnnz
subroutine psb_d_csr_csgetptn(imin,imax,a,nz,ia,ja,info,&
& jmin,jmax,iren,append,nzin,rscale,cscale) & jmin,jmax,iren,append,nzin,rscale,cscale)
! Output is always in COO format ! Output is always in COO format
use psb_error_mod use psb_error_mod
use psb_const_mod use psb_const_mod
use psb_error_mod use psb_error_mod
use psb_d_base_mat_mod use psb_d_base_mat_mod
use psb_d_csr_mat_mod, psb_protect_name => d_csr_csgetptn_impl use psb_d_csr_mat_mod, psb_protect_name => psb_d_csr_csgetptn
implicit none implicit none
class(psb_d_csr_sparse_mat), intent(in) :: a class(psb_d_csr_sparse_mat), intent(in) :: a
@ -1231,17 +1484,17 @@ contains
end subroutine csr_getptn end subroutine csr_getptn
end subroutine d_csr_csgetptn_impl end subroutine psb_d_csr_csgetptn
subroutine d_csr_csgetrow_impl(imin,imax,a,nz,ia,ja,val,info,& subroutine psb_d_csr_csgetrow(imin,imax,a,nz,ia,ja,val,info,&
& jmin,jmax,iren,append,nzin,rscale,cscale) & jmin,jmax,iren,append,nzin,rscale,cscale)
! Output is always in COO format ! Output is always in COO format
use psb_error_mod use psb_error_mod
use psb_const_mod use psb_const_mod
use psb_error_mod use psb_error_mod
use psb_d_base_mat_mod use psb_d_base_mat_mod
use psb_d_csr_mat_mod, psb_protect_name => d_csr_csgetrow_impl use psb_d_csr_mat_mod, psb_protect_name => psb_d_csr_csgetrow
implicit none implicit none
class(psb_d_csr_sparse_mat), intent(in) :: a class(psb_d_csr_sparse_mat), intent(in) :: a
@ -1412,14 +1665,73 @@ contains
end subroutine csr_getrow end subroutine csr_getrow
end subroutine d_csr_csgetrow_impl end subroutine psb_d_csr_csgetrow
subroutine psb_d_csr_csgetblk(imin,imax,a,b,info,&
& jmin,jmax,iren,append,rscale,cscale)
! Output is always in COO format
use psb_error_mod
use psb_const_mod
use psb_d_csr_mat_mod, psb_protect_name => psb_d_csr_csgetblk
implicit none
class(psb_d_csr_sparse_mat), intent(in) :: a
class(psb_d_coo_sparse_mat), intent(inout) :: b
integer, intent(in) :: imin,imax
integer,intent(out) :: info
logical, intent(in), optional :: append
integer, intent(in), optional :: iren(:)
integer, intent(in), optional :: jmin,jmax
logical, intent(in), optional :: rscale,cscale
Integer :: err_act, nzin, nzout
character(len=20) :: name='csget'
logical :: append_
logical, parameter :: debug=.false.
call psb_erractionsave(err_act)
info = 0
if (present(append)) then
append_ = append
else
append_ = .false.
endif
if (append_) then
nzin = a%get_nzeros()
else
nzin = 0
endif
call a%csget(imin,imax,nzout,b%ia,b%ja,b%val,info,&
& jmin=jmin, jmax=jmax, iren=iren, append=append_, &
& nzin=nzin, rscale=rscale, cscale=cscale)
subroutine d_csr_csput_impl(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl) if (info /= 0) goto 9999
call b%set_nzeros(nzin+nzout)
call b%fix(info)
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 psb_d_csr_csgetblk
subroutine psb_d_csr_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
use psb_error_mod use psb_error_mod
use psb_realloc_mod use psb_realloc_mod
use psb_d_csr_mat_mod, psb_protect_name => d_csr_csput_impl use psb_d_csr_mat_mod, psb_protect_name => psb_d_csr_csput
implicit none implicit none
class(psb_d_csr_sparse_mat), intent(inout) :: a class(psb_d_csr_sparse_mat), intent(inout) :: a
@ -1434,7 +1746,38 @@ subroutine d_csr_csput_impl(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
logical, parameter :: debug=.false. logical, parameter :: debug=.false.
integer :: nza, i,j,k, nzl, isza, int_err(5) integer :: nza, i,j,k, nzl, isza, int_err(5)
call psb_erractionsave(err_act)
info = 0 info = 0
if (nz <= 0) then
info = 10
int_err(1)=1
call psb_errpush(info,name,i_err=int_err)
goto 9999
end if
if (size(ia) < nz) then
info = 35
int_err(1)=2
call psb_errpush(info,name,i_err=int_err)
goto 9999
end if
if (size(ja) < nz) then
info = 35
int_err(1)=3
call psb_errpush(info,name,i_err=int_err)
goto 9999
end if
if (size(val) < nz) then
info = 35
int_err(1)=4
call psb_errpush(info,name,i_err=int_err)
goto 9999
end if
if (nz == 0) return
nza = a%get_nzeros() nza = a%get_nzeros()
if (a%is_bld()) then if (a%is_bld()) then
@ -1442,7 +1785,7 @@ subroutine d_csr_csput_impl(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
info = 1121 info = 1121
else if (a%is_upd()) then else if (a%is_upd()) then
call d_csr_srch_upd(nz,ia,ja,val,a,& call psb_d_csr_srch_upd(nz,ia,ja,val,a,&
& imin,imax,jmin,jmax,info,gtl) & imin,imax,jmin,jmax,info,gtl)
if (info /= 0) then if (info /= 0) then
@ -1474,7 +1817,7 @@ subroutine d_csr_csput_impl(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
contains contains
subroutine d_csr_srch_upd(nz,ia,ja,val,a,& subroutine psb_d_csr_srch_upd(nz,ia,ja,val,a,&
& imin,imax,jmin,jmax,info,gtl) & imin,imax,jmin,jmax,info,gtl)
use psb_const_mod use psb_const_mod
@ -1667,17 +2010,181 @@ contains
end if end if
end subroutine d_csr_srch_upd end subroutine psb_d_csr_srch_upd
end subroutine psb_d_csr_csput
subroutine psb_d_csr_reinit(a,clear)
use psb_error_mod
use psb_d_csr_mat_mod, psb_protect_name => psb_d_csr_reinit
implicit none
class(psb_d_csr_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 psb_d_csr_reinit
subroutine psb_d_csr_trim(a)
use psb_realloc_mod
use psb_error_mod
use psb_d_csr_mat_mod, psb_protect_name => psb_d_csr_trim
implicit none
class(psb_d_csr_sparse_mat), intent(inout) :: a
Integer :: err_act, info, nz, m
character(len=20) :: name='trim'
logical, parameter :: debug=.false.
call psb_erractionsave(err_act)
info = 0
m = a%get_nrows()
nz = a%get_nzeros()
if (info == 0) call psb_realloc(m+1,a%irp,info)
if (info == 0) call psb_realloc(nz,a%ja,info)
if (info == 0) call psb_realloc(nz,a%val,info)
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 psb_d_csr_trim
subroutine psb_d_csr_print(iout,a,iv,eirs,eics,head,ivr,ivc)
use psb_string_mod
use psb_d_csr_mat_mod, psb_protect_name => psb_d_csr_print
implicit none
integer, intent(in) :: iout
class(psb_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
end subroutine d_csr_csput_impl 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 psb_d_csr_print
subroutine d_cp_csr_from_coo_impl(a,b,info)
subroutine psb_d_cp_csr_from_coo(a,b,info)
use psb_const_mod use psb_const_mod
use psb_realloc_mod use psb_realloc_mod
use psb_d_base_mat_mod use psb_d_base_mat_mod
use psb_d_csr_mat_mod, psb_protect_name => d_cp_csr_from_coo_impl use psb_d_csr_mat_mod, psb_protect_name => psb_d_cp_csr_from_coo
implicit none implicit none
class(psb_d_csr_sparse_mat), intent(inout) :: a class(psb_d_csr_sparse_mat), intent(inout) :: a
@ -1698,18 +2205,18 @@ subroutine d_cp_csr_from_coo_impl(a,b,info)
call tmp%cp_from_coo(b,info) call tmp%cp_from_coo(b,info)
if (info ==0) call a%mv_from_coo(tmp,info) if (info ==0) call a%mv_from_coo(tmp,info)
end subroutine d_cp_csr_from_coo_impl end subroutine psb_d_cp_csr_from_coo
subroutine d_cp_csr_to_coo_impl(a,b,info) subroutine psb_d_cp_csr_to_coo(a,b,info)
use psb_const_mod use psb_const_mod
use psb_d_base_mat_mod use psb_d_base_mat_mod
use psb_d_csr_mat_mod, psb_protect_name => d_cp_csr_to_coo_impl use psb_d_csr_mat_mod, psb_protect_name => psb_d_cp_csr_to_coo
implicit none implicit none
class(psb_d_csr_sparse_mat), intent(in) :: a class(psb_d_csr_sparse_mat), intent(in) :: a
class(psb_d_coo_sparse_mat), intent(out) :: b class(psb_d_coo_sparse_mat), intent(inout) :: b
integer, intent(out) :: info integer, intent(out) :: info
integer, allocatable :: itemp(:) integer, allocatable :: itemp(:)
@ -1740,18 +2247,18 @@ subroutine d_cp_csr_to_coo_impl(a,b,info)
call b%fix(info) call b%fix(info)
end subroutine d_cp_csr_to_coo_impl end subroutine psb_d_cp_csr_to_coo
subroutine d_mv_csr_to_coo_impl(a,b,info) subroutine psb_d_mv_csr_to_coo(a,b,info)
use psb_const_mod use psb_const_mod
use psb_realloc_mod use psb_realloc_mod
use psb_d_base_mat_mod use psb_d_base_mat_mod
use psb_d_csr_mat_mod, psb_protect_name => d_mv_csr_to_coo_impl use psb_d_csr_mat_mod, psb_protect_name => psb_d_mv_csr_to_coo
implicit none implicit none
class(psb_d_csr_sparse_mat), intent(inout) :: a class(psb_d_csr_sparse_mat), intent(inout) :: a
class(psb_d_coo_sparse_mat), intent(out) :: b class(psb_d_coo_sparse_mat), intent(inout) :: b
integer, intent(out) :: info integer, intent(out) :: info
integer, allocatable :: itemp(:) integer, allocatable :: itemp(:)
@ -1783,15 +2290,15 @@ subroutine d_mv_csr_to_coo_impl(a,b,info)
call b%fix(info) call b%fix(info)
end subroutine d_mv_csr_to_coo_impl end subroutine psb_d_mv_csr_to_coo
subroutine d_mv_csr_from_coo_impl(a,b,info) subroutine psb_d_mv_csr_from_coo(a,b,info)
use psb_const_mod use psb_const_mod
use psb_realloc_mod use psb_realloc_mod
use psb_d_base_mat_mod use psb_d_base_mat_mod
use psb_d_csr_mat_mod, psb_protect_name => d_mv_csr_from_coo_impl use psb_d_csr_mat_mod, psb_protect_name => psb_d_mv_csr_from_coo
implicit none implicit none
class(psb_d_csr_sparse_mat), intent(inout) :: a class(psb_d_csr_sparse_mat), intent(inout) :: a
@ -1874,18 +2381,17 @@ subroutine d_mv_csr_from_coo_impl(a,b,info)
endif endif
end subroutine d_mv_csr_from_coo_impl end subroutine psb_d_mv_csr_from_coo
subroutine d_mv_csr_to_fmt_impl(a,b,info) subroutine psb_d_mv_csr_to_fmt(a,b,info)
use psb_const_mod use psb_const_mod
use psb_realloc_mod
use psb_d_base_mat_mod use psb_d_base_mat_mod
use psb_d_csr_mat_mod, psb_protect_name => d_mv_csr_to_fmt_impl use psb_d_csr_mat_mod, psb_protect_name => psb_d_mv_csr_to_fmt
implicit none implicit none
class(psb_d_csr_sparse_mat), intent(inout) :: a class(psb_d_csr_sparse_mat), intent(inout) :: a
class(psb_d_base_sparse_mat), intent(out) :: b class(psb_d_base_sparse_mat), intent(inout) :: b
integer, intent(out) :: info integer, intent(out) :: info
!locals !locals
@ -1914,18 +2420,17 @@ subroutine d_mv_csr_to_fmt_impl(a,b,info)
if (info == 0) call b%mv_from_coo(tmp,info) if (info == 0) call b%mv_from_coo(tmp,info)
end select end select
end subroutine d_mv_csr_to_fmt_impl end subroutine psb_d_mv_csr_to_fmt
subroutine d_cp_csr_to_fmt_impl(a,b,info) subroutine psb_d_cp_csr_to_fmt(a,b,info)
use psb_const_mod use psb_const_mod
use psb_realloc_mod
use psb_d_base_mat_mod use psb_d_base_mat_mod
use psb_d_csr_mat_mod, psb_protect_name => d_cp_csr_to_fmt_impl use psb_d_csr_mat_mod, psb_protect_name => psb_d_cp_csr_to_fmt
implicit none implicit none
class(psb_d_csr_sparse_mat), intent(in) :: a class(psb_d_csr_sparse_mat), intent(in) :: a
class(psb_d_base_sparse_mat), intent(out) :: b class(psb_d_base_sparse_mat), intent(inout) :: b
integer, intent(out) :: info integer, intent(out) :: info
!locals !locals
@ -1954,14 +2459,13 @@ subroutine d_cp_csr_to_fmt_impl(a,b,info)
if (info == 0) call b%mv_from_coo(tmp,info) if (info == 0) call b%mv_from_coo(tmp,info)
end select end select
end subroutine d_cp_csr_to_fmt_impl end subroutine psb_d_cp_csr_to_fmt
subroutine d_mv_csr_from_fmt_impl(a,b,info) subroutine psb_d_mv_csr_from_fmt(a,b,info)
use psb_const_mod use psb_const_mod
use psb_realloc_mod
use psb_d_base_mat_mod use psb_d_base_mat_mod
use psb_d_csr_mat_mod, psb_protect_name => d_mv_csr_from_fmt_impl use psb_d_csr_mat_mod, psb_protect_name => psb_d_mv_csr_from_fmt
implicit none implicit none
class(psb_d_csr_sparse_mat), intent(inout) :: a class(psb_d_csr_sparse_mat), intent(inout) :: a
@ -1994,15 +2498,14 @@ subroutine d_mv_csr_from_fmt_impl(a,b,info)
if (info == 0) call a%mv_from_coo(tmp,info) if (info == 0) call a%mv_from_coo(tmp,info)
end select end select
end subroutine d_mv_csr_from_fmt_impl end subroutine psb_d_mv_csr_from_fmt
subroutine d_cp_csr_from_fmt_impl(a,b,info) subroutine psb_d_cp_csr_from_fmt(a,b,info)
use psb_const_mod use psb_const_mod
use psb_realloc_mod
use psb_d_base_mat_mod use psb_d_base_mat_mod
use psb_d_csr_mat_mod, psb_protect_name => d_cp_csr_from_fmt_impl use psb_d_csr_mat_mod, psb_protect_name => psb_d_cp_csr_from_fmt
implicit none implicit none
class(psb_d_csr_sparse_mat), intent(inout) :: a class(psb_d_csr_sparse_mat), intent(inout) :: a
@ -2033,5 +2536,82 @@ subroutine d_cp_csr_from_fmt_impl(a,b,info)
call tmp%cp_from_fmt(b,info) call tmp%cp_from_fmt(b,info)
if (info == 0) call a%mv_from_coo(tmp,info) if (info == 0) call a%mv_from_coo(tmp,info)
end select end select
end subroutine d_cp_csr_from_fmt_impl end subroutine psb_d_cp_csr_from_fmt
subroutine psb_d_csr_cp_from(a,b)
use psb_error_mod
use psb_d_csr_mat_mod, psb_protect_name => psb_d_csr_cp_from
implicit none
class(psb_d_csr_sparse_mat), intent(inout) :: a
type(psb_d_csr_sparse_mat), intent(in) :: b
Integer :: 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 psb_d_csr_cp_from
subroutine psb_d_csr_mv_from(a,b)
use psb_error_mod
use psb_d_csr_mat_mod, psb_protect_name => psb_d_csr_mv_from
implicit none
class(psb_d_csr_sparse_mat), intent(inout) :: a
type(psb_d_csr_sparse_mat), intent(inout) :: b
Integer :: 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 psb_d_csr_mv_from

File diff suppressed because it is too large Load Diff

File diff suppressed because it is too large Load Diff

File diff suppressed because it is too large Load Diff

File diff suppressed because it is too large Load Diff

File diff suppressed because it is too large Load Diff

File diff suppressed because it is too large Load Diff

File diff suppressed because it is too large Load Diff

File diff suppressed because it is too large Load Diff

File diff suppressed because it is too large Load Diff

File diff suppressed because it is too large Load Diff

File diff suppressed because it is too large Load Diff

File diff suppressed because it is too large Load Diff

File diff suppressed because it is too large Load Diff

File diff suppressed because it is too large Load Diff

@ -2,7 +2,7 @@
BICGSTAB Iterative method BICGSTAB CGS BICG BICGSTABL RGMRES BICGSTAB Iterative method BICGSTAB CGS BICG BICGSTABL RGMRES
BJAC Preconditioner NONE DIAG BJAC BJAC Preconditioner NONE DIAG BJAC
CSR Storage format for matrix A: CSR COO JAD CSR Storage format for matrix A: CSR COO JAD
060 Domain size (acutal system is this**3) 020 Domain size (acutal system is this**3)
2 Stopping criterion 2 Stopping criterion
0100 MAXIT 0100 MAXIT
01 ITRACE 01 ITRACE

@ -0,0 +1,37 @@
include ../../Make.inc
#
# Libraries used
#
LIBDIR=../../lib/
PSBLAS_LIB= -L$(LIBDIR) -lpsb_util -lpsb_krylov -lpsb_prec -lpsb_base
LDLIBS=$(PSBLDLIBS)
#
# Compilers and such
#
CCOPT= -g
FINCLUDES=$(FMFLAG)$(LIBDIR) $(FMFLAG).
PSBTOBJS=psb_mvsv_tester.o psbtf.o
EXEDIR=./runs
all: psbtf
psbtf: $(PSBTOBJS)
$(F90LINK) $(PSBTOBJS) -o psbtf $(PSBLAS_LIB) $(LDLIBS)
/bin/mv psbtf $(EXEDIR)
psbtf.o: psb_mvsv_tester.o
.f90.o:
$(MPF90) $(F90COPT) $(FINCLUDES) $(FDEFINES) -c $<
clean:
/bin/rm -f $(PSBTOBJS) ppde.o spde.o $(EXEDIR)/ppde
verycleanlib:
(cd ../..; make veryclean)
lib:
(cd ../../; make library)

File diff suppressed because it is too large Load Diff

@ -0,0 +1,754 @@
!
! Parallel Sparse BLAS fortran interface testing code
!
!
!
program main
use psb_sparse_mod
use psb_mvsv_tester
implicit none
integer, parameter :: psb_fidasize_=16
integer :: res,passed=0,failed=0;
integer :: ictxt, iam=-1, np=-1
character(len=psb_fidasize_) :: afmt
write(*,*) 'Format ?'
read(*,*) afmt
! afmt = 'COO'
call psb_init(ictxt)
call psb_info(ictxt,iam,np)
if(iam<0)then
goto 9999
endif
call s_usmv_2_n_ap3_bp1_ix1_iy1(res,afmt,ictxt)
if(res/=0)failed=failed+1
if(res.eq.0)passed=passed+1
res=0
call s_usmv_2_t_ap3_bp1_ix1_iy1(res,afmt,ictxt)
if(res/=0)failed=failed+1
if(res.eq.0)passed=passed+1
res=0
call s_usmv_2_c_ap3_bp1_ix1_iy1(res,afmt,ictxt)
if(res/=0)failed=failed+1
if(res.eq.0)passed=passed+1
res=0
call s_usmv_2_n_ap3_bm0_ix1_iy1(res,afmt,ictxt)
if(res/=0)failed=failed+1
if(res.eq.0)passed=passed+1
res=0
call s_usmv_2_t_ap3_bm0_ix1_iy1(res,afmt,ictxt)
if(res/=0)failed=failed+1
if(res.eq.0)passed=passed+1
res=0
call s_usmv_2_c_ap3_bm0_ix1_iy1(res,afmt,ictxt)
if(res/=0)failed=failed+1
if(res.eq.0)passed=passed+1
res=0
call s_usmv_2_n_ap1_bp1_ix1_iy1(res,afmt,ictxt)
if(res/=0)failed=failed+1
if(res.eq.0)passed=passed+1
res=0
call s_usmv_2_t_ap1_bp1_ix1_iy1(res,afmt,ictxt)
if(res/=0)failed=failed+1
if(res.eq.0)passed=passed+1
res=0
call s_usmv_2_c_ap1_bp1_ix1_iy1(res,afmt,ictxt)
if(res/=0)failed=failed+1
if(res.eq.0)passed=passed+1
res=0
call s_usmv_2_n_ap1_bm0_ix1_iy1(res,afmt,ictxt)
if(res/=0)failed=failed+1
if(res.eq.0)passed=passed+1
res=0
call s_usmv_2_t_ap1_bm0_ix1_iy1(res,afmt,ictxt)
if(res/=0)failed=failed+1
if(res.eq.0)passed=passed+1
res=0
call s_usmv_2_c_ap1_bm0_ix1_iy1(res,afmt,ictxt)
if(res/=0)failed=failed+1
if(res.eq.0)passed=passed+1
res=0
call s_usmv_2_n_am1_bp1_ix1_iy1(res,afmt,ictxt)
if(res/=0)failed=failed+1
if(res.eq.0)passed=passed+1
res=0
call s_usmv_2_t_am1_bp1_ix1_iy1(res,afmt,ictxt)
if(res/=0)failed=failed+1
if(res.eq.0)passed=passed+1
res=0
call s_usmv_2_c_am1_bp1_ix1_iy1(res,afmt,ictxt)
if(res/=0)failed=failed+1
if(res.eq.0)passed=passed+1
res=0
call s_usmv_2_n_am1_bm0_ix1_iy1(res,afmt,ictxt)
if(res/=0)failed=failed+1
if(res.eq.0)passed=passed+1
res=0
call s_usmv_2_t_am1_bm0_ix1_iy1(res,afmt,ictxt)
if(res/=0)failed=failed+1
if(res.eq.0)passed=passed+1
res=0
call s_usmv_2_c_am1_bm0_ix1_iy1(res,afmt,ictxt)
if(res/=0)failed=failed+1
if(res.eq.0)passed=passed+1
res=0
call s_usmv_2_n_am3_bp1_ix1_iy1(res,afmt,ictxt)
if(res/=0)failed=failed+1
if(res.eq.0)passed=passed+1
res=0
call s_usmv_2_t_am3_bp1_ix1_iy1(res,afmt,ictxt)
if(res/=0)failed=failed+1
if(res.eq.0)passed=passed+1
res=0
call s_usmv_2_c_am3_bp1_ix1_iy1(res,afmt,ictxt)
if(res/=0)failed=failed+1
if(res.eq.0)passed=passed+1
res=0
call s_usmv_2_n_am3_bm0_ix1_iy1(res,afmt,ictxt)
if(res/=0)failed=failed+1
if(res.eq.0)passed=passed+1
res=0
call s_usmv_2_t_am3_bm0_ix1_iy1(res,afmt,ictxt)
if(res/=0)failed=failed+1
if(res.eq.0)passed=passed+1
res=0
call s_usmv_2_c_am3_bm0_ix1_iy1(res,afmt,ictxt)
if(res/=0)failed=failed+1
if(res.eq.0)passed=passed+1
res=0
call s_ussv_2_n_ap3_bm0_ix1_iy1(res,afmt,ictxt)
if(res/=0)failed=failed+1
if(res.eq.0)passed=passed+1
res=0
call s_ussv_2_t_ap3_bm0_ix1_iy1(res,afmt,ictxt)
if(res/=0)failed=failed+1
if(res.eq.0)passed=passed+1
res=0
call s_ussv_2_c_ap3_bm0_ix1_iy1(res,afmt,ictxt)
if(res/=0)failed=failed+1
if(res.eq.0)passed=passed+1
res=0
call s_ussv_2_n_ap1_bm0_ix1_iy1(res,afmt,ictxt)
if(res/=0)failed=failed+1
if(res.eq.0)passed=passed+1
res=0
call s_ussv_2_t_ap1_bm0_ix1_iy1(res,afmt,ictxt)
if(res/=0)failed=failed+1
if(res.eq.0)passed=passed+1
res=0
call s_ussv_2_c_ap1_bm0_ix1_iy1(res,afmt,ictxt)
if(res/=0)failed=failed+1
if(res.eq.0)passed=passed+1
res=0
call s_ussv_2_n_am1_bm0_ix1_iy1(res,afmt,ictxt)
if(res/=0)failed=failed+1
if(res.eq.0)passed=passed+1
res=0
call s_ussv_2_t_am1_bm0_ix1_iy1(res,afmt,ictxt)
if(res/=0)failed=failed+1
if(res.eq.0)passed=passed+1
res=0
call s_ussv_2_c_am1_bm0_ix1_iy1(res,afmt,ictxt)
if(res/=0)failed=failed+1
if(res.eq.0)passed=passed+1
res=0
call s_ussv_2_n_am3_bm0_ix1_iy1(res,afmt,ictxt)
if(res/=0)failed=failed+1
if(res.eq.0)passed=passed+1
res=0
call s_ussv_2_t_am3_bm0_ix1_iy1(res,afmt,ictxt)
if(res/=0)failed=failed+1
if(res.eq.0)passed=passed+1
res=0
call s_ussv_2_c_am3_bm0_ix1_iy1(res,afmt,ictxt)
if(res/=0)failed=failed+1
if(res.eq.0)passed=passed+1
res=0
call d_usmv_2_n_ap3_bp1_ix1_iy1(res,afmt,ictxt)
if(res/=0)failed=failed+1
if(res.eq.0)passed=passed+1
res=0
call d_usmv_2_t_ap3_bp1_ix1_iy1(res,afmt,ictxt)
if(res/=0)failed=failed+1
if(res.eq.0)passed=passed+1
res=0
call d_usmv_2_c_ap3_bp1_ix1_iy1(res,afmt,ictxt)
if(res/=0)failed=failed+1
if(res.eq.0)passed=passed+1
res=0
call d_usmv_2_n_ap3_bm0_ix1_iy1(res,afmt,ictxt)
if(res/=0)failed=failed+1
if(res.eq.0)passed=passed+1
res=0
call d_usmv_2_t_ap3_bm0_ix1_iy1(res,afmt,ictxt)
if(res/=0)failed=failed+1
if(res.eq.0)passed=passed+1
res=0
call d_usmv_2_c_ap3_bm0_ix1_iy1(res,afmt,ictxt)
if(res/=0)failed=failed+1
if(res.eq.0)passed=passed+1
res=0
call d_usmv_2_n_ap1_bp1_ix1_iy1(res,afmt,ictxt)
if(res/=0)failed=failed+1
if(res.eq.0)passed=passed+1
res=0
call d_usmv_2_t_ap1_bp1_ix1_iy1(res,afmt,ictxt)
if(res/=0)failed=failed+1
if(res.eq.0)passed=passed+1
res=0
call d_usmv_2_c_ap1_bp1_ix1_iy1(res,afmt,ictxt)
if(res/=0)failed=failed+1
if(res.eq.0)passed=passed+1
res=0
call d_usmv_2_n_ap1_bm0_ix1_iy1(res,afmt,ictxt)
if(res/=0)failed=failed+1
if(res.eq.0)passed=passed+1
res=0
call d_usmv_2_t_ap1_bm0_ix1_iy1(res,afmt,ictxt)
if(res/=0)failed=failed+1
if(res.eq.0)passed=passed+1
res=0
call d_usmv_2_c_ap1_bm0_ix1_iy1(res,afmt,ictxt)
if(res/=0)failed=failed+1
if(res.eq.0)passed=passed+1
res=0
call d_usmv_2_n_am1_bp1_ix1_iy1(res,afmt,ictxt)
if(res/=0)failed=failed+1
if(res.eq.0)passed=passed+1
res=0
call d_usmv_2_t_am1_bp1_ix1_iy1(res,afmt,ictxt)
if(res/=0)failed=failed+1
if(res.eq.0)passed=passed+1
res=0
call d_usmv_2_c_am1_bp1_ix1_iy1(res,afmt,ictxt)
if(res/=0)failed=failed+1
if(res.eq.0)passed=passed+1
res=0
call d_usmv_2_n_am1_bm0_ix1_iy1(res,afmt,ictxt)
if(res/=0)failed=failed+1
if(res.eq.0)passed=passed+1
res=0
call d_usmv_2_t_am1_bm0_ix1_iy1(res,afmt,ictxt)
if(res/=0)failed=failed+1
if(res.eq.0)passed=passed+1
res=0
call d_usmv_2_c_am1_bm0_ix1_iy1(res,afmt,ictxt)
if(res/=0)failed=failed+1
if(res.eq.0)passed=passed+1
res=0
call d_usmv_2_n_am3_bp1_ix1_iy1(res,afmt,ictxt)
if(res/=0)failed=failed+1
if(res.eq.0)passed=passed+1
res=0
call d_usmv_2_t_am3_bp1_ix1_iy1(res,afmt,ictxt)
if(res/=0)failed=failed+1
if(res.eq.0)passed=passed+1
res=0
call d_usmv_2_c_am3_bp1_ix1_iy1(res,afmt,ictxt)
if(res/=0)failed=failed+1
if(res.eq.0)passed=passed+1
res=0
call d_usmv_2_n_am3_bm0_ix1_iy1(res,afmt,ictxt)
if(res/=0)failed=failed+1
if(res.eq.0)passed=passed+1
res=0
call d_usmv_2_t_am3_bm0_ix1_iy1(res,afmt,ictxt)
if(res/=0)failed=failed+1
if(res.eq.0)passed=passed+1
res=0
call d_usmv_2_c_am3_bm0_ix1_iy1(res,afmt,ictxt)
if(res/=0)failed=failed+1
if(res.eq.0)passed=passed+1
res=0
call d_ussv_2_n_ap3_bm0_ix1_iy1(res,afmt,ictxt)
if(res/=0)failed=failed+1
if(res.eq.0)passed=passed+1
res=0
call d_ussv_2_t_ap3_bm0_ix1_iy1(res,afmt,ictxt)
if(res/=0)failed=failed+1
if(res.eq.0)passed=passed+1
res=0
call d_ussv_2_c_ap3_bm0_ix1_iy1(res,afmt,ictxt)
if(res/=0)failed=failed+1
if(res.eq.0)passed=passed+1
res=0
call d_ussv_2_n_ap1_bm0_ix1_iy1(res,afmt,ictxt)
if(res/=0)failed=failed+1
if(res.eq.0)passed=passed+1
res=0
call d_ussv_2_t_ap1_bm0_ix1_iy1(res,afmt,ictxt)
if(res/=0)failed=failed+1
if(res.eq.0)passed=passed+1
res=0
call d_ussv_2_c_ap1_bm0_ix1_iy1(res,afmt,ictxt)
if(res/=0)failed=failed+1
if(res.eq.0)passed=passed+1
res=0
call d_ussv_2_n_am1_bm0_ix1_iy1(res,afmt,ictxt)
if(res/=0)failed=failed+1
if(res.eq.0)passed=passed+1
res=0
call d_ussv_2_t_am1_bm0_ix1_iy1(res,afmt,ictxt)
if(res/=0)failed=failed+1
if(res.eq.0)passed=passed+1
res=0
call d_ussv_2_c_am1_bm0_ix1_iy1(res,afmt,ictxt)
if(res/=0)failed=failed+1
if(res.eq.0)passed=passed+1
res=0
call d_ussv_2_n_am3_bm0_ix1_iy1(res,afmt,ictxt)
if(res/=0)failed=failed+1
if(res.eq.0)passed=passed+1
res=0
call d_ussv_2_t_am3_bm0_ix1_iy1(res,afmt,ictxt)
if(res/=0)failed=failed+1
if(res.eq.0)passed=passed+1
res=0
call d_ussv_2_c_am3_bm0_ix1_iy1(res,afmt,ictxt)
if(res/=0)failed=failed+1
if(res.eq.0)passed=passed+1
res=0
call c_usmv_2_n_ap3_bp1_ix1_iy1(res,afmt,ictxt)
if(res/=0)failed=failed+1
if(res.eq.0)passed=passed+1
res=0
call c_usmv_2_t_ap3_bp1_ix1_iy1(res,afmt,ictxt)
if(res/=0)failed=failed+1
if(res.eq.0)passed=passed+1
res=0
call c_usmv_2_c_ap3_bp1_ix1_iy1(res,afmt,ictxt)
if(res/=0)failed=failed+1
if(res.eq.0)passed=passed+1
res=0
call c_usmv_2_n_ap3_bm0_ix1_iy1(res,afmt,ictxt)
if(res/=0)failed=failed+1
if(res.eq.0)passed=passed+1
res=0
call c_usmv_2_t_ap3_bm0_ix1_iy1(res,afmt,ictxt)
if(res/=0)failed=failed+1
if(res.eq.0)passed=passed+1
res=0
call c_usmv_2_c_ap3_bm0_ix1_iy1(res,afmt,ictxt)
if(res/=0)failed=failed+1
if(res.eq.0)passed=passed+1
res=0
call c_usmv_2_n_ap1_bp1_ix1_iy1(res,afmt,ictxt)
if(res/=0)failed=failed+1
if(res.eq.0)passed=passed+1
res=0
call c_usmv_2_t_ap1_bp1_ix1_iy1(res,afmt,ictxt)
if(res/=0)failed=failed+1
if(res.eq.0)passed=passed+1
res=0
call c_usmv_2_c_ap1_bp1_ix1_iy1(res,afmt,ictxt)
if(res/=0)failed=failed+1
if(res.eq.0)passed=passed+1
res=0
call c_usmv_2_n_ap1_bm0_ix1_iy1(res,afmt,ictxt)
if(res/=0)failed=failed+1
if(res.eq.0)passed=passed+1
res=0
call c_usmv_2_t_ap1_bm0_ix1_iy1(res,afmt,ictxt)
if(res/=0)failed=failed+1
if(res.eq.0)passed=passed+1
res=0
call c_usmv_2_c_ap1_bm0_ix1_iy1(res,afmt,ictxt)
if(res/=0)failed=failed+1
if(res.eq.0)passed=passed+1
res=0
call c_usmv_2_n_am1_bp1_ix1_iy1(res,afmt,ictxt)
if(res/=0)failed=failed+1
if(res.eq.0)passed=passed+1
res=0
call c_usmv_2_t_am1_bp1_ix1_iy1(res,afmt,ictxt)
if(res/=0)failed=failed+1
if(res.eq.0)passed=passed+1
res=0
call c_usmv_2_c_am1_bp1_ix1_iy1(res,afmt,ictxt)
if(res/=0)failed=failed+1
if(res.eq.0)passed=passed+1
res=0
call c_usmv_2_n_am1_bm0_ix1_iy1(res,afmt,ictxt)
if(res/=0)failed=failed+1
if(res.eq.0)passed=passed+1
res=0
call c_usmv_2_t_am1_bm0_ix1_iy1(res,afmt,ictxt)
if(res/=0)failed=failed+1
if(res.eq.0)passed=passed+1
res=0
call c_usmv_2_c_am1_bm0_ix1_iy1(res,afmt,ictxt)
if(res/=0)failed=failed+1
if(res.eq.0)passed=passed+1
res=0
call c_usmv_2_n_am3_bp1_ix1_iy1(res,afmt,ictxt)
if(res/=0)failed=failed+1
if(res.eq.0)passed=passed+1
res=0
call c_usmv_2_t_am3_bp1_ix1_iy1(res,afmt,ictxt)
if(res/=0)failed=failed+1
if(res.eq.0)passed=passed+1
res=0
call c_usmv_2_c_am3_bp1_ix1_iy1(res,afmt,ictxt)
if(res/=0)failed=failed+1
if(res.eq.0)passed=passed+1
res=0
call c_usmv_2_n_am3_bm0_ix1_iy1(res,afmt,ictxt)
if(res/=0)failed=failed+1
if(res.eq.0)passed=passed+1
res=0
call c_usmv_2_t_am3_bm0_ix1_iy1(res,afmt,ictxt)
if(res/=0)failed=failed+1
if(res.eq.0)passed=passed+1
res=0
call c_usmv_2_c_am3_bm0_ix1_iy1(res,afmt,ictxt)
if(res/=0)failed=failed+1
if(res.eq.0)passed=passed+1
res=0
call c_ussv_2_n_ap3_bm0_ix1_iy1(res,afmt,ictxt)
if(res/=0)failed=failed+1
if(res.eq.0)passed=passed+1
res=0
call c_ussv_2_t_ap3_bm0_ix1_iy1(res,afmt,ictxt)
if(res/=0)failed=failed+1
if(res.eq.0)passed=passed+1
res=0
call c_ussv_2_c_ap3_bm0_ix1_iy1(res,afmt,ictxt)
if(res/=0)failed=failed+1
if(res.eq.0)passed=passed+1
res=0
call c_ussv_2_n_ap1_bm0_ix1_iy1(res,afmt,ictxt)
if(res/=0)failed=failed+1
if(res.eq.0)passed=passed+1
res=0
call c_ussv_2_t_ap1_bm0_ix1_iy1(res,afmt,ictxt)
if(res/=0)failed=failed+1
if(res.eq.0)passed=passed+1
res=0
call c_ussv_2_c_ap1_bm0_ix1_iy1(res,afmt,ictxt)
if(res/=0)failed=failed+1
if(res.eq.0)passed=passed+1
res=0
call c_ussv_2_n_am1_bm0_ix1_iy1(res,afmt,ictxt)
if(res/=0)failed=failed+1
if(res.eq.0)passed=passed+1
res=0
call c_ussv_2_t_am1_bm0_ix1_iy1(res,afmt,ictxt)
if(res/=0)failed=failed+1
if(res.eq.0)passed=passed+1
res=0
call c_ussv_2_c_am1_bm0_ix1_iy1(res,afmt,ictxt)
if(res/=0)failed=failed+1
if(res.eq.0)passed=passed+1
res=0
call c_ussv_2_n_am3_bm0_ix1_iy1(res,afmt,ictxt)
if(res/=0)failed=failed+1
if(res.eq.0)passed=passed+1
res=0
call c_ussv_2_t_am3_bm0_ix1_iy1(res,afmt,ictxt)
if(res/=0)failed=failed+1
if(res.eq.0)passed=passed+1
res=0
call c_ussv_2_c_am3_bm0_ix1_iy1(res,afmt,ictxt)
if(res/=0)failed=failed+1
if(res.eq.0)passed=passed+1
res=0
call z_usmv_2_n_ap3_bp1_ix1_iy1(res,afmt,ictxt)
if(res/=0)failed=failed+1
if(res.eq.0)passed=passed+1
res=0
call z_usmv_2_t_ap3_bp1_ix1_iy1(res,afmt,ictxt)
if(res/=0)failed=failed+1
if(res.eq.0)passed=passed+1
res=0
call z_usmv_2_c_ap3_bp1_ix1_iy1(res,afmt,ictxt)
if(res/=0)failed=failed+1
if(res.eq.0)passed=passed+1
res=0
call z_usmv_2_n_ap3_bm0_ix1_iy1(res,afmt,ictxt)
if(res/=0)failed=failed+1
if(res.eq.0)passed=passed+1
res=0
call z_usmv_2_t_ap3_bm0_ix1_iy1(res,afmt,ictxt)
if(res/=0)failed=failed+1
if(res.eq.0)passed=passed+1
res=0
call z_usmv_2_c_ap3_bm0_ix1_iy1(res,afmt,ictxt)
if(res/=0)failed=failed+1
if(res.eq.0)passed=passed+1
res=0
call z_usmv_2_n_ap1_bp1_ix1_iy1(res,afmt,ictxt)
if(res/=0)failed=failed+1
if(res.eq.0)passed=passed+1
res=0
call z_usmv_2_t_ap1_bp1_ix1_iy1(res,afmt,ictxt)
if(res/=0)failed=failed+1
if(res.eq.0)passed=passed+1
res=0
call z_usmv_2_c_ap1_bp1_ix1_iy1(res,afmt,ictxt)
if(res/=0)failed=failed+1
if(res.eq.0)passed=passed+1
res=0
call z_usmv_2_n_ap1_bm0_ix1_iy1(res,afmt,ictxt)
if(res/=0)failed=failed+1
if(res.eq.0)passed=passed+1
res=0
call z_usmv_2_t_ap1_bm0_ix1_iy1(res,afmt,ictxt)
if(res/=0)failed=failed+1
if(res.eq.0)passed=passed+1
res=0
call z_usmv_2_c_ap1_bm0_ix1_iy1(res,afmt,ictxt)
if(res/=0)failed=failed+1
if(res.eq.0)passed=passed+1
res=0
call z_usmv_2_n_am1_bp1_ix1_iy1(res,afmt,ictxt)
if(res/=0)failed=failed+1
if(res.eq.0)passed=passed+1
res=0
call z_usmv_2_t_am1_bp1_ix1_iy1(res,afmt,ictxt)
if(res/=0)failed=failed+1
if(res.eq.0)passed=passed+1
res=0
call z_usmv_2_c_am1_bp1_ix1_iy1(res,afmt,ictxt)
if(res/=0)failed=failed+1
if(res.eq.0)passed=passed+1
res=0
call z_usmv_2_n_am1_bm0_ix1_iy1(res,afmt,ictxt)
if(res/=0)failed=failed+1
if(res.eq.0)passed=passed+1
res=0
call z_usmv_2_t_am1_bm0_ix1_iy1(res,afmt,ictxt)
if(res/=0)failed=failed+1
if(res.eq.0)passed=passed+1
res=0
call z_usmv_2_c_am1_bm0_ix1_iy1(res,afmt,ictxt)
if(res/=0)failed=failed+1
if(res.eq.0)passed=passed+1
res=0
call z_usmv_2_n_am3_bp1_ix1_iy1(res,afmt,ictxt)
if(res/=0)failed=failed+1
if(res.eq.0)passed=passed+1
res=0
call z_usmv_2_t_am3_bp1_ix1_iy1(res,afmt,ictxt)
if(res/=0)failed=failed+1
if(res.eq.0)passed=passed+1
res=0
call z_usmv_2_c_am3_bp1_ix1_iy1(res,afmt,ictxt)
if(res/=0)failed=failed+1
if(res.eq.0)passed=passed+1
res=0
call z_usmv_2_n_am3_bm0_ix1_iy1(res,afmt,ictxt)
if(res/=0)failed=failed+1
if(res.eq.0)passed=passed+1
res=0
call z_usmv_2_t_am3_bm0_ix1_iy1(res,afmt,ictxt)
if(res/=0)failed=failed+1
if(res.eq.0)passed=passed+1
res=0
call z_usmv_2_c_am3_bm0_ix1_iy1(res,afmt,ictxt)
if(res/=0)failed=failed+1
if(res.eq.0)passed=passed+1
res=0
call z_ussv_2_n_ap3_bm0_ix1_iy1(res,afmt,ictxt)
if(res/=0)failed=failed+1
if(res.eq.0)passed=passed+1
res=0
call z_ussv_2_t_ap3_bm0_ix1_iy1(res,afmt,ictxt)
if(res/=0)failed=failed+1
if(res.eq.0)passed=passed+1
res=0
call z_ussv_2_c_ap3_bm0_ix1_iy1(res,afmt,ictxt)
if(res/=0)failed=failed+1
if(res.eq.0)passed=passed+1
res=0
call z_ussv_2_n_ap1_bm0_ix1_iy1(res,afmt,ictxt)
if(res/=0)failed=failed+1
if(res.eq.0)passed=passed+1
res=0
call z_ussv_2_t_ap1_bm0_ix1_iy1(res,afmt,ictxt)
if(res/=0)failed=failed+1
if(res.eq.0)passed=passed+1
res=0
call z_ussv_2_c_ap1_bm0_ix1_iy1(res,afmt,ictxt)
if(res/=0)failed=failed+1
if(res.eq.0)passed=passed+1
res=0
call z_ussv_2_n_am1_bm0_ix1_iy1(res,afmt,ictxt)
if(res/=0)failed=failed+1
if(res.eq.0)passed=passed+1
res=0
call z_ussv_2_t_am1_bm0_ix1_iy1(res,afmt,ictxt)
if(res/=0)failed=failed+1
if(res.eq.0)passed=passed+1
res=0
call z_ussv_2_c_am1_bm0_ix1_iy1(res,afmt,ictxt)
if(res/=0)failed=failed+1
if(res.eq.0)passed=passed+1
res=0
call z_ussv_2_n_am3_bm0_ix1_iy1(res,afmt,ictxt)
if(res/=0)failed=failed+1
if(res.eq.0)passed=passed+1
res=0
call z_ussv_2_t_am3_bm0_ix1_iy1(res,afmt,ictxt)
if(res/=0)failed=failed+1
if(res.eq.0)passed=passed+1
res=0
call z_ussv_2_c_am3_bm0_ix1_iy1(res,afmt,ictxt)
if(res/=0)failed=failed+1
if(res.eq.0)passed=passed+1
res=0
9999 continue
print *,"PASSED:",passed
print *,"FAILED:",failed
call psb_exit(ictxt)
end program main

@ -7,10 +7,11 @@ HERE=.
BASEOBJS= psb_blockpart_mod.o psb_metispart_mod.o \ BASEOBJS= psb_blockpart_mod.o psb_metispart_mod.o \
psb_hbio_mod.o psb_mmio_mod.o psb_mat_dist_mod.o psb_hbio_mod.o psb_mmio_mod.o psb_mat_dist_mod.o
MODOBJ=psb_util_mod.o IMPLOBJS= psb_hbio_impl.o psb_mmio_impl.o psb_mat_dist_impl.o
OBJS=$(BASEOBJS) $(MODOBJ) MODOBJS=psb_util_mod.o $(BASEOBJS)
OBJS=$(MODOBJS) $(IMPLOBJS)
LIBMOD=psb_util_mod$(.mod) LIBMOD=psb_util_mod$(.mod)
LOCAL_MODS=$(OBJS:.o=$(.mod)) LOCAL_MODS=$(MODOBJS:.o=$(.mod))
LIBNAME=$(UTILLIBNAME) LIBNAME=$(UTILLIBNAME)
FINCLUDES=$(FMFLAG)$(LIBDIR) $(FMFLAG). FINCLUDES=$(FMFLAG)$(LIBDIR) $(FMFLAG).
@ -23,7 +24,6 @@ lib: $(OBJS)
psb_util_mod.o: $(BASEOBJS) psb_util_mod.o: $(BASEOBJS)
psb_read_mat_mod.o: psb_mmio_mod.o
veryclean: clean veryclean: clean
/bin/rm -f $(HERE)/$(LIBNAME) /bin/rm -f $(HERE)/$(LIBNAME)

File diff suppressed because it is too large Load Diff

File diff suppressed because it is too large Load Diff

File diff suppressed because it is too large Load Diff

File diff suppressed because it is too large Load Diff

File diff suppressed because it is too large Load Diff

File diff suppressed because it is too large Load Diff
Loading…
Cancel
Save