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

Merged internal docs and html headers.

Browse Source
stopcriterion
Salvatore Filippone 17 years ago
parent d8a4ceb5a5
commit 2272f944be
47 changed files with 1468 additions and 1936 deletions
Show Stats Download Patch File Download Diff File

2
Changelog
Unescape Escape View File

@ -1,6 +1,8 @@
Changelog. A lot less detailed than usual, at least for past Changelog. A lot less detailed than usual, at least for past
history. history.
2007/12/21: Merge version with prologues and internal docs.
2007/11/15: Created pargen example. 2007/11/15: Created pargen example.
2007/11/14: Fix INTENT(IN) on X vector in preconditioner routines. 2007/11/14: Fix INTENT(IN) on X vector in preconditioner routines.

117
mlprec/mld_daggrmap_bld.f90
Unescape Escape View File

@ -41,7 +41,7 @@
! !
! This routine builds a mapping from the row indices of the fine-level matrix ! This routine builds a mapping from the row indices of the fine-level matrix
! to the row indices of the coarse-level matrix, according to a decoupled ! to the row indices of the coarse-level matrix, according to a decoupled
! aggregation algorithm. This mapping will be used by mld_daggrmat_asb to ! aggregation algorithm. This mapping will be used by mld_aggrmat_asb to
! build the coarse-level matrix. ! build the coarse-level matrix.
! !
! The aggregation algorithm is a parallel version of that described in ! The aggregation algorithm is a parallel version of that described in
@ -79,29 +79,30 @@ subroutine mld_daggrmap_bld(aggr_type,a,desc_a,nlaggr,ilaggr,info)
implicit none implicit none
! Arguments ! Arguments
integer, intent(in) :: aggr_type integer, intent(in) :: aggr_type
type(psb_dspmat_type), intent(in), target :: a type(psb_dspmat_type), intent(in), target :: 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
! 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), target :: atmp, atrans
type(psb_dspmat_type), pointer :: apnt type(psb_dspmat_type), pointer :: apnt
logical :: recovery logical :: recovery
logical, parameter :: debug=.false. integer :: debug_level, debug_unit
integer :: ictxt,np,me,err_act integer :: ictxt,np,me,err_act
integer :: nrow, ncol, n_ne integer :: nrow, ncol, n_ne
integer, parameter :: one=1, two=2
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 = 'mld_aggrmap_bld' name = 'mld_aggrmap_bld'
call psb_erractionsave(err_act) 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 ! Note. At the time being we are ignoring aggr_type so
! that we only have decoupled aggregation. This might ! that we only have decoupled aggregation. This might
@ -115,10 +116,9 @@ subroutine mld_daggrmap_bld(aggr_type,a,desc_a,nlaggr,ilaggr,info)
select case (aggr_type) select case (aggr_type)
case (mld_dec_aggr_,mld_sym_dec_aggr_) case (mld_dec_aggr_,mld_sym_dec_aggr_)
nr = a%m nr = a%m
allocate(ilaggr(nr),neigh(nr),stat=info) allocate(ilaggr(nr),neigh(nr),stat=info)
if(info.ne.0) then if(info /= 0) then
info=4025 info=4025
call psb_errpush(info,name,i_err=(/2*nr,0,0,0,0/),& call psb_errpush(info,name,i_err=(/2*nr,0,0,0,0/),&
& a_err='integer') & a_err='integer')
@ -135,18 +135,23 @@ subroutine mld_daggrmap_bld(aggr_type,a,desc_a,nlaggr,ilaggr,info)
& rscale=.false.,cscale=.false.) & rscale=.false.,cscale=.false.)
atmp%m=nr atmp%m=nr
atmp%k=nr atmp%k=nr
call psb_transp(atmp,atrans,fmt='COO') if (info == 0) call psb_transp(atmp,atrans,fmt='COO')
call psb_rwextd(nr,atmp,info,b=atrans,rowscale=.false.) if (info == 0) call psb_rwextd(nr,atmp,info,b=atrans,rowscale=.false.)
atmp%m=nr atmp%m=nr
atmp%k=nr atmp%k=nr
call psb_sp_free(atrans,info) if (info == 0) call psb_sp_free(atrans,info)
call psb_ipcoo2csr(atmp,info) if (info == 0) call psb_ipcoo2csr(atmp,info)
apnt => atmp apnt => atmp
if (info/=0) then
info=4001
call psb_errpush(info,name,a_err='init apnt')
goto 9999
end if end if
! end if
! Meaning of variables in the loops beloc
! -(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
@ -168,11 +173,10 @@ subroutine mld_daggrmap_bld(aggr_type,a,desc_a,nlaggr,ilaggr,info)
naggr = naggr + 1 naggr = naggr + 1
ilaggr(i) = naggr ilaggr(i) = naggr
call psb_neigh(apnt,i,neigh,n_ne,info,lev=one) call psb_neigh(apnt,i,neigh,n_ne,info,lev=1)
if (info/=0) then if (info/=0) then
info=4010 info=4010
ch_err='psb_neigh' call psb_errpush(info,name,a_err='psb_neigh')
call psb_errpush(info,name,a_err=ch_err)
goto 9999 goto 9999
end if end if
do k=1, n_ne do k=1, n_ne
@ -184,11 +188,10 @@ subroutine mld_daggrmap_bld(aggr_type,a,desc_a,nlaggr,ilaggr,info)
! !
! 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=two) call psb_neigh(apnt,i,neigh,n_ne,info,lev=2)
if (info/=0) then if (info/=0) then
info=4010 info=4010
ch_err='psb_neigh' call psb_errpush(info,name,a_err='psb_neigh')
call psb_errpush(info,name,a_err=ch_err)
goto 9999 goto 9999
end if end if
@ -203,15 +206,17 @@ subroutine mld_daggrmap_bld(aggr_type,a,desc_a,nlaggr,ilaggr,info)
nlp = nlp + 1 nlp = nlp + 1
if (icnt == 0) exit if (icnt == 0) exit
enddo enddo
if (debug) then if (debug_level >= psb_debug_outer_) then
write(0,*) 'Check 1:',count(ilaggr == -(nr+1)),(a%ia1(i),i=a%ia2(1),a%ia2(2)-1) write(debug_unit,*) me,' ',trim(name),&
& ' Check 1:',count(ilaggr == -(nr+1)),&
& (a%ia1(i),i=a%ia2(1),a%ia2(2)-1)
end if end if
! !
! Phase two: sweep over leftovers. ! Phase two: sweep over leftovers.
! !
allocate(ils(naggr+10),stat=info) allocate(ils(naggr+10),stat=info)
if(info.ne.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/),&
& a_err='integer') & a_err='integer')
@ -225,16 +230,20 @@ subroutine mld_daggrmap_bld(aggr_type,a,desc_a,nlaggr,ilaggr,info)
n = ilaggr(i) n = ilaggr(i)
if (n>0) then if (n>0) then
if (n>naggr) then if (n>naggr) then
write(0,*) 'loc_Aggregate: n > naggr 1 ? ',n,naggr info=4001
call psb_errpush(info,name,a_err='loc_Aggregate: n > naggr 1 ?')
goto 9999
else else
ils(n) = ils(n) + 1 ils(n) = ils(n) + 1
end if end if
end if end if
end do end do
if (debug) then if (debug_level >= psb_debug_outer_) then
write(0,*) 'Phase 1: number of aggregates ',naggr write(debug_unit,*) me,' ',trim(name),&
write(0,*) 'Phase 1: nodes aggregated ',sum(ils) & 'Phase 1: number of aggregates ',naggr
write(debug_unit,*) me,' ',trim(name),&
& 'Phase 1: nodes aggregated ',sum(ils)
end if end if
recovery=.false. recovery=.false.
@ -247,11 +256,10 @@ subroutine mld_daggrmap_bld(aggr_type,a,desc_a,nlaggr,ilaggr,info)
isz = nr+1 isz = nr+1
ia = -1 ia = -1
call psb_neigh(apnt,i,neigh,n_ne,info,lev=one) call psb_neigh(apnt,i,neigh,n_ne,info,lev=1)
if (info/=0) then if (info/=0) then
info=4010 info=4010
ch_err='psb_neigh' call psb_errpush(info,name,a_err='psb_neigh')
call psb_errpush(info,name,a_err=ch_err)
goto 9999 goto 9999
end if end if
@ -261,7 +269,9 @@ subroutine mld_daggrmap_bld(aggr_type,a,desc_a,nlaggr,ilaggr,info)
n = ilaggr(k) n = ilaggr(k)
if (n>0) then if (n>0) then
if (n>naggr) then if (n>naggr) then
write(0,*) 'loc_Aggregate: n > naggr 2? ',n,naggr info=4001
call psb_errpush(info,name,a_err='loc_Aggregate: n > naggr 2 ?')
goto 9999
end if end if
if (ils(n) < isz) then if (ils(n) < isz) then
@ -275,7 +285,9 @@ subroutine mld_daggrmap_bld(aggr_type,a,desc_a,nlaggr,ilaggr,info)
if (ilaggr(i) > -(nr+1)) then if (ilaggr(i) > -(nr+1)) then
ilaggr(i) = abs(ilaggr(i)) ilaggr(i) = abs(ilaggr(i))
if (ilaggr(I)>naggr) then if (ilaggr(I)>naggr) then
write(0,*) 'loc_Aggregate: n > naggr 3? ',ilaggr(i),naggr info=4001
call psb_errpush(info,name,a_err='loc_Aggregate: n > naggr 3 ?')
goto 9999
end if end if
ils(ilaggr(i)) = ils(ilaggr(i)) + 1 ils(ilaggr(i)) = ils(ilaggr(i)) + 1
! !
@ -284,35 +296,44 @@ subroutine mld_daggrmap_bld(aggr_type,a,desc_a,nlaggr,ilaggr,info)
! !
recovery = .true. recovery = .true.
else else
write(0,*) 'Unrecoverable error !!',ilaggr(i), nr info=4001
call psb_errpush(info,name,a_err='Unrecoverable error !!')
goto 9999
endif endif
else else
ilaggr(i) = ia ilaggr(i) = ia
if (ia>naggr) then if (ia>naggr) then
write(0,*) 'loc_Aggregate: n > naggr 4? ',ia,naggr info=4001
call psb_errpush(info,name,a_err='loc_Aggregate: n > naggr 4? ')
goto 9999
end if end if
ils(ia) = ils(ia) + 1 ils(ia) = ils(ia) + 1
endif endif
end if end if
enddo enddo
if (debug_level >= psb_debug_outer_) then
if (recovery) then if (recovery) then
write(0,*) 'Had to recover from strange situation in loc_aggregate.' write(debug_unit,*) me,' ',trim(name),&
write(0,*) 'Perhaps an unsymmetric pattern?' & 'Had to recover from strange situation in loc_aggregate.'
write(debug_unit,*) me,' ',trim(name),&
& 'Perhaps an unsymmetric pattern?'
endif endif
if (debug) then write(debug_unit,*) me,' ',trim(name),&
write(0,*) 'Phase 2: number of aggregates ',naggr & 'Phase 2: number of aggregates ',naggr,sum(ils)
write(0,*) 'Phase 2: nodes aggregated ',sum(ils)
do i=1, naggr do i=1, naggr
write(*,*) 'Size of aggregate ',i,' :',count(ilaggr==i), ils(i) write(debug_unit,*) me,' ',trim(name),&
& 'Size of aggregate ',i,' :',count(ilaggr==i), ils(i)
enddo enddo
write(*,*) maxval(ils(1:naggr)) write(debug_unit,*) me,' ',trim(name),&
write(*,*) 'Leftovers ',count(ilaggr<0), ' in ',nlp,' loops' & maxval(ils(1:naggr))
write(debug_unit,*) me,' ',trim(name),&
& 'Leftovers ',count(ilaggr<0), ' in ',nlp,' loops'
end if end if
!!$ write(0,*) 'desc_a loc_aggr 4 : ', desc_a%matrix_data(m_)
if (count(ilaggr<0) >0) then if (count(ilaggr<0) >0) then
write(0,*) 'Fatal error: some leftovers!!!' info=4001
call psb_errpush(info,name,a_err='Fatal error: some leftovers')
goto 9999
endif endif
deallocate(ils,neigh,stat=info) deallocate(ils,neigh,stat=info)
@ -322,9 +343,6 @@ subroutine mld_daggrmap_bld(aggr_type,a,desc_a,nlaggr,ilaggr,info)
goto 9999 goto 9999
end if end if
if (nrow /= size(ilaggr)) then
write(0,*) 'SOmething wrong ilaggr ',nrow,size(ilaggr)
endif
call psb_realloc(ncol,ilaggr,info) call psb_realloc(ncol,ilaggr,info)
if (info/=0) then if (info/=0) then
info=4010 info=4010
@ -351,7 +369,6 @@ subroutine mld_daggrmap_bld(aggr_type,a,desc_a,nlaggr,ilaggr,info)
case default case default
write(0,*) 'Unimplemented aggregation algorithm ',aggr_type
info = -1 info = -1
call psb_errpush(30,name,i_err=(/1,aggr_type,0,0,0/)) call psb_errpush(30,name,i_err=(/1,aggr_type,0,0,0/))
goto 9999 goto 9999

15
mlprec/mld_daggrmat_asb.f90
Unescape Escape View File

@ -107,7 +107,6 @@ subroutine mld_daggrmat_asb(a,desc_a,ac,desc_ac,p,info)
integer, intent(out) :: info integer, intent(out) :: info
! Local variables ! Local variables
logical, parameter :: aggr_dump=.false.
integer ::ictxt,np,me, err_act, icomm integer ::ictxt,np,me, err_act, icomm
character(len=20) :: name character(len=20) :: name
@ -125,24 +124,22 @@ subroutine mld_daggrmat_asb(a,desc_a,ac,desc_ac,p,info)
case (mld_no_smooth_) case (mld_no_smooth_)
call mld_aggrmat_raw_asb(a,desc_a,ac,desc_ac,p,info) call mld_aggrmat_raw_asb(a,desc_a,ac,desc_ac,p,info)
if(info /= 0) then if(info /= 0) then
call psb_errpush(4010,name,a_err='raw_aggregate') call psb_errpush(4010,name,a_err='mld_aggrmat_raw_asb')
goto 9999 goto 9999
end if end if
if (aggr_dump) call psb_csprt(90+me,ac,head='% Raw aggregate.')
case(mld_smooth_prol_,mld_biz_prol_) case(mld_smooth_prol_,mld_biz_prol_)
if (aggr_dump) call psb_csprt(70+me,a,head='% Input matrix')
call mld_aggrmat_smth_asb(a,desc_a,ac,desc_ac,p,info)
call mld_aggrmat_smth_asb(a,desc_a,ac,desc_ac,p,info)
if(info /= 0) then if(info /= 0) then
call psb_errpush(4010,name,a_err='smooth_aggregate') call psb_errpush(4010,name,a_err='mld_aggrmat_smth_asb')
goto 9999 goto 9999
end if end if
if (aggr_dump) call psb_csprt(90+me,ac,head='% Smooth aggregate.')
case default case default
call psb_errpush(4010,name,a_err=name)
call psb_errpush(4001,name,a_err='Invalid aggr kind')
goto 9999 goto 9999
end select end select

23
mlprec/mld_daggrmat_raw_asb.F90
Unescape Escape View File

@ -95,7 +95,6 @@ subroutine mld_daggrmat_raw_asb(a,desc_a,ac,desc_ac,p,info)
integer, intent(out) :: info integer, intent(out) :: info
! Local variables ! Local variables
logical, parameter :: aggr_dump=.false.
integer ::ictxt,np,me, err_act, icomm integer ::ictxt,np,me, err_act, icomm
character(len=20) :: name character(len=20) :: name
type(psb_dspmat_type) :: b type(psb_dspmat_type) :: b
@ -202,7 +201,7 @@ subroutine mld_daggrmat_raw_asb(a,desc_a,ac,desc_ac,p,info)
ac%k = ntaggr ac%k = ntaggr
ac%infoa(psb_nnz_) = nzac ac%infoa(psb_nnz_) = nzac
ac%fida='COO' ac%fida='COO'
ac%descra='G' ac%descra='GUN'
call psb_spcnv(ac,info,afmt='coo',dupl=psb_dupl_add_) call psb_spcnv(ac,info,afmt='coo',dupl=psb_dupl_add_)
if(info /= 0) then if(info /= 0) then
call psb_errpush(4010,name,a_err='sp_free') call psb_errpush(4010,name,a_err='sp_free')
@ -212,19 +211,10 @@ subroutine mld_daggrmat_raw_asb(a,desc_a,ac,desc_ac,p,info)
else if (p%iprcparm(mld_coarse_mat_) == mld_distr_mat_) then else if (p%iprcparm(mld_coarse_mat_) == mld_distr_mat_) then
call psb_cdall(ictxt,desc_ac,info,nl=naggr) call psb_cdall(ictxt,desc_ac,info,nl=naggr)
if (info == 0) call psb_cdasb(desc_ac,info)
if (info == 0) call psb_sp_clone(b,ac,info)
if(info /= 0) then if(info /= 0) then
call psb_errpush(4010,name,a_err='psb_cdall') call psb_errpush(4001,name,a_err='Build ac, desc_ac')
goto 9999
end if
call psb_cdasb(desc_ac,info)
if(info /= 0) then
call psb_errpush(4010,name,a_err='psb_cdasb')
goto 9999
end if
call psb_sp_clone(b,ac,info)
if(info /= 0) then
call psb_errpush(4010,name,a_err='spclone')
goto 9999 goto 9999
end if end if
call psb_sp_free(b,info) call psb_sp_free(b,info)
@ -234,8 +224,9 @@ subroutine mld_daggrmat_raw_asb(a,desc_a,ac,desc_ac,p,info)
end if end if
else else
info = 4001
write(0,*) 'Unknown p%iprcparm(coarse_mat) in aggregate_sp',p%iprcparm(mld_coarse_mat_) call psb_errpush(4001,name,a_err='invalid mld_coarse_mat_')
goto 9999
end if end if
deallocate(nzbr,idisp) deallocate(nzbr,idisp)

353
mlprec/mld_daggrmat_smth_asb.F90
Unescape Escape View File

@ -117,14 +117,15 @@ subroutine mld_daggrmat_smth_asb(a,desc_a,ac,desc_ac,p,info)
integer, pointer :: nzbr(:), idisp(:) integer, pointer :: nzbr(:), idisp(:)
integer :: nrow, nglob, ncol, ntaggr, nzac, ip, ndx,& integer :: nrow, nglob, ncol, ntaggr, nzac, ip, ndx,&
& naggr, nzl,naggrm1,naggrp1, i, j, k & naggr, nzl,naggrm1,naggrp1, i, j, k
logical, parameter :: aggr_dump=.false.
integer ::ictxt,np,me, err_act, icomm integer ::ictxt,np,me, err_act, icomm
character(len=20) :: name character(len=20) :: name
type(psb_dspmat_type), pointer :: am1,am2 type(psb_dspmat_type), pointer :: am1,am2
type(psb_dspmat_type) :: am3,am4 type(psb_dspmat_type) :: am3,am4
logical :: ml_global_nmb logical :: ml_global_nmb
integer :: nz
logical, parameter :: test_dump=.false.,debug=.false. integer, allocatable :: ia(:), ja(:)
real(kind(1.d0)), allocatable :: val(:)
integer :: debug_level, debug_unit
integer, parameter :: ncmax=16 integer, parameter :: ncmax=16
real(kind(1.d0)) :: omega, anorm, tmp, dg real(kind(1.d0)) :: omega, anorm, tmp, dg
@ -132,10 +133,12 @@ subroutine mld_daggrmat_smth_asb(a,desc_a,ac,desc_ac,p,info)
if(psb_get_errstatus().ne.0) return if(psb_get_errstatus().ne.0) return
info=0 info=0
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
debug_unit = psb_get_debug_unit()
debug_level = psb_get_debug_level()
ictxt = psb_cd_get_context(desc_a) ictxt = psb_cd_get_context(desc_a)
icomm = psb_cd_get_mpic(desc_a) icomm = psb_cd_get_mpic(desc_a)
ictxt=psb_cd_get_context(desc_a) ictxt = psb_cd_get_context(desc_a)
call psb_info(ictxt, me, np) call psb_info(ictxt, me, np)
@ -164,38 +167,27 @@ subroutine mld_daggrmat_smth_asb(a,desc_a,ac,desc_ac,p,info)
goto 9999 goto 9999
end if end if
naggrm1 = sum(p%nlaggr(1:me)) naggrm1 = sum(p%nlaggr(1:me))
naggrp1 = sum(p%nlaggr(1:me+1)) naggrp1 = sum(p%nlaggr(1:me+1))
ml_global_nmb = ( (p%iprcparm(mld_aggr_kind_) == mld_smooth_prol_).or.& ml_global_nmb = ( (p%iprcparm(mld_aggr_kind_) == mld_smooth_prol_).or.&
& ( (p%iprcparm(mld_aggr_kind_) == mld_biz_prol_).and.& & ( (p%iprcparm(mld_aggr_kind_) == mld_biz_prol_).and.&
& (p%iprcparm(mld_coarse_mat_) == mld_repl_mat_)) ) & (p%iprcparm(mld_coarse_mat_) == mld_repl_mat_)) )
if (ml_global_nmb) then if (ml_global_nmb) then
p%mlia(1:nrow) = p%mlia(1:nrow) + naggrm1 p%mlia(1:nrow) = p%mlia(1:nrow) + naggrm1
call psb_halo(p%mlia,desc_a,info) call psb_halo(p%mlia,desc_a,info)
if(info /= 0) then if (info /= 0) then
call psb_errpush(4010,name,a_err='psb_halo') call psb_errpush(4010,name,a_err='psb_halo')
goto 9999 goto 9999
end if end if
end if end if
if (aggr_dump) then
open(30+me)
write(30+me,*) '% Aggregation map'
do i=1,ncol
write(30+me,*) i,p%mlia(i)
end do
close(30+me)
end if
! naggr: number of local aggregates ! naggr: number of local aggregates
! nrow: local rows. ! nrow: local rows.
! !
allocate(p%dorig(nrow),stat=info) allocate(p%dorig(nrow),stat=info)
if (info /= 0) then if (info /= 0) then
info=4025 info=4025
call psb_errpush(info,name,i_err=(/nrow,0,0,0,0/),& call psb_errpush(info,name,i_err=(/nrow,0,0,0,0/),&
@ -218,13 +210,6 @@ subroutine mld_daggrmat_smth_asb(a,desc_a,ac,desc_ac,p,info)
end if end if
end do end do
! where (p%dorig /= dzero)
! p%dorig = done / p%dorig
! elsewhere
! p%dorig = done
! end where
! 1. Allocate Ptilde in sparse matrix form ! 1. Allocate Ptilde in sparse matrix form
am4%fida='COO' am4%fida='COO'
am4%m=ncol am4%m=ncol
@ -235,7 +220,8 @@ subroutine mld_daggrmat_smth_asb(a,desc_a,ac,desc_ac,p,info)
am4%k=naggr am4%k=naggr
call psb_sp_all(ncol,naggr,am4,ncol,info) call psb_sp_all(ncol,naggr,am4,ncol,info)
endif endif
if(info /= 0) then
if (info /= 0) then
call psb_errpush(4010,name,a_err='spall') call psb_errpush(4010,name,a_err='spall')
goto 9999 goto 9999
end if end if
@ -258,16 +244,14 @@ subroutine mld_daggrmat_smth_asb(a,desc_a,ac,desc_ac,p,info)
call psb_spcnv(am4,info,afmt='csr',dupl=psb_dupl_add_) call psb_spcnv(am4,info,afmt='csr',dupl=psb_dupl_add_)
if(info /= 0) then if (info==0) call psb_spcnv(a,am3,info,afmt='csr')
if (info /= 0) then
call psb_errpush(4010,name,a_err='spcnv') call psb_errpush(4010,name,a_err='spcnv')
goto 9999 goto 9999
end if end if
if (debug_level >= psb_debug_outer_) &
call psb_sp_clone(a,am3,info) & write(debug_unit,*) me,' ',trim(name),&
if(info /= 0) then & ' Initial copies done.'
call psb_errpush(4010,name,a_err='spclone')
goto 9999
end if
! !
! WARNING: the cycles below assume that AM3 does have ! WARNING: the cycles below assume that AM3 does have
@ -275,7 +259,7 @@ subroutine mld_daggrmat_smth_asb(a,desc_a,ac,desc_ac,p,info)
! Should we switch to something safer? ! Should we switch to something safer?
! !
call psb_sp_scal(am3,p%dorig,info) call psb_sp_scal(am3,p%dorig,info)
if(info /= 0) goto 9999 if (info /= 0) goto 9999
if (p%iprcparm(mld_aggr_eig_) == mld_max_norm_) then if (p%iprcparm(mld_aggr_eig_) == mld_max_norm_) then
@ -284,6 +268,7 @@ subroutine mld_daggrmat_smth_asb(a,desc_a,ac,desc_ac,p,info)
! !
! This only works with CSR. ! This only works with CSR.
! !
if (toupper(am3%fida)=='CSR') then
anorm = dzero anorm = dzero
dg = done dg = done
do i=1,am3%m do i=1,am3%m
@ -300,9 +285,16 @@ subroutine mld_daggrmat_smth_asb(a,desc_a,ac,desc_ac,p,info)
enddo enddo
call psb_amx(ictxt,anorm) call psb_amx(ictxt,anorm)
else
info = 4001
endif
else else
anorm = psb_spnrmi(am3,desc_a,info) anorm = psb_spnrmi(am3,desc_a,info)
endif endif
if (info /= 0) then
call psb_errpush(4001,name,a_err='Invalid AM3 storage format')
goto 9999
end if
omega = 4.d0/(3.d0*anorm) omega = 4.d0/(3.d0*anorm)
p%dprcparm(mld_aggr_damp_) = omega p%dprcparm(mld_aggr_damp_) = omega
@ -311,8 +303,9 @@ subroutine mld_daggrmat_smth_asb(a,desc_a,ac,desc_ac,p,info)
omega = p%dprcparm(mld_aggr_damp_) omega = p%dprcparm(mld_aggr_damp_)
else if (p%iprcparm(mld_aggr_eig_) /= mld_user_choice_) then else if (p%iprcparm(mld_aggr_eig_) /= mld_user_choice_) then
write(0,*) me,'Error: invalid choice for OMEGA in blaggrmat?? ',& info = 4001
& p%iprcparm(mld_aggr_eig_) call psb_errpush(info,name,a_err='invalid mld_aggr_eig_')
goto 9999
end if end if
@ -326,41 +319,14 @@ subroutine mld_daggrmat_smth_asb(a,desc_a,ac,desc_ac,p,info)
end if end if
end do end do
end do end do
else if (toupper(am3%fida)=='COO') then
do j=1,am3%infoa(psb_nnz_)
if (am3%ia1(j) /= am3%ia2(j)) then
am3%aspk(j) = - omega*am3%aspk(j)
else else
am3%aspk(j) = done - omega*am3%aspk(j) call psb_errpush(4001,name,a_err='Invalid AM3 storage format')
endif
end do
call psb_spcnv(am3,info,afmt='csr',dupl=psb_dupl_add_)
if (info /=0) then
call psb_errpush(4010,name,a_err='spcnv am3')
goto 9999
end if
else
write(0,*) 'Missing implementation of I sum'
call psb_errpush(4010,name)
goto 9999 goto 9999
end if end if
if (test_dump) then if (debug_level >= psb_debug_outer_) &
open(30+me) & write(debug_unit,*) me,' ',trim(name),&
write(30+me,*) 'OMEGA: ',omega & 'Done gather, going for SYMBMM 1'
do i=1,size(p%dorig)
write(30+me,*) p%dorig(i)
end do
close(30+me)
end if
if (test_dump) call &
& psb_csprt(20+me,am4,head='% Operator Ptilde.',ivr=desc_a%loc_to_glob)
if (test_dump) call psb_csprt(40+me,am3,head='% (I-wDA)',ivr=desc_a%loc_to_glob,&
& ivc=desc_a%loc_to_glob)
if (debug) write(0,*) me,'Done gather, going for SYMBMM 1'
! !
! Symbmm90 does the allocation for its result. ! Symbmm90 does the allocation for its result.
! !
@ -376,7 +342,9 @@ subroutine mld_daggrmat_smth_asb(a,desc_a,ac,desc_ac,p,info)
call psb_numbmm(am3,am4,am1) call psb_numbmm(am3,am4,am1)
if (debug) write(0,*) me,'Done NUMBMM 1' if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'Done NUMBMM 1'
call psb_sp_free(am4,info) call psb_sp_free(am4,info)
if(info /= 0) then if(info /= 0) then
@ -391,35 +359,15 @@ subroutine mld_daggrmat_smth_asb(a,desc_a,ac,desc_ac,p,info)
! !
call psb_sphalo(am1,desc_a,am4,info,& call psb_sphalo(am1,desc_a,am4,info,&
& colcnv=.false.,rowscale=.true.) & colcnv=.false.,rowscale=.true.)
if (info == 0) call psb_rwextd(ncol,am1,info,b=am4)
if(info /= 0) then if (info == 0) call psb_sp_free(am4,info)
call psb_errpush(4010,name,a_err='psb_sphalo')
goto 9999
end if
call psb_rwextd(ncol,am1,info,b=am4)
if(info /= 0) then
call psb_errpush(4010,name,a_err='psb_rwextd')
goto 9999
end if
call psb_sp_free(am4,info)
if(info /= 0) then
call psb_errpush(4010,name,a_err='psb_sp_free')
goto 9999
end if
else else
call psb_rwextd(ncol,am1,info) call psb_rwextd(ncol,am1,info)
endif
if(info /= 0) then if(info /= 0) then
call psb_errpush(4010,name,a_err='rwextd') call psb_errpush(4001,name,a_err='Halo of am1')
goto 9999 goto 9999
end if end if
endif
if (test_dump) &
& call psb_csprt(60+me,am1,head='% (I-wDA)Pt',ivr=desc_a%loc_to_glob)
call psb_symbmm(a,am1,am3,info) call psb_symbmm(a,am1,am3,info)
if(info /= 0) then if(info /= 0) then
@ -428,7 +376,9 @@ subroutine mld_daggrmat_smth_asb(a,desc_a,ac,desc_ac,p,info)
end if end if
call psb_numbmm(a,am1,am3) call psb_numbmm(a,am1,am3)
if (debug) write(0,*) me,'Done NUMBMM 2' if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'Done NUMBMM 2'
if (p%iprcparm(mld_aggr_kind_) == mld_smooth_prol_) then if (p%iprcparm(mld_aggr_kind_) == mld_smooth_prol_) then
call psb_transp(am1,am2,fmt='COO') call psb_transp(am1,am2,fmt='COO')
@ -446,7 +396,6 @@ subroutine mld_daggrmat_smth_asb(a,desc_a,ac,desc_ac,p,info)
am2%ia2(i) = am2%ia2(k) am2%ia2(i) = am2%ia2(k)
end if end if
end do end do
am2%infoa(psb_nnz_) = i am2%infoa(psb_nnz_) = i
call psb_spcnv(am2,info,afmt='csr',dupl=psb_dupl_add_) call psb_spcnv(am2,info,afmt='csr',dupl=psb_dupl_add_)
if (info /=0) then if (info /=0) then
@ -456,63 +405,38 @@ subroutine mld_daggrmat_smth_asb(a,desc_a,ac,desc_ac,p,info)
else else
call psb_transp(am1,am2) call psb_transp(am1,am2)
endif endif
if (debug) write(0,*) me,'starting sphalo/ rwxtd' if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'starting sphalo/ rwxtd'
if (p%iprcparm(mld_aggr_kind_) == mld_smooth_prol_) then if (p%iprcparm(mld_aggr_kind_) == mld_smooth_prol_) then
! am2 = ((i-wDA)Ptilde)^T ! am2 = ((i-wDA)Ptilde)^T
call psb_sphalo(am3,desc_a,am4,info,& call psb_sphalo(am3,desc_a,am4,info,&
& colcnv=.false.,rowscale=.true.) & colcnv=.false.,rowscale=.true.)
if (info == 0) call psb_rwextd(ncol,am3,info,b=am4)
if(info /= 0) then if (info == 0) call psb_sp_free(am4,info)
call psb_errpush(4010,name,a_err='psb_sphalo')
goto 9999
end if
call psb_rwextd(ncol,am3,info,b=am4)
if(info /= 0) then
call psb_errpush(4010,name,a_err='psb_rwextd')
goto 9999
end if
call psb_sp_free(am4,info)
if(info /= 0) then
call psb_errpush(4010,name,a_err='psb_sp_free')
goto 9999
end if
else if (p%iprcparm(mld_aggr_kind_) == mld_biz_prol_) then else if (p%iprcparm(mld_aggr_kind_) == mld_biz_prol_) then
call psb_rwextd(ncol,am3,info) call psb_rwextd(ncol,am3,info)
if(info /= 0) then
call psb_errpush(4010,name,a_err='psb_rwextd')
goto 9999
end if
endif endif
if (debug) write(0,*) me,'starting symbmm 3'
call psb_symbmm(am2,am3,b,info)
if(info /= 0) then if(info /= 0) then
call psb_errpush(4010,name,a_err='symbmm 3') call psb_errpush(4001,name,a_err='Extend am3')
goto 9999 goto 9999
end if end if
if (debug) write(0,*) me,'starting numbmm 3'
call psb_numbmm(am2,am3,b)
if (debug) write(0,*) me,'Done NUMBMM 3'
!!$ if (aggr_dump) call csprt(50+me,am1,head='% Operator PTrans.') if (debug_level >= psb_debug_outer_) &
call psb_sp_free(am3,info) & write(debug_unit,*) me,' ',trim(name),&
if(info /= 0) then & 'starting symbmm 3'
call psb_errpush(4010,name,a_err='psb_sp_free') call psb_symbmm(am2,am3,b,info)
goto 9999 if (info == 0) call psb_numbmm(am2,am3,b)
end if if (info == 0) call psb_sp_free(am3,info)
if (info == 0) call psb_spcnv(b,info,afmt='coo',dupl=psb_dupl_add_)
call psb_spcnv(b,info,afmt='coo',dupl=psb_dupl_add_) if (info /= 0) then
if (info /=0) then call psb_errpush(4001,name,a_err='Build b = am2 x am3')
call psb_errpush(4010,name,a_err='spcnv b')
goto 9999 goto 9999
end if end if
if (test_dump) call psb_csprt(80+me,b,head='% Smoothed aggregate AC.')
select case(p%iprcparm(mld_aggr_kind_)) select case(p%iprcparm(mld_aggr_kind_))
@ -523,55 +447,30 @@ subroutine mld_daggrmat_smth_asb(a,desc_a,ac,desc_ac,p,info)
case(mld_distr_mat_) case(mld_distr_mat_)
call psb_sp_clone(b,ac,info) call psb_sp_clone(b,ac,info)
if(info /= 0) goto 9999
nzac = ac%infoa(psb_nnz_) nzac = ac%infoa(psb_nnz_)
nzl = ac%infoa(psb_nnz_) nzl = ac%infoa(psb_nnz_)
if (info == 0) call psb_cdall(ictxt,desc_ac,info,nl=p%nlaggr(me+1))
call psb_cdall(ictxt,desc_ac,info,nl=p%nlaggr(me+1)) if (info == 0) call psb_cdins(nzl,ac%ia1,ac%ia2,desc_ac,info)
if(info /= 0) then if (info == 0) call psb_cdasb(desc_ac,info)
call psb_errpush(4010,name,a_err='psb_cdall') if (info == 0) call psb_glob_to_loc(ac%ia1(1:nzl),desc_ac,info,iact='I')
goto 9999 if (info == 0) call psb_glob_to_loc(ac%ia2(1:nzl),desc_ac,info,iact='I')
end if if (info /= 0) then
call psb_errpush(4001,name,a_err='Creating desc_ac and converting ac')
call psb_cdins(nzl,ac%ia1,ac%ia2,desc_ac,info)
if(info /= 0) then
call psb_errpush(4010,name,a_err='psb_cdins')
goto 9999
end if
if (debug) write(0,*) me,'Created aux descr. distr.'
call psb_cdasb(desc_ac,info)
if(info /= 0) then
call psb_errpush(4010,name,a_err='psb_cdasb')
goto 9999
end if
if (debug) write(0,*) me,'Asmbld aux descr. distr.'
call psb_glob_to_loc(ac%ia1(1:nzl),desc_ac,info,iact='I')
if(info /= 0) then
call psb_errpush(4010,name,a_err='psglob_to_loc')
goto 9999
end if
call psb_glob_to_loc(ac%ia2(1:nzl),desc_ac,info,iact='I')
if(info /= 0) then
call psb_errpush(4010,name,a_err='psglob_to_loc')
goto 9999 goto 9999
end if end if
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'Assembld aux descr. distr.'
ac%m=desc_ac%matrix_data(psb_n_row_) ac%m=desc_ac%matrix_data(psb_n_row_)
ac%k=desc_ac%matrix_data(psb_n_col_) ac%k=desc_ac%matrix_data(psb_n_col_)
ac%fida='COO' ac%fida='COO'
ac%descra='G' ac%descra='GUN'
call psb_sp_free(b,info) call psb_sp_free(b,info)
if (info == 0) deallocate(nzbr,idisp,stat=info) if (info == 0) deallocate(nzbr,idisp,stat=info)
if(info /= 0) then if (info /= 0) then
call psb_errpush(4010,name,a_err='psb_sp_free') call psb_errpush(4010,name,a_err='psb_sp_free')
goto 9999 goto 9999
end if end if
@ -579,7 +478,6 @@ subroutine mld_daggrmat_smth_asb(a,desc_a,ac,desc_ac,p,info)
if (np>1) then if (np>1) then
nzl = psb_sp_get_nnzeros(am1) nzl = psb_sp_get_nnzeros(am1)
call psb_glob_to_loc(am1%ia1(1:nzl),desc_ac,info,'I') call psb_glob_to_loc(am1%ia1(1:nzl),desc_ac,info,'I')
if(info /= 0) then if(info /= 0) then
call psb_errpush(4010,name,a_err='psb_glob_to_loc') call psb_errpush(4010,name,a_err='psb_glob_to_loc')
goto 9999 goto 9999
@ -589,44 +487,31 @@ subroutine mld_daggrmat_smth_asb(a,desc_a,ac,desc_ac,p,info)
if (np>1) then if (np>1) then
call psb_spcnv(am2,info,afmt='coo',dupl=psb_dupl_add_) call psb_spcnv(am2,info,afmt='coo',dupl=psb_dupl_add_)
if(info /= 0) then
call psb_errpush(4010,name,a_err='spcnv')
goto 9999
end if
nzl = am2%infoa(psb_nnz_) nzl = am2%infoa(psb_nnz_)
call psb_glob_to_loc(am2%ia1(1:nzl),desc_ac,info,'I') if (info == 0) call psb_glob_to_loc(am2%ia1(1:nzl),desc_ac,info,'I')
if (info == 0) call psb_spcnv(am2,info,afmt='csr',dupl=psb_dupl_add_)
if(info /= 0) then if(info /= 0) then
call psb_errpush(4010,name,a_err='psb_glob_to_loc') call psb_errpush(4001,name,a_err='Converting am2 to local')
goto 9999
end if
call psb_spcnv(am2,info,afmt='csr',dupl=psb_dupl_add_)
if(info /= 0) then
call psb_errpush(4010,name,a_err='spcnv')
goto 9999 goto 9999
end if end if
end if end if
am2%m=desc_ac%matrix_data(psb_n_col_) am2%m=desc_ac%matrix_data(psb_n_col_)
if (debug) write(0,*) me,'Done ac ' if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'Done ac '
case(mld_repl_mat_) case(mld_repl_mat_)
! !
! !
call psb_cdall(ictxt,desc_ac,info,mg=ntaggr,repl=.true.) call psb_cdall(ictxt,desc_ac,info,mg=ntaggr,repl=.true.)
if(info /= 0) then
call psb_errpush(4010,name,a_err='psb_cdall')
goto 9999
end if
nzbr(:) = 0 nzbr(:) = 0
nzbr(me+1) = b%infoa(psb_nnz_) nzbr(me+1) = b%infoa(psb_nnz_)
call psb_sum(ictxt,nzbr(1:np)) call psb_sum(ictxt,nzbr(1:np))
nzac = sum(nzbr) nzac = sum(nzbr)
call psb_sp_all(ntaggr,ntaggr,ac,nzac,info) if (info == 0) call psb_sp_all(ntaggr,ntaggr,ac,nzac,info)
if(info /= 0) goto 9999 if (info /= 0) goto 9999
do ip=1,np do ip=1,np
idisp(ip) = sum(nzbr(1:ip-1)) idisp(ip) = sum(nzbr(1:ip-1))
@ -635,30 +520,36 @@ subroutine mld_daggrmat_smth_asb(a,desc_a,ac,desc_ac,p,info)
call mpi_allgatherv(b%aspk,ndx,mpi_double_precision,ac%aspk,nzbr,idisp,& call mpi_allgatherv(b%aspk,ndx,mpi_double_precision,ac%aspk,nzbr,idisp,&
& mpi_double_precision,icomm,info) & mpi_double_precision,icomm,info)
call mpi_allgatherv(b%ia1,ndx,mpi_integer,ac%ia1,nzbr,idisp,& if (info == 0) call mpi_allgatherv(b%ia1,ndx,mpi_integer,ac%ia1,nzbr,idisp,&
& mpi_integer,icomm,info) & mpi_integer,icomm,info)
call mpi_allgatherv(b%ia2,ndx,mpi_integer,ac%ia2,nzbr,idisp,& if (info == 0) call mpi_allgatherv(b%ia2,ndx,mpi_integer,ac%ia2,nzbr,idisp,&
& mpi_integer,icomm,info) & mpi_integer,icomm,info)
if(info /= 0) goto 9999
if (info /= 0) then
call psb_errpush(4001,name,a_err=' from mpi_allgatherv')
goto 9999
end if
ac%m = ntaggr ac%m = ntaggr
ac%k = ntaggr ac%k = ntaggr
ac%infoa(psb_nnz_) = nzac ac%infoa(psb_nnz_) = nzac
ac%fida='COO' ac%fida='COO'
ac%descra='G' ac%descra='GUN'
call psb_spcnv(ac,info,afmt='coo',dupl=psb_dupl_add_) call psb_spcnv(ac,info,afmt='coo',dupl=psb_dupl_add_)
if(info /= 0) goto 9999 if(info /= 0) goto 9999
call psb_sp_free(b,info) call psb_sp_free(b,info)
if(info /= 0) goto 9999 if(info /= 0) goto 9999
if (me==0) then
if (test_dump) call psb_csprt(80+me,ac,head='% Smoothed aggregate AC.')
endif
deallocate(nzbr,idisp)
deallocate(nzbr,idisp,stat=info)
if (info /= 0) then
info = 4000
call psb_errpush(info,name)
goto 9999
end if
case default case default
write(0,*) 'Inconsistent input in smooth_new_aggregate' info = 4001
call psb_errpush(info,name,a_err='invalid mld_coarse_mat_')
goto 9999
end select end select
@ -669,25 +560,11 @@ subroutine mld_daggrmat_smth_asb(a,desc_a,ac,desc_ac,p,info)
case(mld_distr_mat_) case(mld_distr_mat_)
call psb_sp_clone(b,ac,info) call psb_sp_clone(b,ac,info)
if(info /= 0) then if (info == 0) call psb_cdall(ictxt,desc_ac,info,nl=naggr)
call psb_errpush(4010,name,a_err='spclone') if (info == 0) call psb_cdasb(desc_ac,info)
goto 9999 if (info == 0) call psb_sp_free(b,info)
end if if (info /= 0) then
call psb_cdall(ictxt,desc_ac,info,nl=naggr) call psb_errpush(4010,name,a_err='Build desc_ac, ac')
if(info /= 0) then
call psb_errpush(4010,name,a_err='psb_cdall')
goto 9999
end if
call psb_cdasb(desc_ac,info)
if(info /= 0) then
call psb_errpush(4010,name,a_err='psb_cdasb')
goto 9999
end if
call psb_sp_free(b,info)
if(info /= 0) then
call psb_errpush(4010,name,a_err='sp_free')
goto 9999 goto 9999
end if end if
@ -718,13 +595,12 @@ subroutine mld_daggrmat_smth_asb(a,desc_a,ac,desc_ac,p,info)
call mpi_allgatherv(b%aspk,ndx,mpi_double_precision,ac%aspk,nzbr,idisp,& call mpi_allgatherv(b%aspk,ndx,mpi_double_precision,ac%aspk,nzbr,idisp,&
& mpi_double_precision,icomm,info) & mpi_double_precision,icomm,info)
call mpi_allgatherv(b%ia1,ndx,mpi_integer,ac%ia1,nzbr,idisp,& if (info == 0) call mpi_allgatherv(b%ia1,ndx,mpi_integer,ac%ia1,nzbr,idisp,&
& mpi_integer,icomm,info) & mpi_integer,icomm,info)
call mpi_allgatherv(b%ia2,ndx,mpi_integer,ac%ia2,nzbr,idisp,& if (info == 0) call mpi_allgatherv(b%ia2,ndx,mpi_integer,ac%ia2,nzbr,idisp,&
& mpi_integer,icomm,info) & mpi_integer,icomm,info)
if(info /= 0) then if (info /= 0) then
info=-1 call psb_errpush(4001,name,a_err=' from mpi_allgatherv')
call psb_errpush(info,name)
goto 9999 goto 9999
end if end if
@ -733,7 +609,7 @@ subroutine mld_daggrmat_smth_asb(a,desc_a,ac,desc_ac,p,info)
ac%k = ntaggr ac%k = ntaggr
ac%infoa(psb_nnz_) = nzac ac%infoa(psb_nnz_) = nzac
ac%fida='COO' ac%fida='COO'
ac%descra='G' ac%descra='GUN'
call psb_spcnv(ac,info,afmt='coo',dupl=psb_dupl_add_) call psb_spcnv(ac,info,afmt='coo',dupl=psb_dupl_add_)
if(info /= 0) then if(info /= 0) then
call psb_errpush(4010,name,a_err='spcnv') call psb_errpush(4010,name,a_err='spcnv')
@ -745,8 +621,23 @@ subroutine mld_daggrmat_smth_asb(a,desc_a,ac,desc_ac,p,info)
goto 9999 goto 9999
end if end if
case default
info = 4001
call psb_errpush(info,name,a_err='invalid mld_coarse_mat_')
goto 9999
end select end select
deallocate(nzbr,idisp)
deallocate(nzbr,idisp,stat=info)
if (info /= 0) then
info = 4000
call psb_errpush(info,name)
goto 9999
end if
case default
info = 4001
call psb_errpush(info,name,a_err='invalid mld_smooth_prol_')
goto 9999
end select end select
@ -756,7 +647,9 @@ subroutine mld_daggrmat_smth_asb(a,desc_a,ac,desc_ac,p,info)
goto 9999 goto 9999
end if end if
if (debug) write(0,*) me,'Done smooth_aggregate ' if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'Done smooth_aggregate '
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
return return

64
mlprec/mld_dasmat_bld.f90
Unescape Escape View File

@ -78,7 +78,7 @@ subroutine mld_dasmat_bld(ptype,novr,a,blk,desc_data,upd,desc_p,info,outfmt)
Implicit None Implicit None
! Arguments ! Arguments
integer, intent(in) :: ptype,novr integer, intent(in) :: ptype,novr
Type(psb_dspmat_type), Intent(in) :: a Type(psb_dspmat_type), Intent(in) :: a
Type(psb_dspmat_type), Intent(inout) :: blk Type(psb_dspmat_type), Intent(inout) :: blk
@ -88,21 +88,24 @@ subroutine mld_dasmat_bld(ptype,novr,a,blk,desc_data,upd,desc_p,info,outfmt)
Character, Intent(in) :: upd Character, Intent(in) :: upd
character(len=5), optional :: outfmt character(len=5), optional :: outfmt
! Local variables ! Local variables
real(kind(1.d0)) :: t1,t2,t3
integer icomm integer icomm
Integer :: np,me,nnzero,& Integer :: np,me,nnzero,&
& ictxt, n_col,int_err(5),& & ictxt, n_col,int_err(5),&
& tot_recv, n_row,nhalo, nrow_a,err_act & tot_recv, n_row,nhalo, nrow_a,err_act
Logical,Parameter :: debug=.false. integer :: debug_level, debug_unit
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
name='mld_dasmat_bld' name='mld_dasmat_bld'
if(psb_get_errstatus().ne.0) return if(psb_get_errstatus() /= 0) return
info=0 info=0
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
debug_unit = psb_get_debug_unit()
debug_level = psb_get_debug_level()
If(debug) Write(0,*)'IN DASMATBLD ', upd If (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& ' start ', upd
ictxt = psb_cd_get_context(desc_data) ictxt = psb_cd_get_context(desc_data)
icomm = psb_cd_get_mpic(desc_data) icomm = psb_cd_get_mpic(desc_data)
@ -121,7 +124,6 @@ subroutine mld_dasmat_bld(ptype,novr,a,blk,desc_data,upd,desc_p,info,outfmt)
! Block-Jacobi preconditioner. Copy the descriptor, just in case ! Block-Jacobi preconditioner. Copy the descriptor, just in case
! we want to renumber the rows and columns of the matrix. ! we want to renumber the rows and columns of the matrix.
! !
If(debug) Write(0,*)' asmatbld calling allocate '
call psb_sp_all(0,0,blk,1,info) call psb_sp_all(0,0,blk,1,info)
if(info /= 0) then if(info /= 0) then
info=4010 info=4010
@ -131,10 +133,11 @@ subroutine mld_dasmat_bld(ptype,novr,a,blk,desc_data,upd,desc_p,info,outfmt)
end if end if
blk%fida = 'COO' blk%fida = 'COO'
blk%infoa(psb_nnz_) = 0 blk%infoa(psb_nnz_) = 0
If(debug) Write(0,*)' asmatbld done spallocate'
If (upd == 'F') Then If (upd == 'F') Then
call psb_cdcpy(desc_data,desc_p,info) call psb_cdcpy(desc_data,desc_p,info)
If(debug) Write(0,*)' asmatbld done cdcpy' If(debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& ' done cdcpy'
if(info /= 0) then if(info /= 0) then
info=4010 info=4010
ch_err='psb_cdcpy' ch_err='psb_cdcpy'
@ -144,12 +147,9 @@ subroutine mld_dasmat_bld(ptype,novr,a,blk,desc_data,upd,desc_p,info,outfmt)
endif endif
case(mld_as_) case(mld_as_)
! !
! Additive Schwarz ! Additive Schwarz
! !
if (novr < 0) then if (novr < 0) then
info=3 info=3
int_err(1)=novr int_err(1)=novr
@ -161,7 +161,9 @@ subroutine mld_dasmat_bld(ptype,novr,a,blk,desc_data,upd,desc_p,info,outfmt)
! !
! Actually, this is just block Jacobi ! Actually, this is just block Jacobi
! !
If(debug) Write(0,*)' asmatbld calling allocate novr=0' If(debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& ' calling allocate novr=0'
call psb_sp_all(0,0,blk,1,info) call psb_sp_all(0,0,blk,1,info)
if(info /= 0) then if(info /= 0) then
info=4010 info=4010
@ -171,25 +173,28 @@ subroutine mld_dasmat_bld(ptype,novr,a,blk,desc_data,upd,desc_p,info,outfmt)
end if end if
blk%fida = 'COO' blk%fida = 'COO'
blk%infoa(psb_nnz_) = 0 blk%infoa(psb_nnz_) = 0
if (debug) write(0,*) 'Calling desccpy' if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'Calling desccpy'
if (upd == 'F') then if (upd == 'F') then
call psb_cdcpy(desc_data,desc_p,info) call psb_cdcpy(desc_data,desc_p,info)
If(debug) Write(0,*)' asmatbld done cdcpy' If(debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& ' done cdcpy'
if(info /= 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)
goto 9999 goto 9999
end if end if
if (debug) write(0,*) 'Early return from asmatbld: P>=3 N_OVR=0' if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'Early return: P>=3 N_OVR=0'
endif endif
return return
endif endif
If(debug)Write(0,*)'BEGIN dasmatbld',me,upd,novr
t1 = psb_wtime()
If (upd == 'F') Then If (upd == 'F') Then
! !
! Build the auxiliary descriptor desc_p%matrix_data(psb_n_row_). ! Build the auxiliary descriptor desc_p%matrix_data(psb_n_row_).
@ -200,7 +205,7 @@ subroutine mld_dasmat_bld(ptype,novr,a,blk,desc_data,upd,desc_p,info,outfmt)
! a descriptor for an extended stencil in a PDE solver. ! a descriptor for an extended stencil in a PDE solver.
! !
call psb_cdbldext(a,desc_data,novr,desc_p,info,extype=psb_ovt_asov_) call psb_cdbldext(a,desc_data,novr,desc_p,info,extype=psb_ovt_asov_)
if(info /= 0) then if (info /= 0) then
info=4010 info=4010
ch_err='psb_cdbldext' ch_err='psb_cdbldext'
call psb_errpush(info,name,a_err=ch_err) call psb_errpush(info,name,a_err=ch_err)
@ -208,7 +213,9 @@ subroutine mld_dasmat_bld(ptype,novr,a,blk,desc_data,upd,desc_p,info,outfmt)
end if end if
Endif Endif
if(debug) write(0,*) me,' From cdbldext _:',desc_p%matrix_data(psb_n_row_),& if(debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& ' From cdbldext _:',desc_p%matrix_data(psb_n_row_),&
& desc_p%matrix_data(psb_n_col_) & desc_p%matrix_data(psb_n_col_)
! !
@ -216,30 +223,35 @@ subroutine mld_dasmat_bld(ptype,novr,a,blk,desc_data,upd,desc_p,info,outfmt)
! !
n_row = desc_p%matrix_data(psb_n_row_) n_row = desc_p%matrix_data(psb_n_row_)
t2 = psb_wtime()
if (debug) write(0,*) 'Before sphalo ',blk%fida,blk%m,psb_nnz_,blk%infoa(psb_nnz_) if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'Before sphalo ',blk%fida,blk%m,psb_nnz_,blk%infoa(psb_nnz_)
Call psb_sphalo(a,desc_p,blk,info,& Call psb_sphalo(a,desc_p,blk,info,&
& outfmt=outfmt,data=psb_comm_ext_,rowscale=.true.) & outfmt=outfmt,data=psb_comm_ext_,rowscale=.true.)
if(info /= 0) then if (info /= 0) then
info=4010 info=4010
ch_err='psb_sphalo' ch_err='psb_sphalo'
call psb_errpush(info,name,a_err=ch_err) call psb_errpush(info,name,a_err=ch_err)
goto 9999 goto 9999
end if end if
if (debug) write(0,*) 'After psb_sphalo ',& if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'After psb_sphalo ',&
& blk%fida,blk%m,psb_nnz_,blk%infoa(psb_nnz_) & blk%fida,blk%m,psb_nnz_,blk%infoa(psb_nnz_)
case default case default
if(info /= 0) then if(info /= 0) then
info=4000 info=4001
ch_err='Invalid ptype' ch_err='Invalid ptype'
call psb_errpush(info,name,a_err=ch_err) call psb_errpush(info,name,a_err=ch_err)
goto 9999 goto 9999
end if end if
End select End select
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),'Done'
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
return return

27
mlprec/mld_dbaseprec_aply.f90
Unescape Escape View File

@ -98,7 +98,6 @@ subroutine mld_dbaseprec_aply(alpha,prec,x,beta,y,desc_data,trans,work,info)
real(kind(1.d0)), pointer :: ww(:), aux(:), tx(:),ty(:) real(kind(1.d0)), pointer :: ww(:), aux(:), tx(:),ty(:)
character ::diagl, diagu character ::diagl, diagu
integer :: ictxt,np,me,isz, err_act integer :: ictxt,np,me,isz, err_act
logical, parameter :: debug=.false., debugprt=.false.
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
name='mld_dbaseprec_aply' name='mld_dbaseprec_aply'
@ -164,7 +163,7 @@ subroutine mld_dbaseprec_aply(alpha,prec,x,beta,y,desc_data,trans,work,info)
! !
call mld_bjac_aply(alpha,prec,x,beta,y,desc_data,trans,work,info) call mld_bjac_aply(alpha,prec,x,beta,y,desc_data,trans,work,info)
if(info.ne.0) then if(info /= 0) then
info=4010 info=4010
ch_err='mld_bjac_aply' ch_err='mld_bjac_aply'
goto 9999 goto 9999
@ -180,7 +179,7 @@ subroutine mld_dbaseprec_aply(alpha,prec,x,beta,y,desc_data,trans,work,info)
! shortcut: this fixes performance for RAS(0) == BJA ! shortcut: this fixes performance for RAS(0) == BJA
! !
call mld_bjac_aply(alpha,prec,x,beta,y,desc_data,trans,work,info) call mld_bjac_aply(alpha,prec,x,beta,y,desc_data,trans,work,info)
if(info.ne.0) then if(info /= 0) then
info=4010 info=4010
ch_err='psb_bjacaply' ch_err='psb_bjacaply'
goto 9999 goto 9999
@ -230,9 +229,6 @@ subroutine mld_dbaseprec_aply(alpha,prec,x,beta,y,desc_data,trans,work,info)
endif endif
if (debugprt) write(0,*)' vdiag: ',prec%d(:)
if (debug) write(0,*) 'Bi-CGSTAB with Additive Schwarz prec'
tx(1:nrow_d) = x(1:nrow_d) tx(1:nrow_d) = x(1:nrow_d)
tx(nrow_d+1:isz) = dzero tx(nrow_d+1:isz) = dzero
@ -247,8 +243,8 @@ subroutine mld_dbaseprec_aply(alpha,prec,x,beta,y,desc_data,trans,work,info)
goto 9999 goto 9999
end if end if
else if (prec%iprcparm(mld_sub_restr_) /= psb_none_) then else if (prec%iprcparm(mld_sub_restr_) /= psb_none_) then
write(0,*) 'Problem in PREC_APLY: Unknown value for restriction ',& call psb_errpush(4001,name,a_err='Invalid mld_sub_restr_')
&prec%iprcparm(mld_sub_restr_) goto 9999
end if end if
! !
@ -270,7 +266,7 @@ subroutine mld_dbaseprec_aply(alpha,prec,x,beta,y,desc_data,trans,work,info)
! preconditioner). The resulting vector is ty. ! preconditioner). The resulting vector is ty.
! !
call mld_bjac_aply(done,prec,tx,dzero,ty,prec%desc_data,trans,aux,info) call mld_bjac_aply(done,prec,tx,dzero,ty,prec%desc_data,trans,aux,info)
if(info.ne.0) then if(info /= 0) then
info=4010 info=4010
ch_err='mld_bjac_aply' ch_err='mld_bjac_aply'
goto 9999 goto 9999
@ -281,7 +277,7 @@ subroutine mld_dbaseprec_aply(alpha,prec,x,beta,y,desc_data,trans,work,info)
! !
if (prec%iprcparm(mld_sub_ren_)>0) then if (prec%iprcparm(mld_sub_ren_)>0) then
call psb_gelp('n',prec%invperm,ty,info) call psb_gelp('n',prec%invperm,ty,info)
if(info /=0) then if(info /= 0) then
info=4010 info=4010
ch_err='psb_gelp' ch_err='psb_gelp'
goto 9999 goto 9999
@ -309,8 +305,8 @@ subroutine mld_dbaseprec_aply(alpha,prec,x,beta,y,desc_data,trans,work,info)
end if end if
case default case default
write(0,*) 'Problem in PREC_APLY: Unknown value for prolongation ',& call psb_errpush(4001,name,a_err='Invalid mld_sub_prol_')
& prec%iprcparm(mld_sub_prol_) goto 9999
end select end select
! !
@ -330,9 +326,8 @@ subroutine mld_dbaseprec_aply(alpha,prec,x,beta,y,desc_data,trans,work,info)
end if end if
case default case default
write(0,*) 'Invalid PRE%PREC ',prec%iprcparm(mld_prec_type_),':',& call psb_errpush(4001,name,a_err='Invalid mld_prec_type_')
& mld_min_prec_,mld_noprec_,mld_diag_,mld_bjac_,mld_as_ goto 9999
end select end select
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
@ -341,7 +336,7 @@ subroutine mld_dbaseprec_aply(alpha,prec,x,beta,y,desc_data,trans,work,info)
9999 continue 9999 continue
call psb_errpush(info,name,i_err=int_err,a_err=ch_err) call psb_errpush(info,name,i_err=int_err,a_err=ch_err)
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
if (err_act.eq.psb_act_abort_) then if (err_act == psb_act_abort_) then
call psb_error() call psb_error()
return return
end if end if

40
mlprec/mld_dbaseprec_bld.f90
Unescape Escape View File

@ -77,34 +77,33 @@ subroutine mld_dbaseprc_bld(a,desc_a,p,info,upd)
! Local variables ! Local variables
Integer :: err, n_row, n_col,ictxt, me,np,mglob, err_act Integer :: err, n_row, n_col,ictxt, me,np,mglob, err_act
integer :: int_err(5)
character :: iupd character :: iupd
integer :: debug_level, debug_unit
logical, parameter :: debug=.false.
integer,parameter :: iroot=0,iout=60,ilout=40
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
name = 'mld_dbaseprc_bld'
info=0 info=0
err=0 err=0
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
name = 'mld_dbaseprc_bld' debug_unit = psb_get_debug_unit()
debug_level = psb_get_debug_level()
if (debug) write(0,*) 'Entering baseprc_bld'
info = 0
int_err(1) = 0
ictxt = psb_cd_get_context(desc_a) ictxt = psb_cd_get_context(desc_a)
n_row = psb_cd_get_local_rows(desc_a) n_row = psb_cd_get_local_rows(desc_a)
n_col = psb_cd_get_local_cols(desc_a) n_col = psb_cd_get_local_cols(desc_a)
mglob = psb_cd_get_global_rows(desc_a) mglob = psb_cd_get_global_rows(desc_a)
if (debug) write(0,*) 'Preconditioner Blacs_gridinfo'
call psb_info(ictxt, me, np) call psb_info(ictxt, me, np)
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),' start'
if (present(upd)) then if (present(upd)) then
if (debug) write(0,*) 'UPD ', upd if (debug_level >= psb_debug_outer_) &
if ((UPD.eq.'F').or.(UPD.eq.'T')) then & write(debug_unit,*) me,' ',trim(name),'UPD ', upd
IUPD=UPD if ((toupper(UPD) == 'F').or.(toupper(UPD) == 'T')) then
IUPD=toupper(UPD)
else else
IUPD='F' IUPD='F'
endif endif
@ -140,7 +139,9 @@ subroutine mld_dbaseprc_bld(a,desc_a,p,info,upd)
! Diagonal preconditioner ! Diagonal preconditioner
call mld_diag_bld(a,desc_a,p,iupd,info) call mld_diag_bld(a,desc_a,p,iupd,info)
if(debug) write(0,*)me,': out of mld_diag_bld' if(debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& ': out of mld_diag_bld'
if(info /= 0) then if(info /= 0) then
info=4010 info=4010
ch_err='mld_diag_bld' ch_err='mld_diag_bld'
@ -168,8 +169,9 @@ subroutine mld_dbaseprc_bld(a,desc_a,p,info,upd)
p%iprcparm(mld_smooth_sweeps_) = 1 p%iprcparm(mld_smooth_sweeps_) = 1
end if end if
if (debug) write(0,*)me, ': Calling mld_bjac_bld' if (debug_level >= psb_debug_outer_) &
if (debug) call psb_barrier(ictxt) & write(debug_unit,*) me,' ',trim(name),&
& ': Calling mld_bjac_bld'
! Build the local part of the base preconditioner ! Build the local part of the base preconditioner
call mld_bjac_bld(a,desc_a,p,iupd,info) call mld_bjac_bld(a,desc_a,p,iupd,info)
@ -180,7 +182,7 @@ subroutine mld_dbaseprc_bld(a,desc_a,p,info,upd)
end if end if
case default case default
info=4010 info=4001
ch_err='Unknown mld_prec_type_' ch_err='Unknown mld_prec_type_'
call psb_errpush(info,name,a_err=ch_err) call psb_errpush(info,name,a_err=ch_err)
goto 9999 goto 9999
@ -190,6 +192,8 @@ subroutine mld_dbaseprc_bld(a,desc_a,p,info,upd)
p%base_a => a p%base_a => a
p%base_desc => desc_a p%base_desc => desc_a
p%iprcparm(mld_prec_status_) = mld_prec_built_ p%iprcparm(mld_prec_status_) = mld_prec_built_
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),': Done'
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
return return

83
mlprec/mld_dbjac_aply.f90
Unescape Escape View File

@ -150,8 +150,7 @@ subroutine mld_dbjac_aply(alpha,prec,x,beta,y,desc_data,trans,work,info)
! Local variables ! Local variables
integer :: n_row,n_col integer :: n_row,n_col
real(kind(1.d0)), pointer :: ww(:), aux(:), tx(:),ty(:) real(kind(1.d0)), pointer :: ww(:), aux(:), tx(:),ty(:)
integer :: ictxt,np,me,i, err_act, int_err(5) integer :: ictxt,np,me,i, err_act
logical,parameter :: debug=.false., debugprt=.false.
character(len=20) :: name character(len=20) :: name
interface interface
@ -206,10 +205,6 @@ subroutine mld_dbjac_aply(alpha,prec,x,beta,y,desc_data,trans,work,info)
end if end if
endif endif
if (debug) then
write(0,*) me,' mld_bjac_APLY: ',prec%iprcparm(mld_sub_solve_),prec%iprcparm(mld_smooth_sweeps_)
end if
if (prec%iprcparm(mld_smooth_sweeps_) == 1) then if (prec%iprcparm(mld_smooth_sweeps_) == 1) then
! !
! TASKS 1, 3 and 4 ! TASKS 1, 3 and 4
@ -228,19 +223,17 @@ subroutine mld_dbjac_aply(alpha,prec,x,beta,y,desc_data,trans,work,info)
call psb_spsm(done,prec%av(mld_l_pr_),x,dzero,ww,desc_data,info,& call psb_spsm(done,prec%av(mld_l_pr_),x,dzero,ww,desc_data,info,&
& trans='N',unit='L',diag=prec%d,choice=psb_none_,work=aux) & trans='N',unit='L',diag=prec%d,choice=psb_none_,work=aux)
if(info /=0) goto 9999 if (info == 0) call psb_spsm(alpha,prec%av(mld_u_pr_),ww,beta,y,desc_data,info,&
call psb_spsm(alpha,prec%av(mld_u_pr_),ww,beta,y,desc_data,info,&
& trans='N',unit='U',choice=psb_none_, work=aux) & trans='N',unit='U',choice=psb_none_, work=aux)
if(info /=0) goto 9999
case('T','C') case('T','C')
call psb_spsm(done,prec%av(mld_u_pr_),x,dzero,ww,desc_data,info,& call psb_spsm(done,prec%av(mld_u_pr_),x,dzero,ww,desc_data,info,&
& trans=trans,unit='L',diag=prec%d,choice=psb_none_,work=aux) & trans=trans,unit='L',diag=prec%d,choice=psb_none_,work=aux)
if(info /=0) goto 9999 if (info == 0) call psb_spsm(alpha,prec%av(mld_l_pr_),ww,beta,y,desc_data,info,&
call psb_spsm(alpha,prec%av(mld_l_pr_),ww,beta,y,desc_data,info,&
& trans=trans,unit='U',choice=psb_none_,work=aux) & trans=trans,unit='U',choice=psb_none_,work=aux)
if(info /=0) goto 9999 case default
call psb_errpush(4001,name,a_err='Invalid TRANS in ILU subsolve')
goto 9999
end select end select
case(mld_slu_) case(mld_slu_)
@ -258,10 +251,12 @@ subroutine mld_dbjac_aply(alpha,prec,x,beta,y,desc_data,trans,work,info)
call mld_dslu_solve(0,n_row,1,ww,n_row,prec%iprcparm(mld_slu_ptr_),info) call mld_dslu_solve(0,n_row,1,ww,n_row,prec%iprcparm(mld_slu_ptr_),info)
case('T','C') case('T','C')
call mld_dslu_solve(1,n_row,1,ww,n_row,prec%iprcparm(mld_slu_ptr_),info) call mld_dslu_solve(1,n_row,1,ww,n_row,prec%iprcparm(mld_slu_ptr_),info)
case default
call psb_errpush(4001,name,a_err='Invalid TRANS in SLU subsolve')
goto 9999
end select end select
if(info /=0) goto 9999 if (info ==0) call psb_geaxpby(alpha,ww,beta,y,desc_data,info)
call psb_geaxpby(alpha,ww,beta,y,desc_data,info)
case(mld_sludist_) case(mld_sludist_)
! !
@ -276,10 +271,12 @@ subroutine mld_dbjac_aply(alpha,prec,x,beta,y,desc_data,trans,work,info)
call mld_dsludist_solve(0,n_row,1,ww,n_row,prec%iprcparm(mld_slud_ptr_),info) call mld_dsludist_solve(0,n_row,1,ww,n_row,prec%iprcparm(mld_slud_ptr_),info)
case('T','C') case('T','C')
call mld_dsludist_solve(1,n_row,1,ww,n_row,prec%iprcparm(mld_slud_ptr_),info) call mld_dsludist_solve(1,n_row,1,ww,n_row,prec%iprcparm(mld_slud_ptr_),info)
case default
call psb_errpush(4001,name,a_err='Invalid TRANS in SLUDist subsolve')
goto 9999
end select end select
if(info /=0) goto 9999 if (info == 0) call psb_geaxpby(alpha,ww,beta,y,desc_data,info)
call psb_geaxpby(alpha,ww,beta,y,desc_data,info)
case (mld_umf_) case (mld_umf_)
! !
@ -295,16 +292,22 @@ subroutine mld_dbjac_aply(alpha,prec,x,beta,y,desc_data,trans,work,info)
call mld_dumf_solve(0,n_row,ww,x,n_row,prec%iprcparm(mld_umf_numptr_),info) call mld_dumf_solve(0,n_row,ww,x,n_row,prec%iprcparm(mld_umf_numptr_),info)
case('T','C') case('T','C')
call mld_dumf_solve(1,n_row,ww,x,n_row,prec%iprcparm(mld_umf_numptr_),info) call mld_dumf_solve(1,n_row,ww,x,n_row,prec%iprcparm(mld_umf_numptr_),info)
case default
call psb_errpush(4001,name,a_err='Invalid TRANS in UMF subsolve')
goto 9999
end select end select
if(info /=0) goto 9999 if (info == 0) call psb_geaxpby(alpha,ww,beta,y,desc_data,info)
call psb_geaxpby(alpha,ww,beta,y,desc_data,info)
case default case default
write(0,*) 'Unknown factorization type in mld_bjac_aply',prec%iprcparm(mld_sub_solve_) call psb_errpush(4001,name,a_err='Invalid mld_sub_solve_')
goto 9999
end select end select
if (debugprt) write(0,*)' Y: ',y(:) if (info /= 0) then
call psb_errpush(4001,name,a_err='Error in subsolve Jacobi Sweeps = 1')
goto 9999
endif
else if (prec%iprcparm(mld_smooth_sweeps_) > 1) then else if (prec%iprcparm(mld_smooth_sweeps_) > 1) then
@ -346,23 +349,23 @@ subroutine mld_dbjac_aply(alpha,prec,x,beta,y,desc_data,trans,work,info)
ty(1:n_row) = x(1:n_row) ty(1:n_row) = x(1:n_row)
call psb_spmm(-done,prec%av(mld_ap_nd_),tx,done,ty,& call psb_spmm(-done,prec%av(mld_ap_nd_),tx,done,ty,&
& prec%desc_data,info,work=aux) & prec%desc_data,info,work=aux)
if(info /=0) goto 9999 if (info /=0) exit
call psb_spsm(done,prec%av(mld_l_pr_),ty,dzero,ww,& call psb_spsm(done,prec%av(mld_l_pr_),ty,dzero,ww,&
& prec%desc_data,info,& & prec%desc_data,info,&
& trans='N',unit='L',diag=prec%d,choice=psb_none_,work=aux) & trans='N',unit='L',diag=prec%d,choice=psb_none_,work=aux)
if(info /=0) goto 9999 if (info /=0) exit
call psb_spsm(done,prec%av(mld_u_pr_),ww,dzero,tx,& call psb_spsm(done,prec%av(mld_u_pr_),ww,dzero,tx,&
& prec%desc_data,info,& & prec%desc_data,info,&
& trans='N',unit='U',choice=psb_none_,work=aux) & trans='N',unit='U',choice=psb_none_,work=aux)
if(info /=0) goto 9999 if (info /=0) exit
end do end do
case(mld_sludist_) case(mld_sludist_)
! !
! Wrong choice: SuperLU_DIST ! Wrong choice: SuperLU_DIST
! !
write(0,*) 'No sense in having SuperLU_DIST with multiple Jacobi sweeps' info = 4001
info=4010 call psb_errpush(4001,name,a_err='Invalid SuperLU_DIST with Jacobi sweeps >1')
goto 9999 goto 9999
case(mld_slu_) case(mld_slu_)
@ -379,10 +382,10 @@ subroutine mld_dbjac_aply(alpha,prec,x,beta,y,desc_data,trans,work,info)
ty(1:n_row) = x(1:n_row) ty(1:n_row) = x(1:n_row)
call psb_spmm(-done,prec%av(mld_ap_nd_),tx,done,ty,& call psb_spmm(-done,prec%av(mld_ap_nd_),tx,done,ty,&
& prec%desc_data,info,work=aux) & prec%desc_data,info,work=aux)
if(info /=0) goto 9999 if(info /=0) exit
call mld_dslu_solve(0,n_row,1,ty,n_row,prec%iprcparm(mld_slu_ptr_),info) call mld_dslu_solve(0,n_row,1,ty,n_row,prec%iprcparm(mld_slu_ptr_),info)
if(info /=0) goto 9999 if(info /=0) exit
tx(1:n_row) = ty(1:n_row) tx(1:n_row) = ty(1:n_row)
end do end do
@ -400,23 +403,34 @@ subroutine mld_dbjac_aply(alpha,prec,x,beta,y,desc_data,trans,work,info)
ty(1:n_row) = x(1:n_row) ty(1:n_row) = x(1:n_row)
call psb_spmm(-done,prec%av(mld_ap_nd_),tx,done,ty,& call psb_spmm(-done,prec%av(mld_ap_nd_),tx,done,ty,&
& prec%desc_data,info,work=aux) & prec%desc_data,info,work=aux)
if(info /=0) goto 9999 if(info /=0) exit
call mld_dumf_solve(0,n_row,ww,ty,n_row,& call mld_dumf_solve(0,n_row,ww,ty,n_row,&
& prec%iprcparm(mld_umf_numptr_),info) & prec%iprcparm(mld_umf_numptr_),info)
if(info /=0) goto 9999 if(info /=0) exit
tx(1:n_row) = ww(1:n_row) tx(1:n_row) = ww(1:n_row)
end do end do
case default
call psb_errpush(4001,name,a_err='Invalid mld_sub_solve_')
goto 9999
end select end select
if (info /= 0) then
info=4001
call psb_errpush(info,name,a_err='subsolve with Jacobi sweeps > 1')
goto 9999
end if
! !
! Put the result into the output vector Y. ! Put the result into the output vector Y.
! !
call psb_geaxpby(alpha,tx,beta,y,desc_data,info) call psb_geaxpby(alpha,tx,beta,y,desc_data,info)
deallocate(tx,ty,stat=info)
if (info /= 0) then
deallocate(tx,ty) info=4001
call psb_errpush(info,name,a_err='final cleanup with Jacobi sweeps > 1')
goto 9999
end if
else else
@ -440,7 +454,6 @@ subroutine mld_dbjac_aply(alpha,prec,x,beta,y,desc_data,trans,work,info)
return return
9999 continue 9999 continue
call psb_errpush(info,name,i_err=int_err)
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()

195
mlprec/mld_dbjac_bld.f90
Unescape Escape View File

@ -59,19 +59,14 @@
! 2. setup of block-Jacobi sweeps to compute an approximate solution of a ! 2. setup of block-Jacobi sweeps to compute an approximate solution of a
! linear system ! linear system
! A*Y = X, ! A*Y = X,
!
! distributed among the processes (allowed only at the coarsest level); ! distributed among the processes (allowed only at the coarsest level);
! !
! 3. LU factorization of a linear system ! 3. LU factorization of a linear system
!
! A*Y = X, ! A*Y = X,
!
! distributed among the processes (allowed only at the coarsest level); ! distributed among the processes (allowed only at the coarsest level);
! !
! 4. LU or incomplete LU factorization of a linear system ! 4. LU or incomplete LU factorization of a linear system
!
! A*Y = X, ! A*Y = X,
!
! replicated on the processes (allowed only at the coarsest level). ! replicated on the processes (allowed only at the coarsest level).
! !
! The following factorizations are available: ! The following factorizations are available:
@ -116,7 +111,7 @@ subroutine mld_dbjac_bld(a,desc_a,p,upd,info)
integer :: int_err(5) integer :: int_err(5)
character :: trans, unitd character :: trans, unitd
type(psb_dspmat_type) :: blck, atmp type(psb_dspmat_type) :: blck, atmp
logical, parameter :: debugprt=.false., debug=.false., aggr_dump=.false. integer :: debug_level, debug_unit
integer :: err_act, n_row, nrow_a,n_col integer :: err_act, n_row, nrow_a,n_col
integer :: ictxt,np,me integer :: ictxt,np,me
character(len=20) :: name character(len=20) :: name
@ -126,8 +121,9 @@ subroutine mld_dbjac_bld(a,desc_a,p,upd,info)
info=0 info=0
name='mld_dbjac_bld' name='mld_dbjac_bld'
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
debug_unit = psb_get_debug_unit()
ictxt=psb_cd_get_context(desc_a) debug_level = psb_get_debug_level()
ictxt = psb_cd_get_context(desc_a)
call psb_info(ictxt, me, np) call psb_info(ictxt, me, np)
m = a%m m = a%m
@ -152,9 +148,9 @@ subroutine mld_dbjac_bld(a,desc_a,p,upd,info)
call psb_nullify_sp(atmp) call psb_nullify_sp(atmp)
if(debug) write(0,*)me,': calling mld_asmat_bld',& if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),': Start',&
& p%iprcparm(mld_prec_type_),p%iprcparm(mld_n_ovr_) & p%iprcparm(mld_prec_type_),p%iprcparm(mld_n_ovr_)
if (debug) call psb_barrier(ictxt)
! !
! Build the communication descriptor for the Additive Schwarz ! Build the communication descriptor for the Additive Schwarz
@ -166,22 +162,14 @@ subroutine mld_dbjac_bld(a,desc_a,p,upd,info)
call mld_asmat_bld(p%iprcparm(mld_prec_type_),p%iprcparm(mld_n_ovr_),a,& call mld_asmat_bld(p%iprcparm(mld_prec_type_),p%iprcparm(mld_n_ovr_),a,&
& blck,desc_a,upd,p%desc_data,info,outfmt=csrfmt) & blck,desc_a,upd,p%desc_data,info,outfmt=csrfmt)
if (debugprt) then if (info/=0) then
open(60+me)
call psb_csprt(60+me,a,head='% A')
close(60+me)
open(70+me)
call psb_csprt(70+me,blck,head='% BLCK')
close(70+me)
endif
if(info/=0) then
call psb_errpush(4010,name,a_err='mld_asmat_bld') call psb_errpush(4010,name,a_err='mld_asmat_bld')
goto 9999 goto 9999
end if end if
if (debug) write(0,*)me,': out of mld_asmat_bld' if (debug_level >= psb_debug_outer_) &
if (debug) call psb_barrier(ictxt) & write(debug_unit,*) me,' ',trim(name),&
& ': out of mld_asmat_bld'
! !
! Treat separately the case the local matrix has to be reordered ! Treat separately the case the local matrix has to be reordered
@ -200,7 +188,6 @@ subroutine mld_dbjac_bld(a,desc_a,p,upd,info)
! matrix is stored into atmp, using the COO format. ! matrix is stored into atmp, using the COO format.
! !
call mld_sp_renum(a,desc_a,blck,p,atmp,info) call mld_sp_renum(a,desc_a,blck,p,atmp,info)
if (info/=0) then if (info/=0) then
call psb_errpush(4010,name,a_err='mld_sp_renum') call psb_errpush(4010,name,a_err='mld_sp_renum')
goto 9999 goto 9999
@ -212,10 +199,10 @@ subroutine mld_dbjac_bld(a,desc_a,p,upd,info)
! !
call psb_sp_clip(atmp,p%av(mld_ap_nd_),info,& call psb_sp_clip(atmp,p%av(mld_ap_nd_),info,&
& jmin=atmp%m+1,rscale=.false.,cscale=.false.) & jmin=atmp%m+1,rscale=.false.,cscale=.false.)
if (info == 0) call psb_spcnv(p%av(mld_ap_nd_),info,&
call psb_spcnv(p%av(mld_ap_nd_),info,afmt='csr',dupl=psb_dupl_add_) & afmt='csr',dupl=psb_dupl_add_)
if(info /= 0) then if (info /= 0) then
call psb_errpush(4010,name,a_err='psb_spcnv csr 1') call psb_errpush(4010,name,a_err='psb_spcnv')
goto 9999 goto 9999
end if end if
@ -232,14 +219,9 @@ subroutine mld_dbjac_bld(a,desc_a,p,upd,info)
end if end if
if (debugprt) then if (debug_level >= psb_debug_outer_) &
call psb_barrier(ictxt) & write(debug_unit,*) me,' ',trim(name),' Factoring rows ',&
open(40+me) & atmp%m,a%m,blck%m,atmp%ia2(atmp%m+1)-1
call psb_csprt(40+me,atmp,head='% Local matrix')
close(40+me)
endif
if (debug) write(0,*) me,' Factoring rows ',&
&atmp%m,a%m,blck%m,atmp%ia2(atmp%m+1)-1
! !
! Compute a factorization of the diagonal block of the local matrix, ! Compute a factorization of the diagonal block of the local matrix,
@ -251,48 +233,21 @@ subroutine mld_dbjac_bld(a,desc_a,p,upd,info)
! !
! ILU(k)/MILU(k)/ILU(k,t) factorization. ! ILU(k)/MILU(k)/ILU(k,t) factorization.
! !
call psb_spcnv(atmp,info,afmt='csr',dupl=psb_dupl_add_) call psb_spcnv(atmp,info,afmt='csr',dupl=psb_dupl_add_)
if (info /= 0) then if (info == 0) call mld_ilu_bld(atmp,p%desc_data,p,upd,info)
call psb_errpush(4010,name,a_err='psb_spcnv csr 2')
goto 9999
end if
call mld_ilu_bld(atmp,p%desc_data,p,upd,info)
if (info/=0) then if (info/=0) then
call psb_errpush(4010,name,a_err='mld_ilu_bld') call psb_errpush(4010,name,a_err='mld_ilu_bld')
goto 9999 goto 9999
end if end if
if (debugprt) then
open(80+me)
call psb_csprt(80+me,p%av(mld_l_pr_),head='% Local L factor')
write(80+me,*) '% Diagonal: ',p%av(mld_l_pr_)%m
do i=1,p%av(mld_l_pr_)%m
write(80+me,*) i,i,p%d(i)
enddo
call psb_csprt(80+me,p%av(mld_u_pr_),head='% Local U factor')
close(80+me)
endif
case(mld_slu_) case(mld_slu_)
! !
! LU factorization through the SuperLU package. ! LU factorization through the SuperLU package.
! !
call psb_spcnv(atmp,info,afmt='csr',dupl=psb_dupl_add_) call psb_spcnv(atmp,info,afmt='csr',dupl=psb_dupl_add_)
if (info == 0) call mld_slu_bld(atmp,p%desc_data,p,info)
if (info /= 0) then if (info /= 0) then
call psb_errpush(4010,name,a_err='psb_spcnv csr 3')
goto 9999
end if
call mld_slu_bld(atmp,p%desc_data,p,info)
if(info /= 0) then
call psb_errpush(4010,name,a_err='mld_slu_bld') call psb_errpush(4010,name,a_err='mld_slu_bld')
goto 9999 goto 9999
end if end if
@ -301,15 +256,8 @@ subroutine mld_dbjac_bld(a,desc_a,p,upd,info)
! !
! LU factorization through the UMFPACK package. ! LU factorization through the UMFPACK package.
! !
call psb_spcnv(atmp,info,afmt='csc',dupl=psb_dupl_add_) call psb_spcnv(atmp,info,afmt='csc',dupl=psb_dupl_add_)
if (info /= 0) then if (info == 0) call mld_umf_bld(atmp,p%desc_data,p,info)
call psb_errpush(4010,name,a_err='psb_spcnv csc')
goto 9999
end if
call mld_umf_bld(atmp,p%desc_data,p,info)
if(debug) write(0,*)me,': Done mld_umf_bld ',info
if (info /= 0) then if (info /= 0) then
call psb_errpush(4010,name,a_err='mld_umf_bld') call psb_errpush(4010,name,a_err='mld_umf_bld')
goto 9999 goto 9999
@ -319,19 +267,19 @@ subroutine mld_dbjac_bld(a,desc_a,p,upd,info)
! !
! Error: no factorization required. ! Error: no factorization required.
! !
info=4010 info=4001
call psb_errpush(info,name,a_err='Inconsistent prec mld_f_none_') call psb_errpush(info,name,a_err='Inconsistent prec mld_f_none_')
goto 9999 goto 9999
case default case default
info=4010 info=4001
call psb_errpush(info,name,a_err='Unknown mld_sub_solve_') call psb_errpush(info,name,a_err='Unknown mld_sub_solve_')
goto 9999 goto 9999
end select end select
call psb_sp_free(atmp,info) call psb_sp_free(atmp,info)
if(info/=0) then if (info/=0) then
call psb_errpush(4010,name,a_err='psb_sp_free') call psb_errpush(4010,name,a_err='psb_sp_free')
goto 9999 goto 9999
end if end if
@ -347,7 +295,6 @@ subroutine mld_dbjac_bld(a,desc_a,p,upd,info)
! !
select case(p%iprcparm(mld_sub_solve_)) select case(p%iprcparm(mld_sub_solve_))
case(mld_ilu_n_,mld_milu_n_,mld_ilu_t_) case(mld_ilu_n_,mld_milu_n_,mld_ilu_t_)
! !
! ILU(k)/MILU(k)/ILU(k,t) factorization. ! ILU(k)/MILU(k)/ILU(k,t) factorization.
@ -367,13 +314,13 @@ subroutine mld_dbjac_bld(a,desc_a,p,upd,info)
! given that the output from CLIP is in COO. ! given that the output from CLIP is in COO.
call psb_sp_clip(a,p%av(mld_ap_nd_),info,& call psb_sp_clip(a,p%av(mld_ap_nd_),info,&
& jmin=nrow_a+1,rscale=.false.,cscale=.false.) & jmin=nrow_a+1,rscale=.false.,cscale=.false.)
call psb_sp_clip(blck,atmp,info,& if (info == 0) call psb_sp_clip(blck,atmp,info,&
& jmin=nrow_a+1,rscale=.false.,cscale=.false.) & jmin=nrow_a+1,rscale=.false.,cscale=.false.)
call psb_rwextd(n_row,p%av(mld_ap_nd_),info,b=atmp) if (info == 0) call psb_rwextd(n_row,p%av(mld_ap_nd_),info,b=atmp)
if (info == 0) call psb_spcnv(p%av(mld_ap_nd_),info,&
call psb_spcnv(p%av(mld_ap_nd_),info,afmt='csr',dupl=psb_dupl_add_) & afmt='csr',dupl=psb_dupl_add_)
if(info /= 0) then if (info /= 0) then
call psb_errpush(4010,name,a_err='psb_spcnv csr 4') call psb_errpush(4010,name,a_err='clip & psb_spcnv csr 4')
goto 9999 goto 9999
end if end if
@ -390,45 +337,23 @@ subroutine mld_dbjac_bld(a,desc_a,p,upd,info)
end if end if
call psb_sp_free(atmp,info) call psb_sp_free(atmp,info)
end if end if
! !
! Compute the incomplete LU factorization. ! Compute the incomplete LU factorization.
! !
call mld_ilu_bld(a,desc_a,p,upd,info,blck=blck) call mld_ilu_bld(a,desc_a,p,upd,info,blck=blck)
if (info/=0) then
if(info/=0) then
call psb_errpush(4010,name,a_err='mld_ilu_bld') call psb_errpush(4010,name,a_err='mld_ilu_bld')
goto 9999 goto 9999
end if end if
if (debugprt) then
open(80+me)
call psb_csprt(80+me,p%av(mld_l_pr_),head='% Local L factor')
write(80+me,*) '% Diagonal: ',p%av(mld_l_pr_)%m
do i=1,p%av(mld_l_pr_)%m
write(80+me,*) i,i,p%d(i)
enddo
call psb_csprt(80+me,p%av(mld_u_pr_),head='% Local U factor')
close(80+me)
endif
case(mld_slu_) case(mld_slu_)
! !
! LU factorization through the SuperLU package. ! LU factorization through the SuperLU package.
! !
call psb_spcnv(a,atmp,info,afmt='coo')
if (info /= 0) then
call psb_errpush(4010,name,a_err='psb_spcnv')
goto 9999
end if
n_row = psb_cd_get_local_rows(p%desc_data) n_row = psb_cd_get_local_rows(p%desc_data)
n_col = psb_cd_get_local_cols(p%desc_data) n_col = psb_cd_get_local_cols(p%desc_data)
call psb_rwextd(n_row,atmp,info,b=blck) call psb_spcnv(a,atmp,info,afmt='coo')
if (info == 0) call psb_rwextd(n_row,atmp,info,b=blck)
! !
! In case of multiple block-Jacobi sweeps, clip into p%av(ap_nd_) ! In case of multiple block-Jacobi sweeps, clip into p%av(ap_nd_)
@ -437,11 +362,12 @@ subroutine mld_dbjac_bld(a,desc_a,p,upd,info)
! !
if (p%iprcparm(mld_smooth_sweeps_) > 1) then if (p%iprcparm(mld_smooth_sweeps_) > 1) then
call psb_sp_clip(atmp,p%av(mld_ap_nd_),info,& if (info == 0) call psb_sp_clip(atmp,p%av(mld_ap_nd_),info,&
& jmin=atmp%m+1,rscale=.false.,cscale=.false.) & jmin=atmp%m+1,rscale=.false.,cscale=.false.)
call psb_spcnv(p%av(mld_ap_nd_),info,afmt='csr',dupl=psb_dupl_add_) if (info == 0) call psb_spcnv(p%av(mld_ap_nd_),info,&
if(info /= 0) then & afmt='csr',dupl=psb_dupl_add_)
if (info /= 0) then
call psb_errpush(4010,name,a_err='psb_spcnv csr 6') call psb_errpush(4010,name,a_err='psb_spcnv csr 6')
goto 9999 goto 9999
end if end if
@ -458,19 +384,18 @@ subroutine mld_dbjac_bld(a,desc_a,p,upd,info)
p%iprcparm(mld_smooth_sweeps_) = 1 p%iprcparm(mld_smooth_sweeps_) = 1
end if end if
endif endif
! !
! Compute the LU factorization. ! Compute the LU factorization.
! !
if (info == 0) call psb_spcnv(atmp,info,afmt='csr',dupl=psb_dupl_add_) if (info == 0) call psb_spcnv(atmp,info,afmt='csr',dupl=psb_dupl_add_)
if (info == 0) call mld_slu_bld(atmp,p%desc_data,p,info) if (info == 0) call mld_slu_bld(atmp,p%desc_data,p,info)
if(info /= 0) then if (info /= 0) then
call psb_errpush(4010,name,a_err='mld_slu_bld') call psb_errpush(4010,name,a_err='mld_slu_bld')
goto 9999 goto 9999
end if end if
call psb_sp_free(atmp,info) call psb_sp_free(atmp,info)
if(info/=0) then if (info/=0) then
call psb_errpush(4010,name,a_err='psb_sp_free') call psb_errpush(4010,name,a_err='psb_sp_free')
goto 9999 goto 9999
end if end if
@ -481,23 +406,15 @@ subroutine mld_dbjac_bld(a,desc_a,p,upd,info)
! when the matrix is distributed among the processes. ! when the matrix is distributed among the processes.
! NOTE: Should have NO overlap here!!!! ! NOTE: Should have NO overlap here!!!!
! !
call psb_spcnv(a,atmp,info,afmt='csr') call psb_spcnv(a,atmp,info,afmt='csr')
if (info /= 0) then
call psb_errpush(4010,name,a_err='psb_spcnv')
goto 9999
end if
n_row = psb_cd_get_local_rows(p%desc_data)
n_col = psb_cd_get_local_cols(p%desc_data)
if (info == 0) call mld_sludist_bld(atmp,p%desc_data,p,info) if (info == 0) call mld_sludist_bld(atmp,p%desc_data,p,info)
if(info /= 0) then if (info /= 0) then
call psb_errpush(4010,name,a_err='mld_slu_bld') call psb_errpush(4010,name,a_err='mld_slu_bld')
goto 9999 goto 9999
end if end if
call psb_sp_free(atmp,info) call psb_sp_free(atmp,info)
if(info/=0) then if (info/=0) then
call psb_errpush(4010,name,a_err='psb_sp_free') call psb_errpush(4010,name,a_err='psb_sp_free')
goto 9999 goto 9999
end if end if
@ -527,13 +444,12 @@ subroutine mld_dbjac_bld(a,desc_a,p,upd,info)
call psb_sp_clip(atmp,p%av(mld_ap_nd_),info,& call psb_sp_clip(atmp,p%av(mld_ap_nd_),info,&
& jmin=atmp%m+1,rscale=.false.,cscale=.false.) & jmin=atmp%m+1,rscale=.false.,cscale=.false.)
if (info == 0) call psb_spcnv(p%av(mld_ap_nd_),info,&
call psb_spcnv(p%av(mld_ap_nd_),info,afmt='csr',dupl=psb_dupl_add_) & afmt='csr',dupl=psb_dupl_add_)
if(info /= 0) then if (info /= 0) then
call psb_errpush(4010,name,a_err='psb_spcnv csr 8') call psb_errpush(4010,name,a_err='psb_spcnv csr 8')
goto 9999 goto 9999
end if end if
k = psb_sp_get_nnzeros(p%av(mld_ap_nd_)) k = psb_sp_get_nnzeros(p%av(mld_ap_nd_))
call psb_sum(ictxt,k) call psb_sum(ictxt,k)
@ -551,19 +467,17 @@ subroutine mld_dbjac_bld(a,desc_a,p,upd,info)
! Compute the LU factorization. ! Compute the LU factorization.
! !
if (info == 0) call psb_ipcoo2csc(atmp,info,clshr=.true.) if (info == 0) call psb_ipcoo2csc(atmp,info,clshr=.true.)
if (info /= 0) then if (info == 0) call mld_umf_bld(atmp,p%desc_data,p,info)
call psb_errpush(4010,name,a_err='psb_ipcoo2csc') if (debug_level >= psb_debug_outer_) &
goto 9999 & write(debug_unit,*) me,' ',trim(name),&
end if & ': Done mld_umf_bld ',info
call mld_umf_bld(atmp,p%desc_data,p,info)
if(debug) write(0,*)me,': Done mld_umf_bld ',info
if (info /= 0) then if (info /= 0) then
call psb_errpush(4010,name,a_err='mld_umf_bld') call psb_errpush(4010,name,a_err='mld_umf_bld')
goto 9999 goto 9999
end if end if
call psb_sp_free(atmp,info) call psb_sp_free(atmp,info)
if(info/=0) then if (info/=0) then
call psb_errpush(4010,name,a_err='psb_sp_free') call psb_errpush(4010,name,a_err='psb_sp_free')
goto 9999 goto 9999
end if end if
@ -573,31 +487,30 @@ subroutine mld_dbjac_bld(a,desc_a,p,upd,info)
! !
! Error: no factorization required. ! Error: no factorization required.
! !
info=4010 info=4001
call psb_errpush(info,name,a_err='Inconsistent prec mld_f_none_') call psb_errpush(info,name,a_err='Inconsistent prec mld_f_none_')
goto 9999 goto 9999
case default case default
info=4010 info=4001
call psb_errpush(info,name,a_err='Unknown mld_sub_solve_') call psb_errpush(info,name,a_err='Unknown mld_sub_solve_')
goto 9999 goto 9999
end select end select
case default case default
info=4010 info=4001
call psb_errpush(info,name,a_err='Invalid renum_') call psb_errpush(info,name,a_err='Invalid renum_')
goto 9999 goto 9999
end select end select
call psb_sp_free(blck,info) call psb_sp_free(blck,info)
if(info/=0) then if (info /= 0) then
call psb_errpush(4010,name,a_err='psb_sp_free') call psb_errpush(4010,name,a_err='psb_sp_free')
goto 9999 goto 9999
end if end if
if (debug) write(0,*) me,'End of ilu_bld' if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),'End '
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)

22
mlprec/mld_ddiagsc_bld.f90
Unescape Escape View File

@ -72,30 +72,25 @@ subroutine mld_ddiag_bld(a,desc_a,p,upd,info)
! Local variables ! Local variables
Integer :: err, n_row, n_col,I,j,k,ictxt,& Integer :: err, n_row, n_col,I,j,k,ictxt,&
& me,np,mglob,lw, err_act & me,np,mglob,lw, err_act
integer :: int_err(5) integer :: debug_level, debug_unit
logical, parameter :: debug=.false.
integer,parameter :: iroot=0,iout=60,ilout=40
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
if(psb_get_errstatus().ne.0) return if(psb_get_errstatus().ne.0) return
info=0 info=0
err=0 err=0
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
debug_unit = psb_get_debug_unit()
debug_level = psb_get_debug_level()
name = 'mld_ddiag_bld' name = 'mld_ddiag_bld'
if (debug) write(0,*) 'Entering diagsc_bld'
info = 0 info = 0
int_err(1) = 0
ictxt = psb_cd_get_context(desc_a) ictxt = psb_cd_get_context(desc_a)
n_row = psb_cd_get_local_rows(desc_a) n_row = psb_cd_get_local_rows(desc_a)
n_col = psb_cd_get_local_cols(desc_a) n_col = psb_cd_get_local_cols(desc_a)
mglob = psb_cd_get_global_rows(desc_a) mglob = psb_cd_get_global_rows(desc_a)
if (debug) write(0,*) 'Preconditioner Blacs_gridinfo'
call psb_info(ictxt, me, np) call psb_info(ictxt, me, np)
if (debug) write(0,*) 'Precond: Diagonal' if (debug_level >= psb_debug_outer_)&
& write(debug_unit,*) me,' ',trim(name),' Enter'
call psb_realloc(n_col,p%d,info) call psb_realloc(n_col,p%d,info)
if (info /= 0) then if (info /= 0) then
@ -122,7 +117,6 @@ subroutine mld_ddiag_bld(a,desc_a,p,upd,info)
goto 9999 goto 9999
end if end if
if (debug) write(ilout+me,*) 'VDIAG ',n_row
! !
! The i-th diagonal entry of the preconditioner is set to one if the ! The i-th diagonal entry of the preconditioner is set to one if the
! corresponding entry a_ii of the sparse matrix A is zero; otherwise ! corresponding entry a_ii of the sparse matrix A is zero; otherwise
@ -134,8 +128,6 @@ subroutine mld_ddiag_bld(a,desc_a,p,upd,info)
else else
p%d(i) = done/p%d(i) p%d(i) = done/p%d(i)
endif endif
if (debug) write(ilout+me,*) i,desc_a%loc_to_glob(i), p%d(i)
end do end do
if (a%pl(1) /= 0) then if (a%pl(1) /= 0) then
@ -151,8 +143,8 @@ subroutine mld_ddiag_bld(a,desc_a,p,upd,info)
end if end if
endif endif
if (debug) write(*,*) 'Preconditioner DIAG computed OK' if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),'Done'
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
return return

35
mlprec/mld_dilu_bld.f90
Unescape Escape View File

@ -106,7 +106,7 @@ subroutine mld_dilu_bld(a,desc_a,p,upd,info,blck)
! Local Variables ! Local Variables
integer :: i, nztota, err_act, n_row, nrow_a integer :: i, nztota, err_act, n_row, nrow_a
character :: trans, unitd character :: trans, unitd
logical, parameter :: debugprt=.false., debug=.false., aggr_dump=.false. integer :: debug_level, debug_unit
integer :: ictxt,np,me integer :: ictxt,np,me
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
@ -114,10 +114,12 @@ subroutine mld_dilu_bld(a,desc_a,p,upd,info,blck)
info=0 info=0
name='mld_dilu_bld' name='mld_dilu_bld'
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
debug_unit = psb_get_debug_unit()
ictxt=psb_cd_get_context(desc_a) debug_level = psb_get_debug_level()
ictxt = psb_cd_get_context(desc_a)
call psb_info(ictxt, me, np) call psb_info(ictxt, me, np)
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),' start'
trans = 'N' trans = 'N'
unitd = 'U' unitd = 'U'
@ -145,15 +147,15 @@ subroutine mld_dilu_bld(a,desc_a,p,upd,info,blck)
goto 9999 goto 9999
end if end if
endif endif
!!$ call psb_csprt(50+me,a,head='% (A)')
nrow_a = psb_cd_get_local_rows(desc_a) nrow_a = psb_cd_get_local_rows(desc_a)
nztota = psb_sp_get_nnzeros(a) nztota = psb_sp_get_nnzeros(a)
if (present(blck)) then if (present(blck)) then
nztota = nztota + psb_sp_get_nnzeros(blck) nztota = nztota + psb_sp_get_nnzeros(blck)
end if end if
if (debug) write(0,*)me,': out get_nnzeros',nztota,a%m,a%k if (debug_level >= psb_debug_outer_) &
if (debug) call psb_barrier(ictxt) & write(debug_unit,*) me,' ',trim(name),&
& ': out get_nnzeros',nztota,a%m,a%k
n_row = p%desc_data%matrix_data(psb_n_row_) n_row = p%desc_data%matrix_data(psb_n_row_)
p%av(mld_l_pr_)%m = n_row p%av(mld_l_pr_)%m = n_row
@ -253,22 +255,6 @@ subroutine mld_dilu_bld(a,desc_a,p,upd,info,blck)
end select end select
if (debugprt) then
!
! Print out the factors on file.
!
open(80+me)
call psb_csprt(80+me,p%av(mld_l_pr_),head='% Local L factor')
write(80+me,*) '% Diagonal: ',p%av(mld_l_pr_)%m
do i=1,p%av(mld_l_pr_)%m
write(80+me,*) i,i,p%d(i)
enddo
call psb_csprt(80+me,p%av(mld_u_pr_),head='% Local U factor')
close(80+me)
endif
if (psb_sp_getifld(psb_upd_,p%av(mld_u_pr_),info) /= psb_upd_perm_) then if (psb_sp_getifld(psb_upd_,p%av(mld_u_pr_),info) /= psb_upd_perm_) then
call psb_sp_trim(p%av(mld_u_pr_),info) call psb_sp_trim(p%av(mld_u_pr_),info)
endif endif
@ -277,7 +263,8 @@ subroutine mld_dilu_bld(a,desc_a,p,upd,info,blck)
call psb_sp_trim(p%av(mld_l_pr_),info) call psb_sp_trim(p%av(mld_l_pr_),info)
endif endif
if (debug) write(0,*) me,'End of ilu_bld' if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),'End'
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
return return

11
mlprec/mld_dilu_fct.f90
Unescape Escape View File

@ -116,7 +116,6 @@ subroutine mld_dilu_fct(ialg,a,l,u,d,info,blck)
integer :: l1, l2,m,err_act integer :: l1, l2,m,err_act
type(psb_dspmat_type), pointer :: blck_ type(psb_dspmat_type), pointer :: blck_
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
logical, parameter :: debug=.false.
name='mld_dilu_fct' name='mld_dilu_fct'
info = 0 info = 0
@ -290,7 +289,6 @@ contains
integer :: i,j,k,l,low1,low2,kk,jj,ll, ktrw,err_act integer :: i,j,k,l,low1,low2,kk,jj,ll, ktrw,err_act
real(kind(1.d0)) :: dia,temp real(kind(1.d0)) :: dia,temp
integer, parameter :: nrb=16 integer, parameter :: nrb=16
logical,parameter :: debug=.false.
type(psb_dspmat_type) :: trw type(psb_dspmat_type) :: trw
integer :: int_err(5) integer :: int_err(5)
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
@ -302,7 +300,7 @@ contains
call psb_nullify_sp(trw) call psb_nullify_sp(trw)
trw%m=0 trw%m=0
trw%k=0 trw%k=0
if(debug) write(0,*)'LUINT Allocating TRW'
call psb_sp_all(trw,1,info) call psb_sp_all(trw,1,info)
if(info.ne.0) then if(info.ne.0) then
info=4010 info=4010
@ -310,20 +308,18 @@ contains
call psb_errpush(info,name,a_err=ch_err) call psb_errpush(info,name,a_err=ch_err)
goto 9999 goto 9999
end if end if
if(debug) write(0,*)'LUINT Done Allocating TRW'
lia2(1) = 1 lia2(1) = 1
uia2(1) = 1 uia2(1) = 1
l1 = 0 l1 = 0
l2 = 0 l2 = 0
m = ma+mb m = ma+mb
if(debug) write(0,*)'In DCSRLU Begin cycle',m,ma,mb
! !
! Cycle over the matrix rows ! Cycle over the matrix rows
! !
do i = 1, m do i = 1, m
if(debug) write(0,*)'LUINT: Loop index ',i,ma
d(i) = dzero d(i) = dzero
if (i <= ma) then if (i <= ma) then
@ -448,7 +444,6 @@ contains
call psb_errpush(info,name,a_err=ch_err) call psb_errpush(info,name,a_err=ch_err)
goto 9999 goto 9999
end if end if
if(debug) write(0,*)'Leaving ilu_fct'
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
return return
@ -465,7 +460,7 @@ contains
! !
! Subroutine: ilu_copyin ! Subroutine: ilu_copyin
! Version: real ! Version: real
! Note: internal subroutine of mld_dilu_fct. ! Note: internal subroutine of mld_dilu_fct
! !
! This routine copies a row of a sparse matrix A, stored in the psb_dspmat_type ! This routine copies a row of a sparse matrix A, stored in the psb_dspmat_type
! data structure a, into the arrays laspk and uaspk and into the scalar variable ! data structure a, into the arrays laspk and uaspk and into the scalar variable

14
mlprec/mld_diluk_fct.f90
Unescape Escape View File

@ -112,14 +112,11 @@ subroutine mld_diluk_fct(fill_in,ialg,a,l,u,d,info,blck)
type(psb_dspmat_type), pointer :: blck_ type(psb_dspmat_type), pointer :: blck_
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
logical, parameter :: debug=.false.
name='mld_diluk_fct' name='mld_diluk_fct'
info = 0 info = 0
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
if (debug) write(0,*) 'mld_diluk_fct: start'
! !
! Point to / allocate memory for the incomplete factorization ! Point to / allocate memory for the incomplete factorization
! !
@ -145,7 +142,6 @@ subroutine mld_diluk_fct(fill_in,ialg,a,l,u,d,info,blck)
! !
! Compute the ILU(k) or the MILU(k) factorization, depending on ialg ! Compute the ILU(k) or the MILU(k) factorization, depending on ialg
! !
if (debug) write(0,*) 'mld_diluk_fct: calling fctint'
call mld_diluk_fctint(fill_in,ialg,m,a%m,a,blck_%m,blck_,& call mld_diluk_fctint(fill_in,ialg,m,a%m,a,blck_%m,blck_,&
& d,l%aspk,l%ia1,l%ia2,u%aspk,u%ia1,u%ia2,l1,l2,info) & d,l%aspk,l%ia1,l%ia2,u%aspk,u%ia1,u%ia2,l1,l2,info)
if (info /= 0) then if (info /= 0) then
@ -289,7 +285,6 @@ contains
integer, allocatable :: uplevs(:), rowlevs(:),idxs(:) integer, allocatable :: uplevs(:), rowlevs(:),idxs(:)
real(kind(1.d0)), allocatable :: row(:) real(kind(1.d0)), allocatable :: row(:)
type(psb_int_heap) :: heap type(psb_int_heap) :: heap
logical,parameter :: debug=.false.
type(psb_dspmat_type) :: trw type(psb_dspmat_type) :: trw
character(len=20), parameter :: name='mld_diluk_fctint' character(len=20), parameter :: name='mld_diluk_fctint'
character(len=20) :: ch_err character(len=20) :: ch_err
@ -303,7 +298,6 @@ contains
! !
! Allocate a temporary buffer for the iluk_copyin function ! Allocate a temporary buffer for the iluk_copyin function
! !
if (debug) write(0,*)'LUINT Allocating TRW'
call psb_sp_all(0,0,trw,1,info) call psb_sp_all(0,0,trw,1,info)
if (info==0) call psb_ensure_size(m+1,lia2,info) if (info==0) call psb_ensure_size(m+1,lia2,info)
if (info==0) call psb_ensure_size(m+1,uia2,info) if (info==0) call psb_ensure_size(m+1,uia2,info)
@ -313,15 +307,12 @@ contains
call psb_errpush(info,name,a_err='psb_sp_all') call psb_errpush(info,name,a_err='psb_sp_all')
goto 9999 goto 9999
end if end if
if (debug) write(0,*)'LUINT Done Allocating TRW'
l1=0 l1=0
l2=0 l2=0
lia2(1) = 1 lia2(1) = 1
uia2(1) = 1 uia2(1) = 1
if (debug) write(0,*)'In DCSRLU Begin cycle',m,ma,mb
! !
! Allocate memory to hold the entries of a row and the corresponding ! Allocate memory to hold the entries of a row and the corresponding
! fill levels ! fill levels
@ -342,8 +333,6 @@ contains
! !
do i = 1, m do i = 1, m
if (debug.and.(mod(i,500)==1)) write(0,*)'LUINT: Loop index ',i,ma
! !
! At each iteration of the loop we keep in a heap the column indices ! At each iteration of the loop we keep in a heap the column indices
! affected by the factorization. The heap is initialized and filled ! affected by the factorization. The heap is initialized and filled
@ -366,8 +355,6 @@ contains
call iluk_copyin(i-ma,mb,b,1,m,row,rowlevs,heap,ktrw,trw) call iluk_copyin(i-ma,mb,b,1,m,row,rowlevs,heap,ktrw,trw)
endif endif
if (debug) write(0,*)'LUINT: input Copy done'
! Do an elimination step on the current row. It turns out we only ! Do an elimination step on the current row. It turns out we only
! need to keep track of fill levels for the upper triangle, hence we ! need to keep track of fill levels for the upper triangle, hence we
! do not have a lowlevs variable. ! do not have a lowlevs variable.
@ -398,7 +385,6 @@ contains
call psb_errpush(info,name,a_err=ch_err) call psb_errpush(info,name,a_err=ch_err)
goto 9999 goto 9999
end if end if
if (debug) write(0,*)'Leaving ilu_fct'
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
return return

42
mlprec/mld_dilut_fct.f90
Unescape Escape View File

@ -111,14 +111,11 @@ subroutine mld_dilut_fct(fill_in,thres,ialg,a,l,u,d,info,blck)
type(psb_dspmat_type), pointer :: blck_ type(psb_dspmat_type), pointer :: blck_
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
logical, parameter :: debug=.false.
name='mld_dilut_fct' name='mld_dilut_fct'
info = 0 info = 0
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
if (debug) write(0,*) 'mld_dilut_fct: start'
! !
! Point to / allocate memory for the incomplete factorization ! Point to / allocate memory for the incomplete factorization
! !
@ -144,7 +141,6 @@ subroutine mld_dilut_fct(fill_in,thres,ialg,a,l,u,d,info,blck)
! !
! Compute the ILU(k,t) factorization ! Compute the ILU(k,t) factorization
! !
if (debug) write(0,*) 'mld_dilut_fct: calling fctint'
call mld_dilut_fctint(fill_in,thres,ialg,m,a%m,a,blck_%m,blck_,& call mld_dilut_fctint(fill_in,thres,ialg,m,a%m,a,blck_%m,blck_,&
& d,l%aspk,l%ia1,l%ia2,u%aspk,u%ia1,u%ia2,l1,l2,info) & d,l%aspk,l%ia1,l%ia2,u%aspk,u%ia1,u%ia2,l1,l2,info)
if (info /= 0) then if (info /= 0) then
@ -288,7 +284,6 @@ contains
integer, allocatable :: idxs(:) integer, allocatable :: idxs(:)
real(kind(1.d0)), allocatable :: row(:) real(kind(1.d0)), allocatable :: row(:)
type(psb_int_heap) :: heap type(psb_int_heap) :: heap
logical,parameter :: debug=.false.
type(psb_dspmat_type) :: trw type(psb_dspmat_type) :: trw
character(len=20), parameter :: name='mld_dilut_fctint' character(len=20), parameter :: name='mld_dilut_fctint'
character(len=20) :: ch_err character(len=20) :: ch_err
@ -302,7 +297,6 @@ contains
! !
! Allocate a temporary buffer for the ilut_copyin function ! Allocate a temporary buffer for the ilut_copyin function
! !
if (debug) write(0,*)'LUINT Allocating TRW'
call psb_sp_all(0,0,trw,1,info) call psb_sp_all(0,0,trw,1,info)
if (info==0) call psb_ensure_size(m+1,lia2,info) if (info==0) call psb_ensure_size(m+1,lia2,info)
if (info==0) call psb_ensure_size(m+1,uia2,info) if (info==0) call psb_ensure_size(m+1,uia2,info)
@ -312,15 +306,12 @@ contains
call psb_errpush(info,name,a_err='psb_sp_all') call psb_errpush(info,name,a_err='psb_sp_all')
goto 9999 goto 9999
end if end if
if (debug) write(0,*)'LUINT Done Allocating TRW'
l1=0 l1=0
l2=0 l2=0
lia2(1) = 1 lia2(1) = 1
uia2(1) = 1 uia2(1) = 1
if (debug) write(0,*)'In DCSRLU Begin cycle',m,ma,mb
! !
! Allocate memory to hold the entries of a row ! Allocate memory to hold the entries of a row
! !
@ -338,7 +329,6 @@ contains
! !
do i = 1, m do i = 1, m
if (debug) write(0,*)'LUINT: Loop index ',i
! !
! At each iteration of the loop we keep in a heap the column indices ! At each iteration of the loop we keep in a heap the column indices
! affected by the factorization. The heap is initialized and filled ! affected by the factorization. The heap is initialized and filled
@ -354,7 +344,6 @@ contains
call ilut_copyin(i-ma,mb,b,i,1,m,nlw,nup,jmaxup,nrmi,row,heap,ktrw,trw) call ilut_copyin(i-ma,mb,b,i,1,m,nlw,nup,jmaxup,nrmi,row,heap,ktrw,trw)
endif endif
if (debug) write(0,*)'LUINT: input Copy done'
! !
! Do an elimination step on current row ! Do an elimination step on current row
! !
@ -384,7 +373,6 @@ contains
call psb_errpush(info,name,a_err=ch_err) call psb_errpush(info,name,a_err=ch_err)
goto 9999 goto 9999
end if end if
if (debug) write(0,*)'Leaving ilu_fct'
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
return return
@ -675,7 +663,6 @@ contains
! Local Variables ! Local Variables
integer :: k,j,jj,info, lastk integer :: k,j,jj,info, lastk
real(kind(1.d0)) :: rwk real(kind(1.d0)) :: rwk
logical, parameter :: debug=.false.
call psb_ensure_size(200,idxs,info) call psb_ensure_size(200,idxs,info)
@ -748,12 +735,6 @@ contains
end do end do
if (debug) then
write(0,*) 'At end of factint: ',i,nidx
write(0,*) idxs(1:nidx)
write(0,*) row(idxs(1:nidx))
end if
end subroutine ilut_fact end subroutine ilut_fact
! !
@ -870,7 +851,6 @@ contains
character(len=20), parameter :: name='mld_dilut_fctint' character(len=20), parameter :: name='mld_dilut_fctint'
character(len=20) :: ch_err character(len=20) :: ch_err
logical :: fndmaxup logical :: fndmaxup
logical, parameter :: debug=.false.
if (psb_get_errstatus() /= 0) return if (psb_get_errstatus() /= 0) return
info=0 info=0
@ -909,10 +889,6 @@ contains
if (idxs(idxp) >= i) exit if (idxs(idxp) >= i) exit
widx = idxs(idxp) widx = idxs(idxp)
witem = row(widx) witem = row(widx)
if (debug) then
write(0,*) 'Lower: Deciding on drop of item ',witem,widx,thres,nrmi,thres*nrmi
end if
! !
! Dropping rule based on the 2-norm ! Dropping rule based on the 2-norm
! !
@ -1032,11 +1008,6 @@ contains
cycle cycle
end if end if
witem = row(widx) witem = row(widx)
if (debug) then
write(0,*) 'Upper: Deciding on drop of item ',witem,widx,&
& jmaxup,thres,nrmi,thres*nrmi
end if
! !
! Dropping rule based on the 2-norm. But keep the jmaxup-th entry anyway. ! Dropping rule based on the 2-norm. But keep the jmaxup-th entry anyway.
! !
@ -1051,14 +1022,6 @@ contains
end do end do
if (debug) then
write(0,*) 'Row ',i,' copyout: after first round at upper:',nz,jmaxup
write(0,*) xwid(1:nz)
write(0,*) xw(1:nz)
write(0,*) 'Dumping heap'
call psb_dump_heap(0,heap,info)
end if
! !
! Now we have to take out the first nup-fill_in entries. But make sure ! Now we have to take out the first nup-fill_in entries. But make sure
! we include entry jmaxup. ! we include entry jmaxup.
@ -1093,11 +1056,6 @@ contains
! Now we put things back into ascending column order ! Now we put things back into ascending column order
! !
call psb_msort(xwid(1:nz),indx(1:nz),dir=psb_sort_up_) call psb_msort(xwid(1:nz),indx(1:nz),dir=psb_sort_up_)
if (debug) then
write(0,*) 'Row ',i,' copyout: after sort at upper:',nz,jmaxup
write(0,*) xwid(1:nz)
write(0,*) xw(indx(1:nz))
end if
! !
! Copy out the upper part of the row ! Copy out the upper part of the row

290
mlprec/mld_dmlprec_aply.f90
Unescape Escape View File

@ -64,11 +64,11 @@
! level 1 is the finest level and A(1) is the matrix A. ! level 1 is the finest level and A(1) is the matrix A.
! !
! For a general description of (parallel) multilevel preconditioners see ! For a general description of (parallel) multilevel preconditioners see
! 1. B.F. Smith, P.E. Bjorstad & W.D. Gropp, ! - B.F. Smith, P.E. Bjorstad & W.D. Gropp,
! Domain decomposition: parallel multilevel methods for elliptic partial ! Domain decomposition: parallel multilevel methods for elliptic partial
! differential equations, ! differential equations,
! Cambridge University Press, 1996. ! Cambridge University Press, 1996.
! 2. K. Stuben, ! - K. Stuben,
! Algebraic Multigrid (AMG): An Introduction with Applications, ! Algebraic Multigrid (AMG): An Introduction with Applications,
! GMD Report N. 70, 1999. ! GMD Report N. 70, 1999.
! !
@ -182,7 +182,7 @@ subroutine mld_dmlprec_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info)
! Local variables ! Local variables
integer :: n_row,n_col integer :: n_row,n_col
integer :: ictxt,np,me,i, nr2l,nc2l,err_act integer :: ictxt,np,me,i, nr2l,nc2l,err_act
logical, parameter :: debug=.false., debugprt=.false. integer :: debug_level, debug_unit
integer :: ismth, nlev, ilev, icm integer :: ismth, nlev, ilev, icm
character(len=20) :: name character(len=20) :: name
@ -194,12 +194,15 @@ subroutine mld_dmlprec_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info)
name='mld_dmlprec_aply' name='mld_dmlprec_aply'
info = 0 info = 0
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
debug_unit = psb_get_debug_unit()
debug_level = psb_get_debug_level()
ictxt = psb_cd_get_context(desc_data) ictxt = psb_cd_get_context(desc_data)
call psb_info(ictxt, me, np) call psb_info(ictxt, me, np)
if (debug) write(0,*) me,'Entry to mlprec_aply ',& if (debug_level >= psb_debug_inner_) &
& size(baseprecv) & write(debug_unit,*) me,' ',trim(name),&
& ' Entry ', size(baseprecv)
nlev = size(baseprecv) nlev = size(baseprecv)
allocate(mlprec_wrk(nlev),stat=info) allocate(mlprec_wrk(nlev),stat=info)
@ -215,7 +218,7 @@ subroutine mld_dmlprec_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info)
! !
! No preconditioning, should not really get here ! No preconditioning, should not really get here
! !
call psb_errpush(4010,name,a_err='mld_no_ml_ in mlprc_aply?') call psb_errpush(4001,name,a_err='mld_no_ml_ in mlprc_aply?')
goto 9999 goto 9999
@ -260,7 +263,10 @@ subroutine mld_dmlprec_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info)
! !
call mld_baseprec_aply(alpha,baseprecv(1),x,beta,y,& call mld_baseprec_aply(alpha,baseprecv(1),x,beta,y,&
& baseprecv(1)%base_desc,trans,work,info) & baseprecv(1)%base_desc,trans,work,info)
if(info /=0) goto 9999 if (info /=0) then
call psb_errpush(4010,name,a_err='baseprec_aply')
goto 9999
end if
allocate(mlprec_wrk(1)%x2l(size(x)),mlprec_wrk(1)%y2l(size(y)), stat=info) allocate(mlprec_wrk(1)%x2l(size(x)),mlprec_wrk(1)%y2l(size(y)), stat=info)
if (info /= 0) then if (info /= 0) then
@ -308,11 +314,8 @@ subroutine mld_dmlprec_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info)
! !
call psb_halo(mlprec_wrk(ilev-1)%x2l,baseprecv(ilev-1)%base_desc,& call psb_halo(mlprec_wrk(ilev-1)%x2l,baseprecv(ilev-1)%base_desc,&
& info,work=work) & info,work=work)
if(info /=0) goto 9999 if (info == 0) call psb_csmm(done,baseprecv(ilev)%av(mld_sm_pr_t_),&
call psb_csmm(done,baseprecv(ilev)%av(mld_sm_pr_t_),mlprec_wrk(ilev-1)%x2l,& & mlprec_wrk(ilev-1)%x2l,dzero,mlprec_wrk(ilev)%x2l,info)
& dzero,mlprec_wrk(ilev)%x2l,info)
if(info /=0) goto 9999
else else
! !
! Apply the raw aggregation map transpose (take a shortcut) ! Apply the raw aggregation map transpose (take a shortcut)
@ -324,11 +327,19 @@ subroutine mld_dmlprec_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info)
end do end do
end if end if
if (info /=0) then
call psb_errpush(4001,name,a_err='Error during restriction')
goto 9999
end if
if (icm == mld_repl_mat_) then if (icm == mld_repl_mat_) then
call psb_sum(ictxt,mlprec_wrk(ilev)%x2l(1:nr2l)) call psb_sum(ictxt,mlprec_wrk(ilev)%x2l(1:nr2l))
else if (icm /= mld_distr_mat_) then else if (icm /= mld_distr_mat_) then
write(0,*) 'Unknown value for baseprecv(2)%iprcparm(mld_coarse_mat_) ',icm info = 4013
call psb_errpush(info,name,a_err='invalid mld_coarse_mat_',&
& i_Err=(/icm,0,0,0,0/))
goto 9999
endif endif
! !
@ -361,8 +372,6 @@ subroutine mld_dmlprec_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info)
! !
call psb_csmm(done,baseprecv(ilev)%av(mld_sm_pr_),mlprec_wrk(ilev)%y2l,& call psb_csmm(done,baseprecv(ilev)%av(mld_sm_pr_),mlprec_wrk(ilev)%y2l,&
& done,mlprec_wrk(ilev-1)%y2l,info) & done,mlprec_wrk(ilev-1)%y2l,info)
if(info /=0) goto 9999
else else
! !
! Apply the raw aggregation map (take a shortcut) ! Apply the raw aggregation map (take a shortcut)
@ -373,6 +382,10 @@ subroutine mld_dmlprec_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info)
enddo enddo
end if end if
if (info /=0) then
call psb_errpush(4001,name,a_err='Error during prolognation')
goto 9999
end if
end do end do
! !
@ -381,8 +394,10 @@ subroutine mld_dmlprec_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info)
! Compute the output vector Y ! Compute the output vector Y
! !
call psb_geaxpby(alpha,mlprec_wrk(1)%y2l,done,y,baseprecv(1)%base_desc,info) call psb_geaxpby(alpha,mlprec_wrk(1)%y2l,done,y,baseprecv(1)%base_desc,info)
if(info /=0) goto 9999 if (info /= 0) then
call psb_errpush(4001,name,a_err='Error on final update')
goto 9999
end if
case(mld_mult_ml_) case(mld_mult_ml_)
@ -432,8 +447,9 @@ subroutine mld_dmlprec_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info)
! !
! Copy the input vector X ! Copy the input vector X
! !
if (debug) write(0,*) me, 'mlprec_aply desc_data',& if (debug_level >= psb_debug_inner_) &
& allocated(desc_data%matrix_data) & write(debug_unit,*) me,' ',trim(name),&
& ' desc_data status',allocated(desc_data%matrix_data)
n_col = psb_cd_get_local_cols(desc_data) n_col = psb_cd_get_local_cols(desc_data)
nc2l = psb_cd_get_local_cols(baseprecv(1)%desc_data) nc2l = psb_cd_get_local_cols(baseprecv(1)%desc_data)
@ -463,7 +479,9 @@ subroutine mld_dmlprec_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info)
ismth = baseprecv(ilev)%iprcparm(mld_aggr_kind_) ismth = baseprecv(ilev)%iprcparm(mld_aggr_kind_)
icm = baseprecv(ilev)%iprcparm(mld_coarse_mat_) icm = baseprecv(ilev)%iprcparm(mld_coarse_mat_)
if (debug) write(0,*) me, 'mlprec_aply starting up sweep ',& if (debug_level >= psb_debug_inner_) &
& write(debug_unit,*) me,' ',trim(name), &
& ' starting up sweep ',&
& ilev,allocated(baseprecv(ilev)%iprcparm),n_row,n_col,& & ilev,allocated(baseprecv(ilev)%iprcparm),n_row,n_col,&
& nc2l, nr2l,ismth & nc2l, nr2l,ismth
@ -485,15 +503,13 @@ subroutine mld_dmlprec_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info)
! !
! Apply the smoothed prolongator transpose ! Apply the smoothed prolongator transpose
! !
if (debug) write(0,*) me, 'mlprec_aply halo in up sweep ', ilev if (debug_level >= psb_debug_inner_) &
& write(debug_unit,*) me,' ',trim(name), ' up sweep ', ilev
call psb_halo(mlprec_wrk(ilev-1)%x2l,& call psb_halo(mlprec_wrk(ilev-1)%x2l,&
& baseprecv(ilev-1)%base_desc,info,work=work) & baseprecv(ilev-1)%base_desc,info,work=work)
if(info /=0) goto 9999 if (info == 0) call psb_csmm(done,baseprecv(ilev)%av(mld_sm_pr_t_),&
if (debug) write(0,*) me, 'mlprec_aply csmm in up sweep ', ilev & mlprec_wrk(ilev-1)%x2l,dzero,mlprec_wrk(ilev)%x2l,info)
call psb_csmm(done,baseprecv(ilev)%av(mld_sm_pr_t_),mlprec_wrk(ilev-1)%x2l, &
& dzero,mlprec_wrk(ilev)%x2l,info)
if(info /=0) goto 9999
else else
! !
! Apply the raw aggregation map transpose (take a shortcut) ! Apply the raw aggregation map transpose (take a shortcut)
@ -505,20 +521,18 @@ subroutine mld_dmlprec_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info)
end do end do
end if end if
if (info /=0) then
if (debug) write(0,*) me, 'mlprec_aply possible sum in up sweep ', & call psb_errpush(4001,name,a_err='Error during restriction')
& ilev,icm,associated(baseprecv(ilev)%base_desc),mld_repl_mat_ goto 9999
if (debug) write(0,*) me, 'mlprec_aply geaxpby in up sweep X', & end if
& ilev,associated(baseprecv(ilev)%base_desc),&
& baseprecv(ilev)%base_desc%matrix_data(psb_n_row_),&
& baseprecv(ilev)%base_desc%matrix_data(psb_n_col_),&
& size(mlprec_wrk(ilev)%tx),size(mlprec_wrk(ilev)%x2l)
if (icm == mld_repl_mat_) Then if (icm == mld_repl_mat_) Then
if (debug) write(0,*) 'Entering psb_sum ',nr2l
call psb_sum(ictxt,mlprec_wrk(ilev)%x2l(1:nr2l)) call psb_sum(ictxt,mlprec_wrk(ilev)%x2l(1:nr2l))
else if (icm /= mld_distr_mat_) Then else if (icm /= mld_distr_mat_) Then
write(0,*) 'Unknown value for baseprecv(2)%iprcparm(mld_coarse_mat_) ', icm info = 4013
call psb_errpush(info,name,a_err='invalid mld_coarse_mat_',&
& i_Err=(/icm,0,0,0,0/))
goto 9999
endif endif
! !
@ -526,9 +540,14 @@ subroutine mld_dmlprec_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info)
! !
call psb_geaxpby(done,mlprec_wrk(ilev)%x2l,dzero,mlprec_wrk(ilev)%tx,& call psb_geaxpby(done,mlprec_wrk(ilev)%x2l,dzero,mlprec_wrk(ilev)%tx,&
& baseprecv(ilev)%base_desc,info) & baseprecv(ilev)%base_desc,info)
if(info /=0) goto 9999 if (info /= 0) then
if (debug) write(0,*) me, 'mlprec_aply done up sweep ',& call psb_errpush(4001,name,a_err='Error in update')
& ilev goto 9999
end if
if (debug_level >= psb_debug_inner_) &
& write(debug_unit,*) me,' ',trim(name),&
& ' done up sweep ', ilev
enddo enddo
@ -539,10 +558,13 @@ subroutine mld_dmlprec_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info)
! !
call mld_baseprec_aply(done,baseprecv(nlev),mlprec_wrk(nlev)%x2l, & call mld_baseprec_aply(done,baseprecv(nlev),mlprec_wrk(nlev)%x2l, &
& dzero, mlprec_wrk(nlev)%y2l,baseprecv(nlev)%desc_data,'N',work,info) & dzero, mlprec_wrk(nlev)%y2l,baseprecv(nlev)%desc_data,'N',work,info)
if (info /=0) then
call psb_errpush(4010,name,a_err='baseprec_aply')
goto 9999
end if
if(info /=0) goto 9999 if (debug_level >= psb_debug_inner_) write(debug_unit,*) &
if (debug) write(0,*) me, 'mlprec_aply done prc_apl ',& & me,' ',trim(name), ' done baseprec_aply ', nlev
& nlev
! !
! STEP 4 ! STEP 4
@ -551,7 +573,10 @@ subroutine mld_dmlprec_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info)
! !
do ilev=nlev-1, 1, -1 do ilev=nlev-1, 1, -1
if (debug) write(0,*) me, 'mlprec_aply starting down sweep',ilev if (debug_level >= psb_debug_inner_) &
& write(debug_unit,*) me,' ',trim(name),&
& ' starting down sweep',ilev
ismth = baseprecv(ilev+1)%iprcparm(mld_aggr_kind_) ismth = baseprecv(ilev+1)%iprcparm(mld_aggr_kind_)
n_row = psb_cd_get_local_rows(baseprecv(ilev)%base_desc) n_row = psb_cd_get_local_rows(baseprecv(ilev)%base_desc)
@ -562,10 +587,8 @@ subroutine mld_dmlprec_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info)
if (ismth == mld_smooth_prol_) & if (ismth == mld_smooth_prol_) &
& call psb_halo(mlprec_wrk(ilev+1)%y2l,baseprecv(ilev+1)%desc_data,& & call psb_halo(mlprec_wrk(ilev+1)%y2l,baseprecv(ilev+1)%desc_data,&
& info,work=work) & info,work=work)
call psb_csmm(done,baseprecv(ilev+1)%av(mld_sm_pr_),mlprec_wrk(ilev+1)%y2l,& if (info == 0) call psb_csmm(done,baseprecv(ilev+1)%av(mld_sm_pr_),&
& dzero,mlprec_wrk(ilev)%y2l,info) & mlprec_wrk(ilev+1)%y2l, dzero,mlprec_wrk(ilev)%y2l,info)
if(info /=0) goto 9999
else else
! !
! Apply the raw aggregation map (take a shortcut) ! Apply the raw aggregation map (take a shortcut)
@ -575,7 +598,10 @@ subroutine mld_dmlprec_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info)
mlprec_wrk(ilev)%y2l(i) = mlprec_wrk(ilev)%y2l(i) + & mlprec_wrk(ilev)%y2l(i) = mlprec_wrk(ilev)%y2l(i) + &
& mlprec_wrk(ilev+1)%y2l(baseprecv(ilev+1)%mlia(i)) & mlprec_wrk(ilev+1)%y2l(baseprecv(ilev+1)%mlia(i))
enddo enddo
end if
if (info /=0) then
call psb_errpush(4001,name,a_err='Error during prolongation')
goto 9999
end if end if
! !
@ -584,16 +610,19 @@ subroutine mld_dmlprec_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info)
call psb_spmm(-done,baseprecv(ilev)%base_a,mlprec_wrk(ilev)%y2l,& call psb_spmm(-done,baseprecv(ilev)%base_a,mlprec_wrk(ilev)%y2l,&
& done,mlprec_wrk(ilev)%tx,baseprecv(ilev)%base_desc,info,work=work) & done,mlprec_wrk(ilev)%tx,baseprecv(ilev)%base_desc,info,work=work)
if(info /=0) goto 9999
! !
! Apply the base preconditioner ! Apply the base preconditioner
! !
call mld_baseprec_aply(done,baseprecv(ilev),mlprec_wrk(ilev)%tx,& if (info == 0) call mld_baseprec_aply(done,baseprecv(ilev),mlprec_wrk(ilev)%tx,&
& done,mlprec_wrk(ilev)%y2l,baseprecv(ilev)%base_desc, trans, work,info) & done,mlprec_wrk(ilev)%y2l,baseprecv(ilev)%base_desc, trans, work,info)
if (info /=0) then
call psb_errpush(4001,name,a_err=' spmm/baseprec_aply')
goto 9999
end if
if(info /=0) goto 9999 if (debug_level >= psb_debug_inner_) &
if (debug) write(0,*) me, 'mlprec_aply done down sweep',ilev & write(debug_unit,*) me,' ',trim(name),&
& ' done down sweep',ilev
enddo enddo
! !
@ -603,8 +632,10 @@ subroutine mld_dmlprec_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info)
! !
call psb_geaxpby(alpha,mlprec_wrk(1)%y2l,beta,y,baseprecv(1)%base_desc,info) call psb_geaxpby(alpha,mlprec_wrk(1)%y2l,beta,y,baseprecv(1)%base_desc,info)
if(info /=0) goto 9999 if (info /=0) then
call psb_errpush(4001,name,a_err=' Final update')
goto 9999
end if
case(mld_pre_smooth_) case(mld_pre_smooth_)
@ -675,9 +706,10 @@ subroutine mld_dmlprec_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info)
& dzero,mlprec_wrk(1)%y2l,& & dzero,mlprec_wrk(1)%y2l,&
& baseprecv(1)%base_desc,& & baseprecv(1)%base_desc,&
& trans,work,info) & trans,work,info)
if (info /=0) then
if(info /=0) goto 9999 call psb_errpush(4010,name,a_err=' baseprec_aply')
goto 9999
end if
! !
! STEP 3 ! STEP 3
@ -688,7 +720,10 @@ subroutine mld_dmlprec_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info)
call psb_spmm(-done,baseprecv(1)%base_a,mlprec_wrk(1)%y2l,& call psb_spmm(-done,baseprecv(1)%base_a,mlprec_wrk(1)%y2l,&
& done,mlprec_wrk(1)%tx,baseprecv(1)%base_desc,info,work=work) & done,mlprec_wrk(1)%tx,baseprecv(1)%base_desc,info,work=work)
if(info /=0) goto 9999 if (info /=0) then
call psb_errpush(4001,name,a_err=' fine level residual')
goto 9999
end if
! !
! STEP 4 ! STEP 4
@ -723,12 +758,8 @@ subroutine mld_dmlprec_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info)
! !
call psb_halo(mlprec_wrk(ilev-1)%tx,baseprecv(ilev-1)%base_desc,& call psb_halo(mlprec_wrk(ilev-1)%tx,baseprecv(ilev-1)%base_desc,&
& info,work=work) & info,work=work)
if(info /=0) goto 9999 if (info == 0) call psb_csmm(done,baseprecv(ilev)%av(mld_sm_pr_t_),&
& mlprec_wrk(ilev-1)%tx,dzero,mlprec_wrk(ilev)%x2l,info)
call psb_csmm(done,baseprecv(ilev)%av(mld_sm_pr_t_),mlprec_wrk(ilev-1)%tx,dzero,&
& mlprec_wrk(ilev)%x2l,info)
if(info /=0) goto 9999
else else
! !
! Apply the raw aggregation map transpose (take a shortcut) ! Apply the raw aggregation map transpose (take a shortcut)
@ -740,11 +771,18 @@ subroutine mld_dmlprec_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info)
& mlprec_wrk(ilev-1)%tx(i) & mlprec_wrk(ilev-1)%tx(i)
end do end do
end if end if
if (info /=0) then
call psb_errpush(4001,name,a_err='Error during restriction')
goto 9999
end if
if (icm ==mld_repl_mat_) then if (icm ==mld_repl_mat_) then
call psb_sum(ictxt,mlprec_wrk(ilev)%x2l(1:nr2l)) call psb_sum(ictxt,mlprec_wrk(ilev)%x2l(1:nr2l))
else if (icm /= mld_distr_mat_) then else if (icm /= mld_distr_mat_) then
write(0,*) 'Unknown value for baseprecv(2)%iprcparm(mld_coarse_mat_) ', icm info = 4013
call psb_errpush(info,name,a_err='invalid mld_coarse_mat_',&
& i_Err=(/icm,0,0,0,0/))
goto 9999
endif endif
! !
@ -753,18 +791,19 @@ subroutine mld_dmlprec_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info)
call mld_baseprec_aply(done,baseprecv(ilev),mlprec_wrk(ilev)%x2l,& call mld_baseprec_aply(done,baseprecv(ilev),mlprec_wrk(ilev)%x2l,&
& dzero,mlprec_wrk(ilev)%y2l,baseprecv(ilev)%desc_data, 'N',work,info) & dzero,mlprec_wrk(ilev)%y2l,baseprecv(ilev)%desc_data, 'N',work,info)
if(info /= 0) goto 9999
! !
! Compute the residual (at all levels but the coarsest one) ! Compute the residual (at all levels but the coarsest one)
! !
if (ilev < nlev) then if (ilev < nlev) then
mlprec_wrk(ilev)%tx = mlprec_wrk(ilev)%x2l mlprec_wrk(ilev)%tx = mlprec_wrk(ilev)%x2l
call psb_spmm(-done,baseprecv(ilev)%base_a,mlprec_wrk(ilev)%y2l,& if (info == 0) call psb_spmm(-done,baseprecv(ilev)%base_a,&
& done,mlprec_wrk(ilev)%tx,baseprecv(ilev)%base_desc,info,work=work) & mlprec_wrk(ilev)%y2l,done,mlprec_wrk(ilev)%tx,&
if(info /=0) goto 9999 & baseprecv(ilev)%base_desc,info,work=work)
endif endif
if (info /=0) then
call psb_errpush(4001,name,a_err='Error on up sweep residual')
goto 9999
end if
enddo enddo
! !
@ -784,10 +823,8 @@ subroutine mld_dmlprec_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info)
if (ismth == mld_smooth_prol_) & if (ismth == mld_smooth_prol_) &
& call psb_halo(mlprec_wrk(ilev+1)%y2l,& & call psb_halo(mlprec_wrk(ilev+1)%y2l,&
& baseprecv(ilev+1)%desc_data,info,work=work) & baseprecv(ilev+1)%desc_data,info,work=work)
call psb_csmm(done,baseprecv(ilev+1)%av(mld_sm_pr_),mlprec_wrk(ilev+1)%y2l,& if (info == 0) call psb_csmm(done,baseprecv(ilev+1)%av(mld_sm_pr_),&
& done,mlprec_wrk(ilev)%y2l,info) & mlprec_wrk(ilev+1)%y2l,done,mlprec_wrk(ilev)%y2l,info)
if(info /=0) goto 9999
else else
! !
! Apply the raw aggregation map (take a shortcut) ! Apply the raw aggregation map (take a shortcut)
@ -796,9 +833,11 @@ subroutine mld_dmlprec_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info)
mlprec_wrk(ilev)%y2l(i) = mlprec_wrk(ilev)%y2l(i) + & mlprec_wrk(ilev)%y2l(i) = mlprec_wrk(ilev)%y2l(i) + &
& mlprec_wrk(ilev+1)%y2l(baseprecv(ilev+1)%mlia(i)) & mlprec_wrk(ilev+1)%y2l(baseprecv(ilev+1)%mlia(i))
enddo enddo
end if end if
if (info /=0) then
call psb_errpush(4001,name,a_err='Error during prolongation')
goto 9999
end if
enddo enddo
! !
@ -808,8 +847,11 @@ subroutine mld_dmlprec_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info)
! !
call psb_geaxpby(alpha,mlprec_wrk(1)%y2l,beta,y,& call psb_geaxpby(alpha,mlprec_wrk(1)%y2l,beta,y,&
& baseprecv(1)%base_desc,info) & baseprecv(1)%base_desc,info)
if (info /=0) then
call psb_errpush(4001,name,a_err='Error on final update')
goto 9999
end if
if(info /=0) goto 9999
case(mld_twoside_smooth_) case(mld_twoside_smooth_)
@ -891,18 +933,18 @@ subroutine mld_dmlprec_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info)
& dzero,mlprec_wrk(1)%y2l,& & dzero,mlprec_wrk(1)%y2l,&
& baseprecv(1)%base_desc,& & baseprecv(1)%base_desc,&
& trans,work,info) & trans,work,info)
if(info /=0) goto 9999
! !
! STEP 3 ! STEP 3
! !
! Compute the residual at the finest level ! Compute the residual at the finest level
! !
mlprec_wrk(1)%ty = mlprec_wrk(1)%x2l mlprec_wrk(1)%ty = mlprec_wrk(1)%x2l
call psb_spmm(-done,baseprecv(1)%base_a,mlprec_wrk(1)%y2l,& if (info == 0) call psb_spmm(-done,baseprecv(1)%base_a,mlprec_wrk(1)%y2l,&
& done,mlprec_wrk(1)%ty,baseprecv(1)%base_desc,info,work=work) & done,mlprec_wrk(1)%ty,baseprecv(1)%base_desc,info,work=work)
if(info /=0) goto 9999 if (info /=0) then
call psb_errpush(4010,name,a_err='Fine level baseprec/residual')
goto 9999
end if
! !
! STEP 4 ! STEP 4
@ -938,11 +980,8 @@ subroutine mld_dmlprec_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info)
! !
call psb_halo(mlprec_wrk(ilev-1)%ty,baseprecv(ilev-1)%base_desc,& call psb_halo(mlprec_wrk(ilev-1)%ty,baseprecv(ilev-1)%base_desc,&
& info,work=work) & info,work=work)
if(info /=0) goto 9999 if (info == 0) call psb_csmm(done,baseprecv(ilev)%av(mld_sm_pr_t_),&
call psb_csmm(done,baseprecv(ilev)%av(mld_sm_pr_t_),mlprec_wrk(ilev-1)%ty,dzero,& & mlprec_wrk(ilev-1)%ty,dzero,mlprec_wrk(ilev)%x2l,info)
& mlprec_wrk(ilev)%x2l,info)
if(info /=0) goto 9999
else else
! !
! Apply the raw aggregation map transpose (take a shortcut) ! Apply the raw aggregation map transpose (take a shortcut)
@ -954,34 +993,41 @@ subroutine mld_dmlprec_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info)
& mlprec_wrk(ilev-1)%ty(i) & mlprec_wrk(ilev-1)%ty(i)
end do end do
end if end if
if (info /=0) then
call psb_errpush(4001,name,a_err='Error during restriction')
goto 9999
end if
if (icm == mld_repl_mat_) then if (icm == mld_repl_mat_) then
call psb_sum(ictxt,mlprec_wrk(ilev)%x2l(1:nr2l)) call psb_sum(ictxt,mlprec_wrk(ilev)%x2l(1:nr2l))
else if (icm /= mld_distr_mat_) then else if (icm /= mld_distr_mat_) then
write(0,*) 'Unknown value for baseprecv(2)%iprcparm(mld_coarse_mat_) ', icm info = 4013
call psb_errpush(info,name,a_err='invalid mld_coarse_mat_',&
& i_Err=(/icm,0,0,0,0/))
goto 9999
endif endif
call psb_geaxpby(done,mlprec_wrk(ilev)%x2l,dzero,mlprec_wrk(ilev)%tx,& call psb_geaxpby(done,mlprec_wrk(ilev)%x2l,dzero,mlprec_wrk(ilev)%tx,&
& baseprecv(ilev)%base_desc,info) & baseprecv(ilev)%base_desc,info)
if(info /=0) goto 9999
! !
! Apply the base preconditioner ! Apply the base preconditioner
! !
call mld_baseprec_aply(done,baseprecv(ilev),mlprec_wrk(ilev)%x2l,& if (info == 0) call mld_baseprec_aply(done,baseprecv(ilev),&
& dzero,mlprec_wrk(ilev)%y2l,baseprecv(ilev)%desc_data, 'N',work,info) & mlprec_wrk(ilev)%x2l,dzero,mlprec_wrk(ilev)%y2l,&
& baseprecv(ilev)%desc_data, 'N',work,info)
if(info /=0) goto 9999
! !
! Compute the residual (at all levels but the coarsest one) ! Compute the residual (at all levels but the coarsest one)
! !
if(ilev < nlev) then if(ilev < nlev) then
mlprec_wrk(ilev)%ty = mlprec_wrk(ilev)%x2l mlprec_wrk(ilev)%ty = mlprec_wrk(ilev)%x2l
call psb_spmm(-done,baseprecv(ilev)%base_a,mlprec_wrk(ilev)%y2l,& if (info == 0) call psb_spmm(-done,baseprecv(ilev)%base_a,&
& done,mlprec_wrk(ilev)%ty,baseprecv(ilev)%base_desc,info,work=work) & mlprec_wrk(ilev)%y2l,done,mlprec_wrk(ilev)%ty,&
if(info /=0) goto 9999 & baseprecv(ilev)%base_desc,info,work=work)
endif endif
if (info /=0) then
call psb_errpush(4001,name,a_err='baseprec_aply/residual')
goto 9999
end if
enddo enddo
@ -1002,10 +1048,8 @@ subroutine mld_dmlprec_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info)
if (ismth == mld_smooth_prol_) & if (ismth == mld_smooth_prol_) &
& call psb_halo(mlprec_wrk(ilev+1)%y2l,baseprecv(ilev+1)%desc_data,& & call psb_halo(mlprec_wrk(ilev+1)%y2l,baseprecv(ilev+1)%desc_data,&
& info,work=work) & info,work=work)
call psb_csmm(done,baseprecv(ilev+1)%av(mld_sm_pr_),mlprec_wrk(ilev+1)%y2l,& if (info == 0) call psb_csmm(done,baseprecv(ilev+1)%av(mld_sm_pr_),&
& done,mlprec_wrk(ilev)%y2l,info) & mlprec_wrk(ilev+1)%y2l, done,mlprec_wrk(ilev)%y2l,info)
if(info /=0) goto 9999
else else
! !
! Apply the raw aggregation map (take a shortcut) ! Apply the raw aggregation map (take a shortcut)
@ -1014,7 +1058,10 @@ subroutine mld_dmlprec_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info)
mlprec_wrk(ilev)%y2l(i) = mlprec_wrk(ilev)%y2l(i) + & mlprec_wrk(ilev)%y2l(i) = mlprec_wrk(ilev)%y2l(i) + &
& mlprec_wrk(ilev+1)%y2l(baseprecv(ilev+1)%mlia(i)) & mlprec_wrk(ilev+1)%y2l(baseprecv(ilev+1)%mlia(i))
enddo enddo
end if
if (info /=0 ) then
call psb_errpush(4001,name,a_err='Error during restriction')
goto 9999
end if end if
! !
@ -1022,17 +1069,15 @@ subroutine mld_dmlprec_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info)
! !
call psb_spmm(-done,baseprecv(ilev)%base_a,mlprec_wrk(ilev)%y2l,& call psb_spmm(-done,baseprecv(ilev)%base_a,mlprec_wrk(ilev)%y2l,&
& done,mlprec_wrk(ilev)%tx,baseprecv(ilev)%base_desc,info,work=work) & done,mlprec_wrk(ilev)%tx,baseprecv(ilev)%base_desc,info,work=work)
if(info /=0) goto 9999
! !
! Apply the base preconditioner ! Apply the base preconditioner
! !
call mld_baseprec_aply(done,baseprecv(ilev),mlprec_wrk(ilev)%tx,& if (info == 0) call mld_baseprec_aply(done,baseprecv(ilev),mlprec_wrk(ilev)%tx,&
& done,mlprec_wrk(ilev)%y2l,baseprecv(ilev)%base_desc, trans, work,info) & done,mlprec_wrk(ilev)%y2l,baseprecv(ilev)%base_desc, trans, work,info)
if (info /= 0) then
if(info /=0) goto 9999 call psb_errpush(4001,name,a_err='Error: residual/baseprec_aply')
goto 9999
end if
enddo enddo
! !
@ -1043,30 +1088,37 @@ subroutine mld_dmlprec_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info)
call psb_geaxpby(alpha,mlprec_wrk(1)%y2l,beta,y,& call psb_geaxpby(alpha,mlprec_wrk(1)%y2l,beta,y,&
& baseprecv(1)%base_desc,info) & baseprecv(1)%base_desc,info)
if(info /=0) goto 9999 if (info /= 0) then
call psb_errpush(4001,name,a_err='Error final update')
goto 9999
end if
case default case default
info = 4013
call psb_errpush(4013,name,a_err='wrong smooth_pos',& call psb_errpush(info,name,a_err='invalid smooth_pos',&
& i_Err=(/baseprecv(2)%iprcparm(mld_smooth_pos_),0,0,0,0/)) & i_Err=(/baseprecv(2)%iprcparm(mld_smooth_pos_),0,0,0,0/))
goto 9999 goto 9999
end select end select
case default case default
call psb_errpush(4013,name,a_err='wrong mltype',& info = 4013
call psb_errpush(info,name,a_err='invalid mltype',&
& i_Err=(/baseprecv(2)%iprcparm(mld_ml_type_),0,0,0,0/)) & i_Err=(/baseprecv(2)%iprcparm(mld_ml_type_),0,0,0,0/))
goto 9999 goto 9999
end select end select
deallocate(mlprec_wrk) deallocate(mlprec_wrk,stat=info)
if (info /= 0) then
call psb_errpush(4000,name)
goto 9999
end if
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
return return
9999 continue 9999 continue
call psb_errpush(info,name)
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()

27
mlprec/mld_dmlprec_bld.f90
Unescape Escape View File

@ -73,16 +73,15 @@ subroutine mld_dmlprec_bld(a,desc_a,p,info)
integer :: err_act integer :: err_act
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
logical, parameter :: debug=.false.
type(psb_dspmat_type) :: ac type(psb_dspmat_type) :: ac
integer :: ictxt, np, me integer :: ictxt, np, me
name='psb_dmlprec_bld' name='psb_dmlprec_bld'
if (psb_get_errstatus().ne.0) return if (psb_get_errstatus().ne.0) return
call psb_erractionsave(err_act)
info = 0 info = 0
ictxt = psb_cd_get_context(desc_a) ictxt = psb_cd_get_context(desc_a)
call psb_info(ictxt,me,np) call psb_info(ictxt,me,np)
call psb_erractionsave(err_act)
if (.not.allocated(p%iprcparm)) then if (.not.allocated(p%iprcparm)) then
info = 2222 info = 2222
@ -120,14 +119,10 @@ subroutine mld_dmlprec_bld(a,desc_a,p,info)
! !
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_),a,desc_a,p%nlaggr,p%mlia,info)
if(info /= 0) then if(info /= 0) then
info=4010 call psb_errpush(4010,name,a_err='mld_aggrmap_bld')
ch_err='mld_aggrmap_bld'
call psb_errpush(info,name,a_err=ch_err)
goto 9999 goto 9999
end if end if
if (debug) write(0,*) 'Out from genaggrmap',p%nlaggr
! !
! Build the coarse-level matrix from the fine level one, starting from ! Build the coarse-level matrix from the fine level one, starting from
! the mapping defined by mld_aggrmap_bld and applying the aggregation ! the mapping defined by mld_aggrmap_bld and applying the aggregation
@ -137,22 +132,16 @@ subroutine mld_dmlprec_bld(a,desc_a,p,info)
call psb_nullify_desc(desc_ac) call psb_nullify_desc(desc_ac)
call mld_aggrmat_asb(a,desc_a,ac,desc_ac,p,info) call mld_aggrmat_asb(a,desc_a,ac,desc_ac,p,info)
if(info /= 0) then if(info /= 0) then
info=4010 call psb_errpush(4010,name,a_err='mld_aggrmat_asb')
ch_err='mld_aggrmat_asb'
call psb_errpush(info,name,a_err=ch_err)
goto 9999 goto 9999
end if end if
if (debug) write(0,*) 'Out from bldaggrmat',desc_ac%matrix_data(:)
! !
! Build the 'base preconditioner' corresponding to the coarse level ! Build the 'base preconditioner' corresponding to the coarse level
! !
call mld_baseprc_bld(ac,desc_ac,p,info) call mld_baseprc_bld(ac,desc_ac,p,info)
if (debug) write(0,*) 'Out from baseprcbld',info if (info /= 0) then
if(info /= 0) then call psb_errpush(4010,name,a_err='mld_baseprc_bld')
info=4010
ch_err='mld_baseprc_bld'
call psb_errpush(info,name,a_err=ch_err)
goto 9999 goto 9999
end if end if
@ -165,12 +154,10 @@ subroutine mld_dmlprec_bld(a,desc_a,p,info)
! !
call psb_sp_transfer(ac,p%av(mld_ac_),info) call psb_sp_transfer(ac,p%av(mld_ac_),info)
p%base_a => p%av(mld_ac_) p%base_a => p%av(mld_ac_)
call psb_cdtransfer(desc_ac,p%desc_ac,info) if (info==0) call psb_cdtransfer(desc_ac,p%desc_ac,info)
if (info /= 0) then if (info /= 0) then
info=4010 call psb_errpush(4010,name,a_err='psb_cdtransfer')
ch_err='psb_cdtransfer'
call psb_errpush(info,name,a_err=ch_err)
goto 9999 goto 9999
end if end if
p%base_desc => p%desc_ac p%base_desc => p%desc_ac

34
mlprec/mld_dprec_aply.f90
Unescape Escape View File

@ -66,7 +66,8 @@
! If trans='N','n' then op(M^(-1)) = M^(-1); ! If trans='N','n' then op(M^(-1)) = M^(-1);
! if trans='T','t' then op(M^(-1)) = M^(-T) (transpose of M^(-1)). ! if trans='T','t' then op(M^(-1)) = M^(-T) (transpose of M^(-1)).
! work - real(kind(0.d0)), dimension (:), optional, target. ! work - real(kind(0.d0)), dimension (:), optional, target.
! Workspace. Its size must be at least 4*psb_cd_get_local_cols(desc_data). ! Workspace. Its size must be at
! least 4*psb_cd_get_local_cols(desc_data).
! !
subroutine mld_dprec_aply(prec,x,y,desc_data,info,trans,work) subroutine mld_dprec_aply(prec,x,y,desc_data,info,trans,work)
@ -88,7 +89,6 @@ subroutine mld_dprec_aply(prec,x,y,desc_data,info,trans,work)
character :: trans_ character :: trans_
real(kind(1.d0)), pointer :: work_(:) real(kind(1.d0)), pointer :: work_(:)
integer :: ictxt,np,me,err_act,iwsz integer :: ictxt,np,me,err_act,iwsz
logical,parameter :: debug=.false., debugprt=.false.
character(len=20) :: name character(len=20) :: name
name='mld_dprec_aply' name='mld_dprec_aply'
@ -118,10 +118,12 @@ subroutine mld_dprec_aply(prec,x,y,desc_data,info,trans,work)
end if end if
if (.not.(allocated(prec%baseprecv))) then if (.not.(allocated(prec%baseprecv))) then
write(0,*) 'Inconsistent preconditioner: neither ML nor BASE?' !! Error 1: should call mld_dprecbld
info=3112
call psb_errpush(info,name)
goto 9999
end if end if
if (size(prec%baseprecv) >1) then if (size(prec%baseprecv) >1) then
if (debug) write(0,*) 'Into mlprec_aply',size(x),size(y)
call mld_mlprec_aply(done,prec%baseprecv,x,dzero,y,desc_data,trans_,work_,info) call mld_mlprec_aply(done,prec%baseprecv,x,dzero,y,desc_data,trans_,work_,info)
if(info /= 0) then if(info /= 0) then
call psb_errpush(4010,name,a_err='mld_dmlprec_aply') call psb_errpush(4010,name,a_err='mld_dmlprec_aply')
@ -131,7 +133,10 @@ subroutine mld_dprec_aply(prec,x,y,desc_data,info,trans,work)
else if (size(prec%baseprecv) == 1) then else if (size(prec%baseprecv) == 1) then
call mld_baseprec_aply(done,prec%baseprecv(1),x,dzero,y,desc_data,trans_, work_,info) call mld_baseprec_aply(done,prec%baseprecv(1),x,dzero,y,desc_data,trans_, work_,info)
else else
write(0,*) 'Inconsistent preconditioner: size of baseprecv???' info = 4013
call psb_errpush(info,name,a_err='Invalid size of baseprecv',&
& i_Err=(/size(prec%baseprecv),0,0,0,0/))
goto 9999
endif endif
if (present(work)) then if (present(work)) then
@ -200,7 +205,6 @@ subroutine mld_dprec_aply1(prec,x,desc_data,info,trans)
character(len=1), optional :: trans character(len=1), optional :: trans
! Local variables ! Local variables
logical,parameter :: debug=.false., debugprt=.false.
character :: trans_ character :: trans_
integer :: ictxt,np,me, err_act integer :: ictxt,np,me, err_act
real(kind(1.d0)), pointer :: WW(:), w1(:) real(kind(1.d0)), pointer :: WW(:), w1(:)
@ -226,17 +230,25 @@ subroutine mld_dprec_aply1(prec,x,desc_data,info,trans)
& a_err='real(kind(1.d0))') & a_err='real(kind(1.d0))')
goto 9999 goto 9999
end if end if
if (debug) write(0,*) 'prec_aply1 size(x) ',size(x), size(ww),size(w1)
call mld_dprec_aply(prec,x,ww,desc_data,info,trans_,work=w1) call mld_precaply(prec,x,ww,desc_data,info,trans_,work=w1)
if(info /=0) goto 9999 if (info /= 0) then
call psb_errpush(4010,name,a_err='mld_precaply')
goto 9999
end if
x(:) = ww(:) x(:) = ww(:)
deallocate(ww,W1) deallocate(ww,W1,stat=info)
if (info /= 0) then
info = 4000
call psb_errpush(info,name)
goto 9999
end if
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
return return
9999 continue 9999 continue
call psb_errpush(info,name)
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()

110
mlprec/mld_dprecbld.f90
Unescape Escape View File

@ -41,7 +41,7 @@
! Contains: subroutine init_baseprc_av ! Contains: subroutine init_baseprc_av
! !
! This routine builds the preconditioner according to the requirements made by ! This routine builds the preconditioner according to the requirements made by
! the user trough the subroutines mld_dprecinit and mld_dprecset. ! the user trough the subroutines mld_precinit and mld_precset.
! !
! A multilevel preconditioner is regarded as an array of 'base preconditioners', ! A multilevel preconditioner is regarded as an array of 'base preconditioners',
! each representing the part of the preconditioner associated to a certain level. ! each representing the part of the preconditioner associated to a certain level.
@ -76,32 +76,36 @@ subroutine mld_dprecbld(a,desc_a,p,info,upd)
character, intent(in), optional :: upd character, intent(in), optional :: upd
! Local Variables ! Local Variables
Integer :: err,i,k,ictxt, me,np, err_act Integer :: err,i,k,ictxt, me,np, err_act, iszv
integer :: int_err(5) integer :: int_err(5)
character :: iupd character :: iupd
logical, parameter :: debug=.false. integer :: debug_level, debug_unit
integer,parameter :: iroot=0,iout=60,ilout=40
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
if(psb_get_errstatus().ne.0) return if (psb_get_errstatus().ne.0) return
info=0 info=0
err=0 err=0
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
name = 'mld_dprecbld' debug_unit = psb_get_debug_unit()
debug_level = psb_get_debug_level()
if (debug) write(0,*) 'Entering precbld',desc_a%matrix_data(:) name = 'mld_dprecbld'
info = 0 info = 0
int_err(1) = 0 int_err(1) = 0
ictxt = psb_cd_get_context(desc_a) ictxt = psb_cd_get_context(desc_a)
if (debug) write(0,*) 'Preconditioner psb_info'
call psb_info(ictxt, me, np) call psb_info(ictxt, me, np)
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'Entering ',desc_a%matrix_data(:)
if (present(upd)) then if (present(upd)) then
if (debug) write(0,*) 'UPD ', upd if (debug_level >= psb_debug_outer_) &
if ((upd.eq.'F').or.(upd.eq.'T')) then & write(debug_unit,*) me,' ',trim(name),'UPD ', upd
iupd=upd
if ((toupper(upd).eq.'F').or.(toupper(upd).eq.'T')) then
iupd=toupper(upd)
else else
iupd='F' iupd='F'
endif endif
@ -110,86 +114,81 @@ subroutine mld_dprecbld(a,desc_a,p,info,upd)
endif endif
if (.not.allocated(p%baseprecv)) then if (.not.allocated(p%baseprecv)) then
!! Error 1: should call mld_dprecset !! Error: should have called mld_dprecinit
info=4010 info=3111
ch_err='unallocated bpv' call psb_errpush(info,name)
call psb_errpush(info,name,a_err=ch_err)
goto 9999 goto 9999
end if end if
! !
! Should add check to ensure all procs have the same ... ! Check to ensure all procs have the same
! !
iszv = size(p%baseprecv)
call psb_bcast(ictxt,iszv)
if (iszv /= size(p%baseprecv)) then
info=4001
call psb_errpush(info,name,a_err='Inconsistent size of baseprecv')
goto 9999
end if
if (size(p%baseprecv) >= 1) then if (iszv >= 1) then
! !
! Allocate the av component of the preconditioner data type ! Allocate and build the fine level preconditioner
! at the finest level
! !
call init_baseprc_av(p%baseprecv(1),info) call init_baseprc_av(p%baseprecv(1),info)
if (info == 0) call mld_baseprc_bld(a,desc_a,p%baseprecv(1),info,iupd)
if (info /= 0) then if (info /= 0) then
info=4010 call psb_errpush(4001,name,a_err='Base level precbuild.')
ch_err='allocate'
call psb_errpush(info,name,a_err=ch_err)
goto 9999 goto 9999
endif end if
!
! Build the base preconditioner corresponding to the finest
! level
!
call mld_baseprc_bld(a,desc_a,p%baseprecv(1),info,iupd)
else else
info=4010 info=4010
ch_err='size bpv' ch_err='size bpv'
call psb_errpush(info,name,a_err=ch_err) call psb_errpush(info,name,a_err=ch_err)
goto 9999 goto 9999
endif endif
if (size(p%baseprecv) > 1) then if (iszv > 1) then
! !
! Build the base preconditioners corresponding to the remaining ! Build the base preconditioners corresponding to the remaining
! levels ! levels
! !
do i=2, size(p%baseprecv) do i=2, iszv
! !
! Allocate the av component of the preconditioner data type ! Allocate the av component of the preconditioner data type
! at level i ! at level i
! !
call init_baseprc_av(p%baseprecv(i),info) if (i<iszv) then
if (info /= 0) then
info=4010
ch_err='allocate'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
endif
if (i<size(p%baseprecv)) then
! !
! A replicated matrix only makes sense at the coarsest level ! A replicated matrix only makes sense at the coarsest level
! !
call mld_check_def(p%baseprecv(i)%iprcparm(mld_coarse_mat_),'Coarse matrix',& call mld_check_def(p%baseprecv(i)%iprcparm(mld_coarse_mat_),'Coarse matrix',&
& mld_distr_mat_,is_distr_ml_coarse_mat) & mld_distr_mat_,is_distr_ml_coarse_mat)
end if end if
call init_baseprc_av(p%baseprecv(i),info)
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'Calling mlprcbld at level ',i
! !
! Build the base preconditioner corresponding to level i ! Build the base preconditioner corresponding to level i
! !
call mld_mlprec_bld(p%baseprecv(i-1)%base_a,p%baseprecv(i-1)%base_desc,& if (info == 0) call mld_mlprec_bld(p%baseprecv(i-1)%base_a,&
& p%baseprecv(i),info) & p%baseprecv(i-1)%base_desc, p%baseprecv(i),info)
if (info /= 0) then if (info /= 0) then
info=4010 call psb_errpush(4001,name,a_err='Init & build upper level preconditioner')
call psb_errpush(info,name)
goto 9999 goto 9999
endif endif
if (debug) then
write(0,*) 'Return from ',i-1,' call to mlprcbld ',info
endif
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'Return from ',i,' call to mlprcbld ',info
end do end do
endif endif
@ -211,12 +210,15 @@ contains
type(mld_dbaseprc_type), intent(inout) :: p type(mld_dbaseprc_type), intent(inout) :: p
integer :: info integer :: info
if (allocated(p%av)) then if (allocated(p%av)) then
! if (size(p%av) /= mld_max_avsz_) then
! We have not yet decided what to do deallocate(p%av,stat=info)
! if (info /= 0) return
endif
end if end if
if (.not.(allocated(p%av))) then
allocate(p%av(mld_max_avsz_),stat=info) allocate(p%av(mld_max_avsz_),stat=info)
!!$ if (info /= 0) return if (info /= 0) return
end if
do k=1,size(p%av) do k=1,size(p%av)
call psb_nullify_sp(p%av(k)) call psb_nullify_sp(p%av(k))
end do end do

3
mlprec/mld_dprecinit.f90
Unescape Escape View File

@ -182,9 +182,6 @@ subroutine mld_dprecinit(p,ptype,info,nlev)
else else
nlev_ = 2 nlev_ = 2
end if end if
if (nlev_ == 1) then
write(0,*) 'Warning: requested ML preconditioner with NLEV=1'
endif
ilev_ = 1 ilev_ = 1
allocate(p%baseprecv(nlev_),stat=info) allocate(p%baseprecv(nlev_),stat=info)
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)

19
mlprec/mld_dprecset.f90
Unescape Escape View File

@ -87,8 +87,7 @@ subroutine mld_dprecseti(p,what,val,info,ilev)
info = 0 info = 0
if (.not.allocated(p%baseprecv)) then if (.not.allocated(p%baseprecv)) then
write(0,*) 'Error: trying to call PRECSET on an uninitialized preconditioner' info = 3111
info = -1
return return
endif endif
nlev_ = size(p%baseprecv) nlev_ = size(p%baseprecv)
@ -100,13 +99,11 @@ subroutine mld_dprecseti(p,what,val,info,ilev)
end if end if
if ((ilev_<1).or.(ilev_ > nlev_)) then if ((ilev_<1).or.(ilev_ > nlev_)) then
write(0,*) 'PRECSET ERRROR: ilev out of bounds'
info = -1 info = -1
return return
endif endif
if (.not.allocated(p%baseprecv(ilev_)%iprcparm)) then if (.not.allocated(p%baseprecv(ilev_)%iprcparm)) then
write(0,*) 'Error: trying to call PRECSET on an uninitialized preconditioner' info = 3111
info = -1
return return
endif endif
@ -251,8 +248,7 @@ subroutine mld_dprecsetc(p,what,string,info,ilev)
info = 0 info = 0
if (.not.allocated(p%baseprecv)) then if (.not.allocated(p%baseprecv)) then
write(0,*) 'Error: trying to call PRECSET on an uninitialized preconditioner' info = 3111
info = -1
return return
endif endif
nlev_ = size(p%baseprecv) nlev_ = size(p%baseprecv)
@ -269,8 +265,7 @@ subroutine mld_dprecsetc(p,what,string,info,ilev)
return return
endif endif
if (.not.allocated(p%baseprecv(ilev_)%iprcparm)) then if (.not.allocated(p%baseprecv(ilev_)%iprcparm)) then
write(0,*) 'Error: trying to call PRECSET on an uninitialized preconditioner' info = 3111
info = -1
return return
endif endif
@ -445,8 +440,7 @@ subroutine mld_dprecsetd(p,what,val,info,ilev)
end if end if
if (.not.allocated(p%baseprecv)) then if (.not.allocated(p%baseprecv)) then
write(0,*) 'Error: trying to call PRECSET on an uninitialized preconditioner' info = 3111
info = -1
return return
endif endif
nlev_ = size(p%baseprecv) nlev_ = size(p%baseprecv)
@ -457,8 +451,7 @@ subroutine mld_dprecsetd(p,what,val,info,ilev)
return return
endif endif
if (.not.allocated(p%baseprecv(ilev_)%dprcparm)) then if (.not.allocated(p%baseprecv(ilev_)%dprcparm)) then
write(0,*) 'Error: trying to call PRECSET on an uninitialized preconditioner' info = 3111
info = -1
return return
endif endif

17
mlprec/mld_dslu_bld.f90
Unescape Escape View File

@ -82,7 +82,6 @@ subroutine mld_dslu_bld(a,desc_a,p,info)
! Local variables ! Local variables
integer :: nzt,ictxt,me,np,err_act integer :: nzt,ictxt,me,np,err_act
logical, parameter :: debug=.false.
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
if(psb_get_errstatus().ne.0) return if(psb_get_errstatus().ne.0) return
@ -95,19 +94,12 @@ subroutine mld_dslu_bld(a,desc_a,p,info)
call psb_info(ictxt, me, np) call psb_info(ictxt, me, np)
if (toupper(a%fida) /= 'CSR') then if (toupper(a%fida) /= 'CSR') then
write(0,*) 'Unimplemented input to mld_slu_BLD' info=135
call psb_errpush(info,name,a_err=a%fida)
goto 9999 goto 9999
endif endif
nzt = psb_sp_get_nnzeros(a) nzt = psb_sp_get_nnzeros(a)
if (Debug) then
write(0,*) me,'Calling mld_slu_factor ',nzt,a%m,&
& a%k,p%desc_data%matrix_data(psb_n_row_)
call psb_barrier(ictxt)
endif
! !
! Compute the LU factorization ! Compute the LU factorization
! !
@ -120,11 +112,6 @@ subroutine mld_dslu_bld(a,desc_a,p,info)
goto 9999 goto 9999
end if end if
if (Debug) then
write(0,*) me, 'SPLUBLD: Done mld_slu_Factor',info,p%iprcparm(mld_slu_ptr_)
call psb_barrier(ictxt)
endif
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
return return

4
mlprec/mld_dslud_bld.f90
Unescape Escape View File

@ -80,7 +80,6 @@ subroutine mld_dsludist_bld(a,desc_a,p,info)
! Local variables ! Local variables
integer :: nzt,ictxt,me,np,err_act,& integer :: nzt,ictxt,me,np,err_act,&
& mglob,ifrst,ibcheck,nrow,ncol,npr,npc & mglob,ifrst,ibcheck,nrow,ncol,npr,npc
logical, parameter :: debug=.false.
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
if (psb_get_errstatus().ne.0) return if (psb_get_errstatus().ne.0) return
@ -93,7 +92,8 @@ subroutine mld_dsludist_bld(a,desc_a,p,info)
call psb_info(ictxt, me, np) call psb_info(ictxt, me, np)
if (toupper(a%fida) /= 'CSR') then if (toupper(a%fida) /= 'CSR') then
write(0,*) 'Unimplemented input to mld_slu_BLD' info=135
call psb_errpush(info,name,a_err=a%fida)
goto 9999 goto 9999
endif endif

16
mlprec/mld_dumf_bld.f90
Unescape Escape View File

@ -89,7 +89,6 @@ subroutine mld_dumf_bld(a,desc_a,p,info)
! Local variables ! Local variables
integer :: nzt,ictxt,me,np,err_act integer :: nzt,ictxt,me,np,err_act
integer :: i_err(5) integer :: i_err(5)
logical, parameter :: debug=.false.
character(len=20) :: name character(len=20) :: name
info=0 info=0
@ -104,18 +103,8 @@ subroutine mld_dumf_bld(a,desc_a,p,info)
goto 9999 goto 9999
endif endif
nzt = psb_sp_get_nnzeros(a) nzt = psb_sp_get_nnzeros(a)
if (Debug) then
write(0,*) me,'Calling mld_umf_factor ',nzt,a%m,&
& a%k,p%desc_data%matrix_data(psb_n_row_)
open(80+me)
call psb_csprt(80+me,a)
close(80+me)
call psb_barrier(ictxt)
endif
! !
! Compute the LU factorization ! Compute the LU factorization
! !
@ -130,11 +119,6 @@ subroutine mld_dumf_bld(a,desc_a,p,info)
goto 9999 goto 9999
end if end if
if (Debug) then
write(0,*) me, 'UMFBLD: Done mld_umf_Factor',info,p%iprcparm(mld_umf_numptr_)
call psb_barrier(ictxt)
endif
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
return return

110
mlprec/mld_zaggrmap_bld.f90
Unescape Escape View File

@ -41,7 +41,7 @@
! !
! This routine builds a mapping from the row indices of the fine-level matrix ! This routine builds a mapping from the row indices of the fine-level matrix
! to the row indices of the coarse-level matrix, according to a decoupled ! to the row indices of the coarse-level matrix, according to a decoupled
! aggregation algorithm. This mapping will be used by mld_daggrmat_asb to ! aggregation algorithm. This mapping will be used by mld_aggrmat_asb to
! build the coarse-level matrix. ! build the coarse-level matrix.
! !
! The aggregation algorithm is a parallel version of that described in ! The aggregation algorithm is a parallel version of that described in
@ -93,16 +93,17 @@ subroutine mld_zaggrmap_bld(aggr_type,a,desc_a,nlaggr,ilaggr,info)
type(psb_zspmat_type), pointer :: apnt type(psb_zspmat_type), pointer :: apnt
logical :: recovery logical :: recovery
logical, parameter :: debug=.false. integer :: debug_level, debug_unit
integer ::ictxt,np,me,err_act integer :: ictxt,np,me,err_act
integer :: nrow, ncol, n_ne integer :: nrow, ncol, n_ne
integer, parameter :: one=1, two=2
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 = 'mld_aggrmap_bld' name = 'mld_aggrmap_bld'
call psb_erractionsave(err_act) 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 ! Note. At the time being we are ignoring aggr_type so
! that we only have decoupled aggregation. This might ! that we only have decoupled aggregation. This might
@ -116,10 +117,9 @@ subroutine mld_zaggrmap_bld(aggr_type,a,desc_a,nlaggr,ilaggr,info)
select case (aggr_type) select case (aggr_type)
case (mld_dec_aggr_,mld_sym_dec_aggr_) case (mld_dec_aggr_,mld_sym_dec_aggr_)
nr = a%m nr = a%m
allocate(ilaggr(nr),neigh(nr),stat=info) allocate(ilaggr(nr),neigh(nr),stat=info)
if(info.ne.0) then if(info /= 0) then
info=4025 info=4025
call psb_errpush(info,name,i_err=(/2*nr,0,0,0,0/),& call psb_errpush(info,name,i_err=(/2*nr,0,0,0,0/),&
& a_err='integer') & a_err='integer')
@ -136,13 +136,19 @@ subroutine mld_zaggrmap_bld(aggr_type,a,desc_a,nlaggr,ilaggr,info)
& rscale=.false.,cscale=.false.) & rscale=.false.,cscale=.false.)
atmp%m=nr atmp%m=nr
atmp%k=nr atmp%k=nr
call psb_transp(atmp,atrans,fmt='COO') if (info == 0) call psb_transp(atmp,atrans,fmt='COO')
call psb_rwextd(nr,atmp,info,b=atrans,rowscale=.false.) if (info == 0) call psb_rwextd(nr,atmp,info,b=atrans,rowscale=.false.)
atmp%m=nr atmp%m=nr
atmp%k=nr atmp%k=nr
call psb_sp_free(atrans,info) if (info == 0) call psb_sp_free(atrans,info)
call psb_ipcoo2csr(atmp,info) if (info == 0) call psb_ipcoo2csr(atmp,info)
apnt => atmp apnt => atmp
if (info/=0) then
info=4001
call psb_errpush(info,name,a_err='init apnt')
goto 9999
end if
end if end if
@ -168,11 +174,10 @@ subroutine mld_zaggrmap_bld(aggr_type,a,desc_a,nlaggr,ilaggr,info)
naggr = naggr + 1 naggr = naggr + 1
ilaggr(i) = naggr ilaggr(i) = naggr
call psb_neigh(apnt,i,neigh,n_ne,info,lev=one) call psb_neigh(apnt,i,neigh,n_ne,info,lev=1)
if (info/=0) then if (info/=0) then
info=4010 info=4010
ch_err='psb_neigh' call psb_errpush(info,name,a_err='psb_neigh')
call psb_errpush(info,name,a_err=ch_err)
goto 9999 goto 9999
end if end if
do k=1, n_ne do k=1, n_ne
@ -184,11 +189,10 @@ subroutine mld_zaggrmap_bld(aggr_type,a,desc_a,nlaggr,ilaggr,info)
! !
! 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=two) call psb_neigh(apnt,i,neigh,n_ne,info,lev=2)
if (info/=0) then if (info/=0) then
info=4010 info=4010
ch_err='psb_neigh' call psb_errpush(info,name,a_err='psb_neigh')
call psb_errpush(info,name,a_err=ch_err)
goto 9999 goto 9999
end if end if
@ -203,15 +207,17 @@ subroutine mld_zaggrmap_bld(aggr_type,a,desc_a,nlaggr,ilaggr,info)
nlp = nlp + 1 nlp = nlp + 1
if (icnt == 0) exit if (icnt == 0) exit
enddo enddo
if (debug) then if (debug_level >= psb_debug_outer_) then
write(0,*) 'Check 1:',count(ilaggr == -(nr+1)),(a%ia1(i),i=a%ia2(1),a%ia2(2)-1) write(debug_unit,*) me,' ',trim(name),&
& ' Check 1:',count(ilaggr == -(nr+1)),&
& (a%ia1(i),i=a%ia2(1),a%ia2(2)-1)
end if end if
! !
! Phase two: sweep over leftovers. ! Phase two: sweep over leftovers.
! !
allocate(ils(naggr+10),stat=info) allocate(ils(naggr+10),stat=info)
if(info.ne.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/),&
& a_err='integer') & a_err='integer')
@ -225,16 +231,20 @@ subroutine mld_zaggrmap_bld(aggr_type,a,desc_a,nlaggr,ilaggr,info)
n = ilaggr(i) n = ilaggr(i)
if (n>0) then if (n>0) then
if (n>naggr) then if (n>naggr) then
write(0,*) 'loc_Aggregate: n > naggr 1 ? ',n,naggr info=4001
call psb_errpush(info,name,a_err='loc_Aggregate: n > naggr 1 ?')
goto 9999
else else
ils(n) = ils(n) + 1 ils(n) = ils(n) + 1
end if end if
end if end if
end do end do
if (debug) then if (debug_level >= psb_debug_outer_) then
write(0,*) 'Phase 1: number of aggregates ',naggr write(debug_unit,*) me,' ',trim(name),&
write(0,*) 'Phase 1: nodes aggregated ',sum(ils) & 'Phase 1: number of aggregates ',naggr
write(debug_unit,*) me,' ',trim(name),&
& 'Phase 1: nodes aggregated ',sum(ils)
end if end if
recovery=.false. recovery=.false.
@ -247,11 +257,10 @@ subroutine mld_zaggrmap_bld(aggr_type,a,desc_a,nlaggr,ilaggr,info)
isz = nr+1 isz = nr+1
ia = -1 ia = -1
call psb_neigh(apnt,i,neigh,n_ne,info,lev=one) call psb_neigh(apnt,i,neigh,n_ne,info,lev=1)
if (info/=0) then if (info/=0) then
info=4010 info=4010
ch_err='psb_neigh' call psb_errpush(info,name,a_err='psb_neigh')
call psb_errpush(info,name,a_err=ch_err)
goto 9999 goto 9999
end if end if
@ -261,7 +270,9 @@ subroutine mld_zaggrmap_bld(aggr_type,a,desc_a,nlaggr,ilaggr,info)
n = ilaggr(k) n = ilaggr(k)
if (n>0) then if (n>0) then
if (n>naggr) then if (n>naggr) then
write(0,*) 'loc_Aggregate: n > naggr 2? ',n,naggr info=4001
call psb_errpush(info,name,a_err='loc_Aggregate: n > naggr 2 ?')
goto 9999
end if end if
if (ils(n) < isz) then if (ils(n) < isz) then
@ -275,7 +286,9 @@ subroutine mld_zaggrmap_bld(aggr_type,a,desc_a,nlaggr,ilaggr,info)
if (ilaggr(i) > -(nr+1)) then if (ilaggr(i) > -(nr+1)) then
ilaggr(i) = abs(ilaggr(i)) ilaggr(i) = abs(ilaggr(i))
if (ilaggr(I)>naggr) then if (ilaggr(I)>naggr) then
write(0,*) 'loc_Aggregate: n > naggr 3? ',ilaggr(i),naggr info=4001
call psb_errpush(info,name,a_err='loc_Aggregate: n > naggr 3 ?')
goto 9999
end if end if
ils(ilaggr(i)) = ils(ilaggr(i)) + 1 ils(ilaggr(i)) = ils(ilaggr(i)) + 1
! !
@ -284,35 +297,44 @@ subroutine mld_zaggrmap_bld(aggr_type,a,desc_a,nlaggr,ilaggr,info)
! !
recovery = .true. recovery = .true.
else else
write(0,*) 'Unrecoverable error !!',ilaggr(i), nr info=4001
call psb_errpush(info,name,a_err='Unrecoverable error !!')
goto 9999
endif endif
else else
ilaggr(i) = ia ilaggr(i) = ia
if (ia>naggr) then if (ia>naggr) then
write(0,*) 'loc_Aggregate: n > naggr 4? ',ia,naggr info=4001
call psb_errpush(info,name,a_err='loc_Aggregate: n > naggr 4? ')
goto 9999
end if end if
ils(ia) = ils(ia) + 1 ils(ia) = ils(ia) + 1
endif endif
end if end if
enddo enddo
if (debug_level >= psb_debug_outer_) then
if (recovery) then if (recovery) then
write(0,*) 'Had to recover from strange situation in loc_aggregate.' write(debug_unit,*) me,' ',trim(name),&
write(0,*) 'Perhaps an unsymmetric pattern?' & 'Had to recover from strange situation in loc_aggregate.'
write(debug_unit,*) me,' ',trim(name),&
& 'Perhaps an unsymmetric pattern?'
endif endif
if (debug) then write(debug_unit,*) me,' ',trim(name),&
write(0,*) 'Phase 2: number of aggregates ',naggr & 'Phase 2: number of aggregates ',naggr,sum(ils)
write(0,*) 'Phase 2: nodes aggregated ',sum(ils)
do i=1, naggr do i=1, naggr
write(*,*) 'Size of aggregate ',i,' :',count(ilaggr==i), ils(i) write(debug_unit,*) me,' ',trim(name),&
& 'Size of aggregate ',i,' :',count(ilaggr==i), ils(i)
enddo enddo
write(*,*) maxval(ils(1:naggr)) write(debug_unit,*) me,' ',trim(name),&
write(*,*) 'Leftovers ',count(ilaggr<0), ' in ',nlp,' loops' & maxval(ils(1:naggr))
write(debug_unit,*) me,' ',trim(name),&
& 'Leftovers ',count(ilaggr<0), ' in ',nlp,' loops'
end if end if
!!$ write(0,*) 'desc_a loc_aggr 4 : ', desc_a%matrix_data(m_)
if (count(ilaggr<0) >0) then if (count(ilaggr<0) >0) then
write(0,*) 'Fatal error: some leftovers!!!' info=4001
call psb_errpush(info,name,a_err='Fatal error: some leftovers')
goto 9999
endif endif
deallocate(ils,neigh,stat=info) deallocate(ils,neigh,stat=info)
@ -322,9 +344,6 @@ subroutine mld_zaggrmap_bld(aggr_type,a,desc_a,nlaggr,ilaggr,info)
goto 9999 goto 9999
end if end if
if (nrow /= size(ilaggr)) then
write(0,*) 'SOmething wrong ilaggr ',nrow,size(ilaggr)
endif
call psb_realloc(ncol,ilaggr,info) call psb_realloc(ncol,ilaggr,info)
if (info/=0) then if (info/=0) then
info=4010 info=4010
@ -351,7 +370,6 @@ subroutine mld_zaggrmap_bld(aggr_type,a,desc_a,nlaggr,ilaggr,info)
case default case default
write(0,*) 'Unimplemented aggregation algorithm ',aggr_type
info = -1 info = -1
call psb_errpush(30,name,i_err=(/1,aggr_type,0,0,0/)) call psb_errpush(30,name,i_err=(/1,aggr_type,0,0,0/))
goto 9999 goto 9999

17
mlprec/mld_zaggrmat_asb.f90
Unescape Escape View File

@ -107,8 +107,7 @@ subroutine mld_zaggrmat_asb(a,desc_a,ac,desc_ac,p,info)
integer, intent(out) :: info integer, intent(out) :: info
! Local variables ! Local variables
logical, parameter :: aggr_dump=.false. integer ::ictxt,np,me, err_act, icomm
integer :: ictxt,np,me, err_act,icomm
character(len=20) :: name character(len=20) :: name
name='mld_aggrmat_asb' name='mld_aggrmat_asb'
@ -125,24 +124,22 @@ subroutine mld_zaggrmat_asb(a,desc_a,ac,desc_ac,p,info)
case (mld_no_smooth_) case (mld_no_smooth_)
call mld_aggrmat_raw_asb(a,desc_a,ac,desc_ac,p,info) call mld_aggrmat_raw_asb(a,desc_a,ac,desc_ac,p,info)
if(info /= 0) then if(info /= 0) then
call psb_errpush(4010,name,a_err='raw_aggregate') call psb_errpush(4010,name,a_err='mld_aggrmat_raw_asb')
goto 9999 goto 9999
end if end if
if (aggr_dump) call psb_csprt(90+me,ac,head='% Raw aggregate.')
case(mld_smooth_prol_,mld_biz_prol_) case(mld_smooth_prol_,mld_biz_prol_)
if (aggr_dump) call psb_csprt(70+me,a,head='% Input matrix')
call mld_aggrmat_smth_asb(a,desc_a,ac,desc_ac,p,info)
call mld_aggrmat_smth_asb(a,desc_a,ac,desc_ac,p,info)
if(info /= 0) then if(info /= 0) then
call psb_errpush(4010,name,a_err='smooth_aggregate') call psb_errpush(4010,name,a_err='mld_aggrmat_smth_asb')
goto 9999 goto 9999
end if end if
if (aggr_dump) call psb_csprt(90+me,ac,head='% Smooth aggregate.')
case default case default
call psb_errpush(4010,name,a_err=name)
call psb_errpush(4001,name,a_err='Invalid aggr kind')
goto 9999 goto 9999
end select end select

25
mlprec/mld_zaggrmat_raw_asb.F90
Unescape Escape View File

@ -95,8 +95,7 @@ subroutine mld_zaggrmat_raw_asb(a,desc_a,ac,desc_ac,p,info)
integer, intent(out) :: info integer, intent(out) :: info
! Local variables ! Local variables
logical, parameter :: aggr_dump=.false. integer ::ictxt,np,me, err_act, icomm
integer ::ictxt,np,me, err_act,icomm
character(len=20) :: name character(len=20) :: name
type(psb_zspmat_type) :: b type(psb_zspmat_type) :: b
integer, pointer :: nzbr(:), idisp(:) integer, pointer :: nzbr(:), idisp(:)
@ -202,7 +201,7 @@ subroutine mld_zaggrmat_raw_asb(a,desc_a,ac,desc_ac,p,info)
ac%k = ntaggr ac%k = ntaggr
ac%infoa(psb_nnz_) = nzac ac%infoa(psb_nnz_) = nzac
ac%fida='COO' ac%fida='COO'
ac%descra='G' ac%descra='GUN'
call psb_spcnv(ac,info,afmt='coo',dupl=psb_dupl_add_) call psb_spcnv(ac,info,afmt='coo',dupl=psb_dupl_add_)
if(info /= 0) then if(info /= 0) then
call psb_errpush(4010,name,a_err='sp_free') call psb_errpush(4010,name,a_err='sp_free')
@ -212,19 +211,10 @@ subroutine mld_zaggrmat_raw_asb(a,desc_a,ac,desc_ac,p,info)
else if (p%iprcparm(mld_coarse_mat_) == mld_distr_mat_) then else if (p%iprcparm(mld_coarse_mat_) == mld_distr_mat_) then
call psb_cdall(ictxt,desc_ac,info,nl=naggr) call psb_cdall(ictxt,desc_ac,info,nl=naggr)
if (info == 0) call psb_cdasb(desc_ac,info)
if (info == 0) call psb_sp_clone(b,ac,info)
if(info /= 0) then if(info /= 0) then
call psb_errpush(4010,name,a_err='psb_cdall') call psb_errpush(4001,name,a_err='Build ac, desc_ac')
goto 9999
end if
call psb_cdasb(desc_ac,info)
if(info /= 0) then
call psb_errpush(4010,name,a_err='psb_cdasb')
goto 9999
end if
call psb_sp_clone(b,ac,info)
if(info /= 0) then
call psb_errpush(4010,name,a_err='spclone')
goto 9999 goto 9999
end if end if
call psb_sp_free(b,info) call psb_sp_free(b,info)
@ -234,8 +224,9 @@ subroutine mld_zaggrmat_raw_asb(a,desc_a,ac,desc_ac,p,info)
end if end if
else else
info = 4001
write(0,*) 'Unknown p%iprcparm(coarse_mat) in aggregate_sp',p%iprcparm(mld_coarse_mat_) call psb_errpush(4001,name,a_err='invalid mld_coarse_mat_')
goto 9999
end if end if
deallocate(nzbr,idisp) deallocate(nzbr,idisp)

350
mlprec/mld_zaggrmat_smth_asb.F90
Unescape Escape View File

@ -117,14 +117,15 @@ subroutine mld_zaggrmat_smth_asb(a,desc_a,ac,desc_ac,p,info)
integer, pointer :: nzbr(:), idisp(:) integer, pointer :: nzbr(:), idisp(:)
integer :: nrow, nglob, ncol, ntaggr, nzac, ip, ndx,& integer :: nrow, nglob, ncol, ntaggr, nzac, ip, ndx,&
& naggr, nzl,naggrm1,naggrp1, i, j, k & naggr, nzl,naggrm1,naggrp1, i, j, k
logical, parameter :: aggr_dump=.false.
integer ::ictxt,np,me, err_act, icomm integer ::ictxt,np,me, err_act, icomm
character(len=20) :: name character(len=20) :: name
type(psb_zspmat_type), pointer :: am1,am2 type(psb_zspmat_type), pointer :: am1,am2
type(psb_zspmat_type) :: am3,am4 type(psb_zspmat_type) :: am3,am4
logical :: ml_global_nmb logical :: ml_global_nmb
integer :: nz
logical, parameter :: test_dump=.false., debug=.false. integer, allocatable :: ia(:), ja(:)
complex(kind(1.d0)), allocatable :: val(:)
integer :: debug_level, debug_unit
integer, parameter :: ncmax=16 integer, parameter :: ncmax=16
real(kind(1.d0)) :: omega, anorm, tmp, dg real(kind(1.d0)) :: omega, anorm, tmp, dg
@ -132,10 +133,12 @@ subroutine mld_zaggrmat_smth_asb(a,desc_a,ac,desc_ac,p,info)
if(psb_get_errstatus().ne.0) return if(psb_get_errstatus().ne.0) return
info=0 info=0
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
debug_unit = psb_get_debug_unit()
debug_level = psb_get_debug_level()
ictxt = psb_cd_get_context(desc_a) ictxt = psb_cd_get_context(desc_a)
icomm = psb_cd_get_mpic(desc_a) icomm = psb_cd_get_mpic(desc_a)
ictxt=psb_cd_get_context(desc_a) ictxt = psb_cd_get_context(desc_a)
call psb_info(ictxt, me, np) call psb_info(ictxt, me, np)
@ -164,38 +167,27 @@ subroutine mld_zaggrmat_smth_asb(a,desc_a,ac,desc_ac,p,info)
goto 9999 goto 9999
end if end if
naggrm1 = sum(p%nlaggr(1:me)) naggrm1 = sum(p%nlaggr(1:me))
naggrp1 = sum(p%nlaggr(1:me+1)) naggrp1 = sum(p%nlaggr(1:me+1))
ml_global_nmb = ( (p%iprcparm(mld_aggr_kind_) == mld_smooth_prol_).or.& ml_global_nmb = ( (p%iprcparm(mld_aggr_kind_) == mld_smooth_prol_).or.&
& ( (p%iprcparm(mld_aggr_kind_) == mld_biz_prol_).and.& & ( (p%iprcparm(mld_aggr_kind_) == mld_biz_prol_).and.&
& (p%iprcparm(mld_coarse_mat_) == mld_repl_mat_)) ) & (p%iprcparm(mld_coarse_mat_) == mld_repl_mat_)) )
if (ml_global_nmb) then if (ml_global_nmb) then
p%mlia(1:nrow) = p%mlia(1:nrow) + naggrm1 p%mlia(1:nrow) = p%mlia(1:nrow) + naggrm1
call psb_halo(p%mlia,desc_a,info) call psb_halo(p%mlia,desc_a,info)
if(info /= 0) then if (info /= 0) then
call psb_errpush(4010,name,a_err='psb_halo') call psb_errpush(4010,name,a_err='psb_halo')
goto 9999 goto 9999
end if end if
end if end if
if (aggr_dump) then
open(30+me)
write(30+me,*) '% Aggregation map'
do i=1,ncol
write(30+me,*) i,p%mlia(i)
end do
close(30+me)
end if
! naggr: number of local aggregates ! naggr: number of local aggregates
! nrow: local rows. ! nrow: local rows.
! !
allocate(p%dorig(nrow),stat=info) allocate(p%dorig(nrow),stat=info)
if (info /= 0) then if (info /= 0) then
info=4025 info=4025
call psb_errpush(info,name,i_err=(/nrow,0,0,0,0/),& call psb_errpush(info,name,i_err=(/nrow,0,0,0,0/),&
@ -218,13 +210,6 @@ subroutine mld_zaggrmat_smth_asb(a,desc_a,ac,desc_ac,p,info)
end if end if
end do end do
! where (p%dorig /= zzero)
! p%dorig = zone / p%dorig
! elsewhere
! p%dorig = zone
! end where
! 1. Allocate Ptilde in sparse matrix form ! 1. Allocate Ptilde in sparse matrix form
am4%fida='COO' am4%fida='COO'
am4%m=ncol am4%m=ncol
@ -235,7 +220,8 @@ subroutine mld_zaggrmat_smth_asb(a,desc_a,ac,desc_ac,p,info)
am4%k=naggr am4%k=naggr
call psb_sp_all(ncol,naggr,am4,ncol,info) call psb_sp_all(ncol,naggr,am4,ncol,info)
endif endif
if(info /= 0) then
if (info /= 0) then
call psb_errpush(4010,name,a_err='spall') call psb_errpush(4010,name,a_err='spall')
goto 9999 goto 9999
end if end if
@ -258,24 +244,19 @@ subroutine mld_zaggrmat_smth_asb(a,desc_a,ac,desc_ac,p,info)
call psb_spcnv(am4,info,afmt='csr',dupl=psb_dupl_add_) call psb_spcnv(am4,info,afmt='csr',dupl=psb_dupl_add_)
if(info /= 0) then if (info==0) call psb_spcnv(a,am3,info,afmt='csr',dupl=psb_dupl_add_)
if (info /= 0) then
call psb_errpush(4010,name,a_err='spcnv') call psb_errpush(4010,name,a_err='spcnv')
goto 9999 goto 9999
end if end if
call psb_sp_clone(a,am3,info)
if(info /= 0) then
call psb_errpush(4010,name,a_err='spclone')
goto 9999
end if
! !
! WARNING: the cycles below assume that AM3 does have ! WARNING: the cycles below assume that AM3 does have
! its diagonal elements stored explicitly!!! ! its diagonal elements stored explicitly!!!
! Should we switch to something safer? ! Should we switch to something safer?
! !
call psb_sp_scal(am3,p%dorig,info) call psb_sp_scal(am3,p%dorig,info)
if(info /= 0) goto 9999 if (info /= 0) goto 9999
if (p%iprcparm(mld_aggr_eig_) == mld_max_norm_) then if (p%iprcparm(mld_aggr_eig_) == mld_max_norm_) then
@ -284,6 +265,7 @@ subroutine mld_zaggrmat_smth_asb(a,desc_a,ac,desc_ac,p,info)
! !
! This only works with CSR. ! This only works with CSR.
! !
if (toupper(am3%fida)=='CSR') then
anorm = dzero anorm = dzero
dg = done dg = done
do i=1,am3%m do i=1,am3%m
@ -300,9 +282,16 @@ subroutine mld_zaggrmat_smth_asb(a,desc_a,ac,desc_ac,p,info)
enddo enddo
call psb_amx(ictxt,anorm) call psb_amx(ictxt,anorm)
else
info = 4001
endif
else else
anorm = psb_spnrmi(am3,desc_a,info) anorm = psb_spnrmi(am3,desc_a,info)
endif endif
if (info /= 0) then
call psb_errpush(4001,name,a_err='Invalid AM3 storage format')
goto 9999
end if
omega = 4.d0/(3.d0*anorm) omega = 4.d0/(3.d0*anorm)
p%dprcparm(mld_aggr_damp_) = omega p%dprcparm(mld_aggr_damp_) = omega
@ -311,8 +300,9 @@ subroutine mld_zaggrmat_smth_asb(a,desc_a,ac,desc_ac,p,info)
omega = p%dprcparm(mld_aggr_damp_) omega = p%dprcparm(mld_aggr_damp_)
else if (p%iprcparm(mld_aggr_eig_) /= mld_user_choice_) then else if (p%iprcparm(mld_aggr_eig_) /= mld_user_choice_) then
write(0,*) me,'Error: invalid choice for OMEGA in blaggrmat?? ',& info = 4001
& p%iprcparm(mld_aggr_eig_) call psb_errpush(info,name,a_err='invalid mld_aggr_eig_')
goto 9999
end if end if
@ -326,41 +316,14 @@ subroutine mld_zaggrmat_smth_asb(a,desc_a,ac,desc_ac,p,info)
end if end if
end do end do
end do end do
else if (toupper(am3%fida)=='COO') then
do j=1,am3%infoa(psb_nnz_)
if (am3%ia1(j) /= am3%ia2(j)) then
am3%aspk(j) = - omega*am3%aspk(j)
else else
am3%aspk(j) = zone - omega*am3%aspk(j) call psb_errpush(4001,name,a_err='Invalid AM3 storage format')
endif
end do
call psb_spcnv(am3,info,afmt='csr',dupl=psb_dupl_add_)
if (info /=0) then
call psb_errpush(4010,name,a_err='spcnv am3')
goto 9999
end if
else
write(0,*) 'Missing implementation of I sum'
call psb_errpush(4010,name)
goto 9999 goto 9999
end if end if
if (test_dump) then if (debug_level >= psb_debug_outer_) &
open(30+me) & write(debug_unit,*) me,' ',trim(name),&
write(30+me,*) 'OMEGA: ',omega & 'Done gather, going for SYMBMM 1'
do i=1,size(p%dorig)
write(30+me,*) p%dorig(i)
end do
close(30+me)
end if
if (test_dump) call &
& psb_csprt(20+me,am4,head='% Operator Ptilde.',ivr=desc_a%loc_to_glob)
if (test_dump) call psb_csprt(40+me,am3,head='% (I-wDA)',ivr=desc_a%loc_to_glob,&
& ivc=desc_a%loc_to_glob)
if (debug) write(0,*) me,'Done gather, going for SYMBMM 1'
! !
! Symbmm90 does the allocation for its result. ! Symbmm90 does the allocation for its result.
! !
@ -376,7 +339,9 @@ subroutine mld_zaggrmat_smth_asb(a,desc_a,ac,desc_ac,p,info)
call psb_numbmm(am3,am4,am1) call psb_numbmm(am3,am4,am1)
if (debug) write(0,*) me,'Done NUMBMM 1' if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'Done NUMBMM 1'
call psb_sp_free(am4,info) call psb_sp_free(am4,info)
if(info /= 0) then if(info /= 0) then
@ -391,35 +356,15 @@ subroutine mld_zaggrmat_smth_asb(a,desc_a,ac,desc_ac,p,info)
! !
call psb_sphalo(am1,desc_a,am4,info,& call psb_sphalo(am1,desc_a,am4,info,&
& colcnv=.false.,rowscale=.true.) & colcnv=.false.,rowscale=.true.)
if (info == 0) call psb_rwextd(ncol,am1,info,b=am4)
if(info /= 0) then if (info == 0) call psb_sp_free(am4,info)
call psb_errpush(4010,name,a_err='psb_sphalo')
goto 9999
end if
call psb_rwextd(ncol,am1,info,b=am4)
if(info /= 0) then
call psb_errpush(4010,name,a_err='psb_rwextd')
goto 9999
end if
call psb_sp_free(am4,info)
if(info /= 0) then
call psb_errpush(4010,name,a_err='psb_sp_free')
goto 9999
end if
else else
call psb_rwextd(ncol,am1,info) call psb_rwextd(ncol,am1,info)
endif
if(info /= 0) then if(info /= 0) then
call psb_errpush(4010,name,a_err='rwextd') call psb_errpush(4001,name,a_err='Halo of am1')
goto 9999 goto 9999
end if end if
endif
if (test_dump) &
& call psb_csprt(60+me,am1,head='% (I-wDA)Pt',ivr=desc_a%loc_to_glob)
call psb_symbmm(a,am1,am3,info) call psb_symbmm(a,am1,am3,info)
if(info /= 0) then if(info /= 0) then
@ -428,7 +373,9 @@ subroutine mld_zaggrmat_smth_asb(a,desc_a,ac,desc_ac,p,info)
end if end if
call psb_numbmm(a,am1,am3) call psb_numbmm(a,am1,am3)
if (debug) write(0,*) me,'Done NUMBMM 2' if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'Done NUMBMM 2'
if (p%iprcparm(mld_aggr_kind_) == mld_smooth_prol_) then if (p%iprcparm(mld_aggr_kind_) == mld_smooth_prol_) then
call psb_transp(am1,am2,fmt='COO') call psb_transp(am1,am2,fmt='COO')
@ -446,7 +393,6 @@ subroutine mld_zaggrmat_smth_asb(a,desc_a,ac,desc_ac,p,info)
am2%ia2(i) = am2%ia2(k) am2%ia2(i) = am2%ia2(k)
end if end if
end do end do
am2%infoa(psb_nnz_) = i am2%infoa(psb_nnz_) = i
call psb_spcnv(am2,info,afmt='csr',dupl=psb_dupl_add_) call psb_spcnv(am2,info,afmt='csr',dupl=psb_dupl_add_)
if (info /=0) then if (info /=0) then
@ -456,63 +402,38 @@ subroutine mld_zaggrmat_smth_asb(a,desc_a,ac,desc_ac,p,info)
else else
call psb_transp(am1,am2) call psb_transp(am1,am2)
endif endif
if (debug) write(0,*) me,'starting sphalo/ rwxtd' if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'starting sphalo/ rwxtd'
if (p%iprcparm(mld_aggr_kind_) == mld_smooth_prol_) then if (p%iprcparm(mld_aggr_kind_) == mld_smooth_prol_) then
! am2 = ((i-wDA)Ptilde)^T ! am2 = ((i-wDA)Ptilde)^T
call psb_sphalo(am3,desc_a,am4,info,& call psb_sphalo(am3,desc_a,am4,info,&
& colcnv=.false.,rowscale=.true.) & colcnv=.false.,rowscale=.true.)
if (info == 0) call psb_rwextd(ncol,am3,info,b=am4)
if(info /= 0) then if (info == 0) call psb_sp_free(am4,info)
call psb_errpush(4010,name,a_err='psb_sphalo')
goto 9999
end if
call psb_rwextd(ncol,am3,info,b=am4)
if(info /= 0) then
call psb_errpush(4010,name,a_err='psb_rwextd')
goto 9999
end if
call psb_sp_free(am4,info)
if(info /= 0) then
call psb_errpush(4010,name,a_err='psb_sp_free')
goto 9999
end if
else if (p%iprcparm(mld_aggr_kind_) == mld_biz_prol_) then else if (p%iprcparm(mld_aggr_kind_) == mld_biz_prol_) then
call psb_rwextd(ncol,am3,info) call psb_rwextd(ncol,am3,info)
if(info /= 0) then
call psb_errpush(4010,name,a_err='psb_rwextd')
goto 9999
end if
endif endif
if (debug) write(0,*) me,'starting symbmm 3'
call psb_symbmm(am2,am3,b,info)
if(info /= 0) then if(info /= 0) then
call psb_errpush(4010,name,a_err='symbmm 3') call psb_errpush(4001,name,a_err='Extend am3')
goto 9999 goto 9999
end if end if
if (debug) write(0,*) me,'starting numbmm 3'
call psb_numbmm(am2,am3,b)
if (debug) write(0,*) me,'Done NUMBMM 3'
!!$ if (aggr_dump) call csprt(50+me,am1,head='% Operator PTrans.') if (debug_level >= psb_debug_outer_) &
call psb_sp_free(am3,info) & write(debug_unit,*) me,' ',trim(name),&
if(info /= 0) then & 'starting symbmm 3'
call psb_errpush(4010,name,a_err='psb_sp_free') call psb_symbmm(am2,am3,b,info)
goto 9999 if (info == 0) call psb_numbmm(am2,am3,b)
end if if (info == 0) call psb_sp_free(am3,info)
if (info == 0) call psb_spcnv(b,info,afmt='coo',dupl=psb_dupl_add_)
call psb_spcnv(b,info,afmt='coo',dupl=psb_dupl_add_) if (info /= 0) then
if (info /=0) then call psb_errpush(4001,name,a_err='Build b = am2 x am3')
call psb_errpush(4010,name,a_err='spcnv b')
goto 9999 goto 9999
end if end if
if (test_dump) call psb_csprt(80+me,b,head='% Smoothed aggregate AC.')
select case(p%iprcparm(mld_aggr_kind_)) select case(p%iprcparm(mld_aggr_kind_))
@ -523,55 +444,30 @@ subroutine mld_zaggrmat_smth_asb(a,desc_a,ac,desc_ac,p,info)
case(mld_distr_mat_) case(mld_distr_mat_)
call psb_sp_clone(b,ac,info) call psb_sp_clone(b,ac,info)
if(info /= 0) goto 9999
nzac = ac%infoa(psb_nnz_) nzac = ac%infoa(psb_nnz_)
nzl = ac%infoa(psb_nnz_) nzl = ac%infoa(psb_nnz_)
if (info == 0) call psb_cdall(ictxt,desc_ac,info,nl=p%nlaggr(me+1))
call psb_cdall(ictxt,desc_ac,info,nl=p%nlaggr(me+1)) if (info == 0) call psb_cdins(nzl,ac%ia1,ac%ia2,desc_ac,info)
if(info /= 0) then if (info == 0) call psb_cdasb(desc_ac,info)
call psb_errpush(4010,name,a_err='psb_cdall') if (info == 0) call psb_glob_to_loc(ac%ia1(1:nzl),desc_ac,info,iact='I')
goto 9999 if (info == 0) call psb_glob_to_loc(ac%ia2(1:nzl),desc_ac,info,iact='I')
end if if (info /= 0) then
call psb_errpush(4001,name,a_err='Creating desc_ac and converting ac')
call psb_cdins(nzl,ac%ia1,ac%ia2,desc_ac,info)
if(info /= 0) then
call psb_errpush(4010,name,a_err='psb_cdins')
goto 9999
end if
if (debug) write(0,*) me,'Created aux descr. distr.'
call psb_cdasb(desc_ac,info)
if(info /= 0) then
call psb_errpush(4010,name,a_err='psb_cdasb')
goto 9999
end if
if (debug) write(0,*) me,'Asmbld aux descr. distr.'
call psb_glob_to_loc(ac%ia1(1:nzl),desc_ac,info,iact='I')
if(info /= 0) then
call psb_errpush(4010,name,a_err='psglob_to_loc')
goto 9999
end if
call psb_glob_to_loc(ac%ia2(1:nzl),desc_ac,info,iact='I')
if(info /= 0) then
call psb_errpush(4010,name,a_err='psglob_to_loc')
goto 9999 goto 9999
end if end if
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'Assembld aux descr. distr.'
ac%m=desc_ac%matrix_data(psb_n_row_) ac%m=desc_ac%matrix_data(psb_n_row_)
ac%k=desc_ac%matrix_data(psb_n_col_) ac%k=desc_ac%matrix_data(psb_n_col_)
ac%fida='COO' ac%fida='COO'
ac%descra='G' ac%descra='GUN'
call psb_sp_free(b,info) call psb_sp_free(b,info)
if (info == 0) deallocate(nzbr,idisp,stat=info) if (info == 0) deallocate(nzbr,idisp,stat=info)
if(info /= 0) then if (info /= 0) then
call psb_errpush(4010,name,a_err='psb_sp_free') call psb_errpush(4010,name,a_err='psb_sp_free')
goto 9999 goto 9999
end if end if
@ -579,7 +475,6 @@ subroutine mld_zaggrmat_smth_asb(a,desc_a,ac,desc_ac,p,info)
if (np>1) then if (np>1) then
nzl = psb_sp_get_nnzeros(am1) nzl = psb_sp_get_nnzeros(am1)
call psb_glob_to_loc(am1%ia1(1:nzl),desc_ac,info,'I') call psb_glob_to_loc(am1%ia1(1:nzl),desc_ac,info,'I')
if(info /= 0) then if(info /= 0) then
call psb_errpush(4010,name,a_err='psb_glob_to_loc') call psb_errpush(4010,name,a_err='psb_glob_to_loc')
goto 9999 goto 9999
@ -589,44 +484,31 @@ subroutine mld_zaggrmat_smth_asb(a,desc_a,ac,desc_ac,p,info)
if (np>1) then if (np>1) then
call psb_spcnv(am2,info,afmt='coo',dupl=psb_dupl_add_) call psb_spcnv(am2,info,afmt='coo',dupl=psb_dupl_add_)
if(info /= 0) then
call psb_errpush(4010,name,a_err='spcnv')
goto 9999
end if
nzl = am2%infoa(psb_nnz_) nzl = am2%infoa(psb_nnz_)
call psb_glob_to_loc(am2%ia1(1:nzl),desc_ac,info,'I') if (info == 0) call psb_glob_to_loc(am2%ia1(1:nzl),desc_ac,info,'I')
if (info == 0) call psb_spcnv(am2,info,afmt='csr',dupl=psb_dupl_add_)
if(info /= 0) then if(info /= 0) then
call psb_errpush(4010,name,a_err='psb_glob_to_loc') call psb_errpush(4001,name,a_err='Converting am2 to local')
goto 9999
end if
call psb_spcnv(am2,info,afmt='csr',dupl=psb_dupl_add_)
if(info /= 0) then
call psb_errpush(4010,name,a_err='spcnv')
goto 9999 goto 9999
end if end if
end if end if
am2%m=desc_ac%matrix_data(psb_n_col_) am2%m=desc_ac%matrix_data(psb_n_col_)
if (debug) write(0,*) me,'Done ac ' if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'Done ac '
case(mld_repl_mat_) case(mld_repl_mat_)
! !
! !
call psb_cdall(ictxt,desc_ac,info,mg=ntaggr,repl=.true.) call psb_cdall(ictxt,desc_ac,info,mg=ntaggr,repl=.true.)
if(info /= 0) then
call psb_errpush(4010,name,a_err='psb_cdall')
goto 9999
end if
nzbr(:) = 0 nzbr(:) = 0
nzbr(me+1) = b%infoa(psb_nnz_) nzbr(me+1) = b%infoa(psb_nnz_)
call psb_sum(ictxt,nzbr(1:np)) call psb_sum(ictxt,nzbr(1:np))
nzac = sum(nzbr) nzac = sum(nzbr)
call psb_sp_all(ntaggr,ntaggr,ac,nzac,info) if (info == 0) call psb_sp_all(ntaggr,ntaggr,ac,nzac,info)
if(info /= 0) goto 9999 if (info /= 0) goto 9999
do ip=1,np do ip=1,np
idisp(ip) = sum(nzbr(1:ip-1)) idisp(ip) = sum(nzbr(1:ip-1))
@ -635,30 +517,36 @@ subroutine mld_zaggrmat_smth_asb(a,desc_a,ac,desc_ac,p,info)
call mpi_allgatherv(b%aspk,ndx,mpi_double_complex,ac%aspk,nzbr,idisp,& call mpi_allgatherv(b%aspk,ndx,mpi_double_complex,ac%aspk,nzbr,idisp,&
& mpi_double_complex,icomm,info) & mpi_double_complex,icomm,info)
call mpi_allgatherv(b%ia1,ndx,mpi_integer,ac%ia1,nzbr,idisp,& if (info == 0) call mpi_allgatherv(b%ia1,ndx,mpi_integer,ac%ia1,nzbr,idisp,&
& mpi_integer,icomm,info) & mpi_integer,icomm,info)
call mpi_allgatherv(b%ia2,ndx,mpi_integer,ac%ia2,nzbr,idisp,& if (info == 0) call mpi_allgatherv(b%ia2,ndx,mpi_integer,ac%ia2,nzbr,idisp,&
& mpi_integer,icomm,info) & mpi_integer,icomm,info)
if(info /= 0) goto 9999
if (info /= 0) then
call psb_errpush(4001,name,a_err=' from mpi_allgatherv')
goto 9999
end if
ac%m = ntaggr ac%m = ntaggr
ac%k = ntaggr ac%k = ntaggr
ac%infoa(psb_nnz_) = nzac ac%infoa(psb_nnz_) = nzac
ac%fida='COO' ac%fida='COO'
ac%descra='G' ac%descra='GUN'
call psb_spcnv(ac,info,afmt='coo',dupl=psb_dupl_add_) call psb_spcnv(ac,info,afmt='coo',dupl=psb_dupl_add_)
if(info /= 0) goto 9999 if(info /= 0) goto 9999
call psb_sp_free(b,info) call psb_sp_free(b,info)
if(info /= 0) goto 9999 if(info /= 0) goto 9999
if (me==0) then
if (test_dump) call psb_csprt(80+me,ac,head='% Smoothed aggregate AC.')
endif
deallocate(nzbr,idisp)
deallocate(nzbr,idisp,stat=info)
if (info /= 0) then
info = 4000
call psb_errpush(info,name)
goto 9999
end if
case default case default
write(0,*) 'Inconsistent input in smooth_new_aggregate' info = 4001
call psb_errpush(info,name,a_err='invalid mld_coarse_mat_')
goto 9999
end select end select
@ -669,25 +557,11 @@ subroutine mld_zaggrmat_smth_asb(a,desc_a,ac,desc_ac,p,info)
case(mld_distr_mat_) case(mld_distr_mat_)
call psb_sp_clone(b,ac,info) call psb_sp_clone(b,ac,info)
if(info /= 0) then if (info == 0) call psb_cdall(ictxt,desc_ac,info,nl=naggr)
call psb_errpush(4010,name,a_err='spclone') if (info == 0) call psb_cdasb(desc_ac,info)
goto 9999 if (info == 0) call psb_sp_free(b,info)
end if if (info /= 0) then
call psb_cdall(ictxt,desc_ac,info,nl=naggr) call psb_errpush(4010,name,a_err='Build desc_ac, ac')
if(info /= 0) then
call psb_errpush(4010,name,a_err='psb_cdall')
goto 9999
end if
call psb_cdasb(desc_ac,info)
if(info /= 0) then
call psb_errpush(4010,name,a_err='psb_cdasb')
goto 9999
end if
call psb_sp_free(b,info)
if(info /= 0) then
call psb_errpush(4010,name,a_err='sp_free')
goto 9999 goto 9999
end if end if
@ -718,13 +592,12 @@ subroutine mld_zaggrmat_smth_asb(a,desc_a,ac,desc_ac,p,info)
call mpi_allgatherv(b%aspk,ndx,mpi_double_complex,ac%aspk,nzbr,idisp,& call mpi_allgatherv(b%aspk,ndx,mpi_double_complex,ac%aspk,nzbr,idisp,&
& mpi_double_complex,icomm,info) & mpi_double_complex,icomm,info)
call mpi_allgatherv(b%ia1,ndx,mpi_integer,ac%ia1,nzbr,idisp,& if (info == 0) call mpi_allgatherv(b%ia1,ndx,mpi_integer,ac%ia1,nzbr,idisp,&
& mpi_integer,icomm,info) & mpi_integer,icomm,info)
call mpi_allgatherv(b%ia2,ndx,mpi_integer,ac%ia2,nzbr,idisp,& if (info == 0) call mpi_allgatherv(b%ia2,ndx,mpi_integer,ac%ia2,nzbr,idisp,&
& mpi_integer,icomm,info) & mpi_integer,icomm,info)
if(info /= 0) then if (info /= 0) then
info=-1 call psb_errpush(4001,name,a_err=' from mpi_allgatherv')
call psb_errpush(info,name)
goto 9999 goto 9999
end if end if
@ -733,7 +606,7 @@ subroutine mld_zaggrmat_smth_asb(a,desc_a,ac,desc_ac,p,info)
ac%k = ntaggr ac%k = ntaggr
ac%infoa(psb_nnz_) = nzac ac%infoa(psb_nnz_) = nzac
ac%fida='COO' ac%fida='COO'
ac%descra='G' ac%descra='GUN'
call psb_spcnv(ac,info,afmt='coo',dupl=psb_dupl_add_) call psb_spcnv(ac,info,afmt='coo',dupl=psb_dupl_add_)
if(info /= 0) then if(info /= 0) then
call psb_errpush(4010,name,a_err='spcnv') call psb_errpush(4010,name,a_err='spcnv')
@ -745,8 +618,23 @@ subroutine mld_zaggrmat_smth_asb(a,desc_a,ac,desc_ac,p,info)
goto 9999 goto 9999
end if end if
case default
info = 4001
call psb_errpush(info,name,a_err='invalid mld_coarse_mat_')
goto 9999
end select end select
deallocate(nzbr,idisp)
deallocate(nzbr,idisp,stat=info)
if (info /= 0) then
info = 4000
call psb_errpush(info,name)
goto 9999
end if
case default
info = 4001
call psb_errpush(info,name,a_err='invalid mld_smooth_prol_')
goto 9999
end select end select
@ -756,7 +644,9 @@ subroutine mld_zaggrmat_smth_asb(a,desc_a,ac,desc_ac,p,info)
goto 9999 goto 9999
end if end if
if (debug) write(0,*) me,'Done smooth_aggregate ' if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'Done smooth_aggregate '
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
return return

64
mlprec/mld_zasmat_bld.f90
Unescape Escape View File

@ -78,7 +78,7 @@ subroutine mld_zasmat_bld(ptype,novr,a,blk,desc_data,upd,desc_p,info,outfmt)
Implicit None Implicit None
! Arguments ! Arguments
integer, intent(in) :: ptype,novr integer, intent(in) :: ptype,novr
Type(psb_zspmat_type), Intent(in) :: a Type(psb_zspmat_type), Intent(in) :: a
Type(psb_zspmat_type), Intent(inout) :: blk Type(psb_zspmat_type), Intent(inout) :: blk
@ -88,21 +88,24 @@ subroutine mld_zasmat_bld(ptype,novr,a,blk,desc_data,upd,desc_p,info,outfmt)
Character, Intent(in) :: upd Character, Intent(in) :: upd
character(len=5), optional :: outfmt character(len=5), optional :: outfmt
! Local variables ! Local variables
real(kind(1.d0)) :: t1,t2,t3
integer icomm integer icomm
Integer :: np,me,nnzero,& Integer :: np,me,nnzero,&
& ictxt, n_col,int_err(5),& & ictxt, n_col,int_err(5),&
& tot_recv, n_row,nhalo, nrow_a,err_act & tot_recv, n_row,nhalo, nrow_a,err_act
Logical,Parameter :: debug=.false., debugprt=.false. integer :: debug_level, debug_unit
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
name='mld_zasmat_bld' name='mld_zasmat_bld'
if(psb_get_errstatus().ne.0) return if(psb_get_errstatus() /= 0) return
info=0 info=0
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
debug_unit = psb_get_debug_unit()
debug_level = psb_get_debug_level()
If(debug) Write(0,*)'IN DASMATBLD ', upd If (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& ' start ', upd
ictxt = psb_cd_get_context(desc_data) ictxt = psb_cd_get_context(desc_data)
icomm = psb_cd_get_mpic(desc_data) icomm = psb_cd_get_mpic(desc_data)
@ -121,7 +124,6 @@ subroutine mld_zasmat_bld(ptype,novr,a,blk,desc_data,upd,desc_p,info,outfmt)
! Block-Jacobi preconditioner. Copy the descriptor, just in case ! Block-Jacobi preconditioner. Copy the descriptor, just in case
! we want to renumber the rows and columns of the matrix. ! we want to renumber the rows and columns of the matrix.
! !
If(debug) Write(0,*)' asmatbld calling allocate '
call psb_sp_all(0,0,blk,1,info) call psb_sp_all(0,0,blk,1,info)
if(info /= 0) then if(info /= 0) then
info=4010 info=4010
@ -131,10 +133,11 @@ subroutine mld_zasmat_bld(ptype,novr,a,blk,desc_data,upd,desc_p,info,outfmt)
end if end if
blk%fida = 'COO' blk%fida = 'COO'
blk%infoa(psb_nnz_) = 0 blk%infoa(psb_nnz_) = 0
If(debug) Write(0,*)' asmatbld done spallocate'
If (upd == 'F') Then If (upd == 'F') Then
call psb_cdcpy(desc_data,desc_p,info) call psb_cdcpy(desc_data,desc_p,info)
If(debug) Write(0,*)' asmatbld done cdcpy' If(debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& ' done cdcpy'
if(info /= 0) then if(info /= 0) then
info=4010 info=4010
ch_err='psb_cdcpy' ch_err='psb_cdcpy'
@ -144,12 +147,9 @@ subroutine mld_zasmat_bld(ptype,novr,a,blk,desc_data,upd,desc_p,info,outfmt)
endif endif
case(mld_as_) case(mld_as_)
! !
! Additive Schwarz ! Additive Schwarz
! !
if (novr < 0) then if (novr < 0) then
info=3 info=3
int_err(1)=novr int_err(1)=novr
@ -161,7 +161,9 @@ subroutine mld_zasmat_bld(ptype,novr,a,blk,desc_data,upd,desc_p,info,outfmt)
! !
! Actually, this is just block Jacobi ! Actually, this is just block Jacobi
! !
If(debug) Write(0,*)' asmatbld calling allocate novr=0' If(debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& ' calling allocate novr=0'
call psb_sp_all(0,0,blk,1,info) call psb_sp_all(0,0,blk,1,info)
if(info /= 0) then if(info /= 0) then
info=4010 info=4010
@ -171,25 +173,28 @@ subroutine mld_zasmat_bld(ptype,novr,a,blk,desc_data,upd,desc_p,info,outfmt)
end if end if
blk%fida = 'COO' blk%fida = 'COO'
blk%infoa(psb_nnz_) = 0 blk%infoa(psb_nnz_) = 0
if (debug) write(0,*) 'Calling desccpy' if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'Calling desccpy'
if (upd == 'F') then if (upd == 'F') then
call psb_cdcpy(desc_data,desc_p,info) call psb_cdcpy(desc_data,desc_p,info)
If(debug) Write(0,*)' asmatbld done cdcpy' If(debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& ' done cdcpy'
if(info /= 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)
goto 9999 goto 9999
end if end if
if (debug) write(0,*) 'Early return from asmatbld: P>=3 N_OVR=0' if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'Early return: P>=3 N_OVR=0'
endif endif
return return
endif endif
If(debug)Write(0,*)'BEGIN dasmatbld',me,upd,novr
t1 = psb_wtime()
If (upd == 'F') Then If (upd == 'F') Then
! !
! Build the auxiliary descriptor desc_p%matrix_data(psb_n_row_). ! Build the auxiliary descriptor desc_p%matrix_data(psb_n_row_).
@ -200,7 +205,7 @@ subroutine mld_zasmat_bld(ptype,novr,a,blk,desc_data,upd,desc_p,info,outfmt)
! a descriptor for an extended stencil in a PDE solver. ! a descriptor for an extended stencil in a PDE solver.
! !
call psb_cdbldext(a,desc_data,novr,desc_p,info,extype=psb_ovt_asov_) call psb_cdbldext(a,desc_data,novr,desc_p,info,extype=psb_ovt_asov_)
if(info /= 0) then if (info /= 0) then
info=4010 info=4010
ch_err='psb_cdbldext' ch_err='psb_cdbldext'
call psb_errpush(info,name,a_err=ch_err) call psb_errpush(info,name,a_err=ch_err)
@ -208,7 +213,9 @@ subroutine mld_zasmat_bld(ptype,novr,a,blk,desc_data,upd,desc_p,info,outfmt)
end if end if
Endif Endif
if(debug) write(0,*) me,' From cdbldext _:',desc_p%matrix_data(psb_n_row_),& if(debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& ' From cdbldext _:',desc_p%matrix_data(psb_n_row_),&
& desc_p%matrix_data(psb_n_col_) & desc_p%matrix_data(psb_n_col_)
! !
@ -216,30 +223,35 @@ subroutine mld_zasmat_bld(ptype,novr,a,blk,desc_data,upd,desc_p,info,outfmt)
! !
n_row = desc_p%matrix_data(psb_n_row_) n_row = desc_p%matrix_data(psb_n_row_)
t2 = psb_wtime()
if (debug) write(0,*) 'Before sphalo ',blk%fida,blk%m,psb_nnz_,blk%infoa(psb_nnz_) if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'Before sphalo ',blk%fida,blk%m,psb_nnz_,blk%infoa(psb_nnz_)
Call psb_sphalo(a,desc_p,blk,info,& Call psb_sphalo(a,desc_p,blk,info,&
& outfmt=outfmt,data=psb_comm_ext_,rowscale=.true.) & outfmt=outfmt,data=psb_comm_ext_,rowscale=.true.)
if(info /= 0) then if (info /= 0) then
info=4010 info=4010
ch_err='psb_sphalo' ch_err='psb_sphalo'
call psb_errpush(info,name,a_err=ch_err) call psb_errpush(info,name,a_err=ch_err)
goto 9999 goto 9999
end if end if
if (debug) write(0,*) 'After psb_sphalo ',& if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'After psb_sphalo ',&
& blk%fida,blk%m,psb_nnz_,blk%infoa(psb_nnz_) & blk%fida,blk%m,psb_nnz_,blk%infoa(psb_nnz_)
case default case default
if(info /= 0) then if(info /= 0) then
info=4000 info=4001
ch_err='Invalid ptype' ch_err='Invalid ptype'
call psb_errpush(info,name,a_err=ch_err) call psb_errpush(info,name,a_err=ch_err)
goto 9999 goto 9999
end if end if
End select End select
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),'Done'
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
return return

27
mlprec/mld_zbaseprec_aply.f90
Unescape Escape View File

@ -97,8 +97,7 @@ subroutine mld_zbaseprec_aply(alpha,prec,x,beta,y,desc_data,trans,work,info)
integer :: n_row,n_col, int_err(5), nrow_d integer :: n_row,n_col, int_err(5), nrow_d
complex(kind(1.d0)), pointer :: ww(:), aux(:), tx(:),ty(:) complex(kind(1.d0)), pointer :: ww(:), aux(:), tx(:),ty(:)
character ::diagl, diagu character ::diagl, diagu
integer :: ictxt,np,me, isz, err_act integer :: ictxt,np,me,isz, err_act
logical,parameter :: debug=.false., debugprt=.false.
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
name='mld_zbaseprec_aply' name='mld_zbaseprec_aply'
@ -164,7 +163,7 @@ subroutine mld_zbaseprec_aply(alpha,prec,x,beta,y,desc_data,trans,work,info)
! !
call mld_bjac_aply(alpha,prec,x,beta,y,desc_data,trans,work,info) call mld_bjac_aply(alpha,prec,x,beta,y,desc_data,trans,work,info)
if(info.ne.0) then if(info /= 0) then
info=4010 info=4010
ch_err='mld_bjac_aply' ch_err='mld_bjac_aply'
goto 9999 goto 9999
@ -180,7 +179,7 @@ subroutine mld_zbaseprec_aply(alpha,prec,x,beta,y,desc_data,trans,work,info)
! shortcut: this fixes performance for RAS(0) == BJA ! shortcut: this fixes performance for RAS(0) == BJA
! !
call mld_bjac_aply(alpha,prec,x,beta,y,desc_data,trans,work,info) call mld_bjac_aply(alpha,prec,x,beta,y,desc_data,trans,work,info)
if(info.ne.0) then if(info /= 0) then
info=4010 info=4010
ch_err='psb_bjacaply' ch_err='psb_bjacaply'
goto 9999 goto 9999
@ -230,9 +229,6 @@ subroutine mld_zbaseprec_aply(alpha,prec,x,beta,y,desc_data,trans,work,info)
endif endif
if (debugprt) write(0,*)' vdiag: ',prec%d(:)
if (debug) write(0,*) 'Bi-CGSTAB with Additive Schwarz prec'
tx(1:nrow_d) = x(1:nrow_d) tx(1:nrow_d) = x(1:nrow_d)
tx(nrow_d+1:isz) = zzero tx(nrow_d+1:isz) = zzero
@ -247,8 +243,8 @@ subroutine mld_zbaseprec_aply(alpha,prec,x,beta,y,desc_data,trans,work,info)
goto 9999 goto 9999
end if end if
else if (prec%iprcparm(mld_sub_restr_) /= psb_none_) then else if (prec%iprcparm(mld_sub_restr_) /= psb_none_) then
write(0,*) 'Problem in PREC_APLY: Unknown value for restriction ',& call psb_errpush(4001,name,a_err='Invalid mld_sub_restr_')
&prec%iprcparm(mld_sub_restr_) goto 9999
end if end if
! !
@ -270,7 +266,7 @@ subroutine mld_zbaseprec_aply(alpha,prec,x,beta,y,desc_data,trans,work,info)
! preconditioner). The resulting vector is ty. ! preconditioner). The resulting vector is ty.
! !
call mld_bjac_aply(zone,prec,tx,zzero,ty,prec%desc_data,trans,aux,info) call mld_bjac_aply(zone,prec,tx,zzero,ty,prec%desc_data,trans,aux,info)
if(info.ne.0) then if(info /= 0) then
info=4010 info=4010
ch_err='mld_bjac_aply' ch_err='mld_bjac_aply'
goto 9999 goto 9999
@ -309,8 +305,8 @@ subroutine mld_zbaseprec_aply(alpha,prec,x,beta,y,desc_data,trans,work,info)
end if end if
case default case default
write(0,*) 'Problem in PREC_APLY: Unknown value for prolongation ',& call psb_errpush(4001,name,a_err='Invalid mld_sub_prol_')
& prec%iprcparm(mld_sub_prol_) goto 9999
end select end select
! !
@ -330,9 +326,8 @@ subroutine mld_zbaseprec_aply(alpha,prec,x,beta,y,desc_data,trans,work,info)
end if end if
case default case default
write(0,*) 'Invalid PRE%PREC ',prec%iprcparm(mld_prec_type_),':',& call psb_errpush(4001,name,a_err='Invalid mld_prec_type_')
& mld_min_prec_,mld_noprec_,mld_diag_,mld_bjac_,mld_as_ goto 9999
end select end select
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
@ -341,7 +336,7 @@ subroutine mld_zbaseprec_aply(alpha,prec,x,beta,y,desc_data,trans,work,info)
9999 continue 9999 continue
call psb_errpush(info,name,i_err=int_err,a_err=ch_err) call psb_errpush(info,name,i_err=int_err,a_err=ch_err)
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
if (err_act.eq.psb_act_abort_) then if (err_act == psb_act_abort_) then
call psb_error() call psb_error()
return return
end if end if

40
mlprec/mld_zbaseprec_bld.f90
Unescape Escape View File

@ -77,34 +77,33 @@ subroutine mld_zbaseprc_bld(a,desc_a,p,info,upd)
! Local variables ! Local variables
Integer :: err, n_row, n_col,ictxt, me,np,mglob, err_act Integer :: err, n_row, n_col,ictxt, me,np,mglob, err_act
integer :: int_err(5)
character :: iupd character :: iupd
integer :: debug_level, debug_unit
logical, parameter :: debug=.false.
integer,parameter :: iroot=0,iout=60,ilout=40
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
name = 'mld_zbaseprc_bld'
info=0 info=0
err=0 err=0
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
name = 'mld_zbaseprc_bld' debug_unit = psb_get_debug_unit()
debug_level = psb_get_debug_level()
if (debug) write(0,*) 'Entering baseprc_bld'
info = 0
int_err(1) = 0
ictxt = psb_cd_get_context(desc_a) ictxt = psb_cd_get_context(desc_a)
n_row = psb_cd_get_local_rows(desc_a) n_row = psb_cd_get_local_rows(desc_a)
n_col = psb_cd_get_local_cols(desc_a) n_col = psb_cd_get_local_cols(desc_a)
mglob = psb_cd_get_global_rows(desc_a) mglob = psb_cd_get_global_rows(desc_a)
if (debug) write(0,*) 'Preconditioner Blacs_gridinfo'
call psb_info(ictxt, me, np) call psb_info(ictxt, me, np)
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),' start'
if (present(upd)) then if (present(upd)) then
if (debug) write(0,*) 'UPD ', upd if (debug_level >= psb_debug_outer_) &
if ((UPD.eq.'F').or.(UPD.eq.'T')) then & write(debug_unit,*) me,' ',trim(name),'UPD ', upd
IUPD=UPD if ((toupper(UPD) == 'F').or.(toupper(UPD) == 'T')) then
IUPD=toupper(UPD)
else else
IUPD='F' IUPD='F'
endif endif
@ -140,7 +139,9 @@ subroutine mld_zbaseprc_bld(a,desc_a,p,info,upd)
! Diagonal preconditioner ! Diagonal preconditioner
call mld_diag_bld(a,desc_a,p,iupd,info) call mld_diag_bld(a,desc_a,p,iupd,info)
if(debug) write(0,*)me,': out of mld_diag_bld' if(debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& ': out of mld_diag_bld'
if(info /= 0) then if(info /= 0) then
info=4010 info=4010
ch_err='mld_diag_bld' ch_err='mld_diag_bld'
@ -168,8 +169,9 @@ subroutine mld_zbaseprc_bld(a,desc_a,p,info,upd)
p%iprcparm(mld_smooth_sweeps_) = 1 p%iprcparm(mld_smooth_sweeps_) = 1
end if end if
if (debug) write(0,*)me, ': Calling mld_bjac_bld' if (debug_level >= psb_debug_outer_) &
if (debug) call psb_barrier(ictxt) & write(debug_unit,*) me,' ',trim(name),&
& ': Calling mld_bjac_bld'
! Build the local part of the base preconditioner ! Build the local part of the base preconditioner
call mld_bjac_bld(a,desc_a,p,iupd,info) call mld_bjac_bld(a,desc_a,p,iupd,info)
@ -180,7 +182,7 @@ subroutine mld_zbaseprc_bld(a,desc_a,p,info,upd)
end if end if
case default case default
info=4010 info=4001
ch_err='Unknown mld_prec_type_' ch_err='Unknown mld_prec_type_'
call psb_errpush(info,name,a_err=ch_err) call psb_errpush(info,name,a_err=ch_err)
goto 9999 goto 9999
@ -190,6 +192,8 @@ subroutine mld_zbaseprc_bld(a,desc_a,p,info,upd)
p%base_a => a p%base_a => a
p%base_desc => desc_a p%base_desc => desc_a
p%iprcparm(mld_prec_status_) = mld_prec_built_ p%iprcparm(mld_prec_status_) = mld_prec_built_
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),': Done'
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
return return

79
mlprec/mld_zbjac_aply.f90
Unescape Escape View File

@ -150,8 +150,7 @@ subroutine mld_zbjac_aply(alpha,prec,x,beta,y,desc_data,trans,work,info)
! Local variables ! Local variables
integer :: n_row,n_col integer :: n_row,n_col
complex(kind(1.d0)), pointer :: ww(:), aux(:), tx(:),ty(:) complex(kind(1.d0)), pointer :: ww(:), aux(:), tx(:),ty(:)
integer :: ictxt,np,me,i, err_act, int_err(5) integer :: ictxt,np,me,i, err_act
logical,parameter :: debug=.false., debugprt=.false.
character(len=20) :: name character(len=20) :: name
interface interface
@ -206,10 +205,6 @@ subroutine mld_zbjac_aply(alpha,prec,x,beta,y,desc_data,trans,work,info)
end if end if
endif endif
if (debug) then
write(0,*) me,' mld_bjac_APLY: ',prec%iprcparm(mld_sub_solve_),prec%iprcparm(mld_smooth_sweeps_)
end if
if (prec%iprcparm(mld_smooth_sweeps_) == 1) then if (prec%iprcparm(mld_smooth_sweeps_) == 1) then
! !
! TASKS 1, 3 and 4 ! TASKS 1, 3 and 4
@ -228,19 +223,17 @@ subroutine mld_zbjac_aply(alpha,prec,x,beta,y,desc_data,trans,work,info)
call psb_spsm(zone,prec%av(mld_l_pr_),x,zzero,ww,desc_data,info,& call psb_spsm(zone,prec%av(mld_l_pr_),x,zzero,ww,desc_data,info,&
& trans='N',unit='L',diag=prec%d,choice=psb_none_,work=aux) & trans='N',unit='L',diag=prec%d,choice=psb_none_,work=aux)
if(info /=0) goto 9999 if (info == 0) call psb_spsm(alpha,prec%av(mld_u_pr_),ww,beta,y,desc_data,info,&
call psb_spsm(alpha,prec%av(mld_u_pr_),ww,beta,y,desc_data,info,&
& trans='N',unit='U',choice=psb_none_, work=aux) & trans='N',unit='U',choice=psb_none_, work=aux)
if(info /=0) goto 9999
case('T','C') case('T','C')
call psb_spsm(zone,prec%av(mld_u_pr_),x,zzero,ww,desc_data,info,& call psb_spsm(zone,prec%av(mld_u_pr_),x,zzero,ww,desc_data,info,&
& trans=trans,unit='L',diag=prec%d,choice=psb_none_, work=aux) & trans=trans,unit='L',diag=prec%d,choice=psb_none_, work=aux)
if(info /=0) goto 9999 if(info ==0) call psb_spsm(alpha,prec%av(mld_l_pr_),ww,beta,y,desc_data,info,&
call psb_spsm(alpha,prec%av(mld_l_pr_),ww,beta,y,desc_data,info,&
& trans=trans,unit='U',choice=psb_none_,work=aux) & trans=trans,unit='U',choice=psb_none_,work=aux)
if(info /=0) goto 9999 case default
call psb_errpush(4001,name,a_err='Invalid TRANS in ILU subsolve')
goto 9999
end select end select
case(mld_slu_) case(mld_slu_)
@ -260,10 +253,12 @@ subroutine mld_zbjac_aply(alpha,prec,x,beta,y,desc_data,trans,work,info)
call mld_zslu_solve(1,n_row,1,ww,n_row,prec%iprcparm(mld_slu_ptr_),info) call mld_zslu_solve(1,n_row,1,ww,n_row,prec%iprcparm(mld_slu_ptr_),info)
case('C') case('C')
call mld_zslu_solve(2,n_row,1,ww,n_row,prec%iprcparm(mld_slu_ptr_),info) call mld_zslu_solve(2,n_row,1,ww,n_row,prec%iprcparm(mld_slu_ptr_),info)
case default
call psb_errpush(4001,name,a_err='Invalid TRANS in SLU subsolve')
goto 9999
end select end select
if(info /=0) goto 9999 if (info ==0) call psb_geaxpby(alpha,ww,beta,y,desc_data,info)
call psb_geaxpby(alpha,ww,beta,y,desc_data,info)
case(mld_sludist_) case(mld_sludist_)
! !
@ -280,10 +275,12 @@ subroutine mld_zbjac_aply(alpha,prec,x,beta,y,desc_data,trans,work,info)
call mld_zsludist_solve(1,n_row,1,ww,n_row,prec%iprcparm(mld_slud_ptr_),info) call mld_zsludist_solve(1,n_row,1,ww,n_row,prec%iprcparm(mld_slud_ptr_),info)
case('C') case('C')
call mld_zsludist_solve(2,n_row,1,ww,n_row,prec%iprcparm(mld_slud_ptr_),info) call mld_zsludist_solve(2,n_row,1,ww,n_row,prec%iprcparm(mld_slud_ptr_),info)
case default
call psb_errpush(4001,name,a_err='Invalid TRANS in SLUDist subsolve')
goto 9999
end select end select
if(info /=0) goto 9999 if (info == 0) call psb_geaxpby(alpha,ww,beta,y,desc_data,info)
call psb_geaxpby(alpha,ww,beta,y,desc_data,info)
case (mld_umf_) case (mld_umf_)
! !
@ -301,16 +298,22 @@ subroutine mld_zbjac_aply(alpha,prec,x,beta,y,desc_data,trans,work,info)
call mld_zumf_solve(1,n_row,ww,x,n_row,prec%iprcparm(mld_umf_numptr_),info) call mld_zumf_solve(1,n_row,ww,x,n_row,prec%iprcparm(mld_umf_numptr_),info)
case('C') case('C')
call mld_zumf_solve(2,n_row,ww,x,n_row,prec%iprcparm(mld_umf_numptr_),info) call mld_zumf_solve(2,n_row,ww,x,n_row,prec%iprcparm(mld_umf_numptr_),info)
case default
call psb_errpush(4001,name,a_err='Invalid TRANS in UMF subsolve')
goto 9999
end select end select
if(info /=0) goto 9999 if (info == 0) call psb_geaxpby(alpha,ww,beta,y,desc_data,info)
call psb_geaxpby(alpha,ww,beta,y,desc_data,info)
case default case default
write(0,*) 'Unknown factorization type in mld_bjac_aply',prec%iprcparm(mld_sub_solve_) call psb_errpush(4001,name,a_err='Invalid mld_sub_solve_')
goto 9999
end select end select
if (debugprt) write(0,*)' Y: ',y(:) if (info /= 0) then
call psb_errpush(4001,name,a_err='Error in subsolve Jacobi Sweeps = 1')
goto 9999
endif
else if (prec%iprcparm(mld_smooth_sweeps_) > 1) then else if (prec%iprcparm(mld_smooth_sweeps_) > 1) then
@ -352,15 +355,15 @@ subroutine mld_zbjac_aply(alpha,prec,x,beta,y,desc_data,trans,work,info)
ty(1:n_row) = x(1:n_row) ty(1:n_row) = x(1:n_row)
call psb_spmm(-zone,prec%av(mld_ap_nd_),tx,zone,ty,& call psb_spmm(-zone,prec%av(mld_ap_nd_),tx,zone,ty,&
& prec%desc_data,info,work=aux) & prec%desc_data,info,work=aux)
if(info /=0) goto 9999 if (info /=0) exit
call psb_spsm(zone,prec%av(mld_l_pr_),ty,zzero,ww,& call psb_spsm(zone,prec%av(mld_l_pr_),ty,zzero,ww,&
& prec%desc_data,info,& & prec%desc_data,info,&
& trans='N',unit='L',diag=prec%d,choice=psb_none_,work=aux) & trans='N',unit='L',diag=prec%d,choice=psb_none_,work=aux)
if(info /=0) goto 9999 if (info /=0) exit
call psb_spsm(zone,prec%av(mld_u_pr_),ww,zzero,tx,& call psb_spsm(zone,prec%av(mld_u_pr_),ww,zzero,tx,&
& prec%desc_data,info,& & prec%desc_data,info,&
& trans='N',unit='U',choice=psb_none_,work=aux) & trans='N',unit='U',choice=psb_none_,work=aux)
if(info /=0) goto 9999 if (info /=0) exit
end do end do
case(mld_sludist_) case(mld_sludist_)
@ -385,10 +388,10 @@ subroutine mld_zbjac_aply(alpha,prec,x,beta,y,desc_data,trans,work,info)
ty(1:n_row) = x(1:n_row) ty(1:n_row) = x(1:n_row)
call psb_spmm(-zone,prec%av(mld_ap_nd_),tx,zone,ty,& call psb_spmm(-zone,prec%av(mld_ap_nd_),tx,zone,ty,&
& prec%desc_data,info,work=aux) & prec%desc_data,info,work=aux)
if(info /=0) goto 9999 if (info /=0) exit
call mld_zslu_solve(0,n_row,1,ty,n_row,prec%iprcparm(mld_slu_ptr_),info) call mld_zslu_solve(0,n_row,1,ty,n_row,prec%iprcparm(mld_slu_ptr_),info)
if(info /=0) goto 9999 if (info /=0) exit
tx(1:n_row) = ty(1:n_row) tx(1:n_row) = ty(1:n_row)
end do end do
@ -406,23 +409,34 @@ subroutine mld_zbjac_aply(alpha,prec,x,beta,y,desc_data,trans,work,info)
ty(1:n_row) = x(1:n_row) ty(1:n_row) = x(1:n_row)
call psb_spmm(-zone,prec%av(mld_ap_nd_),tx,zone,ty,& call psb_spmm(-zone,prec%av(mld_ap_nd_),tx,zone,ty,&
& prec%desc_data,info,work=aux) & prec%desc_data,info,work=aux)
if(info /=0) goto 9999 if (info /=0) exit
call mld_zumf_solve(0,n_row,ww,ty,n_row,& call mld_zumf_solve(0,n_row,ww,ty,n_row,&
& prec%iprcparm(mld_umf_numptr_),info) & prec%iprcparm(mld_umf_numptr_),info)
if(info /=0) goto 9999 if (info /=0) exit
tx(1:n_row) = ww(1:n_row) tx(1:n_row) = ww(1:n_row)
end do end do
case default
call psb_errpush(4001,name,a_err='Invalid mld_sub_solve_')
goto 9999
end select end select
if (info /= 0) then
info=4001
call psb_errpush(info,name,a_err='subsolve with Jacobi sweeps > 1')
goto 9999
end if
! !
! Put the result into the output vector Y. ! Put the result into the output vector Y.
! !
call psb_geaxpby(alpha,tx,beta,y,desc_data,info) call psb_geaxpby(alpha,tx,beta,y,desc_data,info)
deallocate(tx,ty,stat=info)
if (info /= 0) then
deallocate(tx,ty) info=4001
call psb_errpush(info,name,a_err='final cleanup with Jacobi sweeps > 1')
goto 9999
end if
else else
@ -446,7 +460,6 @@ subroutine mld_zbjac_aply(alpha,prec,x,beta,y,desc_data,trans,work,info)
return return
9999 continue 9999 continue
call psb_errpush(info,name,i_err=int_err)
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()

195
mlprec/mld_zbjac_bld.f90
Unescape Escape View File

@ -59,19 +59,14 @@
! 2. setup of block-Jacobi sweeps to compute an approximate solution of a ! 2. setup of block-Jacobi sweeps to compute an approximate solution of a
! linear system ! linear system
! A*Y = X, ! A*Y = X,
!
! distributed among the processes (allowed only at the coarsest level); ! distributed among the processes (allowed only at the coarsest level);
! !
! 3. LU factorization of a linear system ! 3. LU factorization of a linear system
!
! A*Y = X, ! A*Y = X,
!
! distributed among the processes (allowed only at the coarsest level); ! distributed among the processes (allowed only at the coarsest level);
! !
! 4. LU or incomplete LU factorization of a linear system ! 4. LU or incomplete LU factorization of a linear system
!
! A*Y = X, ! A*Y = X,
!
! replicated on the processes (allowed only at the coarsest level). ! replicated on the processes (allowed only at the coarsest level).
! !
! The following factorizations are available: ! The following factorizations are available:
@ -116,7 +111,7 @@ subroutine mld_zbjac_bld(a,desc_a,p,upd,info)
integer :: int_err(5) integer :: int_err(5)
character :: trans, unitd character :: trans, unitd
type(psb_zspmat_type) :: blck, atmp type(psb_zspmat_type) :: blck, atmp
logical, parameter :: debugprt=.false., debug=.false., aggr_dump=.false. integer :: debug_level, debug_unit
integer :: err_act, n_row, nrow_a,n_col integer :: err_act, n_row, nrow_a,n_col
integer :: ictxt,np,me integer :: ictxt,np,me
character(len=20) :: name character(len=20) :: name
@ -126,8 +121,9 @@ subroutine mld_zbjac_bld(a,desc_a,p,upd,info)
info=0 info=0
name='mld_zbjac_bld' name='mld_zbjac_bld'
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
debug_unit = psb_get_debug_unit()
ictxt=psb_cd_get_context(desc_a) debug_level = psb_get_debug_level()
ictxt = psb_cd_get_context(desc_a)
call psb_info(ictxt, me, np) call psb_info(ictxt, me, np)
m = a%m m = a%m
@ -152,9 +148,9 @@ subroutine mld_zbjac_bld(a,desc_a,p,upd,info)
call psb_nullify_sp(atmp) call psb_nullify_sp(atmp)
if(debug) write(0,*)me,': calling mld_asmat_bld',& if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),': Start',&
& p%iprcparm(mld_prec_type_),p%iprcparm(mld_n_ovr_) & p%iprcparm(mld_prec_type_),p%iprcparm(mld_n_ovr_)
if (debug) call psb_barrier(ictxt)
! !
! Build the communication descriptor for the Additive Schwarz ! Build the communication descriptor for the Additive Schwarz
@ -166,22 +162,14 @@ subroutine mld_zbjac_bld(a,desc_a,p,upd,info)
call mld_asmat_bld(p%iprcparm(mld_prec_type_),p%iprcparm(mld_n_ovr_),a,& call mld_asmat_bld(p%iprcparm(mld_prec_type_),p%iprcparm(mld_n_ovr_),a,&
& blck,desc_a,upd,p%desc_data,info,outfmt=csrfmt) & blck,desc_a,upd,p%desc_data,info,outfmt=csrfmt)
if (debugprt) then if (info/=0) then
open(60+me)
call psb_csprt(60+me,a,head='% A')
close(60+me)
open(70+me)
call psb_csprt(70+me,blck,head='% BLCK')
close(70+me)
endif
if(info/=0) then
call psb_errpush(4010,name,a_err='mld_asmat_bld') call psb_errpush(4010,name,a_err='mld_asmat_bld')
goto 9999 goto 9999
end if end if
if (debug) write(0,*)me,': out of mld_asmat_bld' if (debug_level >= psb_debug_outer_) &
if (debug) call psb_barrier(ictxt) & write(debug_unit,*) me,' ',trim(name),&
& ': out of mld_asmat_bld'
! !
! Treat separately the case the local matrix has to be reordered ! Treat separately the case the local matrix has to be reordered
@ -200,7 +188,6 @@ subroutine mld_zbjac_bld(a,desc_a,p,upd,info)
! matrix is stored into atmp, using the COO format. ! matrix is stored into atmp, using the COO format.
! !
call mld_sp_renum(a,desc_a,blck,p,atmp,info) call mld_sp_renum(a,desc_a,blck,p,atmp,info)
if (info/=0) then if (info/=0) then
call psb_errpush(4010,name,a_err='mld_sp_renum') call psb_errpush(4010,name,a_err='mld_sp_renum')
goto 9999 goto 9999
@ -212,10 +199,10 @@ subroutine mld_zbjac_bld(a,desc_a,p,upd,info)
! !
call psb_sp_clip(atmp,p%av(mld_ap_nd_),info,& call psb_sp_clip(atmp,p%av(mld_ap_nd_),info,&
& jmin=atmp%m+1,rscale=.false.,cscale=.false.) & jmin=atmp%m+1,rscale=.false.,cscale=.false.)
if (info == 0) call psb_spcnv(p%av(mld_ap_nd_),info,&
call psb_spcnv(p%av(mld_ap_nd_),info,afmt='csr',dupl=psb_dupl_add_) & afmt='csr',dupl=psb_dupl_add_)
if(info /= 0) then if (info /= 0) then
call psb_errpush(4010,name,a_err='psb_spcnv csr 1') call psb_errpush(4010,name,a_err='psb_spcnv')
goto 9999 goto 9999
end if end if
@ -232,14 +219,9 @@ subroutine mld_zbjac_bld(a,desc_a,p,upd,info)
end if end if
if (debugprt) then if (debug_level >= psb_debug_outer_) &
call psb_barrier(ictxt) & write(debug_unit,*) me,' ',trim(name),' Factoring rows ',&
open(40+me) & atmp%m,a%m,blck%m,atmp%ia2(atmp%m+1)-1
call psb_csprt(40+me,atmp,head='% Local matrix')
close(40+me)
endif
if (debug) write(0,*) me,' Factoring rows ',&
&atmp%m,a%m,blck%m,atmp%ia2(atmp%m+1)-1
! !
! Compute a factorization of the diagonal block of the local matrix, ! Compute a factorization of the diagonal block of the local matrix,
@ -251,48 +233,21 @@ subroutine mld_zbjac_bld(a,desc_a,p,upd,info)
! !
! ILU(k)/MILU(k)/ILU(k,t) factorization. ! ILU(k)/MILU(k)/ILU(k,t) factorization.
! !
call psb_spcnv(atmp,info,afmt='csr',dupl=psb_dupl_add_) call psb_spcnv(atmp,info,afmt='csr',dupl=psb_dupl_add_)
if (info /= 0) then if (info == 0) call mld_ilu_bld(atmp,p%desc_data,p,upd,info)
call psb_errpush(4010,name,a_err='psb_spcnv csr 2')
goto 9999
end if
call mld_ilu_bld(atmp,p%desc_data,p,upd,info)
if (info/=0) then if (info/=0) then
call psb_errpush(4010,name,a_err='mld_ilu_bld') call psb_errpush(4010,name,a_err='mld_ilu_bld')
goto 9999 goto 9999
end if end if
if (debugprt) then
open(80+me)
call psb_csprt(80+me,p%av(mld_l_pr_),head='% Local L factor')
write(80+me,*) '% Diagonal: ',p%av(mld_l_pr_)%m
do i=1,p%av(mld_l_pr_)%m
write(80+me,*) i,i,p%d(i)
enddo
call psb_csprt(80+me,p%av(mld_u_pr_),head='% Local U factor')
close(80+me)
endif
case(mld_slu_) case(mld_slu_)
! !
! LU factorization through the SuperLU package. ! LU factorization through the SuperLU package.
! !
call psb_spcnv(atmp,info,afmt='csr',dupl=psb_dupl_add_) call psb_spcnv(atmp,info,afmt='csr',dupl=psb_dupl_add_)
if (info == 0) call mld_slu_bld(atmp,p%desc_data,p,info)
if (info /= 0) then if (info /= 0) then
call psb_errpush(4010,name,a_err='psb_spcnv csr 3')
goto 9999
end if
call mld_slu_bld(atmp,p%desc_data,p,info)
if(info /= 0) then
call psb_errpush(4010,name,a_err='mld_slu_bld') call psb_errpush(4010,name,a_err='mld_slu_bld')
goto 9999 goto 9999
end if end if
@ -301,15 +256,8 @@ subroutine mld_zbjac_bld(a,desc_a,p,upd,info)
! !
! LU factorization through the UMFPACK package. ! LU factorization through the UMFPACK package.
! !
call psb_spcnv(atmp,info,afmt='csc',dupl=psb_dupl_add_) call psb_spcnv(atmp,info,afmt='csc',dupl=psb_dupl_add_)
if (info /= 0) then if (info == 0) call mld_umf_bld(atmp,p%desc_data,p,info)
call psb_errpush(4010,name,a_err='psb_spcnv csc')
goto 9999
end if
call mld_umf_bld(atmp,p%desc_data,p,info)
if(debug) write(0,*)me,': Done mld_umf_bld ',info
if (info /= 0) then if (info /= 0) then
call psb_errpush(4010,name,a_err='mld_umf_bld') call psb_errpush(4010,name,a_err='mld_umf_bld')
goto 9999 goto 9999
@ -319,19 +267,19 @@ subroutine mld_zbjac_bld(a,desc_a,p,upd,info)
! !
! Error: no factorization required. ! Error: no factorization required.
! !
info=4010 info=4001
call psb_errpush(info,name,a_err='Inconsistent prec mld_f_none_') call psb_errpush(info,name,a_err='Inconsistent prec mld_f_none_')
goto 9999 goto 9999
case default case default
info=4010 info=4001
call psb_errpush(info,name,a_err='Unknown mld_sub_solve_') call psb_errpush(info,name,a_err='Unknown mld_sub_solve_')
goto 9999 goto 9999
end select end select
call psb_sp_free(atmp,info) call psb_sp_free(atmp,info)
if(info/=0) then if (info/=0) then
call psb_errpush(4010,name,a_err='psb_sp_free') call psb_errpush(4010,name,a_err='psb_sp_free')
goto 9999 goto 9999
end if end if
@ -347,7 +295,6 @@ subroutine mld_zbjac_bld(a,desc_a,p,upd,info)
! !
select case(p%iprcparm(mld_sub_solve_)) select case(p%iprcparm(mld_sub_solve_))
case(mld_ilu_n_,mld_milu_n_,mld_ilu_t_) case(mld_ilu_n_,mld_milu_n_,mld_ilu_t_)
! !
! ILU(k)/MILU(k)/ILU(k,t) factorization. ! ILU(k)/MILU(k)/ILU(k,t) factorization.
@ -367,13 +314,13 @@ subroutine mld_zbjac_bld(a,desc_a,p,upd,info)
! given that the output from CLIP is in COO. ! given that the output from CLIP is in COO.
call psb_sp_clip(a,p%av(mld_ap_nd_),info,& call psb_sp_clip(a,p%av(mld_ap_nd_),info,&
& jmin=nrow_a+1,rscale=.false.,cscale=.false.) & jmin=nrow_a+1,rscale=.false.,cscale=.false.)
call psb_sp_clip(blck,atmp,info,& if (info == 0) call psb_sp_clip(blck,atmp,info,&
& jmin=nrow_a+1,rscale=.false.,cscale=.false.) & jmin=nrow_a+1,rscale=.false.,cscale=.false.)
call psb_rwextd(n_row,p%av(mld_ap_nd_),info,b=atmp) if (info == 0) call psb_rwextd(n_row,p%av(mld_ap_nd_),info,b=atmp)
if (info == 0) call psb_spcnv(p%av(mld_ap_nd_),info,&
call psb_spcnv(p%av(mld_ap_nd_),info,afmt='csr',dupl=psb_dupl_add_) & afmt='csr',dupl=psb_dupl_add_)
if(info /= 0) then if (info /= 0) then
call psb_errpush(4010,name,a_err='psb_spcnv csr 4') call psb_errpush(4010,name,a_err='clip & psb_spcnv csr 4')
goto 9999 goto 9999
end if end if
@ -390,45 +337,23 @@ subroutine mld_zbjac_bld(a,desc_a,p,upd,info)
end if end if
call psb_sp_free(atmp,info) call psb_sp_free(atmp,info)
end if end if
! !
! Compute the incomplete LU factorization. ! Compute the incomplete LU factorization.
! !
call mld_ilu_bld(a,desc_a,p,upd,info,blck=blck) call mld_ilu_bld(a,desc_a,p,upd,info,blck=blck)
if (info/=0) then
if(info/=0) then
call psb_errpush(4010,name,a_err='mld_ilu_bld') call psb_errpush(4010,name,a_err='mld_ilu_bld')
goto 9999 goto 9999
end if end if
if (debugprt) then
open(80+me)
call psb_csprt(80+me,p%av(mld_l_pr_),head='% Local L factor')
write(80+me,*) '% Diagonal: ',p%av(mld_l_pr_)%m
do i=1,p%av(mld_l_pr_)%m
write(80+me,*) i,i,p%d(i)
enddo
call psb_csprt(80+me,p%av(mld_u_pr_),head='% Local U factor')
close(80+me)
endif
case(mld_slu_) case(mld_slu_)
! !
! LU factorization through the SuperLU package. ! LU factorization through the SuperLU package.
! !
call psb_spcnv(a,atmp,info,afmt='coo')
if (info /= 0) then
call psb_errpush(4010,name,a_err='psb_spcnv')
goto 9999
end if
n_row = psb_cd_get_local_rows(p%desc_data) n_row = psb_cd_get_local_rows(p%desc_data)
n_col = psb_cd_get_local_cols(p%desc_data) n_col = psb_cd_get_local_cols(p%desc_data)
call psb_rwextd(n_row,atmp,info,b=blck) call psb_spcnv(a,atmp,info,afmt='coo')
if (info == 0) call psb_rwextd(n_row,atmp,info,b=blck)
! !
! In case of multiple block-Jacobi sweeps, clip into p%av(ap_nd_) ! In case of multiple block-Jacobi sweeps, clip into p%av(ap_nd_)
@ -437,11 +362,12 @@ subroutine mld_zbjac_bld(a,desc_a,p,upd,info)
! !
if (p%iprcparm(mld_smooth_sweeps_) > 1) then if (p%iprcparm(mld_smooth_sweeps_) > 1) then
call psb_sp_clip(atmp,p%av(mld_ap_nd_),info,& if (info == 0) call psb_sp_clip(atmp,p%av(mld_ap_nd_),info,&
& jmin=atmp%m+1,rscale=.false.,cscale=.false.) & jmin=atmp%m+1,rscale=.false.,cscale=.false.)
call psb_spcnv(p%av(mld_ap_nd_),info,afmt='csr',dupl=psb_dupl_add_) if (info == 0) call psb_spcnv(p%av(mld_ap_nd_),info,&
if(info /= 0) then & afmt='csr',dupl=psb_dupl_add_)
if (info /= 0) then
call psb_errpush(4010,name,a_err='psb_spcnv csr 6') call psb_errpush(4010,name,a_err='psb_spcnv csr 6')
goto 9999 goto 9999
end if end if
@ -458,19 +384,18 @@ subroutine mld_zbjac_bld(a,desc_a,p,upd,info)
p%iprcparm(mld_smooth_sweeps_) = 1 p%iprcparm(mld_smooth_sweeps_) = 1
end if end if
endif endif
! !
! Compute the LU factorization. ! Compute the LU factorization.
! !
if (info == 0) call psb_spcnv(atmp,info,afmt='csr',dupl=psb_dupl_add_) if (info == 0) call psb_spcnv(atmp,info,afmt='csr',dupl=psb_dupl_add_)
if (info == 0) call mld_slu_bld(atmp,p%desc_data,p,info) if (info == 0) call mld_slu_bld(atmp,p%desc_data,p,info)
if(info /= 0) then if (info /= 0) then
call psb_errpush(4010,name,a_err='mld_slu_bld') call psb_errpush(4010,name,a_err='mld_slu_bld')
goto 9999 goto 9999
end if end if
call psb_sp_free(atmp,info) call psb_sp_free(atmp,info)
if(info/=0) then if (info/=0) then
call psb_errpush(4010,name,a_err='psb_sp_free') call psb_errpush(4010,name,a_err='psb_sp_free')
goto 9999 goto 9999
end if end if
@ -481,23 +406,15 @@ subroutine mld_zbjac_bld(a,desc_a,p,upd,info)
! when the matrix is distributed among the processes. ! when the matrix is distributed among the processes.
! NOTE: Should have NO overlap here!!!! ! NOTE: Should have NO overlap here!!!!
! !
call psb_spcnv(a,atmp,info,afmt='csr') call psb_spcnv(a,atmp,info,afmt='csr')
if (info /= 0) then
call psb_errpush(4010,name,a_err='psb_spcnv')
goto 9999
end if
n_row = psb_cd_get_local_rows(p%desc_data)
n_col = psb_cd_get_local_cols(p%desc_data)
if (info == 0) call mld_sludist_bld(atmp,p%desc_data,p,info) if (info == 0) call mld_sludist_bld(atmp,p%desc_data,p,info)
if(info /= 0) then if (info /= 0) then
call psb_errpush(4010,name,a_err='mld_slu_bld') call psb_errpush(4010,name,a_err='mld_slu_bld')
goto 9999 goto 9999
end if end if
call psb_sp_free(atmp,info) call psb_sp_free(atmp,info)
if(info/=0) then if (info/=0) then
call psb_errpush(4010,name,a_err='psb_sp_free') call psb_errpush(4010,name,a_err='psb_sp_free')
goto 9999 goto 9999
end if end if
@ -527,13 +444,12 @@ subroutine mld_zbjac_bld(a,desc_a,p,upd,info)
call psb_sp_clip(atmp,p%av(mld_ap_nd_),info,& call psb_sp_clip(atmp,p%av(mld_ap_nd_),info,&
& jmin=atmp%m+1,rscale=.false.,cscale=.false.) & jmin=atmp%m+1,rscale=.false.,cscale=.false.)
if (info == 0) call psb_spcnv(p%av(mld_ap_nd_),info,&
call psb_spcnv(p%av(mld_ap_nd_),info,afmt='csr',dupl=psb_dupl_add_) & afmt='csr',dupl=psb_dupl_add_)
if(info /= 0) then if (info /= 0) then
call psb_errpush(4010,name,a_err='psb_spcnv csr 8') call psb_errpush(4010,name,a_err='psb_spcnv csr 8')
goto 9999 goto 9999
end if end if
k = psb_sp_get_nnzeros(p%av(mld_ap_nd_)) k = psb_sp_get_nnzeros(p%av(mld_ap_nd_))
call psb_sum(ictxt,k) call psb_sum(ictxt,k)
@ -551,19 +467,17 @@ subroutine mld_zbjac_bld(a,desc_a,p,upd,info)
! Compute the LU factorization. ! Compute the LU factorization.
! !
if (info == 0) call psb_ipcoo2csc(atmp,info,clshr=.true.) if (info == 0) call psb_ipcoo2csc(atmp,info,clshr=.true.)
if (info /= 0) then if (info == 0) call mld_umf_bld(atmp,p%desc_data,p,info)
call psb_errpush(4010,name,a_err='psb_ipcoo2csc') if (debug_level >= psb_debug_outer_) &
goto 9999 & write(debug_unit,*) me,' ',trim(name),&
end if & ': Done mld_umf_bld ',info
call mld_umf_bld(atmp,p%desc_data,p,info)
if(debug) write(0,*)me,': Done mld_umf_bld ',info
if (info /= 0) then if (info /= 0) then
call psb_errpush(4010,name,a_err='mld_umf_bld') call psb_errpush(4010,name,a_err='mld_umf_bld')
goto 9999 goto 9999
end if end if
call psb_sp_free(atmp,info) call psb_sp_free(atmp,info)
if(info/=0) then if (info/=0) then
call psb_errpush(4010,name,a_err='psb_sp_free') call psb_errpush(4010,name,a_err='psb_sp_free')
goto 9999 goto 9999
end if end if
@ -573,31 +487,30 @@ subroutine mld_zbjac_bld(a,desc_a,p,upd,info)
! !
! Error: no factorization required. ! Error: no factorization required.
! !
info=4010 info=4001
call psb_errpush(info,name,a_err='Inconsistent prec mld_f_none_') call psb_errpush(info,name,a_err='Inconsistent prec mld_f_none_')
goto 9999 goto 9999
case default case default
info=4010 info=4001
call psb_errpush(info,name,a_err='Unknown mld_sub_solve_') call psb_errpush(info,name,a_err='Unknown mld_sub_solve_')
goto 9999 goto 9999
end select end select
case default case default
info=4010 info=4001
call psb_errpush(info,name,a_err='Invalid renum_') call psb_errpush(info,name,a_err='Invalid renum_')
goto 9999 goto 9999
end select end select
call psb_sp_free(blck,info) call psb_sp_free(blck,info)
if(info/=0) then if (info /= 0) then
call psb_errpush(4010,name,a_err='psb_sp_free') call psb_errpush(4010,name,a_err='psb_sp_free')
goto 9999 goto 9999
end if end if
if (debug) write(0,*) me,'End of ilu_bld' if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),'End '
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)

22
mlprec/mld_zdiagsc_bld.f90
Unescape Escape View File

@ -72,30 +72,25 @@ subroutine mld_zdiag_bld(a,desc_a,p,upd,info)
! Local variables ! Local variables
Integer :: err, n_row, n_col,I,j,k,ictxt,& Integer :: err, n_row, n_col,I,j,k,ictxt,&
& me,np,mglob,lw, err_act & me,np,mglob,lw, err_act
integer :: int_err(5) integer :: debug_level, debug_unit
logical, parameter :: debug=.false.
integer,parameter :: iroot=0,iout=60,ilout=40
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
if(psb_get_errstatus().ne.0) return if(psb_get_errstatus().ne.0) return
info=0 info=0
err=0 err=0
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
debug_unit = psb_get_debug_unit()
debug_level = psb_get_debug_level()
name = 'mld_zdiag_bld' name = 'mld_zdiag_bld'
if (debug) write(0,*) 'Entering diagsc_bld'
info = 0 info = 0
int_err(1) = 0
ictxt = psb_cd_get_context(desc_a) ictxt = psb_cd_get_context(desc_a)
n_row = psb_cd_get_local_rows(desc_a) n_row = psb_cd_get_local_rows(desc_a)
n_col = psb_cd_get_local_cols(desc_a) n_col = psb_cd_get_local_cols(desc_a)
mglob = psb_cd_get_global_rows(desc_a) mglob = psb_cd_get_global_rows(desc_a)
if (debug) write(0,*) 'Preconditioner Blacs_gridinfo'
call psb_info(ictxt, me, np) call psb_info(ictxt, me, np)
if (debug) write(0,*) 'Precond: Diagonal' if (debug_level >= psb_debug_outer_)&
& write(debug_unit,*) me,' ',trim(name),' Enter'
call psb_realloc(n_col,p%d,info) call psb_realloc(n_col,p%d,info)
if (info /= 0) then if (info /= 0) then
@ -122,7 +117,6 @@ subroutine mld_zdiag_bld(a,desc_a,p,upd,info)
goto 9999 goto 9999
end if end if
if (debug) write(ilout+me,*) 'VDIAG ',n_row
! !
! The i-th diagonal entry of the preconditioner is set to one if the ! The i-th diagonal entry of the preconditioner is set to one if the
! corresponding entry a_ii of the sparse matrix A is zero; otherwise ! corresponding entry a_ii of the sparse matrix A is zero; otherwise
@ -134,8 +128,6 @@ subroutine mld_zdiag_bld(a,desc_a,p,upd,info)
else else
p%d(i) = zone/p%d(i) p%d(i) = zone/p%d(i)
endif endif
if (debug) write(ilout+me,*) i,desc_a%loc_to_glob(i), p%d(i)
end do end do
if (a%pl(1) /= 0) then if (a%pl(1) /= 0) then
@ -151,8 +143,8 @@ subroutine mld_zdiag_bld(a,desc_a,p,upd,info)
end if end if
endif endif
if (debug) write(*,*) 'Preconditioner DIAG computed OK' if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),'Done'
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
return return

35
mlprec/mld_zilu_bld.f90
Unescape Escape View File

@ -106,7 +106,7 @@ subroutine mld_zilu_bld(a,desc_a,p,upd,info,blck)
! Local Variables ! Local Variables
integer :: i, nztota, err_act, n_row, nrow_a integer :: i, nztota, err_act, n_row, nrow_a
character :: trans, unitd character :: trans, unitd
logical, parameter :: debugprt=.false., debug=.false., aggr_dump=.false. integer :: debug_level, debug_unit
integer :: ictxt,np,me integer :: ictxt,np,me
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
@ -114,10 +114,12 @@ subroutine mld_zilu_bld(a,desc_a,p,upd,info,blck)
info=0 info=0
name='mld_zilu_bld' name='mld_zilu_bld'
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
debug_unit = psb_get_debug_unit()
ictxt=psb_cd_get_context(desc_a) debug_level = psb_get_debug_level()
ictxt = psb_cd_get_context(desc_a)
call psb_info(ictxt, me, np) call psb_info(ictxt, me, np)
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),' start'
trans = 'N' trans = 'N'
unitd = 'U' unitd = 'U'
@ -145,15 +147,15 @@ subroutine mld_zilu_bld(a,desc_a,p,upd,info,blck)
goto 9999 goto 9999
end if end if
endif endif
!!$ call psb_csprt(50+me,a,head='% (A)')
nrow_a = psb_cd_get_local_rows(desc_a) nrow_a = psb_cd_get_local_rows(desc_a)
nztota = psb_sp_get_nnzeros(a) nztota = psb_sp_get_nnzeros(a)
if (present(blck)) then if (present(blck)) then
nztota = nztota + psb_sp_get_nnzeros(blck) nztota = nztota + psb_sp_get_nnzeros(blck)
end if end if
if (debug) write(0,*)me,': out get_nnzeros',nztota,a%m,a%k if (debug_level >= psb_debug_outer_) &
if (debug) call psb_barrier(ictxt) & write(debug_unit,*) me,' ',trim(name),&
& ': out get_nnzeros',nztota,a%m,a%k
n_row = p%desc_data%matrix_data(psb_n_row_) n_row = p%desc_data%matrix_data(psb_n_row_)
p%av(mld_l_pr_)%m = n_row p%av(mld_l_pr_)%m = n_row
@ -253,22 +255,6 @@ subroutine mld_zilu_bld(a,desc_a,p,upd,info,blck)
end select end select
if (debugprt) then
!
! Print out the factors on file.
!
open(80+me)
call psb_csprt(80+me,p%av(mld_l_pr_),head='% Local L factor')
write(80+me,*) '% Diagonal: ',p%av(mld_l_pr_)%m
do i=1,p%av(mld_l_pr_)%m
write(80+me,*) i,i,p%d(i)
enddo
call psb_csprt(80+me,p%av(mld_u_pr_),head='% Local U factor')
close(80+me)
endif
if (psb_sp_getifld(psb_upd_,p%av(mld_u_pr_),info) /= psb_upd_perm_) then if (psb_sp_getifld(psb_upd_,p%av(mld_u_pr_),info) /= psb_upd_perm_) then
call psb_sp_trim(p%av(mld_u_pr_),info) call psb_sp_trim(p%av(mld_u_pr_),info)
endif endif
@ -277,7 +263,8 @@ subroutine mld_zilu_bld(a,desc_a,p,upd,info,blck)
call psb_sp_trim(p%av(mld_l_pr_),info) call psb_sp_trim(p%av(mld_l_pr_),info)
endif endif
if (debug) write(0,*) me,'End of ilu_bld' if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),'End'
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
return return

9
mlprec/mld_zilu_fct.f90
Unescape Escape View File

@ -115,7 +115,6 @@ subroutine mld_zilu_fct(ialg,a,l,u,d,info,blck)
integer :: l1, l2,m,err_act integer :: l1, l2,m,err_act
type(psb_zspmat_type), pointer :: blck_ type(psb_zspmat_type), pointer :: blck_
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
logical, parameter :: debug=.false.
name='mld_zilu_fct' name='mld_zilu_fct'
info = 0 info = 0
@ -289,7 +288,6 @@ contains
integer :: i,j,k,l,low1,low2,kk,jj,ll, ktrw,err_act integer :: i,j,k,l,low1,low2,kk,jj,ll, ktrw,err_act
complex(kind(1.d0)) :: dia,temp complex(kind(1.d0)) :: dia,temp
integer, parameter :: nrb=16 integer, parameter :: nrb=16
logical,parameter :: debug=.false.
type(psb_zspmat_type) :: trw type(psb_zspmat_type) :: trw
integer :: int_err(5) integer :: int_err(5)
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
@ -301,7 +299,7 @@ contains
call psb_nullify_sp(trw) call psb_nullify_sp(trw)
trw%m=0 trw%m=0
trw%k=0 trw%k=0
if(debug) write(0,*)'LUINT Allocating TRW'
call psb_sp_all(trw,1,info) call psb_sp_all(trw,1,info)
if(info.ne.0) then if(info.ne.0) then
info=4010 info=4010
@ -309,20 +307,18 @@ contains
call psb_errpush(info,name,a_err=ch_err) call psb_errpush(info,name,a_err=ch_err)
goto 9999 goto 9999
end if end if
if(debug) write(0,*)'LUINT Done Allocating TRW'
lia2(1) = 1 lia2(1) = 1
uia2(1) = 1 uia2(1) = 1
l1 = 0 l1 = 0
l2 = 0 l2 = 0
m = ma+mb m = ma+mb
if(debug) write(0,*)'In DCSRLU Begin cycle',m,ma,mb
! !
! Cycle over the matrix rows ! Cycle over the matrix rows
! !
do i = 1, m do i = 1, m
if(debug) write(0,*)'LUINT: Loop index ',i,ma
d(i) = zzero d(i) = zzero
if (i <= ma) then if (i <= ma) then
@ -447,7 +443,6 @@ contains
call psb_errpush(info,name,a_err=ch_err) call psb_errpush(info,name,a_err=ch_err)
goto 9999 goto 9999
end if end if
if(debug) write(0,*)'Leaving ilu_fct'
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
return return

13
mlprec/mld_ziluk_fct.f90
Unescape Escape View File

@ -111,14 +111,11 @@ subroutine mld_ziluk_fct(fill_in,ialg,a,l,u,d,info,blck)
type(psb_zspmat_type), pointer :: blck_ type(psb_zspmat_type), pointer :: blck_
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
logical, parameter :: debug=.false.
name='mld_ziluk_fct' name='mld_ziluk_fct'
info = 0 info = 0
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
if (debug) write(0,*) 'mld_diluk_fct: start'
! !
! Point to / allocate memory for the incomplete factorization ! Point to / allocate memory for the incomplete factorization
! !
@ -144,7 +141,6 @@ subroutine mld_ziluk_fct(fill_in,ialg,a,l,u,d,info,blck)
! !
! Compute the ILU(k) or the MILU(k) factorization, depending on ialg ! Compute the ILU(k) or the MILU(k) factorization, depending on ialg
! !
if (debug) write(0,*) 'mld_ziluk_fct: calling fctint'
call mld_ziluk_fctint(fill_in,ialg,m,a%m,a,blck_%m,blck_,& call mld_ziluk_fctint(fill_in,ialg,m,a%m,a,blck_%m,blck_,&
& d,l%aspk,l%ia1,l%ia2,u%aspk,u%ia1,u%ia2,l1,l2,info) & d,l%aspk,l%ia1,l%ia2,u%aspk,u%ia1,u%ia2,l1,l2,info)
if (info /= 0) then if (info /= 0) then
@ -302,7 +298,6 @@ contains
! !
! Allocate a temporary buffer for the iluk_copyin function ! Allocate a temporary buffer for the iluk_copyin function
! !
if (debug) write(0,*)'LUINT Allocating TRW'
call psb_sp_all(0,0,trw,1,info) call psb_sp_all(0,0,trw,1,info)
if (info==0) call psb_ensure_size(m+1,lia2,info) if (info==0) call psb_ensure_size(m+1,lia2,info)
if (info==0) call psb_ensure_size(m+1,uia2,info) if (info==0) call psb_ensure_size(m+1,uia2,info)
@ -312,15 +307,12 @@ contains
call psb_errpush(info,name,a_err='psb_sp_all') call psb_errpush(info,name,a_err='psb_sp_all')
goto 9999 goto 9999
end if end if
if (debug) write(0,*)'LUINT Done Allocating TRW'
l1=0 l1=0
l2=0 l2=0
lia2(1) = 1 lia2(1) = 1
uia2(1) = 1 uia2(1) = 1
if (debug) write(0,*)'In DCSRLU Begin cycle',m,ma,mb
! !
! Allocate memory to hold the entries of a row and the corresponding ! Allocate memory to hold the entries of a row and the corresponding
! fill levels ! fill levels
@ -341,8 +333,6 @@ contains
! !
do i = 1, m do i = 1, m
if (debug.and.(mod(i,500)==1)) write(0,*)'LUINT: Loop index ',i,ma
! !
! At each iteration of the loop we keep in a heap the column indices ! At each iteration of the loop we keep in a heap the column indices
! affected by the factorization. The heap is initialized and filled ! affected by the factorization. The heap is initialized and filled
@ -365,8 +355,6 @@ contains
call iluk_copyin(i-ma,mb,b,1,m,row,rowlevs,heap,ktrw,trw) call iluk_copyin(i-ma,mb,b,1,m,row,rowlevs,heap,ktrw,trw)
endif endif
if (debug) write(0,*)'LUINT: input Copy done'
! Do an elimination step on the current row. It turns out we only ! Do an elimination step on the current row. It turns out we only
! need to keep track of fill levels for the upper triangle, hence we ! need to keep track of fill levels for the upper triangle, hence we
! do not have a lowlevs variable. ! do not have a lowlevs variable.
@ -397,7 +385,6 @@ contains
call psb_errpush(info,name,a_err=ch_err) call psb_errpush(info,name,a_err=ch_err)
goto 9999 goto 9999
end if end if
if (debug) write(0,*)'Leaving ilu_fct'
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
return return

42
mlprec/mld_zilut_fct.f90
Unescape Escape View File

@ -110,14 +110,11 @@ subroutine mld_zilut_fct(fill_in,thres,ialg,a,l,u,d,info,blck)
type(psb_zspmat_type), pointer :: blck_ type(psb_zspmat_type), pointer :: blck_
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
logical, parameter :: debug=.false.
name='mld_zilut_fct' name='mld_zilut_fct'
info = 0 info = 0
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
if (debug) write(0,*) 'mld_zilut_fct: start'
! !
! Point to / allocate memory for the incomplete factorization ! Point to / allocate memory for the incomplete factorization
! !
@ -143,7 +140,6 @@ subroutine mld_zilut_fct(fill_in,thres,ialg,a,l,u,d,info,blck)
! !
! Compute the ILU(k,t) factorization ! Compute the ILU(k,t) factorization
! !
if (debug) write(0,*) 'mld_zilut_fct: calling fctint'
call mld_zilut_fctint(fill_in,thres,ialg,m,a%m,a,blck_%m,blck_,& call mld_zilut_fctint(fill_in,thres,ialg,m,a%m,a,blck_%m,blck_,&
& d,l%aspk,l%ia1,l%ia2,u%aspk,u%ia1,u%ia2,l1,l2,info) & d,l%aspk,l%ia1,l%ia2,u%aspk,u%ia1,u%ia2,l1,l2,info)
if (info /= 0) then if (info /= 0) then
@ -287,7 +283,6 @@ contains
integer, allocatable :: idxs(:) integer, allocatable :: idxs(:)
complex(kind(1.d0)), allocatable :: row(:) complex(kind(1.d0)), allocatable :: row(:)
type(psb_int_heap) :: heap type(psb_int_heap) :: heap
logical,parameter :: debug=.false.
type(psb_zspmat_type) :: trw type(psb_zspmat_type) :: trw
character(len=20), parameter :: name='mld_zilut_fctint' character(len=20), parameter :: name='mld_zilut_fctint'
character(len=20) :: ch_err character(len=20) :: ch_err
@ -301,7 +296,6 @@ contains
! !
! Allocate a temporary buffer for the ilut_copyin function ! Allocate a temporary buffer for the ilut_copyin function
! !
if (debug) write(0,*)'LUINT Allocating TRW'
call psb_sp_all(0,0,trw,1,info) call psb_sp_all(0,0,trw,1,info)
if (info==0) call psb_ensure_size(m+1,lia2,info) if (info==0) call psb_ensure_size(m+1,lia2,info)
if (info==0) call psb_ensure_size(m+1,uia2,info) if (info==0) call psb_ensure_size(m+1,uia2,info)
@ -311,15 +305,12 @@ contains
call psb_errpush(info,name,a_err='psb_sp_all') call psb_errpush(info,name,a_err='psb_sp_all')
goto 9999 goto 9999
end if end if
if (debug) write(0,*)'LUINT Done Allocating TRW'
l1=0 l1=0
l2=0 l2=0
lia2(1) = 1 lia2(1) = 1
uia2(1) = 1 uia2(1) = 1
if (debug) write(0,*)'In DCSRLU Begin cycle',m,ma,mb
! !
! Allocate memory to hold the entries of a row ! Allocate memory to hold the entries of a row
! !
@ -337,7 +328,6 @@ contains
! !
do i = 1, m do i = 1, m
if (debug) write(0,*)'LUINT: Loop index ',i
! !
! At each iteration of the loop we keep in a heap the column indices ! At each iteration of the loop we keep in a heap the column indices
! affected by the factorization. The heap is initialized and filled ! affected by the factorization. The heap is initialized and filled
@ -353,7 +343,6 @@ contains
call ilut_copyin(i-ma,mb,b,i,1,m,nlw,nup,jmaxup,nrmi,row,heap,ktrw,trw) call ilut_copyin(i-ma,mb,b,i,1,m,nlw,nup,jmaxup,nrmi,row,heap,ktrw,trw)
endif endif
if (debug) write(0,*)'LUINT: input Copy done'
! !
! Do an elimination step on current row ! Do an elimination step on current row
! !
@ -383,7 +372,6 @@ contains
call psb_errpush(info,name,a_err=ch_err) call psb_errpush(info,name,a_err=ch_err)
goto 9999 goto 9999
end if end if
if (debug) write(0,*)'Leaving ilu_fct'
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
return return
@ -675,7 +663,6 @@ contains
! Local Variables ! Local Variables
integer :: k,j,jj,info, lastk integer :: k,j,jj,info, lastk
complex(kind(1.d0)) :: rwk complex(kind(1.d0)) :: rwk
logical, parameter :: debug=.false.
call psb_ensure_size(200,idxs,info) call psb_ensure_size(200,idxs,info)
@ -748,12 +735,6 @@ contains
end do end do
if (debug) then
write(0,*) 'At end of factint: ',i,nidx
write(0,*) idxs(1:nidx)
write(0,*) row(idxs(1:nidx))
end if
end subroutine ilut_fact end subroutine ilut_fact
! !
@ -870,7 +851,6 @@ contains
character(len=20), parameter :: name='mld_zilut_fctint' character(len=20), parameter :: name='mld_zilut_fctint'
character(len=20) :: ch_err character(len=20) :: ch_err
logical :: fndmaxup logical :: fndmaxup
logical, parameter :: debug=.false.
if (psb_get_errstatus() /= 0) return if (psb_get_errstatus() /= 0) return
info=0 info=0
@ -909,10 +889,6 @@ contains
if (idxs(idxp) >= i) exit if (idxs(idxp) >= i) exit
widx = idxs(idxp) widx = idxs(idxp)
witem = row(widx) witem = row(widx)
if (debug) then
write(0,*) 'Lower: Deciding on drop of item ',witem,widx,thres,nrmi,thres*nrmi
end if
! !
! Dropping rule based on the 2-norm ! Dropping rule based on the 2-norm
! !
@ -1032,11 +1008,6 @@ contains
cycle cycle
end if end if
witem = row(widx) witem = row(widx)
if (debug) then
write(0,*) 'Upper: Deciding on drop of item ',witem,widx,&
& jmaxup,thres,nrmi,thres*nrmi
end if
! !
! Dropping rule based on the 2-norm. But keep the jmaxup-th entry anyway. ! Dropping rule based on the 2-norm. But keep the jmaxup-th entry anyway.
! !
@ -1051,14 +1022,6 @@ contains
end do end do
if (debug) then
write(0,*) 'Row ',i,' copyout: after first round at upper:',nz,jmaxup
write(0,*) xwid(1:nz)
write(0,*) xw(1:nz)
write(0,*) 'Dumping heap'
call psb_dump_heap(0,heap,info)
end if
! !
! Now we have to take out the first nup-fill_in entries. But make sure ! Now we have to take out the first nup-fill_in entries. But make sure
! we include entry jmaxup. ! we include entry jmaxup.
@ -1093,11 +1056,6 @@ contains
! Now we put things back into ascending column order ! Now we put things back into ascending column order
! !
call psb_msort(xwid(1:nz),indx(1:nz),dir=psb_sort_up_) call psb_msort(xwid(1:nz),indx(1:nz),dir=psb_sort_up_)
if (debug) then
write(0,*) 'Row ',i,' copyout: after sort at upper:',nz,jmaxup
write(0,*) xwid(1:nz)
write(0,*) xw(indx(1:nz))
end if
! !
! Copy out the upper part of the row ! Copy out the upper part of the row

293
mlprec/mld_zmlprec_aply.f90
Unescape Escape View File

@ -64,11 +64,11 @@
! level 1 is the finest level and A(1) is the matrix A. ! level 1 is the finest level and A(1) is the matrix A.
! !
! For a general description of (parallel) multilevel preconditioners see ! For a general description of (parallel) multilevel preconditioners see
! 1. B.F. Smith, P.E. Bjorstad & W.D. Gropp, ! - B.F. Smith, P.E. Bjorstad & W.D. Gropp,
! Domain decomposition: parallel multilevel methods for elliptic partial ! Domain decomposition: parallel multilevel methods for elliptic partial
! differential equations, ! differential equations,
! Cambridge University Press, 1996. ! Cambridge University Press, 1996.
! 2. K. Stuben, ! - K. Stuben,
! Algebraic Multigrid (AMG): An Introduction with Applications, ! Algebraic Multigrid (AMG): An Introduction with Applications,
! GMD Report N. 70, 1999. ! GMD Report N. 70, 1999.
! !
@ -182,7 +182,7 @@ subroutine mld_zmlprec_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info)
! Local variables ! Local variables
integer :: n_row,n_col integer :: n_row,n_col
integer :: ictxt,np,me,i, nr2l,nc2l,err_act integer :: ictxt,np,me,i, nr2l,nc2l,err_act
logical, parameter :: debug=.false., debugprt=.false. integer :: debug_level, debug_unit
integer :: ismth, nlev, ilev, icm integer :: ismth, nlev, ilev, icm
character(len=20) :: name character(len=20) :: name
@ -194,12 +194,15 @@ subroutine mld_zmlprec_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info)
name='mld_zmlprec_aply' name='mld_zmlprec_aply'
info = 0 info = 0
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
debug_unit = psb_get_debug_unit()
debug_level = psb_get_debug_level()
ictxt = psb_cd_get_context(desc_data) ictxt = psb_cd_get_context(desc_data)
call psb_info(ictxt, me, np) call psb_info(ictxt, me, np)
if (debug) write(0,*) me,'Entry to mlprec_aply ',& if (debug_level >= psb_debug_inner_) &
& size(baseprecv) & write(debug_unit,*) me,' ',trim(name),&
& ' Entry ', size(baseprecv)
nlev = size(baseprecv) nlev = size(baseprecv)
allocate(mlprec_wrk(nlev),stat=info) allocate(mlprec_wrk(nlev),stat=info)
@ -215,7 +218,7 @@ subroutine mld_zmlprec_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info)
! !
! No preconditioning, should not really get here ! No preconditioning, should not really get here
! !
call psb_errpush(4010,name,a_err='mld_no_ml_ in mlprc_aply?') call psb_errpush(4001,name,a_err='mld_no_ml_ in mlprc_aply?')
goto 9999 goto 9999
@ -260,7 +263,10 @@ subroutine mld_zmlprec_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info)
! !
call mld_baseprec_aply(alpha,baseprecv(1),x,beta,y,& call mld_baseprec_aply(alpha,baseprecv(1),x,beta,y,&
& baseprecv(1)%base_desc,trans,work,info) & baseprecv(1)%base_desc,trans,work,info)
if(info /=0) goto 9999 if (info /=0) then
call psb_errpush(4010,name,a_err='baseprec_aply')
goto 9999
end if
allocate(mlprec_wrk(1)%x2l(size(x)),mlprec_wrk(1)%y2l(size(y)), stat=info) allocate(mlprec_wrk(1)%x2l(size(x)),mlprec_wrk(1)%y2l(size(y)), stat=info)
if (info /= 0) then if (info /= 0) then
@ -309,12 +315,8 @@ subroutine mld_zmlprec_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info)
! !
call psb_halo(mlprec_wrk(ilev-1)%x2l,baseprecv(ilev-1)%base_desc,& call psb_halo(mlprec_wrk(ilev-1)%x2l,baseprecv(ilev-1)%base_desc,&
& info,work=work) & info,work=work)
if(info /=0) goto 9999 if (info == 0) call psb_csmm(zone,baseprecv(ilev)%av(mld_sm_pr_t_),&
& mlprec_wrk(ilev-1)%x2l,zzero,mlprec_wrk(ilev)%x2l,info)
call psb_csmm(zone,baseprecv(ilev)%av(mld_sm_pr_t_),mlprec_wrk(ilev-1)%x2l,&
& zzero,mlprec_wrk(ilev)%x2l,info)
if(info /=0) goto 9999
else else
! !
! Apply the raw aggregation map transpose (take a shortcut) ! Apply the raw aggregation map transpose (take a shortcut)
@ -326,11 +328,19 @@ subroutine mld_zmlprec_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info)
end do end do
end if end if
if (info /=0) then
call psb_errpush(4001,name,a_err='Error during restriction')
goto 9999
end if
if (icm == mld_repl_mat_) then if (icm == mld_repl_mat_) then
call psb_sum(ictxt,mlprec_wrk(ilev)%x2l(1:nr2l)) call psb_sum(ictxt,mlprec_wrk(ilev)%x2l(1:nr2l))
else if (icm /= mld_distr_mat_) then else if (icm /= mld_distr_mat_) then
write(0,*) 'Unknown value for baseprecv(2)%iprcparm(mld_coarse_mat_) ',icm info = 4013
call psb_errpush(info,name,a_err='invalid mld_coarse_mat_',&
& i_Err=(/icm,0,0,0,0/))
goto 9999
endif endif
! !
@ -363,8 +373,6 @@ subroutine mld_zmlprec_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info)
! !
call psb_csmm(zone,baseprecv(ilev)%av(mld_sm_pr_),mlprec_wrk(ilev)%y2l,& call psb_csmm(zone,baseprecv(ilev)%av(mld_sm_pr_),mlprec_wrk(ilev)%y2l,&
& zone,mlprec_wrk(ilev-1)%y2l,info) & zone,mlprec_wrk(ilev-1)%y2l,info)
if(info /=0) goto 9999
else else
! !
! Apply the raw aggregation map (take a shortcut) ! Apply the raw aggregation map (take a shortcut)
@ -375,6 +383,10 @@ subroutine mld_zmlprec_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info)
enddo enddo
end if end if
if (info /=0) then
call psb_errpush(4001,name,a_err='Error during prolognation')
goto 9999
end if
end do end do
! !
@ -383,8 +395,10 @@ subroutine mld_zmlprec_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info)
! Compute the output vector Y ! Compute the output vector Y
! !
call psb_geaxpby(alpha,mlprec_wrk(1)%y2l,zone,y,baseprecv(1)%base_desc,info) call psb_geaxpby(alpha,mlprec_wrk(1)%y2l,zone,y,baseprecv(1)%base_desc,info)
if(info /=0) goto 9999 if (info /= 0) then
call psb_errpush(4001,name,a_err='Error on final update')
goto 9999
end if
case(mld_mult_ml_) case(mld_mult_ml_)
@ -434,8 +448,9 @@ subroutine mld_zmlprec_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info)
! !
! Copy the input vector X ! Copy the input vector X
! !
if (debug) write(0,*) me, 'mlprec_aply desc_data',& if (debug_level >= psb_debug_inner_) &
& allocated(desc_data%matrix_data) & write(debug_unit,*) me,' ',trim(name),&
& ' desc_data status',allocated(desc_data%matrix_data)
n_col = psb_cd_get_local_cols(desc_data) n_col = psb_cd_get_local_cols(desc_data)
nc2l = psb_cd_get_local_cols(baseprecv(1)%desc_data) nc2l = psb_cd_get_local_cols(baseprecv(1)%desc_data)
@ -465,7 +480,9 @@ subroutine mld_zmlprec_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info)
ismth = baseprecv(ilev)%iprcparm(mld_aggr_kind_) ismth = baseprecv(ilev)%iprcparm(mld_aggr_kind_)
icm = baseprecv(ilev)%iprcparm(mld_coarse_mat_) icm = baseprecv(ilev)%iprcparm(mld_coarse_mat_)
if (debug) write(0,*) me, 'mlprec_aply starting up sweep ',& if (debug_level >= psb_debug_inner_) &
& write(debug_unit,*) me,' ',trim(name), &
& ' starting up sweep ',&
& ilev,allocated(baseprecv(ilev)%iprcparm),n_row,n_col,& & ilev,allocated(baseprecv(ilev)%iprcparm),n_row,n_col,&
& nc2l, nr2l,ismth & nc2l, nr2l,ismth
@ -486,15 +503,13 @@ subroutine mld_zmlprec_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info)
! !
! Apply the smoothed prolongator transpose ! Apply the smoothed prolongator transpose
! !
if (debug) write(0,*) me, 'mlprec_aply halo in up sweep ', ilev if (debug_level >= psb_debug_inner_) &
& write(debug_unit,*) me,' ',trim(name), ' up sweep ', ilev
call psb_halo(mlprec_wrk(ilev-1)%x2l,& call psb_halo(mlprec_wrk(ilev-1)%x2l,&
& baseprecv(ilev-1)%base_desc,info,work=work) & baseprecv(ilev-1)%base_desc,info,work=work)
if(info /=0) goto 9999 if (info == 0) call psb_csmm(zone,baseprecv(ilev)%av(mld_sm_pr_t_),&
if (debug) write(0,*) me, 'mlprec_aply csmm in up sweep ', ilev & mlprec_wrk(ilev-1)%x2l,zzero,mlprec_wrk(ilev)%x2l,info)
call psb_csmm(zone,baseprecv(ilev)%av(mld_sm_pr_t_),mlprec_wrk(ilev-1)%x2l, &
& zzero,mlprec_wrk(ilev)%x2l,info)
if(info /=0) goto 9999
else else
! !
! Apply the raw aggregation map transpose (take a shortcut) ! Apply the raw aggregation map transpose (take a shortcut)
@ -506,20 +521,18 @@ subroutine mld_zmlprec_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info)
end do end do
end if end if
if (info /=0) then
if (debug) write(0,*) me, 'mlprec_aply possible sum in up sweep ', & call psb_errpush(4001,name,a_err='Error during restriction')
& ilev,icm,associated(baseprecv(ilev)%base_desc),mld_repl_mat_ goto 9999
if (debug) write(0,*) me, 'mlprec_aply geaxpby in up sweep X', & end if
& ilev,associated(baseprecv(ilev)%base_desc),&
& baseprecv(ilev)%base_desc%matrix_data(psb_n_row_),&
& baseprecv(ilev)%base_desc%matrix_data(psb_n_col_),&
& size(mlprec_wrk(ilev)%tx),size(mlprec_wrk(ilev)%x2l)
if (icm == mld_repl_mat_) Then if (icm == mld_repl_mat_) Then
if (debug) write(0,*) 'Entering psb_sum ',nr2l
call psb_sum(ictxt,mlprec_wrk(ilev)%x2l(1:nr2l)) call psb_sum(ictxt,mlprec_wrk(ilev)%x2l(1:nr2l))
else if (icm /= mld_distr_mat_) Then else if (icm /= mld_distr_mat_) Then
write(0,*) 'Unknown value for baseprecv(2)%iprcparm(mld_coarse_mat_) ', icm info = 4013
call psb_errpush(info,name,a_err='invalid mld_coarse_mat_',&
& i_Err=(/icm,0,0,0,0/))
goto 9999
endif endif
! !
@ -527,9 +540,14 @@ subroutine mld_zmlprec_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info)
! !
call psb_geaxpby(zone,mlprec_wrk(ilev)%x2l,zzero,mlprec_wrk(ilev)%tx,& call psb_geaxpby(zone,mlprec_wrk(ilev)%x2l,zzero,mlprec_wrk(ilev)%tx,&
& baseprecv(ilev)%base_desc,info) & baseprecv(ilev)%base_desc,info)
if(info /=0) goto 9999 if (info /= 0) then
if (debug) write(0,*) me, 'mlprec_aply done up sweep ',& call psb_errpush(4001,name,a_err='Error in update')
& ilev goto 9999
end if
if (debug_level >= psb_debug_inner_) &
& write(debug_unit,*) me,' ',trim(name),&
& ' done up sweep ', ilev
enddo enddo
@ -540,10 +558,13 @@ subroutine mld_zmlprec_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info)
! !
call mld_baseprec_aply(zone,baseprecv(nlev),mlprec_wrk(nlev)%x2l, & call mld_baseprec_aply(zone,baseprecv(nlev),mlprec_wrk(nlev)%x2l, &
& zzero, mlprec_wrk(nlev)%y2l,baseprecv(nlev)%desc_data,'N',work,info) & zzero, mlprec_wrk(nlev)%y2l,baseprecv(nlev)%desc_data,'N',work,info)
if (info /=0) then
call psb_errpush(4010,name,a_err='baseprec_aply')
goto 9999
end if
if(info /=0) goto 9999 if (debug_level >= psb_debug_inner_) write(debug_unit,*) &
if (debug) write(0,*) me, 'mlprec_aply done prc_apl ',& & me,' ',trim(name), ' done baseprec_aply ', nlev
& nlev
! !
! STEP 4 ! STEP 4
@ -552,7 +573,10 @@ subroutine mld_zmlprec_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info)
! !
do ilev=nlev-1, 1, -1 do ilev=nlev-1, 1, -1
if (debug) write(0,*) me, 'mlprec_aply starting down sweep',ilev if (debug_level >= psb_debug_inner_) &
& write(debug_unit,*) me,' ',trim(name),&
& ' starting down sweep',ilev
ismth = baseprecv(ilev+1)%iprcparm(mld_aggr_kind_) ismth = baseprecv(ilev+1)%iprcparm(mld_aggr_kind_)
n_row = psb_cd_get_local_rows(baseprecv(ilev)%base_desc) n_row = psb_cd_get_local_rows(baseprecv(ilev)%base_desc)
@ -563,10 +587,8 @@ subroutine mld_zmlprec_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info)
if (ismth == mld_smooth_prol_) & if (ismth == mld_smooth_prol_) &
& call psb_halo(mlprec_wrk(ilev+1)%y2l,baseprecv(ilev+1)%desc_data,& & call psb_halo(mlprec_wrk(ilev+1)%y2l,baseprecv(ilev+1)%desc_data,&
& info,work=work) & info,work=work)
call psb_csmm(zone,baseprecv(ilev+1)%av(mld_sm_pr_),mlprec_wrk(ilev+1)%y2l,& if (info == 0) call psb_csmm(zone,baseprecv(ilev+1)%av(mld_sm_pr_),&
& zzero,mlprec_wrk(ilev)%y2l,info) & mlprec_wrk(ilev+1)%y2l, zzero,mlprec_wrk(ilev)%y2l,info)
if(info /=0) goto 9999
else else
! !
! Apply the raw aggregation map (take a shortcut) ! Apply the raw aggregation map (take a shortcut)
@ -576,7 +598,10 @@ subroutine mld_zmlprec_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info)
mlprec_wrk(ilev)%y2l(i) = mlprec_wrk(ilev)%y2l(i) + & mlprec_wrk(ilev)%y2l(i) = mlprec_wrk(ilev)%y2l(i) + &
& mlprec_wrk(ilev+1)%y2l(baseprecv(ilev+1)%mlia(i)) & mlprec_wrk(ilev+1)%y2l(baseprecv(ilev+1)%mlia(i))
enddo enddo
end if
if (info /=0) then
call psb_errpush(4001,name,a_err='Error during prolongation')
goto 9999
end if end if
! !
@ -585,16 +610,19 @@ subroutine mld_zmlprec_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info)
call psb_spmm(-zone,baseprecv(ilev)%base_a,mlprec_wrk(ilev)%y2l,& call psb_spmm(-zone,baseprecv(ilev)%base_a,mlprec_wrk(ilev)%y2l,&
& zone,mlprec_wrk(ilev)%tx,baseprecv(ilev)%base_desc,info,work=work) & zone,mlprec_wrk(ilev)%tx,baseprecv(ilev)%base_desc,info,work=work)
if(info /=0) goto 9999
! !
! Apply the base preconditioner ! Apply the base preconditioner
! !
call mld_baseprec_aply(zone,baseprecv(ilev),mlprec_wrk(ilev)%tx,& if (info == 0) call mld_baseprec_aply(zone,baseprecv(ilev),mlprec_wrk(ilev)%tx,&
& zone,mlprec_wrk(ilev)%y2l,baseprecv(ilev)%base_desc, trans, work,info) & zone,mlprec_wrk(ilev)%y2l,baseprecv(ilev)%base_desc, trans, work,info)
if (info /=0) then
call psb_errpush(4001,name,a_err=' spmm/baseprec_aply')
goto 9999
end if
if(info /=0) goto 9999 if (debug_level >= psb_debug_inner_) &
if (debug) write(0,*) me, 'mlprec_aply done down sweep',ilev & write(debug_unit,*) me,' ',trim(name),&
& ' done down sweep',ilev
enddo enddo
! !
@ -604,8 +632,10 @@ subroutine mld_zmlprec_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info)
! !
call psb_geaxpby(alpha,mlprec_wrk(1)%y2l,beta,y,baseprecv(1)%base_desc,info) call psb_geaxpby(alpha,mlprec_wrk(1)%y2l,beta,y,baseprecv(1)%base_desc,info)
if(info /=0) goto 9999 if (info /=0) then
call psb_errpush(4001,name,a_err=' Final update')
goto 9999
end if
case(mld_pre_smooth_) case(mld_pre_smooth_)
@ -676,9 +706,10 @@ subroutine mld_zmlprec_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info)
& zzero,mlprec_wrk(1)%y2l,& & zzero,mlprec_wrk(1)%y2l,&
& baseprecv(1)%base_desc,& & baseprecv(1)%base_desc,&
& trans,work,info) & trans,work,info)
if (info /=0) then
if(info /=0) goto 9999 call psb_errpush(4010,name,a_err=' baseprec_aply')
goto 9999
end if
! !
! STEP 3 ! STEP 3
@ -689,7 +720,10 @@ subroutine mld_zmlprec_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info)
call psb_spmm(-zone,baseprecv(1)%base_a,mlprec_wrk(1)%y2l,& call psb_spmm(-zone,baseprecv(1)%base_a,mlprec_wrk(1)%y2l,&
& zone,mlprec_wrk(1)%tx,baseprecv(1)%base_desc,info,work=work) & zone,mlprec_wrk(1)%tx,baseprecv(1)%base_desc,info,work=work)
if(info /=0) goto 9999 if (info /=0) then
call psb_errpush(4001,name,a_err=' fine level residual')
goto 9999
end if
! !
! STEP 4 ! STEP 4
@ -718,19 +752,14 @@ subroutine mld_zmlprec_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info)
mlprec_wrk(ilev)%y2l(:) = zzero mlprec_wrk(ilev)%y2l(:) = zzero
mlprec_wrk(ilev)%tx(:) = zzero mlprec_wrk(ilev)%tx(:) = zzero
if (ismth /= mld_no_smooth_) then if (ismth /= mld_no_smooth_) then
! !
! Apply the smoothed prolongator transpose ! Apply the smoothed prolongator transpose
! !
call psb_halo(mlprec_wrk(ilev-1)%tx,baseprecv(ilev-1)%base_desc,& call psb_halo(mlprec_wrk(ilev-1)%tx,baseprecv(ilev-1)%base_desc,&
& info,work=work) & info,work=work)
if(info /=0) goto 9999 if (info == 0) call psb_csmm(zone,baseprecv(ilev)%av(mld_sm_pr_t_),&
& mlprec_wrk(ilev-1)%tx,zzero,mlprec_wrk(ilev)%x2l,info)
call psb_csmm(zone,baseprecv(ilev)%av(mld_sm_pr_t_),mlprec_wrk(ilev-1)%tx,zzero,&
& mlprec_wrk(ilev)%x2l,info)
if(info /=0) goto 9999
else else
! !
! Apply the raw aggregation map transpose (take a shortcut) ! Apply the raw aggregation map transpose (take a shortcut)
@ -742,11 +771,18 @@ subroutine mld_zmlprec_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info)
& mlprec_wrk(ilev-1)%tx(i) & mlprec_wrk(ilev-1)%tx(i)
end do end do
end if end if
if (info /=0) then
call psb_errpush(4001,name,a_err='Error during restriction')
goto 9999
end if
if (icm ==mld_repl_mat_) then if (icm ==mld_repl_mat_) then
call psb_sum(ictxt,mlprec_wrk(ilev)%x2l(1:nr2l)) call psb_sum(ictxt,mlprec_wrk(ilev)%x2l(1:nr2l))
else if (icm /= mld_distr_mat_) then else if (icm /= mld_distr_mat_) then
write(0,*) 'Unknown value for baseprecv(2)%iprcparm(mld_coarse_mat_) ', icm info = 4013
call psb_errpush(info,name,a_err='invalid mld_coarse_mat_',&
& i_Err=(/icm,0,0,0,0/))
goto 9999
endif endif
! !
@ -755,18 +791,19 @@ subroutine mld_zmlprec_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info)
call mld_baseprec_aply(zone,baseprecv(ilev),mlprec_wrk(ilev)%x2l,& call mld_baseprec_aply(zone,baseprecv(ilev),mlprec_wrk(ilev)%x2l,&
& zzero,mlprec_wrk(ilev)%y2l,baseprecv(ilev)%desc_data, 'N',work,info) & zzero,mlprec_wrk(ilev)%y2l,baseprecv(ilev)%desc_data, 'N',work,info)
if(info /=0) goto 9999
! !
! Compute the residual (at all levels but the coarsest one) ! Compute the residual (at all levels but the coarsest one)
! !
if (ilev < nlev) then if (ilev < nlev) then
mlprec_wrk(ilev)%tx = mlprec_wrk(ilev)%x2l mlprec_wrk(ilev)%tx = mlprec_wrk(ilev)%x2l
call psb_spmm(-zone,baseprecv(ilev)%base_a,mlprec_wrk(ilev)%y2l,& if (info == 0) call psb_spmm(-zone,baseprecv(ilev)%base_a,&
& zone,mlprec_wrk(ilev)%tx,baseprecv(ilev)%base_desc,info,work=work) & mlprec_wrk(ilev)%y2l,zone,mlprec_wrk(ilev)%tx,&
if(info /=0) goto 9999 & baseprecv(ilev)%base_desc,info,work=work)
endif endif
if (info /=0) then
call psb_errpush(4001,name,a_err='Error on up sweep residual')
goto 9999
end if
enddo enddo
! !
@ -786,11 +823,8 @@ subroutine mld_zmlprec_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info)
if (ismth == mld_smooth_prol_) & if (ismth == mld_smooth_prol_) &
& call psb_halo(mlprec_wrk(ilev+1)%y2l,& & call psb_halo(mlprec_wrk(ilev+1)%y2l,&
& baseprecv(ilev+1)%desc_data,info,work=work) & baseprecv(ilev+1)%desc_data,info,work=work)
call psb_csmm(zone,baseprecv(ilev+1)%av(mld_sm_pr_),mlprec_wrk(ilev+1)%y2l,& if (info == 0) call psb_csmm(zone,baseprecv(ilev+1)%av(mld_sm_pr_),&
& zone,mlprec_wrk(ilev)%y2l,info) & mlprec_wrk(ilev+1)%y2l,zone,mlprec_wrk(ilev)%y2l,info)
if(info /=0) goto 9999
else else
! !
! Apply the raw aggregation map (take a shortcut) ! Apply the raw aggregation map (take a shortcut)
@ -799,9 +833,11 @@ subroutine mld_zmlprec_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info)
mlprec_wrk(ilev)%y2l(i) = mlprec_wrk(ilev)%y2l(i) + & mlprec_wrk(ilev)%y2l(i) = mlprec_wrk(ilev)%y2l(i) + &
& mlprec_wrk(ilev+1)%y2l(baseprecv(ilev+1)%mlia(i)) & mlprec_wrk(ilev+1)%y2l(baseprecv(ilev+1)%mlia(i))
enddo enddo
end if end if
if (info /=0) then
call psb_errpush(4001,name,a_err='Error during prolongation')
goto 9999
end if
enddo enddo
! !
@ -811,8 +847,11 @@ subroutine mld_zmlprec_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info)
! !
call psb_geaxpby(alpha,mlprec_wrk(1)%y2l,beta,y,& call psb_geaxpby(alpha,mlprec_wrk(1)%y2l,beta,y,&
& baseprecv(1)%base_desc,info) & baseprecv(1)%base_desc,info)
if (info /=0) then
call psb_errpush(4001,name,a_err='Error on final update')
goto 9999
end if
if(info /=0) goto 9999
case(mld_twoside_smooth_) case(mld_twoside_smooth_)
@ -895,18 +934,18 @@ subroutine mld_zmlprec_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info)
& zzero,mlprec_wrk(1)%y2l,& & zzero,mlprec_wrk(1)%y2l,&
& baseprecv(1)%base_desc,& & baseprecv(1)%base_desc,&
& trans,work,info) & trans,work,info)
if(info /=0) goto 9999
! !
! STEP 3 ! STEP 3
! !
! Compute the residual at the finest level ! Compute the residual at the finest level
! !
mlprec_wrk(1)%ty = mlprec_wrk(1)%x2l mlprec_wrk(1)%ty = mlprec_wrk(1)%x2l
call psb_spmm(-zone,baseprecv(1)%base_a,mlprec_wrk(1)%y2l,& if (info == 0) call psb_spmm(-zone,baseprecv(1)%base_a,mlprec_wrk(1)%y2l,&
& zone,mlprec_wrk(1)%ty,baseprecv(1)%base_desc,info,work=work) & zone,mlprec_wrk(1)%ty,baseprecv(1)%base_desc,info,work=work)
if(info /=0) goto 9999 if (info /=0) then
call psb_errpush(4010,name,a_err='Fine level baseprec/residual')
goto 9999
end if
! !
! STEP 4 ! STEP 4
@ -943,11 +982,8 @@ subroutine mld_zmlprec_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info)
! !
call psb_halo(mlprec_wrk(ilev-1)%ty,baseprecv(ilev-1)%base_desc,& call psb_halo(mlprec_wrk(ilev-1)%ty,baseprecv(ilev-1)%base_desc,&
& info,work=work) & info,work=work)
if(info /=0) goto 9999 if (info == 0) call psb_csmm(zone,baseprecv(ilev)%av(mld_sm_pr_t_),&
call psb_csmm(zone,baseprecv(ilev)%av(mld_sm_pr_t_),mlprec_wrk(ilev-1)%ty,zzero,& & mlprec_wrk(ilev-1)%ty,zzero,mlprec_wrk(ilev)%x2l,info)
& mlprec_wrk(ilev)%x2l,info)
if(info /=0) goto 9999
else else
! !
! Apply the raw aggregation map transpose (take a shortcut) ! Apply the raw aggregation map transpose (take a shortcut)
@ -959,34 +995,41 @@ subroutine mld_zmlprec_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info)
& mlprec_wrk(ilev-1)%ty(i) & mlprec_wrk(ilev-1)%ty(i)
end do end do
end if end if
if (info /=0) then
call psb_errpush(4001,name,a_err='Error during restriction')
goto 9999
end if
if (icm == mld_repl_mat_) then if (icm == mld_repl_mat_) then
call psb_sum(ictxt,mlprec_wrk(ilev)%x2l(1:nr2l)) call psb_sum(ictxt,mlprec_wrk(ilev)%x2l(1:nr2l))
else if (icm /= mld_distr_mat_) then else if (icm /= mld_distr_mat_) then
write(0,*) 'Unknown value for baseprecv(2)%iprcparm(mld_coarse_mat_) ', icm info = 4013
call psb_errpush(info,name,a_err='invalid mld_coarse_mat_',&
& i_Err=(/icm,0,0,0,0/))
goto 9999
endif endif
call psb_geaxpby(zone,mlprec_wrk(ilev)%x2l,zzero,mlprec_wrk(ilev)%tx,& call psb_geaxpby(zone,mlprec_wrk(ilev)%x2l,zzero,mlprec_wrk(ilev)%tx,&
& baseprecv(ilev)%base_desc,info) & baseprecv(ilev)%base_desc,info)
if(info /=0) goto 9999
! !
! Apply the base preconditioner ! Apply the base preconditioner
! !
call mld_baseprec_aply(zone,baseprecv(ilev),mlprec_wrk(ilev)%x2l,& if (info == 0) call mld_baseprec_aply(zone,baseprecv(ilev),&
& zzero,mlprec_wrk(ilev)%y2l,baseprecv(ilev)%desc_data, 'N',work,info) & mlprec_wrk(ilev)%x2l,zzero,mlprec_wrk(ilev)%y2l,&
&baseprecv(ilev)%desc_data, 'N',work,info)
if(info /=0) goto 9999
! !
! Compute the residual (at all levels but the coarsest one) ! Compute the residual (at all levels but the coarsest one)
! !
if(ilev < nlev) then if(ilev < nlev) then
mlprec_wrk(ilev)%ty = mlprec_wrk(ilev)%x2l mlprec_wrk(ilev)%ty = mlprec_wrk(ilev)%x2l
call psb_spmm(-zone,baseprecv(ilev)%base_a,mlprec_wrk(ilev)%y2l,& if (info == 0) call psb_spmm(-zone,baseprecv(ilev)%base_a,&
& zone,mlprec_wrk(ilev)%ty,baseprecv(ilev)%base_desc,info,work=work) & mlprec_wrk(ilev)%y2l,zone,mlprec_wrk(ilev)%ty,&
if(info /=0) goto 9999 & baseprecv(ilev)%base_desc,info,work=work)
endif endif
if (info /=0) then
call psb_errpush(4001,name,a_err='baseprec_aply/residual')
goto 9999
end if
enddo enddo
@ -1007,10 +1050,8 @@ subroutine mld_zmlprec_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info)
if (ismth == mld_smooth_prol_) & if (ismth == mld_smooth_prol_) &
& call psb_halo(mlprec_wrk(ilev+1)%y2l,baseprecv(ilev+1)%desc_data,& & call psb_halo(mlprec_wrk(ilev+1)%y2l,baseprecv(ilev+1)%desc_data,&
& info,work=work) & info,work=work)
call psb_csmm(zone,baseprecv(ilev+1)%av(mld_sm_pr_),mlprec_wrk(ilev+1)%y2l,& if (info == 0) call psb_csmm(zone,baseprecv(ilev+1)%av(mld_sm_pr_),&
& zone,mlprec_wrk(ilev)%y2l,info) & mlprec_wrk(ilev+1)%y2l,zone,mlprec_wrk(ilev)%y2l,info)
if(info /=0) goto 9999
else else
! !
! Apply the raw aggregation map (take a shortcut) ! Apply the raw aggregation map (take a shortcut)
@ -1019,7 +1060,10 @@ subroutine mld_zmlprec_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info)
mlprec_wrk(ilev)%y2l(i) = mlprec_wrk(ilev)%y2l(i) + & mlprec_wrk(ilev)%y2l(i) = mlprec_wrk(ilev)%y2l(i) + &
& mlprec_wrk(ilev+1)%y2l(baseprecv(ilev+1)%mlia(i)) & mlprec_wrk(ilev+1)%y2l(baseprecv(ilev+1)%mlia(i))
enddo enddo
end if
if (info /=0 ) then
call psb_errpush(4001,name,a_err='Error during restriction')
goto 9999
end if end if
! !
@ -1027,17 +1071,15 @@ subroutine mld_zmlprec_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info)
! !
call psb_spmm(-zone,baseprecv(ilev)%base_a,mlprec_wrk(ilev)%y2l,& call psb_spmm(-zone,baseprecv(ilev)%base_a,mlprec_wrk(ilev)%y2l,&
& zone,mlprec_wrk(ilev)%tx,baseprecv(ilev)%base_desc,info,work=work) & zone,mlprec_wrk(ilev)%tx,baseprecv(ilev)%base_desc,info,work=work)
if(info /=0) goto 9999
! !
! Apply the base preconditioner ! Apply the base preconditioner
! !
call mld_baseprec_aply(zone,baseprecv(ilev),mlprec_wrk(ilev)%tx,& if (info == 0) call mld_baseprec_aply(zone,baseprecv(ilev),mlprec_wrk(ilev)%tx,&
& zone,mlprec_wrk(ilev)%y2l,baseprecv(ilev)%base_desc, trans, work,info) & zone,mlprec_wrk(ilev)%y2l,baseprecv(ilev)%base_desc, trans, work,info)
if (info /= 0) then
if(info /=0) goto 9999 call psb_errpush(4001,name,a_err='Error: residual/baseprec_aply')
goto 9999
end if
enddo enddo
! !
@ -1048,30 +1090,37 @@ subroutine mld_zmlprec_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info)
call psb_geaxpby(alpha,mlprec_wrk(1)%y2l,beta,y,& call psb_geaxpby(alpha,mlprec_wrk(1)%y2l,beta,y,&
& baseprecv(1)%base_desc,info) & baseprecv(1)%base_desc,info)
if(info /=0) goto 9999 if (info /= 0) then
call psb_errpush(4001,name,a_err='Error final update')
goto 9999
end if
case default case default
info = 4013
call psb_errpush(4013,name,a_err='wrong smooth_pos',& call psb_errpush(info,name,a_err='invalid smooth_pos',&
& i_Err=(/baseprecv(2)%iprcparm(mld_smooth_pos_),0,0,0,0/)) & i_Err=(/baseprecv(2)%iprcparm(mld_smooth_pos_),0,0,0,0/))
goto 9999 goto 9999
end select end select
case default case default
call psb_errpush(4013,name,a_err='wrong mltype',& info = 4013
call psb_errpush(info,name,a_err='invalid mltype',&
& i_Err=(/baseprecv(2)%iprcparm(mld_ml_type_),0,0,0,0/)) & i_Err=(/baseprecv(2)%iprcparm(mld_ml_type_),0,0,0,0/))
goto 9999 goto 9999
end select end select
deallocate(mlprec_wrk) deallocate(mlprec_wrk,stat=info)
if (info /= 0) then
call psb_errpush(4000,name)
goto 9999
end if
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
return return
9999 continue 9999 continue
call psb_errpush(info,name)
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()

27
mlprec/mld_zmlprec_bld.f90
Unescape Escape View File

@ -73,16 +73,15 @@ subroutine mld_zmlprec_bld(a,desc_a,p,info)
integer :: err_act integer :: err_act
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
logical, parameter :: debug=.false.
type(psb_zspmat_type) :: ac type(psb_zspmat_type) :: ac
integer :: ictxt, np, me integer :: ictxt, np, me
name='psb_zmlprec_bld' name='psb_zmlprec_bld'
if (psb_get_errstatus().ne.0) return if (psb_get_errstatus().ne.0) return
call psb_erractionsave(err_act)
info = 0 info = 0
ictxt = psb_cd_get_context(desc_a) ictxt = psb_cd_get_context(desc_a)
call psb_info(ictxt,me,np) call psb_info(ictxt,me,np)
call psb_erractionsave(err_act)
if (.not.allocated(p%iprcparm)) then if (.not.allocated(p%iprcparm)) then
info = 2222 info = 2222
@ -120,14 +119,10 @@ subroutine mld_zmlprec_bld(a,desc_a,p,info)
! !
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_),a,desc_a,p%nlaggr,p%mlia,info)
if(info /= 0) then if(info /= 0) then
info=4010 call psb_errpush(4010,name,a_err='mld_aggrmap_bld')
ch_err='mld_aggrmap_bld'
call psb_errpush(info,name,a_err=ch_err)
goto 9999 goto 9999
end if end if
if (debug) write(0,*) 'Out from genaggrmap',p%nlaggr
! !
! Build the coarse-level matrix from the fine level one, starting from ! Build the coarse-level matrix from the fine level one, starting from
! the mapping defined by mld_aggrmap_bld and applying the aggregation ! the mapping defined by mld_aggrmap_bld and applying the aggregation
@ -137,22 +132,16 @@ subroutine mld_zmlprec_bld(a,desc_a,p,info)
call psb_nullify_desc(desc_ac) call psb_nullify_desc(desc_ac)
call mld_aggrmat_asb(a,desc_a,ac,desc_ac,p,info) call mld_aggrmat_asb(a,desc_a,ac,desc_ac,p,info)
if(info /= 0) then if(info /= 0) then
info=4010 call psb_errpush(4010,name,a_err='mld_aggrmat_asb')
ch_err='mld_aggrmat_asb'
call psb_errpush(info,name,a_err=ch_err)
goto 9999 goto 9999
end if end if
if (debug) write(0,*) 'Out from bldaggrmat',desc_ac%matrix_data(:)
! !
! Build the 'base preconditioner' corresponding to the coarse level ! Build the 'base preconditioner' corresponding to the coarse level
! !
call mld_baseprc_bld(ac,desc_ac,p,info) call mld_baseprc_bld(ac,desc_ac,p,info)
if (debug) write(0,*) 'Out from baseprcbld',info if (info /= 0) then
if(info /= 0) then call psb_errpush(4010,name,a_err='mld_baseprc_bld')
info=4010
ch_err='mld_baseprc_bld'
call psb_errpush(info,name,a_err=ch_err)
goto 9999 goto 9999
end if end if
@ -165,12 +154,10 @@ subroutine mld_zmlprec_bld(a,desc_a,p,info)
! !
call psb_sp_transfer(ac,p%av(mld_ac_),info) call psb_sp_transfer(ac,p%av(mld_ac_),info)
p%base_a => p%av(mld_ac_) p%base_a => p%av(mld_ac_)
call psb_cdtransfer(desc_ac,p%desc_ac,info) if (info==0) call psb_cdtransfer(desc_ac,p%desc_ac,info)
if (info /= 0) then if (info /= 0) then
info=4010 call psb_errpush(4010,name,a_err='psb_cdtransfer')
ch_err='psb_cdtransfer'
call psb_errpush(info,name,a_err=ch_err)
goto 9999 goto 9999
end if end if
p%base_desc => p%desc_ac p%base_desc => p%desc_ac

38
mlprec/mld_zprec_aply.f90
Unescape Escape View File

@ -66,7 +66,8 @@
! If trans='N','n' then op(M^(-1)) = M^(-1); ! If trans='N','n' then op(M^(-1)) = M^(-1);
! if trans='T','t' then op(M^(-1)) = M^(-T) (transpose of M^(-1)). ! if trans='T','t' then op(M^(-1)) = M^(-T) (transpose of M^(-1)).
! work - complex(kind(0.d0)), dimension (:), optional, target. ! work - complex(kind(0.d0)), dimension (:), optional, target.
! Workspace. Its size must be at least 4*psb_cd_get_local_cols(desc_data). ! Workspace. Its size must be at
! least 4*psb_cd_get_local_cols(desc_data).
! !
subroutine mld_zprec_aply(prec,x,y,desc_data,info,trans,work) subroutine mld_zprec_aply(prec,x,y,desc_data,info,trans,work)
@ -88,7 +89,6 @@ subroutine mld_zprec_aply(prec,x,y,desc_data,info,trans,work)
character :: trans_ character :: trans_
complex(kind(1.d0)), pointer :: work_(:) complex(kind(1.d0)), pointer :: work_(:)
integer :: ictxt,np,me,err_act,iwsz integer :: ictxt,np,me,err_act,iwsz
logical,parameter :: debug=.false., debugprt=.false.
character(len=20) :: name character(len=20) :: name
name='mld_zprec_aply' name='mld_zprec_aply'
@ -110,8 +110,7 @@ subroutine mld_zprec_aply(prec,x,y,desc_data,info,trans,work)
iwsz = max(1,4*psb_cd_get_local_cols(desc_data)) iwsz = max(1,4*psb_cd_get_local_cols(desc_data))
allocate(work_(iwsz),stat=info) allocate(work_(iwsz),stat=info)
if (info /= 0) then if (info /= 0) then
info=4025 call psb_errpush(4025,name,i_err=(/iwsz,0,0,0,0/),&
call psb_errpush(info,name,i_err=(/iwsz,0,0,0,0/),&
& a_err='complex(kind(1.d0))') & a_err='complex(kind(1.d0))')
goto 9999 goto 9999
end if end if
@ -119,10 +118,12 @@ subroutine mld_zprec_aply(prec,x,y,desc_data,info,trans,work)
end if end if
if (.not.(allocated(prec%baseprecv))) then if (.not.(allocated(prec%baseprecv))) then
write(0,*) 'Inconsistent preconditioner: neither ML nor BASE?' !! Error 1: should call mld_dprecbld
info=3112
call psb_errpush(info,name)
goto 9999
end if end if
if (size(prec%baseprecv) >1) then if (size(prec%baseprecv) >1) then
if (debug) write(0,*) 'Into mlprec_aply',size(x),size(y)
call mld_mlprec_aply(zone,prec%baseprecv,x,zzero,y,desc_data,trans_,work_,info) call mld_mlprec_aply(zone,prec%baseprecv,x,zzero,y,desc_data,trans_,work_,info)
if(info /= 0) then if(info /= 0) then
call psb_errpush(4010,name,a_err='mld_zmlprec_aply') call psb_errpush(4010,name,a_err='mld_zmlprec_aply')
@ -132,7 +133,10 @@ subroutine mld_zprec_aply(prec,x,y,desc_data,info,trans,work)
else if (size(prec%baseprecv) == 1) then else if (size(prec%baseprecv) == 1) then
call mld_baseprec_aply(zone,prec%baseprecv(1),x,zzero,y,desc_data,trans_, work_,info) call mld_baseprec_aply(zone,prec%baseprecv(1),x,zzero,y,desc_data,trans_, work_,info)
else else
write(0,*) 'Inconsistent preconditioner: size of baseprecv???' info = 4013
call psb_errpush(info,name,a_err='Invalid size of baseprecv',&
& i_Err=(/size(prec%baseprecv),0,0,0,0/))
goto 9999
endif endif
if (present(work)) then if (present(work)) then
@ -202,11 +206,11 @@ subroutine mld_zprec_aply1(prec,x,desc_data,info,trans)
character(len=1), optional :: trans character(len=1), optional :: trans
! Local variables ! Local variables
logical,parameter :: debug=.false., debugprt=.false.
character :: trans_ character :: trans_
integer :: ictxt,np,me, err_act integer :: ictxt,np,me, err_act
complex(kind(1.d0)), pointer :: WW(:), w1(:) complex(kind(1.d0)), pointer :: WW(:), w1(:)
character(len=20) :: name character(len=20) :: name
name='mld_zprec_aply1' name='mld_zprec_aply1'
info = 0 info = 0
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
@ -227,17 +231,25 @@ subroutine mld_zprec_aply1(prec,x,desc_data,info,trans)
& a_err='complex(kind(1.d0))') & a_err='complex(kind(1.d0))')
goto 9999 goto 9999
end if end if
if (debug) write(0,*) 'prec_aply1 Size(x) ',size(x), size(ww),size(w1)
call mld_zprec_aply(prec,x,ww,desc_data,info,trans_,work=w1) call mld_precaply(prec,x,ww,desc_data,info,trans_,work=w1)
if(info /=0) goto 9999 if (info /= 0) then
call psb_errpush(4010,name,a_err='mld_precaply')
goto 9999
end if
x(:) = ww(:) x(:) = ww(:)
deallocate(ww,W1) deallocate(ww,W1,stat=info)
if (info /= 0) then
info = 4000
call psb_errpush(info,name)
goto 9999
end if
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
return return
9999 continue 9999 continue
call psb_errpush(info,name)
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()

108
mlprec/mld_zprecbld.f90
Unescape Escape View File

@ -41,7 +41,7 @@
! Contains: subroutine init_baseprc_av ! Contains: subroutine init_baseprc_av
! !
! This routine builds the preconditioner according to the requirements made by ! This routine builds the preconditioner according to the requirements made by
! the user trough the subroutines mld_zprecinit and mld_zprecset. ! the user trough the subroutines mld_precinit and mld_precset.
! !
! A multilevel preconditioner is regarded as an array of 'base preconditioners', ! A multilevel preconditioner is regarded as an array of 'base preconditioners',
! each representing the part of the preconditioner associated to a certain level. ! each representing the part of the preconditioner associated to a certain level.
@ -76,32 +76,36 @@ subroutine mld_zprecbld(a,desc_a,p,info,upd)
! Local Variables ! Local Variables
Integer :: err,i,k,ictxt, me,np, err_act Integer :: err,i,k,ictxt, me,np, err_act, iszv
integer :: int_err(5) integer :: int_err(5)
character :: iupd character :: iupd
logical, parameter :: debug=.false. integer :: debug_level, debug_unit
integer,parameter :: iroot=0,iout=60,ilout=40
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
if(psb_get_errstatus().ne.0) return if(psb_get_errstatus().ne.0) return
info=0 info=0
err=0 err=0
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
name = 'mld_zprecbld' debug_unit = psb_get_debug_unit()
debug_level = psb_get_debug_level()
if (debug) write(0,*) 'Entering precbld',desc_a%matrix_data(:) name = 'mld_zprecbld'
info = 0 info = 0
int_err(1) = 0 int_err(1) = 0
ictxt = psb_cd_get_context(desc_a) ictxt = psb_cd_get_context(desc_a)
if (debug) write(0,*) 'Preconditioner psb_info'
call psb_info(ictxt, me, np) call psb_info(ictxt, me, np)
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'Entering ',desc_a%matrix_data(:)
if (present(upd)) then if (present(upd)) then
if (debug) write(0,*) 'UPD ', upd if (debug_level >= psb_debug_outer_) &
if ((upd.eq.'F').or.(upd.eq.'T')) then & write(debug_unit,*) me,' ',trim(name),'UPD ', upd
iupd=upd
if ((toupper(upd).eq.'F').or.(toupper(upd).eq.'T')) then
iupd=toupper(upd)
else else
iupd='F' iupd='F'
endif endif
@ -110,86 +114,81 @@ subroutine mld_zprecbld(a,desc_a,p,info,upd)
endif endif
if (.not.allocated(p%baseprecv)) then if (.not.allocated(p%baseprecv)) then
!! Error 1: should call mld_dprecset !! Error: should have called mld_dprecinit
info=4010 info=3111
ch_err='unallocated bpv' call psb_errpush(info,name)
call psb_errpush(info,name,a_err=ch_err)
goto 9999 goto 9999
end if end if
! !
! Should add check to ensure all procs have the same ... ! Check to ensure all procs have the same
! !
iszv = size(p%baseprecv)
call psb_bcast(ictxt,iszv)
if (iszv /= size(p%baseprecv)) then
info=4001
call psb_errpush(info,name,a_err='Inconsistent size of baseprecv')
goto 9999
end if
if (size(p%baseprecv) >= 1) then if (iszv >= 1) then
! !
! Allocate the av component of the preconditioner data type ! Allocate and build the fine level preconditioner
! at the finest level
! !
call init_baseprc_av(p%baseprecv(1),info) call init_baseprc_av(p%baseprecv(1),info)
if (info == 0) call mld_baseprc_bld(a,desc_a,p%baseprecv(1),info,iupd)
if (info /= 0) then if (info /= 0) then
info=4010 call psb_errpush(4001,name,a_err='Base level precbuild.')
ch_err='allocate'
call psb_errpush(info,name,a_err=ch_err)
goto 9999 goto 9999
endif end if
!
! Build the base preconditioner corresponding to the finest
! level
!
call mld_baseprc_bld(a,desc_a,p%baseprecv(1),info,iupd)
else else
info=4010 info=4010
ch_err='size bpv' ch_err='size bpv'
call psb_errpush(info,name,a_err=ch_err) call psb_errpush(info,name,a_err=ch_err)
goto 9999 goto 9999
endif endif
if (size(p%baseprecv) > 1) then if (iszv > 1) then
! !
! Build the base preconditioners corresponding to the remaining ! Build the base preconditioners corresponding to the remaining
! levels ! levels
! !
do i=2, size(p%baseprecv) do i=2, iszv
! !
! Allocate the av component of the preconditioner data type ! Allocate the av component of the preconditioner data type
! at level i ! at level i
! !
call init_baseprc_av(p%baseprecv(i),info) if (i<iszv) then
if (info /= 0) then
info=4010
ch_err='allocate'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
endif
if (i<size(p%baseprecv)) then
! !
! A replicated matrix only makes sense at the coarsest level ! A replicated matrix only makes sense at the coarsest level
! !
call mld_check_def(p%baseprecv(i)%iprcparm(mld_coarse_mat_),'Coarse matrix',& call mld_check_def(p%baseprecv(i)%iprcparm(mld_coarse_mat_),'Coarse matrix',&
& mld_distr_mat_,is_distr_ml_coarse_mat) & mld_distr_mat_,is_distr_ml_coarse_mat)
end if end if
call init_baseprc_av(p%baseprecv(i),info)
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'Calling mlprcbld at level ',i
! !
! Build the base preconditioner corresponding to level i ! Build the base preconditioner corresponding to level i
! !
call mld_mlprec_bld(p%baseprecv(i-1)%base_a,p%baseprecv(i-1)%base_desc,& if (info == 0) call mld_mlprec_bld(p%baseprecv(i-1)%base_a,&
& p%baseprecv(i),info) & p%baseprecv(i-1)%base_desc, p%baseprecv(i),info)
if (info /= 0) then if (info /= 0) then
info=4010 call psb_errpush(4001,name,a_err='Init & build upper level preconditioner')
call psb_errpush(info,name)
goto 9999 goto 9999
endif endif
if (debug) then
write(0,*) 'Return from ',i-1,' call to mlprcbld ',info
endif
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'Return from ',i,' call to mlprcbld ',info
end do end do
endif endif
@ -211,12 +210,15 @@ contains
type(mld_zbaseprc_type), intent(inout) :: p type(mld_zbaseprc_type), intent(inout) :: p
integer :: info integer :: info
if (allocated(p%av)) then if (allocated(p%av)) then
! if (size(p%av) /= mld_max_avsz_) then
! We have not yet decided what to do deallocate(p%av,stat=info)
! if (info /= 0) return
endif
end if end if
if (.not.(allocated(p%av))) then
allocate(p%av(mld_max_avsz_),stat=info) allocate(p%av(mld_max_avsz_),stat=info)
!!$ if (info /= 0) return if (info /= 0) return
end if
do k=1,size(p%av) do k=1,size(p%av)
call psb_nullify_sp(p%av(k)) call psb_nullify_sp(p%av(k))
end do end do

3
mlprec/mld_zprecinit.f90
Unescape Escape View File

@ -182,9 +182,6 @@ subroutine mld_zprecinit(p,ptype,info,nlev)
else else
nlev_ = 2 nlev_ = 2
end if end if
if (nlev_ == 1) then
write(0,*) 'Warning: requested ML preconditioner with NLEV=1'
endif
ilev_ = 1 ilev_ = 1
allocate(p%baseprecv(nlev_),stat=info) allocate(p%baseprecv(nlev_),stat=info)
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)

19
mlprec/mld_zprecset.f90
Unescape Escape View File

@ -87,8 +87,7 @@ subroutine mld_zprecseti(p,what,val,info,ilev)
info = 0 info = 0
if (.not.allocated(p%baseprecv)) then if (.not.allocated(p%baseprecv)) then
write(0,*) 'Error: trying to call PRECSET on an uninitialized preconditioner' info = 3111
info = -1
return return
endif endif
nlev_ = size(p%baseprecv) nlev_ = size(p%baseprecv)
@ -100,13 +99,11 @@ subroutine mld_zprecseti(p,what,val,info,ilev)
end if end if
if ((ilev_<1).or.(ilev_ > nlev_)) then if ((ilev_<1).or.(ilev_ > nlev_)) then
write(0,*) 'PRECSET ERRROR: ilev out of bounds'
info = -1 info = -1
return return
endif endif
if (.not.allocated(p%baseprecv(ilev_)%iprcparm)) then if (.not.allocated(p%baseprecv(ilev_)%iprcparm)) then
write(0,*) 'Error: trying to call PRECSET on an uninitialized preconditioner' info = 3111
info = -1
return return
endif endif
@ -251,8 +248,7 @@ subroutine mld_zprecsetc(p,what,string,info,ilev)
info = 0 info = 0
if (.not.allocated(p%baseprecv)) then if (.not.allocated(p%baseprecv)) then
write(0,*) 'Error: trying to call PRECSET on an uninitialized preconditioner' info = 3111
info = -1
return return
endif endif
nlev_ = size(p%baseprecv) nlev_ = size(p%baseprecv)
@ -269,8 +265,7 @@ subroutine mld_zprecsetc(p,what,string,info,ilev)
return return
endif endif
if (.not.allocated(p%baseprecv(ilev_)%iprcparm)) then if (.not.allocated(p%baseprecv(ilev_)%iprcparm)) then
write(0,*) 'Error: trying to call PRECSET on an uninitialized preconditioner' info = 3111
info = -1
return return
endif endif
@ -445,8 +440,7 @@ subroutine mld_zprecsetd(p,what,val,info,ilev)
end if end if
if (.not.allocated(p%baseprecv)) then if (.not.allocated(p%baseprecv)) then
write(0,*) 'Error: trying to call PRECSET on an uninitialized preconditioner' info = 3111
info = -1
return return
endif endif
nlev_ = size(p%baseprecv) nlev_ = size(p%baseprecv)
@ -457,8 +451,7 @@ subroutine mld_zprecsetd(p,what,val,info,ilev)
return return
endif endif
if (.not.allocated(p%baseprecv(ilev_)%dprcparm)) then if (.not.allocated(p%baseprecv(ilev_)%dprcparm)) then
write(0,*) 'Error: trying to call PRECSET on an uninitialized preconditioner' info = 3111
info = -1
return return
endif endif

17
mlprec/mld_zslu_bld.f90
Unescape Escape View File

@ -82,7 +82,6 @@ subroutine mld_zslu_bld(a,desc_a,p,info)
! Local variables ! Local variables
integer :: nzt,ictxt,me,np,err_act integer :: nzt,ictxt,me,np,err_act
logical, parameter :: debug=.false.
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
if(psb_get_errstatus().ne.0) return if(psb_get_errstatus().ne.0) return
@ -95,19 +94,12 @@ subroutine mld_zslu_bld(a,desc_a,p,info)
call psb_info(ictxt, me, np) call psb_info(ictxt, me, np)
if (toupper(a%fida) /= 'CSR') then if (toupper(a%fida) /= 'CSR') then
write(0,*) 'Unimplemented input to mld_slu_BLD' info=135
call psb_errpush(info,name,a_err=a%fida)
goto 9999 goto 9999
endif endif
nzt = psb_sp_get_nnzeros(a) nzt = psb_sp_get_nnzeros(a)
if (Debug) then
write(0,*) me,'Calling mld_slu_factor ',nzt,a%m,&
& a%k,p%desc_data%matrix_data(psb_n_row_)
call psb_barrier(ictxt)
endif
! !
! Compute the LU factorization ! Compute the LU factorization
! !
@ -120,11 +112,6 @@ subroutine mld_zslu_bld(a,desc_a,p,info)
goto 9999 goto 9999
end if end if
if (Debug) then
write(0,*) me, 'SPLUBLD: Done mld_slu_Factor',info,p%iprcparm(mld_slu_ptr_)
call psb_barrier(ictxt)
endif
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
return return

4
mlprec/mld_zslud_bld.f90
Unescape Escape View File

@ -80,7 +80,6 @@ subroutine mld_zsludist_bld(a,desc_a,p,info)
! Local variables ! Local variables
integer :: nzt,ictxt,me,np,err_act,& integer :: nzt,ictxt,me,np,err_act,&
& mglob,ifrst,ibcheck,nrow,ncol,npr,npc & mglob,ifrst,ibcheck,nrow,ncol,npr,npc
logical, parameter :: debug=.false.
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
if(psb_get_errstatus().ne.0) return if(psb_get_errstatus().ne.0) return
@ -93,7 +92,8 @@ subroutine mld_zsludist_bld(a,desc_a,p,info)
call psb_info(ictxt, me, np) call psb_info(ictxt, me, np)
if (toupper(a%fida) /= 'CSR') then if (toupper(a%fida) /= 'CSR') then
write(0,*) 'Unimplemented input to mld_slu_BLD' info=135
call psb_errpush(info,name,a_err=a%fida)
goto 9999 goto 9999
endif endif

16
mlprec/mld_zumf_bld.f90
Unescape Escape View File

@ -89,7 +89,6 @@ subroutine mld_zumf_bld(a,desc_a,p,info)
! Local variables ! Local variables
integer :: nzt,ictxt,me,np,err_act integer :: nzt,ictxt,me,np,err_act
integer :: i_err(5) integer :: i_err(5)
logical, parameter :: debug=.false.
character(len=20) :: name character(len=20) :: name
info=0 info=0
@ -104,18 +103,8 @@ subroutine mld_zumf_bld(a,desc_a,p,info)
goto 9999 goto 9999
endif endif
nzt = psb_sp_get_nnzeros(a) nzt = psb_sp_get_nnzeros(a)
if (Debug) then
write(0,*) me,'Calling mld_umf_factor ',nzt,a%m,&
& a%k,p%desc_data%matrix_data(psb_n_row_)
open(80+me)
call psb_csprt(80+me,a)
close(80+me)
call psb_barrier(ictxt)
endif
! !
! Compute the LU factorization ! Compute the LU factorization
! !
@ -130,11 +119,6 @@ subroutine mld_zumf_bld(a,desc_a,p,info)
goto 9999 goto 9999
end if end if
if (Debug) then
write(0,*) me, 'UMFBLD: Done mld_umf_Factor',info,p%iprcparm(mld_umf_numptr_)
call psb_barrier(ictxt)
endif
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
return return

Write Preview
Loading…
Cancel
Save