fdurastante
/
psblas3
mirror of https://github.com/sfilippone/psblas3.git
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity

psblas3:

Browse Source 
base/modules/Makefile
 base/modules/psb_base_mat_mod.f03
 base/modules/psb_d_base_mat_mod.f03
 base/modules/psb_linmap_mod.f90
 base/modules/psb_linmap_type_mod.f90
 base/modules/psb_psblas_mod.f90
 base/modules/psb_s_base_mat_mod.f03
 base/modules/psb_serial_mod.f90
 base/modules/psb_spmat_type.f03
 base/modules/psb_tools_mod.f90
 base/modules/psi_serial_mod.f90
 base/psblas/psb_dnrmi.f90
 base/psblas/psb_dspmm.f90
 base/psblas/psb_dspsm.f90
 base/psblas/psb_snrmi.f90
 base/psblas/psb_sspmm.f90
 base/psblas/psb_sspsm.f90
 base/serial/Makefile
 base/serial/coo/Makefile
 base/serial/csr/Makefile
 base/serial/dp/Makefile
 base/serial/f03/psb_d_csr_impl.f03
 base/serial/f03/psb_s_csr_impl.f03
 base/serial/f77/Makefile
 base/serial/jad/Makefile
 base/serial/psb_getrow_mod.f90
 base/serial/psb_regen_mod.f90
 base/serial/psb_update_mod.f90
 base/tools/psb_dcdbldext.F90
 base/tools/psb_dspalloc.f90
 base/tools/psb_dspasb.f90
 base/tools/psb_dspfree.f90
 base/tools/psb_dspins.f90
 base/tools/psb_linmap.f90
 base/tools/psb_scdbldext.F90
 base/tools/psb_sspalloc.f90
 base/tools/psb_sspasb.f90
 base/tools/psb_sspfree.f90
 base/tools/psb_ssphalo.F90
 base/tools/psb_sspins.f90
 base/tools/psb_ssprn.f90
 krylov/psb_krylov_mod.f90
 krylov/psb_sbicg.f90
 krylov/psb_scg.F90
 krylov/psb_scgs.f90
 krylov/psb_scgstab.F90
 krylov/psb_scgstabl.f90
 krylov/psb_srgmres.f90
 prec/psb_dbjac_aply.f90
 prec/psb_dbjac_bld.f90
 prec/psb_ddiagsc_bld.f90
 prec/psb_dilu_fct.f90
 prec/psb_dprecbld.f90
 prec/psb_prec_mod.f90
 prec/psb_prec_type.f90
 prec/psb_sbjac_aply.f90
 prec/psb_sbjac_bld.f90
 prec/psb_sdiagsc_bld.f90
 prec/psb_silu_fct.f90
 prec/psb_sprecbld.f90
 test/pargen/Makefile
 test/pargen/ppde.f90
 test/pargen/runs/ppde.inp
 test/pargen/spde.f90
 util/psb_hbio_mod.f90
 util/psb_mat_dist_mod.f90
 util/psb_metispart_mod.F90
 util/psb_mmio_mod.f90

Single precision version. At least, up to working pargen examples..
psblas3-type-indexed
Salvatore Filippone 16 years ago
parent 052a1751ef
commit 7cc636302a
68 changed files with 3934 additions and 3724 deletions
Show Stats Download Patch File Download Diff File

4
base/modules/Makefile
Unescape Escape View File

@ -27,7 +27,7 @@ lib: $(BASIC_MODS) blacsmod $(UTIL_MODS) $(OBJS) $(LIBMOD)
/bin/cp -p *$(.mod) $(LIBDIR)
psb_base_mat_mod.o: psb_string_mod.o psb_sort_mod.o psb_ip_reord_mod.o psb_error_mod.o
psb_base_mat_mod.o: psb_string_mod.o psb_sort_mod.o psb_ip_reord_mod.o psb_error_mod.o psi_serial_mod.o
psb_s_base_mat_mod.o psb_d_base_mat_mod.o: psb_base_mat_mod.o
psb_s_mat_mod.o: psb_s_base_mat_mod.o psb_s_csr_mat_mod.o
psb_d_mat_mod.o: psb_d_base_mat_mod.o psb_d_csr_mat_mod.o
@ -41,7 +41,7 @@ psb_blacs_mod.o: psb_const_mod.o
psi_serial_mod.o: psb_const_mod.o psb_realloc_mod.o
psi_mod.o: psb_penv_mod.o psb_error_mod.o psb_desc_type.o psb_const_mod.o psi_serial_mod.o psb_serial_mod.o
psb_desc_type.o: psb_const_mod.o psb_error_mod.o psb_penv_mod.o psb_realloc_mod.o psb_hash_mod.o
psb_linmap_mod.o: psb_linmap_type_mod.o psb_mat_mod.o
psb_linmap_mod.o: psb_linmap_type_mod.o psb_mat_mod.o
psb_linmap_type_mod.o: psb_desc_type.o psb_spmat_type.o psb_error_mod.o psb_serial_mod.o psb_comm_mod.o psb_mat_mod.o
psb_check_mod.o: psb_desc_type.o
psb_serial_mod.o: psb_spmat_type.o psb_string_mod.o psb_sort_mod.o psi_serial_mod.o

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

@ -1,6 +1,7 @@
module psb_base_mat_mod
use psb_const_mod
use psi_serial_mod
type :: psb_base_sparse_mat
integer, private :: m, n

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

@ -995,7 +995,7 @@ contains
end do
end if
if (info == 0)&
& call daxpby(nar,nc,alpha,tmp,size(tmp,1),beta,y,size(y,1),info)
& call psb_geaxpby(nar,nc,alpha,tmp,beta,y,info)
if (info == 0) then
deallocate(tmp,stat=info)
@ -1120,7 +1120,7 @@ contains
if (info == 0) tmp(1:nar) = d(1:nar)*tmp(1:nar)
if (info == 0)&
& call daxpby(nar,nc,alpha,tmp,size(tmp,1),beta,y,size(y,1),info)
& call psb_geaxpby(nar,alpha,tmp,beta,y,info)
if (info == 0) then
deallocate(tmp,stat=info)

13
base/modules/psb_linmap_mod.f90
Unescape Escape View File

@ -37,8 +37,7 @@
!
module psb_linmap_mod
use psb_spmat_type, only : psb_sspmat_type, &
& psb_cspmat_type, psb_zspmat_type, psb_spk_, psb_dpk_, psb_sizeof
use psb_spmat_type, only : psb_cspmat_type, psb_zspmat_type, psb_spk_, psb_dpk_, psb_sizeof
use psb_descriptor_type
use psb_linmap_type_mod
@ -166,7 +165,7 @@ module psb_linmap_mod
implicit none
type(psb_slinmap_type) :: psb_s_linmap
type(psb_desc_type), target :: desc_X, desc_Y
type(psb_sspmat_type), intent(in) :: map_X2Y, map_Y2X
type(psb_s_sparse_mat), intent(in) :: map_X2Y, map_Y2X
integer, intent(in) :: map_kind
integer, intent(in), optional :: iaggr(:), naggr(:)
end function psb_s_linmap
@ -452,6 +451,7 @@ contains
function psb_slinmap_sizeof(map) result(val)
use psb_mat_mod
implicit none
type(psb_slinmap_type), intent(in) :: map
integer(psb_long_int_k_) :: val
@ -471,7 +471,7 @@ contains
end function psb_slinmap_sizeof
function psb_dlinmap_sizeof(map) result(val)
use psb_d_mat_mod
use psb_mat_mod
implicit none
type(psb_dlinmap_type), intent(in) :: map
integer(psb_long_int_k_) :: val
@ -534,7 +534,7 @@ contains
implicit none
type(psb_slinmap_type), intent(out) :: out_map
type(psb_desc_type), target :: desc_X, desc_Y
type(psb_sspmat_type), intent(in) :: map_X2Y, map_Y2X
type(psb_s_sparse_mat), intent(in) :: map_X2Y, map_Y2X
integer, intent(in) :: map_kind
integer, intent(in), optional :: iaggr(:), naggr(:)
out_map = psb_linmap(map_kind,desc_X,desc_Y,map_X2Y,map_Y2X,iaggr,naggr)
@ -575,8 +575,9 @@ contains
subroutine psb_slinmap_transfer(mapin,mapout,info)
use psb_spmat_type
use psb_realloc_mod
use psb_descriptor_type
use psb_mat_mod
implicit none
type(psb_slinmap_type) :: mapin,mapout
integer, intent(out) :: info

15
base/modules/psb_linmap_type_mod.f90
Unescape Escape View File

@ -36,10 +36,9 @@
! to different spaces.
!
module psb_linmap_type_mod
use psb_spmat_type, only : psb_sspmat_type, &
& psb_cspmat_type, psb_zspmat_type, psb_spk_, psb_dpk_, psb_sizeof
use psb_spmat_type, only : psb_cspmat_type, psb_zspmat_type, psb_spk_, psb_dpk_, psb_sizeof
use psb_d_mat_mod, only: psb_d_sparse_mat
use psb_mat_mod, only: psb_d_sparse_mat, psb_s_sparse_mat
use psb_descriptor_type, only: psb_desc_type
@ -56,16 +55,16 @@ module psb_linmap_type_mod
type psb_slinmap_type
integer, allocatable :: itd_data(:), iaggr(:), naggr(:)
integer, allocatable :: itd_data(:), iaggr(:), naggr(:)
type(psb_desc_type), pointer :: p_desc_X=>null(), p_desc_Y=>null()
type(psb_desc_type) :: desc_X, desc_Y
type(psb_sspmat_type) :: map_X2Y, map_Y2X
type(psb_desc_type) :: desc_X, desc_Y
type(psb_s_sparse_mat) :: map_X2Y, map_Y2X
end type psb_slinmap_type
type psb_dlinmap_type
integer, allocatable :: itd_data(:), iaggr(:), naggr(:)
integer, allocatable :: itd_data(:), iaggr(:), naggr(:)
type(psb_desc_type), pointer :: p_desc_X=>null(), p_desc_Y=>null()
type(psb_desc_type) :: desc_X, desc_Y
type(psb_desc_type) :: desc_X, desc_Y
type(psb_d_sparse_mat) :: map_X2Y, map_Y2X
end type psb_dlinmap_type

49
base/modules/psb_psblas_mod.f90
Unescape Escape View File

@ -581,18 +581,19 @@ module psb_psblas_mod
function psb_snrmi(a, desc_a,info)
use psb_serial_mod
use psb_descriptor_type
real(psb_spk_) :: psb_snrmi
type(psb_sspmat_type), intent (in) :: a
type(psb_desc_type), intent (in) :: desc_a
use psb_mat_mod
real(psb_spk_) :: psb_snrmi
type(psb_s_sparse_mat), intent (in) :: a
type(psb_desc_type), intent (in) :: desc_a
integer, intent(out) :: info
end function psb_snrmi
function psb_dnrmi(a, desc_a,info)
use psb_serial_mod
use psb_descriptor_type
use psb_d_mat_mod
real(psb_dpk_) :: psb_dnrmi
use psb_mat_mod
real(psb_dpk_) :: psb_dnrmi
type(psb_d_sparse_mat), intent (in) :: a
type(psb_desc_type), intent (in) :: desc_a
type(psb_desc_type), intent (in) :: desc_a
integer, intent(out) :: info
end function psb_dnrmi
function psb_cnrmi(a, desc_a,info)
@ -618,7 +619,8 @@ module psb_psblas_mod
&trans, k, jx, jy,work,doswap)
use psb_serial_mod
use psb_descriptor_type
type(psb_sspmat_type), intent(in) :: a
use psb_mat_mod
type(psb_s_sparse_mat), intent(in) :: a
real(psb_spk_), intent(inout) :: x(:,:)
real(psb_spk_), intent(inout) :: y(:,:)
real(psb_spk_), intent(in) :: alpha, beta
@ -633,7 +635,8 @@ module psb_psblas_mod
& desc_a, info, trans, work,doswap)
use psb_serial_mod
use psb_descriptor_type
type(psb_sspmat_type), intent(in) :: a
use psb_mat_mod
type(psb_s_sparse_mat), intent(in) :: a
real(psb_spk_), intent(inout) :: x(:)
real(psb_spk_), intent(inout) :: y(:)
real(psb_spk_), intent(in) :: alpha, beta
@ -647,7 +650,7 @@ module psb_psblas_mod
&trans, k, jx, jy,work,doswap)
use psb_serial_mod
use psb_descriptor_type
use psb_d_mat_mod
use psb_mat_mod
type(psb_d_sparse_mat), intent(in) :: a
real(psb_dpk_), intent(inout) :: x(:,:)
real(psb_dpk_), intent(inout) :: y(:,:)
@ -663,7 +666,7 @@ module psb_psblas_mod
& desc_a, info, trans, work,doswap)
use psb_serial_mod
use psb_descriptor_type
use psb_d_mat_mod
use psb_mat_mod
type(psb_d_sparse_mat), intent(in) :: a
real(psb_dpk_), intent(inout) :: x(:)
real(psb_dpk_), intent(inout) :: y(:)
@ -736,65 +739,67 @@ module psb_psblas_mod
interface psb_spsm
subroutine psb_sspsm(alpha, t, x, beta, y,&
& desc_a, info, trans, unit, choice,&
& desc_a, info, trans, side, choice,&
& diag, n, jx, jy, work)
use psb_serial_mod
use psb_descriptor_type
type(psb_sspmat_type), intent(in) :: t
use psb_mat_mod
type(psb_s_sparse_mat), intent(in) :: t
real(psb_spk_), intent(in) :: x(:,:)
real(psb_spk_), intent(inout) :: y(:,:)
real(psb_spk_), intent(in) :: alpha, beta
type(psb_desc_type), intent(in) :: desc_a
character, optional, intent(in) :: trans, unit
character, optional, intent(in) :: trans, side
integer, optional, intent(in) :: n, jx, jy
integer, optional, intent(in) :: choice
real(psb_spk_), optional, intent(in),target :: work(:), diag(:)
integer, intent(out) :: info
end subroutine psb_sspsm
subroutine psb_sspsv(alpha, t, x, beta, y,&
& desc_a, info, trans, unit, choice,&
& desc_a, info, trans, side, choice,&
& diag, work)
use psb_serial_mod
use psb_descriptor_type
type(psb_sspmat_type), intent(in) :: t
use psb_mat_mod
type(psb_s_sparse_mat), intent(in) :: t
real(psb_spk_), intent(in) :: x(:)
real(psb_spk_), intent(inout) :: y(:)
real(psb_spk_), intent(in) :: alpha, beta
type(psb_desc_type), intent(in) :: desc_a
character, optional, intent(in) :: trans, unit
character, optional, intent(in) :: trans, side
integer, optional, intent(in) :: choice
real(psb_spk_), optional, intent(in),target :: work(:), diag(:)
integer, intent(out) :: info
end subroutine psb_sspsv
subroutine psb_dspsm(alpha, t, x, beta, y,&
& desc_a, info, trans, unit, choice,&
& desc_a, info, trans, side, choice,&
& diag, n, jx, jy, work)
use psb_serial_mod
use psb_descriptor_type
use psb_d_mat_mod
use psb_mat_mod
type(psb_d_sparse_mat), intent(in) :: t
real(psb_dpk_), intent(in) :: x(:,:)
real(psb_dpk_), intent(inout) :: y(:,:)
real(psb_dpk_), intent(in) :: alpha, beta
type(psb_desc_type), intent(in) :: desc_a
character, optional, intent(in) :: trans, unit
character, optional, intent(in) :: trans, side
integer, optional, intent(in) :: n, jx, jy
integer, optional, intent(in) :: choice
real(psb_dpk_), optional, intent(in),target :: work(:), diag(:)
integer, intent(out) :: info
end subroutine psb_dspsm
subroutine psb_dspsv(alpha, t, x, beta, y,&
& desc_a, info, trans, unit, choice,&
& desc_a, info, trans, side, choice,&
& diag, work)
use psb_serial_mod
use psb_descriptor_type
use psb_d_mat_mod
use psb_mat_mod
type(psb_d_sparse_mat), intent(in) :: t
real(psb_dpk_), intent(in) :: x(:)
real(psb_dpk_), intent(inout) :: y(:)
real(psb_dpk_), intent(in) :: alpha, beta
type(psb_desc_type), intent(in) :: desc_a
character, optional, intent(in) :: trans, unit
character, optional, intent(in) :: trans, side
integer, optional, intent(in) :: choice
real(psb_dpk_), optional, intent(in),target :: work(:), diag(:)
integer, intent(out) :: info

4
base/modules/psb_s_base_mat_mod.f03
Unescape Escape View File

@ -995,7 +995,7 @@ contains
end do
end if
if (info == 0)&
& call daxpby(nar,nc,alpha,tmp,size(tmp,1),beta,y,size(y,1),info)
& call psb_geaxpby(nar,nc,alpha,tmp,beta,y,info)
if (info == 0) then
deallocate(tmp,stat=info)
@ -1120,7 +1120,7 @@ contains
if (info == 0) tmp(1:nar) = d(1:nar)*tmp(1:nar)
if (info == 0)&
& call daxpby(nar,nc,alpha,tmp,size(tmp,1),beta,y,size(y,1),info)
& call psb_geaxpby(nar,alpha,tmp,beta,y,info)
if (info == 0) then
deallocate(tmp,stat=info)

569
base/modules/psb_serial_mod.f90
Unescape Escape View File

