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

Fixed all versions of MAT_ASB.

Browse Source
stopcriterion
Salvatore Filippone 6 years ago
parent 5bdd07b13b
commit f0472fa227
16 changed files with 380 additions and 576 deletions
Show Stats Download Patch File Download Diff File

72
mlprec/impl/aggregator/mld_caggrmat_biz_asb.f90
Unescape Escape View File

@ -88,26 +88,26 @@ subroutine mld_caggrmat_biz_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_restr
implicit none
! Arguments
type(psb_cspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(inout) :: ilaggr(:), nlaggr(:)
type(mld_sml_parms), intent(inout) :: parms
type(psb_cspmat_type), intent(inout) :: op_prol
type(psb_cspmat_type), intent(out) :: ac,op_restr
integer(psb_ipk_), intent(out) :: info
type(psb_cspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_a
integer(psb_lpk_), intent(inout) :: ilaggr(:), nlaggr(:)
type(mld_sml_parms), intent(inout) :: parms
type(psb_lcspmat_type), intent(inout) :: op_prol
type(psb_lcspmat_type), intent(out) :: ac,op_restr
integer(psb_ipk_), intent(out) :: info
! Local variables
integer(psb_ipk_) :: nrow, nglob, ncol, ntaggr, ip, ndx,&
& naggr, nzl,naggrm1,naggrp1, i, j, k, jd, icolF, nrw, err_act
integer(psb_lpk_) :: nrow, nglob, ncol, ntaggr, ip, &
& naggr, nzl,naggrm1,naggrp1, i, j, k, jd, icolF, nrw
integer(psb_ipk_) ::ictxt, np, me
character(len=20) :: name
type(psb_cspmat_type) :: am3, am4,tmp_prol
type(psb_c_coo_sparse_mat) :: tmpcoo
type(psb_c_csr_sparse_mat) :: acsr1, acsr2, acsr3, acsrf, ptilde
type(psb_lcspmat_type) :: am3, am4,tmp_prol, la
type(psb_lc_coo_sparse_mat) :: tmpcoo
type(psb_lc_csr_sparse_mat) :: acsr1, acsr2, acsr3, acsrf, ptilde
complex(psb_spk_), allocatable :: adiag(:)
integer(psb_ipk_) :: ierr(5)
logical :: filter_mat
integer(psb_ipk_) :: debug_level, debug_unit
integer(psb_ipk_) :: debug_level, debug_unit, err_act
integer(psb_ipk_), parameter :: ncmax=16
real(psb_spk_) :: anorm, omega, tmp, dg, theta
@ -130,10 +130,8 @@ subroutine mld_caggrmat_biz_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_restr
ncol = desc_a%get_local_cols()
theta = parms%aggr_thresh
naggr = nlaggr(me+1)
ntaggr = sum(nlaggr)
filter_mat = (parms%aggr_filter == mld_filter_mat_)
! naggr: number of local aggregates
@ -145,8 +143,8 @@ subroutine mld_caggrmat_biz_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_restr
& call psb_realloc(ncol,adiag,info)
if (info == psb_success_) &
& call psb_halo(adiag,desc_a,info)
if(info /= psb_success_) then
if (info == psb_success_) call a%cp_to_l(la)
if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='sp_getdiag')
goto 9999
end if
@ -154,7 +152,7 @@ subroutine mld_caggrmat_biz_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_restr
! 1. Allocate Ptilde in sparse matrix form
call op_prol%mv_to(tmpcoo)
call ptilde%mv_from_coo(tmpcoo,info)
if (info == psb_success_) call a%cscnv(acsr3,info,dupl=psb_dupl_add_)
if (info == psb_success_) call la%cscnv(acsr3,info,dupl=psb_dupl_add_)
if (info /= psb_success_) goto 9999
if (debug_level >= psb_debug_outer_) &
@ -165,9 +163,9 @@ subroutine mld_caggrmat_biz_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_restr
!
! Build the filtered matrix Af from A
!
if (info == psb_success_) call a%cscnv(acsrf,info,dupl=psb_dupl_add_)
if (info == psb_success_) call acsr3%cp_to_fmt(acsrf,info)
do i=1,nrow
do i=1, nrow
tmp = czero
jd = -1
do j=acsrf%irp(i),acsrf%irp(i+1)-1
@ -273,17 +271,15 @@ subroutine mld_caggrmat_biz_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_restr
! Doing it this way means to consider diag(Af_i)
!
!
call psb_symbmm(acsrf,ptilde,acsr1,info)
call psb_spspmm(acsrf,ptilde,acsr1,info)
if(info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='symbmm 1')
call psb_errpush(psb_err_from_subroutine_,name,a_err='spspmm 1')
goto 9999
end if
call psb_numbmm(acsrf,ptilde,acsr1)
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'Done NUMBMM 1'
& 'Done SPSPMM 1'
else
!
@ -309,17 +305,15 @@ subroutine mld_caggrmat_biz_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_restr
! Doing it this way means to consider diag(A_i)
!
!
call psb_symbmm(acsr3,ptilde,acsr1,info)
call psb_spspmm(acsr3,ptilde,acsr1,info)
if(info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='symbmm 1')
call psb_errpush(psb_err_from_subroutine_,name,a_err='spspmm 1')
goto 9999
end if
call psb_numbmm(acsr3,ptilde,acsr1)
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'Done NUMBMM 1'
& 'Done SPSPMM 1'
end if
call ptilde%free()
@ -333,16 +327,15 @@ subroutine mld_caggrmat_biz_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_restr
goto 9999
end if
call psb_symbmm(a,tmp_prol,am3,info)
call psb_spspmm(la,tmp_prol,am3,info)
if(info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='symbmm 2')
call psb_errpush(psb_err_from_subroutine_,name,a_err='spspmm 2')
goto 9999
end if
call psb_numbmm(a,tmp_prol,am3)
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'Done NUMBMM 2',parms%aggr_prol, mld_smooth_prol_
& 'Done SPSPMM 2',parms%aggr_prol, mld_smooth_prol_
call tmp_prol%transp(op_restr)
if (debug_level >= psb_debug_outer_) &
@ -355,23 +348,18 @@ subroutine mld_caggrmat_biz_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_restr
goto 9999
end if
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'starting symbmm 3'
call psb_symbmm(op_restr,am3,ac,info)
if (info == psb_success_) call psb_numbmm(op_restr,am3,ac)
& 'starting spspmm 3'
call psb_spspmm(op_restr,am3,ac,info)
if (info == psb_success_) call am3%free()
if (info == psb_success_) call ac%cscnv(info,type='coo',dupl=psb_dupl_add_)
if (info == psb_success_) call ac%cscnv(info,type='csr',dupl=psb_dupl_add_)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,a_err='Build b = op_restr x am3')
goto 9999
end if
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'Done smooth_aggregate '

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

