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

Refactor assembly and cnv

Browse Source
non-diag
sfilippone 1 year ago
parent 4d051c777d
commit 3aa3c795e9
16 changed files with 1457 additions and 625 deletions
Show Stats Download Patch File Download Diff File

15
base/modules/serial/psb_c_mat_mod.F90
Unescape Escape View File

@ -204,6 +204,7 @@ module psb_c_mat_mod
procedure, pass(a) :: cscnv_ip => psb_c_cscnv_ip procedure, pass(a) :: cscnv_ip => psb_c_cscnv_ip
procedure, pass(a) :: cscnv_base => psb_c_cscnv_base procedure, pass(a) :: cscnv_base => psb_c_cscnv_base
generic, public :: cscnv => cscnv_np, cscnv_ip, cscnv_base generic, public :: cscnv => cscnv_np, cscnv_ip, cscnv_base
procedure, pass(a) :: split_nd => psb_c_split_nd
procedure, pass(a) :: clone => psb_cspmat_clone procedure, pass(a) :: clone => psb_cspmat_clone
procedure, pass(a) :: move_alloc => psb_cspmat_type_move procedure, pass(a) :: move_alloc => psb_cspmat_type_move
! !
@ -842,6 +843,18 @@ module psb_c_mat_mod
! !
! !
interface
subroutine psb_c_split_nd(a,n_rows,n_cols,info)
import :: psb_ipk_, psb_lpk_, psb_cspmat_type, psb_spk_, psb_c_base_sparse_mat
class(psb_cspmat_type), intent(inout) :: a
integer(psb_ipk_), intent(in) :: n_rows, n_cols
integer(psb_ipk_), intent(out) :: info
!!$ integer(psb_ipk_),optional, intent(in) :: dupl
!!$ character(len=*), optional, intent(in) :: type
!!$ class(psb_c_base_sparse_mat), intent(in), optional :: mold
end subroutine psb_c_split_nd
end interface
! !
! CSCNV: switches to a different internal derived type. ! CSCNV: switches to a different internal derived type.
! 3 versions: copying to target ! 3 versions: copying to target
@ -861,7 +874,6 @@ module psb_c_mat_mod
end subroutine psb_c_cscnv end subroutine psb_c_cscnv
end interface end interface
interface interface
subroutine psb_c_cscnv_ip(a,iinfo,type,mold,dupl) subroutine psb_c_cscnv_ip(a,iinfo,type,mold,dupl)
import :: psb_ipk_, psb_lpk_, psb_cspmat_type, psb_spk_, psb_c_base_sparse_mat import :: psb_ipk_, psb_lpk_, psb_cspmat_type, psb_spk_, psb_c_base_sparse_mat
@ -873,7 +885,6 @@ module psb_c_mat_mod
end subroutine psb_c_cscnv_ip end subroutine psb_c_cscnv_ip
end interface end interface
interface interface
subroutine psb_c_cscnv_base(a,b,info,dupl) subroutine psb_c_cscnv_base(a,b,info,dupl)
import :: psb_ipk_, psb_lpk_, psb_cspmat_type, psb_spk_, psb_c_base_sparse_mat import :: psb_ipk_, psb_lpk_, psb_cspmat_type, psb_spk_, psb_c_base_sparse_mat

15
base/modules/serial/psb_d_mat_mod.F90
Unescape Escape View File

@ -204,6 +204,7 @@ module psb_d_mat_mod
procedure, pass(a) :: cscnv_ip => psb_d_cscnv_ip procedure, pass(a) :: cscnv_ip => psb_d_cscnv_ip
procedure, pass(a) :: cscnv_base => psb_d_cscnv_base procedure, pass(a) :: cscnv_base => psb_d_cscnv_base
generic, public :: cscnv => cscnv_np, cscnv_ip, cscnv_base generic, public :: cscnv => cscnv_np, cscnv_ip, cscnv_base
procedure, pass(a) :: split_nd => psb_d_split_nd
procedure, pass(a) :: clone => psb_dspmat_clone procedure, pass(a) :: clone => psb_dspmat_clone
procedure, pass(a) :: move_alloc => psb_dspmat_type_move procedure, pass(a) :: move_alloc => psb_dspmat_type_move
! !
@ -842,6 +843,18 @@ module psb_d_mat_mod
! !
! !
interface
subroutine psb_d_split_nd(a,n_rows,n_cols,info)
import :: psb_ipk_, psb_lpk_, psb_dspmat_type, psb_dpk_, psb_d_base_sparse_mat
class(psb_dspmat_type), intent(inout) :: a
integer(psb_ipk_), intent(in) :: n_rows, n_cols
integer(psb_ipk_), intent(out) :: info
!!$ integer(psb_ipk_),optional, intent(in) :: dupl
!!$ character(len=*), optional, intent(in) :: type
!!$ class(psb_d_base_sparse_mat), intent(in), optional :: mold
end subroutine psb_d_split_nd
end interface
! !
! CSCNV: switches to a different internal derived type. ! CSCNV: switches to a different internal derived type.
! 3 versions: copying to target ! 3 versions: copying to target
@ -861,7 +874,6 @@ module psb_d_mat_mod
end subroutine psb_d_cscnv end subroutine psb_d_cscnv
end interface end interface
interface interface
subroutine psb_d_cscnv_ip(a,iinfo,type,mold,dupl) subroutine psb_d_cscnv_ip(a,iinfo,type,mold,dupl)
import :: psb_ipk_, psb_lpk_, psb_dspmat_type, psb_dpk_, psb_d_base_sparse_mat import :: psb_ipk_, psb_lpk_, psb_dspmat_type, psb_dpk_, psb_d_base_sparse_mat
@ -873,7 +885,6 @@ module psb_d_mat_mod
end subroutine psb_d_cscnv_ip end subroutine psb_d_cscnv_ip
end interface end interface
interface interface
subroutine psb_d_cscnv_base(a,b,info,dupl) subroutine psb_d_cscnv_base(a,b,info,dupl)
import :: psb_ipk_, psb_lpk_, psb_dspmat_type, psb_dpk_, psb_d_base_sparse_mat import :: psb_ipk_, psb_lpk_, psb_dspmat_type, psb_dpk_, psb_d_base_sparse_mat

15
base/modules/serial/psb_s_mat_mod.F90
Unescape Escape View File

@ -204,6 +204,7 @@ module psb_s_mat_mod
procedure, pass(a) :: cscnv_ip => psb_s_cscnv_ip procedure, pass(a) :: cscnv_ip => psb_s_cscnv_ip
procedure, pass(a) :: cscnv_base => psb_s_cscnv_base procedure, pass(a) :: cscnv_base => psb_s_cscnv_base
generic, public :: cscnv => cscnv_np, cscnv_ip, cscnv_base generic, public :: cscnv => cscnv_np, cscnv_ip, cscnv_base
procedure, pass(a) :: split_nd => psb_s_split_nd
procedure, pass(a) :: clone => psb_sspmat_clone procedure, pass(a) :: clone => psb_sspmat_clone
procedure, pass(a) :: move_alloc => psb_sspmat_type_move procedure, pass(a) :: move_alloc => psb_sspmat_type_move
! !
@ -842,6 +843,18 @@ module psb_s_mat_mod
! !
! !
interface
subroutine psb_s_split_nd(a,n_rows,n_cols,info)
import :: psb_ipk_, psb_lpk_, psb_sspmat_type, psb_spk_, psb_s_base_sparse_mat
class(psb_sspmat_type), intent(inout) :: a
integer(psb_ipk_), intent(in) :: n_rows, n_cols
integer(psb_ipk_), intent(out) :: info
!!$ integer(psb_ipk_),optional, intent(in) :: dupl
!!$ character(len=*), optional, intent(in) :: type
!!$ class(psb_s_base_sparse_mat), intent(in), optional :: mold
end subroutine psb_s_split_nd
end interface
! !
! CSCNV: switches to a different internal derived type. ! CSCNV: switches to a different internal derived type.
! 3 versions: copying to target ! 3 versions: copying to target
@ -861,7 +874,6 @@ module psb_s_mat_mod
end subroutine psb_s_cscnv end subroutine psb_s_cscnv
end interface end interface
interface interface
subroutine psb_s_cscnv_ip(a,iinfo,type,mold,dupl) subroutine psb_s_cscnv_ip(a,iinfo,type,mold,dupl)
import :: psb_ipk_, psb_lpk_, psb_sspmat_type, psb_spk_, psb_s_base_sparse_mat import :: psb_ipk_, psb_lpk_, psb_sspmat_type, psb_spk_, psb_s_base_sparse_mat
@ -873,7 +885,6 @@ module psb_s_mat_mod
end subroutine psb_s_cscnv_ip end subroutine psb_s_cscnv_ip
end interface end interface
interface interface
subroutine psb_s_cscnv_base(a,b,info,dupl) subroutine psb_s_cscnv_base(a,b,info,dupl)
import :: psb_ipk_, psb_lpk_, psb_sspmat_type, psb_spk_, psb_s_base_sparse_mat import :: psb_ipk_, psb_lpk_, psb_sspmat_type, psb_spk_, psb_s_base_sparse_mat

15
base/modules/serial/psb_z_mat_mod.F90
Unescape Escape View File

@ -204,6 +204,7 @@ module psb_z_mat_mod
procedure, pass(a) :: cscnv_ip => psb_z_cscnv_ip procedure, pass(a) :: cscnv_ip => psb_z_cscnv_ip
procedure, pass(a) :: cscnv_base => psb_z_cscnv_base procedure, pass(a) :: cscnv_base => psb_z_cscnv_base
generic, public :: cscnv => cscnv_np, cscnv_ip, cscnv_base generic, public :: cscnv => cscnv_np, cscnv_ip, cscnv_base
procedure, pass(a) :: split_nd => psb_z_split_nd
procedure, pass(a) :: clone => psb_zspmat_clone procedure, pass(a) :: clone => psb_zspmat_clone
procedure, pass(a) :: move_alloc => psb_zspmat_type_move procedure, pass(a) :: move_alloc => psb_zspmat_type_move
! !
@ -842,6 +843,18 @@ module psb_z_mat_mod
! !
! !
interface
subroutine psb_z_split_nd(a,n_rows,n_cols,info)
import :: psb_ipk_, psb_lpk_, psb_zspmat_type, psb_dpk_, psb_z_base_sparse_mat
class(psb_zspmat_type), intent(inout) :: a
integer(psb_ipk_), intent(in) :: n_rows, n_cols
integer(psb_ipk_), intent(out) :: info
!!$ integer(psb_ipk_),optional, intent(in) :: dupl
!!$ character(len=*), optional, intent(in) :: type
!!$ class(psb_z_base_sparse_mat), intent(in), optional :: mold
end subroutine psb_z_split_nd
end interface
! !
! CSCNV: switches to a different internal derived type. ! CSCNV: switches to a different internal derived type.
! 3 versions: copying to target ! 3 versions: copying to target
@ -861,7 +874,6 @@ module psb_z_mat_mod
end subroutine psb_z_cscnv end subroutine psb_z_cscnv
end interface end interface
interface interface
subroutine psb_z_cscnv_ip(a,iinfo,type,mold,dupl) subroutine psb_z_cscnv_ip(a,iinfo,type,mold,dupl)
import :: psb_ipk_, psb_lpk_, psb_zspmat_type, psb_dpk_, psb_z_base_sparse_mat import :: psb_ipk_, psb_lpk_, psb_zspmat_type, psb_dpk_, psb_z_base_sparse_mat
@ -873,7 +885,6 @@ module psb_z_mat_mod
end subroutine psb_z_cscnv_ip end subroutine psb_z_cscnv_ip
end interface end interface
interface interface
subroutine psb_z_cscnv_base(a,b,info,dupl) subroutine psb_z_cscnv_base(a,b,info,dupl)
import :: psb_ipk_, psb_lpk_, psb_zspmat_type, psb_dpk_, psb_z_base_sparse_mat import :: psb_ipk_, psb_lpk_, psb_zspmat_type, psb_dpk_, psb_z_base_sparse_mat

74
base/psblas/psb_cspmm.f90
Unescape Escape View File