@ -49,8 +49,7 @@ module psb_serial_mod
!!$ character, optional :: trans
!!$ end subroutine psb_dcsrws
subroutine psb_zcsrws(rw,a,info,trans)
use psb_spmat_type, only : psb_sspmat_type, &
& psb_cspmat_type, psb_zspmat_type, psb_spk_, psb_dpk_
use psb_spmat_type, only : psb_cspmat_type, psb_zspmat_type, psb_spk_, psb_dpk_
type(psb_zspmat_type) :: a
complex(psb_dpk_), allocatable :: rw(:)
integer :: info
@ -211,23 +210,23 @@ module psb_serial_mod
end interface
interface psb_spcnv
subroutine psb_sspcnv2(ain, a, info, afmt, upd, dupl)
use psb_spmat_type, only : psb_sspmat_type, &
& psb_cspmat_type, psb_zspmat_type, psb_spk_, psb_dpk_
type(psb_sspmat_type), intent (in) :: ain
type(psb_sspmat_type), intent (out) :: a
integer, intent(out) :: info
integer,optional, intent(in) :: dupl, upd
character(len=*), optional, intent(in) :: afmt
end subroutine psb_sspcnv2
subroutine psb_sspcnv1(a, info, afmt, upd, dupl)
use psb_spmat_type, only : psb_sspmat_type, &
& psb_cspmat_type, psb_zspmat_type, psb_spk_, psb_dpk_
type(psb_sspmat_type), intent (inout) :: a
integer, intent(out) :: info
integer,optional, intent(in) :: dupl, upd
character(len=*), optional, intent(in) :: afmt
end subroutine psb_sspcnv1
!!$ subroutine psb_sspcnv2(ain, a, info, afmt, upd, dupl)
!!$ use psb_spmat_type, only : psb_sspmat_type, &
!!$ & psb_cspmat_type, psb_zspmat_type, psb_spk_, psb_dpk_
!!$ type(psb_sspmat_type), intent (in) :: ain
!!$ type(psb_sspmat_type), intent (out) :: a
!!$ integer, intent(out) :: info
!!$ integer,optional, intent(in) :: dupl, upd
!!$ character(len=*), optional, intent(in) :: afmt
!!$ end subroutine psb_sspcnv2
!!$ subroutine psb_sspcnv1(a, info, afmt, upd, dupl)
!!$ use psb_spmat_type, only : psb_sspmat_type, &
!!$ & psb_cspmat_type, psb_zspmat_type, psb_spk_, psb_dpk_
!!$ type(psb_sspmat_type), intent (inout) :: a
!!$ integer, intent(out) :: info
!!$ integer,optional, intent(in) :: dupl, upd
!!$ character(len=*), optional, intent(in) :: afmt
!!$ end subroutine psb_sspcnv1
!!$ subroutine psb_dspcnv2(ain, a, info, afmt, upd, dupl)
!!$ use psb_spmat_type, only : psb_sspmat_type, psb_dspmat_type,&
!!$ & psb_cspmat_type, psb_zspmat_type, psb_spk_, psb_dpk_
@ -246,8 +245,7 @@ module psb_serial_mod
!!$ character(len=*), optional, intent(in) :: afmt
!!$ end subroutine psb_dspcnv1
subroutine psb_cspcnv2(ain, a, info, afmt, upd, dupl)
use psb_spmat_type, only : psb_sspmat_type, &
& psb_cspmat_type, psb_zspmat_type, psb_spk_, psb_dpk_
use psb_spmat_type, only : psb_cspmat_type, psb_zspmat_type, psb_spk_, psb_dpk_
type(psb_cspmat_type), intent (in) :: ain
type(psb_cspmat_type), intent (out) :: a
integer, intent(out) :: info
@ -255,16 +253,14 @@ module psb_serial_mod
character(len=*), optional, intent(in) :: afmt
end subroutine psb_cspcnv2
subroutine psb_cspcnv1(a, info, afmt, upd, dupl)
use psb_spmat_type, only : psb_sspmat_type, &
& psb_cspmat_type, psb_zspmat_type, psb_spk_, psb_dpk_
use psb_spmat_type, only : psb_cspmat_type, psb_zspmat_type, psb_spk_, psb_dpk_
type(psb_cspmat_type), intent (inout) :: a
integer, intent(out) :: info
integer,optional, intent(in) :: dupl, upd
character(len=*), optional, intent(in) :: afmt
end subroutine psb_cspcnv1
subroutine psb_zspcnv2(ain, a, info, afmt, upd, dupl)
use psb_spmat_type, only : psb_sspmat_type, &
& psb_cspmat_type, psb_zspmat_type, psb_spk_, psb_dpk_
use psb_spmat_type, only : psb_cspmat_type, psb_zspmat_type, psb_spk_, psb_dpk_
type(psb_zspmat_type), intent (in) :: ain
type(psb_zspmat_type), intent (out) :: a
integer, intent(out) :: info
@ -272,8 +268,7 @@ module psb_serial_mod
character(len=*), optional, intent(in) :: afmt
end subroutine psb_zspcnv2
subroutine psb_zspcnv1(a, info, afmt, upd, dupl)
use psb_spmat_type, only : psb_sspmat_type, &
& psb_cspmat_type, psb_zspmat_type, psb_spk_, psb_dpk_
use psb_spmat_type, only : psb_cspmat_type, psb_zspmat_type, psb_spk_, psb_dpk_
type(psb_zspmat_type), intent (inout) :: a
integer, intent(out) :: info
integer,optional, intent(in) :: dupl, upd
@ -284,13 +279,13 @@ module psb_serial_mod
interface psb_fixcoo
subroutine psb_sfixcoo(a,info,idir)
use psb_spmat_type, only : psb_sspmat_type, &
& psb_cspmat_type, psb_zspmat_type, psb_spk_, psb_dpk_
type(psb_sspmat_type), intent(inout) :: a
integer, intent(out) :: info
integer, intent(in), optional :: idir
end subroutine psb_sfixcoo
!!$ subroutine psb_sfixcoo(a,info,idir)
!!$ use psb_spmat_type, only : psb_sspmat_type, &
!!$ & psb_cspmat_type, psb_zspmat_type, psb_spk_, psb_dpk_
!!$ type(psb_sspmat_type), intent(inout) :: a
!!$ integer, intent(out) :: info
!!$ integer, intent(in), optional :: idir
!!$ end subroutine psb_sfixcoo
!!$ subroutine psb_dfixcoo(a,info,idir)
!!$ use psb_spmat_type, only : psb_sspmat_type, psb_dspmat_type,&
!!$ & psb_cspmat_type, psb_zspmat_type, psb_spk_, psb_dpk_
@ -299,15 +294,13 @@ module psb_serial_mod
!!$ integer, intent(in), optional :: idir
!!$ end subroutine psb_dfixcoo
subroutine psb_cfixcoo(a,info,idir)
use psb_spmat_type, only : psb_sspmat_type, &
& psb_cspmat_type, psb_zspmat_type, psb_spk_, psb_dpk_
use psb_spmat_type, only : psb_cspmat_type, psb_zspmat_type, psb_spk_, psb_dpk_
type(psb_cspmat_type), intent(inout) :: a
integer, intent(out) :: info
integer, intent(in), optional :: idir
end subroutine psb_cfixcoo
subroutine psb_zfixcoo(a,info,idir)
use psb_spmat_type, only : psb_sspmat_type, &
& psb_cspmat_type, psb_zspmat_type, psb_spk_, psb_dpk_
use psb_spmat_type, only : psb_cspmat_type, psb_zspmat_type, psb_spk_, psb_dpk_
type(psb_zspmat_type), intent(inout) :: a
integer, intent(out) :: info
integer, intent(in), optional :: idir
@ -315,13 +308,13 @@ module psb_serial_mod
end interface
interface psb_ipcoo2csr
subroutine psb_sipcoo2csr(a,info,rwshr)
use psb_spmat_type, only : psb_sspmat_type, &
& psb_cspmat_type, psb_zspmat_type, psb_spk_, psb_dpk_
type(psb_sspmat_type), intent(inout) :: a
integer, intent(out) :: info
logical, optional :: rwshr
end subroutine psb_sipcoo2csr
!!$ subroutine psb_sipcoo2csr(a,info,rwshr)
!!$ use psb_spmat_type, only : psb_sspmat_type, &
!!$ & psb_cspmat_type, psb_zspmat_type, psb_spk_, psb_dpk_
!!$ type(psb_sspmat_type), intent(inout) :: a
!!$ integer, intent(out) :: info
!!$ logical, optional :: rwshr
!!$ end subroutine psb_sipcoo2csr
!!$ subroutine psb_dipcoo2csr(a,info,rwshr)
!!$ use psb_spmat_type, only : psb_sspmat_type, psb_dspmat_type,&
!!$ & psb_cspmat_type, psb_zspmat_type, psb_spk_, psb_dpk_
@ -330,15 +323,13 @@ module psb_serial_mod
!!$ logical, optional :: rwshr
!!$ end subroutine psb_dipcoo2csr
subroutine psb_cipcoo2csr(a,info,rwshr)
use psb_spmat_type, only : psb_sspmat_type, &
& psb_cspmat_type, psb_zspmat_type, psb_spk_, psb_dpk_
use psb_spmat_type, only : psb_cspmat_type, psb_zspmat_type, psb_spk_, psb_dpk_
type(psb_cspmat_type), intent(inout) :: a
integer, intent(out) :: info
logical, optional :: rwshr
end subroutine psb_cipcoo2csr
subroutine psb_zipcoo2csr(a,info,rwshr)
use psb_spmat_type, only : psb_sspmat_type, &
& psb_cspmat_type, psb_zspmat_type, psb_spk_, psb_dpk_
use psb_spmat_type, only : psb_cspmat_type, psb_zspmat_type, psb_spk_, psb_dpk_
type(psb_zspmat_type), intent(inout) :: a
integer, intent(out) :: info
logical, optional :: rwshr
@ -346,13 +337,13 @@ module psb_serial_mod
end interface
interface psb_ipcoo2csc
subroutine psb_sipcoo2csc(a,info,clshr)
use psb_spmat_type, only : psb_sspmat_type, &
& psb_cspmat_type, psb_zspmat_type, psb_spk_, psb_dpk_
type(psb_sspmat_type), intent(inout) :: a
integer, intent(out) :: info
logical, optional :: clshr
end subroutine psb_sipcoo2csc
!!$ subroutine psb_sipcoo2csc(a,info,clshr)
!!$ use psb_spmat_type, only : psb_sspmat_type, &
!!$ & psb_cspmat_type, psb_zspmat_type, psb_spk_, psb_dpk_
!!$ type(psb_sspmat_type), intent(inout) :: a
!!$ integer, intent(out) :: info
!!$ logical, optional :: clshr
!!$ end subroutine psb_sipcoo2csc
!!$ subroutine psb_dipcoo2csc(a,info,clshr)
!!$ use psb_spmat_type, only : psb_sspmat_type, psb_dspmat_type,&
!!$ & psb_cspmat_type, psb_zspmat_type, psb_spk_, psb_dpk_
@ -361,15 +352,13 @@ module psb_serial_mod
!!$ logical, optional :: clshr
!!$ end subroutine psb_dipcoo2csc
subroutine psb_cipcoo2csc(a,info,clshr)
use psb_spmat_type, only : psb_sspmat_type, &
& psb_cspmat_type, psb_zspmat_type, psb_spk_, psb_dpk_
use psb_spmat_type, only : psb_cspmat_type, psb_zspmat_type, psb_spk_, psb_dpk_
type(psb_cspmat_type), intent(inout) :: a
integer, intent(out) :: info
logical, optional :: clshr
end subroutine psb_cipcoo2csc
subroutine psb_zipcoo2csc(a,info,clshr)
use psb_spmat_type, only : psb_sspmat_type, &
& psb_cspmat_type, psb_zspmat_type, psb_spk_, psb_dpk_
use psb_spmat_type, only : psb_cspmat_type, psb_zspmat_type, psb_spk_, psb_dpk_
type(psb_zspmat_type), intent(inout) :: a
integer, intent(out) :: info
logical, optional :: clshr
@ -377,12 +366,12 @@ module psb_serial_mod
end interface
interface psb_ipcsr2coo
subroutine psb_sipcsr2coo(a,info)
use psb_spmat_type, only : psb_sspmat_type, &
& psb_cspmat_type, psb_zspmat_type, psb_spk_, psb_dpk_
type(psb_sspmat_type), intent(inout) :: a
integer, intent(out) :: info
end subroutine psb_sipcsr2coo
!!$ subroutine psb_sipcsr2coo(a,info)
!!$ use psb_spmat_type, only : psb_sspmat_type, &
!!$ & psb_cspmat_type, psb_zspmat_type, psb_spk_, psb_dpk_
!!$ type(psb_sspmat_type), intent(inout) :: a
!!$ integer, intent(out) :: info
!!$ end subroutine psb_sipcsr2coo
!!$ subroutine psb_dipcsr2coo(a,info)
!!$ use psb_spmat_type, only : psb_sspmat_type, psb_dspmat_type,&
!!$ & psb_cspmat_type, psb_zspmat_type, psb_spk_, psb_dpk_
@ -390,30 +379,28 @@ module psb_serial_mod
!!$ integer, intent(out) :: info
!!$ end subroutine psb_dipcsr2coo
subroutine psb_cipcsr2coo(a,info)
use psb_spmat_type, only : psb_sspmat_type, &
& psb_cspmat_type, psb_zspmat_type, psb_spk_, psb_dpk_
use psb_spmat_type, only : psb_cspmat_type, psb_zspmat_type, psb_spk_, psb_dpk_
type(psb_cspmat_type), intent(inout) :: a
integer, intent(out) :: info
end subroutine psb_cipcsr2coo
subroutine psb_zipcsr2coo(a,info)
use psb_spmat_type, only : psb_sspmat_type, &
& psb_cspmat_type, psb_zspmat_type, psb_spk_, psb_dpk_
use psb_spmat_type, only : psb_cspmat_type, psb_zspmat_type, psb_spk_, psb_dpk_
type(psb_zspmat_type), intent(inout) :: a
integer, intent(out) :: info
end subroutine psb_zipcsr2coo
end interface
interface psb_csprt
subroutine psb_scsprt(iout,a,iv,irs,ics,head,ivr,ivc)
use psb_spmat_type, only : psb_sspmat_type, &
& psb_cspmat_type, psb_zspmat_type, psb_spk_, psb_dpk_
integer, intent(in) :: iout
type(psb_sspmat_type), intent(in) :: a
integer, intent(in), optional :: iv(:)
integer, intent(in), optional :: irs,ics
character(len=*), optional :: head
integer, intent(in), optional :: ivr(:),ivc(:)
end subroutine psb_scsprt
!!$ subroutine psb_scsprt(iout,a,iv,irs,ics,head,ivr,ivc)
!!$ use psb_spmat_type, only : psb_sspmat_type, &
!!$ & psb_cspmat_type, psb_zspmat_type, psb_spk_, psb_dpk_
!!$ integer, intent(in) :: iout
!!$ type(psb_sspmat_type), intent(in) :: a
!!$ integer, intent(in), optional :: iv(:)
!!$ integer, intent(in), optional :: irs,ics
!!$ character(len=*), optional :: head
!!$ integer, intent(in), optional :: ivr(:),ivc(:)
!!$ end subroutine psb_scsprt
!!$ subroutine psb_dcsprt(iout,a,iv,irs,ics,head,ivr,ivc)
!!$ use psb_spmat_type, only : psb_sspmat_type, psb_dspmat_type,&
!!$ & psb_cspmat_type, psb_zspmat_type, psb_spk_, psb_dpk_
@ -425,8 +412,7 @@ module psb_serial_mod
!!$ integer, intent(in), optional :: ivr(:),ivc(:)
!!$ end subroutine psb_dcsprt
subroutine psb_ccsprt(iout,a,iv,irs,ics,head,ivr,ivc)
use psb_spmat_type, only : psb_sspmat_type, &
& psb_cspmat_type, psb_zspmat_type, psb_spk_, psb_dpk_
use psb_spmat_type, only : psb_cspmat_type, psb_zspmat_type, psb_spk_, psb_dpk_
integer, intent(in) :: iout
type(psb_cspmat_type), intent(in) :: a
integer, intent(in), optional :: iv(:)
@ -435,8 +421,7 @@ module psb_serial_mod
integer, intent(in), optional :: ivr(:),ivc(:)
end subroutine psb_ccsprt
subroutine psb_zcsprt(iout,a,iv,irs,ics,head,ivr,ivc)
use psb_spmat_type, only : psb_sspmat_type, &
& psb_cspmat_type, psb_zspmat_type, psb_spk_, psb_dpk_
use psb_spmat_type, only : psb_cspmat_type, psb_zspmat_type, psb_spk_, psb_dpk_
integer, intent(in) :: iout
type(psb_zspmat_type), intent(in) :: a
integer, intent(in), optional :: iv(:)
@ -447,16 +432,16 @@ module psb_serial_mod
end interface
interface psb_neigh
subroutine psb_sneigh(a,idx,neigh,n,info,lev)
use psb_spmat_type, only : psb_sspmat_type, &
& psb_cspmat_type, psb_zspmat_type, psb_spk_, psb_dpk_
type(psb_sspmat_type), intent(in) :: a
integer, intent(in) :: idx
integer, intent(out) :: n
integer, allocatable :: neigh(:)
integer, intent(out) :: info
integer, optional, intent(in) :: lev
end subroutine psb_sneigh
!!$ subroutine psb_sneigh(a,idx,neigh,n,info,lev)
!!$ use psb_spmat_type, only : psb_sspmat_type, &
!!$ & psb_cspmat_type, psb_zspmat_type, psb_spk_, psb_dpk_
!!$ type(psb_sspmat_type), intent(in) :: a
!!$ integer, intent(in) :: idx
!!$ integer, intent(out) :: n
!!$ integer, allocatable :: neigh(:)
!!$ integer, intent(out) :: info
!!$ integer, optional, intent(in) :: lev
!!$ end subroutine psb_sneigh
!!$ subroutine psb_dneigh(a,idx,neigh,n,info,lev)
!!$ use psb_spmat_type, only : psb_sspmat_type, psb_dspmat_type,&
!!$ & psb_cspmat_type, psb_zspmat_type, psb_spk_, psb_dpk_
@ -468,8 +453,7 @@ module psb_serial_mod
!!$ integer, optional, intent(in) :: lev
!!$ end subroutine psb_dneigh
subroutine psb_cneigh(a,idx,neigh,n,info,lev)
use psb_spmat_type, only : psb_sspmat_type, &
& psb_cspmat_type, psb_zspmat_type, psb_spk_, psb_dpk_
use psb_spmat_type, only : psb_cspmat_type, psb_zspmat_type, psb_spk_, psb_dpk_
type(psb_cspmat_type), intent(in) :: a
integer, intent(in) :: idx
integer, intent(out) :: n
@ -478,8 +462,7 @@ module psb_serial_mod
integer, optional, intent(in) :: lev
end subroutine psb_cneigh
subroutine psb_zneigh(a,idx,neigh,n,info,lev)
use psb_spmat_type, only : psb_sspmat_type, &
& psb_cspmat_type, psb_zspmat_type, psb_spk_, psb_dpk_
use psb_spmat_type, only : psb_cspmat_type, psb_zspmat_type, psb_spk_, psb_dpk_
type(psb_zspmat_type), intent(in) :: a
integer, intent(in) :: idx
integer, intent(out) :: n
@ -490,17 +473,17 @@ module psb_serial_mod
end interface
interface psb_coins
subroutine psb_scoins(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl,rebuild)
use psb_spmat_type, only : psb_sspmat_type, &
& psb_cspmat_type, psb_zspmat_type, psb_spk_, psb_dpk_
integer, intent(in) :: nz, imin,imax,jmin,jmax
integer, intent(in) :: ia(:),ja(:)
real(psb_spk_), intent(in) :: val(:)
type(psb_sspmat_type), intent(inout) :: a
integer, intent(out) :: info
integer, intent(in), optional :: gtl(:)
logical, optional, intent(in) :: rebuild
end subroutine psb_scoins
!!$ subroutine psb_scoins(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl,rebuild)
!!$ use psb_spmat_type, only : psb_sspmat_type, &
!!$ & psb_cspmat_type, psb_zspmat_type, psb_spk_, psb_dpk_
!!$ integer, intent(in) :: nz, imin,imax,jmin,jmax
!!$ integer, intent(in) :: ia(:),ja(:)
!!$ real(psb_spk_), intent(in) :: val(:)
!!$ type(psb_sspmat_type), intent(inout) :: a
!!$ integer, intent(out) :: info
!!$ integer, intent(in), optional :: gtl(:)
!!$ logical, optional, intent(in) :: rebuild
!!$ end subroutine psb_scoins
!!$ subroutine psb_dcoins(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl,rebuild)
!!$ use psb_spmat_type, only : psb_sspmat_type, psb_dspmat_type,&
!!$ & psb_cspmat_type, psb_zspmat_type, psb_spk_, psb_dpk_
@ -513,8 +496,7 @@ module psb_serial_mod
!!$ logical, optional, intent(in) :: rebuild
!!$ end subroutine psb_dcoins
subroutine psb_ccoins(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl,rebuild)
use psb_spmat_type, only : psb_sspmat_type, &
& psb_cspmat_type, psb_zspmat_type, psb_spk_, psb_dpk_
use psb_spmat_type, only : psb_cspmat_type, psb_zspmat_type, psb_spk_, psb_dpk_
integer, intent(in) :: nz, imin,imax,jmin,jmax
integer, intent(in) :: ia(:),ja(:)
complex(psb_spk_), intent(in) :: val(:)
@ -524,8 +506,7 @@ module psb_serial_mod
logical, optional, intent(in) :: rebuild
end subroutine psb_ccoins
subroutine psb_zcoins(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl,rebuild)
use psb_spmat_type, only : psb_sspmat_type, &
& psb_cspmat_type, psb_zspmat_type, psb_spk_, psb_dpk_
use psb_spmat_type, only : psb_cspmat_type, psb_zspmat_type, psb_spk_, psb_dpk_
integer, intent(in) :: nz, imin,imax,jmin,jmax
integer, intent(in) :: ia(:),ja(:)
complex(psb_dpk_), intent(in) :: val(:)
@ -538,12 +519,12 @@ module psb_serial_mod
interface psb_symbmm
subroutine psb_ssymbmm(a,b,c,info)
use psb_spmat_type, only : psb_sspmat_type, &
& psb_cspmat_type, psb_zspmat_type, psb_spk_, psb_dpk_
type(psb_sspmat_type) :: a,b,c
integer :: info
end subroutine psb_ssymbmm
!!$ subroutine psb_ssymbmm(a,b,c,info)
!!$ use psb_spmat_type, only : psb_sspmat_type, &
!!$ & psb_cspmat_type, psb_zspmat_type, psb_spk_, psb_dpk_
!!$ type(psb_sspmat_type) :: a,b,c
!!$ integer :: info
!!$ end subroutine psb_ssymbmm
!!$ subroutine psb_dsymbmm(a,b,c,info)
!!$ use psb_spmat_type, only : psb_sspmat_type, psb_dspmat_type,&
!!$ & psb_cspmat_type, psb_zspmat_type, psb_spk_, psb_dpk_
@ -551,51 +532,47 @@ module psb_serial_mod
!!$ integer :: info
!!$ end subroutine psb_dsymbmm
subroutine psb_csymbmm(a,b,c,info)
use psb_spmat_type, only : psb_sspmat_type, &
& psb_cspmat_type, psb_zspmat_type, psb_spk_, psb_dpk_
use psb_spmat_type, only : psb_cspmat_type, psb_zspmat_type, psb_spk_, psb_dpk_
type(psb_cspmat_type) :: a,b,c
integer :: info
end subroutine psb_csymbmm
subroutine psb_zsymbmm(a,b,c,info)
use psb_spmat_type, only : psb_sspmat_type, &
& psb_cspmat_type, psb_zspmat_type, psb_spk_, psb_dpk_
use psb_spmat_type, only : psb_cspmat_type, psb_zspmat_type, psb_spk_, psb_dpk_
type(psb_zspmat_type) :: a,b,c
integer :: info
end subroutine psb_zsymbmm
end interface
interface psb_numbmm
subroutine psb_snumbmm(a,b,c)
use psb_spmat_type, only : psb_sspmat_type, &
& psb_cspmat_type, psb_zspmat_type, psb_spk_, psb_dpk_
type(psb_sspmat_type) :: a,b,c
end subroutine psb_snumbmm
!!$ subroutine psb_snumbmm(a,b,c)
!!$ use psb_spmat_type, only : psb_sspmat_type, &
!!$ & psb_cspmat_type, psb_zspmat_type, psb_spk_, psb_dpk_
!!$ type(psb_sspmat_type) :: a,b,c
!!$ end subroutine psb_snumbmm
!!$ subroutine psb_dnumbmm(a,b,c)
!!$ use psb_spmat_type, only : psb_sspmat_type, psb_dspmat_type,&
!!$ & psb_cspmat_type, psb_zspmat_type, psb_spk_, psb_dpk_
!!$ type(psb_dspmat_type) :: a,b,c
!!$ end subroutine psb_dnumbmm
subroutine psb_cnumbmm(a,b,c)
use psb_spmat_type, only : psb_sspmat_type, &
& psb_cspmat_type, psb_zspmat_type, psb_spk_, psb_dpk_
use psb_spmat_type, only : psb_cspmat_type, psb_zspmat_type, psb_spk_, psb_dpk_
type(psb_cspmat_type) :: a,b,c
end subroutine psb_cnumbmm
subroutine psb_znumbmm(a,b,c)
use psb_spmat_type, only : psb_sspmat_type, &
& psb_cspmat_type, psb_zspmat_type, psb_spk_, psb_dpk_
use psb_spmat_type, only : psb_cspmat_type, psb_zspmat_type, psb_spk_, psb_dpk_
type(psb_zspmat_type) :: a,b,c
end subroutine psb_znumbmm
end interface
interface psb_transp
subroutine psb_stransp(a,b,c,fmt)
use psb_spmat_type, only : psb_sspmat_type, &
& psb_cspmat_type, psb_zspmat_type, psb_spk_, psb_dpk_
type(psb_sspmat_type), intent(in) :: a
type(psb_sspmat_type), intent(out) :: b
integer, optional :: c
character(len=*), optional :: fmt
end subroutine psb_stransp
!!$ subroutine psb_stransp(a,b,c,fmt)
!!$ use psb_spmat_type, only : psb_sspmat_type, &
!!$ & psb_cspmat_type, psb_zspmat_type, psb_spk_, psb_dpk_
!!$ type(psb_sspmat_type), intent(in) :: a
!!$ type(psb_sspmat_type), intent(out) :: b
!!$ integer, optional :: c
!!$ character(len=*), optional :: fmt
!!$ end subroutine psb_stransp
!!$ subroutine psb_dtransp(a,b,c,fmt)
!!$ use psb_spmat_type, only : psb_sspmat_type, psb_dspmat_type,&
!!$ & psb_cspmat_type, psb_zspmat_type, psb_spk_, psb_dpk_
@ -605,28 +582,26 @@ module psb_serial_mod
!!$ character(len=*), optional :: fmt
!!$ end subroutine psb_dtransp
subroutine psb_ctransp(a,b,c,fmt)
use psb_spmat_type, only : psb_sspmat_type, &
& psb_cspmat_type, psb_zspmat_type, psb_spk_, psb_dpk_
use psb_spmat_type, only : psb_cspmat_type, psb_zspmat_type, psb_spk_, psb_dpk_
type(psb_cspmat_type), intent(in) :: a
type(psb_cspmat_type), intent(out) :: b
integer, optional :: c
character(len=*), optional :: fmt
end subroutine psb_ctransp
subroutine psb_ztransp(a,b,c,fmt)
use psb_spmat_type, only : psb_sspmat_type, &
& psb_cspmat_type, psb_zspmat_type, psb_spk_, psb_dpk_
use psb_spmat_type, only : psb_cspmat_type, psb_zspmat_type, psb_spk_, psb_dpk_
type(psb_zspmat_type), intent(in) :: a
type(psb_zspmat_type), intent(out) :: b
integer, optional :: c
character(len=*), optional :: fmt
end subroutine psb_ztransp
subroutine psb_stransp1(a,c,fmt)
use psb_spmat_type, only : psb_sspmat_type, &
& psb_cspmat_type, psb_zspmat_type, psb_spk_, psb_dpk_
type(psb_sspmat_type), intent(inout) :: a
integer, optional :: c
character(len=*), optional :: fmt
end subroutine psb_stransp1
!!$ subroutine psb_stransp1(a,c,fmt)
!!$ use psb_spmat_type, only : psb_sspmat_type, &
!!$ & psb_cspmat_type, psb_zspmat_type, psb_spk_, psb_dpk_
!!$ type(psb_sspmat_type), intent(inout) :: a
!!$ integer, optional :: c
!!$ character(len=*), optional :: fmt
!!$ end subroutine psb_stransp1
!!$ subroutine psb_dtransp1(a,c,fmt)
!!$ use psb_spmat_type, only : psb_sspmat_type, psb_dspmat_type,&
!!$ & psb_cspmat_type, psb_zspmat_type, psb_spk_, psb_dpk_
@ -635,15 +610,13 @@ module psb_serial_mod
!!$ character(len=*), optional :: fmt
!!$ end subroutine psb_dtransp1
subroutine psb_ctransp1(a,c,fmt)
use psb_spmat_type, only : psb_sspmat_type, &
& psb_cspmat_type, psb_zspmat_type, psb_spk_, psb_dpk_
use psb_spmat_type, only : psb_cspmat_type, psb_zspmat_type, psb_spk_, psb_dpk_
type(psb_cspmat_type), intent(inout) :: a
integer, optional :: c
character(len=*), optional :: fmt
end subroutine psb_ctransp1
subroutine psb_ztransp1(a,c,fmt)
use psb_spmat_type, only : psb_sspmat_type, &
& psb_cspmat_type, psb_zspmat_type, psb_spk_, psb_dpk_
use psb_spmat_type, only : psb_cspmat_type, psb_zspmat_type, psb_spk_, psb_dpk_
type(psb_zspmat_type), intent(inout) :: a
integer, optional :: c
character(len=*), optional :: fmt
@ -652,16 +625,14 @@ module psb_serial_mod
interface psb_transc
subroutine psb_ctransc(a,b,c,fmt)
use psb_spmat_type, only : psb_sspmat_type, &
& psb_cspmat_type, psb_zspmat_type, psb_spk_, psb_dpk_
use psb_spmat_type, only : psb_cspmat_type, psb_zspmat_type, psb_spk_, psb_dpk_
type(psb_cspmat_type), intent(in) :: a
type(psb_cspmat_type), intent(out) :: b
integer, optional :: c
character(len=*), optional :: fmt
end subroutine psb_ctransc
subroutine psb_ztransc(a,b,c,fmt)
use psb_spmat_type, only : psb_sspmat_type, &
& psb_cspmat_type, psb_zspmat_type, psb_spk_, psb_dpk_
use psb_spmat_type, only : psb_cspmat_type, psb_zspmat_type, psb_spk_, psb_dpk_
type(psb_zspmat_type), intent(in) :: a
type(psb_zspmat_type), intent(out) :: b
integer, optional :: c
@ -670,15 +641,15 @@ module psb_serial_mod
end interface
interface psb_rwextd
subroutine psb_srwextd(nr,a,info,b,rowscale)
use psb_spmat_type, only : psb_sspmat_type, &
& psb_cspmat_type, psb_zspmat_type, psb_spk_, psb_dpk_
integer, intent(in) :: nr
type(psb_sspmat_type), intent(inout) :: a
integer, intent(out) :: info
type(psb_sspmat_type), intent(in), optional :: b
logical, intent(in), optional :: rowscale
end subroutine psb_srwextd
!!$ subroutine psb_srwextd(nr,a,info,b,rowscale)
!!$ use psb_spmat_type, only : psb_sspmat_type, &
!!$ & psb_cspmat_type, psb_zspmat_type, psb_spk_, psb_dpk_
!!$ integer, intent(in) :: nr
!!$ type(psb_sspmat_type), intent(inout) :: a
!!$ integer, intent(out) :: info
!!$ type(psb_sspmat_type), intent(in), optional :: b
!!$ logical, intent(in), optional :: rowscale
!!$ end subroutine psb_srwextd
!!$ subroutine psb_drwextd(nr,a,info,b,rowscale)
!!$ use psb_spmat_type, only : psb_sspmat_type, psb_dspmat_type,&
!!$ & psb_cspmat_type, psb_zspmat_type, psb_spk_, psb_dpk_
@ -689,8 +660,7 @@ module psb_serial_mod
!!$ logical, intent(in), optional :: rowscale
!!$ end subroutine psb_drwextd
subroutine psb_crwextd(nr,a,info,b,rowscale)
use psb_spmat_type, only : psb_sspmat_type, &
& psb_cspmat_type, psb_zspmat_type, psb_spk_, psb_dpk_
use psb_spmat_type, only : psb_cspmat_type, psb_zspmat_type, psb_spk_, psb_dpk_
integer, intent(in) :: nr
type(psb_cspmat_type), intent(inout) :: a
integer, intent(out) :: info
@ -698,8 +668,7 @@ module psb_serial_mod
logical, intent(in), optional :: rowscale
end subroutine psb_crwextd
subroutine psb_zrwextd(nr,a,info,b,rowscale)
use psb_spmat_type, only : psb_sspmat_type, &
& psb_cspmat_type, psb_zspmat_type, psb_spk_, psb_dpk_
use psb_spmat_type, only : psb_cspmat_type, psb_zspmat_type, psb_spk_, psb_dpk_
integer, intent(in) :: nr
type(psb_zspmat_type), intent(inout) :: a
integer, intent(out) :: info
@ -709,14 +678,14 @@ module psb_serial_mod
end interface
interface psb_csnmi
function psb_scsnmi(a,info,trans)
use psb_spmat_type, only : psb_sspmat_type, &
& psb_cspmat_type, psb_zspmat_type, psb_spk_, psb_dpk_
type(psb_sspmat_type), intent(in) :: a
integer, intent(out) :: info
character, optional :: trans
real(psb_spk_) :: psb_scsnmi
end function psb_scsnmi
!!$ function psb_scsnmi(a,info,trans)
!!$ use psb_spmat_type, only : psb_sspmat_type, &
!!$ & psb_cspmat_type, psb_zspmat_type, psb_spk_, psb_dpk_
!!$ type(psb_sspmat_type), intent(in) :: a
!!$ integer, intent(out) :: info
!!$ character, optional :: trans
!!$ real(psb_spk_) :: psb_scsnmi
!!$ end function psb_scsnmi
!!$ function psb_dcsnmi(a,info,trans)
!!$ use psb_spmat_type, only : psb_sspmat_type, psb_dspmat_type,&
!!$ & psb_cspmat_type, psb_zspmat_type, psb_spk_, psb_dpk_
@ -726,16 +695,14 @@ module psb_serial_mod
!!$ real(psb_dpk_) :: psb_dcsnmi
!!$ end function psb_dcsnmi
function psb_ccsnmi(a,info,trans)
use psb_spmat_type, only : psb_sspmat_type, &
& psb_cspmat_type, psb_zspmat_type, psb_spk_, psb_dpk_
use psb_spmat_type, only : psb_cspmat_type, psb_zspmat_type, psb_spk_, psb_dpk_
type(psb_cspmat_type), intent(in) :: a
integer, intent(out) :: info
character, optional :: trans
real(psb_spk_) :: psb_ccsnmi
end function psb_ccsnmi
function psb_zcsnmi(a,info,trans)
use psb_spmat_type, only : psb_sspmat_type, &
& psb_cspmat_type, psb_zspmat_type, psb_spk_, psb_dpk_
use psb_spmat_type, only : psb_cspmat_type, psb_zspmat_type, psb_spk_, psb_dpk_
type(psb_zspmat_type), intent(in) :: a
integer, intent(out) :: info
character, optional :: trans
@ -744,16 +711,16 @@ module psb_serial_mod
end interface
interface psb_sp_clip
subroutine psb_sspclip(a,b,info,imin,imax,jmin,jmax,rscale,cscale)
use psb_spmat_type, only : psb_sspmat_type, &
& psb_cspmat_type, psb_zspmat_type, psb_spk_, psb_dpk_
implicit none
type(psb_sspmat_type), intent(in) :: a
type(psb_sspmat_type), intent(out) :: b
integer, intent(out) :: info
integer, intent(in), optional :: imin,imax,jmin,jmax
logical, intent(in), optional :: rscale,cscale
end subroutine psb_sspclip
!!$ subroutine psb_sspclip(a,b,info,imin,imax,jmin,jmax,rscale,cscale)
!!$ use psb_spmat_type, only : psb_sspmat_type, &
!!$ & psb_cspmat_type, psb_zspmat_type, psb_spk_, psb_dpk_
!!$ implicit none
!!$ type(psb_sspmat_type), intent(in) :: a
!!$ type(psb_sspmat_type), intent(out) :: b
!!$ integer, intent(out) :: info
!!$ integer, intent(in), optional :: imin,imax,jmin,jmax
!!$ logical, intent(in), optional :: rscale,cscale
!!$ end subroutine psb_sspclip
!!$ subroutine psb_dspclip(a,b,info,imin,imax,jmin,jmax,rscale,cscale)
!!$ use psb_spmat_type, only : psb_sspmat_type, psb_dspmat_type,&
!!$ & psb_cspmat_type, psb_zspmat_type, psb_spk_, psb_dpk_
@ -765,8 +732,7 @@ module psb_serial_mod
!!$ logical, intent(in), optional :: rscale,cscale
!!$ end subroutine psb_dspclip
subroutine psb_cspclip(a,b,info,imin,imax,jmin,jmax,rscale,cscale)
use psb_spmat_type, only : psb_sspmat_type, &
& psb_cspmat_type, psb_zspmat_type, psb_spk_, psb_dpk_
use psb_spmat_type, only : psb_cspmat_type, psb_zspmat_type, psb_spk_, psb_dpk_
implicit none
type(psb_cspmat_type), intent(in) :: a
type(psb_cspmat_type), intent(out) :: b
@ -775,8 +741,7 @@ module psb_serial_mod
logical, intent(in), optional :: rscale,cscale
end subroutine psb_cspclip
subroutine psb_zspclip(a,b,info,imin,imax,jmin,jmax,rscale,cscale)
use psb_spmat_type, only : psb_sspmat_type, &
& psb_cspmat_type, psb_zspmat_type, psb_spk_, psb_dpk_
use psb_spmat_type, only : psb_cspmat_type, psb_zspmat_type, psb_spk_, psb_dpk_
implicit none
type(psb_zspmat_type), intent(in) :: a
type(psb_zspmat_type), intent(out) :: b
@ -787,13 +752,13 @@ module psb_serial_mod
end interface
interface psb_sp_getdiag
subroutine psb_sspgtdiag(a,d,info)
use psb_spmat_type, only : psb_sspmat_type, &
& psb_cspmat_type, psb_zspmat_type, psb_spk_, psb_dpk_
type(psb_sspmat_type), intent(in) :: a
real(psb_spk_), intent(inout) :: d(:)
integer, intent(out) :: info
end subroutine psb_sspgtdiag
!!$ subroutine psb_sspgtdiag(a,d,info)
!!$ use psb_spmat_type, only : psb_sspmat_type, &
!!$ & psb_cspmat_type, psb_zspmat_type, psb_spk_, psb_dpk_
!!$ type(psb_sspmat_type), intent(in) :: a
!!$ real(psb_spk_), intent(inout) :: d(:)
!!$ integer, intent(out) :: info
!!$ end subroutine psb_sspgtdiag
!!$ subroutine psb_dspgtdiag(a,d,info)
!!$ use psb_spmat_type, only : psb_sspmat_type, psb_dspmat_type,&
!!$ & psb_cspmat_type, psb_zspmat_type, psb_spk_, psb_dpk_
@ -802,15 +767,13 @@ module psb_serial_mod
!!$ integer, intent(out) :: info
!!$ end subroutine psb_dspgtdiag
subroutine psb_cspgtdiag(a,d,info)
use psb_spmat_type, only : psb_sspmat_type, &
& psb_cspmat_type, psb_zspmat_type, psb_spk_, psb_dpk_
use psb_spmat_type, only : psb_cspmat_type, psb_zspmat_type, psb_spk_, psb_dpk_
type(psb_cspmat_type), intent(in) :: a
complex(psb_spk_), intent(inout) :: d(:)
integer, intent(out) :: info
end subroutine psb_cspgtdiag
subroutine psb_zspgtdiag(a,d,info)
use psb_spmat_type, only : psb_sspmat_type, &
& psb_cspmat_type, psb_zspmat_type, psb_spk_, psb_dpk_
use psb_spmat_type, only : psb_cspmat_type, psb_zspmat_type, psb_spk_, psb_dpk_
type(psb_zspmat_type), intent(in) :: a
complex(psb_dpk_), intent(inout) :: d(:)
integer, intent(out) :: info
@ -818,20 +781,20 @@ module psb_serial_mod
end interface
interface psb_sp_scal
subroutine psb_sspscals(a,d,info)
use psb_spmat_type, only : psb_sspmat_type, &
& psb_cspmat_type, psb_zspmat_type, psb_spk_, psb_dpk_
type(psb_sspmat_type), intent(inout) :: a
real(psb_spk_), intent(in) :: d
integer, intent(out) :: info
end subroutine psb_sspscals
subroutine psb_sspscal(a,d,info)
use psb_spmat_type, only : psb_sspmat_type, &
& psb_cspmat_type, psb_zspmat_type, psb_spk_, psb_dpk_
type(psb_sspmat_type), intent(inout) :: a
real(psb_spk_), intent(in) :: d(:)
integer, intent(out) :: info
end subroutine psb_sspscal
!!$ subroutine psb_sspscals(a,d,info)
!!$ use psb_spmat_type, only : psb_sspmat_type, &
!!$ & psb_cspmat_type, psb_zspmat_type, psb_spk_, psb_dpk_
!!$ type(psb_sspmat_type), intent(inout) :: a
!!$ real(psb_spk_), intent(in) :: d
!!$ integer, intent(out) :: info
!!$ end subroutine psb_sspscals
!!$ subroutine psb_sspscal(a,d,info)
!!$ use psb_spmat_type, only : psb_sspmat_type, &
!!$ & psb_cspmat_type, psb_zspmat_type, psb_spk_, psb_dpk_
!!$ type(psb_sspmat_type), intent(inout) :: a
!!$ real(psb_spk_), intent(in) :: d(:)
!!$ integer, intent(out) :: info
!!$ end subroutine psb_sspscal
!!$ subroutine psb_dspscals(a,d,info)
!!$ use psb_spmat_type, only : psb_sspmat_type, psb_dspmat_type,&
!!$ & psb_cspmat_type, psb_zspmat_type, psb_spk_, psb_dpk_
@ -847,29 +810,25 @@ module psb_serial_mod
!!$ integer, intent(out) :: info
!!$ end subroutine psb_dspscal
subroutine psb_cspscals(a,d,info)
use psb_spmat_type, only : psb_sspmat_type, &
& psb_cspmat_type, psb_zspmat_type, psb_spk_, psb_dpk_
use psb_spmat_type, only : psb_cspmat_type, psb_zspmat_type, psb_spk_, psb_dpk_
type(psb_cspmat_type), intent(inout) :: a
complex(psb_spk_), intent(in) :: d
integer, intent(out) :: info
end subroutine psb_cspscals
subroutine psb_cspscal(a,d,info)
use psb_spmat_type, only : psb_sspmat_type, &
& psb_cspmat_type, psb_zspmat_type, psb_spk_, psb_dpk_
use psb_spmat_type, only : psb_cspmat_type, psb_zspmat_type, psb_spk_, psb_dpk_
type(psb_cspmat_type), intent(inout) :: a
complex(psb_spk_), intent(in) :: d(:)
integer, intent(out) :: info
end subroutine psb_cspscal
subroutine psb_zspscals(a,d,info)
use psb_spmat_type, only : psb_sspmat_type, &
& psb_cspmat_type, psb_zspmat_type, psb_spk_, psb_dpk_
use psb_spmat_type, only : psb_cspmat_type, psb_zspmat_type, psb_spk_, psb_dpk_
type(psb_zspmat_type), intent(inout) :: a
complex(psb_dpk_), intent(in) :: d
integer, intent(out) :: info
end subroutine psb_zspscals
subroutine psb_zspscal(a,d,info)
use psb_spmat_type, only : psb_sspmat_type, &
& psb_cspmat_type, psb_zspmat_type, psb_spk_, psb_dpk_
use psb_spmat_type, only : psb_cspmat_type, psb_zspmat_type, psb_spk_, psb_dpk_
type(psb_zspmat_type), intent(inout) :: a
complex(psb_dpk_), intent(in) :: d(:)
integer, intent(out) :: info
@ -892,14 +851,12 @@ module psb_serial_mod
!!$ integer, intent(out) :: info
!!$ end subroutine psb_dspsetbld2
subroutine psb_zspsetbld1(a,info)
use psb_spmat_type, only : psb_sspmat_type, &
& psb_cspmat_type, psb_zspmat_type, psb_spk_, psb_dpk_
use psb_spmat_type, only : psb_cspmat_type, psb_zspmat_type, psb_spk_, psb_dpk_
type(psb_zspmat_type), intent(inout) :: a
integer, intent(out) :: info
end subroutine psb_zspsetbld1
subroutine psb_zspsetbld2(a,b,info)
use psb_spmat_type, only : psb_sspmat_type, &
& psb_cspmat_type, psb_zspmat_type, psb_spk_, psb_dpk_
use psb_spmat_type, only : psb_cspmat_type, psb_zspmat_type, psb_spk_, psb_dpk_
type(psb_zspmat_type), intent(in) :: a
type(psb_zspmat_type), intent(out) :: b
integer, intent(out) :: info
@ -916,8 +873,7 @@ module psb_serial_mod
!!$ integer, intent(out) :: info
!!$ end subroutine psb_dspshift
subroutine psb_zspshift(alpha,a,beta,b,info)
use psb_spmat_type, only : psb_sspmat_type, &
& psb_cspmat_type, psb_zspmat_type, psb_spk_, psb_dpk_
use psb_spmat_type, only : psb_cspmat_type, psb_zspmat_type, psb_spk_, psb_dpk_
type(psb_zspmat_type), intent(in) :: a
type(psb_zspmat_type), intent(out) :: b
complex(psb_dpk_), intent(in) :: alpha, beta
@ -926,18 +882,18 @@ module psb_serial_mod
end interface
interface psb_sp_getblk
subroutine psb_sspgtblk(irw,a,b,info,append,iren,lrw,srt)
use psb_spmat_type, only : psb_sspmat_type, &
& psb_cspmat_type, psb_zspmat_type, psb_spk_, psb_dpk_
type(psb_sspmat_type), intent(in) :: a
integer, intent(in) :: irw
type(psb_sspmat_type), intent(inout) :: b
integer, intent(out) :: info
logical, intent(in), optional :: append
integer, intent(in), target, optional :: iren(:)
integer, intent(in), optional :: lrw
logical, intent(in), optional :: srt
end subroutine psb_sspgtblk
!!$ subroutine psb_sspgtblk(irw,a,b,info,append,iren,lrw,srt)
!!$ use psb_spmat_type, only : psb_sspmat_type, &
!!$ & psb_cspmat_type, psb_zspmat_type, psb_spk_, psb_dpk_
!!$ type(psb_sspmat_type), intent(in) :: a
!!$ integer, intent(in) :: irw
!!$ type(psb_sspmat_type), intent(inout) :: b
!!$ integer, intent(out) :: info
!!$ logical, intent(in), optional :: append
!!$ integer, intent(in), target, optional :: iren(:)
!!$ integer, intent(in), optional :: lrw
!!$ logical, intent(in), optional :: srt
!!$ end subroutine psb_sspgtblk
!!$ subroutine psb_dspgtblk(irw,a,b,info,append,iren,lrw,srt)
!!$ use psb_spmat_type, only : psb_sspmat_type, psb_dspmat_type,&
!!$ & psb_cspmat_type, psb_zspmat_type, psb_spk_, psb_dpk_
@ -951,8 +907,7 @@ module psb_serial_mod
!!$ logical, intent(in), optional :: srt
!!$ end subroutine psb_dspgtblk
subroutine psb_cspgtblk(irw,a,b,info,append,iren,lrw,srt)
use psb_spmat_type, only : psb_sspmat_type, &
& psb_cspmat_type, psb_zspmat_type, psb_spk_, psb_dpk_
use psb_spmat_type, only : psb_cspmat_type, psb_zspmat_type, psb_spk_, psb_dpk_
type(psb_cspmat_type), intent(in) :: a
integer, intent(in) :: irw
type(psb_cspmat_type), intent(inout) :: b
@ -963,8 +918,7 @@ module psb_serial_mod
logical, intent(in), optional :: srt
end subroutine psb_cspgtblk
subroutine psb_zspgtblk(irw,a,b,info,append,iren,lrw,srt)
use psb_spmat_type, only : psb_sspmat_type, &
& psb_cspmat_type, psb_zspmat_type, psb_spk_, psb_dpk_
use psb_spmat_type, only : psb_cspmat_type, psb_zspmat_type, psb_spk_, psb_dpk_
type(psb_zspmat_type), intent(in) :: a
integer, intent(in) :: irw
type(psb_zspmat_type), intent(inout) :: b
@ -977,22 +931,22 @@ module psb_serial_mod
end interface
interface psb_sp_getrow
subroutine psb_sspgetrow(irw,a,nz,ia,ja,val,info,iren,lrw,append,nzin)
! Output is always in COO format
use psb_spmat_type, only : psb_sspmat_type, &
& psb_cspmat_type, psb_zspmat_type, psb_spk_, psb_dpk_
implicit none
type(psb_sspmat_type), intent(in) :: a
integer, intent(in) :: irw
integer, intent(out) :: nz
integer, allocatable, intent(inout) :: ia(:), ja(:)
real(psb_spk_), allocatable, intent(inout) :: val(:)
integer,intent(out) :: info
logical, intent(in), optional :: append
integer, intent(in), optional :: iren(:)
integer, intent(in), optional :: lrw, nzin
end subroutine psb_sspgetrow
!!$ subroutine psb_sspgetrow(irw,a,nz,ia,ja,val,info,iren,lrw,append,nzin)
!!$ ! Output is always in COO format
!!$ use psb_spmat_type, only : psb_sspmat_type, &
!!$ & psb_cspmat_type, psb_zspmat_type, psb_spk_, psb_dpk_
!!$ implicit none
!!$
!!$ type(psb_sspmat_type), intent(in) :: a
!!$ integer, intent(in) :: irw
!!$ integer, intent(out) :: nz
!!$ integer, allocatable, intent(inout) :: ia(:), ja(:)
!!$ real(psb_spk_), allocatable, intent(inout) :: val(:)
!!$ integer,intent(out) :: info
!!$ logical, intent(in), optional :: append
!!$ integer, intent(in), optional :: iren(:)
!!$ integer, intent(in), optional :: lrw, nzin
!!$ end subroutine psb_sspgetrow
!!$ subroutine psb_dspgetrow(irw,a,nz,ia,ja,val,info,iren,lrw,append,nzin)
!!$ ! Output is always in COO format
!!$ use psb_spmat_type, only : psb_sspmat_type, psb_dspmat_type,&
@ -1011,8 +965,7 @@ module psb_serial_mod
!!$ end subroutine psb_dspgetrow
subroutine psb_cspgetrow(irw,a,nz,ia,ja,val,info,iren,lrw,append,nzin)
! Output is always in COO format
use psb_spmat_type, only : psb_sspmat_type, &
& psb_cspmat_type, psb_zspmat_type, psb_spk_, psb_dpk_
use psb_spmat_type, only : psb_cspmat_type, psb_zspmat_type, psb_spk_, psb_dpk_
implicit none
type(psb_cspmat_type), intent(in) :: a
@ -1027,8 +980,7 @@ module psb_serial_mod
end subroutine psb_cspgetrow
subroutine psb_zspgetrow(irw,a,nz,ia,ja,val,info,iren,lrw,append,nzin)
! Output is always in COO format
use psb_spmat_type, only : psb_sspmat_type, &
& psb_cspmat_type, psb_zspmat_type, psb_spk_, psb_dpk_
use psb_spmat_type, only : psb_cspmat_type, psb_zspmat_type, psb_spk_, psb_dpk_
implicit none
type(psb_zspmat_type), intent(in) :: a
@ -1054,81 +1006,12 @@ module psb_serial_mod
!!$ character, intent(in) :: trans
!!$ end subroutine psb_dcsrp
subroutine psb_zcsrp(trans,iperm,a, info)
use psb_spmat_type, only : psb_sspmat_type, &
& psb_cspmat_type, psb_zspmat_type, psb_spk_, psb_dpk_
use psb_spmat_type, only : psb_cspmat_type, psb_zspmat_type, psb_spk_, psb_dpk_
type(psb_zspmat_type), intent(inout) :: a
integer, intent(inout) :: iperm(:), info
character, intent(in) :: trans
end subroutine psb_zcsrp
end interface
interface psb_gelp
! 2-D version
subroutine psb_sgelp(trans,iperm,x,info)
use psb_const_mod
real(psb_spk_), intent(inout) :: x(:,:)
integer, intent(in) :: iperm(:)
integer, intent(out) :: info
character, intent(in) :: trans
end subroutine psb_sgelp
! 1-D version
subroutine psb_sgelpv(trans,iperm,x,info)
use psb_const_mod
real(psb_spk_), intent(inout) :: x(:)
integer, intent(in) :: iperm(:)
integer, intent(out) :: info
character, intent(in) :: trans
end subroutine psb_sgelpv
subroutine psb_dgelp(trans,iperm,x,info)
use psb_const_mod
real(psb_dpk_), intent(inout) :: x(:,:)
integer, intent(in) :: iperm(:)
integer, intent(out) :: info
character, intent(in) :: trans
end subroutine psb_dgelp
! 1-D version
subroutine psb_dgelpv(trans,iperm,x,info)
use psb_const_mod
real(psb_dpk_), intent(inout) :: x(:)
integer, intent(in) :: iperm(:)
integer, intent(out) :: info
character, intent(in) :: trans
end subroutine psb_dgelpv
! 2-D version
subroutine psb_cgelp(trans,iperm,x,info)
use psb_const_mod
complex(psb_spk_), intent(inout) :: x(:,:)
integer, intent(in) :: iperm(:)
integer, intent(out) :: info
character, intent(in) :: trans
end subroutine psb_cgelp
! 1-D version
subroutine psb_cgelpv(trans,iperm,x,info)
use psb_const_mod
complex(psb_spk_), intent(inout) :: x(:)
integer, intent(in) :: iperm(:)
integer, intent(out) :: info
character, intent(in) :: trans
end subroutine psb_cgelpv
! 2-D version
subroutine psb_zgelp(trans,iperm,x,info)
use psb_const_mod
complex(psb_dpk_), intent(inout) :: x(:,:)
integer, intent(in) :: iperm(:)
integer, intent(out) :: info
character, intent(in) :: trans
end subroutine psb_zgelp
! 1-D version
subroutine psb_zgelpv(trans,iperm,x,info)
use psb_const_mod
complex(psb_dpk_), intent(inout) :: x(:)
integer, intent(in) :: iperm(:)
integer, intent(out) :: info
character, intent(in) :: trans
end subroutine psb_zgelpv
end interface
end module psb_serial_mod