@ -118,29 +118,28 @@ subroutine mld_caggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_re
! Arguments
type(psb_cspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(inout) :: ilaggr(:), nlaggr(:)
type(mld_sml_parms), intent(inout) :: parms
type(psb_cspmat_type), intent(inout) :: op_prol
type(psb_cspmat_type), intent(out) :: ac,op_restr
integer(psb_lpk_), intent(inout) :: ilaggr(:), nlaggr(:)
type(mld_sml_parms), intent(inout) :: parms
type(psb_lcspmat_type), intent(inout) :: op_prol
type(psb_lcspmat_type), intent(out) :: ac,op_restr
integer(psb_ipk_), intent(out) :: info
! Local variables
integer(psb_ipk_), allocatable :: nzbr(:), idisp(:)
integer(psb_ipk_) :: nrow, nglob, ncol, ntaggr, nzac, ip, ndx,&
& naggr, nzl,naggrm1,naggrp1, i, j, k, jd, icolF, nrt, err_act
integer(psb_lpk_) :: nrow, nglob, ncol, ntaggr, nzac, ip, ndx,&
& naggr, nzl,naggrm1,naggrp1, i, j, k, jd, icolF, nrt
integer(psb_ipk_) :: ictxt,np,me, icomm
character(len=20) :: name
type(psb_cspmat_type) :: af, ptilde, rtilde, atran, atp, atdatp
type(psb_cspmat_type) :: am3,am4, ap, adap,atmp,rada, ra, atmp2, dap, dadap, da
type(psb_cspmat_type) :: dat, datp, datdatp, atmp3, tmp_prol
type(psb_c_coo_sparse_mat) :: tmpcoo
type(psb_c_csr_sparse_mat) :: acsr1, acsr2, acsr3, acsr, acsrf
type(psb_c_csc_sparse_mat) :: csc_dap, csc_dadap, csc_datp, csc_datdatp, acsc
type(psb_lcspmat_type) :: la, af, ptilde, rtilde, atran, atp, atdatp
type(psb_lcspmat_type) :: am3,am4, ap, adap,atmp,rada, ra, atmp2, dap, dadap, da
type(psb_lcspmat_type) :: dat, datp, datdatp, atmp3, tmp_prol
type(psb_lc_coo_sparse_mat) :: tmpcoo
type(psb_lc_csr_sparse_mat) :: acsr1, acsr2, acsr3, acsr, acsrf
type(psb_lc_csc_sparse_mat) :: csc_dap, csc_dadap, csc_datp, csc_datdatp, acsc
complex(psb_spk_), allocatable :: adiag(:), adinv(:)
complex(psb_spk_), allocatable :: omf(:), omp(:), omi(:), oden(:)
logical :: filter_mat
integer(psb_ipk_) :: ierr(5)
integer(psb_ipk_) :: debug_level, debug_unit
integer(psb_ipk_) :: debug_level, debug_unit, err_act
integer(psb_ipk_), parameter :: ncmax=16
real(psb_spk_) :: anorm, theta
complex(psb_spk_) :: tmp, alpha, beta, ommx
@ -169,13 +168,6 @@ subroutine mld_caggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_re
naggr = nlaggr(me+1)
ntaggr = sum(nlaggr)
allocate(nzbr(np), idisp(np),stat=info)
if (info /= psb_success_) then
info=psb_err_alloc_request_; ierr(1)=2*np;
call psb_errpush(info,name,i_err=ierr,a_err='integer')
goto 9999
end if
naggrm1 = sum(nlaggr(1:me))
naggrp1 = sum(nlaggr(1:me+1))
@ -199,6 +191,11 @@ subroutine mld_caggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_re
& call psb_realloc(ncol,adiag,info)
if (info == psb_success_) &
& call psb_halo(adiag,desc_a,info)
if (info == psb_success_) call a%cp_to_l(la)
if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='sp_getdiag')
goto 9999
end if
do i=1,size(adiag)
if (adiag(i) /= czero) then
@ -208,10 +205,6 @@ subroutine mld_caggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_re
end if
end do
if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='sp_getdiag')
goto 9999
end if
! 1. Allocate Ptilde in sparse matrix form
@ -219,8 +212,8 @@ subroutine mld_caggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_re
call ptilde%mv_from(tmpcoo)
call ptilde%cscnv(info,type='csr')
if (info == psb_success_) call a%cscnv(am3,info,type='csr',dupl=psb_dupl_add_)
if (info == psb_success_) call a%cscnv(da,info,type='csr',dupl=psb_dupl_add_)
if (info == psb_success_) call la%cscnv(am3,info,type='csr',dupl=psb_dupl_add_)
if (info == psb_success_) call la%cscnv(da,info,type='csr',dupl=psb_dupl_add_)
if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='spcnv')
goto 9999
@ -231,11 +224,10 @@ subroutine mld_caggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_re
call da%scal(adinv,info)
call psb_symbmm(da,ptilde,dap,info)
if (info == psb_success_) call psb_numbmm(da,ptilde,dap)
call psb_spspmm(da,ptilde,dap,info)
if(info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='symbmm 1')
call psb_errpush(psb_err_from_subroutine_,name,a_err='spspmm 1')
goto 9999
end if
@ -246,8 +238,7 @@ subroutine mld_caggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_re
if (info == psb_success_) call psb_rwextd(ncol,atmp,info,b=am4)
if (info == psb_success_) call am4%free()
call psb_symbmm(da,atmp,dadap,info)
call psb_numbmm(da,atmp,dadap)
call psb_spspmm(da,atmp,dadap,info)
call atmp%free()
! !$ write(0,*) 'Columns of AP',psb_sp_get_ncols(ap)
@ -255,7 +246,6 @@ subroutine mld_caggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_re
call dap%mv_to(csc_dap)
call dadap%mv_to(csc_dadap)
call csc_mat_col_prod(csc_dap,csc_dadap,omp,info)
call csc_mat_col_prod(csc_dadap,csc_dadap,oden,info)
call psb_sum(ictxt,omp)
@ -293,7 +283,7 @@ subroutine mld_caggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_re
!
! Build the filtered matrix Af from A
!
call a%cscnv(acsrf,info,dupl=psb_dupl_add_)
call la%cscnv(acsrf,info,dupl=psb_dupl_add_)
do i=1,nrow
tmp = czero
@ -333,23 +323,14 @@ subroutine mld_caggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_re
call af%mv_from(acsrf)
!
! Symbmm90 does the allocation for its result.
!
! op_prol = (I-w*D*Af)Ptilde
! Doing it this way means to consider diag(Af_i)
!
!
call psb_symbmm(af,ptilde,op_prol,info)
if(info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='symbmm 1')
goto 9999
end if
call psb_numbmm(af,ptilde,op_prol)
call psb_spspmm(af,ptilde,op_prol,info)
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'Done NUMBMM 1'
& 'Done SPSPMM 1'
else
!
! Build the smoothed prolongator using the original matrix
@ -369,19 +350,11 @@ subroutine mld_caggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_re
& write(debug_unit,*) me,' ',trim(name),&
& 'Done gather, going for SYMBMM 1'
!
! Symbmm90 does the allocation for its result.
!
! op_prol = (I-w*D*A)Ptilde
!
!
call psb_symbmm(am3,ptilde,op_prol,info)
if(info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='symbmm 1')
goto 9999
end if
call psb_numbmm(am3,ptilde,op_prol)
call psb_spspmm(am3,ptilde,op_prol,info)
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'Done NUMBMM 1'
@ -393,11 +366,11 @@ subroutine mld_caggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_re
! Ok, let's start over with the restrictor
!
call ptilde%transc(rtilde)
call a%cscnv(atmp,info,type='csr')
call la%cscnv(atmp,info,type='csr')
call psb_sphalo(atmp,desc_a,am4,info,&
& colcnv=.true.,rowscale=.true.)
nrt = am4%get_nrows()
call am4%csclip(atmp2,info,ione,nrt,ione,ncol)
call am4%csclip(atmp2,info,lone,nrt,lone,ncol)
call atmp2%cscnv(info,type='CSR')
if (info == psb_success_) call psb_rwextd(ncol,atmp,info,b=atmp2)
call am4%free()
@ -406,13 +379,12 @@ subroutine mld_caggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_re
! This is to compute the transpose. It ONLY works if the
! original A has a symmetric pattern.
call atmp%transc(atmp2)
call atmp2%csclip(dat,info,ione,nrow,ione,ncol)
call atmp2%csclip(dat,info,lone,nrow,lone,ncol)
call dat%cscnv(info,type='csr')
call dat%scal(adinv,info)
! Now for the product.
call psb_symbmm(dat,ptilde,datp,info)
if (info == psb_success_) call psb_numbmm(dat,ptilde,datp)
call psb_spspmm(dat,ptilde,datp,info)
call datp%clone(atmp2,info)
call psb_sphalo(atmp2,desc_a,am4,info,&
@ -490,8 +462,7 @@ subroutine mld_caggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_re
call rtilde%mv_from(tmpcoo)
call rtilde%cscnv(info,type='csr')
call psb_symbmm(rtilde,atmp,op_restr,info)
call psb_numbmm(rtilde,atmp,op_restr)
call psb_spspmm(rtilde,atmp,op_restr,info)
!
! Now we have to gather the halo of op_prol, and add it to itself
@ -533,16 +504,10 @@ subroutine mld_caggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_re
& write(debug_unit,*) me,' ',trim(name),&
& 'starting sphalo/ rwxtd'
call psb_symbmm(a,tmp_prol,am3,info)
if(info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,&
& a_err='symbmm 2')
goto 9999
end if
call psb_numbmm(a,tmp_prol,am3)
call psb_spspmm(la,tmp_prol,am3,info)
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'Done NUMBMM 2'
& 'Done SPSPMM 2'
call psb_sphalo(am3,desc_a,am4,info,&
& colcnv=.false.,rowscale=.true.)
@ -558,8 +523,7 @@ subroutine mld_caggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_re
& write(debug_unit,*) me,' ',trim(name),&
& 'Done sphalo/ rwxtd'
call psb_symbmm(op_restr,am3,ac,info)
if (info == psb_success_) call psb_numbmm(op_restr,am3,ac)
call psb_spspmm(op_restr,am3,ac,info)
if (info == psb_success_) call am3%free()
if (info == psb_success_) call ac%cscnv(info,type='coo',dupl=psb_dupl_add_)
@ -587,11 +551,11 @@ contains
subroutine csc_mat_col_prod(a,b,v,info)
implicit none
type(psb_c_csc_sparse_mat), intent(in) :: a, b
type(psb_lc_csc_sparse_mat), intent(in) :: a, b
complex(psb_spk_), intent(out) :: v(:)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: i,j,k, nr, nc,iap,nra,ibp,nrb
integer(psb_lpk_) :: i,j,k, nr, nc,iap,nra,ibp,nrb
info = psb_success_
nc = a%get_ncols()
@ -615,11 +579,11 @@ contains
subroutine csr_mat_row_prod(a,b,v,info)
implicit none
type(psb_c_csr_sparse_mat), intent(in) :: a, b
type(psb_lc_csr_sparse_mat), intent(in) :: a, b
complex(psb_spk_), intent(out) :: v(:)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: i,j,k, nr, nc,iap,nca,ibp,ncb
integer(psb_lpk_) :: i,j,k, nr, nc,iap,nca,ibp,ncb
info = psb_success_
nr = a%get_nrows()
@ -643,12 +607,12 @@ contains
function sparse_srtd_dot(nv1,iv1,v1,nv2,iv2,v2) result(dot)
implicit none
integer(psb_ipk_), intent(in) :: nv1,nv2
integer(psb_ipk_), intent(in) :: iv1(:), iv2(:)
integer(psb_lpk_), intent(in) :: nv1,nv2
integer(psb_lpk_), intent(in) :: iv1(:), iv2(:)
complex(psb_spk_), intent(in) :: v1(:),v2(:)
complex(psb_spk_) :: dot
integer(psb_ipk_) :: i,j,k, ip1, ip2
integer(psb_lpk_) :: i,j,k, ip1, ip2
dot = czero
ip1 = 1
@ -671,7 +635,7 @@ contains
end function sparse_srtd_dot
subroutine local_dump(me,mat,name,header)
type(psb_cspmat_type), intent(in) :: mat
type(psb_lcspmat_type), intent(in) :: mat
integer(psb_ipk_), intent(in) :: me
character(len=*), intent(in) :: name
character(len=*), intent(in) :: header

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

@ -106,25 +106,26 @@ subroutine mld_caggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_re
! Arguments
type(psb_cspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(inout) :: ilaggr(:), nlaggr(:)
integer(psb_lpk_), intent(inout) :: ilaggr(:), nlaggr(:)
type(mld_sml_parms), intent(inout) :: parms
type(psb_cspmat_type), intent(inout) :: op_prol
type(psb_cspmat_type), intent(out) :: ac,op_restr
type(psb_lcspmat_type), intent(inout) :: op_prol
type(psb_lcspmat_type), intent(out) :: ac,op_restr
integer(psb_ipk_), intent(out) :: info
! Local variables
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ictxt,np,me, icomm, ndx, minfo
integer(psb_ipk_) :: ictxt, np, me, icomm, minfo
character(len=20) :: name
integer(psb_ipk_) :: ierr(5)
type(psb_c_coo_sparse_mat) :: ac_coo, tmpcoo
type(psb_c_csr_sparse_mat) :: acsr1, acsr2
integer(psb_ipk_) :: ierr(5)
type(psb_lcspmat_type) :: la
type(psb_lc_coo_sparse_mat) :: ac_coo, tmpcoo
type(psb_lc_csr_sparse_mat) :: acsr1, acsr2
integer(psb_ipk_) :: debug_level, debug_unit
integer(psb_ipk_) :: nrow, nglob, ncol, ntaggr, nzl, ip, &
integer(psb_lpk_) :: nrow, nglob, ncol, ntaggr, nzl, ip, &
& naggr, nzt, naggrm1, naggrp1, i, k
name='mld_aggrmat_nosmth_asb'
info=psb_success_
name = 'mld_aggrmat_nosmth_asb'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_; goto 9999
@ -137,24 +138,23 @@ subroutine mld_caggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_re
nrow = desc_a%get_local_rows()
ncol = desc_a%get_local_cols()
naggr = nlaggr(me+1)
ntaggr = sum(nlaggr)
naggrm1 = sum(nlaggr(1:me))
naggrp1 = sum(nlaggr(1:me+1))
call op_prol%cp_to(tmpcoo)
call op_prol%cscnv(info,type='csr',dupl=psb_dupl_add_)
call tmpcoo%transp()
nzl = tmpcoo%get_nzeros()
i=0
!
! Now we have to fix this. The only rows of tmpcoo/op_restr that are correct
! are those corresponding to "local" aggregates, i.e. indices in ilaggr(:)
!
do k=1, nzl
nzl = tmpcoo%get_nzeros()
i = 0
do k = 1, nzl
if ((naggrm1 < tmpcoo%ia(k)) .and.(tmpcoo%ia(k) <= naggrp1)) then
i = i+1
tmpcoo%val(i) = tmpcoo%val(k)
@ -169,11 +169,11 @@ subroutine mld_caggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_re
if (info /= psb_success_) goto 9999
call a%cp_to(ac_coo)
call a%cp_to_l(la)
call la%mv_to(ac_coo)
nzt = ac_coo%get_nzeros()
k = 0
do i=1, nzt
k = 0
do i = 1, nzt
k = k + 1
ac_coo%ia(k) = ilaggr(ac_coo%ia(i))
ac_coo%ja(k) = ilaggr(ac_coo%ja(i))

7
mlprec/impl/aggregator/mld_caggrmat_smth_asb.f90
Unescape Escape View File

@ -126,9 +126,9 @@ subroutine mld_caggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_rest
integer(psb_ipk_), intent(out) :: info
! Local variables
integer(psb_lpk_) :: nrow, nglob, ncol, ntaggr, ip, ndx,&
integer(psb_lpk_) :: nrow, nglob, ncol, ntaggr, ip, &
& naggr, nzl,naggrm1,naggrp1, i, j, k, jd, icolF, nrw
integer(psb_ipk_) ::ictxt, np, me
integer(psb_ipk_) :: ictxt, np, me
character(len=20) :: name
type(psb_lcspmat_type) :: la, am3, am4, tmp_prol
type(psb_lc_coo_sparse_mat) :: tmpcoo
@ -149,7 +149,6 @@ subroutine mld_caggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_rest
debug_unit = psb_get_debug_unit()
debug_level = psb_get_debug_level()
ictxt = desc_a%get_context()
ictxt = desc_a%get_context()
call psb_info(ictxt, me, np)
@ -201,7 +200,7 @@ subroutine mld_caggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_rest
!
if (info == psb_success_) call acsr3%cp_to_fmt(acsrf,info)
do i=1,nrow
do i=1, nrow
tmp = czero
jd = -1
do j=acsrf%irp(i),acsrf%irp(i+1)-1

72
mlprec/impl/aggregator/mld_daggrmat_biz_asb.f90
Unescape Escape View File

@ -88,26 +88,26 @@ subroutine mld_daggrmat_biz_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_restr
implicit none
! Arguments
type(psb_dspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(inout) :: ilaggr(:), nlaggr(:)
type(mld_dml_parms), intent(inout) :: parms
type(psb_dspmat_type), intent(inout) :: op_prol
type(psb_dspmat_type), intent(out) :: ac,op_restr
integer(psb_ipk_), intent(out) :: info
type(psb_dspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_a
integer(psb_lpk_), intent(inout) :: ilaggr(:), nlaggr(:)
type(mld_dml_parms), intent(inout) :: parms
type(psb_ldspmat_type), intent(inout) :: op_prol
type(psb_ldspmat_type), intent(out) :: ac,op_restr
integer(psb_ipk_), intent(out) :: info
! Local variables
integer(psb_ipk_) :: nrow, nglob, ncol, ntaggr, ip, ndx,&
& naggr, nzl,naggrm1,naggrp1, i, j, k, jd, icolF, nrw, err_act
integer(psb_lpk_) :: nrow, nglob, ncol, ntaggr, ip, &
& naggr, nzl,naggrm1,naggrp1, i, j, k, jd, icolF, nrw
integer(psb_ipk_) ::ictxt, np, me
character(len=20) :: name
type(psb_dspmat_type) :: am3, am4,tmp_prol
type(psb_d_coo_sparse_mat) :: tmpcoo
type(psb_d_csr_sparse_mat) :: acsr1, acsr2, acsr3, acsrf, ptilde
type(psb_ldspmat_type) :: am3, am4,tmp_prol, la
type(psb_ld_coo_sparse_mat) :: tmpcoo
type(psb_ld_csr_sparse_mat) :: acsr1, acsr2, acsr3, acsrf, ptilde
real(psb_dpk_), allocatable :: adiag(:)
integer(psb_ipk_) :: ierr(5)
logical :: filter_mat
integer(psb_ipk_) :: debug_level, debug_unit
integer(psb_ipk_) :: debug_level, debug_unit, err_act
integer(psb_ipk_), parameter :: ncmax=16
real(psb_dpk_) :: anorm, omega, tmp, dg, theta
@ -130,10 +130,8 @@ subroutine mld_daggrmat_biz_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_restr
ncol = desc_a%get_local_cols()
theta = parms%aggr_thresh
naggr = nlaggr(me+1)
ntaggr = sum(nlaggr)
filter_mat = (parms%aggr_filter == mld_filter_mat_)
! naggr: number of local aggregates
@ -145,8 +143,8 @@ subroutine mld_daggrmat_biz_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_restr
& call psb_realloc(ncol,adiag,info)
if (info == psb_success_) &
& call psb_halo(adiag,desc_a,info)
if(info /= psb_success_) then
if (info == psb_success_) call a%cp_to_l(la)
if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='sp_getdiag')
goto 9999
end if
@ -154,7 +152,7 @@ subroutine mld_daggrmat_biz_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_restr
! 1. Allocate Ptilde in sparse matrix form
call op_prol%mv_to(tmpcoo)
call ptilde%mv_from_coo(tmpcoo,info)
if (info == psb_success_) call a%cscnv(acsr3,info,dupl=psb_dupl_add_)
if (info == psb_success_) call la%cscnv(acsr3,info,dupl=psb_dupl_add_)
if (info /= psb_success_) goto 9999
if (debug_level >= psb_debug_outer_) &
@ -165,9 +163,9 @@ subroutine mld_daggrmat_biz_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_restr
!
! Build the filtered matrix Af from A
!
if (info == psb_success_) call a%cscnv(acsrf,info,dupl=psb_dupl_add_)
if (info == psb_success_) call acsr3%cp_to_fmt(acsrf,info)
do i=1,nrow
do i=1, nrow
tmp = dzero
jd = -1
do j=acsrf%irp(i),acsrf%irp(i+1)-1
@ -273,17 +271,15 @@ subroutine mld_daggrmat_biz_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_restr
! Doing it this way means to consider diag(Af_i)
!
!
call psb_symbmm(acsrf,ptilde,acsr1,info)
call psb_spspmm(acsrf,ptilde,acsr1,info)
if(info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='symbmm 1')
call psb_errpush(psb_err_from_subroutine_,name,a_err='spspmm 1')
goto 9999
end if
call psb_numbmm(acsrf,ptilde,acsr1)
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'Done NUMBMM 1'
& 'Done SPSPMM 1'
else
!
@ -309,17 +305,15 @@ subroutine mld_daggrmat_biz_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_restr
! Doing it this way means to consider diag(A_i)
!
!
call psb_symbmm(acsr3,ptilde,acsr1,info)
call psb_spspmm(acsr3,ptilde,acsr1,info)
if(info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='symbmm 1')
call psb_errpush(psb_err_from_subroutine_,name,a_err='spspmm 1')
goto 9999
end if
call psb_numbmm(acsr3,ptilde,acsr1)
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'Done NUMBMM 1'
& 'Done SPSPMM 1'
end if
call ptilde%free()
@ -333,16 +327,15 @@ subroutine mld_daggrmat_biz_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_restr
goto 9999
end if
call psb_symbmm(a,tmp_prol,am3,info)
call psb_spspmm(la,tmp_prol,am3,info)
if(info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='symbmm 2')
call psb_errpush(psb_err_from_subroutine_,name,a_err='spspmm 2')
goto 9999
end if
call psb_numbmm(a,tmp_prol,am3)
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'Done NUMBMM 2',parms%aggr_prol, mld_smooth_prol_
& 'Done SPSPMM 2',parms%aggr_prol, mld_smooth_prol_
call tmp_prol%transp(op_restr)
if (debug_level >= psb_debug_outer_) &
@ -355,23 +348,18 @@ subroutine mld_daggrmat_biz_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_restr
goto 9999
end if
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'starting symbmm 3'
call psb_symbmm(op_restr,am3,ac,info)
if (info == psb_success_) call psb_numbmm(op_restr,am3,ac)
& 'starting spspmm 3'
call psb_spspmm(op_restr,am3,ac,info)
if (info == psb_success_) call am3%free()
if (info == psb_success_) call ac%cscnv(info,type='coo',dupl=psb_dupl_add_)
if (info == psb_success_) call ac%cscnv(info,type='csr',dupl=psb_dupl_add_)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,a_err='Build b = op_restr x am3')
goto 9999
end if
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'Done smooth_aggregate '

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

@ -118,29 +118,28 @@ subroutine mld_daggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_re
! Arguments
type(psb_dspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(inout) :: ilaggr(:), nlaggr(:)
type(mld_dml_parms), intent(inout) :: parms
type(psb_dspmat_type), intent(inout) :: op_prol
type(psb_dspmat_type), intent(out) :: ac,op_restr
integer(psb_lpk_), intent(inout) :: ilaggr(:), nlaggr(:)
type(mld_dml_parms), intent(inout) :: parms
type(psb_ldspmat_type), intent(inout) :: op_prol
type(psb_ldspmat_type), intent(out) :: ac,op_restr
integer(psb_ipk_), intent(out) :: info
! Local variables
integer(psb_ipk_), allocatable :: nzbr(:), idisp(:)
integer(psb_ipk_) :: nrow, nglob, ncol, ntaggr, nzac, ip, ndx,&
& naggr, nzl,naggrm1,naggrp1, i, j, k, jd, icolF, nrt, err_act
integer(psb_lpk_) :: nrow, nglob, ncol, ntaggr, nzac, ip, ndx,&
& naggr, nzl,naggrm1,naggrp1, i, j, k, jd, icolF, nrt
integer(psb_ipk_) :: ictxt,np,me, icomm
character(len=20) :: name
type(psb_dspmat_type) :: af, ptilde, rtilde, atran, atp, atdatp
type(psb_dspmat_type) :: am3,am4, ap, adap,atmp,rada, ra, atmp2, dap, dadap, da
type(psb_dspmat_type) :: dat, datp, datdatp, atmp3, tmp_prol
type(psb_d_coo_sparse_mat) :: tmpcoo
type(psb_d_csr_sparse_mat) :: acsr1, acsr2, acsr3, acsr, acsrf
type(psb_d_csc_sparse_mat) :: csc_dap, csc_dadap, csc_datp, csc_datdatp, acsc
type(psb_ldspmat_type) :: la, af, ptilde, rtilde, atran, atp, atdatp
type(psb_ldspmat_type) :: am3,am4, ap, adap,atmp,rada, ra, atmp2, dap, dadap, da
type(psb_ldspmat_type) :: dat, datp, datdatp, atmp3, tmp_prol
type(psb_ld_coo_sparse_mat) :: tmpcoo
type(psb_ld_csr_sparse_mat) :: acsr1, acsr2, acsr3, acsr, acsrf
type(psb_ld_csc_sparse_mat) :: csc_dap, csc_dadap, csc_datp, csc_datdatp, acsc
real(psb_dpk_), allocatable :: adiag(:), adinv(:)
real(psb_dpk_), allocatable :: omf(:), omp(:), omi(:), oden(:)
logical :: filter_mat
integer(psb_ipk_) :: ierr(5)
integer(psb_ipk_) :: debug_level, debug_unit
integer(psb_ipk_) :: debug_level, debug_unit, err_act
integer(psb_ipk_), parameter :: ncmax=16
real(psb_dpk_) :: anorm, theta
real(psb_dpk_) :: tmp, alpha, beta, ommx
@ -169,13 +168,6 @@ subroutine mld_daggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_re
naggr = nlaggr(me+1)
ntaggr = sum(nlaggr)
allocate(nzbr(np), idisp(np),stat=info)
if (info /= psb_success_) then
info=psb_err_alloc_request_; ierr(1)=2*np;
call psb_errpush(info,name,i_err=ierr,a_err='integer')
goto 9999
end if
naggrm1 = sum(nlaggr(1:me))
naggrp1 = sum(nlaggr(1:me+1))
@ -199,6 +191,11 @@ subroutine mld_daggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_re
& call psb_realloc(ncol,adiag,info)
if (info == psb_success_) &
& call psb_halo(adiag,desc_a,info)
if (info == psb_success_) call a%cp_to_l(la)
if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='sp_getdiag')
goto 9999
end if
do i=1,size(adiag)
if (adiag(i) /= dzero) then
@ -208,10 +205,6 @@ subroutine mld_daggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_re
end if
end do
if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='sp_getdiag')
goto 9999
end if
! 1. Allocate Ptilde in sparse matrix form
@ -219,8 +212,8 @@ subroutine mld_daggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_re
call ptilde%mv_from(tmpcoo)
call ptilde%cscnv(info,type='csr')
if (info == psb_success_) call a%cscnv(am3,info,type='csr',dupl=psb_dupl_add_)
if (info == psb_success_) call a%cscnv(da,info,type='csr',dupl=psb_dupl_add_)
if (info == psb_success_) call la%cscnv(am3,info,type='csr',dupl=psb_dupl_add_)
if (info == psb_success_) call la%cscnv(da,info,type='csr',dupl=psb_dupl_add_)
if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='spcnv')
goto 9999
@ -231,11 +224,10 @@ subroutine mld_daggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_re
call da%scal(adinv,info)
call psb_symbmm(da,ptilde,dap,info)
if (info == psb_success_) call psb_numbmm(da,ptilde,dap)
call psb_spspmm(da,ptilde,dap,info)
if(info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='symbmm 1')
call psb_errpush(psb_err_from_subroutine_,name,a_err='spspmm 1')
goto 9999
end if
@ -246,8 +238,7 @@ subroutine mld_daggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_re
if (info == psb_success_) call psb_rwextd(ncol,atmp,info,b=am4)
if (info == psb_success_) call am4%free()
call psb_symbmm(da,atmp,dadap,info)
call psb_numbmm(da,atmp,dadap)
call psb_spspmm(da,atmp,dadap,info)
call atmp%free()
! !$ write(0,*) 'Columns of AP',psb_sp_get_ncols(ap)
@ -255,7 +246,6 @@ subroutine mld_daggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_re
call dap%mv_to(csc_dap)
call dadap%mv_to(csc_dadap)
call csc_mat_col_prod(csc_dap,csc_dadap,omp,info)
call csc_mat_col_prod(csc_dadap,csc_dadap,oden,info)
call psb_sum(ictxt,omp)
@ -293,7 +283,7 @@ subroutine mld_daggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_re
!
! Build the filtered matrix Af from A
!
call a%cscnv(acsrf,info,dupl=psb_dupl_add_)
call la%cscnv(acsrf,info,dupl=psb_dupl_add_)
do i=1,nrow
tmp = dzero
@ -333,23 +323,14 @@ subroutine mld_daggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_re
call af%mv_from(acsrf)
!
! Symbmm90 does the allocation for its result.
!
! op_prol = (I-w*D*Af)Ptilde
! Doing it this way means to consider diag(Af_i)
!
!
call psb_symbmm(af,ptilde,op_prol,info)
if(info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='symbmm 1')
goto 9999
end if
call psb_numbmm(af,ptilde,op_prol)
call psb_spspmm(af,ptilde,op_prol,info)
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'Done NUMBMM 1'
& 'Done SPSPMM 1'
else
!
! Build the smoothed prolongator using the original matrix
@ -369,19 +350,11 @@ subroutine mld_daggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_re
& write(debug_unit,*) me,' ',trim(name),&
& 'Done gather, going for SYMBMM 1'
!
! Symbmm90 does the allocation for its result.
!
! op_prol = (I-w*D*A)Ptilde
!
!
call psb_symbmm(am3,ptilde,op_prol,info)
if(info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='symbmm 1')
goto 9999
end if
call psb_numbmm(am3,ptilde,op_prol)
call psb_spspmm(am3,ptilde,op_prol,info)
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'Done NUMBMM 1'
@ -393,11 +366,11 @@ subroutine mld_daggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_re
! Ok, let's start over with the restrictor
!
call ptilde%transc(rtilde)
call a%cscnv(atmp,info,type='csr')
call la%cscnv(atmp,info,type='csr')
call psb_sphalo(atmp,desc_a,am4,info,&
& colcnv=.true.,rowscale=.true.)
nrt = am4%get_nrows()
call am4%csclip(atmp2,info,ione,nrt,ione,ncol)
call am4%csclip(atmp2,info,lone,nrt,lone,ncol)
call atmp2%cscnv(info,type='CSR')
if (info == psb_success_) call psb_rwextd(ncol,atmp,info,b=atmp2)
call am4%free()
@ -406,13 +379,12 @@ subroutine mld_daggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_re
! This is to compute the transpose. It ONLY works if the
! original A has a symmetric pattern.
call atmp%transc(atmp2)
call atmp2%csclip(dat,info,ione,nrow,ione,ncol)
call atmp2%csclip(dat,info,lone,nrow,lone,ncol)
call dat%cscnv(info,type='csr')
call dat%scal(adinv,info)
! Now for the product.
call psb_symbmm(dat,ptilde,datp,info)
if (info == psb_success_) call psb_numbmm(dat,ptilde,datp)
call psb_spspmm(dat,ptilde,datp,info)
call datp%clone(atmp2,info)
call psb_sphalo(atmp2,desc_a,am4,info,&
@ -490,8 +462,7 @@ subroutine mld_daggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_re
call rtilde%mv_from(tmpcoo)
call rtilde%cscnv(info,type='csr')
call psb_symbmm(rtilde,atmp,op_restr,info)
call psb_numbmm(rtilde,atmp,op_restr)
call psb_spspmm(rtilde,atmp,op_restr,info)
!
! Now we have to gather the halo of op_prol, and add it to itself
@ -533,16 +504,10 @@ subroutine mld_daggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_re
& write(debug_unit,*) me,' ',trim(name),&
& 'starting sphalo/ rwxtd'
call psb_symbmm(a,tmp_prol,am3,info)
if(info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,&
& a_err='symbmm 2')
goto 9999
end if
call psb_numbmm(a,tmp_prol,am3)
call psb_spspmm(la,tmp_prol,am3,info)
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'Done NUMBMM 2'
& 'Done SPSPMM 2'
call psb_sphalo(am3,desc_a,am4,info,&
& colcnv=.false.,rowscale=.true.)
@ -558,8 +523,7 @@ subroutine mld_daggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_re
& write(debug_unit,*) me,' ',trim(name),&
& 'Done sphalo/ rwxtd'
call psb_symbmm(op_restr,am3,ac,info)
if (info == psb_success_) call psb_numbmm(op_restr,am3,ac)
call psb_spspmm(op_restr,am3,ac,info)
if (info == psb_success_) call am3%free()
if (info == psb_success_) call ac%cscnv(info,type='coo',dupl=psb_dupl_add_)
@ -587,11 +551,11 @@ contains
subroutine csc_mat_col_prod(a,b,v,info)
implicit none
type(psb_d_csc_sparse_mat), intent(in) :: a, b
type(psb_ld_csc_sparse_mat), intent(in) :: a, b
real(psb_dpk_), intent(out) :: v(:)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: i,j,k, nr, nc,iap,nra,ibp,nrb
integer(psb_lpk_) :: i,j,k, nr, nc,iap,nra,ibp,nrb
info = psb_success_
nc = a%get_ncols()
@ -615,11 +579,11 @@ contains
subroutine csr_mat_row_prod(a,b,v,info)
implicit none
type(psb_d_csr_sparse_mat), intent(in) :: a, b
type(psb_ld_csr_sparse_mat), intent(in) :: a, b
real(psb_dpk_), intent(out) :: v(:)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: i,j,k, nr, nc,iap,nca,ibp,ncb
integer(psb_lpk_) :: i,j,k, nr, nc,iap,nca,ibp,ncb
info = psb_success_
nr = a%get_nrows()
@ -643,12 +607,12 @@ contains
function sparse_srtd_dot(nv1,iv1,v1,nv2,iv2,v2) result(dot)
implicit none
integer(psb_ipk_), intent(in) :: nv1,nv2
integer(psb_ipk_), intent(in) :: iv1(:), iv2(:)
integer(psb_lpk_), intent(in) :: nv1,nv2
integer(psb_lpk_), intent(in) :: iv1(:), iv2(:)
real(psb_dpk_), intent(in) :: v1(:),v2(:)
real(psb_dpk_) :: dot
integer(psb_ipk_) :: i,j,k, ip1, ip2
integer(psb_lpk_) :: i,j,k, ip1, ip2
dot = dzero
ip1 = 1
@ -671,7 +635,7 @@ contains
end function sparse_srtd_dot
subroutine local_dump(me,mat,name,header)
type(psb_dspmat_type), intent(in) :: mat
type(psb_ldspmat_type), intent(in) :: mat
integer(psb_ipk_), intent(in) :: me
character(len=*), intent(in) :: name
character(len=*), intent(in) :: header

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

@ -106,25 +106,26 @@ subroutine mld_daggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_re
! Arguments
type(psb_dspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(inout) :: ilaggr(:), nlaggr(:)
integer(psb_lpk_), intent(inout) :: ilaggr(:), nlaggr(:)
type(mld_dml_parms), intent(inout) :: parms
type(psb_dspmat_type), intent(inout) :: op_prol
type(psb_dspmat_type), intent(out) :: ac,op_restr
type(psb_ldspmat_type), intent(inout) :: op_prol
type(psb_ldspmat_type), intent(out) :: ac,op_restr
integer(psb_ipk_), intent(out) :: info
! Local variables
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ictxt,np,me, icomm, ndx, minfo
integer(psb_ipk_) :: ictxt, np, me, icomm, minfo
character(len=20) :: name
integer(psb_ipk_) :: ierr(5)
type(psb_d_coo_sparse_mat) :: ac_coo, tmpcoo
type(psb_d_csr_sparse_mat) :: acsr1, acsr2
integer(psb_ipk_) :: ierr(5)
type(psb_ldspmat_type) :: la
type(psb_ld_coo_sparse_mat) :: ac_coo, tmpcoo
type(psb_ld_csr_sparse_mat) :: acsr1, acsr2
integer(psb_ipk_) :: debug_level, debug_unit
integer(psb_ipk_) :: nrow, nglob, ncol, ntaggr, nzl, ip, &
integer(psb_lpk_) :: nrow, nglob, ncol, ntaggr, nzl, ip, &
& naggr, nzt, naggrm1, naggrp1, i, k
name='mld_aggrmat_nosmth_asb'
info=psb_success_
name = 'mld_aggrmat_nosmth_asb'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_; goto 9999
@ -137,24 +138,23 @@ subroutine mld_daggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_re
nrow = desc_a%get_local_rows()
ncol = desc_a%get_local_cols()
naggr = nlaggr(me+1)
ntaggr = sum(nlaggr)
naggrm1 = sum(nlaggr(1:me))
naggrp1 = sum(nlaggr(1:me+1))
call op_prol%cp_to(tmpcoo)
call op_prol%cscnv(info,type='csr',dupl=psb_dupl_add_)
call tmpcoo%transp()
nzl = tmpcoo%get_nzeros()
i=0
!
! Now we have to fix this. The only rows of tmpcoo/op_restr that are correct
! are those corresponding to "local" aggregates, i.e. indices in ilaggr(:)
!
do k=1, nzl
nzl = tmpcoo%get_nzeros()
i = 0
do k = 1, nzl
if ((naggrm1 < tmpcoo%ia(k)) .and.(tmpcoo%ia(k) <= naggrp1)) then
i = i+1
tmpcoo%val(i) = tmpcoo%val(k)
@ -169,11 +169,11 @@ subroutine mld_daggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_re
if (info /= psb_success_) goto 9999
call a%cp_to(ac_coo)
call a%cp_to_l(la)
call la%mv_to(ac_coo)
nzt = ac_coo%get_nzeros()
k = 0
do i=1, nzt
k = 0
do i = 1, nzt
k = k + 1
ac_coo%ia(k) = ilaggr(ac_coo%ia(i))
ac_coo%ja(k) = ilaggr(ac_coo%ja(i))

7
mlprec/impl/aggregator/mld_daggrmat_smth_asb.f90
Unescape Escape View File

@ -126,9 +126,9 @@ subroutine mld_daggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_rest
integer(psb_ipk_), intent(out) :: info
! Local variables
integer(psb_lpk_) :: nrow, nglob, ncol, ntaggr, ip, ndx,&
integer(psb_lpk_) :: nrow, nglob, ncol, ntaggr, ip, &
& naggr, nzl,naggrm1,naggrp1, i, j, k, jd, icolF, nrw
integer(psb_ipk_) ::ictxt, np, me
integer(psb_ipk_) :: ictxt, np, me
character(len=20) :: name
type(psb_ldspmat_type) :: la, am3, am4, tmp_prol
type(psb_ld_coo_sparse_mat) :: tmpcoo
@ -149,7 +149,6 @@ subroutine mld_daggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_rest
debug_unit = psb_get_debug_unit()
debug_level = psb_get_debug_level()
ictxt = desc_a%get_context()
ictxt = desc_a%get_context()
call psb_info(ictxt, me, np)
@ -201,7 +200,7 @@ subroutine mld_daggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_rest
!
if (info == psb_success_) call acsr3%cp_to_fmt(acsrf,info)
do i=1,nrow
do i=1, nrow
tmp = dzero
jd = -1
do j=acsrf%irp(i),acsrf%irp(i+1)-1

72
mlprec/impl/aggregator/mld_saggrmat_biz_asb.f90
Unescape Escape View File

@ -88,26 +88,26 @@ subroutine mld_saggrmat_biz_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_restr
implicit none
! Arguments
type(psb_sspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(inout) :: ilaggr(:), nlaggr(:)
type(mld_sml_parms), intent(inout) :: parms
type(psb_sspmat_type), intent(inout) :: op_prol
type(psb_sspmat_type), intent(out) :: ac,op_restr
integer(psb_ipk_), intent(out) :: info
type(psb_sspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_a
integer(psb_lpk_), intent(inout) :: ilaggr(:), nlaggr(:)
type(mld_sml_parms), intent(inout) :: parms
type(psb_lsspmat_type), intent(inout) :: op_prol
type(psb_lsspmat_type), intent(out) :: ac,op_restr
integer(psb_ipk_), intent(out) :: info
! Local variables
integer(psb_ipk_) :: nrow, nglob, ncol, ntaggr, ip, ndx,&
& naggr, nzl,naggrm1,naggrp1, i, j, k, jd, icolF, nrw, err_act
integer(psb_lpk_) :: nrow, nglob, ncol, ntaggr, ip, &
& naggr, nzl,naggrm1,naggrp1, i, j, k, jd, icolF, nrw
integer(psb_ipk_) ::ictxt, np, me
character(len=20) :: name
type(psb_sspmat_type) :: am3, am4,tmp_prol
type(psb_s_coo_sparse_mat) :: tmpcoo
type(psb_s_csr_sparse_mat) :: acsr1, acsr2, acsr3, acsrf, ptilde
type(psb_lsspmat_type) :: am3, am4,tmp_prol, la
type(psb_ls_coo_sparse_mat) :: tmpcoo
type(psb_ls_csr_sparse_mat) :: acsr1, acsr2, acsr3, acsrf, ptilde
real(psb_spk_), allocatable :: adiag(:)
integer(psb_ipk_) :: ierr(5)
logical :: filter_mat
integer(psb_ipk_) :: debug_level, debug_unit
integer(psb_ipk_) :: debug_level, debug_unit, err_act
integer(psb_ipk_), parameter :: ncmax=16
real(psb_spk_) :: anorm, omega, tmp, dg, theta
@ -130,10 +130,8 @@ subroutine mld_saggrmat_biz_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_restr
ncol = desc_a%get_local_cols()
theta = parms%aggr_thresh
naggr = nlaggr(me+1)
ntaggr = sum(nlaggr)
filter_mat = (parms%aggr_filter == mld_filter_mat_)
! naggr: number of local aggregates
@ -145,8 +143,8 @@ subroutine mld_saggrmat_biz_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_restr
& call psb_realloc(ncol,adiag,info)
if (info == psb_success_) &
& call psb_halo(adiag,desc_a,info)
if(info /= psb_success_) then
if (info == psb_success_) call a%cp_to_l(la)
if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='sp_getdiag')
goto 9999
end if
@ -154,7 +152,7 @@ subroutine mld_saggrmat_biz_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_restr
! 1. Allocate Ptilde in sparse matrix form
call op_prol%mv_to(tmpcoo)
call ptilde%mv_from_coo(tmpcoo,info)
if (info == psb_success_) call a%cscnv(acsr3,info,dupl=psb_dupl_add_)
if (info == psb_success_) call la%cscnv(acsr3,info,dupl=psb_dupl_add_)
if (info /= psb_success_) goto 9999
if (debug_level >= psb_debug_outer_) &
@ -165,9 +163,9 @@ subroutine mld_saggrmat_biz_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_restr
!
! Build the filtered matrix Af from A
!
if (info == psb_success_) call a%cscnv(acsrf,info,dupl=psb_dupl_add_)
if (info == psb_success_) call acsr3%cp_to_fmt(acsrf,info)
do i=1,nrow
do i=1, nrow
tmp = szero
jd = -1
do j=acsrf%irp(i),acsrf%irp(i+1)-1
@ -273,17 +271,15 @@ subroutine mld_saggrmat_biz_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_restr
! Doing it this way means to consider diag(Af_i)
!
!
call psb_symbmm(acsrf,ptilde,acsr1,info)
call psb_spspmm(acsrf,ptilde,acsr1,info)
if(info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='symbmm 1')
call psb_errpush(psb_err_from_subroutine_,name,a_err='spspmm 1')
goto 9999
end if
call psb_numbmm(acsrf,ptilde,acsr1)
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'Done NUMBMM 1'
& 'Done SPSPMM 1'
else
!
@ -309,17 +305,15 @@ subroutine mld_saggrmat_biz_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_restr
! Doing it this way means to consider diag(A_i)
!
!
call psb_symbmm(acsr3,ptilde,acsr1,info)
call psb_spspmm(acsr3,ptilde,acsr1,info)
if(info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='symbmm 1')
call psb_errpush(psb_err_from_subroutine_,name,a_err='spspmm 1')
goto 9999
end if
call psb_numbmm(acsr3,ptilde,acsr1)
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'Done NUMBMM 1'
& 'Done SPSPMM 1'
end if
call ptilde%free()
@ -333,16 +327,15 @@ subroutine mld_saggrmat_biz_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_restr
goto 9999
end if
call psb_symbmm(a,tmp_prol,am3,info)
call psb_spspmm(la,tmp_prol,am3,info)
if(info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='symbmm 2')
call psb_errpush(psb_err_from_subroutine_,name,a_err='spspmm 2')
goto 9999
end if
call psb_numbmm(a,tmp_prol,am3)
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'Done NUMBMM 2',parms%aggr_prol, mld_smooth_prol_
& 'Done SPSPMM 2',parms%aggr_prol, mld_smooth_prol_
call tmp_prol%transp(op_restr)
if (debug_level >= psb_debug_outer_) &
@ -355,23 +348,18 @@ subroutine mld_saggrmat_biz_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_restr
goto 9999
end if
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'starting symbmm 3'
call psb_symbmm(op_restr,am3,ac,info)
if (info == psb_success_) call psb_numbmm(op_restr,am3,ac)
& 'starting spspmm 3'
call psb_spspmm(op_restr,am3,ac,info)
if (info == psb_success_) call am3%free()
if (info == psb_success_) call ac%cscnv(info,type='coo',dupl=psb_dupl_add_)
if (info == psb_success_) call ac%cscnv(info,type='csr',dupl=psb_dupl_add_)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,a_err='Build b = op_restr x am3')
goto 9999
end if
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'Done smooth_aggregate '

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

@ -118,29 +118,28 @@ subroutine mld_saggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_re
! Arguments
type(psb_sspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(inout) :: ilaggr(:), nlaggr(:)
type(mld_sml_parms), intent(inout) :: parms
type(psb_sspmat_type), intent(inout) :: op_prol
type(psb_sspmat_type), intent(out) :: ac,op_restr
integer(psb_lpk_), intent(inout) :: ilaggr(:), nlaggr(:)
type(mld_sml_parms), intent(inout) :: parms
type(psb_lsspmat_type), intent(inout) :: op_prol
type(psb_lsspmat_type), intent(out) :: ac,op_restr
integer(psb_ipk_), intent(out) :: info
! Local variables
integer(psb_ipk_), allocatable :: nzbr(:), idisp(:)
integer(psb_ipk_) :: nrow, nglob, ncol, ntaggr, nzac, ip, ndx,&
& naggr, nzl,naggrm1,naggrp1, i, j, k, jd, icolF, nrt, err_act
integer(psb_lpk_) :: nrow, nglob, ncol, ntaggr, nzac, ip, ndx,&
& naggr, nzl,naggrm1,naggrp1, i, j, k, jd, icolF, nrt
integer(psb_ipk_) :: ictxt,np,me, icomm
character(len=20) :: name
type(psb_sspmat_type) :: af, ptilde, rtilde, atran, atp, atdatp
type(psb_sspmat_type) :: am3,am4, ap, adap,atmp,rada, ra, atmp2, dap, dadap, da
type(psb_sspmat_type) :: dat, datp, datdatp, atmp3, tmp_prol
type(psb_s_coo_sparse_mat) :: tmpcoo
type(psb_s_csr_sparse_mat) :: acsr1, acsr2, acsr3, acsr, acsrf
type(psb_s_csc_sparse_mat) :: csc_dap, csc_dadap, csc_datp, csc_datdatp, acsc
type(psb_lsspmat_type) :: la, af, ptilde, rtilde, atran, atp, atdatp
type(psb_lsspmat_type) :: am3,am4, ap, adap,atmp,rada, ra, atmp2, dap, dadap, da
type(psb_lsspmat_type) :: dat, datp, datdatp, atmp3, tmp_prol
type(psb_ls_coo_sparse_mat) :: tmpcoo
type(psb_ls_csr_sparse_mat) :: acsr1, acsr2, acsr3, acsr, acsrf
type(psb_ls_csc_sparse_mat) :: csc_dap, csc_dadap, csc_datp, csc_datdatp, acsc
real(psb_spk_), allocatable :: adiag(:), adinv(:)
real(psb_spk_), allocatable :: omf(:), omp(:), omi(:), oden(:)
logical :: filter_mat
integer(psb_ipk_) :: ierr(5)
integer(psb_ipk_) :: debug_level, debug_unit
integer(psb_ipk_) :: debug_level, debug_unit, err_act
integer(psb_ipk_), parameter :: ncmax=16
real(psb_spk_) :: anorm, theta
real(psb_spk_) :: tmp, alpha, beta, ommx
@ -169,13 +168,6 @@ subroutine mld_saggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_re
naggr = nlaggr(me+1)
ntaggr = sum(nlaggr)
allocate(nzbr(np), idisp(np),stat=info)
if (info /= psb_success_) then
info=psb_err_alloc_request_; ierr(1)=2*np;
call psb_errpush(info,name,i_err=ierr,a_err='integer')
goto 9999
end if
naggrm1 = sum(nlaggr(1:me))
naggrp1 = sum(nlaggr(1:me+1))
@ -199,6 +191,11 @@ subroutine mld_saggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_re
& call psb_realloc(ncol,adiag,info)
if (info == psb_success_) &
& call psb_halo(adiag,desc_a,info)
if (info == psb_success_) call a%cp_to_l(la)
if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='sp_getdiag')
goto 9999
end if
do i=1,size(adiag)
if (adiag(i) /= szero) then
@ -208,10 +205,6 @@ subroutine mld_saggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_re
end if
end do
if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='sp_getdiag')
goto 9999
end if
! 1. Allocate Ptilde in sparse matrix form
@ -219,8 +212,8 @@ subroutine mld_saggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_re
call ptilde%mv_from(tmpcoo)
call ptilde%cscnv(info,type='csr')
if (info == psb_success_) call a%cscnv(am3,info,type='csr',dupl=psb_dupl_add_)
if (info == psb_success_) call a%cscnv(da,info,type='csr',dupl=psb_dupl_add_)
if (info == psb_success_) call la%cscnv(am3,info,type='csr',dupl=psb_dupl_add_)
if (info == psb_success_) call la%cscnv(da,info,type='csr',dupl=psb_dupl_add_)
if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='spcnv')
goto 9999
@ -231,11 +224,10 @@ subroutine mld_saggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_re
call da%scal(adinv,info)
call psb_symbmm(da,ptilde,dap,info)
if (info == psb_success_) call psb_numbmm(da,ptilde,dap)
call psb_spspmm(da,ptilde,dap,info)
if(info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='symbmm 1')
call psb_errpush(psb_err_from_subroutine_,name,a_err='spspmm 1')
goto 9999
end if
@ -246,8 +238,7 @@ subroutine mld_saggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_re
if (info == psb_success_) call psb_rwextd(ncol,atmp,info,b=am4)
if (info == psb_success_) call am4%free()
call psb_symbmm(da,atmp,dadap,info)
call psb_numbmm(da,atmp,dadap)
call psb_spspmm(da,atmp,dadap,info)
call atmp%free()
! !$ write(0,*) 'Columns of AP',psb_sp_get_ncols(ap)
@ -255,7 +246,6 @@ subroutine mld_saggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_re
call dap%mv_to(csc_dap)
call dadap%mv_to(csc_dadap)
call csc_mat_col_prod(csc_dap,csc_dadap,omp,info)
call csc_mat_col_prod(csc_dadap,csc_dadap,oden,info)
call psb_sum(ictxt,omp)
@ -293,7 +283,7 @@ subroutine mld_saggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_re
!
! Build the filtered matrix Af from A
!
call a%cscnv(acsrf,info,dupl=psb_dupl_add_)
call la%cscnv(acsrf,info,dupl=psb_dupl_add_)
do i=1,nrow
tmp = szero
@ -333,23 +323,14 @@ subroutine mld_saggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_re
call af%mv_from(acsrf)
!
! Symbmm90 does the allocation for its result.
!
! op_prol = (I-w*D*Af)Ptilde
! Doing it this way means to consider diag(Af_i)
!
!
call psb_symbmm(af,ptilde,op_prol,info)
if(info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='symbmm 1')
goto 9999
end if
call psb_numbmm(af,ptilde,op_prol)
call psb_spspmm(af,ptilde,op_prol,info)
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'Done NUMBMM 1'
& 'Done SPSPMM 1'
else
!
! Build the smoothed prolongator using the original matrix
@ -369,19 +350,11 @@ subroutine mld_saggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_re
& write(debug_unit,*) me,' ',trim(name),&
& 'Done gather, going for SYMBMM 1'
!
! Symbmm90 does the allocation for its result.
!
! op_prol = (I-w*D*A)Ptilde
!
!
call psb_symbmm(am3,ptilde,op_prol,info)
if(info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='symbmm 1')
goto 9999
end if
call psb_numbmm(am3,ptilde,op_prol)
call psb_spspmm(am3,ptilde,op_prol,info)
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'Done NUMBMM 1'
@ -393,11 +366,11 @@ subroutine mld_saggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_re
! Ok, let's start over with the restrictor
!
call ptilde%transc(rtilde)
call a%cscnv(atmp,info,type='csr')
call la%cscnv(atmp,info,type='csr')
call psb_sphalo(atmp,desc_a,am4,info,&
& colcnv=.true.,rowscale=.true.)
nrt = am4%get_nrows()
call am4%csclip(atmp2,info,ione,nrt,ione,ncol)
call am4%csclip(atmp2,info,lone,nrt,lone,ncol)
call atmp2%cscnv(info,type='CSR')
if (info == psb_success_) call psb_rwextd(ncol,atmp,info,b=atmp2)
call am4%free()
@ -406,13 +379,12 @@ subroutine mld_saggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_re
! This is to compute the transpose. It ONLY works if the
! original A has a symmetric pattern.
call atmp%transc(atmp2)
call atmp2%csclip(dat,info,ione,nrow,ione,ncol)
call atmp2%csclip(dat,info,lone,nrow,lone,ncol)
call dat%cscnv(info,type='csr')
call dat%scal(adinv,info)
! Now for the product.
call psb_symbmm(dat,ptilde,datp,info)
if (info == psb_success_) call psb_numbmm(dat,ptilde,datp)
call psb_spspmm(dat,ptilde,datp,info)
call datp%clone(atmp2,info)
call psb_sphalo(atmp2,desc_a,am4,info,&
@ -490,8 +462,7 @@ subroutine mld_saggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_re
call rtilde%mv_from(tmpcoo)
call rtilde%cscnv(info,type='csr')
call psb_symbmm(rtilde,atmp,op_restr,info)
call psb_numbmm(rtilde,atmp,op_restr)
call psb_spspmm(rtilde,atmp,op_restr,info)
!
! Now we have to gather the halo of op_prol, and add it to itself
@ -533,16 +504,10 @@ subroutine mld_saggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_re
& write(debug_unit,*) me,' ',trim(name),&
& 'starting sphalo/ rwxtd'
call psb_symbmm(a,tmp_prol,am3,info)
if(info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,&
& a_err='symbmm 2')
goto 9999
end if
call psb_numbmm(a,tmp_prol,am3)
call psb_spspmm(la,tmp_prol,am3,info)
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'Done NUMBMM 2'
& 'Done SPSPMM 2'
call psb_sphalo(am3,desc_a,am4,info,&
& colcnv=.false.,rowscale=.true.)
@ -558,8 +523,7 @@ subroutine mld_saggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_re
& write(debug_unit,*) me,' ',trim(name),&
& 'Done sphalo/ rwxtd'
call psb_symbmm(op_restr,am3,ac,info)
if (info == psb_success_) call psb_numbmm(op_restr,am3,ac)
call psb_spspmm(op_restr,am3,ac,info)
if (info == psb_success_) call am3%free()
if (info == psb_success_) call ac%cscnv(info,type='coo',dupl=psb_dupl_add_)
@ -587,11 +551,11 @@ contains
subroutine csc_mat_col_prod(a,b,v,info)
implicit none
type(psb_s_csc_sparse_mat), intent(in) :: a, b
type(psb_ls_csc_sparse_mat), intent(in) :: a, b
real(psb_spk_), intent(out) :: v(:)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: i,j,k, nr, nc,iap,nra,ibp,nrb
integer(psb_lpk_) :: i,j,k, nr, nc,iap,nra,ibp,nrb
info = psb_success_
nc = a%get_ncols()
@ -615,11 +579,11 @@ contains
subroutine csr_mat_row_prod(a,b,v,info)
implicit none
type(psb_s_csr_sparse_mat), intent(in) :: a, b
type(psb_ls_csr_sparse_mat), intent(in) :: a, b
real(psb_spk_), intent(out) :: v(:)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: i,j,k, nr, nc,iap,nca,ibp,ncb
integer(psb_lpk_) :: i,j,k, nr, nc,iap,nca,ibp,ncb
info = psb_success_
nr = a%get_nrows()
@ -643,12 +607,12 @@ contains
function sparse_srtd_dot(nv1,iv1,v1,nv2,iv2,v2) result(dot)
implicit none
integer(psb_ipk_), intent(in) :: nv1,nv2
integer(psb_ipk_), intent(in) :: iv1(:), iv2(:)
integer(psb_lpk_), intent(in) :: nv1,nv2
integer(psb_lpk_), intent(in) :: iv1(:), iv2(:)
real(psb_spk_), intent(in) :: v1(:),v2(:)
real(psb_spk_) :: dot
integer(psb_ipk_) :: i,j,k, ip1, ip2
integer(psb_lpk_) :: i,j,k, ip1, ip2
dot = szero
ip1 = 1
@ -671,7 +635,7 @@ contains
end function sparse_srtd_dot
subroutine local_dump(me,mat,name,header)
type(psb_sspmat_type), intent(in) :: mat
type(psb_lsspmat_type), intent(in) :: mat
integer(psb_ipk_), intent(in) :: me
character(len=*), intent(in) :: name
character(len=*), intent(in) :: header

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

@ -106,25 +106,26 @@ subroutine mld_saggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_re
! Arguments
type(psb_sspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(inout) :: ilaggr(:), nlaggr(:)
integer(psb_lpk_), intent(inout) :: ilaggr(:), nlaggr(:)
type(mld_sml_parms), intent(inout) :: parms
type(psb_sspmat_type), intent(inout) :: op_prol
type(psb_sspmat_type), intent(out) :: ac,op_restr
type(psb_lsspmat_type), intent(inout) :: op_prol
type(psb_lsspmat_type), intent(out) :: ac,op_restr
integer(psb_ipk_), intent(out) :: info
! Local variables
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ictxt,np,me, icomm, ndx, minfo
integer(psb_ipk_) :: ictxt, np, me, icomm, minfo
character(len=20) :: name
integer(psb_ipk_) :: ierr(5)
type(psb_s_coo_sparse_mat) :: ac_coo, tmpcoo
type(psb_s_csr_sparse_mat) :: acsr1, acsr2
integer(psb_ipk_) :: ierr(5)
type(psb_lsspmat_type) :: la
type(psb_ls_coo_sparse_mat) :: ac_coo, tmpcoo
type(psb_ls_csr_sparse_mat) :: acsr1, acsr2
integer(psb_ipk_) :: debug_level, debug_unit
integer(psb_ipk_) :: nrow, nglob, ncol, ntaggr, nzl, ip, &
integer(psb_lpk_) :: nrow, nglob, ncol, ntaggr, nzl, ip, &
& naggr, nzt, naggrm1, naggrp1, i, k
name='mld_aggrmat_nosmth_asb'
info=psb_success_
name = 'mld_aggrmat_nosmth_asb'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_; goto 9999
@ -137,24 +138,23 @@ subroutine mld_saggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_re
nrow = desc_a%get_local_rows()
ncol = desc_a%get_local_cols()
naggr = nlaggr(me+1)
ntaggr = sum(nlaggr)
naggrm1 = sum(nlaggr(1:me))
naggrp1 = sum(nlaggr(1:me+1))
call op_prol%cp_to(tmpcoo)
call op_prol%cscnv(info,type='csr',dupl=psb_dupl_add_)
call tmpcoo%transp()
nzl = tmpcoo%get_nzeros()
i=0
!
! Now we have to fix this. The only rows of tmpcoo/op_restr that are correct
! are those corresponding to "local" aggregates, i.e. indices in ilaggr(:)
!
do k=1, nzl
nzl = tmpcoo%get_nzeros()
i = 0
do k = 1, nzl
if ((naggrm1 < tmpcoo%ia(k)) .and.(tmpcoo%ia(k) <= naggrp1)) then
i = i+1
tmpcoo%val(i) = tmpcoo%val(k)
@ -169,11 +169,11 @@ subroutine mld_saggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_re
if (info /= psb_success_) goto 9999
call a%cp_to(ac_coo)
call a%cp_to_l(la)
call la%mv_to(ac_coo)
nzt = ac_coo%get_nzeros()
k = 0
do i=1, nzt
k = 0
do i = 1, nzt
k = k + 1
ac_coo%ia(k) = ilaggr(ac_coo%ia(i))
ac_coo%ja(k) = ilaggr(ac_coo%ja(i))

7
mlprec/impl/aggregator/mld_saggrmat_smth_asb.f90
Unescape Escape View File

@ -126,9 +126,9 @@ subroutine mld_saggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_rest
integer(psb_ipk_), intent(out) :: info
! Local variables
integer(psb_lpk_) :: nrow, nglob, ncol, ntaggr, ip, ndx,&
integer(psb_lpk_) :: nrow, nglob, ncol, ntaggr, ip, &
& naggr, nzl,naggrm1,naggrp1, i, j, k, jd, icolF, nrw
integer(psb_ipk_) ::ictxt, np, me
integer(psb_ipk_) :: ictxt, np, me
character(len=20) :: name
type(psb_lsspmat_type) :: la, am3, am4, tmp_prol
type(psb_ls_coo_sparse_mat) :: tmpcoo
@ -149,7 +149,6 @@ subroutine mld_saggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_rest
debug_unit = psb_get_debug_unit()
debug_level = psb_get_debug_level()
ictxt = desc_a%get_context()
ictxt = desc_a%get_context()
call psb_info(ictxt, me, np)
@ -201,7 +200,7 @@ subroutine mld_saggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_rest
!
if (info == psb_success_) call acsr3%cp_to_fmt(acsrf,info)
do i=1,nrow
do i=1, nrow
tmp = szero
jd = -1
do j=acsrf%irp(i),acsrf%irp(i+1)-1

72
mlprec/impl/aggregator/mld_zaggrmat_biz_asb.f90
Unescape Escape View File

@ -88,26 +88,26 @@ subroutine mld_zaggrmat_biz_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_restr
implicit none
! Arguments
type(psb_zspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(inout) :: ilaggr(:), nlaggr(:)
type(mld_dml_parms), intent(inout) :: parms
type(psb_zspmat_type), intent(inout) :: op_prol
type(psb_zspmat_type), intent(out) :: ac,op_restr
integer(psb_ipk_), intent(out) :: info
type(psb_zspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_a
integer(psb_lpk_), intent(inout) :: ilaggr(:), nlaggr(:)
type(mld_dml_parms), intent(inout) :: parms
type(psb_lzspmat_type), intent(inout) :: op_prol
type(psb_lzspmat_type), intent(out) :: ac,op_restr
integer(psb_ipk_), intent(out) :: info
! Local variables
integer(psb_ipk_) :: nrow, nglob, ncol, ntaggr, ip, ndx,&
& naggr, nzl,naggrm1,naggrp1, i, j, k, jd, icolF, nrw, err_act
integer(psb_lpk_) :: nrow, nglob, ncol, ntaggr, ip, &
& naggr, nzl,naggrm1,naggrp1, i, j, k, jd, icolF, nrw
integer(psb_ipk_) ::ictxt, np, me
character(len=20) :: name
type(psb_zspmat_type) :: am3, am4,tmp_prol
type(psb_z_coo_sparse_mat) :: tmpcoo
type(psb_z_csr_sparse_mat) :: acsr1, acsr2, acsr3, acsrf, ptilde
type(psb_lzspmat_type) :: am3, am4,tmp_prol, la
type(psb_lz_coo_sparse_mat) :: tmpcoo
type(psb_lz_csr_sparse_mat) :: acsr1, acsr2, acsr3, acsrf, ptilde
complex(psb_dpk_), allocatable :: adiag(:)
integer(psb_ipk_) :: ierr(5)
logical :: filter_mat
integer(psb_ipk_) :: debug_level, debug_unit
integer(psb_ipk_) :: debug_level, debug_unit, err_act
integer(psb_ipk_), parameter :: ncmax=16
real(psb_dpk_) :: anorm, omega, tmp, dg, theta
@ -130,10 +130,8 @@ subroutine mld_zaggrmat_biz_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_restr
ncol = desc_a%get_local_cols()
theta = parms%aggr_thresh
naggr = nlaggr(me+1)
ntaggr = sum(nlaggr)
filter_mat = (parms%aggr_filter == mld_filter_mat_)
! naggr: number of local aggregates
@ -145,8 +143,8 @@ subroutine mld_zaggrmat_biz_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_restr
& call psb_realloc(ncol,adiag,info)
if (info == psb_success_) &
& call psb_halo(adiag,desc_a,info)
if(info /= psb_success_) then
if (info == psb_success_) call a%cp_to_l(la)
if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='sp_getdiag')
goto 9999
end if
@ -154,7 +152,7 @@ subroutine mld_zaggrmat_biz_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_restr
! 1. Allocate Ptilde in sparse matrix form
call op_prol%mv_to(tmpcoo)
call ptilde%mv_from_coo(tmpcoo,info)
if (info == psb_success_) call a%cscnv(acsr3,info,dupl=psb_dupl_add_)
if (info == psb_success_) call la%cscnv(acsr3,info,dupl=psb_dupl_add_)
if (info /= psb_success_) goto 9999
if (debug_level >= psb_debug_outer_) &
@ -165,9 +163,9 @@ subroutine mld_zaggrmat_biz_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_restr
!
! Build the filtered matrix Af from A
!
if (info == psb_success_) call a%cscnv(acsrf,info,dupl=psb_dupl_add_)
if (info == psb_success_) call acsr3%cp_to_fmt(acsrf,info)
do i=1,nrow
do i=1, nrow
tmp = zzero
jd = -1
do j=acsrf%irp(i),acsrf%irp(i+1)-1
@ -273,17 +271,15 @@ subroutine mld_zaggrmat_biz_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_restr
! Doing it this way means to consider diag(Af_i)
!
!
call psb_symbmm(acsrf,ptilde,acsr1,info)
call psb_spspmm(acsrf,ptilde,acsr1,info)
if(info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='symbmm 1')
call psb_errpush(psb_err_from_subroutine_,name,a_err='spspmm 1')
goto 9999
end if
call psb_numbmm(acsrf,ptilde,acsr1)
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'Done NUMBMM 1'
& 'Done SPSPMM 1'
else
!
@ -309,17 +305,15 @@ subroutine mld_zaggrmat_biz_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_restr
! Doing it this way means to consider diag(A_i)
!
!
call psb_symbmm(acsr3,ptilde,acsr1,info)
call psb_spspmm(acsr3,ptilde,acsr1,info)
if(info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='symbmm 1')
call psb_errpush(psb_err_from_subroutine_,name,a_err='spspmm 1')
goto 9999
end if
call psb_numbmm(acsr3,ptilde,acsr1)
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'Done NUMBMM 1'
& 'Done SPSPMM 1'
end if
call ptilde%free()
@ -333,16 +327,15 @@ subroutine mld_zaggrmat_biz_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_restr
goto 9999
end if
call psb_symbmm(a,tmp_prol,am3,info)
call psb_spspmm(la,tmp_prol,am3,info)
if(info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='symbmm 2')
call psb_errpush(psb_err_from_subroutine_,name,a_err='spspmm 2')
goto 9999
end if
call psb_numbmm(a,tmp_prol,am3)
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'Done NUMBMM 2',parms%aggr_prol, mld_smooth_prol_
& 'Done SPSPMM 2',parms%aggr_prol, mld_smooth_prol_
call tmp_prol%transp(op_restr)
if (debug_level >= psb_debug_outer_) &
@ -355,23 +348,18 @@ subroutine mld_zaggrmat_biz_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_restr
goto 9999
end if
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'starting symbmm 3'
call psb_symbmm(op_restr,am3,ac,info)
if (info == psb_success_) call psb_numbmm(op_restr,am3,ac)
& 'starting spspmm 3'
call psb_spspmm(op_restr,am3,ac,info)
if (info == psb_success_) call am3%free()
if (info == psb_success_) call ac%cscnv(info,type='coo',dupl=psb_dupl_add_)
if (info == psb_success_) call ac%cscnv(info,type='csr',dupl=psb_dupl_add_)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,a_err='Build b = op_restr x am3')
goto 9999
end if
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'Done smooth_aggregate '

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

@ -118,29 +118,28 @@ subroutine mld_zaggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_re
! Arguments
type(psb_zspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(inout) :: ilaggr(:), nlaggr(:)
type(mld_dml_parms), intent(inout) :: parms
type(psb_zspmat_type), intent(inout) :: op_prol
type(psb_zspmat_type), intent(out) :: ac,op_restr
integer(psb_lpk_), intent(inout) :: ilaggr(:), nlaggr(:)
type(mld_dml_parms), intent(inout) :: parms
type(psb_lzspmat_type), intent(inout) :: op_prol
type(psb_lzspmat_type), intent(out) :: ac,op_restr
integer(psb_ipk_), intent(out) :: info
! Local variables
integer(psb_ipk_), allocatable :: nzbr(:), idisp(:)
integer(psb_ipk_) :: nrow, nglob, ncol, ntaggr, nzac, ip, ndx,&
& naggr, nzl,naggrm1,naggrp1, i, j, k, jd, icolF, nrt, err_act
integer(psb_lpk_) :: nrow, nglob, ncol, ntaggr, nzac, ip, ndx,&
& naggr, nzl,naggrm1,naggrp1, i, j, k, jd, icolF, nrt
integer(psb_ipk_) :: ictxt,np,me, icomm
character(len=20) :: name
type(psb_zspmat_type) :: af, ptilde, rtilde, atran, atp, atdatp
type(psb_zspmat_type) :: am3,am4, ap, adap,atmp,rada, ra, atmp2, dap, dadap, da
type(psb_zspmat_type) :: dat, datp, datdatp, atmp3, tmp_prol
type(psb_z_coo_sparse_mat) :: tmpcoo
type(psb_z_csr_sparse_mat) :: acsr1, acsr2, acsr3, acsr, acsrf
type(psb_z_csc_sparse_mat) :: csc_dap, csc_dadap, csc_datp, csc_datdatp, acsc
type(psb_lzspmat_type) :: la, af, ptilde, rtilde, atran, atp, atdatp
type(psb_lzspmat_type) :: am3,am4, ap, adap,atmp,rada, ra, atmp2, dap, dadap, da
type(psb_lzspmat_type) :: dat, datp, datdatp, atmp3, tmp_prol
type(psb_lz_coo_sparse_mat) :: tmpcoo
type(psb_lz_csr_sparse_mat) :: acsr1, acsr2, acsr3, acsr, acsrf
type(psb_lz_csc_sparse_mat) :: csc_dap, csc_dadap, csc_datp, csc_datdatp, acsc
complex(psb_dpk_), allocatable :: adiag(:), adinv(:)
complex(psb_dpk_), allocatable :: omf(:), omp(:), omi(:), oden(:)
logical :: filter_mat
integer(psb_ipk_) :: ierr(5)
integer(psb_ipk_) :: debug_level, debug_unit
integer(psb_ipk_) :: debug_level, debug_unit, err_act
integer(psb_ipk_), parameter :: ncmax=16
real(psb_dpk_) :: anorm, theta
complex(psb_dpk_) :: tmp, alpha, beta, ommx
@ -169,13 +168,6 @@ subroutine mld_zaggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_re
naggr = nlaggr(me+1)
ntaggr = sum(nlaggr)
allocate(nzbr(np), idisp(np),stat=info)
if (info /= psb_success_) then
info=psb_err_alloc_request_; ierr(1)=2*np;
call psb_errpush(info,name,i_err=ierr,a_err='integer')
goto 9999
end if
naggrm1 = sum(nlaggr(1:me))
naggrp1 = sum(nlaggr(1:me+1))
@ -199,6 +191,11 @@ subroutine mld_zaggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_re
& call psb_realloc(ncol,adiag,info)
if (info == psb_success_) &
& call psb_halo(adiag,desc_a,info)
if (info == psb_success_) call a%cp_to_l(la)
if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='sp_getdiag')
goto 9999
end if
do i=1,size(adiag)
if (adiag(i) /= zzero) then
@ -208,10 +205,6 @@ subroutine mld_zaggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_re
end if
end do
if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='sp_getdiag')
goto 9999
end if
! 1. Allocate Ptilde in sparse matrix form
@ -219,8 +212,8 @@ subroutine mld_zaggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_re
call ptilde%mv_from(tmpcoo)
call ptilde%cscnv(info,type='csr')
if (info == psb_success_) call a%cscnv(am3,info,type='csr',dupl=psb_dupl_add_)
if (info == psb_success_) call a%cscnv(da,info,type='csr',dupl=psb_dupl_add_)
if (info == psb_success_) call la%cscnv(am3,info,type='csr',dupl=psb_dupl_add_)
if (info == psb_success_) call la%cscnv(da,info,type='csr',dupl=psb_dupl_add_)
if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='spcnv')
goto 9999
@ -231,11 +224,10 @@ subroutine mld_zaggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_re
call da%scal(adinv,info)
call psb_symbmm(da,ptilde,dap,info)
if (info == psb_success_) call psb_numbmm(da,ptilde,dap)
call psb_spspmm(da,ptilde,dap,info)
if(info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='symbmm 1')
call psb_errpush(psb_err_from_subroutine_,name,a_err='spspmm 1')
goto 9999
end if
@ -246,8 +238,7 @@ subroutine mld_zaggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_re
if (info == psb_success_) call psb_rwextd(ncol,atmp,info,b=am4)
if (info == psb_success_) call am4%free()
call psb_symbmm(da,atmp,dadap,info)
call psb_numbmm(da,atmp,dadap)
call psb_spspmm(da,atmp,dadap,info)
call atmp%free()
! !$ write(0,*) 'Columns of AP',psb_sp_get_ncols(ap)
@ -255,7 +246,6 @@ subroutine mld_zaggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_re
call dap%mv_to(csc_dap)
call dadap%mv_to(csc_dadap)
call csc_mat_col_prod(csc_dap,csc_dadap,omp,info)
call csc_mat_col_prod(csc_dadap,csc_dadap,oden,info)
call psb_sum(ictxt,omp)
@ -293,7 +283,7 @@ subroutine mld_zaggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_re
!
! Build the filtered matrix Af from A
!
call a%cscnv(acsrf,info,dupl=psb_dupl_add_)
call la%cscnv(acsrf,info,dupl=psb_dupl_add_)
do i=1,nrow
tmp = zzero
@ -333,23 +323,14 @@ subroutine mld_zaggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_re
call af%mv_from(acsrf)
!
! Symbmm90 does the allocation for its result.
!
! op_prol = (I-w*D*Af)Ptilde
! Doing it this way means to consider diag(Af_i)
!
!
call psb_symbmm(af,ptilde,op_prol,info)
if(info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='symbmm 1')
goto 9999
end if
call psb_numbmm(af,ptilde,op_prol)
call psb_spspmm(af,ptilde,op_prol,info)
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'Done NUMBMM 1'
& 'Done SPSPMM 1'
else
!
! Build the smoothed prolongator using the original matrix
@ -369,19 +350,11 @@ subroutine mld_zaggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_re
& write(debug_unit,*) me,' ',trim(name),&
& 'Done gather, going for SYMBMM 1'
!
! Symbmm90 does the allocation for its result.
!
! op_prol = (I-w*D*A)Ptilde
!
!
call psb_symbmm(am3,ptilde,op_prol,info)
if(info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='symbmm 1')
goto 9999
end if
call psb_numbmm(am3,ptilde,op_prol)
call psb_spspmm(am3,ptilde,op_prol,info)
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'Done NUMBMM 1'
@ -393,11 +366,11 @@ subroutine mld_zaggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_re
! Ok, let's start over with the restrictor
!
call ptilde%transc(rtilde)
call a%cscnv(atmp,info,type='csr')
call la%cscnv(atmp,info,type='csr')
call psb_sphalo(atmp,desc_a,am4,info,&
& colcnv=.true.,rowscale=.true.)
nrt = am4%get_nrows()
call am4%csclip(atmp2,info,ione,nrt,ione,ncol)
call am4%csclip(atmp2,info,lone,nrt,lone,ncol)
call atmp2%cscnv(info,type='CSR')
if (info == psb_success_) call psb_rwextd(ncol,atmp,info,b=atmp2)
call am4%free()
@ -406,13 +379,12 @@ subroutine mld_zaggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_re
! This is to compute the transpose. It ONLY works if the
! original A has a symmetric pattern.
call atmp%transc(atmp2)
call atmp2%csclip(dat,info,ione,nrow,ione,ncol)
call atmp2%csclip(dat,info,lone,nrow,lone,ncol)
call dat%cscnv(info,type='csr')
call dat%scal(adinv,info)
! Now for the product.
call psb_symbmm(dat,ptilde,datp,info)
if (info == psb_success_) call psb_numbmm(dat,ptilde,datp)
call psb_spspmm(dat,ptilde,datp,info)
call datp%clone(atmp2,info)
call psb_sphalo(atmp2,desc_a,am4,info,&
@ -490,8 +462,7 @@ subroutine mld_zaggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_re
call rtilde%mv_from(tmpcoo)
call rtilde%cscnv(info,type='csr')
call psb_symbmm(rtilde,atmp,op_restr,info)
call psb_numbmm(rtilde,atmp,op_restr)
call psb_spspmm(rtilde,atmp,op_restr,info)
!
! Now we have to gather the halo of op_prol, and add it to itself
@ -533,16 +504,10 @@ subroutine mld_zaggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_re
& write(debug_unit,*) me,' ',trim(name),&
& 'starting sphalo/ rwxtd'
call psb_symbmm(a,tmp_prol,am3,info)
if(info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,&
& a_err='symbmm 2')
goto 9999
end if
call psb_numbmm(a,tmp_prol,am3)
call psb_spspmm(la,tmp_prol,am3,info)
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'Done NUMBMM 2'
& 'Done SPSPMM 2'
call psb_sphalo(am3,desc_a,am4,info,&
& colcnv=.false.,rowscale=.true.)
@ -558,8 +523,7 @@ subroutine mld_zaggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_re
& write(debug_unit,*) me,' ',trim(name),&
& 'Done sphalo/ rwxtd'
call psb_symbmm(op_restr,am3,ac,info)
if (info == psb_success_) call psb_numbmm(op_restr,am3,ac)
call psb_spspmm(op_restr,am3,ac,info)
if (info == psb_success_) call am3%free()
if (info == psb_success_) call ac%cscnv(info,type='coo',dupl=psb_dupl_add_)
@ -587,11 +551,11 @@ contains
subroutine csc_mat_col_prod(a,b,v,info)
implicit none
type(psb_z_csc_sparse_mat), intent(in) :: a, b
type(psb_lz_csc_sparse_mat), intent(in) :: a, b
complex(psb_dpk_), intent(out) :: v(:)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: i,j,k, nr, nc,iap,nra,ibp,nrb
integer(psb_lpk_) :: i,j,k, nr, nc,iap,nra,ibp,nrb
info = psb_success_
nc = a%get_ncols()
@ -615,11 +579,11 @@ contains
subroutine csr_mat_row_prod(a,b,v,info)
implicit none
type(psb_z_csr_sparse_mat), intent(in) :: a, b
type(psb_lz_csr_sparse_mat), intent(in) :: a, b
complex(psb_dpk_), intent(out) :: v(:)
integer(psb_ipk_), intent(out) :: info
integer(psb_ipk_) :: i,j,k, nr, nc,iap,nca,ibp,ncb
integer(psb_lpk_) :: i,j,k, nr, nc,iap,nca,ibp,ncb
info = psb_success_
nr = a%get_nrows()
@ -643,12 +607,12 @@ contains
function sparse_srtd_dot(nv1,iv1,v1,nv2,iv2,v2) result(dot)
implicit none
integer(psb_ipk_), intent(in) :: nv1,nv2
integer(psb_ipk_), intent(in) :: iv1(:), iv2(:)
integer(psb_lpk_), intent(in) :: nv1,nv2
integer(psb_lpk_), intent(in) :: iv1(:), iv2(:)
complex(psb_dpk_), intent(in) :: v1(:),v2(:)
complex(psb_dpk_) :: dot
integer(psb_ipk_) :: i,j,k, ip1, ip2
integer(psb_lpk_) :: i,j,k, ip1, ip2
dot = zzero
ip1 = 1
@ -671,7 +635,7 @@ contains
end function sparse_srtd_dot
subroutine local_dump(me,mat,name,header)
type(psb_zspmat_type), intent(in) :: mat
type(psb_lzspmat_type), intent(in) :: mat
integer(psb_ipk_), intent(in) :: me
character(len=*), intent(in) :: name
character(len=*), intent(in) :: header

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

@ -106,25 +106,26 @@ subroutine mld_zaggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_re
! Arguments
type(psb_zspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_a
integer(psb_ipk_), intent(inout) :: ilaggr(:), nlaggr(:)
integer(psb_lpk_), intent(inout) :: ilaggr(:), nlaggr(:)
type(mld_dml_parms), intent(inout) :: parms
type(psb_zspmat_type), intent(inout) :: op_prol
type(psb_zspmat_type), intent(out) :: ac,op_restr
type(psb_lzspmat_type), intent(inout) :: op_prol
type(psb_lzspmat_type), intent(out) :: ac,op_restr
integer(psb_ipk_), intent(out) :: info
! Local variables
integer(psb_ipk_) :: err_act
integer(psb_ipk_) :: ictxt,np,me, icomm, ndx, minfo
integer(psb_ipk_) :: ictxt, np, me, icomm, minfo
character(len=20) :: name
integer(psb_ipk_) :: ierr(5)
type(psb_z_coo_sparse_mat) :: ac_coo, tmpcoo
type(psb_z_csr_sparse_mat) :: acsr1, acsr2
integer(psb_ipk_) :: ierr(5)
type(psb_lzspmat_type) :: la
type(psb_lz_coo_sparse_mat) :: ac_coo, tmpcoo
type(psb_lz_csr_sparse_mat) :: acsr1, acsr2
integer(psb_ipk_) :: debug_level, debug_unit
integer(psb_ipk_) :: nrow, nglob, ncol, ntaggr, nzl, ip, &
integer(psb_lpk_) :: nrow, nglob, ncol, ntaggr, nzl, ip, &
& naggr, nzt, naggrm1, naggrp1, i, k
name='mld_aggrmat_nosmth_asb'
info=psb_success_
name = 'mld_aggrmat_nosmth_asb'
info = psb_success_
call psb_erractionsave(err_act)
if (psb_errstatus_fatal()) then
info = psb_err_internal_error_; goto 9999
@ -137,24 +138,23 @@ subroutine mld_zaggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_re
nrow = desc_a%get_local_rows()
ncol = desc_a%get_local_cols()
naggr = nlaggr(me+1)
ntaggr = sum(nlaggr)
naggrm1 = sum(nlaggr(1:me))
naggrp1 = sum(nlaggr(1:me+1))
call op_prol%cp_to(tmpcoo)
call op_prol%cscnv(info,type='csr',dupl=psb_dupl_add_)
call tmpcoo%transp()
nzl = tmpcoo%get_nzeros()
i=0
!
! Now we have to fix this. The only rows of tmpcoo/op_restr that are correct
! are those corresponding to "local" aggregates, i.e. indices in ilaggr(:)
!
do k=1, nzl
nzl = tmpcoo%get_nzeros()
i = 0
do k = 1, nzl
if ((naggrm1 < tmpcoo%ia(k)) .and.(tmpcoo%ia(k) <= naggrp1)) then
i = i+1
tmpcoo%val(i) = tmpcoo%val(k)
@ -169,11 +169,11 @@ subroutine mld_zaggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_re
if (info /= psb_success_) goto 9999
call a%cp_to(ac_coo)
call a%cp_to_l(la)
call la%mv_to(ac_coo)
nzt = ac_coo%get_nzeros()
k = 0
do i=1, nzt
k = 0
do i = 1, nzt
k = k + 1
ac_coo%ia(k) = ilaggr(ac_coo%ia(i))
ac_coo%ja(k) = ilaggr(ac_coo%ja(i))

7
mlprec/impl/aggregator/mld_zaggrmat_smth_asb.f90
Unescape Escape View File

@ -126,9 +126,9 @@ subroutine mld_zaggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_rest
integer(psb_ipk_), intent(out) :: info
! Local variables
integer(psb_lpk_) :: nrow, nglob, ncol, ntaggr, ip, ndx,&
integer(psb_lpk_) :: nrow, nglob, ncol, ntaggr, ip, &
& naggr, nzl,naggrm1,naggrp1, i, j, k, jd, icolF, nrw
integer(psb_ipk_) ::ictxt, np, me
integer(psb_ipk_) :: ictxt, np, me
character(len=20) :: name
type(psb_lzspmat_type) :: la, am3, am4, tmp_prol
type(psb_lz_coo_sparse_mat) :: tmpcoo
@ -149,7 +149,6 @@ subroutine mld_zaggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_rest
debug_unit = psb_get_debug_unit()
debug_level = psb_get_debug_level()
ictxt = desc_a%get_context()
ictxt = desc_a%get_context()
call psb_info(ictxt, me, np)
@ -201,7 +200,7 @@ subroutine mld_zaggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_rest
!
if (info == psb_success_) call acsr3%cp_to_fmt(acsrf,info)
do i=1,nrow
do i=1, nrow
tmp = zzero
jd = -1
do j=acsrf%irp(i),acsrf%irp(i+1)-1

Write Preview
Loading…
Cancel
Save