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

Fixed singleton marking in SOC1/SOC2.

Browse Source 
Fixed singleton handling for unsmoothed aggregation and minenergy.
stopcriterion
Salvatore Filippone 6 years ago
parent c6b9ce5e2a
commit 5a1dace4e3
20 changed files with 276 additions and 104 deletions
Show Stats Download Patch File Download Diff File

17
mlprec/impl/aggregator/mld_c_map_to_tprol.f90
Unescape Escape View File

@ -125,12 +125,21 @@ subroutine mld_c_map_to_tprol(desc_a,ilaggr,nlaggr,op_prol,info)
end if
call tmpcoo%allocate(ncol,ntaggr,ncol)
k = 0
do i=1,ncol
tmpcoo%val(i) = cone
tmpcoo%ia(i) = i
tmpcoo%ja(i) = ilaggr(i)
!
! Note: at this point, a value ilaggr(i)<=0
! tags a "singleton" row, and it has to be
! left alone.
!
if (ilaggr(i)>0) then
k = k + 1
tmpcoo%val(k) = cone
tmpcoo%ia(k) = i
tmpcoo%ja(k) = ilaggr(i)
end if
end do
call tmpcoo%set_nzeros(ncol)
call tmpcoo%set_nzeros(k)
call tmpcoo%set_dupl(psb_dupl_add_)
call tmpcoo%set_sorted() ! At this point this is in row-major
call op_prol%mv_from(tmpcoo)

31
mlprec/impl/aggregator/mld_c_soc1_map_bld.f90
Unescape Escape View File

@ -95,6 +95,7 @@ subroutine mld_c_soc1_map_bld(iorder,theta,a,desc_a,nlaggr,ilaggr,info)
integer(psb_ipk_) :: debug_level, debug_unit,err_act
integer(psb_ipk_) :: ictxt,np,me
integer(psb_ipk_) :: nrow, ncol, n_ne
integer(psb_lpk_) :: nrglob
character(len=20) :: name, ch_err
info=psb_success_
@ -110,6 +111,7 @@ subroutine mld_c_soc1_map_bld(iorder,theta,a,desc_a,nlaggr,ilaggr,info)
call psb_info(ictxt,me,np)
nrow = desc_a%get_local_rows()
ncol = desc_a%get_local_cols()
nrglob = desc_a%get_global_rows()
nr = a%get_nrows()
nc = a%get_ncols()
@ -261,12 +263,6 @@ subroutine mld_c_soc1_map_bld(iorder,theta,a,desc_a,nlaggr,ilaggr,info)
nz = (acsr%irp(i+1)-acsr%irp(i))
icol(1:nz) = acsr%ja(acsr%irp(i):acsr%irp(i+1)-1)
val(1:nz) = acsr%val(acsr%irp(i):acsr%irp(i+1)-1)
!!$ call a%csget(i,i,nz,irow,icol,val,info,chksz=.false.)
!!$ if (info /= psb_success_) then
!!$ info=psb_err_from_subroutine_
!!$ call psb_errpush(info,name,a_err='psb_sp_getrow')
!!$ goto 9999
!!$ end if
!
! Find its strongly connected neighbourhood not
! already aggregated, and make it into a new aggregate.
@ -302,11 +298,24 @@ subroutine mld_c_soc1_map_bld(iorder,theta,a,desc_a,nlaggr,ilaggr,info)
end do step3
if (count(ilaggr<0) >0) then
info=psb_err_internal_error_
call psb_errpush(info,name,a_err='Fatal error: some leftovers')
goto 9999
endif
! Any leftovers?
do i=1, nr
if (ilaggr(i) < 0) then
nz = (acsr%irp(i+1)-acsr%irp(i))
if (nz == 1) then
! Mark explicitly as a singleton so that
! it will be ignored in map_to_tprol.
! Need to use -(nrglob+nr) to make sure
! it's still negative when shifted and combined with
! other processes.
ilaggr(i) = -(nrglob+nr)
else
info=psb_err_internal_error_
call psb_errpush(info,name,a_err='Fatal error: non-singleton leftovers')
goto 9999
endif
end if
end do
if (naggr > ncol) then
!write(0,*) name,'Error : naggr > ncol',naggr,ncol

