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 7 years ago
parent 5bdd07b13b
commit f0472fa227
16 changed files with 380 additions and 576 deletions
Show Stats Download Patch File Download Diff File

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

@ -90,24 +90,24 @@ subroutine mld_caggrmat_biz_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_restr
! Arguments ! Arguments
type(psb_cspmat_type), intent(in) :: a type(psb_cspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_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(mld_sml_parms), intent(inout) :: parms
type(psb_cspmat_type), intent(inout) :: op_prol type(psb_lcspmat_type), intent(inout) :: op_prol
type(psb_cspmat_type), intent(out) :: ac,op_restr type(psb_lcspmat_type), intent(out) :: ac,op_restr
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
! Local variables ! Local variables
integer(psb_ipk_) :: nrow, nglob, ncol, ntaggr, ip, ndx,& integer(psb_lpk_) :: nrow, nglob, ncol, ntaggr, ip, &
& naggr, nzl,naggrm1,naggrp1, i, j, k, jd, icolF, nrw, err_act & 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 character(len=20) :: name
type(psb_cspmat_type) :: am3, am4,tmp_prol type(psb_lcspmat_type) :: am3, am4,tmp_prol, la
type(psb_c_coo_sparse_mat) :: tmpcoo type(psb_lc_coo_sparse_mat) :: tmpcoo
type(psb_c_csr_sparse_mat) :: acsr1, acsr2, acsr3, acsrf, ptilde type(psb_lc_csr_sparse_mat) :: acsr1, acsr2, acsr3, acsrf, ptilde
complex(psb_spk_), allocatable :: adiag(:) complex(psb_spk_), allocatable :: adiag(:)
integer(psb_ipk_) :: ierr(5) integer(psb_ipk_) :: ierr(5)
logical :: filter_mat 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 integer(psb_ipk_), parameter :: ncmax=16
real(psb_spk_) :: anorm, omega, tmp, dg, theta 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() ncol = desc_a%get_local_cols()
theta = parms%aggr_thresh theta = parms%aggr_thresh
naggr = nlaggr(me+1) naggr = nlaggr(me+1)
ntaggr = sum(nlaggr) ntaggr = sum(nlaggr)
filter_mat = (parms%aggr_filter == mld_filter_mat_) filter_mat = (parms%aggr_filter == mld_filter_mat_)
! naggr: number of local aggregates ! naggr: number of local aggregates
@ -145,7 +143,7 @@ subroutine mld_caggrmat_biz_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_restr
& call psb_realloc(ncol,adiag,info) & call psb_realloc(ncol,adiag,info)
if (info == psb_success_) & if (info == psb_success_) &
& call psb_halo(adiag,desc_a,info) & call psb_halo(adiag,desc_a,info)
if (info == psb_success_) call a%cp_to_l(la)
if (info /= psb_success_) then if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='sp_getdiag') call psb_errpush(psb_err_from_subroutine_,name,a_err='sp_getdiag')
goto 9999 goto 9999
@ -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 ! 1. Allocate Ptilde in sparse matrix form
call op_prol%mv_to(tmpcoo) call op_prol%mv_to(tmpcoo)
call ptilde%mv_from_coo(tmpcoo,info) 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 (info /= psb_success_) goto 9999
if (debug_level >= psb_debug_outer_) & if (debug_level >= psb_debug_outer_) &
@ -165,7 +163,7 @@ subroutine mld_caggrmat_biz_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_restr
! !
! Build the filtered matrix Af from A ! 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 tmp = czero
@ -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) ! 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 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 goto 9999
end if end if
call psb_numbmm(acsrf,ptilde,acsr1)
if (debug_level >= psb_debug_outer_) & if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),& & write(debug_unit,*) me,' ',trim(name),&
& 'Done NUMBMM 1' & 'Done SPSPMM 1'
else 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) ! 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 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 goto 9999
end if end if
call psb_numbmm(acsr3,ptilde,acsr1)
if (debug_level >= psb_debug_outer_) & if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),& & write(debug_unit,*) me,' ',trim(name),&
& 'Done NUMBMM 1' & 'Done SPSPMM 1'
end if end if
call ptilde%free() 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 goto 9999
end if end if
call psb_symbmm(a,tmp_prol,am3,info) call psb_spspmm(la,tmp_prol,am3,info)
if(info /= psb_success_) then 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 goto 9999
end if end if
call psb_numbmm(a,tmp_prol,am3)
if (debug_level >= psb_debug_outer_) & if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),& & 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) call tmp_prol%transp(op_restr)
if (debug_level >= psb_debug_outer_) & 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 goto 9999
end if end if
if (debug_level >= psb_debug_outer_) & if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),& & write(debug_unit,*) me,' ',trim(name),&
& 'starting symbmm 3' & 'starting spspmm 3'
call psb_symbmm(op_restr,am3,ac,info) call psb_spspmm(op_restr,am3,ac,info)
if (info == psb_success_) call psb_numbmm(op_restr,am3,ac)
if (info == psb_success_) call am3%free() 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 if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,a_err='Build b = op_restr x am3') call psb_errpush(psb_err_internal_error_,name,a_err='Build b = op_restr x am3')
goto 9999 goto 9999
end if end if
if (debug_level >= psb_debug_outer_) & if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),& & write(debug_unit,*) me,' ',trim(name),&
& 'Done smooth_aggregate ' & 'Done smooth_aggregate '

