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,&
& counter_t,n_elem,i_ovr,jj,proc_id,isz, nl, &
& 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 :: 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(:)
logical, allocatable, target :: lmask(:)
logical, pointer :: mask_(:)
integer(psb_ipk_) :: ierr(5)
integer(psb_ipk_) :: debug_level, debug_unit
character(len=20) :: name, ch_err
character(len=20) :: name
name='psb_cd_lstext'
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()
ictxt = desc_a%get_context()
icomm = desc_a%get_mpic()
Call psb_info(ictxt, me, np)
If (debug_level >= psb_debug_outer_) &
& Write(debug_unit,*) me,' ',trim(name),': start',size(in_list)
m = desc_a%get_local_rows()
n_row = desc_a%get_local_rows()
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)
if (info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_cdcpy'
call psb_errpush(info,name,a_err=ch_err)
call psb_errpush(info,name,a_err='psb_cdcpy')
goto 9999
end if
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)
if (info /= psb_success_) then
ch_err='sp_free'
call psb_errpush(psb_err_from_subroutine_ai_,name,a_err=ch_err,i_err=(/info,0,0,0,0/))
ierr(1) = info
call psb_errpush(psb_err_from_subroutine_ai_,name,a_err='sp_free',&
& i_err=ierr)
goto 9999
end if

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

@ -46,11 +46,12 @@ Subroutine psb_cd_switch_ovl_indxmap(desc,info)
! .. Local Scalars ..
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_) :: debug_level, debug_unit
character(len=20) :: name, ch_err
integer(psb_ipk_) :: debug_level, debug_unit, ierr(5)
integer(psb_mpik_) :: iictxt
character(len=20) :: name, ch_err
name='cd_switch_ovl_indxmap'
info = psb_success_
@ -59,13 +60,12 @@ Subroutine psb_cd_switch_ovl_indxmap(desc,info)
debug_level = psb_get_debug_level()
ictxt = desc%get_context()
icomm = desc%get_mpic()
Call psb_info(ictxt, me, np)
If (debug_level >= psb_debug_outer_) &
& Write(debug_unit,*) me,' ',trim(name),&
& ': start'
iictxt = ictxt
mglob = desc%get_global_rows()
n_row = desc%get_local_rows()
n_col = desc%get_local_cols()
@ -81,10 +81,10 @@ Subroutine psb_cd_switch_ovl_indxmap(desc,info)
end do
call desc%indxmap%l2g(vl(1:n_col),info)
!!$ write(0,*) 'from l2g' ,info,n_row,n_Col
if (info /= psb_success_) then
ierr(1)=info
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
end if
@ -97,19 +97,15 @@ Subroutine psb_cd_switch_ovl_indxmap(desc,info)
allocate(psb_list_map :: desc%indxmap, stat=info)
end if
!!$ write(0,*) 'from allocate indxmap' ,info
if (info == psb_success_)&
& call desc%indxmap%init(ictxt,vl(1:n_row),info)
!!$ write(0,*) 'from indxmap%init' ,info
& call desc%indxmap%init(iictxt,vl(1:n_row),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_) &
& 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
ierr(1) = info
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
end if
if (n_row /= desc%indxmap%get_lr()) then