31
mlprec/impl/aggregator/mld_c_soc2_map_bld.f90
Unescape Escape View File

@ -88,6 +88,7 @@ subroutine mld_c_soc2_map_bld(iorder,theta,a,desc_a,nlaggr,ilaggr,info)
integer(psb_lpk_), allocatable :: tmpaggr(:)
complex(psb_spk_), allocatable :: val(:), diag(:)
integer(psb_ipk_) :: icnt,nlp,k,n,ia,isz,nr,nc,naggr,i,j,m, nz, ilg, ii, ip, ip1,nzcnt
integer(psb_lpk_) :: nrglob
type(psb_c_csr_sparse_mat) :: acsr, muij, s_neigh
type(psb_c_coo_sparse_mat) :: s_neigh_coo
real(psb_spk_) :: cpling, tcl
@ -108,8 +109,9 @@ subroutine mld_c_soc2_map_bld(iorder,theta,a,desc_a,nlaggr,ilaggr,info)
!
ictxt=desc_a%get_context()
call psb_info(ictxt,me,np)
nrow = desc_a%get_local_rows()
ncol = desc_a%get_local_cols()
nrow = desc_a%get_local_rows()
ncol = desc_a%get_local_cols()
nrglob = desc_a%get_global_rows()
nr = a%get_nrows()
nc = a%get_ncols()
@ -288,15 +290,26 @@ subroutine mld_c_soc2_map_bld(iorder,theta,a,desc_a,nlaggr,ilaggr,info)
end if
end do step3
if (count(ilaggr<0) >0) then
info=psb_err_internal_error_
call psb_errpush(info,name,a_err='Fatal error: some leftovers')
goto 9999
endif
! Any leftovers?
do i=1, nr
if (ilaggr(i) <= 0) then
nz = (s_neigh%irp(i+1)-s_neigh%irp(i))
if (nz <= 1) then
! Mark explicitly as a singleton so that
! it will be ignored in map_to_tprol.
! Need to use -(nrglob+nr) to make sure
! it's still negative when shifted and combined with
! other processes.
ilaggr(i) = -(nrglob+nr)
else
info=psb_err_internal_error_
call psb_errpush(info,name,a_err='Fatal error: non-singleton leftovers')
goto 9999
endif
end if
end do
if (naggr > ncol) then
write(0,*) name,'Error : naggr > ncol',naggr,ncol
info=psb_err_internal_error_
call psb_errpush(info,name,a_err='Fatal error: naggr>ncol')
goto 9999

12
mlprec/impl/aggregator/mld_caggrmat_minnrg_asb.f90
Unescape Escape View File

@ -260,7 +260,11 @@ subroutine mld_caggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_re
! Compute omega_int
ommx = czero
do i=1, ncol
omi(i) = omp(ilaggr(i))
if (ilaggr(i) >0) then
omi(i) = omp(ilaggr(i))
else
omi(i) = czero
end if
if(abs(omi(i)) .gt. abs(ommx)) ommx = omi(i)
end do
! Compute omega_fine
@ -409,7 +413,11 @@ subroutine mld_caggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_re
! Compute omega_int
ommx = czero
do i=1, ncol
omi(i) = omp(ilaggr(i))
if (ilaggr(i) >0) then
omi(i) = omp(ilaggr(i))
else
omi(i) = czero
end if
if(abs(omi(i)) .gt. abs(ommx)) ommx = omi(i)
end do
! Compute omega_fine

4
mlprec/impl/aggregator/mld_caggrmat_nosmth_asb.f90
Unescape Escape View File

@ -178,6 +178,10 @@ subroutine mld_caggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_re
ac_coo%ia(k) = ilaggr(ac_coo%ia(i))
ac_coo%ja(k) = ilaggr(ac_coo%ja(i))
ac_coo%val(k) = ac_coo%val(i)
! At this point, there may be negative entries,
! because that's how ILAGGR marks singletons
! If this is the case, roll back K
if ((ac_coo%ia(k)<=0).or.(ac_coo%ja(k)<=0)) k = k-1
enddo
call ac_coo%set_nrows(naggr)
call ac_coo%set_ncols(naggr)