120
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 ! Arguments
type(psb_cspmat_type), intent(in) :: a type(psb_cspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_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(mld_sml_parms), intent(inout) :: parms
type(psb_cspmat_type), intent(inout) :: op_prol type(psb_lcspmat_type), intent(inout) :: op_prol
type(psb_cspmat_type), intent(out) :: ac,op_restr type(psb_lcspmat_type), intent(out) :: ac,op_restr
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
! Local variables ! Local variables
integer(psb_ipk_), allocatable :: nzbr(:), idisp(:) integer(psb_lpk_) :: nrow, nglob, ncol, ntaggr, nzac, ip, ndx,&
integer(psb_ipk_) :: nrow, nglob, ncol, ntaggr, nzac, ip, ndx,& & naggr, nzl,naggrm1,naggrp1, i, j, k, jd, icolF, nrt
& naggr, nzl,naggrm1,naggrp1, i, j, k, jd, icolF, nrt, err_act
integer(psb_ipk_) :: ictxt,np,me, icomm integer(psb_ipk_) :: ictxt,np,me, icomm
character(len=20) :: name character(len=20) :: name
type(psb_cspmat_type) :: af, ptilde, rtilde, atran, atp, atdatp type(psb_lcspmat_type) :: la, af, ptilde, rtilde, atran, atp, atdatp
type(psb_cspmat_type) :: am3,am4, ap, adap,atmp,rada, ra, atmp2, dap, dadap, da type(psb_lcspmat_type) :: am3,am4, ap, adap,atmp,rada, ra, atmp2, dap, dadap, da
type(psb_cspmat_type) :: dat, datp, datdatp, atmp3, tmp_prol type(psb_lcspmat_type) :: dat, datp, datdatp, atmp3, tmp_prol
type(psb_c_coo_sparse_mat) :: tmpcoo type(psb_lc_coo_sparse_mat) :: tmpcoo
type(psb_c_csr_sparse_mat) :: acsr1, acsr2, acsr3, acsr, acsrf type(psb_lc_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_lc_csc_sparse_mat) :: csc_dap, csc_dadap, csc_datp, csc_datdatp, acsc
complex(psb_spk_), allocatable :: adiag(:), adinv(:) complex(psb_spk_), allocatable :: adiag(:), adinv(:)
complex(psb_spk_), allocatable :: omf(:), omp(:), omi(:), oden(:) complex(psb_spk_), allocatable :: omf(:), omp(:), omi(:), oden(:)
logical :: filter_mat logical :: filter_mat
integer(psb_ipk_) :: ierr(5) 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 integer(psb_ipk_), parameter :: ncmax=16
real(psb_spk_) :: anorm, theta real(psb_spk_) :: anorm, theta
complex(psb_spk_) :: tmp, alpha, beta, ommx 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) naggr = nlaggr(me+1)
ntaggr = sum(nlaggr) 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)) naggrm1 = sum(nlaggr(1:me))
naggrp1 = sum(nlaggr(1:me+1)) 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) & call psb_realloc(ncol,adiag,info)
if (info == psb_success_) & if (info == psb_success_) &
& call psb_halo(adiag,desc_a,info) & 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) do i=1,size(adiag)
if (adiag(i) /= czero) then 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 if
end do 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 ! 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%mv_from(tmpcoo)
call ptilde%cscnv(info,type='csr') 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 la%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(da,info,type='csr',dupl=psb_dupl_add_)
if (info /= psb_success_) then if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='spcnv') call psb_errpush(psb_err_from_subroutine_,name,a_err='spcnv')
goto 9999 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 da%scal(adinv,info)
call psb_symbmm(da,ptilde,dap,info) call psb_spspmm(da,ptilde,dap,info)
if (info == psb_success_) call psb_numbmm(da,ptilde,dap)
if(info /= psb_success_) then 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 goto 9999
end if 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 psb_rwextd(ncol,atmp,info,b=am4)
if (info == psb_success_) call am4%free() if (info == psb_success_) call am4%free()
call psb_symbmm(da,atmp,dadap,info) call psb_spspmm(da,atmp,dadap,info)
call psb_numbmm(da,atmp,dadap)
call atmp%free() call atmp%free()
! !$ write(0,*) 'Columns of AP',psb_sp_get_ncols(ap) ! !$ 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 dap%mv_to(csc_dap)
call dadap%mv_to(csc_dadap) call dadap%mv_to(csc_dadap)
call csc_mat_col_prod(csc_dap,csc_dadap,omp,info) call csc_mat_col_prod(csc_dap,csc_dadap,omp,info)
call csc_mat_col_prod(csc_dadap,csc_dadap,oden,info) call csc_mat_col_prod(csc_dadap,csc_dadap,oden,info)
call psb_sum(ictxt,omp) 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 ! 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 do i=1,nrow
tmp = czero 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) call af%mv_from(acsrf)
! !
! Symbmm90 does the allocation for its result.
!
! op_prol = (I-w*D*Af)Ptilde ! op_prol = (I-w*D*Af)Ptilde
! Doing it this way means to consider diag(Af_i) ! Doing it this way means to consider diag(Af_i)
! !
! !
call psb_symbmm(af,ptilde,op_prol,info) call psb_spspmm(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)
if (debug_level >= psb_debug_outer_) & if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),& & write(debug_unit,*) me,' ',trim(name),&
& 'Done NUMBMM 1' & 'Done SPSPMM 1'
else else
! !
! Build the smoothed prolongator using the original matrix ! 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),& & write(debug_unit,*) me,' ',trim(name),&
& 'Done gather, going for SYMBMM 1' & 'Done gather, going for SYMBMM 1'
! !
! Symbmm90 does the allocation for its result.
! !
! op_prol = (I-w*D*A)Ptilde ! op_prol = (I-w*D*A)Ptilde
! !
! !
call psb_symbmm(am3,ptilde,op_prol,info) call psb_spspmm(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)
if (debug_level >= psb_debug_outer_) & if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),& & write(debug_unit,*) me,' ',trim(name),&
& 'Done NUMBMM 1' & '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 ! Ok, let's start over with the restrictor
! !
call ptilde%transc(rtilde) 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,& call psb_sphalo(atmp,desc_a,am4,info,&
& colcnv=.true.,rowscale=.true.) & colcnv=.true.,rowscale=.true.)
nrt = am4%get_nrows() 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') call atmp2%cscnv(info,type='CSR')
if (info == psb_success_) call psb_rwextd(ncol,atmp,info,b=atmp2) if (info == psb_success_) call psb_rwextd(ncol,atmp,info,b=atmp2)
call am4%free() 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 ! This is to compute the transpose. It ONLY works if the
! original A has a symmetric pattern. ! original A has a symmetric pattern.
call atmp%transc(atmp2) 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%cscnv(info,type='csr')
call dat%scal(adinv,info) call dat%scal(adinv,info)
! Now for the product. ! Now for the product.
call psb_symbmm(dat,ptilde,datp,info) call psb_spspmm(dat,ptilde,datp,info)
if (info == psb_success_) call psb_numbmm(dat,ptilde,datp)
call datp%clone(atmp2,info) call datp%clone(atmp2,info)
call psb_sphalo(atmp2,desc_a,am4,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%mv_from(tmpcoo)
call rtilde%cscnv(info,type='csr') call rtilde%cscnv(info,type='csr')
call psb_symbmm(rtilde,atmp,op_restr,info) call psb_spspmm(rtilde,atmp,op_restr,info)
call psb_numbmm(rtilde,atmp,op_restr)
! !
! Now we have to gather the halo of op_prol, and add it to itself ! 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),& & write(debug_unit,*) me,' ',trim(name),&
& 'starting sphalo/ rwxtd' & 'starting sphalo/ rwxtd'
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')
goto 9999
end if
call psb_numbmm(a,tmp_prol,am3)
if (debug_level >= psb_debug_outer_) & if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),& & write(debug_unit,*) me,' ',trim(name),&
& 'Done NUMBMM 2' & 'Done SPSPMM 2'
call psb_sphalo(am3,desc_a,am4,info,& call psb_sphalo(am3,desc_a,am4,info,&
& colcnv=.false.,rowscale=.true.) & 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),& & write(debug_unit,*) me,' ',trim(name),&
& 'Done sphalo/ rwxtd' & 'Done sphalo/ rwxtd'
call psb_symbmm(op_restr,am3,ac,info) call psb_spspmm(op_restr,am3,ac,info)
if (info == psb_success_) call psb_numbmm(op_restr,am3,ac)
if (info == psb_success_) call am3%free() 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='coo',dupl=psb_dupl_add_)
@ -587,11 +551,11 @@ contains
subroutine csc_mat_col_prod(a,b,v,info) subroutine csc_mat_col_prod(a,b,v,info)
implicit none 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(:) complex(psb_spk_), intent(out) :: v(:)
integer(psb_ipk_), intent(out) :: info 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_ info = psb_success_
nc = a%get_ncols() nc = a%get_ncols()
@ -615,11 +579,11 @@ contains
subroutine csr_mat_row_prod(a,b,v,info) subroutine csr_mat_row_prod(a,b,v,info)
implicit none 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(:) complex(psb_spk_), intent(out) :: v(:)
integer(psb_ipk_), intent(out) :: info 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_ info = psb_success_
nr = a%get_nrows() nr = a%get_nrows()
@ -643,12 +607,12 @@ contains
function sparse_srtd_dot(nv1,iv1,v1,nv2,iv2,v2) result(dot) function sparse_srtd_dot(nv1,iv1,v1,nv2,iv2,v2) result(dot)
implicit none implicit none
integer(psb_ipk_), intent(in) :: nv1,nv2 integer(psb_lpk_), intent(in) :: nv1,nv2
integer(psb_ipk_), intent(in) :: iv1(:), iv2(:) integer(psb_lpk_), intent(in) :: iv1(:), iv2(:)
complex(psb_spk_), intent(in) :: v1(:),v2(:) complex(psb_spk_), intent(in) :: v1(:),v2(:)
complex(psb_spk_) :: dot complex(psb_spk_) :: dot
integer(psb_ipk_) :: i,j,k, ip1, ip2 integer(psb_lpk_) :: i,j,k, ip1, ip2
dot = czero dot = czero
ip1 = 1 ip1 = 1
@ -671,7 +635,7 @@ contains
end function sparse_srtd_dot end function sparse_srtd_dot
subroutine local_dump(me,mat,name,header) 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 integer(psb_ipk_), intent(in) :: me
character(len=*), intent(in) :: name character(len=*), intent(in) :: name
character(len=*), intent(in) :: header character(len=*), intent(in) :: header

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

@ -106,21 +106,22 @@ subroutine mld_caggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_re
! Arguments ! Arguments
type(psb_cspmat_type), intent(in) :: a type(psb_cspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_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(mld_sml_parms), intent(inout) :: parms
type(psb_cspmat_type), intent(inout) :: op_prol type(psb_lcspmat_type), intent(inout) :: op_prol
type(psb_cspmat_type), intent(out) :: ac,op_restr type(psb_lcspmat_type), intent(out) :: ac,op_restr
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
! Local variables ! Local variables
integer(psb_ipk_) :: err_act 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 character(len=20) :: name
integer(psb_ipk_) :: ierr(5) integer(psb_ipk_) :: ierr(5)
type(psb_c_coo_sparse_mat) :: ac_coo, tmpcoo type(psb_lcspmat_type) :: la
type(psb_c_csr_sparse_mat) :: acsr1, acsr2 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_) :: 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 & naggr, nzt, naggrm1, naggrp1, i, k
name = 'mld_aggrmat_nosmth_asb' name = 'mld_aggrmat_nosmth_asb'
@ -137,7 +138,6 @@ subroutine mld_caggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_re
nrow = desc_a%get_local_rows() nrow = desc_a%get_local_rows()
ncol = desc_a%get_local_cols() ncol = desc_a%get_local_cols()
naggr = nlaggr(me+1) naggr = nlaggr(me+1)
ntaggr = sum(nlaggr) ntaggr = sum(nlaggr)
naggrm1 = sum(nlaggr(1:me)) naggrm1 = sum(nlaggr(1:me))
@ -148,12 +148,12 @@ subroutine mld_caggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_re
call op_prol%cscnv(info,type='csr',dupl=psb_dupl_add_) call op_prol%cscnv(info,type='csr',dupl=psb_dupl_add_)
call tmpcoo%transp() 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 ! 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(:) ! are those corresponding to "local" aggregates, i.e. indices in ilaggr(:)
! !
nzl = tmpcoo%get_nzeros()
i = 0
do k = 1, nzl do k = 1, nzl
if ((naggrm1 < tmpcoo%ia(k)) .and.(tmpcoo%ia(k) <= naggrp1)) then if ((naggrm1 < tmpcoo%ia(k)) .and.(tmpcoo%ia(k) <= naggrp1)) then
i = i+1 i = i+1
@ -169,8 +169,8 @@ subroutine mld_caggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_re
if (info /= psb_success_) goto 9999 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() nzt = ac_coo%get_nzeros()
k = 0 k = 0
do i = 1, nzt do i = 1, nzt

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

@ -126,7 +126,7 @@ subroutine mld_caggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_rest
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
! Local variables ! 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 & 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 character(len=20) :: name
@ -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_unit = psb_get_debug_unit()
debug_level = psb_get_debug_level() debug_level = psb_get_debug_level()
ictxt = desc_a%get_context()
ictxt = desc_a%get_context() ictxt = desc_a%get_context()
call psb_info(ictxt, me, np) call psb_info(ictxt, me, np)

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

