added error check on subroutine entry point

psblas3-type-indexed
Alfredo Buttari 19 years ago
parent 31e309760f
commit 4398391a5c

@ -17,7 +17,6 @@ subroutine psi_desc_index(desc_data,index_in,dep_list,&
!c ....local scalars...
integer :: j,me,np,npcol,mycol,i,proc,dim
!c ...parameters...
integer, parameter :: ione=1
integer :: icontxt
integer :: no_comm,err
parameter (no_comm=-1)

@ -14,6 +14,7 @@ subroutine psi_sort_dl(dep_list,l_dep_list,np,info)
character(len=20) :: name, ch_err
name='psi_sort_dl'
if(psb_get_errstatus().ne.0) return
info=0
call psb_erractionsave(err_act)

@ -77,7 +77,6 @@ subroutine psb_dbicg(a,prec,b,x,eps,desc_a,info,&
character ::diagl, diagu
logical, parameter :: debug = .false.
logical, parameter :: exchange=.true., noexchange=.false.
integer, parameter :: ione=1
integer, parameter :: irmax = 8
integer :: itx, i, isvch, ich, icontxt
logical :: do_renum_left

@ -76,7 +76,6 @@ Subroutine psb_dcg(a,prec,b,x,eps,desc_a,info,&
& nprows,npcols,me,mecol, n_col, isvch, ich, icontxt, n_row,err_act, int_err(5)
character ::diagl, diagu
logical, parameter :: exchange=.true., noexchange=.false.
integer, parameter :: ione=1
real(kind(1.d0)), parameter :: one=1.d0, zero=0.d0, epstol=1.d-35
character(len=20) :: name,ch_err

@ -74,7 +74,6 @@ Subroutine psb_dcgs(a,prec,b,x,eps,desc_a,info,&
& nprows,npcols,me,mecol, n_row, n_col,listop, err_act
Character ::diagl, diagu
Logical, Parameter :: exchange=.True., noexchange=.False.
Integer, Parameter :: ione=1
Integer, Parameter :: irmax = 8
Integer :: itx, i, isvch, ich, icontxt
Logical :: do_renum_left

@ -75,7 +75,6 @@ Subroutine psb_dcgstab(a,prec,b,x,eps,desc_a,info,&
Character ::diagl, diagu
Logical, Parameter :: debug = .false.
Logical, Parameter :: exchange=.True., noexchange=.False., debug1 = .False.
Integer, Parameter :: ione=1
Integer, Parameter :: irmax = 8
Integer :: itx, i, isvch, ich, icontxt, err_act, int_err(5),ii
Integer :: listop

@ -83,7 +83,6 @@ Subroutine psb_dcgstabl(a,prec,b,x,eps,desc_a,info,&
& nprows,npcols,me,mecol, n_row, n_col, nl, err_act
Character ::diagl, diagu
Logical, Parameter :: exchange=.True., noexchange=.False.
Integer, Parameter :: ione=1
Integer, Parameter :: irmax = 8
Integer :: itx, i, isvch, ich, icontxt,listop,j, int_err(5)
Logical :: do_renum_left

@ -85,7 +85,6 @@ Subroutine psb_dgmresr(a,prec,b,x,eps,desc_a,info,&
& nprows,npcols,me,mecol, n_row, n_col, nl, int_err(5)
Character ::diagl, diagu
Logical, Parameter :: exchange=.True., noexchange=.False.
Integer, Parameter :: ione=1
Integer, Parameter :: irmax = 8
Integer :: itx, i, isvch, ich, icontxt,listop, err_act
Logical :: do_renum_left,inner_stop

@ -17,6 +17,7 @@ subroutine psb_dbldaggrmat(a,desc_a,p,info)
integer ::icontxt,nprow,npcol,me,mycol, err_act
character(len=20) :: name, ch_err
name='psb_dbldaggrmat'
if(psb_get_errstatus().ne.0) return
info=0
call psb_erractionsave(err_act)
@ -77,7 +78,8 @@ contains
& naggr, np, myprow, mypcol, nprows, npcols,nzt,irs,jl,nzl,nlr,&
& icomm,naggrm1, mtype, i, j, err_act
name='raw_aggregate'
info=0
if(psb_get_errstatus().ne.0) return
info=0
call psb_erractionsave(err_act)
bg => p%av(ac_)
@ -314,7 +316,8 @@ contains
name='smooth_aggregate'
info=0
if(psb_get_errstatus().ne.0) return
info=0
call psb_erractionsave(err_act)
icontxt = desc_a%matrix_data(psb_ctxt_)

@ -76,6 +76,7 @@ subroutine psb_dcslu(a,desc_a,p,upd,info)
end Subroutine psb_dcsrsetup
end interface
if(psb_get_errstatus().ne.0) return
info=0
name='psb_dcslu'
call psb_erractionsave(err_act)
@ -317,7 +318,8 @@ contains
integer, intent(out) :: info
character(len=20) :: name, ch_err
info=0
if(psb_get_errstatus().ne.0) return
info=0
name='apply_renum'
call psb_erractionsave(err_act)
@ -615,7 +617,8 @@ contains
character(len=20) :: name, ch_err
info=0
if(psb_get_errstatus().ne.0) return
info=0
name='gps_reduction'
call psb_erractionsave(err_act)

@ -48,6 +48,7 @@ Subroutine psb_dcsrsetup(ptype,novr,a,blk,desc_data,upd,desc_p,info,outfmt)
Logical,Parameter :: debug=.false., debugprt=.false.
character(len=20) :: name, ch_err
name='psb_dcsrsetup'
if(psb_get_errstatus().ne.0) return
info=0
call psb_erractionsave(err_act)

@ -20,6 +20,7 @@ subroutine psb_dgenaggrmap(aggr_type,a,desc_a,nlaggr,ilaggr,info)
integer, parameter :: one=1, two=2
character(len=20) :: name, ch_err
if(psb_get_errstatus().ne.0) return
info=0
name = 'psb_bldaggrmat'
call psb_erractionsave(err_act)

@ -255,8 +255,7 @@ subroutine psb_dbaseprcaply(prec,x,beta,y,desc_data,trans,work,info)
end if
if (prec%iprcparm(iren_)>0) then
!!$ call psb_dgelp('N',n_row,1,prec%perm,tx,isz,ww,isz,info)
info = -1
call dgelp('N',n_row,1,prec%perm,tx,isz,ww,isz,info)
if(info /=0) then
info=4010
ch_err='psb_dgelp'
@ -267,8 +266,7 @@ subroutine psb_dbaseprcaply(prec,x,beta,y,desc_data,trans,work,info)
call psb_dbjacaply(prec,tx,zero,ty,prec%desc_data,trans,aux,info)
if (prec%iprcparm(iren_)>0) then
!!$ call psb_dgelp('N',n_row,1,prec%invperm,ty,isz,ww,isz,info)
info = -1
call dgelp('N',n_row,1,prec%invperm,ty,isz,ww,isz,info)
if(info /=0) then
info=4010
ch_err='psb_dgelp'

@ -4,6 +4,7 @@ subroutine psb_dprecbld(a,p,desc_a,info,upd)
Use psb_spmat_type
use psb_descriptor_type
use psb_prec_type
use psb_tools_mod
use psb_comm_mod
use psb_const_mod
use psb_psblas_mod
@ -70,6 +71,7 @@ subroutine psb_dprecbld(a,p,desc_a,info,upd)
integer,parameter :: iroot=0,iout=60,ilout=40
character(len=20) :: name, ch_err
if(psb_get_errstatus().ne.0) return
info=0
err=0
call psb_erractionsave(err_act)
@ -307,6 +309,7 @@ subroutine psb_splu_bld(a,desc_a,p,info)
use psb_serial_mod
use psb_descriptor_type
use psb_prec_type
use psb_tools_mod
use psb_const_mod
implicit none
@ -339,6 +342,7 @@ subroutine psb_splu_bld(a,desc_a,p,info)
end Subroutine psb_dcsrsetup
end interface
if(psb_get_errstatus().ne.0) return
info=0
name='psb_splu_bld'
call psb_erractionsave(err_act)
@ -663,6 +667,7 @@ end subroutine psb_umf_bld
subroutine psb_mlprec_bld(a,desc_a,p,info)
use psb_serial_mod
use psb_tools_mod
use psb_descriptor_type
use psb_prec_type
use psb_const_mod
@ -716,6 +721,7 @@ subroutine psb_mlprec_bld(a,desc_a,p,info)
integer :: icontxt, nprow, npcol, me, mycol
name='psb_mlprec_bld'
if(psb_get_errstatus().ne.0) return
info=0
call psb_erractionsave(err_act)

@ -17,9 +17,9 @@ subroutine psb_dprecfree(p,info)
integer :: temp(1), me
real(kind(1.d0)) :: real_err(5)
integer :: icontxt,err_act,i
integer,parameter :: ione=1
character(len=20) :: name, ch_err
if(psb_get_errstatus().ne.0) return
info=0
name = 'psdprecfree'
call psb_erractionsave(err_act)

@ -108,7 +108,8 @@ contains
character(len=20) :: name, ch_err
name='psb_dspluint'
info=0
if(psb_get_errstatus().ne.0) return
info=0
call psb_erractionsave(err_act)
trw%m=0

@ -30,6 +30,7 @@ subroutine psb_chkglobvect( m, n, lldx, ix, jx, desc_dec, info)
integer :: err_act, int_err(5)
character(len=20) :: name, ch_err
if(psb_get_errstatus().ne.0) return
info=0
name='psb_chkglobvect'
call psb_erractionsave(err_act)

@ -35,6 +35,7 @@ subroutine psb_chkmat( m, n, ia, ja, desc_dec, info, iia, jja)
integer :: err_act, int_err(5)
character(len=20) :: name, ch_err
if(psb_get_errstatus().ne.0) return
info=0
name='psb_chkmat'
call psb_erractionsave(err_act)

@ -34,6 +34,7 @@ subroutine psb_chkvect( m, n, lldx, ix, jx, desc_dec, info, iix, jjx)
integer :: err_act, int_err(5)
character(len=20) :: name, ch_err
if(psb_get_errstatus().ne.0) return
info=0
name='psb_chkvect'
call psb_erractionsave(err_act)

@ -35,6 +35,7 @@ function psb_damax (x,desc_a, info, jx)
character(len=20) :: name, ch_err
name='psb_damax'
if(psb_get_errstatus().ne.0) return
info=0
call psb_erractionsave(err_act)
@ -137,6 +138,7 @@ function psb_damaxv (x,desc_a, info)
character(len=20) :: name, ch_err
name='psb_damaxv'
if(psb_get_errstatus().ne.0) return
info=0
call psb_erractionsave(err_act)
@ -236,6 +238,7 @@ subroutine psb_damaxvs (res,x,desc_a, info)
character(len=20) :: name, ch_err
name='psb_damaxvs'
if(psb_get_errstatus().ne.0) return
info=0
call psb_erractionsave(err_act)
@ -336,6 +339,7 @@ subroutine psb_dmamaxs (res,x,desc_a, info,jx)
character(len=20) :: name, ch_err
name='psb_dmamaxs'
if(psb_get_errstatus().ne.0) return
info=0
call psb_erractionsave(err_act)

@ -35,6 +35,7 @@ function psb_dasum (x,desc_a, info, jx)
character(len=20) :: name, ch_err
name='psb_dasum'
if(psb_get_errstatus().ne.0) return
info=0
call psb_erractionsave(err_act)
@ -155,6 +156,7 @@ function psb_dasumv (x,desc_a, info)
character(len=20) :: name, ch_err
name='psb_dasumv'
if(psb_get_errstatus().ne.0) return
info=0
call psb_erractionsave(err_act)
@ -271,6 +273,7 @@ subroutine psb_dasumvs (res,x,desc_a, info)
character(len=20) :: name, ch_err
name='psb_dasumvs'
if(psb_get_errstatus().ne.0) return
info=0
call psb_erractionsave(err_act)

@ -40,6 +40,7 @@ subroutine psb_daxpby(alpha, x, beta,y,desc_a,info, n, jx, jy)
character(len=20) :: name, ch_err
name='psb_daxpby'
if(psb_get_errstatus().ne.0) return
info=0
call psb_erractionsave(err_act)
@ -165,6 +166,7 @@ subroutine psb_daxpbyv(alpha, x, beta,y,desc_a,info)
character(len=20) :: name, ch_err
name='psb_daxpby'
if(psb_get_errstatus().ne.0) return
info=0
call psb_erractionsave(err_act)

@ -38,6 +38,7 @@ function psb_ddot(x, y,desc_a, info, jx, jy)
character(len=20) :: name, ch_err
name='psb_ddot'
if(psb_get_errstatus().ne.0) return
info=0
call psb_erractionsave(err_act)
@ -167,6 +168,7 @@ function psb_ddotv(x, y,desc_a, info)
character(len=20) :: name, ch_err
name='psb_ddot'
if(psb_get_errstatus().ne.0) return
info=0
call psb_erractionsave(err_act)
@ -280,6 +282,7 @@ subroutine psb_ddotvs(res, x, y,desc_a, info)
character(len=20) :: name, ch_err
name='psb_ddot'
if(psb_get_errstatus().ne.0) return
info=0
call psb_erractionsave(err_act)
@ -395,6 +398,7 @@ subroutine psb_dmdots(res, x, y, desc_a, info)
character(len=20) :: name, ch_err
name='psb_dmdots'
if(psb_get_errstatus().ne.0) return
info=0
call psb_erractionsave(err_act)

@ -34,6 +34,7 @@ function psb_dnrm2(x, desc_a, info, jx)
character(len=20) :: name, ch_err
name='psb_dnrm2'
if(psb_get_errstatus().ne.0) return
info=0
call psb_erractionsave(err_act)
@ -146,6 +147,7 @@ function psb_dnrm2v(x, desc_a, info)
character(len=20) :: name, ch_err
name='psb_dnrm2v'
if(psb_get_errstatus().ne.0) return
info=0
call psb_erractionsave(err_act)
@ -257,6 +259,7 @@ subroutine psb_dnrm2vs(res, x, desc_a, info)
character(len=20) :: name, ch_err
name='psb_dnrm2'
if(psb_get_errstatus().ne.0) return
info=0
call psb_erractionsave(err_act)

@ -29,6 +29,7 @@ function psb_dnrmi(a,desc_a,info)
character(len=20) :: name, ch_err
name='psb_dnrmi'
if(psb_get_errstatus().ne.0) return
info=0
call psb_erractionsave(err_act)

@ -80,6 +80,7 @@ subroutine psb_dspmm(alpha,a,x,beta,y,desc_a,info,&
character(len=20) :: name, ch_err
name='psb_dspmm'
if(psb_get_errstatus().ne.0) return
info=0
call psb_erractionsave(err_act)
@ -396,6 +397,7 @@ subroutine psb_dspmv(alpha,a,x,beta,y,desc_a,info,&
character(len=20) :: name, ch_err
name='psb_dspmv'
if(psb_get_errstatus().ne.0) return
info=0
call psb_erractionsave(err_act)

@ -78,6 +78,7 @@ subroutine psb_dspsm(alpha,a,x,beta,y,desc_a,info,&
character(len=20) :: name, ch_err
name='psb_dspsm'
if(psb_get_errstatus().ne.0) return
info=0
call psb_erractionsave(err_act)
@ -353,6 +354,7 @@ subroutine psb_dspsv(alpha,a,x,beta,y,desc_a,info,&
character(len=20) :: name, ch_err
name='psb_dspsv'
if(psb_get_errstatus().ne.0) return
info=0
call psb_erractionsave(err_act)

@ -4,6 +4,7 @@
subroutine psb_dtransp(a,b,c,fmt)
use psb_spmat_type
use psb_tools_mod
use psb_serial_mod, only : psb_ipcoo2csr, psb_ipcsr2coo, psb_fixcoo
implicit none

@ -35,6 +35,7 @@ subroutine psb_dalloc(m, n, x, desc_a, info, js)
character(len=20) :: name, ch_err
name='psb_dallc'
if(psb_get_errstatus().ne.0) return
info=0
err=0
int_err(1)=0
@ -193,6 +194,7 @@ subroutine psb_dallocv(m, x, desc_a,info)
logical, parameter :: debug=.false.
character(len=20) :: name, ch_err
if(psb_get_errstatus().ne.0) return
info=0
name='psb_dallcv'
call psb_erractionsave(err_act)

@ -24,11 +24,11 @@ subroutine psb_dasb(x, desc_a, info)
real(kind(1.d0)),pointer :: dtemp(:,:)
integer :: int_err(5), i1sz, i2sz, dectype, i,j
double precision :: real_err(5)
integer, parameter :: ione=1
real(kind(1.d0)),parameter :: one=1
logical, parameter :: debug=.false.
character(len=20) :: name, ch_err
if(psb_get_errstatus().ne.0) return
info=0
name='psb_dasb'
call psb_erractionsave(err_act)
@ -140,7 +140,6 @@ subroutine psb_dasbv(x, desc_a, info)
integer :: int_err(5), i1sz,nrow,ncol, dectype, i, err_act
real(kind(1.d0)),pointer :: dtemp(:)
double precision :: real_err(5)
integer, parameter :: ione=1
real(kind(1.d0)),parameter :: one=1
logical, parameter :: debug=.false.
character(len=20) :: name,ch_err

@ -21,7 +21,7 @@ Subroutine psb_dcsrovr(a,desc_a,blk,info,rwcnv,clcnv,outfmt)
use psb_descriptor_type
Use psb_prec_type
use psb_realloc_mod
use psb_tools_mod, only : psb_glob_to_loc, psb_loc_to_glob
use psb_tools_mod, only : psb_glob_to_loc, psb_loc_to_glob, psb_spfree
use psb_error_mod
Implicit None
@ -48,6 +48,7 @@ Subroutine psb_dcsrovr(a,desc_a,blk,info,rwcnv,clcnv,outfmt)
real(kind(1.d0)) :: t1,t2,t3,t4,t5,t6,t7,t8,t9
character(len=20) :: name, ch_err
if(psb_get_errstatus().ne.0) return
info=0
name='psb_dcsrovr'
call psb_erractionsave(err_act)

@ -66,6 +66,7 @@ subroutine psb_dcsrp(trans,iperm,a, desc_a, info)
n_row = desc_a%matrix_data(psb_n_row_)
n_col = desc_a%matrix_data(psb_n_col_)
if(psb_get_errstatus().ne.0) return
info=0
call psb_erractionsave(err_act)
name = 'psd_csrp'
@ -84,7 +85,7 @@ subroutine psb_dcsrp(trans,iperm,a, desc_a, info)
endif
if (.not.is_asb_dec(dectype)) then
if (.not.psb_is_asb_dec(dectype)) then
info = 600
int_err(1) = dectype
call psb_errpush(info,name,int_err)

@ -22,7 +22,7 @@ Subroutine psb_descasb(n_ovr,desc_p,desc_a,a,&
use psb_serial_mod
Use psi_mod
use psb_realloc_mod
use psb_tools_mod, only : psb_descprt
use psb_tools_mod, only : psb_descprt, psb_spfree
use psb_error_mod
use psb_const_mod
Implicit None
@ -57,6 +57,7 @@ Subroutine psb_descasb(n_ovr,desc_p,desc_a,a,&
real(kind(1.d0)) :: t1,t2,t3,t4,t5,t6,t7, tl, tch
character(len=20) :: name, ch_err
if(psb_get_errstatus().ne.0) return
info=0
name='psb_descasb'
call psb_erractionsave(err_act)
@ -622,7 +623,8 @@ Subroutine psb_descasb(n_ovr,desc_p,desc_a,a,&
end if
! Ok, register into MATRIX_DATA & free temporary work areas
desc_a%matrix_data(psb_dec_type_) = psb_desc_asb_
write(0,*)'!!! verify this !!!'
desc_p%matrix_data(psb_dec_type_) = psb_desc_asb_
allocate(desc_p%lprm(1))
desc_p%lprm(1) = 0

@ -22,10 +22,10 @@ subroutine psb_dfree(x, desc_a, info)
!...locals....
integer :: int_err(5)
integer :: icontxt,nprow,npcol,me,mypcol,err, err_act
integer,parameter :: ione=1
character(len=20) :: name
if(psb_get_errstatus().ne.0) return
info=0
call psb_erractionsave(err_act)
name='psb_dfree'
@ -107,10 +107,10 @@ subroutine psb_dfreev(x, desc_a, info)
!...locals....
integer :: int_err(5)
integer :: icontxt,nprow,npcol,me,mypcol,err, err_act
integer,parameter :: ione=1
character(len=20) :: name
if(psb_get_errstatus().ne.0) return
info=0
call psb_erractionsave(err_act)
name='psb_dfreev'

@ -28,7 +28,6 @@ subroutine psb_dgelp(trans,iperm,x,desc_a,info)
real(kind(1.d0)),pointer :: dtemp(:)
integer :: int_err(5), i1sz, i2sz, dectype, i, err_act
character(len=20) :: itrans
integer, parameter :: ione=1
real(kind(1.d0)),parameter :: one=1
logical, parameter :: debug=.false.
@ -53,6 +52,7 @@ subroutine psb_dgelp(trans,iperm,x,desc_a,info)
character(len=20) :: name, ch_err
name = 'psb_dgelp'
if(psb_get_errstatus().ne.0) return
info=0
call psb_erractionsave(err_act)
@ -148,7 +148,6 @@ subroutine psb_dgelpv(trans,iperm,x,desc_a,info)
real(kind(1.d0)),pointer :: dtemp(:)
double precision :: real_err(5)
character :: itrans
integer, parameter :: ione=1
real(kind(1.d0)),parameter :: one=1
logical, parameter :: debug=.false.
@ -173,6 +172,7 @@ subroutine psb_dgelpv(trans,iperm,x,desc_a,info)
character(len=20) :: name, ch_err
name = 'psb_dgelpv'
if(psb_get_errstatus().ne.0) return
info=0
call psb_erractionsave(err_act)

@ -40,6 +40,7 @@ subroutine psb_dins(m, n, x, ix, jx, blck, desc_a, info,&
character :: temp_descra*11,temp_fida*5
character(len=20) :: name, char_err
if(psb_get_errstatus().ne.0) return
info=0
call psb_erractionsave(err_act)
name = 'psb_dins'
@ -210,6 +211,7 @@ subroutine psb_dinsvm(m, x, ix, jx, blck, desc_a,info,&
integer :: nprow,npcol, me ,mypcol, iblock
character(len=20) :: name, char_err
if(psb_get_errstatus().ne.0) return
info=0
call psb_erractionsave(err_act)
name = 'psb_dinsvm'
@ -365,6 +367,7 @@ subroutine psb_dinsvv(m, x, ix, blck, desc_a, info,&
integer :: nprow,npcol, me ,mypcol
character(len=20) :: name, char_err
if(psb_get_errstatus().ne.0) return
info=0
call psb_erractionsave(err_act)
name = 'psb_dinsvv'

@ -34,6 +34,7 @@ subroutine psb_dscall(m, n, parts, icontxt, desc_a, info)
logical, parameter :: debug=.false.
character(len=20) :: name, char_err
if(psb_get_errstatus().ne.0) return
info=0
err=0
name = 'psb_dscall'

@ -33,6 +33,7 @@ subroutine psb_dscalv(m, v, icontxt, desc_a, info, flag)
logical, parameter :: debug=.false.
character(len=20) :: name, ch_err
if(psb_get_errstatus().ne.0) return
info=0
err=0
name = 'psb_dscalv'

@ -27,10 +27,10 @@ subroutine psb_dsccpy(desc_out, desc_a, info)
& icontxt, isz, dectype, err_act, err
integer :: int_err(5),temp(1)
real(kind(1.d0)) :: real_err(5)
integer, parameter :: ione=1, itwo=2,root=0
logical, parameter :: debug=.false.
character(len=20) :: name, char_err
if(psb_get_errstatus().ne.0) return
info=0
call psb_erractionsave(err_act)
name = 'psb_dsccpy'

@ -95,12 +95,12 @@ subroutine psb_dscdec(nloc, icontxt, desc_a, info)
& l_ov_ix,l_ov_el,idx, flag_, err_act,m, ip
Integer :: INT_ERR(5),TEMP(1),EXCH(2)
Real(Kind(1.d0)) :: REAL_ERR(5)
Integer, Parameter :: IONE=1, ITWO=2,ROOT=0
Integer, Pointer :: temp_ovrlap(:), ov_idx(:), ov_el(:)
integer, allocatable :: nlv(:)
logical, parameter :: debug=.false.
character(len=20) :: name, ch_err
if(psb_get_errstatus().ne.0) return
info=0
err=0
name = 'psb_dscdec'

@ -20,9 +20,9 @@ subroutine psb_dscfree(desc_a,info)
integer :: temp(1)
real(kind(1.d0)) :: real_err(5)
integer :: icontxt,nprow,npcol,me,mypcol, err_act
integer,parameter :: ione=1
character(len=20) :: name, char_err
if(psb_get_errstatus().ne.0) return
info=0
call psb_erractionsave(err_act)
name = 'psb_dscfree'

@ -36,6 +36,7 @@ subroutine psb_dscren(trans,iperm,desc_a,info)
logical, parameter :: debug=.false.
character(len=20) :: name, char_err
if(psb_get_errstatus().ne.0) return
info=0
call psb_erractionsave(err_act)
name = 'psb_dcren'

@ -99,6 +99,7 @@ subroutine psb_dscrep(m, icontxt, desc_a, info)
logical, parameter :: debug=.false.
character(len=20) :: name, ch_err
if(psb_get_errstatus().ne.0) return
info=0
err=0
name = 'psb_dscrep'

@ -30,10 +30,10 @@ subroutine psb_dspalloc(a, desc_a, info, nnz)
& length_ia1,length_ia2,err,nprocs, err_act,m,n
integer :: int_err(5),temp(1)
real(kind(1.d0)) :: real_err(5)
integer, parameter :: ione=1, itwo=2,root=0
logical, parameter :: debug=.false.
character(len=20) :: name, ch_err
if(psb_get_errstatus().ne.0) return
info=0
call psb_erractionsave(err_act)
name = 'psb_dspalloc'

@ -31,6 +31,21 @@ subroutine psb_dspasb(a,desc_a, info, afmt, up, dup)
end subroutine psb_cest
end interface
interface psb_spfree
subroutine psb_dspfree(a, desc_a,info)
use psb_descriptor_type
use psb_spmat_type
type(psb_desc_type), intent(in) :: desc_a
type(psb_dspmat_type), intent(inout) ::a
integer, intent(out) :: info
end subroutine psb_dspfree
subroutine psb_dspfrees(a,info)
use psb_spmat_type
type(psb_dspmat_type), intent(inout) ::a
integer, intent(out) :: info
end subroutine psb_dspfrees
end interface
!...Parameters....
type(psb_dspmat_type), intent (inout) :: a
type(psb_desc_type), intent(in) :: desc_a

@ -77,13 +77,13 @@ subroutine psb_dspcnv(a,b,desc_a,info)
integer :: lwork_dcsdp,dectype
integer :: icontxt,temp(1),n_row
character :: check*1, trans*1, unitd*1
integer, parameter :: ione=1
real(kind(1.d0)) :: time(10), mpi_wtime
external mpi_wtime
logical, parameter :: debug=.false.
character(len=20) :: name, ch_err
if(psb_get_errstatus().ne.0) return
info=0
name = 'psb_dspcnv'
call psb_erractionsave(err_act)

@ -26,9 +26,9 @@ subroutine psb_dspfree(a, desc_a,info)
integer :: temp(1)
real(kind(1.d0)) :: real_err(5)
integer :: icontxt,nprow,npcol,me,mypcol,err, err_act
integer,parameter :: ione=1
character(len=20) :: name, ch_err
if(psb_get_errstatus().ne.0) return
info=0
name = 'psb_dspfree'
call psb_erractionsave(err_act)
@ -95,78 +95,78 @@ end subroutine psb_dspfree
!!$subroutine psb_dspfrees(a, info)
!!$ !...free sparse matrix structure...
!!$ use psb_descriptor_type
!!$ use psb_spmat_type
!!$ use psb_serial_mod
!!$ use psb_const_mod
!!$ use psb_error_mod
!!$ implicit none
!!$
!!$ !....parameters...
!!$ type(psb_dspmat_type), intent(inout) ::a
!!$ integer, intent(out) :: info
!!$ !...locals....
!!$ integer :: int_err(5)
!!$ integer :: temp(1)
!!$ real(kind(1.d0)) :: real_err(5)
!!$ integer :: icontxt,nprow,npcol,me,mypcol,err, err_act
!!$ integer,parameter :: ione=1
!!$ character(len=20) :: name, ch_err
!!$
!!$ info=0
!!$ name = 'psb_dspfrees'
!!$ call psb_erractionsave(err_act)
!!$
!!$ !...deallocate a....
!!$
!!$ if ((info.eq.0).and.(.not.associated(a%pr))) info=2951
!!$ if (info.eq.0) then
!!$ !deallocate pr field
!!$ deallocate(a%pr,stat=info)
!!$ if (info.ne.0) info=2045
!!$ end if
!!$ if ((info.eq.0).and.(.not.associated(a%pl))) info=2952
!!$ !deallocate pl field
!!$ if (info.eq.0) then
!!$ deallocate(a%pl,stat=info)
!!$ if (info.ne.0) info=2046
!!$ end if
!!$ if ((info.eq.0).and.(.not.associated(a%ia2))) info=2953
!!$ if (info.eq.0) then
!!$ !deallocate ia2 field
!!$ deallocate(a%ia2,stat=info)
!!$ if (info.ne.0) info=2047
!!$ end if
!!$ if ((info.eq.0).and.(.not.associated(a%ia1))) info=2954
!!$ if (info.eq.0) then
!!$ !deallocate ia1 field
!!$ deallocate(a%ia1,stat=info)
!!$ if (info.ne.0) info=2048
!!$ endif
!!$ if ((info.eq.0).and.(.not.associated(a%aspk))) info=2955
!!$ if (info.eq.0) then
!!$ !deallocate aspk field
!!$ deallocate(a%aspk,stat=info)
!!$ if (info.ne.0) info=2049
!!$ endif
!!$ if (info.eq.0) call psb_nullify_sp(a)
!!$
!!$ if(info.ne.0) then
!!$ call psb_errpush(info,name)
!!$ goto 9999
!!$ end if
!!$
!!$ call psb_erractionrestore(err_act)
!!$ return
!!$
!!$9999 continue
!!$ call psb_erractionrestore(err_act)
!!$ if (err_act.eq.act_abort) then
!!$ call psb_error()
!!$ return
!!$ end if
!!$ return
!!$
!!$end subroutine psb_dspfrees
subroutine psb_dspfrees(a, info)
!...free sparse matrix structure...
use psb_descriptor_type
use psb_spmat_type
use psb_serial_mod
use psb_const_mod
use psb_error_mod
implicit none
!....parameters...
type(psb_dspmat_type), intent(inout) ::a
integer, intent(out) :: info
!...locals....
integer :: int_err(5)
integer :: temp(1)
real(kind(1.d0)) :: real_err(5)
integer :: icontxt,nprow,npcol,me,mypcol,err, err_act
character(len=20) :: name, ch_err
if(psb_get_errstatus().ne.0) return
info=0
name = 'psb_dspfrees'
call psb_erractionsave(err_act)
!...deallocate a....
if ((info.eq.0).and.(.not.associated(a%pr))) info=2951
if (info.eq.0) then
!deallocate pr field
deallocate(a%pr,stat=info)
if (info.ne.0) info=2045
end if
if ((info.eq.0).and.(.not.associated(a%pl))) info=2952
!deallocate pl field
if (info.eq.0) then
deallocate(a%pl,stat=info)
if (info.ne.0) info=2046
end if
if ((info.eq.0).and.(.not.associated(a%ia2))) info=2953
if (info.eq.0) then
!deallocate ia2 field
deallocate(a%ia2,stat=info)
if (info.ne.0) info=2047
end if
if ((info.eq.0).and.(.not.associated(a%ia1))) info=2954
if (info.eq.0) then
!deallocate ia1 field
deallocate(a%ia1,stat=info)
if (info.ne.0) info=2048
endif
if ((info.eq.0).and.(.not.associated(a%aspk))) info=2955
if (info.eq.0) then
!deallocate aspk field
deallocate(a%aspk,stat=info)
if (info.ne.0) info=2049
endif
if (info.eq.0) call psb_nullify_sp(a)
if(info.ne.0) then
call psb_errpush(info,name)
goto 9999
end if
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act.eq.act_abort) then
call psb_error()
return
end if
return
end subroutine psb_dspfrees

@ -61,6 +61,7 @@ subroutine psb_dspupdate(a, ia, ja, blck, desc_a,info,ix,jx,updflag)
integer,pointer :: iworkaux(:)
character(len=20) :: name, ch_err
if(psb_get_errstatus().ne.0) return
info=0
name='psb_dspupdate'
call psb_erractionsave(err_act)

@ -31,6 +31,7 @@ subroutine psb_glob_to_loc2(x,y,desc_a,info,iact)
integer, parameter :: zero=0
character(len=20) :: name, char_err
if(psb_get_errstatus().ne.0) return
info=0
name = 'glob_to_loc'
call psb_erractionsave(err_act)
@ -133,6 +134,7 @@ subroutine psb_glob_to_loc(x,desc_a,info,iact)
integer, parameter :: zero=0
character(len=20) :: name, char_err
if(psb_get_errstatus().ne.0) return
info=0
name = 'glob_to_loc'
call psb_erractionsave(err_act)

@ -32,6 +32,7 @@ subroutine psb_ialloc(m, n, x, desc_a, info,js)
real(kind(1.d0)) :: real_err(5)
character(len=20) :: name, char_err
if(psb_get_errstatus().ne.0) return
info=0
name='psb_ialloc'
call psb_erractionsave(err_act)
@ -180,6 +181,7 @@ subroutine psb_iallocv(m, x, desc_a, info)
logical, parameter :: debug=.false.
character(len=20) :: name, char_err
if(psb_get_errstatus().ne.0) return
info=0
name='psb_iallocv'
call psb_erractionsave(err_act)

@ -24,11 +24,10 @@ subroutine psb_iasb(x, desc_a, info)
integer, pointer :: itemp(:,:)
integer :: int_err(5), i1sz, i2sz, dectype, i
real(kind(1.d0)) :: real_err(5)
integer, parameter :: ione=1
real(kind(1.d0)),parameter :: one=1
logical, parameter :: debug=.false.
character(len=20) :: name, char_err
if(psb_get_errstatus().ne.0) return
info=0
name='psb_iasb'
call psb_erractionsave(err_act)
@ -76,7 +75,7 @@ subroutine psb_iasb(x, desc_a, info)
endif
! ..update halo elements..
call psb_halo(x,desc_a,info,alpha=one)
call psb_halo(x,desc_a,info,alpha=done)
call psb_erractionrestore(err_act)
return
@ -117,11 +116,10 @@ subroutine psb_iasbv(x, desc_a, info)
integer :: int_err(5), i1sz,nrow,ncol, dectype, i
integer, pointer :: itemp(:)
real(kind(1.d0)) :: real_err(5)
integer, parameter :: ione=1
real(kind(1.d0)),parameter :: one=1
logical, parameter :: debug=.false.
character(len=20) :: name, ch_err
if(psb_get_errstatus().ne.0) return
info=0
call psb_erractionsave(err_act)
name = 'psb_iasbv'
@ -162,7 +160,7 @@ subroutine psb_iasbv(x, desc_a, info)
endif
! ..update halo elements..
call psb_halo(x,desc_a,info,alpha=one)
call psb_halo(x,desc_a,info,alpha=done)
call psb_erractionrestore(err_act)
return

@ -24,9 +24,9 @@ subroutine psb_ifree(x, desc_a, info)
integer :: temp(1)
real(kind(1.d0)) :: real_err(5)
integer :: icontxt,nprow,npcol,me,mypcol,err_act
integer,parameter :: ione=1
character(len=20) :: name, ch_err
if(psb_get_errstatus().ne.0) return
info=0
call psb_erractionsave(err_act)
name = 'psb_ifree'
@ -104,9 +104,9 @@ subroutine psb_ifreev(x, desc_a,info)
integer :: temp(1)
real(kind(1.d0)) :: real_err(5)
integer :: icontxt,nprow,npcol,me,mypcol,err_act
integer,parameter :: ione=1
character(len=20) :: name, ch_err
if(psb_get_errstatus().ne.0) return
info=0
call psb_erractionsave(err_act)
name = 'psb_ifreev'

@ -38,6 +38,7 @@ subroutine psb_iins(m, n, x, ix, jx, blck, desc_a, info,&
integer :: nprow,npcol, myrow ,mycol, int_err(5),err_act
character(len=20) :: name, ch_err
if(psb_get_errstatus().ne.0) return
info=0
call psb_erractionsave(err_act)
name = 'psb_iins'
@ -209,6 +210,7 @@ subroutine psb_iinsvm(m, x, ix, jx, blck, desc_a, info,&
integer :: nprow,npcol, myrow ,mycol
character(len=20) :: name, ch_err
if(psb_get_errstatus().ne.0) return
info=0
name = 'psb_iinsvm'
call psb_erractionsave(err_act)
@ -294,6 +296,7 @@ subroutine psb_iinsvv(m, x, ix, blck, desc_a, info,&
integer :: nprow,npcol, myrow ,mycol
character(len=20) :: name, ch_err
if(psb_get_errstatus().ne.0) return
info=0
name = 'psb_iinsvv'
call psb_erractionsave(err_act)

@ -32,6 +32,7 @@ subroutine psb_loc_to_glob2(x,y,desc_a,info,iact)
integer, parameter :: zero=0
character(len=20) :: name, char_err
if(psb_get_errstatus().ne.0) return
info=0
name='psb_loc_to_glob2'
call psb_erractionsave(err_act)
@ -124,6 +125,7 @@ subroutine psb_loc_to_glob(x,desc_a,info,iact)
integer, parameter :: zero=0
character(len=20) :: name, char_err
if(psb_get_errstatus().ne.0) return
info=0
name='psb_loc_to_glob'
call psb_erractionsave(err_act)

@ -1,13 +1,13 @@
11 Number of inputs
bcsstk35.mtx This (and others) from: http://math.nist.gov/MatrixMarket/
kivap001.mtx This (and others) from: http://math.nist.gov/MatrixMarket/
NONE
CGS
BICGSTAB
ILU !!!! Actually, it's IPREC below. Should take this line out.
CSR
2 IPART: Partition method
1 IPART: Partition method
1 ISTOPC
00800 ITMAX
6 ITRACE
7 IPREC 0:NONE 1:DIAGSC 2:ILU 3: AS 4: RAS 5,6: variants
4 IPREC 0:NONE 1:DIAGSC 2:ILU 3: AS 4: RAS 5,6: variants
1 ML
1.d-6 EPS
1.d-7 EPS

@ -81,6 +81,7 @@ program df_sample
amroot = (myprow==0).and.(mypcol==0)
name='df_sample'
if(psb_get_errstatus().ne.0) return
info=0
call psb_set_errverbosity(2)
call psb_set_erraction(0)
@ -194,7 +195,7 @@ program df_sample
write(*,'("Time to read and partition matrix : ",es10.4)')t2
write(*,'(" ")')
end if
!
! prepare the preconditioning matrix. note the availability
! of optional parameters
@ -272,8 +273,8 @@ program df_sample
call dgamx2d(ictxt,'a',' ',ione, ione,t2,ione,t1,t1,-1,-1,-1)
call psb_axpby(1.d0,b_col,0.d0,r_col,desc_a,info)
call psb_spmm(-1.d0,a,x_col,1.d0,r_col,desc_a,info)
call psb_nrm2(resmx,r_col,desc_a,info)
call psb_amax(resmxp,r_col,desc_a,info)
call psb_nrm2s(resmx,r_col,desc_a,info)
call psb_amaxs(resmxp,r_col,desc_a,info)
!!$ iter=iparm(5)
!!$ err = rparm(2)
@ -281,7 +282,7 @@ program df_sample
! call psb_prec_descr(6,pre)
write(*,'("Matrix: ",a)')mtrx_file
write(*,'("Computed solution on ",i4," processors")')nprow
write(*,'("Iterations to convergence: ",i)')iter
write(*,'("Iterations to convergence: ",i6)')iter
write(*,'("Error indicator on exit: ",f7.2)')err
write(*,'("Time to buil prec. : ",es10.4)')tprec
write(*,'("Time to solve matrix : ",es10.4)')t2

@ -98,12 +98,12 @@ CONTAINS
CALL IGEBS2D(ICONTXT,'ALL',' ',6,1,INPARMS,6)
CALL DGEBS2D(ICONTXT,'ALL',' ',1,1,EPS,1)
write(*,'("Solving matrix : ",a)')mtrx_file
write(*,'("Number of processors : ",i)')nprow
write(*,'("Solving matrix : ",a20)')mtrx_file
write(*,'("Number of processors : ",i3)')nprow
write(*,'("Data distribution : ",i2)')ipart
write(*,'("Preconditioner : ",i)')iprec
if(iprec.gt.2) write(*,'("Overlapping levels : ",i)')novr
write(*,'("Iterative method : ",a)')cmethd
write(*,'("Preconditioner : ",i2)')iprec
if(iprec.gt.2) write(*,'("Overlapping levels : ",i2)')novr
write(*,'("Iterative method : ",a20)')cmethd
write(*,'("Storage format : ",a3)')afmt(1:3)
write(*,'(" ")')
else

Loading…
Cancel
Save