fdurastante/psblas3
1
0
Fork 0
mirror of https://github.com/sfilippone/psblas3.git synced 2026-10-06 22:55:08 +00:00
Code Issues Packages Projects Releases Wiki Activity

psblas3:

Browse Source 
Changelog
 base/modules/Makefile
 base/modules/psb_base_mat_mod.f90
 base/modules/psb_c_base_mat_mod.f90
 base/modules/psb_c_base_vect_mod.f90
 base/modules/psb_c_csc_mat_mod.f90
 base/modules/psb_c_csr_mat_mod.f90
 base/modules/psb_c_mat_mod.f90
 base/modules/psb_c_tools_mod.f90
 base/modules/psb_c_vect_mod.F90
 base/modules/psb_const_mod.F90
 base/modules/psb_d_base_mat_mod.f90
 base/modules/psb_d_base_vect_mod.f90
 base/modules/psb_d_csc_mat_mod.f90
 base/modules/psb_d_csr_mat_mod.f90
 base/modules/psb_d_mat_mod.f90
 base/modules/psb_d_tools_mod.f90
 base/modules/psb_d_vect_mod.F90
 base/modules/psb_i_base_vect_mod.f90
 base/modules/psb_i_vect_mod.F90
 base/modules/psb_realloc_mod.F90
 base/modules/psb_s_base_mat_mod.f90
 base/modules/psb_s_base_vect_mod.f90
 base/modules/psb_s_csc_mat_mod.f90
 base/modules/psb_s_csr_mat_mod.f90
 base/modules/psb_s_mat_mod.f90
 base/modules/psb_s_tools_mod.f90
 base/modules/psb_s_vect_mod.F90
 base/modules/psb_sort_mod.f90
 base/modules/psb_vect_mod.f90
 base/modules/psb_z_base_mat_mod.f90
 base/modules/psb_z_base_vect_mod.f90
 base/modules/psb_z_csc_mat_mod.f90
 base/modules/psb_z_csr_mat_mod.f90
 base/modules/psb_z_mat_mod.f90
 base/modules/psb_z_tools_mod.f90
 base/modules/psb_z_vect_mod.F90
 base/serial/impl/psb_c_base_mat_impl.F90
 base/serial/impl/psb_c_coo_impl.f90
 base/serial/impl/psb_c_csc_impl.f90
 base/serial/impl/psb_c_csr_impl.f90
 base/serial/impl/psb_c_mat_impl.F90
 base/serial/impl/psb_d_base_mat_impl.F90
 base/serial/impl/psb_d_coo_impl.f90
 base/serial/impl/psb_d_csc_impl.f90
 base/serial/impl/psb_d_csr_impl.f90
 base/serial/impl/psb_d_mat_impl.F90
 base/serial/impl/psb_s_base_mat_impl.F90
 base/serial/impl/psb_s_coo_impl.f90
 base/serial/impl/psb_s_csc_impl.f90
 base/serial/impl/psb_s_csr_impl.f90
 base/serial/impl/psb_s_mat_impl.F90
 base/serial/impl/psb_z_base_mat_impl.F90
 base/serial/impl/psb_z_coo_impl.f90
 base/serial/impl/psb_z_csc_impl.f90
 base/serial/impl/psb_z_csr_impl.f90
 base/serial/impl/psb_z_mat_impl.F90
 base/serial/psb_sort_impl.f90
 base/tools/psb_cins.f90
 base/tools/psb_cspasb.f90
 base/tools/psb_cspins.f90
 base/tools/psb_dins.f90
 base/tools/psb_dspasb.f90
 base/tools/psb_dspins.f90
 base/tools/psb_glob_to_loc.f90
 base/tools/psb_sins.f90
 base/tools/psb_sspasb.f90
 base/tools/psb_sspins.f90
 base/tools/psb_zins.f90
 base/tools/psb_zspasb.f90
 base/tools/psb_zspins.f90
 test/pargen/runs/ppde.inp

