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

Added more error control in overlap build.

Browse Source 
Optional arguments to psb_krylov to be invoked by keyword.
psblas3-type-indexed
Salvatore Filippone 19 years ago
parent a15b856bd9
commit f2c532f812
7 changed files with 105 additions and 59 deletions
Show Stats Download Patch File Download Diff File

17
src/tools/psb_dcdovr.f90
Unescape Escape View File

@ -126,7 +126,7 @@ Subroutine psb_dcdovr(a,desc_a,novr,desc_ov,info)
! !
if (debug) write(0,*) 'Calling desccpy' if (debug) write(0,*) 'Calling desccpy'
call psb_cdcpy(desc_a,desc_ov,info) call psb_cdcpy(desc_a,desc_ov,info)
if (info.ne.0) then if (info /= 0) then
info=4010 info=4010
ch_err='psb_cdcpy' ch_err='psb_cdcpy'
call psb_errpush(info,name,a_err=ch_err) call psb_errpush(info,name,a_err=ch_err)
@ -161,7 +161,7 @@ Subroutine psb_dcdovr(a,desc_a,novr,desc_ov,info)
! nonzeros per row is the same as the global. ! nonzeros per row is the same as the global.
! !
call psb_spinfo(psb_nztotreq_,a,nztot,info) call psb_spinfo(psb_nztotreq_,a,nztot,info)
if (info.ne.0) then if (info /= 0) then
info=4010 info=4010
ch_err='psb_spinfo' ch_err='psb_spinfo'
call psb_errpush(info,name,a_err=ch_err) call psb_errpush(info,name,a_err=ch_err)
@ -184,7 +184,7 @@ Subroutine psb_dcdovr(a,desc_a,novr,desc_ov,info)
& desc_ov%ovrlap_elem(novr*(Max(elem_dim,1)+3)),& & desc_ov%ovrlap_elem(novr*(Max(elem_dim,1)+3)),&
& desc_ov%matrix_data(psb_mdata_size_),& & desc_ov%matrix_data(psb_mdata_size_),&
& desc_ov%halo_index(novr*(Size(desc_a%halo_index)+3)),STAT=INFO) & desc_ov%halo_index(novr*(Size(desc_a%halo_index)+3)),STAT=INFO)
if (info.ne.0) then if (info /= 0) then
info=4000 info=4000
call psb_errpush(info,name) call psb_errpush(info,name)
goto 9999 goto 9999
@ -200,7 +200,12 @@ Subroutine psb_dcdovr(a,desc_a,novr,desc_ov,info)
desc_ov%matrix_data(psb_dec_type_) = psb_desc_bld_ desc_ov%matrix_data(psb_dec_type_) = psb_desc_bld_
Allocate(desc_ov%loc_to_glob(Size(desc_a%loc_to_glob)),& Allocate(desc_ov%loc_to_glob(Size(desc_a%loc_to_glob)),&
& desc_ov%glob_to_loc(Size(desc_a%glob_to_loc))) & desc_ov%glob_to_loc(Size(desc_a%glob_to_loc)),stat=info)
if (info /= 0) then
info=4000
call psb_errpush(info,name)
goto 9999
end if
desc_ov%loc_to_glob(:) = desc_a%loc_to_glob(:) desc_ov%loc_to_glob(:) = desc_a%loc_to_glob(:)
desc_ov%glob_to_loc(:) = desc_a%glob_to_loc(:) desc_ov%glob_to_loc(:) = desc_a%glob_to_loc(:)
@ -213,7 +218,7 @@ Subroutine psb_dcdovr(a,desc_a,novr,desc_ov,info)
! !
Call psb_cdovrbld(novr,desc_ov,desc_a,a,& Call psb_cdovrbld(novr,desc_ov,desc_a,a,&
& l_tmp_halo,l_tmp_ovr_idx,lworks,lworkr,info) & l_tmp_halo,l_tmp_ovr_idx,lworks,lworkr,info)
if (info.ne.0) then if (info /= 0) then
info=4010 info=4010
ch_err='psb_cdovrbld' ch_err='psb_cdovrbld'
call psb_errpush(info,name,a_err=ch_err) call psb_errpush(info,name,a_err=ch_err)
@ -231,7 +236,7 @@ Subroutine psb_dcdovr(a,desc_a,novr,desc_ov,info)
9999 continue 9999 continue
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
if (err_act.eq.act_abort) then if (err_act == act_abort) then
call psb_error(ictxt) call psb_error(ictxt)
return return
end if end if

62
src/tools/psb_dcdovrbld.f90
Unescape Escape View File

