diff --git a/amgprec/amg_c_inner_mod.f90 b/amgprec/amg_c_inner_mod.f90 index 48208290..0275f273 100644 --- a/amgprec/amg_c_inner_mod.f90 +++ b/amgprec/amg_c_inner_mod.f90 @@ -67,7 +67,7 @@ module amg_c_inner_mod end interface amg_mlprec_bld interface amg_mlprec_aply - subroutine amg_cmlprec_aply(alpha,p,x,beta,y,desc_data,trans,work,info) + subroutine amg_cmlprec_aply_a(alpha,p,x,beta,y,desc_data,trans,work,info) import :: psb_cspmat_type, psb_desc_type, psb_spk_, psb_ipk_ import :: amg_cprec_type implicit none @@ -79,7 +79,7 @@ module amg_c_inner_mod character,intent(in) :: trans complex(psb_spk_),target :: work(:) integer(psb_ipk_), intent(out) :: info - end subroutine amg_cmlprec_aply + end subroutine amg_cmlprec_aply_a subroutine amg_cmlprec_aply_vect(alpha,p,x,beta,y,desc_data,trans,work,info) import :: psb_cspmat_type, psb_desc_type, & & psb_spk_, psb_c_vect_type, psb_ipk_ diff --git a/amgprec/amg_c_onelev_mod.f90 b/amgprec/amg_c_onelev_mod.f90 index 51c72174..f448a66c 100644 --- a/amgprec/amg_c_onelev_mod.f90 +++ b/amgprec/amg_c_onelev_mod.f90 @@ -807,7 +807,8 @@ contains info = psb_success_ call wk%free(info) write(0,*) 'wrk_alloc D: "',trim(desc%get_fmt()),'"', present(desc2),desc%is_valid() - + + allocate(wk%wv(nwv),stat=info) if (present(desc2).and.(desc%is_valid())) then write(0,*) 'wrk_alloc D2:',desc2%get_fmt(),desc2%is_asb() if (desc2%get_local_cols()>desc%get_local_cols()) then @@ -838,7 +839,6 @@ contains & scratch=.true.,mold=vmold) call psb_geasb(wk%vty,desc,info,& & scratch=.true.,mold=vmold) - allocate(wk%wv(nwv),stat=info) do i=1,nwv call psb_geasb(wk%wv(i),desc,info,& & scratch=.true.,mold=vmold) diff --git a/amgprec/amg_d_inner_mod.f90 b/amgprec/amg_d_inner_mod.f90 index 7f18cd0a..8498bac7 100644 --- a/amgprec/amg_d_inner_mod.f90 +++ b/amgprec/amg_d_inner_mod.f90 @@ -67,7 +67,7 @@ module amg_d_inner_mod end interface amg_mlprec_bld interface amg_mlprec_aply - subroutine amg_dmlprec_aply(alpha,p,x,beta,y,desc_data,trans,work,info) + subroutine amg_dmlprec_aply_a(alpha,p,x,beta,y,desc_data,trans,work,info) import :: psb_dspmat_type, psb_desc_type, psb_dpk_, psb_ipk_ import :: amg_dprec_type implicit none @@ -79,7 +79,7 @@ module amg_d_inner_mod character,intent(in) :: trans real(psb_dpk_),target :: work(:) integer(psb_ipk_), intent(out) :: info - end subroutine amg_dmlprec_aply + end subroutine amg_dmlprec_aply_a subroutine amg_dmlprec_aply_vect(alpha,p,x,beta,y,desc_data,trans,work,info) import :: psb_dspmat_type, psb_desc_type, & & psb_dpk_, psb_d_vect_type, psb_ipk_ diff --git a/amgprec/amg_d_onelev_mod.f90 b/amgprec/amg_d_onelev_mod.f90 index 8c874164..b73ee5f5 100644 --- a/amgprec/amg_d_onelev_mod.f90 +++ b/amgprec/amg_d_onelev_mod.f90 @@ -808,7 +808,8 @@ contains info = psb_success_ call wk%free(info) write(0,*) 'wrk_alloc D: "',trim(desc%get_fmt()),'"', present(desc2),desc%is_valid() - + + allocate(wk%wv(nwv),stat=info) if (present(desc2).and.(desc%is_valid())) then write(0,*) 'wrk_alloc D2:',desc2%get_fmt(),desc2%is_asb() if (desc2%get_local_cols()>desc%get_local_cols()) then @@ -839,7 +840,6 @@ contains & scratch=.true.,mold=vmold) call psb_geasb(wk%vty,desc,info,& & scratch=.true.,mold=vmold) - allocate(wk%wv(nwv),stat=info) do i=1,nwv call psb_geasb(wk%wv(i),desc,info,& & scratch=.true.,mold=vmold) diff --git a/amgprec/amg_s_inner_mod.f90 b/amgprec/amg_s_inner_mod.f90 index 3c5c1ca0..ca743e6b 100644 --- a/amgprec/amg_s_inner_mod.f90 +++ b/amgprec/amg_s_inner_mod.f90 @@ -67,7 +67,7 @@ module amg_s_inner_mod end interface amg_mlprec_bld interface amg_mlprec_aply - subroutine amg_smlprec_aply(alpha,p,x,beta,y,desc_data,trans,work,info) + subroutine amg_smlprec_aply_a(alpha,p,x,beta,y,desc_data,trans,work,info) import :: psb_sspmat_type, psb_desc_type, psb_spk_, psb_ipk_ import :: amg_sprec_type implicit none @@ -79,7 +79,7 @@ module amg_s_inner_mod character,intent(in) :: trans real(psb_spk_),target :: work(:) integer(psb_ipk_), intent(out) :: info - end subroutine amg_smlprec_aply + end subroutine amg_smlprec_aply_a subroutine amg_smlprec_aply_vect(alpha,p,x,beta,y,desc_data,trans,work,info) import :: psb_sspmat_type, psb_desc_type, & & psb_spk_, psb_s_vect_type, psb_ipk_ diff --git a/amgprec/amg_s_onelev_mod.f90 b/amgprec/amg_s_onelev_mod.f90 index 60c1ec67..dd5cff75 100644 --- a/amgprec/amg_s_onelev_mod.f90 +++ b/amgprec/amg_s_onelev_mod.f90 @@ -808,7 +808,8 @@ contains info = psb_success_ call wk%free(info) write(0,*) 'wrk_alloc D: "',trim(desc%get_fmt()),'"', present(desc2),desc%is_valid() - + + allocate(wk%wv(nwv),stat=info) if (present(desc2).and.(desc%is_valid())) then write(0,*) 'wrk_alloc D2:',desc2%get_fmt(),desc2%is_asb() if (desc2%get_local_cols()>desc%get_local_cols()) then @@ -839,7 +840,6 @@ contains & scratch=.true.,mold=vmold) call psb_geasb(wk%vty,desc,info,& & scratch=.true.,mold=vmold) - allocate(wk%wv(nwv),stat=info) do i=1,nwv call psb_geasb(wk%wv(i),desc,info,& & scratch=.true.,mold=vmold) diff --git a/amgprec/amg_z_inner_mod.f90 b/amgprec/amg_z_inner_mod.f90 index c5e3112f..8046a759 100644 --- a/amgprec/amg_z_inner_mod.f90 +++ b/amgprec/amg_z_inner_mod.f90 @@ -67,7 +67,7 @@ module amg_z_inner_mod end interface amg_mlprec_bld interface amg_mlprec_aply - subroutine amg_zmlprec_aply(alpha,p,x,beta,y,desc_data,trans,work,info) + subroutine amg_zmlprec_aply_a(alpha,p,x,beta,y,desc_data,trans,work,info) import :: psb_zspmat_type, psb_desc_type, psb_dpk_, psb_ipk_ import :: amg_zprec_type implicit none @@ -79,7 +79,7 @@ module amg_z_inner_mod character,intent(in) :: trans complex(psb_dpk_),target :: work(:) integer(psb_ipk_), intent(out) :: info - end subroutine amg_zmlprec_aply + end subroutine amg_zmlprec_aply_a subroutine amg_zmlprec_aply_vect(alpha,p,x,beta,y,desc_data,trans,work,info) import :: psb_zspmat_type, psb_desc_type, & & psb_dpk_, psb_z_vect_type, psb_ipk_ diff --git a/amgprec/amg_z_onelev_mod.f90 b/amgprec/amg_z_onelev_mod.f90 index b9bf041d..7c54f113 100644 --- a/amgprec/amg_z_onelev_mod.f90 +++ b/amgprec/amg_z_onelev_mod.f90 @@ -807,7 +807,8 @@ contains info = psb_success_ call wk%free(info) write(0,*) 'wrk_alloc D: "',trim(desc%get_fmt()),'"', present(desc2),desc%is_valid() - + + allocate(wk%wv(nwv),stat=info) if (present(desc2).and.(desc%is_valid())) then write(0,*) 'wrk_alloc D2:',desc2%get_fmt(),desc2%is_asb() if (desc2%get_local_cols()>desc%get_local_cols()) then @@ -838,7 +839,6 @@ contains & scratch=.true.,mold=vmold) call psb_geasb(wk%vty,desc,info,& & scratch=.true.,mold=vmold) - allocate(wk%wv(nwv),stat=info) do i=1,nwv call psb_geasb(wk%wv(i),desc,info,& & scratch=.true.,mold=vmold) diff --git a/amgprec/impl/Makefile b/amgprec/impl/Makefile index 0c08f070..85b3c3c4 100644 --- a/amgprec/impl/Makefile +++ b/amgprec/impl/Makefile @@ -25,22 +25,22 @@ MPCOBJS=amg_dslud_interface.o amg_zslud_interface.o DINNEROBJS= amg_dmlprec_bld.o amg_dfile_prec_descr.o amg_dfile_prec_memory_use.o \ amg_d_smoothers_bld.o amg_d_hierarchy_bld.o amg_d_hierarchy_rebld.o \ - amg_dmlprec_aply.o \ + amg_dmlprec_aply.o amg_dmlprec_aply_a.o \ $(DMPFOBJS) amg_d_extprol_bld.o SINNEROBJS= amg_smlprec_bld.o amg_sfile_prec_descr.o amg_sfile_prec_memory_use.o \ amg_s_smoothers_bld.o amg_s_hierarchy_bld.o amg_s_hierarchy_rebld.o \ - amg_smlprec_aply.o \ + amg_smlprec_aply.o amg_smlprec_aply_a.o \ $(SMPFOBJS) amg_s_extprol_bld.o ZINNEROBJS= amg_zmlprec_bld.o amg_zfile_prec_descr.o amg_zfile_prec_memory_use.o \ amg_z_smoothers_bld.o amg_z_hierarchy_bld.o amg_z_hierarchy_rebld.o \ - amg_zmlprec_aply.o \ + amg_zmlprec_aply.o amg_zmlprec_aply_a.o \ $(ZMPFOBJS) amg_z_extprol_bld.o CINNEROBJS= amg_cmlprec_bld.o amg_cfile_prec_descr.o amg_cfile_prec_memory_use.o \ amg_c_smoothers_bld.o amg_c_hierarchy_bld.o amg_c_hierarchy_rebld.o \ - amg_cmlprec_aply.o \ + amg_cmlprec_aply.o amg_cmlprec_aply_a.o \ $(CMPFOBJS) amg_c_extprol_bld.o INNEROBJS= $(SINNEROBJS) $(DINNEROBJS) $(CINNEROBJS) $(ZINNEROBJS) diff --git a/amgprec/impl/aggregator/amg_c_dec_aggregator_mat_asb.f90 b/amgprec/impl/aggregator/amg_c_dec_aggregator_mat_asb.f90 index 336bc4de..2b8674cd 100644 --- a/amgprec/impl/aggregator/amg_c_dec_aggregator_mat_asb.f90 +++ b/amgprec/impl/aggregator/amg_c_dec_aggregator_mat_asb.f90 @@ -114,63 +114,67 @@ subroutine amg_c_dec_aggregator_mat_asb(ag,parms,a,desc_a,& info = psb_success_ ctxt = desc_a%get_context() call psb_info(ctxt,me,np) - - select case(parms%coarse_mat) - - case(amg_distr_mat_) - - call ac%cscnv(info,type='csr') - call op_prol%cscnv(info,type='csr') - call op_restr%cscnv(info,type='csr') - - if (debug_level >= psb_debug_outer_) & - & write(debug_unit,*) me,' ',trim(name),& - & 'Done ac ' - - case(amg_repl_mat_) - ! - ! We are assuming here that an c matrix - ! can hold all entries - ! - if (desc_ac%get_global_rows() < huge(1_psb_ipk_) ) then - ntaggr = desc_ac%get_global_rows() - i_nr = ntaggr - else + + if (me >=0) then + select case(parms%coarse_mat) + + case(amg_distr_mat_) + + call ac%cscnv(info,type='csr') + call op_prol%cscnv(info,type='csr') + call op_restr%cscnv(info,type='csr') + + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & 'Done ac ' + + case(amg_repl_mat_) + ! + ! We are assuming here that an c matrix + ! can hold all entries + ! + if (desc_ac%get_global_rows() < huge(1_psb_ipk_) ) then + ntaggr = desc_ac%get_global_rows() + i_nr = ntaggr + else + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='invalid amg_coarse_mat_') + goto 9999 + end if + + call op_prol%mv_to(tmpcoo) + nzl = tmpcoo%get_nzeros() + call psb_loc_to_glob(tmpcoo%ja(1:nzl),desc_ac,info,'I') + call tmpcoo%set_ncols(i_nr) + call op_prol%mv_from(tmpcoo) + + call op_restr%mv_to(tmpcoo) + nzl = tmpcoo%get_nzeros() + call psb_loc_to_glob(tmpcoo%ia(1:nzl),desc_ac,info,'I') + call tmpcoo%set_nrows(i_nr) + call op_restr%mv_from(tmpcoo) + + + call psb_gather(tmp_ac,ac,desc_ac,info,root=-ione,& + & dupl=psb_dupl_add_,keeploc=.false.) + call tmp_ac%mv_to(tmpcoo) + call ac%mv_from(tmpcoo) + + call psb_cdall(ctxt,desc_ac,info,mg=ntaggr,repl=.true.) + if (info == psb_success_) call psb_cdasb(desc_ac,info) + + if (info /= psb_success_) goto 9999 + + case default info = psb_err_internal_error_ call psb_errpush(info,name,a_err='invalid amg_coarse_mat_') goto 9999 - end if - - call op_prol%mv_to(tmpcoo) - nzl = tmpcoo%get_nzeros() - call psb_loc_to_glob(tmpcoo%ja(1:nzl),desc_ac,info,'I') - call tmpcoo%set_ncols(i_nr) - call op_prol%mv_from(tmpcoo) - - call op_restr%mv_to(tmpcoo) - nzl = tmpcoo%get_nzeros() - call psb_loc_to_glob(tmpcoo%ia(1:nzl),desc_ac,info,'I') - call tmpcoo%set_nrows(i_nr) - call op_restr%mv_from(tmpcoo) - - - call psb_gather(tmp_ac,ac,desc_ac,info,root=-ione,& - & dupl=psb_dupl_add_,keeploc=.false.) - call tmp_ac%mv_to(tmpcoo) - call ac%mv_from(tmpcoo) - - call psb_cdall(ctxt,desc_ac,info,mg=ntaggr,repl=.true.) - if (info == psb_success_) call psb_cdasb(desc_ac,info) - - if (info /= psb_success_) goto 9999 - - case default - info = psb_err_internal_error_ - call psb_errpush(info,name,a_err='invalid amg_coarse_mat_') - goto 9999 - end select - - + end select + else + call op_prol%allocate(izero,izero,info) + call op_restr%allocate(izero,izero,info) + call ac%allocate(izero,izero,info) + end if call psb_erractionrestore(err_act) return diff --git a/amgprec/impl/aggregator/amg_c_dec_aggregator_mat_bld.f90 b/amgprec/impl/aggregator/amg_c_dec_aggregator_mat_bld.f90 index eb0451d0..caa553da 100644 --- a/amgprec/impl/aggregator/amg_c_dec_aggregator_mat_bld.f90 +++ b/amgprec/impl/aggregator/amg_c_dec_aggregator_mat_bld.f90 @@ -139,7 +139,7 @@ subroutine amg_c_dec_aggregator_mat_bld(ag,parms,a,desc_a,ilaggr,nlaggr,& use amg_c_prec_type, amg_protect_name => amg_c_dec_aggregator_mat_bld use amg_c_inner_mod implicit none - + class(amg_c_dec_aggregator_type), target, intent(inout) :: ag type(amg_sml_parms), intent(inout) :: parms type(psb_cspmat_type), intent(in) :: a @@ -169,39 +169,46 @@ subroutine amg_c_dec_aggregator_mat_bld(ag,parms,a,desc_a,ilaggr,nlaggr,& ctxt = desc_a%get_context() call psb_info(ctxt,me,np) - ! - ! Build the coarse-level matrix from the fine-level one, starting from - ! the mapping defined by amg_aggrmap_bld and applying the aggregation - ! algorithm specified by - ! - select case (parms%aggr_prol) - case (amg_no_smooth_) + if (me >=0) then + ! + ! Build the coarse-level matrix from the fine-level one, starting from + ! the mapping defined by amg_aggrmap_bld and applying the aggregation + ! algorithm specified by + ! + select case (parms%aggr_prol) + case (amg_no_smooth_) - call amg_caggrmat_nosmth_bld(parms%aggr_prol,a,desc_a,ilaggr,& - nlaggr,parms,ac,desc_ac,op_prol,op_restr,t_prol,info) + call amg_caggrmat_nosmth_bld(parms%aggr_prol,a,desc_a,ilaggr,& + nlaggr,parms,ac,desc_ac,op_prol,op_restr,t_prol,info) - case(amg_smooth_prol_,amg_l1_smooth_prol_) + case(amg_smooth_prol_,amg_l1_smooth_prol_) - call amg_caggrmat_smth_bld(parms%aggr_prol,a,desc_a,& - ilaggr,nlaggr,parms,ac,desc_ac,op_prol,& - op_restr,t_prol,info) + call amg_caggrmat_smth_bld(parms%aggr_prol,a,desc_a,& + ilaggr,nlaggr,parms,ac,desc_ac,op_prol,& + op_restr,t_prol,info) !!$ case(amg_biz_prol_) !!$ !!$ call amg_caggrmat_biz_bld(a,desc_a,ilaggr,nlaggr, & !!$ & parms,ac,desc_ac,op_prol,op_restr,t_prol,info) - - case(amg_min_energy_) - call amg_caggrmat_minnrg_bld(parms%aggr_prol,a,desc_a,ilaggr,& - nlaggr,parms,ac,desc_ac,op_prol,op_restr,t_prol,info) + case(amg_min_energy_) - case default - info = psb_err_internal_error_ - call psb_errpush(info,name,a_err='Invalid aggr kind') - goto 9999 + call amg_caggrmat_minnrg_bld(parms%aggr_prol,a,desc_a,ilaggr,& + nlaggr,parms,ac,desc_ac,op_prol,op_restr,t_prol,info) + + case default + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='Invalid aggr kind') + goto 9999 + + end select + else + call op_prol%allocate(izero,izero,info) + call op_restr%allocate(izero,izero,info) + call ac%allocate(izero,izero,info) + end if - end select if (info /= psb_success_) then call psb_errpush(psb_err_from_subroutine_,name,a_err='Inner aggrmat bld') goto 9999 @@ -214,5 +221,5 @@ subroutine amg_c_dec_aggregator_mat_bld(ag,parms,a,desc_a,ilaggr,nlaggr,& 9999 call psb_error_handler(err_act) return - + end subroutine amg_c_dec_aggregator_mat_bld diff --git a/amgprec/impl/aggregator/amg_c_dec_aggregator_tprol.f90 b/amgprec/impl/aggregator/amg_c_dec_aggregator_tprol.f90 index b17f74d4..66b77e77 100644 --- a/amgprec/impl/aggregator/amg_c_dec_aggregator_tprol.f90 +++ b/amgprec/impl/aggregator/amg_c_dec_aggregator_tprol.f90 @@ -122,19 +122,23 @@ subroutine amg_c_dec_aggregator_build_tprol(ag,parms,ag_data,& call amg_check_def(parms%aggr_ord,'Ordering',& & amg_aggr_ord_nat_,is_legal_ml_aggr_ord) call amg_check_def(parms%aggr_thresh,'Aggr_Thresh',szero,is_legal_s_aggr_thrs) + if (me >=0) then + ! + ! The decoupled aggregator based on SOC measures ignores + ! ag_data except for clean_zeros; soc_map_bld is a procedure pointer. + ! + if (do_timings) call psb_tic(idx_map_bld) + clean_zeros = ag%do_clean_zeros + call ag%soc_map_bld(parms%aggr_ord,parms%aggr_thresh,clean_zeros,a,desc_a,nlaggr,ilaggr,info) + if (do_timings) call psb_toc(idx_map_bld) + if (do_timings) call psb_tic(idx_map_tprol) - ! - ! The decoupled aggregator based on SOC measures ignores - ! ag_data except for clean_zeros; soc_map_bld is a procedure pointer. - ! - if (do_timings) call psb_tic(idx_map_bld) - clean_zeros = ag%do_clean_zeros - call ag%soc_map_bld(parms%aggr_ord,parms%aggr_thresh,clean_zeros,a,desc_a,nlaggr,ilaggr,info) - if (do_timings) call psb_toc(idx_map_bld) - if (do_timings) call psb_tic(idx_map_tprol) - - if (info==psb_success_) call amg_map_to_tprol(desc_a,ilaggr,nlaggr,t_prol,info) - if (do_timings) call psb_toc(idx_map_tprol) + if (info==psb_success_) call amg_map_to_tprol(desc_a,ilaggr,nlaggr,t_prol,info) + if (do_timings) call psb_toc(idx_map_tprol) + else + allocate(nlaggr(0),ilaggr(0)) + call t_prol%allocate(lzero,lzero,info) + end if if (info /= psb_success_) then info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='soc_map_bld/map_to_tprol') diff --git a/amgprec/impl/aggregator/amg_d_dec_aggregator_mat_asb.f90 b/amgprec/impl/aggregator/amg_d_dec_aggregator_mat_asb.f90 index 78539cdf..eafc74d5 100644 --- a/amgprec/impl/aggregator/amg_d_dec_aggregator_mat_asb.f90 +++ b/amgprec/impl/aggregator/amg_d_dec_aggregator_mat_asb.f90 @@ -114,63 +114,67 @@ subroutine amg_d_dec_aggregator_mat_asb(ag,parms,a,desc_a,& info = psb_success_ ctxt = desc_a%get_context() call psb_info(ctxt,me,np) - - select case(parms%coarse_mat) - - case(amg_distr_mat_) - - call ac%cscnv(info,type='csr') - call op_prol%cscnv(info,type='csr') - call op_restr%cscnv(info,type='csr') - - if (debug_level >= psb_debug_outer_) & - & write(debug_unit,*) me,' ',trim(name),& - & 'Done ac ' - - case(amg_repl_mat_) - ! - ! We are assuming here that an d matrix - ! can hold all entries - ! - if (desc_ac%get_global_rows() < huge(1_psb_ipk_) ) then - ntaggr = desc_ac%get_global_rows() - i_nr = ntaggr - else + + if (me >=0) then + select case(parms%coarse_mat) + + case(amg_distr_mat_) + + call ac%cscnv(info,type='csr') + call op_prol%cscnv(info,type='csr') + call op_restr%cscnv(info,type='csr') + + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & 'Done ac ' + + case(amg_repl_mat_) + ! + ! We are assuming here that an d matrix + ! can hold all entries + ! + if (desc_ac%get_global_rows() < huge(1_psb_ipk_) ) then + ntaggr = desc_ac%get_global_rows() + i_nr = ntaggr + else + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='invalid amg_coarse_mat_') + goto 9999 + end if + + call op_prol%mv_to(tmpcoo) + nzl = tmpcoo%get_nzeros() + call psb_loc_to_glob(tmpcoo%ja(1:nzl),desc_ac,info,'I') + call tmpcoo%set_ncols(i_nr) + call op_prol%mv_from(tmpcoo) + + call op_restr%mv_to(tmpcoo) + nzl = tmpcoo%get_nzeros() + call psb_loc_to_glob(tmpcoo%ia(1:nzl),desc_ac,info,'I') + call tmpcoo%set_nrows(i_nr) + call op_restr%mv_from(tmpcoo) + + + call psb_gather(tmp_ac,ac,desc_ac,info,root=-ione,& + & dupl=psb_dupl_add_,keeploc=.false.) + call tmp_ac%mv_to(tmpcoo) + call ac%mv_from(tmpcoo) + + call psb_cdall(ctxt,desc_ac,info,mg=ntaggr,repl=.true.) + if (info == psb_success_) call psb_cdasb(desc_ac,info) + + if (info /= psb_success_) goto 9999 + + case default info = psb_err_internal_error_ call psb_errpush(info,name,a_err='invalid amg_coarse_mat_') goto 9999 - end if - - call op_prol%mv_to(tmpcoo) - nzl = tmpcoo%get_nzeros() - call psb_loc_to_glob(tmpcoo%ja(1:nzl),desc_ac,info,'I') - call tmpcoo%set_ncols(i_nr) - call op_prol%mv_from(tmpcoo) - - call op_restr%mv_to(tmpcoo) - nzl = tmpcoo%get_nzeros() - call psb_loc_to_glob(tmpcoo%ia(1:nzl),desc_ac,info,'I') - call tmpcoo%set_nrows(i_nr) - call op_restr%mv_from(tmpcoo) - - - call psb_gather(tmp_ac,ac,desc_ac,info,root=-ione,& - & dupl=psb_dupl_add_,keeploc=.false.) - call tmp_ac%mv_to(tmpcoo) - call ac%mv_from(tmpcoo) - - call psb_cdall(ctxt,desc_ac,info,mg=ntaggr,repl=.true.) - if (info == psb_success_) call psb_cdasb(desc_ac,info) - - if (info /= psb_success_) goto 9999 - - case default - info = psb_err_internal_error_ - call psb_errpush(info,name,a_err='invalid amg_coarse_mat_') - goto 9999 - end select - - + end select + else + call op_prol%allocate(izero,izero,info) + call op_restr%allocate(izero,izero,info) + call ac%allocate(izero,izero,info) + end if call psb_erractionrestore(err_act) return diff --git a/amgprec/impl/aggregator/amg_d_dec_aggregator_mat_bld.f90 b/amgprec/impl/aggregator/amg_d_dec_aggregator_mat_bld.f90 index cf2a1d2b..426430a2 100644 --- a/amgprec/impl/aggregator/amg_d_dec_aggregator_mat_bld.f90 +++ b/amgprec/impl/aggregator/amg_d_dec_aggregator_mat_bld.f90 @@ -139,7 +139,7 @@ subroutine amg_d_dec_aggregator_mat_bld(ag,parms,a,desc_a,ilaggr,nlaggr,& use amg_d_prec_type, amg_protect_name => amg_d_dec_aggregator_mat_bld use amg_d_inner_mod implicit none - + class(amg_d_dec_aggregator_type), target, intent(inout) :: ag type(amg_dml_parms), intent(inout) :: parms type(psb_dspmat_type), intent(in) :: a @@ -169,39 +169,46 @@ subroutine amg_d_dec_aggregator_mat_bld(ag,parms,a,desc_a,ilaggr,nlaggr,& ctxt = desc_a%get_context() call psb_info(ctxt,me,np) - ! - ! Build the coarse-level matrix from the fine-level one, starting from - ! the mapping defined by amg_aggrmap_bld and applying the aggregation - ! algorithm specified by - ! - select case (parms%aggr_prol) - case (amg_no_smooth_) + if (me >=0) then + ! + ! Build the coarse-level matrix from the fine-level one, starting from + ! the mapping defined by amg_aggrmap_bld and applying the aggregation + ! algorithm specified by + ! + select case (parms%aggr_prol) + case (amg_no_smooth_) - call amg_daggrmat_nosmth_bld(parms%aggr_prol,a,desc_a,ilaggr,& - nlaggr,parms,ac,desc_ac,op_prol,op_restr,t_prol,info) + call amg_daggrmat_nosmth_bld(parms%aggr_prol,a,desc_a,ilaggr,& + nlaggr,parms,ac,desc_ac,op_prol,op_restr,t_prol,info) - case(amg_smooth_prol_,amg_l1_smooth_prol_) + case(amg_smooth_prol_,amg_l1_smooth_prol_) - call amg_daggrmat_smth_bld(parms%aggr_prol,a,desc_a,& - ilaggr,nlaggr,parms,ac,desc_ac,op_prol,& - op_restr,t_prol,info) + call amg_daggrmat_smth_bld(parms%aggr_prol,a,desc_a,& + ilaggr,nlaggr,parms,ac,desc_ac,op_prol,& + op_restr,t_prol,info) !!$ case(amg_biz_prol_) !!$ !!$ call amg_daggrmat_biz_bld(a,desc_a,ilaggr,nlaggr, & !!$ & parms,ac,desc_ac,op_prol,op_restr,t_prol,info) - - case(amg_min_energy_) - call amg_daggrmat_minnrg_bld(parms%aggr_prol,a,desc_a,ilaggr,& - nlaggr,parms,ac,desc_ac,op_prol,op_restr,t_prol,info) + case(amg_min_energy_) - case default - info = psb_err_internal_error_ - call psb_errpush(info,name,a_err='Invalid aggr kind') - goto 9999 + call amg_daggrmat_minnrg_bld(parms%aggr_prol,a,desc_a,ilaggr,& + nlaggr,parms,ac,desc_ac,op_prol,op_restr,t_prol,info) + + case default + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='Invalid aggr kind') + goto 9999 + + end select + else + call op_prol%allocate(izero,izero,info) + call op_restr%allocate(izero,izero,info) + call ac%allocate(izero,izero,info) + end if - end select if (info /= psb_success_) then call psb_errpush(psb_err_from_subroutine_,name,a_err='Inner aggrmat bld') goto 9999 @@ -214,5 +221,5 @@ subroutine amg_d_dec_aggregator_mat_bld(ag,parms,a,desc_a,ilaggr,nlaggr,& 9999 call psb_error_handler(err_act) return - + end subroutine amg_d_dec_aggregator_mat_bld diff --git a/amgprec/impl/aggregator/amg_d_dec_aggregator_tprol.f90 b/amgprec/impl/aggregator/amg_d_dec_aggregator_tprol.f90 index b77beea6..83d3746c 100644 --- a/amgprec/impl/aggregator/amg_d_dec_aggregator_tprol.f90 +++ b/amgprec/impl/aggregator/amg_d_dec_aggregator_tprol.f90 @@ -122,19 +122,23 @@ subroutine amg_d_dec_aggregator_build_tprol(ag,parms,ag_data,& call amg_check_def(parms%aggr_ord,'Ordering',& & amg_aggr_ord_nat_,is_legal_ml_aggr_ord) call amg_check_def(parms%aggr_thresh,'Aggr_Thresh',dzero,is_legal_d_aggr_thrs) + if (me >=0) then + ! + ! The decoupled aggregator based on SOC measures ignores + ! ag_data except for clean_zeros; soc_map_bld is a procedure pointer. + ! + if (do_timings) call psb_tic(idx_map_bld) + clean_zeros = ag%do_clean_zeros + call ag%soc_map_bld(parms%aggr_ord,parms%aggr_thresh,clean_zeros,a,desc_a,nlaggr,ilaggr,info) + if (do_timings) call psb_toc(idx_map_bld) + if (do_timings) call psb_tic(idx_map_tprol) - ! - ! The decoupled aggregator based on SOC measures ignores - ! ag_data except for clean_zeros; soc_map_bld is a procedure pointer. - ! - if (do_timings) call psb_tic(idx_map_bld) - clean_zeros = ag%do_clean_zeros - call ag%soc_map_bld(parms%aggr_ord,parms%aggr_thresh,clean_zeros,a,desc_a,nlaggr,ilaggr,info) - if (do_timings) call psb_toc(idx_map_bld) - if (do_timings) call psb_tic(idx_map_tprol) - - if (info==psb_success_) call amg_map_to_tprol(desc_a,ilaggr,nlaggr,t_prol,info) - if (do_timings) call psb_toc(idx_map_tprol) + if (info==psb_success_) call amg_map_to_tprol(desc_a,ilaggr,nlaggr,t_prol,info) + if (do_timings) call psb_toc(idx_map_tprol) + else + allocate(nlaggr(0),ilaggr(0)) + call t_prol%allocate(lzero,lzero,info) + end if if (info /= psb_success_) then info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='soc_map_bld/map_to_tprol') diff --git a/amgprec/impl/aggregator/amg_s_dec_aggregator_mat_asb.f90 b/amgprec/impl/aggregator/amg_s_dec_aggregator_mat_asb.f90 index 9711a135..16546a28 100644 --- a/amgprec/impl/aggregator/amg_s_dec_aggregator_mat_asb.f90 +++ b/amgprec/impl/aggregator/amg_s_dec_aggregator_mat_asb.f90 @@ -114,63 +114,67 @@ subroutine amg_s_dec_aggregator_mat_asb(ag,parms,a,desc_a,& info = psb_success_ ctxt = desc_a%get_context() call psb_info(ctxt,me,np) - - select case(parms%coarse_mat) - - case(amg_distr_mat_) - - call ac%cscnv(info,type='csr') - call op_prol%cscnv(info,type='csr') - call op_restr%cscnv(info,type='csr') - - if (debug_level >= psb_debug_outer_) & - & write(debug_unit,*) me,' ',trim(name),& - & 'Done ac ' - - case(amg_repl_mat_) - ! - ! We are assuming here that an s matrix - ! can hold all entries - ! - if (desc_ac%get_global_rows() < huge(1_psb_ipk_) ) then - ntaggr = desc_ac%get_global_rows() - i_nr = ntaggr - else + + if (me >=0) then + select case(parms%coarse_mat) + + case(amg_distr_mat_) + + call ac%cscnv(info,type='csr') + call op_prol%cscnv(info,type='csr') + call op_restr%cscnv(info,type='csr') + + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & 'Done ac ' + + case(amg_repl_mat_) + ! + ! We are assuming here that an s matrix + ! can hold all entries + ! + if (desc_ac%get_global_rows() < huge(1_psb_ipk_) ) then + ntaggr = desc_ac%get_global_rows() + i_nr = ntaggr + else + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='invalid amg_coarse_mat_') + goto 9999 + end if + + call op_prol%mv_to(tmpcoo) + nzl = tmpcoo%get_nzeros() + call psb_loc_to_glob(tmpcoo%ja(1:nzl),desc_ac,info,'I') + call tmpcoo%set_ncols(i_nr) + call op_prol%mv_from(tmpcoo) + + call op_restr%mv_to(tmpcoo) + nzl = tmpcoo%get_nzeros() + call psb_loc_to_glob(tmpcoo%ia(1:nzl),desc_ac,info,'I') + call tmpcoo%set_nrows(i_nr) + call op_restr%mv_from(tmpcoo) + + + call psb_gather(tmp_ac,ac,desc_ac,info,root=-ione,& + & dupl=psb_dupl_add_,keeploc=.false.) + call tmp_ac%mv_to(tmpcoo) + call ac%mv_from(tmpcoo) + + call psb_cdall(ctxt,desc_ac,info,mg=ntaggr,repl=.true.) + if (info == psb_success_) call psb_cdasb(desc_ac,info) + + if (info /= psb_success_) goto 9999 + + case default info = psb_err_internal_error_ call psb_errpush(info,name,a_err='invalid amg_coarse_mat_') goto 9999 - end if - - call op_prol%mv_to(tmpcoo) - nzl = tmpcoo%get_nzeros() - call psb_loc_to_glob(tmpcoo%ja(1:nzl),desc_ac,info,'I') - call tmpcoo%set_ncols(i_nr) - call op_prol%mv_from(tmpcoo) - - call op_restr%mv_to(tmpcoo) - nzl = tmpcoo%get_nzeros() - call psb_loc_to_glob(tmpcoo%ia(1:nzl),desc_ac,info,'I') - call tmpcoo%set_nrows(i_nr) - call op_restr%mv_from(tmpcoo) - - - call psb_gather(tmp_ac,ac,desc_ac,info,root=-ione,& - & dupl=psb_dupl_add_,keeploc=.false.) - call tmp_ac%mv_to(tmpcoo) - call ac%mv_from(tmpcoo) - - call psb_cdall(ctxt,desc_ac,info,mg=ntaggr,repl=.true.) - if (info == psb_success_) call psb_cdasb(desc_ac,info) - - if (info /= psb_success_) goto 9999 - - case default - info = psb_err_internal_error_ - call psb_errpush(info,name,a_err='invalid amg_coarse_mat_') - goto 9999 - end select - - + end select + else + call op_prol%allocate(izero,izero,info) + call op_restr%allocate(izero,izero,info) + call ac%allocate(izero,izero,info) + end if call psb_erractionrestore(err_act) return diff --git a/amgprec/impl/aggregator/amg_s_dec_aggregator_mat_bld.f90 b/amgprec/impl/aggregator/amg_s_dec_aggregator_mat_bld.f90 index 0d0e7ee0..df52b5d3 100644 --- a/amgprec/impl/aggregator/amg_s_dec_aggregator_mat_bld.f90 +++ b/amgprec/impl/aggregator/amg_s_dec_aggregator_mat_bld.f90 @@ -139,7 +139,7 @@ subroutine amg_s_dec_aggregator_mat_bld(ag,parms,a,desc_a,ilaggr,nlaggr,& use amg_s_prec_type, amg_protect_name => amg_s_dec_aggregator_mat_bld use amg_s_inner_mod implicit none - + class(amg_s_dec_aggregator_type), target, intent(inout) :: ag type(amg_sml_parms), intent(inout) :: parms type(psb_sspmat_type), intent(in) :: a @@ -169,39 +169,46 @@ subroutine amg_s_dec_aggregator_mat_bld(ag,parms,a,desc_a,ilaggr,nlaggr,& ctxt = desc_a%get_context() call psb_info(ctxt,me,np) - ! - ! Build the coarse-level matrix from the fine-level one, starting from - ! the mapping defined by amg_aggrmap_bld and applying the aggregation - ! algorithm specified by - ! - select case (parms%aggr_prol) - case (amg_no_smooth_) + if (me >=0) then + ! + ! Build the coarse-level matrix from the fine-level one, starting from + ! the mapping defined by amg_aggrmap_bld and applying the aggregation + ! algorithm specified by + ! + select case (parms%aggr_prol) + case (amg_no_smooth_) - call amg_saggrmat_nosmth_bld(parms%aggr_prol,a,desc_a,ilaggr,& - nlaggr,parms,ac,desc_ac,op_prol,op_restr,t_prol,info) + call amg_saggrmat_nosmth_bld(parms%aggr_prol,a,desc_a,ilaggr,& + nlaggr,parms,ac,desc_ac,op_prol,op_restr,t_prol,info) - case(amg_smooth_prol_,amg_l1_smooth_prol_) + case(amg_smooth_prol_,amg_l1_smooth_prol_) - call amg_saggrmat_smth_bld(parms%aggr_prol,a,desc_a,& - ilaggr,nlaggr,parms,ac,desc_ac,op_prol,& - op_restr,t_prol,info) + call amg_saggrmat_smth_bld(parms%aggr_prol,a,desc_a,& + ilaggr,nlaggr,parms,ac,desc_ac,op_prol,& + op_restr,t_prol,info) !!$ case(amg_biz_prol_) !!$ !!$ call amg_saggrmat_biz_bld(a,desc_a,ilaggr,nlaggr, & !!$ & parms,ac,desc_ac,op_prol,op_restr,t_prol,info) - - case(amg_min_energy_) - call amg_saggrmat_minnrg_bld(parms%aggr_prol,a,desc_a,ilaggr,& - nlaggr,parms,ac,desc_ac,op_prol,op_restr,t_prol,info) + case(amg_min_energy_) - case default - info = psb_err_internal_error_ - call psb_errpush(info,name,a_err='Invalid aggr kind') - goto 9999 + call amg_saggrmat_minnrg_bld(parms%aggr_prol,a,desc_a,ilaggr,& + nlaggr,parms,ac,desc_ac,op_prol,op_restr,t_prol,info) + + case default + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='Invalid aggr kind') + goto 9999 + + end select + else + call op_prol%allocate(izero,izero,info) + call op_restr%allocate(izero,izero,info) + call ac%allocate(izero,izero,info) + end if - end select if (info /= psb_success_) then call psb_errpush(psb_err_from_subroutine_,name,a_err='Inner aggrmat bld') goto 9999 @@ -214,5 +221,5 @@ subroutine amg_s_dec_aggregator_mat_bld(ag,parms,a,desc_a,ilaggr,nlaggr,& 9999 call psb_error_handler(err_act) return - + end subroutine amg_s_dec_aggregator_mat_bld diff --git a/amgprec/impl/aggregator/amg_s_dec_aggregator_tprol.f90 b/amgprec/impl/aggregator/amg_s_dec_aggregator_tprol.f90 index 4fd57498..f5f8c8dd 100644 --- a/amgprec/impl/aggregator/amg_s_dec_aggregator_tprol.f90 +++ b/amgprec/impl/aggregator/amg_s_dec_aggregator_tprol.f90 @@ -122,19 +122,23 @@ subroutine amg_s_dec_aggregator_build_tprol(ag,parms,ag_data,& call amg_check_def(parms%aggr_ord,'Ordering',& & amg_aggr_ord_nat_,is_legal_ml_aggr_ord) call amg_check_def(parms%aggr_thresh,'Aggr_Thresh',szero,is_legal_s_aggr_thrs) + if (me >=0) then + ! + ! The decoupled aggregator based on SOC measures ignores + ! ag_data except for clean_zeros; soc_map_bld is a procedure pointer. + ! + if (do_timings) call psb_tic(idx_map_bld) + clean_zeros = ag%do_clean_zeros + call ag%soc_map_bld(parms%aggr_ord,parms%aggr_thresh,clean_zeros,a,desc_a,nlaggr,ilaggr,info) + if (do_timings) call psb_toc(idx_map_bld) + if (do_timings) call psb_tic(idx_map_tprol) - ! - ! The decoupled aggregator based on SOC measures ignores - ! ag_data except for clean_zeros; soc_map_bld is a procedure pointer. - ! - if (do_timings) call psb_tic(idx_map_bld) - clean_zeros = ag%do_clean_zeros - call ag%soc_map_bld(parms%aggr_ord,parms%aggr_thresh,clean_zeros,a,desc_a,nlaggr,ilaggr,info) - if (do_timings) call psb_toc(idx_map_bld) - if (do_timings) call psb_tic(idx_map_tprol) - - if (info==psb_success_) call amg_map_to_tprol(desc_a,ilaggr,nlaggr,t_prol,info) - if (do_timings) call psb_toc(idx_map_tprol) + if (info==psb_success_) call amg_map_to_tprol(desc_a,ilaggr,nlaggr,t_prol,info) + if (do_timings) call psb_toc(idx_map_tprol) + else + allocate(nlaggr(0),ilaggr(0)) + call t_prol%allocate(lzero,lzero,info) + end if if (info /= psb_success_) then info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='soc_map_bld/map_to_tprol') diff --git a/amgprec/impl/aggregator/amg_z_dec_aggregator_mat_asb.f90 b/amgprec/impl/aggregator/amg_z_dec_aggregator_mat_asb.f90 index 40e5e713..5bdd3db0 100644 --- a/amgprec/impl/aggregator/amg_z_dec_aggregator_mat_asb.f90 +++ b/amgprec/impl/aggregator/amg_z_dec_aggregator_mat_asb.f90 @@ -114,63 +114,67 @@ subroutine amg_z_dec_aggregator_mat_asb(ag,parms,a,desc_a,& info = psb_success_ ctxt = desc_a%get_context() call psb_info(ctxt,me,np) - - select case(parms%coarse_mat) - - case(amg_distr_mat_) - - call ac%cscnv(info,type='csr') - call op_prol%cscnv(info,type='csr') - call op_restr%cscnv(info,type='csr') - - if (debug_level >= psb_debug_outer_) & - & write(debug_unit,*) me,' ',trim(name),& - & 'Done ac ' - - case(amg_repl_mat_) - ! - ! We are assuming here that an z matrix - ! can hold all entries - ! - if (desc_ac%get_global_rows() < huge(1_psb_ipk_) ) then - ntaggr = desc_ac%get_global_rows() - i_nr = ntaggr - else + + if (me >=0) then + select case(parms%coarse_mat) + + case(amg_distr_mat_) + + call ac%cscnv(info,type='csr') + call op_prol%cscnv(info,type='csr') + call op_restr%cscnv(info,type='csr') + + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & 'Done ac ' + + case(amg_repl_mat_) + ! + ! We are assuming here that an z matrix + ! can hold all entries + ! + if (desc_ac%get_global_rows() < huge(1_psb_ipk_) ) then + ntaggr = desc_ac%get_global_rows() + i_nr = ntaggr + else + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='invalid amg_coarse_mat_') + goto 9999 + end if + + call op_prol%mv_to(tmpcoo) + nzl = tmpcoo%get_nzeros() + call psb_loc_to_glob(tmpcoo%ja(1:nzl),desc_ac,info,'I') + call tmpcoo%set_ncols(i_nr) + call op_prol%mv_from(tmpcoo) + + call op_restr%mv_to(tmpcoo) + nzl = tmpcoo%get_nzeros() + call psb_loc_to_glob(tmpcoo%ia(1:nzl),desc_ac,info,'I') + call tmpcoo%set_nrows(i_nr) + call op_restr%mv_from(tmpcoo) + + + call psb_gather(tmp_ac,ac,desc_ac,info,root=-ione,& + & dupl=psb_dupl_add_,keeploc=.false.) + call tmp_ac%mv_to(tmpcoo) + call ac%mv_from(tmpcoo) + + call psb_cdall(ctxt,desc_ac,info,mg=ntaggr,repl=.true.) + if (info == psb_success_) call psb_cdasb(desc_ac,info) + + if (info /= psb_success_) goto 9999 + + case default info = psb_err_internal_error_ call psb_errpush(info,name,a_err='invalid amg_coarse_mat_') goto 9999 - end if - - call op_prol%mv_to(tmpcoo) - nzl = tmpcoo%get_nzeros() - call psb_loc_to_glob(tmpcoo%ja(1:nzl),desc_ac,info,'I') - call tmpcoo%set_ncols(i_nr) - call op_prol%mv_from(tmpcoo) - - call op_restr%mv_to(tmpcoo) - nzl = tmpcoo%get_nzeros() - call psb_loc_to_glob(tmpcoo%ia(1:nzl),desc_ac,info,'I') - call tmpcoo%set_nrows(i_nr) - call op_restr%mv_from(tmpcoo) - - - call psb_gather(tmp_ac,ac,desc_ac,info,root=-ione,& - & dupl=psb_dupl_add_,keeploc=.false.) - call tmp_ac%mv_to(tmpcoo) - call ac%mv_from(tmpcoo) - - call psb_cdall(ctxt,desc_ac,info,mg=ntaggr,repl=.true.) - if (info == psb_success_) call psb_cdasb(desc_ac,info) - - if (info /= psb_success_) goto 9999 - - case default - info = psb_err_internal_error_ - call psb_errpush(info,name,a_err='invalid amg_coarse_mat_') - goto 9999 - end select - - + end select + else + call op_prol%allocate(izero,izero,info) + call op_restr%allocate(izero,izero,info) + call ac%allocate(izero,izero,info) + end if call psb_erractionrestore(err_act) return diff --git a/amgprec/impl/aggregator/amg_z_dec_aggregator_mat_bld.f90 b/amgprec/impl/aggregator/amg_z_dec_aggregator_mat_bld.f90 index aa962952..c128f544 100644 --- a/amgprec/impl/aggregator/amg_z_dec_aggregator_mat_bld.f90 +++ b/amgprec/impl/aggregator/amg_z_dec_aggregator_mat_bld.f90 @@ -139,7 +139,7 @@ subroutine amg_z_dec_aggregator_mat_bld(ag,parms,a,desc_a,ilaggr,nlaggr,& use amg_z_prec_type, amg_protect_name => amg_z_dec_aggregator_mat_bld use amg_z_inner_mod implicit none - + class(amg_z_dec_aggregator_type), target, intent(inout) :: ag type(amg_dml_parms), intent(inout) :: parms type(psb_zspmat_type), intent(in) :: a @@ -169,39 +169,46 @@ subroutine amg_z_dec_aggregator_mat_bld(ag,parms,a,desc_a,ilaggr,nlaggr,& ctxt = desc_a%get_context() call psb_info(ctxt,me,np) - ! - ! Build the coarse-level matrix from the fine-level one, starting from - ! the mapping defined by amg_aggrmap_bld and applying the aggregation - ! algorithm specified by - ! - select case (parms%aggr_prol) - case (amg_no_smooth_) + if (me >=0) then + ! + ! Build the coarse-level matrix from the fine-level one, starting from + ! the mapping defined by amg_aggrmap_bld and applying the aggregation + ! algorithm specified by + ! + select case (parms%aggr_prol) + case (amg_no_smooth_) - call amg_zaggrmat_nosmth_bld(parms%aggr_prol,a,desc_a,ilaggr,& - nlaggr,parms,ac,desc_ac,op_prol,op_restr,t_prol,info) + call amg_zaggrmat_nosmth_bld(parms%aggr_prol,a,desc_a,ilaggr,& + nlaggr,parms,ac,desc_ac,op_prol,op_restr,t_prol,info) - case(amg_smooth_prol_,amg_l1_smooth_prol_) + case(amg_smooth_prol_,amg_l1_smooth_prol_) - call amg_zaggrmat_smth_bld(parms%aggr_prol,a,desc_a,& - ilaggr,nlaggr,parms,ac,desc_ac,op_prol,& - op_restr,t_prol,info) + call amg_zaggrmat_smth_bld(parms%aggr_prol,a,desc_a,& + ilaggr,nlaggr,parms,ac,desc_ac,op_prol,& + op_restr,t_prol,info) !!$ case(amg_biz_prol_) !!$ !!$ call amg_zaggrmat_biz_bld(a,desc_a,ilaggr,nlaggr, & !!$ & parms,ac,desc_ac,op_prol,op_restr,t_prol,info) - - case(amg_min_energy_) - call amg_zaggrmat_minnrg_bld(parms%aggr_prol,a,desc_a,ilaggr,& - nlaggr,parms,ac,desc_ac,op_prol,op_restr,t_prol,info) + case(amg_min_energy_) - case default - info = psb_err_internal_error_ - call psb_errpush(info,name,a_err='Invalid aggr kind') - goto 9999 + call amg_zaggrmat_minnrg_bld(parms%aggr_prol,a,desc_a,ilaggr,& + nlaggr,parms,ac,desc_ac,op_prol,op_restr,t_prol,info) + + case default + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='Invalid aggr kind') + goto 9999 + + end select + else + call op_prol%allocate(izero,izero,info) + call op_restr%allocate(izero,izero,info) + call ac%allocate(izero,izero,info) + end if - end select if (info /= psb_success_) then call psb_errpush(psb_err_from_subroutine_,name,a_err='Inner aggrmat bld') goto 9999 @@ -214,5 +221,5 @@ subroutine amg_z_dec_aggregator_mat_bld(ag,parms,a,desc_a,ilaggr,nlaggr,& 9999 call psb_error_handler(err_act) return - + end subroutine amg_z_dec_aggregator_mat_bld diff --git a/amgprec/impl/aggregator/amg_z_dec_aggregator_tprol.f90 b/amgprec/impl/aggregator/amg_z_dec_aggregator_tprol.f90 index 5e075169..0093b086 100644 --- a/amgprec/impl/aggregator/amg_z_dec_aggregator_tprol.f90 +++ b/amgprec/impl/aggregator/amg_z_dec_aggregator_tprol.f90 @@ -122,19 +122,23 @@ subroutine amg_z_dec_aggregator_build_tprol(ag,parms,ag_data,& call amg_check_def(parms%aggr_ord,'Ordering',& & amg_aggr_ord_nat_,is_legal_ml_aggr_ord) call amg_check_def(parms%aggr_thresh,'Aggr_Thresh',dzero,is_legal_d_aggr_thrs) + if (me >=0) then + ! + ! The decoupled aggregator based on SOC measures ignores + ! ag_data except for clean_zeros; soc_map_bld is a procedure pointer. + ! + if (do_timings) call psb_tic(idx_map_bld) + clean_zeros = ag%do_clean_zeros + call ag%soc_map_bld(parms%aggr_ord,parms%aggr_thresh,clean_zeros,a,desc_a,nlaggr,ilaggr,info) + if (do_timings) call psb_toc(idx_map_bld) + if (do_timings) call psb_tic(idx_map_tprol) - ! - ! The decoupled aggregator based on SOC measures ignores - ! ag_data except for clean_zeros; soc_map_bld is a procedure pointer. - ! - if (do_timings) call psb_tic(idx_map_bld) - clean_zeros = ag%do_clean_zeros - call ag%soc_map_bld(parms%aggr_ord,parms%aggr_thresh,clean_zeros,a,desc_a,nlaggr,ilaggr,info) - if (do_timings) call psb_toc(idx_map_bld) - if (do_timings) call psb_tic(idx_map_tprol) - - if (info==psb_success_) call amg_map_to_tprol(desc_a,ilaggr,nlaggr,t_prol,info) - if (do_timings) call psb_toc(idx_map_tprol) + if (info==psb_success_) call amg_map_to_tprol(desc_a,ilaggr,nlaggr,t_prol,info) + if (do_timings) call psb_toc(idx_map_tprol) + else + allocate(nlaggr(0),ilaggr(0)) + call t_prol%allocate(lzero,lzero,info) + end if if (info /= psb_success_) then info=psb_err_from_subroutine_ call psb_errpush(info,name,a_err='soc_map_bld/map_to_tprol') diff --git a/amgprec/impl/amg_c_hierarchy_bld.F90 b/amgprec/impl/amg_c_hierarchy_bld.F90 index 6c0bedf0..88702bba 100644 --- a/amgprec/impl/amg_c_hierarchy_bld.F90 +++ b/amgprec/impl/amg_c_hierarchy_bld.F90 @@ -98,6 +98,8 @@ subroutine amg_c_hierarchy_bld(a,desc_a,prec,info,cpymat) character(len=40) :: ch_err integer(psb_ipk_), save :: idx_bldtp=-1, idx_matasb=-1 logical, parameter :: do_timings=.false. + type(psb_ctxt_type) :: lctxt + integer(psb_ipk_) :: lme,lnp info=psb_success_ err=0 @@ -130,7 +132,7 @@ subroutine amg_c_hierarchy_bld(a,desc_a,prec,info,cpymat) end if cpymat_ = .false. if (present(cpymat)) cpymat_ = cpymat - + ! ! Check to ensure all procs have the same ! @@ -227,7 +229,7 @@ subroutine amg_c_hierarchy_bld(a,desc_a,prec,info,cpymat) casize = mncsize end if prec%ag_data%target_coarse_size = casize - + nplevs = max(itwo,mxplevs) ! @@ -301,7 +303,7 @@ subroutine amg_c_hierarchy_bld(a,desc_a,prec,info,cpymat) end if call psb_cd_renum_block(desc_a,prec%precv(1)%desc_ac,info) prec%precv(1)%base_desc => prec%precv(1)%desc_ac - + newsz = 0 array_build_loop: do i=2, iszv ! @@ -309,7 +311,9 @@ subroutine amg_c_hierarchy_bld(a,desc_a,prec,info,cpymat) ! on all processes. ! call psb_bcast(ctxt,prec%precv(i)%parms) - + lctxt = prec%precv(i-1)%base_desc%get_ctxt() + call psb_info(lctxt,lme,lnp) + write(0,*) 'Check at level',i,lme,lnp ! ! Sanity checks on the parameters ! @@ -376,18 +380,29 @@ subroutine amg_c_hierarchy_bld(a,desc_a,prec,info,cpymat) end if end if - if (all(nlaggr == prec%precv(i-1)%linmap%naggr)) then - newsz=i-1 - if (me == 0) then - write(debug_unit,*) trim(name),& - &': Warning: aggregates from level ',& - & newsz - write(debug_unit,*) trim(name),& - &': to level ',& - & iszv,' coincide.' - write(debug_unit,*) trim(name),& - &': Number of levels actually used :',newsz - write(debug_unit,*) + ! + ! TO BE REVIWED + ! + write(0,*) me,lme,allocated(prec%precv(i-1)%linmap%naggr) + if (allocated(prec%precv(i-1)%linmap%naggr)) then + write(0,*) me,lme,size(prec%precv(i-1)%linmap%naggr), size(nlaggr) + end if + if (.false.) then + if (lme >=0) then + if (all(nlaggr == prec%precv(i-1)%linmap%naggr)) then + newsz=i-1 + if (me == 0) then + write(debug_unit,*) trim(name),& + &': Warning: aggregates from level ',& + & newsz + write(debug_unit,*) trim(name),& + &': to level ',& + & iszv,' coincide.' + write(debug_unit,*) trim(name),& + &': Number of levels actually used :',newsz + write(debug_unit,*) + end if + end if end if end if end if @@ -426,6 +441,31 @@ subroutine amg_c_hierarchy_bld(a,desc_a,prec,info,cpymat) & a_err=ch_err) goto 9999 endif + if (amg_get_do_remap().and.(i>=2)) then + block + type(psb_ctxt_type) :: lctxt + integer(psb_ipk_) :: lme,lnp + lctxt = prec%precv(i)%desc_ac%get_ctxt() + call psb_info(lctxt,lme,lnp) + write(0,*) ' Context on remapping ',lme,lnp + if ((lme >=0).and.(lnp>=2)) then + associate(lv=>prec%precv(i), rmp => prec%precv(i)%remap_data) + call lv%desc_ac%clone(rmp%desc_ac_pre_remap,info) + call lv%ac%clone(rmp%ac_pre_remap,info) + write(0,*) ' Doing remapping ',lnp, lnp/2 + call psb_remap(lnp/2,rmp%desc_ac_pre_remap,rmp%ac_pre_remap,& + & rmp%idest,rmp%isrc,rmp%nrsrc,rmp%naggr,lv%desc_ac,lv%ac,info) +!!$ write(0,*) me,' Out of remapping ',rmp%desc_ac_pre_remap%get_fmt(),' ',& +!!$ & lv%desc_ac%get_fmt(),sum(lv%linmap%naggr),sum(rmp%naggr) + write(0,*) 'Assignment ',size(lv%linmap%naggr),size(rmp%naggr) + lv%linmap%naggr(:) = rmp%naggr(:) + lv%linmap%p_desc_V => rmp%desc_ac_pre_remap + lv%base_a => lv%ac + lv%base_desc => lv%desc_ac + end associate + end if + end block + end if exit array_build_loop else if (do_timings) call psb_tic(idx_matasb) @@ -442,8 +482,35 @@ subroutine amg_c_hierarchy_bld(a,desc_a,prec,info,cpymat) endif if (i=2)) then + block + type(psb_ctxt_type) :: lctxt + integer(psb_ipk_) :: lme,lnp + lctxt = prec%precv(i)%desc_ac%get_ctxt() + call psb_info(lctxt,lme,lnp) + write(0,*) ' Context on remapping ',lme,lnp + if ((lme >=0).and.(lnp>=2)) then + associate(lv=>prec%precv(i), rmp => prec%precv(i)%remap_data) + call lv%desc_ac%clone(rmp%desc_ac_pre_remap,info) + call lv%ac%clone(rmp%ac_pre_remap,info) + write(0,*) ' Doing remapping ',lnp, lnp/2 + call psb_remap(lnp/2,rmp%desc_ac_pre_remap,rmp%ac_pre_remap,& + & rmp%idest,rmp%isrc,rmp%nrsrc,rmp%naggr,lv%desc_ac,lv%ac,info) +!!$ write(0,*) me,' Out of remapping ',rmp%desc_ac_pre_remap%get_fmt(),' ',& +!!$ & lv%desc_ac%get_fmt(),sum(lv%linmap%naggr),sum(rmp%naggr) + write(0,*) 'Assignment ',size(lv%linmap%naggr),size(rmp%naggr) + lv%linmap%naggr(:) = rmp%naggr(:) + lv%linmap%p_desc_V => rmp%desc_ac_pre_remap + lv%base_a => lv%ac + lv%base_desc => lv%desc_ac + end associate + end if + end block + end if + write(0,*) ' End of array_build_loop',i,iszv,info end do array_build_loop - + write(0,*) ' Done array_build_loop',iszv,newsz,info,psb_errstatus_fatal() + call psb_barrier(ctxt) if (newsz > 0) then ! ! We exited early from the build loop, need to fix @@ -487,32 +554,35 @@ subroutine amg_c_hierarchy_bld(a,desc_a,prec,info,cpymat) & prec%precv(i)%linmap%p_desc_V => prec%precv(i)%base_desc end do end if + write(0,*) ' Done reallocating precv',iszv,newsz,info,psb_errstatus_fatal() + call psb_barrier(ctxt) !write(0,*) 'Should we remap? ' - if (amg_get_do_remap().and.(np>=4)) then + if (.false.) then + if (amg_get_do_remap().and.(np>=4)) then !!$ write(0,*) 'Going for remapping ' - if (.true.) then - associate(lv=>prec%precv(iszv), rmp => prec%precv(iszv)%remap_data) - call lv%desc_ac%clone(rmp%desc_ac_pre_remap,info) - call lv%ac%clone(rmp%ac_pre_remap,info) - if (np >= 8) then - call psb_remap(np/4,rmp%desc_ac_pre_remap,rmp%ac_pre_remap,& - & rmp%idest,rmp%isrc,rmp%nrsrc,rmp%naggr,lv%desc_ac,lv%ac,info) - else - call psb_remap(np/2,rmp%desc_ac_pre_remap,rmp%ac_pre_remap,& - & rmp%idest,rmp%isrc,rmp%nrsrc,rmp%naggr,lv%desc_ac,lv%ac,info) - end if + if (.true.) then + associate(lv=>prec%precv(iszv), rmp => prec%precv(iszv)%remap_data) + call lv%desc_ac%clone(rmp%desc_ac_pre_remap,info) + call lv%ac%clone(rmp%ac_pre_remap,info) + if (np >= 8) then + call psb_remap(np/4,rmp%desc_ac_pre_remap,rmp%ac_pre_remap,& + & rmp%idest,rmp%isrc,rmp%nrsrc,rmp%naggr,lv%desc_ac,lv%ac,info) + else + call psb_remap(np/2,rmp%desc_ac_pre_remap,rmp%ac_pre_remap,& + & rmp%idest,rmp%isrc,rmp%nrsrc,rmp%naggr,lv%desc_ac,lv%ac,info) + end if !!$ write(0,*) me,' Out of remapping ',rmp%desc_ac_pre_remap%get_fmt(),' ',& !!$ & lv%desc_ac%get_fmt(),sum(lv%linmap%naggr),sum(rmp%naggr) - lv%linmap%naggr(:) = rmp%naggr(:) - lv%linmap%p_desc_V => rmp%desc_ac_pre_remap - lv%base_a => lv%ac - lv%base_desc => lv%desc_ac - end associate + lv%linmap%naggr(:) = rmp%naggr(:) + lv%linmap%p_desc_V => rmp%desc_ac_pre_remap + lv%base_a => lv%ac + lv%base_desc => lv%desc_ac + end associate + end if end if end if - if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& & a_err='Internal hierarchy build' ) diff --git a/amgprec/impl/amg_cmlprec_aply.f90 b/amgprec/impl/amg_cmlprec_aply.f90 index 44862063..4f724a46 100644 --- a/amgprec/impl/amg_cmlprec_aply.f90 +++ b/amgprec/impl/amg_cmlprec_aply.f90 @@ -207,6 +207,7 @@ subroutine amg_cmlprec_aply_vect(alpha,p,x,beta,y,desc_data,trans,work,info) use psb_base_mod use amg_base_prec_type + use amg_prec_mod use amg_c_inner_mod, amg_protect_name => amg_cmlprec_aply_vect implicit none @@ -605,7 +606,7 @@ contains if(debug_level > 1) then write(debug_unit,*) me,' inner_mult at level ',level end if - + write(debug_unit,*) me,' inner_mult at level (1):',level,np sweeps_post = p%precv(level)%parms%sweeps_post sweeps_pre = p%precv(level)%parms%sweeps_pre pre = ((sweeps_pre>0).and.(trans=='N')).or.((sweeps_post>0).and.(trans/='N')) @@ -615,6 +616,10 @@ contains & vtx => p%precv(level)%wrk%vtx,vty => p%precv(level)%wrk%vty,& & base_a => p%precv(level)%base_a, base_desc=>p%precv(level)%base_desc,& & wv => p%precv(level)%wrk%wv) + write(0,*) 'Inner mult at level (2):',level,' :',me,np,':',& + & size(p%precv(level)%wrk%wv), allocated(p%precv(level)%wrk%wv) + if (me >=0) then + if (level < nlev) then ! ! Apply the first smoother @@ -622,7 +627,6 @@ contains ! if (pre) then - if (me >=0) then !!$ write(0,*) me,'Applying smoother pre ', level if (trans == 'N') then sweeps = p%precv(level)%parms%sweeps_pre @@ -641,24 +645,26 @@ contains & a_err='Error during PRE smoother_apply') goto 9999 end if - end if - endif + + endif ! ! Compute the residual for next level and call recursively ! if (pre) then - call psb_geaxpby(cone,vx2l,& - & czero,vty,& - & base_desc,info) - - if (info == psb_success_) call psb_spmm(-cone,base_a,& - & vy2l,cone,vty,& - & base_desc,info,work=work,trans=trans) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during residue') - goto 9999 - end if + + call psb_geaxpby(cone,vx2l,& + & czero,vty,& + & base_desc,info) + + if (info == psb_success_) call psb_spmm(-cone,base_a,& + & vy2l,cone,vty,& + & base_desc,info,work=work,trans=trans) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Error during residue') + goto 9999 + end if + call p%precv(level+1)%map_rstr(cone,vty,& & czero,p%precv(level+1)%wrk%vx2l,& & info,work=work,& @@ -698,13 +704,13 @@ contains if (p%precv(level)%parms%ml_cycle == amg_wcycle_ml_) then - if (me >=0) then + call psb_geaxpby(cone,vx2l, czero,vty,& & base_desc,info) if (info == psb_success_) call psb_spmm(-cone,base_a,& & vy2l,cone,vty,& & base_desc,info,work=work,trans=trans) - end if + if (info == psb_success_) & & call p%precv(level+1)%map_rstr(cone,vty,& & czero,p%precv(level+1)%wrk%vx2l,info,work=work,& @@ -732,7 +738,7 @@ contains if (post) then - if (me >=0) then + call psb_geaxpby(cone,vx2l,& & czero,vty,& & base_desc,info) @@ -759,7 +765,7 @@ contains & vty,cone,vy2l, base_desc, trans,& & sweeps,work,wv,info,init='Z') end if - end if + if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& @@ -786,6 +792,7 @@ contains & a_err='Invalid LEVEL vs NLEV') goto 9999 end if + end if end associate 9998 continue call psb_erractionrestore(err_act) @@ -1004,9 +1011,6 @@ contains end subroutine amg_c_inner_k_cycle recursive subroutine amg_cinneritkcycle(p, level, trans, work, innersolv) - use psb_base_mod - use amg_prec_mod - use amg_c_inner_mod, amg_protect_name => amg_cmlprec_aply implicit none @@ -1158,532 +1162,3 @@ contains end subroutine amg_cmlprec_aply_vect - -! -! Old routine for arrays instead of psb_X_vector. To be deleted eventually. -! -! -subroutine amg_cmlprec_aply(alpha,p,x,beta,y,desc_data,trans,work,info) - - use psb_base_mod - use amg_base_prec_type - use amg_c_inner_mod, amg_protect_name => amg_cmlprec_aply - - implicit none - - ! Arguments - type(psb_desc_type),intent(in) :: desc_data - type(amg_cprec_type), intent(inout) :: p - complex(psb_spk_),intent(in) :: alpha,beta - complex(psb_spk_),intent(inout) :: x(:) - complex(psb_spk_),intent(inout) :: y(:) - character, intent(in) :: trans - complex(psb_spk_),target :: work(:) - integer(psb_ipk_), intent(out) :: info - - ! Local variables - type(psb_ctxt_type) :: ctxt - integer(psb_ipk_) :: np, me - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: debug_level, debug_unit, nlev,nc2l,nr2l,level - character(len=20) :: name - character :: trans_ - type amg_mlwrk_type - complex(psb_spk_), allocatable :: tx(:), ty(:), x2l(:), y2l(:) - end type amg_mlwrk_type - type(amg_mlwrk_type), allocatable, target :: mlwrk(:) - - name='amg_cmlprec_aply' - info = psb_success_ - call psb_erractionsave(err_act) - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - - ctxt = desc_data%get_context() - call psb_info(ctxt, me, np) - - if (debug_level >= psb_debug_inner_) & - & write(debug_unit,*) me,' ',trim(name),& - & ' Entry ', size(p%precv) - - trans_ = psb_toupper(trans) - - nlev = size(p%precv) - allocate(mlwrk(nlev),stat=info) - if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') - goto 9999 - end if - level = 1 - - do level = 1, nlev - call psb_geasb(mlwrk(level)%x2l,& - & p%precv(level)%base_desc,info) - call psb_geasb(mlwrk(level)%y2l,& - & p%precv(level)%base_desc,info) - call psb_geasb(mlwrk(level)%tx,& - & p%precv(level)%base_desc,info) - call psb_geasb(mlwrk(level)%ty,& - & p%precv(level)%base_desc,info) - if (psb_errstatus_fatal()) then - nc2l = p%precv(level)%base_desc%get_local_cols() - info=psb_err_alloc_request_ - call psb_errpush(info,name,i_err=(/2*nc2l,izero,izero,izero,izero/),& - & a_err='complex(psb_spk_)') - goto 9999 - end if - end do - - mlwrk(level)%x2l(:) = x(:) - mlwrk(level)%y2l(:) = czero - - call inner_ml_aply(level,p,mlwrk,trans_,work,info) - - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Inner prec aply') - goto 9999 - end if - - call psb_geaxpby(alpha,mlwrk(level)%y2l,beta,y,& - & p%precv(level)%base_desc,info) - - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error final update') - goto 9999 - end if - - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - -contains - - ! - ! - ! inner_ml_aply: apply AMG at a given level. - ! This routine dispatches the computation according to the type - ! specified at the current level. - ! Each of the corrections will inturn call recursively this routine. - ! - ! Assumptions: - ! On input: - ! mlprec_wkr(level)%vx2l contains the input vector (RHS) - ! mlprec_wkr(level)%vy2l contains the initial guess - ! - ! On output: - ! mlprec_wkr(level)%vy2l contains the solution - ! - ! Constraints: each of the called routines must properly handle - ! the input/output conditions for level+1 (i.e. apply - ! prolongation/restriction). - ! Note: for historical/convenience reasons the prolongator/restrictor - ! between level and level+1 are stored at level+1. - ! - ! - recursive subroutine inner_ml_aply(level,p,mlwrk,trans,work,info) - - implicit none - - ! Arguments - integer(psb_ipk_) :: level - type(amg_cprec_type), target, intent(inout) :: p - type(amg_mlwrk_type), intent(inout), target :: mlwrk(:) - character, intent(in) :: trans - complex(psb_spk_),target :: work(:) - integer(psb_ipk_), intent(out) :: info - - type(psb_c_vect_type) :: res - type(psb_c_vect_type), pointer :: current - integer(psb_ipk_) :: sweeps_post, sweeps_pre - ! Local variables - type(psb_ctxt_type) :: ctxt - integer(psb_ipk_) :: np, me - integer(psb_ipk_) :: i, err_act - integer(psb_ipk_) :: debug_level, debug_unit - integer(psb_ipk_) :: nlev, ilev, sweeps - logical :: pre, post - character(len=20) :: name - - - - name = 'inner_ml_aply' - info = psb_success_ - call psb_erractionsave(err_act) - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - nlev = size(p%precv) - if ((level < 1) .or. (level > nlev)) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='wrong call level to inner_ml') - goto 9999 - end if - ctxt = p%precv(level)%base_desc%get_context() - call psb_info(ctxt, me, np) - - if(debug_level > 1) then - write(debug_unit,*) me,' inner_ml_aply at level ',level - end if - - select case(p%precv(level)%parms%ml_cycle) - - case(amg_no_ml_) - ! - ! No preconditioning, should not really get here - ! - call psb_errpush(psb_err_internal_error_,name,& - & a_err='amg_no_ml_ in mlprc_aply?') - goto 9999 - - case(amg_add_ml_) - - call amg_c_inner_add(p, mlwrk, level, trans, work) - - case(amg_mult_ml_, amg_vcycle_ml_, amg_wcycle_ml_) - - call amg_c_inner_mult(p, mlwrk, level, trans, work) - -! !$ case(amg_kcycle_ml_, amg_kcyclesym_ml_) -! !$ -! !$ call amg_c_inner_k_cycle(p, mlwrk, level, trans, work) - - case default - info = psb_err_from_subroutine_ai_ - call psb_errpush(info,name,a_err='invalid ml_cycle',& - & i_Err=(/p%precv(level)%parms%ml_cycle,izero,izero,izero,izero/)) - goto 9999 - - end select - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - return - - end subroutine inner_ml_aply - - - recursive subroutine amg_c_inner_add(p, mlwrk, level, trans, work) - use psb_base_mod - use amg_prec_mod - - implicit none - - !Input/Oputput variables - type(amg_cprec_type), intent(inout) :: p - - type(amg_mlwrk_type), target, intent(inout) :: mlwrk(:) - integer(psb_ipk_), intent(in) :: level - character, intent(in) :: trans - complex(psb_spk_),target :: work(:) - type(psb_c_vect_type) :: res - type(psb_c_vect_type), pointer :: current - integer(psb_ipk_) :: sweeps_post, sweeps_pre - ! Local variables - type(psb_ctxt_type) :: ctxt - integer(psb_ipk_) :: np, me - integer(psb_ipk_) :: i, err_act - integer(psb_ipk_) :: debug_level, debug_unit - integer(psb_ipk_) :: nlev, ilev, sweeps - logical :: pre, post - character(len=20) :: name - - - - name = 'inner_inner_add' - info = psb_success_ - call psb_erractionsave(err_act) - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - nlev = size(p%precv) - if ((level < 1) .or. (level > nlev)) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='wrong call level to inner_add') - goto 9999 - end if - ctxt = p%precv(level)%base_desc%get_context() - call psb_info(ctxt, me, np) - - if(debug_level > 1) then - write(debug_unit,*) me,' inner_add at level ',level - end if - - if ((level<1).or.(level>nlev)) then - info = psb_err_internal_error_ - call psb_errpush(info,name,& - & a_err='Invalid LEVEL>NLEV') - goto 9999 - end if - - sweeps = p%precv(level)%parms%sweeps_pre - call p%precv(level)%sm%apply(cone,& - & mlwrk(level)%x2l,czero,mlwrk(level)%y2l,& - & p%precv(level)%base_desc, trans,& - & sweeps,work,info) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during ADD smoother_apply') - goto 9999 - end if - - if (level < nlev) then - ! Apply the restriction - call p%precv(level+1)%map_rstr(cone,mlwrk(level)%x2l,& - & czero,mlwrk(level+1)%x2l,& - & info,work=work) - mlwrk(level+1)%y2l(:) = czero - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during restriction') - goto 9999 - end if - - call inner_ml_aply(level+1,p,mlwrk,trans,work,info) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error in recursive call') - goto 9999 - end if - - ! - ! Apply the prolongator and add correction. - ! - call p%precv(level+1)%map_prol(cone,& - & mlwrk(level+1)%y2l,cone,mlwrk(level)%y2l,& - & info,work=work) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during prolongation') - goto 9999 - end if - - - end if - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - return - - end subroutine amg_c_inner_add - - recursive subroutine amg_c_inner_mult(p, mlwrk, level, trans, work) - use psb_base_mod - use amg_prec_mod - - implicit none - - !Input/Oputput variables - type(amg_cprec_type), intent(inout) :: p - - type(amg_mlwrk_type), target, intent(inout) :: mlwrk(:) - integer(psb_ipk_), intent(in) :: level - character, intent(in) :: trans - complex(psb_spk_),target :: work(:) - type(psb_c_vect_type) :: res - type(psb_c_vect_type), pointer :: current - integer(psb_ipk_) :: sweeps_post, sweeps_pre - ! Local variables - type(psb_ctxt_type) :: ctxt - integer(psb_ipk_) :: np, me - integer(psb_ipk_) :: i, err_act - integer(psb_ipk_) :: debug_level, debug_unit - integer(psb_ipk_) :: nlev, ilev, sweeps - logical :: pre, post - character(len=20) :: name - - - - name = 'inner_inner_mult' - info = psb_success_ - call psb_erractionsave(err_act) - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - nlev = size(p%precv) - if ((level < 1) .or. (level > nlev)) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='wrong call level to inner_mult') - goto 9999 - end if - ctxt = p%precv(level)%base_desc%get_context() - call psb_info(ctxt, me, np) - - if(debug_level > 1) then - write(debug_unit,*) me,' inner_mult at level ',level - end if - - if ((level < nlev).or.(nlev == 1)) then - sweeps_post = p%precv(level)%parms%sweeps_post - sweeps_pre = p%precv(level)%parms%sweeps_pre - else - sweeps_post = p%precv(level-1)%parms%sweeps_post - sweeps_pre = p%precv(level-1)%parms%sweeps_pre - endif - - pre = ((sweeps_pre>0).and.(trans=='N')).or.((sweeps_post>0).and.(trans/='N')) - post = ((sweeps_post>0).and.(trans=='N')).or.((sweeps_pre>0).and.(trans/='N')) - - - if (level < nlev) then - - ! - ! Apply the first smoother - ! - - if (pre) then - if (trans == 'N') then - sweeps = p%precv(level)%parms%sweeps_pre - if (info == psb_success_) call p%precv(level)%sm%apply(cone,& - & mlwrk(level)%x2l,czero,mlwrk(level)%y2l,& - & p%precv(level)%base_desc, trans,& - & sweeps,work,info,init='Y') - else - sweeps = p%precv(level)%parms%sweeps_post - if (info == psb_success_) call p%precv(level)%sm2%apply(cone,& - & mlwrk(level)%x2l,czero,mlwrk(level)%y2l,& - & p%precv(level)%base_desc, trans,& - & sweeps,work,info,init='Y') - end if - - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during PRE smoother_apply') - goto 9999 - end if - endif - - ! - ! Compute the residual and call recursively - ! - if (pre) then - call psb_geaxpby(cone,mlwrk(level)%x2l,& - & czero,mlwrk(level)%ty,& - & p%precv(level)%base_desc,info) - - if (info == psb_success_) call psb_spmm(-cone,p%precv(level)%base_a,& - & mlwrk(level)%y2l,cone,mlwrk(level)%ty,& - & p%precv(level)%base_desc,info,work=work,trans=trans) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during residue') - goto 9999 - end if - call p%precv(level+1)%map_rstr(cone,mlwrk(level)%ty,& - & czero,mlwrk(level+1)%x2l,info,work=work) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during restriction') - goto 9999 - end if - else - ! Shortcut: just transfer x2l. - call p%precv(level+1)%map_rstr(cone,mlwrk(level)%x2l,& - & czero,mlwrk(level+1)%x2l,info,work=work) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during restriction') - goto 9999 - end if - endif - ! First guess is zero - mlwrk(level+1)%y2l(:) = czero - - - call inner_ml_aply(level+1,p,mlwrk,trans,work,info) - - if (p%precv(level)%parms%ml_cycle == amg_wcycle_ml_) then - ! On second call will use output y2l as initial guess - if (info == psb_success_) call inner_ml_aply(level+1,p,mlwrk,trans,work,info) - endif - - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error in recursive call') - goto 9999 - end if - - - ! - ! Apply the prolongator - ! - call p%precv(level+1)%map_prol(cone,mlwrk(level+1)%y2l,& - & cone,mlwrk(level)%y2l,info,work=work) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during prolongation') - goto 9999 - end if - - ! - ! Compute the residual - ! - if (post) then - call psb_geaxpby(cone,mlwrk(level)%x2l,& - & czero,mlwrk(level)%tx,& - & p%precv(level)%base_desc,info) - call psb_spmm(-cone,p%precv(level)%base_a,mlwrk(level)%y2l,& - & cone,mlwrk(level)%tx,p%precv(level)%base_desc,info,& - & work=work,trans=trans) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during residue') - goto 9999 - end if - ! - ! Apply the second smoother - ! - if (trans == 'N') then - sweeps = p%precv(level)%parms%sweeps_post - if (info == psb_success_) call p%precv(level)%sm2%apply(cone,& - & mlwrk(level)%tx,cone,mlwrk(level)%y2l,& - & p%precv(level)%base_desc, trans,& - & sweeps,work,info,init='Z') - else - sweeps = p%precv(level)%parms%sweeps_pre - if (info == psb_success_) call p%precv(level)%sm%apply(cone,& - & mlwrk(level)%tx,cone,mlwrk(level)%y2l,& - & p%precv(level)%base_desc, trans,& - & sweeps,work,info,init='Z') - end if - - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during POST smoother_apply') - goto 9999 - end if - - endif - - else if (level == nlev) then - - sweeps = p%precv(level)%parms%sweeps_pre - if (info == psb_success_) call p%precv(level)%sm%apply(cone,& - & mlwrk(level)%x2l,czero,mlwrk(level)%y2l,& - & p%precv(level)%base_desc, trans,& - & sweeps,work,info) - - else - - info = psb_err_internal_error_ - call psb_errpush(info,name,& - & a_err='Invalid LEVEL vs NLEV') - goto 9999 - end if - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - return - - end subroutine amg_c_inner_mult - - -end subroutine amg_cmlprec_aply diff --git a/amgprec/impl/amg_cmlprec_aply_a.f90 b/amgprec/impl/amg_cmlprec_aply_a.f90 new file mode 100644 index 00000000..dfc65987 --- /dev/null +++ b/amgprec/impl/amg_cmlprec_aply_a.f90 @@ -0,0 +1,733 @@ +! +! +! AMG4PSBLAS version 1.0 +! Algebraic Multigrid Package +! based on PSBLAS (Parallel Sparse BLAS version 3.7) +! +! (C) Copyright 2021 +! +! Salvatore Filippone +! Pasqua D'Ambra +! Fabio Durastante +! +! 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 AMG4PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific prior 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 AMG4PSBLAS 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: amg_cmlprec_aply.f90 +! +! Subroutine: amg_cmlprec_aply +! Version: real +! +! Current version of this file contributed by: +! Ambra Abdullahi Hassan +! +! +! This routine computes +! +! Y = beta*Y + alpha*op(ML^(-1))*X, +! where +! - ML is a multilevel preconditioner associated with +! a certain matrix A and stored in p, +! - op(ML^(-1)) is ML^(-1) or its transpose, according to the value of trans, +! - X and Y are vectors, +! - alpha and beta are scalars. +! +! The following multilevel strategies can be applied: +! +! - Additive multilevel Schwarz, +! - classical V-cycle, +! - classical W-cycle, +! - K-cycle both for symmetric and nonsymmetric matrices, where 2 iterations +! of FCG(1) or GCR, respectively, are applied at each level +! except the coarsest. +! +! For each level we have as many submatrices as processes (except for the coarsest +! level where we might have a replicated index space) and each process takes care +! of one submatrix. +! +! A multilevel preconditioner is regarded as an array of 'one-level' data structures, +! each containing the part of the preconditioner associated to a certain level +! (for more details see the description of amg_Tonelev_type in amg_prec_type.f90). +! For each level lev, there is a smoother stored in +! p%precv(lev)%sm +! which in turn contains a solver +! p$precv(lev)%sm%sv +! Typically the solver acts only locally, and the smoother applies any required +! parallel communication/action. +! Each level has a matrix A(lev), obtained by 'tranferring' the original +! matrix A (i.e. the matrix to be preconditioned) to the level lev, through smoothed +! aggregation. +! +! The levels are numbered in increasing order starting from the finest one, i.e. +! level 1 is the finest level and A(1) is the matrix A. +! +! This routine is formulated in a recursive way, so it is quite compact. +! +! The V-cycle can be described as follows, where +! P(lev) denotes the smoothed prolongator from level lev to level +! lev-1, while R(lev) denotes the corresponding restriction operator +! (normally its transpose) from level lev-1 to level lev. +! M(lev) is the smoother at the current level. +! +! +! 1. Transfer the outer vector Xest to u(1) (inner X at level 1) +! +! 2. Invoke V-cycle(1,M,P,R,A,b,u) +! +! procedure V-cycle(lev,M,P,R,A,b,u) +! +! if (lev < nlev) then +! +! u(lev) = u(lev) + M(lev)*(b(lev)-A(lev)*u(lev)) +! +! b(lev+1) = R(lev+1)*(b(lev)-A(lev)*u(lev)) +! +! u(lev+1) = V-cycle(lev+1,M,P,R,A,b,u) +! +! u(lev) = u(lev) + P(lev+1) * u(lev+1) +! +! u(lev) = u(lev) + M(lev)*(b(lev)-A(lev)*u(lev)) +! +! else +! +! solve A(lev)*u(lev) = b(lev) +! +! end if +! +! return u(lev) +! end +! +! 3. Transfer u(1) to the external: +! Yext = beta*Yext + alpha*u(1) +! +! +! In the implementation, the recursive procedure is inner_ml_aply, which +! in turn uses amg_inner_add (for additive multilevel), +! amg_inner_mult (for V-cycle and W-cycle), and +! amg_inner_k_cycle (for symmetric and non-symmetric K-cycle). +! +! For a detailed description of the algorithms, see: +! +! - B.F. Smith, P.E. Bjorstad, W.D. Gropp, +! Domain decomposition: parallel multilevel methods for elliptic partial +! differential equations, Cambridge University Press, 1996. +! +! - W. L. Briggs, V. E. Henson, S. F. McCormick, +! A Multigrid Tutorial, Second Edition +! SIAM, 2000. +! +! - K. Stuben, +! An Introduction to Algebraic Multigrid, +! in A. Schuller, U. Trottenberg, C. Oosterlee, Multigrid, Academic Press, 2001. +! +! - Y. Notay, P. S. Vassilevski, +! Recursive Krylov-based multigrid cycles +! Numerical Linear Algebra with Applications, 15 (5), 2008, 473--487. +! +! +! Arguments: +! alpha - complex(psb_spk_), input. +! The scalar alpha. +! p - type(amg_cprec_type), input. +! The multilevel preconditioner data structure containing the +! local part of the preconditioner to be applied. +! Note that nlev = size(p%precv) = number of levels. +! p%precv(lev)%sm - type(psb_cbaseprec_type) +! The pre-'smoother' for the current level +! p%precv(lev)%sm2 - type(psb_cbaseprec_type) +! The post-'smoother' for the current level +! may be the same or different from %sm +! p%precv(lev)%ac - type(psb_cspmat_type) +! The local part of the matrix A(lev). +! p%precv(lev)%parms - type(psb_sml_parms) +! Parameters controllin the multilevel prec. +! p%precv(lev)%desc_ac - type(psb_desc_type). +! The communication descriptor associated to the sparse +! matrix A(lev) +! p%precv(lev)%map - type(psb_inter_desc_type) +! Stores the linear operators mapping level (lev-1) +! to (lev) and vice versa. These are the restriction +! and prolongation operators described in the sequel. +! p%precv(lev)%base_a - type(psb_cspmat_type), pointer. +! Pointer (really a pointer!) to the base matrix of +! the current level, i.e. the local part of A(lev); +! so we have a unified treatment of residuals. We +! need this to avoid passing explicitly the matrix +! A(lev) to the routine which applies the +! preconditioner. +! p%precv(lev)%base_desc - type(psb_desc_type), pointer. +! Pointer to the communication descriptor associated +! to the sparse matrix pointed by base_a. +! +! x - complex(psb_spk_), dimension(:), input. +! The local part of the vector X. +! beta - complex(psb_spk_), input. +! The scalar beta. +! y - complex(psb_spk_), dimension(:), input/output. +! The local part of the vector Y. +! desc_data - type(psb_desc_type), input. +! The communication descriptor associated to the matrix to be +! preconditioned. +! trans - character, optional. +! If trans='N','n' then op(M^(-1)) = M^(-1); +! if trans='T','t' then op(M^(-1)) = M^(-T) (transpose of M^(-1)). +! work - complex(psb_spk_), dimension (:), optional, target. +! Workspace. Its size must be at least 4*desc_data%get_local_cols(). +! info - integer, output. +! Error code. +! +! Note that when the LU factorization of the matrix A(lev) is computed instead of +! the ILU one, by using UMFPACK or SuperLU or MUMPS, the corresponding +! L and U factors are stored in data structures handled +! by the third party software. +! + +! +! Old routine for arrays instead of psb_X_vector. To be deleted eventually. +! +! +subroutine amg_cmlprec_aply_a(alpha,p,x,beta,y,desc_data,trans,work,info) + + use psb_base_mod + use amg_base_prec_type + use amg_c_inner_mod, amg_protect_name => amg_cmlprec_aply_a + + implicit none + + ! Arguments + type(psb_desc_type),intent(in) :: desc_data + type(amg_cprec_type), intent(inout) :: p + complex(psb_spk_),intent(in) :: alpha,beta + complex(psb_spk_),intent(inout) :: x(:) + complex(psb_spk_),intent(inout) :: y(:) + character, intent(in) :: trans + complex(psb_spk_),target :: work(:) + integer(psb_ipk_), intent(out) :: info + + ! Local variables + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me + integer(psb_ipk_) :: err_act + integer(psb_ipk_) :: debug_level, debug_unit, nlev,nc2l,nr2l,level + character(len=20) :: name + character :: trans_ + type amg_mlwrk_type + complex(psb_spk_), allocatable :: tx(:), ty(:), x2l(:), y2l(:) + end type amg_mlwrk_type + type(amg_mlwrk_type), allocatable, target :: mlwrk(:) + + name='amg_cmlprec_aply' + info = psb_success_ + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + ctxt = desc_data%get_context() + call psb_info(ctxt, me, np) + + if (debug_level >= psb_debug_inner_) & + & write(debug_unit,*) me,' ',trim(name),& + & ' Entry ', size(p%precv) + + trans_ = psb_toupper(trans) + + nlev = size(p%precv) + allocate(mlwrk(nlev),stat=info) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') + goto 9999 + end if + level = 1 + + do level = 1, nlev + call psb_geasb(mlwrk(level)%x2l,& + & p%precv(level)%base_desc,info) + call psb_geasb(mlwrk(level)%y2l,& + & p%precv(level)%base_desc,info) + call psb_geasb(mlwrk(level)%tx,& + & p%precv(level)%base_desc,info) + call psb_geasb(mlwrk(level)%ty,& + & p%precv(level)%base_desc,info) + if (psb_errstatus_fatal()) then + nc2l = p%precv(level)%base_desc%get_local_cols() + info=psb_err_alloc_request_ + call psb_errpush(info,name,i_err=(/2*nc2l,izero,izero,izero,izero/),& + & a_err='complex(psb_spk_)') + goto 9999 + end if + end do + + mlwrk(level)%x2l(:) = x(:) + mlwrk(level)%y2l(:) = czero + + call inner_ml_aply(level,p,mlwrk,trans_,work,info) + + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Inner prec aply') + goto 9999 + end if + + call psb_geaxpby(alpha,mlwrk(level)%y2l,beta,y,& + & p%precv(level)%base_desc,info) + + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Error final update') + goto 9999 + end if + + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +contains + + ! + ! + ! inner_ml_aply: apply AMG at a given level. + ! This routine dispatches the computation according to the type + ! specified at the current level. + ! Each of the corrections will inturn call recursively this routine. + ! + ! Assumptions: + ! On input: + ! mlprec_wkr(level)%vx2l contains the input vector (RHS) + ! mlprec_wkr(level)%vy2l contains the initial guess + ! + ! On output: + ! mlprec_wkr(level)%vy2l contains the solution + ! + ! Constraints: each of the called routines must properly handle + ! the input/output conditions for level+1 (i.e. apply + ! prolongation/restriction). + ! Note: for historical/convenience reasons the prolongator/restrictor + ! between level and level+1 are stored at level+1. + ! + ! + recursive subroutine inner_ml_aply(level,p,mlwrk,trans,work,info) + + implicit none + + ! Arguments + integer(psb_ipk_) :: level + type(amg_cprec_type), target, intent(inout) :: p + type(amg_mlwrk_type), intent(inout), target :: mlwrk(:) + character, intent(in) :: trans + complex(psb_spk_),target :: work(:) + integer(psb_ipk_), intent(out) :: info + + type(psb_c_vect_type) :: res + type(psb_c_vect_type), pointer :: current + integer(psb_ipk_) :: sweeps_post, sweeps_pre + ! Local variables + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me + integer(psb_ipk_) :: i, err_act + integer(psb_ipk_) :: debug_level, debug_unit + integer(psb_ipk_) :: nlev, ilev, sweeps + logical :: pre, post + character(len=20) :: name + + + + name = 'inner_ml_aply' + info = psb_success_ + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + nlev = size(p%precv) + if ((level < 1) .or. (level > nlev)) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='wrong call level to inner_ml') + goto 9999 + end if + ctxt = p%precv(level)%base_desc%get_context() + call psb_info(ctxt, me, np) + + if(debug_level > 1) then + write(debug_unit,*) me,' inner_ml_aply at level ',level + end if + + select case(p%precv(level)%parms%ml_cycle) + + case(amg_no_ml_) + ! + ! No preconditioning, should not really get here + ! + call psb_errpush(psb_err_internal_error_,name,& + & a_err='amg_no_ml_ in mlprc_aply?') + goto 9999 + + case(amg_add_ml_) + + call amg_c_inner_add(p, mlwrk, level, trans, work) + + case(amg_mult_ml_, amg_vcycle_ml_, amg_wcycle_ml_) + + call amg_c_inner_mult(p, mlwrk, level, trans, work) + +! !$ case(amg_kcycle_ml_, amg_kcyclesym_ml_) +! !$ +! !$ call amg_c_inner_k_cycle(p, mlwrk, level, trans, work) + + case default + info = psb_err_from_subroutine_ai_ + call psb_errpush(info,name,a_err='invalid ml_cycle',& + & i_Err=(/p%precv(level)%parms%ml_cycle,izero,izero,izero,izero/)) + goto 9999 + + end select + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + return + + end subroutine inner_ml_aply + + recursive subroutine amg_c_inner_add(p, mlwrk, level, trans, work) + use psb_base_mod + use amg_prec_mod + + implicit none + + !Input/Oputput variables + type(amg_cprec_type), intent(inout) :: p + + type(amg_mlwrk_type), target, intent(inout) :: mlwrk(:) + integer(psb_ipk_), intent(in) :: level + character, intent(in) :: trans + complex(psb_spk_),target :: work(:) + type(psb_c_vect_type) :: res + type(psb_c_vect_type), pointer :: current + integer(psb_ipk_) :: sweeps_post, sweeps_pre + ! Local variables + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me + integer(psb_ipk_) :: i, err_act + integer(psb_ipk_) :: debug_level, debug_unit + integer(psb_ipk_) :: nlev, ilev, sweeps + logical :: pre, post + character(len=20) :: name + + + + name = 'inner_inner_add' + info = psb_success_ + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + nlev = size(p%precv) + if ((level < 1) .or. (level > nlev)) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='wrong call level to inner_add') + goto 9999 + end if + ctxt = p%precv(level)%base_desc%get_context() + call psb_info(ctxt, me, np) + + if(debug_level > 1) then + write(debug_unit,*) me,' inner_add at level ',level + end if + + if ((level<1).or.(level>nlev)) then + info = psb_err_internal_error_ + call psb_errpush(info,name,& + & a_err='Invalid LEVEL>NLEV') + goto 9999 + end if + + sweeps = p%precv(level)%parms%sweeps_pre + call p%precv(level)%sm%apply(cone,& + & mlwrk(level)%x2l,czero,mlwrk(level)%y2l,& + & p%precv(level)%base_desc, trans,& + & sweeps,work,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Error during ADD smoother_apply') + goto 9999 + end if + + if (level < nlev) then + ! Apply the restriction + call p%precv(level+1)%map_rstr(cone,mlwrk(level)%x2l,& + & czero,mlwrk(level+1)%x2l,& + & info,work=work) + mlwrk(level+1)%y2l(:) = czero + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Error during restriction') + goto 9999 + end if + + call inner_ml_aply(level+1,p,mlwrk,trans,work,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Error in recursive call') + goto 9999 + end if + + ! + ! Apply the prolongator and add correction. + ! + call p%precv(level+1)%map_prol(cone,& + & mlwrk(level+1)%y2l,cone,mlwrk(level)%y2l,& + & info,work=work) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Error during prolongation') + goto 9999 + end if + + + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + return + + end subroutine amg_c_inner_add + + recursive subroutine amg_c_inner_mult(p, mlwrk, level, trans, work) + use psb_base_mod + use amg_prec_mod + + implicit none + + !Input/Oputput variables + type(amg_cprec_type), intent(inout) :: p + + type(amg_mlwrk_type), target, intent(inout) :: mlwrk(:) + integer(psb_ipk_), intent(in) :: level + character, intent(in) :: trans + complex(psb_spk_),target :: work(:) + type(psb_c_vect_type) :: res + type(psb_c_vect_type), pointer :: current + integer(psb_ipk_) :: sweeps_post, sweeps_pre + ! Local variables + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me + integer(psb_ipk_) :: i, err_act + integer(psb_ipk_) :: debug_level, debug_unit + integer(psb_ipk_) :: nlev, ilev, sweeps + logical :: pre, post + character(len=20) :: name + + + + name = 'inner_inner_mult' + info = psb_success_ + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + nlev = size(p%precv) + if ((level < 1) .or. (level > nlev)) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='wrong call level to inner_mult') + goto 9999 + end if + ctxt = p%precv(level)%base_desc%get_context() + call psb_info(ctxt, me, np) + + if(debug_level > 1) then + write(debug_unit,*) me,' inner_mult at level ',level + end if + + if ((level < nlev).or.(nlev == 1)) then + sweeps_post = p%precv(level)%parms%sweeps_post + sweeps_pre = p%precv(level)%parms%sweeps_pre + else + sweeps_post = p%precv(level-1)%parms%sweeps_post + sweeps_pre = p%precv(level-1)%parms%sweeps_pre + endif + + pre = ((sweeps_pre>0).and.(trans=='N')).or.((sweeps_post>0).and.(trans/='N')) + post = ((sweeps_post>0).and.(trans=='N')).or.((sweeps_pre>0).and.(trans/='N')) + + + if (level < nlev) then + + ! + ! Apply the first smoother + ! + + if (pre) then + if (trans == 'N') then + sweeps = p%precv(level)%parms%sweeps_pre + if (info == psb_success_) call p%precv(level)%sm%apply(cone,& + & mlwrk(level)%x2l,czero,mlwrk(level)%y2l,& + & p%precv(level)%base_desc, trans,& + & sweeps,work,info,init='Y') + else + sweeps = p%precv(level)%parms%sweeps_post + if (info == psb_success_) call p%precv(level)%sm2%apply(cone,& + & mlwrk(level)%x2l,czero,mlwrk(level)%y2l,& + & p%precv(level)%base_desc, trans,& + & sweeps,work,info,init='Y') + end if + + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Error during PRE smoother_apply') + goto 9999 + end if + endif + + ! + ! Compute the residual and call recursively + ! + if (pre) then + call psb_geaxpby(cone,mlwrk(level)%x2l,& + & czero,mlwrk(level)%ty,& + & p%precv(level)%base_desc,info) + + if (info == psb_success_) call psb_spmm(-cone,p%precv(level)%base_a,& + & mlwrk(level)%y2l,cone,mlwrk(level)%ty,& + & p%precv(level)%base_desc,info,work=work,trans=trans) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Error during residue') + goto 9999 + end if + call p%precv(level+1)%map_rstr(cone,mlwrk(level)%ty,& + & czero,mlwrk(level+1)%x2l,info,work=work) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Error during restriction') + goto 9999 + end if + else + ! Shortcut: just transfer x2l. + call p%precv(level+1)%map_rstr(cone,mlwrk(level)%x2l,& + & czero,mlwrk(level+1)%x2l,info,work=work) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Error during restriction') + goto 9999 + end if + endif + ! First guess is zero + mlwrk(level+1)%y2l(:) = czero + + + call inner_ml_aply(level+1,p,mlwrk,trans,work,info) + + if (p%precv(level)%parms%ml_cycle == amg_wcycle_ml_) then + ! On second call will use output y2l as initial guess + if (info == psb_success_) call inner_ml_aply(level+1,p,mlwrk,trans,work,info) + endif + + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Error in recursive call') + goto 9999 + end if + + + ! + ! Apply the prolongator + ! + call p%precv(level+1)%map_prol(cone,mlwrk(level+1)%y2l,& + & cone,mlwrk(level)%y2l,info,work=work) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Error during prolongation') + goto 9999 + end if + + ! + ! Compute the residual + ! + if (post) then + call psb_geaxpby(cone,mlwrk(level)%x2l,& + & czero,mlwrk(level)%tx,& + & p%precv(level)%base_desc,info) + call psb_spmm(-cone,p%precv(level)%base_a,mlwrk(level)%y2l,& + & cone,mlwrk(level)%tx,p%precv(level)%base_desc,info,& + & work=work,trans=trans) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Error during residue') + goto 9999 + end if + ! + ! Apply the second smoother + ! + if (trans == 'N') then + sweeps = p%precv(level)%parms%sweeps_post + if (info == psb_success_) call p%precv(level)%sm2%apply(cone,& + & mlwrk(level)%tx,cone,mlwrk(level)%y2l,& + & p%precv(level)%base_desc, trans,& + & sweeps,work,info,init='Z') + else + sweeps = p%precv(level)%parms%sweeps_pre + if (info == psb_success_) call p%precv(level)%sm%apply(cone,& + & mlwrk(level)%tx,cone,mlwrk(level)%y2l,& + & p%precv(level)%base_desc, trans,& + & sweeps,work,info,init='Z') + end if + + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Error during POST smoother_apply') + goto 9999 + end if + + endif + + else if (level == nlev) then + + sweeps = p%precv(level)%parms%sweeps_pre + if (info == psb_success_) call p%precv(level)%sm%apply(cone,& + & mlwrk(level)%x2l,czero,mlwrk(level)%y2l,& + & p%precv(level)%base_desc, trans,& + & sweeps,work,info) + + else + + info = psb_err_internal_error_ + call psb_errpush(info,name,& + & a_err='Invalid LEVEL vs NLEV') + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + return + + end subroutine amg_c_inner_mult + + +end subroutine amg_cmlprec_aply_a diff --git a/amgprec/impl/amg_d_hierarchy_bld.F90 b/amgprec/impl/amg_d_hierarchy_bld.F90 index 466ce335..9f6c6df3 100644 --- a/amgprec/impl/amg_d_hierarchy_bld.F90 +++ b/amgprec/impl/amg_d_hierarchy_bld.F90 @@ -98,6 +98,8 @@ subroutine amg_d_hierarchy_bld(a,desc_a,prec,info,cpymat) character(len=40) :: ch_err integer(psb_ipk_), save :: idx_bldtp=-1, idx_matasb=-1 logical, parameter :: do_timings=.false. + type(psb_ctxt_type) :: lctxt + integer(psb_ipk_) :: lme,lnp info=psb_success_ err=0 @@ -130,7 +132,7 @@ subroutine amg_d_hierarchy_bld(a,desc_a,prec,info,cpymat) end if cpymat_ = .false. if (present(cpymat)) cpymat_ = cpymat - + ! ! Check to ensure all procs have the same ! @@ -227,7 +229,7 @@ subroutine amg_d_hierarchy_bld(a,desc_a,prec,info,cpymat) casize = mncsize end if prec%ag_data%target_coarse_size = casize - + nplevs = max(itwo,mxplevs) ! @@ -301,7 +303,7 @@ subroutine amg_d_hierarchy_bld(a,desc_a,prec,info,cpymat) end if call psb_cd_renum_block(desc_a,prec%precv(1)%desc_ac,info) prec%precv(1)%base_desc => prec%precv(1)%desc_ac - + newsz = 0 array_build_loop: do i=2, iszv ! @@ -309,7 +311,9 @@ subroutine amg_d_hierarchy_bld(a,desc_a,prec,info,cpymat) ! on all processes. ! call psb_bcast(ctxt,prec%precv(i)%parms) - + lctxt = prec%precv(i-1)%base_desc%get_ctxt() + call psb_info(lctxt,lme,lnp) + write(0,*) 'Check at level',i,lme,lnp ! ! Sanity checks on the parameters ! @@ -376,18 +380,29 @@ subroutine amg_d_hierarchy_bld(a,desc_a,prec,info,cpymat) end if end if - if (all(nlaggr == prec%precv(i-1)%linmap%naggr)) then - newsz=i-1 - if (me == 0) then - write(debug_unit,*) trim(name),& - &': Warning: aggregates from level ',& - & newsz - write(debug_unit,*) trim(name),& - &': to level ',& - & iszv,' coincide.' - write(debug_unit,*) trim(name),& - &': Number of levels actually used :',newsz - write(debug_unit,*) + ! + ! TO BE REVIWED + ! + write(0,*) me,lme,allocated(prec%precv(i-1)%linmap%naggr) + if (allocated(prec%precv(i-1)%linmap%naggr)) then + write(0,*) me,lme,size(prec%precv(i-1)%linmap%naggr), size(nlaggr) + end if + if (.false.) then + if (lme >=0) then + if (all(nlaggr == prec%precv(i-1)%linmap%naggr)) then + newsz=i-1 + if (me == 0) then + write(debug_unit,*) trim(name),& + &': Warning: aggregates from level ',& + & newsz + write(debug_unit,*) trim(name),& + &': to level ',& + & iszv,' coincide.' + write(debug_unit,*) trim(name),& + &': Number of levels actually used :',newsz + write(debug_unit,*) + end if + end if end if end if end if @@ -426,6 +441,31 @@ subroutine amg_d_hierarchy_bld(a,desc_a,prec,info,cpymat) & a_err=ch_err) goto 9999 endif + if (amg_get_do_remap().and.(i>=2)) then + block + type(psb_ctxt_type) :: lctxt + integer(psb_ipk_) :: lme,lnp + lctxt = prec%precv(i)%desc_ac%get_ctxt() + call psb_info(lctxt,lme,lnp) + write(0,*) ' Context on remapping ',lme,lnp + if ((lme >=0).and.(lnp>=2)) then + associate(lv=>prec%precv(i), rmp => prec%precv(i)%remap_data) + call lv%desc_ac%clone(rmp%desc_ac_pre_remap,info) + call lv%ac%clone(rmp%ac_pre_remap,info) + write(0,*) ' Doing remapping ',lnp, lnp/2 + call psb_remap(lnp/2,rmp%desc_ac_pre_remap,rmp%ac_pre_remap,& + & rmp%idest,rmp%isrc,rmp%nrsrc,rmp%naggr,lv%desc_ac,lv%ac,info) +!!$ write(0,*) me,' Out of remapping ',rmp%desc_ac_pre_remap%get_fmt(),' ',& +!!$ & lv%desc_ac%get_fmt(),sum(lv%linmap%naggr),sum(rmp%naggr) + write(0,*) 'Assignment ',size(lv%linmap%naggr),size(rmp%naggr) + lv%linmap%naggr(:) = rmp%naggr(:) + lv%linmap%p_desc_V => rmp%desc_ac_pre_remap + lv%base_a => lv%ac + lv%base_desc => lv%desc_ac + end associate + end if + end block + end if exit array_build_loop else if (do_timings) call psb_tic(idx_matasb) @@ -442,8 +482,35 @@ subroutine amg_d_hierarchy_bld(a,desc_a,prec,info,cpymat) endif if (i=2)) then + block + type(psb_ctxt_type) :: lctxt + integer(psb_ipk_) :: lme,lnp + lctxt = prec%precv(i)%desc_ac%get_ctxt() + call psb_info(lctxt,lme,lnp) + write(0,*) ' Context on remapping ',lme,lnp + if ((lme >=0).and.(lnp>=2)) then + associate(lv=>prec%precv(i), rmp => prec%precv(i)%remap_data) + call lv%desc_ac%clone(rmp%desc_ac_pre_remap,info) + call lv%ac%clone(rmp%ac_pre_remap,info) + write(0,*) ' Doing remapping ',lnp, lnp/2 + call psb_remap(lnp/2,rmp%desc_ac_pre_remap,rmp%ac_pre_remap,& + & rmp%idest,rmp%isrc,rmp%nrsrc,rmp%naggr,lv%desc_ac,lv%ac,info) +!!$ write(0,*) me,' Out of remapping ',rmp%desc_ac_pre_remap%get_fmt(),' ',& +!!$ & lv%desc_ac%get_fmt(),sum(lv%linmap%naggr),sum(rmp%naggr) + write(0,*) 'Assignment ',size(lv%linmap%naggr),size(rmp%naggr) + lv%linmap%naggr(:) = rmp%naggr(:) + lv%linmap%p_desc_V => rmp%desc_ac_pre_remap + lv%base_a => lv%ac + lv%base_desc => lv%desc_ac + end associate + end if + end block + end if + write(0,*) ' End of array_build_loop',i,iszv,info end do array_build_loop - + write(0,*) ' Done array_build_loop',iszv,newsz,info,psb_errstatus_fatal() + call psb_barrier(ctxt) if (newsz > 0) then ! ! We exited early from the build loop, need to fix @@ -487,32 +554,35 @@ subroutine amg_d_hierarchy_bld(a,desc_a,prec,info,cpymat) & prec%precv(i)%linmap%p_desc_V => prec%precv(i)%base_desc end do end if + write(0,*) ' Done reallocating precv',iszv,newsz,info,psb_errstatus_fatal() + call psb_barrier(ctxt) !write(0,*) 'Should we remap? ' - if (amg_get_do_remap().and.(np>=4)) then + if (.false.) then + if (amg_get_do_remap().and.(np>=4)) then !!$ write(0,*) 'Going for remapping ' - if (.true.) then - associate(lv=>prec%precv(iszv), rmp => prec%precv(iszv)%remap_data) - call lv%desc_ac%clone(rmp%desc_ac_pre_remap,info) - call lv%ac%clone(rmp%ac_pre_remap,info) - if (np >= 8) then - call psb_remap(np/4,rmp%desc_ac_pre_remap,rmp%ac_pre_remap,& - & rmp%idest,rmp%isrc,rmp%nrsrc,rmp%naggr,lv%desc_ac,lv%ac,info) - else - call psb_remap(np/2,rmp%desc_ac_pre_remap,rmp%ac_pre_remap,& - & rmp%idest,rmp%isrc,rmp%nrsrc,rmp%naggr,lv%desc_ac,lv%ac,info) - end if + if (.true.) then + associate(lv=>prec%precv(iszv), rmp => prec%precv(iszv)%remap_data) + call lv%desc_ac%clone(rmp%desc_ac_pre_remap,info) + call lv%ac%clone(rmp%ac_pre_remap,info) + if (np >= 8) then + call psb_remap(np/4,rmp%desc_ac_pre_remap,rmp%ac_pre_remap,& + & rmp%idest,rmp%isrc,rmp%nrsrc,rmp%naggr,lv%desc_ac,lv%ac,info) + else + call psb_remap(np/2,rmp%desc_ac_pre_remap,rmp%ac_pre_remap,& + & rmp%idest,rmp%isrc,rmp%nrsrc,rmp%naggr,lv%desc_ac,lv%ac,info) + end if !!$ write(0,*) me,' Out of remapping ',rmp%desc_ac_pre_remap%get_fmt(),' ',& !!$ & lv%desc_ac%get_fmt(),sum(lv%linmap%naggr),sum(rmp%naggr) - lv%linmap%naggr(:) = rmp%naggr(:) - lv%linmap%p_desc_V => rmp%desc_ac_pre_remap - lv%base_a => lv%ac - lv%base_desc => lv%desc_ac - end associate + lv%linmap%naggr(:) = rmp%naggr(:) + lv%linmap%p_desc_V => rmp%desc_ac_pre_remap + lv%base_a => lv%ac + lv%base_desc => lv%desc_ac + end associate + end if end if end if - if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& & a_err='Internal hierarchy build' ) diff --git a/amgprec/impl/amg_dmlprec_aply.f90 b/amgprec/impl/amg_dmlprec_aply.f90 index a1a904de..bcddbcc1 100644 --- a/amgprec/impl/amg_dmlprec_aply.f90 +++ b/amgprec/impl/amg_dmlprec_aply.f90 @@ -207,6 +207,7 @@ subroutine amg_dmlprec_aply_vect(alpha,p,x,beta,y,desc_data,trans,work,info) use psb_base_mod use amg_base_prec_type + use amg_prec_mod use amg_d_inner_mod, amg_protect_name => amg_dmlprec_aply_vect implicit none @@ -605,7 +606,7 @@ contains if(debug_level > 1) then write(debug_unit,*) me,' inner_mult at level ',level end if - + write(debug_unit,*) me,' inner_mult at level (1):',level,np sweeps_post = p%precv(level)%parms%sweeps_post sweeps_pre = p%precv(level)%parms%sweeps_pre pre = ((sweeps_pre>0).and.(trans=='N')).or.((sweeps_post>0).and.(trans/='N')) @@ -615,6 +616,10 @@ contains & vtx => p%precv(level)%wrk%vtx,vty => p%precv(level)%wrk%vty,& & base_a => p%precv(level)%base_a, base_desc=>p%precv(level)%base_desc,& & wv => p%precv(level)%wrk%wv) + write(0,*) 'Inner mult at level (2):',level,' :',me,np,':',& + & size(p%precv(level)%wrk%wv), allocated(p%precv(level)%wrk%wv) + if (me >=0) then + if (level < nlev) then ! ! Apply the first smoother @@ -622,7 +627,6 @@ contains ! if (pre) then - if (me >=0) then !!$ write(0,*) me,'Applying smoother pre ', level if (trans == 'N') then sweeps = p%precv(level)%parms%sweeps_pre @@ -641,24 +645,26 @@ contains & a_err='Error during PRE smoother_apply') goto 9999 end if - end if - endif + + endif ! ! Compute the residual for next level and call recursively ! if (pre) then - call psb_geaxpby(done,vx2l,& - & dzero,vty,& - & base_desc,info) - - if (info == psb_success_) call psb_spmm(-done,base_a,& - & vy2l,done,vty,& - & base_desc,info,work=work,trans=trans) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during residue') - goto 9999 - end if + + call psb_geaxpby(done,vx2l,& + & dzero,vty,& + & base_desc,info) + + if (info == psb_success_) call psb_spmm(-done,base_a,& + & vy2l,done,vty,& + & base_desc,info,work=work,trans=trans) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Error during residue') + goto 9999 + end if + call p%precv(level+1)%map_rstr(done,vty,& & dzero,p%precv(level+1)%wrk%vx2l,& & info,work=work,& @@ -698,13 +704,13 @@ contains if (p%precv(level)%parms%ml_cycle == amg_wcycle_ml_) then - if (me >=0) then + call psb_geaxpby(done,vx2l, dzero,vty,& & base_desc,info) if (info == psb_success_) call psb_spmm(-done,base_a,& & vy2l,done,vty,& & base_desc,info,work=work,trans=trans) - end if + if (info == psb_success_) & & call p%precv(level+1)%map_rstr(done,vty,& & dzero,p%precv(level+1)%wrk%vx2l,info,work=work,& @@ -732,7 +738,7 @@ contains if (post) then - if (me >=0) then + call psb_geaxpby(done,vx2l,& & dzero,vty,& & base_desc,info) @@ -759,7 +765,7 @@ contains & vty,done,vy2l, base_desc, trans,& & sweeps,work,wv,info,init='Z') end if - end if + if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& @@ -786,6 +792,7 @@ contains & a_err='Invalid LEVEL vs NLEV') goto 9999 end if + end if end associate 9998 continue call psb_erractionrestore(err_act) @@ -1004,9 +1011,6 @@ contains end subroutine amg_d_inner_k_cycle recursive subroutine amg_dinneritkcycle(p, level, trans, work, innersolv) - use psb_base_mod - use amg_prec_mod - use amg_d_inner_mod, amg_protect_name => amg_dmlprec_aply implicit none @@ -1158,532 +1162,3 @@ contains end subroutine amg_dmlprec_aply_vect - -! -! Old routine for arrays instead of psb_X_vector. To be deleted eventually. -! -! -subroutine amg_dmlprec_aply(alpha,p,x,beta,y,desc_data,trans,work,info) - - use psb_base_mod - use amg_base_prec_type - use amg_d_inner_mod, amg_protect_name => amg_dmlprec_aply - - implicit none - - ! Arguments - type(psb_desc_type),intent(in) :: desc_data - type(amg_dprec_type), intent(inout) :: p - real(psb_dpk_),intent(in) :: alpha,beta - real(psb_dpk_),intent(inout) :: x(:) - real(psb_dpk_),intent(inout) :: y(:) - character, intent(in) :: trans - real(psb_dpk_),target :: work(:) - integer(psb_ipk_), intent(out) :: info - - ! Local variables - type(psb_ctxt_type) :: ctxt - integer(psb_ipk_) :: np, me - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: debug_level, debug_unit, nlev,nc2l,nr2l,level - character(len=20) :: name - character :: trans_ - type amg_mlwrk_type - real(psb_dpk_), allocatable :: tx(:), ty(:), x2l(:), y2l(:) - end type amg_mlwrk_type - type(amg_mlwrk_type), allocatable, target :: mlwrk(:) - - name='amg_dmlprec_aply' - info = psb_success_ - call psb_erractionsave(err_act) - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - - ctxt = desc_data%get_context() - call psb_info(ctxt, me, np) - - if (debug_level >= psb_debug_inner_) & - & write(debug_unit,*) me,' ',trim(name),& - & ' Entry ', size(p%precv) - - trans_ = psb_toupper(trans) - - nlev = size(p%precv) - allocate(mlwrk(nlev),stat=info) - if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') - goto 9999 - end if - level = 1 - - do level = 1, nlev - call psb_geasb(mlwrk(level)%x2l,& - & p%precv(level)%base_desc,info) - call psb_geasb(mlwrk(level)%y2l,& - & p%precv(level)%base_desc,info) - call psb_geasb(mlwrk(level)%tx,& - & p%precv(level)%base_desc,info) - call psb_geasb(mlwrk(level)%ty,& - & p%precv(level)%base_desc,info) - if (psb_errstatus_fatal()) then - nc2l = p%precv(level)%base_desc%get_local_cols() - info=psb_err_alloc_request_ - call psb_errpush(info,name,i_err=(/2*nc2l,izero,izero,izero,izero/),& - & a_err='real(psb_dpk_)') - goto 9999 - end if - end do - - mlwrk(level)%x2l(:) = x(:) - mlwrk(level)%y2l(:) = dzero - - call inner_ml_aply(level,p,mlwrk,trans_,work,info) - - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Inner prec aply') - goto 9999 - end if - - call psb_geaxpby(alpha,mlwrk(level)%y2l,beta,y,& - & p%precv(level)%base_desc,info) - - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error final update') - goto 9999 - end if - - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - -contains - - ! - ! - ! inner_ml_aply: apply AMG at a given level. - ! This routine dispatches the computation according to the type - ! specified at the current level. - ! Each of the corrections will inturn call recursively this routine. - ! - ! Assumptions: - ! On input: - ! mlprec_wkr(level)%vx2l contains the input vector (RHS) - ! mlprec_wkr(level)%vy2l contains the initial guess - ! - ! On output: - ! mlprec_wkr(level)%vy2l contains the solution - ! - ! Constraints: each of the called routines must properly handle - ! the input/output conditions for level+1 (i.e. apply - ! prolongation/restriction). - ! Note: for historical/convenience reasons the prolongator/restrictor - ! between level and level+1 are stored at level+1. - ! - ! - recursive subroutine inner_ml_aply(level,p,mlwrk,trans,work,info) - - implicit none - - ! Arguments - integer(psb_ipk_) :: level - type(amg_dprec_type), target, intent(inout) :: p - type(amg_mlwrk_type), intent(inout), target :: mlwrk(:) - character, intent(in) :: trans - real(psb_dpk_),target :: work(:) - integer(psb_ipk_), intent(out) :: info - - type(psb_d_vect_type) :: res - type(psb_d_vect_type), pointer :: current - integer(psb_ipk_) :: sweeps_post, sweeps_pre - ! Local variables - type(psb_ctxt_type) :: ctxt - integer(psb_ipk_) :: np, me - integer(psb_ipk_) :: i, err_act - integer(psb_ipk_) :: debug_level, debug_unit - integer(psb_ipk_) :: nlev, ilev, sweeps - logical :: pre, post - character(len=20) :: name - - - - name = 'inner_ml_aply' - info = psb_success_ - call psb_erractionsave(err_act) - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - nlev = size(p%precv) - if ((level < 1) .or. (level > nlev)) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='wrong call level to inner_ml') - goto 9999 - end if - ctxt = p%precv(level)%base_desc%get_context() - call psb_info(ctxt, me, np) - - if(debug_level > 1) then - write(debug_unit,*) me,' inner_ml_aply at level ',level - end if - - select case(p%precv(level)%parms%ml_cycle) - - case(amg_no_ml_) - ! - ! No preconditioning, should not really get here - ! - call psb_errpush(psb_err_internal_error_,name,& - & a_err='amg_no_ml_ in mlprc_aply?') - goto 9999 - - case(amg_add_ml_) - - call amg_d_inner_add(p, mlwrk, level, trans, work) - - case(amg_mult_ml_, amg_vcycle_ml_, amg_wcycle_ml_) - - call amg_d_inner_mult(p, mlwrk, level, trans, work) - -! !$ case(amg_kcycle_ml_, amg_kcyclesym_ml_) -! !$ -! !$ call amg_d_inner_k_cycle(p, mlwrk, level, trans, work) - - case default - info = psb_err_from_subroutine_ai_ - call psb_errpush(info,name,a_err='invalid ml_cycle',& - & i_Err=(/p%precv(level)%parms%ml_cycle,izero,izero,izero,izero/)) - goto 9999 - - end select - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - return - - end subroutine inner_ml_aply - - - recursive subroutine amg_d_inner_add(p, mlwrk, level, trans, work) - use psb_base_mod - use amg_prec_mod - - implicit none - - !Input/Oputput variables - type(amg_dprec_type), intent(inout) :: p - - type(amg_mlwrk_type), target, intent(inout) :: mlwrk(:) - integer(psb_ipk_), intent(in) :: level - character, intent(in) :: trans - real(psb_dpk_),target :: work(:) - type(psb_d_vect_type) :: res - type(psb_d_vect_type), pointer :: current - integer(psb_ipk_) :: sweeps_post, sweeps_pre - ! Local variables - type(psb_ctxt_type) :: ctxt - integer(psb_ipk_) :: np, me - integer(psb_ipk_) :: i, err_act - integer(psb_ipk_) :: debug_level, debug_unit - integer(psb_ipk_) :: nlev, ilev, sweeps - logical :: pre, post - character(len=20) :: name - - - - name = 'inner_inner_add' - info = psb_success_ - call psb_erractionsave(err_act) - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - nlev = size(p%precv) - if ((level < 1) .or. (level > nlev)) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='wrong call level to inner_add') - goto 9999 - end if - ctxt = p%precv(level)%base_desc%get_context() - call psb_info(ctxt, me, np) - - if(debug_level > 1) then - write(debug_unit,*) me,' inner_add at level ',level - end if - - if ((level<1).or.(level>nlev)) then - info = psb_err_internal_error_ - call psb_errpush(info,name,& - & a_err='Invalid LEVEL>NLEV') - goto 9999 - end if - - sweeps = p%precv(level)%parms%sweeps_pre - call p%precv(level)%sm%apply(done,& - & mlwrk(level)%x2l,dzero,mlwrk(level)%y2l,& - & p%precv(level)%base_desc, trans,& - & sweeps,work,info) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during ADD smoother_apply') - goto 9999 - end if - - if (level < nlev) then - ! Apply the restriction - call p%precv(level+1)%map_rstr(done,mlwrk(level)%x2l,& - & dzero,mlwrk(level+1)%x2l,& - & info,work=work) - mlwrk(level+1)%y2l(:) = dzero - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during restriction') - goto 9999 - end if - - call inner_ml_aply(level+1,p,mlwrk,trans,work,info) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error in recursive call') - goto 9999 - end if - - ! - ! Apply the prolongator and add correction. - ! - call p%precv(level+1)%map_prol(done,& - & mlwrk(level+1)%y2l,done,mlwrk(level)%y2l,& - & info,work=work) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during prolongation') - goto 9999 - end if - - - end if - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - return - - end subroutine amg_d_inner_add - - recursive subroutine amg_d_inner_mult(p, mlwrk, level, trans, work) - use psb_base_mod - use amg_prec_mod - - implicit none - - !Input/Oputput variables - type(amg_dprec_type), intent(inout) :: p - - type(amg_mlwrk_type), target, intent(inout) :: mlwrk(:) - integer(psb_ipk_), intent(in) :: level - character, intent(in) :: trans - real(psb_dpk_),target :: work(:) - type(psb_d_vect_type) :: res - type(psb_d_vect_type), pointer :: current - integer(psb_ipk_) :: sweeps_post, sweeps_pre - ! Local variables - type(psb_ctxt_type) :: ctxt - integer(psb_ipk_) :: np, me - integer(psb_ipk_) :: i, err_act - integer(psb_ipk_) :: debug_level, debug_unit - integer(psb_ipk_) :: nlev, ilev, sweeps - logical :: pre, post - character(len=20) :: name - - - - name = 'inner_inner_mult' - info = psb_success_ - call psb_erractionsave(err_act) - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - nlev = size(p%precv) - if ((level < 1) .or. (level > nlev)) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='wrong call level to inner_mult') - goto 9999 - end if - ctxt = p%precv(level)%base_desc%get_context() - call psb_info(ctxt, me, np) - - if(debug_level > 1) then - write(debug_unit,*) me,' inner_mult at level ',level - end if - - if ((level < nlev).or.(nlev == 1)) then - sweeps_post = p%precv(level)%parms%sweeps_post - sweeps_pre = p%precv(level)%parms%sweeps_pre - else - sweeps_post = p%precv(level-1)%parms%sweeps_post - sweeps_pre = p%precv(level-1)%parms%sweeps_pre - endif - - pre = ((sweeps_pre>0).and.(trans=='N')).or.((sweeps_post>0).and.(trans/='N')) - post = ((sweeps_post>0).and.(trans=='N')).or.((sweeps_pre>0).and.(trans/='N')) - - - if (level < nlev) then - - ! - ! Apply the first smoother - ! - - if (pre) then - if (trans == 'N') then - sweeps = p%precv(level)%parms%sweeps_pre - if (info == psb_success_) call p%precv(level)%sm%apply(done,& - & mlwrk(level)%x2l,dzero,mlwrk(level)%y2l,& - & p%precv(level)%base_desc, trans,& - & sweeps,work,info,init='Y') - else - sweeps = p%precv(level)%parms%sweeps_post - if (info == psb_success_) call p%precv(level)%sm2%apply(done,& - & mlwrk(level)%x2l,dzero,mlwrk(level)%y2l,& - & p%precv(level)%base_desc, trans,& - & sweeps,work,info,init='Y') - end if - - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during PRE smoother_apply') - goto 9999 - end if - endif - - ! - ! Compute the residual and call recursively - ! - if (pre) then - call psb_geaxpby(done,mlwrk(level)%x2l,& - & dzero,mlwrk(level)%ty,& - & p%precv(level)%base_desc,info) - - if (info == psb_success_) call psb_spmm(-done,p%precv(level)%base_a,& - & mlwrk(level)%y2l,done,mlwrk(level)%ty,& - & p%precv(level)%base_desc,info,work=work,trans=trans) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during residue') - goto 9999 - end if - call p%precv(level+1)%map_rstr(done,mlwrk(level)%ty,& - & dzero,mlwrk(level+1)%x2l,info,work=work) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during restriction') - goto 9999 - end if - else - ! Shortcut: just transfer x2l. - call p%precv(level+1)%map_rstr(done,mlwrk(level)%x2l,& - & dzero,mlwrk(level+1)%x2l,info,work=work) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during restriction') - goto 9999 - end if - endif - ! First guess is zero - mlwrk(level+1)%y2l(:) = dzero - - - call inner_ml_aply(level+1,p,mlwrk,trans,work,info) - - if (p%precv(level)%parms%ml_cycle == amg_wcycle_ml_) then - ! On second call will use output y2l as initial guess - if (info == psb_success_) call inner_ml_aply(level+1,p,mlwrk,trans,work,info) - endif - - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error in recursive call') - goto 9999 - end if - - - ! - ! Apply the prolongator - ! - call p%precv(level+1)%map_prol(done,mlwrk(level+1)%y2l,& - & done,mlwrk(level)%y2l,info,work=work) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during prolongation') - goto 9999 - end if - - ! - ! Compute the residual - ! - if (post) then - call psb_geaxpby(done,mlwrk(level)%x2l,& - & dzero,mlwrk(level)%tx,& - & p%precv(level)%base_desc,info) - call psb_spmm(-done,p%precv(level)%base_a,mlwrk(level)%y2l,& - & done,mlwrk(level)%tx,p%precv(level)%base_desc,info,& - & work=work,trans=trans) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during residue') - goto 9999 - end if - ! - ! Apply the second smoother - ! - if (trans == 'N') then - sweeps = p%precv(level)%parms%sweeps_post - if (info == psb_success_) call p%precv(level)%sm2%apply(done,& - & mlwrk(level)%tx,done,mlwrk(level)%y2l,& - & p%precv(level)%base_desc, trans,& - & sweeps,work,info,init='Z') - else - sweeps = p%precv(level)%parms%sweeps_pre - if (info == psb_success_) call p%precv(level)%sm%apply(done,& - & mlwrk(level)%tx,done,mlwrk(level)%y2l,& - & p%precv(level)%base_desc, trans,& - & sweeps,work,info,init='Z') - end if - - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during POST smoother_apply') - goto 9999 - end if - - endif - - else if (level == nlev) then - - sweeps = p%precv(level)%parms%sweeps_pre - if (info == psb_success_) call p%precv(level)%sm%apply(done,& - & mlwrk(level)%x2l,dzero,mlwrk(level)%y2l,& - & p%precv(level)%base_desc, trans,& - & sweeps,work,info) - - else - - info = psb_err_internal_error_ - call psb_errpush(info,name,& - & a_err='Invalid LEVEL vs NLEV') - goto 9999 - end if - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - return - - end subroutine amg_d_inner_mult - - -end subroutine amg_dmlprec_aply diff --git a/amgprec/impl/amg_dmlprec_aply_a.f90 b/amgprec/impl/amg_dmlprec_aply_a.f90 new file mode 100644 index 00000000..832656b5 --- /dev/null +++ b/amgprec/impl/amg_dmlprec_aply_a.f90 @@ -0,0 +1,733 @@ +! +! +! AMG4PSBLAS version 1.0 +! Algebraic Multigrid Package +! based on PSBLAS (Parallel Sparse BLAS version 3.7) +! +! (C) Copyright 2021 +! +! Salvatore Filippone +! Pasqua D'Ambra +! Fabio Durastante +! +! 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 AMG4PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific prior 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 AMG4PSBLAS 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: amg_dmlprec_aply.f90 +! +! Subroutine: amg_dmlprec_aply +! Version: real +! +! Current version of this file contributed by: +! Ambra Abdullahi Hassan +! +! +! This routine computes +! +! Y = beta*Y + alpha*op(ML^(-1))*X, +! where +! - ML is a multilevel preconditioner associated with +! a certain matrix A and stored in p, +! - op(ML^(-1)) is ML^(-1) or its transpose, according to the value of trans, +! - X and Y are vectors, +! - alpha and beta are scalars. +! +! The following multilevel strategies can be applied: +! +! - Additive multilevel Schwarz, +! - classical V-cycle, +! - classical W-cycle, +! - K-cycle both for symmetric and nonsymmetric matrices, where 2 iterations +! of FCG(1) or GCR, respectively, are applied at each level +! except the coarsest. +! +! For each level we have as many submatrices as processes (except for the coarsest +! level where we might have a replicated index space) and each process takes care +! of one submatrix. +! +! A multilevel preconditioner is regarded as an array of 'one-level' data structures, +! each containing the part of the preconditioner associated to a certain level +! (for more details see the description of amg_Tonelev_type in amg_prec_type.f90). +! For each level lev, there is a smoother stored in +! p%precv(lev)%sm +! which in turn contains a solver +! p$precv(lev)%sm%sv +! Typically the solver acts only locally, and the smoother applies any required +! parallel communication/action. +! Each level has a matrix A(lev), obtained by 'tranferring' the original +! matrix A (i.e. the matrix to be preconditioned) to the level lev, through smoothed +! aggregation. +! +! The levels are numbered in increasing order starting from the finest one, i.e. +! level 1 is the finest level and A(1) is the matrix A. +! +! This routine is formulated in a recursive way, so it is quite compact. +! +! The V-cycle can be described as follows, where +! P(lev) denotes the smoothed prolongator from level lev to level +! lev-1, while R(lev) denotes the corresponding restriction operator +! (normally its transpose) from level lev-1 to level lev. +! M(lev) is the smoother at the current level. +! +! +! 1. Transfer the outer vector Xest to u(1) (inner X at level 1) +! +! 2. Invoke V-cycle(1,M,P,R,A,b,u) +! +! procedure V-cycle(lev,M,P,R,A,b,u) +! +! if (lev < nlev) then +! +! u(lev) = u(lev) + M(lev)*(b(lev)-A(lev)*u(lev)) +! +! b(lev+1) = R(lev+1)*(b(lev)-A(lev)*u(lev)) +! +! u(lev+1) = V-cycle(lev+1,M,P,R,A,b,u) +! +! u(lev) = u(lev) + P(lev+1) * u(lev+1) +! +! u(lev) = u(lev) + M(lev)*(b(lev)-A(lev)*u(lev)) +! +! else +! +! solve A(lev)*u(lev) = b(lev) +! +! end if +! +! return u(lev) +! end +! +! 3. Transfer u(1) to the external: +! Yext = beta*Yext + alpha*u(1) +! +! +! In the implementation, the recursive procedure is inner_ml_aply, which +! in turn uses amg_inner_add (for additive multilevel), +! amg_inner_mult (for V-cycle and W-cycle), and +! amg_inner_k_cycle (for symmetric and non-symmetric K-cycle). +! +! For a detailed description of the algorithms, see: +! +! - B.F. Smith, P.E. Bjorstad, W.D. Gropp, +! Domain decomposition: parallel multilevel methods for elliptic partial +! differential equations, Cambridge University Press, 1996. +! +! - W. L. Briggs, V. E. Henson, S. F. McCormick, +! A Multigrid Tutorial, Second Edition +! SIAM, 2000. +! +! - K. Stuben, +! An Introduction to Algebraic Multigrid, +! in A. Schuller, U. Trottenberg, C. Oosterlee, Multigrid, Academic Press, 2001. +! +! - Y. Notay, P. S. Vassilevski, +! Recursive Krylov-based multigrid cycles +! Numerical Linear Algebra with Applications, 15 (5), 2008, 473--487. +! +! +! Arguments: +! alpha - real(psb_dpk_), input. +! The scalar alpha. +! p - type(amg_dprec_type), input. +! The multilevel preconditioner data structure containing the +! local part of the preconditioner to be applied. +! Note that nlev = size(p%precv) = number of levels. +! p%precv(lev)%sm - type(psb_dbaseprec_type) +! The pre-'smoother' for the current level +! p%precv(lev)%sm2 - type(psb_dbaseprec_type) +! The post-'smoother' for the current level +! may be the same or different from %sm +! p%precv(lev)%ac - type(psb_dspmat_type) +! The local part of the matrix A(lev). +! p%precv(lev)%parms - type(psb_dml_parms) +! Parameters controllin the multilevel prec. +! p%precv(lev)%desc_ac - type(psb_desc_type). +! The communication descriptor associated to the sparse +! matrix A(lev) +! p%precv(lev)%map - type(psb_inter_desc_type) +! Stores the linear operators mapping level (lev-1) +! to (lev) and vice versa. These are the restriction +! and prolongation operators described in the sequel. +! p%precv(lev)%base_a - type(psb_dspmat_type), pointer. +! Pointer (really a pointer!) to the base matrix of +! the current level, i.e. the local part of A(lev); +! so we have a unified treatment of residuals. We +! need this to avoid passing explicitly the matrix +! A(lev) to the routine which applies the +! preconditioner. +! p%precv(lev)%base_desc - type(psb_desc_type), pointer. +! Pointer to the communication descriptor associated +! to the sparse matrix pointed by base_a. +! +! x - real(psb_dpk_), dimension(:), input. +! The local part of the vector X. +! beta - real(psb_dpk_), input. +! The scalar beta. +! y - real(psb_dpk_), dimension(:), input/output. +! The local part of the vector Y. +! desc_data - type(psb_desc_type), input. +! The communication descriptor associated to the matrix to be +! preconditioned. +! trans - character, optional. +! If trans='N','n' then op(M^(-1)) = M^(-1); +! if trans='T','t' then op(M^(-1)) = M^(-T) (transpose of M^(-1)). +! work - real(psb_dpk_), dimension (:), optional, target. +! Workspace. Its size must be at least 4*desc_data%get_local_cols(). +! info - integer, output. +! Error code. +! +! Note that when the LU factorization of the matrix A(lev) is computed instead of +! the ILU one, by using UMFPACK or SuperLU or MUMPS, the corresponding +! L and U factors are stored in data structures handled +! by the third party software. +! + +! +! Old routine for arrays instead of psb_X_vector. To be deleted eventually. +! +! +subroutine amg_dmlprec_aply_a(alpha,p,x,beta,y,desc_data,trans,work,info) + + use psb_base_mod + use amg_base_prec_type + use amg_d_inner_mod, amg_protect_name => amg_dmlprec_aply_a + + implicit none + + ! Arguments + type(psb_desc_type),intent(in) :: desc_data + type(amg_dprec_type), intent(inout) :: p + real(psb_dpk_),intent(in) :: alpha,beta + real(psb_dpk_),intent(inout) :: x(:) + real(psb_dpk_),intent(inout) :: y(:) + character, intent(in) :: trans + real(psb_dpk_),target :: work(:) + integer(psb_ipk_), intent(out) :: info + + ! Local variables + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me + integer(psb_ipk_) :: err_act + integer(psb_ipk_) :: debug_level, debug_unit, nlev,nc2l,nr2l,level + character(len=20) :: name + character :: trans_ + type amg_mlwrk_type + real(psb_dpk_), allocatable :: tx(:), ty(:), x2l(:), y2l(:) + end type amg_mlwrk_type + type(amg_mlwrk_type), allocatable, target :: mlwrk(:) + + name='amg_dmlprec_aply' + info = psb_success_ + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + ctxt = desc_data%get_context() + call psb_info(ctxt, me, np) + + if (debug_level >= psb_debug_inner_) & + & write(debug_unit,*) me,' ',trim(name),& + & ' Entry ', size(p%precv) + + trans_ = psb_toupper(trans) + + nlev = size(p%precv) + allocate(mlwrk(nlev),stat=info) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') + goto 9999 + end if + level = 1 + + do level = 1, nlev + call psb_geasb(mlwrk(level)%x2l,& + & p%precv(level)%base_desc,info) + call psb_geasb(mlwrk(level)%y2l,& + & p%precv(level)%base_desc,info) + call psb_geasb(mlwrk(level)%tx,& + & p%precv(level)%base_desc,info) + call psb_geasb(mlwrk(level)%ty,& + & p%precv(level)%base_desc,info) + if (psb_errstatus_fatal()) then + nc2l = p%precv(level)%base_desc%get_local_cols() + info=psb_err_alloc_request_ + call psb_errpush(info,name,i_err=(/2*nc2l,izero,izero,izero,izero/),& + & a_err='real(psb_dpk_)') + goto 9999 + end if + end do + + mlwrk(level)%x2l(:) = x(:) + mlwrk(level)%y2l(:) = dzero + + call inner_ml_aply(level,p,mlwrk,trans_,work,info) + + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Inner prec aply') + goto 9999 + end if + + call psb_geaxpby(alpha,mlwrk(level)%y2l,beta,y,& + & p%precv(level)%base_desc,info) + + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Error final update') + goto 9999 + end if + + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +contains + + ! + ! + ! inner_ml_aply: apply AMG at a given level. + ! This routine dispatches the computation according to the type + ! specified at the current level. + ! Each of the corrections will inturn call recursively this routine. + ! + ! Assumptions: + ! On input: + ! mlprec_wkr(level)%vx2l contains the input vector (RHS) + ! mlprec_wkr(level)%vy2l contains the initial guess + ! + ! On output: + ! mlprec_wkr(level)%vy2l contains the solution + ! + ! Constraints: each of the called routines must properly handle + ! the input/output conditions for level+1 (i.e. apply + ! prolongation/restriction). + ! Note: for historical/convenience reasons the prolongator/restrictor + ! between level and level+1 are stored at level+1. + ! + ! + recursive subroutine inner_ml_aply(level,p,mlwrk,trans,work,info) + + implicit none + + ! Arguments + integer(psb_ipk_) :: level + type(amg_dprec_type), target, intent(inout) :: p + type(amg_mlwrk_type), intent(inout), target :: mlwrk(:) + character, intent(in) :: trans + real(psb_dpk_),target :: work(:) + integer(psb_ipk_), intent(out) :: info + + type(psb_d_vect_type) :: res + type(psb_d_vect_type), pointer :: current + integer(psb_ipk_) :: sweeps_post, sweeps_pre + ! Local variables + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me + integer(psb_ipk_) :: i, err_act + integer(psb_ipk_) :: debug_level, debug_unit + integer(psb_ipk_) :: nlev, ilev, sweeps + logical :: pre, post + character(len=20) :: name + + + + name = 'inner_ml_aply' + info = psb_success_ + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + nlev = size(p%precv) + if ((level < 1) .or. (level > nlev)) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='wrong call level to inner_ml') + goto 9999 + end if + ctxt = p%precv(level)%base_desc%get_context() + call psb_info(ctxt, me, np) + + if(debug_level > 1) then + write(debug_unit,*) me,' inner_ml_aply at level ',level + end if + + select case(p%precv(level)%parms%ml_cycle) + + case(amg_no_ml_) + ! + ! No preconditioning, should not really get here + ! + call psb_errpush(psb_err_internal_error_,name,& + & a_err='amg_no_ml_ in mlprc_aply?') + goto 9999 + + case(amg_add_ml_) + + call amg_d_inner_add(p, mlwrk, level, trans, work) + + case(amg_mult_ml_, amg_vcycle_ml_, amg_wcycle_ml_) + + call amg_d_inner_mult(p, mlwrk, level, trans, work) + +! !$ case(amg_kcycle_ml_, amg_kcyclesym_ml_) +! !$ +! !$ call amg_d_inner_k_cycle(p, mlwrk, level, trans, work) + + case default + info = psb_err_from_subroutine_ai_ + call psb_errpush(info,name,a_err='invalid ml_cycle',& + & i_Err=(/p%precv(level)%parms%ml_cycle,izero,izero,izero,izero/)) + goto 9999 + + end select + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + return + + end subroutine inner_ml_aply + + recursive subroutine amg_d_inner_add(p, mlwrk, level, trans, work) + use psb_base_mod + use amg_prec_mod + + implicit none + + !Input/Oputput variables + type(amg_dprec_type), intent(inout) :: p + + type(amg_mlwrk_type), target, intent(inout) :: mlwrk(:) + integer(psb_ipk_), intent(in) :: level + character, intent(in) :: trans + real(psb_dpk_),target :: work(:) + type(psb_d_vect_type) :: res + type(psb_d_vect_type), pointer :: current + integer(psb_ipk_) :: sweeps_post, sweeps_pre + ! Local variables + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me + integer(psb_ipk_) :: i, err_act + integer(psb_ipk_) :: debug_level, debug_unit + integer(psb_ipk_) :: nlev, ilev, sweeps + logical :: pre, post + character(len=20) :: name + + + + name = 'inner_inner_add' + info = psb_success_ + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + nlev = size(p%precv) + if ((level < 1) .or. (level > nlev)) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='wrong call level to inner_add') + goto 9999 + end if + ctxt = p%precv(level)%base_desc%get_context() + call psb_info(ctxt, me, np) + + if(debug_level > 1) then + write(debug_unit,*) me,' inner_add at level ',level + end if + + if ((level<1).or.(level>nlev)) then + info = psb_err_internal_error_ + call psb_errpush(info,name,& + & a_err='Invalid LEVEL>NLEV') + goto 9999 + end if + + sweeps = p%precv(level)%parms%sweeps_pre + call p%precv(level)%sm%apply(done,& + & mlwrk(level)%x2l,dzero,mlwrk(level)%y2l,& + & p%precv(level)%base_desc, trans,& + & sweeps,work,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Error during ADD smoother_apply') + goto 9999 + end if + + if (level < nlev) then + ! Apply the restriction + call p%precv(level+1)%map_rstr(done,mlwrk(level)%x2l,& + & dzero,mlwrk(level+1)%x2l,& + & info,work=work) + mlwrk(level+1)%y2l(:) = dzero + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Error during restriction') + goto 9999 + end if + + call inner_ml_aply(level+1,p,mlwrk,trans,work,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Error in recursive call') + goto 9999 + end if + + ! + ! Apply the prolongator and add correction. + ! + call p%precv(level+1)%map_prol(done,& + & mlwrk(level+1)%y2l,done,mlwrk(level)%y2l,& + & info,work=work) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Error during prolongation') + goto 9999 + end if + + + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + return + + end subroutine amg_d_inner_add + + recursive subroutine amg_d_inner_mult(p, mlwrk, level, trans, work) + use psb_base_mod + use amg_prec_mod + + implicit none + + !Input/Oputput variables + type(amg_dprec_type), intent(inout) :: p + + type(amg_mlwrk_type), target, intent(inout) :: mlwrk(:) + integer(psb_ipk_), intent(in) :: level + character, intent(in) :: trans + real(psb_dpk_),target :: work(:) + type(psb_d_vect_type) :: res + type(psb_d_vect_type), pointer :: current + integer(psb_ipk_) :: sweeps_post, sweeps_pre + ! Local variables + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me + integer(psb_ipk_) :: i, err_act + integer(psb_ipk_) :: debug_level, debug_unit + integer(psb_ipk_) :: nlev, ilev, sweeps + logical :: pre, post + character(len=20) :: name + + + + name = 'inner_inner_mult' + info = psb_success_ + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + nlev = size(p%precv) + if ((level < 1) .or. (level > nlev)) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='wrong call level to inner_mult') + goto 9999 + end if + ctxt = p%precv(level)%base_desc%get_context() + call psb_info(ctxt, me, np) + + if(debug_level > 1) then + write(debug_unit,*) me,' inner_mult at level ',level + end if + + if ((level < nlev).or.(nlev == 1)) then + sweeps_post = p%precv(level)%parms%sweeps_post + sweeps_pre = p%precv(level)%parms%sweeps_pre + else + sweeps_post = p%precv(level-1)%parms%sweeps_post + sweeps_pre = p%precv(level-1)%parms%sweeps_pre + endif + + pre = ((sweeps_pre>0).and.(trans=='N')).or.((sweeps_post>0).and.(trans/='N')) + post = ((sweeps_post>0).and.(trans=='N')).or.((sweeps_pre>0).and.(trans/='N')) + + + if (level < nlev) then + + ! + ! Apply the first smoother + ! + + if (pre) then + if (trans == 'N') then + sweeps = p%precv(level)%parms%sweeps_pre + if (info == psb_success_) call p%precv(level)%sm%apply(done,& + & mlwrk(level)%x2l,dzero,mlwrk(level)%y2l,& + & p%precv(level)%base_desc, trans,& + & sweeps,work,info,init='Y') + else + sweeps = p%precv(level)%parms%sweeps_post + if (info == psb_success_) call p%precv(level)%sm2%apply(done,& + & mlwrk(level)%x2l,dzero,mlwrk(level)%y2l,& + & p%precv(level)%base_desc, trans,& + & sweeps,work,info,init='Y') + end if + + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Error during PRE smoother_apply') + goto 9999 + end if + endif + + ! + ! Compute the residual and call recursively + ! + if (pre) then + call psb_geaxpby(done,mlwrk(level)%x2l,& + & dzero,mlwrk(level)%ty,& + & p%precv(level)%base_desc,info) + + if (info == psb_success_) call psb_spmm(-done,p%precv(level)%base_a,& + & mlwrk(level)%y2l,done,mlwrk(level)%ty,& + & p%precv(level)%base_desc,info,work=work,trans=trans) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Error during residue') + goto 9999 + end if + call p%precv(level+1)%map_rstr(done,mlwrk(level)%ty,& + & dzero,mlwrk(level+1)%x2l,info,work=work) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Error during restriction') + goto 9999 + end if + else + ! Shortcut: just transfer x2l. + call p%precv(level+1)%map_rstr(done,mlwrk(level)%x2l,& + & dzero,mlwrk(level+1)%x2l,info,work=work) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Error during restriction') + goto 9999 + end if + endif + ! First guess is zero + mlwrk(level+1)%y2l(:) = dzero + + + call inner_ml_aply(level+1,p,mlwrk,trans,work,info) + + if (p%precv(level)%parms%ml_cycle == amg_wcycle_ml_) then + ! On second call will use output y2l as initial guess + if (info == psb_success_) call inner_ml_aply(level+1,p,mlwrk,trans,work,info) + endif + + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Error in recursive call') + goto 9999 + end if + + + ! + ! Apply the prolongator + ! + call p%precv(level+1)%map_prol(done,mlwrk(level+1)%y2l,& + & done,mlwrk(level)%y2l,info,work=work) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Error during prolongation') + goto 9999 + end if + + ! + ! Compute the residual + ! + if (post) then + call psb_geaxpby(done,mlwrk(level)%x2l,& + & dzero,mlwrk(level)%tx,& + & p%precv(level)%base_desc,info) + call psb_spmm(-done,p%precv(level)%base_a,mlwrk(level)%y2l,& + & done,mlwrk(level)%tx,p%precv(level)%base_desc,info,& + & work=work,trans=trans) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Error during residue') + goto 9999 + end if + ! + ! Apply the second smoother + ! + if (trans == 'N') then + sweeps = p%precv(level)%parms%sweeps_post + if (info == psb_success_) call p%precv(level)%sm2%apply(done,& + & mlwrk(level)%tx,done,mlwrk(level)%y2l,& + & p%precv(level)%base_desc, trans,& + & sweeps,work,info,init='Z') + else + sweeps = p%precv(level)%parms%sweeps_pre + if (info == psb_success_) call p%precv(level)%sm%apply(done,& + & mlwrk(level)%tx,done,mlwrk(level)%y2l,& + & p%precv(level)%base_desc, trans,& + & sweeps,work,info,init='Z') + end if + + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Error during POST smoother_apply') + goto 9999 + end if + + endif + + else if (level == nlev) then + + sweeps = p%precv(level)%parms%sweeps_pre + if (info == psb_success_) call p%precv(level)%sm%apply(done,& + & mlwrk(level)%x2l,dzero,mlwrk(level)%y2l,& + & p%precv(level)%base_desc, trans,& + & sweeps,work,info) + + else + + info = psb_err_internal_error_ + call psb_errpush(info,name,& + & a_err='Invalid LEVEL vs NLEV') + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + return + + end subroutine amg_d_inner_mult + + +end subroutine amg_dmlprec_aply_a diff --git a/amgprec/impl/amg_s_hierarchy_bld.F90 b/amgprec/impl/amg_s_hierarchy_bld.F90 index 53d4534f..f54d4379 100644 --- a/amgprec/impl/amg_s_hierarchy_bld.F90 +++ b/amgprec/impl/amg_s_hierarchy_bld.F90 @@ -98,6 +98,8 @@ subroutine amg_s_hierarchy_bld(a,desc_a,prec,info,cpymat) character(len=40) :: ch_err integer(psb_ipk_), save :: idx_bldtp=-1, idx_matasb=-1 logical, parameter :: do_timings=.false. + type(psb_ctxt_type) :: lctxt + integer(psb_ipk_) :: lme,lnp info=psb_success_ err=0 @@ -130,7 +132,7 @@ subroutine amg_s_hierarchy_bld(a,desc_a,prec,info,cpymat) end if cpymat_ = .false. if (present(cpymat)) cpymat_ = cpymat - + ! ! Check to ensure all procs have the same ! @@ -227,7 +229,7 @@ subroutine amg_s_hierarchy_bld(a,desc_a,prec,info,cpymat) casize = mncsize end if prec%ag_data%target_coarse_size = casize - + nplevs = max(itwo,mxplevs) ! @@ -301,7 +303,7 @@ subroutine amg_s_hierarchy_bld(a,desc_a,prec,info,cpymat) end if call psb_cd_renum_block(desc_a,prec%precv(1)%desc_ac,info) prec%precv(1)%base_desc => prec%precv(1)%desc_ac - + newsz = 0 array_build_loop: do i=2, iszv ! @@ -309,7 +311,9 @@ subroutine amg_s_hierarchy_bld(a,desc_a,prec,info,cpymat) ! on all processes. ! call psb_bcast(ctxt,prec%precv(i)%parms) - + lctxt = prec%precv(i-1)%base_desc%get_ctxt() + call psb_info(lctxt,lme,lnp) + write(0,*) 'Check at level',i,lme,lnp ! ! Sanity checks on the parameters ! @@ -376,18 +380,29 @@ subroutine amg_s_hierarchy_bld(a,desc_a,prec,info,cpymat) end if end if - if (all(nlaggr == prec%precv(i-1)%linmap%naggr)) then - newsz=i-1 - if (me == 0) then - write(debug_unit,*) trim(name),& - &': Warning: aggregates from level ',& - & newsz - write(debug_unit,*) trim(name),& - &': to level ',& - & iszv,' coincide.' - write(debug_unit,*) trim(name),& - &': Number of levels actually used :',newsz - write(debug_unit,*) + ! + ! TO BE REVIWED + ! + write(0,*) me,lme,allocated(prec%precv(i-1)%linmap%naggr) + if (allocated(prec%precv(i-1)%linmap%naggr)) then + write(0,*) me,lme,size(prec%precv(i-1)%linmap%naggr), size(nlaggr) + end if + if (.false.) then + if (lme >=0) then + if (all(nlaggr == prec%precv(i-1)%linmap%naggr)) then + newsz=i-1 + if (me == 0) then + write(debug_unit,*) trim(name),& + &': Warning: aggregates from level ',& + & newsz + write(debug_unit,*) trim(name),& + &': to level ',& + & iszv,' coincide.' + write(debug_unit,*) trim(name),& + &': Number of levels actually used :',newsz + write(debug_unit,*) + end if + end if end if end if end if @@ -426,6 +441,31 @@ subroutine amg_s_hierarchy_bld(a,desc_a,prec,info,cpymat) & a_err=ch_err) goto 9999 endif + if (amg_get_do_remap().and.(i>=2)) then + block + type(psb_ctxt_type) :: lctxt + integer(psb_ipk_) :: lme,lnp + lctxt = prec%precv(i)%desc_ac%get_ctxt() + call psb_info(lctxt,lme,lnp) + write(0,*) ' Context on remapping ',lme,lnp + if ((lme >=0).and.(lnp>=2)) then + associate(lv=>prec%precv(i), rmp => prec%precv(i)%remap_data) + call lv%desc_ac%clone(rmp%desc_ac_pre_remap,info) + call lv%ac%clone(rmp%ac_pre_remap,info) + write(0,*) ' Doing remapping ',lnp, lnp/2 + call psb_remap(lnp/2,rmp%desc_ac_pre_remap,rmp%ac_pre_remap,& + & rmp%idest,rmp%isrc,rmp%nrsrc,rmp%naggr,lv%desc_ac,lv%ac,info) +!!$ write(0,*) me,' Out of remapping ',rmp%desc_ac_pre_remap%get_fmt(),' ',& +!!$ & lv%desc_ac%get_fmt(),sum(lv%linmap%naggr),sum(rmp%naggr) + write(0,*) 'Assignment ',size(lv%linmap%naggr),size(rmp%naggr) + lv%linmap%naggr(:) = rmp%naggr(:) + lv%linmap%p_desc_V => rmp%desc_ac_pre_remap + lv%base_a => lv%ac + lv%base_desc => lv%desc_ac + end associate + end if + end block + end if exit array_build_loop else if (do_timings) call psb_tic(idx_matasb) @@ -442,8 +482,35 @@ subroutine amg_s_hierarchy_bld(a,desc_a,prec,info,cpymat) endif if (i=2)) then + block + type(psb_ctxt_type) :: lctxt + integer(psb_ipk_) :: lme,lnp + lctxt = prec%precv(i)%desc_ac%get_ctxt() + call psb_info(lctxt,lme,lnp) + write(0,*) ' Context on remapping ',lme,lnp + if ((lme >=0).and.(lnp>=2)) then + associate(lv=>prec%precv(i), rmp => prec%precv(i)%remap_data) + call lv%desc_ac%clone(rmp%desc_ac_pre_remap,info) + call lv%ac%clone(rmp%ac_pre_remap,info) + write(0,*) ' Doing remapping ',lnp, lnp/2 + call psb_remap(lnp/2,rmp%desc_ac_pre_remap,rmp%ac_pre_remap,& + & rmp%idest,rmp%isrc,rmp%nrsrc,rmp%naggr,lv%desc_ac,lv%ac,info) +!!$ write(0,*) me,' Out of remapping ',rmp%desc_ac_pre_remap%get_fmt(),' ',& +!!$ & lv%desc_ac%get_fmt(),sum(lv%linmap%naggr),sum(rmp%naggr) + write(0,*) 'Assignment ',size(lv%linmap%naggr),size(rmp%naggr) + lv%linmap%naggr(:) = rmp%naggr(:) + lv%linmap%p_desc_V => rmp%desc_ac_pre_remap + lv%base_a => lv%ac + lv%base_desc => lv%desc_ac + end associate + end if + end block + end if + write(0,*) ' End of array_build_loop',i,iszv,info end do array_build_loop - + write(0,*) ' Done array_build_loop',iszv,newsz,info,psb_errstatus_fatal() + call psb_barrier(ctxt) if (newsz > 0) then ! ! We exited early from the build loop, need to fix @@ -487,32 +554,35 @@ subroutine amg_s_hierarchy_bld(a,desc_a,prec,info,cpymat) & prec%precv(i)%linmap%p_desc_V => prec%precv(i)%base_desc end do end if + write(0,*) ' Done reallocating precv',iszv,newsz,info,psb_errstatus_fatal() + call psb_barrier(ctxt) !write(0,*) 'Should we remap? ' - if (amg_get_do_remap().and.(np>=4)) then + if (.false.) then + if (amg_get_do_remap().and.(np>=4)) then !!$ write(0,*) 'Going for remapping ' - if (.true.) then - associate(lv=>prec%precv(iszv), rmp => prec%precv(iszv)%remap_data) - call lv%desc_ac%clone(rmp%desc_ac_pre_remap,info) - call lv%ac%clone(rmp%ac_pre_remap,info) - if (np >= 8) then - call psb_remap(np/4,rmp%desc_ac_pre_remap,rmp%ac_pre_remap,& - & rmp%idest,rmp%isrc,rmp%nrsrc,rmp%naggr,lv%desc_ac,lv%ac,info) - else - call psb_remap(np/2,rmp%desc_ac_pre_remap,rmp%ac_pre_remap,& - & rmp%idest,rmp%isrc,rmp%nrsrc,rmp%naggr,lv%desc_ac,lv%ac,info) - end if + if (.true.) then + associate(lv=>prec%precv(iszv), rmp => prec%precv(iszv)%remap_data) + call lv%desc_ac%clone(rmp%desc_ac_pre_remap,info) + call lv%ac%clone(rmp%ac_pre_remap,info) + if (np >= 8) then + call psb_remap(np/4,rmp%desc_ac_pre_remap,rmp%ac_pre_remap,& + & rmp%idest,rmp%isrc,rmp%nrsrc,rmp%naggr,lv%desc_ac,lv%ac,info) + else + call psb_remap(np/2,rmp%desc_ac_pre_remap,rmp%ac_pre_remap,& + & rmp%idest,rmp%isrc,rmp%nrsrc,rmp%naggr,lv%desc_ac,lv%ac,info) + end if !!$ write(0,*) me,' Out of remapping ',rmp%desc_ac_pre_remap%get_fmt(),' ',& !!$ & lv%desc_ac%get_fmt(),sum(lv%linmap%naggr),sum(rmp%naggr) - lv%linmap%naggr(:) = rmp%naggr(:) - lv%linmap%p_desc_V => rmp%desc_ac_pre_remap - lv%base_a => lv%ac - lv%base_desc => lv%desc_ac - end associate + lv%linmap%naggr(:) = rmp%naggr(:) + lv%linmap%p_desc_V => rmp%desc_ac_pre_remap + lv%base_a => lv%ac + lv%base_desc => lv%desc_ac + end associate + end if end if end if - if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& & a_err='Internal hierarchy build' ) diff --git a/amgprec/impl/amg_smlprec_aply.f90 b/amgprec/impl/amg_smlprec_aply.f90 index ee4df8e0..40091e60 100644 --- a/amgprec/impl/amg_smlprec_aply.f90 +++ b/amgprec/impl/amg_smlprec_aply.f90 @@ -207,6 +207,7 @@ subroutine amg_smlprec_aply_vect(alpha,p,x,beta,y,desc_data,trans,work,info) use psb_base_mod use amg_base_prec_type + use amg_prec_mod use amg_s_inner_mod, amg_protect_name => amg_smlprec_aply_vect implicit none @@ -605,7 +606,7 @@ contains if(debug_level > 1) then write(debug_unit,*) me,' inner_mult at level ',level end if - + write(debug_unit,*) me,' inner_mult at level (1):',level,np sweeps_post = p%precv(level)%parms%sweeps_post sweeps_pre = p%precv(level)%parms%sweeps_pre pre = ((sweeps_pre>0).and.(trans=='N')).or.((sweeps_post>0).and.(trans/='N')) @@ -615,6 +616,10 @@ contains & vtx => p%precv(level)%wrk%vtx,vty => p%precv(level)%wrk%vty,& & base_a => p%precv(level)%base_a, base_desc=>p%precv(level)%base_desc,& & wv => p%precv(level)%wrk%wv) + write(0,*) 'Inner mult at level (2):',level,' :',me,np,':',& + & size(p%precv(level)%wrk%wv), allocated(p%precv(level)%wrk%wv) + if (me >=0) then + if (level < nlev) then ! ! Apply the first smoother @@ -622,7 +627,6 @@ contains ! if (pre) then - if (me >=0) then !!$ write(0,*) me,'Applying smoother pre ', level if (trans == 'N') then sweeps = p%precv(level)%parms%sweeps_pre @@ -641,24 +645,26 @@ contains & a_err='Error during PRE smoother_apply') goto 9999 end if - end if - endif + + endif ! ! Compute the residual for next level and call recursively ! if (pre) then - call psb_geaxpby(sone,vx2l,& - & szero,vty,& - & base_desc,info) - - if (info == psb_success_) call psb_spmm(-sone,base_a,& - & vy2l,sone,vty,& - & base_desc,info,work=work,trans=trans) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during residue') - goto 9999 - end if + + call psb_geaxpby(sone,vx2l,& + & szero,vty,& + & base_desc,info) + + if (info == psb_success_) call psb_spmm(-sone,base_a,& + & vy2l,sone,vty,& + & base_desc,info,work=work,trans=trans) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Error during residue') + goto 9999 + end if + call p%precv(level+1)%map_rstr(sone,vty,& & szero,p%precv(level+1)%wrk%vx2l,& & info,work=work,& @@ -698,13 +704,13 @@ contains if (p%precv(level)%parms%ml_cycle == amg_wcycle_ml_) then - if (me >=0) then + call psb_geaxpby(sone,vx2l, szero,vty,& & base_desc,info) if (info == psb_success_) call psb_spmm(-sone,base_a,& & vy2l,sone,vty,& & base_desc,info,work=work,trans=trans) - end if + if (info == psb_success_) & & call p%precv(level+1)%map_rstr(sone,vty,& & szero,p%precv(level+1)%wrk%vx2l,info,work=work,& @@ -732,7 +738,7 @@ contains if (post) then - if (me >=0) then + call psb_geaxpby(sone,vx2l,& & szero,vty,& & base_desc,info) @@ -759,7 +765,7 @@ contains & vty,sone,vy2l, base_desc, trans,& & sweeps,work,wv,info,init='Z') end if - end if + if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& @@ -786,6 +792,7 @@ contains & a_err='Invalid LEVEL vs NLEV') goto 9999 end if + end if end associate 9998 continue call psb_erractionrestore(err_act) @@ -1004,9 +1011,6 @@ contains end subroutine amg_s_inner_k_cycle recursive subroutine amg_sinneritkcycle(p, level, trans, work, innersolv) - use psb_base_mod - use amg_prec_mod - use amg_s_inner_mod, amg_protect_name => amg_smlprec_aply implicit none @@ -1158,532 +1162,3 @@ contains end subroutine amg_smlprec_aply_vect - -! -! Old routine for arrays instead of psb_X_vector. To be deleted eventually. -! -! -subroutine amg_smlprec_aply(alpha,p,x,beta,y,desc_data,trans,work,info) - - use psb_base_mod - use amg_base_prec_type - use amg_s_inner_mod, amg_protect_name => amg_smlprec_aply - - implicit none - - ! Arguments - type(psb_desc_type),intent(in) :: desc_data - type(amg_sprec_type), intent(inout) :: p - real(psb_spk_),intent(in) :: alpha,beta - real(psb_spk_),intent(inout) :: x(:) - real(psb_spk_),intent(inout) :: y(:) - character, intent(in) :: trans - real(psb_spk_),target :: work(:) - integer(psb_ipk_), intent(out) :: info - - ! Local variables - type(psb_ctxt_type) :: ctxt - integer(psb_ipk_) :: np, me - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: debug_level, debug_unit, nlev,nc2l,nr2l,level - character(len=20) :: name - character :: trans_ - type amg_mlwrk_type - real(psb_spk_), allocatable :: tx(:), ty(:), x2l(:), y2l(:) - end type amg_mlwrk_type - type(amg_mlwrk_type), allocatable, target :: mlwrk(:) - - name='amg_smlprec_aply' - info = psb_success_ - call psb_erractionsave(err_act) - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - - ctxt = desc_data%get_context() - call psb_info(ctxt, me, np) - - if (debug_level >= psb_debug_inner_) & - & write(debug_unit,*) me,' ',trim(name),& - & ' Entry ', size(p%precv) - - trans_ = psb_toupper(trans) - - nlev = size(p%precv) - allocate(mlwrk(nlev),stat=info) - if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') - goto 9999 - end if - level = 1 - - do level = 1, nlev - call psb_geasb(mlwrk(level)%x2l,& - & p%precv(level)%base_desc,info) - call psb_geasb(mlwrk(level)%y2l,& - & p%precv(level)%base_desc,info) - call psb_geasb(mlwrk(level)%tx,& - & p%precv(level)%base_desc,info) - call psb_geasb(mlwrk(level)%ty,& - & p%precv(level)%base_desc,info) - if (psb_errstatus_fatal()) then - nc2l = p%precv(level)%base_desc%get_local_cols() - info=psb_err_alloc_request_ - call psb_errpush(info,name,i_err=(/2*nc2l,izero,izero,izero,izero/),& - & a_err='real(psb_spk_)') - goto 9999 - end if - end do - - mlwrk(level)%x2l(:) = x(:) - mlwrk(level)%y2l(:) = szero - - call inner_ml_aply(level,p,mlwrk,trans_,work,info) - - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Inner prec aply') - goto 9999 - end if - - call psb_geaxpby(alpha,mlwrk(level)%y2l,beta,y,& - & p%precv(level)%base_desc,info) - - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error final update') - goto 9999 - end if - - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - -contains - - ! - ! - ! inner_ml_aply: apply AMG at a given level. - ! This routine dispatches the computation according to the type - ! specified at the current level. - ! Each of the corrections will inturn call recursively this routine. - ! - ! Assumptions: - ! On input: - ! mlprec_wkr(level)%vx2l contains the input vector (RHS) - ! mlprec_wkr(level)%vy2l contains the initial guess - ! - ! On output: - ! mlprec_wkr(level)%vy2l contains the solution - ! - ! Constraints: each of the called routines must properly handle - ! the input/output conditions for level+1 (i.e. apply - ! prolongation/restriction). - ! Note: for historical/convenience reasons the prolongator/restrictor - ! between level and level+1 are stored at level+1. - ! - ! - recursive subroutine inner_ml_aply(level,p,mlwrk,trans,work,info) - - implicit none - - ! Arguments - integer(psb_ipk_) :: level - type(amg_sprec_type), target, intent(inout) :: p - type(amg_mlwrk_type), intent(inout), target :: mlwrk(:) - character, intent(in) :: trans - real(psb_spk_),target :: work(:) - integer(psb_ipk_), intent(out) :: info - - type(psb_s_vect_type) :: res - type(psb_s_vect_type), pointer :: current - integer(psb_ipk_) :: sweeps_post, sweeps_pre - ! Local variables - type(psb_ctxt_type) :: ctxt - integer(psb_ipk_) :: np, me - integer(psb_ipk_) :: i, err_act - integer(psb_ipk_) :: debug_level, debug_unit - integer(psb_ipk_) :: nlev, ilev, sweeps - logical :: pre, post - character(len=20) :: name - - - - name = 'inner_ml_aply' - info = psb_success_ - call psb_erractionsave(err_act) - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - nlev = size(p%precv) - if ((level < 1) .or. (level > nlev)) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='wrong call level to inner_ml') - goto 9999 - end if - ctxt = p%precv(level)%base_desc%get_context() - call psb_info(ctxt, me, np) - - if(debug_level > 1) then - write(debug_unit,*) me,' inner_ml_aply at level ',level - end if - - select case(p%precv(level)%parms%ml_cycle) - - case(amg_no_ml_) - ! - ! No preconditioning, should not really get here - ! - call psb_errpush(psb_err_internal_error_,name,& - & a_err='amg_no_ml_ in mlprc_aply?') - goto 9999 - - case(amg_add_ml_) - - call amg_s_inner_add(p, mlwrk, level, trans, work) - - case(amg_mult_ml_, amg_vcycle_ml_, amg_wcycle_ml_) - - call amg_s_inner_mult(p, mlwrk, level, trans, work) - -! !$ case(amg_kcycle_ml_, amg_kcyclesym_ml_) -! !$ -! !$ call amg_s_inner_k_cycle(p, mlwrk, level, trans, work) - - case default - info = psb_err_from_subroutine_ai_ - call psb_errpush(info,name,a_err='invalid ml_cycle',& - & i_Err=(/p%precv(level)%parms%ml_cycle,izero,izero,izero,izero/)) - goto 9999 - - end select - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - return - - end subroutine inner_ml_aply - - - recursive subroutine amg_s_inner_add(p, mlwrk, level, trans, work) - use psb_base_mod - use amg_prec_mod - - implicit none - - !Input/Oputput variables - type(amg_sprec_type), intent(inout) :: p - - type(amg_mlwrk_type), target, intent(inout) :: mlwrk(:) - integer(psb_ipk_), intent(in) :: level - character, intent(in) :: trans - real(psb_spk_),target :: work(:) - type(psb_s_vect_type) :: res - type(psb_s_vect_type), pointer :: current - integer(psb_ipk_) :: sweeps_post, sweeps_pre - ! Local variables - type(psb_ctxt_type) :: ctxt - integer(psb_ipk_) :: np, me - integer(psb_ipk_) :: i, err_act - integer(psb_ipk_) :: debug_level, debug_unit - integer(psb_ipk_) :: nlev, ilev, sweeps - logical :: pre, post - character(len=20) :: name - - - - name = 'inner_inner_add' - info = psb_success_ - call psb_erractionsave(err_act) - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - nlev = size(p%precv) - if ((level < 1) .or. (level > nlev)) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='wrong call level to inner_add') - goto 9999 - end if - ctxt = p%precv(level)%base_desc%get_context() - call psb_info(ctxt, me, np) - - if(debug_level > 1) then - write(debug_unit,*) me,' inner_add at level ',level - end if - - if ((level<1).or.(level>nlev)) then - info = psb_err_internal_error_ - call psb_errpush(info,name,& - & a_err='Invalid LEVEL>NLEV') - goto 9999 - end if - - sweeps = p%precv(level)%parms%sweeps_pre - call p%precv(level)%sm%apply(sone,& - & mlwrk(level)%x2l,szero,mlwrk(level)%y2l,& - & p%precv(level)%base_desc, trans,& - & sweeps,work,info) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during ADD smoother_apply') - goto 9999 - end if - - if (level < nlev) then - ! Apply the restriction - call p%precv(level+1)%map_rstr(sone,mlwrk(level)%x2l,& - & szero,mlwrk(level+1)%x2l,& - & info,work=work) - mlwrk(level+1)%y2l(:) = szero - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during restriction') - goto 9999 - end if - - call inner_ml_aply(level+1,p,mlwrk,trans,work,info) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error in recursive call') - goto 9999 - end if - - ! - ! Apply the prolongator and add correction. - ! - call p%precv(level+1)%map_prol(sone,& - & mlwrk(level+1)%y2l,sone,mlwrk(level)%y2l,& - & info,work=work) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during prolongation') - goto 9999 - end if - - - end if - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - return - - end subroutine amg_s_inner_add - - recursive subroutine amg_s_inner_mult(p, mlwrk, level, trans, work) - use psb_base_mod - use amg_prec_mod - - implicit none - - !Input/Oputput variables - type(amg_sprec_type), intent(inout) :: p - - type(amg_mlwrk_type), target, intent(inout) :: mlwrk(:) - integer(psb_ipk_), intent(in) :: level - character, intent(in) :: trans - real(psb_spk_),target :: work(:) - type(psb_s_vect_type) :: res - type(psb_s_vect_type), pointer :: current - integer(psb_ipk_) :: sweeps_post, sweeps_pre - ! Local variables - type(psb_ctxt_type) :: ctxt - integer(psb_ipk_) :: np, me - integer(psb_ipk_) :: i, err_act - integer(psb_ipk_) :: debug_level, debug_unit - integer(psb_ipk_) :: nlev, ilev, sweeps - logical :: pre, post - character(len=20) :: name - - - - name = 'inner_inner_mult' - info = psb_success_ - call psb_erractionsave(err_act) - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - nlev = size(p%precv) - if ((level < 1) .or. (level > nlev)) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='wrong call level to inner_mult') - goto 9999 - end if - ctxt = p%precv(level)%base_desc%get_context() - call psb_info(ctxt, me, np) - - if(debug_level > 1) then - write(debug_unit,*) me,' inner_mult at level ',level - end if - - if ((level < nlev).or.(nlev == 1)) then - sweeps_post = p%precv(level)%parms%sweeps_post - sweeps_pre = p%precv(level)%parms%sweeps_pre - else - sweeps_post = p%precv(level-1)%parms%sweeps_post - sweeps_pre = p%precv(level-1)%parms%sweeps_pre - endif - - pre = ((sweeps_pre>0).and.(trans=='N')).or.((sweeps_post>0).and.(trans/='N')) - post = ((sweeps_post>0).and.(trans=='N')).or.((sweeps_pre>0).and.(trans/='N')) - - - if (level < nlev) then - - ! - ! Apply the first smoother - ! - - if (pre) then - if (trans == 'N') then - sweeps = p%precv(level)%parms%sweeps_pre - if (info == psb_success_) call p%precv(level)%sm%apply(sone,& - & mlwrk(level)%x2l,szero,mlwrk(level)%y2l,& - & p%precv(level)%base_desc, trans,& - & sweeps,work,info,init='Y') - else - sweeps = p%precv(level)%parms%sweeps_post - if (info == psb_success_) call p%precv(level)%sm2%apply(sone,& - & mlwrk(level)%x2l,szero,mlwrk(level)%y2l,& - & p%precv(level)%base_desc, trans,& - & sweeps,work,info,init='Y') - end if - - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during PRE smoother_apply') - goto 9999 - end if - endif - - ! - ! Compute the residual and call recursively - ! - if (pre) then - call psb_geaxpby(sone,mlwrk(level)%x2l,& - & szero,mlwrk(level)%ty,& - & p%precv(level)%base_desc,info) - - if (info == psb_success_) call psb_spmm(-sone,p%precv(level)%base_a,& - & mlwrk(level)%y2l,sone,mlwrk(level)%ty,& - & p%precv(level)%base_desc,info,work=work,trans=trans) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during residue') - goto 9999 - end if - call p%precv(level+1)%map_rstr(sone,mlwrk(level)%ty,& - & szero,mlwrk(level+1)%x2l,info,work=work) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during restriction') - goto 9999 - end if - else - ! Shortcut: just transfer x2l. - call p%precv(level+1)%map_rstr(sone,mlwrk(level)%x2l,& - & szero,mlwrk(level+1)%x2l,info,work=work) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during restriction') - goto 9999 - end if - endif - ! First guess is zero - mlwrk(level+1)%y2l(:) = szero - - - call inner_ml_aply(level+1,p,mlwrk,trans,work,info) - - if (p%precv(level)%parms%ml_cycle == amg_wcycle_ml_) then - ! On second call will use output y2l as initial guess - if (info == psb_success_) call inner_ml_aply(level+1,p,mlwrk,trans,work,info) - endif - - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error in recursive call') - goto 9999 - end if - - - ! - ! Apply the prolongator - ! - call p%precv(level+1)%map_prol(sone,mlwrk(level+1)%y2l,& - & sone,mlwrk(level)%y2l,info,work=work) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during prolongation') - goto 9999 - end if - - ! - ! Compute the residual - ! - if (post) then - call psb_geaxpby(sone,mlwrk(level)%x2l,& - & szero,mlwrk(level)%tx,& - & p%precv(level)%base_desc,info) - call psb_spmm(-sone,p%precv(level)%base_a,mlwrk(level)%y2l,& - & sone,mlwrk(level)%tx,p%precv(level)%base_desc,info,& - & work=work,trans=trans) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during residue') - goto 9999 - end if - ! - ! Apply the second smoother - ! - if (trans == 'N') then - sweeps = p%precv(level)%parms%sweeps_post - if (info == psb_success_) call p%precv(level)%sm2%apply(sone,& - & mlwrk(level)%tx,sone,mlwrk(level)%y2l,& - & p%precv(level)%base_desc, trans,& - & sweeps,work,info,init='Z') - else - sweeps = p%precv(level)%parms%sweeps_pre - if (info == psb_success_) call p%precv(level)%sm%apply(sone,& - & mlwrk(level)%tx,sone,mlwrk(level)%y2l,& - & p%precv(level)%base_desc, trans,& - & sweeps,work,info,init='Z') - end if - - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during POST smoother_apply') - goto 9999 - end if - - endif - - else if (level == nlev) then - - sweeps = p%precv(level)%parms%sweeps_pre - if (info == psb_success_) call p%precv(level)%sm%apply(sone,& - & mlwrk(level)%x2l,szero,mlwrk(level)%y2l,& - & p%precv(level)%base_desc, trans,& - & sweeps,work,info) - - else - - info = psb_err_internal_error_ - call psb_errpush(info,name,& - & a_err='Invalid LEVEL vs NLEV') - goto 9999 - end if - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - return - - end subroutine amg_s_inner_mult - - -end subroutine amg_smlprec_aply diff --git a/amgprec/impl/amg_smlprec_aply_a.f90 b/amgprec/impl/amg_smlprec_aply_a.f90 new file mode 100644 index 00000000..1d35ceb7 --- /dev/null +++ b/amgprec/impl/amg_smlprec_aply_a.f90 @@ -0,0 +1,733 @@ +! +! +! AMG4PSBLAS version 1.0 +! Algebraic Multigrid Package +! based on PSBLAS (Parallel Sparse BLAS version 3.7) +! +! (C) Copyright 2021 +! +! Salvatore Filippone +! Pasqua D'Ambra +! Fabio Durastante +! +! 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 AMG4PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific prior 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 AMG4PSBLAS 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: amg_smlprec_aply.f90 +! +! Subroutine: amg_smlprec_aply +! Version: real +! +! Current version of this file contributed by: +! Ambra Abdullahi Hassan +! +! +! This routine computes +! +! Y = beta*Y + alpha*op(ML^(-1))*X, +! where +! - ML is a multilevel preconditioner associated with +! a certain matrix A and stored in p, +! - op(ML^(-1)) is ML^(-1) or its transpose, according to the value of trans, +! - X and Y are vectors, +! - alpha and beta are scalars. +! +! The following multilevel strategies can be applied: +! +! - Additive multilevel Schwarz, +! - classical V-cycle, +! - classical W-cycle, +! - K-cycle both for symmetric and nonsymmetric matrices, where 2 iterations +! of FCG(1) or GCR, respectively, are applied at each level +! except the coarsest. +! +! For each level we have as many submatrices as processes (except for the coarsest +! level where we might have a replicated index space) and each process takes care +! of one submatrix. +! +! A multilevel preconditioner is regarded as an array of 'one-level' data structures, +! each containing the part of the preconditioner associated to a certain level +! (for more details see the description of amg_Tonelev_type in amg_prec_type.f90). +! For each level lev, there is a smoother stored in +! p%precv(lev)%sm +! which in turn contains a solver +! p$precv(lev)%sm%sv +! Typically the solver acts only locally, and the smoother applies any required +! parallel communication/action. +! Each level has a matrix A(lev), obtained by 'tranferring' the original +! matrix A (i.e. the matrix to be preconditioned) to the level lev, through smoothed +! aggregation. +! +! The levels are numbered in increasing order starting from the finest one, i.e. +! level 1 is the finest level and A(1) is the matrix A. +! +! This routine is formulated in a recursive way, so it is quite compact. +! +! The V-cycle can be described as follows, where +! P(lev) denotes the smoothed prolongator from level lev to level +! lev-1, while R(lev) denotes the corresponding restriction operator +! (normally its transpose) from level lev-1 to level lev. +! M(lev) is the smoother at the current level. +! +! +! 1. Transfer the outer vector Xest to u(1) (inner X at level 1) +! +! 2. Invoke V-cycle(1,M,P,R,A,b,u) +! +! procedure V-cycle(lev,M,P,R,A,b,u) +! +! if (lev < nlev) then +! +! u(lev) = u(lev) + M(lev)*(b(lev)-A(lev)*u(lev)) +! +! b(lev+1) = R(lev+1)*(b(lev)-A(lev)*u(lev)) +! +! u(lev+1) = V-cycle(lev+1,M,P,R,A,b,u) +! +! u(lev) = u(lev) + P(lev+1) * u(lev+1) +! +! u(lev) = u(lev) + M(lev)*(b(lev)-A(lev)*u(lev)) +! +! else +! +! solve A(lev)*u(lev) = b(lev) +! +! end if +! +! return u(lev) +! end +! +! 3. Transfer u(1) to the external: +! Yext = beta*Yext + alpha*u(1) +! +! +! In the implementation, the recursive procedure is inner_ml_aply, which +! in turn uses amg_inner_add (for additive multilevel), +! amg_inner_mult (for V-cycle and W-cycle), and +! amg_inner_k_cycle (for symmetric and non-symmetric K-cycle). +! +! For a detailed description of the algorithms, see: +! +! - B.F. Smith, P.E. Bjorstad, W.D. Gropp, +! Domain decomposition: parallel multilevel methods for elliptic partial +! differential equations, Cambridge University Press, 1996. +! +! - W. L. Briggs, V. E. Henson, S. F. McCormick, +! A Multigrid Tutorial, Second Edition +! SIAM, 2000. +! +! - K. Stuben, +! An Introduction to Algebraic Multigrid, +! in A. Schuller, U. Trottenberg, C. Oosterlee, Multigrid, Academic Press, 2001. +! +! - Y. Notay, P. S. Vassilevski, +! Recursive Krylov-based multigrid cycles +! Numerical Linear Algebra with Applications, 15 (5), 2008, 473--487. +! +! +! Arguments: +! alpha - real(psb_spk_), input. +! The scalar alpha. +! p - type(amg_sprec_type), input. +! The multilevel preconditioner data structure containing the +! local part of the preconditioner to be applied. +! Note that nlev = size(p%precv) = number of levels. +! p%precv(lev)%sm - type(psb_sbaseprec_type) +! The pre-'smoother' for the current level +! p%precv(lev)%sm2 - type(psb_sbaseprec_type) +! The post-'smoother' for the current level +! may be the same or different from %sm +! p%precv(lev)%ac - type(psb_sspmat_type) +! The local part of the matrix A(lev). +! p%precv(lev)%parms - type(psb_sml_parms) +! Parameters controllin the multilevel prec. +! p%precv(lev)%desc_ac - type(psb_desc_type). +! The communication descriptor associated to the sparse +! matrix A(lev) +! p%precv(lev)%map - type(psb_inter_desc_type) +! Stores the linear operators mapping level (lev-1) +! to (lev) and vice versa. These are the restriction +! and prolongation operators described in the sequel. +! p%precv(lev)%base_a - type(psb_sspmat_type), pointer. +! Pointer (really a pointer!) to the base matrix of +! the current level, i.e. the local part of A(lev); +! so we have a unified treatment of residuals. We +! need this to avoid passing explicitly the matrix +! A(lev) to the routine which applies the +! preconditioner. +! p%precv(lev)%base_desc - type(psb_desc_type), pointer. +! Pointer to the communication descriptor associated +! to the sparse matrix pointed by base_a. +! +! x - real(psb_spk_), dimension(:), input. +! The local part of the vector X. +! beta - real(psb_spk_), input. +! The scalar beta. +! y - real(psb_spk_), dimension(:), input/output. +! The local part of the vector Y. +! desc_data - type(psb_desc_type), input. +! The communication descriptor associated to the matrix to be +! preconditioned. +! trans - character, optional. +! If trans='N','n' then op(M^(-1)) = M^(-1); +! if trans='T','t' then op(M^(-1)) = M^(-T) (transpose of M^(-1)). +! work - real(psb_spk_), dimension (:), optional, target. +! Workspace. Its size must be at least 4*desc_data%get_local_cols(). +! info - integer, output. +! Error code. +! +! Note that when the LU factorization of the matrix A(lev) is computed instead of +! the ILU one, by using UMFPACK or SuperLU or MUMPS, the corresponding +! L and U factors are stored in data structures handled +! by the third party software. +! + +! +! Old routine for arrays instead of psb_X_vector. To be deleted eventually. +! +! +subroutine amg_smlprec_aply_a(alpha,p,x,beta,y,desc_data,trans,work,info) + + use psb_base_mod + use amg_base_prec_type + use amg_s_inner_mod, amg_protect_name => amg_smlprec_aply_a + + implicit none + + ! Arguments + type(psb_desc_type),intent(in) :: desc_data + type(amg_sprec_type), intent(inout) :: p + real(psb_spk_),intent(in) :: alpha,beta + real(psb_spk_),intent(inout) :: x(:) + real(psb_spk_),intent(inout) :: y(:) + character, intent(in) :: trans + real(psb_spk_),target :: work(:) + integer(psb_ipk_), intent(out) :: info + + ! Local variables + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me + integer(psb_ipk_) :: err_act + integer(psb_ipk_) :: debug_level, debug_unit, nlev,nc2l,nr2l,level + character(len=20) :: name + character :: trans_ + type amg_mlwrk_type + real(psb_spk_), allocatable :: tx(:), ty(:), x2l(:), y2l(:) + end type amg_mlwrk_type + type(amg_mlwrk_type), allocatable, target :: mlwrk(:) + + name='amg_smlprec_aply' + info = psb_success_ + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + ctxt = desc_data%get_context() + call psb_info(ctxt, me, np) + + if (debug_level >= psb_debug_inner_) & + & write(debug_unit,*) me,' ',trim(name),& + & ' Entry ', size(p%precv) + + trans_ = psb_toupper(trans) + + nlev = size(p%precv) + allocate(mlwrk(nlev),stat=info) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') + goto 9999 + end if + level = 1 + + do level = 1, nlev + call psb_geasb(mlwrk(level)%x2l,& + & p%precv(level)%base_desc,info) + call psb_geasb(mlwrk(level)%y2l,& + & p%precv(level)%base_desc,info) + call psb_geasb(mlwrk(level)%tx,& + & p%precv(level)%base_desc,info) + call psb_geasb(mlwrk(level)%ty,& + & p%precv(level)%base_desc,info) + if (psb_errstatus_fatal()) then + nc2l = p%precv(level)%base_desc%get_local_cols() + info=psb_err_alloc_request_ + call psb_errpush(info,name,i_err=(/2*nc2l,izero,izero,izero,izero/),& + & a_err='real(psb_spk_)') + goto 9999 + end if + end do + + mlwrk(level)%x2l(:) = x(:) + mlwrk(level)%y2l(:) = szero + + call inner_ml_aply(level,p,mlwrk,trans_,work,info) + + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Inner prec aply') + goto 9999 + end if + + call psb_geaxpby(alpha,mlwrk(level)%y2l,beta,y,& + & p%precv(level)%base_desc,info) + + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Error final update') + goto 9999 + end if + + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +contains + + ! + ! + ! inner_ml_aply: apply AMG at a given level. + ! This routine dispatches the computation according to the type + ! specified at the current level. + ! Each of the corrections will inturn call recursively this routine. + ! + ! Assumptions: + ! On input: + ! mlprec_wkr(level)%vx2l contains the input vector (RHS) + ! mlprec_wkr(level)%vy2l contains the initial guess + ! + ! On output: + ! mlprec_wkr(level)%vy2l contains the solution + ! + ! Constraints: each of the called routines must properly handle + ! the input/output conditions for level+1 (i.e. apply + ! prolongation/restriction). + ! Note: for historical/convenience reasons the prolongator/restrictor + ! between level and level+1 are stored at level+1. + ! + ! + recursive subroutine inner_ml_aply(level,p,mlwrk,trans,work,info) + + implicit none + + ! Arguments + integer(psb_ipk_) :: level + type(amg_sprec_type), target, intent(inout) :: p + type(amg_mlwrk_type), intent(inout), target :: mlwrk(:) + character, intent(in) :: trans + real(psb_spk_),target :: work(:) + integer(psb_ipk_), intent(out) :: info + + type(psb_s_vect_type) :: res + type(psb_s_vect_type), pointer :: current + integer(psb_ipk_) :: sweeps_post, sweeps_pre + ! Local variables + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me + integer(psb_ipk_) :: i, err_act + integer(psb_ipk_) :: debug_level, debug_unit + integer(psb_ipk_) :: nlev, ilev, sweeps + logical :: pre, post + character(len=20) :: name + + + + name = 'inner_ml_aply' + info = psb_success_ + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + nlev = size(p%precv) + if ((level < 1) .or. (level > nlev)) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='wrong call level to inner_ml') + goto 9999 + end if + ctxt = p%precv(level)%base_desc%get_context() + call psb_info(ctxt, me, np) + + if(debug_level > 1) then + write(debug_unit,*) me,' inner_ml_aply at level ',level + end if + + select case(p%precv(level)%parms%ml_cycle) + + case(amg_no_ml_) + ! + ! No preconditioning, should not really get here + ! + call psb_errpush(psb_err_internal_error_,name,& + & a_err='amg_no_ml_ in mlprc_aply?') + goto 9999 + + case(amg_add_ml_) + + call amg_s_inner_add(p, mlwrk, level, trans, work) + + case(amg_mult_ml_, amg_vcycle_ml_, amg_wcycle_ml_) + + call amg_s_inner_mult(p, mlwrk, level, trans, work) + +! !$ case(amg_kcycle_ml_, amg_kcyclesym_ml_) +! !$ +! !$ call amg_s_inner_k_cycle(p, mlwrk, level, trans, work) + + case default + info = psb_err_from_subroutine_ai_ + call psb_errpush(info,name,a_err='invalid ml_cycle',& + & i_Err=(/p%precv(level)%parms%ml_cycle,izero,izero,izero,izero/)) + goto 9999 + + end select + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + return + + end subroutine inner_ml_aply + + recursive subroutine amg_s_inner_add(p, mlwrk, level, trans, work) + use psb_base_mod + use amg_prec_mod + + implicit none + + !Input/Oputput variables + type(amg_sprec_type), intent(inout) :: p + + type(amg_mlwrk_type), target, intent(inout) :: mlwrk(:) + integer(psb_ipk_), intent(in) :: level + character, intent(in) :: trans + real(psb_spk_),target :: work(:) + type(psb_s_vect_type) :: res + type(psb_s_vect_type), pointer :: current + integer(psb_ipk_) :: sweeps_post, sweeps_pre + ! Local variables + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me + integer(psb_ipk_) :: i, err_act + integer(psb_ipk_) :: debug_level, debug_unit + integer(psb_ipk_) :: nlev, ilev, sweeps + logical :: pre, post + character(len=20) :: name + + + + name = 'inner_inner_add' + info = psb_success_ + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + nlev = size(p%precv) + if ((level < 1) .or. (level > nlev)) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='wrong call level to inner_add') + goto 9999 + end if + ctxt = p%precv(level)%base_desc%get_context() + call psb_info(ctxt, me, np) + + if(debug_level > 1) then + write(debug_unit,*) me,' inner_add at level ',level + end if + + if ((level<1).or.(level>nlev)) then + info = psb_err_internal_error_ + call psb_errpush(info,name,& + & a_err='Invalid LEVEL>NLEV') + goto 9999 + end if + + sweeps = p%precv(level)%parms%sweeps_pre + call p%precv(level)%sm%apply(sone,& + & mlwrk(level)%x2l,szero,mlwrk(level)%y2l,& + & p%precv(level)%base_desc, trans,& + & sweeps,work,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Error during ADD smoother_apply') + goto 9999 + end if + + if (level < nlev) then + ! Apply the restriction + call p%precv(level+1)%map_rstr(sone,mlwrk(level)%x2l,& + & szero,mlwrk(level+1)%x2l,& + & info,work=work) + mlwrk(level+1)%y2l(:) = szero + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Error during restriction') + goto 9999 + end if + + call inner_ml_aply(level+1,p,mlwrk,trans,work,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Error in recursive call') + goto 9999 + end if + + ! + ! Apply the prolongator and add correction. + ! + call p%precv(level+1)%map_prol(sone,& + & mlwrk(level+1)%y2l,sone,mlwrk(level)%y2l,& + & info,work=work) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Error during prolongation') + goto 9999 + end if + + + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + return + + end subroutine amg_s_inner_add + + recursive subroutine amg_s_inner_mult(p, mlwrk, level, trans, work) + use psb_base_mod + use amg_prec_mod + + implicit none + + !Input/Oputput variables + type(amg_sprec_type), intent(inout) :: p + + type(amg_mlwrk_type), target, intent(inout) :: mlwrk(:) + integer(psb_ipk_), intent(in) :: level + character, intent(in) :: trans + real(psb_spk_),target :: work(:) + type(psb_s_vect_type) :: res + type(psb_s_vect_type), pointer :: current + integer(psb_ipk_) :: sweeps_post, sweeps_pre + ! Local variables + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me + integer(psb_ipk_) :: i, err_act + integer(psb_ipk_) :: debug_level, debug_unit + integer(psb_ipk_) :: nlev, ilev, sweeps + logical :: pre, post + character(len=20) :: name + + + + name = 'inner_inner_mult' + info = psb_success_ + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + nlev = size(p%precv) + if ((level < 1) .or. (level > nlev)) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='wrong call level to inner_mult') + goto 9999 + end if + ctxt = p%precv(level)%base_desc%get_context() + call psb_info(ctxt, me, np) + + if(debug_level > 1) then + write(debug_unit,*) me,' inner_mult at level ',level + end if + + if ((level < nlev).or.(nlev == 1)) then + sweeps_post = p%precv(level)%parms%sweeps_post + sweeps_pre = p%precv(level)%parms%sweeps_pre + else + sweeps_post = p%precv(level-1)%parms%sweeps_post + sweeps_pre = p%precv(level-1)%parms%sweeps_pre + endif + + pre = ((sweeps_pre>0).and.(trans=='N')).or.((sweeps_post>0).and.(trans/='N')) + post = ((sweeps_post>0).and.(trans=='N')).or.((sweeps_pre>0).and.(trans/='N')) + + + if (level < nlev) then + + ! + ! Apply the first smoother + ! + + if (pre) then + if (trans == 'N') then + sweeps = p%precv(level)%parms%sweeps_pre + if (info == psb_success_) call p%precv(level)%sm%apply(sone,& + & mlwrk(level)%x2l,szero,mlwrk(level)%y2l,& + & p%precv(level)%base_desc, trans,& + & sweeps,work,info,init='Y') + else + sweeps = p%precv(level)%parms%sweeps_post + if (info == psb_success_) call p%precv(level)%sm2%apply(sone,& + & mlwrk(level)%x2l,szero,mlwrk(level)%y2l,& + & p%precv(level)%base_desc, trans,& + & sweeps,work,info,init='Y') + end if + + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Error during PRE smoother_apply') + goto 9999 + end if + endif + + ! + ! Compute the residual and call recursively + ! + if (pre) then + call psb_geaxpby(sone,mlwrk(level)%x2l,& + & szero,mlwrk(level)%ty,& + & p%precv(level)%base_desc,info) + + if (info == psb_success_) call psb_spmm(-sone,p%precv(level)%base_a,& + & mlwrk(level)%y2l,sone,mlwrk(level)%ty,& + & p%precv(level)%base_desc,info,work=work,trans=trans) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Error during residue') + goto 9999 + end if + call p%precv(level+1)%map_rstr(sone,mlwrk(level)%ty,& + & szero,mlwrk(level+1)%x2l,info,work=work) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Error during restriction') + goto 9999 + end if + else + ! Shortcut: just transfer x2l. + call p%precv(level+1)%map_rstr(sone,mlwrk(level)%x2l,& + & szero,mlwrk(level+1)%x2l,info,work=work) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Error during restriction') + goto 9999 + end if + endif + ! First guess is zero + mlwrk(level+1)%y2l(:) = szero + + + call inner_ml_aply(level+1,p,mlwrk,trans,work,info) + + if (p%precv(level)%parms%ml_cycle == amg_wcycle_ml_) then + ! On second call will use output y2l as initial guess + if (info == psb_success_) call inner_ml_aply(level+1,p,mlwrk,trans,work,info) + endif + + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Error in recursive call') + goto 9999 + end if + + + ! + ! Apply the prolongator + ! + call p%precv(level+1)%map_prol(sone,mlwrk(level+1)%y2l,& + & sone,mlwrk(level)%y2l,info,work=work) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Error during prolongation') + goto 9999 + end if + + ! + ! Compute the residual + ! + if (post) then + call psb_geaxpby(sone,mlwrk(level)%x2l,& + & szero,mlwrk(level)%tx,& + & p%precv(level)%base_desc,info) + call psb_spmm(-sone,p%precv(level)%base_a,mlwrk(level)%y2l,& + & sone,mlwrk(level)%tx,p%precv(level)%base_desc,info,& + & work=work,trans=trans) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Error during residue') + goto 9999 + end if + ! + ! Apply the second smoother + ! + if (trans == 'N') then + sweeps = p%precv(level)%parms%sweeps_post + if (info == psb_success_) call p%precv(level)%sm2%apply(sone,& + & mlwrk(level)%tx,sone,mlwrk(level)%y2l,& + & p%precv(level)%base_desc, trans,& + & sweeps,work,info,init='Z') + else + sweeps = p%precv(level)%parms%sweeps_pre + if (info == psb_success_) call p%precv(level)%sm%apply(sone,& + & mlwrk(level)%tx,sone,mlwrk(level)%y2l,& + & p%precv(level)%base_desc, trans,& + & sweeps,work,info,init='Z') + end if + + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Error during POST smoother_apply') + goto 9999 + end if + + endif + + else if (level == nlev) then + + sweeps = p%precv(level)%parms%sweeps_pre + if (info == psb_success_) call p%precv(level)%sm%apply(sone,& + & mlwrk(level)%x2l,szero,mlwrk(level)%y2l,& + & p%precv(level)%base_desc, trans,& + & sweeps,work,info) + + else + + info = psb_err_internal_error_ + call psb_errpush(info,name,& + & a_err='Invalid LEVEL vs NLEV') + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + return + + end subroutine amg_s_inner_mult + + +end subroutine amg_smlprec_aply_a diff --git a/amgprec/impl/amg_z_hierarchy_bld.F90 b/amgprec/impl/amg_z_hierarchy_bld.F90 index 9c1da2d2..6a2cd661 100644 --- a/amgprec/impl/amg_z_hierarchy_bld.F90 +++ b/amgprec/impl/amg_z_hierarchy_bld.F90 @@ -98,6 +98,8 @@ subroutine amg_z_hierarchy_bld(a,desc_a,prec,info,cpymat) character(len=40) :: ch_err integer(psb_ipk_), save :: idx_bldtp=-1, idx_matasb=-1 logical, parameter :: do_timings=.false. + type(psb_ctxt_type) :: lctxt + integer(psb_ipk_) :: lme,lnp info=psb_success_ err=0 @@ -130,7 +132,7 @@ subroutine amg_z_hierarchy_bld(a,desc_a,prec,info,cpymat) end if cpymat_ = .false. if (present(cpymat)) cpymat_ = cpymat - + ! ! Check to ensure all procs have the same ! @@ -227,7 +229,7 @@ subroutine amg_z_hierarchy_bld(a,desc_a,prec,info,cpymat) casize = mncsize end if prec%ag_data%target_coarse_size = casize - + nplevs = max(itwo,mxplevs) ! @@ -301,7 +303,7 @@ subroutine amg_z_hierarchy_bld(a,desc_a,prec,info,cpymat) end if call psb_cd_renum_block(desc_a,prec%precv(1)%desc_ac,info) prec%precv(1)%base_desc => prec%precv(1)%desc_ac - + newsz = 0 array_build_loop: do i=2, iszv ! @@ -309,7 +311,9 @@ subroutine amg_z_hierarchy_bld(a,desc_a,prec,info,cpymat) ! on all processes. ! call psb_bcast(ctxt,prec%precv(i)%parms) - + lctxt = prec%precv(i-1)%base_desc%get_ctxt() + call psb_info(lctxt,lme,lnp) + write(0,*) 'Check at level',i,lme,lnp ! ! Sanity checks on the parameters ! @@ -376,18 +380,29 @@ subroutine amg_z_hierarchy_bld(a,desc_a,prec,info,cpymat) end if end if - if (all(nlaggr == prec%precv(i-1)%linmap%naggr)) then - newsz=i-1 - if (me == 0) then - write(debug_unit,*) trim(name),& - &': Warning: aggregates from level ',& - & newsz - write(debug_unit,*) trim(name),& - &': to level ',& - & iszv,' coincide.' - write(debug_unit,*) trim(name),& - &': Number of levels actually used :',newsz - write(debug_unit,*) + ! + ! TO BE REVIWED + ! + write(0,*) me,lme,allocated(prec%precv(i-1)%linmap%naggr) + if (allocated(prec%precv(i-1)%linmap%naggr)) then + write(0,*) me,lme,size(prec%precv(i-1)%linmap%naggr), size(nlaggr) + end if + if (.false.) then + if (lme >=0) then + if (all(nlaggr == prec%precv(i-1)%linmap%naggr)) then + newsz=i-1 + if (me == 0) then + write(debug_unit,*) trim(name),& + &': Warning: aggregates from level ',& + & newsz + write(debug_unit,*) trim(name),& + &': to level ',& + & iszv,' coincide.' + write(debug_unit,*) trim(name),& + &': Number of levels actually used :',newsz + write(debug_unit,*) + end if + end if end if end if end if @@ -426,6 +441,31 @@ subroutine amg_z_hierarchy_bld(a,desc_a,prec,info,cpymat) & a_err=ch_err) goto 9999 endif + if (amg_get_do_remap().and.(i>=2)) then + block + type(psb_ctxt_type) :: lctxt + integer(psb_ipk_) :: lme,lnp + lctxt = prec%precv(i)%desc_ac%get_ctxt() + call psb_info(lctxt,lme,lnp) + write(0,*) ' Context on remapping ',lme,lnp + if ((lme >=0).and.(lnp>=2)) then + associate(lv=>prec%precv(i), rmp => prec%precv(i)%remap_data) + call lv%desc_ac%clone(rmp%desc_ac_pre_remap,info) + call lv%ac%clone(rmp%ac_pre_remap,info) + write(0,*) ' Doing remapping ',lnp, lnp/2 + call psb_remap(lnp/2,rmp%desc_ac_pre_remap,rmp%ac_pre_remap,& + & rmp%idest,rmp%isrc,rmp%nrsrc,rmp%naggr,lv%desc_ac,lv%ac,info) +!!$ write(0,*) me,' Out of remapping ',rmp%desc_ac_pre_remap%get_fmt(),' ',& +!!$ & lv%desc_ac%get_fmt(),sum(lv%linmap%naggr),sum(rmp%naggr) + write(0,*) 'Assignment ',size(lv%linmap%naggr),size(rmp%naggr) + lv%linmap%naggr(:) = rmp%naggr(:) + lv%linmap%p_desc_V => rmp%desc_ac_pre_remap + lv%base_a => lv%ac + lv%base_desc => lv%desc_ac + end associate + end if + end block + end if exit array_build_loop else if (do_timings) call psb_tic(idx_matasb) @@ -442,8 +482,35 @@ subroutine amg_z_hierarchy_bld(a,desc_a,prec,info,cpymat) endif if (i=2)) then + block + type(psb_ctxt_type) :: lctxt + integer(psb_ipk_) :: lme,lnp + lctxt = prec%precv(i)%desc_ac%get_ctxt() + call psb_info(lctxt,lme,lnp) + write(0,*) ' Context on remapping ',lme,lnp + if ((lme >=0).and.(lnp>=2)) then + associate(lv=>prec%precv(i), rmp => prec%precv(i)%remap_data) + call lv%desc_ac%clone(rmp%desc_ac_pre_remap,info) + call lv%ac%clone(rmp%ac_pre_remap,info) + write(0,*) ' Doing remapping ',lnp, lnp/2 + call psb_remap(lnp/2,rmp%desc_ac_pre_remap,rmp%ac_pre_remap,& + & rmp%idest,rmp%isrc,rmp%nrsrc,rmp%naggr,lv%desc_ac,lv%ac,info) +!!$ write(0,*) me,' Out of remapping ',rmp%desc_ac_pre_remap%get_fmt(),' ',& +!!$ & lv%desc_ac%get_fmt(),sum(lv%linmap%naggr),sum(rmp%naggr) + write(0,*) 'Assignment ',size(lv%linmap%naggr),size(rmp%naggr) + lv%linmap%naggr(:) = rmp%naggr(:) + lv%linmap%p_desc_V => rmp%desc_ac_pre_remap + lv%base_a => lv%ac + lv%base_desc => lv%desc_ac + end associate + end if + end block + end if + write(0,*) ' End of array_build_loop',i,iszv,info end do array_build_loop - + write(0,*) ' Done array_build_loop',iszv,newsz,info,psb_errstatus_fatal() + call psb_barrier(ctxt) if (newsz > 0) then ! ! We exited early from the build loop, need to fix @@ -487,32 +554,35 @@ subroutine amg_z_hierarchy_bld(a,desc_a,prec,info,cpymat) & prec%precv(i)%linmap%p_desc_V => prec%precv(i)%base_desc end do end if + write(0,*) ' Done reallocating precv',iszv,newsz,info,psb_errstatus_fatal() + call psb_barrier(ctxt) !write(0,*) 'Should we remap? ' - if (amg_get_do_remap().and.(np>=4)) then + if (.false.) then + if (amg_get_do_remap().and.(np>=4)) then !!$ write(0,*) 'Going for remapping ' - if (.true.) then - associate(lv=>prec%precv(iszv), rmp => prec%precv(iszv)%remap_data) - call lv%desc_ac%clone(rmp%desc_ac_pre_remap,info) - call lv%ac%clone(rmp%ac_pre_remap,info) - if (np >= 8) then - call psb_remap(np/4,rmp%desc_ac_pre_remap,rmp%ac_pre_remap,& - & rmp%idest,rmp%isrc,rmp%nrsrc,rmp%naggr,lv%desc_ac,lv%ac,info) - else - call psb_remap(np/2,rmp%desc_ac_pre_remap,rmp%ac_pre_remap,& - & rmp%idest,rmp%isrc,rmp%nrsrc,rmp%naggr,lv%desc_ac,lv%ac,info) - end if + if (.true.) then + associate(lv=>prec%precv(iszv), rmp => prec%precv(iszv)%remap_data) + call lv%desc_ac%clone(rmp%desc_ac_pre_remap,info) + call lv%ac%clone(rmp%ac_pre_remap,info) + if (np >= 8) then + call psb_remap(np/4,rmp%desc_ac_pre_remap,rmp%ac_pre_remap,& + & rmp%idest,rmp%isrc,rmp%nrsrc,rmp%naggr,lv%desc_ac,lv%ac,info) + else + call psb_remap(np/2,rmp%desc_ac_pre_remap,rmp%ac_pre_remap,& + & rmp%idest,rmp%isrc,rmp%nrsrc,rmp%naggr,lv%desc_ac,lv%ac,info) + end if !!$ write(0,*) me,' Out of remapping ',rmp%desc_ac_pre_remap%get_fmt(),' ',& !!$ & lv%desc_ac%get_fmt(),sum(lv%linmap%naggr),sum(rmp%naggr) - lv%linmap%naggr(:) = rmp%naggr(:) - lv%linmap%p_desc_V => rmp%desc_ac_pre_remap - lv%base_a => lv%ac - lv%base_desc => lv%desc_ac - end associate + lv%linmap%naggr(:) = rmp%naggr(:) + lv%linmap%p_desc_V => rmp%desc_ac_pre_remap + lv%base_a => lv%ac + lv%base_desc => lv%desc_ac + end associate + end if end if end if - if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& & a_err='Internal hierarchy build' ) diff --git a/amgprec/impl/amg_zmlprec_aply.f90 b/amgprec/impl/amg_zmlprec_aply.f90 index 53422171..8b22eab5 100644 --- a/amgprec/impl/amg_zmlprec_aply.f90 +++ b/amgprec/impl/amg_zmlprec_aply.f90 @@ -207,6 +207,7 @@ subroutine amg_zmlprec_aply_vect(alpha,p,x,beta,y,desc_data,trans,work,info) use psb_base_mod use amg_base_prec_type + use amg_prec_mod use amg_z_inner_mod, amg_protect_name => amg_zmlprec_aply_vect implicit none @@ -605,7 +606,7 @@ contains if(debug_level > 1) then write(debug_unit,*) me,' inner_mult at level ',level end if - + write(debug_unit,*) me,' inner_mult at level (1):',level,np sweeps_post = p%precv(level)%parms%sweeps_post sweeps_pre = p%precv(level)%parms%sweeps_pre pre = ((sweeps_pre>0).and.(trans=='N')).or.((sweeps_post>0).and.(trans/='N')) @@ -615,6 +616,10 @@ contains & vtx => p%precv(level)%wrk%vtx,vty => p%precv(level)%wrk%vty,& & base_a => p%precv(level)%base_a, base_desc=>p%precv(level)%base_desc,& & wv => p%precv(level)%wrk%wv) + write(0,*) 'Inner mult at level (2):',level,' :',me,np,':',& + & size(p%precv(level)%wrk%wv), allocated(p%precv(level)%wrk%wv) + if (me >=0) then + if (level < nlev) then ! ! Apply the first smoother @@ -622,7 +627,6 @@ contains ! if (pre) then - if (me >=0) then !!$ write(0,*) me,'Applying smoother pre ', level if (trans == 'N') then sweeps = p%precv(level)%parms%sweeps_pre @@ -641,24 +645,26 @@ contains & a_err='Error during PRE smoother_apply') goto 9999 end if - end if - endif + + endif ! ! Compute the residual for next level and call recursively ! if (pre) then - call psb_geaxpby(zone,vx2l,& - & zzero,vty,& - & base_desc,info) - - if (info == psb_success_) call psb_spmm(-zone,base_a,& - & vy2l,zone,vty,& - & base_desc,info,work=work,trans=trans) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during residue') - goto 9999 - end if + + call psb_geaxpby(zone,vx2l,& + & zzero,vty,& + & base_desc,info) + + if (info == psb_success_) call psb_spmm(-zone,base_a,& + & vy2l,zone,vty,& + & base_desc,info,work=work,trans=trans) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Error during residue') + goto 9999 + end if + call p%precv(level+1)%map_rstr(zone,vty,& & zzero,p%precv(level+1)%wrk%vx2l,& & info,work=work,& @@ -698,13 +704,13 @@ contains if (p%precv(level)%parms%ml_cycle == amg_wcycle_ml_) then - if (me >=0) then + call psb_geaxpby(zone,vx2l, zzero,vty,& & base_desc,info) if (info == psb_success_) call psb_spmm(-zone,base_a,& & vy2l,zone,vty,& & base_desc,info,work=work,trans=trans) - end if + if (info == psb_success_) & & call p%precv(level+1)%map_rstr(zone,vty,& & zzero,p%precv(level+1)%wrk%vx2l,info,work=work,& @@ -732,7 +738,7 @@ contains if (post) then - if (me >=0) then + call psb_geaxpby(zone,vx2l,& & zzero,vty,& & base_desc,info) @@ -759,7 +765,7 @@ contains & vty,zone,vy2l, base_desc, trans,& & sweeps,work,wv,info,init='Z') end if - end if + if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& @@ -786,6 +792,7 @@ contains & a_err='Invalid LEVEL vs NLEV') goto 9999 end if + end if end associate 9998 continue call psb_erractionrestore(err_act) @@ -1004,9 +1011,6 @@ contains end subroutine amg_z_inner_k_cycle recursive subroutine amg_zinneritkcycle(p, level, trans, work, innersolv) - use psb_base_mod - use amg_prec_mod - use amg_z_inner_mod, amg_protect_name => amg_zmlprec_aply implicit none @@ -1158,532 +1162,3 @@ contains end subroutine amg_zmlprec_aply_vect - -! -! Old routine for arrays instead of psb_X_vector. To be deleted eventually. -! -! -subroutine amg_zmlprec_aply(alpha,p,x,beta,y,desc_data,trans,work,info) - - use psb_base_mod - use amg_base_prec_type - use amg_z_inner_mod, amg_protect_name => amg_zmlprec_aply - - implicit none - - ! Arguments - type(psb_desc_type),intent(in) :: desc_data - type(amg_zprec_type), intent(inout) :: p - complex(psb_dpk_),intent(in) :: alpha,beta - complex(psb_dpk_),intent(inout) :: x(:) - complex(psb_dpk_),intent(inout) :: y(:) - character, intent(in) :: trans - complex(psb_dpk_),target :: work(:) - integer(psb_ipk_), intent(out) :: info - - ! Local variables - type(psb_ctxt_type) :: ctxt - integer(psb_ipk_) :: np, me - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: debug_level, debug_unit, nlev,nc2l,nr2l,level - character(len=20) :: name - character :: trans_ - type amg_mlwrk_type - complex(psb_dpk_), allocatable :: tx(:), ty(:), x2l(:), y2l(:) - end type amg_mlwrk_type - type(amg_mlwrk_type), allocatable, target :: mlwrk(:) - - name='amg_zmlprec_aply' - info = psb_success_ - call psb_erractionsave(err_act) - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - - ctxt = desc_data%get_context() - call psb_info(ctxt, me, np) - - if (debug_level >= psb_debug_inner_) & - & write(debug_unit,*) me,' ',trim(name),& - & ' Entry ', size(p%precv) - - trans_ = psb_toupper(trans) - - nlev = size(p%precv) - allocate(mlwrk(nlev),stat=info) - if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') - goto 9999 - end if - level = 1 - - do level = 1, nlev - call psb_geasb(mlwrk(level)%x2l,& - & p%precv(level)%base_desc,info) - call psb_geasb(mlwrk(level)%y2l,& - & p%precv(level)%base_desc,info) - call psb_geasb(mlwrk(level)%tx,& - & p%precv(level)%base_desc,info) - call psb_geasb(mlwrk(level)%ty,& - & p%precv(level)%base_desc,info) - if (psb_errstatus_fatal()) then - nc2l = p%precv(level)%base_desc%get_local_cols() - info=psb_err_alloc_request_ - call psb_errpush(info,name,i_err=(/2*nc2l,izero,izero,izero,izero/),& - & a_err='complex(psb_dpk_)') - goto 9999 - end if - end do - - mlwrk(level)%x2l(:) = x(:) - mlwrk(level)%y2l(:) = zzero - - call inner_ml_aply(level,p,mlwrk,trans_,work,info) - - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Inner prec aply') - goto 9999 - end if - - call psb_geaxpby(alpha,mlwrk(level)%y2l,beta,y,& - & p%precv(level)%base_desc,info) - - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error final update') - goto 9999 - end if - - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - -contains - - ! - ! - ! inner_ml_aply: apply AMG at a given level. - ! This routine dispatches the computation according to the type - ! specified at the current level. - ! Each of the corrections will inturn call recursively this routine. - ! - ! Assumptions: - ! On input: - ! mlprec_wkr(level)%vx2l contains the input vector (RHS) - ! mlprec_wkr(level)%vy2l contains the initial guess - ! - ! On output: - ! mlprec_wkr(level)%vy2l contains the solution - ! - ! Constraints: each of the called routines must properly handle - ! the input/output conditions for level+1 (i.e. apply - ! prolongation/restriction). - ! Note: for historical/convenience reasons the prolongator/restrictor - ! between level and level+1 are stored at level+1. - ! - ! - recursive subroutine inner_ml_aply(level,p,mlwrk,trans,work,info) - - implicit none - - ! Arguments - integer(psb_ipk_) :: level - type(amg_zprec_type), target, intent(inout) :: p - type(amg_mlwrk_type), intent(inout), target :: mlwrk(:) - character, intent(in) :: trans - complex(psb_dpk_),target :: work(:) - integer(psb_ipk_), intent(out) :: info - - type(psb_z_vect_type) :: res - type(psb_z_vect_type), pointer :: current - integer(psb_ipk_) :: sweeps_post, sweeps_pre - ! Local variables - type(psb_ctxt_type) :: ctxt - integer(psb_ipk_) :: np, me - integer(psb_ipk_) :: i, err_act - integer(psb_ipk_) :: debug_level, debug_unit - integer(psb_ipk_) :: nlev, ilev, sweeps - logical :: pre, post - character(len=20) :: name - - - - name = 'inner_ml_aply' - info = psb_success_ - call psb_erractionsave(err_act) - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - nlev = size(p%precv) - if ((level < 1) .or. (level > nlev)) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='wrong call level to inner_ml') - goto 9999 - end if - ctxt = p%precv(level)%base_desc%get_context() - call psb_info(ctxt, me, np) - - if(debug_level > 1) then - write(debug_unit,*) me,' inner_ml_aply at level ',level - end if - - select case(p%precv(level)%parms%ml_cycle) - - case(amg_no_ml_) - ! - ! No preconditioning, should not really get here - ! - call psb_errpush(psb_err_internal_error_,name,& - & a_err='amg_no_ml_ in mlprc_aply?') - goto 9999 - - case(amg_add_ml_) - - call amg_z_inner_add(p, mlwrk, level, trans, work) - - case(amg_mult_ml_, amg_vcycle_ml_, amg_wcycle_ml_) - - call amg_z_inner_mult(p, mlwrk, level, trans, work) - -! !$ case(amg_kcycle_ml_, amg_kcyclesym_ml_) -! !$ -! !$ call amg_z_inner_k_cycle(p, mlwrk, level, trans, work) - - case default - info = psb_err_from_subroutine_ai_ - call psb_errpush(info,name,a_err='invalid ml_cycle',& - & i_Err=(/p%precv(level)%parms%ml_cycle,izero,izero,izero,izero/)) - goto 9999 - - end select - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - return - - end subroutine inner_ml_aply - - - recursive subroutine amg_z_inner_add(p, mlwrk, level, trans, work) - use psb_base_mod - use amg_prec_mod - - implicit none - - !Input/Oputput variables - type(amg_zprec_type), intent(inout) :: p - - type(amg_mlwrk_type), target, intent(inout) :: mlwrk(:) - integer(psb_ipk_), intent(in) :: level - character, intent(in) :: trans - complex(psb_dpk_),target :: work(:) - type(psb_z_vect_type) :: res - type(psb_z_vect_type), pointer :: current - integer(psb_ipk_) :: sweeps_post, sweeps_pre - ! Local variables - type(psb_ctxt_type) :: ctxt - integer(psb_ipk_) :: np, me - integer(psb_ipk_) :: i, err_act - integer(psb_ipk_) :: debug_level, debug_unit - integer(psb_ipk_) :: nlev, ilev, sweeps - logical :: pre, post - character(len=20) :: name - - - - name = 'inner_inner_add' - info = psb_success_ - call psb_erractionsave(err_act) - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - nlev = size(p%precv) - if ((level < 1) .or. (level > nlev)) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='wrong call level to inner_add') - goto 9999 - end if - ctxt = p%precv(level)%base_desc%get_context() - call psb_info(ctxt, me, np) - - if(debug_level > 1) then - write(debug_unit,*) me,' inner_add at level ',level - end if - - if ((level<1).or.(level>nlev)) then - info = psb_err_internal_error_ - call psb_errpush(info,name,& - & a_err='Invalid LEVEL>NLEV') - goto 9999 - end if - - sweeps = p%precv(level)%parms%sweeps_pre - call p%precv(level)%sm%apply(zone,& - & mlwrk(level)%x2l,zzero,mlwrk(level)%y2l,& - & p%precv(level)%base_desc, trans,& - & sweeps,work,info) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during ADD smoother_apply') - goto 9999 - end if - - if (level < nlev) then - ! Apply the restriction - call p%precv(level+1)%map_rstr(zone,mlwrk(level)%x2l,& - & zzero,mlwrk(level+1)%x2l,& - & info,work=work) - mlwrk(level+1)%y2l(:) = zzero - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during restriction') - goto 9999 - end if - - call inner_ml_aply(level+1,p,mlwrk,trans,work,info) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error in recursive call') - goto 9999 - end if - - ! - ! Apply the prolongator and add correction. - ! - call p%precv(level+1)%map_prol(zone,& - & mlwrk(level+1)%y2l,zone,mlwrk(level)%y2l,& - & info,work=work) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during prolongation') - goto 9999 - end if - - - end if - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - return - - end subroutine amg_z_inner_add - - recursive subroutine amg_z_inner_mult(p, mlwrk, level, trans, work) - use psb_base_mod - use amg_prec_mod - - implicit none - - !Input/Oputput variables - type(amg_zprec_type), intent(inout) :: p - - type(amg_mlwrk_type), target, intent(inout) :: mlwrk(:) - integer(psb_ipk_), intent(in) :: level - character, intent(in) :: trans - complex(psb_dpk_),target :: work(:) - type(psb_z_vect_type) :: res - type(psb_z_vect_type), pointer :: current - integer(psb_ipk_) :: sweeps_post, sweeps_pre - ! Local variables - type(psb_ctxt_type) :: ctxt - integer(psb_ipk_) :: np, me - integer(psb_ipk_) :: i, err_act - integer(psb_ipk_) :: debug_level, debug_unit - integer(psb_ipk_) :: nlev, ilev, sweeps - logical :: pre, post - character(len=20) :: name - - - - name = 'inner_inner_mult' - info = psb_success_ - call psb_erractionsave(err_act) - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - nlev = size(p%precv) - if ((level < 1) .or. (level > nlev)) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='wrong call level to inner_mult') - goto 9999 - end if - ctxt = p%precv(level)%base_desc%get_context() - call psb_info(ctxt, me, np) - - if(debug_level > 1) then - write(debug_unit,*) me,' inner_mult at level ',level - end if - - if ((level < nlev).or.(nlev == 1)) then - sweeps_post = p%precv(level)%parms%sweeps_post - sweeps_pre = p%precv(level)%parms%sweeps_pre - else - sweeps_post = p%precv(level-1)%parms%sweeps_post - sweeps_pre = p%precv(level-1)%parms%sweeps_pre - endif - - pre = ((sweeps_pre>0).and.(trans=='N')).or.((sweeps_post>0).and.(trans/='N')) - post = ((sweeps_post>0).and.(trans=='N')).or.((sweeps_pre>0).and.(trans/='N')) - - - if (level < nlev) then - - ! - ! Apply the first smoother - ! - - if (pre) then - if (trans == 'N') then - sweeps = p%precv(level)%parms%sweeps_pre - if (info == psb_success_) call p%precv(level)%sm%apply(zone,& - & mlwrk(level)%x2l,zzero,mlwrk(level)%y2l,& - & p%precv(level)%base_desc, trans,& - & sweeps,work,info,init='Y') - else - sweeps = p%precv(level)%parms%sweeps_post - if (info == psb_success_) call p%precv(level)%sm2%apply(zone,& - & mlwrk(level)%x2l,zzero,mlwrk(level)%y2l,& - & p%precv(level)%base_desc, trans,& - & sweeps,work,info,init='Y') - end if - - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during PRE smoother_apply') - goto 9999 - end if - endif - - ! - ! Compute the residual and call recursively - ! - if (pre) then - call psb_geaxpby(zone,mlwrk(level)%x2l,& - & zzero,mlwrk(level)%ty,& - & p%precv(level)%base_desc,info) - - if (info == psb_success_) call psb_spmm(-zone,p%precv(level)%base_a,& - & mlwrk(level)%y2l,zone,mlwrk(level)%ty,& - & p%precv(level)%base_desc,info,work=work,trans=trans) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during residue') - goto 9999 - end if - call p%precv(level+1)%map_rstr(zone,mlwrk(level)%ty,& - & zzero,mlwrk(level+1)%x2l,info,work=work) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during restriction') - goto 9999 - end if - else - ! Shortcut: just transfer x2l. - call p%precv(level+1)%map_rstr(zone,mlwrk(level)%x2l,& - & zzero,mlwrk(level+1)%x2l,info,work=work) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during restriction') - goto 9999 - end if - endif - ! First guess is zero - mlwrk(level+1)%y2l(:) = zzero - - - call inner_ml_aply(level+1,p,mlwrk,trans,work,info) - - if (p%precv(level)%parms%ml_cycle == amg_wcycle_ml_) then - ! On second call will use output y2l as initial guess - if (info == psb_success_) call inner_ml_aply(level+1,p,mlwrk,trans,work,info) - endif - - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error in recursive call') - goto 9999 - end if - - - ! - ! Apply the prolongator - ! - call p%precv(level+1)%map_prol(zone,mlwrk(level+1)%y2l,& - & zone,mlwrk(level)%y2l,info,work=work) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during prolongation') - goto 9999 - end if - - ! - ! Compute the residual - ! - if (post) then - call psb_geaxpby(zone,mlwrk(level)%x2l,& - & zzero,mlwrk(level)%tx,& - & p%precv(level)%base_desc,info) - call psb_spmm(-zone,p%precv(level)%base_a,mlwrk(level)%y2l,& - & zone,mlwrk(level)%tx,p%precv(level)%base_desc,info,& - & work=work,trans=trans) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during residue') - goto 9999 - end if - ! - ! Apply the second smoother - ! - if (trans == 'N') then - sweeps = p%precv(level)%parms%sweeps_post - if (info == psb_success_) call p%precv(level)%sm2%apply(zone,& - & mlwrk(level)%tx,zone,mlwrk(level)%y2l,& - & p%precv(level)%base_desc, trans,& - & sweeps,work,info,init='Z') - else - sweeps = p%precv(level)%parms%sweeps_pre - if (info == psb_success_) call p%precv(level)%sm%apply(zone,& - & mlwrk(level)%tx,zone,mlwrk(level)%y2l,& - & p%precv(level)%base_desc, trans,& - & sweeps,work,info,init='Z') - end if - - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during POST smoother_apply') - goto 9999 - end if - - endif - - else if (level == nlev) then - - sweeps = p%precv(level)%parms%sweeps_pre - if (info == psb_success_) call p%precv(level)%sm%apply(zone,& - & mlwrk(level)%x2l,zzero,mlwrk(level)%y2l,& - & p%precv(level)%base_desc, trans,& - & sweeps,work,info) - - else - - info = psb_err_internal_error_ - call psb_errpush(info,name,& - & a_err='Invalid LEVEL vs NLEV') - goto 9999 - end if - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - return - - end subroutine amg_z_inner_mult - - -end subroutine amg_zmlprec_aply diff --git a/amgprec/impl/amg_zmlprec_aply_a.f90 b/amgprec/impl/amg_zmlprec_aply_a.f90 new file mode 100644 index 00000000..d3676a97 --- /dev/null +++ b/amgprec/impl/amg_zmlprec_aply_a.f90 @@ -0,0 +1,733 @@ +! +! +! AMG4PSBLAS version 1.0 +! Algebraic Multigrid Package +! based on PSBLAS (Parallel Sparse BLAS version 3.7) +! +! (C) Copyright 2021 +! +! Salvatore Filippone +! Pasqua D'Ambra +! Fabio Durastante +! +! 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 AMG4PSBLAS group or the names of its contributors may +! not be used to endorse or promote products derived from this +! software without specific prior 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 AMG4PSBLAS 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: amg_zmlprec_aply.f90 +! +! Subroutine: amg_zmlprec_aply +! Version: real +! +! Current version of this file contributed by: +! Ambra Abdullahi Hassan +! +! +! This routine computes +! +! Y = beta*Y + alpha*op(ML^(-1))*X, +! where +! - ML is a multilevel preconditioner associated with +! a certain matrix A and stored in p, +! - op(ML^(-1)) is ML^(-1) or its transpose, according to the value of trans, +! - X and Y are vectors, +! - alpha and beta are scalars. +! +! The following multilevel strategies can be applied: +! +! - Additive multilevel Schwarz, +! - classical V-cycle, +! - classical W-cycle, +! - K-cycle both for symmetric and nonsymmetric matrices, where 2 iterations +! of FCG(1) or GCR, respectively, are applied at each level +! except the coarsest. +! +! For each level we have as many submatrices as processes (except for the coarsest +! level where we might have a replicated index space) and each process takes care +! of one submatrix. +! +! A multilevel preconditioner is regarded as an array of 'one-level' data structures, +! each containing the part of the preconditioner associated to a certain level +! (for more details see the description of amg_Tonelev_type in amg_prec_type.f90). +! For each level lev, there is a smoother stored in +! p%precv(lev)%sm +! which in turn contains a solver +! p$precv(lev)%sm%sv +! Typically the solver acts only locally, and the smoother applies any required +! parallel communication/action. +! Each level has a matrix A(lev), obtained by 'tranferring' the original +! matrix A (i.e. the matrix to be preconditioned) to the level lev, through smoothed +! aggregation. +! +! The levels are numbered in increasing order starting from the finest one, i.e. +! level 1 is the finest level and A(1) is the matrix A. +! +! This routine is formulated in a recursive way, so it is quite compact. +! +! The V-cycle can be described as follows, where +! P(lev) denotes the smoothed prolongator from level lev to level +! lev-1, while R(lev) denotes the corresponding restriction operator +! (normally its transpose) from level lev-1 to level lev. +! M(lev) is the smoother at the current level. +! +! +! 1. Transfer the outer vector Xest to u(1) (inner X at level 1) +! +! 2. Invoke V-cycle(1,M,P,R,A,b,u) +! +! procedure V-cycle(lev,M,P,R,A,b,u) +! +! if (lev < nlev) then +! +! u(lev) = u(lev) + M(lev)*(b(lev)-A(lev)*u(lev)) +! +! b(lev+1) = R(lev+1)*(b(lev)-A(lev)*u(lev)) +! +! u(lev+1) = V-cycle(lev+1,M,P,R,A,b,u) +! +! u(lev) = u(lev) + P(lev+1) * u(lev+1) +! +! u(lev) = u(lev) + M(lev)*(b(lev)-A(lev)*u(lev)) +! +! else +! +! solve A(lev)*u(lev) = b(lev) +! +! end if +! +! return u(lev) +! end +! +! 3. Transfer u(1) to the external: +! Yext = beta*Yext + alpha*u(1) +! +! +! In the implementation, the recursive procedure is inner_ml_aply, which +! in turn uses amg_inner_add (for additive multilevel), +! amg_inner_mult (for V-cycle and W-cycle), and +! amg_inner_k_cycle (for symmetric and non-symmetric K-cycle). +! +! For a detailed description of the algorithms, see: +! +! - B.F. Smith, P.E. Bjorstad, W.D. Gropp, +! Domain decomposition: parallel multilevel methods for elliptic partial +! differential equations, Cambridge University Press, 1996. +! +! - W. L. Briggs, V. E. Henson, S. F. McCormick, +! A Multigrid Tutorial, Second Edition +! SIAM, 2000. +! +! - K. Stuben, +! An Introduction to Algebraic Multigrid, +! in A. Schuller, U. Trottenberg, C. Oosterlee, Multigrid, Academic Press, 2001. +! +! - Y. Notay, P. S. Vassilevski, +! Recursive Krylov-based multigrid cycles +! Numerical Linear Algebra with Applications, 15 (5), 2008, 473--487. +! +! +! Arguments: +! alpha - complex(psb_dpk_), input. +! The scalar alpha. +! p - type(amg_zprec_type), input. +! The multilevel preconditioner data structure containing the +! local part of the preconditioner to be applied. +! Note that nlev = size(p%precv) = number of levels. +! p%precv(lev)%sm - type(psb_zbaseprec_type) +! The pre-'smoother' for the current level +! p%precv(lev)%sm2 - type(psb_zbaseprec_type) +! The post-'smoother' for the current level +! may be the same or different from %sm +! p%precv(lev)%ac - type(psb_zspmat_type) +! The local part of the matrix A(lev). +! p%precv(lev)%parms - type(psb_dml_parms) +! Parameters controllin the multilevel prec. +! p%precv(lev)%desc_ac - type(psb_desc_type). +! The communication descriptor associated to the sparse +! matrix A(lev) +! p%precv(lev)%map - type(psb_inter_desc_type) +! Stores the linear operators mapping level (lev-1) +! to (lev) and vice versa. These are the restriction +! and prolongation operators described in the sequel. +! p%precv(lev)%base_a - type(psb_zspmat_type), pointer. +! Pointer (really a pointer!) to the base matrix of +! the current level, i.e. the local part of A(lev); +! so we have a unified treatment of residuals. We +! need this to avoid passing explicitly the matrix +! A(lev) to the routine which applies the +! preconditioner. +! p%precv(lev)%base_desc - type(psb_desc_type), pointer. +! Pointer to the communication descriptor associated +! to the sparse matrix pointed by base_a. +! +! x - complex(psb_dpk_), dimension(:), input. +! The local part of the vector X. +! beta - complex(psb_dpk_), input. +! The scalar beta. +! y - complex(psb_dpk_), dimension(:), input/output. +! The local part of the vector Y. +! desc_data - type(psb_desc_type), input. +! The communication descriptor associated to the matrix to be +! preconditioned. +! trans - character, optional. +! If trans='N','n' then op(M^(-1)) = M^(-1); +! if trans='T','t' then op(M^(-1)) = M^(-T) (transpose of M^(-1)). +! work - complex(psb_dpk_), dimension (:), optional, target. +! Workspace. Its size must be at least 4*desc_data%get_local_cols(). +! info - integer, output. +! Error code. +! +! Note that when the LU factorization of the matrix A(lev) is computed instead of +! the ILU one, by using UMFPACK or SuperLU or MUMPS, the corresponding +! L and U factors are stored in data structures handled +! by the third party software. +! + +! +! Old routine for arrays instead of psb_X_vector. To be deleted eventually. +! +! +subroutine amg_zmlprec_aply_a(alpha,p,x,beta,y,desc_data,trans,work,info) + + use psb_base_mod + use amg_base_prec_type + use amg_z_inner_mod, amg_protect_name => amg_zmlprec_aply_a + + implicit none + + ! Arguments + type(psb_desc_type),intent(in) :: desc_data + type(amg_zprec_type), intent(inout) :: p + complex(psb_dpk_),intent(in) :: alpha,beta + complex(psb_dpk_),intent(inout) :: x(:) + complex(psb_dpk_),intent(inout) :: y(:) + character, intent(in) :: trans + complex(psb_dpk_),target :: work(:) + integer(psb_ipk_), intent(out) :: info + + ! Local variables + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me + integer(psb_ipk_) :: err_act + integer(psb_ipk_) :: debug_level, debug_unit, nlev,nc2l,nr2l,level + character(len=20) :: name + character :: trans_ + type amg_mlwrk_type + complex(psb_dpk_), allocatable :: tx(:), ty(:), x2l(:), y2l(:) + end type amg_mlwrk_type + type(amg_mlwrk_type), allocatable, target :: mlwrk(:) + + name='amg_zmlprec_aply' + info = psb_success_ + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + ctxt = desc_data%get_context() + call psb_info(ctxt, me, np) + + if (debug_level >= psb_debug_inner_) & + & write(debug_unit,*) me,' ',trim(name),& + & ' Entry ', size(p%precv) + + trans_ = psb_toupper(trans) + + nlev = size(p%precv) + allocate(mlwrk(nlev),stat=info) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') + goto 9999 + end if + level = 1 + + do level = 1, nlev + call psb_geasb(mlwrk(level)%x2l,& + & p%precv(level)%base_desc,info) + call psb_geasb(mlwrk(level)%y2l,& + & p%precv(level)%base_desc,info) + call psb_geasb(mlwrk(level)%tx,& + & p%precv(level)%base_desc,info) + call psb_geasb(mlwrk(level)%ty,& + & p%precv(level)%base_desc,info) + if (psb_errstatus_fatal()) then + nc2l = p%precv(level)%base_desc%get_local_cols() + info=psb_err_alloc_request_ + call psb_errpush(info,name,i_err=(/2*nc2l,izero,izero,izero,izero/),& + & a_err='complex(psb_dpk_)') + goto 9999 + end if + end do + + mlwrk(level)%x2l(:) = x(:) + mlwrk(level)%y2l(:) = zzero + + call inner_ml_aply(level,p,mlwrk,trans_,work,info) + + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Inner prec aply') + goto 9999 + end if + + call psb_geaxpby(alpha,mlwrk(level)%y2l,beta,y,& + & p%precv(level)%base_desc,info) + + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Error final update') + goto 9999 + end if + + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +contains + + ! + ! + ! inner_ml_aply: apply AMG at a given level. + ! This routine dispatches the computation according to the type + ! specified at the current level. + ! Each of the corrections will inturn call recursively this routine. + ! + ! Assumptions: + ! On input: + ! mlprec_wkr(level)%vx2l contains the input vector (RHS) + ! mlprec_wkr(level)%vy2l contains the initial guess + ! + ! On output: + ! mlprec_wkr(level)%vy2l contains the solution + ! + ! Constraints: each of the called routines must properly handle + ! the input/output conditions for level+1 (i.e. apply + ! prolongation/restriction). + ! Note: for historical/convenience reasons the prolongator/restrictor + ! between level and level+1 are stored at level+1. + ! + ! + recursive subroutine inner_ml_aply(level,p,mlwrk,trans,work,info) + + implicit none + + ! Arguments + integer(psb_ipk_) :: level + type(amg_zprec_type), target, intent(inout) :: p + type(amg_mlwrk_type), intent(inout), target :: mlwrk(:) + character, intent(in) :: trans + complex(psb_dpk_),target :: work(:) + integer(psb_ipk_), intent(out) :: info + + type(psb_z_vect_type) :: res + type(psb_z_vect_type), pointer :: current + integer(psb_ipk_) :: sweeps_post, sweeps_pre + ! Local variables + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me + integer(psb_ipk_) :: i, err_act + integer(psb_ipk_) :: debug_level, debug_unit + integer(psb_ipk_) :: nlev, ilev, sweeps + logical :: pre, post + character(len=20) :: name + + + + name = 'inner_ml_aply' + info = psb_success_ + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + nlev = size(p%precv) + if ((level < 1) .or. (level > nlev)) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='wrong call level to inner_ml') + goto 9999 + end if + ctxt = p%precv(level)%base_desc%get_context() + call psb_info(ctxt, me, np) + + if(debug_level > 1) then + write(debug_unit,*) me,' inner_ml_aply at level ',level + end if + + select case(p%precv(level)%parms%ml_cycle) + + case(amg_no_ml_) + ! + ! No preconditioning, should not really get here + ! + call psb_errpush(psb_err_internal_error_,name,& + & a_err='amg_no_ml_ in mlprc_aply?') + goto 9999 + + case(amg_add_ml_) + + call amg_z_inner_add(p, mlwrk, level, trans, work) + + case(amg_mult_ml_, amg_vcycle_ml_, amg_wcycle_ml_) + + call amg_z_inner_mult(p, mlwrk, level, trans, work) + +! !$ case(amg_kcycle_ml_, amg_kcyclesym_ml_) +! !$ +! !$ call amg_z_inner_k_cycle(p, mlwrk, level, trans, work) + + case default + info = psb_err_from_subroutine_ai_ + call psb_errpush(info,name,a_err='invalid ml_cycle',& + & i_Err=(/p%precv(level)%parms%ml_cycle,izero,izero,izero,izero/)) + goto 9999 + + end select + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + return + + end subroutine inner_ml_aply + + recursive subroutine amg_z_inner_add(p, mlwrk, level, trans, work) + use psb_base_mod + use amg_prec_mod + + implicit none + + !Input/Oputput variables + type(amg_zprec_type), intent(inout) :: p + + type(amg_mlwrk_type), target, intent(inout) :: mlwrk(:) + integer(psb_ipk_), intent(in) :: level + character, intent(in) :: trans + complex(psb_dpk_),target :: work(:) + type(psb_z_vect_type) :: res + type(psb_z_vect_type), pointer :: current + integer(psb_ipk_) :: sweeps_post, sweeps_pre + ! Local variables + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me + integer(psb_ipk_) :: i, err_act + integer(psb_ipk_) :: debug_level, debug_unit + integer(psb_ipk_) :: nlev, ilev, sweeps + logical :: pre, post + character(len=20) :: name + + + + name = 'inner_inner_add' + info = psb_success_ + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + nlev = size(p%precv) + if ((level < 1) .or. (level > nlev)) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='wrong call level to inner_add') + goto 9999 + end if + ctxt = p%precv(level)%base_desc%get_context() + call psb_info(ctxt, me, np) + + if(debug_level > 1) then + write(debug_unit,*) me,' inner_add at level ',level + end if + + if ((level<1).or.(level>nlev)) then + info = psb_err_internal_error_ + call psb_errpush(info,name,& + & a_err='Invalid LEVEL>NLEV') + goto 9999 + end if + + sweeps = p%precv(level)%parms%sweeps_pre + call p%precv(level)%sm%apply(zone,& + & mlwrk(level)%x2l,zzero,mlwrk(level)%y2l,& + & p%precv(level)%base_desc, trans,& + & sweeps,work,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Error during ADD smoother_apply') + goto 9999 + end if + + if (level < nlev) then + ! Apply the restriction + call p%precv(level+1)%map_rstr(zone,mlwrk(level)%x2l,& + & zzero,mlwrk(level+1)%x2l,& + & info,work=work) + mlwrk(level+1)%y2l(:) = zzero + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Error during restriction') + goto 9999 + end if + + call inner_ml_aply(level+1,p,mlwrk,trans,work,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Error in recursive call') + goto 9999 + end if + + ! + ! Apply the prolongator and add correction. + ! + call p%precv(level+1)%map_prol(zone,& + & mlwrk(level+1)%y2l,zone,mlwrk(level)%y2l,& + & info,work=work) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Error during prolongation') + goto 9999 + end if + + + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + return + + end subroutine amg_z_inner_add + + recursive subroutine amg_z_inner_mult(p, mlwrk, level, trans, work) + use psb_base_mod + use amg_prec_mod + + implicit none + + !Input/Oputput variables + type(amg_zprec_type), intent(inout) :: p + + type(amg_mlwrk_type), target, intent(inout) :: mlwrk(:) + integer(psb_ipk_), intent(in) :: level + character, intent(in) :: trans + complex(psb_dpk_),target :: work(:) + type(psb_z_vect_type) :: res + type(psb_z_vect_type), pointer :: current + integer(psb_ipk_) :: sweeps_post, sweeps_pre + ! Local variables + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me + integer(psb_ipk_) :: i, err_act + integer(psb_ipk_) :: debug_level, debug_unit + integer(psb_ipk_) :: nlev, ilev, sweeps + logical :: pre, post + character(len=20) :: name + + + + name = 'inner_inner_mult' + info = psb_success_ + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + nlev = size(p%precv) + if ((level < 1) .or. (level > nlev)) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='wrong call level to inner_mult') + goto 9999 + end if + ctxt = p%precv(level)%base_desc%get_context() + call psb_info(ctxt, me, np) + + if(debug_level > 1) then + write(debug_unit,*) me,' inner_mult at level ',level + end if + + if ((level < nlev).or.(nlev == 1)) then + sweeps_post = p%precv(level)%parms%sweeps_post + sweeps_pre = p%precv(level)%parms%sweeps_pre + else + sweeps_post = p%precv(level-1)%parms%sweeps_post + sweeps_pre = p%precv(level-1)%parms%sweeps_pre + endif + + pre = ((sweeps_pre>0).and.(trans=='N')).or.((sweeps_post>0).and.(trans/='N')) + post = ((sweeps_post>0).and.(trans=='N')).or.((sweeps_pre>0).and.(trans/='N')) + + + if (level < nlev) then + + ! + ! Apply the first smoother + ! + + if (pre) then + if (trans == 'N') then + sweeps = p%precv(level)%parms%sweeps_pre + if (info == psb_success_) call p%precv(level)%sm%apply(zone,& + & mlwrk(level)%x2l,zzero,mlwrk(level)%y2l,& + & p%precv(level)%base_desc, trans,& + & sweeps,work,info,init='Y') + else + sweeps = p%precv(level)%parms%sweeps_post + if (info == psb_success_) call p%precv(level)%sm2%apply(zone,& + & mlwrk(level)%x2l,zzero,mlwrk(level)%y2l,& + & p%precv(level)%base_desc, trans,& + & sweeps,work,info,init='Y') + end if + + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Error during PRE smoother_apply') + goto 9999 + end if + endif + + ! + ! Compute the residual and call recursively + ! + if (pre) then + call psb_geaxpby(zone,mlwrk(level)%x2l,& + & zzero,mlwrk(level)%ty,& + & p%precv(level)%base_desc,info) + + if (info == psb_success_) call psb_spmm(-zone,p%precv(level)%base_a,& + & mlwrk(level)%y2l,zone,mlwrk(level)%ty,& + & p%precv(level)%base_desc,info,work=work,trans=trans) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Error during residue') + goto 9999 + end if + call p%precv(level+1)%map_rstr(zone,mlwrk(level)%ty,& + & zzero,mlwrk(level+1)%x2l,info,work=work) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Error during restriction') + goto 9999 + end if + else + ! Shortcut: just transfer x2l. + call p%precv(level+1)%map_rstr(zone,mlwrk(level)%x2l,& + & zzero,mlwrk(level+1)%x2l,info,work=work) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Error during restriction') + goto 9999 + end if + endif + ! First guess is zero + mlwrk(level+1)%y2l(:) = zzero + + + call inner_ml_aply(level+1,p,mlwrk,trans,work,info) + + if (p%precv(level)%parms%ml_cycle == amg_wcycle_ml_) then + ! On second call will use output y2l as initial guess + if (info == psb_success_) call inner_ml_aply(level+1,p,mlwrk,trans,work,info) + endif + + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Error in recursive call') + goto 9999 + end if + + + ! + ! Apply the prolongator + ! + call p%precv(level+1)%map_prol(zone,mlwrk(level+1)%y2l,& + & zone,mlwrk(level)%y2l,info,work=work) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Error during prolongation') + goto 9999 + end if + + ! + ! Compute the residual + ! + if (post) then + call psb_geaxpby(zone,mlwrk(level)%x2l,& + & zzero,mlwrk(level)%tx,& + & p%precv(level)%base_desc,info) + call psb_spmm(-zone,p%precv(level)%base_a,mlwrk(level)%y2l,& + & zone,mlwrk(level)%tx,p%precv(level)%base_desc,info,& + & work=work,trans=trans) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Error during residue') + goto 9999 + end if + ! + ! Apply the second smoother + ! + if (trans == 'N') then + sweeps = p%precv(level)%parms%sweeps_post + if (info == psb_success_) call p%precv(level)%sm2%apply(zone,& + & mlwrk(level)%tx,zone,mlwrk(level)%y2l,& + & p%precv(level)%base_desc, trans,& + & sweeps,work,info,init='Z') + else + sweeps = p%precv(level)%parms%sweeps_pre + if (info == psb_success_) call p%precv(level)%sm%apply(zone,& + & mlwrk(level)%tx,zone,mlwrk(level)%y2l,& + & p%precv(level)%base_desc, trans,& + & sweeps,work,info,init='Z') + end if + + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Error during POST smoother_apply') + goto 9999 + end if + + endif + + else if (level == nlev) then + + sweeps = p%precv(level)%parms%sweeps_pre + if (info == psb_success_) call p%precv(level)%sm%apply(zone,& + & mlwrk(level)%x2l,zzero,mlwrk(level)%y2l,& + & p%precv(level)%base_desc, trans,& + & sweeps,work,info) + + else + + info = psb_err_internal_error_ + call psb_errpush(info,name,& + & a_err='Invalid LEVEL vs NLEV') + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + return + + end subroutine amg_z_inner_mult + + +end subroutine amg_zmlprec_aply_a diff --git a/amgprec/impl/level/amg_c_base_onelev_descr.f90 b/amgprec/impl/level/amg_c_base_onelev_descr.f90 index a87148da..957944b4 100644 --- a/amgprec/impl/level/amg_c_base_onelev_descr.f90 +++ b/amgprec/impl/level/amg_c_base_onelev_descr.f90 @@ -62,6 +62,8 @@ subroutine amg_c_base_onelev_descr(lv,il,nl,ilmin,info,iout,verbosity,prefix) integer(psb_ipk_) :: iout_, verbosity_ logical :: coarse character(1024) :: prefix_ + type(psb_ctxt_type) :: pctxt + integer(psb_ipk_) :: pme, pnp call psb_erractionsave(err_act) @@ -81,12 +83,16 @@ subroutine amg_c_base_onelev_descr(lv,il,nl,ilmin,info,iout,verbosity,prefix) verbosity_ = 0 end if if (verbosity_ < 0) goto 9998 - if (present(prefix)) then - prefix_ = prefix - else - prefix_ = "" - end if - + if (present(prefix)) then + prefix_ = prefix + else + prefix_ = "" + end if + + pctxt = lv%desc_ac%get_ctxt() + call psb_info(pctxt,pme,pnp) + write(iout_,*) trim(prefix_) + write(iout_,*) 'At level :',il,' we have ',pnp,' processes' write(iout_,*) trim(prefix_) if (il == ilmin) then call lv%parms%mlcycledsc(iout_,info) diff --git a/amgprec/impl/level/amg_c_base_onelev_map_rstr.F90 b/amgprec/impl/level/amg_c_base_onelev_map_rstr.F90 index eedbe26d..ad3b81e7 100644 --- a/amgprec/impl/level/amg_c_base_onelev_map_rstr.F90 +++ b/amgprec/impl/level/amg_c_base_onelev_map_rstr.F90 @@ -55,7 +55,7 @@ subroutine amg_c_base_onelev_map_rstr_v(lv,alpha,vect_u,beta,vect_v,info,& ! !!$ write(0,*) 'Remap handling not implemented yet ' block - type(psb_ctxt_type) :: ctxt, nctxt + type(psb_ctxt_type) :: ctxt, rctxt integer(psb_mpk_) :: i,j,ip, idest, nsrc, nrl, kp integer(psb_mpk_) :: me, np, rme, rnp complex(psb_spk_), allocatable :: rsnd(:), rrcv(:) @@ -63,8 +63,8 @@ subroutine amg_c_base_onelev_map_rstr_v(lv,alpha,vect_u,beta,vect_v,info,& ctxt = lv%remap_data%desc_ac_pre_remap%get_ctxt() call psb_info(ctxt,me,np) - nctxt = lv%desc_ac%get_ctxt() - call psb_info(nctxt,rme,rnp) + rctxt = lv%desc_ac%get_ctxt() + call psb_info(rctxt,rme,rnp) !!$ write(0,*) 'New context ',rme,rnp idest = lv%remap_data%idest associate(isrc => lv%remap_data%isrc, nrsrc => lv%remap_data%nrsrc) @@ -74,12 +74,15 @@ subroutine amg_c_base_onelev_map_rstr_v(lv,alpha,vect_u,beta,vect_v,info,& nrl = lv%remap_data%desc_ac_pre_remap%get_local_rows() call psb_geall(tv,lv%remap_data%desc_ac_pre_remap,info) call psb_geasb(tv,lv%remap_data%desc_ac_pre_remap,info,mold=vect_u%v) -!!$ write(0,*) me,' Size of TV ',tv%get_nrows() + write(0,*) me,' map_rstr calling U2V: ',me,np,rme,rnp,tv%get_nrows() + flush(0) + call psb_barrier(ctxt) call lv%linmap%map_U2V(alpha,vect_u,beta,tv,info,& & work=work,vtx=vtx,vty=vty) call tv%sync() !rsnd = tv%get_vect() - !call psb_snd(ctxt,rsnd(1:nrl),idest) + !call psb_snd(ctxt,rsnd(1:nrl),idest) + write(0,*) me,' map_rstr sending ',me,idest call psb_snd(ctxt,tv%v%v(1:nrl),idest) if (rme >=0) then allocate(rrcv(sum(nrsrc))) @@ -88,7 +91,7 @@ subroutine amg_c_base_onelev_map_rstr_v(lv,alpha,vect_u,beta,vect_v,info,& do i = 1,size(isrc) ip = isrc(i) nrl = nrsrc(i) -!!$ write(0,*) me,' Receiving from ',ip,nrl,kp+1,kp+nrl,size(rrcv) + write(0,*) me,' map_rstr receiving',rme,i,ip call psb_rcv(ctxt,rrcv(kp+1:kp+nrl),ip) kp = kp + nrl end do diff --git a/amgprec/impl/level/amg_d_base_onelev_descr.f90 b/amgprec/impl/level/amg_d_base_onelev_descr.f90 index e3533199..000c5b59 100644 --- a/amgprec/impl/level/amg_d_base_onelev_descr.f90 +++ b/amgprec/impl/level/amg_d_base_onelev_descr.f90 @@ -62,6 +62,8 @@ subroutine amg_d_base_onelev_descr(lv,il,nl,ilmin,info,iout,verbosity,prefix) integer(psb_ipk_) :: iout_, verbosity_ logical :: coarse character(1024) :: prefix_ + type(psb_ctxt_type) :: pctxt + integer(psb_ipk_) :: pme, pnp call psb_erractionsave(err_act) @@ -81,12 +83,16 @@ subroutine amg_d_base_onelev_descr(lv,il,nl,ilmin,info,iout,verbosity,prefix) verbosity_ = 0 end if if (verbosity_ < 0) goto 9998 - if (present(prefix)) then - prefix_ = prefix - else - prefix_ = "" - end if - + if (present(prefix)) then + prefix_ = prefix + else + prefix_ = "" + end if + + pctxt = lv%desc_ac%get_ctxt() + call psb_info(pctxt,pme,pnp) + write(iout_,*) trim(prefix_) + write(iout_,*) 'At level :',il,' we have ',pnp,' processes' write(iout_,*) trim(prefix_) if (il == ilmin) then call lv%parms%mlcycledsc(iout_,info) diff --git a/amgprec/impl/level/amg_d_base_onelev_map_rstr.F90 b/amgprec/impl/level/amg_d_base_onelev_map_rstr.F90 index 25104694..ee17de60 100644 --- a/amgprec/impl/level/amg_d_base_onelev_map_rstr.F90 +++ b/amgprec/impl/level/amg_d_base_onelev_map_rstr.F90 @@ -55,7 +55,7 @@ subroutine amg_d_base_onelev_map_rstr_v(lv,alpha,vect_u,beta,vect_v,info,& ! !!$ write(0,*) 'Remap handling not implemented yet ' block - type(psb_ctxt_type) :: ctxt, nctxt + type(psb_ctxt_type) :: ctxt, rctxt integer(psb_mpk_) :: i,j,ip, idest, nsrc, nrl, kp integer(psb_mpk_) :: me, np, rme, rnp real(psb_dpk_), allocatable :: rsnd(:), rrcv(:) @@ -63,8 +63,8 @@ subroutine amg_d_base_onelev_map_rstr_v(lv,alpha,vect_u,beta,vect_v,info,& ctxt = lv%remap_data%desc_ac_pre_remap%get_ctxt() call psb_info(ctxt,me,np) - nctxt = lv%desc_ac%get_ctxt() - call psb_info(nctxt,rme,rnp) + rctxt = lv%desc_ac%get_ctxt() + call psb_info(rctxt,rme,rnp) !!$ write(0,*) 'New context ',rme,rnp idest = lv%remap_data%idest associate(isrc => lv%remap_data%isrc, nrsrc => lv%remap_data%nrsrc) @@ -74,12 +74,15 @@ subroutine amg_d_base_onelev_map_rstr_v(lv,alpha,vect_u,beta,vect_v,info,& nrl = lv%remap_data%desc_ac_pre_remap%get_local_rows() call psb_geall(tv,lv%remap_data%desc_ac_pre_remap,info) call psb_geasb(tv,lv%remap_data%desc_ac_pre_remap,info,mold=vect_u%v) -!!$ write(0,*) me,' Size of TV ',tv%get_nrows() + write(0,*) me,' map_rstr calling U2V: ',me,np,rme,rnp,tv%get_nrows() + flush(0) + call psb_barrier(ctxt) call lv%linmap%map_U2V(alpha,vect_u,beta,tv,info,& & work=work,vtx=vtx,vty=vty) call tv%sync() !rsnd = tv%get_vect() - !call psb_snd(ctxt,rsnd(1:nrl),idest) + !call psb_snd(ctxt,rsnd(1:nrl),idest) + write(0,*) me,' map_rstr sending ',me,idest call psb_snd(ctxt,tv%v%v(1:nrl),idest) if (rme >=0) then allocate(rrcv(sum(nrsrc))) @@ -88,7 +91,7 @@ subroutine amg_d_base_onelev_map_rstr_v(lv,alpha,vect_u,beta,vect_v,info,& do i = 1,size(isrc) ip = isrc(i) nrl = nrsrc(i) -!!$ write(0,*) me,' Receiving from ',ip,nrl,kp+1,kp+nrl,size(rrcv) + write(0,*) me,' map_rstr receiving',rme,i,ip call psb_rcv(ctxt,rrcv(kp+1:kp+nrl),ip) kp = kp + nrl end do diff --git a/amgprec/impl/level/amg_s_base_onelev_descr.f90 b/amgprec/impl/level/amg_s_base_onelev_descr.f90 index 94de1a64..98d103ff 100644 --- a/amgprec/impl/level/amg_s_base_onelev_descr.f90 +++ b/amgprec/impl/level/amg_s_base_onelev_descr.f90 @@ -62,6 +62,8 @@ subroutine amg_s_base_onelev_descr(lv,il,nl,ilmin,info,iout,verbosity,prefix) integer(psb_ipk_) :: iout_, verbosity_ logical :: coarse character(1024) :: prefix_ + type(psb_ctxt_type) :: pctxt + integer(psb_ipk_) :: pme, pnp call psb_erractionsave(err_act) @@ -81,12 +83,16 @@ subroutine amg_s_base_onelev_descr(lv,il,nl,ilmin,info,iout,verbosity,prefix) verbosity_ = 0 end if if (verbosity_ < 0) goto 9998 - if (present(prefix)) then - prefix_ = prefix - else - prefix_ = "" - end if - + if (present(prefix)) then + prefix_ = prefix + else + prefix_ = "" + end if + + pctxt = lv%desc_ac%get_ctxt() + call psb_info(pctxt,pme,pnp) + write(iout_,*) trim(prefix_) + write(iout_,*) 'At level :',il,' we have ',pnp,' processes' write(iout_,*) trim(prefix_) if (il == ilmin) then call lv%parms%mlcycledsc(iout_,info) diff --git a/amgprec/impl/level/amg_s_base_onelev_map_rstr.F90 b/amgprec/impl/level/amg_s_base_onelev_map_rstr.F90 index 63d8af5b..e9e0cdb5 100644 --- a/amgprec/impl/level/amg_s_base_onelev_map_rstr.F90 +++ b/amgprec/impl/level/amg_s_base_onelev_map_rstr.F90 @@ -55,7 +55,7 @@ subroutine amg_s_base_onelev_map_rstr_v(lv,alpha,vect_u,beta,vect_v,info,& ! !!$ write(0,*) 'Remap handling not implemented yet ' block - type(psb_ctxt_type) :: ctxt, nctxt + type(psb_ctxt_type) :: ctxt, rctxt integer(psb_mpk_) :: i,j,ip, idest, nsrc, nrl, kp integer(psb_mpk_) :: me, np, rme, rnp real(psb_spk_), allocatable :: rsnd(:), rrcv(:) @@ -63,8 +63,8 @@ subroutine amg_s_base_onelev_map_rstr_v(lv,alpha,vect_u,beta,vect_v,info,& ctxt = lv%remap_data%desc_ac_pre_remap%get_ctxt() call psb_info(ctxt,me,np) - nctxt = lv%desc_ac%get_ctxt() - call psb_info(nctxt,rme,rnp) + rctxt = lv%desc_ac%get_ctxt() + call psb_info(rctxt,rme,rnp) !!$ write(0,*) 'New context ',rme,rnp idest = lv%remap_data%idest associate(isrc => lv%remap_data%isrc, nrsrc => lv%remap_data%nrsrc) @@ -74,12 +74,15 @@ subroutine amg_s_base_onelev_map_rstr_v(lv,alpha,vect_u,beta,vect_v,info,& nrl = lv%remap_data%desc_ac_pre_remap%get_local_rows() call psb_geall(tv,lv%remap_data%desc_ac_pre_remap,info) call psb_geasb(tv,lv%remap_data%desc_ac_pre_remap,info,mold=vect_u%v) -!!$ write(0,*) me,' Size of TV ',tv%get_nrows() + write(0,*) me,' map_rstr calling U2V: ',me,np,rme,rnp,tv%get_nrows() + flush(0) + call psb_barrier(ctxt) call lv%linmap%map_U2V(alpha,vect_u,beta,tv,info,& & work=work,vtx=vtx,vty=vty) call tv%sync() !rsnd = tv%get_vect() - !call psb_snd(ctxt,rsnd(1:nrl),idest) + !call psb_snd(ctxt,rsnd(1:nrl),idest) + write(0,*) me,' map_rstr sending ',me,idest call psb_snd(ctxt,tv%v%v(1:nrl),idest) if (rme >=0) then allocate(rrcv(sum(nrsrc))) @@ -88,7 +91,7 @@ subroutine amg_s_base_onelev_map_rstr_v(lv,alpha,vect_u,beta,vect_v,info,& do i = 1,size(isrc) ip = isrc(i) nrl = nrsrc(i) -!!$ write(0,*) me,' Receiving from ',ip,nrl,kp+1,kp+nrl,size(rrcv) + write(0,*) me,' map_rstr receiving',rme,i,ip call psb_rcv(ctxt,rrcv(kp+1:kp+nrl),ip) kp = kp + nrl end do diff --git a/amgprec/impl/level/amg_z_base_onelev_descr.f90 b/amgprec/impl/level/amg_z_base_onelev_descr.f90 index e58b77f3..d0e9ef2f 100644 --- a/amgprec/impl/level/amg_z_base_onelev_descr.f90 +++ b/amgprec/impl/level/amg_z_base_onelev_descr.f90 @@ -62,6 +62,8 @@ subroutine amg_z_base_onelev_descr(lv,il,nl,ilmin,info,iout,verbosity,prefix) integer(psb_ipk_) :: iout_, verbosity_ logical :: coarse character(1024) :: prefix_ + type(psb_ctxt_type) :: pctxt + integer(psb_ipk_) :: pme, pnp call psb_erractionsave(err_act) @@ -81,12 +83,16 @@ subroutine amg_z_base_onelev_descr(lv,il,nl,ilmin,info,iout,verbosity,prefix) verbosity_ = 0 end if if (verbosity_ < 0) goto 9998 - if (present(prefix)) then - prefix_ = prefix - else - prefix_ = "" - end if - + if (present(prefix)) then + prefix_ = prefix + else + prefix_ = "" + end if + + pctxt = lv%desc_ac%get_ctxt() + call psb_info(pctxt,pme,pnp) + write(iout_,*) trim(prefix_) + write(iout_,*) 'At level :',il,' we have ',pnp,' processes' write(iout_,*) trim(prefix_) if (il == ilmin) then call lv%parms%mlcycledsc(iout_,info) diff --git a/amgprec/impl/level/amg_z_base_onelev_map_rstr.F90 b/amgprec/impl/level/amg_z_base_onelev_map_rstr.F90 index 2b26e27a..c3a742dc 100644 --- a/amgprec/impl/level/amg_z_base_onelev_map_rstr.F90 +++ b/amgprec/impl/level/amg_z_base_onelev_map_rstr.F90 @@ -55,7 +55,7 @@ subroutine amg_z_base_onelev_map_rstr_v(lv,alpha,vect_u,beta,vect_v,info,& ! !!$ write(0,*) 'Remap handling not implemented yet ' block - type(psb_ctxt_type) :: ctxt, nctxt + type(psb_ctxt_type) :: ctxt, rctxt integer(psb_mpk_) :: i,j,ip, idest, nsrc, nrl, kp integer(psb_mpk_) :: me, np, rme, rnp complex(psb_dpk_), allocatable :: rsnd(:), rrcv(:) @@ -63,8 +63,8 @@ subroutine amg_z_base_onelev_map_rstr_v(lv,alpha,vect_u,beta,vect_v,info,& ctxt = lv%remap_data%desc_ac_pre_remap%get_ctxt() call psb_info(ctxt,me,np) - nctxt = lv%desc_ac%get_ctxt() - call psb_info(nctxt,rme,rnp) + rctxt = lv%desc_ac%get_ctxt() + call psb_info(rctxt,rme,rnp) !!$ write(0,*) 'New context ',rme,rnp idest = lv%remap_data%idest associate(isrc => lv%remap_data%isrc, nrsrc => lv%remap_data%nrsrc) @@ -74,12 +74,15 @@ subroutine amg_z_base_onelev_map_rstr_v(lv,alpha,vect_u,beta,vect_v,info,& nrl = lv%remap_data%desc_ac_pre_remap%get_local_rows() call psb_geall(tv,lv%remap_data%desc_ac_pre_remap,info) call psb_geasb(tv,lv%remap_data%desc_ac_pre_remap,info,mold=vect_u%v) -!!$ write(0,*) me,' Size of TV ',tv%get_nrows() + write(0,*) me,' map_rstr calling U2V: ',me,np,rme,rnp,tv%get_nrows() + flush(0) + call psb_barrier(ctxt) call lv%linmap%map_U2V(alpha,vect_u,beta,tv,info,& & work=work,vtx=vtx,vty=vty) call tv%sync() !rsnd = tv%get_vect() - !call psb_snd(ctxt,rsnd(1:nrl),idest) + !call psb_snd(ctxt,rsnd(1:nrl),idest) + write(0,*) me,' map_rstr sending ',me,idest call psb_snd(ctxt,tv%v%v(1:nrl),idest) if (rme >=0) then allocate(rrcv(sum(nrsrc))) @@ -88,7 +91,7 @@ subroutine amg_z_base_onelev_map_rstr_v(lv,alpha,vect_u,beta,vect_v,info,& do i = 1,size(isrc) ip = isrc(i) nrl = nrsrc(i) -!!$ write(0,*) me,' Receiving from ',ip,nrl,kp+1,kp+nrl,size(rrcv) + write(0,*) me,' map_rstr receiving',rme,i,ip call psb_rcv(ctxt,rrcv(kp+1:kp+nrl),ip) kp = kp + nrl end do diff --git a/samples/advanced/remap/amg_d_pde3d.F90 b/samples/advanced/remap/amg_d_pde3d.F90 index 26888b94..c092bf08 100644 --- a/samples/advanced/remap/amg_d_pde3d.F90 +++ b/samples/advanced/remap/amg_d_pde3d.F90 @@ -491,6 +491,7 @@ program amg_d_pde3d write(psb_out_unit,'(" ")') end if + call prec%descr(info,iout=psb_out_unit) if (p_choice%dump) then call prec%dump(info,istart=p_choice%dlmin,iend=p_choice%dlmax,& & ac=p_choice%dump_ac,rp=p_choice%dump_rp,tprol=p_choice%dump_tprol,&