@ -90,24 +90,24 @@ subroutine mld_daggrmat_biz_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_restr
! Arguments ! Arguments
type(psb_dspmat_type), intent(in) :: a type(psb_dspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_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(mld_dml_parms), intent(inout) :: parms
type(psb_dspmat_type), intent(inout) :: op_prol type(psb_ldspmat_type), intent(inout) :: op_prol
type(psb_dspmat_type), intent(out) :: ac,op_restr type(psb_ldspmat_type), intent(out) :: ac,op_restr
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
! Local variables ! Local variables
integer(psb_ipk_) :: nrow, nglob, ncol, ntaggr, ip, ndx,& integer(psb_lpk_) :: nrow, nglob, ncol, ntaggr, ip, &
& naggr, nzl,naggrm1,naggrp1, i, j, k, jd, icolF, nrw, err_act & 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 character(len=20) :: name
type(psb_dspmat_type) :: am3, am4,tmp_prol type(psb_ldspmat_type) :: am3, am4,tmp_prol, la
type(psb_d_coo_sparse_mat) :: tmpcoo type(psb_ld_coo_sparse_mat) :: tmpcoo
type(psb_d_csr_sparse_mat) :: acsr1, acsr2, acsr3, acsrf, ptilde type(psb_ld_csr_sparse_mat) :: acsr1, acsr2, acsr3, acsrf, ptilde
real(psb_dpk_), allocatable :: adiag(:) real(psb_dpk_), allocatable :: adiag(:)
integer(psb_ipk_) :: ierr(5) integer(psb_ipk_) :: ierr(5)
logical :: filter_mat 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 integer(psb_ipk_), parameter :: ncmax=16
real(psb_dpk_) :: anorm, omega, tmp, dg, theta 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() ncol = desc_a%get_local_cols()
theta = parms%aggr_thresh theta = parms%aggr_thresh
naggr = nlaggr(me+1) naggr = nlaggr(me+1)
ntaggr = sum(nlaggr) ntaggr = sum(nlaggr)
filter_mat = (parms%aggr_filter == mld_filter_mat_) filter_mat = (parms%aggr_filter == mld_filter_mat_)
! naggr: number of local aggregates ! naggr: number of local aggregates
@ -145,7 +143,7 @@ subroutine mld_daggrmat_biz_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_restr
& call psb_realloc(ncol,adiag,info) & call psb_realloc(ncol,adiag,info)
if (info == psb_success_) & if (info == psb_success_) &
& call psb_halo(adiag,desc_a,info) & call psb_halo(adiag,desc_a,info)
if (info == psb_success_) call a%cp_to_l(la)
if (info /= psb_success_) then if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='sp_getdiag') call psb_errpush(psb_err_from_subroutine_,name,a_err='sp_getdiag')
goto 9999 goto 9999
@ -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 ! 1. Allocate Ptilde in sparse matrix form
call op_prol%mv_to(tmpcoo) call op_prol%mv_to(tmpcoo)
call ptilde%mv_from_coo(tmpcoo,info) 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 (info /= psb_success_) goto 9999
if (debug_level >= psb_debug_outer_) & if (debug_level >= psb_debug_outer_) &
@ -165,7 +163,7 @@ subroutine mld_daggrmat_biz_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_restr
! !
! Build the filtered matrix Af from A ! 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 tmp = dzero
@ -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) ! 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 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 goto 9999
end if end if
call psb_numbmm(acsrf,ptilde,acsr1)
if (debug_level >= psb_debug_outer_) & if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),& & write(debug_unit,*) me,' ',trim(name),&
& 'Done NUMBMM 1' & 'Done SPSPMM 1'
else 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) ! 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 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 goto 9999
end if end if
call psb_numbmm(acsr3,ptilde,acsr1)
if (debug_level >= psb_debug_outer_) & if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),& & write(debug_unit,*) me,' ',trim(name),&
& 'Done NUMBMM 1' & 'Done SPSPMM 1'
end if end if
call ptilde%free() 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 goto 9999
end if end if
call psb_symbmm(a,tmp_prol,am3,info) call psb_spspmm(la,tmp_prol,am3,info)
if(info /= psb_success_) then 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 goto 9999
end if end if
call psb_numbmm(a,tmp_prol,am3)
if (debug_level >= psb_debug_outer_) & if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),& & 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) call tmp_prol%transp(op_restr)
if (debug_level >= psb_debug_outer_) & 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 goto 9999
end if end if
if (debug_level >= psb_debug_outer_) & if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),& & write(debug_unit,*) me,' ',trim(name),&
& 'starting symbmm 3' & 'starting spspmm 3'
call psb_symbmm(op_restr,am3,ac,info) call psb_spspmm(op_restr,am3,ac,info)
if (info == psb_success_) call psb_numbmm(op_restr,am3,ac)
if (info == psb_success_) call am3%free() 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 if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,a_err='Build b = op_restr x am3') call psb_errpush(psb_err_internal_error_,name,a_err='Build b = op_restr x am3')
goto 9999 goto 9999
end if end if
if (debug_level >= psb_debug_outer_) & if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),& & write(debug_unit,*) me,' ',trim(name),&
& 'Done smooth_aggregate ' & 'Done smooth_aggregate '