17
mlprec/impl/aggregator/mld_d_map_to_tprol.f90
Unescape Escape View File

@ -125,12 +125,21 @@ subroutine mld_d_map_to_tprol(desc_a,ilaggr,nlaggr,op_prol,info)
end if
call tmpcoo%allocate(ncol,ntaggr,ncol)
k = 0
do i=1,ncol
tmpcoo%val(i) = done
tmpcoo%ia(i) = i
tmpcoo%ja(i) = ilaggr(i)
!
! Note: at this point, a value ilaggr(i)<=0
! tags a "singleton" row, and it has to be
! left alone.
!
if (ilaggr(i)>0) then
k = k + 1
tmpcoo%val(k) = done
tmpcoo%ia(k) = i
tmpcoo%ja(k) = ilaggr(i)
end if
end do
call tmpcoo%set_nzeros(ncol)
call tmpcoo%set_nzeros(k)
call tmpcoo%set_dupl(psb_dupl_add_)
call tmpcoo%set_sorted() ! At this point this is in row-major
call op_prol%mv_from(tmpcoo)

31
mlprec/impl/aggregator/mld_d_soc1_map_bld.f90
Unescape Escape View File

@ -95,6 +95,7 @@ subroutine mld_d_soc1_map_bld(iorder,theta,a,desc_a,nlaggr,ilaggr,info)
integer(psb_ipk_) :: debug_level, debug_unit,err_act
integer(psb_ipk_) :: ictxt,np,me
integer(psb_ipk_) :: nrow, ncol, n_ne
integer(psb_lpk_) :: nrglob
character(len=20) :: name, ch_err
info=psb_success_
@ -110,6 +111,7 @@ subroutine mld_d_soc1_map_bld(iorder,theta,a,desc_a,nlaggr,ilaggr,info)
call psb_info(ictxt,me,np)
nrow = desc_a%get_local_rows()
ncol = desc_a%get_local_cols()
nrglob = desc_a%get_global_rows()
nr = a%get_nrows()
nc = a%get_ncols()
@ -261,12 +263,6 @@ subroutine mld_d_soc1_map_bld(iorder,theta,a,desc_a,nlaggr,ilaggr,info)
nz = (acsr%irp(i+1)-acsr%irp(i))
icol(1:nz) = acsr%ja(acsr%irp(i):acsr%irp(i+1)-1)
val(1:nz) = acsr%val(acsr%irp(i):acsr%irp(i+1)-1)
!!$ call a%csget(i,i,nz,irow,icol,val,info,chksz=.false.)
!!$ if (info /= psb_success_) then
!!$ info=psb_err_from_subroutine_
!!$ call psb_errpush(info,name,a_err='psb_sp_getrow')
!!$ goto 9999
!!$ end if
!
! Find its strongly connected neighbourhood not
! already aggregated, and make it into a new aggregate.
@ -302,11 +298,24 @@ subroutine mld_d_soc1_map_bld(iorder,theta,a,desc_a,nlaggr,ilaggr,info)
end do step3
if (count(ilaggr<0) >0) then
info=psb_err_internal_error_
call psb_errpush(info,name,a_err='Fatal error: some leftovers')
goto 9999
endif
! Any leftovers?
do i=1, nr
if (ilaggr(i) < 0) then
nz = (acsr%irp(i+1)-acsr%irp(i))
if (nz == 1) then
! Mark explicitly as a singleton so that
! it will be ignored in map_to_tprol.
! Need to use -(nrglob+nr) to make sure
! it's still negative when shifted and combined with
! other processes.
ilaggr(i) = -(nrglob+nr)
else
info=psb_err_internal_error_
call psb_errpush(info,name,a_err='Fatal error: non-singleton leftovers')
goto 9999
endif
end if
end do
if (naggr > ncol) then
!write(0,*) name,'Error : naggr > ncol',naggr,ncol