83
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
logical :: rebuild_
integer(psb_ipk_), allocatable :: ila(:),jla(:)
character(len=20) :: name, ch_err
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name
info = psb_success_
name = 'psb_cspins'
call psb_erractionsave(err_act)
if (.not.desc_a%is_ok()) then
info = psb_err_invalid_cd_state_
call psb_errpush(info,name)
goto 9999
end if
ictxt = desc_a%get_context()
call psb_info(ictxt, me, np)
if (.not.psb_is_ok_desc(desc_a)) then
info = psb_err_invalid_cd_state_
call psb_errpush(info,name)
goto 9999
endif
if (nz < 0) then
info = 1111
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)
if (info /= psb_success_) then
ch_err='allocate'
ierr(1) = info
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
end if
call psb_cdins(nz,ia,ja,desc_a,info,ila=ila,jla=jla)
if (info /= psb_success_) then
ch_err='psb_cdins'
ierr(1) = info
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
end if
nrow = desc_a%get_local_rows()
ncol = desc_a%get_local_cols()
if (a%is_bld()) then
call a%csput(nz,ila,jla,val,1,nrow,1,ncol,info)
call a%csput(nz,ila,jla,val,ione,nrow,ione,ncol,info)
if (info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_coins'
call psb_errpush(info,name,a_err=ch_err)
call psb_errpush(info,name,a_err='a%csput')
goto 9999
end if
else
@ -153,9 +151,9 @@ subroutine psb_cspins(nz,ia,ja,val,a,desc_a,info,rebuild)
allocate(ila(nz),jla(nz),stat=info)
if (info /= psb_success_) then
ch_err='allocate'
ierr(1) = info
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
end if
@ -166,11 +164,10 @@ subroutine psb_cspins(nz,ia,ja,val,a,desc_a,info,rebuild)
nrow = desc_a%get_local_rows()
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
info=psb_err_from_subroutine_
ch_err='psb_coins'
call psb_errpush(info,name,a_err=ch_err)
call psb_errpush(info,name,a_err='a%csput')
goto 9999
end if
@ -213,27 +210,26 @@ subroutine psb_cspins_2desc(nz,ia,ja,val,a,desc_ar,desc_ac,info)
logical, parameter :: debug=.false.
integer(psb_ipk_), parameter :: relocsz=200
integer(psb_ipk_), allocatable :: ila(:),jla(:)
character(len=20) :: name, ch_err
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name
info = psb_success_
name = 'psb_cspins'
if (psb_errstatus_fatal()) return
name = 'psb_dspins'
call psb_erractionsave(err_act)
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_
if (.not.desc_ar%is_ok()) then
info = psb_err_invalid_cd_state_
call psb_errpush(info,name)
goto 9999
endif
if (.not.psb_is_ok_desc(desc_ac)) then
end if
if (.not.desc_ac%is_ok()) then
info = psb_err_invalid_cd_state_
call psb_errpush(info,name)
goto 9999
endif
end if
ictxt = desc_ar%get_context()
call psb_info(ictxt, me, np)
if (nz < 0) then
info = 1111
@ -258,13 +254,13 @@ subroutine psb_cspins_2desc(nz,ia,ja,val,a,desc_ar,desc_ac,info)
end if
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)
if (info /= psb_success_) then
ch_err='allocate'
ierr(1) = info
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
end if
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))
if (info /= psb_success_) then
ch_err='psb_cdins'
if (psb_errstatus_fatal()) then
ierr(1) = info
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
end if
nrow = desc_ar%get_local_rows()
ncol = desc_ac%get_local_cols()
call a%csput(nz,ila,jla,val,1,nrow,1,ncol,info)
if (info /= psb_success_) then
call a%csput(nz,ila,jla,val,ione,nrow,ione,ncol,info)
if (psb_errstatus_fatal()) then
info=psb_err_from_subroutine_
ch_err='psb_coins'
call psb_errpush(info,name,a_err=ch_err)
call psb_errpush(info,name,a_err='a%csput')
goto 9999
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?'
info = psb_err_invalid_cd_state_

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