120
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 ! Arguments
type(psb_dspmat_type), intent(in) :: a type(psb_dspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_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(mld_dml_parms), intent(inout) :: parms
type(psb_dspmat_type), intent(inout) :: op_prol type(psb_ldspmat_type), intent(inout) :: op_prol
type(psb_dspmat_type), intent(out) :: ac,op_restr type(psb_ldspmat_type), intent(out) :: ac,op_restr
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
! Local variables ! Local variables
integer(psb_ipk_), allocatable :: nzbr(:), idisp(:) integer(psb_lpk_) :: nrow, nglob, ncol, ntaggr, nzac, ip, ndx,&
integer(psb_ipk_) :: nrow, nglob, ncol, ntaggr, nzac, ip, ndx,& & naggr, nzl,naggrm1,naggrp1, i, j, k, jd, icolF, nrt
& naggr, nzl,naggrm1,naggrp1, i, j, k, jd, icolF, nrt, err_act
integer(psb_ipk_) :: ictxt,np,me, icomm integer(psb_ipk_) :: ictxt,np,me, icomm
character(len=20) :: name character(len=20) :: name
type(psb_dspmat_type) :: af, ptilde, rtilde, atran, atp, atdatp type(psb_ldspmat_type) :: la, af, ptilde, rtilde, atran, atp, atdatp
type(psb_dspmat_type) :: am3,am4, ap, adap,atmp,rada, ra, atmp2, dap, dadap, da type(psb_ldspmat_type) :: am3,am4, ap, adap,atmp,rada, ra, atmp2, dap, dadap, da
type(psb_dspmat_type) :: dat, datp, datdatp, atmp3, tmp_prol type(psb_ldspmat_type) :: dat, datp, datdatp, atmp3, tmp_prol
type(psb_d_coo_sparse_mat) :: tmpcoo type(psb_ld_coo_sparse_mat) :: tmpcoo
type(psb_d_csr_sparse_mat) :: acsr1, acsr2, acsr3, acsr, acsrf type(psb_ld_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_ld_csc_sparse_mat) :: csc_dap, csc_dadap, csc_datp, csc_datdatp, acsc
real(psb_dpk_), allocatable :: adiag(:), adinv(:) real(psb_dpk_), allocatable :: adiag(:), adinv(:)
real(psb_dpk_), allocatable :: omf(:), omp(:), omi(:), oden(:) real(psb_dpk_), allocatable :: omf(:), omp(:), omi(:), oden(:)
logical :: filter_mat logical :: filter_mat
integer(psb_ipk_) :: ierr(5) 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 integer(psb_ipk_), parameter :: ncmax=16
real(psb_dpk_) :: anorm, theta real(psb_dpk_) :: anorm, theta
real(psb_dpk_) :: tmp, alpha, beta, ommx 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) naggr = nlaggr(me+1)
ntaggr = sum(nlaggr) 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)) naggrm1 = sum(nlaggr(1:me))
naggrp1 = sum(nlaggr(1:me+1)) 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) & call psb_realloc(ncol,adiag,info)
if (info == psb_success_) & if (info == psb_success_) &
& call psb_halo(adiag,desc_a,info) & 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) do i=1,size(adiag)
if (adiag(i) /= dzero) then 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 if
end do 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 ! 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%mv_from(tmpcoo)
call ptilde%cscnv(info,type='csr') 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 la%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(da,info,type='csr',dupl=psb_dupl_add_)
if (info /= psb_success_) then if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='spcnv') call psb_errpush(psb_err_from_subroutine_,name,a_err='spcnv')
goto 9999 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 da%scal(adinv,info)
call psb_symbmm(da,ptilde,dap,info) call psb_spspmm(da,ptilde,dap,info)
if (info == psb_success_) call psb_numbmm(da,ptilde,dap)
if(info /= psb_success_) then 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 goto 9999
end if 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 psb_rwextd(ncol,atmp,info,b=am4)
if (info == psb_success_) call am4%free() if (info == psb_success_) call am4%free()
call psb_symbmm(da,atmp,dadap,info) call psb_spspmm(da,atmp,dadap,info)
call psb_numbmm(da,atmp,dadap)
call atmp%free() call atmp%free()
! !$ write(0,*) 'Columns of AP',psb_sp_get_ncols(ap) ! !$ 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 dap%mv_to(csc_dap)
call dadap%mv_to(csc_dadap) call dadap%mv_to(csc_dadap)
call csc_mat_col_prod(csc_dap,csc_dadap,omp,info) call csc_mat_col_prod(csc_dap,csc_dadap,omp,info)
call csc_mat_col_prod(csc_dadap,csc_dadap,oden,info) call csc_mat_col_prod(csc_dadap,csc_dadap,oden,info)
call psb_sum(ictxt,omp) 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 ! 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 do i=1,nrow
tmp = dzero 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) call af%mv_from(acsrf)
! !
! Symbmm90 does the allocation for its result.
!
! op_prol = (I-w*D*Af)Ptilde ! op_prol = (I-w*D*Af)Ptilde
! Doing it this way means to consider diag(Af_i) ! Doing it this way means to consider diag(Af_i)
! !
! !
call psb_symbmm(af,ptilde,op_prol,info) call psb_spspmm(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)
if (debug_level >= psb_debug_outer_) & if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),& & write(debug_unit,*) me,' ',trim(name),&
& 'Done NUMBMM 1' & 'Done SPSPMM 1'
else else
! !
! Build the smoothed prolongator using the original matrix ! 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),& & write(debug_unit,*) me,' ',trim(name),&
& 'Done gather, going for SYMBMM 1' & 'Done gather, going for SYMBMM 1'
! !
! Symbmm90 does the allocation for its result.
! !
! op_prol = (I-w*D*A)Ptilde ! op_prol = (I-w*D*A)Ptilde
! !
! !
call psb_symbmm(am3,ptilde,op_prol,info) call psb_spspmm(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)
if (debug_level >= psb_debug_outer_) & if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),& & write(debug_unit,*) me,' ',trim(name),&
& 'Done NUMBMM 1' & '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 ! Ok, let's start over with the restrictor
! !
call ptilde%transc(rtilde) 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,& call psb_sphalo(atmp,desc_a,am4,info,&
& colcnv=.true.,rowscale=.true.) & colcnv=.true.,rowscale=.true.)
nrt = am4%get_nrows() 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') call atmp2%cscnv(info,type='CSR')
if (info == psb_success_) call psb_rwextd(ncol,atmp,info,b=atmp2) if (info == psb_success_) call psb_rwextd(ncol,atmp,info,b=atmp2)
call am4%free() 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 ! This is to compute the transpose. It ONLY works if the
! original A has a symmetric pattern. ! original A has a symmetric pattern.
call atmp%transc(atmp2) 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%cscnv(info,type='csr')
call dat%scal(adinv,info) call dat%scal(adinv,info)
! Now for the product. ! Now for the product.
call psb_symbmm(dat,ptilde,datp,info) call psb_spspmm(dat,ptilde,datp,info)
if (info == psb_success_) call psb_numbmm(dat,ptilde,datp)
call datp%clone(atmp2,info) call datp%clone(atmp2,info)
call psb_sphalo(atmp2,desc_a,am4,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%mv_from(tmpcoo)
call rtilde%cscnv(info,type='csr') call rtilde%cscnv(info,type='csr')
call psb_symbmm(rtilde,atmp,op_restr,info) call psb_spspmm(rtilde,atmp,op_restr,info)
call psb_numbmm(rtilde,atmp,op_restr)
! !
! Now we have to gather the halo of op_prol, and add it to itself ! 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),& & write(debug_unit,*) me,' ',trim(name),&
& 'starting sphalo/ rwxtd' & 'starting sphalo/ rwxtd'
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')
goto 9999
end if
call psb_numbmm(a,tmp_prol,am3)
if (debug_level >= psb_debug_outer_) & if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),& & write(debug_unit,*) me,' ',trim(name),&
& 'Done NUMBMM 2' & 'Done SPSPMM 2'
call psb_sphalo(am3,desc_a,am4,info,& call psb_sphalo(am3,desc_a,am4,info,&
& colcnv=.false.,rowscale=.true.) & 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),& & write(debug_unit,*) me,' ',trim(name),&
& 'Done sphalo/ rwxtd' & 'Done sphalo/ rwxtd'
call psb_symbmm(op_restr,am3,ac,info) call psb_spspmm(op_restr,am3,ac,info)
if (info == psb_success_) call psb_numbmm(op_restr,am3,ac)
if (info == psb_success_) call am3%free() 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='coo',dupl=psb_dupl_add_)
@ -587,11 +551,11 @@ contains
subroutine csc_mat_col_prod(a,b,v,info) subroutine csc_mat_col_prod(a,b,v,info)
implicit none 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(:) real(psb_dpk_), intent(out) :: v(:)
integer(psb_ipk_), intent(out) :: info 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_ info = psb_success_
nc = a%get_ncols() nc = a%get_ncols()
@ -615,11 +579,11 @@ contains
subroutine csr_mat_row_prod(a,b,v,info) subroutine csr_mat_row_prod(a,b,v,info)
implicit none 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(:) real(psb_dpk_), intent(out) :: v(:)
integer(psb_ipk_), intent(out) :: info 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_ info = psb_success_
nr = a%get_nrows() nr = a%get_nrows()
@ -643,12 +607,12 @@ contains
function sparse_srtd_dot(nv1,iv1,v1,nv2,iv2,v2) result(dot) function sparse_srtd_dot(nv1,iv1,v1,nv2,iv2,v2) result(dot)
implicit none implicit none
integer(psb_ipk_), intent(in) :: nv1,nv2 integer(psb_lpk_), intent(in) :: nv1,nv2
integer(psb_ipk_), intent(in) :: iv1(:), iv2(:) integer(psb_lpk_), intent(in) :: iv1(:), iv2(:)
real(psb_dpk_), intent(in) :: v1(:),v2(:) real(psb_dpk_), intent(in) :: v1(:),v2(:)
real(psb_dpk_) :: dot real(psb_dpk_) :: dot
integer(psb_ipk_) :: i,j,k, ip1, ip2 integer(psb_lpk_) :: i,j,k, ip1, ip2
dot = dzero dot = dzero
ip1 = 1 ip1 = 1
@ -671,7 +635,7 @@ contains
end function sparse_srtd_dot end function sparse_srtd_dot
subroutine local_dump(me,mat,name,header) 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 integer(psb_ipk_), intent(in) :: me
character(len=*), intent(in) :: name character(len=*), intent(in) :: name
character(len=*), intent(in) :: header character(len=*), intent(in) :: header

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

@ -106,21 +106,22 @@ subroutine mld_daggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_re
! Arguments ! Arguments
type(psb_dspmat_type), intent(in) :: a type(psb_dspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_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(mld_dml_parms), intent(inout) :: parms
type(psb_dspmat_type), intent(inout) :: op_prol type(psb_ldspmat_type), intent(inout) :: op_prol
type(psb_dspmat_type), intent(out) :: ac,op_restr type(psb_ldspmat_type), intent(out) :: ac,op_restr
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
! Local variables ! Local variables
integer(psb_ipk_) :: err_act 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 character(len=20) :: name
integer(psb_ipk_) :: ierr(5) integer(psb_ipk_) :: ierr(5)
type(psb_d_coo_sparse_mat) :: ac_coo, tmpcoo type(psb_ldspmat_type) :: la
type(psb_d_csr_sparse_mat) :: acsr1, acsr2 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_) :: 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 & naggr, nzt, naggrm1, naggrp1, i, k
name = 'mld_aggrmat_nosmth_asb' name = 'mld_aggrmat_nosmth_asb'
@ -137,7 +138,6 @@ subroutine mld_daggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_re
nrow = desc_a%get_local_rows() nrow = desc_a%get_local_rows()
ncol = desc_a%get_local_cols() ncol = desc_a%get_local_cols()
naggr = nlaggr(me+1) naggr = nlaggr(me+1)
ntaggr = sum(nlaggr) ntaggr = sum(nlaggr)
naggrm1 = sum(nlaggr(1:me)) naggrm1 = sum(nlaggr(1:me))
@ -148,12 +148,12 @@ subroutine mld_daggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_re
call op_prol%cscnv(info,type='csr',dupl=psb_dupl_add_) call op_prol%cscnv(info,type='csr',dupl=psb_dupl_add_)
call tmpcoo%transp() 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 ! 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(:) ! are those corresponding to "local" aggregates, i.e. indices in ilaggr(:)
! !
nzl = tmpcoo%get_nzeros()
i = 0
do k = 1, nzl do k = 1, nzl
if ((naggrm1 < tmpcoo%ia(k)) .and.(tmpcoo%ia(k) <= naggrp1)) then if ((naggrm1 < tmpcoo%ia(k)) .and.(tmpcoo%ia(k) <= naggrp1)) then
i = i+1 i = i+1
@ -169,8 +169,8 @@ subroutine mld_daggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_re
if (info /= psb_success_) goto 9999 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() nzt = ac_coo%get_nzeros()
k = 0 k = 0
do i = 1, nzt do i = 1, nzt

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

@ -126,7 +126,7 @@ subroutine mld_daggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_rest
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
! Local variables ! 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 & 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 character(len=20) :: name
@ -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_unit = psb_get_debug_unit()
debug_level = psb_get_debug_level() debug_level = psb_get_debug_level()
ictxt = desc_a%get_context()
ictxt = desc_a%get_context() ictxt = desc_a%get_context()
call psb_info(ictxt, me, np) call psb_info(ictxt, me, np)

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

