fdurastante/psblas3
1
0
Fork 0
mirror of https://github.com/sfilippone/psblas3.git synced 2026-10-19 04:12:09 +00:00
Code Issues Packages Projects Releases Wiki Activity

psblas3:

Browse Source 
base/tools/psb_callc.f90
 base/tools/psb_casb.f90
 base/tools/psb_ccdbldext.F90
 base/tools/psb_cfree.f90
 base/tools/psb_cins.f90
 base/tools/psb_cspalloc.f90
 base/tools/psb_cspasb.f90
 base/tools/psb_cspfree.f90
 base/tools/psb_csphalo.F90
 base/tools/psb_cspins.f90
 base/tools/psb_d_map.f90
 base/tools/psb_dallc.f90
 base/tools/psb_dasb.f90
 base/tools/psb_dcdbldext.F90
 base/tools/psb_dfree.f90
 base/tools/psb_dins.f90
 base/tools/psb_dspalloc.f90
 base/tools/psb_dspasb.f90
 base/tools/psb_dspfree.f90
 base/tools/psb_dsphalo.F90
 base/tools/psb_dspins.f90
 base/tools/psb_sallc.f90
 base/tools/psb_sasb.f90
 base/tools/psb_scdbldext.F90
 base/tools/psb_sfree.f90
 base/tools/psb_sins.f90
 base/tools/psb_sspalloc.f90
 base/tools/psb_sspasb.f90
 base/tools/psb_sspfree.f90
 base/tools/psb_ssphalo.F90
 base/tools/psb_sspins.f90
 base/tools/psb_zallc.f90
 base/tools/psb_zasb.f90
 base/tools/psb_zcdbldext.F90
 base/tools/psb_zfree.f90
 base/tools/psb_zins.f90
 base/tools/psb_zspalloc.f90
 base/tools/psb_zspasb.f90
 base/tools/psb_zspfree.f90
 base/tools/psb_zsphalo.F90
 base/tools/psb_zspins.f90