31
mlprec/impl/aggregator/mld_d_soc2_map_bld.f90
Unescape Escape View File

@ -88,6 +88,7 @@ subroutine mld_d_soc2_map_bld(iorder,theta,a,desc_a,nlaggr,ilaggr,info)
integer(psb_lpk_), allocatable :: tmpaggr(:)
real(psb_dpk_), allocatable :: val(:), diag(:)
integer(psb_ipk_) :: icnt,nlp,k,n,ia,isz,nr,nc,naggr,i,j,m, nz, ilg, ii, ip, ip1,nzcnt
integer(psb_lpk_) :: nrglob
type(psb_d_csr_sparse_mat) :: acsr, muij, s_neigh
type(psb_d_coo_sparse_mat) :: s_neigh_coo
real(psb_dpk_) :: cpling, tcl
@ -108,8 +109,9 @@ subroutine mld_d_soc2_map_bld(iorder,theta,a,desc_a,nlaggr,ilaggr,info)
!
ictxt=desc_a%get_context()
call psb_info(ictxt,me,np)
nrow = desc_a%get_local_rows()
ncol = desc_a%get_local_cols()
nrow = desc_a%get_local_rows()
ncol = desc_a%get_local_cols()
nrglob = desc_a%get_global_rows()
nr = a%get_nrows()
nc = a%get_ncols()
@ -288,15 +290,26 @@ subroutine mld_d_soc2_map_bld(iorder,theta,a,desc_a,nlaggr,ilaggr,info)
end if
end do step3
if (count(ilaggr<0) >0) then
info=psb_err_internal_error_
call psb_errpush(info,name,a_err='Fatal error: some leftovers')
goto 9999
endif
! Any leftovers?
do i=1, nr
if (ilaggr(i) <= 0) then
nz = (s_neigh%irp(i+1)-s_neigh%irp(i))
if (nz <= 1) then
! Mark explicitly as a singleton so that
! it will be ignored in map_to_tprol.
! Need to use -(nrglob+nr) to make sure
! it's still negative when shifted and combined with
! other processes.
ilaggr(i) = -(nrglob+nr)
else
info=psb_err_internal_error_
call psb_errpush(info,name,a_err='Fatal error: non-singleton leftovers')
goto 9999
endif
end if
end do
if (naggr > ncol) then
write(0,*) name,'Error : naggr > ncol',naggr,ncol
info=psb_err_internal_error_
call psb_errpush(info,name,a_err='Fatal error: naggr>ncol')
goto 9999

12
mlprec/impl/aggregator/mld_daggrmat_minnrg_asb.f90
Unescape Escape View File

@ -260,7 +260,11 @@ subroutine mld_daggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_re
! Compute omega_int
ommx = dzero
do i=1, ncol
omi(i) = omp(ilaggr(i))
if (ilaggr(i) >0) then
omi(i) = omp(ilaggr(i))
else
omi(i) = dzero
end if
if(abs(omi(i)) .gt. abs(ommx)) ommx = omi(i)
end do
! Compute omega_fine
@ -409,7 +413,11 @@ subroutine mld_daggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_re
! Compute omega_int
ommx = dzero
do i=1, ncol
omi(i) = omp(ilaggr(i))
if (ilaggr(i) >0) then
omi(i) = omp(ilaggr(i))
else
omi(i) = dzero
end if
if(abs(omi(i)) .gt. abs(ommx)) ommx = omi(i)
end do
! Compute omega_fine

4
mlprec/impl/aggregator/mld_daggrmat_nosmth_asb.f90
Unescape Escape View File

@ -178,6 +178,10 @@ subroutine mld_daggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_re
ac_coo%ia(k) = ilaggr(ac_coo%ia(i))
ac_coo%ja(k) = ilaggr(ac_coo%ja(i))
ac_coo%val(k) = ac_coo%val(i)
! At this point, there may be negative entries,
! because that's how ILAGGR marks singletons
! If this is the case, roll back K
if ((ac_coo%ia(k)<=0).or.(ac_coo%ja(k)<=0)) k = k-1
enddo
call ac_coo%set_nrows(naggr)
call ac_coo%set_ncols(naggr)