@ -41,7 +41,7 @@
! nz - integer. The number of points to insert.
! ia(:) - integer The row 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_dspmat_type). The sparse destination matrix.
! desc_a - type(psb_desc_type). The communication descriptor.
! info - integer. Error code
@ -50,15 +50,16 @@
!
subroutine psb_dspins(nz,ia,ja,val,a,desc_a,info,rebuild)
use psb_base_mod, psb_protect_name => psb_dspins
use psi_mod
implicit none
!....parameters...
type(psb_desc_type), intent(inout) :: desc_a
type(psb_desc_type), intent(inout) :: desc_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(psb_dpk_), intent(in) :: val(:)
integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: rebuild
integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: rebuild
!locals.....
integer(psb_ipk_) :: nrow, err_act, ncol, spstate
@ -67,10 +68,10 @@ subroutine psb_dspins(nz,ia,ja,val,a,desc_a,info,rebuild)
integer(psb_ipk_), parameter :: relocsz=200
logical :: rebuild_
integer(psb_ipk_), allocatable :: ila(:),jla(:)
character(len=20) :: name, ch_err
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name
info = psb_success_
if (psb_errstatus_fatal()) return
name = 'psb_dspins'
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)
if (info /= psb_success_) then
ch_err='allocate'
ierr(1) = info
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
end if
call psb_cdins(nz,ia,ja,desc_a,info,ila=ila,jla=jla)
if (info /= psb_success_) then
ch_err='psb_cdins'
ierr(1) = info
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
end if
nrow = desc_a%get_local_rows()
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
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
info=psb_err_from_subroutine_
ch_err='psb_coins'
call psb_errpush(info,name,a_err=ch_err)
call psb_errpush(info,name,a_err='a%csput')
goto 9999
end if
else
@ -152,9 +151,9 @@ subroutine psb_dspins(nz,ia,ja,val,a,desc_a,info,rebuild)
allocate(ila(nz),jla(nz),stat=info)
if (info /= psb_success_) then
ch_err='allocate'
ierr(1) = info
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
end if
@ -165,11 +164,10 @@ subroutine psb_dspins(nz,ia,ja,val,a,desc_a,info,rebuild)
nrow = desc_a%get_local_rows()
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
info=psb_err_from_subroutine_
ch_err='psb_coins'
call psb_errpush(info,name,a_err=ch_err)
call psb_errpush(info,name,a_err='a%csput')
goto 9999
end if
@ -195,6 +193,7 @@ end subroutine psb_dspins
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 psi_mod
implicit none
!....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_dspmat_type), intent(inout) :: a
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
!locals.....
@ -211,7 +210,8 @@ subroutine psb_dspins_2desc(nz,ia,ja,val,a,desc_ar,desc_ac,info)
logical, parameter :: debug=.false.
integer(psb_ipk_), parameter :: relocsz=200
integer(psb_ipk_), allocatable :: ila(:),jla(:)
character(len=20) :: name, ch_err
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name
info = psb_success_
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)
if (info /= psb_success_) then
ch_err='allocate'
ierr(1) = info
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
end if
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))
if (psb_errstatus_fatal()) then
ch_err='psb_cdins'
ierr(1) = info
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
end if
nrow = desc_ar%get_local_rows()
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
info=psb_err_from_subroutine_
ch_err='psb_coins'
call psb_errpush(info,name,a_err=ch_err)
call psb_errpush(info,name,a_err='a%csput')
goto 9999
end if

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