2282
base/modules/psb_spmat_type.f03
View File

File diff suppressed because it is too large Load Diff

103
base/modules/psb_tools_mod.f90
Unescape Escape View File

@ -219,9 +219,9 @@ Module psb_tools_mod
Subroutine psb_ssphalo(a,desc_a,blk,info,rowcnv,colcnv,&
& rowscale,colscale,outfmt,data)
use psb_descriptor_type
use psb_spmat_type
Type(psb_sspmat_type),Intent(in) :: a
Type(psb_sspmat_type),Intent(inout) :: blk
use psb_mat_mod
Type(psb_s_sparse_mat),Intent(in) :: a
Type(psb_s_sparse_mat),Intent(inout) :: blk
Type(psb_desc_type),Intent(in),target :: desc_a
integer, intent(out) :: info
logical, optional, intent(in) :: rowcnv,colcnv,rowscale,colscale
@ -477,9 +477,9 @@ Module psb_tools_mod
interface psb_cdbldext
Subroutine psb_scdbldext(a,desc_a,novr,desc_ov,info,extype)
use psb_descriptor_type
Use psb_spmat_type
Use psb_mat_mod
integer, intent(in) :: novr
Type(psb_sspmat_type), Intent(in) :: a
Type(psb_s_sparse_mat), Intent(in) :: a
Type(psb_desc_type), Intent(in), target :: desc_a
Type(psb_desc_type), Intent(out) :: desc_ov
integer, intent(out) :: info
@ -540,20 +540,20 @@ Module psb_tools_mod
interface psb_spall
subroutine psb_sspalloc(a, desc_a, info, nnz)
use psb_descriptor_type
use psb_spmat_type
type(psb_desc_type), intent(inout) :: desc_a
type(psb_sspmat_type), intent(out) :: a
integer, intent(out) :: info
integer, optional, intent(in) :: nnz
use psb_mat_mod
type(psb_desc_type), intent(inout) :: desc_a
type(psb_s_sparse_mat), intent(out) :: a
integer, intent(out) :: info
integer, optional, intent(in) :: nnz
end subroutine psb_sspalloc
subroutine psb_dspalloc(a, desc_a, info, nnz)
use psb_descriptor_type
use psb_spmat_type
use psb_d_mat_mod
type(psb_desc_type), intent(inout) :: desc_a
use psb_mat_mod
type(psb_desc_type), intent(inout) :: desc_a
type(psb_d_sparse_mat), intent(out) :: a
integer, intent(out) :: info
integer, optional, intent(in) :: nnz
integer, intent(out) :: info
integer, optional, intent(in) :: nnz
end subroutine psb_dspalloc
subroutine psb_cspalloc(a, desc_a, info, nnz)
use psb_descriptor_type
@ -574,19 +574,20 @@ Module psb_tools_mod
end interface
interface psb_spasb
subroutine psb_sspasb(a,desc_a, info, afmt, upd, dupl)
subroutine psb_sspasb(a,desc_a, info, afmt, upd, dupl, mold)
use psb_descriptor_type
use psb_spmat_type
type(psb_sspmat_type), intent (inout) :: a
use psb_mat_mod
type(psb_s_sparse_mat), intent (inout) :: a
type(psb_desc_type), intent(in) :: desc_a
integer, intent(out) :: info
integer,optional, intent(in) :: dupl, upd
character(len=*), optional, intent(in) :: afmt
class(psb_s_base_sparse_mat), intent(in), optional :: mold
end subroutine psb_sspasb
subroutine psb_dspasb(a,desc_a, info, afmt, upd, dupl,mold)
use psb_descriptor_type
use psb_spmat_type
use psb_d_mat_mod
use psb_mat_mod
type(psb_d_sparse_mat), intent (inout) :: a
type(psb_desc_type), intent(in) :: desc_a
integer, intent(out) :: info
@ -621,18 +622,18 @@ Module psb_tools_mod
interface psb_spfree
subroutine psb_sspfree(a, desc_a,info)
use psb_descriptor_type
use psb_spmat_type
type(psb_desc_type), intent(in) :: desc_a
type(psb_sspmat_type), intent(inout) ::a
integer, intent(out) :: info
use psb_mat_mod
type(psb_desc_type), intent(in) :: desc_a
type(psb_s_sparse_mat), intent(inout) :: a
integer, intent(out) :: info
end subroutine psb_sspfree
subroutine psb_dspfree(a, desc_a,info)
use psb_descriptor_type
use psb_spmat_type
use psb_d_mat_mod
type(psb_desc_type), intent(in) :: desc_a
type(psb_d_sparse_mat), intent(inout) ::a
integer, intent(out) :: info
use psb_mat_mod
type(psb_desc_type), intent(in) :: desc_a
type(psb_d_sparse_mat), intent(inout) :: a
integer, intent(out) :: info
end subroutine psb_dspfree
subroutine psb_cspfree(a, desc_a,info)
use psb_descriptor_type
@ -654,28 +655,28 @@ Module psb_tools_mod
interface psb_spins
subroutine psb_sspins(nz,ia,ja,val,a,desc_a,info,rebuild)
use psb_descriptor_type
use psb_spmat_type
type(psb_desc_type), intent(inout) :: desc_a
type(psb_sspmat_type), intent(inout) :: a
integer, intent(in) :: nz,ia(:),ja(:)
real(psb_spk_), intent(in) :: val(:)
integer, intent(out) :: info
logical, intent(in), optional :: rebuild
use psb_mat_mod
type(psb_desc_type), intent(inout) :: desc_a
type(psb_s_sparse_mat), intent(inout) :: a
integer, intent(in) :: nz,ia(:),ja(:)
real(psb_spk_), intent(in) :: val(:)
integer, intent(out) :: info
logical, intent(in), optional :: rebuild
end subroutine psb_sspins
subroutine psb_sspins_2desc(nz,ia,ja,val,a,desc_ar,desc_ac,info)
use psb_descriptor_type
use psb_spmat_type
type(psb_desc_type), intent(in) :: desc_ar
type(psb_desc_type), intent(inout) :: desc_ac
type(psb_sspmat_type), intent(inout) :: a
integer, intent(in) :: nz,ia(:),ja(:)
real(psb_spk_), intent(in) :: val(:)
integer, intent(out) :: info
use psb_mat_mod
type(psb_desc_type), intent(in) :: desc_ar
type(psb_desc_type), intent(inout) :: desc_ac
type(psb_s_sparse_mat), intent(inout) :: a
integer, intent(in) :: nz,ia(:),ja(:)
real(psb_spk_), intent(in) :: val(:)
integer, intent(out) :: info
end subroutine psb_sspins_2desc
subroutine psb_dspins(nz,ia,ja,val,a,desc_a,info,rebuild)
use psb_descriptor_type
use psb_spmat_type
use psb_d_mat_mod
use psb_mat_mod
type(psb_desc_type), intent(inout) :: desc_a
type(psb_d_sparse_mat), intent(inout) :: a
integer, intent(in) :: nz,ia(:),ja(:)
@ -685,7 +686,7 @@ Module psb_tools_mod
end subroutine psb_dspins
subroutine psb_dspins_2desc(nz,ia,ja,val,a,desc_ar,desc_ac,info)
use psb_descriptor_type
use psb_d_mat_mod
use psb_mat_mod
type(psb_d_sparse_mat), intent(inout) :: a
type(psb_desc_type), intent(in) :: desc_ar
type(psb_desc_type), intent(inout) :: desc_ac
@ -739,19 +740,19 @@ Module psb_tools_mod
interface psb_sprn
subroutine psb_ssprn(a, desc_a,info,clear)
use psb_descriptor_type
use psb_spmat_type
type(psb_desc_type), intent(in) :: desc_a
type(psb_sspmat_type), intent(inout) :: a
integer, intent(out) :: info
logical, intent(in), optional :: clear
end subroutine psb_ssprn
use psb_mat_mod
type(psb_desc_type), intent(in) :: desc_a
type(psb_s_sparse_mat), intent(inout) :: a
integer, intent(out) :: info
logical, intent(in), optional :: clear
end subroutine psb_ssprn
subroutine psb_dsprn(a, desc_a,info,clear)
use psb_descriptor_type
use psb_mat_mod
type(psb_desc_type), intent(in) :: desc_a
type(psb_desc_type), intent(in) :: desc_a
type(psb_d_sparse_mat), intent(inout) :: a
integer, intent(out) :: info
logical, intent(in), optional :: clear
integer, intent(out) :: info
logical, intent(in), optional :: clear
end subroutine psb_dsprn
subroutine psb_csprn(a, desc_a,info,clear)
use psb_descriptor_type

497
base/modules/psi_serial_mod.f90
Unescape Escape View File

@ -30,8 +30,8 @@
!!$
!!$
module psi_serial_mod
interface psi_gth
module procedure &
& psi_igthv, psi_sgthv, psi_cgthv, psi_dgthv, psi_zgthv,&
@ -47,6 +47,80 @@ module psi_serial_mod
& psi_zsctmv, psi_zsctv
end interface
interface psb_geaxpby
module procedure psi_saxpbyv, psi_saxpby, &
& psi_daxpbyv, psi_daxpby, &
& psi_caxpbyv, psi_caxpby, &
& psi_zaxpbyv, psi_zaxpby
end interface
interface psb_gelp
! 2-D version
subroutine psb_sgelp(trans,iperm,x,info)
use psb_const_mod
real(psb_spk_), intent(inout) :: x(:,:)
integer, intent(in) :: iperm(:)
integer, intent(out) :: info
character, intent(in) :: trans
end subroutine psb_sgelp
! 1-D version
subroutine psb_sgelpv(trans,iperm,x,info)
use psb_const_mod
real(psb_spk_), intent(inout) :: x(:)
integer, intent(in) :: iperm(:)
integer, intent(out) :: info
character, intent(in) :: trans
end subroutine psb_sgelpv
subroutine psb_dgelp(trans,iperm,x,info)
use psb_const_mod
real(psb_dpk_), intent(inout) :: x(:,:)
integer, intent(in) :: iperm(:)
integer, intent(out) :: info
character, intent(in) :: trans
end subroutine psb_dgelp
! 1-D version
subroutine psb_dgelpv(trans,iperm,x,info)
use psb_const_mod
real(psb_dpk_), intent(inout) :: x(:)
integer, intent(in) :: iperm(:)
integer, intent(out) :: info
character, intent(in) :: trans
end subroutine psb_dgelpv
! 2-D version
subroutine psb_cgelp(trans,iperm,x,info)
use psb_const_mod
complex(psb_spk_), intent(inout) :: x(:,:)
integer, intent(in) :: iperm(:)
integer, intent(out) :: info
character, intent(in) :: trans
end subroutine psb_cgelp
! 1-D version
subroutine psb_cgelpv(trans,iperm,x,info)
use psb_const_mod
complex(psb_spk_), intent(inout) :: x(:)
integer, intent(in) :: iperm(:)
integer, intent(out) :: info
character, intent(in) :: trans
end subroutine psb_cgelpv
! 2-D version
subroutine psb_zgelp(trans,iperm,x,info)
use psb_const_mod
complex(psb_dpk_), intent(inout) :: x(:,:)
integer, intent(in) :: iperm(:)
integer, intent(out) :: info
character, intent(in) :: trans
end subroutine psb_zgelp
! 1-D version
subroutine psb_zgelpv(trans,iperm,x,info)
use psb_const_mod
complex(psb_dpk_), intent(inout) :: x(:)
integer, intent(in) :: iperm(:)
integer, intent(out) :: info
character, intent(in) :: trans
end subroutine psb_zgelpv
end interface
contains
@ -87,7 +161,7 @@ contains
else
y(1:n) = beta*y(1:n)
end if
if (alpha == izero) then
! do nothing
else if (alpha == ione) then
@ -143,7 +217,7 @@ contains
else
y(1:n) = beta*y(1:n)
end if
if (alpha == szero) then
! do nothing
else if (alpha == sone) then
@ -199,7 +273,7 @@ contains
else
y(1:n) = beta*y(1:n)
end if
if (alpha == dzero) then
! do nothing
else if (alpha == done) then
@ -255,7 +329,7 @@ contains
else
y(1:n) = beta*y(1:n)
end if
if (alpha == czero) then
! do nothing
else if (alpha == cone) then
@ -311,7 +385,7 @@ contains
else
y(1:n) = beta*y(1:n)
end if
if (alpha == zzero) then
! do nothing
else if (alpha == zone) then
@ -854,6 +928,413 @@ contains
end do
end if
end subroutine psi_zsctv
subroutine psi_saxpbyv(m,alpha, x, beta, y, info)
use psb_const_mod
use psb_error_mod
implicit none
integer, intent(in) :: m
real(psb_spk_), intent (in) :: x(:)
real(psb_spk_), intent (inout) :: y(:)
real(psb_spk_), intent (in) :: alpha, beta
integer, intent(out) :: info
integer :: err_act
character(len=20) :: name, ch_err
name='psb_geaxpby'
if(psb_get_errstatus() /= 0) return
info=0
call psb_erractionsave(err_act)
if (m < 0) then
info = 10
call psb_errpush(info,name,i_err=(/1,m,0,0,0/))
goto 9999
end if
if (size(x) < m) then
info = 36
call psb_errpush(info,name,i_err=(/3,m,0,0,0/))
goto 9999
end if
if (size(y) < m) then
info = 36
call psb_errpush(info,name,i_err=(/5,m,0,0,0/))
goto 9999
end if
if (m>0) call saxpby(m,1,alpha,x,size(x,1),beta,y,size(y,1),info)
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 psi_saxpbyv
subroutine psi_saxpby(m,n,alpha, x, beta, y, info)
use psb_const_mod
use psb_error_mod
implicit none
integer, intent(in) :: m, n
real(psb_spk_), intent (in) :: x(:,:)
real(psb_spk_), intent (inout) :: y(:,:)
real(psb_spk_), intent (in) :: alpha, beta
integer, intent(out) :: info
integer :: err_act
character(len=20) :: name, ch_err
name='psb_geaxpby'
if(psb_get_errstatus() /= 0) return
info=0
call psb_erractionsave(err_act)
if (m < 0) then
info = 10
call psb_errpush(info,name,i_err=(/1,m,0,0,0/))
goto 9999
end if
if (n < 0) then
info = 10
call psb_errpush(info,name,i_err=(/2,n,0,0,0/))
goto 9999
end if
if (size(x,1) < m) then
info = 36
call psb_errpush(info,name,i_err=(/4,m,0,0,0/))
goto 9999
end if
if (size(y,1) < m) then
info = 36
call psb_errpush(info,name,i_err=(/6,m,0,0,0/))
goto 9999
end if
if ((m>0).and.(n>0)) call saxpby(m,n,alpha,x,size(x,1),beta,y,size(y,1),info)
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 psi_saxpby
subroutine psi_daxpbyv(m,alpha, x, beta, y, info)
use psb_const_mod
use psb_error_mod
implicit none
integer, intent(in) :: m
real(psb_dpk_), intent (in) :: x(:)
real(psb_dpk_), intent (inout) :: y(:)
real(psb_dpk_), intent (in) :: alpha, beta
integer, intent(out) :: info
integer :: err_act
character(len=20) :: name, ch_err
name='psb_geaxpby'
if(psb_get_errstatus() /= 0) return
info=0
call psb_erractionsave(err_act)
if (m < 0) then
info = 10
call psb_errpush(info,name,i_err=(/1,m,0,0,0/))
goto 9999
end if
if (size(x) < m) then
info = 36
call psb_errpush(info,name,i_err=(/3,m,0,0,0/))
goto 9999
end if
if (size(y) < m) then
info = 36
call psb_errpush(info,name,i_err=(/5,m,0,0,0/))
goto 9999
end if
if (m>0) call daxpby(m,1,alpha,x,size(x,1),beta,y,size(y,1),info)
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 psi_daxpbyv
subroutine psi_daxpby(m,n,alpha, x, beta, y, info)
use psb_const_mod
use psb_error_mod
implicit none
integer, intent(in) :: m, n
real(psb_dpk_), intent (in) :: x(:,:)
real(psb_dpk_), intent (inout) :: y(:,:)
real(psb_dpk_), intent (in) :: alpha, beta
integer, intent(out) :: info
integer :: err_act
character(len=20) :: name, ch_err
name='psb_geaxpby'
if(psb_get_errstatus() /= 0) return
info=0
call psb_erractionsave(err_act)
if (m < 0) then
info = 10
call psb_errpush(info,name,i_err=(/1,m,0,0,0/))
goto 9999
end if
if (n < 0) then
info = 10
call psb_errpush(info,name,i_err=(/2,n,0,0,0/))
goto 9999
end if
if (size(x,1) < m) then
info = 36
call psb_errpush(info,name,i_err=(/4,m,0,0,0/))
goto 9999
end if
if (size(y,1) < m) then
info = 36
call psb_errpush(info,name,i_err=(/6,m,0,0,0/))
goto 9999
end if
if ((m>0).and.(n>0)) call daxpby(m,n,alpha,x,size(x,1),beta,y,size(y,1),info)
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 psi_daxpby
subroutine psi_caxpbyv(m,alpha, x, beta, y, info)
use psb_const_mod
use psb_error_mod
implicit none
integer, intent(in) :: m
complex(psb_spk_), intent (in) :: x(:)
complex(psb_spk_), intent (inout) :: y(:)
complex(psb_spk_), intent (in) :: alpha, beta
integer, intent(out) :: info
integer :: err_act
character(len=20) :: name, ch_err
name='psb_geaxpby'
if(psb_get_errstatus() /= 0) return
info=0
call psb_erractionsave(err_act)
if (m < 0) then
info = 10
call psb_errpush(info,name,i_err=(/1,m,0,0,0/))
goto 9999
end if
if (size(x) < m) then
info = 36
call psb_errpush(info,name,i_err=(/3,m,0,0,0/))
goto 9999
end if
if (size(y) < m) then
info = 36
call psb_errpush(info,name,i_err=(/5,m,0,0,0/))
goto 9999
end if
if (m>0) call caxpby(m,1,alpha,x,size(x,1),beta,y,size(y,1),info)
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 psi_caxpbyv
subroutine psi_caxpby(m,n,alpha, x, beta, y, info)
use psb_const_mod
use psb_error_mod
implicit none
integer, intent(in) :: m, n
complex(psb_spk_), intent (in) :: x(:,:)
complex(psb_spk_), intent (inout) :: y(:,:)
complex(psb_spk_), intent (in) :: alpha, beta
integer, intent(out) :: info
integer :: err_act
character(len=20) :: name, ch_err
name='psb_geaxpby'
if(psb_get_errstatus() /= 0) return
info=0
call psb_erractionsave(err_act)
if (m < 0) then
info = 10
call psb_errpush(info,name,i_err=(/1,m,0,0,0/))
goto 9999
end if
if (n < 0) then
info = 10
call psb_errpush(info,name,i_err=(/2,n,0,0,0/))
goto 9999
end if
if (size(x,1) < m) then
info = 36
call psb_errpush(info,name,i_err=(/4,m,0,0,0/))
goto 9999
end if
if (size(y,1) < m) then
info = 36
call psb_errpush(info,name,i_err=(/6,m,0,0,0/))
goto 9999
end if
if ((m>0).and.(n>0)) call caxpby(m,n,alpha,x,size(x,1),beta,y,size(y,1),info)
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 psi_caxpby
subroutine psi_zaxpbyv(m,alpha, x, beta, y, info)
use psb_const_mod
use psb_error_mod
implicit none
integer, intent(in) :: m
complex(psb_dpk_), intent (in) :: x(:)
complex(psb_dpk_), intent (inout) :: y(:)
complex(psb_dpk_), intent (in) :: alpha, beta
integer, intent(out) :: info
integer :: err_act
character(len=20) :: name, ch_err
name='psb_geaxpby'
if(psb_get_errstatus() /= 0) return
info=0
call psb_erractionsave(err_act)
if (m < 0) then
info = 10
call psb_errpush(info,name,i_err=(/1,m,0,0,0/))
goto 9999
end if
if (size(x) < m) then
info = 36
call psb_errpush(info,name,i_err=(/3,m,0,0,0/))
goto 9999
end if
if (size(y) < m) then
info = 36
call psb_errpush(info,name,i_err=(/5,m,0,0,0/))
goto 9999
end if
if (m>0) call zaxpby(m,1,alpha,x,size(x,1),beta,y,size(y,1),info)
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 psi_zaxpbyv
subroutine psi_zaxpby(m,n,alpha, x, beta, y, info)
use psb_const_mod
use psb_error_mod
implicit none
integer, intent(in) :: m, n
complex(psb_dpk_), intent (in) :: x(:,:)
complex(psb_dpk_), intent (inout) :: y(:,:)
complex(psb_dpk_), intent (in) :: alpha, beta
integer, intent(out) :: info
integer :: err_act
character(len=20) :: name, ch_err
name='psb_geaxpby'
if(psb_get_errstatus() /= 0) return
info=0
call psb_erractionsave(err_act)
if (m < 0) then
info = 10
call psb_errpush(info,name,i_err=(/1,m,0,0,0/))
goto 9999
end if
if (n < 0) then
info = 10
call psb_errpush(info,name,i_err=(/2,n,0,0,0/))
goto 9999
end if
if (size(x,1) < m) then
info = 36
call psb_errpush(info,name,i_err=(/4,m,0,0,0/))
goto 9999
end if
if (size(y,1) < m) then
info = 36
call psb_errpush(info,name,i_err=(/6,m,0,0,0/))
goto 9999
end if
if ((m>0).and.(n>0)) call zaxpby(m,n,alpha,x,size(x,1),beta,y,size(y,1),info)
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 psi_zaxpby
end module psi_serial_mod

2
base/psblas/psb_dnrmi.f90
Unescape Escape View File

@ -46,7 +46,7 @@ function psb_dnrmi(a,desc_a,info)
use psb_check_mod
use psb_error_mod
use psb_penv_mod
use psb_d_mat_mod
use psb_mat_mod
implicit none
type(psb_d_sparse_mat), intent(in) :: a

4
base/psblas/psb_dspmm.f90
Unescape Escape View File

