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

mld2p4

Browse Source 
Merged data type restructuring from prectype branch.
stopcriterion
Salvatore Filippone 16 years ago
parent f11d4fba3a
commit d4e7e9e0f1
48 changed files with 2763 additions and 2605 deletions
Show Stats Download Patch File Download Diff File

25
mlprec/mld_caggrmat_asb.f90
Unescape Escape View File

@ -52,7 +52,7 @@
! adjacency graph of A_C has been computed by the mld_aggrmap_bld subroutine.
! The prolongator P_C is built here from this mapping, according to the
! value of p%iprcparm(mld_aggr_kind_), specified by the user through
! mld_dprecinit and mld_dprecset.
! mld_cprecinit and mld_cprecset.
!
! Currently three different prolongators are implemented, corresponding to
! three aggregation algorithms:
@ -76,24 +76,21 @@
! 1181-1196.
!
!
!
! Arguments:
! a - type(psb_cspmat_type), input.
! The sparse matrix structure containing the local part of
! the fine-level matrix.
! desc_a - type(psb_desc_type), input.
! The communication descriptor of the fine-level matrix.
! ac - type(psb_cspmat_type), output.
! The sparse matrix structure containing the local part of
! the coarse-level matrix.
! desc_ac - type(psb_desc_type), output.
! The communication descriptor of the coarse-level matrix.
! p - type(mld_cbaseprc_type), input/output.
! The base preconditioner data structure containing the local
! part of the base preconditioner to be built.
! p - type(mld_c_onelev_prec_type), input/output.
! The one-level preconditioner data structure containing the local
! part of the base preconditioner to be built as well as the
! aggregate matrices.
! info - integer, output.
! Error code.
!
subroutine mld_caggrmat_asb(a,desc_a,ac,desc_ac,p,info)
subroutine mld_caggrmat_asb(a,desc_a,p,info)
use psb_base_mod
use mld_inner_mod, mld_protect_name => mld_caggrmat_asb
@ -103,9 +100,7 @@ subroutine mld_caggrmat_asb(a,desc_a,ac,desc_ac,p,info)
! Arguments
type(psb_cspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_a
type(psb_cspmat_type), intent(out) :: ac
type(psb_desc_type), intent(out) :: desc_ac
type(mld_cbaseprc_type), intent(inout), target :: p
type(mld_c_onelev_prec_type), intent(inout), target :: p
integer, intent(out) :: info
! Local variables
@ -125,7 +120,7 @@ subroutine mld_caggrmat_asb(a,desc_a,ac,desc_ac,p,info)
select case (p%iprcparm(mld_aggr_kind_))
case (mld_no_smooth_)
call mld_aggrmat_raw_asb(a,desc_a,ac,desc_ac,p,info)
call mld_aggrmat_raw_asb(a,desc_a,p,info)
if(info /= 0) then
call psb_errpush(4010,name,a_err='mld_aggrmat_raw_asb')
goto 9999
@ -133,7 +128,7 @@ subroutine mld_caggrmat_asb(a,desc_a,ac,desc_ac,p,info)
case(mld_smooth_prol_,mld_biz_prol_)
call mld_aggrmat_smth_asb(a,desc_a,ac,desc_ac,p,info)
call mld_aggrmat_smth_asb(a,desc_a,p,info)
if(info /= 0) then
call psb_errpush(4010,name,a_err='mld_aggrmat_smth_asb')
goto 9999

74
mlprec/mld_caggrmat_raw_asb.F90
Unescape Escape View File

@ -51,7 +51,7 @@
!
! The coarse-level matrix A_C is distributed among the parallel processes or
! replicated on each of them, according to the value of p%iprcparm(mld_coarse_mat_),
! specified by the user through mld_dprecinit and mld_dprecset.
! specified by the user through mld_cprecinit and mld_cprecset.
!
! For details see
! P. D'Ambra, D. di Serafino and S. Filippone, On the development of
@ -59,24 +59,21 @@
! 57 (2007), 1181-1196.
!
!
!
! Arguments:
! a - type(psb_cspmat_type), input.
! The sparse matrix structure containing the local part of
! the fine-level matrix.
! desc_a - type(psb_desc_type), input.
! The communication descriptor of the fine-level matrix.
! ac - type(psb_cspmat_type), output.
! The sparse matrix structure containing the local part of
! the coarse-level matrix.
! desc_ac - type(psb_desc_type), output.
! The communication descriptor of the coarse-level matrix.
! p - type(mld_cbaseprc_type), input/output.
! The base preconditioner data structure containing the local
! part of the base preconditioner to be built.
! p - type(mld_c_onelev_prec_type), input/output.
! The one-level preconditioner data structure containing the local
! part of the base preconditioner to be built as well as the
! aggregate matrices.
! info - integer, output.
! Error code.
!
subroutine mld_caggrmat_raw_asb(a,desc_a,ac,desc_ac,p,info)
subroutine mld_caggrmat_raw_asb(a,desc_a,p,info)
use psb_base_mod
use mld_inner_mod, mld_protect_name => mld_caggrmat_raw_asb
@ -91,17 +88,15 @@ subroutine mld_caggrmat_raw_asb(a,desc_a,ac,desc_ac,p,info)
! Arguments
type(psb_cspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_a
type(psb_cspmat_type), intent(out) :: ac
type(psb_desc_type), intent(out) :: desc_ac
type(mld_cbaseprc_type), intent(inout), target :: p
type(mld_c_onelev_prec_type), intent(inout), target :: p
integer, intent(out) :: info
! Local variables
integer ::ictxt,np,me, err_act, icomm
character(len=20) :: name
type(psb_cspmat_type) :: b
integer, pointer :: nzbr(:), idisp(:)
type(psb_cspmat_type), pointer :: am1,am2
integer, allocatable :: nzbr(:), idisp(:)
type(psb_cspmat_type) :: am1,am2
integer :: nrow, nglob, ncol, ntaggr, nzac, ip, ndx,&
& naggr, nzt,naggrm1, i
@ -119,9 +114,6 @@ subroutine mld_caggrmat_raw_asb(a,desc_a,ac,desc_ac,p,info)
nrow = psb_cd_get_local_rows(desc_a)
ncol = psb_cd_get_local_cols(desc_a)
am2 => p%av(mld_sm_pr_t_)
am1 => p%av(mld_sm_pr_)
call psb_nullify_sp(am1)
call psb_nullify_sp(am2)
@ -195,7 +187,7 @@ subroutine mld_caggrmat_raw_asb(a,desc_a,ac,desc_ac,p,info)
if (p%iprcparm(mld_coarse_mat_) == mld_repl_mat_) then
call psb_cdall(ictxt,desc_ac,info,mg=ntaggr,repl=.true.)
call psb_cdall(ictxt,p%desc_ac,info,mg=ntaggr,repl=.true.)
if(info /= 0) then
call psb_errpush(4010,name,a_err='psb_cdall')
goto 9999
@ -206,7 +198,7 @@ subroutine mld_caggrmat_raw_asb(a,desc_a,ac,desc_ac,p,info)
call psb_sum(ictxt,nzbr(1:np))
nzac = sum(nzbr)
call psb_sp_all(ntaggr,ntaggr,ac,nzac,info)
call psb_sp_all(ntaggr,ntaggr,p%ac,nzac,info)
if(info /= 0) then
call psb_errpush(4010,name,a_err='sp_all')
goto 9999
@ -217,11 +209,11 @@ subroutine mld_caggrmat_raw_asb(a,desc_a,ac,desc_ac,p,info)
enddo
ndx = nzbr(me+1)
call mpi_allgatherv(b%aspk,ndx,mpi_complex,ac%aspk,nzbr,idisp,&
call mpi_allgatherv(b%aspk,ndx,mpi_complex,p%ac%aspk,nzbr,idisp,&
& mpi_complex,icomm,info)
call mpi_allgatherv(b%ia1,ndx,mpi_integer,ac%ia1,nzbr,idisp,&
call mpi_allgatherv(b%ia1,ndx,mpi_integer,p%ac%ia1,nzbr,idisp,&
& mpi_integer,icomm,info)
call mpi_allgatherv(b%ia2,ndx,mpi_integer,ac%ia2,nzbr,idisp,&
call mpi_allgatherv(b%ia2,ndx,mpi_integer,p%ac%ia2,nzbr,idisp,&
& mpi_integer,icomm,info)
if(info /= 0) then
info=-1
@ -229,12 +221,12 @@ subroutine mld_caggrmat_raw_asb(a,desc_a,ac,desc_ac,p,info)
goto 9999
end if
ac%m = ntaggr
ac%k = ntaggr
ac%infoa(psb_nnz_) = nzac
ac%fida='COO'
ac%descra='GUN'
call psb_spcnv(ac,info,afmt='coo',dupl=psb_dupl_add_)
p%ac%m = ntaggr
p%ac%k = ntaggr
p%ac%infoa(psb_nnz_) = nzac
p%ac%fida='COO'
p%ac%descra='GUN'
call psb_spcnv(p%ac,info,afmt='coo',dupl=psb_dupl_add_)
if(info /= 0) then
call psb_errpush(4010,name,a_err='sp_free')
goto 9999
@ -242,9 +234,9 @@ subroutine mld_caggrmat_raw_asb(a,desc_a,ac,desc_ac,p,info)
else if (p%iprcparm(mld_coarse_mat_) == mld_distr_mat_) then
call psb_cdall(ictxt,desc_ac,info,nl=naggr)
if (info == 0) call psb_cdasb(desc_ac,info)
if (info == 0) call psb_sp_clone(b,ac,info)
call psb_cdall(ictxt,p%desc_ac,info,nl=naggr)
if (info == 0) call psb_cdasb(p%desc_ac,info)
if (info == 0) call psb_sp_clone(b,p%ac,info)
if(info /= 0) then
call psb_errpush(4001,name,a_err='Build ac, desc_ac')
goto 9999
@ -263,9 +255,23 @@ subroutine mld_caggrmat_raw_asb(a,desc_a,ac,desc_ac,p,info)
deallocate(nzbr,idisp)
call psb_spcnv(ac,info,afmt='csr',dupl=psb_dupl_add_)
call psb_spcnv(p%ac,info,afmt='csr',dupl=psb_dupl_add_)
if(info /= 0) then
call psb_errpush(4010,name,a_err='spcnv')
goto 9999
end if
!
! Copy the prolongation/restriction matrices into the descriptor map.
! am2 => PR^T i.e. restriction operator
! am1 => PR i.e. prolongation operator
!
p%map_desc = psb_inter_desc(psb_map_aggr_,desc_a,&
& p%desc_ac,am2,am1)
if (info == 0) call psb_sp_free(am1,info)
if (info == 0) call psb_sp_free(am2,info)
if(info /= 0) then
call psb_errpush(4010,name,a_err='ipcoo2csr')
call psb_errpush(4010,name,a_err='sp_Free')
goto 9999
end if

133
mlprec/mld_caggrmat_smth_asb.F90
Unescape Escape View File

@ -83,18 +83,14 @@
! the fine-level matrix.
! desc_a - type(psb_desc_type), input.
! The communication descriptor of the fine-level matrix.
! ac - type(psb_cspmat_type), output.
! The sparse matrix structure containing the local part of
! the coarse-level matrix.
! desc_ac - type(psb_desc_type), output.
! The communication descriptor of the coarse-level matrix.
! p - type(mld_cbaseprc_type), input/output.
! The base preconditioner data structure containing the local
! part of the base preconditioner to be built.
! p - type(mld_c_onelev_prec_type), input/output.
! The one-level preconditioner data structure containing the local
! part of the base preconditioner to be built as well as the
! aggregate matrices.
! info - integer, output.
! Error code.
!
subroutine mld_caggrmat_smth_asb(a,desc_a,ac,desc_ac,p,info)
subroutine mld_caggrmat_smth_asb(a,desc_a,p,info)
use psb_base_mod
use mld_inner_mod, mld_protect_name => mld_caggrmat_smth_asb
@ -109,19 +105,17 @@ subroutine mld_caggrmat_smth_asb(a,desc_a,ac,desc_ac,p,info)
! Arguments
type(psb_cspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_a
type(psb_cspmat_type), intent(out) :: ac
type(psb_desc_type), intent(out) :: desc_ac
type(mld_cbaseprc_type), intent(inout), target :: p
type(mld_c_onelev_prec_type), intent(inout), target :: p
integer, intent(out) :: info
! Local variables
type(psb_cspmat_type) :: b
integer, pointer :: nzbr(:), idisp(:)
integer, allocatable :: nzbr(:), idisp(:)
integer :: nrow, nglob, ncol, ntaggr, nzac, ip, ndx,&
& naggr, nzl,naggrm1,naggrp1, i, j, k
integer ::ictxt,np,me, err_act, icomm
character(len=20) :: name
type(psb_cspmat_type), pointer :: am1,am2
type(psb_cspmat_type) :: am1,am2
type(psb_cspmat_type) :: am3,am4
complex(psb_spk_), allocatable :: adiag(:)
logical :: ml_global_nmb
@ -146,9 +140,6 @@ subroutine mld_caggrmat_smth_asb(a,desc_a,ac,desc_ac,p,info)
call psb_nullify_sp(b)
call psb_nullify_sp(am3)
call psb_nullify_sp(am4)
am2 => p%av(mld_sm_pr_t_)
am1 => p%av(mld_sm_pr_)
call psb_nullify_sp(am1)
call psb_nullify_sp(am2)
@ -191,7 +182,7 @@ subroutine mld_caggrmat_smth_asb(a,desc_a,ac,desc_ac,p,info)
if (info /= 0) then
info=4025
call psb_errpush(info,name,i_err=(/nrow,0,0,0,0/),&
& a_err='real(psb_spk_)')
& a_err='complex(psb_spk_)')
goto 9999
end if
@ -263,7 +254,6 @@ subroutine mld_caggrmat_smth_asb(a,desc_a,ac,desc_ac,p,info)
if (p%iprcparm(mld_aggr_omega_alg_) == mld_eig_est_) then
if (p%iprcparm(mld_aggr_eig_) == mld_max_norm_) then
if (p%iprcparm(mld_aggr_kind_) == mld_biz_prol_) then
@ -286,13 +276,13 @@ subroutine mld_caggrmat_smth_asb(a,desc_a,ac,desc_ac,p,info)
end do
anorm = max(anorm,tmp/dg)
enddo
call psb_amx(ictxt,anorm)
else
info = 4001
call psb_errpush(info,name,a_err='this section only CSR')
goto 9999
endif
call psb_amx(ictxt,anorm)
else
anorm = psb_spnrmi(am3,desc_a,info)
endif
@ -457,16 +447,16 @@ subroutine mld_caggrmat_smth_asb(a,desc_a,ac,desc_ac,p,info)
case(mld_distr_mat_)
call psb_sp_clone(b,ac,info)
nzac = ac%infoa(psb_nnz_)
nzl = ac%infoa(psb_nnz_)
if (info == 0) call psb_cdall(ictxt,desc_ac,info,nl=p%nlaggr(me+1))
if (info == 0) call psb_cdins(nzl,ac%ia1,ac%ia2,desc_ac,info)
if (info == 0) call psb_cdasb(desc_ac,info)
if (info == 0) call psb_glob_to_loc(ac%ia1(1:nzl),desc_ac,info,iact='I')
if (info == 0) call psb_glob_to_loc(ac%ia2(1:nzl),desc_ac,info,iact='I')
call psb_sp_clone(b,p%ac,info)
nzac = p%ac%infoa(psb_nnz_)
nzl = p%ac%infoa(psb_nnz_)
if (info == 0) call psb_cdall(ictxt,p%desc_ac,info,nl=p%nlaggr(me+1))
if (info == 0) call psb_cdins(nzl,p%ac%ia1,p%ac%ia2,p%desc_ac,info)
if (info == 0) call psb_cdasb(p%desc_ac,info)
if (info == 0) call psb_glob_to_loc(p%ac%ia1(1:nzl),p%desc_ac,info,iact='I')
if (info == 0) call psb_glob_to_loc(p%ac%ia2(1:nzl),p%desc_ac,info,iact='I')
if (info /= 0) then
call psb_errpush(4001,name,a_err='Creating desc_ac and converting ac')
call psb_errpush(4001,name,a_err='Creating p%desc_ac and converting ac')
goto 9999
end if
if (debug_level >= psb_debug_outer_) &
@ -474,10 +464,10 @@ subroutine mld_caggrmat_smth_asb(a,desc_a,ac,desc_ac,p,info)
& 'Assembld aux descr. distr.'
ac%m=desc_ac%matrix_data(psb_n_row_)
ac%k=desc_ac%matrix_data(psb_n_col_)
ac%fida='COO'
ac%descra='GUN'
p%ac%m=psb_cd_get_local_rows(p%desc_ac)
p%ac%k=psb_cd_get_local_cols(p%desc_ac)
p%ac%fida='COO'
p%ac%descra='GUN'
call psb_sp_free(b,info)
if (info == 0) deallocate(nzbr,idisp,stat=info)
@ -488,25 +478,25 @@ subroutine mld_caggrmat_smth_asb(a,desc_a,ac,desc_ac,p,info)
if (np>1) then
nzl = psb_sp_get_nnzeros(am1)
call psb_glob_to_loc(am1%ia1(1:nzl),desc_ac,info,'I')
call psb_glob_to_loc(am1%ia1(1:nzl),p%desc_ac,info,'I')
if(info /= 0) then
call psb_errpush(4010,name,a_err='psb_glob_to_loc')
goto 9999
end if
endif
am1%k=desc_ac%matrix_data(psb_n_col_)
am1%k=psb_cd_get_local_cols(p%desc_ac)
if (np>1) then
call psb_spcnv(am2,info,afmt='coo',dupl=psb_dupl_add_)
nzl = am2%infoa(psb_nnz_)
if (info == 0) call psb_glob_to_loc(am2%ia1(1:nzl),desc_ac,info,'I')
if (info == 0) call psb_glob_to_loc(am2%ia1(1:nzl),p%desc_ac,info,'I')
if (info == 0) call psb_spcnv(am2,info,afmt='csr',dupl=psb_dupl_add_)
if(info /= 0) then
call psb_errpush(4001,name,a_err='Converting am2 to local')
goto 9999
end if
end if
am2%m=desc_ac%matrix_data(psb_n_col_)
am2%m=psb_cd_get_local_cols(p%desc_ac)
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
@ -515,13 +505,13 @@ subroutine mld_caggrmat_smth_asb(a,desc_a,ac,desc_ac,p,info)
case(mld_repl_mat_)
!
!
call psb_cdall(ictxt,desc_ac,info,mg=ntaggr,repl=.true.)
call psb_cdall(ictxt,p%desc_ac,info,mg=ntaggr,repl=.true.)
nzbr(:) = 0
nzbr(me+1) = b%infoa(psb_nnz_)
call psb_sum(ictxt,nzbr(1:np))
nzac = sum(nzbr)
if (info == 0) call psb_sp_all(ntaggr,ntaggr,ac,nzac,info)
if (info == 0) call psb_sp_all(ntaggr,ntaggr,p%ac,nzac,info)
if (info /= 0) goto 9999
do ip=1,np
@ -529,11 +519,11 @@ subroutine mld_caggrmat_smth_asb(a,desc_a,ac,desc_ac,p,info)
enddo
ndx = nzbr(me+1)
call mpi_allgatherv(b%aspk,ndx,mpi_complex,ac%aspk,nzbr,idisp,&
call mpi_allgatherv(b%aspk,ndx,mpi_complex,p%ac%aspk,nzbr,idisp,&
& mpi_complex,icomm,info)
if (info == 0) call mpi_allgatherv(b%ia1,ndx,mpi_integer,ac%ia1,nzbr,idisp,&
if (info == 0) call mpi_allgatherv(b%ia1,ndx,mpi_integer,p%ac%ia1,nzbr,idisp,&
& mpi_integer,icomm,info)
if (info == 0) call mpi_allgatherv(b%ia2,ndx,mpi_integer,ac%ia2,nzbr,idisp,&
if (info == 0) call mpi_allgatherv(b%ia2,ndx,mpi_integer,p%ac%ia2,nzbr,idisp,&
& mpi_integer,icomm,info)
if (info /= 0) then
@ -541,12 +531,12 @@ subroutine mld_caggrmat_smth_asb(a,desc_a,ac,desc_ac,p,info)
goto 9999
end if
ac%m = ntaggr
ac%k = ntaggr
ac%infoa(psb_nnz_) = nzac
ac%fida='COO'
ac%descra='GUN'
call psb_spcnv(ac,info,afmt='coo',dupl=psb_dupl_add_)
p%ac%m = ntaggr
p%ac%k = ntaggr
p%ac%infoa(psb_nnz_) = nzac
p%ac%fida='COO'
p%ac%descra='GUN'
call psb_spcnv(p%ac,info,afmt='coo',dupl=psb_dupl_add_)
if(info /= 0) goto 9999
call psb_sp_free(b,info)
if(info /= 0) goto 9999
@ -570,9 +560,9 @@ subroutine mld_caggrmat_smth_asb(a,desc_a,ac,desc_ac,p,info)
case(mld_distr_mat_)
call psb_sp_clone(b,ac,info)
if (info == 0) call psb_cdall(ictxt,desc_ac,info,nl=naggr)
if (info == 0) call psb_cdasb(desc_ac,info)
call psb_sp_clone(b,p%ac,info)
if (info == 0) call psb_cdall(ictxt,p%desc_ac,info,nl=naggr)
if (info == 0) call psb_cdasb(p%desc_ac,info)
if (info == 0) call psb_sp_free(b,info)
if (info /= 0) then
call psb_errpush(4010,name,a_err='Build desc_ac, ac')
@ -583,7 +573,7 @@ subroutine mld_caggrmat_smth_asb(a,desc_a,ac,desc_ac,p,info)
case(mld_repl_mat_)
!
!
call psb_cdall(ictxt,desc_ac,info,mg=ntaggr,repl=.true.)
call psb_cdall(ictxt,p%desc_ac,info,mg=ntaggr,repl=.true.)
if(info /= 0) then
call psb_errpush(4010,name,a_err='psb_cdall')
goto 9999
@ -593,7 +583,7 @@ subroutine mld_caggrmat_smth_asb(a,desc_a,ac,desc_ac,p,info)
nzbr(me+1) = b%infoa(psb_nnz_)
call psb_sum(ictxt,nzbr(1:np))
nzac = sum(nzbr)
call psb_sp_all(ntaggr,ntaggr,ac,nzac,info)
call psb_sp_all(ntaggr,ntaggr,p%ac,nzac,info)
if(info /= 0) then
call psb_errpush(4010,name,a_err='psb_sp_all')
goto 9999
@ -604,11 +594,11 @@ subroutine mld_caggrmat_smth_asb(a,desc_a,ac,desc_ac,p,info)
enddo
ndx = nzbr(me+1)
call mpi_allgatherv(b%aspk,ndx,mpi_complex,ac%aspk,nzbr,idisp,&
call mpi_allgatherv(b%aspk,ndx,mpi_complex,p%ac%aspk,nzbr,idisp,&
& mpi_complex,icomm,info)
if (info == 0) call mpi_allgatherv(b%ia1,ndx,mpi_integer,ac%ia1,nzbr,idisp,&
if (info == 0) call mpi_allgatherv(b%ia1,ndx,mpi_integer,p%ac%ia1,nzbr,idisp,&
& mpi_integer,icomm,info)
if (info == 0) call mpi_allgatherv(b%ia2,ndx,mpi_integer,ac%ia2,nzbr,idisp,&
if (info == 0) call mpi_allgatherv(b%ia2,ndx,mpi_integer,p%ac%ia2,nzbr,idisp,&
& mpi_integer,icomm,info)
if (info /= 0) then
call psb_errpush(4001,name,a_err=' from mpi_allgatherv')
@ -616,12 +606,12 @@ subroutine mld_caggrmat_smth_asb(a,desc_a,ac,desc_ac,p,info)
end if
ac%m = ntaggr
ac%k = ntaggr
ac%infoa(psb_nnz_) = nzac
ac%fida='COO'
ac%descra='GUN'
call psb_spcnv(ac,info,afmt='coo',dupl=psb_dupl_add_)
p%ac%m = ntaggr
p%ac%k = ntaggr
p%ac%infoa(psb_nnz_) = nzac
p%ac%fida='COO'
p%ac%descra='GUN'
call psb_spcnv(p%ac,info,afmt='coo',dupl=psb_dupl_add_)
if(info /= 0) then
call psb_errpush(4010,name,a_err='spcnv')
goto 9999
@ -652,12 +642,27 @@ subroutine mld_caggrmat_smth_asb(a,desc_a,ac,desc_ac,p,info)
end select
call psb_spcnv(ac,info,afmt='csr',dupl=psb_dupl_add_)
call psb_spcnv(p%ac,info,afmt='csr',dupl=psb_dupl_add_)
if(info /= 0) then
call psb_errpush(4010,name,a_err='spcnv')
goto 9999
end if
!
! Copy the prolongation/restriction matrices into the descriptor map.
! am2 => PR^T i.e. restriction operator
! am1 => PR i.e. prolongation operator
!
p%map_desc = psb_inter_desc(psb_map_aggr_,desc_a,&
& p%desc_ac,am2,am1)
if (info == 0) call psb_sp_free(am1,info)
if (info == 0) call psb_sp_free(am2,info)
if(info /= 0) then
call psb_errpush(4010,name,a_err='sp_Free')
goto 9999
end if
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'Done smooth_aggregate '

2
mlprec/mld_cbaseprec_bld.f90
Unescape Escape View File

@ -197,8 +197,6 @@ subroutine mld_cbaseprc_bld(a,desc_a,p,info,upd)
end select
p%base_a => a
p%base_desc => desc_a
p%iprcparm(mld_prec_status_) = mld_prec_built_
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),': Done'

358
mlprec/mld_cmlprec_aply.f90
Unescape Escape View File

@ -46,7 +46,7 @@
! Y = beta*Y + alpha*op(M^(-1))*X,
! where
! - M is a multilevel domain decomposition (Schwarz) preconditioner associated
! to a certain matrix A and stored in the array baseprecv,
! to a certain matrix A and stored in the array precv,
! - op(M^(-1)) is M^(-1) or its transpose, according to the value of trans,
! - X and Y are vectors,
! - alpha and beta are scalars.
@ -55,9 +55,9 @@
! level where we might have a replicated index space) and each process takes care
! of one submatrix.
!
! The multilevel preconditioner M is regarded as an array of 'base preconditioners',
! The multilevel preconditioner M is regarded as an array of 'one-level preconditioners',
! each representing the part of the preconditioner associated to a certain level.
! For each level ilev, the base preconditioner K(ilev) is stored in baseprecv(ilev)
! For each level ilev, the preconditioner K(ilev) is stored in precv(ilev)
! and is associated to a matrix A(ilev), obtained by 'tranferring' the original
! matrix A (i.e. the matrix to be preconditioned) to the level ilev, through smoothed
! aggregation.
@ -78,64 +78,41 @@
! Arguments:
! alpha - complex(psb_spk_), input.
! The scalar alpha.
! baseprecv - type(mld_cbaseprc_type), dimension(:), input.
! The array of base preconditioner data structures containing the
! precv - type(mld_c_onelev_prec_type), dimension(:), input.
! The array of one-level preconditioner data structures containing the
! local parts of the preconditioners to be applied at each level.
! Note that nlev = size(baseprecv) = number of levels.
! baseprecv(ilev)%av - type(psb_cspmat_type), dimension(:), allocatable(:).
! The sparse matrices needed to apply the preconditioner
! at level ilev.
! baseprecv(ilev)%av(mld_l_pr_) - The L factor of the ILU factorization of the
! local diagonal block of A(ilev).
! baseprecv(ilev)%av(mld_u_pr_) - The U factor of the ILU factorization of the
! local diagonal block of A(ilev), except its
! diagonal entries (stored in baseprecv(ilev)%d).
! baseprecv(ilev)%av(mld_ap_nd_) - The entries of the local part of A(ilev)
! outside the diagonal block, for block-Jacobi
! sweeps.
! baseprecv(ilev)%av(mld_ac_) - The local part of the matrix A(ilev).
! baseprecv(ilev)%av(mld_sm_pr_) - The smoothed prolongator.
! It maps vectors (ilev) ---> (ilev-1).
! baseprecv(ilev)%av(mld_sm_pr_t_) - The smoothed prolongator transpose.
! It maps vectors (ilev-1) ---> (ilev).
! baseprecv(ilev)%d - complex(psb_spk_), dimension(:), allocatable.
! The diagonal entries of the U factor in the ILU
! factorization of A(ilev).
! baseprecv(ilev)%desc_data - type(psb_desc_type).
! The communication descriptor associated to the base
! preconditioner, i.e. to the sparse matrices needed
! to apply the base preconditioner at the current level.
! baseprecv(ilev)%desc_ac - type(psb_desc_type).
! Note that nlev = size(precv) = number of levels.
! precv(ilev)%prec - type(psb_cbaseprc_type)
! The "base" preconditioner for the current level
! precv(ilev)%ac - type(psb_cspmat_type)
! The local part of the matrix A(ilev).
! precv(ilev)%desc_ac - type(psb_desc_type).
! The communication descriptor associated to the sparse
! matrix A(ilev), stored in baseprecv(ilev)%av(mld_ac_).
! baseprecv(ilev)%iprcparm - integer, dimension(:), allocatable.
! The integer parameters defining the base
! preconditioner K(ilev).
! baseprecv(ilev)%rprcparm - complex(psb_spk_), dimension(:), allocatable.
! The real parameters defining the base preconditioner
! K(ilev).
! baseprecv(ilev)%perm - integer, dimension(:), allocatable.
! The row and column permutations applied to the local
! part of A(ilev) (defined only if baseprecv(ilev)%
! iprcparm(mld_sub_ren_)>0).
! baseprecv(ilev)%invperm - integer, dimension(:), allocatable.
! The inverse of the permutation stored in
! baseprecv(ilev)%perm.
! baseprecv(ilev)%mlia - integer, dimension(:), allocatable.
! matrix A(ilev)
! precv(ilev)%map_desc - type(psb_inter_desc_type)
! Stores the linear operators mapping between levels
! (ilev-1) and (ilev). These are the restriction and
! prolongation operators described in the sequel.
! precv(ilev)%iprcparm - integer, dimension(:), allocatable.
! The integer parameters defining the multilevel
! strategy
! precv(ilev)%rprcparm - real(psb_spk_), dimension(:), allocatable.
! The real parameters defining the multilevel strategy
! precv(ilev)%mlia - integer, dimension(:), allocatable.
! The aggregation map (ilev-1) --> (ilev).
! In case of non-smoothed aggregation, it is used
! instead of mld_sm_pr_.
! baseprecv(ilev)%nlaggr - integer, dimension(:), allocatable.
! precv(ilev)%nlaggr - integer, dimension(:), allocatable.
! The number of aggregates (rows of A(ilev)) on the
! various processes.
! baseprecv(ilev)%base_a - type(psb_cspmat_type), pointer.
! precv(ilev)%base_a - type(psb_cspmat_type), pointer.
! Pointer (really a pointer!) to the base matrix of
! the current level, i.e. the local part of A(ilev);
! so we have a unified treatment of residuals. We
! need this to avoid passing explicitly the matrix
! A(ilev) to the routine which applies the
! preconditioner.
! baseprecv(ilev)%base_desc - type(psb_desc_type), pointer.
! precv(ilev)%base_desc - type(psb_desc_type), pointer.
! Pointer to the communication descriptor associated
! to the sparse matrix pointed by base_a.
!
@ -159,10 +136,10 @@
! Note that when the LU factorization of the matrix A(ilev) is computed instead of
! the ILU one, by using UMFPACK or SuperLU, the corresponding L and U factors
! are stored in data structures provided by UMFPACK or SuperLU and pointed by
! baseprecv(ilev)%iprcparm(mld_umf_ptr) or baseprecv(ilev)%iprcparm(mld_slu_ptr),
! precv(ilev)%prec%iprcparm(mld_umf_ptr) or precv(ilev)%prec%iprcparm(mld_slu_ptr),
! respectively.
!
subroutine mld_cmlprec_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info)
subroutine mld_cmlprec_aply(alpha,precv,x,beta,y,desc_data,trans,work,info)
use psb_base_mod
use mld_inner_mod, mld_protect_name => mld_cmlprec_aply
@ -171,7 +148,7 @@ subroutine mld_cmlprec_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info)
! Arguments
type(psb_desc_type),intent(in) :: desc_data
type(mld_cbaseprc_type), intent(in) :: baseprecv(:)
type(mld_c_onelev_prec_type), intent(in) :: precv(:)
complex(psb_spk_),intent(in) :: alpha,beta
complex(psb_spk_),intent(in) :: x(:)
complex(psb_spk_),intent(inout) :: y(:)
@ -196,11 +173,11 @@ subroutine mld_cmlprec_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info)
if (debug_level >= psb_debug_inner_) &
& write(debug_unit,*) me,' ',trim(name),&
& ' Entry ', size(baseprecv)
& ' Entry ', size(precv)
trans_ = psb_toupper(trans)
select case(baseprecv(2)%iprcparm(mld_ml_type_))
select case(precv(2)%iprcparm(mld_ml_type_))
case(mld_no_ml_)
!
@ -214,7 +191,7 @@ subroutine mld_cmlprec_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info)
! Additive multilevel
!
call add_ml_aply(alpha,baseprecv,x,beta,y,desc_data,trans_,work,info)
call add_ml_aply(alpha,precv,x,beta,y,desc_data,trans_,work,info)
case(mld_mult_ml_)
!
@ -225,15 +202,15 @@ subroutine mld_cmlprec_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info)
! Note that the transpose switches pre <-> post.
!
select case(baseprecv(2)%iprcparm(mld_smoother_pos_))
select case(precv(2)%iprcparm(mld_smoother_pos_))
case(mld_post_smooth_)
select case (trans_)
case('N')
call mlt_post_ml_aply(alpha,baseprecv,x,beta,y,desc_data,trans_,work,info)
call mlt_post_ml_aply(alpha,precv,x,beta,y,desc_data,trans_,work,info)
case('T','C')
call mlt_pre_ml_aply(alpha,baseprecv,x,beta,y,desc_data,trans_,work,info)
call mlt_pre_ml_aply(alpha,precv,x,beta,y,desc_data,trans_,work,info)
case default
info = 4001
call psb_errpush(info,name,a_err='invalid trans')
@ -244,9 +221,9 @@ subroutine mld_cmlprec_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info)
select case (trans_)
case('N')
call mlt_pre_ml_aply(alpha,baseprecv,x,beta,y,desc_data,trans_,work,info)
call mlt_pre_ml_aply(alpha,precv,x,beta,y,desc_data,trans_,work,info)
case('T','C')
call mlt_post_ml_aply(alpha,baseprecv,x,beta,y,desc_data,trans_,work,info)
call mlt_post_ml_aply(alpha,precv,x,beta,y,desc_data,trans_,work,info)
case default
info = 4001
call psb_errpush(info,name,a_err='invalid trans')
@ -255,12 +232,12 @@ subroutine mld_cmlprec_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info)
case(mld_twoside_smooth_)
call mlt_twoside_ml_aply(alpha,baseprecv,x,beta,y,desc_data,trans_,work,info)
call mlt_twoside_ml_aply(alpha,precv,x,beta,y,desc_data,trans_,work,info)
case default
info = 4013
call psb_errpush(info,name,a_err='invalid smooth_pos',&
& i_Err=(/baseprecv(2)%iprcparm(mld_smoother_pos_),0,0,0,0/))
& i_Err=(/precv(2)%iprcparm(mld_smoother_pos_),0,0,0,0/))
goto 9999
end select
@ -268,7 +245,7 @@ subroutine mld_cmlprec_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info)
case default
info = 4013
call psb_errpush(info,name,a_err='invalid mltype',&
& i_Err=(/baseprecv(2)%iprcparm(mld_ml_type_),0,0,0,0/))
& i_Err=(/precv(2)%iprcparm(mld_ml_type_),0,0,0,0/))
goto 9999
end select
@ -295,7 +272,7 @@ contains
! Y = beta*Y + alpha*op(M^(-1))*X,
! where
! - M is an additive multilevel domain decomposition (Schwarz) preconditioner
! associated to a certain matrix A and stored in the array baseprecv,
! associated to a certain matrix A and stored in the array precv,
! - op(M^(-1)) is M^(-1) or its (conjugate) transpose, according to
! the value of trans,
! - X and Y are vectors,
@ -308,9 +285,9 @@ contains
! level where we might have a replicated index space) and each process takes care
! of one submatrix.
!
! The multilevel preconditioner M is regarded as an array of 'base preconditioners',
! The multilevel preconditioner M is regarded as an array of 'one-level preconditioners',
! each representing the part of the preconditioner associated to a certain level.
! For each level ilev, the base preconditioner K(ilev) is stored in baseprecv(ilev)
! For each level ilev, the base preconditioner K(ilev) is stored in precv(ilev)
! and is associated to a matrix A(ilev), obtained by 'tranferring' the original
! matrix A (i.e. the matrix to be preconditioned) to the level ilev, through smoothed
! aggregation.
@ -324,7 +301,7 @@ contains
! Domain decomposition: parallel multilevel methods for elliptic partial
! differential equations, Cambridge University Press, 1996.
!
! For a description of the arguments see mld_dmlprec_aply.
! For a description of the arguments see mld_cmlprec_aply.
!
! A sketch of the algorithm implemented in this routine is provided below
! (AV(ilev; sm_pr_) denotes the smoothed prolongator from level ilev to
@ -358,13 +335,13 @@ contains
!
! 4. Yext = beta*Yext + alpha*Y(1)
!
subroutine add_ml_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info)
subroutine add_ml_aply(alpha,precv,x,beta,y,desc_data,trans,work,info)
implicit none
! Arguments
type(psb_desc_type),intent(in) :: desc_data
type(mld_cbaseprc_type), intent(in) :: baseprecv(:)
type(mld_c_onelev_prec_type), intent(in) :: precv(:)
complex(psb_spk_),intent(in) :: alpha,beta
complex(psb_spk_),intent(in) :: x(:)
complex(psb_spk_),intent(inout) :: y(:)
@ -373,10 +350,9 @@ contains
integer, intent(out) :: info
! Local variables
integer :: n_row,n_col
integer :: ictxt,np,me,i, nr2l,nc2l,err_act
integer :: debug_level, debug_unit
integer :: ismth, nlev, ilev, icm
integer :: nlev, ilev
character(len=20) :: name
type psb_mlprec_wrk_type
@ -395,9 +371,9 @@ contains
if (debug_level >= psb_debug_inner_) &
& write(debug_unit,*) me,' ',trim(name),&
& ' Entry ', size(baseprecv)
& ' Entry ', size(precv)
nlev = size(baseprecv)
nlev = size(precv)
allocate(mlprec_wrk(nlev),stat=info)
if (info /= 0) then
call psb_errpush(4010,name,a_err='Allocate')
@ -420,9 +396,8 @@ contains
mlprec_wrk(1)%x2l(:) = x(:)
mlprec_wrk(1)%y2l(:) = czero
call mld_baseprec_aply(alpha,baseprecv(1),x,beta,y,&
& baseprecv(1)%base_desc,trans,work,info)
call mld_baseprec_aply(alpha,precv(1)%prec,x,beta,y,&
& precv(1)%base_desc,trans,work,info)
if (info /=0) then
call psb_errpush(4010,name,a_err='baseprec_aply')
goto 9999
@ -433,40 +408,33 @@ contains
! For each level except the finest one ...
!
do ilev = 2, nlev
n_row = psb_cd_get_local_rows(baseprecv(ilev-1)%base_desc)
n_col = psb_cd_get_local_cols(baseprecv(ilev-1)%base_desc)
nc2l = psb_cd_get_local_cols(baseprecv(ilev)%base_desc)
nr2l = psb_cd_get_local_rows(baseprecv(ilev)%base_desc)
nc2l = psb_cd_get_local_cols(precv(ilev)%base_desc)
nr2l = psb_cd_get_local_rows(precv(ilev)%base_desc)
allocate(mlprec_wrk(ilev)%x2l(nc2l),mlprec_wrk(ilev)%y2l(nc2l),&
& stat=info)
if (info /= 0) then
info=4025
call psb_errpush(info,name,i_err=(/2*(nc2l+max(n_row,n_col)),0,0,0,0/),&
call psb_errpush(info,name,i_err=(/2*nc2l,0,0,0,0/),&
& a_err='complex(psb_spk_)')
goto 9999
end if
ismth = baseprecv(ilev)%iprcparm(mld_aggr_kind_)
icm = baseprecv(ilev)%iprcparm(mld_coarse_mat_)
! Apply prolongator transpose, i.e. restriction
call psb_forward_map(cone,mlprec_wrk(ilev-1)%x2l,&
& czero,mlprec_wrk(ilev)%x2l,&
& baseprecv(ilev)%map_desc,info,work=work)
& precv(ilev)%map_desc,info,work=work)
if (info /=0) then
call psb_errpush(4001,name,a_err='Error during restriction')
goto 9999
end if
!
! Apply the base preconditioner
!
call mld_baseprec_aply(cone,baseprecv(ilev),&
call mld_baseprec_aply(cone,precv(ilev)%prec,&
& mlprec_wrk(ilev)%x2l,czero,mlprec_wrk(ilev)%y2l,&
& baseprecv(ilev)%base_desc,trans,work,info)
& precv(ilev)%base_desc,trans,work,info)
enddo
@ -477,19 +445,15 @@ contains
!
do ilev =nlev,2,-1
n_row = psb_cd_get_local_rows(baseprecv(ilev-1)%base_desc)
n_col = psb_cd_get_local_cols(baseprecv(ilev-1)%base_desc)
nc2l = psb_cd_get_local_cols(baseprecv(ilev)%base_desc)
nr2l = psb_cd_get_local_rows(baseprecv(ilev)%base_desc)
ismth = baseprecv(ilev)%iprcparm(mld_aggr_kind_)
icm = baseprecv(ilev)%iprcparm(mld_coarse_mat_)
nc2l = psb_cd_get_local_cols(precv(ilev)%base_desc)
nr2l = psb_cd_get_local_rows(precv(ilev)%base_desc)
!
! Apply prolongator
!
call psb_backward_map(cone,mlprec_wrk(ilev)%y2l,&
& cone,mlprec_wrk(ilev-1)%y2l,&
& baseprecv(ilev)%map_desc,info,work=work)
& precv(ilev)%map_desc,info,work=work)
if (info /=0) then
call psb_errpush(4001,name,a_err='Error during prolongation')
@ -502,7 +466,7 @@ contains
!
! Compute the output vector Y
!
call psb_geaxpby(alpha,mlprec_wrk(1)%y2l,cone,y,baseprecv(1)%base_desc,info)
call psb_geaxpby(alpha,mlprec_wrk(1)%y2l,cone,y,precv(1)%base_desc,info)
if (info /= 0) then
call psb_errpush(4001,name,a_err='Error on final update')
goto 9999
@ -529,14 +493,14 @@ contains
!
! Subroutine: mlt_pre_ml_aply
! Version: complex
! Note: internal subroutine of mld_dmlprec_aply.
! Note: internal subroutine of mld_cmlprec_aply.
!
! This routine computes
!
! Y = beta*Y + alpha*op(M^(-1))*X,
! where
! - M is a hybrid multilevel domain decomposition (Schwarz) preconditioner
! associated to a certain matrix A and stored in the array baseprecv,
! associated to a certain matrix A and stored in the array precv,
! - op(M^(-1)) is M^(-1) or its (conjugate) transpose, according to
! the value of trans,
! - X and Y are vectors,
@ -549,9 +513,9 @@ contains
! level where we might have a replicated index space) and each process takes care
! of one submatrix.
!
! The multilevel preconditioner M is regarded as an array of 'base preconditioners',
! The multilevel preconditioner M is regarded as an array of 'one-level preconditioners',
! each representing the part of the preconditioner associated to a certain level.
! For each level ilev, the base preconditioner K(ilev) is stored in baseprecv(ilev)
! For each level ilev, the base preconditioner K(ilev) is stored in precv(ilev)
! and is associated to a matrix A(ilev), obtained by 'tranferring' the original
! matrix A (i.e. the matrix to be preconditioned) to the level ilev, through smoothed
! aggregation.
@ -565,7 +529,7 @@ contains
! Domain decomposition: parallel multilevel methods for elliptic partial
! differential equations, Cambridge University Press, 1996.
!
! For a description of the arguments see mld_dmlprec_aply.
! For a description of the arguments see mld_cmlprec_aply.
!
! A sketch of the algorithm implemented in this routine is provided below
! (AV(ilev; sm_pr_) denotes the smoothed prolongator from level ilev to
@ -607,13 +571,13 @@ contains
! 6. Yext = beta*Yext + alpha*Y(1)
!
!
subroutine mlt_pre_ml_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info)
subroutine mlt_pre_ml_aply(alpha,precv,x,beta,y,desc_data,trans,work,info)
implicit none
! Arguments
type(psb_desc_type),intent(in) :: desc_data
type(mld_cbaseprc_type), intent(in) :: baseprecv(:)
type(mld_c_onelev_prec_type), intent(in) :: precv(:)
complex(psb_spk_),intent(in) :: alpha,beta
complex(psb_spk_),intent(in) :: x(:)
complex(psb_spk_),intent(inout) :: y(:)
@ -622,10 +586,9 @@ contains
integer, intent(out) :: info
! Local variables
integer :: n_row,n_col
integer :: ictxt,np,me,i, nr2l,nc2l,err_act
integer :: debug_level, debug_unit
integer :: ismth, nlev, ilev, icm
integer :: nlev, ilev
character(len=20) :: name
type psb_mlprec_wrk_type
@ -644,9 +607,9 @@ contains
if (debug_level >= psb_debug_inner_) &
& write(debug_unit,*) me,' ',trim(name),&
& ' Entry ', size(baseprecv)
& ' Entry ', size(precv)
nlev = size(baseprecv)
nlev = size(precv)
allocate(mlprec_wrk(nlev),stat=info)
if (info /= 0) then
call psb_errpush(4010,name,a_err='Allocate')
@ -658,8 +621,7 @@ contains
!
! Copy the input vector X
!
n_col = psb_cd_get_local_cols(desc_data)
nc2l = psb_cd_get_local_cols(baseprecv(1)%base_desc)
nc2l = psb_cd_get_local_cols(precv(1)%base_desc)
allocate(mlprec_wrk(1)%x2l(nc2l),mlprec_wrk(1)%y2l(nc2l), &
& mlprec_wrk(1)%tx(nc2l), stat=info)
@ -676,8 +638,8 @@ contains
!
! Apply the base preconditioner at the finest level
!
call mld_baseprec_aply(cone,baseprecv(1),mlprec_wrk(1)%x2l,&
& czero,mlprec_wrk(1)%y2l,baseprecv(1)%base_desc,&
call mld_baseprec_aply(cone,precv(1)%prec,mlprec_wrk(1)%x2l,&
& czero,mlprec_wrk(1)%y2l,precv(1)%base_desc,&
& trans,work,info)
if (info /=0) then
call psb_errpush(4010,name,a_err=' baseprec_aply')
@ -691,8 +653,8 @@ contains
!
mlprec_wrk(1)%tx = mlprec_wrk(1)%x2l
call psb_spmm(-cone,baseprecv(1)%base_a,mlprec_wrk(1)%y2l,&
& cone,mlprec_wrk(1)%tx,baseprecv(1)%base_desc,info,&
call psb_spmm(-cone,precv(1)%base_a,mlprec_wrk(1)%y2l,&
& cone,mlprec_wrk(1)%tx,precv(1)%base_desc,info,&
& work=work,trans=trans)
if (info /=0) then
call psb_errpush(4001,name,a_err=' fine level residual')
@ -706,12 +668,8 @@ contains
!
do ilev = 2, nlev
n_row = psb_cd_get_local_rows(baseprecv(ilev-1)%base_desc)
n_col = psb_cd_get_local_cols(baseprecv(ilev-1)%base_desc)
nc2l = psb_cd_get_local_cols(baseprecv(ilev)%base_desc)
nr2l = psb_cd_get_local_rows(baseprecv(ilev)%base_desc)
ismth = baseprecv(ilev)%iprcparm(mld_aggr_kind_)
icm = baseprecv(ilev)%iprcparm(mld_coarse_mat_)
nc2l = psb_cd_get_local_cols(precv(ilev)%base_desc)
nr2l = psb_cd_get_local_rows(precv(ilev)%base_desc)
allocate(mlprec_wrk(ilev)%tx(nc2l),mlprec_wrk(ilev)%y2l(nc2l),&
& mlprec_wrk(ilev)%x2l(nc2l), stat=info)
@ -725,28 +683,27 @@ contains
! Apply prolongator transpose, i.e. restriction
call psb_forward_map(cone,mlprec_wrk(ilev-1)%tx,&
& czero,mlprec_wrk(ilev)%x2l,&
& baseprecv(ilev)%map_desc,info,work=work)
& precv(ilev)%map_desc,info,work=work)
if (info /=0) then
call psb_errpush(4001,name,a_err='Error during restriction')
goto 9999
end if
!
! Apply the base preconditioner
!
call mld_baseprec_aply(cone,baseprecv(ilev),mlprec_wrk(ilev)%x2l,&
& czero,mlprec_wrk(ilev)%y2l,baseprecv(ilev)%base_desc,trans,work,info)
call mld_baseprec_aply(cone,precv(ilev)%prec,mlprec_wrk(ilev)%x2l,&
& czero,mlprec_wrk(ilev)%y2l,precv(ilev)%base_desc,trans,work,info)
!
! Compute the residual (at all levels but the coarsest one)
!
if (ilev < nlev) then
mlprec_wrk(ilev)%tx = mlprec_wrk(ilev)%x2l
if (info == 0) call psb_spmm(-cone,baseprecv(ilev)%base_a,&
if (info == 0) call psb_spmm(-cone,precv(ilev)%base_a,&
& mlprec_wrk(ilev)%y2l,cone,mlprec_wrk(ilev)%tx,&
& baseprecv(ilev)%base_desc,info,work=work,trans=trans)
& precv(ilev)%base_desc,info,work=work,trans=trans)
endif
if (info /=0) then
call psb_errpush(4001,name,a_err='Error on up sweep residual')
@ -760,16 +717,12 @@ contains
! For each level but the coarsest one ...
!
do ilev = nlev-1, 1, -1
ismth = baseprecv(ilev+1)%iprcparm(mld_aggr_kind_)
n_row = psb_cd_get_local_rows(baseprecv(ilev)%base_desc)
!
! Apply prolongator
!
call psb_backward_map(cone,mlprec_wrk(ilev+1)%y2l,&
& cone,mlprec_wrk(ilev)%y2l,&
& baseprecv(ilev+1)%map_desc,info,work=work)
& precv(ilev+1)%map_desc,info,work=work)
if (info /=0) then
call psb_errpush(4001,name,a_err='Error during prolongation')
@ -783,7 +736,7 @@ contains
! Compute the output vector Y
!
call psb_geaxpby(alpha,mlprec_wrk(1)%y2l,beta,y,&
& baseprecv(1)%base_desc,info)
& precv(1)%base_desc,info)
if (info /=0) then
call psb_errpush(4001,name,a_err='Error on final update')
goto 9999
@ -809,14 +762,14 @@ contains
!
! Subroutine: mlt_post_ml_aply
! Version: complex
! Note: internal subroutine of mld_dmlprec_aply.
! Note: internal subroutine of mld_cmlprec_aply.
!
! This routine computes
!
! Y = beta*Y + alpha*op(M^(-1))*X,
! where
! - M is a hybrid multilevel domain decomposition (Schwarz) preconditioner
! associated to a certain matrix A and stored in the array baseprecv,
! associated to a certain matrix A and stored in the array precv,
! - op(M^(-1)) is M^(-1) or its (conjugate) transpose, according to
! the value of trans,
! - X and Y are vectors,
@ -829,9 +782,9 @@ contains
! level where we might have a replicated index space) and each process takes care
! of one submatrix.
!
! The multilevel preconditioner M is regarded as an array of 'base preconditioners',
! The multilevel preconditioner M is regarded as an array of 'one-level preconditioners',
! each representing the part of the preconditioner associated to a certain level.
! For each level ilev, the base preconditioner K(ilev) is stored in baseprecv(ilev)
! For each level ilev, the base preconditioner K(ilev) is stored in precv(ilev)
! and is associated to a matrix A(ilev), obtained by 'tranferring' the original
! matrix A (i.e. the matrix to be preconditioned) to the level ilev, through smoothed
! aggregation.
@ -844,7 +797,7 @@ contains
! Domain decomposition: parallel multilevel methods for elliptic partial
! differential equations, Cambridge University Press, 1996.
!
! For a description of the arguments see mld_dmlprec_aply.
! For a description of the arguments see mld_cmlprec_aply.
!
! A sketch of the algorithm implemented in this routine is provided below.
! (AV(ilev; sm_pr_) denotes the smoothed prolongator from level ilev to
@ -878,13 +831,13 @@ contains
! 5. Yext = beta*Yext + alpha*Y(1)
!
!
subroutine mlt_post_ml_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info)
subroutine mlt_post_ml_aply(alpha,precv,x,beta,y,desc_data,trans,work,info)
implicit none
! Arguments
type(psb_desc_type),intent(in) :: desc_data
type(mld_cbaseprc_type), intent(in) :: baseprecv(:)
type(mld_c_onelev_prec_type), intent(in) :: precv(:)
complex(psb_spk_),intent(in) :: alpha,beta
complex(psb_spk_),intent(in) :: x(:)
complex(psb_spk_),intent(inout) :: y(:)
@ -893,10 +846,9 @@ contains
integer, intent(out) :: info
! Local variables
integer :: n_row,n_col
integer :: ictxt,np,me,i, nr2l,nc2l,err_act
integer :: debug_level, debug_unit
integer :: ismth, nlev, ilev, icm
integer :: nlev, ilev
character(len=20) :: name
type psb_mlprec_wrk_type
@ -915,9 +867,9 @@ contains
if (debug_level >= psb_debug_inner_) &
& write(debug_unit,*) me,' ',trim(name),&
& ' Entry ', size(baseprecv)
& ' Entry ', size(precv)
nlev = size(baseprecv)
nlev = size(precv)
allocate(mlprec_wrk(nlev),stat=info)
if (info /= 0) then
call psb_errpush(4010,name,a_err='Allocate')
@ -933,16 +885,21 @@ contains
& write(debug_unit,*) me,' ',trim(name),&
& ' desc_data status',allocated(desc_data%matrix_data)
n_col = psb_cd_get_local_cols(desc_data)
nc2l = psb_cd_get_local_cols(baseprecv(1)%base_desc)
nc2l = psb_cd_get_local_cols(precv(1)%base_desc)
allocate(mlprec_wrk(1)%x2l(nc2l),mlprec_wrk(1)%y2l(nc2l), &
& mlprec_wrk(1)%tx(nc2l), stat=info)
if (info /= 0) then
info=4025
call psb_errpush(info,name,i_err=(/4*nc2l,0,0,0,0/),&
& a_err='complex(psb_spk_)')
goto 9999
end if
call psb_geaxpby(cone,x,czero,mlprec_wrk(1)%tx,&
& baseprecv(1)%base_desc,info)
& precv(1)%base_desc,info)
call psb_geaxpby(cone,x,czero,mlprec_wrk(1)%x2l,&
& baseprecv(1)%base_desc,info)
& precv(1)%base_desc,info)
!
! STEP 2
@ -951,18 +908,13 @@ contains
!
do ilev=2, nlev
n_row = psb_cd_get_local_rows(baseprecv(ilev-1)%base_desc)
n_col = psb_cd_get_local_cols(baseprecv(ilev-1)%base_desc)
nc2l = psb_cd_get_local_cols(baseprecv(ilev)%base_desc)
nr2l = psb_cd_get_local_rows(baseprecv(ilev)%base_desc)
ismth = baseprecv(ilev)%iprcparm(mld_aggr_kind_)
icm = baseprecv(ilev)%iprcparm(mld_coarse_mat_)
nc2l = psb_cd_get_local_cols(precv(ilev)%base_desc)
nr2l = psb_cd_get_local_rows(precv(ilev)%base_desc)
if (debug_level >= psb_debug_inner_) &
& write(debug_unit,*) me,' ',trim(name), &
& ' starting up sweep ',&
& ilev,allocated(baseprecv(ilev)%iprcparm),n_row,n_col,&
& nc2l, nr2l,ismth
& ilev,allocated(precv(ilev)%iprcparm),nc2l, nr2l
allocate(mlprec_wrk(ilev)%tx(nc2l),mlprec_wrk(ilev)%y2l(nc2l),&
& mlprec_wrk(ilev)%x2l(nc2l), stat=info)
@ -977,19 +929,18 @@ contains
! Apply prolongator transpose, i.e. restriction
call psb_forward_map(cone,mlprec_wrk(ilev-1)%x2l,&
& czero,mlprec_wrk(ilev)%x2l,&
& baseprecv(ilev)%map_desc,info,work=work)
& precv(ilev)%map_desc,info,work=work)
if (info /=0) then
call psb_errpush(4001,name,a_err='Error during restriction')
goto 9999
end if
!
! update x2l
!
call psb_geaxpby(cone,mlprec_wrk(ilev)%x2l,czero,mlprec_wrk(ilev)%tx,&
& baseprecv(ilev)%base_desc,info)
& precv(ilev)%base_desc,info)
if (info /= 0) then
call psb_errpush(4001,name,a_err='Error in update')
goto 9999
@ -1006,8 +957,8 @@ contains
!
! Apply the base preconditioner at the coarsest level
!
call mld_baseprec_aply(cone,baseprecv(nlev),mlprec_wrk(nlev)%x2l, &
& czero, mlprec_wrk(nlev)%y2l,baseprecv(nlev)%base_desc,trans,work,info)
call mld_baseprec_aply(cone,precv(nlev)%prec,mlprec_wrk(nlev)%x2l, &
& czero, mlprec_wrk(nlev)%y2l,precv(nlev)%base_desc,trans,work,info)
if (info /=0) then
call psb_errpush(4010,name,a_err='baseprec_aply')
goto 9999
@ -1027,15 +978,12 @@ contains
& write(debug_unit,*) me,' ',trim(name),&
& ' starting down sweep',ilev
ismth = baseprecv(ilev+1)%iprcparm(mld_aggr_kind_)
n_row = psb_cd_get_local_rows(baseprecv(ilev)%base_desc)
!
! Apply prolongator
!
call psb_backward_map(cone,mlprec_wrk(ilev+1)%y2l,&
& czero,mlprec_wrk(ilev)%y2l,&
& baseprecv(ilev+1)%map_desc,info,work=work)
& precv(ilev+1)%map_desc,info,work=work)
if (info /=0) then
call psb_errpush(4001,name,a_err='Error during prolongation')
@ -1045,15 +993,16 @@ contains
!
! Compute the residual
!
call psb_spmm(-cone,baseprecv(ilev)%base_a,mlprec_wrk(ilev)%y2l,&
& cone,mlprec_wrk(ilev)%tx,baseprecv(ilev)%base_desc,info,&
call psb_spmm(-cone,precv(ilev)%base_a,mlprec_wrk(ilev)%y2l,&
& cone,mlprec_wrk(ilev)%tx,precv(ilev)%base_desc,info,&
& work=work,trans=trans)
!
! Apply the base preconditioner
!
if (info == 0) call mld_baseprec_aply(cone,baseprecv(ilev),mlprec_wrk(ilev)%tx,&
& cone,mlprec_wrk(ilev)%y2l,baseprecv(ilev)%base_desc,trans,work,info)
if (info == 0) call mld_baseprec_aply(cone,precv(ilev)%prec,&
& mlprec_wrk(ilev)%tx,cone,mlprec_wrk(ilev)%y2l,precv(ilev)%base_desc,&
& trans,work,info)
if (info /=0) then
call psb_errpush(4001,name,a_err=' spmm/baseprec_aply')
goto 9999
@ -1069,7 +1018,7 @@ contains
!
! Compute the output vector Y
!
call psb_geaxpby(alpha,mlprec_wrk(1)%y2l,beta,y,baseprecv(1)%base_desc,info)
call psb_geaxpby(alpha,mlprec_wrk(1)%y2l,beta,y,precv(1)%base_desc,info)
if (info /=0) then
call psb_errpush(4001,name,a_err=' Final update')
@ -1098,7 +1047,7 @@ contains
!
! Subroutine: mlt_twoside_ml_aply
! Version: complex
! Note: internal subroutine of mld_dmlprec_aply.
! Note: internal subroutine of mld_cmlprec_aply.
!
! This routine computes
!
@ -1106,7 +1055,7 @@ contains
! where
! - M is a symmetrized hybrid multilevel domain decomposition (Schwarz)
! preconditioner associated to a certain matrix A and stored in the array
! baseprecv,
! precv,
! - op(M^(-1)) is M^(-1) or its (conjugate) transpose, according to
! the value of trans,
! - X and Y are vectors,
@ -1120,9 +1069,9 @@ contains
! level where we might have a replicated index space) and each process takes care
! of one submatrix.
!
! The multilevel preconditioner M is regarded as an array of 'base preconditioners',
! The multilevel preconditioner M is regarded as an array of 'one-level preconditioners',
! each representing the part of the preconditioner associated to a certain level.
! For each level ilev, the base preconditioner K(ilev) is stored in baseprecv(ilev)
! For each level ilev, the base preconditioner K(ilev) is stored in precv(ilev)
! and is associated to a matrix A(ilev), obtained by 'tranferring' the original
! matrix A (i.e. the matrix to be preconditioned) to the level ilev, through smoothed
! aggregation.
@ -1136,7 +1085,7 @@ contains
! Domain decomposition: parallel multilevel methods for elliptic partial
! differential equations, Cambridge University Press, 1996.
!
! For a description of the arguments see mld_dmlprec_aply.
! For a description of the arguments see mld_cmlprec_aply.
!
! A sketch of the algorithm implemented in this routine is provided below.
! (AV(ilev; sm_pr_) denotes the smoothed prolongator from level ilev to
@ -1180,13 +1129,13 @@ contains
!
! 6. Yext = beta*Yext + alpha*Y(1)
!
subroutine mlt_twoside_ml_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info)
subroutine mlt_twoside_ml_aply(alpha,precv,x,beta,y,desc_data,trans,work,info)
implicit none
! Arguments
type(psb_desc_type),intent(in) :: desc_data
type(mld_cbaseprc_type), intent(in) :: baseprecv(:)
type(mld_c_onelev_prec_type), intent(in) :: precv(:)
complex(psb_spk_),intent(in) :: alpha,beta
complex(psb_spk_),intent(in) :: x(:)
complex(psb_spk_),intent(inout) :: y(:)
@ -1195,10 +1144,9 @@ contains
integer, intent(out) :: info
! Local variables
integer :: n_row,n_col
integer :: ictxt,np,me,i, nr2l,nc2l,err_act
integer :: debug_level, debug_unit
integer :: ismth, nlev, ilev, icm
integer :: nlev, ilev
character(len=20) :: name
type psb_mlprec_wrk_type
@ -1217,9 +1165,9 @@ contains
if (debug_level >= psb_debug_inner_) &
& write(debug_unit,*) me,' ',trim(name),&
& ' Entry ', size(baseprecv)
& ' Entry ', size(precv)
nlev = size(baseprecv)
nlev = size(precv)
allocate(mlprec_wrk(nlev),stat=info)
if (info /= 0) then
call psb_errpush(4010,name,a_err='Allocate')
@ -1230,8 +1178,7 @@ contains
!
! Copy the input vector X
!
n_col = psb_cd_get_local_cols(desc_data)
nc2l = psb_cd_get_local_cols(baseprecv(1)%base_desc)
nc2l = psb_cd_get_local_cols(precv(1)%base_desc)
allocate(mlprec_wrk(1)%x2l(nc2l),mlprec_wrk(1)%y2l(nc2l), &
& mlprec_wrk(1)%ty(nc2l), mlprec_wrk(1)%tx(nc2l), stat=info)
@ -1244,17 +1191,17 @@ contains
end if
call psb_geaxpby(cone,x,czero,mlprec_wrk(1)%x2l,&
& baseprecv(1)%base_desc,info)
& precv(1)%base_desc,info)
call psb_geaxpby(cone,x,czero,mlprec_wrk(1)%tx,&
& baseprecv(1)%base_desc,info)
& precv(1)%base_desc,info)
!
! STEP 2
!
! Apply the base preconditioner at the finest level
!
call mld_baseprec_aply(cone,baseprecv(1),mlprec_wrk(1)%x2l,&
& czero,mlprec_wrk(1)%y2l,baseprecv(1)%base_desc,&
call mld_baseprec_aply(cone,precv(1)%prec,mlprec_wrk(1)%x2l,&
& czero,mlprec_wrk(1)%y2l,precv(1)%base_desc,&
& trans,work,info)
!
! STEP 3
@ -1262,8 +1209,8 @@ contains
! Compute the residual at the finest level
!
mlprec_wrk(1)%ty = mlprec_wrk(1)%x2l
if (info == 0) call psb_spmm(-cone,baseprecv(1)%base_a,mlprec_wrk(1)%y2l,&
& cone,mlprec_wrk(1)%ty,baseprecv(1)%base_desc,info,&
if (info == 0) call psb_spmm(-cone,precv(1)%base_a,mlprec_wrk(1)%y2l,&
& cone,mlprec_wrk(1)%ty,precv(1)%base_desc,info,&
& work=work,trans=trans)
if (info /=0) then
call psb_errpush(4010,name,a_err='Fine level baseprec/residual')
@ -1277,12 +1224,9 @@ contains
!
do ilev = 2, nlev
n_row = psb_cd_get_local_rows(baseprecv(ilev-1)%base_desc)
n_col = psb_cd_get_local_cols(baseprecv(ilev-1)%base_desc)
nc2l = psb_cd_get_local_cols(baseprecv(ilev)%base_desc)
nr2l = psb_cd_get_local_rows(baseprecv(ilev)%base_desc)
ismth = baseprecv(ilev)%iprcparm(mld_aggr_kind_)
icm = baseprecv(ilev)%iprcparm(mld_coarse_mat_)
nc2l = psb_cd_get_local_cols(precv(ilev)%base_desc)
nr2l = psb_cd_get_local_rows(precv(ilev)%base_desc)
allocate(mlprec_wrk(ilev)%tx(nc2l),mlprec_wrk(ilev)%ty(nc2l),&
& mlprec_wrk(ilev)%y2l(nc2l),mlprec_wrk(ilev)%x2l(nc2l), stat=info)
@ -1296,30 +1240,29 @@ contains
! Apply prolongator transpose, i.e. restriction
call psb_forward_map(cone,mlprec_wrk(ilev-1)%ty,&
& czero,mlprec_wrk(ilev)%x2l,&
& baseprecv(ilev)%map_desc,info,work=work)
& precv(ilev)%map_desc,info,work=work)
if (info /=0) then
call psb_errpush(4001,name,a_err='Error during restriction')
goto 9999
end if
call psb_geaxpby(cone,mlprec_wrk(ilev)%x2l,czero,mlprec_wrk(ilev)%tx,&
& baseprecv(ilev)%base_desc,info)
& precv(ilev)%base_desc,info)
!
! Apply the base preconditioner
!
if (info == 0) call mld_baseprec_aply(cone,baseprecv(ilev),&
if (info == 0) call mld_baseprec_aply(cone,precv(ilev)%prec,&
& mlprec_wrk(ilev)%x2l,czero,mlprec_wrk(ilev)%y2l,&
&baseprecv(ilev)%base_desc,trans,work,info)
&precv(ilev)%base_desc,trans,work,info)
!
! Compute the residual (at all levels but the coarsest one)
!
if(ilev < nlev) then
mlprec_wrk(ilev)%ty = mlprec_wrk(ilev)%x2l
if (info == 0) call psb_spmm(-cone,baseprecv(ilev)%base_a,&
if (info == 0) call psb_spmm(-cone,precv(ilev)%base_a,&
& mlprec_wrk(ilev)%y2l,cone,mlprec_wrk(ilev)%ty,&
& baseprecv(ilev)%base_desc,info,work=work,trans=trans)
& precv(ilev)%base_desc,info,work=work,trans=trans)
endif
if (info /=0) then
call psb_errpush(4001,name,a_err='baseprec_aply/residual')
@ -1335,15 +1278,12 @@ contains
!
do ilev=nlev-1, 1, -1
ismth = baseprecv(ilev+1)%iprcparm(mld_aggr_kind_)
n_row = psb_cd_get_local_rows(baseprecv(ilev)%base_desc)
!
! Apply prolongator
!
call psb_backward_map(cone,mlprec_wrk(ilev+1)%y2l,&
& cone,mlprec_wrk(ilev)%y2l,&
& baseprecv(ilev+1)%map_desc,info,work=work)
& precv(ilev+1)%map_desc,info,work=work)
if (info /=0 ) then
call psb_errpush(4001,name,a_err='Error during restriction')
@ -1353,14 +1293,14 @@ contains
!
! Compute the residual
!
call psb_spmm(-cone,baseprecv(ilev)%base_a,mlprec_wrk(ilev)%y2l,&
& cone,mlprec_wrk(ilev)%tx,baseprecv(ilev)%base_desc,info,&
call psb_spmm(-cone,precv(ilev)%base_a,mlprec_wrk(ilev)%y2l,&
& cone,mlprec_wrk(ilev)%tx,precv(ilev)%base_desc,info,&
& work=work,trans=trans)
!
! Apply the base preconditioner
!
if (info == 0) call mld_baseprec_aply(cone,baseprecv(ilev),mlprec_wrk(ilev)%tx,&
& cone,mlprec_wrk(ilev)%y2l,baseprecv(ilev)%base_desc, trans, work,info)
if (info == 0) call mld_baseprec_aply(cone,precv(ilev)%prec,mlprec_wrk(ilev)%tx,&
& cone,mlprec_wrk(ilev)%y2l,precv(ilev)%base_desc, trans, work,info)
if (info /= 0) then
call psb_errpush(4001,name,a_err='Error: residual/baseprec_aply')
goto 9999
@ -1373,7 +1313,7 @@ contains
! Compute the output vector Y
!
call psb_geaxpby(alpha,mlprec_wrk(1)%y2l,beta,y,&
& baseprecv(1)%base_desc,info)
& precv(1)%base_desc,info)
if (info /= 0) then
call psb_errpush(4001,name,a_err='Error final update')

46
mlprec/mld_cmlprec_bld.f90
Unescape Escape View File

@ -41,7 +41,7 @@
! Subroutine: mld_cmlprec_bld
! Version: complex
!
! This routine builds the base preconditioner corresponding to the current
! This routine builds the preconditioner corresponding to the current
! level of the multilevel preconditioner. The routine first builds the
! (coarse) matrix associated to the current level from the (fine) matrix
! associated to the previous level, then builds the related base preconditioner.
@ -53,9 +53,9 @@
! matrix to be preconditioned.
! desc_a - type(psb_desc_type), input.
! The communication descriptor of a.
! p - type(mld_cbaseprc_type), input/output.
! The base preconditioner data structure containing the local
! part of the base preconditioner to be built.
! p - type(mld_c_onelev_type), input/output.
! The preconditioner data structure containing the local
! part of the one-level preconditioner to be built.
! info - integer, output.
! Error code.
!
@ -69,7 +69,7 @@ subroutine mld_cmlprec_bld(a,desc_a,p,info)
! Arguments
type(psb_cspmat_type), intent(in), target :: a
type(psb_desc_type), intent(in), target :: desc_a
type(mld_cbaseprc_type), intent(inout),target :: p
type(mld_c_onelev_prec_type), intent(inout),target :: p
integer, intent(out) :: info
! Local variables
@ -106,16 +106,16 @@ subroutine mld_cmlprec_bld(a,desc_a,p,info)
& mld_max_norm_,is_legal_ml_aggr_eig)
select case(p%iprcparm(mld_sub_solve_))
select case(p%prec%iprcparm(mld_sub_solve_))
case(mld_ilu_n_,mld_milu_n_)
call mld_check_def(p%iprcparm(mld_sub_fillin_),'Level',0,is_legal_ml_lev)
call mld_check_def(p%prec%iprcparm(mld_sub_fillin_),'Level',0,is_legal_ml_lev)
case(mld_ilu_t_)
call mld_check_def(p%rprcparm(mld_sub_iluthrs_),'Eps',szero,is_legal_s_fact_thrs)
call mld_check_def(p%prec%rprcparm(mld_sub_iluthrs_),'Eps',szero,is_legal_s_fact_thrs)
end select
call mld_check_def(p%prec%iprcparm(mld_smoother_sweeps_),'Jacobi sweeps',&
& 1,is_legal_jac_sweeps)
call mld_check_def(p%rprcparm(mld_aggr_omega_val_),'Omega',szero,is_legal_s_omega)
call mld_check_def(p%rprcparm(mld_aggr_thresh_),'Aggr_Thresh',szero,is_legal_s_aggr_thrs)
call mld_check_def(p%iprcparm(mld_smoother_sweeps_),'Jacobi sweeps',&
& 1,is_legal_jac_sweeps)
!
! Build a mapping between the row indices of the fine-level matrix
@ -135,7 +135,7 @@ subroutine mld_cmlprec_bld(a,desc_a,p,info)
! the mapping defined by mld_aggrmap_bld and applying the aggregation
! algorithm specified by p%iprcparm(mld_aggr_kind_)
!
call mld_aggrmat_asb(a,desc_a,ac,desc_ac,p,info)
call mld_aggrmat_asb(a,desc_a,p,info)
if(info /= 0) then
call psb_errpush(4010,name,a_err='mld_aggrmat_asb')
goto 9999
@ -144,32 +144,16 @@ subroutine mld_cmlprec_bld(a,desc_a,p,info)
!
! Build the 'base preconditioner' corresponding to the coarse level
!
call mld_baseprc_bld(ac,desc_ac,p,info)
call mld_baseprc_bld(p%ac,p%desc_ac,p%prec,info)
if (info /= 0) then
call psb_errpush(4010,name,a_err='mld_baseprc_bld')
goto 9999
end if
!
! We have used a separate ac because
! 1. we want to reuse the same routines mld_ilu_bld, etc.,
! 2. we do NOT want to pass an argument twice to them (p%av(mld_ac_) and p),
! as this would violate the Fortran standard.
! Hence a separate AC and a TRANSFER function at the end.
! Fix the base_a and base_desc pointers for handling of residuals.
! This is correct because this routine is only called at levels >=2.
!
call psb_sp_transfer(ac,p%av(mld_ac_),info)
p%base_a => p%av(mld_ac_)
if (info==0) call psb_cdtransfer(desc_ac,p%desc_ac,info)
p%map_desc = psb_inter_desc(psb_map_aggr_,desc_a,&
& p%desc_ac,p%av(mld_sm_pr_t_),p%av(mld_sm_pr_))
! The two matrices from p%av() have been copied, may free them.
if (info == 0) call psb_sp_free(p%av(mld_sm_pr_t_),info)
if (info == 0) call psb_sp_free(p%av(mld_sm_pr_),info)
if (info /= 0) then
call psb_errpush(4010,name,a_err='psb_cdtransfer')
goto 9999
end if
p%base_a => p%ac
p%base_desc => p%desc_ac
call psb_erractionrestore(err_act)

14
mlprec/mld_cprec_aply.f90
Unescape Escape View File

@ -120,25 +120,25 @@ subroutine mld_cprec_aply(prec,x,y,desc_data,info,trans,work)
end if
if (.not.(allocated(prec%baseprecv))) then
if (.not.(allocated(prec%precv))) then
!! Error 1: should call mld_dprecbld
info=3112
call psb_errpush(info,name)
goto 9999
end if
if (size(prec%baseprecv) >1) then
call mld_mlprec_aply(cone,prec%baseprecv,x,czero,y,desc_data,trans_,work_,info)
if (size(prec%precv) >1) then
call mld_mlprec_aply(cone,prec%precv,x,czero,y,desc_data,trans_,work_,info)
if(info /= 0) then
call psb_errpush(4010,name,a_err='mld_cmlprec_aply')
goto 9999
end if
else if (size(prec%baseprecv) == 1) then
call mld_baseprec_aply(cone,prec%baseprecv(1),x,czero,y,desc_data,trans_, work_,info)
else if (size(prec%precv) == 1) then
call mld_baseprec_aply(cone,prec%precv(1)%prec,x,czero,y,desc_data,trans_, work_,info)
else
info = 4013
call psb_errpush(info,name,a_err='Invalid size of baseprecv',&
& i_Err=(/size(prec%baseprecv),0,0,0,0/))
call psb_errpush(info,name,a_err='Invalid size of precv',&
& i_Err=(/size(prec%precv),0,0,0,0/))
goto 9999
endif

77
mlprec/mld_cprecbld.f90
Unescape Escape View File

@ -119,8 +119,8 @@ subroutine mld_cprecbld(a,desc_a,p,info)
!!$ endif
upd_ = 'F'
if (.not.allocated(p%baseprecv)) then
!! Error: should have called mld_dprecinit
if (.not.allocated(p%precv)) then
!! Error: should have called mld_cprecinit
info=3111
call psb_errpush(info,name)
goto 9999
@ -129,11 +129,11 @@ subroutine mld_cprecbld(a,desc_a,p,info)
!
! Check to ensure all procs have the same
!
iszv = size(p%baseprecv)
iszv = size(p%precv)
call psb_bcast(ictxt,iszv)
if (iszv /= size(p%baseprecv)) then
if (iszv /= size(p%precv)) then
info=4001
call psb_errpush(info,name,a_err='Inconsistent size of baseprecv')
call psb_errpush(info,name,a_err='Inconsistent size of precv')
goto 9999
end if
@ -142,18 +142,20 @@ subroutine mld_cprecbld(a,desc_a,p,info)
! Check on the iprcparm contents: they should be the same
! on all processes.
!
if (me == psb_root_) ipv(:) = p%baseprecv(1)%iprcparm(:)
if (me == psb_root_) ipv(:) = p%precv(1)%iprcparm(:)
call psb_bcast(ictxt,ipv)
if (any(ipv(:) /= p%baseprecv(1)%iprcparm(:) )) then
if (any(ipv(:) /= p%precv(1)%iprcparm(:) )) then
write(debug_unit,*) me,name,&
&': Inconsistent arguments among processes, forcing a default'
p%baseprecv(1)%iprcparm(:) = ipv(:)
p%precv(1)%iprcparm(:) = ipv(:)
end if
!
! Allocate and build the fine level preconditioner
! Finest level first; remember to fix base_a and base_desc
!
call init_baseprc_av(p%baseprecv(1),info)
if (info == 0) call mld_baseprc_bld(a,desc_a,p%baseprecv(1),info,upd_)
call init_baseprc_av(p%precv(1)%prec,info)
if (info == 0) call mld_baseprc_bld(a,desc_a,p%precv(1)%prec,info,upd_)
p%precv(1)%base_a => a
p%precv(1)%base_desc => desc_a
if (info /= 0) then
call psb_errpush(4001,name,a_err='Base level precbuild.')
@ -178,69 +180,69 @@ subroutine mld_cprecbld(a,desc_a,p,info)
! Check on the iprcparm contents: they should be the same
! on all processes.
!
if (me == psb_root_) ipv(:) = p%baseprecv(i)%iprcparm(:)
if (me == psb_root_) ipv(:) = p%precv(i)%iprcparm(:)
call psb_bcast(ictxt,ipv)
if (any(ipv(:) /= p%baseprecv(i)%iprcparm(:) )) then
if (any(ipv(:) /= p%precv(i)%iprcparm(:) )) then
write(debug_unit,*) me,name,&
&': Inconsistent arguments among processes, resetting.'
p%baseprecv(i)%iprcparm(:) = ipv(:)
p%precv(i)%iprcparm(:) = ipv(:)
end if
!
! Allocate the av component of the preconditioner data type
! at level i
! Sanity checks on the parameters
!
if (i<iszv) then
!
! A replicated matrix only makes sense at the coarsest level
!
call mld_check_def(p%baseprecv(i)%iprcparm(mld_coarse_mat_),'Coarse matrix',&
call mld_check_def(p%precv(i)%iprcparm(mld_coarse_mat_),'Coarse matrix',&
& mld_distr_mat_,is_distr_ml_coarse_mat)
else if (i == iszv) then
!
! At the coarsest level, check mld_coarse_solve_
!
val = p%baseprecv(i)%iprcparm(mld_coarse_solve_)
val = p%precv(i)%iprcparm(mld_coarse_solve_)
select case (val)
case(mld_umf_, mld_slu_)
if ((p%baseprecv(i)%iprcparm(mld_coarse_mat_) /= mld_repl_mat_).or.&
& (p%baseprecv(i)%iprcparm(mld_sub_solve_) /= val)) then
if ((p%precv(i)%iprcparm(mld_coarse_mat_) /= mld_repl_mat_).or.&
& (p%precv(i)%prec%iprcparm(mld_sub_solve_) /= val)) then
if (me == 0) write(debug_unit,*)&
& 'Warning: inconsistent coarse level specification.'
if (me == 0) write(debug_unit,*)&
& ' Resetting according to the value specified for mld_coarse_solve_.'
p%baseprecv(i)%iprcparm(mld_coarse_mat_) = mld_repl_mat_
p%baseprecv(i)%iprcparm(mld_sub_solve_) = val
p%baseprecv(i)%iprcparm(mld_smoother_type_) = mld_bjac_
p%precv(i)%iprcparm(mld_coarse_mat_) = mld_repl_mat_
p%precv(i)%prec%iprcparm(mld_sub_solve_) = val
p%precv(i)%prec%iprcparm(mld_smoother_type_) = mld_bjac_
end if
case(mld_sludist_)
if ((p%baseprecv(i)%iprcparm(mld_coarse_mat_) /= mld_distr_mat_).or.&
& (p%baseprecv(i)%iprcparm(mld_sub_solve_) /= val)) then
if ((p%precv(i)%iprcparm(mld_coarse_mat_) /= mld_distr_mat_).or.&
& (p%precv(i)%prec%iprcparm(mld_sub_solve_) /= val)) then
if (me == 0) write(debug_unit,*)&
& 'Warning: inconsistent coarse level specification.'
if (me == 0) write(debug_unit,*)&
& ' Resetting according to the value specified for mld_coarse_solve_.'
p%baseprecv(i)%iprcparm(mld_coarse_mat_) = mld_distr_mat_
p%baseprecv(i)%iprcparm(mld_sub_solve_) = val
p%baseprecv(i)%iprcparm(mld_smoother_type_) = mld_bjac_
p%baseprecv(i)%iprcparm(mld_smoother_sweeps_) = 1
p%precv(i)%iprcparm(mld_coarse_mat_) = mld_distr_mat_
p%precv(i)%prec%iprcparm(mld_sub_solve_) = val
p%precv(i)%prec%iprcparm(mld_smoother_type_) = mld_bjac_
p%precv(i)%prec%iprcparm(mld_smoother_sweeps_) = 1
end if
end select
end if
call init_baseprc_av(p%baseprecv(i),info)
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'Calling mlprcbld at level ',i
!
! Build the base preconditioner corresponding to level i
! Allocate and build the preconditioner at level i.
! baseprec_bld is called inside mlprec_bld.
!
if (info == 0) call mld_mlprec_bld(p%baseprecv(i-1)%base_a,&
& p%baseprecv(i-1)%base_desc, p%baseprecv(i),info)
call init_baseprc_av(p%precv(i)%prec,info)
if (info == 0) call mld_mlprec_bld(p%precv(i-1)%base_a,&
& p%precv(i-1)%base_desc, p%precv(i),info)
if (info /= 0) then
call psb_errpush(4001,name,a_err='Init & build upper level preconditioner')
goto 9999
@ -250,11 +252,14 @@ subroutine mld_cprecbld(a,desc_a,p,info)
& write(debug_unit,*) me,' ',trim(name),&
& 'Return from ',i,' call to mlprcbld ',info
end do
!
! Check on sizes from level 2 onwards
!
if (me==0) then
k = iszv+1
do i=iszv,3,-1
if (all(p%baseprecv(i)%nlaggr == p%baseprecv(i-1)%nlaggr)) then
if (all(p%precv(i)%nlaggr == p%precv(i-1)%nlaggr)) then
k=i-1
end if
end do

8
mlprec/mld_cprecfree.f90
Unescape Escape View File

@ -74,11 +74,11 @@ subroutine mld_cprecfree(p,info)
me=-1
if (allocated(p%baseprecv)) then
do i=1,size(p%baseprecv)
call mld_base_precfree(p%baseprecv(i),info)
if (allocated(p%precv)) then
do i=1,size(p%precv)
call mld_onelev_precfree(p%precv(i),info)
end do
deallocate(p%baseprecv)
deallocate(p%precv)
end if
call psb_erractionrestore(err_act)
return

241
mlprec/mld_cprecinit.F90
Unescape Escape View File

@ -104,7 +104,7 @@ subroutine mld_cprecinit(p,ptype,info,nlev)
character(len=*), parameter :: name='mld_precinit'
info = 0
if (allocated(p%baseprecv)) then
if (allocated(p%precv)) then
call mld_precfree(p,info)
if (info /=0) then
! Do we want to do something?
@ -115,68 +115,88 @@ subroutine mld_cprecinit(p,ptype,info,nlev)
case ('NOPREC')
nlev_ = 1
ilev_ = 1
allocate(p%baseprecv(nlev_),stat=info)
if (info == 0) call psb_realloc(mld_ifpsz_,p%baseprecv(ilev_)%iprcparm,info)
if (info == 0) call psb_realloc(mld_rfpsz_,p%baseprecv(ilev_)%rprcparm,info)
allocate(p%precv(nlev_),stat=info)
if (info == 0) call psb_realloc(mld_ifpsz_,p%precv(ilev_)%iprcparm,info)
if (info == 0) call psb_realloc(mld_rfpsz_,p%precv(ilev_)%rprcparm,info)
if (info == 0) call psb_realloc(mld_ifpsz_,p%precv(ilev_)%prec%iprcparm,info)
if (info == 0) call psb_realloc(mld_rfpsz_,p%precv(ilev_)%prec%rprcparm,info)
if (info /= 0) return
p%baseprecv(ilev_)%iprcparm(:) = 0
p%baseprecv(ilev_)%iprcparm(mld_smoother_type_) = mld_noprec_
p%baseprecv(ilev_)%iprcparm(mld_sub_solve_) = mld_f_none_
p%baseprecv(ilev_)%iprcparm(mld_sub_restr_) = psb_none_
p%baseprecv(ilev_)%iprcparm(mld_sub_prol_) = psb_none_
p%baseprecv(ilev_)%iprcparm(mld_sub_ren_) = 0
p%baseprecv(ilev_)%iprcparm(mld_sub_ovr_) = 0
p%baseprecv(ilev_)%iprcparm(mld_smoother_sweeps_) = 1
p%precv(ilev_)%iprcparm(:) = 0
p%precv(ilev_)%rprcparm(:) = szero
p%precv(ilev_)%prec%iprcparm(:) = 0
p%precv(ilev_)%prec%rprcparm(:) = szero
p%precv(ilev_)%prec%iprcparm(mld_smoother_type_) = mld_noprec_
p%precv(ilev_)%prec%iprcparm(mld_sub_solve_) = mld_f_none_
p%precv(ilev_)%prec%iprcparm(mld_sub_restr_) = psb_none_
p%precv(ilev_)%prec%iprcparm(mld_sub_prol_) = psb_none_
p%precv(ilev_)%prec%iprcparm(mld_sub_ren_) = 0
p%precv(ilev_)%prec%iprcparm(mld_sub_ovr_) = 0
p%precv(ilev_)%prec%iprcparm(mld_smoother_sweeps_) = 1
case ('DIAG')
nlev_ = 1
ilev_ = 1
allocate(p%baseprecv(nlev_),stat=info)
if (info == 0) call psb_realloc(mld_ifpsz_,p%baseprecv(ilev_)%iprcparm,info)
if (info == 0) call psb_realloc(mld_rfpsz_,p%baseprecv(ilev_)%rprcparm,info)
allocate(p%precv(nlev_),stat=info)
if (info == 0) call psb_realloc(mld_ifpsz_,p%precv(ilev_)%iprcparm,info)
if (info == 0) call psb_realloc(mld_rfpsz_,p%precv(ilev_)%rprcparm,info)
if (info == 0) call psb_realloc(mld_ifpsz_,p%precv(ilev_)%prec%iprcparm,info)
if (info == 0) call psb_realloc(mld_rfpsz_,p%precv(ilev_)%prec%rprcparm,info)
if (info /= 0) return
p%baseprecv(ilev_)%iprcparm(:) = 0
p%baseprecv(ilev_)%iprcparm(mld_smoother_type_) = mld_diag_
p%baseprecv(ilev_)%iprcparm(mld_sub_solve_) = mld_f_none_
p%baseprecv(ilev_)%iprcparm(mld_sub_restr_) = psb_none_
p%baseprecv(ilev_)%iprcparm(mld_sub_prol_) = psb_none_
p%baseprecv(ilev_)%iprcparm(mld_sub_ren_) = 0
p%baseprecv(ilev_)%iprcparm(mld_sub_ovr_) = 0
p%baseprecv(ilev_)%iprcparm(mld_smoother_sweeps_) = 1
p%precv(ilev_)%iprcparm(:) = 0
p%precv(ilev_)%rprcparm(:) = szero
p%precv(ilev_)%prec%iprcparm(:) = 0
p%precv(ilev_)%prec%rprcparm(:) = szero
p%precv(ilev_)%prec%iprcparm(mld_smoother_type_) = mld_diag_
p%precv(ilev_)%prec%iprcparm(mld_sub_solve_) = mld_f_none_
p%precv(ilev_)%prec%iprcparm(mld_sub_restr_) = psb_none_
p%precv(ilev_)%prec%iprcparm(mld_sub_prol_) = psb_none_
p%precv(ilev_)%prec%iprcparm(mld_sub_ren_) = 0
p%precv(ilev_)%prec%iprcparm(mld_sub_ovr_) = 0
p%precv(ilev_)%prec%iprcparm(mld_smoother_sweeps_) = 1
case ('BJAC')
nlev_ = 1
ilev_ = 1
allocate(p%baseprecv(nlev_),stat=info)
if (info == 0) call psb_realloc(mld_ifpsz_,p%baseprecv(ilev_)%iprcparm,info)
if (info == 0) call psb_realloc(mld_rfpsz_,p%baseprecv(ilev_)%rprcparm,info)
allocate(p%precv(nlev_),stat=info)
if (info == 0) call psb_realloc(mld_ifpsz_,p%precv(ilev_)%iprcparm,info)
if (info == 0) call psb_realloc(mld_rfpsz_,p%precv(ilev_)%rprcparm,info)
if (info == 0) call psb_realloc(mld_ifpsz_,p%precv(ilev_)%prec%iprcparm,info)
if (info == 0) call psb_realloc(mld_rfpsz_,p%precv(ilev_)%prec%rprcparm,info)
if (info /= 0) return
p%baseprecv(ilev_)%iprcparm(:) = 0
p%baseprecv(ilev_)%iprcparm(mld_smoother_type_) = mld_bjac_
p%baseprecv(ilev_)%iprcparm(mld_sub_solve_) = mld_ilu_n_
p%baseprecv(ilev_)%iprcparm(mld_sub_restr_) = psb_none_
p%baseprecv(ilev_)%iprcparm(mld_sub_prol_) = psb_none_
p%baseprecv(ilev_)%iprcparm(mld_sub_ren_) = 0
p%baseprecv(ilev_)%iprcparm(mld_sub_ovr_) = 0
p%baseprecv(ilev_)%iprcparm(mld_sub_fillin_) = 0
p%baseprecv(ilev_)%iprcparm(mld_smoother_sweeps_) = 1
p%precv(ilev_)%iprcparm(:) = 0
p%precv(ilev_)%rprcparm(:) = szero
p%precv(ilev_)%prec%iprcparm(:) = 0
p%precv(ilev_)%prec%rprcparm(:) = szero
p%precv(ilev_)%prec%iprcparm(mld_smoother_type_) = mld_bjac_
p%precv(ilev_)%prec%iprcparm(mld_sub_solve_) = mld_ilu_n_
p%precv(ilev_)%prec%iprcparm(mld_sub_restr_) = psb_none_
p%precv(ilev_)%prec%iprcparm(mld_sub_prol_) = psb_none_
p%precv(ilev_)%prec%iprcparm(mld_sub_ren_) = 0
p%precv(ilev_)%prec%iprcparm(mld_sub_ovr_) = 0
p%precv(ilev_)%prec%iprcparm(mld_sub_fillin_) = 0
p%precv(ilev_)%prec%iprcparm(mld_smoother_sweeps_) = 1
case ('AS')
nlev_ = 1
ilev_ = 1
allocate(p%baseprecv(nlev_),stat=info)
if (info == 0) call psb_realloc(mld_ifpsz_,p%baseprecv(ilev_)%iprcparm,info)
if (info == 0) call psb_realloc(mld_rfpsz_,p%baseprecv(ilev_)%rprcparm,info)
allocate(p%precv(nlev_),stat=info)
if (info == 0) call psb_realloc(mld_ifpsz_,p%precv(ilev_)%iprcparm,info)
if (info == 0) call psb_realloc(mld_rfpsz_,p%precv(ilev_)%rprcparm,info)
if (info == 0) call psb_realloc(mld_ifpsz_,p%precv(ilev_)%prec%iprcparm,info)
if (info == 0) call psb_realloc(mld_rfpsz_,p%precv(ilev_)%prec%rprcparm,info)
if (info /= 0) return
p%baseprecv(ilev_)%iprcparm(:) = 0
p%baseprecv(ilev_)%iprcparm(mld_smoother_type_) = mld_as_
p%baseprecv(ilev_)%iprcparm(mld_sub_solve_) = mld_ilu_n_
p%baseprecv(ilev_)%iprcparm(mld_sub_restr_) = psb_halo_
p%baseprecv(ilev_)%iprcparm(mld_sub_prol_) = psb_none_
p%baseprecv(ilev_)%iprcparm(mld_sub_ren_) = 0
p%baseprecv(ilev_)%iprcparm(mld_sub_ovr_) = 1
p%baseprecv(ilev_)%iprcparm(mld_sub_fillin_) = 0
p%baseprecv(ilev_)%iprcparm(mld_smoother_sweeps_) = 1
p%precv(ilev_)%iprcparm(:) = 0
p%precv(ilev_)%rprcparm(:) = szero
p%precv(ilev_)%prec%iprcparm(:) = 0
p%precv(ilev_)%prec%rprcparm(:) = szero
p%precv(ilev_)%prec%iprcparm(mld_smoother_type_) = mld_as_
p%precv(ilev_)%prec%iprcparm(mld_sub_solve_) = mld_ilu_n_
p%precv(ilev_)%prec%iprcparm(mld_sub_restr_) = psb_halo_
p%precv(ilev_)%prec%iprcparm(mld_sub_prol_) = psb_none_
p%precv(ilev_)%prec%iprcparm(mld_sub_ren_) = 0
p%precv(ilev_)%prec%iprcparm(mld_sub_ovr_) = 1
p%precv(ilev_)%prec%iprcparm(mld_sub_fillin_) = 0
p%precv(ilev_)%prec%iprcparm(mld_smoother_sweeps_) = 1
case ('ML')
@ -187,74 +207,87 @@ subroutine mld_cprecinit(p,ptype,info,nlev)
nlev_ = 2
end if
ilev_ = 1
allocate(p%baseprecv(nlev_),stat=info)
if (info == 0) call psb_realloc(mld_ifpsz_,p%baseprecv(ilev_)%iprcparm,info)
if (info == 0) call psb_realloc(mld_rfpsz_,p%baseprecv(ilev_)%rprcparm,info)
allocate(p%precv(nlev_),stat=info)
if (info == 0) call psb_realloc(mld_ifpsz_,p%precv(ilev_)%iprcparm,info)
if (info == 0) call psb_realloc(mld_rfpsz_,p%precv(ilev_)%rprcparm,info)
if (info == 0) call psb_realloc(mld_ifpsz_,p%precv(ilev_)%prec%iprcparm,info)
if (info == 0) call psb_realloc(mld_rfpsz_,p%precv(ilev_)%prec%rprcparm,info)
if (info /= 0) return
p%baseprecv(ilev_)%iprcparm(:) = 0
p%baseprecv(ilev_)%rprcparm(:) = szero
p%baseprecv(ilev_)%iprcparm(mld_smoother_type_) = mld_as_
p%baseprecv(ilev_)%iprcparm(mld_sub_solve_) = mld_ilu_n_
p%baseprecv(ilev_)%iprcparm(mld_sub_restr_) = psb_halo_
p%baseprecv(ilev_)%iprcparm(mld_sub_prol_) = psb_none_
p%baseprecv(ilev_)%iprcparm(mld_sub_ren_) = 0
p%baseprecv(ilev_)%iprcparm(mld_sub_ovr_) = 1
p%baseprecv(ilev_)%iprcparm(mld_sub_fillin_) = 0
p%baseprecv(ilev_)%iprcparm(mld_smoother_sweeps_) = 1
p%precv(ilev_)%iprcparm(:) = 0
p%precv(ilev_)%rprcparm(:) = szero
p%precv(ilev_)%prec%iprcparm(:) = 0
p%precv(ilev_)%prec%rprcparm(:) = szero
p%precv(ilev_)%prec%iprcparm(mld_smoother_type_) = mld_as_
p%precv(ilev_)%prec%iprcparm(mld_sub_solve_) = mld_ilu_n_
p%precv(ilev_)%prec%iprcparm(mld_sub_restr_) = psb_halo_
p%precv(ilev_)%prec%iprcparm(mld_sub_prol_) = psb_none_
p%precv(ilev_)%prec%iprcparm(mld_sub_ren_) = 0
p%precv(ilev_)%prec%iprcparm(mld_sub_ovr_) = 1
p%precv(ilev_)%prec%iprcparm(mld_sub_fillin_) = 0
p%precv(ilev_)%prec%iprcparm(mld_smoother_sweeps_) = 1
if (nlev_ == 1) return
do ilev_ = 2, nlev_ -1
if (info == 0) call psb_realloc(mld_ifpsz_,p%baseprecv(ilev_)%iprcparm,info)
if (info == 0) call psb_realloc(mld_rfpsz_,p%baseprecv(ilev_)%rprcparm,info)
if (info == 0) call psb_realloc(mld_ifpsz_,p%precv(ilev_)%iprcparm,info)
if (info == 0) call psb_realloc(mld_rfpsz_,p%precv(ilev_)%rprcparm,info)
if (info == 0) call psb_realloc(mld_ifpsz_,p%precv(ilev_)%prec%iprcparm,info)
if (info == 0) call psb_realloc(mld_rfpsz_,p%precv(ilev_)%prec%rprcparm,info)
if (info /= 0) return
p%baseprecv(ilev_)%iprcparm(:) = 0
p%baseprecv(ilev_)%rprcparm(:) = szero
p%baseprecv(ilev_)%iprcparm(mld_smoother_type_) = mld_as_
p%baseprecv(ilev_)%iprcparm(mld_sub_restr_) = psb_halo_
p%baseprecv(ilev_)%iprcparm(mld_sub_prol_) = psb_none_
p%baseprecv(ilev_)%iprcparm(mld_sub_ren_) = 0
p%baseprecv(ilev_)%iprcparm(mld_sub_ovr_) = 1
p%baseprecv(ilev_)%iprcparm(mld_ml_type_) = mld_mult_ml_
p%baseprecv(ilev_)%iprcparm(mld_aggr_alg_) = mld_dec_aggr_
p%baseprecv(ilev_)%iprcparm(mld_aggr_kind_) = mld_smooth_prol_
p%baseprecv(ilev_)%iprcparm(mld_coarse_mat_) = mld_distr_mat_
p%baseprecv(ilev_)%iprcparm(mld_smoother_pos_) = mld_post_smooth_
p%baseprecv(ilev_)%iprcparm(mld_aggr_omega_alg_) = mld_eig_est_
p%baseprecv(ilev_)%iprcparm(mld_aggr_eig_) = mld_max_norm_
p%baseprecv(ilev_)%iprcparm(mld_sub_solve_) = mld_ilu_n_
p%baseprecv(ilev_)%iprcparm(mld_sub_fillin_) = 0
p%baseprecv(ilev_)%iprcparm(mld_smoother_sweeps_) = 1
p%baseprecv(ilev_)%rprcparm(mld_aggr_omega_val_) = szero
p%baseprecv(ilev_)%rprcparm(mld_aggr_thresh_) = szero
p%precv(ilev_)%iprcparm(:) = 0
p%precv(ilev_)%rprcparm(:) = szero
p%precv(ilev_)%prec%iprcparm(:) = 0
p%precv(ilev_)%prec%rprcparm(:) = szero
p%precv(ilev_)%prec%iprcparm(mld_smoother_type_) = mld_as_
p%precv(ilev_)%prec%iprcparm(mld_sub_restr_) = psb_halo_
p%precv(ilev_)%prec%iprcparm(mld_sub_prol_) = psb_none_
p%precv(ilev_)%prec%iprcparm(mld_sub_ren_) = 0
p%precv(ilev_)%prec%iprcparm(mld_sub_ovr_) = 1
p%precv(ilev_)%prec%iprcparm(mld_sub_solve_) = mld_ilu_n_
p%precv(ilev_)%prec%iprcparm(mld_sub_fillin_) = 0
p%precv(ilev_)%prec%iprcparm(mld_smoother_sweeps_) = 1
p%precv(ilev_)%iprcparm(mld_ml_type_) = mld_mult_ml_
p%precv(ilev_)%iprcparm(mld_aggr_alg_) = mld_dec_aggr_
p%precv(ilev_)%iprcparm(mld_aggr_kind_) = mld_smooth_prol_
p%precv(ilev_)%iprcparm(mld_coarse_mat_) = mld_distr_mat_
p%precv(ilev_)%iprcparm(mld_smoother_pos_) = mld_post_smooth_
p%precv(ilev_)%iprcparm(mld_aggr_omega_alg_) = mld_eig_est_
p%precv(ilev_)%iprcparm(mld_aggr_eig_) = mld_max_norm_
p%precv(ilev_)%rprcparm(mld_aggr_omega_val_) = szero
p%precv(ilev_)%rprcparm(mld_aggr_thresh_) = szero
end do
ilev_ = nlev_
if (info == 0) call psb_realloc(mld_ifpsz_,p%baseprecv(ilev_)%iprcparm,info)
if (info == 0) call psb_realloc(mld_rfpsz_,p%baseprecv(ilev_)%rprcparm,info)
if (info == 0) call psb_realloc(mld_ifpsz_,p%precv(ilev_)%iprcparm,info)
if (info == 0) call psb_realloc(mld_rfpsz_,p%precv(ilev_)%rprcparm,info)
if (info == 0) call psb_realloc(mld_ifpsz_,p%precv(ilev_)%prec%iprcparm,info)
if (info == 0) call psb_realloc(mld_rfpsz_,p%precv(ilev_)%prec%rprcparm,info)
if (info /= 0) return
p%baseprecv(ilev_)%iprcparm(:) = 0
p%baseprecv(ilev_)%rprcparm(:) = szero
p%baseprecv(ilev_)%iprcparm(mld_coarse_solve_) = mld_bjac_
p%precv(ilev_)%iprcparm(:) = 0
p%precv(ilev_)%rprcparm(:) = szero
p%precv(ilev_)%prec%iprcparm(:) = 0
p%precv(ilev_)%prec%rprcparm(:) = szero
p%precv(ilev_)%prec%iprcparm(mld_coarse_solve_) = mld_bjac_
#if defined(HAVE_SLU_)
p%baseprecv(ilev_)%iprcparm(mld_sub_solve_) = mld_slu_
p%precv(ilev_)%prec%iprcparm(mld_sub_solve_) = mld_slu_
#else
p%baseprecv(ilev_)%iprcparm(mld_sub_solve_) = mld_ilu_n_
p%precv(ilev_)%prec%iprcparm(mld_sub_solve_) = mld_ilu_n_
#endif
p%baseprecv(ilev_)%iprcparm(mld_smoother_type_) = mld_bjac_
p%baseprecv(ilev_)%iprcparm(mld_coarse_mat_) = mld_distr_mat_
p%baseprecv(ilev_)%iprcparm(mld_sub_restr_) = psb_none_
p%baseprecv(ilev_)%iprcparm(mld_sub_prol_) = psb_none_
p%baseprecv(ilev_)%iprcparm(mld_sub_ren_) = 0
p%baseprecv(ilev_)%iprcparm(mld_sub_ovr_) = 0
p%baseprecv(ilev_)%iprcparm(mld_ml_type_) = mld_mult_ml_
p%baseprecv(ilev_)%iprcparm(mld_aggr_alg_) = mld_dec_aggr_
p%baseprecv(ilev_)%iprcparm(mld_aggr_kind_) = mld_smooth_prol_
p%baseprecv(ilev_)%iprcparm(mld_smoother_pos_) = mld_post_smooth_
p%baseprecv(ilev_)%iprcparm(mld_aggr_omega_alg_) = mld_eig_est_
p%baseprecv(ilev_)%iprcparm(mld_aggr_eig_) = mld_max_norm_
p%baseprecv(ilev_)%iprcparm(mld_sub_fillin_) = 0
p%baseprecv(ilev_)%iprcparm(mld_smoother_sweeps_) = 4
p%baseprecv(ilev_)%rprcparm(mld_aggr_omega_val_) = szero
p%baseprecv(ilev_)%rprcparm(mld_aggr_thresh_) = szero
p%precv(ilev_)%prec%iprcparm(mld_smoother_type_) = mld_bjac_
p%precv(ilev_)%prec%iprcparm(mld_coarse_mat_) = mld_distr_mat_
p%precv(ilev_)%prec%iprcparm(mld_sub_restr_) = psb_none_
p%precv(ilev_)%prec%iprcparm(mld_sub_prol_) = psb_none_
p%precv(ilev_)%prec%iprcparm(mld_sub_ren_) = 0
p%precv(ilev_)%prec%iprcparm(mld_sub_ovr_) = 0
p%precv(ilev_)%prec%iprcparm(mld_sub_fillin_) = 0
p%precv(ilev_)%prec%iprcparm(mld_smoother_sweeps_) = 4
p%precv(ilev_)%iprcparm(mld_ml_type_) = mld_mult_ml_
p%precv(ilev_)%iprcparm(mld_aggr_alg_) = mld_dec_aggr_
p%precv(ilev_)%iprcparm(mld_aggr_kind_) = mld_smooth_prol_
p%precv(ilev_)%iprcparm(mld_smoother_pos_) = mld_post_smooth_
p%precv(ilev_)%iprcparm(mld_aggr_omega_alg_) = mld_eig_est_
p%precv(ilev_)%iprcparm(mld_aggr_eig_) = mld_max_norm_
p%precv(ilev_)%rprcparm(mld_aggr_omega_val_) = szero
p%precv(ilev_)%rprcparm(mld_aggr_thresh_) = szero
case default
write(0,*) name,': Warning: Unknown preconditioner type request "',ptype,'"'
info = 2

115
mlprec/mld_cprecset.f90
Unescape Escape View File

@ -69,7 +69,6 @@
! If nlev is not present, the parameter identified by 'what'
! is set at all the appropriate levels.
!
!
! NOTE: currently, the use of the argument ilev is not "safe" and is reserved to
! MLD2P4 developers. Indeed, by using ilev it is possible to set different values
! of the same parameter at different levels 1,...,nlev-1, even in cases where
@ -97,12 +96,12 @@ subroutine mld_cprecseti(p,what,val,info,ilev)
info = 0
if (.not.allocated(p%baseprecv)) then
if (.not.allocated(p%precv)) then
info = 3111
write(0,*) name,': Error: uninitialized preconditioner, should call MLD_PRECINIT'
return
endif
nlev_ = size(p%baseprecv)
nlev_ = size(p%precv)
if (present(ilev)) then
ilev_ = ilev
@ -115,7 +114,13 @@ subroutine mld_cprecseti(p,what,val,info,ilev)
write(0,*) name,': Error: invalid ILEV/NLEV combination',ilev_, nlev_
return
endif
if (.not.allocated(p%baseprecv(ilev_)%iprcparm)) then
if (.not.allocated(p%precv(ilev_)%iprcparm)) then
info = 3111
write(0,*) name,&
&': Error: uninitialized preconditioner component, should call MLD_PRECINIT'
return
endif
if (.not.allocated(p%precv(ilev_)%prec%iprcparm)) then
info = 3111
write(0,*) name,&
&': Error: uninitialized preconditioner component, should call MLD_PRECINIT'
@ -134,7 +139,7 @@ subroutine mld_cprecseti(p,what,val,info,ilev)
select case(what)
case(mld_smoother_type_,mld_sub_solve_,mld_sub_restr_,mld_sub_prol_,&
& mld_sub_ren_,mld_sub_ovr_,mld_sub_fillin_,mld_smoother_sweeps_)
p%baseprecv(ilev_)%iprcparm(what) = val
p%precv(ilev_)%prec%iprcparm(what) = val
case default
write(0,*) name,': Error: invalid WHAT'
info = -2
@ -144,23 +149,25 @@ subroutine mld_cprecseti(p,what,val,info,ilev)
select case(what)
case(mld_smoother_type_,mld_sub_solve_,mld_sub_restr_,mld_sub_prol_,&
& mld_sub_ren_,mld_sub_ovr_,mld_sub_fillin_,&
& mld_smoother_sweeps_,mld_ml_type_,mld_aggr_alg_,mld_aggr_kind_,&
& mld_smoother_sweeps_)
p%precv(ilev_)%prec%iprcparm(what) = val
case(mld_ml_type_,mld_aggr_alg_,mld_aggr_kind_,&
& mld_smoother_pos_,mld_aggr_omega_alg_,mld_aggr_eig_)
p%baseprecv(ilev_)%iprcparm(what) = val
p%precv(ilev_)%iprcparm(what) = val
case(mld_coarse_mat_)
if (ilev_ /= nlev_ .and. val /= mld_distr_mat_) then
write(0,*) name,': Error: Inconsistent specification of WHAT vs. ILEV'
info = -2
return
end if
p%baseprecv(ilev_)%iprcparm(mld_coarse_mat_) = val
p%precv(ilev_)%iprcparm(mld_coarse_mat_) = val
case(mld_coarse_subsolve_)
if (ilev_ /= nlev_) then
write(0,*) name,': Error: Inconsistent specification of WHAT vs. ILEV'
info = -2
return
end if
p%baseprecv(ilev_)%iprcparm(mld_sub_solve_) = val
p%precv(ilev_)%iprcparm(mld_sub_solve_) = val
case(mld_coarse_solve_)
if (ilev_ /= nlev_) then
write(0,*) name,': Error: Inconsistent specification of WHAT vs. ILEV'
@ -169,15 +176,15 @@ subroutine mld_cprecseti(p,what,val,info,ilev)
end if
if (nlev_ > 1) then
p%baseprecv(nlev_)%iprcparm(mld_coarse_solve_) = val
p%baseprecv(nlev_)%iprcparm(mld_smoother_type_) = mld_bjac_
p%baseprecv(nlev_)%iprcparm(mld_coarse_mat_) = mld_distr_mat_
p%precv(nlev_)%iprcparm(mld_coarse_solve_) = val
p%precv(nlev_)%prec%iprcparm(mld_smoother_type_) = mld_bjac_
p%precv(nlev_)%iprcparm(mld_coarse_mat_) = mld_distr_mat_
select case (val)
case(mld_umf_, mld_slu_)
p%baseprecv(nlev_)%iprcparm(mld_coarse_mat_) = mld_repl_mat_
p%baseprecv(nlev_)%iprcparm(mld_sub_solve_) = val
p%precv(nlev_)%iprcparm(mld_coarse_mat_) = mld_repl_mat_
p%precv(nlev_)%prec%iprcparm(mld_sub_solve_) = val
case(mld_sludist_)
p%baseprecv(nlev_)%iprcparm(mld_sub_solve_) = val
p%precv(nlev_)%prec%iprcparm(mld_sub_solve_) = val
end select
endif
case(mld_coarse_sweeps_)
@ -186,14 +193,14 @@ subroutine mld_cprecseti(p,what,val,info,ilev)
info = -2
return
end if
p%baseprecv(ilev_)%iprcparm(mld_smoother_sweeps_) = val
p%precv(ilev_)%prec%iprcparm(mld_smoother_sweeps_) = val
case(mld_coarse_fillin_)
if (ilev_ /= nlev_) then
write(0,*) name,': Error: Inconsistent specification of WHAT vs. ILEV'
info = -2
return
end if
p%baseprecv(ilev_)%iprcparm(mld_sub_fillin_) = val
p%precv(ilev_)%prec%iprcparm(mld_sub_fillin_) = val
case default
write(0,*) name,': Error: invalid WHAT'
info = -2
@ -211,35 +218,35 @@ subroutine mld_cprecseti(p,what,val,info,ilev)
& mld_sub_ren_,mld_sub_ovr_,mld_sub_fillin_,&
& mld_smoother_sweeps_)
do ilev_=1,max(1,nlev_-1)
if (.not.allocated(p%baseprecv(ilev_)%iprcparm)) then
if (.not.allocated(p%precv(ilev_)%iprcparm)) then
write(0,*) name,&
&': Error: uninitialized preconditioner component, should call MLD_PRECINIT'
info = -1
return
endif
p%baseprecv(ilev_)%iprcparm(what) = val
p%precv(ilev_)%prec%iprcparm(what) = val
end do
case(mld_ml_type_,mld_aggr_alg_,mld_aggr_kind_,&
& mld_smoother_pos_,mld_aggr_omega_alg_,mld_aggr_eig_)
do ilev_=2,nlev_
if (.not.allocated(p%baseprecv(ilev_)%iprcparm)) then
if (.not.allocated(p%precv(ilev_)%iprcparm)) then
write(0,*) name,&
&': Error: uninitialized preconditioner component, should call MLD_PRECINIT'
info = -1
return
endif
p%baseprecv(ilev_)%iprcparm(what) = val
p%precv(ilev_)%iprcparm(what) = val
end do
case(mld_coarse_mat_)
if (.not.allocated(p%baseprecv(nlev_)%iprcparm)) then
if (.not.allocated(p%precv(nlev_)%iprcparm)) then
write(0,*) name,&
& ': Error: uninitialized preconditioner component, should call MLD_PRECINIT'
info = -1
return
endif
if (nlev_ > 1) p%baseprecv(nlev_)%iprcparm(mld_coarse_mat_) = val
if (nlev_ > 1) p%precv(nlev_)%iprcparm(mld_coarse_mat_) = val
case(mld_coarse_solve_)
if (.not.allocated(p%baseprecv(nlev_)%iprcparm)) then
if (.not.allocated(p%precv(nlev_)%iprcparm)) then
write(0,*) name,&
&': Error: uninitialized preconditioner component, should call MLD_PRECINIT'
info = -1
@ -247,42 +254,42 @@ subroutine mld_cprecseti(p,what,val,info,ilev)
endif
if (nlev_ > 1) then
p%baseprecv(nlev_)%iprcparm(mld_coarse_solve_) = val
p%baseprecv(nlev_)%iprcparm(mld_smoother_type_) = mld_bjac_
p%baseprecv(nlev_)%iprcparm(mld_coarse_mat_) = mld_distr_mat_
p%precv(nlev_)%iprcparm(mld_coarse_solve_) = val
p%precv(nlev_)%prec%iprcparm(mld_smoother_type_) = mld_bjac_
p%precv(nlev_)%iprcparm(mld_coarse_mat_) = mld_distr_mat_
select case (val)
case(mld_umf_, mld_slu_)
p%baseprecv(nlev_)%iprcparm(mld_coarse_mat_) = mld_repl_mat_
p%baseprecv(nlev_)%iprcparm(mld_sub_solve_) = val
p%precv(nlev_)%iprcparm(mld_coarse_mat_) = mld_repl_mat_
p%precv(nlev_)%prec%iprcparm(mld_sub_solve_) = val
case(mld_sludist_)
p%baseprecv(nlev_)%iprcparm(mld_sub_solve_) = val
p%precv(nlev_)%prec%iprcparm(mld_sub_solve_) = val
end select
endif
case(mld_coarse_subsolve_)
if (.not.allocated(p%baseprecv(nlev_)%iprcparm)) then
if (.not.allocated(p%precv(nlev_)%iprcparm)) then
write(0,*) name,&
&': Error: uninitialized preconditioner component, should call MLD_PRECINIT'
info = -1
return
end if
if (nlev_ > 1) p%baseprecv(nlev_)%iprcparm(mld_sub_solve_) = val
if (nlev_ > 1) p%precv(nlev_)%prec%iprcparm(mld_sub_solve_) = val
case(mld_coarse_sweeps_)
if (.not.allocated(p%baseprecv(nlev_)%iprcparm)) then
if (.not.allocated(p%precv(nlev_)%iprcparm)) then
write(0,*) name,&
&': Error: uninitialized preconditioner component, should call MLD_PRECINIT'
info = -1
return
endif
if (nlev_ > 1) p%baseprecv(nlev_)%iprcparm(mld_smoother_sweeps_) = val
if (nlev_ > 1) p%precv(nlev_)%prec%iprcparm(mld_smoother_sweeps_) = val
case(mld_coarse_fillin_)
if (.not.allocated(p%baseprecv(nlev_)%iprcparm)) then
if (.not.allocated(p%precv(nlev_)%iprcparm)) then
write(0,*) name,&
&': Error: uninitialized preconditioner component, should call MLD_PRECINIT'
info = -1
return
endif
if (nlev_ > 1) p%baseprecv(nlev_)%iprcparm(mld_sub_fillin_) = val
if (nlev_ > 1) p%precv(nlev_)%prec%iprcparm(mld_sub_fillin_) = val
case default
write(0,*) name,': Error: invalid WHAT'
info = -2
@ -353,11 +360,11 @@ subroutine mld_cprecsetc(p,what,string,info,ilev)
info = 0
if (.not.allocated(p%baseprecv)) then
if (.not.allocated(p%precv)) then
info = 3111
return
endif
nlev_ = size(p%baseprecv)
nlev_ = size(p%precv)
if (present(ilev)) then
ilev_ = ilev
@ -370,7 +377,7 @@ subroutine mld_cprecsetc(p,what,string,info,ilev)
info = -1
return
endif
if (.not.allocated(p%baseprecv(ilev_)%iprcparm)) then
if (.not.allocated(p%precv(ilev_)%iprcparm)) then
write(0,*) name,': Error: uninitialized preconditioner component, should call MLD_PRECINIT'
info = 3111
return
@ -450,19 +457,19 @@ subroutine mld_cprecsetr(p,what,val,info,ilev)
ilev_ = 1
end if
if (.not.allocated(p%baseprecv)) then
if (.not.allocated(p%precv)) then
write(0,*) name,': Error: uninitialized preconditioner, should call MLD_PRECINIT'
info = 3111
return
endif
nlev_ = size(p%baseprecv)
nlev_ = size(p%precv)
if ((ilev_<1).or.(ilev_ > nlev_)) then
write(0,*) name,': Error: invalid ILEV/NLEV combination',ilev_, nlev_
info = -1
return
endif
if (.not.allocated(p%baseprecv(ilev_)%rprcparm)) then
if (.not.allocated(p%precv(ilev_)%rprcparm)) then
write(0,*) name,': Error: uninitialized preconditioner component, should call MLD_PRECINIT'
info = 3111
return
@ -479,7 +486,7 @@ subroutine mld_cprecsetr(p,what,val,info,ilev)
!
select case(what)
case(mld_sub_iluthrs_)
p%baseprecv(ilev_)%rprcparm(what) = val
p%precv(ilev_)%prec%rprcparm(what) = val
case default
write(0,*) name,': Error: invalid WHAT'
info = -2
@ -487,8 +494,10 @@ subroutine mld_cprecsetr(p,what,val,info,ilev)
else if (ilev_ > 1) then
select case(what)
case(mld_aggr_omega_val_,mld_aggr_thresh_,mld_sub_iluthrs_)
p%baseprecv(ilev_)%rprcparm(what) = val
case(mld_sub_iluthrs_)
p%precv(ilev_)%prec%rprcparm(what) = val
case(mld_aggr_omega_val_,mld_aggr_thresh_)
p%precv(ilev_)%rprcparm(what) = val
case default
write(0,*) name,': Error: invalid WHAT'
info = -2
@ -503,38 +512,38 @@ subroutine mld_cprecsetr(p,what,val,info,ilev)
select case(what)
case(mld_sub_iluthrs_)
do ilev_=1,nlev_
if (.not.allocated(p%baseprecv(ilev_)%rprcparm)) then
if (.not.allocated(p%precv(ilev_)%rprcparm)) then
write(0,*) name,': Error: uninitialized preconditioner component, should call MLD_PRECINIT'
info = -1
return
endif
p%baseprecv(ilev_)%rprcparm(what) = val
p%precv(ilev_)%prec%rprcparm(what) = val
end do
case(mld_coarse_iluthrs_)
ilev_=nlev_
if (.not.allocated(p%baseprecv(ilev_)%rprcparm)) then
if (.not.allocated(p%precv(ilev_)%rprcparm)) then
write(0,*) name,': Error: uninitialized preconditioner component, should call MLD_PRECINIT'
info = -1
return
endif
p%baseprecv(ilev_)%rprcparm(mld_sub_iluthrs_) = val
p%precv(ilev_)%prec%rprcparm(mld_sub_iluthrs_) = val
case(mld_aggr_omega_val_)
do ilev_=2,nlev_
if (.not.allocated(p%baseprecv(ilev_)%rprcparm)) then
if (.not.allocated(p%precv(ilev_)%rprcparm)) then
write(0,*) name,': Error: uninitialized preconditioner component, should call MLD_PRECINIT'
info = -1
return
endif
p%baseprecv(ilev_)%rprcparm(what) = val
p%precv(ilev_)%rprcparm(what) = val
end do
case(mld_aggr_thresh_)
do ilev_=2,nlev_
if (.not.allocated(p%baseprecv(ilev_)%rprcparm)) then
if (.not.allocated(p%precv(ilev_)%rprcparm)) then
write(0,*) name,': Error: uninitialized preconditioner component, should call MLD_PRECINIT'
info = -1
return
endif
p%baseprecv(ilev_)%rprcparm(what) = val
p%precv(ilev_)%rprcparm(what) = val
end do
case default
write(0,*) name,': Error: invalid WHAT'

2
mlprec/mld_daggrmap_bld.f90
Unescape Escape View File

@ -131,7 +131,7 @@ subroutine mld_daggrmap_bld(aggr_type,theta,a,desc_a,nlaggr,ilaggr,info)
atmp%m=nr
atmp%k=nr
if (info == 0) call psb_sp_free(atrans,info)
if (info == 0) call psb_ipcoo2csr(atmp,info)
if (info == 0) call psb_spcnv(atmp,info,afmt='csr')
if (info == 0) call mld_dec_map_bld(theta,atmp,desc_a,nlaggr,ilaggr,info)
if (info == 0) call psb_sp_free(atmp,info)

23
mlprec/mld_daggrmat_asb.f90
Unescape Escape View File

@ -76,24 +76,21 @@
! 1181-1196.
!
!
!
! Arguments:
! a - type(psb_dspmat_type), input.
! The sparse matrix structure containing the local part of
! the fine-level matrix.
! desc_a - type(psb_desc_type), input.
! The communication descriptor of the fine-level matrix.
! ac - type(psb_dspmat_type), output.
! The sparse matrix structure containing the local part of
! the coarse-level matrix.
! desc_ac - type(psb_desc_type), output.
! The communication descriptor of the coarse-level matrix.
! p - type(mld_dbaseprc_type), input/output.
! The base preconditioner data structure containing the local
! part of the base preconditioner to be built.
! p - type(mld_d_onelev_prec_type), input/output.
! The one-level preconditioner data structure containing the local
! part of the base preconditioner to be built as well as the
! aggregate matrices.
! info - integer, output.
! Error code.
!
subroutine mld_daggrmat_asb(a,desc_a,ac,desc_ac,p,info)
subroutine mld_daggrmat_asb(a,desc_a,p,info)
use psb_base_mod
use mld_inner_mod, mld_protect_name => mld_daggrmat_asb
@ -103,9 +100,7 @@ subroutine mld_daggrmat_asb(a,desc_a,ac,desc_ac,p,info)
! Arguments
type(psb_dspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_a
type(psb_dspmat_type), intent(out) :: ac
type(psb_desc_type), intent(out) :: desc_ac
type(mld_dbaseprc_type), intent(inout), target :: p
type(mld_d_onelev_prec_type), intent(inout), target :: p
integer, intent(out) :: info
! Local variables
@ -125,7 +120,7 @@ subroutine mld_daggrmat_asb(a,desc_a,ac,desc_ac,p,info)
select case (p%iprcparm(mld_aggr_kind_))
case (mld_no_smooth_)
call mld_aggrmat_raw_asb(a,desc_a,ac,desc_ac,p,info)
call mld_aggrmat_raw_asb(a,desc_a,p,info)
if(info /= 0) then
call psb_errpush(4010,name,a_err='mld_aggrmat_raw_asb')
goto 9999
@ -133,7 +128,7 @@ subroutine mld_daggrmat_asb(a,desc_a,ac,desc_ac,p,info)
case(mld_smooth_prol_,mld_biz_prol_)
call mld_aggrmat_smth_asb(a,desc_a,ac,desc_ac,p,info)
call mld_aggrmat_smth_asb(a,desc_a,p,info)
if(info /= 0) then
call psb_errpush(4010,name,a_err='mld_aggrmat_smth_asb')
goto 9999

72
mlprec/mld_daggrmat_raw_asb.F90
Unescape Escape View File

@ -59,24 +59,21 @@
! 57 (2007), 1181-1196.
!
!
!
! Arguments:
! a - type(psb_dspmat_type), input.
! The sparse matrix structure containing the local part of
! the fine-level matrix.
! desc_a - type(psb_desc_type), input.
! The communication descriptor of the fine-level matrix.
! ac - type(psb_dspmat_type), output.
! The sparse matrix structure containing the local part of
! the coarse-level matrix.
! desc_ac - type(psb_desc_type), output.
! The communication descriptor of the coarse-level matrix.
! p - type(mld_dbaseprc_type), input/output.
! The base preconditioner data structure containing the local
! part of the base preconditioner to be built.
! p - type(mld_d_onelev_prec_type), input/output.
! The one-level preconditioner data structure containing the local
! part of the base preconditioner to be built as well as the
! aggregate matrices.
! info - integer, output.
! Error code.
!
subroutine mld_daggrmat_raw_asb(a,desc_a,ac,desc_ac,p,info)
subroutine mld_daggrmat_raw_asb(a,desc_a,p,info)
use psb_base_mod
use mld_inner_mod, mld_protect_name => mld_daggrmat_raw_asb
@ -91,17 +88,15 @@ subroutine mld_daggrmat_raw_asb(a,desc_a,ac,desc_ac,p,info)
! Arguments
type(psb_dspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_a
type(psb_dspmat_type), intent(out) :: ac
type(psb_desc_type), intent(out) :: desc_ac
type(mld_dbaseprc_type), intent(inout), target :: p
type(mld_d_onelev_prec_type), intent(inout), target :: p
integer, intent(out) :: info
! Local variables
integer ::ictxt,np,me, err_act, icomm
character(len=20) :: name
type(psb_dspmat_type) :: b
integer, pointer :: nzbr(:), idisp(:)
type(psb_dspmat_type), pointer :: am1,am2
integer, allocatable :: nzbr(:), idisp(:)
type(psb_dspmat_type) :: am1,am2
integer :: nrow, nglob, ncol, ntaggr, nzac, ip, ndx,&
& naggr, nzt, naggrm1, i
@ -119,9 +114,6 @@ subroutine mld_daggrmat_raw_asb(a,desc_a,ac,desc_ac,p,info)
nrow = psb_cd_get_local_rows(desc_a)
ncol = psb_cd_get_local_cols(desc_a)
am2 => p%av(mld_sm_pr_t_)
am1 => p%av(mld_sm_pr_)
call psb_nullify_sp(am1)
call psb_nullify_sp(am2)
@ -195,7 +187,7 @@ subroutine mld_daggrmat_raw_asb(a,desc_a,ac,desc_ac,p,info)
if (p%iprcparm(mld_coarse_mat_) == mld_repl_mat_) then
call psb_cdall(ictxt,desc_ac,info,mg=ntaggr,repl=.true.)
call psb_cdall(ictxt,p%desc_ac,info,mg=ntaggr,repl=.true.)
if(info /= 0) then
call psb_errpush(4010,name,a_err='psb_cdall')
goto 9999
@ -206,7 +198,7 @@ subroutine mld_daggrmat_raw_asb(a,desc_a,ac,desc_ac,p,info)
call psb_sum(ictxt,nzbr(1:np))
nzac = sum(nzbr)
call psb_sp_all(ntaggr,ntaggr,ac,nzac,info)
call psb_sp_all(ntaggr,ntaggr,p%ac,nzac,info)
if(info /= 0) then
call psb_errpush(4010,name,a_err='sp_all')
goto 9999
@ -217,11 +209,11 @@ subroutine mld_daggrmat_raw_asb(a,desc_a,ac,desc_ac,p,info)
enddo
ndx = nzbr(me+1)
call mpi_allgatherv(b%aspk,ndx,mpi_double_precision,ac%aspk,nzbr,idisp,&
call mpi_allgatherv(b%aspk,ndx,mpi_double_precision,p%ac%aspk,nzbr,idisp,&
& mpi_double_precision,icomm,info)
call mpi_allgatherv(b%ia1,ndx,mpi_integer,ac%ia1,nzbr,idisp,&
call mpi_allgatherv(b%ia1,ndx,mpi_integer,p%ac%ia1,nzbr,idisp,&
& mpi_integer,icomm,info)
call mpi_allgatherv(b%ia2,ndx,mpi_integer,ac%ia2,nzbr,idisp,&
call mpi_allgatherv(b%ia2,ndx,mpi_integer,p%ac%ia2,nzbr,idisp,&
& mpi_integer,icomm,info)
if(info /= 0) then
info=-1
@ -229,12 +221,12 @@ subroutine mld_daggrmat_raw_asb(a,desc_a,ac,desc_ac,p,info)
goto 9999
end if
ac%m = ntaggr
ac%k = ntaggr
ac%infoa(psb_nnz_) = nzac
ac%fida='COO'
ac%descra='GUN'
call psb_spcnv(ac,info,afmt='coo',dupl=psb_dupl_add_)
p%ac%m = ntaggr
p%ac%k = ntaggr
p%ac%infoa(psb_nnz_) = nzac
p%ac%fida='COO'
p%ac%descra='GUN'
call psb_spcnv(p%ac,info,afmt='coo',dupl=psb_dupl_add_)
if(info /= 0) then
call psb_errpush(4010,name,a_err='sp_free')
goto 9999
@ -242,9 +234,9 @@ subroutine mld_daggrmat_raw_asb(a,desc_a,ac,desc_ac,p,info)
else if (p%iprcparm(mld_coarse_mat_) == mld_distr_mat_) then
call psb_cdall(ictxt,desc_ac,info,nl=naggr)
if (info == 0) call psb_cdasb(desc_ac,info)
if (info == 0) call psb_sp_clone(b,ac,info)
call psb_cdall(ictxt,p%desc_ac,info,nl=naggr)
if (info == 0) call psb_cdasb(p%desc_ac,info)
if (info == 0) call psb_sp_clone(b,p%ac,info)
if(info /= 0) then
call psb_errpush(4001,name,a_err='Build ac, desc_ac')
goto 9999
@ -263,9 +255,23 @@ subroutine mld_daggrmat_raw_asb(a,desc_a,ac,desc_ac,p,info)
deallocate(nzbr,idisp)
call psb_spcnv(ac,info,afmt='csr',dupl=psb_dupl_add_)
call psb_spcnv(p%ac,info,afmt='csr',dupl=psb_dupl_add_)
if(info /= 0) then
call psb_errpush(4010,name,a_err='spcnv')
goto 9999
end if
!
! Copy the prolongation/restriction matrices into the descriptor map.
! am2 => PR^T i.e. restriction operator
! am1 => PR i.e. prolongation operator
!
p%map_desc = psb_inter_desc(psb_map_aggr_,desc_a,&
& p%desc_ac,am2,am1)
if (info == 0) call psb_sp_free(am1,info)
if (info == 0) call psb_sp_free(am2,info)
if(info /= 0) then
call psb_errpush(4010,name,a_err='ipcoo2csr')
call psb_errpush(4010,name,a_err='sp_Free')
goto 9999
end if

126
mlprec/mld_daggrmat_smth_asb.F90
Unescape Escape View File

@ -83,18 +83,14 @@
! the fine-level matrix.
! desc_a - type(psb_desc_type), input.
! The communication descriptor of the fine-level matrix.
! ac - type(psb_dspmat_type), output.
! The sparse matrix structure containing the local part of
! the coarse-level matrix.
! desc_ac - type(psb_desc_type), output.
! The communication descriptor of the coarse-level matrix.
! p - type(mld_dbaseprc_type), input/output.
! The base preconditioner data structure containing the local
! part of the base preconditioner to be built.
! p - type(mld_d_onelev_prec_type), input/output.
! The one-level preconditioner data structure containing the local
! part of the base preconditioner to be built as well as the
! aggregate matrices.
! info - integer, output.
! Error code.
!
subroutine mld_daggrmat_smth_asb(a,desc_a,ac,desc_ac,p,info)
subroutine mld_daggrmat_smth_asb(a,desc_a,p,info)
use psb_base_mod
use mld_inner_mod, mld_protect_name => mld_daggrmat_smth_asb
@ -109,19 +105,17 @@ subroutine mld_daggrmat_smth_asb(a,desc_a,ac,desc_ac,p,info)
! Arguments
type(psb_dspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_a
type(psb_dspmat_type), intent(out) :: ac
type(psb_desc_type), intent(out) :: desc_ac
type(mld_dbaseprc_type), intent(inout), target :: p
type(mld_d_onelev_prec_type), intent(inout), target :: p
integer, intent(out) :: info
! Local variables
type(psb_dspmat_type) :: b
integer, pointer :: nzbr(:), idisp(:)
integer, allocatable :: nzbr(:), idisp(:)
integer :: nrow, nglob, ncol, ntaggr, nzac, ip, ndx,&
& naggr, nzl,naggrm1,naggrp1, i, j, k
integer ::ictxt,np,me, err_act, icomm
character(len=20) :: name
type(psb_dspmat_type), pointer :: am1,am2
type(psb_dspmat_type) :: am1,am2
type(psb_dspmat_type) :: am3,am4
real(psb_dpk_), allocatable :: adiag(:)
logical :: ml_global_nmb
@ -146,9 +140,6 @@ subroutine mld_daggrmat_smth_asb(a,desc_a,ac,desc_ac,p,info)
call psb_nullify_sp(b)
call psb_nullify_sp(am3)
call psb_nullify_sp(am4)
am2 => p%av(mld_sm_pr_t_)
am1 => p%av(mld_sm_pr_)
call psb_nullify_sp(am1)
call psb_nullify_sp(am2)
@ -456,16 +447,16 @@ subroutine mld_daggrmat_smth_asb(a,desc_a,ac,desc_ac,p,info)
case(mld_distr_mat_)
call psb_sp_clone(b,ac,info)
nzac = ac%infoa(psb_nnz_)
nzl = ac%infoa(psb_nnz_)
if (info == 0) call psb_cdall(ictxt,desc_ac,info,nl=p%nlaggr(me+1))
if (info == 0) call psb_cdins(nzl,ac%ia1,ac%ia2,desc_ac,info)
if (info == 0) call psb_cdasb(desc_ac,info)
if (info == 0) call psb_glob_to_loc(ac%ia1(1:nzl),desc_ac,info,iact='I')
if (info == 0) call psb_glob_to_loc(ac%ia2(1:nzl),desc_ac,info,iact='I')
call psb_sp_clone(b,p%ac,info)
nzac = p%ac%infoa(psb_nnz_)
nzl = p%ac%infoa(psb_nnz_)
if (info == 0) call psb_cdall(ictxt,p%desc_ac,info,nl=p%nlaggr(me+1))
if (info == 0) call psb_cdins(nzl,p%ac%ia1,p%ac%ia2,p%desc_ac,info)
if (info == 0) call psb_cdasb(p%desc_ac,info)
if (info == 0) call psb_glob_to_loc(p%ac%ia1(1:nzl),p%desc_ac,info,iact='I')
if (info == 0) call psb_glob_to_loc(p%ac%ia2(1:nzl),p%desc_ac,info,iact='I')
if (info /= 0) then
call psb_errpush(4001,name,a_err='Creating desc_ac and converting ac')
call psb_errpush(4001,name,a_err='Creating p%desc_ac and converting ac')
goto 9999
end if
if (debug_level >= psb_debug_outer_) &
@ -473,10 +464,10 @@ subroutine mld_daggrmat_smth_asb(a,desc_a,ac,desc_ac,p,info)
& 'Assembld aux descr. distr.'
ac%m=desc_ac%matrix_data(psb_n_row_)
ac%k=desc_ac%matrix_data(psb_n_col_)
ac%fida='COO'
ac%descra='GUN'
p%ac%m=psb_cd_get_local_rows(p%desc_ac)
p%ac%k=psb_cd_get_local_cols(p%desc_ac)
p%ac%fida='COO'
p%ac%descra='GUN'
call psb_sp_free(b,info)
if (info == 0) deallocate(nzbr,idisp,stat=info)
@ -487,25 +478,25 @@ subroutine mld_daggrmat_smth_asb(a,desc_a,ac,desc_ac,p,info)
if (np>1) then
nzl = psb_sp_get_nnzeros(am1)
call psb_glob_to_loc(am1%ia1(1:nzl),desc_ac,info,'I')
call psb_glob_to_loc(am1%ia1(1:nzl),p%desc_ac,info,'I')
if(info /= 0) then
call psb_errpush(4010,name,a_err='psb_glob_to_loc')
goto 9999
end if
endif
am1%k=desc_ac%matrix_data(psb_n_col_)
am1%k=psb_cd_get_local_cols(p%desc_ac)
if (np>1) then
call psb_spcnv(am2,info,afmt='coo',dupl=psb_dupl_add_)
nzl = am2%infoa(psb_nnz_)
if (info == 0) call psb_glob_to_loc(am2%ia1(1:nzl),desc_ac,info,'I')
if (info == 0) call psb_glob_to_loc(am2%ia1(1:nzl),p%desc_ac,info,'I')
if (info == 0) call psb_spcnv(am2,info,afmt='csr',dupl=psb_dupl_add_)
if(info /= 0) then
call psb_errpush(4001,name,a_err='Converting am2 to local')
goto 9999
end if
end if
am2%m=desc_ac%matrix_data(psb_n_col_)
am2%m=psb_cd_get_local_cols(p%desc_ac)
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
@ -514,13 +505,13 @@ subroutine mld_daggrmat_smth_asb(a,desc_a,ac,desc_ac,p,info)
case(mld_repl_mat_)
!
!
call psb_cdall(ictxt,desc_ac,info,mg=ntaggr,repl=.true.)
call psb_cdall(ictxt,p%desc_ac,info,mg=ntaggr,repl=.true.)
nzbr(:) = 0
nzbr(me+1) = b%infoa(psb_nnz_)
call psb_sum(ictxt,nzbr(1:np))
nzac = sum(nzbr)
if (info == 0) call psb_sp_all(ntaggr,ntaggr,ac,nzac,info)
if (info == 0) call psb_sp_all(ntaggr,ntaggr,p%ac,nzac,info)
if (info /= 0) goto 9999
do ip=1,np
@ -528,11 +519,11 @@ subroutine mld_daggrmat_smth_asb(a,desc_a,ac,desc_ac,p,info)
enddo
ndx = nzbr(me+1)
call mpi_allgatherv(b%aspk,ndx,mpi_double_precision,ac%aspk,nzbr,idisp,&
call mpi_allgatherv(b%aspk,ndx,mpi_double_precision,p%ac%aspk,nzbr,idisp,&
& mpi_double_precision,icomm,info)
if (info == 0) call mpi_allgatherv(b%ia1,ndx,mpi_integer,ac%ia1,nzbr,idisp,&
if (info == 0) call mpi_allgatherv(b%ia1,ndx,mpi_integer,p%ac%ia1,nzbr,idisp,&
& mpi_integer,icomm,info)
if (info == 0) call mpi_allgatherv(b%ia2,ndx,mpi_integer,ac%ia2,nzbr,idisp,&
if (info == 0) call mpi_allgatherv(b%ia2,ndx,mpi_integer,p%ac%ia2,nzbr,idisp,&
& mpi_integer,icomm,info)
if (info /= 0) then
@ -540,12 +531,12 @@ subroutine mld_daggrmat_smth_asb(a,desc_a,ac,desc_ac,p,info)
goto 9999
end if
ac%m = ntaggr
ac%k = ntaggr
ac%infoa(psb_nnz_) = nzac
ac%fida='COO'
ac%descra='GUN'
call psb_spcnv(ac,info,afmt='coo',dupl=psb_dupl_add_)
p%ac%m = ntaggr
p%ac%k = ntaggr
p%ac%infoa(psb_nnz_) = nzac
p%ac%fida='COO'
p%ac%descra='GUN'
call psb_spcnv(p%ac,info,afmt='coo',dupl=psb_dupl_add_)
if(info /= 0) goto 9999
call psb_sp_free(b,info)
if(info /= 0) goto 9999
@ -569,9 +560,9 @@ subroutine mld_daggrmat_smth_asb(a,desc_a,ac,desc_ac,p,info)
case(mld_distr_mat_)
call psb_sp_clone(b,ac,info)
if (info == 0) call psb_cdall(ictxt,desc_ac,info,nl=naggr)
if (info == 0) call psb_cdasb(desc_ac,info)
call psb_sp_clone(b,p%ac,info)
if (info == 0) call psb_cdall(ictxt,p%desc_ac,info,nl=naggr)
if (info == 0) call psb_cdasb(p%desc_ac,info)
if (info == 0) call psb_sp_free(b,info)
if (info /= 0) then
call psb_errpush(4010,name,a_err='Build desc_ac, ac')
@ -582,7 +573,7 @@ subroutine mld_daggrmat_smth_asb(a,desc_a,ac,desc_ac,p,info)
case(mld_repl_mat_)
!
!
call psb_cdall(ictxt,desc_ac,info,mg=ntaggr,repl=.true.)
call psb_cdall(ictxt,p%desc_ac,info,mg=ntaggr,repl=.true.)
if(info /= 0) then
call psb_errpush(4010,name,a_err='psb_cdall')
goto 9999
@ -592,7 +583,7 @@ subroutine mld_daggrmat_smth_asb(a,desc_a,ac,desc_ac,p,info)
nzbr(me+1) = b%infoa(psb_nnz_)
call psb_sum(ictxt,nzbr(1:np))
nzac = sum(nzbr)
call psb_sp_all(ntaggr,ntaggr,ac,nzac,info)
call psb_sp_all(ntaggr,ntaggr,p%ac,nzac,info)
if(info /= 0) then
call psb_errpush(4010,name,a_err='psb_sp_all')
goto 9999
@ -603,11 +594,11 @@ subroutine mld_daggrmat_smth_asb(a,desc_a,ac,desc_ac,p,info)
enddo
ndx = nzbr(me+1)
call mpi_allgatherv(b%aspk,ndx,mpi_double_precision,ac%aspk,nzbr,idisp,&
call mpi_allgatherv(b%aspk,ndx,mpi_double_precision,p%ac%aspk,nzbr,idisp,&
& mpi_double_precision,icomm,info)
if (info == 0) call mpi_allgatherv(b%ia1,ndx,mpi_integer,ac%ia1,nzbr,idisp,&
if (info == 0) call mpi_allgatherv(b%ia1,ndx,mpi_integer,p%ac%ia1,nzbr,idisp,&
& mpi_integer,icomm,info)
if (info == 0) call mpi_allgatherv(b%ia2,ndx,mpi_integer,ac%ia2,nzbr,idisp,&
if (info == 0) call mpi_allgatherv(b%ia2,ndx,mpi_integer,p%ac%ia2,nzbr,idisp,&
& mpi_integer,icomm,info)
if (info /= 0) then
call psb_errpush(4001,name,a_err=' from mpi_allgatherv')
@ -615,12 +606,12 @@ subroutine mld_daggrmat_smth_asb(a,desc_a,ac,desc_ac,p,info)
end if
ac%m = ntaggr
ac%k = ntaggr
ac%infoa(psb_nnz_) = nzac
ac%fida='COO'
ac%descra='GUN'
call psb_spcnv(ac,info,afmt='coo',dupl=psb_dupl_add_)
p%ac%m = ntaggr
p%ac%k = ntaggr
p%ac%infoa(psb_nnz_) = nzac
p%ac%fida='COO'
p%ac%descra='GUN'
call psb_spcnv(p%ac,info,afmt='coo',dupl=psb_dupl_add_)
if(info /= 0) then
call psb_errpush(4010,name,a_err='spcnv')
goto 9999
@ -651,12 +642,27 @@ subroutine mld_daggrmat_smth_asb(a,desc_a,ac,desc_ac,p,info)
end select
call psb_spcnv(ac,info,afmt='csr',dupl=psb_dupl_add_)
call psb_spcnv(p%ac,info,afmt='csr',dupl=psb_dupl_add_)
if(info /= 0) then
call psb_errpush(4010,name,a_err='spcnv')
goto 9999
end if
!
! Copy the prolongation/restriction matrices into the descriptor map.
! am2 => PR^T i.e. restriction operator
! am1 => PR i.e. prolongation operator
!
p%map_desc = psb_inter_desc(psb_map_aggr_,desc_a,&
& p%desc_ac,am2,am1)
if (info == 0) call psb_sp_free(am1,info)
if (info == 0) call psb_sp_free(am2,info)
if(info /= 0) then
call psb_errpush(4010,name,a_err='sp_Free')
goto 9999
end if
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'Done smooth_aggregate '

2
mlprec/mld_dbaseprec_bld.f90
Unescape Escape View File

@ -197,8 +197,6 @@ subroutine mld_dbaseprc_bld(a,desc_a,p,info,upd)
end select
p%base_a => a
p%base_desc => desc_a
p%iprcparm(mld_prec_status_) = mld_prec_built_
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),': Done'

341
mlprec/mld_dmlprec_aply.f90
Unescape Escape View File

@ -46,7 +46,7 @@
! Y = beta*Y + alpha*op(M^(-1))*X,
! where
! - M is a multilevel domain decomposition (Schwarz) preconditioner associated
! to a certain matrix A and stored in the array baseprecv,
! to a certain matrix A and stored in the array precv,
! - op(M^(-1)) is M^(-1) or its transpose, according to the value of trans,
! - X and Y are vectors,
! - alpha and beta are scalars.
@ -55,9 +55,9 @@
! level where we might have a replicated index space) and each process takes care
! of one submatrix.
!
! The multilevel preconditioner M is regarded as an array of 'base preconditioners',
! The multilevel preconditioner M is regarded as an array of 'one-level preconditioners',
! each representing the part of the preconditioner associated to a certain level.
! For each level ilev, the base preconditioner K(ilev) is stored in baseprecv(ilev)
! For each level ilev, the preconditioner K(ilev) is stored in precv(ilev)
! and is associated to a matrix A(ilev), obtained by 'tranferring' the original
! matrix A (i.e. the matrix to be preconditioned) to the level ilev, through smoothed
! aggregation.
@ -78,64 +78,41 @@
! Arguments:
! alpha - real(psb_dpk_), input.
! The scalar alpha.
! baseprecv - type(mld_dbaseprc_type), dimension(:), input.
! The array of base preconditioner data structures containing the
! precv - type(mld_d_onelev_prec_type), dimension(:), input.
! The array of one-level preconditioner data structures containing the
! local parts of the preconditioners to be applied at each level.
! Note that nlev = size(baseprecv) = number of levels.
! baseprecv(ilev)%av - type(psb_dspmat_type), dimension(:), allocatable(:).
! The sparse matrices needed to apply the preconditioner
! at level ilev.
! baseprecv(ilev)%av(mld_l_pr_) - The L factor of the ILU factorization of
! the local diagonal block of A(ilev).
! baseprecv(ilev)%av(mld_u_pr_) - The U factor of the ILU factorization of the
! local diagonal block of A(ilev), except its
! diagonal entries (stored in baseprecv(ilev)%d).
! baseprecv(ilev)%av(mld_ap_nd_) - The entries of the local part of A(ilev)
! outside the diagonal block, for block-Jacobi
! sweeps.
! baseprecv(ilev)%av(mld_ac_) - The local part of the matrix A(ilev).
! baseprecv(ilev)%av(mld_sm_pr_) - The smoothed prolongator.
! It maps vectors (ilev) ---> (ilev-1).
! baseprecv(ilev)%av(mld_sm_pr_t_) - The smoothed prolongator transpose.
! It maps vectors (ilev-1) ---> (ilev).
! baseprecv(ilev)%d - real(psb_dpk_), dimension(:), allocatable.
! The diagonal entries of the U factor in the ILU
! factorization of A(ilev).
! baseprecv(ilev)%desc_data - type(psb_desc_type).
! The communication descriptor associated to the base
! preconditioner, i.e. to the sparse matrices needed
! to apply the base preconditioner at the current level.
! baseprecv(ilev)%desc_ac - type(psb_desc_type).
! Note that nlev = size(precv) = number of levels.
! precv(ilev)%prec - type(psb_dbaseprc_type)
! The "base" preconditioner for the current level
! precv(ilev)%ac - type(psb_dspmat_type)
! The local part of the matrix A(ilev).
! precv(ilev)%desc_ac - type(psb_desc_type).
! The communication descriptor associated to the sparse
! matrix A(ilev), stored in baseprecv(ilev)%av(mld_ac_).
! baseprecv(ilev)%iprcparm - integer, dimension(:), allocatable.
! The integer parameters defining the base
! preconditioner K(ilev).
! baseprecv(ilev)%rprcparm - real(psb_dpk_), dimension(:), allocatable.
! The real parameters defining the base preconditioner
! K(ilev).
! baseprecv(ilev)%perm - integer, dimension(:), allocatable.
! The row and column permutations applied to the local
! part of A(ilev) (defined only if baseprecv(ilev)%
! iprcparm(mld_sub_ren_)>0).
! baseprecv(ilev)%invperm - integer, dimension(:), allocatable.
! The inverse of the permutation stored in
! baseprecv(ilev)%perm.
! baseprecv(ilev)%mlia - integer, dimension(:), allocatable.
! matrix A(ilev)
! precv(ilev)%map_desc - type(psb_inter_desc_type)
! Stores the linear operators mapping between levels
! (ilev-1) and (ilev). These are the restriction and
! prolongation operators described in the sequel.
! precv(ilev)%iprcparm - integer, dimension(:), allocatable.
! The integer parameters defining the multilevel
! strategy
! precv(ilev)%rprcparm - real(psb_dpk_), dimension(:), allocatable.
! The real parameters defining the multilevel strategy
! precv(ilev)%mlia - integer, dimension(:), allocatable.
! The aggregation map (ilev-1) --> (ilev).
! In case of non-smoothed aggregation, it is used
! instead of mld_sm_pr_.
! baseprecv(ilev)%nlaggr - integer, dimension(:), allocatable.
! precv(ilev)%nlaggr - integer, dimension(:), allocatable.
! The number of aggregates (rows of A(ilev)) on the
! various processes.
! baseprecv(ilev)%base_a - type(psb_dspmat_type), pointer.
! precv(ilev)%base_a - type(psb_dspmat_type), pointer.
! Pointer (really a pointer!) to the base matrix of
! the current level, i.e. the local part of A(ilev);
! so we have a unified treatment of residuals. We
! need this to avoid passing explicitly the matrix
! A(ilev) to the routine which applies the
! preconditioner.
! baseprecv(ilev)%base_desc - type(psb_desc_type), pointer.
! precv(ilev)%base_desc - type(psb_desc_type), pointer.
! Pointer to the communication descriptor associated
! to the sparse matrix pointed by base_a.
!
@ -159,10 +136,10 @@
! Note that when the LU factorization of the matrix A(ilev) is computed instead of
! the ILU one, by using UMFPACK or SuperLU, the corresponding L and U factors
! are stored in data structures provided by UMFPACK or SuperLU and pointed by
! baseprecv(ilev)%iprcparm(mld_umf_ptr) or baseprecv(ilev)%iprcparm(mld_slu_ptr),
! precv(ilev)%prec%iprcparm(mld_umf_ptr) or precv(ilev)%prec%iprcparm(mld_slu_ptr),
! respectively.
!
subroutine mld_dmlprec_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info)
subroutine mld_dmlprec_aply(alpha,precv,x,beta,y,desc_data,trans,work,info)
use psb_base_mod
use mld_inner_mod, mld_protect_name => mld_dmlprec_aply
@ -171,7 +148,7 @@ subroutine mld_dmlprec_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info)
! Arguments
type(psb_desc_type),intent(in) :: desc_data
type(mld_dbaseprc_type), intent(in) :: baseprecv(:)
type(mld_d_onelev_prec_type), intent(in) :: precv(:)
real(psb_dpk_),intent(in) :: alpha,beta
real(psb_dpk_),intent(in) :: x(:)
real(psb_dpk_),intent(inout) :: y(:)
@ -196,11 +173,11 @@ subroutine mld_dmlprec_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info)
if (debug_level >= psb_debug_inner_) &
& write(debug_unit,*) me,' ',trim(name),&
& ' Entry ', size(baseprecv)
& ' Entry ', size(precv)
trans_ = psb_toupper(trans)
select case(baseprecv(2)%iprcparm(mld_ml_type_))
select case(precv(2)%iprcparm(mld_ml_type_))
case(mld_no_ml_)
!
@ -214,7 +191,7 @@ subroutine mld_dmlprec_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info)
! Additive multilevel
!
call add_ml_aply(alpha,baseprecv,x,beta,y,desc_data,trans_,work,info)
call add_ml_aply(alpha,precv,x,beta,y,desc_data,trans_,work,info)
case(mld_mult_ml_)
!
@ -225,15 +202,15 @@ subroutine mld_dmlprec_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info)
! Note that the transpose switches pre <-> post.
!
select case(baseprecv(2)%iprcparm(mld_smoother_pos_))
select case(precv(2)%iprcparm(mld_smoother_pos_))
case(mld_post_smooth_)
select case (trans_)
case('N')
call mlt_post_ml_aply(alpha,baseprecv,x,beta,y,desc_data,trans_,work,info)
call mlt_post_ml_aply(alpha,precv,x,beta,y,desc_data,trans_,work,info)
case('T','C')
call mlt_pre_ml_aply(alpha,baseprecv,x,beta,y,desc_data,trans_,work,info)
call mlt_pre_ml_aply(alpha,precv,x,beta,y,desc_data,trans_,work,info)
case default
info = 4001
call psb_errpush(info,name,a_err='invalid trans')
@ -244,9 +221,9 @@ subroutine mld_dmlprec_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info)
select case (trans_)
case('N')
call mlt_pre_ml_aply(alpha,baseprecv,x,beta,y,desc_data,trans_,work,info)
call mlt_pre_ml_aply(alpha,precv,x,beta,y,desc_data,trans_,work,info)
case('T','C')
call mlt_post_ml_aply(alpha,baseprecv,x,beta,y,desc_data,trans_,work,info)
call mlt_post_ml_aply(alpha,precv,x,beta,y,desc_data,trans_,work,info)
case default
info = 4001
call psb_errpush(info,name,a_err='invalid trans')
@ -255,12 +232,12 @@ subroutine mld_dmlprec_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info)
case(mld_twoside_smooth_)
call mlt_twoside_ml_aply(alpha,baseprecv,x,beta,y,desc_data,trans_,work,info)
call mlt_twoside_ml_aply(alpha,precv,x,beta,y,desc_data,trans_,work,info)
case default
info = 4013
call psb_errpush(info,name,a_err='invalid smooth_pos',&
& i_Err=(/baseprecv(2)%iprcparm(mld_smoother_pos_),0,0,0,0/))
& i_Err=(/precv(2)%iprcparm(mld_smoother_pos_),0,0,0,0/))
goto 9999
end select
@ -268,7 +245,7 @@ subroutine mld_dmlprec_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info)
case default
info = 4013
call psb_errpush(info,name,a_err='invalid mltype',&
& i_Err=(/baseprecv(2)%iprcparm(mld_ml_type_),0,0,0,0/))
& i_Err=(/precv(2)%iprcparm(mld_ml_type_),0,0,0,0/))
goto 9999
end select
@ -295,7 +272,7 @@ contains
! Y = beta*Y + alpha*op(M^(-1))*X,
! where
! - M is an additive multilevel domain decomposition (Schwarz) preconditioner
! associated to a certain matrix A and stored in the array baseprecv,
! associated to a certain matrix A and stored in the array precv,
! - op(M^(-1)) is M^(-1) or its transpose, according to the value of trans,
! - X and Y are vectors,
! - alpha and beta are scalars.
@ -307,9 +284,9 @@ contains
! level where we might have a replicated index space) and each process takes care
! of one submatrix.
!
! The multilevel preconditioner M is regarded as an array of 'base preconditioners',
! The multilevel preconditioner M is regarded as an array of 'one-level preconditioners',
! each representing the part of the preconditioner associated to a certain level.
! For each level ilev, the base preconditioner K(ilev) is stored in baseprecv(ilev)
! For each level ilev, the base preconditioner K(ilev) is stored in precv(ilev)
! and is associated to a matrix A(ilev), obtained by 'tranferring' the original
! matrix A (i.e. the matrix to be preconditioned) to the level ilev, through smoothed
! aggregation.
@ -357,13 +334,13 @@ contains
!
! 4. Yext = beta*Yext + alpha*Y(1)
!
subroutine add_ml_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info)
subroutine add_ml_aply(alpha,precv,x,beta,y,desc_data,trans,work,info)
implicit none
! Arguments
type(psb_desc_type),intent(in) :: desc_data
type(mld_dbaseprc_type), intent(in) :: baseprecv(:)
type(mld_d_onelev_prec_type), intent(in) :: precv(:)
real(psb_dpk_),intent(in) :: alpha,beta
real(psb_dpk_),intent(in) :: x(:)
real(psb_dpk_),intent(inout) :: y(:)
@ -372,10 +349,9 @@ contains
integer, intent(out) :: info
! Local variables
integer :: n_row,n_col
integer :: ictxt,np,me,i, nr2l,nc2l,err_act
integer :: debug_level, debug_unit
integer :: ismth, nlev, ilev, icm
integer :: nlev, ilev
character(len=20) :: name
type psb_mlprec_wrk_type
@ -394,9 +370,9 @@ contains
if (debug_level >= psb_debug_inner_) &
& write(debug_unit,*) me,' ',trim(name),&
& ' Entry ', size(baseprecv)
& ' Entry ', size(precv)
nlev = size(baseprecv)
nlev = size(precv)
allocate(mlprec_wrk(nlev),stat=info)
if (info /= 0) then
call psb_errpush(4010,name,a_err='Allocate')
@ -419,8 +395,8 @@ contains
mlprec_wrk(1)%x2l(:) = x(:)
mlprec_wrk(1)%y2l(:) = dzero
call mld_baseprec_aply(alpha,baseprecv(1),x,beta,y,&
& baseprecv(1)%base_desc,trans,work,info)
call mld_baseprec_aply(alpha,precv(1)%prec,x,beta,y,&
& precv(1)%base_desc,trans,work,info)
if (info /=0) then
call psb_errpush(4010,name,a_err='baseprec_aply')
goto 9999
@ -431,40 +407,33 @@ contains
! For each level except the finest one ...
!
do ilev = 2, nlev
n_row = psb_cd_get_local_rows(baseprecv(ilev-1)%base_desc)
n_col = psb_cd_get_local_cols(baseprecv(ilev-1)%base_desc)
nc2l = psb_cd_get_local_cols(baseprecv(ilev)%base_desc)
nr2l = psb_cd_get_local_rows(baseprecv(ilev)%base_desc)
nc2l = psb_cd_get_local_cols(precv(ilev)%base_desc)
nr2l = psb_cd_get_local_rows(precv(ilev)%base_desc)
allocate(mlprec_wrk(ilev)%x2l(nc2l),mlprec_wrk(ilev)%y2l(nc2l),&
& stat=info)
if (info /= 0) then
info=4025
call psb_errpush(info,name,i_err=(/2*(nc2l+max(n_row,n_col)),0,0,0,0/),&
call psb_errpush(info,name,i_err=(/2*nc2l,0,0,0,0/),&
& a_err='real(psb_dpk_)')
goto 9999
end if
ismth = baseprecv(ilev)%iprcparm(mld_aggr_kind_)
icm = baseprecv(ilev)%iprcparm(mld_coarse_mat_)
! Apply prolongator transpose, i.e. restriction
call psb_forward_map(done,mlprec_wrk(ilev-1)%x2l,&
& dzero,mlprec_wrk(ilev)%x2l,&
& baseprecv(ilev)%map_desc,info,work=work)
& precv(ilev)%map_desc,info,work=work)
if (info /=0) then
call psb_errpush(4001,name,a_err='Error during restriction')
goto 9999
end if
!
! Apply the base preconditioner
!
call mld_baseprec_aply(done,baseprecv(ilev),&
call mld_baseprec_aply(done,precv(ilev)%prec,&
& mlprec_wrk(ilev)%x2l,dzero,mlprec_wrk(ilev)%y2l,&
& baseprecv(ilev)%base_desc, trans,work,info)
& precv(ilev)%base_desc, trans,work,info)
enddo
@ -475,19 +444,15 @@ contains
!
do ilev =nlev,2,-1
n_row = psb_cd_get_local_rows(baseprecv(ilev-1)%base_desc)
n_col = psb_cd_get_local_cols(baseprecv(ilev-1)%base_desc)
nc2l = psb_cd_get_local_cols(baseprecv(ilev)%base_desc)
nr2l = psb_cd_get_local_rows(baseprecv(ilev)%base_desc)
ismth = baseprecv(ilev)%iprcparm(mld_aggr_kind_)
icm = baseprecv(ilev)%iprcparm(mld_coarse_mat_)
nc2l = psb_cd_get_local_cols(precv(ilev)%base_desc)
nr2l = psb_cd_get_local_rows(precv(ilev)%base_desc)
!
! Apply prolongator
!
call psb_backward_map(done,mlprec_wrk(ilev)%y2l,&
& done,mlprec_wrk(ilev-1)%y2l,&
& baseprecv(ilev)%map_desc,info,work=work)
& precv(ilev)%map_desc,info,work=work)
if (info /=0) then
call psb_errpush(4001,name,a_err='Error during prolongation')
@ -500,7 +465,7 @@ contains
!
! Compute the output vector Y
!
call psb_geaxpby(alpha,mlprec_wrk(1)%y2l,done,y,baseprecv(1)%base_desc,info)
call psb_geaxpby(alpha,mlprec_wrk(1)%y2l,done,y,precv(1)%base_desc,info)
if (info /= 0) then
call psb_errpush(4001,name,a_err='Error on final update')
goto 9999
@ -534,7 +499,7 @@ contains
! Y = beta*Y + alpha*op(M^(-1))*X,
! where
! - M is a hybrid multilevel domain decomposition (Schwarz) preconditioner
! associated to a certain matrix A and stored in the array baseprecv,
! associated to a certain matrix A and stored in the array precv,
! - op(M^(-1)) is M^(-1) or its transpose, according to the value of trans,
! - X and Y are vectors,
! - alpha and beta are scalars.
@ -546,9 +511,9 @@ contains
! level where we might have a replicated index space) and each process takes care
! of one submatrix.
!
! The multilevel preconditioner M is regarded as an array of 'base preconditioners',
! The multilevel preconditioner M is regarded as an array of 'one-level preconditioners',
! each representing the part of the preconditioner associated to a certain level.
! For each level ilev, the base preconditioner K(ilev) is stored in baseprecv(ilev)
! For each level ilev, the base preconditioner K(ilev) is stored in precv(ilev)
! and is associated to a matrix A(ilev), obtained by 'tranferring' the original
! matrix A (i.e. the matrix to be preconditioned) to the level ilev, through smoothed
! aggregation.
@ -604,13 +569,13 @@ contains
! 6. Yext = beta*Yext + alpha*Y(1)
!
!
subroutine mlt_pre_ml_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info)
subroutine mlt_pre_ml_aply(alpha,precv,x,beta,y,desc_data,trans,work,info)
implicit none
! Arguments
type(psb_desc_type),intent(in) :: desc_data
type(mld_dbaseprc_type), intent(in) :: baseprecv(:)
type(mld_d_onelev_prec_type), intent(in) :: precv(:)
real(psb_dpk_),intent(in) :: alpha,beta
real(psb_dpk_),intent(in) :: x(:)
real(psb_dpk_),intent(inout) :: y(:)
@ -619,10 +584,9 @@ contains
integer, intent(out) :: info
! Local variables
integer :: n_row,n_col
integer :: ictxt,np,me,i, nr2l,nc2l,err_act
integer :: debug_level, debug_unit
integer :: ismth, nlev, ilev, icm
integer :: nlev, ilev
character(len=20) :: name
type psb_mlprec_wrk_type
@ -641,9 +605,9 @@ contains
if (debug_level >= psb_debug_inner_) &
& write(debug_unit,*) me,' ',trim(name),&
& ' Entry ', size(baseprecv)
& ' Entry ', size(precv)
nlev = size(baseprecv)
nlev = size(precv)
allocate(mlprec_wrk(nlev),stat=info)
if (info /= 0) then
call psb_errpush(4010,name,a_err='Allocate')
@ -655,8 +619,7 @@ contains
!
! Copy the input vector X
!
n_col = psb_cd_get_local_cols(desc_data)
nc2l = psb_cd_get_local_cols(baseprecv(1)%base_desc)
nc2l = psb_cd_get_local_cols(precv(1)%base_desc)
allocate(mlprec_wrk(1)%x2l(nc2l),mlprec_wrk(1)%y2l(nc2l), &
& mlprec_wrk(1)%tx(nc2l), stat=info)
@ -673,8 +636,8 @@ contains
!
! Apply the base preconditioner at the finest level
!
call mld_baseprec_aply(done,baseprecv(1),mlprec_wrk(1)%x2l,&
& dzero,mlprec_wrk(1)%y2l,baseprecv(1)%base_desc,&
call mld_baseprec_aply(done,precv(1)%prec,mlprec_wrk(1)%x2l,&
& dzero,mlprec_wrk(1)%y2l,precv(1)%base_desc,&
& trans,work,info)
if (info /=0) then
call psb_errpush(4010,name,a_err=' baseprec_aply')
@ -688,8 +651,8 @@ contains
!
mlprec_wrk(1)%tx = mlprec_wrk(1)%x2l
call psb_spmm(-done,baseprecv(1)%base_a,mlprec_wrk(1)%y2l,&
& done,mlprec_wrk(1)%tx,baseprecv(1)%base_desc,info,&
call psb_spmm(-done,precv(1)%base_a,mlprec_wrk(1)%y2l,&
& done,mlprec_wrk(1)%tx,precv(1)%base_desc,info,&
& work=work,trans=trans)
if (info /=0) then
call psb_errpush(4001,name,a_err=' fine level residual')
@ -703,12 +666,8 @@ contains
!
do ilev = 2, nlev
n_row = psb_cd_get_local_rows(baseprecv(ilev-1)%base_desc)
n_col = psb_cd_get_local_cols(baseprecv(ilev-1)%base_desc)
nc2l = psb_cd_get_local_cols(baseprecv(ilev)%base_desc)
nr2l = psb_cd_get_local_rows(baseprecv(ilev)%base_desc)
ismth = baseprecv(ilev)%iprcparm(mld_aggr_kind_)
icm = baseprecv(ilev)%iprcparm(mld_coarse_mat_)
nc2l = psb_cd_get_local_cols(precv(ilev)%base_desc)
nr2l = psb_cd_get_local_rows(precv(ilev)%base_desc)
allocate(mlprec_wrk(ilev)%tx(nc2l),mlprec_wrk(ilev)%y2l(nc2l),&
& mlprec_wrk(ilev)%x2l(nc2l), stat=info)
@ -722,7 +681,7 @@ contains
! Apply prolongator transpose, i.e. restriction
call psb_forward_map(done,mlprec_wrk(ilev-1)%tx,&
& dzero,mlprec_wrk(ilev)%x2l,&
& baseprecv(ilev)%map_desc,info,work=work)
& precv(ilev)%map_desc,info,work=work)
if (info /=0) then
call psb_errpush(4001,name,a_err='Error during restriction')
@ -732,17 +691,17 @@ contains
!
! Apply the base preconditioner
!
call mld_baseprec_aply(done,baseprecv(ilev),mlprec_wrk(ilev)%x2l,&
& dzero,mlprec_wrk(ilev)%y2l,baseprecv(ilev)%base_desc,trans,work,info)
call mld_baseprec_aply(done,precv(ilev)%prec,mlprec_wrk(ilev)%x2l,&
& dzero,mlprec_wrk(ilev)%y2l,precv(ilev)%base_desc,trans,work,info)
!
! Compute the residual (at all levels but the coarsest one)
!
if (ilev < nlev) then
mlprec_wrk(ilev)%tx = mlprec_wrk(ilev)%x2l
if (info == 0) call psb_spmm(-done,baseprecv(ilev)%base_a,&
if (info == 0) call psb_spmm(-done,precv(ilev)%base_a,&
& mlprec_wrk(ilev)%y2l,done,mlprec_wrk(ilev)%tx,&
& baseprecv(ilev)%base_desc,info,work=work,trans=trans)
& precv(ilev)%base_desc,info,work=work,trans=trans)
endif
if (info /=0) then
call psb_errpush(4001,name,a_err='Error on up sweep residual')
@ -756,16 +715,12 @@ contains
! For each level but the coarsest one ...
!
do ilev = nlev-1, 1, -1
ismth = baseprecv(ilev+1)%iprcparm(mld_aggr_kind_)
n_row = psb_cd_get_local_rows(baseprecv(ilev)%base_desc)
!
! Apply prolongator
!
call psb_backward_map(done,mlprec_wrk(ilev+1)%y2l,&
& done,mlprec_wrk(ilev)%y2l,&
& baseprecv(ilev+1)%map_desc,info,work=work)
& precv(ilev+1)%map_desc,info,work=work)
if (info /=0) then
call psb_errpush(4001,name,a_err='Error during prolongation')
@ -779,7 +734,7 @@ contains
! Compute the output vector Y
!
call psb_geaxpby(alpha,mlprec_wrk(1)%y2l,beta,y,&
& baseprecv(1)%base_desc,info)
& precv(1)%base_desc,info)
if (info /=0) then
call psb_errpush(4001,name,a_err='Error on final update')
goto 9999
@ -812,7 +767,7 @@ contains
! Y = beta*Y + alpha*op(M^(-1))*X,
! where
! - M is a hybrid multilevel domain decomposition (Schwarz) preconditioner
! associated to a certain matrix A and stored in the array baseprecv,
! associated to a certain matrix A and stored in the array precv,
! - op(M^(-1)) is M^(-1) or its transpose, according to the value of trans,
! - X and Y are vectors,
! - alpha and beta are scalars.
@ -824,9 +779,9 @@ contains
! level where we might have a replicated index space) and each process takes care
! of one submatrix.
!
! The multilevel preconditioner M is regarded as an array of 'base preconditioners',
! The multilevel preconditioner M is regarded as an array of 'one-level preconditioners',
! each representing the part of the preconditioner associated to a certain level.
! For each level ilev, the base preconditioner K(ilev) is stored in baseprecv(ilev)
! For each level ilev, the base preconditioner K(ilev) is stored in precv(ilev)
! and is associated to a matrix A(ilev), obtained by 'tranferring' the original
! matrix A (i.e. the matrix to be preconditioned) to the level ilev, through smoothed
! aggregation.
@ -873,13 +828,13 @@ contains
! 5. Yext = beta*Yext + alpha*Y(1)
!
!
subroutine mlt_post_ml_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info)
subroutine mlt_post_ml_aply(alpha,precv,x,beta,y,desc_data,trans,work,info)
implicit none
! Arguments
type(psb_desc_type),intent(in) :: desc_data
type(mld_dbaseprc_type), intent(in) :: baseprecv(:)
type(mld_d_onelev_prec_type), intent(in) :: precv(:)
real(psb_dpk_),intent(in) :: alpha,beta
real(psb_dpk_),intent(in) :: x(:)
real(psb_dpk_),intent(inout) :: y(:)
@ -888,10 +843,9 @@ contains
integer, intent(out) :: info
! Local variables
integer :: n_row,n_col
integer :: ictxt,np,me,i, nr2l,nc2l,err_act
integer :: debug_level, debug_unit
integer :: ismth, nlev, ilev, icm
integer :: nlev, ilev
character(len=20) :: name
type psb_mlprec_wrk_type
@ -910,9 +864,9 @@ contains
if (debug_level >= psb_debug_inner_) &
& write(debug_unit,*) me,' ',trim(name),&
& ' Entry ', size(baseprecv)
& ' Entry ', size(precv)
nlev = size(baseprecv)
nlev = size(precv)
allocate(mlprec_wrk(nlev),stat=info)
if (info /= 0) then
call psb_errpush(4010,name,a_err='Allocate')
@ -928,16 +882,21 @@ contains
& write(debug_unit,*) me,' ',trim(name),&
& ' desc_data status',allocated(desc_data%matrix_data)
n_col = psb_cd_get_local_cols(desc_data)
nc2l = psb_cd_get_local_cols(baseprecv(1)%base_desc)
nc2l = psb_cd_get_local_cols(precv(1)%base_desc)
allocate(mlprec_wrk(1)%x2l(nc2l),mlprec_wrk(1)%y2l(nc2l), &
& mlprec_wrk(1)%tx(nc2l), stat=info)
if (info /= 0) then
info=4025
call psb_errpush(info,name,i_err=(/4*nc2l,0,0,0,0/),&
& a_err='real(psb_dpk_)')
goto 9999
end if
call psb_geaxpby(done,x,dzero,mlprec_wrk(1)%tx,&
& baseprecv(1)%base_desc,info)
& precv(1)%base_desc,info)
call psb_geaxpby(done,x,dzero,mlprec_wrk(1)%x2l,&
& baseprecv(1)%base_desc,info)
& precv(1)%base_desc,info)
!
! STEP 2
@ -946,18 +905,13 @@ contains
!
do ilev=2, nlev
n_row = psb_cd_get_local_rows(baseprecv(ilev-1)%base_desc)
n_col = psb_cd_get_local_cols(baseprecv(ilev-1)%base_desc)
nc2l = psb_cd_get_local_cols(baseprecv(ilev)%base_desc)
nr2l = psb_cd_get_local_rows(baseprecv(ilev)%base_desc)
ismth = baseprecv(ilev)%iprcparm(mld_aggr_kind_)
icm = baseprecv(ilev)%iprcparm(mld_coarse_mat_)
nc2l = psb_cd_get_local_cols(precv(ilev)%base_desc)
nr2l = psb_cd_get_local_rows(precv(ilev)%base_desc)
if (debug_level >= psb_debug_inner_) &
& write(debug_unit,*) me,' ',trim(name), &
& ' starting up sweep ',&
& ilev,allocated(baseprecv(ilev)%iprcparm),n_row,n_col,&
& nc2l, nr2l,ismth
& ilev,allocated(precv(ilev)%iprcparm),nc2l, nr2l
allocate(mlprec_wrk(ilev)%tx(nc2l),mlprec_wrk(ilev)%y2l(nc2l),&
& mlprec_wrk(ilev)%x2l(nc2l), stat=info)
@ -972,7 +926,7 @@ contains
! Apply prolongator transpose, i.e. restriction
call psb_forward_map(done,mlprec_wrk(ilev-1)%x2l,&
& dzero,mlprec_wrk(ilev)%x2l,&
& baseprecv(ilev)%map_desc,info,work=work)
& precv(ilev)%map_desc,info,work=work)
if (info /=0) then
call psb_errpush(4001,name,a_err='Error during restriction')
@ -983,7 +937,7 @@ contains
! update x2l
!
call psb_geaxpby(done,mlprec_wrk(ilev)%x2l,dzero,mlprec_wrk(ilev)%tx,&
& baseprecv(ilev)%base_desc,info)
& precv(ilev)%base_desc,info)
if (info /= 0) then
call psb_errpush(4001,name,a_err='Error in update')
goto 9999
@ -1000,9 +954,8 @@ contains
!
! Apply the base preconditioner at the coarsest level
!
call mld_baseprec_aply(done,baseprecv(nlev),mlprec_wrk(nlev)%x2l, &
& dzero, mlprec_wrk(nlev)%y2l,baseprecv(nlev)%base_desc,trans,work,info)
call mld_baseprec_aply(done,precv(nlev)%prec,mlprec_wrk(nlev)%x2l, &
& dzero, mlprec_wrk(nlev)%y2l,precv(nlev)%base_desc,trans,work,info)
if (info /=0) then
call psb_errpush(4010,name,a_err='baseprec_aply')
goto 9999
@ -1022,15 +975,12 @@ contains
& write(debug_unit,*) me,' ',trim(name),&
& ' starting down sweep',ilev
ismth = baseprecv(ilev+1)%iprcparm(mld_aggr_kind_)
n_row = psb_cd_get_local_rows(baseprecv(ilev)%base_desc)
!
! Apply prolongator
!
call psb_backward_map(done,mlprec_wrk(ilev+1)%y2l,&
& dzero,mlprec_wrk(ilev)%y2l,&
& baseprecv(ilev+1)%map_desc,info,work=work)
& precv(ilev+1)%map_desc,info,work=work)
if (info /=0) then
call psb_errpush(4001,name,a_err='Error during prolongation')
@ -1040,15 +990,16 @@ contains
!
! Compute the residual
!
call psb_spmm(-done,baseprecv(ilev)%base_a,mlprec_wrk(ilev)%y2l,&
& done,mlprec_wrk(ilev)%tx,baseprecv(ilev)%base_desc,info,&
call psb_spmm(-done,precv(ilev)%base_a,mlprec_wrk(ilev)%y2l,&
& done,mlprec_wrk(ilev)%tx,precv(ilev)%base_desc,info,&
& work=work,trans=trans)
!
! Apply the base preconditioner
!
if (info == 0) call mld_baseprec_aply(done,baseprecv(ilev),mlprec_wrk(ilev)%tx,&
& done,mlprec_wrk(ilev)%y2l,baseprecv(ilev)%base_desc,trans,work,info)
if (info == 0) call mld_baseprec_aply(done,precv(ilev)%prec,&
& mlprec_wrk(ilev)%tx,done,mlprec_wrk(ilev)%y2l,precv(ilev)%base_desc,&
& trans,work,info)
if (info /=0) then
call psb_errpush(4001,name,a_err=' spmm/baseprec_aply')
goto 9999
@ -1064,7 +1015,7 @@ contains
!
! Compute the output vector Y
!
call psb_geaxpby(alpha,mlprec_wrk(1)%y2l,beta,y,baseprecv(1)%base_desc,info)
call psb_geaxpby(alpha,mlprec_wrk(1)%y2l,beta,y,precv(1)%base_desc,info)
if (info /=0) then
call psb_errpush(4001,name,a_err=' Final update')
@ -1101,7 +1052,7 @@ contains
! where
! - M is a symmetrized hybrid multilevel domain decomposition (Schwarz)
! preconditioner associated to a certain matrix A and stored in the array
! baseprecv,
! precv,
! - op(M^(-1)) is M^(-1) or its transpose, according to the value of trans,
! - X and Y are vectors,
! - alpha and beta are scalars.
@ -1114,9 +1065,9 @@ contains
! level where we might have a replicated index space) and each process takes care
! of one submatrix.
!
! The multilevel preconditioner M is regarded as an array of 'base preconditioners',
! The multilevel preconditioner M is regarded as an array of 'one-level preconditioners',
! each representing the part of the preconditioner associated to a certain level.
! For each level ilev, the base preconditioner K(ilev) is stored in baseprecv(ilev)
! For each level ilev, the base preconditioner K(ilev) is stored in precv(ilev)
! and is associated to a matrix A(ilev), obtained by 'tranferring' the original
! matrix A (i.e. the matrix to be preconditioned) to the level ilev, through smoothed
! aggregation.
@ -1174,13 +1125,13 @@ contains
!
! 6. Yext = beta*Yext + alpha*Y(1)
!
subroutine mlt_twoside_ml_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info)
subroutine mlt_twoside_ml_aply(alpha,precv,x,beta,y,desc_data,trans,work,info)
implicit none
! Arguments
type(psb_desc_type),intent(in) :: desc_data
type(mld_dbaseprc_type), intent(in) :: baseprecv(:)
type(mld_d_onelev_prec_type), intent(in) :: precv(:)
real(psb_dpk_),intent(in) :: alpha,beta
real(psb_dpk_),intent(in) :: x(:)
real(psb_dpk_),intent(inout) :: y(:)
@ -1189,10 +1140,9 @@ contains
integer, intent(out) :: info
! Local variables
integer :: n_row,n_col
integer :: ictxt,np,me,i, nr2l,nc2l,err_act
integer :: debug_level, debug_unit
integer :: ismth, nlev, ilev, icm
integer :: nlev, ilev
character(len=20) :: name
type psb_mlprec_wrk_type
@ -1211,9 +1161,9 @@ contains
if (debug_level >= psb_debug_inner_) &
& write(debug_unit,*) me,' ',trim(name),&
& ' Entry ', size(baseprecv)
& ' Entry ', size(precv)
nlev = size(baseprecv)
nlev = size(precv)
allocate(mlprec_wrk(nlev),stat=info)
if (info /= 0) then
call psb_errpush(4010,name,a_err='Allocate')
@ -1224,8 +1174,7 @@ contains
!
! Copy the input vector X
!
n_col = psb_cd_get_local_cols(desc_data)
nc2l = psb_cd_get_local_cols(baseprecv(1)%base_desc)
nc2l = psb_cd_get_local_cols(precv(1)%base_desc)
allocate(mlprec_wrk(1)%x2l(nc2l),mlprec_wrk(1)%y2l(nc2l), &
& mlprec_wrk(1)%ty(nc2l), mlprec_wrk(1)%tx(nc2l), stat=info)
@ -1238,17 +1187,17 @@ contains
end if
call psb_geaxpby(done,x,dzero,mlprec_wrk(1)%x2l,&
& baseprecv(1)%base_desc,info)
& precv(1)%base_desc,info)
call psb_geaxpby(done,x,dzero,mlprec_wrk(1)%tx,&
& baseprecv(1)%base_desc,info)
& precv(1)%base_desc,info)
!
! STEP 2
!
! Apply the base preconditioner at the finest level
!
call mld_baseprec_aply(done,baseprecv(1),mlprec_wrk(1)%x2l,&
& dzero,mlprec_wrk(1)%y2l,baseprecv(1)%base_desc,&
call mld_baseprec_aply(done,precv(1)%prec,mlprec_wrk(1)%x2l,&
& dzero,mlprec_wrk(1)%y2l,precv(1)%base_desc,&
& trans,work,info)
!
! STEP 3
@ -1256,8 +1205,8 @@ contains
! Compute the residual at the finest level
!
mlprec_wrk(1)%ty = mlprec_wrk(1)%x2l
if (info == 0) call psb_spmm(-done,baseprecv(1)%base_a,mlprec_wrk(1)%y2l,&
& done,mlprec_wrk(1)%ty,baseprecv(1)%base_desc,info,&
if (info == 0) call psb_spmm(-done,precv(1)%base_a,mlprec_wrk(1)%y2l,&
& done,mlprec_wrk(1)%ty,precv(1)%base_desc,info,&
& work=work,trans=trans)
if (info /=0) then
call psb_errpush(4010,name,a_err='Fine level baseprec/residual')
@ -1271,12 +1220,9 @@ contains
!
do ilev = 2, nlev
n_row = psb_cd_get_local_rows(baseprecv(ilev-1)%base_desc)
n_col = psb_cd_get_local_cols(baseprecv(ilev-1)%base_desc)
nc2l = psb_cd_get_local_cols(baseprecv(ilev)%base_desc)
nr2l = psb_cd_get_local_rows(baseprecv(ilev)%base_desc)
ismth = baseprecv(ilev)%iprcparm(mld_aggr_kind_)
icm = baseprecv(ilev)%iprcparm(mld_coarse_mat_)
nc2l = psb_cd_get_local_cols(precv(ilev)%base_desc)
nr2l = psb_cd_get_local_rows(precv(ilev)%base_desc)
allocate(mlprec_wrk(ilev)%tx(nc2l),mlprec_wrk(ilev)%ty(nc2l),&
& mlprec_wrk(ilev)%y2l(nc2l),mlprec_wrk(ilev)%x2l(nc2l), stat=info)
@ -1290,7 +1236,7 @@ contains
! Apply prolongator transpose, i.e. restriction
call psb_forward_map(done,mlprec_wrk(ilev-1)%ty,&
& dzero,mlprec_wrk(ilev)%x2l,&
& baseprecv(ilev)%map_desc,info,work=work)
& precv(ilev)%map_desc,info,work=work)
if (info /=0) then
call psb_errpush(4001,name,a_err='Error during restriction')
@ -1298,21 +1244,21 @@ contains
end if
call psb_geaxpby(done,mlprec_wrk(ilev)%x2l,dzero,mlprec_wrk(ilev)%tx,&
& baseprecv(ilev)%base_desc,info)
& precv(ilev)%base_desc,info)
!
! Apply the base preconditioner
!
if (info == 0) call mld_baseprec_aply(done,baseprecv(ilev),&
if (info == 0) call mld_baseprec_aply(done,precv(ilev)%prec,&
& mlprec_wrk(ilev)%x2l,dzero,mlprec_wrk(ilev)%y2l,&
& baseprecv(ilev)%base_desc,trans,work,info)
& precv(ilev)%base_desc,trans,work,info)
!
! Compute the residual (at all levels but the coarsest one)
!
if(ilev < nlev) then
mlprec_wrk(ilev)%ty = mlprec_wrk(ilev)%x2l
if (info == 0) call psb_spmm(-done,baseprecv(ilev)%base_a,&
if (info == 0) call psb_spmm(-done,precv(ilev)%base_a,&
& mlprec_wrk(ilev)%y2l,done,mlprec_wrk(ilev)%ty,&
& baseprecv(ilev)%base_desc,info,work=work,trans=trans)
& precv(ilev)%base_desc,info,work=work,trans=trans)
endif
if (info /=0) then
call psb_errpush(4001,name,a_err='baseprec_aply/residual')
@ -1328,15 +1274,12 @@ contains
!
do ilev=nlev-1, 1, -1
ismth = baseprecv(ilev+1)%iprcparm(mld_aggr_kind_)
n_row = psb_cd_get_local_rows(baseprecv(ilev)%base_desc)
!
! Apply prolongator
!
call psb_backward_map(done,mlprec_wrk(ilev+1)%y2l,&
& done,mlprec_wrk(ilev)%y2l,&
& baseprecv(ilev+1)%map_desc,info,work=work)
& precv(ilev+1)%map_desc,info,work=work)
if (info /=0 ) then
call psb_errpush(4001,name,a_err='Error during restriction')
@ -1346,14 +1289,14 @@ contains
!
! Compute the residual
!
call psb_spmm(-done,baseprecv(ilev)%base_a,mlprec_wrk(ilev)%y2l,&
& done,mlprec_wrk(ilev)%tx,baseprecv(ilev)%base_desc,info,&
call psb_spmm(-done,precv(ilev)%base_a,mlprec_wrk(ilev)%y2l,&
& done,mlprec_wrk(ilev)%tx,precv(ilev)%base_desc,info,&
& work=work,trans=trans)
!
! Apply the base preconditioner
!
if (info == 0) call mld_baseprec_aply(done,baseprecv(ilev),mlprec_wrk(ilev)%tx,&
& done,mlprec_wrk(ilev)%y2l,baseprecv(ilev)%base_desc, trans, work,info)
if (info == 0) call mld_baseprec_aply(done,precv(ilev)%prec,mlprec_wrk(ilev)%tx,&
& done,mlprec_wrk(ilev)%y2l,precv(ilev)%base_desc, trans, work,info)
if (info /= 0) then
call psb_errpush(4001,name,a_err='Error: residual/baseprec_aply')
goto 9999
@ -1366,7 +1309,7 @@ contains
! Compute the output vector Y
!
call psb_geaxpby(alpha,mlprec_wrk(1)%y2l,beta,y,&
& baseprecv(1)%base_desc,info)
& precv(1)%base_desc,info)
if (info /= 0) then
call psb_errpush(4001,name,a_err='Error final update')

47
mlprec/mld_dmlprec_bld.f90
Unescape Escape View File

@ -41,10 +41,11 @@
! Subroutine: mld_dmlprec_bld
! Version: real
!
! This routine builds the base preconditioner corresponding to the current
! This routine builds the preconditioner corresponding to the current
! level of the multilevel preconditioner. The routine first builds the
! (coarse) matrix associated to the current level from the (fine) matrix
! associated to the previous level, then builds the related base preconditioner.
! Note that this routine is only ever called on levels >= 2.
!
!
! Arguments:
@ -53,9 +54,9 @@
! matrix to be preconditioned.
! desc_a - type(psb_desc_type), input.
! The communication descriptor of a.
! p - type(mld_dbaseprc_type), input/output.
! The base preconditioner data structure containing the local
! part of the base preconditioner to be built.
! p - type(mld_d_onelev_type), input/output.
! The preconditioner data structure containing the local
! part of the one-level preconditioner to be built.
! info - integer, output.
! Error code.
!
@ -69,7 +70,7 @@ subroutine mld_dmlprec_bld(a,desc_a,p,info)
! Arguments
type(psb_dspmat_type), intent(in), target :: a
type(psb_desc_type), intent(in), target :: desc_a
type(mld_dbaseprc_type), intent(inout),target :: p
type(mld_d_onelev_prec_type), intent(inout),target :: p
integer, intent(out) :: info
! Local variables
@ -106,16 +107,16 @@ subroutine mld_dmlprec_bld(a,desc_a,p,info)
& mld_max_norm_,is_legal_ml_aggr_eig)
select case(p%iprcparm(mld_sub_solve_))
select case(p%prec%iprcparm(mld_sub_solve_))
case(mld_ilu_n_,mld_milu_n_)
call mld_check_def(p%iprcparm(mld_sub_fillin_),'Level',0,is_legal_ml_lev)
call mld_check_def(p%prec%iprcparm(mld_sub_fillin_),'Level',0,is_legal_ml_lev)
case(mld_ilu_t_)
call mld_check_def(p%rprcparm(mld_sub_iluthrs_),'Eps',dzero,is_legal_fact_thrs)
call mld_check_def(p%prec%rprcparm(mld_sub_iluthrs_),'Eps',dzero,is_legal_fact_thrs)
end select
call mld_check_def(p%prec%iprcparm(mld_smoother_sweeps_),'Jacobi sweeps',&
& 1,is_legal_jac_sweeps)
call mld_check_def(p%rprcparm(mld_aggr_omega_val_),'Omega',dzero,is_legal_omega)
call mld_check_def(p%rprcparm(mld_aggr_thresh_),'Aggr_Thresh',dzero,is_legal_aggr_thrs)
call mld_check_def(p%iprcparm(mld_smoother_sweeps_),'Jacobi sweeps',&
& 1,is_legal_jac_sweeps)
!
! Build a mapping between the row indices of the fine-level matrix
@ -135,7 +136,7 @@ subroutine mld_dmlprec_bld(a,desc_a,p,info)
! the mapping defined by mld_aggrmap_bld and applying the aggregation
! algorithm specified by p%iprcparm(mld_aggr_kind_)
!
call mld_aggrmat_asb(a,desc_a,ac,desc_ac,p,info)
call mld_aggrmat_asb(a,desc_a,p,info)
if(info /= 0) then
call psb_errpush(4010,name,a_err='mld_aggrmat_asb')
goto 9999
@ -144,32 +145,16 @@ subroutine mld_dmlprec_bld(a,desc_a,p,info)
!
! Build the 'base preconditioner' corresponding to the coarse level
!
call mld_baseprc_bld(ac,desc_ac,p,info)
call mld_baseprc_bld(p%ac,p%desc_ac,p%prec,info)
if (info /= 0) then
call psb_errpush(4010,name,a_err='mld_baseprc_bld')
goto 9999
end if
!
! We have used a separate ac because
! 1. we want to reuse the same routines mld_ilu_bld, etc.,
! 2. we do NOT want to pass an argument twice to them (p%av(mld_ac_) and p),
! as this would violate the Fortran standard.
! Hence a separate AC and a TRANSFER function at the end.
! Fix the base_a and base_desc pointers for handling of residuals.
! This is correct because this routine is only called at levels >=2.
!
call psb_sp_transfer(ac,p%av(mld_ac_),info)
p%base_a => p%av(mld_ac_)
if (info==0) call psb_cdtransfer(desc_ac,p%desc_ac,info)
p%map_desc = psb_inter_desc(psb_map_aggr_,desc_a,&
& p%desc_ac,p%av(mld_sm_pr_t_),p%av(mld_sm_pr_))
! The two matrices from p%av() have been copied, may free them.
if (info == 0) call psb_sp_free(p%av(mld_sm_pr_t_),info)
if (info == 0) call psb_sp_free(p%av(mld_sm_pr_),info)
if (info /= 0) then
call psb_errpush(4010,name,a_err='psb_cdtransfer')
goto 9999
end if
p%base_a => p%ac
p%base_desc => p%desc_ac
call psb_erractionrestore(err_act)

14
mlprec/mld_dprec_aply.f90
Unescape Escape View File

@ -120,25 +120,25 @@ subroutine mld_dprec_aply(prec,x,y,desc_data,info,trans,work)
end if
if (.not.(allocated(prec%baseprecv))) then
if (.not.(allocated(prec%precv))) then
!! Error 1: should call mld_dprecbld
info=3112
call psb_errpush(info,name)
goto 9999
end if
if (size(prec%baseprecv) >1) then
call mld_mlprec_aply(done,prec%baseprecv,x,dzero,y,desc_data,trans_,work_,info)
if (size(prec%precv) >1) then
call mld_mlprec_aply(done,prec%precv,x,dzero,y,desc_data,trans_,work_,info)
if(info /= 0) then
call psb_errpush(4010,name,a_err='mld_dmlprec_aply')
goto 9999
end if
else if (size(prec%baseprecv) == 1) then
call mld_baseprec_aply(done,prec%baseprecv(1),x,dzero,y,desc_data,trans_, work_,info)
else if (size(prec%precv) == 1) then
call mld_baseprec_aply(done,prec%precv(1)%prec,x,dzero,y,desc_data,trans_, work_,info)
else
info = 4013
call psb_errpush(info,name,a_err='Invalid size of baseprecv',&
& i_Err=(/size(prec%baseprecv),0,0,0,0/))
call psb_errpush(info,name,a_err='Invalid size of precv',&
& i_Err=(/size(prec%precv),0,0,0,0/))
goto 9999
endif

75
mlprec/mld_dprecbld.f90
Unescape Escape View File

@ -119,7 +119,7 @@ subroutine mld_dprecbld(a,desc_a,p,info)
!!$ endif
upd_ = 'F'
if (.not.allocated(p%baseprecv)) then
if (.not.allocated(p%precv)) then
!! Error: should have called mld_dprecinit
info=3111
call psb_errpush(info,name)
@ -129,11 +129,11 @@ subroutine mld_dprecbld(a,desc_a,p,info)
!
! Check to ensure all procs have the same
!
iszv = size(p%baseprecv)
iszv = size(p%precv)
call psb_bcast(ictxt,iszv)
if (iszv /= size(p%baseprecv)) then
if (iszv /= size(p%precv)) then
info=4001
call psb_errpush(info,name,a_err='Inconsistent size of baseprecv')
call psb_errpush(info,name,a_err='Inconsistent size of precv')
goto 9999
end if
@ -142,18 +142,20 @@ subroutine mld_dprecbld(a,desc_a,p,info)
! Check on the iprcparm contents: they should be the same
! on all processes.
!
if (me == psb_root_) ipv(:) = p%baseprecv(1)%iprcparm(:)
if (me == psb_root_) ipv(:) = p%precv(1)%iprcparm(:)
call psb_bcast(ictxt,ipv)
if (any(ipv(:) /= p%baseprecv(1)%iprcparm(:) )) then
if (any(ipv(:) /= p%precv(1)%iprcparm(:) )) then
write(debug_unit,*) me,name,&
&': Inconsistent arguments among processes, forcing a default'
p%baseprecv(1)%iprcparm(:) = ipv(:)
p%precv(1)%iprcparm(:) = ipv(:)
end if
!
! Allocate and build the fine level preconditioner
! Finest level first; remember to fix base_a and base_desc
!
call init_baseprc_av(p%baseprecv(1),info)
if (info == 0) call mld_baseprc_bld(a,desc_a,p%baseprecv(1),info,upd_)
call init_baseprc_av(p%precv(1)%prec,info)
if (info == 0) call mld_baseprc_bld(a,desc_a,p%precv(1)%prec,info,upd_)
p%precv(1)%base_a => a
p%precv(1)%base_desc => desc_a
if (info /= 0) then
call psb_errpush(4001,name,a_err='Base level precbuild.')
@ -178,69 +180,69 @@ subroutine mld_dprecbld(a,desc_a,p,info)
! Check on the iprcparm contents: they should be the same
! on all processes.
!
if (me == psb_root_) ipv(:) = p%baseprecv(i)%iprcparm(:)
if (me == psb_root_) ipv(:) = p%precv(i)%iprcparm(:)
call psb_bcast(ictxt,ipv)
if (any(ipv(:) /= p%baseprecv(i)%iprcparm(:) )) then
if (any(ipv(:) /= p%precv(i)%iprcparm(:) )) then
write(debug_unit,*) me,name,&
&': Inconsistent arguments among processes, resetting.'
p%baseprecv(i)%iprcparm(:) = ipv(:)
p%precv(i)%iprcparm(:) = ipv(:)
end if
!
! Allocate the av component of the preconditioner data type
! at level i
! Sanity checks on the parameters
!
if (i<iszv) then
!
! A replicated matrix only makes sense at the coarsest level
!
call mld_check_def(p%baseprecv(i)%iprcparm(mld_coarse_mat_),'Coarse matrix',&
call mld_check_def(p%precv(i)%iprcparm(mld_coarse_mat_),'Coarse matrix',&
& mld_distr_mat_,is_distr_ml_coarse_mat)
else if (i == iszv) then
!
! At the coarsest level, check mld_coarse_solve_
!
val = p%baseprecv(i)%iprcparm(mld_coarse_solve_)
val = p%precv(i)%iprcparm(mld_coarse_solve_)
select case (val)
case(mld_umf_, mld_slu_)
if ((p%baseprecv(i)%iprcparm(mld_coarse_mat_) /= mld_repl_mat_).or.&
& (p%baseprecv(i)%iprcparm(mld_sub_solve_) /= val)) then
if ((p%precv(i)%iprcparm(mld_coarse_mat_) /= mld_repl_mat_).or.&
& (p%precv(i)%prec%iprcparm(mld_sub_solve_) /= val)) then
if (me == 0) write(debug_unit,*)&
& 'Warning: inconsistent coarse level specification.'
if (me == 0) write(debug_unit,*)&
& ' Resetting according to the value specified for mld_coarse_solve_.'
p%baseprecv(i)%iprcparm(mld_coarse_mat_) = mld_repl_mat_
p%baseprecv(i)%iprcparm(mld_sub_solve_) = val
p%baseprecv(i)%iprcparm(mld_smoother_type_) = mld_bjac_
p%precv(i)%iprcparm(mld_coarse_mat_) = mld_repl_mat_
p%precv(i)%prec%iprcparm(mld_sub_solve_) = val
p%precv(i)%prec%iprcparm(mld_smoother_type_) = mld_bjac_
end if
case(mld_sludist_)
if ((p%baseprecv(i)%iprcparm(mld_coarse_mat_) /= mld_distr_mat_).or.&
& (p%baseprecv(i)%iprcparm(mld_sub_solve_) /= val)) then
if ((p%precv(i)%iprcparm(mld_coarse_mat_) /= mld_distr_mat_).or.&
& (p%precv(i)%prec%iprcparm(mld_sub_solve_) /= val)) then
if (me == 0) write(debug_unit,*)&
& 'Warning: inconsistent coarse level specification.'
if (me == 0) write(debug_unit,*)&
& ' Resetting according to the value specified for mld_coarse_solve_.'
p%baseprecv(i)%iprcparm(mld_coarse_mat_) = mld_distr_mat_
p%baseprecv(i)%iprcparm(mld_sub_solve_) = val
p%baseprecv(i)%iprcparm(mld_smoother_type_) = mld_bjac_
p%baseprecv(i)%iprcparm(mld_smoother_sweeps_) = 1
p%precv(i)%iprcparm(mld_coarse_mat_) = mld_distr_mat_
p%precv(i)%prec%iprcparm(mld_sub_solve_) = val
p%precv(i)%prec%iprcparm(mld_smoother_type_) = mld_bjac_
p%precv(i)%prec%iprcparm(mld_smoother_sweeps_) = 1
end if
end select
end if
call init_baseprc_av(p%baseprecv(i),info)
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'Calling mlprcbld at level ',i
!
! Build the base preconditioner corresponding to level i
! Allocate and build the preconditioner at level i.
! baseprec_bld is called inside mlprec_bld.
!
if (info == 0) call mld_mlprec_bld(p%baseprecv(i-1)%base_a,&
& p%baseprecv(i-1)%base_desc, p%baseprecv(i),info)
call init_baseprc_av(p%precv(i)%prec,info)
if (info == 0) call mld_mlprec_bld(p%precv(i-1)%base_a,&
& p%precv(i-1)%base_desc, p%precv(i),info)
if (info /= 0) then
call psb_errpush(4001,name,a_err='Init & build upper level preconditioner')
goto 9999
@ -250,11 +252,14 @@ subroutine mld_dprecbld(a,desc_a,p,info)
& write(debug_unit,*) me,' ',trim(name),&
& 'Return from ',i,' call to mlprcbld ',info
end do
!
! Check on sizes from level 2 onwards
!
if (me==0) then
k = iszv+1
do i=iszv,3,-1
if (all(p%baseprecv(i)%nlaggr == p%baseprecv(i-1)%nlaggr)) then
if (all(p%precv(i)%nlaggr == p%precv(i-1)%nlaggr)) then
k=i-1
end if
end do

8
mlprec/mld_dprecfree.f90
Unescape Escape View File

@ -74,11 +74,11 @@ subroutine mld_dprecfree(p,info)
me=-1
if (allocated(p%baseprecv)) then
do i=1,size(p%baseprecv)
call mld_base_precfree(p%baseprecv(i),info)
if (allocated(p%precv)) then
do i=1,size(p%precv)
call mld_onelev_precfree(p%precv(i),info)
end do
deallocate(p%baseprecv)
deallocate(p%precv)
end if
call psb_erractionrestore(err_act)
return

242
mlprec/mld_dprecinit.F90
Unescape Escape View File

@ -104,7 +104,7 @@ subroutine mld_dprecinit(p,ptype,info,nlev)
character(len=*), parameter :: name='mld_precinit'
info = 0
if (allocated(p%baseprecv)) then
if (allocated(p%precv)) then
call mld_precfree(p,info)
if (info /=0) then
! Do we want to do something?
@ -115,68 +115,88 @@ subroutine mld_dprecinit(p,ptype,info,nlev)
case ('NOPREC')
nlev_ = 1
ilev_ = 1
allocate(p%baseprecv(nlev_),stat=info)
if (info == 0) call psb_realloc(mld_ifpsz_,p%baseprecv(ilev_)%iprcparm,info)
if (info == 0) call psb_realloc(mld_rfpsz_,p%baseprecv(ilev_)%rprcparm,info)
allocate(p%precv(nlev_),stat=info)
if (info == 0) call psb_realloc(mld_ifpsz_,p%precv(ilev_)%iprcparm,info)
if (info == 0) call psb_realloc(mld_rfpsz_,p%precv(ilev_)%rprcparm,info)
if (info == 0) call psb_realloc(mld_ifpsz_,p%precv(ilev_)%prec%iprcparm,info)
if (info == 0) call psb_realloc(mld_rfpsz_,p%precv(ilev_)%prec%rprcparm,info)
if (info /= 0) return
p%baseprecv(ilev_)%iprcparm(:) = 0
p%baseprecv(ilev_)%iprcparm(mld_smoother_type_) = mld_noprec_
p%baseprecv(ilev_)%iprcparm(mld_sub_solve_) = mld_f_none_
p%baseprecv(ilev_)%iprcparm(mld_sub_restr_) = psb_none_
p%baseprecv(ilev_)%iprcparm(mld_sub_prol_) = psb_none_
p%baseprecv(ilev_)%iprcparm(mld_sub_ren_) = 0
p%baseprecv(ilev_)%iprcparm(mld_sub_ovr_) = 0
p%baseprecv(ilev_)%iprcparm(mld_smoother_sweeps_) = 1
p%precv(ilev_)%iprcparm(:) = 0
p%precv(ilev_)%rprcparm(:) = dzero
p%precv(ilev_)%prec%iprcparm(:) = 0
p%precv(ilev_)%prec%rprcparm(:) = dzero
p%precv(ilev_)%prec%iprcparm(mld_smoother_type_) = mld_noprec_
p%precv(ilev_)%prec%iprcparm(mld_sub_solve_) = mld_f_none_
p%precv(ilev_)%prec%iprcparm(mld_sub_restr_) = psb_none_
p%precv(ilev_)%prec%iprcparm(mld_sub_prol_) = psb_none_
p%precv(ilev_)%prec%iprcparm(mld_sub_ren_) = 0
p%precv(ilev_)%prec%iprcparm(mld_sub_ovr_) = 0
p%precv(ilev_)%prec%iprcparm(mld_smoother_sweeps_) = 1
case ('DIAG')
nlev_ = 1
ilev_ = 1
allocate(p%baseprecv(nlev_),stat=info)
if (info == 0) call psb_realloc(mld_ifpsz_,p%baseprecv(ilev_)%iprcparm,info)
if (info == 0) call psb_realloc(mld_rfpsz_,p%baseprecv(ilev_)%rprcparm,info)
allocate(p%precv(nlev_),stat=info)
if (info == 0) call psb_realloc(mld_ifpsz_,p%precv(ilev_)%iprcparm,info)
if (info == 0) call psb_realloc(mld_rfpsz_,p%precv(ilev_)%rprcparm,info)
if (info == 0) call psb_realloc(mld_ifpsz_,p%precv(ilev_)%prec%iprcparm,info)
if (info == 0) call psb_realloc(mld_rfpsz_,p%precv(ilev_)%prec%rprcparm,info)
if (info /= 0) return
p%baseprecv(ilev_)%iprcparm(:) = 0
p%baseprecv(ilev_)%iprcparm(mld_smoother_type_) = mld_diag_
p%baseprecv(ilev_)%iprcparm(mld_sub_solve_) = mld_f_none_
p%baseprecv(ilev_)%iprcparm(mld_sub_restr_) = psb_none_
p%baseprecv(ilev_)%iprcparm(mld_sub_prol_) = psb_none_
p%baseprecv(ilev_)%iprcparm(mld_sub_ren_) = 0
p%baseprecv(ilev_)%iprcparm(mld_sub_ovr_) = 0
p%baseprecv(ilev_)%iprcparm(mld_smoother_sweeps_) = 1
p%precv(ilev_)%iprcparm(:) = 0
p%precv(ilev_)%rprcparm(:) = dzero
p%precv(ilev_)%prec%iprcparm(:) = 0
p%precv(ilev_)%prec%rprcparm(:) = dzero
p%precv(ilev_)%prec%iprcparm(mld_smoother_type_) = mld_diag_
p%precv(ilev_)%prec%iprcparm(mld_sub_solve_) = mld_f_none_
p%precv(ilev_)%prec%iprcparm(mld_sub_restr_) = psb_none_
p%precv(ilev_)%prec%iprcparm(mld_sub_prol_) = psb_none_
p%precv(ilev_)%prec%iprcparm(mld_sub_ren_) = 0
p%precv(ilev_)%prec%iprcparm(mld_sub_ovr_) = 0
p%precv(ilev_)%prec%iprcparm(mld_smoother_sweeps_) = 1
case ('BJAC')
nlev_ = 1
ilev_ = 1
allocate(p%baseprecv(nlev_),stat=info)
if (info == 0) call psb_realloc(mld_ifpsz_,p%baseprecv(ilev_)%iprcparm,info)
if (info == 0) call psb_realloc(mld_rfpsz_,p%baseprecv(ilev_)%rprcparm,info)
allocate(p%precv(nlev_),stat=info)
if (info == 0) call psb_realloc(mld_ifpsz_,p%precv(ilev_)%iprcparm,info)
if (info == 0) call psb_realloc(mld_rfpsz_,p%precv(ilev_)%rprcparm,info)
if (info == 0) call psb_realloc(mld_ifpsz_,p%precv(ilev_)%prec%iprcparm,info)
if (info == 0) call psb_realloc(mld_rfpsz_,p%precv(ilev_)%prec%rprcparm,info)
if (info /= 0) return
p%baseprecv(ilev_)%iprcparm(:) = 0
p%baseprecv(ilev_)%iprcparm(mld_smoother_type_) = mld_bjac_
p%baseprecv(ilev_)%iprcparm(mld_sub_solve_) = mld_ilu_n_
p%baseprecv(ilev_)%iprcparm(mld_sub_restr_) = psb_none_
p%baseprecv(ilev_)%iprcparm(mld_sub_prol_) = psb_none_
p%baseprecv(ilev_)%iprcparm(mld_sub_ren_) = 0
p%baseprecv(ilev_)%iprcparm(mld_sub_ovr_) = 0
p%baseprecv(ilev_)%iprcparm(mld_sub_fillin_) = 0
p%baseprecv(ilev_)%iprcparm(mld_smoother_sweeps_) = 1
p%precv(ilev_)%iprcparm(:) = 0
p%precv(ilev_)%rprcparm(:) = dzero
p%precv(ilev_)%prec%iprcparm(:) = 0
p%precv(ilev_)%prec%rprcparm(:) = dzero
p%precv(ilev_)%prec%iprcparm(mld_smoother_type_) = mld_bjac_
p%precv(ilev_)%prec%iprcparm(mld_sub_solve_) = mld_ilu_n_
p%precv(ilev_)%prec%iprcparm(mld_sub_restr_) = psb_none_
p%precv(ilev_)%prec%iprcparm(mld_sub_prol_) = psb_none_
p%precv(ilev_)%prec%iprcparm(mld_sub_ren_) = 0
p%precv(ilev_)%prec%iprcparm(mld_sub_ovr_) = 0
p%precv(ilev_)%prec%iprcparm(mld_sub_fillin_) = 0
p%precv(ilev_)%prec%iprcparm(mld_smoother_sweeps_) = 1
case ('AS')
nlev_ = 1
ilev_ = 1
allocate(p%baseprecv(nlev_),stat=info)
if (info == 0) call psb_realloc(mld_ifpsz_,p%baseprecv(ilev_)%iprcparm,info)
if (info == 0) call psb_realloc(mld_rfpsz_,p%baseprecv(ilev_)%rprcparm,info)
allocate(p%precv(nlev_),stat=info)
if (info == 0) call psb_realloc(mld_ifpsz_,p%precv(ilev_)%iprcparm,info)
if (info == 0) call psb_realloc(mld_rfpsz_,p%precv(ilev_)%rprcparm,info)
if (info == 0) call psb_realloc(mld_ifpsz_,p%precv(ilev_)%prec%iprcparm,info)
if (info == 0) call psb_realloc(mld_rfpsz_,p%precv(ilev_)%prec%rprcparm,info)
if (info /= 0) return
p%baseprecv(ilev_)%iprcparm(:) = 0
p%baseprecv(ilev_)%iprcparm(mld_smoother_type_) = mld_as_
p%baseprecv(ilev_)%iprcparm(mld_sub_solve_) = mld_ilu_n_
p%baseprecv(ilev_)%iprcparm(mld_sub_restr_) = psb_halo_
p%baseprecv(ilev_)%iprcparm(mld_sub_prol_) = psb_none_
p%baseprecv(ilev_)%iprcparm(mld_sub_ren_) = 0
p%baseprecv(ilev_)%iprcparm(mld_sub_ovr_) = 1
p%baseprecv(ilev_)%iprcparm(mld_sub_fillin_) = 0
p%baseprecv(ilev_)%iprcparm(mld_smoother_sweeps_) = 1
p%precv(ilev_)%iprcparm(:) = 0
p%precv(ilev_)%rprcparm(:) = dzero
p%precv(ilev_)%prec%iprcparm(:) = 0
p%precv(ilev_)%prec%rprcparm(:) = dzero
p%precv(ilev_)%prec%iprcparm(mld_smoother_type_) = mld_as_
p%precv(ilev_)%prec%iprcparm(mld_sub_solve_) = mld_ilu_n_
p%precv(ilev_)%prec%iprcparm(mld_sub_restr_) = psb_halo_
p%precv(ilev_)%prec%iprcparm(mld_sub_prol_) = psb_none_
p%precv(ilev_)%prec%iprcparm(mld_sub_ren_) = 0
p%precv(ilev_)%prec%iprcparm(mld_sub_ovr_) = 1
p%precv(ilev_)%prec%iprcparm(mld_sub_fillin_) = 0
p%precv(ilev_)%prec%iprcparm(mld_smoother_sweeps_) = 1
case ('ML')
@ -187,76 +207,88 @@ subroutine mld_dprecinit(p,ptype,info,nlev)
nlev_ = 2
end if
ilev_ = 1
allocate(p%baseprecv(nlev_),stat=info)
if (info == 0) call psb_realloc(mld_ifpsz_,p%baseprecv(ilev_)%iprcparm,info)
if (info == 0) call psb_realloc(mld_rfpsz_,p%baseprecv(ilev_)%rprcparm,info)
allocate(p%precv(nlev_),stat=info)
if (info == 0) call psb_realloc(mld_ifpsz_,p%precv(ilev_)%iprcparm,info)
if (info == 0) call psb_realloc(mld_rfpsz_,p%precv(ilev_)%rprcparm,info)
if (info == 0) call psb_realloc(mld_ifpsz_,p%precv(ilev_)%prec%iprcparm,info)
if (info == 0) call psb_realloc(mld_rfpsz_,p%precv(ilev_)%prec%rprcparm,info)
if (info /= 0) return
p%baseprecv(ilev_)%iprcparm(:) = 0
p%baseprecv(ilev_)%rprcparm(:) = dzero
p%baseprecv(ilev_)%iprcparm(mld_smoother_type_) = mld_as_
p%baseprecv(ilev_)%iprcparm(mld_sub_solve_) = mld_ilu_n_
p%baseprecv(ilev_)%iprcparm(mld_sub_restr_) = psb_halo_
p%baseprecv(ilev_)%iprcparm(mld_sub_prol_) = psb_none_
p%baseprecv(ilev_)%iprcparm(mld_sub_ren_) = 0
p%baseprecv(ilev_)%iprcparm(mld_sub_ovr_) = 1
p%baseprecv(ilev_)%iprcparm(mld_sub_fillin_) = 0
p%baseprecv(ilev_)%iprcparm(mld_smoother_sweeps_) = 1
p%precv(ilev_)%iprcparm(:) = 0
p%precv(ilev_)%rprcparm(:) = dzero
p%precv(ilev_)%prec%iprcparm(:) = 0
p%precv(ilev_)%prec%rprcparm(:) = dzero
p%precv(ilev_)%prec%iprcparm(mld_smoother_type_) = mld_as_
p%precv(ilev_)%prec%iprcparm(mld_sub_solve_) = mld_ilu_n_
p%precv(ilev_)%prec%iprcparm(mld_sub_restr_) = psb_halo_
p%precv(ilev_)%prec%iprcparm(mld_sub_prol_) = psb_none_
p%precv(ilev_)%prec%iprcparm(mld_sub_ren_) = 0
p%precv(ilev_)%prec%iprcparm(mld_sub_ovr_) = 1
p%precv(ilev_)%prec%iprcparm(mld_sub_fillin_) = 0
p%precv(ilev_)%prec%iprcparm(mld_smoother_sweeps_) = 1
if (nlev_ == 1) return
do ilev_ = 2, nlev_ -1
if (info == 0) call psb_realloc(mld_ifpsz_,p%baseprecv(ilev_)%iprcparm,info)
if (info == 0) call psb_realloc(mld_rfpsz_,p%baseprecv(ilev_)%rprcparm,info)
if (info == 0) call psb_realloc(mld_ifpsz_,p%precv(ilev_)%iprcparm,info)
if (info == 0) call psb_realloc(mld_rfpsz_,p%precv(ilev_)%rprcparm,info)
if (info == 0) call psb_realloc(mld_ifpsz_,p%precv(ilev_)%prec%iprcparm,info)
if (info == 0) call psb_realloc(mld_rfpsz_,p%precv(ilev_)%prec%rprcparm,info)
if (info /= 0) return
p%baseprecv(ilev_)%iprcparm(:) = 0
p%baseprecv(ilev_)%rprcparm(:) = dzero
p%baseprecv(ilev_)%iprcparm(mld_smoother_type_) = mld_as_
p%baseprecv(ilev_)%iprcparm(mld_sub_restr_) = psb_halo_
p%baseprecv(ilev_)%iprcparm(mld_sub_prol_) = psb_none_
p%baseprecv(ilev_)%iprcparm(mld_sub_ren_) = 0
p%baseprecv(ilev_)%iprcparm(mld_sub_ovr_) = 1
p%baseprecv(ilev_)%iprcparm(mld_ml_type_) = mld_mult_ml_
p%baseprecv(ilev_)%iprcparm(mld_aggr_alg_) = mld_dec_aggr_
p%baseprecv(ilev_)%iprcparm(mld_aggr_kind_) = mld_smooth_prol_
p%baseprecv(ilev_)%iprcparm(mld_coarse_mat_) = mld_distr_mat_
p%baseprecv(ilev_)%iprcparm(mld_smoother_pos_) = mld_post_smooth_
p%baseprecv(ilev_)%iprcparm(mld_aggr_omega_alg_) = mld_eig_est_
p%baseprecv(ilev_)%iprcparm(mld_aggr_eig_) = mld_max_norm_
p%baseprecv(ilev_)%iprcparm(mld_sub_solve_) = mld_ilu_n_
p%baseprecv(ilev_)%iprcparm(mld_sub_fillin_) = 0
p%baseprecv(ilev_)%iprcparm(mld_smoother_sweeps_) = 1
p%baseprecv(ilev_)%rprcparm(mld_aggr_omega_val_) = dzero
p%baseprecv(ilev_)%rprcparm(mld_aggr_thresh_) = dzero
p%precv(ilev_)%iprcparm(:) = 0
p%precv(ilev_)%rprcparm(:) = dzero
p%precv(ilev_)%prec%iprcparm(:) = 0
p%precv(ilev_)%prec%rprcparm(:) = dzero
p%precv(ilev_)%prec%iprcparm(mld_smoother_type_) = mld_as_
p%precv(ilev_)%prec%iprcparm(mld_sub_restr_) = psb_halo_
p%precv(ilev_)%prec%iprcparm(mld_sub_prol_) = psb_none_
p%precv(ilev_)%prec%iprcparm(mld_sub_ren_) = 0
p%precv(ilev_)%prec%iprcparm(mld_sub_ovr_) = 1
p%precv(ilev_)%prec%iprcparm(mld_sub_solve_) = mld_ilu_n_
p%precv(ilev_)%prec%iprcparm(mld_sub_fillin_) = 0
p%precv(ilev_)%prec%iprcparm(mld_smoother_sweeps_) = 1
p%precv(ilev_)%iprcparm(mld_ml_type_) = mld_mult_ml_
p%precv(ilev_)%iprcparm(mld_aggr_alg_) = mld_dec_aggr_
p%precv(ilev_)%iprcparm(mld_aggr_kind_) = mld_smooth_prol_
p%precv(ilev_)%iprcparm(mld_coarse_mat_) = mld_distr_mat_
p%precv(ilev_)%iprcparm(mld_smoother_pos_) = mld_post_smooth_
p%precv(ilev_)%iprcparm(mld_aggr_omega_alg_) = mld_eig_est_
p%precv(ilev_)%iprcparm(mld_aggr_eig_) = mld_max_norm_
p%precv(ilev_)%rprcparm(mld_aggr_omega_val_) = dzero
p%precv(ilev_)%rprcparm(mld_aggr_thresh_) = dzero
end do
ilev_ = nlev_
if (info == 0) call psb_realloc(mld_ifpsz_,p%baseprecv(ilev_)%iprcparm,info)
if (info == 0) call psb_realloc(mld_rfpsz_,p%baseprecv(ilev_)%rprcparm,info)
if (info == 0) call psb_realloc(mld_ifpsz_,p%precv(ilev_)%iprcparm,info)
if (info == 0) call psb_realloc(mld_rfpsz_,p%precv(ilev_)%rprcparm,info)
if (info == 0) call psb_realloc(mld_ifpsz_,p%precv(ilev_)%prec%iprcparm,info)
if (info == 0) call psb_realloc(mld_rfpsz_,p%precv(ilev_)%prec%rprcparm,info)
if (info /= 0) return
p%baseprecv(ilev_)%iprcparm(:) = 0
p%baseprecv(ilev_)%rprcparm(:) = dzero
p%baseprecv(ilev_)%iprcparm(mld_coarse_solve_) = mld_bjac_
p%precv(ilev_)%iprcparm(:) = 0
p%precv(ilev_)%rprcparm(:) = dzero
p%precv(ilev_)%prec%iprcparm(:) = 0
p%precv(ilev_)%prec%rprcparm(:) = dzero
p%precv(ilev_)%prec%iprcparm(mld_coarse_solve_) = mld_bjac_
#if defined(HAVE_UMF_)
p%baseprecv(ilev_)%iprcparm(mld_sub_solve_) = mld_umf_
p%precv(ilev_)%prec%iprcparm(mld_sub_solve_) = mld_umf_
#elif defined(HAVE_SLU_)
p%baseprecv(ilev_)%iprcparm(mld_sub_solve_) = mld_slu_
p%precv(ilev_)%prec%iprcparm(mld_sub_solve_) = mld_slu_
#else
p%baseprecv(ilev_)%iprcparm(mld_sub_solve_) = mld_ilu_n_
p%precv(ilev_)%prec%iprcparm(mld_sub_solve_) = mld_ilu_n_
#endif
p%baseprecv(ilev_)%iprcparm(mld_smoother_type_) = mld_bjac_
p%baseprecv(ilev_)%iprcparm(mld_coarse_mat_) = mld_distr_mat_
p%baseprecv(ilev_)%iprcparm(mld_sub_restr_) = psb_none_
p%baseprecv(ilev_)%iprcparm(mld_sub_prol_) = psb_none_
p%baseprecv(ilev_)%iprcparm(mld_sub_ren_) = 0
p%baseprecv(ilev_)%iprcparm(mld_sub_ovr_) = 0
p%baseprecv(ilev_)%iprcparm(mld_ml_type_) = mld_mult_ml_
p%baseprecv(ilev_)%iprcparm(mld_aggr_alg_) = mld_dec_aggr_
p%baseprecv(ilev_)%iprcparm(mld_aggr_kind_) = mld_smooth_prol_
p%baseprecv(ilev_)%iprcparm(mld_smoother_pos_) = mld_post_smooth_
p%baseprecv(ilev_)%iprcparm(mld_aggr_omega_alg_) = mld_eig_est_
p%baseprecv(ilev_)%iprcparm(mld_aggr_eig_) = mld_max_norm_
p%baseprecv(ilev_)%iprcparm(mld_sub_fillin_) = 0
p%baseprecv(ilev_)%iprcparm(mld_smoother_sweeps_) = 4
p%baseprecv(ilev_)%rprcparm(mld_aggr_omega_val_) = dzero
p%baseprecv(ilev_)%rprcparm(mld_aggr_thresh_) = dzero
p%precv(ilev_)%prec%iprcparm(mld_smoother_type_) = mld_bjac_
p%precv(ilev_)%prec%iprcparm(mld_coarse_mat_) = mld_distr_mat_
p%precv(ilev_)%prec%iprcparm(mld_sub_restr_) = psb_none_
p%precv(ilev_)%prec%iprcparm(mld_sub_prol_) = psb_none_
p%precv(ilev_)%prec%iprcparm(mld_sub_ren_) = 0
p%precv(ilev_)%prec%iprcparm(mld_sub_ovr_) = 0
p%precv(ilev_)%prec%iprcparm(mld_sub_fillin_) = 0
p%precv(ilev_)%prec%iprcparm(mld_smoother_sweeps_) = 4
p%precv(ilev_)%iprcparm(mld_ml_type_) = mld_mult_ml_
p%precv(ilev_)%iprcparm(mld_aggr_alg_) = mld_dec_aggr_
p%precv(ilev_)%iprcparm(mld_aggr_kind_) = mld_smooth_prol_
p%precv(ilev_)%iprcparm(mld_smoother_pos_) = mld_post_smooth_
p%precv(ilev_)%iprcparm(mld_aggr_omega_alg_) = mld_eig_est_
p%precv(ilev_)%iprcparm(mld_aggr_eig_) = mld_max_norm_
p%precv(ilev_)%rprcparm(mld_aggr_omega_val_) = dzero
p%precv(ilev_)%rprcparm(mld_aggr_thresh_) = dzero
case default
write(0,*) name,': Warning: Unknown preconditioner type request "',ptype,'"'

114
mlprec/mld_dprecset.f90
Unescape Escape View File

@ -96,12 +96,12 @@ subroutine mld_dprecseti(p,what,val,info,ilev)
info = 0
if (.not.allocated(p%baseprecv)) then
if (.not.allocated(p%precv)) then
info = 3111
write(0,*) name,': Error: uninitialized preconditioner, should call MLD_PRECINIT'
return
endif
nlev_ = size(p%baseprecv)
nlev_ = size(p%precv)
if (present(ilev)) then
ilev_ = ilev
@ -114,7 +114,13 @@ subroutine mld_dprecseti(p,what,val,info,ilev)
write(0,*) name,': Error: invalid ILEV/NLEV combination',ilev_, nlev_
return
endif
if (.not.allocated(p%baseprecv(ilev_)%iprcparm)) then
if (.not.allocated(p%precv(ilev_)%iprcparm)) then
info = 3111
write(0,*) name,&
&': Error: uninitialized preconditioner component, should call MLD_PRECINIT'
return
endif
if (.not.allocated(p%precv(ilev_)%prec%iprcparm)) then
info = 3111
write(0,*) name,&
&': Error: uninitialized preconditioner component, should call MLD_PRECINIT'
@ -133,7 +139,7 @@ subroutine mld_dprecseti(p,what,val,info,ilev)
select case(what)
case(mld_smoother_type_,mld_sub_solve_,mld_sub_restr_,mld_sub_prol_,&
& mld_sub_ren_,mld_sub_ovr_,mld_sub_fillin_,mld_smoother_sweeps_)
p%baseprecv(ilev_)%iprcparm(what) = val
p%precv(ilev_)%prec%iprcparm(what) = val
case default
write(0,*) name,': Error: invalid WHAT'
info = -2
@ -143,23 +149,25 @@ subroutine mld_dprecseti(p,what,val,info,ilev)
select case(what)
case(mld_smoother_type_,mld_sub_solve_,mld_sub_restr_,mld_sub_prol_,&
& mld_sub_ren_,mld_sub_ovr_,mld_sub_fillin_,&
& mld_smoother_sweeps_,mld_ml_type_,mld_aggr_alg_,mld_aggr_kind_,&
& mld_smoother_sweeps_)
p%precv(ilev_)%prec%iprcparm(what) = val
case(mld_ml_type_,mld_aggr_alg_,mld_aggr_kind_,&
& mld_smoother_pos_,mld_aggr_omega_alg_,mld_aggr_eig_)
p%baseprecv(ilev_)%iprcparm(what) = val
p%precv(ilev_)%iprcparm(what) = val
case(mld_coarse_mat_)
if (ilev_ /= nlev_ .and. val /= mld_distr_mat_) then
write(0,*) name,': Error: Inconsistent specification of WHAT vs. ILEV'
info = -2
return
end if
p%baseprecv(ilev_)%iprcparm(mld_coarse_mat_) = val
p%precv(ilev_)%iprcparm(mld_coarse_mat_) = val
case(mld_coarse_subsolve_)
if (ilev_ /= nlev_) then
write(0,*) name,': Error: Inconsistent specification of WHAT vs. ILEV'
info = -2
return
end if
p%baseprecv(ilev_)%iprcparm(mld_sub_solve_) = val
p%precv(ilev_)%iprcparm(mld_sub_solve_) = val
case(mld_coarse_solve_)
if (ilev_ /= nlev_) then
write(0,*) name,': Error: Inconsistent specification of WHAT vs. ILEV'
@ -168,15 +176,15 @@ subroutine mld_dprecseti(p,what,val,info,ilev)
end if
if (nlev_ > 1) then
p%baseprecv(nlev_)%iprcparm(mld_coarse_solve_) = val
p%baseprecv(nlev_)%iprcparm(mld_smoother_type_) = mld_bjac_
p%baseprecv(nlev_)%iprcparm(mld_coarse_mat_) = mld_distr_mat_
p%precv(nlev_)%iprcparm(mld_coarse_solve_) = val
p%precv(nlev_)%prec%iprcparm(mld_smoother_type_) = mld_bjac_
p%precv(nlev_)%iprcparm(mld_coarse_mat_) = mld_distr_mat_
select case (val)
case(mld_umf_, mld_slu_)
p%baseprecv(nlev_)%iprcparm(mld_coarse_mat_) = mld_repl_mat_
p%baseprecv(nlev_)%iprcparm(mld_sub_solve_) = val
p%precv(nlev_)%iprcparm(mld_coarse_mat_) = mld_repl_mat_
p%precv(nlev_)%prec%iprcparm(mld_sub_solve_) = val
case(mld_sludist_)
p%baseprecv(nlev_)%iprcparm(mld_sub_solve_) = val
p%precv(nlev_)%prec%iprcparm(mld_sub_solve_) = val
end select
endif
case(mld_coarse_sweeps_)
@ -185,14 +193,14 @@ subroutine mld_dprecseti(p,what,val,info,ilev)
info = -2
return
end if
p%baseprecv(ilev_)%iprcparm(mld_smoother_sweeps_) = val
p%precv(ilev_)%prec%iprcparm(mld_smoother_sweeps_) = val
case(mld_coarse_fillin_)
if (ilev_ /= nlev_) then
write(0,*) name,': Error: Inconsistent specification of WHAT vs. ILEV'
info = -2
return
end if
p%baseprecv(ilev_)%iprcparm(mld_sub_fillin_) = val
p%precv(ilev_)%prec%iprcparm(mld_sub_fillin_) = val
case default
write(0,*) name,': Error: invalid WHAT'
info = -2
@ -210,35 +218,35 @@ subroutine mld_dprecseti(p,what,val,info,ilev)
& mld_sub_ren_,mld_sub_ovr_,mld_sub_fillin_,&
& mld_smoother_sweeps_)
do ilev_=1,max(1,nlev_-1)
if (.not.allocated(p%baseprecv(ilev_)%iprcparm)) then
if (.not.allocated(p%precv(ilev_)%iprcparm)) then
write(0,*) name,&
&': Error: uninitialized preconditioner component, should call MLD_PRECINIT'
info = -1
return
endif
p%baseprecv(ilev_)%iprcparm(what) = val
p%precv(ilev_)%prec%iprcparm(what) = val
end do
case(mld_ml_type_,mld_aggr_alg_,mld_aggr_kind_,&
& mld_smoother_pos_,mld_aggr_omega_alg_,mld_aggr_eig_)
do ilev_=2,nlev_
if (.not.allocated(p%baseprecv(ilev_)%iprcparm)) then
if (.not.allocated(p%precv(ilev_)%iprcparm)) then
write(0,*) name,&
&': Error: uninitialized preconditioner component, should call MLD_PRECINIT'
info = -1
return
endif
p%baseprecv(ilev_)%iprcparm(what) = val
p%precv(ilev_)%iprcparm(what) = val
end do
case(mld_coarse_mat_)
if (.not.allocated(p%baseprecv(nlev_)%iprcparm)) then
if (.not.allocated(p%precv(nlev_)%iprcparm)) then
write(0,*) name,&
& ': Error: uninitialized preconditioner component, should call MLD_PRECINIT'
info = -1
return
endif
if (nlev_ > 1) p%baseprecv(nlev_)%iprcparm(mld_coarse_mat_) = val
if (nlev_ > 1) p%precv(nlev_)%iprcparm(mld_coarse_mat_) = val
case(mld_coarse_solve_)
if (.not.allocated(p%baseprecv(nlev_)%iprcparm)) then
if (.not.allocated(p%precv(nlev_)%iprcparm)) then
write(0,*) name,&
&': Error: uninitialized preconditioner component, should call MLD_PRECINIT'
info = -1
@ -246,42 +254,42 @@ subroutine mld_dprecseti(p,what,val,info,ilev)
endif
if (nlev_ > 1) then
p%baseprecv(nlev_)%iprcparm(mld_coarse_solve_) = val
p%baseprecv(nlev_)%iprcparm(mld_smoother_type_) = mld_bjac_
p%baseprecv(nlev_)%iprcparm(mld_coarse_mat_) = mld_distr_mat_
p%precv(nlev_)%iprcparm(mld_coarse_solve_) = val
p%precv(nlev_)%prec%iprcparm(mld_smoother_type_) = mld_bjac_
p%precv(nlev_)%iprcparm(mld_coarse_mat_) = mld_distr_mat_
select case (val)
case(mld_umf_, mld_slu_)
p%baseprecv(nlev_)%iprcparm(mld_coarse_mat_) = mld_repl_mat_
p%baseprecv(nlev_)%iprcparm(mld_sub_solve_) = val
p%precv(nlev_)%iprcparm(mld_coarse_mat_) = mld_repl_mat_
p%precv(nlev_)%prec%iprcparm(mld_sub_solve_) = val
case(mld_sludist_)
p%baseprecv(nlev_)%iprcparm(mld_sub_solve_) = val
p%precv(nlev_)%prec%iprcparm(mld_sub_solve_) = val
end select
endif
case(mld_coarse_subsolve_)
if (.not.allocated(p%baseprecv(nlev_)%iprcparm)) then
if (.not.allocated(p%precv(nlev_)%iprcparm)) then
write(0,*) name,&
&': Error: uninitialized preconditioner component, should call MLD_PRECINIT'
info = -1
return
end if
if (nlev_ > 1) p%baseprecv(nlev_)%iprcparm(mld_sub_solve_) = val
if (nlev_ > 1) p%precv(nlev_)%prec%iprcparm(mld_sub_solve_) = val
case(mld_coarse_sweeps_)
if (.not.allocated(p%baseprecv(nlev_)%iprcparm)) then
if (.not.allocated(p%precv(nlev_)%iprcparm)) then
write(0,*) name,&
&': Error: uninitialized preconditioner component, should call MLD_PRECINIT'
info = -1
return
endif
if (nlev_ > 1) p%baseprecv(nlev_)%iprcparm(mld_smoother_sweeps_) = val
if (nlev_ > 1) p%precv(nlev_)%prec%iprcparm(mld_smoother_sweeps_) = val
case(mld_coarse_fillin_)
if (.not.allocated(p%baseprecv(nlev_)%iprcparm)) then
if (.not.allocated(p%precv(nlev_)%iprcparm)) then
write(0,*) name,&
&': Error: uninitialized preconditioner component, should call MLD_PRECINIT'
info = -1
return
endif
if (nlev_ > 1) p%baseprecv(nlev_)%iprcparm(mld_sub_fillin_) = val
if (nlev_ > 1) p%precv(nlev_)%prec%iprcparm(mld_sub_fillin_) = val
case default
write(0,*) name,': Error: invalid WHAT'
info = -2
@ -351,11 +359,11 @@ subroutine mld_dprecsetc(p,what,string,info,ilev)
info = 0
if (.not.allocated(p%baseprecv)) then
if (.not.allocated(p%precv)) then
info = 3111
return
endif
nlev_ = size(p%baseprecv)
nlev_ = size(p%precv)
if (present(ilev)) then
ilev_ = ilev
@ -368,7 +376,7 @@ subroutine mld_dprecsetc(p,what,string,info,ilev)
info = -1
return
endif
if (.not.allocated(p%baseprecv(ilev_)%iprcparm)) then
if (.not.allocated(p%precv(ilev_)%iprcparm)) then
write(0,*) name,': Error: uninitialized preconditioner component, should call MLD_PRECINIT'
info = 3111
return
@ -446,19 +454,19 @@ subroutine mld_dprecsetr(p,what,val,info,ilev)
ilev_ = 1
end if
if (.not.allocated(p%baseprecv)) then
if (.not.allocated(p%precv)) then
write(0,*) name,': Error: uninitialized preconditioner, should call MLD_PRECINIT'
info = 3111
return
endif
nlev_ = size(p%baseprecv)
nlev_ = size(p%precv)
if ((ilev_<1).or.(ilev_ > nlev_)) then
write(0,*) name,': Error: invalid ILEV/NLEV combination',ilev_, nlev_
info = -1
return
endif
if (.not.allocated(p%baseprecv(ilev_)%rprcparm)) then
if (.not.allocated(p%precv(ilev_)%rprcparm)) then
write(0,*) name,': Error: uninitialized preconditioner component, should call MLD_PRECINIT'
info = 3111
return
@ -475,7 +483,7 @@ subroutine mld_dprecsetr(p,what,val,info,ilev)
!
select case(what)
case(mld_sub_iluthrs_)
p%baseprecv(ilev_)%rprcparm(what) = val
p%precv(ilev_)%prec%rprcparm(what) = val
case default
write(0,*) name,': Error: invalid WHAT'
info = -2
@ -483,8 +491,10 @@ subroutine mld_dprecsetr(p,what,val,info,ilev)
else if (ilev_ > 1) then
select case(what)
case(mld_aggr_omega_val_,mld_aggr_thresh_,mld_sub_iluthrs_)
p%baseprecv(ilev_)%rprcparm(what) = val
case(mld_sub_iluthrs_)
p%precv(ilev_)%prec%rprcparm(what) = val
case(mld_aggr_omega_val_,mld_aggr_thresh_)
p%precv(ilev_)%rprcparm(what) = val
case default
write(0,*) name,': Error: invalid WHAT'
info = -2
@ -499,38 +509,38 @@ subroutine mld_dprecsetr(p,what,val,info,ilev)
select case(what)
case(mld_sub_iluthrs_)
do ilev_=1,nlev_
if (.not.allocated(p%baseprecv(ilev_)%rprcparm)) then
if (.not.allocated(p%precv(ilev_)%rprcparm)) then
write(0,*) name,': Error: uninitialized preconditioner component, should call MLD_PRECINIT'
info = -1
return
endif
p%baseprecv(ilev_)%rprcparm(what) = val
p%precv(ilev_)%prec%rprcparm(what) = val
end do
case(mld_coarse_iluthrs_)
ilev_=nlev_
if (.not.allocated(p%baseprecv(ilev_)%rprcparm)) then
if (.not.allocated(p%precv(ilev_)%rprcparm)) then
write(0,*) name,': Error: uninitialized preconditioner component, should call MLD_PRECINIT'
info = -1
return
endif
p%baseprecv(ilev_)%rprcparm(mld_sub_iluthrs_) = val
p%precv(ilev_)%prec%rprcparm(mld_sub_iluthrs_) = val
case(mld_aggr_omega_val_)
do ilev_=2,nlev_
if (.not.allocated(p%baseprecv(ilev_)%rprcparm)) then
if (.not.allocated(p%precv(ilev_)%rprcparm)) then
write(0,*) name,': Error: uninitialized preconditioner component, should call MLD_PRECINIT'
info = -1
return
endif
p%baseprecv(ilev_)%rprcparm(what) = val
p%precv(ilev_)%rprcparm(what) = val
end do
case(mld_aggr_thresh_)
do ilev_=2,nlev_
if (.not.allocated(p%baseprecv(ilev_)%rprcparm)) then
if (.not.allocated(p%precv(ilev_)%rprcparm)) then
write(0,*) name,': Error: uninitialized preconditioner component, should call MLD_PRECINIT'
info = -1
return
endif
p%baseprecv(ilev_)%rprcparm(what) = val
p%precv(ilev_)%rprcparm(what) = val
end do
case default
write(0,*) name,': Error: invalid WHAT'

132
mlprec/mld_inner_mod.f90
Unescape Escape View File

@ -142,11 +142,11 @@ module mld_inner_mod
end interface
interface mld_mlprec_aply
subroutine mld_smlprec_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info)
subroutine mld_smlprec_aply(alpha,precv,x,beta,y,desc_data,trans,work,info)
use psb_base_mod, only : psb_sspmat_type, psb_desc_type, psb_spk_
use mld_prec_type, only : mld_sbaseprc_type
use mld_prec_type, only : mld_sbaseprc_type, mld_s_onelev_prec_type
type(psb_desc_type),intent(in) :: desc_data
type(mld_sbaseprc_type), intent(in) :: baseprecv(:)
type(mld_s_onelev_prec_type), intent(in) :: precv(:)
real(psb_spk_),intent(in) :: alpha,beta
real(psb_spk_),intent(in) :: x(:)
real(psb_spk_),intent(inout) :: y(:)
@ -154,11 +154,11 @@ module mld_inner_mod
real(psb_spk_),target :: work(:)
integer, intent(out) :: info
end subroutine mld_smlprec_aply
subroutine mld_dmlprec_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info)
subroutine mld_dmlprec_aply(alpha,precv,x,beta,y,desc_data,trans,work,info)
use psb_base_mod, only : psb_dspmat_type, psb_desc_type, psb_dpk_
use mld_prec_type, only : mld_dbaseprc_type
use mld_prec_type, only : mld_dbaseprc_type, mld_d_onelev_prec_type
type(psb_desc_type),intent(in) :: desc_data
type(mld_dbaseprc_type), intent(in) :: baseprecv(:)
type(mld_d_onelev_prec_type), intent(in) :: precv(:)
real(psb_dpk_),intent(in) :: alpha,beta
real(psb_dpk_),intent(in) :: x(:)
real(psb_dpk_),intent(inout) :: y(:)
@ -168,9 +168,9 @@ module mld_inner_mod
end subroutine mld_dmlprec_aply
subroutine mld_cmlprec_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info)
use psb_base_mod, only : psb_cspmat_type, psb_desc_type, psb_spk_
use mld_prec_type, only : mld_cbaseprc_type
use mld_prec_type, only : mld_cbaseprc_type, mld_c_onelev_prec_type
type(psb_desc_type),intent(in) :: desc_data
type(mld_cbaseprc_type), intent(in) :: baseprecv(:)
type(mld_c_onelev_prec_type), intent(in) :: baseprecv(:)
complex(psb_spk_),intent(in) :: alpha,beta
complex(psb_spk_),intent(in) :: x(:)
complex(psb_spk_),intent(inout) :: y(:)
@ -180,9 +180,9 @@ module mld_inner_mod
end subroutine mld_cmlprec_aply
subroutine mld_zmlprec_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info)
use psb_base_mod, only : psb_zspmat_type, psb_desc_type, psb_dpk_
use mld_prec_type, only : mld_zbaseprc_type
use mld_prec_type, only : mld_zbaseprc_type, mld_z_onelev_prec_type
type(psb_desc_type),intent(in) :: desc_data
type(mld_zbaseprc_type), intent(in) :: baseprecv(:)
type(mld_z_onelev_prec_type), intent(in) :: baseprecv(:)
complex(psb_dpk_),intent(in) :: alpha,beta
complex(psb_dpk_),intent(in) :: x(:)
complex(psb_dpk_),intent(inout) :: y(:)
@ -427,130 +427,106 @@ module mld_inner_mod
end interface
interface mld_aggrmat_asb
subroutine mld_saggrmat_asb(a,desc_a,ac,desc_ac,p,info)
subroutine mld_saggrmat_asb(a,desc_a,p,info)
use psb_base_mod, only : psb_sspmat_type, psb_desc_type, psb_spk_
use mld_prec_type, only : mld_sbaseprc_type
use mld_prec_type, only : mld_sbaseprc_type, mld_s_onelev_prec_type
type(psb_sspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_a
type(psb_sspmat_type), intent(out) :: ac
type(psb_desc_type), intent(out) :: desc_ac
type(mld_sbaseprc_type), intent(inout), target :: p
type(mld_s_onelev_prec_type), intent(inout), target :: p
integer, intent(out) :: info
end subroutine mld_saggrmat_asb
subroutine mld_daggrmat_asb(a,desc_a,ac,desc_ac,p,info)
subroutine mld_daggrmat_asb(a,desc_a,p,info)
use psb_base_mod, only : psb_dspmat_type, psb_desc_type, psb_dpk_
use mld_prec_type, only : mld_dbaseprc_type
use mld_prec_type, only : mld_dbaseprc_type, mld_d_onelev_prec_type
type(psb_dspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_a
type(psb_dspmat_type), intent(out) :: ac
type(psb_desc_type), intent(out) :: desc_ac
type(mld_dbaseprc_type), intent(inout), target :: p
type(mld_d_onelev_prec_type), intent(inout), target :: p
integer, intent(out) :: info
end subroutine mld_daggrmat_asb
subroutine mld_caggrmat_asb(a,desc_a,ac,desc_ac,p,info)
subroutine mld_caggrmat_asb(a,desc_a,p,info)
use psb_base_mod, only : psb_cspmat_type, psb_desc_type, psb_spk_
use mld_prec_type, only : mld_cbaseprc_type
use mld_prec_type, only : mld_cbaseprc_type, mld_c_onelev_prec_type
type(psb_cspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_a
type(psb_cspmat_type), intent(out) :: ac
type(psb_desc_type), intent(out) :: desc_ac
type(mld_cbaseprc_type), intent(inout), target :: p
type(mld_c_onelev_prec_type), intent(inout), target :: p
integer, intent(out) :: info
end subroutine mld_caggrmat_asb
subroutine mld_zaggrmat_asb(a,desc_a,ac,desc_ac,p,info)
subroutine mld_zaggrmat_asb(a,desc_a,p,info)
use psb_base_mod, only : psb_zspmat_type, psb_desc_type, psb_dpk_
use mld_prec_type, only : mld_zbaseprc_type
use mld_prec_type, only : mld_zbaseprc_type, mld_z_onelev_prec_type
type(psb_zspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_a
type(psb_zspmat_type), intent(out) :: ac
type(psb_desc_type), intent(out) :: desc_ac
type(mld_zbaseprc_type), intent(inout), target :: p
type(mld_z_onelev_prec_type), intent(inout), target :: p
integer, intent(out) :: info
end subroutine mld_zaggrmat_asb
end interface
interface mld_aggrmat_raw_asb
subroutine mld_saggrmat_raw_asb(a,desc_a,ac,desc_ac,p,info)
subroutine mld_saggrmat_raw_asb(a,desc_a,p,info)
use psb_base_mod, only : psb_sspmat_type, psb_desc_type, psb_spk_
use mld_prec_type, only : mld_sbaseprc_type
use mld_prec_type, only : mld_sbaseprc_type, mld_s_onelev_prec_type
type(psb_sspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_a
type(psb_sspmat_type), intent(out) :: ac
type(psb_desc_type), intent(out) :: desc_ac
type(mld_sbaseprc_type), intent(inout), target :: p
type(mld_s_onelev_prec_type), intent(inout), target :: p
integer, intent(out) :: info
end subroutine mld_saggrmat_raw_asb
subroutine mld_daggrmat_raw_asb(a,desc_a,ac,desc_ac,p,info)
subroutine mld_daggrmat_raw_asb(a,desc_a,p,info)
use psb_base_mod, only : psb_dspmat_type, psb_desc_type, psb_dpk_
use mld_prec_type, only : mld_dbaseprc_type
use mld_prec_type, only : mld_dbaseprc_type, mld_d_onelev_prec_type
type(psb_dspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_a
type(psb_dspmat_type), intent(out) :: ac
type(psb_desc_type), intent(out) :: desc_ac
type(mld_dbaseprc_type), intent(inout), target :: p
type(mld_d_onelev_prec_type), intent(inout), target :: p
integer, intent(out) :: info
end subroutine mld_daggrmat_raw_asb
subroutine mld_caggrmat_raw_asb(a,desc_a,ac,desc_ac,p,info)
subroutine mld_caggrmat_raw_asb(a,desc_a,p,info)
use psb_base_mod, only : psb_cspmat_type, psb_desc_type, psb_spk_
use mld_prec_type, only : mld_cbaseprc_type
use mld_prec_type, only : mld_cbaseprc_type, mld_c_onelev_prec_type
type(psb_cspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_a
type(psb_cspmat_type), intent(out) :: ac
type(psb_desc_type), intent(out) :: desc_ac
type(mld_cbaseprc_type), intent(inout), target :: p
type(mld_c_onelev_prec_type), intent(inout), target :: p
integer, intent(out) :: info
end subroutine mld_caggrmat_raw_asb
subroutine mld_zaggrmat_raw_asb(a,desc_a,ac,desc_ac,p,info)
subroutine mld_zaggrmat_raw_asb(a,desc_a,p,info)
use psb_base_mod, only : psb_zspmat_type, psb_desc_type, psb_dpk_
use mld_prec_type, only : mld_zbaseprc_type
use mld_prec_type, only : mld_zbaseprc_type, mld_z_onelev_prec_type
type(psb_zspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_a
type(psb_zspmat_type), intent(out) :: ac
type(psb_desc_type), intent(out) :: desc_ac
type(mld_zbaseprc_type), intent(inout), target :: p
type(mld_z_onelev_prec_type), intent(inout), target :: p
integer, intent(out) :: info
end subroutine mld_zaggrmat_raw_asb
end interface
interface mld_aggrmat_smth_asb
subroutine mld_saggrmat_smth_asb(a,desc_a,ac,desc_ac,p,info)
subroutine mld_saggrmat_smth_asb(a,desc_a,p,info)
use psb_base_mod, only : psb_sspmat_type, psb_desc_type, psb_spk_
use mld_prec_type, only : mld_sbaseprc_type
use mld_prec_type, only : mld_sbaseprc_type, mld_s_onelev_prec_type
type(psb_sspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_a
type(psb_sspmat_type), intent(out) :: ac
type(psb_desc_type), intent(out) :: desc_ac
type(mld_sbaseprc_type), intent(inout), target :: p
type(mld_s_onelev_prec_type), intent(inout), target :: p
integer, intent(out) :: info
end subroutine mld_saggrmat_smth_asb
subroutine mld_daggrmat_smth_asb(a,desc_a,ac,desc_ac,p,info)
subroutine mld_daggrmat_smth_asb(a,desc_a,p,info)
use psb_base_mod, only : psb_dspmat_type, psb_desc_type, psb_dpk_
use mld_prec_type, only : mld_dbaseprc_type
use mld_prec_type, only : mld_dbaseprc_type, mld_d_onelev_prec_type
type(psb_dspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_a
type(psb_dspmat_type), intent(out) :: ac
type(psb_desc_type), intent(out) :: desc_ac
type(mld_dbaseprc_type), intent(inout), target :: p
type(mld_d_onelev_prec_type), intent(inout), target :: p
integer, intent(out) :: info
end subroutine mld_daggrmat_smth_asb
subroutine mld_caggrmat_smth_asb(a,desc_a,ac,desc_ac,p,info)
subroutine mld_caggrmat_smth_asb(a,desc_a,p,info)
use psb_base_mod, only : psb_cspmat_type, psb_desc_type, psb_spk_
use mld_prec_type, only : mld_cbaseprc_type
use mld_prec_type, only : mld_cbaseprc_type, mld_c_onelev_prec_type
type(psb_cspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_a
type(psb_cspmat_type), intent(out) :: ac
type(psb_desc_type), intent(out) :: desc_ac
type(mld_cbaseprc_type), intent(inout), target :: p
type(mld_c_onelev_prec_type), intent(inout), target :: p
integer, intent(out) :: info
end subroutine mld_caggrmat_smth_asb
subroutine mld_zaggrmat_smth_asb(a,desc_a,ac,desc_ac,p,info)
subroutine mld_zaggrmat_smth_asb(a,desc_a,p,info)
use psb_base_mod, only : psb_zspmat_type, psb_desc_type, psb_dpk_
use mld_prec_type, only : mld_zbaseprc_type
use mld_prec_type, only : mld_zbaseprc_type, mld_z_onelev_prec_type
type(psb_zspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_a
type(psb_zspmat_type), intent(out) :: ac
type(psb_desc_type), intent(out) :: desc_ac
type(mld_zbaseprc_type), intent(inout), target :: p
type(mld_z_onelev_prec_type), intent(inout), target :: p
integer, intent(out) :: info
end subroutine mld_zaggrmat_smth_asb
end interface
@ -636,34 +612,34 @@ module mld_inner_mod
interface mld_mlprec_bld
subroutine mld_smlprec_bld(a,desc_a,p,info)
use psb_base_mod, only : psb_sspmat_type, psb_desc_type, psb_spk_
use mld_prec_type, only : mld_sbaseprc_type
use mld_prec_type, only : mld_sbaseprc_type, mld_s_onelev_prec_type
type(psb_sspmat_type), intent(inout), target :: a
type(psb_desc_type), intent(in), target :: desc_a
type(mld_sbaseprc_type), intent(inout), target :: p
type(mld_s_onelev_prec_type), intent(inout), target :: p
integer, intent(out) :: info
end subroutine mld_smlprec_bld
subroutine mld_dmlprec_bld(a,desc_a,p,info)
use psb_base_mod, only : psb_dspmat_type, psb_desc_type, psb_dpk_
use mld_prec_type, only : mld_dbaseprc_type
use mld_prec_type, only : mld_dbaseprc_type, mld_d_onelev_prec_type
type(psb_dspmat_type), intent(inout), target :: a
type(psb_desc_type), intent(in), target :: desc_a
type(mld_dbaseprc_type), intent(inout), target :: p
type(mld_d_onelev_prec_type), intent(inout), target :: p
integer, intent(out) :: info
end subroutine mld_dmlprec_bld
subroutine mld_cmlprec_bld(a,desc_a,p,info)
use psb_base_mod, only : psb_cspmat_type, psb_desc_type, psb_spk_
use mld_prec_type, only : mld_cbaseprc_type
use mld_prec_type, only : mld_cbaseprc_type, mld_c_onelev_prec_type
type(psb_cspmat_type), intent(inout), target :: a
type(psb_desc_type), intent(in), target :: desc_a
type(mld_cbaseprc_type), intent(inout),target :: p
type(mld_c_onelev_prec_type), intent(inout),target :: p
integer, intent(out) :: info
end subroutine mld_cmlprec_bld
subroutine mld_zmlprec_bld(a,desc_a,p,info)
use psb_base_mod, only : psb_zspmat_type, psb_desc_type, psb_dpk_
use mld_prec_type, only : mld_zbaseprc_type
use mld_prec_type, only : mld_zbaseprc_type, mld_z_onelev_prec_type
type(psb_zspmat_type), intent(inout), target :: a
type(psb_desc_type), intent(in), target :: desc_a
type(mld_zbaseprc_type), intent(inout),target :: p
type(mld_z_onelev_prec_type), intent(inout),target :: p
integer, intent(out) :: info
end subroutine mld_zmlprec_bld
end interface

741
mlprec/mld_prec_type.f90
View File

File diff suppressed because it is too large Load Diff

4
mlprec/mld_saggrmap_bld.f90
Unescape Escape View File

@ -131,7 +131,7 @@ subroutine mld_saggrmap_bld(aggr_type,theta,a,desc_a,nlaggr,ilaggr,info)
atmp%m=nr
atmp%k=nr
if (info == 0) call psb_sp_free(atrans,info)
if (info == 0) call psb_ipcoo2csr(atmp,info)
if (info == 0) call psb_spcnv(atmp,info,afmt='csr')
if (info == 0) call mld_dec_map_bld(theta,atmp,desc_a,nlaggr,ilaggr,info)
if (info == 0) call psb_sp_free(atmp,info)
@ -161,8 +161,6 @@ subroutine mld_saggrmap_bld(aggr_type,theta,a,desc_a,nlaggr,ilaggr,info)
contains
subroutine mld_dec_map_bld(theta,a,desc_a,nlaggr,ilaggr,info)
use psb_base_mod

23
mlprec/mld_saggrmat_asb.f90
Unescape Escape View File

@ -76,24 +76,21 @@
! 1181-1196.
!
!
!
! Arguments:
! a - type(psb_sspmat_type), input.
! The sparse matrix structure containing the local part of
! the fine-level matrix.
! desc_a - type(psb_desc_type), input.
! The communication descriptor of the fine-level matrix.
! ac - type(psb_sspmat_type), output.
! The sparse matrix structure containing the local part of
! the coarse-level matrix.
! desc_ac - type(psb_desc_type), output.
! The communication descriptor of the coarse-level matrix.
! p - type(mld_sbaseprc_type), input/output.
! The base preconditioner data structure containing the local
! part of the base preconditioner to be built.
! p - type(mld_s_onelev_prec_type), input/output.
! The one-level preconditioner data structure containing the local
! part of the base preconditioner to be built as well as the
! aggregate matrices.
! info - integer, output.
! Error code.
!
subroutine mld_saggrmat_asb(a,desc_a,ac,desc_ac,p,info)
subroutine mld_saggrmat_asb(a,desc_a,p,info)
use psb_base_mod
use mld_inner_mod, mld_protect_name => mld_saggrmat_asb
@ -103,9 +100,7 @@ subroutine mld_saggrmat_asb(a,desc_a,ac,desc_ac,p,info)
! Arguments
type(psb_sspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_a
type(psb_sspmat_type), intent(out) :: ac
type(psb_desc_type), intent(out) :: desc_ac
type(mld_sbaseprc_type), intent(inout), target :: p
type(mld_s_onelev_prec_type), intent(inout), target :: p
integer, intent(out) :: info
! Local variables
@ -125,7 +120,7 @@ subroutine mld_saggrmat_asb(a,desc_a,ac,desc_ac,p,info)
select case (p%iprcparm(mld_aggr_kind_))
case (mld_no_smooth_)
call mld_aggrmat_raw_asb(a,desc_a,ac,desc_ac,p,info)
call mld_aggrmat_raw_asb(a,desc_a,p,info)
if(info /= 0) then
call psb_errpush(4010,name,a_err='mld_aggrmat_raw_asb')
goto 9999
@ -133,7 +128,7 @@ subroutine mld_saggrmat_asb(a,desc_a,ac,desc_ac,p,info)
case(mld_smooth_prol_,mld_biz_prol_)
call mld_aggrmat_smth_asb(a,desc_a,ac,desc_ac,p,info)
call mld_aggrmat_smth_asb(a,desc_a,p,info)
if(info /= 0) then
call psb_errpush(4010,name,a_err='mld_aggrmat_smth_asb')
goto 9999

72
mlprec/mld_saggrmat_raw_asb.F90
Unescape Escape View File

@ -59,24 +59,21 @@
! 57 (2007), 1181-1196.
!
!
!
! Arguments:
! a - type(psb_sspmat_type), input.
! The sparse matrix structure containing the local part of
! the fine-level matrix.
! desc_a - type(psb_desc_type), input.
! The communication descriptor of the fine-level matrix.
! ac - type(psb_sspmat_type), output.
! The sparse matrix structure containing the local part of
! the coarse-level matrix.
! desc_ac - type(psb_desc_type), output.
! The communication descriptor of the coarse-level matrix.
! p - type(mld_sbaseprc_type), input/output.
! The base preconditioner data structure containing the local
! part of the base preconditioner to be built.
! p - type(mld_s_onelev_prec_type), input/output.
! The one-level preconditioner data structure containing the local
! part of the base preconditioner to be built as well as the
! aggregate matrices.
! info - integer, output.
! Error code.
!
subroutine mld_saggrmat_raw_asb(a,desc_a,ac,desc_ac,p,info)
subroutine mld_saggrmat_raw_asb(a,desc_a,p,info)
use psb_base_mod
use mld_inner_mod, mld_protect_name => mld_saggrmat_raw_asb
@ -91,17 +88,15 @@ subroutine mld_saggrmat_raw_asb(a,desc_a,ac,desc_ac,p,info)
! Arguments
type(psb_sspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_a
type(psb_sspmat_type), intent(out) :: ac
type(psb_desc_type), intent(out) :: desc_ac
type(mld_sbaseprc_type), intent(inout), target :: p
type(mld_s_onelev_prec_type), intent(inout), target :: p
integer, intent(out) :: info
! Local variables
integer ::ictxt,np,me, err_act, icomm
character(len=20) :: name
type(psb_sspmat_type) :: b
integer, pointer :: nzbr(:), idisp(:)
type(psb_sspmat_type), pointer :: am1,am2
integer, allocatable :: nzbr(:), idisp(:)
type(psb_sspmat_type) :: am1,am2
integer :: nrow, nglob, ncol, ntaggr, nzac, ip, ndx,&
& naggr, nzt, naggrm1, i
@ -119,9 +114,6 @@ subroutine mld_saggrmat_raw_asb(a,desc_a,ac,desc_ac,p,info)
nrow = psb_cd_get_local_rows(desc_a)
ncol = psb_cd_get_local_cols(desc_a)
am2 => p%av(mld_sm_pr_t_)
am1 => p%av(mld_sm_pr_)
call psb_nullify_sp(am1)
call psb_nullify_sp(am2)
@ -195,7 +187,7 @@ subroutine mld_saggrmat_raw_asb(a,desc_a,ac,desc_ac,p,info)
if (p%iprcparm(mld_coarse_mat_) == mld_repl_mat_) then
call psb_cdall(ictxt,desc_ac,info,mg=ntaggr,repl=.true.)
call psb_cdall(ictxt,p%desc_ac,info,mg=ntaggr,repl=.true.)
if(info /= 0) then
call psb_errpush(4010,name,a_err='psb_cdall')
goto 9999
@ -206,7 +198,7 @@ subroutine mld_saggrmat_raw_asb(a,desc_a,ac,desc_ac,p,info)
call psb_sum(ictxt,nzbr(1:np))
nzac = sum(nzbr)
call psb_sp_all(ntaggr,ntaggr,ac,nzac,info)
call psb_sp_all(ntaggr,ntaggr,p%ac,nzac,info)
if(info /= 0) then
call psb_errpush(4010,name,a_err='sp_all')
goto 9999
@ -217,11 +209,11 @@ subroutine mld_saggrmat_raw_asb(a,desc_a,ac,desc_ac,p,info)
enddo
ndx = nzbr(me+1)
call mpi_allgatherv(b%aspk,ndx,mpi_real,ac%aspk,nzbr,idisp,&
call mpi_allgatherv(b%aspk,ndx,mpi_real,p%ac%aspk,nzbr,idisp,&
& mpi_real,icomm,info)
call mpi_allgatherv(b%ia1,ndx,mpi_integer,ac%ia1,nzbr,idisp,&
call mpi_allgatherv(b%ia1,ndx,mpi_integer,p%ac%ia1,nzbr,idisp,&
& mpi_integer,icomm,info)
call mpi_allgatherv(b%ia2,ndx,mpi_integer,ac%ia2,nzbr,idisp,&
call mpi_allgatherv(b%ia2,ndx,mpi_integer,p%ac%ia2,nzbr,idisp,&
& mpi_integer,icomm,info)
if(info /= 0) then
info=-1
@ -229,12 +221,12 @@ subroutine mld_saggrmat_raw_asb(a,desc_a,ac,desc_ac,p,info)
goto 9999
end if
ac%m = ntaggr
ac%k = ntaggr
ac%infoa(psb_nnz_) = nzac
ac%fida='COO'
ac%descra='GUN'
call psb_spcnv(ac,info,afmt='coo',dupl=psb_dupl_add_)
p%ac%m = ntaggr
p%ac%k = ntaggr
p%ac%infoa(psb_nnz_) = nzac
p%ac%fida='COO'
p%ac%descra='GUN'
call psb_spcnv(p%ac,info,afmt='coo',dupl=psb_dupl_add_)
if(info /= 0) then
call psb_errpush(4010,name,a_err='sp_free')
goto 9999
@ -242,9 +234,9 @@ subroutine mld_saggrmat_raw_asb(a,desc_a,ac,desc_ac,p,info)
else if (p%iprcparm(mld_coarse_mat_) == mld_distr_mat_) then
call psb_cdall(ictxt,desc_ac,info,nl=naggr)
if (info == 0) call psb_cdasb(desc_ac,info)
if (info == 0) call psb_sp_clone(b,ac,info)
call psb_cdall(ictxt,p%desc_ac,info,nl=naggr)
if (info == 0) call psb_cdasb(p%desc_ac,info)
if (info == 0) call psb_sp_clone(b,p%ac,info)
if(info /= 0) then
call psb_errpush(4001,name,a_err='Build ac, desc_ac')
goto 9999
@ -263,9 +255,23 @@ subroutine mld_saggrmat_raw_asb(a,desc_a,ac,desc_ac,p,info)
deallocate(nzbr,idisp)
call psb_spcnv(ac,info,afmt='csr',dupl=psb_dupl_add_)
call psb_spcnv(p%ac,info,afmt='csr',dupl=psb_dupl_add_)
if(info /= 0) then
call psb_errpush(4010,name,a_err='spcnv')
goto 9999
end if
!
! Copy the prolongation/restriction matrices into the descriptor map.
! am2 => PR^T i.e. restriction operator
! am1 => PR i.e. prolongation operator
!
p%map_desc = psb_inter_desc(psb_map_aggr_,desc_a,&
& p%desc_ac,am2,am1)
if (info == 0) call psb_sp_free(am1,info)
if (info == 0) call psb_sp_free(am2,info)
if(info /= 0) then
call psb_errpush(4010,name,a_err='ipcoo2csr')
call psb_errpush(4010,name,a_err='sp_Free')
goto 9999
end if

128
mlprec/mld_saggrmat_smth_asb.F90
Unescape Escape View File

@ -83,18 +83,14 @@
! the fine-level matrix.
! desc_a - type(psb_desc_type), input.
! The communication descriptor of the fine-level matrix.
! ac - type(psb_sspmat_type), output.
! The sparse matrix structure containing the local part of
! the coarse-level matrix.
! desc_ac - type(psb_desc_type), output.
! The communication descriptor of the coarse-level matrix.
! p - type(mld_sbaseprc_type), input/output.
! The base preconditioner data structure containing the local
! part of the base preconditioner to be built.
! p - type(mld_s_onelev_prec_type), input/output.
! The one-level preconditioner data structure containing the local
! part of the base preconditioner to be built as well as the
! aggregate matrices.
! info - integer, output.
! Error code.
!
subroutine mld_saggrmat_smth_asb(a,desc_a,ac,desc_ac,p,info)
subroutine mld_saggrmat_smth_asb(a,desc_a,p,info)
use psb_base_mod
use mld_inner_mod, mld_protect_name => mld_saggrmat_smth_asb
@ -109,19 +105,17 @@ subroutine mld_saggrmat_smth_asb(a,desc_a,ac,desc_ac,p,info)
! Arguments
type(psb_sspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_a
type(psb_sspmat_type), intent(out) :: ac
type(psb_desc_type), intent(out) :: desc_ac
type(mld_sbaseprc_type), intent(inout), target :: p
type(mld_s_onelev_prec_type), intent(inout), target :: p
integer, intent(out) :: info
! Local variables
type(psb_sspmat_type) :: b
integer, pointer :: nzbr(:), idisp(:)
integer, allocatable :: nzbr(:), idisp(:)
integer :: nrow, nglob, ncol, ntaggr, nzac, ip, ndx,&
& naggr, nzl,naggrm1,naggrp1, i, j, k
integer ::ictxt,np,me, err_act, icomm
character(len=20) :: name
type(psb_sspmat_type), pointer :: am1,am2
type(psb_sspmat_type) :: am1,am2
type(psb_sspmat_type) :: am3,am4
real(psb_spk_), allocatable :: adiag(:)
logical :: ml_global_nmb
@ -146,9 +140,6 @@ subroutine mld_saggrmat_smth_asb(a,desc_a,ac,desc_ac,p,info)
call psb_nullify_sp(b)
call psb_nullify_sp(am3)
call psb_nullify_sp(am4)
am2 => p%av(mld_sm_pr_t_)
am1 => p%av(mld_sm_pr_)
call psb_nullify_sp(am1)
call psb_nullify_sp(am2)
@ -263,7 +254,6 @@ subroutine mld_saggrmat_smth_asb(a,desc_a,ac,desc_ac,p,info)
if (p%iprcparm(mld_aggr_omega_alg_) == mld_eig_est_) then
if (p%iprcparm(mld_aggr_eig_) == mld_max_norm_) then
if (p%iprcparm(mld_aggr_kind_) == mld_biz_prol_) then
@ -293,7 +283,6 @@ subroutine mld_saggrmat_smth_asb(a,desc_a,ac,desc_ac,p,info)
call psb_errpush(info,name,a_err='this section only CSR')
goto 9999
endif
else
anorm = psb_spnrmi(am3,desc_a,info)
endif
@ -458,16 +447,16 @@ subroutine mld_saggrmat_smth_asb(a,desc_a,ac,desc_ac,p,info)
case(mld_distr_mat_)
call psb_sp_clone(b,ac,info)
nzac = ac%infoa(psb_nnz_)
nzl = ac%infoa(psb_nnz_)
if (info == 0) call psb_cdall(ictxt,desc_ac,info,nl=p%nlaggr(me+1))
if (info == 0) call psb_cdins(nzl,ac%ia1,ac%ia2,desc_ac,info)
if (info == 0) call psb_cdasb(desc_ac,info)
if (info == 0) call psb_glob_to_loc(ac%ia1(1:nzl),desc_ac,info,iact='I')
if (info == 0) call psb_glob_to_loc(ac%ia2(1:nzl),desc_ac,info,iact='I')
call psb_sp_clone(b,p%ac,info)
nzac = p%ac%infoa(psb_nnz_)
nzl = p%ac%infoa(psb_nnz_)
if (info == 0) call psb_cdall(ictxt,p%desc_ac,info,nl=p%nlaggr(me+1))
if (info == 0) call psb_cdins(nzl,p%ac%ia1,p%ac%ia2,p%desc_ac,info)
if (info == 0) call psb_cdasb(p%desc_ac,info)
if (info == 0) call psb_glob_to_loc(p%ac%ia1(1:nzl),p%desc_ac,info,iact='I')
if (info == 0) call psb_glob_to_loc(p%ac%ia2(1:nzl),p%desc_ac,info,iact='I')
if (info /= 0) then
call psb_errpush(4001,name,a_err='Creating desc_ac and converting ac')
call psb_errpush(4001,name,a_err='Creating p%desc_ac and converting ac')
goto 9999
end if
if (debug_level >= psb_debug_outer_) &
@ -475,10 +464,10 @@ subroutine mld_saggrmat_smth_asb(a,desc_a,ac,desc_ac,p,info)
& 'Assembld aux descr. distr.'
ac%m=desc_ac%matrix_data(psb_n_row_)
ac%k=desc_ac%matrix_data(psb_n_col_)
ac%fida='COO'
ac%descra='GUN'
p%ac%m=psb_cd_get_local_rows(p%desc_ac)
p%ac%k=psb_cd_get_local_cols(p%desc_ac)
p%ac%fida='COO'
p%ac%descra='GUN'
call psb_sp_free(b,info)
if (info == 0) deallocate(nzbr,idisp,stat=info)
@ -489,25 +478,25 @@ subroutine mld_saggrmat_smth_asb(a,desc_a,ac,desc_ac,p,info)
if (np>1) then
nzl = psb_sp_get_nnzeros(am1)
call psb_glob_to_loc(am1%ia1(1:nzl),desc_ac,info,'I')
call psb_glob_to_loc(am1%ia1(1:nzl),p%desc_ac,info,'I')
if(info /= 0) then
call psb_errpush(4010,name,a_err='psb_glob_to_loc')
goto 9999
end if
endif
am1%k=desc_ac%matrix_data(psb_n_col_)
am1%k=psb_cd_get_local_cols(p%desc_ac)
if (np>1) then
call psb_spcnv(am2,info,afmt='coo',dupl=psb_dupl_add_)
nzl = am2%infoa(psb_nnz_)
if (info == 0) call psb_glob_to_loc(am2%ia1(1:nzl),desc_ac,info,'I')
if (info == 0) call psb_glob_to_loc(am2%ia1(1:nzl),p%desc_ac,info,'I')
if (info == 0) call psb_spcnv(am2,info,afmt='csr',dupl=psb_dupl_add_)
if(info /= 0) then
call psb_errpush(4001,name,a_err='Converting am2 to local')
goto 9999
end if
end if
am2%m=desc_ac%matrix_data(psb_n_col_)
am2%m=psb_cd_get_local_cols(p%desc_ac)
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
@ -516,13 +505,13 @@ subroutine mld_saggrmat_smth_asb(a,desc_a,ac,desc_ac,p,info)
case(mld_repl_mat_)
!
!
call psb_cdall(ictxt,desc_ac,info,mg=ntaggr,repl=.true.)
call psb_cdall(ictxt,p%desc_ac,info,mg=ntaggr,repl=.true.)
nzbr(:) = 0
nzbr(me+1) = b%infoa(psb_nnz_)
call psb_sum(ictxt,nzbr(1:np))
nzac = sum(nzbr)
if (info == 0) call psb_sp_all(ntaggr,ntaggr,ac,nzac,info)
if (info == 0) call psb_sp_all(ntaggr,ntaggr,p%ac,nzac,info)
if (info /= 0) goto 9999
do ip=1,np
@ -530,11 +519,11 @@ subroutine mld_saggrmat_smth_asb(a,desc_a,ac,desc_ac,p,info)
enddo
ndx = nzbr(me+1)
call mpi_allgatherv(b%aspk,ndx,mpi_real,ac%aspk,nzbr,idisp,&
call mpi_allgatherv(b%aspk,ndx,mpi_real,p%ac%aspk,nzbr,idisp,&
& mpi_real,icomm,info)
if (info == 0) call mpi_allgatherv(b%ia1,ndx,mpi_integer,ac%ia1,nzbr,idisp,&
if (info == 0) call mpi_allgatherv(b%ia1,ndx,mpi_integer,p%ac%ia1,nzbr,idisp,&
& mpi_integer,icomm,info)
if (info == 0) call mpi_allgatherv(b%ia2,ndx,mpi_integer,ac%ia2,nzbr,idisp,&
if (info == 0) call mpi_allgatherv(b%ia2,ndx,mpi_integer,p%ac%ia2,nzbr,idisp,&
& mpi_integer,icomm,info)
if (info /= 0) then
@ -542,12 +531,12 @@ subroutine mld_saggrmat_smth_asb(a,desc_a,ac,desc_ac,p,info)
goto 9999
end if
ac%m = ntaggr
ac%k = ntaggr
ac%infoa(psb_nnz_) = nzac
ac%fida='COO'
ac%descra='GUN'
call psb_spcnv(ac,info,afmt='coo',dupl=psb_dupl_add_)
p%ac%m = ntaggr
p%ac%k = ntaggr
p%ac%infoa(psb_nnz_) = nzac
p%ac%fida='COO'
p%ac%descra='GUN'
call psb_spcnv(p%ac,info,afmt='coo',dupl=psb_dupl_add_)
if(info /= 0) goto 9999
call psb_sp_free(b,info)
if(info /= 0) goto 9999
@ -571,9 +560,9 @@ subroutine mld_saggrmat_smth_asb(a,desc_a,ac,desc_ac,p,info)
case(mld_distr_mat_)
call psb_sp_clone(b,ac,info)
if (info == 0) call psb_cdall(ictxt,desc_ac,info,nl=naggr)
if (info == 0) call psb_cdasb(desc_ac,info)
call psb_sp_clone(b,p%ac,info)
if (info == 0) call psb_cdall(ictxt,p%desc_ac,info,nl=naggr)
if (info == 0) call psb_cdasb(p%desc_ac,info)
if (info == 0) call psb_sp_free(b,info)
if (info /= 0) then
call psb_errpush(4010,name,a_err='Build desc_ac, ac')
@ -584,7 +573,7 @@ subroutine mld_saggrmat_smth_asb(a,desc_a,ac,desc_ac,p,info)
case(mld_repl_mat_)
!
!
call psb_cdall(ictxt,desc_ac,info,mg=ntaggr,repl=.true.)
call psb_cdall(ictxt,p%desc_ac,info,mg=ntaggr,repl=.true.)
if(info /= 0) then
call psb_errpush(4010,name,a_err='psb_cdall')
goto 9999
@ -594,7 +583,7 @@ subroutine mld_saggrmat_smth_asb(a,desc_a,ac,desc_ac,p,info)
nzbr(me+1) = b%infoa(psb_nnz_)
call psb_sum(ictxt,nzbr(1:np))
nzac = sum(nzbr)
call psb_sp_all(ntaggr,ntaggr,ac,nzac,info)
call psb_sp_all(ntaggr,ntaggr,p%ac,nzac,info)
if(info /= 0) then
call psb_errpush(4010,name,a_err='psb_sp_all')
goto 9999
@ -605,11 +594,11 @@ subroutine mld_saggrmat_smth_asb(a,desc_a,ac,desc_ac,p,info)
enddo
ndx = nzbr(me+1)
call mpi_allgatherv(b%aspk,ndx,mpi_real,ac%aspk,nzbr,idisp,&
call mpi_allgatherv(b%aspk,ndx,mpi_real,p%ac%aspk,nzbr,idisp,&
& mpi_real,icomm,info)
if (info == 0) call mpi_allgatherv(b%ia1,ndx,mpi_integer,ac%ia1,nzbr,idisp,&
if (info == 0) call mpi_allgatherv(b%ia1,ndx,mpi_integer,p%ac%ia1,nzbr,idisp,&
& mpi_integer,icomm,info)
if (info == 0) call mpi_allgatherv(b%ia2,ndx,mpi_integer,ac%ia2,nzbr,idisp,&
if (info == 0) call mpi_allgatherv(b%ia2,ndx,mpi_integer,p%ac%ia2,nzbr,idisp,&
& mpi_integer,icomm,info)
if (info /= 0) then
call psb_errpush(4001,name,a_err=' from mpi_allgatherv')
@ -617,12 +606,12 @@ subroutine mld_saggrmat_smth_asb(a,desc_a,ac,desc_ac,p,info)
end if
ac%m = ntaggr
ac%k = ntaggr
ac%infoa(psb_nnz_) = nzac
ac%fida='COO'
ac%descra='GUN'
call psb_spcnv(ac,info,afmt='coo',dupl=psb_dupl_add_)
p%ac%m = ntaggr
p%ac%k = ntaggr
p%ac%infoa(psb_nnz_) = nzac
p%ac%fida='COO'
p%ac%descra='GUN'
call psb_spcnv(p%ac,info,afmt='coo',dupl=psb_dupl_add_)
if(info /= 0) then
call psb_errpush(4010,name,a_err='spcnv')
goto 9999
@ -653,12 +642,27 @@ subroutine mld_saggrmat_smth_asb(a,desc_a,ac,desc_ac,p,info)
end select
call psb_spcnv(ac,info,afmt='csr',dupl=psb_dupl_add_)
call psb_spcnv(p%ac,info,afmt='csr',dupl=psb_dupl_add_)
if(info /= 0) then
call psb_errpush(4010,name,a_err='spcnv')
goto 9999
end if
!
! Copy the prolongation/restriction matrices into the descriptor map.
! am2 => PR^T i.e. restriction operator
! am1 => PR i.e. prolongation operator
!
p%map_desc = psb_inter_desc(psb_map_aggr_,desc_a,&
& p%desc_ac,am2,am1)
if (info == 0) call psb_sp_free(am1,info)
if (info == 0) call psb_sp_free(am2,info)
if(info /= 0) then
call psb_errpush(4010,name,a_err='sp_Free')
goto 9999
end if
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'Done smooth_aggregate '

2
mlprec/mld_sbaseprec_bld.f90
Unescape Escape View File

@ -197,8 +197,6 @@ subroutine mld_sbaseprc_bld(a,desc_a,p,info,upd)
end select
p%base_a => a
p%base_desc => desc_a
p%iprcparm(mld_prec_status_) = mld_prec_built_
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),': Done'

340
mlprec/mld_smlprec_aply.f90
Unescape Escape View File

@ -46,7 +46,7 @@
! Y = beta*Y + alpha*op(M^(-1))*X,
! where
! - M is a multilevel domain decomposition (Schwarz) preconditioner associated
! to a certain matrix A and stored in the array baseprecv,
! to a certain matrix A and stored in the array precv,
! - op(M^(-1)) is M^(-1) or its transpose, according to the value of trans,
! - X and Y are vectors,
! - alpha and beta are scalars.
@ -55,9 +55,9 @@
! level where we might have a replicated index space) and each process takes care
! of one submatrix.
!
! The multilevel preconditioner M is regarded as an array of 'base preconditioners',
! The multilevel preconditioner M is regarded as an array of 'one-level preconditioners',
! each representing the part of the preconditioner associated to a certain level.
! For each level ilev, the base preconditioner K(ilev) is stored in baseprecv(ilev)
! For each level ilev, the preconditioner K(ilev) is stored in precv(ilev)
! and is associated to a matrix A(ilev), obtained by 'tranferring' the original
! matrix A (i.e. the matrix to be preconditioned) to the level ilev, through smoothed
! aggregation.
@ -78,64 +78,41 @@
! Arguments:
! alpha - real(psb_spk_), input.
! The scalar alpha.
! baseprecv - type(mld_sbaseprc_type), dimension(:), input.
! The array of base preconditioner data structures containing the
! precv - type(mld_s_onelev_prec_type), dimension(:), input.
! The array of one-level preconditioner data structures containing the
! local parts of the preconditioners to be applied at each level.
! Note that nlev = size(baseprecv) = number of levels.
! baseprecv(ilev)%av - type(psb_sspmat_type), dimension(:), allocatable(:).
! The sparse matrices needed to apply the preconditioner
! at level ilev.
! baseprecv(ilev)%av(mld_l_pr_) - The L factor of the ILU factorization of
! the local diagonal block of A(ilev).
! baseprecv(ilev)%av(mld_u_pr_) - The U factor of the ILU factorization of the
! local diagonal block of A(ilev), except its
! diagonal entries (stored in baseprecv(ilev)%d).
! baseprecv(ilev)%av(mld_ap_nd_) - The entries of the local part of A(ilev)
! outside the diagonal block, for block-Jacobi
! sweeps.
! baseprecv(ilev)%av(mld_ac_) - The local part of the matrix A(ilev).
! baseprecv(ilev)%av(mld_sm_pr_) - The smoothed prolongator.
! It maps vectors (ilev) ---> (ilev-1).
! baseprecv(ilev)%av(mld_sm_pr_t_) - The smoothed prolongator transpose.
! It maps vectors (ilev-1) ---> (ilev).
! baseprecv(ilev)%d - real(psb_spk_), dimension(:), allocatable.
! The diagonal entries of the U factor in the ILU
! factorization of A(ilev).
! baseprecv(ilev)%desc_data - type(psb_desc_type).
! The communication descriptor associated to the base
! preconditioner, i.e. to the sparse matrices needed
! to apply the base preconditioner at the current level.
! baseprecv(ilev)%desc_ac - type(psb_desc_type).
! Note that nlev = size(precv) = number of levels.
! precv(ilev)%prec - type(psb_sbaseprc_type)
! The "base" preconditioner for the current level
! precv(ilev)%ac - type(psb_sspmat_type)
! The local part of the matrix A(ilev).
! precv(ilev)%desc_ac - type(psb_desc_type).
! The communication descriptor associated to the sparse
! matrix A(ilev), stored in baseprecv(ilev)%av(mld_ac_).
! baseprecv(ilev)%iprcparm - integer, dimension(:), allocatable.
! The integer parameters defining the base
! preconditioner K(ilev).
! baseprecv(ilev)%rprcparm - real(psb_spk_), dimension(:), allocatable.
! The real parameters defining the base preconditioner
! K(ilev).
! baseprecv(ilev)%perm - integer, dimension(:), allocatable.
! The row and column permutations applied to the local
! part of A(ilev) (defined only if baseprecv(ilev)%
! iprcparm(mld_sub_ren_)>0).
! baseprecv(ilev)%invperm - integer, dimension(:), allocatable.
! The inverse of the permutation stored in
! baseprecv(ilev)%perm.
! baseprecv(ilev)%mlia - integer, dimension(:), allocatable.
! matrix A(ilev)
! precv(ilev)%map_desc - type(psb_inter_desc_type)
! Stores the linear operators mapping between levels
! (ilev-1) and (ilev). These are the restriction and
! prolongation operators described in the sequel.
! precv(ilev)%iprcparm - integer, dimension(:), allocatable.
! The integer parameters defining the multilevel
! strategy
! precv(ilev)%rprcparm - real(psb_spk_), dimension(:), allocatable.
! The real parameters defining the multilevel strategy
! precv(ilev)%mlia - integer, dimension(:), allocatable.
! The aggregation map (ilev-1) --> (ilev).
! In case of non-smoothed aggregation, it is used
! instead of mld_sm_pr_.
! baseprecv(ilev)%nlaggr - integer, dimension(:), allocatable.
! precv(ilev)%nlaggr - integer, dimension(:), allocatable.
! The number of aggregates (rows of A(ilev)) on the
! various processes.
! baseprecv(ilev)%base_a - type(psb_sspmat_type), pointer.
! precv(ilev)%base_a - type(psb_sspmat_type), pointer.
! Pointer (really a pointer!) to the base matrix of
! the current level, i.e. the local part of A(ilev);
! so we have a unified treatment of residuals. We
! need this to avoid passing explicitly the matrix
! A(ilev) to the routine which applies the
! preconditioner.
! baseprecv(ilev)%base_desc - type(psb_desc_type), pointer.
! precv(ilev)%base_desc - type(psb_desc_type), pointer.
! Pointer to the communication descriptor associated
! to the sparse matrix pointed by base_a.
!
@ -159,10 +136,10 @@
! Note that when the LU factorization of the matrix A(ilev) is computed instead of
! the ILU one, by using UMFPACK or SuperLU, the corresponding L and U factors
! are stored in data structures provided by UMFPACK or SuperLU and pointed by
! baseprecv(ilev)%iprcparm(mld_umf_ptr) or baseprecv(ilev)%iprcparm(mld_slu_ptr),
! precv(ilev)%prec%iprcparm(mld_umf_ptr) or precv(ilev)%prec%iprcparm(mld_slu_ptr),
! respectively.
!
subroutine mld_smlprec_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info)
subroutine mld_smlprec_aply(alpha,precv,x,beta,y,desc_data,trans,work,info)
use psb_base_mod
use mld_inner_mod, mld_protect_name => mld_smlprec_aply
@ -171,7 +148,7 @@ subroutine mld_smlprec_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info)
! Arguments
type(psb_desc_type),intent(in) :: desc_data
type(mld_sbaseprc_type), intent(in) :: baseprecv(:)
type(mld_s_onelev_prec_type), intent(in) :: precv(:)
real(psb_spk_),intent(in) :: alpha,beta
real(psb_spk_),intent(in) :: x(:)
real(psb_spk_),intent(inout) :: y(:)
@ -196,11 +173,11 @@ subroutine mld_smlprec_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info)
if (debug_level >= psb_debug_inner_) &
& write(debug_unit,*) me,' ',trim(name),&
& ' Entry ', size(baseprecv)
& ' Entry ', size(precv)
trans_ = psb_toupper(trans)
select case(baseprecv(2)%iprcparm(mld_ml_type_))
select case(precv(2)%iprcparm(mld_ml_type_))
case(mld_no_ml_)
!
@ -214,7 +191,7 @@ subroutine mld_smlprec_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info)
! Additive multilevel
!
call add_ml_aply(alpha,baseprecv,x,beta,y,desc_data,trans_,work,info)
call add_ml_aply(alpha,precv,x,beta,y,desc_data,trans_,work,info)
case(mld_mult_ml_)
!
@ -225,15 +202,15 @@ subroutine mld_smlprec_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info)
! Note that the transpose switches pre <-> post.
!
select case(baseprecv(2)%iprcparm(mld_smoother_pos_))
select case(precv(2)%iprcparm(mld_smoother_pos_))
case(mld_post_smooth_)
select case (trans_)
case('N')
call mlt_post_ml_aply(alpha,baseprecv,x,beta,y,desc_data,trans_,work,info)
call mlt_post_ml_aply(alpha,precv,x,beta,y,desc_data,trans_,work,info)
case('T','C')
call mlt_pre_ml_aply(alpha,baseprecv,x,beta,y,desc_data,trans_,work,info)
call mlt_pre_ml_aply(alpha,precv,x,beta,y,desc_data,trans_,work,info)
case default
info = 4001
call psb_errpush(info,name,a_err='invalid trans')
@ -244,9 +221,9 @@ subroutine mld_smlprec_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info)
select case (trans_)
case('N')
call mlt_pre_ml_aply(alpha,baseprecv,x,beta,y,desc_data,trans_,work,info)
call mlt_pre_ml_aply(alpha,precv,x,beta,y,desc_data,trans_,work,info)
case('T','C')
call mlt_post_ml_aply(alpha,baseprecv,x,beta,y,desc_data,trans_,work,info)
call mlt_post_ml_aply(alpha,precv,x,beta,y,desc_data,trans_,work,info)
case default
info = 4001
call psb_errpush(info,name,a_err='invalid trans')
@ -255,12 +232,12 @@ subroutine mld_smlprec_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info)
case(mld_twoside_smooth_)
call mlt_twoside_ml_aply(alpha,baseprecv,x,beta,y,desc_data,trans_,work,info)
call mlt_twoside_ml_aply(alpha,precv,x,beta,y,desc_data,trans_,work,info)
case default
info = 4013
call psb_errpush(info,name,a_err='invalid smooth_pos',&
& i_Err=(/baseprecv(2)%iprcparm(mld_smoother_pos_),0,0,0,0/))
& i_Err=(/precv(2)%iprcparm(mld_smoother_pos_),0,0,0,0/))
goto 9999
end select
@ -268,7 +245,7 @@ subroutine mld_smlprec_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info)
case default
info = 4013
call psb_errpush(info,name,a_err='invalid mltype',&
& i_Err=(/baseprecv(2)%iprcparm(mld_ml_type_),0,0,0,0/))
& i_Err=(/precv(2)%iprcparm(mld_ml_type_),0,0,0,0/))
goto 9999
end select
@ -295,7 +272,7 @@ contains
! Y = beta*Y + alpha*op(M^(-1))*X,
! where
! - M is an additive multilevel domain decomposition (Schwarz) preconditioner
! associated to a certain matrix A and stored in the array baseprecv,
! associated to a certain matrix A and stored in the array precv,
! - op(M^(-1)) is M^(-1) or its transpose, according to the value of trans,
! - X and Y are vectors,
! - alpha and beta are scalars.
@ -307,9 +284,9 @@ contains
! level where we might have a replicated index space) and each process takes care
! of one submatrix.
!
! The multilevel preconditioner M is regarded as an array of 'base preconditioners',
! The multilevel preconditioner M is regarded as an array of 'one-level preconditioners',
! each representing the part of the preconditioner associated to a certain level.
! For each level ilev, the base preconditioner K(ilev) is stored in baseprecv(ilev)
! For each level ilev, the base preconditioner K(ilev) is stored in precv(ilev)
! and is associated to a matrix A(ilev), obtained by 'tranferring' the original
! matrix A (i.e. the matrix to be preconditioned) to the level ilev, through smoothed
! aggregation.
@ -357,13 +334,13 @@ contains
!
! 4. Yext = beta*Yext + alpha*Y(1)
!
subroutine add_ml_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info)
subroutine add_ml_aply(alpha,precv,x,beta,y,desc_data,trans,work,info)
implicit none
! Arguments
type(psb_desc_type),intent(in) :: desc_data
type(mld_sbaseprc_type), intent(in) :: baseprecv(:)
type(mld_s_onelev_prec_type), intent(in) :: precv(:)
real(psb_spk_),intent(in) :: alpha,beta
real(psb_spk_),intent(in) :: x(:)
real(psb_spk_),intent(inout) :: y(:)
@ -372,10 +349,9 @@ contains
integer, intent(out) :: info
! Local variables
integer :: n_row,n_col
integer :: ictxt,np,me,i, nr2l,nc2l,err_act
integer :: debug_level, debug_unit
integer :: ismth, nlev, ilev, icm
integer :: nlev, ilev
character(len=20) :: name
type psb_mlprec_wrk_type
@ -394,9 +370,9 @@ contains
if (debug_level >= psb_debug_inner_) &
& write(debug_unit,*) me,' ',trim(name),&
& ' Entry ', size(baseprecv)
& ' Entry ', size(precv)
nlev = size(baseprecv)
nlev = size(precv)
allocate(mlprec_wrk(nlev),stat=info)
if (info /= 0) then
call psb_errpush(4010,name,a_err='Allocate')
@ -419,8 +395,8 @@ contains
mlprec_wrk(1)%x2l(:) = x(:)
mlprec_wrk(1)%y2l(:) = szero
call mld_baseprec_aply(alpha,baseprecv(1),x,beta,y,&
& baseprecv(1)%base_desc,trans,work,info)
call mld_baseprec_aply(alpha,precv(1)%prec,x,beta,y,&
& precv(1)%base_desc,trans,work,info)
if (info /=0) then
call psb_errpush(4010,name,a_err='baseprec_aply')
goto 9999
@ -431,27 +407,21 @@ contains
! For each level except the finest one ...
!
do ilev = 2, nlev
n_row = psb_cd_get_local_rows(baseprecv(ilev-1)%base_desc)
n_col = psb_cd_get_local_cols(baseprecv(ilev-1)%base_desc)
nc2l = psb_cd_get_local_cols(baseprecv(ilev)%base_desc)
nr2l = psb_cd_get_local_rows(baseprecv(ilev)%base_desc)
nc2l = psb_cd_get_local_cols(precv(ilev)%base_desc)
nr2l = psb_cd_get_local_rows(precv(ilev)%base_desc)
allocate(mlprec_wrk(ilev)%x2l(nc2l),mlprec_wrk(ilev)%y2l(nc2l),&
& stat=info)
if (info /= 0) then
info=4025
call psb_errpush(info,name,i_err=(/2*(nc2l+max(n_row,n_col)),0,0,0,0/),&
call psb_errpush(info,name,i_err=(/2*nc2l,0,0,0,0/),&
& a_err='real(psb_spk_)')
goto 9999
end if
ismth = baseprecv(ilev)%iprcparm(mld_aggr_kind_)
icm = baseprecv(ilev)%iprcparm(mld_coarse_mat_)
! Apply prolongator transpose, i.e. restriction
call psb_forward_map(sone,mlprec_wrk(ilev-1)%x2l,&
& szero,mlprec_wrk(ilev)%x2l,&
& baseprecv(ilev)%map_desc,info,work=work)
& precv(ilev)%map_desc,info,work=work)
if (info /=0) then
call psb_errpush(4001,name,a_err='Error during restriction')
@ -461,9 +431,9 @@ contains
!
! Apply the base preconditioner
!
call mld_baseprec_aply(sone,baseprecv(ilev),&
call mld_baseprec_aply(sone,precv(ilev)%prec,&
& mlprec_wrk(ilev)%x2l,szero,mlprec_wrk(ilev)%y2l,&
& baseprecv(ilev)%base_desc, trans,work,info)
& precv(ilev)%base_desc, trans,work,info)
enddo
@ -474,19 +444,15 @@ contains
!
do ilev =nlev,2,-1
n_row = psb_cd_get_local_rows(baseprecv(ilev-1)%base_desc)
n_col = psb_cd_get_local_cols(baseprecv(ilev-1)%base_desc)
nc2l = psb_cd_get_local_cols(baseprecv(ilev)%base_desc)
nr2l = psb_cd_get_local_rows(baseprecv(ilev)%base_desc)
ismth = baseprecv(ilev)%iprcparm(mld_aggr_kind_)
icm = baseprecv(ilev)%iprcparm(mld_coarse_mat_)
nc2l = psb_cd_get_local_cols(precv(ilev)%base_desc)
nr2l = psb_cd_get_local_rows(precv(ilev)%base_desc)
!
! Apply prolongator
!
call psb_backward_map(sone,mlprec_wrk(ilev)%y2l,&
& sone,mlprec_wrk(ilev-1)%y2l,&
& baseprecv(ilev)%map_desc,info,work=work)
& precv(ilev)%map_desc,info,work=work)
if (info /=0) then
call psb_errpush(4001,name,a_err='Error during prolongation')
@ -499,7 +465,7 @@ contains
!
! Compute the output vector Y
!
call psb_geaxpby(alpha,mlprec_wrk(1)%y2l,sone,y,baseprecv(1)%base_desc,info)
call psb_geaxpby(alpha,mlprec_wrk(1)%y2l,sone,y,precv(1)%base_desc,info)
if (info /= 0) then
call psb_errpush(4001,name,a_err='Error on final update')
goto 9999
@ -533,7 +499,7 @@ contains
! Y = beta*Y + alpha*op(M^(-1))*X,
! where
! - M is a hybrid multilevel domain decomposition (Schwarz) preconditioner
! associated to a certain matrix A and stored in the array baseprecv,
! associated to a certain matrix A and stored in the array precv,
! - op(M^(-1)) is M^(-1) or its transpose, according to the value of trans,
! - X and Y are vectors,
! - alpha and beta are scalars.
@ -545,9 +511,9 @@ contains
! level where we might have a replicated index space) and each process takes care
! of one submatrix.
!
! The multilevel preconditioner M is regarded as an array of 'base preconditioners',
! The multilevel preconditioner M is regarded as an array of 'one-level preconditioners',
! each representing the part of the preconditioner associated to a certain level.
! For each level ilev, the base preconditioner K(ilev) is stored in baseprecv(ilev)
! For each level ilev, the base preconditioner K(ilev) is stored in precv(ilev)
! and is associated to a matrix A(ilev), obtained by 'tranferring' the original
! matrix A (i.e. the matrix to be preconditioned) to the level ilev, through smoothed
! aggregation.
@ -603,13 +569,13 @@ contains
! 6. Yext = beta*Yext + alpha*Y(1)
!
!
subroutine mlt_pre_ml_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info)
subroutine mlt_pre_ml_aply(alpha,precv,x,beta,y,desc_data,trans,work,info)
implicit none
! Arguments
type(psb_desc_type),intent(in) :: desc_data
type(mld_sbaseprc_type), intent(in) :: baseprecv(:)
type(mld_s_onelev_prec_type), intent(in) :: precv(:)
real(psb_spk_),intent(in) :: alpha,beta
real(psb_spk_),intent(in) :: x(:)
real(psb_spk_),intent(inout) :: y(:)
@ -618,10 +584,9 @@ contains
integer, intent(out) :: info
! Local variables
integer :: n_row,n_col
integer :: ictxt,np,me,i, nr2l,nc2l,err_act
integer :: debug_level, debug_unit
integer :: ismth, nlev, ilev, icm
integer :: nlev, ilev
character(len=20) :: name
type psb_mlprec_wrk_type
@ -640,9 +605,9 @@ contains
if (debug_level >= psb_debug_inner_) &
& write(debug_unit,*) me,' ',trim(name),&
& ' Entry ', size(baseprecv)
& ' Entry ', size(precv)
nlev = size(baseprecv)
nlev = size(precv)
allocate(mlprec_wrk(nlev),stat=info)
if (info /= 0) then
call psb_errpush(4010,name,a_err='Allocate')
@ -654,8 +619,7 @@ contains
!
! Copy the input vector X
!
n_col = psb_cd_get_local_cols(desc_data)
nc2l = psb_cd_get_local_cols(baseprecv(1)%base_desc)
nc2l = psb_cd_get_local_cols(precv(1)%base_desc)
allocate(mlprec_wrk(1)%x2l(nc2l),mlprec_wrk(1)%y2l(nc2l), &
& mlprec_wrk(1)%tx(nc2l), stat=info)
@ -672,8 +636,8 @@ contains
!
! Apply the base preconditioner at the finest level
!
call mld_baseprec_aply(sone,baseprecv(1),mlprec_wrk(1)%x2l,&
& szero,mlprec_wrk(1)%y2l,baseprecv(1)%base_desc,&
call mld_baseprec_aply(sone,precv(1)%prec,mlprec_wrk(1)%x2l,&
& szero,mlprec_wrk(1)%y2l,precv(1)%base_desc,&
& trans,work,info)
if (info /=0) then
call psb_errpush(4010,name,a_err=' baseprec_aply')
@ -687,8 +651,8 @@ contains
!
mlprec_wrk(1)%tx = mlprec_wrk(1)%x2l
call psb_spmm(-sone,baseprecv(1)%base_a,mlprec_wrk(1)%y2l,&
& sone,mlprec_wrk(1)%tx,baseprecv(1)%base_desc,info,&
call psb_spmm(-sone,precv(1)%base_a,mlprec_wrk(1)%y2l,&
& sone,mlprec_wrk(1)%tx,precv(1)%base_desc,info,&
& work=work,trans=trans)
if (info /=0) then
call psb_errpush(4001,name,a_err=' fine level residual')
@ -702,12 +666,8 @@ contains
!
do ilev = 2, nlev
n_row = psb_cd_get_local_rows(baseprecv(ilev-1)%base_desc)
n_col = psb_cd_get_local_cols(baseprecv(ilev-1)%base_desc)
nc2l = psb_cd_get_local_cols(baseprecv(ilev)%base_desc)
nr2l = psb_cd_get_local_rows(baseprecv(ilev)%base_desc)
ismth = baseprecv(ilev)%iprcparm(mld_aggr_kind_)
icm = baseprecv(ilev)%iprcparm(mld_coarse_mat_)
nc2l = psb_cd_get_local_cols(precv(ilev)%base_desc)
nr2l = psb_cd_get_local_rows(precv(ilev)%base_desc)
allocate(mlprec_wrk(ilev)%tx(nc2l),mlprec_wrk(ilev)%y2l(nc2l),&
& mlprec_wrk(ilev)%x2l(nc2l), stat=info)
@ -721,7 +681,7 @@ contains
! Apply prolongator transpose, i.e. restriction
call psb_forward_map(sone,mlprec_wrk(ilev-1)%tx,&
& szero,mlprec_wrk(ilev)%x2l,&
& baseprecv(ilev)%map_desc,info,work=work)
& precv(ilev)%map_desc,info,work=work)
if (info /=0) then
call psb_errpush(4001,name,a_err='Error during restriction')
@ -731,17 +691,17 @@ contains
!
! Apply the base preconditioner
!
call mld_baseprec_aply(sone,baseprecv(ilev),mlprec_wrk(ilev)%x2l,&
& szero,mlprec_wrk(ilev)%y2l,baseprecv(ilev)%base_desc,trans,work,info)
call mld_baseprec_aply(sone,precv(ilev)%prec,mlprec_wrk(ilev)%x2l,&
& szero,mlprec_wrk(ilev)%y2l,precv(ilev)%base_desc,trans,work,info)
!
! Compute the residual (at all levels but the coarsest one)
!
if (ilev < nlev) then
mlprec_wrk(ilev)%tx = mlprec_wrk(ilev)%x2l
if (info == 0) call psb_spmm(-sone,baseprecv(ilev)%base_a,&
if (info == 0) call psb_spmm(-sone,precv(ilev)%base_a,&
& mlprec_wrk(ilev)%y2l,sone,mlprec_wrk(ilev)%tx,&
& baseprecv(ilev)%base_desc,info,work=work,trans=trans)
& precv(ilev)%base_desc,info,work=work,trans=trans)
endif
if (info /=0) then
call psb_errpush(4001,name,a_err='Error on up sweep residual')
@ -755,16 +715,12 @@ contains
! For each level but the coarsest one ...
!
do ilev = nlev-1, 1, -1
ismth = baseprecv(ilev+1)%iprcparm(mld_aggr_kind_)
n_row = psb_cd_get_local_rows(baseprecv(ilev)%base_desc)
!
! Apply prolongator
!
call psb_backward_map(sone,mlprec_wrk(ilev+1)%y2l,&
& sone,mlprec_wrk(ilev)%y2l,&
& baseprecv(ilev+1)%map_desc,info,work=work)
& precv(ilev+1)%map_desc,info,work=work)
if (info /=0) then
call psb_errpush(4001,name,a_err='Error during prolongation')
@ -778,7 +734,7 @@ contains
! Compute the output vector Y
!
call psb_geaxpby(alpha,mlprec_wrk(1)%y2l,beta,y,&
& baseprecv(1)%base_desc,info)
& precv(1)%base_desc,info)
if (info /=0) then
call psb_errpush(4001,name,a_err='Error on final update')
goto 9999
@ -811,7 +767,7 @@ contains
! Y = beta*Y + alpha*op(M^(-1))*X,
! where
! - M is a hybrid multilevel domain decomposition (Schwarz) preconditioner
! associated to a certain matrix A and stored in the array baseprecv,
! associated to a certain matrix A and stored in the array precv,
! - op(M^(-1)) is M^(-1) or its transpose, according to the value of trans,
! - X and Y are vectors,
! - alpha and beta are scalars.
@ -823,9 +779,9 @@ contains
! level where we might have a replicated index space) and each process takes care
! of one submatrix.
!
! The multilevel preconditioner M is regarded as an array of 'base preconditioners',
! The multilevel preconditioner M is regarded as an array of 'one-level preconditioners',
! each representing the part of the preconditioner associated to a certain level.
! For each level ilev, the base preconditioner K(ilev) is stored in baseprecv(ilev)
! For each level ilev, the base preconditioner K(ilev) is stored in precv(ilev)
! and is associated to a matrix A(ilev), obtained by 'tranferring' the original
! matrix A (i.e. the matrix to be preconditioned) to the level ilev, through smoothed
! aggregation.
@ -872,13 +828,13 @@ contains
! 5. Yext = beta*Yext + alpha*Y(1)
!
!
subroutine mlt_post_ml_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info)
subroutine mlt_post_ml_aply(alpha,precv,x,beta,y,desc_data,trans,work,info)
implicit none
! Arguments
type(psb_desc_type),intent(in) :: desc_data
type(mld_sbaseprc_type), intent(in) :: baseprecv(:)
type(mld_s_onelev_prec_type), intent(in) :: precv(:)
real(psb_spk_),intent(in) :: alpha,beta
real(psb_spk_),intent(in) :: x(:)
real(psb_spk_),intent(inout) :: y(:)
@ -887,10 +843,9 @@ contains
integer, intent(out) :: info
! Local variables
integer :: n_row,n_col
integer :: ictxt,np,me,i, nr2l,nc2l,err_act
integer :: debug_level, debug_unit
integer :: ismth, nlev, ilev, icm
integer :: nlev, ilev
character(len=20) :: name
type psb_mlprec_wrk_type
@ -909,9 +864,9 @@ contains
if (debug_level >= psb_debug_inner_) &
& write(debug_unit,*) me,' ',trim(name),&
& ' Entry ', size(baseprecv)
& ' Entry ', size(precv)
nlev = size(baseprecv)
nlev = size(precv)
allocate(mlprec_wrk(nlev),stat=info)
if (info /= 0) then
call psb_errpush(4010,name,a_err='Allocate')
@ -927,16 +882,21 @@ contains
& write(debug_unit,*) me,' ',trim(name),&
& ' desc_data status',allocated(desc_data%matrix_data)
n_col = psb_cd_get_local_cols(desc_data)
nc2l = psb_cd_get_local_cols(baseprecv(1)%base_desc)
nc2l = psb_cd_get_local_cols(precv(1)%base_desc)
allocate(mlprec_wrk(1)%x2l(nc2l),mlprec_wrk(1)%y2l(nc2l), &
& mlprec_wrk(1)%tx(nc2l), stat=info)
if (info /= 0) then
info=4025
call psb_errpush(info,name,i_err=(/4*nc2l,0,0,0,0/),&
& a_err='real(psb_spk_)')
goto 9999
end if
call psb_geaxpby(sone,x,szero,mlprec_wrk(1)%tx,&
& baseprecv(1)%base_desc,info)
& precv(1)%base_desc,info)
call psb_geaxpby(sone,x,szero,mlprec_wrk(1)%x2l,&
& baseprecv(1)%base_desc,info)
& precv(1)%base_desc,info)
!
! STEP 2
@ -945,18 +905,13 @@ contains
!
do ilev=2, nlev
n_row = psb_cd_get_local_rows(baseprecv(ilev-1)%base_desc)
n_col = psb_cd_get_local_cols(baseprecv(ilev-1)%base_desc)
nc2l = psb_cd_get_local_cols(baseprecv(ilev)%base_desc)
nr2l = psb_cd_get_local_rows(baseprecv(ilev)%base_desc)
ismth = baseprecv(ilev)%iprcparm(mld_aggr_kind_)
icm = baseprecv(ilev)%iprcparm(mld_coarse_mat_)
nc2l = psb_cd_get_local_cols(precv(ilev)%base_desc)
nr2l = psb_cd_get_local_rows(precv(ilev)%base_desc)
if (debug_level >= psb_debug_inner_) &
& write(debug_unit,*) me,' ',trim(name), &
& ' starting up sweep ',&
& ilev,allocated(baseprecv(ilev)%iprcparm),n_row,n_col,&
& nc2l, nr2l,ismth
& ilev,allocated(precv(ilev)%iprcparm),nc2l, nr2l
allocate(mlprec_wrk(ilev)%tx(nc2l),mlprec_wrk(ilev)%y2l(nc2l),&
& mlprec_wrk(ilev)%x2l(nc2l), stat=info)
@ -971,7 +926,7 @@ contains
! Apply prolongator transpose, i.e. restriction
call psb_forward_map(sone,mlprec_wrk(ilev-1)%x2l,&
& szero,mlprec_wrk(ilev)%x2l,&
& baseprecv(ilev)%map_desc,info,work=work)
& precv(ilev)%map_desc,info,work=work)
if (info /=0) then
call psb_errpush(4001,name,a_err='Error during restriction')
@ -982,7 +937,7 @@ contains
! update x2l
!
call psb_geaxpby(sone,mlprec_wrk(ilev)%x2l,szero,mlprec_wrk(ilev)%tx,&
& baseprecv(ilev)%base_desc,info)
& precv(ilev)%base_desc,info)
if (info /= 0) then
call psb_errpush(4001,name,a_err='Error in update')
goto 9999
@ -999,9 +954,8 @@ contains
!
! Apply the base preconditioner at the coarsest level
!
call mld_baseprec_aply(sone,baseprecv(nlev),mlprec_wrk(nlev)%x2l, &
& szero, mlprec_wrk(nlev)%y2l,baseprecv(nlev)%base_desc,trans,work,info)
call mld_baseprec_aply(sone,precv(nlev)%prec,mlprec_wrk(nlev)%x2l, &
& szero, mlprec_wrk(nlev)%y2l,precv(nlev)%base_desc,trans,work,info)
if (info /=0) then
call psb_errpush(4010,name,a_err='baseprec_aply')
goto 9999
@ -1021,15 +975,12 @@ contains
& write(debug_unit,*) me,' ',trim(name),&
& ' starting down sweep',ilev
ismth = baseprecv(ilev+1)%iprcparm(mld_aggr_kind_)
n_row = psb_cd_get_local_rows(baseprecv(ilev)%base_desc)
!
! Apply prolongator
!
call psb_backward_map(sone,mlprec_wrk(ilev+1)%y2l,&
& szero,mlprec_wrk(ilev)%y2l,&
& baseprecv(ilev+1)%map_desc,info,work=work)
& precv(ilev+1)%map_desc,info,work=work)
if (info /=0) then
call psb_errpush(4001,name,a_err='Error during prolongation')
@ -1039,15 +990,16 @@ contains
!
! Compute the residual
!
call psb_spmm(-sone,baseprecv(ilev)%base_a,mlprec_wrk(ilev)%y2l,&
& sone,mlprec_wrk(ilev)%tx,baseprecv(ilev)%base_desc,info,&
call psb_spmm(-sone,precv(ilev)%base_a,mlprec_wrk(ilev)%y2l,&
& sone,mlprec_wrk(ilev)%tx,precv(ilev)%base_desc,info,&
& work=work,trans=trans)
!
! Apply the base preconditioner
!
if (info == 0) call mld_baseprec_aply(sone,baseprecv(ilev),mlprec_wrk(ilev)%tx,&
& sone,mlprec_wrk(ilev)%y2l,baseprecv(ilev)%base_desc,trans,work,info)
if (info == 0) call mld_baseprec_aply(sone,precv(ilev)%prec,&
& mlprec_wrk(ilev)%tx,sone,mlprec_wrk(ilev)%y2l,precv(ilev)%base_desc,&
& trans,work,info)
if (info /=0) then
call psb_errpush(4001,name,a_err=' spmm/baseprec_aply')
goto 9999
@ -1063,7 +1015,7 @@ contains
!
! Compute the output vector Y
!
call psb_geaxpby(alpha,mlprec_wrk(1)%y2l,beta,y,baseprecv(1)%base_desc,info)
call psb_geaxpby(alpha,mlprec_wrk(1)%y2l,beta,y,precv(1)%base_desc,info)
if (info /=0) then
call psb_errpush(4001,name,a_err=' Final update')
@ -1100,7 +1052,7 @@ contains
! where
! - M is a symmetrized hybrid multilevel domain decomposition (Schwarz)
! preconditioner associated to a certain matrix A and stored in the array
! baseprecv,
! precv,
! - op(M^(-1)) is M^(-1) or its transpose, according to the value of trans,
! - X and Y are vectors,
! - alpha and beta are scalars.
@ -1113,9 +1065,9 @@ contains
! level where we might have a replicated index space) and each process takes care
! of one submatrix.
!
! The multilevel preconditioner M is regarded as an array of 'base preconditioners',
! The multilevel preconditioner M is regarded as an array of 'one-level preconditioners',
! each representing the part of the preconditioner associated to a certain level.
! For each level ilev, the base preconditioner K(ilev) is stored in baseprecv(ilev)
! For each level ilev, the base preconditioner K(ilev) is stored in precv(ilev)
! and is associated to a matrix A(ilev), obtained by 'tranferring' the original
! matrix A (i.e. the matrix to be preconditioned) to the level ilev, through smoothed
! aggregation.
@ -1173,13 +1125,13 @@ contains
!
! 6. Yext = beta*Yext + alpha*Y(1)
!
subroutine mlt_twoside_ml_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info)
subroutine mlt_twoside_ml_aply(alpha,precv,x,beta,y,desc_data,trans,work,info)
implicit none
! Arguments
type(psb_desc_type),intent(in) :: desc_data
type(mld_sbaseprc_type), intent(in) :: baseprecv(:)
type(mld_s_onelev_prec_type), intent(in) :: precv(:)
real(psb_spk_),intent(in) :: alpha,beta
real(psb_spk_),intent(in) :: x(:)
real(psb_spk_),intent(inout) :: y(:)
@ -1188,10 +1140,9 @@ contains
integer, intent(out) :: info
! Local variables
integer :: n_row,n_col
integer :: ictxt,np,me,i, nr2l,nc2l,err_act
integer :: debug_level, debug_unit
integer :: ismth, nlev, ilev, icm
integer :: nlev, ilev
character(len=20) :: name
type psb_mlprec_wrk_type
@ -1210,9 +1161,9 @@ contains
if (debug_level >= psb_debug_inner_) &
& write(debug_unit,*) me,' ',trim(name),&
& ' Entry ', size(baseprecv)
& ' Entry ', size(precv)
nlev = size(baseprecv)
nlev = size(precv)
allocate(mlprec_wrk(nlev),stat=info)
if (info /= 0) then
call psb_errpush(4010,name,a_err='Allocate')
@ -1223,8 +1174,7 @@ contains
!
! Copy the input vector X
!
n_col = psb_cd_get_local_cols(desc_data)
nc2l = psb_cd_get_local_cols(baseprecv(1)%base_desc)
nc2l = psb_cd_get_local_cols(precv(1)%base_desc)
allocate(mlprec_wrk(1)%x2l(nc2l),mlprec_wrk(1)%y2l(nc2l), &
& mlprec_wrk(1)%ty(nc2l), mlprec_wrk(1)%tx(nc2l), stat=info)
@ -1237,17 +1187,17 @@ contains
end if
call psb_geaxpby(sone,x,szero,mlprec_wrk(1)%x2l,&
& baseprecv(1)%base_desc,info)
& precv(1)%base_desc,info)
call psb_geaxpby(sone,x,szero,mlprec_wrk(1)%tx,&
& baseprecv(1)%base_desc,info)
& precv(1)%base_desc,info)
!
! STEP 2
!
! Apply the base preconditioner at the finest level
!
call mld_baseprec_aply(sone,baseprecv(1),mlprec_wrk(1)%x2l,&
& szero,mlprec_wrk(1)%y2l,baseprecv(1)%base_desc,&
call mld_baseprec_aply(sone,precv(1)%prec,mlprec_wrk(1)%x2l,&
& szero,mlprec_wrk(1)%y2l,precv(1)%base_desc,&
& trans,work,info)
!
! STEP 3
@ -1255,8 +1205,8 @@ contains
! Compute the residual at the finest level
!
mlprec_wrk(1)%ty = mlprec_wrk(1)%x2l
if (info == 0) call psb_spmm(-sone,baseprecv(1)%base_a,mlprec_wrk(1)%y2l,&
& sone,mlprec_wrk(1)%ty,baseprecv(1)%base_desc,info,&
if (info == 0) call psb_spmm(-sone,precv(1)%base_a,mlprec_wrk(1)%y2l,&
& sone,mlprec_wrk(1)%ty,precv(1)%base_desc,info,&
& work=work,trans=trans)
if (info /=0) then
call psb_errpush(4010,name,a_err='Fine level baseprec/residual')
@ -1270,12 +1220,9 @@ contains
!
do ilev = 2, nlev
n_row = psb_cd_get_local_rows(baseprecv(ilev-1)%base_desc)
n_col = psb_cd_get_local_cols(baseprecv(ilev-1)%base_desc)
nc2l = psb_cd_get_local_cols(baseprecv(ilev)%base_desc)
nr2l = psb_cd_get_local_rows(baseprecv(ilev)%base_desc)
ismth = baseprecv(ilev)%iprcparm(mld_aggr_kind_)
icm = baseprecv(ilev)%iprcparm(mld_coarse_mat_)
nc2l = psb_cd_get_local_cols(precv(ilev)%base_desc)
nr2l = psb_cd_get_local_rows(precv(ilev)%base_desc)
allocate(mlprec_wrk(ilev)%tx(nc2l),mlprec_wrk(ilev)%ty(nc2l),&
& mlprec_wrk(ilev)%y2l(nc2l),mlprec_wrk(ilev)%x2l(nc2l), stat=info)
@ -1289,7 +1236,7 @@ contains
! Apply prolongator transpose, i.e. restriction
call psb_forward_map(sone,mlprec_wrk(ilev-1)%ty,&
& szero,mlprec_wrk(ilev)%x2l,&
& baseprecv(ilev)%map_desc,info,work=work)
& precv(ilev)%map_desc,info,work=work)
if (info /=0) then
call psb_errpush(4001,name,a_err='Error during restriction')
@ -1297,21 +1244,21 @@ contains
end if
call psb_geaxpby(sone,mlprec_wrk(ilev)%x2l,szero,mlprec_wrk(ilev)%tx,&
& baseprecv(ilev)%base_desc,info)
& precv(ilev)%base_desc,info)
!
! Apply the base preconditioner
!
if (info == 0) call mld_baseprec_aply(sone,baseprecv(ilev),&
if (info == 0) call mld_baseprec_aply(sone,precv(ilev)%prec,&
& mlprec_wrk(ilev)%x2l,szero,mlprec_wrk(ilev)%y2l,&
& baseprecv(ilev)%base_desc,trans,work,info)
& precv(ilev)%base_desc,trans,work,info)
!
! Compute the residual (at all levels but the coarsest one)
!
if(ilev < nlev) then
mlprec_wrk(ilev)%ty = mlprec_wrk(ilev)%x2l
if (info == 0) call psb_spmm(-sone,baseprecv(ilev)%base_a,&
if (info == 0) call psb_spmm(-sone,precv(ilev)%base_a,&
& mlprec_wrk(ilev)%y2l,sone,mlprec_wrk(ilev)%ty,&
& baseprecv(ilev)%base_desc,info,work=work,trans=trans)
& precv(ilev)%base_desc,info,work=work,trans=trans)
endif
if (info /=0) then
call psb_errpush(4001,name,a_err='baseprec_aply/residual')
@ -1327,15 +1274,12 @@ contains
!
do ilev=nlev-1, 1, -1
ismth = baseprecv(ilev+1)%iprcparm(mld_aggr_kind_)
n_row = psb_cd_get_local_rows(baseprecv(ilev)%base_desc)
!
! Apply prolongator
!
call psb_backward_map(sone,mlprec_wrk(ilev+1)%y2l,&
& sone,mlprec_wrk(ilev)%y2l,&
& baseprecv(ilev+1)%map_desc,info,work=work)
& precv(ilev+1)%map_desc,info,work=work)
if (info /=0 ) then
call psb_errpush(4001,name,a_err='Error during restriction')
@ -1345,14 +1289,14 @@ contains
!
! Compute the residual
!
call psb_spmm(-sone,baseprecv(ilev)%base_a,mlprec_wrk(ilev)%y2l,&
& sone,mlprec_wrk(ilev)%tx,baseprecv(ilev)%base_desc,info,&
call psb_spmm(-sone,precv(ilev)%base_a,mlprec_wrk(ilev)%y2l,&
& sone,mlprec_wrk(ilev)%tx,precv(ilev)%base_desc,info,&
& work=work,trans=trans)
!
! Apply the base preconditioner
!
if (info == 0) call mld_baseprec_aply(sone,baseprecv(ilev),mlprec_wrk(ilev)%tx,&
& sone,mlprec_wrk(ilev)%y2l,baseprecv(ilev)%base_desc, trans, work,info)
if (info == 0) call mld_baseprec_aply(sone,precv(ilev)%prec,mlprec_wrk(ilev)%tx,&
& sone,mlprec_wrk(ilev)%y2l,precv(ilev)%base_desc, trans, work,info)
if (info /= 0) then
call psb_errpush(4001,name,a_err='Error: residual/baseprec_aply')
goto 9999
@ -1365,7 +1309,7 @@ contains
! Compute the output vector Y
!
call psb_geaxpby(alpha,mlprec_wrk(1)%y2l,beta,y,&
& baseprecv(1)%base_desc,info)
& precv(1)%base_desc,info)
if (info /= 0) then
call psb_errpush(4001,name,a_err='Error final update')

47
mlprec/mld_smlprec_bld.f90
Unescape Escape View File

@ -41,10 +41,11 @@
! Subroutine: mld_smlprec_bld
! Version: real
!
! This routine builds the base preconditioner corresponding to the current
! This routine builds the preconditioner corresponding to the current
! level of the multilevel preconditioner. The routine first builds the
! (coarse) matrix associated to the current level from the (fine) matrix
! associated to the previous level, then builds the related base preconditioner.
! Note that this routine is only ever called on levels >= 2.
!
!
! Arguments:
@ -53,9 +54,9 @@
! matrix to be preconditioned.
! desc_a - type(psb_desc_type), input.
! The communication descriptor of a.
! p - type(mld_sbaseprc_type), input/output.
! The base preconditioner data structure containing the local
! part of the base preconditioner to be built.
! p - type(mld_s_onelev_type), input/output.
! The preconditioner data structure containing the local
! part of the one-level preconditioner to be built.
! info - integer, output.
! Error code.
!
@ -69,7 +70,7 @@ subroutine mld_smlprec_bld(a,desc_a,p,info)
! Arguments
type(psb_sspmat_type), intent(in), target :: a
type(psb_desc_type), intent(in), target :: desc_a
type(mld_sbaseprc_type), intent(inout),target :: p
type(mld_s_onelev_prec_type), intent(inout),target :: p
integer, intent(out) :: info
! Local variables
@ -106,16 +107,16 @@ subroutine mld_smlprec_bld(a,desc_a,p,info)
& mld_max_norm_,is_legal_ml_aggr_eig)
select case(p%iprcparm(mld_sub_solve_))
select case(p%prec%iprcparm(mld_sub_solve_))
case(mld_ilu_n_,mld_milu_n_)
call mld_check_def(p%iprcparm(mld_sub_fillin_),'Level',0,is_legal_ml_lev)
call mld_check_def(p%prec%iprcparm(mld_sub_fillin_),'Level',0,is_legal_ml_lev)
case(mld_ilu_t_)
call mld_check_def(p%rprcparm(mld_sub_iluthrs_),'Eps',szero,is_legal_s_fact_thrs)
call mld_check_def(p%prec%rprcparm(mld_sub_iluthrs_),'Eps',szero,is_legal_s_fact_thrs)
end select
call mld_check_def(p%prec%iprcparm(mld_smoother_sweeps_),'Jacobi sweeps',&
& 1,is_legal_jac_sweeps)
call mld_check_def(p%rprcparm(mld_aggr_omega_val_),'Omega',szero,is_legal_s_omega)
call mld_check_def(p%rprcparm(mld_aggr_thresh_),'Aggr_Thresh',szero,is_legal_s_aggr_thrs)
call mld_check_def(p%iprcparm(mld_smoother_sweeps_),'Jacobi sweeps',&
& 1,is_legal_jac_sweeps)
!
! Build a mapping between the row indices of the fine-level matrix
@ -135,7 +136,7 @@ subroutine mld_smlprec_bld(a,desc_a,p,info)
! the mapping defined by mld_aggrmap_bld and applying the aggregation
! algorithm specified by p%iprcparm(mld_aggr_kind_)
!
call mld_aggrmat_asb(a,desc_a,ac,desc_ac,p,info)
call mld_aggrmat_asb(a,desc_a,p,info)
if(info /= 0) then
call psb_errpush(4010,name,a_err='mld_aggrmat_asb')
goto 9999
@ -144,32 +145,16 @@ subroutine mld_smlprec_bld(a,desc_a,p,info)
!
! Build the 'base preconditioner' corresponding to the coarse level
!
call mld_baseprc_bld(ac,desc_ac,p,info)
call mld_baseprc_bld(p%ac,p%desc_ac,p%prec,info)
if (info /= 0) then
call psb_errpush(4010,name,a_err='mld_baseprc_bld')
goto 9999
end if
!
! We have used a separate ac because
! 1. we want to reuse the same routines mld_ilu_bld, etc.,
! 2. we do NOT want to pass an argument twice to them (p%av(mld_ac_) and p),
! as this would violate the Fortran standard.
! Hence a separate AC and a TRANSFER function at the end.
! Fix the base_a and base_desc pointers for handling of residuals.
! This is correct because this routine is only called at levels >=2.
!
call psb_sp_transfer(ac,p%av(mld_ac_),info)
p%base_a => p%av(mld_ac_)
if (info==0) call psb_cdtransfer(desc_ac,p%desc_ac,info)
p%map_desc = psb_inter_desc(psb_map_aggr_,desc_a,&
& p%desc_ac,p%av(mld_sm_pr_t_),p%av(mld_sm_pr_))
! The two matrices from p%av() have been copied, may free them.
if (info == 0) call psb_sp_free(p%av(mld_sm_pr_t_),info)
if (info == 0) call psb_sp_free(p%av(mld_sm_pr_),info)
if (info /= 0) then
call psb_errpush(4010,name,a_err='psb_cdtransfer')
goto 9999
end if
p%base_a => p%ac
p%base_desc => p%desc_ac
call psb_erractionrestore(err_act)

14
mlprec/mld_sprec_aply.f90
Unescape Escape View File

@ -120,25 +120,25 @@ subroutine mld_sprec_aply(prec,x,y,desc_data,info,trans,work)
end if
if (.not.(allocated(prec%baseprecv))) then
if (.not.(allocated(prec%precv))) then
!! Error 1: should call mld_sprecbld
info=3112
call psb_errpush(info,name)
goto 9999
end if
if (size(prec%baseprecv) >1) then
call mld_mlprec_aply(sone,prec%baseprecv,x,szero,y,desc_data,trans_,work_,info)
if (size(prec%precv) >1) then
call mld_mlprec_aply(sone,prec%precv,x,szero,y,desc_data,trans_,work_,info)
if(info /= 0) then
call psb_errpush(4010,name,a_err='mld_smlprec_aply')
goto 9999
end if
else if (size(prec%baseprecv) == 1) then
call mld_baseprec_aply(sone,prec%baseprecv(1),x,szero,y,desc_data,trans_, work_,info)
else if (size(prec%precv) == 1) then
call mld_baseprec_aply(sone,prec%precv(1)%prec,x,szero,y,desc_data,trans_, work_,info)
else
info = 4013
call psb_errpush(info,name,a_err='Invalid size of baseprecv',&
& i_Err=(/size(prec%baseprecv),0,0,0,0/))
call psb_errpush(info,name,a_err='Invalid size of precv',&
& i_Err=(/size(prec%precv),0,0,0,0/))
goto 9999
endif

75
mlprec/mld_sprecbld.f90
Unescape Escape View File

@ -119,7 +119,7 @@ subroutine mld_sprecbld(a,desc_a,p,info)
!!$ endif
upd_ = 'F'
if (.not.allocated(p%baseprecv)) then
if (.not.allocated(p%precv)) then
!! Error: should have called mld_sprecinit
info=3111
call psb_errpush(info,name)
@ -129,11 +129,11 @@ subroutine mld_sprecbld(a,desc_a,p,info)
!
! Check to ensure all procs have the same
!
iszv = size(p%baseprecv)
iszv = size(p%precv)
call psb_bcast(ictxt,iszv)
if (iszv /= size(p%baseprecv)) then
if (iszv /= size(p%precv)) then
info=4001
call psb_errpush(info,name,a_err='Inconsistent size of baseprecv')
call psb_errpush(info,name,a_err='Inconsistent size of precv')
goto 9999
end if
@ -142,18 +142,20 @@ subroutine mld_sprecbld(a,desc_a,p,info)
! Check on the iprcparm contents: they should be the same
! on all processes.
!
if (me == psb_root_) ipv(:) = p%baseprecv(1)%iprcparm(:)
if (me == psb_root_) ipv(:) = p%precv(1)%iprcparm(:)
call psb_bcast(ictxt,ipv)
if (any(ipv(:) /= p%baseprecv(1)%iprcparm(:) )) then
if (any(ipv(:) /= p%precv(1)%iprcparm(:) )) then
write(debug_unit,*) me,name,&
&': Inconsistent arguments among processes, forcing a default'
p%baseprecv(1)%iprcparm(:) = ipv(:)
p%precv(1)%iprcparm(:) = ipv(:)
end if
!
! Allocate and build the fine level preconditioner
! Finest level first; remember to fix base_a and base_desc
!
call init_baseprc_av(p%baseprecv(1),info)
if (info == 0) call mld_baseprc_bld(a,desc_a,p%baseprecv(1),info,upd_)
call init_baseprc_av(p%precv(1)%prec,info)
if (info == 0) call mld_baseprc_bld(a,desc_a,p%precv(1)%prec,info,upd_)
p%precv(1)%base_a => a
p%precv(1)%base_desc => desc_a
if (info /= 0) then
call psb_errpush(4001,name,a_err='Base level precbuild.')
@ -178,69 +180,69 @@ subroutine mld_sprecbld(a,desc_a,p,info)
! Check on the iprcparm contents: they should be the same
! on all processes.
!
if (me == psb_root_) ipv(:) = p%baseprecv(i)%iprcparm(:)
if (me == psb_root_) ipv(:) = p%precv(i)%iprcparm(:)
call psb_bcast(ictxt,ipv)
if (any(ipv(:) /= p%baseprecv(i)%iprcparm(:) )) then
if (any(ipv(:) /= p%precv(i)%iprcparm(:) )) then
write(debug_unit,*) me,name,&
&': Inconsistent arguments among processes, resetting.'
p%baseprecv(i)%iprcparm(:) = ipv(:)
p%precv(i)%iprcparm(:) = ipv(:)
end if
!
! Allocate the av component of the preconditioner data type
! at level i
! Sanity checks on the parameters
!
if (i<iszv) then
!
! A replicated matrix only makes sense at the coarsest level
!
call mld_check_def(p%baseprecv(i)%iprcparm(mld_coarse_mat_),'Coarse matrix',&
call mld_check_def(p%precv(i)%iprcparm(mld_coarse_mat_),'Coarse matrix',&
& mld_distr_mat_,is_distr_ml_coarse_mat)
else if (i == iszv) then
!
! At the coarsest level, check mld_coarse_solve_
!
val = p%baseprecv(i)%iprcparm(mld_coarse_solve_)
val = p%precv(i)%iprcparm(mld_coarse_solve_)
select case (val)
case(mld_umf_, mld_slu_)
if ((p%baseprecv(i)%iprcparm(mld_coarse_mat_) /= mld_repl_mat_).or.&
& (p%baseprecv(i)%iprcparm(mld_sub_solve_) /= val)) then
if ((p%precv(i)%iprcparm(mld_coarse_mat_) /= mld_repl_mat_).or.&
& (p%precv(i)%prec%iprcparm(mld_sub_solve_) /= val)) then
if (me == 0) write(debug_unit,*)&
& 'Warning: inconsistent coarse level specification.'
if (me == 0) write(debug_unit,*)&
& ' Resetting according to the value specified for mld_coarse_solve_.'
p%baseprecv(i)%iprcparm(mld_coarse_mat_) = mld_repl_mat_
p%baseprecv(i)%iprcparm(mld_sub_solve_) = val
p%baseprecv(i)%iprcparm(mld_smoother_type_) = mld_bjac_
p%precv(i)%iprcparm(mld_coarse_mat_) = mld_repl_mat_
p%precv(i)%prec%iprcparm(mld_sub_solve_) = val
p%precv(i)%prec%iprcparm(mld_smoother_type_) = mld_bjac_
end if
case(mld_sludist_)
if ((p%baseprecv(i)%iprcparm(mld_coarse_mat_) /= mld_distr_mat_).or.&
& (p%baseprecv(i)%iprcparm(mld_sub_solve_) /= val)) then
if ((p%precv(i)%iprcparm(mld_coarse_mat_) /= mld_distr_mat_).or.&
& (p%precv(i)%prec%iprcparm(mld_sub_solve_) /= val)) then
if (me == 0) write(debug_unit,*)&
& 'Warning: inconsistent coarse level specification.'
if (me == 0) write(debug_unit,*)&
& ' Resetting according to the value specified for mld_coarse_solve_.'
p%baseprecv(i)%iprcparm(mld_coarse_mat_) = mld_distr_mat_
p%baseprecv(i)%iprcparm(mld_sub_solve_) = val
p%baseprecv(i)%iprcparm(mld_smoother_type_) = mld_bjac_
p%baseprecv(i)%iprcparm(mld_smoother_sweeps_) = 1
p%precv(i)%iprcparm(mld_coarse_mat_) = mld_distr_mat_
p%precv(i)%prec%iprcparm(mld_sub_solve_) = val
p%precv(i)%prec%iprcparm(mld_smoother_type_) = mld_bjac_
p%precv(i)%prec%iprcparm(mld_smoother_sweeps_) = 1
end if
end select
end if
call init_baseprc_av(p%baseprecv(i),info)
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'Calling mlprcbld at level ',i
!
! Build the base preconditioner corresponding to level i
! Allocate and build the preconditioner at level i.
! baseprec_bld is called inside mlprec_bld.
!
if (info == 0) call mld_mlprec_bld(p%baseprecv(i-1)%base_a,&
& p%baseprecv(i-1)%base_desc, p%baseprecv(i),info)
call init_baseprc_av(p%precv(i)%prec,info)
if (info == 0) call mld_mlprec_bld(p%precv(i-1)%base_a,&
& p%precv(i-1)%base_desc, p%precv(i),info)
if (info /= 0) then
call psb_errpush(4001,name,a_err='Init & build upper level preconditioner')
goto 9999
@ -250,11 +252,14 @@ subroutine mld_sprecbld(a,desc_a,p,info)
& write(debug_unit,*) me,' ',trim(name),&
& 'Return from ',i,' call to mlprcbld ',info
end do
!
! Check on sizes from level 2 onwards
!
if (me==0) then
k = iszv+1
do i=iszv,3,-1
if (all(p%baseprecv(i)%nlaggr == p%baseprecv(i-1)%nlaggr)) then
if (all(p%precv(i)%nlaggr == p%precv(i-1)%nlaggr)) then
k=i-1
end if
end do

8
mlprec/mld_sprecfree.f90
Unescape Escape View File

@ -74,11 +74,11 @@ subroutine mld_sprecfree(p,info)
me=-1
if (allocated(p%baseprecv)) then
do i=1,size(p%baseprecv)
call mld_base_precfree(p%baseprecv(i),info)
if (allocated(p%precv)) then
do i=1,size(p%precv)
call mld_onelev_precfree(p%precv(i),info)
end do
deallocate(p%baseprecv)
deallocate(p%precv)
end if
call psb_erractionrestore(err_act)
return

240
mlprec/mld_sprecinit.F90
Unescape Escape View File

@ -104,7 +104,7 @@ subroutine mld_sprecinit(p,ptype,info,nlev)
character(len=*), parameter :: name='mld_precinit'
info = 0
if (allocated(p%baseprecv)) then
if (allocated(p%precv)) then
call mld_precfree(p,info)
if (info /=0) then
! Do we want to do something?
@ -115,68 +115,88 @@ subroutine mld_sprecinit(p,ptype,info,nlev)
case ('NOPREC')
nlev_ = 1
ilev_ = 1
allocate(p%baseprecv(nlev_),stat=info)
if (info == 0) call psb_realloc(mld_ifpsz_,p%baseprecv(ilev_)%iprcparm,info)
if (info == 0) call psb_realloc(mld_rfpsz_,p%baseprecv(ilev_)%rprcparm,info)
allocate(p%precv(nlev_),stat=info)
if (info == 0) call psb_realloc(mld_ifpsz_,p%precv(ilev_)%iprcparm,info)
if (info == 0) call psb_realloc(mld_rfpsz_,p%precv(ilev_)%rprcparm,info)
if (info == 0) call psb_realloc(mld_ifpsz_,p%precv(ilev_)%prec%iprcparm,info)
if (info == 0) call psb_realloc(mld_rfpsz_,p%precv(ilev_)%prec%rprcparm,info)
if (info /= 0) return
p%baseprecv(ilev_)%iprcparm(:) = 0
p%baseprecv(ilev_)%iprcparm(mld_smoother_type_) = mld_noprec_
p%baseprecv(ilev_)%iprcparm(mld_sub_solve_) = mld_f_none_
p%baseprecv(ilev_)%iprcparm(mld_sub_restr_) = psb_none_
p%baseprecv(ilev_)%iprcparm(mld_sub_prol_) = psb_none_
p%baseprecv(ilev_)%iprcparm(mld_sub_ren_) = 0
p%baseprecv(ilev_)%iprcparm(mld_sub_ovr_) = 0
p%baseprecv(ilev_)%iprcparm(mld_smoother_sweeps_) = 1
p%precv(ilev_)%iprcparm(:) = 0
p%precv(ilev_)%rprcparm(:) = szero
p%precv(ilev_)%prec%iprcparm(:) = 0
p%precv(ilev_)%prec%rprcparm(:) = szero
p%precv(ilev_)%prec%iprcparm(mld_smoother_type_) = mld_noprec_
p%precv(ilev_)%prec%iprcparm(mld_sub_solve_) = mld_f_none_
p%precv(ilev_)%prec%iprcparm(mld_sub_restr_) = psb_none_
p%precv(ilev_)%prec%iprcparm(mld_sub_prol_) = psb_none_
p%precv(ilev_)%prec%iprcparm(mld_sub_ren_) = 0
p%precv(ilev_)%prec%iprcparm(mld_sub_ovr_) = 0
p%precv(ilev_)%prec%iprcparm(mld_smoother_sweeps_) = 1
case ('DIAG')
nlev_ = 1
ilev_ = 1
allocate(p%baseprecv(nlev_),stat=info)
if (info == 0) call psb_realloc(mld_ifpsz_,p%baseprecv(ilev_)%iprcparm,info)
if (info == 0) call psb_realloc(mld_rfpsz_,p%baseprecv(ilev_)%rprcparm,info)
allocate(p%precv(nlev_),stat=info)
if (info == 0) call psb_realloc(mld_ifpsz_,p%precv(ilev_)%iprcparm,info)
if (info == 0) call psb_realloc(mld_rfpsz_,p%precv(ilev_)%rprcparm,info)
if (info == 0) call psb_realloc(mld_ifpsz_,p%precv(ilev_)%prec%iprcparm,info)
if (info == 0) call psb_realloc(mld_rfpsz_,p%precv(ilev_)%prec%rprcparm,info)
if (info /= 0) return
p%baseprecv(ilev_)%iprcparm(:) = 0
p%baseprecv(ilev_)%iprcparm(mld_smoother_type_) = mld_diag_
p%baseprecv(ilev_)%iprcparm(mld_sub_solve_) = mld_f_none_
p%baseprecv(ilev_)%iprcparm(mld_sub_restr_) = psb_none_
p%baseprecv(ilev_)%iprcparm(mld_sub_prol_) = psb_none_
p%baseprecv(ilev_)%iprcparm(mld_sub_ren_) = 0
p%baseprecv(ilev_)%iprcparm(mld_sub_ovr_) = 0
p%baseprecv(ilev_)%iprcparm(mld_smoother_sweeps_) = 1
p%precv(ilev_)%iprcparm(:) = 0
p%precv(ilev_)%rprcparm(:) = szero
p%precv(ilev_)%prec%iprcparm(:) = 0
p%precv(ilev_)%prec%rprcparm(:) = szero
p%precv(ilev_)%prec%iprcparm(mld_smoother_type_) = mld_diag_
p%precv(ilev_)%prec%iprcparm(mld_sub_solve_) = mld_f_none_
p%precv(ilev_)%prec%iprcparm(mld_sub_restr_) = psb_none_
p%precv(ilev_)%prec%iprcparm(mld_sub_prol_) = psb_none_
p%precv(ilev_)%prec%iprcparm(mld_sub_ren_) = 0
p%precv(ilev_)%prec%iprcparm(mld_sub_ovr_) = 0
p%precv(ilev_)%prec%iprcparm(mld_smoother_sweeps_) = 1
case ('BJAC')
nlev_ = 1
ilev_ = 1
allocate(p%baseprecv(nlev_),stat=info)
if (info == 0) call psb_realloc(mld_ifpsz_,p%baseprecv(ilev_)%iprcparm,info)
if (info == 0) call psb_realloc(mld_rfpsz_,p%baseprecv(ilev_)%rprcparm,info)
allocate(p%precv(nlev_),stat=info)
if (info == 0) call psb_realloc(mld_ifpsz_,p%precv(ilev_)%iprcparm,info)
if (info == 0) call psb_realloc(mld_rfpsz_,p%precv(ilev_)%rprcparm,info)
if (info == 0) call psb_realloc(mld_ifpsz_,p%precv(ilev_)%prec%iprcparm,info)
if (info == 0) call psb_realloc(mld_rfpsz_,p%precv(ilev_)%prec%rprcparm,info)
if (info /= 0) return
p%baseprecv(ilev_)%iprcparm(:) = 0
p%baseprecv(ilev_)%iprcparm(mld_smoother_type_) = mld_bjac_
p%baseprecv(ilev_)%iprcparm(mld_sub_solve_) = mld_ilu_n_
p%baseprecv(ilev_)%iprcparm(mld_sub_restr_) = psb_none_
p%baseprecv(ilev_)%iprcparm(mld_sub_prol_) = psb_none_
p%baseprecv(ilev_)%iprcparm(mld_sub_ren_) = 0
p%baseprecv(ilev_)%iprcparm(mld_sub_ovr_) = 0
p%baseprecv(ilev_)%iprcparm(mld_sub_fillin_) = 0
p%baseprecv(ilev_)%iprcparm(mld_smoother_sweeps_) = 1
p%precv(ilev_)%iprcparm(:) = 0
p%precv(ilev_)%rprcparm(:) = szero
p%precv(ilev_)%prec%iprcparm(:) = 0
p%precv(ilev_)%prec%rprcparm(:) = szero
p%precv(ilev_)%prec%iprcparm(mld_smoother_type_) = mld_bjac_
p%precv(ilev_)%prec%iprcparm(mld_sub_solve_) = mld_ilu_n_
p%precv(ilev_)%prec%iprcparm(mld_sub_restr_) = psb_none_
p%precv(ilev_)%prec%iprcparm(mld_sub_prol_) = psb_none_
p%precv(ilev_)%prec%iprcparm(mld_sub_ren_) = 0
p%precv(ilev_)%prec%iprcparm(mld_sub_ovr_) = 0
p%precv(ilev_)%prec%iprcparm(mld_sub_fillin_) = 0
p%precv(ilev_)%prec%iprcparm(mld_smoother_sweeps_) = 1
case ('AS')
nlev_ = 1
ilev_ = 1
allocate(p%baseprecv(nlev_),stat=info)
if (info == 0) call psb_realloc(mld_ifpsz_,p%baseprecv(ilev_)%iprcparm,info)
if (info == 0) call psb_realloc(mld_rfpsz_,p%baseprecv(ilev_)%rprcparm,info)
allocate(p%precv(nlev_),stat=info)
if (info == 0) call psb_realloc(mld_ifpsz_,p%precv(ilev_)%iprcparm,info)
if (info == 0) call psb_realloc(mld_rfpsz_,p%precv(ilev_)%rprcparm,info)
if (info == 0) call psb_realloc(mld_ifpsz_,p%precv(ilev_)%prec%iprcparm,info)
if (info == 0) call psb_realloc(mld_rfpsz_,p%precv(ilev_)%prec%rprcparm,info)
if (info /= 0) return
p%baseprecv(ilev_)%iprcparm(:) = 0
p%baseprecv(ilev_)%iprcparm(mld_smoother_type_) = mld_as_
p%baseprecv(ilev_)%iprcparm(mld_sub_solve_) = mld_ilu_n_
p%baseprecv(ilev_)%iprcparm(mld_sub_restr_) = psb_halo_
p%baseprecv(ilev_)%iprcparm(mld_sub_prol_) = psb_none_
p%baseprecv(ilev_)%iprcparm(mld_sub_ren_) = 0
p%baseprecv(ilev_)%iprcparm(mld_sub_ovr_) = 1
p%baseprecv(ilev_)%iprcparm(mld_sub_fillin_) = 0
p%baseprecv(ilev_)%iprcparm(mld_smoother_sweeps_) = 1
p%precv(ilev_)%iprcparm(:) = 0
p%precv(ilev_)%rprcparm(:) = szero
p%precv(ilev_)%prec%iprcparm(:) = 0
p%precv(ilev_)%prec%rprcparm(:) = szero
p%precv(ilev_)%prec%iprcparm(mld_smoother_type_) = mld_as_
p%precv(ilev_)%prec%iprcparm(mld_sub_solve_) = mld_ilu_n_
p%precv(ilev_)%prec%iprcparm(mld_sub_restr_) = psb_halo_
p%precv(ilev_)%prec%iprcparm(mld_sub_prol_) = psb_none_
p%precv(ilev_)%prec%iprcparm(mld_sub_ren_) = 0
p%precv(ilev_)%prec%iprcparm(mld_sub_ovr_) = 1
p%precv(ilev_)%prec%iprcparm(mld_sub_fillin_) = 0
p%precv(ilev_)%prec%iprcparm(mld_smoother_sweeps_) = 1
case ('ML')
@ -187,74 +207,86 @@ subroutine mld_sprecinit(p,ptype,info,nlev)
nlev_ = 2
end if
ilev_ = 1
allocate(p%baseprecv(nlev_),stat=info)
if (info == 0) call psb_realloc(mld_ifpsz_,p%baseprecv(ilev_)%iprcparm,info)
if (info == 0) call psb_realloc(mld_rfpsz_,p%baseprecv(ilev_)%rprcparm,info)
allocate(p%precv(nlev_),stat=info)
if (info == 0) call psb_realloc(mld_ifpsz_,p%precv(ilev_)%iprcparm,info)
if (info == 0) call psb_realloc(mld_rfpsz_,p%precv(ilev_)%rprcparm,info)
if (info == 0) call psb_realloc(mld_ifpsz_,p%precv(ilev_)%prec%iprcparm,info)
if (info == 0) call psb_realloc(mld_rfpsz_,p%precv(ilev_)%prec%rprcparm,info)
if (info /= 0) return
p%baseprecv(ilev_)%iprcparm(:) = 0
p%baseprecv(ilev_)%rprcparm(:) = szero
p%baseprecv(ilev_)%iprcparm(mld_smoother_type_) = mld_as_
p%baseprecv(ilev_)%iprcparm(mld_sub_solve_) = mld_ilu_n_
p%baseprecv(ilev_)%iprcparm(mld_sub_restr_) = psb_halo_
p%baseprecv(ilev_)%iprcparm(mld_sub_prol_) = psb_none_
p%baseprecv(ilev_)%iprcparm(mld_sub_ren_) = 0
p%baseprecv(ilev_)%iprcparm(mld_sub_ovr_) = 1
p%baseprecv(ilev_)%iprcparm(mld_sub_fillin_) = 0
p%baseprecv(ilev_)%iprcparm(mld_smoother_sweeps_) = 1
p%precv(ilev_)%iprcparm(:) = 0
p%precv(ilev_)%rprcparm(:) = szero
p%precv(ilev_)%prec%iprcparm(:) = 0
p%precv(ilev_)%prec%rprcparm(:) = szero
p%precv(ilev_)%prec%iprcparm(mld_smoother_type_) = mld_as_
p%precv(ilev_)%prec%iprcparm(mld_sub_solve_) = mld_ilu_n_
p%precv(ilev_)%prec%iprcparm(mld_sub_restr_) = psb_halo_
p%precv(ilev_)%prec%iprcparm(mld_sub_prol_) = psb_none_
p%precv(ilev_)%prec%iprcparm(mld_sub_ren_) = 0
p%precv(ilev_)%prec%iprcparm(mld_sub_ovr_) = 1
p%precv(ilev_)%prec%iprcparm(mld_sub_fillin_) = 0
p%precv(ilev_)%prec%iprcparm(mld_smoother_sweeps_) = 1
if (nlev_ == 1) return
do ilev_ = 2, nlev_ -1
if (info == 0) call psb_realloc(mld_ifpsz_,p%baseprecv(ilev_)%iprcparm,info)
if (info == 0) call psb_realloc(mld_rfpsz_,p%baseprecv(ilev_)%rprcparm,info)
if (info == 0) call psb_realloc(mld_ifpsz_,p%precv(ilev_)%iprcparm,info)
if (info == 0) call psb_realloc(mld_rfpsz_,p%precv(ilev_)%rprcparm,info)
if (info == 0) call psb_realloc(mld_ifpsz_,p%precv(ilev_)%prec%iprcparm,info)
if (info == 0) call psb_realloc(mld_rfpsz_,p%precv(ilev_)%prec%rprcparm,info)
if (info /= 0) return
p%baseprecv(ilev_)%iprcparm(:) = 0
p%baseprecv(ilev_)%rprcparm(:) = szero
p%baseprecv(ilev_)%iprcparm(mld_smoother_type_) = mld_as_
p%baseprecv(ilev_)%iprcparm(mld_sub_restr_) = psb_halo_
p%baseprecv(ilev_)%iprcparm(mld_sub_prol_) = psb_none_
p%baseprecv(ilev_)%iprcparm(mld_sub_ren_) = 0
p%baseprecv(ilev_)%iprcparm(mld_sub_ovr_) = 1
p%baseprecv(ilev_)%iprcparm(mld_ml_type_) = mld_mult_ml_
p%baseprecv(ilev_)%iprcparm(mld_aggr_alg_) = mld_dec_aggr_
p%baseprecv(ilev_)%iprcparm(mld_aggr_kind_) = mld_smooth_prol_
p%baseprecv(ilev_)%iprcparm(mld_coarse_mat_) = mld_distr_mat_
p%baseprecv(ilev_)%iprcparm(mld_smoother_pos_) = mld_post_smooth_
p%baseprecv(ilev_)%iprcparm(mld_aggr_omega_alg_) = mld_eig_est_
p%baseprecv(ilev_)%iprcparm(mld_aggr_eig_) = mld_max_norm_
p%baseprecv(ilev_)%iprcparm(mld_sub_solve_) = mld_ilu_n_
p%baseprecv(ilev_)%iprcparm(mld_sub_fillin_) = 0
p%baseprecv(ilev_)%iprcparm(mld_smoother_sweeps_) = 1
p%baseprecv(ilev_)%rprcparm(mld_aggr_omega_val_) = szero
p%baseprecv(ilev_)%rprcparm(mld_aggr_thresh_) = szero
p%precv(ilev_)%iprcparm(:) = 0
p%precv(ilev_)%rprcparm(:) = szero
p%precv(ilev_)%prec%iprcparm(:) = 0
p%precv(ilev_)%prec%rprcparm(:) = szero
p%precv(ilev_)%prec%iprcparm(mld_smoother_type_) = mld_as_
p%precv(ilev_)%prec%iprcparm(mld_sub_restr_) = psb_halo_
p%precv(ilev_)%prec%iprcparm(mld_sub_prol_) = psb_none_
p%precv(ilev_)%prec%iprcparm(mld_sub_ren_) = 0
p%precv(ilev_)%prec%iprcparm(mld_sub_ovr_) = 1
p%precv(ilev_)%prec%iprcparm(mld_sub_solve_) = mld_ilu_n_
p%precv(ilev_)%prec%iprcparm(mld_sub_fillin_) = 0
p%precv(ilev_)%prec%iprcparm(mld_smoother_sweeps_) = 1
p%precv(ilev_)%iprcparm(mld_ml_type_) = mld_mult_ml_
p%precv(ilev_)%iprcparm(mld_aggr_alg_) = mld_dec_aggr_
p%precv(ilev_)%iprcparm(mld_aggr_kind_) = mld_smooth_prol_
p%precv(ilev_)%iprcparm(mld_coarse_mat_) = mld_distr_mat_
p%precv(ilev_)%iprcparm(mld_smoother_pos_) = mld_post_smooth_
p%precv(ilev_)%iprcparm(mld_aggr_omega_alg_) = mld_eig_est_
p%precv(ilev_)%iprcparm(mld_aggr_eig_) = mld_max_norm_
p%precv(ilev_)%rprcparm(mld_aggr_omega_val_) = szero
p%precv(ilev_)%rprcparm(mld_aggr_thresh_) = szero
end do
ilev_ = nlev_
if (info == 0) call psb_realloc(mld_ifpsz_,p%baseprecv(ilev_)%iprcparm,info)
if (info == 0) call psb_realloc(mld_rfpsz_,p%baseprecv(ilev_)%rprcparm,info)
if (info == 0) call psb_realloc(mld_ifpsz_,p%precv(ilev_)%iprcparm,info)
if (info == 0) call psb_realloc(mld_rfpsz_,p%precv(ilev_)%rprcparm,info)
if (info == 0) call psb_realloc(mld_ifpsz_,p%precv(ilev_)%prec%iprcparm,info)
if (info == 0) call psb_realloc(mld_rfpsz_,p%precv(ilev_)%prec%rprcparm,info)
if (info /= 0) return
p%baseprecv(ilev_)%iprcparm(:) = 0
p%baseprecv(ilev_)%rprcparm(:) = szero
p%baseprecv(ilev_)%iprcparm(mld_coarse_solve_) = mld_bjac_
p%precv(ilev_)%iprcparm(:) = 0
p%precv(ilev_)%rprcparm(:) = szero
p%precv(ilev_)%prec%iprcparm(:) = 0
p%precv(ilev_)%prec%rprcparm(:) = szero
p%precv(ilev_)%prec%iprcparm(mld_coarse_solve_) = mld_bjac_
#if defined(HAVE_SLU_)
p%baseprecv(ilev_)%iprcparm(mld_sub_solve_) = mld_slu_
p%precv(ilev_)%prec%iprcparm(mld_sub_solve_) = mld_slu_
#else
p%baseprecv(ilev_)%iprcparm(mld_sub_solve_) = mld_ilu_n_
p%precv(ilev_)%prec%iprcparm(mld_sub_solve_) = mld_ilu_n_
#endif
p%baseprecv(ilev_)%iprcparm(mld_smoother_type_) = mld_bjac_
p%baseprecv(ilev_)%iprcparm(mld_coarse_mat_) = mld_distr_mat_
p%baseprecv(ilev_)%iprcparm(mld_sub_restr_) = psb_none_
p%baseprecv(ilev_)%iprcparm(mld_sub_prol_) = psb_none_
p%baseprecv(ilev_)%iprcparm(mld_sub_ren_) = 0
p%baseprecv(ilev_)%iprcparm(mld_sub_ovr_) = 0
p%baseprecv(ilev_)%iprcparm(mld_ml_type_) = mld_mult_ml_
p%baseprecv(ilev_)%iprcparm(mld_aggr_alg_) = mld_dec_aggr_
p%baseprecv(ilev_)%iprcparm(mld_aggr_kind_) = mld_smooth_prol_
p%baseprecv(ilev_)%iprcparm(mld_smoother_pos_) = mld_post_smooth_
p%baseprecv(ilev_)%iprcparm(mld_aggr_omega_alg_) = mld_eig_est_
p%baseprecv(ilev_)%iprcparm(mld_aggr_eig_) = mld_max_norm_
p%baseprecv(ilev_)%iprcparm(mld_sub_fillin_) = 0
p%baseprecv(ilev_)%iprcparm(mld_smoother_sweeps_) = 4
p%baseprecv(ilev_)%rprcparm(mld_aggr_omega_val_) = szero
p%baseprecv(ilev_)%rprcparm(mld_aggr_thresh_) = szero
p%precv(ilev_)%prec%iprcparm(mld_smoother_type_) = mld_bjac_
p%precv(ilev_)%prec%iprcparm(mld_coarse_mat_) = mld_distr_mat_
p%precv(ilev_)%prec%iprcparm(mld_sub_restr_) = psb_none_
p%precv(ilev_)%prec%iprcparm(mld_sub_prol_) = psb_none_
p%precv(ilev_)%prec%iprcparm(mld_sub_ren_) = 0
p%precv(ilev_)%prec%iprcparm(mld_sub_ovr_) = 0
p%precv(ilev_)%prec%iprcparm(mld_sub_fillin_) = 0
p%precv(ilev_)%prec%iprcparm(mld_smoother_sweeps_) = 4
p%precv(ilev_)%iprcparm(mld_ml_type_) = mld_mult_ml_
p%precv(ilev_)%iprcparm(mld_aggr_alg_) = mld_dec_aggr_
p%precv(ilev_)%iprcparm(mld_aggr_kind_) = mld_smooth_prol_
p%precv(ilev_)%iprcparm(mld_smoother_pos_) = mld_post_smooth_
p%precv(ilev_)%iprcparm(mld_aggr_omega_alg_) = mld_eig_est_
p%precv(ilev_)%iprcparm(mld_aggr_eig_) = mld_max_norm_
p%precv(ilev_)%rprcparm(mld_aggr_omega_val_) = szero
p%precv(ilev_)%rprcparm(mld_aggr_thresh_) = szero
case default
write(0,*) name,': Warning: Unknown preconditioner type request "',ptype,'"'

115
mlprec/mld_sprecset.f90
Unescape Escape View File

@ -69,7 +69,6 @@
! If nlev is not present, the parameter identified by 'what'
! is set at all the appropriate levels.
!
!
! NOTE: currently, the use of the argument ilev is not "safe" and is reserved to
! MLD2P4 developers. Indeed, by using ilev it is possible to set different values
! of the same parameter at different levels 1,...,nlev-1, even in cases where
@ -97,12 +96,12 @@ subroutine mld_sprecseti(p,what,val,info,ilev)
info = 0
if (.not.allocated(p%baseprecv)) then
if (.not.allocated(p%precv)) then
info = 3111
write(0,*) name,': Error: uninitialized preconditioner, should call MLD_PRECINIT'
return
endif
nlev_ = size(p%baseprecv)
nlev_ = size(p%precv)
if (present(ilev)) then
ilev_ = ilev
@ -115,7 +114,13 @@ subroutine mld_sprecseti(p,what,val,info,ilev)
write(0,*) name,': Error: invalid ILEV/NLEV combination',ilev_, nlev_
return
endif
if (.not.allocated(p%baseprecv(ilev_)%iprcparm)) then
if (.not.allocated(p%precv(ilev_)%iprcparm)) then
info = 3111
write(0,*) name,&
&': Error: uninitialized preconditioner component, should call MLD_PRECINIT'
return
endif
if (.not.allocated(p%precv(ilev_)%prec%iprcparm)) then
info = 3111
write(0,*) name,&
&': Error: uninitialized preconditioner component, should call MLD_PRECINIT'
@ -134,7 +139,7 @@ subroutine mld_sprecseti(p,what,val,info,ilev)
select case(what)
case(mld_smoother_type_,mld_sub_solve_,mld_sub_restr_,mld_sub_prol_,&
& mld_sub_ren_,mld_sub_ovr_,mld_sub_fillin_,mld_smoother_sweeps_)
p%baseprecv(ilev_)%iprcparm(what) = val
p%precv(ilev_)%prec%iprcparm(what) = val
case default
write(0,*) name,': Error: invalid WHAT'
info = -2
@ -144,23 +149,25 @@ subroutine mld_sprecseti(p,what,val,info,ilev)
select case(what)
case(mld_smoother_type_,mld_sub_solve_,mld_sub_restr_,mld_sub_prol_,&
& mld_sub_ren_,mld_sub_ovr_,mld_sub_fillin_,&
& mld_smoother_sweeps_,mld_ml_type_,mld_aggr_alg_,mld_aggr_kind_,&
& mld_smoother_sweeps_)
p%precv(ilev_)%prec%iprcparm(what) = val
case(mld_ml_type_,mld_aggr_alg_,mld_aggr_kind_,&
& mld_smoother_pos_,mld_aggr_omega_alg_,mld_aggr_eig_)
p%baseprecv(ilev_)%iprcparm(what) = val
p%precv(ilev_)%iprcparm(what) = val
case(mld_coarse_mat_)
if (ilev_ /= nlev_ .and. val /= mld_distr_mat_) then
write(0,*) name,': Error: Inconsistent specification of WHAT vs. ILEV'
info = -2
return
end if
p%baseprecv(ilev_)%iprcparm(mld_coarse_mat_) = val
p%precv(ilev_)%iprcparm(mld_coarse_mat_) = val
case(mld_coarse_subsolve_)
if (ilev_ /= nlev_) then
write(0,*) name,': Error: Inconsistent specification of WHAT vs. ILEV'
info = -2
return
end if
p%baseprecv(ilev_)%iprcparm(mld_sub_solve_) = val
p%precv(ilev_)%iprcparm(mld_sub_solve_) = val
case(mld_coarse_solve_)
if (ilev_ /= nlev_) then
write(0,*) name,': Error: Inconsistent specification of WHAT vs. ILEV'
@ -169,15 +176,15 @@ subroutine mld_sprecseti(p,what,val,info,ilev)
end if
if (nlev_ > 1) then
p%baseprecv(nlev_)%iprcparm(mld_coarse_solve_) = val
p%baseprecv(nlev_)%iprcparm(mld_smoother_type_) = mld_bjac_
p%baseprecv(nlev_)%iprcparm(mld_coarse_mat_) = mld_distr_mat_
p%precv(nlev_)%iprcparm(mld_coarse_solve_) = val
p%precv(nlev_)%prec%iprcparm(mld_smoother_type_) = mld_bjac_
p%precv(nlev_)%iprcparm(mld_coarse_mat_) = mld_distr_mat_
select case (val)
case(mld_umf_, mld_slu_)
p%baseprecv(nlev_)%iprcparm(mld_coarse_mat_) = mld_repl_mat_
p%baseprecv(nlev_)%iprcparm(mld_sub_solve_) = val
p%precv(nlev_)%iprcparm(mld_coarse_mat_) = mld_repl_mat_
p%precv(nlev_)%prec%iprcparm(mld_sub_solve_) = val
case(mld_sludist_)
p%baseprecv(nlev_)%iprcparm(mld_sub_solve_) = val
p%precv(nlev_)%prec%iprcparm(mld_sub_solve_) = val
end select
endif
case(mld_coarse_sweeps_)
@ -186,14 +193,14 @@ subroutine mld_sprecseti(p,what,val,info,ilev)
info = -2
return
end if
p%baseprecv(ilev_)%iprcparm(mld_smoother_sweeps_) = val
p%precv(ilev_)%prec%iprcparm(mld_smoother_sweeps_) = val
case(mld_coarse_fillin_)
if (ilev_ /= nlev_) then
write(0,*) name,': Error: Inconsistent specification of WHAT vs. ILEV'
info = -2
return
end if
p%baseprecv(ilev_)%iprcparm(mld_sub_fillin_) = val
p%precv(ilev_)%prec%iprcparm(mld_sub_fillin_) = val
case default
write(0,*) name,': Error: invalid WHAT'
info = -2
@ -211,35 +218,35 @@ subroutine mld_sprecseti(p,what,val,info,ilev)
& mld_sub_ren_,mld_sub_ovr_,mld_sub_fillin_,&
& mld_smoother_sweeps_)
do ilev_=1,max(1,nlev_-1)
if (.not.allocated(p%baseprecv(ilev_)%iprcparm)) then
if (.not.allocated(p%precv(ilev_)%iprcparm)) then
write(0,*) name,&
&': Error: uninitialized preconditioner component, should call MLD_PRECINIT'
info = -1
return
endif
p%baseprecv(ilev_)%iprcparm(what) = val
p%precv(ilev_)%prec%iprcparm(what) = val
end do
case(mld_ml_type_,mld_aggr_alg_,mld_aggr_kind_,&
& mld_smoother_pos_,mld_aggr_omega_alg_,mld_aggr_eig_)
do ilev_=2,nlev_
if (.not.allocated(p%baseprecv(ilev_)%iprcparm)) then
if (.not.allocated(p%precv(ilev_)%iprcparm)) then
write(0,*) name,&
&': Error: uninitialized preconditioner component, should call MLD_PRECINIT'
info = -1
return
endif
p%baseprecv(ilev_)%iprcparm(what) = val
p%precv(ilev_)%iprcparm(what) = val
end do
case(mld_coarse_mat_)
if (.not.allocated(p%baseprecv(nlev_)%iprcparm)) then
if (.not.allocated(p%precv(nlev_)%iprcparm)) then
write(0,*) name,&
& ': Error: uninitialized preconditioner component, should call MLD_PRECINIT'
info = -1
return
endif
if (nlev_ > 1) p%baseprecv(nlev_)%iprcparm(mld_coarse_mat_) = val
if (nlev_ > 1) p%precv(nlev_)%iprcparm(mld_coarse_mat_) = val
case(mld_coarse_solve_)
if (.not.allocated(p%baseprecv(nlev_)%iprcparm)) then
if (.not.allocated(p%precv(nlev_)%iprcparm)) then
write(0,*) name,&
&': Error: uninitialized preconditioner component, should call MLD_PRECINIT'
info = -1
@ -247,42 +254,42 @@ subroutine mld_sprecseti(p,what,val,info,ilev)
endif
if (nlev_ > 1) then
p%baseprecv(nlev_)%iprcparm(mld_coarse_solve_) = val
p%baseprecv(nlev_)%iprcparm(mld_smoother_type_) = mld_bjac_
p%baseprecv(nlev_)%iprcparm(mld_coarse_mat_) = mld_distr_mat_
p%precv(nlev_)%iprcparm(mld_coarse_solve_) = val
p%precv(nlev_)%prec%iprcparm(mld_smoother_type_) = mld_bjac_
p%precv(nlev_)%iprcparm(mld_coarse_mat_) = mld_distr_mat_
select case (val)
case(mld_umf_, mld_slu_)
p%baseprecv(nlev_)%iprcparm(mld_coarse_mat_) = mld_repl_mat_
p%baseprecv(nlev_)%iprcparm(mld_sub_solve_) = val
p%precv(nlev_)%iprcparm(mld_coarse_mat_) = mld_repl_mat_
p%precv(nlev_)%prec%iprcparm(mld_sub_solve_) = val
case(mld_sludist_)
p%baseprecv(nlev_)%iprcparm(mld_sub_solve_) = val
p%precv(nlev_)%prec%iprcparm(mld_sub_solve_) = val
end select
endif
case(mld_coarse_subsolve_)
if (.not.allocated(p%baseprecv(nlev_)%iprcparm)) then
if (.not.allocated(p%precv(nlev_)%iprcparm)) then
write(0,*) name,&
&': Error: uninitialized preconditioner component, should call MLD_PRECINIT'
info = -1
return
end if
if (nlev_ > 1) p%baseprecv(nlev_)%iprcparm(mld_sub_solve_) = val
if (nlev_ > 1) p%precv(nlev_)%prec%iprcparm(mld_sub_solve_) = val
case(mld_coarse_sweeps_)
if (.not.allocated(p%baseprecv(nlev_)%iprcparm)) then
if (.not.allocated(p%precv(nlev_)%iprcparm)) then
write(0,*) name,&
&': Error: uninitialized preconditioner component, should call MLD_PRECINIT'
info = -1
return
endif
if (nlev_ > 1) p%baseprecv(nlev_)%iprcparm(mld_smoother_sweeps_) = val
if (nlev_ > 1) p%precv(nlev_)%prec%iprcparm(mld_smoother_sweeps_) = val
case(mld_coarse_fillin_)
if (.not.allocated(p%baseprecv(nlev_)%iprcparm)) then
if (.not.allocated(p%precv(nlev_)%iprcparm)) then
write(0,*) name,&
&': Error: uninitialized preconditioner component, should call MLD_PRECINIT'
info = -1
return
endif
if (nlev_ > 1) p%baseprecv(nlev_)%iprcparm(mld_sub_fillin_) = val
if (nlev_ > 1) p%precv(nlev_)%prec%iprcparm(mld_sub_fillin_) = val
case default
write(0,*) name,': Error: invalid WHAT'
info = -2
@ -353,11 +360,11 @@ subroutine mld_sprecsetc(p,what,string,info,ilev)
info = 0
if (.not.allocated(p%baseprecv)) then
if (.not.allocated(p%precv)) then
info = 3111
return
endif
nlev_ = size(p%baseprecv)
nlev_ = size(p%precv)
if (present(ilev)) then
ilev_ = ilev
@ -370,7 +377,7 @@ subroutine mld_sprecsetc(p,what,string,info,ilev)
info = -1
return
endif
if (.not.allocated(p%baseprecv(ilev_)%iprcparm)) then
if (.not.allocated(p%precv(ilev_)%iprcparm)) then
write(0,*) name,': Error: uninitialized preconditioner component, should call MLD_PRECINIT'
info = 3111
return
@ -449,19 +456,19 @@ subroutine mld_sprecsetr(p,what,val,info,ilev)
ilev_ = 1
end if
if (.not.allocated(p%baseprecv)) then
if (.not.allocated(p%precv)) then
write(0,*) name,': Error: uninitialized preconditioner, should call MLD_PRECINIT'
info = 3111
return
endif
nlev_ = size(p%baseprecv)
nlev_ = size(p%precv)
if ((ilev_<1).or.(ilev_ > nlev_)) then
write(0,*) name,': Error: invalid ILEV/NLEV combination',ilev_, nlev_
info = -1
return
endif
if (.not.allocated(p%baseprecv(ilev_)%rprcparm)) then
if (.not.allocated(p%precv(ilev_)%rprcparm)) then
write(0,*) name,': Error: uninitialized preconditioner component, should call MLD_PRECINIT'
info = 3111
return
@ -478,7 +485,7 @@ subroutine mld_sprecsetr(p,what,val,info,ilev)
!
select case(what)
case(mld_sub_iluthrs_)
p%baseprecv(ilev_)%rprcparm(what) = val
p%precv(ilev_)%prec%rprcparm(what) = val
case default
write(0,*) name,': Error: invalid WHAT'
info = -2
@ -486,8 +493,10 @@ subroutine mld_sprecsetr(p,what,val,info,ilev)
else if (ilev_ > 1) then
select case(what)
case(mld_aggr_omega_val_,mld_aggr_thresh_,mld_sub_iluthrs_)
p%baseprecv(ilev_)%rprcparm(what) = val
case(mld_sub_iluthrs_)
p%precv(ilev_)%prec%rprcparm(what) = val
case(mld_aggr_omega_val_,mld_aggr_thresh_)
p%precv(ilev_)%rprcparm(what) = val
case default
write(0,*) name,': Error: invalid WHAT'
info = -2
@ -502,38 +511,38 @@ subroutine mld_sprecsetr(p,what,val,info,ilev)
select case(what)
case(mld_sub_iluthrs_)
do ilev_=1,nlev_
if (.not.allocated(p%baseprecv(ilev_)%rprcparm)) then
if (.not.allocated(p%precv(ilev_)%rprcparm)) then
write(0,*) name,': Error: uninitialized preconditioner component, should call MLD_PRECINIT'
info = -1
return
endif
p%baseprecv(ilev_)%rprcparm(what) = val
p%precv(ilev_)%prec%rprcparm(what) = val
end do
case(mld_coarse_iluthrs_)
ilev_=nlev_
if (.not.allocated(p%baseprecv(ilev_)%rprcparm)) then
if (.not.allocated(p%precv(ilev_)%rprcparm)) then
write(0,*) name,': Error: uninitialized preconditioner component, should call MLD_PRECINIT'
info = -1
return
endif
p%baseprecv(ilev_)%rprcparm(mld_sub_iluthrs_) = val
p%precv(ilev_)%prec%rprcparm(mld_sub_iluthrs_) = val
case(mld_aggr_omega_val_)
do ilev_=2,nlev_
if (.not.allocated(p%baseprecv(ilev_)%rprcparm)) then
if (.not.allocated(p%precv(ilev_)%rprcparm)) then
write(0,*) name,': Error: uninitialized preconditioner component, should call MLD_PRECINIT'
info = -1
return
endif
p%baseprecv(ilev_)%rprcparm(what) = val
p%precv(ilev_)%rprcparm(what) = val
end do
case(mld_aggr_thresh_)
do ilev_=2,nlev_
if (.not.allocated(p%baseprecv(ilev_)%rprcparm)) then
if (.not.allocated(p%precv(ilev_)%rprcparm)) then
write(0,*) name,': Error: uninitialized preconditioner component, should call MLD_PRECINIT'
info = -1
return
endif
p%baseprecv(ilev_)%rprcparm(what) = val
p%precv(ilev_)%rprcparm(what) = val
end do
case default
write(0,*) name,': Error: invalid WHAT'

25
mlprec/mld_zaggrmat_asb.f90
Unescape Escape View File

@ -52,7 +52,7 @@
! adjacency graph of A_C has been computed by the mld_aggrmap_bld subroutine.
! The prolongator P_C is built here from this mapping, according to the
! value of p%iprcparm(mld_aggr_kind_), specified by the user through
! mld_dprecinit and mld_dprecset.
! mld_zprecinit and mld_zprecset.
!
! Currently three different prolongators are implemented, corresponding to
! three aggregation algorithms:
@ -76,24 +76,21 @@
! 1181-1196.
!
!
!
! Arguments:
! a - type(psb_zspmat_type), input.
! The sparse matrix structure containing the local part of
! the fine-level matrix.
! desc_a - type(psb_desc_type), input.
! The communication descriptor of the fine-level matrix.
! ac - type(psb_zspmat_type), output.
! The sparse matrix structure containing the local part of
! the coarse-level matrix.
! desc_ac - type(psb_desc_type), output.
! The communication descriptor of the coarse-level matrix.
! p - type(mld_zbaseprc_type), input/output.
! The base preconditioner data structure containing the local
! part of the base preconditioner to be built.
! p - type(mld_z_onelev_prec_type), input/output.
! The one-level preconditioner data structure containing the local
! part of the base preconditioner to be built as well as the
! aggregate matrices.
! info - integer, output.
! Error code.
!
subroutine mld_zaggrmat_asb(a,desc_a,ac,desc_ac,p,info)
subroutine mld_zaggrmat_asb(a,desc_a,p,info)
use psb_base_mod
use mld_inner_mod, mld_protect_name => mld_zaggrmat_asb
@ -103,9 +100,7 @@ subroutine mld_zaggrmat_asb(a,desc_a,ac,desc_ac,p,info)
! Arguments
type(psb_zspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_a
type(psb_zspmat_type), intent(out) :: ac
type(psb_desc_type), intent(out) :: desc_ac
type(mld_zbaseprc_type), intent(inout), target :: p
type(mld_z_onelev_prec_type), intent(inout), target :: p
integer, intent(out) :: info
! Local variables
@ -125,7 +120,7 @@ subroutine mld_zaggrmat_asb(a,desc_a,ac,desc_ac,p,info)
select case (p%iprcparm(mld_aggr_kind_))
case (mld_no_smooth_)
call mld_aggrmat_raw_asb(a,desc_a,ac,desc_ac,p,info)
call mld_aggrmat_raw_asb(a,desc_a,p,info)
if(info /= 0) then
call psb_errpush(4010,name,a_err='mld_aggrmat_raw_asb')
goto 9999
@ -133,7 +128,7 @@ subroutine mld_zaggrmat_asb(a,desc_a,ac,desc_ac,p,info)
case(mld_smooth_prol_,mld_biz_prol_)
call mld_aggrmat_smth_asb(a,desc_a,ac,desc_ac,p,info)
call mld_aggrmat_smth_asb(a,desc_a,p,info)
if(info /= 0) then
call psb_errpush(4010,name,a_err='mld_aggrmat_smth_asb')
goto 9999

74
mlprec/mld_zaggrmat_raw_asb.F90
Unescape Escape View File

@ -51,7 +51,7 @@
!
! The coarse-level matrix A_C is distributed among the parallel processes or
! replicated on each of them, according to the value of p%iprcparm(mld_coarse_mat_),
! specified by the user through mld_dprecinit and mld_dprecset.
! specified by the user through mld_zprecinit and mld_zprecset.
!
! For details see
! P. D'Ambra, D. di Serafino and S. Filippone, On the development of
@ -59,24 +59,21 @@
! 57 (2007), 1181-1196.
!
!
!
! Arguments:
! a - type(psb_zspmat_type), input.
! The sparse matrix structure containing the local part of
! the fine-level matrix.
! desc_a - type(psb_desc_type), input.
! The communication descriptor of the fine-level matrix.
! ac - type(psb_zspmat_type), output.
! The sparse matrix structure containing the local part of
! the coarse-level matrix.
! desc_ac - type(psb_desc_type), output.
! The communication descriptor of the coarse-level matrix.
! p - type(mld_zbaseprc_type), input/output.
! The base preconditioner data structure containing the local
! part of the base preconditioner to be built.
! p - type(mld_z_onelev_prec_type), input/output.
! The one-level preconditioner data structure containing the local
! part of the base preconditioner to be built as well as the
! aggregate matrices.
! info - integer, output.
! Error code.
!
subroutine mld_zaggrmat_raw_asb(a,desc_a,ac,desc_ac,p,info)
subroutine mld_zaggrmat_raw_asb(a,desc_a,p,info)
use psb_base_mod
use mld_inner_mod, mld_protect_name => mld_zaggrmat_raw_asb
@ -91,17 +88,15 @@ subroutine mld_zaggrmat_raw_asb(a,desc_a,ac,desc_ac,p,info)
! Arguments
type(psb_zspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_a
type(psb_zspmat_type), intent(out) :: ac
type(psb_desc_type), intent(out) :: desc_ac
type(mld_zbaseprc_type), intent(inout), target :: p
type(mld_z_onelev_prec_type), intent(inout), target :: p
integer, intent(out) :: info
! Local variables
integer ::ictxt,np,me, err_act, icomm
character(len=20) :: name
type(psb_zspmat_type) :: b
integer, pointer :: nzbr(:), idisp(:)
type(psb_zspmat_type), pointer :: am1,am2
integer, allocatable :: nzbr(:), idisp(:)
type(psb_zspmat_type) :: am1,am2
integer :: nrow, nglob, ncol, ntaggr, nzac, ip, ndx,&
& naggr, nzt,naggrm1, i
@ -119,9 +114,6 @@ subroutine mld_zaggrmat_raw_asb(a,desc_a,ac,desc_ac,p,info)
nrow = psb_cd_get_local_rows(desc_a)
ncol = psb_cd_get_local_cols(desc_a)
am2 => p%av(mld_sm_pr_t_)
am1 => p%av(mld_sm_pr_)
call psb_nullify_sp(am1)
call psb_nullify_sp(am2)
@ -195,7 +187,7 @@ subroutine mld_zaggrmat_raw_asb(a,desc_a,ac,desc_ac,p,info)
if (p%iprcparm(mld_coarse_mat_) == mld_repl_mat_) then
call psb_cdall(ictxt,desc_ac,info,mg=ntaggr,repl=.true.)
call psb_cdall(ictxt,p%desc_ac,info,mg=ntaggr,repl=.true.)
if(info /= 0) then
call psb_errpush(4010,name,a_err='psb_cdall')
goto 9999
@ -206,7 +198,7 @@ subroutine mld_zaggrmat_raw_asb(a,desc_a,ac,desc_ac,p,info)
call psb_sum(ictxt,nzbr(1:np))
nzac = sum(nzbr)
call psb_sp_all(ntaggr,ntaggr,ac,nzac,info)
call psb_sp_all(ntaggr,ntaggr,p%ac,nzac,info)
if(info /= 0) then
call psb_errpush(4010,name,a_err='sp_all')
goto 9999
@ -217,11 +209,11 @@ subroutine mld_zaggrmat_raw_asb(a,desc_a,ac,desc_ac,p,info)
enddo
ndx = nzbr(me+1)
call mpi_allgatherv(b%aspk,ndx,mpi_double_complex,ac%aspk,nzbr,idisp,&
call mpi_allgatherv(b%aspk,ndx,mpi_double_complex,p%ac%aspk,nzbr,idisp,&
& mpi_double_complex,icomm,info)
call mpi_allgatherv(b%ia1,ndx,mpi_integer,ac%ia1,nzbr,idisp,&
call mpi_allgatherv(b%ia1,ndx,mpi_integer,p%ac%ia1,nzbr,idisp,&
& mpi_integer,icomm,info)
call mpi_allgatherv(b%ia2,ndx,mpi_integer,ac%ia2,nzbr,idisp,&
call mpi_allgatherv(b%ia2,ndx,mpi_integer,p%ac%ia2,nzbr,idisp,&
& mpi_integer,icomm,info)
if(info /= 0) then
info=-1
@ -229,12 +221,12 @@ subroutine mld_zaggrmat_raw_asb(a,desc_a,ac,desc_ac,p,info)
goto 9999
end if
ac%m = ntaggr
ac%k = ntaggr
ac%infoa(psb_nnz_) = nzac
ac%fida='COO'
ac%descra='GUN'
call psb_spcnv(ac,info,afmt='coo',dupl=psb_dupl_add_)
p%ac%m = ntaggr
p%ac%k = ntaggr
p%ac%infoa(psb_nnz_) = nzac
p%ac%fida='COO'
p%ac%descra='GUN'
call psb_spcnv(p%ac,info,afmt='coo',dupl=psb_dupl_add_)
if(info /= 0) then
call psb_errpush(4010,name,a_err='sp_free')
goto 9999
@ -242,9 +234,9 @@ subroutine mld_zaggrmat_raw_asb(a,desc_a,ac,desc_ac,p,info)
else if (p%iprcparm(mld_coarse_mat_) == mld_distr_mat_) then
call psb_cdall(ictxt,desc_ac,info,nl=naggr)
if (info == 0) call psb_cdasb(desc_ac,info)
if (info == 0) call psb_sp_clone(b,ac,info)
call psb_cdall(ictxt,p%desc_ac,info,nl=naggr)
if (info == 0) call psb_cdasb(p%desc_ac,info)
if (info == 0) call psb_sp_clone(b,p%ac,info)
if(info /= 0) then
call psb_errpush(4001,name,a_err='Build ac, desc_ac')
goto 9999
@ -263,9 +255,23 @@ subroutine mld_zaggrmat_raw_asb(a,desc_a,ac,desc_ac,p,info)
deallocate(nzbr,idisp)
call psb_spcnv(ac,info,afmt='csr',dupl=psb_dupl_add_)
call psb_spcnv(p%ac,info,afmt='csr',dupl=psb_dupl_add_)
if(info /= 0) then
call psb_errpush(4010,name,a_err='spcnv')
goto 9999
end if
!
! Copy the prolongation/restriction matrices into the descriptor map.
! am2 => PR^T i.e. restriction operator
! am1 => PR i.e. prolongation operator
!
p%map_desc = psb_inter_desc(psb_map_aggr_,desc_a,&
& p%desc_ac,am2,am1)
if (info == 0) call psb_sp_free(am1,info)
if (info == 0) call psb_sp_free(am2,info)
if(info /= 0) then
call psb_errpush(4010,name,a_err='ipcoo2csr')
call psb_errpush(4010,name,a_err='sp_Free')
goto 9999
end if

128
mlprec/mld_zaggrmat_smth_asb.F90
Unescape Escape View File

@ -83,18 +83,14 @@
! the fine-level matrix.
! desc_a - type(psb_desc_type), input.
! The communication descriptor of the fine-level matrix.
! ac - type(psb_zspmat_type), output.
! The sparse matrix structure containing the local part of
! the coarse-level matrix.
! desc_ac - type(psb_desc_type), output.
! The communication descriptor of the coarse-level matrix.
! p - type(mld_zbaseprc_type), input/output.
! The base preconditioner data structure containing the local
! part of the base preconditioner to be built.
! p - type(mld_z_onelev_prec_type), input/output.
! The one-level preconditioner data structure containing the local
! part of the base preconditioner to be built as well as the
! aggregate matrices.
! info - integer, output.
! Error code.
!
subroutine mld_zaggrmat_smth_asb(a,desc_a,ac,desc_ac,p,info)
subroutine mld_zaggrmat_smth_asb(a,desc_a,p,info)
use psb_base_mod
use mld_inner_mod, mld_protect_name => mld_zaggrmat_smth_asb
@ -109,19 +105,17 @@ subroutine mld_zaggrmat_smth_asb(a,desc_a,ac,desc_ac,p,info)
! Arguments
type(psb_zspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_a
type(psb_zspmat_type), intent(out) :: ac
type(psb_desc_type), intent(out) :: desc_ac
type(mld_zbaseprc_type), intent(inout), target :: p
type(mld_z_onelev_prec_type), intent(inout), target :: p
integer, intent(out) :: info
! Local variables
type(psb_zspmat_type) :: b
integer, pointer :: nzbr(:), idisp(:)
integer, allocatable :: nzbr(:), idisp(:)
integer :: nrow, nglob, ncol, ntaggr, nzac, ip, ndx,&
& naggr, nzl,naggrm1,naggrp1, i, j, k
integer ::ictxt,np,me, err_act, icomm
character(len=20) :: name
type(psb_zspmat_type), pointer :: am1,am2
type(psb_zspmat_type) :: am1,am2
type(psb_zspmat_type) :: am3,am4
complex(psb_dpk_), allocatable :: adiag(:)
logical :: ml_global_nmb
@ -146,9 +140,6 @@ subroutine mld_zaggrmat_smth_asb(a,desc_a,ac,desc_ac,p,info)
call psb_nullify_sp(b)
call psb_nullify_sp(am3)
call psb_nullify_sp(am4)
am2 => p%av(mld_sm_pr_t_)
am1 => p%av(mld_sm_pr_)
call psb_nullify_sp(am1)
call psb_nullify_sp(am2)
@ -191,7 +182,7 @@ subroutine mld_zaggrmat_smth_asb(a,desc_a,ac,desc_ac,p,info)
if (info /= 0) then
info=4025
call psb_errpush(info,name,i_err=(/nrow,0,0,0,0/),&
& a_err='real(psb_dpk_)')
& a_err='complex(psb_dpk_)')
goto 9999
end if
@ -456,16 +447,16 @@ subroutine mld_zaggrmat_smth_asb(a,desc_a,ac,desc_ac,p,info)
case(mld_distr_mat_)
call psb_sp_clone(b,ac,info)
nzac = ac%infoa(psb_nnz_)
nzl = ac%infoa(psb_nnz_)
if (info == 0) call psb_cdall(ictxt,desc_ac,info,nl=p%nlaggr(me+1))
if (info == 0) call psb_cdins(nzl,ac%ia1,ac%ia2,desc_ac,info)
if (info == 0) call psb_cdasb(desc_ac,info)
if (info == 0) call psb_glob_to_loc(ac%ia1(1:nzl),desc_ac,info,iact='I')
if (info == 0) call psb_glob_to_loc(ac%ia2(1:nzl),desc_ac,info,iact='I')
call psb_sp_clone(b,p%ac,info)
nzac = p%ac%infoa(psb_nnz_)
nzl = p%ac%infoa(psb_nnz_)
if (info == 0) call psb_cdall(ictxt,p%desc_ac,info,nl=p%nlaggr(me+1))
if (info == 0) call psb_cdins(nzl,p%ac%ia1,p%ac%ia2,p%desc_ac,info)
if (info == 0) call psb_cdasb(p%desc_ac,info)
if (info == 0) call psb_glob_to_loc(p%ac%ia1(1:nzl),p%desc_ac,info,iact='I')
if (info == 0) call psb_glob_to_loc(p%ac%ia2(1:nzl),p%desc_ac,info,iact='I')
if (info /= 0) then
call psb_errpush(4001,name,a_err='Creating desc_ac and converting ac')
call psb_errpush(4001,name,a_err='Creating p%desc_ac and converting ac')
goto 9999
end if
if (debug_level >= psb_debug_outer_) &
@ -473,10 +464,10 @@ subroutine mld_zaggrmat_smth_asb(a,desc_a,ac,desc_ac,p,info)
& 'Assembld aux descr. distr.'
ac%m=desc_ac%matrix_data(psb_n_row_)
ac%k=desc_ac%matrix_data(psb_n_col_)
ac%fida='COO'
ac%descra='GUN'
p%ac%m=psb_cd_get_local_rows(p%desc_ac)
p%ac%k=psb_cd_get_local_cols(p%desc_ac)
p%ac%fida='COO'
p%ac%descra='GUN'
call psb_sp_free(b,info)
if (info == 0) deallocate(nzbr,idisp,stat=info)
@ -487,25 +478,25 @@ subroutine mld_zaggrmat_smth_asb(a,desc_a,ac,desc_ac,p,info)
if (np>1) then
nzl = psb_sp_get_nnzeros(am1)
call psb_glob_to_loc(am1%ia1(1:nzl),desc_ac,info,'I')
call psb_glob_to_loc(am1%ia1(1:nzl),p%desc_ac,info,'I')
if(info /= 0) then
call psb_errpush(4010,name,a_err='psb_glob_to_loc')
goto 9999
end if
endif
am1%k=desc_ac%matrix_data(psb_n_col_)
am1%k=psb_cd_get_local_cols(p%desc_ac)
if (np>1) then
call psb_spcnv(am2,info,afmt='coo',dupl=psb_dupl_add_)
nzl = am2%infoa(psb_nnz_)
if (info == 0) call psb_glob_to_loc(am2%ia1(1:nzl),desc_ac,info,'I')
if (info == 0) call psb_glob_to_loc(am2%ia1(1:nzl),p%desc_ac,info,'I')
if (info == 0) call psb_spcnv(am2,info,afmt='csr',dupl=psb_dupl_add_)
if(info /= 0) then
call psb_errpush(4001,name,a_err='Converting am2 to local')
goto 9999
end if
end if
am2%m=desc_ac%matrix_data(psb_n_col_)
am2%m=psb_cd_get_local_cols(p%desc_ac)
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
@ -514,13 +505,13 @@ subroutine mld_zaggrmat_smth_asb(a,desc_a,ac,desc_ac,p,info)
case(mld_repl_mat_)
!
!
call psb_cdall(ictxt,desc_ac,info,mg=ntaggr,repl=.true.)
call psb_cdall(ictxt,p%desc_ac,info,mg=ntaggr,repl=.true.)
nzbr(:) = 0
nzbr(me+1) = b%infoa(psb_nnz_)
call psb_sum(ictxt,nzbr(1:np))
nzac = sum(nzbr)
if (info == 0) call psb_sp_all(ntaggr,ntaggr,ac,nzac,info)
if (info == 0) call psb_sp_all(ntaggr,ntaggr,p%ac,nzac,info)
if (info /= 0) goto 9999
do ip=1,np
@ -528,11 +519,11 @@ subroutine mld_zaggrmat_smth_asb(a,desc_a,ac,desc_ac,p,info)
enddo
ndx = nzbr(me+1)
call mpi_allgatherv(b%aspk,ndx,mpi_double_complex,ac%aspk,nzbr,idisp,&
call mpi_allgatherv(b%aspk,ndx,mpi_double_complex,p%ac%aspk,nzbr,idisp,&
& mpi_double_complex,icomm,info)
if (info == 0) call mpi_allgatherv(b%ia1,ndx,mpi_integer,ac%ia1,nzbr,idisp,&
if (info == 0) call mpi_allgatherv(b%ia1,ndx,mpi_integer,p%ac%ia1,nzbr,idisp,&
& mpi_integer,icomm,info)
if (info == 0) call mpi_allgatherv(b%ia2,ndx,mpi_integer,ac%ia2,nzbr,idisp,&
if (info == 0) call mpi_allgatherv(b%ia2,ndx,mpi_integer,p%ac%ia2,nzbr,idisp,&
& mpi_integer,icomm,info)
if (info /= 0) then
@ -540,12 +531,12 @@ subroutine mld_zaggrmat_smth_asb(a,desc_a,ac,desc_ac,p,info)
goto 9999
end if
ac%m = ntaggr
ac%k = ntaggr
ac%infoa(psb_nnz_) = nzac
ac%fida='COO'
ac%descra='GUN'
call psb_spcnv(ac,info,afmt='coo',dupl=psb_dupl_add_)
p%ac%m = ntaggr
p%ac%k = ntaggr
p%ac%infoa(psb_nnz_) = nzac
p%ac%fida='COO'
p%ac%descra='GUN'
call psb_spcnv(p%ac,info,afmt='coo',dupl=psb_dupl_add_)
if(info /= 0) goto 9999
call psb_sp_free(b,info)
if(info /= 0) goto 9999
@ -569,9 +560,9 @@ subroutine mld_zaggrmat_smth_asb(a,desc_a,ac,desc_ac,p,info)
case(mld_distr_mat_)
call psb_sp_clone(b,ac,info)
if (info == 0) call psb_cdall(ictxt,desc_ac,info,nl=naggr)
if (info == 0) call psb_cdasb(desc_ac,info)
call psb_sp_clone(b,p%ac,info)
if (info == 0) call psb_cdall(ictxt,p%desc_ac,info,nl=naggr)
if (info == 0) call psb_cdasb(p%desc_ac,info)
if (info == 0) call psb_sp_free(b,info)
if (info /= 0) then
call psb_errpush(4010,name,a_err='Build desc_ac, ac')
@ -582,7 +573,7 @@ subroutine mld_zaggrmat_smth_asb(a,desc_a,ac,desc_ac,p,info)
case(mld_repl_mat_)
!
!
call psb_cdall(ictxt,desc_ac,info,mg=ntaggr,repl=.true.)
call psb_cdall(ictxt,p%desc_ac,info,mg=ntaggr,repl=.true.)
if(info /= 0) then
call psb_errpush(4010,name,a_err='psb_cdall')
goto 9999
@ -592,7 +583,7 @@ subroutine mld_zaggrmat_smth_asb(a,desc_a,ac,desc_ac,p,info)
nzbr(me+1) = b%infoa(psb_nnz_)
call psb_sum(ictxt,nzbr(1:np))
nzac = sum(nzbr)
call psb_sp_all(ntaggr,ntaggr,ac,nzac,info)
call psb_sp_all(ntaggr,ntaggr,p%ac,nzac,info)
if(info /= 0) then
call psb_errpush(4010,name,a_err='psb_sp_all')
goto 9999
@ -603,11 +594,11 @@ subroutine mld_zaggrmat_smth_asb(a,desc_a,ac,desc_ac,p,info)
enddo
ndx = nzbr(me+1)
call mpi_allgatherv(b%aspk,ndx,mpi_double_complex,ac%aspk,nzbr,idisp,&
call mpi_allgatherv(b%aspk,ndx,mpi_double_complex,p%ac%aspk,nzbr,idisp,&
& mpi_double_complex,icomm,info)
if (info == 0) call mpi_allgatherv(b%ia1,ndx,mpi_integer,ac%ia1,nzbr,idisp,&
if (info == 0) call mpi_allgatherv(b%ia1,ndx,mpi_integer,p%ac%ia1,nzbr,idisp,&
& mpi_integer,icomm,info)
if (info == 0) call mpi_allgatherv(b%ia2,ndx,mpi_integer,ac%ia2,nzbr,idisp,&
if (info == 0) call mpi_allgatherv(b%ia2,ndx,mpi_integer,p%ac%ia2,nzbr,idisp,&
& mpi_integer,icomm,info)
if (info /= 0) then
call psb_errpush(4001,name,a_err=' from mpi_allgatherv')
@ -615,12 +606,12 @@ subroutine mld_zaggrmat_smth_asb(a,desc_a,ac,desc_ac,p,info)
end if
ac%m = ntaggr
ac%k = ntaggr
ac%infoa(psb_nnz_) = nzac
ac%fida='COO'
ac%descra='GUN'
call psb_spcnv(ac,info,afmt='coo',dupl=psb_dupl_add_)
p%ac%m = ntaggr
p%ac%k = ntaggr
p%ac%infoa(psb_nnz_) = nzac
p%ac%fida='COO'
p%ac%descra='GUN'
call psb_spcnv(p%ac,info,afmt='coo',dupl=psb_dupl_add_)
if(info /= 0) then
call psb_errpush(4010,name,a_err='spcnv')
goto 9999
@ -651,12 +642,27 @@ subroutine mld_zaggrmat_smth_asb(a,desc_a,ac,desc_ac,p,info)
end select
call psb_spcnv(ac,info,afmt='csr',dupl=psb_dupl_add_)
call psb_spcnv(p%ac,info,afmt='csr',dupl=psb_dupl_add_)
if(info /= 0) then
call psb_errpush(4010,name,a_err='spcnv')
goto 9999
end if
!
! Copy the prolongation/restriction matrices into the descriptor map.
! am2 => PR^T i.e. restriction operator
! am1 => PR i.e. prolongation operator
!
p%map_desc = psb_inter_desc(psb_map_aggr_,desc_a,&
& p%desc_ac,am2,am1)
if (info == 0) call psb_sp_free(am1,info)
if (info == 0) call psb_sp_free(am2,info)
if(info /= 0) then
call psb_errpush(4010,name,a_err='sp_Free')
goto 9999
end if
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'Done smooth_aggregate '

2
mlprec/mld_zbaseprec_bld.f90
Unescape Escape View File

@ -197,8 +197,6 @@ subroutine mld_zbaseprc_bld(a,desc_a,p,info,upd)
end select
p%base_a => a
p%base_desc => desc_a
p%iprcparm(mld_prec_status_) = mld_prec_built_
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),': Done'

364
mlprec/mld_zmlprec_aply.f90
Unescape Escape View File

@ -46,7 +46,7 @@
! Y = beta*Y + alpha*op(M^(-1))*X,
! where
! - M is a multilevel domain decomposition (Schwarz) preconditioner associated
! to a certain matrix A and stored in the array baseprecv,
! to a certain matrix A and stored in the array precv,
! - op(M^(-1)) is M^(-1) or its transpose, according to the value of trans,
! - X and Y are vectors,
! - alpha and beta are scalars.
@ -55,9 +55,9 @@
! level where we might have a replicated index space) and each process takes care
! of one submatrix.
!
! The multilevel preconditioner M is regarded as an array of 'base preconditioners',
! The multilevel preconditioner M is regarded as an array of 'one-level preconditioners',
! each representing the part of the preconditioner associated to a certain level.
! For each level ilev, the base preconditioner K(ilev) is stored in baseprecv(ilev)
! For each level ilev, the preconditioner K(ilev) is stored in precv(ilev)
! and is associated to a matrix A(ilev), obtained by 'tranferring' the original
! matrix A (i.e. the matrix to be preconditioned) to the level ilev, through smoothed
! aggregation.
@ -78,64 +78,41 @@
! Arguments:
! alpha - complex(psb_dpk_), input.
! The scalar alpha.
! baseprecv - type(mld_zbaseprc_type), dimension(:), input.
! The array of base preconditioner data structures containing the
! precv - type(mld_z_onelev_prec_type), dimension(:), input.
! The array of one-level preconditioner data structures containing the
! local parts of the preconditioners to be applied at each level.
! Note that nlev = size(baseprecv) = number of levels.
! baseprecv(ilev)%av - type(psb_zspmat_type), dimension(:), allocatable(:).
! The sparse matrices needed to apply the preconditioner
! at level ilev.
! baseprecv(ilev)%av(mld_l_pr_) - The L factor of the ILU factorization of the
! local diagonal block of A(ilev).
! baseprecv(ilev)%av(mld_u_pr_) - The U factor of the ILU factorization of the
! local diagonal block of A(ilev), except its
! diagonal entries (stored in baseprecv(ilev)%d).
! baseprecv(ilev)%av(mld_ap_nd_) - The entries of the local part of A(ilev)
! outside the diagonal block, for block-Jacobi
! sweeps.
! baseprecv(ilev)%av(mld_ac_) - The local part of the matrix A(ilev).
! baseprecv(ilev)%av(mld_sm_pr_) - The smoothed prolongator.
! It maps vectors (ilev) ---> (ilev-1).
! baseprecv(ilev)%av(mld_sm_pr_t_) - The smoothed prolongator transpose.
! It maps vectors (ilev-1) ---> (ilev).
! baseprecv(ilev)%d - complex(psb_dpk_), dimension(:), allocatable.
! The diagonal entries of the U factor in the ILU
! factorization of A(ilev).
! baseprecv(ilev)%desc_data - type(psb_desc_type).
! The communication descriptor associated to the base
! preconditioner, i.e. to the sparse matrices needed
! to apply the base preconditioner at the current level.
! baseprecv(ilev)%desc_ac - type(psb_desc_type).
! Note that nlev = size(precv) = number of levels.
! precv(ilev)%prec - type(psb_zbaseprc_type)
! The "base" preconditioner for the current level
! precv(ilev)%ac - type(psb_zspmat_type)
! The local part of the matrix A(ilev).
! precv(ilev)%desc_ac - type(psb_desc_type).
! The communication descriptor associated to the sparse
! matrix A(ilev), stored in baseprecv(ilev)%av(mld_ac_).
! baseprecv(ilev)%iprcparm - integer, dimension(:), allocatable.
! The integer parameters defining the base
! preconditioner K(ilev).
! baseprecv(ilev)%rprcparm - complex(psb_dpk_), dimension(:), allocatable.
! The real parameters defining the base preconditioner
! K(ilev).
! baseprecv(ilev)%perm - integer, dimension(:), allocatable.
! The row and column permutations applied to the local
! part of A(ilev) (defined only if baseprecv(ilev)%
! iprcparm(mld_sub_ren_)>0).
! baseprecv(ilev)%invperm - integer, dimension(:), allocatable.
! The inverse of the permutation stored in
! baseprecv(ilev)%perm.
! baseprecv(ilev)%mlia - integer, dimension(:), allocatable.
! matrix A(ilev)
! precv(ilev)%map_desc - type(psb_inter_desc_type)
! Stores the linear operators mapping between levels
! (ilev-1) and (ilev). These are the restriction and
! prolongation operators described in the sequel.
! precv(ilev)%iprcparm - integer, dimension(:), allocatable.
! The integer parameters defining the multilevel
! strategy
! precv(ilev)%rprcparm - real(psb_dpk_), dimension(:), allocatable.
! The real parameters defining the multilevel strategy
! precv(ilev)%mlia - integer, dimension(:), allocatable.
! The aggregation map (ilev-1) --> (ilev).
! In case of non-smoothed aggregation, it is used
! instead of mld_sm_pr_.
! baseprecv(ilev)%nlaggr - integer, dimension(:), allocatable.
! precv(ilev)%nlaggr - integer, dimension(:), allocatable.
! The number of aggregates (rows of A(ilev)) on the
! various processes.
! baseprecv(ilev)%base_a - type(psb_zspmat_type), pointer.
! precv(ilev)%base_a - type(psb_zspmat_type), pointer.
! Pointer (really a pointer!) to the base matrix of
! the current level, i.e. the local part of A(ilev);
! so we have a unified treatment of residuals. We
! need this to avoid passing explicitly the matrix
! A(ilev) to the routine which applies the
! preconditioner.
! baseprecv(ilev)%base_desc - type(psb_desc_type), pointer.
! precv(ilev)%base_desc - type(psb_desc_type), pointer.
! Pointer to the communication descriptor associated
! to the sparse matrix pointed by base_a.
!
@ -159,10 +136,10 @@
! Note that when the LU factorization of the matrix A(ilev) is computed instead of
! the ILU one, by using UMFPACK or SuperLU, the corresponding L and U factors
! are stored in data structures provided by UMFPACK or SuperLU and pointed by
! baseprecv(ilev)%iprcparm(mld_umf_ptr) or baseprecv(ilev)%iprcparm(mld_slu_ptr),
! precv(ilev)%prec%iprcparm(mld_umf_ptr) or precv(ilev)%prec%iprcparm(mld_slu_ptr),
! respectively.
!
subroutine mld_zmlprec_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info)
subroutine mld_zmlprec_aply(alpha,precv,x,beta,y,desc_data,trans,work,info)
use psb_base_mod
use mld_inner_mod, mld_protect_name => mld_zmlprec_aply
@ -171,7 +148,7 @@ subroutine mld_zmlprec_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info)
! Arguments
type(psb_desc_type),intent(in) :: desc_data
type(mld_zbaseprc_type), intent(in) :: baseprecv(:)
type(mld_z_onelev_prec_type), intent(in) :: precv(:)
complex(psb_dpk_),intent(in) :: alpha,beta
complex(psb_dpk_),intent(in) :: x(:)
complex(psb_dpk_),intent(inout) :: y(:)
@ -196,11 +173,11 @@ subroutine mld_zmlprec_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info)
if (debug_level >= psb_debug_inner_) &
& write(debug_unit,*) me,' ',trim(name),&
& ' Entry ', size(baseprecv)
& ' Entry ', size(precv)
trans_ = psb_toupper(trans)
select case(baseprecv(2)%iprcparm(mld_ml_type_))
select case(precv(2)%iprcparm(mld_ml_type_))
case(mld_no_ml_)
!
@ -214,7 +191,7 @@ subroutine mld_zmlprec_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info)
! Additive multilevel
!
call add_ml_aply(alpha,baseprecv,x,beta,y,desc_data,trans_,work,info)
call add_ml_aply(alpha,precv,x,beta,y,desc_data,trans_,work,info)
case(mld_mult_ml_)
!
@ -225,15 +202,15 @@ subroutine mld_zmlprec_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info)
! Note that the transpose switches pre <-> post.
!
select case(baseprecv(2)%iprcparm(mld_smoother_pos_))
select case(precv(2)%iprcparm(mld_smoother_pos_))
case(mld_post_smooth_)
select case (trans_)
case('N')
call mlt_post_ml_aply(alpha,baseprecv,x,beta,y,desc_data,trans_,work,info)
call mlt_post_ml_aply(alpha,precv,x,beta,y,desc_data,trans_,work,info)
case('T','C')
call mlt_pre_ml_aply(alpha,baseprecv,x,beta,y,desc_data,trans_,work,info)
call mlt_pre_ml_aply(alpha,precv,x,beta,y,desc_data,trans_,work,info)
case default
info = 4001
call psb_errpush(info,name,a_err='invalid trans')
@ -244,9 +221,9 @@ subroutine mld_zmlprec_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info)
select case (trans_)
case('N')
call mlt_pre_ml_aply(alpha,baseprecv,x,beta,y,desc_data,trans_,work,info)
call mlt_pre_ml_aply(alpha,precv,x,beta,y,desc_data,trans_,work,info)
case('T','C')
call mlt_post_ml_aply(alpha,baseprecv,x,beta,y,desc_data,trans_,work,info)
call mlt_post_ml_aply(alpha,precv,x,beta,y,desc_data,trans_,work,info)
case default
info = 4001
call psb_errpush(info,name,a_err='invalid trans')
@ -255,12 +232,12 @@ subroutine mld_zmlprec_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info)
case(mld_twoside_smooth_)
call mlt_twoside_ml_aply(alpha,baseprecv,x,beta,y,desc_data,trans_,work,info)
call mlt_twoside_ml_aply(alpha,precv,x,beta,y,desc_data,trans_,work,info)
case default
info = 4013
call psb_errpush(info,name,a_err='invalid smooth_pos',&
& i_Err=(/baseprecv(2)%iprcparm(mld_smoother_pos_),0,0,0,0/))
& i_Err=(/precv(2)%iprcparm(mld_smoother_pos_),0,0,0,0/))
goto 9999
end select
@ -268,7 +245,7 @@ subroutine mld_zmlprec_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info)
case default
info = 4013
call psb_errpush(info,name,a_err='invalid mltype',&
& i_Err=(/baseprecv(2)%iprcparm(mld_ml_type_),0,0,0,0/))
& i_Err=(/precv(2)%iprcparm(mld_ml_type_),0,0,0,0/))
goto 9999
end select
@ -295,7 +272,7 @@ contains
! Y = beta*Y + alpha*op(M^(-1))*X,
! where
! - M is an additive multilevel domain decomposition (Schwarz) preconditioner
! associated to a certain matrix A and stored in the array baseprecv,
! associated to a certain matrix A and stored in the array precv,
! - op(M^(-1)) is M^(-1) or its (conjugate) transpose, according to
! the value of trans,
! - X and Y are vectors,
@ -308,9 +285,9 @@ contains
! level where we might have a replicated index space) and each process takes care
! of one submatrix.
!
! The multilevel preconditioner M is regarded as an array of 'base preconditioners',
! The multilevel preconditioner M is regarded as an array of 'one-level preconditioners',
! each representing the part of the preconditioner associated to a certain level.
! For each level ilev, the base preconditioner K(ilev) is stored in baseprecv(ilev)
! For each level ilev, the base preconditioner K(ilev) is stored in precv(ilev)
! and is associated to a matrix A(ilev), obtained by 'tranferring' the original
! matrix A (i.e. the matrix to be preconditioned) to the level ilev, through smoothed
! aggregation.
@ -324,7 +301,7 @@ contains
! Domain decomposition: parallel multilevel methods for elliptic partial
! differential equations, Cambridge University Press, 1996.
!
! For a description of the arguments see mld_dmlprec_aply.
! For a description of the arguments see mld_zmlprec_aply.
!
! A sketch of the algorithm implemented in this routine is provided below
! (AV(ilev; sm_pr_) denotes the smoothed prolongator from level ilev to
@ -358,13 +335,13 @@ contains
!
! 4. Yext = beta*Yext + alpha*Y(1)
!
subroutine add_ml_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info)
subroutine add_ml_aply(alpha,precv,x,beta,y,desc_data,trans,work,info)
implicit none
! Arguments
type(psb_desc_type),intent(in) :: desc_data
type(mld_zbaseprc_type), intent(in) :: baseprecv(:)
type(mld_z_onelev_prec_type), intent(in) :: precv(:)
complex(psb_dpk_),intent(in) :: alpha,beta
complex(psb_dpk_),intent(in) :: x(:)
complex(psb_dpk_),intent(inout) :: y(:)
@ -373,10 +350,9 @@ contains
integer, intent(out) :: info
! Local variables
integer :: n_row,n_col
integer :: ictxt,np,me,i, nr2l,nc2l,err_act
integer :: debug_level, debug_unit
integer :: ismth, nlev, ilev, icm
integer :: nlev, ilev
character(len=20) :: name
type psb_mlprec_wrk_type
@ -395,9 +371,9 @@ contains
if (debug_level >= psb_debug_inner_) &
& write(debug_unit,*) me,' ',trim(name),&
& ' Entry ', size(baseprecv)
& ' Entry ', size(precv)
nlev = size(baseprecv)
nlev = size(precv)
allocate(mlprec_wrk(nlev),stat=info)
if (info /= 0) then
call psb_errpush(4010,name,a_err='Allocate')
@ -420,9 +396,8 @@ contains
mlprec_wrk(1)%x2l(:) = x(:)
mlprec_wrk(1)%y2l(:) = zzero
call mld_baseprec_aply(alpha,baseprecv(1),x,beta,y,&
& baseprecv(1)%base_desc,trans,work,info)
call mld_baseprec_aply(alpha,precv(1)%prec,x,beta,y,&
& precv(1)%base_desc,trans,work,info)
if (info /=0) then
call psb_errpush(4010,name,a_err='baseprec_aply')
goto 9999
@ -433,49 +408,33 @@ contains
! For each level except the finest one ...
!
do ilev = 2, nlev
n_row = psb_cd_get_local_rows(baseprecv(ilev-1)%base_desc)
n_col = psb_cd_get_local_cols(baseprecv(ilev-1)%base_desc)
nc2l = psb_cd_get_local_cols(baseprecv(ilev)%base_desc)
nr2l = psb_cd_get_local_rows(baseprecv(ilev)%base_desc)
nc2l = psb_cd_get_local_cols(precv(ilev)%base_desc)
nr2l = psb_cd_get_local_rows(precv(ilev)%base_desc)
allocate(mlprec_wrk(ilev)%x2l(nc2l),mlprec_wrk(ilev)%y2l(nc2l),&
& stat=info)
if (info /= 0) then
info=4025
call psb_errpush(info,name,i_err=(/2*(nc2l+max(n_row,n_col)),0,0,0,0/),&
call psb_errpush(info,name,i_err=(/2*nc2l,0,0,0,0/),&
& a_err='complex(psb_dpk_)')
goto 9999
end if
ismth = baseprecv(ilev)%iprcparm(mld_aggr_kind_)
icm = baseprecv(ilev)%iprcparm(mld_coarse_mat_)
! Apply prolongator transpose, i.e. restriction
call psb_forward_map(zone,mlprec_wrk(ilev-1)%x2l,&
& zzero,mlprec_wrk(ilev)%x2l,&
& baseprecv(ilev)%map_desc,info,work=work)
& precv(ilev)%map_desc,info,work=work)
if (info /=0) then
call psb_errpush(4001,name,a_err='Error during restriction')
goto 9999
end if
if (icm == mld_repl_mat_) then
call psb_sum(ictxt,mlprec_wrk(ilev)%x2l(1:nr2l))
else if (icm /= mld_distr_mat_) then
info = 4013
call psb_errpush(info,name,a_err='invalid mld_coarse_mat_',&
& i_Err=(/icm,0,0,0,0/))
goto 9999
endif
!
! Apply the base preconditioner
!
call mld_baseprec_aply(zone,baseprecv(ilev),&
call mld_baseprec_aply(zone,precv(ilev)%prec,&
& mlprec_wrk(ilev)%x2l,zzero,mlprec_wrk(ilev)%y2l,&
& baseprecv(ilev)%base_desc,trans,work,info)
& precv(ilev)%base_desc,trans,work,info)
enddo
@ -486,19 +445,15 @@ contains
!
do ilev =nlev,2,-1
n_row = psb_cd_get_local_rows(baseprecv(ilev-1)%base_desc)
n_col = psb_cd_get_local_cols(baseprecv(ilev-1)%base_desc)
nc2l = psb_cd_get_local_cols(baseprecv(ilev)%base_desc)
nr2l = psb_cd_get_local_rows(baseprecv(ilev)%base_desc)
ismth = baseprecv(ilev)%iprcparm(mld_aggr_kind_)
icm = baseprecv(ilev)%iprcparm(mld_coarse_mat_)
nc2l = psb_cd_get_local_cols(precv(ilev)%base_desc)
nr2l = psb_cd_get_local_rows(precv(ilev)%base_desc)
!
! Apply prolongator
!
call psb_backward_map(zone,mlprec_wrk(ilev)%y2l,&
& zone,mlprec_wrk(ilev-1)%y2l,&
& baseprecv(ilev)%map_desc,info,work=work)
& precv(ilev)%map_desc,info,work=work)
if (info /=0) then
call psb_errpush(4001,name,a_err='Error during prolongation')
@ -511,7 +466,7 @@ contains
!
! Compute the output vector Y
!
call psb_geaxpby(alpha,mlprec_wrk(1)%y2l,zone,y,baseprecv(1)%base_desc,info)
call psb_geaxpby(alpha,mlprec_wrk(1)%y2l,zone,y,precv(1)%base_desc,info)
if (info /= 0) then
call psb_errpush(4001,name,a_err='Error on final update')
goto 9999
@ -538,14 +493,14 @@ contains
!
! Subroutine: mlt_pre_ml_aply
! Version: complex
! Note: internal subroutine of mld_dmlprec_aply.
! Note: internal subroutine of mld_zmlprec_aply.
!
! This routine computes
!
! Y = beta*Y + alpha*op(M^(-1))*X,
! where
! - M is a hybrid multilevel domain decomposition (Schwarz) preconditioner
! associated to a certain matrix A and stored in the array baseprecv,
! associated to a certain matrix A and stored in the array precv,
! - op(M^(-1)) is M^(-1) or its (conjugate) transpose, according to
! the value of trans,
! - X and Y are vectors,
@ -558,9 +513,9 @@ contains
! level where we might have a replicated index space) and each process takes care
! of one submatrix.
!
! The multilevel preconditioner M is regarded as an array of 'base preconditioners',
! The multilevel preconditioner M is regarded as an array of 'one-level preconditioners',
! each representing the part of the preconditioner associated to a certain level.
! For each level ilev, the base preconditioner K(ilev) is stored in baseprecv(ilev)
! For each level ilev, the base preconditioner K(ilev) is stored in precv(ilev)
! and is associated to a matrix A(ilev), obtained by 'tranferring' the original
! matrix A (i.e. the matrix to be preconditioned) to the level ilev, through smoothed
! aggregation.
@ -574,7 +529,7 @@ contains
! Domain decomposition: parallel multilevel methods for elliptic partial
! differential equations, Cambridge University Press, 1996.
!
! For a description of the arguments see mld_dmlprec_aply.
! For a description of the arguments see mld_zmlprec_aply.
!
! A sketch of the algorithm implemented in this routine is provided below
! (AV(ilev; sm_pr_) denotes the smoothed prolongator from level ilev to
@ -616,13 +571,13 @@ contains
! 6. Yext = beta*Yext + alpha*Y(1)
!
!
subroutine mlt_pre_ml_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info)
subroutine mlt_pre_ml_aply(alpha,precv,x,beta,y,desc_data,trans,work,info)
implicit none
! Arguments
type(psb_desc_type),intent(in) :: desc_data
type(mld_zbaseprc_type), intent(in) :: baseprecv(:)
type(mld_z_onelev_prec_type), intent(in) :: precv(:)
complex(psb_dpk_),intent(in) :: alpha,beta
complex(psb_dpk_),intent(in) :: x(:)
complex(psb_dpk_),intent(inout) :: y(:)
@ -631,10 +586,9 @@ contains
integer, intent(out) :: info
! Local variables
integer :: n_row,n_col
integer :: ictxt,np,me,i, nr2l,nc2l,err_act
integer :: debug_level, debug_unit
integer :: ismth, nlev, ilev, icm
integer :: nlev, ilev
character(len=20) :: name
type psb_mlprec_wrk_type
@ -653,9 +607,9 @@ contains
if (debug_level >= psb_debug_inner_) &
& write(debug_unit,*) me,' ',trim(name),&
& ' Entry ', size(baseprecv)
& ' Entry ', size(precv)
nlev = size(baseprecv)
nlev = size(precv)
allocate(mlprec_wrk(nlev),stat=info)
if (info /= 0) then
call psb_errpush(4010,name,a_err='Allocate')
@ -667,8 +621,7 @@ contains
!
! Copy the input vector X
!
n_col = psb_cd_get_local_cols(desc_data)
nc2l = psb_cd_get_local_cols(baseprecv(1)%base_desc)
nc2l = psb_cd_get_local_cols(precv(1)%base_desc)
allocate(mlprec_wrk(1)%x2l(nc2l),mlprec_wrk(1)%y2l(nc2l), &
& mlprec_wrk(1)%tx(nc2l), stat=info)
@ -685,8 +638,8 @@ contains
!
! Apply the base preconditioner at the finest level
!
call mld_baseprec_aply(zone,baseprecv(1),mlprec_wrk(1)%x2l,&
& zzero,mlprec_wrk(1)%y2l,baseprecv(1)%base_desc,&
call mld_baseprec_aply(zone,precv(1)%prec,mlprec_wrk(1)%x2l,&
& zzero,mlprec_wrk(1)%y2l,precv(1)%base_desc,&
& trans,work,info)
if (info /=0) then
call psb_errpush(4010,name,a_err=' baseprec_aply')
@ -700,8 +653,8 @@ contains
!
mlprec_wrk(1)%tx = mlprec_wrk(1)%x2l
call psb_spmm(-zone,baseprecv(1)%base_a,mlprec_wrk(1)%y2l,&
& zone,mlprec_wrk(1)%tx,baseprecv(1)%base_desc,info,&
call psb_spmm(-zone,precv(1)%base_a,mlprec_wrk(1)%y2l,&
& zone,mlprec_wrk(1)%tx,precv(1)%base_desc,info,&
& work=work,trans=trans)
if (info /=0) then
call psb_errpush(4001,name,a_err=' fine level residual')
@ -715,12 +668,8 @@ contains
!
do ilev = 2, nlev
n_row = psb_cd_get_local_rows(baseprecv(ilev-1)%base_desc)
n_col = psb_cd_get_local_cols(baseprecv(ilev-1)%base_desc)
nc2l = psb_cd_get_local_cols(baseprecv(ilev)%base_desc)
nr2l = psb_cd_get_local_rows(baseprecv(ilev)%base_desc)
ismth = baseprecv(ilev)%iprcparm(mld_aggr_kind_)
icm = baseprecv(ilev)%iprcparm(mld_coarse_mat_)
nc2l = psb_cd_get_local_cols(precv(ilev)%base_desc)
nr2l = psb_cd_get_local_rows(precv(ilev)%base_desc)
allocate(mlprec_wrk(ilev)%tx(nc2l),mlprec_wrk(ilev)%y2l(nc2l),&
& mlprec_wrk(ilev)%x2l(nc2l), stat=info)
@ -734,7 +683,7 @@ contains
! Apply prolongator transpose, i.e. restriction
call psb_forward_map(zone,mlprec_wrk(ilev-1)%tx,&
& zzero,mlprec_wrk(ilev)%x2l,&
& baseprecv(ilev)%map_desc,info,work=work)
& precv(ilev)%map_desc,info,work=work)
if (info /=0) then
call psb_errpush(4001,name,a_err='Error during restriction')
@ -744,17 +693,17 @@ contains
!
! Apply the base preconditioner
!
call mld_baseprec_aply(zone,baseprecv(ilev),mlprec_wrk(ilev)%x2l,&
& zzero,mlprec_wrk(ilev)%y2l,baseprecv(ilev)%base_desc,trans,work,info)
call mld_baseprec_aply(zone,precv(ilev)%prec,mlprec_wrk(ilev)%x2l,&
& zzero,mlprec_wrk(ilev)%y2l,precv(ilev)%base_desc,trans,work,info)
!
! Compute the residual (at all levels but the coarsest one)
!
if (ilev < nlev) then
mlprec_wrk(ilev)%tx = mlprec_wrk(ilev)%x2l
if (info == 0) call psb_spmm(-zone,baseprecv(ilev)%base_a,&
if (info == 0) call psb_spmm(-zone,precv(ilev)%base_a,&
& mlprec_wrk(ilev)%y2l,zone,mlprec_wrk(ilev)%tx,&
& baseprecv(ilev)%base_desc,info,work=work,trans=trans)
& precv(ilev)%base_desc,info,work=work,trans=trans)
endif
if (info /=0) then
call psb_errpush(4001,name,a_err='Error on up sweep residual')
@ -768,16 +717,12 @@ contains
! For each level but the coarsest one ...
!
do ilev = nlev-1, 1, -1
ismth = baseprecv(ilev+1)%iprcparm(mld_aggr_kind_)
n_row = psb_cd_get_local_rows(baseprecv(ilev)%base_desc)
!
! Apply prolongator
!
call psb_backward_map(zone,mlprec_wrk(ilev+1)%y2l,&
& zone,mlprec_wrk(ilev)%y2l,&
& baseprecv(ilev+1)%map_desc,info,work=work)
& precv(ilev+1)%map_desc,info,work=work)
if (info /=0) then
call psb_errpush(4001,name,a_err='Error during prolongation')
@ -791,7 +736,7 @@ contains
! Compute the output vector Y
!
call psb_geaxpby(alpha,mlprec_wrk(1)%y2l,beta,y,&
& baseprecv(1)%base_desc,info)
& precv(1)%base_desc,info)
if (info /=0) then
call psb_errpush(4001,name,a_err='Error on final update')
goto 9999
@ -817,14 +762,14 @@ contains
!
! Subroutine: mlt_post_ml_aply
! Version: complex
! Note: internal subroutine of mld_dmlprec_aply.
! Note: internal subroutine of mld_zmlprec_aply.
!
! This routine computes
!
! Y = beta*Y + alpha*op(M^(-1))*X,
! where
! - M is a hybrid multilevel domain decomposition (Schwarz) preconditioner
! associated to a certain matrix A and stored in the array baseprecv,
! associated to a certain matrix A and stored in the array precv,
! - op(M^(-1)) is M^(-1) or its (conjugate) transpose, according to
! the value of trans,
! - X and Y are vectors,
@ -837,9 +782,9 @@ contains
! level where we might have a replicated index space) and each process takes care
! of one submatrix.
!
! The multilevel preconditioner M is regarded as an array of 'base preconditioners',
! The multilevel preconditioner M is regarded as an array of 'one-level preconditioners',
! each representing the part of the preconditioner associated to a certain level.
! For each level ilev, the base preconditioner K(ilev) is stored in baseprecv(ilev)
! For each level ilev, the base preconditioner K(ilev) is stored in precv(ilev)
! and is associated to a matrix A(ilev), obtained by 'tranferring' the original
! matrix A (i.e. the matrix to be preconditioned) to the level ilev, through smoothed
! aggregation.
@ -852,7 +797,7 @@ contains
! Domain decomposition: parallel multilevel methods for elliptic partial
! differential equations, Cambridge University Press, 1996.
!
! For a description of the arguments see mld_dmlprec_aply.
! For a description of the arguments see mld_zmlprec_aply.
!
! A sketch of the algorithm implemented in this routine is provided below.
! (AV(ilev; sm_pr_) denotes the smoothed prolongator from level ilev to
@ -886,13 +831,13 @@ contains
! 5. Yext = beta*Yext + alpha*Y(1)
!
!
subroutine mlt_post_ml_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info)
subroutine mlt_post_ml_aply(alpha,precv,x,beta,y,desc_data,trans,work,info)
implicit none
! Arguments
type(psb_desc_type),intent(in) :: desc_data
type(mld_zbaseprc_type), intent(in) :: baseprecv(:)
type(mld_z_onelev_prec_type), intent(in) :: precv(:)
complex(psb_dpk_),intent(in) :: alpha,beta
complex(psb_dpk_),intent(in) :: x(:)
complex(psb_dpk_),intent(inout) :: y(:)
@ -901,10 +846,9 @@ contains
integer, intent(out) :: info
! Local variables
integer :: n_row,n_col
integer :: ictxt,np,me,i, nr2l,nc2l,err_act
integer :: debug_level, debug_unit
integer :: ismth, nlev, ilev, icm
integer :: nlev, ilev
character(len=20) :: name
type psb_mlprec_wrk_type
@ -923,9 +867,9 @@ contains
if (debug_level >= psb_debug_inner_) &
& write(debug_unit,*) me,' ',trim(name),&
& ' Entry ', size(baseprecv)
& ' Entry ', size(precv)
nlev = size(baseprecv)
nlev = size(precv)
allocate(mlprec_wrk(nlev),stat=info)
if (info /= 0) then
call psb_errpush(4010,name,a_err='Allocate')
@ -941,16 +885,21 @@ contains
& write(debug_unit,*) me,' ',trim(name),&
& ' desc_data status',allocated(desc_data%matrix_data)
n_col = psb_cd_get_local_cols(desc_data)
nc2l = psb_cd_get_local_cols(baseprecv(1)%base_desc)
nc2l = psb_cd_get_local_cols(precv(1)%base_desc)
allocate(mlprec_wrk(1)%x2l(nc2l),mlprec_wrk(1)%y2l(nc2l), &
& mlprec_wrk(1)%tx(nc2l), stat=info)
if (info /= 0) then
info=4025
call psb_errpush(info,name,i_err=(/4*nc2l,0,0,0,0/),&
& a_err='complex(psb_dpk_)')
goto 9999
end if
call psb_geaxpby(zone,x,zzero,mlprec_wrk(1)%tx,&
& baseprecv(1)%base_desc,info)
& precv(1)%base_desc,info)
call psb_geaxpby(zone,x,zzero,mlprec_wrk(1)%x2l,&
& baseprecv(1)%base_desc,info)
& precv(1)%base_desc,info)
!
! STEP 2
@ -959,18 +908,13 @@ contains
!
do ilev=2, nlev
n_row = psb_cd_get_local_rows(baseprecv(ilev-1)%base_desc)
n_col = psb_cd_get_local_cols(baseprecv(ilev-1)%base_desc)
nc2l = psb_cd_get_local_cols(baseprecv(ilev)%base_desc)
nr2l = psb_cd_get_local_rows(baseprecv(ilev)%base_desc)
ismth = baseprecv(ilev)%iprcparm(mld_aggr_kind_)
icm = baseprecv(ilev)%iprcparm(mld_coarse_mat_)
nc2l = psb_cd_get_local_cols(precv(ilev)%base_desc)
nr2l = psb_cd_get_local_rows(precv(ilev)%base_desc)
if (debug_level >= psb_debug_inner_) &
& write(debug_unit,*) me,' ',trim(name), &
& ' starting up sweep ',&
& ilev,allocated(baseprecv(ilev)%iprcparm),n_row,n_col,&
& nc2l, nr2l,ismth
& ilev,allocated(precv(ilev)%iprcparm),nc2l, nr2l
allocate(mlprec_wrk(ilev)%tx(nc2l),mlprec_wrk(ilev)%y2l(nc2l),&
& mlprec_wrk(ilev)%x2l(nc2l), stat=info)
@ -985,7 +929,7 @@ contains
! Apply prolongator transpose, i.e. restriction
call psb_forward_map(zone,mlprec_wrk(ilev-1)%x2l,&
& zzero,mlprec_wrk(ilev)%x2l,&
& baseprecv(ilev)%map_desc,info,work=work)
& precv(ilev)%map_desc,info,work=work)
if (info /=0) then
call psb_errpush(4001,name,a_err='Error during restriction')
@ -996,7 +940,7 @@ contains
! update x2l
!
call psb_geaxpby(zone,mlprec_wrk(ilev)%x2l,zzero,mlprec_wrk(ilev)%tx,&
& baseprecv(ilev)%base_desc,info)
& precv(ilev)%base_desc,info)
if (info /= 0) then
call psb_errpush(4001,name,a_err='Error in update')
goto 9999
@ -1013,8 +957,8 @@ contains
!
! Apply the base preconditioner at the coarsest level
!
call mld_baseprec_aply(zone,baseprecv(nlev),mlprec_wrk(nlev)%x2l, &
& zzero, mlprec_wrk(nlev)%y2l,baseprecv(nlev)%base_desc,trans,work,info)
call mld_baseprec_aply(zone,precv(nlev)%prec,mlprec_wrk(nlev)%x2l, &
& zzero, mlprec_wrk(nlev)%y2l,precv(nlev)%base_desc,trans,work,info)
if (info /=0) then
call psb_errpush(4010,name,a_err='baseprec_aply')
goto 9999
@ -1034,15 +978,12 @@ contains
& write(debug_unit,*) me,' ',trim(name),&
& ' starting down sweep',ilev
ismth = baseprecv(ilev+1)%iprcparm(mld_aggr_kind_)
n_row = psb_cd_get_local_rows(baseprecv(ilev)%base_desc)
!
! Apply prolongator
!
call psb_backward_map(zone,mlprec_wrk(ilev+1)%y2l,&
& zzero,mlprec_wrk(ilev)%y2l,&
& baseprecv(ilev+1)%map_desc,info,work=work)
& precv(ilev+1)%map_desc,info,work=work)
if (info /=0) then
call psb_errpush(4001,name,a_err='Error during prolongation')
@ -1052,15 +993,16 @@ contains
!
! Compute the residual
!
call psb_spmm(-zone,baseprecv(ilev)%base_a,mlprec_wrk(ilev)%y2l,&
& zone,mlprec_wrk(ilev)%tx,baseprecv(ilev)%base_desc,info,&
call psb_spmm(-zone,precv(ilev)%base_a,mlprec_wrk(ilev)%y2l,&
& zone,mlprec_wrk(ilev)%tx,precv(ilev)%base_desc,info,&
& work=work,trans=trans)
!
! Apply the base preconditioner
!
if (info == 0) call mld_baseprec_aply(zone,baseprecv(ilev),mlprec_wrk(ilev)%tx,&
& zone,mlprec_wrk(ilev)%y2l,baseprecv(ilev)%base_desc,trans,work,info)
if (info == 0) call mld_baseprec_aply(zone,precv(ilev)%prec,&
& mlprec_wrk(ilev)%tx,zone,mlprec_wrk(ilev)%y2l,precv(ilev)%base_desc,&
&trans,work,info)
if (info /=0) then
call psb_errpush(4001,name,a_err=' spmm/baseprec_aply')
goto 9999
@ -1076,7 +1018,7 @@ contains
!
! Compute the output vector Y
!
call psb_geaxpby(alpha,mlprec_wrk(1)%y2l,beta,y,baseprecv(1)%base_desc,info)
call psb_geaxpby(alpha,mlprec_wrk(1)%y2l,beta,y,precv(1)%base_desc,info)
if (info /=0) then
call psb_errpush(4001,name,a_err=' Final update')
@ -1105,7 +1047,7 @@ contains
!
! Subroutine: mlt_twoside_ml_aply
! Version: complex
! Note: internal subroutine of mld_dmlprec_aply.
! Note: internal subroutine of mld_zmlprec_aply.
!
! This routine computes
!
@ -1113,7 +1055,7 @@ contains
! where
! - M is a symmetrized hybrid multilevel domain decomposition (Schwarz)
! preconditioner associated to a certain matrix A and stored in the array
! baseprecv,
! precv,
! - op(M^(-1)) is M^(-1) or its (conjugate) transpose, according to
! the value of trans,
! - X and Y are vectors,
@ -1127,9 +1069,9 @@ contains
! level where we might have a replicated index space) and each process takes care
! of one submatrix.
!
! The multilevel preconditioner M is regarded as an array of 'base preconditioners',
! The multilevel preconditioner M is regarded as an array of 'one-level preconditioners',
! each representing the part of the preconditioner associated to a certain level.
! For each level ilev, the base preconditioner K(ilev) is stored in baseprecv(ilev)
! For each level ilev, the base preconditioner K(ilev) is stored in precv(ilev)
! and is associated to a matrix A(ilev), obtained by 'tranferring' the original
! matrix A (i.e. the matrix to be preconditioned) to the level ilev, through smoothed
! aggregation.
@ -1143,7 +1085,7 @@ contains
! Domain decomposition: parallel multilevel methods for elliptic partial
! differential equations, Cambridge University Press, 1996.
!
! For a description of the arguments see mld_dmlprec_aply.
! For a description of the arguments see mld_zmlprec_aply.
!
! A sketch of the algorithm implemented in this routine is provided below.
! (AV(ilev; sm_pr_) denotes the smoothed prolongator from level ilev to
@ -1187,13 +1129,13 @@ contains
!
! 6. Yext = beta*Yext + alpha*Y(1)
!
subroutine mlt_twoside_ml_aply(alpha,baseprecv,x,beta,y,desc_data,trans,work,info)
subroutine mlt_twoside_ml_aply(alpha,precv,x,beta,y,desc_data,trans,work,info)
implicit none
! Arguments
type(psb_desc_type),intent(in) :: desc_data
type(mld_zbaseprc_type), intent(in) :: baseprecv(:)
type(mld_z_onelev_prec_type), intent(in) :: precv(:)
complex(psb_dpk_),intent(in) :: alpha,beta
complex(psb_dpk_),intent(in) :: x(:)
complex(psb_dpk_),intent(inout) :: y(:)
@ -1202,10 +1144,9 @@ contains
integer, intent(out) :: info
! Local variables
integer :: n_row,n_col
integer :: ictxt,np,me,i, nr2l,nc2l,err_act
integer :: debug_level, debug_unit
integer :: ismth, nlev, ilev, icm
integer :: nlev, ilev
character(len=20) :: name
type psb_mlprec_wrk_type
@ -1224,9 +1165,9 @@ contains
if (debug_level >= psb_debug_inner_) &
& write(debug_unit,*) me,' ',trim(name),&
& ' Entry ', size(baseprecv)
& ' Entry ', size(precv)
nlev = size(baseprecv)
nlev = size(precv)
allocate(mlprec_wrk(nlev),stat=info)
if (info /= 0) then
call psb_errpush(4010,name,a_err='Allocate')
@ -1237,8 +1178,7 @@ contains
!
! Copy the input vector X
!
n_col = psb_cd_get_local_cols(desc_data)
nc2l = psb_cd_get_local_cols(baseprecv(1)%base_desc)
nc2l = psb_cd_get_local_cols(precv(1)%base_desc)
allocate(mlprec_wrk(1)%x2l(nc2l),mlprec_wrk(1)%y2l(nc2l), &
& mlprec_wrk(1)%ty(nc2l), mlprec_wrk(1)%tx(nc2l), stat=info)
@ -1251,17 +1191,17 @@ contains
end if
call psb_geaxpby(zone,x,zzero,mlprec_wrk(1)%x2l,&
& baseprecv(1)%base_desc,info)
& precv(1)%base_desc,info)
call psb_geaxpby(zone,x,zzero,mlprec_wrk(1)%tx,&
& baseprecv(1)%base_desc,info)
& precv(1)%base_desc,info)
!
! STEP 2
!
! Apply the base preconditioner at the finest level
!
call mld_baseprec_aply(zone,baseprecv(1),mlprec_wrk(1)%x2l,&
& zzero,mlprec_wrk(1)%y2l,baseprecv(1)%base_desc,&
call mld_baseprec_aply(zone,precv(1)%prec,mlprec_wrk(1)%x2l,&
& zzero,mlprec_wrk(1)%y2l,precv(1)%base_desc,&
& trans,work,info)
!
! STEP 3
@ -1269,8 +1209,8 @@ contains
! Compute the residual at the finest level
!
mlprec_wrk(1)%ty = mlprec_wrk(1)%x2l
if (info == 0) call psb_spmm(-zone,baseprecv(1)%base_a,mlprec_wrk(1)%y2l,&
& zone,mlprec_wrk(1)%ty,baseprecv(1)%base_desc,info,&
if (info == 0) call psb_spmm(-zone,precv(1)%base_a,mlprec_wrk(1)%y2l,&
& zone,mlprec_wrk(1)%ty,precv(1)%base_desc,info,&
& work=work,trans=trans)
if (info /=0) then
call psb_errpush(4010,name,a_err='Fine level baseprec/residual')
@ -1284,12 +1224,9 @@ contains
!
do ilev = 2, nlev
n_row = psb_cd_get_local_rows(baseprecv(ilev-1)%base_desc)
n_col = psb_cd_get_local_cols(baseprecv(ilev-1)%base_desc)
nc2l = psb_cd_get_local_cols(baseprecv(ilev)%base_desc)
nr2l = psb_cd_get_local_rows(baseprecv(ilev)%base_desc)
ismth = baseprecv(ilev)%iprcparm(mld_aggr_kind_)
icm = baseprecv(ilev)%iprcparm(mld_coarse_mat_)
nc2l = psb_cd_get_local_cols(precv(ilev)%base_desc)
nr2l = psb_cd_get_local_rows(precv(ilev)%base_desc)
allocate(mlprec_wrk(ilev)%tx(nc2l),mlprec_wrk(ilev)%ty(nc2l),&
& mlprec_wrk(ilev)%y2l(nc2l),mlprec_wrk(ilev)%x2l(nc2l), stat=info)
@ -1303,7 +1240,7 @@ contains
! Apply prolongator transpose, i.e. restriction
call psb_forward_map(zone,mlprec_wrk(ilev-1)%ty,&
& zzero,mlprec_wrk(ilev)%x2l,&
& baseprecv(ilev)%map_desc,info,work=work)
& precv(ilev)%map_desc,info,work=work)
if (info /=0) then
call psb_errpush(4001,name,a_err='Error during restriction')
@ -1311,21 +1248,21 @@ contains
end if
call psb_geaxpby(zone,mlprec_wrk(ilev)%x2l,zzero,mlprec_wrk(ilev)%tx,&
& baseprecv(ilev)%base_desc,info)
& precv(ilev)%base_desc,info)
!
! Apply the base preconditioner
!
if (info == 0) call mld_baseprec_aply(zone,baseprecv(ilev),&
if (info == 0) call mld_baseprec_aply(zone,precv(ilev)%prec,&
& mlprec_wrk(ilev)%x2l,zzero,mlprec_wrk(ilev)%y2l,&
&baseprecv(ilev)%base_desc,trans,work,info)
&precv(ilev)%base_desc,trans,work,info)
!
! Compute the residual (at all levels but the coarsest one)
!
if(ilev < nlev) then
mlprec_wrk(ilev)%ty = mlprec_wrk(ilev)%x2l
if (info == 0) call psb_spmm(-zone,baseprecv(ilev)%base_a,&
if (info == 0) call psb_spmm(-zone,precv(ilev)%base_a,&
& mlprec_wrk(ilev)%y2l,zone,mlprec_wrk(ilev)%ty,&
& baseprecv(ilev)%base_desc,info,work=work,trans=trans)
& precv(ilev)%base_desc,info,work=work,trans=trans)
endif
if (info /=0) then
call psb_errpush(4001,name,a_err='baseprec_aply/residual')
@ -1341,15 +1278,12 @@ contains
!
do ilev=nlev-1, 1, -1
ismth = baseprecv(ilev+1)%iprcparm(mld_aggr_kind_)
n_row = psb_cd_get_local_rows(baseprecv(ilev)%base_desc)
!
! Apply prolongator
!
call psb_backward_map(zone,mlprec_wrk(ilev+1)%y2l,&
& zone,mlprec_wrk(ilev)%y2l,&
& baseprecv(ilev+1)%map_desc,info,work=work)
& precv(ilev+1)%map_desc,info,work=work)
if (info /=0 ) then
call psb_errpush(4001,name,a_err='Error during restriction')
@ -1359,14 +1293,14 @@ contains
!
! Compute the residual
!
call psb_spmm(-zone,baseprecv(ilev)%base_a,mlprec_wrk(ilev)%y2l,&
& zone,mlprec_wrk(ilev)%tx,baseprecv(ilev)%base_desc,info,&
call psb_spmm(-zone,precv(ilev)%base_a,mlprec_wrk(ilev)%y2l,&
& zone,mlprec_wrk(ilev)%tx,precv(ilev)%base_desc,info,&
& work=work,trans=trans)
!
! Apply the base preconditioner
!
if (info == 0) call mld_baseprec_aply(zone,baseprecv(ilev),mlprec_wrk(ilev)%tx,&
& zone,mlprec_wrk(ilev)%y2l,baseprecv(ilev)%base_desc, trans, work,info)
if (info == 0) call mld_baseprec_aply(zone,precv(ilev)%prec,mlprec_wrk(ilev)%tx,&
& zone,mlprec_wrk(ilev)%y2l,precv(ilev)%base_desc, trans, work,info)
if (info /= 0) then
call psb_errpush(4001,name,a_err='Error: residual/baseprec_aply')
goto 9999
@ -1379,7 +1313,7 @@ contains
! Compute the output vector Y
!
call psb_geaxpby(alpha,mlprec_wrk(1)%y2l,beta,y,&
& baseprecv(1)%base_desc,info)
& precv(1)%base_desc,info)
if (info /= 0) then
call psb_errpush(4001,name,a_err='Error final update')

46
mlprec/mld_zmlprec_bld.f90
Unescape Escape View File

@ -41,7 +41,7 @@
! Subroutine: mld_zmlprec_bld
! Version: complex
!
! This routine builds the base preconditioner corresponding to the current
! This routine builds the preconditioner corresponding to the current
! level of the multilevel preconditioner. The routine first builds the
! (coarse) matrix associated to the current level from the (fine) matrix
! associated to the previous level, then builds the related base preconditioner.
@ -53,9 +53,9 @@
! matrix to be preconditioned.
! desc_a - type(psb_desc_type), input.
! The communication descriptor of a.
! p - type(mld_zbaseprc_type), input/output.
! The base preconditioner data structure containing the local
! part of the base preconditioner to be built.
! p - type(mld_z_onelev_type), input/output.
! The preconditioner data structure containing the local
! part of the one-level preconditioner to be built.
! info - integer, output.
! Error code.
!
@ -69,7 +69,7 @@ subroutine mld_zmlprec_bld(a,desc_a,p,info)
! Arguments
type(psb_zspmat_type), intent(in), target :: a
type(psb_desc_type), intent(in), target :: desc_a
type(mld_zbaseprc_type), intent(inout),target :: p
type(mld_z_onelev_prec_type), intent(inout),target :: p
integer, intent(out) :: info
! Local variables
@ -106,16 +106,16 @@ subroutine mld_zmlprec_bld(a,desc_a,p,info)
& mld_max_norm_,is_legal_ml_aggr_eig)
select case(p%iprcparm(mld_sub_solve_))
select case(p%prec%iprcparm(mld_sub_solve_))
case(mld_ilu_n_,mld_milu_n_)
call mld_check_def(p%iprcparm(mld_sub_fillin_),'Level',0,is_legal_ml_lev)
call mld_check_def(p%prec%iprcparm(mld_sub_fillin_),'Level',0,is_legal_ml_lev)
case(mld_ilu_t_)
call mld_check_def(p%rprcparm(mld_sub_iluthrs_),'Eps',dzero,is_legal_fact_thrs)
call mld_check_def(p%prec%rprcparm(mld_sub_iluthrs_),'Eps',dzero,is_legal_fact_thrs)
end select
call mld_check_def(p%prec%iprcparm(mld_smoother_sweeps_),'Jacobi sweeps',&
& 1,is_legal_jac_sweeps)
call mld_check_def(p%rprcparm(mld_aggr_omega_val_),'Omega',dzero,is_legal_omega)
call mld_check_def(p%rprcparm(mld_aggr_thresh_),'Aggr_Thresh',dzero,is_legal_aggr_thrs)
call mld_check_def(p%iprcparm(mld_smoother_sweeps_),'Jacobi sweeps',&
& 1,is_legal_jac_sweeps)
!
! Build a mapping between the row indices of the fine-level matrix
@ -135,7 +135,7 @@ subroutine mld_zmlprec_bld(a,desc_a,p,info)
! the mapping defined by mld_aggrmap_bld and applying the aggregation
! algorithm specified by p%iprcparm(mld_aggr_kind_)
!
call mld_aggrmat_asb(a,desc_a,ac,desc_ac,p,info)
call mld_aggrmat_asb(a,desc_a,p,info)
if(info /= 0) then
call psb_errpush(4010,name,a_err='mld_aggrmat_asb')
goto 9999
@ -144,32 +144,16 @@ subroutine mld_zmlprec_bld(a,desc_a,p,info)
!
! Build the 'base preconditioner' corresponding to the coarse level
!
call mld_baseprc_bld(ac,desc_ac,p,info)
call mld_baseprc_bld(p%ac,p%desc_ac,p%prec,info)
if (info /= 0) then
call psb_errpush(4010,name,a_err='mld_baseprc_bld')
goto 9999
end if
!
! We have used a separate ac because
! 1. we want to reuse the same routines mld_ilu_bld, etc.,
! 2. we do NOT want to pass an argument twice to them (p%av(mld_ac_) and p),
! as this would violate the Fortran standard.
! Hence a separate AC and a TRANSFER function at the end.
! Fix the base_a and base_desc pointers for handling of residuals.
! This is correct because this routine is only called at levels >=2.
!
call psb_sp_transfer(ac,p%av(mld_ac_),info)
p%base_a => p%av(mld_ac_)
if (info==0) call psb_cdtransfer(desc_ac,p%desc_ac,info)
p%map_desc = psb_inter_desc(psb_map_aggr_,desc_a,&
& p%desc_ac,p%av(mld_sm_pr_t_),p%av(mld_sm_pr_))
! The two matrices from p%av() have been copied, may free them.
if (info == 0) call psb_sp_free(p%av(mld_sm_pr_t_),info)
if (info == 0) call psb_sp_free(p%av(mld_sm_pr_),info)
if (info /= 0) then
call psb_errpush(4010,name,a_err='psb_cdtransfer')
goto 9999
end if
p%base_a => p%ac
p%base_desc => p%desc_ac
call psb_erractionrestore(err_act)

14
mlprec/mld_zprec_aply.f90
Unescape Escape View File

@ -120,25 +120,25 @@ subroutine mld_zprec_aply(prec,x,y,desc_data,info,trans,work)
end if
if (.not.(allocated(prec%baseprecv))) then
if (.not.(allocated(prec%precv))) then
!! Error 1: should call mld_dprecbld
info=3112
call psb_errpush(info,name)
goto 9999
end if
if (size(prec%baseprecv) >1) then
call mld_mlprec_aply(zone,prec%baseprecv,x,zzero,y,desc_data,trans_,work_,info)
if (size(prec%precv) >1) then
call mld_mlprec_aply(zone,prec%precv,x,zzero,y,desc_data,trans_,work_,info)
if(info /= 0) then
call psb_errpush(4010,name,a_err='mld_zmlprec_aply')
goto 9999
end if
else if (size(prec%baseprecv) == 1) then
call mld_baseprec_aply(zone,prec%baseprecv(1),x,zzero,y,desc_data,trans_, work_,info)
else if (size(prec%precv) == 1) then
call mld_baseprec_aply(zone,prec%precv(1)%prec,x,zzero,y,desc_data,trans_, work_,info)
else
info = 4013
call psb_errpush(info,name,a_err='Invalid size of baseprecv',&
& i_Err=(/size(prec%baseprecv),0,0,0,0/))
call psb_errpush(info,name,a_err='Invalid size of precv',&
& i_Err=(/size(prec%precv),0,0,0,0/))
goto 9999
endif

77
mlprec/mld_zprecbld.f90
Unescape Escape View File

@ -119,8 +119,8 @@ subroutine mld_zprecbld(a,desc_a,p,info)
!!$ endif
upd_ = 'F'
if (.not.allocated(p%baseprecv)) then
!! Error: should have called mld_dprecinit
if (.not.allocated(p%precv)) then
!! Error: should have called mld_zprecinit
info=3111
call psb_errpush(info,name)
goto 9999
@ -129,11 +129,11 @@ subroutine mld_zprecbld(a,desc_a,p,info)
!
! Check to ensure all procs have the same
!
iszv = size(p%baseprecv)
iszv = size(p%precv)
call psb_bcast(ictxt,iszv)
if (iszv /= size(p%baseprecv)) then
if (iszv /= size(p%precv)) then
info=4001
call psb_errpush(info,name,a_err='Inconsistent size of baseprecv')
call psb_errpush(info,name,a_err='Inconsistent size of precv')
goto 9999
end if
@ -142,18 +142,20 @@ subroutine mld_zprecbld(a,desc_a,p,info)
! Check on the iprcparm contents: they should be the same
! on all processes.
!
if (me == psb_root_) ipv(:) = p%baseprecv(1)%iprcparm(:)
if (me == psb_root_) ipv(:) = p%precv(1)%iprcparm(:)
call psb_bcast(ictxt,ipv)
if (any(ipv(:) /= p%baseprecv(1)%iprcparm(:) )) then
if (any(ipv(:) /= p%precv(1)%iprcparm(:) )) then
write(debug_unit,*) me,name,&
&': Inconsistent arguments among processes, forcing a default'
p%baseprecv(1)%iprcparm(:) = ipv(:)
p%precv(1)%iprcparm(:) = ipv(:)
end if
!
! Allocate and build the fine level preconditioner
! Finest level first; remember to fix base_a and base_desc
!
call init_baseprc_av(p%baseprecv(1),info)
if (info == 0) call mld_baseprc_bld(a,desc_a,p%baseprecv(1),info,upd_)
call init_baseprc_av(p%precv(1)%prec,info)
if (info == 0) call mld_baseprc_bld(a,desc_a,p%precv(1)%prec,info,upd_)
p%precv(1)%base_a => a
p%precv(1)%base_desc => desc_a
if (info /= 0) then
call psb_errpush(4001,name,a_err='Base level precbuild.')
@ -178,69 +180,69 @@ subroutine mld_zprecbld(a,desc_a,p,info)
! Check on the iprcparm contents: they should be the same
! on all processes.
!
if (me == psb_root_) ipv(:) = p%baseprecv(i)%iprcparm(:)
if (me == psb_root_) ipv(:) = p%precv(i)%iprcparm(:)
call psb_bcast(ictxt,ipv)
if (any(ipv(:) /= p%baseprecv(i)%iprcparm(:) )) then
if (any(ipv(:) /= p%precv(i)%iprcparm(:) )) then
write(debug_unit,*) me,name,&
&': Inconsistent arguments among processes, resetting.'
p%baseprecv(i)%iprcparm(:) = ipv(:)
p%precv(i)%iprcparm(:) = ipv(:)
end if
!
! Allocate the av component of the preconditioner data type
! at level i
! Sanity checks on the parameters
!
if (i<iszv) then
!
! A replicated matrix only makes sense at the coarsest level
!
call mld_check_def(p%baseprecv(i)%iprcparm(mld_coarse_mat_),'Coarse matrix',&
call mld_check_def(p%precv(i)%iprcparm(mld_coarse_mat_),'Coarse matrix',&
& mld_distr_mat_,is_distr_ml_coarse_mat)
else if (i == iszv) then
!
! At the coarsest level, check mld_coarse_solve_
!
val = p%baseprecv(i)%iprcparm(mld_coarse_solve_)
val = p%precv(i)%iprcparm(mld_coarse_solve_)
select case (val)
case(mld_umf_, mld_slu_)
if ((p%baseprecv(i)%iprcparm(mld_coarse_mat_) /= mld_repl_mat_).or.&
& (p%baseprecv(i)%iprcparm(mld_sub_solve_) /= val)) then
if ((p%precv(i)%iprcparm(mld_coarse_mat_) /= mld_repl_mat_).or.&
& (p%precv(i)%prec%iprcparm(mld_sub_solve_) /= val)) then
if (me == 0) write(debug_unit,*)&
& 'Warning: inconsistent coarse level specification.'
if (me == 0) write(debug_unit,*)&
& ' Resetting according to the value specified for mld_coarse_solve_.'
p%baseprecv(i)%iprcparm(mld_coarse_mat_) = mld_repl_mat_
p%baseprecv(i)%iprcparm(mld_sub_solve_) = val
p%baseprecv(i)%iprcparm(mld_smoother_type_) = mld_bjac_
p%precv(i)%iprcparm(mld_coarse_mat_) = mld_repl_mat_
p%precv(i)%prec%iprcparm(mld_sub_solve_) = val
p%precv(i)%prec%iprcparm(mld_smoother_type_) = mld_bjac_
end if
case(mld_sludist_)
if ((p%baseprecv(i)%iprcparm(mld_coarse_mat_) /= mld_distr_mat_).or.&
& (p%baseprecv(i)%iprcparm(mld_sub_solve_) /= val)) then
if ((p%precv(i)%iprcparm(mld_coarse_mat_) /= mld_distr_mat_).or.&
& (p%precv(i)%prec%iprcparm(mld_sub_solve_) /= val)) then
if (me == 0) write(debug_unit,*)&
& 'Warning: inconsistent coarse level specification.'
if (me == 0) write(debug_unit,*)&
& ' Resetting according to the value specified for mld_coarse_solve_.'
p%baseprecv(i)%iprcparm(mld_coarse_mat_) = mld_distr_mat_
p%baseprecv(i)%iprcparm(mld_sub_solve_) = val
p%baseprecv(i)%iprcparm(mld_smoother_type_) = mld_bjac_
p%baseprecv(i)%iprcparm(mld_smoother_sweeps_) = 1
p%precv(i)%iprcparm(mld_coarse_mat_) = mld_distr_mat_
p%precv(i)%prec%iprcparm(mld_sub_solve_) = val
p%precv(i)%prec%iprcparm(mld_smoother_type_) = mld_bjac_
p%precv(i)%prec%iprcparm(mld_smoother_sweeps_) = 1
end if
end select
end if
call init_baseprc_av(p%baseprecv(i),info)
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'Calling mlprcbld at level ',i
!
! Build the base preconditioner corresponding to level i
! Allocate and build the preconditioner at level i.
! baseprec_bld is called inside mlprec_bld.
!
if (info == 0) call mld_mlprec_bld(p%baseprecv(i-1)%base_a,&
& p%baseprecv(i-1)%base_desc, p%baseprecv(i),info)
call init_baseprc_av(p%precv(i)%prec,info)
if (info == 0) call mld_mlprec_bld(p%precv(i-1)%base_a,&
& p%precv(i-1)%base_desc, p%precv(i),info)
if (info /= 0) then
call psb_errpush(4001,name,a_err='Init & build upper level preconditioner')
goto 9999
@ -250,11 +252,14 @@ subroutine mld_zprecbld(a,desc_a,p,info)
& write(debug_unit,*) me,' ',trim(name),&
& 'Return from ',i,' call to mlprcbld ',info
end do
!
! Check on sizes from level 2 onwards
!
if (me==0) then
k = iszv+1
do i=iszv,3,-1
if (all(p%baseprecv(i)%nlaggr == p%baseprecv(i-1)%nlaggr)) then
if (all(p%precv(i)%nlaggr == p%precv(i-1)%nlaggr)) then
k=i-1
end if
end do

8
mlprec/mld_zprecfree.f90
Unescape Escape View File

@ -74,11 +74,11 @@ subroutine mld_zprecfree(p,info)
me=-1
if (allocated(p%baseprecv)) then
do i=1,size(p%baseprecv)
call mld_base_precfree(p%baseprecv(i),info)
if (allocated(p%precv)) then
do i=1,size(p%precv)
call mld_onelev_precfree(p%precv(i),info)
end do
deallocate(p%baseprecv)
deallocate(p%precv)
end if
call psb_erractionrestore(err_act)
return

242
mlprec/mld_zprecinit.F90
Unescape Escape View File

@ -104,7 +104,7 @@ subroutine mld_zprecinit(p,ptype,info,nlev)
character(len=*), parameter :: name='mld_precinit'
info = 0
if (allocated(p%baseprecv)) then
if (allocated(p%precv)) then
call mld_precfree(p,info)
if (info /=0) then
! Do we want to do something?
@ -115,68 +115,88 @@ subroutine mld_zprecinit(p,ptype,info,nlev)
case ('NOPREC')
nlev_ = 1
ilev_ = 1
allocate(p%baseprecv(nlev_),stat=info)
if (info == 0) call psb_realloc(mld_ifpsz_,p%baseprecv(ilev_)%iprcparm,info)
if (info == 0) call psb_realloc(mld_rfpsz_,p%baseprecv(ilev_)%rprcparm,info)
allocate(p%precv(nlev_),stat=info)
if (info == 0) call psb_realloc(mld_ifpsz_,p%precv(ilev_)%iprcparm,info)
if (info == 0) call psb_realloc(mld_rfpsz_,p%precv(ilev_)%rprcparm,info)
if (info == 0) call psb_realloc(mld_ifpsz_,p%precv(ilev_)%prec%iprcparm,info)
if (info == 0) call psb_realloc(mld_rfpsz_,p%precv(ilev_)%prec%rprcparm,info)
if (info /= 0) return
p%baseprecv(ilev_)%iprcparm(:) = 0
p%baseprecv(ilev_)%iprcparm(mld_smoother_type_) = mld_noprec_
p%baseprecv(ilev_)%iprcparm(mld_sub_solve_) = mld_f_none_
p%baseprecv(ilev_)%iprcparm(mld_sub_restr_) = psb_none_
p%baseprecv(ilev_)%iprcparm(mld_sub_prol_) = psb_none_
p%baseprecv(ilev_)%iprcparm(mld_sub_ren_) = 0
p%baseprecv(ilev_)%iprcparm(mld_sub_ovr_) = 0
p%baseprecv(ilev_)%iprcparm(mld_smoother_sweeps_) = 1
p%precv(ilev_)%iprcparm(:) = 0
p%precv(ilev_)%rprcparm(:) = dzero
p%precv(ilev_)%prec%iprcparm(:) = 0
p%precv(ilev_)%prec%rprcparm(:) = dzero
p%precv(ilev_)%prec%iprcparm(mld_smoother_type_) = mld_noprec_
p%precv(ilev_)%prec%iprcparm(mld_sub_solve_) = mld_f_none_
p%precv(ilev_)%prec%iprcparm(mld_sub_restr_) = psb_none_
p%precv(ilev_)%prec%iprcparm(mld_sub_prol_) = psb_none_
p%precv(ilev_)%prec%iprcparm(mld_sub_ren_) = 0
p%precv(ilev_)%prec%iprcparm(mld_sub_ovr_) = 0
p%precv(ilev_)%prec%iprcparm(mld_smoother_sweeps_) = 1
case ('DIAG')
nlev_ = 1
ilev_ = 1
allocate(p%baseprecv(nlev_),stat=info)
if (info == 0) call psb_realloc(mld_ifpsz_,p%baseprecv(ilev_)%iprcparm,info)
if (info == 0) call psb_realloc(mld_rfpsz_,p%baseprecv(ilev_)%rprcparm,info)
allocate(p%precv(nlev_),stat=info)
if (info == 0) call psb_realloc(mld_ifpsz_,p%precv(ilev_)%iprcparm,info)
if (info == 0) call psb_realloc(mld_rfpsz_,p%precv(ilev_)%rprcparm,info)
if (info == 0) call psb_realloc(mld_ifpsz_,p%precv(ilev_)%prec%iprcparm,info)
if (info == 0) call psb_realloc(mld_rfpsz_,p%precv(ilev_)%prec%rprcparm,info)
if (info /= 0) return
p%baseprecv(ilev_)%iprcparm(:) = 0
p%baseprecv(ilev_)%iprcparm(mld_smoother_type_) = mld_diag_
p%baseprecv(ilev_)%iprcparm(mld_sub_solve_) = mld_f_none_
p%baseprecv(ilev_)%iprcparm(mld_sub_restr_) = psb_none_
p%baseprecv(ilev_)%iprcparm(mld_sub_prol_) = psb_none_
p%baseprecv(ilev_)%iprcparm(mld_sub_ren_) = 0
p%baseprecv(ilev_)%iprcparm(mld_sub_ovr_) = 0
p%baseprecv(ilev_)%iprcparm(mld_smoother_sweeps_) = 1
p%precv(ilev_)%iprcparm(:) = 0
p%precv(ilev_)%rprcparm(:) = dzero
p%precv(ilev_)%prec%iprcparm(:) = 0
p%precv(ilev_)%prec%rprcparm(:) = dzero
p%precv(ilev_)%prec%iprcparm(mld_smoother_type_) = mld_diag_
p%precv(ilev_)%prec%iprcparm(mld_sub_solve_) = mld_f_none_
p%precv(ilev_)%prec%iprcparm(mld_sub_restr_) = psb_none_
p%precv(ilev_)%prec%iprcparm(mld_sub_prol_) = psb_none_
p%precv(ilev_)%prec%iprcparm(mld_sub_ren_) = 0
p%precv(ilev_)%prec%iprcparm(mld_sub_ovr_) = 0
p%precv(ilev_)%prec%iprcparm(mld_smoother_sweeps_) = 1
case ('BJAC')
nlev_ = 1
ilev_ = 1
allocate(p%baseprecv(nlev_),stat=info)
if (info == 0) call psb_realloc(mld_ifpsz_,p%baseprecv(ilev_)%iprcparm,info)
if (info == 0) call psb_realloc(mld_rfpsz_,p%baseprecv(ilev_)%rprcparm,info)
allocate(p%precv(nlev_),stat=info)
if (info == 0) call psb_realloc(mld_ifpsz_,p%precv(ilev_)%iprcparm,info)
if (info == 0) call psb_realloc(mld_rfpsz_,p%precv(ilev_)%rprcparm,info)
if (info == 0) call psb_realloc(mld_ifpsz_,p%precv(ilev_)%prec%iprcparm,info)
if (info == 0) call psb_realloc(mld_rfpsz_,p%precv(ilev_)%prec%rprcparm,info)
if (info /= 0) return
p%baseprecv(ilev_)%iprcparm(:) = 0
p%baseprecv(ilev_)%iprcparm(mld_smoother_type_) = mld_bjac_
p%baseprecv(ilev_)%iprcparm(mld_sub_solve_) = mld_ilu_n_
p%baseprecv(ilev_)%iprcparm(mld_sub_restr_) = psb_none_
p%baseprecv(ilev_)%iprcparm(mld_sub_prol_) = psb_none_
p%baseprecv(ilev_)%iprcparm(mld_sub_ren_) = 0
p%baseprecv(ilev_)%iprcparm(mld_sub_ovr_) = 0
p%baseprecv(ilev_)%iprcparm(mld_sub_fillin_) = 0
p%baseprecv(ilev_)%iprcparm(mld_smoother_sweeps_) = 1
p%precv(ilev_)%iprcparm(:) = 0
p%precv(ilev_)%rprcparm(:) = dzero
p%precv(ilev_)%prec%iprcparm(:) = 0
p%precv(ilev_)%prec%rprcparm(:) = dzero
p%precv(ilev_)%prec%iprcparm(mld_smoother_type_) = mld_bjac_
p%precv(ilev_)%prec%iprcparm(mld_sub_solve_) = mld_ilu_n_
p%precv(ilev_)%prec%iprcparm(mld_sub_restr_) = psb_none_
p%precv(ilev_)%prec%iprcparm(mld_sub_prol_) = psb_none_
p%precv(ilev_)%prec%iprcparm(mld_sub_ren_) = 0
p%precv(ilev_)%prec%iprcparm(mld_sub_ovr_) = 0
p%precv(ilev_)%prec%iprcparm(mld_sub_fillin_) = 0
p%precv(ilev_)%prec%iprcparm(mld_smoother_sweeps_) = 1
case ('AS')
nlev_ = 1
ilev_ = 1
allocate(p%baseprecv(nlev_),stat=info)
if (info == 0) call psb_realloc(mld_ifpsz_,p%baseprecv(ilev_)%iprcparm,info)
if (info == 0) call psb_realloc(mld_rfpsz_,p%baseprecv(ilev_)%rprcparm,info)
allocate(p%precv(nlev_),stat=info)
if (info == 0) call psb_realloc(mld_ifpsz_,p%precv(ilev_)%iprcparm,info)
if (info == 0) call psb_realloc(mld_rfpsz_,p%precv(ilev_)%rprcparm,info)
if (info == 0) call psb_realloc(mld_ifpsz_,p%precv(ilev_)%prec%iprcparm,info)
if (info == 0) call psb_realloc(mld_rfpsz_,p%precv(ilev_)%prec%rprcparm,info)
if (info /= 0) return
p%baseprecv(ilev_)%iprcparm(:) = 0
p%baseprecv(ilev_)%iprcparm(mld_smoother_type_) = mld_as_
p%baseprecv(ilev_)%iprcparm(mld_sub_solve_) = mld_ilu_n_
p%baseprecv(ilev_)%iprcparm(mld_sub_restr_) = psb_halo_
p%baseprecv(ilev_)%iprcparm(mld_sub_prol_) = psb_none_
p%baseprecv(ilev_)%iprcparm(mld_sub_ren_) = 0
p%baseprecv(ilev_)%iprcparm(mld_sub_ovr_) = 1
p%baseprecv(ilev_)%iprcparm(mld_sub_fillin_) = 0
p%baseprecv(ilev_)%iprcparm(mld_smoother_sweeps_) = 1
p%precv(ilev_)%iprcparm(:) = 0
p%precv(ilev_)%rprcparm(:) = dzero
p%precv(ilev_)%prec%iprcparm(:) = 0
p%precv(ilev_)%prec%rprcparm(:) = dzero
p%precv(ilev_)%prec%iprcparm(mld_smoother_type_) = mld_as_
p%precv(ilev_)%prec%iprcparm(mld_sub_solve_) = mld_ilu_n_
p%precv(ilev_)%prec%iprcparm(mld_sub_restr_) = psb_halo_
p%precv(ilev_)%prec%iprcparm(mld_sub_prol_) = psb_none_
p%precv(ilev_)%prec%iprcparm(mld_sub_ren_) = 0
p%precv(ilev_)%prec%iprcparm(mld_sub_ovr_) = 1
p%precv(ilev_)%prec%iprcparm(mld_sub_fillin_) = 0
p%precv(ilev_)%prec%iprcparm(mld_smoother_sweeps_) = 1
case ('ML')
@ -187,76 +207,88 @@ subroutine mld_zprecinit(p,ptype,info,nlev)
nlev_ = 2
end if
ilev_ = 1
allocate(p%baseprecv(nlev_),stat=info)
if (info == 0) call psb_realloc(mld_ifpsz_,p%baseprecv(ilev_)%iprcparm,info)
if (info == 0) call psb_realloc(mld_rfpsz_,p%baseprecv(ilev_)%rprcparm,info)
allocate(p%precv(nlev_),stat=info)
if (info == 0) call psb_realloc(mld_ifpsz_,p%precv(ilev_)%iprcparm,info)
if (info == 0) call psb_realloc(mld_rfpsz_,p%precv(ilev_)%rprcparm,info)
if (info == 0) call psb_realloc(mld_ifpsz_,p%precv(ilev_)%prec%iprcparm,info)
if (info == 0) call psb_realloc(mld_rfpsz_,p%precv(ilev_)%prec%rprcparm,info)
if (info /= 0) return
p%baseprecv(ilev_)%iprcparm(:) = 0
p%baseprecv(ilev_)%rprcparm(:) = dzero
p%baseprecv(ilev_)%iprcparm(mld_smoother_type_) = mld_as_
p%baseprecv(ilev_)%iprcparm(mld_sub_solve_) = mld_ilu_n_
p%baseprecv(ilev_)%iprcparm(mld_sub_restr_) = psb_halo_
p%baseprecv(ilev_)%iprcparm(mld_sub_prol_) = psb_none_
p%baseprecv(ilev_)%iprcparm(mld_sub_ren_) = 0
p%baseprecv(ilev_)%iprcparm(mld_sub_ovr_) = 1
p%baseprecv(ilev_)%iprcparm(mld_sub_fillin_) = 0
p%baseprecv(ilev_)%iprcparm(mld_smoother_sweeps_) = 1
p%precv(ilev_)%iprcparm(:) = 0
p%precv(ilev_)%rprcparm(:) = dzero
p%precv(ilev_)%prec%iprcparm(:) = 0
p%precv(ilev_)%prec%rprcparm(:) = dzero
p%precv(ilev_)%prec%iprcparm(mld_smoother_type_) = mld_as_
p%precv(ilev_)%prec%iprcparm(mld_sub_solve_) = mld_ilu_n_
p%precv(ilev_)%prec%iprcparm(mld_sub_restr_) = psb_halo_
p%precv(ilev_)%prec%iprcparm(mld_sub_prol_) = psb_none_
p%precv(ilev_)%prec%iprcparm(mld_sub_ren_) = 0
p%precv(ilev_)%prec%iprcparm(mld_sub_ovr_) = 1
p%precv(ilev_)%prec%iprcparm(mld_sub_fillin_) = 0
p%precv(ilev_)%prec%iprcparm(mld_smoother_sweeps_) = 1
if (nlev_ == 1) return
do ilev_ = 2, nlev_ -1
if (info == 0) call psb_realloc(mld_ifpsz_,p%baseprecv(ilev_)%iprcparm,info)
if (info == 0) call psb_realloc(mld_rfpsz_,p%baseprecv(ilev_)%rprcparm,info)
if (info == 0) call psb_realloc(mld_ifpsz_,p%precv(ilev_)%iprcparm,info)
if (info == 0) call psb_realloc(mld_rfpsz_,p%precv(ilev_)%rprcparm,info)
if (info == 0) call psb_realloc(mld_ifpsz_,p%precv(ilev_)%prec%iprcparm,info)
if (info == 0) call psb_realloc(mld_rfpsz_,p%precv(ilev_)%prec%rprcparm,info)
if (info /= 0) return
p%baseprecv(ilev_)%iprcparm(:) = 0
p%baseprecv(ilev_)%rprcparm(:) = dzero
p%baseprecv(ilev_)%iprcparm(mld_smoother_type_) = mld_as_
p%baseprecv(ilev_)%iprcparm(mld_sub_restr_) = psb_halo_
p%baseprecv(ilev_)%iprcparm(mld_sub_prol_) = psb_none_
p%baseprecv(ilev_)%iprcparm(mld_sub_ren_) = 0
p%baseprecv(ilev_)%iprcparm(mld_sub_ovr_) = 1
p%baseprecv(ilev_)%iprcparm(mld_ml_type_) = mld_mult_ml_
p%baseprecv(ilev_)%iprcparm(mld_aggr_alg_) = mld_dec_aggr_
p%baseprecv(ilev_)%iprcparm(mld_aggr_kind_) = mld_smooth_prol_
p%baseprecv(ilev_)%iprcparm(mld_coarse_mat_) = mld_distr_mat_
p%baseprecv(ilev_)%iprcparm(mld_smoother_pos_) = mld_post_smooth_
p%baseprecv(ilev_)%iprcparm(mld_aggr_omega_alg_) = mld_eig_est_
p%baseprecv(ilev_)%iprcparm(mld_aggr_eig_) = mld_max_norm_
p%baseprecv(ilev_)%iprcparm(mld_sub_solve_) = mld_ilu_n_
p%baseprecv(ilev_)%iprcparm(mld_sub_fillin_) = 0
p%baseprecv(ilev_)%iprcparm(mld_smoother_sweeps_) = 1
p%baseprecv(ilev_)%rprcparm(mld_aggr_omega_val_) = dzero
p%baseprecv(ilev_)%rprcparm(mld_aggr_thresh_) = dzero
p%precv(ilev_)%iprcparm(:) = 0
p%precv(ilev_)%rprcparm(:) = dzero
p%precv(ilev_)%prec%iprcparm(:) = 0
p%precv(ilev_)%prec%rprcparm(:) = dzero
p%precv(ilev_)%prec%iprcparm(mld_smoother_type_) = mld_as_
p%precv(ilev_)%prec%iprcparm(mld_sub_restr_) = psb_halo_
p%precv(ilev_)%prec%iprcparm(mld_sub_prol_) = psb_none_
p%precv(ilev_)%prec%iprcparm(mld_sub_ren_) = 0
p%precv(ilev_)%prec%iprcparm(mld_sub_ovr_) = 1
p%precv(ilev_)%prec%iprcparm(mld_sub_solve_) = mld_ilu_n_
p%precv(ilev_)%prec%iprcparm(mld_sub_fillin_) = 0
p%precv(ilev_)%prec%iprcparm(mld_smoother_sweeps_) = 1
p%precv(ilev_)%iprcparm(mld_ml_type_) = mld_mult_ml_
p%precv(ilev_)%iprcparm(mld_aggr_alg_) = mld_dec_aggr_
p%precv(ilev_)%iprcparm(mld_aggr_kind_) = mld_smooth_prol_
p%precv(ilev_)%iprcparm(mld_coarse_mat_) = mld_distr_mat_
p%precv(ilev_)%iprcparm(mld_smoother_pos_) = mld_post_smooth_
p%precv(ilev_)%iprcparm(mld_aggr_omega_alg_) = mld_eig_est_
p%precv(ilev_)%iprcparm(mld_aggr_eig_) = mld_max_norm_
p%precv(ilev_)%rprcparm(mld_aggr_omega_val_) = dzero
p%precv(ilev_)%rprcparm(mld_aggr_thresh_) = dzero
end do
ilev_ = nlev_
if (info == 0) call psb_realloc(mld_ifpsz_,p%baseprecv(ilev_)%iprcparm,info)
if (info == 0) call psb_realloc(mld_rfpsz_,p%baseprecv(ilev_)%rprcparm,info)
if (info == 0) call psb_realloc(mld_ifpsz_,p%precv(ilev_)%iprcparm,info)
if (info == 0) call psb_realloc(mld_rfpsz_,p%precv(ilev_)%rprcparm,info)
if (info == 0) call psb_realloc(mld_ifpsz_,p%precv(ilev_)%prec%iprcparm,info)
if (info == 0) call psb_realloc(mld_rfpsz_,p%precv(ilev_)%prec%rprcparm,info)
if (info /= 0) return
p%baseprecv(ilev_)%iprcparm(:) = 0
p%baseprecv(ilev_)%rprcparm(:) = dzero
p%baseprecv(ilev_)%iprcparm(mld_coarse_solve_) = mld_bjac_
p%precv(ilev_)%iprcparm(:) = 0
p%precv(ilev_)%rprcparm(:) = dzero
p%precv(ilev_)%prec%iprcparm(:) = 0
p%precv(ilev_)%prec%rprcparm(:) = dzero
p%precv(ilev_)%prec%iprcparm(mld_coarse_solve_) = mld_bjac_
#if defined(HAVE_UMF_)
p%baseprecv(ilev_)%iprcparm(mld_sub_solve_) = mld_umf_
p%precv(ilev_)%prec%iprcparm(mld_sub_solve_) = mld_umf_
#elif defined(HAVE_SLU_)
p%baseprecv(ilev_)%iprcparm(mld_sub_solve_) = mld_slu_
p%precv(ilev_)%prec%iprcparm(mld_sub_solve_) = mld_slu_
#else
p%baseprecv(ilev_)%iprcparm(mld_sub_solve_) = mld_ilu_n_
p%precv(ilev_)%prec%iprcparm(mld_sub_solve_) = mld_ilu_n_
#endif
p%baseprecv(ilev_)%iprcparm(mld_smoother_type_) = mld_bjac_
p%baseprecv(ilev_)%iprcparm(mld_coarse_mat_) = mld_distr_mat_
p%baseprecv(ilev_)%iprcparm(mld_sub_restr_) = psb_none_
p%baseprecv(ilev_)%iprcparm(mld_sub_prol_) = psb_none_
p%baseprecv(ilev_)%iprcparm(mld_sub_ren_) = 0
p%baseprecv(ilev_)%iprcparm(mld_sub_ovr_) = 0
p%baseprecv(ilev_)%iprcparm(mld_ml_type_) = mld_mult_ml_
p%baseprecv(ilev_)%iprcparm(mld_aggr_alg_) = mld_dec_aggr_
p%baseprecv(ilev_)%iprcparm(mld_aggr_kind_) = mld_smooth_prol_
p%baseprecv(ilev_)%iprcparm(mld_smoother_pos_) = mld_post_smooth_
p%baseprecv(ilev_)%iprcparm(mld_aggr_omega_alg_) = mld_eig_est_
p%baseprecv(ilev_)%iprcparm(mld_aggr_eig_) = mld_max_norm_
p%baseprecv(ilev_)%iprcparm(mld_sub_fillin_) = 0
p%baseprecv(ilev_)%iprcparm(mld_smoother_sweeps_) = 4
p%baseprecv(ilev_)%rprcparm(mld_aggr_omega_val_) = dzero
p%baseprecv(ilev_)%rprcparm(mld_aggr_thresh_) = dzero
p%precv(ilev_)%prec%iprcparm(mld_smoother_type_) = mld_bjac_
p%precv(ilev_)%prec%iprcparm(mld_coarse_mat_) = mld_distr_mat_
p%precv(ilev_)%prec%iprcparm(mld_sub_restr_) = psb_none_
p%precv(ilev_)%prec%iprcparm(mld_sub_prol_) = psb_none_
p%precv(ilev_)%prec%iprcparm(mld_sub_ren_) = 0
p%precv(ilev_)%prec%iprcparm(mld_sub_ovr_) = 0
p%precv(ilev_)%prec%iprcparm(mld_sub_fillin_) = 0
p%precv(ilev_)%prec%iprcparm(mld_smoother_sweeps_) = 4
p%precv(ilev_)%iprcparm(mld_ml_type_) = mld_mult_ml_
p%precv(ilev_)%iprcparm(mld_aggr_alg_) = mld_dec_aggr_
p%precv(ilev_)%iprcparm(mld_aggr_kind_) = mld_smooth_prol_
p%precv(ilev_)%iprcparm(mld_smoother_pos_) = mld_post_smooth_
p%precv(ilev_)%iprcparm(mld_aggr_omega_alg_) = mld_eig_est_
p%precv(ilev_)%iprcparm(mld_aggr_eig_) = mld_max_norm_
p%precv(ilev_)%rprcparm(mld_aggr_omega_val_) = dzero
p%precv(ilev_)%rprcparm(mld_aggr_thresh_) = dzero
case default
write(0,*) name,': Warning: Unknown preconditioner type request "',ptype,'"'

114
mlprec/mld_zprecset.f90
Unescape Escape View File

@ -97,12 +97,12 @@ subroutine mld_zprecseti(p,what,val,info,ilev)
info = 0
if (.not.allocated(p%baseprecv)) then
if (.not.allocated(p%precv)) then
info = 3111
write(0,*) name,': Error: uninitialized preconditioner, should call MLD_PRECINIT'
return
endif
nlev_ = size(p%baseprecv)
nlev_ = size(p%precv)
if (present(ilev)) then
ilev_ = ilev
@ -115,7 +115,13 @@ subroutine mld_zprecseti(p,what,val,info,ilev)
write(0,*) name,': Error: invalid ILEV/NLEV combination',ilev_, nlev_
return
endif
if (.not.allocated(p%baseprecv(ilev_)%iprcparm)) then
if (.not.allocated(p%precv(ilev_)%iprcparm)) then
info = 3111
write(0,*) name,&
&': Error: uninitialized preconditioner component, should call MLD_PRECINIT'
return
endif
if (.not.allocated(p%precv(ilev_)%prec%iprcparm)) then
info = 3111
write(0,*) name,&
&': Error: uninitialized preconditioner component, should call MLD_PRECINIT'
@ -134,7 +140,7 @@ subroutine mld_zprecseti(p,what,val,info,ilev)
select case(what)
case(mld_smoother_type_,mld_sub_solve_,mld_sub_restr_,mld_sub_prol_,&
& mld_sub_ren_,mld_sub_ovr_,mld_sub_fillin_,mld_smoother_sweeps_)
p%baseprecv(ilev_)%iprcparm(what) = val
p%precv(ilev_)%prec%iprcparm(what) = val
case default
write(0,*) name,': Error: invalid WHAT'
info = -2
@ -144,23 +150,25 @@ subroutine mld_zprecseti(p,what,val,info,ilev)
select case(what)
case(mld_smoother_type_,mld_sub_solve_,mld_sub_restr_,mld_sub_prol_,&
& mld_sub_ren_,mld_sub_ovr_,mld_sub_fillin_,&
& mld_smoother_sweeps_,mld_ml_type_,mld_aggr_alg_,mld_aggr_kind_,&
& mld_smoother_sweeps_)
p%precv(ilev_)%prec%iprcparm(what) = val
case(mld_ml_type_,mld_aggr_alg_,mld_aggr_kind_,&
& mld_smoother_pos_,mld_aggr_omega_alg_,mld_aggr_eig_)
p%baseprecv(ilev_)%iprcparm(what) = val
p%precv(ilev_)%iprcparm(what) = val
case(mld_coarse_mat_)
if (ilev_ /= nlev_ .and. val /= mld_distr_mat_) then
write(0,*) name,': Error: Inconsistent specification of WHAT vs. ILEV'
info = -2
return
end if
p%baseprecv(ilev_)%iprcparm(mld_coarse_mat_) = val
p%precv(ilev_)%iprcparm(mld_coarse_mat_) = val
case(mld_coarse_subsolve_)
if (ilev_ /= nlev_) then
write(0,*) name,': Error: Inconsistent specification of WHAT vs. ILEV'
info = -2
return
end if
p%baseprecv(ilev_)%iprcparm(mld_sub_solve_) = val
p%precv(ilev_)%iprcparm(mld_sub_solve_) = val
case(mld_coarse_solve_)
if (ilev_ /= nlev_) then
write(0,*) name,': Error: Inconsistent specification of WHAT vs. ILEV'
@ -169,15 +177,15 @@ subroutine mld_zprecseti(p,what,val,info,ilev)
end if
if (nlev_ > 1) then
p%baseprecv(nlev_)%iprcparm(mld_coarse_solve_) = val
p%baseprecv(nlev_)%iprcparm(mld_smoother_type_) = mld_bjac_
p%baseprecv(nlev_)%iprcparm(mld_coarse_mat_) = mld_distr_mat_
p%precv(nlev_)%iprcparm(mld_coarse_solve_) = val
p%precv(nlev_)%prec%iprcparm(mld_smoother_type_) = mld_bjac_
p%precv(nlev_)%iprcparm(mld_coarse_mat_) = mld_distr_mat_
select case (val)
case(mld_umf_, mld_slu_)
p%baseprecv(nlev_)%iprcparm(mld_coarse_mat_) = mld_repl_mat_
p%baseprecv(nlev_)%iprcparm(mld_sub_solve_) = val
p%precv(nlev_)%iprcparm(mld_coarse_mat_) = mld_repl_mat_
p%precv(nlev_)%prec%iprcparm(mld_sub_solve_) = val
case(mld_sludist_)
p%baseprecv(nlev_)%iprcparm(mld_sub_solve_) = val
p%precv(nlev_)%prec%iprcparm(mld_sub_solve_) = val
end select
endif
case(mld_coarse_sweeps_)
@ -186,14 +194,14 @@ subroutine mld_zprecseti(p,what,val,info,ilev)
info = -2
return
end if
p%baseprecv(ilev_)%iprcparm(mld_smoother_sweeps_) = val
p%precv(ilev_)%prec%iprcparm(mld_smoother_sweeps_) = val
case(mld_coarse_fillin_)
if (ilev_ /= nlev_) then
write(0,*) name,': Error: Inconsistent specification of WHAT vs. ILEV'
info = -2
return
end if
p%baseprecv(ilev_)%iprcparm(mld_sub_fillin_) = val
p%precv(ilev_)%prec%iprcparm(mld_sub_fillin_) = val
case default
write(0,*) name,': Error: invalid WHAT'
info = -2
@ -211,35 +219,35 @@ subroutine mld_zprecseti(p,what,val,info,ilev)
& mld_sub_ren_,mld_sub_ovr_,mld_sub_fillin_,&
& mld_smoother_sweeps_)
do ilev_=1,max(1,nlev_-1)
if (.not.allocated(p%baseprecv(ilev_)%iprcparm)) then
if (.not.allocated(p%precv(ilev_)%iprcparm)) then
write(0,*) name,&
&': Error: uninitialized preconditioner component, should call MLD_PRECINIT'
info = -1
return
endif
p%baseprecv(ilev_)%iprcparm(what) = val
p%precv(ilev_)%prec%iprcparm(what) = val
end do
case(mld_ml_type_,mld_aggr_alg_,mld_aggr_kind_,&
& mld_smoother_pos_,mld_aggr_omega_alg_,mld_aggr_eig_)
do ilev_=2,nlev_
if (.not.allocated(p%baseprecv(ilev_)%iprcparm)) then
if (.not.allocated(p%precv(ilev_)%iprcparm)) then
write(0,*) name,&
&': Error: uninitialized preconditioner component, should call MLD_PRECINIT'
info = -1
return
endif
p%baseprecv(ilev_)%iprcparm(what) = val
p%precv(ilev_)%iprcparm(what) = val
end do
case(mld_coarse_mat_)
if (.not.allocated(p%baseprecv(nlev_)%iprcparm)) then
if (.not.allocated(p%precv(nlev_)%iprcparm)) then
write(0,*) name,&
& ': Error: uninitialized preconditioner component, should call MLD_PRECINIT'
info = -1
return
endif
if (nlev_ > 1) p%baseprecv(nlev_)%iprcparm(mld_coarse_mat_) = val
if (nlev_ > 1) p%precv(nlev_)%iprcparm(mld_coarse_mat_) = val
case(mld_coarse_solve_)
if (.not.allocated(p%baseprecv(nlev_)%iprcparm)) then
if (.not.allocated(p%precv(nlev_)%iprcparm)) then
write(0,*) name,&
&': Error: uninitialized preconditioner component, should call MLD_PRECINIT'
info = -1
@ -247,42 +255,42 @@ subroutine mld_zprecseti(p,what,val,info,ilev)
endif
if (nlev_ > 1) then
p%baseprecv(nlev_)%iprcparm(mld_coarse_solve_) = val
p%baseprecv(nlev_)%iprcparm(mld_smoother_type_) = mld_bjac_
p%baseprecv(nlev_)%iprcparm(mld_coarse_mat_) = mld_distr_mat_
p%precv(nlev_)%iprcparm(mld_coarse_solve_) = val
p%precv(nlev_)%prec%iprcparm(mld_smoother_type_) = mld_bjac_
p%precv(nlev_)%iprcparm(mld_coarse_mat_) = mld_distr_mat_
select case (val)
case(mld_umf_, mld_slu_)
p%baseprecv(nlev_)%iprcparm(mld_coarse_mat_) = mld_repl_mat_
p%baseprecv(nlev_)%iprcparm(mld_sub_solve_) = val
p%precv(nlev_)%iprcparm(mld_coarse_mat_) = mld_repl_mat_
p%precv(nlev_)%prec%iprcparm(mld_sub_solve_) = val
case(mld_sludist_)
p%baseprecv(nlev_)%iprcparm(mld_sub_solve_) = val
p%precv(nlev_)%prec%iprcparm(mld_sub_solve_) = val
end select
endif
case(mld_coarse_subsolve_)
if (.not.allocated(p%baseprecv(nlev_)%iprcparm)) then
if (.not.allocated(p%precv(nlev_)%iprcparm)) then
write(0,*) name,&
&': Error: uninitialized preconditioner component, should call MLD_PRECINIT'
info = -1
return
end if
if (nlev_ > 1) p%baseprecv(nlev_)%iprcparm(mld_sub_solve_) = val
if (nlev_ > 1) p%precv(nlev_)%prec%iprcparm(mld_sub_solve_) = val
case(mld_coarse_sweeps_)
if (.not.allocated(p%baseprecv(nlev_)%iprcparm)) then
if (.not.allocated(p%precv(nlev_)%iprcparm)) then
write(0,*) name,&
&': Error: uninitialized preconditioner component, should call MLD_PRECINIT'
info = -1
return
endif
if (nlev_ > 1) p%baseprecv(nlev_)%iprcparm(mld_smoother_sweeps_) = val
if (nlev_ > 1) p%precv(nlev_)%prec%iprcparm(mld_smoother_sweeps_) = val
case(mld_coarse_fillin_)
if (.not.allocated(p%baseprecv(nlev_)%iprcparm)) then
if (.not.allocated(p%precv(nlev_)%iprcparm)) then
write(0,*) name,&
&': Error: uninitialized preconditioner component, should call MLD_PRECINIT'
info = -1
return
endif
if (nlev_ > 1) p%baseprecv(nlev_)%iprcparm(mld_sub_fillin_) = val
if (nlev_ > 1) p%precv(nlev_)%prec%iprcparm(mld_sub_fillin_) = val
case default
write(0,*) name,': Error: invalid WHAT'
info = -2
@ -353,11 +361,11 @@ subroutine mld_zprecsetc(p,what,string,info,ilev)
info = 0
if (.not.allocated(p%baseprecv)) then
if (.not.allocated(p%precv)) then
info = 3111
return
endif
nlev_ = size(p%baseprecv)
nlev_ = size(p%precv)
if (present(ilev)) then
ilev_ = ilev
@ -370,7 +378,7 @@ subroutine mld_zprecsetc(p,what,string,info,ilev)
info = -1
return
endif
if (.not.allocated(p%baseprecv(ilev_)%iprcparm)) then
if (.not.allocated(p%precv(ilev_)%iprcparm)) then
write(0,*) name,': Error: uninitialized preconditioner component, should call MLD_PRECINIT'
info = 3111
return
@ -450,19 +458,19 @@ subroutine mld_zprecsetr(p,what,val,info,ilev)
ilev_ = 1
end if
if (.not.allocated(p%baseprecv)) then
if (.not.allocated(p%precv)) then
write(0,*) name,': Error: uninitialized preconditioner, should call MLD_PRECINIT'
info = 3111
return
endif
nlev_ = size(p%baseprecv)
nlev_ = size(p%precv)
if ((ilev_<1).or.(ilev_ > nlev_)) then
write(0,*) name,': Error: invalid ILEV/NLEV combination',ilev_, nlev_
info = -1
return
endif
if (.not.allocated(p%baseprecv(ilev_)%rprcparm)) then
if (.not.allocated(p%precv(ilev_)%rprcparm)) then
write(0,*) name,': Error: uninitialized preconditioner component, should call MLD_PRECINIT'
info = 3111
return
@ -479,7 +487,7 @@ subroutine mld_zprecsetr(p,what,val,info,ilev)
!
select case(what)
case(mld_sub_iluthrs_)
p%baseprecv(ilev_)%rprcparm(what) = val
p%precv(ilev_)%prec%rprcparm(what) = val
case default
write(0,*) name,': Error: invalid WHAT'
info = -2
@ -487,8 +495,10 @@ subroutine mld_zprecsetr(p,what,val,info,ilev)
else if (ilev_ > 1) then
select case(what)
case(mld_aggr_omega_val_,mld_aggr_thresh_,mld_sub_iluthrs_)
p%baseprecv(ilev_)%rprcparm(what) = val
case(mld_sub_iluthrs_)
p%precv(ilev_)%prec%rprcparm(what) = val
case(mld_aggr_omega_val_,mld_aggr_thresh_)
p%precv(ilev_)%rprcparm(what) = val
case default
write(0,*) name,': Error: invalid WHAT'
info = -2
@ -503,38 +513,38 @@ subroutine mld_zprecsetr(p,what,val,info,ilev)
select case(what)
case(mld_sub_iluthrs_)
do ilev_=1,nlev_
if (.not.allocated(p%baseprecv(ilev_)%rprcparm)) then
if (.not.allocated(p%precv(ilev_)%rprcparm)) then
write(0,*) name,': Error: uninitialized preconditioner component, should call MLD_PRECINIT'
info = -1
return
endif
p%baseprecv(ilev_)%rprcparm(what) = val
p%precv(ilev_)%prec%rprcparm(what) = val
end do
case(mld_coarse_iluthrs_)
ilev_=nlev_
if (.not.allocated(p%baseprecv(ilev_)%rprcparm)) then
if (.not.allocated(p%precv(ilev_)%rprcparm)) then
write(0,*) name,': Error: uninitialized preconditioner component, should call MLD_PRECINIT'
info = -1
return
endif
p%baseprecv(ilev_)%rprcparm(mld_sub_iluthrs_) = val
p%precv(ilev_)%prec%rprcparm(mld_sub_iluthrs_) = val
case(mld_aggr_omega_val_)
do ilev_=2,nlev_
if (.not.allocated(p%baseprecv(ilev_)%rprcparm)) then
if (.not.allocated(p%precv(ilev_)%rprcparm)) then
write(0,*) name,': Error: uninitialized preconditioner component, should call MLD_PRECINIT'
info = -1
return
endif
p%baseprecv(ilev_)%rprcparm(what) = val
p%precv(ilev_)%rprcparm(what) = val
end do
case(mld_aggr_thresh_)
do ilev_=2,nlev_
if (.not.allocated(p%baseprecv(ilev_)%rprcparm)) then
if (.not.allocated(p%precv(ilev_)%rprcparm)) then
write(0,*) name,': Error: uninitialized preconditioner component, should call MLD_PRECINIT'
info = -1
return
endif
p%baseprecv(ilev_)%rprcparm(what) = val
p%precv(ilev_)%rprcparm(what) = val
end do
case default
write(0,*) name,': Error: invalid WHAT'

Write Preview
Loading…
Cancel
Save