17
mlprec/impl/aggregator/mld_s_map_to_tprol.f90
Unescape Escape View File

@ -125,12 +125,21 @@ subroutine mld_s_map_to_tprol(desc_a,ilaggr,nlaggr,op_prol,info)
end if
call tmpcoo%allocate(ncol,ntaggr,ncol)
k = 0
do i=1,ncol
tmpcoo%val(i) = sone
tmpcoo%ia(i) = i
tmpcoo%ja(i) = ilaggr(i)
!
! Note: at this point, a value ilaggr(i)<=0
! tags a "singleton" row, and it has to be
! left alone.
!
if (ilaggr(i)>0) then
k = k + 1
tmpcoo%val(k) = sone
tmpcoo%ia(k) = i
tmpcoo%ja(k) = ilaggr(i)
end if
end do
call tmpcoo%set_nzeros(ncol)
call tmpcoo%set_nzeros(k)
call tmpcoo%set_dupl(psb_dupl_add_)
call tmpcoo%set_sorted() ! At this point this is in row-major
call op_prol%mv_from(tmpcoo)

31
mlprec/impl/aggregator/mld_s_soc1_map_bld.f90
Unescape Escape View File

@ -95,6 +95,7 @@ subroutine mld_s_soc1_map_bld(iorder,theta,a,desc_a,nlaggr,ilaggr,info)
integer(psb_ipk_) :: debug_level, debug_unit,err_act
integer(psb_ipk_) :: ictxt,np,me
integer(psb_ipk_) :: nrow, ncol, n_ne
integer(psb_lpk_) :: nrglob
character(len=20) :: name, ch_err
info=psb_success_
@ -110,6 +111,7 @@ subroutine mld_s_soc1_map_bld(iorder,theta,a,desc_a,nlaggr,ilaggr,info)
call psb_info(ictxt,me,np)
nrow = desc_a%get_local_rows()
ncol = desc_a%get_local_cols()
nrglob = desc_a%get_global_rows()
nr = a%get_nrows()
nc = a%get_ncols()
@ -261,12 +263,6 @@ subroutine mld_s_soc1_map_bld(iorder,theta,a,desc_a,nlaggr,ilaggr,info)
nz = (acsr%irp(i+1)-acsr%irp(i))
icol(1:nz) = acsr%ja(acsr%irp(i):acsr%irp(i+1)-1)
val(1:nz) = acsr%val(acsr%irp(i):acsr%irp(i+1)-1)
!!$ call a%csget(i,i,nz,irow,icol,val,info,chksz=.false.)
!!$ if (info /= psb_success_) then
!!$ info=psb_err_from_subroutine_
!!$ call psb_errpush(info,name,a_err='psb_sp_getrow')
!!$ goto 9999
!!$ end if
!
! Find its strongly connected neighbourhood not
! already aggregated, and make it into a new aggregate.
@ -302,11 +298,24 @@ subroutine mld_s_soc1_map_bld(iorder,theta,a,desc_a,nlaggr,ilaggr,info)
end do step3
if (count(ilaggr<0) >0) then
info=psb_err_internal_error_
call psb_errpush(info,name,a_err='Fatal error: some leftovers')
goto 9999
endif
! Any leftovers?
do i=1, nr
if (ilaggr(i) < 0) then
nz = (acsr%irp(i+1)-acsr%irp(i))
if (nz == 1) then
! Mark explicitly as a singleton so that
! it will be ignored in map_to_tprol.
! Need to use -(nrglob+nr) to make sure
! it's still negative when shifted and combined with
! other processes.
ilaggr(i) = -(nrglob+nr)
else
info=psb_err_internal_error_
call psb_errpush(info,name,a_err='Fatal error: non-singleton leftovers')
goto 9999
endif
end if
end do
if (naggr > ncol) then
!write(0,*) name,'Error : naggr > ncol',naggr,ncol