@ -72,7 +72,7 @@ subroutine psb_dspmm(alpha,a,x,beta,y,desc_a,info,&
use psb_error_mod
use psb_string_mod
use psb_penv_mod
use psb_d_mat_mod
use psb_mat_mod
implicit none
real(psb_dpk_), intent(in) :: alpha, beta
@ -432,7 +432,7 @@ subroutine psb_dspmv(alpha,a,x,beta,y,desc_a,info,&
use psb_error_mod
use psb_string_mod
use psb_penv_mod
use psb_d_mat_mod
use psb_mat_mod
implicit none
real(psb_dpk_), intent(in) :: alpha, beta

5
base/psblas/psb_dspsm.f90
Unescape Escape View File

@ -84,7 +84,7 @@ subroutine psb_dspsm(alpha,a,x,beta,y,desc_a,info,&
use psb_error_mod
use psb_string_mod
use psb_penv_mod
use psb_d_mat_mod
use psb_mat_mod
implicit none
real(psb_dpk_), intent(in) :: alpha, beta
@ -369,7 +369,7 @@ subroutine psb_dspsv(alpha,a,x,beta,y,desc_a,info,&
use psb_error_mod
use psb_string_mod
use psb_penv_mod
use psb_d_mat_mod
use psb_mat_mod
implicit none
real(psb_dpk_), intent(in) :: alpha, beta
@ -526,7 +526,6 @@ subroutine psb_dspsv(alpha,a,x,beta,y,desc_a,info,&
xp => x(iix:lldx)
yp => y(iiy:lldy)
call psb_cssm(alpha,a,xp,beta,yp,info,side=side,d=diag,trans=trans)
!!$ call psb_cssm(alpha,a,xp,beta,yp,info,side=side,d=id,trans=itrans)
if(info /= 0) then
info = 4010

7
base/psblas/psb_snrmi.f90
Unescape Escape View File

@ -43,13 +43,13 @@
!
function psb_snrmi(a,desc_a,info)
use psb_descriptor_type
use psb_serial_mod
use psb_check_mod
use psb_error_mod
use psb_penv_mod
use psb_mat_mod
implicit none
type(psb_sspmat_type), intent(in) :: a
type(psb_s_sparse_mat), intent(in) :: a
integer, intent(out) :: info
type(psb_desc_type), intent(in) :: desc_a
real(psb_spk_) :: psb_snrmi
@ -94,8 +94,7 @@ function psb_snrmi(a,desc_a,info)
end if
if ((m /= 0).and.(n /= 0)) then
nrmi = psb_csnmi(a,info)
nrmi = psb_csnmi(a)
if(info /= 0) then
info=4010
ch_err='psb_csnmi'

19
base/psblas/psb_sspmm.f90
Unescape Escape View File

@ -74,12 +74,13 @@ subroutine psb_sspmm(alpha,a,x,beta,y,desc_a,info,&
use psb_error_mod
use psb_string_mod
use psb_penv_mod
use psb_mat_mod
implicit none
real(psb_spk_), intent(in) :: alpha, beta
real(psb_spk_), intent(inout), target :: x(:,:)
real(psb_spk_), intent(inout), target :: y(:,:)
type(psb_sspmat_type), intent(in) :: a
type(psb_s_sparse_mat), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_a
integer, intent(out) :: info
real(psb_spk_), optional, target :: work(:)
@ -250,7 +251,7 @@ subroutine psb_sspmm(alpha,a,x,beta,y,desc_a,info,&
if(info /= 0) exit blk
! local Matrix-vector product
call a%csmm(alpha,x(:,jjx+i-1:jjx+i-1+ib-1),&
call psb_csmm(alpha,a,x(:,jjx+i-1:jjx+i-1+ib-1),&
& beta,y(:,jjy+i-1:jjy+i-1+ib-1),info,trans=trans_)
if(info /= 0) exit blk
@ -265,7 +266,7 @@ subroutine psb_sspmm(alpha,a,x,beta,y,desc_a,info,&
if (doswap_)&
& call psi_swapdata(ior(psb_swap_send_,psb_swap_recv_),&
& ib1,szero,x(:,1:ik),desc_a,iwork,info)
if (info == 0) call a%csmm(alpha,x(:,1:ik),beta,y(:,1:ik),info)
if (info == 0) call psb_csmm(alpha,a,x(:,1:ik),beta,y(:,1:ik),info)
end if
if(info /= 0) then
info = 4011
@ -312,7 +313,7 @@ subroutine psb_sspmm(alpha,a,x,beta,y,desc_a,info,&
if (info == 0) call psi_ovrl_upd(x,desc_a,psb_avg_,info)
y(nrow+1:ncol,1:ik) = szero
if (info == 0) call a%csmm(alpha,x(:,1:ik),beta,y(:,1:ik),info,trans=trans_)
if (info == 0) call psb_csmm(alpha,a,x(:,1:ik),beta,y(:,1:ik),info,trans=trans_)
if (debug_level >= psb_debug_comp_) &
& write(debug_unit,*) me,' ',trim(name),' csmm ', info
if (info /= 0) then
@ -425,8 +426,6 @@ end subroutine psb_sspmm
subroutine psb_sspmv(alpha,a,x,beta,y,desc_a,info,&
& trans, work, doswap)
use psb_spmat_type
use psb_serial_mod
use psb_descriptor_type
use psb_comm_mod
use psb_const_mod
@ -435,12 +434,13 @@ subroutine psb_sspmv(alpha,a,x,beta,y,desc_a,info,&
use psb_error_mod
use psb_string_mod
use psb_penv_mod
use psb_mat_mod
implicit none
real(psb_spk_), intent(in) :: alpha, beta
real(psb_spk_), intent(inout), target :: x(:)
real(psb_spk_), intent(inout), target :: y(:)
type(psb_sspmat_type), intent(in) :: a
type(psb_s_sparse_mat), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_a
integer, intent(out) :: info
real(psb_spk_), optional, target :: work(:)
@ -581,8 +581,7 @@ subroutine psb_sspmv(alpha,a,x,beta,y,desc_a,info,&
& szero,x,desc_a,iwork,info,data=psb_comm_halo_)
end if
! local Matrix-vector product
call a%csmm(alpha,x(iix:lldx),beta,y(iiy:lldy),info)
call psb_csmm(alpha,a,x,beta,y,info)
if(info /= 0) then
info = 4011
@ -631,7 +630,7 @@ subroutine psb_sspmv(alpha,a,x,beta,y,desc_a,info,&
yp(nrow+1:ncol) = szero
! local Matrix-vector product
if (info == 0) call a%csmm(alpha,x,beta,yp,info,trans=trans_)
if (info == 0) call psb_csmm(alpha,a,x,beta,y,info,trans=trans_)
if (debug_level >= psb_debug_comp_) &
& write(debug_unit,*) me,' ',trim(name),' csmm ', info

42
base/psblas/psb_sspsm.f90
Unescape Escape View File

@ -75,10 +75,8 @@
!
!
subroutine psb_sspsm(alpha,a,x,beta,y,desc_a,info,&
& trans, unitd, choice, diag, k, jx, jy, work)
& trans, side, choice, diag, k, jx, jy, work)
use psb_spmat_type
use psb_serial_mod
use psb_descriptor_type
use psb_comm_mod
use psi_mod
@ -86,17 +84,18 @@ subroutine psb_sspsm(alpha,a,x,beta,y,desc_a,info,&
use psb_error_mod
use psb_string_mod
use psb_penv_mod
use psb_mat_mod
implicit none
real(psb_spk_), intent(in) :: alpha, beta
real(psb_spk_), intent(in), target :: x(:,:)
real(psb_spk_), intent(inout), target :: y(:,:)
type (psb_sspmat_type), intent(in) :: a
type (psb_s_sparse_mat), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_a
integer, intent(out) :: info
real(psb_spk_), intent(in), optional, target :: diag(:)
real(psb_spk_), optional, target :: work(:)
character, intent(in), optional :: trans, unitd
character, intent(in), optional :: trans, side
integer, intent(in), optional :: choice
integer, intent(in), optional :: k, jx, jy
@ -106,7 +105,7 @@ subroutine psb_sspsm(alpha,a,x,beta,y,desc_a,info,&
& ix, iy, ik, ijx, ijy, i, lld,&
& m, nrow, ncol, liwork, llwork, iiy, jjy, idx, ndm
character :: lunitd
character :: lside
integer, parameter :: nb=4
real(psb_spk_),pointer :: iwork(:), xp(:,:), yp(:,:), id(:)
character :: itrans
@ -158,10 +157,10 @@ subroutine psb_sspsm(alpha,a,x,beta,y,desc_a,info,&
choice_ = psb_avg_
endif
if (present(unitd)) then
lunitd = psb_toupper(unitd)
if (present(side)) then
lside = psb_toupper(side)
else
lunitd = 'U'
lside = 'U'
endif
if (present(trans)) then
@ -192,8 +191,6 @@ subroutine psb_sspsm(alpha,a,x,beta,y,desc_a,info,&
! check for presence/size of a work area
iwork => null()
liwork= 2*ncol
if (a%pr(1) /= 0) llwork = liwork + m * ik
if (a%pl(1) /= 0) llwork = llwork + m * ik
if (present(work)) then
if (size(work) >= liwork) then
aliw =.false.
@ -259,7 +256,7 @@ subroutine psb_sspsm(alpha,a,x,beta,y,desc_a,info,&
! Perform local triangular system solve
xp => x(iix:lldx,jjx:jjx+ik-1)
yp => y(iiy:lldy,jjy:jjy+ik-1)
call a%cssm(alpha,xp,beta,yp,info,unitd=lunitd,d=id,trans=itrans)
call psb_cssm(alpha,a,xp,beta,yp,info,side=side,d=diag,trans=trans)
if(info /= 0) then
info = 4010
@ -357,16 +354,14 @@ end subroutine psb_sspsm
! desc_a - type(psb_desc_type). The communication descriptor.
! info - integer. Return code
! trans - character(optional). Whether A or A'. If not present 'N' is assumed.
! unitd - character(optional). Specify some type of operation with
! side - character(optional). Specify some type of operation with
! the diagonal matrix D.
! choice - integer(optional). The kind of update to perform on overlap elements.
! d(:) - real , optional Matrix for diagonal scaling.
! work(:) - real , optional Working area.
!
subroutine psb_sspsv(alpha,a,x,beta,y,desc_a,info,&
& trans, unitd, choice, diag, work)
use psb_spmat_type
use psb_serial_mod
& trans, side, choice, diag, work)
use psb_descriptor_type
use psb_comm_mod
use psi_mod
@ -374,17 +369,18 @@ subroutine psb_sspsv(alpha,a,x,beta,y,desc_a,info,&
use psb_error_mod
use psb_string_mod
use psb_penv_mod
use psb_mat_mod
implicit none
real(psb_spk_), intent(in) :: alpha, beta
real(psb_spk_), intent(in), target :: x(:)
real(psb_spk_), intent(inout), target :: y(:)
type(psb_sspmat_type), intent(in) :: a
type(psb_s_sparse_mat), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_a
integer, intent(out) :: info
real(psb_spk_), intent(in), optional, target :: diag(:)
real(psb_spk_), optional, target :: work(:)
character, intent(in), optional :: trans, unitd
character, intent(in), optional :: trans, side
integer, intent(in), optional :: choice
! locals
@ -393,7 +389,7 @@ subroutine psb_sspsv(alpha,a,x,beta,y,desc_a,info,&
& ix, iy, ik, jx, jy, i, lld,&
& m, nrow, ncol, liwork, llwork, iiy, jjy, idx, ndm
character :: lunitd
character :: lside
integer, parameter :: nb=4
real(psb_spk_),pointer :: iwork(:), xp(:), yp(:), id(:)
character :: itrans
@ -429,10 +425,10 @@ subroutine psb_sspsv(alpha,a,x,beta,y,desc_a,info,&
choice_ = psb_avg_
endif
if (present(unitd)) then
lunitd = psb_toupper(unitd)
if (present(side)) then
lside = psb_toupper(side)
else
lunitd = 'U'
lside = 'U'
endif
if (present(trans)) then
@ -529,7 +525,7 @@ subroutine psb_sspsv(alpha,a,x,beta,y,desc_a,info,&
! Perform local triangular system solve
xp => x(iix:lldx)
yp => y(iiy:lldy)
call a%cssm(alpha,xp,beta,yp,info,unitd=lunitd,d=id,trans=itrans)
call psb_cssm(alpha,a,xp,beta,yp,info,side=side,d=diag,trans=trans)
if(info /= 0) then
info = 4010

6
base/serial/Makefile
Unescape Escape View File

@ -11,12 +11,6 @@ FOBJS = psb_cest.o \
psb_getifield.o psb_setifield.o psb_update_mod.o psb_getrow_mod.o\
psb_zgelp.o\
psb_zspshift.o psb_zspsetbld.o\
psb_scsprt.o psb_sspcnv.o psb_scoins.o psb_scsmm.o psb_scsmv.o \
psb_scssm.o psb_scssv.o psb_sneigh.o psb_sspgtblk.o psb_sspgetrow.o \
psb_sfixcoo.o psb_sipcsr2coo.o psb_sipcoo2csr.o psb_sipcoo2csc.o \
psb_sgelp.o psb_sspgtdiag.o psb_scsnmi.o psb_stransp.o \
psb_sspclip.o psb_srwextd.o psb_sspscal.o\
psb_snumbmm.o psb_ssymbmm.o\
psb_ccsprt.o psb_cspcnv.o psb_ccoins.o psb_ccsnmi.o\
psb_cfixcoo.o psb_cipcsr2coo.o psb_cipcoo2csr.o psb_cipcoo2csc.o \
psb_cgelp.o psb_cspgtdiag.o psb_cspgtblk.o psb_cspgetrow.o\

5
base/serial/coo/Makefile
Unescape Escape View File

@ -3,11 +3,12 @@ include ../../../Make.inc
#
# The object files
#
FOBJS = scoonrmi.o scoomm.o scoomv.o scoosm.o scoosv.o scoorws.o\
ccoonrmi.o ccoomm.o ccoomv.o ccoosm.o ccoosv.o ccoorws.o\
FOBJS = ccoonrmi.o ccoomm.o ccoomv.o ccoosm.o ccoosv.o ccoorws.o\
zcoomm.o zcoomv.o zcoonrmi.o zcoorws.o zcoosm.o zcoosv.o
# dcoonrmi.o dcoomm.o dcoomv.o dcoosm.o dcoosv.o dcoorws.o\
#scoonrmi.o scoomm.o scoomv.o scoosm.o scoosv.o scoorws.o\
OBJS=$(FOBJS)

6
base/serial/csr/Makefile
Unescape Escape View File

@ -4,13 +4,13 @@ include ../../../Make.inc
# The object files
#
FOBJS = scsrmm.o scsrmv.o scsrmv2.o scsrmv3.o scsrmv4.o scsrsm.o scsrsv.o\
scrnrmi.o \
ccrnrmi.o ccsrmm.o ccsrrws.o ccsrsm.o csrmv.o csrsv.o ccsrck.o\
FOBJS = ccrnrmi.o ccsrmm.o ccsrrws.o ccsrsm.o csrmv.o csrsv.o ccsrck.o\
zcrnrmi.o zcsrmm.o zcsrrws.o zcsrsm.o zsrmv.o zsrsv.o zcsrck.o
#dcsrck.o dcsrmm.o dcsrsm.o dcsrmv.o dcsrsv.o dcrnrmi.o \
# dcsrmv4.o dcsrmv2.o dcsrmv3.o dcsrrws.o\
# scsrmm.o scsrmv.o scsrmv2.o scsrmv3.o scsrmv4.o scsrsm.o scsrsv.o\
# scrnrmi.o \
OBJS=$(FOBJS)

2
base/serial/dp/Makefile
Unescape Escape View File

@ -8,7 +8,6 @@ FOBJS = partition.o dgblock.o dvtfg.o \
check_dim.o \
Max_nnzero.o \
gen_block.o\
scrco.o scrcr.o scocr.o scoco.o sgindex.o sgind_tri.o\
ccoco.o ccocr.o ccrco.o ccrcr.o cgindex.o cgind_tri.o\
zcoco.o zcocr.o zcrco.o zcrcr.o zgindex.o zgind_tri.o\
$(XOBJS)
@ -17,6 +16,7 @@ FOBJS = partition.o dgblock.o dvtfg.o \
#dcrcr.o
#dgindex.o djadrp.o djadrp1.o dcsrrp.o dcsrp1.o
#dcrjd.o
# scrco.o scrcr.o scocr.o scoco.o sgindex.o sgind_tri.o\
#
# dgind_tri.o

2
base/serial/f03/psb_d_csr_impl.f03
Unescape Escape View File

@ -807,7 +807,7 @@ subroutine d_csr_cssm_impl(alpha,a,x,beta,y,info,trans)
real(psb_dpk_), allocatable :: tmp(:,:)
logical :: tra
Integer :: err_act
character(len=20) :: name='d_base_csmm'
character(len=20) :: name='d_base_cssm'
logical, parameter :: debug=.false.
info = 0

14
base/serial/f03/psb_s_csr_impl.f03
Unescape Escape View File

@ -622,12 +622,24 @@ subroutine s_csr_cssv_impl(alpha,a,x,beta,y,info,trans)
tra = ((trans_=='T').or.(trans_=='t'))
m = a%get_nrows()
if (.not. (a%is_triangle())) then
info = 1121
call psb_errpush(info,name)
goto 9999
end if
if (size(x)<m) then
info = 36
call psb_errpush(info,name,i_err=(/3,m,0,0,0/))
goto 9999
end if
if (size(y)<m) then
info = 36
call psb_errpush(info,name,i_err=(/5,m,0,0,0/))
goto 9999
end if
if (alpha == szero) then
if (beta == szero) then
@ -807,7 +819,7 @@ subroutine s_csr_cssm_impl(alpha,a,x,beta,y,info,trans)
real(psb_spk_), allocatable :: tmp(:,:)
logical :: tra
Integer :: err_act
character(len=20) :: name='s_base_csmm'
character(len=20) :: name='s_base_cssm'
logical, parameter :: debug=.false.
info = 0

6
base/serial/f77/Makefile
Unescape Escape View File

@ -3,8 +3,8 @@ include ../../../Make.inc
#
# The object files
#
FOBJS = daxpby.o saxpby.o slpupd.o scsmm.o sswmm.o scsnmi.o scsrws.o\
sswsm.o scssm.o sgelp.o\
FOBJS = daxpby.o saxpby.o \
sgelp.o\
caxpby.o clpupd.o ccsmm.o cswmm.o ccsnmi.o ccsrws.o\
cswsm.o ccssm.o cgelp.o\
zcsnmi.o zaxpby.o zcsmm.o zcssm.o zswmm.o zswsm.o\
@ -13,6 +13,8 @@ FOBJS = daxpby.o saxpby.o slpupd.o scsmm.o sswmm.o scsnmi.o scsrws.o\
#dcsmm.o dcsnmi.o dcsrp.o dcssm.o \
# dgelp.o dlpupd.o dswmm.o \
# dswsm.o smmp.o dcsrws.o \
#slpupd.o scsmm.o sswmm.o scsnmi.o scsrws.o\
#sswsm.o scssm.o
OBJS=$(FOBJS)

5
base/serial/jad/Makefile
Unescape Escape View File

@ -3,8 +3,9 @@ include ../../../Make.inc
# The object files
#
FOBJS = sjadmm.o sjadmv.o sjadsm.o sjadsv.o sjdnrmi.o sjadnr.o\
sjadmv2.o sjadmv3.o sjadmv4.o sjadrws.o sjdrws.o
FOBJS =
# sjadmm.o sjadmv.o sjadsm.o sjadsv.o sjdnrmi.o sjadnr.o\
# sjadmv2.o sjadmv3.o sjadmv4.o sjadrws.o sjdrws.o
#djadmm.o djadmv.o djadsm.o djadsv.o djdnrmi.o djadnr.o\
# djadmv2.o djadmv3.o djadmv4.o djadrws.o djdrws.o \

850
base/serial/psb_getrow_mod.f90
Unescape Escape View File

@ -32,440 +32,440 @@
module psb_getrow_mod
interface csr_getrow
module procedure csr_sspgtrow, csr_cspgtrow, csr_zspgtrow
module procedure csr_cspgtrow, csr_zspgtrow
end interface
interface coo_getrow
module procedure coo_sspgtrow, coo_cspgtrow, coo_zspgtrow
module procedure coo_cspgtrow, coo_zspgtrow
end interface
interface jad_getrow
module procedure jad_sspgtrow, jad_cspgtrow, jad_zspgtrow
module procedure jad_cspgtrow, jad_zspgtrow
end interface
contains
subroutine csr_sspgtrow(irw,a,nz,ia,ja,val,nzin,append,lrw,info,iren)
use psb_sort_mod
use psb_spmat_type
use psb_const_mod
implicit none
type(psb_sspmat_type), intent(in) :: a
integer :: irw
integer, intent(out) :: nz
integer, allocatable, intent(inout) :: ia(:), ja(:)
real(psb_spk_), allocatable, intent(inout) :: val(:)
integer :: nzin
logical, intent(in) :: append
integer :: lrw,info
integer, optional :: iren(:)
integer :: idx,i,j, k, nr, row_idx, nzin_
integer, allocatable :: indices(:)
if (append) then
nzin_ = nzin
else
nzin_ = 0
endif
if (a%pl(1) /= 0) then
nr = lrw - irw + 1
allocate(indices(nr))
nz = 0
do i=1,nr
indices(i)=a%pl(irw+i-1)
nz=nz+a%ia2(indices(i)+1)-a%ia2(indices(i))
end do
call psb_ensure_size(nzin_+nz,ia,info)
if (info==0) call psb_ensure_size(nzin_+nz,ja,info)
if (info==0) call psb_ensure_size(nzin_+nz,val,info)
if (info /= 0) return
k=0
if(present(iren)) then
do i=1,nr
row_idx=indices(i)
do j=a%ia2(row_idx),a%ia2(row_idx+1)-1
k = k + 1
val(nzin_+k) = a%aspk(j)
ia(nzin_+k) = iren(row_idx)
ja(nzin_+k) = iren(a%ia1(j))
end do
end do
else
do i=1,nr
row_idx=indices(i)
do j=a%ia2(row_idx),a%ia2(row_idx+1)-1
k = k + 1
val(nzin_+k) = a%aspk(j)
ia(nzin_+k) = row_idx
ja(nzin_+k) = a%ia1(j)
end do
end do
end if
else
idx = irw
if (idx<0) then
write(0,*) ' spgtrow Error : idx no good ',idx
info = 2
return
end if
nr = lrw - irw + 1
nz = a%ia2(idx+nr) - a%ia2(idx)
call psb_ensure_size(nzin_+nz,ia,info)
if (info==0) call psb_ensure_size(nzin_+nz,ja,info)
if (info==0) call psb_ensure_size(nzin_+nz,val,info)
if (info /= 0) return
if (present(iren)) then
k=0
do i=irw,lrw
do j=a%ia2(i),a%ia2(i+1)-1
k = k + 1
val(nzin_+k) = a%aspk(j)
ia(nzin_+k) = iren(i)
ja(nzin_+k) = iren(a%ia1(j))
end do
enddo
else
k=0
do i=irw,lrw
do j=a%ia2(i),a%ia2(i+1)-1
k = k + 1
ia(nzin_+k) = i
ja(nzin_+k) = a%ia1(j)
val(nzin_+k) = a%aspk(j)
end do
enddo
end if
!!$ if (nz /= k) then
!!$ write(0,*) 'csr getrow Size mismatch ',nz,k
!!$ subroutine csr_sspgtrow(irw,a,nz,ia,ja,val,nzin,append,lrw,info,iren)
!!$
!!$ use psb_sort_mod
!!$ use psb_spmat_type
!!$ use psb_const_mod
!!$ implicit none
!!$
!!$ type(psb_sspmat_type), intent(in) :: a
!!$ integer :: irw
!!$ integer, intent(out) :: nz
!!$ integer, allocatable, intent(inout) :: ia(:), ja(:)
!!$ real(psb_spk_), allocatable, intent(inout) :: val(:)
!!$ integer :: nzin
!!$ logical, intent(in) :: append
!!$ integer :: lrw,info
!!$ integer, optional :: iren(:)
!!$
!!$ integer :: idx,i,j, k, nr, row_idx, nzin_
!!$ integer, allocatable :: indices(:)
!!$
!!$ if (append) then
!!$ nzin_ = nzin
!!$ else
!!$ nzin_ = 0
!!$ endif
!!$
!!$ if (a%pl(1) /= 0) then
!!$
!!$ nr = lrw - irw + 1
!!$ allocate(indices(nr))
!!$ nz = 0
!!$ do i=1,nr
!!$ indices(i)=a%pl(irw+i-1)
!!$ nz=nz+a%ia2(indices(i)+1)-a%ia2(indices(i))
!!$ end do
!!$
!!$ call psb_ensure_size(nzin_+nz,ia,info)
!!$ if (info==0) call psb_ensure_size(nzin_+nz,ja,info)
!!$ if (info==0) call psb_ensure_size(nzin_+nz,val,info)
!!$ if (info /= 0) return
!!$
!!$ k=0
!!$ if(present(iren)) then
!!$ do i=1,nr
!!$ row_idx=indices(i)
!!$ do j=a%ia2(row_idx),a%ia2(row_idx+1)-1
!!$ k = k + 1
!!$ val(nzin_+k) = a%aspk(j)
!!$ ia(nzin_+k) = iren(row_idx)
!!$ ja(nzin_+k) = iren(a%ia1(j))
!!$ end do
!!$ end do
!!$ else
!!$ do i=1,nr
!!$ row_idx=indices(i)
!!$ do j=a%ia2(row_idx),a%ia2(row_idx+1)-1
!!$ k = k + 1
!!$ val(nzin_+k) = a%aspk(j)
!!$ ia(nzin_+k) = row_idx
!!$ ja(nzin_+k) = a%ia1(j)
!!$ end do
!!$ end do
!!$ end if
!!$
!!$ else
!!$
!!$ idx = irw
!!$
!!$ if (idx<0) then
!!$ write(0,*) ' spgtrow Error : idx no good ',idx
!!$ info = 2
!!$ return
!!$ end if
!!$ nr = lrw - irw + 1
!!$ nz = a%ia2(idx+nr) - a%ia2(idx)
!!$
!!$ call psb_ensure_size(nzin_+nz,ia,info)
!!$ if (info==0) call psb_ensure_size(nzin_+nz,ja,info)
!!$ if (info==0) call psb_ensure_size(nzin_+nz,val,info)
!!$ if (info /= 0) return
!!$
!!$
!!$ if (present(iren)) then
!!$ k=0
!!$ do i=irw,lrw
!!$ do j=a%ia2(i),a%ia2(i+1)-1
!!$ k = k + 1
!!$ val(nzin_+k) = a%aspk(j)
!!$ ia(nzin_+k) = iren(i)
!!$ ja(nzin_+k) = iren(a%ia1(j))
!!$ end do
!!$ enddo
!!$ else
!!$ k=0
!!$
!!$ do i=irw,lrw
!!$ do j=a%ia2(i),a%ia2(i+1)-1
!!$ k = k + 1
!!$ ia(nzin_+k) = i
!!$ ja(nzin_+k) = a%ia1(j)
!!$ val(nzin_+k) = a%aspk(j)
!!$ end do
!!$ enddo
!!$ end if
!!$! !$ if (nz /= k) then
!!$! !$ write(0,*) 'csr getrow Size mismatch ',nz,k
!!$! !$ endif
!!$ if (a%pr(1) /= 0) then
!!$ write(0,*) 'Feeling lazy today, Right Permutation will have to wait'
!!$ endif
if (a%pr(1) /= 0) then
write(0,*) 'Feeling lazy today, Right Permutation will have to wait'
endif
endif
end subroutine csr_sspgtrow
subroutine coo_sspgtrow(irw,a,nz,ia,ja,val,nzin,append,lrw,info,iren)
use psb_sort_mod
use psb_spmat_type
use psb_const_mod
use psb_error_mod
implicit none
type(psb_sspmat_type), intent(in) :: a
integer :: irw
integer, intent(out) :: nz
integer, allocatable, intent(inout) :: ia(:), ja(:)
real(psb_spk_), allocatable, intent(inout) :: val(:)
integer :: nzin
logical, intent(in) :: append
integer :: lrw,info
integer, optional :: iren(:)
integer :: nzin_, nza, idx,ip,jp,i,k, nzt
integer :: debug_level, debug_unit
character(len=20) :: name='coo_sspgtrow'
debug_unit = psb_get_debug_unit()
debug_level = psb_get_debug_level()
nza = a%infoa(psb_nnz_)
if (a%pl(1) /= 0) then
write(debug_unit,*) 'Fatal error in SPGTROW: do not feed a permuted mat so far!'
idx = -1
else
idx = irw
endif
if (idx<0) then
write(debug_unit,*) ' spgtrow Error : idx no good ',idx
info = 2
return
end if
if (append) then
nzin_ = nzin
else
nzin_ = 0
endif
if (a%infoa(psb_srtd_) == psb_isrtdcoo_) then
! In this case we can do a binary search.
if (debug_level >= psb_debug_serial_)&
& write(debug_unit,*) trim(name), ': srtdcoo '
do
ip = psb_ibsrch(irw,nza,a%ia1)
if (ip /= -1) exit
irw = irw + 1
if (irw > lrw) then
write(debug_unit,*) trim(name),&
& 'Warning : did not find any rows. Is this an error? ',&
& irw,lrw,idx
exit
end if
end do
if (ip /= -1) then
! expand [ip,jp] to contain all row entries.
do
if (ip < 2) exit
if (a%ia1(ip-1) == irw) then
ip = ip -1
else
exit
end if
end do
end if
do
jp = psb_ibsrch(lrw,nza,a%ia1)
if (jp /= -1) exit
lrw = lrw - 1
if (irw > lrw) then
write(debug_unit,*) trim(name),&
& 'Warning : did not find any rows. Is this an error?'
exit
end if
end do
if (jp /= -1) then
! expand [ip,jp] to contain all row entries.
do
if (jp == nza) exit
if (a%ia1(jp+1) == lrw) then
jp = jp + 1
else
exit
end if
end do
end if
if (debug_level >= psb_debug_serial_) &
& write(debug_unit,*) trim(name),': ip jp',ip,jp,nza
if ((ip /= -1) .and.(jp /= -1)) then
! Now do the copy.
nz = jp - ip +1
call psb_ensure_size(nzin_+nz,ia,info)
if (info==0) call psb_ensure_size(nzin_+nz,ja,info)
if (info==0) call psb_ensure_size(nzin_+nz,val,info)
if (info /= 0) return
if (present(iren)) then
do i=ip,jp
nzin_ = nzin_ + 1
val(nzin_) = a%aspk(i)
ia(nzin_) = iren(a%ia1(i))
ja(nzin_) = iren(a%ia2(i))
enddo
else
do i=ip,jp
nzin_ = nzin_ + 1
val(nzin_) = a%aspk(i)
ia(nzin_) = a%ia1(i)
ja(nzin_) = a%ia2(i)
enddo
end if
else
nz = 0
end if
else
if (debug_level >= psb_debug_serial_) &
& write(debug_unit,*) trim(name),': unsorted '
nzt = (nza*(lrw-irw+1))/max(a%m,1)
call psb_ensure_size(nzin_+nzt,ia,info)
if (info==0) call psb_ensure_size(nzin_+nzt,ja,info)
if (info==0) call psb_ensure_size(nzin_+nzt,val,info)
if (info /= 0) return
if (present(iren)) then
k = 0
do i=1, a%infoa(psb_nnz_)
if ((a%ia1(i)>=irw).and.(a%ia1(i)<=lrw)) then
k = k + 1
if (k > nzt) then
nzt = k
call psb_ensure_size(nzin_+nzt,ia,info)
if (info==0) call psb_ensure_size(nzin_+nzt,ja,info)
if (info==0) call psb_ensure_size(nzin_+nzt,val,info)
if (info /= 0) return
end if
val(nzin_+k) = a%aspk(i)
ia(nzin_+k) = iren(a%ia1(i))
ja(nzin_+k) = iren(a%ia2(i))
endif
enddo
else
k = 0
do i=1,a%infoa(psb_nnz_)
if ((a%ia1(i)>=irw).and.(a%ia1(i)<=lrw)) then
k = k + 1
if (k > nzt) then
nzt = k
call psb_ensure_size(nzin_+nzt,ia,info)
if (info==0) call psb_ensure_size(nzin_+nzt,ja,info)
if (info==0) call psb_ensure_size(nzin_+nzt,val,info)
if (info /= 0) return
end if
val(nzin_+k) = a%aspk(i)
ia(nzin_+k) = (a%ia1(i))
ja(nzin_+k) = (a%ia2(i))
endif
enddo
nzin_=nzin_+k
end if
nz = k
end if
end subroutine coo_sspgtrow
subroutine jad_sspgtrow(irw,a,nz,ia,ja,val,nzin,append,lrw,info,iren)
use psb_sort_mod
use psb_spmat_type
use psb_const_mod
implicit none
type(psb_sspmat_type), intent(in), target :: a
integer :: irw
integer, intent(out) :: nz
integer, allocatable, intent(inout) :: ia(:), ja(:)
real(psb_spk_), allocatable, intent(inout) :: val(:)
integer :: nzin
logical, intent(in) :: append
integer, optional :: iren(:)
integer :: lrw,info
integer, pointer :: ia1(:), ia2(:), ia3(:),&
& ja_(:), ka_(:), indices(:), blks(:)
integer :: png, pia, pja, ipx, blk, rb, row, k_pt, npg, col, ng, nzin_,&
& i,j,k,nr
png = a%ia2(1) ! points to the number of blocks
pia = a%ia2(2) ! points to the beginning of ia(3,png)
pja = a%ia2(3) ! points to the beginning of ja(:)
ng = a%ia2(png) ! the number of blocks
ja_ => a%ia2(pja:) ! the array containing the pointers to ka and aspk
ka_ => a%ia1(:) ! the array containing the column indices
ia1 => a%ia2(pia:pja-1:3) ! the array containing the first row index of each block
ia2 => a%ia2(pia+1:pja-1:3) ! the array containing a pointer to the pos. in ja to the first jad column
ia3 => a%ia2(pia+2:pja-1:3) ! the array containing a pointer to the pos. in ja to the first csr column
if (append) then
nzin_ = nzin
else
nzin_ = 0
endif
if (a%pl(1) /= 0) then
nr = lrw - irw + 1
allocate(indices(nr),blks(nr))
nz = 0
do i=1,nr
indices(i)=a%pl(irw+i-1)
j=0
blkfnd: do
j=j+1
if(ia1(j) == indices(i)) then
blks(i)=j
nz=nz+ia3(j)-ia2(j)
ipx = ia1(j) ! the first row index of the block
rb = indices(i)-ipx ! the row offset within the block
row = ia3(j)+rb
nz = nz+ja_(row+1)-ja_(row)
exit blkfnd
else if(ia1(j) > indices(i)) then
blks(i)=j-1
nz=nz+ia3(j-1)-ia2(j-1)
ipx = ia1(j-1) ! the first row index of the block
rb = indices(i)-ipx ! the row offset within the block
row = ia3(j-1)+rb
nz = nz+ja_(row+1)-ja_(row)
exit blkfnd
end if
end do blkfnd
end do
call psb_ensure_size(nzin_+nz,ia,info)
if (info==0) call psb_ensure_size(nzin_+nz,ja,info)
if (info==0) call psb_ensure_size(nzin_+nz,val,info)
if (info /= 0) return
k=0
! cycle over rows
do i=1,nr
! find which block the row belongs to
blk = blks(i)
! extract first part of the row from the jad block
ipx = ia1(blk) ! the first row index of the block
k_pt= ia2(blk) ! the pointer to the beginning of a column in ja
rb = indices(i)-ipx ! the row offset within the block
npg = ja_(k_pt+1)-ja_(k_pt) ! the number of rows in the block
if(present(iren))then
do col = ia2(blk), ia3(blk)-1
k=k+1
val(nzin_+k) = a%aspk(ja_(col)+rb)
ia(nzin_+k) = iren(irw+i-1)
ja(nzin_+k) = iren(ka_(ja_(col)+rb))
end do
else
do col = ia2(blk), ia3(blk)-1
k=k+1
val(nzin_+k) = a%aspk(ja_(col)+rb)
ia(nzin_+k) = irw+i-1
ja(nzin_+k) = ka_(ja_(col)+rb)
end do
end if
! extract second part of the row from the csr tail
row=ia3(blk)+rb
if(present(iren))then
do j=ja_(row), ja_(row+1)-1
k=k+1
val(nzin_+k) = a%aspk(j)
ia(nzin_+k) = iren(irw+i-1)
ja(nzin_+k) = iren(ka_(j))
end do
else
do j=ja_(row), ja_(row+1)-1
k=k+1
val(nzin_+k) = a%aspk(j)
ia(nzin_+k) = irw+i-1
ja(nzin_+k) = ka_(j)
end do
end if
end do
else
! There might be some problems
info=134
end if
end subroutine jad_sspgtrow
!!$
!!$ endif
!!$
!!$ end subroutine csr_sspgtrow
!!$
!!$ subroutine coo_sspgtrow(irw,a,nz,ia,ja,val,nzin,append,lrw,info,iren)
!!$
!!$ use psb_sort_mod
!!$ use psb_spmat_type
!!$ use psb_const_mod
!!$ use psb_error_mod
!!$ implicit none
!!$
!!$ type(psb_sspmat_type), intent(in) :: a
!!$ integer :: irw
!!$ integer, intent(out) :: nz
!!$ integer, allocatable, intent(inout) :: ia(:), ja(:)
!!$ real(psb_spk_), allocatable, intent(inout) :: val(:)
!!$ integer :: nzin
!!$ logical, intent(in) :: append
!!$ integer :: lrw,info
!!$ integer, optional :: iren(:)
!!$ integer :: nzin_, nza, idx,ip,jp,i,k, nzt
!!$ integer :: debug_level, debug_unit
!!$ character(len=20) :: name='coo_sspgtrow'
!!$
!!$ debug_unit = psb_get_debug_unit()
!!$ debug_level = psb_get_debug_level()
!!$
!!$ nza = a%infoa(psb_nnz_)
!!$ if (a%pl(1) /= 0) then
!!$ write(debug_unit,*) 'Fatal error in SPGTROW: do not feed a permuted mat so far!'
!!$ idx = -1
!!$ else
!!$ idx = irw
!!$ endif
!!$ if (idx<0) then
!!$ write(debug_unit,*) ' spgtrow Error : idx no good ',idx
!!$ info = 2
!!$ return
!!$ end if
!!$
!!$ if (append) then
!!$ nzin_ = nzin
!!$ else
!!$ nzin_ = 0
!!$ endif
!!$
!!$ if (a%infoa(psb_srtd_) == psb_isrtdcoo_) then
!!$ ! In this case we can do a binary search.
!!$ if (debug_level >= psb_debug_serial_)&
!!$ & write(debug_unit,*) trim(name), ': srtdcoo '
!!$ do
!!$ ip = psb_ibsrch(irw,nza,a%ia1)
!!$ if (ip /= -1) exit
!!$ irw = irw + 1
!!$ if (irw > lrw) then
!!$ write(debug_unit,*) trim(name),&
!!$ & 'Warning : did not find any rows. Is this an error? ',&
!!$ & irw,lrw,idx
!!$ exit
!!$ end if
!!$ end do
!!$
!!$ if (ip /= -1) then
!!$ ! expand [ip,jp] to contain all row entries.
!!$ do
!!$ if (ip < 2) exit
!!$ if (a%ia1(ip-1) == irw) then
!!$ ip = ip -1
!!$ else
!!$ exit
!!$ end if
!!$ end do
!!$
!!$ end if
!!$
!!$ do
!!$ jp = psb_ibsrch(lrw,nza,a%ia1)
!!$ if (jp /= -1) exit
!!$ lrw = lrw - 1
!!$ if (irw > lrw) then
!!$ write(debug_unit,*) trim(name),&
!!$ & 'Warning : did not find any rows. Is this an error?'
!!$ exit
!!$ end if
!!$ end do
!!$
!!$ if (jp /= -1) then
!!$ ! expand [ip,jp] to contain all row entries.
!!$ do
!!$ if (jp == nza) exit
!!$ if (a%ia1(jp+1) == lrw) then
!!$ jp = jp + 1
!!$ else
!!$ exit
!!$ end if
!!$ end do
!!$ end if
!!$ if (debug_level >= psb_debug_serial_) &
!!$ & write(debug_unit,*) trim(name),': ip jp',ip,jp,nza
!!$ if ((ip /= -1) .and.(jp /= -1)) then
!!$ ! Now do the copy.
!!$ nz = jp - ip +1
!!$
!!$ call psb_ensure_size(nzin_+nz,ia,info)
!!$ if (info==0) call psb_ensure_size(nzin_+nz,ja,info)
!!$ if (info==0) call psb_ensure_size(nzin_+nz,val,info)
!!$ if (info /= 0) return
!!$
!!$ if (present(iren)) then
!!$ do i=ip,jp
!!$ nzin_ = nzin_ + 1
!!$ val(nzin_) = a%aspk(i)
!!$ ia(nzin_) = iren(a%ia1(i))
!!$ ja(nzin_) = iren(a%ia2(i))
!!$ enddo
!!$ else
!!$ do i=ip,jp
!!$ nzin_ = nzin_ + 1
!!$ val(nzin_) = a%aspk(i)
!!$ ia(nzin_) = a%ia1(i)
!!$ ja(nzin_) = a%ia2(i)
!!$ enddo
!!$ end if
!!$ else
!!$ nz = 0
!!$ end if
!!$
!!$ else
!!$ if (debug_level >= psb_debug_serial_) &
!!$ & write(debug_unit,*) trim(name),': unsorted '
!!$
!!$ nzt = (nza*(lrw-irw+1))/max(a%m,1)
!!$ call psb_ensure_size(nzin_+nzt,ia,info)
!!$ if (info==0) call psb_ensure_size(nzin_+nzt,ja,info)
!!$ if (info==0) call psb_ensure_size(nzin_+nzt,val,info)
!!$ if (info /= 0) return
!!$
!!$ if (present(iren)) then
!!$ k = 0
!!$ do i=1, a%infoa(psb_nnz_)
!!$ if ((a%ia1(i)>=irw).and.(a%ia1(i)<=lrw)) then
!!$ k = k + 1
!!$ if (k > nzt) then
!!$ nzt = k
!!$ call psb_ensure_size(nzin_+nzt,ia,info)
!!$ if (info==0) call psb_ensure_size(nzin_+nzt,ja,info)
!!$ if (info==0) call psb_ensure_size(nzin_+nzt,val,info)
!!$ if (info /= 0) return
!!$ end if
!!$ val(nzin_+k) = a%aspk(i)
!!$ ia(nzin_+k) = iren(a%ia1(i))
!!$ ja(nzin_+k) = iren(a%ia2(i))
!!$ endif
!!$ enddo
!!$ else
!!$ k = 0
!!$ do i=1,a%infoa(psb_nnz_)
!!$ if ((a%ia1(i)>=irw).and.(a%ia1(i)<=lrw)) then
!!$ k = k + 1
!!$ if (k > nzt) then
!!$ nzt = k
!!$ call psb_ensure_size(nzin_+nzt,ia,info)
!!$ if (info==0) call psb_ensure_size(nzin_+nzt,ja,info)
!!$ if (info==0) call psb_ensure_size(nzin_+nzt,val,info)
!!$ if (info /= 0) return
!!$
!!$ end if
!!$ val(nzin_+k) = a%aspk(i)
!!$ ia(nzin_+k) = (a%ia1(i))
!!$ ja(nzin_+k) = (a%ia2(i))
!!$ endif
!!$ enddo
!!$ nzin_=nzin_+k
!!$ end if
!!$ nz = k
!!$ end if
!!$
!!$ end subroutine coo_sspgtrow
!!$
!!$
!!$ subroutine jad_sspgtrow(irw,a,nz,ia,ja,val,nzin,append,lrw,info,iren)
!!$
!!$ use psb_sort_mod
!!$ use psb_spmat_type
!!$ use psb_const_mod
!!$
!!$ implicit none
!!$
!!$ type(psb_sspmat_type), intent(in), target :: a
!!$ integer :: irw
!!$ integer, intent(out) :: nz
!!$ integer, allocatable, intent(inout) :: ia(:), ja(:)
!!$ real(psb_spk_), allocatable, intent(inout) :: val(:)
!!$ integer :: nzin
!!$ logical, intent(in) :: append
!!$ integer, optional :: iren(:)
!!$ integer :: lrw,info
!!$
!!$ integer, pointer :: ia1(:), ia2(:), ia3(:),&
!!$ & ja_(:), ka_(:), indices(:), blks(:)
!!$ integer :: png, pia, pja, ipx, blk, rb, row, k_pt, npg, col, ng, nzin_,&
!!$ & i,j,k,nr
!!$
!!$
!!$ png = a%ia2(1) ! points to the number of blocks
!!$ pia = a%ia2(2) ! points to the beginning of ia(3,png)
!!$ pja = a%ia2(3) ! points to the beginning of ja(:)
!!$
!!$ ng = a%ia2(png) ! the number of blocks
!!$ ja_ => a%ia2(pja:) ! the array containing the pointers to ka and aspk
!!$ ka_ => a%ia1(:) ! the array containing the column indices
!!$ ia1 => a%ia2(pia:pja-1:3) ! the array containing the first row index of each block
!!$ ia2 => a%ia2(pia+1:pja-1:3) ! the array containing a pointer to the pos. in ja to the first jad column
!!$ ia3 => a%ia2(pia+2:pja-1:3) ! the array containing a pointer to the pos. in ja to the first csr column
!!$
!!$ if (append) then
!!$ nzin_ = nzin
!!$ else
!!$ nzin_ = 0
!!$ endif
!!$
!!$ if (a%pl(1) /= 0) then
!!$
!!$ nr = lrw - irw + 1
!!$ allocate(indices(nr),blks(nr))
!!$ nz = 0
!!$
!!$ do i=1,nr
!!$ indices(i)=a%pl(irw+i-1)
!!$ j=0
!!$ blkfnd: do
!!$ j=j+1
!!$ if(ia1(j) == indices(i)) then
!!$ blks(i)=j
!!$ nz=nz+ia3(j)-ia2(j)
!!$ ipx = ia1(j) ! the first row index of the block
!!$ rb = indices(i)-ipx ! the row offset within the block
!!$ row = ia3(j)+rb
!!$ nz = nz+ja_(row+1)-ja_(row)
!!$ exit blkfnd
!!$ else if(ia1(j) > indices(i)) then
!!$ blks(i)=j-1
!!$ nz=nz+ia3(j-1)-ia2(j-1)
!!$ ipx = ia1(j-1) ! the first row index of the block
!!$ rb = indices(i)-ipx ! the row offset within the block
!!$ row = ia3(j-1)+rb
!!$ nz = nz+ja_(row+1)-ja_(row)
!!$ exit blkfnd
!!$ end if
!!$ end do blkfnd
!!$ end do
!!$
!!$
!!$ call psb_ensure_size(nzin_+nz,ia,info)
!!$ if (info==0) call psb_ensure_size(nzin_+nz,ja,info)
!!$ if (info==0) call psb_ensure_size(nzin_+nz,val,info)
!!$ if (info /= 0) return
!!$
!!$ k=0
!!$ ! cycle over rows
!!$ do i=1,nr
!!$
!!$ ! find which block the row belongs to
!!$ blk = blks(i)
!!$
!!$ ! extract first part of the row from the jad block
!!$ ipx = ia1(blk) ! the first row index of the block
!!$ k_pt= ia2(blk) ! the pointer to the beginning of a column in ja
!!$ rb = indices(i)-ipx ! the row offset within the block
!!$ npg = ja_(k_pt+1)-ja_(k_pt) ! the number of rows in the block
!!$
!!$ if(present(iren))then
!!$ do col = ia2(blk), ia3(blk)-1
!!$ k=k+1
!!$ val(nzin_+k) = a%aspk(ja_(col)+rb)
!!$ ia(nzin_+k) = iren(irw+i-1)
!!$ ja(nzin_+k) = iren(ka_(ja_(col)+rb))
!!$ end do
!!$ else
!!$ do col = ia2(blk), ia3(blk)-1
!!$ k=k+1
!!$ val(nzin_+k) = a%aspk(ja_(col)+rb)
!!$ ia(nzin_+k) = irw+i-1
!!$ ja(nzin_+k) = ka_(ja_(col)+rb)
!!$ end do
!!$ end if
!!$ ! extract second part of the row from the csr tail
!!$ row=ia3(blk)+rb
!!$ if(present(iren))then
!!$ do j=ja_(row), ja_(row+1)-1
!!$ k=k+1
!!$ val(nzin_+k) = a%aspk(j)
!!$ ia(nzin_+k) = iren(irw+i-1)
!!$ ja(nzin_+k) = iren(ka_(j))
!!$ end do
!!$ else
!!$ do j=ja_(row), ja_(row+1)-1
!!$ k=k+1
!!$ val(nzin_+k) = a%aspk(j)
!!$ ia(nzin_+k) = irw+i-1
!!$ ja(nzin_+k) = ka_(j)
!!$ end do
!!$ end if
!!$ end do
!!$
!!$ else
!!$ ! There might be some problems
!!$ info=134
!!$ end if
!!$
!!$ end subroutine jad_sspgtrow
!!$ subroutine csr_dspgtrow(irw,a,nz,ia,ja,val,nzin,append,lrw,info,iren)

640
base/serial/psb_regen_mod.f90
Unescape Escape View File

@ -32,334 +32,334 @@
module psb_regen_mod
interface csr_regen
module procedure csr_ssp_regen, csr_csp_regen, csr_zsp_regen
module procedure csr_csp_regen, csr_zsp_regen
end interface
interface coo_regen
module procedure coo_ssp_regen, coo_csp_regen, coo_zsp_regen
module procedure coo_csp_regen, coo_zsp_regen
end interface
interface jad_regen
module procedure jad_ssp_regen, jad_csp_regen, jad_zsp_regen
module procedure jad_csp_regen, jad_zsp_regen
end interface
contains
subroutine csr_ssp_regen(a,info)
use psb_spmat_type
use psb_const_mod
use psb_error_mod
implicit none
type(psb_sspmat_type), intent(inout) :: a
integer :: info
integer :: i, ip1,ip2,nnz,iflag,ichk,nnzt
real(psb_spk_), allocatable :: work(:)
integer :: err_act
character(len=20) :: name
integer :: debug_level, debug_unit
name='psb_spcnv'
info = 0
call psb_erractionsave(err_act)
debug_unit = psb_get_debug_unit()
debug_level = psb_get_debug_level()
!
! dupl_ and upd_ fields should not be changed.
!
select case(psb_sp_getifld(psb_upd_,a,info))
case(psb_upd_perm_)
allocate(work(size(a%aspk)+1000),stat=info)
if (info /= 0) then
info=2040
call psb_errpush(info,name)
goto 9999
end if
if (debug_level >= psb_debug_serial_)&
& write(debug_unit,*) trim(name),'Regeneration with psb_upd_perm_'
ip1 = psb_sp_getifld(psb_upd_pnt_,a,info)
ip2 = a%ia2(ip1+psb_ip2_)
nnz = a%ia2(ip1+psb_nnz_)
iflag = a%ia2(ip1+psb_iflag_)
ichk = a%ia2(ip1+psb_ichk_)
nnzt = a%ia2(ip1+psb_nnzt_)
if (debug_level >= psb_debug_serial_) &
& write(debug_unit,*) trim(name),'Regeneration start: ',&
& a%infoa(psb_upd_),psb_upd_perm_,nnz,nnzt ,iflag,info
if ((ichk/=nnzt+iflag).or.(nnz/=nnzt)) then
info = 8889
write(debug_unit,*) trim(name),'Regeneration start error: ',&
& a%infoa(psb_upd_),psb_upd_perm_,nnz,nnzt ,iflag,ichk
call psb_errpush(info,name)
goto 9999
endif
do i= 1, nnz
work(i) = dzero
enddo
select case(iflag)
case(psb_dupl_ovwrt_,psb_dupl_err_)
do i=1, nnz
work(a%ia2(ip2+i-1)) = a%aspk(i)
enddo
case(psb_dupl_add_)
do i=1, nnz
work(a%ia2(ip2+i-1)) = a%aspk(i) + work(a%ia2(ip2+i-1))
enddo
case default
info = 8887
call psb_errpush(info,name)
goto 9999
end select
do i=1, nnz
a%aspk(i) = work(i)
enddo
case(psb_upd_srch_)
! Nothing to be done here.
if (debug_level >= psb_debug_serial_)&
& write(debug_unit,*) trim(name),&
& 'Going through on regeneration with psb_upd_srch_'
case default
! Wrong value
info = 8888
call psb_errpush(info,name)
goto 9999
end select
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 csr_ssp_regen
subroutine coo_ssp_regen(a,info)
use psb_spmat_type
use psb_const_mod
use psb_error_mod
implicit none
type(psb_sspmat_type), intent(inout) :: a
integer :: info
integer :: i, ip1,ip2,nnz,iflag,ichk,nnzt
real(psb_spk_), allocatable :: work(:)
integer :: err_act
character(len=20) :: name
integer :: debug_level, debug_unit
name='psb_spcnv'
info = 0
call psb_erractionsave(err_act)
debug_unit = psb_get_debug_unit()
debug_level = psb_get_debug_level()
!
! dupl_ and upd_ fields should not be changed.
!
select case(psb_sp_getifld(psb_upd_,a,info))
case(psb_upd_perm_)
allocate(work(size(a%aspk)+1000),stat=info)
if (info /= 0) then
info=2040
call psb_errpush(info,name)
goto 9999
end if
if (debug_level >= psb_debug_serial_)&
& write(debug_unit,*) trim(name),'Regeneration with psb_upd_perm_'
ip1 = psb_sp_getifld(psb_upd_pnt_,a,info)
ip2 = a%ia2(ip1+psb_ip2_)
nnz = a%ia2(ip1+psb_nnz_)
iflag = a%ia2(ip1+psb_iflag_)
ichk = a%ia2(ip1+psb_ichk_)
nnzt = a%ia2(ip1+psb_nnzt_)
if (debug_level >= psb_debug_serial_)&
& write(debug_unit,*) trim(name),'Regeneration start: ',&
& a%infoa(psb_upd_),psb_upd_perm_,nnz,nnzt ,iflag,info
if ((ichk/=nnzt+iflag).or.(nnz/=nnzt)) then
info = 8889
write(debug_unit,*) trim(name),'Regeneration start error: ',&
& a%infoa(psb_upd_),psb_upd_perm_,nnz,nnzt ,iflag,ichk
call psb_errpush(info,name)
goto 9999
endif
do i= 1, nnz
work(i) = dzero
enddo
select case(iflag)
case(psb_dupl_ovwrt_,psb_dupl_err_)
do i=1, nnz
work(a%ia2(ip2+i-1)) = a%aspk(i)
enddo
case(psb_dupl_add_)
do i=1, nnz
work(a%ia2(ip2+i-1)) = a%aspk(i) + work(a%ia2(ip2+i-1))
enddo
case default
info = 8887
call psb_errpush(info,name)
goto 9999
end select
do i=1, nnz
a%aspk(i) = work(i)
enddo
case(psb_upd_srch_)
! Nothing to be done here.
if (debug_level >= psb_debug_serial_) &
& write(debug_unit,*) trim(name),&
& 'Going through on regeneration with psb_upd_srch_'
case default
! Wrong value
info = 8888
call psb_errpush(info,name)
goto 9999
end select
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 coo_ssp_regen
subroutine jad_ssp_regen(a,info)
use psb_spmat_type
use psb_const_mod
use psb_error_mod
implicit none
type(psb_sspmat_type), intent(inout) :: a
integer :: info
integer :: i, ip1,ip2,nnz,iflag,ichk,nnzt
real(psb_spk_), allocatable :: work(:)
integer :: err_act
character(len=20) :: name
integer :: debug_level, debug_unit
name='psb_spcnv'
info = 0
call psb_erractionsave(err_act)
debug_unit = psb_get_debug_unit()
debug_level = psb_get_debug_level()
!
! dupl_ and upd_ fields should not be changed.
!
select case(psb_sp_getifld(psb_upd_,a,info))
case(psb_upd_perm_)
allocate(work(size(a%aspk)+1000),stat=info)
if (info /= 0) then
info=2040
call psb_errpush(info,name)
goto 9999
end if
if (debug_level >= psb_debug_serial_)&
& write(debug_unit,*) trim(name),'Regeneration with psb_upd_perm_'
ip1 = psb_sp_getifld(psb_upd_pnt_,a,info)
ip2 = a%ia1(ip1+psb_ip2_)
nnz = a%ia1(ip1+psb_nnz_)
iflag = a%ia1(ip1+psb_iflag_)
ichk = a%ia1(ip1+psb_ichk_)
nnzt = a%ia1(ip1+psb_nnzt_)
if (debug_level >= psb_debug_serial_)&
& write(debug_unit,*) trim(name),'Regeneration start: ',&
& a%infoa(psb_upd_),psb_upd_perm_,nnz,nnzt ,iflag,info
if ((ichk/=nnzt+iflag).or.(nnz/=nnzt)) then
info = 8889
write(debug_unit,*) trim(name),'Regeneration start error: ',&
& a%infoa(psb_upd_),psb_upd_perm_,nnz,nnzt ,iflag,ichk
call psb_errpush(info,name)
goto 9999
endif
do i= 1, nnz
work(i) = dzero
enddo
select case(iflag)
case(psb_dupl_ovwrt_,psb_dupl_err_)
do i=1, nnz
work(a%ia1(ip2+i-1)) = a%aspk(i)
enddo
case(psb_dupl_add_)
do i=1, nnz
work(a%ia1(ip2+i-1)) = a%aspk(i) + work(a%ia1(ip2+i-1))
enddo
case default
info = 8887
call psb_errpush(info,name)
goto 9999
end select
do i=1, nnz
a%aspk(i) = work(i)
enddo
case(psb_upd_srch_)
! Nothing to be done here.
if (debug_level >= psb_debug_serial_)&
& write(debug_unit,*) trim(name),&
& 'Going through on regeneration with psb_upd_srch_'
case default
! Wrong value
info = 8888
call psb_errpush(info,name)
goto 9999
end select
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 jad_ssp_regen
!!$ subroutine csr_ssp_regen(a,info)
!!$
!!$ use psb_spmat_type
!!$ use psb_const_mod
!!$ use psb_error_mod
!!$ implicit none
!!$
!!$ type(psb_sspmat_type), intent(inout) :: a
!!$ integer :: info
!!$
!!$ integer :: i, ip1,ip2,nnz,iflag,ichk,nnzt
!!$ real(psb_spk_), allocatable :: work(:)
!!$ integer :: err_act
!!$ character(len=20) :: name
!!$ integer :: debug_level, debug_unit
!!$
!!$
!!$ name='psb_spcnv'
!!$ info = 0
!!$ call psb_erractionsave(err_act)
!!$ debug_unit = psb_get_debug_unit()
!!$ debug_level = psb_get_debug_level()
!!$
!!$
!!$ !
!!$ ! dupl_ and upd_ fields should not be changed.
!!$ !
!!$ select case(psb_sp_getifld(psb_upd_,a,info))
!!$
!!$ case(psb_upd_perm_)
!!$
!!$ allocate(work(size(a%aspk)+1000),stat=info)
!!$ if (info /= 0) then
!!$ info=2040
!!$ call psb_errpush(info,name)
!!$ goto 9999
!!$ end if
!!$
!!$ if (debug_level >= psb_debug_serial_)&
!!$ & write(debug_unit,*) trim(name),'Regeneration with psb_upd_perm_'
!!$ ip1 = psb_sp_getifld(psb_upd_pnt_,a,info)
!!$ ip2 = a%ia2(ip1+psb_ip2_)
!!$ nnz = a%ia2(ip1+psb_nnz_)
!!$ iflag = a%ia2(ip1+psb_iflag_)
!!$ ichk = a%ia2(ip1+psb_ichk_)
!!$ nnzt = a%ia2(ip1+psb_nnzt_)
!!$ if (debug_level >= psb_debug_serial_) &
!!$ & write(debug_unit,*) trim(name),'Regeneration start: ',&
!!$ & a%infoa(psb_upd_),psb_upd_perm_,nnz,nnzt ,iflag,info
!!$
!!$ if ((ichk/=nnzt+iflag).or.(nnz/=nnzt)) then
!!$ info = 8889
!!$ write(debug_unit,*) trim(name),'Regeneration start error: ',&
!!$ & a%infoa(psb_upd_),psb_upd_perm_,nnz,nnzt ,iflag,ichk
!!$ call psb_errpush(info,name)
!!$ goto 9999
!!$ endif
!!$ do i= 1, nnz
!!$ work(i) = dzero
!!$ enddo
!!$ select case(iflag)
!!$ case(psb_dupl_ovwrt_,psb_dupl_err_)
!!$ do i=1, nnz
!!$ work(a%ia2(ip2+i-1)) = a%aspk(i)
!!$ enddo
!!$ case(psb_dupl_add_)
!!$ do i=1, nnz
!!$ work(a%ia2(ip2+i-1)) = a%aspk(i) + work(a%ia2(ip2+i-1))
!!$ enddo
!!$ case default
!!$ info = 8887
!!$ call psb_errpush(info,name)
!!$ goto 9999
!!$ end select
!!$
!!$ do i=1, nnz
!!$ a%aspk(i) = work(i)
!!$ enddo
!!$
!!$
!!$ case(psb_upd_srch_)
!!$ ! Nothing to be done here.
!!$ if (debug_level >= psb_debug_serial_)&
!!$ & write(debug_unit,*) trim(name),&
!!$ & 'Going through on regeneration with psb_upd_srch_'
!!$ case default
!!$ ! Wrong value
!!$ info = 8888
!!$ call psb_errpush(info,name)
!!$ goto 9999
!!$
!!$ end select
!!$
!!$ 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 csr_ssp_regen
!!$
!!$ subroutine coo_ssp_regen(a,info)
!!$
!!$ use psb_spmat_type
!!$ use psb_const_mod
!!$ use psb_error_mod
!!$ implicit none
!!$
!!$ type(psb_sspmat_type), intent(inout) :: a
!!$ integer :: info
!!$
!!$ integer :: i, ip1,ip2,nnz,iflag,ichk,nnzt
!!$ real(psb_spk_), allocatable :: work(:)
!!$ integer :: err_act
!!$ character(len=20) :: name
!!$ integer :: debug_level, debug_unit
!!$
!!$
!!$ name='psb_spcnv'
!!$ info = 0
!!$ call psb_erractionsave(err_act)
!!$ debug_unit = psb_get_debug_unit()
!!$ debug_level = psb_get_debug_level()
!!$
!!$
!!$ !
!!$ ! dupl_ and upd_ fields should not be changed.
!!$ !
!!$ select case(psb_sp_getifld(psb_upd_,a,info))
!!$
!!$ case(psb_upd_perm_)
!!$
!!$ allocate(work(size(a%aspk)+1000),stat=info)
!!$ if (info /= 0) then
!!$ info=2040
!!$ call psb_errpush(info,name)
!!$ goto 9999
!!$ end if
!!$
!!$ if (debug_level >= psb_debug_serial_)&
!!$ & write(debug_unit,*) trim(name),'Regeneration with psb_upd_perm_'
!!$ ip1 = psb_sp_getifld(psb_upd_pnt_,a,info)
!!$ ip2 = a%ia2(ip1+psb_ip2_)
!!$ nnz = a%ia2(ip1+psb_nnz_)
!!$ iflag = a%ia2(ip1+psb_iflag_)
!!$ ichk = a%ia2(ip1+psb_ichk_)
!!$ nnzt = a%ia2(ip1+psb_nnzt_)
!!$ if (debug_level >= psb_debug_serial_)&
!!$ & write(debug_unit,*) trim(name),'Regeneration start: ',&
!!$ & a%infoa(psb_upd_),psb_upd_perm_,nnz,nnzt ,iflag,info
!!$
!!$ if ((ichk/=nnzt+iflag).or.(nnz/=nnzt)) then
!!$ info = 8889
!!$ write(debug_unit,*) trim(name),'Regeneration start error: ',&
!!$ & a%infoa(psb_upd_),psb_upd_perm_,nnz,nnzt ,iflag,ichk
!!$ call psb_errpush(info,name)
!!$ goto 9999
!!$ endif
!!$ do i= 1, nnz
!!$ work(i) = dzero
!!$ enddo
!!$ select case(iflag)
!!$ case(psb_dupl_ovwrt_,psb_dupl_err_)
!!$ do i=1, nnz
!!$ work(a%ia2(ip2+i-1)) = a%aspk(i)
!!$ enddo
!!$ case(psb_dupl_add_)
!!$ do i=1, nnz
!!$ work(a%ia2(ip2+i-1)) = a%aspk(i) + work(a%ia2(ip2+i-1))
!!$ enddo
!!$ case default
!!$ info = 8887
!!$ call psb_errpush(info,name)
!!$ goto 9999
!!$ end select
!!$
!!$ do i=1, nnz
!!$ a%aspk(i) = work(i)
!!$ enddo
!!$
!!$
!!$ case(psb_upd_srch_)
!!$ ! Nothing to be done here.
!!$ if (debug_level >= psb_debug_serial_) &
!!$ & write(debug_unit,*) trim(name),&
!!$ & 'Going through on regeneration with psb_upd_srch_'
!!$ case default
!!$ ! Wrong value
!!$ info = 8888
!!$ call psb_errpush(info,name)
!!$ goto 9999
!!$
!!$ end select
!!$
!!$ 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 coo_ssp_regen
!!$
!!$ subroutine jad_ssp_regen(a,info)
!!$
!!$ use psb_spmat_type
!!$ use psb_const_mod
!!$ use psb_error_mod
!!$ implicit none
!!$
!!$ type(psb_sspmat_type), intent(inout) :: a
!!$ integer :: info
!!$
!!$ integer :: i, ip1,ip2,nnz,iflag,ichk,nnzt
!!$ real(psb_spk_), allocatable :: work(:)
!!$ integer :: err_act
!!$ character(len=20) :: name
!!$ integer :: debug_level, debug_unit
!!$
!!$ name='psb_spcnv'
!!$ info = 0
!!$ call psb_erractionsave(err_act)
!!$ debug_unit = psb_get_debug_unit()
!!$ debug_level = psb_get_debug_level()
!!$
!!$
!!$ !
!!$ ! dupl_ and upd_ fields should not be changed.
!!$ !
!!$ select case(psb_sp_getifld(psb_upd_,a,info))
!!$
!!$ case(psb_upd_perm_)
!!$
!!$ allocate(work(size(a%aspk)+1000),stat=info)
!!$ if (info /= 0) then
!!$ info=2040
!!$ call psb_errpush(info,name)
!!$ goto 9999
!!$ end if
!!$
!!$ if (debug_level >= psb_debug_serial_)&
!!$ & write(debug_unit,*) trim(name),'Regeneration with psb_upd_perm_'
!!$ ip1 = psb_sp_getifld(psb_upd_pnt_,a,info)
!!$ ip2 = a%ia1(ip1+psb_ip2_)
!!$ nnz = a%ia1(ip1+psb_nnz_)
!!$ iflag = a%ia1(ip1+psb_iflag_)
!!$ ichk = a%ia1(ip1+psb_ichk_)
!!$ nnzt = a%ia1(ip1+psb_nnzt_)
!!$ if (debug_level >= psb_debug_serial_)&
!!$ & write(debug_unit,*) trim(name),'Regeneration start: ',&
!!$ & a%infoa(psb_upd_),psb_upd_perm_,nnz,nnzt ,iflag,info
!!$
!!$ if ((ichk/=nnzt+iflag).or.(nnz/=nnzt)) then
!!$ info = 8889
!!$ write(debug_unit,*) trim(name),'Regeneration start error: ',&
!!$ & a%infoa(psb_upd_),psb_upd_perm_,nnz,nnzt ,iflag,ichk
!!$ call psb_errpush(info,name)
!!$ goto 9999
!!$ endif
!!$ do i= 1, nnz
!!$ work(i) = dzero
!!$ enddo
!!$ select case(iflag)
!!$ case(psb_dupl_ovwrt_,psb_dupl_err_)
!!$ do i=1, nnz
!!$ work(a%ia1(ip2+i-1)) = a%aspk(i)
!!$ enddo
!!$ case(psb_dupl_add_)
!!$ do i=1, nnz
!!$ work(a%ia1(ip2+i-1)) = a%aspk(i) + work(a%ia1(ip2+i-1))
!!$ enddo
!!$ case default
!!$ info = 8887
!!$ call psb_errpush(info,name)
!!$ goto 9999
!!$ end select
!!$
!!$ do i=1, nnz
!!$ a%aspk(i) = work(i)
!!$ enddo
!!$
!!$
!!$ case(psb_upd_srch_)
!!$ ! Nothing to be done here.
!!$ if (debug_level >= psb_debug_serial_)&
!!$ & write(debug_unit,*) trim(name),&
!!$ & 'Going through on regeneration with psb_upd_srch_'
!!$ case default
!!$ ! Wrong value
!!$ info = 8888
!!$ call psb_errpush(info,name)
!!$ goto 9999
!!$
!!$ end select
!!$
!!$ 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 jad_ssp_regen
!!$
!!$ subroutine csr_dsp_regen(a,info)
!!$
!!$ use psb_spmat_type

1404
base/serial/psb_update_mod.f90
View File

File diff suppressed because it is too large Load Diff

4
base/tools/psb_dcdbldext.F90
Unescape Escape View File

@ -78,8 +78,8 @@ Subroutine psb_dcdbldext(a,desc_a,novr,desc_ov,info, extype)
#endif
! .. Array Arguments ..
integer, intent(in) :: novr
Type(psb_d_sparse_mat), Intent(in) :: a
integer, intent(in) :: novr
Type(psb_d_sparse_mat), Intent(in) :: a
Type(psb_desc_type), Intent(in), target :: desc_a
Type(psb_desc_type), Intent(out) :: desc_ov
integer, intent(out) :: info

2
base/tools/psb_dspalloc.f90
Unescape Escape View File

@ -47,7 +47,7 @@ subroutine psb_dspalloc(a, desc_a, info, nnz)
use psb_const_mod
use psb_error_mod
use psb_penv_mod
use psb_d_mat_mod
use psb_mat_mod
implicit none
!....parameters...

2
base/tools/psb_dspasb.f90
Unescape Escape View File

@ -55,7 +55,7 @@ subroutine psb_dspasb(a,desc_a, info, afmt, upd, dupl, mold)
use psb_error_mod
use psb_string_mod
use psb_penv_mod
use psb_d_mat_mod
use psb_mat_mod
implicit none

6
base/tools/psb_dspfree.f90
Unescape Escape View File

@ -44,13 +44,13 @@ subroutine psb_dspfree(a, desc_a,info)
use psb_descriptor_type
use psb_const_mod
use psb_error_mod
use psb_d_mat_mod
use psb_mat_mod
implicit none
!....parameters...
type(psb_desc_type), intent(in) :: desc_a
type(psb_desc_type), intent(in) :: desc_a
type(psb_d_sparse_mat), intent(inout) :: a
integer, intent(out) :: info
integer, intent(out) :: info
!...locals....
integer :: ictxt,err_act
character(len=20) :: name

4
base/tools/psb_dspins.f90
Unescape Escape View File

@ -55,7 +55,7 @@ subroutine psb_dspins(nz,ia,ja,val,a,desc_a,info,rebuild)
use psb_const_mod
use psb_error_mod
use psb_penv_mod
use psb_d_mat_mod
use psb_mat_mod
implicit none
!....parameters...
@ -242,7 +242,7 @@ subroutine psb_dspins_2desc(nz,ia,ja,val,a,desc_ar,desc_ac,info)
use psb_const_mod
use psb_error_mod
use psb_penv_mod
use psb_d_mat_mod
use psb_mat_mod
implicit none
!....parameters...

14
base/tools/psb_linmap.f90
Unescape Escape View File

@ -193,11 +193,11 @@ function psb_s_linmap(map_kind,desc_X, desc_Y, map_X2Y, map_Y2X,iaggr,naggr) res
use psb_base_mod, psb_protect_name => psb_s_linmap
implicit none
type(psb_slinmap_type) :: this
type(psb_desc_type), target :: desc_X, desc_Y
type(psb_sspmat_type), intent(in) :: map_X2Y, map_Y2X
integer, intent(in) :: map_kind
integer, intent(in), optional :: iaggr(:), naggr(:)
type(psb_slinmap_type) :: this
type(psb_desc_type), target :: desc_X, desc_Y
type(psb_s_sparse_mat), intent(in) :: map_X2Y, map_Y2X
integer, intent(in) :: map_kind
integer, intent(in), optional :: iaggr(:), naggr(:)
!
integer :: info
character(len=20), parameter :: name='psb_linmap'
@ -254,8 +254,8 @@ function psb_s_linmap(map_kind,desc_X, desc_Y, map_X2Y, map_Y2X,iaggr,naggr) res
end select
if (info == 0) call psb_sp_clone(map_X2Y,this%map_X2Y,info)
if (info == 0) call psb_sp_clone(map_Y2X,this%map_Y2X,info)
if (info == 0) call psb_clone(map_X2Y,this%map_X2Y,info)
if (info == 0) call psb_clone(map_Y2X,this%map_Y2X,info)
if (info == 0) call psb_realloc(psb_itd_data_size_,this%itd_data,info)
if (info == 0) then
call psb_set_map_kind(map_kind, this)

67
base/tools/psb_scdbldext.F90
Unescape Escape View File

@ -67,6 +67,7 @@ Subroutine psb_scdbldext(a,desc_a,novr,desc_ov,info, extype)
use psb_error_mod
use psb_penv_mod
use psb_realloc_mod
use psb_mat_mod
use psi_mod
#ifdef MPI_MOD
use mpi
@ -77,15 +78,15 @@ Subroutine psb_scdbldext(a,desc_a,novr,desc_ov,info, extype)
#endif
! .. Array Arguments ..
integer, intent(in) :: novr
Type(psb_sspmat_type), Intent(in) :: a
integer, intent(in) :: novr
Type(psb_s_sparse_mat), Intent(in) :: a
Type(psb_desc_type), Intent(in), target :: desc_a
Type(psb_desc_type), Intent(out) :: desc_ov
integer, intent(out) :: info
integer, intent(in),optional :: extype
! .. Local Scalars ..
Integer :: i, j, np, me,m,nnzero,&
Integer :: i, j, np, me,m,&
& ictxt, lovr, lworks,lworkr, n_row,n_col, int_err(5),&
& index_dim,elem_dim, l_tmp_ovr_idx,l_tmp_halo, nztot,nhalo
Integer :: counter,counter_h, counter_o, counter_e,idx,gidx,proc,n_elem_recv,&
@ -94,7 +95,7 @@ Subroutine psb_scdbldext(a,desc_a,novr,desc_ov,info, extype)
& idxr, idxs, iszr, iszs, nxch, nsnd, nrcv,lidx, extype_
integer :: icomm, err_act
type(psb_sspmat_type) :: blk
integer, allocatable :: irow(:), icol(:)
Integer, allocatable :: tmp_halo(:),tmp_ovr_idx(:), orig_ovr(:)
Integer,allocatable :: halo(:),works(:),workr(:),t_halo_in(:),&
& t_halo_out(:),temp(:),maskr(:)
@ -122,7 +123,6 @@ Subroutine psb_scdbldext(a,desc_a,novr,desc_ov,info, extype)
extype_ = psb_ovt_xhal_
endif
m = psb_cd_get_local_rows(desc_a)
nnzero = Size(a%aspk)
n_row = psb_cd_get_local_rows(desc_a)
n_col = psb_cd_get_local_cols(desc_a)
nhalo = n_col-m
@ -169,7 +169,7 @@ Subroutine psb_scdbldext(a,desc_a,novr,desc_ov,info, extype)
! LOVR= (NNZ/NROW)*N_HALO*NOVR This assumes that the local average
! nonzeros per row is the same as the global.
!
nztot = psb_sp_get_nnzeros(a)
nztot = a%get_nzeros()
if (nztot>0) then
lovr = ((nztot+m-1)/m)*nhalo*novr
lworks = ((nztot+m-1)/m)*nhalo
@ -210,16 +210,6 @@ Subroutine psb_scdbldext(a,desc_a,novr,desc_ov,info, extype)
goto 9999
end if
call psb_sp_all(blk,max(lworks,lworkr),info)
if (info /= 0) then
info=4010
ch_err='psb_sp_all'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
blk%fida='COO'
Allocate(orig_ovr(l_tmp_ovr_idx),tmp_ovr_idx(l_tmp_ovr_idx),&
& tmp_halo(l_tmp_halo), halo(size(desc_a%halo_index)),stat=info)
if (info /= 0) then
@ -414,35 +404,20 @@ Subroutine psb_scdbldext(a,desc_a,novr,desc_ov,info, extype)
! Prepare to exchange the halo rows with the other proc.
!
If (i_ovr <= (novr)) Then
n_elem = psb_sp_get_nnz_row(idx,a)
call psb_ensure_size((idxs+tot_elem+n_elem),works,info)
call a%csget(idx,idx,n_elem,irow,icol,info)
if (info /= 0) then
info=4010
call psb_errpush(info,name,a_err='psb_ensure_size')
call psb_errpush(info,name,a_err='csget')
goto 9999
end if
If((n_elem) > size(blk%ia2)) Then
isz = max((3*size(blk%ia2))/2,(n_elem))
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,'Realloc blk',isz
call psb_sp_reall(blk,isz,info)
if (info /= 0) then
info=4010
ch_err='psb_sp_reall'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
End If
call psb_sp_getblk(idx,a,blk,info)
call psb_ensure_size((idxs+tot_elem+n_elem),works,info)
if (info /= 0) then
info=4010
ch_err='psb_sp_getblk'
call psb_errpush(info,name,a_err=ch_err)
call psb_errpush(info,name,a_err='psb_ensure_size')
goto 9999
end if
call psb_map_l2g(blk%ia2(1:n_elem),&
call psb_map_l2g(icol(1:n_elem),&
& works(idxs+tot_elem+1:idxs+tot_elem+n_elem),&
& desc_ov%idxmap,info)
tot_elem=tot_elem+n_elem
@ -734,15 +709,21 @@ Subroutine psb_scdbldext(a,desc_a,novr,desc_ov,info, extype)
end if
call psb_icdasb(desc_ov,info,ext_hv=.true.)
call psb_cd_set_ovl_asb(desc_ov,info)
if (info == 0) call psb_sp_free(blk,info)
if (info /= 0) then
ch_err='sp_free'
call psb_errpush(4013,name,a_err=ch_err,i_err=(/info,0,0,0,0/))
call psb_errpush(4010,name,a_err='icdasdb')
goto 9999
end if
call psb_cd_set_ovl_asb(desc_ov,info)
if (info == 0) then
if (allocated(irow)) deallocate(irow,stat=info)
if ((info ==0).and.allocated(icol)) deallocate(icol,stat=info)
if (info /= 0) then
call psb_errpush(4013,name,a_err='deallocate',i_err=(/info,0,0,0,0/))
goto 9999
end if
end if
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),': end'

7
base/tools/psb_sspalloc.f90
Unescape Escape View File

@ -44,16 +44,15 @@
subroutine psb_sspalloc(a, desc_a, info, nnz)
use psb_descriptor_type
use psb_spmat_type
use psb_serial_mod
use psb_const_mod
use psb_error_mod
use psb_penv_mod
use psb_mat_mod
implicit none
!....parameters...
type(psb_desc_type), intent(inout) :: desc_a
type(psb_sspmat_type), intent(out) :: a
type(psb_s_sparse_mat), intent(out) :: a
integer, intent(out) :: info
integer, optional, intent(in) :: nnz
@ -108,7 +107,7 @@ subroutine psb_sspalloc(a, desc_a, info, nnz)
& write(debug_unit,*) me,' ',trim(name),':allocating size:',length_ia1
!....allocate aspk, ia1, ia2.....
call psb_sp_all(loc_row,loc_col,a,length_ia1,info)
call a%csall(loc_row,loc_col,info,nz=length_ia1)
if(info /= 0) then
info=4010
ch_err='sp_all'

28
base/tools/psb_sspasb.f90
Unescape Escape View File

@ -48,24 +48,24 @@
! psb_dupl_err_ raise an error.
!
!
subroutine psb_sspasb(a,desc_a, info, afmt, upd, dupl)
subroutine psb_sspasb(a,desc_a, info, afmt, upd, dupl, mold)
use psb_descriptor_type
use psb_spmat_type
use psb_serial_mod
use psb_const_mod
use psi_mod
use psb_error_mod
use psb_string_mod
use psb_penv_mod
use psb_mat_mod
implicit none
!...Parameters....
type(psb_sspmat_type), intent (inout) :: a
type(psb_s_sparse_mat), intent (inout) :: a
type(psb_desc_type), intent(in) :: desc_a
integer, intent(out) :: info
integer,optional, intent(in) :: dupl, upd
character(len=*), optional, intent(in) :: afmt
class(psb_s_base_sparse_mat), intent(in), optional :: mold
!....Locals....
integer :: int_err(5)
integer :: np,me,n_col, err_act
@ -106,23 +106,27 @@ subroutine psb_sspasb(a,desc_a, info, afmt, upd, dupl)
!check on errors encountered in psdspins
spstate = a%infoa(psb_state_)
if (spstate == psb_spmat_bld_) then
if (a%is_bld()) then
!
! First case: we come from a fresh build.
!
n_row = psb_cd_get_local_rows(desc_a)
n_col = psb_cd_get_local_cols(desc_a)
a%m = n_row
a%k = n_col
call a%set_nrows(n_row)
call a%set_ncols(n_col)
end if
call psb_spcnv(a,info,afmt=afmt,upd=upd,dupl=dupl)
call a%cscnv(info,type=afmt,dupl=dupl, mold=mold)
IF (debug_level >= psb_debug_ext_)&
& write(debug_unit, *) me,' ',trim(name),': From SPCNV',&
& info,' ',A%FIDA
IF (debug_level >= psb_debug_ext_) then
ch_err=a%get_fmt()
write(debug_unit, *) me,' ',trim(name),': From SPCNV',&
& info,' ',ch_err
end IF
if (info /= psb_no_err_) then
info=4010
ch_err='psb_spcnv'

18
base/tools/psb_sspfree.f90
Unescape Escape View File

@ -42,16 +42,15 @@
subroutine psb_sspfree(a, desc_a,info)
!...free sparse matrix structure...
use psb_descriptor_type
use psb_spmat_type
use psb_serial_mod
use psb_const_mod
use psb_error_mod
use psb_mat_mod
implicit none
!....parameters...
type(psb_desc_type), intent(in) :: desc_a
type(psb_sspmat_type), intent(inout) :: a
integer, intent(out) :: info
type(psb_desc_type), intent(in) :: desc_a
type(psb_s_sparse_mat), intent(inout) :: a
integer, intent(out) :: info
!...locals....
integer :: ictxt,err_act
character(len=20) :: name
@ -70,14 +69,7 @@ subroutine psb_sspfree(a, desc_a,info)
end if
!...deallocate a....
call psb_sp_free(a,info)
if(info /= 0) then
info=2045
call psb_errpush(info,name)
goto 9999
end if
call a%free()
call psb_erractionrestore(err_act)
return

85
base/tools/psb_ssphalo.F90
Unescape Escape View File

@ -60,7 +60,8 @@ Subroutine psb_ssphalo(a,desc_a,blk,info,rowcnv,colcnv,&
& rowscale,colscale,outfmt,data)
use psb_const_mod
use psb_serial_mod
use psb_string_mod
use psb_mat_mod
use psb_descriptor_type
use psb_realloc_mod
use psb_tools_mod, psb_protect_name => psb_ssphalo
@ -74,8 +75,8 @@ Subroutine psb_ssphalo(a,desc_a,blk,info,rowcnv,colcnv,&
include 'mpif.h'
#endif
Type(psb_sspmat_type),Intent(in) :: a
Type(psb_sspmat_type),Intent(inout) :: blk
Type(psb_s_sparse_mat),Intent(in) :: a
Type(psb_s_sparse_mat),Intent(inout) :: blk
Type(psb_desc_type),Intent(in), target :: desc_a
integer, intent(out) :: info
logical, optional, intent(in) :: rowcnv,colcnv,rowscale,colscale
@ -90,6 +91,7 @@ Subroutine psb_ssphalo(a,desc_a,blk,info,rowcnv,colcnv,&
Integer, allocatable :: sdid(:,:), brvindx(:),rvid(:,:), &
& rvsz(:), bsdindx(:),sdsz(:), iasnd(:), jasnd(:)
real(psb_spk_), allocatable :: valsnd(:)
type(psb_s_coo_sparse_mat), allocatable :: acoo
integer, pointer :: idxv(:)
logical :: rowcnv_,colcnv_,rowscale_,colscale_
character(len=5) :: outfmt_
@ -144,7 +146,7 @@ Subroutine psb_ssphalo(a,desc_a,blk,info,rowcnv,colcnv,&
Call psb_info(ictxt, me, np)
Allocate(sdid(np,3),rvid(np,3),brvindx(np+1),&
& rvsz(np),sdsz(np),bsdindx(np+1),stat=info)
& rvsz(np),sdsz(np),bsdindx(np+1), acoo,stat=info)
if (info /= 0) then
info=4000
@ -181,8 +183,7 @@ Subroutine psb_ssphalo(a,desc_a,blk,info,rowcnv,colcnv,&
idx = 0
idxs = 0
idxr = 0
blk%k = a%k
blk%m = 0
call acoo%allocate(0,a%get_ncols(),info)
! For all rows in the halo descriptor, extract and send/receive.
Do
proc=idxv(counter)
@ -193,13 +194,11 @@ Subroutine psb_ssphalo(a,desc_a,blk,info,rowcnv,colcnv,&
tot_elem = 0
Do j=0,n_el_send-1
idx = idxv(counter+psb_elem_send_+j)
n_elem = psb_sp_get_nnz_row(idx,a)
n_elem = a%get_nz_row(idx)
tot_elem = tot_elem+n_elem
Enddo
sdsz(proc+1) = tot_elem
blk%m = blk%m + n_el_recv
call acoo%set_nrows(acoo%get_nrows() + n_el_recv)
counter = counter+n_el_send+3
Enddo
@ -229,9 +228,9 @@ Subroutine psb_ssphalo(a,desc_a,blk,info,rowcnv,colcnv,&
Enddo
iszr=sum(rvsz)
call psb_sp_all(blk,max(iszr,1),info)
call acoo%reallocate(max(iszr,1))
if (debug_level >= psb_debug_outer_)&
& write(debug_unit,*) me,' ',trim(name),': Sizes:',size(blk%ia1),size(blk%ia2),&
& write(debug_unit,*) me,' ',trim(name),': Sizes:',acoo%get_size(),&
& ' Send:',sdsz(:),' Receive:',rvsz(:)
if (info /= 0) then
info=4010
@ -260,9 +259,8 @@ Subroutine psb_ssphalo(a,desc_a,blk,info,rowcnv,colcnv,&
Do j=0,n_el_send-1
idx = idxv(counter+psb_elem_send_+j)
n_elem = psb_sp_get_nnz_row(idx,a)
call psb_sp_getrow(idx,a,ngtz,iasnd,jasnd,valsnd,info,&
n_elem = a%get_nz_row(idx)
call a%csget(idx,idx,ngtz,iasnd,jasnd,valsnd,info,&
& append=.true.,nzin=tot_elem)
if (info /= 0) then
info=4010
@ -272,9 +270,7 @@ Subroutine psb_ssphalo(a,desc_a,blk,info,rowcnv,colcnv,&
end if
tot_elem=tot_elem+n_elem
Enddo
ipx = ipx + 1
counter = counter+n_el_send+3
Enddo
nz = tot_elem
@ -290,11 +286,11 @@ Subroutine psb_ssphalo(a,desc_a,blk,info,rowcnv,colcnv,&
call mpi_alltoallv(valsnd,sdsz,bsdindx,mpi_real,&
& blk%aspk,rvsz,brvindx,mpi_real,icomm,info)
& acoo%val,rvsz,brvindx,mpi_real,icomm,info)
call mpi_alltoallv(iasnd,sdsz,bsdindx,mpi_integer,&
& blk%ia1,rvsz,brvindx,mpi_integer,icomm,info)
& acoo%ia,rvsz,brvindx,mpi_integer,icomm,info)
call mpi_alltoallv(jasnd,sdsz,bsdindx,mpi_integer,&
& blk%ia2,rvsz,brvindx,mpi_integer,icomm,info)
& acoo%ja,rvsz,brvindx,mpi_integer,icomm,info)
if (info /= 0) then
info=4010
ch_err='mpi_alltoallv'
@ -305,8 +301,8 @@ Subroutine psb_ssphalo(a,desc_a,blk,info,rowcnv,colcnv,&
!
! Convert into local numbering
!
if (rowcnv_) call psb_glob_to_loc(blk%ia1(1:iszr),desc_a,info,iact='I')
if (colcnv_) call psb_glob_to_loc(blk%ia2(1:iszr),desc_a,info,iact='I')
if (rowcnv_) call psb_glob_to_loc(acoo%ia(1:iszr),desc_a,info,iact='I')
if (colcnv_) call psb_glob_to_loc(acoo%ja(1:iszr),desc_a,info,iact='I')
if (info /= 0) then
info=4010
@ -316,21 +312,21 @@ Subroutine psb_ssphalo(a,desc_a,blk,info,rowcnv,colcnv,&
end if
l1 = 0
blk%m=0
call acoo%set_nrows(0)
!
irmin = huge(irmin)
icmin = huge(icmin)
irmax = 0
icmax = 0
Do i=1,iszr
r=(blk%ia1(i))
k=(blk%ia2(i))
r=(acoo%ia(i))
k=(acoo%ja(i))
! Just in case some of the conversions were out-of-range
If ((r>0).and.(k>0)) Then
l1=l1+1
blk%aspk(l1) = blk%aspk(i)
blk%ia1(l1) = r
blk%ia2(l1) = k
acoo%val(l1) = acoo%val(i)
acoo%ia(l1) = r
acoo%ja(l1) = k
irmin = min(irmin,r)
irmax = max(irmax,r)
icmin = min(icmin,k)
@ -338,37 +334,28 @@ Subroutine psb_ssphalo(a,desc_a,blk,info,rowcnv,colcnv,&
End If
Enddo
if (rowscale_) then
blk%m = max(irmax-irmin+1,0)
blk%ia1(1:l1) = blk%ia1(1:l1) - irmin + 1
else
blk%m = irmax
call acoo%set_nrows(max(irmax-irmin+1,0))
acoo%ia(1:l1) = acoo%ia(1:l1) - irmin + 1
else
call acoo%set_nrows(irmax)
end if
if (colscale_) then
blk%k = max(icmax-icmin+1,0)
blk%ia2(1:l1) = blk%ia2(1:l1) - icmin + 1
call acoo%set_ncols(max(icmax-icmin+1,0))
acoo%ja(1:l1) = acoo%ja(1:l1) - icmin + 1
else
blk%k = icmax
call acoo%set_ncols(icmax)
end if
call acoo%set_nzeros(l1)
blk%fida = 'COO'
blk%infoa(psb_nnz_) = l1
call psb_ensure_size(1,blk%pl,info)
if (info == 0) call psb_ensure_size(1,blk%pr,info)
if (info /= 0) then
info=4010
ch_err='psb_ensure_size'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
blk%pl = 0
blk%pr = 0
if (debug_level >= psb_debug_outer_)&
& write(debug_unit,*) me,' ',trim(name),&
& ': End data exchange',counter,l1,blk%m
& ': End data exchange',counter,l1
call move_alloc(acoo,blk%a)
! Do we expect any duplicates to appear????
call psb_spcnv(blk,info,afmt=outfmt_,dupl=psb_dupl_add_)
call blk%cscnv(info,type=outfmt_,dupl=psb_dupl_add_)
if (info /= 0) then
info=4010
ch_err='psb_spcnv'

29
base/tools/psb_sspins.f90
Unescape Escape View File

@ -52,16 +52,15 @@ subroutine psb_sspins(nz,ia,ja,val,a,desc_a,info,rebuild)
use psb_tools_mod, psb_protect_name => psb_sspins
use psb_descriptor_type
use psb_spmat_type
use psb_serial_mod
use psb_const_mod
use psb_error_mod
use psb_penv_mod
use psb_mat_mod
implicit none
!....parameters...
type(psb_desc_type), intent(inout) :: desc_a
type(psb_sspmat_type), intent(inout) :: a
type(psb_s_sparse_mat), intent(inout) :: a
integer, intent(in) :: nz,ia(:),ja(:)
real(psb_spk_), intent(in) :: val(:)
integer, intent(out) :: info
@ -120,7 +119,6 @@ subroutine psb_sspins(nz,ia,ja,val,a,desc_a,info,rebuild)
rebuild_ = .false.
endif
spstate = a%infoa(psb_state_)
if (psb_is_bld_desc(desc_a)) then
if (psb_is_large_desc(desc_a)) then
@ -139,8 +137,8 @@ subroutine psb_sspins(nz,ia,ja,val,a,desc_a,info,rebuild)
nrow = psb_cd_get_local_rows(desc_a)
ncol = psb_cd_get_local_cols(desc_a)
if (spstate == psb_spmat_bld_) then
call psb_coins(nz,ila,jla,val,a,1,nrow,1,ncol,info)
if (a%is_bld()) then
call a%csput(nz,ila,jla,val,1,nrow,1,ncol,info)
if (info /= 0) then
info=4010
ch_err='psb_coins'
@ -164,8 +162,8 @@ subroutine psb_sspins(nz,ia,ja,val,a,desc_a,info,rebuild)
nrow = psb_cd_get_local_rows(desc_a)
ncol = psb_cd_get_local_cols(desc_a)
if (spstate == psb_spmat_bld_) then
call psb_coins(nz,ia,ja,val,a,1,nrow,1,ncol,info,gtl=desc_a%idxmap%glob_to_loc)
if (a%is_bld()) then
call a%csput(nz,ia,ja,val,1,nrow,1,ncol,info,gtl=desc_a%idxmap%glob_to_loc)
if (info /= 0) then
info=4010
ch_err='psb_coins'
@ -198,8 +196,7 @@ subroutine psb_sspins(nz,ia,ja,val,a,desc_a,info,rebuild)
nrow = psb_cd_get_local_rows(desc_a)
ncol = psb_cd_get_local_cols(desc_a)
call psb_coins(nz,ila,jla,val,a,1,nrow,1,ncol,&
& info,rebuild=rebuild_)
call a%csput(nz,ila,jla,val,1,nrow,1,ncol,info)
if (info /= 0) then
info=4010
ch_err='psb_coins'
@ -210,8 +207,8 @@ subroutine psb_sspins(nz,ia,ja,val,a,desc_a,info,rebuild)
else
nrow = psb_cd_get_local_rows(desc_a)
ncol = psb_cd_get_local_cols(desc_a)
call psb_coins(nz,ia,ja,val,a,1,nrow,1,ncol,&
& info,gtl=desc_a%idxmap%glob_to_loc,rebuild=rebuild_)
call a%csput(nz,ia,ja,val,1,nrow,1,ncol,&
& info,gtl=desc_a%idxmap%glob_to_loc)
if (info /= 0) then
info=4010
ch_err='psb_coins'
@ -242,17 +239,16 @@ end subroutine psb_sspins
subroutine psb_sspins_2desc(nz,ia,ja,val,a,desc_ar,desc_ac,info)
use psb_tools_mod, psb_protect_name => psb_sspins_2desc
use psb_descriptor_type
use psb_spmat_type
use psb_serial_mod
use psb_const_mod
use psb_error_mod
use psb_penv_mod
use psb_mat_mod
implicit none
!....parameters...
type(psb_desc_type), intent(in) :: desc_ar
type(psb_desc_type), intent(inout) :: desc_ac
type(psb_sspmat_type), intent(inout) :: a
type(psb_s_sparse_mat), intent(inout) :: a
integer, intent(in) :: nz,ia(:),ja(:)
real(kind=psb_spk_), intent(in) :: val(:)
integer, intent(out) :: info
@ -308,7 +304,6 @@ subroutine psb_sspins_2desc(nz,ia,ja,val,a,desc_ar,desc_ac,info)
end if
if (nz==0) return
spstate = a%infoa(psb_state_)
if (psb_is_bld_desc(desc_ac)) then
allocate(ila(nz),jla(nz),stat=info)
@ -332,7 +327,7 @@ subroutine psb_sspins_2desc(nz,ia,ja,val,a,desc_ar,desc_ac,info)
nrow = psb_cd_get_local_rows(desc_ar)
ncol = psb_cd_get_local_cols(desc_ac)
call psb_coins(nz,ila,jla,val,a,1,nrow,1,ncol,info)
call a%csput(nz,ila,jla,val,1,nrow,1,ncol,info)
if (info /= 0) then
info=4010
ch_err='psb_coins'

11
base/tools/psb_ssprn.f90
Unescape Escape View File

@ -44,7 +44,7 @@
Subroutine psb_ssprn(a, desc_a,info,clear)
use psb_descriptor_type
use psb_spmat_type
use psb_mat_mod
use psb_serial_mod
use psb_const_mod
use psb_error_mod
@ -53,7 +53,7 @@ Subroutine psb_ssprn(a, desc_a,info,clear)
!....Parameters...
Type(psb_desc_type), intent(in) :: desc_a
Type(psb_sspmat_type), intent(inout) :: a
Type(psb_s_sparse_mat), intent(inout) :: a
integer, intent(out) :: info
logical, intent(in), optional :: clear
@ -87,13 +87,8 @@ Subroutine psb_ssprn(a, desc_a,info,clear)
call psb_errpush(info,name)
goto 9999
endif
if (present(clear)) then
clear_ = clear
else
clear_ = .true.
end if
call psb_sp_reinit(a,info,clear=clear_)
call a%reinit(clear=clear)
if (info /= 0) goto 9999
if (debug_level >= psb_debug_outer_) &

30
krylov/psb_krylov_mod.f90
Unescape Escape View File

@ -45,9 +45,9 @@ Module psb_krylov_mod
interface psb_cg
subroutine psb_scg(a,prec,b,x,eps,&
& desc_a,info,itmax,iter,err,itrace,istop,cond)
use psb_base_mod, only : psb_desc_type, psb_sspmat_type, psb_spk_
use psb_base_mod, only : psb_desc_type, psb_s_sparse_mat, psb_spk_
use psb_prec_mod, only : psb_sprec_type
type(psb_sspmat_type), intent(in) :: a
type(psb_s_sparse_mat), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_a
real(psb_spk_), intent(in) :: b(:)
real(psb_spk_), intent(inout) :: x(:)
@ -108,9 +108,9 @@ Module psb_krylov_mod
interface psb_bicg
subroutine psb_sbicg(a,prec,b,x,eps,&
& desc_a,info,itmax,iter,err,itrace,istop)
use psb_base_mod, only : psb_desc_type, psb_sspmat_type, psb_spk_
use psb_base_mod, only : psb_desc_type, psb_s_sparse_mat, psb_spk_
use psb_prec_mod, only : psb_sprec_type
type(psb_sspmat_type), intent(in) :: a
type(psb_s_sparse_mat), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_a
real(psb_spk_), intent(in) :: b(:)
real(psb_spk_), intent(inout) :: x(:)
@ -171,9 +171,9 @@ Module psb_krylov_mod
interface psb_bicgstab
subroutine psb_scgstab(a,prec,b,x,eps,&
& desc_a,info,itmax,iter,err,itrace,istop)
use psb_base_mod, only : psb_desc_type, psb_sspmat_type, psb_spk_
use psb_base_mod, only : psb_desc_type, psb_s_sparse_mat, psb_spk_
use psb_prec_mod, only : psb_sprec_type
type(psb_sspmat_type), intent(in) :: a
type(psb_s_sparse_mat), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_a
real(psb_spk_), intent(in) :: b(:)
real(psb_spk_), intent(inout) :: x(:)
@ -234,9 +234,9 @@ Module psb_krylov_mod
interface psb_bicgstabl
Subroutine psb_scgstabl(a,prec,b,x,eps,desc_a,info,&
&itmax,iter,err, itrace,irst,istop)
use psb_base_mod, only : psb_desc_type, psb_sspmat_type, psb_spk_
use psb_base_mod, only : psb_desc_type, psb_s_sparse_mat, psb_spk_
use psb_prec_mod, only : psb_sprec_type
Type(psb_sspmat_type), Intent(in) :: a
Type(psb_s_sparse_mat), Intent(in) :: a
Type(psb_desc_type), Intent(in) :: desc_a
type(psb_sprec_type), intent(in) :: prec
Real(psb_spk_), Intent(in) :: b(:)
@ -297,9 +297,9 @@ Module psb_krylov_mod
interface psb_rgmres
Subroutine psb_srgmres(a,prec,b,x,eps,desc_a,info,&
&itmax,iter,err,itrace,irst,istop)
use psb_base_mod, only : psb_desc_type, psb_sspmat_type, psb_spk_
use psb_base_mod, only : psb_desc_type, psb_s_sparse_mat, psb_spk_
use psb_prec_mod, only : psb_sprec_type
Type(psb_sspmat_type), Intent(in) :: a
Type(psb_s_sparse_mat), Intent(in) :: a
Type(psb_desc_type), Intent(in) :: desc_a
type(psb_sprec_type), intent(in) :: prec
Real(psb_spk_), Intent(in) :: b(:)
@ -360,9 +360,9 @@ Module psb_krylov_mod
interface psb_cgs
subroutine psb_scgs(a,prec,b,x,eps,desc_a,info,&
&itmax,iter,err,itrace,istop)
use psb_base_mod, only : psb_desc_type, psb_sspmat_type, psb_spk_
use psb_base_mod, only : psb_desc_type, psb_s_sparse_mat, psb_spk_
use psb_prec_mod, only : psb_sprec_type
type(psb_sspmat_type), intent(in) :: a
type(psb_s_sparse_mat), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_a
type(psb_sprec_type), intent(in) :: prec
real(psb_spk_), intent(in) :: b(:)
@ -462,7 +462,7 @@ contains
! BICGSTABL
! RGMRES
!
! a - type(psb_sspmat_type) Input: sparse matrix containing A.
! a - type(psb_s_sparse_mat) Input: sparse matrix containing A.
! prec - type(psb_sprec_type) Input: preconditioner
! b - real,dimension(:) Input: vector containing the
! right hand side B
@ -498,7 +498,7 @@ contains
use psb_prec_mod,only : psb_sprec_type, psb_dprec_type, psb_cprec_type, psb_zprec_type
character(len=*) :: method
Type(psb_sspmat_type), Intent(in) :: a
Type(psb_s_sparse_mat), Intent(in) :: a
Type(psb_desc_type), Intent(in) :: desc_a
type(psb_sprec_type), intent(in) :: prec
Real(psb_spk_), Intent(in) :: b(:)
@ -996,7 +996,7 @@ contains
implicit none
character(len=*), intent(in) :: methdname
integer, intent(in) :: stopc, trace,itmax
type(psb_sspmat_type), intent(in) :: a
type(psb_s_sparse_mat), intent(in) :: a
real(psb_spk_), intent(in) :: b(:), eps
type(psb_desc_type), intent(in) :: desc_a
type(psb_itconv_type) :: stopdat

4
krylov/psb_sbicg.f90
Unescape Escape View File

@ -62,7 +62,7 @@
!
! Arguments:
!
! a - type(psb_sspmat_type) Input: sparse matrix containing A.
! a - type(psb_s_sparse_mat) Input: sparse matrix containing A.
! prec - type(psb_sprec_type) Input: preconditioner
! b - real,dimension(:) Input: vector containing the
! right hand side B
@ -101,7 +101,7 @@ subroutine psb_sbicg(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop)
implicit none
!!$ parameters
type(psb_sspmat_type), intent(in) :: a
type(psb_s_sparse_mat), intent(in) :: a
type(psb_sprec_type), intent(in) :: prec
type(psb_desc_type), intent(in) :: desc_a
real(psb_spk_), intent(in) :: b(:)

4
krylov/psb_scg.F90
Unescape Escape View File

@ -63,7 +63,7 @@
!
! Arguments:
!
! a - type(psb_sspmat_type) Input: sparse matrix containing A.
! a - type(psb_s_sparse_mat) Input: sparse matrix containing A.
! prec - type(psb_sprec_type) Input: preconditioner
! b - real,dimension(:) Input: vector containing the
! right hand side B
@ -102,7 +102,7 @@ subroutine psb_scg(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop,cond)
implicit none
!!$ Parameters
Type(psb_sspmat_type), Intent(in) :: a
Type(psb_s_sparse_mat), Intent(in) :: a
Type(psb_sprec_type), Intent(in) :: prec
Type(psb_desc_type), Intent(in) :: desc_a
Real(psb_spk_), Intent(in) :: b(:)

4
krylov/psb_scgs.f90
Unescape Escape View File

@ -62,7 +62,7 @@
!
! Arguments:
!
! a - type(psb_sspmat_type) Input: sparse matrix containing A.
! a - type(psb_s_sparse_mat) Input: sparse matrix containing A.
! prec - type(psb_sprec_type) Input: preconditioner
! b - real,dimension(:) Input: vector containing the
! right hand side B
@ -101,7 +101,7 @@ Subroutine psb_scgs(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop)
implicit none
!!$ parameters
Type(psb_sspmat_type), Intent(in) :: a
Type(psb_s_sparse_mat), Intent(in) :: a
Type(psb_desc_type), Intent(in) :: desc_a
Type(psb_sprec_type), Intent(in) :: prec
Real(psb_spk_), Intent(in) :: b(:)

10
krylov/psb_scgstab.F90
Unescape Escape View File

@ -62,7 +62,7 @@
!
! Arguments:
!
! a - type(psb_sspmat_type) Input: sparse matrix containing A.
! a - type(psb_s_sparse_mat) Input: sparse matrix containing A.
! prec - type(psb_sprec_type) Input: preconditioner
! b - real,dimension(:) Input: vector containing the
! right hand side B
@ -100,7 +100,7 @@ Subroutine psb_scgstab(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop)
use psb_krylov_mod, psb_protect_name => psb_scgstab
Implicit None
!!$ parameters
Type(psb_sspmat_type), Intent(in) :: a
Type(psb_s_sparse_mat), Intent(in) :: a
Type(psb_sprec_type), Intent(in) :: prec
Type(psb_desc_type), Intent(in) :: desc_a
Real(psb_spk_), Intent(in) :: b(:)
@ -272,7 +272,7 @@ Subroutine psb_scgstab(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop)
rho_old = rho
rho = psb_gedot(q,r,desc_a,info)
if (rho==dzero) then
if (rho==szero) then
if (debug_level >= psb_debug_ext_) &
& write(debug_unit,*) me,' ',trim(name),&
& ' Iteration breakdown R',rho
@ -302,7 +302,7 @@ Subroutine psb_scgstab(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop)
#endif
sigma = psb_gedot(q,v,desc_a,info)
if (sigma==dzero) then
if (sigma==szero) then
if (debug_level >= psb_debug_ext_) &
& write(debug_unit,*) me,' ',trim(name),&
& ' Iteration breakdown S1', sigma
@ -339,7 +339,7 @@ Subroutine psb_scgstab(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop)
end if
sigma = psb_gedot(t,t,desc_a,info)
if (sigma==dzero) then
if (sigma==szero) then
if (debug_level >= psb_debug_ext_) &
& write(debug_unit,*) me,' ',trim(name),&
& ' Iteration breakdown S2', sigma

4
krylov/psb_scgstabl.f90
Unescape Escape View File

@ -69,7 +69,7 @@
!
! Arguments:
!
! a - type(psb_sspmat_type) Input: sparse matrix containing A.
! a - type(psb_s_sparse_mat) Input: sparse matrix containing A.
! prec - type(psb_sprec_type) Input: preconditioner
! b - real,dimension(:) Input: vector containing the
! right hand side B
@ -110,7 +110,7 @@ Subroutine psb_scgstabl(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,irst,is
implicit none
!!$ parameters
Type(psb_sspmat_type), Intent(in) :: a
Type(psb_s_sparse_mat), Intent(in) :: a
Type(psb_sprec_type), Intent(in) :: prec
Type(psb_desc_type), Intent(in) :: desc_a
Real(psb_spk_), Intent(in) :: b(:)

4
krylov/psb_srgmres.f90
Unescape Escape View File

@ -73,7 +73,7 @@
!
! Arguments:
!
! a - type(psb_sspmat_type) Input: sparse matrix containing A.
! a - type(psb_s_sparse_mat) Input: sparse matrix containing A.
! prec - type(psb_sprec_type) Input: preconditioner
! b - real,dimension(:) Input: vector containing the
! right hand side B
@ -113,7 +113,7 @@ subroutine psb_srgmres(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,irst,ist
implicit none
!!$ Parameters
Type(psb_sspmat_type), Intent(in) :: a
Type(psb_s_sparse_mat), Intent(in) :: a
Type(psb_sprec_type), Intent(in) :: prec
Type(psb_desc_type), Intent(in) :: desc_a
Real(psb_spk_), Intent(in) :: b(:)

8
prec/psb_dbjac_aply.f90
Unescape Escape View File

@ -108,18 +108,18 @@ subroutine psb_dbjac_aply(alpha,prec,x,beta,y,desc_data,trans,work,info)
case('N')
call psb_spsm(done,prec%av(psb_l_pr_),x,dzero,ww,desc_data,info,&
& trans=trans_,unit='L',diag=prec%d,choice=psb_none_,work=aux)
& trans=trans_,side='L',diag=prec%d,choice=psb_none_,work=aux)
if(info /=0) goto 9999
call psb_spsm(alpha,prec%av(psb_u_pr_),ww,beta,y,desc_data,info,&
& trans=trans_,unit='U',choice=psb_none_, work=aux)
& trans=trans_,side='U',choice=psb_none_, work=aux)
if(info /=0) goto 9999
case('T','C')
call psb_spsm(done,prec%av(psb_u_pr_),x,dzero,ww,desc_data,info,&
& trans=trans_,unit='L',diag=prec%d,choice=psb_none_, work=aux)
& trans=trans_,side='L',diag=prec%d,choice=psb_none_, work=aux)
if(info /=0) goto 9999
call psb_spsm(alpha,prec%av(psb_l_pr_),ww,beta,y,desc_data,info,&
& trans=trans_,unit='U',choice=psb_none_,work=aux)
& trans=trans_,side='U',choice=psb_none_,work=aux)
if(info /=0) goto 9999
end select

27
prec/psb_dbjac_bld.f90
Unescape Escape View File

@ -46,7 +46,6 @@ subroutine psb_dbjac_bld(a,desc_a,p,upd,info)
integer :: i, m
integer :: int_err(5)
character :: trans, unitd
!!$ type(psb_dspmat_type) :: atmp
type(psb_d_csr_sparse_mat), allocatable :: lf, uf
real(psb_dpk_) :: t1,t2,t3,t4,t5,t6, t7, t8
integer nztota, err_act, n_row, nrow_a,n_col, nhalo
@ -72,7 +71,6 @@ subroutine psb_dbjac_bld(a,desc_a,p,upd,info)
endif
trans = 'N'
unitd = 'U'
!!$ call psb_nullify_sp(atmp)
call psb_cdcpy(desc_a,p%desc_data,info)
if(info /= 0) then
@ -91,11 +89,6 @@ subroutine psb_dbjac_bld(a,desc_a,p,upd,info)
if (size(p%av) < psb_bp_ilu_avsz) then
do i=1,size(p%av)
call p%av(i)%free()
!!$ if (info /= 0) then
!!$ ! Actually, we don't care here about this.
!!$ ! Just let it go.
!!$ ! return
!!$ end if
enddo
deallocate(p%av,stat=info)
endif
@ -119,9 +112,6 @@ subroutine psb_dbjac_bld(a,desc_a,p,upd,info)
if (info == 0) call lf%allocate(n_row,n_row,nztota)
if (info == 0) call uf%allocate(n_row,n_row,nztota)
!!$ call p%av(psb_l_pr_)%csall(n_row,n_row,info,nztota)
!!$ if (info == 0) call p%av(psb_u_pr_)%csall(n_row,n_row,info,nztota)
if(info/=0) then
info=4010
ch_err='psb_sp_all'
@ -144,15 +134,11 @@ subroutine psb_dbjac_bld(a,desc_a,p,upd,info)
endif
t3 = psb_wtime()
! This is where we have no renumbering, thus no need
! for ATMP
!!$ call p%av(psb_l_pr_)%cscnv(info,type='CSR')
!!$ call p%av(psb_u_pr_)%cscnv(info,type='CSR')
call psb_ilu_fct(a,lf,uf,p%d,info)
if(info==0) then
call move_alloc(lf,p%av(psb_l_pr_)%a)
call move_alloc(uf,p%av(psb_u_pr_)%a)
call p%av(psb_l_pr_)%mv_from(lf)
call p%av(psb_u_pr_)%mv_from(uf)
call p%av(psb_l_pr_)%set_asb()
call p%av(psb_u_pr_)%set_asb()
call p%av(psb_l_pr_)%trim()
@ -163,15 +149,6 @@ subroutine psb_dbjac_bld(a,desc_a,p,upd,info)
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
!!$
!!$ if (psb_sp_getifld(psb_upd_,p%av(psb_u_pr_),info) /= psb_upd_perm_) then
!!$ call psb_sp_trim(p%av(psb_u_pr_),info)
!!$ endif
!!$
!!$ if (psb_sp_getifld(psb_upd_,p%av(psb_l_pr_),info) /= psb_upd_perm_) then
!!$ call psb_sp_trim(p%av(psb_l_pr_),info)
!!$ endif
case(psb_f_none_)
info=4010

13
prec/psb_ddiagsc_bld.f90
Unescape Escape View File

@ -105,19 +105,6 @@ subroutine psb_ddiagsc_bld(a,desc_a,p,upd,info)
endif
end do
!!$ if (a%pl(1) /= 0) then
!!$ !
!!$ ! Apply the same row permutation as in the sparse matrix A
!!$ !
!!$ call psb_gelp('n',a%pl,p%d,info)
!!$ if(info /= 0) then
!!$ info=4010
!!$ ch_err='psb_dgelp'
!!$ call psb_errpush(info,name,a_err=ch_err)
!!$ goto 9999
!!$ end if
!!$ endif
call psb_erractionrestore(err_act)
return

67
prec/psb_dilu_fct.f90
Unescape Escape View File

@ -49,7 +49,7 @@ subroutine psb_dilu_fct(a,l,u,d,info,blck)
integer :: l1,l2,m,err_act
type(psb_d_sparse_mat), pointer :: blck_
character(len=20) :: name, ch_err
name='psb_dcsrlu'
name='psb_ilu_fct'
info = 0
call psb_erractionsave(err_act)
! .. Executable Statements ..
@ -115,7 +115,7 @@ subroutine psb_dilu_fct(a,l,u,d,info,blck)
contains
subroutine psb_dilu_fctint(m,ma,a,mb,b,&
& d,laspk,lia1,lia2,uaspk,uia1,uia2,l1,l2,info)
use psb_d_base_mat_mod
use psb_mat_mod
implicit none
@ -129,9 +129,6 @@ contains
real(psb_dpk_) :: dia,temp
integer, parameter :: nrb=60
type(psb_d_coo_sparse_mat) :: trw
integer, allocatable :: irow(:), icol(:)
real(psb_dpk_), allocatable :: val(:)
integer :: int_err(5)
character(len=20) :: name, ch_err
@ -275,36 +272,36 @@ contains
do i = ma+1, m
d(i) = dzero
!!$ if ((mod(i,nrb) == 1).or.(nrb==1)) then
!!$ irb = min(ma-i+1,nrb)
!!$ call b%csget(i-ma,i-ma+irb-1,trw,info)
!!$ nz = trw%get_nzeros()
!!$ if(info /= 0) then
!!$ info=4010
!!$ ch_err='a%csget'
!!$ call psb_errpush(info,name,a_err=ch_err)
!!$ goto 9999
!!$ end if
!!$ ktrw=1
!!$ end if
!!$
!!$ do
!!$ if (ktrw > nz ) exit
!!$ if (trw%ia(ktrw) > i) exit
!!$ k = trw%ja(ktrw)
!!$ if ((k < i).and.(k >= 1)) then
!!$ l1 = l1 + 1
!!$ laspk(l1) = trw%val(ktrw)
!!$ lia1(l1) = k
!!$ else if (k == i) then
!!$ d(i) = trw%val(ktrw)
!!$ else if ((k > i).and.(k <= m)) then
!!$ l2 = l2 + 1
!!$ uaspk(l2) = trw%val(ktrw)
!!$ uia1(l2) = k
!!$ end if
!!$ ktrw = ktrw + 1
!!$ enddo
if ((mod(i,nrb) == 1).or.(nrb==1)) then
irb = min(ma-i+1,nrb)
call b%a%csget(i-ma,i-ma+irb-1,trw,info)
nz = trw%get_nzeros()
if(info /= 0) then
info=4010
ch_err='a%csget'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
ktrw=1
end if
do
if (ktrw > nz ) exit
if (trw%ia(ktrw) > i) exit
k = trw%ja(ktrw)
if ((k < i).and.(k >= 1)) then
l1 = l1 + 1
laspk(l1) = trw%val(ktrw)
lia1(l1) = k
else if (k == i) then
d(i) = trw%val(ktrw)
else if ((k > i).and.(k <= m)) then
l2 = l2 + 1
uaspk(l2) = trw%val(ktrw)
uia1(l2) = k
end if
ktrw = ktrw + 1
enddo
lia2(i+1) = l1 + 1

9
prec/psb_dprecbld.f90
Unescape Escape View File

@ -29,13 +29,13 @@
!!$ POSSIBILITY OF SUCH DAMAGE.
!!$
!!$
subroutine psb_dprecbld(aa,desc_a,p,info,upd)
subroutine psb_dprecbld(a,desc_a,p,info,upd)
use psb_base_mod
use psb_prec_mod, psb_protect_name => psb_dprecbld
Implicit None
type(psb_d_sparse_mat), intent(in), target :: aa
type(psb_d_sparse_mat), intent(in), target :: a
type(psb_desc_type), intent(in), target :: desc_a
type(psb_dprec_type),intent(inout) :: p
integer, intent(out) :: info
@ -86,7 +86,6 @@ subroutine psb_dprecbld(aa,desc_a,p,info,upd)
call psb_nullify_desc(p%desc_data)
select case(p%iprcparm(psb_p_type_))
case (psb_noprec_)
! Do nothing.
@ -100,7 +99,7 @@ subroutine psb_dprecbld(aa,desc_a,p,info,upd)
case (psb_diag_)
call psb_diagsc_bld(aa,desc_a,p,upd_,info)
call psb_diagsc_bld(a,desc_a,p,upd_,info)
if(info /= 0) then
info=4010
ch_err='psb_diagsc_bld'
@ -113,7 +112,7 @@ subroutine psb_dprecbld(aa,desc_a,p,info,upd)
call psb_check_def(p%iprcparm(psb_f_type_),'fact',&
& psb_f_ilu_n_,is_legal_ml_fact)
call psb_bjac_bld(aa,desc_a,p,upd_,info)
call psb_bjac_bld(a,desc_a,p,upd_,info)
if(info /= 0) then
call psb_errpush(4010,name,a_err='psb_bjac_bld')

35
prec/psb_prec_mod.f90
Unescape Escape View File

@ -35,10 +35,10 @@ module psb_prec_mod
interface psb_precbld
subroutine psb_sprecbld(a,desc_a,prec,info,upd)
use psb_base_mod, only : psb_desc_type, psb_sspmat_type, psb_spk_
use psb_base_mod, only : psb_desc_type, psb_s_sparse_mat, psb_spk_
use psb_prec_type, only : psb_sprec_type
implicit none
type(psb_sspmat_type), intent(in), target :: a
type(psb_s_sparse_mat), intent(in), target :: a
type(psb_desc_type), intent(in), target :: desc_a
type(psb_sprec_type), intent(inout) :: prec
integer, intent(out) :: info
@ -78,7 +78,7 @@ module psb_prec_mod
interface psb_precinit
subroutine psb_sprecinit(prec,ptype,info)
use psb_base_mod, only : psb_desc_type, psb_sspmat_type, psb_spk_
use psb_base_mod, only : psb_desc_type, psb_s_sparse_mat, psb_spk_
use psb_prec_type, only : psb_sprec_type
implicit none
type(psb_sprec_type), intent(inout) :: prec
@ -113,7 +113,7 @@ module psb_prec_mod
interface psb_precset
subroutine psb_sprecseti(prec,what,val,info)
use psb_base_mod, only : psb_desc_type, psb_sspmat_type, psb_spk_
use psb_base_mod, only : psb_desc_type, psb_s_sparse_mat, psb_spk_
use psb_prec_type, only : psb_sprec_type
implicit none
type(psb_sprec_type), intent(inout) :: prec
@ -121,7 +121,7 @@ module psb_prec_mod
integer, intent(out) :: info
end subroutine psb_sprecseti
subroutine psb_sprecsets(prec,what,val,info)
use psb_base_mod, only : psb_desc_type, psb_sspmat_type, psb_spk_
use psb_base_mod, only : psb_desc_type, psb_s_sparse_mat, psb_spk_
use psb_prec_type, only : psb_sprec_type
implicit none
type(psb_sprec_type), intent(inout) :: prec
@ -185,7 +185,7 @@ module psb_prec_mod
interface psb_precaply
subroutine psb_sprc_aply(prec,x,y,desc_data,info,trans,work)
use psb_base_mod, only : psb_desc_type, psb_sspmat_type, psb_spk_
use psb_base_mod, only : psb_desc_type, psb_s_sparse_mat, psb_spk_
use psb_prec_type, only : psb_sprec_type
type(psb_desc_type),intent(in) :: desc_data
type(psb_sprec_type), intent(in) :: prec
@ -196,7 +196,7 @@ module psb_prec_mod
real(psb_spk_),intent(inout), optional, target :: work(:)
end subroutine psb_sprc_aply
subroutine psb_sprc_aply1(prec,x,desc_data,info,trans)
use psb_base_mod, only : psb_desc_type, psb_sspmat_type, psb_spk_
use psb_base_mod, only : psb_desc_type, psb_s_sparse_mat, psb_spk_
use psb_prec_type, only : psb_sprec_type
type(psb_desc_type),intent(in) :: desc_data
type(psb_sprec_type), intent(in) :: prec
@ -269,7 +269,7 @@ module psb_prec_mod
interface psb_bjac_aply
subroutine psb_sbjac_aply(alpha,prec,x,beta,y,desc_data,trans,work,info)
use psb_base_mod, only : psb_desc_type, psb_sspmat_type, psb_spk_
use psb_base_mod, only : psb_desc_type, psb_s_sparse_mat, psb_spk_
use psb_prec_type, only : psb_sprec_type
type(psb_desc_type), intent(in) :: desc_data
type(psb_sprec_type), intent(in) :: prec
@ -320,11 +320,12 @@ module psb_prec_mod
interface psb_ilu_fct
subroutine psb_silu_fct(a,l,u,d,info,blck)
use psb_base_mod, only : psb_desc_type, psb_sspmat_type, psb_spk_
use psb_base_mod, only : psb_desc_type, psb_s_sparse_mat,&
& psb_s_csr_sparse_mat, psb_spk_
integer, intent(out) :: info
type(psb_sspmat_type),intent(in) :: a
type(psb_sspmat_type),intent(inout) :: l,u
type(psb_sspmat_type),intent(in), optional, target :: blck
type(psb_s_sparse_mat),intent(in) :: a
type(psb_s_csr_sparse_mat),intent(inout) :: l,u
type(psb_s_sparse_mat),intent(in), optional, target :: blck
real(psb_spk_), intent(inout) :: d(:)
end subroutine psb_silu_fct
subroutine psb_dilu_fct(a,l,u,d,info,blck)
@ -356,10 +357,10 @@ module psb_prec_mod
interface psb_bjac_bld
subroutine psb_sbjac_bld(a,desc_a,p,upd,info)
use psb_base_mod, only : psb_desc_type, psb_sspmat_type, psb_spk_
use psb_base_mod, only : psb_desc_type, psb_s_sparse_mat, psb_spk_
use psb_prec_type, only : psb_sprec_type
integer, intent(out) :: info
type(psb_sspmat_type), intent(in), target :: a
type(psb_s_sparse_mat), intent(in), target :: a
type(psb_sprec_type), intent(inout) :: p
type(psb_desc_type), intent(in) :: desc_a
character, intent(in) :: upd
@ -395,10 +396,10 @@ module psb_prec_mod
interface psb_diagsc_bld
subroutine psb_sdiagsc_bld(a,desc_a,p,upd,info)
use psb_base_mod, only : psb_desc_type, psb_sspmat_type, psb_spk_
use psb_base_mod, only : psb_desc_type, psb_s_sparse_mat, psb_spk_
use psb_prec_type, only : psb_sprec_type
integer, intent(out) :: info
type(psb_sspmat_type), intent(in), target :: a
type(psb_s_sparse_mat), intent(in), target :: a
type(psb_sprec_type), intent(inout) :: p
type(psb_desc_type), intent(in) :: desc_a
character, intent(in) :: upd
@ -435,7 +436,7 @@ module psb_prec_mod
interface psb_gprec_aply
subroutine psb_sgprec_aply(alpha,prec,x,beta,y,desc_data,trans,work,info)
use psb_base_mod, only : psb_desc_type, psb_sspmat_type, psb_spk_
use psb_base_mod, only : psb_desc_type, psb_s_sparse_mat, psb_spk_
use psb_prec_type, only : psb_sprec_type
type(psb_desc_type),intent(in) :: desc_data
type(psb_sprec_type), intent(in) :: prec

46
prec/psb_prec_type.f90
Unescape Escape View File

@ -37,11 +37,11 @@
module psb_prec_type
! Reduces size of .mod file.
use psb_base_mod, only : psb_sspmat_type, psb_cspmat_type,&
use psb_base_mod, only : psb_cspmat_type,&
& psb_zspmat_type, psb_dpk_, psb_spk_, psb_long_int_k_,&
& psb_desc_type, psb_sizeof, psb_sp_free, psb_cdfree,&
& psb_erractionsave, psb_erractionrestore, psb_error, psb_get_errstatus
use psb_d_mat_mod, only : psb_d_sparse_mat
use psb_mat_mod, only : psb_s_sparse_mat, psb_d_sparse_mat
integer, parameter :: psb_min_prec_=0, psb_noprec_=0, psb_diag_=1, &
& psb_bjac_=2, psb_max_prec_=2
@ -66,23 +66,23 @@ module psb_prec_type
type psb_sprec_type
type(psb_sspmat_type), allocatable :: av(:)
real(psb_spk_), allocatable :: d(:)
type(psb_desc_type) :: desc_data
integer, allocatable :: iprcparm(:)
real(psb_spk_), allocatable :: rprcparm(:)
integer, allocatable :: perm(:), invperm(:)
integer :: prec, base_prec
type(psb_s_sparse_mat), allocatable :: av(:)
real(psb_spk_), allocatable :: d(:)
type(psb_desc_type) :: desc_data
integer, allocatable :: iprcparm(:)
real(psb_spk_), allocatable :: rprcparm(:)
integer, allocatable :: perm(:), invperm(:)
integer :: prec, base_prec
end type psb_sprec_type
type psb_dprec_type
type(psb_d_sparse_mat), allocatable :: av(:)
real(psb_dpk_), allocatable :: d(:)
type(psb_desc_type) :: desc_data
integer, allocatable :: iprcparm(:)
real(psb_dpk_), allocatable :: rprcparm(:)
integer, allocatable :: perm(:), invperm(:)
integer :: prec, base_prec
real(psb_dpk_), allocatable :: d(:)
type(psb_desc_type) :: desc_data
integer, allocatable :: iprcparm(:)
real(psb_dpk_), allocatable :: rprcparm(:)
integer, allocatable :: perm(:), invperm(:)
integer :: prec, base_prec
end type psb_dprec_type
type psb_cprec_type
@ -331,12 +331,7 @@ contains
if (allocated(p%av)) then
do i=1,size(p%av)
call psb_sp_free(p%av(i),info)
if (info /= 0) then
! Actually, we don't care here about this.
! Just let it go.
! return
end if
call p%av(i)%free()
enddo
deallocate(p%av,stat=info)
end if
@ -403,13 +398,7 @@ contains
if (allocated(p%av)) then
do i=1,size(p%av)
!!$ call psb_sp_free(p%av(i),info)
call p%av(i)%free()
if (info /= 0) then
! Actually, we don't care here about this.
! Just let it go.
! return
end if
enddo
deallocate(p%av,stat=info)
end if
@ -602,7 +591,7 @@ contains
function psb_dprec_sizeof(prec) result(val)
use psb_d_mat_mod
use psb_mat_mod
type(psb_dprec_type), intent(in) :: prec
integer(psb_long_int_k_) :: val
integer :: i
@ -622,6 +611,7 @@ contains
end function psb_dprec_sizeof
function psb_sprec_sizeof(prec) result(val)
use psb_mat_mod
type(psb_sprec_type), intent(in) :: prec
integer(psb_long_int_k_) :: val
integer :: i

8
prec/psb_sbjac_aply.f90
Unescape Escape View File

@ -108,18 +108,18 @@ subroutine psb_sbjac_aply(alpha,prec,x,beta,y,desc_data,trans,work,info)
case('N')
call psb_spsm(sone,prec%av(psb_l_pr_),x,szero,ww,desc_data,info,&
& trans=trans_,unit='L',diag=prec%d,choice=psb_none_,work=aux)
& trans=trans_,side='L',diag=prec%d,choice=psb_none_,work=aux)
if(info /=0) goto 9999
call psb_spsm(alpha,prec%av(psb_u_pr_),ww,beta,y,desc_data,info,&
& trans=trans_,unit='U',choice=psb_none_, work=aux)
& trans=trans_,side='U',choice=psb_none_, work=aux)
if(info /=0) goto 9999
case('T','C')
call psb_spsm(sone,prec%av(psb_u_pr_),x,szero,ww,desc_data,info,&
& trans=trans_,unit='L',diag=prec%d,choice=psb_none_, work=aux)
& trans=trans_,side='L',diag=prec%d,choice=psb_none_, work=aux)
if(info /=0) goto 9999
call psb_spsm(alpha,prec%av(psb_l_pr_),ww,beta,y,desc_data,info,&
& trans=trans_,unit='U',choice=psb_none_,work=aux)
& trans=trans_,side='U',choice=psb_none_,work=aux)
if(info /=0) goto 9999
end select

54
prec/psb_sbjac_bld.f90
Unescape Escape View File

@ -37,7 +37,7 @@ subroutine psb_sbjac_bld(a,desc_a,p,upd,info)
! .. Scalar Arguments ..
integer, intent(out) :: info
! .. array Arguments ..
type(psb_sspmat_type), intent(in), target :: a
type(psb_s_sparse_mat), intent(in), target :: a
type(psb_sprec_type), intent(inout) :: p
type(psb_desc_type), intent(in) :: desc_a
character, intent(in) :: upd
@ -46,8 +46,8 @@ subroutine psb_sbjac_bld(a,desc_a,p,upd,info)
integer :: i, m
integer :: int_err(5)
character :: trans, unitd
type(psb_sspmat_type) :: atmp
real(psb_spk_) :: t1,t2,t3,t4,t5,t6, t7, t8
type(psb_s_csr_sparse_mat), allocatable :: lf, uf
real(psb_dpk_) :: t1,t2,t3,t4,t5,t6, t7, t8
integer nztota, err_act, n_row, nrow_a,n_col, nhalo
integer :: ictxt,np,me
character(len=20) :: name, ch_err
@ -61,7 +61,7 @@ subroutine psb_sbjac_bld(a,desc_a,p,upd,info)
ictxt=psb_cd_get_context(desc_a)
call psb_info(ictxt, me, np)
m = a%m
m = a%get_nrows()
if (m < 0) then
info = 10
int_err(1) = 1
@ -71,7 +71,6 @@ subroutine psb_sbjac_bld(a,desc_a,p,upd,info)
endif
trans = 'N'
unitd = 'U'
call psb_nullify_sp(atmp)
call psb_cdcpy(desc_a,p%desc_data,info)
if(info /= 0) then
@ -89,12 +88,7 @@ subroutine psb_sbjac_bld(a,desc_a,p,upd,info)
if (allocated(p%av)) then
if (size(p%av) < psb_bp_ilu_avsz) then
do i=1,size(p%av)
call psb_sp_free(p%av(i),info)
if (info /= 0) then
! Actually, we don't care here about this.
! Just let it go.
! return
end if
call p%av(i)%free()
enddo
deallocate(p%av,stat=info)
endif
@ -108,17 +102,16 @@ subroutine psb_sbjac_bld(a,desc_a,p,upd,info)
endif
nrow_a = psb_cd_get_local_rows(desc_a)
nztota = psb_sp_get_nnzeros(a)
nztota = a%get_nzeros()
n_col = psb_cd_get_local_cols(desc_a)
nhalo = n_col-nrow_a
n_row = p%desc_data%matrix_data(psb_n_row_)
p%av(psb_l_pr_)%m = n_row
p%av(psb_l_pr_)%k = n_row
p%av(psb_u_pr_)%m = n_row
p%av(psb_u_pr_)%k = n_row
call psb_sp_all(n_row,n_row,p%av(psb_l_pr_),nztota,info)
if (info == 0) call psb_sp_all(n_row,n_row,p%av(psb_u_pr_),nztota,info)
allocate(lf,uf,stat=info)
if (info == 0) call lf%allocate(n_row,n_row,nztota)
if (info == 0) call uf%allocate(n_row,n_row,nztota)
if(info/=0) then
info=4010
ch_err='psb_sp_all'
@ -140,26 +133,23 @@ subroutine psb_sbjac_bld(a,desc_a,p,upd,info)
endif
t3 = psb_wtime()
! This is where we have mo renumbering, thus no need
! for ATMP
call psb_ilu_fct(a,p%av(psb_l_pr_),p%av(psb_u_pr_),p%d,info)
if(info/=0) then
! This is where we have no renumbering, thus no need
call psb_ilu_fct(a,lf,uf,p%d,info)
if(info==0) then
call p%av(psb_l_pr_)%mv_from(lf)
call p%av(psb_u_pr_)%mv_from(uf)
call p%av(psb_l_pr_)%set_asb()
call p%av(psb_u_pr_)%set_asb()
call p%av(psb_l_pr_)%trim()
call p%av(psb_u_pr_)%trim()
else
info=4010
ch_err='psb_ilu_fct'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
if (psb_sp_getifld(psb_upd_,p%av(psb_u_pr_),info) /= psb_upd_perm_) then
call psb_sp_trim(p%av(psb_u_pr_),info)
endif
if (psb_sp_getifld(psb_upd_,p%av(psb_l_pr_),info) /= psb_upd_perm_) then
call psb_sp_trim(p%av(psb_l_pr_),info)
endif
case(psb_f_none_)
info=4010
ch_err='Inconsistent prec psb_f_none_'

23
prec/psb_sdiagsc_bld.f90
Unescape Escape View File

@ -35,7 +35,7 @@ subroutine psb_sdiagsc_bld(a,desc_a,p,upd,info)
use psb_prec_mod, psb_protect_name => psb_sdiagsc_bld
Implicit None
type(psb_sspmat_type), intent(in), target :: a
type(psb_s_sparse_mat), intent(in), target :: a
type(psb_desc_type), intent(in) :: desc_a
type(psb_sprec_type),intent(inout) :: p
character, intent(in) :: upd
@ -76,7 +76,7 @@ subroutine psb_sdiagsc_bld(a,desc_a,p,upd,info)
!
! Retrieve the diagonal entries of the matrix A
!
call psb_sp_getdiag(a,p%d,info)
call a%get_diag(p%d,info)
if(info /= 0) then
info=4010
ch_err='psb_sp_getdiag'
@ -98,26 +98,13 @@ subroutine psb_sdiagsc_bld(a,desc_a,p,upd,info)
! it is set to one/a_ii
!
do i=1,n_row
if (p%d(i) == dzero) then
p%d(i) = done
if (p%d(i) == szero) then
p%d(i) = sone
else
p%d(i) = done/p%d(i)
p%d(i) = sone/p%d(i)
endif
end do
if (a%pl(1) /= 0) then
!
! Apply the same row permutation as in the sparse matrix A
!
call psb_gelp('n',a%pl,p%d,info)
if(info /= 0) then
info=4010
ch_err='psb_gelp'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
endif
call psb_erractionrestore(err_act)
return

246
prec/psb_silu_fct.f90
Unescape Escape View File

@ -41,13 +41,13 @@ subroutine psb_silu_fct(a,l,u,d,info,blck)
! .. Scalar Arguments ..
integer, intent(out) :: info
! .. Array Arguments ..
type(psb_sspmat_type),intent(in) :: a
type(psb_sspmat_type),intent(inout) :: l,u
type(psb_sspmat_type),intent(in), optional, target :: blck
type(psb_s_sparse_mat),intent(in) :: a
type(psb_s_csr_sparse_mat),intent(inout) :: l,u
type(psb_s_sparse_mat),intent(in), optional, target :: blck
real(psb_spk_), intent(inout) :: d(:)
! .. Local Scalars ..
integer :: l1,l2,m,err_act
type(psb_sspmat_type), pointer :: blck_
type(psb_s_sparse_mat), pointer :: blck_
character(len=20) :: name, ch_err
name='psb_ilu_fct'
info = 0
@ -64,41 +64,34 @@ subroutine psb_silu_fct(a,l,u,d,info,blck)
goto 9999
end if
call psb_nullify_sp(blck_) ! Why do we need this? Who knows....
call psb_sp_all(0,0,blck_,1,info)
if(info /= 0) then
info=4010
ch_err='psb_sp_all'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
call blck_%csall(0,0,info,1)
blck_%m=0
endif
call psb_silu_fctint(m,a%m,a,blck_%m,blck_,&
& d,l%aspk,l%ia1,l%ia2,u%aspk,u%ia1,u%ia2,l1,l2,info)
call psb_silu_fctint(m,a%get_nrows(),a,blck_%get_nrows(),blck_,&
& d,l%val,l%ja,l%irp,u%val,u%ja,u%irp,l1,l2,info)
if(info /= 0) then
info=4010
ch_err='psb_silu_fctint'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
l%infoa(1) = l1
l%fida = 'CSR'
l%descra = 'TLU'
u%infoa(1) = l2
u%fida = 'CSR'
u%descra = 'TUU'
l%m = m
l%k = m
u%m = m
u%k = m
call l%set_triangle()
call l%set_lower()
call l%set_unit()
call u%set_triangle()
call u%set_upper()
call u%set_unit()
call l%set_nrows(m)
call l%set_ncols(m)
call u%set_nrows(m)
call u%set_ncols(m)
if (present(blck)) then
blck_ => null()
else
call psb_sp_free(blck_,info)
call blck_%free()
if(info /= 0) then
info=4010
ch_err='psb_sp_free'
@ -122,17 +115,20 @@ subroutine psb_silu_fct(a,l,u,d,info,blck)
contains
subroutine psb_silu_fctint(m,ma,a,mb,b,&
& d,laspk,lia1,lia2,uaspk,uia1,uia2,l1,l2,info)
use psb_mat_mod
implicit none
type(psb_sspmat_type) :: a,b
type(psb_s_sparse_mat) :: a
type(psb_s_sparse_mat) :: b
integer :: m,ma,mb,l1,l2,info
integer, dimension(:) :: lia1,lia2,uia1,uia2
real(psb_spk_), dimension(:) :: laspk,uaspk,d
integer :: i,j,k,l,low1,low2,kk,jj,ll, irb, ktrw,err_act
integer :: i,j,k,l,low1,low2,kk,jj,ll, irb, ktrw,err_act, nz
real(psb_spk_) :: dia,temp
integer, parameter :: nrb=16
type(psb_sspmat_type) :: trw
integer, parameter :: nrb=60
type(psb_s_coo_sparse_mat) :: trw
integer :: int_err(5)
character(len=20) :: name, ch_err
@ -140,11 +136,7 @@ contains
if(psb_get_errstatus() /= 0) return
info=0
call psb_erractionsave(err_act)
call psb_nullify_sp(trw)
trw%m=0
trw%k=0
call psb_sp_all(trw,1,info)
call trw%allocate(0,0,info)
if(info /= 0) then
info=4010
ch_err='psb_sp_all'
@ -159,64 +151,39 @@ contains
m = ma+mb
do i = 1, ma
d(i) = dzero
d(i) = szero
!
! Here we take a fast shortcut if possible, otherwise
! use spgtblk, slower but able (in principle) to handle
! anything.
!
if (a%fida=='CSR') then
do j = a%ia2(i), a%ia2(i+1) - 1
k = a%ia1(j)
! write(0,*)'KKKKK',k
if ((k < i).and.(k >= 1)) then
l1 = l1 + 1
laspk(l1) = a%aspk(j)
lia1(l1) = k
else if (k == i) then
d(i) = a%aspk(j)
else if ((k > i).and.(k <= m)) then
l2 = l2 + 1
uaspk(l2) = a%aspk(j)
uia1(l2) = k
end if
enddo
else
if ((mod(i,nrb) == 1).or.(nrb==1)) then
irb = min(ma-i+1,nrb)
call psb_sp_getblk(i,a,trw,info,lrw=i+irb-1)
if(info /= 0) then
info=4010
ch_err='psb_sp_getblk'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
ktrw=1
if ((mod(i,nrb) == 1).or.(nrb==1)) then
irb = min(ma-i+1,nrb)
call a%a%csget(i,i+irb-1,trw,info)
if(info /= 0) then
info=4010
ch_err='a%csget'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
do
if (ktrw > trw%infoa(psb_nnz_)) exit
if (trw%ia1(ktrw) > i) exit
k = trw%ia2(ktrw)
if ((k < i).and.(k >= 1)) then
l1 = l1 + 1
laspk(l1) = trw%aspk(ktrw)
lia1(l1) = k
else if (k == i) then
d(i) = trw%aspk(ktrw)
else if ((k > i).and.(k <= m)) then
l2 = l2 + 1
uaspk(l2) = trw%aspk(ktrw)
uia1(l2) = k
end if
ktrw = ktrw + 1
enddo
nz = trw%get_nzeros()
ktrw=1
end if
do
if (ktrw > nz ) exit
if (trw%ia(ktrw) > i) exit
k = trw%ja(ktrw)
if ((k < i).and.(k >= 1)) then
l1 = l1 + 1
laspk(l1) = trw%val(ktrw)
lia1(l1) = k
else if (k == i) then
d(i) = trw%val(ktrw)
else if ((k > i).and.(k <= m)) then
l2 = l2 + 1
uaspk(l2) = trw%val(ktrw)
uia1(l2) = k
end if
ktrw = ktrw + 1
enddo
!!$
lia2(i+1) = l1 + 1
@ -291,7 +258,7 @@ contains
call psb_errpush(info,name,i_err=int_err,a_err=ch_err)
goto 9999
else
dia = done/dia
dia = sone/dia
end if
d(i) = dia
! write(6,*)'diag(',i,')=',d(i)
@ -302,63 +269,38 @@ contains
enddo
do i = ma+1, m
d(i) = dzero
if (b%fida=='CSR') then
do j = b%ia2(i-ma), b%ia2(i-ma+1) - 1
k = b%ia1(j)
! if (me == 2) write(0,*)'ecco k=',k
if ((k < i).and.(k >= 1)) then
l1 = l1 + 1
laspk(l1) = b%aspk(j)
lia1(l1) = k
! if(me == 2) write(0,*)'scrivo l'
else if (k == i) then
d(i) = b%aspk(j)
else if ((k > i).and.(k <= m)) then
l2 = l2 + 1
uaspk(l2) = b%aspk(j)
! write(0,*)'KKKKK',k
uia1(l2) = k
end if
enddo
else
if ((mod((i-ma),nrb) == 1).or.(nrb==1)) then
irb = min(m-i+1,nrb)
call psb_sp_getblk(i-ma,b,trw,info,lrw=i-ma+irb-1)
if(info /= 0) then
info=4010
ch_err='psb_sp_getblk'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
ktrw=1
d(i) = szero
if ((mod(i,nrb) == 1).or.(nrb==1)) then
irb = min(ma-i+1,nrb)
call b%a%csget(i-ma,i-ma+irb-1,trw,info)
nz = trw%get_nzeros()
if(info /= 0) then
info=4010
ch_err='a%csget'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
do
if (ktrw > trw%infoa(psb_nnz_)) exit
if (trw%ia1(ktrw) > i) exit
k = trw%ia2(ktrw)
! write(0,*)'KKKKK',k
if ((k < i).and.(k >= 1)) then
l1 = l1 + 1
laspk(l1) = trw%aspk(ktrw)
lia1(l1) = k
else if (k == i) then
d(i) = trw%aspk(ktrw)
else if ((k > i).and.(k <= m)) then
l2 = l2 + 1
uaspk(l2) = trw%aspk(ktrw)
uia1(l2) = k
end if
ktrw = ktrw + 1
enddo
endif
ktrw=1
end if
do
if (ktrw > nz ) exit
if (trw%ia(ktrw) > i) exit
k = trw%ja(ktrw)
if ((k < i).and.(k >= 1)) then
l1 = l1 + 1
laspk(l1) = trw%val(ktrw)
lia1(l1) = k
else if (k == i) then
d(i) = trw%val(ktrw)
else if ((k > i).and.(k <= m)) then
l2 = l2 + 1
uaspk(l2) = trw%val(ktrw)
uia1(l2) = k
end if
ktrw = ktrw + 1
enddo
lia2(i+1) = l1 + 1
@ -431,7 +373,7 @@ contains
call psb_errpush(info,name,i_err=int_err,a_err=ch_err)
goto 9999
else
dia = done/dia
dia = sone/dia
end if
d(i) = dia
! Scale row i of upper triangle
@ -440,13 +382,7 @@ contains
enddo
enddo
call psb_sp_free(trw,info)
if(info /= 0) then
info=4010
ch_err='psb_sp_free'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
call trw%free()
call psb_erractionrestore(err_act)
return

2
prec/psb_sprecbld.f90
Unescape Escape View File

@ -35,7 +35,7 @@ subroutine psb_sprecbld(a,desc_a,p,info,upd)
use psb_prec_mod, psb_protect_name => psb_sprecbld
Implicit None
type(psb_sspmat_type), intent(in), target :: a
type(psb_s_sparse_mat), intent(in), target :: a
type(psb_desc_type), intent(in), target :: desc_a
type(psb_sprec_type),intent(inout) :: p
integer, intent(out) :: info

4
test/pargen/Makefile
Unescape Escape View File

@ -22,8 +22,8 @@ ppde: ppde.o psb_d_csc_impl.o psb_d_csc_mat_mod.o
psb_d_csc_impl.o ppde.o: psb_d_csc_mat_mod.o
spde: spde.o
$(F90LINK) spde.o -o spde $(PSBLAS_LIB) $(LDLIBS)
spde: spde.o enablecore.o
$(F90LINK) spde.o enablecore.o -o spde $(PSBLAS_LIB) $(LDLIBS)
/bin/mv spde $(EXEDIR)
.f90.o:

4
test/pargen/ppde.f90
Unescape Escape View File

@ -78,7 +78,6 @@ program ppde
! sparse matrix and preconditioner
type(psb_d_sparse_mat) :: a
!!$ type(psb_dspmat_type) :: a
type(psb_dprec_type) :: prec
! descriptor
type(psb_desc_type) :: desc_a
@ -110,7 +109,6 @@ program ppde
if(psb_get_errstatus() /= 0) goto 9999
name='pde90'
call psb_set_errverbosity(2)
!
! get parameters
!
@ -611,7 +609,7 @@ contains
tasb = psb_wtime()-t1
call psb_barrier(ictxt)
ttot = psb_wtime() - t0
!!$ call a%print(20+iam)
call psb_amx(ictxt,talc)
call psb_amx(ictxt,tgen)
call psb_amx(ictxt,tasb)

2
test/pargen/runs/ppde.inp
Unescape Escape View File

@ -5,7 +5,7 @@ CSR Storage format for matrix A: CSR COO JAD
060 Domain size (acutal system is this**3)
2 Stopping criterion
0400 MAXIT
-01 ITRACE
001 ITRACE
20 IRST restart for RGMRES and BiCGSTABL

24
test/pargen/spde.f90
Unescape Escape View File

@ -73,11 +73,11 @@ program ppde
integer :: idim
! miscellaneous
real(psb_spk_), parameter :: one = 1.d0
real(psb_spk_) :: t1, t2, tprec
real(psb_spk_), parameter :: one = 1.0
real(psb_dpk_) :: t1, t2, tprec
! sparse matrix and preconditioner
type(psb_sspmat_type) :: a
type(psb_s_sparse_mat) :: a
type(psb_sprec_type) :: prec
! descriptor
type(psb_desc_type) :: desc_a
@ -92,7 +92,7 @@ program ppde
real(psb_spk_) :: err, eps
! other variables
integer :: info
integer :: info, i
character(len=20) :: name,ch_err
info=0
@ -109,6 +109,7 @@ program ppde
if(psb_get_errstatus() /= 0) goto 9999
name='pde90'
call psb_set_errverbosity(2)
call enablecore()
!
! get parameters
!
@ -128,7 +129,6 @@ program ppde
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
if (iam == psb_root_) write(*,'("Overall matrix creation time : ",es12.5)')t2
if (iam == psb_root_) write(*,'(" ")')
!
@ -153,7 +153,6 @@ program ppde
if (iam == psb_root_) write(*,'("Preconditioner time : ",es12.5)')tprec
if (iam == psb_root_) write(*,'(" ")')
!
! iterative method parameters
!
@ -181,6 +180,7 @@ program ppde
call psb_sum(ictxt,amatsize)
call psb_sum(ictxt,descsize)
call psb_sum(ictxt,precsize)
if (iam == psb_root_) then
write(*,'(" ")')
write(*,'("Time to solve matrix : ",es12.5)')t2
@ -341,6 +341,7 @@ contains
! Note that if a1=a2=a3=a4=0., the PDE is the well-known Laplace equation.
!
use psb_base_mod
use psb_mat_mod
implicit none
integer :: idim
integer, parameter :: nb=20
@ -348,7 +349,9 @@ contains
type(psb_desc_type) :: desc_a
integer :: ictxt, info
character :: afmt*5
type(psb_sspmat_type) :: a
type(psb_s_sparse_mat) :: a
type(psb_s_coo_sparse_mat) :: acoo
type(psb_s_csr_sparse_mat) :: acsr
real(psb_spk_) :: zt(nb),glob_x,glob_y,glob_z
integer :: m,n,nnz,glob_row,nlr,i,ii,ib,k
integer :: x,y,z,ia,indx_owner
@ -365,7 +368,7 @@ contains
external :: a1, a2, a3, a4, b1, b2, b3
integer :: err_act
character(len=20) :: name, ch_err
character(len=20) :: name, ch_err,tmpfmt
info = 0
name = 'create_matrix'
@ -585,7 +588,7 @@ contains
t1 = psb_wtime()
call psb_cdasb(desc_a,info)
if (info == 0) &
& call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,afmt=afmt)
& call psb_spasb(a,desc_a,info,dupl=psb_dupl_err_,mold=acsr)
call psb_barrier(ictxt)
if(info /= 0) then
info=4010
@ -610,8 +613,9 @@ contains
call psb_amx(ictxt,tasb)
call psb_amx(ictxt,ttot)
if(iam == psb_root_) then
tmpfmt = a%get_fmt()
write(*,'("The matrix has been generated and assembled in ",a3," format.")')&
& a%fida(1:3)
& tmpfmt
write(*,'("-allocation time : ",es12.5)') talc
write(*,'("-coeff. gen. time : ",es12.5)') tgen
write(*,'("-assembly time : ",es12.5)') tasb

88
util/psb_hbio_mod.f90
Unescape Escape View File

@ -44,7 +44,7 @@ contains
subroutine shb_read(a, iret, iunit, filename,b,g,x,mtitle)
use psb_base_mod
implicit none
type(psb_sspmat_type), intent(out) :: a
type(psb_s_sparse_mat), intent(out) :: a
integer, intent(out) :: iret
integer, optional, intent(in) :: iunit
character(len=*), optional, intent(in) :: filename
@ -56,6 +56,8 @@ contains
character indfmt*16,ptrfmt*16,rhsfmt*20,valfmt*20
integer :: indcrd, ptrcrd, totcrd,&
& valcrd, rhscrd, nrow, ncol, nnzero, neltvl, nrhs, nrhsix
type(psb_s_csr_sparse_mat) :: acsr
type(psb_s_coo_sparse_mat) :: acoo
integer :: ircode, i,nzr,infile, info
character(len=*), parameter :: fmt10='(a72,a8,/,5i14,/,a3,11x,4i14,/,2a16,2a20)'
character(len=*), parameter :: fmt11='(a3,11x,2i14)'
@ -82,31 +84,29 @@ contains
endif
endif
read(infile,fmt=fmt10) mtitle_,key,totcrd,ptrcrd,indcrd,valcrd,rhscrd,&
read (infile,fmt=fmt10) mtitle_,key,totcrd,ptrcrd,indcrd,valcrd,rhscrd,&
& type,nrow,ncol,nnzero,neltvl,ptrfmt,indfmt,valfmt,rhsfmt
if (rhscrd > 0) read(infile,fmt=fmt11)rhstype,nrhs,nrhsix
call psb_sp_all(a,nnzero,nrow+1,nnzero,ircode)
call acsr%allocate(nrow,ncol,nnzero)
if (ircode /= 0 ) then
write(0,*) 'Memory allocation failed'
goto 993
end if
if (present(mtitle)) mtitle=mtitle_
a%m = nrow
a%k = ncol
a%fida = 'CSR'
a%descra='G'
if (psb_tolower(type(1:1)) == 'r') then
if (psb_tolower(type(2:2)) == 'u') then
read (infile,fmt=ptrfmt) (a%ia2(i),i=1,nrow+1)
read (infile,fmt=indfmt) (a%ia1(i),i=1,nnzero)
if (valcrd > 0) read (infile,fmt=valfmt) (a%aspk(i),i=1,nnzero)
read (infile,fmt=ptrfmt) (acsr%irp(i),i=1,nrow+1)
read (infile,fmt=indfmt) (acsr%ja(i),i=1,nnzero)
if (valcrd > 0) read (infile,fmt=valfmt) (acsr%val(i),i=1,nnzero)
call a%mv_from(acsr)
if (present(b)) then
if ((psb_toupper(rhstype(1:1)) == 'F').and.(rhscrd > 0)) then
call psb_realloc(nrow,1,b,info)
@ -131,9 +131,9 @@ contains
! we are generally working with non-symmetric matrices, so
! we de-symmetrize what we are about to read
read (infile,fmt=ptrfmt) (a%ia2(i),i=1,nrow+1)
read (infile,fmt=indfmt) (a%ia1(i),i=1,nnzero)
if (valcrd > 0) read (infile,fmt=valfmt) (a%aspk(i),i=1,nnzero)
read (infile,fmt=ptrfmt) (acsr%irp(i),i=1,nrow+1)
read (infile,fmt=indfmt) (acsr%ja(i),i=1,nnzero)
if (valcrd > 0) read (infile,fmt=valfmt) (acsr%val(i),i=1,nnzero)
if (present(b)) then
@ -155,23 +155,24 @@ contains
endif
endif
call psb_spcnv(a,ircode,afmt='csr')
if (ircode /= 0) goto 993
call psb_sp_reall(a,2*nnzero,ircode)
call acoo%mv_from_fmt(acsr,info)
call acoo%reallocate(2*nnzero)
! A is now in COO format
nzr = nnzero
do i=1,nnzero
if (a%ia1(i) /= a%ia2(i)) then
if (acoo%ia(i) /= acoo%ja(i)) then
nzr = nzr + 1
a%aspk(nzr) = a%aspk(i)
a%ia1(nzr) = a%ia2(i)
a%ia2(nzr) = a%ia1(i)
acoo%val(nzr) = acoo%val(i)
acoo%ia(nzr) = acoo%ja(i)
acoo%ja(nzr) = acoo%ia(i)
end if
end do
a%infoa(psb_nnz_) = nzr
call psb_spcnv(a,ircode,afmt='csr')
if (ircode /= 0) goto 993
call acoo%set_nzeros(nzr)
call acoo%fix(ircode)
if (ircode==0) call a%mv_from(acoo)
if (ircode==0) call a%cscnv(ircode,type='csr')
if (ircode/=0) goto 993
else
write(0,*) 'read_matrix: matrix type not yet supported'
@ -197,11 +198,10 @@ contains
return
end subroutine shb_read
subroutine shb_write(a,iret,iunit,filename,key,rhs,g,x,mtitle)
use psb_base_mod
implicit none
type(psb_sspmat_type), intent(in) :: a
type(psb_s_sparse_mat), intent(in) :: a
integer, intent(out) :: iret
character(len=*), optional, intent(in) :: mtitle
integer, optional, intent(in) :: iunit
@ -258,11 +258,13 @@ contains
key_ = 'PSBMAT00'
endif
if (psb_toupper(a%fida) == 'CSR') then
select type(aa=>a%a)
type is (psb_s_csr_sparse_mat)
nrow = a%m
ncol = a%k
nnzero = a%ia2(nrow+1)-1
nrow = aa%get_nrows()
ncol = aa%get_ncols()
nnzero = aa%get_nzeros()
neltvl = 0
@ -286,7 +288,8 @@ contains
rhscrd = 0
nrhs = 0
end if
totcrd = ptrcrd + indcrd + valcrd + rhscrd
totcrd = ptrcrd + indcrd + valcrd + rhscrd
nrhsix = nrhs*nrow
if (present(g)) then
@ -295,24 +298,24 @@ contains
if (present(x)) then
rhstype(3:3) = 'X'
end if
type = 'RUA'
write (iout,fmt=fmt10) mtitle_,key_,totcrd,ptrcrd,indcrd,valcrd,rhscrd,&
& type,nrow,ncol,nnzero,neltvl,ptrfmt,indfmt,valfmt,rhsfmt
if (rhscrd > 0) write (iout,fmt=fmt11) rhstype,nrhs,nrhsix
write (iout,fmt=ptrfmt) (a%ia2(i),i=1,nrow+1)
write (iout,fmt=indfmt) (a%ia1(i),i=1,nnzero)
if (valcrd > 0) write (iout,fmt=valfmt) (a%aspk(i),i=1,nnzero)
write (iout,fmt=ptrfmt) (aa%irp(i),i=1,nrow+1)
write (iout,fmt=indfmt) (aa%ja(i),i=1,nnzero)
if (valcrd > 0) write (iout,fmt=valfmt) (aa%val(i),i=1,nnzero)
if (rhscrd > 0) write (iout,fmt=rhsfmt) (rhs(i),i=1,nrow)
if (present(g).and.(rhscrd>0)) write (iout,fmt=rhsfmt) (g(i),i=1,nrow)
if (present(x).and.(rhscrd>0)) write (iout,fmt=rhsfmt) (x(i),i=1,nrow)
else
write(0,*) 'format: ',a%fida,' not yet implemented'
class default
endif
write(0,*) 'format: ',a%get_fmt(),' not yet implemented'
end select
if (iout /= 6) close(iout)
@ -325,6 +328,7 @@ contains
return
end subroutine shb_write
subroutine dhb_read(a, iret, iunit, filename,b,g,x,mtitle)
use psb_base_mod
implicit none

27
util/psb_mat_dist_mod.f90
Unescape Escape View File

@ -97,14 +97,15 @@ contains
! on exit : unchanged.
!
use psb_base_mod
use psb_mat_mod
implicit none
! parameters
type(psb_sspmat_type) :: a_glob
type(psb_s_sparse_mat) :: a_glob
real(psb_spk_) :: b_glob(:)
integer :: ictxt
type(psb_sspmat_type) :: a
real(psb_spk_), allocatable :: b(:)
type(psb_s_sparse_mat) :: a
real(psb_spk_), allocatable :: b(:)
type(psb_desc_type) :: desc_a
integer, intent(out) :: info
integer, optional :: inroot
@ -148,22 +149,15 @@ contains
end if
call psb_info(ictxt, iam, np)
if (iam == root) then
! extract information from a_glob
if (a_glob%fida /= 'CSR') then
info=135
ch_err='CSR'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
endif
nrow = a_glob%m
ncol = a_glob%k
nrow = a_glob%get_nrows()
ncol = a_glob%get_ncols()
if (nrow /= ncol) then
write(0,*) 'a rectangular matrix ? ',nrow,ncol
info=-1
call psb_errpush(info,name)
goto 9999
endif
nnzero = size(a_glob%aspk)
nnzero = a_glob%get_nzeros()
nrhs = 1
endif
@ -268,7 +262,7 @@ contains
ll = 0
do i= i_count, j_count-1
call psb_sp_getrow(i,a_glob,nz,&
call a_glob%csget(i,i,nz,&
& irow,icol,val,info,nzin=ll,append=.true.)
if (info /= 0) then
if (nz >min(size(irow(ll+1:)),size(icol(ll+1:)),size(val(ll+1:)))) then
@ -356,7 +350,7 @@ contains
ll = 0
do i= i_count, i_count
call psb_sp_getrow(i,a_glob,nz,&
call a_glob%csget(i,i,nz,&
& irow,icol,val,info,nzin=ll,append=.true.)
if (info /= 0) then
if (nz >min(size(irow(ll+1:)),size(icol(ll+1:)),size(val(ll+1:)))) then
@ -488,6 +482,7 @@ contains
end subroutine smatdist
subroutine dmatdist(a_glob, a, ictxt, desc_a,&
& b_glob, b, info, parts, v, inroot,fmt)
!
@ -547,7 +542,7 @@ contains
! on exit : unchanged.
!
use psb_base_mod
use psb_d_mat_mod
use psb_mat_mod
implicit none
! parameters

19
util/psb_metispart_mod.F90
Unescape Escape View File

@ -60,7 +60,7 @@ module psb_metispart_mod
integer, allocatable, save :: graph_vect(:)
interface build_mtpart
module procedure build_mtpart, d_mat_build_mtpart
module procedure build_mtpart, d_mat_build_mtpart, s_mat_build_mtpart
end interface
contains
@ -150,6 +150,23 @@ contains
end subroutine d_mat_build_mtpart
subroutine s_mat_build_mtpart(a,nparts)
use psb_base_mod
type(psb_s_sparse_mat), intent(in) :: a
integer :: nparts
select type (aa=>a%a)
type is (psb_s_csr_sparse_mat)
call build_mtpart(aa%get_nrows(),aa%get_fmt(),aa%ja,aa%irp,nparts)
class default
write(0,*) 'Sorry, right now we only take CSR input!'
call psb_abort(ictxt)
end select
end subroutine s_mat_build_mtpart
subroutine build_mtpart(n,fida,ia1,ia2,nparts)
use psb_base_mod

55
util/psb_mmio_mod.f90
Unescape Escape View File

@ -341,11 +341,10 @@ contains
end subroutine mm_zvet_read
subroutine smm_mat_read(a, info, iunit, filename)
use psb_base_mod
implicit none
type(psb_sspmat_type), intent(out) :: a
type(psb_s_sparse_mat), intent(out) :: a
integer, intent(out) :: info
integer, optional, intent(in) :: iunit
character(len=*), optional, intent(in) :: filename
@ -353,6 +352,7 @@ contains
character(1024) :: line
integer :: nrow, ncol, nnzero
integer :: ircode, i,nzr,infile
type(psb_s_coo_sparse_mat), allocatable :: acoo
info = 0
@ -388,46 +388,51 @@ contains
if (line(1:1) /= '%') exit
end do
read(line,fmt=*) nrow,ncol,nnzero
allocate(acoo, stat=ircode)
if (ircode /= 0) goto 993
if ((psb_tolower(type) == 'real').and.(psb_tolower(sym) == 'general')) then
call psb_sp_all(nrow,ncol,a,nnzero,ircode)
a%fida = 'COO'
a%descra = 'G'
if (ircode /= 0) goto 993
call acoo%allocate(nrow,ncol,nnzero)
do i=1,nnzero
read(infile,fmt=*,end=902) a%ia1(i),a%ia2(i),a%aspk(i)
read(infile,fmt=*,end=902) acoo%ia(i),acoo%ja(i),acoo%val(i)
end do
a%infoa(psb_nnz_) = nnzero
call psb_spcnv(a,ircode,afmt='csr')
call acoo%set_nzeros(nnzero)
call acoo%fix(info)
call a%mv_from(acoo)
call a%cscnv(ircode,type='csr')
else if ((psb_tolower(type) == 'real').and.(psb_tolower(sym) == 'symmetric')) then
! we are generally working with non-symmetric matrices, so
! we de-symmetrize what we are about to read
call psb_sp_all(nrow,ncol,a,2*nnzero,ircode)
a%fida = 'COO'
a%descra = 'G'
if (ircode /= 0) goto 993
call acoo%allocate(nrow,ncol,nnzero)
do i=1,nnzero
read(infile,fmt=*,end=902) a%ia1(i),a%ia2(i),a%aspk(i)
read(infile,fmt=*,end=902) acoo%ia(i),acoo%ja(i),acoo%val(i)
end do
nzr = nnzero
do i=1,nnzero
if (a%ia1(i) /= a%ia2(i)) then
if (acoo%ia(i) /= acoo%ja(i)) then
nzr = nzr + 1
a%aspk(nzr) = a%aspk(i)
a%ia1(nzr) = a%ia2(i)
a%ia2(nzr) = a%ia1(i)
acoo%val(nzr) = acoo%val(i)
acoo%ia(nzr) = acoo%ja(i)
acoo%ja(nzr) = acoo%ia(i)
end if
end do
a%infoa(psb_nnz_) = nzr
call psb_spcnv(a,ircode,afmt='csr')
call acoo%set_nzeros(nzr)
call acoo%fix(info)
call a%mv_from(acoo)
call a%cscnv(ircode,type='csr')
else
write(0,*) 'read_matrix: matrix type not yet supported'
info=904
end if
if (infile/=5) close(infile)
return
! open failed
@ -446,7 +451,7 @@ contains
subroutine smm_mat_write(a,mtitle,info,iunit,filename)
use psb_base_mod
implicit none
type(psb_sspmat_type), intent(in) :: a
type(psb_s_sparse_mat), intent(in) :: a
integer, intent(out) :: info
character(len=*), intent(in) :: mtitle
integer, optional, intent(in) :: iunit
@ -475,7 +480,7 @@ contains
endif
endif
call psb_csprt(iout,a,head=mtitle)
call a%print(iout,head=mtitle)
if (iout /= 6) close(iout)
@ -487,6 +492,8 @@ contains
write(0,*) 'Error while opening ',filename
return
end subroutine smm_mat_write
subroutine dmm_mat_read(a, info, iunit, filename)
use psb_base_mod

Write Preview
Loading…
Cancel
Save