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

mld2p4:

Browse Source 
mlprec/mld_caggrmap_bld.f90
 mlprec/mld_cmlprec_bld.f90
 mlprec/mld_cprecinit.f90
 mlprec/mld_cprecset.f90
 mlprec/mld_daggrmap_bld.f90
 mlprec/mld_dmlprec_bld.f90
 mlprec/mld_dprecinit.f90
 mlprec/mld_dprecset.f90
 mlprec/mld_inner_mod.f90
 mlprec/mld_prec_type.f90
 mlprec/mld_saggrmap_bld.f90
 mlprec/mld_smlprec_bld.f90
 mlprec/mld_sprecinit.f90
 mlprec/mld_sprecset.f90
 mlprec/mld_zaggrmap_bld.f90
 mlprec/mld_zmlprec_bld.f90
 mlprec/mld_zprecinit.f90
 mlprec/mld_zprecset.f90
 test/fileread/cf_sample.f90
 test/fileread/df_bench.f90
 test/fileread/df_sample.f90
 test/fileread/runs/cfs.inp
 test/fileread/runs/dfs.inp
 test/fileread/runs/drt.sh
 test/fileread/runs/sfs.inp
 test/fileread/runs/zfs.inp
 test/fileread/sf_sample.f90
 test/fileread/zf_sample.f90


Added an aggregation threshold to account for anisotropies.
stopcriterion
Salvatore Filippone 17 years ago
parent b7d9b380d5
commit b9901f1f8e
28 changed files with 852 additions and 437 deletions
Show Stats Download Patch File Download Diff File

274
mlprec/mld_caggrmap_bld.f90
Unescape Escape View File