31
mlprec/impl/aggregator/mld_s_soc2_map_bld.f90
Unescape Escape View File

@ -88,6 +88,7 @@ subroutine mld_s_soc2_map_bld(iorder,theta,a,desc_a,nlaggr,ilaggr,info)
integer(psb_lpk_), allocatable :: tmpaggr(:)
real(psb_spk_), allocatable :: val(:), diag(:)
integer(psb_ipk_) :: icnt,nlp,k,n,ia,isz,nr,nc,naggr,i,j,m, nz, ilg, ii, ip, ip1,nzcnt
integer(psb_lpk_) :: nrglob
type(psb_s_csr_sparse_mat) :: acsr, muij, s_neigh
type(psb_s_coo_sparse_mat) :: s_neigh_coo
real(psb_spk_) :: cpling, tcl
@ -108,8 +109,9 @@ subroutine mld_s_soc2_map_bld(iorder,theta,a,desc_a,nlaggr,ilaggr,info)
!
ictxt=desc_a%get_context()
call psb_info(ictxt,me,np)
nrow = desc_a%get_local_rows()
ncol = desc_a%get_local_cols()
nrow = desc_a%get_local_rows()
ncol = desc_a%get_local_cols()
nrglob = desc_a%get_global_rows()
nr = a%get_nrows()
nc = a%get_ncols()
@ -288,15 +290,26 @@ subroutine mld_s_soc2_map_bld(iorder,theta,a,desc_a,nlaggr,ilaggr,info)
end if
end do step3
if (count(ilaggr<0) >0) then
info=psb_err_internal_error_
call psb_errpush(info,name,a_err='Fatal error: some leftovers')
goto 9999
endif
! Any leftovers?
do i=1, nr
if (ilaggr(i) <= 0) then
nz = (s_neigh%irp(i+1)-s_neigh%irp(i))
if (nz <= 1) then
! Mark explicitly as a singleton so that
! it will be ignored in map_to_tprol.
! Need to use -(nrglob+nr) to make sure
! it's still negative when shifted and combined with
! other processes.
ilaggr(i) = -(nrglob+nr)
else
info=psb_err_internal_error_
call psb_errpush(info,name,a_err='Fatal error: non-singleton leftovers')
goto 9999
endif
end if
end do
if (naggr > ncol) then
write(0,*) name,'Error : naggr > ncol',naggr,ncol
info=psb_err_internal_error_
call psb_errpush(info,name,a_err='Fatal error: naggr>ncol')
goto 9999

12
mlprec/impl/aggregator/mld_saggrmat_minnrg_asb.f90
Unescape Escape View File

@ -260,7 +260,11 @@ subroutine mld_saggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_re
! Compute omega_int
ommx = szero
do i=1, ncol
omi(i) = omp(ilaggr(i))
if (ilaggr(i) >0) then
omi(i) = omp(ilaggr(i))
else
omi(i) = szero
end if
if(abs(omi(i)) .gt. abs(ommx)) ommx = omi(i)
end do
! Compute omega_fine
@ -409,7 +413,11 @@ subroutine mld_saggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_re
! Compute omega_int
ommx = szero
do i=1, ncol
omi(i) = omp(ilaggr(i))
if (ilaggr(i) >0) then
omi(i) = omp(ilaggr(i))
else
omi(i) = szero
end if
if(abs(omi(i)) .gt. abs(ommx)) ommx = omi(i)
end do
! Compute omega_fine

4
mlprec/impl/aggregator/mld_saggrmat_nosmth_asb.f90
Unescape Escape View File

@ -178,6 +178,10 @@ subroutine mld_saggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_re
ac_coo%ia(k) = ilaggr(ac_coo%ia(i))
ac_coo%ja(k) = ilaggr(ac_coo%ja(i))
ac_coo%val(k) = ac_coo%val(i)
! At this point, there may be negative entries,
! because that's how ILAGGR marks singletons
! If this is the case, roll back K
if ((ac_coo%ia(k)<=0).or.(ac_coo%ja(k)<=0)) k = k-1
enddo
call ac_coo%set_nrows(naggr)
call ac_coo%set_ncols(naggr)

