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

psblas3-integer8:

Browse Source 
base/tools/psb_cd_lstext.f90
 base/tools/psb_cd_switch_ovl_indxmap.f90
 base/tools/psb_cspins.f90
 base/tools/psb_dspins.f90
 base/tools/psb_sspins.f90
 base/tools/psb_zspins.f90


Now base/*  compiles with integer8
psblas3-type-indexed
Salvatore Filippone 13 years ago
parent 42994a8ab2
commit 1f9b8bc0e5
6 changed files with 178 additions and 195 deletions
Show Stats Download Patch File Download Diff File

15
base/tools/psb_cd_lstext.f90
Unescape Escape View File

@ -52,7 +52,7 @@ Subroutine psb_cd_lstext(desc_a,in_list,desc_ov,info, mask,extype)
& n_elem_send,tot_recv,tot_elem,cntov_o,& & n_elem_send,tot_recv,tot_elem,cntov_o,&
& counter_t,n_elem,i_ovr,jj,proc_id,isz, nl, & & counter_t,n_elem,i_ovr,jj,proc_id,isz, nl, &
& idxr, idxs, iszr, iszs, nxch, nsnd, nrcv,lidx, extype_ & idxr, idxs, iszr, iszs, nxch, nsnd, nrcv,lidx, extype_
integer(psb_ipk_) :: icomm, err_act integer(psb_ipk_) :: err_act
integer(psb_ipk_), allocatable :: tmp_halo(:),tmp_ovr_idx(:), orig_ovr(:) integer(psb_ipk_), allocatable :: tmp_halo(:),tmp_ovr_idx(:), orig_ovr(:)
integer(psb_ipk_),allocatable :: halo(:),works(:),workr(:),t_halo_in(:),& integer(psb_ipk_),allocatable :: halo(:),works(:),workr(:),t_halo_in(:),&
@ -60,8 +60,9 @@ Subroutine psb_cd_lstext(desc_a,in_list,desc_ov,info, mask,extype)
integer(psb_ipk_),allocatable :: brvindx(:),rvsz(:), bsdindx(:),sdsz(:) integer(psb_ipk_),allocatable :: brvindx(:),rvsz(:), bsdindx(:),sdsz(:)
logical, allocatable, target :: lmask(:) logical, allocatable, target :: lmask(:)
logical, pointer :: mask_(:) logical, pointer :: mask_(:)
integer(psb_ipk_) :: ierr(5)
integer(psb_ipk_) :: debug_level, debug_unit integer(psb_ipk_) :: debug_level, debug_unit
character(len=20) :: name, ch_err character(len=20) :: name
name='psb_cd_lstext' name='psb_cd_lstext'
info = psb_success_ info = psb_success_
@ -70,14 +71,12 @@ Subroutine psb_cd_lstext(desc_a,in_list,desc_ov,info, mask,extype)
debug_level = psb_get_debug_level() debug_level = psb_get_debug_level()
ictxt = desc_a%get_context() ictxt = desc_a%get_context()
icomm = desc_a%get_mpic()
Call psb_info(ictxt, me, np) Call psb_info(ictxt, me, np)
If (debug_level >= psb_debug_outer_) & If (debug_level >= psb_debug_outer_) &
& Write(debug_unit,*) me,' ',trim(name),': start',size(in_list) & Write(debug_unit,*) me,' ',trim(name),': start',size(in_list)
m = desc_a%get_local_rows() m = desc_a%get_local_rows()
n_row = desc_a%get_local_rows() n_row = desc_a%get_local_rows()
n_col = desc_a%get_local_cols() n_col = desc_a%get_local_cols()
@ -115,8 +114,7 @@ Subroutine psb_cd_lstext(desc_a,in_list,desc_ov,info, mask,extype)
call psb_cdcpy(desc_a,desc_ov,info) call psb_cdcpy(desc_a,desc_ov,info)
if (info /= psb_success_) then if (info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
ch_err='psb_cdcpy' call psb_errpush(info,name,a_err='psb_cdcpy')
call psb_errpush(info,name,a_err=ch_err)
goto 9999 goto 9999
end if end if
if (debug_level >= psb_debug_outer_) & if (debug_level >= psb_debug_outer_) &
@ -143,8 +141,9 @@ Subroutine psb_cd_lstext(desc_a,in_list,desc_ov,info, mask,extype)
call psb_cd_set_ovl_asb(desc_ov,info) call psb_cd_set_ovl_asb(desc_ov,info)
if (info /= psb_success_) then if (info /= psb_success_) then
ch_err='sp_free' ierr(1) = info
call psb_errpush(psb_err_from_subroutine_ai_,name,a_err=ch_err,i_err=(/info,0,0,0,0/)) call psb_errpush(psb_err_from_subroutine_ai_,name,a_err='sp_free',&
& i_err=ierr)
goto 9999 goto 9999
end if end if

22
base/tools/psb_cd_switch_ovl_indxmap.f90
Unescape Escape View File

@ -46,10 +46,11 @@ Subroutine psb_cd_switch_ovl_indxmap(desc,info)
! .. Local Scalars .. ! .. Local Scalars ..
integer(psb_ipk_) :: i, j, np, me, mglob, ictxt, n_row, n_col integer(psb_ipk_) :: i, j, np, me, mglob, ictxt, n_row, n_col
integer(psb_ipk_) :: icomm, err_act integer(psb_ipk_) :: err_act
integer(psb_ipk_), allocatable :: vl(:) integer(psb_ipk_), allocatable :: vl(:)
integer(psb_ipk_) :: debug_level, debug_unit integer(psb_ipk_) :: debug_level, debug_unit, ierr(5)
integer(psb_mpik_) :: iictxt
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
name='cd_switch_ovl_indxmap' name='cd_switch_ovl_indxmap'
@ -59,13 +60,12 @@ Subroutine psb_cd_switch_ovl_indxmap(desc,info)
debug_level = psb_get_debug_level() debug_level = psb_get_debug_level()
ictxt = desc%get_context() ictxt = desc%get_context()
icomm = desc%get_mpic()
Call psb_info(ictxt, me, np) Call psb_info(ictxt, me, np)
If (debug_level >= psb_debug_outer_) & If (debug_level >= psb_debug_outer_) &
& Write(debug_unit,*) me,' ',trim(name),& & Write(debug_unit,*) me,' ',trim(name),&
& ': start' & ': start'
iictxt = ictxt
mglob = desc%get_global_rows() mglob = desc%get_global_rows()
n_row = desc%get_local_rows() n_row = desc%get_local_rows()
n_col = desc%get_local_cols() n_col = desc%get_local_cols()
@ -81,10 +81,10 @@ Subroutine psb_cd_switch_ovl_indxmap(desc,info)
end do end do
call desc%indxmap%l2g(vl(1:n_col),info) call desc%indxmap%l2g(vl(1:n_col),info)
!!$ write(0,*) 'from l2g' ,info,n_row,n_Col
if (info /= psb_success_) then if (info /= psb_success_) then
ierr(1)=info
call psb_errpush(psb_err_from_subroutine_ai_,name,& call psb_errpush(psb_err_from_subroutine_ai_,name,&
& a_err='map%l2g',i_err=(/info,0,0,0,0/)) & a_err='map%l2g',i_err=ierr)
goto 9999 goto 9999
end if end if
@ -97,19 +97,15 @@ Subroutine psb_cd_switch_ovl_indxmap(desc,info)
allocate(psb_list_map :: desc%indxmap, stat=info) allocate(psb_list_map :: desc%indxmap, stat=info)
end if end if
!!$ write(0,*) 'from allocate indxmap' ,info
if (info == psb_success_)& if (info == psb_success_)&
& call desc%indxmap%init(ictxt,vl(1:n_row),info) & call desc%indxmap%init(iictxt,vl(1:n_row),info)
!!$ write(0,*) 'from indxmap%init' ,info
if (info == psb_success_) call psb_cd_set_bld(desc,info) if (info == psb_success_) call psb_cd_set_bld(desc,info)
!!$ write(0,*) 'from cd_Set_bld' ,info
!!$ write(0,*) 'into g2l_ins' ,info,vl(n_row+1:n_col)
if (info == psb_success_) & if (info == psb_success_) &
& call desc%indxmap%g2l_ins(vl(n_row+1:n_col),info) & call desc%indxmap%g2l_ins(vl(n_row+1:n_col),info)
!!$ write(0,*) 'from g2l_ins' ,info,vl(n_row+1:n_col)
if (info /= psb_success_) then if (info /= psb_success_) then
ierr(1) = info
call psb_errpush(psb_err_from_subroutine_ai_,name,& call psb_errpush(psb_err_from_subroutine_ai_,name,&
& a_err='allocate/init',i_err=(/info,0,0,0,0/)) & a_err='allocate/init',i_err=ierr)
goto 9999 goto 9999
end if end if
if (n_row /= desc%indxmap%get_lr()) then if (n_row /= desc%indxmap%get_lr()) then

75
base/tools/psb_cspins.f90
Unescape Escape View File

@ -68,23 +68,22 @@ subroutine psb_cspins(nz,ia,ja,val,a,desc_a,info,rebuild)
integer(psb_ipk_), parameter :: relocsz=200 integer(psb_ipk_), parameter :: relocsz=200
logical :: rebuild_ logical :: rebuild_
integer(psb_ipk_), allocatable :: ila(:),jla(:) integer(psb_ipk_), allocatable :: ila(:),jla(:)
character(len=20) :: name, ch_err integer(psb_ipk_) :: ierr(5)
character(len=20) :: name
info = psb_success_ info = psb_success_
name = 'psb_cspins' name = 'psb_cspins'
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
if (.not.desc_a%is_ok()) then
ictxt = desc_a%get_context()
call psb_info(ictxt, me, np)
if (.not.psb_is_ok_desc(desc_a)) then
info = psb_err_invalid_cd_state_ info = psb_err_invalid_cd_state_
call psb_errpush(info,name) call psb_errpush(info,name)
goto 9999 goto 9999
end if end if
ictxt = desc_a%get_context()
call psb_info(ictxt, me, np)
if (nz < 0) then if (nz < 0) then
info = 1111 info = 1111
call psb_errpush(info,name) call psb_errpush(info,name)
@ -118,28 +117,27 @@ subroutine psb_cspins(nz,ia,ja,val,a,desc_a,info,rebuild)
allocate(ila(nz),jla(nz),stat=info) allocate(ila(nz),jla(nz),stat=info)
if (info /= psb_success_) then if (info /= psb_success_) then
ch_err='allocate' ierr(1) = info
call psb_errpush(psb_err_from_subroutine_ai_,name,& call psb_errpush(psb_err_from_subroutine_ai_,name,&
& a_err=ch_err,i_err=(/info,0,0,0,0/)) & a_err='allocate',i_err=ierr)
goto 9999 goto 9999
end if end if
call psb_cdins(nz,ia,ja,desc_a,info,ila=ila,jla=jla) call psb_cdins(nz,ia,ja,desc_a,info,ila=ila,jla=jla)
if (info /= psb_success_) then if (info /= psb_success_) then
ch_err='psb_cdins' ierr(1) = info
call psb_errpush(psb_err_from_subroutine_ai_,name,& call psb_errpush(psb_err_from_subroutine_ai_,name,&
& a_err=ch_err,i_err=(/info,0,0,0,0/)) & a_err='psb_cdins',i_err=ierr)
goto 9999 goto 9999
end if end if
nrow = desc_a%get_local_rows() nrow = desc_a%get_local_rows()
ncol = desc_a%get_local_cols() ncol = desc_a%get_local_cols()
if (a%is_bld()) then if (a%is_bld()) then
call a%csput(nz,ila,jla,val,1,nrow,1,ncol,info) call a%csput(nz,ila,jla,val,ione,nrow,ione,ncol,info)
if (info /= psb_success_) then if (info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
ch_err='psb_coins' call psb_errpush(info,name,a_err='a%csput')
call psb_errpush(info,name,a_err=ch_err)
goto 9999 goto 9999
end if end if
else else
@ -153,9 +151,9 @@ subroutine psb_cspins(nz,ia,ja,val,a,desc_a,info,rebuild)
allocate(ila(nz),jla(nz),stat=info) allocate(ila(nz),jla(nz),stat=info)
if (info /= psb_success_) then if (info /= psb_success_) then
ch_err='allocate' ierr(1) = info
call psb_errpush(psb_err_from_subroutine_ai_,name,& call psb_errpush(psb_err_from_subroutine_ai_,name,&
& a_err=ch_err,i_err=(/info,0,0,0,0/)) & a_err='allocate',i_err=ierr)
goto 9999 goto 9999
end if end if
@ -166,11 +164,10 @@ subroutine psb_cspins(nz,ia,ja,val,a,desc_a,info,rebuild)
nrow = desc_a%get_local_rows() nrow = desc_a%get_local_rows()
ncol = desc_a%get_local_cols() ncol = desc_a%get_local_cols()
call a%csput(nz,ila,jla,val,1,nrow,1,ncol,info) call a%csput(nz,ila,jla,val,ione,nrow,ione,ncol,info)
if (info /= psb_success_) then if (info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
ch_err='psb_coins' call psb_errpush(info,name,a_err='a%csput')
call psb_errpush(info,name,a_err=ch_err)
goto 9999 goto 9999
end if end if
@ -213,28 +210,27 @@ subroutine psb_cspins_2desc(nz,ia,ja,val,a,desc_ar,desc_ac,info)
logical, parameter :: debug=.false. logical, parameter :: debug=.false.
integer(psb_ipk_), parameter :: relocsz=200 integer(psb_ipk_), parameter :: relocsz=200
integer(psb_ipk_), allocatable :: ila(:),jla(:) integer(psb_ipk_), allocatable :: ila(:),jla(:)
character(len=20) :: name, ch_err integer(psb_ipk_) :: ierr(5)
character(len=20) :: name
info = psb_success_ info = psb_success_
name = 'psb_cspins' if (psb_errstatus_fatal()) return
name = 'psb_dspins'
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
if (.not.desc_ar%is_ok()) then
ictxt = desc_ar%get_context()
call psb_info(ictxt, me, np)
if (.not.psb_is_ok_desc(desc_ar)) then
info = psb_err_invalid_cd_state_ info = psb_err_invalid_cd_state_
call psb_errpush(info,name) call psb_errpush(info,name)
goto 9999 goto 9999
end if end if
if (.not.psb_is_ok_desc(desc_ac)) then if (.not.desc_ac%is_ok()) then
info = psb_err_invalid_cd_state_ info = psb_err_invalid_cd_state_
call psb_errpush(info,name) call psb_errpush(info,name)
goto 9999 goto 9999
end if end if
ictxt = desc_ar%get_context()
call psb_info(ictxt, me, np)
if (nz < 0) then if (nz < 0) then
info = 1111 info = 1111
call psb_errpush(info,name) call psb_errpush(info,name)
@ -258,13 +254,13 @@ subroutine psb_cspins_2desc(nz,ia,ja,val,a,desc_ar,desc_ac,info)
end if end if
if (nz == 0) return if (nz == 0) return
if (psb_is_bld_desc(desc_ac)) then if (desc_ac%is_bld()) then
allocate(ila(nz),jla(nz),stat=info) allocate(ila(nz),jla(nz),stat=info)
if (info /= psb_success_) then if (info /= psb_success_) then
ch_err='allocate' ierr(1) = info
call psb_errpush(psb_err_from_subroutine_ai_,name,& call psb_errpush(psb_err_from_subroutine_ai_,name,&
& a_err=ch_err,i_err=(/info,0,0,0,0/)) & a_err='allocate',i_err=ierr)
goto 9999 goto 9999
end if end if
ila(1:nz) = ia(1:nz) ila(1:nz) = ia(1:nz)
@ -273,25 +269,24 @@ subroutine psb_cspins_2desc(nz,ia,ja,val,a,desc_ar,desc_ac,info)
call psb_cdins(nz,ja,desc_ac,info,jla=jla, mask=(ila(1:nz)>0)) call psb_cdins(nz,ja,desc_ac,info,jla=jla, mask=(ila(1:nz)>0))
if (info /= psb_success_) then if (psb_errstatus_fatal()) then
ch_err='psb_cdins' ierr(1) = info
call psb_errpush(psb_err_from_subroutine_ai_,name,& call psb_errpush(psb_err_from_subroutine_ai_,name,&
& a_err=ch_err,i_err=(/info,0,0,0,0/)) & a_err='psb_cdins',i_err=ierr)
goto 9999 goto 9999
end if end if
nrow = desc_ar%get_local_rows() nrow = desc_ar%get_local_rows()
ncol = desc_ac%get_local_cols() ncol = desc_ac%get_local_cols()
call a%csput(nz,ila,jla,val,1,nrow,1,ncol,info) call a%csput(nz,ila,jla,val,ione,nrow,ione,ncol,info)
if (info /= psb_success_) then if (psb_errstatus_fatal()) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
ch_err='psb_coins' call psb_errpush(info,name,a_err='a%csput')
call psb_errpush(info,name,a_err=ch_err)
goto 9999 goto 9999
end if end if
else if (psb_is_asb_desc(desc_ac)) then else if (desc_ac%is_asb()) then
write(psb_err_unit,*) 'Why are you calling me on an assembled desc_ac?' write(psb_err_unit,*) 'Why are you calling me on an assembled desc_ac?'
info = psb_err_invalid_cd_state_ info = psb_err_invalid_cd_state_

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

@ -50,6 +50,7 @@
! !
subroutine psb_dspins(nz,ia,ja,val,a,desc_a,info,rebuild) subroutine psb_dspins(nz,ia,ja,val,a,desc_a,info,rebuild)
use psb_base_mod, psb_protect_name => psb_dspins use psb_base_mod, psb_protect_name => psb_dspins
use psi_mod
implicit none implicit none
!....parameters... !....parameters...
@ -67,10 +68,10 @@ subroutine psb_dspins(nz,ia,ja,val,a,desc_a,info,rebuild)
integer(psb_ipk_), parameter :: relocsz=200 integer(psb_ipk_), parameter :: relocsz=200
logical :: rebuild_ logical :: rebuild_
integer(psb_ipk_), allocatable :: ila(:),jla(:) integer(psb_ipk_), allocatable :: ila(:),jla(:)
character(len=20) :: name, ch_err integer(psb_ipk_) :: ierr(5)
character(len=20) :: name
info = psb_success_ info = psb_success_
if (psb_errstatus_fatal()) return
name = 'psb_dspins' name = 'psb_dspins'
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
@ -116,29 +117,27 @@ subroutine psb_dspins(nz,ia,ja,val,a,desc_a,info,rebuild)
allocate(ila(nz),jla(nz),stat=info) allocate(ila(nz),jla(nz),stat=info)
if (info /= psb_success_) then if (info /= psb_success_) then
ch_err='allocate' ierr(1) = info
call psb_errpush(psb_err_from_subroutine_ai_,name,& call psb_errpush(psb_err_from_subroutine_ai_,name,&
& a_err=ch_err,i_err=(/info,0,0,0,0/)) & a_err='allocate',i_err=ierr)
goto 9999 goto 9999
end if end if
call psb_cdins(nz,ia,ja,desc_a,info,ila=ila,jla=jla) call psb_cdins(nz,ia,ja,desc_a,info,ila=ila,jla=jla)
if (info /= psb_success_) then if (info /= psb_success_) then
ch_err='psb_cdins' ierr(1) = info
call psb_errpush(psb_err_from_subroutine_ai_,name,& call psb_errpush(psb_err_from_subroutine_ai_,name,&
& a_err=ch_err,i_err=(/info,0,0,0,0/)) & a_err='psb_cdins',i_err=ierr)
goto 9999 goto 9999
end if end if
nrow = desc_a%get_local_rows() nrow = desc_a%get_local_rows()
ncol = desc_a%get_local_cols() ncol = desc_a%get_local_cols()
!!$ write(0,*) me,' Into csput valid row entries',count(ila(1:nz)>0),count(jla(1:nz)>0)
if (a%is_bld()) then if (a%is_bld()) then
call a%csput(nz,ila,jla,val,1,nrow,1,ncol,info) call a%csput(nz,ila,jla,val,ione,nrow,ione,ncol,info)
if (info /= psb_success_) then if (info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
ch_err='psb_coins' call psb_errpush(info,name,a_err='a%csput')
call psb_errpush(info,name,a_err=ch_err)
goto 9999 goto 9999
end if end if
else else
@ -152,9 +151,9 @@ subroutine psb_dspins(nz,ia,ja,val,a,desc_a,info,rebuild)
allocate(ila(nz),jla(nz),stat=info) allocate(ila(nz),jla(nz),stat=info)
if (info /= psb_success_) then if (info /= psb_success_) then
ch_err='allocate' ierr(1) = info
call psb_errpush(psb_err_from_subroutine_ai_,name,& call psb_errpush(psb_err_from_subroutine_ai_,name,&
& a_err=ch_err,i_err=(/info,0,0,0,0/)) & a_err='allocate',i_err=ierr)
goto 9999 goto 9999
end if end if
@ -165,11 +164,10 @@ subroutine psb_dspins(nz,ia,ja,val,a,desc_a,info,rebuild)
nrow = desc_a%get_local_rows() nrow = desc_a%get_local_rows()
ncol = desc_a%get_local_cols() ncol = desc_a%get_local_cols()
call a%csput(nz,ila,jla,val,1,nrow,1,ncol,info) call a%csput(nz,ila,jla,val,ione,nrow,ione,ncol,info)
if (info /= psb_success_) then if (info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
ch_err='psb_coins' call psb_errpush(info,name,a_err='a%csput')
call psb_errpush(info,name,a_err=ch_err)
goto 9999 goto 9999
end if end if
@ -195,6 +193,7 @@ end subroutine psb_dspins
subroutine psb_dspins_2desc(nz,ia,ja,val,a,desc_ar,desc_ac,info) subroutine psb_dspins_2desc(nz,ia,ja,val,a,desc_ar,desc_ac,info)
use psb_base_mod, psb_protect_name => psb_dspins_2desc use psb_base_mod, psb_protect_name => psb_dspins_2desc
use psi_mod
implicit none implicit none
!....parameters... !....parameters...
@ -202,7 +201,7 @@ subroutine psb_dspins_2desc(nz,ia,ja,val,a,desc_ar,desc_ac,info)
type(psb_desc_type), intent(inout) :: desc_ac type(psb_desc_type), intent(inout) :: desc_ac
type(psb_dspmat_type), intent(inout) :: a type(psb_dspmat_type), intent(inout) :: a
integer(psb_ipk_), intent(in) :: nz,ia(:),ja(:) integer(psb_ipk_), intent(in) :: nz,ia(:),ja(:)
real(kind=psb_dpk_), intent(in) :: val(:) real(psb_dpk_), intent(in) :: val(:)
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
!locals..... !locals.....
@ -211,7 +210,8 @@ subroutine psb_dspins_2desc(nz,ia,ja,val,a,desc_ar,desc_ac,info)
logical, parameter :: debug=.false. logical, parameter :: debug=.false.
integer(psb_ipk_), parameter :: relocsz=200 integer(psb_ipk_), parameter :: relocsz=200
integer(psb_ipk_), allocatable :: ila(:),jla(:) integer(psb_ipk_), allocatable :: ila(:),jla(:)
character(len=20) :: name, ch_err integer(psb_ipk_) :: ierr(5)
character(len=20) :: name
info = psb_success_ info = psb_success_
if (psb_errstatus_fatal()) return if (psb_errstatus_fatal()) return
@ -258,9 +258,9 @@ subroutine psb_dspins_2desc(nz,ia,ja,val,a,desc_ar,desc_ac,info)
allocate(ila(nz),jla(nz),stat=info) allocate(ila(nz),jla(nz),stat=info)
if (info /= psb_success_) then if (info /= psb_success_) then
ch_err='allocate' ierr(1) = info
call psb_errpush(psb_err_from_subroutine_ai_,name,& call psb_errpush(psb_err_from_subroutine_ai_,name,&
& a_err=ch_err,i_err=(/info,0,0,0,0/)) & a_err='allocate',i_err=ierr)
goto 9999 goto 9999
end if end if
ila(1:nz) = ia(1:nz) ila(1:nz) = ia(1:nz)
@ -270,20 +270,19 @@ subroutine psb_dspins_2desc(nz,ia,ja,val,a,desc_ar,desc_ac,info)
call psb_cdins(nz,ja,desc_ac,info,jla=jla, mask=(ila(1:nz)>0)) call psb_cdins(nz,ja,desc_ac,info,jla=jla, mask=(ila(1:nz)>0))
if (psb_errstatus_fatal()) then if (psb_errstatus_fatal()) then
ch_err='psb_cdins' ierr(1) = info
call psb_errpush(psb_err_from_subroutine_ai_,name,& call psb_errpush(psb_err_from_subroutine_ai_,name,&
& a_err=ch_err,i_err=(/info,0,0,0,0/)) & a_err='psb_cdins',i_err=ierr)
goto 9999 goto 9999
end if end if
nrow = desc_ar%get_local_rows() nrow = desc_ar%get_local_rows()
ncol = desc_ac%get_local_cols() ncol = desc_ac%get_local_cols()
call a%csput(nz,ila,jla,val,1,nrow,1,ncol,info) call a%csput(nz,ila,jla,val,ione,nrow,ione,ncol,info)
if (psb_errstatus_fatal()) then if (psb_errstatus_fatal()) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
ch_err='psb_coins' call psb_errpush(info,name,a_err='a%csput')
call psb_errpush(info,name,a_err=ch_err)
goto 9999 goto 9999
end if end if

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

@ -42,7 +42,7 @@
! ia(:) - integer The row indices of the coefficients. ! ia(:) - integer The row indices of the coefficients.
! ja(:) - integer The column indices of the coefficients. ! ja(:) - integer The column indices of the coefficients.
! val(:) - real The values of the coefficients to be inserted. ! val(:) - real The values of the coefficients to be inserted.
! a - type(psb_sspmat_type). The sparse destination matrix. ! a - type(psb_dspmat_type). The sparse destination matrix.
! desc_a - type(psb_desc_type). The communication descriptor. ! desc_a - type(psb_desc_type). The communication descriptor.
! info - integer. Error code ! info - integer. Error code
! rebuild - logical Allows to reopen a matrix under ! rebuild - logical Allows to reopen a matrix under
@ -50,6 +50,7 @@
! !
subroutine psb_sspins(nz,ia,ja,val,a,desc_a,info,rebuild) subroutine psb_sspins(nz,ia,ja,val,a,desc_a,info,rebuild)
use psb_base_mod, psb_protect_name => psb_sspins use psb_base_mod, psb_protect_name => psb_sspins
use psi_mod
implicit none implicit none
!....parameters... !....parameters...
@ -67,23 +68,22 @@ subroutine psb_sspins(nz,ia,ja,val,a,desc_a,info,rebuild)
integer(psb_ipk_), parameter :: relocsz=200 integer(psb_ipk_), parameter :: relocsz=200
logical :: rebuild_ logical :: rebuild_
integer(psb_ipk_), allocatable :: ila(:),jla(:) integer(psb_ipk_), allocatable :: ila(:),jla(:)
character(len=20) :: name, ch_err integer(psb_ipk_) :: ierr(5)
character(len=20) :: name
info = psb_success_ info = psb_success_
name = 'psb_sspins' name = 'psb_sspins'
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
if (.not.desc_a%is_ok()) then
ictxt = desc_a%get_context()
call psb_info(ictxt, me, np)
if (.not.psb_is_ok_desc(desc_a)) then
info = psb_err_invalid_cd_state_ info = psb_err_invalid_cd_state_
call psb_errpush(info,name) call psb_errpush(info,name)
goto 9999 goto 9999
end if end if
ictxt = desc_a%get_context()
call psb_info(ictxt, me, np)
if (nz < 0) then if (nz < 0) then
info = 1111 info = 1111
call psb_errpush(info,name) call psb_errpush(info,name)
@ -117,28 +117,27 @@ subroutine psb_sspins(nz,ia,ja,val,a,desc_a,info,rebuild)
allocate(ila(nz),jla(nz),stat=info) allocate(ila(nz),jla(nz),stat=info)
if (info /= psb_success_) then if (info /= psb_success_) then
ch_err='allocate' ierr(1) = info
call psb_errpush(psb_err_from_subroutine_ai_,name,& call psb_errpush(psb_err_from_subroutine_ai_,name,&
& a_err=ch_err,i_err=(/info,0,0,0,0/)) & a_err='allocate',i_err=ierr)
goto 9999 goto 9999
end if end if
call psb_cdins(nz,ia,ja,desc_a,info,ila=ila,jla=jla) call psb_cdins(nz,ia,ja,desc_a,info,ila=ila,jla=jla)
if (info /= psb_success_) then if (info /= psb_success_) then
ch_err='psb_cdins' ierr(1) = info
call psb_errpush(psb_err_from_subroutine_ai_,name,& call psb_errpush(psb_err_from_subroutine_ai_,name,&
& a_err=ch_err,i_err=(/info,0,0,0,0/)) & a_err='psb_cdins',i_err=ierr)
goto 9999 goto 9999
end if end if
nrow = desc_a%get_local_rows() nrow = desc_a%get_local_rows()
ncol = desc_a%get_local_cols() ncol = desc_a%get_local_cols()
if (a%is_bld()) then if (a%is_bld()) then
call a%csput(nz,ila,jla,val,1,nrow,1,ncol,info) call a%csput(nz,ila,jla,val,ione,nrow,ione,ncol,info)
if (info /= psb_success_) then if (info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
ch_err='psb_coins' call psb_errpush(info,name,a_err='a%csput')
call psb_errpush(info,name,a_err=ch_err)
goto 9999 goto 9999
end if end if
else else
@ -152,9 +151,9 @@ subroutine psb_sspins(nz,ia,ja,val,a,desc_a,info,rebuild)
allocate(ila(nz),jla(nz),stat=info) allocate(ila(nz),jla(nz),stat=info)
if (info /= psb_success_) then if (info /= psb_success_) then
ch_err='allocate' ierr(1) = info
call psb_errpush(psb_err_from_subroutine_ai_,name,& call psb_errpush(psb_err_from_subroutine_ai_,name,&
& a_err=ch_err,i_err=(/info,0,0,0,0/)) & a_err='allocate',i_err=ierr)
goto 9999 goto 9999
end if end if
@ -165,11 +164,10 @@ subroutine psb_sspins(nz,ia,ja,val,a,desc_a,info,rebuild)
nrow = desc_a%get_local_rows() nrow = desc_a%get_local_rows()
ncol = desc_a%get_local_cols() ncol = desc_a%get_local_cols()
call a%csput(nz,ila,jla,val,1,nrow,1,ncol,info) call a%csput(nz,ila,jla,val,ione,nrow,ione,ncol,info)
if (info /= psb_success_) then if (info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
ch_err='psb_coins' call psb_errpush(info,name,a_err='a%csput')
call psb_errpush(info,name,a_err=ch_err)
goto 9999 goto 9999
end if end if
@ -195,6 +193,7 @@ end subroutine psb_sspins
subroutine psb_sspins_2desc(nz,ia,ja,val,a,desc_ar,desc_ac,info) subroutine psb_sspins_2desc(nz,ia,ja,val,a,desc_ar,desc_ac,info)
use psb_base_mod, psb_protect_name => psb_sspins_2desc use psb_base_mod, psb_protect_name => psb_sspins_2desc
use psi_mod
implicit none implicit none
!....parameters... !....parameters...
@ -202,7 +201,7 @@ subroutine psb_sspins_2desc(nz,ia,ja,val,a,desc_ar,desc_ac,info)
type(psb_desc_type), intent(inout) :: desc_ac type(psb_desc_type), intent(inout) :: desc_ac
type(psb_sspmat_type), intent(inout) :: a type(psb_sspmat_type), intent(inout) :: a
integer(psb_ipk_), intent(in) :: nz,ia(:),ja(:) integer(psb_ipk_), intent(in) :: nz,ia(:),ja(:)
real(kind=psb_spk_), intent(in) :: val(:) real(psb_spk_), intent(in) :: val(:)
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
!locals..... !locals.....
@ -211,28 +210,27 @@ subroutine psb_sspins_2desc(nz,ia,ja,val,a,desc_ar,desc_ac,info)
logical, parameter :: debug=.false. logical, parameter :: debug=.false.
integer(psb_ipk_), parameter :: relocsz=200 integer(psb_ipk_), parameter :: relocsz=200
integer(psb_ipk_), allocatable :: ila(:),jla(:) integer(psb_ipk_), allocatable :: ila(:),jla(:)
character(len=20) :: name, ch_err integer(psb_ipk_) :: ierr(5)
character(len=20) :: name
info = psb_success_ info = psb_success_
name = 'psb_sspins' if (psb_errstatus_fatal()) return
name = 'psb_dspins'
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
if (.not.desc_ar%is_ok()) then
ictxt = desc_ar%get_context()
call psb_info(ictxt, me, np)
if (.not.psb_is_ok_desc(desc_ar)) then
info = psb_err_invalid_cd_state_ info = psb_err_invalid_cd_state_
call psb_errpush(info,name) call psb_errpush(info,name)
goto 9999 goto 9999
end if end if
if (.not.psb_is_ok_desc(desc_ac)) then if (.not.desc_ac%is_ok()) then
info = psb_err_invalid_cd_state_ info = psb_err_invalid_cd_state_
call psb_errpush(info,name) call psb_errpush(info,name)
goto 9999 goto 9999
end if end if
ictxt = desc_ar%get_context()
call psb_info(ictxt, me, np)
if (nz < 0) then if (nz < 0) then
info = 1111 info = 1111
call psb_errpush(info,name) call psb_errpush(info,name)
@ -256,13 +254,13 @@ subroutine psb_sspins_2desc(nz,ia,ja,val,a,desc_ar,desc_ac,info)
end if end if
if (nz == 0) return if (nz == 0) return
if (psb_is_bld_desc(desc_ac)) then if (desc_ac%is_bld()) then
allocate(ila(nz),jla(nz),stat=info) allocate(ila(nz),jla(nz),stat=info)
if (info /= psb_success_) then if (info /= psb_success_) then
ch_err='allocate' ierr(1) = info
call psb_errpush(psb_err_from_subroutine_ai_,name,& call psb_errpush(psb_err_from_subroutine_ai_,name,&
& a_err=ch_err,i_err=(/info,0,0,0,0/)) & a_err='allocate',i_err=ierr)
goto 9999 goto 9999
end if end if
ila(1:nz) = ia(1:nz) ila(1:nz) = ia(1:nz)
@ -271,25 +269,24 @@ subroutine psb_sspins_2desc(nz,ia,ja,val,a,desc_ar,desc_ac,info)
call psb_cdins(nz,ja,desc_ac,info,jla=jla, mask=(ila(1:nz)>0)) call psb_cdins(nz,ja,desc_ac,info,jla=jla, mask=(ila(1:nz)>0))
if (info /= psb_success_) then if (psb_errstatus_fatal()) then
ch_err='psb_cdins' ierr(1) = info
call psb_errpush(psb_err_from_subroutine_ai_,name,& call psb_errpush(psb_err_from_subroutine_ai_,name,&
& a_err=ch_err,i_err=(/info,0,0,0,0/)) & a_err='psb_cdins',i_err=ierr)
goto 9999 goto 9999
end if end if
nrow = desc_ar%get_local_rows() nrow = desc_ar%get_local_rows()
ncol = desc_ac%get_local_cols() ncol = desc_ac%get_local_cols()
call a%csput(nz,ila,jla,val,1,nrow,1,ncol,info) call a%csput(nz,ila,jla,val,ione,nrow,ione,ncol,info)
if (info /= psb_success_) then if (psb_errstatus_fatal()) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
ch_err='psb_coins' call psb_errpush(info,name,a_err='a%csput')
call psb_errpush(info,name,a_err=ch_err)
goto 9999 goto 9999
end if end if
else if (psb_is_asb_desc(desc_ac)) then else if (desc_ac%is_asb()) then
write(psb_err_unit,*) 'Why are you calling me on an assembled desc_ac?' write(psb_err_unit,*) 'Why are you calling me on an assembled desc_ac?'
info = psb_err_invalid_cd_state_ info = psb_err_invalid_cd_state_

77
base/tools/psb_zspins.f90
Unescape Escape View File

@ -50,6 +50,7 @@
! !
subroutine psb_zspins(nz,ia,ja,val,a,desc_a,info,rebuild) subroutine psb_zspins(nz,ia,ja,val,a,desc_a,info,rebuild)
use psb_base_mod, psb_protect_name => psb_zspins use psb_base_mod, psb_protect_name => psb_zspins
use psi_mod
implicit none implicit none
!....parameters... !....parameters...
@ -67,23 +68,22 @@ subroutine psb_zspins(nz,ia,ja,val,a,desc_a,info,rebuild)
integer(psb_ipk_), parameter :: relocsz=200 integer(psb_ipk_), parameter :: relocsz=200
logical :: rebuild_ logical :: rebuild_
integer(psb_ipk_), allocatable :: ila(:),jla(:) integer(psb_ipk_), allocatable :: ila(:),jla(:)
character(len=20) :: name, ch_err integer(psb_ipk_) :: ierr(5)
character(len=20) :: name
info = psb_success_ info = psb_success_
name = 'psb_zspins' name = 'psb_zspins'
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
if (.not.desc_a%is_ok()) then
ictxt = desc_a%get_context()
call psb_info(ictxt, me, np)
if (.not.psb_is_ok_desc(desc_a)) then
info = psb_err_invalid_cd_state_ info = psb_err_invalid_cd_state_
call psb_errpush(info,name) call psb_errpush(info,name)
goto 9999 goto 9999
end if end if
ictxt = desc_a%get_context()
call psb_info(ictxt, me, np)
if (nz < 0) then if (nz < 0) then
info = 1111 info = 1111
call psb_errpush(info,name) call psb_errpush(info,name)
@ -117,28 +117,27 @@ subroutine psb_zspins(nz,ia,ja,val,a,desc_a,info,rebuild)
allocate(ila(nz),jla(nz),stat=info) allocate(ila(nz),jla(nz),stat=info)
if (info /= psb_success_) then if (info /= psb_success_) then
ch_err='allocate' ierr(1) = info
call psb_errpush(psb_err_from_subroutine_ai_,name,& call psb_errpush(psb_err_from_subroutine_ai_,name,&
& a_err=ch_err,i_err=(/info,0,0,0,0/)) & a_err='allocate',i_err=ierr)
goto 9999 goto 9999
end if end if
call psb_cdins(nz,ia,ja,desc_a,info,ila=ila,jla=jla) call psb_cdins(nz,ia,ja,desc_a,info,ila=ila,jla=jla)
if (info /= psb_success_) then if (info /= psb_success_) then
ch_err='psb_cdins' ierr(1) = info
call psb_errpush(psb_err_from_subroutine_ai_,name,& call psb_errpush(psb_err_from_subroutine_ai_,name,&
& a_err=ch_err,i_err=(/info,0,0,0,0/)) & a_err='psb_cdins',i_err=ierr)
goto 9999 goto 9999
end if end if
nrow = desc_a%get_local_rows() nrow = desc_a%get_local_rows()
ncol = desc_a%get_local_cols() ncol = desc_a%get_local_cols()
if (a%is_bld()) then if (a%is_bld()) then
call a%csput(nz,ila,jla,val,1,nrow,1,ncol,info) call a%csput(nz,ila,jla,val,ione,nrow,ione,ncol,info)
if (info /= psb_success_) then if (info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
ch_err='psb_coins' call psb_errpush(info,name,a_err='a%csput')
call psb_errpush(info,name,a_err=ch_err)
goto 9999 goto 9999
end if end if
else else
@ -152,9 +151,9 @@ subroutine psb_zspins(nz,ia,ja,val,a,desc_a,info,rebuild)
allocate(ila(nz),jla(nz),stat=info) allocate(ila(nz),jla(nz),stat=info)
if (info /= psb_success_) then if (info /= psb_success_) then
ch_err='allocate' ierr(1) = info
call psb_errpush(psb_err_from_subroutine_ai_,name,& call psb_errpush(psb_err_from_subroutine_ai_,name,&
& a_err=ch_err,i_err=(/info,0,0,0,0/)) & a_err='allocate',i_err=ierr)
goto 9999 goto 9999
end if end if
@ -165,11 +164,10 @@ subroutine psb_zspins(nz,ia,ja,val,a,desc_a,info,rebuild)
nrow = desc_a%get_local_rows() nrow = desc_a%get_local_rows()
ncol = desc_a%get_local_cols() ncol = desc_a%get_local_cols()
call a%csput(nz,ila,jla,val,1,nrow,1,ncol,info) call a%csput(nz,ila,jla,val,ione,nrow,ione,ncol,info)
if (info /= psb_success_) then if (info /= psb_success_) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
ch_err='psb_coins' call psb_errpush(info,name,a_err='a%csput')
call psb_errpush(info,name,a_err=ch_err)
goto 9999 goto 9999
end if end if
@ -195,6 +193,7 @@ end subroutine psb_zspins
subroutine psb_zspins_2desc(nz,ia,ja,val,a,desc_ar,desc_ac,info) subroutine psb_zspins_2desc(nz,ia,ja,val,a,desc_ar,desc_ac,info)
use psb_base_mod, psb_protect_name => psb_zspins_2desc use psb_base_mod, psb_protect_name => psb_zspins_2desc
use psi_mod
implicit none implicit none
!....parameters... !....parameters...
@ -211,28 +210,27 @@ subroutine psb_zspins_2desc(nz,ia,ja,val,a,desc_ar,desc_ac,info)
logical, parameter :: debug=.false. logical, parameter :: debug=.false.
integer(psb_ipk_), parameter :: relocsz=200 integer(psb_ipk_), parameter :: relocsz=200
integer(psb_ipk_), allocatable :: ila(:),jla(:) integer(psb_ipk_), allocatable :: ila(:),jla(:)
character(len=20) :: name, ch_err integer(psb_ipk_) :: ierr(5)
character(len=20) :: name
info = psb_success_ info = psb_success_
name = 'psb_zspins' if (psb_errstatus_fatal()) return
name = 'psb_dspins'
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
if (.not.desc_ar%is_ok()) then
ictxt = desc_ar%get_context()
call psb_info(ictxt, me, np)
if (.not.psb_is_ok_desc(desc_ar)) then
info = psb_err_invalid_cd_state_ info = psb_err_invalid_cd_state_
call psb_errpush(info,name) call psb_errpush(info,name)
goto 9999 goto 9999
end if end if
if (.not.psb_is_ok_desc(desc_ac)) then if (.not.desc_ac%is_ok()) then
info = psb_err_invalid_cd_state_ info = psb_err_invalid_cd_state_
call psb_errpush(info,name) call psb_errpush(info,name)
goto 9999 goto 9999
end if end if
ictxt = desc_ar%get_context()
call psb_info(ictxt, me, np)
if (nz < 0) then if (nz < 0) then
info = 1111 info = 1111
call psb_errpush(info,name) call psb_errpush(info,name)
@ -256,13 +254,13 @@ subroutine psb_zspins_2desc(nz,ia,ja,val,a,desc_ar,desc_ac,info)
end if end if
if (nz == 0) return if (nz == 0) return
if (psb_is_bld_desc(desc_ac)) then if (desc_ac%is_bld()) then
allocate(ila(nz),jla(nz),stat=info) allocate(ila(nz),jla(nz),stat=info)
if (info /= psb_success_) then if (info /= psb_success_) then
ch_err='allocate' ierr(1) = info
call psb_errpush(psb_err_from_subroutine_ai_,name,& call psb_errpush(psb_err_from_subroutine_ai_,name,&
& a_err=ch_err,i_err=(/info,0,0,0,0/)) & a_err='allocate',i_err=ierr)
goto 9999 goto 9999
end if end if
ila(1:nz) = ia(1:nz) ila(1:nz) = ia(1:nz)
@ -271,25 +269,24 @@ subroutine psb_zspins_2desc(nz,ia,ja,val,a,desc_ar,desc_ac,info)
call psb_cdins(nz,ja,desc_ac,info,jla=jla, mask=(ila(1:nz)>0)) call psb_cdins(nz,ja,desc_ac,info,jla=jla, mask=(ila(1:nz)>0))
if (info /= psb_success_) then if (psb_errstatus_fatal()) then
ch_err='psb_cdins' ierr(1) = info
call psb_errpush(psb_err_from_subroutine_ai_,name,& call psb_errpush(psb_err_from_subroutine_ai_,name,&
& a_err=ch_err,i_err=(/info,0,0,0,0/)) & a_err='psb_cdins',i_err=ierr)
goto 9999 goto 9999
end if end if
nrow = desc_ar%get_local_rows() nrow = desc_ar%get_local_rows()
ncol = desc_ac%get_local_cols() ncol = desc_ac%get_local_cols()
call a%csput(nz,ila,jla,val,1,nrow,1,ncol,info) call a%csput(nz,ila,jla,val,ione,nrow,ione,ncol,info)
if (info /= psb_success_) then if (psb_errstatus_fatal()) then
info=psb_err_from_subroutine_ info=psb_err_from_subroutine_
ch_err='psb_coins' call psb_errpush(info,name,a_err='a%csput')
call psb_errpush(info,name,a_err=ch_err)
goto 9999 goto 9999
end if end if
else if (psb_is_asb_desc(desc_ac)) then else if (desc_ac%is_asb()) then
write(psb_err_unit,*) 'Why are you calling me on an assembled desc_ac?' write(psb_err_unit,*) 'Why are you calling me on an assembled desc_ac?'
info = psb_err_invalid_cd_state_ info = psb_err_invalid_cd_state_

Write Preview
Loading…
Cancel
Save