@ -90,24 +90,24 @@ subroutine mld_saggrmat_biz_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_restr
! Arguments ! Arguments
type(psb_sspmat_type), intent(in) :: a type(psb_sspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_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(mld_sml_parms), intent(inout) :: parms
type(psb_sspmat_type), intent(inout) :: op_prol type(psb_lsspmat_type), intent(inout) :: op_prol
type(psb_sspmat_type), intent(out) :: ac,op_restr type(psb_lsspmat_type), intent(out) :: ac,op_restr
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
! Local variables ! Local variables
integer(psb_ipk_) :: nrow, nglob, ncol, ntaggr, ip, ndx,& integer(psb_lpk_) :: nrow, nglob, ncol, ntaggr, ip, &
& naggr, nzl,naggrm1,naggrp1, i, j, k, jd, icolF, nrw, err_act & 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 character(len=20) :: name
type(psb_sspmat_type) :: am3, am4,tmp_prol type(psb_lsspmat_type) :: am3, am4,tmp_prol, la
type(psb_s_coo_sparse_mat) :: tmpcoo type(psb_ls_coo_sparse_mat) :: tmpcoo
type(psb_s_csr_sparse_mat) :: acsr1, acsr2, acsr3, acsrf, ptilde type(psb_ls_csr_sparse_mat) :: acsr1, acsr2, acsr3, acsrf, ptilde
real(psb_spk_), allocatable :: adiag(:) real(psb_spk_), allocatable :: adiag(:)
integer(psb_ipk_) :: ierr(5) integer(psb_ipk_) :: ierr(5)
logical :: filter_mat 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 integer(psb_ipk_), parameter :: ncmax=16
real(psb_spk_) :: anorm, omega, tmp, dg, theta 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() ncol = desc_a%get_local_cols()
theta = parms%aggr_thresh theta = parms%aggr_thresh
naggr = nlaggr(me+1) naggr = nlaggr(me+1)
ntaggr = sum(nlaggr) ntaggr = sum(nlaggr)
filter_mat = (parms%aggr_filter == mld_filter_mat_) filter_mat = (parms%aggr_filter == mld_filter_mat_)
! naggr: number of local aggregates ! naggr: number of local aggregates
@ -145,7 +143,7 @@ subroutine mld_saggrmat_biz_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_restr
& call psb_realloc(ncol,adiag,info) & call psb_realloc(ncol,adiag,info)
if (info == psb_success_) & if (info == psb_success_) &
& call psb_halo(adiag,desc_a,info) & call psb_halo(adiag,desc_a,info)
if (info == psb_success_) call a%cp_to_l(la)
if (info /= psb_success_) then if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='sp_getdiag') call psb_errpush(psb_err_from_subroutine_,name,a_err='sp_getdiag')
goto 9999 goto 9999
@ -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 ! 1. Allocate Ptilde in sparse matrix form
call op_prol%mv_to(tmpcoo) call op_prol%mv_to(tmpcoo)
call ptilde%mv_from_coo(tmpcoo,info) 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 (info /= psb_success_) goto 9999
if (debug_level >= psb_debug_outer_) & if (debug_level >= psb_debug_outer_) &
@ -165,7 +163,7 @@ subroutine mld_saggrmat_biz_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_restr
! !
! Build the filtered matrix Af from A ! 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 tmp = szero
@ -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) ! 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 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 goto 9999
end if end if
call psb_numbmm(acsrf,ptilde,acsr1)
if (debug_level >= psb_debug_outer_) & if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),& & write(debug_unit,*) me,' ',trim(name),&
& 'Done NUMBMM 1' & 'Done SPSPMM 1'
else 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) ! 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 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 goto 9999
end if end if
call psb_numbmm(acsr3,ptilde,acsr1)
if (debug_level >= psb_debug_outer_) & if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),& & write(debug_unit,*) me,' ',trim(name),&
& 'Done NUMBMM 1' & 'Done SPSPMM 1'
end if end if
call ptilde%free() 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 goto 9999
end if end if
call psb_symbmm(a,tmp_prol,am3,info) call psb_spspmm(la,tmp_prol,am3,info)
if(info /= psb_success_) then 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 goto 9999
end if end if
call psb_numbmm(a,tmp_prol,am3)
if (debug_level >= psb_debug_outer_) & if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),& & 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) call tmp_prol%transp(op_restr)
if (debug_level >= psb_debug_outer_) & 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 goto 9999
end if end if
if (debug_level >= psb_debug_outer_) & if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),& & write(debug_unit,*) me,' ',trim(name),&
& 'starting symbmm 3' & 'starting spspmm 3'
call psb_symbmm(op_restr,am3,ac,info) call psb_spspmm(op_restr,am3,ac,info)
if (info == psb_success_) call psb_numbmm(op_restr,am3,ac)
if (info == psb_success_) call am3%free() 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 if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,a_err='Build b = op_restr x am3') call psb_errpush(psb_err_internal_error_,name,a_err='Build b = op_restr x am3')
goto 9999 goto 9999
end if end if
if (debug_level >= psb_debug_outer_) & if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),& & write(debug_unit,*) me,' ',trim(name),&
& 'Done smooth_aggregate ' & 'Done smooth_aggregate '