17
mlprec/impl/aggregator/mld_z_map_to_tprol.f90
Unescape Escape View File

@ -125,12 +125,21 @@ subroutine mld_z_map_to_tprol(desc_a,ilaggr,nlaggr,op_prol,info)
end if
call tmpcoo%allocate(ncol,ntaggr,ncol)
k = 0
do i=1,ncol
tmpcoo%val(i) = zone
tmpcoo%ia(i) = i
tmpcoo%ja(i) = ilaggr(i)
!
! Note: at this point, a value ilaggr(i)<=0
! tags a "singleton" row, and it has to be
! left alone.
!
if (ilaggr(i)>0) then
k = k + 1
tmpcoo%val(k) = zone
tmpcoo%ia(k) = i
tmpcoo%ja(k) = ilaggr(i)
end if
end do
call tmpcoo%set_nzeros(ncol)
call tmpcoo%set_nzeros(k)
call tmpcoo%set_dupl(psb_dupl_add_)
call tmpcoo%set_sorted() ! At this point this is in row-major
call op_prol%mv_from(tmpcoo)

31
mlprec/impl/aggregator/mld_z_soc1_map_bld.f90
Unescape Escape View File

@ -95,6 +95,7 @@ subroutine mld_z_soc1_map_bld(iorder,theta,a,desc_a,nlaggr,ilaggr,info)
integer(psb_ipk_) :: debug_level, debug_unit,err_act
integer(psb_ipk_) :: ictxt,np,me
integer(psb_ipk_) :: nrow, ncol, n_ne
integer(psb_lpk_) :: nrglob
character(len=20) :: name, ch_err
info=psb_success_
@ -110,6 +111,7 @@ subroutine mld_z_soc1_map_bld(iorder,theta,a,desc_a,nlaggr,ilaggr,info)
call psb_info(ictxt,me,np)
nrow = desc_a%get_local_rows()
ncol = desc_a%get_local_cols()
nrglob = desc_a%get_global_rows()
nr = a%get_nrows()
nc = a%get_ncols()
@ -261,12 +263,6 @@ subroutine mld_z_soc1_map_bld(iorder,theta,a,desc_a,nlaggr,ilaggr,info)
nz = (acsr%irp(i+1)-acsr%irp(i))
icol(1:nz) = acsr%ja(acsr%irp(i):acsr%irp(i+1)-1)
val(1:nz) = acsr%val(acsr%irp(i):acsr%irp(i+1)-1)
!!$ call a%csget(i,i,nz,irow,icol,val,info,chksz=.false.)
!!$ if (info /= psb_success_) then
!!$ info=psb_err_from_subroutine_
!!$ call psb_errpush(info,name,a_err='psb_sp_getrow')
!!$ goto 9999
!!$ end if
!
! Find its strongly connected neighbourhood not
! already aggregated, and make it into a new aggregate.
@ -302,11 +298,24 @@ subroutine mld_z_soc1_map_bld(iorder,theta,a,desc_a,nlaggr,ilaggr,info)
end do step3
if (count(ilaggr<0) >0) then
info=psb_err_internal_error_
call psb_errpush(info,name,a_err='Fatal error: some leftovers')
goto 9999
endif
! Any leftovers?
do i=1, nr
if (ilaggr(i) < 0) then
nz = (acsr%irp(i+1)-acsr%irp(i))
if (nz == 1) then
! Mark explicitly as a singleton so that
! it will be ignored in map_to_tprol.
! Need to use -(nrglob+nr) to make sure
! it's still negative when shifted and combined with
! other processes.
ilaggr(i) = -(nrglob+nr)
else
info=psb_err_internal_error_
call psb_errpush(info,name,a_err='Fatal error: non-singleton leftovers')
goto 9999
endif
end if
end do
if (naggr > ncol) then
!write(0,*) name,'Error : naggr > ncol',naggr,ncol

31
mlprec/impl/aggregator/mld_z_soc2_map_bld.f90
Unescape Escape View File