@ -83,6 +83,9 @@ subroutine psb_cspmv_vect(alpha,a,x,beta,y,desc_a,info,&
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
logical :: aliw, doswap_ logical :: aliw, doswap_
integer(psb_ipk_) :: debug_level, debug_unit integer(psb_ipk_) :: debug_level, debug_unit
logical, parameter :: do_timings=.true.
integer(psb_ipk_), save :: mv_phase1=-1, mv_phase2=-1, mv_phase3=-1, mv_phase4=-1
integer(psb_ipk_), save :: mv_phase11=-1, mv_phase12=-1
name='psb_cspmv' name='psb_cspmv'
info=psb_success_ info=psb_success_
@ -130,6 +133,19 @@ subroutine psb_cspmv_vect(alpha,a,x,beta,y,desc_a,info,&
call psb_errpush(info,name) call psb_errpush(info,name)
goto 9999 goto 9999
end if end if
if ((do_timings).and.(mv_phase1==-1)) &
& mv_phase1 = psb_get_timer_idx("SPMM: and send ")
if ((do_timings).and.(mv_phase2==-1)) &
& mv_phase2 = psb_get_timer_idx("SPMM: and cmp ad")
if ((do_timings).and.(mv_phase3==-1)) &
& mv_phase3 = psb_get_timer_idx("SPMM: and rcv")
if ((do_timings).and.(mv_phase4==-1)) &
& mv_phase4 = psb_get_timer_idx("SPMM: and cmp and")
if ((do_timings).and.(mv_phase11==-1)) &
& mv_phase11 = psb_get_timer_idx("SPMM: noand exch ")
if ((do_timings).and.(mv_phase12==-1)) &
& mv_phase12 = psb_get_timer_idx("SPMM: noand cmp")
m = desc_a%get_global_rows() m = desc_a%get_global_rows()
n = desc_a%get_global_cols() n = desc_a%get_global_cols()
@ -178,34 +194,44 @@ subroutine psb_cspmv_vect(alpha,a,x,beta,y,desc_a,info,&
if (trans_ == 'N') then if (trans_ == 'N') then
! Matrix is not transposed ! Matrix is not transposed
if (allocated(a%ad)) then if (allocated(a%ad)) then
block block
logical, parameter :: do_timings=.true. logical, parameter :: do_timings=.true.
real(psb_dpk_) :: t1, t2, t3, t4, t5 real(psb_dpk_) :: t1, t2, t3, t4, t5
if (do_timings) call psb_barrier(ctxt) !if (me==0) write(0,*) 'going for overlap ',a%ad%get_fmt(),' ',a%and%get_fmt()
if (do_timings) t1= psb_wtime() if (do_timings) call psb_barrier(ctxt)
if (doswap_) call psi_swapdata(psb_swap_send_,& if (do_timings) call psb_tic(mv_phase1)
& czero,x%v,desc_a,iwork,info,data=psb_comm_halo_) if (doswap_) call psi_swapdata(psb_swap_send_,&
if (do_timings) t2= psb_wtime()
call a%ad%spmm(alpha,x%v,beta,y%v,info)
if (do_timings) t3= psb_wtime()
if (doswap_) call psi_swapdata(psb_swap_recv_,&
& czero,x%v,desc_a,iwork,info,data=psb_comm_halo_)
if (do_timings) t4= psb_wtime()
call a%and%spmm(alpha,x%v,cone,y%v,info)
if (do_timings) t5= psb_wtime()
if (do_timings) write(0,*) me,' SPMM:',t2-t1,t3-t2,t4-t3,t5-t4
end block
else
if (doswap_) then
call psi_swapdata(ior(psb_swap_send_,psb_swap_recv_),&
& czero,x%v,desc_a,iwork,info,data=psb_comm_halo_) & czero,x%v,desc_a,iwork,info,data=psb_comm_halo_)
end if if (do_timings) call psb_toc(mv_phase1)
if (do_timings) call psb_tic(mv_phase2)
call psb_csmm(alpha,a,x,beta,y,info) call a%ad%spmm(alpha,x%v,beta,y%v,info)
if (do_timings) call psb_tic(mv_phase3)
if (doswap_) call psi_swapdata(psb_swap_recv_,&
& czero,x%v,desc_a,iwork,info,data=psb_comm_halo_)
if (do_timings) call psb_toc(mv_phase3)
if (do_timings) call psb_tic(mv_phase4)
call a%and%spmm(alpha,x%v,cone,y%v,info)
if (do_timings) call psb_toc(mv_phase4)
end block
else
block
logical, parameter :: do_timings=.true.
real(psb_dpk_) :: t1, t2, t3, t4, t5
if (do_timings) call psb_barrier(ctxt)
if (do_timings) call psb_tic(mv_phase11)
if (doswap_) then
call psi_swapdata(ior(psb_swap_send_,psb_swap_recv_),&
& czero,x%v,desc_a,iwork,info,data=psb_comm_halo_)
end if
if (do_timings) call psb_toc(mv_phase11)
if (do_timings) call psb_tic(mv_phase12)
call psb_csmm(alpha,a,x,beta,y,info)
if (do_timings) call psb_toc(mv_phase12)
end block
end if end if
if(info /= psb_success_) then if(info /= psb_success_) then

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

@ -194,48 +194,45 @@ subroutine psb_dspmv_vect(alpha,a,x,beta,y,desc_a,info,&
if (trans_ == 'N') then if (trans_ == 'N') then
! Matrix is not transposed ! Matrix is not transposed
if (allocated(a%ad)) then if (allocated(a%ad)) then
block block
logical, parameter :: do_timings=.true. logical, parameter :: do_timings=.true.
real(psb_dpk_) :: t1, t2, t3, t4, t5 real(psb_dpk_) :: t1, t2, t3, t4, t5
!write(0,*) 'Going for overlap ',a%ad%get_fmt(),' ',a%and%get_fmt() !if (me==0) write(0,*) 'going for overlap ',a%ad%get_fmt(),' ',a%and%get_fmt()
if (do_timings) call psb_barrier(ctxt) if (do_timings) call psb_barrier(ctxt)
if (do_timings) call psb_tic(mv_phase1) if (do_timings) call psb_tic(mv_phase1)
if (doswap_) call psi_swapdata(psb_swap_send_,& if (doswap_) call psi_swapdata(psb_swap_send_,&
& dzero,x%v,desc_a,iwork,info,data=psb_comm_halo_) & dzero,x%v,desc_a,iwork,info,data=psb_comm_halo_)
if (do_timings) call psb_toc(mv_phase1) if (do_timings) call psb_toc(mv_phase1)
if (do_timings) call psb_tic(mv_phase2) if (do_timings) call psb_tic(mv_phase2)
call a%ad%spmm(alpha,x%v,beta,y%v,info) call a%ad%spmm(alpha,x%v,beta,y%v,info)
if (do_timings) call psb_toc(mv_phase2) if (do_timings) call psb_tic(mv_phase3)
if (do_timings) call psb_tic(mv_phase3) if (doswap_) call psi_swapdata(psb_swap_recv_,&
if (doswap_) call psi_swapdata(psb_swap_recv_,& & dzero,x%v,desc_a,iwork,info,data=psb_comm_halo_)
& dzero,x%v,desc_a,iwork,info,data=psb_comm_halo_) if (do_timings) call psb_toc(mv_phase3)
if (do_timings) call psb_toc(mv_phase3) if (do_timings) call psb_tic(mv_phase4)
if (do_timings) call psb_tic(mv_phase4) call a%and%spmm(alpha,x%v,done,y%v,info)
if (do_timings) t4= psb_wtime() if (do_timings) call psb_toc(mv_phase4)
call a%and%spmm(alpha,x%v,done,y%v,info) end block
if (do_timings) call psb_toc(mv_phase4)
end block
else else
block block
logical, parameter :: do_timings=.true. logical, parameter :: do_timings=.true.
real(psb_dpk_) :: t1, t2, t3, t4, t5 real(psb_dpk_) :: t1, t2, t3, t4, t5
if (do_timings) call psb_barrier(ctxt) if (do_timings) call psb_barrier(ctxt)
if (do_timings) call psb_tic(mv_phase11) if (do_timings) call psb_tic(mv_phase11)
if (doswap_) then if (doswap_) then
call psi_swapdata(ior(psb_swap_send_,psb_swap_recv_),& call psi_swapdata(ior(psb_swap_send_,psb_swap_recv_),&
& dzero,x%v,desc_a,iwork,info,data=psb_comm_halo_) & dzero,x%v,desc_a,iwork,info,data=psb_comm_halo_)
end if end if
if (do_timings) call psb_toc(mv_phase11) if (do_timings) call psb_toc(mv_phase11)
if (do_timings) call psb_tic(mv_phase12) if (do_timings) call psb_tic(mv_phase12)
call psb_csmm(alpha,a,x,beta,y,info) call psb_csmm(alpha,a,x,beta,y,info)
if (do_timings) call psb_toc(mv_phase12) if (do_timings) call psb_toc(mv_phase12)
end block end block
end if end if
if(info /= psb_success_) then if(info /= psb_success_) then
info = psb_err_from_subroutine_non_ info = psb_err_from_subroutine_non_

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

@ -83,6 +83,9 @@ subroutine psb_sspmv_vect(alpha,a,x,beta,y,desc_a,info,&
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
logical :: aliw, doswap_ logical :: aliw, doswap_
integer(psb_ipk_) :: debug_level, debug_unit integer(psb_ipk_) :: debug_level, debug_unit
logical, parameter :: do_timings=.true.
integer(psb_ipk_), save :: mv_phase1=-1, mv_phase2=-1, mv_phase3=-1, mv_phase4=-1
integer(psb_ipk_), save :: mv_phase11=-1, mv_phase12=-1
name='psb_sspmv' name='psb_sspmv'
info=psb_success_ info=psb_success_
@ -130,6 +133,19 @@ subroutine psb_sspmv_vect(alpha,a,x,beta,y,desc_a,info,&
call psb_errpush(info,name) call psb_errpush(info,name)
goto 9999 goto 9999
end if end if
if ((do_timings).and.(mv_phase1==-1)) &
& mv_phase1 = psb_get_timer_idx("SPMM: and send ")
if ((do_timings).and.(mv_phase2==-1)) &
& mv_phase2 = psb_get_timer_idx("SPMM: and cmp ad")
if ((do_timings).and.(mv_phase3==-1)) &
& mv_phase3 = psb_get_timer_idx("SPMM: and rcv")
if ((do_timings).and.(mv_phase4==-1)) &
& mv_phase4 = psb_get_timer_idx("SPMM: and cmp and")
if ((do_timings).and.(mv_phase11==-1)) &
& mv_phase11 = psb_get_timer_idx("SPMM: noand exch ")
if ((do_timings).and.(mv_phase12==-1)) &
& mv_phase12 = psb_get_timer_idx("SPMM: noand cmp")
m = desc_a%get_global_rows() m = desc_a%get_global_rows()
n = desc_a%get_global_cols() n = desc_a%get_global_cols()
@ -178,34 +194,44 @@ subroutine psb_sspmv_vect(alpha,a,x,beta,y,desc_a,info,&
if (trans_ == 'N') then if (trans_ == 'N') then
! Matrix is not transposed ! Matrix is not transposed
if (allocated(a%ad)) then if (allocated(a%ad)) then
block block
logical, parameter :: do_timings=.true. logical, parameter :: do_timings=.true.
real(psb_dpk_) :: t1, t2, t3, t4, t5 real(psb_dpk_) :: t1, t2, t3, t4, t5
if (do_timings) call psb_barrier(ctxt) !if (me==0) write(0,*) 'going for overlap ',a%ad%get_fmt(),' ',a%and%get_fmt()
if (do_timings) t1= psb_wtime() if (do_timings) call psb_barrier(ctxt)
if (doswap_) call psi_swapdata(psb_swap_send_,& if (do_timings) call psb_tic(mv_phase1)
& szero,x%v,desc_a,iwork,info,data=psb_comm_halo_) if (doswap_) call psi_swapdata(psb_swap_send_,&
if (do_timings) t2= psb_wtime()
call a%ad%spmm(alpha,x%v,beta,y%v,info)
if (do_timings) t3= psb_wtime()
if (doswap_) call psi_swapdata(psb_swap_recv_,&
& szero,x%v,desc_a,iwork,info,data=psb_comm_halo_)
if (do_timings) t4= psb_wtime()
call a%and%spmm(alpha,x%v,sone,y%v,info)
if (do_timings) t5= psb_wtime()
if (do_timings) write(0,*) me,' SPMM:',t2-t1,t3-t2,t4-t3,t5-t4
end block
else
if (doswap_) then
call psi_swapdata(ior(psb_swap_send_,psb_swap_recv_),&
& szero,x%v,desc_a,iwork,info,data=psb_comm_halo_) & szero,x%v,desc_a,iwork,info,data=psb_comm_halo_)
end if if (do_timings) call psb_toc(mv_phase1)
if (do_timings) call psb_tic(mv_phase2)
call psb_csmm(alpha,a,x,beta,y,info) call a%ad%spmm(alpha,x%v,beta,y%v,info)
if (do_timings) call psb_tic(mv_phase3)
if (doswap_) call psi_swapdata(psb_swap_recv_,&
& szero,x%v,desc_a,iwork,info,data=psb_comm_halo_)
if (do_timings) call psb_toc(mv_phase3)
if (do_timings) call psb_tic(mv_phase4)
call a%and%spmm(alpha,x%v,sone,y%v,info)
if (do_timings) call psb_toc(mv_phase4)
end block
else
block
logical, parameter :: do_timings=.true.
real(psb_dpk_) :: t1, t2, t3, t4, t5
if (do_timings) call psb_barrier(ctxt)
if (do_timings) call psb_tic(mv_phase11)
if (doswap_) then
call psi_swapdata(ior(psb_swap_send_,psb_swap_recv_),&
& szero,x%v,desc_a,iwork,info,data=psb_comm_halo_)
end if
if (do_timings) call psb_toc(mv_phase11)
if (do_timings) call psb_tic(mv_phase12)
call psb_csmm(alpha,a,x,beta,y,info)
if (do_timings) call psb_toc(mv_phase12)
end block
end if end if
if(info /= psb_success_) then if(info /= psb_success_) then

74
base/psblas/psb_zspmm.f90
Unescape Escape View File

@ -83,6 +83,9 @@ subroutine psb_zspmv_vect(alpha,a,x,beta,y,desc_a,info,&
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
logical :: aliw, doswap_ logical :: aliw, doswap_
integer(psb_ipk_) :: debug_level, debug_unit integer(psb_ipk_) :: debug_level, debug_unit
logical, parameter :: do_timings=.true.
integer(psb_ipk_), save :: mv_phase1=-1, mv_phase2=-1, mv_phase3=-1, mv_phase4=-1
integer(psb_ipk_), save :: mv_phase11=-1, mv_phase12=-1
name='psb_zspmv' name='psb_zspmv'
info=psb_success_ info=psb_success_
@ -130,6 +133,19 @@ subroutine psb_zspmv_vect(alpha,a,x,beta,y,desc_a,info,&
call psb_errpush(info,name) call psb_errpush(info,name)
goto 9999 goto 9999
end if end if
if ((do_timings).and.(mv_phase1==-1)) &
& mv_phase1 = psb_get_timer_idx("SPMM: and send ")
if ((do_timings).and.(mv_phase2==-1)) &
& mv_phase2 = psb_get_timer_idx("SPMM: and cmp ad")
if ((do_timings).and.(mv_phase3==-1)) &
& mv_phase3 = psb_get_timer_idx("SPMM: and rcv")
if ((do_timings).and.(mv_phase4==-1)) &
& mv_phase4 = psb_get_timer_idx("SPMM: and cmp and")
if ((do_timings).and.(mv_phase11==-1)) &
& mv_phase11 = psb_get_timer_idx("SPMM: noand exch ")
if ((do_timings).and.(mv_phase12==-1)) &
& mv_phase12 = psb_get_timer_idx("SPMM: noand cmp")
m = desc_a%get_global_rows() m = desc_a%get_global_rows()
n = desc_a%get_global_cols() n = desc_a%get_global_cols()
@ -178,34 +194,44 @@ subroutine psb_zspmv_vect(alpha,a,x,beta,y,desc_a,info,&
if (trans_ == 'N') then if (trans_ == 'N') then
! Matrix is not transposed ! Matrix is not transposed
if (allocated(a%ad)) then if (allocated(a%ad)) then
block block
logical, parameter :: do_timings=.true. logical, parameter :: do_timings=.true.
real(psb_dpk_) :: t1, t2, t3, t4, t5 real(psb_dpk_) :: t1, t2, t3, t4, t5
if (do_timings) call psb_barrier(ctxt) !if (me==0) write(0,*) 'going for overlap ',a%ad%get_fmt(),' ',a%and%get_fmt()
if (do_timings) t1= psb_wtime() if (do_timings) call psb_barrier(ctxt)
if (doswap_) call psi_swapdata(psb_swap_send_,& if (do_timings) call psb_tic(mv_phase1)
& zzero,x%v,desc_a,iwork,info,data=psb_comm_halo_) if (doswap_) call psi_swapdata(psb_swap_send_,&
if (do_timings) t2= psb_wtime()
call a%ad%spmm(alpha,x%v,beta,y%v,info)
if (do_timings) t3= psb_wtime()
if (doswap_) call psi_swapdata(psb_swap_recv_,&
& zzero,x%v,desc_a,iwork,info,data=psb_comm_halo_)
if (do_timings) t4= psb_wtime()
call a%and%spmm(alpha,x%v,zone,y%v,info)
if (do_timings) t5= psb_wtime()
if (do_timings) write(0,*) me,' SPMM:',t2-t1,t3-t2,t4-t3,t5-t4
end block
else
if (doswap_) then
call psi_swapdata(ior(psb_swap_send_,psb_swap_recv_),&
& zzero,x%v,desc_a,iwork,info,data=psb_comm_halo_) & zzero,x%v,desc_a,iwork,info,data=psb_comm_halo_)
end if if (do_timings) call psb_toc(mv_phase1)
if (do_timings) call psb_tic(mv_phase2)
call psb_csmm(alpha,a,x,beta,y,info) call a%ad%spmm(alpha,x%v,beta,y%v,info)
if (do_timings) call psb_tic(mv_phase3)
if (doswap_) call psi_swapdata(psb_swap_recv_,&
& zzero,x%v,desc_a,iwork,info,data=psb_comm_halo_)
if (do_timings) call psb_toc(mv_phase3)
if (do_timings) call psb_tic(mv_phase4)
call a%and%spmm(alpha,x%v,zone,y%v,info)
if (do_timings) call psb_toc(mv_phase4)
end block
else
block
logical, parameter :: do_timings=.true.
real(psb_dpk_) :: t1, t2, t3, t4, t5
if (do_timings) call psb_barrier(ctxt)
if (do_timings) call psb_tic(mv_phase11)
if (doswap_) then
call psi_swapdata(ior(psb_swap_send_,psb_swap_recv_),&
& zzero,x%v,desc_a,iwork,info,data=psb_comm_halo_)
end if
if (do_timings) call psb_toc(mv_phase11)
if (do_timings) call psb_tic(mv_phase12)
call psb_csmm(alpha,a,x,beta,y,info)
if (do_timings) call psb_toc(mv_phase12)
end block
end if end if
if(info /= psb_success_) then if(info /= psb_success_) then

356
base/serial/impl/psb_c_mat_impl.F90
Unescape Escape View File

@ -1213,6 +1213,56 @@ subroutine psb_c_b_csclip(a,b,info,&
end subroutine psb_c_b_csclip end subroutine psb_c_b_csclip
subroutine psb_c_split_nd(a,n_rows,n_cols,info)
use psb_error_mod
use psb_string_mod
use psb_c_mat_mod, psb_protect_name => psb_c_split_nd
implicit none
class(psb_cspmat_type), intent(inout) :: a
integer(psb_ipk_), intent(in) :: n_rows, n_cols
integer(psb_ipk_), intent(out) :: info
!!$ integer(psb_ipk_),optional, intent(in) :: dupl
!!$ character(len=*), optional, intent(in) :: type
!!$ class(psb_c_base_sparse_mat), intent(in), optional :: mold
type(psb_c_coo_sparse_mat) :: acoo
type(psb_c_csr_sparse_mat), allocatable :: aclip
type(psb_c_ecsr_sparse_mat), allocatable :: andclip
logical, parameter :: use_ecsr=.true.
character(len=20) :: name, ch_err
integer(psb_ipk_) :: err_act
info = psb_success_
name = 'psb_split'
call psb_erractionsave(err_act)
allocate(aclip)
call a%a%csclip(acoo,info,jmax=n_rows,rscale=.false.,cscale=.false.)
allocate(a%ad,mold=a%a)
call a%ad%mv_from_coo(acoo,info)
call a%a%csclip(acoo,info,jmin=n_rows+1,jmax=n_cols,rscale=.false.,cscale=.false.)
if (use_ecsr) then
allocate(andclip)
call andclip%mv_from_coo(acoo,info)
call move_alloc(andclip,a%and)
else
allocate(a%and,mold=a%a)
call a%and%mv_from_coo(acoo,info)
end if
if (psb_errstatus_fatal()) then
info=psb_err_from_subroutine_
call psb_errpush(info,name,a_err='cscnv')
goto 9999
endif
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(err_act)
return
end subroutine psb_c_split_nd
subroutine psb_c_cscnv(a,b,info,type,mold,upd,dupl) subroutine psb_c_cscnv(a,b,info,type,mold,upd,dupl)
use psb_error_mod use psb_error_mod
use psb_string_mod use psb_string_mod
@ -1246,54 +1296,65 @@ subroutine psb_c_cscnv(a,b,info,type,mold,upd,dupl)
goto 9999 goto 9999
end if end if
if (present(mold)) then if (.false.) then
if (present(mold)) then
allocate(altmp, mold=mold,stat=info)
allocate(altmp, mold=mold,stat=info)
else if (present(type)) then
else if (present(type)) then
select case (psb_toupper(type))
case ('CSR')
allocate(psb_c_csr_sparse_mat :: altmp, stat=info)
case ('COO')
allocate(psb_c_coo_sparse_mat :: altmp, stat=info)
case ('CSC')
allocate(psb_c_csc_sparse_mat :: altmp, stat=info)
case default
info = psb_err_format_unknown_
call psb_errpush(info,name,a_err=type)
goto 9999
end select
else
allocate(altmp, mold=psb_get_mat_default(a),stat=info)
end if
select case (psb_toupper(type)) if (info /= psb_success_) then
case ('CSR') info = psb_err_alloc_dealloc_
allocate(psb_c_csr_sparse_mat :: altmp, stat=info) call psb_errpush(info,name)
case ('COO')
allocate(psb_c_coo_sparse_mat :: altmp, stat=info)
case ('CSC')
allocate(psb_c_csc_sparse_mat :: altmp, stat=info)
case default
info = psb_err_format_unknown_
call psb_errpush(info,name,a_err=type)
goto 9999 goto 9999
end select end if
else
allocate(altmp, mold=psb_get_mat_default(a),stat=info)
end if
if (info /= psb_success_) then
info = psb_err_alloc_dealloc_
call psb_errpush(info,name)
goto 9999
end if
if (present(dupl)) then
call altmp%set_dupl(dupl)
else if (a%is_bld()) then
! Does this make sense at all?? Who knows..
call altmp%set_dupl(psb_dupl_def_)
end if
if (present(dupl)) then if (debug) write(psb_err_unit,*) 'Converting from ',&
call altmp%set_dupl(dupl) & a%get_fmt(),' to ',altmp%get_fmt()
else if (a%is_bld()) then
! Does this make sense at all?? Who knows..
call altmp%set_dupl(psb_dupl_def_)
end if
if (debug) write(psb_err_unit,*) 'Converting from ',& call altmp%cp_from_fmt(a%a, info)
& a%get_fmt(),' to ',altmp%get_fmt()
call altmp%cp_from_fmt(a%a, info) if (info /= psb_success_) then
info = psb_err_from_subroutine_
call psb_errpush(info,name,a_err="mv_from")
goto 9999
end if
if (info /= psb_success_) then call move_alloc(altmp,b%a)
info = psb_err_from_subroutine_ else
call psb_errpush(info,name,a_err="mv_from") call inner_cp_fmt(a%a,b%a,info,type,mold,dupl)
goto 9999 if (allocated(a%ad)) then
call inner_cp_fmt(a%ad,b%ad,info,type,mold,dupl)
end if
if (allocated(a%and)) then
call inner_cp_fmt(a%and,b%and,info,type,mold,dupl)
end if
end if end if
call move_alloc(altmp,b%a)
call b%trim() call b%trim()
call b%set_asb() call b%set_asb()
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
@ -1303,7 +1364,79 @@ subroutine psb_c_cscnv(a,b,info,type,mold,upd,dupl)
9999 call psb_error_handler(err_act) 9999 call psb_error_handler(err_act)
return return
contains
subroutine inner_cp_fmt(a,b,info,type,mold,dupl)
class(psb_c_base_sparse_mat), intent(in) :: a
class(psb_c_base_sparse_mat), intent(inout), allocatable :: b
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_),optional, intent(in) :: dupl
character(len=*), optional, intent(in) :: type
class(psb_c_base_sparse_mat), intent(in), optional :: mold
class(psb_c_base_sparse_mat), allocatable :: altmp
integer(psb_ipk_) :: err_act
info = psb_success_
call psb_erractionsave(err_act)
if (present(mold)) then
allocate(altmp, mold=mold,stat=info)
else if (present(type)) then
select case (psb_toupper(type))
case ('CSR')
allocate(psb_c_csr_sparse_mat :: altmp, stat=info)
case ('COO')
allocate(psb_c_coo_sparse_mat :: altmp, stat=info)
case ('CSC')
allocate(psb_c_csc_sparse_mat :: altmp, stat=info)
case default
info = psb_err_format_unknown_
call psb_errpush(info,name,a_err=type)
goto 9999
end select
else
allocate(psb_c_csr_sparse_mat :: altmp, stat=info)
!allocate(altmp, mold=psb_get_mat_default(a),stat=info)
end if
if (info /= psb_success_) then
info = psb_err_alloc_dealloc_
call psb_errpush(info,name)
goto 9999
end if
if (present(dupl)) then
call altmp%set_dupl(dupl)
else if (a%is_bld()) then
! Does this make sense at all?? Who knows..
call altmp%set_dupl(psb_dupl_def_)
end if
if (debug) write(psb_err_unit,*) 'Converting from ',&
& a%get_fmt(),' to ',altmp%get_fmt()
call altmp%cp_from_fmt(a, info)
if (info /= psb_success_) then
info = psb_err_from_subroutine_
call psb_errpush(info,name,a_err="mv_from")
goto 9999
end if
call move_alloc(altmp,b)
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(err_act)
return
end subroutine inner_cp_fmt
end subroutine psb_c_cscnv end subroutine psb_c_cscnv
subroutine psb_c_cscnv_ip(a,info,type,mold,dupl) subroutine psb_c_cscnv_ip(a,info,type,mold,dupl)
@ -1312,13 +1445,12 @@ subroutine psb_c_cscnv_ip(a,info,type,mold,dupl)
use psb_c_mat_mod, psb_protect_name => psb_c_cscnv_ip use psb_c_mat_mod, psb_protect_name => psb_c_cscnv_ip
implicit none implicit none
class(psb_cspmat_type), intent(inout) :: a class(psb_cspmat_type), intent(inout) :: a
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_),optional, intent(in) :: dupl integer(psb_ipk_),optional, intent(in) :: dupl
character(len=*), optional, intent(in) :: type character(len=*), optional, intent(in) :: type
class(psb_c_base_sparse_mat), intent(in), optional :: mold class(psb_c_base_sparse_mat), intent(in), optional :: mold
class(psb_c_base_sparse_mat), allocatable :: altmp class(psb_c_base_sparse_mat), allocatable :: altmp
integer(psb_ipk_) :: err_act integer(psb_ipk_) :: err_act
character(len=20) :: name='cscnv_ip' character(len=20) :: name='cscnv_ip'
@ -1345,46 +1477,55 @@ subroutine psb_c_cscnv_ip(a,info,type,mold,dupl)
goto 9999 goto 9999
end if end if
if (present(mold)) then if (.false.) then
if (present(mold)) then
allocate(altmp, mold=mold,stat=info)
else if (present(type)) then
select case (psb_toupper(type))
case ('CSR')
allocate(psb_c_csr_sparse_mat :: altmp, stat=info)
case ('COO')
allocate(psb_c_coo_sparse_mat :: altmp, stat=info)
case ('CSC')
allocate(psb_c_csc_sparse_mat :: altmp, stat=info)
case default
info = psb_err_format_unknown_
call psb_errpush(info,name,a_err=type)
goto 9999
end select
else
allocate(altmp, mold=psb_get_mat_default(a),stat=info)
end if
allocate(altmp, mold=mold,stat=info) if (info /= psb_success_) then
info = psb_err_alloc_dealloc_
call psb_errpush(info,name)
goto 9999
end if
else if (present(type)) then if (debug) write(psb_err_unit,*) 'Converting in-place from ',&
& a%get_fmt(),' to ',altmp%get_fmt()
select case (psb_toupper(type)) call altmp%mv_from_fmt(a%a, info)
case ('CSR') call move_alloc(altmp,a%a)
allocate(psb_c_csr_sparse_mat :: altmp, stat=info)
case ('COO')
allocate(psb_c_coo_sparse_mat :: altmp, stat=info)
case ('CSC')
allocate(psb_c_csc_sparse_mat :: altmp, stat=info)
case default
info = psb_err_format_unknown_
call psb_errpush(info,name,a_err=type)
goto 9999
end select
else else
allocate(altmp, mold=psb_get_mat_default(a),stat=info) call inner_mv_fmt(a%a,info,type,mold,dupl)
if (allocated(a%ad)) then
call inner_mv_fmt(a%ad,info,type,mold,dupl)
end if
if (allocated(a%and)) then
call inner_mv_fmt(a%and,info,type,mold,dupl)
end if
end if end if
if (info /= psb_success_) then
info = psb_err_alloc_dealloc_
call psb_errpush(info,name)
goto 9999
end if
if (debug) write(psb_err_unit,*) 'Converting in-place from ',&
& a%get_fmt(),' to ',altmp%get_fmt()
call altmp%mv_from_fmt(a%a, info)
if (info /= psb_success_) then if (info /= psb_success_) then
info = psb_err_from_subroutine_ info = psb_err_from_subroutine_
call psb_errpush(info,name,a_err="mv_from") call psb_errpush(info,name,a_err="mv_from")
goto 9999 goto 9999
end if end if
call move_alloc(altmp,a%a)
call a%trim() call a%trim()
call a%set_asb() call a%set_asb()
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
@ -1394,6 +1535,77 @@ subroutine psb_c_cscnv_ip(a,info,type,mold,dupl)
9999 call psb_error_handler(err_act) 9999 call psb_error_handler(err_act)
return return
contains
subroutine inner_mv_fmt(a,info,type,mold,dupl)
class(psb_c_base_sparse_mat), intent(inout), allocatable :: a
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_),optional, intent(in) :: dupl
character(len=*), optional, intent(in) :: type
class(psb_c_base_sparse_mat), intent(in), optional :: mold
class(psb_c_base_sparse_mat), allocatable :: altmp
integer(psb_ipk_) :: err_act
info = psb_success_
call psb_erractionsave(err_act)
if (present(mold)) then
allocate(altmp, mold=mold,stat=info)
else if (present(type)) then
select case (psb_toupper(type))
case ('CSR')
allocate(psb_c_csr_sparse_mat :: altmp, stat=info)
case ('COO')
allocate(psb_c_coo_sparse_mat :: altmp, stat=info)
case ('CSC')
allocate(psb_c_csc_sparse_mat :: altmp, stat=info)
case default
info = psb_err_format_unknown_
call psb_errpush(info,name,a_err=type)
goto 9999
end select
else
allocate(psb_c_csr_sparse_mat :: altmp, stat=info)
!allocate(altmp, mold=psb_get_mat_default(a),stat=info)
end if
if (info /= psb_success_) then
info = psb_err_alloc_dealloc_
call psb_errpush(info,name)
goto 9999
end if
if (present(dupl)) then
call altmp%set_dupl(dupl)
else if (a%is_bld()) then
! Does this make sense at all?? Who knows..
call altmp%set_dupl(psb_dupl_def_)
end if
if (debug) write(psb_err_unit,*) 'Converting from ',&
& a%get_fmt(),' to ',altmp%get_fmt()
call altmp%mv_from_fmt(a, info)
if (info /= psb_success_) then
info = psb_err_from_subroutine_
call psb_errpush(info,name,a_err="mv_from")
goto 9999
end if
call move_alloc(altmp,a)
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(err_act)
return
end subroutine inner_mv_fmt
end subroutine psb_c_cscnv_ip end subroutine psb_c_cscnv_ip

369
base/serial/impl/psb_d_mat_impl.F90
Unescape Escape View File

@ -1213,6 +1213,56 @@ subroutine psb_d_b_csclip(a,b,info,&
end subroutine psb_d_b_csclip end subroutine psb_d_b_csclip
subroutine psb_d_split_nd(a,n_rows,n_cols,info)
use psb_error_mod
use psb_string_mod
use psb_d_mat_mod, psb_protect_name => psb_d_split_nd
implicit none
class(psb_dspmat_type), intent(inout) :: a
integer(psb_ipk_), intent(in) :: n_rows, n_cols
integer(psb_ipk_), intent(out) :: info
!!$ integer(psb_ipk_),optional, intent(in) :: dupl
!!$ character(len=*), optional, intent(in) :: type
!!$ class(psb_d_base_sparse_mat), intent(in), optional :: mold
type(psb_d_coo_sparse_mat) :: acoo
type(psb_d_csr_sparse_mat), allocatable :: aclip
type(psb_d_ecsr_sparse_mat), allocatable :: andclip
logical, parameter :: use_ecsr=.true.
character(len=20) :: name, ch_err
integer(psb_ipk_) :: err_act
info = psb_success_
name = 'psb_split'
call psb_erractionsave(err_act)
allocate(aclip)
call a%a%csclip(acoo,info,jmax=n_rows,rscale=.false.,cscale=.false.)
allocate(a%ad,mold=a%a)
call a%ad%mv_from_coo(acoo,info)
call a%a%csclip(acoo,info,jmin=n_rows+1,jmax=n_cols,rscale=.false.,cscale=.false.)
if (use_ecsr) then
allocate(andclip)
call andclip%mv_from_coo(acoo,info)
call move_alloc(andclip,a%and)
else
allocate(a%and,mold=a%a)
call a%and%mv_from_coo(acoo,info)
end if
if (psb_errstatus_fatal()) then
info=psb_err_from_subroutine_
call psb_errpush(info,name,a_err='cscnv')
goto 9999
endif
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(err_act)
return
end subroutine psb_d_split_nd
subroutine psb_d_cscnv(a,b,info,type,mold,upd,dupl) subroutine psb_d_cscnv(a,b,info,type,mold,upd,dupl)
use psb_error_mod use psb_error_mod
use psb_string_mod use psb_string_mod
@ -1246,65 +1296,64 @@ subroutine psb_d_cscnv(a,b,info,type,mold,upd,dupl)
goto 9999 goto 9999
end if end if
!!$ if (present(mold)) then if (.false.) then
!!$ if (present(mold)) then
!!$ allocate(altmp, mold=mold,stat=info)
!!$
!!$ else if (present(type)) then
!!$
!!$ select case (psb_toupper(type))
!!$ case ('CSR')
!!$ allocate(psb_d_csr_sparse_mat :: altmp, stat=info)
!!$ case ('COO')
!!$ allocate(psb_d_coo_sparse_mat :: altmp, stat=info)
!!$ case ('CSC')
!!$ allocate(psb_d_csc_sparse_mat :: altmp, stat=info)
!!$ case default
!!$ info = psb_err_format_unknown_
!!$ call psb_errpush(info,name,a_err=type)
!!$ goto 9999
!!$ end select
!!$ else
!!$ allocate(altmp, mold=psb_get_mat_default(a),stat=info)
!!$ end if
!!$
!!$ if (info /= psb_success_) then
!!$ info = psb_err_alloc_dealloc_
!!$ call psb_errpush(info,name)
!!$ goto 9999
!!$ end if
!!$
!!$
!!$ if (present(dupl)) then
!!$ call altmp%set_dupl(dupl)
!!$ else if (a%is_bld()) then
!!$ ! Does this make sense at all?? Who knows..
!!$ call altmp%set_dupl(psb_dupl_def_)
!!$ end if
!!$
!!$ if (debug) write(psb_err_unit,*) 'Converting from ',&
!!$ & a%get_fmt(),' to ',altmp%get_fmt()
!!$
!!$ call altmp%cp_from_fmt(a%a, info)
!!$
!!$ if (info /= psb_success_) then
!!$ info = psb_err_from_subroutine_
!!$ call psb_errpush(info,name,a_err="mv_from")
!!$ goto 9999
!!$ end if
!!$
!!$ call move_alloc(altmp,b%a)
call inner_cp_alloc(a%a,b%a,info,type,mold)
if (info /= 0) goto 9999
if (allocated(a%ad)) then
call inner_cp_alloc(a%ad,b%ad,info,type,mold)
if (info /= 0) goto 9999
end if
if (allocated(a%and)) then
call inner_cp_alloc(a%and,b%and,info,type,mold)
if (info /= 0) goto 9999
end if
allocate(altmp, mold=mold,stat=info)
else if (present(type)) then
select case (psb_toupper(type))
case ('CSR')
allocate(psb_d_csr_sparse_mat :: altmp, stat=info)
case ('COO')
allocate(psb_d_coo_sparse_mat :: altmp, stat=info)
case ('CSC')
allocate(psb_d_csc_sparse_mat :: altmp, stat=info)
case default
info = psb_err_format_unknown_
call psb_errpush(info,name,a_err=type)
goto 9999
end select
else
allocate(altmp, mold=psb_get_mat_default(a),stat=info)
end if
if (info /= psb_success_) then
info = psb_err_alloc_dealloc_
call psb_errpush(info,name)
goto 9999
end if
if (present(dupl)) then
call altmp%set_dupl(dupl)
else if (a%is_bld()) then
! Does this make sense at all?? Who knows..
call altmp%set_dupl(psb_dupl_def_)
end if
if (debug) write(psb_err_unit,*) 'Converting from ',&
& a%get_fmt(),' to ',altmp%get_fmt()
call altmp%cp_from_fmt(a%a, info)
if (info /= psb_success_) then
info = psb_err_from_subroutine_
call psb_errpush(info,name,a_err="mv_from")
goto 9999
end if
call move_alloc(altmp,b%a)
else
call inner_cp_fmt(a%a,b%a,info,type,mold,dupl)
if (allocated(a%ad)) then
call inner_cp_fmt(a%ad,b%ad,info,type,mold,dupl)
end if
if (allocated(a%and)) then
call inner_cp_fmt(a%and,b%and,info,type,mold,dupl)
end if
end if
call b%trim() call b%trim()
call b%set_asb() call b%set_asb()
@ -1316,24 +1365,26 @@ subroutine psb_d_cscnv(a,b,info,type,mold,upd,dupl)
return return
contains contains
subroutine inner_cp_alloc(a,b,info,type,mold) subroutine inner_cp_fmt(a,b,info,type,mold,dupl)
class(psb_d_base_sparse_mat), intent(in) :: a class(psb_d_base_sparse_mat), intent(in) :: a
class(psb_d_base_sparse_mat), intent(inout), allocatable :: b class(psb_d_base_sparse_mat), intent(inout), allocatable :: b
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_),optional, intent(in) :: dupl
character(len=*), optional, intent(in) :: type character(len=*), optional, intent(in) :: type
class(psb_d_base_sparse_mat), intent(in), optional :: mold class(psb_d_base_sparse_mat), intent(in), optional :: mold
class(psb_d_base_sparse_mat), allocatable :: altmp class(psb_d_base_sparse_mat), allocatable :: altmp
integer(psb_ipk_) :: err_act
info = psb_success_ info = psb_success_
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
if (present(mold)) then if (present(mold)) then
allocate(altmp, mold=mold,stat=info) allocate(altmp, mold=mold,stat=info)
else if (present(type)) then else if (present(type)) then
select case (psb_toupper(type)) select case (psb_toupper(type))
case ('CSR') case ('CSR')
allocate(psb_d_csr_sparse_mat :: altmp, stat=info) allocate(psb_d_csr_sparse_mat :: altmp, stat=info)
@ -1347,38 +1398,45 @@ contains
goto 9999 goto 9999
end select end select
else else
!!$ allocate(altmp, mold=psb_get_mat_default(a),stat=info)
allocate(psb_d_csr_sparse_mat :: altmp, stat=info) allocate(psb_d_csr_sparse_mat :: altmp, stat=info)
!allocate(altmp, mold=psb_get_mat_default(a),stat=info)
end if end if
if (info /= psb_success_) then if (info /= psb_success_) then
info = psb_err_alloc_dealloc_ info = psb_err_alloc_dealloc_
call psb_errpush(info,name) call psb_errpush(info,name)
goto 9999 goto 9999
end if end if
if (debug) write(psb_err_unit,*) 'Converting in-place from ',&
if (present(dupl)) then
call altmp%set_dupl(dupl)
else if (a%is_bld()) then
! Does this make sense at all?? Who knows..
call altmp%set_dupl(psb_dupl_def_)
end if
if (debug) write(psb_err_unit,*) 'Converting from ',&
& a%get_fmt(),' to ',altmp%get_fmt() & a%get_fmt(),' to ',altmp%get_fmt()
call altmp%cp_from_fmt(a, info) call altmp%cp_from_fmt(a, info)
if (info /= psb_success_) then if (info /= psb_success_) then
info = psb_err_from_subroutine_ info = psb_err_from_subroutine_
call psb_errpush(info,name,a_err="mv_from") call psb_errpush(info,name,a_err="mv_from")
goto 9999 goto 9999
end if end if
call move_alloc(altmp,b) call move_alloc(altmp,b)
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
return return
9999 call psb_error_handler(err_act) 9999 call psb_error_handler(err_act)
return
end subroutine inner_cp_alloc
return
end subroutine inner_cp_fmt
end subroutine psb_d_cscnv end subroutine psb_d_cscnv
subroutine psb_d_cscnv_ip(a,info,type,mold,dupl) subroutine psb_d_cscnv_ip(a,info,type,mold,dupl)
@ -1387,13 +1445,12 @@ subroutine psb_d_cscnv_ip(a,info,type,mold,dupl)
use psb_d_mat_mod, psb_protect_name => psb_d_cscnv_ip use psb_d_mat_mod, psb_protect_name => psb_d_cscnv_ip
implicit none implicit none
class(psb_dspmat_type), intent(inout) :: a class(psb_dspmat_type), intent(inout) :: a
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_),optional, intent(in) :: dupl integer(psb_ipk_),optional, intent(in) :: dupl
character(len=*), optional, intent(in) :: type character(len=*), optional, intent(in) :: type
class(psb_d_base_sparse_mat), intent(in), optional :: mold class(psb_d_base_sparse_mat), intent(in), optional :: mold
class(psb_d_base_sparse_mat), allocatable :: altmp class(psb_d_base_sparse_mat), allocatable :: altmp
integer(psb_ipk_) :: err_act integer(psb_ipk_) :: err_act
character(len=20) :: name='cscnv_ip' character(len=20) :: name='cscnv_ip'
@ -1420,57 +1477,55 @@ subroutine psb_d_cscnv_ip(a,info,type,mold,dupl)
goto 9999 goto 9999
end if end if
!!$ if (present(mold)) then if (.false.) then
!!$ if (present(mold)) then
!!$ allocate(altmp, mold=mold,stat=info)
!!$ allocate(altmp, mold=mold,stat=info)
!!$ else if (present(type)) then
!!$ else if (present(type)) then
!!$ select case (psb_toupper(type))
!!$ case ('CSR') select case (psb_toupper(type))
!!$ allocate(psb_d_csr_sparse_mat :: altmp, stat=info) case ('CSR')
!!$ case ('COO') allocate(psb_d_csr_sparse_mat :: altmp, stat=info)
!!$ allocate(psb_d_coo_sparse_mat :: altmp, stat=info) case ('COO')
!!$ case ('CSC') allocate(psb_d_coo_sparse_mat :: altmp, stat=info)
!!$ allocate(psb_d_csc_sparse_mat :: altmp, stat=info) case ('CSC')
!!$ case default allocate(psb_d_csc_sparse_mat :: altmp, stat=info)
!!$ info = psb_err_format_unknown_ case default
!!$ call psb_errpush(info,name,a_err=type) info = psb_err_format_unknown_
!!$ goto 9999 call psb_errpush(info,name,a_err=type)
!!$ end select goto 9999
!!$ else end select
!!$ allocate(altmp, mold=psb_get_mat_default(a),stat=info) else
!!$ end if allocate(altmp, mold=psb_get_mat_default(a),stat=info)
!!$ end if
!!$ if (info /= psb_success_) then
!!$ info = psb_err_alloc_dealloc_ if (info /= psb_success_) then
!!$ call psb_errpush(info,name) info = psb_err_alloc_dealloc_
!!$ goto 9999 call psb_errpush(info,name)
!!$ end if goto 9999
!!$ end if
!!$ if (debug) write(psb_err_unit,*) 'Converting in-place from ',&
!!$ & a%get_fmt(),' to ',altmp%get_fmt() if (debug) write(psb_err_unit,*) 'Converting in-place from ',&
!!$ & a%get_fmt(),' to ',altmp%get_fmt()
!!$ call altmp%mv_from_fmt(a%a, info)
!!$ call altmp%mv_from_fmt(a%a, info)
!!$ if (info /= psb_success_) then call move_alloc(altmp,a%a)
!!$ info = psb_err_from_subroutine_ else
!!$ call psb_errpush(info,name,a_err="mv_from") call inner_mv_fmt(a%a,info,type,mold,dupl)
!!$ goto 9999 if (allocated(a%ad)) then
!!$ end if call inner_mv_fmt(a%ad,info,type,mold,dupl)
!!$ end if
!!$ call move_alloc(altmp,a%a) if (allocated(a%and)) then
call inner_mv_fmt(a%and,info,type,mold,dupl)
call inner_mv_alloc(a%a,info,type,mold) end if
if (info /= 0) goto 9999
if (allocated(a%ad)) then
call inner_mv_alloc(a%ad,info,type,mold)
if (info /= 0) goto 9999
end if end if
if (allocated(a%and)) then if (info /= psb_success_) then
call inner_mv_alloc(a%and,info,type,mold) info = psb_err_from_subroutine_
if (info /= 0) goto 9999 call psb_errpush(info,name,a_err="mv_from")
goto 9999
end if end if
call a%trim() call a%trim()
call a%set_asb() call a%set_asb()
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
@ -1481,23 +1536,24 @@ subroutine psb_d_cscnv_ip(a,info,type,mold,dupl)
return return
contains contains
subroutine inner_mv_alloc(a,info,type,mold) subroutine inner_mv_fmt(a,info,type,mold,dupl)
class(psb_d_base_sparse_mat), intent(inout), allocatable :: a class(psb_d_base_sparse_mat), intent(inout), allocatable :: a
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_),optional, intent(in) :: dupl
character(len=*), optional, intent(in) :: type character(len=*), optional, intent(in) :: type
class(psb_d_base_sparse_mat), intent(in), optional :: mold class(psb_d_base_sparse_mat), intent(in), optional :: mold
class(psb_d_base_sparse_mat), allocatable :: altmp class(psb_d_base_sparse_mat), allocatable :: altmp
integer(psb_ipk_) :: err_act
info = psb_success_ info = psb_success_
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
if (present(mold)) then if (present(mold)) then
allocate(altmp, mold=mold,stat=info) allocate(altmp, mold=mold,stat=info)
else if (present(type)) then else if (present(type)) then
select case (psb_toupper(type)) select case (psb_toupper(type))
case ('CSR') case ('CSR')
allocate(psb_d_csr_sparse_mat :: altmp, stat=info) allocate(psb_d_csr_sparse_mat :: altmp, stat=info)
@ -1511,37 +1567,46 @@ contains
goto 9999 goto 9999
end select end select
else else
!!$ allocate(altmp, mold=psb_get_mat_default(a),stat=info)
allocate(psb_d_csr_sparse_mat :: altmp, stat=info) allocate(psb_d_csr_sparse_mat :: altmp, stat=info)
!allocate(altmp, mold=psb_get_mat_default(a),stat=info)
end if end if
if (info /= psb_success_) then if (info /= psb_success_) then
info = psb_err_alloc_dealloc_ info = psb_err_alloc_dealloc_
call psb_errpush(info,name) call psb_errpush(info,name)
goto 9999 goto 9999
end if end if
if (debug) write(psb_err_unit,*) 'Converting in-place from ',&
if (present(dupl)) then
call altmp%set_dupl(dupl)
else if (a%is_bld()) then
! Does this make sense at all?? Who knows..
call altmp%set_dupl(psb_dupl_def_)
end if
if (debug) write(psb_err_unit,*) 'Converting from ',&
& a%get_fmt(),' to ',altmp%get_fmt() & a%get_fmt(),' to ',altmp%get_fmt()
call altmp%mv_from_fmt(a, info) call altmp%mv_from_fmt(a, info)
if (info /= psb_success_) then if (info /= psb_success_) then
info = psb_err_from_subroutine_ info = psb_err_from_subroutine_
call psb_errpush(info,name,a_err="mv_from") call psb_errpush(info,name,a_err="mv_from")
goto 9999 goto 9999
end if end if
call move_alloc(altmp,a) call move_alloc(altmp,a)
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
return return
9999 call psb_error_handler(err_act) 9999 call psb_error_handler(err_act)
return return
end subroutine inner_mv_alloc end subroutine inner_mv_fmt
end subroutine psb_d_cscnv_ip end subroutine psb_d_cscnv_ip

356
base/serial/impl/psb_s_mat_impl.F90
Unescape Escape View File

@ -1213,6 +1213,56 @@ subroutine psb_s_b_csclip(a,b,info,&
end subroutine psb_s_b_csclip end subroutine psb_s_b_csclip
subroutine psb_s_split_nd(a,n_rows,n_cols,info)
use psb_error_mod
use psb_string_mod
use psb_s_mat_mod, psb_protect_name => psb_s_split_nd
implicit none
class(psb_sspmat_type), intent(inout) :: a
integer(psb_ipk_), intent(in) :: n_rows, n_cols
integer(psb_ipk_), intent(out) :: info
!!$ integer(psb_ipk_),optional, intent(in) :: dupl
!!$ character(len=*), optional, intent(in) :: type
!!$ class(psb_s_base_sparse_mat), intent(in), optional :: mold
type(psb_s_coo_sparse_mat) :: acoo
type(psb_s_csr_sparse_mat), allocatable :: aclip
type(psb_s_ecsr_sparse_mat), allocatable :: andclip
logical, parameter :: use_ecsr=.true.
character(len=20) :: name, ch_err
integer(psb_ipk_) :: err_act
info = psb_success_
name = 'psb_split'
call psb_erractionsave(err_act)
allocate(aclip)
call a%a%csclip(acoo,info,jmax=n_rows,rscale=.false.,cscale=.false.)
allocate(a%ad,mold=a%a)
call a%ad%mv_from_coo(acoo,info)
call a%a%csclip(acoo,info,jmin=n_rows+1,jmax=n_cols,rscale=.false.,cscale=.false.)
if (use_ecsr) then
allocate(andclip)
call andclip%mv_from_coo(acoo,info)
call move_alloc(andclip,a%and)
else
allocate(a%and,mold=a%a)
call a%and%mv_from_coo(acoo,info)
end if
if (psb_errstatus_fatal()) then
info=psb_err_from_subroutine_
call psb_errpush(info,name,a_err='cscnv')
goto 9999
endif
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(err_act)
return
end subroutine psb_s_split_nd
subroutine psb_s_cscnv(a,b,info,type,mold,upd,dupl) subroutine psb_s_cscnv(a,b,info,type,mold,upd,dupl)
use psb_error_mod use psb_error_mod
use psb_string_mod use psb_string_mod
@ -1246,54 +1296,65 @@ subroutine psb_s_cscnv(a,b,info,type,mold,upd,dupl)
goto 9999 goto 9999
end if end if
if (present(mold)) then if (.false.) then
if (present(mold)) then
allocate(altmp, mold=mold,stat=info)
allocate(altmp, mold=mold,stat=info)
else if (present(type)) then
else if (present(type)) then
select case (psb_toupper(type))
case ('CSR')
allocate(psb_s_csr_sparse_mat :: altmp, stat=info)
case ('COO')
allocate(psb_s_coo_sparse_mat :: altmp, stat=info)
case ('CSC')
allocate(psb_s_csc_sparse_mat :: altmp, stat=info)
case default
info = psb_err_format_unknown_
call psb_errpush(info,name,a_err=type)
goto 9999
end select
else
allocate(altmp, mold=psb_get_mat_default(a),stat=info)
end if
select case (psb_toupper(type)) if (info /= psb_success_) then
case ('CSR') info = psb_err_alloc_dealloc_
allocate(psb_s_csr_sparse_mat :: altmp, stat=info) call psb_errpush(info,name)
case ('COO')
allocate(psb_s_coo_sparse_mat :: altmp, stat=info)
case ('CSC')
allocate(psb_s_csc_sparse_mat :: altmp, stat=info)
case default
info = psb_err_format_unknown_
call psb_errpush(info,name,a_err=type)
goto 9999 goto 9999
end select end if
else
allocate(altmp, mold=psb_get_mat_default(a),stat=info)
end if
if (info /= psb_success_) then
info = psb_err_alloc_dealloc_
call psb_errpush(info,name)
goto 9999
end if
if (present(dupl)) then
call altmp%set_dupl(dupl)
else if (a%is_bld()) then
! Does this make sense at all?? Who knows..
call altmp%set_dupl(psb_dupl_def_)
end if
if (present(dupl)) then if (debug) write(psb_err_unit,*) 'Converting from ',&
call altmp%set_dupl(dupl) & a%get_fmt(),' to ',altmp%get_fmt()
else if (a%is_bld()) then
! Does this make sense at all?? Who knows..
call altmp%set_dupl(psb_dupl_def_)
end if
if (debug) write(psb_err_unit,*) 'Converting from ',& call altmp%cp_from_fmt(a%a, info)
& a%get_fmt(),' to ',altmp%get_fmt()
call altmp%cp_from_fmt(a%a, info) if (info /= psb_success_) then
info = psb_err_from_subroutine_
call psb_errpush(info,name,a_err="mv_from")
goto 9999
end if
if (info /= psb_success_) then call move_alloc(altmp,b%a)
info = psb_err_from_subroutine_ else
call psb_errpush(info,name,a_err="mv_from") call inner_cp_fmt(a%a,b%a,info,type,mold,dupl)
goto 9999 if (allocated(a%ad)) then
call inner_cp_fmt(a%ad,b%ad,info,type,mold,dupl)
end if
if (allocated(a%and)) then
call inner_cp_fmt(a%and,b%and,info,type,mold,dupl)
end if
end if end if
call move_alloc(altmp,b%a)
call b%trim() call b%trim()
call b%set_asb() call b%set_asb()
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
@ -1303,7 +1364,79 @@ subroutine psb_s_cscnv(a,b,info,type,mold,upd,dupl)
9999 call psb_error_handler(err_act) 9999 call psb_error_handler(err_act)
return return
contains
subroutine inner_cp_fmt(a,b,info,type,mold,dupl)
class(psb_s_base_sparse_mat), intent(in) :: a
class(psb_s_base_sparse_mat), intent(inout), allocatable :: b
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_),optional, intent(in) :: dupl
character(len=*), optional, intent(in) :: type
class(psb_s_base_sparse_mat), intent(in), optional :: mold
class(psb_s_base_sparse_mat), allocatable :: altmp
integer(psb_ipk_) :: err_act
info = psb_success_
call psb_erractionsave(err_act)
if (present(mold)) then
allocate(altmp, mold=mold,stat=info)
else if (present(type)) then
select case (psb_toupper(type))
case ('CSR')
allocate(psb_s_csr_sparse_mat :: altmp, stat=info)
case ('COO')
allocate(psb_s_coo_sparse_mat :: altmp, stat=info)
case ('CSC')
allocate(psb_s_csc_sparse_mat :: altmp, stat=info)
case default
info = psb_err_format_unknown_
call psb_errpush(info,name,a_err=type)
goto 9999
end select
else
allocate(psb_s_csr_sparse_mat :: altmp, stat=info)
!allocate(altmp, mold=psb_get_mat_default(a),stat=info)
end if
if (info /= psb_success_) then
info = psb_err_alloc_dealloc_
call psb_errpush(info,name)
goto 9999
end if
if (present(dupl)) then
call altmp%set_dupl(dupl)
else if (a%is_bld()) then
! Does this make sense at all?? Who knows..
call altmp%set_dupl(psb_dupl_def_)
end if
if (debug) write(psb_err_unit,*) 'Converting from ',&
& a%get_fmt(),' to ',altmp%get_fmt()
call altmp%cp_from_fmt(a, info)
if (info /= psb_success_) then
info = psb_err_from_subroutine_
call psb_errpush(info,name,a_err="mv_from")
goto 9999
end if
call move_alloc(altmp,b)
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(err_act)
return
end subroutine inner_cp_fmt
end subroutine psb_s_cscnv end subroutine psb_s_cscnv
subroutine psb_s_cscnv_ip(a,info,type,mold,dupl) subroutine psb_s_cscnv_ip(a,info,type,mold,dupl)
@ -1312,13 +1445,12 @@ subroutine psb_s_cscnv_ip(a,info,type,mold,dupl)
use psb_s_mat_mod, psb_protect_name => psb_s_cscnv_ip use psb_s_mat_mod, psb_protect_name => psb_s_cscnv_ip
implicit none implicit none
class(psb_sspmat_type), intent(inout) :: a class(psb_sspmat_type), intent(inout) :: a
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_),optional, intent(in) :: dupl integer(psb_ipk_),optional, intent(in) :: dupl
character(len=*), optional, intent(in) :: type character(len=*), optional, intent(in) :: type
class(psb_s_base_sparse_mat), intent(in), optional :: mold class(psb_s_base_sparse_mat), intent(in), optional :: mold
class(psb_s_base_sparse_mat), allocatable :: altmp class(psb_s_base_sparse_mat), allocatable :: altmp
integer(psb_ipk_) :: err_act integer(psb_ipk_) :: err_act
character(len=20) :: name='cscnv_ip' character(len=20) :: name='cscnv_ip'
@ -1345,46 +1477,55 @@ subroutine psb_s_cscnv_ip(a,info,type,mold,dupl)
goto 9999 goto 9999
end if end if
if (present(mold)) then if (.false.) then
if (present(mold)) then
allocate(altmp, mold=mold,stat=info)
else if (present(type)) then
select case (psb_toupper(type))
case ('CSR')
allocate(psb_s_csr_sparse_mat :: altmp, stat=info)
case ('COO')
allocate(psb_s_coo_sparse_mat :: altmp, stat=info)
case ('CSC')
allocate(psb_s_csc_sparse_mat :: altmp, stat=info)
case default
info = psb_err_format_unknown_
call psb_errpush(info,name,a_err=type)
goto 9999
end select
else
allocate(altmp, mold=psb_get_mat_default(a),stat=info)
end if
allocate(altmp, mold=mold,stat=info) if (info /= psb_success_) then
info = psb_err_alloc_dealloc_
call psb_errpush(info,name)
goto 9999
end if
else if (present(type)) then if (debug) write(psb_err_unit,*) 'Converting in-place from ',&
& a%get_fmt(),' to ',altmp%get_fmt()
select case (psb_toupper(type)) call altmp%mv_from_fmt(a%a, info)
case ('CSR') call move_alloc(altmp,a%a)
allocate(psb_s_csr_sparse_mat :: altmp, stat=info)
case ('COO')
allocate(psb_s_coo_sparse_mat :: altmp, stat=info)
case ('CSC')
allocate(psb_s_csc_sparse_mat :: altmp, stat=info)
case default
info = psb_err_format_unknown_
call psb_errpush(info,name,a_err=type)
goto 9999
end select
else else
allocate(altmp, mold=psb_get_mat_default(a),stat=info) call inner_mv_fmt(a%a,info,type,mold,dupl)
if (allocated(a%ad)) then
call inner_mv_fmt(a%ad,info,type,mold,dupl)
end if
if (allocated(a%and)) then
call inner_mv_fmt(a%and,info,type,mold,dupl)
end if
end if end if
if (info /= psb_success_) then
info = psb_err_alloc_dealloc_
call psb_errpush(info,name)
goto 9999
end if
if (debug) write(psb_err_unit,*) 'Converting in-place from ',&
& a%get_fmt(),' to ',altmp%get_fmt()
call altmp%mv_from_fmt(a%a, info)
if (info /= psb_success_) then if (info /= psb_success_) then
info = psb_err_from_subroutine_ info = psb_err_from_subroutine_
call psb_errpush(info,name,a_err="mv_from") call psb_errpush(info,name,a_err="mv_from")
goto 9999 goto 9999
end if end if
call move_alloc(altmp,a%a)
call a%trim() call a%trim()
call a%set_asb() call a%set_asb()
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
@ -1394,6 +1535,77 @@ subroutine psb_s_cscnv_ip(a,info,type,mold,dupl)
9999 call psb_error_handler(err_act) 9999 call psb_error_handler(err_act)
return return
contains
subroutine inner_mv_fmt(a,info,type,mold,dupl)
class(psb_s_base_sparse_mat), intent(inout), allocatable :: a
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_),optional, intent(in) :: dupl
character(len=*), optional, intent(in) :: type
class(psb_s_base_sparse_mat), intent(in), optional :: mold
class(psb_s_base_sparse_mat), allocatable :: altmp
integer(psb_ipk_) :: err_act
info = psb_success_
call psb_erractionsave(err_act)
if (present(mold)) then
allocate(altmp, mold=mold,stat=info)
else if (present(type)) then
select case (psb_toupper(type))
case ('CSR')
allocate(psb_s_csr_sparse_mat :: altmp, stat=info)
case ('COO')
allocate(psb_s_coo_sparse_mat :: altmp, stat=info)
case ('CSC')
allocate(psb_s_csc_sparse_mat :: altmp, stat=info)
case default
info = psb_err_format_unknown_
call psb_errpush(info,name,a_err=type)
goto 9999
end select
else
allocate(psb_s_csr_sparse_mat :: altmp, stat=info)
!allocate(altmp, mold=psb_get_mat_default(a),stat=info)
end if
if (info /= psb_success_) then
info = psb_err_alloc_dealloc_
call psb_errpush(info,name)
goto 9999
end if
if (present(dupl)) then
call altmp%set_dupl(dupl)
else if (a%is_bld()) then
! Does this make sense at all?? Who knows..
call altmp%set_dupl(psb_dupl_def_)
end if
if (debug) write(psb_err_unit,*) 'Converting from ',&
& a%get_fmt(),' to ',altmp%get_fmt()
call altmp%mv_from_fmt(a, info)
if (info /= psb_success_) then
info = psb_err_from_subroutine_
call psb_errpush(info,name,a_err="mv_from")
goto 9999
end if
call move_alloc(altmp,a)
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(err_act)
return
end subroutine inner_mv_fmt
end subroutine psb_s_cscnv_ip end subroutine psb_s_cscnv_ip

356
base/serial/impl/psb_z_mat_impl.F90
Unescape Escape View File

@ -1213,6 +1213,56 @@ subroutine psb_z_b_csclip(a,b,info,&
end subroutine psb_z_b_csclip end subroutine psb_z_b_csclip
subroutine psb_z_split_nd(a,n_rows,n_cols,info)
use psb_error_mod
use psb_string_mod
use psb_z_mat_mod, psb_protect_name => psb_z_split_nd
implicit none
class(psb_zspmat_type), intent(inout) :: a
integer(psb_ipk_), intent(in) :: n_rows, n_cols
integer(psb_ipk_), intent(out) :: info
!!$ integer(psb_ipk_),optional, intent(in) :: dupl
!!$ character(len=*), optional, intent(in) :: type
!!$ class(psb_z_base_sparse_mat), intent(in), optional :: mold
type(psb_z_coo_sparse_mat) :: acoo
type(psb_z_csr_sparse_mat), allocatable :: aclip
type(psb_z_ecsr_sparse_mat), allocatable :: andclip
logical, parameter :: use_ecsr=.true.
character(len=20) :: name, ch_err
integer(psb_ipk_) :: err_act
info = psb_success_
name = 'psb_split'
call psb_erractionsave(err_act)
allocate(aclip)
call a%a%csclip(acoo,info,jmax=n_rows,rscale=.false.,cscale=.false.)
allocate(a%ad,mold=a%a)
call a%ad%mv_from_coo(acoo,info)
call a%a%csclip(acoo,info,jmin=n_rows+1,jmax=n_cols,rscale=.false.,cscale=.false.)
if (use_ecsr) then
allocate(andclip)
call andclip%mv_from_coo(acoo,info)
call move_alloc(andclip,a%and)
else
allocate(a%and,mold=a%a)
call a%and%mv_from_coo(acoo,info)
end if
if (psb_errstatus_fatal()) then
info=psb_err_from_subroutine_
call psb_errpush(info,name,a_err='cscnv')
goto 9999
endif
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(err_act)
return
end subroutine psb_z_split_nd
subroutine psb_z_cscnv(a,b,info,type,mold,upd,dupl) subroutine psb_z_cscnv(a,b,info,type,mold,upd,dupl)
use psb_error_mod use psb_error_mod
use psb_string_mod use psb_string_mod
@ -1246,54 +1296,65 @@ subroutine psb_z_cscnv(a,b,info,type,mold,upd,dupl)
goto 9999 goto 9999
end if end if
if (present(mold)) then if (.false.) then
if (present(mold)) then
allocate(altmp, mold=mold,stat=info)
allocate(altmp, mold=mold,stat=info)
else if (present(type)) then
else if (present(type)) then
select case (psb_toupper(type))
case ('CSR')
allocate(psb_z_csr_sparse_mat :: altmp, stat=info)
case ('COO')
allocate(psb_z_coo_sparse_mat :: altmp, stat=info)
case ('CSC')
allocate(psb_z_csc_sparse_mat :: altmp, stat=info)
case default
info = psb_err_format_unknown_
call psb_errpush(info,name,a_err=type)
goto 9999
end select
else
allocate(altmp, mold=psb_get_mat_default(a),stat=info)
end if
select case (psb_toupper(type)) if (info /= psb_success_) then
case ('CSR') info = psb_err_alloc_dealloc_
allocate(psb_z_csr_sparse_mat :: altmp, stat=info) call psb_errpush(info,name)
case ('COO')
allocate(psb_z_coo_sparse_mat :: altmp, stat=info)
case ('CSC')
allocate(psb_z_csc_sparse_mat :: altmp, stat=info)
case default
info = psb_err_format_unknown_
call psb_errpush(info,name,a_err=type)
goto 9999 goto 9999
end select end if
else
allocate(altmp, mold=psb_get_mat_default(a),stat=info)
end if
if (info /= psb_success_) then
info = psb_err_alloc_dealloc_
call psb_errpush(info,name)
goto 9999
end if
if (present(dupl)) then
call altmp%set_dupl(dupl)
else if (a%is_bld()) then
! Does this make sense at all?? Who knows..
call altmp%set_dupl(psb_dupl_def_)
end if
if (present(dupl)) then if (debug) write(psb_err_unit,*) 'Converting from ',&
call altmp%set_dupl(dupl) & a%get_fmt(),' to ',altmp%get_fmt()
else if (a%is_bld()) then
! Does this make sense at all?? Who knows..
call altmp%set_dupl(psb_dupl_def_)
end if
if (debug) write(psb_err_unit,*) 'Converting from ',& call altmp%cp_from_fmt(a%a, info)
& a%get_fmt(),' to ',altmp%get_fmt()
call altmp%cp_from_fmt(a%a, info) if (info /= psb_success_) then
info = psb_err_from_subroutine_
call psb_errpush(info,name,a_err="mv_from")
goto 9999
end if
if (info /= psb_success_) then call move_alloc(altmp,b%a)
info = psb_err_from_subroutine_ else
call psb_errpush(info,name,a_err="mv_from") call inner_cp_fmt(a%a,b%a,info,type,mold,dupl)
goto 9999 if (allocated(a%ad)) then
call inner_cp_fmt(a%ad,b%ad,info,type,mold,dupl)
end if
if (allocated(a%and)) then
call inner_cp_fmt(a%and,b%and,info,type,mold,dupl)
end if
end if end if
call move_alloc(altmp,b%a)
call b%trim() call b%trim()
call b%set_asb() call b%set_asb()
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
@ -1303,7 +1364,79 @@ subroutine psb_z_cscnv(a,b,info,type,mold,upd,dupl)
9999 call psb_error_handler(err_act) 9999 call psb_error_handler(err_act)
return return
contains
subroutine inner_cp_fmt(a,b,info,type,mold,dupl)
class(psb_z_base_sparse_mat), intent(in) :: a
class(psb_z_base_sparse_mat), intent(inout), allocatable :: b
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_),optional, intent(in) :: dupl
character(len=*), optional, intent(in) :: type
class(psb_z_base_sparse_mat), intent(in), optional :: mold
class(psb_z_base_sparse_mat), allocatable :: altmp
integer(psb_ipk_) :: err_act
info = psb_success_
call psb_erractionsave(err_act)
if (present(mold)) then
allocate(altmp, mold=mold,stat=info)
else if (present(type)) then
select case (psb_toupper(type))
case ('CSR')
allocate(psb_z_csr_sparse_mat :: altmp, stat=info)
case ('COO')
allocate(psb_z_coo_sparse_mat :: altmp, stat=info)
case ('CSC')
allocate(psb_z_csc_sparse_mat :: altmp, stat=info)
case default
info = psb_err_format_unknown_
call psb_errpush(info,name,a_err=type)
goto 9999
end select
else
allocate(psb_z_csr_sparse_mat :: altmp, stat=info)
!allocate(altmp, mold=psb_get_mat_default(a),stat=info)
end if
if (info /= psb_success_) then
info = psb_err_alloc_dealloc_
call psb_errpush(info,name)
goto 9999
end if
if (present(dupl)) then
call altmp%set_dupl(dupl)
else if (a%is_bld()) then
! Does this make sense at all?? Who knows..
call altmp%set_dupl(psb_dupl_def_)
end if
if (debug) write(psb_err_unit,*) 'Converting from ',&
& a%get_fmt(),' to ',altmp%get_fmt()
call altmp%cp_from_fmt(a, info)
if (info /= psb_success_) then
info = psb_err_from_subroutine_
call psb_errpush(info,name,a_err="mv_from")
goto 9999
end if
call move_alloc(altmp,b)
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(err_act)
return
end subroutine inner_cp_fmt
end subroutine psb_z_cscnv end subroutine psb_z_cscnv
subroutine psb_z_cscnv_ip(a,info,type,mold,dupl) subroutine psb_z_cscnv_ip(a,info,type,mold,dupl)
@ -1312,13 +1445,12 @@ subroutine psb_z_cscnv_ip(a,info,type,mold,dupl)
use psb_z_mat_mod, psb_protect_name => psb_z_cscnv_ip use psb_z_mat_mod, psb_protect_name => psb_z_cscnv_ip
implicit none implicit none
class(psb_zspmat_type), intent(inout) :: a class(psb_zspmat_type), intent(inout) :: a
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_),optional, intent(in) :: dupl integer(psb_ipk_),optional, intent(in) :: dupl
character(len=*), optional, intent(in) :: type character(len=*), optional, intent(in) :: type
class(psb_z_base_sparse_mat), intent(in), optional :: mold class(psb_z_base_sparse_mat), intent(in), optional :: mold
class(psb_z_base_sparse_mat), allocatable :: altmp class(psb_z_base_sparse_mat), allocatable :: altmp
integer(psb_ipk_) :: err_act integer(psb_ipk_) :: err_act
character(len=20) :: name='cscnv_ip' character(len=20) :: name='cscnv_ip'
@ -1345,46 +1477,55 @@ subroutine psb_z_cscnv_ip(a,info,type,mold,dupl)
goto 9999 goto 9999
end if end if
if (present(mold)) then if (.false.) then
if (present(mold)) then
allocate(altmp, mold=mold,stat=info)
else if (present(type)) then
select case (psb_toupper(type))
case ('CSR')
allocate(psb_z_csr_sparse_mat :: altmp, stat=info)
case ('COO')
allocate(psb_z_coo_sparse_mat :: altmp, stat=info)
case ('CSC')
allocate(psb_z_csc_sparse_mat :: altmp, stat=info)
case default
info = psb_err_format_unknown_
call psb_errpush(info,name,a_err=type)
goto 9999
end select
else
allocate(altmp, mold=psb_get_mat_default(a),stat=info)
end if
allocate(altmp, mold=mold,stat=info) if (info /= psb_success_) then
info = psb_err_alloc_dealloc_
call psb_errpush(info,name)
goto 9999
end if
else if (present(type)) then if (debug) write(psb_err_unit,*) 'Converting in-place from ',&
& a%get_fmt(),' to ',altmp%get_fmt()
select case (psb_toupper(type)) call altmp%mv_from_fmt(a%a, info)
case ('CSR') call move_alloc(altmp,a%a)
allocate(psb_z_csr_sparse_mat :: altmp, stat=info)
case ('COO')
allocate(psb_z_coo_sparse_mat :: altmp, stat=info)
case ('CSC')
allocate(psb_z_csc_sparse_mat :: altmp, stat=info)
case default
info = psb_err_format_unknown_
call psb_errpush(info,name,a_err=type)
goto 9999
end select
else else
allocate(altmp, mold=psb_get_mat_default(a),stat=info) call inner_mv_fmt(a%a,info,type,mold,dupl)
if (allocated(a%ad)) then
call inner_mv_fmt(a%ad,info,type,mold,dupl)
end if
if (allocated(a%and)) then
call inner_mv_fmt(a%and,info,type,mold,dupl)
end if
end if end if
if (info /= psb_success_) then
info = psb_err_alloc_dealloc_
call psb_errpush(info,name)
goto 9999
end if
if (debug) write(psb_err_unit,*) 'Converting in-place from ',&
& a%get_fmt(),' to ',altmp%get_fmt()
call altmp%mv_from_fmt(a%a, info)
if (info /= psb_success_) then if (info /= psb_success_) then
info = psb_err_from_subroutine_ info = psb_err_from_subroutine_
call psb_errpush(info,name,a_err="mv_from") call psb_errpush(info,name,a_err="mv_from")
goto 9999 goto 9999
end if end if
call move_alloc(altmp,a%a)
call a%trim() call a%trim()
call a%set_asb() call a%set_asb()
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
@ -1394,6 +1535,77 @@ subroutine psb_z_cscnv_ip(a,info,type,mold,dupl)
9999 call psb_error_handler(err_act) 9999 call psb_error_handler(err_act)
return return
contains
subroutine inner_mv_fmt(a,info,type,mold,dupl)
class(psb_z_base_sparse_mat), intent(inout), allocatable :: a
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_),optional, intent(in) :: dupl
character(len=*), optional, intent(in) :: type
class(psb_z_base_sparse_mat), intent(in), optional :: mold
class(psb_z_base_sparse_mat), allocatable :: altmp
integer(psb_ipk_) :: err_act
info = psb_success_
call psb_erractionsave(err_act)
if (present(mold)) then
allocate(altmp, mold=mold,stat=info)
else if (present(type)) then
select case (psb_toupper(type))
case ('CSR')
allocate(psb_z_csr_sparse_mat :: altmp, stat=info)
case ('COO')
allocate(psb_z_coo_sparse_mat :: altmp, stat=info)
case ('CSC')
allocate(psb_z_csc_sparse_mat :: altmp, stat=info)
case default
info = psb_err_format_unknown_
call psb_errpush(info,name,a_err=type)
goto 9999
end select
else
allocate(psb_z_csr_sparse_mat :: altmp, stat=info)
!allocate(altmp, mold=psb_get_mat_default(a),stat=info)
end if
if (info /= psb_success_) then
info = psb_err_alloc_dealloc_
call psb_errpush(info,name)
goto 9999
end if
if (present(dupl)) then
call altmp%set_dupl(dupl)
else if (a%is_bld()) then
! Does this make sense at all?? Who knows..
call altmp%set_dupl(psb_dupl_def_)
end if
if (debug) write(psb_err_unit,*) 'Converting from ',&
& a%get_fmt(),' to ',altmp%get_fmt()
call altmp%mv_from_fmt(a, info)
if (info /= psb_success_) then
info = psb_err_from_subroutine_
call psb_errpush(info,name,a_err="mv_from")
goto 9999
end if
call move_alloc(altmp,a)
call psb_erractionrestore(err_act)
return
9999 call psb_error_handler(err_act)
return
end subroutine inner_mv_fmt
end subroutine psb_z_cscnv_ip end subroutine psb_z_cscnv_ip

73
base/tools/psb_cspasb.f90
Unescape Escape View File

@ -178,41 +178,44 @@ subroutine psb_cspasb(a,desc_a, info, afmt, upd, mold, bld_and)
end if end if
if (bld_and_) then if (bld_and_) then
block !!$ allocate(a%ad,mold=a%a)
character(len=1024) :: fname !!$ allocate(a%and,mold=a%a)o
type(psb_c_coo_sparse_mat) :: acoo call a%split_nd(n_row,n_col,info)
type(psb_c_csr_sparse_mat), allocatable :: aclip !!$ block
type(psb_c_ecsr_sparse_mat), allocatable :: andclip !!$ character(len=1024) :: fname
logical, parameter :: use_ecsr=.true. !!$ type(psb_c_coo_sparse_mat) :: acoo
allocate(aclip) !!$ type(psb_c_csr_sparse_mat), allocatable :: aclip
call a%a%csclip(acoo,info,jmax=n_row,rscale=.false.,cscale=.false.) !!$ type(psb_c_ecsr_sparse_mat), allocatable :: andclip
allocate(a%ad,mold=a%a) !!$ logical, parameter :: use_ecsr=.true.
call a%ad%mv_from_coo(acoo,info) !!$ allocate(aclip)
call a%a%csclip(acoo,info,jmin=n_row+1,jmax=n_col,rscale=.false.,cscale=.false.) !!$ call a%a%csclip(acoo,info,jmax=n_row,rscale=.false.,cscale=.false.)
if (use_ecsr) then !!$ allocate(a%ad,mold=a%a)
allocate(andclip) !!$ call a%ad%mv_from_coo(acoo,info)
call andclip%mv_from_coo(acoo,info) !!$ call a%a%csclip(acoo,info,jmin=n_row+1,jmax=n_col,rscale=.false.,cscale=.false.)
call move_alloc(andclip,a%and) !!$ if (use_ecsr) then
else !!$ allocate(andclip)
allocate(a%and,mold=a%a) !!$ call andclip%mv_from_coo(acoo,info)
call a%and%mv_from_coo(acoo,info) !!$ call move_alloc(andclip,a%and)
end if !!$ else
if (.false.) then !!$ allocate(a%and,mold=a%a)
write(fname,'(a,i2.2,a)') 'adclip_',me,'.mtx' !!$ call a%and%mv_from_coo(acoo,info)
open(25,file=fname) !!$ end if
call a%ad%print(25) !!$ if (.false.) then
close(25) !!$ write(fname,'(a,i2.2,a)') 'adclip_',me,'.mtx'
write(fname,'(a,i2.2,a)') 'andclip_',me,'.mtx' !!$ open(25,file=fname)
open(25,file=fname) !!$ call a%ad%print(25)
call a%and%print(25) !!$ close(25)
close(25) !!$ write(fname,'(a,i2.2,a)') 'andclip_',me,'.mtx'
!call andclip%set_cols(n_col) !!$ open(25,file=fname)
write(*,*) me,' ',trim(name),' ad ',& !!$ call a%and%print(25)
&a%ad%get_nrows(),a%ad%get_ncols(),n_row,n_col !!$ close(25)
write(*,*) me,' ',trim(name),' and ',& !!$ !call andclip%set_cols(n_col)
&a%and%get_nrows(),a%and%get_ncols(),n_row,n_col !!$ write(*,*) me,' ',trim(name),' ad ',&
end if !!$ &a%ad%get_nrows(),a%ad%get_ncols(),n_row,n_col
end block !!$ write(*,*) me,' ',trim(name),' and ',&
!!$ &a%and%get_nrows(),a%and%get_ncols(),n_row,n_col
!!$ end if
!!$ end block
else else
if (allocated(a%ad)) deallocate(a%ad) if (allocated(a%ad)) deallocate(a%ad)
if (allocated(a%and)) deallocate(a%and) if (allocated(a%and)) deallocate(a%and)

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

@ -178,41 +178,44 @@ subroutine psb_dspasb(a,desc_a, info, afmt, upd, mold, bld_and)
end if end if
if (bld_and_) then if (bld_and_) then
block !!$ allocate(a%ad,mold=a%a)
character(len=1024) :: fname !!$ allocate(a%and,mold=a%a)o
type(psb_d_coo_sparse_mat) :: acoo call a%split_nd(n_row,n_col,info)
type(psb_d_csr_sparse_mat), allocatable :: aclip !!$ block
type(psb_d_ecsr_sparse_mat), allocatable :: andclip !!$ character(len=1024) :: fname
logical, parameter :: use_ecsr=.true. !!$ type(psb_d_coo_sparse_mat) :: acoo
allocate(aclip) !!$ type(psb_d_csr_sparse_mat), allocatable :: aclip
call a%a%csclip(acoo,info,jmax=n_row,rscale=.false.,cscale=.false.) !!$ type(psb_d_ecsr_sparse_mat), allocatable :: andclip
allocate(a%ad,mold=a%a) !!$ logical, parameter :: use_ecsr=.true.
call a%ad%mv_from_coo(acoo,info) !!$ allocate(aclip)
call a%a%csclip(acoo,info,jmin=n_row+1,jmax=n_col,rscale=.false.,cscale=.false.) !!$ call a%a%csclip(acoo,info,jmax=n_row,rscale=.false.,cscale=.false.)
if (use_ecsr) then !!$ allocate(a%ad,mold=a%a)
allocate(andclip) !!$ call a%ad%mv_from_coo(acoo,info)
call andclip%mv_from_coo(acoo,info) !!$ call a%a%csclip(acoo,info,jmin=n_row+1,jmax=n_col,rscale=.false.,cscale=.false.)
call move_alloc(andclip,a%and) !!$ if (use_ecsr) then
else !!$ allocate(andclip)
allocate(a%and,mold=a%a) !!$ call andclip%mv_from_coo(acoo,info)
call a%and%mv_from_coo(acoo,info) !!$ call move_alloc(andclip,a%and)
end if !!$ else
if (.false.) then !!$ allocate(a%and,mold=a%a)
write(fname,'(a,i2.2,a)') 'adclip_',me,'.mtx' !!$ call a%and%mv_from_coo(acoo,info)
open(25,file=fname) !!$ end if
call a%ad%print(25) !!$ if (.false.) then
close(25) !!$ write(fname,'(a,i2.2,a)') 'adclip_',me,'.mtx'
write(fname,'(a,i2.2,a)') 'andclip_',me,'.mtx' !!$ open(25,file=fname)
open(25,file=fname) !!$ call a%ad%print(25)
call a%and%print(25) !!$ close(25)
close(25) !!$ write(fname,'(a,i2.2,a)') 'andclip_',me,'.mtx'
!call andclip%set_cols(n_col) !!$ open(25,file=fname)
write(*,*) me,' ',trim(name),' ad ',& !!$ call a%and%print(25)
&a%ad%get_nrows(),a%ad%get_ncols(),n_row,n_col !!$ close(25)
write(*,*) me,' ',trim(name),' and ',& !!$ !call andclip%set_cols(n_col)
&a%and%get_nrows(),a%and%get_ncols(),n_row,n_col !!$ write(*,*) me,' ',trim(name),' ad ',&
end if !!$ &a%ad%get_nrows(),a%ad%get_ncols(),n_row,n_col
end block !!$ write(*,*) me,' ',trim(name),' and ',&
!!$ &a%and%get_nrows(),a%and%get_ncols(),n_row,n_col
!!$ end if
!!$ end block
else else
if (allocated(a%ad)) deallocate(a%ad) if (allocated(a%ad)) deallocate(a%ad)
if (allocated(a%and)) deallocate(a%and) if (allocated(a%and)) deallocate(a%and)

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

@ -178,41 +178,44 @@ subroutine psb_sspasb(a,desc_a, info, afmt, upd, mold, bld_and)
end if end if
if (bld_and_) then if (bld_and_) then
block !!$ allocate(a%ad,mold=a%a)
character(len=1024) :: fname !!$ allocate(a%and,mold=a%a)o
type(psb_s_coo_sparse_mat) :: acoo call a%split_nd(n_row,n_col,info)
type(psb_s_csr_sparse_mat), allocatable :: aclip !!$ block
type(psb_s_ecsr_sparse_mat), allocatable :: andclip !!$ character(len=1024) :: fname
logical, parameter :: use_ecsr=.true. !!$ type(psb_s_coo_sparse_mat) :: acoo
allocate(aclip) !!$ type(psb_s_csr_sparse_mat), allocatable :: aclip
call a%a%csclip(acoo,info,jmax=n_row,rscale=.false.,cscale=.false.) !!$ type(psb_s_ecsr_sparse_mat), allocatable :: andclip
allocate(a%ad,mold=a%a) !!$ logical, parameter :: use_ecsr=.true.
call a%ad%mv_from_coo(acoo,info) !!$ allocate(aclip)
call a%a%csclip(acoo,info,jmin=n_row+1,jmax=n_col,rscale=.false.,cscale=.false.) !!$ call a%a%csclip(acoo,info,jmax=n_row,rscale=.false.,cscale=.false.)
if (use_ecsr) then !!$ allocate(a%ad,mold=a%a)
allocate(andclip) !!$ call a%ad%mv_from_coo(acoo,info)
call andclip%mv_from_coo(acoo,info) !!$ call a%a%csclip(acoo,info,jmin=n_row+1,jmax=n_col,rscale=.false.,cscale=.false.)
call move_alloc(andclip,a%and) !!$ if (use_ecsr) then
else !!$ allocate(andclip)
allocate(a%and,mold=a%a) !!$ call andclip%mv_from_coo(acoo,info)
call a%and%mv_from_coo(acoo,info) !!$ call move_alloc(andclip,a%and)
end if !!$ else
if (.false.) then !!$ allocate(a%and,mold=a%a)
write(fname,'(a,i2.2,a)') 'adclip_',me,'.mtx' !!$ call a%and%mv_from_coo(acoo,info)
open(25,file=fname) !!$ end if
call a%ad%print(25) !!$ if (.false.) then
close(25) !!$ write(fname,'(a,i2.2,a)') 'adclip_',me,'.mtx'
write(fname,'(a,i2.2,a)') 'andclip_',me,'.mtx' !!$ open(25,file=fname)
open(25,file=fname) !!$ call a%ad%print(25)
call a%and%print(25) !!$ close(25)
close(25) !!$ write(fname,'(a,i2.2,a)') 'andclip_',me,'.mtx'
!call andclip%set_cols(n_col) !!$ open(25,file=fname)
write(*,*) me,' ',trim(name),' ad ',& !!$ call a%and%print(25)
&a%ad%get_nrows(),a%ad%get_ncols(),n_row,n_col !!$ close(25)
write(*,*) me,' ',trim(name),' and ',& !!$ !call andclip%set_cols(n_col)
&a%and%get_nrows(),a%and%get_ncols(),n_row,n_col !!$ write(*,*) me,' ',trim(name),' ad ',&
end if !!$ &a%ad%get_nrows(),a%ad%get_ncols(),n_row,n_col
end block !!$ write(*,*) me,' ',trim(name),' and ',&
!!$ &a%and%get_nrows(),a%and%get_ncols(),n_row,n_col
!!$ end if
!!$ end block
else else
if (allocated(a%ad)) deallocate(a%ad) if (allocated(a%ad)) deallocate(a%ad)
if (allocated(a%and)) deallocate(a%and) if (allocated(a%and)) deallocate(a%and)

73
base/tools/psb_zspasb.f90
Unescape Escape View File

@ -178,41 +178,44 @@ subroutine psb_zspasb(a,desc_a, info, afmt, upd, mold, bld_and)
end if end if
if (bld_and_) then if (bld_and_) then
block !!$ allocate(a%ad,mold=a%a)
character(len=1024) :: fname !!$ allocate(a%and,mold=a%a)o
type(psb_z_coo_sparse_mat) :: acoo call a%split_nd(n_row,n_col,info)
type(psb_z_csr_sparse_mat), allocatable :: aclip !!$ block
type(psb_z_ecsr_sparse_mat), allocatable :: andclip !!$ character(len=1024) :: fname
logical, parameter :: use_ecsr=.true. !!$ type(psb_z_coo_sparse_mat) :: acoo
allocate(aclip) !!$ type(psb_z_csr_sparse_mat), allocatable :: aclip
call a%a%csclip(acoo,info,jmax=n_row,rscale=.false.,cscale=.false.) !!$ type(psb_z_ecsr_sparse_mat), allocatable :: andclip
allocate(a%ad,mold=a%a) !!$ logical, parameter :: use_ecsr=.true.
call a%ad%mv_from_coo(acoo,info) !!$ allocate(aclip)
call a%a%csclip(acoo,info,jmin=n_row+1,jmax=n_col,rscale=.false.,cscale=.false.) !!$ call a%a%csclip(acoo,info,jmax=n_row,rscale=.false.,cscale=.false.)
if (use_ecsr) then !!$ allocate(a%ad,mold=a%a)
allocate(andclip) !!$ call a%ad%mv_from_coo(acoo,info)
call andclip%mv_from_coo(acoo,info) !!$ call a%a%csclip(acoo,info,jmin=n_row+1,jmax=n_col,rscale=.false.,cscale=.false.)
call move_alloc(andclip,a%and) !!$ if (use_ecsr) then
else !!$ allocate(andclip)
allocate(a%and,mold=a%a) !!$ call andclip%mv_from_coo(acoo,info)
call a%and%mv_from_coo(acoo,info) !!$ call move_alloc(andclip,a%and)
end if !!$ else
if (.false.) then !!$ allocate(a%and,mold=a%a)
write(fname,'(a,i2.2,a)') 'adclip_',me,'.mtx' !!$ call a%and%mv_from_coo(acoo,info)
open(25,file=fname) !!$ end if
call a%ad%print(25) !!$ if (.false.) then
close(25) !!$ write(fname,'(a,i2.2,a)') 'adclip_',me,'.mtx'
write(fname,'(a,i2.2,a)') 'andclip_',me,'.mtx' !!$ open(25,file=fname)
open(25,file=fname) !!$ call a%ad%print(25)
call a%and%print(25) !!$ close(25)
close(25) !!$ write(fname,'(a,i2.2,a)') 'andclip_',me,'.mtx'
!call andclip%set_cols(n_col) !!$ open(25,file=fname)
write(*,*) me,' ',trim(name),' ad ',& !!$ call a%and%print(25)
&a%ad%get_nrows(),a%ad%get_ncols(),n_row,n_col !!$ close(25)
write(*,*) me,' ',trim(name),' and ',& !!$ !call andclip%set_cols(n_col)
&a%and%get_nrows(),a%and%get_ncols(),n_row,n_col !!$ write(*,*) me,' ',trim(name),' ad ',&
end if !!$ &a%ad%get_nrows(),a%ad%get_ncols(),n_row,n_col
end block !!$ write(*,*) me,' ',trim(name),' and ',&
!!$ &a%and%get_nrows(),a%and%get_ncols(),n_row,n_col
!!$ end if
!!$ end block
else else
if (allocated(a%ad)) deallocate(a%ad) if (allocated(a%ad)) deallocate(a%ad)
if (allocated(a%and)) deallocate(a%and) if (allocated(a%and)) deallocate(a%and)

Write Preview
Loading…
Cancel
Save