120
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 ! Arguments
type(psb_sspmat_type), intent(in) :: a type(psb_sspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_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(mld_sml_parms), intent(inout) :: parms
type(psb_sspmat_type), intent(inout) :: op_prol type(psb_lsspmat_type), intent(inout) :: op_prol
type(psb_sspmat_type), intent(out) :: ac,op_restr type(psb_lsspmat_type), intent(out) :: ac,op_restr
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
! Local variables ! Local variables
integer(psb_ipk_), allocatable :: nzbr(:), idisp(:) integer(psb_lpk_) :: nrow, nglob, ncol, ntaggr, nzac, ip, ndx,&
integer(psb_ipk_) :: nrow, nglob, ncol, ntaggr, nzac, ip, ndx,& & naggr, nzl,naggrm1,naggrp1, i, j, k, jd, icolF, nrt
& naggr, nzl,naggrm1,naggrp1, i, j, k, jd, icolF, nrt, err_act
integer(psb_ipk_) :: ictxt,np,me, icomm integer(psb_ipk_) :: ictxt,np,me, icomm
character(len=20) :: name character(len=20) :: name
type(psb_sspmat_type) :: af, ptilde, rtilde, atran, atp, atdatp type(psb_lsspmat_type) :: la, af, ptilde, rtilde, atran, atp, atdatp
type(psb_sspmat_type) :: am3,am4, ap, adap,atmp,rada, ra, atmp2, dap, dadap, da type(psb_lsspmat_type) :: am3,am4, ap, adap,atmp,rada, ra, atmp2, dap, dadap, da
type(psb_sspmat_type) :: dat, datp, datdatp, atmp3, tmp_prol type(psb_lsspmat_type) :: dat, datp, datdatp, atmp3, tmp_prol
type(psb_s_coo_sparse_mat) :: tmpcoo type(psb_ls_coo_sparse_mat) :: tmpcoo
type(psb_s_csr_sparse_mat) :: acsr1, acsr2, acsr3, acsr, acsrf type(psb_ls_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_ls_csc_sparse_mat) :: csc_dap, csc_dadap, csc_datp, csc_datdatp, acsc
real(psb_spk_), allocatable :: adiag(:), adinv(:) real(psb_spk_), allocatable :: adiag(:), adinv(:)
real(psb_spk_), allocatable :: omf(:), omp(:), omi(:), oden(:) real(psb_spk_), allocatable :: omf(:), omp(:), omi(:), oden(:)
logical :: filter_mat logical :: filter_mat
integer(psb_ipk_) :: ierr(5) 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 integer(psb_ipk_), parameter :: ncmax=16
real(psb_spk_) :: anorm, theta real(psb_spk_) :: anorm, theta
real(psb_spk_) :: tmp, alpha, beta, ommx 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) naggr = nlaggr(me+1)
ntaggr = sum(nlaggr) 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)) naggrm1 = sum(nlaggr(1:me))
naggrp1 = sum(nlaggr(1:me+1)) 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) & call psb_realloc(ncol,adiag,info)
if (info == psb_success_) & if (info == psb_success_) &
& call psb_halo(adiag,desc_a,info) & 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) do i=1,size(adiag)
if (adiag(i) /= szero) then 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 if
end do 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 ! 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%mv_from(tmpcoo)
call ptilde%cscnv(info,type='csr') 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 la%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(da,info,type='csr',dupl=psb_dupl_add_)
if (info /= psb_success_) then if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='spcnv') call psb_errpush(psb_err_from_subroutine_,name,a_err='spcnv')
goto 9999 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 da%scal(adinv,info)
call psb_symbmm(da,ptilde,dap,info) call psb_spspmm(da,ptilde,dap,info)
if (info == psb_success_) call psb_numbmm(da,ptilde,dap)
if(info /= psb_success_) then 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 goto 9999
end if 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 psb_rwextd(ncol,atmp,info,b=am4)
if (info == psb_success_) call am4%free() if (info == psb_success_) call am4%free()
call psb_symbmm(da,atmp,dadap,info) call psb_spspmm(da,atmp,dadap,info)
call psb_numbmm(da,atmp,dadap)
call atmp%free() call atmp%free()
! !$ write(0,*) 'Columns of AP',psb_sp_get_ncols(ap) ! !$ 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 dap%mv_to(csc_dap)
call dadap%mv_to(csc_dadap) call dadap%mv_to(csc_dadap)
call csc_mat_col_prod(csc_dap,csc_dadap,omp,info) call csc_mat_col_prod(csc_dap,csc_dadap,omp,info)
call csc_mat_col_prod(csc_dadap,csc_dadap,oden,info) call csc_mat_col_prod(csc_dadap,csc_dadap,oden,info)
call psb_sum(ictxt,omp) 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 ! 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 do i=1,nrow
tmp = szero 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) call af%mv_from(acsrf)
! !
! Symbmm90 does the allocation for its result.
!
! op_prol = (I-w*D*Af)Ptilde ! op_prol = (I-w*D*Af)Ptilde
! Doing it this way means to consider diag(Af_i) ! Doing it this way means to consider diag(Af_i)
! !
! !
call psb_symbmm(af,ptilde,op_prol,info) call psb_spspmm(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)
if (debug_level >= psb_debug_outer_) & if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),& & write(debug_unit,*) me,' ',trim(name),&
& 'Done NUMBMM 1' & 'Done SPSPMM 1'
else else
! !
! Build the smoothed prolongator using the original matrix ! 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),& & write(debug_unit,*) me,' ',trim(name),&
& 'Done gather, going for SYMBMM 1' & 'Done gather, going for SYMBMM 1'
! !
! Symbmm90 does the allocation for its result.
! !
! op_prol = (I-w*D*A)Ptilde ! op_prol = (I-w*D*A)Ptilde
! !
! !
call psb_symbmm(am3,ptilde,op_prol,info) call psb_spspmm(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)
if (debug_level >= psb_debug_outer_) & if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),& & write(debug_unit,*) me,' ',trim(name),&
& 'Done NUMBMM 1' & '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 ! Ok, let's start over with the restrictor
! !
call ptilde%transc(rtilde) 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,& call psb_sphalo(atmp,desc_a,am4,info,&
& colcnv=.true.,rowscale=.true.) & colcnv=.true.,rowscale=.true.)
nrt = am4%get_nrows() 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') call atmp2%cscnv(info,type='CSR')
if (info == psb_success_) call psb_rwextd(ncol,atmp,info,b=atmp2) if (info == psb_success_) call psb_rwextd(ncol,atmp,info,b=atmp2)
call am4%free() 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 ! This is to compute the transpose. It ONLY works if the
! original A has a symmetric pattern. ! original A has a symmetric pattern.
call atmp%transc(atmp2) 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%cscnv(info,type='csr')
call dat%scal(adinv,info) call dat%scal(adinv,info)
! Now for the product. ! Now for the product.
call psb_symbmm(dat,ptilde,datp,info) call psb_spspmm(dat,ptilde,datp,info)
if (info == psb_success_) call psb_numbmm(dat,ptilde,datp)
call datp%clone(atmp2,info) call datp%clone(atmp2,info)
call psb_sphalo(atmp2,desc_a,am4,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%mv_from(tmpcoo)
call rtilde%cscnv(info,type='csr') call rtilde%cscnv(info,type='csr')
call psb_symbmm(rtilde,atmp,op_restr,info) call psb_spspmm(rtilde,atmp,op_restr,info)
call psb_numbmm(rtilde,atmp,op_restr)
! !
! Now we have to gather the halo of op_prol, and add it to itself ! 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),& & write(debug_unit,*) me,' ',trim(name),&
& 'starting sphalo/ rwxtd' & 'starting sphalo/ rwxtd'
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')
goto 9999
end if
call psb_numbmm(a,tmp_prol,am3)
if (debug_level >= psb_debug_outer_) & if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),& & write(debug_unit,*) me,' ',trim(name),&
& 'Done NUMBMM 2' & 'Done SPSPMM 2'
call psb_sphalo(am3,desc_a,am4,info,& call psb_sphalo(am3,desc_a,am4,info,&
& colcnv=.false.,rowscale=.true.) & 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),& & write(debug_unit,*) me,' ',trim(name),&
& 'Done sphalo/ rwxtd' & 'Done sphalo/ rwxtd'
call psb_symbmm(op_restr,am3,ac,info) call psb_spspmm(op_restr,am3,ac,info)
if (info == psb_success_) call psb_numbmm(op_restr,am3,ac)
if (info == psb_success_) call am3%free() 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='coo',dupl=psb_dupl_add_)
@ -587,11 +551,11 @@ contains
subroutine csc_mat_col_prod(a,b,v,info) subroutine csc_mat_col_prod(a,b,v,info)
implicit none 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(:) real(psb_spk_), intent(out) :: v(:)
integer(psb_ipk_), intent(out) :: info 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_ info = psb_success_
nc = a%get_ncols() nc = a%get_ncols()
@ -615,11 +579,11 @@ contains
subroutine csr_mat_row_prod(a,b,v,info) subroutine csr_mat_row_prod(a,b,v,info)
implicit none 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(:) real(psb_spk_), intent(out) :: v(:)
integer(psb_ipk_), intent(out) :: info 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_ info = psb_success_
nr = a%get_nrows() nr = a%get_nrows()
@ -643,12 +607,12 @@ contains
function sparse_srtd_dot(nv1,iv1,v1,nv2,iv2,v2) result(dot) function sparse_srtd_dot(nv1,iv1,v1,nv2,iv2,v2) result(dot)
implicit none implicit none
integer(psb_ipk_), intent(in) :: nv1,nv2 integer(psb_lpk_), intent(in) :: nv1,nv2
integer(psb_ipk_), intent(in) :: iv1(:), iv2(:) integer(psb_lpk_), intent(in) :: iv1(:), iv2(:)
real(psb_spk_), intent(in) :: v1(:),v2(:) real(psb_spk_), intent(in) :: v1(:),v2(:)
real(psb_spk_) :: dot real(psb_spk_) :: dot
integer(psb_ipk_) :: i,j,k, ip1, ip2 integer(psb_lpk_) :: i,j,k, ip1, ip2
dot = szero dot = szero
ip1 = 1 ip1 = 1
@ -671,7 +635,7 @@ contains
end function sparse_srtd_dot end function sparse_srtd_dot
subroutine local_dump(me,mat,name,header) 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 integer(psb_ipk_), intent(in) :: me
character(len=*), intent(in) :: name character(len=*), intent(in) :: name
character(len=*), intent(in) :: header character(len=*), intent(in) :: header

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

@ -106,21 +106,22 @@ subroutine mld_saggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_re
! Arguments ! Arguments
type(psb_sspmat_type), intent(in) :: a type(psb_sspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_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(mld_sml_parms), intent(inout) :: parms
type(psb_sspmat_type), intent(inout) :: op_prol type(psb_lsspmat_type), intent(inout) :: op_prol
type(psb_sspmat_type), intent(out) :: ac,op_restr type(psb_lsspmat_type), intent(out) :: ac,op_restr
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
! Local variables ! Local variables
integer(psb_ipk_) :: err_act 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 character(len=20) :: name
integer(psb_ipk_) :: ierr(5) integer(psb_ipk_) :: ierr(5)
type(psb_s_coo_sparse_mat) :: ac_coo, tmpcoo type(psb_lsspmat_type) :: la
type(psb_s_csr_sparse_mat) :: acsr1, acsr2 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_) :: 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 & naggr, nzt, naggrm1, naggrp1, i, k
name = 'mld_aggrmat_nosmth_asb' name = 'mld_aggrmat_nosmth_asb'
@ -137,7 +138,6 @@ subroutine mld_saggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_re
nrow = desc_a%get_local_rows() nrow = desc_a%get_local_rows()
ncol = desc_a%get_local_cols() ncol = desc_a%get_local_cols()
naggr = nlaggr(me+1) naggr = nlaggr(me+1)
ntaggr = sum(nlaggr) ntaggr = sum(nlaggr)
naggrm1 = sum(nlaggr(1:me)) naggrm1 = sum(nlaggr(1:me))
@ -148,12 +148,12 @@ subroutine mld_saggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_re
call op_prol%cscnv(info,type='csr',dupl=psb_dupl_add_) call op_prol%cscnv(info,type='csr',dupl=psb_dupl_add_)
call tmpcoo%transp() 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 ! 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(:) ! are those corresponding to "local" aggregates, i.e. indices in ilaggr(:)
! !
nzl = tmpcoo%get_nzeros()
i = 0
do k = 1, nzl do k = 1, nzl
if ((naggrm1 < tmpcoo%ia(k)) .and.(tmpcoo%ia(k) <= naggrp1)) then if ((naggrm1 < tmpcoo%ia(k)) .and.(tmpcoo%ia(k) <= naggrp1)) then
i = i+1 i = i+1
@ -169,8 +169,8 @@ subroutine mld_saggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_re
if (info /= psb_success_) goto 9999 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() nzt = ac_coo%get_nzeros()
k = 0 k = 0
do i = 1, nzt do i = 1, nzt

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

@ -126,7 +126,7 @@ subroutine mld_saggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_rest
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
! Local variables ! 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 & 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 character(len=20) :: name
@ -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_unit = psb_get_debug_unit()
debug_level = psb_get_debug_level() debug_level = psb_get_debug_level()
ictxt = desc_a%get_context()
ictxt = desc_a%get_context() ictxt = desc_a%get_context()
call psb_info(ictxt, me, np) call psb_info(ictxt, me, np)

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

