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

mld2p4-2:

Browse Source 
mlprec/Makefile
 mlprec/impl/Makefile
 mlprec/impl/mld_c_onelev_impl.f90
 mlprec/impl/mld_caggrmat_asb.f90
 mlprec/impl/mld_caggrmat_biz_asb.f90
 mlprec/impl/mld_caggrmat_minnrg_asb.F90
 mlprec/impl/mld_caggrmat_minnrg_asb.f90
 mlprec/impl/mld_caggrmat_nosmth_asb.F90
 mlprec/impl/mld_caggrmat_nosmth_asb.f90
 mlprec/impl/mld_caggrmat_smth_asb.F90
 mlprec/impl/mld_caggrmat_smth_asb.f90
 mlprec/impl/mld_ccoarse_bld.f90
 mlprec/impl/mld_cmlprec_bld.f90
 mlprec/impl/mld_cprecaply.f90
 mlprec/impl/mld_cprecinit.F90
 mlprec/impl/mld_cprecset.F90
 mlprec/impl/mld_d_onelev_impl.f90
 mlprec/impl/mld_daggrmap_bld.f90
 mlprec/impl/mld_daggrmat_asb.f90
 mlprec/impl/mld_daggrmat_biz_asb.f90
 mlprec/impl/mld_daggrmat_minnrg_asb.F90
 mlprec/impl/mld_daggrmat_minnrg_asb.f90
 mlprec/impl/mld_daggrmat_nosmth_asb.F90
 mlprec/impl/mld_daggrmat_nosmth_asb.f90
 mlprec/impl/mld_daggrmat_smth_asb.F90
 mlprec/impl/mld_daggrmat_smth_asb.f90
 mlprec/impl/mld_dcoarse_bld.f90
 mlprec/impl/mld_dmlprec_bld.f90
 mlprec/impl/mld_dprecaply.f90
 mlprec/impl/mld_dprecinit.F90
 mlprec/impl/mld_dprecset.F90
 mlprec/impl/mld_s_onelev_impl.f90
 mlprec/impl/mld_saggrmat_asb.f90
 mlprec/impl/mld_saggrmat_biz_asb.f90
 mlprec/impl/mld_saggrmat_minnrg_asb.F90
 mlprec/impl/mld_saggrmat_minnrg_asb.f90
 mlprec/impl/mld_saggrmat_nosmth_asb.F90
 mlprec/impl/mld_saggrmat_nosmth_asb.f90
 mlprec/impl/mld_saggrmat_smth_asb.F90
 mlprec/impl/mld_saggrmat_smth_asb.f90
 mlprec/impl/mld_scoarse_bld.f90
 mlprec/impl/mld_smlprec_bld.f90
 mlprec/impl/mld_sprecaply.f90
 mlprec/impl/mld_sprecinit.F90
 mlprec/impl/mld_sprecset.F90
 mlprec/impl/mld_z_onelev_impl.f90
 mlprec/impl/mld_zaggrmat_asb.f90
 mlprec/impl/mld_zaggrmat_biz_asb.f90
 mlprec/impl/mld_zaggrmat_minnrg_asb.F90
 mlprec/impl/mld_zaggrmat_minnrg_asb.f90
 mlprec/impl/mld_zaggrmat_nosmth_asb.F90
 mlprec/impl/mld_zaggrmat_nosmth_asb.f90
 mlprec/impl/mld_zaggrmat_smth_asb.F90
 mlprec/impl/mld_zaggrmat_smth_asb.f90
 mlprec/impl/mld_zcoarse_bld.f90
 mlprec/impl/mld_zmlprec_bld.f90
 mlprec/impl/mld_zprecaply.f90
 mlprec/impl/mld_zprecinit.F90
 mlprec/impl/mld_zprecset.F90
 mlprec/mld_base_prec_type.F90
 mlprec/mld_c_inner_mod.f90
 mlprec/mld_c_move_alloc_mod.f90
 mlprec/mld_c_onelev_mod.f90
 mlprec/mld_c_prec_mod.f90
 mlprec/mld_c_prec_type.f90
 mlprec/mld_d_inner_mod.f90
 mlprec/mld_d_move_alloc_mod.f90
 mlprec/mld_d_onelev_mod.f90
 mlprec/mld_d_prec_mod.f90
 mlprec/mld_d_prec_type.f90
 mlprec/mld_s_inner_mod.f90
 mlprec/mld_s_move_alloc_mod.f90
 mlprec/mld_s_onelev_mod.f90
 mlprec/mld_s_prec_mod.f90
 mlprec/mld_s_prec_type.f90
 mlprec/mld_z_inner_mod.f90
 mlprec/mld_z_move_alloc_mod.f90
 mlprec/mld_z_onelev_mod.f90
 mlprec/mld_z_prec_mod.f90
 mlprec/mld_z_prec_type.f90
 tests/pdegen/ppde2d.f90
 tests/pdegen/ppde3d.f90
 tests/pdegen/runs/ppde.inp
 tests/pdegen/spde2d.f90
 tests/pdegen/spde3d.f90

Merge NewNL branch.
stopcriterion
Salvatore Filippone 13 years ago
parent d76e2e2a6e 7586e725ff
commit d90f8820e7
65 changed files with 3955 additions and 3572 deletions
Show Stats Download Patch File Download Diff File

32
mlprec/Makefile
Unescape Escape View File

@ -7,22 +7,22 @@ HERE=.
FINCLUDES=$(FMFLAG). $(FMFLAG)$(LIBDIR) $(FMFLAG)$(PSBINCDIR) $(FMFLAG)$(PSBLIBDIR) FINCLUDES=$(FMFLAG). $(FMFLAG)$(LIBDIR) $(FMFLAG)$(PSBINCDIR) $(FMFLAG)$(PSBLIBDIR)
DMODOBJS=mld_d_prec_type.o mld_d_prec_mod.o mld_d_move_alloc_mod.o mld_d_ilu_fact_mod.o \ DMODOBJS=mld_d_prec_type.o mld_d_prec_mod.o mld_d_ilu_fact_mod.o \
mld_d_inner_mod.o mld_d_ilu_solver.o mld_d_diag_solver.o mld_d_jac_smoother.o mld_d_as_smoother.o \ mld_d_inner_mod.o mld_d_ilu_solver.o mld_d_diag_solver.o mld_d_jac_smoother.o mld_d_as_smoother.o \
mld_d_umf_solver.o mld_d_slu_solver.o mld_d_sludist_solver.o mld_d_id_solver.o\ mld_d_umf_solver.o mld_d_slu_solver.o mld_d_sludist_solver.o mld_d_id_solver.o\
mld_d_base_solver_mod.o mld_d_base_smoother_mod.o mld_d_onelev_mod.o mld_d_base_solver_mod.o mld_d_base_smoother_mod.o mld_d_onelev_mod.o
SMODOBJS=mld_s_prec_type.o mld_s_prec_mod.o mld_s_move_alloc_mod.o mld_s_ilu_fact_mod.o \ SMODOBJS=mld_s_prec_type.o mld_s_prec_mod.o mld_s_ilu_fact_mod.o \
mld_s_inner_mod.o mld_s_ilu_solver.o mld_s_diag_solver.o mld_s_jac_smoother.o mld_s_as_smoother.o \ mld_s_inner_mod.o mld_s_ilu_solver.o mld_s_diag_solver.o mld_s_jac_smoother.o mld_s_as_smoother.o \
mld_s_slu_solver.o mld_s_sludist_solver.o mld_s_id_solver.o\ mld_s_slu_solver.o mld_s_sludist_solver.o mld_s_id_solver.o\
mld_s_base_solver_mod.o mld_s_base_smoother_mod.o mld_s_onelev_mod.o mld_s_base_solver_mod.o mld_s_base_smoother_mod.o mld_s_onelev_mod.o
ZMODOBJS=mld_z_prec_type.o mld_z_prec_mod.o mld_z_move_alloc_mod.o mld_z_ilu_fact_mod.o \ ZMODOBJS=mld_z_prec_type.o mld_z_prec_mod.o mld_z_ilu_fact_mod.o \
mld_z_inner_mod.o mld_z_ilu_solver.o mld_z_diag_solver.o mld_z_jac_smoother.o mld_z_as_smoother.o \ mld_z_inner_mod.o mld_z_ilu_solver.o mld_z_diag_solver.o mld_z_jac_smoother.o mld_z_as_smoother.o \
mld_z_umf_solver.o mld_z_slu_solver.o mld_z_sludist_solver.o mld_z_id_solver.o\ mld_z_umf_solver.o mld_z_slu_solver.o mld_z_sludist_solver.o mld_z_id_solver.o\
mld_z_base_solver_mod.o mld_z_base_smoother_mod.o mld_z_onelev_mod.o mld_z_base_solver_mod.o mld_z_base_smoother_mod.o mld_z_onelev_mod.o
CMODOBJS=mld_c_prec_type.o mld_c_prec_mod.o mld_c_move_alloc_mod.o mld_c_ilu_fact_mod.o \ CMODOBJS=mld_c_prec_type.o mld_c_prec_mod.o mld_c_ilu_fact_mod.o \
mld_c_inner_mod.o mld_c_ilu_solver.o mld_c_diag_solver.o mld_c_jac_smoother.o mld_c_as_smoother.o \ mld_c_inner_mod.o mld_c_ilu_solver.o mld_c_diag_solver.o mld_c_jac_smoother.o mld_c_as_smoother.o \
mld_c_slu_solver.o mld_c_sludist_solver.o mld_c_id_solver.o\ mld_c_slu_solver.o mld_c_sludist_solver.o mld_c_id_solver.o\
mld_c_base_solver_mod.o mld_c_base_smoother_mod.o mld_c_onelev_mod.o mld_c_base_solver_mod.o mld_c_base_smoother_mod.o mld_c_onelev_mod.o
@ -63,20 +63,15 @@ $(DINNEROBJS) $(DOUTEROBJS): $(DMODOBJS)
$(CINNEROBJS) $(COUTEROBJS): $(CMODOBJS) $(CINNEROBJS) $(COUTEROBJS): $(CMODOBJS)
$(ZINNEROBJS) $(ZOUTEROBJS): $(ZMODOBJS) $(ZINNEROBJS) $(ZOUTEROBJS): $(ZMODOBJS)
mld_s_inner_mod.o: mld_s_move_alloc_mod.o mld_s_prec_type.o mld_s_inner_mod.o: mld_s_prec_type.o
mld_d_inner_mod.o: mld_d_move_alloc_mod.o mld_d_prec_type.o mld_d_inner_mod.o: mld_d_prec_type.o
mld_c_inner_mod.o: mld_c_move_alloc_mod.o mld_c_prec_type.o mld_c_inner_mod.o: mld_c_prec_type.o
mld_z_inner_mod.o: mld_z_move_alloc_mod.o mld_z_prec_type.o mld_z_inner_mod.o: mld_z_prec_type.o
mld_s_move_alloc_mod.o: mld_s_prec_type.o mld_s_prec_mod.o: mld_s_prec_type.o
mld_d_move_alloc_mod.o: mld_d_prec_type.o mld_d_prec_mod.o: mld_d_prec_type.o
mld_c_move_alloc_mod.o: mld_c_prec_type.o mld_c_prec_mod.o: mld_c_prec_type.o
mld_z_move_alloc_mod.o: mld_z_prec_type.o mld_z_prec_mod.o: mld_z_prec_type.o
mld_s_prec_mod.o: mld_s_move_alloc_mod.o
mld_d_prec_mod.o: mld_d_move_alloc_mod.o
mld_c_prec_mod.o: mld_c_move_alloc_mod.o
mld_z_prec_mod.o: mld_z_move_alloc_mod.o
mld_s_prec_type.o: mld_s_onelev_mod.o mld_s_prec_type.o: mld_s_onelev_mod.o
@ -97,9 +92,6 @@ mld_z_base_smoother_mod.o: mld_z_base_solver_mod.o
mld_s_base_solver_mod.o mld_d_base_solver_mod.o mld_c_base_solver_mod.o mld_z_base_solver_mod.o: mld_base_prec_type.o mld_s_base_solver_mod.o mld_d_base_solver_mod.o mld_c_base_solver_mod.o mld_z_base_solver_mod.o: mld_base_prec_type.o
mld_d_id_solver.o mld_d_sludist_solver.o mld_d_slu_solver.o \ mld_d_id_solver.o mld_d_sludist_solver.o mld_d_slu_solver.o \
mld_d_umf_solver.o mld_d_diag_solver.o mld_d_ilu_solver.o: mld_d_base_solver_mod.o mld_d_prec_type.o mld_d_umf_solver.o mld_d_diag_solver.o mld_d_ilu_solver.o: mld_d_base_solver_mod.o mld_d_prec_type.o

8
mlprec/impl/Makefile
Unescape Escape View File

@ -7,13 +7,13 @@ HERE=..
FINCLUDES=$(FMFLAG).. $(FMFLAG)$(LIBDIR) $(FMFLAG)$(PSBINCDIR) $(FMFLAG)$(PSBLIBDIR) FINCLUDES=$(FMFLAG).. $(FMFLAG)$(LIBDIR) $(FMFLAG)$(PSBINCDIR) $(FMFLAG)$(PSBLIBDIR)
DMPFOBJS=mld_daggrmat_nosmth_asb.o mld_daggrmat_smth_asb.o mld_daggrmat_minnrg_asb.o DMPFOBJS=mld_daggrmat_nosmth_asb.o mld_daggrmat_smth_asb.o mld_daggrmat_minnrg_asb.o mld_daggrmat_biz_asb.o
SMPFOBJS=mld_saggrmat_nosmth_asb.o mld_saggrmat_smth_asb.o mld_saggrmat_minnrg_asb.o SMPFOBJS=mld_saggrmat_nosmth_asb.o mld_saggrmat_smth_asb.o mld_saggrmat_minnrg_asb.o mld_saggrmat_biz_asb.o
ZMPFOBJS=mld_zaggrmat_nosmth_asb.o mld_zaggrmat_smth_asb.o mld_zaggrmat_minnrg_asb.o ZMPFOBJS=mld_zaggrmat_nosmth_asb.o mld_zaggrmat_smth_asb.o mld_zaggrmat_minnrg_asb.o mld_zaggrmat_biz_asb.o
CMPFOBJS=mld_caggrmat_nosmth_asb.o mld_caggrmat_smth_asb.o mld_caggrmat_minnrg_asb.o CMPFOBJS=mld_caggrmat_nosmth_asb.o mld_caggrmat_smth_asb.o mld_caggrmat_minnrg_asb.o mld_caggrmat_biz_asb.o
MPFOBJS=$(SMPFOBJS) $(DMPFOBJS) $(CMPFOBJS) $(ZMPFOBJS) MPFOBJS=$(SMPFOBJS) $(DMPFOBJS) $(CMPFOBJS) $(ZMPFOBJS)

2
mlprec/impl/mld_c_onelev_impl.f90
Unescape Escape View File

@ -154,7 +154,7 @@ subroutine mld_c_base_onelev_free(lv,info)
& call lv%sm%free(info) & call lv%sm%free(info)
call lv%ac%free() call lv%ac%free()
if (psb_is_ok_desc(lv%desc_ac)) & if (lv%desc_ac%is_ok()) &
& call psb_cdfree(lv%desc_ac,info) & call psb_cdfree(lv%desc_ac,info)
call lv%map%free(info) call lv%map%free(info)

142
mlprec/impl/mld_caggrmat_asb.f90
Unescape Escape View File

@ -113,6 +113,11 @@ subroutine mld_caggrmat_asb(a,desc_a,ilaggr,nlaggr,p,info)
integer, intent(out) :: info integer, intent(out) :: info
! Local variables ! Local variables
type(psb_cspmat_type) :: ac, op_prol,op_restr
type(psb_c_coo_sparse_mat) :: acoo, bcoo
type(psb_c_csr_sparse_mat) :: acsr1
integer :: nzl,ntaggr
integer :: debug_level, debug_unit
integer :: ictxt,np,me, err_act integer :: ictxt,np,me, err_act
character(len=20) :: name character(len=20) :: name
@ -120,6 +125,9 @@ subroutine mld_caggrmat_asb(a,desc_a,ilaggr,nlaggr,p,info)
if(psb_get_errstatus().ne.0) return if(psb_get_errstatus().ne.0) return
info=psb_success_ info=psb_success_
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
debug_unit = psb_get_debug_unit()
debug_level = psb_get_debug_level()
ictxt = desc_a%get_context() ictxt = desc_a%get_context()
@ -128,35 +136,139 @@ subroutine mld_caggrmat_asb(a,desc_a,ilaggr,nlaggr,p,info)
select case (p%parms%aggr_kind) select case (p%parms%aggr_kind)
case (mld_no_smooth_) case (mld_no_smooth_)
call mld_aggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,p,info) call mld_caggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,&
if(info /= psb_success_) then & p%parms,ac,op_prol,op_restr,info)
call psb_errpush(psb_err_from_subroutine_,name,a_err='mld_aggrmat_nosmth_asb')
case(mld_smooth_prol_)
call mld_caggrmat_smth_asb(a,desc_a,ilaggr,nlaggr, &
& p%parms,ac,op_prol,op_restr,info)
case(mld_biz_prol_)
call mld_caggrmat_biz_asb(a,desc_a,ilaggr,nlaggr, &
& p%parms,ac,op_prol,op_restr,info)
case(mld_min_energy_)
call mld_caggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr, &
& p%parms,ac,op_prol,op_restr,info)
case default
info = psb_err_internal_error_
call psb_errpush(info,name,a_err='Invalid aggr kind')
goto 9999
end select
if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='Inner aggrmat asb')
goto 9999
end if
ntaggr = sum(nlaggr)
select case(p%parms%coarse_mat)
case(mld_distr_mat_)
nzl = ac%get_nzeros()
call ac%mv_to(bcoo)
if (info == psb_success_) call psb_cdall(ictxt,p%desc_ac,info,nl=nlaggr(me+1))
if (info == psb_success_) call psb_cdins(nzl,bcoo%ia,bcoo%ja,p%desc_ac,info)
if (info == psb_success_) call psb_cdasb(p%desc_ac,info)
if (info == psb_success_) call psb_glob_to_loc(bcoo%ia(1:nzl),p%desc_ac,info,iact='I')
if (info == psb_success_) call psb_glob_to_loc(bcoo%ja(1:nzl),p%desc_ac,info,iact='I')
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Creating p%desc_ac and converting ac')
goto 9999 goto 9999
end if end if
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'Assembld aux descr. distr.'
call p%ac%mv_from(bcoo)
case(mld_smooth_prol_,mld_biz_prol_) call p%ac%set_nrows(p%desc_ac%get_local_rows())
call p%ac%set_ncols(p%desc_ac%get_local_cols())
call p%ac%set_asb()
call mld_aggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info) if (info /= psb_success_) then
if(info /= psb_success_) then call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_sp_free')
call psb_errpush(psb_err_from_subroutine_,name,a_err='mld_aggrmat_smth_asb')
goto 9999 goto 9999
end if end if
case(mld_min_energy_) if (np>1) then
call op_prol%mv_to(acsr1)
nzl = acsr1%get_nzeros()
call psb_glob_to_loc(acsr1%ja(1:nzl),p%desc_ac,info,'I')
if(info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_glob_to_loc')
goto 9999
end if
call op_prol%mv_from(acsr1)
endif
call op_prol%set_ncols(p%desc_ac%get_local_cols())
call mld_aggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info) if (np>1) then
if(info /= psb_success_) then call op_restr%cscnv(info,type='coo',dupl=psb_dupl_add_)
call psb_errpush(psb_err_from_subroutine_,name,a_err='mld_aggrmat_smth_asb') call op_restr%mv_to(acoo)
goto 9999 nzl = acoo%get_nzeros()
if (info == psb_success_) call psb_glob_to_loc(acoo%ia(1:nzl),p%desc_ac,info,'I')
call acoo%set_dupl(psb_dupl_add_)
if (info == psb_success_) call op_restr%mv_from(acoo)
if (info == psb_success_) call op_restr%cscnv(info,type='csr')
if(info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,a_err='Converting op_restr to local')
goto 9999
end if
end if end if
call op_restr%set_nrows(p%desc_ac%get_local_cols())
case default if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'Done ac '
call psb_errpush(psb_err_internal_error_,name,a_err='Invalid aggr kind') case(mld_repl_mat_)
goto 9999 !
!
call psb_cdall(ictxt,p%desc_ac,info,mg=ntaggr,repl=.true.)
if (info == psb_success_) call psb_cdasb(p%desc_ac,info)
if (info == psb_success_) &
& call psb_gather(p%ac,ac,p%desc_ac,info,dupl=psb_dupl_add_,keeploc=.false.)
if (info /= psb_success_) goto 9999
case default
info = psb_err_internal_error_
call psb_errpush(info,name,a_err='invalid mld_coarse_mat_')
goto 9999
end select end select
call p%ac%cscnv(info,type='csr',dupl=psb_dupl_add_)
if(info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='spcnv')
goto 9999
end if
!
! Copy the prolongation/restriction matrices into the descriptor map.
! op_restr => PR^T i.e. restriction operator
! op_prol => PR i.e. prolongation operator
!
p%map = psb_linmap(psb_map_aggr_,desc_a,&
& p%desc_ac,op_restr,op_prol,ilaggr,nlaggr)
if (info == psb_success_) call op_prol%free()
if (info == psb_success_) call op_restr%free()
if(info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='sp_Free')
goto 9999
end if
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
return return

422
mlprec/impl/mld_caggrmat_biz_asb.f90
Unescape Escape View File

@ -0,0 +1,422 @@
!!$
!!$
!!$ MLD2P4 version 2.0
!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package
!!$ based on PSBLAS (Parallel Sparse BLAS version 3.0)
!!$
!!$ (C) Copyright 2008,2009,2010
!!$
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$ Pasqua D'Ambra ICAR-CNR, Naples
!!$ Daniela di Serafino Second University of Naples
!!$
!!$ Redistribution and use in source and binary forms, with or without
!!$ modification, are permitted provided that the following conditions
!!$ are met:
!!$ 1. Redistributions of source code must retain the above copyright
!!$ notice, this list of conditions and the following disclaimer.
!!$ 2. Redistributions in binary form must reproduce the above copyright
!!$ notice, this list of conditions, and the following disclaimer in the
!!$ documentation and/or other materials provided with the distribution.
!!$ 3. The name of the MLD2P4 group or the names of its contributors may
!!$ not be used to endorse or promote products derived from this
!!$ software without specific written permission.
!!$
!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE MLD2P4 GROUP OR ITS CONTRIBUTORS
!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
!!$ POSSIBILITY OF SUCH DAMAGE.
!!$
!!$
! File: mld_caggrmat_biz_asb.F90
!
! Subroutine: mld_caggrmat_biz_asb
! Version: complex
!
! This routine builds a coarse-level matrix A_C from a fine-level matrix A
! by using the Galerkin approach, i.e.
!
! A_C = P_C^T A P_C,
!
! where P_C is a prolongator from the coarse level to the fine one.
!
! This routine builds A_C according to a "bizarre" aggregation algorithm,
! using a "naive" prolongator proposed by the authors of MLD2P4. However, this
! prolongator still requires a deep analysis and testing and its use is not
! recommended.
!
! The coarse-level matrix A_C is distributed among the parallel processes or
! replicated on each of them, according to the value of p%parms%coarse_mat,
! specified by the user through mld_cprecinit and mld_zprecset.
!
! 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.
! p - type(mld_c_onelev_type), input/output.
! The 'one-level' data structure that will contain the local
! part of the matrix to be built as well as the information
! concerning the prolongator and its transpose.
! ilaggr - integer, dimension(:), allocatable.
! The mapping between the row indices of the coarse-level
! matrix and the row indices of the fine-level matrix.
! ilaggr(i)=j means that node i in the adjacency graph
! of the fine-level matrix is mapped onto node j in the
! adjacency graph of the coarse-level matrix.
! nlaggr - integer, dimension(:), allocatable.
! nlaggr(i) contains the aggregates held by process i.
! info - integer, output.
! Error code.
!
subroutine mld_caggrmat_biz_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_restr,info)
use psb_base_mod
use mld_c_inner_mod, mld_protect_name => mld_caggrmat_biz_asb
implicit none
! Arguments
type(psb_cspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_a
integer, intent(inout) :: ilaggr(:), nlaggr(:)
type(mld_sml_parms), intent(inout) :: parms
type(psb_cspmat_type), intent(out) :: ac,op_prol,op_restr
integer, intent(out) :: info
! Local variables
integer :: nrow, nglob, ncol, ntaggr, ip, ndx,&
& naggr, nzl,naggrm1,naggrp1, i, j, k, jd, icolF, nrw
integer ::ictxt, np, me, err_act
character(len=20) :: name
type(psb_cspmat_type) :: am3, am4
type(psb_c_coo_sparse_mat) :: tmpcoo
type(psb_c_csr_sparse_mat) :: acsr1, acsr2, acsr3, acsrf, ptilde
complex(psb_spk_), allocatable :: adiag(:)
integer(psb_ipk_) :: ierr(5)
logical :: filter_mat
integer :: debug_level, debug_unit
integer, parameter :: ncmax=16
real(psb_spk_) :: anorm, omega, tmp, dg, theta
name='mld_aggrmat_biz_asb'
if(psb_get_errstatus().ne.0) return
info=psb_success_
call psb_erractionsave(err_act)
debug_unit = psb_get_debug_unit()
debug_level = psb_get_debug_level()
ictxt = desc_a%get_context()
ictxt = desc_a%get_context()
call psb_info(ictxt, me, np)
nglob = desc_a%get_global_rows()
nrow = desc_a%get_local_rows()
ncol = desc_a%get_local_cols()
theta = parms%aggr_thresh
naggr = nlaggr(me+1)
ntaggr = sum(nlaggr)
naggrm1 = sum(nlaggr(1:me))
naggrp1 = sum(nlaggr(1:me+1))
filter_mat = (parms%aggr_filter == mld_filter_mat_)
ilaggr(1:nrow) = ilaggr(1:nrow) + naggrm1
call psb_halo(ilaggr,desc_a,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_halo')
goto 9999
end if
! naggr: number of local aggregates
! nrow: local rows.
!
allocate(adiag(ncol),stat=info)
if (info /= psb_success_) then
info=psb_err_alloc_request_; ierr(1)=nrow;
call psb_errpush(info,name,i_err=ierr,a_err='complex(psb_spk_)')
goto 9999
end if
! Get the diagonal D
call a%get_diag(adiag,info)
if (info == psb_success_) &
& call psb_halo(adiag,desc_a,info)
if(info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='sp_getdiag')
goto 9999
end if
! 1. Allocate Ptilde in sparse matrix form
call tmpcoo%allocate(ncol,naggr,ncol)
do i=1,nrow
tmpcoo%val(i) = cone
tmpcoo%ia(i) = i
tmpcoo%ja(i) = ilaggr(i)
end do
call tmpcoo%set_nzeros(nrow)
call tmpcoo%set_dupl(psb_dupl_add_)
call ptilde%mv_from_coo(tmpcoo,info)
if (info == psb_success_) call a%cscnv(acsr3,info,dupl=psb_dupl_add_)
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& ' Initial copies sone.'
if (filter_mat) then
!
! Build the filtered matrix Af from A
!
if (info == psb_success_) call a%cscnv(acsrf,info,dupl=psb_dupl_add_)
do i=1,nrow
tmp = czero
jd = -1
do j=acsrf%irp(i),acsrf%irp(i+1)-1
if (acsrf%ja(j) == i) jd = j
if (abs(acsrf%val(j)) < theta*sqrt(abs(adiag(i)*adiag(acsrf%ja(j))))) then
tmp=tmp+acsrf%val(j)
acsrf%val(j)=czero
endif
enddo
if (jd == -1) then
write(0,*) 'Wrong input: we need the diagonal!!!!', i
else
acsrf%val(jd)=acsrf%val(jd)-tmp
end if
enddo
! Take out zeroed terms
call acsrf%mv_to_coo(tmpcoo,info)
k = 0
do j=1,tmpcoo%get_nzeros()
if ((tmpcoo%val(j) /= czero) .or. (tmpcoo%ia(j) == tmpcoo%ja(j))) then
k = k + 1
tmpcoo%val(k) = tmpcoo%val(j)
tmpcoo%ia(k) = tmpcoo%ia(j)
tmpcoo%ja(k) = tmpcoo%ja(j)
end if
end do
call tmpcoo%set_nzeros(k)
call tmpcoo%set_dupl(psb_dupl_add_)
call acsrf%mv_from_coo(tmpcoo,info)
end if
do i=1,size(adiag)
if (adiag(i) /= czero) then
adiag(i) = cone / adiag(i)
else
adiag(i) = cone
end if
end do
if (filter_mat) call acsrf%scal(adiag,info)
if (info == psb_success_) call acsr3%scal(adiag,info)
if (info /= psb_success_) goto 9999
if (parms%aggr_omega_alg == mld_eig_est_) then
if (parms%aggr_eig == mld_max_norm_) then
!
! This only works with CSR
!
anorm = szero
dg = sone
nrw = acsr3%get_nrows()
do i=1, nrw
tmp = szero
do j=acsr3%irp(i),acsr3%irp(i+1)-1
if (acsr3%ja(j) <= nrw) then
tmp = tmp + abs(acsr3%val(j))
endif
if (acsr3%ja(j) == i ) then
dg = abs(acsr3%val(j))
end if
end do
anorm = max(anorm,tmp/dg)
enddo
call psb_amx(ictxt,anorm)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,a_err='Invalid AM3 storage format')
goto 9999
end if
omega = 4.d0/(3.d0*anorm)
parms%aggr_omega_val = omega
else
info = psb_err_internal_error_
call psb_errpush(info,name,a_err='invalid mld_aggr_eig_')
goto 9999
end if
else if (parms%aggr_omega_alg == mld_user_choice_) then
omega = parms%aggr_omega_val
else if (parms%aggr_omega_alg /= mld_user_choice_) then
info = psb_err_internal_error_
call psb_errpush(info,name,a_err='invalid mld_aggr_omega_alg_')
goto 9999
end if
if (filter_mat) then
!
! Build the smoothed prolongator using the filtered matrix
!
do i=1,acsrf%get_nrows()
do j=acsrf%irp(i),acsrf%irp(i+1)-1
if (acsrf%ja(j) == i) then
acsrf%val(j) = cone - omega*acsrf%val(j)
else
acsrf%val(j) = - omega*acsrf%val(j)
end if
end do
end do
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'Done gather, going for SYMBMM 1'
!
! Symbmm90 does the allocation for its result.
!
! acsrm1 = (I-w*D*Af)Ptilde
! Doing it this way means to consider diag(Af_i)
!
!
call psb_symbmm(acsrf,ptilde,acsr1,info)
if(info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='symbmm 1')
goto 9999
end if
call psb_numbmm(acsrf,ptilde,acsr1)
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'Done NUMBMM 1'
else
!
! Build the smoothed prolongator using the original matrix
!
do i=1,acsr3%get_nrows()
do j=acsr3%irp(i),acsr3%irp(i+1)-1
if (acsr3%ja(j) == i) then
acsr3%val(j) = cone - omega*acsr3%val(j)
else
acsr3%val(j) = - omega*acsr3%val(j)
end if
end do
end do
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'Done gather, going for SYMBMM 1'
!
! Symbmm90 does the allocation for its result.
!
! acsrm1 = (I-w*D*A)Ptilde
! Doing it this way means to consider diag(A_i)
!
!
call psb_symbmm(acsr3,ptilde,acsr1,info)
if(info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='symbmm 1')
goto 9999
end if
call psb_numbmm(acsr3,ptilde,acsr1)
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'Done NUMBMM 1'
end if
call ptilde%free()
call acsr1%set_dupl(psb_dupl_add_)
call op_prol%mv_from(acsr1)
call psb_rwextd(ncol,op_prol,info)
if(info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,a_err='Halo of op_prol')
goto 9999
end if
call psb_symbmm(a,op_prol,am3,info)
if(info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='symbmm 2')
goto 9999
end if
call psb_numbmm(a,op_prol,am3)
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'Done NUMBMM 2',parms%aggr_kind, mld_smooth_prol_
call op_prol%transp(op_restr)
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'starting sphalo/ rwxtd'
call psb_rwextd(ncol,am3,info)
if(info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,a_err='Extend am3')
goto 9999
end if
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'starting symbmm 3'
call psb_symbmm(op_restr,am3,ac,info)
if (info == psb_success_) call psb_numbmm(op_restr,am3,ac)
if (info == psb_success_) call am3%free()
if (info == psb_success_) call ac%cscnv(info,type='coo',dupl=psb_dupl_add_)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,a_err='Build b = op_restr x am3')
goto 9999
end if
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'Done smooth_aggregate '
call psb_erractionrestore(err_act)
return
9999 continue
call psb_errpush(info,name)
call psb_erractionrestore(err_act)
if (err_act.eq.psb_act_abort_) then
call psb_error()
return
end if
return
end subroutine mld_caggrmat_biz_asb

218
mlprec/impl/mld_caggrmat_minnrg_asb.F90 → mlprec/impl/mld_caggrmat_minnrg_asb.f90
Unescape Escape View File

@ -98,37 +98,31 @@
! info - integer, output. ! info - integer, output.
! Error code. ! Error code.
! !
subroutine mld_caggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info) subroutine mld_caggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_restr,info)
use psb_base_mod use psb_base_mod
use mld_c_inner_mod, mld_protect_name => mld_caggrmat_minnrg_asb use mld_c_inner_mod, mld_protect_name => mld_caggrmat_minnrg_asb
#ifdef MPI_MOD
use mpi
#endif
implicit none implicit none
#ifdef MPI_H
include 'mpif.h'
#endif
! Arguments ! Arguments
type(psb_cspmat_type), intent(in) :: a type(psb_cspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_a type(psb_desc_type), intent(in) :: desc_a
integer, intent(inout) :: ilaggr(:), nlaggr(:) integer, intent(inout) :: ilaggr(:), nlaggr(:)
type(mld_c_onelev_type), intent(inout), target :: p type(mld_sml_parms), intent(inout) :: parms
type(psb_cspmat_type), intent(out) :: ac,op_prol,op_restr
integer, intent(out) :: info integer, intent(out) :: info
! Local variables ! Local variables
type(psb_cspmat_type) :: b
integer(psb_mpik_), allocatable :: nzbr(:), idisp(:) integer(psb_mpik_), allocatable :: nzbr(:), idisp(:)
integer :: nrow, nglob, ncol, ntaggr, nzac, ip, ndx,& integer :: nrow, nglob, ncol, ntaggr, nzac, ip, ndx,&
& naggr, nzl,naggrm1,naggrp1, i, j, k, jd, icolF, nrt & naggr, nzl,naggrm1,naggrp1, i, j, k, jd, icolF, nrt
integer :: ictxt,np,me, err_act, icomm integer :: ictxt,np,me, err_act, icomm
character(len=20) :: name character(len=20) :: name
type(psb_cspmat_type) :: am1,am2, af, ptilde, rtilde, atran, atp, atdatp type(psb_cspmat_type) :: af, ptilde, rtilde, atran, atp, atdatp
type(psb_cspmat_type) :: am3,am4, ap, adap,atmp,rada, ra, atmp2, dap, dadap, da type(psb_cspmat_type) :: am3,am4, ap, adap,atmp,rada, ra, atmp2, dap, dadap, da
type(psb_cspmat_type) :: dat, datp, datdatp, atmp3 type(psb_cspmat_type) :: dat, datp, datdatp, atmp3
type(psb_c_coo_sparse_mat) :: acoo, acoof, bcoo, tmpcoo type(psb_c_coo_sparse_mat) :: tmpcoo
type(psb_c_csr_sparse_mat) :: acsr1, acsr2, acsr3, bcsr, acsr, acsrf type(psb_c_csr_sparse_mat) :: acsr1, acsr2, acsr3, acsr, acsrf
type(psb_c_csc_sparse_mat) :: csc_dap, csc_dadap, csc_datp, csc_datdatp, acsc type(psb_c_csc_sparse_mat) :: csc_dap, csc_dadap, csc_datp, csc_datdatp, acsc
complex(psb_spk_), allocatable :: adiag(:), adinv(:) complex(psb_spk_), allocatable :: adiag(:), adinv(:)
complex(psb_spk_), allocatable :: omf(:), omp(:), omi(:), oden(:) complex(psb_spk_), allocatable :: omf(:), omp(:), omi(:), oden(:)
@ -156,7 +150,7 @@ subroutine mld_caggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info)
nrow = desc_a%get_local_rows() nrow = desc_a%get_local_rows()
ncol = desc_a%get_local_cols() ncol = desc_a%get_local_cols()
theta = p%parms%aggr_thresh theta = parms%aggr_thresh
naggr = nlaggr(me+1) naggr = nlaggr(me+1)
ntaggr = sum(nlaggr) ntaggr = sum(nlaggr)
@ -171,7 +165,7 @@ subroutine mld_caggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info)
naggrm1 = sum(nlaggr(1:me)) naggrm1 = sum(nlaggr(1:me))
naggrp1 = sum(nlaggr(1:me+1)) naggrp1 = sum(nlaggr(1:me+1))
filter_mat = (p%parms%aggr_filter == mld_filter_mat_) filter_mat = (parms%aggr_filter == mld_filter_mat_)
ilaggr(1:nrow) = ilaggr(1:nrow) + naggrm1 ilaggr(1:nrow) = ilaggr(1:nrow) + naggrm1
call psb_halo(ilaggr,desc_a,info) call psb_halo(ilaggr,desc_a,info)
@ -213,16 +207,16 @@ subroutine mld_caggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info)
! 1. Allocate Ptilde in sparse matrix form ! 1. Allocate Ptilde in sparse matrix form
call acoo%allocate(ncol,ntaggr,ncol) call tmpcoo%allocate(ncol,ntaggr,ncol)
do i=1,ncol do i=1,ncol
acoo%val(i) = cone tmpcoo%val(i) = cone
acoo%ia(i) = i tmpcoo%ia(i) = i
acoo%ja(i) = ilaggr(i) tmpcoo%ja(i) = ilaggr(i)
end do end do
call acoo%set_nzeros(ncol) call tmpcoo%set_nzeros(ncol)
call acoo%set_dupl(psb_dupl_add_) call tmpcoo%set_dupl(psb_dupl_add_)
call acoo%set_asb() call tmpcoo%set_asb()
call ptilde%mv_from(acoo) call ptilde%mv_from(tmpcoo)
call ptilde%cscnv(info,type='csr') call ptilde%cscnv(info,type='csr')
!!$ call local_dump(me,ptilde,'csr-ptilde','Ptilde-1') !!$ call local_dump(me,ptilde,'csr-ptilde','Ptilde-1')
@ -354,17 +348,17 @@ subroutine mld_caggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info)
! !
! Symbmm90 does the allocation for its result. ! Symbmm90 does the allocation for its result.
! !
! am1 = (I-w*D*Af)Ptilde ! op_prol = (I-w*D*Af)Ptilde
! Doing it this way means to consider diag(Af_i) ! Doing it this way means to consider diag(Af_i)
! !
! !
call psb_symbmm(af,ptilde,am1,info) call psb_symbmm(af,ptilde,op_prol,info)
if(info /= psb_success_) then if(info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='symbmm 1') call psb_errpush(psb_err_from_subroutine_,name,a_err='symbmm 1')
goto 9999 goto 9999
end if end if
call psb_numbmm(af,ptilde,am1) call psb_numbmm(af,ptilde,op_prol)
if (debug_level >= psb_debug_outer_) & if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),& & write(debug_unit,*) me,' ',trim(name),&
@ -390,16 +384,16 @@ subroutine mld_caggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info)
! !
! Symbmm90 does the allocation for its result. ! Symbmm90 does the allocation for its result.
! !
! am1 = (I-w*D*A)Ptilde ! op_prol = (I-w*D*A)Ptilde
! !
! !
call psb_symbmm(am3,ptilde,am1,info) call psb_symbmm(am3,ptilde,op_prol,info)
if(info /= psb_success_) then if(info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='symbmm 1') call psb_errpush(psb_err_from_subroutine_,name,a_err='symbmm 1')
goto 9999 goto 9999
end if end if
call psb_numbmm(am3,ptilde,am1) call psb_numbmm(am3,ptilde,op_prol)
if (debug_level >= psb_debug_outer_) & if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),& & write(debug_unit,*) me,' ',trim(name),&
@ -509,20 +503,20 @@ subroutine mld_caggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info)
call rtilde%mv_from(tmpcoo) call rtilde%mv_from(tmpcoo)
call rtilde%cscnv(info,type='csr') call rtilde%cscnv(info,type='csr')
call psb_symbmm(rtilde,atmp,am2,info) call psb_symbmm(rtilde,atmp,op_restr,info)
call psb_numbmm(rtilde,atmp,am2) call psb_numbmm(rtilde,atmp,op_restr)
! !
! Now we have to gather the halo of am1, and add it to itself ! Now we have to gather the halo of op_prol, and add it to itself
! to multiply it by A, ! to multiply it by A,
! !
call psb_sphalo(am1,desc_a,am4,info,& call psb_sphalo(op_prol,desc_a,am4,info,&
& colcnv=.false.,rowscale=.true.) & colcnv=.false.,rowscale=.true.)
if (info == psb_success_) call psb_rwextd(ncol,am1,info,b=am4) if (info == psb_success_) call psb_rwextd(ncol,op_prol,info,b=am4)
if (info == psb_success_) call am4%free() if (info == psb_success_) call am4%free()
if(info /= psb_success_) then if(info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,a_err='Halo of am1') call psb_errpush(psb_err_internal_error_,name,a_err='Halo of op_prol')
goto 9999 goto 9999
end if end if
@ -530,7 +524,7 @@ subroutine mld_caggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info)
! Now we have to fix this. The only rows of B that are correct ! Now we have to fix this. The only rows of B that are correct
! are those corresponding to "local" aggregates, i.e. indices in ilaggr(:) ! are those corresponding to "local" aggregates, i.e. indices in ilaggr(:)
! !
call am2%mv_to(tmpcoo) call op_restr%mv_to(tmpcoo)
nzl = tmpcoo%get_nzeros() nzl = tmpcoo%get_nzeros()
i=0 i=0
@ -543,21 +537,21 @@ subroutine mld_caggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info)
end if end if
end do end do
call tmpcoo%set_nzeros(i) call tmpcoo%set_nzeros(i)
call am2%mv_from(tmpcoo) call op_restr%mv_from(tmpcoo)
call am2%cscnv(info,type='csr') call op_restr%cscnv(info,type='csr')
if (debug_level >= psb_debug_outer_) & if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),& & write(debug_unit,*) me,' ',trim(name),&
& 'starting sphalo/ rwxtd' & 'starting sphalo/ rwxtd'
call psb_symbmm(a,am1,am3,info) call psb_symbmm(a,op_prol,am3,info)
if(info /= psb_success_) then if(info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,& call psb_errpush(psb_err_from_subroutine_,name,&
& a_err='symbmm 2') & a_err='symbmm 2')
goto 9999 goto 9999
end if end if
call psb_numbmm(a,am1,am3) call psb_numbmm(a,op_prol,am3)
if (debug_level >= psb_debug_outer_) & if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),& & write(debug_unit,*) me,' ',trim(name),&
& 'Done NUMBMM 2' & 'Done NUMBMM 2'
@ -576,156 +570,18 @@ subroutine mld_caggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info)
& write(debug_unit,*) me,' ',trim(name),& & write(debug_unit,*) me,' ',trim(name),&
& 'Done sphalo/ rwxtd' & 'Done sphalo/ rwxtd'
call psb_symbmm(am2,am3,b,info) call psb_symbmm(op_restr,am3,ac,info)
if (info == psb_success_) call psb_numbmm(am2,am3,b) if (info == psb_success_) call psb_numbmm(op_restr,am3,ac)
if (info == psb_success_) call am3%free() if (info == psb_success_) call am3%free()
call b%mv_to(bcoo) if (info == psb_success_) call ac%cscnv(info,type='coo',dupl=psb_dupl_add_)
if (info /= psb_success_) then if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,& call psb_errpush(psb_err_internal_error_,name,&
&a_err='Build b = am2 x am3') &a_err='Build ac = op_restr x am3')
goto 9999 goto 9999
end if end if
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'Done mv_to_coo'
select case(p%parms%coarse_mat)
case(mld_distr_mat_)
nzl = bcoo%get_nzeros()
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& ' B matrix nzl: ',nzl
if (info == psb_success_) call psb_cdall(ictxt,p%desc_ac,info,nl=nlaggr(me+1))
if (info == psb_success_) call psb_cdins(nzl,bcoo%ia,bcoo%ja,p%desc_ac,info)
if (info == psb_success_) call psb_cdasb(p%desc_ac,info)
if (info == psb_success_) call psb_glob_to_loc(bcoo%ia(1:nzl),p%desc_ac,info,iact='I')
if (info == psb_success_) call psb_glob_to_loc(bcoo%ja(1:nzl),p%desc_ac,info,iact='I')
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Creating p%desc_ac and converting ac')
goto 9999
end if
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& ' Assembld aux descr. distr.'
call bcoo%set_nrows(p%desc_ac%get_local_rows())
call bcoo%set_ncols(p%desc_ac%get_local_cols())
call bcoo%fix(info)
call p%ac%mv_from(bcoo)
call p%ac%set_asb()
call p%ac%cscnv(info,type='csr')
if (np>1) then
call am1%mv_to(acsr)
nzl = acsr%get_nzeros()
call psb_glob_to_loc(acsr%ja(1:nzl),p%desc_ac,info,'I')
if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_glob_to_loc')
goto 9999
end if
call am1%mv_from(acsr)
endif
call am1%set_ncols(p%desc_ac%get_local_cols())
if (np>1) then
call am2%mv_to(tmpcoo)
nzl = tmpcoo%get_nzeros()
if (info == psb_success_) call psb_glob_to_loc(tmpcoo%ia(1:nzl),p%desc_ac,info,'I')
if(info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,a_err='Converting am2 to local')
goto 9999
end if
call am2%mv_from(tmpcoo)
call am2%cscnv(info,type='csr')
end if
call am2%set_nrows(p%desc_ac%get_local_cols())
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'Done ac '
case(mld_repl_mat_)
!
!
call psb_cdall(ictxt,p%desc_ac,info,mg=ntaggr,repl=.true.)
nzbr(:) = 0
nzbr(me+1) = bcoo%get_nzeros()
call psb_sum(ictxt,nzbr(1:np))
nzac = sum(nzbr)
if (info == psb_success_) call tmpcoo%allocate(ntaggr,ntaggr,nzac)
if (info /= psb_success_) goto 9999
do ip=1,np
idisp(ip) = sum(nzbr(1:ip-1))
enddo
ndx = nzbr(me+1)
call mpi_allgatherv(bcoo%val,ndx,mpi_complex,tmpcoo%val,nzbr,idisp,&
& mpi_complex,icomm,info)
if (info == psb_success_)&
& call mpi_allgatherv(bcoo%ia,ndx,psb_mpi_ipk_integer,tmpcoo%ia,nzbr,idisp,&
& psb_mpi_ipk_integer,icomm,info)
if (info == psb_success_)&
& call mpi_allgatherv(bcoo%ja,ndx,psb_mpi_ipk_integer,tmpcoo%ja,nzbr,idisp,&
& psb_mpi_ipk_integer,icomm,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err=' from mpi_allgatherv')
goto 9999
end if
call bcoo%free()
call tmpcoo%fix(info)
call p%ac%mv_from(tmpcoo)
call p%ac%cscnv(info,type='csr')
if(info /= psb_success_) goto 9999
deallocate(nzbr,idisp,stat=info)
if (info /= psb_success_) then
info = psb_err_alloc_dealloc_
call psb_errpush(info,name)
goto 9999
end if
case default
info = psb_err_internal_error_
call psb_errpush(info,name,a_err='invalid mld_coarse_mat_')
goto 9999
end select
call p%ac%cscnv(info,type='csr')
if(info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='spcnv')
goto 9999
end if
!
! Copy the prolongation/restriction matrices into the descriptor map.
! am2 => R i.e. restriction operator
! am1 => P i.e. prolongation operator
!
p%map = psb_linmap(psb_map_aggr_,desc_a,&
& p%desc_ac,am2,am1,ilaggr,nlaggr)
if (info == psb_success_) call am1%free()
if (info == psb_success_) call am2%free()
if(info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='sp_Free')
goto 9999
end if
if (debug_level >= psb_debug_outer_) & if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),& & write(debug_unit,*) me,' ',trim(name),&

163
mlprec/impl/mld_caggrmat_nosmth_asb.F90 → mlprec/impl/mld_caggrmat_nosmth_asb.f90
Unescape Escape View File

@ -81,35 +81,29 @@
! info - integer, output. ! info - integer, output.
! Error code. ! Error code.
! !
subroutine mld_caggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,p,info) subroutine mld_caggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_restr,info)
use psb_base_mod use psb_base_mod
use mld_c_inner_mod, mld_protect_name => mld_caggrmat_nosmth_asb use mld_c_inner_mod, mld_protect_name => mld_caggrmat_nosmth_asb
#ifdef MPI_MOD
use mpi
#endif
implicit none implicit none
#ifdef MPI_H
include 'mpif.h'
#endif
! Arguments ! Arguments
type(psb_cspmat_type), intent(in) :: a type(psb_cspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_a type(psb_desc_type), intent(in) :: desc_a
integer, intent(inout) :: ilaggr(:), nlaggr(:) integer, intent(inout) :: ilaggr(:), nlaggr(:)
type(mld_c_onelev_type), intent(inout), target :: p type(mld_sml_parms), intent(inout) :: parms
type(psb_cspmat_type), intent(out) :: ac,op_prol,op_restr
integer, intent(out) :: info integer, intent(out) :: info
! Local variables ! Local variables
integer :: ictxt,np,me, err_act integer :: ictxt,np,me, err_act
integer(psb_mpik_) :: icomm, ndx, minfo integer(psb_mpik_) :: icomm, ndx, minfo
character(len=20) :: name character(len=20) :: name
type(psb_cspmat_type) :: b
integer(psb_mpik_), allocatable :: nzbr(:), idisp(:)
integer(psb_ipk_) :: ierr(5) integer(psb_ipk_) :: ierr(5)
type(psb_cspmat_type) :: am1,am2 type(psb_c_coo_sparse_mat) :: ac_coo, acoo
type(psb_c_coo_sparse_mat) :: acoo1, acoo2, bcoo, ac_coo type(psb_c_csr_sparse_mat) :: acsr1, acsr2
integer :: nrow, nglob, ncol, ntaggr, nzac, ip, & integer :: debug_level, debug_unit
integer :: nrow, nglob, ncol, ntaggr, nzl, ip, &
& naggr, nzt, naggrm1, i & naggr, nzt, naggrm1, i
name='mld_aggrmat_nosmth_asb' name='mld_aggrmat_nosmth_asb'
@ -128,141 +122,48 @@ subroutine mld_caggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,p,info)
naggr = nlaggr(me+1) naggr = nlaggr(me+1)
ntaggr = sum(nlaggr) ntaggr = sum(nlaggr)
allocate(nzbr(np), idisp(np),stat=info)
if (info /= psb_success_) then
info=psb_err_alloc_request_; ierr(1)=2*np;
call psb_errpush(info,name,i_err=ierr,a_err='integer')
goto 9999
end if
naggrm1=sum(nlaggr(1:me)) naggrm1=sum(nlaggr(1:me))
if (p%parms%coarse_mat == mld_repl_mat_) then do i=1, nrow
do i=1, nrow ilaggr(i) = ilaggr(i) + naggrm1
ilaggr(i) = ilaggr(i) + naggrm1 end do
end do call psb_halo(ilaggr,desc_a,info)
call psb_halo(ilaggr,desc_a,info)
end if
if(info /= psb_success_) then if(info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_halo') call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_halo')
goto 9999 goto 9999
end if end if
if (p%parms%coarse_mat == mld_repl_mat_) then call acoo%allocate(ncol,ntaggr,ncol)
call acoo1%allocate(ncol,ntaggr,ncol)
else
call acoo1%allocate(ncol,naggr,ncol)
end if
do i=1,nrow do i=1,nrow
acoo1%val(i) = cone acoo%val(i) = cone
acoo1%ia(i) = i acoo%ia(i) = i
acoo1%ja(i) = ilaggr(i) acoo%ja(i) = ilaggr(i)
end do end do
call acoo1%set_dupl(psb_dupl_add_) call acoo%set_dupl(psb_dupl_add_)
call acoo1%set_nzeros(nrow) call acoo%set_nzeros(nrow)
call acoo1%set_asb() call acoo%set_asb()
call acoo1%fix(info) call acoo%fix(info)
call acoo1%transp(acoo2)
call a%csclip(bcoo,info,jmax=nrow) call op_prol%mv_from(acoo)
call op_prol%cscnv(info,type='csr',dupl=psb_dupl_add_)
if (info == psb_success_) call op_prol%transp(op_restr)
call a%csclip(ac_coo,info,jmax=nrow)
nzt = bcoo%get_nzeros() nzt = ac_coo%get_nzeros()
do i=1, nzt do i=1, nzt
bcoo%ia(i) = ilaggr(bcoo%ia(i)) ac_coo%ia(i) = ilaggr(ac_coo%ia(i))
bcoo%ja(i) = ilaggr(bcoo%ja(i)) ac_coo%ja(i) = ilaggr(ac_coo%ja(i))
enddo enddo
call bcoo%set_nrows(naggr) call ac_coo%set_nrows(naggr)
call bcoo%set_ncols(naggr) call ac_coo%set_ncols(naggr)
call bcoo%set_dupl(psb_dupl_add_) call ac_coo%set_dupl(psb_dupl_add_)
call bcoo%fix(info) call ac_coo%fix(info)
call ac%mv_from(ac_coo)
if (p%parms%coarse_mat == mld_repl_mat_) then
call psb_cdall(ictxt,p%desc_ac,info,mg=ntaggr,repl=.true.)
if (info == psb_success_) call psb_cdasb(p%desc_ac,info)
if(info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_cdall')
goto 9999
end if
nzbr(:) = 0
nzbr(me+1) = nzt
call psb_sum(ictxt,nzbr(1:np))
nzac = sum(nzbr)
call ac_coo%allocate(ntaggr,ntaggr,nzac)
do ip=1,np
idisp(ip) = sum(nzbr(1:ip-1))
enddo
ndx = nzbr(me+1)
call mpi_allgatherv(bcoo%val,ndx,mpi_complex,ac_coo%val,nzbr,idisp,&
& mpi_complex,icomm,minfo)
call mpi_allgatherv(bcoo%ia,ndx,psb_mpi_ipk_integer,ac_coo%ia,nzbr,idisp,&
& psb_mpi_ipk_integer,icomm,minfo)
call mpi_allgatherv(bcoo%ja,ndx,psb_mpi_ipk_integer,ac_coo%ja,nzbr,idisp,&
& psb_mpi_ipk_integer,icomm,minfo)
if(info /= psb_success_) then
info=-1
call psb_errpush(info,name)
goto 9999
end if
call ac_coo%set_nzeros(nzac)
call ac_coo%set_dupl(psb_dupl_add_)
call ac_coo%fix(info)
call p%ac%mv_from(ac_coo)
else if (p%parms%coarse_mat == mld_distr_mat_) then
call psb_cdall(ictxt,p%desc_ac,info,nl=naggr)
if (info == psb_success_) call psb_cdasb(p%desc_ac,info)
call p%ac%mv_from(bcoo)
if(info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,a_err='Build ac, desc_ac')
goto 9999
end if
else
info = psb_err_internal_error_
call psb_errpush(psb_err_internal_error_,name,a_err='invalid mld_coarse_mat_')
goto 9999
end if
call bcoo%free()
deallocate(nzbr,idisp)
call p%ac%cscnv(info,type='csr',dupl=psb_dupl_add_)
if(info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='cscnv')
goto 9999
end if
call am1%mv_from(acoo1)
call am1%cscnv(info,type='csr',dupl=psb_dupl_add_)
if (info == psb_success_) call am2%mv_from(acoo2)
if (info == psb_success_) call am2%cscnv(info,type='csr',dupl=psb_dupl_add_)
!
! Copy the prolongation/restriction matrices into the descriptor map.
! am2 => PR^T i.e. restriction operator
! am1 => PR i.e. prolongation operator
!
if (info == psb_success_) &
& p%map = psb_linmap(psb_map_aggr_,desc_a,&
& p%desc_ac,am2,am1,ilaggr,nlaggr)
if (info == psb_success_) call am1%free()
if (info == psb_success_) call am2%free()
if(info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='linmap build')
goto 9999
end if
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)

421
mlprec/impl/mld_caggrmat_smth_asb.F90 → mlprec/impl/mld_caggrmat_smth_asb.f90
Unescape Escape View File

@ -61,11 +61,6 @@
! according to the value of p%parms%aggr_omega_alg, specified by the user ! according to the value of p%parms%aggr_omega_alg, specified by the user
! through mld_cprecinit and mld_zprecset. ! through mld_cprecinit and mld_zprecset.
! !
! This routine can also build A_C according to a "bizarre" aggregation algorithm,
! using a "naive" prolongator proposed by the authors of MLD2P4. However, this
! prolongator still requires a deep analysis and testing and its use is not
! recommended.
!
! The coarse-level matrix A_C is distributed among the parallel processes or ! The coarse-level matrix A_C is distributed among the parallel processes or
! replicated on each of them, according to the value of p%parms%coarse_mat, ! replicated on each of them, according to the value of p%parms%coarse_mat,
! specified by the user through mld_cprecinit and mld_zprecset. ! specified by the user through mld_cprecinit and mld_zprecset.
@ -98,38 +93,31 @@
! info - integer, output. ! info - integer, output.
! Error code. ! Error code.
! !
subroutine mld_caggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info) subroutine mld_caggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_restr,info)
use psb_base_mod use psb_base_mod
use mld_c_inner_mod, mld_protect_name => mld_caggrmat_smth_asb use mld_c_inner_mod, mld_protect_name => mld_caggrmat_smth_asb
#ifdef MPI_MOD
use mpi
#endif
implicit none implicit none
#ifdef MPI_H
include 'mpif.h'
#endif
! Arguments ! Arguments
type(psb_cspmat_type), intent(in) :: a type(psb_cspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_a type(psb_desc_type), intent(in) :: desc_a
integer, intent(inout) :: ilaggr(:), nlaggr(:) integer, intent(inout) :: ilaggr(:), nlaggr(:)
type(mld_c_onelev_type), intent(inout), target :: p type(mld_sml_parms), intent(inout) :: parms
type(psb_cspmat_type), intent(out) :: ac,op_prol,op_restr
integer, intent(out) :: info integer, intent(out) :: info
! Local variables ! Local variables
type(psb_cspmat_type) :: b integer :: nrow, nglob, ncol, ntaggr, ip, ndx,&
integer, allocatable :: nzbr(:), idisp(:)
integer :: nrow, nglob, ncol, ntaggr, nzac, ip, ndx,&
& naggr, nzl,naggrm1,naggrp1, i, j, k, jd, icolF, nrw & naggr, nzl,naggrm1,naggrp1, i, j, k, jd, icolF, nrw
integer ::ictxt, np, me, err_act integer ::ictxt, np, me, err_act
character(len=20) :: name character(len=20) :: name
type(psb_cspmat_type) :: am1,am2, am3, am4 type(psb_cspmat_type) :: am3, am4
type(psb_c_coo_sparse_mat) :: acoo, acoof, bcoo type(psb_c_coo_sparse_mat) :: tmpcoo
type(psb_c_csr_sparse_mat) :: acsr1, acsr2, acsr3, acsrf, ptilde type(psb_c_csr_sparse_mat) :: acsr1, acsr2, acsr3, acsrf, ptilde
complex(psb_spk_), allocatable :: adiag(:) complex(psb_spk_), allocatable :: adiag(:)
integer(psb_ipk_) :: ierr(5) integer(psb_ipk_) :: ierr(5)
logical :: ml_global_nmb, filter_mat logical :: filter_mat
integer :: debug_level, debug_unit integer :: debug_level, debug_unit
integer, parameter :: ncmax=16 integer, parameter :: ncmax=16
real(psb_spk_) :: anorm, omega, tmp, dg, theta real(psb_spk_) :: anorm, omega, tmp, dg, theta
@ -150,34 +138,21 @@ subroutine mld_caggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info)
nrow = desc_a%get_local_rows() nrow = desc_a%get_local_rows()
ncol = desc_a%get_local_cols() ncol = desc_a%get_local_cols()
theta = p%parms%aggr_thresh theta = parms%aggr_thresh
naggr = nlaggr(me+1) naggr = nlaggr(me+1)
ntaggr = sum(nlaggr) ntaggr = sum(nlaggr)
allocate(nzbr(np), idisp(np),stat=info)
if (info /= psb_success_) then
info=psb_err_alloc_request_; ierr(1)=2*np;
call psb_errpush(info,name,i_err=ierr,a_err='integer')
goto 9999
end if
naggrm1 = sum(nlaggr(1:me)) naggrm1 = sum(nlaggr(1:me))
naggrp1 = sum(nlaggr(1:me+1)) naggrp1 = sum(nlaggr(1:me+1))
ml_global_nmb = ( (p%parms%aggr_kind == mld_smooth_prol_).or.& filter_mat = (parms%aggr_filter == mld_filter_mat_)
& ( (p%parms%aggr_kind == mld_biz_prol_).and.&
& (p%parms%coarse_mat == mld_repl_mat_)) )
filter_mat = (p%parms%aggr_filter == mld_filter_mat_)
if (ml_global_nmb) then ilaggr(1:nrow) = ilaggr(1:nrow) + naggrm1
ilaggr(1:nrow) = ilaggr(1:nrow) + naggrm1 call psb_halo(ilaggr,desc_a,info)
call psb_halo(ilaggr,desc_a,info)
if (info /= psb_success_) then if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_halo') call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_halo')
goto 9999 goto 9999
end if
end if end if
! naggr: number of local aggregates ! naggr: number of local aggregates
@ -202,32 +177,22 @@ subroutine mld_caggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info)
end if end if
! 1. Allocate Ptilde in sparse matrix form ! 1. Allocate Ptilde in sparse matrix form
if (ml_global_nmb) then call tmpcoo%allocate(ncol,ntaggr,ncol)
call acoo%allocate(ncol,ntaggr,ncol) do i=1,ncol
do i=1,ncol tmpcoo%val(i) = cone
acoo%val(i) = cone tmpcoo%ia(i) = i
acoo%ia(i) = i tmpcoo%ja(i) = ilaggr(i)
acoo%ja(i) = ilaggr(i) end do
end do call tmpcoo%set_nzeros(ncol)
call acoo%set_nzeros(ncol) call tmpcoo%set_dupl(psb_dupl_add_)
else
call acoo%allocate(ncol,naggr,ncol) call ptilde%mv_from_coo(tmpcoo,info)
do i=1,nrow
acoo%val(i) = cone
acoo%ia(i) = i
acoo%ja(i) = ilaggr(i)
end do
call acoo%set_nzeros(nrow)
endif
call acoo%set_dupl(psb_dupl_add_)
call ptilde%mv_from_coo(acoo,info)
if (info == psb_success_) call a%cscnv(acsr3,info,dupl=psb_dupl_add_) if (info == psb_success_) call a%cscnv(acsr3,info,dupl=psb_dupl_add_)
if (debug_level >= psb_debug_outer_) & if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),& & write(debug_unit,*) me,' ',trim(name),&
& ' Initial copies sone.' & ' Initial copies sone.'
if (filter_mat) then if (filter_mat) then
! !
! Build the filtered matrix Af from A ! Build the filtered matrix Af from A
@ -252,19 +217,19 @@ subroutine mld_caggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info)
end if end if
enddo enddo
! Take out zeroed terms ! Take out zeroed terms
call acsrf%mv_to_coo(acoof,info) call acsrf%mv_to_coo(tmpcoo,info)
k = 0 k = 0
do j=1,acoof%get_nzeros() do j=1,tmpcoo%get_nzeros()
if ((acoof%val(j) /= czero) .or. (acoof%ia(j) == acoof%ja(j))) then if ((tmpcoo%val(j) /= czero) .or. (tmpcoo%ia(j) == tmpcoo%ja(j))) then
k = k + 1 k = k + 1
acoof%val(k) = acoof%val(j) tmpcoo%val(k) = tmpcoo%val(j)
acoof%ia(k) = acoof%ia(j) tmpcoo%ia(k) = tmpcoo%ia(j)
acoof%ja(k) = acoof%ja(j) tmpcoo%ja(k) = tmpcoo%ja(j)
end if end if
end do end do
call acoof%set_nzeros(k) call tmpcoo%set_nzeros(k)
call acoof%set_dupl(psb_dupl_add_) call tmpcoo%set_dupl(psb_dupl_add_)
call acsrf%mv_from_coo(acoof,info) call acsrf%mv_from_coo(tmpcoo,info)
end if end if
@ -281,41 +246,13 @@ subroutine mld_caggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info)
if (info /= psb_success_) goto 9999 if (info /= psb_success_) goto 9999
if (p%parms%aggr_omega_alg == mld_eig_est_) then if (parms%aggr_omega_alg == mld_eig_est_) then
if (p%parms%aggr_eig == mld_max_norm_) then if (parms%aggr_eig == mld_max_norm_) then
if (p%parms%aggr_kind == mld_biz_prol_) then anorm = acsr3%csnmi()
!
! This only works with CSR
!
anorm = szero
dg = sone
nrw = acsr3%get_nrows()
do i=1, nrw
tmp = szero
do j=acsr3%irp(i),acsr3%irp(i+1)-1
if (acsr3%ja(j) <= nrw) then
tmp = tmp + abs(acsr3%val(j))
endif
if (acsr3%ja(j) == i ) then
dg = abs(acsr3%val(j))
end if
end do
anorm = max(anorm,tmp/dg)
enddo
call psb_amx(ictxt,anorm)
else
anorm = acsr3%csnmi()
endif
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,a_err='Invalid AM3 storage format')
goto 9999
end if
omega = 4.d0/(3.d0*anorm) omega = 4.d0/(3.d0*anorm)
p%parms%aggr_omega_val = omega parms%aggr_omega_val = omega
else else
info = psb_err_internal_error_ info = psb_err_internal_error_
@ -323,11 +260,11 @@ subroutine mld_caggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info)
goto 9999 goto 9999
end if end if
else if (p%parms%aggr_omega_alg == mld_user_choice_) then else if (parms%aggr_omega_alg == mld_user_choice_) then
omega = p%parms%aggr_omega_val omega = parms%aggr_omega_val
else if (p%parms%aggr_omega_alg /= mld_user_choice_) then else if (parms%aggr_omega_alg /= mld_user_choice_) then
info = psb_err_internal_error_ info = psb_err_internal_error_
call psb_errpush(info,name,a_err='invalid mld_aggr_omega_alg_') call psb_errpush(info,name,a_err='invalid mld_aggr_omega_alg_')
goto 9999 goto 9999
@ -368,7 +305,7 @@ subroutine mld_caggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info)
if (debug_level >= psb_debug_outer_) & if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),& & write(debug_unit,*) me,' ',trim(name),&
& 'Done NUMBMM 1' & 'Done NUMBMM 1'
else else
! !
! Build the smoothed prolongator using the original matrix ! Build the smoothed prolongator using the original matrix
@ -409,76 +346,64 @@ subroutine mld_caggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info)
call ptilde%free() call ptilde%free()
call acsr1%set_dupl(psb_dupl_add_) call acsr1%set_dupl(psb_dupl_add_)
call am1%mv_from(acsr1) call op_prol%mv_from(acsr1)
if (ml_global_nmb) then !
! ! Now we have to gather the halo of op_prol, and add it to itself
! Now we have to gather the halo of am1, and add it to itself ! to multiply it by A,
! to multiply it by A, !
! call psb_sphalo(op_prol,desc_a,am4,info,&
call psb_sphalo(am1,desc_a,am4,info,& & colcnv=.false.,rowscale=.true.)
& colcnv=.false.,rowscale=.true.) if (info == psb_success_) call psb_rwextd(ncol,op_prol,info,b=am4)
if (info == psb_success_) call psb_rwextd(ncol,am1,info,b=am4) if (info == psb_success_) call am4%free()
if (info == psb_success_) call am4%free()
else
call psb_rwextd(ncol,am1,info)
endif
if(info /= psb_success_) then if(info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,a_err='Halo of am1') call psb_errpush(psb_err_internal_error_,name,a_err='Halo of op_prol')
goto 9999 goto 9999
end if end if
call psb_symbmm(a,am1,am3,info) call psb_symbmm(a,op_prol,am3,info)
if(info /= psb_success_) then if(info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='symbmm 2') call psb_errpush(psb_err_from_subroutine_,name,a_err='symbmm 2')
goto 9999 goto 9999
end if end if
call psb_numbmm(a,am1,am3) call psb_numbmm(a,op_prol,am3)
if (debug_level >= psb_debug_outer_) & if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),& & write(debug_unit,*) me,' ',trim(name),&
& 'Done NUMBMM 2',p%parms%aggr_kind, mld_smooth_prol_ & 'Done NUMBMM 2',parms%aggr_kind, mld_smooth_prol_
if (p%parms%aggr_kind == mld_smooth_prol_) then call op_prol%transp(op_restr)
call am1%transp(am2) call op_restr%mv_to(tmpcoo)
call am2%mv_to(acoo) nzl = tmpcoo%get_nzeros()
nzl = acoo%get_nzeros() i=0
i=0 !
! ! Now we have to fix this. The only rows of B that are correct
! Now we have to fix this. The only rows of B that are correct ! are those corresponding to "local" aggregates, i.e. indices in ilaggr(:)
! are those corresponding to "local" aggregates, i.e. indices in ilaggr(:) !
! do k=1, nzl
do k=1, nzl if ((naggrm1 < tmpcoo%ia(k)) .and.(tmpcoo%ia(k) <= naggrp1)) then
if ((naggrm1 < acoo%ia(k)) .and.(acoo%ia(k) <= naggrp1)) then i = i+1
i = i+1 tmpcoo%val(i) = tmpcoo%val(k)
acoo%val(i) = acoo%val(k) tmpcoo%ia(i) = tmpcoo%ia(k)
acoo%ia(i) = acoo%ia(k) tmpcoo%ja(i) = tmpcoo%ja(k)
acoo%ja(i) = acoo%ja(k)
end if
end do
call acoo%set_nzeros(i)
call acoo%trim()
call am2%mv_from(acoo)
call am2%cscnv(info,type='csr',dupl=psb_dupl_add_)
if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='spcnv am2')
goto 9999
end if end if
else end do
call am1%transp(am2) call tmpcoo%set_nzeros(i)
endif call tmpcoo%trim()
call op_restr%mv_from(tmpcoo)
call op_restr%cscnv(info,type='csr',dupl=psb_dupl_add_)
if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='spcnv op_restr')
goto 9999
end if
if (debug_level >= psb_debug_outer_) & if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),& & write(debug_unit,*) me,' ',trim(name),&
& 'starting sphalo/ rwxtd' & 'starting sphalo/ rwxtd'
if (p%parms%aggr_kind == mld_smooth_prol_) then ! op_restr = ((i-wDA)Ptilde)^T
! am2 = ((i-wDA)Ptilde)^T call psb_sphalo(am3,desc_a,am4,info,&
call psb_sphalo(am3,desc_a,am4,info,& & colcnv=.false.,rowscale=.true.)
& colcnv=.false.,rowscale=.true.) if (info == psb_success_) call psb_rwextd(ncol,am3,info,b=am4)
if (info == psb_success_) call psb_rwextd(ncol,am3,info,b=am4) if (info == psb_success_) call am4%free()
if (info == psb_success_) call am4%free()
else if (p%parms%aggr_kind == mld_biz_prol_) then
call psb_rwextd(ncol,am3,info)
endif
if(info /= psb_success_) then if(info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,a_err='Extend am3') call psb_errpush(psb_err_internal_error_,name,a_err='Extend am3')
goto 9999 goto 9999
@ -488,180 +413,12 @@ subroutine mld_caggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info)
if (debug_level >= psb_debug_outer_) & if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),& & write(debug_unit,*) me,' ',trim(name),&
& 'starting symbmm 3' & 'starting symbmm 3'
call psb_symbmm(am2,am3,b,info) call psb_symbmm(op_restr,am3,ac,info)
if (info == psb_success_) call psb_numbmm(am2,am3,b) if (info == psb_success_) call psb_numbmm(op_restr,am3,ac)
if (info == psb_success_) call am3%free() if (info == psb_success_) call am3%free()
if (info == psb_success_) call b%cscnv(info,type='coo',dupl=psb_dupl_add_) if (info == psb_success_) call ac%cscnv(info,type='coo',dupl=psb_dupl_add_)
if (info /= psb_success_) then if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,a_err='Build b = am2 x am3') call psb_errpush(psb_err_internal_error_,name,a_err='Build ac = op_restr x am3')
goto 9999
end if
select case(p%parms%aggr_kind)
case(mld_smooth_prol_)
select case(p%parms%coarse_mat)
case(mld_distr_mat_)
nzac = b%get_nzeros()
nzl = nzac
call b%mv_to(bcoo)
if (info == psb_success_) call psb_cdall(ictxt,p%desc_ac,info,nl=nlaggr(me+1))
if (info == psb_success_) call psb_cdins(nzl,bcoo%ia,bcoo%ja,p%desc_ac,info)
if (info == psb_success_) call psb_cdasb(p%desc_ac,info)
if (info == psb_success_) call psb_glob_to_loc(bcoo%ia(1:nzl),p%desc_ac,info,iact='I')
if (info == psb_success_) call psb_glob_to_loc(bcoo%ja(1:nzl),p%desc_ac,info,iact='I')
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Creating p%desc_ac and converting ac')
goto 9999
end if
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'Assembld aux descr. distr.'
call p%ac%mv_from(bcoo)
call p%ac%set_nrows(p%desc_ac%get_local_rows())
call p%ac%set_ncols(p%desc_ac%get_local_cols())
call p%ac%set_asb()
if (info == psb_success_) deallocate(nzbr,idisp,stat=info)
if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_sp_free')
goto 9999
end if
if (np>1) then
call am1%mv_to(acsr1)
nzl = acsr1%get_nzeros()
call psb_glob_to_loc(acsr1%ja(1:nzl),p%desc_ac,info,'I')
if(info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_glob_to_loc')
goto 9999
end if
call am1%mv_from(acsr1)
endif
call am1%set_ncols(p%desc_ac%get_local_cols())
if (np>1) then
call am2%cscnv(info,type='coo',dupl=psb_dupl_add_)
call am2%mv_to(acoo)
nzl = acoo%get_nzeros()
if (info == psb_success_) call psb_glob_to_loc(acoo%ia(1:nzl),p%desc_ac,info,'I')
call acoo%set_dupl(psb_dupl_add_)
if (info == psb_success_) call am2%mv_from(acoo)
if (info == psb_success_) call am2%cscnv(info,type='csr')
if(info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,a_err='Converting am2 to local')
goto 9999
end if
end if
call am2%set_nrows(p%desc_ac%get_local_cols())
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'Done ac '
case(mld_repl_mat_)
!
!
call psb_cdall(ictxt,p%desc_ac,info,mg=ntaggr,repl=.true.)
if (info == psb_success_) call psb_cdasb(p%desc_ac,info)
if (info == psb_success_) &
& call psb_gather(p%ac,b,p%desc_ac,info,dupl=psb_dupl_add_,keeploc=.false.)
if (info /= psb_success_) goto 9999
deallocate(nzbr,idisp,stat=info)
if (info /= psb_success_) then
info = psb_err_alloc_dealloc_
call psb_errpush(info,name)
goto 9999
end if
case default
info = psb_err_internal_error_
call psb_errpush(info,name,a_err='invalid mld_coarse_mat_')
goto 9999
end select
case(mld_biz_prol_)
select case(p%parms%coarse_mat)
case(mld_distr_mat_)
call psb_move_alloc(b,p%ac,info)
if (info == psb_success_) call psb_cdall(ictxt,p%desc_ac,info,nl=naggr)
if (info == psb_success_) call psb_cdasb(p%desc_ac,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='Build desc_ac, ac')
goto 9999
end if
case(mld_repl_mat_)
!
!
call psb_cdall(ictxt,p%desc_ac,info,mg=ntaggr,repl=.true.)
if (info == psb_success_) call psb_cdasb(p%desc_ac,info)
if(info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_cdall')
goto 9999
end if
call psb_gather(p%ac,b,p%desc_ac,info,dupl=psb_dupl_add_,keeploc=.false.)
if(info /= psb_success_) goto 9999
deallocate(nzbr,idisp,stat=info)
if (info /= psb_success_) then
info = psb_err_alloc_dealloc_
call psb_errpush(info,name)
goto 9999
end if
case default
info = psb_err_internal_error_
call psb_errpush(info,name,a_err='invalid mld_coarse_mat_')
goto 9999
end select
deallocate(nzbr,idisp,stat=info)
if (info /= psb_success_) then
info = psb_err_alloc_dealloc_
call psb_errpush(info,name)
goto 9999
end if
case default
info = psb_err_internal_error_
call psb_errpush(info,name,a_err='invalid mld_smooth_prol_')
goto 9999
end select
call p%ac%cscnv(info,type='csr',dupl=psb_dupl_add_)
if(info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='spcnv')
goto 9999
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 = psb_linmap(psb_map_aggr_,desc_a,&
& p%desc_ac,am2,am1,ilaggr,nlaggr)
if (info == psb_success_) call am1%free()
if (info == psb_success_) call am2%free()
if(info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='sp_Free')
goto 9999 goto 9999
end if end if

267
mlprec/impl/mld_cmlprec_bld.f90
Unescape Escape View File

@ -93,11 +93,13 @@ subroutine mld_cmlprec_bld(a,desc_a,p,info,amold,vmold)
! Local Variables ! Local Variables
type(mld_cprec_type) :: t_prec type(mld_cprec_type) :: t_prec
Integer :: err,i,k,ictxt, me,np, err_act, iszv, newsz Integer :: err,i,k,ictxt, me,np, err_act, iszv, newsz, casize
integer :: ipv(mld_ifpsz_), val integer :: ipv(mld_ifpsz_), val
integer :: int_err(5) integer :: int_err(5)
character :: upd_ character :: upd_
type(mld_sml_parms) :: prm class(mld_c_base_smoother_type), allocatable :: coarse_sm, base_sm, med_sm
type(mld_sml_parms) :: baseparms, medparms, coarseparms
type(mld_c_onelev_node), pointer :: head, tail, newnode, current
integer :: debug_level, debug_unit integer :: debug_level, debug_unit
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
@ -145,12 +147,22 @@ subroutine mld_cmlprec_bld(a,desc_a,p,info,amold,vmold)
! Check to ensure all procs have the same ! Check to ensure all procs have the same
! !
newsz = -1 newsz = -1
casize = p%coarse_aggr_size
iszv = size(p%precv) iszv = size(p%precv)
call psb_bcast(ictxt,iszv) call psb_bcast(ictxt,iszv)
if (iszv /= size(p%precv)) then call psb_bcast(ictxt,casize)
info=psb_err_internal_error_ if (casize > 0) then
call psb_errpush(info,name,a_err='Inconsistent size of precv') if (casize /= p%coarse_aggr_size) then
goto 9999 info=psb_err_internal_error_
call psb_errpush(info,name,a_err='Inconsistent coarse_aggr_size')
goto 9999
end if
else
if (iszv /= size(p%precv)) then
info=psb_err_internal_error_
call psb_errpush(info,name,a_err='Inconsistent size of precv')
goto 9999
end if
end if end if
if (iszv <= 1) then if (iszv <= 1) then
@ -162,7 +174,161 @@ subroutine mld_cmlprec_bld(a,desc_a,p,info,amold,vmold)
endif endif
if (iszv > 1) then
if (casize>0) then
!
! New strategy to build according to coarse size.
!
coarseparms = p%precv(iszv)%parms
baseparms = p%precv(1)%parms
medparms = p%precv(2)%parms
allocate(coarse_sm, source=p%precv(iszv)%sm,stat=info)
if (info == psb_success_) &
& allocate(med_sm, source=p%precv(2)%sm,stat=info)
if (info == psb_success_) &
& allocate(base_sm, source=p%precv(1)%sm,stat=info)
if (info /= psb_success_) then
write(0,*) 'Error in saving smoothers',info
call psb_errpush(psb_err_internal_error_,name,a_err='Base level precbuild.')
goto 9999
end if
!
! Replicated matrix should only ever happen at coarse level.
!
call mld_check_def(baseparms%coarse_mat,'Coarse matrix',&
& mld_distr_mat_,is_distr_ml_coarse_mat)
!
! Now build a doubly linked list
!
allocate(newnode,stat=info)
if (info /= psb_success_) then
info = psb_err_internal_error_
call psb_errpush(info,name,a_err='List start'); goto 9999
end if
head => newnode
tail => newnode
newnode%item%base_a => a
newnode%item%base_desc => desc_a
newnode%item%parms = baseparms
newsz = 1
current => head
list_build_loop: do
allocate(newnode,stat=info)
if (info /= psb_success_) then
info = psb_err_internal_error_
call psb_errpush(info,name,a_err='List start'); goto 9999
end if
current%next => newnode
newnode%prev => current
newsz = newsz + 1
newnode%item%parms = medparms
newnode%item%parms%aggr_thresh = current%item%parms%aggr_thresh/2
call mld_coarse_bld(current%item%base_a, current%item%base_desc, &
& newnode%item,info)
if (info /= psb_success_) then
info = psb_err_internal_error_
call psb_errpush(info,name,a_err='build next level'); goto 9999
end if
if (newsz>2) then
if (all(current%item%map%naggr == newnode%item%map%naggr)) then
!
! We are not gaining anything
!
newsz = newsz-1
current%next => null()
call newnode%item%free(info)
if (info == psb_success_) deallocate(newnode,stat=info)
if (info /= psb_success_) then
info = psb_err_internal_error_
call psb_errpush(info,name,a_err='Deallocate at list end'); goto 9999
end if
end if
end if
current => current%next
tail => current
if (sum(newnode%item%map%naggr) <= casize) then
!
! Target reached; but we may need to rebuild.
!
exit list_build_loop
end if
end do list_build_loop
!
! At this point, we are at the list tail,
! and it needs to be rebuilt in case the parms were
! different.
!
! But the threshold has to be fixed before rebuliding
coarseparms%aggr_thresh = current%item%parms%aggr_thresh
current%item%parms = coarseparms
call mld_coarse_bld(current%prev%item%base_a,&
& current%prev%item%base_desc, &
& current%item,info)
if (info /= psb_success_) then
info = psb_err_internal_error_
call psb_errpush(info,name,a_err='build next level'); goto 9999
end if
!
! Ok, now allocate the output vector and fix items.
!
do i=1,iszv
if (info == psb_success_) call p%precv(i)%free(info)
end do
if (info == psb_success_) deallocate(p%precv,stat=info)
if (info == psb_success_) allocate(p%precv(newsz),stat=info)
if (info /= psb_success_) then
info = psb_err_internal_error_
call psb_errpush(info,name,a_err='Reallocate precv'); goto 9999
end if
newnode => head
do i=1, newsz
current => newnode
if (info == psb_success_) &
& call mld_move_alloc(current%item,p%precv(i),info)
if (info == psb_success_) then
if (i ==1) then
allocate(p%precv(i)%sm,source=base_sm,stat=info)
else if (i < newsz) then
allocate(p%precv(i)%sm,source=med_sm,stat=info)
else
allocate(p%precv(i)%sm,source=coarse_sm,stat=info)
end if
end if
if (info /= psb_success_) then
info = psb_err_internal_error_
call psb_errpush(info,name,a_err='list cpy'); goto 9999
end if
if (i == 1) then
p%precv(i)%base_a => a
p%precv(i)%base_desc => desc_a
else
p%precv(i)%base_a => p%precv(i)%ac
p%precv(i)%base_desc => p%precv(i)%desc_ac
p%precv(i)%map%p_desc_X => p%precv(i-1)%base_desc
p%precv(i)%map%p_desc_Y => p%precv(i)%base_desc
end if
newnode => current%next
deallocate(current)
end do
call base_sm%free(info)
if (info == psb_success_) call med_sm%free(info)
if (info == psb_success_) call coarse_sm%free(info)
if (info == psb_success_) deallocate(coarse_sm,med_sm,base_sm,stat=info)
if (info /= psb_success_) then
info = psb_err_internal_error_
call psb_errpush(info,name,a_err='final cleanup'); goto 9999
end if
iszv = newsz
else
!
! Default, oldstyle
!
! !
! Build the matrix and the transfer operators corresponding ! Build the matrix and the transfer operators corresponding
@ -179,11 +345,6 @@ subroutine mld_cmlprec_bld(a,desc_a,p,info,amold,vmold)
p%precv(1)%base_a => a p%precv(1)%base_a => a
p%precv(1)%base_desc => desc_a p%precv(1)%base_desc => desc_a
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,a_err='Base level precbuild.')
goto 9999
end if
do i=2, iszv do i=2, iszv
! !
@ -201,11 +362,6 @@ subroutine mld_cmlprec_bld(a,desc_a,p,info,amold,vmold)
! !
call mld_check_def(p%precv(i)%parms%coarse_mat,'Coarse matrix',& call mld_check_def(p%precv(i)%parms%coarse_mat,'Coarse matrix',&
& mld_distr_mat_,is_distr_ml_coarse_mat) & mld_distr_mat_,is_distr_ml_coarse_mat)
else if (i == iszv) then
!!$ call check_coarse_lev(p%precv(i))
end if end if
if (debug_level >= psb_debug_outer_) & if (debug_level >= psb_debug_outer_) &
@ -277,9 +433,7 @@ subroutine mld_cmlprec_bld(a,desc_a,p,info,amold,vmold)
p%precv(i)%map%p_desc_Y => p%precv(i)%base_desc p%precv(i)%map%p_desc_Y => p%precv(i)%base_desc
end do end do
i = iszv i = iszv
call check_coarse_lev(p%precv(i))
if (info == psb_success_) call mld_coarse_bld(p%precv(i-1)%base_a,& if (info == psb_success_) call mld_coarse_bld(p%precv(i-1)%base_a,&
& p%precv(i-1)%base_desc, p%precv(i),info) & p%precv(i-1)%base_desc, p%precv(i),info)
if (info /= psb_success_) then if (info /= psb_success_) then
@ -289,6 +443,12 @@ subroutine mld_cmlprec_bld(a,desc_a,p,info,amold,vmold)
end if end if
end if end if
!
! The coarse space hierarchy has been build.
!
! Now do the preconditioner build.
!
do i=1, iszv do i=1, iszv
! !
! build the base preconditioner at level i ! build the base preconditioner at level i
@ -316,10 +476,6 @@ subroutine mld_cmlprec_bld(a,desc_a,p,info,amold,vmold)
goto 9999 goto 9999
end if end if
!
! Test version for beginning of OO stuff.
!
call p%precv(i)%sm%build(p%precv(i)%base_a,p%precv(i)%base_desc,& call p%precv(i)%sm%build(p%precv(i)%base_a,p%precv(i)%base_desc,&
& 'F',info,amold=amold,vmold=vmold) & 'F',info,amold=amold,vmold=vmold)
@ -350,69 +506,4 @@ subroutine mld_cmlprec_bld(a,desc_a,p,info,amold,vmold)
end if end if
return return
contains
subroutine check_coarse_lev(prec)
type(mld_c_onelev_type) :: prec
!
! At the coarsest level, check mld_coarse_solve_
!
!!$ val = prec%parms%coarse_solve
!!$ select case (val)
!!$ case(mld_jac_)
!!$
!!$ if (prec%prec%iprcparm(mld_sub_solve_) /= mld_diag_scale_) 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_.'
!!$ prec%prec%iprcparm(mld_sub_solve_) = mld_diag_scale_
!!$ end if
!!$ prec%prec%iprcparm(mld_smoother_type_) = mld_jac_
!!$
!!$ case(mld_bjac_)
!!$
!!$ if ((prec%prec%iprcparm(mld_sub_solve_) == mld_diag_scale_).or.&
!!$ & ( prec%prec%iprcparm(mld_smoother_type_) /= mld_bjac_)) 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_.'
!!$! !$#if defined(HAVE_UMF_)
!!$! !$ prec%prec%iprcparm(mld_sub_solve_) = mld_umf_
!!$! !$#elif defined(HAVE_SLU_)
!!$! !$ prec%prec%iprcparm(mld_sub_solve_) = mld_slu_
!!$! !$#else
!!$ prec%prec%iprcparm(mld_sub_solve_) = mld_ilu_n_
!!$! !$#endif
!!$ end if
!!$ prec%prec%iprcparm(mld_smoother_type_) = mld_bjac_
!!$
!!$ case(mld_umf_, mld_slu_)
!!$ if ((prec%iprcparm(mld_coarse_mat_) /= mld_repl_mat_).or.&
!!$ & (prec%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_.'
!!$ prec%iprcparm(mld_coarse_mat_) = mld_repl_mat_
!!$ prec%prec%iprcparm(mld_sub_solve_) = val
!!$ prec%prec%iprcparm(mld_smoother_type_) = mld_bjac_
!!$ end if
!!$ case(mld_sludist_)
!!$ if ((prec%iprcparm(mld_coarse_mat_) /= mld_distr_mat_).or.&
!!$ & (prec%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_.'
!!$ prec%iprcparm(mld_coarse_mat_) = mld_distr_mat_
!!$ prec%prec%iprcparm(mld_sub_solve_) = val
!!$ prec%prec%iprcparm(mld_smoother_type_) = mld_bjac_
!!$ prec%prec%iprcparm(mld_smoother_sweeps_) = 1
!!$ end if
!!$ end select
end subroutine check_coarse_lev
end subroutine mld_cmlprec_bld end subroutine mld_cmlprec_bld

1
mlprec/impl/mld_cprecinit.F90
Unescape Escape View File

@ -125,6 +125,7 @@ subroutine mld_cprecinit(p,ptype,info,nlev)
! Do we want to do something? ! Do we want to do something?
endif endif
endif endif
p%coarse_aggr_size = -1
select case(psb_toupper(ptype(1:len_trim(ptype)))) select case(psb_toupper(ptype(1:len_trim(ptype))))
case ('NOPREC','NONE') case ('NOPREC','NONE')

5
mlprec/impl/mld_cprecset.F90
Unescape Escape View File

@ -129,6 +129,11 @@ subroutine mld_cprecseti(p,what,val,info,ilev)
return return
endif endif
if (what == mld_coarse_aggr_size_) then
p%coarse_aggr_size = max(val,-1)
return
end if
! !
! Set preconditioner parameters at level ilev. ! Set preconditioner parameters at level ilev.
! !

2
mlprec/impl/mld_d_onelev_impl.f90
Unescape Escape View File

@ -154,7 +154,7 @@ subroutine mld_d_base_onelev_free(lv,info)
& call lv%sm%free(info) & call lv%sm%free(info)
call lv%ac%free() call lv%ac%free()
if (psb_is_ok_desc(lv%desc_ac)) & if (lv%desc_ac%is_ok()) &
& call psb_cdfree(lv%desc_ac,info) & call psb_cdfree(lv%desc_ac,info)
call lv%map%free(info) call lv%map%free(info)

2
mlprec/impl/mld_daggrmap_bld.f90
Unescape Escape View File

@ -133,7 +133,7 @@ subroutine mld_daggrmap_bld(aggr_type,theta,a,desc_a,ilaggr,nlaggr,info)
call atmp%set_ncols(nr) call atmp%set_ncols(nr)
if (info == psb_success_) call atrans%free() if (info == psb_success_) call atrans%free()
if (info == psb_success_) call atmp%cscnv(info,type='CSR') if (info == psb_success_) call atmp%cscnv(info,type='CSR')
if (info == psb_success_) call mld_dec_map_bld(theta,atmp,desc_a,nlaggr,ilaggr,info) if (info == psb_success_) call mld_dec_map_bld(theta,atmp,desc_a,nlaggr,ilaggr,info)
if (info == psb_success_) call atmp%free() if (info == psb_success_) call atmp%free()
case default case default

142
mlprec/impl/mld_daggrmat_asb.f90
Unescape Escape View File

@ -113,6 +113,11 @@ subroutine mld_daggrmat_asb(a,desc_a,ilaggr,nlaggr,p,info)
integer, intent(out) :: info integer, intent(out) :: info
! Local variables ! Local variables
type(psb_dspmat_type) :: ac, op_prol,op_restr
type(psb_d_coo_sparse_mat) :: acoo, bcoo
type(psb_d_csr_sparse_mat) :: acsr1
integer :: nzl,ntaggr
integer :: debug_level, debug_unit
integer :: ictxt,np,me, err_act integer :: ictxt,np,me, err_act
character(len=20) :: name character(len=20) :: name
@ -120,6 +125,9 @@ subroutine mld_daggrmat_asb(a,desc_a,ilaggr,nlaggr,p,info)
if(psb_get_errstatus().ne.0) return if(psb_get_errstatus().ne.0) return
info=psb_success_ info=psb_success_
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
debug_unit = psb_get_debug_unit()
debug_level = psb_get_debug_level()
ictxt = desc_a%get_context() ictxt = desc_a%get_context()
@ -128,35 +136,139 @@ subroutine mld_daggrmat_asb(a,desc_a,ilaggr,nlaggr,p,info)
select case (p%parms%aggr_kind) select case (p%parms%aggr_kind)
case (mld_no_smooth_) case (mld_no_smooth_)
call mld_aggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,p,info) call mld_daggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,&
if(info /= psb_success_) then & p%parms,ac,op_prol,op_restr,info)
call psb_errpush(psb_err_from_subroutine_,name,a_err='mld_aggrmat_nosmth_asb')
case(mld_smooth_prol_)
call mld_daggrmat_smth_asb(a,desc_a,ilaggr,nlaggr, &
& p%parms,ac,op_prol,op_restr,info)
case(mld_biz_prol_)
call mld_daggrmat_biz_asb(a,desc_a,ilaggr,nlaggr, &
& p%parms,ac,op_prol,op_restr,info)
case(mld_min_energy_)
call mld_daggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr, &
& p%parms,ac,op_prol,op_restr,info)
case default
info = psb_err_internal_error_
call psb_errpush(info,name,a_err='Invalid aggr kind')
goto 9999
end select
if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='Inner aggrmat asb')
goto 9999
end if
ntaggr = sum(nlaggr)
select case(p%parms%coarse_mat)
case(mld_distr_mat_)
nzl = ac%get_nzeros()
call ac%mv_to(bcoo)
if (info == psb_success_) call psb_cdall(ictxt,p%desc_ac,info,nl=nlaggr(me+1))
if (info == psb_success_) call psb_cdins(nzl,bcoo%ia,bcoo%ja,p%desc_ac,info)
if (info == psb_success_) call psb_cdasb(p%desc_ac,info)
if (info == psb_success_) call psb_glob_to_loc(bcoo%ia(1:nzl),p%desc_ac,info,iact='I')
if (info == psb_success_) call psb_glob_to_loc(bcoo%ja(1:nzl),p%desc_ac,info,iact='I')
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Creating p%desc_ac and converting ac')
goto 9999 goto 9999
end if end if
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'Assembld aux descr. distr.'
call p%ac%mv_from(bcoo)
case(mld_smooth_prol_,mld_biz_prol_) call p%ac%set_nrows(p%desc_ac%get_local_rows())
call p%ac%set_ncols(p%desc_ac%get_local_cols())
call p%ac%set_asb()
call mld_aggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info) if (info /= psb_success_) then
if(info /= psb_success_) then call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_sp_free')
call psb_errpush(psb_err_from_subroutine_,name,a_err='mld_aggrmat_smth_asb')
goto 9999 goto 9999
end if end if
case(mld_min_energy_) if (np>1) then
call op_prol%mv_to(acsr1)
nzl = acsr1%get_nzeros()
call psb_glob_to_loc(acsr1%ja(1:nzl),p%desc_ac,info,'I')
if(info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_glob_to_loc')
goto 9999
end if
call op_prol%mv_from(acsr1)
endif
call op_prol%set_ncols(p%desc_ac%get_local_cols())
call mld_aggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info) if (np>1) then
if(info /= psb_success_) then call op_restr%cscnv(info,type='coo',dupl=psb_dupl_add_)
call psb_errpush(psb_err_from_subroutine_,name,a_err='mld_aggrmat_smth_asb') call op_restr%mv_to(acoo)
goto 9999 nzl = acoo%get_nzeros()
if (info == psb_success_) call psb_glob_to_loc(acoo%ia(1:nzl),p%desc_ac,info,'I')
call acoo%set_dupl(psb_dupl_add_)
if (info == psb_success_) call op_restr%mv_from(acoo)
if (info == psb_success_) call op_restr%cscnv(info,type='csr')
if(info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,a_err='Converting op_restr to local')
goto 9999
end if
end if end if
call op_restr%set_nrows(p%desc_ac%get_local_cols())
case default if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'Done ac '
call psb_errpush(psb_err_internal_error_,name,a_err='Invalid aggr kind') case(mld_repl_mat_)
goto 9999 !
!
call psb_cdall(ictxt,p%desc_ac,info,mg=ntaggr,repl=.true.)
if (info == psb_success_) call psb_cdasb(p%desc_ac,info)
if (info == psb_success_) &
& call psb_gather(p%ac,ac,p%desc_ac,info,dupl=psb_dupl_add_,keeploc=.false.)
if (info /= psb_success_) goto 9999
case default
info = psb_err_internal_error_
call psb_errpush(info,name,a_err='invalid mld_coarse_mat_')
goto 9999
end select end select
call p%ac%cscnv(info,type='csr',dupl=psb_dupl_add_)
if(info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='spcnv')
goto 9999
end if
!
! Copy the prolongation/restriction matrices into the descriptor map.
! op_restr => PR^T i.e. restriction operator
! op_prol => PR i.e. prolongation operator
!
p%map = psb_linmap(psb_map_aggr_,desc_a,&
& p%desc_ac,op_restr,op_prol,ilaggr,nlaggr)
if (info == psb_success_) call op_prol%free()
if (info == psb_success_) call op_restr%free()
if(info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='sp_Free')
goto 9999
end if
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
return return

422
mlprec/impl/mld_daggrmat_biz_asb.f90
Unescape Escape View File

@ -0,0 +1,422 @@
!!$
!!$
!!$ MLD2P4 version 2.0
!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package
!!$ based on PSBLAS (Parallel Sparse BLAS version 3.0)
!!$
!!$ (C) Copyright 2008,2009,2010
!!$
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$ Pasqua D'Ambra ICAR-CNR, Naples
!!$ Daniela di Serafino Second University of Naples
!!$
!!$ Redistribution and use in source and binary forms, with or without
!!$ modification, are permitted provided that the following conditions
!!$ are met:
!!$ 1. Redistributions of source code must retain the above copyright
!!$ notice, this list of conditions and the following disclaimer.
!!$ 2. Redistributions in binary form must reproduce the above copyright
!!$ notice, this list of conditions, and the following disclaimer in the
!!$ documentation and/or other materials provided with the distribution.
!!$ 3. The name of the MLD2P4 group or the names of its contributors may
!!$ not be used to endorse or promote products derived from this
!!$ software without specific written permission.
!!$
!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE MLD2P4 GROUP OR ITS CONTRIBUTORS
!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
!!$ POSSIBILITY OF SUCH DAMAGE.
!!$
!!$
! File: mld_daggrmat_biz_asb.F90
!
! Subroutine: mld_daggrmat_biz_asb
! Version: real
!
! This routine builds a coarse-level matrix A_C from a fine-level matrix A
! by using the Galerkin approach, i.e.
!
! A_C = P_C^T A P_C,
!
! where P_C is a prolongator from the coarse level to the fine one.
!
! This routine builds A_C according to a "bizarre" aggregation algorithm,
! using a "naive" prolongator proposed by the authors of MLD2P4. However, this
! prolongator still requires a deep analysis and testing and its use is not
! recommended.
!
! The coarse-level matrix A_C is distributed among the parallel processes or
! replicated on each of them, according to the value of p%parms%coarse_mat,
! specified by the user through mld_dprecinit and mld_zprecset.
!
! 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.
! p - type(mld_d_onelev_type), input/output.
! The 'one-level' data structure that will contain the local
! part of the matrix to be built as well as the information
! concerning the prolongator and its transpose.
! ilaggr - integer, dimension(:), allocatable.
! The mapping between the row indices of the coarse-level
! matrix and the row indices of the fine-level matrix.
! ilaggr(i)=j means that node i in the adjacency graph
! of the fine-level matrix is mapped onto node j in the
! adjacency graph of the coarse-level matrix.
! nlaggr - integer, dimension(:), allocatable.
! nlaggr(i) contains the aggregates held by process i.
! info - integer, output.
! Error code.
!
subroutine mld_daggrmat_biz_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_restr,info)
use psb_base_mod
use mld_d_inner_mod, mld_protect_name => mld_daggrmat_biz_asb
implicit none
! Arguments
type(psb_dspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_a
integer, intent(inout) :: ilaggr(:), nlaggr(:)
type(mld_dml_parms), intent(inout) :: parms
type(psb_dspmat_type), intent(out) :: ac,op_prol,op_restr
integer, intent(out) :: info
! Local variables
integer :: nrow, nglob, ncol, ntaggr, ip, ndx,&
& naggr, nzl,naggrm1,naggrp1, i, j, k, jd, icolF, nrw
integer ::ictxt, np, me, err_act
character(len=20) :: name
type(psb_dspmat_type) :: am3, am4
type(psb_d_coo_sparse_mat) :: tmpcoo
type(psb_d_csr_sparse_mat) :: acsr1, acsr2, acsr3, acsrf, ptilde
real(psb_dpk_), allocatable :: adiag(:)
integer(psb_ipk_) :: ierr(5)
logical :: filter_mat
integer :: debug_level, debug_unit
integer, parameter :: ncmax=16
real(psb_dpk_) :: anorm, omega, tmp, dg, theta
name='mld_aggrmat_biz_asb'
if(psb_get_errstatus().ne.0) return
info=psb_success_
call psb_erractionsave(err_act)
debug_unit = psb_get_debug_unit()
debug_level = psb_get_debug_level()
ictxt = desc_a%get_context()
ictxt = desc_a%get_context()
call psb_info(ictxt, me, np)
nglob = desc_a%get_global_rows()
nrow = desc_a%get_local_rows()
ncol = desc_a%get_local_cols()
theta = parms%aggr_thresh
naggr = nlaggr(me+1)
ntaggr = sum(nlaggr)
naggrm1 = sum(nlaggr(1:me))
naggrp1 = sum(nlaggr(1:me+1))
filter_mat = (parms%aggr_filter == mld_filter_mat_)
ilaggr(1:nrow) = ilaggr(1:nrow) + naggrm1
call psb_halo(ilaggr,desc_a,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_halo')
goto 9999
end if
! naggr: number of local aggregates
! nrow: local rows.
!
allocate(adiag(ncol),stat=info)
if (info /= psb_success_) then
info=psb_err_alloc_request_; ierr(1)=nrow;
call psb_errpush(info,name,i_err=ierr,a_err='real(psb_dpk_)')
goto 9999
end if
! Get the diagonal D
call a%get_diag(adiag,info)
if (info == psb_success_) &
& call psb_halo(adiag,desc_a,info)
if(info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='sp_getdiag')
goto 9999
end if
! 1. Allocate Ptilde in sparse matrix form
call tmpcoo%allocate(ncol,naggr,ncol)
do i=1,nrow
tmpcoo%val(i) = done
tmpcoo%ia(i) = i
tmpcoo%ja(i) = ilaggr(i)
end do
call tmpcoo%set_nzeros(nrow)
call tmpcoo%set_dupl(psb_dupl_add_)
call ptilde%mv_from_coo(tmpcoo,info)
if (info == psb_success_) call a%cscnv(acsr3,info,dupl=psb_dupl_add_)
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& ' Initial copies sone.'
if (filter_mat) then
!
! Build the filtered matrix Af from A
!
if (info == psb_success_) call a%cscnv(acsrf,info,dupl=psb_dupl_add_)
do i=1,nrow
tmp = dzero
jd = -1
do j=acsrf%irp(i),acsrf%irp(i+1)-1
if (acsrf%ja(j) == i) jd = j
if (abs(acsrf%val(j)) < theta*sqrt(abs(adiag(i)*adiag(acsrf%ja(j))))) then
tmp=tmp+acsrf%val(j)
acsrf%val(j)=dzero
endif
enddo
if (jd == -1) then
write(0,*) 'Wrong input: we need the diagonal!!!!', i
else
acsrf%val(jd)=acsrf%val(jd)-tmp
end if
enddo
! Take out zeroed terms
call acsrf%mv_to_coo(tmpcoo,info)
k = 0
do j=1,tmpcoo%get_nzeros()
if ((tmpcoo%val(j) /= dzero) .or. (tmpcoo%ia(j) == tmpcoo%ja(j))) then
k = k + 1
tmpcoo%val(k) = tmpcoo%val(j)
tmpcoo%ia(k) = tmpcoo%ia(j)
tmpcoo%ja(k) = tmpcoo%ja(j)
end if
end do
call tmpcoo%set_nzeros(k)
call tmpcoo%set_dupl(psb_dupl_add_)
call acsrf%mv_from_coo(tmpcoo,info)
end if
do i=1,size(adiag)
if (adiag(i) /= dzero) then
adiag(i) = done / adiag(i)
else
adiag(i) = done
end if
end do
if (filter_mat) call acsrf%scal(adiag,info)
if (info == psb_success_) call acsr3%scal(adiag,info)
if (info /= psb_success_) goto 9999
if (parms%aggr_omega_alg == mld_eig_est_) then
if (parms%aggr_eig == mld_max_norm_) then
!
! This only works with CSR
!
anorm = dzero
dg = done
nrw = acsr3%get_nrows()
do i=1, nrw
tmp = dzero
do j=acsr3%irp(i),acsr3%irp(i+1)-1
if (acsr3%ja(j) <= nrw) then
tmp = tmp + abs(acsr3%val(j))
endif
if (acsr3%ja(j) == i ) then
dg = abs(acsr3%val(j))
end if
end do
anorm = max(anorm,tmp/dg)
enddo
call psb_amx(ictxt,anorm)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,a_err='Invalid AM3 storage format')
goto 9999
end if
omega = 4.d0/(3.d0*anorm)
parms%aggr_omega_val = omega
else
info = psb_err_internal_error_
call psb_errpush(info,name,a_err='invalid mld_aggr_eig_')
goto 9999
end if
else if (parms%aggr_omega_alg == mld_user_choice_) then
omega = parms%aggr_omega_val
else if (parms%aggr_omega_alg /= mld_user_choice_) then
info = psb_err_internal_error_
call psb_errpush(info,name,a_err='invalid mld_aggr_omega_alg_')
goto 9999
end if
if (filter_mat) then
!
! Build the smoothed prolongator using the filtered matrix
!
do i=1,acsrf%get_nrows()
do j=acsrf%irp(i),acsrf%irp(i+1)-1
if (acsrf%ja(j) == i) then
acsrf%val(j) = done - omega*acsrf%val(j)
else
acsrf%val(j) = - omega*acsrf%val(j)
end if
end do
end do
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'Done gather, going for SYMBMM 1'
!
! Symbmm90 does the allocation for its result.
!
! acsrm1 = (I-w*D*Af)Ptilde
! Doing it this way means to consider diag(Af_i)
!
!
call psb_symbmm(acsrf,ptilde,acsr1,info)
if(info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='symbmm 1')
goto 9999
end if
call psb_numbmm(acsrf,ptilde,acsr1)
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'Done NUMBMM 1'
else
!
! Build the smoothed prolongator using the original matrix
!
do i=1,acsr3%get_nrows()
do j=acsr3%irp(i),acsr3%irp(i+1)-1
if (acsr3%ja(j) == i) then
acsr3%val(j) = done - omega*acsr3%val(j)
else
acsr3%val(j) = - omega*acsr3%val(j)
end if
end do
end do
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'Done gather, going for SYMBMM 1'
!
! Symbmm90 does the allocation for its result.
!
! acsrm1 = (I-w*D*A)Ptilde
! Doing it this way means to consider diag(A_i)
!
!
call psb_symbmm(acsr3,ptilde,acsr1,info)
if(info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='symbmm 1')
goto 9999
end if
call psb_numbmm(acsr3,ptilde,acsr1)
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'Done NUMBMM 1'
end if
call ptilde%free()
call acsr1%set_dupl(psb_dupl_add_)
call op_prol%mv_from(acsr1)
call psb_rwextd(ncol,op_prol,info)
if(info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,a_err='Halo of op_prol')
goto 9999
end if
call psb_symbmm(a,op_prol,am3,info)
if(info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='symbmm 2')
goto 9999
end if
call psb_numbmm(a,op_prol,am3)
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'Done NUMBMM 2',parms%aggr_kind, mld_smooth_prol_
call op_prol%transp(op_restr)
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'starting sphalo/ rwxtd'
call psb_rwextd(ncol,am3,info)
if(info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,a_err='Extend am3')
goto 9999
end if
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'starting symbmm 3'
call psb_symbmm(op_restr,am3,ac,info)
if (info == psb_success_) call psb_numbmm(op_restr,am3,ac)
if (info == psb_success_) call am3%free()
if (info == psb_success_) call ac%cscnv(info,type='coo',dupl=psb_dupl_add_)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,a_err='Build b = op_restr x am3')
goto 9999
end if
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'Done smooth_aggregate '
call psb_erractionrestore(err_act)
return
9999 continue
call psb_errpush(info,name)
call psb_erractionrestore(err_act)
if (err_act.eq.psb_act_abort_) then
call psb_error()
return
end if
return
end subroutine mld_daggrmat_biz_asb

222
mlprec/impl/mld_daggrmat_minnrg_asb.F90 → mlprec/impl/mld_daggrmat_minnrg_asb.f90
Unescape Escape View File

@ -98,37 +98,31 @@
! info - integer, output. ! info - integer, output.
! Error code. ! Error code.
! !
subroutine mld_daggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info) subroutine mld_daggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_restr,info)
use psb_base_mod use psb_base_mod
use mld_d_inner_mod, mld_protect_name => mld_daggrmat_minnrg_asb use mld_d_inner_mod, mld_protect_name => mld_daggrmat_minnrg_asb
#ifdef MPI_MOD
use mpi
#endif
implicit none implicit none
#ifdef MPI_H
include 'mpif.h'
#endif
! Arguments ! Arguments
type(psb_dspmat_type), intent(in) :: a type(psb_dspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_a type(psb_desc_type), intent(in) :: desc_a
integer, intent(inout) :: ilaggr(:), nlaggr(:) integer, intent(inout) :: ilaggr(:), nlaggr(:)
type(mld_d_onelev_type), intent(inout), target :: p type(mld_dml_parms), intent(inout) :: parms
type(psb_dspmat_type), intent(out) :: ac,op_prol,op_restr
integer, intent(out) :: info integer, intent(out) :: info
! Local variables ! Local variables
type(psb_dspmat_type) :: b
integer(psb_mpik_), allocatable :: nzbr(:), idisp(:) integer(psb_mpik_), allocatable :: nzbr(:), idisp(:)
integer :: nrow, nglob, ncol, ntaggr, nzac, ip, ndx,& integer :: nrow, nglob, ncol, ntaggr, nzac, ip, ndx,&
& naggr, nzl,naggrm1,naggrp1, i, j, k, jd, icolF, nrt & naggr, nzl,naggrm1,naggrp1, i, j, k, jd, icolF, nrt
integer :: ictxt,np,me, err_act, icomm integer :: ictxt,np,me, err_act, icomm
character(len=20) :: name character(len=20) :: name
type(psb_dspmat_type) :: am1,am2, af, ptilde, rtilde, atran, atp, atdatp type(psb_dspmat_type) :: af, ptilde, rtilde, atran, atp, atdatp
type(psb_dspmat_type) :: am3,am4, ap, adap,atmp,rada, ra, atmp2, dap, dadap, da type(psb_dspmat_type) :: am3,am4, ap, adap,atmp,rada, ra, atmp2, dap, dadap, da
type(psb_dspmat_type) :: dat, datp, datdatp, atmp3 type(psb_dspmat_type) :: dat, datp, datdatp, atmp3
type(psb_d_coo_sparse_mat) :: acoo, acoof, bcoo, tmpcoo type(psb_d_coo_sparse_mat) :: tmpcoo
type(psb_d_csr_sparse_mat) :: acsr1, acsr2, acsr3, bcsr, acsr, acsrf type(psb_d_csr_sparse_mat) :: acsr1, acsr2, acsr3, acsr, acsrf
type(psb_d_csc_sparse_mat) :: csc_dap, csc_dadap, csc_datp, csc_datdatp, acsc type(psb_d_csc_sparse_mat) :: csc_dap, csc_dadap, csc_datp, csc_datdatp, acsc
real(psb_dpk_), allocatable :: adiag(:), adinv(:) real(psb_dpk_), allocatable :: adiag(:), adinv(:)
real(psb_dpk_), allocatable :: omf(:), omp(:), omi(:), oden(:) real(psb_dpk_), allocatable :: omf(:), omp(:), omi(:), oden(:)
@ -156,7 +150,7 @@ subroutine mld_daggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info)
nrow = desc_a%get_local_rows() nrow = desc_a%get_local_rows()
ncol = desc_a%get_local_cols() ncol = desc_a%get_local_cols()
theta = p%parms%aggr_thresh theta = parms%aggr_thresh
naggr = nlaggr(me+1) naggr = nlaggr(me+1)
ntaggr = sum(nlaggr) ntaggr = sum(nlaggr)
@ -171,7 +165,7 @@ subroutine mld_daggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info)
naggrm1 = sum(nlaggr(1:me)) naggrm1 = sum(nlaggr(1:me))
naggrp1 = sum(nlaggr(1:me+1)) naggrp1 = sum(nlaggr(1:me+1))
filter_mat = (p%parms%aggr_filter == mld_filter_mat_) filter_mat = (parms%aggr_filter == mld_filter_mat_)
ilaggr(1:nrow) = ilaggr(1:nrow) + naggrm1 ilaggr(1:nrow) = ilaggr(1:nrow) + naggrm1
call psb_halo(ilaggr,desc_a,info) call psb_halo(ilaggr,desc_a,info)
@ -213,16 +207,16 @@ subroutine mld_daggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info)
! 1. Allocate Ptilde in sparse matrix form ! 1. Allocate Ptilde in sparse matrix form
call acoo%allocate(ncol,ntaggr,ncol) call tmpcoo%allocate(ncol,ntaggr,ncol)
do i=1,ncol do i=1,ncol
acoo%val(i) = done tmpcoo%val(i) = done
acoo%ia(i) = i tmpcoo%ia(i) = i
acoo%ja(i) = ilaggr(i) tmpcoo%ja(i) = ilaggr(i)
end do end do
call acoo%set_nzeros(ncol) call tmpcoo%set_nzeros(ncol)
call acoo%set_dupl(psb_dupl_add_) call tmpcoo%set_dupl(psb_dupl_add_)
call acoo%set_asb() call tmpcoo%set_asb()
call ptilde%mv_from(acoo) call ptilde%mv_from(tmpcoo)
call ptilde%cscnv(info,type='csr') call ptilde%cscnv(info,type='csr')
!!$ call local_dump(me,ptilde,'csr-ptilde','Ptilde-1') !!$ call local_dump(me,ptilde,'csr-ptilde','Ptilde-1')
@ -280,7 +274,7 @@ subroutine mld_daggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info)
call am3%mv_to(acsr3) call am3%mv_to(acsr3)
! Compute omega_int ! Compute omega_int
ommx = cmplx(szero,szero) ommx = cmplx(dzero,dzero)
do i=1, ncol do i=1, ncol
omi(i) = omp(ilaggr(i)) omi(i) = omp(ilaggr(i))
if(abs(omi(i)) .gt. abs(ommx)) ommx = omi(i) if(abs(omi(i)) .gt. abs(ommx)) ommx = omi(i)
@ -354,17 +348,17 @@ subroutine mld_daggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info)
! !
! Symbmm90 does the allocation for its result. ! Symbmm90 does the allocation for its result.
! !
! am1 = (I-w*D*Af)Ptilde ! op_prol = (I-w*D*Af)Ptilde
! Doing it this way means to consider diag(Af_i) ! Doing it this way means to consider diag(Af_i)
! !
! !
call psb_symbmm(af,ptilde,am1,info) call psb_symbmm(af,ptilde,op_prol,info)
if(info /= psb_success_) then if(info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='symbmm 1') call psb_errpush(psb_err_from_subroutine_,name,a_err='symbmm 1')
goto 9999 goto 9999
end if end if
call psb_numbmm(af,ptilde,am1) call psb_numbmm(af,ptilde,op_prol)
if (debug_level >= psb_debug_outer_) & if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),& & write(debug_unit,*) me,' ',trim(name),&
@ -390,16 +384,16 @@ subroutine mld_daggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info)
! !
! Symbmm90 does the allocation for its result. ! Symbmm90 does the allocation for its result.
! !
! am1 = (I-w*D*A)Ptilde ! op_prol = (I-w*D*A)Ptilde
! !
! !
call psb_symbmm(am3,ptilde,am1,info) call psb_symbmm(am3,ptilde,op_prol,info)
if(info /= psb_success_) then if(info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='symbmm 1') call psb_errpush(psb_err_from_subroutine_,name,a_err='symbmm 1')
goto 9999 goto 9999
end if end if
call psb_numbmm(am3,ptilde,am1) call psb_numbmm(am3,ptilde,op_prol)
if (debug_level >= psb_debug_outer_) & if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),& & write(debug_unit,*) me,' ',trim(name),&
@ -458,7 +452,7 @@ subroutine mld_daggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info)
omp = omp/oden omp = omp/oden
! !$ write(0,*) 'Check on output restrictor',omp(1:min(size(omp),10)) ! !$ write(0,*) 'Check on output restrictor',omp(1:min(size(omp),10))
! Compute omega_int ! Compute omega_int
ommx = cmplx(szero,szero) ommx = cmplx(dzero,dzero)
do i=1, ncol do i=1, ncol
omi(i) = omp(ilaggr(i)) omi(i) = omp(ilaggr(i))
if(abs(omi(i)) .gt. abs(ommx)) ommx = omi(i) if(abs(omi(i)) .gt. abs(ommx)) ommx = omi(i)
@ -509,20 +503,20 @@ subroutine mld_daggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info)
call rtilde%mv_from(tmpcoo) call rtilde%mv_from(tmpcoo)
call rtilde%cscnv(info,type='csr') call rtilde%cscnv(info,type='csr')
call psb_symbmm(rtilde,atmp,am2,info) call psb_symbmm(rtilde,atmp,op_restr,info)
call psb_numbmm(rtilde,atmp,am2) call psb_numbmm(rtilde,atmp,op_restr)
! !
! Now we have to gather the halo of am1, and add it to itself ! Now we have to gather the halo of op_prol, and add it to itself
! to multiply it by A, ! to multiply it by A,
! !
call psb_sphalo(am1,desc_a,am4,info,& call psb_sphalo(op_prol,desc_a,am4,info,&
& colcnv=.false.,rowscale=.true.) & colcnv=.false.,rowscale=.true.)
if (info == psb_success_) call psb_rwextd(ncol,am1,info,b=am4) if (info == psb_success_) call psb_rwextd(ncol,op_prol,info,b=am4)
if (info == psb_success_) call am4%free() if (info == psb_success_) call am4%free()
if(info /= psb_success_) then if(info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,a_err='Halo of am1') call psb_errpush(psb_err_internal_error_,name,a_err='Halo of op_prol')
goto 9999 goto 9999
end if end if
@ -530,7 +524,7 @@ subroutine mld_daggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info)
! Now we have to fix this. The only rows of B that are correct ! Now we have to fix this. The only rows of B that are correct
! are those corresponding to "local" aggregates, i.e. indices in ilaggr(:) ! are those corresponding to "local" aggregates, i.e. indices in ilaggr(:)
! !
call am2%mv_to(tmpcoo) call op_restr%mv_to(tmpcoo)
nzl = tmpcoo%get_nzeros() nzl = tmpcoo%get_nzeros()
i=0 i=0
@ -543,21 +537,21 @@ subroutine mld_daggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info)
end if end if
end do end do
call tmpcoo%set_nzeros(i) call tmpcoo%set_nzeros(i)
call am2%mv_from(tmpcoo) call op_restr%mv_from(tmpcoo)
call am2%cscnv(info,type='csr') call op_restr%cscnv(info,type='csr')
if (debug_level >= psb_debug_outer_) & if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),& & write(debug_unit,*) me,' ',trim(name),&
& 'starting sphalo/ rwxtd' & 'starting sphalo/ rwxtd'
call psb_symbmm(a,am1,am3,info) call psb_symbmm(a,op_prol,am3,info)
if(info /= psb_success_) then if(info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,& call psb_errpush(psb_err_from_subroutine_,name,&
& a_err='symbmm 2') & a_err='symbmm 2')
goto 9999 goto 9999
end if end if
call psb_numbmm(a,am1,am3) call psb_numbmm(a,op_prol,am3)
if (debug_level >= psb_debug_outer_) & if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),& & write(debug_unit,*) me,' ',trim(name),&
& 'Done NUMBMM 2' & 'Done NUMBMM 2'
@ -576,156 +570,18 @@ subroutine mld_daggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info)
& write(debug_unit,*) me,' ',trim(name),& & write(debug_unit,*) me,' ',trim(name),&
& 'Done sphalo/ rwxtd' & 'Done sphalo/ rwxtd'
call psb_symbmm(am2,am3,b,info) call psb_symbmm(op_restr,am3,ac,info)
if (info == psb_success_) call psb_numbmm(am2,am3,b) if (info == psb_success_) call psb_numbmm(op_restr,am3,ac)
if (info == psb_success_) call am3%free() if (info == psb_success_) call am3%free()
call b%mv_to(bcoo) if (info == psb_success_) call ac%cscnv(info,type='coo',dupl=psb_dupl_add_)
if (info /= psb_success_) then if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,& call psb_errpush(psb_err_internal_error_,name,&
&a_err='Build b = am2 x am3') &a_err='Build ac = op_restr x am3')
goto 9999 goto 9999
end if end if
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'Done mv_to_coo'
select case(p%parms%coarse_mat)
case(mld_distr_mat_)
nzl = bcoo%get_nzeros()
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& ' B matrix nzl: ',nzl
if (info == psb_success_) call psb_cdall(ictxt,p%desc_ac,info,nl=nlaggr(me+1))
if (info == psb_success_) call psb_cdins(nzl,bcoo%ia,bcoo%ja,p%desc_ac,info)
if (info == psb_success_) call psb_cdasb(p%desc_ac,info)
if (info == psb_success_) call psb_glob_to_loc(bcoo%ia(1:nzl),p%desc_ac,info,iact='I')
if (info == psb_success_) call psb_glob_to_loc(bcoo%ja(1:nzl),p%desc_ac,info,iact='I')
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Creating p%desc_ac and converting ac')
goto 9999
end if
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& ' Assembld aux descr. distr.'
call bcoo%set_nrows(p%desc_ac%get_local_rows())
call bcoo%set_ncols(p%desc_ac%get_local_cols())
call bcoo%fix(info)
call p%ac%mv_from(bcoo)
call p%ac%set_asb()
call p%ac%cscnv(info,type='csr')
if (np>1) then
call am1%mv_to(acsr)
nzl = acsr%get_nzeros()
call psb_glob_to_loc(acsr%ja(1:nzl),p%desc_ac,info,'I')
if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_glob_to_loc')
goto 9999
end if
call am1%mv_from(acsr)
endif
call am1%set_ncols(p%desc_ac%get_local_cols())
if (np>1) then
call am2%mv_to(tmpcoo)
nzl = tmpcoo%get_nzeros()
if (info == psb_success_) call psb_glob_to_loc(tmpcoo%ia(1:nzl),p%desc_ac,info,'I')
if(info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,a_err='Converting am2 to local')
goto 9999
end if
call am2%mv_from(tmpcoo)
call am2%cscnv(info,type='csr')
end if
call am2%set_nrows(p%desc_ac%get_local_cols())
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'Done ac '
case(mld_repl_mat_)
!
!
call psb_cdall(ictxt,p%desc_ac,info,mg=ntaggr,repl=.true.)
nzbr(:) = 0
nzbr(me+1) = bcoo%get_nzeros()
call psb_sum(ictxt,nzbr(1:np))
nzac = sum(nzbr)
if (info == psb_success_) call tmpcoo%allocate(ntaggr,ntaggr,nzac)
if (info /= psb_success_) goto 9999
do ip=1,np
idisp(ip) = sum(nzbr(1:ip-1))
enddo
ndx = nzbr(me+1)
call mpi_allgatherv(bcoo%val,ndx,mpi_double_precision,tmpcoo%val,nzbr,idisp,&
& mpi_double_precision,icomm,info)
if (info == psb_success_)&
& call mpi_allgatherv(bcoo%ia,ndx,psb_mpi_ipk_integer,tmpcoo%ia,nzbr,idisp,&
& psb_mpi_ipk_integer,icomm,info)
if (info == psb_success_)&
& call mpi_allgatherv(bcoo%ja,ndx,psb_mpi_ipk_integer,tmpcoo%ja,nzbr,idisp,&
& psb_mpi_ipk_integer,icomm,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err=' from mpi_allgatherv')
goto 9999
end if
call bcoo%free()
call tmpcoo%fix(info)
call p%ac%mv_from(tmpcoo)
call p%ac%cscnv(info,type='csr')
if(info /= psb_success_) goto 9999
deallocate(nzbr,idisp,stat=info)
if (info /= psb_success_) then
info = psb_err_alloc_dealloc_
call psb_errpush(info,name)
goto 9999
end if
case default
info = psb_err_internal_error_
call psb_errpush(info,name,a_err='invalid mld_coarse_mat_')
goto 9999
end select
call p%ac%cscnv(info,type='csr')
if(info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='spcnv')
goto 9999
end if
!
! Copy the prolongation/restriction matrices into the descriptor map.
! am2 => R i.e. restriction operator
! am1 => P i.e. prolongation operator
!
p%map = psb_linmap(psb_map_aggr_,desc_a,&
& p%desc_ac,am2,am1,ilaggr,nlaggr)
if (info == psb_success_) call am1%free()
if (info == psb_success_) call am2%free()
if(info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='sp_Free')
goto 9999
end if
if (debug_level >= psb_debug_outer_) & if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),& & write(debug_unit,*) me,' ',trim(name),&

163
mlprec/impl/mld_daggrmat_nosmth_asb.F90 → mlprec/impl/mld_daggrmat_nosmth_asb.f90
Unescape Escape View File

@ -81,35 +81,29 @@
! info - integer, output. ! info - integer, output.
! Error code. ! Error code.
! !
subroutine mld_daggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,p,info) subroutine mld_daggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_restr,info)
use psb_base_mod use psb_base_mod
use mld_d_inner_mod, mld_protect_name => mld_daggrmat_nosmth_asb use mld_d_inner_mod, mld_protect_name => mld_daggrmat_nosmth_asb
#ifdef MPI_MOD
use mpi
#endif
implicit none implicit none
#ifdef MPI_H
include 'mpif.h'
#endif
! Arguments ! Arguments
type(psb_dspmat_type), intent(in) :: a type(psb_dspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_a type(psb_desc_type), intent(in) :: desc_a
integer, intent(inout) :: ilaggr(:), nlaggr(:) integer, intent(inout) :: ilaggr(:), nlaggr(:)
type(mld_d_onelev_type), intent(inout), target :: p type(mld_dml_parms), intent(inout) :: parms
type(psb_dspmat_type), intent(out) :: ac,op_prol,op_restr
integer, intent(out) :: info integer, intent(out) :: info
! Local variables ! Local variables
integer :: ictxt,np,me, err_act integer :: ictxt,np,me, err_act
integer(psb_mpik_) :: icomm, ndx, minfo integer(psb_mpik_) :: icomm, ndx, minfo
character(len=20) :: name character(len=20) :: name
type(psb_dspmat_type) :: b
integer(psb_mpik_), allocatable :: nzbr(:), idisp(:)
integer(psb_ipk_) :: ierr(5) integer(psb_ipk_) :: ierr(5)
type(psb_dspmat_type) :: am1,am2 type(psb_d_coo_sparse_mat) :: ac_coo, acoo
type(psb_d_coo_sparse_mat) :: acoo1, acoo2, bcoo, ac_coo type(psb_d_csr_sparse_mat) :: acsr1, acsr2
integer :: nrow, nglob, ncol, ntaggr, nzac, ip, & integer :: debug_level, debug_unit
integer :: nrow, nglob, ncol, ntaggr, nzl, ip, &
& naggr, nzt, naggrm1, i & naggr, nzt, naggrm1, i
name='mld_aggrmat_nosmth_asb' name='mld_aggrmat_nosmth_asb'
@ -128,141 +122,48 @@ subroutine mld_daggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,p,info)
naggr = nlaggr(me+1) naggr = nlaggr(me+1)
ntaggr = sum(nlaggr) ntaggr = sum(nlaggr)
allocate(nzbr(np), idisp(np),stat=info)
if (info /= psb_success_) then
info=psb_err_alloc_request_; ierr(1)=2*np;
call psb_errpush(info,name,i_err=ierr,a_err='integer')
goto 9999
end if
naggrm1=sum(nlaggr(1:me)) naggrm1=sum(nlaggr(1:me))
if (p%parms%coarse_mat == mld_repl_mat_) then do i=1, nrow
do i=1, nrow ilaggr(i) = ilaggr(i) + naggrm1
ilaggr(i) = ilaggr(i) + naggrm1 end do
end do call psb_halo(ilaggr,desc_a,info)
call psb_halo(ilaggr,desc_a,info)
end if
if(info /= psb_success_) then if(info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_halo') call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_halo')
goto 9999 goto 9999
end if end if
if (p%parms%coarse_mat == mld_repl_mat_) then call acoo%allocate(ncol,ntaggr,ncol)
call acoo1%allocate(ncol,ntaggr,ncol)
else
call acoo1%allocate(ncol,naggr,ncol)
end if
do i=1,nrow do i=1,nrow
acoo1%val(i) = done acoo%val(i) = done
acoo1%ia(i) = i acoo%ia(i) = i
acoo1%ja(i) = ilaggr(i) acoo%ja(i) = ilaggr(i)
end do end do
call acoo1%set_dupl(psb_dupl_add_) call acoo%set_dupl(psb_dupl_add_)
call acoo1%set_nzeros(nrow) call acoo%set_nzeros(nrow)
call acoo1%set_asb() call acoo%set_asb()
call acoo1%fix(info) call acoo%fix(info)
call acoo1%transp(acoo2)
call a%csclip(bcoo,info,jmax=nrow) call op_prol%mv_from(acoo)
call op_prol%cscnv(info,type='csr',dupl=psb_dupl_add_)
if (info == psb_success_) call op_prol%transp(op_restr)
call a%csclip(ac_coo,info,jmax=nrow)
nzt = bcoo%get_nzeros() nzt = ac_coo%get_nzeros()
do i=1, nzt do i=1, nzt
bcoo%ia(i) = ilaggr(bcoo%ia(i)) ac_coo%ia(i) = ilaggr(ac_coo%ia(i))
bcoo%ja(i) = ilaggr(bcoo%ja(i)) ac_coo%ja(i) = ilaggr(ac_coo%ja(i))
enddo enddo
call bcoo%set_nrows(naggr) call ac_coo%set_nrows(naggr)
call bcoo%set_ncols(naggr) call ac_coo%set_ncols(naggr)
call bcoo%set_dupl(psb_dupl_add_) call ac_coo%set_dupl(psb_dupl_add_)
call bcoo%fix(info) call ac_coo%fix(info)
call ac%mv_from(ac_coo)
if (p%parms%coarse_mat == mld_repl_mat_) then
call psb_cdall(ictxt,p%desc_ac,info,mg=ntaggr,repl=.true.)
if (info == psb_success_) call psb_cdasb(p%desc_ac,info)
if(info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_cdall')
goto 9999
end if
nzbr(:) = 0
nzbr(me+1) = nzt
call psb_sum(ictxt,nzbr(1:np))
nzac = sum(nzbr)
call ac_coo%allocate(ntaggr,ntaggr,nzac)
do ip=1,np
idisp(ip) = sum(nzbr(1:ip-1))
enddo
ndx = nzbr(me+1)
call mpi_allgatherv(bcoo%val,ndx,mpi_double_precision,ac_coo%val,nzbr,idisp,&
& mpi_double_precision,icomm,minfo)
call mpi_allgatherv(bcoo%ia,ndx,psb_mpi_ipk_integer,ac_coo%ia,nzbr,idisp,&
& psb_mpi_ipk_integer,icomm,minfo)
call mpi_allgatherv(bcoo%ja,ndx,psb_mpi_ipk_integer,ac_coo%ja,nzbr,idisp,&
& psb_mpi_ipk_integer,icomm,minfo)
if(info /= psb_success_) then
info=-1
call psb_errpush(info,name)
goto 9999
end if
call ac_coo%set_nzeros(nzac)
call ac_coo%set_dupl(psb_dupl_add_)
call ac_coo%fix(info)
call p%ac%mv_from(ac_coo)
else if (p%parms%coarse_mat == mld_distr_mat_) then
call psb_cdall(ictxt,p%desc_ac,info,nl=naggr)
if (info == psb_success_) call psb_cdasb(p%desc_ac,info)
call p%ac%mv_from(bcoo)
if(info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,a_err='Build ac, desc_ac')
goto 9999
end if
else
info = psb_err_internal_error_
call psb_errpush(psb_err_internal_error_,name,a_err='invalid mld_coarse_mat_')
goto 9999
end if
call bcoo%free()
deallocate(nzbr,idisp)
call p%ac%cscnv(info,type='csr',dupl=psb_dupl_add_)
if(info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='cscnv')
goto 9999
end if
call am1%mv_from(acoo1)
call am1%cscnv(info,type='csr',dupl=psb_dupl_add_)
if (info == psb_success_) call am2%mv_from(acoo2)
if (info == psb_success_) call am2%cscnv(info,type='csr',dupl=psb_dupl_add_)
!
! Copy the prolongation/restriction matrices into the descriptor map.
! am2 => PR^T i.e. restriction operator
! am1 => PR i.e. prolongation operator
!
if (info == psb_success_) &
& p%map = psb_linmap(psb_map_aggr_,desc_a,&
& p%desc_ac,am2,am1,ilaggr,nlaggr)
if (info == psb_success_) call am1%free()
if (info == psb_success_) call am2%free()
if(info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='linmap build')
goto 9999
end if
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)

421
mlprec/impl/mld_daggrmat_smth_asb.F90 → mlprec/impl/mld_daggrmat_smth_asb.f90
Unescape Escape View File

@ -61,11 +61,6 @@
! according to the value of p%parms%aggr_omega_alg, specified by the user ! according to the value of p%parms%aggr_omega_alg, specified by the user
! through mld_dprecinit and mld_zprecset. ! through mld_dprecinit and mld_zprecset.
! !
! This routine can also build A_C according to a "bizarre" aggregation algorithm,
! using a "naive" prolongator proposed by the authors of MLD2P4. However, this
! prolongator still requires a deep analysis and testing and its use is not
! recommended.
!
! The coarse-level matrix A_C is distributed among the parallel processes or ! The coarse-level matrix A_C is distributed among the parallel processes or
! replicated on each of them, according to the value of p%parms%coarse_mat, ! replicated on each of them, according to the value of p%parms%coarse_mat,
! specified by the user through mld_dprecinit and mld_zprecset. ! specified by the user through mld_dprecinit and mld_zprecset.
@ -98,38 +93,31 @@
! info - integer, output. ! info - integer, output.
! Error code. ! Error code.
! !
subroutine mld_daggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info) subroutine mld_daggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_restr,info)
use psb_base_mod use psb_base_mod
use mld_d_inner_mod, mld_protect_name => mld_daggrmat_smth_asb use mld_d_inner_mod, mld_protect_name => mld_daggrmat_smth_asb
#ifdef MPI_MOD
use mpi
#endif
implicit none implicit none
#ifdef MPI_H
include 'mpif.h'
#endif
! Arguments ! Arguments
type(psb_dspmat_type), intent(in) :: a type(psb_dspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_a type(psb_desc_type), intent(in) :: desc_a
integer, intent(inout) :: ilaggr(:), nlaggr(:) integer, intent(inout) :: ilaggr(:), nlaggr(:)
type(mld_d_onelev_type), intent(inout), target :: p type(mld_dml_parms), intent(inout) :: parms
type(psb_dspmat_type), intent(out) :: ac,op_prol,op_restr
integer, intent(out) :: info integer, intent(out) :: info
! Local variables ! Local variables
type(psb_dspmat_type) :: b integer :: nrow, nglob, ncol, ntaggr, ip, ndx,&
integer, allocatable :: nzbr(:), idisp(:)
integer :: nrow, nglob, ncol, ntaggr, nzac, ip, ndx,&
& naggr, nzl,naggrm1,naggrp1, i, j, k, jd, icolF, nrw & naggr, nzl,naggrm1,naggrp1, i, j, k, jd, icolF, nrw
integer ::ictxt, np, me, err_act integer ::ictxt, np, me, err_act
character(len=20) :: name character(len=20) :: name
type(psb_dspmat_type) :: am1,am2, am3, am4 type(psb_dspmat_type) :: am3, am4
type(psb_d_coo_sparse_mat) :: acoo, acoof, bcoo type(psb_d_coo_sparse_mat) :: tmpcoo
type(psb_d_csr_sparse_mat) :: acsr1, acsr2, acsr3, acsrf, ptilde type(psb_d_csr_sparse_mat) :: acsr1, acsr2, acsr3, acsrf, ptilde
real(psb_dpk_), allocatable :: adiag(:) real(psb_dpk_), allocatable :: adiag(:)
integer(psb_ipk_) :: ierr(5) integer(psb_ipk_) :: ierr(5)
logical :: ml_global_nmb, filter_mat logical :: filter_mat
integer :: debug_level, debug_unit integer :: debug_level, debug_unit
integer, parameter :: ncmax=16 integer, parameter :: ncmax=16
real(psb_dpk_) :: anorm, omega, tmp, dg, theta real(psb_dpk_) :: anorm, omega, tmp, dg, theta
@ -150,34 +138,21 @@ subroutine mld_daggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info)
nrow = desc_a%get_local_rows() nrow = desc_a%get_local_rows()
ncol = desc_a%get_local_cols() ncol = desc_a%get_local_cols()
theta = p%parms%aggr_thresh theta = parms%aggr_thresh
naggr = nlaggr(me+1) naggr = nlaggr(me+1)
ntaggr = sum(nlaggr) ntaggr = sum(nlaggr)
allocate(nzbr(np), idisp(np),stat=info)
if (info /= psb_success_) then
info=psb_err_alloc_request_; ierr(1)=2*np;
call psb_errpush(info,name,i_err=ierr,a_err='integer')
goto 9999
end if
naggrm1 = sum(nlaggr(1:me)) naggrm1 = sum(nlaggr(1:me))
naggrp1 = sum(nlaggr(1:me+1)) naggrp1 = sum(nlaggr(1:me+1))
ml_global_nmb = ( (p%parms%aggr_kind == mld_smooth_prol_).or.& filter_mat = (parms%aggr_filter == mld_filter_mat_)
& ( (p%parms%aggr_kind == mld_biz_prol_).and.&
& (p%parms%coarse_mat == mld_repl_mat_)) )
filter_mat = (p%parms%aggr_filter == mld_filter_mat_)
if (ml_global_nmb) then ilaggr(1:nrow) = ilaggr(1:nrow) + naggrm1
ilaggr(1:nrow) = ilaggr(1:nrow) + naggrm1 call psb_halo(ilaggr,desc_a,info)
call psb_halo(ilaggr,desc_a,info)
if (info /= psb_success_) then if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_halo') call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_halo')
goto 9999 goto 9999
end if
end if end if
! naggr: number of local aggregates ! naggr: number of local aggregates
@ -202,32 +177,22 @@ subroutine mld_daggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info)
end if end if
! 1. Allocate Ptilde in sparse matrix form ! 1. Allocate Ptilde in sparse matrix form
if (ml_global_nmb) then call tmpcoo%allocate(ncol,ntaggr,ncol)
call acoo%allocate(ncol,ntaggr,ncol) do i=1,ncol
do i=1,ncol tmpcoo%val(i) = done
acoo%val(i) = done tmpcoo%ia(i) = i
acoo%ia(i) = i tmpcoo%ja(i) = ilaggr(i)
acoo%ja(i) = ilaggr(i) end do
end do call tmpcoo%set_nzeros(ncol)
call acoo%set_nzeros(ncol) call tmpcoo%set_dupl(psb_dupl_add_)
else
call acoo%allocate(ncol,naggr,ncol) call ptilde%mv_from_coo(tmpcoo,info)
do i=1,nrow
acoo%val(i) = done
acoo%ia(i) = i
acoo%ja(i) = ilaggr(i)
end do
call acoo%set_nzeros(nrow)
endif
call acoo%set_dupl(psb_dupl_add_)
call ptilde%mv_from_coo(acoo,info)
if (info == psb_success_) call a%cscnv(acsr3,info,dupl=psb_dupl_add_) if (info == psb_success_) call a%cscnv(acsr3,info,dupl=psb_dupl_add_)
if (debug_level >= psb_debug_outer_) & if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),& & write(debug_unit,*) me,' ',trim(name),&
& ' Initial copies sone.' & ' Initial copies sone.'
if (filter_mat) then if (filter_mat) then
! !
! Build the filtered matrix Af from A ! Build the filtered matrix Af from A
@ -252,19 +217,19 @@ subroutine mld_daggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info)
end if end if
enddo enddo
! Take out zeroed terms ! Take out zeroed terms
call acsrf%mv_to_coo(acoof,info) call acsrf%mv_to_coo(tmpcoo,info)
k = 0 k = 0
do j=1,acoof%get_nzeros() do j=1,tmpcoo%get_nzeros()
if ((acoof%val(j) /= dzero) .or. (acoof%ia(j) == acoof%ja(j))) then if ((tmpcoo%val(j) /= dzero) .or. (tmpcoo%ia(j) == tmpcoo%ja(j))) then
k = k + 1 k = k + 1
acoof%val(k) = acoof%val(j) tmpcoo%val(k) = tmpcoo%val(j)
acoof%ia(k) = acoof%ia(j) tmpcoo%ia(k) = tmpcoo%ia(j)
acoof%ja(k) = acoof%ja(j) tmpcoo%ja(k) = tmpcoo%ja(j)
end if end if
end do end do
call acoof%set_nzeros(k) call tmpcoo%set_nzeros(k)
call acoof%set_dupl(psb_dupl_add_) call tmpcoo%set_dupl(psb_dupl_add_)
call acsrf%mv_from_coo(acoof,info) call acsrf%mv_from_coo(tmpcoo,info)
end if end if
@ -281,41 +246,13 @@ subroutine mld_daggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info)
if (info /= psb_success_) goto 9999 if (info /= psb_success_) goto 9999
if (p%parms%aggr_omega_alg == mld_eig_est_) then if (parms%aggr_omega_alg == mld_eig_est_) then
if (p%parms%aggr_eig == mld_max_norm_) then if (parms%aggr_eig == mld_max_norm_) then
if (p%parms%aggr_kind == mld_biz_prol_) then anorm = acsr3%csnmi()
!
! This only works with CSR
!
anorm = dzero
dg = done
nrw = acsr3%get_nrows()
do i=1, nrw
tmp = szero
do j=acsr3%irp(i),acsr3%irp(i+1)-1
if (acsr3%ja(j) <= nrw) then
tmp = tmp + abs(acsr3%val(j))
endif
if (acsr3%ja(j) == i ) then
dg = abs(acsr3%val(j))
end if
end do
anorm = max(anorm,tmp/dg)
enddo
call psb_amx(ictxt,anorm)
else
anorm = acsr3%csnmi()
endif
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,a_err='Invalid AM3 storage format')
goto 9999
end if
omega = 4.d0/(3.d0*anorm) omega = 4.d0/(3.d0*anorm)
p%parms%aggr_omega_val = omega parms%aggr_omega_val = omega
else else
info = psb_err_internal_error_ info = psb_err_internal_error_
@ -323,11 +260,11 @@ subroutine mld_daggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info)
goto 9999 goto 9999
end if end if
else if (p%parms%aggr_omega_alg == mld_user_choice_) then else if (parms%aggr_omega_alg == mld_user_choice_) then
omega = p%parms%aggr_omega_val omega = parms%aggr_omega_val
else if (p%parms%aggr_omega_alg /= mld_user_choice_) then else if (parms%aggr_omega_alg /= mld_user_choice_) then
info = psb_err_internal_error_ info = psb_err_internal_error_
call psb_errpush(info,name,a_err='invalid mld_aggr_omega_alg_') call psb_errpush(info,name,a_err='invalid mld_aggr_omega_alg_')
goto 9999 goto 9999
@ -368,7 +305,7 @@ subroutine mld_daggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info)
if (debug_level >= psb_debug_outer_) & if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),& & write(debug_unit,*) me,' ',trim(name),&
& 'Done NUMBMM 1' & 'Done NUMBMM 1'
else else
! !
! Build the smoothed prolongator using the original matrix ! Build the smoothed prolongator using the original matrix
@ -409,76 +346,64 @@ subroutine mld_daggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info)
call ptilde%free() call ptilde%free()
call acsr1%set_dupl(psb_dupl_add_) call acsr1%set_dupl(psb_dupl_add_)
call am1%mv_from(acsr1) call op_prol%mv_from(acsr1)
if (ml_global_nmb) then !
! ! Now we have to gather the halo of op_prol, and add it to itself
! Now we have to gather the halo of am1, and add it to itself ! to multiply it by A,
! to multiply it by A, !
! call psb_sphalo(op_prol,desc_a,am4,info,&
call psb_sphalo(am1,desc_a,am4,info,& & colcnv=.false.,rowscale=.true.)
& colcnv=.false.,rowscale=.true.) if (info == psb_success_) call psb_rwextd(ncol,op_prol,info,b=am4)
if (info == psb_success_) call psb_rwextd(ncol,am1,info,b=am4) if (info == psb_success_) call am4%free()
if (info == psb_success_) call am4%free()
else
call psb_rwextd(ncol,am1,info)
endif
if(info /= psb_success_) then if(info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,a_err='Halo of am1') call psb_errpush(psb_err_internal_error_,name,a_err='Halo of op_prol')
goto 9999 goto 9999
end if end if
call psb_symbmm(a,am1,am3,info) call psb_symbmm(a,op_prol,am3,info)
if(info /= psb_success_) then if(info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='symbmm 2') call psb_errpush(psb_err_from_subroutine_,name,a_err='symbmm 2')
goto 9999 goto 9999
end if end if
call psb_numbmm(a,am1,am3) call psb_numbmm(a,op_prol,am3)
if (debug_level >= psb_debug_outer_) & if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),& & write(debug_unit,*) me,' ',trim(name),&
& 'Done NUMBMM 2',p%parms%aggr_kind, mld_smooth_prol_ & 'Done NUMBMM 2',parms%aggr_kind, mld_smooth_prol_
if (p%parms%aggr_kind == mld_smooth_prol_) then call op_prol%transp(op_restr)
call am1%transp(am2) call op_restr%mv_to(tmpcoo)
call am2%mv_to(acoo) nzl = tmpcoo%get_nzeros()
nzl = acoo%get_nzeros() i=0
i=0 !
! ! Now we have to fix this. The only rows of B that are correct
! Now we have to fix this. The only rows of B that are correct ! are those corresponding to "local" aggregates, i.e. indices in ilaggr(:)
! are those corresponding to "local" aggregates, i.e. indices in ilaggr(:) !
! do k=1, nzl
do k=1, nzl if ((naggrm1 < tmpcoo%ia(k)) .and.(tmpcoo%ia(k) <= naggrp1)) then
if ((naggrm1 < acoo%ia(k)) .and.(acoo%ia(k) <= naggrp1)) then i = i+1
i = i+1 tmpcoo%val(i) = tmpcoo%val(k)
acoo%val(i) = acoo%val(k) tmpcoo%ia(i) = tmpcoo%ia(k)
acoo%ia(i) = acoo%ia(k) tmpcoo%ja(i) = tmpcoo%ja(k)
acoo%ja(i) = acoo%ja(k)
end if
end do
call acoo%set_nzeros(i)
call acoo%trim()
call am2%mv_from(acoo)
call am2%cscnv(info,type='csr',dupl=psb_dupl_add_)
if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='spcnv am2')
goto 9999
end if end if
else end do
call am1%transp(am2) call tmpcoo%set_nzeros(i)
endif call tmpcoo%trim()
call op_restr%mv_from(tmpcoo)
call op_restr%cscnv(info,type='csr',dupl=psb_dupl_add_)
if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='spcnv op_restr')
goto 9999
end if
if (debug_level >= psb_debug_outer_) & if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),& & write(debug_unit,*) me,' ',trim(name),&
& 'starting sphalo/ rwxtd' & 'starting sphalo/ rwxtd'
if (p%parms%aggr_kind == mld_smooth_prol_) then ! op_restr = ((i-wDA)Ptilde)^T
! am2 = ((i-wDA)Ptilde)^T call psb_sphalo(am3,desc_a,am4,info,&
call psb_sphalo(am3,desc_a,am4,info,& & colcnv=.false.,rowscale=.true.)
& colcnv=.false.,rowscale=.true.) if (info == psb_success_) call psb_rwextd(ncol,am3,info,b=am4)
if (info == psb_success_) call psb_rwextd(ncol,am3,info,b=am4) if (info == psb_success_) call am4%free()
if (info == psb_success_) call am4%free()
else if (p%parms%aggr_kind == mld_biz_prol_) then
call psb_rwextd(ncol,am3,info)
endif
if(info /= psb_success_) then if(info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,a_err='Extend am3') call psb_errpush(psb_err_internal_error_,name,a_err='Extend am3')
goto 9999 goto 9999
@ -488,180 +413,12 @@ subroutine mld_daggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info)
if (debug_level >= psb_debug_outer_) & if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),& & write(debug_unit,*) me,' ',trim(name),&
& 'starting symbmm 3' & 'starting symbmm 3'
call psb_symbmm(am2,am3,b,info) call psb_symbmm(op_restr,am3,ac,info)
if (info == psb_success_) call psb_numbmm(am2,am3,b) if (info == psb_success_) call psb_numbmm(op_restr,am3,ac)
if (info == psb_success_) call am3%free() if (info == psb_success_) call am3%free()
if (info == psb_success_) call b%cscnv(info,type='coo',dupl=psb_dupl_add_) if (info == psb_success_) call ac%cscnv(info,type='coo',dupl=psb_dupl_add_)
if (info /= psb_success_) then if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,a_err='Build b = am2 x am3') call psb_errpush(psb_err_internal_error_,name,a_err='Build ac = op_restr x am3')
goto 9999
end if
select case(p%parms%aggr_kind)
case(mld_smooth_prol_)
select case(p%parms%coarse_mat)
case(mld_distr_mat_)
nzac = b%get_nzeros()
nzl = nzac
call b%mv_to(bcoo)
if (info == psb_success_) call psb_cdall(ictxt,p%desc_ac,info,nl=nlaggr(me+1))
if (info == psb_success_) call psb_cdins(nzl,bcoo%ia,bcoo%ja,p%desc_ac,info)
if (info == psb_success_) call psb_cdasb(p%desc_ac,info)
if (info == psb_success_) call psb_glob_to_loc(bcoo%ia(1:nzl),p%desc_ac,info,iact='I')
if (info == psb_success_) call psb_glob_to_loc(bcoo%ja(1:nzl),p%desc_ac,info,iact='I')
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Creating p%desc_ac and converting ac')
goto 9999
end if
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'Assembld aux descr. distr.'
call p%ac%mv_from(bcoo)
call p%ac%set_nrows(p%desc_ac%get_local_rows())
call p%ac%set_ncols(p%desc_ac%get_local_cols())
call p%ac%set_asb()
if (info == psb_success_) deallocate(nzbr,idisp,stat=info)
if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_sp_free')
goto 9999
end if
if (np>1) then
call am1%mv_to(acsr1)
nzl = acsr1%get_nzeros()
call psb_glob_to_loc(acsr1%ja(1:nzl),p%desc_ac,info,'I')
if(info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_glob_to_loc')
goto 9999
end if
call am1%mv_from(acsr1)
endif
call am1%set_ncols(p%desc_ac%get_local_cols())
if (np>1) then
call am2%cscnv(info,type='coo',dupl=psb_dupl_add_)
call am2%mv_to(acoo)
nzl = acoo%get_nzeros()
if (info == psb_success_) call psb_glob_to_loc(acoo%ia(1:nzl),p%desc_ac,info,'I')
call acoo%set_dupl(psb_dupl_add_)
if (info == psb_success_) call am2%mv_from(acoo)
if (info == psb_success_) call am2%cscnv(info,type='csr')
if(info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,a_err='Converting am2 to local')
goto 9999
end if
end if
call am2%set_nrows(p%desc_ac%get_local_cols())
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'Done ac '
case(mld_repl_mat_)
!
!
call psb_cdall(ictxt,p%desc_ac,info,mg=ntaggr,repl=.true.)
if (info == psb_success_) call psb_cdasb(p%desc_ac,info)
if (info == psb_success_) &
& call psb_gather(p%ac,b,p%desc_ac,info,dupl=psb_dupl_add_,keeploc=.false.)
if (info /= psb_success_) goto 9999
deallocate(nzbr,idisp,stat=info)
if (info /= psb_success_) then
info = psb_err_alloc_dealloc_
call psb_errpush(info,name)
goto 9999
end if
case default
info = psb_err_internal_error_
call psb_errpush(info,name,a_err='invalid mld_coarse_mat_')
goto 9999
end select
case(mld_biz_prol_)
select case(p%parms%coarse_mat)
case(mld_distr_mat_)
call psb_move_alloc(b,p%ac,info)
if (info == psb_success_) call psb_cdall(ictxt,p%desc_ac,info,nl=naggr)
if (info == psb_success_) call psb_cdasb(p%desc_ac,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='Build desc_ac, ac')
goto 9999
end if
case(mld_repl_mat_)
!
!
call psb_cdall(ictxt,p%desc_ac,info,mg=ntaggr,repl=.true.)
if (info == psb_success_) call psb_cdasb(p%desc_ac,info)
if(info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_cdall')
goto 9999
end if
call psb_gather(p%ac,b,p%desc_ac,info,dupl=psb_dupl_add_,keeploc=.false.)
if(info /= psb_success_) goto 9999
deallocate(nzbr,idisp,stat=info)
if (info /= psb_success_) then
info = psb_err_alloc_dealloc_
call psb_errpush(info,name)
goto 9999
end if
case default
info = psb_err_internal_error_
call psb_errpush(info,name,a_err='invalid mld_coarse_mat_')
goto 9999
end select
deallocate(nzbr,idisp,stat=info)
if (info /= psb_success_) then
info = psb_err_alloc_dealloc_
call psb_errpush(info,name)
goto 9999
end if
case default
info = psb_err_internal_error_
call psb_errpush(info,name,a_err='invalid mld_smooth_prol_')
goto 9999
end select
call p%ac%cscnv(info,type='csr',dupl=psb_dupl_add_)
if(info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='spcnv')
goto 9999
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 = psb_linmap(psb_map_aggr_,desc_a,&
& p%desc_ac,am2,am1,ilaggr,nlaggr)
if (info == psb_success_) call am1%free()
if (info == psb_success_) call am2%free()
if(info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='sp_Free')
goto 9999 goto 9999
end if end if

267
mlprec/impl/mld_dmlprec_bld.f90
Unescape Escape View File

@ -93,11 +93,13 @@ subroutine mld_dmlprec_bld(a,desc_a,p,info,amold,vmold)
! Local Variables ! Local Variables
type(mld_dprec_type) :: t_prec type(mld_dprec_type) :: t_prec
Integer :: err,i,k,ictxt, me,np, err_act, iszv, newsz Integer :: err,i,k,ictxt, me,np, err_act, iszv, newsz, casize
integer :: ipv(mld_ifpsz_), val integer :: ipv(mld_ifpsz_), val
integer :: int_err(5) integer :: int_err(5)
character :: upd_ character :: upd_
type(mld_dml_parms) :: prm class(mld_d_base_smoother_type), allocatable :: coarse_sm, base_sm, med_sm
type(mld_dml_parms) :: baseparms, medparms, coarseparms
type(mld_d_onelev_node), pointer :: head, tail, newnode, current
integer :: debug_level, debug_unit integer :: debug_level, debug_unit
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
@ -145,12 +147,22 @@ subroutine mld_dmlprec_bld(a,desc_a,p,info,amold,vmold)
! Check to ensure all procs have the same ! Check to ensure all procs have the same
! !
newsz = -1 newsz = -1
casize = p%coarse_aggr_size
iszv = size(p%precv) iszv = size(p%precv)
call psb_bcast(ictxt,iszv) call psb_bcast(ictxt,iszv)
if (iszv /= size(p%precv)) then call psb_bcast(ictxt,casize)
info=psb_err_internal_error_ if (casize > 0) then
call psb_errpush(info,name,a_err='Inconsistent size of precv') if (casize /= p%coarse_aggr_size) then
goto 9999 info=psb_err_internal_error_
call psb_errpush(info,name,a_err='Inconsistent coarse_aggr_size')
goto 9999
end if
else
if (iszv /= size(p%precv)) then
info=psb_err_internal_error_
call psb_errpush(info,name,a_err='Inconsistent size of precv')
goto 9999
end if
end if end if
if (iszv <= 1) then if (iszv <= 1) then
@ -162,7 +174,161 @@ subroutine mld_dmlprec_bld(a,desc_a,p,info,amold,vmold)
endif endif
if (iszv > 1) then
if (casize>0) then
!
! New strategy to build according to coarse size.
!
coarseparms = p%precv(iszv)%parms
baseparms = p%precv(1)%parms
medparms = p%precv(2)%parms
allocate(coarse_sm, source=p%precv(iszv)%sm,stat=info)
if (info == psb_success_) &
& allocate(med_sm, source=p%precv(2)%sm,stat=info)
if (info == psb_success_) &
& allocate(base_sm, source=p%precv(1)%sm,stat=info)
if (info /= psb_success_) then
write(0,*) 'Error in saving smoothers',info
call psb_errpush(psb_err_internal_error_,name,a_err='Base level precbuild.')
goto 9999
end if
!
! Replicated matrix should only ever happen at coarse level.
!
call mld_check_def(baseparms%coarse_mat,'Coarse matrix',&
& mld_distr_mat_,is_distr_ml_coarse_mat)
!
! Now build a doubly linked list
!
allocate(newnode,stat=info)
if (info /= psb_success_) then
info = psb_err_internal_error_
call psb_errpush(info,name,a_err='List start'); goto 9999
end if
head => newnode
tail => newnode
newnode%item%base_a => a
newnode%item%base_desc => desc_a
newnode%item%parms = baseparms
newsz = 1
current => head
list_build_loop: do
allocate(newnode,stat=info)
if (info /= psb_success_) then
info = psb_err_internal_error_
call psb_errpush(info,name,a_err='List start'); goto 9999
end if
current%next => newnode
newnode%prev => current
newsz = newsz + 1
newnode%item%parms = medparms
newnode%item%parms%aggr_thresh = current%item%parms%aggr_thresh/2
call mld_coarse_bld(current%item%base_a, current%item%base_desc, &
& newnode%item,info)
if (info /= psb_success_) then
info = psb_err_internal_error_
call psb_errpush(info,name,a_err='build next level'); goto 9999
end if
if (newsz>2) then
if (all(current%item%map%naggr == newnode%item%map%naggr)) then
!
! We are not gaining anything
!
newsz = newsz-1
current%next => null()
call newnode%item%free(info)
if (info == psb_success_) deallocate(newnode,stat=info)
if (info /= psb_success_) then
info = psb_err_internal_error_
call psb_errpush(info,name,a_err='Deallocate at list end'); goto 9999
end if
end if
end if
current => current%next
tail => current
if (sum(newnode%item%map%naggr) <= casize) then
!
! Target reached; but we may need to rebuild.
!
exit list_build_loop
end if
end do list_build_loop
!
! At this point, we are at the list tail,
! and it needs to be rebuilt in case the parms were
! different.
!
! But the threshold has to be fixed before rebuliding
coarseparms%aggr_thresh = current%item%parms%aggr_thresh
current%item%parms = coarseparms
call mld_coarse_bld(current%prev%item%base_a,&
& current%prev%item%base_desc, &
& current%item,info)
if (info /= psb_success_) then
info = psb_err_internal_error_
call psb_errpush(info,name,a_err='build next level'); goto 9999
end if
!
! Ok, now allocate the output vector and fix items.
!
do i=1,iszv
if (info == psb_success_) call p%precv(i)%free(info)
end do
if (info == psb_success_) deallocate(p%precv,stat=info)
if (info == psb_success_) allocate(p%precv(newsz),stat=info)
if (info /= psb_success_) then
info = psb_err_internal_error_
call psb_errpush(info,name,a_err='Reallocate precv'); goto 9999
end if
newnode => head
do i=1, newsz
current => newnode
if (info == psb_success_) &
& call mld_move_alloc(current%item,p%precv(i),info)
if (info == psb_success_) then
if (i ==1) then
allocate(p%precv(i)%sm,source=base_sm,stat=info)
else if (i < newsz) then
allocate(p%precv(i)%sm,source=med_sm,stat=info)
else
allocate(p%precv(i)%sm,source=coarse_sm,stat=info)
end if
end if
if (info /= psb_success_) then
info = psb_err_internal_error_
call psb_errpush(info,name,a_err='list cpy'); goto 9999
end if
if (i == 1) then
p%precv(i)%base_a => a
p%precv(i)%base_desc => desc_a
else
p%precv(i)%base_a => p%precv(i)%ac
p%precv(i)%base_desc => p%precv(i)%desc_ac
p%precv(i)%map%p_desc_X => p%precv(i-1)%base_desc
p%precv(i)%map%p_desc_Y => p%precv(i)%base_desc
end if
newnode => current%next
deallocate(current)
end do
call base_sm%free(info)
if (info == psb_success_) call med_sm%free(info)
if (info == psb_success_) call coarse_sm%free(info)
if (info == psb_success_) deallocate(coarse_sm,med_sm,base_sm,stat=info)
if (info /= psb_success_) then
info = psb_err_internal_error_
call psb_errpush(info,name,a_err='final cleanup'); goto 9999
end if
iszv = newsz
else
!
! Default, oldstyle
!
! !
! Build the matrix and the transfer operators corresponding ! Build the matrix and the transfer operators corresponding
@ -179,11 +345,6 @@ subroutine mld_dmlprec_bld(a,desc_a,p,info,amold,vmold)
p%precv(1)%base_a => a p%precv(1)%base_a => a
p%precv(1)%base_desc => desc_a p%precv(1)%base_desc => desc_a
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,a_err='Base level precbuild.')
goto 9999
end if
do i=2, iszv do i=2, iszv
! !
@ -201,11 +362,6 @@ subroutine mld_dmlprec_bld(a,desc_a,p,info,amold,vmold)
! !
call mld_check_def(p%precv(i)%parms%coarse_mat,'Coarse matrix',& call mld_check_def(p%precv(i)%parms%coarse_mat,'Coarse matrix',&
& mld_distr_mat_,is_distr_ml_coarse_mat) & mld_distr_mat_,is_distr_ml_coarse_mat)
else if (i == iszv) then
!!$ call check_coarse_lev(p%precv(i))
end if end if
if (debug_level >= psb_debug_outer_) & if (debug_level >= psb_debug_outer_) &
@ -277,9 +433,7 @@ subroutine mld_dmlprec_bld(a,desc_a,p,info,amold,vmold)
p%precv(i)%map%p_desc_Y => p%precv(i)%base_desc p%precv(i)%map%p_desc_Y => p%precv(i)%base_desc
end do end do
i = iszv i = iszv
call check_coarse_lev(p%precv(i))
if (info == psb_success_) call mld_coarse_bld(p%precv(i-1)%base_a,& if (info == psb_success_) call mld_coarse_bld(p%precv(i-1)%base_a,&
& p%precv(i-1)%base_desc, p%precv(i),info) & p%precv(i-1)%base_desc, p%precv(i),info)
if (info /= psb_success_) then if (info /= psb_success_) then
@ -289,6 +443,12 @@ subroutine mld_dmlprec_bld(a,desc_a,p,info,amold,vmold)
end if end if
end if end if
!
! The coarse space hierarchy has been build.
!
! Now do the preconditioner build.
!
do i=1, iszv do i=1, iszv
! !
! build the base preconditioner at level i ! build the base preconditioner at level i
@ -316,10 +476,6 @@ subroutine mld_dmlprec_bld(a,desc_a,p,info,amold,vmold)
goto 9999 goto 9999
end if end if
!
! Test version for beginning of OO stuff.
!
call p%precv(i)%sm%build(p%precv(i)%base_a,p%precv(i)%base_desc,& call p%precv(i)%sm%build(p%precv(i)%base_a,p%precv(i)%base_desc,&
& 'F',info,amold=amold,vmold=vmold) & 'F',info,amold=amold,vmold=vmold)
@ -350,69 +506,4 @@ subroutine mld_dmlprec_bld(a,desc_a,p,info,amold,vmold)
end if end if
return return
contains
subroutine check_coarse_lev(prec)
type(mld_d_onelev_type) :: prec
!
! At the coarsest level, check mld_coarse_solve_
!
!!$ val = prec%parms%coarse_solve
!!$ select case (val)
!!$ case(mld_jac_)
!!$
!!$ if (prec%prec%iprcparm(mld_sub_solve_) /= mld_diag_scale_) 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_.'
!!$ prec%prec%iprcparm(mld_sub_solve_) = mld_diag_scale_
!!$ end if
!!$ prec%prec%iprcparm(mld_smoother_type_) = mld_jac_
!!$
!!$ case(mld_bjac_)
!!$
!!$ if ((prec%prec%iprcparm(mld_sub_solve_) == mld_diag_scale_).or.&
!!$ & ( prec%prec%iprcparm(mld_smoother_type_) /= mld_bjac_)) 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_.'
!!$! !$#if defined(HAVE_UMF_)
!!$! !$ prec%prec%iprcparm(mld_sub_solve_) = mld_umf_
!!$! !$#elif defined(HAVE_SLU_)
!!$! !$ prec%prec%iprcparm(mld_sub_solve_) = mld_slu_
!!$! !$#else
!!$ prec%prec%iprcparm(mld_sub_solve_) = mld_ilu_n_
!!$! !$#endif
!!$ end if
!!$ prec%prec%iprcparm(mld_smoother_type_) = mld_bjac_
!!$
!!$ case(mld_umf_, mld_slu_)
!!$ if ((prec%iprcparm(mld_coarse_mat_) /= mld_repl_mat_).or.&
!!$ & (prec%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_.'
!!$ prec%iprcparm(mld_coarse_mat_) = mld_repl_mat_
!!$ prec%prec%iprcparm(mld_sub_solve_) = val
!!$ prec%prec%iprcparm(mld_smoother_type_) = mld_bjac_
!!$ end if
!!$ case(mld_sludist_)
!!$ if ((prec%iprcparm(mld_coarse_mat_) /= mld_distr_mat_).or.&
!!$ & (prec%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_.'
!!$ prec%iprcparm(mld_coarse_mat_) = mld_distr_mat_
!!$ prec%prec%iprcparm(mld_sub_solve_) = val
!!$ prec%prec%iprcparm(mld_smoother_type_) = mld_bjac_
!!$ prec%prec%iprcparm(mld_smoother_sweeps_) = 1
!!$ end if
!!$ end select
end subroutine check_coarse_lev
end subroutine mld_dmlprec_bld end subroutine mld_dmlprec_bld

1
mlprec/impl/mld_dprecinit.F90
Unescape Escape View File

@ -125,6 +125,7 @@ subroutine mld_dprecinit(p,ptype,info,nlev)
! Do we want to do something? ! Do we want to do something?
endif endif
endif endif
p%coarse_aggr_size = -1
select case(psb_toupper(ptype(1:len_trim(ptype)))) select case(psb_toupper(ptype(1:len_trim(ptype))))
case ('NOPREC','NONE') case ('NOPREC','NONE')

5
mlprec/impl/mld_dprecset.F90
Unescape Escape View File

@ -129,6 +129,11 @@ subroutine mld_dprecseti(p,what,val,info,ilev)
return return
endif endif
if (what == mld_coarse_aggr_size_) then
p%coarse_aggr_size = max(val,-1)
return
end if
! !
! Set preconditioner parameters at level ilev. ! Set preconditioner parameters at level ilev.
! !

2
mlprec/impl/mld_s_onelev_impl.f90
Unescape Escape View File

@ -154,7 +154,7 @@ subroutine mld_s_base_onelev_free(lv,info)
& call lv%sm%free(info) & call lv%sm%free(info)
call lv%ac%free() call lv%ac%free()
if (psb_is_ok_desc(lv%desc_ac)) & if (lv%desc_ac%is_ok()) &
& call psb_cdfree(lv%desc_ac,info) & call psb_cdfree(lv%desc_ac,info)
call lv%map%free(info) call lv%map%free(info)

142
mlprec/impl/mld_saggrmat_asb.f90
Unescape Escape View File

@ -113,6 +113,11 @@ subroutine mld_saggrmat_asb(a,desc_a,ilaggr,nlaggr,p,info)
integer, intent(out) :: info integer, intent(out) :: info
! Local variables ! Local variables
type(psb_sspmat_type) :: ac, op_prol,op_restr
type(psb_s_coo_sparse_mat) :: acoo, bcoo
type(psb_s_csr_sparse_mat) :: acsr1
integer :: nzl,ntaggr
integer :: debug_level, debug_unit
integer :: ictxt,np,me, err_act integer :: ictxt,np,me, err_act
character(len=20) :: name character(len=20) :: name
@ -120,6 +125,9 @@ subroutine mld_saggrmat_asb(a,desc_a,ilaggr,nlaggr,p,info)
if(psb_get_errstatus().ne.0) return if(psb_get_errstatus().ne.0) return
info=psb_success_ info=psb_success_
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
debug_unit = psb_get_debug_unit()
debug_level = psb_get_debug_level()
ictxt = desc_a%get_context() ictxt = desc_a%get_context()
@ -128,35 +136,139 @@ subroutine mld_saggrmat_asb(a,desc_a,ilaggr,nlaggr,p,info)
select case (p%parms%aggr_kind) select case (p%parms%aggr_kind)
case (mld_no_smooth_) case (mld_no_smooth_)
call mld_aggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,p,info) call mld_saggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,&
if(info /= psb_success_) then & p%parms,ac,op_prol,op_restr,info)
call psb_errpush(psb_err_from_subroutine_,name,a_err='mld_aggrmat_nosmth_asb')
case(mld_smooth_prol_)
call mld_saggrmat_smth_asb(a,desc_a,ilaggr,nlaggr, &
& p%parms,ac,op_prol,op_restr,info)
case(mld_biz_prol_)
call mld_saggrmat_biz_asb(a,desc_a,ilaggr,nlaggr, &
& p%parms,ac,op_prol,op_restr,info)
case(mld_min_energy_)
call mld_saggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr, &
& p%parms,ac,op_prol,op_restr,info)
case default
info = psb_err_internal_error_
call psb_errpush(info,name,a_err='Invalid aggr kind')
goto 9999
end select
if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='Inner aggrmat asb')
goto 9999
end if
ntaggr = sum(nlaggr)
select case(p%parms%coarse_mat)
case(mld_distr_mat_)
nzl = ac%get_nzeros()
call ac%mv_to(bcoo)
if (info == psb_success_) call psb_cdall(ictxt,p%desc_ac,info,nl=nlaggr(me+1))
if (info == psb_success_) call psb_cdins(nzl,bcoo%ia,bcoo%ja,p%desc_ac,info)
if (info == psb_success_) call psb_cdasb(p%desc_ac,info)
if (info == psb_success_) call psb_glob_to_loc(bcoo%ia(1:nzl),p%desc_ac,info,iact='I')
if (info == psb_success_) call psb_glob_to_loc(bcoo%ja(1:nzl),p%desc_ac,info,iact='I')
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Creating p%desc_ac and converting ac')
goto 9999 goto 9999
end if end if
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'Assembld aux descr. distr.'
call p%ac%mv_from(bcoo)
case(mld_smooth_prol_,mld_biz_prol_) call p%ac%set_nrows(p%desc_ac%get_local_rows())
call p%ac%set_ncols(p%desc_ac%get_local_cols())
call p%ac%set_asb()
call mld_aggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info) if (info /= psb_success_) then
if(info /= psb_success_) then call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_sp_free')
call psb_errpush(psb_err_from_subroutine_,name,a_err='mld_aggrmat_smth_asb')
goto 9999 goto 9999
end if end if
case(mld_min_energy_) if (np>1) then
call op_prol%mv_to(acsr1)
nzl = acsr1%get_nzeros()
call psb_glob_to_loc(acsr1%ja(1:nzl),p%desc_ac,info,'I')
if(info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_glob_to_loc')
goto 9999
end if
call op_prol%mv_from(acsr1)
endif
call op_prol%set_ncols(p%desc_ac%get_local_cols())
call mld_aggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info) if (np>1) then
if(info /= psb_success_) then call op_restr%cscnv(info,type='coo',dupl=psb_dupl_add_)
call psb_errpush(psb_err_from_subroutine_,name,a_err='mld_aggrmat_smth_asb') call op_restr%mv_to(acoo)
goto 9999 nzl = acoo%get_nzeros()
if (info == psb_success_) call psb_glob_to_loc(acoo%ia(1:nzl),p%desc_ac,info,'I')
call acoo%set_dupl(psb_dupl_add_)
if (info == psb_success_) call op_restr%mv_from(acoo)
if (info == psb_success_) call op_restr%cscnv(info,type='csr')
if(info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,a_err='Converting op_restr to local')
goto 9999
end if
end if end if
call op_restr%set_nrows(p%desc_ac%get_local_cols())
case default if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'Done ac '
call psb_errpush(psb_err_internal_error_,name,a_err='Invalid aggr kind') case(mld_repl_mat_)
goto 9999 !
!
call psb_cdall(ictxt,p%desc_ac,info,mg=ntaggr,repl=.true.)
if (info == psb_success_) call psb_cdasb(p%desc_ac,info)
if (info == psb_success_) &
& call psb_gather(p%ac,ac,p%desc_ac,info,dupl=psb_dupl_add_,keeploc=.false.)
if (info /= psb_success_) goto 9999
case default
info = psb_err_internal_error_
call psb_errpush(info,name,a_err='invalid mld_coarse_mat_')
goto 9999
end select end select
call p%ac%cscnv(info,type='csr',dupl=psb_dupl_add_)
if(info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='spcnv')
goto 9999
end if
!
! Copy the prolongation/restriction matrices into the descriptor map.
! op_restr => PR^T i.e. restriction operator
! op_prol => PR i.e. prolongation operator
!
p%map = psb_linmap(psb_map_aggr_,desc_a,&
& p%desc_ac,op_restr,op_prol,ilaggr,nlaggr)
if (info == psb_success_) call op_prol%free()
if (info == psb_success_) call op_restr%free()
if(info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='sp_Free')
goto 9999
end if
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
return return

422
mlprec/impl/mld_saggrmat_biz_asb.f90
Unescape Escape View File

@ -0,0 +1,422 @@
!!$
!!$
!!$ MLD2P4 version 2.0
!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package
!!$ based on PSBLAS (Parallel Sparse BLAS version 3.0)
!!$
!!$ (C) Copyright 2008,2009,2010
!!$
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$ Pasqua D'Ambra ICAR-CNR, Naples
!!$ Daniela di Serafino Second University of Naples
!!$
!!$ Redistribution and use in source and binary forms, with or without
!!$ modification, are permitted provided that the following conditions
!!$ are met:
!!$ 1. Redistributions of source code must retain the above copyright
!!$ notice, this list of conditions and the following disclaimer.
!!$ 2. Redistributions in binary form must reproduce the above copyright
!!$ notice, this list of conditions, and the following disclaimer in the
!!$ documentation and/or other materials provided with the distribution.
!!$ 3. The name of the MLD2P4 group or the names of its contributors may
!!$ not be used to endorse or promote products derived from this
!!$ software without specific written permission.
!!$
!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE MLD2P4 GROUP OR ITS CONTRIBUTORS
!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
!!$ POSSIBILITY OF SUCH DAMAGE.
!!$
!!$
! File: mld_saggrmat_biz_asb.F90
!
! Subroutine: mld_saggrmat_biz_asb
! Version: real
!
! This routine builds a coarse-level matrix A_C from a fine-level matrix A
! by using the Galerkin approach, i.e.
!
! A_C = P_C^T A P_C,
!
! where P_C is a prolongator from the coarse level to the fine one.
!
! This routine builds A_C according to a "bizarre" aggregation algorithm,
! using a "naive" prolongator proposed by the authors of MLD2P4. However, this
! prolongator still requires a deep analysis and testing and its use is not
! recommended.
!
! The coarse-level matrix A_C is distributed among the parallel processes or
! replicated on each of them, according to the value of p%parms%coarse_mat,
! specified by the user through mld_sprecinit and mld_zprecset.
!
! 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.
! p - type(mld_s_onelev_type), input/output.
! The 'one-level' data structure that will contain the local
! part of the matrix to be built as well as the information
! concerning the prolongator and its transpose.
! ilaggr - integer, dimension(:), allocatable.
! The mapping between the row indices of the coarse-level
! matrix and the row indices of the fine-level matrix.
! ilaggr(i)=j means that node i in the adjacency graph
! of the fine-level matrix is mapped onto node j in the
! adjacency graph of the coarse-level matrix.
! nlaggr - integer, dimension(:), allocatable.
! nlaggr(i) contains the aggregates held by process i.
! info - integer, output.
! Error code.
!
subroutine mld_saggrmat_biz_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_restr,info)
use psb_base_mod
use mld_s_inner_mod, mld_protect_name => mld_saggrmat_biz_asb
implicit none
! Arguments
type(psb_sspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_a
integer, intent(inout) :: ilaggr(:), nlaggr(:)
type(mld_sml_parms), intent(inout) :: parms
type(psb_sspmat_type), intent(out) :: ac,op_prol,op_restr
integer, intent(out) :: info
! Local variables
integer :: nrow, nglob, ncol, ntaggr, ip, ndx,&
& naggr, nzl,naggrm1,naggrp1, i, j, k, jd, icolF, nrw
integer ::ictxt, np, me, err_act
character(len=20) :: name
type(psb_sspmat_type) :: am3, am4
type(psb_s_coo_sparse_mat) :: tmpcoo
type(psb_s_csr_sparse_mat) :: acsr1, acsr2, acsr3, acsrf, ptilde
real(psb_spk_), allocatable :: adiag(:)
integer(psb_ipk_) :: ierr(5)
logical :: filter_mat
integer :: debug_level, debug_unit
integer, parameter :: ncmax=16
real(psb_spk_) :: anorm, omega, tmp, dg, theta
name='mld_aggrmat_biz_asb'
if(psb_get_errstatus().ne.0) return
info=psb_success_
call psb_erractionsave(err_act)
debug_unit = psb_get_debug_unit()
debug_level = psb_get_debug_level()
ictxt = desc_a%get_context()
ictxt = desc_a%get_context()
call psb_info(ictxt, me, np)
nglob = desc_a%get_global_rows()
nrow = desc_a%get_local_rows()
ncol = desc_a%get_local_cols()
theta = parms%aggr_thresh
naggr = nlaggr(me+1)
ntaggr = sum(nlaggr)
naggrm1 = sum(nlaggr(1:me))
naggrp1 = sum(nlaggr(1:me+1))
filter_mat = (parms%aggr_filter == mld_filter_mat_)
ilaggr(1:nrow) = ilaggr(1:nrow) + naggrm1
call psb_halo(ilaggr,desc_a,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_halo')
goto 9999
end if
! naggr: number of local aggregates
! nrow: local rows.
!
allocate(adiag(ncol),stat=info)
if (info /= psb_success_) then
info=psb_err_alloc_request_; ierr(1)=nrow;
call psb_errpush(info,name,i_err=ierr,a_err='real(psb_spk_)')
goto 9999
end if
! Get the diagonal D
call a%get_diag(adiag,info)
if (info == psb_success_) &
& call psb_halo(adiag,desc_a,info)
if(info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='sp_getdiag')
goto 9999
end if
! 1. Allocate Ptilde in sparse matrix form
call tmpcoo%allocate(ncol,naggr,ncol)
do i=1,nrow
tmpcoo%val(i) = sone
tmpcoo%ia(i) = i
tmpcoo%ja(i) = ilaggr(i)
end do
call tmpcoo%set_nzeros(nrow)
call tmpcoo%set_dupl(psb_dupl_add_)
call ptilde%mv_from_coo(tmpcoo,info)
if (info == psb_success_) call a%cscnv(acsr3,info,dupl=psb_dupl_add_)
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& ' Initial copies sone.'
if (filter_mat) then
!
! Build the filtered matrix Af from A
!
if (info == psb_success_) call a%cscnv(acsrf,info,dupl=psb_dupl_add_)
do i=1,nrow
tmp = szero
jd = -1
do j=acsrf%irp(i),acsrf%irp(i+1)-1
if (acsrf%ja(j) == i) jd = j
if (abs(acsrf%val(j)) < theta*sqrt(abs(adiag(i)*adiag(acsrf%ja(j))))) then
tmp=tmp+acsrf%val(j)
acsrf%val(j)=szero
endif
enddo
if (jd == -1) then
write(0,*) 'Wrong input: we need the diagonal!!!!', i
else
acsrf%val(jd)=acsrf%val(jd)-tmp
end if
enddo
! Take out zeroed terms
call acsrf%mv_to_coo(tmpcoo,info)
k = 0
do j=1,tmpcoo%get_nzeros()
if ((tmpcoo%val(j) /= szero) .or. (tmpcoo%ia(j) == tmpcoo%ja(j))) then
k = k + 1
tmpcoo%val(k) = tmpcoo%val(j)
tmpcoo%ia(k) = tmpcoo%ia(j)
tmpcoo%ja(k) = tmpcoo%ja(j)
end if
end do
call tmpcoo%set_nzeros(k)
call tmpcoo%set_dupl(psb_dupl_add_)
call acsrf%mv_from_coo(tmpcoo,info)
end if
do i=1,size(adiag)
if (adiag(i) /= szero) then
adiag(i) = sone / adiag(i)
else
adiag(i) = sone
end if
end do
if (filter_mat) call acsrf%scal(adiag,info)
if (info == psb_success_) call acsr3%scal(adiag,info)
if (info /= psb_success_) goto 9999
if (parms%aggr_omega_alg == mld_eig_est_) then
if (parms%aggr_eig == mld_max_norm_) then
!
! This only works with CSR
!
anorm = szero
dg = sone
nrw = acsr3%get_nrows()
do i=1, nrw
tmp = szero
do j=acsr3%irp(i),acsr3%irp(i+1)-1
if (acsr3%ja(j) <= nrw) then
tmp = tmp + abs(acsr3%val(j))
endif
if (acsr3%ja(j) == i ) then
dg = abs(acsr3%val(j))
end if
end do
anorm = max(anorm,tmp/dg)
enddo
call psb_amx(ictxt,anorm)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,a_err='Invalid AM3 storage format')
goto 9999
end if
omega = 4.d0/(3.d0*anorm)
parms%aggr_omega_val = omega
else
info = psb_err_internal_error_
call psb_errpush(info,name,a_err='invalid mld_aggr_eig_')
goto 9999
end if
else if (parms%aggr_omega_alg == mld_user_choice_) then
omega = parms%aggr_omega_val
else if (parms%aggr_omega_alg /= mld_user_choice_) then
info = psb_err_internal_error_
call psb_errpush(info,name,a_err='invalid mld_aggr_omega_alg_')
goto 9999
end if
if (filter_mat) then
!
! Build the smoothed prolongator using the filtered matrix
!
do i=1,acsrf%get_nrows()
do j=acsrf%irp(i),acsrf%irp(i+1)-1
if (acsrf%ja(j) == i) then
acsrf%val(j) = sone - omega*acsrf%val(j)
else
acsrf%val(j) = - omega*acsrf%val(j)
end if
end do
end do
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'Done gather, going for SYMBMM 1'
!
! Symbmm90 does the allocation for its result.
!
! acsrm1 = (I-w*D*Af)Ptilde
! Doing it this way means to consider diag(Af_i)
!
!
call psb_symbmm(acsrf,ptilde,acsr1,info)
if(info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='symbmm 1')
goto 9999
end if
call psb_numbmm(acsrf,ptilde,acsr1)
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'Done NUMBMM 1'
else
!
! Build the smoothed prolongator using the original matrix
!
do i=1,acsr3%get_nrows()
do j=acsr3%irp(i),acsr3%irp(i+1)-1
if (acsr3%ja(j) == i) then
acsr3%val(j) = sone - omega*acsr3%val(j)
else
acsr3%val(j) = - omega*acsr3%val(j)
end if
end do
end do
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'Done gather, going for SYMBMM 1'
!
! Symbmm90 does the allocation for its result.
!
! acsrm1 = (I-w*D*A)Ptilde
! Doing it this way means to consider diag(A_i)
!
!
call psb_symbmm(acsr3,ptilde,acsr1,info)
if(info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='symbmm 1')
goto 9999
end if
call psb_numbmm(acsr3,ptilde,acsr1)
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'Done NUMBMM 1'
end if
call ptilde%free()
call acsr1%set_dupl(psb_dupl_add_)
call op_prol%mv_from(acsr1)
call psb_rwextd(ncol,op_prol,info)
if(info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,a_err='Halo of op_prol')
goto 9999
end if
call psb_symbmm(a,op_prol,am3,info)
if(info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='symbmm 2')
goto 9999
end if
call psb_numbmm(a,op_prol,am3)
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'Done NUMBMM 2',parms%aggr_kind, mld_smooth_prol_
call op_prol%transp(op_restr)
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'starting sphalo/ rwxtd'
call psb_rwextd(ncol,am3,info)
if(info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,a_err='Extend am3')
goto 9999
end if
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'starting symbmm 3'
call psb_symbmm(op_restr,am3,ac,info)
if (info == psb_success_) call psb_numbmm(op_restr,am3,ac)
if (info == psb_success_) call am3%free()
if (info == psb_success_) call ac%cscnv(info,type='coo',dupl=psb_dupl_add_)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,a_err='Build b = op_restr x am3')
goto 9999
end if
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'Done smooth_aggregate '
call psb_erractionrestore(err_act)
return
9999 continue
call psb_errpush(info,name)
call psb_erractionrestore(err_act)
if (err_act.eq.psb_act_abort_) then
call psb_error()
return
end if
return
end subroutine mld_saggrmat_biz_asb

218
mlprec/impl/mld_saggrmat_minnrg_asb.F90 → mlprec/impl/mld_saggrmat_minnrg_asb.f90
Unescape Escape View File

@ -98,37 +98,31 @@
! info - integer, output. ! info - integer, output.
! Error code. ! Error code.
! !
subroutine mld_saggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info) subroutine mld_saggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_restr,info)
use psb_base_mod use psb_base_mod
use mld_s_inner_mod, mld_protect_name => mld_saggrmat_minnrg_asb use mld_s_inner_mod, mld_protect_name => mld_saggrmat_minnrg_asb
#ifdef MPI_MOD
use mpi
#endif
implicit none implicit none
#ifdef MPI_H
include 'mpif.h'
#endif
! Arguments ! Arguments
type(psb_sspmat_type), intent(in) :: a type(psb_sspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_a type(psb_desc_type), intent(in) :: desc_a
integer, intent(inout) :: ilaggr(:), nlaggr(:) integer, intent(inout) :: ilaggr(:), nlaggr(:)
type(mld_s_onelev_type), intent(inout), target :: p type(mld_sml_parms), intent(inout) :: parms
type(psb_sspmat_type), intent(out) :: ac,op_prol,op_restr
integer, intent(out) :: info integer, intent(out) :: info
! Local variables ! Local variables
type(psb_sspmat_type) :: b
integer(psb_mpik_), allocatable :: nzbr(:), idisp(:) integer(psb_mpik_), allocatable :: nzbr(:), idisp(:)
integer :: nrow, nglob, ncol, ntaggr, nzac, ip, ndx,& integer :: nrow, nglob, ncol, ntaggr, nzac, ip, ndx,&
& naggr, nzl,naggrm1,naggrp1, i, j, k, jd, icolF, nrt & naggr, nzl,naggrm1,naggrp1, i, j, k, jd, icolF, nrt
integer :: ictxt,np,me, err_act, icomm integer :: ictxt,np,me, err_act, icomm
character(len=20) :: name character(len=20) :: name
type(psb_sspmat_type) :: am1,am2, af, ptilde, rtilde, atran, atp, atdatp type(psb_sspmat_type) :: af, ptilde, rtilde, atran, atp, atdatp
type(psb_sspmat_type) :: am3,am4, ap, adap,atmp,rada, ra, atmp2, dap, dadap, da type(psb_sspmat_type) :: am3,am4, ap, adap,atmp,rada, ra, atmp2, dap, dadap, da
type(psb_sspmat_type) :: dat, datp, datdatp, atmp3 type(psb_sspmat_type) :: dat, datp, datdatp, atmp3
type(psb_s_coo_sparse_mat) :: acoo, acoof, bcoo, tmpcoo type(psb_s_coo_sparse_mat) :: tmpcoo
type(psb_s_csr_sparse_mat) :: acsr1, acsr2, acsr3, bcsr, acsr, acsrf type(psb_s_csr_sparse_mat) :: acsr1, acsr2, acsr3, acsr, acsrf
type(psb_s_csc_sparse_mat) :: csc_dap, csc_dadap, csc_datp, csc_datdatp, acsc type(psb_s_csc_sparse_mat) :: csc_dap, csc_dadap, csc_datp, csc_datdatp, acsc
real(psb_spk_), allocatable :: adiag(:), adinv(:) real(psb_spk_), allocatable :: adiag(:), adinv(:)
real(psb_spk_), allocatable :: omf(:), omp(:), omi(:), oden(:) real(psb_spk_), allocatable :: omf(:), omp(:), omi(:), oden(:)
@ -156,7 +150,7 @@ subroutine mld_saggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info)
nrow = desc_a%get_local_rows() nrow = desc_a%get_local_rows()
ncol = desc_a%get_local_cols() ncol = desc_a%get_local_cols()
theta = p%parms%aggr_thresh theta = parms%aggr_thresh
naggr = nlaggr(me+1) naggr = nlaggr(me+1)
ntaggr = sum(nlaggr) ntaggr = sum(nlaggr)
@ -171,7 +165,7 @@ subroutine mld_saggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info)
naggrm1 = sum(nlaggr(1:me)) naggrm1 = sum(nlaggr(1:me))
naggrp1 = sum(nlaggr(1:me+1)) naggrp1 = sum(nlaggr(1:me+1))
filter_mat = (p%parms%aggr_filter == mld_filter_mat_) filter_mat = (parms%aggr_filter == mld_filter_mat_)
ilaggr(1:nrow) = ilaggr(1:nrow) + naggrm1 ilaggr(1:nrow) = ilaggr(1:nrow) + naggrm1
call psb_halo(ilaggr,desc_a,info) call psb_halo(ilaggr,desc_a,info)
@ -213,16 +207,16 @@ subroutine mld_saggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info)
! 1. Allocate Ptilde in sparse matrix form ! 1. Allocate Ptilde in sparse matrix form
call acoo%allocate(ncol,ntaggr,ncol) call tmpcoo%allocate(ncol,ntaggr,ncol)
do i=1,ncol do i=1,ncol
acoo%val(i) = sone tmpcoo%val(i) = sone
acoo%ia(i) = i tmpcoo%ia(i) = i
acoo%ja(i) = ilaggr(i) tmpcoo%ja(i) = ilaggr(i)
end do end do
call acoo%set_nzeros(ncol) call tmpcoo%set_nzeros(ncol)
call acoo%set_dupl(psb_dupl_add_) call tmpcoo%set_dupl(psb_dupl_add_)
call acoo%set_asb() call tmpcoo%set_asb()
call ptilde%mv_from(acoo) call ptilde%mv_from(tmpcoo)
call ptilde%cscnv(info,type='csr') call ptilde%cscnv(info,type='csr')
!!$ call local_dump(me,ptilde,'csr-ptilde','Ptilde-1') !!$ call local_dump(me,ptilde,'csr-ptilde','Ptilde-1')
@ -354,17 +348,17 @@ subroutine mld_saggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info)
! !
! Symbmm90 does the allocation for its result. ! Symbmm90 does the allocation for its result.
! !
! am1 = (I-w*D*Af)Ptilde ! op_prol = (I-w*D*Af)Ptilde
! Doing it this way means to consider diag(Af_i) ! Doing it this way means to consider diag(Af_i)
! !
! !
call psb_symbmm(af,ptilde,am1,info) call psb_symbmm(af,ptilde,op_prol,info)
if(info /= psb_success_) then if(info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='symbmm 1') call psb_errpush(psb_err_from_subroutine_,name,a_err='symbmm 1')
goto 9999 goto 9999
end if end if
call psb_numbmm(af,ptilde,am1) call psb_numbmm(af,ptilde,op_prol)
if (debug_level >= psb_debug_outer_) & if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),& & write(debug_unit,*) me,' ',trim(name),&
@ -390,16 +384,16 @@ subroutine mld_saggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info)
! !
! Symbmm90 does the allocation for its result. ! Symbmm90 does the allocation for its result.
! !
! am1 = (I-w*D*A)Ptilde ! op_prol = (I-w*D*A)Ptilde
! !
! !
call psb_symbmm(am3,ptilde,am1,info) call psb_symbmm(am3,ptilde,op_prol,info)
if(info /= psb_success_) then if(info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='symbmm 1') call psb_errpush(psb_err_from_subroutine_,name,a_err='symbmm 1')
goto 9999 goto 9999
end if end if
call psb_numbmm(am3,ptilde,am1) call psb_numbmm(am3,ptilde,op_prol)
if (debug_level >= psb_debug_outer_) & if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),& & write(debug_unit,*) me,' ',trim(name),&
@ -509,20 +503,20 @@ subroutine mld_saggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info)
call rtilde%mv_from(tmpcoo) call rtilde%mv_from(tmpcoo)
call rtilde%cscnv(info,type='csr') call rtilde%cscnv(info,type='csr')
call psb_symbmm(rtilde,atmp,am2,info) call psb_symbmm(rtilde,atmp,op_restr,info)
call psb_numbmm(rtilde,atmp,am2) call psb_numbmm(rtilde,atmp,op_restr)
! !
! Now we have to gather the halo of am1, and add it to itself ! Now we have to gather the halo of op_prol, and add it to itself
! to multiply it by A, ! to multiply it by A,
! !
call psb_sphalo(am1,desc_a,am4,info,& call psb_sphalo(op_prol,desc_a,am4,info,&
& colcnv=.false.,rowscale=.true.) & colcnv=.false.,rowscale=.true.)
if (info == psb_success_) call psb_rwextd(ncol,am1,info,b=am4) if (info == psb_success_) call psb_rwextd(ncol,op_prol,info,b=am4)
if (info == psb_success_) call am4%free() if (info == psb_success_) call am4%free()
if(info /= psb_success_) then if(info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,a_err='Halo of am1') call psb_errpush(psb_err_internal_error_,name,a_err='Halo of op_prol')
goto 9999 goto 9999
end if end if
@ -530,7 +524,7 @@ subroutine mld_saggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info)
! Now we have to fix this. The only rows of B that are correct ! Now we have to fix this. The only rows of B that are correct
! are those corresponding to "local" aggregates, i.e. indices in ilaggr(:) ! are those corresponding to "local" aggregates, i.e. indices in ilaggr(:)
! !
call am2%mv_to(tmpcoo) call op_restr%mv_to(tmpcoo)
nzl = tmpcoo%get_nzeros() nzl = tmpcoo%get_nzeros()
i=0 i=0
@ -543,21 +537,21 @@ subroutine mld_saggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info)
end if end if
end do end do
call tmpcoo%set_nzeros(i) call tmpcoo%set_nzeros(i)
call am2%mv_from(tmpcoo) call op_restr%mv_from(tmpcoo)
call am2%cscnv(info,type='csr') call op_restr%cscnv(info,type='csr')
if (debug_level >= psb_debug_outer_) & if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),& & write(debug_unit,*) me,' ',trim(name),&
& 'starting sphalo/ rwxtd' & 'starting sphalo/ rwxtd'
call psb_symbmm(a,am1,am3,info) call psb_symbmm(a,op_prol,am3,info)
if(info /= psb_success_) then if(info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,& call psb_errpush(psb_err_from_subroutine_,name,&
& a_err='symbmm 2') & a_err='symbmm 2')
goto 9999 goto 9999
end if end if
call psb_numbmm(a,am1,am3) call psb_numbmm(a,op_prol,am3)
if (debug_level >= psb_debug_outer_) & if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),& & write(debug_unit,*) me,' ',trim(name),&
& 'Done NUMBMM 2' & 'Done NUMBMM 2'
@ -576,156 +570,18 @@ subroutine mld_saggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info)
& write(debug_unit,*) me,' ',trim(name),& & write(debug_unit,*) me,' ',trim(name),&
& 'Done sphalo/ rwxtd' & 'Done sphalo/ rwxtd'
call psb_symbmm(am2,am3,b,info) call psb_symbmm(op_restr,am3,ac,info)
if (info == psb_success_) call psb_numbmm(am2,am3,b) if (info == psb_success_) call psb_numbmm(op_restr,am3,ac)
if (info == psb_success_) call am3%free() if (info == psb_success_) call am3%free()
call b%mv_to(bcoo) if (info == psb_success_) call ac%cscnv(info,type='coo',dupl=psb_dupl_add_)
if (info /= psb_success_) then if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,& call psb_errpush(psb_err_internal_error_,name,&
&a_err='Build b = am2 x am3') &a_err='Build ac = op_restr x am3')
goto 9999 goto 9999
end if end if
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'Done mv_to_coo'
select case(p%parms%coarse_mat)
case(mld_distr_mat_)
nzl = bcoo%get_nzeros()
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& ' B matrix nzl: ',nzl
if (info == psb_success_) call psb_cdall(ictxt,p%desc_ac,info,nl=nlaggr(me+1))
if (info == psb_success_) call psb_cdins(nzl,bcoo%ia,bcoo%ja,p%desc_ac,info)
if (info == psb_success_) call psb_cdasb(p%desc_ac,info)
if (info == psb_success_) call psb_glob_to_loc(bcoo%ia(1:nzl),p%desc_ac,info,iact='I')
if (info == psb_success_) call psb_glob_to_loc(bcoo%ja(1:nzl),p%desc_ac,info,iact='I')
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Creating p%desc_ac and converting ac')
goto 9999
end if
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& ' Assembld aux descr. distr.'
call bcoo%set_nrows(p%desc_ac%get_local_rows())
call bcoo%set_ncols(p%desc_ac%get_local_cols())
call bcoo%fix(info)
call p%ac%mv_from(bcoo)
call p%ac%set_asb()
call p%ac%cscnv(info,type='csr')
if (np>1) then
call am1%mv_to(acsr)
nzl = acsr%get_nzeros()
call psb_glob_to_loc(acsr%ja(1:nzl),p%desc_ac,info,'I')
if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_glob_to_loc')
goto 9999
end if
call am1%mv_from(acsr)
endif
call am1%set_ncols(p%desc_ac%get_local_cols())
if (np>1) then
call am2%mv_to(tmpcoo)
nzl = tmpcoo%get_nzeros()
if (info == psb_success_) call psb_glob_to_loc(tmpcoo%ia(1:nzl),p%desc_ac,info,'I')
if(info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,a_err='Converting am2 to local')
goto 9999
end if
call am2%mv_from(tmpcoo)
call am2%cscnv(info,type='csr')
end if
call am2%set_nrows(p%desc_ac%get_local_cols())
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'Done ac '
case(mld_repl_mat_)
!
!
call psb_cdall(ictxt,p%desc_ac,info,mg=ntaggr,repl=.true.)
nzbr(:) = 0
nzbr(me+1) = bcoo%get_nzeros()
call psb_sum(ictxt,nzbr(1:np))
nzac = sum(nzbr)
if (info == psb_success_) call tmpcoo%allocate(ntaggr,ntaggr,nzac)
if (info /= psb_success_) goto 9999
do ip=1,np
idisp(ip) = sum(nzbr(1:ip-1))
enddo
ndx = nzbr(me+1)
call mpi_allgatherv(bcoo%val,ndx,mpi_real,tmpcoo%val,nzbr,idisp,&
& mpi_real,icomm,info)
if (info == psb_success_)&
& call mpi_allgatherv(bcoo%ia,ndx,psb_mpi_ipk_integer,tmpcoo%ia,nzbr,idisp,&
& psb_mpi_ipk_integer,icomm,info)
if (info == psb_success_)&
& call mpi_allgatherv(bcoo%ja,ndx,psb_mpi_ipk_integer,tmpcoo%ja,nzbr,idisp,&
& psb_mpi_ipk_integer,icomm,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err=' from mpi_allgatherv')
goto 9999
end if
call bcoo%free()
call tmpcoo%fix(info)
call p%ac%mv_from(tmpcoo)
call p%ac%cscnv(info,type='csr')
if(info /= psb_success_) goto 9999
deallocate(nzbr,idisp,stat=info)
if (info /= psb_success_) then
info = psb_err_alloc_dealloc_
call psb_errpush(info,name)
goto 9999
end if
case default
info = psb_err_internal_error_
call psb_errpush(info,name,a_err='invalid mld_coarse_mat_')
goto 9999
end select
call p%ac%cscnv(info,type='csr')
if(info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='spcnv')
goto 9999
end if
!
! Copy the prolongation/restriction matrices into the descriptor map.
! am2 => R i.e. restriction operator
! am1 => P i.e. prolongation operator
!
p%map = psb_linmap(psb_map_aggr_,desc_a,&
& p%desc_ac,am2,am1,ilaggr,nlaggr)
if (info == psb_success_) call am1%free()
if (info == psb_success_) call am2%free()
if(info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='sp_Free')
goto 9999
end if
if (debug_level >= psb_debug_outer_) & if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),& & write(debug_unit,*) me,' ',trim(name),&

163
mlprec/impl/mld_saggrmat_nosmth_asb.F90 → mlprec/impl/mld_saggrmat_nosmth_asb.f90
Unescape Escape View File

@ -81,35 +81,29 @@
! info - integer, output. ! info - integer, output.
! Error code. ! Error code.
! !
subroutine mld_saggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,p,info) subroutine mld_saggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_restr,info)
use psb_base_mod use psb_base_mod
use mld_s_inner_mod, mld_protect_name => mld_saggrmat_nosmth_asb use mld_s_inner_mod, mld_protect_name => mld_saggrmat_nosmth_asb
#ifdef MPI_MOD
use mpi
#endif
implicit none implicit none
#ifdef MPI_H
include 'mpif.h'
#endif
! Arguments ! Arguments
type(psb_sspmat_type), intent(in) :: a type(psb_sspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_a type(psb_desc_type), intent(in) :: desc_a
integer, intent(inout) :: ilaggr(:), nlaggr(:) integer, intent(inout) :: ilaggr(:), nlaggr(:)
type(mld_s_onelev_type), intent(inout), target :: p type(mld_sml_parms), intent(inout) :: parms
type(psb_sspmat_type), intent(out) :: ac,op_prol,op_restr
integer, intent(out) :: info integer, intent(out) :: info
! Local variables ! Local variables
integer :: ictxt,np,me, err_act integer :: ictxt,np,me, err_act
integer(psb_mpik_) :: icomm, ndx, minfo integer(psb_mpik_) :: icomm, ndx, minfo
character(len=20) :: name character(len=20) :: name
type(psb_sspmat_type) :: b
integer(psb_mpik_), allocatable :: nzbr(:), idisp(:)
integer(psb_ipk_) :: ierr(5) integer(psb_ipk_) :: ierr(5)
type(psb_sspmat_type) :: am1,am2 type(psb_s_coo_sparse_mat) :: ac_coo, acoo
type(psb_s_coo_sparse_mat) :: acoo1, acoo2, bcoo, ac_coo type(psb_s_csr_sparse_mat) :: acsr1, acsr2
integer :: nrow, nglob, ncol, ntaggr, nzac, ip, & integer :: debug_level, debug_unit
integer :: nrow, nglob, ncol, ntaggr, nzl, ip, &
& naggr, nzt, naggrm1, i & naggr, nzt, naggrm1, i
name='mld_aggrmat_nosmth_asb' name='mld_aggrmat_nosmth_asb'
@ -128,141 +122,48 @@ subroutine mld_saggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,p,info)
naggr = nlaggr(me+1) naggr = nlaggr(me+1)
ntaggr = sum(nlaggr) ntaggr = sum(nlaggr)
allocate(nzbr(np), idisp(np),stat=info)
if (info /= psb_success_) then
info=psb_err_alloc_request_; ierr(1)=2*np;
call psb_errpush(info,name,i_err=ierr,a_err='integer')
goto 9999
end if
naggrm1=sum(nlaggr(1:me)) naggrm1=sum(nlaggr(1:me))
if (p%parms%coarse_mat == mld_repl_mat_) then do i=1, nrow
do i=1, nrow ilaggr(i) = ilaggr(i) + naggrm1
ilaggr(i) = ilaggr(i) + naggrm1 end do
end do call psb_halo(ilaggr,desc_a,info)
call psb_halo(ilaggr,desc_a,info)
end if
if(info /= psb_success_) then if(info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_halo') call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_halo')
goto 9999 goto 9999
end if end if
if (p%parms%coarse_mat == mld_repl_mat_) then call acoo%allocate(ncol,ntaggr,ncol)
call acoo1%allocate(ncol,ntaggr,ncol)
else
call acoo1%allocate(ncol,naggr,ncol)
end if
do i=1,nrow do i=1,nrow
acoo1%val(i) = sone acoo%val(i) = sone
acoo1%ia(i) = i acoo%ia(i) = i
acoo1%ja(i) = ilaggr(i) acoo%ja(i) = ilaggr(i)
end do end do
call acoo1%set_dupl(psb_dupl_add_) call acoo%set_dupl(psb_dupl_add_)
call acoo1%set_nzeros(nrow) call acoo%set_nzeros(nrow)
call acoo1%set_asb() call acoo%set_asb()
call acoo1%fix(info) call acoo%fix(info)
call acoo1%transp(acoo2)
call a%csclip(bcoo,info,jmax=nrow) call op_prol%mv_from(acoo)
call op_prol%cscnv(info,type='csr',dupl=psb_dupl_add_)
if (info == psb_success_) call op_prol%transp(op_restr)
call a%csclip(ac_coo,info,jmax=nrow)
nzt = bcoo%get_nzeros() nzt = ac_coo%get_nzeros()
do i=1, nzt do i=1, nzt
bcoo%ia(i) = ilaggr(bcoo%ia(i)) ac_coo%ia(i) = ilaggr(ac_coo%ia(i))
bcoo%ja(i) = ilaggr(bcoo%ja(i)) ac_coo%ja(i) = ilaggr(ac_coo%ja(i))
enddo enddo
call bcoo%set_nrows(naggr) call ac_coo%set_nrows(naggr)
call bcoo%set_ncols(naggr) call ac_coo%set_ncols(naggr)
call bcoo%set_dupl(psb_dupl_add_) call ac_coo%set_dupl(psb_dupl_add_)
call bcoo%fix(info) call ac_coo%fix(info)
call ac%mv_from(ac_coo)
if (p%parms%coarse_mat == mld_repl_mat_) then
call psb_cdall(ictxt,p%desc_ac,info,mg=ntaggr,repl=.true.)
if (info == psb_success_) call psb_cdasb(p%desc_ac,info)
if(info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_cdall')
goto 9999
end if
nzbr(:) = 0
nzbr(me+1) = nzt
call psb_sum(ictxt,nzbr(1:np))
nzac = sum(nzbr)
call ac_coo%allocate(ntaggr,ntaggr,nzac)
do ip=1,np
idisp(ip) = sum(nzbr(1:ip-1))
enddo
ndx = nzbr(me+1)
call mpi_allgatherv(bcoo%val,ndx,mpi_real,ac_coo%val,nzbr,idisp,&
& mpi_real,icomm,minfo)
call mpi_allgatherv(bcoo%ia,ndx,psb_mpi_ipk_integer,ac_coo%ia,nzbr,idisp,&
& psb_mpi_ipk_integer,icomm,minfo)
call mpi_allgatherv(bcoo%ja,ndx,psb_mpi_ipk_integer,ac_coo%ja,nzbr,idisp,&
& psb_mpi_ipk_integer,icomm,minfo)
if(info /= psb_success_) then
info=-1
call psb_errpush(info,name)
goto 9999
end if
call ac_coo%set_nzeros(nzac)
call ac_coo%set_dupl(psb_dupl_add_)
call ac_coo%fix(info)
call p%ac%mv_from(ac_coo)
else if (p%parms%coarse_mat == mld_distr_mat_) then
call psb_cdall(ictxt,p%desc_ac,info,nl=naggr)
if (info == psb_success_) call psb_cdasb(p%desc_ac,info)
call p%ac%mv_from(bcoo)
if(info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,a_err='Build ac, desc_ac')
goto 9999
end if
else
info = psb_err_internal_error_
call psb_errpush(psb_err_internal_error_,name,a_err='invalid mld_coarse_mat_')
goto 9999
end if
call bcoo%free()
deallocate(nzbr,idisp)
call p%ac%cscnv(info,type='csr',dupl=psb_dupl_add_)
if(info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='cscnv')
goto 9999
end if
call am1%mv_from(acoo1)
call am1%cscnv(info,type='csr',dupl=psb_dupl_add_)
if (info == psb_success_) call am2%mv_from(acoo2)
if (info == psb_success_) call am2%cscnv(info,type='csr',dupl=psb_dupl_add_)
!
! Copy the prolongation/restriction matrices into the descriptor map.
! am2 => PR^T i.e. restriction operator
! am1 => PR i.e. prolongation operator
!
if (info == psb_success_) &
& p%map = psb_linmap(psb_map_aggr_,desc_a,&
& p%desc_ac,am2,am1,ilaggr,nlaggr)
if (info == psb_success_) call am1%free()
if (info == psb_success_) call am2%free()
if(info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='linmap build')
goto 9999
end if
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)

421
mlprec/impl/mld_saggrmat_smth_asb.F90 → mlprec/impl/mld_saggrmat_smth_asb.f90
Unescape Escape View File

@ -61,11 +61,6 @@
! according to the value of p%parms%aggr_omega_alg, specified by the user ! according to the value of p%parms%aggr_omega_alg, specified by the user
! through mld_sprecinit and mld_zprecset. ! through mld_sprecinit and mld_zprecset.
! !
! This routine can also build A_C according to a "bizarre" aggregation algorithm,
! using a "naive" prolongator proposed by the authors of MLD2P4. However, this
! prolongator still requires a deep analysis and testing and its use is not
! recommended.
!
! The coarse-level matrix A_C is distributed among the parallel processes or ! The coarse-level matrix A_C is distributed among the parallel processes or
! replicated on each of them, according to the value of p%parms%coarse_mat, ! replicated on each of them, according to the value of p%parms%coarse_mat,
! specified by the user through mld_sprecinit and mld_zprecset. ! specified by the user through mld_sprecinit and mld_zprecset.
@ -98,38 +93,31 @@
! info - integer, output. ! info - integer, output.
! Error code. ! Error code.
! !
subroutine mld_saggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info) subroutine mld_saggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_restr,info)
use psb_base_mod use psb_base_mod
use mld_s_inner_mod, mld_protect_name => mld_saggrmat_smth_asb use mld_s_inner_mod, mld_protect_name => mld_saggrmat_smth_asb
#ifdef MPI_MOD
use mpi
#endif
implicit none implicit none
#ifdef MPI_H
include 'mpif.h'
#endif
! Arguments ! Arguments
type(psb_sspmat_type), intent(in) :: a type(psb_sspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_a type(psb_desc_type), intent(in) :: desc_a
integer, intent(inout) :: ilaggr(:), nlaggr(:) integer, intent(inout) :: ilaggr(:), nlaggr(:)
type(mld_s_onelev_type), intent(inout), target :: p type(mld_sml_parms), intent(inout) :: parms
type(psb_sspmat_type), intent(out) :: ac,op_prol,op_restr
integer, intent(out) :: info integer, intent(out) :: info
! Local variables ! Local variables
type(psb_sspmat_type) :: b integer :: nrow, nglob, ncol, ntaggr, ip, ndx,&
integer, allocatable :: nzbr(:), idisp(:)
integer :: nrow, nglob, ncol, ntaggr, nzac, ip, ndx,&
& naggr, nzl,naggrm1,naggrp1, i, j, k, jd, icolF, nrw & naggr, nzl,naggrm1,naggrp1, i, j, k, jd, icolF, nrw
integer ::ictxt, np, me, err_act integer ::ictxt, np, me, err_act
character(len=20) :: name character(len=20) :: name
type(psb_sspmat_type) :: am1,am2, am3, am4 type(psb_sspmat_type) :: am3, am4
type(psb_s_coo_sparse_mat) :: acoo, acoof, bcoo type(psb_s_coo_sparse_mat) :: tmpcoo
type(psb_s_csr_sparse_mat) :: acsr1, acsr2, acsr3, acsrf, ptilde type(psb_s_csr_sparse_mat) :: acsr1, acsr2, acsr3, acsrf, ptilde
real(psb_spk_), allocatable :: adiag(:) real(psb_spk_), allocatable :: adiag(:)
integer(psb_ipk_) :: ierr(5) integer(psb_ipk_) :: ierr(5)
logical :: ml_global_nmb, filter_mat logical :: filter_mat
integer :: debug_level, debug_unit integer :: debug_level, debug_unit
integer, parameter :: ncmax=16 integer, parameter :: ncmax=16
real(psb_spk_) :: anorm, omega, tmp, dg, theta real(psb_spk_) :: anorm, omega, tmp, dg, theta
@ -150,34 +138,21 @@ subroutine mld_saggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info)
nrow = desc_a%get_local_rows() nrow = desc_a%get_local_rows()
ncol = desc_a%get_local_cols() ncol = desc_a%get_local_cols()
theta = p%parms%aggr_thresh theta = parms%aggr_thresh
naggr = nlaggr(me+1) naggr = nlaggr(me+1)
ntaggr = sum(nlaggr) ntaggr = sum(nlaggr)
allocate(nzbr(np), idisp(np),stat=info)
if (info /= psb_success_) then
info=psb_err_alloc_request_; ierr(1)=2*np;
call psb_errpush(info,name,i_err=ierr,a_err='integer')
goto 9999
end if
naggrm1 = sum(nlaggr(1:me)) naggrm1 = sum(nlaggr(1:me))
naggrp1 = sum(nlaggr(1:me+1)) naggrp1 = sum(nlaggr(1:me+1))
ml_global_nmb = ( (p%parms%aggr_kind == mld_smooth_prol_).or.& filter_mat = (parms%aggr_filter == mld_filter_mat_)
& ( (p%parms%aggr_kind == mld_biz_prol_).and.&
& (p%parms%coarse_mat == mld_repl_mat_)) )
filter_mat = (p%parms%aggr_filter == mld_filter_mat_)
if (ml_global_nmb) then ilaggr(1:nrow) = ilaggr(1:nrow) + naggrm1
ilaggr(1:nrow) = ilaggr(1:nrow) + naggrm1 call psb_halo(ilaggr,desc_a,info)
call psb_halo(ilaggr,desc_a,info)
if (info /= psb_success_) then if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_halo') call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_halo')
goto 9999 goto 9999
end if
end if end if
! naggr: number of local aggregates ! naggr: number of local aggregates
@ -202,32 +177,22 @@ subroutine mld_saggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info)
end if end if
! 1. Allocate Ptilde in sparse matrix form ! 1. Allocate Ptilde in sparse matrix form
if (ml_global_nmb) then call tmpcoo%allocate(ncol,ntaggr,ncol)
call acoo%allocate(ncol,ntaggr,ncol) do i=1,ncol
do i=1,ncol tmpcoo%val(i) = sone
acoo%val(i) = sone tmpcoo%ia(i) = i
acoo%ia(i) = i tmpcoo%ja(i) = ilaggr(i)
acoo%ja(i) = ilaggr(i) end do
end do call tmpcoo%set_nzeros(ncol)
call acoo%set_nzeros(ncol) call tmpcoo%set_dupl(psb_dupl_add_)
else
call acoo%allocate(ncol,naggr,ncol) call ptilde%mv_from_coo(tmpcoo,info)
do i=1,nrow
acoo%val(i) = sone
acoo%ia(i) = i
acoo%ja(i) = ilaggr(i)
end do
call acoo%set_nzeros(nrow)
endif
call acoo%set_dupl(psb_dupl_add_)
call ptilde%mv_from_coo(acoo,info)
if (info == psb_success_) call a%cscnv(acsr3,info,dupl=psb_dupl_add_) if (info == psb_success_) call a%cscnv(acsr3,info,dupl=psb_dupl_add_)
if (debug_level >= psb_debug_outer_) & if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),& & write(debug_unit,*) me,' ',trim(name),&
& ' Initial copies sone.' & ' Initial copies sone.'
if (filter_mat) then if (filter_mat) then
! !
! Build the filtered matrix Af from A ! Build the filtered matrix Af from A
@ -252,19 +217,19 @@ subroutine mld_saggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info)
end if end if
enddo enddo
! Take out zeroed terms ! Take out zeroed terms
call acsrf%mv_to_coo(acoof,info) call acsrf%mv_to_coo(tmpcoo,info)
k = 0 k = 0
do j=1,acoof%get_nzeros() do j=1,tmpcoo%get_nzeros()
if ((acoof%val(j) /= szero) .or. (acoof%ia(j) == acoof%ja(j))) then if ((tmpcoo%val(j) /= szero) .or. (tmpcoo%ia(j) == tmpcoo%ja(j))) then
k = k + 1 k = k + 1
acoof%val(k) = acoof%val(j) tmpcoo%val(k) = tmpcoo%val(j)
acoof%ia(k) = acoof%ia(j) tmpcoo%ia(k) = tmpcoo%ia(j)
acoof%ja(k) = acoof%ja(j) tmpcoo%ja(k) = tmpcoo%ja(j)
end if end if
end do end do
call acoof%set_nzeros(k) call tmpcoo%set_nzeros(k)
call acoof%set_dupl(psb_dupl_add_) call tmpcoo%set_dupl(psb_dupl_add_)
call acsrf%mv_from_coo(acoof,info) call acsrf%mv_from_coo(tmpcoo,info)
end if end if
@ -281,41 +246,13 @@ subroutine mld_saggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info)
if (info /= psb_success_) goto 9999 if (info /= psb_success_) goto 9999
if (p%parms%aggr_omega_alg == mld_eig_est_) then if (parms%aggr_omega_alg == mld_eig_est_) then
if (p%parms%aggr_eig == mld_max_norm_) then if (parms%aggr_eig == mld_max_norm_) then
if (p%parms%aggr_kind == mld_biz_prol_) then anorm = acsr3%csnmi()
!
! This only works with CSR
!
anorm = szero
dg = sone
nrw = acsr3%get_nrows()
do i=1, nrw
tmp = szero
do j=acsr3%irp(i),acsr3%irp(i+1)-1
if (acsr3%ja(j) <= nrw) then
tmp = tmp + abs(acsr3%val(j))
endif
if (acsr3%ja(j) == i ) then
dg = abs(acsr3%val(j))
end if
end do
anorm = max(anorm,tmp/dg)
enddo
call psb_amx(ictxt,anorm)
else
anorm = acsr3%csnmi()
endif
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,a_err='Invalid AM3 storage format')
goto 9999
end if
omega = 4.d0/(3.d0*anorm) omega = 4.d0/(3.d0*anorm)
p%parms%aggr_omega_val = omega parms%aggr_omega_val = omega
else else
info = psb_err_internal_error_ info = psb_err_internal_error_
@ -323,11 +260,11 @@ subroutine mld_saggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info)
goto 9999 goto 9999
end if end if
else if (p%parms%aggr_omega_alg == mld_user_choice_) then else if (parms%aggr_omega_alg == mld_user_choice_) then
omega = p%parms%aggr_omega_val omega = parms%aggr_omega_val
else if (p%parms%aggr_omega_alg /= mld_user_choice_) then else if (parms%aggr_omega_alg /= mld_user_choice_) then
info = psb_err_internal_error_ info = psb_err_internal_error_
call psb_errpush(info,name,a_err='invalid mld_aggr_omega_alg_') call psb_errpush(info,name,a_err='invalid mld_aggr_omega_alg_')
goto 9999 goto 9999
@ -368,7 +305,7 @@ subroutine mld_saggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info)
if (debug_level >= psb_debug_outer_) & if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),& & write(debug_unit,*) me,' ',trim(name),&
& 'Done NUMBMM 1' & 'Done NUMBMM 1'
else else
! !
! Build the smoothed prolongator using the original matrix ! Build the smoothed prolongator using the original matrix
@ -409,76 +346,64 @@ subroutine mld_saggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info)
call ptilde%free() call ptilde%free()
call acsr1%set_dupl(psb_dupl_add_) call acsr1%set_dupl(psb_dupl_add_)
call am1%mv_from(acsr1) call op_prol%mv_from(acsr1)
if (ml_global_nmb) then !
! ! Now we have to gather the halo of op_prol, and add it to itself
! Now we have to gather the halo of am1, and add it to itself ! to multiply it by A,
! to multiply it by A, !
! call psb_sphalo(op_prol,desc_a,am4,info,&
call psb_sphalo(am1,desc_a,am4,info,& & colcnv=.false.,rowscale=.true.)
& colcnv=.false.,rowscale=.true.) if (info == psb_success_) call psb_rwextd(ncol,op_prol,info,b=am4)
if (info == psb_success_) call psb_rwextd(ncol,am1,info,b=am4) if (info == psb_success_) call am4%free()
if (info == psb_success_) call am4%free()
else
call psb_rwextd(ncol,am1,info)
endif
if(info /= psb_success_) then if(info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,a_err='Halo of am1') call psb_errpush(psb_err_internal_error_,name,a_err='Halo of op_prol')
goto 9999 goto 9999
end if end if
call psb_symbmm(a,am1,am3,info) call psb_symbmm(a,op_prol,am3,info)
if(info /= psb_success_) then if(info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='symbmm 2') call psb_errpush(psb_err_from_subroutine_,name,a_err='symbmm 2')
goto 9999 goto 9999
end if end if
call psb_numbmm(a,am1,am3) call psb_numbmm(a,op_prol,am3)
if (debug_level >= psb_debug_outer_) & if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),& & write(debug_unit,*) me,' ',trim(name),&
& 'Done NUMBMM 2',p%parms%aggr_kind, mld_smooth_prol_ & 'Done NUMBMM 2',parms%aggr_kind, mld_smooth_prol_
if (p%parms%aggr_kind == mld_smooth_prol_) then call op_prol%transp(op_restr)
call am1%transp(am2) call op_restr%mv_to(tmpcoo)
call am2%mv_to(acoo) nzl = tmpcoo%get_nzeros()
nzl = acoo%get_nzeros() i=0
i=0 !
! ! Now we have to fix this. The only rows of B that are correct
! Now we have to fix this. The only rows of B that are correct ! are those corresponding to "local" aggregates, i.e. indices in ilaggr(:)
! are those corresponding to "local" aggregates, i.e. indices in ilaggr(:) !
! do k=1, nzl
do k=1, nzl if ((naggrm1 < tmpcoo%ia(k)) .and.(tmpcoo%ia(k) <= naggrp1)) then
if ((naggrm1 < acoo%ia(k)) .and.(acoo%ia(k) <= naggrp1)) then i = i+1
i = i+1 tmpcoo%val(i) = tmpcoo%val(k)
acoo%val(i) = acoo%val(k) tmpcoo%ia(i) = tmpcoo%ia(k)
acoo%ia(i) = acoo%ia(k) tmpcoo%ja(i) = tmpcoo%ja(k)
acoo%ja(i) = acoo%ja(k)
end if
end do
call acoo%set_nzeros(i)
call acoo%trim()
call am2%mv_from(acoo)
call am2%cscnv(info,type='csr',dupl=psb_dupl_add_)
if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='spcnv am2')
goto 9999
end if end if
else end do
call am1%transp(am2) call tmpcoo%set_nzeros(i)
endif call tmpcoo%trim()
call op_restr%mv_from(tmpcoo)
call op_restr%cscnv(info,type='csr',dupl=psb_dupl_add_)
if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='spcnv op_restr')
goto 9999
end if
if (debug_level >= psb_debug_outer_) & if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),& & write(debug_unit,*) me,' ',trim(name),&
& 'starting sphalo/ rwxtd' & 'starting sphalo/ rwxtd'
if (p%parms%aggr_kind == mld_smooth_prol_) then ! op_restr = ((i-wDA)Ptilde)^T
! am2 = ((i-wDA)Ptilde)^T call psb_sphalo(am3,desc_a,am4,info,&
call psb_sphalo(am3,desc_a,am4,info,& & colcnv=.false.,rowscale=.true.)
& colcnv=.false.,rowscale=.true.) if (info == psb_success_) call psb_rwextd(ncol,am3,info,b=am4)
if (info == psb_success_) call psb_rwextd(ncol,am3,info,b=am4) if (info == psb_success_) call am4%free()
if (info == psb_success_) call am4%free()
else if (p%parms%aggr_kind == mld_biz_prol_) then
call psb_rwextd(ncol,am3,info)
endif
if(info /= psb_success_) then if(info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,a_err='Extend am3') call psb_errpush(psb_err_internal_error_,name,a_err='Extend am3')
goto 9999 goto 9999
@ -488,180 +413,12 @@ subroutine mld_saggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info)
if (debug_level >= psb_debug_outer_) & if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),& & write(debug_unit,*) me,' ',trim(name),&
& 'starting symbmm 3' & 'starting symbmm 3'
call psb_symbmm(am2,am3,b,info) call psb_symbmm(op_restr,am3,ac,info)
if (info == psb_success_) call psb_numbmm(am2,am3,b) if (info == psb_success_) call psb_numbmm(op_restr,am3,ac)
if (info == psb_success_) call am3%free() if (info == psb_success_) call am3%free()
if (info == psb_success_) call b%cscnv(info,type='coo',dupl=psb_dupl_add_) if (info == psb_success_) call ac%cscnv(info,type='coo',dupl=psb_dupl_add_)
if (info /= psb_success_) then if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,a_err='Build b = am2 x am3') call psb_errpush(psb_err_internal_error_,name,a_err='Build ac = op_restr x am3')
goto 9999
end if
select case(p%parms%aggr_kind)
case(mld_smooth_prol_)
select case(p%parms%coarse_mat)
case(mld_distr_mat_)
nzac = b%get_nzeros()
nzl = nzac
call b%mv_to(bcoo)
if (info == psb_success_) call psb_cdall(ictxt,p%desc_ac,info,nl=nlaggr(me+1))
if (info == psb_success_) call psb_cdins(nzl,bcoo%ia,bcoo%ja,p%desc_ac,info)
if (info == psb_success_) call psb_cdasb(p%desc_ac,info)
if (info == psb_success_) call psb_glob_to_loc(bcoo%ia(1:nzl),p%desc_ac,info,iact='I')
if (info == psb_success_) call psb_glob_to_loc(bcoo%ja(1:nzl),p%desc_ac,info,iact='I')
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Creating p%desc_ac and converting ac')
goto 9999
end if
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'Assembld aux descr. distr.'
call p%ac%mv_from(bcoo)
call p%ac%set_nrows(p%desc_ac%get_local_rows())
call p%ac%set_ncols(p%desc_ac%get_local_cols())
call p%ac%set_asb()
if (info == psb_success_) deallocate(nzbr,idisp,stat=info)
if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_sp_free')
goto 9999
end if
if (np>1) then
call am1%mv_to(acsr1)
nzl = acsr1%get_nzeros()
call psb_glob_to_loc(acsr1%ja(1:nzl),p%desc_ac,info,'I')
if(info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_glob_to_loc')
goto 9999
end if
call am1%mv_from(acsr1)
endif
call am1%set_ncols(p%desc_ac%get_local_cols())
if (np>1) then
call am2%cscnv(info,type='coo',dupl=psb_dupl_add_)
call am2%mv_to(acoo)
nzl = acoo%get_nzeros()
if (info == psb_success_) call psb_glob_to_loc(acoo%ia(1:nzl),p%desc_ac,info,'I')
call acoo%set_dupl(psb_dupl_add_)
if (info == psb_success_) call am2%mv_from(acoo)
if (info == psb_success_) call am2%cscnv(info,type='csr')
if(info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,a_err='Converting am2 to local')
goto 9999
end if
end if
call am2%set_nrows(p%desc_ac%get_local_cols())
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'Done ac '
case(mld_repl_mat_)
!
!
call psb_cdall(ictxt,p%desc_ac,info,mg=ntaggr,repl=.true.)
if (info == psb_success_) call psb_cdasb(p%desc_ac,info)
if (info == psb_success_) &
& call psb_gather(p%ac,b,p%desc_ac,info,dupl=psb_dupl_add_,keeploc=.false.)
if (info /= psb_success_) goto 9999
deallocate(nzbr,idisp,stat=info)
if (info /= psb_success_) then
info = psb_err_alloc_dealloc_
call psb_errpush(info,name)
goto 9999
end if
case default
info = psb_err_internal_error_
call psb_errpush(info,name,a_err='invalid mld_coarse_mat_')
goto 9999
end select
case(mld_biz_prol_)
select case(p%parms%coarse_mat)
case(mld_distr_mat_)
call psb_move_alloc(b,p%ac,info)
if (info == psb_success_) call psb_cdall(ictxt,p%desc_ac,info,nl=naggr)
if (info == psb_success_) call psb_cdasb(p%desc_ac,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='Build desc_ac, ac')
goto 9999
end if
case(mld_repl_mat_)
!
!
call psb_cdall(ictxt,p%desc_ac,info,mg=ntaggr,repl=.true.)
if (info == psb_success_) call psb_cdasb(p%desc_ac,info)
if(info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_cdall')
goto 9999
end if
call psb_gather(p%ac,b,p%desc_ac,info,dupl=psb_dupl_add_,keeploc=.false.)
if(info /= psb_success_) goto 9999
deallocate(nzbr,idisp,stat=info)
if (info /= psb_success_) then
info = psb_err_alloc_dealloc_
call psb_errpush(info,name)
goto 9999
end if
case default
info = psb_err_internal_error_
call psb_errpush(info,name,a_err='invalid mld_coarse_mat_')
goto 9999
end select
deallocate(nzbr,idisp,stat=info)
if (info /= psb_success_) then
info = psb_err_alloc_dealloc_
call psb_errpush(info,name)
goto 9999
end if
case default
info = psb_err_internal_error_
call psb_errpush(info,name,a_err='invalid mld_smooth_prol_')
goto 9999
end select
call p%ac%cscnv(info,type='csr',dupl=psb_dupl_add_)
if(info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='spcnv')
goto 9999
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 = psb_linmap(psb_map_aggr_,desc_a,&
& p%desc_ac,am2,am1,ilaggr,nlaggr)
if (info == psb_success_) call am1%free()
if (info == psb_success_) call am2%free()
if(info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='sp_Free')
goto 9999 goto 9999
end if end if

267
mlprec/impl/mld_smlprec_bld.f90
Unescape Escape View File

@ -93,11 +93,13 @@ subroutine mld_smlprec_bld(a,desc_a,p,info,amold,vmold)
! Local Variables ! Local Variables
type(mld_sprec_type) :: t_prec type(mld_sprec_type) :: t_prec
Integer :: err,i,k,ictxt, me,np, err_act, iszv, newsz Integer :: err,i,k,ictxt, me,np, err_act, iszv, newsz, casize
integer :: ipv(mld_ifpsz_), val integer :: ipv(mld_ifpsz_), val
integer :: int_err(5) integer :: int_err(5)
character :: upd_ character :: upd_
type(mld_sml_parms) :: prm class(mld_s_base_smoother_type), allocatable :: coarse_sm, base_sm, med_sm
type(mld_sml_parms) :: baseparms, medparms, coarseparms
type(mld_s_onelev_node), pointer :: head, tail, newnode, current
integer :: debug_level, debug_unit integer :: debug_level, debug_unit
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
@ -145,12 +147,22 @@ subroutine mld_smlprec_bld(a,desc_a,p,info,amold,vmold)
! Check to ensure all procs have the same ! Check to ensure all procs have the same
! !
newsz = -1 newsz = -1
casize = p%coarse_aggr_size
iszv = size(p%precv) iszv = size(p%precv)
call psb_bcast(ictxt,iszv) call psb_bcast(ictxt,iszv)
if (iszv /= size(p%precv)) then call psb_bcast(ictxt,casize)
info=psb_err_internal_error_ if (casize > 0) then
call psb_errpush(info,name,a_err='Inconsistent size of precv') if (casize /= p%coarse_aggr_size) then
goto 9999 info=psb_err_internal_error_
call psb_errpush(info,name,a_err='Inconsistent coarse_aggr_size')
goto 9999
end if
else
if (iszv /= size(p%precv)) then
info=psb_err_internal_error_
call psb_errpush(info,name,a_err='Inconsistent size of precv')
goto 9999
end if
end if end if
if (iszv <= 1) then if (iszv <= 1) then
@ -162,7 +174,161 @@ subroutine mld_smlprec_bld(a,desc_a,p,info,amold,vmold)
endif endif
if (iszv > 1) then
if (casize>0) then
!
! New strategy to build according to coarse size.
!
coarseparms = p%precv(iszv)%parms
baseparms = p%precv(1)%parms
medparms = p%precv(2)%parms
allocate(coarse_sm, source=p%precv(iszv)%sm,stat=info)
if (info == psb_success_) &
& allocate(med_sm, source=p%precv(2)%sm,stat=info)
if (info == psb_success_) &
& allocate(base_sm, source=p%precv(1)%sm,stat=info)
if (info /= psb_success_) then
write(0,*) 'Error in saving smoothers',info
call psb_errpush(psb_err_internal_error_,name,a_err='Base level precbuild.')
goto 9999
end if
!
! Replicated matrix should only ever happen at coarse level.
!
call mld_check_def(baseparms%coarse_mat,'Coarse matrix',&
& mld_distr_mat_,is_distr_ml_coarse_mat)
!
! Now build a doubly linked list
!
allocate(newnode,stat=info)
if (info /= psb_success_) then
info = psb_err_internal_error_
call psb_errpush(info,name,a_err='List start'); goto 9999
end if
head => newnode
tail => newnode
newnode%item%base_a => a
newnode%item%base_desc => desc_a
newnode%item%parms = baseparms
newsz = 1
current => head
list_build_loop: do
allocate(newnode,stat=info)
if (info /= psb_success_) then
info = psb_err_internal_error_
call psb_errpush(info,name,a_err='List start'); goto 9999
end if
current%next => newnode
newnode%prev => current
newsz = newsz + 1
newnode%item%parms = medparms
newnode%item%parms%aggr_thresh = current%item%parms%aggr_thresh/2
call mld_coarse_bld(current%item%base_a, current%item%base_desc, &
& newnode%item,info)
if (info /= psb_success_) then
info = psb_err_internal_error_
call psb_errpush(info,name,a_err='build next level'); goto 9999
end if
if (newsz>2) then
if (all(current%item%map%naggr == newnode%item%map%naggr)) then
!
! We are not gaining anything
!
newsz = newsz-1
current%next => null()
call newnode%item%free(info)
if (info == psb_success_) deallocate(newnode,stat=info)
if (info /= psb_success_) then
info = psb_err_internal_error_
call psb_errpush(info,name,a_err='Deallocate at list end'); goto 9999
end if
end if
end if
current => current%next
tail => current
if (sum(newnode%item%map%naggr) <= casize) then
!
! Target reached; but we may need to rebuild.
!
exit list_build_loop
end if
end do list_build_loop
!
! At this point, we are at the list tail,
! and it needs to be rebuilt in case the parms were
! different.
!
! But the threshold has to be fixed before rebuliding
coarseparms%aggr_thresh = current%item%parms%aggr_thresh
current%item%parms = coarseparms
call mld_coarse_bld(current%prev%item%base_a,&
& current%prev%item%base_desc, &
& current%item,info)
if (info /= psb_success_) then
info = psb_err_internal_error_
call psb_errpush(info,name,a_err='build next level'); goto 9999
end if
!
! Ok, now allocate the output vector and fix items.
!
do i=1,iszv
if (info == psb_success_) call p%precv(i)%free(info)
end do
if (info == psb_success_) deallocate(p%precv,stat=info)
if (info == psb_success_) allocate(p%precv(newsz),stat=info)
if (info /= psb_success_) then
info = psb_err_internal_error_
call psb_errpush(info,name,a_err='Reallocate precv'); goto 9999
end if
newnode => head
do i=1, newsz
current => newnode
if (info == psb_success_) &
& call mld_move_alloc(current%item,p%precv(i),info)
if (info == psb_success_) then
if (i ==1) then
allocate(p%precv(i)%sm,source=base_sm,stat=info)
else if (i < newsz) then
allocate(p%precv(i)%sm,source=med_sm,stat=info)
else
allocate(p%precv(i)%sm,source=coarse_sm,stat=info)
end if
end if
if (info /= psb_success_) then
info = psb_err_internal_error_
call psb_errpush(info,name,a_err='list cpy'); goto 9999
end if
if (i == 1) then
p%precv(i)%base_a => a
p%precv(i)%base_desc => desc_a
else
p%precv(i)%base_a => p%precv(i)%ac
p%precv(i)%base_desc => p%precv(i)%desc_ac
p%precv(i)%map%p_desc_X => p%precv(i-1)%base_desc
p%precv(i)%map%p_desc_Y => p%precv(i)%base_desc
end if
newnode => current%next
deallocate(current)
end do
call base_sm%free(info)
if (info == psb_success_) call med_sm%free(info)
if (info == psb_success_) call coarse_sm%free(info)
if (info == psb_success_) deallocate(coarse_sm,med_sm,base_sm,stat=info)
if (info /= psb_success_) then
info = psb_err_internal_error_
call psb_errpush(info,name,a_err='final cleanup'); goto 9999
end if
iszv = newsz
else
!
! Default, oldstyle
!
! !
! Build the matrix and the transfer operators corresponding ! Build the matrix and the transfer operators corresponding
@ -179,11 +345,6 @@ subroutine mld_smlprec_bld(a,desc_a,p,info,amold,vmold)
p%precv(1)%base_a => a p%precv(1)%base_a => a
p%precv(1)%base_desc => desc_a p%precv(1)%base_desc => desc_a
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,a_err='Base level precbuild.')
goto 9999
end if
do i=2, iszv do i=2, iszv
! !
@ -201,11 +362,6 @@ subroutine mld_smlprec_bld(a,desc_a,p,info,amold,vmold)
! !
call mld_check_def(p%precv(i)%parms%coarse_mat,'Coarse matrix',& call mld_check_def(p%precv(i)%parms%coarse_mat,'Coarse matrix',&
& mld_distr_mat_,is_distr_ml_coarse_mat) & mld_distr_mat_,is_distr_ml_coarse_mat)
else if (i == iszv) then
!!$ call check_coarse_lev(p%precv(i))
end if end if
if (debug_level >= psb_debug_outer_) & if (debug_level >= psb_debug_outer_) &
@ -277,9 +433,7 @@ subroutine mld_smlprec_bld(a,desc_a,p,info,amold,vmold)
p%precv(i)%map%p_desc_Y => p%precv(i)%base_desc p%precv(i)%map%p_desc_Y => p%precv(i)%base_desc
end do end do
i = iszv i = iszv
call check_coarse_lev(p%precv(i))
if (info == psb_success_) call mld_coarse_bld(p%precv(i-1)%base_a,& if (info == psb_success_) call mld_coarse_bld(p%precv(i-1)%base_a,&
& p%precv(i-1)%base_desc, p%precv(i),info) & p%precv(i-1)%base_desc, p%precv(i),info)
if (info /= psb_success_) then if (info /= psb_success_) then
@ -289,6 +443,12 @@ subroutine mld_smlprec_bld(a,desc_a,p,info,amold,vmold)
end if end if
end if end if
!
! The coarse space hierarchy has been build.
!
! Now do the preconditioner build.
!
do i=1, iszv do i=1, iszv
! !
! build the base preconditioner at level i ! build the base preconditioner at level i
@ -316,10 +476,6 @@ subroutine mld_smlprec_bld(a,desc_a,p,info,amold,vmold)
goto 9999 goto 9999
end if end if
!
! Test version for beginning of OO stuff.
!
call p%precv(i)%sm%build(p%precv(i)%base_a,p%precv(i)%base_desc,& call p%precv(i)%sm%build(p%precv(i)%base_a,p%precv(i)%base_desc,&
& 'F',info,amold=amold,vmold=vmold) & 'F',info,amold=amold,vmold=vmold)
@ -350,69 +506,4 @@ subroutine mld_smlprec_bld(a,desc_a,p,info,amold,vmold)
end if end if
return return
contains
subroutine check_coarse_lev(prec)
type(mld_s_onelev_type) :: prec
!
! At the coarsest level, check mld_coarse_solve_
!
!!$ val = prec%parms%coarse_solve
!!$ select case (val)
!!$ case(mld_jac_)
!!$
!!$ if (prec%prec%iprcparm(mld_sub_solve_) /= mld_diag_scale_) 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_.'
!!$ prec%prec%iprcparm(mld_sub_solve_) = mld_diag_scale_
!!$ end if
!!$ prec%prec%iprcparm(mld_smoother_type_) = mld_jac_
!!$
!!$ case(mld_bjac_)
!!$
!!$ if ((prec%prec%iprcparm(mld_sub_solve_) == mld_diag_scale_).or.&
!!$ & ( prec%prec%iprcparm(mld_smoother_type_) /= mld_bjac_)) 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_.'
!!$! !$#if defined(HAVE_UMF_)
!!$! !$ prec%prec%iprcparm(mld_sub_solve_) = mld_umf_
!!$! !$#elif defined(HAVE_SLU_)
!!$! !$ prec%prec%iprcparm(mld_sub_solve_) = mld_slu_
!!$! !$#else
!!$ prec%prec%iprcparm(mld_sub_solve_) = mld_ilu_n_
!!$! !$#endif
!!$ end if
!!$ prec%prec%iprcparm(mld_smoother_type_) = mld_bjac_
!!$
!!$ case(mld_umf_, mld_slu_)
!!$ if ((prec%iprcparm(mld_coarse_mat_) /= mld_repl_mat_).or.&
!!$ & (prec%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_.'
!!$ prec%iprcparm(mld_coarse_mat_) = mld_repl_mat_
!!$ prec%prec%iprcparm(mld_sub_solve_) = val
!!$ prec%prec%iprcparm(mld_smoother_type_) = mld_bjac_
!!$ end if
!!$ case(mld_sludist_)
!!$ if ((prec%iprcparm(mld_coarse_mat_) /= mld_distr_mat_).or.&
!!$ & (prec%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_.'
!!$ prec%iprcparm(mld_coarse_mat_) = mld_distr_mat_
!!$ prec%prec%iprcparm(mld_sub_solve_) = val
!!$ prec%prec%iprcparm(mld_smoother_type_) = mld_bjac_
!!$ prec%prec%iprcparm(mld_smoother_sweeps_) = 1
!!$ end if
!!$ end select
end subroutine check_coarse_lev
end subroutine mld_smlprec_bld end subroutine mld_smlprec_bld

1
mlprec/impl/mld_sprecinit.F90
Unescape Escape View File

@ -125,6 +125,7 @@ subroutine mld_sprecinit(p,ptype,info,nlev)
! Do we want to do something? ! Do we want to do something?
endif endif
endif endif
p%coarse_aggr_size = -1
select case(psb_toupper(ptype(1:len_trim(ptype)))) select case(psb_toupper(ptype(1:len_trim(ptype))))
case ('NOPREC','NONE') case ('NOPREC','NONE')

5
mlprec/impl/mld_sprecset.F90
Unescape Escape View File

@ -129,6 +129,11 @@ subroutine mld_sprecseti(p,what,val,info,ilev)
return return
endif endif
if (what == mld_coarse_aggr_size_) then
p%coarse_aggr_size = max(val,-1)
return
end if
! !
! Set preconditioner parameters at level ilev. ! Set preconditioner parameters at level ilev.
! !

2
mlprec/impl/mld_z_onelev_impl.f90
Unescape Escape View File

@ -154,7 +154,7 @@ subroutine mld_z_base_onelev_free(lv,info)
& call lv%sm%free(info) & call lv%sm%free(info)
call lv%ac%free() call lv%ac%free()
if (psb_is_ok_desc(lv%desc_ac)) & if (lv%desc_ac%is_ok()) &
& call psb_cdfree(lv%desc_ac,info) & call psb_cdfree(lv%desc_ac,info)
call lv%map%free(info) call lv%map%free(info)

142
mlprec/impl/mld_zaggrmat_asb.f90
Unescape Escape View File

@ -113,6 +113,11 @@ subroutine mld_zaggrmat_asb(a,desc_a,ilaggr,nlaggr,p,info)
integer, intent(out) :: info integer, intent(out) :: info
! Local variables ! Local variables
type(psb_zspmat_type) :: ac, op_prol,op_restr
type(psb_z_coo_sparse_mat) :: acoo, bcoo
type(psb_z_csr_sparse_mat) :: acsr1
integer :: nzl,ntaggr
integer :: debug_level, debug_unit
integer :: ictxt,np,me, err_act integer :: ictxt,np,me, err_act
character(len=20) :: name character(len=20) :: name
@ -120,6 +125,9 @@ subroutine mld_zaggrmat_asb(a,desc_a,ilaggr,nlaggr,p,info)
if(psb_get_errstatus().ne.0) return if(psb_get_errstatus().ne.0) return
info=psb_success_ info=psb_success_
call psb_erractionsave(err_act) call psb_erractionsave(err_act)
debug_unit = psb_get_debug_unit()
debug_level = psb_get_debug_level()
ictxt = desc_a%get_context() ictxt = desc_a%get_context()
@ -128,35 +136,139 @@ subroutine mld_zaggrmat_asb(a,desc_a,ilaggr,nlaggr,p,info)
select case (p%parms%aggr_kind) select case (p%parms%aggr_kind)
case (mld_no_smooth_) case (mld_no_smooth_)
call mld_aggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,p,info) call mld_zaggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,&
if(info /= psb_success_) then & p%parms,ac,op_prol,op_restr,info)
call psb_errpush(psb_err_from_subroutine_,name,a_err='mld_aggrmat_nosmth_asb')
case(mld_smooth_prol_)
call mld_zaggrmat_smth_asb(a,desc_a,ilaggr,nlaggr, &
& p%parms,ac,op_prol,op_restr,info)
case(mld_biz_prol_)
call mld_zaggrmat_biz_asb(a,desc_a,ilaggr,nlaggr, &
& p%parms,ac,op_prol,op_restr,info)
case(mld_min_energy_)
call mld_zaggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr, &
& p%parms,ac,op_prol,op_restr,info)
case default
info = psb_err_internal_error_
call psb_errpush(info,name,a_err='Invalid aggr kind')
goto 9999
end select
if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='Inner aggrmat asb')
goto 9999
end if
ntaggr = sum(nlaggr)
select case(p%parms%coarse_mat)
case(mld_distr_mat_)
nzl = ac%get_nzeros()
call ac%mv_to(bcoo)
if (info == psb_success_) call psb_cdall(ictxt,p%desc_ac,info,nl=nlaggr(me+1))
if (info == psb_success_) call psb_cdins(nzl,bcoo%ia,bcoo%ja,p%desc_ac,info)
if (info == psb_success_) call psb_cdasb(p%desc_ac,info)
if (info == psb_success_) call psb_glob_to_loc(bcoo%ia(1:nzl),p%desc_ac,info,iact='I')
if (info == psb_success_) call psb_glob_to_loc(bcoo%ja(1:nzl),p%desc_ac,info,iact='I')
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Creating p%desc_ac and converting ac')
goto 9999 goto 9999
end if end if
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'Assembld aux descr. distr.'
call p%ac%mv_from(bcoo)
case(mld_smooth_prol_,mld_biz_prol_) call p%ac%set_nrows(p%desc_ac%get_local_rows())
call p%ac%set_ncols(p%desc_ac%get_local_cols())
call p%ac%set_asb()
call mld_aggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info) if (info /= psb_success_) then
if(info /= psb_success_) then call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_sp_free')
call psb_errpush(psb_err_from_subroutine_,name,a_err='mld_aggrmat_smth_asb')
goto 9999 goto 9999
end if end if
case(mld_min_energy_) if (np>1) then
call op_prol%mv_to(acsr1)
nzl = acsr1%get_nzeros()
call psb_glob_to_loc(acsr1%ja(1:nzl),p%desc_ac,info,'I')
if(info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_glob_to_loc')
goto 9999
end if
call op_prol%mv_from(acsr1)
endif
call op_prol%set_ncols(p%desc_ac%get_local_cols())
call mld_aggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info) if (np>1) then
if(info /= psb_success_) then call op_restr%cscnv(info,type='coo',dupl=psb_dupl_add_)
call psb_errpush(psb_err_from_subroutine_,name,a_err='mld_aggrmat_smth_asb') call op_restr%mv_to(acoo)
goto 9999 nzl = acoo%get_nzeros()
if (info == psb_success_) call psb_glob_to_loc(acoo%ia(1:nzl),p%desc_ac,info,'I')
call acoo%set_dupl(psb_dupl_add_)
if (info == psb_success_) call op_restr%mv_from(acoo)
if (info == psb_success_) call op_restr%cscnv(info,type='csr')
if(info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,a_err='Converting op_restr to local')
goto 9999
end if
end if end if
call op_restr%set_nrows(p%desc_ac%get_local_cols())
case default if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'Done ac '
call psb_errpush(psb_err_internal_error_,name,a_err='Invalid aggr kind') case(mld_repl_mat_)
goto 9999 !
!
call psb_cdall(ictxt,p%desc_ac,info,mg=ntaggr,repl=.true.)
if (info == psb_success_) call psb_cdasb(p%desc_ac,info)
if (info == psb_success_) &
& call psb_gather(p%ac,ac,p%desc_ac,info,dupl=psb_dupl_add_,keeploc=.false.)
if (info /= psb_success_) goto 9999
case default
info = psb_err_internal_error_
call psb_errpush(info,name,a_err='invalid mld_coarse_mat_')
goto 9999
end select end select
call p%ac%cscnv(info,type='csr',dupl=psb_dupl_add_)
if(info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='spcnv')
goto 9999
end if
!
! Copy the prolongation/restriction matrices into the descriptor map.
! op_restr => PR^T i.e. restriction operator
! op_prol => PR i.e. prolongation operator
!
p%map = psb_linmap(psb_map_aggr_,desc_a,&
& p%desc_ac,op_restr,op_prol,ilaggr,nlaggr)
if (info == psb_success_) call op_prol%free()
if (info == psb_success_) call op_restr%free()
if(info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='sp_Free')
goto 9999
end if
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)
return return

422
mlprec/impl/mld_zaggrmat_biz_asb.f90
Unescape Escape View File

@ -0,0 +1,422 @@
!!$
!!$
!!$ MLD2P4 version 2.0
!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package
!!$ based on PSBLAS (Parallel Sparse BLAS version 3.0)
!!$
!!$ (C) Copyright 2008,2009,2010
!!$
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$ Pasqua D'Ambra ICAR-CNR, Naples
!!$ Daniela di Serafino Second University of Naples
!!$
!!$ Redistribution and use in source and binary forms, with or without
!!$ modification, are permitted provided that the following conditions
!!$ are met:
!!$ 1. Redistributions of source code must retain the above copyright
!!$ notice, this list of conditions and the following disclaimer.
!!$ 2. Redistributions in binary form must reproduce the above copyright
!!$ notice, this list of conditions, and the following disclaimer in the
!!$ documentation and/or other materials provided with the distribution.
!!$ 3. The name of the MLD2P4 group or the names of its contributors may
!!$ not be used to endorse or promote products derived from this
!!$ software without specific written permission.
!!$
!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE MLD2P4 GROUP OR ITS CONTRIBUTORS
!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
!!$ POSSIBILITY OF SUCH DAMAGE.
!!$
!!$
! File: mld_zaggrmat_biz_asb.F90
!
! Subroutine: mld_zaggrmat_biz_asb
! Version: complex
!
! This routine builds a coarse-level matrix A_C from a fine-level matrix A
! by using the Galerkin approach, i.e.
!
! A_C = P_C^T A P_C,
!
! where P_C is a prolongator from the coarse level to the fine one.
!
! This routine builds A_C according to a "bizarre" aggregation algorithm,
! using a "naive" prolongator proposed by the authors of MLD2P4. However, this
! prolongator still requires a deep analysis and testing and its use is not
! recommended.
!
! The coarse-level matrix A_C is distributed among the parallel processes or
! replicated on each of them, according to the value of p%parms%coarse_mat,
! specified by the user through mld_zprecinit and mld_zprecset.
!
! 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.
! p - type(mld_z_onelev_type), input/output.
! The 'one-level' data structure that will contain the local
! part of the matrix to be built as well as the information
! concerning the prolongator and its transpose.
! ilaggr - integer, dimension(:), allocatable.
! The mapping between the row indices of the coarse-level
! matrix and the row indices of the fine-level matrix.
! ilaggr(i)=j means that node i in the adjacency graph
! of the fine-level matrix is mapped onto node j in the
! adjacency graph of the coarse-level matrix.
! nlaggr - integer, dimension(:), allocatable.
! nlaggr(i) contains the aggregates held by process i.
! info - integer, output.
! Error code.
!
subroutine mld_zaggrmat_biz_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_restr,info)
use psb_base_mod
use mld_z_inner_mod, mld_protect_name => mld_zaggrmat_biz_asb
implicit none
! Arguments
type(psb_zspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_a
integer, intent(inout) :: ilaggr(:), nlaggr(:)
type(mld_dml_parms), intent(inout) :: parms
type(psb_zspmat_type), intent(out) :: ac,op_prol,op_restr
integer, intent(out) :: info
! Local variables
integer :: nrow, nglob, ncol, ntaggr, ip, ndx,&
& naggr, nzl,naggrm1,naggrp1, i, j, k, jd, icolF, nrw
integer ::ictxt, np, me, err_act
character(len=20) :: name
type(psb_zspmat_type) :: am3, am4
type(psb_z_coo_sparse_mat) :: tmpcoo
type(psb_z_csr_sparse_mat) :: acsr1, acsr2, acsr3, acsrf, ptilde
complex(psb_dpk_), allocatable :: adiag(:)
integer(psb_ipk_) :: ierr(5)
logical :: filter_mat
integer :: debug_level, debug_unit
integer, parameter :: ncmax=16
real(psb_dpk_) :: anorm, omega, tmp, dg, theta
name='mld_aggrmat_biz_asb'
if(psb_get_errstatus().ne.0) return
info=psb_success_
call psb_erractionsave(err_act)
debug_unit = psb_get_debug_unit()
debug_level = psb_get_debug_level()
ictxt = desc_a%get_context()
ictxt = desc_a%get_context()
call psb_info(ictxt, me, np)
nglob = desc_a%get_global_rows()
nrow = desc_a%get_local_rows()
ncol = desc_a%get_local_cols()
theta = parms%aggr_thresh
naggr = nlaggr(me+1)
ntaggr = sum(nlaggr)
naggrm1 = sum(nlaggr(1:me))
naggrp1 = sum(nlaggr(1:me+1))
filter_mat = (parms%aggr_filter == mld_filter_mat_)
ilaggr(1:nrow) = ilaggr(1:nrow) + naggrm1
call psb_halo(ilaggr,desc_a,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_halo')
goto 9999
end if
! naggr: number of local aggregates
! nrow: local rows.
!
allocate(adiag(ncol),stat=info)
if (info /= psb_success_) then
info=psb_err_alloc_request_; ierr(1)=nrow;
call psb_errpush(info,name,i_err=ierr,a_err='complex(psb_dpk_)')
goto 9999
end if
! Get the diagonal D
call a%get_diag(adiag,info)
if (info == psb_success_) &
& call psb_halo(adiag,desc_a,info)
if(info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='sp_getdiag')
goto 9999
end if
! 1. Allocate Ptilde in sparse matrix form
call tmpcoo%allocate(ncol,naggr,ncol)
do i=1,nrow
tmpcoo%val(i) = zone
tmpcoo%ia(i) = i
tmpcoo%ja(i) = ilaggr(i)
end do
call tmpcoo%set_nzeros(nrow)
call tmpcoo%set_dupl(psb_dupl_add_)
call ptilde%mv_from_coo(tmpcoo,info)
if (info == psb_success_) call a%cscnv(acsr3,info,dupl=psb_dupl_add_)
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& ' Initial copies sone.'
if (filter_mat) then
!
! Build the filtered matrix Af from A
!
if (info == psb_success_) call a%cscnv(acsrf,info,dupl=psb_dupl_add_)
do i=1,nrow
tmp = zzero
jd = -1
do j=acsrf%irp(i),acsrf%irp(i+1)-1
if (acsrf%ja(j) == i) jd = j
if (abs(acsrf%val(j)) < theta*sqrt(abs(adiag(i)*adiag(acsrf%ja(j))))) then
tmp=tmp+acsrf%val(j)
acsrf%val(j)=zzero
endif
enddo
if (jd == -1) then
write(0,*) 'Wrong input: we need the diagonal!!!!', i
else
acsrf%val(jd)=acsrf%val(jd)-tmp
end if
enddo
! Take out zeroed terms
call acsrf%mv_to_coo(tmpcoo,info)
k = 0
do j=1,tmpcoo%get_nzeros()
if ((tmpcoo%val(j) /= zzero) .or. (tmpcoo%ia(j) == tmpcoo%ja(j))) then
k = k + 1
tmpcoo%val(k) = tmpcoo%val(j)
tmpcoo%ia(k) = tmpcoo%ia(j)
tmpcoo%ja(k) = tmpcoo%ja(j)
end if
end do
call tmpcoo%set_nzeros(k)
call tmpcoo%set_dupl(psb_dupl_add_)
call acsrf%mv_from_coo(tmpcoo,info)
end if
do i=1,size(adiag)
if (adiag(i) /= zzero) then
adiag(i) = zone / adiag(i)
else
adiag(i) = zone
end if
end do
if (filter_mat) call acsrf%scal(adiag,info)
if (info == psb_success_) call acsr3%scal(adiag,info)
if (info /= psb_success_) goto 9999
if (parms%aggr_omega_alg == mld_eig_est_) then
if (parms%aggr_eig == mld_max_norm_) then
!
! This only works with CSR
!
anorm = dzero
dg = done
nrw = acsr3%get_nrows()
do i=1, nrw
tmp = dzero
do j=acsr3%irp(i),acsr3%irp(i+1)-1
if (acsr3%ja(j) <= nrw) then
tmp = tmp + abs(acsr3%val(j))
endif
if (acsr3%ja(j) == i ) then
dg = abs(acsr3%val(j))
end if
end do
anorm = max(anorm,tmp/dg)
enddo
call psb_amx(ictxt,anorm)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,a_err='Invalid AM3 storage format')
goto 9999
end if
omega = 4.d0/(3.d0*anorm)
parms%aggr_omega_val = omega
else
info = psb_err_internal_error_
call psb_errpush(info,name,a_err='invalid mld_aggr_eig_')
goto 9999
end if
else if (parms%aggr_omega_alg == mld_user_choice_) then
omega = parms%aggr_omega_val
else if (parms%aggr_omega_alg /= mld_user_choice_) then
info = psb_err_internal_error_
call psb_errpush(info,name,a_err='invalid mld_aggr_omega_alg_')
goto 9999
end if
if (filter_mat) then
!
! Build the smoothed prolongator using the filtered matrix
!
do i=1,acsrf%get_nrows()
do j=acsrf%irp(i),acsrf%irp(i+1)-1
if (acsrf%ja(j) == i) then
acsrf%val(j) = zone - omega*acsrf%val(j)
else
acsrf%val(j) = - omega*acsrf%val(j)
end if
end do
end do
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'Done gather, going for SYMBMM 1'
!
! Symbmm90 does the allocation for its result.
!
! acsrm1 = (I-w*D*Af)Ptilde
! Doing it this way means to consider diag(Af_i)
!
!
call psb_symbmm(acsrf,ptilde,acsr1,info)
if(info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='symbmm 1')
goto 9999
end if
call psb_numbmm(acsrf,ptilde,acsr1)
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'Done NUMBMM 1'
else
!
! Build the smoothed prolongator using the original matrix
!
do i=1,acsr3%get_nrows()
do j=acsr3%irp(i),acsr3%irp(i+1)-1
if (acsr3%ja(j) == i) then
acsr3%val(j) = zone - omega*acsr3%val(j)
else
acsr3%val(j) = - omega*acsr3%val(j)
end if
end do
end do
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'Done gather, going for SYMBMM 1'
!
! Symbmm90 does the allocation for its result.
!
! acsrm1 = (I-w*D*A)Ptilde
! Doing it this way means to consider diag(A_i)
!
!
call psb_symbmm(acsr3,ptilde,acsr1,info)
if(info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='symbmm 1')
goto 9999
end if
call psb_numbmm(acsr3,ptilde,acsr1)
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'Done NUMBMM 1'
end if
call ptilde%free()
call acsr1%set_dupl(psb_dupl_add_)
call op_prol%mv_from(acsr1)
call psb_rwextd(ncol,op_prol,info)
if(info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,a_err='Halo of op_prol')
goto 9999
end if
call psb_symbmm(a,op_prol,am3,info)
if(info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='symbmm 2')
goto 9999
end if
call psb_numbmm(a,op_prol,am3)
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'Done NUMBMM 2',parms%aggr_kind, mld_smooth_prol_
call op_prol%transp(op_restr)
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'starting sphalo/ rwxtd'
call psb_rwextd(ncol,am3,info)
if(info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,a_err='Extend am3')
goto 9999
end if
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'starting symbmm 3'
call psb_symbmm(op_restr,am3,ac,info)
if (info == psb_success_) call psb_numbmm(op_restr,am3,ac)
if (info == psb_success_) call am3%free()
if (info == psb_success_) call ac%cscnv(info,type='coo',dupl=psb_dupl_add_)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,a_err='Build b = op_restr x am3')
goto 9999
end if
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'Done smooth_aggregate '
call psb_erractionrestore(err_act)
return
9999 continue
call psb_errpush(info,name)
call psb_erractionrestore(err_act)
if (err_act.eq.psb_act_abort_) then
call psb_error()
return
end if
return
end subroutine mld_zaggrmat_biz_asb

222
mlprec/impl/mld_zaggrmat_minnrg_asb.F90 → mlprec/impl/mld_zaggrmat_minnrg_asb.f90
Unescape Escape View File

@ -98,37 +98,31 @@
! info - integer, output. ! info - integer, output.
! Error code. ! Error code.
! !
subroutine mld_zaggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info) subroutine mld_zaggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_restr,info)
use psb_base_mod use psb_base_mod
use mld_z_inner_mod, mld_protect_name => mld_zaggrmat_minnrg_asb use mld_z_inner_mod, mld_protect_name => mld_zaggrmat_minnrg_asb
#ifdef MPI_MOD
use mpi
#endif
implicit none implicit none
#ifdef MPI_H
include 'mpif.h'
#endif
! Arguments ! Arguments
type(psb_zspmat_type), intent(in) :: a type(psb_zspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_a type(psb_desc_type), intent(in) :: desc_a
integer, intent(inout) :: ilaggr(:), nlaggr(:) integer, intent(inout) :: ilaggr(:), nlaggr(:)
type(mld_z_onelev_type), intent(inout), target :: p type(mld_dml_parms), intent(inout) :: parms
type(psb_zspmat_type), intent(out) :: ac,op_prol,op_restr
integer, intent(out) :: info integer, intent(out) :: info
! Local variables ! Local variables
type(psb_zspmat_type) :: b
integer(psb_mpik_), allocatable :: nzbr(:), idisp(:) integer(psb_mpik_), allocatable :: nzbr(:), idisp(:)
integer :: nrow, nglob, ncol, ntaggr, nzac, ip, ndx,& integer :: nrow, nglob, ncol, ntaggr, nzac, ip, ndx,&
& naggr, nzl,naggrm1,naggrp1, i, j, k, jd, icolF, nrt & naggr, nzl,naggrm1,naggrp1, i, j, k, jd, icolF, nrt
integer :: ictxt,np,me, err_act, icomm integer :: ictxt,np,me, err_act, icomm
character(len=20) :: name character(len=20) :: name
type(psb_zspmat_type) :: am1,am2, af, ptilde, rtilde, atran, atp, atdatp type(psb_zspmat_type) :: af, ptilde, rtilde, atran, atp, atdatp
type(psb_zspmat_type) :: am3,am4, ap, adap,atmp,rada, ra, atmp2, dap, dadap, da type(psb_zspmat_type) :: am3,am4, ap, adap,atmp,rada, ra, atmp2, dap, dadap, da
type(psb_zspmat_type) :: dat, datp, datdatp, atmp3 type(psb_zspmat_type) :: dat, datp, datdatp, atmp3
type(psb_z_coo_sparse_mat) :: acoo, acoof, bcoo, tmpcoo type(psb_z_coo_sparse_mat) :: tmpcoo
type(psb_z_csr_sparse_mat) :: acsr1, acsr2, acsr3, bcsr, acsr, acsrf type(psb_z_csr_sparse_mat) :: acsr1, acsr2, acsr3, acsr, acsrf
type(psb_z_csc_sparse_mat) :: csc_dap, csc_dadap, csc_datp, csc_datdatp, acsc type(psb_z_csc_sparse_mat) :: csc_dap, csc_dadap, csc_datp, csc_datdatp, acsc
complex(psb_dpk_), allocatable :: adiag(:), adinv(:) complex(psb_dpk_), allocatable :: adiag(:), adinv(:)
complex(psb_dpk_), allocatable :: omf(:), omp(:), omi(:), oden(:) complex(psb_dpk_), allocatable :: omf(:), omp(:), omi(:), oden(:)
@ -156,7 +150,7 @@ subroutine mld_zaggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info)
nrow = desc_a%get_local_rows() nrow = desc_a%get_local_rows()
ncol = desc_a%get_local_cols() ncol = desc_a%get_local_cols()
theta = p%parms%aggr_thresh theta = parms%aggr_thresh
naggr = nlaggr(me+1) naggr = nlaggr(me+1)
ntaggr = sum(nlaggr) ntaggr = sum(nlaggr)
@ -171,7 +165,7 @@ subroutine mld_zaggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info)
naggrm1 = sum(nlaggr(1:me)) naggrm1 = sum(nlaggr(1:me))
naggrp1 = sum(nlaggr(1:me+1)) naggrp1 = sum(nlaggr(1:me+1))
filter_mat = (p%parms%aggr_filter == mld_filter_mat_) filter_mat = (parms%aggr_filter == mld_filter_mat_)
ilaggr(1:nrow) = ilaggr(1:nrow) + naggrm1 ilaggr(1:nrow) = ilaggr(1:nrow) + naggrm1
call psb_halo(ilaggr,desc_a,info) call psb_halo(ilaggr,desc_a,info)
@ -213,16 +207,16 @@ subroutine mld_zaggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info)
! 1. Allocate Ptilde in sparse matrix form ! 1. Allocate Ptilde in sparse matrix form
call acoo%allocate(ncol,ntaggr,ncol) call tmpcoo%allocate(ncol,ntaggr,ncol)
do i=1,ncol do i=1,ncol
acoo%val(i) = zone tmpcoo%val(i) = zone
acoo%ia(i) = i tmpcoo%ia(i) = i
acoo%ja(i) = ilaggr(i) tmpcoo%ja(i) = ilaggr(i)
end do end do
call acoo%set_nzeros(ncol) call tmpcoo%set_nzeros(ncol)
call acoo%set_dupl(psb_dupl_add_) call tmpcoo%set_dupl(psb_dupl_add_)
call acoo%set_asb() call tmpcoo%set_asb()
call ptilde%mv_from(acoo) call ptilde%mv_from(tmpcoo)
call ptilde%cscnv(info,type='csr') call ptilde%cscnv(info,type='csr')
!!$ call local_dump(me,ptilde,'csr-ptilde','Ptilde-1') !!$ call local_dump(me,ptilde,'csr-ptilde','Ptilde-1')
@ -280,7 +274,7 @@ subroutine mld_zaggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info)
call am3%mv_to(acsr3) call am3%mv_to(acsr3)
! Compute omega_int ! Compute omega_int
ommx = cmplx(szero,szero) ommx = cmplx(dzero,dzero)
do i=1, ncol do i=1, ncol
omi(i) = omp(ilaggr(i)) omi(i) = omp(ilaggr(i))
if(abs(omi(i)) .gt. abs(ommx)) ommx = omi(i) if(abs(omi(i)) .gt. abs(ommx)) ommx = omi(i)
@ -354,17 +348,17 @@ subroutine mld_zaggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info)
! !
! Symbmm90 does the allocation for its result. ! Symbmm90 does the allocation for its result.
! !
! am1 = (I-w*D*Af)Ptilde ! op_prol = (I-w*D*Af)Ptilde
! Doing it this way means to consider diag(Af_i) ! Doing it this way means to consider diag(Af_i)
! !
! !
call psb_symbmm(af,ptilde,am1,info) call psb_symbmm(af,ptilde,op_prol,info)
if(info /= psb_success_) then if(info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='symbmm 1') call psb_errpush(psb_err_from_subroutine_,name,a_err='symbmm 1')
goto 9999 goto 9999
end if end if
call psb_numbmm(af,ptilde,am1) call psb_numbmm(af,ptilde,op_prol)
if (debug_level >= psb_debug_outer_) & if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),& & write(debug_unit,*) me,' ',trim(name),&
@ -390,16 +384,16 @@ subroutine mld_zaggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info)
! !
! Symbmm90 does the allocation for its result. ! Symbmm90 does the allocation for its result.
! !
! am1 = (I-w*D*A)Ptilde ! op_prol = (I-w*D*A)Ptilde
! !
! !
call psb_symbmm(am3,ptilde,am1,info) call psb_symbmm(am3,ptilde,op_prol,info)
if(info /= psb_success_) then if(info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='symbmm 1') call psb_errpush(psb_err_from_subroutine_,name,a_err='symbmm 1')
goto 9999 goto 9999
end if end if
call psb_numbmm(am3,ptilde,am1) call psb_numbmm(am3,ptilde,op_prol)
if (debug_level >= psb_debug_outer_) & if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),& & write(debug_unit,*) me,' ',trim(name),&
@ -458,7 +452,7 @@ subroutine mld_zaggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info)
omp = omp/oden omp = omp/oden
! !$ write(0,*) 'Check on output restrictor',omp(1:min(size(omp),10)) ! !$ write(0,*) 'Check on output restrictor',omp(1:min(size(omp),10))
! Compute omega_int ! Compute omega_int
ommx = cmplx(szero,szero) ommx = cmplx(dzero,dzero)
do i=1, ncol do i=1, ncol
omi(i) = omp(ilaggr(i)) omi(i) = omp(ilaggr(i))
if(abs(omi(i)) .gt. abs(ommx)) ommx = omi(i) if(abs(omi(i)) .gt. abs(ommx)) ommx = omi(i)
@ -509,20 +503,20 @@ subroutine mld_zaggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info)
call rtilde%mv_from(tmpcoo) call rtilde%mv_from(tmpcoo)
call rtilde%cscnv(info,type='csr') call rtilde%cscnv(info,type='csr')
call psb_symbmm(rtilde,atmp,am2,info) call psb_symbmm(rtilde,atmp,op_restr,info)
call psb_numbmm(rtilde,atmp,am2) call psb_numbmm(rtilde,atmp,op_restr)
! !
! Now we have to gather the halo of am1, and add it to itself ! Now we have to gather the halo of op_prol, and add it to itself
! to multiply it by A, ! to multiply it by A,
! !
call psb_sphalo(am1,desc_a,am4,info,& call psb_sphalo(op_prol,desc_a,am4,info,&
& colcnv=.false.,rowscale=.true.) & colcnv=.false.,rowscale=.true.)
if (info == psb_success_) call psb_rwextd(ncol,am1,info,b=am4) if (info == psb_success_) call psb_rwextd(ncol,op_prol,info,b=am4)
if (info == psb_success_) call am4%free() if (info == psb_success_) call am4%free()
if(info /= psb_success_) then if(info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,a_err='Halo of am1') call psb_errpush(psb_err_internal_error_,name,a_err='Halo of op_prol')
goto 9999 goto 9999
end if end if
@ -530,7 +524,7 @@ subroutine mld_zaggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info)
! Now we have to fix this. The only rows of B that are correct ! Now we have to fix this. The only rows of B that are correct
! are those corresponding to "local" aggregates, i.e. indices in ilaggr(:) ! are those corresponding to "local" aggregates, i.e. indices in ilaggr(:)
! !
call am2%mv_to(tmpcoo) call op_restr%mv_to(tmpcoo)
nzl = tmpcoo%get_nzeros() nzl = tmpcoo%get_nzeros()
i=0 i=0
@ -543,21 +537,21 @@ subroutine mld_zaggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info)
end if end if
end do end do
call tmpcoo%set_nzeros(i) call tmpcoo%set_nzeros(i)
call am2%mv_from(tmpcoo) call op_restr%mv_from(tmpcoo)
call am2%cscnv(info,type='csr') call op_restr%cscnv(info,type='csr')
if (debug_level >= psb_debug_outer_) & if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),& & write(debug_unit,*) me,' ',trim(name),&
& 'starting sphalo/ rwxtd' & 'starting sphalo/ rwxtd'
call psb_symbmm(a,am1,am3,info) call psb_symbmm(a,op_prol,am3,info)
if(info /= psb_success_) then if(info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,& call psb_errpush(psb_err_from_subroutine_,name,&
& a_err='symbmm 2') & a_err='symbmm 2')
goto 9999 goto 9999
end if end if
call psb_numbmm(a,am1,am3) call psb_numbmm(a,op_prol,am3)
if (debug_level >= psb_debug_outer_) & if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),& & write(debug_unit,*) me,' ',trim(name),&
& 'Done NUMBMM 2' & 'Done NUMBMM 2'
@ -576,156 +570,18 @@ subroutine mld_zaggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info)
& write(debug_unit,*) me,' ',trim(name),& & write(debug_unit,*) me,' ',trim(name),&
& 'Done sphalo/ rwxtd' & 'Done sphalo/ rwxtd'
call psb_symbmm(am2,am3,b,info) call psb_symbmm(op_restr,am3,ac,info)
if (info == psb_success_) call psb_numbmm(am2,am3,b) if (info == psb_success_) call psb_numbmm(op_restr,am3,ac)
if (info == psb_success_) call am3%free() if (info == psb_success_) call am3%free()
call b%mv_to(bcoo) if (info == psb_success_) call ac%cscnv(info,type='coo',dupl=psb_dupl_add_)
if (info /= psb_success_) then if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,& call psb_errpush(psb_err_internal_error_,name,&
&a_err='Build b = am2 x am3') &a_err='Build ac = op_restr x am3')
goto 9999 goto 9999
end if end if
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'Done mv_to_coo'
select case(p%parms%coarse_mat)
case(mld_distr_mat_)
nzl = bcoo%get_nzeros()
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& ' B matrix nzl: ',nzl
if (info == psb_success_) call psb_cdall(ictxt,p%desc_ac,info,nl=nlaggr(me+1))
if (info == psb_success_) call psb_cdins(nzl,bcoo%ia,bcoo%ja,p%desc_ac,info)
if (info == psb_success_) call psb_cdasb(p%desc_ac,info)
if (info == psb_success_) call psb_glob_to_loc(bcoo%ia(1:nzl),p%desc_ac,info,iact='I')
if (info == psb_success_) call psb_glob_to_loc(bcoo%ja(1:nzl),p%desc_ac,info,iact='I')
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Creating p%desc_ac and converting ac')
goto 9999
end if
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& ' Assembld aux descr. distr.'
call bcoo%set_nrows(p%desc_ac%get_local_rows())
call bcoo%set_ncols(p%desc_ac%get_local_cols())
call bcoo%fix(info)
call p%ac%mv_from(bcoo)
call p%ac%set_asb()
call p%ac%cscnv(info,type='csr')
if (np>1) then
call am1%mv_to(acsr)
nzl = acsr%get_nzeros()
call psb_glob_to_loc(acsr%ja(1:nzl),p%desc_ac,info,'I')
if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_glob_to_loc')
goto 9999
end if
call am1%mv_from(acsr)
endif
call am1%set_ncols(p%desc_ac%get_local_cols())
if (np>1) then
call am2%mv_to(tmpcoo)
nzl = tmpcoo%get_nzeros()
if (info == psb_success_) call psb_glob_to_loc(tmpcoo%ia(1:nzl),p%desc_ac,info,'I')
if(info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,a_err='Converting am2 to local')
goto 9999
end if
call am2%mv_from(tmpcoo)
call am2%cscnv(info,type='csr')
end if
call am2%set_nrows(p%desc_ac%get_local_cols())
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'Done ac '
case(mld_repl_mat_)
!
!
call psb_cdall(ictxt,p%desc_ac,info,mg=ntaggr,repl=.true.)
nzbr(:) = 0
nzbr(me+1) = bcoo%get_nzeros()
call psb_sum(ictxt,nzbr(1:np))
nzac = sum(nzbr)
if (info == psb_success_) call tmpcoo%allocate(ntaggr,ntaggr,nzac)
if (info /= psb_success_) goto 9999
do ip=1,np
idisp(ip) = sum(nzbr(1:ip-1))
enddo
ndx = nzbr(me+1)
call mpi_allgatherv(bcoo%val,ndx,mpi_double_complex,tmpcoo%val,nzbr,idisp,&
& mpi_double_complex,icomm,info)
if (info == psb_success_)&
& call mpi_allgatherv(bcoo%ia,ndx,psb_mpi_ipk_integer,tmpcoo%ia,nzbr,idisp,&
& psb_mpi_ipk_integer,icomm,info)
if (info == psb_success_)&
& call mpi_allgatherv(bcoo%ja,ndx,psb_mpi_ipk_integer,tmpcoo%ja,nzbr,idisp,&
& psb_mpi_ipk_integer,icomm,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err=' from mpi_allgatherv')
goto 9999
end if
call bcoo%free()
call tmpcoo%fix(info)
call p%ac%mv_from(tmpcoo)
call p%ac%cscnv(info,type='csr')
if(info /= psb_success_) goto 9999
deallocate(nzbr,idisp,stat=info)
if (info /= psb_success_) then
info = psb_err_alloc_dealloc_
call psb_errpush(info,name)
goto 9999
end if
case default
info = psb_err_internal_error_
call psb_errpush(info,name,a_err='invalid mld_coarse_mat_')
goto 9999
end select
call p%ac%cscnv(info,type='csr')
if(info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='spcnv')
goto 9999
end if
!
! Copy the prolongation/restriction matrices into the descriptor map.
! am2 => R i.e. restriction operator
! am1 => P i.e. prolongation operator
!
p%map = psb_linmap(psb_map_aggr_,desc_a,&
& p%desc_ac,am2,am1,ilaggr,nlaggr)
if (info == psb_success_) call am1%free()
if (info == psb_success_) call am2%free()
if(info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='sp_Free')
goto 9999
end if
if (debug_level >= psb_debug_outer_) & if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),& & write(debug_unit,*) me,' ',trim(name),&

163
mlprec/impl/mld_zaggrmat_nosmth_asb.F90 → mlprec/impl/mld_zaggrmat_nosmth_asb.f90
Unescape Escape View File

@ -81,35 +81,29 @@
! info - integer, output. ! info - integer, output.
! Error code. ! Error code.
! !
subroutine mld_zaggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,p,info) subroutine mld_zaggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_restr,info)
use psb_base_mod use psb_base_mod
use mld_z_inner_mod, mld_protect_name => mld_zaggrmat_nosmth_asb use mld_z_inner_mod, mld_protect_name => mld_zaggrmat_nosmth_asb
#ifdef MPI_MOD
use mpi
#endif
implicit none implicit none
#ifdef MPI_H
include 'mpif.h'
#endif
! Arguments ! Arguments
type(psb_zspmat_type), intent(in) :: a type(psb_zspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_a type(psb_desc_type), intent(in) :: desc_a
integer, intent(inout) :: ilaggr(:), nlaggr(:) integer, intent(inout) :: ilaggr(:), nlaggr(:)
type(mld_z_onelev_type), intent(inout), target :: p type(mld_dml_parms), intent(inout) :: parms
type(psb_zspmat_type), intent(out) :: ac,op_prol,op_restr
integer, intent(out) :: info integer, intent(out) :: info
! Local variables ! Local variables
integer :: ictxt,np,me, err_act integer :: ictxt,np,me, err_act
integer(psb_mpik_) :: icomm, ndx, minfo integer(psb_mpik_) :: icomm, ndx, minfo
character(len=20) :: name character(len=20) :: name
type(psb_zspmat_type) :: b
integer(psb_mpik_), allocatable :: nzbr(:), idisp(:)
integer(psb_ipk_) :: ierr(5) integer(psb_ipk_) :: ierr(5)
type(psb_zspmat_type) :: am1,am2 type(psb_z_coo_sparse_mat) :: ac_coo, acoo
type(psb_z_coo_sparse_mat) :: acoo1, acoo2, bcoo, ac_coo type(psb_z_csr_sparse_mat) :: acsr1, acsr2
integer :: nrow, nglob, ncol, ntaggr, nzac, ip, & integer :: debug_level, debug_unit
integer :: nrow, nglob, ncol, ntaggr, nzl, ip, &
& naggr, nzt, naggrm1, i & naggr, nzt, naggrm1, i
name='mld_aggrmat_nosmth_asb' name='mld_aggrmat_nosmth_asb'
@ -128,141 +122,48 @@ subroutine mld_zaggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,p,info)
naggr = nlaggr(me+1) naggr = nlaggr(me+1)
ntaggr = sum(nlaggr) ntaggr = sum(nlaggr)
allocate(nzbr(np), idisp(np),stat=info)
if (info /= psb_success_) then
info=psb_err_alloc_request_; ierr(1)=2*np;
call psb_errpush(info,name,i_err=ierr,a_err='integer')
goto 9999
end if
naggrm1=sum(nlaggr(1:me)) naggrm1=sum(nlaggr(1:me))
if (p%parms%coarse_mat == mld_repl_mat_) then do i=1, nrow
do i=1, nrow ilaggr(i) = ilaggr(i) + naggrm1
ilaggr(i) = ilaggr(i) + naggrm1 end do
end do call psb_halo(ilaggr,desc_a,info)
call psb_halo(ilaggr,desc_a,info)
end if
if(info /= psb_success_) then if(info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_halo') call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_halo')
goto 9999 goto 9999
end if end if
if (p%parms%coarse_mat == mld_repl_mat_) then call acoo%allocate(ncol,ntaggr,ncol)
call acoo1%allocate(ncol,ntaggr,ncol)
else
call acoo1%allocate(ncol,naggr,ncol)
end if
do i=1,nrow do i=1,nrow
acoo1%val(i) = zone acoo%val(i) = zone
acoo1%ia(i) = i acoo%ia(i) = i
acoo1%ja(i) = ilaggr(i) acoo%ja(i) = ilaggr(i)
end do end do
call acoo1%set_dupl(psb_dupl_add_) call acoo%set_dupl(psb_dupl_add_)
call acoo1%set_nzeros(nrow) call acoo%set_nzeros(nrow)
call acoo1%set_asb() call acoo%set_asb()
call acoo1%fix(info) call acoo%fix(info)
call acoo1%transp(acoo2)
call a%csclip(bcoo,info,jmax=nrow) call op_prol%mv_from(acoo)
call op_prol%cscnv(info,type='csr',dupl=psb_dupl_add_)
if (info == psb_success_) call op_prol%transp(op_restr)
call a%csclip(ac_coo,info,jmax=nrow)
nzt = bcoo%get_nzeros() nzt = ac_coo%get_nzeros()
do i=1, nzt do i=1, nzt
bcoo%ia(i) = ilaggr(bcoo%ia(i)) ac_coo%ia(i) = ilaggr(ac_coo%ia(i))
bcoo%ja(i) = ilaggr(bcoo%ja(i)) ac_coo%ja(i) = ilaggr(ac_coo%ja(i))
enddo enddo
call bcoo%set_nrows(naggr) call ac_coo%set_nrows(naggr)
call bcoo%set_ncols(naggr) call ac_coo%set_ncols(naggr)
call bcoo%set_dupl(psb_dupl_add_) call ac_coo%set_dupl(psb_dupl_add_)
call bcoo%fix(info) call ac_coo%fix(info)
call ac%mv_from(ac_coo)
if (p%parms%coarse_mat == mld_repl_mat_) then
call psb_cdall(ictxt,p%desc_ac,info,mg=ntaggr,repl=.true.)
if (info == psb_success_) call psb_cdasb(p%desc_ac,info)
if(info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_cdall')
goto 9999
end if
nzbr(:) = 0
nzbr(me+1) = nzt
call psb_sum(ictxt,nzbr(1:np))
nzac = sum(nzbr)
call ac_coo%allocate(ntaggr,ntaggr,nzac)
do ip=1,np
idisp(ip) = sum(nzbr(1:ip-1))
enddo
ndx = nzbr(me+1)
call mpi_allgatherv(bcoo%val,ndx,mpi_double_complex,ac_coo%val,nzbr,idisp,&
& mpi_double_complex,icomm,minfo)
call mpi_allgatherv(bcoo%ia,ndx,psb_mpi_ipk_integer,ac_coo%ia,nzbr,idisp,&
& psb_mpi_ipk_integer,icomm,minfo)
call mpi_allgatherv(bcoo%ja,ndx,psb_mpi_ipk_integer,ac_coo%ja,nzbr,idisp,&
& psb_mpi_ipk_integer,icomm,minfo)
if(info /= psb_success_) then
info=-1
call psb_errpush(info,name)
goto 9999
end if
call ac_coo%set_nzeros(nzac)
call ac_coo%set_dupl(psb_dupl_add_)
call ac_coo%fix(info)
call p%ac%mv_from(ac_coo)
else if (p%parms%coarse_mat == mld_distr_mat_) then
call psb_cdall(ictxt,p%desc_ac,info,nl=naggr)
if (info == psb_success_) call psb_cdasb(p%desc_ac,info)
call p%ac%mv_from(bcoo)
if(info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,a_err='Build ac, desc_ac')
goto 9999
end if
else
info = psb_err_internal_error_
call psb_errpush(psb_err_internal_error_,name,a_err='invalid mld_coarse_mat_')
goto 9999
end if
call bcoo%free()
deallocate(nzbr,idisp)
call p%ac%cscnv(info,type='csr',dupl=psb_dupl_add_)
if(info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='cscnv')
goto 9999
end if
call am1%mv_from(acoo1)
call am1%cscnv(info,type='csr',dupl=psb_dupl_add_)
if (info == psb_success_) call am2%mv_from(acoo2)
if (info == psb_success_) call am2%cscnv(info,type='csr',dupl=psb_dupl_add_)
!
! Copy the prolongation/restriction matrices into the descriptor map.
! am2 => PR^T i.e. restriction operator
! am1 => PR i.e. prolongation operator
!
if (info == psb_success_) &
& p%map = psb_linmap(psb_map_aggr_,desc_a,&
& p%desc_ac,am2,am1,ilaggr,nlaggr)
if (info == psb_success_) call am1%free()
if (info == psb_success_) call am2%free()
if(info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='linmap build')
goto 9999
end if
call psb_erractionrestore(err_act) call psb_erractionrestore(err_act)

421
mlprec/impl/mld_zaggrmat_smth_asb.F90 → mlprec/impl/mld_zaggrmat_smth_asb.f90
Unescape Escape View File

@ -61,11 +61,6 @@
! according to the value of p%parms%aggr_omega_alg, specified by the user ! according to the value of p%parms%aggr_omega_alg, specified by the user
! through mld_zprecinit and mld_zprecset. ! through mld_zprecinit and mld_zprecset.
! !
! This routine can also build A_C according to a "bizarre" aggregation algorithm,
! using a "naive" prolongator proposed by the authors of MLD2P4. However, this
! prolongator still requires a deep analysis and testing and its use is not
! recommended.
!
! The coarse-level matrix A_C is distributed among the parallel processes or ! The coarse-level matrix A_C is distributed among the parallel processes or
! replicated on each of them, according to the value of p%parms%coarse_mat, ! replicated on each of them, according to the value of p%parms%coarse_mat,
! specified by the user through mld_zprecinit and mld_zprecset. ! specified by the user through mld_zprecinit and mld_zprecset.
@ -98,38 +93,31 @@
! info - integer, output. ! info - integer, output.
! Error code. ! Error code.
! !
subroutine mld_zaggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info) subroutine mld_zaggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_restr,info)
use psb_base_mod use psb_base_mod
use mld_z_inner_mod, mld_protect_name => mld_zaggrmat_smth_asb use mld_z_inner_mod, mld_protect_name => mld_zaggrmat_smth_asb
#ifdef MPI_MOD
use mpi
#endif
implicit none implicit none
#ifdef MPI_H
include 'mpif.h'
#endif
! Arguments ! Arguments
type(psb_zspmat_type), intent(in) :: a type(psb_zspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_a type(psb_desc_type), intent(in) :: desc_a
integer, intent(inout) :: ilaggr(:), nlaggr(:) integer, intent(inout) :: ilaggr(:), nlaggr(:)
type(mld_z_onelev_type), intent(inout), target :: p type(mld_dml_parms), intent(inout) :: parms
type(psb_zspmat_type), intent(out) :: ac,op_prol,op_restr
integer, intent(out) :: info integer, intent(out) :: info
! Local variables ! Local variables
type(psb_zspmat_type) :: b integer :: nrow, nglob, ncol, ntaggr, ip, ndx,&
integer, allocatable :: nzbr(:), idisp(:)
integer :: nrow, nglob, ncol, ntaggr, nzac, ip, ndx,&
& naggr, nzl,naggrm1,naggrp1, i, j, k, jd, icolF, nrw & naggr, nzl,naggrm1,naggrp1, i, j, k, jd, icolF, nrw
integer ::ictxt, np, me, err_act integer ::ictxt, np, me, err_act
character(len=20) :: name character(len=20) :: name
type(psb_zspmat_type) :: am1,am2, am3, am4 type(psb_zspmat_type) :: am3, am4
type(psb_z_coo_sparse_mat) :: acoo, acoof, bcoo type(psb_z_coo_sparse_mat) :: tmpcoo
type(psb_z_csr_sparse_mat) :: acsr1, acsr2, acsr3, acsrf, ptilde type(psb_z_csr_sparse_mat) :: acsr1, acsr2, acsr3, acsrf, ptilde
complex(psb_dpk_), allocatable :: adiag(:) complex(psb_dpk_), allocatable :: adiag(:)
integer(psb_ipk_) :: ierr(5) integer(psb_ipk_) :: ierr(5)
logical :: ml_global_nmb, filter_mat logical :: filter_mat
integer :: debug_level, debug_unit integer :: debug_level, debug_unit
integer, parameter :: ncmax=16 integer, parameter :: ncmax=16
real(psb_dpk_) :: anorm, omega, tmp, dg, theta real(psb_dpk_) :: anorm, omega, tmp, dg, theta
@ -150,34 +138,21 @@ subroutine mld_zaggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info)
nrow = desc_a%get_local_rows() nrow = desc_a%get_local_rows()
ncol = desc_a%get_local_cols() ncol = desc_a%get_local_cols()
theta = p%parms%aggr_thresh theta = parms%aggr_thresh
naggr = nlaggr(me+1) naggr = nlaggr(me+1)
ntaggr = sum(nlaggr) ntaggr = sum(nlaggr)
allocate(nzbr(np), idisp(np),stat=info)
if (info /= psb_success_) then
info=psb_err_alloc_request_; ierr(1)=2*np;
call psb_errpush(info,name,i_err=ierr,a_err='integer')
goto 9999
end if
naggrm1 = sum(nlaggr(1:me)) naggrm1 = sum(nlaggr(1:me))
naggrp1 = sum(nlaggr(1:me+1)) naggrp1 = sum(nlaggr(1:me+1))
ml_global_nmb = ( (p%parms%aggr_kind == mld_smooth_prol_).or.& filter_mat = (parms%aggr_filter == mld_filter_mat_)
& ( (p%parms%aggr_kind == mld_biz_prol_).and.&
& (p%parms%coarse_mat == mld_repl_mat_)) )
filter_mat = (p%parms%aggr_filter == mld_filter_mat_)
if (ml_global_nmb) then ilaggr(1:nrow) = ilaggr(1:nrow) + naggrm1
ilaggr(1:nrow) = ilaggr(1:nrow) + naggrm1 call psb_halo(ilaggr,desc_a,info)
call psb_halo(ilaggr,desc_a,info)
if (info /= psb_success_) then if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_halo') call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_halo')
goto 9999 goto 9999
end if
end if end if
! naggr: number of local aggregates ! naggr: number of local aggregates
@ -202,32 +177,22 @@ subroutine mld_zaggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info)
end if end if
! 1. Allocate Ptilde in sparse matrix form ! 1. Allocate Ptilde in sparse matrix form
if (ml_global_nmb) then call tmpcoo%allocate(ncol,ntaggr,ncol)
call acoo%allocate(ncol,ntaggr,ncol) do i=1,ncol
do i=1,ncol tmpcoo%val(i) = zone
acoo%val(i) = zone tmpcoo%ia(i) = i
acoo%ia(i) = i tmpcoo%ja(i) = ilaggr(i)
acoo%ja(i) = ilaggr(i) end do
end do call tmpcoo%set_nzeros(ncol)
call acoo%set_nzeros(ncol) call tmpcoo%set_dupl(psb_dupl_add_)
else
call acoo%allocate(ncol,naggr,ncol) call ptilde%mv_from_coo(tmpcoo,info)
do i=1,nrow
acoo%val(i) = zone
acoo%ia(i) = i
acoo%ja(i) = ilaggr(i)
end do
call acoo%set_nzeros(nrow)
endif
call acoo%set_dupl(psb_dupl_add_)
call ptilde%mv_from_coo(acoo,info)
if (info == psb_success_) call a%cscnv(acsr3,info,dupl=psb_dupl_add_) if (info == psb_success_) call a%cscnv(acsr3,info,dupl=psb_dupl_add_)
if (debug_level >= psb_debug_outer_) & if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),& & write(debug_unit,*) me,' ',trim(name),&
& ' Initial copies sone.' & ' Initial copies sone.'
if (filter_mat) then if (filter_mat) then
! !
! Build the filtered matrix Af from A ! Build the filtered matrix Af from A
@ -252,19 +217,19 @@ subroutine mld_zaggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info)
end if end if
enddo enddo
! Take out zeroed terms ! Take out zeroed terms
call acsrf%mv_to_coo(acoof,info) call acsrf%mv_to_coo(tmpcoo,info)
k = 0 k = 0
do j=1,acoof%get_nzeros() do j=1,tmpcoo%get_nzeros()
if ((acoof%val(j) /= zzero) .or. (acoof%ia(j) == acoof%ja(j))) then if ((tmpcoo%val(j) /= zzero) .or. (tmpcoo%ia(j) == tmpcoo%ja(j))) then
k = k + 1 k = k + 1
acoof%val(k) = acoof%val(j) tmpcoo%val(k) = tmpcoo%val(j)
acoof%ia(k) = acoof%ia(j) tmpcoo%ia(k) = tmpcoo%ia(j)
acoof%ja(k) = acoof%ja(j) tmpcoo%ja(k) = tmpcoo%ja(j)
end if end if
end do end do
call acoof%set_nzeros(k) call tmpcoo%set_nzeros(k)
call acoof%set_dupl(psb_dupl_add_) call tmpcoo%set_dupl(psb_dupl_add_)
call acsrf%mv_from_coo(acoof,info) call acsrf%mv_from_coo(tmpcoo,info)
end if end if
@ -281,41 +246,13 @@ subroutine mld_zaggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info)
if (info /= psb_success_) goto 9999 if (info /= psb_success_) goto 9999
if (p%parms%aggr_omega_alg == mld_eig_est_) then if (parms%aggr_omega_alg == mld_eig_est_) then
if (p%parms%aggr_eig == mld_max_norm_) then if (parms%aggr_eig == mld_max_norm_) then
if (p%parms%aggr_kind == mld_biz_prol_) then anorm = acsr3%csnmi()
!
! This only works with CSR
!
anorm = dzero
dg = done
nrw = acsr3%get_nrows()
do i=1, nrw
tmp = szero
do j=acsr3%irp(i),acsr3%irp(i+1)-1
if (acsr3%ja(j) <= nrw) then
tmp = tmp + abs(acsr3%val(j))
endif
if (acsr3%ja(j) == i ) then
dg = abs(acsr3%val(j))
end if
end do
anorm = max(anorm,tmp/dg)
enddo
call psb_amx(ictxt,anorm)
else
anorm = acsr3%csnmi()
endif
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,a_err='Invalid AM3 storage format')
goto 9999
end if
omega = 4.d0/(3.d0*anorm) omega = 4.d0/(3.d0*anorm)
p%parms%aggr_omega_val = omega parms%aggr_omega_val = omega
else else
info = psb_err_internal_error_ info = psb_err_internal_error_
@ -323,11 +260,11 @@ subroutine mld_zaggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info)
goto 9999 goto 9999
end if end if
else if (p%parms%aggr_omega_alg == mld_user_choice_) then else if (parms%aggr_omega_alg == mld_user_choice_) then
omega = p%parms%aggr_omega_val omega = parms%aggr_omega_val
else if (p%parms%aggr_omega_alg /= mld_user_choice_) then else if (parms%aggr_omega_alg /= mld_user_choice_) then
info = psb_err_internal_error_ info = psb_err_internal_error_
call psb_errpush(info,name,a_err='invalid mld_aggr_omega_alg_') call psb_errpush(info,name,a_err='invalid mld_aggr_omega_alg_')
goto 9999 goto 9999
@ -368,7 +305,7 @@ subroutine mld_zaggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info)
if (debug_level >= psb_debug_outer_) & if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),& & write(debug_unit,*) me,' ',trim(name),&
& 'Done NUMBMM 1' & 'Done NUMBMM 1'
else else
! !
! Build the smoothed prolongator using the original matrix ! Build the smoothed prolongator using the original matrix
@ -409,76 +346,64 @@ subroutine mld_zaggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info)
call ptilde%free() call ptilde%free()
call acsr1%set_dupl(psb_dupl_add_) call acsr1%set_dupl(psb_dupl_add_)
call am1%mv_from(acsr1) call op_prol%mv_from(acsr1)
if (ml_global_nmb) then !
! ! Now we have to gather the halo of op_prol, and add it to itself
! Now we have to gather the halo of am1, and add it to itself ! to multiply it by A,
! to multiply it by A, !
! call psb_sphalo(op_prol,desc_a,am4,info,&
call psb_sphalo(am1,desc_a,am4,info,& & colcnv=.false.,rowscale=.true.)
& colcnv=.false.,rowscale=.true.) if (info == psb_success_) call psb_rwextd(ncol,op_prol,info,b=am4)
if (info == psb_success_) call psb_rwextd(ncol,am1,info,b=am4) if (info == psb_success_) call am4%free()
if (info == psb_success_) call am4%free()
else
call psb_rwextd(ncol,am1,info)
endif
if(info /= psb_success_) then if(info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,a_err='Halo of am1') call psb_errpush(psb_err_internal_error_,name,a_err='Halo of op_prol')
goto 9999 goto 9999
end if end if
call psb_symbmm(a,am1,am3,info) call psb_symbmm(a,op_prol,am3,info)
if(info /= psb_success_) then if(info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='symbmm 2') call psb_errpush(psb_err_from_subroutine_,name,a_err='symbmm 2')
goto 9999 goto 9999
end if end if
call psb_numbmm(a,am1,am3) call psb_numbmm(a,op_prol,am3)
if (debug_level >= psb_debug_outer_) & if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),& & write(debug_unit,*) me,' ',trim(name),&
& 'Done NUMBMM 2',p%parms%aggr_kind, mld_smooth_prol_ & 'Done NUMBMM 2',parms%aggr_kind, mld_smooth_prol_
if (p%parms%aggr_kind == mld_smooth_prol_) then call op_prol%transp(op_restr)
call am1%transp(am2) call op_restr%mv_to(tmpcoo)
call am2%mv_to(acoo) nzl = tmpcoo%get_nzeros()
nzl = acoo%get_nzeros() i=0
i=0 !
! ! Now we have to fix this. The only rows of B that are correct
! Now we have to fix this. The only rows of B that are correct ! are those corresponding to "local" aggregates, i.e. indices in ilaggr(:)
! are those corresponding to "local" aggregates, i.e. indices in ilaggr(:) !
! do k=1, nzl
do k=1, nzl if ((naggrm1 < tmpcoo%ia(k)) .and.(tmpcoo%ia(k) <= naggrp1)) then
if ((naggrm1 < acoo%ia(k)) .and.(acoo%ia(k) <= naggrp1)) then i = i+1
i = i+1 tmpcoo%val(i) = tmpcoo%val(k)
acoo%val(i) = acoo%val(k) tmpcoo%ia(i) = tmpcoo%ia(k)
acoo%ia(i) = acoo%ia(k) tmpcoo%ja(i) = tmpcoo%ja(k)
acoo%ja(i) = acoo%ja(k)
end if
end do
call acoo%set_nzeros(i)
call acoo%trim()
call am2%mv_from(acoo)
call am2%cscnv(info,type='csr',dupl=psb_dupl_add_)
if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='spcnv am2')
goto 9999
end if end if
else end do
call am1%transp(am2) call tmpcoo%set_nzeros(i)
endif call tmpcoo%trim()
call op_restr%mv_from(tmpcoo)
call op_restr%cscnv(info,type='csr',dupl=psb_dupl_add_)
if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='spcnv op_restr')
goto 9999
end if
if (debug_level >= psb_debug_outer_) & if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),& & write(debug_unit,*) me,' ',trim(name),&
& 'starting sphalo/ rwxtd' & 'starting sphalo/ rwxtd'
if (p%parms%aggr_kind == mld_smooth_prol_) then ! op_restr = ((i-wDA)Ptilde)^T
! am2 = ((i-wDA)Ptilde)^T call psb_sphalo(am3,desc_a,am4,info,&
call psb_sphalo(am3,desc_a,am4,info,& & colcnv=.false.,rowscale=.true.)
& colcnv=.false.,rowscale=.true.) if (info == psb_success_) call psb_rwextd(ncol,am3,info,b=am4)
if (info == psb_success_) call psb_rwextd(ncol,am3,info,b=am4) if (info == psb_success_) call am4%free()
if (info == psb_success_) call am4%free()
else if (p%parms%aggr_kind == mld_biz_prol_) then
call psb_rwextd(ncol,am3,info)
endif
if(info /= psb_success_) then if(info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,a_err='Extend am3') call psb_errpush(psb_err_internal_error_,name,a_err='Extend am3')
goto 9999 goto 9999
@ -488,180 +413,12 @@ subroutine mld_zaggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info)
if (debug_level >= psb_debug_outer_) & if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),& & write(debug_unit,*) me,' ',trim(name),&
& 'starting symbmm 3' & 'starting symbmm 3'
call psb_symbmm(am2,am3,b,info) call psb_symbmm(op_restr,am3,ac,info)
if (info == psb_success_) call psb_numbmm(am2,am3,b) if (info == psb_success_) call psb_numbmm(op_restr,am3,ac)
if (info == psb_success_) call am3%free() if (info == psb_success_) call am3%free()
if (info == psb_success_) call b%cscnv(info,type='coo',dupl=psb_dupl_add_) if (info == psb_success_) call ac%cscnv(info,type='coo',dupl=psb_dupl_add_)
if (info /= psb_success_) then if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,a_err='Build b = am2 x am3') call psb_errpush(psb_err_internal_error_,name,a_err='Build ac = op_restr x am3')
goto 9999
end if
select case(p%parms%aggr_kind)
case(mld_smooth_prol_)
select case(p%parms%coarse_mat)
case(mld_distr_mat_)
nzac = b%get_nzeros()
nzl = nzac
call b%mv_to(bcoo)
if (info == psb_success_) call psb_cdall(ictxt,p%desc_ac,info,nl=nlaggr(me+1))
if (info == psb_success_) call psb_cdins(nzl,bcoo%ia,bcoo%ja,p%desc_ac,info)
if (info == psb_success_) call psb_cdasb(p%desc_ac,info)
if (info == psb_success_) call psb_glob_to_loc(bcoo%ia(1:nzl),p%desc_ac,info,iact='I')
if (info == psb_success_) call psb_glob_to_loc(bcoo%ja(1:nzl),p%desc_ac,info,iact='I')
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,&
& a_err='Creating p%desc_ac and converting ac')
goto 9999
end if
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'Assembld aux descr. distr.'
call p%ac%mv_from(bcoo)
call p%ac%set_nrows(p%desc_ac%get_local_rows())
call p%ac%set_ncols(p%desc_ac%get_local_cols())
call p%ac%set_asb()
if (info == psb_success_) deallocate(nzbr,idisp,stat=info)
if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_sp_free')
goto 9999
end if
if (np>1) then
call am1%mv_to(acsr1)
nzl = acsr1%get_nzeros()
call psb_glob_to_loc(acsr1%ja(1:nzl),p%desc_ac,info,'I')
if(info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_glob_to_loc')
goto 9999
end if
call am1%mv_from(acsr1)
endif
call am1%set_ncols(p%desc_ac%get_local_cols())
if (np>1) then
call am2%cscnv(info,type='coo',dupl=psb_dupl_add_)
call am2%mv_to(acoo)
nzl = acoo%get_nzeros()
if (info == psb_success_) call psb_glob_to_loc(acoo%ia(1:nzl),p%desc_ac,info,'I')
call acoo%set_dupl(psb_dupl_add_)
if (info == psb_success_) call am2%mv_from(acoo)
if (info == psb_success_) call am2%cscnv(info,type='csr')
if(info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,a_err='Converting am2 to local')
goto 9999
end if
end if
call am2%set_nrows(p%desc_ac%get_local_cols())
if (debug_level >= psb_debug_outer_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'Done ac '
case(mld_repl_mat_)
!
!
call psb_cdall(ictxt,p%desc_ac,info,mg=ntaggr,repl=.true.)
if (info == psb_success_) call psb_cdasb(p%desc_ac,info)
if (info == psb_success_) &
& call psb_gather(p%ac,b,p%desc_ac,info,dupl=psb_dupl_add_,keeploc=.false.)
if (info /= psb_success_) goto 9999
deallocate(nzbr,idisp,stat=info)
if (info /= psb_success_) then
info = psb_err_alloc_dealloc_
call psb_errpush(info,name)
goto 9999
end if
case default
info = psb_err_internal_error_
call psb_errpush(info,name,a_err='invalid mld_coarse_mat_')
goto 9999
end select
case(mld_biz_prol_)
select case(p%parms%coarse_mat)
case(mld_distr_mat_)
call psb_move_alloc(b,p%ac,info)
if (info == psb_success_) call psb_cdall(ictxt,p%desc_ac,info,nl=naggr)
if (info == psb_success_) call psb_cdasb(p%desc_ac,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='Build desc_ac, ac')
goto 9999
end if
case(mld_repl_mat_)
!
!
call psb_cdall(ictxt,p%desc_ac,info,mg=ntaggr,repl=.true.)
if (info == psb_success_) call psb_cdasb(p%desc_ac,info)
if(info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_cdall')
goto 9999
end if
call psb_gather(p%ac,b,p%desc_ac,info,dupl=psb_dupl_add_,keeploc=.false.)
if(info /= psb_success_) goto 9999
deallocate(nzbr,idisp,stat=info)
if (info /= psb_success_) then
info = psb_err_alloc_dealloc_
call psb_errpush(info,name)
goto 9999
end if
case default
info = psb_err_internal_error_
call psb_errpush(info,name,a_err='invalid mld_coarse_mat_')
goto 9999
end select
deallocate(nzbr,idisp,stat=info)
if (info /= psb_success_) then
info = psb_err_alloc_dealloc_
call psb_errpush(info,name)
goto 9999
end if
case default
info = psb_err_internal_error_
call psb_errpush(info,name,a_err='invalid mld_smooth_prol_')
goto 9999
end select
call p%ac%cscnv(info,type='csr',dupl=psb_dupl_add_)
if(info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='spcnv')
goto 9999
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 = psb_linmap(psb_map_aggr_,desc_a,&
& p%desc_ac,am2,am1,ilaggr,nlaggr)
if (info == psb_success_) call am1%free()
if (info == psb_success_) call am2%free()
if(info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='sp_Free')
goto 9999 goto 9999
end if end if

267
mlprec/impl/mld_zmlprec_bld.f90
Unescape Escape View File

@ -93,11 +93,13 @@ subroutine mld_zmlprec_bld(a,desc_a,p,info,amold,vmold)
! Local Variables ! Local Variables
type(mld_zprec_type) :: t_prec type(mld_zprec_type) :: t_prec
Integer :: err,i,k,ictxt, me,np, err_act, iszv, newsz Integer :: err,i,k,ictxt, me,np, err_act, iszv, newsz, casize
integer :: ipv(mld_ifpsz_), val integer :: ipv(mld_ifpsz_), val
integer :: int_err(5) integer :: int_err(5)
character :: upd_ character :: upd_
type(mld_dml_parms) :: prm class(mld_z_base_smoother_type), allocatable :: coarse_sm, base_sm, med_sm
type(mld_dml_parms) :: baseparms, medparms, coarseparms
type(mld_z_onelev_node), pointer :: head, tail, newnode, current
integer :: debug_level, debug_unit integer :: debug_level, debug_unit
character(len=20) :: name, ch_err character(len=20) :: name, ch_err
@ -145,12 +147,22 @@ subroutine mld_zmlprec_bld(a,desc_a,p,info,amold,vmold)
! Check to ensure all procs have the same ! Check to ensure all procs have the same
! !
newsz = -1 newsz = -1
casize = p%coarse_aggr_size
iszv = size(p%precv) iszv = size(p%precv)
call psb_bcast(ictxt,iszv) call psb_bcast(ictxt,iszv)
if (iszv /= size(p%precv)) then call psb_bcast(ictxt,casize)
info=psb_err_internal_error_ if (casize > 0) then
call psb_errpush(info,name,a_err='Inconsistent size of precv') if (casize /= p%coarse_aggr_size) then
goto 9999 info=psb_err_internal_error_
call psb_errpush(info,name,a_err='Inconsistent coarse_aggr_size')
goto 9999
end if
else
if (iszv /= size(p%precv)) then
info=psb_err_internal_error_
call psb_errpush(info,name,a_err='Inconsistent size of precv')
goto 9999
end if
end if end if
if (iszv <= 1) then if (iszv <= 1) then
@ -162,7 +174,161 @@ subroutine mld_zmlprec_bld(a,desc_a,p,info,amold,vmold)
endif endif
if (iszv > 1) then
if (casize>0) then
!
! New strategy to build according to coarse size.
!
coarseparms = p%precv(iszv)%parms
baseparms = p%precv(1)%parms
medparms = p%precv(2)%parms
allocate(coarse_sm, source=p%precv(iszv)%sm,stat=info)
if (info == psb_success_) &
& allocate(med_sm, source=p%precv(2)%sm,stat=info)
if (info == psb_success_) &
& allocate(base_sm, source=p%precv(1)%sm,stat=info)
if (info /= psb_success_) then
write(0,*) 'Error in saving smoothers',info
call psb_errpush(psb_err_internal_error_,name,a_err='Base level precbuild.')
goto 9999
end if
!
! Replicated matrix should only ever happen at coarse level.
!
call mld_check_def(baseparms%coarse_mat,'Coarse matrix',&
& mld_distr_mat_,is_distr_ml_coarse_mat)
!
! Now build a doubly linked list
!
allocate(newnode,stat=info)
if (info /= psb_success_) then
info = psb_err_internal_error_
call psb_errpush(info,name,a_err='List start'); goto 9999
end if
head => newnode
tail => newnode
newnode%item%base_a => a
newnode%item%base_desc => desc_a
newnode%item%parms = baseparms
newsz = 1
current => head
list_build_loop: do
allocate(newnode,stat=info)
if (info /= psb_success_) then
info = psb_err_internal_error_
call psb_errpush(info,name,a_err='List start'); goto 9999
end if
current%next => newnode
newnode%prev => current
newsz = newsz + 1
newnode%item%parms = medparms
newnode%item%parms%aggr_thresh = current%item%parms%aggr_thresh/2
call mld_coarse_bld(current%item%base_a, current%item%base_desc, &
& newnode%item,info)
if (info /= psb_success_) then
info = psb_err_internal_error_
call psb_errpush(info,name,a_err='build next level'); goto 9999
end if
if (newsz>2) then
if (all(current%item%map%naggr == newnode%item%map%naggr)) then
!
! We are not gaining anything
!
newsz = newsz-1
current%next => null()
call newnode%item%free(info)
if (info == psb_success_) deallocate(newnode,stat=info)
if (info /= psb_success_) then
info = psb_err_internal_error_
call psb_errpush(info,name,a_err='Deallocate at list end'); goto 9999
end if
end if
end if
current => current%next
tail => current
if (sum(newnode%item%map%naggr) <= casize) then
!
! Target reached; but we may need to rebuild.
!
exit list_build_loop
end if
end do list_build_loop
!
! At this point, we are at the list tail,
! and it needs to be rebuilt in case the parms were
! different.
!
! But the threshold has to be fixed before rebuliding
coarseparms%aggr_thresh = current%item%parms%aggr_thresh
current%item%parms = coarseparms
call mld_coarse_bld(current%prev%item%base_a,&
& current%prev%item%base_desc, &
& current%item,info)
if (info /= psb_success_) then
info = psb_err_internal_error_
call psb_errpush(info,name,a_err='build next level'); goto 9999
end if
!
! Ok, now allocate the output vector and fix items.
!
do i=1,iszv
if (info == psb_success_) call p%precv(i)%free(info)
end do
if (info == psb_success_) deallocate(p%precv,stat=info)
if (info == psb_success_) allocate(p%precv(newsz),stat=info)
if (info /= psb_success_) then
info = psb_err_internal_error_
call psb_errpush(info,name,a_err='Reallocate precv'); goto 9999
end if
newnode => head
do i=1, newsz
current => newnode
if (info == psb_success_) &
& call mld_move_alloc(current%item,p%precv(i),info)
if (info == psb_success_) then
if (i ==1) then
allocate(p%precv(i)%sm,source=base_sm,stat=info)
else if (i < newsz) then
allocate(p%precv(i)%sm,source=med_sm,stat=info)
else
allocate(p%precv(i)%sm,source=coarse_sm,stat=info)
end if
end if
if (info /= psb_success_) then
info = psb_err_internal_error_
call psb_errpush(info,name,a_err='list cpy'); goto 9999
end if
if (i == 1) then
p%precv(i)%base_a => a
p%precv(i)%base_desc => desc_a
else
p%precv(i)%base_a => p%precv(i)%ac
p%precv(i)%base_desc => p%precv(i)%desc_ac
p%precv(i)%map%p_desc_X => p%precv(i-1)%base_desc
p%precv(i)%map%p_desc_Y => p%precv(i)%base_desc
end if
newnode => current%next
deallocate(current)
end do
call base_sm%free(info)
if (info == psb_success_) call med_sm%free(info)
if (info == psb_success_) call coarse_sm%free(info)
if (info == psb_success_) deallocate(coarse_sm,med_sm,base_sm,stat=info)
if (info /= psb_success_) then
info = psb_err_internal_error_
call psb_errpush(info,name,a_err='final cleanup'); goto 9999
end if
iszv = newsz
else
!
! Default, oldstyle
!
! !
! Build the matrix and the transfer operators corresponding ! Build the matrix and the transfer operators corresponding
@ -179,11 +345,6 @@ subroutine mld_zmlprec_bld(a,desc_a,p,info,amold,vmold)
p%precv(1)%base_a => a p%precv(1)%base_a => a
p%precv(1)%base_desc => desc_a p%precv(1)%base_desc => desc_a
if (info /= psb_success_) then
call psb_errpush(psb_err_internal_error_,name,a_err='Base level precbuild.')
goto 9999
end if
do i=2, iszv do i=2, iszv
! !
@ -201,11 +362,6 @@ subroutine mld_zmlprec_bld(a,desc_a,p,info,amold,vmold)
! !
call mld_check_def(p%precv(i)%parms%coarse_mat,'Coarse matrix',& call mld_check_def(p%precv(i)%parms%coarse_mat,'Coarse matrix',&
& mld_distr_mat_,is_distr_ml_coarse_mat) & mld_distr_mat_,is_distr_ml_coarse_mat)
else if (i == iszv) then
!!$ call check_coarse_lev(p%precv(i))
end if end if
if (debug_level >= psb_debug_outer_) & if (debug_level >= psb_debug_outer_) &
@ -277,9 +433,7 @@ subroutine mld_zmlprec_bld(a,desc_a,p,info,amold,vmold)
p%precv(i)%map%p_desc_Y => p%precv(i)%base_desc p%precv(i)%map%p_desc_Y => p%precv(i)%base_desc
end do end do
i = iszv i = iszv
call check_coarse_lev(p%precv(i))
if (info == psb_success_) call mld_coarse_bld(p%precv(i-1)%base_a,& if (info == psb_success_) call mld_coarse_bld(p%precv(i-1)%base_a,&
& p%precv(i-1)%base_desc, p%precv(i),info) & p%precv(i-1)%base_desc, p%precv(i),info)
if (info /= psb_success_) then if (info /= psb_success_) then
@ -289,6 +443,12 @@ subroutine mld_zmlprec_bld(a,desc_a,p,info,amold,vmold)
end if end if
end if end if
!
! The coarse space hierarchy has been build.
!
! Now do the preconditioner build.
!
do i=1, iszv do i=1, iszv
! !
! build the base preconditioner at level i ! build the base preconditioner at level i
@ -316,10 +476,6 @@ subroutine mld_zmlprec_bld(a,desc_a,p,info,amold,vmold)
goto 9999 goto 9999
end if end if
!
! Test version for beginning of OO stuff.
!
call p%precv(i)%sm%build(p%precv(i)%base_a,p%precv(i)%base_desc,& call p%precv(i)%sm%build(p%precv(i)%base_a,p%precv(i)%base_desc,&
& 'F',info,amold=amold,vmold=vmold) & 'F',info,amold=amold,vmold=vmold)
@ -350,69 +506,4 @@ subroutine mld_zmlprec_bld(a,desc_a,p,info,amold,vmold)
end if end if
return return
contains
subroutine check_coarse_lev(prec)
type(mld_z_onelev_type) :: prec
!
! At the coarsest level, check mld_coarse_solve_
!
!!$ val = prec%parms%coarse_solve
!!$ select case (val)
!!$ case(mld_jac_)
!!$
!!$ if (prec%prec%iprcparm(mld_sub_solve_) /= mld_diag_scale_) 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_.'
!!$ prec%prec%iprcparm(mld_sub_solve_) = mld_diag_scale_
!!$ end if
!!$ prec%prec%iprcparm(mld_smoother_type_) = mld_jac_
!!$
!!$ case(mld_bjac_)
!!$
!!$ if ((prec%prec%iprcparm(mld_sub_solve_) == mld_diag_scale_).or.&
!!$ & ( prec%prec%iprcparm(mld_smoother_type_) /= mld_bjac_)) 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_.'
!!$! !$#if defined(HAVE_UMF_)
!!$! !$ prec%prec%iprcparm(mld_sub_solve_) = mld_umf_
!!$! !$#elif defined(HAVE_SLU_)
!!$! !$ prec%prec%iprcparm(mld_sub_solve_) = mld_slu_
!!$! !$#else
!!$ prec%prec%iprcparm(mld_sub_solve_) = mld_ilu_n_
!!$! !$#endif
!!$ end if
!!$ prec%prec%iprcparm(mld_smoother_type_) = mld_bjac_
!!$
!!$ case(mld_umf_, mld_slu_)
!!$ if ((prec%iprcparm(mld_coarse_mat_) /= mld_repl_mat_).or.&
!!$ & (prec%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_.'
!!$ prec%iprcparm(mld_coarse_mat_) = mld_repl_mat_
!!$ prec%prec%iprcparm(mld_sub_solve_) = val
!!$ prec%prec%iprcparm(mld_smoother_type_) = mld_bjac_
!!$ end if
!!$ case(mld_sludist_)
!!$ if ((prec%iprcparm(mld_coarse_mat_) /= mld_distr_mat_).or.&
!!$ & (prec%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_.'
!!$ prec%iprcparm(mld_coarse_mat_) = mld_distr_mat_
!!$ prec%prec%iprcparm(mld_sub_solve_) = val
!!$ prec%prec%iprcparm(mld_smoother_type_) = mld_bjac_
!!$ prec%prec%iprcparm(mld_smoother_sweeps_) = 1
!!$ end if
!!$ end select
end subroutine check_coarse_lev
end subroutine mld_zmlprec_bld end subroutine mld_zmlprec_bld

1
mlprec/impl/mld_zprecinit.F90
Unescape Escape View File

@ -125,6 +125,7 @@ subroutine mld_zprecinit(p,ptype,info,nlev)
! Do we want to do something? ! Do we want to do something?
endif endif
endif endif
p%coarse_aggr_size = -1
select case(psb_toupper(ptype(1:len_trim(ptype)))) select case(psb_toupper(ptype(1:len_trim(ptype))))
case ('NOPREC','NONE') case ('NOPREC','NONE')

5
mlprec/impl/mld_zprecset.F90
Unescape Escape View File

@ -129,6 +129,11 @@ subroutine mld_zprecseti(p,what,val,info,ilev)
return return
endif endif
if (what == mld_coarse_aggr_size_) then
p%coarse_aggr_size = max(val,-1)
return
end if
! !
! Set preconditioner parameters at level ilev. ! Set preconditioner parameters at level ilev.
! !

38
mlprec/mld_base_prec_type.F90
Unescape Escape View File

@ -104,6 +104,7 @@ module mld_base_prec_type
procedure, pass(pm) :: descr => ml_parms_descr procedure, pass(pm) :: descr => ml_parms_descr
procedure, pass(pm) :: mldescr => ml_parms_mldescr procedure, pass(pm) :: mldescr => ml_parms_mldescr
procedure, pass(pm) :: coarsedescr => ml_parms_coarsedescr procedure, pass(pm) :: coarsedescr => ml_parms_coarsedescr
procedure, pass(pm) :: printout => ml_parms_printout
end type mld_ml_parms end type mld_ml_parms
@ -111,12 +112,14 @@ module mld_base_prec_type
real(psb_spk_) :: aggr_omega_val, aggr_thresh real(psb_spk_) :: aggr_omega_val, aggr_thresh
contains contains
procedure, pass(pm) :: descr => s_ml_parms_descr procedure, pass(pm) :: descr => s_ml_parms_descr
procedure, pass(pm) :: printout => s_ml_parms_printout
end type mld_sml_parms end type mld_sml_parms
type, extends(mld_ml_parms) :: mld_dml_parms type, extends(mld_ml_parms) :: mld_dml_parms
real(psb_dpk_) :: aggr_omega_val, aggr_thresh real(psb_dpk_) :: aggr_omega_val, aggr_thresh
contains contains
procedure, pass(pm) :: descr => d_ml_parms_descr procedure, pass(pm) :: descr => d_ml_parms_descr
procedure, pass(pm) :: printout => d_ml_parms_printout
end type mld_dml_parms end type mld_dml_parms
@ -157,6 +160,7 @@ module mld_base_prec_type
integer, parameter :: mld_coarse_fillin_ = 32 integer, parameter :: mld_coarse_fillin_ = 32
integer, parameter :: mld_coarse_subsolve_ = 33 integer, parameter :: mld_coarse_subsolve_ = 33
integer, parameter :: mld_smoother_sweeps_ = 34 integer, parameter :: mld_smoother_sweeps_ = 34
integer, parameter :: mld_coarse_aggr_size_ = 35
integer, parameter :: mld_ifpsz_ = 36 integer, parameter :: mld_ifpsz_ = 36
! !
@ -436,6 +440,40 @@ contains
end subroutine mld_stringval end subroutine mld_stringval
subroutine ml_parms_printout(pm,iout)
implicit none
class(mld_ml_parms), intent(in) :: pm
integer, intent(in) :: iout
write(iout,*) 'Sweeps: ',pm%sweeps,pm%sweeps_pre,pm%sweeps_post
write(iout,*) 'ML : ',pm%ml_type,pm%smoother_pos
write(iout,*) 'AGGR : ',pm%aggr_alg,pm%aggr_kind
write(iout,*) ' : ',pm%aggr_omega_alg,pm%aggr_eig,pm%aggr_filter
write(iout,*) 'COARSE: ',pm%coarse_mat,pm%coarse_solve
end subroutine ml_parms_printout
subroutine s_ml_parms_printout(pm,iout)
implicit none
class(mld_sml_parms), intent(in) :: pm
integer, intent(in) :: iout
call pm%mld_ml_parms%printout(iout)
write(iout,*) 'REAL : ',pm%aggr_omega_val,pm%aggr_thresh
end subroutine s_ml_parms_printout
subroutine d_ml_parms_printout(pm,iout)
implicit none
class(mld_dml_parms), intent(in) :: pm
integer, intent(in) :: iout
call pm%mld_ml_parms%printout(iout)
write(iout,*) 'REAL : ',pm%aggr_omega_val,pm%aggr_thresh
end subroutine d_ml_parms_printout
! !
! Routines printing out a description of the preconditioner ! Routines printing out a description of the preconditioner
! !

52
mlprec/mld_c_inner_mod.f90
Unescape Escape View File

@ -46,8 +46,6 @@
! !
module mld_c_inner_mod module mld_c_inner_mod
use mld_c_prec_type use mld_c_prec_type
use mld_c_move_alloc_mod
interface mld_mlprec_bld interface mld_mlprec_bld
subroutine mld_cmlprec_bld(a,desc_a,prec,info, amold, vmold) subroutine mld_cmlprec_bld(a,desc_a,prec,info, amold, vmold)
@ -130,6 +128,7 @@ module mld_c_inner_mod
end subroutine mld_c_dec_map_bld end subroutine mld_c_dec_map_bld
end interface mld_dec_map_bld end interface mld_dec_map_bld
interface mld_aggrmat_asb interface mld_aggrmat_asb
subroutine mld_caggrmat_asb(a,desc_a,ilaggr,nlaggr,p,info) subroutine mld_caggrmat_asb(a,desc_a,ilaggr,nlaggr,p,info)
use psb_base_mod, only : psb_cspmat_type, psb_desc_type, psb_spk_ use psb_base_mod, only : psb_cspmat_type, psb_desc_type, psb_spk_
@ -142,40 +141,25 @@ module mld_c_inner_mod
end subroutine mld_caggrmat_asb end subroutine mld_caggrmat_asb
end interface mld_aggrmat_asb end interface mld_aggrmat_asb
interface mld_aggrmat_nosmth_asb
subroutine mld_caggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,p,info)
use psb_base_mod, only : psb_cspmat_type, psb_desc_type, psb_spk_
use mld_c_prec_type, only : mld_c_onelev_type
type(psb_cspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_a
integer, intent(inout) :: ilaggr(:), nlaggr(:)
type(mld_c_onelev_type), intent(inout), target :: p
integer, intent(out) :: info
end subroutine mld_caggrmat_nosmth_asb
end interface mld_aggrmat_nosmth_asb
interface mld_aggrmat_smth_asb abstract interface
subroutine mld_caggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info) subroutine mld_caggrmat_var_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_restr,info)
use psb_base_mod, only : psb_cspmat_type, psb_desc_type, psb_spk_ use psb_base_mod, only : psb_cspmat_type, psb_desc_type, psb_spk_
use mld_c_prec_type, only : mld_c_onelev_type use mld_c_prec_type, only : mld_c_onelev_type, mld_sml_parms
type(psb_cspmat_type), intent(in) :: a type(psb_cspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_a type(psb_desc_type), intent(in) :: desc_a
integer, intent(inout) :: ilaggr(:), nlaggr(:) integer, intent(inout) :: ilaggr(:), nlaggr(:)
type(mld_c_onelev_type), intent(inout), target :: p type(mld_sml_parms), intent(inout) :: parms
integer, intent(out) :: info type(psb_cspmat_type), intent(out) :: ac,op_prol,op_restr
end subroutine mld_caggrmat_smth_asb integer, intent(out) :: info
end interface mld_aggrmat_smth_asb end subroutine mld_caggrmat_var_asb
end interface
procedure(mld_caggrmat_var_asb) :: mld_caggrmat_nosmth_asb, &
& mld_caggrmat_smth_asb, mld_caggrmat_minnrg_asb, &
& mld_caggrmat_biz_asb
interface mld_aggrmat_minnrg_asb
subroutine mld_caggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info)
use psb_base_mod, only : psb_cspmat_type, psb_desc_type, psb_spk_
use mld_c_prec_type, only : mld_c_onelev_type
type(psb_cspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_a
integer, intent(inout) :: ilaggr(:), nlaggr(:)
type(mld_c_onelev_type), intent(inout), target :: p
integer, intent(out) :: info
end subroutine mld_caggrmat_minnrg_asb
end interface mld_aggrmat_minnrg_asb
end module mld_c_inner_mod end module mld_c_inner_mod

102
mlprec/mld_c_move_alloc_mod.f90
Unescape Escape View File

@ -1,102 +0,0 @@
!!$
!!$
!!$ MLD2P4 version 2.0
!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package
!!$ based on PSBLAS (Parallel Sparse BLAS version 3.0)
!!$
!!$ (C) Copyright 2008,2009,2010
!!$
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$ Pasqua D'Ambra ICAR-CNR, Naples
!!$ Daniela di Serafino Second University of Naples
!!$
!!$ Redistribution and use in source and binary forms, with or without
!!$ modification, are permitted provided that the following conditions
!!$ are met:
!!$ 1. Redistributions of source code must retain the above copyright
!!$ notice, this list of conditions and the following disclaimer.
!!$ 2. Redistributions in binary form must reproduce the above copyright
!!$ notice, this list of conditions, and the following disclaimer in the
!!$ documentation and/or other materials provided with the distribution.
!!$ 3. The name of the MLD2P4 group or the names of its contributors may
!!$ not be used to endorse or promote products derived from this
!!$ software without specific written permission.
!!$
!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE MLD2P4 GROUP OR ITS CONTRIBUTORS
!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
!!$ POSSIBILITY OF SUCH DAMAGE.
!!$
!!$
! File: mld_c_move_alloc_mod.f90
!
! Module: mld_c_move_alloc_mod
!
! This module defines move_alloc-like routines, and related interfaces,
! for the preconditioner data structures. .
!
module mld_c_move_alloc_mod
use mld_c_prec_type
interface mld_move_alloc
module procedure mld_c_onelev_prec_move_alloc,&
& mld_cprec_move_alloc
end interface
contains
subroutine mld_c_onelev_prec_move_alloc(a, b,info)
use psb_base_mod
implicit none
type(mld_c_onelev_type), intent(inout) :: a, b
integer, intent(out) :: info
call b%free(info)
call move_alloc(a%sm,b%sm)
if (info == psb_success_) call psb_move_alloc(a%ac,b%ac,info)
if (info == psb_success_) call psb_move_alloc(a%desc_ac,b%desc_ac,info)
if (info == psb_success_) call psb_move_alloc(a%map,b%map,info)
b%base_a => a%base_a
b%base_desc => a%base_desc
end subroutine mld_c_onelev_prec_move_alloc
subroutine mld_cprec_move_alloc(a, b,info)
use psb_base_mod
implicit none
type(mld_cprec_type), intent(inout) :: a
type(mld_cprec_type), intent(inout), target :: b
integer, intent(out) :: info
integer :: i
if (allocated(b%precv)) then
! This might not be required if FINAL procedures are available.
call mld_precfree(b,info)
if (info /= psb_success_) then
! ?????
!!$ return
endif
end if
call move_alloc(a%precv,b%precv)
! Fix the pointers except on level 1.
do i=2, size(b%precv)
b%precv(i)%base_a => b%precv(i)%ac
b%precv(i)%base_desc => b%precv(i)%desc_ac
b%precv(i)%map%p_desc_X => b%precv(i-1)%base_desc
b%precv(i)%map%p_desc_Y => b%precv(i)%base_desc
end do
end subroutine mld_cprec_move_alloc
end module mld_c_move_alloc_mod

26
mlprec/mld_c_onelev_mod.f90
Unescape Escape View File

@ -141,6 +141,11 @@ module mld_c_onelev_mod
procedure, pass(lv) :: get_nzeros => c_base_onelev_get_nzeros procedure, pass(lv) :: get_nzeros => c_base_onelev_get_nzeros
end type mld_c_onelev_type end type mld_c_onelev_type
type mld_c_onelev_node
type(mld_c_onelev_type) :: item
type(mld_c_onelev_node), pointer :: prev=>null(), next=>null()
end type mld_c_onelev_node
private :: c_base_onelev_default, c_base_onelev_sizeof, & private :: c_base_onelev_default, c_base_onelev_sizeof, &
& c_base_onelev_nullify, c_base_onelev_get_nzeros & c_base_onelev_nullify, c_base_onelev_get_nzeros
@ -234,6 +239,9 @@ module mld_c_onelev_mod
end subroutine mld_c_base_onelev_dump end subroutine mld_c_base_onelev_dump
end interface end interface
interface mld_move_alloc
module procedure mld_c_onelev_move_alloc
end interface
contains contains
! !
@ -312,4 +320,22 @@ contains
end subroutine c_base_onelev_default end subroutine c_base_onelev_default
subroutine mld_c_onelev_move_alloc(a, b,info)
use psb_base_mod
implicit none
type(mld_c_onelev_type), intent(inout) :: a, b
integer, intent(out) :: info
call b%free(info)
b%parms = a%parms
call move_alloc(a%sm,b%sm)
if (info == psb_success_) call psb_move_alloc(a%ac,b%ac,info)
if (info == psb_success_) call psb_move_alloc(a%desc_ac,b%desc_ac,info)
if (info == psb_success_) call psb_move_alloc(a%map,b%map,info)
b%base_a => a%base_a
b%base_desc => a%base_desc
end subroutine mld_c_onelev_move_alloc
end module mld_c_onelev_mod end module mld_c_onelev_mod

1
mlprec/mld_c_prec_mod.f90
Unescape Escape View File

@ -46,7 +46,6 @@
module mld_c_prec_mod module mld_c_prec_mod
use mld_c_prec_type use mld_c_prec_type
use mld_c_move_alloc_mod
interface mld_precinit interface mld_precinit
subroutine mld_cprecinit(p,ptype,info,nlev) subroutine mld_cprecinit(p,ptype,info,nlev)

32
mlprec/mld_c_prec_type.f90
Unescape Escape View File

@ -81,6 +81,7 @@ module mld_c_prec_type
type, extends(psb_cprec_type) :: mld_cprec_type type, extends(psb_cprec_type) :: mld_cprec_type
integer :: ictxt integer :: ictxt
integer(psb_ipk_) :: coarse_aggr_size
real(psb_spk_) :: op_complexity=szero real(psb_spk_) :: op_complexity=szero
type(mld_c_onelev_type), allocatable :: precv(:) type(mld_c_onelev_type), allocatable :: precv(:)
contains contains
@ -159,6 +160,10 @@ module mld_c_prec_type
end subroutine mld_cprecaply1 end subroutine mld_cprecaply1
end interface end interface
interface mld_move_alloc
module procedure mld_cprec_move_alloc
end interface
contains contains
! !
! Function returning the size of the mld_prec_type data structure ! Function returning the size of the mld_prec_type data structure
@ -577,5 +582,32 @@ contains
end do end do
end subroutine mld_c_dump end subroutine mld_c_dump
subroutine mld_cprec_move_alloc(a, b,info)
use psb_base_mod
implicit none
type(mld_cprec_type), intent(inout) :: a
type(mld_cprec_type), intent(inout), target :: b
integer, intent(out) :: info
integer :: i
if (allocated(b%precv)) then
! This might not be required if FINAL procedures are available.
call mld_precfree(b,info)
if (info /= psb_success_) then
! ?????
!!$ return
endif
end if
call move_alloc(a%precv,b%precv)
! Fix the pointers except on level 1.
do i=2, size(b%precv)
b%precv(i)%base_a => b%precv(i)%ac
b%precv(i)%base_desc => b%precv(i)%desc_ac
b%precv(i)%map%p_desc_X => b%precv(i-1)%base_desc
b%precv(i)%map%p_desc_Y => b%precv(i)%base_desc
end do
end subroutine mld_cprec_move_alloc
end module mld_c_prec_type end module mld_c_prec_type

52
mlprec/mld_d_inner_mod.f90
Unescape Escape View File

@ -46,8 +46,6 @@
! !
module mld_d_inner_mod module mld_d_inner_mod
use mld_d_prec_type use mld_d_prec_type
use mld_d_move_alloc_mod
interface mld_mlprec_bld interface mld_mlprec_bld
subroutine mld_dmlprec_bld(a,desc_a,prec,info, amold, vmold) subroutine mld_dmlprec_bld(a,desc_a,prec,info, amold, vmold)
@ -130,6 +128,7 @@ module mld_d_inner_mod
end subroutine mld_d_dec_map_bld end subroutine mld_d_dec_map_bld
end interface mld_dec_map_bld end interface mld_dec_map_bld
interface mld_aggrmat_asb interface mld_aggrmat_asb
subroutine mld_daggrmat_asb(a,desc_a,ilaggr,nlaggr,p,info) subroutine mld_daggrmat_asb(a,desc_a,ilaggr,nlaggr,p,info)
use psb_base_mod, only : psb_dspmat_type, psb_desc_type, psb_dpk_ use psb_base_mod, only : psb_dspmat_type, psb_desc_type, psb_dpk_
@ -142,40 +141,25 @@ module mld_d_inner_mod
end subroutine mld_daggrmat_asb end subroutine mld_daggrmat_asb
end interface mld_aggrmat_asb end interface mld_aggrmat_asb
interface mld_aggrmat_nosmth_asb
subroutine mld_daggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,p,info)
use psb_base_mod, only : psb_dspmat_type, psb_desc_type, psb_dpk_
use mld_d_prec_type, only : mld_d_onelev_type
type(psb_dspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_a
integer, intent(inout) :: ilaggr(:), nlaggr(:)
type(mld_d_onelev_type), intent(inout), target :: p
integer, intent(out) :: info
end subroutine mld_daggrmat_nosmth_asb
end interface mld_aggrmat_nosmth_asb
interface mld_aggrmat_smth_asb abstract interface
subroutine mld_daggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info) subroutine mld_daggrmat_var_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_restr,info)
use psb_base_mod, only : psb_dspmat_type, psb_desc_type, psb_dpk_ use psb_base_mod, only : psb_dspmat_type, psb_desc_type, psb_dpk_
use mld_d_prec_type, only : mld_d_onelev_type use mld_d_prec_type, only : mld_d_onelev_type, mld_dml_parms
type(psb_dspmat_type), intent(in) :: a type(psb_dspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_a type(psb_desc_type), intent(in) :: desc_a
integer, intent(inout) :: ilaggr(:), nlaggr(:) integer, intent(inout) :: ilaggr(:), nlaggr(:)
type(mld_d_onelev_type), intent(inout), target :: p type(mld_dml_parms), intent(inout) :: parms
integer, intent(out) :: info type(psb_dspmat_type), intent(out) :: ac,op_prol,op_restr
end subroutine mld_daggrmat_smth_asb integer, intent(out) :: info
end interface mld_aggrmat_smth_asb end subroutine mld_daggrmat_var_asb
end interface
procedure(mld_daggrmat_var_asb) :: mld_daggrmat_nosmth_asb, &
& mld_daggrmat_smth_asb, mld_daggrmat_minnrg_asb, &
& mld_daggrmat_biz_asb
interface mld_aggrmat_minnrg_asb
subroutine mld_daggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info)
use psb_base_mod, only : psb_dspmat_type, psb_desc_type, psb_dpk_
use mld_d_prec_type, only : mld_d_onelev_type
type(psb_dspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_a
integer, intent(inout) :: ilaggr(:), nlaggr(:)
type(mld_d_onelev_type), intent(inout), target :: p
integer, intent(out) :: info
end subroutine mld_daggrmat_minnrg_asb
end interface mld_aggrmat_minnrg_asb
end module mld_d_inner_mod end module mld_d_inner_mod

102
mlprec/mld_d_move_alloc_mod.f90
Unescape Escape View File

@ -1,102 +0,0 @@
!!$
!!$
!!$ MLD2P4 version 2.0
!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package
!!$ based on PSBLAS (Parallel Sparse BLAS version 3.0)
!!$
!!$ (C) Copyright 2008,2009,2010
!!$
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$ Pasqua D'Ambra ICAR-CNR, Naples
!!$ Daniela di Serafino Second University of Naples
!!$
!!$ Redistribution and use in source and binary forms, with or without
!!$ modification, are permitted provided that the following conditions
!!$ are met:
!!$ 1. Redistributions of source code must retain the above copyright
!!$ notice, this list of conditions and the following disclaimer.
!!$ 2. Redistributions in binary form must reproduce the above copyright
!!$ notice, this list of conditions, and the following disclaimer in the
!!$ documentation and/or other materials provided with the distribution.
!!$ 3. The name of the MLD2P4 group or the names of its contributors may
!!$ not be used to endorse or promote products derived from this
!!$ software without specific written permission.
!!$
!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE MLD2P4 GROUP OR ITS CONTRIBUTORS
!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
!!$ POSSIBILITY OF SUCH DAMAGE.
!!$
!!$
! File: mld_d_move_alloc_mod.f90
!
! Module: mld_d_move_alloc_mod
!
! This module defines move_alloc-like routines, and related interfaces,
! for the preconditioner data structures. .
!
module mld_d_move_alloc_mod
use mld_d_prec_type
interface mld_move_alloc
module procedure mld_d_onelev_prec_move_alloc,&
& mld_dprec_move_alloc
end interface
contains
subroutine mld_d_onelev_prec_move_alloc(a, b,info)
use psb_base_mod
implicit none
type(mld_d_onelev_type), intent(inout) :: a, b
integer, intent(out) :: info
call b%free(info)
call move_alloc(a%sm,b%sm)
if (info == psb_success_) call psb_move_alloc(a%ac,b%ac,info)
if (info == psb_success_) call psb_move_alloc(a%desc_ac,b%desc_ac,info)
if (info == psb_success_) call psb_move_alloc(a%map,b%map,info)
b%base_a => a%base_a
b%base_desc => a%base_desc
end subroutine mld_d_onelev_prec_move_alloc
subroutine mld_dprec_move_alloc(a, b,info)
use psb_base_mod
implicit none
type(mld_dprec_type), intent(inout) :: a
type(mld_dprec_type), intent(inout), target :: b
integer, intent(out) :: info
integer :: i
if (allocated(b%precv)) then
! This might not be required if FINAL procedures are available.
call mld_precfree(b,info)
if (info /= psb_success_) then
! ?????
!!$ return
endif
end if
call move_alloc(a%precv,b%precv)
! Fix the pointers except on level 1.
do i=2, size(b%precv)
b%precv(i)%base_a => b%precv(i)%ac
b%precv(i)%base_desc => b%precv(i)%desc_ac
b%precv(i)%map%p_desc_X => b%precv(i-1)%base_desc
b%precv(i)%map%p_desc_Y => b%precv(i)%base_desc
end do
end subroutine mld_dprec_move_alloc
end module mld_d_move_alloc_mod

26
mlprec/mld_d_onelev_mod.f90
Unescape Escape View File

@ -141,6 +141,11 @@ module mld_d_onelev_mod
procedure, pass(lv) :: get_nzeros => d_base_onelev_get_nzeros procedure, pass(lv) :: get_nzeros => d_base_onelev_get_nzeros
end type mld_d_onelev_type end type mld_d_onelev_type
type mld_d_onelev_node
type(mld_d_onelev_type) :: item
type(mld_d_onelev_node), pointer :: prev=>null(), next=>null()
end type mld_d_onelev_node
private :: d_base_onelev_default, d_base_onelev_sizeof, & private :: d_base_onelev_default, d_base_onelev_sizeof, &
& d_base_onelev_nullify, d_base_onelev_get_nzeros & d_base_onelev_nullify, d_base_onelev_get_nzeros
@ -234,6 +239,9 @@ module mld_d_onelev_mod
end subroutine mld_d_base_onelev_dump end subroutine mld_d_base_onelev_dump
end interface end interface
interface mld_move_alloc
module procedure mld_d_onelev_move_alloc
end interface
contains contains
! !
@ -312,4 +320,22 @@ contains
end subroutine d_base_onelev_default end subroutine d_base_onelev_default
subroutine mld_d_onelev_move_alloc(a, b,info)
use psb_base_mod
implicit none
type(mld_d_onelev_type), intent(inout) :: a, b
integer, intent(out) :: info
call b%free(info)
b%parms = a%parms
call move_alloc(a%sm,b%sm)
if (info == psb_success_) call psb_move_alloc(a%ac,b%ac,info)
if (info == psb_success_) call psb_move_alloc(a%desc_ac,b%desc_ac,info)
if (info == psb_success_) call psb_move_alloc(a%map,b%map,info)
b%base_a => a%base_a
b%base_desc => a%base_desc
end subroutine mld_d_onelev_move_alloc
end module mld_d_onelev_mod end module mld_d_onelev_mod

1
mlprec/mld_d_prec_mod.f90
Unescape Escape View File

@ -46,7 +46,6 @@
module mld_d_prec_mod module mld_d_prec_mod
use mld_d_prec_type use mld_d_prec_type
use mld_d_move_alloc_mod
interface mld_precinit interface mld_precinit
subroutine mld_dprecinit(p,ptype,info,nlev) subroutine mld_dprecinit(p,ptype,info,nlev)

32
mlprec/mld_d_prec_type.f90
Unescape Escape View File

@ -81,6 +81,7 @@ module mld_d_prec_type
type, extends(psb_dprec_type) :: mld_dprec_type type, extends(psb_dprec_type) :: mld_dprec_type
integer :: ictxt integer :: ictxt
integer(psb_ipk_) :: coarse_aggr_size
real(psb_dpk_) :: op_complexity=dzero real(psb_dpk_) :: op_complexity=dzero
type(mld_d_onelev_type), allocatable :: precv(:) type(mld_d_onelev_type), allocatable :: precv(:)
contains contains
@ -159,6 +160,10 @@ module mld_d_prec_type
end subroutine mld_dprecaply1 end subroutine mld_dprecaply1
end interface end interface
interface mld_move_alloc
module procedure mld_dprec_move_alloc
end interface
contains contains
! !
! Function returning the size of the mld_prec_type data structure ! Function returning the size of the mld_prec_type data structure
@ -577,5 +582,32 @@ contains
end do end do
end subroutine mld_d_dump end subroutine mld_d_dump
subroutine mld_dprec_move_alloc(a, b,info)
use psb_base_mod
implicit none
type(mld_dprec_type), intent(inout) :: a
type(mld_dprec_type), intent(inout), target :: b
integer, intent(out) :: info
integer :: i
if (allocated(b%precv)) then
! This might not be required if FINAL procedures are available.
call mld_precfree(b,info)
if (info /= psb_success_) then
! ?????
!!$ return
endif
end if
call move_alloc(a%precv,b%precv)
! Fix the pointers except on level 1.
do i=2, size(b%precv)
b%precv(i)%base_a => b%precv(i)%ac
b%precv(i)%base_desc => b%precv(i)%desc_ac
b%precv(i)%map%p_desc_X => b%precv(i-1)%base_desc
b%precv(i)%map%p_desc_Y => b%precv(i)%base_desc
end do
end subroutine mld_dprec_move_alloc
end module mld_d_prec_type end module mld_d_prec_type

52
mlprec/mld_s_inner_mod.f90
Unescape Escape View File

@ -46,8 +46,6 @@
! !
module mld_s_inner_mod module mld_s_inner_mod
use mld_s_prec_type use mld_s_prec_type
use mld_s_move_alloc_mod
interface mld_mlprec_bld interface mld_mlprec_bld
subroutine mld_smlprec_bld(a,desc_a,prec,info, amold, vmold) subroutine mld_smlprec_bld(a,desc_a,prec,info, amold, vmold)
@ -130,6 +128,7 @@ module mld_s_inner_mod
end subroutine mld_s_dec_map_bld end subroutine mld_s_dec_map_bld
end interface mld_dec_map_bld end interface mld_dec_map_bld
interface mld_aggrmat_asb interface mld_aggrmat_asb
subroutine mld_saggrmat_asb(a,desc_a,ilaggr,nlaggr,p,info) subroutine mld_saggrmat_asb(a,desc_a,ilaggr,nlaggr,p,info)
use psb_base_mod, only : psb_sspmat_type, psb_desc_type, psb_spk_ use psb_base_mod, only : psb_sspmat_type, psb_desc_type, psb_spk_
@ -142,40 +141,25 @@ module mld_s_inner_mod
end subroutine mld_saggrmat_asb end subroutine mld_saggrmat_asb
end interface mld_aggrmat_asb end interface mld_aggrmat_asb
interface mld_aggrmat_nosmth_asb
subroutine mld_saggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,p,info)
use psb_base_mod, only : psb_sspmat_type, psb_desc_type, psb_spk_
use mld_s_prec_type, only : mld_s_onelev_type
type(psb_sspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_a
integer, intent(inout) :: ilaggr(:), nlaggr(:)
type(mld_s_onelev_type), intent(inout), target :: p
integer, intent(out) :: info
end subroutine mld_saggrmat_nosmth_asb
end interface mld_aggrmat_nosmth_asb
interface mld_aggrmat_smth_asb abstract interface
subroutine mld_saggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info) subroutine mld_saggrmat_var_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_restr,info)
use psb_base_mod, only : psb_sspmat_type, psb_desc_type, psb_spk_ use psb_base_mod, only : psb_sspmat_type, psb_desc_type, psb_spk_
use mld_s_prec_type, only : mld_s_onelev_type use mld_s_prec_type, only : mld_s_onelev_type, mld_sml_parms
type(psb_sspmat_type), intent(in) :: a type(psb_sspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_a type(psb_desc_type), intent(in) :: desc_a
integer, intent(inout) :: ilaggr(:), nlaggr(:) integer, intent(inout) :: ilaggr(:), nlaggr(:)
type(mld_s_onelev_type), intent(inout), target :: p type(mld_sml_parms), intent(inout) :: parms
integer, intent(out) :: info type(psb_sspmat_type), intent(out) :: ac,op_prol,op_restr
end subroutine mld_saggrmat_smth_asb integer, intent(out) :: info
end interface mld_aggrmat_smth_asb end subroutine mld_saggrmat_var_asb
end interface
procedure(mld_saggrmat_var_asb) :: mld_saggrmat_nosmth_asb, &
& mld_saggrmat_smth_asb, mld_saggrmat_minnrg_asb, &
& mld_saggrmat_biz_asb
interface mld_aggrmat_minnrg_asb
subroutine mld_saggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info)
use psb_base_mod, only : psb_sspmat_type, psb_desc_type, psb_spk_
use mld_s_prec_type, only : mld_s_onelev_type
type(psb_sspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_a
integer, intent(inout) :: ilaggr(:), nlaggr(:)
type(mld_s_onelev_type), intent(inout), target :: p
integer, intent(out) :: info
end subroutine mld_saggrmat_minnrg_asb
end interface mld_aggrmat_minnrg_asb
end module mld_s_inner_mod end module mld_s_inner_mod

102
mlprec/mld_s_move_alloc_mod.f90
Unescape Escape View File

@ -1,102 +0,0 @@
!!$
!!$
!!$ MLD2P4 version 2.0
!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package
!!$ based on PSBLAS (Parallel Sparse BLAS version 3.0)
!!$
!!$ (C) Copyright 2008,2009,2010
!!$
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$ Pasqua D'Ambra ICAR-CNR, Naples
!!$ Daniela di Serafino Second University of Naples
!!$
!!$ Redistribution and use in source and binary forms, with or without
!!$ modification, are permitted provided that the following conditions
!!$ are met:
!!$ 1. Redistributions of source code must retain the above copyright
!!$ notice, this list of conditions and the following disclaimer.
!!$ 2. Redistributions in binary form must reproduce the above copyright
!!$ notice, this list of conditions, and the following disclaimer in the
!!$ documentation and/or other materials provided with the distribution.
!!$ 3. The name of the MLD2P4 group or the names of its contributors may
!!$ not be used to endorse or promote products derived from this
!!$ software without specific written permission.
!!$
!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE MLD2P4 GROUP OR ITS CONTRIBUTORS
!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
!!$ POSSIBILITY OF SUCH DAMAGE.
!!$
!!$
! File: mld_s_move_alloc_mod.f90
!
! Module: mld_s_move_alloc_mod
!
! This module defines move_alloc-like routines, and related interfaces,
! for the preconditioner data structures. .
!
module mld_s_move_alloc_mod
use mld_s_prec_type
interface mld_move_alloc
module procedure mld_s_onelev_prec_move_alloc,&
& mld_sprec_move_alloc
end interface
contains
subroutine mld_s_onelev_prec_move_alloc(a, b,info)
use psb_base_mod
implicit none
type(mld_s_onelev_type), intent(inout) :: a, b
integer, intent(out) :: info
call b%free(info)
call move_alloc(a%sm,b%sm)
if (info == psb_success_) call psb_move_alloc(a%ac,b%ac,info)
if (info == psb_success_) call psb_move_alloc(a%desc_ac,b%desc_ac,info)
if (info == psb_success_) call psb_move_alloc(a%map,b%map,info)
b%base_a => a%base_a
b%base_desc => a%base_desc
end subroutine mld_s_onelev_prec_move_alloc
subroutine mld_sprec_move_alloc(a, b,info)
use psb_base_mod
implicit none
type(mld_sprec_type), intent(inout) :: a
type(mld_sprec_type), intent(inout), target :: b
integer, intent(out) :: info
integer :: i
if (allocated(b%precv)) then
! This might not be required if FINAL procedures are available.
call mld_precfree(b,info)
if (info /= psb_success_) then
! ?????
!!$ return
endif
end if
call move_alloc(a%precv,b%precv)
! Fix the pointers except on level 1.
do i=2, size(b%precv)
b%precv(i)%base_a => b%precv(i)%ac
b%precv(i)%base_desc => b%precv(i)%desc_ac
b%precv(i)%map%p_desc_X => b%precv(i-1)%base_desc
b%precv(i)%map%p_desc_Y => b%precv(i)%base_desc
end do
end subroutine mld_sprec_move_alloc
end module mld_s_move_alloc_mod

26
mlprec/mld_s_onelev_mod.f90
Unescape Escape View File

@ -141,6 +141,11 @@ module mld_s_onelev_mod
procedure, pass(lv) :: get_nzeros => s_base_onelev_get_nzeros procedure, pass(lv) :: get_nzeros => s_base_onelev_get_nzeros
end type mld_s_onelev_type end type mld_s_onelev_type
type mld_s_onelev_node
type(mld_s_onelev_type) :: item
type(mld_s_onelev_node), pointer :: prev=>null(), next=>null()
end type mld_s_onelev_node
private :: s_base_onelev_default, s_base_onelev_sizeof, & private :: s_base_onelev_default, s_base_onelev_sizeof, &
& s_base_onelev_nullify, s_base_onelev_get_nzeros & s_base_onelev_nullify, s_base_onelev_get_nzeros
@ -234,6 +239,9 @@ module mld_s_onelev_mod
end subroutine mld_s_base_onelev_dump end subroutine mld_s_base_onelev_dump
end interface end interface
interface mld_move_alloc
module procedure mld_s_onelev_move_alloc
end interface
contains contains
! !
@ -312,4 +320,22 @@ contains
end subroutine s_base_onelev_default end subroutine s_base_onelev_default
subroutine mld_s_onelev_move_alloc(a, b,info)
use psb_base_mod
implicit none
type(mld_s_onelev_type), intent(inout) :: a, b
integer, intent(out) :: info
call b%free(info)
b%parms = a%parms
call move_alloc(a%sm,b%sm)
if (info == psb_success_) call psb_move_alloc(a%ac,b%ac,info)
if (info == psb_success_) call psb_move_alloc(a%desc_ac,b%desc_ac,info)
if (info == psb_success_) call psb_move_alloc(a%map,b%map,info)
b%base_a => a%base_a
b%base_desc => a%base_desc
end subroutine mld_s_onelev_move_alloc
end module mld_s_onelev_mod end module mld_s_onelev_mod

1
mlprec/mld_s_prec_mod.f90
Unescape Escape View File

@ -46,7 +46,6 @@
module mld_s_prec_mod module mld_s_prec_mod
use mld_s_prec_type use mld_s_prec_type
use mld_s_move_alloc_mod
interface mld_precinit interface mld_precinit
subroutine mld_sprecinit(p,ptype,info,nlev) subroutine mld_sprecinit(p,ptype,info,nlev)

32
mlprec/mld_s_prec_type.f90
Unescape Escape View File

@ -81,6 +81,7 @@ module mld_s_prec_type
type, extends(psb_sprec_type) :: mld_sprec_type type, extends(psb_sprec_type) :: mld_sprec_type
integer :: ictxt integer :: ictxt
integer(psb_ipk_) :: coarse_aggr_size
real(psb_spk_) :: op_complexity=szero real(psb_spk_) :: op_complexity=szero
type(mld_s_onelev_type), allocatable :: precv(:) type(mld_s_onelev_type), allocatable :: precv(:)
contains contains
@ -159,6 +160,10 @@ module mld_s_prec_type
end subroutine mld_sprecaply1 end subroutine mld_sprecaply1
end interface end interface
interface mld_move_alloc
module procedure mld_sprec_move_alloc
end interface
contains contains
! !
! Function returning the size of the mld_prec_type data structure ! Function returning the size of the mld_prec_type data structure
@ -577,5 +582,32 @@ contains
end do end do
end subroutine mld_s_dump end subroutine mld_s_dump
subroutine mld_sprec_move_alloc(a, b,info)
use psb_base_mod
implicit none
type(mld_sprec_type), intent(inout) :: a
type(mld_sprec_type), intent(inout), target :: b
integer, intent(out) :: info
integer :: i
if (allocated(b%precv)) then
! This might not be required if FINAL procedures are available.
call mld_precfree(b,info)
if (info /= psb_success_) then
! ?????
!!$ return
endif
end if
call move_alloc(a%precv,b%precv)
! Fix the pointers except on level 1.
do i=2, size(b%precv)
b%precv(i)%base_a => b%precv(i)%ac
b%precv(i)%base_desc => b%precv(i)%desc_ac
b%precv(i)%map%p_desc_X => b%precv(i-1)%base_desc
b%precv(i)%map%p_desc_Y => b%precv(i)%base_desc
end do
end subroutine mld_sprec_move_alloc
end module mld_s_prec_type end module mld_s_prec_type

52
mlprec/mld_z_inner_mod.f90
Unescape Escape View File

@ -46,8 +46,6 @@
! !
module mld_z_inner_mod module mld_z_inner_mod
use mld_z_prec_type use mld_z_prec_type
use mld_z_move_alloc_mod
interface mld_mlprec_bld interface mld_mlprec_bld
subroutine mld_zmlprec_bld(a,desc_a,prec,info, amold, vmold) subroutine mld_zmlprec_bld(a,desc_a,prec,info, amold, vmold)
@ -130,6 +128,7 @@ module mld_z_inner_mod
end subroutine mld_z_dec_map_bld end subroutine mld_z_dec_map_bld
end interface mld_dec_map_bld end interface mld_dec_map_bld
interface mld_aggrmat_asb interface mld_aggrmat_asb
subroutine mld_zaggrmat_asb(a,desc_a,ilaggr,nlaggr,p,info) subroutine mld_zaggrmat_asb(a,desc_a,ilaggr,nlaggr,p,info)
use psb_base_mod, only : psb_zspmat_type, psb_desc_type, psb_dpk_ use psb_base_mod, only : psb_zspmat_type, psb_desc_type, psb_dpk_
@ -142,40 +141,25 @@ module mld_z_inner_mod
end subroutine mld_zaggrmat_asb end subroutine mld_zaggrmat_asb
end interface mld_aggrmat_asb end interface mld_aggrmat_asb
interface mld_aggrmat_nosmth_asb
subroutine mld_zaggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,p,info)
use psb_base_mod, only : psb_zspmat_type, psb_desc_type, psb_dpk_
use mld_z_prec_type, only : mld_z_onelev_type
type(psb_zspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_a
integer, intent(inout) :: ilaggr(:), nlaggr(:)
type(mld_z_onelev_type), intent(inout), target :: p
integer, intent(out) :: info
end subroutine mld_zaggrmat_nosmth_asb
end interface mld_aggrmat_nosmth_asb
interface mld_aggrmat_smth_asb abstract interface
subroutine mld_zaggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info) subroutine mld_zaggrmat_var_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_restr,info)
use psb_base_mod, only : psb_zspmat_type, psb_desc_type, psb_dpk_ use psb_base_mod, only : psb_zspmat_type, psb_desc_type, psb_dpk_
use mld_z_prec_type, only : mld_z_onelev_type use mld_z_prec_type, only : mld_z_onelev_type, mld_dml_parms
type(psb_zspmat_type), intent(in) :: a type(psb_zspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_a type(psb_desc_type), intent(in) :: desc_a
integer, intent(inout) :: ilaggr(:), nlaggr(:) integer, intent(inout) :: ilaggr(:), nlaggr(:)
type(mld_z_onelev_type), intent(inout), target :: p type(mld_dml_parms), intent(inout) :: parms
integer, intent(out) :: info type(psb_zspmat_type), intent(out) :: ac,op_prol,op_restr
end subroutine mld_zaggrmat_smth_asb integer, intent(out) :: info
end interface mld_aggrmat_smth_asb end subroutine mld_zaggrmat_var_asb
end interface
procedure(mld_zaggrmat_var_asb) :: mld_zaggrmat_nosmth_asb, &
& mld_zaggrmat_smth_asb, mld_zaggrmat_minnrg_asb, &
& mld_zaggrmat_biz_asb
interface mld_aggrmat_minnrg_asb
subroutine mld_zaggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info)
use psb_base_mod, only : psb_zspmat_type, psb_desc_type, psb_dpk_
use mld_z_prec_type, only : mld_z_onelev_type
type(psb_zspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_a
integer, intent(inout) :: ilaggr(:), nlaggr(:)
type(mld_z_onelev_type), intent(inout), target :: p
integer, intent(out) :: info
end subroutine mld_zaggrmat_minnrg_asb
end interface mld_aggrmat_minnrg_asb
end module mld_z_inner_mod end module mld_z_inner_mod

102
mlprec/mld_z_move_alloc_mod.f90
Unescape Escape View File

@ -1,102 +0,0 @@
!!$
!!$
!!$ MLD2P4 version 2.0
!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package
!!$ based on PSBLAS (Parallel Sparse BLAS version 3.0)
!!$
!!$ (C) Copyright 2008,2009,2010
!!$
!!$ Salvatore Filippone University of Rome Tor Vergata
!!$ Alfredo Buttari CNRS-IRIT, Toulouse
!!$ Pasqua D'Ambra ICAR-CNR, Naples
!!$ Daniela di Serafino Second University of Naples
!!$
!!$ Redistribution and use in source and binary forms, with or without
!!$ modification, are permitted provided that the following conditions
!!$ are met:
!!$ 1. Redistributions of source code must retain the above copyright
!!$ notice, this list of conditions and the following disclaimer.
!!$ 2. Redistributions in binary form must reproduce the above copyright
!!$ notice, this list of conditions, and the following disclaimer in the
!!$ documentation and/or other materials provided with the distribution.
!!$ 3. The name of the MLD2P4 group or the names of its contributors may
!!$ not be used to endorse or promote products derived from this
!!$ software without specific written permission.
!!$
!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE MLD2P4 GROUP OR ITS CONTRIBUTORS
!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
!!$ POSSIBILITY OF SUCH DAMAGE.
!!$
!!$
! File: mld_z_move_alloc_mod.f90
!
! Module: mld_z_move_alloc_mod
!
! This module defines move_alloc-like routines, and related interfaces,
! for the preconditioner data structures. .
!
module mld_z_move_alloc_mod
use mld_z_prec_type
interface mld_move_alloc
module procedure mld_z_onelev_prec_move_alloc,&
& mld_zprec_move_alloc
end interface
contains
subroutine mld_z_onelev_prec_move_alloc(a, b,info)
use psb_base_mod
implicit none
type(mld_z_onelev_type), intent(inout) :: a, b
integer, intent(out) :: info
call b%free(info)
call move_alloc(a%sm,b%sm)
if (info == psb_success_) call psb_move_alloc(a%ac,b%ac,info)
if (info == psb_success_) call psb_move_alloc(a%desc_ac,b%desc_ac,info)
if (info == psb_success_) call psb_move_alloc(a%map,b%map,info)
b%base_a => a%base_a
b%base_desc => a%base_desc
end subroutine mld_z_onelev_prec_move_alloc
subroutine mld_zprec_move_alloc(a, b,info)
use psb_base_mod
implicit none
type(mld_zprec_type), intent(inout) :: a
type(mld_zprec_type), intent(inout), target :: b
integer, intent(out) :: info
integer :: i
if (allocated(b%precv)) then
! This might not be required if FINAL procedures are available.
call mld_precfree(b,info)
if (info /= psb_success_) then
! ?????
!!$ return
endif
end if
call move_alloc(a%precv,b%precv)
! Fix the pointers except on level 1.
do i=2, size(b%precv)
b%precv(i)%base_a => b%precv(i)%ac
b%precv(i)%base_desc => b%precv(i)%desc_ac
b%precv(i)%map%p_desc_X => b%precv(i-1)%base_desc
b%precv(i)%map%p_desc_Y => b%precv(i)%base_desc
end do
end subroutine mld_zprec_move_alloc
end module mld_z_move_alloc_mod

26
mlprec/mld_z_onelev_mod.f90
Unescape Escape View File

@ -141,6 +141,11 @@ module mld_z_onelev_mod
procedure, pass(lv) :: get_nzeros => z_base_onelev_get_nzeros procedure, pass(lv) :: get_nzeros => z_base_onelev_get_nzeros
end type mld_z_onelev_type end type mld_z_onelev_type
type mld_z_onelev_node
type(mld_z_onelev_type) :: item
type(mld_z_onelev_node), pointer :: prev=>null(), next=>null()
end type mld_z_onelev_node
private :: z_base_onelev_default, z_base_onelev_sizeof, & private :: z_base_onelev_default, z_base_onelev_sizeof, &
& z_base_onelev_nullify, z_base_onelev_get_nzeros & z_base_onelev_nullify, z_base_onelev_get_nzeros
@ -234,6 +239,9 @@ module mld_z_onelev_mod
end subroutine mld_z_base_onelev_dump end subroutine mld_z_base_onelev_dump
end interface end interface
interface mld_move_alloc
module procedure mld_z_onelev_move_alloc
end interface
contains contains
! !
@ -312,4 +320,22 @@ contains
end subroutine z_base_onelev_default end subroutine z_base_onelev_default
subroutine mld_z_onelev_move_alloc(a, b,info)
use psb_base_mod
implicit none
type(mld_z_onelev_type), intent(inout) :: a, b
integer, intent(out) :: info
call b%free(info)
b%parms = a%parms
call move_alloc(a%sm,b%sm)
if (info == psb_success_) call psb_move_alloc(a%ac,b%ac,info)
if (info == psb_success_) call psb_move_alloc(a%desc_ac,b%desc_ac,info)
if (info == psb_success_) call psb_move_alloc(a%map,b%map,info)
b%base_a => a%base_a
b%base_desc => a%base_desc
end subroutine mld_z_onelev_move_alloc
end module mld_z_onelev_mod end module mld_z_onelev_mod

1
mlprec/mld_z_prec_mod.f90
Unescape Escape View File

@ -46,7 +46,6 @@
module mld_z_prec_mod module mld_z_prec_mod
use mld_z_prec_type use mld_z_prec_type
use mld_z_move_alloc_mod
interface mld_precinit interface mld_precinit
subroutine mld_zprecinit(p,ptype,info,nlev) subroutine mld_zprecinit(p,ptype,info,nlev)

32
mlprec/mld_z_prec_type.f90
Unescape Escape View File

@ -81,6 +81,7 @@ module mld_z_prec_type
type, extends(psb_zprec_type) :: mld_zprec_type type, extends(psb_zprec_type) :: mld_zprec_type
integer :: ictxt integer :: ictxt
integer(psb_ipk_) :: coarse_aggr_size
real(psb_dpk_) :: op_complexity=dzero real(psb_dpk_) :: op_complexity=dzero
type(mld_z_onelev_type), allocatable :: precv(:) type(mld_z_onelev_type), allocatable :: precv(:)
contains contains
@ -159,6 +160,10 @@ module mld_z_prec_type
end subroutine mld_zprecaply1 end subroutine mld_zprecaply1
end interface end interface
interface mld_move_alloc
module procedure mld_zprec_move_alloc
end interface
contains contains
! !
! Function returning the size of the mld_prec_type data structure ! Function returning the size of the mld_prec_type data structure
@ -577,5 +582,32 @@ contains
end do end do
end subroutine mld_z_dump end subroutine mld_z_dump
subroutine mld_zprec_move_alloc(a, b,info)
use psb_base_mod
implicit none
type(mld_zprec_type), intent(inout) :: a
type(mld_zprec_type), intent(inout), target :: b
integer, intent(out) :: info
integer :: i
if (allocated(b%precv)) then
! This might not be required if FINAL procedures are available.
call mld_precfree(b,info)
if (info /= psb_success_) then
! ?????
!!$ return
endif
end if
call move_alloc(a%precv,b%precv)
! Fix the pointers except on level 1.
do i=2, size(b%precv)
b%precv(i)%base_a => b%precv(i)%ac
b%precv(i)%base_desc => b%precv(i)%desc_ac
b%precv(i)%map%p_desc_X => b%precv(i-1)%base_desc
b%precv(i)%map%p_desc_Y => b%precv(i)%base_desc
end do
end subroutine mld_zprec_move_alloc
end module mld_z_prec_type end module mld_z_prec_type

4
tests/pdegen/ppde2d.f90
Unescape Escape View File

@ -160,6 +160,7 @@ program ppde2d
character(len=16) :: aggr_alg ! local or global aggregation character(len=16) :: aggr_alg ! local or global aggregation
character(len=16) :: mltype ! additive or multiplicative 2nd level prec character(len=16) :: mltype ! additive or multiplicative 2nd level prec
character(len=16) :: smthpos ! side: pre, post, both smoothing character(len=16) :: smthpos ! side: pre, post, both smoothing
integer :: csize ! aggregation size at which to stop.
character(len=16) :: cmat ! coarse mat character(len=16) :: cmat ! coarse mat
character(len=16) :: csolve ! Coarse solver: bjac, umf, slu, sludist character(len=16) :: csolve ! Coarse solver: bjac, umf, slu, sludist
character(len=16) :: csbsolve ! Coarse subsolver: ILU, ILU(T), SuperLU, UMFPACK. character(len=16) :: csbsolve ! Coarse subsolver: ILU, ILU(T), SuperLU, UMFPACK.
@ -246,6 +247,7 @@ program ppde2d
call mld_precset(prec,mld_coarse_fillin_, prectype%cfill, info) call mld_precset(prec,mld_coarse_fillin_, prectype%cfill, info)
call mld_precset(prec,mld_coarse_iluthrs_, prectype%cthres, info) call mld_precset(prec,mld_coarse_iluthrs_, prectype%cthres, info)
call mld_precset(prec,mld_coarse_sweeps_, prectype%cjswp, info) call mld_precset(prec,mld_coarse_sweeps_, prectype%cjswp, info)
call mld_precset(prec,mld_coarse_aggr_size_, prectype%csize, info)
else else
nlv = 1 nlv = 1
call mld_precinit(prec,prectype%prec, info, nlev=nlv) call mld_precinit(prec,prectype%prec, info, nlev=nlv)
@ -386,6 +388,7 @@ contains
call read_data(prectype%cthres,5) ! Threshold for fact. 1 ILU(T) call read_data(prectype%cthres,5) ! Threshold for fact. 1 ILU(T)
call read_data(prectype%cjswp,5) ! Jacobi sweeps call read_data(prectype%cjswp,5) ! Jacobi sweeps
call read_data(prectype%athres,5) ! smoother aggr thresh call read_data(prectype%athres,5) ! smoother aggr thresh
call read_data(prectype%csize,5) ! coarse size
end if end if
end if end if
@ -423,6 +426,7 @@ contains
call psb_bcast(ictxt,prectype%cthres) ! Threshold for fact. 1 ILU(T) call psb_bcast(ictxt,prectype%cthres) ! Threshold for fact. 1 ILU(T)
call psb_bcast(ictxt,prectype%cjswp) ! Jacobi sweeps call psb_bcast(ictxt,prectype%cjswp) ! Jacobi sweeps
call psb_bcast(ictxt,prectype%athres) ! smoother aggr thresh call psb_bcast(ictxt,prectype%athres) ! smoother aggr thresh
call psb_bcast(ictxt,prectype%csize) ! coarse size
end if end if
if (iam == psb_root_) then if (iam == psb_root_) then

4
tests/pdegen/ppde3d.f90
Unescape Escape View File

@ -172,6 +172,7 @@ program ppde3d
character(len=16) :: aggr_alg ! local or global aggregation character(len=16) :: aggr_alg ! local or global aggregation
character(len=16) :: mltype ! additive or multiplicative 2nd level prec character(len=16) :: mltype ! additive or multiplicative 2nd level prec
character(len=16) :: smthpos ! side: pre, post, both smoothing character(len=16) :: smthpos ! side: pre, post, both smoothing
integer :: csize ! aggregation size at which to stop.
character(len=16) :: cmat ! coarse mat character(len=16) :: cmat ! coarse mat
character(len=16) :: csolve ! Coarse solver: bjac, umf, slu, sludist character(len=16) :: csolve ! Coarse solver: bjac, umf, slu, sludist
character(len=16) :: csbsolve ! Coarse subsolver: ILU, ILU(T), SuperLU, UMFPACK. character(len=16) :: csbsolve ! Coarse subsolver: ILU, ILU(T), SuperLU, UMFPACK.
@ -261,6 +262,7 @@ program ppde3d
call mld_precset(prec,mld_coarse_fillin_, prectype%cfill, info) call mld_precset(prec,mld_coarse_fillin_, prectype%cfill, info)
call mld_precset(prec,mld_coarse_iluthrs_, prectype%cthres, info) call mld_precset(prec,mld_coarse_iluthrs_, prectype%cthres, info)
call mld_precset(prec,mld_coarse_sweeps_, prectype%cjswp, info) call mld_precset(prec,mld_coarse_sweeps_, prectype%cjswp, info)
call mld_precset(prec,mld_coarse_aggr_size_, prectype%csize, info)
else else
nlv = 1 nlv = 1
call mld_precinit(prec,prectype%prec, info, nlev=nlv) call mld_precinit(prec,prectype%prec, info, nlev=nlv)
@ -401,6 +403,7 @@ contains
call read_data(prectype%cthres,5) ! Threshold for fact. 1 ILU(T) call read_data(prectype%cthres,5) ! Threshold for fact. 1 ILU(T)
call read_data(prectype%cjswp,5) ! Jacobi sweeps call read_data(prectype%cjswp,5) ! Jacobi sweeps
call read_data(prectype%athres,5) ! smoother aggr thresh call read_data(prectype%athres,5) ! smoother aggr thresh
call read_data(prectype%csize,5) ! coarse size
end if end if
end if end if
@ -438,6 +441,7 @@ contains
call psb_bcast(ictxt,prectype%cthres) ! Threshold for fact. 1 ILU(T) call psb_bcast(ictxt,prectype%cthres) ! Threshold for fact. 1 ILU(T)
call psb_bcast(ictxt,prectype%cjswp) ! Jacobi sweeps call psb_bcast(ictxt,prectype%cjswp) ! Jacobi sweeps
call psb_bcast(ictxt,prectype%athres) ! smoother aggr thresh call psb_bcast(ictxt,prectype%athres) ! smoother aggr thresh
call psb_bcast(ictxt,prectype%csize) ! coarse size
end if end if
if (iam == psb_root_) then if (iam == psb_root_) then

7
tests/pdegen/runs/ppde.inp
Unescape Escape View File

@ -1,6 +1,6 @@
BICGSTAB ! Iterative method: BiCGSTAB BiCG CGS RGMRES BiCGSTABL CG BICGSTAB ! Iterative method: BiCGSTAB BiCG CGS RGMRES BiCGSTABL CG
CSR ! Storage format CSR COO JAD CSR ! Storage format CSR COO JAD
040 ! IDIM; domain size is idim**3 060 ! IDIM; domain size is idim**3
2 ! ISTOPC 2 ! ISTOPC
0100 ! ITMAX 0100 ! ITMAX
-1 ! ITRACE -1 ! ITRACE
@ -17,14 +17,15 @@ ILU ! Subdomain solver DSCALE ILU MILU ILUT UMF SLU
4 ! Smoother/Jacobi sweeps 4 ! Smoother/Jacobi sweeps
BJAC ! Smoother type JACOBI BJAC AS; ignored for non-ML BJAC ! Smoother type JACOBI BJAC AS; ignored for non-ML
3 ! Number of levels in a multilevel preconditioner 3 ! Number of levels in a multilevel preconditioner
SMOOTHED ! Kind of aggregation: SMOOTHED, NONSMOOTHED NONSMOOTHED ! Kind of aggregation: SMOOTHED, NONSMOOTHED
DEC ! Type of aggregation DEC SYMDEC GLB DEC ! Type of aggregation DEC SYMDEC GLB
MULT ! Type of multilevel correction: ADD MULT MULT ! Type of multilevel correction: ADD MULT
TWOSIDE ! Side of correction PRE POST TWOSIDE (ignored for ADD) TWOSIDE ! Side of correction PRE POST TWOSIDE (ignored for ADD)
DIST ! Coarse level: matrix distribution DIST REPL REPL ! Coarse level: matrix distribution DIST REPL
BJAC ! Coarse level: solver JACOBI BJAC UMF SLU SLUDIST BJAC ! Coarse level: solver JACOBI BJAC UMF SLU SLUDIST
ILU ! Coarse level: subsolver DSCALE ILU UMF SLU SLUDIST ILU ! Coarse level: subsolver DSCALE ILU UMF SLU SLUDIST
1 ! Coarse level: Level-set N for ILU(N) 1 ! Coarse level: Level-set N for ILU(N)
1.d-4 ! Coarse level: Threshold T for ILU(T,P) 1.d-4 ! Coarse level: Threshold T for ILU(T,P)
4 ! Coarse level: Number of Jacobi sweeps 4 ! Coarse level: Number of Jacobi sweeps
-0.10d0 ! Smoother Aggregation Threshold: >= 0.0 default if <0 -0.10d0 ! Smoother Aggregation Threshold: >= 0.0 default if <0
100 ! Coarse size limit to determine levels. If <0, then use NL

4
tests/pdegen/spde2d.f90
Unescape Escape View File

@ -160,6 +160,7 @@ program spde2d
character(len=16) :: aggr_alg ! local or global aggregation character(len=16) :: aggr_alg ! local or global aggregation
character(len=16) :: mltype ! additive or multiplicative 2nd level prec character(len=16) :: mltype ! additive or multiplicative 2nd level prec
character(len=16) :: smthpos ! side: pre, post, both smoothing character(len=16) :: smthpos ! side: pre, post, both smoothing
integer :: csize ! aggregation size at which to stop.
character(len=16) :: cmat ! coarse mat character(len=16) :: cmat ! coarse mat
character(len=16) :: csolve ! Coarse solver: bjac, umf, slu, sludist character(len=16) :: csolve ! Coarse solver: bjac, umf, slu, sludist
character(len=16) :: csbsolve ! Coarse subsolver: ILU, ILU(T), SuperLU, UMFPACK. character(len=16) :: csbsolve ! Coarse subsolver: ILU, ILU(T), SuperLU, UMFPACK.
@ -246,6 +247,7 @@ program spde2d
call mld_precset(prec,mld_coarse_fillin_, prectype%cfill, info) call mld_precset(prec,mld_coarse_fillin_, prectype%cfill, info)
call mld_precset(prec,mld_coarse_iluthrs_, prectype%cthres, info) call mld_precset(prec,mld_coarse_iluthrs_, prectype%cthres, info)
call mld_precset(prec,mld_coarse_sweeps_, prectype%cjswp, info) call mld_precset(prec,mld_coarse_sweeps_, prectype%cjswp, info)
call mld_precset(prec,mld_coarse_aggr_size_, prectype%csize, info)
else else
nlv = 1 nlv = 1
call mld_precinit(prec,prectype%prec, info, nlev=nlv) call mld_precinit(prec,prectype%prec, info, nlev=nlv)
@ -386,6 +388,7 @@ contains
call read_data(prectype%cthres,5) ! Threshold for fact. 1 ILU(T) call read_data(prectype%cthres,5) ! Threshold for fact. 1 ILU(T)
call read_data(prectype%cjswp,5) ! Jacobi sweeps call read_data(prectype%cjswp,5) ! Jacobi sweeps
call read_data(prectype%athres,5) ! smoother aggr thresh call read_data(prectype%athres,5) ! smoother aggr thresh
call read_data(prectype%csize,5) ! coarse size
end if end if
end if end if
@ -423,6 +426,7 @@ contains
call psb_bcast(ictxt,prectype%cthres) ! Threshold for fact. 1 ILU(T) call psb_bcast(ictxt,prectype%cthres) ! Threshold for fact. 1 ILU(T)
call psb_bcast(ictxt,prectype%cjswp) ! Jacobi sweeps call psb_bcast(ictxt,prectype%cjswp) ! Jacobi sweeps
call psb_bcast(ictxt,prectype%athres) ! smoother aggr thresh call psb_bcast(ictxt,prectype%athres) ! smoother aggr thresh
call psb_bcast(ictxt,prectype%csize) ! coarse size
end if end if
if (iam == psb_root_) then if (iam == psb_root_) then

4
tests/pdegen/spde3d.f90
Unescape Escape View File

@ -172,6 +172,7 @@ program spde3d
character(len=16) :: aggr_alg ! local or global aggregation character(len=16) :: aggr_alg ! local or global aggregation
character(len=16) :: mltype ! additive or multiplicative 2nd level prec character(len=16) :: mltype ! additive or multiplicative 2nd level prec
character(len=16) :: smthpos ! side: pre, post, both smoothing character(len=16) :: smthpos ! side: pre, post, both smoothing
integer :: csize ! aggregation size at which to stop.
character(len=16) :: cmat ! coarse mat character(len=16) :: cmat ! coarse mat
character(len=16) :: csolve ! Coarse solver: bjac, umf, slu, sludist character(len=16) :: csolve ! Coarse solver: bjac, umf, slu, sludist
character(len=16) :: csbsolve ! Coarse subsolver: ILU, ILU(T), SuperLU, UMFPACK. character(len=16) :: csbsolve ! Coarse subsolver: ILU, ILU(T), SuperLU, UMFPACK.
@ -261,6 +262,7 @@ program spde3d
call mld_precset(prec,mld_coarse_fillin_, prectype%cfill, info) call mld_precset(prec,mld_coarse_fillin_, prectype%cfill, info)
call mld_precset(prec,mld_coarse_iluthrs_, prectype%cthres, info) call mld_precset(prec,mld_coarse_iluthrs_, prectype%cthres, info)
call mld_precset(prec,mld_coarse_sweeps_, prectype%cjswp, info) call mld_precset(prec,mld_coarse_sweeps_, prectype%cjswp, info)
call mld_precset(prec,mld_coarse_aggr_size_, prectype%csize, info)
else else
nlv = 1 nlv = 1
call mld_precinit(prec,prectype%prec, info, nlev=nlv) call mld_precinit(prec,prectype%prec, info, nlev=nlv)
@ -401,6 +403,7 @@ contains
call read_data(prectype%cthres,5) ! Threshold for fact. 1 ILU(T) call read_data(prectype%cthres,5) ! Threshold for fact. 1 ILU(T)
call read_data(prectype%cjswp,5) ! Jacobi sweeps call read_data(prectype%cjswp,5) ! Jacobi sweeps
call read_data(prectype%athres,5) ! smoother aggr thresh call read_data(prectype%athres,5) ! smoother aggr thresh
call read_data(prectype%csize,5) ! coarse size
end if end if
end if end if
@ -438,6 +441,7 @@ contains
call psb_bcast(ictxt,prectype%cthres) ! Threshold for fact. 1 ILU(T) call psb_bcast(ictxt,prectype%cthres) ! Threshold for fact. 1 ILU(T)
call psb_bcast(ictxt,prectype%cjswp) ! Jacobi sweeps call psb_bcast(ictxt,prectype%cjswp) ! Jacobi sweeps
call psb_bcast(ictxt,prectype%athres) ! smoother aggr thresh call psb_bcast(ictxt,prectype%athres) ! smoother aggr thresh
call psb_bcast(ictxt,prectype%csize) ! coarse size
end if end if
if (iam == psb_root_) then if (iam == psb_root_) then

Write Preview
Loading…
Cancel
Save