@ -74,7 +74,7 @@
! info - integer, output. ! info - integer, output.
! Error code. ! Error code.
! !
subroutine mld_caggrmap_bld(aggr_type,a,desc_a,nlaggr,ilaggr,info) subroutine mld_caggrmap_bld(aggr_type,theta,a,desc_a,nlaggr,ilaggr,info)
use psb_base_mod use psb_base_mod
use mld_inner_mod, mld_protect_name => mld_caggrmap_bld use mld_inner_mod, mld_protect_name => mld_caggrmap_bld
@ -83,7 +83,8 @@ subroutine mld_caggrmap_bld(aggr_type,a,desc_a,nlaggr,ilaggr,info)
! Arguments ! Arguments
integer, intent(in) :: aggr_type integer, intent(in) :: aggr_type
type(psb_cspmat_type), intent(in), target :: a real(psb_spk_), intent(in) :: theta
type(psb_cspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_a type(psb_desc_type), intent(in) :: desc_a
integer, allocatable, intent(out) :: ilaggr(:),nlaggr(:) integer, allocatable, intent(out) :: ilaggr(:),nlaggr(:)
integer, intent(out) :: info integer, intent(out) :: info
@ -91,9 +92,7 @@ subroutine mld_caggrmap_bld(aggr_type,a,desc_a,nlaggr,ilaggr,info)
! Local variables ! Local variables
integer, allocatable :: ils(:), neigh(:) integer, allocatable :: ils(:), neigh(:)
integer :: icnt,nlp,k,n,ia,isz,nr, naggr,i,j,m integer :: icnt,nlp,k,n,ia,isz,nr, naggr,i,j,m
type(psb_cspmat_type), target :: atmp, atrans type(psb_cspmat_type) :: atmp, atrans
type(psb_cspmat_type), pointer :: apnt
logical :: recovery logical :: recovery
integer :: debug_level, debug_unit integer :: debug_level, debug_unit
integer :: ictxt,np,me,err_act integer :: ictxt,np,me,err_act
@ -117,8 +116,93 @@ subroutine mld_caggrmap_bld(aggr_type,a,desc_a,nlaggr,ilaggr,info)
ncol = psb_cd_get_local_cols(desc_a) ncol = psb_cd_get_local_cols(desc_a)
select case (aggr_type) select case (aggr_type)
case (mld_dec_aggr_,mld_sym_dec_aggr_) case (mld_dec_aggr_)
call mld_dec_map_bld(theta,a,desc_a,nlaggr,ilaggr,info)
case (mld_sym_dec_aggr_)
nr = psb_sp_get_nrows(a)
call psb_sp_clip(a,atmp,info,imax=nr,jmax=nr,&
& rscale=.false.,cscale=.false.)
atmp%m=nr
atmp%k=nr
if (info == 0) call psb_transp(atmp,atrans,fmt='COO')
if (info == 0) call psb_rwextd(nr,atmp,info,b=atrans,rowscale=.false.)
atmp%m=nr
atmp%k=nr
if (info == 0) call psb_sp_free(atrans,info)
if (info == 0) call psb_ipcoo2csr(atmp,info)
if (info == 0) call mld_dec_map_bld(theta,atmp,desc_a,nlaggr,ilaggr,info)
if (info == 0) call psb_sp_free(atmp,info)
case default
info = -1
call psb_errpush(30,name,i_err=(/1,aggr_type,0,0,0/))
goto 9999
end select
if (info/=0) then
info=4001
call psb_errpush(info,name,a_err='dec_map_bld')
goto 9999
end if
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act.eq.psb_act_abort_) then
call psb_error()
return
end if
return
contains
subroutine mld_dec_map_bld(theta,a,desc_a,nlaggr,ilaggr,info)
use psb_base_mod
use mld_inner_mod !, mld_protect_name => mld_daggrmap_bld
implicit none
! Arguments
type(psb_cspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_a
real(psb_spk_), intent(in) :: theta
integer, allocatable, intent(out) :: ilaggr(:),nlaggr(:)
integer, intent(out) :: info
! Local variables
integer, allocatable :: ils(:), neigh(:), irow(:), icol(:)
complex(psb_spk_), allocatable :: val(:), diag(:)
integer :: icnt,nlp,k,n,ia,isz,nr, naggr,i,j,m, nz
real(psb_spk_) :: cpling, tcl
logical :: recovery
integer :: debug_level, debug_unit
integer :: ictxt,np,me,err_act
integer :: nrow, ncol, n_ne
character(len=20) :: name, ch_err
if(psb_get_errstatus() /= 0) return
info=0
name = 'mld_dec_map_bld'
call psb_erractionsave(err_act)
debug_unit = psb_get_debug_unit()
debug_level = psb_get_debug_level()
!
! Note. At the time being we are ignoring aggr_type so
! that we only have decoupled aggregation. This might
! change in the future.
!
ictxt=psb_cd_get_context(desc_a)
call psb_info(ictxt,me,np)
nrow = psb_cd_get_local_rows(desc_a)
ncol = psb_cd_get_local_cols(desc_a)
nr = a%m nr = a%m
allocate(ilaggr(nr),neigh(nr),stat=info) allocate(ilaggr(nr),neigh(nr),stat=info)
if(info /= 0) then if(info /= 0) then
@ -128,36 +212,28 @@ subroutine mld_caggrmap_bld(aggr_type,a,desc_a,nlaggr,ilaggr,info)
goto 9999 goto 9999
end if end if
allocate(diag(nr),stat=info)
if(info /= 0) then
info=4025
call psb_errpush(info,name,i_err=(/nr,0,0,0,0/),&
& a_err='complex(psb_spk_)')
goto 9999
end if
call psb_sp_getdiag(a,diag,info)
if(info /= 0) then
info=4010
call psb_errpush(info,name,a_err='psb_sp_getdiag')
goto 9999
end if
do i=1, nr do i=1, nr
ilaggr(i) = -(nr+1) ilaggr(i) = -(nr+1)
end do end do
if (aggr_type == mld_dec_aggr_) then
apnt => a
else
call psb_sp_clip(a,atmp,info,imax=nr,jmax=nr,&
& rscale=.false.,cscale=.false.)
atmp%m=nr
atmp%k=nr
if (info == 0) call psb_transp(atmp,atrans,fmt='COO')
if (info == 0) call psb_rwextd(nr,atmp,info,b=atrans,rowscale=.false.)
atmp%m=nr
atmp%k=nr
if (info == 0) call psb_sp_free(atrans,info)
if (info == 0) call psb_ipcoo2csr(atmp,info)
apnt => atmp
if (info/=0) then
info=4001
call psb_errpush(info,name,a_err='init apnt')
goto 9999
end if
end if
! Note: -(nr+1) Untouched as yet ! Note: -(nr+1) Untouched as yet
! -i 1<=i<=nr Adjacent to aggregate i ! -i 1<=i<=nr Adjacent to aggregate i
! i 1<=i<=nr Belonging to aggregate i ! i 1<=i<=nr Belonging to aggregate i
! !
! Phase one: group nodes together. ! Phase one: group nodes together.
! Very simple minded strategy. ! Very simple minded strategy.
@ -172,26 +248,32 @@ subroutine mld_caggrmap_bld(aggr_type,a,desc_a,nlaggr,ilaggr,info)
! 1. Untouched nodes are marked >0 together ! 1. Untouched nodes are marked >0 together
! with their neighbours ! with their neighbours
! !
icnt = icnt + 1 icnt = icnt + 1
naggr = naggr + 1 naggr = naggr + 1
ilaggr(i) = naggr ilaggr(i) = naggr
call psb_neigh(apnt,i,neigh,n_ne,info,lev=1) call psb_sp_getrow(i,a,nz,irow,icol,val,info)
if (info/=0) then if (info/=0) then
info=4010 info=4010
call psb_errpush(info,name,a_err='psb_neigh') call psb_errpush(info,name,a_err='psb_sp_getrow')
goto 9999 goto 9999
end if end if
do k=1, n_ne
j = neigh(k) do k=1, nz
if ((1<=j).and.(j<=nr)) then j = icol(k)
ilaggr(j) = naggr if ((1<=j).and.(j<=nr).and.(i/=j)) then
endif if (abs(val(k)) > theta*sqrt(abs(diag(i)*diag(j)))) then
ilaggr(j) = naggr
else
ilaggr(j) = -naggr
endif
end if
enddo enddo
! !
! 2. Untouched neighbours of these nodes are marked <0. ! 2. Untouched neighbours of these nodes are marked <0.
! !
call psb_neigh(apnt,i,neigh,n_ne,info,lev=2) call psb_neigh(a,i,neigh,n_ne,info,lev=2)
if (info/=0) then if (info/=0) then
info=4010 info=4010
call psb_errpush(info,name,a_err='psb_neigh') call psb_errpush(info,name,a_err='psb_neigh')
@ -218,7 +300,7 @@ subroutine mld_caggrmap_bld(aggr_type,a,desc_a,nlaggr,ilaggr,info)
! !
! Phase two: sweep over leftovers. ! Phase two: sweep over leftovers.
! !
allocate(ils(naggr+10),stat=info) allocate(ils(nr),stat=info)
if(info /= 0) then if(info /= 0) then
info=4025 info=4025
call psb_errpush(info,name,i_err=(/naggr+10,0,0,0,0/),& call psb_errpush(info,name,i_err=(/naggr+10,0,0,0,0/),&
@ -254,57 +336,55 @@ subroutine mld_caggrmap_bld(aggr_type,a,desc_a,nlaggr,ilaggr,info)
if (ilaggr(i) < 0) then if (ilaggr(i) < 0) then
! !
! Now some silly rule to break ties: ! Now some silly rule to break ties:
! Group with smallest adjacent aggregate. ! Group with adjacent aggregate.
! !
isz = nr+1 isz = nr+1
ia = -1 ia = -1
cpling = 0.0
call psb_neigh(apnt,i,neigh,n_ne,info,lev=1) call psb_sp_getrow(i,a,nz,irow,icol,val,info)
if (info/=0) then if (info/=0) then
info=4010 info=4010
call psb_errpush(info,name,a_err='psb_neigh') call psb_errpush(info,name,a_err='psb_sp_getrow')
goto 9999 goto 9999
end if end if
do j=1, n_ne do j=1, nz
k = neigh(j) k = icol(j)
if ((1<=k).and.(k<=nr)) then if ((1<=k).and.(k<=nr).and.(k/=i)) then
n = ilaggr(k) tcl = abs(val(j)) / sqrt(abs(diag(i)*diag(k)))
if (n>0) then if (abs(val(j)) > theta*sqrt(abs(diag(i)*diag(k)))) then
if (n>naggr) then !!$ if (tcl > theta) then
info=4001 n = ilaggr(k)
call psb_errpush(info,name,a_err='loc_Aggregate: n > naggr 2 ?') if (n>0) then
goto 9999 if (n>naggr) then
end if info=4001
call psb_errpush(info,name,a_err='loc_Aggregate: n > naggr 2 ?')
if (ils(n) < isz) then goto 9999
ia = n end if
isz = ils(n)
if ((abs(val(j))>cpling) .or. &
& ((abs(val(j)) == cpling).and. (ils(n) < isz))) then
!!$ if ((tcl > cpling) .or. ((tcl == cpling).and. (ils(n) < isz))) then
ia = n
isz = ils(n)
cpling = abs(val(j))
!!$ cpling = tcl
endif
endif endif
endif endif
endif end if
enddo enddo
if (ia == -1) then if (ia == -1) then
if (ilaggr(i) > -(nr+1)) then ! At this point, the easiest thing is to start a new aggregate
ilaggr(i) = abs(ilaggr(i)) naggr = naggr + 1
if (ilaggr(I)>naggr) then ilaggr(i) = naggr
info=4001 ils(ilaggr(i)) = 1
call psb_errpush(info,name,a_err='loc_Aggregate: n > naggr 3 ?')
goto 9999
end if
ils(ilaggr(i)) = ils(ilaggr(i)) + 1
!
! This might happen if the pattern is non symmetric.
! Need a better handling.
!
recovery = .true.
else
info=4001
call psb_errpush(info,name,a_err='Unrecoverable error !!')
goto 9999
endif
else else
ilaggr(i) = ia ilaggr(i) = ia
if (ia>naggr) then if (ia>naggr) then
info=4001 info=4001
call psb_errpush(info,name,a_err='loc_Aggregate: n > naggr 4? ') call psb_errpush(info,name,a_err='loc_Aggregate: n > naggr 4? ')
@ -312,8 +392,9 @@ subroutine mld_caggrmap_bld(aggr_type,a,desc_a,nlaggr,ilaggr,info)
end if end if
ils(ia) = ils(ia) + 1 ils(ia) = ils(ia) + 1
endif endif
end if end if
enddo end do
if (debug_level >= psb_debug_outer_) then if (debug_level >= psb_debug_outer_) then
if (recovery) then if (recovery) then
write(debug_unit,*) me,' ',trim(name),& write(debug_unit,*) me,' ',trim(name),&
@ -345,6 +426,12 @@ subroutine mld_caggrmap_bld(aggr_type,a,desc_a,nlaggr,ilaggr,info)
call psb_errpush(info,name) call psb_errpush(info,name)
goto 9999 goto 9999
end if end if
if (naggr > ncol) then
write(0,*) name,'Error : naggr > ncol',naggr,ncol
info=4001
call psb_errpush(info,name,a_err='Fatal error: naggr>ncol')
goto 9999
end if
call psb_realloc(ncol,ilaggr,info) call psb_realloc(ncol,ilaggr,info)
if (info/=0) then if (info/=0) then
@ -366,26 +453,17 @@ subroutine mld_caggrmap_bld(aggr_type,a,desc_a,nlaggr,ilaggr,info)
nlaggr(me+1) = naggr nlaggr(me+1) = naggr
call psb_sum(ictxt,nlaggr(1:np)) call psb_sum(ictxt,nlaggr(1:np))
if (aggr_type == mld_sym_dec_aggr_) then call psb_erractionrestore(err_act)
call psb_sp_free(atmp,info) return
end if
case default
info = -1
call psb_errpush(30,name,i_err=(/1,aggr_type,0,0,0/))
goto 9999
end select
call psb_erractionrestore(err_act)
return
9999 continue 9999 continue
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
if (err_act.eq.psb_act_abort_) then if (err_act.eq.psb_act_abort_) then
call psb_error() call psb_error()
return
end if
return return
end if
return end subroutine mld_dec_map_bld
end subroutine mld_caggrmap_bld end subroutine mld_caggrmap_bld

4
mlprec/mld_cmlprec_bld.f90
Unescape Escape View File

@ -109,6 +109,7 @@ subroutine mld_cmlprec_bld(a,desc_a,p,info)
call mld_check_def(p%rprcparm(mld_fact_thrs_),'Eps',szero,is_legal_s_fact_thrs) call mld_check_def(p%rprcparm(mld_fact_thrs_),'Eps',szero,is_legal_s_fact_thrs)
end select end select
call mld_check_def(p%rprcparm(mld_aggr_damp_),'Omega',szero,is_legal_s_omega) call mld_check_def(p%rprcparm(mld_aggr_damp_),'Omega',szero,is_legal_s_omega)
call mld_check_def(p%rprcparm(mld_aggr_thresh_),'Aggr_Thresh',szero,is_legal_s_aggr_thrs)
call mld_check_def(p%iprcparm(mld_smooth_sweeps_),'Jacobi sweeps',& call mld_check_def(p%iprcparm(mld_smooth_sweeps_),'Jacobi sweeps',&
& 1,is_legal_jac_sweeps) & 1,is_legal_jac_sweeps)
@ -118,7 +119,8 @@ subroutine mld_cmlprec_bld(a,desc_a,p,info)
! aggregation algorithm. This also defines a tentative prolongator from ! aggregation algorithm. This also defines a tentative prolongator from
! the coarse to the fine level. ! the coarse to the fine level.
! !
call mld_aggrmap_bld(p%iprcparm(mld_aggr_alg_),a,desc_a,p%nlaggr,p%mlia,info) call mld_aggrmap_bld(p%iprcparm(mld_aggr_alg_),p%rprcparm(mld_aggr_thresh_),&
& a,desc_a,p%nlaggr,p%mlia,info)
if(info /= 0) then if(info /= 0) then
call psb_errpush(4010,name,a_err='mld_aggrmap_bld') call psb_errpush(4010,name,a_err='mld_aggrmap_bld')
goto 9999 goto 9999

9
mlprec/mld_cprecinit.f90
Unescape Escape View File

@ -189,7 +189,8 @@ subroutine mld_cprecinit(p,ptype,info,nlev)
if (info == 0) call psb_realloc(mld_ifpsz_,p%baseprecv(ilev_)%iprcparm,info) if (info == 0) call psb_realloc(mld_ifpsz_,p%baseprecv(ilev_)%iprcparm,info)
if (info == 0) call psb_realloc(mld_rfpsz_,p%baseprecv(ilev_)%rprcparm,info) if (info == 0) call psb_realloc(mld_rfpsz_,p%baseprecv(ilev_)%rprcparm,info)
if (info /= 0) return if (info /= 0) return
p%baseprecv(ilev_)%iprcparm(:) = 0 p%baseprecv(ilev_)%iprcparm(:) = 0
p%baseprecv(ilev_)%rprcparm(:) = szero
p%baseprecv(ilev_)%iprcparm(mld_prec_type_) = mld_as_ p%baseprecv(ilev_)%iprcparm(mld_prec_type_) = mld_as_
p%baseprecv(ilev_)%iprcparm(mld_sub_solve_) = mld_ilu_n_ p%baseprecv(ilev_)%iprcparm(mld_sub_solve_) = mld_ilu_n_
p%baseprecv(ilev_)%iprcparm(mld_sub_restr_) = psb_halo_ p%baseprecv(ilev_)%iprcparm(mld_sub_restr_) = psb_halo_
@ -204,7 +205,8 @@ subroutine mld_cprecinit(p,ptype,info,nlev)
if (info == 0) call psb_realloc(mld_ifpsz_,p%baseprecv(ilev_)%iprcparm,info) if (info == 0) call psb_realloc(mld_ifpsz_,p%baseprecv(ilev_)%iprcparm,info)
if (info == 0) call psb_realloc(mld_rfpsz_,p%baseprecv(ilev_)%rprcparm,info) if (info == 0) call psb_realloc(mld_rfpsz_,p%baseprecv(ilev_)%rprcparm,info)
if (info /= 0) return if (info /= 0) return
p%baseprecv(ilev_)%iprcparm(:) = 0 p%baseprecv(ilev_)%iprcparm(:) = 0
p%baseprecv(ilev_)%rprcparm(:) = szero
p%baseprecv(ilev_)%iprcparm(mld_prec_type_) = mld_bjac_ p%baseprecv(ilev_)%iprcparm(mld_prec_type_) = mld_bjac_
p%baseprecv(ilev_)%iprcparm(mld_sub_restr_) = psb_none_ p%baseprecv(ilev_)%iprcparm(mld_sub_restr_) = psb_none_
p%baseprecv(ilev_)%iprcparm(mld_sub_prol_) = psb_none_ p%baseprecv(ilev_)%iprcparm(mld_sub_prol_) = psb_none_
@ -225,7 +227,8 @@ subroutine mld_cprecinit(p,ptype,info,nlev)
if (info == 0) call psb_realloc(mld_ifpsz_,p%baseprecv(ilev_)%iprcparm,info) if (info == 0) call psb_realloc(mld_ifpsz_,p%baseprecv(ilev_)%iprcparm,info)
if (info == 0) call psb_realloc(mld_rfpsz_,p%baseprecv(ilev_)%rprcparm,info) if (info == 0) call psb_realloc(mld_rfpsz_,p%baseprecv(ilev_)%rprcparm,info)
if (info /= 0) return if (info /= 0) return
p%baseprecv(ilev_)%iprcparm(:) = 0 p%baseprecv(ilev_)%iprcparm(:) = 0
p%baseprecv(ilev_)%rprcparm(:) = szero
p%baseprecv(ilev_)%iprcparm(mld_prec_type_) = mld_bjac_ p%baseprecv(ilev_)%iprcparm(mld_prec_type_) = mld_bjac_
p%baseprecv(ilev_)%iprcparm(mld_sub_restr_) = psb_none_ p%baseprecv(ilev_)%iprcparm(mld_sub_restr_) = psb_none_
p%baseprecv(ilev_)%iprcparm(mld_sub_prol_) = psb_none_ p%baseprecv(ilev_)%iprcparm(mld_sub_prol_) = psb_none_

15
mlprec/mld_cprecset.f90
Unescape Escape View File

@ -595,7 +595,7 @@ subroutine mld_cprecsetr(p,what,val,info,ilev)
else if (ilev_ > 1) then else if (ilev_ > 1) then
select case(what) select case(what)
case(mld_aggr_damp_,mld_fact_thrs_) case(mld_aggr_damp_,mld_aggr_thresh_,mld_fact_thrs_)
p%baseprecv(ilev_)%rprcparm(what) = val p%baseprecv(ilev_)%rprcparm(what) = val
case default case default
write(0,*) name,': Error: invalid WHAT' write(0,*) name,': Error: invalid WHAT'
@ -610,7 +610,7 @@ subroutine mld_cprecsetr(p,what,val,info,ilev)
select case(what) select case(what)
case(mld_fact_thrs_) case(mld_fact_thrs_)
do ilev_=1,nlev_-1 do ilev_=1,nlev_
if (.not.allocated(p%baseprecv(ilev_)%rprcparm)) then if (.not.allocated(p%baseprecv(ilev_)%rprcparm)) then
write(0,*) name,': Error: Uninitialized preconditioner component, should call MLD_PRECINIT' write(0,*) name,': Error: Uninitialized preconditioner component, should call MLD_PRECINIT'
info = -1 info = -1
@ -619,7 +619,16 @@ subroutine mld_cprecsetr(p,what,val,info,ilev)
p%baseprecv(ilev_)%rprcparm(what) = val p%baseprecv(ilev_)%rprcparm(what) = val
end do end do
case(mld_aggr_damp_) case(mld_aggr_damp_)
do ilev_=2,nlev_-1 do ilev_=2,nlev_
if (.not.allocated(p%baseprecv(ilev_)%rprcparm)) then
write(0,*) name,': Error: Uninitialized preconditioner component, should call MLD_PRECINIT'
info = -1
return
endif
p%baseprecv(ilev_)%rprcparm(what) = val
end do
case(mld_aggr_thresh_)
do ilev_=2,nlev_
if (.not.allocated(p%baseprecv(ilev_)%rprcparm)) then if (.not.allocated(p%baseprecv(ilev_)%rprcparm)) then
write(0,*) name,': Error: Uninitialized preconditioner component, should call MLD_PRECINIT' write(0,*) name,': Error: Uninitialized preconditioner component, should call MLD_PRECINIT'
info = -1 info = -1

275
mlprec/mld_daggrmap_bld.f90
Unescape Escape View File

@ -74,16 +74,17 @@
! info - integer, output. ! info - integer, output.
! Error code. ! Error code.
! !
subroutine mld_daggrmap_bld(aggr_type,a,desc_a,nlaggr,ilaggr,info) subroutine mld_daggrmap_bld(aggr_type,theta,a,desc_a,nlaggr,ilaggr,info)
use psb_base_mod use psb_base_mod
use mld_inner_mod, mld_protect_name => mld_daggrmap_bld use mld_inner_mod, mld_protect_name => mld_daggrmap_bld
implicit none implicit none
! Arguments ! Arguments
integer, intent(in) :: aggr_type integer, intent(in) :: aggr_type
type(psb_dspmat_type), intent(in), target :: a real(psb_dpk_), intent(in) :: theta
type(psb_dspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_a type(psb_desc_type), intent(in) :: desc_a
integer, allocatable, intent(out) :: ilaggr(:),nlaggr(:) integer, allocatable, intent(out) :: ilaggr(:),nlaggr(:)
integer, intent(out) :: info integer, intent(out) :: info
@ -91,8 +92,7 @@ subroutine mld_daggrmap_bld(aggr_type,a,desc_a,nlaggr,ilaggr,info)
! Local variables ! Local variables
integer, allocatable :: ils(:), neigh(:) integer, allocatable :: ils(:), neigh(:)
integer :: icnt,nlp,k,n,ia,isz,nr, naggr,i,j,m integer :: icnt,nlp,k,n,ia,isz,nr, naggr,i,j,m
type(psb_dspmat_type), target :: atmp, atrans type(psb_dspmat_type) :: atmp, atrans
type(psb_dspmat_type), pointer :: apnt
logical :: recovery logical :: recovery
integer :: debug_level, debug_unit integer :: debug_level, debug_unit
integer :: ictxt,np,me,err_act integer :: ictxt,np,me,err_act
@ -116,8 +116,93 @@ subroutine mld_daggrmap_bld(aggr_type,a,desc_a,nlaggr,ilaggr,info)
ncol = psb_cd_get_local_cols(desc_a) ncol = psb_cd_get_local_cols(desc_a)
select case (aggr_type) select case (aggr_type)
case (mld_dec_aggr_,mld_sym_dec_aggr_) case (mld_dec_aggr_)
call mld_dec_map_bld(theta,a,desc_a,nlaggr,ilaggr,info)
case (mld_sym_dec_aggr_)
nr = psb_sp_get_nrows(a)
call psb_sp_clip(a,atmp,info,imax=nr,jmax=nr,&
& rscale=.false.,cscale=.false.)
atmp%m=nr
atmp%k=nr
if (info == 0) call psb_transp(atmp,atrans,fmt='COO')
if (info == 0) call psb_rwextd(nr,atmp,info,b=atrans,rowscale=.false.)
atmp%m=nr
atmp%k=nr
if (info == 0) call psb_sp_free(atrans,info)
if (info == 0) call psb_ipcoo2csr(atmp,info)
if (info == 0) call mld_dec_map_bld(theta,atmp,desc_a,nlaggr,ilaggr,info)
if (info == 0) call psb_sp_free(atmp,info)
case default
info = -1
call psb_errpush(30,name,i_err=(/1,aggr_type,0,0,0/))
goto 9999
end select
if (info/=0) then
info=4001
call psb_errpush(info,name,a_err='dec_map_bld')
goto 9999
end if
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act.eq.psb_act_abort_) then
call psb_error()
return
end if
return
contains
subroutine mld_dec_map_bld(theta,a,desc_a,nlaggr,ilaggr,info)
use psb_base_mod
use mld_inner_mod !, mld_protect_name => mld_daggrmap_bld
implicit none
! Arguments
type(psb_dspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_a
real(psb_dpk_), intent(in) :: theta
integer, allocatable, intent(out) :: ilaggr(:),nlaggr(:)
integer, intent(out) :: info
! Local variables
integer, allocatable :: ils(:), neigh(:), irow(:), icol(:)
real(psb_dpk_), allocatable :: val(:), diag(:)
integer :: icnt,nlp,k,n,ia,isz,nr, naggr,i,j,m, nz
real(psb_dpk_) :: cpling, tcl
logical :: recovery
integer :: debug_level, debug_unit
integer :: ictxt,np,me,err_act
integer :: nrow, ncol, n_ne
character(len=20) :: name, ch_err
if(psb_get_errstatus() /= 0) return
info=0
name = 'mld_dec_map_bld'
call psb_erractionsave(err_act)
debug_unit = psb_get_debug_unit()
debug_level = psb_get_debug_level()
!
! Note. At the time being we are ignoring aggr_type so
! that we only have decoupled aggregation. This might
! change in the future.
!
ictxt=psb_cd_get_context(desc_a)
call psb_info(ictxt,me,np)
nrow = psb_cd_get_local_rows(desc_a)
ncol = psb_cd_get_local_cols(desc_a)
nr = a%m nr = a%m
allocate(ilaggr(nr),neigh(nr),stat=info) allocate(ilaggr(nr),neigh(nr),stat=info)
if(info /= 0) then if(info /= 0) then
@ -127,36 +212,28 @@ subroutine mld_daggrmap_bld(aggr_type,a,desc_a,nlaggr,ilaggr,info)
goto 9999 goto 9999
end if end if
allocate(diag(nr),stat=info)
if(info /= 0) then
info=4025
call psb_errpush(info,name,i_err=(/nr,0,0,0,0/),&
& a_err='real(psb_dpk_)')
goto 9999
end if
call psb_sp_getdiag(a,diag,info)
if(info /= 0) then
info=4010
call psb_errpush(info,name,a_err='psb_sp_getdiag')
goto 9999
end if
do i=1, nr do i=1, nr
ilaggr(i) = -(nr+1) ilaggr(i) = -(nr+1)
end do end do
if (aggr_type == mld_dec_aggr_) then
apnt => a
else
call psb_sp_clip(a,atmp,info,imax=nr,jmax=nr,&
& rscale=.false.,cscale=.false.)
atmp%m=nr
atmp%k=nr
if (info == 0) call psb_transp(atmp,atrans,fmt='COO')
if (info == 0) call psb_rwextd(nr,atmp,info,b=atrans,rowscale=.false.)
atmp%m=nr
atmp%k=nr
if (info == 0) call psb_sp_free(atrans,info)
if (info == 0) call psb_ipcoo2csr(atmp,info)
apnt => atmp
if (info/=0) then
info=4001
call psb_errpush(info,name,a_err='init apnt')
goto 9999
end if
end if
! Note: -(nr+1) Untouched as yet ! Note: -(nr+1) Untouched as yet
! -i 1<=i<=nr Adjacent to aggregate i ! -i 1<=i<=nr Adjacent to aggregate i
! i 1<=i<=nr Belonging to aggregate i ! i 1<=i<=nr Belonging to aggregate i
! !
! Phase one: group nodes together. ! Phase one: group nodes together.
! Very simple minded strategy. ! Very simple minded strategy.
@ -171,26 +248,32 @@ subroutine mld_daggrmap_bld(aggr_type,a,desc_a,nlaggr,ilaggr,info)
! 1. Untouched nodes are marked >0 together ! 1. Untouched nodes are marked >0 together
! with their neighbours ! with their neighbours
! !
icnt = icnt + 1 icnt = icnt + 1
naggr = naggr + 1 naggr = naggr + 1
ilaggr(i) = naggr ilaggr(i) = naggr
call psb_neigh(apnt,i,neigh,n_ne,info,lev=1) call psb_sp_getrow(i,a,nz,irow,icol,val,info)
if (info/=0) then if (info/=0) then
info=4010 info=4010
call psb_errpush(info,name,a_err='psb_neigh') call psb_errpush(info,name,a_err='psb_sp_getrow')
goto 9999 goto 9999
end if end if
do k=1, n_ne
j = neigh(k) do k=1, nz
if ((1<=j).and.(j<=nr)) then j = icol(k)
ilaggr(j) = naggr if ((1<=j).and.(j<=nr).and.(i/=j)) then
endif if (abs(val(k)) > theta*sqrt(abs(diag(i)*diag(j)))) then
ilaggr(j) = naggr
else
ilaggr(j) = -naggr
endif
end if
enddo enddo
! !
! 2. Untouched neighbours of these nodes are marked <0. ! 2. Untouched neighbours of these nodes are marked <0.
! !
call psb_neigh(apnt,i,neigh,n_ne,info,lev=2) call psb_neigh(a,i,neigh,n_ne,info,lev=2)
if (info/=0) then if (info/=0) then
info=4010 info=4010
call psb_errpush(info,name,a_err='psb_neigh') call psb_errpush(info,name,a_err='psb_neigh')
@ -217,7 +300,7 @@ subroutine mld_daggrmap_bld(aggr_type,a,desc_a,nlaggr,ilaggr,info)
! !
! Phase two: sweep over leftovers. ! Phase two: sweep over leftovers.
! !
allocate(ils(naggr+10),stat=info) allocate(ils(nr),stat=info)
if(info /= 0) then if(info /= 0) then
info=4025 info=4025
call psb_errpush(info,name,i_err=(/naggr+10,0,0,0,0/),& call psb_errpush(info,name,i_err=(/naggr+10,0,0,0,0/),&
@ -253,57 +336,55 @@ subroutine mld_daggrmap_bld(aggr_type,a,desc_a,nlaggr,ilaggr,info)
if (ilaggr(i) < 0) then if (ilaggr(i) < 0) then
! !
! Now some silly rule to break ties: ! Now some silly rule to break ties:
! Group with smallest adjacent aggregate. ! Group with adjacent aggregate.
! !
isz = nr+1 isz = nr+1
ia = -1 ia = -1
cpling = 0.0d0
call psb_neigh(apnt,i,neigh,n_ne,info,lev=1) call psb_sp_getrow(i,a,nz,irow,icol,val,info)
if (info/=0) then if (info/=0) then
info=4010 info=4010
call psb_errpush(info,name,a_err='psb_neigh') call psb_errpush(info,name,a_err='psb_sp_getrow')
goto 9999 goto 9999
end if end if
do j=1, n_ne do j=1, nz
k = neigh(j) k = icol(j)
if ((1<=k).and.(k<=nr)) then if ((1<=k).and.(k<=nr).and.(k/=i)) then
n = ilaggr(k) tcl = abs(val(j)) / sqrt(abs(diag(i)*diag(k)))
if (n>0) then if (abs(val(j)) > theta*sqrt(abs(diag(i)*diag(k)))) then
if (n>naggr) then !!$ if (tcl > theta) then
info=4001 n = ilaggr(k)
call psb_errpush(info,name,a_err='loc_Aggregate: n > naggr 2 ?') if (n>0) then
goto 9999 if (n>naggr) then
end if info=4001
call psb_errpush(info,name,a_err='loc_Aggregate: n > naggr 2 ?')
if (ils(n) < isz) then goto 9999
ia = n end if
isz = ils(n)
if ((abs(val(j))>cpling) .or. &
& ((abs(val(j)) == cpling).and. (ils(n) < isz))) then
!!$ if ((tcl > cpling) .or. ((tcl == cpling).and. (ils(n) < isz))) then
ia = n
isz = ils(n)
cpling = abs(val(j))
!!$ cpling = tcl
endif
endif endif
endif endif
endif end if
enddo enddo
if (ia == -1) then if (ia == -1) then
if (ilaggr(i) > -(nr+1)) then ! At this point, the easiest thing is to start a new aggregate
ilaggr(i) = abs(ilaggr(i)) naggr = naggr + 1
if (ilaggr(I)>naggr) then ilaggr(i) = naggr
info=4001 ils(ilaggr(i)) = 1
call psb_errpush(info,name,a_err='loc_Aggregate: n > naggr 3 ?')
goto 9999
end if
ils(ilaggr(i)) = ils(ilaggr(i)) + 1
!
! This might happen if the pattern is non symmetric.
! Need a better handling.
!
recovery = .true.
else
info=4001
call psb_errpush(info,name,a_err='Unrecoverable error !!')
goto 9999
endif
else else
ilaggr(i) = ia ilaggr(i) = ia
if (ia>naggr) then if (ia>naggr) then
info=4001 info=4001
call psb_errpush(info,name,a_err='loc_Aggregate: n > naggr 4? ') call psb_errpush(info,name,a_err='loc_Aggregate: n > naggr 4? ')
@ -311,8 +392,9 @@ subroutine mld_daggrmap_bld(aggr_type,a,desc_a,nlaggr,ilaggr,info)
end if end if
ils(ia) = ils(ia) + 1 ils(ia) = ils(ia) + 1
endif endif
end if end if
enddo end do
if (debug_level >= psb_debug_outer_) then if (debug_level >= psb_debug_outer_) then
if (recovery) then if (recovery) then
write(debug_unit,*) me,' ',trim(name),& write(debug_unit,*) me,' ',trim(name),&
@ -344,6 +426,12 @@ subroutine mld_daggrmap_bld(aggr_type,a,desc_a,nlaggr,ilaggr,info)
call psb_errpush(info,name) call psb_errpush(info,name)
goto 9999 goto 9999
end if end if
if (naggr > ncol) then
write(0,*) name,'Error : naggr > ncol',naggr,ncol
info=4001
call psb_errpush(info,name,a_err='Fatal error: naggr>ncol')
goto 9999
end if
call psb_realloc(ncol,ilaggr,info) call psb_realloc(ncol,ilaggr,info)
if (info/=0) then if (info/=0) then
@ -365,26 +453,17 @@ subroutine mld_daggrmap_bld(aggr_type,a,desc_a,nlaggr,ilaggr,info)
nlaggr(me+1) = naggr nlaggr(me+1) = naggr
call psb_sum(ictxt,nlaggr(1:np)) call psb_sum(ictxt,nlaggr(1:np))
if (aggr_type == mld_sym_dec_aggr_) then call psb_erractionrestore(err_act)
call psb_sp_free(atmp,info) return
end if
case default
info = -1
call psb_errpush(30,name,i_err=(/1,aggr_type,0,0,0/))
goto 9999
end select
call psb_erractionrestore(err_act)
return
9999 continue 9999 continue
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
if (err_act.eq.psb_act_abort_) then if (err_act.eq.psb_act_abort_) then
call psb_error() call psb_error()
return
end if
return return
end if
return end subroutine mld_dec_map_bld
end subroutine mld_daggrmap_bld end subroutine mld_daggrmap_bld

4
mlprec/mld_dmlprec_bld.f90
Unescape Escape View File

@ -109,6 +109,7 @@ subroutine mld_dmlprec_bld(a,desc_a,p,info)
call mld_check_def(p%rprcparm(mld_fact_thrs_),'Eps',dzero,is_legal_fact_thrs) call mld_check_def(p%rprcparm(mld_fact_thrs_),'Eps',dzero,is_legal_fact_thrs)
end select end select
call mld_check_def(p%rprcparm(mld_aggr_damp_),'Omega',dzero,is_legal_omega) call mld_check_def(p%rprcparm(mld_aggr_damp_),'Omega',dzero,is_legal_omega)
call mld_check_def(p%rprcparm(mld_aggr_thresh_),'Aggr_Thresh',dzero,is_legal_aggr_thrs)
call mld_check_def(p%iprcparm(mld_smooth_sweeps_),'Jacobi sweeps',& call mld_check_def(p%iprcparm(mld_smooth_sweeps_),'Jacobi sweeps',&
& 1,is_legal_jac_sweeps) & 1,is_legal_jac_sweeps)
@ -118,7 +119,8 @@ subroutine mld_dmlprec_bld(a,desc_a,p,info)
! aggregation algorithm. This also defines a tentative prolongator from ! aggregation algorithm. This also defines a tentative prolongator from
! the coarse to the fine level. ! the coarse to the fine level.
! !
call mld_aggrmap_bld(p%iprcparm(mld_aggr_alg_),a,desc_a,p%nlaggr,p%mlia,info) call mld_aggrmap_bld(p%iprcparm(mld_aggr_alg_),p%rprcparm(mld_aggr_thresh_),&
& a,desc_a,p%nlaggr,p%mlia,info)
if(info /= 0) then if(info /= 0) then
call psb_errpush(4010,name,a_err='mld_aggrmap_bld') call psb_errpush(4010,name,a_err='mld_aggrmap_bld')
goto 9999 goto 9999

9
mlprec/mld_dprecinit.f90
Unescape Escape View File

@ -189,7 +189,8 @@ subroutine mld_dprecinit(p,ptype,info,nlev)
if (info == 0) call psb_realloc(mld_ifpsz_,p%baseprecv(ilev_)%iprcparm,info) if (info == 0) call psb_realloc(mld_ifpsz_,p%baseprecv(ilev_)%iprcparm,info)
if (info == 0) call psb_realloc(mld_rfpsz_,p%baseprecv(ilev_)%rprcparm,info) if (info == 0) call psb_realloc(mld_rfpsz_,p%baseprecv(ilev_)%rprcparm,info)
if (info /= 0) return if (info /= 0) return
p%baseprecv(ilev_)%iprcparm(:) = 0 p%baseprecv(ilev_)%iprcparm(:) = 0
p%baseprecv(ilev_)%rprcparm(:) = dzero
p%baseprecv(ilev_)%iprcparm(mld_prec_type_) = mld_as_ p%baseprecv(ilev_)%iprcparm(mld_prec_type_) = mld_as_
p%baseprecv(ilev_)%iprcparm(mld_sub_solve_) = mld_ilu_n_ p%baseprecv(ilev_)%iprcparm(mld_sub_solve_) = mld_ilu_n_
p%baseprecv(ilev_)%iprcparm(mld_sub_restr_) = psb_halo_ p%baseprecv(ilev_)%iprcparm(mld_sub_restr_) = psb_halo_
@ -204,7 +205,8 @@ subroutine mld_dprecinit(p,ptype,info,nlev)
if (info == 0) call psb_realloc(mld_ifpsz_,p%baseprecv(ilev_)%iprcparm,info) if (info == 0) call psb_realloc(mld_ifpsz_,p%baseprecv(ilev_)%iprcparm,info)
if (info == 0) call psb_realloc(mld_rfpsz_,p%baseprecv(ilev_)%rprcparm,info) if (info == 0) call psb_realloc(mld_rfpsz_,p%baseprecv(ilev_)%rprcparm,info)
if (info /= 0) return if (info /= 0) return
p%baseprecv(ilev_)%iprcparm(:) = 0 p%baseprecv(ilev_)%iprcparm(:) = 0
p%baseprecv(ilev_)%rprcparm(:) = dzero
p%baseprecv(ilev_)%iprcparm(mld_prec_type_) = mld_bjac_ p%baseprecv(ilev_)%iprcparm(mld_prec_type_) = mld_bjac_
p%baseprecv(ilev_)%iprcparm(mld_sub_restr_) = psb_none_ p%baseprecv(ilev_)%iprcparm(mld_sub_restr_) = psb_none_
p%baseprecv(ilev_)%iprcparm(mld_sub_prol_) = psb_none_ p%baseprecv(ilev_)%iprcparm(mld_sub_prol_) = psb_none_
@ -225,7 +227,8 @@ subroutine mld_dprecinit(p,ptype,info,nlev)
if (info == 0) call psb_realloc(mld_ifpsz_,p%baseprecv(ilev_)%iprcparm,info) if (info == 0) call psb_realloc(mld_ifpsz_,p%baseprecv(ilev_)%iprcparm,info)
if (info == 0) call psb_realloc(mld_rfpsz_,p%baseprecv(ilev_)%rprcparm,info) if (info == 0) call psb_realloc(mld_rfpsz_,p%baseprecv(ilev_)%rprcparm,info)
if (info /= 0) return if (info /= 0) return
p%baseprecv(ilev_)%iprcparm(:) = 0 p%baseprecv(ilev_)%iprcparm(:) = 0
p%baseprecv(ilev_)%rprcparm(:) = dzero
p%baseprecv(ilev_)%iprcparm(mld_prec_type_) = mld_bjac_ p%baseprecv(ilev_)%iprcparm(mld_prec_type_) = mld_bjac_
p%baseprecv(ilev_)%iprcparm(mld_sub_restr_) = psb_none_ p%baseprecv(ilev_)%iprcparm(mld_sub_restr_) = psb_none_
p%baseprecv(ilev_)%iprcparm(mld_sub_prol_) = psb_none_ p%baseprecv(ilev_)%iprcparm(mld_sub_prol_) = psb_none_

15
mlprec/mld_dprecset.f90
Unescape Escape View File

@ -595,7 +595,7 @@ subroutine mld_dprecsetr(p,what,val,info,ilev)
else if (ilev_ > 1) then else if (ilev_ > 1) then
select case(what) select case(what)
case(mld_aggr_damp_,mld_fact_thrs_) case(mld_aggr_damp_,mld_aggr_thresh_,mld_fact_thrs_)
p%baseprecv(ilev_)%rprcparm(what) = val p%baseprecv(ilev_)%rprcparm(what) = val
case default case default
write(0,*) name,': Error: invalid WHAT' write(0,*) name,': Error: invalid WHAT'
@ -610,7 +610,7 @@ subroutine mld_dprecsetr(p,what,val,info,ilev)
select case(what) select case(what)
case(mld_fact_thrs_) case(mld_fact_thrs_)
do ilev_=1,nlev_-1 do ilev_=1,nlev_
if (.not.allocated(p%baseprecv(ilev_)%rprcparm)) then if (.not.allocated(p%baseprecv(ilev_)%rprcparm)) then
write(0,*) name,': Error: Uninitialized preconditioner component, should call MLD_PRECINIT' write(0,*) name,': Error: Uninitialized preconditioner component, should call MLD_PRECINIT'
info = -1 info = -1
@ -619,7 +619,16 @@ subroutine mld_dprecsetr(p,what,val,info,ilev)
p%baseprecv(ilev_)%rprcparm(what) = val p%baseprecv(ilev_)%rprcparm(what) = val
end do end do
case(mld_aggr_damp_) case(mld_aggr_damp_)
do ilev_=2,nlev_-1 do ilev_=2,nlev_
if (.not.allocated(p%baseprecv(ilev_)%rprcparm)) then
write(0,*) name,': Error: Uninitialized preconditioner component, should call MLD_PRECINIT'
info = -1
return
endif
p%baseprecv(ilev_)%rprcparm(what) = val
end do
case(mld_aggr_thresh_)
do ilev_=2,nlev_
if (.not.allocated(p%baseprecv(ilev_)%rprcparm)) then if (.not.allocated(p%baseprecv(ilev_)%rprcparm)) then
write(0,*) name,': Error: Uninitialized preconditioner component, should call MLD_PRECINIT' write(0,*) name,': Error: Uninitialized preconditioner component, should call MLD_PRECINIT'
info = -1 info = -1

20
mlprec/mld_inner_mod.f90
Unescape Escape View File

@ -384,38 +384,42 @@ module mld_inner_mod
end interface end interface
interface mld_aggrmap_bld interface mld_aggrmap_bld
subroutine mld_saggrmap_bld(aggr_type,a,desc_a,nlaggr,ilaggr,info) subroutine mld_saggrmap_bld(aggr_type,theta,a,desc_a,nlaggr,ilaggr,info)
use psb_base_mod, only : psb_sspmat_type, psb_desc_type, psb_spk_ use psb_base_mod, only : psb_sspmat_type, psb_desc_type, psb_spk_
use mld_prec_type, only : mld_sbaseprc_type use mld_prec_type, only : mld_sbaseprc_type
integer, intent(in) :: aggr_type integer, intent(in) :: aggr_type
type(psb_sspmat_type), intent(in), target :: a real(psb_spk_), intent(in) :: theta
type(psb_sspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_a type(psb_desc_type), intent(in) :: desc_a
integer, allocatable, intent(out) :: ilaggr(:),nlaggr(:) integer, allocatable, intent(out) :: ilaggr(:),nlaggr(:)
integer, intent(out) :: info integer, intent(out) :: info
end subroutine mld_saggrmap_bld end subroutine mld_saggrmap_bld
subroutine mld_daggrmap_bld(aggr_type,a,desc_a,nlaggr,ilaggr,info) subroutine mld_daggrmap_bld(aggr_type,theta,a,desc_a,nlaggr,ilaggr,info)
use psb_base_mod, only : psb_dspmat_type, psb_desc_type, psb_dpk_ use psb_base_mod, only : psb_dspmat_type, psb_desc_type, psb_dpk_
use mld_prec_type, only : mld_dbaseprc_type use mld_prec_type, only : mld_dbaseprc_type
integer, intent(in) :: aggr_type integer, intent(in) :: aggr_type
type(psb_dspmat_type), intent(in), target :: a real(psb_dpk_), intent(in) :: theta
type(psb_dspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_a type(psb_desc_type), intent(in) :: desc_a
integer, allocatable, intent(out) :: ilaggr(:),nlaggr(:) integer, allocatable, intent(out) :: ilaggr(:),nlaggr(:)
integer, intent(out) :: info integer, intent(out) :: info
end subroutine mld_daggrmap_bld end subroutine mld_daggrmap_bld
subroutine mld_caggrmap_bld(aggr_type,a,desc_a,nlaggr,ilaggr,info) subroutine mld_caggrmap_bld(aggr_type,theta,a,desc_a,nlaggr,ilaggr,info)
use psb_base_mod, only : psb_cspmat_type, psb_desc_type, psb_spk_ use psb_base_mod, only : psb_cspmat_type, psb_desc_type, psb_spk_
use mld_prec_type, only : mld_cbaseprc_type use mld_prec_type, only : mld_cbaseprc_type
integer, intent(in) :: aggr_type integer, intent(in) :: aggr_type
type(psb_cspmat_type), intent(in), target :: a real(psb_spk_), intent(in) :: theta
type(psb_cspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_a type(psb_desc_type), intent(in) :: desc_a
integer, allocatable, intent(out) :: ilaggr(:),nlaggr(:) integer, allocatable, intent(out) :: ilaggr(:),nlaggr(:)
integer, intent(out) :: info integer, intent(out) :: info
end subroutine mld_caggrmap_bld end subroutine mld_caggrmap_bld
subroutine mld_zaggrmap_bld(aggr_type,a,desc_a,nlaggr,ilaggr,info) subroutine mld_zaggrmap_bld(aggr_type,theta,a,desc_a,nlaggr,ilaggr,info)
use psb_base_mod, only : psb_zspmat_type, psb_desc_type, psb_dpk_ use psb_base_mod, only : psb_zspmat_type, psb_desc_type, psb_dpk_
use mld_prec_type, only : mld_zbaseprc_type use mld_prec_type, only : mld_zbaseprc_type
integer, intent(in) :: aggr_type integer, intent(in) :: aggr_type
type(psb_zspmat_type), intent(in), target :: a real(psb_dpk_), intent(in) :: theta
type(psb_zspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_a type(psb_desc_type), intent(in) :: desc_a
integer, allocatable, intent(out) :: ilaggr(:),nlaggr(:) integer, allocatable, intent(out) :: ilaggr(:),nlaggr(:)
integer, intent(out) :: info integer, intent(out) :: info

30
mlprec/mld_prec_type.f90
Unescape Escape View File

@ -66,7 +66,9 @@ module mld_prec_type
& psb_dspmat_type, psb_zspmat_type,& & psb_dspmat_type, psb_zspmat_type,&
& psb_sspmat_type, psb_cspmat_type,& & psb_sspmat_type, psb_cspmat_type,&
& psb_desc_type, psb_inter_desc_type, psb_sizeof, psb_dpk_, psb_spk_,& & psb_desc_type, psb_inter_desc_type, psb_sizeof, psb_dpk_, psb_spk_,&
& psb_sp_free, psb_cdfree & psb_sp_free, psb_cdfree, psb_halo_, psb_none_, &
& psb_nohalo_, psb_square_root_, &
& psb_sizeof_int, psb_sizeof_sp, psb_sizeof_dp, psb_sizeof
! !
! Type: mld_dprec_type, mld_zprec_type ! Type: mld_dprec_type, mld_zprec_type
@ -718,6 +720,8 @@ contains
& aggr_names(p%baseprecv(ilev)%iprcparm(mld_aggr_alg_)) & aggr_names(p%baseprecv(ilev)%iprcparm(mld_aggr_alg_))
write(iout,*) 'Aggregation smoothing: ', & write(iout,*) 'Aggregation smoothing: ', &
& aggr_kinds(p%baseprecv(ilev)%iprcparm(mld_aggr_kind_)) & aggr_kinds(p%baseprecv(ilev)%iprcparm(mld_aggr_kind_))
write(iout,*) 'Aggregation threshold: ', &
& p%baseprecv(ilev)%rprcparm(mld_aggr_thresh_)
if (p%baseprecv(ilev)%iprcparm(mld_aggr_kind_) /= mld_no_smooth_) then if (p%baseprecv(ilev)%iprcparm(mld_aggr_kind_) /= mld_no_smooth_) then
write(iout,*) 'Damping omega: ', & write(iout,*) 'Damping omega: ', &
& p%baseprecv(ilev)%rprcparm(mld_aggr_damp_) & p%baseprecv(ilev)%rprcparm(mld_aggr_damp_)
@ -822,6 +826,8 @@ contains
& aggr_names(p%baseprecv(ilev)%iprcparm(mld_aggr_alg_)) & aggr_names(p%baseprecv(ilev)%iprcparm(mld_aggr_alg_))
write(iout,*) 'Aggregation smoothing: ', & write(iout,*) 'Aggregation smoothing: ', &
& aggr_kinds(p%baseprecv(ilev)%iprcparm(mld_aggr_kind_)) & aggr_kinds(p%baseprecv(ilev)%iprcparm(mld_aggr_kind_))
write(iout,*) 'Aggregation threshold: ', &
& p%baseprecv(ilev)%rprcparm(mld_aggr_thresh_)
if (p%baseprecv(ilev)%iprcparm(mld_aggr_kind_) /= mld_no_smooth_) then if (p%baseprecv(ilev)%iprcparm(mld_aggr_kind_) /= mld_no_smooth_) then
write(iout,*) 'Damping omega: ', & write(iout,*) 'Damping omega: ', &
& p%baseprecv(ilev)%rprcparm(mld_aggr_damp_) & p%baseprecv(ilev)%rprcparm(mld_aggr_damp_)
@ -944,8 +950,10 @@ contains
if (p%baseprecv(ilev)%iprcparm(mld_ml_type_)>mld_no_ml_) then if (p%baseprecv(ilev)%iprcparm(mld_ml_type_)>mld_no_ml_) then
write(iout,*) 'Multilevel aggregation: ', & write(iout,*) 'Multilevel aggregation: ', &
& aggr_names(p%baseprecv(ilev)%iprcparm(mld_aggr_alg_)) & aggr_names(p%baseprecv(ilev)%iprcparm(mld_aggr_alg_))
write(iout,*) 'Smoother: ', & write(iout,*) 'Aggregation smoothing: ', &
& aggr_kinds(p%baseprecv(ilev)%iprcparm(mld_aggr_kind_)) & aggr_kinds(p%baseprecv(ilev)%iprcparm(mld_aggr_kind_))
write(iout,*) 'Aggregation threshold: ', &
& p%baseprecv(ilev)%rprcparm(mld_aggr_thresh_)
if (p%baseprecv(ilev)%iprcparm(mld_aggr_kind_) /= mld_no_smooth_) then if (p%baseprecv(ilev)%iprcparm(mld_aggr_kind_) /= mld_no_smooth_) then
write(iout,*) 'Smoothing omega: ', & write(iout,*) 'Smoothing omega: ', &
& p%baseprecv(ilev)%rprcparm(mld_aggr_damp_) & p%baseprecv(ilev)%rprcparm(mld_aggr_damp_)
@ -1047,8 +1055,10 @@ contains
if (p%baseprecv(ilev)%iprcparm(mld_ml_type_)>mld_no_ml_) then if (p%baseprecv(ilev)%iprcparm(mld_ml_type_)>mld_no_ml_) then
write(iout,*) 'Multilevel aggregation: ', & write(iout,*) 'Multilevel aggregation: ', &
& aggr_names(p%baseprecv(ilev)%iprcparm(mld_aggr_alg_)) & aggr_names(p%baseprecv(ilev)%iprcparm(mld_aggr_alg_))
write(iout,*) 'Smoother: ', & write(iout,*) 'Aggregation smoothing: ', &
& aggr_kinds(p%baseprecv(ilev)%iprcparm(mld_aggr_kind_)) & aggr_kinds(p%baseprecv(ilev)%iprcparm(mld_aggr_kind_))
write(iout,*) 'Aggregation threshold: ', &
& p%baseprecv(ilev)%rprcparm(mld_aggr_thresh_)
if (p%baseprecv(ilev)%iprcparm(mld_aggr_kind_) /= mld_no_smooth_) then if (p%baseprecv(ilev)%iprcparm(mld_aggr_kind_) /= mld_no_smooth_) then
write(iout,*) 'Smoothing omega: ', & write(iout,*) 'Smoothing omega: ', &
& p%baseprecv(ilev)%rprcparm(mld_aggr_damp_) & p%baseprecv(ilev)%rprcparm(mld_aggr_damp_)
@ -1205,6 +1215,13 @@ contains
is_legal_fact_thrs = (ip>=0.0d0) is_legal_fact_thrs = (ip>=0.0d0)
return return
end function is_legal_fact_thrs end function is_legal_fact_thrs
function is_legal_aggr_thrs(ip)
real(psb_dpk_), intent(in) :: ip
logical :: is_legal_aggr_thrs
is_legal_aggr_thrs = (ip>=0.0d0)
return
end function is_legal_aggr_thrs
function is_legal_s_omega(ip) function is_legal_s_omega(ip)
real(psb_spk_), intent(in) :: ip real(psb_spk_), intent(in) :: ip
@ -1219,6 +1236,13 @@ contains
is_legal_s_fact_thrs = (ip>=0.0) is_legal_s_fact_thrs = (ip>=0.0)
return return
end function is_legal_s_fact_thrs end function is_legal_s_fact_thrs
function is_legal_s_aggr_thrs(ip)
real(psb_spk_), intent(in) :: ip
logical :: is_legal_s_aggr_thrs
is_legal_s_aggr_thrs = (ip>=0.0)
return
end function is_legal_s_aggr_thrs
subroutine mld_icheck_def(ip,name,id,is_legal) subroutine mld_icheck_def(ip,name,id,is_legal)

273
mlprec/mld_saggrmap_bld.f90
Unescape Escape View File

@ -74,7 +74,7 @@
! info - integer, output. ! info - integer, output.
! Error code. ! Error code.
! !
subroutine mld_saggrmap_bld(aggr_type,a,desc_a,nlaggr,ilaggr,info) subroutine mld_saggrmap_bld(aggr_type,theta,a,desc_a,nlaggr,ilaggr,info)
use psb_base_mod use psb_base_mod
use mld_inner_mod, mld_protect_name => mld_saggrmap_bld use mld_inner_mod, mld_protect_name => mld_saggrmap_bld
@ -83,7 +83,8 @@ subroutine mld_saggrmap_bld(aggr_type,a,desc_a,nlaggr,ilaggr,info)
! Arguments ! Arguments
integer, intent(in) :: aggr_type integer, intent(in) :: aggr_type
type(psb_sspmat_type), intent(in), target :: a real(psb_spk_), intent(in) :: theta
type(psb_sspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_a type(psb_desc_type), intent(in) :: desc_a
integer, allocatable, intent(out) :: ilaggr(:),nlaggr(:) integer, allocatable, intent(out) :: ilaggr(:),nlaggr(:)
integer, intent(out) :: info integer, intent(out) :: info
@ -91,8 +92,7 @@ subroutine mld_saggrmap_bld(aggr_type,a,desc_a,nlaggr,ilaggr,info)
! Local variables ! Local variables
integer, allocatable :: ils(:), neigh(:) integer, allocatable :: ils(:), neigh(:)
integer :: icnt,nlp,k,n,ia,isz,nr, naggr,i,j,m integer :: icnt,nlp,k,n,ia,isz,nr, naggr,i,j,m
type(psb_sspmat_type), target :: atmp, atrans type(psb_sspmat_type) :: atmp, atrans
type(psb_sspmat_type), pointer :: apnt
logical :: recovery logical :: recovery
integer :: debug_level, debug_unit integer :: debug_level, debug_unit
integer :: ictxt,np,me,err_act integer :: ictxt,np,me,err_act
@ -116,8 +116,93 @@ subroutine mld_saggrmap_bld(aggr_type,a,desc_a,nlaggr,ilaggr,info)
ncol = psb_cd_get_local_cols(desc_a) ncol = psb_cd_get_local_cols(desc_a)
select case (aggr_type) select case (aggr_type)
case (mld_dec_aggr_,mld_sym_dec_aggr_) case (mld_dec_aggr_)
call mld_dec_map_bld(theta,a,desc_a,nlaggr,ilaggr,info)
case (mld_sym_dec_aggr_)
nr = psb_sp_get_nrows(a)
call psb_sp_clip(a,atmp,info,imax=nr,jmax=nr,&
& rscale=.false.,cscale=.false.)
atmp%m=nr
atmp%k=nr
if (info == 0) call psb_transp(atmp,atrans,fmt='COO')
if (info == 0) call psb_rwextd(nr,atmp,info,b=atrans,rowscale=.false.)
atmp%m=nr
atmp%k=nr
if (info == 0) call psb_sp_free(atrans,info)
if (info == 0) call psb_ipcoo2csr(atmp,info)
if (info == 0) call mld_dec_map_bld(theta,atmp,desc_a,nlaggr,ilaggr,info)
if (info == 0) call psb_sp_free(atmp,info)
case default
info = -1
call psb_errpush(30,name,i_err=(/1,aggr_type,0,0,0/))
goto 9999
end select
if (info/=0) then
info=4001
call psb_errpush(info,name,a_err='dec_map_bld')
goto 9999
end if
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act.eq.psb_act_abort_) then
call psb_error()
return
end if
return
contains
subroutine mld_dec_map_bld(theta,a,desc_a,nlaggr,ilaggr,info)
use psb_base_mod
use mld_inner_mod !, mld_protect_name => mld_daggrmap_bld
implicit none
! Arguments
type(psb_sspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_a
real(psb_spk_), intent(in) :: theta
integer, allocatable, intent(out) :: ilaggr(:),nlaggr(:)
integer, intent(out) :: info
! Local variables
integer, allocatable :: ils(:), neigh(:), irow(:), icol(:)
real(psb_spk_), allocatable :: val(:), diag(:)
integer :: icnt,nlp,k,n,ia,isz,nr, naggr,i,j,m, nz
real(psb_spk_) :: cpling, tcl
logical :: recovery
integer :: debug_level, debug_unit
integer :: ictxt,np,me,err_act
integer :: nrow, ncol, n_ne
character(len=20) :: name, ch_err
if(psb_get_errstatus() /= 0) return
info=0
name = 'mld_dec_map_bld'
call psb_erractionsave(err_act)
debug_unit = psb_get_debug_unit()
debug_level = psb_get_debug_level()
!
! Note. At the time being we are ignoring aggr_type so
! that we only have decoupled aggregation. This might
! change in the future.
!
ictxt=psb_cd_get_context(desc_a)
call psb_info(ictxt,me,np)
nrow = psb_cd_get_local_rows(desc_a)
ncol = psb_cd_get_local_cols(desc_a)
nr = a%m nr = a%m
allocate(ilaggr(nr),neigh(nr),stat=info) allocate(ilaggr(nr),neigh(nr),stat=info)
if(info /= 0) then if(info /= 0) then
@ -127,36 +212,28 @@ subroutine mld_saggrmap_bld(aggr_type,a,desc_a,nlaggr,ilaggr,info)
goto 9999 goto 9999
end if end if
allocate(diag(nr),stat=info)
if(info /= 0) then
info=4025
call psb_errpush(info,name,i_err=(/nr,0,0,0,0/),&
& a_err='real(psb_spk_)')
goto 9999
end if
call psb_sp_getdiag(a,diag,info)
if(info /= 0) then
info=4010
call psb_errpush(info,name,a_err='psb_sp_getdiag')
goto 9999
end if
do i=1, nr do i=1, nr
ilaggr(i) = -(nr+1) ilaggr(i) = -(nr+1)
end do end do
if (aggr_type == mld_dec_aggr_) then
apnt => a
else
call psb_sp_clip(a,atmp,info,imax=nr,jmax=nr,&
& rscale=.false.,cscale=.false.)
atmp%m=nr
atmp%k=nr
if (info == 0) call psb_transp(atmp,atrans,fmt='COO')
if (info == 0) call psb_rwextd(nr,atmp,info,b=atrans,rowscale=.false.)
atmp%m=nr
atmp%k=nr
if (info == 0) call psb_sp_free(atrans,info)
if (info == 0) call psb_ipcoo2csr(atmp,info)
apnt => atmp
if (info/=0) then
info=4001
call psb_errpush(info,name,a_err='init apnt')
goto 9999
end if
end if
! Note: -(nr+1) Untouched as yet ! Note: -(nr+1) Untouched as yet
! -i 1<=i<=nr Adjacent to aggregate i ! -i 1<=i<=nr Adjacent to aggregate i
! i 1<=i<=nr Belonging to aggregate i ! i 1<=i<=nr Belonging to aggregate i
! !
! Phase one: group nodes together. ! Phase one: group nodes together.
! Very simple minded strategy. ! Very simple minded strategy.
@ -171,26 +248,32 @@ subroutine mld_saggrmap_bld(aggr_type,a,desc_a,nlaggr,ilaggr,info)
! 1. Untouched nodes are marked >0 together ! 1. Untouched nodes are marked >0 together
! with their neighbours ! with their neighbours
! !
icnt = icnt + 1 icnt = icnt + 1
naggr = naggr + 1 naggr = naggr + 1
ilaggr(i) = naggr ilaggr(i) = naggr
call psb_neigh(apnt,i,neigh,n_ne,info,lev=1) call psb_sp_getrow(i,a,nz,irow,icol,val,info)
if (info/=0) then if (info/=0) then
info=4010 info=4010
call psb_errpush(info,name,a_err='psb_neigh') call psb_errpush(info,name,a_err='psb_sp_getrow')
goto 9999 goto 9999
end if end if
do k=1, n_ne
j = neigh(k) do k=1, nz
if ((1<=j).and.(j<=nr)) then j = icol(k)
ilaggr(j) = naggr if ((1<=j).and.(j<=nr).and.(i/=j)) then
endif if (abs(val(k)) > theta*sqrt(abs(diag(i)*diag(j)))) then
ilaggr(j) = naggr
else
ilaggr(j) = -naggr
endif
end if
enddo enddo
! !
! 2. Untouched neighbours of these nodes are marked <0. ! 2. Untouched neighbours of these nodes are marked <0.
! !
call psb_neigh(apnt,i,neigh,n_ne,info,lev=2) call psb_neigh(a,i,neigh,n_ne,info,lev=2)
if (info/=0) then if (info/=0) then
info=4010 info=4010
call psb_errpush(info,name,a_err='psb_neigh') call psb_errpush(info,name,a_err='psb_neigh')
@ -217,7 +300,7 @@ subroutine mld_saggrmap_bld(aggr_type,a,desc_a,nlaggr,ilaggr,info)
! !
! Phase two: sweep over leftovers. ! Phase two: sweep over leftovers.
! !
allocate(ils(naggr+10),stat=info) allocate(ils(nr),stat=info)
if(info /= 0) then if(info /= 0) then
info=4025 info=4025
call psb_errpush(info,name,i_err=(/naggr+10,0,0,0,0/),& call psb_errpush(info,name,i_err=(/naggr+10,0,0,0,0/),&
@ -253,57 +336,55 @@ subroutine mld_saggrmap_bld(aggr_type,a,desc_a,nlaggr,ilaggr,info)
if (ilaggr(i) < 0) then if (ilaggr(i) < 0) then
! !
! Now some silly rule to break ties: ! Now some silly rule to break ties:
! Group with smallest adjacent aggregate. ! Group with adjacent aggregate.
! !
isz = nr+1 isz = nr+1
ia = -1 ia = -1
cpling = 0.0
call psb_neigh(apnt,i,neigh,n_ne,info,lev=1) call psb_sp_getrow(i,a,nz,irow,icol,val,info)
if (info/=0) then if (info/=0) then
info=4010 info=4010
call psb_errpush(info,name,a_err='psb_neigh') call psb_errpush(info,name,a_err='psb_sp_getrow')
goto 9999 goto 9999
end if end if
do j=1, n_ne do j=1, nz
k = neigh(j) k = icol(j)
if ((1<=k).and.(k<=nr)) then if ((1<=k).and.(k<=nr).and.(k/=i)) then
n = ilaggr(k) tcl = abs(val(j)) / sqrt(abs(diag(i)*diag(k)))
if (n>0) then if (abs(val(j)) > theta*sqrt(abs(diag(i)*diag(k)))) then
if (n>naggr) then !!$ if (tcl > theta) then
info=4001 n = ilaggr(k)
call psb_errpush(info,name,a_err='loc_Aggregate: n > naggr 2 ?') if (n>0) then
goto 9999 if (n>naggr) then
end if info=4001
call psb_errpush(info,name,a_err='loc_Aggregate: n > naggr 2 ?')
if (ils(n) < isz) then goto 9999
ia = n end if
isz = ils(n)
if ((abs(val(j))>cpling) .or. &
& ((abs(val(j)) == cpling).and. (ils(n) < isz))) then
!!$ if ((tcl > cpling) .or. ((tcl == cpling).and. (ils(n) < isz))) then
ia = n
isz = ils(n)
cpling = abs(val(j))
!!$ cpling = tcl
endif
endif endif
endif endif
endif end if
enddo enddo
if (ia == -1) then if (ia == -1) then
if (ilaggr(i) > -(nr+1)) then ! At this point, the easiest thing is to start a new aggregate
ilaggr(i) = abs(ilaggr(i)) naggr = naggr + 1
if (ilaggr(I)>naggr) then ilaggr(i) = naggr
info=4001 ils(ilaggr(i)) = 1
call psb_errpush(info,name,a_err='loc_Aggregate: n > naggr 3 ?')
goto 9999
end if
ils(ilaggr(i)) = ils(ilaggr(i)) + 1
!
! This might happen if the pattern is non symmetric.
! Need a better handling.
!
recovery = .true.
else
info=4001
call psb_errpush(info,name,a_err='Unrecoverable error !!')
goto 9999
endif
else else
ilaggr(i) = ia ilaggr(i) = ia
if (ia>naggr) then if (ia>naggr) then
info=4001 info=4001
call psb_errpush(info,name,a_err='loc_Aggregate: n > naggr 4? ') call psb_errpush(info,name,a_err='loc_Aggregate: n > naggr 4? ')
@ -311,8 +392,9 @@ subroutine mld_saggrmap_bld(aggr_type,a,desc_a,nlaggr,ilaggr,info)
end if end if
ils(ia) = ils(ia) + 1 ils(ia) = ils(ia) + 1
endif endif
end if end if
enddo end do
if (debug_level >= psb_debug_outer_) then if (debug_level >= psb_debug_outer_) then
if (recovery) then if (recovery) then
write(debug_unit,*) me,' ',trim(name),& write(debug_unit,*) me,' ',trim(name),&
@ -344,6 +426,12 @@ subroutine mld_saggrmap_bld(aggr_type,a,desc_a,nlaggr,ilaggr,info)
call psb_errpush(info,name) call psb_errpush(info,name)
goto 9999 goto 9999
end if end if
if (naggr > ncol) then
write(0,*) name,'Error : naggr > ncol',naggr,ncol
info=4001
call psb_errpush(info,name,a_err='Fatal error: naggr>ncol')
goto 9999
end if
call psb_realloc(ncol,ilaggr,info) call psb_realloc(ncol,ilaggr,info)
if (info/=0) then if (info/=0) then
@ -365,26 +453,17 @@ subroutine mld_saggrmap_bld(aggr_type,a,desc_a,nlaggr,ilaggr,info)
nlaggr(me+1) = naggr nlaggr(me+1) = naggr
call psb_sum(ictxt,nlaggr(1:np)) call psb_sum(ictxt,nlaggr(1:np))
if (aggr_type == mld_sym_dec_aggr_) then call psb_erractionrestore(err_act)
call psb_sp_free(atmp,info) return
end if
case default
info = -1
call psb_errpush(30,name,i_err=(/1,aggr_type,0,0,0/))
goto 9999
end select
call psb_erractionrestore(err_act)
return
9999 continue 9999 continue
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
if (err_act.eq.psb_act_abort_) then if (err_act.eq.psb_act_abort_) then
call psb_error() call psb_error()
return
end if
return return
end if
return end subroutine mld_dec_map_bld
end subroutine mld_saggrmap_bld end subroutine mld_saggrmap_bld

4
mlprec/mld_smlprec_bld.f90
Unescape Escape View File

@ -109,6 +109,7 @@ subroutine mld_smlprec_bld(a,desc_a,p,info)
call mld_check_def(p%rprcparm(mld_fact_thrs_),'Eps',szero,is_legal_s_fact_thrs) call mld_check_def(p%rprcparm(mld_fact_thrs_),'Eps',szero,is_legal_s_fact_thrs)
end select end select
call mld_check_def(p%rprcparm(mld_aggr_damp_),'Omega',szero,is_legal_s_omega) call mld_check_def(p%rprcparm(mld_aggr_damp_),'Omega',szero,is_legal_s_omega)
call mld_check_def(p%rprcparm(mld_aggr_thresh_),'Aggr_Thresh',szero,is_legal_s_aggr_thrs)
call mld_check_def(p%iprcparm(mld_smooth_sweeps_),'Jacobi sweeps',& call mld_check_def(p%iprcparm(mld_smooth_sweeps_),'Jacobi sweeps',&
& 1,is_legal_jac_sweeps) & 1,is_legal_jac_sweeps)
@ -118,7 +119,8 @@ subroutine mld_smlprec_bld(a,desc_a,p,info)
! aggregation algorithm. This also defines a tentative prolongator from ! aggregation algorithm. This also defines a tentative prolongator from
! the coarse to the fine level. ! the coarse to the fine level.
! !
call mld_aggrmap_bld(p%iprcparm(mld_aggr_alg_),a,desc_a,p%nlaggr,p%mlia,info) call mld_aggrmap_bld(p%iprcparm(mld_aggr_alg_),p%rprcparm(mld_aggr_thresh_),&
& a,desc_a,p%nlaggr,p%mlia,info)
if(info /= 0) then if(info /= 0) then
call psb_errpush(4010,name,a_err='mld_aggrmap_bld') call psb_errpush(4010,name,a_err='mld_aggrmap_bld')
goto 9999 goto 9999

9
mlprec/mld_sprecinit.f90
Unescape Escape View File

@ -189,7 +189,8 @@ subroutine mld_sprecinit(p,ptype,info,nlev)
if (info == 0) call psb_realloc(mld_ifpsz_,p%baseprecv(ilev_)%iprcparm,info) if (info == 0) call psb_realloc(mld_ifpsz_,p%baseprecv(ilev_)%iprcparm,info)
if (info == 0) call psb_realloc(mld_rfpsz_,p%baseprecv(ilev_)%rprcparm,info) if (info == 0) call psb_realloc(mld_rfpsz_,p%baseprecv(ilev_)%rprcparm,info)
if (info /= 0) return if (info /= 0) return
p%baseprecv(ilev_)%iprcparm(:) = 0 p%baseprecv(ilev_)%iprcparm(:) = 0
p%baseprecv(ilev_)%rprcparm(:) = szero
p%baseprecv(ilev_)%iprcparm(mld_prec_type_) = mld_as_ p%baseprecv(ilev_)%iprcparm(mld_prec_type_) = mld_as_
p%baseprecv(ilev_)%iprcparm(mld_sub_solve_) = mld_ilu_n_ p%baseprecv(ilev_)%iprcparm(mld_sub_solve_) = mld_ilu_n_
p%baseprecv(ilev_)%iprcparm(mld_sub_restr_) = psb_halo_ p%baseprecv(ilev_)%iprcparm(mld_sub_restr_) = psb_halo_
@ -204,7 +205,8 @@ subroutine mld_sprecinit(p,ptype,info,nlev)
if (info == 0) call psb_realloc(mld_ifpsz_,p%baseprecv(ilev_)%iprcparm,info) if (info == 0) call psb_realloc(mld_ifpsz_,p%baseprecv(ilev_)%iprcparm,info)
if (info == 0) call psb_realloc(mld_rfpsz_,p%baseprecv(ilev_)%rprcparm,info) if (info == 0) call psb_realloc(mld_rfpsz_,p%baseprecv(ilev_)%rprcparm,info)
if (info /= 0) return if (info /= 0) return
p%baseprecv(ilev_)%iprcparm(:) = 0 p%baseprecv(ilev_)%iprcparm(:) = 0
p%baseprecv(ilev_)%rprcparm(:) = szero
p%baseprecv(ilev_)%iprcparm(mld_prec_type_) = mld_bjac_ p%baseprecv(ilev_)%iprcparm(mld_prec_type_) = mld_bjac_
p%baseprecv(ilev_)%iprcparm(mld_sub_restr_) = psb_none_ p%baseprecv(ilev_)%iprcparm(mld_sub_restr_) = psb_none_
p%baseprecv(ilev_)%iprcparm(mld_sub_prol_) = psb_none_ p%baseprecv(ilev_)%iprcparm(mld_sub_prol_) = psb_none_
@ -225,7 +227,8 @@ subroutine mld_sprecinit(p,ptype,info,nlev)
if (info == 0) call psb_realloc(mld_ifpsz_,p%baseprecv(ilev_)%iprcparm,info) if (info == 0) call psb_realloc(mld_ifpsz_,p%baseprecv(ilev_)%iprcparm,info)
if (info == 0) call psb_realloc(mld_rfpsz_,p%baseprecv(ilev_)%rprcparm,info) if (info == 0) call psb_realloc(mld_rfpsz_,p%baseprecv(ilev_)%rprcparm,info)
if (info /= 0) return if (info /= 0) return
p%baseprecv(ilev_)%iprcparm(:) = 0 p%baseprecv(ilev_)%iprcparm(:) = 0
p%baseprecv(ilev_)%rprcparm(:) = szero
p%baseprecv(ilev_)%iprcparm(mld_prec_type_) = mld_bjac_ p%baseprecv(ilev_)%iprcparm(mld_prec_type_) = mld_bjac_
p%baseprecv(ilev_)%iprcparm(mld_sub_restr_) = psb_none_ p%baseprecv(ilev_)%iprcparm(mld_sub_restr_) = psb_none_
p%baseprecv(ilev_)%iprcparm(mld_sub_prol_) = psb_none_ p%baseprecv(ilev_)%iprcparm(mld_sub_prol_) = psb_none_

15
mlprec/mld_sprecset.f90
Unescape Escape View File

@ -595,7 +595,7 @@ subroutine mld_sprecsetr(p,what,val,info,ilev)
else if (ilev_ > 1) then else if (ilev_ > 1) then
select case(what) select case(what)
case(mld_aggr_damp_,mld_fact_thrs_) case(mld_aggr_damp_,mld_aggr_thresh_,mld_fact_thrs_)
p%baseprecv(ilev_)%rprcparm(what) = val p%baseprecv(ilev_)%rprcparm(what) = val
case default case default
write(0,*) name,': Error: invalid WHAT' write(0,*) name,': Error: invalid WHAT'
@ -610,7 +610,7 @@ subroutine mld_sprecsetr(p,what,val,info,ilev)
select case(what) select case(what)
case(mld_fact_thrs_) case(mld_fact_thrs_)
do ilev_=1,nlev_-1 do ilev_=1,nlev_
if (.not.allocated(p%baseprecv(ilev_)%rprcparm)) then if (.not.allocated(p%baseprecv(ilev_)%rprcparm)) then
write(0,*) name,': Error: Uninitialized preconditioner component, should call MLD_PRECINIT' write(0,*) name,': Error: Uninitialized preconditioner component, should call MLD_PRECINIT'
info = -1 info = -1
@ -619,7 +619,16 @@ subroutine mld_sprecsetr(p,what,val,info,ilev)
p%baseprecv(ilev_)%rprcparm(what) = val p%baseprecv(ilev_)%rprcparm(what) = val
end do end do
case(mld_aggr_damp_) case(mld_aggr_damp_)
do ilev_=2,nlev_-1 do ilev_=2,nlev_
if (.not.allocated(p%baseprecv(ilev_)%rprcparm)) then
write(0,*) name,': Error: Uninitialized preconditioner component, should call MLD_PRECINIT'
info = -1
return
endif
p%baseprecv(ilev_)%rprcparm(what) = val
end do
case(mld_aggr_thresh_)
do ilev_=2,nlev_
if (.not.allocated(p%baseprecv(ilev_)%rprcparm)) then if (.not.allocated(p%baseprecv(ilev_)%rprcparm)) then
write(0,*) name,': Error: Uninitialized preconditioner component, should call MLD_PRECINIT' write(0,*) name,': Error: Uninitialized preconditioner component, should call MLD_PRECINIT'
info = -1 info = -1

274
mlprec/mld_zaggrmap_bld.f90
Unescape Escape View File

@ -74,7 +74,7 @@
! info - integer, output. ! info - integer, output.
! Error code. ! Error code.
! !
subroutine mld_zaggrmap_bld(aggr_type,a,desc_a,nlaggr,ilaggr,info) subroutine mld_zaggrmap_bld(aggr_type,theta,a,desc_a,nlaggr,ilaggr,info)
use psb_base_mod use psb_base_mod
use mld_inner_mod, mld_protect_name => mld_zaggrmap_bld use mld_inner_mod, mld_protect_name => mld_zaggrmap_bld
@ -83,7 +83,8 @@ subroutine mld_zaggrmap_bld(aggr_type,a,desc_a,nlaggr,ilaggr,info)
! Arguments ! Arguments
integer, intent(in) :: aggr_type integer, intent(in) :: aggr_type
type(psb_zspmat_type), intent(in), target :: a real(psb_dpk_), intent(in) :: theta
type(psb_zspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_a type(psb_desc_type), intent(in) :: desc_a
integer, allocatable, intent(out) :: ilaggr(:),nlaggr(:) integer, allocatable, intent(out) :: ilaggr(:),nlaggr(:)
integer, intent(out) :: info integer, intent(out) :: info
@ -91,9 +92,7 @@ subroutine mld_zaggrmap_bld(aggr_type,a,desc_a,nlaggr,ilaggr,info)
! Local variables ! Local variables
integer, allocatable :: ils(:), neigh(:) integer, allocatable :: ils(:), neigh(:)
integer :: icnt,nlp,k,n,ia,isz,nr, naggr,i,j,m integer :: icnt,nlp,k,n,ia,isz,nr, naggr,i,j,m
type(psb_zspmat_type), target :: atmp, atrans type(psb_zspmat_type) :: atmp, atrans
type(psb_zspmat_type), pointer :: apnt
logical :: recovery logical :: recovery
integer :: debug_level, debug_unit integer :: debug_level, debug_unit
integer :: ictxt,np,me,err_act integer :: ictxt,np,me,err_act
@ -117,8 +116,93 @@ subroutine mld_zaggrmap_bld(aggr_type,a,desc_a,nlaggr,ilaggr,info)
ncol = psb_cd_get_local_cols(desc_a) ncol = psb_cd_get_local_cols(desc_a)
select case (aggr_type) select case (aggr_type)
case (mld_dec_aggr_,mld_sym_dec_aggr_) case (mld_dec_aggr_)
call mld_dec_map_bld(theta,a,desc_a,nlaggr,ilaggr,info)
case (mld_sym_dec_aggr_)
nr = psb_sp_get_nrows(a)
call psb_sp_clip(a,atmp,info,imax=nr,jmax=nr,&
& rscale=.false.,cscale=.false.)
atmp%m=nr
atmp%k=nr
if (info == 0) call psb_transp(atmp,atrans,fmt='COO')
if (info == 0) call psb_rwextd(nr,atmp,info,b=atrans,rowscale=.false.)
atmp%m=nr
atmp%k=nr
if (info == 0) call psb_sp_free(atrans,info)
if (info == 0) call psb_ipcoo2csr(atmp,info)
if (info == 0) call mld_dec_map_bld(theta,atmp,desc_a,nlaggr,ilaggr,info)
if (info == 0) call psb_sp_free(atmp,info)
case default
info = -1
call psb_errpush(30,name,i_err=(/1,aggr_type,0,0,0/))
goto 9999
end select
if (info/=0) then
info=4001
call psb_errpush(info,name,a_err='dec_map_bld')
goto 9999
end if
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act.eq.psb_act_abort_) then
call psb_error()
return
end if
return
contains
subroutine mld_dec_map_bld(theta,a,desc_a,nlaggr,ilaggr,info)
use psb_base_mod
use mld_inner_mod !, mld_protect_name => mld_daggrmap_bld
implicit none
! Arguments
type(psb_zspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_a
real(psb_dpk_), intent(in) :: theta
integer, allocatable, intent(out) :: ilaggr(:),nlaggr(:)
integer, intent(out) :: info
! Local variables
integer, allocatable :: ils(:), neigh(:), irow(:), icol(:)
complex(psb_dpk_), allocatable :: val(:), diag(:)
integer :: icnt,nlp,k,n,ia,isz,nr, naggr,i,j,m, nz
real(psb_dpk_) :: cpling, tcl
logical :: recovery
integer :: debug_level, debug_unit
integer :: ictxt,np,me,err_act
integer :: nrow, ncol, n_ne
character(len=20) :: name, ch_err
if(psb_get_errstatus() /= 0) return
info=0
name = 'mld_dec_map_bld'
call psb_erractionsave(err_act)
debug_unit = psb_get_debug_unit()
debug_level = psb_get_debug_level()
!
! Note. At the time being we are ignoring aggr_type so
! that we only have decoupled aggregation. This might
! change in the future.
!
ictxt=psb_cd_get_context(desc_a)
call psb_info(ictxt,me,np)
nrow = psb_cd_get_local_rows(desc_a)
ncol = psb_cd_get_local_cols(desc_a)
nr = a%m nr = a%m
allocate(ilaggr(nr),neigh(nr),stat=info) allocate(ilaggr(nr),neigh(nr),stat=info)
if(info /= 0) then if(info /= 0) then
@ -128,36 +212,28 @@ subroutine mld_zaggrmap_bld(aggr_type,a,desc_a,nlaggr,ilaggr,info)
goto 9999 goto 9999
end if end if
allocate(diag(nr),stat=info)
if(info /= 0) then
info=4025
call psb_errpush(info,name,i_err=(/nr,0,0,0,0/),&
& a_err='complex(psb_dpk_)')
goto 9999
end if
call psb_sp_getdiag(a,diag,info)
if(info /= 0) then
info=4010
call psb_errpush(info,name,a_err='psb_sp_getdiag')
goto 9999
end if
do i=1, nr do i=1, nr
ilaggr(i) = -(nr+1) ilaggr(i) = -(nr+1)
end do end do
if (aggr_type == mld_dec_aggr_) then
apnt => a
else
call psb_sp_clip(a,atmp,info,imax=nr,jmax=nr,&
& rscale=.false.,cscale=.false.)
atmp%m=nr
atmp%k=nr
if (info == 0) call psb_transp(atmp,atrans,fmt='COO')
if (info == 0) call psb_rwextd(nr,atmp,info,b=atrans,rowscale=.false.)
atmp%m=nr
atmp%k=nr
if (info == 0) call psb_sp_free(atrans,info)
if (info == 0) call psb_ipcoo2csr(atmp,info)
apnt => atmp
if (info/=0) then
info=4001
call psb_errpush(info,name,a_err='init apnt')
goto 9999
end if
end if
! Note: -(nr+1) Untouched as yet ! Note: -(nr+1) Untouched as yet
! -i 1<=i<=nr Adjacent to aggregate i ! -i 1<=i<=nr Adjacent to aggregate i
! i 1<=i<=nr Belonging to aggregate i ! i 1<=i<=nr Belonging to aggregate i
! !
! Phase one: group nodes together. ! Phase one: group nodes together.
! Very simple minded strategy. ! Very simple minded strategy.
@ -172,26 +248,32 @@ subroutine mld_zaggrmap_bld(aggr_type,a,desc_a,nlaggr,ilaggr,info)
! 1. Untouched nodes are marked >0 together ! 1. Untouched nodes are marked >0 together
! with their neighbours ! with their neighbours
! !
icnt = icnt + 1 icnt = icnt + 1
naggr = naggr + 1 naggr = naggr + 1
ilaggr(i) = naggr ilaggr(i) = naggr
call psb_neigh(apnt,i,neigh,n_ne,info,lev=1) call psb_sp_getrow(i,a,nz,irow,icol,val,info)
if (info/=0) then if (info/=0) then
info=4010 info=4010
call psb_errpush(info,name,a_err='psb_neigh') call psb_errpush(info,name,a_err='psb_sp_getrow')
goto 9999 goto 9999
end if end if
do k=1, n_ne
j = neigh(k) do k=1, nz
if ((1<=j).and.(j<=nr)) then j = icol(k)
ilaggr(j) = naggr if ((1<=j).and.(j<=nr).and.(i/=j)) then
endif if (abs(val(k)) > theta*sqrt(abs(diag(i)*diag(j)))) then
ilaggr(j) = naggr
else
ilaggr(j) = -naggr
endif
end if
enddo enddo
! !
! 2. Untouched neighbours of these nodes are marked <0. ! 2. Untouched neighbours of these nodes are marked <0.
! !
call psb_neigh(apnt,i,neigh,n_ne,info,lev=2) call psb_neigh(a,i,neigh,n_ne,info,lev=2)
if (info/=0) then if (info/=0) then
info=4010 info=4010
call psb_errpush(info,name,a_err='psb_neigh') call psb_errpush(info,name,a_err='psb_neigh')
@ -218,7 +300,7 @@ subroutine mld_zaggrmap_bld(aggr_type,a,desc_a,nlaggr,ilaggr,info)
! !
! Phase two: sweep over leftovers. ! Phase two: sweep over leftovers.
! !
allocate(ils(naggr+10),stat=info) allocate(ils(nr),stat=info)
if(info /= 0) then if(info /= 0) then
info=4025 info=4025
call psb_errpush(info,name,i_err=(/naggr+10,0,0,0,0/),& call psb_errpush(info,name,i_err=(/naggr+10,0,0,0,0/),&
@ -254,57 +336,55 @@ subroutine mld_zaggrmap_bld(aggr_type,a,desc_a,nlaggr,ilaggr,info)
if (ilaggr(i) < 0) then if (ilaggr(i) < 0) then
! !
! Now some silly rule to break ties: ! Now some silly rule to break ties:
! Group with smallest adjacent aggregate. ! Group with adjacent aggregate.
! !
isz = nr+1 isz = nr+1
ia = -1 ia = -1
cpling = 0.0d0
call psb_neigh(apnt,i,neigh,n_ne,info,lev=1) call psb_sp_getrow(i,a,nz,irow,icol,val,info)
if (info/=0) then if (info/=0) then
info=4010 info=4010
call psb_errpush(info,name,a_err='psb_neigh') call psb_errpush(info,name,a_err='psb_sp_getrow')
goto 9999 goto 9999
end if end if
do j=1, n_ne do j=1, nz
k = neigh(j) k = icol(j)
if ((1<=k).and.(k<=nr)) then if ((1<=k).and.(k<=nr).and.(k/=i)) then
n = ilaggr(k) tcl = abs(val(j)) / sqrt(abs(diag(i)*diag(k)))
if (n>0) then if (abs(val(j)) > theta*sqrt(abs(diag(i)*diag(k)))) then
if (n>naggr) then !!$ if (tcl > theta) then
info=4001 n = ilaggr(k)
call psb_errpush(info,name,a_err='loc_Aggregate: n > naggr 2 ?') if (n>0) then
goto 9999 if (n>naggr) then
end if info=4001
call psb_errpush(info,name,a_err='loc_Aggregate: n > naggr 2 ?')
if (ils(n) < isz) then goto 9999
ia = n end if
isz = ils(n)
if ((abs(val(j))>cpling) .or. &
& ((abs(val(j)) == cpling).and. (ils(n) < isz))) then
!!$ if ((tcl > cpling) .or. ((tcl == cpling).and. (ils(n) < isz))) then
ia = n
isz = ils(n)
cpling = abs(val(j))
!!$ cpling = tcl
endif
endif endif
endif endif
endif end if
enddo enddo
if (ia == -1) then if (ia == -1) then
if (ilaggr(i) > -(nr+1)) then ! At this point, the easiest thing is to start a new aggregate
ilaggr(i) = abs(ilaggr(i)) naggr = naggr + 1
if (ilaggr(I)>naggr) then ilaggr(i) = naggr
info=4001 ils(ilaggr(i)) = 1
call psb_errpush(info,name,a_err='loc_Aggregate: n > naggr 3 ?')
goto 9999
end if
ils(ilaggr(i)) = ils(ilaggr(i)) + 1
!
! This might happen if the pattern is non symmetric.
! Need a better handling.
!
recovery = .true.
else
info=4001
call psb_errpush(info,name,a_err='Unrecoverable error !!')
goto 9999
endif
else else
ilaggr(i) = ia ilaggr(i) = ia
if (ia>naggr) then if (ia>naggr) then
info=4001 info=4001
call psb_errpush(info,name,a_err='loc_Aggregate: n > naggr 4? ') call psb_errpush(info,name,a_err='loc_Aggregate: n > naggr 4? ')
@ -312,8 +392,9 @@ subroutine mld_zaggrmap_bld(aggr_type,a,desc_a,nlaggr,ilaggr,info)
end if end if
ils(ia) = ils(ia) + 1 ils(ia) = ils(ia) + 1
endif endif
end if end if
enddo end do
if (debug_level >= psb_debug_outer_) then if (debug_level >= psb_debug_outer_) then
if (recovery) then if (recovery) then
write(debug_unit,*) me,' ',trim(name),& write(debug_unit,*) me,' ',trim(name),&
@ -345,6 +426,12 @@ subroutine mld_zaggrmap_bld(aggr_type,a,desc_a,nlaggr,ilaggr,info)
call psb_errpush(info,name) call psb_errpush(info,name)
goto 9999 goto 9999
end if end if
if (naggr > ncol) then
write(0,*) name,'Error : naggr > ncol',naggr,ncol
info=4001
call psb_errpush(info,name,a_err='Fatal error: naggr>ncol')
goto 9999
end if
call psb_realloc(ncol,ilaggr,info) call psb_realloc(ncol,ilaggr,info)
if (info/=0) then if (info/=0) then
@ -366,26 +453,17 @@ subroutine mld_zaggrmap_bld(aggr_type,a,desc_a,nlaggr,ilaggr,info)
nlaggr(me+1) = naggr nlaggr(me+1) = naggr
call psb_sum(ictxt,nlaggr(1:np)) call psb_sum(ictxt,nlaggr(1:np))
if (aggr_type == mld_sym_dec_aggr_) then call psb_erractionrestore(err_act)
call psb_sp_free(atmp,info) return
end if
case default
info = -1
call psb_errpush(30,name,i_err=(/1,aggr_type,0,0,0/))
goto 9999
end select
call psb_erractionrestore(err_act)
return
9999 continue 9999 continue
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
if (err_act.eq.psb_act_abort_) then if (err_act.eq.psb_act_abort_) then
call psb_error() call psb_error()
return
end if
return return
end if
return end subroutine mld_dec_map_bld
end subroutine mld_zaggrmap_bld end subroutine mld_zaggrmap_bld

4
mlprec/mld_zmlprec_bld.f90
Unescape Escape View File

@ -109,6 +109,7 @@ subroutine mld_zmlprec_bld(a,desc_a,p,info)
call mld_check_def(p%rprcparm(mld_fact_thrs_),'Eps',dzero,is_legal_fact_thrs) call mld_check_def(p%rprcparm(mld_fact_thrs_),'Eps',dzero,is_legal_fact_thrs)
end select end select
call mld_check_def(p%rprcparm(mld_aggr_damp_),'Omega',dzero,is_legal_omega) call mld_check_def(p%rprcparm(mld_aggr_damp_),'Omega',dzero,is_legal_omega)
call mld_check_def(p%rprcparm(mld_aggr_thresh_),'Aggr_Thresh',dzero,is_legal_aggr_thrs)
call mld_check_def(p%iprcparm(mld_smooth_sweeps_),'Jacobi sweeps',& call mld_check_def(p%iprcparm(mld_smooth_sweeps_),'Jacobi sweeps',&
& 1,is_legal_jac_sweeps) & 1,is_legal_jac_sweeps)
@ -118,7 +119,8 @@ subroutine mld_zmlprec_bld(a,desc_a,p,info)
! aggregation algorithm. This also defines a tentative prolongator from ! aggregation algorithm. This also defines a tentative prolongator from
! the coarse to the fine level. ! the coarse to the fine level.
! !
call mld_aggrmap_bld(p%iprcparm(mld_aggr_alg_),a,desc_a,p%nlaggr,p%mlia,info) call mld_aggrmap_bld(p%iprcparm(mld_aggr_alg_),p%rprcparm(mld_aggr_thresh_),&
& a,desc_a,p%nlaggr,p%mlia,info)
if(info /= 0) then if(info /= 0) then
call psb_errpush(4010,name,a_err='mld_aggrmap_bld') call psb_errpush(4010,name,a_err='mld_aggrmap_bld')
goto 9999 goto 9999

9
mlprec/mld_zprecinit.f90
Unescape Escape View File

@ -189,7 +189,8 @@ subroutine mld_zprecinit(p,ptype,info,nlev)
if (info == 0) call psb_realloc(mld_ifpsz_,p%baseprecv(ilev_)%iprcparm,info) if (info == 0) call psb_realloc(mld_ifpsz_,p%baseprecv(ilev_)%iprcparm,info)
if (info == 0) call psb_realloc(mld_rfpsz_,p%baseprecv(ilev_)%rprcparm,info) if (info == 0) call psb_realloc(mld_rfpsz_,p%baseprecv(ilev_)%rprcparm,info)
if (info /= 0) return if (info /= 0) return
p%baseprecv(ilev_)%iprcparm(:) = 0 p%baseprecv(ilev_)%iprcparm(:) = 0
p%baseprecv(ilev_)%rprcparm(:) = dzero
p%baseprecv(ilev_)%iprcparm(mld_prec_type_) = mld_as_ p%baseprecv(ilev_)%iprcparm(mld_prec_type_) = mld_as_
p%baseprecv(ilev_)%iprcparm(mld_sub_solve_) = mld_ilu_n_ p%baseprecv(ilev_)%iprcparm(mld_sub_solve_) = mld_ilu_n_
p%baseprecv(ilev_)%iprcparm(mld_sub_restr_) = psb_halo_ p%baseprecv(ilev_)%iprcparm(mld_sub_restr_) = psb_halo_
@ -204,7 +205,8 @@ subroutine mld_zprecinit(p,ptype,info,nlev)
if (info == 0) call psb_realloc(mld_ifpsz_,p%baseprecv(ilev_)%iprcparm,info) if (info == 0) call psb_realloc(mld_ifpsz_,p%baseprecv(ilev_)%iprcparm,info)
if (info == 0) call psb_realloc(mld_rfpsz_,p%baseprecv(ilev_)%rprcparm,info) if (info == 0) call psb_realloc(mld_rfpsz_,p%baseprecv(ilev_)%rprcparm,info)
if (info /= 0) return if (info /= 0) return
p%baseprecv(ilev_)%iprcparm(:) = 0 p%baseprecv(ilev_)%iprcparm(:) = 0
p%baseprecv(ilev_)%rprcparm(:) = dzero
p%baseprecv(ilev_)%iprcparm(mld_prec_type_) = mld_bjac_ p%baseprecv(ilev_)%iprcparm(mld_prec_type_) = mld_bjac_
p%baseprecv(ilev_)%iprcparm(mld_sub_restr_) = psb_none_ p%baseprecv(ilev_)%iprcparm(mld_sub_restr_) = psb_none_
p%baseprecv(ilev_)%iprcparm(mld_sub_prol_) = psb_none_ p%baseprecv(ilev_)%iprcparm(mld_sub_prol_) = psb_none_
@ -225,7 +227,8 @@ subroutine mld_zprecinit(p,ptype,info,nlev)
if (info == 0) call psb_realloc(mld_ifpsz_,p%baseprecv(ilev_)%iprcparm,info) if (info == 0) call psb_realloc(mld_ifpsz_,p%baseprecv(ilev_)%iprcparm,info)
if (info == 0) call psb_realloc(mld_rfpsz_,p%baseprecv(ilev_)%rprcparm,info) if (info == 0) call psb_realloc(mld_rfpsz_,p%baseprecv(ilev_)%rprcparm,info)
if (info /= 0) return if (info /= 0) return
p%baseprecv(ilev_)%iprcparm(:) = 0 p%baseprecv(ilev_)%iprcparm(:) = 0
p%baseprecv(ilev_)%rprcparm(:) = dzero
p%baseprecv(ilev_)%iprcparm(mld_prec_type_) = mld_bjac_ p%baseprecv(ilev_)%iprcparm(mld_prec_type_) = mld_bjac_
p%baseprecv(ilev_)%iprcparm(mld_sub_restr_) = psb_none_ p%baseprecv(ilev_)%iprcparm(mld_sub_restr_) = psb_none_
p%baseprecv(ilev_)%iprcparm(mld_sub_prol_) = psb_none_ p%baseprecv(ilev_)%iprcparm(mld_sub_prol_) = psb_none_

15
mlprec/mld_zprecset.f90
Unescape Escape View File

@ -595,7 +595,7 @@ subroutine mld_zprecsetr(p,what,val,info,ilev)
else if (ilev_ > 1) then else if (ilev_ > 1) then
select case(what) select case(what)
case(mld_aggr_damp_,mld_fact_thrs_) case(mld_aggr_damp_,mld_aggr_thresh_,mld_fact_thrs_)
p%baseprecv(ilev_)%rprcparm(what) = val p%baseprecv(ilev_)%rprcparm(what) = val
case default case default
write(0,*) name,': Error: invalid WHAT' write(0,*) name,': Error: invalid WHAT'
@ -610,7 +610,7 @@ subroutine mld_zprecsetr(p,what,val,info,ilev)
select case(what) select case(what)
case(mld_fact_thrs_) case(mld_fact_thrs_)
do ilev_=1,nlev_-1 do ilev_=1,nlev_
if (.not.allocated(p%baseprecv(ilev_)%rprcparm)) then if (.not.allocated(p%baseprecv(ilev_)%rprcparm)) then
write(0,*) name,': Error: Uninitialized preconditioner component, should call MLD_PRECINIT' write(0,*) name,': Error: Uninitialized preconditioner component, should call MLD_PRECINIT'
info = -1 info = -1
@ -619,7 +619,16 @@ subroutine mld_zprecsetr(p,what,val,info,ilev)
p%baseprecv(ilev_)%rprcparm(what) = val p%baseprecv(ilev_)%rprcparm(what) = val
end do end do
case(mld_aggr_damp_) case(mld_aggr_damp_)
do ilev_=2,nlev_-1 do ilev_=2,nlev_
if (.not.allocated(p%baseprecv(ilev_)%rprcparm)) then
write(0,*) name,': Error: Uninitialized preconditioner component, should call MLD_PRECINIT'
info = -1
return
endif
p%baseprecv(ilev_)%rprcparm(what) = val
end do
case(mld_aggr_thresh_)
do ilev_=2,nlev_
if (.not.allocated(p%baseprecv(ilev_)%rprcparm)) then if (.not.allocated(p%baseprecv(ilev_)%rprcparm)) then
write(0,*) name,': Error: Uninitialized preconditioner component, should call MLD_PRECINIT' write(0,*) name,': Error: Uninitialized preconditioner component, should call MLD_PRECINIT'
info = -1 info = -1

5
test/fileread/cf_sample.f90
Unescape Escape View File

@ -67,6 +67,7 @@ program cf_sample
real(psb_spk_) :: cthres ! Threshold for fact. 1 ILU(T) real(psb_spk_) :: cthres ! Threshold for fact. 1 ILU(T)
integer :: cjswp ! Jacobi sweeps integer :: cjswp ! Jacobi sweeps
real(psb_spk_) :: omega ! smoother omega real(psb_spk_) :: omega ! smoother omega
real(psb_spk_) :: athres ! smoother aggregation threshold
end type precdata end type precdata
type(precdata) :: prec_choice type(precdata) :: prec_choice
@ -242,7 +243,7 @@ program cf_sample
call mld_precset(prec,mld_coarse_solve_,prec_choice%csolve,info) call mld_precset(prec,mld_coarse_solve_,prec_choice%csolve,info)
call mld_precset(prec,mld_sub_fill_in_,prec_choice%cfill,info,ilev=nlv) call mld_precset(prec,mld_sub_fill_in_,prec_choice%cfill,info,ilev=nlv)
call mld_precset(prec,mld_fact_thrs_,prec_choice%cthres,info,ilev=nlv) call mld_precset(prec,mld_fact_thrs_,prec_choice%cthres,info,ilev=nlv)
call mld_precset(prec,mld_smooth_sweeps_,prec_choice%cjswp,info,ilev=nlv) call mld_precset(prec,mld_aggr_thresh_,prec_choice%athres,info)
call mld_precset(prec,mld_smooth_sweeps_,prec_choice%cjswp,info,ilev=nlv) call mld_precset(prec,mld_smooth_sweeps_,prec_choice%cjswp,info,ilev=nlv)
if (prec_choice%omega>=0.0) then if (prec_choice%omega>=0.0) then
call mld_precset(prec,mld_aggr_damp_,prec_choice%omega,info,ilev=nlv) call mld_precset(prec,mld_aggr_damp_,prec_choice%omega,info,ilev=nlv)
@ -392,6 +393,7 @@ contains
call read_data(prec%cthres,5) ! Threshold for fact. 1 ILU(T) call read_data(prec%cthres,5) ! Threshold for fact. 1 ILU(T)
call read_data(prec%cjswp,5) ! Jacobi sweeps call read_data(prec%cjswp,5) ! Jacobi sweeps
call read_data(prec%omega,5) ! smoother omega call read_data(prec%omega,5) ! smoother omega
call read_data(prec%athres,5) ! smoother aggr thresh
end if end if
end if end if
@ -426,6 +428,7 @@ contains
call psb_bcast(icontxt,prec%cthres) ! Threshold for fact. 1 ILU(T) call psb_bcast(icontxt,prec%cthres) ! Threshold for fact. 1 ILU(T)
call psb_bcast(icontxt,prec%cjswp) ! Jacobi sweeps call psb_bcast(icontxt,prec%cjswp) ! Jacobi sweeps
call psb_bcast(icontxt,prec%omega) ! smoother omega call psb_bcast(icontxt,prec%omega) ! smoother omega
call psb_bcast(icontxt,prec%athres) ! smoother aggr thresh
end if end if
end subroutine get_parms end subroutine get_parms

1
test/fileread/df_bench.f90
Unescape Escape View File

@ -29,6 +29,7 @@ program df_bench
real(psb_dpk_) :: thr2 ! Threshold for fact. 1 ILU(T) real(psb_dpk_) :: thr2 ! Threshold for fact. 1 ILU(T)
integer :: jswp ! Jacobi sweeps integer :: jswp ! Jacobi sweeps
real(psb_dpk_) :: omega ! smoother omega real(psb_dpk_) :: omega ! smoother omega
real(psb_dpk_) :: athres ! smoother aggregation
character(len=40) :: descr ! verbose description of the prec character(len=40) :: descr ! verbose description of the prec
end type precdata end type precdata
type(precdata), allocatable :: precs(:) type(precdata), allocatable :: precs(:)

5
test/fileread/df_sample.f90
Unescape Escape View File

@ -67,6 +67,7 @@ program df_sample
real(psb_dpk_) :: cthres ! Threshold for fact. 1 ILU(T) real(psb_dpk_) :: cthres ! Threshold for fact. 1 ILU(T)
integer :: cjswp ! Jacobi sweeps integer :: cjswp ! Jacobi sweeps
real(psb_dpk_) :: omega ! smoother omega real(psb_dpk_) :: omega ! smoother omega
real(psb_dpk_) :: athres ! smoother aggregation threshold
end type precdata end type precdata
type(precdata) :: prec_choice type(precdata) :: prec_choice
@ -242,7 +243,7 @@ program df_sample
call mld_precset(prec,mld_coarse_solve_,prec_choice%csolve,info) call mld_precset(prec,mld_coarse_solve_,prec_choice%csolve,info)
call mld_precset(prec,mld_sub_fill_in_,prec_choice%cfill,info,ilev=nlv) call mld_precset(prec,mld_sub_fill_in_,prec_choice%cfill,info,ilev=nlv)
call mld_precset(prec,mld_fact_thrs_,prec_choice%cthres,info,ilev=nlv) call mld_precset(prec,mld_fact_thrs_,prec_choice%cthres,info,ilev=nlv)
call mld_precset(prec,mld_smooth_sweeps_,prec_choice%cjswp,info,ilev=nlv) call mld_precset(prec,mld_aggr_thresh_,prec_choice%athres,info)
call mld_precset(prec,mld_smooth_sweeps_,prec_choice%cjswp,info,ilev=nlv) call mld_precset(prec,mld_smooth_sweeps_,prec_choice%cjswp,info,ilev=nlv)
if (prec_choice%omega>=0.0) then if (prec_choice%omega>=0.0) then
call mld_precset(prec,mld_aggr_damp_,prec_choice%omega,info,ilev=nlv) call mld_precset(prec,mld_aggr_damp_,prec_choice%omega,info,ilev=nlv)
@ -392,6 +393,7 @@ contains
call read_data(prec%cthres,5) ! Threshold for fact. 1 ILU(T) call read_data(prec%cthres,5) ! Threshold for fact. 1 ILU(T)
call read_data(prec%cjswp,5) ! Jacobi sweeps call read_data(prec%cjswp,5) ! Jacobi sweeps
call read_data(prec%omega,5) ! smoother omega call read_data(prec%omega,5) ! smoother omega
call read_data(prec%athres,5) ! smoother aggr thresh
end if end if
end if end if
@ -426,6 +428,7 @@ contains
call psb_bcast(icontxt,prec%cthres) ! Threshold for fact. 1 ILU(T) call psb_bcast(icontxt,prec%cthres) ! Threshold for fact. 1 ILU(T)
call psb_bcast(icontxt,prec%cjswp) ! Jacobi sweeps call psb_bcast(icontxt,prec%cjswp) ! Jacobi sweeps
call psb_bcast(icontxt,prec%omega) ! smoother omega call psb_bcast(icontxt,prec%omega) ! smoother omega
call psb_bcast(icontxt,prec%athres) ! smoother aggr thresh
end if end if
end subroutine get_parms end subroutine get_parms

1
test/fileread/runs/cfs.inp
Unescape Escape View File

@ -27,3 +27,4 @@ ILU ! Coarse level: solver ILU ILUT UMF SLU SLUDIST
1.d-4 ! Coarse level: Threshold T for ILU(T,P) 1.d-4 ! Coarse level: Threshold T for ILU(T,P)
4 ! Coarse level: Number of Jacobi sweeps 4 ! Coarse level: Number of Jacobi sweeps
-1.0d0 ! Smoother Omega: if < 0 means library choice. -1.0d0 ! Smoother Omega: if < 0 means library choice.
0.01d0 ! Smoother Aggregation Threshold: >= 0.0

5
test/fileread/runs/dfs.inp
Unescape Escape View File

@ -1,5 +1,5 @@
thm1000x600.mtx ! les_t4.mtx ! young1r.mtx This (and others) from: http://math.nist.gov/MatrixMarket/ or matphi_140x33x45.mtx !A_1M_gps.mtx !thm1000x600.mtx ! les_t4.mtx ! young1r.mtx This (and others) from: http://math.nist.gov/MatrixMarket/ or
NONE !les_t4.rhs ! rhs.mtx http://www.cise.ufl.edu/research/sparse/matrices/index.html tnoto_phi.mtx !NONE !les_t4.rhs ! rhs.mtx http://www.cise.ufl.edu/research/sparse/matrices/index.html
BICGSTAB ! Iterative method: BiCGSTAB BiCG CGS RGMRES BiCGSTABL CG BICGSTAB ! Iterative method: BiCGSTAB BiCG CGS RGMRES BiCGSTABL CG
CSR ! Storage format CSR COO JAD CSR ! Storage format CSR COO JAD
0 ! IPART: Partition method 0: BLK 2: graph (with Metis) 0 ! IPART: Partition method 0: BLK 2: graph (with Metis)
@ -27,3 +27,4 @@ ILU ! Coarse level: solver ILU ILUT UMF SLU SLUDIST
1.d-4 ! Coarse level: Threshold T for ILU(T,P) 1.d-4 ! Coarse level: Threshold T for ILU(T,P)
4 ! Coarse level: Number of Jacobi sweeps 4 ! Coarse level: Number of Jacobi sweeps
-1.0d0 ! Smoother Omega: if < 0 means library choice. -1.0d0 ! Smoother Omega: if < 0 means library choice.
0.01d0 ! Smoother Aggregation Threshold: >= 0.0

2
test/fileread/runs/drt.sh
Unescape Escape View File

@ -16,7 +16,7 @@ do
# 3rd batch: 14bis,64bis 4 sweeps # 3rd batch: 14bis,64bis 4 sweeps
echo "mpirun -np $np -machinefile locm df_bench >>log.part$part.ren$renum.${np}p" echo "mpirun -np $np -machinefile locm df_bench >>log.part$part.ren$renum.${np}p"
#/usr/local/mpich-gcc42/bin/mpirun -np $np -machinefile locm df_bench <<EOF #/usr/local/mpich-gcc42/bin/mpirun -np $np -machinefile locm df_bench <<EOF
/usr/local/mpich-gcc42/bin/mpirun -np $np -machinefile locm df_bench >>run.gfc.kiva.log.${np}p.$date 2>err.gfc.kiva.log.${np}p.$date <<EOF mpirun -np $np -machinefile locm df_bench >>run.gfc.kiva.log.${np}p.$date 2>err.gfc.kiva.log.${np}p.$date <<EOF
out.${np}p.$date Out file 1: summary out.${np}p.$date Out file 1: summary
stat.${np}p.$date Out file 2: detailed for statistics stat.${np}p.$date Out file 2: detailed for statistics
BICGSTAB iterative method to use BICGSTAB iterative method to use

1
test/fileread/runs/sfs.inp
Unescape Escape View File

@ -27,3 +27,4 @@ ILU ! Coarse level: solver ILU ILUT UMF SLU SLUDIST
1.d-4 ! Coarse level: Threshold T for ILU(T,P) 1.d-4 ! Coarse level: Threshold T for ILU(T,P)
4 ! Coarse level: Number of Jacobi sweeps 4 ! Coarse level: Number of Jacobi sweeps
-1.0d0 ! Smoother Omega: if < 0 means library choice. -1.0d0 ! Smoother Omega: if < 0 means library choice.
0.01d0 ! Smoother Aggregation Threshold: >= 0.0

1
test/fileread/runs/zfs.inp
Unescape Escape View File

@ -27,3 +27,4 @@ ILU ! Coarse level: solver ILU ILUT UMF SLU SLUDIST
1.d-4 ! Coarse level: Threshold T for ILU(T,P) 1.d-4 ! Coarse level: Threshold T for ILU(T,P)
4 ! Coarse level: Number of Jacobi sweeps 4 ! Coarse level: Number of Jacobi sweeps
-1.0d0 ! Smoother Omega: if < 0 means library choice. -1.0d0 ! Smoother Omega: if < 0 means library choice.
0.01d0 ! Smoother Aggregation Threshold: >= 0.0

5
test/fileread/sf_sample.f90
Unescape Escape View File

@ -67,6 +67,7 @@ program sf_sample
real(psb_spk_) :: cthres ! Threshold for fact. 1 ILU(T) real(psb_spk_) :: cthres ! Threshold for fact. 1 ILU(T)
integer :: cjswp ! Jacobi sweeps integer :: cjswp ! Jacobi sweeps
real(psb_spk_) :: omega ! smoother omega real(psb_spk_) :: omega ! smoother omega
real(psb_spk_) :: athres ! smoother aggregation threshold
end type precdata end type precdata
type(precdata) :: prec_choice type(precdata) :: prec_choice
@ -242,7 +243,7 @@ program sf_sample
call mld_precset(prec,mld_coarse_solve_,prec_choice%csolve,info) call mld_precset(prec,mld_coarse_solve_,prec_choice%csolve,info)
call mld_precset(prec,mld_sub_fill_in_,prec_choice%cfill,info,ilev=nlv) call mld_precset(prec,mld_sub_fill_in_,prec_choice%cfill,info,ilev=nlv)
call mld_precset(prec,mld_fact_thrs_,prec_choice%cthres,info,ilev=nlv) call mld_precset(prec,mld_fact_thrs_,prec_choice%cthres,info,ilev=nlv)
call mld_precset(prec,mld_smooth_sweeps_,prec_choice%cjswp,info,ilev=nlv) call mld_precset(prec,mld_aggr_thresh_,prec_choice%athres,info)
call mld_precset(prec,mld_smooth_sweeps_,prec_choice%cjswp,info,ilev=nlv) call mld_precset(prec,mld_smooth_sweeps_,prec_choice%cjswp,info,ilev=nlv)
if (prec_choice%omega>=0.0) then if (prec_choice%omega>=0.0) then
call mld_precset(prec,mld_aggr_damp_,prec_choice%omega,info,ilev=nlv) call mld_precset(prec,mld_aggr_damp_,prec_choice%omega,info,ilev=nlv)
@ -392,6 +393,7 @@ contains
call read_data(prec%cthres,5) ! Threshold for fact. 1 ILU(T) call read_data(prec%cthres,5) ! Threshold for fact. 1 ILU(T)
call read_data(prec%cjswp,5) ! Jacobi sweeps call read_data(prec%cjswp,5) ! Jacobi sweeps
call read_data(prec%omega,5) ! smoother omega call read_data(prec%omega,5) ! smoother omega
call read_data(prec%athres,5) ! smoother aggr thresh
end if end if
end if end if
@ -426,6 +428,7 @@ contains
call psb_bcast(icontxt,prec%cthres) ! Threshold for fact. 1 ILU(T) call psb_bcast(icontxt,prec%cthres) ! Threshold for fact. 1 ILU(T)
call psb_bcast(icontxt,prec%cjswp) ! Jacobi sweeps call psb_bcast(icontxt,prec%cjswp) ! Jacobi sweeps
call psb_bcast(icontxt,prec%omega) ! smoother omega call psb_bcast(icontxt,prec%omega) ! smoother omega
call psb_bcast(icontxt,prec%athres) ! smoother aggr thresh
end if end if
end subroutine get_parms end subroutine get_parms

5
test/fileread/zf_sample.f90
Unescape Escape View File

@ -67,6 +67,7 @@ program zf_sample
real(psb_dpk_) :: cthres ! Threshold for fact. 1 ILU(T) real(psb_dpk_) :: cthres ! Threshold for fact. 1 ILU(T)
integer :: cjswp ! Jacobi sweeps integer :: cjswp ! Jacobi sweeps
real(psb_dpk_) :: omega ! smoother omega real(psb_dpk_) :: omega ! smoother omega
real(psb_dpk_) :: athres ! smoother aggregation threshold
end type precdata end type precdata
type(precdata) :: prec_choice type(precdata) :: prec_choice
@ -242,7 +243,7 @@ program zf_sample
call mld_precset(prec,mld_coarse_solve_,prec_choice%csolve,info) call mld_precset(prec,mld_coarse_solve_,prec_choice%csolve,info)
call mld_precset(prec,mld_sub_fill_in_,prec_choice%cfill,info,ilev=nlv) call mld_precset(prec,mld_sub_fill_in_,prec_choice%cfill,info,ilev=nlv)
call mld_precset(prec,mld_fact_thrs_,prec_choice%cthres,info,ilev=nlv) call mld_precset(prec,mld_fact_thrs_,prec_choice%cthres,info,ilev=nlv)
call mld_precset(prec,mld_smooth_sweeps_,prec_choice%cjswp,info,ilev=nlv) call mld_precset(prec,mld_aggr_thresh_,prec_choice%athres,info)
call mld_precset(prec,mld_smooth_sweeps_,prec_choice%cjswp,info,ilev=nlv) call mld_precset(prec,mld_smooth_sweeps_,prec_choice%cjswp,info,ilev=nlv)
if (prec_choice%omega>=0.0) then if (prec_choice%omega>=0.0) then
call mld_precset(prec,mld_aggr_damp_,prec_choice%omega,info,ilev=nlv) call mld_precset(prec,mld_aggr_damp_,prec_choice%omega,info,ilev=nlv)
@ -392,6 +393,7 @@ contains
call read_data(prec%cthres,5) ! Threshold for fact. 1 ILU(T) call read_data(prec%cthres,5) ! Threshold for fact. 1 ILU(T)
call read_data(prec%cjswp,5) ! Jacobi sweeps call read_data(prec%cjswp,5) ! Jacobi sweeps
call read_data(prec%omega,5) ! smoother omega call read_data(prec%omega,5) ! smoother omega
call read_data(prec%athres,5) ! smoother aggr thresh
end if end if
end if end if
@ -426,6 +428,7 @@ contains
call psb_bcast(icontxt,prec%cthres) ! Threshold for fact. 1 ILU(T) call psb_bcast(icontxt,prec%cthres) ! Threshold for fact. 1 ILU(T)
call psb_bcast(icontxt,prec%cjswp) ! Jacobi sweeps call psb_bcast(icontxt,prec%cjswp) ! Jacobi sweeps
call psb_bcast(icontxt,prec%omega) ! smoother omega call psb_bcast(icontxt,prec%omega) ! smoother omega
call psb_bcast(icontxt,prec%athres) ! smoother aggr thresh
end if end if
end subroutine get_parms end subroutine get_parms

Write Preview
Loading…
Cancel
Save