@ -90,24 +90,24 @@ subroutine mld_zaggrmat_biz_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_restr
! Arguments ! Arguments
type(psb_zspmat_type), intent(in) :: a type(psb_zspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_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(mld_dml_parms), intent(inout) :: parms
type(psb_zspmat_type), intent(inout) :: op_prol type(psb_lzspmat_type), intent(inout) :: op_prol
type(psb_zspmat_type), intent(out) :: ac,op_restr type(psb_lzspmat_type), intent(out) :: ac,op_restr
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
! Local variables ! Local variables
integer(psb_ipk_) :: nrow, nglob, ncol, ntaggr, ip, ndx,& integer(psb_lpk_) :: nrow, nglob, ncol, ntaggr, ip, &
& naggr, nzl,naggrm1,naggrp1, i, j, k, jd, icolF, nrw, err_act & 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 character(len=20) :: name
type(psb_zspmat_type) :: am3, am4,tmp_prol type(psb_lzspmat_type) :: am3, am4,tmp_prol, la
type(psb_z_coo_sparse_mat) :: tmpcoo type(psb_lz_coo_sparse_mat) :: tmpcoo
type(psb_z_csr_sparse_mat) :: acsr1, acsr2, acsr3, acsrf, ptilde type(psb_lz_csr_sparse_mat) :: acsr1, acsr2, acsr3, acsrf, ptilde
complex(psb_dpk_), allocatable :: adiag(:) complex(psb_dpk_), allocatable :: adiag(:)
integer(psb_ipk_) :: ierr(5) integer(psb_ipk_) :: ierr(5)
logical :: filter_mat 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 integer(psb_ipk_), parameter :: ncmax=16
real(psb_dpk_) :: anorm, omega, tmp, dg, theta 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() ncol = desc_a%get_local_cols()
theta = parms%aggr_thresh theta = parms%aggr_thresh
naggr = nlaggr(me+1) naggr = nlaggr(me+1)
ntaggr = sum(nlaggr) ntaggr = sum(nlaggr)
filter_mat = (parms%aggr_filter == mld_filter_mat_) filter_mat = (parms%aggr_filter == mld_filter_mat_)
! naggr: number of local aggregates ! naggr: number of local aggregates
@ -145,7 +143,7 @@ subroutine mld_zaggrmat_biz_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_restr
& call psb_realloc(ncol,adiag,info) & call psb_realloc(ncol,adiag,info)
if (info == psb_success_) & if (info == psb_success_) &
& call psb_halo(adiag,desc_a,info) & call psb_halo(adiag,desc_a,info)
if (info == psb_success_) call a%cp_to_l(la)
if (info /= psb_success_) then if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='sp_getdiag') call psb_errpush(psb_err_from_subroutine_,name,a_err='sp_getdiag')
goto 9999 goto 9999
@ -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 ! 1. Allocate Ptilde in sparse matrix form
call op_prol%mv_to(tmpcoo) call op_prol%mv_to(tmpcoo)
call ptilde%mv_from_coo(tmpcoo,info) 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 (info /= psb_success_) goto 9999
if (debug_level >= psb_debug_outer_) & if (debug_level >= psb_debug_outer_) &
@ -165,7 +163,7 @@ subroutine mld_zaggrmat_biz_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_restr
! !
! Build the filtered matrix Af from A ! 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 tmp = zzero
@ -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) ! 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 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 goto 9999
end if end if
call psb_numbmm(acsrf,ptilde,acsr1)
if (debug_level >= psb_debug_outer_) & if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),& & write(debug_unit,*) me,' ',trim(name),&
& 'Done NUMBMM 1' & 'Done SPSPMM 1'
else 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) ! 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 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 goto 9999
end if end if
call psb_numbmm(acsr3,ptilde,acsr1)
if (debug_level >= psb_debug_outer_) & if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),& & write(debug_unit,*) me,' ',trim(name),&
& 'Done NUMBMM 1' & 'Done SPSPMM 1'
end if end if
call ptilde%free() 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 goto 9999
end if end if
call psb_symbmm(a,tmp_prol,am3,info) call psb_spspmm(la,tmp_prol,am3,info)
if(info /= psb_success_) then 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 goto 9999
end if end if
call psb_numbmm(a,tmp_prol,am3)
if (debug_level >= psb_debug_outer_) & if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),& & 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) call tmp_prol%transp(op_restr)
if (debug_level >= psb_debug_outer_) & 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 goto 9999
end if end if
if (debug_level >= psb_debug_outer_) & if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),& & write(debug_unit,*) me,' ',trim(name),&
& 'starting symbmm 3' & 'starting spspmm 3'
call psb_symbmm(op_restr,am3,ac,info) call psb_spspmm(op_restr,am3,ac,info)
if (info == psb_success_) call psb_numbmm(op_restr,am3,ac)
if (info == psb_success_) call am3%free() 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 if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,a_err='Build b = op_restr x am3') call psb_errpush(psb_err_internal_error_,name,a_err='Build b = op_restr x am3')
goto 9999 goto 9999
end if end if
if (debug_level >= psb_debug_outer_) & if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),& & write(debug_unit,*) me,' ',trim(name),&
& 'Done smooth_aggregate ' & 'Done smooth_aggregate '