@ -87,7 +87,7 @@ Subroutine psb_dcdovrbld(n_ovr,desc_p,desc_a,a,&
real(kind(1.d0)) :: t1,t2,t3,t4,t5,t6,t7, tl, tch real(kind(1.d0)) :: t1,t2,t3,t4,t5,t6,t7, tl, tch
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
if(psb_get_errstatus().ne.0) return if(psb_get_errstatus() /= 0) return
info=0 info=0
name='psb_cdovrbld' name='psb_cdovrbld'
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
@ -99,6 +99,10 @@ Subroutine psb_dcdovrbld(n_ovr,desc_p,desc_a,a,&
call psb_nullify_sp(blk) call psb_nullify_sp(blk)
Allocate(brvindx(np+1),rvsz(np),sdsz(np),bsdindx(np+1),stat=info) Allocate(brvindx(np+1),rvsz(np),sdsz(np),bsdindx(np+1),stat=info)
if (info /= 0) then
call psb_errpush(4010,name,a_err='Allocate')
goto 9999
end if
tl = 0.0 tl = 0.0
tch = 0.0 tch = 0.0
t4 = 0.0 t4 = 0.0
@ -122,7 +126,7 @@ Subroutine psb_dcdovrbld(n_ovr,desc_p,desc_a,a,&
call psb_sp_all(blk,max(lworks,lworkr),info) call psb_sp_all(blk,max(lworks,lworkr),info)
if (info.ne.0) then if (info /= 0) then
info=4010 info=4010
ch_err='psb_sp_all' ch_err='psb_sp_all'
call psb_errpush(info,name,a_err=ch_err) call psb_errpush(info,name,a_err=ch_err)
@ -148,7 +152,7 @@ Subroutine psb_dcdovrbld(n_ovr,desc_p,desc_a,a,&
! See comment in main loop below. ! See comment in main loop below.
call InitPairSearchTree(info) call InitPairSearchTree(info)
if (info.ne.0) then if (info /= 0) then
info=4010 info=4010
ch_err='InitPairSearhTree' ch_err='InitPairSearhTree'
call psb_errpush(info,name,a_err=ch_err) call psb_errpush(info,name,a_err=ch_err)
@ -254,7 +258,7 @@ Subroutine psb_dcdovrbld(n_ovr,desc_p,desc_a,a,&
isz = max((3*Size(tmp_ovr_idx))/2,(counter_o+3)) isz = max((3*Size(tmp_ovr_idx))/2,(counter_o+3))
if (debug) write(0,*) myrow,'Realloc tmp_ovr',isz if (debug) write(0,*) myrow,'Realloc tmp_ovr',isz
call psb_realloc(isz,tmp_ovr_idx,info,pad=-1) call psb_realloc(isz,tmp_ovr_idx,info,pad=-1)
if (info.ne.0) then if (info /= 0) then
info=4010 info=4010
ch_err='psb_realloc' ch_err='psb_realloc'
call psb_errpush(info,name,a_err=ch_err) call psb_errpush(info,name,a_err=ch_err)
@ -272,7 +276,7 @@ Subroutine psb_dcdovrbld(n_ovr,desc_p,desc_a,a,&
isz = max((3*Size(tmp_halo))/2,(counter_h+3)) isz = max((3*Size(tmp_halo))/2,(counter_h+3))
if (debug) write(0,*) myrow,'Realloc tmp_halo',isz if (debug) write(0,*) myrow,'Realloc tmp_halo',isz
call psb_realloc(isz,tmp_halo,info) call psb_realloc(isz,tmp_halo,info)
if (info.ne.0) then if (info /= 0) then
info=4010 info=4010
ch_err='psb_realloc' ch_err='psb_realloc'
call psb_errpush(info,name,a_err=ch_err) call psb_errpush(info,name,a_err=ch_err)
@ -298,7 +302,7 @@ Subroutine psb_dcdovrbld(n_ovr,desc_p,desc_a,a,&
isz = max((3*Size(desc_p%ovrlap_elem))/2,(counter_e+3)) isz = max((3*Size(desc_p%ovrlap_elem))/2,(counter_e+3))
if (debug) write(0,*) myrow,'Realloc ovr_El',isz if (debug) write(0,*) myrow,'Realloc ovr_El',isz
call psb_realloc(isz,desc_p%ovrlap_elem,info) call psb_realloc(isz,desc_p%ovrlap_elem,info)
if (info.ne.0) then if (info /= 0) then
info=4010 info=4010
ch_err='psrealloc' ch_err='psrealloc'
call psb_errpush(info,name,a_err=ch_err) call psb_errpush(info,name,a_err=ch_err)
@ -331,7 +335,7 @@ Subroutine psb_dcdovrbld(n_ovr,desc_p,desc_a,a,&
isz = max((3*Size(tmp_ovr_idx))/2,(counter_o+3)) isz = max((3*Size(tmp_ovr_idx))/2,(counter_o+3))
if (debug) write(0,*) myrow,'Realloc tmp_ovr',isz if (debug) write(0,*) myrow,'Realloc tmp_ovr',isz
call psb_realloc(isz,tmp_ovr_idx,info) call psb_realloc(isz,tmp_ovr_idx,info)
if (info.ne.0) then if (info /= 0) then
info=4010 info=4010
ch_err='psrealloc' ch_err='psrealloc'
call psb_errpush(info,name,a_err=ch_err) call psb_errpush(info,name,a_err=ch_err)
@ -356,7 +360,7 @@ Subroutine psb_dcdovrbld(n_ovr,desc_p,desc_a,a,&
isz = max((3*Size(desc_p%ovrlap_elem))/2,(counter_e+3)) isz = max((3*Size(desc_p%ovrlap_elem))/2,(counter_e+3))
if (debug) write(0,*) myrow,'Realloc ovr_el',isz if (debug) write(0,*) myrow,'Realloc ovr_el',isz
call psb_realloc(isz,desc_p%ovrlap_elem,info) call psb_realloc(isz,desc_p%ovrlap_elem,info)
if (info.ne.0) then if (info /= 0) then
info=4010 info=4010
ch_err='psb_realloc' ch_err='psb_realloc'
call psb_errpush(info,name,a_err=ch_err) call psb_errpush(info,name,a_err=ch_err)
@ -378,7 +382,7 @@ Subroutine psb_dcdovrbld(n_ovr,desc_p,desc_a,a,&
! !
If (i_ovr < (n_ovr)) Then If (i_ovr < (n_ovr)) Then
call psb_spinfo(psb_nzrowreq_,a,n_elem,info,iaux=idx) call psb_spinfo(psb_nzrowreq_,a,n_elem,info,iaux=idx)
if (info.ne.0) then if (info /= 0) then
info=4010 info=4010
ch_err='psb_spinfo' ch_err='psb_spinfo'
call psb_errpush(info,name,a_err=ch_err) call psb_errpush(info,name,a_err=ch_err)
@ -389,7 +393,7 @@ Subroutine psb_dcdovrbld(n_ovr,desc_p,desc_a,a,&
isz = max((3*lworks)/2,(idxs+tot_elem+n_elem)) isz = max((3*lworks)/2,(idxs+tot_elem+n_elem))
if (debug) write(0,*) myrow,'Realloc works',isz if (debug) write(0,*) myrow,'Realloc works',isz
call psb_realloc(isz,works,info) call psb_realloc(isz,works,info)
if (info.ne.0) then if (info /= 0) then
info=4010 info=4010
ch_err='psb_realloc' ch_err='psb_realloc'
call psb_errpush(info,name,a_err=ch_err) call psb_errpush(info,name,a_err=ch_err)
@ -401,7 +405,7 @@ Subroutine psb_dcdovrbld(n_ovr,desc_p,desc_a,a,&
isz = max((3*size(blk%ia2))/2,(n_elem)) isz = max((3*size(blk%ia2))/2,(n_elem))
if (debug) write(0,*) myrow,'Realloc blk',isz if (debug) write(0,*) myrow,'Realloc blk',isz
call psb_sp_reall(blk,isz,info) call psb_sp_reall(blk,isz,info)
if (info.ne.0) then if (info /= 0) then
info=4010 info=4010
ch_err='psb_sp_reall' ch_err='psb_sp_reall'
call psb_errpush(info,name,a_err=ch_err) call psb_errpush(info,name,a_err=ch_err)
@ -410,7 +414,7 @@ Subroutine psb_dcdovrbld(n_ovr,desc_p,desc_a,a,&
End If End If
call psb_spgtblk(idx,a,blk,info) call psb_spgtblk(idx,a,blk,info)
if (info.ne.0) then if (info /= 0) then
info=4010 info=4010
ch_err='psb_spgtblk' ch_err='psb_spgtblk'
call psb_errpush(info,name,a_err=ch_err) call psb_errpush(info,name,a_err=ch_err)
@ -434,6 +438,10 @@ Subroutine psb_dcdovrbld(n_ovr,desc_p,desc_a,a,&
!!$ write(0,*) me,'Realloc temp',tot_elem+2 !!$ write(0,*) me,'Realloc temp',tot_elem+2
deallocate(temp) deallocate(temp)
allocate(temp(tot_elem+2),stat=info) allocate(temp(tot_elem+2),stat=info)
if (info /= 0) then
call psb_errpush(4010,name,a_err='Allocate')
goto 9999
end if
endif endif
Call mrgsrt(tot_elem,works(idxs+1),temp,info) Call mrgsrt(tot_elem,works(idxs+1),temp,info)
If (info.Eq.0) Call ireordv1(tot_elem,works(idxs+1),temp) If (info.Eq.0) Call ireordv1(tot_elem,works(idxs+1),temp)
@ -467,7 +475,7 @@ Subroutine psb_dcdovrbld(n_ovr,desc_p,desc_a,a,&
! matchings SENDs. ! matchings SENDs.
! !
call mpi_alltoall(sdsz,1,mpi_integer,rvsz,1,mpi_integer,icomm,info) call mpi_alltoall(sdsz,1,mpi_integer,rvsz,1,mpi_integer,icomm,info)
if (info.ne.0) then if (info /= 0) then
info=4010 info=4010
ch_err='mpi_alltoall' ch_err='mpi_alltoall'
call psb_errpush(info,name,a_err=ch_err) call psb_errpush(info,name,a_err=ch_err)
@ -493,7 +501,7 @@ Subroutine psb_dcdovrbld(n_ovr,desc_p,desc_a,a,&
iszr=sum(rvsz) iszr=sum(rvsz)
if (max(iszr,1) > lworkr) then if (max(iszr,1) > lworkr) then
call psb_realloc(max(iszr,1),workr,info) call psb_realloc(max(iszr,1),workr,info)
if (info.ne.0) then if (info /= 0) then
info=4010 info=4010
ch_err='psb_realloc' ch_err='psb_realloc'
call psb_errpush(info,name,a_err=ch_err) call psb_errpush(info,name,a_err=ch_err)
@ -504,7 +512,7 @@ Subroutine psb_dcdovrbld(n_ovr,desc_p,desc_a,a,&
call mpi_alltoallv(works,sdsz,bsdindx,mpi_integer,& call mpi_alltoallv(works,sdsz,bsdindx,mpi_integer,&
& workr,rvsz,brvindx,mpi_integer,icomm,info) & workr,rvsz,brvindx,mpi_integer,icomm,info)
if (info.ne.0) then if (info /= 0) then
info=4010 info=4010
ch_err='mpi_alltoallv' ch_err='mpi_alltoallv'
call psb_errpush(info,name,a_err=ch_err) call psb_errpush(info,name,a_err=ch_err)
@ -528,7 +536,7 @@ Subroutine psb_dcdovrbld(n_ovr,desc_p,desc_a,a,&
isz = 3*n_col/2 isz = 3*n_col/2
if (debug) write(0,*) myrow,'Realloc loc_to_glob' if (debug) write(0,*) myrow,'Realloc loc_to_glob'
call psb_realloc(isz,desc_p%loc_to_glob,info) call psb_realloc(isz,desc_p%loc_to_glob,info)
if (info.ne.0) then if (info /= 0) then
info=4010 info=4010
ch_err='psrealloc' ch_err='psrealloc'
call psb_errpush(info,name,a_err=ch_err) call psb_errpush(info,name,a_err=ch_err)
@ -570,6 +578,11 @@ Subroutine psb_dcdovrbld(n_ovr,desc_p,desc_a,a,&
if (debug) write(0,*) myrow,'Realloc work',isz if (debug) write(0,*) myrow,'Realloc work',isz
deallocate(work) deallocate(work)
allocate(work(isz),stat=info) allocate(work(isz),stat=info)
if (info /= 0) then
call psb_errpush(4010,name,a_err='Allocate')
goto 9999
end if
lwork=size(work) lwork=size(work)
Endif Endif
t_halo_in(counter_t)=-1 t_halo_in(counter_t)=-1
@ -626,7 +639,7 @@ Subroutine psb_dcdovrbld(n_ovr,desc_p,desc_a,a,&
! first the halo index ! first the halo index
call psi_crea_index(desc_p,tmp_halo,& call psi_crea_index(desc_p,tmp_halo,&
& desc_p%halo_index,.false.,info) & desc_p%halo_index,.false.,info)
if(info.ne.0) then if(info /= 0) then
call psb_errpush(4010,name,a_err='psi_crea_index') call psb_errpush(4010,name,a_err='psi_crea_index')
goto 9999 goto 9999
end if end if
@ -634,7 +647,7 @@ Subroutine psb_dcdovrbld(n_ovr,desc_p,desc_a,a,&
! then the overlap index ! then the overlap index
call psi_crea_index(desc_p,tmp_ovr_idx,& call psi_crea_index(desc_p,tmp_ovr_idx,&
& desc_p%ovrlap_index,.true.,info) & desc_p%ovrlap_index,.true.,info)
if(info.ne.0) then if(info /= 0) then
call psb_errpush(4010,name,a_err='psi_crea_index') call psb_errpush(4010,name,a_err='psi_crea_index')
goto 9999 goto 9999
end if end if
@ -644,7 +657,7 @@ Subroutine psb_dcdovrbld(n_ovr,desc_p,desc_a,a,&
! finally bnd_elem ! finally bnd_elem
call psi_crea_bnd_elem(desc_p,info) call psi_crea_bnd_elem(desc_p,info)
if(info.ne.0) then if(info /= 0) then
call psb_errpush(4010,name,a_err='psi_crea_bnd_elem') call psb_errpush(4010,name,a_err='psi_crea_bnd_elem')
goto 9999 goto 9999
end if end if
@ -652,7 +665,12 @@ Subroutine psb_dcdovrbld(n_ovr,desc_p,desc_a,a,&
! Ok, register into MATRIX_DATA & free temporary work areas ! Ok, register into MATRIX_DATA & free temporary work areas
desc_p%matrix_data(psb_dec_type_) = psb_desc_asb_ desc_p%matrix_data(psb_dec_type_) = psb_desc_asb_
allocate(desc_p%lprm(1)) allocate(desc_p%lprm(1),stat=info)
if (info /= 0) then
call psb_errpush(4010,name,a_err='Allocate')
goto 9999
end if
desc_p%lprm(1) = 0 desc_p%lprm(1) = 0
if (debug) then if (debug) then
@ -669,8 +687,8 @@ Subroutine psb_dcdovrbld(n_ovr,desc_p,desc_a,a,&
Deallocate(works,workr,t_halo_in,t_halo_out,work,& Deallocate(works,workr,t_halo_in,t_halo_out,work,&
& length_dl,dep_list,tmp_ovr_idx,tmp_halo,& & length_dl,dep_list,tmp_ovr_idx,tmp_halo,&
& brvindx,rvsz,sdsz,bsdindx,temp,stat=info) & brvindx,rvsz,sdsz,bsdindx,temp,stat=info)
call psb_sp_free(blk,info) if (info == 0) call psb_sp_free(blk,info)
if (info.ne.0) then if (info /= 0) then
info=4010 info=4010
ch_err='sp_free' ch_err='sp_free'
call psb_errpush(info,name,a_err=ch_err) call psb_errpush(info,name,a_err=ch_err)

17
src/tools/psb_zcdovr.f90
Unescape Escape View File

@ -126,7 +126,7 @@ Subroutine psb_zcdovr(a,desc_a,novr,desc_ov,info)
! !
if (debug) write(0,*) 'Calling desccpy' if (debug) write(0,*) 'Calling desccpy'
call psb_cdcpy(desc_a,desc_ov,info) call psb_cdcpy(desc_a,desc_ov,info)
if (info.ne.0) then if (info /= 0) then
info=4010 info=4010
ch_err='psb_cdcpy' ch_err='psb_cdcpy'
call psb_errpush(info,name,a_err=ch_err) call psb_errpush(info,name,a_err=ch_err)
@ -161,7 +161,7 @@ Subroutine psb_zcdovr(a,desc_a,novr,desc_ov,info)
! nonzeros per row is the same as the global. ! nonzeros per row is the same as the global.
! !
call psb_spinfo(psb_nztotreq_,a,nztot,info) call psb_spinfo(psb_nztotreq_,a,nztot,info)
if (info.ne.0) then if (info /= 0) then
info=4010 info=4010
ch_err='psb_spinfo' ch_err='psb_spinfo'
call psb_errpush(info,name,a_err=ch_err) call psb_errpush(info,name,a_err=ch_err)
@ -184,7 +184,7 @@ Subroutine psb_zcdovr(a,desc_a,novr,desc_ov,info)
& desc_ov%ovrlap_elem(novr*(Max(elem_dim,1)+3)),& & desc_ov%ovrlap_elem(novr*(Max(elem_dim,1)+3)),&
& desc_ov%matrix_data(psb_mdata_size_),& & desc_ov%matrix_data(psb_mdata_size_),&
& desc_ov%halo_index(novr*(Size(desc_a%halo_index)+3)),STAT=INFO) & desc_ov%halo_index(novr*(Size(desc_a%halo_index)+3)),STAT=INFO)
if (info.ne.0) then if (info /= 0) then
info=4000 info=4000
call psb_errpush(info,name) call psb_errpush(info,name)
goto 9999 goto 9999
@ -200,7 +200,12 @@ Subroutine psb_zcdovr(a,desc_a,novr,desc_ov,info)
desc_ov%matrix_data(psb_dec_type_) = psb_desc_bld_ desc_ov%matrix_data(psb_dec_type_) = psb_desc_bld_
Allocate(desc_ov%loc_to_glob(Size(desc_a%loc_to_glob)),& Allocate(desc_ov%loc_to_glob(Size(desc_a%loc_to_glob)),&
& desc_ov%glob_to_loc(Size(desc_a%glob_to_loc))) & desc_ov%glob_to_loc(Size(desc_a%glob_to_loc)),stat=info)
if (info /= 0) then
info=4000
call psb_errpush(info,name)
goto 9999
end if
desc_ov%loc_to_glob(:) = desc_a%loc_to_glob(:) desc_ov%loc_to_glob(:) = desc_a%loc_to_glob(:)
desc_ov%glob_to_loc(:) = desc_a%glob_to_loc(:) desc_ov%glob_to_loc(:) = desc_a%glob_to_loc(:)
@ -214,7 +219,7 @@ Subroutine psb_zcdovr(a,desc_a,novr,desc_ov,info)
! !
Call psb_cdovrbld(novr,desc_ov,desc_a,a,& Call psb_cdovrbld(novr,desc_ov,desc_a,a,&
& l_tmp_halo,l_tmp_ovr_idx,lworks,lworkr,info) & l_tmp_halo,l_tmp_ovr_idx,lworks,lworkr,info)
if (info.ne.0) then if (info /= 0) then
info=4010 info=4010
ch_err='psb_cdovrbld' ch_err='psb_cdovrbld'
call psb_errpush(info,name,a_err=ch_err) call psb_errpush(info,name,a_err=ch_err)
@ -232,7 +237,7 @@ Subroutine psb_zcdovr(a,desc_a,novr,desc_ov,info)
9999 continue 9999 continue
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
if (err_act.eq.act_abort) then if (err_act == act_abort) then
call psb_error(ictxt) call psb_error(ictxt)
return return
end if end if

62
src/tools/psb_zcdovrbld.f90
Unescape Escape View File

@ -87,7 +87,7 @@ Subroutine psb_zcdovrbld(n_ovr,desc_p,desc_a,a,&
real(kind(1.d0)) :: t1,t2,t3,t4,t5,t6,t7, tl, tch real(kind(1.d0)) :: t1,t2,t3,t4,t5,t6,t7, tl, tch
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
if(psb_get_errstatus().ne.0) return if(psb_get_errstatus() /= 0) return
info=0 info=0
name='psb_cdovrbld' name='psb_cdovrbld'
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
@ -99,6 +99,10 @@ Subroutine psb_zcdovrbld(n_ovr,desc_p,desc_a,a,&
call psb_nullify_sp(blk) call psb_nullify_sp(blk)
Allocate(brvindx(np+1),rvsz(np),sdsz(np),bsdindx(np+1),stat=info) Allocate(brvindx(np+1),rvsz(np),sdsz(np),bsdindx(np+1),stat=info)
if (info /= 0) then
call psb_errpush(4010,name,a_err='Allocate')
goto 9999
end if
tl = 0.0 tl = 0.0
tch = 0.0 tch = 0.0
t4 = 0.0 t4 = 0.0
@ -122,7 +126,7 @@ Subroutine psb_zcdovrbld(n_ovr,desc_p,desc_a,a,&
call psb_sp_all(blk,max(lworks,lworkr),info) call psb_sp_all(blk,max(lworks,lworkr),info)
if (info.ne.0) then if (info /= 0) then
info=4010 info=4010
ch_err='psb_sp_all' ch_err='psb_sp_all'
call psb_errpush(info,name,a_err=ch_err) call psb_errpush(info,name,a_err=ch_err)
@ -148,7 +152,7 @@ Subroutine psb_zcdovrbld(n_ovr,desc_p,desc_a,a,&
! See comment in main loop below. ! See comment in main loop below.
call InitPairSearchTree(info) call InitPairSearchTree(info)
if (info.ne.0) then if (info /= 0) then
info=4010 info=4010
ch_err='InitPairSearhTree' ch_err='InitPairSearhTree'
call psb_errpush(info,name,a_err=ch_err) call psb_errpush(info,name,a_err=ch_err)
@ -254,7 +258,7 @@ Subroutine psb_zcdovrbld(n_ovr,desc_p,desc_a,a,&
isz = max((3*Size(tmp_ovr_idx))/2,(counter_o+3)) isz = max((3*Size(tmp_ovr_idx))/2,(counter_o+3))
if (debug) write(0,*) myrow,'Realloc tmp_ovr',isz if (debug) write(0,*) myrow,'Realloc tmp_ovr',isz
call psb_realloc(isz,tmp_ovr_idx,info,pad=-1) call psb_realloc(isz,tmp_ovr_idx,info,pad=-1)
if (info.ne.0) then if (info /= 0) then
info=4010 info=4010
ch_err='psb_realloc' ch_err='psb_realloc'
call psb_errpush(info,name,a_err=ch_err) call psb_errpush(info,name,a_err=ch_err)
@ -272,7 +276,7 @@ Subroutine psb_zcdovrbld(n_ovr,desc_p,desc_a,a,&
isz = max((3*Size(tmp_halo))/2,(counter_h+3)) isz = max((3*Size(tmp_halo))/2,(counter_h+3))
if (debug) write(0,*) myrow,'Realloc tmp_halo',isz if (debug) write(0,*) myrow,'Realloc tmp_halo',isz
call psb_realloc(isz,tmp_halo,info) call psb_realloc(isz,tmp_halo,info)
if (info.ne.0) then if (info /= 0) then
info=4010 info=4010
ch_err='psb_realloc' ch_err='psb_realloc'
call psb_errpush(info,name,a_err=ch_err) call psb_errpush(info,name,a_err=ch_err)
@ -298,7 +302,7 @@ Subroutine psb_zcdovrbld(n_ovr,desc_p,desc_a,a,&
isz = max((3*Size(desc_p%ovrlap_elem))/2,(counter_e+3)) isz = max((3*Size(desc_p%ovrlap_elem))/2,(counter_e+3))
if (debug) write(0,*) myrow,'Realloc ovr_El',isz if (debug) write(0,*) myrow,'Realloc ovr_El',isz
call psb_realloc(isz,desc_p%ovrlap_elem,info) call psb_realloc(isz,desc_p%ovrlap_elem,info)
if (info.ne.0) then if (info /= 0) then
info=4010 info=4010
ch_err='psrealloc' ch_err='psrealloc'
call psb_errpush(info,name,a_err=ch_err) call psb_errpush(info,name,a_err=ch_err)
@ -331,7 +335,7 @@ Subroutine psb_zcdovrbld(n_ovr,desc_p,desc_a,a,&
isz = max((3*Size(tmp_ovr_idx))/2,(counter_o+3)) isz = max((3*Size(tmp_ovr_idx))/2,(counter_o+3))
if (debug) write(0,*) myrow,'Realloc tmp_ovr',isz if (debug) write(0,*) myrow,'Realloc tmp_ovr',isz
call psb_realloc(isz,tmp_ovr_idx,info) call psb_realloc(isz,tmp_ovr_idx,info)
if (info.ne.0) then if (info /= 0) then
info=4010 info=4010
ch_err='psrealloc' ch_err='psrealloc'
call psb_errpush(info,name,a_err=ch_err) call psb_errpush(info,name,a_err=ch_err)
@ -356,7 +360,7 @@ Subroutine psb_zcdovrbld(n_ovr,desc_p,desc_a,a,&
isz = max((3*Size(desc_p%ovrlap_elem))/2,(counter_e+3)) isz = max((3*Size(desc_p%ovrlap_elem))/2,(counter_e+3))
if (debug) write(0,*) myrow,'Realloc ovr_el',isz if (debug) write(0,*) myrow,'Realloc ovr_el',isz
call psb_realloc(isz,desc_p%ovrlap_elem,info) call psb_realloc(isz,desc_p%ovrlap_elem,info)
if (info.ne.0) then if (info /= 0) then
info=4010 info=4010
ch_err='psb_realloc' ch_err='psb_realloc'
call psb_errpush(info,name,a_err=ch_err) call psb_errpush(info,name,a_err=ch_err)
@ -378,7 +382,7 @@ Subroutine psb_zcdovrbld(n_ovr,desc_p,desc_a,a,&
! !
If (i_ovr < (n_ovr)) Then If (i_ovr < (n_ovr)) Then
call psb_spinfo(psb_nzrowreq_,a,n_elem,info,iaux=idx) call psb_spinfo(psb_nzrowreq_,a,n_elem,info,iaux=idx)
if (info.ne.0) then if (info /= 0) then
info=4010 info=4010
ch_err='psb_spinfo' ch_err='psb_spinfo'
call psb_errpush(info,name,a_err=ch_err) call psb_errpush(info,name,a_err=ch_err)
@ -389,7 +393,7 @@ Subroutine psb_zcdovrbld(n_ovr,desc_p,desc_a,a,&
isz = max((3*lworks)/2,(idxs+tot_elem+n_elem)) isz = max((3*lworks)/2,(idxs+tot_elem+n_elem))
if (debug) write(0,*) myrow,'Realloc works',isz if (debug) write(0,*) myrow,'Realloc works',isz
call psb_realloc(isz,works,info) call psb_realloc(isz,works,info)
if (info.ne.0) then if (info /= 0) then
info=4010 info=4010
ch_err='psb_realloc' ch_err='psb_realloc'
call psb_errpush(info,name,a_err=ch_err) call psb_errpush(info,name,a_err=ch_err)
@ -401,7 +405,7 @@ Subroutine psb_zcdovrbld(n_ovr,desc_p,desc_a,a,&
isz = max((3*size(blk%ia2))/2,(n_elem)) isz = max((3*size(blk%ia2))/2,(n_elem))
if (debug) write(0,*) myrow,'Realloc blk',isz if (debug) write(0,*) myrow,'Realloc blk',isz
call psb_sp_reall(blk,isz,info) call psb_sp_reall(blk,isz,info)
if (info.ne.0) then if (info /= 0) then
info=4010 info=4010
ch_err='psb_sp_reall' ch_err='psb_sp_reall'
call psb_errpush(info,name,a_err=ch_err) call psb_errpush(info,name,a_err=ch_err)
@ -410,7 +414,7 @@ Subroutine psb_zcdovrbld(n_ovr,desc_p,desc_a,a,&
End If End If
call psb_spgtblk(idx,a,blk,info) call psb_spgtblk(idx,a,blk,info)
if (info.ne.0) then if (info /= 0) then
info=4010 info=4010
ch_err='psb_spgtblk' ch_err='psb_spgtblk'
call psb_errpush(info,name,a_err=ch_err) call psb_errpush(info,name,a_err=ch_err)
@ -434,6 +438,10 @@ Subroutine psb_zcdovrbld(n_ovr,desc_p,desc_a,a,&
!!$ write(0,*) me,'Realloc temp',tot_elem+2 !!$ write(0,*) me,'Realloc temp',tot_elem+2
deallocate(temp) deallocate(temp)
allocate(temp(tot_elem+2),stat=info) allocate(temp(tot_elem+2),stat=info)
if (info /= 0) then
call psb_errpush(4010,name,a_err='Allocate')
goto 9999
end if
endif endif
Call mrgsrt(tot_elem,works(idxs+1),temp,info) Call mrgsrt(tot_elem,works(idxs+1),temp,info)
If (info.Eq.0) Call ireordv1(tot_elem,works(idxs+1),temp) If (info.Eq.0) Call ireordv1(tot_elem,works(idxs+1),temp)
@ -467,7 +475,7 @@ Subroutine psb_zcdovrbld(n_ovr,desc_p,desc_a,a,&
! matchings SENDs. ! matchings SENDs.
! !
call mpi_alltoall(sdsz,1,mpi_integer,rvsz,1,mpi_integer,icomm,info) call mpi_alltoall(sdsz,1,mpi_integer,rvsz,1,mpi_integer,icomm,info)
if (info.ne.0) then if (info /= 0) then
info=4010 info=4010
ch_err='mpi_alltoall' ch_err='mpi_alltoall'
call psb_errpush(info,name,a_err=ch_err) call psb_errpush(info,name,a_err=ch_err)
@ -493,7 +501,7 @@ Subroutine psb_zcdovrbld(n_ovr,desc_p,desc_a,a,&
iszr=sum(rvsz) iszr=sum(rvsz)
if (max(iszr,1) > lworkr) then if (max(iszr,1) > lworkr) then
call psb_realloc(max(iszr,1),workr,info) call psb_realloc(max(iszr,1),workr,info)
if (info.ne.0) then if (info /= 0) then
info=4010 info=4010
ch_err='psb_realloc' ch_err='psb_realloc'
call psb_errpush(info,name,a_err=ch_err) call psb_errpush(info,name,a_err=ch_err)
@ -504,7 +512,7 @@ Subroutine psb_zcdovrbld(n_ovr,desc_p,desc_a,a,&
call mpi_alltoallv(works,sdsz,bsdindx,mpi_integer,& call mpi_alltoallv(works,sdsz,bsdindx,mpi_integer,&
& workr,rvsz,brvindx,mpi_integer,icomm,info) & workr,rvsz,brvindx,mpi_integer,icomm,info)
if (info.ne.0) then if (info /= 0) then
info=4010 info=4010
ch_err='mpi_alltoallv' ch_err='mpi_alltoallv'
call psb_errpush(info,name,a_err=ch_err) call psb_errpush(info,name,a_err=ch_err)
@ -528,7 +536,7 @@ Subroutine psb_zcdovrbld(n_ovr,desc_p,desc_a,a,&
isz = 3*n_col/2 isz = 3*n_col/2
if (debug) write(0,*) myrow,'Realloc loc_to_glob' if (debug) write(0,*) myrow,'Realloc loc_to_glob'
call psb_realloc(isz,desc_p%loc_to_glob,info) call psb_realloc(isz,desc_p%loc_to_glob,info)
if (info.ne.0) then if (info /= 0) then
info=4010 info=4010
ch_err='psrealloc' ch_err='psrealloc'
call psb_errpush(info,name,a_err=ch_err) call psb_errpush(info,name,a_err=ch_err)
@ -570,6 +578,11 @@ Subroutine psb_zcdovrbld(n_ovr,desc_p,desc_a,a,&
if (debug) write(0,*) myrow,'Realloc work',isz if (debug) write(0,*) myrow,'Realloc work',isz
deallocate(work) deallocate(work)
allocate(work(isz),stat=info) allocate(work(isz),stat=info)
if (info /= 0) then
call psb_errpush(4010,name,a_err='Allocate')
goto 9999
end if
lwork=size(work) lwork=size(work)
Endif Endif
t_halo_in(counter_t)=-1 t_halo_in(counter_t)=-1
@ -626,7 +639,7 @@ Subroutine psb_zcdovrbld(n_ovr,desc_p,desc_a,a,&
! first the halo index ! first the halo index
call psi_crea_index(desc_p,tmp_halo,& call psi_crea_index(desc_p,tmp_halo,&
& desc_p%halo_index,.false.,info) & desc_p%halo_index,.false.,info)
if(info.ne.0) then if(info /= 0) then
call psb_errpush(4010,name,a_err='psi_crea_index') call psb_errpush(4010,name,a_err='psi_crea_index')
goto 9999 goto 9999
end if end if
@ -634,7 +647,7 @@ Subroutine psb_zcdovrbld(n_ovr,desc_p,desc_a,a,&
! then the overlap index ! then the overlap index
call psi_crea_index(desc_p,tmp_ovr_idx,& call psi_crea_index(desc_p,tmp_ovr_idx,&
& desc_p%ovrlap_index,.true.,info) & desc_p%ovrlap_index,.true.,info)
if(info.ne.0) then if(info /= 0) then
call psb_errpush(4010,name,a_err='psi_crea_index') call psb_errpush(4010,name,a_err='psi_crea_index')
goto 9999 goto 9999
end if end if
@ -644,7 +657,7 @@ Subroutine psb_zcdovrbld(n_ovr,desc_p,desc_a,a,&
! finally bnd_elem ! finally bnd_elem
call psi_crea_bnd_elem(desc_p,info) call psi_crea_bnd_elem(desc_p,info)
if(info.ne.0) then if(info /= 0) then
call psb_errpush(4010,name,a_err='psi_crea_bnd_elem') call psb_errpush(4010,name,a_err='psi_crea_bnd_elem')
goto 9999 goto 9999
end if end if
@ -652,7 +665,12 @@ Subroutine psb_zcdovrbld(n_ovr,desc_p,desc_a,a,&
! Ok, register into MATRIX_DATA & free temporary work areas ! Ok, register into MATRIX_DATA & free temporary work areas
desc_p%matrix_data(psb_dec_type_) = psb_desc_asb_ desc_p%matrix_data(psb_dec_type_) = psb_desc_asb_
allocate(desc_p%lprm(1)) allocate(desc_p%lprm(1),stat=info)
if (info /= 0) then
call psb_errpush(4010,name,a_err='Allocate')
goto 9999
end if
desc_p%lprm(1) = 0 desc_p%lprm(1) = 0
if (debug) then if (debug) then
@ -669,8 +687,8 @@ Subroutine psb_zcdovrbld(n_ovr,desc_p,desc_a,a,&
Deallocate(works,workr,t_halo_in,t_halo_out,work,& Deallocate(works,workr,t_halo_in,t_halo_out,work,&
& length_dl,dep_list,tmp_ovr_idx,tmp_halo,& & length_dl,dep_list,tmp_ovr_idx,tmp_halo,&
& brvindx,rvsz,sdsz,bsdindx,temp,stat=info) & brvindx,rvsz,sdsz,bsdindx,temp,stat=info)
call psb_sp_free(blk,info) if (info == 0) call psb_sp_free(blk,info)
if (info.ne.0) then if (info /= 0) then
info=4010 info=4010
ch_err='sp_free' ch_err='sp_free'
call psb_errpush(info,name,a_err=ch_err) call psb_errpush(info,name,a_err=ch_err)

2
test/Fileread/df_sample.f90
Unescape Escape View File

@ -276,7 +276,7 @@ program df_sample
call blacs_barrier(ictxt,'all') call blacs_barrier(ictxt,'all')
t1 = mpi_wtime() t1 = mpi_wtime()
call psb_krylov(cmethd,a,pre,b_col,x_col,eps,desc_a,info,& call psb_krylov(cmethd,a,pre,b_col,x_col,eps,desc_a,info,&
& itmax,iter,err,itrace,istop=istopc,irst=ml) & itmax=itmax,iter=iter,err=err,itrace=itrace,istop=istopc,irst=ml)
call blacs_barrier(ictxt,'all') call blacs_barrier(ictxt,'all')
t2 = mpi_wtime() - t1 t2 = mpi_wtime() - t1
call psb_amx(ictxt,t2) call psb_amx(ictxt,t2)

2
test/Fileread/zf_sample.f90
Unescape Escape View File

@ -273,7 +273,7 @@ program zf_sample
call blacs_barrier(ictxt,'all') call blacs_barrier(ictxt,'all')
t1 = mpi_wtime() t1 = mpi_wtime()
call psb_krylov(cmethd,a,pre,b_col,x_col,eps,desc_a,info,& call psb_krylov(cmethd,a,pre,b_col,x_col,eps,desc_a,info,&
& itmax,iter,err,itrace,istop=istopc,irst=ml) & itmax=itmax,iter=iter,err=err,itrace=itrace,istop=istopc,irst=ml)
call blacs_barrier(ictxt,'all') call blacs_barrier(ictxt,'all')
t2 = mpi_wtime() - t1 t2 = mpi_wtime() - t1
call psb_amx(ictxt,t2) call psb_amx(ictxt,t2)

2
test/pargen/ppde90.f90
Unescape Escape View File

@ -202,7 +202,7 @@ program pde90
t1 = mpi_wtime() t1 = mpi_wtime()
eps = 1.d-9 eps = 1.d-9
call psb_krylov(cmethd,a,pre,b,x,eps,desc_a,info,& call psb_krylov(cmethd,a,pre,b,x,eps,desc_a,info,&
& itmax,iter,err,itrace,istop=istopc,irst=ml) & itmax=itmax,iter=iter,err=err,itrace=itrace,istop=istopc,irst=ml)
if(info.ne.0) then if(info.ne.0) then
info=4010 info=4010

Write Preview
Loading…
Cancel
Save