New error handling
This commit is contained in:
Salvatore Filippone
2014-12-21 09:46:59 +00:00
parent 0d49855313
commit e48b9cfcea
41 changed files with 384 additions and 843 deletions
Download Patch File Download Diff File Expand all files Collapse all files
base/tools/psb_callc.f90
+13 -28
View File
@@ -111,7 +111,7 @@ subroutine psb_calloc(x, desc_a, info, n, lb)
call psb_errpush(info,name,int_err,a_err='Invalid desc_a')
goto 9999
endif
call psb_realloc(nr,n_,x,info,lb2=lb)
if (info /= psb_success_) then
info=psb_err_alloc_request_
@@ -119,18 +119,14 @@ subroutine psb_calloc(x, desc_a, info, n, lb)
call psb_errpush(info,name,int_err,a_err='complex(psb_spk_)')
goto 9999
endif
x(:,:) = czero
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_abort_) then
call psb_error(ictxt)
return
end if
9999 call psb_error_handler(ictxt,err_act)
return
end subroutine psb_calloc
@@ -228,7 +224,7 @@ subroutine psb_callocv(x, desc_a,info,n)
call psb_errpush(info,name,int_err,a_err='Invalid desc_a')
goto 9999
endif
call psb_realloc(nr,x,info)
if (info /= psb_success_) then
info=psb_err_alloc_request_
@@ -236,22 +232,19 @@ subroutine psb_callocv(x, desc_a,info,n)
call psb_errpush(info,name,int_err,a_err='complex(psb_spk_)')
goto 9999
endif
x(:) = czero
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_abort_) then
call psb_error(ictxt)
return
end if
9999 call psb_error_handler(ictxt,err_act)
return
end subroutine psb_callocv
subroutine psb_calloc_vect(x, desc_a,info,n)
use psb_base_mod, psb_protect_name => psb_calloc_vect
use psi_mod
@@ -319,12 +312,8 @@ subroutine psb_calloc_vect(x, desc_a,info,n)
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_abort_) then
call psb_error(ictxt)
return
end if
9999 call psb_error_handler(ictxt,err_act)
return
end subroutine psb_calloc_vect
@@ -426,12 +415,8 @@ subroutine psb_calloc_vect_r2(x, desc_a,info,n,lb)
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_abort_) then
call psb_error(ictxt)
return
end if
9999 call psb_error_handler(ictxt,err_act)
return
end subroutine psb_calloc_vect_r2
base/tools/psb_casb.f90
+10 -27
View File
@@ -83,8 +83,7 @@ subroutine psb_casb(x, desc_a, info)
goto 9999
else if (.not.psb_is_asb_desc(desc_a)) then
if (debug_level >= psb_debug_ext_) &
& write(debug_unit,*) me,' ',trim(name),' error ',&
& desc_a%get_dectype()
& write(debug_unit,*) me,' ',trim(name),' error '
info = psb_err_input_matrix_unassembled_
call psb_errpush(info,name)
goto 9999
@@ -122,12 +121,8 @@ subroutine psb_casb(x, desc_a, info)
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_abort_) then
call psb_error(ictxt)
return
end if
9999 call psb_error_handler(ictxt,err_act)
return
end subroutine psb_casb
@@ -240,16 +235,13 @@ subroutine psb_casbv(x, desc_a, info)
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_abort_) then
call psb_error(ictxt)
return
end if
9999 call psb_error_handler(ictxt,err_act)
return
end subroutine psb_casbv
subroutine psb_casb_vect(x, desc_a, info, mold, scratch)
use psb_base_mod, psb_protect_name => psb_casb_vect
implicit none
@@ -319,12 +311,8 @@ subroutine psb_casb_vect(x, desc_a, info, mold, scratch)
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_abort_) then
call psb_error(ictxt)
return
end if
9999 call psb_error_handler(ictxt,err_act)
return
end subroutine psb_casb_vect
@@ -385,7 +373,6 @@ subroutine psb_casb_vect_r2(x, desc_a, info, mold, scratch)
end do
else
do i=1, n
call x(i)%asb(ncol,info)
if (info /= 0) exit
@@ -408,12 +395,8 @@ subroutine psb_casb_vect_r2(x, desc_a, info, mold, scratch)
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_abort_) then
call psb_error(ictxt)
return
end if
9999 call psb_error_handler(ictxt,err_act)
return
end subroutine psb_casb_vect_r2
base/tools/psb_ccdbldext.F90
+12 -16
View File
@@ -433,7 +433,7 @@ Subroutine psb_ccdbldext(a,desc_a,novr,desc_ov,info, extype)
call psb_errpush(info,name,a_err='csget')
goto 9999
end if
call psb_ensure_size((idxs+tot_elem+n_elem),works,info)
if (info /= psb_success_) then
info=psb_err_from_subroutine_
@@ -527,7 +527,7 @@ Subroutine psb_ccdbldext(a,desc_a,novr,desc_ov,info, extype)
end if
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& ': going for first idx_cnv', desc_ov%indxmap%get_state()
& ': going for first idx_cnv', desc_ov%indxmap%get_state()
call desc_ov%indxmap%g2l(workr(1:iszr),maskr(1:iszr),info)
iszs = count(maskr(1:iszr)<=0)
@@ -541,21 +541,21 @@ Subroutine psb_ccdbldext(a,desc_a,novr,desc_ov,info, extype)
end do
! Eliminate duplicates from request
call psb_msort_unique(works(1:j),iszs)
!
! fnd_owner on desc_a because we want the procs who
! owned the rows from the beginning!
!
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& ': going for fnd_owner', desc_ov%indxmap%get_state()
& ': going for fnd_owner', desc_ov%indxmap%get_state()
call desc_a%fnd_owner(works(1:iszs),temp,info)
n_col = desc_ov%get_local_cols()
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& ': Done fnd_owner', desc_ov%indxmap%get_state()
& ': Done fnd_owner', desc_ov%indxmap%get_state()
do i=1,iszs
idx = works(i)
n_col = desc_ov%get_local_cols()
@@ -567,14 +567,14 @@ Subroutine psb_ccdbldext(a,desc_a,novr,desc_ov,info, extype)
! will be less than those for HALO(J) whenever I<J
!
proc_id = temp(i)
call psb_ensure_size((counter_t+3),t_halo_in,info,pad=-ione)
if (info /= psb_success_) then
info=psb_err_from_subroutine_
call psb_errpush(info,name,a_err='psb_ensure_size')
goto 9999
end if
t_halo_in(counter_t) = proc_id
t_halo_in(counter_t+1) = 1
t_halo_in(counter_t+2) = lidx
@@ -695,7 +695,7 @@ Subroutine psb_ccdbldext(a,desc_a,novr,desc_ov,info, extype)
call psb_errpush(psb_err_from_subroutine_,name,a_err='icdasdb')
goto 9999
end if
call psb_cd_set_ovl_asb(desc_ov,info)
if (info == psb_success_) then
@@ -716,13 +716,9 @@ Subroutine psb_ccdbldext(a,desc_a,novr,desc_ov,info, extype)
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_abort_) then
call psb_error(ictxt)
return
end if
Return
9999 call psb_error_handler(ictxt,err_act)
return
End Subroutine psb_ccdbldext
base/tools/psb_cfree.f90
+23 -41
View File
@@ -73,9 +73,9 @@ subroutine psb_cfree(x, desc_a, info)
endif
if (.not.allocated(x)) then
info=psb_err_forgot_spall_
call psb_errpush(info,name)
goto 9999
info=psb_err_forgot_spall_
call psb_errpush(info,name)
goto 9999
end if
!deallocate x
@@ -85,17 +85,13 @@ subroutine psb_cfree(x, desc_a, info)
call psb_errpush(info,name)
goto 9999
endif
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_abort_) then
call psb_error(ictxt)
return
end if
9999 call psb_error_handler(ictxt,err_act)
return
end subroutine psb_cfree
@@ -129,44 +125,38 @@ subroutine psb_cfreev(x, desc_a, info)
if (.not.psb_is_ok_desc(desc_a)) then
info=psb_err_forgot_spall_
call psb_errpush(info,name)
goto 9999
info=psb_err_forgot_spall_
call psb_errpush(info,name)
goto 9999
end if
ictxt=desc_a%get_context()
call psb_info(ictxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
if (.not.allocated(x)) then
info=psb_err_forgot_spall_
call psb_errpush(info,name)
goto 9999
info=psb_err_forgot_spall_
call psb_errpush(info,name)
goto 9999
end if
!deallocate x
deallocate(x,stat=info)
if (info /= psb_no_err_) then
info=psb_err_alloc_dealloc_
call psb_errpush(info,name)
info=psb_err_alloc_dealloc_
call psb_errpush(info,name)
endif
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
9999 call psb_error_handler(ictxt,err_act)
if (err_act == psb_act_ret_) then
return
else
call psb_error(ictxt)
end if
return
end subroutine psb_cfreev
@@ -219,12 +209,8 @@ subroutine psb_cfree_vect(x, desc_a, info)
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_abort_) then
call psb_error(ictxt)
return
end if
9999 call psb_error_handler(ictxt,err_act)
return
end subroutine psb_cfree_vect
@@ -274,12 +260,8 @@ subroutine psb_cfree_vect_r2(x, desc_a, info)
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_abort_) then
call psb_error(ictxt)
return
end if
9999 call psb_error_handler(ictxt,err_act)
return
end subroutine psb_cfree_vect_r2
base/tools/psb_cins.f90
+10 -40
View File
@@ -171,14 +171,8 @@ subroutine psb_cinsvi(m, irw, val, x, desc_a, info, dupl,local)
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
9999 call psb_error_handler(ictxt,err_act)
if (err_act == psb_act_ret_) then
return
else
call psb_error(ictxt)
end if
return
end subroutine psb_cinsvi
@@ -265,7 +259,7 @@ subroutine psb_cins_vect(m, irw, val, x, desc_a, info, dupl,local)
call psb_errpush(info,name)
goto 9999
endif
if (present(dupl)) then
dupl_ = dupl
else
@@ -292,14 +286,8 @@ subroutine psb_cins_vect(m, irw, val, x, desc_a, info, dupl,local)
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
9999 call psb_error_handler(ictxt,err_act)
if (err_act == psb_act_ret_) then
return
else
call psb_error(ictxt)
end if
return
end subroutine psb_cins_vect
@@ -379,7 +367,7 @@ subroutine psb_cins_vect_v(m, irw, val, x, desc_a, info, dupl,local)
endif
if (present(dupl)) then
dupl_ = dupl
else
@@ -408,14 +396,8 @@ subroutine psb_cins_vect_v(m, irw, val, x, desc_a, info, dupl,local)
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
9999 call psb_error_handler(ictxt,err_act)
if (err_act == psb_act_ret_) then
return
else
call psb_error(ictxt)
end if
return
end subroutine psb_cins_vect_v
@@ -501,7 +483,7 @@ subroutine psb_cins_vect_r2(m, irw, val, x, desc_a, info, dupl,local)
call psb_errpush(info,name)
goto 9999
endif
if (present(dupl)) then
dupl_ = dupl
else
@@ -518,7 +500,7 @@ subroutine psb_cins_vect_r2(m, irw, val, x, desc_a, info, dupl,local)
else
call desc_a%indxmap%g2l(irw(1:m),irl(1:m),info,owned=.true.)
end if
do i=1,n
if (.not.allocated(x(i)%v)) info = psb_err_invalid_vect_state_
if (info == 0) call x(i)%ins(m,irl,val(:,i),dupl_,info)
@@ -533,14 +515,8 @@ subroutine psb_cins_vect_r2(m, irw, val, x, desc_a, info, dupl,local)
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
9999 call psb_error_handler(ictxt,err_act)
if (err_act == psb_act_ret_) then
return
else
call psb_error(ictxt)
end if
return
end subroutine psb_cins_vect_r2
@@ -687,7 +663,7 @@ subroutine psb_cinsi(m, irw, val, x, desc_a, info, dupl,local)
else
call desc_a%indxmap%g2l(irw(1:m),irl(1:m),info,owned=.true.)
end if
select case(dupl_)
case(psb_dupl_ovwrt_)
do i = 1, m
@@ -730,14 +706,8 @@ subroutine psb_cinsi(m, irw, val, x, desc_a, info, dupl,local)
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
9999 call psb_error_handler(ictxt,err_act)
if (err_act == psb_act_ret_) then
return
else
call psb_error(ictxt)
end if
return
end subroutine psb_cinsi
base/tools/psb_cspalloc.f90
+2 -9
View File
@@ -100,9 +100,8 @@ subroutine psb_cspalloc(a, desc_a, info, nnz)
if (debug_level >= psb_debug_ext_) &
& write(debug_unit,*) me,' ',trim(name),':allocating size:',length_ia1
!....allocate aspk, ia1, ia2.....
call a%free()
!....allocate aspk, ia1, ia2.....
call a%csall(loc_row,loc_col,info,nz=length_ia1)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
@@ -120,14 +119,8 @@ subroutine psb_cspalloc(a, desc_a, info, nnz)
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
9999 call psb_error_handler(ictxt,err_act)
if (err_act == psb_act_ret_) then
return
else
call psb_error(ictxt)
end if
return
end subroutine psb_cspalloc
base/tools/psb_cspasb.f90
+2 -6
View File
@@ -140,12 +140,8 @@ subroutine psb_cspasb(a,desc_a, info, afmt, upd, dupl, mold)
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_abort_) then
call psb_error(ictxt)
return
end if
9999 call psb_error_handler(ictxt,err_act)
return
end subroutine psb_cspasb
base/tools/psb_cspfree.f90
+2 -6
View File
@@ -70,12 +70,8 @@ subroutine psb_cspfree(a, desc_a,info)
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_abort_) then
call psb_error(ictxt)
return
end if
9999 call psb_error_handler(ictxt,err_act)
return
end subroutine psb_cspfree
base/tools/psb_csphalo.F90
+2 -6
View File
@@ -366,12 +366,8 @@ Subroutine psb_csphalo(a,desc_a,blk,info,rowcnv,colcnv,&
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_abort_) then
call psb_error(ictxt)
return
end if
9999 call psb_error_handler(ictxt,err_act)
return
End Subroutine psb_csphalo
base/tools/psb_cspins.f90
+10 -22
View File
@@ -193,12 +193,8 @@ subroutine psb_cspins(nz,ia,ja,val,a,desc_a,info,rebuild,local)
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_abort_) then
call psb_error(ictxt)
return
end if
9999 call psb_error_handler(ictxt,err_act)
return
end subroutine psb_cspins
@@ -313,12 +309,8 @@ subroutine psb_cspins_2desc(nz,ia,ja,val,a,desc_ar,desc_ac,info)
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_abort_) then
call psb_error(ictxt)
return
end if
9999 call psb_error_handler(ictxt,err_act)
return
end subroutine psb_cspins_2desc
@@ -394,9 +386,9 @@ subroutine psb_cspins_v(nz,ia,ja,val,a,desc_a,info,rebuild,local)
if (desc_a%is_bld()) then
!!$ if (local_) then
info = psb_err_invalid_a_and_cd_state_
call psb_errpush(info,name)
goto 9999
info = psb_err_invalid_a_and_cd_state_
call psb_errpush(info,name)
goto 9999
!!$ else
!!$ allocate(ila(nz),jla(nz),stat=info)
!!$ if (info /= psb_success_) then
@@ -444,7 +436,7 @@ subroutine psb_cspins_v(nz,ia,ja,val,a,desc_a,info,rebuild,local)
goto 9999
end if
else
info = psb_err_invalid_cd_state_
info = psb_err_invalid_cd_state_
!!$ allocate(ila(nz),jla(nz),stat=info)
!!$ if (info /= psb_success_) then
@@ -472,12 +464,8 @@ subroutine psb_cspins_v(nz,ia,ja,val,a,desc_a,info,rebuild,local)
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_abort_) then
call psb_error(ictxt)
return
end if
9999 call psb_error_handler(ictxt,err_act)
return
end subroutine psb_cspins_v
base/tools/psb_d_map.f90
+1 -3
View File
@@ -137,12 +137,11 @@ subroutine psb_d_map_X2Y_vect(alpha,x,beta,y,map,info,work)
select case(map_kind)
case(psb_map_aggr_)
ictxt = map%p_desc_Y%get_context()
nr2 = map%p_desc_Y%get_global_rows()
nc2 = map%p_desc_Y%get_local_cols()
call yt%bld(nc2,mold=x%v)
!!$ write(0,*)'From map_aggr_X2Y apply: ',map%p_desc_X%v_halo_index%get_fmt()
if (info == psb_success_) call psb_halo(x,map%p_desc_X,info,work=work)
if (info == psb_success_) call psb_csmm(done,map%map_X2Y,x,dzero,yt,info)
if ((info == psb_success_) .and. map%p_desc_Y%is_repl()) then
@@ -308,7 +307,6 @@ subroutine psb_d_map_Y2X_vect(alpha,x,beta,y,map,info,work)
nr2 = map%p_desc_X%get_global_rows()
nc2 = map%p_desc_X%get_local_cols()
call yt%bld(nc2,mold=y%v)
!!$ write(0,*)'From map_aggr_Y2X apply: ',map%p_desc_Y%v_halo_index%get_fmt()
if (info == psb_success_) call psb_halo(x,map%p_desc_Y,info,work=work)
if (info == psb_success_) call psb_csmm(done,map%map_Y2X,x,dzero,yt,info)
if ((info == psb_success_) .and. map%p_desc_X%is_repl()) then
base/tools/psb_dallc.f90
+19 -35
View File
@@ -48,7 +48,7 @@ subroutine psb_dalloc(x, desc_a, info, n, lb)
implicit none
!....parameters...
real(psb_dpk_), allocatable, intent(out) :: x(:,:)
real(psb_dpk_), allocatable, intent(out) :: x(:,:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_),intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: n, lb
@@ -56,7 +56,7 @@ subroutine psb_dalloc(x, desc_a, info, n, lb)
!locals
integer(psb_ipk_) :: np,me,err,nr,i,j,err_act
integer(psb_ipk_) :: ictxt,n_
integer(psb_ipk_) :: int_err(5), exch(3)
integer(psb_ipk_) :: int_err(5),exch(3)
character(len=20) :: name
name='psb_geall'
@@ -76,7 +76,7 @@ subroutine psb_dalloc(x, desc_a, info, n, lb)
endif
!... check m and n parameters....
if (.not.desc_a%is_ok()) then
if (.not.psb_is_ok_desc(desc_a)) then
info = psb_err_input_matrix_unassembled_
call psb_errpush(info,name)
goto 9999
@@ -111,7 +111,7 @@ subroutine psb_dalloc(x, desc_a, info, n, lb)
call psb_errpush(info,name,int_err,a_err='Invalid desc_a')
goto 9999
endif
call psb_realloc(nr,n_,x,info,lb2=lb)
if (info /= psb_success_) then
info=psb_err_alloc_request_
@@ -119,18 +119,14 @@ subroutine psb_dalloc(x, desc_a, info, n, lb)
call psb_errpush(info,name,int_err,a_err='real(psb_dpk_)')
goto 9999
endif
x(:,:) = dzero
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_abort_) then
call psb_error(ictxt)
return
end if
9999 call psb_error_handler(ictxt,err_act)
return
end subroutine psb_dalloc
@@ -167,9 +163,8 @@ end subroutine psb_dalloc
!!$
!!$
!
!
! Function: psb_dallocv
! Allocates dense matrix for PSBLAS routines.
! Allocates dense matrix for PSBLAS routines
! The descriptor may be in either the build or assembled state.
!
! Arguments:
@@ -229,7 +224,7 @@ subroutine psb_dallocv(x, desc_a,info,n)
call psb_errpush(info,name,int_err,a_err='Invalid desc_a')
goto 9999
endif
call psb_realloc(nr,x,info)
if (info /= psb_success_) then
info=psb_err_alloc_request_
@@ -237,22 +232,19 @@ subroutine psb_dallocv(x, desc_a,info,n)
call psb_errpush(info,name,int_err,a_err='real(psb_dpk_)')
goto 9999
endif
x(:) = dzero
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_abort_) then
call psb_error(ictxt)
return
end if
9999 call psb_error_handler(ictxt,err_act)
return
end subroutine psb_dallocv
subroutine psb_dalloc_vect(x, desc_a,info,n)
use psb_base_mod, psb_protect_name => psb_dalloc_vect
use psi_mod
@@ -312,7 +304,7 @@ subroutine psb_dalloc_vect(x, desc_a,info,n)
if (psb_errstatus_fatal()) then
info=psb_err_alloc_request_
int_err(1)=nr
call psb_errpush(info,name,int_err,a_err='real(psb_dpk_)')
call psb_errpush(info,name,int_err,a_err='real(psb_spk_)')
goto 9999
endif
call x%zero()
@@ -320,12 +312,8 @@ subroutine psb_dalloc_vect(x, desc_a,info,n)
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_abort_) then
call psb_error(ictxt)
return
end if
9999 call psb_error_handler(ictxt,err_act)
return
end subroutine psb_dalloc_vect
@@ -420,19 +408,15 @@ subroutine psb_dalloc_vect_r2(x, desc_a,info,n,lb)
if (psb_errstatus_fatal()) then
info=psb_err_alloc_request_
int_err(1)=nr
call psb_errpush(info,name,int_err,a_err='real(psb_dpk_)')
call psb_errpush(info,name,int_err,a_err='real(psb_spk_)')
goto 9999
endif
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_abort_) then
call psb_error(ictxt)
return
end if
9999 call psb_error_handler(ictxt,err_act)
return
end subroutine psb_dalloc_vect_r2
base/tools/psb_dasb.f90
+29 -44
View File
@@ -32,14 +32,14 @@
! File: psb_dasb.f90
!
! Subroutine: psb_dasb
! Assembles a dense matrix for PSBLAS routines.
! Assembles a dense matrix for PSBLAS routines
! Since the allocation may have been called with the desciptor
! in the build state we make sure that X has a number of rows
! allowing for the halo indices, reallocating if necessary.
! We also call the halo routine for good measure.
!
! Arguments:
! x(:,:) - real,allocatable The matrix to be assembled.
! x(:,:) - real, allocatable The matrix to be assembled.
! desc_a - type(psb_desc_type). The communication descriptor.
! info - integer. return code
subroutine psb_dasb(x, desc_a, info)
@@ -47,7 +47,7 @@ subroutine psb_dasb(x, desc_a, info)
implicit none
type(psb_desc_type), intent(in) :: desc_a
real(psb_dpk_), allocatable, intent(inout) :: x(:,:)
real(psb_dpk_), allocatable, intent(inout) :: x(:,:)
integer(psb_ipk_), intent(out) :: info
! local variables
@@ -83,8 +83,7 @@ subroutine psb_dasb(x, desc_a, info)
goto 9999
else if (.not.psb_is_asb_desc(desc_a)) then
if (debug_level >= psb_debug_ext_) &
& write(debug_unit,*) me,' ',trim(name),' error ',&
& desc_a%get_dectype()
& write(debug_unit,*) me,' ',trim(name),' error '
info = psb_err_input_matrix_unassembled_
call psb_errpush(info,name)
goto 9999
@@ -122,12 +121,8 @@ subroutine psb_dasb(x, desc_a, info)
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_abort_) then
call psb_error(ictxt)
return
end if
9999 call psb_error_handler(ictxt,err_act)
return
end subroutine psb_dasb
@@ -172,15 +167,15 @@ end subroutine psb_dasb
! We also call the halo routine for good measure.
!
! Arguments:
! x(:) - real,allocatable The matrix to be assembled.
! x(:) - real, allocatable The matrix to be assembled.
! desc_a - type(psb_desc_type). The communication descriptor.
! info - integer. Return code
! info - integer. Return code
subroutine psb_dasbv(x, desc_a, info)
use psb_base_mod, psb_protect_name => psb_dasbv
implicit none
type(psb_desc_type), intent(in) :: desc_a
real(psb_dpk_), allocatable, intent(inout) :: x(:)
type(psb_desc_type), intent(in) :: desc_a
real(psb_dpk_), allocatable, intent(inout) :: x(:)
integer(psb_ipk_), intent(out) :: info
! local variables
@@ -240,25 +235,22 @@ subroutine psb_dasbv(x, desc_a, info)
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_abort_) then
call psb_error(ictxt)
return
end if
9999 call psb_error_handler(ictxt,err_act)
return
end subroutine psb_dasbv
subroutine psb_dasb_vect(x, desc_a, info, mold, scratch)
subroutine psb_dasb_vect(x, desc_a, info, mold, scratch)
use psb_base_mod, psb_protect_name => psb_dasb_vect
implicit none
type(psb_desc_type), intent(in) :: desc_a
type(psb_desc_type), intent(in) :: desc_a
type(psb_d_vect_type), intent(inout) :: x
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(out) :: info
class(psb_d_base_vect_type), intent(in), optional :: mold
logical, intent(in), optional :: scratch
logical, intent(in), optional :: scratch
! local variables
integer(psb_ipk_) :: ictxt,np,me
@@ -312,18 +304,15 @@ subroutine psb_dasb_vect(x, desc_a, info, mold, scratch)
if (present(mold)) then
call x%cnv(mold)
end if
if (debug_level >= psb_debug_ext_) &
& write(debug_unit,*) me,' ',trim(name),': end'
endif
end if
if (debug_level >= psb_debug_ext_) &
& write(debug_unit,*) me,' ',trim(name),': end'
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_abort_) then
call psb_error(ictxt)
return
end if
9999 call psb_error_handler(ictxt,err_act)
return
end subroutine psb_dasb_vect
@@ -333,11 +322,11 @@ subroutine psb_dasb_vect_r2(x, desc_a, info, mold, scratch)
use psb_base_mod, psb_protect_name => psb_dasb_vect_r2
implicit none
type(psb_desc_type), intent(in) :: desc_a
type(psb_desc_type), intent(in) :: desc_a
type(psb_d_vect_type), intent(inout) :: x(:)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(out) :: info
class(psb_d_base_vect_type), intent(in), optional :: mold
logical, intent(in), optional :: scratch
logical, intent(in), optional :: scratch
! local variables
integer(psb_ipk_) :: ictxt,np,me, i, n
@@ -355,9 +344,9 @@ subroutine psb_dasb_vect_r2(x, desc_a, info, mold, scratch)
ictxt = desc_a%get_context()
debug_unit = psb_get_debug_unit()
debug_level = psb_get_debug_level()
scratch_ = .false.
if (present(scratch)) scratch_ = scratch
call psb_info(ictxt, me, np)
! ....verify blacs grid correctness..
@@ -406,12 +395,8 @@ subroutine psb_dasb_vect_r2(x, desc_a, info, mold, scratch)
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_abort_) then
call psb_error(ictxt)
return
end if
9999 call psb_error_handler(ictxt,err_act)
return
end subroutine psb_dasb_vect_r2
base/tools/psb_dcdbldext.F90
+12 -16
View File
@@ -433,7 +433,7 @@ Subroutine psb_dcdbldext(a,desc_a,novr,desc_ov,info, extype)
call psb_errpush(info,name,a_err='csget')
goto 9999
end if
call psb_ensure_size((idxs+tot_elem+n_elem),works,info)
if (info /= psb_success_) then
info=psb_err_from_subroutine_
@@ -527,7 +527,7 @@ Subroutine psb_dcdbldext(a,desc_a,novr,desc_ov,info, extype)
end if
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& ': going for first idx_cnv', desc_ov%indxmap%get_state()
& ': going for first idx_cnv', desc_ov%indxmap%get_state()
call desc_ov%indxmap%g2l(workr(1:iszr),maskr(1:iszr),info)
iszs = count(maskr(1:iszr)<=0)
@@ -541,21 +541,21 @@ Subroutine psb_dcdbldext(a,desc_a,novr,desc_ov,info, extype)
end do
! Eliminate duplicates from request
call psb_msort_unique(works(1:j),iszs)
!
! fnd_owner on desc_a because we want the procs who
! owned the rows from the beginning!
!
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& ': going for fnd_owner', desc_ov%indxmap%get_state()
& ': going for fnd_owner', desc_ov%indxmap%get_state()
call desc_a%fnd_owner(works(1:iszs),temp,info)
n_col = desc_ov%get_local_cols()
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& ': Done fnd_owner', desc_ov%indxmap%get_state()
& ': Done fnd_owner', desc_ov%indxmap%get_state()
do i=1,iszs
idx = works(i)
n_col = desc_ov%get_local_cols()
@@ -567,14 +567,14 @@ Subroutine psb_dcdbldext(a,desc_a,novr,desc_ov,info, extype)
! will be less than those for HALO(J) whenever I<J
!
proc_id = temp(i)
call psb_ensure_size((counter_t+3),t_halo_in,info,pad=-ione)
if (info /= psb_success_) then
info=psb_err_from_subroutine_
call psb_errpush(info,name,a_err='psb_ensure_size')
goto 9999
end if
t_halo_in(counter_t) = proc_id
t_halo_in(counter_t+1) = 1
t_halo_in(counter_t+2) = lidx
@@ -695,7 +695,7 @@ Subroutine psb_dcdbldext(a,desc_a,novr,desc_ov,info, extype)
call psb_errpush(psb_err_from_subroutine_,name,a_err='icdasdb')
goto 9999
end if
call psb_cd_set_ovl_asb(desc_ov,info)
if (info == psb_success_) then
@@ -716,13 +716,9 @@ Subroutine psb_dcdbldext(a,desc_a,novr,desc_ov,info, extype)
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_abort_) then
call psb_error(ictxt)
return
end if
Return
9999 call psb_error_handler(ictxt,err_act)
return
End Subroutine psb_dcdbldext
base/tools/psb_dfree.f90
+33 -46
View File
@@ -35,20 +35,20 @@
! frees a dense matrix structure
!
! Arguments:
! x(:,:) - real, allocatable The dense matrix to be freed.
! desc_a - type(psb_desc_type). The communication descriptor.
! info - integer. Return code
! x(:,:) - real, allocatable The dense matrix to be freed.
! desc_a - type(psb_desc_type). The communication descriptor.
! info - integer. Return code
subroutine psb_dfree(x, desc_a, info)
use psb_base_mod, psb_protect_name => psb_dfree
implicit none
!....parameters...
real(psb_dpk_),allocatable, intent(inout) :: x(:,:)
real(psb_dpk_),allocatable, intent(inout) :: x(:,:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
!...locals....
integer(psb_ipk_) :: ictxt,np,me,err_act
integer(psb_ipk_) :: ictxt,np,me, err_act
character(len=20) :: name
@@ -57,12 +57,12 @@ subroutine psb_dfree(x, desc_a, info)
call psb_erractionsave(err_act)
name='psb_dfree'
if (.not.psb_is_ok_desc(desc_a)) then
info=psb_err_forgot_spall_
call psb_errpush(info,name)
goto 9999
info=psb_err_forgot_spall_
call psb_errpush(info,name)
return
end if
ictxt = desc_a%get_context()
ictxt=desc_a%get_context()
call psb_info(ictxt, me, np)
! ....verify blacs grid correctness..
@@ -73,9 +73,9 @@ subroutine psb_dfree(x, desc_a, info)
endif
if (.not.allocated(x)) then
info=psb_err_forgot_spall_
call psb_errpush(info,name)
goto 9999
info=psb_err_forgot_spall_
call psb_errpush(info,name)
goto 9999
end if
!deallocate x
@@ -90,12 +90,8 @@ subroutine psb_dfree(x, desc_a, info)
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_abort_) then
call psb_error(ictxt)
return
end if
9999 call psb_error_handler(ictxt,err_act)
return
end subroutine psb_dfree
@@ -106,7 +102,7 @@ end subroutine psb_dfree
! frees a dense matrix structure
!
! Arguments:
! x(:) - real, allocatable The dense matrix to be freed.
! x(:) - real, allocatable The dense matrix to be freed.
! desc_a - type(psb_desc_type). The communication descriptor.
! info - integer. Return code
subroutine psb_dfreev(x, desc_a, info)
@@ -115,9 +111,10 @@ subroutine psb_dfreev(x, desc_a, info)
!....parameters...
real(psb_dpk_),allocatable, intent(inout) :: x(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(out) :: info
!...locals....
integer(psb_ipk_) :: ictxt,np,me,err_act
integer(psb_ipk_) :: ictxt,np,me, err_act
character(len=20) :: name
@@ -126,24 +123,26 @@ subroutine psb_dfreev(x, desc_a, info)
call psb_erractionsave(err_act)
name='psb_dfreev'
if (.not.psb_is_ok_desc(desc_a)) then
info=psb_err_forgot_spall_
call psb_errpush(info,name)
return
info=psb_err_forgot_spall_
call psb_errpush(info,name)
goto 9999
end if
ictxt = desc_a%get_context()
ictxt=desc_a%get_context()
call psb_info(ictxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
if (.not.allocated(x)) then
info=psb_err_forgot_spall_
call psb_errpush(info,name)
goto 9999
info=psb_err_forgot_spall_
call psb_errpush(info,name)
goto 9999
end if
!deallocate x
@@ -156,12 +155,8 @@ subroutine psb_dfreev(x, desc_a, info)
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_abort_) then
call psb_error(ictxt)
return
end if
9999 call psb_error_handler(ictxt,err_act)
return
end subroutine psb_dfreev
@@ -214,12 +209,8 @@ subroutine psb_dfree_vect(x, desc_a, info)
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_abort_) then
call psb_error(ictxt)
return
end if
9999 call psb_error_handler(ictxt,err_act)
return
end subroutine psb_dfree_vect
@@ -269,12 +260,8 @@ subroutine psb_dfree_vect_r2(x, desc_a, info)
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_abort_) then
call psb_error(ictxt)
return
end if
9999 call psb_error_handler(ictxt,err_act)
return
end subroutine psb_dfree_vect_r2
base/tools/psb_dins.f90
+10 -40
View File
@@ -171,14 +171,8 @@ subroutine psb_dinsvi(m, irw, val, x, desc_a, info, dupl,local)
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
9999 call psb_error_handler(ictxt,err_act)
if (err_act == psb_act_ret_) then
return
else
call psb_error(ictxt)
end if
return
end subroutine psb_dinsvi
@@ -265,7 +259,7 @@ subroutine psb_dins_vect(m, irw, val, x, desc_a, info, dupl,local)
call psb_errpush(info,name)
goto 9999
endif
if (present(dupl)) then
dupl_ = dupl
else
@@ -292,14 +286,8 @@ subroutine psb_dins_vect(m, irw, val, x, desc_a, info, dupl,local)
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
9999 call psb_error_handler(ictxt,err_act)
if (err_act == psb_act_ret_) then
return
else
call psb_error(ictxt)
end if
return
end subroutine psb_dins_vect
@@ -379,7 +367,7 @@ subroutine psb_dins_vect_v(m, irw, val, x, desc_a, info, dupl,local)
endif
if (present(dupl)) then
dupl_ = dupl
else
@@ -408,14 +396,8 @@ subroutine psb_dins_vect_v(m, irw, val, x, desc_a, info, dupl,local)
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
9999 call psb_error_handler(ictxt,err_act)
if (err_act == psb_act_ret_) then
return
else
call psb_error(ictxt)
end if
return
end subroutine psb_dins_vect_v
@@ -501,7 +483,7 @@ subroutine psb_dins_vect_r2(m, irw, val, x, desc_a, info, dupl,local)
call psb_errpush(info,name)
goto 9999
endif
if (present(dupl)) then
dupl_ = dupl
else
@@ -518,7 +500,7 @@ subroutine psb_dins_vect_r2(m, irw, val, x, desc_a, info, dupl,local)
else
call desc_a%indxmap%g2l(irw(1:m),irl(1:m),info,owned=.true.)
end if
do i=1,n
if (.not.allocated(x(i)%v)) info = psb_err_invalid_vect_state_
if (info == 0) call x(i)%ins(m,irl,val(:,i),dupl_,info)
@@ -533,14 +515,8 @@ subroutine psb_dins_vect_r2(m, irw, val, x, desc_a, info, dupl,local)
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
9999 call psb_error_handler(ictxt,err_act)
if (err_act == psb_act_ret_) then
return
else
call psb_error(ictxt)
end if
return
end subroutine psb_dins_vect_r2
@@ -687,7 +663,7 @@ subroutine psb_dinsi(m, irw, val, x, desc_a, info, dupl,local)
else
call desc_a%indxmap%g2l(irw(1:m),irl(1:m),info,owned=.true.)
end if
select case(dupl_)
case(psb_dupl_ovwrt_)
do i = 1, m
@@ -730,14 +706,8 @@ subroutine psb_dinsi(m, irw, val, x, desc_a, info, dupl,local)
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
9999 call psb_error_handler(ictxt,err_act)
if (err_act == psb_act_ret_) then
return
else
call psb_error(ictxt)
end if
return
end subroutine psb_dinsi
base/tools/psb_dspalloc.f90
+4 -16
View File
@@ -59,19 +59,13 @@ subroutine psb_dspalloc(a, desc_a, info, nnz)
integer(psb_ipk_) :: debug_level, debug_unit
character(len=20) :: name, ch_err
if(psb_get_errstatus() /= 0) return
info=psb_success_
if (psb_errstatus_fatal()) return
call psb_erractionsave(err_act)
name = 'psb_dspall'
debug_unit = psb_get_debug_unit()
debug_level = psb_get_debug_level()
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()
dectype = desc_a%get_dectype()
@@ -107,11 +101,11 @@ subroutine psb_dspalloc(a, desc_a, info, nnz)
if (debug_level >= psb_debug_ext_) &
& write(debug_unit,*) me,' ',trim(name),':allocating size:',length_ia1
call a%free()
!....allocate aspk, ia1, ia2.....
call a%csall(loc_row,loc_col,info,nz=length_ia1)
if (psb_errstatus_fatal()) then
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='sp_all'
call psb_errpush(info,name,int_err)
goto 9999
end if
@@ -125,14 +119,8 @@ subroutine psb_dspalloc(a, desc_a, info, nnz)
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
9999 call psb_error_handler(ictxt,err_act)
if (err_act == psb_act_ret_) then
return
else
call psb_error(ictxt)
end if
return
end subroutine psb_dspalloc
base/tools/psb_dspasb.f90
+2 -6
View File
@@ -140,12 +140,8 @@ subroutine psb_dspasb(a,desc_a, info, afmt, upd, dupl, mold)
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_abort_) then
call psb_error(ictxt)
return
end if
9999 call psb_error_handler(ictxt,err_act)
return
end subroutine psb_dspasb
base/tools/psb_dspfree.f90
+8 -17
View File
@@ -44,11 +44,11 @@ subroutine psb_dspfree(a, desc_a,info)
implicit none
!....parameters...
type(psb_desc_type), intent(in) :: desc_a
type(psb_desc_type), intent(in) :: desc_a
type(psb_dspmat_type), intent(inout) :: a
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(out) :: info
!...locals....
integer(psb_ipk_) :: ictxt,err_act
integer(psb_ipk_) :: ictxt, err_act
character(len=20) :: name
if(psb_get_errstatus() /= 0) return
@@ -56,31 +56,22 @@ subroutine psb_dspfree(a, desc_a,info)
name = 'psb_dspfree'
call psb_erractionsave(err_act)
if (.not.desc_a%is_ok()) then
info = psb_err_invalid_cd_state_
if (.not.psb_is_ok_desc(desc_a)) then
info = psb_err_forgot_spall_
call psb_errpush(info,name)
goto 9999
return
else
ictxt = desc_a%get_context()
end if
!...deallocate a....
call a%free()
if (psb_errstatus_fatal()) then
info = psb_err_from_subroutine_
call psb_errpush(info,name,a_err='a%free')
goto 9999
end if
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_abort_) then
call psb_error(ictxt)
return
end if
9999 call psb_error_handler(ictxt,err_act)
return
end subroutine psb_dspfree
base/tools/psb_dsphalo.F90
+2 -6
View File
@@ -366,12 +366,8 @@ Subroutine psb_dsphalo(a,desc_a,blk,info,rowcnv,colcnv,&
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_abort_) then
call psb_error(ictxt)
return
end if
9999 call psb_error_handler(ictxt,err_act)
return
End Subroutine psb_dsphalo
base/tools/psb_dspins.f90
+10 -22
View File
@@ -193,12 +193,8 @@ subroutine psb_dspins(nz,ia,ja,val,a,desc_a,info,rebuild,local)
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_abort_) then
call psb_error(ictxt)
return
end if
9999 call psb_error_handler(ictxt,err_act)
return
end subroutine psb_dspins
@@ -313,12 +309,8 @@ subroutine psb_dspins_2desc(nz,ia,ja,val,a,desc_ar,desc_ac,info)
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_abort_) then
call psb_error(ictxt)
return
end if
9999 call psb_error_handler(ictxt,err_act)
return
end subroutine psb_dspins_2desc
@@ -394,9 +386,9 @@ subroutine psb_dspins_v(nz,ia,ja,val,a,desc_a,info,rebuild,local)
if (desc_a%is_bld()) then
!!$ if (local_) then
info = psb_err_invalid_a_and_cd_state_
call psb_errpush(info,name)
goto 9999
info = psb_err_invalid_a_and_cd_state_
call psb_errpush(info,name)
goto 9999
!!$ else
!!$ allocate(ila(nz),jla(nz),stat=info)
!!$ if (info /= psb_success_) then
@@ -444,7 +436,7 @@ subroutine psb_dspins_v(nz,ia,ja,val,a,desc_a,info,rebuild,local)
goto 9999
end if
else
info = psb_err_invalid_cd_state_
info = psb_err_invalid_cd_state_
!!$ allocate(ila(nz),jla(nz),stat=info)
!!$ if (info /= psb_success_) then
@@ -472,12 +464,8 @@ subroutine psb_dspins_v(nz,ia,ja,val,a,desc_a,info,rebuild,local)
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_abort_) then
call psb_error(ictxt)
return
end if
9999 call psb_error_handler(ictxt,err_act)
return
end subroutine psb_dspins_v
base/tools/psb_sallc.f90
+16 -32
View File
@@ -48,7 +48,7 @@ subroutine psb_salloc(x, desc_a, info, n, lb)
implicit none
!....parameters...
real(psb_spk_), allocatable, intent(out) :: x(:,:)
real(psb_spk_), allocatable, intent(out) :: x(:,:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_),intent(out) :: info
integer(psb_ipk_), optional, intent(in) :: n, lb
@@ -56,7 +56,7 @@ subroutine psb_salloc(x, desc_a, info, n, lb)
!locals
integer(psb_ipk_) :: np,me,err,nr,i,j,err_act
integer(psb_ipk_) :: ictxt,n_
integer(psb_ipk_) :: int_err(5), exch(3)
integer(psb_ipk_) :: int_err(5),exch(3)
character(len=20) :: name
name='psb_geall'
@@ -111,7 +111,7 @@ subroutine psb_salloc(x, desc_a, info, n, lb)
call psb_errpush(info,name,int_err,a_err='Invalid desc_a')
goto 9999
endif
call psb_realloc(nr,n_,x,info,lb2=lb)
if (info /= psb_success_) then
info=psb_err_alloc_request_
@@ -119,18 +119,14 @@ subroutine psb_salloc(x, desc_a, info, n, lb)
call psb_errpush(info,name,int_err,a_err='real(psb_spk_)')
goto 9999
endif
x(:,:) = szero
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_abort_) then
call psb_error(ictxt)
return
end if
9999 call psb_error_handler(ictxt,err_act)
return
end subroutine psb_salloc
@@ -167,9 +163,8 @@ end subroutine psb_salloc
!!$
!!$
!
!
! Function: psb_sallocv
! Allocates dense matrix for PSBLAS routines.
! Allocates dense matrix for PSBLAS routines
! The descriptor may be in either the build or assembled state.
!
! Arguments:
@@ -229,7 +224,7 @@ subroutine psb_sallocv(x, desc_a,info,n)
call psb_errpush(info,name,int_err,a_err='Invalid desc_a')
goto 9999
endif
call psb_realloc(nr,x,info)
if (info /= psb_success_) then
info=psb_err_alloc_request_
@@ -237,22 +232,19 @@ subroutine psb_sallocv(x, desc_a,info,n)
call psb_errpush(info,name,int_err,a_err='real(psb_spk_)')
goto 9999
endif
x(:) = szero
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_abort_) then
call psb_error(ictxt)
return
end if
9999 call psb_error_handler(ictxt,err_act)
return
end subroutine psb_sallocv
subroutine psb_salloc_vect(x, desc_a,info,n)
use psb_base_mod, psb_protect_name => psb_salloc_vect
use psi_mod
@@ -320,12 +312,8 @@ subroutine psb_salloc_vect(x, desc_a,info,n)
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_abort_) then
call psb_error(ictxt)
return
end if
9999 call psb_error_handler(ictxt,err_act)
return
end subroutine psb_salloc_vect
@@ -427,12 +415,8 @@ subroutine psb_salloc_vect_r2(x, desc_a,info,n,lb)
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_abort_) then
call psb_error(ictxt)
return
end if
9999 call psb_error_handler(ictxt,err_act)
return
end subroutine psb_salloc_vect_r2
base/tools/psb_sasb.f90
+17 -33
View File
@@ -32,14 +32,14 @@
! File: psb_sasb.f90
!
! Subroutine: psb_sasb
! Assembles a dense matrix for PSBLAS routines.
! Assembles a dense matrix for PSBLAS routines
! Since the allocation may have been called with the desciptor
! in the build state we make sure that X has a number of rows
! allowing for the halo indices, reallocating if necessary.
! We also call the halo routine for good measure.
!
! Arguments:
! x(:,:) - real,allocatable The matrix to be assembled.
! x(:,:) - real, allocatable The matrix to be assembled.
! desc_a - type(psb_desc_type). The communication descriptor.
! info - integer. return code
subroutine psb_sasb(x, desc_a, info)
@@ -47,7 +47,7 @@ subroutine psb_sasb(x, desc_a, info)
implicit none
type(psb_desc_type), intent(in) :: desc_a
real(psb_spk_), allocatable, intent(inout) :: x(:,:)
real(psb_spk_), allocatable, intent(inout) :: x(:,:)
integer(psb_ipk_), intent(out) :: info
! local variables
@@ -83,8 +83,7 @@ subroutine psb_sasb(x, desc_a, info)
goto 9999
else if (.not.psb_is_asb_desc(desc_a)) then
if (debug_level >= psb_debug_ext_) &
& write(debug_unit,*) me,' ',trim(name),' error ',&
& desc_a%get_dectype()
& write(debug_unit,*) me,' ',trim(name),' error '
info = psb_err_input_matrix_unassembled_
call psb_errpush(info,name)
goto 9999
@@ -122,12 +121,8 @@ subroutine psb_sasb(x, desc_a, info)
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_abort_) then
call psb_error(ictxt)
return
end if
9999 call psb_error_handler(ictxt,err_act)
return
end subroutine psb_sasb
@@ -172,15 +167,15 @@ end subroutine psb_sasb
! We also call the halo routine for good measure.
!
! Arguments:
! x(:) - real,allocatable The matrix to be assembled.
! x(:) - real, allocatable The matrix to be assembled.
! desc_a - type(psb_desc_type). The communication descriptor.
! info - integer. Return code
! info - integer. Return code
subroutine psb_sasbv(x, desc_a, info)
use psb_base_mod, psb_protect_name => psb_sasbv
implicit none
type(psb_desc_type), intent(in) :: desc_a
real(psb_spk_), allocatable, intent(inout) :: x(:)
type(psb_desc_type), intent(in) :: desc_a
real(psb_spk_), allocatable, intent(inout) :: x(:)
integer(psb_ipk_), intent(out) :: info
! local variables
@@ -240,16 +235,13 @@ subroutine psb_sasbv(x, desc_a, info)
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_abort_) then
call psb_error(ictxt)
return
end if
9999 call psb_error_handler(ictxt,err_act)
return
end subroutine psb_sasbv
subroutine psb_sasb_vect(x, desc_a, info, mold, scratch)
use psb_base_mod, psb_protect_name => psb_sasb_vect
implicit none
@@ -319,12 +311,8 @@ subroutine psb_sasb_vect(x, desc_a, info, mold, scratch)
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_abort_) then
call psb_error(ictxt)
return
end if
9999 call psb_error_handler(ictxt,err_act)
return
end subroutine psb_sasb_vect
@@ -407,12 +395,8 @@ subroutine psb_sasb_vect_r2(x, desc_a, info, mold, scratch)
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_abort_) then
call psb_error(ictxt)
return
end if
9999 call psb_error_handler(ictxt,err_act)
return
end subroutine psb_sasb_vect_r2
base/tools/psb_scdbldext.F90
+12 -16
View File
@@ -433,7 +433,7 @@ Subroutine psb_scdbldext(a,desc_a,novr,desc_ov,info, extype)
call psb_errpush(info,name,a_err='csget')
goto 9999
end if
call psb_ensure_size((idxs+tot_elem+n_elem),works,info)
if (info /= psb_success_) then
info=psb_err_from_subroutine_
@@ -527,7 +527,7 @@ Subroutine psb_scdbldext(a,desc_a,novr,desc_ov,info, extype)
end if
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& ': going for first idx_cnv', desc_ov%indxmap%get_state()
& ': going for first idx_cnv', desc_ov%indxmap%get_state()
call desc_ov%indxmap%g2l(workr(1:iszr),maskr(1:iszr),info)
iszs = count(maskr(1:iszr)<=0)
@@ -541,21 +541,21 @@ Subroutine psb_scdbldext(a,desc_a,novr,desc_ov,info, extype)
end do
! Eliminate duplicates from request
call psb_msort_unique(works(1:j),iszs)
!
! fnd_owner on desc_a because we want the procs who
! owned the rows from the beginning!
!
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& ': going for fnd_owner', desc_ov%indxmap%get_state()
& ': going for fnd_owner', desc_ov%indxmap%get_state()
call desc_a%fnd_owner(works(1:iszs),temp,info)
n_col = desc_ov%get_local_cols()
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& ': Done fnd_owner', desc_ov%indxmap%get_state()
& ': Done fnd_owner', desc_ov%indxmap%get_state()
do i=1,iszs
idx = works(i)
n_col = desc_ov%get_local_cols()
@@ -567,14 +567,14 @@ Subroutine psb_scdbldext(a,desc_a,novr,desc_ov,info, extype)
! will be less than those for HALO(J) whenever I<J
!
proc_id = temp(i)
call psb_ensure_size((counter_t+3),t_halo_in,info,pad=-ione)
if (info /= psb_success_) then
info=psb_err_from_subroutine_
call psb_errpush(info,name,a_err='psb_ensure_size')
goto 9999
end if
t_halo_in(counter_t) = proc_id
t_halo_in(counter_t+1) = 1
t_halo_in(counter_t+2) = lidx
@@ -695,7 +695,7 @@ Subroutine psb_scdbldext(a,desc_a,novr,desc_ov,info, extype)
call psb_errpush(psb_err_from_subroutine_,name,a_err='icdasdb')
goto 9999
end if
call psb_cd_set_ovl_asb(desc_ov,info)
if (info == psb_success_) then
@@ -716,13 +716,9 @@ Subroutine psb_scdbldext(a,desc_a,novr,desc_ov,info, extype)
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_abort_) then
call psb_error(ictxt)
return
end if
Return
9999 call psb_error_handler(ictxt,err_act)
return
End Subroutine psb_scdbldext
base/tools/psb_sfree.f90
+26 -39
View File
@@ -35,20 +35,20 @@
! frees a dense matrix structure
!
! Arguments:
! x(:,:) - real, allocatable The dense matrix to be freed.
! desc_a - type(psb_desc_type). The communication descriptor.
! info - integer. Return code
! x(:,:) - real, allocatable The dense matrix to be freed.
! desc_a - type(psb_desc_type). The communication descriptor.
! info - integer. Return code
subroutine psb_sfree(x, desc_a, info)
use psb_base_mod, psb_protect_name => psb_sfree
implicit none
!....parameters...
real(psb_spk_),allocatable, intent(inout) :: x(:,:)
real(psb_spk_),allocatable, intent(inout) :: x(:,:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_),intent(out) :: info
integer(psb_ipk_), intent(out) :: info
!...locals....
integer(psb_ipk_) :: ictxt,np,me,err_act
integer(psb_ipk_) :: ictxt,np,me, err_act
character(len=20) :: name
@@ -59,10 +59,10 @@ subroutine psb_sfree(x, desc_a, info)
if (.not.psb_is_ok_desc(desc_a)) then
info=psb_err_forgot_spall_
call psb_errpush(info,name)
goto 9999
return
end if
ictxt = desc_a%get_context()
ictxt=desc_a%get_context()
call psb_info(ictxt, me, np)
! ....verify blacs grid correctness..
@@ -90,12 +90,8 @@ subroutine psb_sfree(x, desc_a, info)
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_abort_) then
call psb_error(ictxt)
return
end if
9999 call psb_error_handler(ictxt,err_act)
return
end subroutine psb_sfree
@@ -106,18 +102,19 @@ end subroutine psb_sfree
! frees a dense matrix structure
!
! Arguments:
! x():) - real, allocatable The dense matrix to be freed.
! desc_a - type(psb_desc_type). The communication descriptor.
! info - integer. Return code
! x(:) - real, allocatable The dense matrix to be freed.
! desc_a - type(psb_desc_type). The communication descriptor.
! info - integer. Return code
subroutine psb_sfreev(x, desc_a, info)
use psb_base_mod, psb_protect_name => psb_sfreev
implicit none
!....parameters...
real(psb_spk_),allocatable, intent(inout) :: x(:)
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(out) :: info
!...locals....
integer(psb_ipk_) :: ictxt,np,me,err_act
integer(psb_ipk_) :: ictxt,np,me, err_act
character(len=20) :: name
@@ -126,18 +123,20 @@ subroutine psb_sfreev(x, desc_a, info)
call psb_erractionsave(err_act)
name='psb_sfreev'
if (.not.psb_is_ok_desc(desc_a)) then
info=psb_err_forgot_spall_
call psb_errpush(info,name)
return
goto 9999
end if
ictxt = desc_a%get_context()
ictxt=desc_a%get_context()
call psb_info(ictxt, me, np)
if (np == -1) then
info = psb_err_context_error_
call psb_errpush(info,name)
goto 9999
endif
if (.not.allocated(x)) then
@@ -156,12 +155,8 @@ subroutine psb_sfreev(x, desc_a, info)
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_abort_) then
call psb_error(ictxt)
return
end if
9999 call psb_error_handler(ictxt,err_act)
return
end subroutine psb_sfreev
@@ -214,12 +209,8 @@ subroutine psb_sfree_vect(x, desc_a, info)
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_abort_) then
call psb_error(ictxt)
return
end if
9999 call psb_error_handler(ictxt,err_act)
return
end subroutine psb_sfree_vect
@@ -269,12 +260,8 @@ subroutine psb_sfree_vect_r2(x, desc_a, info)
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_abort_) then
call psb_error(ictxt)
return
end if
9999 call psb_error_handler(ictxt,err_act)
return
end subroutine psb_sfree_vect_r2
base/tools/psb_sins.f90
+10 -40
View File
@@ -171,14 +171,8 @@ subroutine psb_sinsvi(m, irw, val, x, desc_a, info, dupl,local)
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
9999 call psb_error_handler(ictxt,err_act)
if (err_act == psb_act_ret_) then
return
else
call psb_error(ictxt)
end if
return
end subroutine psb_sinsvi
@@ -265,7 +259,7 @@ subroutine psb_sins_vect(m, irw, val, x, desc_a, info, dupl,local)
call psb_errpush(info,name)
goto 9999
endif
if (present(dupl)) then
dupl_ = dupl
else
@@ -292,14 +286,8 @@ subroutine psb_sins_vect(m, irw, val, x, desc_a, info, dupl,local)
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
9999 call psb_error_handler(ictxt,err_act)
if (err_act == psb_act_ret_) then
return
else
call psb_error(ictxt)
end if
return
end subroutine psb_sins_vect
@@ -379,7 +367,7 @@ subroutine psb_sins_vect_v(m, irw, val, x, desc_a, info, dupl,local)
endif
if (present(dupl)) then
dupl_ = dupl
else
@@ -408,14 +396,8 @@ subroutine psb_sins_vect_v(m, irw, val, x, desc_a, info, dupl,local)
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
9999 call psb_error_handler(ictxt,err_act)
if (err_act == psb_act_ret_) then
return
else
call psb_error(ictxt)
end if
return
end subroutine psb_sins_vect_v
@@ -501,7 +483,7 @@ subroutine psb_sins_vect_r2(m, irw, val, x, desc_a, info, dupl,local)
call psb_errpush(info,name)
goto 9999
endif
if (present(dupl)) then
dupl_ = dupl
else
@@ -518,7 +500,7 @@ subroutine psb_sins_vect_r2(m, irw, val, x, desc_a, info, dupl,local)
else
call desc_a%indxmap%g2l(irw(1:m),irl(1:m),info,owned=.true.)
end if
do i=1,n
if (.not.allocated(x(i)%v)) info = psb_err_invalid_vect_state_
if (info == 0) call x(i)%ins(m,irl,val(:,i),dupl_,info)
@@ -533,14 +515,8 @@ subroutine psb_sins_vect_r2(m, irw, val, x, desc_a, info, dupl,local)
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
9999 call psb_error_handler(ictxt,err_act)
if (err_act == psb_act_ret_) then
return
else
call psb_error(ictxt)
end if
return
end subroutine psb_sins_vect_r2
@@ -687,7 +663,7 @@ subroutine psb_sinsi(m, irw, val, x, desc_a, info, dupl,local)
else
call desc_a%indxmap%g2l(irw(1:m),irl(1:m),info,owned=.true.)
end if
select case(dupl_)
case(psb_dupl_ovwrt_)
do i = 1, m
@@ -730,14 +706,8 @@ subroutine psb_sinsi(m, irw, val, x, desc_a, info, dupl,local)
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
9999 call psb_error_handler(ictxt,err_act)
if (err_act == psb_act_ret_) then
return
else
call psb_error(ictxt)
end if
return
end subroutine psb_sinsi
base/tools/psb_sspalloc.f90
+1 -7
View File
@@ -119,14 +119,8 @@ subroutine psb_sspalloc(a, desc_a, info, nnz)
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
9999 call psb_error_handler(ictxt,err_act)
if (err_act == psb_act_ret_) then
return
else
call psb_error(ictxt)
end if
return
end subroutine psb_sspalloc
base/tools/psb_sspasb.f90
+2 -6
View File
@@ -140,12 +140,8 @@ subroutine psb_sspasb(a,desc_a, info, afmt, upd, dupl, mold)
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_abort_) then
call psb_error(ictxt)
return
end if
9999 call psb_error_handler(ictxt,err_act)
return
end subroutine psb_sspasb
base/tools/psb_sspfree.f90
+6 -10
View File
@@ -44,11 +44,11 @@ subroutine psb_sspfree(a, desc_a,info)
implicit none
!....parameters...
type(psb_desc_type), intent(in) :: desc_a
type(psb_desc_type), intent(in) :: desc_a
type(psb_sspmat_type), intent(inout) :: a
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_), intent(out) :: info
!...locals....
integer(psb_ipk_) :: ictxt,err_act
integer(psb_ipk_) :: ictxt, err_act
character(len=20) :: name
if(psb_get_errstatus() /= 0) return
@@ -57,7 +57,7 @@ subroutine psb_sspfree(a, desc_a,info)
call psb_erractionsave(err_act)
if (.not.psb_is_ok_desc(desc_a)) then
info=psb_err_forgot_spall_
info = psb_err_forgot_spall_
call psb_errpush(info,name)
return
else
@@ -70,12 +70,8 @@ subroutine psb_sspfree(a, desc_a,info)
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_abort_) then
call psb_error(ictxt)
return
end if
9999 call psb_error_handler(ictxt,err_act)
return
end subroutine psb_sspfree
base/tools/psb_ssphalo.F90
+2 -6
View File
@@ -366,12 +366,8 @@ Subroutine psb_ssphalo(a,desc_a,blk,info,rowcnv,colcnv,&
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_abort_) then
call psb_error(ictxt)
return
end if
9999 call psb_error_handler(ictxt,err_act)
return
End Subroutine psb_ssphalo
base/tools/psb_sspins.f90
+10 -22
View File
@@ -193,12 +193,8 @@ subroutine psb_sspins(nz,ia,ja,val,a,desc_a,info,rebuild,local)
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_abort_) then
call psb_error(ictxt)
return
end if
9999 call psb_error_handler(ictxt,err_act)
return
end subroutine psb_sspins
@@ -313,12 +309,8 @@ subroutine psb_sspins_2desc(nz,ia,ja,val,a,desc_ar,desc_ac,info)
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_abort_) then
call psb_error(ictxt)
return
end if
9999 call psb_error_handler(ictxt,err_act)
return
end subroutine psb_sspins_2desc
@@ -394,9 +386,9 @@ subroutine psb_sspins_v(nz,ia,ja,val,a,desc_a,info,rebuild,local)
if (desc_a%is_bld()) then
!!$ if (local_) then
info = psb_err_invalid_a_and_cd_state_
call psb_errpush(info,name)
goto 9999
info = psb_err_invalid_a_and_cd_state_
call psb_errpush(info,name)
goto 9999
!!$ else
!!$ allocate(ila(nz),jla(nz),stat=info)
!!$ if (info /= psb_success_) then
@@ -444,7 +436,7 @@ subroutine psb_sspins_v(nz,ia,ja,val,a,desc_a,info,rebuild,local)
goto 9999
end if
else
info = psb_err_invalid_cd_state_
info = psb_err_invalid_cd_state_
!!$ allocate(ila(nz),jla(nz),stat=info)
!!$ if (info /= psb_success_) then
@@ -472,12 +464,8 @@ subroutine psb_sspins_v(nz,ia,ja,val,a,desc_a,info,rebuild,local)
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_abort_) then
call psb_error(ictxt)
return
end if
9999 call psb_error_handler(ictxt,err_act)
return
end subroutine psb_sspins_v
base/tools/psb_zallc.f90
+12 -28
View File
@@ -111,7 +111,7 @@ subroutine psb_zalloc(x, desc_a, info, n, lb)
call psb_errpush(info,name,int_err,a_err='Invalid desc_a')
goto 9999
endif
call psb_realloc(nr,n_,x,info,lb2=lb)
if (info /= psb_success_) then
info=psb_err_alloc_request_
@@ -119,18 +119,14 @@ subroutine psb_zalloc(x, desc_a, info, n, lb)
call psb_errpush(info,name,int_err,a_err='complex(psb_dpk_)')
goto 9999
endif
x(:,:) = zzero
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_abort_) then
call psb_error(ictxt)
return
end if
9999 call psb_error_handler(ictxt,err_act)
return
end subroutine psb_zalloc
@@ -228,7 +224,7 @@ subroutine psb_zallocv(x, desc_a,info,n)
call psb_errpush(info,name,int_err,a_err='Invalid desc_a')
goto 9999
endif
call psb_realloc(nr,x,info)
if (info /= psb_success_) then
info=psb_err_alloc_request_
@@ -236,18 +232,14 @@ subroutine psb_zallocv(x, desc_a,info,n)
call psb_errpush(info,name,int_err,a_err='complex(psb_dpk_)')
goto 9999
endif
x(:) = zzero
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_abort_) then
call psb_error(ictxt)
return
end if
9999 call psb_error_handler(ictxt,err_act)
return
end subroutine psb_zallocv
@@ -320,12 +312,8 @@ subroutine psb_zalloc_vect(x, desc_a,info,n)
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_abort_) then
call psb_error(ictxt)
return
end if
9999 call psb_error_handler(ictxt,err_act)
return
end subroutine psb_zalloc_vect
@@ -427,12 +415,8 @@ subroutine psb_zalloc_vect_r2(x, desc_a,info,n,lb)
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_abort_) then
call psb_error(ictxt)
return
end if
9999 call psb_error_handler(ictxt,err_act)
return
end subroutine psb_zalloc_vect_r2
base/tools/psb_zasb.f90
+8 -24
View File
@@ -121,12 +121,8 @@ subroutine psb_zasb(x, desc_a, info)
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_abort_) then
call psb_error(ictxt)
return
end if
9999 call psb_error_handler(ictxt,err_act)
return
end subroutine psb_zasb
@@ -239,12 +235,8 @@ subroutine psb_zasbv(x, desc_a, info)
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_abort_) then
call psb_error(ictxt)
return
end if
9999 call psb_error_handler(ictxt,err_act)
return
end subroutine psb_zasbv
@@ -319,12 +311,8 @@ subroutine psb_zasb_vect(x, desc_a, info, mold, scratch)
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_abort_) then
call psb_error(ictxt)
return
end if
9999 call psb_error_handler(ictxt,err_act)
return
end subroutine psb_zasb_vect
@@ -407,12 +395,8 @@ subroutine psb_zasb_vect_r2(x, desc_a, info, mold, scratch)
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_abort_) then
call psb_error(ictxt)
return
end if
9999 call psb_error_handler(ictxt,err_act)
return
end subroutine psb_zasb_vect_r2
base/tools/psb_zcdbldext.F90
+12 -16
View File
@@ -433,7 +433,7 @@ Subroutine psb_zcdbldext(a,desc_a,novr,desc_ov,info, extype)
call psb_errpush(info,name,a_err='csget')
goto 9999
end if
call psb_ensure_size((idxs+tot_elem+n_elem),works,info)
if (info /= psb_success_) then
info=psb_err_from_subroutine_
@@ -527,7 +527,7 @@ Subroutine psb_zcdbldext(a,desc_a,novr,desc_ov,info, extype)
end if
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& ': going for first idx_cnv', desc_ov%indxmap%get_state()
& ': going for first idx_cnv', desc_ov%indxmap%get_state()
call desc_ov%indxmap%g2l(workr(1:iszr),maskr(1:iszr),info)
iszs = count(maskr(1:iszr)<=0)
@@ -541,21 +541,21 @@ Subroutine psb_zcdbldext(a,desc_a,novr,desc_ov,info, extype)
end do
! Eliminate duplicates from request
call psb_msort_unique(works(1:j),iszs)
!
! fnd_owner on desc_a because we want the procs who
! owned the rows from the beginning!
!
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& ': going for fnd_owner', desc_ov%indxmap%get_state()
& ': going for fnd_owner', desc_ov%indxmap%get_state()
call desc_a%fnd_owner(works(1:iszs),temp,info)
n_col = desc_ov%get_local_cols()
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& ': Done fnd_owner', desc_ov%indxmap%get_state()
& ': Done fnd_owner', desc_ov%indxmap%get_state()
do i=1,iszs
idx = works(i)
n_col = desc_ov%get_local_cols()
@@ -567,14 +567,14 @@ Subroutine psb_zcdbldext(a,desc_a,novr,desc_ov,info, extype)
! will be less than those for HALO(J) whenever I<J
!
proc_id = temp(i)
call psb_ensure_size((counter_t+3),t_halo_in,info,pad=-ione)
if (info /= psb_success_) then
info=psb_err_from_subroutine_
call psb_errpush(info,name,a_err='psb_ensure_size')
goto 9999
end if
t_halo_in(counter_t) = proc_id
t_halo_in(counter_t+1) = 1
t_halo_in(counter_t+2) = lidx
@@ -695,7 +695,7 @@ Subroutine psb_zcdbldext(a,desc_a,novr,desc_ov,info, extype)
call psb_errpush(psb_err_from_subroutine_,name,a_err='icdasdb')
goto 9999
end if
call psb_cd_set_ovl_asb(desc_ov,info)
if (info == psb_success_) then
@@ -716,13 +716,9 @@ Subroutine psb_zcdbldext(a,desc_a,novr,desc_ov,info, extype)
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_abort_) then
call psb_error(ictxt)
return
end if
Return
9999 call psb_error_handler(ictxt,err_act)
return
End Subroutine psb_zcdbldext
base/tools/psb_zfree.f90
+7 -25
View File
@@ -90,12 +90,8 @@ subroutine psb_zfree(x, desc_a, info)
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_abort_) then
call psb_error(ictxt)
return
end if
9999 call psb_error_handler(ictxt,err_act)
return
end subroutine psb_zfree
@@ -159,14 +155,8 @@ subroutine psb_zfreev(x, desc_a, info)
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
9999 call psb_error_handler(ictxt,err_act)
if (err_act == psb_act_ret_) then
return
else
call psb_error(ictxt)
end if
return
end subroutine psb_zfreev
@@ -219,12 +209,8 @@ subroutine psb_zfree_vect(x, desc_a, info)
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_abort_) then
call psb_error(ictxt)
return
end if
9999 call psb_error_handler(ictxt,err_act)
return
end subroutine psb_zfree_vect
@@ -274,12 +260,8 @@ subroutine psb_zfree_vect_r2(x, desc_a, info)
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_abort_) then
call psb_error(ictxt)
return
end if
9999 call psb_error_handler(ictxt,err_act)
return
end subroutine psb_zfree_vect_r2
base/tools/psb_zins.f90
+10 -40
View File
@@ -171,14 +171,8 @@ subroutine psb_zinsvi(m, irw, val, x, desc_a, info, dupl,local)
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
9999 call psb_error_handler(ictxt,err_act)
if (err_act == psb_act_ret_) then
return
else
call psb_error(ictxt)
end if
return
end subroutine psb_zinsvi
@@ -265,7 +259,7 @@ subroutine psb_zins_vect(m, irw, val, x, desc_a, info, dupl,local)
call psb_errpush(info,name)
goto 9999
endif
if (present(dupl)) then
dupl_ = dupl
else
@@ -292,14 +286,8 @@ subroutine psb_zins_vect(m, irw, val, x, desc_a, info, dupl,local)
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
9999 call psb_error_handler(ictxt,err_act)
if (err_act == psb_act_ret_) then
return
else
call psb_error(ictxt)
end if
return
end subroutine psb_zins_vect
@@ -379,7 +367,7 @@ subroutine psb_zins_vect_v(m, irw, val, x, desc_a, info, dupl,local)
endif
if (present(dupl)) then
dupl_ = dupl
else
@@ -408,14 +396,8 @@ subroutine psb_zins_vect_v(m, irw, val, x, desc_a, info, dupl,local)
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
9999 call psb_error_handler(ictxt,err_act)
if (err_act == psb_act_ret_) then
return
else
call psb_error(ictxt)
end if
return
end subroutine psb_zins_vect_v
@@ -501,7 +483,7 @@ subroutine psb_zins_vect_r2(m, irw, val, x, desc_a, info, dupl,local)
call psb_errpush(info,name)
goto 9999
endif
if (present(dupl)) then
dupl_ = dupl
else
@@ -518,7 +500,7 @@ subroutine psb_zins_vect_r2(m, irw, val, x, desc_a, info, dupl,local)
else
call desc_a%indxmap%g2l(irw(1:m),irl(1:m),info,owned=.true.)
end if
do i=1,n
if (.not.allocated(x(i)%v)) info = psb_err_invalid_vect_state_
if (info == 0) call x(i)%ins(m,irl,val(:,i),dupl_,info)
@@ -533,14 +515,8 @@ subroutine psb_zins_vect_r2(m, irw, val, x, desc_a, info, dupl,local)
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
9999 call psb_error_handler(ictxt,err_act)
if (err_act == psb_act_ret_) then
return
else
call psb_error(ictxt)
end if
return
end subroutine psb_zins_vect_r2
@@ -687,7 +663,7 @@ subroutine psb_zinsi(m, irw, val, x, desc_a, info, dupl,local)
else
call desc_a%indxmap%g2l(irw(1:m),irl(1:m),info,owned=.true.)
end if
select case(dupl_)
case(psb_dupl_ovwrt_)
do i = 1, m
@@ -730,14 +706,8 @@ subroutine psb_zinsi(m, irw, val, x, desc_a, info, dupl,local)
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
9999 call psb_error_handler(ictxt,err_act)
if (err_act == psb_act_ret_) then
return
else
call psb_error(ictxt)
end if
return
end subroutine psb_zinsi
base/tools/psb_zspalloc.f90
+1 -7
View File
@@ -119,14 +119,8 @@ subroutine psb_zspalloc(a, desc_a, info, nnz)
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
9999 call psb_error_handler(ictxt,err_act)
if (err_act == psb_act_ret_) then
return
else
call psb_error(ictxt)
end if
return
end subroutine psb_zspalloc
base/tools/psb_zspasb.f90
+2 -6
View File
@@ -140,12 +140,8 @@ subroutine psb_zspasb(a,desc_a, info, afmt, upd, dupl, mold)
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_abort_) then
call psb_error(ictxt)
return
end if
9999 call psb_error_handler(ictxt,err_act)
return
end subroutine psb_zspasb
base/tools/psb_zspfree.f90
+2 -6
View File
@@ -70,12 +70,8 @@ subroutine psb_zspfree(a, desc_a,info)
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_abort_) then
call psb_error(ictxt)
return
end if
9999 call psb_error_handler(ictxt,err_act)
return
end subroutine psb_zspfree
base/tools/psb_zsphalo.F90
+2 -6
View File
@@ -366,12 +366,8 @@ Subroutine psb_zsphalo(a,desc_a,blk,info,rowcnv,colcnv,&
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_abort_) then
call psb_error(ictxt)
return
end if
9999 call psb_error_handler(ictxt,err_act)
return
End Subroutine psb_zsphalo
base/tools/psb_zspins.f90
+10 -22
View File
@@ -193,12 +193,8 @@ subroutine psb_zspins(nz,ia,ja,val,a,desc_a,info,rebuild,local)
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_abort_) then
call psb_error(ictxt)
return
end if
9999 call psb_error_handler(ictxt,err_act)
return
end subroutine psb_zspins
@@ -313,12 +309,8 @@ subroutine psb_zspins_2desc(nz,ia,ja,val,a,desc_ar,desc_ac,info)
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_abort_) then
call psb_error(ictxt)
return
end if
9999 call psb_error_handler(ictxt,err_act)
return
end subroutine psb_zspins_2desc
@@ -394,9 +386,9 @@ subroutine psb_zspins_v(nz,ia,ja,val,a,desc_a,info,rebuild,local)
if (desc_a%is_bld()) then
!!$ if (local_) then
info = psb_err_invalid_a_and_cd_state_
call psb_errpush(info,name)
goto 9999
info = psb_err_invalid_a_and_cd_state_
call psb_errpush(info,name)
goto 9999
!!$ else
!!$ allocate(ila(nz),jla(nz),stat=info)
!!$ if (info /= psb_success_) then
@@ -444,7 +436,7 @@ subroutine psb_zspins_v(nz,ia,ja,val,a,desc_a,info,rebuild,local)
goto 9999
end if
else
info = psb_err_invalid_cd_state_
info = psb_err_invalid_cd_state_
!!$ allocate(ila(nz),jla(nz),stat=info)
!!$ if (info /= psb_success_) then
@@ -472,12 +464,8 @@ subroutine psb_zspins_v(nz,ia,ja,val,a,desc_a,info,rebuild,local)
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_abort_) then
call psb_error(ictxt)
return
end if
9999 call psb_error_handler(ictxt,err_act)
return
end subroutine psb_zspins_v