@ -41,8 +41,8 @@
! nz - integer. The number of points to insert.
! ia(:) - integer The row indices of the coefficients.
! ja(:) - integer The column indices of the coefficients.
! val(:) - real The values of the coefficients to be inserted.
! a - type(psb_sspmat_type). The sparse destination matrix.
! val(:) - real The values of the coefficients to be inserted.
! a - type(psb_dspmat_type). The sparse destination matrix.
! desc_a - type(psb_desc_type). The communication descriptor.
! info - integer. Error code
! rebuild - logical Allows to reopen a matrix under
@ -50,15 +50,16 @@
!
subroutine psb_sspins(nz,ia,ja,val,a,desc_a,info,rebuild)
use psb_base_mod, psb_protect_name => psb_sspins
use psi_mod
implicit none
!....parameters...
type(psb_desc_type), intent(inout) :: desc_a
type(psb_desc_type), intent(inout) :: desc_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(psb_spk_), intent(in) :: val(:)
integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: rebuild
integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: rebuild
!locals.....
integer(psb_ipk_) :: nrow, err_act, ncol, spstate
@ -67,23 +68,22 @@ subroutine psb_sspins(nz,ia,ja,val,a,desc_a,info,rebuild)
integer(psb_ipk_), parameter :: relocsz=200
logical :: rebuild_
integer(psb_ipk_), allocatable :: ila(:),jla(:)
character(len=20) :: name, ch_err
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name
info = psb_success_
name = 'psb_sspins'
call psb_erractionsave(err_act)
if (.not.desc_a%is_ok()) then
info = psb_err_invalid_cd_state_
call psb_errpush(info,name)
goto 9999
end if
ictxt = desc_a%get_context()
call psb_info(ictxt, me, np)
if (.not.psb_is_ok_desc(desc_a)) then
info = psb_err_invalid_cd_state_
call psb_errpush(info,name)
goto 9999
endif
if (nz < 0) then
info = 1111
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)
if (info /= psb_success_) then
ch_err='allocate'
ierr(1) = info
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
end if
call psb_cdins(nz,ia,ja,desc_a,info,ila=ila,jla=jla)
if (info /= psb_success_) then
ch_err='psb_cdins'
ierr(1) = info
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
end if
nrow = desc_a%get_local_rows()
ncol = desc_a%get_local_cols()
if (a%is_bld()) then
call a%csput(nz,ila,jla,val,1,nrow,1,ncol,info)
call a%csput(nz,ila,jla,val,ione,nrow,ione,ncol,info)
if (info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_coins'
call psb_errpush(info,name,a_err=ch_err)
call psb_errpush(info,name,a_err='a%csput')
goto 9999
end if
else
@ -152,9 +151,9 @@ subroutine psb_sspins(nz,ia,ja,val,a,desc_a,info,rebuild)
allocate(ila(nz),jla(nz),stat=info)
if (info /= psb_success_) then
ch_err='allocate'
ierr(1) = info
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
end if
@ -165,11 +164,10 @@ subroutine psb_sspins(nz,ia,ja,val,a,desc_a,info,rebuild)
nrow = desc_a%get_local_rows()
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
info=psb_err_from_subroutine_
ch_err='psb_coins'
call psb_errpush(info,name,a_err=ch_err)
call psb_errpush(info,name,a_err='a%csput')
goto 9999
end if
@ -195,6 +193,7 @@ end subroutine psb_sspins
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 psi_mod
implicit none
!....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_sspmat_type), intent(inout) :: a
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
!locals.....
@ -211,27 +210,26 @@ subroutine psb_sspins_2desc(nz,ia,ja,val,a,desc_ar,desc_ac,info)
logical, parameter :: debug=.false.
integer(psb_ipk_), parameter :: relocsz=200
integer(psb_ipk_), allocatable :: ila(:),jla(:)
character(len=20) :: name, ch_err
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name
info = psb_success_
name = 'psb_sspins'
if (psb_errstatus_fatal()) return
name = 'psb_dspins'
call psb_erractionsave(err_act)
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_
if (.not.desc_ar%is_ok()) then
info = psb_err_invalid_cd_state_
call psb_errpush(info,name)
goto 9999
endif
if (.not.psb_is_ok_desc(desc_ac)) then
end if
if (.not.desc_ac%is_ok()) then
info = psb_err_invalid_cd_state_
call psb_errpush(info,name)
goto 9999
endif
end if
ictxt = desc_ar%get_context()
call psb_info(ictxt, me, np)
if (nz < 0) then
info = 1111
@ -256,13 +254,13 @@ subroutine psb_sspins_2desc(nz,ia,ja,val,a,desc_ar,desc_ac,info)
end if
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)
if (info /= psb_success_) then
ch_err='allocate'
ierr(1) = info
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
end if
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))
if (info /= psb_success_) then
ch_err='psb_cdins'
if (psb_errstatus_fatal()) then
ierr(1) = info
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
end if
nrow = desc_ar%get_local_rows()
ncol = desc_ac%get_local_cols()
call a%csput(nz,ila,jla,val,1,nrow,1,ncol,info)
if (info /= psb_success_) then
call a%csput(nz,ila,jla,val,ione,nrow,ione,ncol,info)
if (psb_errstatus_fatal()) then
info=psb_err_from_subroutine_
ch_err='psb_coins'
call psb_errpush(info,name,a_err=ch_err)
call psb_errpush(info,name,a_err='a%csput')
goto 9999
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?'
info = psb_err_invalid_cd_state_

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