120
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 ! Arguments
type(psb_zspmat_type), intent(in) :: a type(psb_zspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_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(mld_dml_parms), intent(inout) :: parms
type(psb_zspmat_type), intent(inout) :: op_prol type(psb_lzspmat_type), intent(inout) :: op_prol
type(psb_zspmat_type), intent(out) :: ac,op_restr type(psb_lzspmat_type), intent(out) :: ac,op_restr
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
! Local variables ! Local variables
integer(psb_ipk_), allocatable :: nzbr(:), idisp(:) integer(psb_lpk_) :: nrow, nglob, ncol, ntaggr, nzac, ip, ndx,&
integer(psb_ipk_) :: nrow, nglob, ncol, ntaggr, nzac, ip, ndx,& & naggr, nzl,naggrm1,naggrp1, i, j, k, jd, icolF, nrt
& naggr, nzl,naggrm1,naggrp1, i, j, k, jd, icolF, nrt, err_act
integer(psb_ipk_) :: ictxt,np,me, icomm integer(psb_ipk_) :: ictxt,np,me, icomm
character(len=20) :: name character(len=20) :: name
type(psb_zspmat_type) :: af, ptilde, rtilde, atran, atp, atdatp type(psb_lzspmat_type) :: la, af, ptilde, rtilde, atran, atp, atdatp
type(psb_zspmat_type) :: am3,am4, ap, adap,atmp,rada, ra, atmp2, dap, dadap, da type(psb_lzspmat_type) :: am3,am4, ap, adap,atmp,rada, ra, atmp2, dap, dadap, da
type(psb_zspmat_type) :: dat, datp, datdatp, atmp3, tmp_prol type(psb_lzspmat_type) :: dat, datp, datdatp, atmp3, tmp_prol
type(psb_z_coo_sparse_mat) :: tmpcoo type(psb_lz_coo_sparse_mat) :: tmpcoo
type(psb_z_csr_sparse_mat) :: acsr1, acsr2, acsr3, acsr, acsrf type(psb_lz_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_lz_csc_sparse_mat) :: csc_dap, csc_dadap, csc_datp, csc_datdatp, acsc
complex(psb_dpk_), allocatable :: adiag(:), adinv(:) complex(psb_dpk_), allocatable :: adiag(:), adinv(:)
complex(psb_dpk_), allocatable :: omf(:), omp(:), omi(:), oden(:) complex(psb_dpk_), allocatable :: omf(:), omp(:), omi(:), oden(:)
logical :: filter_mat logical :: filter_mat
integer(psb_ipk_) :: ierr(5) 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 integer(psb_ipk_), parameter :: ncmax=16
real(psb_dpk_) :: anorm, theta real(psb_dpk_) :: anorm, theta
complex(psb_dpk_) :: tmp, alpha, beta, ommx 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) naggr = nlaggr(me+1)
ntaggr = sum(nlaggr) 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)) naggrm1 = sum(nlaggr(1:me))
naggrp1 = sum(nlaggr(1:me+1)) 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) & call psb_realloc(ncol,adiag,info)
if (info == psb_success_) & if (info == psb_success_) &
& call psb_halo(adiag,desc_a,info) & 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) do i=1,size(adiag)
if (adiag(i) /= zzero) then 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 if
end do 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 ! 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%mv_from(tmpcoo)
call ptilde%cscnv(info,type='csr') 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 la%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(da,info,type='csr',dupl=psb_dupl_add_)
if (info /= psb_success_) then if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='spcnv') call psb_errpush(psb_err_from_subroutine_,name,a_err='spcnv')
goto 9999 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 da%scal(adinv,info)
call psb_symbmm(da,ptilde,dap,info) call psb_spspmm(da,ptilde,dap,info)
if (info == psb_success_) call psb_numbmm(da,ptilde,dap)
if(info /= psb_success_) then 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 goto 9999
end if 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 psb_rwextd(ncol,atmp,info,b=am4)
if (info == psb_success_) call am4%free() if (info == psb_success_) call am4%free()
call psb_symbmm(da,atmp,dadap,info) call psb_spspmm(da,atmp,dadap,info)
call psb_numbmm(da,atmp,dadap)
call atmp%free() call atmp%free()
! !$ write(0,*) 'Columns of AP',psb_sp_get_ncols(ap) ! !$ 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 dap%mv_to(csc_dap)
call dadap%mv_to(csc_dadap) call dadap%mv_to(csc_dadap)
call csc_mat_col_prod(csc_dap,csc_dadap,omp,info) call csc_mat_col_prod(csc_dap,csc_dadap,omp,info)
call csc_mat_col_prod(csc_dadap,csc_dadap,oden,info) call csc_mat_col_prod(csc_dadap,csc_dadap,oden,info)
call psb_sum(ictxt,omp) 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 ! 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 do i=1,nrow
tmp = zzero 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) call af%mv_from(acsrf)
! !
! Symbmm90 does the allocation for its result.
!
! op_prol = (I-w*D*Af)Ptilde ! op_prol = (I-w*D*Af)Ptilde
! Doing it this way means to consider diag(Af_i) ! Doing it this way means to consider diag(Af_i)
! !
! !
call psb_symbmm(af,ptilde,op_prol,info) call psb_spspmm(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)
if (debug_level >= psb_debug_outer_) & if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),& & write(debug_unit,*) me,' ',trim(name),&
& 'Done NUMBMM 1' & 'Done SPSPMM 1'
else else
! !
! Build the smoothed prolongator using the original matrix ! 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),& & write(debug_unit,*) me,' ',trim(name),&
& 'Done gather, going for SYMBMM 1' & 'Done gather, going for SYMBMM 1'
! !
! Symbmm90 does the allocation for its result.
! !
! op_prol = (I-w*D*A)Ptilde ! op_prol = (I-w*D*A)Ptilde
! !
! !
call psb_symbmm(am3,ptilde,op_prol,info) call psb_spspmm(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)
if (debug_level >= psb_debug_outer_) & if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),& & write(debug_unit,*) me,' ',trim(name),&
& 'Done NUMBMM 1' & '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 ! Ok, let's start over with the restrictor
! !
call ptilde%transc(rtilde) 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,& call psb_sphalo(atmp,desc_a,am4,info,&
& colcnv=.true.,rowscale=.true.) & colcnv=.true.,rowscale=.true.)
nrt = am4%get_nrows() 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') call atmp2%cscnv(info,type='CSR')
if (info == psb_success_) call psb_rwextd(ncol,atmp,info,b=atmp2) if (info == psb_success_) call psb_rwextd(ncol,atmp,info,b=atmp2)
call am4%free() 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 ! This is to compute the transpose. It ONLY works if the
! original A has a symmetric pattern. ! original A has a symmetric pattern.
call atmp%transc(atmp2) 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%cscnv(info,type='csr')
call dat%scal(adinv,info) call dat%scal(adinv,info)
! Now for the product. ! Now for the product.
call psb_symbmm(dat,ptilde,datp,info) call psb_spspmm(dat,ptilde,datp,info)
if (info == psb_success_) call psb_numbmm(dat,ptilde,datp)
call datp%clone(atmp2,info) call datp%clone(atmp2,info)
call psb_sphalo(atmp2,desc_a,am4,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%mv_from(tmpcoo)
call rtilde%cscnv(info,type='csr') call rtilde%cscnv(info,type='csr')
call psb_symbmm(rtilde,atmp,op_restr,info) call psb_spspmm(rtilde,atmp,op_restr,info)
call psb_numbmm(rtilde,atmp,op_restr)
! !
! Now we have to gather the halo of op_prol, and add it to itself ! 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),& & write(debug_unit,*) me,' ',trim(name),&
& 'starting sphalo/ rwxtd' & 'starting sphalo/ rwxtd'
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')
goto 9999
end if
call psb_numbmm(a,tmp_prol,am3)
if (debug_level >= psb_debug_outer_) & if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),& & write(debug_unit,*) me,' ',trim(name),&
& 'Done NUMBMM 2' & 'Done SPSPMM 2'
call psb_sphalo(am3,desc_a,am4,info,& call psb_sphalo(am3,desc_a,am4,info,&
& colcnv=.false.,rowscale=.true.) & 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),& & write(debug_unit,*) me,' ',trim(name),&
& 'Done sphalo/ rwxtd' & 'Done sphalo/ rwxtd'
call psb_symbmm(op_restr,am3,ac,info) call psb_spspmm(op_restr,am3,ac,info)
if (info == psb_success_) call psb_numbmm(op_restr,am3,ac)
if (info == psb_success_) call am3%free() 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='coo',dupl=psb_dupl_add_)
@ -587,11 +551,11 @@ contains
subroutine csc_mat_col_prod(a,b,v,info) subroutine csc_mat_col_prod(a,b,v,info)
implicit none 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(:) complex(psb_dpk_), intent(out) :: v(:)
integer(psb_ipk_), intent(out) :: info 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_ info = psb_success_
nc = a%get_ncols() nc = a%get_ncols()
@ -615,11 +579,11 @@ contains
subroutine csr_mat_row_prod(a,b,v,info) subroutine csr_mat_row_prod(a,b,v,info)
implicit none 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(:) complex(psb_dpk_), intent(out) :: v(:)
integer(psb_ipk_), intent(out) :: info 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_ info = psb_success_
nr = a%get_nrows() nr = a%get_nrows()
@ -643,12 +607,12 @@ contains
function sparse_srtd_dot(nv1,iv1,v1,nv2,iv2,v2) result(dot) function sparse_srtd_dot(nv1,iv1,v1,nv2,iv2,v2) result(dot)
implicit none implicit none
integer(psb_ipk_), intent(in) :: nv1,nv2 integer(psb_lpk_), intent(in) :: nv1,nv2
integer(psb_ipk_), intent(in) :: iv1(:), iv2(:) integer(psb_lpk_), intent(in) :: iv1(:), iv2(:)
complex(psb_dpk_), intent(in) :: v1(:),v2(:) complex(psb_dpk_), intent(in) :: v1(:),v2(:)
complex(psb_dpk_) :: dot complex(psb_dpk_) :: dot
integer(psb_ipk_) :: i,j,k, ip1, ip2 integer(psb_lpk_) :: i,j,k, ip1, ip2
dot = zzero dot = zzero
ip1 = 1 ip1 = 1
@ -671,7 +635,7 @@ contains
end function sparse_srtd_dot end function sparse_srtd_dot
subroutine local_dump(me,mat,name,header) 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 integer(psb_ipk_), intent(in) :: me
character(len=*), intent(in) :: name character(len=*), intent(in) :: name
character(len=*), intent(in) :: header character(len=*), intent(in) :: header

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

@ -106,21 +106,22 @@ subroutine mld_zaggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_re
! Arguments ! Arguments
type(psb_zspmat_type), intent(in) :: a type(psb_zspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_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(mld_dml_parms), intent(inout) :: parms
type(psb_zspmat_type), intent(inout) :: op_prol type(psb_lzspmat_type), intent(inout) :: op_prol
type(psb_zspmat_type), intent(out) :: ac,op_restr type(psb_lzspmat_type), intent(out) :: ac,op_restr
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
! Local variables ! Local variables
integer(psb_ipk_) :: err_act 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 character(len=20) :: name
integer(psb_ipk_) :: ierr(5) integer(psb_ipk_) :: ierr(5)
type(psb_z_coo_sparse_mat) :: ac_coo, tmpcoo type(psb_lzspmat_type) :: la
type(psb_z_csr_sparse_mat) :: acsr1, acsr2 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_) :: 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 & naggr, nzt, naggrm1, naggrp1, i, k
name = 'mld_aggrmat_nosmth_asb' name = 'mld_aggrmat_nosmth_asb'
@ -137,7 +138,6 @@ subroutine mld_zaggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_re
nrow = desc_a%get_local_rows() nrow = desc_a%get_local_rows()
ncol = desc_a%get_local_cols() ncol = desc_a%get_local_cols()
naggr = nlaggr(me+1) naggr = nlaggr(me+1)
ntaggr = sum(nlaggr) ntaggr = sum(nlaggr)
naggrm1 = sum(nlaggr(1:me)) naggrm1 = sum(nlaggr(1:me))
@ -148,12 +148,12 @@ subroutine mld_zaggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_re
call op_prol%cscnv(info,type='csr',dupl=psb_dupl_add_) call op_prol%cscnv(info,type='csr',dupl=psb_dupl_add_)
call tmpcoo%transp() 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 ! 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(:) ! are those corresponding to "local" aggregates, i.e. indices in ilaggr(:)
! !
nzl = tmpcoo%get_nzeros()
i = 0
do k = 1, nzl do k = 1, nzl
if ((naggrm1 < tmpcoo%ia(k)) .and.(tmpcoo%ia(k) <= naggrp1)) then if ((naggrm1 < tmpcoo%ia(k)) .and.(tmpcoo%ia(k) <= naggrp1)) then
i = i+1 i = i+1
@ -169,8 +169,8 @@ subroutine mld_zaggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_re
if (info /= psb_success_) goto 9999 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() nzt = ac_coo%get_nzeros()
k = 0 k = 0
do i = 1, nzt do i = 1, nzt

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

@ -126,7 +126,7 @@ subroutine mld_zaggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_rest
integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), intent(out) :: info
! Local variables ! 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 & 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 character(len=20) :: name
@ -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_unit = psb_get_debug_unit()
debug_level = psb_get_debug_level() debug_level = psb_get_debug_level()
ictxt = desc_a%get_context()
ictxt = desc_a%get_context() ictxt = desc_a%get_context()
call psb_info(ictxt, me, np) call psb_info(ictxt, me, np)

Write Preview
Loading…
Cancel
Save