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

Fixed: must on ALLOCATE() to properly handle error conditions.

Browse Source
psblas3-type-indexed
Salvatore Filippone 19 years ago
parent a17c67348b
commit 9054afb579
14 changed files with 235 additions and 46 deletions
Show Stats Download Patch File Download Diff File

17
src/comm/psb_dscatter.f90
Unescape Escape View File

@ -171,7 +171,13 @@ subroutine psb_dscatterm(globx, locx, desc_a, info, iroot,&
end if
! root has to gather size information
allocate(displ(nprow),all_dim(nprow))
allocate(displ(nprow),all_dim(nprow),stat=info)
if(info.ne.0) then
info=4010
ch_err='Allocate'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
call mpi_gather(nrow,1,mpi_integer,all_dim,&
& nprow,mpi_integer,rootrank,icomm,info)
@ -180,7 +186,14 @@ subroutine psb_dscatterm(globx, locx, desc_a, info, iroot,&
! root has to gather loc_glob from each process
if(myrow.eq.root) then
allocate(l_t_g_all(sum(all_dim)),scatterv(sum(all_dim)))
allocate(l_t_g_all(sum(all_dim)),scatterv(sum(all_dim)),stat=info)
if(info.ne.0) then
info=4010
ch_err='Allocate'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
end if
call mpi_gatherv(desc_a%loc_to_glob,nrow,&

9
src/internals/psi_compute_size.f90
Unescape Escape View File

@ -15,7 +15,7 @@ subroutine psi_compute_size(desc_data,&
! ...local array...
integer :: exch(2)
integer :: int_err(5)
integer, pointer :: counter_recv(:), counter_dl(:)
integer, allocatable :: counter_recv(:), counter_dl(:)
! ...parameters
logical, parameter :: debug=.false.
@ -40,7 +40,12 @@ subroutine psi_compute_size(desc_data,&
endif
np=nprow
allocate(counter_dl(0:np-1),counter_recv(0:np-1))
allocate(counter_dl(0:np-1),counter_recv(0:np-1),stat=info)
if (info /= 0) then
call psb_errpush(4010,name,a_err='Allocate')
goto 9999
end if
! ..initialize counters...
do i=0,np-1
counter_recv(i)=0

7
src/internals/psi_crea_bnd_elem.f90
Unescape Escape View File

@ -50,7 +50,12 @@ subroutine psi_crea_bnd_elem(desc_a,info)
j = 0
endif
allocate(desc_a%bnd_elem(j+1))
allocate(desc_a%bnd_elem(j+1),stat=info)
if (info /= 0) then
call psb_errpush(4010,name,a_err='Allocate')
goto 9999
end if
if (.false.) then
desc_a%bnd_elem(1) = j
desc_a%bnd_elem(2:j+1) = work(1:j)

7
src/internals/psi_crea_index.f90
Unescape Escape View File

@ -77,7 +77,12 @@ subroutine psi_crea_index(desc_a,index_in,index_out,glob_idx,info)
! the number of processors becomes very high
dl_lda=np+1
allocate(dep_list(max(1,dl_lda),0:np),length_dl(0:np))
allocate(dep_list(max(1,dl_lda),0:np),length_dl(0:np),stat=info)
if (info /= 0) then
call psb_errpush(4010,name,a_err='Allocate')
goto 9999
end if
! ...extract dependence list (ordered list of identifer process
! which every process must communcate with...
if (debug) write(*,*) 'crea_halo: calling extract_dep_list'

3
src/internals/psi_extrct_dl.f
Unescape Escape View File

@ -222,7 +222,8 @@ c$$$ + i, i, -ione ,-ione,-ione)
if (.true.) then
call igsum2d(icontxt,'all',' ',np+1,1,length_dl,np+1,-1,-1)
call blacs_get(icontxt,10,icomm )
allocate(itmp(dl_lda))
allocate(itmp(dl_lda),stat=info)
if (info /= 0) goto 9999
itmp(1:dl_lda) = dep_list(1:dl_lda,me)
call mpi_allgather(itmp,dl_lda,mpi_integer,
+ dep_list,dl_lda,mpi_integer,icomm,info)

19
src/prec/psb_dbldaggrmat.f90
Unescape Escape View File

@ -317,7 +317,7 @@ contains
name='smooth_aggregate'
if(psb_get_errstatus().ne.0) return
info=0
info=0
call psb_erractionsave(err_act)
icontxt = desc_a%matrix_data(psb_ctxt_)
@ -338,6 +338,10 @@ contains
ntaggr = sum(p%nlaggr)
allocate(nzbr(np), idisp(np),stat=info)
if (info /= 0) then
call psb_errpush(4010,name,a_err='Allocate')
goto 9999
end if
naggrm1 = sum(p%nlaggr(1:myprow))
@ -371,9 +375,10 @@ contains
! nrow: local rows.
!
allocate(p%dorig(nrow),stat=info)
if (info/=0) then
write(0,*) 'Error from allocation',info
endif
if (info /= 0) then
call psb_errpush(4010,name,a_err='Allocate')
goto 9999
end if
! Get diagonal D
call psb_spgtdiag(a,p%dorig,info)
@ -662,7 +667,11 @@ contains
nzbg = bg%infoa(psb_nnz_)
nzl = bg%infoa(psb_nnz_)
allocate(ivall(ntaggr))
allocate(ivall(ntaggr),stat=info)
if (info /= 0) then
call psb_errpush(4010,name,a_err='Allocate')
goto 9999
end if
i = 1
do ip=1,nprows

41
src/prec/psb_dcslu.f90
Unescape Escape View File

@ -132,7 +132,11 @@ subroutine psb_dcslu(a,desc_a,p,upd,info)
endif
if (.not.associated(p%av)) then
allocate(p%av(bp_ilu_avsz))
allocate(p%av(bp_ilu_avsz),stat=info)
if (info /= 0) then
call psb_errpush(4010,name,a_err='Allocate')
goto 9999
end if
endif
do k=1,size(p%av)
call psb_nullify_sp(p%av(k))
@ -169,6 +173,11 @@ subroutine psb_dcslu(a,desc_a,p,upd,info)
endif
if (.not.associated(p%d)) then
allocate(p%d(n_row),stat=info)
if (info /= 0) then
call psb_errpush(4010,name,a_err='Allocate')
goto 9999
end if
endif
@ -319,7 +328,7 @@ contains
character(len=20) :: name, ch_err
if(psb_get_errstatus().ne.0) return
info=0
info=0
name='apply_renum'
call psb_erractionsave(err_act)
@ -343,7 +352,12 @@ contains
!
nnr = p%desc_data%matrix_data(psb_n_row_)
allocate(p%perm(nnr),p%invperm(nnr),itmp2(nnr))
allocate(p%perm(nnr),p%invperm(nnr),itmp2(nnr),stat=info)
if (info /= 0) then
call psb_errpush(4010,name,a_err='Allocate')
goto 9999
end if
do k=1,nnr
itmp2(k) = p%desc_data%loc_to_glob(k)
enddo
@ -359,8 +373,12 @@ contains
! Build ATMP with new numbering.
allocate(itmp(max(8,atmp%m+2,nztmp+2)),rtmp(atmp%m))
allocate(itmp(max(8,atmp%m+2,nztmp+2)),rtmp(atmp%m),stat=info)
if (info /= 0) then
call psb_errpush(4010,name,a_err='Allocate')
goto 9999
end if
j = 1
atmp%ia2(1) = 1
do i=1, atmp%m
@ -480,7 +498,12 @@ contains
goto 9999
end if
allocate(itmp(max(8,atmp%m+2,nztmp+2)))
allocate(itmp(max(8,atmp%m+2,nztmp+2)),stat=info)
if (info /= 0) then
call psb_errpush(4010,name,a_err='Allocate')
goto 9999
end if
itmp(1:8) = 0
! write(0,*) me,' Renumbering: Calling Metis'
! call blacs_barrier(icontxt,'All')
@ -512,7 +535,11 @@ contains
! Build ATMP with new numbering.
allocate(itmp2(max(8,atmp%m+2,nztmp+2)),rtmp(atmp%m))
allocate(itmp2(max(8,atmp%m+2,nztmp+2)),rtmp(atmp%m),stat=info)
if (info /= 0) then
call psb_errpush(4010,name,a_err='Allocate')
goto 9999
end if
j = 1
atmp%ia2(1) = 1

103
src/prec/psb_dprec.f90
Unescape Escape View File

@ -68,7 +68,12 @@ subroutine psb_dprecaply(prec,x,y,desc_data,info,trans, work)
if (present(work)) then
work_ => work
else
allocate(work_(4*desc_data%matrix_data(psb_n_col_)))
allocate(work_(4*desc_data%matrix_data(psb_n_col_)),stat=info)
if (info /= 0) then
call psb_errpush(4010,name,a_err='Allocate')
goto 9999
end if
end if
if (.not.(associated(prec%baseprecv))) then
@ -235,15 +240,29 @@ subroutine psb_dbaseprcaply(prec,x,beta,y,desc_data,trans,work,info)
aux => work(3*isz+1:)
else if ((4*isz) <= size(work)) then
aux => work(1:)
allocate(ww(isz),tx(isz),ty(isz))
allocate(ww(isz),tx(isz),ty(isz),stat=info)
if (info /= 0) then
call psb_errpush(4010,name,a_err='Allocate')
goto 9999
end if
else if ((3*isz) <= size(work)) then
ww => work(1:isz)
tx => work(isz+1:2*isz)
ty => work(2*isz+1:3*isz)
allocate(aux(4*isz))
allocate(aux(4*isz),stat=info)
if (info /= 0) then
call psb_errpush(4010,name,a_err='Allocate')
goto 9999
end if
else
allocate(ww(isz),tx(isz),ty(isz),&
&aux(4*isz))
&aux(4*isz),stat=info)
if (info /= 0) then
call psb_errpush(4010,name,a_err='Allocate')
goto 9999
end if
endif
if (debug) write(0,*)' vdiag: ',prec%d(:)
@ -416,10 +435,19 @@ subroutine psb_dbjacaply(prec,x,beta,y,desc_data,trans,work,info)
if ((4*n_col+n_col) <= size(work)) then
aux => work(n_col+1:)
else
allocate(aux(4*n_col))
allocate(aux(4*n_col),stat=info)
if (info /= 0) then
call psb_errpush(4010,name,a_err='Allocate')
goto 9999
end if
endif
else
allocate(ww(n_col),aux(4*n_col))
allocate(ww(n_col),aux(4*n_col),stat=info)
if (info /= 0) then
call psb_errpush(4010,name,a_err='Allocate')
goto 9999
end if
endif
@ -509,7 +537,12 @@ subroutine psb_dbjacaply(prec,x,beta,y,desc_data,trans,work,info)
goto 9999
endif
allocate(tx(n_col),ty(n_col))
allocate(tx(n_col),ty(n_col),stat=info)
if (info /= 0) then
call psb_errpush(4010,name,a_err='Allocate')
goto 9999
end if
tx = zero
ty = zero
select case(prec%iprcparm(f_type_))
@ -684,7 +717,12 @@ subroutine psb_dmlprcaply(baseprecv,x,beta,y,desc_data,trans,work,info)
nr2l = baseprecv(2)%desc_data%matrix_data(psb_n_col_)
nrg = baseprecv(2)%desc_data%matrix_data(psb_n_row_)
allocate(t2l(nr2l),w2l(nr2l))
allocate(t2l(nr2l),w2l(nr2l),stat=info)
if (info /= 0) then
call psb_errpush(4010,name,a_err='Allocate')
goto 9999
end if
t2l(:) = zero
w2l(:) = zero
@ -693,7 +731,12 @@ subroutine psb_dmlprcaply(baseprecv,x,beta,y,desc_data,trans,work,info)
! Smoothed aggregation
!
allocate(tx(max(n_row,n_col)),ty(max(n_row,n_col)),&
& tz(max(n_row,n_col)))
& tz(max(n_row,n_col)),stat=info)
if (info /= 0) then
call psb_errpush(4010,name,a_err='Allocate')
goto 9999
end if
tx(1:desc_data%matrix_data(psb_n_row_)) = x(1:desc_data%matrix_data(psb_n_row_))
tx(desc_data%matrix_data(psb_n_row_)+1:max(n_row,n_col)) = zero
ty(desc_data%matrix_data(psb_n_row_)+1:max(n_row,n_col)) = zero
@ -770,7 +813,12 @@ subroutine psb_dmlprcaply(baseprecv,x,beta,y,desc_data,trans,work,info)
n_col = baseprecv(1)%desc_data%matrix_data(psb_n_col_)
nr2l = baseprecv(2)%desc_data%matrix_data(psb_n_col_)
nrg = baseprecv(2)%desc_data%matrix_data(psb_n_row_)
allocate(t2l(nr2l),w2l(nr2l),tx(n_col),ty(n_col))
allocate(t2l(nr2l),w2l(nr2l),tx(n_col),ty(n_col),stat=info)
if (info /= 0) then
call psb_errpush(4010,name,a_err='Allocate')
goto 9999
end if
t2l(:) = zero
w2l(:) = zero
@ -788,7 +836,12 @@ subroutine psb_dmlprcaply(baseprecv,x,beta,y,desc_data,trans,work,info)
!
! Smoothed aggregation
!
allocate(tz(max(n_row,n_col)))
allocate(tz(max(n_row,n_col)),stat=info)
if (info /= 0) then
call psb_errpush(4010,name,a_err='Allocate')
goto 9999
end if
if (baseprecv(2)%iprcparm(glb_smth_) >0) then
call psb_halo(tx,desc_data,info,work=work)
@ -859,7 +912,12 @@ subroutine psb_dmlprcaply(baseprecv,x,beta,y,desc_data,trans,work,info)
n_col = baseprecv(1)%desc_data%matrix_data(psb_n_col_)
nr2l = baseprecv(2)%desc_data%matrix_data(psb_n_col_)
nrg = baseprecv(2)%desc_data%matrix_data(psb_n_row_)
allocate(t2l(nr2l),w2l(nr2l),tx(n_col),ty(n_col),tty(n_col))
allocate(t2l(nr2l),w2l(nr2l),tx(n_col),ty(n_col),tty(n_col),stat=info)
if (info /= 0) then
call psb_errpush(4010,name,a_err='Allocate')
goto 9999
end if
t2l(:) = zero
w2l(:) = zero
@ -878,7 +936,12 @@ subroutine psb_dmlprcaply(baseprecv,x,beta,y,desc_data,trans,work,info)
if(info /=0) goto 9999
if (ismth /= no_smth_) then
allocate(tz(max(n_row,n_col)))
allocate(tz(max(n_row,n_col)),stat=info)
if (info /= 0) then
call psb_errpush(4010,name,a_err='Allocate')
goto 9999
end if
if (baseprecv(2)%iprcparm(glb_smth_) >0) then
call psb_halo(tx,desc_data,info,work=work)
@ -943,7 +1006,12 @@ subroutine psb_dmlprcaply(baseprecv,x,beta,y,desc_data,trans,work,info)
n_col = baseprecv(1)%desc_data%matrix_data(psb_n_col_)
nr2l = baseprecv(2)%desc_data%matrix_data(psb_n_col_)
nrg = baseprecv(2)%desc_data%matrix_data(psb_n_row_)
allocate(t2l(nr2l),w2l(nr2l),tx(n_col),ty(n_col),tty(n_col))
allocate(t2l(nr2l),w2l(nr2l),tx(n_col),ty(n_col),tty(n_col),stat=info)
if (info /= 0) then
call psb_errpush(4010,name,a_err='Allocate')
goto 9999
end if
t2l(:) = zero
w2l(:) = zero
tx(:) = zero
@ -1091,7 +1159,12 @@ subroutine psb_dprecaply1(prec,x,desc_data,info,trans)
trans_='N'
end if
allocate(ww(size(x)),w1(size(x)))
allocate(ww(size(x)),w1(size(x)),stat=info)
if (info /= 0) then
call psb_errpush(4010,name,a_err='Allocate')
goto 9999
end if
call psb_dprecaply(prec,x,ww,desc_data,info,trans_,w1)
if(info /=0) goto 9999
x(:) = ww(:)

35
src/prec/psb_dprecbld.f90
Unescape Escape View File

@ -109,7 +109,12 @@ subroutine psb_dprecbld(a,p,desc_a,info,upd)
call psb_check_def(p%baseprecv(1)%iprcparm(p_type_),'base_prec',&
& diagsc_,is_legal_base_prec)
allocate(p%baseprecv(1)%desc_data)
allocate(p%baseprecv(1)%desc_data,stat=info)
if (info /= 0) then
call psb_errpush(4010,name,a_err='Allocate')
goto 9999
end if
call psb_nullify_desc(p%baseprecv(1)%desc_data)
select case(p%baseprecv(1)%iprcparm(p_type_))
@ -169,7 +174,12 @@ subroutine psb_dprecbld(a,p,desc_a,info,upd)
endif
if (debug) then
allocate(gd(mglob))
allocate(gd(mglob),stat=info)
if (info /= 0) then
call psb_errpush(4010,name,a_err='Allocate')
goto 9999
end if
call psb_gather(gd, p%baseprecv(1)%d, desc_a, info, iroot=iroot)
if(info /= 0) then
info=4010
@ -269,7 +279,12 @@ subroutine psb_dprecbld(a,p,desc_a,info,upd)
& pre_smooth_,is_legal_ml_smooth_pos)
call psb_check_def(p%baseprecv(2)%iprcparm(f_type_),'fact',f_ilu_n_,is_legal_ml_fact)
allocate(p%baseprecv(2)%desc_data)
allocate(p%baseprecv(2)%desc_data,stat=info)
if (info /= 0) then
call psb_errpush(4010,name,a_err='Allocate')
goto 9999
end if
call psb_nullify_desc(p%baseprecv(2)%desc_data)
select case(p%baseprecv(2)%iprcparm(f_type_))
@ -728,8 +743,12 @@ subroutine psb_mlprec_bld(a,desc_a,p,info)
call psb_erractionsave(err_act)
p%aorig => a
allocate(p%av(smth_avsz))
allocate(p%av(smth_avsz),stat=info)
if (info /= 0) then
call psb_errpush(4010,name,a_err='Allocate')
goto 9999
end if
do i=1, smth_avsz
call psb_nullify_sp(p%av(i))
call psb_spall(0,0,p%av(i),1,info)
@ -770,7 +789,11 @@ subroutine psb_mlprec_bld(a,desc_a,p,info)
goto 9999
end if
allocate(p%d(nrg))
allocate(p%d(nrg),stat=info)
if (info /= 0) then
call psb_errpush(4010,name,a_err='Allocate')
goto 9999
end if
select case(p%iprcparm(f_type_))
case(f_ilu_n_,f_ilu_e_)

8
src/prec/psb_dprecset.f90
Unescape Escape View File

@ -1,3 +1,4 @@
subroutine psb_dprecset(p,ptype,iv,rs,rv,info)
use psb_serial_mod
@ -30,7 +31,7 @@ subroutine psb_dprecset(p,ptype,iv,rs,rv,info)
endif
end if
select case(toupper(ptype))
select case(toupper(ptype(1:len_trim(ptype))))
case ('NONE','NOPREC')
p%baseprecv(1)%iprcparm(p_type_) = noprec_
p%baseprecv(1)%iprcparm(f_type_) = f_none_
@ -85,7 +86,10 @@ subroutine psb_dprecset(p,ptype,iv,rs,rv,info)
select case (size(p%baseprecv))
case(1)
! Reallocate
allocate(bpv(2))
allocate(bpv(2),stat=err)
if (err/=0) then
write(0,*)'Precset Memory Failure 2l:1',err
endif
bpv(1) = p%baseprecv(1)
call psb_nullify_baseprec(bpv(2))
deallocate(p%baseprecv)

7
src/prec/psb_dsplu.f90
Unescape Escape View File

@ -33,7 +33,12 @@ subroutine psb_dsplu(a,l,u,d,info,blck)
if (present(blck)) then
blck_ => blck
else
allocate(blck_)
allocate(blck_,stat=info)
if (info /= 0) then
call psb_errpush(4010,name,a_err='Allocate')
goto 9999
end if
call psb_nullify_sp(blck_) ! Why do we need this? Who knows....
call psb_spall(0,0,blck_,1,info)
if(info.ne.0) then

7
src/serial/psb_dipcoo2csr.f90
Unescape Escape View File

@ -42,7 +42,12 @@ subroutine psb_dipcoo2csr(a,info,rwshr)
call psb_fixcoo(a,info)
nr = a%m
nza = a%infoa(psb_nnz_)
allocate(iaux(nr+1))
allocate(iaux(nr+1),stat=info)
if (info /= 0) then
call psb_errpush(4010,name,a_err='Allocate')
goto 9999
end if
if(debug) write(0,*)'DIPCOO2CSR: out of fixcoo',nza,nr,size(a%ia2),size(iaux)
itemp => a%ia1

13
src/tools/psb_descasb.f90
Unescape Escape View File

@ -83,7 +83,11 @@ Subroutine psb_descasb(n_ovr,desc_p,desc_a,a,&
lwork=5*(5*np+2)*np+10
Allocate(works(lworks),workr(lworkr),t_halo_in(3*Size(desc_p%halo_index)),&
& t_halo_out(Size(desc_p%halo_index)), work(lwork),&
& length_dl(np+1),dep_list(dl_lda*np),temp(lworkr))
& length_dl(np+1),dep_list(dl_lda*np),temp(lworkr),stat=info)
if (info /= 0) then
call psb_errpush(4010,name,a_err='Allocate')
goto 9999
end if
call psb_spall(blk,max(lworks,lworkr),info)
@ -97,7 +101,12 @@ Subroutine psb_descasb(n_ovr,desc_p,desc_a,a,&
blk%fida='COO'
halo => desc_a%halo_index
Allocate(tmp_ovr_idx(l_tmp_ovr_idx),tmp_halo(l_tmp_halo))
Allocate(tmp_ovr_idx(l_tmp_ovr_idx),tmp_halo(l_tmp_halo),stat=info)
if (info /= 0) then
call psb_errpush(4010,name,a_err='Allocate')
goto 9999
end if
desc_p%ovrlap_elem(:) = -1
tmp_ovr_idx(:) = -1
tmp_halo(:) = -1

5
src/tools/psb_dscall.f90
Unescape Escape View File

@ -250,6 +250,11 @@ subroutine psb_dscall(m, n, parts, icontxt, desc_a, info)
loc_col=int((psb_colrow_+1.d0)*loc_row)+1
allocate(desc_a%loc_to_glob(loc_col),&
&desc_a%lprm(1),stat=info)
if (info /= 0) then
call psb_errpush(4010,name,a_err='Allocate')
goto 9999
end if
call psb_realloc(1, desc_a%lprm, info)
call psb_realloc(loc_col, desc_a%loc_to_glob, info)
if (info /= no_err) then

Write Preview
Loading…
Cancel
Save