@ -50,15 +50,16 @@
!
subroutine psb_zspins(nz,ia,ja,val,a,desc_a,info,rebuild)
use psb_base_mod, psb_protect_name => psb_zspins
use psi_mod
implicit none
!....parameters...
type(psb_desc_type), intent(inout) :: desc_a
type(psb_desc_type), intent(inout) :: desc_a
type(psb_zspmat_type), intent(inout) :: a
integer(psb_ipk_), intent(in) :: nz,ia(:),ja(:)
complex(psb_dpk_), intent(in) :: val(:)
integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: rebuild
integer(psb_ipk_), intent(in) :: nz,ia(:),ja(:)
complex(psb_dpk_), intent(in) :: val(:)
integer(psb_ipk_), intent(out) :: info
logical, intent(in), optional :: rebuild
!locals.....
integer(psb_ipk_) :: nrow, err_act, ncol, spstate
@ -67,23 +68,22 @@ subroutine psb_zspins(nz,ia,ja,val,a,desc_a,info,rebuild)
integer(psb_ipk_), parameter :: relocsz=200
logical :: rebuild_
integer(psb_ipk_), allocatable :: ila(:),jla(:)
character(len=20) :: name, ch_err
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name
info = psb_success_
name = 'psb_zspins'
call psb_erractionsave(err_act)
if (.not.desc_a%is_ok()) then
info = psb_err_invalid_cd_state_
call psb_errpush(info,name)
goto 9999
end if
ictxt = desc_a%get_context()
call psb_info(ictxt, me, np)
if (.not.psb_is_ok_desc(desc_a)) then
info = psb_err_invalid_cd_state_
call psb_errpush(info,name)
goto 9999
endif
if (nz < 0) then
info = 1111
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)
if (info /= psb_success_) then
ch_err='allocate'
ierr(1) = info
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
end if
call psb_cdins(nz,ia,ja,desc_a,info,ila=ila,jla=jla)
if (info /= psb_success_) then
ch_err='psb_cdins'
ierr(1) = info
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
end if
nrow = desc_a%get_local_rows()
ncol = desc_a%get_local_cols()
if (a%is_bld()) then
call a%csput(nz,ila,jla,val,1,nrow,1,ncol,info)
call a%csput(nz,ila,jla,val,ione,nrow,ione,ncol,info)
if (info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='psb_coins'
call psb_errpush(info,name,a_err=ch_err)
call psb_errpush(info,name,a_err='a%csput')
goto 9999
end if
else
@ -152,9 +151,9 @@ subroutine psb_zspins(nz,ia,ja,val,a,desc_a,info,rebuild)
allocate(ila(nz),jla(nz),stat=info)
if (info /= psb_success_) then
ch_err='allocate'
ierr(1) = info
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
end if
@ -165,11 +164,10 @@ subroutine psb_zspins(nz,ia,ja,val,a,desc_a,info,rebuild)
nrow = desc_a%get_local_rows()
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
info=psb_err_from_subroutine_
ch_err='psb_coins'
call psb_errpush(info,name,a_err=ch_err)
call psb_errpush(info,name,a_err='a%csput')
goto 9999
end if
@ -195,6 +193,7 @@ end subroutine psb_zspins
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 psi_mod
implicit none
!....parameters...
@ -211,27 +210,26 @@ subroutine psb_zspins_2desc(nz,ia,ja,val,a,desc_ar,desc_ac,info)
logical, parameter :: debug=.false.
integer(psb_ipk_), parameter :: relocsz=200
integer(psb_ipk_), allocatable :: ila(:),jla(:)
character(len=20) :: name, ch_err
integer(psb_ipk_) :: ierr(5)
character(len=20) :: name
info = psb_success_
name = 'psb_zspins'
if (psb_errstatus_fatal()) return
name = 'psb_dspins'
call psb_erractionsave(err_act)
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_
if (.not.desc_ar%is_ok()) then
info = psb_err_invalid_cd_state_
call psb_errpush(info,name)
goto 9999
endif
if (.not.psb_is_ok_desc(desc_ac)) then
end if
if (.not.desc_ac%is_ok()) then
info = psb_err_invalid_cd_state_
call psb_errpush(info,name)
goto 9999
endif
end if
ictxt = desc_ar%get_context()
call psb_info(ictxt, me, np)
if (nz < 0) then
info = 1111
@ -256,13 +254,13 @@ subroutine psb_zspins_2desc(nz,ia,ja,val,a,desc_ar,desc_ac,info)
end if
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)
if (info /= psb_success_) then
ch_err='allocate'
ierr(1) = info
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
end if
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))
if (info /= psb_success_) then
ch_err='psb_cdins'
if (psb_errstatus_fatal()) then
ierr(1) = info
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
end if
nrow = desc_ar%get_local_rows()
ncol = desc_ac%get_local_cols()
call a%csput(nz,ila,jla,val,1,nrow,1,ncol,info)
if (info /= psb_success_) then
call a%csput(nz,ila,jla,val,ione,nrow,ione,ncol,info)
if (psb_errstatus_fatal()) then
info=psb_err_from_subroutine_
ch_err='psb_coins'
call psb_errpush(info,name,a_err=ch_err)
call psb_errpush(info,name,a_err='a%csput')
goto 9999
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?'
info = psb_err_invalid_cd_state_

Write Preview
Loading…
Cancel
Save