Merged changes to have uniform handling of host/device memory for both
matrices and vectors.
Introduced multivectors.
CSPUT now accepting vectors as well as arrays. 
Declare version 3.3
This commit is contained in:
Salvatore Filippone
2014-10-15 10:00:27 +00:00
parent 031f93363a d332fb2e99
commit 4eb83389a5
72 changed files with 11460 additions and 252 deletions
Download Patch File Download Diff File Expand all files Collapse all files
Changelog
+17
View File
@@ -1,7 +1,24 @@
Changelog. A lot less detailed than usual, at least for past
history.
2014/10/15: Merged changes into trunk. Declare version 3.3
2014/10/10: Fix recutions when root /= -1
2014/09/10: Use int32/64 kinds & friends from ISO_FORTRAN_ENV
2014/08/30: New multivector types. Vector insertion now takes other
vectors as well as arrays.
2014/07/10: CSPUT has now two specifics, with arrays or vector types.
2014/07/02: Matrices have host/device status.
2014/06/11: Check for bug on multiple generic names.
2014/05/05: Make sure CSPUT ignores (at most a warning) indices not
belonging.
2014/04/14: Sort status in COO. Changes in error handling for CSPUT.
2014/03/31: get_diag, rowsum & friends changed into functions.
base/modules/Makefile
+5 -5
View File
@@ -67,7 +67,7 @@ psb_z_base_mat_mod.o: psb_z_base_vect_mod.o
psb_c_base_vect_mod.o psb_s_base_vect_mod.o psb_d_base_vect_mod.o psb_z_base_vect_mod.o: psb_i_base_vect_mod.o
psb_i_base_vect_mod.o psb_c_base_vect_mod.o psb_s_base_vect_mod.o psb_d_base_vect_mod.o psb_z_base_vect_mod.o: psi_serial_mod.o psb_realloc_mod.o
psb_s_mat_mod.o: psb_s_base_mat_mod.o psb_s_csr_mat_mod.o psb_s_csc_mat_mod.o psb_s_vect_mod.o
psb_d_mat_mod.o: psb_d_base_mat_mod.o psb_d_csr_mat_mod.o psb_d_csc_mat_mod.o psb_d_vect_mod.o
psb_d_mat_mod.o: psb_d_base_mat_mod.o psb_d_csr_mat_mod.o psb_d_csc_mat_mod.o psb_d_vect_mod.o psb_i_vect_mod.o
psb_c_mat_mod.o: psb_c_base_mat_mod.o psb_c_csr_mat_mod.o psb_c_csc_mat_mod.o psb_c_vect_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_vect_mod.o
psb_s_csc_mat_mod.o psb_s_csr_mat_mod.o: psb_s_base_mat_mod.o
@@ -108,10 +108,10 @@ psb_check_mod.o: psb_desc_mod.o
psb_s_serial_mod.o psb_d_serial_mod.o psb_c_serial_mod.o psb_z_serial_mod.o: psb_mat_mod.o psb_string_mod.o psb_sort_mod.o psi_serial_mod.o
psb_serial_mod.o: psb_s_serial_mod.o psb_d_serial_mod.o psb_c_serial_mod.o psb_z_serial_mod.o
psb_i_vect_mod.o: psb_i_base_vect_mod.o
psb_s_vect_mod.o: psb_s_base_vect_mod.o
psb_d_vect_mod.o: psb_d_base_vect_mod.o
psb_c_vect_mod.o: psb_c_base_vect_mod.o
psb_z_vect_mod.o: psb_z_base_vect_mod.o
psb_s_vect_mod.o: psb_s_base_vect_mod.o psb_i_vect_mod.o
psb_d_vect_mod.o: psb_d_base_vect_mod.o psb_i_vect_mod.o
psb_c_vect_mod.o: psb_c_base_vect_mod.o psb_i_vect_mod.o
psb_z_vect_mod.o: psb_z_base_vect_mod.o psb_i_vect_mod.o
psb_tools_mod.o: psb_cd_tools_mod.o psb_s_tools_mod.o psb_d_tools_mod.o\
psb_i_tools_mod.o psb_c_tools_mod.o psb_z_tools_mod.o
psb_cd_tools_mod.o psb_i_tools_mod.o psb_s_tools_mod.o psb_d_tools_mod.o psb_c_tools_mod.o psb_z_tools_mod.o: psb_desc_mod.o psi_mod.o psb_mat_mod.o
base/modules/psb_base_mat_mod.f90
+162
View File
@@ -124,6 +124,8 @@ module psb_base_mat_mod
logical, private :: unitd
!> Are the coefficients sorted ?
logical, private :: sorted
logical, private :: repeatable_updates=.false.
contains
! == = =================================
@@ -140,6 +142,7 @@ module psb_base_mat_mod
procedure, pass(a) :: get_state => psb_base_get_state
procedure, pass(a) :: get_dupl => psb_base_get_dupl
procedure, nopass :: get_fmt => psb_base_get_fmt
procedure, nopass :: has_update => psb_base_has_update
procedure, pass(a) :: is_null => psb_base_is_null
procedure, pass(a) :: is_bld => psb_base_is_bld
procedure, pass(a) :: is_upd => psb_base_is_upd
@@ -151,6 +154,7 @@ module psb_base_mat_mod
procedure, pass(a) :: is_unit => psb_base_is_unit
procedure, pass(a) :: is_by_rows => psb_base_is_by_rows
procedure, pass(a) :: is_by_cols => psb_base_is_by_cols
procedure, pass(a) :: is_repeatable_updates => psb_base_is_repeatable_updates
! == = =================================
!
@@ -171,6 +175,8 @@ module psb_base_mat_mod
procedure, pass(a) :: set_triangle => psb_base_set_triangle
procedure, pass(a) :: set_unit => psb_base_set_unit
procedure, pass(a) :: set_repeatable_updates => psb_base_set_repeatable_updates
! == = =================================
!
@@ -179,12 +185,15 @@ module psb_base_mat_mod
! == = =================================
procedure, pass(a) :: get_neigh => psb_base_get_neigh
procedure, pass(a) :: free => psb_base_free
procedure, pass(a) :: asb => psb_base_mat_asb
procedure, pass(a) :: trim => psb_base_trim
procedure, pass(a) :: reinit => psb_base_reinit
procedure, pass(a) :: allocate_mnnz => psb_base_allocate_mnnz
procedure, pass(a) :: reallocate_nz => psb_base_reallocate_nz
generic, public :: allocate => allocate_mnnz
generic, public :: reallocate => reallocate_nz
procedure, pass(a) :: csgetptn => psb_base_csgetptn
generic, public :: csget => csgetptn
procedure, pass(a) :: print => psb_base_sparse_print
@@ -195,6 +204,19 @@ module psb_base_mat_mod
procedure, pass(a) :: transc_1mat => psb_base_transc_1mat
procedure, pass(a) :: transc_2mat => psb_base_transc_2mat
generic, public :: transc => transc_1mat, transc_2mat
! Sync: centerpiece of handling of external storage.
! Any derived class having extra storage upon sync
! will guarantee that both fortran/host side and
! external side contain the same data. The base
! version is only a placeholder.
!
procedure, pass(a) :: sync => psb_base_mat_sync
procedure, pass(a) :: is_host => psb_base_mat_is_host
procedure, pass(a) :: is_dev => psb_base_mat_is_dev
procedure, pass(a) :: is_sync => psb_base_mat_is_sync
procedure, pass(a) :: set_host => psb_base_mat_set_host
procedure, pass(a) :: set_dev => psb_base_mat_set_dev
procedure, pass(a) :: set_sync => psb_base_mat_set_sync
end type psb_base_sparse_mat
@@ -436,6 +458,16 @@ contains
character(len=5) :: res
res = 'NULL'
end function psb_base_get_fmt
!
!> Function has_update
!! \memberof psb_base_sparse_mat
!! \brief Does the forma have the UPDATE functionality?
!
function psb_base_has_update() result(res)
implicit none
logical :: res
res = .true.
end function psb_base_has_update
!
! Standard getter functions: self-explaining.
@@ -587,6 +619,18 @@ contains
end if
end subroutine psb_base_set_upper
subroutine psb_base_set_repeatable_updates(a,val)
implicit none
class(psb_base_sparse_mat), intent(inout) :: a
logical, intent(in), optional :: val
if (present(val)) then
a%repeatable_updates = val
else
a%repeatable_updates = .true.
end if
end subroutine psb_base_set_repeatable_updates
function psb_base_is_triangle(a) result(res)
implicit none
class(psb_base_sparse_mat), intent(in) :: a
@@ -665,6 +709,13 @@ contains
res = .false.
end function psb_base_is_by_cols
function psb_base_is_repeatable_updates(a) result(res)
implicit none
class(psb_base_sparse_mat), intent(in) :: a
logical :: res
res = a%repeatable_updates
end function psb_base_is_repeatable_updates
!
! TRANSP: note sorted=.false.
@@ -685,6 +736,7 @@ contains
b%unitd = a%unitd
b%upper = .not.a%upper
b%sorted = .false.
b%repeatable_updates = .false.
end subroutine psb_base_transp_2mat
@@ -703,6 +755,7 @@ contains
b%unitd = a%unitd
b%upper = .not.a%upper
b%sorted = .false.
b%repeatable_updates = .false.
end subroutine psb_base_transc_2mat
@@ -721,6 +774,7 @@ contains
a%unitd = a%unitd
a%upper = .not.a%upper
a%sorted = .false.
a%repeatable_updates = .false.
end subroutine psb_base_transp_1mat
@@ -733,5 +787,113 @@ contains
end subroutine psb_base_transc_1mat
!
!> Function base_asb:
!! \memberof psb_base_sparse_mat
!! \brief Sync: base version calls sync and the set_asb.
!!
!
subroutine psb_base_mat_asb(a)
implicit none
class(psb_base_sparse_mat), intent(inout) :: a
call a%sync()
call a%set_asb()
end subroutine psb_base_mat_asb
!
! The base version of SYNC & friends does nothing, it's just
! a placeholder.
!
!
!> Function base_sync:
!! \memberof psb_base_sparse_mat
!! \brief Sync: base version is a no-op.
!!
!
subroutine psb_base_mat_sync(a)
implicit none
class(psb_base_sparse_mat), target, intent(in) :: a
end subroutine psb_base_mat_sync
!
!> Function base_set_host:
!! \memberof psb_base_sparse_mat
!! \brief Set_host: base version is a no-op.
!!
!
subroutine psb_base_mat_set_host(a)
implicit none
class(psb_base_sparse_mat), intent(inout) :: a
end subroutine psb_base_mat_set_host
!
!> Function base_set_dev:
!! \memberof psb_base_sparse_mat
!! \brief Set_dev: base version is a no-op.
!!
!
subroutine psb_base_mat_set_dev(a)
implicit none
class(psb_base_sparse_mat), intent(inout) :: a
end subroutine psb_base_mat_set_dev
!
!> Function base_set_sync:
!! \memberof psb_base_sparse_mat
!! \brief Set_sync: base version is a no-op.
!!
!
subroutine psb_base_mat_set_sync(a)
implicit none
class(psb_base_sparse_mat), intent(inout) :: a
end subroutine psb_base_mat_set_sync
!
!> Function base_is_dev:
!! \memberof psb_base_sparse_mat
!! \brief Is matrix on eaternal device .
!!
!
function psb_base_mat_is_dev(a) result(res)
implicit none
class(psb_base_sparse_mat), intent(in) :: a
logical :: res
res = .false.
end function psb_base_mat_is_dev
!
!> Function base_is_host
!! \memberof psb_base_sparse_mat
!! \brief Is matrix on standard memory .
!!
!
function psb_base_mat_is_host(a) result(res)
implicit none
class(psb_base_sparse_mat), intent(in) :: a
logical :: res
res = .true.
end function psb_base_mat_is_host
!
!> Function base_is_sync
!! \memberof psb_base_sparse_mat
!! \brief Is matrix on sync .
!!
!
function psb_base_mat_is_sync(a) result(res)
implicit none
class(psb_base_sparse_mat), intent(in) :: a
logical :: res
res = .true.
end function psb_base_mat_is_sync
end module psb_base_mat_mod
base/modules/psb_c_base_mat_mod.f90
+25 -6
View File
@@ -57,7 +57,9 @@ module psb_c_base_mat_mod
!
! Data management methods: defined here, but (mostly) not implemented.
!
procedure, pass(a) :: csput => psb_c_base_csput
procedure, pass(a) :: csput_a => psb_c_base_csput_a
procedure, pass(a) :: csput_v => psb_c_base_csput_v
generic, public :: csput => csput_a, csput_v
procedure, pass(a) :: csgetrow => psb_c_base_csgetrow
procedure, pass(a) :: csgetblk => psb_c_base_csgetblk
procedure, pass(a) :: get_diag => psb_c_base_get_diag
@@ -112,6 +114,10 @@ module psb_c_base_mat_mod
procedure, pass(a) :: aclsum => psb_c_base_aclsum
end type psb_c_base_sparse_mat
private :: c_base_mat_sync, c_base_mat_is_host, c_base_mat_is_dev, &
& c_base_mat_is_sync, c_base_mat_set_host, c_base_mat_set_dev,&
& c_base_mat_set_sync
!> \namespace psb_base_mod \class psb_c_coo_sparse_mat
!! \extends psb_c_base_mat_mod::psb_c_base_sparse_mat
!!
@@ -151,7 +157,7 @@ module psb_c_base_mat_mod
procedure, pass(a) :: mv_from_coo => psb_c_mv_coo_from_coo
procedure, pass(a) :: mv_to_fmt => psb_c_mv_coo_to_fmt
procedure, pass(a) :: mv_from_fmt => psb_c_mv_coo_from_fmt
procedure, pass(a) :: csput => psb_c_coo_csput
procedure, pass(a) :: csput_a => psb_c_coo_csput_a
procedure, pass(a) :: get_diag => psb_c_coo_get_diag
procedure, pass(a) :: csgetrow => psb_c_coo_csgetrow
procedure, pass(a) :: csgetptn => psb_c_coo_csgetptn
@@ -250,14 +256,27 @@ module psb_c_base_mat_mod
!!
!
interface
subroutine psb_c_base_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
subroutine psb_c_base_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
import :: psb_ipk_, psb_c_base_sparse_mat, psb_spk_
class(psb_c_base_sparse_mat), intent(inout) :: a
complex(psb_spk_), intent(in) :: val(:)
integer(psb_ipk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: gtl(:)
end subroutine psb_c_base_csput
end subroutine psb_c_base_csput_a
end interface
interface
subroutine psb_c_base_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
import :: psb_ipk_, psb_c_base_sparse_mat, psb_spk_, psb_c_base_vect_type,&
& psb_i_base_vect_type
class(psb_c_base_sparse_mat), intent(inout) :: a
class(psb_c_base_vect_type), intent(inout) :: val
class(psb_i_base_vect_type), intent(inout) :: ia, ja
integer(psb_ipk_), intent(in) :: nz, imin, imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: gtl(:)
end subroutine psb_c_base_csput_v
end interface
!
@@ -1464,7 +1483,7 @@ module psb_c_base_mat_mod
!!
!
interface
subroutine psb_c_coo_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
subroutine psb_c_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
import :: psb_ipk_, psb_c_coo_sparse_mat, psb_spk_
class(psb_c_coo_sparse_mat), intent(inout) :: a
complex(psb_spk_), intent(in) :: val(:)
@@ -1472,7 +1491,7 @@ module psb_c_base_mat_mod
& imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: gtl(:)
end subroutine psb_c_coo_csput
end subroutine psb_c_coo_csput_a
end interface
!>
base/modules/psb_c_base_vect_mod.f90
+1135 -4
View File
File diff suppressed because it is too large Load Diff
base/modules/psb_c_csc_mat_mod.f90
+4 -4
View File
@@ -88,7 +88,7 @@ module psb_c_csc_mat_mod
procedure, pass(a) :: mv_from_coo => psb_c_mv_csc_from_coo
procedure, pass(a) :: mv_to_fmt => psb_c_mv_csc_to_fmt
procedure, pass(a) :: mv_from_fmt => psb_c_mv_csc_from_fmt
procedure, pass(a) :: csput => psb_c_csc_csput
procedure, pass(a) :: csput_a => psb_c_csc_csput_a
procedure, pass(a) :: get_diag => psb_c_csc_get_diag
procedure, pass(a) :: csgetptn => psb_c_csc_csgetptn
procedure, pass(a) :: csgetrow => psb_c_csc_csgetrow
@@ -279,9 +279,9 @@ module psb_c_csc_mat_mod
!> \memberof psb_c_csc_sparse_mat
!! \see psb_c_base_mat_mod::psb_c_base_csput
!! \see psb_c_base_mat_mod::psb_c_base_csput_a
interface
subroutine psb_c_csc_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
subroutine psb_c_csc_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
import :: psb_ipk_, psb_c_csc_sparse_mat, psb_spk_
class(psb_c_csc_sparse_mat), intent(inout) :: a
complex(psb_spk_), intent(in) :: val(:)
@@ -289,7 +289,7 @@ module psb_c_csc_mat_mod
& imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: gtl(:)
end subroutine psb_c_csc_csput
end subroutine psb_c_csc_csput_a
end interface
!> \memberof psb_c_csc_sparse_mat
base/modules/psb_c_csr_mat_mod.f90
+4 -4
View File
@@ -89,7 +89,7 @@ module psb_c_csr_mat_mod
procedure, pass(a) :: mv_from_coo => psb_c_mv_csr_from_coo
procedure, pass(a) :: mv_to_fmt => psb_c_mv_csr_to_fmt
procedure, pass(a) :: mv_from_fmt => psb_c_mv_csr_from_fmt
procedure, pass(a) :: csput => psb_c_csr_csput
procedure, pass(a) :: csput_a => psb_c_csr_csput_a
procedure, pass(a) :: get_diag => psb_c_csr_get_diag
procedure, pass(a) :: csgetptn => psb_c_csr_csgetptn
procedure, pass(a) :: csgetrow => psb_c_csr_csgetrow
@@ -282,9 +282,9 @@ module psb_c_csr_mat_mod
!> \memberof psb_c_csr_sparse_mat
!! \see psb_c_base_mat_mod::psb_c_base_csput
!! \see psb_c_base_mat_mod::psb_c_base_csput_a
interface
subroutine psb_c_csr_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
subroutine psb_c_csr_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
import :: psb_ipk_, psb_c_csr_sparse_mat, psb_spk_
class(psb_c_csr_sparse_mat), intent(inout) :: a
complex(psb_spk_), intent(in) :: val(:)
@@ -292,7 +292,7 @@ module psb_c_csr_mat_mod
& imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: gtl(:)
end subroutine psb_c_csr_csput
end subroutine psb_c_csr_csput_a
end interface
!> \memberof psb_c_csr_sparse_mat
base/modules/psb_c_mat_mod.f90
+56 -3
View File
@@ -98,6 +98,7 @@ module psb_c_mat_mod
procedure, pass(a) :: is_lower => psb_c_is_lower
procedure, pass(a) :: is_triangle => psb_c_is_triangle
procedure, pass(a) :: is_unit => psb_c_is_unit
procedure, pass(a) :: is_repeatable_updates => psb_c_is_repeatable_updates
procedure, pass(a) :: get_fmt => psb_c_get_fmt
procedure, pass(a) :: sizeof => psb_c_sizeof
@@ -114,12 +115,15 @@ module psb_c_mat_mod
procedure, pass(a) :: set_lower => psb_c_set_lower
procedure, pass(a) :: set_triangle => psb_c_set_triangle
procedure, pass(a) :: set_unit => psb_c_set_unit
procedure, pass(a) :: set_repeatable_updates => psb_c_set_repeatable_updates
! Memory/data management
procedure, pass(a) :: csall => psb_c_csall
procedure, pass(a) :: free => psb_c_free
procedure, pass(a) :: trim => psb_c_trim
procedure, pass(a) :: csput => psb_c_csput
procedure, pass(a) :: csput_a => psb_c_csput_a
procedure, pass(a) :: csput_v => psb_c_csput_v
generic, public :: csput => csput_a, csput_v
procedure, pass(a) :: csgetptn => psb_c_csgetptn
procedure, pass(a) :: csgetrow => psb_c_csgetrow
procedure, pass(a) :: csgetblk => psb_c_csgetblk
@@ -136,6 +140,7 @@ module psb_c_mat_mod
procedure, pass(a) :: print_n => psb_c_n_sparse_print
generic, public :: print => print_i, print_n
procedure, pass(a) :: mold => psb_c_mold
procedure, pass(a) :: asb => psb_c_asb
procedure, pass(a) :: transp_1mat => psb_c_transp_1mat
procedure, pass(a) :: transp_2mat => psb_c_transp_2mat
generic, public :: transp => transp_1mat, transp_2mat
@@ -378,16 +383,31 @@ module psb_c_mat_mod
end interface
interface
subroutine psb_c_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
subroutine psb_c_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
import :: psb_ipk_, psb_cspmat_type, psb_spk_
class(psb_cspmat_type), intent(inout) :: a
complex(psb_spk_), intent(in) :: val(:)
integer(psb_ipk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: gtl(:)
end subroutine psb_c_csput
end subroutine psb_c_csput_a
end interface
interface
subroutine psb_c_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
use psb_c_vect_mod, only : psb_c_vect_type
use psb_i_vect_mod, only : psb_i_vect_type
import :: psb_ipk_, psb_cspmat_type
class(psb_cspmat_type), intent(inout) :: a
type(psb_c_vect_type), intent(inout) :: val
type(psb_i_vect_type), intent(inout) :: ia, ja
integer(psb_ipk_), intent(in) :: nz, imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: gtl(:)
end subroutine psb_c_csput_v
end interface
interface
subroutine psb_c_csgetptn(imin,imax,a,nz,ia,ja,info,&
& jmin,jmax,iren,append,nzin,rscale,cscale)
@@ -493,6 +513,14 @@ module psb_c_mat_mod
end subroutine psb_c_mold
end interface
interface
subroutine psb_c_asb(a,mold)
import :: psb_ipk_, psb_cspmat_type, psb_c_base_sparse_mat
class(psb_cspmat_type), intent(inout) :: a
class(psb_c_base_sparse_mat), optional, intent(in) :: mold
end subroutine psb_c_asb
end interface
interface
subroutine psb_c_transp_1mat(a)
import :: psb_ipk_, psb_cspmat_type
@@ -1085,6 +1113,31 @@ contains
function psb_c_is_repeatable_updates(a) result(res)
implicit none
class(psb_cspmat_type), intent(in) :: a
logical :: res
if (allocated(a%a)) then
res = a%a%is_repeatable_updates()
else
res = .false.
end if
end function psb_c_is_repeatable_updates
subroutine psb_c_set_repeatable_updates(a,val)
implicit none
class(psb_cspmat_type), intent(inout) :: a
logical, intent(in), optional :: val
if (allocated(a%a)) then
call a%a%set_repeatable_updates(val)
end if
end subroutine psb_c_set_repeatable_updates
function psb_c_get_nzeros(a) result(res)
implicit none
class(psb_cspmat_type), intent(in) :: a
base/modules/psb_c_tools_mod.f90
+28 -1
View File
@@ -31,7 +31,7 @@
!!$
Module psb_c_tools_mod
use psb_desc_mod, only : psb_desc_type, psb_spk_, psb_ipk_
use psb_c_vect_mod, only : psb_c_base_vect_type, psb_c_vect_type
use psb_c_vect_mod, only : psb_c_base_vect_type, psb_c_vect_type, psb_i_vect_type
use psb_c_mat_mod, only : psb_cspmat_type, psb_c_base_sparse_mat
interface psb_geall
@@ -206,6 +206,19 @@ Module psb_c_tools_mod
integer(psb_ipk_), optional, intent(in) :: dupl
logical, intent(in), optional :: local
end subroutine psb_cins_vect
subroutine psb_cins_vect_v(m,irw,val,x,desc_a,info,dupl,local)
import :: psb_desc_type, psb_spk_, psb_ipk_, &
& psb_c_base_vect_type, psb_c_vect_type, psb_i_vect_type, &
& psb_cspmat_type, psb_c_base_sparse_mat
integer(psb_ipk_), intent(in) :: m
type(psb_desc_type), intent(in) :: desc_a
type(psb_c_vect_type), intent(inout) :: x
type(psb_i_vect_type), intent(inout) :: irw
type(psb_c_vect_type), intent(inout) :: val
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: dupl
logical, intent(in), optional :: local
end subroutine psb_cins_vect_v
subroutine psb_cins_vect_r2(m,irw,val,x,desc_a,info,dupl,local)
import :: psb_desc_type, psb_spk_, psb_ipk_, &
& psb_c_base_vect_type, psb_c_vect_type, &
@@ -286,6 +299,20 @@ Module psb_c_tools_mod
logical, intent(in), optional :: rebuild
logical, intent(in), optional :: local
end subroutine psb_cspins
subroutine psb_cspins_v(nz,ia,ja,val,a,desc_a,info,rebuild,local)
use psb_i_vect_mod, only : psb_i_vect_type
import :: psb_desc_type, psb_spk_, psb_ipk_, &
& psb_c_base_vect_type, psb_c_vect_type,&
& psb_cspmat_type, psb_c_base_sparse_mat
type(psb_desc_type), intent(inout) :: desc_a
type(psb_cspmat_type), intent(inout) :: a
integer(psb_ipk_), intent(in) :: nz
type(psb_i_vect_type), intent(inout) :: ia,ja
type(psb_c_vect_type), intent(inout) :: val
integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: rebuild
logical, intent(in), optional :: local
end subroutine psb_cspins_v
subroutine psb_cspins_2desc(nz,ia,ja,val,a,desc_ar,desc_ac,info)
import :: psb_desc_type, psb_spk_, psb_ipk_, &
& psb_c_base_vect_type, psb_c_vect_type, &
base/modules/psb_c_vect_mod.F90
+660 -3
View File
@@ -40,6 +40,7 @@
module psb_c_vect_mod
use psb_c_base_vect_mod
use psb_i_vect_mod
type psb_c_vect_type
class(psb_c_base_vect_type), allocatable :: v
@@ -76,7 +77,9 @@ module psb_c_vect_mod
procedure, pass(y) :: sctb => c_vect_sctb
generic, public :: sct => sctb
procedure, pass(x) :: free => c_vect_free
procedure, pass(x) :: ins => c_vect_ins
procedure, pass(x) :: ins_a => c_vect_ins_a
procedure, pass(x) :: ins_v => c_vect_ins_v
generic, public :: ins => ins_v, ins_a
procedure, pass(x) :: bld_x => c_vect_bld_x
procedure, pass(x) :: bld_n => c_vect_bld_n
generic, public :: bld => bld_x, bld_n
@@ -619,7 +622,7 @@ contains
end subroutine c_vect_free
subroutine c_vect_ins(n,irl,val,dupl,x,info)
subroutine c_vect_ins_a(n,irl,val,dupl,x,info)
use psi_serial_mod
implicit none
class(psb_c_vect_type), intent(inout) :: x
@@ -638,7 +641,28 @@ contains
call x%v%ins(n,irl,val,dupl,info)
end subroutine c_vect_ins
end subroutine c_vect_ins_a
subroutine c_vect_ins_v(n,irl,val,dupl,x,info)
use psi_serial_mod
implicit none
class(psb_c_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n, dupl
class(psb_i_vect_type), intent(inout) :: irl
class(psb_c_vect_type), intent(inout) :: val
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: i
info = 0
if (.not.(allocated(x%v).and.allocated(irl%v).and.allocated(val%v))) then
info = psb_err_invalid_vect_state_
return
end if
call x%v%ins(n,irl%v,val%v,dupl,info)
end subroutine c_vect_ins_v
subroutine c_vect_cnv(x,mold)
@@ -663,3 +687,636 @@ contains
end subroutine c_vect_cnv
end module psb_c_vect_mod
module psb_c_multivect_mod
use psb_c_base_multivect_mod
use psb_const_mod
!private
type psb_c_multivect_type
class(psb_c_base_multivect_type), allocatable :: v
contains
procedure, pass(x) :: get_nrows => c_vect_get_nrows
procedure, pass(x) :: get_ncols => c_vect_get_ncols
procedure, pass(x) :: sizeof => c_vect_sizeof
procedure, pass(x) :: get_fmt => c_vect_get_fmt
!!$ procedure, pass(x) :: dot_v => c_vect_dot_v
!!$ procedure, pass(x) :: dot_a => c_vect_dot_a
!!$ generic, public :: dot => dot_v, dot_a
!!$ procedure, pass(y) :: axpby_v => c_vect_axpby_v
!!$ procedure, pass(y) :: axpby_a => c_vect_axpby_a
!!$ generic, public :: axpby => axpby_v, axpby_a
!!$ procedure, pass(y) :: mlt_v => c_vect_mlt_v
!!$ procedure, pass(y) :: mlt_a => c_vect_mlt_a
!!$ procedure, pass(z) :: mlt_a_2 => c_vect_mlt_a_2
!!$ procedure, pass(z) :: mlt_v_2 => c_vect_mlt_v_2
!!$ procedure, pass(z) :: mlt_va => c_vect_mlt_va
!!$ procedure, pass(z) :: mlt_av => c_vect_mlt_av
!!$ generic, public :: mlt => mlt_v, mlt_a, mlt_a_2,&
!!$ & mlt_v_2, mlt_av, mlt_va
!!$ procedure, pass(x) :: scal => c_vect_scal
!!$ procedure, pass(x) :: nrm2 => c_vect_nrm2
!!$ procedure, pass(x) :: amax => c_vect_amax
!!$ procedure, pass(x) :: asum => c_vect_asum
procedure, pass(x) :: all => c_vect_all
procedure, pass(x) :: reall => c_vect_reall
procedure, pass(x) :: zero => c_vect_zero
procedure, pass(x) :: asb => c_vect_asb
procedure, pass(x) :: sync => c_vect_sync
!!$ procedure, pass(x) :: gthab => c_vect_gthab
!!$ procedure, pass(x) :: gthzv => c_vect_gthzv
!!$ generic, public :: gth => gthab, gthzv
!!$ procedure, pass(y) :: sctb => c_vect_sctb
!!$ generic, public :: sct => sctb
procedure, pass(x) :: free => c_vect_free
procedure, pass(x) :: ins => c_vect_ins
procedure, pass(x) :: bld_x => c_vect_bld_x
procedure, pass(x) :: bld_n => c_vect_bld_n
generic, public :: bld => bld_x, bld_n
procedure, pass(x) :: get_vect => c_vect_get_vect
procedure, pass(x) :: cnv => c_vect_cnv
procedure, pass(x) :: set_scal => c_vect_set_scal
procedure, pass(x) :: set_vect => c_vect_set_vect
generic, public :: set => set_vect, set_scal
procedure, pass(x) :: clone => c_vect_clone
end type psb_c_multivect_type
public :: psb_c_multivect, psb_c_multivect_type,&
& psb_set_multivect_default, psb_get_multivect_default
private
interface psb_c_multivect
module procedure constructor, size_const
end interface
class(psb_c_base_multivect_type), allocatable, target,&
& save, private :: psb_c_base_multivect_default
interface psb_set_multivect_default
module procedure psb_c_set_multivect_default
end interface
interface psb_get_vect_default
module procedure psb_c_get_multivect_default
end interface
contains
subroutine psb_c_set_multivect_default(v)
implicit none
class(psb_c_base_multivect_type), intent(in) :: v
if (allocated(psb_c_base_multivect_default)) then
deallocate(psb_c_base_multivect_default)
end if
allocate(psb_c_base_multivect_default, mold=v)
end subroutine psb_c_set_multivect_default
function psb_c_get_multivect_default(v) result(res)
implicit none
class(psb_c_multivect_type), intent(in) :: v
class(psb_c_base_multivect_type), pointer :: res
res => psb_c_get_base_multivect_default()
end function psb_c_get_multivect_default
function psb_c_get_base_multivect_default() result(res)
implicit none
class(psb_c_base_multivect_type), pointer :: res
if (.not.allocated(psb_c_base_multivect_default)) then
allocate(psb_c_base_multivect_type :: psb_c_base_multivect_default)
end if
res => psb_c_base_multivect_default
end function psb_c_get_base_multivect_default
subroutine c_vect_clone(x,y,info)
implicit none
class(psb_c_multivect_type), intent(inout) :: x
class(psb_c_multivect_type), intent(inout) :: y
integer(psb_ipk_), intent(out) :: info
info = psb_success_
call y%free(info)
if ((info==0).and.allocated(x%v)) then
call y%bld(x%get_vect(),mold=x%v)
end if
end subroutine c_vect_clone
subroutine c_vect_bld_x(x,invect,mold)
complex(psb_spk_), intent(in) :: invect(:,:)
class(psb_c_multivect_type), intent(out) :: x
class(psb_c_base_multivect_type), intent(in), optional :: mold
integer(psb_ipk_) :: info
class(psb_c_base_multivect_type), pointer :: mld
if (present(mold)) then
#ifdef HAVE_MOLD
allocate(x%v,stat=info,mold=mold)
#else
call mold%mold(x%v,info)
#endif
else
#ifdef HAVE_MOLD
allocate(x%v,stat=info, mold=psb_c_get_base_multivect_default())
#else
mld = psb_c_get_base_multivect_default()
call mld%mold(x%v,info)
#endif
endif
if (info == psb_success_) call x%v%bld(invect)
end subroutine c_vect_bld_x
subroutine c_vect_bld_n(x,m,n,mold)
integer(psb_ipk_), intent(in) :: m,n
class(psb_c_multivect_type), intent(out) :: x
class(psb_c_base_multivect_type), intent(in), optional :: mold
integer(psb_ipk_) :: info
class(psb_c_base_multivect_type), pointer :: mld
if (present(mold)) then
#ifdef HAVE_MOLD
allocate(x%v,stat=info,mold=mold)
#else
call mold%mold(x%v,info)
#endif
else
#ifdef HAVE_MOLD
allocate(x%v,stat=info, mold=psb_c_get_base_multivect_default())
#else
mld = psb_c_get_base_multivect_default()
call mld%mold(x%v,info)
#endif
endif
if (info == psb_success_) call x%v%bld(m,n)
end subroutine c_vect_bld_n
function c_vect_get_vect(x) result(res)
class(psb_c_multivect_type), intent(inout) :: x
complex(psb_spk_), allocatable :: res(:,:)
integer(psb_ipk_) :: info
if (allocated(x%v)) then
res = x%v%get_vect()
end if
end function c_vect_get_vect
subroutine c_vect_set_scal(x,val)
class(psb_c_multivect_type), intent(inout) :: x
complex(psb_spk_), intent(in) :: val
integer(psb_ipk_) :: info
if (allocated(x%v)) call x%v%set(val)
end subroutine c_vect_set_scal
subroutine c_vect_set_vect(x,val)
class(psb_c_multivect_type), intent(inout) :: x
complex(psb_spk_), intent(in) :: val(:,:)
integer(psb_ipk_) :: info
if (allocated(x%v)) call x%v%set(val)
end subroutine c_vect_set_vect
function constructor(x) result(this)
complex(psb_spk_) :: x(:,:)
type(psb_c_multivect_type) :: this
integer(psb_ipk_) :: info
call this%bld(x)
call this%asb(size(x,dim=1,kind=psb_ipk_),size(x,dim=2,kind=psb_ipk_),info)
end function constructor
function size_const(m,n) result(this)
integer(psb_ipk_), intent(in) :: m,n
type(psb_c_multivect_type) :: this
integer(psb_ipk_) :: info
call this%bld(m,n)
call this%asb(m,n,info)
end function size_const
function c_vect_get_nrows(x) result(res)
implicit none
class(psb_c_multivect_type), intent(in) :: x
integer(psb_ipk_) :: res
res = 0
if (allocated(x%v)) res = x%v%get_nrows()
end function c_vect_get_nrows
function c_vect_get_ncols(x) result(res)
implicit none
class(psb_c_multivect_type), intent(in) :: x
integer(psb_ipk_) :: res
res = 0
if (allocated(x%v)) res = x%v%get_ncols()
end function c_vect_get_ncols
function c_vect_sizeof(x) result(res)
implicit none
class(psb_c_multivect_type), intent(in) :: x
integer(psb_long_int_k_) :: res
res = 0
if (allocated(x%v)) res = x%v%sizeof()
end function c_vect_sizeof
function c_vect_get_fmt(x) result(res)
implicit none
class(psb_c_multivect_type), intent(in) :: x
character(len=5) :: res
res = 'NULL'
if (allocated(x%v)) res = x%v%get_fmt()
end function c_vect_get_fmt
!!$ function c_vect_dot_v(n,x,y) result(res)
!!$ implicit none
!!$ class(psb_c_multivect_type), intent(inout) :: x, y
!!$ integer(psb_ipk_), intent(in) :: n
!!$ complex(psb_spk_) :: res
!!$
!!$ res = czero
!!$ if (allocated(x%v).and.allocated(y%v)) &
!!$ & res = x%v%dot(n,y%v)
!!$
!!$ end function c_vect_dot_v
!!$
!!$ function c_vect_dot_a(n,x,y) result(res)
!!$ implicit none
!!$ class(psb_c_multivect_type), intent(inout) :: x
!!$ complex(psb_spk_), intent(in) :: y(:)
!!$ integer(psb_ipk_), intent(in) :: n
!!$ complex(psb_spk_) :: res
!!$
!!$ res = czero
!!$ if (allocated(x%v)) &
!!$ & res = x%v%dot(n,y)
!!$
!!$ end function c_vect_dot_a
!!$
!!$ subroutine c_vect_axpby_v(m,alpha, x, beta, y, info)
!!$ use psi_serial_mod
!!$ implicit none
!!$ integer(psb_ipk_), intent(in) :: m
!!$ class(psb_c_multivect_type), intent(inout) :: x
!!$ class(psb_c_multivect_type), intent(inout) :: y
!!$ complex(psb_spk_), intent (in) :: alpha, beta
!!$ integer(psb_ipk_), intent(out) :: info
!!$
!!$ if (allocated(x%v).and.allocated(y%v)) then
!!$ call y%v%axpby(m,alpha,x%v,beta,info)
!!$ else
!!$ info = psb_err_invalid_vect_state_
!!$ end if
!!$
!!$ end subroutine c_vect_axpby_v
!!$
!!$ subroutine c_vect_axpby_a(m,alpha, x, beta, y, info)
!!$ use psi_serial_mod
!!$ implicit none
!!$ integer(psb_ipk_), intent(in) :: m
!!$ complex(psb_spk_), intent(in) :: x(:)
!!$ class(psb_c_multivect_type), intent(inout) :: y
!!$ complex(psb_spk_), intent (in) :: alpha, beta
!!$ integer(psb_ipk_), intent(out) :: info
!!$
!!$ if (allocated(y%v)) &
!!$ & call y%v%axpby(m,alpha,x,beta,info)
!!$
!!$ end subroutine c_vect_axpby_a
!!$
!!$
!!$ subroutine c_vect_mlt_v(x, y, info)
!!$ use psi_serial_mod
!!$ implicit none
!!$ class(psb_c_multivect_type), intent(inout) :: x
!!$ class(psb_c_multivect_type), intent(inout) :: y
!!$ integer(psb_ipk_), intent(out) :: info
!!$ integer(psb_ipk_) :: i, n
!!$
!!$ info = 0
!!$ if (allocated(x%v).and.allocated(y%v)) &
!!$ & call y%v%mlt(x%v,info)
!!$
!!$ end subroutine c_vect_mlt_v
!!$
!!$ subroutine c_vect_mlt_a(x, y, info)
!!$ use psi_serial_mod
!!$ implicit none
!!$ complex(psb_spk_), intent(in) :: x(:)
!!$ class(psb_c_multivect_type), intent(inout) :: y
!!$ integer(psb_ipk_), intent(out) :: info
!!$ integer(psb_ipk_) :: i, n
!!$
!!$
!!$ info = 0
!!$ if (allocated(y%v)) &
!!$ & call y%v%mlt(x,info)
!!$
!!$ end subroutine c_vect_mlt_a
!!$
!!$
!!$ subroutine c_vect_mlt_a_2(alpha,x,y,beta,z,info)
!!$ use psi_serial_mod
!!$ implicit none
!!$ complex(psb_spk_), intent(in) :: alpha,beta
!!$ complex(psb_spk_), intent(in) :: y(:)
!!$ complex(psb_spk_), intent(in) :: x(:)
!!$ class(psb_c_multivect_type), intent(inout) :: z
!!$ integer(psb_ipk_), intent(out) :: info
!!$ integer(psb_ipk_) :: i, n
!!$
!!$ info = 0
!!$ if (allocated(z%v)) &
!!$ & call z%v%mlt(alpha,x,y,beta,info)
!!$
!!$ end subroutine c_vect_mlt_a_2
!!$
!!$ subroutine c_vect_mlt_v_2(alpha,x,y,beta,z,info,conjgx,conjgy)
!!$ use psi_serial_mod
!!$ implicit none
!!$ complex(psb_spk_), intent(in) :: alpha,beta
!!$ class(psb_c_multivect_type), intent(inout) :: x
!!$ class(psb_c_multivect_type), intent(inout) :: y
!!$ class(psb_c_multivect_type), intent(inout) :: z
!!$ integer(psb_ipk_), intent(out) :: info
!!$ character(len=1), intent(in), optional :: conjgx, conjgy
!!$
!!$ integer(psb_ipk_) :: i, n
!!$
!!$ info = 0
!!$ if (allocated(x%v).and.allocated(y%v).and.&
!!$ & allocated(z%v)) &
!!$ & call z%v%mlt(alpha,x%v,y%v,beta,info,conjgx,conjgy)
!!$
!!$ end subroutine c_vect_mlt_v_2
!!$
!!$ subroutine c_vect_mlt_av(alpha,x,y,beta,z,info)
!!$ use psi_serial_mod
!!$ implicit none
!!$ complex(psb_spk_), intent(in) :: alpha,beta
!!$ complex(psb_spk_), intent(in) :: x(:)
!!$ class(psb_c_multivect_type), intent(inout) :: y
!!$ class(psb_c_multivect_type), intent(inout) :: z
!!$ integer(psb_ipk_), intent(out) :: info
!!$ integer(psb_ipk_) :: i, n
!!$
!!$ info = 0
!!$ if (allocated(z%v).and.allocated(y%v)) &
!!$ & call z%v%mlt(alpha,x,y%v,beta,info)
!!$
!!$ end subroutine c_vect_mlt_av
!!$
!!$ subroutine c_vect_mlt_va(alpha,x,y,beta,z,info)
!!$ use psi_serial_mod
!!$ implicit none
!!$ complex(psb_spk_), intent(in) :: alpha,beta
!!$ complex(psb_spk_), intent(in) :: y(:)
!!$ class(psb_c_multivect_type), intent(inout) :: x
!!$ class(psb_c_multivect_type), intent(inout) :: z
!!$ integer(psb_ipk_), intent(out) :: info
!!$ integer(psb_ipk_) :: i, n
!!$
!!$ info = 0
!!$
!!$ if (allocated(z%v).and.allocated(x%v)) &
!!$ & call z%v%mlt(alpha,x%v,y,beta,info)
!!$
!!$ end subroutine c_vect_mlt_va
!!$
!!$ subroutine c_vect_scal(alpha, x)
!!$ use psi_serial_mod
!!$ implicit none
!!$ class(psb_c_multivect_type), intent(inout) :: x
!!$ complex(psb_spk_), intent (in) :: alpha
!!$
!!$ if (allocated(x%v)) call x%v%scal(alpha)
!!$
!!$ end subroutine c_vect_scal
!!$
!!$
!!$ function c_vect_nrm2(n,x) result(res)
!!$ implicit none
!!$ class(psb_c_multivect_type), intent(inout) :: x
!!$ integer(psb_ipk_), intent(in) :: n
!!$ real(psb_spk_) :: res
!!$
!!$ if (allocated(x%v)) then
!!$ res = x%v%nrm2(n)
!!$ else
!!$ res = szero
!!$ end if
!!$
!!$ end function c_vect_nrm2
!!$
!!$ function c_vect_amax(n,x) result(res)
!!$ implicit none
!!$ class(psb_c_multivect_type), intent(inout) :: x
!!$ integer(psb_ipk_), intent(in) :: n
!!$ real(psb_spk_) :: res
!!$
!!$ if (allocated(x%v)) then
!!$ res = x%v%amax(n)
!!$ else
!!$ res = szero
!!$ end if
!!$
!!$ end function c_vect_amax
!!$
!!$ function c_vect_asum(n,x) result(res)
!!$ implicit none
!!$ class(psb_c_multivect_type), intent(inout) :: x
!!$ integer(psb_ipk_), intent(in) :: n
!!$ real(psb_spk_) :: res
!!$
!!$ if (allocated(x%v)) then
!!$ res = x%v%asum(n)
!!$ else
!!$ res = szero
!!$ end if
!!$
!!$ end function c_vect_asum
subroutine c_vect_all(m,n, x, info, mold)
implicit none
integer(psb_ipk_), intent(in) :: m,n
class(psb_c_multivect_type), intent(out) :: x
class(psb_c_base_multivect_type), intent(in), optional :: mold
integer(psb_ipk_), intent(out) :: info
if (present(mold)) then
#ifdef HAVE_MOLD
allocate(x%v,stat=info,mold=mold)
#else
call mold%mold(x%v,info)
#endif
else
allocate(psb_c_base_multivect_type :: x%v,stat=info)
endif
if (info == 0) then
call x%v%all(m,n,info)
else
info = psb_err_alloc_dealloc_
end if
end subroutine c_vect_all
subroutine c_vect_reall(m,n, x, info)
implicit none
integer(psb_ipk_), intent(in) :: m,n
class(psb_c_multivect_type), intent(inout) :: x
integer(psb_ipk_), intent(out) :: info
info = 0
if (.not.allocated(x%v)) &
& call x%all(m,n,info)
if (info == 0) &
& call x%asb(m,n,info)
end subroutine c_vect_reall
subroutine c_vect_zero(x)
use psi_serial_mod
implicit none
class(psb_c_multivect_type), intent(inout) :: x
if (allocated(x%v)) call x%v%zero()
end subroutine c_vect_zero
subroutine c_vect_asb(m,n, x, info)
use psi_serial_mod
use psb_realloc_mod
implicit none
integer(psb_ipk_), intent(in) :: m,n
class(psb_c_multivect_type), intent(inout) :: x
integer(psb_ipk_), intent(out) :: info
if (allocated(x%v)) &
& call x%v%asb(m,n,info)
end subroutine c_vect_asb
subroutine c_vect_sync(x)
implicit none
class(psb_c_multivect_type), intent(inout) :: x
if (allocated(x%v)) &
& call x%v%sync()
end subroutine c_vect_sync
!!$ subroutine c_vect_gthab(n,idx,alpha,x,beta,y)
!!$ use psi_serial_mod
!!$ integer(psb_ipk_) :: n, idx(:)
!!$ complex(psb_spk_) :: alpha, beta, y(:)
!!$ class(psb_c_multivect_type) :: x
!!$
!!$ if (allocated(x%v)) &
!!$ & call x%v%gth(n,idx,alpha,beta,y)
!!$
!!$ end subroutine c_vect_gthab
!!$
!!$ subroutine c_vect_gthzv(n,idx,x,y)
!!$ use psi_serial_mod
!!$ integer(psb_ipk_) :: n, idx(:)
!!$ complex(psb_spk_) :: y(:)
!!$ class(psb_c_multivect_type) :: x
!!$
!!$ if (allocated(x%v)) &
!!$ & call x%v%gth(n,idx,y)
!!$
!!$ end subroutine c_vect_gthzv
!!$
!!$ subroutine c_vect_sctb(n,idx,x,beta,y)
!!$ use psi_serial_mod
!!$ integer(psb_ipk_) :: n, idx(:)
!!$ complex(psb_spk_) :: beta, x(:)
!!$ class(psb_c_multivect_type) :: y
!!$
!!$ if (allocated(y%v)) &
!!$ & call y%v%sct(n,idx,x,beta)
!!$
!!$ end subroutine c_vect_sctb
subroutine c_vect_free(x, info)
use psi_serial_mod
use psb_realloc_mod
implicit none
class(psb_c_multivect_type), intent(inout) :: x
integer(psb_ipk_), intent(out) :: info
info = 0
if (allocated(x%v)) then
call x%v%free(info)
if (info == 0) deallocate(x%v,stat=info)
end if
end subroutine c_vect_free
subroutine c_vect_ins(n,irl,val,dupl,x,info)
use psi_serial_mod
implicit none
class(psb_c_multivect_type), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n, dupl
integer(psb_ipk_), intent(in) :: irl(:)
complex(psb_spk_), intent(in) :: val(:,:)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: i
info = 0
if (.not.allocated(x%v)) then
info = psb_err_invalid_vect_state_
return
end if
call x%v%ins(n,irl,val,dupl,info)
end subroutine c_vect_ins
subroutine c_vect_cnv(x,mold)
class(psb_c_multivect_type), intent(inout) :: x
class(psb_c_base_multivect_type), intent(in), optional :: mold
class(psb_c_base_multivect_type), allocatable :: tmp
integer(psb_ipk_) :: info
if (present(mold)) then
#ifdef HAVE_MOLD
allocate(tmp,stat=info,mold=mold)
#else
call mold%mold(tmp,info)
#endif
if (allocated(x%v)) then
call x%v%sync()
if (info == psb_success_) call tmp%bld(x%v%v)
call x%v%free(info)
end if
call move_alloc(tmp,x%v)
end if
end subroutine c_vect_cnv
end module psb_c_multivect_mod
base/modules/psb_const_mod.F90
+3 -3
View File
@@ -1,5 +1,5 @@
!!$
!!$ Parallel Sparse BLAS version 3.1
!!$ Parallel Sparse BLAS version 3.3
!!$ (C) Copyright 2006, 2007, 2008, 2009, 2010, 2012, 2013
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
@@ -89,9 +89,9 @@ module psb_const_mod
!
! Version
!
character(len=*), parameter :: psb_version_string_ = "3.2.0"
character(len=*), parameter :: psb_version_string_ = "3.3.0"
integer(psb_ipk_), parameter :: psb_version_major_ = 3
integer(psb_ipk_), parameter :: psb_version_minor_ = 2
integer(psb_ipk_), parameter :: psb_version_minor_ = 3
integer(psb_ipk_), parameter :: psb_patchlevel_ = 0
!
base/modules/psb_d_base_mat_mod.f90
+25 -6
View File
@@ -57,7 +57,9 @@ module psb_d_base_mat_mod
!
! Data management methods: defined here, but (mostly) not implemented.
!
procedure, pass(a) :: csput => psb_d_base_csput
procedure, pass(a) :: csput_a => psb_d_base_csput_a
procedure, pass(a) :: csput_v => psb_d_base_csput_v
generic, public :: csput => csput_a, csput_v
procedure, pass(a) :: csgetrow => psb_d_base_csgetrow
procedure, pass(a) :: csgetblk => psb_d_base_csgetblk
procedure, pass(a) :: get_diag => psb_d_base_get_diag
@@ -112,6 +114,10 @@ module psb_d_base_mat_mod
procedure, pass(a) :: aclsum => psb_d_base_aclsum
end type psb_d_base_sparse_mat
private :: d_base_mat_sync, d_base_mat_is_host, d_base_mat_is_dev, &
& d_base_mat_is_sync, d_base_mat_set_host, d_base_mat_set_dev,&
& d_base_mat_set_sync
!> \namespace psb_base_mod \class psb_d_coo_sparse_mat
!! \extends psb_d_base_mat_mod::psb_d_base_sparse_mat
!!
@@ -151,7 +157,7 @@ module psb_d_base_mat_mod
procedure, pass(a) :: mv_from_coo => psb_d_mv_coo_from_coo
procedure, pass(a) :: mv_to_fmt => psb_d_mv_coo_to_fmt
procedure, pass(a) :: mv_from_fmt => psb_d_mv_coo_from_fmt
procedure, pass(a) :: csput => psb_d_coo_csput
procedure, pass(a) :: csput_a => psb_d_coo_csput_a
procedure, pass(a) :: get_diag => psb_d_coo_get_diag
procedure, pass(a) :: csgetrow => psb_d_coo_csgetrow
procedure, pass(a) :: csgetptn => psb_d_coo_csgetptn
@@ -250,14 +256,27 @@ module psb_d_base_mat_mod
!!
!
interface
subroutine psb_d_base_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
subroutine psb_d_base_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
import :: psb_ipk_, psb_d_base_sparse_mat, psb_dpk_
class(psb_d_base_sparse_mat), intent(inout) :: a
real(psb_dpk_), intent(in) :: val(:)
integer(psb_ipk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: gtl(:)
end subroutine psb_d_base_csput
end subroutine psb_d_base_csput_a
end interface
interface
subroutine psb_d_base_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
import :: psb_ipk_, psb_d_base_sparse_mat, psb_dpk_, psb_d_base_vect_type,&
& psb_i_base_vect_type
class(psb_d_base_sparse_mat), intent(inout) :: a
class(psb_d_base_vect_type), intent(inout) :: val
class(psb_i_base_vect_type), intent(inout) :: ia, ja
integer(psb_ipk_), intent(in) :: nz, imin, imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: gtl(:)
end subroutine psb_d_base_csput_v
end interface
!
@@ -1464,7 +1483,7 @@ module psb_d_base_mat_mod
!!
!
interface
subroutine psb_d_coo_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
subroutine psb_d_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
import :: psb_ipk_, psb_d_coo_sparse_mat, psb_dpk_
class(psb_d_coo_sparse_mat), intent(inout) :: a
real(psb_dpk_), intent(in) :: val(:)
@@ -1472,7 +1491,7 @@ module psb_d_base_mat_mod
& imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: gtl(:)
end subroutine psb_d_coo_csput
end subroutine psb_d_coo_csput_a
end interface
!>
base/modules/psb_d_base_vect_mod.f90
+1134 -4
View File
File diff suppressed because it is too large Load Diff
base/modules/psb_d_csc_mat_mod.f90
+4 -4
View File
@@ -88,7 +88,7 @@ module psb_d_csc_mat_mod
procedure, pass(a) :: mv_from_coo => psb_d_mv_csc_from_coo
procedure, pass(a) :: mv_to_fmt => psb_d_mv_csc_to_fmt
procedure, pass(a) :: mv_from_fmt => psb_d_mv_csc_from_fmt
procedure, pass(a) :: csput => psb_d_csc_csput
procedure, pass(a) :: csput_a => psb_d_csc_csput_a
procedure, pass(a) :: get_diag => psb_d_csc_get_diag
procedure, pass(a) :: csgetptn => psb_d_csc_csgetptn
procedure, pass(a) :: csgetrow => psb_d_csc_csgetrow
@@ -279,9 +279,9 @@ module psb_d_csc_mat_mod
!> \memberof psb_d_csc_sparse_mat
!! \see psb_d_base_mat_mod::psb_d_base_csput
!! \see psb_d_base_mat_mod::psb_d_base_csput_a
interface
subroutine psb_d_csc_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
subroutine psb_d_csc_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
import :: psb_ipk_, psb_d_csc_sparse_mat, psb_dpk_
class(psb_d_csc_sparse_mat), intent(inout) :: a
real(psb_dpk_), intent(in) :: val(:)
@@ -289,7 +289,7 @@ module psb_d_csc_mat_mod
& imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: gtl(:)
end subroutine psb_d_csc_csput
end subroutine psb_d_csc_csput_a
end interface
!> \memberof psb_d_csc_sparse_mat
base/modules/psb_d_csr_mat_mod.f90
+4 -4
View File
@@ -89,7 +89,7 @@ module psb_d_csr_mat_mod
procedure, pass(a) :: mv_from_coo => psb_d_mv_csr_from_coo
procedure, pass(a) :: mv_to_fmt => psb_d_mv_csr_to_fmt
procedure, pass(a) :: mv_from_fmt => psb_d_mv_csr_from_fmt
procedure, pass(a) :: csput => psb_d_csr_csput
procedure, pass(a) :: csput_a => psb_d_csr_csput_a
procedure, pass(a) :: get_diag => psb_d_csr_get_diag
procedure, pass(a) :: csgetptn => psb_d_csr_csgetptn
procedure, pass(a) :: csgetrow => psb_d_csr_csgetrow
@@ -282,9 +282,9 @@ module psb_d_csr_mat_mod
!> \memberof psb_d_csr_sparse_mat
!! \see psb_d_base_mat_mod::psb_d_base_csput
!! \see psb_d_base_mat_mod::psb_d_base_csput_a
interface
subroutine psb_d_csr_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
subroutine psb_d_csr_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
import :: psb_ipk_, psb_d_csr_sparse_mat, psb_dpk_
class(psb_d_csr_sparse_mat), intent(inout) :: a
real(psb_dpk_), intent(in) :: val(:)
@@ -292,7 +292,7 @@ module psb_d_csr_mat_mod
& imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: gtl(:)
end subroutine psb_d_csr_csput
end subroutine psb_d_csr_csput_a
end interface
!> \memberof psb_d_csr_sparse_mat
base/modules/psb_d_mat_mod.f90
+56 -3
View File
@@ -98,6 +98,7 @@ module psb_d_mat_mod
procedure, pass(a) :: is_lower => psb_d_is_lower
procedure, pass(a) :: is_triangle => psb_d_is_triangle
procedure, pass(a) :: is_unit => psb_d_is_unit
procedure, pass(a) :: is_repeatable_updates => psb_d_is_repeatable_updates
procedure, pass(a) :: get_fmt => psb_d_get_fmt
procedure, pass(a) :: sizeof => psb_d_sizeof
@@ -114,12 +115,15 @@ module psb_d_mat_mod
procedure, pass(a) :: set_lower => psb_d_set_lower
procedure, pass(a) :: set_triangle => psb_d_set_triangle
procedure, pass(a) :: set_unit => psb_d_set_unit
procedure, pass(a) :: set_repeatable_updates => psb_d_set_repeatable_updates
! Memory/data management
procedure, pass(a) :: csall => psb_d_csall
procedure, pass(a) :: free => psb_d_free
procedure, pass(a) :: trim => psb_d_trim
procedure, pass(a) :: csput => psb_d_csput
procedure, pass(a) :: csput_a => psb_d_csput_a
procedure, pass(a) :: csput_v => psb_d_csput_v
generic, public :: csput => csput_a, csput_v
procedure, pass(a) :: csgetptn => psb_d_csgetptn
procedure, pass(a) :: csgetrow => psb_d_csgetrow
procedure, pass(a) :: csgetblk => psb_d_csgetblk
@@ -136,6 +140,7 @@ module psb_d_mat_mod
procedure, pass(a) :: print_n => psb_d_n_sparse_print
generic, public :: print => print_i, print_n
procedure, pass(a) :: mold => psb_d_mold
procedure, pass(a) :: asb => psb_d_asb
procedure, pass(a) :: transp_1mat => psb_d_transp_1mat
procedure, pass(a) :: transp_2mat => psb_d_transp_2mat
generic, public :: transp => transp_1mat, transp_2mat
@@ -378,16 +383,31 @@ module psb_d_mat_mod
end interface
interface
subroutine psb_d_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
subroutine psb_d_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
import :: psb_ipk_, psb_dspmat_type, psb_dpk_
class(psb_dspmat_type), intent(inout) :: a
real(psb_dpk_), intent(in) :: val(:)
integer(psb_ipk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: gtl(:)
end subroutine psb_d_csput
end subroutine psb_d_csput_a
end interface
interface
subroutine psb_d_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
use psb_d_vect_mod, only : psb_d_vect_type
use psb_i_vect_mod, only : psb_i_vect_type
import :: psb_ipk_, psb_dspmat_type
class(psb_dspmat_type), intent(inout) :: a
type(psb_d_vect_type), intent(inout) :: val
type(psb_i_vect_type), intent(inout) :: ia, ja
integer(psb_ipk_), intent(in) :: nz, imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: gtl(:)
end subroutine psb_d_csput_v
end interface
interface
subroutine psb_d_csgetptn(imin,imax,a,nz,ia,ja,info,&
& jmin,jmax,iren,append,nzin,rscale,cscale)
@@ -493,6 +513,14 @@ module psb_d_mat_mod
end subroutine psb_d_mold
end interface
interface
subroutine psb_d_asb(a,mold)
import :: psb_ipk_, psb_dspmat_type, psb_d_base_sparse_mat
class(psb_dspmat_type), intent(inout) :: a
class(psb_d_base_sparse_mat), optional, intent(in) :: mold
end subroutine psb_d_asb
end interface
interface
subroutine psb_d_transp_1mat(a)
import :: psb_ipk_, psb_dspmat_type
@@ -1085,6 +1113,31 @@ contains
function psb_d_is_repeatable_updates(a) result(res)
implicit none
class(psb_dspmat_type), intent(in) :: a
logical :: res
if (allocated(a%a)) then
res = a%a%is_repeatable_updates()
else
res = .false.
end if
end function psb_d_is_repeatable_updates
subroutine psb_d_set_repeatable_updates(a,val)
implicit none
class(psb_dspmat_type), intent(inout) :: a
logical, intent(in), optional :: val
if (allocated(a%a)) then
call a%a%set_repeatable_updates(val)
end if
end subroutine psb_d_set_repeatable_updates
function psb_d_get_nzeros(a) result(res)
implicit none
class(psb_dspmat_type), intent(in) :: a
base/modules/psb_d_tools_mod.f90
+28 -1
View File
@@ -31,7 +31,7 @@
!!$
Module psb_d_tools_mod
use psb_desc_mod, only : psb_desc_type, psb_dpk_, psb_ipk_
use psb_d_vect_mod, only : psb_d_base_vect_type, psb_d_vect_type
use psb_d_vect_mod, only : psb_d_base_vect_type, psb_d_vect_type, psb_i_vect_type
use psb_d_mat_mod, only : psb_dspmat_type, psb_d_base_sparse_mat
interface psb_geall
@@ -206,6 +206,19 @@ Module psb_d_tools_mod
integer(psb_ipk_), optional, intent(in) :: dupl
logical, intent(in), optional :: local
end subroutine psb_dins_vect
subroutine psb_dins_vect_v(m,irw,val,x,desc_a,info,dupl,local)
import :: psb_desc_type, psb_dpk_, psb_ipk_, &
& psb_d_base_vect_type, psb_d_vect_type, psb_i_vect_type, &
& psb_dspmat_type, psb_d_base_sparse_mat
integer(psb_ipk_), intent(in) :: m
type(psb_desc_type), intent(in) :: desc_a
type(psb_d_vect_type), intent(inout) :: x
type(psb_i_vect_type), intent(inout) :: irw
type(psb_d_vect_type), intent(inout) :: val
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: dupl
logical, intent(in), optional :: local
end subroutine psb_dins_vect_v
subroutine psb_dins_vect_r2(m,irw,val,x,desc_a,info,dupl,local)
import :: psb_desc_type, psb_dpk_, psb_ipk_, &
& psb_d_base_vect_type, psb_d_vect_type, &
@@ -286,6 +299,20 @@ Module psb_d_tools_mod
logical, intent(in), optional :: rebuild
logical, intent(in), optional :: local
end subroutine psb_dspins
subroutine psb_dspins_v(nz,ia,ja,val,a,desc_a,info,rebuild,local)
use psb_i_vect_mod, only : psb_i_vect_type
import :: psb_desc_type, psb_dpk_, psb_ipk_, &
& psb_d_base_vect_type, psb_d_vect_type,&
& psb_dspmat_type, psb_d_base_sparse_mat
type(psb_desc_type), intent(inout) :: desc_a
type(psb_dspmat_type), intent(inout) :: a
integer(psb_ipk_), intent(in) :: nz
type(psb_i_vect_type), intent(inout) :: ia,ja
type(psb_d_vect_type), intent(inout) :: val
integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: rebuild
logical, intent(in), optional :: local
end subroutine psb_dspins_v
subroutine psb_dspins_2desc(nz,ia,ja,val,a,desc_ar,desc_ac,info)
import :: psb_desc_type, psb_dpk_, psb_ipk_, &
& psb_d_base_vect_type, psb_d_vect_type, &
base/modules/psb_d_vect_mod.F90
+660 -3
View File
@@ -40,6 +40,7 @@
module psb_d_vect_mod
use psb_d_base_vect_mod
use psb_i_vect_mod
type psb_d_vect_type
class(psb_d_base_vect_type), allocatable :: v
@@ -76,7 +77,9 @@ module psb_d_vect_mod
procedure, pass(y) :: sctb => d_vect_sctb
generic, public :: sct => sctb
procedure, pass(x) :: free => d_vect_free
procedure, pass(x) :: ins => d_vect_ins
procedure, pass(x) :: ins_a => d_vect_ins_a
procedure, pass(x) :: ins_v => d_vect_ins_v
generic, public :: ins => ins_v, ins_a
procedure, pass(x) :: bld_x => d_vect_bld_x
procedure, pass(x) :: bld_n => d_vect_bld_n
generic, public :: bld => bld_x, bld_n
@@ -619,7 +622,7 @@ contains
end subroutine d_vect_free
subroutine d_vect_ins(n,irl,val,dupl,x,info)
subroutine d_vect_ins_a(n,irl,val,dupl,x,info)
use psi_serial_mod
implicit none
class(psb_d_vect_type), intent(inout) :: x
@@ -638,7 +641,28 @@ contains
call x%v%ins(n,irl,val,dupl,info)
end subroutine d_vect_ins
end subroutine d_vect_ins_a
subroutine d_vect_ins_v(n,irl,val,dupl,x,info)
use psi_serial_mod
implicit none
class(psb_d_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n, dupl
class(psb_i_vect_type), intent(inout) :: irl
class(psb_d_vect_type), intent(inout) :: val
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: i
info = 0
if (.not.(allocated(x%v).and.allocated(irl%v).and.allocated(val%v))) then
info = psb_err_invalid_vect_state_
return
end if
call x%v%ins(n,irl%v,val%v,dupl,info)
end subroutine d_vect_ins_v
subroutine d_vect_cnv(x,mold)
@@ -663,3 +687,636 @@ contains
end subroutine d_vect_cnv
end module psb_d_vect_mod
module psb_d_multivect_mod
use psb_d_base_multivect_mod
use psb_const_mod
!private
type psb_d_multivect_type
class(psb_d_base_multivect_type), allocatable :: v
contains
procedure, pass(x) :: get_nrows => d_vect_get_nrows
procedure, pass(x) :: get_ncols => d_vect_get_ncols
procedure, pass(x) :: sizeof => d_vect_sizeof
procedure, pass(x) :: get_fmt => d_vect_get_fmt
!!$ procedure, pass(x) :: dot_v => d_vect_dot_v
!!$ procedure, pass(x) :: dot_a => d_vect_dot_a
!!$ generic, public :: dot => dot_v, dot_a
!!$ procedure, pass(y) :: axpby_v => d_vect_axpby_v
!!$ procedure, pass(y) :: axpby_a => d_vect_axpby_a
!!$ generic, public :: axpby => axpby_v, axpby_a
!!$ procedure, pass(y) :: mlt_v => d_vect_mlt_v
!!$ procedure, pass(y) :: mlt_a => d_vect_mlt_a
!!$ procedure, pass(z) :: mlt_a_2 => d_vect_mlt_a_2
!!$ procedure, pass(z) :: mlt_v_2 => d_vect_mlt_v_2
!!$ procedure, pass(z) :: mlt_va => d_vect_mlt_va
!!$ procedure, pass(z) :: mlt_av => d_vect_mlt_av
!!$ generic, public :: mlt => mlt_v, mlt_a, mlt_a_2,&
!!$ & mlt_v_2, mlt_av, mlt_va
!!$ procedure, pass(x) :: scal => d_vect_scal
!!$ procedure, pass(x) :: nrm2 => d_vect_nrm2
!!$ procedure, pass(x) :: amax => d_vect_amax
!!$ procedure, pass(x) :: asum => d_vect_asum
procedure, pass(x) :: all => d_vect_all
procedure, pass(x) :: reall => d_vect_reall
procedure, pass(x) :: zero => d_vect_zero
procedure, pass(x) :: asb => d_vect_asb
procedure, pass(x) :: sync => d_vect_sync
!!$ procedure, pass(x) :: gthab => d_vect_gthab
!!$ procedure, pass(x) :: gthzv => d_vect_gthzv
!!$ generic, public :: gth => gthab, gthzv
!!$ procedure, pass(y) :: sctb => d_vect_sctb
!!$ generic, public :: sct => sctb
procedure, pass(x) :: free => d_vect_free
procedure, pass(x) :: ins => d_vect_ins
procedure, pass(x) :: bld_x => d_vect_bld_x
procedure, pass(x) :: bld_n => d_vect_bld_n
generic, public :: bld => bld_x, bld_n
procedure, pass(x) :: get_vect => d_vect_get_vect
procedure, pass(x) :: cnv => d_vect_cnv
procedure, pass(x) :: set_scal => d_vect_set_scal
procedure, pass(x) :: set_vect => d_vect_set_vect
generic, public :: set => set_vect, set_scal
procedure, pass(x) :: clone => d_vect_clone
end type psb_d_multivect_type
public :: psb_d_multivect, psb_d_multivect_type,&
& psb_set_multivect_default, psb_get_multivect_default
private
interface psb_d_multivect
module procedure constructor, size_const
end interface
class(psb_d_base_multivect_type), allocatable, target,&
& save, private :: psb_d_base_multivect_default
interface psb_set_multivect_default
module procedure psb_d_set_multivect_default
end interface
interface psb_get_vect_default
module procedure psb_d_get_multivect_default
end interface
contains
subroutine psb_d_set_multivect_default(v)
implicit none
class(psb_d_base_multivect_type), intent(in) :: v
if (allocated(psb_d_base_multivect_default)) then
deallocate(psb_d_base_multivect_default)
end if
allocate(psb_d_base_multivect_default, mold=v)
end subroutine psb_d_set_multivect_default
function psb_d_get_multivect_default(v) result(res)
implicit none
class(psb_d_multivect_type), intent(in) :: v
class(psb_d_base_multivect_type), pointer :: res
res => psb_d_get_base_multivect_default()
end function psb_d_get_multivect_default
function psb_d_get_base_multivect_default() result(res)
implicit none
class(psb_d_base_multivect_type), pointer :: res
if (.not.allocated(psb_d_base_multivect_default)) then
allocate(psb_d_base_multivect_type :: psb_d_base_multivect_default)
end if
res => psb_d_base_multivect_default
end function psb_d_get_base_multivect_default
subroutine d_vect_clone(x,y,info)
implicit none
class(psb_d_multivect_type), intent(inout) :: x
class(psb_d_multivect_type), intent(inout) :: y
integer(psb_ipk_), intent(out) :: info
info = psb_success_
call y%free(info)
if ((info==0).and.allocated(x%v)) then
call y%bld(x%get_vect(),mold=x%v)
end if
end subroutine d_vect_clone
subroutine d_vect_bld_x(x,invect,mold)
real(psb_dpk_), intent(in) :: invect(:,:)
class(psb_d_multivect_type), intent(out) :: x
class(psb_d_base_multivect_type), intent(in), optional :: mold
integer(psb_ipk_) :: info
class(psb_d_base_multivect_type), pointer :: mld
if (present(mold)) then
#ifdef HAVE_MOLD
allocate(x%v,stat=info,mold=mold)
#else
call mold%mold(x%v,info)
#endif
else
#ifdef HAVE_MOLD
allocate(x%v,stat=info, mold=psb_d_get_base_multivect_default())
#else
mld = psb_d_get_base_multivect_default()
call mld%mold(x%v,info)
#endif
endif
if (info == psb_success_) call x%v%bld(invect)
end subroutine d_vect_bld_x
subroutine d_vect_bld_n(x,m,n,mold)
integer(psb_ipk_), intent(in) :: m,n
class(psb_d_multivect_type), intent(out) :: x
class(psb_d_base_multivect_type), intent(in), optional :: mold
integer(psb_ipk_) :: info
class(psb_d_base_multivect_type), pointer :: mld
if (present(mold)) then
#ifdef HAVE_MOLD
allocate(x%v,stat=info,mold=mold)
#else
call mold%mold(x%v,info)
#endif
else
#ifdef HAVE_MOLD
allocate(x%v,stat=info, mold=psb_d_get_base_multivect_default())
#else
mld = psb_d_get_base_multivect_default()
call mld%mold(x%v,info)
#endif
endif
if (info == psb_success_) call x%v%bld(m,n)
end subroutine d_vect_bld_n
function d_vect_get_vect(x) result(res)
class(psb_d_multivect_type), intent(inout) :: x
real(psb_dpk_), allocatable :: res(:,:)
integer(psb_ipk_) :: info
if (allocated(x%v)) then
res = x%v%get_vect()
end if
end function d_vect_get_vect
subroutine d_vect_set_scal(x,val)
class(psb_d_multivect_type), intent(inout) :: x
real(psb_dpk_), intent(in) :: val
integer(psb_ipk_) :: info
if (allocated(x%v)) call x%v%set(val)
end subroutine d_vect_set_scal
subroutine d_vect_set_vect(x,val)
class(psb_d_multivect_type), intent(inout) :: x
real(psb_dpk_), intent(in) :: val(:,:)
integer(psb_ipk_) :: info
if (allocated(x%v)) call x%v%set(val)
end subroutine d_vect_set_vect
function constructor(x) result(this)
real(psb_dpk_) :: x(:,:)
type(psb_d_multivect_type) :: this
integer(psb_ipk_) :: info
call this%bld(x)
call this%asb(size(x,dim=1,kind=psb_ipk_),size(x,dim=2,kind=psb_ipk_),info)
end function constructor
function size_const(m,n) result(this)
integer(psb_ipk_), intent(in) :: m,n
type(psb_d_multivect_type) :: this
integer(psb_ipk_) :: info
call this%bld(m,n)
call this%asb(m,n,info)
end function size_const
function d_vect_get_nrows(x) result(res)
implicit none
class(psb_d_multivect_type), intent(in) :: x
integer(psb_ipk_) :: res
res = 0
if (allocated(x%v)) res = x%v%get_nrows()
end function d_vect_get_nrows
function d_vect_get_ncols(x) result(res)
implicit none
class(psb_d_multivect_type), intent(in) :: x
integer(psb_ipk_) :: res
res = 0
if (allocated(x%v)) res = x%v%get_ncols()
end function d_vect_get_ncols
function d_vect_sizeof(x) result(res)
implicit none
class(psb_d_multivect_type), intent(in) :: x
integer(psb_long_int_k_) :: res
res = 0
if (allocated(x%v)) res = x%v%sizeof()
end function d_vect_sizeof
function d_vect_get_fmt(x) result(res)
implicit none
class(psb_d_multivect_type), intent(in) :: x
character(len=5) :: res
res = 'NULL'
if (allocated(x%v)) res = x%v%get_fmt()
end function d_vect_get_fmt
!!$ function d_vect_dot_v(n,x,y) result(res)
!!$ implicit none
!!$ class(psb_d_multivect_type), intent(inout) :: x, y
!!$ integer(psb_ipk_), intent(in) :: n
!!$ real(psb_dpk_) :: res
!!$
!!$ res = dzero
!!$ if (allocated(x%v).and.allocated(y%v)) &
!!$ & res = x%v%dot(n,y%v)
!!$
!!$ end function d_vect_dot_v
!!$
!!$ function d_vect_dot_a(n,x,y) result(res)
!!$ implicit none
!!$ class(psb_d_multivect_type), intent(inout) :: x
!!$ real(psb_dpk_), intent(in) :: y(:)
!!$ integer(psb_ipk_), intent(in) :: n
!!$ real(psb_dpk_) :: res
!!$
!!$ res = dzero
!!$ if (allocated(x%v)) &
!!$ & res = x%v%dot(n,y)
!!$
!!$ end function d_vect_dot_a
!!$
!!$ subroutine d_vect_axpby_v(m,alpha, x, beta, y, info)
!!$ use psi_serial_mod
!!$ implicit none
!!$ integer(psb_ipk_), intent(in) :: m
!!$ class(psb_d_multivect_type), intent(inout) :: x
!!$ class(psb_d_multivect_type), intent(inout) :: y
!!$ real(psb_dpk_), intent (in) :: alpha, beta
!!$ integer(psb_ipk_), intent(out) :: info
!!$
!!$ if (allocated(x%v).and.allocated(y%v)) then
!!$ call y%v%axpby(m,alpha,x%v,beta,info)
!!$ else
!!$ info = psb_err_invalid_vect_state_
!!$ end if
!!$
!!$ end subroutine d_vect_axpby_v
!!$
!!$ subroutine d_vect_axpby_a(m,alpha, x, beta, y, info)
!!$ use psi_serial_mod
!!$ implicit none
!!$ integer(psb_ipk_), intent(in) :: m
!!$ real(psb_dpk_), intent(in) :: x(:)
!!$ class(psb_d_multivect_type), intent(inout) :: y
!!$ real(psb_dpk_), intent (in) :: alpha, beta
!!$ integer(psb_ipk_), intent(out) :: info
!!$
!!$ if (allocated(y%v)) &
!!$ & call y%v%axpby(m,alpha,x,beta,info)
!!$
!!$ end subroutine d_vect_axpby_a
!!$
!!$
!!$ subroutine d_vect_mlt_v(x, y, info)
!!$ use psi_serial_mod
!!$ implicit none
!!$ class(psb_d_multivect_type), intent(inout) :: x
!!$ class(psb_d_multivect_type), intent(inout) :: y
!!$ integer(psb_ipk_), intent(out) :: info
!!$ integer(psb_ipk_) :: i, n
!!$
!!$ info = 0
!!$ if (allocated(x%v).and.allocated(y%v)) &
!!$ & call y%v%mlt(x%v,info)
!!$
!!$ end subroutine d_vect_mlt_v
!!$
!!$ subroutine d_vect_mlt_a(x, y, info)
!!$ use psi_serial_mod
!!$ implicit none
!!$ real(psb_dpk_), intent(in) :: x(:)
!!$ class(psb_d_multivect_type), intent(inout) :: y
!!$ integer(psb_ipk_), intent(out) :: info
!!$ integer(psb_ipk_) :: i, n
!!$
!!$
!!$ info = 0
!!$ if (allocated(y%v)) &
!!$ & call y%v%mlt(x,info)
!!$
!!$ end subroutine d_vect_mlt_a
!!$
!!$
!!$ subroutine d_vect_mlt_a_2(alpha,x,y,beta,z,info)
!!$ use psi_serial_mod
!!$ implicit none
!!$ real(psb_dpk_), intent(in) :: alpha,beta
!!$ real(psb_dpk_), intent(in) :: y(:)
!!$ real(psb_dpk_), intent(in) :: x(:)
!!$ class(psb_d_multivect_type), intent(inout) :: z
!!$ integer(psb_ipk_), intent(out) :: info
!!$ integer(psb_ipk_) :: i, n
!!$
!!$ info = 0
!!$ if (allocated(z%v)) &
!!$ & call z%v%mlt(alpha,x,y,beta,info)
!!$
!!$ end subroutine d_vect_mlt_a_2
!!$
!!$ subroutine d_vect_mlt_v_2(alpha,x,y,beta,z,info,conjgx,conjgy)
!!$ use psi_serial_mod
!!$ implicit none
!!$ real(psb_dpk_), intent(in) :: alpha,beta
!!$ class(psb_d_multivect_type), intent(inout) :: x
!!$ class(psb_d_multivect_type), intent(inout) :: y
!!$ class(psb_d_multivect_type), intent(inout) :: z
!!$ integer(psb_ipk_), intent(out) :: info
!!$ character(len=1), intent(in), optional :: conjgx, conjgy
!!$
!!$ integer(psb_ipk_) :: i, n
!!$
!!$ info = 0
!!$ if (allocated(x%v).and.allocated(y%v).and.&
!!$ & allocated(z%v)) &
!!$ & call z%v%mlt(alpha,x%v,y%v,beta,info,conjgx,conjgy)
!!$
!!$ end subroutine d_vect_mlt_v_2
!!$
!!$ subroutine d_vect_mlt_av(alpha,x,y,beta,z,info)
!!$ use psi_serial_mod
!!$ implicit none
!!$ real(psb_dpk_), intent(in) :: alpha,beta
!!$ real(psb_dpk_), intent(in) :: x(:)
!!$ class(psb_d_multivect_type), intent(inout) :: y
!!$ class(psb_d_multivect_type), intent(inout) :: z
!!$ integer(psb_ipk_), intent(out) :: info
!!$ integer(psb_ipk_) :: i, n
!!$
!!$ info = 0
!!$ if (allocated(z%v).and.allocated(y%v)) &
!!$ & call z%v%mlt(alpha,x,y%v,beta,info)
!!$
!!$ end subroutine d_vect_mlt_av
!!$
!!$ subroutine d_vect_mlt_va(alpha,x,y,beta,z,info)
!!$ use psi_serial_mod
!!$ implicit none
!!$ real(psb_dpk_), intent(in) :: alpha,beta
!!$ real(psb_dpk_), intent(in) :: y(:)
!!$ class(psb_d_multivect_type), intent(inout) :: x
!!$ class(psb_d_multivect_type), intent(inout) :: z
!!$ integer(psb_ipk_), intent(out) :: info
!!$ integer(psb_ipk_) :: i, n
!!$
!!$ info = 0
!!$
!!$ if (allocated(z%v).and.allocated(x%v)) &
!!$ & call z%v%mlt(alpha,x%v,y,beta,info)
!!$
!!$ end subroutine d_vect_mlt_va
!!$
!!$ subroutine d_vect_scal(alpha, x)
!!$ use psi_serial_mod
!!$ implicit none
!!$ class(psb_d_multivect_type), intent(inout) :: x
!!$ real(psb_dpk_), intent (in) :: alpha
!!$
!!$ if (allocated(x%v)) call x%v%scal(alpha)
!!$
!!$ end subroutine d_vect_scal
!!$
!!$
!!$ function d_vect_nrm2(n,x) result(res)
!!$ implicit none
!!$ class(psb_d_multivect_type), intent(inout) :: x
!!$ integer(psb_ipk_), intent(in) :: n
!!$ real(psb_dpk_) :: res
!!$
!!$ if (allocated(x%v)) then
!!$ res = x%v%nrm2(n)
!!$ else
!!$ res = dzero
!!$ end if
!!$
!!$ end function d_vect_nrm2
!!$
!!$ function d_vect_amax(n,x) result(res)
!!$ implicit none
!!$ class(psb_d_multivect_type), intent(inout) :: x
!!$ integer(psb_ipk_), intent(in) :: n
!!$ real(psb_dpk_) :: res
!!$
!!$ if (allocated(x%v)) then
!!$ res = x%v%amax(n)
!!$ else
!!$ res = dzero
!!$ end if
!!$
!!$ end function d_vect_amax
!!$
!!$ function d_vect_asum(n,x) result(res)
!!$ implicit none
!!$ class(psb_d_multivect_type), intent(inout) :: x
!!$ integer(psb_ipk_), intent(in) :: n
!!$ real(psb_dpk_) :: res
!!$
!!$ if (allocated(x%v)) then
!!$ res = x%v%asum(n)
!!$ else
!!$ res = dzero
!!$ end if
!!$
!!$ end function d_vect_asum
subroutine d_vect_all(m,n, x, info, mold)
implicit none
integer(psb_ipk_), intent(in) :: m,n
class(psb_d_multivect_type), intent(out) :: x
class(psb_d_base_multivect_type), intent(in), optional :: mold
integer(psb_ipk_), intent(out) :: info
if (present(mold)) then
#ifdef HAVE_MOLD
allocate(x%v,stat=info,mold=mold)
#else
call mold%mold(x%v,info)
#endif
else
allocate(psb_d_base_multivect_type :: x%v,stat=info)
endif
if (info == 0) then
call x%v%all(m,n,info)
else
info = psb_err_alloc_dealloc_
end if
end subroutine d_vect_all
subroutine d_vect_reall(m,n, x, info)
implicit none
integer(psb_ipk_), intent(in) :: m,n
class(psb_d_multivect_type), intent(inout) :: x
integer(psb_ipk_), intent(out) :: info
info = 0
if (.not.allocated(x%v)) &
& call x%all(m,n,info)
if (info == 0) &
& call x%asb(m,n,info)
end subroutine d_vect_reall
subroutine d_vect_zero(x)
use psi_serial_mod
implicit none
class(psb_d_multivect_type), intent(inout) :: x
if (allocated(x%v)) call x%v%zero()
end subroutine d_vect_zero
subroutine d_vect_asb(m,n, x, info)
use psi_serial_mod
use psb_realloc_mod
implicit none
integer(psb_ipk_), intent(in) :: m,n
class(psb_d_multivect_type), intent(inout) :: x
integer(psb_ipk_), intent(out) :: info
if (allocated(x%v)) &
& call x%v%asb(m,n,info)
end subroutine d_vect_asb
subroutine d_vect_sync(x)
implicit none
class(psb_d_multivect_type), intent(inout) :: x
if (allocated(x%v)) &
& call x%v%sync()
end subroutine d_vect_sync
!!$ subroutine d_vect_gthab(n,idx,alpha,x,beta,y)
!!$ use psi_serial_mod
!!$ integer(psb_ipk_) :: n, idx(:)
!!$ real(psb_dpk_) :: alpha, beta, y(:)
!!$ class(psb_d_multivect_type) :: x
!!$
!!$ if (allocated(x%v)) &
!!$ & call x%v%gth(n,idx,alpha,beta,y)
!!$
!!$ end subroutine d_vect_gthab
!!$
!!$ subroutine d_vect_gthzv(n,idx,x,y)
!!$ use psi_serial_mod
!!$ integer(psb_ipk_) :: n, idx(:)
!!$ real(psb_dpk_) :: y(:)
!!$ class(psb_d_multivect_type) :: x
!!$
!!$ if (allocated(x%v)) &
!!$ & call x%v%gth(n,idx,y)
!!$
!!$ end subroutine d_vect_gthzv
!!$
!!$ subroutine d_vect_sctb(n,idx,x,beta,y)
!!$ use psi_serial_mod
!!$ integer(psb_ipk_) :: n, idx(:)
!!$ real(psb_dpk_) :: beta, x(:)
!!$ class(psb_d_multivect_type) :: y
!!$
!!$ if (allocated(y%v)) &
!!$ & call y%v%sct(n,idx,x,beta)
!!$
!!$ end subroutine d_vect_sctb
subroutine d_vect_free(x, info)
use psi_serial_mod
use psb_realloc_mod
implicit none
class(psb_d_multivect_type), intent(inout) :: x
integer(psb_ipk_), intent(out) :: info
info = 0
if (allocated(x%v)) then
call x%v%free(info)
if (info == 0) deallocate(x%v,stat=info)
end if
end subroutine d_vect_free
subroutine d_vect_ins(n,irl,val,dupl,x,info)
use psi_serial_mod
implicit none
class(psb_d_multivect_type), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n, dupl
integer(psb_ipk_), intent(in) :: irl(:)
real(psb_dpk_), intent(in) :: val(:,:)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: i
info = 0
if (.not.allocated(x%v)) then
info = psb_err_invalid_vect_state_
return
end if
call x%v%ins(n,irl,val,dupl,info)
end subroutine d_vect_ins
subroutine d_vect_cnv(x,mold)
class(psb_d_multivect_type), intent(inout) :: x
class(psb_d_base_multivect_type), intent(in), optional :: mold
class(psb_d_base_multivect_type), allocatable :: tmp
integer(psb_ipk_) :: info
if (present(mold)) then
#ifdef HAVE_MOLD
allocate(tmp,stat=info,mold=mold)
#else
call mold%mold(tmp,info)
#endif
if (allocated(x%v)) then
call x%v%sync()
if (info == psb_success_) call tmp%bld(x%v%v)
call x%v%free(info)
end if
call move_alloc(tmp,x%v)
end if
end subroutine d_vect_cnv
end module psb_d_multivect_mod
base/modules/psb_i_base_vect_mod.f90
+1097
View File
File diff suppressed because it is too large Load Diff
base/modules/psb_i_vect_mod.F90
+632
View File
@@ -653,3 +653,635 @@ contains
end subroutine i_vect_cnv
end module psb_i_vect_mod
module psb_i_multivect_mod
use psb_i_base_multivect_mod
use psb_const_mod
private
type psb_i_multivect_type
class(psb_i_base_multivect_type), allocatable :: v
contains
procedure, pass(x) :: get_nrows => i_vect_get_nrows
procedure, pass(x) :: get_ncols => i_vect_get_ncols
procedure, pass(x) :: sizeof => i_vect_sizeof
procedure, pass(x) :: get_fmt => i_vect_get_fmt
!!$ procedure, pass(x) :: dot_v => i_vect_dot_v
!!$ procedure, pass(x) :: dot_a => i_vect_dot_a
!!$ generic, public :: dot => dot_v, dot_a
!!$ procedure, pass(y) :: axpby_v => i_vect_axpby_v
!!$ procedure, pass(y) :: axpby_a => i_vect_axpby_a
!!$ generic, public :: axpby => axpby_v, axpby_a
!!$ procedure, pass(y) :: mlt_v => i_vect_mlt_v
!!$ procedure, pass(y) :: mlt_a => i_vect_mlt_a
!!$ procedure, pass(z) :: mlt_a_2 => i_vect_mlt_a_2
!!$ procedure, pass(z) :: mlt_v_2 => i_vect_mlt_v_2
!!$ procedure, pass(z) :: mlt_va => i_vect_mlt_va
!!$ procedure, pass(z) :: mlt_av => i_vect_mlt_av
!!$ generic, public :: mlt => mlt_v, mlt_a, mlt_a_2,&
!!$ & mlt_v_2, mlt_av, mlt_va
!!$ procedure, pass(x) :: scal => i_vect_scal
!!$ procedure, pass(x) :: nrm2 => i_vect_nrm2
!!$ procedure, pass(x) :: amax => i_vect_amax
!!$ procedure, pass(x) :: asum => i_vect_asum
procedure, pass(x) :: all => i_vect_all
procedure, pass(x) :: reall => i_vect_reall
procedure, pass(x) :: zero => i_vect_zero
procedure, pass(x) :: asb => i_vect_asb
procedure, pass(x) :: sync => i_vect_sync
!!$ procedure, pass(x) :: gthab => i_vect_gthab
!!$ procedure, pass(x) :: gthzv => i_vect_gthzv
!!$ generic, public :: gth => gthab, gthzv
!!$ procedure, pass(y) :: sctb => i_vect_sctb
!!$ generic, public :: sct => sctb
procedure, pass(x) :: free => i_vect_free
procedure, pass(x) :: ins => i_vect_ins
procedure, pass(x) :: bld_x => i_vect_bld_x
procedure, pass(x) :: bld_n => i_vect_bld_n
generic, public :: bld => bld_x, bld_n
procedure, pass(x) :: get_vect => i_vect_get_vect
procedure, pass(x) :: cnv => i_vect_cnv
procedure, pass(x) :: set_scal => i_vect_set_scal
procedure, pass(x) :: set_vect => i_vect_set_vect
generic, public :: set => set_vect, set_scal
procedure, pass(x) :: clone => i_vect_clone
end type psb_i_multivect_type
public :: psb_i_multivect, psb_i_multivect_type,&
& psb_set_multivect_default, psb_get_multivect_default
interface psb_i_multivect
module procedure constructor, size_const
end interface
class(psb_i_base_multivect_type), allocatable, target,&
& save, private :: psb_i_base_multivect_default
interface psb_set_multivect_default
module procedure psb_i_set_multivect_default
end interface
interface psb_get_vect_default
module procedure psb_i_get_multivect_default
end interface
contains
subroutine psb_i_set_multivect_default(v)
implicit none
class(psb_i_base_multivect_type), intent(in) :: v
if (allocated(psb_i_base_multivect_default)) then
deallocate(psb_i_base_multivect_default)
end if
allocate(psb_i_base_multivect_default, mold=v)
end subroutine psb_i_set_multivect_default
function psb_i_get_multivect_default(v) result(res)
implicit none
class(psb_i_multivect_type), intent(in) :: v
class(psb_i_base_multivect_type), pointer :: res
res => psb_i_get_base_multivect_default()
end function psb_i_get_multivect_default
function psb_i_get_base_multivect_default() result(res)
implicit none
class(psb_i_base_multivect_type), pointer :: res
if (.not.allocated(psb_i_base_multivect_default)) then
allocate(psb_i_base_multivect_type :: psb_i_base_multivect_default)
end if
res => psb_i_base_multivect_default
end function psb_i_get_base_multivect_default
subroutine i_vect_clone(x,y,info)
implicit none
class(psb_i_multivect_type), intent(inout) :: x
class(psb_i_multivect_type), intent(inout) :: y
integer(psb_ipk_), intent(out) :: info
info = psb_success_
call y%free(info)
if ((info==0).and.allocated(x%v)) then
call y%bld(x%get_vect(),mold=x%v)
end if
end subroutine i_vect_clone
subroutine i_vect_bld_x(x,invect,mold)
integer(psb_ipk_), intent(in) :: invect(:,:)
class(psb_i_multivect_type), intent(out) :: x
class(psb_i_base_multivect_type), intent(in), optional :: mold
integer(psb_ipk_) :: info
class(psb_i_base_multivect_type), pointer :: mld
if (present(mold)) then
#ifdef HAVE_MOLD
allocate(x%v,stat=info,mold=mold)
#else
call mold%mold(x%v,info)
#endif
else
#ifdef HAVE_MOLD
allocate(x%v,stat=info, mold=psb_i_get_base_multivect_default())
#else
mld = psb_i_get_base_multivect_default()
call mld%mold(x%v,info)
#endif
endif
if (info == psb_success_) call x%v%bld(invect)
end subroutine i_vect_bld_x
subroutine i_vect_bld_n(x,m,n,mold)
integer(psb_ipk_), intent(in) :: m,n
class(psb_i_multivect_type), intent(out) :: x
class(psb_i_base_multivect_type), intent(in), optional :: mold
integer(psb_ipk_) :: info
class(psb_i_base_multivect_type), pointer :: mld
if (present(mold)) then
#ifdef HAVE_MOLD
allocate(x%v,stat=info,mold=mold)
#else
call mold%mold(x%v,info)
#endif
else
#ifdef HAVE_MOLD
allocate(x%v,stat=info, mold=psb_i_get_base_multivect_default())
#else
mld = psb_i_get_base_multivect_default()
call mld%mold(x%v,info)
#endif
endif
if (info == psb_success_) call x%v%bld(m,n)
end subroutine i_vect_bld_n
function i_vect_get_vect(x) result(res)
class(psb_i_multivect_type), intent(inout) :: x
integer(psb_ipk_), allocatable :: res(:,:)
integer(psb_ipk_) :: info
if (allocated(x%v)) then
res = x%v%get_vect()
end if
end function i_vect_get_vect
subroutine i_vect_set_scal(x,val)
class(psb_i_multivect_type), intent(inout) :: x
integer(psb_ipk_), intent(in) :: val
integer(psb_ipk_) :: info
if (allocated(x%v)) call x%v%set(val)
end subroutine i_vect_set_scal
subroutine i_vect_set_vect(x,val)
class(psb_i_multivect_type), intent(inout) :: x
integer(psb_ipk_), intent(in) :: val(:,:)
integer(psb_ipk_) :: info
if (allocated(x%v)) call x%v%set(val)
end subroutine i_vect_set_vect
function constructor(x) result(this)
integer(psb_ipk_) :: x(:,:)
type(psb_i_multivect_type) :: this
integer(psb_ipk_) :: info
call this%bld(x)
call this%asb(size(x,dim=1,kind=psb_ipk_),size(x,dim=2,kind=psb_ipk_),info)
end function constructor
function size_const(m,n) result(this)
integer(psb_ipk_), intent(in) :: m,n
type(psb_i_multivect_type) :: this
integer(psb_ipk_) :: info
call this%bld(m,n)
call this%asb(m,n,info)
end function size_const
function i_vect_get_nrows(x) result(res)
implicit none
class(psb_i_multivect_type), intent(in) :: x
integer(psb_ipk_) :: res
res = 0
if (allocated(x%v)) res = x%v%get_nrows()
end function i_vect_get_nrows
function i_vect_get_ncols(x) result(res)
implicit none
class(psb_i_multivect_type), intent(in) :: x
integer(psb_ipk_) :: res
res = 0
if (allocated(x%v)) res = x%v%get_ncols()
end function i_vect_get_ncols
function i_vect_sizeof(x) result(res)
implicit none
class(psb_i_multivect_type), intent(in) :: x
integer(psb_long_int_k_) :: res
res = 0
if (allocated(x%v)) res = x%v%sizeof()
end function i_vect_sizeof
function i_vect_get_fmt(x) result(res)
implicit none
class(psb_i_multivect_type), intent(in) :: x
character(len=5) :: res
res = 'NULL'
if (allocated(x%v)) res = x%v%get_fmt()
end function i_vect_get_fmt
!!$ function i_vect_dot_v(n,x,y) result(res)
!!$ implicit none
!!$ class(psb_i_multivect_type), intent(inout) :: x, y
!!$ integer(psb_ipk_), intent(in) :: n
!!$ integer(psb_ipk_) :: res
!!$
!!$ res = izero
!!$ if (allocated(x%v).and.allocated(y%v)) &
!!$ & res = x%v%dot(n,y%v)
!!$
!!$ end function i_vect_dot_v
!!$
!!$ function i_vect_dot_a(n,x,y) result(res)
!!$ implicit none
!!$ class(psb_i_multivect_type), intent(inout) :: x
!!$ integer(psb_ipk_), intent(in) :: y(:)
!!$ integer(psb_ipk_), intent(in) :: n
!!$ integer(psb_ipk_) :: res
!!$
!!$ res = izero
!!$ if (allocated(x%v)) &
!!$ & res = x%v%dot(n,y)
!!$
!!$ end function i_vect_dot_a
!!$
!!$ subroutine i_vect_axpby_v(m,alpha, x, beta, y, info)
!!$ use psi_serial_mod
!!$ implicit none
!!$ integer(psb_ipk_), intent(in) :: m
!!$ class(psb_i_multivect_type), intent(inout) :: x
!!$ class(psb_i_multivect_type), intent(inout) :: y
!!$ integer(psb_ipk_), intent (in) :: alpha, beta
!!$ integer(psb_ipk_), intent(out) :: info
!!$
!!$ if (allocated(x%v).and.allocated(y%v)) then
!!$ call y%v%axpby(m,alpha,x%v,beta,info)
!!$ else
!!$ info = psb_err_invalid_vect_state_
!!$ end if
!!$
!!$ end subroutine i_vect_axpby_v
!!$
!!$ subroutine i_vect_axpby_a(m,alpha, x, beta, y, info)
!!$ use psi_serial_mod
!!$ implicit none
!!$ integer(psb_ipk_), intent(in) :: m
!!$ integer(psb_ipk_), intent(in) :: x(:)
!!$ class(psb_i_multivect_type), intent(inout) :: y
!!$ integer(psb_ipk_), intent (in) :: alpha, beta
!!$ integer(psb_ipk_), intent(out) :: info
!!$
!!$ if (allocated(y%v)) &
!!$ & call y%v%axpby(m,alpha,x,beta,info)
!!$
!!$ end subroutine i_vect_axpby_a
!!$
!!$
!!$ subroutine i_vect_mlt_v(x, y, info)
!!$ use psi_serial_mod
!!$ implicit none
!!$ class(psb_i_multivect_type), intent(inout) :: x
!!$ class(psb_i_multivect_type), intent(inout) :: y
!!$ integer(psb_ipk_), intent(out) :: info
!!$ integer(psb_ipk_) :: i, n
!!$
!!$ info = 0
!!$ if (allocated(x%v).and.allocated(y%v)) &
!!$ & call y%v%mlt(x%v,info)
!!$
!!$ end subroutine i_vect_mlt_v
!!$
!!$ subroutine i_vect_mlt_a(x, y, info)
!!$ use psi_serial_mod
!!$ implicit none
!!$ integer(psb_ipk_), intent(in) :: x(:)
!!$ class(psb_i_multivect_type), intent(inout) :: y
!!$ integer(psb_ipk_), intent(out) :: info
!!$ integer(psb_ipk_) :: i, n
!!$
!!$
!!$ info = 0
!!$ if (allocated(y%v)) &
!!$ & call y%v%mlt(x,info)
!!$
!!$ end subroutine i_vect_mlt_a
!!$
!!$
!!$ subroutine i_vect_mlt_a_2(alpha,x,y,beta,z,info)
!!$ use psi_serial_mod
!!$ implicit none
!!$ integer(psb_ipk_), intent(in) :: alpha,beta
!!$ integer(psb_ipk_), intent(in) :: y(:)
!!$ integer(psb_ipk_), intent(in) :: x(:)
!!$ class(psb_i_multivect_type), intent(inout) :: z
!!$ integer(psb_ipk_), intent(out) :: info
!!$ integer(psb_ipk_) :: i, n
!!$
!!$ info = 0
!!$ if (allocated(z%v)) &
!!$ & call z%v%mlt(alpha,x,y,beta,info)
!!$
!!$ end subroutine i_vect_mlt_a_2
!!$
!!$ subroutine i_vect_mlt_v_2(alpha,x,y,beta,z,info,conjgx,conjgy)
!!$ use psi_serial_mod
!!$ implicit none
!!$ integer(psb_ipk_), intent(in) :: alpha,beta
!!$ class(psb_i_multivect_type), intent(inout) :: x
!!$ class(psb_i_multivect_type), intent(inout) :: y
!!$ class(psb_i_multivect_type), intent(inout) :: z
!!$ integer(psb_ipk_), intent(out) :: info
!!$ character(len=1), intent(in), optional :: conjgx, conjgy
!!$
!!$ integer(psb_ipk_) :: i, n
!!$
!!$ info = 0
!!$ if (allocated(x%v).and.allocated(y%v).and.&
!!$ & allocated(z%v)) &
!!$ & call z%v%mlt(alpha,x%v,y%v,beta,info,conjgx,conjgy)
!!$
!!$ end subroutine i_vect_mlt_v_2
!!$
!!$ subroutine i_vect_mlt_av(alpha,x,y,beta,z,info)
!!$ use psi_serial_mod
!!$ implicit none
!!$ integer(psb_ipk_), intent(in) :: alpha,beta
!!$ integer(psb_ipk_), intent(in) :: x(:)
!!$ class(psb_i_multivect_type), intent(inout) :: y
!!$ class(psb_i_multivect_type), intent(inout) :: z
!!$ integer(psb_ipk_), intent(out) :: info
!!$ integer(psb_ipk_) :: i, n
!!$
!!$ info = 0
!!$ if (allocated(z%v).and.allocated(y%v)) &
!!$ & call z%v%mlt(alpha,x,y%v,beta,info)
!!$
!!$ end subroutine i_vect_mlt_av
!!$
!!$ subroutine i_vect_mlt_va(alpha,x,y,beta,z,info)
!!$ use psi_serial_mod
!!$ implicit none
!!$ integer(psb_ipk_), intent(in) :: alpha,beta
!!$ integer(psb_ipk_), intent(in) :: y(:)
!!$ class(psb_i_multivect_type), intent(inout) :: x
!!$ class(psb_i_multivect_type), intent(inout) :: z
!!$ integer(psb_ipk_), intent(out) :: info
!!$ integer(psb_ipk_) :: i, n
!!$
!!$ info = 0
!!$
!!$ if (allocated(z%v).and.allocated(x%v)) &
!!$ & call z%v%mlt(alpha,x%v,y,beta,info)
!!$
!!$ end subroutine i_vect_mlt_va
!!$
!!$ subroutine i_vect_scal(alpha, x)
!!$ use psi_serial_mod
!!$ implicit none
!!$ class(psb_i_multivect_type), intent(inout) :: x
!!$ integer(psb_ipk_), intent (in) :: alpha
!!$
!!$ if (allocated(x%v)) call x%v%scal(alpha)
!!$
!!$ end subroutine i_vect_scal
!!$
!!$
!!$ function i_vect_nrm2(n,x) result(res)
!!$ implicit none
!!$ class(psb_i_multivect_type), intent(inout) :: x
!!$ integer(psb_ipk_), intent(in) :: n
!!$ integer(psb_ipk_) :: res
!!$
!!$ if (allocated(x%v)) then
!!$ res = x%v%nrm2(n)
!!$ else
!!$ res = izero
!!$ end if
!!$
!!$ end function i_vect_nrm2
!!$
!!$ function i_vect_amax(n,x) result(res)
!!$ implicit none
!!$ class(psb_i_multivect_type), intent(inout) :: x
!!$ integer(psb_ipk_), intent(in) :: n
!!$ integer(psb_ipk_) :: res
!!$
!!$ if (allocated(x%v)) then
!!$ res = x%v%amax(n)
!!$ else
!!$ res = izero
!!$ end if
!!$
!!$ end function i_vect_amax
!!$
!!$ function i_vect_asum(n,x) result(res)
!!$ implicit none
!!$ class(psb_i_multivect_type), intent(inout) :: x
!!$ integer(psb_ipk_), intent(in) :: n
!!$ integer(psb_ipk_) :: res
!!$
!!$ if (allocated(x%v)) then
!!$ res = x%v%asum(n)
!!$ else
!!$ res = izero
!!$ end if
!!$
!!$ end function i_vect_asum
subroutine i_vect_all(m,n, x, info, mold)
implicit none
integer(psb_ipk_), intent(in) :: m,n
class(psb_i_multivect_type), intent(out) :: x
class(psb_i_base_multivect_type), intent(in), optional :: mold
integer(psb_ipk_), intent(out) :: info
if (present(mold)) then
#ifdef HAVE_MOLD
allocate(x%v,stat=info,mold=mold)
#else
call mold%mold(x%v,info)
#endif
else
allocate(psb_i_base_multivect_type :: x%v,stat=info)
endif
if (info == 0) then
call x%v%all(m,n,info)
else
info = psb_err_alloc_dealloc_
end if
end subroutine i_vect_all
subroutine i_vect_reall(m,n, x, info)
implicit none
integer(psb_ipk_), intent(in) :: m,n
class(psb_i_multivect_type), intent(inout) :: x
integer(psb_ipk_), intent(out) :: info
info = 0
if (.not.allocated(x%v)) &
& call x%all(m,n,info)
if (info == 0) &
& call x%asb(m,n,info)
end subroutine i_vect_reall
subroutine i_vect_zero(x)
use psi_serial_mod
implicit none
class(psb_i_multivect_type), intent(inout) :: x
if (allocated(x%v)) call x%v%zero()
end subroutine i_vect_zero
subroutine i_vect_asb(m,n, x, info)
use psi_serial_mod
use psb_realloc_mod
implicit none
integer(psb_ipk_), intent(in) :: m,n
class(psb_i_multivect_type), intent(inout) :: x
integer(psb_ipk_), intent(out) :: info
if (allocated(x%v)) &
& call x%v%asb(m,n,info)
end subroutine i_vect_asb
subroutine i_vect_sync(x)
implicit none
class(psb_i_multivect_type), intent(inout) :: x
if (allocated(x%v)) &
& call x%v%sync()
end subroutine i_vect_sync
!!$ subroutine i_vect_gthab(n,idx,alpha,x,beta,y)
!!$ use psi_serial_mod
!!$ integer(psb_ipk_) :: n, idx(:)
!!$ integer(psb_ipk_) :: alpha, beta, y(:)
!!$ class(psb_i_multivect_type) :: x
!!$
!!$ if (allocated(x%v)) &
!!$ & call x%v%gth(n,idx,alpha,beta,y)
!!$
!!$ end subroutine i_vect_gthab
!!$
!!$ subroutine i_vect_gthzv(n,idx,x,y)
!!$ use psi_serial_mod
!!$ integer(psb_ipk_) :: n, idx(:)
!!$ integer(psb_ipk_) :: y(:)
!!$ class(psb_i_multivect_type) :: x
!!$
!!$ if (allocated(x%v)) &
!!$ & call x%v%gth(n,idx,y)
!!$
!!$ end subroutine i_vect_gthzv
!!$
!!$ subroutine i_vect_sctb(n,idx,x,beta,y)
!!$ use psi_serial_mod
!!$ integer(psb_ipk_) :: n, idx(:)
!!$ integer(psb_ipk_) :: beta, x(:)
!!$ class(psb_i_multivect_type) :: y
!!$
!!$ if (allocated(y%v)) &
!!$ & call y%v%sct(n,idx,x,beta)
!!$
!!$ end subroutine i_vect_sctb
subroutine i_vect_free(x, info)
use psi_serial_mod
use psb_realloc_mod
implicit none
class(psb_i_multivect_type), intent(inout) :: x
integer(psb_ipk_), intent(out) :: info
info = 0
if (allocated(x%v)) then
call x%v%free(info)
if (info == 0) deallocate(x%v,stat=info)
end if
end subroutine i_vect_free
subroutine i_vect_ins(n,irl,val,dupl,x,info)
use psi_serial_mod
implicit none
class(psb_i_multivect_type), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n, dupl
integer(psb_ipk_), intent(in) :: irl(:)
integer(psb_ipk_), intent(in) :: val(:,:)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: i
info = 0
if (.not.allocated(x%v)) then
info = psb_err_invalid_vect_state_
return
end if
call x%v%ins(n,irl,val,dupl,info)
end subroutine i_vect_ins
subroutine i_vect_cnv(x,mold)
class(psb_i_multivect_type), intent(inout) :: x
class(psb_i_base_multivect_type), intent(in), optional :: mold
class(psb_i_base_multivect_type), allocatable :: tmp
integer(psb_ipk_) :: info
if (present(mold)) then
#ifdef HAVE_MOLD
allocate(tmp,stat=info,mold=mold)
#else
call mold%mold(tmp,info)
#endif
if (allocated(x%v)) then
call x%v%sync()
if (info == psb_success_) call tmp%bld(x%v%v)
call x%v%free(info)
end if
call move_alloc(tmp,x%v)
end if
end subroutine i_vect_cnv
end module psb_i_multivect_mod
base/modules/psb_realloc_mod.F90
+43
View File
@@ -3820,4 +3820,47 @@ Contains
#endif
subroutine i_trans(a,at)
implicit none
integer(psb_ipk_) :: nr,nc
integer(psb_ipk_) :: a(:,:)
integer(psb_ipk_), allocatable, intent(out) :: at(:,:)
integer(psb_ipk_) :: i,j,ib, ii
integer(psb_ipk_), parameter :: nb=32
nr = size(a,1)
nc = size(a,2)
allocate(at(nc,nr))
do i=1,nr,nb
ib=min(nb,nr-i+1)
do ii=i,i+ib-1
do j=1,nc
at(j,ii) = a(ii,j)
end do
end do
end do
end subroutine i_trans
subroutine d_trans(a,at)
implicit none
integer(psb_ipk_) :: nr,nc
real(psb_dpk_) :: a(:,:)
real(psb_dpk_), allocatable, intent(out) :: at(:,:)
integer(psb_ipk_) :: i,j,ib, ii
integer(psb_ipk_), parameter :: nb=32
nr = size(a,1)
nc = size(a,2)
allocate(at(nc,nr))
do i=1,nr,nb
ib=min(nb,nr-i+1)
do ii=i,i+ib-1
do j=1,nc
at(j,ii) = a(ii,j)
end do
end do
end do
end subroutine d_trans
end module psb_realloc_mod
base/modules/psb_s_base_mat_mod.f90
+25 -6
View File
@@ -57,7 +57,9 @@ module psb_s_base_mat_mod
!
! Data management methods: defined here, but (mostly) not implemented.
!
procedure, pass(a) :: csput => psb_s_base_csput
procedure, pass(a) :: csput_a => psb_s_base_csput_a
procedure, pass(a) :: csput_v => psb_s_base_csput_v
generic, public :: csput => csput_a, csput_v
procedure, pass(a) :: csgetrow => psb_s_base_csgetrow
procedure, pass(a) :: csgetblk => psb_s_base_csgetblk
procedure, pass(a) :: get_diag => psb_s_base_get_diag
@@ -112,6 +114,10 @@ module psb_s_base_mat_mod
procedure, pass(a) :: aclsum => psb_s_base_aclsum
end type psb_s_base_sparse_mat
private :: s_base_mat_sync, s_base_mat_is_host, s_base_mat_is_dev, &
& s_base_mat_is_sync, s_base_mat_set_host, s_base_mat_set_dev,&
& s_base_mat_set_sync
!> \namespace psb_base_mod \class psb_s_coo_sparse_mat
!! \extends psb_s_base_mat_mod::psb_s_base_sparse_mat
!!
@@ -151,7 +157,7 @@ module psb_s_base_mat_mod
procedure, pass(a) :: mv_from_coo => psb_s_mv_coo_from_coo
procedure, pass(a) :: mv_to_fmt => psb_s_mv_coo_to_fmt
procedure, pass(a) :: mv_from_fmt => psb_s_mv_coo_from_fmt
procedure, pass(a) :: csput => psb_s_coo_csput
procedure, pass(a) :: csput_a => psb_s_coo_csput_a
procedure, pass(a) :: get_diag => psb_s_coo_get_diag
procedure, pass(a) :: csgetrow => psb_s_coo_csgetrow
procedure, pass(a) :: csgetptn => psb_s_coo_csgetptn
@@ -250,14 +256,27 @@ module psb_s_base_mat_mod
!!
!
interface
subroutine psb_s_base_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
subroutine psb_s_base_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
import :: psb_ipk_, psb_s_base_sparse_mat, psb_spk_
class(psb_s_base_sparse_mat), intent(inout) :: a
real(psb_spk_), intent(in) :: val(:)
integer(psb_ipk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: gtl(:)
end subroutine psb_s_base_csput
end subroutine psb_s_base_csput_a
end interface
interface
subroutine psb_s_base_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
import :: psb_ipk_, psb_s_base_sparse_mat, psb_spk_, psb_s_base_vect_type,&
& psb_i_base_vect_type
class(psb_s_base_sparse_mat), intent(inout) :: a
class(psb_s_base_vect_type), intent(inout) :: val
class(psb_i_base_vect_type), intent(inout) :: ia, ja
integer(psb_ipk_), intent(in) :: nz, imin, imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: gtl(:)
end subroutine psb_s_base_csput_v
end interface
!
@@ -1464,7 +1483,7 @@ module psb_s_base_mat_mod
!!
!
interface
subroutine psb_s_coo_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
subroutine psb_s_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
import :: psb_ipk_, psb_s_coo_sparse_mat, psb_spk_
class(psb_s_coo_sparse_mat), intent(inout) :: a
real(psb_spk_), intent(in) :: val(:)
@@ -1472,7 +1491,7 @@ module psb_s_base_mat_mod
& imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: gtl(:)
end subroutine psb_s_coo_csput
end subroutine psb_s_coo_csput_a
end interface
!>
base/modules/psb_s_base_vect_mod.f90
+1135 -4
View File
File diff suppressed because it is too large Load Diff
base/modules/psb_s_csc_mat_mod.f90
+4 -4
View File
@@ -88,7 +88,7 @@ module psb_s_csc_mat_mod
procedure, pass(a) :: mv_from_coo => psb_s_mv_csc_from_coo
procedure, pass(a) :: mv_to_fmt => psb_s_mv_csc_to_fmt
procedure, pass(a) :: mv_from_fmt => psb_s_mv_csc_from_fmt
procedure, pass(a) :: csput => psb_s_csc_csput
procedure, pass(a) :: csput_a => psb_s_csc_csput_a
procedure, pass(a) :: get_diag => psb_s_csc_get_diag
procedure, pass(a) :: csgetptn => psb_s_csc_csgetptn
procedure, pass(a) :: csgetrow => psb_s_csc_csgetrow
@@ -279,9 +279,9 @@ module psb_s_csc_mat_mod
!> \memberof psb_s_csc_sparse_mat
!! \see psb_s_base_mat_mod::psb_s_base_csput
!! \see psb_s_base_mat_mod::psb_s_base_csput_a
interface
subroutine psb_s_csc_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
subroutine psb_s_csc_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
import :: psb_ipk_, psb_s_csc_sparse_mat, psb_spk_
class(psb_s_csc_sparse_mat), intent(inout) :: a
real(psb_spk_), intent(in) :: val(:)
@@ -289,7 +289,7 @@ module psb_s_csc_mat_mod
& imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: gtl(:)
end subroutine psb_s_csc_csput
end subroutine psb_s_csc_csput_a
end interface
!> \memberof psb_s_csc_sparse_mat
base/modules/psb_s_csr_mat_mod.f90
+4 -4
View File
@@ -89,7 +89,7 @@ module psb_s_csr_mat_mod
procedure, pass(a) :: mv_from_coo => psb_s_mv_csr_from_coo
procedure, pass(a) :: mv_to_fmt => psb_s_mv_csr_to_fmt
procedure, pass(a) :: mv_from_fmt => psb_s_mv_csr_from_fmt
procedure, pass(a) :: csput => psb_s_csr_csput
procedure, pass(a) :: csput_a => psb_s_csr_csput_a
procedure, pass(a) :: get_diag => psb_s_csr_get_diag
procedure, pass(a) :: csgetptn => psb_s_csr_csgetptn
procedure, pass(a) :: csgetrow => psb_s_csr_csgetrow
@@ -282,9 +282,9 @@ module psb_s_csr_mat_mod
!> \memberof psb_s_csr_sparse_mat
!! \see psb_s_base_mat_mod::psb_s_base_csput
!! \see psb_s_base_mat_mod::psb_s_base_csput_a
interface
subroutine psb_s_csr_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
subroutine psb_s_csr_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
import :: psb_ipk_, psb_s_csr_sparse_mat, psb_spk_
class(psb_s_csr_sparse_mat), intent(inout) :: a
real(psb_spk_), intent(in) :: val(:)
@@ -292,7 +292,7 @@ module psb_s_csr_mat_mod
& imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: gtl(:)
end subroutine psb_s_csr_csput
end subroutine psb_s_csr_csput_a
end interface
!> \memberof psb_s_csr_sparse_mat
base/modules/psb_s_mat_mod.f90
+56 -3
View File
@@ -98,6 +98,7 @@ module psb_s_mat_mod
procedure, pass(a) :: is_lower => psb_s_is_lower
procedure, pass(a) :: is_triangle => psb_s_is_triangle
procedure, pass(a) :: is_unit => psb_s_is_unit
procedure, pass(a) :: is_repeatable_updates => psb_s_is_repeatable_updates
procedure, pass(a) :: get_fmt => psb_s_get_fmt
procedure, pass(a) :: sizeof => psb_s_sizeof
@@ -114,12 +115,15 @@ module psb_s_mat_mod
procedure, pass(a) :: set_lower => psb_s_set_lower
procedure, pass(a) :: set_triangle => psb_s_set_triangle
procedure, pass(a) :: set_unit => psb_s_set_unit
procedure, pass(a) :: set_repeatable_updates => psb_s_set_repeatable_updates
! Memory/data management
procedure, pass(a) :: csall => psb_s_csall
procedure, pass(a) :: free => psb_s_free
procedure, pass(a) :: trim => psb_s_trim
procedure, pass(a) :: csput => psb_s_csput
procedure, pass(a) :: csput_a => psb_s_csput_a
procedure, pass(a) :: csput_v => psb_s_csput_v
generic, public :: csput => csput_a, csput_v
procedure, pass(a) :: csgetptn => psb_s_csgetptn
procedure, pass(a) :: csgetrow => psb_s_csgetrow
procedure, pass(a) :: csgetblk => psb_s_csgetblk
@@ -136,6 +140,7 @@ module psb_s_mat_mod
procedure, pass(a) :: print_n => psb_s_n_sparse_print
generic, public :: print => print_i, print_n
procedure, pass(a) :: mold => psb_s_mold
procedure, pass(a) :: asb => psb_s_asb
procedure, pass(a) :: transp_1mat => psb_s_transp_1mat
procedure, pass(a) :: transp_2mat => psb_s_transp_2mat
generic, public :: transp => transp_1mat, transp_2mat
@@ -378,16 +383,31 @@ module psb_s_mat_mod
end interface
interface
subroutine psb_s_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
subroutine psb_s_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
import :: psb_ipk_, psb_sspmat_type, psb_spk_
class(psb_sspmat_type), intent(inout) :: a
real(psb_spk_), intent(in) :: val(:)
integer(psb_ipk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: gtl(:)
end subroutine psb_s_csput
end subroutine psb_s_csput_a
end interface
interface
subroutine psb_s_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
use psb_s_vect_mod, only : psb_s_vect_type
use psb_i_vect_mod, only : psb_i_vect_type
import :: psb_ipk_, psb_sspmat_type
class(psb_sspmat_type), intent(inout) :: a
type(psb_s_vect_type), intent(inout) :: val
type(psb_i_vect_type), intent(inout) :: ia, ja
integer(psb_ipk_), intent(in) :: nz, imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: gtl(:)
end subroutine psb_s_csput_v
end interface
interface
subroutine psb_s_csgetptn(imin,imax,a,nz,ia,ja,info,&
& jmin,jmax,iren,append,nzin,rscale,cscale)
@@ -493,6 +513,14 @@ module psb_s_mat_mod
end subroutine psb_s_mold
end interface
interface
subroutine psb_s_asb(a,mold)
import :: psb_ipk_, psb_sspmat_type, psb_s_base_sparse_mat
class(psb_sspmat_type), intent(inout) :: a
class(psb_s_base_sparse_mat), optional, intent(in) :: mold
end subroutine psb_s_asb
end interface
interface
subroutine psb_s_transp_1mat(a)
import :: psb_ipk_, psb_sspmat_type
@@ -1085,6 +1113,31 @@ contains
function psb_s_is_repeatable_updates(a) result(res)
implicit none
class(psb_sspmat_type), intent(in) :: a
logical :: res
if (allocated(a%a)) then
res = a%a%is_repeatable_updates()
else
res = .false.
end if
end function psb_s_is_repeatable_updates
subroutine psb_s_set_repeatable_updates(a,val)
implicit none
class(psb_sspmat_type), intent(inout) :: a
logical, intent(in), optional :: val
if (allocated(a%a)) then
call a%a%set_repeatable_updates(val)
end if
end subroutine psb_s_set_repeatable_updates
function psb_s_get_nzeros(a) result(res)
implicit none
class(psb_sspmat_type), intent(in) :: a
base/modules/psb_s_tools_mod.f90
+28 -1
View File
@@ -31,7 +31,7 @@
!!$
Module psb_s_tools_mod
use psb_desc_mod, only : psb_desc_type, psb_spk_, psb_ipk_
use psb_s_vect_mod, only : psb_s_base_vect_type, psb_s_vect_type
use psb_s_vect_mod, only : psb_s_base_vect_type, psb_s_vect_type, psb_i_vect_type
use psb_s_mat_mod, only : psb_sspmat_type, psb_s_base_sparse_mat
interface psb_geall
@@ -206,6 +206,19 @@ Module psb_s_tools_mod
integer(psb_ipk_), optional, intent(in) :: dupl
logical, intent(in), optional :: local
end subroutine psb_sins_vect
subroutine psb_sins_vect_v(m,irw,val,x,desc_a,info,dupl,local)
import :: psb_desc_type, psb_spk_, psb_ipk_, &
& psb_s_base_vect_type, psb_s_vect_type, psb_i_vect_type, &
& psb_sspmat_type, psb_s_base_sparse_mat
integer(psb_ipk_), intent(in) :: m
type(psb_desc_type), intent(in) :: desc_a
type(psb_s_vect_type), intent(inout) :: x
type(psb_i_vect_type), intent(inout) :: irw
type(psb_s_vect_type), intent(inout) :: val
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: dupl
logical, intent(in), optional :: local
end subroutine psb_sins_vect_v
subroutine psb_sins_vect_r2(m,irw,val,x,desc_a,info,dupl,local)
import :: psb_desc_type, psb_spk_, psb_ipk_, &
& psb_s_base_vect_type, psb_s_vect_type, &
@@ -286,6 +299,20 @@ Module psb_s_tools_mod
logical, intent(in), optional :: rebuild
logical, intent(in), optional :: local
end subroutine psb_sspins
subroutine psb_sspins_v(nz,ia,ja,val,a,desc_a,info,rebuild,local)
use psb_i_vect_mod, only : psb_i_vect_type
import :: psb_desc_type, psb_spk_, psb_ipk_, &
& psb_s_base_vect_type, psb_s_vect_type,&
& psb_sspmat_type, psb_s_base_sparse_mat
type(psb_desc_type), intent(inout) :: desc_a
type(psb_sspmat_type), intent(inout) :: a
integer(psb_ipk_), intent(in) :: nz
type(psb_i_vect_type), intent(inout) :: ia,ja
type(psb_s_vect_type), intent(inout) :: val
integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: rebuild
logical, intent(in), optional :: local
end subroutine psb_sspins_v
subroutine psb_sspins_2desc(nz,ia,ja,val,a,desc_ar,desc_ac,info)
import :: psb_desc_type, psb_spk_, psb_ipk_, &
& psb_s_base_vect_type, psb_s_vect_type, &
base/modules/psb_s_vect_mod.F90
+660 -3
View File
@@ -40,6 +40,7 @@
module psb_s_vect_mod
use psb_s_base_vect_mod
use psb_i_vect_mod
type psb_s_vect_type
class(psb_s_base_vect_type), allocatable :: v
@@ -76,7 +77,9 @@ module psb_s_vect_mod
procedure, pass(y) :: sctb => s_vect_sctb
generic, public :: sct => sctb
procedure, pass(x) :: free => s_vect_free
procedure, pass(x) :: ins => s_vect_ins
procedure, pass(x) :: ins_a => s_vect_ins_a
procedure, pass(x) :: ins_v => s_vect_ins_v
generic, public :: ins => ins_v, ins_a
procedure, pass(x) :: bld_x => s_vect_bld_x
procedure, pass(x) :: bld_n => s_vect_bld_n
generic, public :: bld => bld_x, bld_n
@@ -619,7 +622,7 @@ contains
end subroutine s_vect_free
subroutine s_vect_ins(n,irl,val,dupl,x,info)
subroutine s_vect_ins_a(n,irl,val,dupl,x,info)
use psi_serial_mod
implicit none
class(psb_s_vect_type), intent(inout) :: x
@@ -638,7 +641,28 @@ contains
call x%v%ins(n,irl,val,dupl,info)
end subroutine s_vect_ins
end subroutine s_vect_ins_a
subroutine s_vect_ins_v(n,irl,val,dupl,x,info)
use psi_serial_mod
implicit none
class(psb_s_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n, dupl
class(psb_i_vect_type), intent(inout) :: irl
class(psb_s_vect_type), intent(inout) :: val
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: i
info = 0
if (.not.(allocated(x%v).and.allocated(irl%v).and.allocated(val%v))) then
info = psb_err_invalid_vect_state_
return
end if
call x%v%ins(n,irl%v,val%v,dupl,info)
end subroutine s_vect_ins_v
subroutine s_vect_cnv(x,mold)
@@ -663,3 +687,636 @@ contains
end subroutine s_vect_cnv
end module psb_s_vect_mod
module psb_s_multivect_mod
use psb_s_base_multivect_mod
use psb_const_mod
!private
type psb_s_multivect_type
class(psb_s_base_multivect_type), allocatable :: v
contains
procedure, pass(x) :: get_nrows => s_vect_get_nrows
procedure, pass(x) :: get_ncols => s_vect_get_ncols
procedure, pass(x) :: sizeof => s_vect_sizeof
procedure, pass(x) :: get_fmt => s_vect_get_fmt
!!$ procedure, pass(x) :: dot_v => s_vect_dot_v
!!$ procedure, pass(x) :: dot_a => s_vect_dot_a
!!$ generic, public :: dot => dot_v, dot_a
!!$ procedure, pass(y) :: axpby_v => s_vect_axpby_v
!!$ procedure, pass(y) :: axpby_a => s_vect_axpby_a
!!$ generic, public :: axpby => axpby_v, axpby_a
!!$ procedure, pass(y) :: mlt_v => s_vect_mlt_v
!!$ procedure, pass(y) :: mlt_a => s_vect_mlt_a
!!$ procedure, pass(z) :: mlt_a_2 => s_vect_mlt_a_2
!!$ procedure, pass(z) :: mlt_v_2 => s_vect_mlt_v_2
!!$ procedure, pass(z) :: mlt_va => s_vect_mlt_va
!!$ procedure, pass(z) :: mlt_av => s_vect_mlt_av
!!$ generic, public :: mlt => mlt_v, mlt_a, mlt_a_2,&
!!$ & mlt_v_2, mlt_av, mlt_va
!!$ procedure, pass(x) :: scal => s_vect_scal
!!$ procedure, pass(x) :: nrm2 => s_vect_nrm2
!!$ procedure, pass(x) :: amax => s_vect_amax
!!$ procedure, pass(x) :: asum => s_vect_asum
procedure, pass(x) :: all => s_vect_all
procedure, pass(x) :: reall => s_vect_reall
procedure, pass(x) :: zero => s_vect_zero
procedure, pass(x) :: asb => s_vect_asb
procedure, pass(x) :: sync => s_vect_sync
!!$ procedure, pass(x) :: gthab => s_vect_gthab
!!$ procedure, pass(x) :: gthzv => s_vect_gthzv
!!$ generic, public :: gth => gthab, gthzv
!!$ procedure, pass(y) :: sctb => s_vect_sctb
!!$ generic, public :: sct => sctb
procedure, pass(x) :: free => s_vect_free
procedure, pass(x) :: ins => s_vect_ins
procedure, pass(x) :: bld_x => s_vect_bld_x
procedure, pass(x) :: bld_n => s_vect_bld_n
generic, public :: bld => bld_x, bld_n
procedure, pass(x) :: get_vect => s_vect_get_vect
procedure, pass(x) :: cnv => s_vect_cnv
procedure, pass(x) :: set_scal => s_vect_set_scal
procedure, pass(x) :: set_vect => s_vect_set_vect
generic, public :: set => set_vect, set_scal
procedure, pass(x) :: clone => s_vect_clone
end type psb_s_multivect_type
public :: psb_s_multivect, psb_s_multivect_type,&
& psb_set_multivect_default, psb_get_multivect_default
private
interface psb_s_multivect
module procedure constructor, size_const
end interface
class(psb_s_base_multivect_type), allocatable, target,&
& save, private :: psb_s_base_multivect_default
interface psb_set_multivect_default
module procedure psb_s_set_multivect_default
end interface
interface psb_get_vect_default
module procedure psb_s_get_multivect_default
end interface
contains
subroutine psb_s_set_multivect_default(v)
implicit none
class(psb_s_base_multivect_type), intent(in) :: v
if (allocated(psb_s_base_multivect_default)) then
deallocate(psb_s_base_multivect_default)
end if
allocate(psb_s_base_multivect_default, mold=v)
end subroutine psb_s_set_multivect_default
function psb_s_get_multivect_default(v) result(res)
implicit none
class(psb_s_multivect_type), intent(in) :: v
class(psb_s_base_multivect_type), pointer :: res
res => psb_s_get_base_multivect_default()
end function psb_s_get_multivect_default
function psb_s_get_base_multivect_default() result(res)
implicit none
class(psb_s_base_multivect_type), pointer :: res
if (.not.allocated(psb_s_base_multivect_default)) then
allocate(psb_s_base_multivect_type :: psb_s_base_multivect_default)
end if
res => psb_s_base_multivect_default
end function psb_s_get_base_multivect_default
subroutine s_vect_clone(x,y,info)
implicit none
class(psb_s_multivect_type), intent(inout) :: x
class(psb_s_multivect_type), intent(inout) :: y
integer(psb_ipk_), intent(out) :: info
info = psb_success_
call y%free(info)
if ((info==0).and.allocated(x%v)) then
call y%bld(x%get_vect(),mold=x%v)
end if
end subroutine s_vect_clone
subroutine s_vect_bld_x(x,invect,mold)
real(psb_spk_), intent(in) :: invect(:,:)
class(psb_s_multivect_type), intent(out) :: x
class(psb_s_base_multivect_type), intent(in), optional :: mold
integer(psb_ipk_) :: info
class(psb_s_base_multivect_type), pointer :: mld
if (present(mold)) then
#ifdef HAVE_MOLD
allocate(x%v,stat=info,mold=mold)
#else
call mold%mold(x%v,info)
#endif
else
#ifdef HAVE_MOLD
allocate(x%v,stat=info, mold=psb_s_get_base_multivect_default())
#else
mld = psb_s_get_base_multivect_default()
call mld%mold(x%v,info)
#endif
endif
if (info == psb_success_) call x%v%bld(invect)
end subroutine s_vect_bld_x
subroutine s_vect_bld_n(x,m,n,mold)
integer(psb_ipk_), intent(in) :: m,n
class(psb_s_multivect_type), intent(out) :: x
class(psb_s_base_multivect_type), intent(in), optional :: mold
integer(psb_ipk_) :: info
class(psb_s_base_multivect_type), pointer :: mld
if (present(mold)) then
#ifdef HAVE_MOLD
allocate(x%v,stat=info,mold=mold)
#else
call mold%mold(x%v,info)
#endif
else
#ifdef HAVE_MOLD
allocate(x%v,stat=info, mold=psb_s_get_base_multivect_default())
#else
mld = psb_s_get_base_multivect_default()
call mld%mold(x%v,info)
#endif
endif
if (info == psb_success_) call x%v%bld(m,n)
end subroutine s_vect_bld_n
function s_vect_get_vect(x) result(res)
class(psb_s_multivect_type), intent(inout) :: x
real(psb_spk_), allocatable :: res(:,:)
integer(psb_ipk_) :: info
if (allocated(x%v)) then
res = x%v%get_vect()
end if
end function s_vect_get_vect
subroutine s_vect_set_scal(x,val)
class(psb_s_multivect_type), intent(inout) :: x
real(psb_spk_), intent(in) :: val
integer(psb_ipk_) :: info
if (allocated(x%v)) call x%v%set(val)
end subroutine s_vect_set_scal
subroutine s_vect_set_vect(x,val)
class(psb_s_multivect_type), intent(inout) :: x
real(psb_spk_), intent(in) :: val(:,:)
integer(psb_ipk_) :: info
if (allocated(x%v)) call x%v%set(val)
end subroutine s_vect_set_vect
function constructor(x) result(this)
real(psb_spk_) :: x(:,:)
type(psb_s_multivect_type) :: this
integer(psb_ipk_) :: info
call this%bld(x)
call this%asb(size(x,dim=1,kind=psb_ipk_),size(x,dim=2,kind=psb_ipk_),info)
end function constructor
function size_const(m,n) result(this)
integer(psb_ipk_), intent(in) :: m,n
type(psb_s_multivect_type) :: this
integer(psb_ipk_) :: info
call this%bld(m,n)
call this%asb(m,n,info)
end function size_const
function s_vect_get_nrows(x) result(res)
implicit none
class(psb_s_multivect_type), intent(in) :: x
integer(psb_ipk_) :: res
res = 0
if (allocated(x%v)) res = x%v%get_nrows()
end function s_vect_get_nrows
function s_vect_get_ncols(x) result(res)
implicit none
class(psb_s_multivect_type), intent(in) :: x
integer(psb_ipk_) :: res
res = 0
if (allocated(x%v)) res = x%v%get_ncols()
end function s_vect_get_ncols
function s_vect_sizeof(x) result(res)
implicit none
class(psb_s_multivect_type), intent(in) :: x
integer(psb_long_int_k_) :: res
res = 0
if (allocated(x%v)) res = x%v%sizeof()
end function s_vect_sizeof
function s_vect_get_fmt(x) result(res)
implicit none
class(psb_s_multivect_type), intent(in) :: x
character(len=5) :: res
res = 'NULL'
if (allocated(x%v)) res = x%v%get_fmt()
end function s_vect_get_fmt
!!$ function s_vect_dot_v(n,x,y) result(res)
!!$ implicit none
!!$ class(psb_s_multivect_type), intent(inout) :: x, y
!!$ integer(psb_ipk_), intent(in) :: n
!!$ real(psb_spk_) :: res
!!$
!!$ res = szero
!!$ if (allocated(x%v).and.allocated(y%v)) &
!!$ & res = x%v%dot(n,y%v)
!!$
!!$ end function s_vect_dot_v
!!$
!!$ function s_vect_dot_a(n,x,y) result(res)
!!$ implicit none
!!$ class(psb_s_multivect_type), intent(inout) :: x
!!$ real(psb_spk_), intent(in) :: y(:)
!!$ integer(psb_ipk_), intent(in) :: n
!!$ real(psb_spk_) :: res
!!$
!!$ res = szero
!!$ if (allocated(x%v)) &
!!$ & res = x%v%dot(n,y)
!!$
!!$ end function s_vect_dot_a
!!$
!!$ subroutine s_vect_axpby_v(m,alpha, x, beta, y, info)
!!$ use psi_serial_mod
!!$ implicit none
!!$ integer(psb_ipk_), intent(in) :: m
!!$ class(psb_s_multivect_type), intent(inout) :: x
!!$ class(psb_s_multivect_type), intent(inout) :: y
!!$ real(psb_spk_), intent (in) :: alpha, beta
!!$ integer(psb_ipk_), intent(out) :: info
!!$
!!$ if (allocated(x%v).and.allocated(y%v)) then
!!$ call y%v%axpby(m,alpha,x%v,beta,info)
!!$ else
!!$ info = psb_err_invalid_vect_state_
!!$ end if
!!$
!!$ end subroutine s_vect_axpby_v
!!$
!!$ subroutine s_vect_axpby_a(m,alpha, x, beta, y, info)
!!$ use psi_serial_mod
!!$ implicit none
!!$ integer(psb_ipk_), intent(in) :: m
!!$ real(psb_spk_), intent(in) :: x(:)
!!$ class(psb_s_multivect_type), intent(inout) :: y
!!$ real(psb_spk_), intent (in) :: alpha, beta
!!$ integer(psb_ipk_), intent(out) :: info
!!$
!!$ if (allocated(y%v)) &
!!$ & call y%v%axpby(m,alpha,x,beta,info)
!!$
!!$ end subroutine s_vect_axpby_a
!!$
!!$
!!$ subroutine s_vect_mlt_v(x, y, info)
!!$ use psi_serial_mod
!!$ implicit none
!!$ class(psb_s_multivect_type), intent(inout) :: x
!!$ class(psb_s_multivect_type), intent(inout) :: y
!!$ integer(psb_ipk_), intent(out) :: info
!!$ integer(psb_ipk_) :: i, n
!!$
!!$ info = 0
!!$ if (allocated(x%v).and.allocated(y%v)) &
!!$ & call y%v%mlt(x%v,info)
!!$
!!$ end subroutine s_vect_mlt_v
!!$
!!$ subroutine s_vect_mlt_a(x, y, info)
!!$ use psi_serial_mod
!!$ implicit none
!!$ real(psb_spk_), intent(in) :: x(:)
!!$ class(psb_s_multivect_type), intent(inout) :: y
!!$ integer(psb_ipk_), intent(out) :: info
!!$ integer(psb_ipk_) :: i, n
!!$
!!$
!!$ info = 0
!!$ if (allocated(y%v)) &
!!$ & call y%v%mlt(x,info)
!!$
!!$ end subroutine s_vect_mlt_a
!!$
!!$
!!$ subroutine s_vect_mlt_a_2(alpha,x,y,beta,z,info)
!!$ use psi_serial_mod
!!$ implicit none
!!$ real(psb_spk_), intent(in) :: alpha,beta
!!$ real(psb_spk_), intent(in) :: y(:)
!!$ real(psb_spk_), intent(in) :: x(:)
!!$ class(psb_s_multivect_type), intent(inout) :: z
!!$ integer(psb_ipk_), intent(out) :: info
!!$ integer(psb_ipk_) :: i, n
!!$
!!$ info = 0
!!$ if (allocated(z%v)) &
!!$ & call z%v%mlt(alpha,x,y,beta,info)
!!$
!!$ end subroutine s_vect_mlt_a_2
!!$
!!$ subroutine s_vect_mlt_v_2(alpha,x,y,beta,z,info,conjgx,conjgy)
!!$ use psi_serial_mod
!!$ implicit none
!!$ real(psb_spk_), intent(in) :: alpha,beta
!!$ class(psb_s_multivect_type), intent(inout) :: x
!!$ class(psb_s_multivect_type), intent(inout) :: y
!!$ class(psb_s_multivect_type), intent(inout) :: z
!!$ integer(psb_ipk_), intent(out) :: info
!!$ character(len=1), intent(in), optional :: conjgx, conjgy
!!$
!!$ integer(psb_ipk_) :: i, n
!!$
!!$ info = 0
!!$ if (allocated(x%v).and.allocated(y%v).and.&
!!$ & allocated(z%v)) &
!!$ & call z%v%mlt(alpha,x%v,y%v,beta,info,conjgx,conjgy)
!!$
!!$ end subroutine s_vect_mlt_v_2
!!$
!!$ subroutine s_vect_mlt_av(alpha,x,y,beta,z,info)
!!$ use psi_serial_mod
!!$ implicit none
!!$ real(psb_spk_), intent(in) :: alpha,beta
!!$ real(psb_spk_), intent(in) :: x(:)
!!$ class(psb_s_multivect_type), intent(inout) :: y
!!$ class(psb_s_multivect_type), intent(inout) :: z
!!$ integer(psb_ipk_), intent(out) :: info
!!$ integer(psb_ipk_) :: i, n
!!$
!!$ info = 0
!!$ if (allocated(z%v).and.allocated(y%v)) &
!!$ & call z%v%mlt(alpha,x,y%v,beta,info)
!!$
!!$ end subroutine s_vect_mlt_av
!!$
!!$ subroutine s_vect_mlt_va(alpha,x,y,beta,z,info)
!!$ use psi_serial_mod
!!$ implicit none
!!$ real(psb_spk_), intent(in) :: alpha,beta
!!$ real(psb_spk_), intent(in) :: y(:)
!!$ class(psb_s_multivect_type), intent(inout) :: x
!!$ class(psb_s_multivect_type), intent(inout) :: z
!!$ integer(psb_ipk_), intent(out) :: info
!!$ integer(psb_ipk_) :: i, n
!!$
!!$ info = 0
!!$
!!$ if (allocated(z%v).and.allocated(x%v)) &
!!$ & call z%v%mlt(alpha,x%v,y,beta,info)
!!$
!!$ end subroutine s_vect_mlt_va
!!$
!!$ subroutine s_vect_scal(alpha, x)
!!$ use psi_serial_mod
!!$ implicit none
!!$ class(psb_s_multivect_type), intent(inout) :: x
!!$ real(psb_spk_), intent (in) :: alpha
!!$
!!$ if (allocated(x%v)) call x%v%scal(alpha)
!!$
!!$ end subroutine s_vect_scal
!!$
!!$
!!$ function s_vect_nrm2(n,x) result(res)
!!$ implicit none
!!$ class(psb_s_multivect_type), intent(inout) :: x
!!$ integer(psb_ipk_), intent(in) :: n
!!$ real(psb_spk_) :: res
!!$
!!$ if (allocated(x%v)) then
!!$ res = x%v%nrm2(n)
!!$ else
!!$ res = szero
!!$ end if
!!$
!!$ end function s_vect_nrm2
!!$
!!$ function s_vect_amax(n,x) result(res)
!!$ implicit none
!!$ class(psb_s_multivect_type), intent(inout) :: x
!!$ integer(psb_ipk_), intent(in) :: n
!!$ real(psb_spk_) :: res
!!$
!!$ if (allocated(x%v)) then
!!$ res = x%v%amax(n)
!!$ else
!!$ res = szero
!!$ end if
!!$
!!$ end function s_vect_amax
!!$
!!$ function s_vect_asum(n,x) result(res)
!!$ implicit none
!!$ class(psb_s_multivect_type), intent(inout) :: x
!!$ integer(psb_ipk_), intent(in) :: n
!!$ real(psb_spk_) :: res
!!$
!!$ if (allocated(x%v)) then
!!$ res = x%v%asum(n)
!!$ else
!!$ res = szero
!!$ end if
!!$
!!$ end function s_vect_asum
subroutine s_vect_all(m,n, x, info, mold)
implicit none
integer(psb_ipk_), intent(in) :: m,n
class(psb_s_multivect_type), intent(out) :: x
class(psb_s_base_multivect_type), intent(in), optional :: mold
integer(psb_ipk_), intent(out) :: info
if (present(mold)) then
#ifdef HAVE_MOLD
allocate(x%v,stat=info,mold=mold)
#else
call mold%mold(x%v,info)
#endif
else
allocate(psb_s_base_multivect_type :: x%v,stat=info)
endif
if (info == 0) then
call x%v%all(m,n,info)
else
info = psb_err_alloc_dealloc_
end if
end subroutine s_vect_all
subroutine s_vect_reall(m,n, x, info)
implicit none
integer(psb_ipk_), intent(in) :: m,n
class(psb_s_multivect_type), intent(inout) :: x
integer(psb_ipk_), intent(out) :: info
info = 0
if (.not.allocated(x%v)) &
& call x%all(m,n,info)
if (info == 0) &
& call x%asb(m,n,info)
end subroutine s_vect_reall
subroutine s_vect_zero(x)
use psi_serial_mod
implicit none
class(psb_s_multivect_type), intent(inout) :: x
if (allocated(x%v)) call x%v%zero()
end subroutine s_vect_zero
subroutine s_vect_asb(m,n, x, info)
use psi_serial_mod
use psb_realloc_mod
implicit none
integer(psb_ipk_), intent(in) :: m,n
class(psb_s_multivect_type), intent(inout) :: x
integer(psb_ipk_), intent(out) :: info
if (allocated(x%v)) &
& call x%v%asb(m,n,info)
end subroutine s_vect_asb
subroutine s_vect_sync(x)
implicit none
class(psb_s_multivect_type), intent(inout) :: x
if (allocated(x%v)) &
& call x%v%sync()
end subroutine s_vect_sync
!!$ subroutine s_vect_gthab(n,idx,alpha,x,beta,y)
!!$ use psi_serial_mod
!!$ integer(psb_ipk_) :: n, idx(:)
!!$ real(psb_spk_) :: alpha, beta, y(:)
!!$ class(psb_s_multivect_type) :: x
!!$
!!$ if (allocated(x%v)) &
!!$ & call x%v%gth(n,idx,alpha,beta,y)
!!$
!!$ end subroutine s_vect_gthab
!!$
!!$ subroutine s_vect_gthzv(n,idx,x,y)
!!$ use psi_serial_mod
!!$ integer(psb_ipk_) :: n, idx(:)
!!$ real(psb_spk_) :: y(:)
!!$ class(psb_s_multivect_type) :: x
!!$
!!$ if (allocated(x%v)) &
!!$ & call x%v%gth(n,idx,y)
!!$
!!$ end subroutine s_vect_gthzv
!!$
!!$ subroutine s_vect_sctb(n,idx,x,beta,y)
!!$ use psi_serial_mod
!!$ integer(psb_ipk_) :: n, idx(:)
!!$ real(psb_spk_) :: beta, x(:)
!!$ class(psb_s_multivect_type) :: y
!!$
!!$ if (allocated(y%v)) &
!!$ & call y%v%sct(n,idx,x,beta)
!!$
!!$ end subroutine s_vect_sctb
subroutine s_vect_free(x, info)
use psi_serial_mod
use psb_realloc_mod
implicit none
class(psb_s_multivect_type), intent(inout) :: x
integer(psb_ipk_), intent(out) :: info
info = 0
if (allocated(x%v)) then
call x%v%free(info)
if (info == 0) deallocate(x%v,stat=info)
end if
end subroutine s_vect_free
subroutine s_vect_ins(n,irl,val,dupl,x,info)
use psi_serial_mod
implicit none
class(psb_s_multivect_type), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n, dupl
integer(psb_ipk_), intent(in) :: irl(:)
real(psb_spk_), intent(in) :: val(:,:)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: i
info = 0
if (.not.allocated(x%v)) then
info = psb_err_invalid_vect_state_
return
end if
call x%v%ins(n,irl,val,dupl,info)
end subroutine s_vect_ins
subroutine s_vect_cnv(x,mold)
class(psb_s_multivect_type), intent(inout) :: x
class(psb_s_base_multivect_type), intent(in), optional :: mold
class(psb_s_base_multivect_type), allocatable :: tmp
integer(psb_ipk_) :: info
if (present(mold)) then
#ifdef HAVE_MOLD
allocate(tmp,stat=info,mold=mold)
#else
call mold%mold(tmp,info)
#endif
if (allocated(x%v)) then
call x%v%sync()
if (info == psb_success_) call tmp%bld(x%v%v)
call x%v%free(info)
end if
call move_alloc(tmp,x%v)
end if
end subroutine s_vect_cnv
end module psb_s_multivect_mod
base/modules/psb_sort_mod.f90
+3 -3
View File
@@ -90,7 +90,7 @@ module psb_sort_mod
function psb_iblsrch(key,n,v) result(ipos)
import :: psb_ipk_
integer(psb_ipk_) :: ipos, key, n
integer(psb_ipk_) :: v(n)
integer(psb_ipk_) :: v(:)
end function psb_iblsrch
end interface
@@ -98,7 +98,7 @@ module psb_sort_mod
function psb_ibsrch(key,n,v) result(ipos)
import :: psb_ipk_
integer(psb_ipk_) :: ipos, key, n
integer(psb_ipk_) :: v(n)
integer(psb_ipk_) :: v(:)
end function psb_ibsrch
end interface
@@ -107,7 +107,7 @@ module psb_sort_mod
import :: psb_ipk_
implicit none
integer(psb_ipk_) :: ipos, key, n
integer(psb_ipk_) :: v(n)
integer(psb_ipk_) :: v(:)
end function psb_issrch
end interface
base/modules/psb_vect_mod.f90
+5
View File
@@ -4,4 +4,9 @@ module psb_vect_mod
use psb_d_vect_mod
use psb_c_vect_mod
use psb_z_vect_mod
use psb_i_multivect_mod
use psb_s_multivect_mod
use psb_d_multivect_mod
use psb_c_multivect_mod
use psb_z_multivect_mod
end module psb_vect_mod
base/modules/psb_z_base_mat_mod.f90
+25 -6
View File
@@ -57,7 +57,9 @@ module psb_z_base_mat_mod
!
! Data management methods: defined here, but (mostly) not implemented.
!
procedure, pass(a) :: csput => psb_z_base_csput
procedure, pass(a) :: csput_a => psb_z_base_csput_a
procedure, pass(a) :: csput_v => psb_z_base_csput_v
generic, public :: csput => csput_a, csput_v
procedure, pass(a) :: csgetrow => psb_z_base_csgetrow
procedure, pass(a) :: csgetblk => psb_z_base_csgetblk
procedure, pass(a) :: get_diag => psb_z_base_get_diag
@@ -112,6 +114,10 @@ module psb_z_base_mat_mod
procedure, pass(a) :: aclsum => psb_z_base_aclsum
end type psb_z_base_sparse_mat
private :: z_base_mat_sync, z_base_mat_is_host, z_base_mat_is_dev, &
& z_base_mat_is_sync, z_base_mat_set_host, z_base_mat_set_dev,&
& z_base_mat_set_sync
!> \namespace psb_base_mod \class psb_z_coo_sparse_mat
!! \extends psb_z_base_mat_mod::psb_z_base_sparse_mat
!!
@@ -151,7 +157,7 @@ module psb_z_base_mat_mod
procedure, pass(a) :: mv_from_coo => psb_z_mv_coo_from_coo
procedure, pass(a) :: mv_to_fmt => psb_z_mv_coo_to_fmt
procedure, pass(a) :: mv_from_fmt => psb_z_mv_coo_from_fmt
procedure, pass(a) :: csput => psb_z_coo_csput
procedure, pass(a) :: csput_a => psb_z_coo_csput_a
procedure, pass(a) :: get_diag => psb_z_coo_get_diag
procedure, pass(a) :: csgetrow => psb_z_coo_csgetrow
procedure, pass(a) :: csgetptn => psb_z_coo_csgetptn
@@ -250,14 +256,27 @@ module psb_z_base_mat_mod
!!
!
interface
subroutine psb_z_base_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
subroutine psb_z_base_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
import :: psb_ipk_, psb_z_base_sparse_mat, psb_dpk_
class(psb_z_base_sparse_mat), intent(inout) :: a
complex(psb_dpk_), intent(in) :: val(:)
integer(psb_ipk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: gtl(:)
end subroutine psb_z_base_csput
end subroutine psb_z_base_csput_a
end interface
interface
subroutine psb_z_base_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
import :: psb_ipk_, psb_z_base_sparse_mat, psb_dpk_, psb_z_base_vect_type,&
& psb_i_base_vect_type
class(psb_z_base_sparse_mat), intent(inout) :: a
class(psb_z_base_vect_type), intent(inout) :: val
class(psb_i_base_vect_type), intent(inout) :: ia, ja
integer(psb_ipk_), intent(in) :: nz, imin, imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: gtl(:)
end subroutine psb_z_base_csput_v
end interface
!
@@ -1464,7 +1483,7 @@ module psb_z_base_mat_mod
!!
!
interface
subroutine psb_z_coo_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
subroutine psb_z_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
import :: psb_ipk_, psb_z_coo_sparse_mat, psb_dpk_
class(psb_z_coo_sparse_mat), intent(inout) :: a
complex(psb_dpk_), intent(in) :: val(:)
@@ -1472,7 +1491,7 @@ module psb_z_base_mat_mod
& imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: gtl(:)
end subroutine psb_z_coo_csput
end subroutine psb_z_coo_csput_a
end interface
!>
base/modules/psb_z_base_vect_mod.f90
+1135 -4
View File
File diff suppressed because it is too large Load Diff
base/modules/psb_z_csc_mat_mod.f90
+4 -4
View File
@@ -88,7 +88,7 @@ module psb_z_csc_mat_mod
procedure, pass(a) :: mv_from_coo => psb_z_mv_csc_from_coo
procedure, pass(a) :: mv_to_fmt => psb_z_mv_csc_to_fmt
procedure, pass(a) :: mv_from_fmt => psb_z_mv_csc_from_fmt
procedure, pass(a) :: csput => psb_z_csc_csput
procedure, pass(a) :: csput_a => psb_z_csc_csput_a
procedure, pass(a) :: get_diag => psb_z_csc_get_diag
procedure, pass(a) :: csgetptn => psb_z_csc_csgetptn
procedure, pass(a) :: csgetrow => psb_z_csc_csgetrow
@@ -279,9 +279,9 @@ module psb_z_csc_mat_mod
!> \memberof psb_z_csc_sparse_mat
!! \see psb_z_base_mat_mod::psb_z_base_csput
!! \see psb_z_base_mat_mod::psb_z_base_csput_a
interface
subroutine psb_z_csc_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
subroutine psb_z_csc_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
import :: psb_ipk_, psb_z_csc_sparse_mat, psb_dpk_
class(psb_z_csc_sparse_mat), intent(inout) :: a
complex(psb_dpk_), intent(in) :: val(:)
@@ -289,7 +289,7 @@ module psb_z_csc_mat_mod
& imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: gtl(:)
end subroutine psb_z_csc_csput
end subroutine psb_z_csc_csput_a
end interface
!> \memberof psb_z_csc_sparse_mat
base/modules/psb_z_csr_mat_mod.f90
+4 -4
View File
@@ -89,7 +89,7 @@ module psb_z_csr_mat_mod
procedure, pass(a) :: mv_from_coo => psb_z_mv_csr_from_coo
procedure, pass(a) :: mv_to_fmt => psb_z_mv_csr_to_fmt
procedure, pass(a) :: mv_from_fmt => psb_z_mv_csr_from_fmt
procedure, pass(a) :: csput => psb_z_csr_csput
procedure, pass(a) :: csput_a => psb_z_csr_csput_a
procedure, pass(a) :: get_diag => psb_z_csr_get_diag
procedure, pass(a) :: csgetptn => psb_z_csr_csgetptn
procedure, pass(a) :: csgetrow => psb_z_csr_csgetrow
@@ -282,9 +282,9 @@ module psb_z_csr_mat_mod
!> \memberof psb_z_csr_sparse_mat
!! \see psb_z_base_mat_mod::psb_z_base_csput
!! \see psb_z_base_mat_mod::psb_z_base_csput_a
interface
subroutine psb_z_csr_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
subroutine psb_z_csr_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
import :: psb_ipk_, psb_z_csr_sparse_mat, psb_dpk_
class(psb_z_csr_sparse_mat), intent(inout) :: a
complex(psb_dpk_), intent(in) :: val(:)
@@ -292,7 +292,7 @@ module psb_z_csr_mat_mod
& imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: gtl(:)
end subroutine psb_z_csr_csput
end subroutine psb_z_csr_csput_a
end interface
!> \memberof psb_z_csr_sparse_mat
base/modules/psb_z_mat_mod.f90
+56 -3
View File
@@ -98,6 +98,7 @@ module psb_z_mat_mod
procedure, pass(a) :: is_lower => psb_z_is_lower
procedure, pass(a) :: is_triangle => psb_z_is_triangle
procedure, pass(a) :: is_unit => psb_z_is_unit
procedure, pass(a) :: is_repeatable_updates => psb_z_is_repeatable_updates
procedure, pass(a) :: get_fmt => psb_z_get_fmt
procedure, pass(a) :: sizeof => psb_z_sizeof
@@ -114,12 +115,15 @@ module psb_z_mat_mod
procedure, pass(a) :: set_lower => psb_z_set_lower
procedure, pass(a) :: set_triangle => psb_z_set_triangle
procedure, pass(a) :: set_unit => psb_z_set_unit
procedure, pass(a) :: set_repeatable_updates => psb_z_set_repeatable_updates
! Memory/data management
procedure, pass(a) :: csall => psb_z_csall
procedure, pass(a) :: free => psb_z_free
procedure, pass(a) :: trim => psb_z_trim
procedure, pass(a) :: csput => psb_z_csput
procedure, pass(a) :: csput_a => psb_z_csput_a
procedure, pass(a) :: csput_v => psb_z_csput_v
generic, public :: csput => csput_a, csput_v
procedure, pass(a) :: csgetptn => psb_z_csgetptn
procedure, pass(a) :: csgetrow => psb_z_csgetrow
procedure, pass(a) :: csgetblk => psb_z_csgetblk
@@ -136,6 +140,7 @@ module psb_z_mat_mod
procedure, pass(a) :: print_n => psb_z_n_sparse_print
generic, public :: print => print_i, print_n
procedure, pass(a) :: mold => psb_z_mold
procedure, pass(a) :: asb => psb_z_asb
procedure, pass(a) :: transp_1mat => psb_z_transp_1mat
procedure, pass(a) :: transp_2mat => psb_z_transp_2mat
generic, public :: transp => transp_1mat, transp_2mat
@@ -378,16 +383,31 @@ module psb_z_mat_mod
end interface
interface
subroutine psb_z_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
subroutine psb_z_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
import :: psb_ipk_, psb_zspmat_type, psb_dpk_
class(psb_zspmat_type), intent(inout) :: a
complex(psb_dpk_), intent(in) :: val(:)
integer(psb_ipk_), intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: gtl(:)
end subroutine psb_z_csput
end subroutine psb_z_csput_a
end interface
interface
subroutine psb_z_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
use psb_z_vect_mod, only : psb_z_vect_type
use psb_i_vect_mod, only : psb_i_vect_type
import :: psb_ipk_, psb_zspmat_type
class(psb_zspmat_type), intent(inout) :: a
type(psb_z_vect_type), intent(inout) :: val
type(psb_i_vect_type), intent(inout) :: ia, ja
integer(psb_ipk_), intent(in) :: nz, imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: gtl(:)
end subroutine psb_z_csput_v
end interface
interface
subroutine psb_z_csgetptn(imin,imax,a,nz,ia,ja,info,&
& jmin,jmax,iren,append,nzin,rscale,cscale)
@@ -493,6 +513,14 @@ module psb_z_mat_mod
end subroutine psb_z_mold
end interface
interface
subroutine psb_z_asb(a,mold)
import :: psb_ipk_, psb_zspmat_type, psb_z_base_sparse_mat
class(psb_zspmat_type), intent(inout) :: a
class(psb_z_base_sparse_mat), optional, intent(in) :: mold
end subroutine psb_z_asb
end interface
interface
subroutine psb_z_transp_1mat(a)
import :: psb_ipk_, psb_zspmat_type
@@ -1085,6 +1113,31 @@ contains
function psb_z_is_repeatable_updates(a) result(res)
implicit none
class(psb_zspmat_type), intent(in) :: a
logical :: res
if (allocated(a%a)) then
res = a%a%is_repeatable_updates()
else
res = .false.
end if
end function psb_z_is_repeatable_updates
subroutine psb_z_set_repeatable_updates(a,val)
implicit none
class(psb_zspmat_type), intent(inout) :: a
logical, intent(in), optional :: val
if (allocated(a%a)) then
call a%a%set_repeatable_updates(val)
end if
end subroutine psb_z_set_repeatable_updates
function psb_z_get_nzeros(a) result(res)
implicit none
class(psb_zspmat_type), intent(in) :: a
base/modules/psb_z_tools_mod.f90
+28 -1
View File
@@ -31,7 +31,7 @@
!!$
Module psb_z_tools_mod
use psb_desc_mod, only : psb_desc_type, psb_dpk_, psb_ipk_
use psb_z_vect_mod, only : psb_z_base_vect_type, psb_z_vect_type
use psb_z_vect_mod, only : psb_z_base_vect_type, psb_z_vect_type, psb_i_vect_type
use psb_z_mat_mod, only : psb_zspmat_type, psb_z_base_sparse_mat
interface psb_geall
@@ -206,6 +206,19 @@ Module psb_z_tools_mod
integer(psb_ipk_), optional, intent(in) :: dupl
logical, intent(in), optional :: local
end subroutine psb_zins_vect
subroutine psb_zins_vect_v(m,irw,val,x,desc_a,info,dupl,local)
import :: psb_desc_type, psb_dpk_, psb_ipk_, &
& psb_z_base_vect_type, psb_z_vect_type, psb_i_vect_type, &
& psb_zspmat_type, psb_z_base_sparse_mat
integer(psb_ipk_), intent(in) :: m
type(psb_desc_type), intent(in) :: desc_a
type(psb_z_vect_type), intent(inout) :: x
type(psb_i_vect_type), intent(inout) :: irw
type(psb_z_vect_type), intent(inout) :: val
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: dupl
logical, intent(in), optional :: local
end subroutine psb_zins_vect_v
subroutine psb_zins_vect_r2(m,irw,val,x,desc_a,info,dupl,local)
import :: psb_desc_type, psb_dpk_, psb_ipk_, &
& psb_z_base_vect_type, psb_z_vect_type, &
@@ -286,6 +299,20 @@ Module psb_z_tools_mod
logical, intent(in), optional :: rebuild
logical, intent(in), optional :: local
end subroutine psb_zspins
subroutine psb_zspins_v(nz,ia,ja,val,a,desc_a,info,rebuild,local)
use psb_i_vect_mod, only : psb_i_vect_type
import :: psb_desc_type, psb_dpk_, psb_ipk_, &
& psb_z_base_vect_type, psb_z_vect_type,&
& psb_zspmat_type, psb_z_base_sparse_mat
type(psb_desc_type), intent(inout) :: desc_a
type(psb_zspmat_type), intent(inout) :: a
integer(psb_ipk_), intent(in) :: nz
type(psb_i_vect_type), intent(inout) :: ia,ja
type(psb_z_vect_type), intent(inout) :: val
integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: rebuild
logical, intent(in), optional :: local
end subroutine psb_zspins_v
subroutine psb_zspins_2desc(nz,ia,ja,val,a,desc_ar,desc_ac,info)
import :: psb_desc_type, psb_dpk_, psb_ipk_, &
& psb_z_base_vect_type, psb_z_vect_type, &
base/modules/psb_z_vect_mod.F90
+660 -3
View File
@@ -40,6 +40,7 @@
module psb_z_vect_mod
use psb_z_base_vect_mod
use psb_i_vect_mod
type psb_z_vect_type
class(psb_z_base_vect_type), allocatable :: v
@@ -76,7 +77,9 @@ module psb_z_vect_mod
procedure, pass(y) :: sctb => z_vect_sctb
generic, public :: sct => sctb
procedure, pass(x) :: free => z_vect_free
procedure, pass(x) :: ins => z_vect_ins
procedure, pass(x) :: ins_a => z_vect_ins_a
procedure, pass(x) :: ins_v => z_vect_ins_v
generic, public :: ins => ins_v, ins_a
procedure, pass(x) :: bld_x => z_vect_bld_x
procedure, pass(x) :: bld_n => z_vect_bld_n
generic, public :: bld => bld_x, bld_n
@@ -619,7 +622,7 @@ contains
end subroutine z_vect_free
subroutine z_vect_ins(n,irl,val,dupl,x,info)
subroutine z_vect_ins_a(n,irl,val,dupl,x,info)
use psi_serial_mod
implicit none
class(psb_z_vect_type), intent(inout) :: x
@@ -638,7 +641,28 @@ contains
call x%v%ins(n,irl,val,dupl,info)
end subroutine z_vect_ins
end subroutine z_vect_ins_a
subroutine z_vect_ins_v(n,irl,val,dupl,x,info)
use psi_serial_mod
implicit none
class(psb_z_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n, dupl
class(psb_i_vect_type), intent(inout) :: irl
class(psb_z_vect_type), intent(inout) :: val
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: i
info = 0
if (.not.(allocated(x%v).and.allocated(irl%v).and.allocated(val%v))) then
info = psb_err_invalid_vect_state_
return
end if
call x%v%ins(n,irl%v,val%v,dupl,info)
end subroutine z_vect_ins_v
subroutine z_vect_cnv(x,mold)
@@ -663,3 +687,636 @@ contains
end subroutine z_vect_cnv
end module psb_z_vect_mod
module psb_z_multivect_mod
use psb_z_base_multivect_mod
use psb_const_mod
!private
type psb_z_multivect_type
class(psb_z_base_multivect_type), allocatable :: v
contains
procedure, pass(x) :: get_nrows => z_vect_get_nrows
procedure, pass(x) :: get_ncols => z_vect_get_ncols
procedure, pass(x) :: sizeof => z_vect_sizeof
procedure, pass(x) :: get_fmt => z_vect_get_fmt
!!$ procedure, pass(x) :: dot_v => z_vect_dot_v
!!$ procedure, pass(x) :: dot_a => z_vect_dot_a
!!$ generic, public :: dot => dot_v, dot_a
!!$ procedure, pass(y) :: axpby_v => z_vect_axpby_v
!!$ procedure, pass(y) :: axpby_a => z_vect_axpby_a
!!$ generic, public :: axpby => axpby_v, axpby_a
!!$ procedure, pass(y) :: mlt_v => z_vect_mlt_v
!!$ procedure, pass(y) :: mlt_a => z_vect_mlt_a
!!$ procedure, pass(z) :: mlt_a_2 => z_vect_mlt_a_2
!!$ procedure, pass(z) :: mlt_v_2 => z_vect_mlt_v_2
!!$ procedure, pass(z) :: mlt_va => z_vect_mlt_va
!!$ procedure, pass(z) :: mlt_av => z_vect_mlt_av
!!$ generic, public :: mlt => mlt_v, mlt_a, mlt_a_2,&
!!$ & mlt_v_2, mlt_av, mlt_va
!!$ procedure, pass(x) :: scal => z_vect_scal
!!$ procedure, pass(x) :: nrm2 => z_vect_nrm2
!!$ procedure, pass(x) :: amax => z_vect_amax
!!$ procedure, pass(x) :: asum => z_vect_asum
procedure, pass(x) :: all => z_vect_all
procedure, pass(x) :: reall => z_vect_reall
procedure, pass(x) :: zero => z_vect_zero
procedure, pass(x) :: asb => z_vect_asb
procedure, pass(x) :: sync => z_vect_sync
!!$ procedure, pass(x) :: gthab => z_vect_gthab
!!$ procedure, pass(x) :: gthzv => z_vect_gthzv
!!$ generic, public :: gth => gthab, gthzv
!!$ procedure, pass(y) :: sctb => z_vect_sctb
!!$ generic, public :: sct => sctb
procedure, pass(x) :: free => z_vect_free
procedure, pass(x) :: ins => z_vect_ins
procedure, pass(x) :: bld_x => z_vect_bld_x
procedure, pass(x) :: bld_n => z_vect_bld_n
generic, public :: bld => bld_x, bld_n
procedure, pass(x) :: get_vect => z_vect_get_vect
procedure, pass(x) :: cnv => z_vect_cnv
procedure, pass(x) :: set_scal => z_vect_set_scal
procedure, pass(x) :: set_vect => z_vect_set_vect
generic, public :: set => set_vect, set_scal
procedure, pass(x) :: clone => z_vect_clone
end type psb_z_multivect_type
public :: psb_z_multivect, psb_z_multivect_type,&
& psb_set_multivect_default, psb_get_multivect_default
private
interface psb_z_multivect
module procedure constructor, size_const
end interface
class(psb_z_base_multivect_type), allocatable, target,&
& save, private :: psb_z_base_multivect_default
interface psb_set_multivect_default
module procedure psb_z_set_multivect_default
end interface
interface psb_get_vect_default
module procedure psb_z_get_multivect_default
end interface
contains
subroutine psb_z_set_multivect_default(v)
implicit none
class(psb_z_base_multivect_type), intent(in) :: v
if (allocated(psb_z_base_multivect_default)) then
deallocate(psb_z_base_multivect_default)
end if
allocate(psb_z_base_multivect_default, mold=v)
end subroutine psb_z_set_multivect_default
function psb_z_get_multivect_default(v) result(res)
implicit none
class(psb_z_multivect_type), intent(in) :: v
class(psb_z_base_multivect_type), pointer :: res
res => psb_z_get_base_multivect_default()
end function psb_z_get_multivect_default
function psb_z_get_base_multivect_default() result(res)
implicit none
class(psb_z_base_multivect_type), pointer :: res
if (.not.allocated(psb_z_base_multivect_default)) then
allocate(psb_z_base_multivect_type :: psb_z_base_multivect_default)
end if
res => psb_z_base_multivect_default
end function psb_z_get_base_multivect_default
subroutine z_vect_clone(x,y,info)
implicit none
class(psb_z_multivect_type), intent(inout) :: x
class(psb_z_multivect_type), intent(inout) :: y
integer(psb_ipk_), intent(out) :: info
info = psb_success_
call y%free(info)
if ((info==0).and.allocated(x%v)) then
call y%bld(x%get_vect(),mold=x%v)
end if
end subroutine z_vect_clone
subroutine z_vect_bld_x(x,invect,mold)
complex(psb_dpk_), intent(in) :: invect(:,:)
class(psb_z_multivect_type), intent(out) :: x
class(psb_z_base_multivect_type), intent(in), optional :: mold
integer(psb_ipk_) :: info
class(psb_z_base_multivect_type), pointer :: mld
if (present(mold)) then
#ifdef HAVE_MOLD
allocate(x%v,stat=info,mold=mold)
#else
call mold%mold(x%v,info)
#endif
else
#ifdef HAVE_MOLD
allocate(x%v,stat=info, mold=psb_z_get_base_multivect_default())
#else
mld = psb_z_get_base_multivect_default()
call mld%mold(x%v,info)
#endif
endif
if (info == psb_success_) call x%v%bld(invect)
end subroutine z_vect_bld_x
subroutine z_vect_bld_n(x,m,n,mold)
integer(psb_ipk_), intent(in) :: m,n
class(psb_z_multivect_type), intent(out) :: x
class(psb_z_base_multivect_type), intent(in), optional :: mold
integer(psb_ipk_) :: info
class(psb_z_base_multivect_type), pointer :: mld
if (present(mold)) then
#ifdef HAVE_MOLD
allocate(x%v,stat=info,mold=mold)
#else
call mold%mold(x%v,info)
#endif
else
#ifdef HAVE_MOLD
allocate(x%v,stat=info, mold=psb_z_get_base_multivect_default())
#else
mld = psb_z_get_base_multivect_default()
call mld%mold(x%v,info)
#endif
endif
if (info == psb_success_) call x%v%bld(m,n)
end subroutine z_vect_bld_n
function z_vect_get_vect(x) result(res)
class(psb_z_multivect_type), intent(inout) :: x
complex(psb_dpk_), allocatable :: res(:,:)
integer(psb_ipk_) :: info
if (allocated(x%v)) then
res = x%v%get_vect()
end if
end function z_vect_get_vect
subroutine z_vect_set_scal(x,val)
class(psb_z_multivect_type), intent(inout) :: x
complex(psb_dpk_), intent(in) :: val
integer(psb_ipk_) :: info
if (allocated(x%v)) call x%v%set(val)
end subroutine z_vect_set_scal
subroutine z_vect_set_vect(x,val)
class(psb_z_multivect_type), intent(inout) :: x
complex(psb_dpk_), intent(in) :: val(:,:)
integer(psb_ipk_) :: info
if (allocated(x%v)) call x%v%set(val)
end subroutine z_vect_set_vect
function constructor(x) result(this)
complex(psb_dpk_) :: x(:,:)
type(psb_z_multivect_type) :: this
integer(psb_ipk_) :: info
call this%bld(x)
call this%asb(size(x,dim=1,kind=psb_ipk_),size(x,dim=2,kind=psb_ipk_),info)
end function constructor
function size_const(m,n) result(this)
integer(psb_ipk_), intent(in) :: m,n
type(psb_z_multivect_type) :: this
integer(psb_ipk_) :: info
call this%bld(m,n)
call this%asb(m,n,info)
end function size_const
function z_vect_get_nrows(x) result(res)
implicit none
class(psb_z_multivect_type), intent(in) :: x
integer(psb_ipk_) :: res
res = 0
if (allocated(x%v)) res = x%v%get_nrows()
end function z_vect_get_nrows
function z_vect_get_ncols(x) result(res)
implicit none
class(psb_z_multivect_type), intent(in) :: x
integer(psb_ipk_) :: res
res = 0
if (allocated(x%v)) res = x%v%get_ncols()
end function z_vect_get_ncols
function z_vect_sizeof(x) result(res)
implicit none
class(psb_z_multivect_type), intent(in) :: x
integer(psb_long_int_k_) :: res
res = 0
if (allocated(x%v)) res = x%v%sizeof()
end function z_vect_sizeof
function z_vect_get_fmt(x) result(res)
implicit none
class(psb_z_multivect_type), intent(in) :: x
character(len=5) :: res
res = 'NULL'
if (allocated(x%v)) res = x%v%get_fmt()
end function z_vect_get_fmt
!!$ function z_vect_dot_v(n,x,y) result(res)
!!$ implicit none
!!$ class(psb_z_multivect_type), intent(inout) :: x, y
!!$ integer(psb_ipk_), intent(in) :: n
!!$ complex(psb_dpk_) :: res
!!$
!!$ res = zzero
!!$ if (allocated(x%v).and.allocated(y%v)) &
!!$ & res = x%v%dot(n,y%v)
!!$
!!$ end function z_vect_dot_v
!!$
!!$ function z_vect_dot_a(n,x,y) result(res)
!!$ implicit none
!!$ class(psb_z_multivect_type), intent(inout) :: x
!!$ complex(psb_dpk_), intent(in) :: y(:)
!!$ integer(psb_ipk_), intent(in) :: n
!!$ complex(psb_dpk_) :: res
!!$
!!$ res = zzero
!!$ if (allocated(x%v)) &
!!$ & res = x%v%dot(n,y)
!!$
!!$ end function z_vect_dot_a
!!$
!!$ subroutine z_vect_axpby_v(m,alpha, x, beta, y, info)
!!$ use psi_serial_mod
!!$ implicit none
!!$ integer(psb_ipk_), intent(in) :: m
!!$ class(psb_z_multivect_type), intent(inout) :: x
!!$ class(psb_z_multivect_type), intent(inout) :: y
!!$ complex(psb_dpk_), intent (in) :: alpha, beta
!!$ integer(psb_ipk_), intent(out) :: info
!!$
!!$ if (allocated(x%v).and.allocated(y%v)) then
!!$ call y%v%axpby(m,alpha,x%v,beta,info)
!!$ else
!!$ info = psb_err_invalid_vect_state_
!!$ end if
!!$
!!$ end subroutine z_vect_axpby_v
!!$
!!$ subroutine z_vect_axpby_a(m,alpha, x, beta, y, info)
!!$ use psi_serial_mod
!!$ implicit none
!!$ integer(psb_ipk_), intent(in) :: m
!!$ complex(psb_dpk_), intent(in) :: x(:)
!!$ class(psb_z_multivect_type), intent(inout) :: y
!!$ complex(psb_dpk_), intent (in) :: alpha, beta
!!$ integer(psb_ipk_), intent(out) :: info
!!$
!!$ if (allocated(y%v)) &
!!$ & call y%v%axpby(m,alpha,x,beta,info)
!!$
!!$ end subroutine z_vect_axpby_a
!!$
!!$
!!$ subroutine z_vect_mlt_v(x, y, info)
!!$ use psi_serial_mod
!!$ implicit none
!!$ class(psb_z_multivect_type), intent(inout) :: x
!!$ class(psb_z_multivect_type), intent(inout) :: y
!!$ integer(psb_ipk_), intent(out) :: info
!!$ integer(psb_ipk_) :: i, n
!!$
!!$ info = 0
!!$ if (allocated(x%v).and.allocated(y%v)) &
!!$ & call y%v%mlt(x%v,info)
!!$
!!$ end subroutine z_vect_mlt_v
!!$
!!$ subroutine z_vect_mlt_a(x, y, info)
!!$ use psi_serial_mod
!!$ implicit none
!!$ complex(psb_dpk_), intent(in) :: x(:)
!!$ class(psb_z_multivect_type), intent(inout) :: y
!!$ integer(psb_ipk_), intent(out) :: info
!!$ integer(psb_ipk_) :: i, n
!!$
!!$
!!$ info = 0
!!$ if (allocated(y%v)) &
!!$ & call y%v%mlt(x,info)
!!$
!!$ end subroutine z_vect_mlt_a
!!$
!!$
!!$ subroutine z_vect_mlt_a_2(alpha,x,y,beta,z,info)
!!$ use psi_serial_mod
!!$ implicit none
!!$ complex(psb_dpk_), intent(in) :: alpha,beta
!!$ complex(psb_dpk_), intent(in) :: y(:)
!!$ complex(psb_dpk_), intent(in) :: x(:)
!!$ class(psb_z_multivect_type), intent(inout) :: z
!!$ integer(psb_ipk_), intent(out) :: info
!!$ integer(psb_ipk_) :: i, n
!!$
!!$ info = 0
!!$ if (allocated(z%v)) &
!!$ & call z%v%mlt(alpha,x,y,beta,info)
!!$
!!$ end subroutine z_vect_mlt_a_2
!!$
!!$ subroutine z_vect_mlt_v_2(alpha,x,y,beta,z,info,conjgx,conjgy)
!!$ use psi_serial_mod
!!$ implicit none
!!$ complex(psb_dpk_), intent(in) :: alpha,beta
!!$ class(psb_z_multivect_type), intent(inout) :: x
!!$ class(psb_z_multivect_type), intent(inout) :: y
!!$ class(psb_z_multivect_type), intent(inout) :: z
!!$ integer(psb_ipk_), intent(out) :: info
!!$ character(len=1), intent(in), optional :: conjgx, conjgy
!!$
!!$ integer(psb_ipk_) :: i, n
!!$
!!$ info = 0
!!$ if (allocated(x%v).and.allocated(y%v).and.&
!!$ & allocated(z%v)) &
!!$ & call z%v%mlt(alpha,x%v,y%v,beta,info,conjgx,conjgy)
!!$
!!$ end subroutine z_vect_mlt_v_2
!!$
!!$ subroutine z_vect_mlt_av(alpha,x,y,beta,z,info)
!!$ use psi_serial_mod
!!$ implicit none
!!$ complex(psb_dpk_), intent(in) :: alpha,beta
!!$ complex(psb_dpk_), intent(in) :: x(:)
!!$ class(psb_z_multivect_type), intent(inout) :: y
!!$ class(psb_z_multivect_type), intent(inout) :: z
!!$ integer(psb_ipk_), intent(out) :: info
!!$ integer(psb_ipk_) :: i, n
!!$
!!$ info = 0
!!$ if (allocated(z%v).and.allocated(y%v)) &
!!$ & call z%v%mlt(alpha,x,y%v,beta,info)
!!$
!!$ end subroutine z_vect_mlt_av
!!$
!!$ subroutine z_vect_mlt_va(alpha,x,y,beta,z,info)
!!$ use psi_serial_mod
!!$ implicit none
!!$ complex(psb_dpk_), intent(in) :: alpha,beta
!!$ complex(psb_dpk_), intent(in) :: y(:)
!!$ class(psb_z_multivect_type), intent(inout) :: x
!!$ class(psb_z_multivect_type), intent(inout) :: z
!!$ integer(psb_ipk_), intent(out) :: info
!!$ integer(psb_ipk_) :: i, n
!!$
!!$ info = 0
!!$
!!$ if (allocated(z%v).and.allocated(x%v)) &
!!$ & call z%v%mlt(alpha,x%v,y,beta,info)
!!$
!!$ end subroutine z_vect_mlt_va
!!$
!!$ subroutine z_vect_scal(alpha, x)
!!$ use psi_serial_mod
!!$ implicit none
!!$ class(psb_z_multivect_type), intent(inout) :: x
!!$ complex(psb_dpk_), intent (in) :: alpha
!!$
!!$ if (allocated(x%v)) call x%v%scal(alpha)
!!$
!!$ end subroutine z_vect_scal
!!$
!!$
!!$ function z_vect_nrm2(n,x) result(res)
!!$ implicit none
!!$ class(psb_z_multivect_type), intent(inout) :: x
!!$ integer(psb_ipk_), intent(in) :: n
!!$ real(psb_dpk_) :: res
!!$
!!$ if (allocated(x%v)) then
!!$ res = x%v%nrm2(n)
!!$ else
!!$ res = dzero
!!$ end if
!!$
!!$ end function z_vect_nrm2
!!$
!!$ function z_vect_amax(n,x) result(res)
!!$ implicit none
!!$ class(psb_z_multivect_type), intent(inout) :: x
!!$ integer(psb_ipk_), intent(in) :: n
!!$ real(psb_dpk_) :: res
!!$
!!$ if (allocated(x%v)) then
!!$ res = x%v%amax(n)
!!$ else
!!$ res = dzero
!!$ end if
!!$
!!$ end function z_vect_amax
!!$
!!$ function z_vect_asum(n,x) result(res)
!!$ implicit none
!!$ class(psb_z_multivect_type), intent(inout) :: x
!!$ integer(psb_ipk_), intent(in) :: n
!!$ real(psb_dpk_) :: res
!!$
!!$ if (allocated(x%v)) then
!!$ res = x%v%asum(n)
!!$ else
!!$ res = dzero
!!$ end if
!!$
!!$ end function z_vect_asum
subroutine z_vect_all(m,n, x, info, mold)
implicit none
integer(psb_ipk_), intent(in) :: m,n
class(psb_z_multivect_type), intent(out) :: x
class(psb_z_base_multivect_type), intent(in), optional :: mold
integer(psb_ipk_), intent(out) :: info
if (present(mold)) then
#ifdef HAVE_MOLD
allocate(x%v,stat=info,mold=mold)
#else
call mold%mold(x%v,info)
#endif
else
allocate(psb_z_base_multivect_type :: x%v,stat=info)
endif
if (info == 0) then
call x%v%all(m,n,info)
else
info = psb_err_alloc_dealloc_
end if
end subroutine z_vect_all
subroutine z_vect_reall(m,n, x, info)
implicit none
integer(psb_ipk_), intent(in) :: m,n
class(psb_z_multivect_type), intent(inout) :: x
integer(psb_ipk_), intent(out) :: info
info = 0
if (.not.allocated(x%v)) &
& call x%all(m,n,info)
if (info == 0) &
& call x%asb(m,n,info)
end subroutine z_vect_reall
subroutine z_vect_zero(x)
use psi_serial_mod
implicit none
class(psb_z_multivect_type), intent(inout) :: x
if (allocated(x%v)) call x%v%zero()
end subroutine z_vect_zero
subroutine z_vect_asb(m,n, x, info)
use psi_serial_mod
use psb_realloc_mod
implicit none
integer(psb_ipk_), intent(in) :: m,n
class(psb_z_multivect_type), intent(inout) :: x
integer(psb_ipk_), intent(out) :: info
if (allocated(x%v)) &
& call x%v%asb(m,n,info)
end subroutine z_vect_asb
subroutine z_vect_sync(x)
implicit none
class(psb_z_multivect_type), intent(inout) :: x
if (allocated(x%v)) &
& call x%v%sync()
end subroutine z_vect_sync
!!$ subroutine z_vect_gthab(n,idx,alpha,x,beta,y)
!!$ use psi_serial_mod
!!$ integer(psb_ipk_) :: n, idx(:)
!!$ complex(psb_dpk_) :: alpha, beta, y(:)
!!$ class(psb_z_multivect_type) :: x
!!$
!!$ if (allocated(x%v)) &
!!$ & call x%v%gth(n,idx,alpha,beta,y)
!!$
!!$ end subroutine z_vect_gthab
!!$
!!$ subroutine z_vect_gthzv(n,idx,x,y)
!!$ use psi_serial_mod
!!$ integer(psb_ipk_) :: n, idx(:)
!!$ complex(psb_dpk_) :: y(:)
!!$ class(psb_z_multivect_type) :: x
!!$
!!$ if (allocated(x%v)) &
!!$ & call x%v%gth(n,idx,y)
!!$
!!$ end subroutine z_vect_gthzv
!!$
!!$ subroutine z_vect_sctb(n,idx,x,beta,y)
!!$ use psi_serial_mod
!!$ integer(psb_ipk_) :: n, idx(:)
!!$ complex(psb_dpk_) :: beta, x(:)
!!$ class(psb_z_multivect_type) :: y
!!$
!!$ if (allocated(y%v)) &
!!$ & call y%v%sct(n,idx,x,beta)
!!$
!!$ end subroutine z_vect_sctb
subroutine z_vect_free(x, info)
use psi_serial_mod
use psb_realloc_mod
implicit none
class(psb_z_multivect_type), intent(inout) :: x
integer(psb_ipk_), intent(out) :: info
info = 0
if (allocated(x%v)) then
call x%v%free(info)
if (info == 0) deallocate(x%v,stat=info)
end if
end subroutine z_vect_free
subroutine z_vect_ins(n,irl,val,dupl,x,info)
use psi_serial_mod
implicit none
class(psb_z_multivect_type), intent(inout) :: x
integer(psb_ipk_), intent(in) :: n, dupl
integer(psb_ipk_), intent(in) :: irl(:)
complex(psb_dpk_), intent(in) :: val(:,:)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: i
info = 0
if (.not.allocated(x%v)) then
info = psb_err_invalid_vect_state_
return
end if
call x%v%ins(n,irl,val,dupl,info)
end subroutine z_vect_ins
subroutine z_vect_cnv(x,mold)
class(psb_z_multivect_type), intent(inout) :: x
class(psb_z_base_multivect_type), intent(in), optional :: mold
class(psb_z_base_multivect_type), allocatable :: tmp
integer(psb_ipk_) :: info
if (present(mold)) then
#ifdef HAVE_MOLD
allocate(tmp,stat=info,mold=mold)
#else
call mold%mold(tmp,info)
#endif
if (allocated(x%v)) then
call x%v%sync()
if (info == psb_success_) call tmp%bld(x%v%v)
call x%v%free(info)
end if
call move_alloc(tmp,x%v)
end if
end subroutine z_vect_cnv
end module psb_z_multivect_mod
base/serial/impl/psb_c_base_mat_impl.F90
+52 -3
View File
@@ -327,9 +327,9 @@ subroutine psb_c_base_mv_from_fmt(a,b,info)
end subroutine psb_c_base_mv_from_fmt
subroutine psb_c_base_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
subroutine psb_c_base_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
use psb_error_mod
use psb_c_base_mat_mod, psb_protect_name => psb_c_base_csput
use psb_c_base_mat_mod, psb_protect_name => psb_c_base_csput_a
implicit none
class(psb_c_base_sparse_mat), intent(inout) :: a
complex(psb_spk_), intent(in) :: val(:)
@@ -354,7 +354,56 @@ subroutine psb_c_base_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
end if
return
end subroutine psb_c_base_csput
end subroutine psb_c_base_csput_a
subroutine psb_c_base_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
use psb_error_mod
use psb_c_base_mat_mod, psb_protect_name => psb_c_base_csput_v
use psb_c_base_vect_mod
implicit none
class(psb_c_base_sparse_mat), intent(inout) :: a
class(psb_c_base_vect_type), intent(inout) :: val
class(psb_i_base_vect_type), intent(inout) :: ia, ja
integer(psb_ipk_), intent(in) :: nz, imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: gtl(:)
integer(psb_ipk_) :: err_act, nzin, nzout
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='csput_v'
integer :: jmin_, jmax_
logical :: append_, rscale_, cscale_
logical, parameter :: debug=.false.
call psb_erractionsave(err_act)
info = psb_success_
if (allocated(val%v).and.allocated(ia%v).and.allocated(ja%v)) then
if (val%is_dev()) call val%sync()
if (ia%is_dev()) call ia%sync()
if (ja%is_dev()) call ja%sync()
call a%csput(nz,ia%v,ja%v,val%v,imin,imax,jmin,jmax,info,gtl)
else
info = psb_err_invalid_mat_state_
endif
if (info /= 0) then
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_c_base_csput_v
subroutine psb_c_base_csgetrow(imin,imax,a,nz,ia,ja,val,info,&
& jmin,jmax,iren,append,nzin,rscale,cscale)
base/serial/impl/psb_c_coo_impl.f90
+4 -4
View File
@@ -2573,11 +2573,11 @@ contains
end subroutine psb_c_coo_csgetrow
subroutine psb_c_coo_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
subroutine psb_c_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
use psb_error_mod
use psb_realloc_mod
use psb_sort_mod
use psb_c_base_mat_mod, psb_protect_name => psb_c_coo_csput
use psb_c_base_mat_mod, psb_protect_name => psb_c_coo_csput_a
implicit none
class(psb_c_coo_sparse_mat), intent(inout) :: a
@@ -2589,7 +2589,7 @@ subroutine psb_c_coo_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='c_coo_csput_impl'
character(len=20) :: name='c_coo_csput_a_impl'
logical, parameter :: debug=.false.
integer(psb_ipk_) :: nza, i,j,k, nzl, isza, debug_level, debug_unit
@@ -2953,7 +2953,7 @@ contains
end subroutine c_coo_srch_upd
end subroutine psb_c_coo_csput
end subroutine psb_c_coo_csput_a
subroutine psb_c_cp_coo_to_coo(a,b,info)
base/serial/impl/psb_c_csc_impl.f90
+4 -4
View File
@@ -1965,10 +1965,10 @@ end subroutine psb_c_csc_csgetrow
subroutine psb_c_csc_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
subroutine psb_c_csc_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
use psb_error_mod
use psb_realloc_mod
use psb_c_csc_mat_mod, psb_protect_name => psb_c_csc_csput
use psb_c_csc_mat_mod, psb_protect_name => psb_c_csc_csput_a
implicit none
class(psb_c_csc_sparse_mat), intent(inout) :: a
@@ -1980,7 +1980,7 @@ subroutine psb_c_csc_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='c_csc_csput'
character(len=20) :: name='c_csc_csput_a'
logical, parameter :: debug=.false.
integer(psb_ipk_) :: nza, i,j,k, nzl, isza, debug_level, debug_unit
@@ -2232,7 +2232,7 @@ contains
end subroutine psb_c_csc_srch_upd
end subroutine psb_c_csc_csput
end subroutine psb_c_csc_csput_a
base/serial/impl/psb_c_csr_impl.f90
+7 -5
View File
@@ -2338,10 +2338,10 @@ end subroutine psb_c_csr_csgetblk
subroutine psb_c_csr_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
subroutine psb_c_csr_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
use psb_error_mod
use psb_realloc_mod
use psb_c_csr_mat_mod, psb_protect_name => psb_c_csr_csput
use psb_c_csr_mat_mod, psb_protect_name => psb_c_csr_csput_a
implicit none
class(psb_c_csr_sparse_mat), intent(inout) :: a
@@ -2353,7 +2353,7 @@ subroutine psb_c_csr_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='c_csr_csput'
character(len=20) :: name='c_csr_csput_a'
logical, parameter :: debug=.false.
integer(psb_ipk_) :: nza, i,j,k, nzl, isza, debug_level, debug_unit
@@ -2604,7 +2604,7 @@ contains
end subroutine psb_c_csr_srch_upd
end subroutine psb_c_csr_csput
end subroutine psb_c_csr_csput_a
subroutine psb_c_csr_reinit(a,clear)
@@ -2788,7 +2788,9 @@ subroutine psb_c_cp_csr_from_coo(a,b,info)
character(len=20) :: name
info = psb_success_
debug_unit = psb_get_debug_unit()
debug_level = psb_get_debug_level()
if (.not.b%is_sorted()) then
! This is to have fix_coo called behind the scenes
call tmp%cp_from_coo(b,info)
base/serial/impl/psb_c_mat_impl.F90
+99 -6
View File
@@ -733,8 +733,8 @@ end subroutine psb_c_trim
subroutine psb_c_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
use psb_c_mat_mod, psb_protect_name => psb_c_csput
subroutine psb_c_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
use psb_c_mat_mod, psb_protect_name => psb_c_csput_a
use psb_c_base_mat_mod
use psb_error_mod
implicit none
@@ -745,7 +745,7 @@ subroutine psb_c_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
integer(psb_ipk_), intent(in), optional :: gtl(:)
integer(psb_ipk_) :: err_act
character(len=20) :: name='csput'
character(len=20) :: name='csput_a'
logical, parameter :: debug=.false.
info = psb_success_
@@ -771,7 +771,54 @@ subroutine psb_c_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
return
end if
end subroutine psb_c_csput
end subroutine psb_c_csput_a
subroutine psb_c_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
use psb_c_mat_mod, psb_protect_name => psb_c_csput_v
use psb_c_base_mat_mod
use psb_c_vect_mod, only : psb_c_vect_type
use psb_i_vect_mod, only : psb_i_vect_type
use psb_error_mod
implicit none
class(psb_cspmat_type), intent(inout) :: a
type(psb_c_vect_type), intent(inout) :: val
type(psb_i_vect_type), intent(inout) :: ia, ja
integer(psb_ipk_), intent(in) :: nz, imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: gtl(:)
integer(psb_ipk_) :: err_act
character(len=20) :: name='csput_v'
logical, parameter :: debug=.false.
info = psb_success_
call psb_erractionsave(err_act)
if (.not.(a%is_bld().or.a%is_upd())) then
info = psb_err_invalid_mat_state_
call psb_errpush(info,name)
goto 9999
endif
if (allocated(val%v).and.allocated(ia%v).and.allocated(ja%v)) then
call a%a%csput(nz,ia%v,ja%v,val%v,imin,imax,jmin,jmax,info,gtl)
else
info = psb_err_invalid_mat_state_
endif
if (info /= psb_success_) goto 9999
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_abort_) then
call psb_error()
return
end if
end subroutine psb_c_csput_v
subroutine psb_c_csgetptn(imin,imax,a,nz,ia,ja,info,&
@@ -1244,8 +1291,8 @@ subroutine psb_c_cscnv(a,b,info,type,mold,upd,dupl)
end if
call move_alloc(altmp,b%a)
call b%set_asb()
call b%trim()
call b%asb()
call psb_erractionrestore(err_act)
return
@@ -1870,7 +1917,47 @@ subroutine psb_c_transc_2mat(a,b)
end subroutine psb_c_transc_2mat
subroutine psb_c_asb(a,mold)
use psb_c_mat_mod, psb_protect_name => psb_c_asb
use psb_error_mod
implicit none
class(psb_cspmat_type), intent(inout) :: a
class(psb_c_base_sparse_mat), optional, intent(in) :: mold
class(psb_c_base_sparse_mat), allocatable :: tmp
integer(psb_ipk_) :: err_act, info
character(len=20) :: name='c_asb'
call psb_erractionsave(err_act)
if (a%is_null()) then
info = psb_err_invalid_mat_state_
call psb_errpush(info,name)
goto 9999
endif
call a%a%asb()
if (present(mold)) then
if (.not.same_type_as(a%a,mold)) then
allocate(tmp,mold=mold)
call tmp%mv_from_fmt(a%a,info)
call a%a%free()
call move_alloc(tmp,a%a)
end if
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
end subroutine psb_c_asb
subroutine psb_c_reinit(a,clear)
use psb_c_mat_mod, psb_protect_name => psb_c_reinit
@@ -1889,7 +1976,13 @@ subroutine psb_c_reinit(a,clear)
goto 9999
endif
call a%a%reinit(clear)
if (a%a%has_update()) then
call a%a%reinit(clear)
else
info = psb_err_missing_override_method_
call psb_errpush(info,name)
goto 9999
endif
call psb_erractionrestore(err_act)
return
base/serial/impl/psb_d_base_mat_impl.F90
+52 -3
View File
@@ -327,9 +327,9 @@ subroutine psb_d_base_mv_from_fmt(a,b,info)
end subroutine psb_d_base_mv_from_fmt
subroutine psb_d_base_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
subroutine psb_d_base_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
use psb_error_mod
use psb_d_base_mat_mod, psb_protect_name => psb_d_base_csput
use psb_d_base_mat_mod, psb_protect_name => psb_d_base_csput_a
implicit none
class(psb_d_base_sparse_mat), intent(inout) :: a
real(psb_dpk_), intent(in) :: val(:)
@@ -354,7 +354,56 @@ subroutine psb_d_base_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
end if
return
end subroutine psb_d_base_csput
end subroutine psb_d_base_csput_a
subroutine psb_d_base_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
use psb_error_mod
use psb_d_base_mat_mod, psb_protect_name => psb_d_base_csput_v
use psb_d_base_vect_mod
implicit none
class(psb_d_base_sparse_mat), intent(inout) :: a
class(psb_d_base_vect_type), intent(inout) :: val
class(psb_i_base_vect_type), intent(inout) :: ia, ja
integer(psb_ipk_), intent(in) :: nz, imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: gtl(:)
integer(psb_ipk_) :: err_act, nzin, nzout
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='csput_v'
integer :: jmin_, jmax_
logical :: append_, rscale_, cscale_
logical, parameter :: debug=.false.
call psb_erractionsave(err_act)
info = psb_success_
if (allocated(val%v).and.allocated(ia%v).and.allocated(ja%v)) then
if (val%is_dev()) call val%sync()
if (ia%is_dev()) call ia%sync()
if (ja%is_dev()) call ja%sync()
call a%csput(nz,ia%v,ja%v,val%v,imin,imax,jmin,jmax,info,gtl)
else
info = psb_err_invalid_mat_state_
endif
if (info /= 0) then
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_base_csput_v
subroutine psb_d_base_csgetrow(imin,imax,a,nz,ia,ja,val,info,&
& jmin,jmax,iren,append,nzin,rscale,cscale)
base/serial/impl/psb_d_coo_impl.f90
+4 -4
View File
@@ -2573,11 +2573,11 @@ contains
end subroutine psb_d_coo_csgetrow
subroutine psb_d_coo_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
subroutine psb_d_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
use psb_error_mod
use psb_realloc_mod
use psb_sort_mod
use psb_d_base_mat_mod, psb_protect_name => psb_d_coo_csput
use psb_d_base_mat_mod, psb_protect_name => psb_d_coo_csput_a
implicit none
class(psb_d_coo_sparse_mat), intent(inout) :: a
@@ -2589,7 +2589,7 @@ subroutine psb_d_coo_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='d_coo_csput_impl'
character(len=20) :: name='d_coo_csput_a_impl'
logical, parameter :: debug=.false.
integer(psb_ipk_) :: nza, i,j,k, nzl, isza, debug_level, debug_unit
@@ -2953,7 +2953,7 @@ contains
end subroutine d_coo_srch_upd
end subroutine psb_d_coo_csput
end subroutine psb_d_coo_csput_a
subroutine psb_d_cp_coo_to_coo(a,b,info)
base/serial/impl/psb_d_csc_impl.f90
+4 -4
View File
@@ -1965,10 +1965,10 @@ end subroutine psb_d_csc_csgetrow
subroutine psb_d_csc_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
subroutine psb_d_csc_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
use psb_error_mod
use psb_realloc_mod
use psb_d_csc_mat_mod, psb_protect_name => psb_d_csc_csput
use psb_d_csc_mat_mod, psb_protect_name => psb_d_csc_csput_a
implicit none
class(psb_d_csc_sparse_mat), intent(inout) :: a
@@ -1980,7 +1980,7 @@ subroutine psb_d_csc_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='d_csc_csput'
character(len=20) :: name='d_csc_csput_a'
logical, parameter :: debug=.false.
integer(psb_ipk_) :: nza, i,j,k, nzl, isza, debug_level, debug_unit
@@ -2232,7 +2232,7 @@ contains
end subroutine psb_d_csc_srch_upd
end subroutine psb_d_csc_csput
end subroutine psb_d_csc_csput_a
base/serial/impl/psb_d_csr_impl.f90
+7 -5
View File
@@ -2338,10 +2338,10 @@ end subroutine psb_d_csr_csgetblk
subroutine psb_d_csr_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
subroutine psb_d_csr_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
use psb_error_mod
use psb_realloc_mod
use psb_d_csr_mat_mod, psb_protect_name => psb_d_csr_csput
use psb_d_csr_mat_mod, psb_protect_name => psb_d_csr_csput_a
implicit none
class(psb_d_csr_sparse_mat), intent(inout) :: a
@@ -2353,7 +2353,7 @@ subroutine psb_d_csr_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='d_csr_csput'
character(len=20) :: name='d_csr_csput_a'
logical, parameter :: debug=.false.
integer(psb_ipk_) :: nza, i,j,k, nzl, isza, debug_level, debug_unit
@@ -2604,7 +2604,7 @@ contains
end subroutine psb_d_csr_srch_upd
end subroutine psb_d_csr_csput
end subroutine psb_d_csr_csput_a
subroutine psb_d_csr_reinit(a,clear)
@@ -2788,7 +2788,9 @@ subroutine psb_d_cp_csr_from_coo(a,b,info)
character(len=20) :: name
info = psb_success_
debug_unit = psb_get_debug_unit()
debug_level = psb_get_debug_level()
if (.not.b%is_sorted()) then
! This is to have fix_coo called behind the scenes
call tmp%cp_from_coo(b,info)
base/serial/impl/psb_d_mat_impl.F90
+99 -6
View File
@@ -733,8 +733,8 @@ end subroutine psb_d_trim
subroutine psb_d_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
use psb_d_mat_mod, psb_protect_name => psb_d_csput
subroutine psb_d_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
use psb_d_mat_mod, psb_protect_name => psb_d_csput_a
use psb_d_base_mat_mod
use psb_error_mod
implicit none
@@ -745,7 +745,7 @@ subroutine psb_d_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
integer(psb_ipk_), intent(in), optional :: gtl(:)
integer(psb_ipk_) :: err_act
character(len=20) :: name='csput'
character(len=20) :: name='csput_a'
logical, parameter :: debug=.false.
info = psb_success_
@@ -771,7 +771,54 @@ subroutine psb_d_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
return
end if
end subroutine psb_d_csput
end subroutine psb_d_csput_a
subroutine psb_d_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
use psb_d_mat_mod, psb_protect_name => psb_d_csput_v
use psb_d_base_mat_mod
use psb_d_vect_mod, only : psb_d_vect_type
use psb_i_vect_mod, only : psb_i_vect_type
use psb_error_mod
implicit none
class(psb_dspmat_type), intent(inout) :: a
type(psb_d_vect_type), intent(inout) :: val
type(psb_i_vect_type), intent(inout) :: ia, ja
integer(psb_ipk_), intent(in) :: nz, imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: gtl(:)
integer(psb_ipk_) :: err_act
character(len=20) :: name='csput_v'
logical, parameter :: debug=.false.
info = psb_success_
call psb_erractionsave(err_act)
if (.not.(a%is_bld().or.a%is_upd())) then
info = psb_err_invalid_mat_state_
call psb_errpush(info,name)
goto 9999
endif
if (allocated(val%v).and.allocated(ia%v).and.allocated(ja%v)) then
call a%a%csput(nz,ia%v,ja%v,val%v,imin,imax,jmin,jmax,info,gtl)
else
info = psb_err_invalid_mat_state_
endif
if (info /= psb_success_) goto 9999
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_abort_) then
call psb_error()
return
end if
end subroutine psb_d_csput_v
subroutine psb_d_csgetptn(imin,imax,a,nz,ia,ja,info,&
@@ -1244,8 +1291,8 @@ subroutine psb_d_cscnv(a,b,info,type,mold,upd,dupl)
end if
call move_alloc(altmp,b%a)
call b%set_asb()
call b%trim()
call b%asb()
call psb_erractionrestore(err_act)
return
@@ -1870,7 +1917,47 @@ subroutine psb_d_transc_2mat(a,b)
end subroutine psb_d_transc_2mat
subroutine psb_d_asb(a,mold)
use psb_d_mat_mod, psb_protect_name => psb_d_asb
use psb_error_mod
implicit none
class(psb_dspmat_type), intent(inout) :: a
class(psb_d_base_sparse_mat), optional, intent(in) :: mold
class(psb_d_base_sparse_mat), allocatable :: tmp
integer(psb_ipk_) :: err_act, info
character(len=20) :: name='d_asb'
call psb_erractionsave(err_act)
if (a%is_null()) then
info = psb_err_invalid_mat_state_
call psb_errpush(info,name)
goto 9999
endif
call a%a%asb()
if (present(mold)) then
if (.not.same_type_as(a%a,mold)) then
allocate(tmp,mold=mold)
call tmp%mv_from_fmt(a%a,info)
call a%a%free()
call move_alloc(tmp,a%a)
end if
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
end subroutine psb_d_asb
subroutine psb_d_reinit(a,clear)
use psb_d_mat_mod, psb_protect_name => psb_d_reinit
@@ -1889,7 +1976,13 @@ subroutine psb_d_reinit(a,clear)
goto 9999
endif
call a%a%reinit(clear)
if (a%a%has_update()) then
call a%a%reinit(clear)
else
info = psb_err_missing_override_method_
call psb_errpush(info,name)
goto 9999
endif
call psb_erractionrestore(err_act)
return
base/serial/impl/psb_s_base_mat_impl.F90
+52 -3
View File
@@ -327,9 +327,9 @@ subroutine psb_s_base_mv_from_fmt(a,b,info)
end subroutine psb_s_base_mv_from_fmt
subroutine psb_s_base_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
subroutine psb_s_base_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
use psb_error_mod
use psb_s_base_mat_mod, psb_protect_name => psb_s_base_csput
use psb_s_base_mat_mod, psb_protect_name => psb_s_base_csput_a
implicit none
class(psb_s_base_sparse_mat), intent(inout) :: a
real(psb_spk_), intent(in) :: val(:)
@@ -354,7 +354,56 @@ subroutine psb_s_base_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
end if
return
end subroutine psb_s_base_csput
end subroutine psb_s_base_csput_a
subroutine psb_s_base_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
use psb_error_mod
use psb_s_base_mat_mod, psb_protect_name => psb_s_base_csput_v
use psb_s_base_vect_mod
implicit none
class(psb_s_base_sparse_mat), intent(inout) :: a
class(psb_s_base_vect_type), intent(inout) :: val
class(psb_i_base_vect_type), intent(inout) :: ia, ja
integer(psb_ipk_), intent(in) :: nz, imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: gtl(:)
integer(psb_ipk_) :: err_act, nzin, nzout
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='csput_v'
integer :: jmin_, jmax_
logical :: append_, rscale_, cscale_
logical, parameter :: debug=.false.
call psb_erractionsave(err_act)
info = psb_success_
if (allocated(val%v).and.allocated(ia%v).and.allocated(ja%v)) then
if (val%is_dev()) call val%sync()
if (ia%is_dev()) call ia%sync()
if (ja%is_dev()) call ja%sync()
call a%csput(nz,ia%v,ja%v,val%v,imin,imax,jmin,jmax,info,gtl)
else
info = psb_err_invalid_mat_state_
endif
if (info /= 0) then
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_s_base_csput_v
subroutine psb_s_base_csgetrow(imin,imax,a,nz,ia,ja,val,info,&
& jmin,jmax,iren,append,nzin,rscale,cscale)
base/serial/impl/psb_s_coo_impl.f90
+4 -4
View File
@@ -2573,11 +2573,11 @@ contains
end subroutine psb_s_coo_csgetrow
subroutine psb_s_coo_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
subroutine psb_s_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
use psb_error_mod
use psb_realloc_mod
use psb_sort_mod
use psb_s_base_mat_mod, psb_protect_name => psb_s_coo_csput
use psb_s_base_mat_mod, psb_protect_name => psb_s_coo_csput_a
implicit none
class(psb_s_coo_sparse_mat), intent(inout) :: a
@@ -2589,7 +2589,7 @@ subroutine psb_s_coo_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='s_coo_csput_impl'
character(len=20) :: name='s_coo_csput_a_impl'
logical, parameter :: debug=.false.
integer(psb_ipk_) :: nza, i,j,k, nzl, isza, debug_level, debug_unit
@@ -2953,7 +2953,7 @@ contains
end subroutine s_coo_srch_upd
end subroutine psb_s_coo_csput
end subroutine psb_s_coo_csput_a
subroutine psb_s_cp_coo_to_coo(a,b,info)
base/serial/impl/psb_s_csc_impl.f90
+4 -4
View File
@@ -1965,10 +1965,10 @@ end subroutine psb_s_csc_csgetrow
subroutine psb_s_csc_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
subroutine psb_s_csc_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
use psb_error_mod
use psb_realloc_mod
use psb_s_csc_mat_mod, psb_protect_name => psb_s_csc_csput
use psb_s_csc_mat_mod, psb_protect_name => psb_s_csc_csput_a
implicit none
class(psb_s_csc_sparse_mat), intent(inout) :: a
@@ -1980,7 +1980,7 @@ subroutine psb_s_csc_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='s_csc_csput'
character(len=20) :: name='s_csc_csput_a'
logical, parameter :: debug=.false.
integer(psb_ipk_) :: nza, i,j,k, nzl, isza, debug_level, debug_unit
@@ -2232,7 +2232,7 @@ contains
end subroutine psb_s_csc_srch_upd
end subroutine psb_s_csc_csput
end subroutine psb_s_csc_csput_a
base/serial/impl/psb_s_csr_impl.f90
+7 -5
View File
@@ -2338,10 +2338,10 @@ end subroutine psb_s_csr_csgetblk
subroutine psb_s_csr_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
subroutine psb_s_csr_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
use psb_error_mod
use psb_realloc_mod
use psb_s_csr_mat_mod, psb_protect_name => psb_s_csr_csput
use psb_s_csr_mat_mod, psb_protect_name => psb_s_csr_csput_a
implicit none
class(psb_s_csr_sparse_mat), intent(inout) :: a
@@ -2353,7 +2353,7 @@ subroutine psb_s_csr_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='s_csr_csput'
character(len=20) :: name='s_csr_csput_a'
logical, parameter :: debug=.false.
integer(psb_ipk_) :: nza, i,j,k, nzl, isza, debug_level, debug_unit
@@ -2604,7 +2604,7 @@ contains
end subroutine psb_s_csr_srch_upd
end subroutine psb_s_csr_csput
end subroutine psb_s_csr_csput_a
subroutine psb_s_csr_reinit(a,clear)
@@ -2788,7 +2788,9 @@ subroutine psb_s_cp_csr_from_coo(a,b,info)
character(len=20) :: name
info = psb_success_
debug_unit = psb_get_debug_unit()
debug_level = psb_get_debug_level()
if (.not.b%is_sorted()) then
! This is to have fix_coo called behind the scenes
call tmp%cp_from_coo(b,info)
base/serial/impl/psb_s_mat_impl.F90
+99 -6
View File
@@ -733,8 +733,8 @@ end subroutine psb_s_trim
subroutine psb_s_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
use psb_s_mat_mod, psb_protect_name => psb_s_csput
subroutine psb_s_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
use psb_s_mat_mod, psb_protect_name => psb_s_csput_a
use psb_s_base_mat_mod
use psb_error_mod
implicit none
@@ -745,7 +745,7 @@ subroutine psb_s_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
integer(psb_ipk_), intent(in), optional :: gtl(:)
integer(psb_ipk_) :: err_act
character(len=20) :: name='csput'
character(len=20) :: name='csput_a'
logical, parameter :: debug=.false.
info = psb_success_
@@ -771,7 +771,54 @@ subroutine psb_s_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
return
end if
end subroutine psb_s_csput
end subroutine psb_s_csput_a
subroutine psb_s_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
use psb_s_mat_mod, psb_protect_name => psb_s_csput_v
use psb_s_base_mat_mod
use psb_s_vect_mod, only : psb_s_vect_type
use psb_i_vect_mod, only : psb_i_vect_type
use psb_error_mod
implicit none
class(psb_sspmat_type), intent(inout) :: a
type(psb_s_vect_type), intent(inout) :: val
type(psb_i_vect_type), intent(inout) :: ia, ja
integer(psb_ipk_), intent(in) :: nz, imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: gtl(:)
integer(psb_ipk_) :: err_act
character(len=20) :: name='csput_v'
logical, parameter :: debug=.false.
info = psb_success_
call psb_erractionsave(err_act)
if (.not.(a%is_bld().or.a%is_upd())) then
info = psb_err_invalid_mat_state_
call psb_errpush(info,name)
goto 9999
endif
if (allocated(val%v).and.allocated(ia%v).and.allocated(ja%v)) then
call a%a%csput(nz,ia%v,ja%v,val%v,imin,imax,jmin,jmax,info,gtl)
else
info = psb_err_invalid_mat_state_
endif
if (info /= psb_success_) goto 9999
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_abort_) then
call psb_error()
return
end if
end subroutine psb_s_csput_v
subroutine psb_s_csgetptn(imin,imax,a,nz,ia,ja,info,&
@@ -1244,8 +1291,8 @@ subroutine psb_s_cscnv(a,b,info,type,mold,upd,dupl)
end if
call move_alloc(altmp,b%a)
call b%set_asb()
call b%trim()
call b%asb()
call psb_erractionrestore(err_act)
return
@@ -1870,7 +1917,47 @@ subroutine psb_s_transc_2mat(a,b)
end subroutine psb_s_transc_2mat
subroutine psb_s_asb(a,mold)
use psb_s_mat_mod, psb_protect_name => psb_s_asb
use psb_error_mod
implicit none
class(psb_sspmat_type), intent(inout) :: a
class(psb_s_base_sparse_mat), optional, intent(in) :: mold
class(psb_s_base_sparse_mat), allocatable :: tmp
integer(psb_ipk_) :: err_act, info
character(len=20) :: name='s_asb'
call psb_erractionsave(err_act)
if (a%is_null()) then
info = psb_err_invalid_mat_state_
call psb_errpush(info,name)
goto 9999
endif
call a%a%asb()
if (present(mold)) then
if (.not.same_type_as(a%a,mold)) then
allocate(tmp,mold=mold)
call tmp%mv_from_fmt(a%a,info)
call a%a%free()
call move_alloc(tmp,a%a)
end if
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
end subroutine psb_s_asb
subroutine psb_s_reinit(a,clear)
use psb_s_mat_mod, psb_protect_name => psb_s_reinit
@@ -1889,7 +1976,13 @@ subroutine psb_s_reinit(a,clear)
goto 9999
endif
call a%a%reinit(clear)
if (a%a%has_update()) then
call a%a%reinit(clear)
else
info = psb_err_missing_override_method_
call psb_errpush(info,name)
goto 9999
endif
call psb_erractionrestore(err_act)
return
base/serial/impl/psb_z_base_mat_impl.F90
+52 -3
View File
@@ -327,9 +327,9 @@ subroutine psb_z_base_mv_from_fmt(a,b,info)
end subroutine psb_z_base_mv_from_fmt
subroutine psb_z_base_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
subroutine psb_z_base_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
use psb_error_mod
use psb_z_base_mat_mod, psb_protect_name => psb_z_base_csput
use psb_z_base_mat_mod, psb_protect_name => psb_z_base_csput_a
implicit none
class(psb_z_base_sparse_mat), intent(inout) :: a
complex(psb_dpk_), intent(in) :: val(:)
@@ -354,7 +354,56 @@ subroutine psb_z_base_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
end if
return
end subroutine psb_z_base_csput
end subroutine psb_z_base_csput_a
subroutine psb_z_base_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
use psb_error_mod
use psb_z_base_mat_mod, psb_protect_name => psb_z_base_csput_v
use psb_z_base_vect_mod
implicit none
class(psb_z_base_sparse_mat), intent(inout) :: a
class(psb_z_base_vect_type), intent(inout) :: val
class(psb_i_base_vect_type), intent(inout) :: ia, ja
integer(psb_ipk_), intent(in) :: nz, imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: gtl(:)
integer(psb_ipk_) :: err_act, nzin, nzout
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='csput_v'
integer :: jmin_, jmax_
logical :: append_, rscale_, cscale_
logical, parameter :: debug=.false.
call psb_erractionsave(err_act)
info = psb_success_
if (allocated(val%v).and.allocated(ia%v).and.allocated(ja%v)) then
if (val%is_dev()) call val%sync()
if (ia%is_dev()) call ia%sync()
if (ja%is_dev()) call ja%sync()
call a%csput(nz,ia%v,ja%v,val%v,imin,imax,jmin,jmax,info,gtl)
else
info = psb_err_invalid_mat_state_
endif
if (info /= 0) then
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_z_base_csput_v
subroutine psb_z_base_csgetrow(imin,imax,a,nz,ia,ja,val,info,&
& jmin,jmax,iren,append,nzin,rscale,cscale)
base/serial/impl/psb_z_coo_impl.f90
+4 -4
View File
@@ -2573,11 +2573,11 @@ contains
end subroutine psb_z_coo_csgetrow
subroutine psb_z_coo_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
subroutine psb_z_coo_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
use psb_error_mod
use psb_realloc_mod
use psb_sort_mod
use psb_z_base_mat_mod, psb_protect_name => psb_z_coo_csput
use psb_z_base_mat_mod, psb_protect_name => psb_z_coo_csput_a
implicit none
class(psb_z_coo_sparse_mat), intent(inout) :: a
@@ -2589,7 +2589,7 @@ subroutine psb_z_coo_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='z_coo_csput_impl'
character(len=20) :: name='z_coo_csput_a_impl'
logical, parameter :: debug=.false.
integer(psb_ipk_) :: nza, i,j,k, nzl, isza, debug_level, debug_unit
@@ -2953,7 +2953,7 @@ contains
end subroutine z_coo_srch_upd
end subroutine psb_z_coo_csput
end subroutine psb_z_coo_csput_a
subroutine psb_z_cp_coo_to_coo(a,b,info)
base/serial/impl/psb_z_csc_impl.f90
+4 -4
View File
@@ -1965,10 +1965,10 @@ end subroutine psb_z_csc_csgetrow
subroutine psb_z_csc_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
subroutine psb_z_csc_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
use psb_error_mod
use psb_realloc_mod
use psb_z_csc_mat_mod, psb_protect_name => psb_z_csc_csput
use psb_z_csc_mat_mod, psb_protect_name => psb_z_csc_csput_a
implicit none
class(psb_z_csc_sparse_mat), intent(inout) :: a
@@ -1980,7 +1980,7 @@ subroutine psb_z_csc_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='z_csc_csput'
character(len=20) :: name='z_csc_csput_a'
logical, parameter :: debug=.false.
integer(psb_ipk_) :: nza, i,j,k, nzl, isza, debug_level, debug_unit
@@ -2232,7 +2232,7 @@ contains
end subroutine psb_z_csc_srch_upd
end subroutine psb_z_csc_csput
end subroutine psb_z_csc_csput_a
base/serial/impl/psb_z_csr_impl.f90
+7 -5
View File
@@ -2338,10 +2338,10 @@ end subroutine psb_z_csr_csgetblk
subroutine psb_z_csr_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
subroutine psb_z_csr_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
use psb_error_mod
use psb_realloc_mod
use psb_z_csr_mat_mod, psb_protect_name => psb_z_csr_csput
use psb_z_csr_mat_mod, psb_protect_name => psb_z_csr_csput_a
implicit none
class(psb_z_csr_sparse_mat), intent(inout) :: a
@@ -2353,7 +2353,7 @@ subroutine psb_z_csr_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name='z_csr_csput'
character(len=20) :: name='z_csr_csput_a'
logical, parameter :: debug=.false.
integer(psb_ipk_) :: nza, i,j,k, nzl, isza, debug_level, debug_unit
@@ -2604,7 +2604,7 @@ contains
end subroutine psb_z_csr_srch_upd
end subroutine psb_z_csr_csput
end subroutine psb_z_csr_csput_a
subroutine psb_z_csr_reinit(a,clear)
@@ -2788,7 +2788,9 @@ subroutine psb_z_cp_csr_from_coo(a,b,info)
character(len=20) :: name
info = psb_success_
debug_unit = psb_get_debug_unit()
debug_level = psb_get_debug_level()
if (.not.b%is_sorted()) then
! This is to have fix_coo called behind the scenes
call tmp%cp_from_coo(b,info)
base/serial/impl/psb_z_mat_impl.F90
+99 -6
View File
@@ -733,8 +733,8 @@ end subroutine psb_z_trim
subroutine psb_z_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
use psb_z_mat_mod, psb_protect_name => psb_z_csput
subroutine psb_z_csput_a(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
use psb_z_mat_mod, psb_protect_name => psb_z_csput_a
use psb_z_base_mat_mod
use psb_error_mod
implicit none
@@ -745,7 +745,7 @@ subroutine psb_z_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
integer(psb_ipk_), intent(in), optional :: gtl(:)
integer(psb_ipk_) :: err_act
character(len=20) :: name='csput'
character(len=20) :: name='csput_a'
logical, parameter :: debug=.false.
info = psb_success_
@@ -771,7 +771,54 @@ subroutine psb_z_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
return
end if
end subroutine psb_z_csput
end subroutine psb_z_csput_a
subroutine psb_z_csput_v(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
use psb_z_mat_mod, psb_protect_name => psb_z_csput_v
use psb_z_base_mat_mod
use psb_z_vect_mod, only : psb_z_vect_type
use psb_i_vect_mod, only : psb_i_vect_type
use psb_error_mod
implicit none
class(psb_zspmat_type), intent(inout) :: a
type(psb_z_vect_type), intent(inout) :: val
type(psb_i_vect_type), intent(inout) :: ia, ja
integer(psb_ipk_), intent(in) :: nz, imin,imax,jmin,jmax
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(in), optional :: gtl(:)
integer(psb_ipk_) :: err_act
character(len=20) :: name='csput_v'
logical, parameter :: debug=.false.
info = psb_success_
call psb_erractionsave(err_act)
if (.not.(a%is_bld().or.a%is_upd())) then
info = psb_err_invalid_mat_state_
call psb_errpush(info,name)
goto 9999
endif
if (allocated(val%v).and.allocated(ia%v).and.allocated(ja%v)) then
call a%a%csput(nz,ia%v,ja%v,val%v,imin,imax,jmin,jmax,info,gtl)
else
info = psb_err_invalid_mat_state_
endif
if (info /= psb_success_) goto 9999
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_abort_) then
call psb_error()
return
end if
end subroutine psb_z_csput_v
subroutine psb_z_csgetptn(imin,imax,a,nz,ia,ja,info,&
@@ -1244,8 +1291,8 @@ subroutine psb_z_cscnv(a,b,info,type,mold,upd,dupl)
end if
call move_alloc(altmp,b%a)
call b%set_asb()
call b%trim()
call b%asb()
call psb_erractionrestore(err_act)
return
@@ -1870,7 +1917,47 @@ subroutine psb_z_transc_2mat(a,b)
end subroutine psb_z_transc_2mat
subroutine psb_z_asb(a,mold)
use psb_z_mat_mod, psb_protect_name => psb_z_asb
use psb_error_mod
implicit none
class(psb_zspmat_type), intent(inout) :: a
class(psb_z_base_sparse_mat), optional, intent(in) :: mold
class(psb_z_base_sparse_mat), allocatable :: tmp
integer(psb_ipk_) :: err_act, info
character(len=20) :: name='z_asb'
call psb_erractionsave(err_act)
if (a%is_null()) then
info = psb_err_invalid_mat_state_
call psb_errpush(info,name)
goto 9999
endif
call a%a%asb()
if (present(mold)) then
if (.not.same_type_as(a%a,mold)) then
allocate(tmp,mold=mold)
call tmp%mv_from_fmt(a%a,info)
call a%a%free()
call move_alloc(tmp,a%a)
end if
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
end subroutine psb_z_asb
subroutine psb_z_reinit(a,clear)
use psb_z_mat_mod, psb_protect_name => psb_z_reinit
@@ -1889,7 +1976,13 @@ subroutine psb_z_reinit(a,clear)
goto 9999
endif
call a%a%reinit(clear)
if (a%a%has_update()) then
call a%a%reinit(clear)
else
info = psb_err_missing_override_method_
call psb_errpush(info,name)
goto 9999
endif
call psb_erractionrestore(err_act)
return
base/serial/psb_sort_impl.f90
+3 -3
View File
@@ -102,7 +102,7 @@ function psb_iblsrch(key,n,v) result(ipos)
use psb_sort_mod, psb_protect_name => psb_iblsrch
implicit none
integer(psb_ipk_) :: ipos, key, n
integer(psb_ipk_) :: v(n)
integer(psb_ipk_) :: v(:)
integer(psb_ipk_) :: lb, ub, m
@@ -144,7 +144,7 @@ function psb_ibsrch(key,n,v) result(ipos)
use psb_sort_mod, psb_protect_name => psb_ibsrch
implicit none
integer(psb_ipk_) :: ipos, key, n
integer(psb_ipk_) :: v(n)
integer(psb_ipk_) :: v(:)
integer(psb_ipk_) :: lb, ub, m
@@ -170,7 +170,7 @@ function psb_issrch(key,n,v) result(ipos)
use psb_sort_mod, psb_protect_name => psb_issrch
implicit none
integer(psb_ipk_) :: ipos, key, n
integer(psb_ipk_) :: v(n)
integer(psb_ipk_) :: v(:)
integer(psb_ipk_) :: i
base/tools/psb_cins.f90
+116
View File
@@ -304,6 +304,122 @@ subroutine psb_cins_vect(m, irw, val, x, desc_a, info, dupl,local)
end subroutine psb_cins_vect
subroutine psb_cins_vect_v(m, irw, val, x, desc_a, info, dupl,local)
use psb_base_mod, psb_protect_name => psb_cins_vect_v
use psi_mod
implicit none
! m rows number of submatrix belonging to val to be inserted
! ix x global-row corresponding to position at which val submatrix
! must be inserted
!....parameters...
integer(psb_ipk_), intent(in) :: m
type(psb_i_vect_type), intent(inout) :: irw
type(psb_c_vect_type), intent(inout) :: val
type(psb_c_vect_type), intent(inout) :: x
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: dupl
logical, intent(in), optional :: local
!locals.....
integer(psb_ipk_) :: ictxt,i,&
& loc_rows,loc_cols,mglob,err_act, int_err(5)
integer(psb_ipk_) :: np, me, dupl_
integer(psb_ipk_), allocatable :: irl(:)
complex(psb_spk_), allocatable :: lval(:)
logical :: local_
character(len=20) :: name
if (psb_errstatus_fatal()) return
info=psb_success_
call psb_erractionsave(err_act)
name = 'psb_cinsvi_vect_v'
if (.not.desc_a%is_ok()) then
info = psb_err_invalid_cd_state_
call psb_errpush(info,name)
goto 9999
end if
ictxt = desc_a%get_context()
call psb_info(ictxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
!... check parameters....
if (m < 0) then
info = psb_err_iarg_neg_
int_err(1) = 1
int_err(2) = m
call psb_errpush(info,name,int_err)
goto 9999
else if (x%get_nrows() < desc_a%get_local_rows()) then
info = 310
int_err(1) = 5
int_err(2) = 4
call psb_errpush(info,name,int_err)
goto 9999
endif
if (m == 0) return
loc_rows = desc_a%get_local_rows()
loc_cols = desc_a%get_local_cols()
mglob = desc_a%get_global_rows()
if (.not.allocated(x%v)) then
info = psb_err_invalid_vect_state_
call psb_errpush(info,name)
goto 9999
endif
if (present(dupl)) then
dupl_ = dupl
else
dupl_ = psb_dupl_ovwrt_
endif
if (present(local)) then
local_ = local
else
local_ = .false.
endif
if (local_) then
call x%ins(m,irw,val,dupl_,info)
else
irl = irw%get_vect()
lval = val%get_vect()
call desc_a%indxmap%g2lip(irl(1:m),info,owned=.true.)
call x%ins(m,irl,lval,dupl_,info)
end if
if (info /= 0) then
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_ret_) then
return
else
call psb_error(ictxt)
end if
return
end subroutine psb_cins_vect_v
subroutine psb_cins_vect_r2(m, irw, val, x, desc_a, info, dupl,local)
use psb_base_mod, psb_protect_name => psb_cins_vect_r2
use psi_mod
base/tools/psb_cspasb.f90
+21 -13
View File
@@ -33,10 +33,10 @@
!
! Subroutine: psb_cspasb
! Assemble sparse matrix
!
!
! Arguments:
! a - type(psb_cspmat_type). The sparse matrix to be assembled
! desc_a - type(psb_desc_type). The communication descriptor.
! a - type(psb_cspmat_type). The sparse matrix to be allocated.
! desc_a - type(psb_desc_type). The communication descriptor.
! info - integer. return code.
! afmt - character(optional) The desired output storage format.
! upd - character(optional). How will the matrix be updated?
@@ -48,14 +48,14 @@
! psb_dupl_err_ raise an error.
!
!
subroutine psb_cspasb(a,desc_a, info, afmt, upd, dupl,mold)
subroutine psb_cspasb(a,desc_a, info, afmt, upd, dupl, mold)
use psb_base_mod, psb_protect_name => psb_cspasb
use psi_mod
implicit none
!...Parameters....
type(psb_cspmat_type), intent (inout) :: a
type(psb_cspmat_type), intent (inout) :: a
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_),optional, intent(in) :: dupl, upd
@@ -88,12 +88,12 @@ subroutine psb_cspasb(a,desc_a, info, afmt, upd, dupl,mold)
goto 9999
endif
if (.not.psb_is_asb_desc(desc_a)) then
info = psb_err_spmat_invalid_state_
int_err(1) = desc_a%get_dectype()
if (.not.desc_a%is_asb()) then
info = psb_err_invalid_cd_state_
call psb_errpush(info,name)
goto 9999
endif
end if
if (debug_level >= psb_debug_ext_)&
& write(debug_unit, *) me,' ',trim(name),&
@@ -113,7 +113,16 @@ subroutine psb_cspasb(a,desc_a, info, afmt, upd, dupl,mold)
call a%set_ncols(n_col)
end if
call a%cscnv(info,type=afmt,dupl=dupl, mold=mold)
if (a%is_bld()) then
call a%cscnv(info,type=afmt,dupl=dupl, mold=mold)
else if (a%is_upd()) then
call a%asb(mold=mold)
else
info = psb_err_invalid_mat_state_
call psb_errpush(info,name)
goto 9999
end if
IF (debug_level >= psb_debug_ext_) then
@@ -122,10 +131,9 @@ subroutine psb_cspasb(a,desc_a, info, afmt, upd, dupl,mold)
& info,' ',ch_err
end IF
if (info /= psb_no_err_) then
if (psb_errstatus_fatal()) then
info=psb_err_from_subroutine_
ch_err='psb_spcnv'
call psb_errpush(info,name,a_err=ch_err)
call psb_errpush(info,name,a_err='cscnv')
goto 9999
endif
base/tools/psb_cspins.f90
+161 -3
View File
@@ -129,7 +129,7 @@ subroutine psb_cspins(nz,ia,ja,val,a,desc_a,info,rebuild,local)
end if
call desc_a%indxmap%g2l(ia(1:nz),ila(1:nz),info,owned=.true.)
call desc_a%indxmap%g2l_ins(ja(1:nz),jla(1:nz),info,mask=(ila(1:nz)>0))
if (info == 0) call desc_a%indxmap%g2l_ins(ja(1:nz),jla(1:nz),info,mask=(ila(1:nz)>0))
if (info /= psb_success_) then
ierr(1) = info
@@ -175,7 +175,7 @@ subroutine psb_cspins(nz,ia,ja,val,a,desc_a,info,rebuild,local)
end if
call desc_a%indxmap%g2l(ia(1:nz),ila(1:nz),info)
call desc_a%indxmap%g2l(ja(1:nz),jla(1:nz),info)
if (info == 0) call desc_a%indxmap%g2l(ja(1:nz),jla(1:nz),info)
call a%csput(nz,ila,jla,val,ione,nrow,ione,ncol,info)
if (info /= psb_success_) then
@@ -278,7 +278,7 @@ subroutine psb_cspins_2desc(nz,ia,ja,val,a,desc_ar,desc_ac,info)
end if
call desc_ar%indxmap%g2l(ia(1:nz),ila(1:nz),info,owned=.true.)
call desc_ac%indxmap%g2l_ins(ja(1:nz),jla(1:nz),info, mask=(ila(1:nz)>0))
if (info == 0) call desc_ac%indxmap%g2l_ins(ja(1:nz),jla(1:nz),info, mask=(ila(1:nz)>0))
if (psb_errstatus_fatal()) then
ierr(1) = info
@@ -323,3 +323,161 @@ subroutine psb_cspins_2desc(nz,ia,ja,val,a,desc_ar,desc_ac,info)
end subroutine psb_cspins_2desc
subroutine psb_cspins_v(nz,ia,ja,val,a,desc_a,info,rebuild,local)
use psb_base_mod, psb_protect_name => psb_cspins_v
use psi_mod
implicit none
!....parameters...
type(psb_desc_type), intent(inout) :: desc_a
type(psb_cspmat_type), intent(inout) :: a
integer(psb_ipk_), intent(in) :: nz
type(psb_i_vect_type), intent(inout) :: ia,ja
type(psb_c_vect_type), intent(inout) :: val
integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: rebuild, local
!locals.....
integer(psb_ipk_) :: nrow, err_act, ncol, spstate
integer(psb_ipk_) :: ictxt,np,me
logical, parameter :: debug=.false.
integer(psb_ipk_), parameter :: relocsz=200
logical :: rebuild_, local_
integer(psb_ipk_), allocatable :: ila(:),jla(:)
real(psb_dpk_) :: t1,t2,t3,tcnv,tcsput
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name
info = psb_success_
name = 'psb_cspins'
call psb_erractionsave(err_act)
ictxt = desc_a%get_context()
call psb_info(ictxt, me, np)
if (nz < 0) then
info = 1111
call psb_errpush(info,name)
goto 9999
end if
if (ia%get_nrows() < nz) then
info = 1111
call psb_errpush(info,name)
goto 9999
end if
if (ja%get_nrows() < nz) then
info = 1111
call psb_errpush(info,name)
goto 9999
end if
if (val%get_nrows() < nz) then
info = 1111
call psb_errpush(info,name)
goto 9999
end if
if (nz == 0) return
if (present(rebuild)) then
rebuild_ = rebuild
else
rebuild_ = .false.
endif
if (present(local)) then
local_ = local
else
local_ = .false.
endif
if (desc_a%is_bld()) then
!!$ if (local_) then
info = psb_err_invalid_a_and_cd_state_
call psb_errpush(info,name)
goto 9999
!!$ else
!!$ allocate(ila(nz),jla(nz),stat=info)
!!$ if (info /= psb_success_) then
!!$ ierr(1) = info
!!$ call psb_errpush(psb_err_from_subroutine_ai_,name,&
!!$ & a_err='allocate',i_err=ierr)
!!$ goto 9999
!!$ end if
!!$
!!$ call desc_a%indxmap%g2l(ia(1:nz),ila(1:nz),info,owned=.true.)
!!$ call desc_a%indxmap%g2l_ins(ja(1:nz),jla(1:nz),info,mask=(ila(1:nz)>0))
!!$
!!$ if (info /= psb_success_) then
!!$ ierr(1) = info
!!$ call psb_errpush(psb_err_from_subroutine_ai_,name,&
!!$ & a_err='psb_cdins',i_err=ierr)
!!$ goto 9999
!!$ end if
!!$ nrow = desc_a%get_local_rows()
!!$ ncol = desc_a%get_local_cols()
!!$
!!$ if (a%is_bld()) then
!!$ call a%csput(nz,ila,jla,val,ione,nrow,ione,ncol,info)
!!$ if (info /= psb_success_) then
!!$ info=psb_err_from_subroutine_
!!$ call psb_errpush(info,name,a_err='a%csput')
!!$ goto 9999
!!$ end if
!!$ else
!!$ info = psb_err_invalid_a_and_cd_state_
!!$ call psb_errpush(info,name)
!!$ goto 9999
!!$ end if
!!$ endif
else if (desc_a%is_asb()) then
nrow = desc_a%get_local_rows()
ncol = desc_a%get_local_cols()
if (local_) then
call a%csput(nz,ia,ja,val,ione,nrow,ione,ncol,info)
if (info /= psb_success_) then
info=psb_err_from_subroutine_
call psb_errpush(info,name,a_err='a%csput')
goto 9999
end if
else
info = psb_err_invalid_cd_state_
!!$ allocate(ila(nz),jla(nz),stat=info)
!!$ if (info /= psb_success_) then
!!$ ierr(1) = info
!!$ call psb_errpush(psb_err_from_subroutine_ai_,name,&
!!$ & a_err='allocate',i_err=ierr)
!!$ goto 9999
!!$ end if
!!$
!!$ call desc_a%indxmap%g2l(ia(1:nz),ila(1:nz),info)
!!$ if (info == 0) call desc_a%indxmap%g2l(ja(1:nz),jla(1:nz),info)
!!$ if (info == 0) call a%csput(nz,ila,jla,val,ione,nrow,ione,ncol,info)
!!$ if (info /= psb_success_) then
!!$ info=psb_err_from_subroutine_
!!$ call psb_errpush(info,name,a_err='a%csput')
!!$ goto 9999
!!$ end if
end if
else
info = psb_err_invalid_cd_state_
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(ictxt)
return
end if
return
end subroutine psb_cspins_v
base/tools/psb_dins.f90
+116
View File
@@ -304,6 +304,122 @@ subroutine psb_dins_vect(m, irw, val, x, desc_a, info, dupl,local)
end subroutine psb_dins_vect
subroutine psb_dins_vect_v(m, irw, val, x, desc_a, info, dupl,local)
use psb_base_mod, psb_protect_name => psb_dins_vect_v
use psi_mod
implicit none
! m rows number of submatrix belonging to val to be inserted
! ix x global-row corresponding to position at which val submatrix
! must be inserted
!....parameters...
integer(psb_ipk_), intent(in) :: m
type(psb_i_vect_type), intent(inout) :: irw
type(psb_d_vect_type), intent(inout) :: val
type(psb_d_vect_type), intent(inout) :: x
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: dupl
logical, intent(in), optional :: local
!locals.....
integer(psb_ipk_) :: ictxt,i,&
& loc_rows,loc_cols,mglob,err_act, int_err(5)
integer(psb_ipk_) :: np, me, dupl_
integer(psb_ipk_), allocatable :: irl(:)
real(psb_dpk_), allocatable :: lval(:)
logical :: local_
character(len=20) :: name
if (psb_errstatus_fatal()) return
info=psb_success_
call psb_erractionsave(err_act)
name = 'psb_dinsvi_vect_v'
if (.not.desc_a%is_ok()) then
info = psb_err_invalid_cd_state_
call psb_errpush(info,name)
goto 9999
end if
ictxt = desc_a%get_context()
call psb_info(ictxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
!... check parameters....
if (m < 0) then
info = psb_err_iarg_neg_
int_err(1) = 1
int_err(2) = m
call psb_errpush(info,name,int_err)
goto 9999
else if (x%get_nrows() < desc_a%get_local_rows()) then
info = 310
int_err(1) = 5
int_err(2) = 4
call psb_errpush(info,name,int_err)
goto 9999
endif
if (m == 0) return
loc_rows = desc_a%get_local_rows()
loc_cols = desc_a%get_local_cols()
mglob = desc_a%get_global_rows()
if (.not.allocated(x%v)) then
info = psb_err_invalid_vect_state_
call psb_errpush(info,name)
goto 9999
endif
if (present(dupl)) then
dupl_ = dupl
else
dupl_ = psb_dupl_ovwrt_
endif
if (present(local)) then
local_ = local
else
local_ = .false.
endif
if (local_) then
call x%ins(m,irw,val,dupl_,info)
else
irl = irw%get_vect()
lval = val%get_vect()
call desc_a%indxmap%g2lip(irl(1:m),info,owned=.true.)
call x%ins(m,irl,lval,dupl_,info)
end if
if (info /= 0) then
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_ret_) then
return
else
call psb_error(ictxt)
end if
return
end subroutine psb_dins_vect_v
subroutine psb_dins_vect_r2(m, irw, val, x, desc_a, info, dupl,local)
use psb_base_mod, psb_protect_name => psb_dins_vect_r2
use psi_mod
base/tools/psb_dspasb.f90
+10 -1
View File
@@ -113,7 +113,16 @@ subroutine psb_dspasb(a,desc_a, info, afmt, upd, dupl, mold)
call a%set_ncols(n_col)
end if
call a%cscnv(info,type=afmt,dupl=dupl, mold=mold)
if (a%is_bld()) then
call a%cscnv(info,type=afmt,dupl=dupl, mold=mold)
else if (a%is_upd()) then
call a%asb(mold=mold)
else
info = psb_err_invalid_mat_state_
call psb_errpush(info,name)
goto 9999
end if
IF (debug_level >= psb_debug_ext_) then
base/tools/psb_dspins.f90
+161 -3
View File
@@ -129,7 +129,7 @@ subroutine psb_dspins(nz,ia,ja,val,a,desc_a,info,rebuild,local)
end if
call desc_a%indxmap%g2l(ia(1:nz),ila(1:nz),info,owned=.true.)
call desc_a%indxmap%g2l_ins(ja(1:nz),jla(1:nz),info,mask=(ila(1:nz)>0))
if (info == 0) call desc_a%indxmap%g2l_ins(ja(1:nz),jla(1:nz),info,mask=(ila(1:nz)>0))
if (info /= psb_success_) then
ierr(1) = info
@@ -175,7 +175,7 @@ subroutine psb_dspins(nz,ia,ja,val,a,desc_a,info,rebuild,local)
end if
call desc_a%indxmap%g2l(ia(1:nz),ila(1:nz),info)
call desc_a%indxmap%g2l(ja(1:nz),jla(1:nz),info)
if (info == 0) call desc_a%indxmap%g2l(ja(1:nz),jla(1:nz),info)
call a%csput(nz,ila,jla,val,ione,nrow,ione,ncol,info)
if (info /= psb_success_) then
@@ -278,7 +278,7 @@ subroutine psb_dspins_2desc(nz,ia,ja,val,a,desc_ar,desc_ac,info)
end if
call desc_ar%indxmap%g2l(ia(1:nz),ila(1:nz),info,owned=.true.)
call desc_ac%indxmap%g2l_ins(ja(1:nz),jla(1:nz),info, mask=(ila(1:nz)>0))
if (info == 0) call desc_ac%indxmap%g2l_ins(ja(1:nz),jla(1:nz),info, mask=(ila(1:nz)>0))
if (psb_errstatus_fatal()) then
ierr(1) = info
@@ -323,3 +323,161 @@ subroutine psb_dspins_2desc(nz,ia,ja,val,a,desc_ar,desc_ac,info)
end subroutine psb_dspins_2desc
subroutine psb_dspins_v(nz,ia,ja,val,a,desc_a,info,rebuild,local)
use psb_base_mod, psb_protect_name => psb_dspins_v
use psi_mod
implicit none
!....parameters...
type(psb_desc_type), intent(inout) :: desc_a
type(psb_dspmat_type), intent(inout) :: a
integer(psb_ipk_), intent(in) :: nz
type(psb_i_vect_type), intent(inout) :: ia,ja
type(psb_d_vect_type), intent(inout) :: val
integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: rebuild, local
!locals.....
integer(psb_ipk_) :: nrow, err_act, ncol, spstate
integer(psb_ipk_) :: ictxt,np,me
logical, parameter :: debug=.false.
integer(psb_ipk_), parameter :: relocsz=200
logical :: rebuild_, local_
integer(psb_ipk_), allocatable :: ila(:),jla(:)
real(psb_dpk_) :: t1,t2,t3,tcnv,tcsput
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name
info = psb_success_
name = 'psb_dspins'
call psb_erractionsave(err_act)
ictxt = desc_a%get_context()
call psb_info(ictxt, me, np)
if (nz < 0) then
info = 1111
call psb_errpush(info,name)
goto 9999
end if
if (ia%get_nrows() < nz) then
info = 1111
call psb_errpush(info,name)
goto 9999
end if
if (ja%get_nrows() < nz) then
info = 1111
call psb_errpush(info,name)
goto 9999
end if
if (val%get_nrows() < nz) then
info = 1111
call psb_errpush(info,name)
goto 9999
end if
if (nz == 0) return
if (present(rebuild)) then
rebuild_ = rebuild
else
rebuild_ = .false.
endif
if (present(local)) then
local_ = local
else
local_ = .false.
endif
if (desc_a%is_bld()) then
!!$ if (local_) then
info = psb_err_invalid_a_and_cd_state_
call psb_errpush(info,name)
goto 9999
!!$ else
!!$ allocate(ila(nz),jla(nz),stat=info)
!!$ if (info /= psb_success_) then
!!$ ierr(1) = info
!!$ call psb_errpush(psb_err_from_subroutine_ai_,name,&
!!$ & a_err='allocate',i_err=ierr)
!!$ goto 9999
!!$ end if
!!$
!!$ call desc_a%indxmap%g2l(ia(1:nz),ila(1:nz),info,owned=.true.)
!!$ call desc_a%indxmap%g2l_ins(ja(1:nz),jla(1:nz),info,mask=(ila(1:nz)>0))
!!$
!!$ if (info /= psb_success_) then
!!$ ierr(1) = info
!!$ call psb_errpush(psb_err_from_subroutine_ai_,name,&
!!$ & a_err='psb_cdins',i_err=ierr)
!!$ goto 9999
!!$ end if
!!$ nrow = desc_a%get_local_rows()
!!$ ncol = desc_a%get_local_cols()
!!$
!!$ if (a%is_bld()) then
!!$ call a%csput(nz,ila,jla,val,ione,nrow,ione,ncol,info)
!!$ if (info /= psb_success_) then
!!$ info=psb_err_from_subroutine_
!!$ call psb_errpush(info,name,a_err='a%csput')
!!$ goto 9999
!!$ end if
!!$ else
!!$ info = psb_err_invalid_a_and_cd_state_
!!$ call psb_errpush(info,name)
!!$ goto 9999
!!$ end if
!!$ endif
else if (desc_a%is_asb()) then
nrow = desc_a%get_local_rows()
ncol = desc_a%get_local_cols()
if (local_) then
call a%csput(nz,ia,ja,val,ione,nrow,ione,ncol,info)
if (info /= psb_success_) then
info=psb_err_from_subroutine_
call psb_errpush(info,name,a_err='a%csput')
goto 9999
end if
else
info = psb_err_invalid_cd_state_
!!$ allocate(ila(nz),jla(nz),stat=info)
!!$ if (info /= psb_success_) then
!!$ ierr(1) = info
!!$ call psb_errpush(psb_err_from_subroutine_ai_,name,&
!!$ & a_err='allocate',i_err=ierr)
!!$ goto 9999
!!$ end if
!!$
!!$ call desc_a%indxmap%g2l(ia(1:nz),ila(1:nz),info)
!!$ if (info == 0) call desc_a%indxmap%g2l(ja(1:nz),jla(1:nz),info)
!!$ if (info == 0) call a%csput(nz,ila,jla,val,ione,nrow,ione,ncol,info)
!!$ if (info /= psb_success_) then
!!$ info=psb_err_from_subroutine_
!!$ call psb_errpush(info,name,a_err='a%csput')
!!$ goto 9999
!!$ end if
end if
else
info = psb_err_invalid_cd_state_
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(ictxt)
return
end if
return
end subroutine psb_dspins_v
base/tools/psb_glob_to_loc.f90
+3 -3
View File
@@ -224,12 +224,12 @@ subroutine psb_glob_to_loc1v(x,desc_a,info,iact,owned)
call psb_erractionrestore(err_act)
return
case('W')
if ((info /= psb_success_).or.(count(x(1:n)<0) >0)) then
if ((info /= psb_success_).or.(count(x(:)<0) >0)) then
write(psb_err_unit,'("Error ",i5," in subroutine glob_to_loc")') info
end if
case('A')
if ((info /= psb_success_).or.(count(x(1:n)<0) >0)) then
write(psb_err_unit,*) count(x(1:n)<0)
if ((info /= psb_success_).or.(count(x(:)<0) >0)) then
write(psb_err_unit,*) count(x(:)<0)
call psb_errpush(info,name)
goto 9999
end if
base/tools/psb_sins.f90
+116
View File
@@ -304,6 +304,122 @@ subroutine psb_sins_vect(m, irw, val, x, desc_a, info, dupl,local)
end subroutine psb_sins_vect
subroutine psb_sins_vect_v(m, irw, val, x, desc_a, info, dupl,local)
use psb_base_mod, psb_protect_name => psb_sins_vect_v
use psi_mod
implicit none
! m rows number of submatrix belonging to val to be inserted
! ix x global-row corresponding to position at which val submatrix
! must be inserted
!....parameters...
integer(psb_ipk_), intent(in) :: m
type(psb_i_vect_type), intent(inout) :: irw
type(psb_s_vect_type), intent(inout) :: val
type(psb_s_vect_type), intent(inout) :: x
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: dupl
logical, intent(in), optional :: local
!locals.....
integer(psb_ipk_) :: ictxt,i,&
& loc_rows,loc_cols,mglob,err_act, int_err(5)
integer(psb_ipk_) :: np, me, dupl_
integer(psb_ipk_), allocatable :: irl(:)
real(psb_spk_), allocatable :: lval(:)
logical :: local_
character(len=20) :: name
if (psb_errstatus_fatal()) return
info=psb_success_
call psb_erractionsave(err_act)
name = 'psb_sinsvi_vect_v'
if (.not.desc_a%is_ok()) then
info = psb_err_invalid_cd_state_
call psb_errpush(info,name)
goto 9999
end if
ictxt = desc_a%get_context()
call psb_info(ictxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
!... check parameters....
if (m < 0) then
info = psb_err_iarg_neg_
int_err(1) = 1
int_err(2) = m
call psb_errpush(info,name,int_err)
goto 9999
else if (x%get_nrows() < desc_a%get_local_rows()) then
info = 310
int_err(1) = 5
int_err(2) = 4
call psb_errpush(info,name,int_err)
goto 9999
endif
if (m == 0) return
loc_rows = desc_a%get_local_rows()
loc_cols = desc_a%get_local_cols()
mglob = desc_a%get_global_rows()
if (.not.allocated(x%v)) then
info = psb_err_invalid_vect_state_
call psb_errpush(info,name)
goto 9999
endif
if (present(dupl)) then
dupl_ = dupl
else
dupl_ = psb_dupl_ovwrt_
endif
if (present(local)) then
local_ = local
else
local_ = .false.
endif
if (local_) then
call x%ins(m,irw,val,dupl_,info)
else
irl = irw%get_vect()
lval = val%get_vect()
call desc_a%indxmap%g2lip(irl(1:m),info,owned=.true.)
call x%ins(m,irl,lval,dupl_,info)
end if
if (info /= 0) then
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_ret_) then
return
else
call psb_error(ictxt)
end if
return
end subroutine psb_sins_vect_v
subroutine psb_sins_vect_r2(m, irw, val, x, desc_a, info, dupl,local)
use psb_base_mod, psb_protect_name => psb_sins_vect_r2
use psi_mod
base/tools/psb_sspasb.f90
+16 -8
View File
@@ -88,12 +88,12 @@ subroutine psb_sspasb(a,desc_a, info, afmt, upd, dupl, mold)
goto 9999
endif
if (.not.psb_is_asb_desc(desc_a)) then
info = psb_err_spmat_invalid_state_
int_err(1) = desc_a%get_dectype()
if (.not.desc_a%is_asb()) then
info = psb_err_invalid_cd_state_
call psb_errpush(info,name)
goto 9999
endif
end if
if (debug_level >= psb_debug_ext_)&
& write(debug_unit, *) me,' ',trim(name),&
@@ -113,7 +113,16 @@ subroutine psb_sspasb(a,desc_a, info, afmt, upd, dupl, mold)
call a%set_ncols(n_col)
end if
call a%cscnv(info,type=afmt,dupl=dupl, mold=mold)
if (a%is_bld()) then
call a%cscnv(info,type=afmt,dupl=dupl, mold=mold)
else if (a%is_upd()) then
call a%asb(mold=mold)
else
info = psb_err_invalid_mat_state_
call psb_errpush(info,name)
goto 9999
end if
IF (debug_level >= psb_debug_ext_) then
@@ -122,10 +131,9 @@ subroutine psb_sspasb(a,desc_a, info, afmt, upd, dupl, mold)
& info,' ',ch_err
end IF
if (info /= psb_no_err_) then
if (psb_errstatus_fatal()) then
info=psb_err_from_subroutine_
ch_err='psb_spcnv'
call psb_errpush(info,name,a_err=ch_err)
call psb_errpush(info,name,a_err='cscnv')
goto 9999
endif
base/tools/psb_sspins.f90
+161 -3
View File
@@ -129,7 +129,7 @@ subroutine psb_sspins(nz,ia,ja,val,a,desc_a,info,rebuild,local)
end if
call desc_a%indxmap%g2l(ia(1:nz),ila(1:nz),info,owned=.true.)
call desc_a%indxmap%g2l_ins(ja(1:nz),jla(1:nz),info,mask=(ila(1:nz)>0))
if (info == 0) call desc_a%indxmap%g2l_ins(ja(1:nz),jla(1:nz),info,mask=(ila(1:nz)>0))
if (info /= psb_success_) then
ierr(1) = info
@@ -175,7 +175,7 @@ subroutine psb_sspins(nz,ia,ja,val,a,desc_a,info,rebuild,local)
end if
call desc_a%indxmap%g2l(ia(1:nz),ila(1:nz),info)
call desc_a%indxmap%g2l(ja(1:nz),jla(1:nz),info)
if (info == 0) call desc_a%indxmap%g2l(ja(1:nz),jla(1:nz),info)
call a%csput(nz,ila,jla,val,ione,nrow,ione,ncol,info)
if (info /= psb_success_) then
@@ -278,7 +278,7 @@ subroutine psb_sspins_2desc(nz,ia,ja,val,a,desc_ar,desc_ac,info)
end if
call desc_ar%indxmap%g2l(ia(1:nz),ila(1:nz),info,owned=.true.)
call desc_ac%indxmap%g2l_ins(ja(1:nz),jla(1:nz),info, mask=(ila(1:nz)>0))
if (info == 0) call desc_ac%indxmap%g2l_ins(ja(1:nz),jla(1:nz),info, mask=(ila(1:nz)>0))
if (psb_errstatus_fatal()) then
ierr(1) = info
@@ -323,3 +323,161 @@ subroutine psb_sspins_2desc(nz,ia,ja,val,a,desc_ar,desc_ac,info)
end subroutine psb_sspins_2desc
subroutine psb_sspins_v(nz,ia,ja,val,a,desc_a,info,rebuild,local)
use psb_base_mod, psb_protect_name => psb_sspins_v
use psi_mod
implicit none
!....parameters...
type(psb_desc_type), intent(inout) :: desc_a
type(psb_sspmat_type), intent(inout) :: a
integer(psb_ipk_), intent(in) :: nz
type(psb_i_vect_type), intent(inout) :: ia,ja
type(psb_s_vect_type), intent(inout) :: val
integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: rebuild, local
!locals.....
integer(psb_ipk_) :: nrow, err_act, ncol, spstate
integer(psb_ipk_) :: ictxt,np,me
logical, parameter :: debug=.false.
integer(psb_ipk_), parameter :: relocsz=200
logical :: rebuild_, local_
integer(psb_ipk_), allocatable :: ila(:),jla(:)
real(psb_dpk_) :: t1,t2,t3,tcnv,tcsput
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name
info = psb_success_
name = 'psb_sspins'
call psb_erractionsave(err_act)
ictxt = desc_a%get_context()
call psb_info(ictxt, me, np)
if (nz < 0) then
info = 1111
call psb_errpush(info,name)
goto 9999
end if
if (ia%get_nrows() < nz) then
info = 1111
call psb_errpush(info,name)
goto 9999
end if
if (ja%get_nrows() < nz) then
info = 1111
call psb_errpush(info,name)
goto 9999
end if
if (val%get_nrows() < nz) then
info = 1111
call psb_errpush(info,name)
goto 9999
end if
if (nz == 0) return
if (present(rebuild)) then
rebuild_ = rebuild
else
rebuild_ = .false.
endif
if (present(local)) then
local_ = local
else
local_ = .false.
endif
if (desc_a%is_bld()) then
!!$ if (local_) then
info = psb_err_invalid_a_and_cd_state_
call psb_errpush(info,name)
goto 9999
!!$ else
!!$ allocate(ila(nz),jla(nz),stat=info)
!!$ if (info /= psb_success_) then
!!$ ierr(1) = info
!!$ call psb_errpush(psb_err_from_subroutine_ai_,name,&
!!$ & a_err='allocate',i_err=ierr)
!!$ goto 9999
!!$ end if
!!$
!!$ call desc_a%indxmap%g2l(ia(1:nz),ila(1:nz),info,owned=.true.)
!!$ call desc_a%indxmap%g2l_ins(ja(1:nz),jla(1:nz),info,mask=(ila(1:nz)>0))
!!$
!!$ if (info /= psb_success_) then
!!$ ierr(1) = info
!!$ call psb_errpush(psb_err_from_subroutine_ai_,name,&
!!$ & a_err='psb_cdins',i_err=ierr)
!!$ goto 9999
!!$ end if
!!$ nrow = desc_a%get_local_rows()
!!$ ncol = desc_a%get_local_cols()
!!$
!!$ if (a%is_bld()) then
!!$ call a%csput(nz,ila,jla,val,ione,nrow,ione,ncol,info)
!!$ if (info /= psb_success_) then
!!$ info=psb_err_from_subroutine_
!!$ call psb_errpush(info,name,a_err='a%csput')
!!$ goto 9999
!!$ end if
!!$ else
!!$ info = psb_err_invalid_a_and_cd_state_
!!$ call psb_errpush(info,name)
!!$ goto 9999
!!$ end if
!!$ endif
else if (desc_a%is_asb()) then
nrow = desc_a%get_local_rows()
ncol = desc_a%get_local_cols()
if (local_) then
call a%csput(nz,ia,ja,val,ione,nrow,ione,ncol,info)
if (info /= psb_success_) then
info=psb_err_from_subroutine_
call psb_errpush(info,name,a_err='a%csput')
goto 9999
end if
else
info = psb_err_invalid_cd_state_
!!$ allocate(ila(nz),jla(nz),stat=info)
!!$ if (info /= psb_success_) then
!!$ ierr(1) = info
!!$ call psb_errpush(psb_err_from_subroutine_ai_,name,&
!!$ & a_err='allocate',i_err=ierr)
!!$ goto 9999
!!$ end if
!!$
!!$ call desc_a%indxmap%g2l(ia(1:nz),ila(1:nz),info)
!!$ if (info == 0) call desc_a%indxmap%g2l(ja(1:nz),jla(1:nz),info)
!!$ if (info == 0) call a%csput(nz,ila,jla,val,ione,nrow,ione,ncol,info)
!!$ if (info /= psb_success_) then
!!$ info=psb_err_from_subroutine_
!!$ call psb_errpush(info,name,a_err='a%csput')
!!$ goto 9999
!!$ end if
end if
else
info = psb_err_invalid_cd_state_
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(ictxt)
return
end if
return
end subroutine psb_sspins_v
base/tools/psb_zins.f90
+116
View File
@@ -304,6 +304,122 @@ subroutine psb_zins_vect(m, irw, val, x, desc_a, info, dupl,local)
end subroutine psb_zins_vect
subroutine psb_zins_vect_v(m, irw, val, x, desc_a, info, dupl,local)
use psb_base_mod, psb_protect_name => psb_zins_vect_v
use psi_mod
implicit none
! m rows number of submatrix belonging to val to be inserted
! ix x global-row corresponding to position at which val submatrix
! must be inserted
!....parameters...
integer(psb_ipk_), intent(in) :: m
type(psb_i_vect_type), intent(inout) :: irw
type(psb_z_vect_type), intent(inout) :: val
type(psb_z_vect_type), intent(inout) :: x
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: dupl
logical, intent(in), optional :: local
!locals.....
integer(psb_ipk_) :: ictxt,i,&
& loc_rows,loc_cols,mglob,err_act, int_err(5)
integer(psb_ipk_) :: np, me, dupl_
integer(psb_ipk_), allocatable :: irl(:)
complex(psb_dpk_), allocatable :: lval(:)
logical :: local_
character(len=20) :: name
if (psb_errstatus_fatal()) return
info=psb_success_
call psb_erractionsave(err_act)
name = 'psb_zinsvi_vect_v'
if (.not.desc_a%is_ok()) then
info = psb_err_invalid_cd_state_
call psb_errpush(info,name)
goto 9999
end if
ictxt = desc_a%get_context()
call psb_info(ictxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
!... check parameters....
if (m < 0) then
info = psb_err_iarg_neg_
int_err(1) = 1
int_err(2) = m
call psb_errpush(info,name,int_err)
goto 9999
else if (x%get_nrows() < desc_a%get_local_rows()) then
info = 310
int_err(1) = 5
int_err(2) = 4
call psb_errpush(info,name,int_err)
goto 9999
endif
if (m == 0) return
loc_rows = desc_a%get_local_rows()
loc_cols = desc_a%get_local_cols()
mglob = desc_a%get_global_rows()
if (.not.allocated(x%v)) then
info = psb_err_invalid_vect_state_
call psb_errpush(info,name)
goto 9999
endif
if (present(dupl)) then
dupl_ = dupl
else
dupl_ = psb_dupl_ovwrt_
endif
if (present(local)) then
local_ = local
else
local_ = .false.
endif
if (local_) then
call x%ins(m,irw,val,dupl_,info)
else
irl = irw%get_vect()
lval = val%get_vect()
call desc_a%indxmap%g2lip(irl(1:m),info,owned=.true.)
call x%ins(m,irl,lval,dupl_,info)
end if
if (info /= 0) then
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_ret_) then
return
else
call psb_error(ictxt)
end if
return
end subroutine psb_zins_vect_v
subroutine psb_zins_vect_r2(m, irw, val, x, desc_a, info, dupl,local)
use psb_base_mod, psb_protect_name => psb_zins_vect_r2
use psi_mod
base/tools/psb_zspasb.f90
+20 -12
View File
@@ -33,10 +33,10 @@
!
! Subroutine: psb_zspasb
! Assemble sparse matrix
!
!
! Arguments:
! a - type(psb_zspmat_type). The sparse matrix to be assembled
! desc_a - type(psb_desc_type). The communication descriptor.
! a - type(psb_zspmat_type). The sparse matrix to be allocated.
! desc_a - type(psb_desc_type). The communication descriptor.
! info - integer. return code.
! afmt - character(optional) The desired output storage format.
! upd - character(optional). How will the matrix be updated?
@@ -55,7 +55,7 @@ subroutine psb_zspasb(a,desc_a, info, afmt, upd, dupl, mold)
!...Parameters....
type(psb_zspmat_type), intent (inout) :: a
type(psb_zspmat_type), intent (inout) :: a
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_),optional, intent(in) :: dupl, upd
@@ -88,12 +88,12 @@ subroutine psb_zspasb(a,desc_a, info, afmt, upd, dupl, mold)
goto 9999
endif
if (.not.psb_is_asb_desc(desc_a)) then
info = psb_err_spmat_invalid_state_
int_err(1) = desc_a%get_dectype()
if (.not.desc_a%is_asb()) then
info = psb_err_invalid_cd_state_
call psb_errpush(info,name)
goto 9999
endif
end if
if (debug_level >= psb_debug_ext_)&
& write(debug_unit, *) me,' ',trim(name),&
@@ -113,7 +113,16 @@ subroutine psb_zspasb(a,desc_a, info, afmt, upd, dupl, mold)
call a%set_ncols(n_col)
end if
call a%cscnv(info,type=afmt,dupl=dupl, mold=mold)
if (a%is_bld()) then
call a%cscnv(info,type=afmt,dupl=dupl, mold=mold)
else if (a%is_upd()) then
call a%asb(mold=mold)
else
info = psb_err_invalid_mat_state_
call psb_errpush(info,name)
goto 9999
end if
IF (debug_level >= psb_debug_ext_) then
@@ -122,10 +131,9 @@ subroutine psb_zspasb(a,desc_a, info, afmt, upd, dupl, mold)
& info,' ',ch_err
end IF
if (info /= psb_no_err_) then
if (psb_errstatus_fatal()) then
info=psb_err_from_subroutine_
ch_err='psb_spcnv'
call psb_errpush(info,name,a_err=ch_err)
call psb_errpush(info,name,a_err='cscnv')
goto 9999
endif
base/tools/psb_zspins.f90
+161 -3
View File
@@ -129,7 +129,7 @@ subroutine psb_zspins(nz,ia,ja,val,a,desc_a,info,rebuild,local)
end if
call desc_a%indxmap%g2l(ia(1:nz),ila(1:nz),info,owned=.true.)
call desc_a%indxmap%g2l_ins(ja(1:nz),jla(1:nz),info,mask=(ila(1:nz)>0))
if (info == 0) call desc_a%indxmap%g2l_ins(ja(1:nz),jla(1:nz),info,mask=(ila(1:nz)>0))
if (info /= psb_success_) then
ierr(1) = info
@@ -175,7 +175,7 @@ subroutine psb_zspins(nz,ia,ja,val,a,desc_a,info,rebuild,local)
end if
call desc_a%indxmap%g2l(ia(1:nz),ila(1:nz),info)
call desc_a%indxmap%g2l(ja(1:nz),jla(1:nz),info)
if (info == 0) call desc_a%indxmap%g2l(ja(1:nz),jla(1:nz),info)
call a%csput(nz,ila,jla,val,ione,nrow,ione,ncol,info)
if (info /= psb_success_) then
@@ -278,7 +278,7 @@ subroutine psb_zspins_2desc(nz,ia,ja,val,a,desc_ar,desc_ac,info)
end if
call desc_ar%indxmap%g2l(ia(1:nz),ila(1:nz),info,owned=.true.)
call desc_ac%indxmap%g2l_ins(ja(1:nz),jla(1:nz),info, mask=(ila(1:nz)>0))
if (info == 0) call desc_ac%indxmap%g2l_ins(ja(1:nz),jla(1:nz),info, mask=(ila(1:nz)>0))
if (psb_errstatus_fatal()) then
ierr(1) = info
@@ -323,3 +323,161 @@ subroutine psb_zspins_2desc(nz,ia,ja,val,a,desc_ar,desc_ac,info)
end subroutine psb_zspins_2desc
subroutine psb_zspins_v(nz,ia,ja,val,a,desc_a,info,rebuild,local)
use psb_base_mod, psb_protect_name => psb_zspins_v
use psi_mod
implicit none
!....parameters...
type(psb_desc_type), intent(inout) :: desc_a
type(psb_zspmat_type), intent(inout) :: a
integer(psb_ipk_), intent(in) :: nz
type(psb_i_vect_type), intent(inout) :: ia,ja
type(psb_z_vect_type), intent(inout) :: val
integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: rebuild, local
!locals.....
integer(psb_ipk_) :: nrow, err_act, ncol, spstate
integer(psb_ipk_) :: ictxt,np,me
logical, parameter :: debug=.false.
integer(psb_ipk_), parameter :: relocsz=200
logical :: rebuild_, local_
integer(psb_ipk_), allocatable :: ila(:),jla(:)
real(psb_dpk_) :: t1,t2,t3,tcnv,tcsput
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name
info = psb_success_
name = 'psb_zspins'
call psb_erractionsave(err_act)
ictxt = desc_a%get_context()
call psb_info(ictxt, me, np)
if (nz < 0) then
info = 1111
call psb_errpush(info,name)
goto 9999
end if
if (ia%get_nrows() < nz) then
info = 1111
call psb_errpush(info,name)
goto 9999
end if
if (ja%get_nrows() < nz) then
info = 1111
call psb_errpush(info,name)
goto 9999
end if
if (val%get_nrows() < nz) then
info = 1111
call psb_errpush(info,name)
goto 9999
end if
if (nz == 0) return
if (present(rebuild)) then
rebuild_ = rebuild
else
rebuild_ = .false.
endif
if (present(local)) then
local_ = local
else
local_ = .false.
endif
if (desc_a%is_bld()) then
!!$ if (local_) then
info = psb_err_invalid_a_and_cd_state_
call psb_errpush(info,name)
goto 9999
!!$ else
!!$ allocate(ila(nz),jla(nz),stat=info)
!!$ if (info /= psb_success_) then
!!$ ierr(1) = info
!!$ call psb_errpush(psb_err_from_subroutine_ai_,name,&
!!$ & a_err='allocate',i_err=ierr)
!!$ goto 9999
!!$ end if
!!$
!!$ call desc_a%indxmap%g2l(ia(1:nz),ila(1:nz),info,owned=.true.)
!!$ call desc_a%indxmap%g2l_ins(ja(1:nz),jla(1:nz),info,mask=(ila(1:nz)>0))
!!$
!!$ if (info /= psb_success_) then
!!$ ierr(1) = info
!!$ call psb_errpush(psb_err_from_subroutine_ai_,name,&
!!$ & a_err='psb_cdins',i_err=ierr)
!!$ goto 9999
!!$ end if
!!$ nrow = desc_a%get_local_rows()
!!$ ncol = desc_a%get_local_cols()
!!$
!!$ if (a%is_bld()) then
!!$ call a%csput(nz,ila,jla,val,ione,nrow,ione,ncol,info)
!!$ if (info /= psb_success_) then
!!$ info=psb_err_from_subroutine_
!!$ call psb_errpush(info,name,a_err='a%csput')
!!$ goto 9999
!!$ end if
!!$ else
!!$ info = psb_err_invalid_a_and_cd_state_
!!$ call psb_errpush(info,name)
!!$ goto 9999
!!$ end if
!!$ endif
else if (desc_a%is_asb()) then
nrow = desc_a%get_local_rows()
ncol = desc_a%get_local_cols()
if (local_) then
call a%csput(nz,ia,ja,val,ione,nrow,ione,ncol,info)
if (info /= psb_success_) then
info=psb_err_from_subroutine_
call psb_errpush(info,name,a_err='a%csput')
goto 9999
end if
else
info = psb_err_invalid_cd_state_
!!$ allocate(ila(nz),jla(nz),stat=info)
!!$ if (info /= psb_success_) then
!!$ ierr(1) = info
!!$ call psb_errpush(psb_err_from_subroutine_ai_,name,&
!!$ & a_err='allocate',i_err=ierr)
!!$ goto 9999
!!$ end if
!!$
!!$ call desc_a%indxmap%g2l(ia(1:nz),ila(1:nz),info)
!!$ if (info == 0) call desc_a%indxmap%g2l(ja(1:nz),jla(1:nz),info)
!!$ if (info == 0) call a%csput(nz,ila,jla,val,ione,nrow,ione,ncol,info)
!!$ if (info /= psb_success_) then
!!$ info=psb_err_from_subroutine_
!!$ call psb_errpush(info,name,a_err='a%csput')
!!$ goto 9999
!!$ end if
end if
else
info = psb_err_invalid_cd_state_
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(ictxt)
return
end if
return
end subroutine psb_zspins_v
test/pargen/runs/ppde.inp
+1 -1
View File
@@ -1,6 +1,6 @@
7 Number of entries below this
BICGSTAB Iterative method BICGSTAB CGS BICG BICGSTABL RGMRES
DIAG Preconditioner NONE DIAG BJAC
BJAC Preconditioner NONE DIAG BJAC
CSR Storage format for matrix A: CSR COO JAD
050 Domain size (acutal system is this**3)
2 Stopping criterion