@ -88,6 +88,7 @@ subroutine mld_z_soc2_map_bld(iorder,theta,a,desc_a,nlaggr,ilaggr,info)
integer(psb_lpk_), allocatable :: tmpaggr(:)
complex(psb_dpk_), allocatable :: val(:), diag(:)
integer(psb_ipk_) :: icnt,nlp,k,n,ia,isz,nr,nc,naggr,i,j,m, nz, ilg, ii, ip, ip1,nzcnt
integer(psb_lpk_) :: nrglob
type(psb_z_csr_sparse_mat) :: acsr, muij, s_neigh
type(psb_z_coo_sparse_mat) :: s_neigh_coo
real(psb_dpk_) :: cpling, tcl
@ -108,8 +109,9 @@ subroutine mld_z_soc2_map_bld(iorder,theta,a,desc_a,nlaggr,ilaggr,info)
!
ictxt=desc_a%get_context()
call psb_info(ictxt,me,np)
nrow = desc_a%get_local_rows()
ncol = desc_a%get_local_cols()
nrow = desc_a%get_local_rows()
ncol = desc_a%get_local_cols()
nrglob = desc_a%get_global_rows()
nr = a%get_nrows()
nc = a%get_ncols()
@ -288,15 +290,26 @@ subroutine mld_z_soc2_map_bld(iorder,theta,a,desc_a,nlaggr,ilaggr,info)
end if
end do step3
if (count(ilaggr<0) >0) then
info=psb_err_internal_error_
call psb_errpush(info,name,a_err='Fatal error: some leftovers')
goto 9999
endif
! Any leftovers?
do i=1, nr
if (ilaggr(i) <= 0) then
nz = (s_neigh%irp(i+1)-s_neigh%irp(i))
if (nz <= 1) then
! Mark explicitly as a singleton so that
! it will be ignored in map_to_tprol.
! Need to use -(nrglob+nr) to make sure
! it's still negative when shifted and combined with
! other processes.
ilaggr(i) = -(nrglob+nr)
else
info=psb_err_internal_error_
call psb_errpush(info,name,a_err='Fatal error: non-singleton leftovers')
goto 9999
endif
end if
end do
if (naggr > ncol) then
write(0,*) name,'Error : naggr > ncol',naggr,ncol
info=psb_err_internal_error_
call psb_errpush(info,name,a_err='Fatal error: naggr>ncol')
goto 9999

12
mlprec/impl/aggregator/mld_zaggrmat_minnrg_asb.f90
Unescape Escape View File

@ -260,7 +260,11 @@ subroutine mld_zaggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_re
! Compute omega_int
ommx = zzero
do i=1, ncol
omi(i) = omp(ilaggr(i))
if (ilaggr(i) >0) then
omi(i) = omp(ilaggr(i))
else
omi(i) = zzero
end if
if(abs(omi(i)) .gt. abs(ommx)) ommx = omi(i)
end do
! Compute omega_fine
@ -409,7 +413,11 @@ subroutine mld_zaggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_re
! Compute omega_int
ommx = zzero
do i=1, ncol
omi(i) = omp(ilaggr(i))
if (ilaggr(i) >0) then
omi(i) = omp(ilaggr(i))
else
omi(i) = zzero
end if
if(abs(omi(i)) .gt. abs(ommx)) ommx = omi(i)
end do
! Compute omega_fine

4
mlprec/impl/aggregator/mld_zaggrmat_nosmth_asb.f90
Unescape Escape View File

@ -178,6 +178,10 @@ subroutine mld_zaggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_re
ac_coo%ia(k) = ilaggr(ac_coo%ia(i))
ac_coo%ja(k) = ilaggr(ac_coo%ja(i))
ac_coo%val(k) = ac_coo%val(i)
! At this point, there may be negative entries,
! because that's how ILAGGR marks singletons
! If this is the case, roll back K
if ((ac_coo%ia(k)<=0).or.(ac_coo%ja(k)<=0)) k = k-1
enddo
call ac_coo%set_nrows(naggr)
call ac_coo%set_ncols(naggr)

Write Preview
Loading…
Cancel
Save