diff --git a/mlprec/Makefile b/mlprec/Makefile index 0650ba5d..e2cce546 100644 --- a/mlprec/Makefile +++ b/mlprec/Makefile @@ -7,22 +7,22 @@ HERE=. FINCLUDES=$(FMFLAG). $(FMFLAG)$(LIBDIR) $(FMFLAG)$(PSBINCDIR) $(FMFLAG)$(PSBLIBDIR) -DMODOBJS=mld_d_prec_type.o mld_d_prec_mod.o mld_d_move_alloc_mod.o mld_d_ilu_fact_mod.o \ +DMODOBJS=mld_d_prec_type.o mld_d_prec_mod.o mld_d_ilu_fact_mod.o \ mld_d_inner_mod.o mld_d_ilu_solver.o mld_d_diag_solver.o mld_d_jac_smoother.o mld_d_as_smoother.o \ mld_d_umf_solver.o mld_d_slu_solver.o mld_d_sludist_solver.o mld_d_id_solver.o\ mld_d_base_solver_mod.o mld_d_base_smoother_mod.o mld_d_onelev_mod.o -SMODOBJS=mld_s_prec_type.o mld_s_prec_mod.o mld_s_move_alloc_mod.o mld_s_ilu_fact_mod.o \ +SMODOBJS=mld_s_prec_type.o mld_s_prec_mod.o mld_s_ilu_fact_mod.o \ mld_s_inner_mod.o mld_s_ilu_solver.o mld_s_diag_solver.o mld_s_jac_smoother.o mld_s_as_smoother.o \ mld_s_slu_solver.o mld_s_sludist_solver.o mld_s_id_solver.o\ mld_s_base_solver_mod.o mld_s_base_smoother_mod.o mld_s_onelev_mod.o -ZMODOBJS=mld_z_prec_type.o mld_z_prec_mod.o mld_z_move_alloc_mod.o mld_z_ilu_fact_mod.o \ +ZMODOBJS=mld_z_prec_type.o mld_z_prec_mod.o mld_z_ilu_fact_mod.o \ mld_z_inner_mod.o mld_z_ilu_solver.o mld_z_diag_solver.o mld_z_jac_smoother.o mld_z_as_smoother.o \ mld_z_umf_solver.o mld_z_slu_solver.o mld_z_sludist_solver.o mld_z_id_solver.o\ mld_z_base_solver_mod.o mld_z_base_smoother_mod.o mld_z_onelev_mod.o -CMODOBJS=mld_c_prec_type.o mld_c_prec_mod.o mld_c_move_alloc_mod.o mld_c_ilu_fact_mod.o \ +CMODOBJS=mld_c_prec_type.o mld_c_prec_mod.o mld_c_ilu_fact_mod.o \ mld_c_inner_mod.o mld_c_ilu_solver.o mld_c_diag_solver.o mld_c_jac_smoother.o mld_c_as_smoother.o \ mld_c_slu_solver.o mld_c_sludist_solver.o mld_c_id_solver.o\ mld_c_base_solver_mod.o mld_c_base_smoother_mod.o mld_c_onelev_mod.o @@ -63,20 +63,15 @@ $(DINNEROBJS) $(DOUTEROBJS): $(DMODOBJS) $(CINNEROBJS) $(COUTEROBJS): $(CMODOBJS) $(ZINNEROBJS) $(ZOUTEROBJS): $(ZMODOBJS) -mld_s_inner_mod.o: mld_s_move_alloc_mod.o mld_s_prec_type.o -mld_d_inner_mod.o: mld_d_move_alloc_mod.o mld_d_prec_type.o -mld_c_inner_mod.o: mld_c_move_alloc_mod.o mld_c_prec_type.o -mld_z_inner_mod.o: mld_z_move_alloc_mod.o mld_z_prec_type.o +mld_s_inner_mod.o: mld_s_prec_type.o +mld_d_inner_mod.o: mld_d_prec_type.o +mld_c_inner_mod.o: mld_c_prec_type.o +mld_z_inner_mod.o: mld_z_prec_type.o -mld_s_move_alloc_mod.o: mld_s_prec_type.o -mld_d_move_alloc_mod.o: mld_d_prec_type.o -mld_c_move_alloc_mod.o: mld_c_prec_type.o -mld_z_move_alloc_mod.o: mld_z_prec_type.o - -mld_s_prec_mod.o: mld_s_move_alloc_mod.o -mld_d_prec_mod.o: mld_d_move_alloc_mod.o -mld_c_prec_mod.o: mld_c_move_alloc_mod.o -mld_z_prec_mod.o: mld_z_move_alloc_mod.o +mld_s_prec_mod.o: mld_s_prec_type.o +mld_d_prec_mod.o: mld_d_prec_type.o +mld_c_prec_mod.o: mld_c_prec_type.o +mld_z_prec_mod.o: mld_z_prec_type.o mld_s_prec_type.o: mld_s_onelev_mod.o @@ -97,9 +92,6 @@ mld_z_base_smoother_mod.o: mld_z_base_solver_mod.o mld_s_base_solver_mod.o mld_d_base_solver_mod.o mld_c_base_solver_mod.o mld_z_base_solver_mod.o: mld_base_prec_type.o - - - mld_d_id_solver.o mld_d_sludist_solver.o mld_d_slu_solver.o \ mld_d_umf_solver.o mld_d_diag_solver.o mld_d_ilu_solver.o: mld_d_base_solver_mod.o mld_d_prec_type.o diff --git a/mlprec/impl/Makefile b/mlprec/impl/Makefile index a4ab4cd3..998aed04 100644 --- a/mlprec/impl/Makefile +++ b/mlprec/impl/Makefile @@ -7,13 +7,13 @@ HERE=.. FINCLUDES=$(FMFLAG).. $(FMFLAG)$(LIBDIR) $(FMFLAG)$(PSBINCDIR) $(FMFLAG)$(PSBLIBDIR) -DMPFOBJS=mld_daggrmat_nosmth_asb.o mld_daggrmat_smth_asb.o mld_daggrmat_minnrg_asb.o +DMPFOBJS=mld_daggrmat_nosmth_asb.o mld_daggrmat_smth_asb.o mld_daggrmat_minnrg_asb.o mld_daggrmat_biz_asb.o -SMPFOBJS=mld_saggrmat_nosmth_asb.o mld_saggrmat_smth_asb.o mld_saggrmat_minnrg_asb.o +SMPFOBJS=mld_saggrmat_nosmth_asb.o mld_saggrmat_smth_asb.o mld_saggrmat_minnrg_asb.o mld_saggrmat_biz_asb.o -ZMPFOBJS=mld_zaggrmat_nosmth_asb.o mld_zaggrmat_smth_asb.o mld_zaggrmat_minnrg_asb.o +ZMPFOBJS=mld_zaggrmat_nosmth_asb.o mld_zaggrmat_smth_asb.o mld_zaggrmat_minnrg_asb.o mld_zaggrmat_biz_asb.o -CMPFOBJS=mld_caggrmat_nosmth_asb.o mld_caggrmat_smth_asb.o mld_caggrmat_minnrg_asb.o +CMPFOBJS=mld_caggrmat_nosmth_asb.o mld_caggrmat_smth_asb.o mld_caggrmat_minnrg_asb.o mld_caggrmat_biz_asb.o MPFOBJS=$(SMPFOBJS) $(DMPFOBJS) $(CMPFOBJS) $(ZMPFOBJS) diff --git a/mlprec/impl/mld_c_onelev_impl.f90 b/mlprec/impl/mld_c_onelev_impl.f90 index e5faa843..d25bd23f 100644 --- a/mlprec/impl/mld_c_onelev_impl.f90 +++ b/mlprec/impl/mld_c_onelev_impl.f90 @@ -154,7 +154,7 @@ subroutine mld_c_base_onelev_free(lv,info) & call lv%sm%free(info) call lv%ac%free() - if (psb_is_ok_desc(lv%desc_ac)) & + if (lv%desc_ac%is_ok()) & & call psb_cdfree(lv%desc_ac,info) call lv%map%free(info) diff --git a/mlprec/impl/mld_caggrmat_asb.f90 b/mlprec/impl/mld_caggrmat_asb.f90 index 28c67e8d..bfc5ef91 100644 --- a/mlprec/impl/mld_caggrmat_asb.f90 +++ b/mlprec/impl/mld_caggrmat_asb.f90 @@ -113,6 +113,11 @@ subroutine mld_caggrmat_asb(a,desc_a,ilaggr,nlaggr,p,info) integer, intent(out) :: info ! Local variables + type(psb_cspmat_type) :: ac, op_prol,op_restr + type(psb_c_coo_sparse_mat) :: acoo, bcoo + type(psb_c_csr_sparse_mat) :: acsr1 + integer :: nzl,ntaggr + integer :: debug_level, debug_unit integer :: ictxt,np,me, err_act character(len=20) :: name @@ -120,6 +125,9 @@ subroutine mld_caggrmat_asb(a,desc_a,ilaggr,nlaggr,p,info) if(psb_get_errstatus().ne.0) return info=psb_success_ call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + ictxt = desc_a%get_context() @@ -128,35 +136,139 @@ subroutine mld_caggrmat_asb(a,desc_a,ilaggr,nlaggr,p,info) select case (p%parms%aggr_kind) case (mld_no_smooth_) - call mld_aggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,p,info) - if(info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='mld_aggrmat_nosmth_asb') + call mld_caggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,& + & p%parms,ac,op_prol,op_restr,info) + + case(mld_smooth_prol_) + + call mld_caggrmat_smth_asb(a,desc_a,ilaggr,nlaggr, & + & p%parms,ac,op_prol,op_restr,info) + + case(mld_biz_prol_) + + call mld_caggrmat_biz_asb(a,desc_a,ilaggr,nlaggr, & + & p%parms,ac,op_prol,op_restr,info) + + case(mld_min_energy_) + + call mld_caggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr, & + & p%parms,ac,op_prol,op_restr,info) + + case default + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='Invalid aggr kind') + goto 9999 + + end select + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='Inner aggrmat asb') + goto 9999 + end if + + + + ntaggr = sum(nlaggr) + + select case(p%parms%coarse_mat) + + case(mld_distr_mat_) + + nzl = ac%get_nzeros() + call ac%mv_to(bcoo) + + if (info == psb_success_) call psb_cdall(ictxt,p%desc_ac,info,nl=nlaggr(me+1)) + if (info == psb_success_) call psb_cdins(nzl,bcoo%ia,bcoo%ja,p%desc_ac,info) + if (info == psb_success_) call psb_cdasb(p%desc_ac,info) + if (info == psb_success_) call psb_glob_to_loc(bcoo%ia(1:nzl),p%desc_ac,info,iact='I') + if (info == psb_success_) call psb_glob_to_loc(bcoo%ja(1:nzl),p%desc_ac,info,iact='I') + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Creating p%desc_ac and converting ac') goto 9999 end if + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & 'Assembld aux descr. distr.' + call p%ac%mv_from(bcoo) - case(mld_smooth_prol_,mld_biz_prol_) + call p%ac%set_nrows(p%desc_ac%get_local_rows()) + call p%ac%set_ncols(p%desc_ac%get_local_cols()) + call p%ac%set_asb() - call mld_aggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info) - if(info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='mld_aggrmat_smth_asb') + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_sp_free') goto 9999 end if - case(mld_min_energy_) + if (np>1) then + call op_prol%mv_to(acsr1) + nzl = acsr1%get_nzeros() + call psb_glob_to_loc(acsr1%ja(1:nzl),p%desc_ac,info,'I') + if(info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_glob_to_loc') + goto 9999 + end if + call op_prol%mv_from(acsr1) + endif + call op_prol%set_ncols(p%desc_ac%get_local_cols()) - call mld_aggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info) - if(info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='mld_aggrmat_smth_asb') - goto 9999 + if (np>1) then + call op_restr%cscnv(info,type='coo',dupl=psb_dupl_add_) + call op_restr%mv_to(acoo) + nzl = acoo%get_nzeros() + if (info == psb_success_) call psb_glob_to_loc(acoo%ia(1:nzl),p%desc_ac,info,'I') + call acoo%set_dupl(psb_dupl_add_) + if (info == psb_success_) call op_restr%mv_from(acoo) + if (info == psb_success_) call op_restr%cscnv(info,type='csr') + if(info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,a_err='Converting op_restr to local') + goto 9999 + end if end if + call op_restr%set_nrows(p%desc_ac%get_local_cols()) - case default + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & 'Done ac ' - call psb_errpush(psb_err_internal_error_,name,a_err='Invalid aggr kind') - goto 9999 + case(mld_repl_mat_) + ! + ! + call psb_cdall(ictxt,p%desc_ac,info,mg=ntaggr,repl=.true.) + if (info == psb_success_) call psb_cdasb(p%desc_ac,info) + if (info == psb_success_) & + & call psb_gather(p%ac,ac,p%desc_ac,info,dupl=psb_dupl_add_,keeploc=.false.) + + if (info /= psb_success_) goto 9999 + case default + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='invalid mld_coarse_mat_') + goto 9999 end select + call p%ac%cscnv(info,type='csr',dupl=psb_dupl_add_) + if(info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='spcnv') + goto 9999 + end if + + ! + ! Copy the prolongation/restriction matrices into the descriptor map. + ! op_restr => PR^T i.e. restriction operator + ! op_prol => PR i.e. prolongation operator + ! + + p%map = psb_linmap(psb_map_aggr_,desc_a,& + & p%desc_ac,op_restr,op_prol,ilaggr,nlaggr) + if (info == psb_success_) call op_prol%free() + if (info == psb_success_) call op_restr%free() + if(info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='sp_Free') + goto 9999 + end if + + call psb_erractionrestore(err_act) return diff --git a/mlprec/impl/mld_caggrmat_biz_asb.f90 b/mlprec/impl/mld_caggrmat_biz_asb.f90 new file mode 100644 index 00000000..d278e4bf --- /dev/null +++ b/mlprec/impl/mld_caggrmat_biz_asb.f90 @@ -0,0 +1,422 @@ +!!$ +!!$ +!!$ MLD2P4 version 2.0 +!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package +!!$ based on PSBLAS (Parallel Sparse BLAS version 3.0) +!!$ +!!$ (C) Copyright 2008,2009,2010 +!!$ +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari CNRS-IRIT, Toulouse +!!$ Pasqua D'Ambra ICAR-CNR, Naples +!!$ Daniela di Serafino Second University of Naples +!!$ +!!$ Redistribution and use in source and binary forms, with or without +!!$ modification, are permitted provided that the following conditions +!!$ are met: +!!$ 1. Redistributions of source code must retain the above copyright +!!$ notice, this list of conditions and the following disclaimer. +!!$ 2. Redistributions in binary form must reproduce the above copyright +!!$ notice, this list of conditions, and the following disclaimer in the +!!$ documentation and/or other materials provided with the distribution. +!!$ 3. The name of the MLD2P4 group or the names of its contributors may +!!$ not be used to endorse or promote products derived from this +!!$ software without specific written permission. +!!$ +!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE MLD2P4 GROUP OR ITS CONTRIBUTORS +!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +!!$ POSSIBILITY OF SUCH DAMAGE. +!!$ +!!$ +! File: mld_caggrmat_biz_asb.F90 +! +! Subroutine: mld_caggrmat_biz_asb +! Version: complex +! +! This routine builds a coarse-level matrix A_C from a fine-level matrix A +! by using the Galerkin approach, i.e. +! +! A_C = P_C^T A P_C, +! +! where P_C is a prolongator from the coarse level to the fine one. +! +! This routine builds A_C according to a "bizarre" aggregation algorithm, +! using a "naive" prolongator proposed by the authors of MLD2P4. However, this +! prolongator still requires a deep analysis and testing and its use is not +! recommended. +! +! The coarse-level matrix A_C is distributed among the parallel processes or +! replicated on each of them, according to the value of p%parms%coarse_mat, +! specified by the user through mld_cprecinit and mld_zprecset. +! +! Arguments: +! a - type(psb_cspmat_type), input. +! The sparse matrix structure containing the local part of +! the fine-level matrix. +! desc_a - type(psb_desc_type), input. +! The communication descriptor of the fine-level matrix. +! p - type(mld_c_onelev_type), input/output. +! The 'one-level' data structure that will contain the local +! part of the matrix to be built as well as the information +! concerning the prolongator and its transpose. +! ilaggr - integer, dimension(:), allocatable. +! The mapping between the row indices of the coarse-level +! matrix and the row indices of the fine-level matrix. +! ilaggr(i)=j means that node i in the adjacency graph +! of the fine-level matrix is mapped onto node j in the +! adjacency graph of the coarse-level matrix. +! nlaggr - integer, dimension(:), allocatable. +! nlaggr(i) contains the aggregates held by process i. +! info - integer, output. +! Error code. +! +subroutine mld_caggrmat_biz_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_restr,info) + use psb_base_mod + use mld_c_inner_mod, mld_protect_name => mld_caggrmat_biz_asb + + implicit none + + ! Arguments + type(psb_cspmat_type), intent(in) :: a + type(psb_desc_type), intent(in) :: desc_a + integer, intent(inout) :: ilaggr(:), nlaggr(:) + type(mld_sml_parms), intent(inout) :: parms + type(psb_cspmat_type), intent(out) :: ac,op_prol,op_restr + integer, intent(out) :: info + + ! Local variables + integer :: nrow, nglob, ncol, ntaggr, ip, ndx,& + & naggr, nzl,naggrm1,naggrp1, i, j, k, jd, icolF, nrw + integer ::ictxt, np, me, err_act + character(len=20) :: name + type(psb_cspmat_type) :: am3, am4 + type(psb_c_coo_sparse_mat) :: tmpcoo + type(psb_c_csr_sparse_mat) :: acsr1, acsr2, acsr3, acsrf, ptilde + complex(psb_spk_), allocatable :: adiag(:) + integer(psb_ipk_) :: ierr(5) + logical :: filter_mat + integer :: debug_level, debug_unit + integer, parameter :: ncmax=16 + real(psb_spk_) :: anorm, omega, tmp, dg, theta + + name='mld_aggrmat_biz_asb' + if(psb_get_errstatus().ne.0) return + info=psb_success_ + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + ictxt = desc_a%get_context() + ictxt = desc_a%get_context() + + call psb_info(ictxt, me, np) + + nglob = desc_a%get_global_rows() + nrow = desc_a%get_local_rows() + ncol = desc_a%get_local_cols() + + theta = parms%aggr_thresh + + naggr = nlaggr(me+1) + ntaggr = sum(nlaggr) + + naggrm1 = sum(nlaggr(1:me)) + naggrp1 = sum(nlaggr(1:me+1)) + + filter_mat = (parms%aggr_filter == mld_filter_mat_) + + ilaggr(1:nrow) = ilaggr(1:nrow) + naggrm1 + call psb_halo(ilaggr,desc_a,info) + + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_halo') + goto 9999 + end if + + ! naggr: number of local aggregates + ! nrow: local rows. + ! + allocate(adiag(ncol),stat=info) + + if (info /= psb_success_) then + info=psb_err_alloc_request_; ierr(1)=nrow; + call psb_errpush(info,name,i_err=ierr,a_err='complex(psb_spk_)') + goto 9999 + end if + + ! Get the diagonal D + call a%get_diag(adiag,info) + if (info == psb_success_) & + & call psb_halo(adiag,desc_a,info) + + if(info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='sp_getdiag') + goto 9999 + end if + + ! 1. Allocate Ptilde in sparse matrix form + call tmpcoo%allocate(ncol,naggr,ncol) + do i=1,nrow + tmpcoo%val(i) = cone + tmpcoo%ia(i) = i + tmpcoo%ja(i) = ilaggr(i) + end do + call tmpcoo%set_nzeros(nrow) + call tmpcoo%set_dupl(psb_dupl_add_) + + call ptilde%mv_from_coo(tmpcoo,info) + if (info == psb_success_) call a%cscnv(acsr3,info,dupl=psb_dupl_add_) + + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & ' Initial copies sone.' + + if (filter_mat) then + ! + ! Build the filtered matrix Af from A + ! + if (info == psb_success_) call a%cscnv(acsrf,info,dupl=psb_dupl_add_) + + do i=1,nrow + tmp = czero + jd = -1 + do j=acsrf%irp(i),acsrf%irp(i+1)-1 + if (acsrf%ja(j) == i) jd = j + if (abs(acsrf%val(j)) < theta*sqrt(abs(adiag(i)*adiag(acsrf%ja(j))))) then + tmp=tmp+acsrf%val(j) + acsrf%val(j)=czero + endif + + enddo + if (jd == -1) then + write(0,*) 'Wrong input: we need the diagonal!!!!', i + else + acsrf%val(jd)=acsrf%val(jd)-tmp + end if + enddo + ! Take out zeroed terms + call acsrf%mv_to_coo(tmpcoo,info) + k = 0 + do j=1,tmpcoo%get_nzeros() + if ((tmpcoo%val(j) /= czero) .or. (tmpcoo%ia(j) == tmpcoo%ja(j))) then + k = k + 1 + tmpcoo%val(k) = tmpcoo%val(j) + tmpcoo%ia(k) = tmpcoo%ia(j) + tmpcoo%ja(k) = tmpcoo%ja(j) + end if + end do + call tmpcoo%set_nzeros(k) + call tmpcoo%set_dupl(psb_dupl_add_) + call acsrf%mv_from_coo(tmpcoo,info) + end if + + + do i=1,size(adiag) + if (adiag(i) /= czero) then + adiag(i) = cone / adiag(i) + else + adiag(i) = cone + end if + end do + + if (filter_mat) call acsrf%scal(adiag,info) + if (info == psb_success_) call acsr3%scal(adiag,info) + if (info /= psb_success_) goto 9999 + + + if (parms%aggr_omega_alg == mld_eig_est_) then + + if (parms%aggr_eig == mld_max_norm_) then + + ! + ! This only works with CSR + ! + anorm = szero + dg = sone + nrw = acsr3%get_nrows() + do i=1, nrw + tmp = szero + do j=acsr3%irp(i),acsr3%irp(i+1)-1 + if (acsr3%ja(j) <= nrw) then + tmp = tmp + abs(acsr3%val(j)) + endif + if (acsr3%ja(j) == i ) then + dg = abs(acsr3%val(j)) + end if + end do + anorm = max(anorm,tmp/dg) + enddo + + call psb_amx(ictxt,anorm) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,a_err='Invalid AM3 storage format') + goto 9999 + end if + omega = 4.d0/(3.d0*anorm) + parms%aggr_omega_val = omega + + else + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='invalid mld_aggr_eig_') + goto 9999 + end if + + else if (parms%aggr_omega_alg == mld_user_choice_) then + + omega = parms%aggr_omega_val + + else if (parms%aggr_omega_alg /= mld_user_choice_) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='invalid mld_aggr_omega_alg_') + goto 9999 + end if + + if (filter_mat) then + ! + ! Build the smoothed prolongator using the filtered matrix + ! + do i=1,acsrf%get_nrows() + do j=acsrf%irp(i),acsrf%irp(i+1)-1 + if (acsrf%ja(j) == i) then + acsrf%val(j) = cone - omega*acsrf%val(j) + else + acsrf%val(j) = - omega*acsrf%val(j) + end if + end do + end do + + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & 'Done gather, going for SYMBMM 1' + ! + ! Symbmm90 does the allocation for its result. + ! + ! acsrm1 = (I-w*D*Af)Ptilde + ! Doing it this way means to consider diag(Af_i) + ! + ! + call psb_symbmm(acsrf,ptilde,acsr1,info) + if(info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='symbmm 1') + goto 9999 + end if + + call psb_numbmm(acsrf,ptilde,acsr1) + + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & 'Done NUMBMM 1' + + else + ! + ! Build the smoothed prolongator using the original matrix + ! + do i=1,acsr3%get_nrows() + do j=acsr3%irp(i),acsr3%irp(i+1)-1 + if (acsr3%ja(j) == i) then + acsr3%val(j) = cone - omega*acsr3%val(j) + else + acsr3%val(j) = - omega*acsr3%val(j) + end if + end do + end do + + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & 'Done gather, going for SYMBMM 1' + ! + ! Symbmm90 does the allocation for its result. + ! + ! acsrm1 = (I-w*D*A)Ptilde + ! Doing it this way means to consider diag(A_i) + ! + ! + call psb_symbmm(acsr3,ptilde,acsr1,info) + if(info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='symbmm 1') + goto 9999 + end if + + call psb_numbmm(acsr3,ptilde,acsr1) + + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & 'Done NUMBMM 1' + + end if + call ptilde%free() + call acsr1%set_dupl(psb_dupl_add_) + + call op_prol%mv_from(acsr1) + + call psb_rwextd(ncol,op_prol,info) + if(info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,a_err='Halo of op_prol') + goto 9999 + end if + + call psb_symbmm(a,op_prol,am3,info) + if(info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='symbmm 2') + goto 9999 + end if + + call psb_numbmm(a,op_prol,am3) + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & 'Done NUMBMM 2',parms%aggr_kind, mld_smooth_prol_ + + call op_prol%transp(op_restr) + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & 'starting sphalo/ rwxtd' + + call psb_rwextd(ncol,am3,info) + if(info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,a_err='Extend am3') + goto 9999 + end if + + + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & 'starting symbmm 3' + call psb_symbmm(op_restr,am3,ac,info) + if (info == psb_success_) call psb_numbmm(op_restr,am3,ac) + if (info == psb_success_) call am3%free() + if (info == psb_success_) call ac%cscnv(info,type='coo',dupl=psb_dupl_add_) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,a_err='Build b = op_restr x am3') + goto 9999 + end if + + + + + + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & 'Done smooth_aggregate ' + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_errpush(info,name) + call psb_erractionrestore(err_act) + if (err_act.eq.psb_act_abort_) then + call psb_error() + return + end if + return + + + +end subroutine mld_caggrmat_biz_asb diff --git a/mlprec/impl/mld_caggrmat_minnrg_asb.F90 b/mlprec/impl/mld_caggrmat_minnrg_asb.f90 similarity index 78% rename from mlprec/impl/mld_caggrmat_minnrg_asb.F90 rename to mlprec/impl/mld_caggrmat_minnrg_asb.f90 index 2cfeb59c..6344b4a7 100644 --- a/mlprec/impl/mld_caggrmat_minnrg_asb.F90 +++ b/mlprec/impl/mld_caggrmat_minnrg_asb.f90 @@ -98,37 +98,31 @@ ! info - integer, output. ! Error code. ! -subroutine mld_caggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info) +subroutine mld_caggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_restr,info) use psb_base_mod use mld_c_inner_mod, mld_protect_name => mld_caggrmat_minnrg_asb -#ifdef MPI_MOD - use mpi -#endif implicit none -#ifdef MPI_H - include 'mpif.h' -#endif ! Arguments type(psb_cspmat_type), intent(in) :: a type(psb_desc_type), intent(in) :: desc_a integer, intent(inout) :: ilaggr(:), nlaggr(:) - type(mld_c_onelev_type), intent(inout), target :: p + type(mld_sml_parms), intent(inout) :: parms + type(psb_cspmat_type), intent(out) :: ac,op_prol,op_restr integer, intent(out) :: info ! Local variables - type(psb_cspmat_type) :: b integer(psb_mpik_), allocatable :: nzbr(:), idisp(:) integer :: nrow, nglob, ncol, ntaggr, nzac, ip, ndx,& & naggr, nzl,naggrm1,naggrp1, i, j, k, jd, icolF, nrt integer :: ictxt,np,me, err_act, icomm character(len=20) :: name - type(psb_cspmat_type) :: am1,am2, af, ptilde, rtilde, atran, atp, atdatp + type(psb_cspmat_type) :: af, ptilde, rtilde, atran, atp, atdatp type(psb_cspmat_type) :: am3,am4, ap, adap,atmp,rada, ra, atmp2, dap, dadap, da type(psb_cspmat_type) :: dat, datp, datdatp, atmp3 - type(psb_c_coo_sparse_mat) :: acoo, acoof, bcoo, tmpcoo - type(psb_c_csr_sparse_mat) :: acsr1, acsr2, acsr3, bcsr, acsr, acsrf + type(psb_c_coo_sparse_mat) :: tmpcoo + type(psb_c_csr_sparse_mat) :: acsr1, acsr2, acsr3, acsr, acsrf type(psb_c_csc_sparse_mat) :: csc_dap, csc_dadap, csc_datp, csc_datdatp, acsc complex(psb_spk_), allocatable :: adiag(:), adinv(:) complex(psb_spk_), allocatable :: omf(:), omp(:), omi(:), oden(:) @@ -156,7 +150,7 @@ subroutine mld_caggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info) nrow = desc_a%get_local_rows() ncol = desc_a%get_local_cols() - theta = p%parms%aggr_thresh + theta = parms%aggr_thresh naggr = nlaggr(me+1) ntaggr = sum(nlaggr) @@ -171,7 +165,7 @@ subroutine mld_caggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info) naggrm1 = sum(nlaggr(1:me)) naggrp1 = sum(nlaggr(1:me+1)) - filter_mat = (p%parms%aggr_filter == mld_filter_mat_) + filter_mat = (parms%aggr_filter == mld_filter_mat_) ilaggr(1:nrow) = ilaggr(1:nrow) + naggrm1 call psb_halo(ilaggr,desc_a,info) @@ -213,16 +207,16 @@ subroutine mld_caggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info) ! 1. Allocate Ptilde in sparse matrix form - call acoo%allocate(ncol,ntaggr,ncol) + call tmpcoo%allocate(ncol,ntaggr,ncol) do i=1,ncol - acoo%val(i) = cone - acoo%ia(i) = i - acoo%ja(i) = ilaggr(i) + tmpcoo%val(i) = cone + tmpcoo%ia(i) = i + tmpcoo%ja(i) = ilaggr(i) end do - call acoo%set_nzeros(ncol) - call acoo%set_dupl(psb_dupl_add_) - call acoo%set_asb() - call ptilde%mv_from(acoo) + call tmpcoo%set_nzeros(ncol) + call tmpcoo%set_dupl(psb_dupl_add_) + call tmpcoo%set_asb() + call ptilde%mv_from(tmpcoo) call ptilde%cscnv(info,type='csr') !!$ call local_dump(me,ptilde,'csr-ptilde','Ptilde-1') @@ -354,17 +348,17 @@ subroutine mld_caggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info) ! ! Symbmm90 does the allocation for its result. ! - ! am1 = (I-w*D*Af)Ptilde + ! op_prol = (I-w*D*Af)Ptilde ! Doing it this way means to consider diag(Af_i) ! ! - call psb_symbmm(af,ptilde,am1,info) + call psb_symbmm(af,ptilde,op_prol,info) if(info /= psb_success_) then call psb_errpush(psb_err_from_subroutine_,name,a_err='symbmm 1') goto 9999 end if - call psb_numbmm(af,ptilde,am1) + call psb_numbmm(af,ptilde,op_prol) if (debug_level >= psb_debug_outer_) & & write(debug_unit,*) me,' ',trim(name),& @@ -390,16 +384,16 @@ subroutine mld_caggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info) ! ! Symbmm90 does the allocation for its result. ! - ! am1 = (I-w*D*A)Ptilde + ! op_prol = (I-w*D*A)Ptilde ! ! - call psb_symbmm(am3,ptilde,am1,info) + call psb_symbmm(am3,ptilde,op_prol,info) if(info /= psb_success_) then call psb_errpush(psb_err_from_subroutine_,name,a_err='symbmm 1') goto 9999 end if - call psb_numbmm(am3,ptilde,am1) + call psb_numbmm(am3,ptilde,op_prol) if (debug_level >= psb_debug_outer_) & & write(debug_unit,*) me,' ',trim(name),& @@ -509,20 +503,20 @@ subroutine mld_caggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info) call rtilde%mv_from(tmpcoo) call rtilde%cscnv(info,type='csr') - call psb_symbmm(rtilde,atmp,am2,info) - call psb_numbmm(rtilde,atmp,am2) + call psb_symbmm(rtilde,atmp,op_restr,info) + call psb_numbmm(rtilde,atmp,op_restr) ! - ! Now we have to gather the halo of am1, and add it to itself + ! Now we have to gather the halo of op_prol, and add it to itself ! to multiply it by A, ! - call psb_sphalo(am1,desc_a,am4,info,& + call psb_sphalo(op_prol,desc_a,am4,info,& & colcnv=.false.,rowscale=.true.) - if (info == psb_success_) call psb_rwextd(ncol,am1,info,b=am4) + if (info == psb_success_) call psb_rwextd(ncol,op_prol,info,b=am4) if (info == psb_success_) call am4%free() if(info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,a_err='Halo of am1') + call psb_errpush(psb_err_internal_error_,name,a_err='Halo of op_prol') goto 9999 end if @@ -530,7 +524,7 @@ subroutine mld_caggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info) ! Now we have to fix this. The only rows of B that are correct ! are those corresponding to "local" aggregates, i.e. indices in ilaggr(:) ! - call am2%mv_to(tmpcoo) + call op_restr%mv_to(tmpcoo) nzl = tmpcoo%get_nzeros() i=0 @@ -543,21 +537,21 @@ subroutine mld_caggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info) end if end do call tmpcoo%set_nzeros(i) - call am2%mv_from(tmpcoo) - call am2%cscnv(info,type='csr') + call op_restr%mv_from(tmpcoo) + call op_restr%cscnv(info,type='csr') if (debug_level >= psb_debug_outer_) & & write(debug_unit,*) me,' ',trim(name),& & 'starting sphalo/ rwxtd' - call psb_symbmm(a,am1,am3,info) + call psb_symbmm(a,op_prol,am3,info) if(info /= psb_success_) then call psb_errpush(psb_err_from_subroutine_,name,& & a_err='symbmm 2') goto 9999 end if - call psb_numbmm(a,am1,am3) + call psb_numbmm(a,op_prol,am3) if (debug_level >= psb_debug_outer_) & & write(debug_unit,*) me,' ',trim(name),& & 'Done NUMBMM 2' @@ -576,156 +570,18 @@ subroutine mld_caggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info) & write(debug_unit,*) me,' ',trim(name),& & 'Done sphalo/ rwxtd' - call psb_symbmm(am2,am3,b,info) - if (info == psb_success_) call psb_numbmm(am2,am3,b) + call psb_symbmm(op_restr,am3,ac,info) + if (info == psb_success_) call psb_numbmm(op_restr,am3,ac) if (info == psb_success_) call am3%free() - call b%mv_to(bcoo) + if (info == psb_success_) call ac%cscnv(info,type='coo',dupl=psb_dupl_add_) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& - &a_err='Build b = am2 x am3') + &a_err='Build ac = op_restr x am3') goto 9999 end if - if (debug_level >= psb_debug_outer_) & - & write(debug_unit,*) me,' ',trim(name),& - & 'Done mv_to_coo' - - - select case(p%parms%coarse_mat) - - case(mld_distr_mat_) - - nzl = bcoo%get_nzeros() - - if (debug_level >= psb_debug_outer_) & - & write(debug_unit,*) me,' ',trim(name),& - & ' B matrix nzl: ',nzl - - if (info == psb_success_) call psb_cdall(ictxt,p%desc_ac,info,nl=nlaggr(me+1)) - if (info == psb_success_) call psb_cdins(nzl,bcoo%ia,bcoo%ja,p%desc_ac,info) - if (info == psb_success_) call psb_cdasb(p%desc_ac,info) - if (info == psb_success_) call psb_glob_to_loc(bcoo%ia(1:nzl),p%desc_ac,info,iact='I') - if (info == psb_success_) call psb_glob_to_loc(bcoo%ja(1:nzl),p%desc_ac,info,iact='I') - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Creating p%desc_ac and converting ac') - goto 9999 - end if - - if (debug_level >= psb_debug_outer_) & - & write(debug_unit,*) me,' ',trim(name),& - & ' Assembld aux descr. distr.' - - call bcoo%set_nrows(p%desc_ac%get_local_rows()) - call bcoo%set_ncols(p%desc_ac%get_local_cols()) - call bcoo%fix(info) - call p%ac%mv_from(bcoo) - call p%ac%set_asb() - - call p%ac%cscnv(info,type='csr') - - if (np>1) then - call am1%mv_to(acsr) - nzl = acsr%get_nzeros() - call psb_glob_to_loc(acsr%ja(1:nzl),p%desc_ac,info,'I') - if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_glob_to_loc') - goto 9999 - end if - call am1%mv_from(acsr) - endif - call am1%set_ncols(p%desc_ac%get_local_cols()) - - if (np>1) then - call am2%mv_to(tmpcoo) - nzl = tmpcoo%get_nzeros() - if (info == psb_success_) call psb_glob_to_loc(tmpcoo%ia(1:nzl),p%desc_ac,info,'I') - if(info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,a_err='Converting am2 to local') - goto 9999 - end if - call am2%mv_from(tmpcoo) - call am2%cscnv(info,type='csr') - end if - call am2%set_nrows(p%desc_ac%get_local_cols()) - - if (debug_level >= psb_debug_outer_) & - & write(debug_unit,*) me,' ',trim(name),& - & 'Done ac ' - - case(mld_repl_mat_) - ! - ! - call psb_cdall(ictxt,p%desc_ac,info,mg=ntaggr,repl=.true.) - nzbr(:) = 0 - nzbr(me+1) = bcoo%get_nzeros() - - call psb_sum(ictxt,nzbr(1:np)) - nzac = sum(nzbr) - if (info == psb_success_) call tmpcoo%allocate(ntaggr,ntaggr,nzac) - if (info /= psb_success_) goto 9999 - - do ip=1,np - idisp(ip) = sum(nzbr(1:ip-1)) - enddo - ndx = nzbr(me+1) - - call mpi_allgatherv(bcoo%val,ndx,mpi_complex,tmpcoo%val,nzbr,idisp,& - & mpi_complex,icomm,info) - if (info == psb_success_)& - & call mpi_allgatherv(bcoo%ia,ndx,psb_mpi_ipk_integer,tmpcoo%ia,nzbr,idisp,& - & psb_mpi_ipk_integer,icomm,info) - if (info == psb_success_)& - & call mpi_allgatherv(bcoo%ja,ndx,psb_mpi_ipk_integer,tmpcoo%ja,nzbr,idisp,& - & psb_mpi_ipk_integer,icomm,info) - - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err=' from mpi_allgatherv') - goto 9999 - end if - - call bcoo%free() - call tmpcoo%fix(info) - call p%ac%mv_from(tmpcoo) - call p%ac%cscnv(info,type='csr') - if(info /= psb_success_) goto 9999 - - deallocate(nzbr,idisp,stat=info) - if (info /= psb_success_) then - info = psb_err_alloc_dealloc_ - call psb_errpush(info,name) - goto 9999 - end if - case default - info = psb_err_internal_error_ - call psb_errpush(info,name,a_err='invalid mld_coarse_mat_') - goto 9999 - end select - - - - call p%ac%cscnv(info,type='csr') - if(info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='spcnv') - goto 9999 - end if - - ! - ! Copy the prolongation/restriction matrices into the descriptor map. - ! am2 => R i.e. restriction operator - ! am1 => P i.e. prolongation operator - ! - p%map = psb_linmap(psb_map_aggr_,desc_a,& - & p%desc_ac,am2,am1,ilaggr,nlaggr) - if (info == psb_success_) call am1%free() - if (info == psb_success_) call am2%free() - if(info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='sp_Free') - goto 9999 - end if if (debug_level >= psb_debug_outer_) & & write(debug_unit,*) me,' ',trim(name),& diff --git a/mlprec/impl/mld_caggrmat_nosmth_asb.F90 b/mlprec/impl/mld_caggrmat_nosmth_asb.f90 similarity index 57% rename from mlprec/impl/mld_caggrmat_nosmth_asb.F90 rename to mlprec/impl/mld_caggrmat_nosmth_asb.f90 index e96b1d55..02294e6a 100644 --- a/mlprec/impl/mld_caggrmat_nosmth_asb.F90 +++ b/mlprec/impl/mld_caggrmat_nosmth_asb.f90 @@ -81,35 +81,29 @@ ! info - integer, output. ! Error code. ! -subroutine mld_caggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,p,info) +subroutine mld_caggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_restr,info) use psb_base_mod use mld_c_inner_mod, mld_protect_name => mld_caggrmat_nosmth_asb -#ifdef MPI_MOD - use mpi -#endif implicit none -#ifdef MPI_H - include 'mpif.h' -#endif ! Arguments type(psb_cspmat_type), intent(in) :: a type(psb_desc_type), intent(in) :: desc_a integer, intent(inout) :: ilaggr(:), nlaggr(:) - type(mld_c_onelev_type), intent(inout), target :: p + type(mld_sml_parms), intent(inout) :: parms + type(psb_cspmat_type), intent(out) :: ac,op_prol,op_restr integer, intent(out) :: info ! Local variables integer :: ictxt,np,me, err_act integer(psb_mpik_) :: icomm, ndx, minfo character(len=20) :: name - type(psb_cspmat_type) :: b - integer(psb_mpik_), allocatable :: nzbr(:), idisp(:) integer(psb_ipk_) :: ierr(5) - type(psb_cspmat_type) :: am1,am2 - type(psb_c_coo_sparse_mat) :: acoo1, acoo2, bcoo, ac_coo - integer :: nrow, nglob, ncol, ntaggr, nzac, ip, & + type(psb_c_coo_sparse_mat) :: ac_coo, acoo + type(psb_c_csr_sparse_mat) :: acsr1, acsr2 + integer :: debug_level, debug_unit + integer :: nrow, nglob, ncol, ntaggr, nzl, ip, & & naggr, nzt, naggrm1, i name='mld_aggrmat_nosmth_asb' @@ -128,141 +122,48 @@ subroutine mld_caggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,p,info) naggr = nlaggr(me+1) ntaggr = sum(nlaggr) - allocate(nzbr(np), idisp(np),stat=info) - if (info /= psb_success_) then - info=psb_err_alloc_request_; ierr(1)=2*np; - call psb_errpush(info,name,i_err=ierr,a_err='integer') - goto 9999 - end if - naggrm1=sum(nlaggr(1:me)) - if (p%parms%coarse_mat == mld_repl_mat_) then - do i=1, nrow - ilaggr(i) = ilaggr(i) + naggrm1 - end do - call psb_halo(ilaggr,desc_a,info) - end if + do i=1, nrow + ilaggr(i) = ilaggr(i) + naggrm1 + end do + call psb_halo(ilaggr,desc_a,info) if(info /= psb_success_) then call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_halo') goto 9999 end if - if (p%parms%coarse_mat == mld_repl_mat_) then - call acoo1%allocate(ncol,ntaggr,ncol) - else - call acoo1%allocate(ncol,naggr,ncol) - end if + call acoo%allocate(ncol,ntaggr,ncol) do i=1,nrow - acoo1%val(i) = cone - acoo1%ia(i) = i - acoo1%ja(i) = ilaggr(i) + acoo%val(i) = cone + acoo%ia(i) = i + acoo%ja(i) = ilaggr(i) end do - call acoo1%set_dupl(psb_dupl_add_) - call acoo1%set_nzeros(nrow) - call acoo1%set_asb() - call acoo1%fix(info) - call acoo1%transp(acoo2) + call acoo%set_dupl(psb_dupl_add_) + call acoo%set_nzeros(nrow) + call acoo%set_asb() + call acoo%fix(info) + - call a%csclip(bcoo,info,jmax=nrow) + call op_prol%mv_from(acoo) + call op_prol%cscnv(info,type='csr',dupl=psb_dupl_add_) + if (info == psb_success_) call op_prol%transp(op_restr) + call a%csclip(ac_coo,info,jmax=nrow) - nzt = bcoo%get_nzeros() + nzt = ac_coo%get_nzeros() do i=1, nzt - bcoo%ia(i) = ilaggr(bcoo%ia(i)) - bcoo%ja(i) = ilaggr(bcoo%ja(i)) + ac_coo%ia(i) = ilaggr(ac_coo%ia(i)) + ac_coo%ja(i) = ilaggr(ac_coo%ja(i)) enddo - call bcoo%set_nrows(naggr) - call bcoo%set_ncols(naggr) - call bcoo%set_dupl(psb_dupl_add_) - call bcoo%fix(info) - - - if (p%parms%coarse_mat == mld_repl_mat_) then - - call psb_cdall(ictxt,p%desc_ac,info,mg=ntaggr,repl=.true.) - if (info == psb_success_) call psb_cdasb(p%desc_ac,info) - if(info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_cdall') - goto 9999 - end if - - nzbr(:) = 0 - nzbr(me+1) = nzt - call psb_sum(ictxt,nzbr(1:np)) - nzac = sum(nzbr) - - call ac_coo%allocate(ntaggr,ntaggr,nzac) - - do ip=1,np - idisp(ip) = sum(nzbr(1:ip-1)) - enddo - ndx = nzbr(me+1) - - call mpi_allgatherv(bcoo%val,ndx,mpi_complex,ac_coo%val,nzbr,idisp,& - & mpi_complex,icomm,minfo) - call mpi_allgatherv(bcoo%ia,ndx,psb_mpi_ipk_integer,ac_coo%ia,nzbr,idisp,& - & psb_mpi_ipk_integer,icomm,minfo) - call mpi_allgatherv(bcoo%ja,ndx,psb_mpi_ipk_integer,ac_coo%ja,nzbr,idisp,& - & psb_mpi_ipk_integer,icomm,minfo) - if(info /= psb_success_) then - info=-1 - call psb_errpush(info,name) - goto 9999 - end if - call ac_coo%set_nzeros(nzac) - call ac_coo%set_dupl(psb_dupl_add_) - call ac_coo%fix(info) - call p%ac%mv_from(ac_coo) - - else if (p%parms%coarse_mat == mld_distr_mat_) then - - call psb_cdall(ictxt,p%desc_ac,info,nl=naggr) - if (info == psb_success_) call psb_cdasb(p%desc_ac,info) - call p%ac%mv_from(bcoo) - if(info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,a_err='Build ac, desc_ac') - goto 9999 - - end if - - else - info = psb_err_internal_error_ - call psb_errpush(psb_err_internal_error_,name,a_err='invalid mld_coarse_mat_') - goto 9999 - end if - - call bcoo%free() - - deallocate(nzbr,idisp) - - call p%ac%cscnv(info,type='csr',dupl=psb_dupl_add_) - if(info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='cscnv') - goto 9999 - end if - - call am1%mv_from(acoo1) - call am1%cscnv(info,type='csr',dupl=psb_dupl_add_) - if (info == psb_success_) call am2%mv_from(acoo2) - if (info == psb_success_) call am2%cscnv(info,type='csr',dupl=psb_dupl_add_) - ! - ! Copy the prolongation/restriction matrices into the descriptor map. - ! am2 => PR^T i.e. restriction operator - ! am1 => PR i.e. prolongation operator - ! - if (info == psb_success_) & - & p%map = psb_linmap(psb_map_aggr_,desc_a,& - & p%desc_ac,am2,am1,ilaggr,nlaggr) - if (info == psb_success_) call am1%free() - if (info == psb_success_) call am2%free() - if(info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='linmap build') - goto 9999 - end if + call ac_coo%set_nrows(naggr) + call ac_coo%set_ncols(naggr) + call ac_coo%set_dupl(psb_dupl_add_) + call ac_coo%fix(info) + call ac%mv_from(ac_coo) call psb_erractionrestore(err_act) diff --git a/mlprec/impl/mld_caggrmat_smth_asb.F90 b/mlprec/impl/mld_caggrmat_smth_asb.f90 similarity index 52% rename from mlprec/impl/mld_caggrmat_smth_asb.F90 rename to mlprec/impl/mld_caggrmat_smth_asb.f90 index 7ec9e44a..d29321b7 100644 --- a/mlprec/impl/mld_caggrmat_smth_asb.F90 +++ b/mlprec/impl/mld_caggrmat_smth_asb.f90 @@ -61,11 +61,6 @@ ! according to the value of p%parms%aggr_omega_alg, specified by the user ! through mld_cprecinit and mld_zprecset. ! -! This routine can also build A_C according to a "bizarre" aggregation algorithm, -! using a "naive" prolongator proposed by the authors of MLD2P4. However, this -! prolongator still requires a deep analysis and testing and its use is not -! recommended. -! ! The coarse-level matrix A_C is distributed among the parallel processes or ! replicated on each of them, according to the value of p%parms%coarse_mat, ! specified by the user through mld_cprecinit and mld_zprecset. @@ -98,38 +93,31 @@ ! info - integer, output. ! Error code. ! -subroutine mld_caggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info) +subroutine mld_caggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_restr,info) use psb_base_mod use mld_c_inner_mod, mld_protect_name => mld_caggrmat_smth_asb -#ifdef MPI_MOD - use mpi -#endif implicit none -#ifdef MPI_H - include 'mpif.h' -#endif ! Arguments type(psb_cspmat_type), intent(in) :: a type(psb_desc_type), intent(in) :: desc_a integer, intent(inout) :: ilaggr(:), nlaggr(:) - type(mld_c_onelev_type), intent(inout), target :: p + type(mld_sml_parms), intent(inout) :: parms + type(psb_cspmat_type), intent(out) :: ac,op_prol,op_restr integer, intent(out) :: info ! Local variables - type(psb_cspmat_type) :: b - integer, allocatable :: nzbr(:), idisp(:) - integer :: nrow, nglob, ncol, ntaggr, nzac, ip, ndx,& + integer :: nrow, nglob, ncol, ntaggr, ip, ndx,& & naggr, nzl,naggrm1,naggrp1, i, j, k, jd, icolF, nrw integer ::ictxt, np, me, err_act character(len=20) :: name - type(psb_cspmat_type) :: am1,am2, am3, am4 - type(psb_c_coo_sparse_mat) :: acoo, acoof, bcoo + type(psb_cspmat_type) :: am3, am4 + type(psb_c_coo_sparse_mat) :: tmpcoo type(psb_c_csr_sparse_mat) :: acsr1, acsr2, acsr3, acsrf, ptilde complex(psb_spk_), allocatable :: adiag(:) integer(psb_ipk_) :: ierr(5) - logical :: ml_global_nmb, filter_mat + logical :: filter_mat integer :: debug_level, debug_unit integer, parameter :: ncmax=16 real(psb_spk_) :: anorm, omega, tmp, dg, theta @@ -150,34 +138,21 @@ subroutine mld_caggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info) nrow = desc_a%get_local_rows() ncol = desc_a%get_local_cols() - theta = p%parms%aggr_thresh + theta = parms%aggr_thresh naggr = nlaggr(me+1) ntaggr = sum(nlaggr) - allocate(nzbr(np), idisp(np),stat=info) - if (info /= psb_success_) then - info=psb_err_alloc_request_; ierr(1)=2*np; - call psb_errpush(info,name,i_err=ierr,a_err='integer') - goto 9999 - end if - naggrm1 = sum(nlaggr(1:me)) naggrp1 = sum(nlaggr(1:me+1)) - ml_global_nmb = ( (p%parms%aggr_kind == mld_smooth_prol_).or.& - & ( (p%parms%aggr_kind == mld_biz_prol_).and.& - & (p%parms%coarse_mat == mld_repl_mat_)) ) - - filter_mat = (p%parms%aggr_filter == mld_filter_mat_) + filter_mat = (parms%aggr_filter == mld_filter_mat_) - if (ml_global_nmb) then - ilaggr(1:nrow) = ilaggr(1:nrow) + naggrm1 - call psb_halo(ilaggr,desc_a,info) + ilaggr(1:nrow) = ilaggr(1:nrow) + naggrm1 + call psb_halo(ilaggr,desc_a,info) - if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_halo') - goto 9999 - end if + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_halo') + goto 9999 end if ! naggr: number of local aggregates @@ -202,32 +177,22 @@ subroutine mld_caggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info) end if ! 1. Allocate Ptilde in sparse matrix form - if (ml_global_nmb) then - call acoo%allocate(ncol,ntaggr,ncol) - do i=1,ncol - acoo%val(i) = cone - acoo%ia(i) = i - acoo%ja(i) = ilaggr(i) - end do - call acoo%set_nzeros(ncol) - else - call acoo%allocate(ncol,naggr,ncol) - do i=1,nrow - acoo%val(i) = cone - acoo%ia(i) = i - acoo%ja(i) = ilaggr(i) - end do - call acoo%set_nzeros(nrow) - endif - call acoo%set_dupl(psb_dupl_add_) - - call ptilde%mv_from_coo(acoo,info) + call tmpcoo%allocate(ncol,ntaggr,ncol) + do i=1,ncol + tmpcoo%val(i) = cone + tmpcoo%ia(i) = i + tmpcoo%ja(i) = ilaggr(i) + end do + call tmpcoo%set_nzeros(ncol) + call tmpcoo%set_dupl(psb_dupl_add_) + + call ptilde%mv_from_coo(tmpcoo,info) if (info == psb_success_) call a%cscnv(acsr3,info,dupl=psb_dupl_add_) if (debug_level >= psb_debug_outer_) & & write(debug_unit,*) me,' ',trim(name),& & ' Initial copies sone.' - + if (filter_mat) then ! ! Build the filtered matrix Af from A @@ -252,19 +217,19 @@ subroutine mld_caggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info) end if enddo ! Take out zeroed terms - call acsrf%mv_to_coo(acoof,info) + call acsrf%mv_to_coo(tmpcoo,info) k = 0 - do j=1,acoof%get_nzeros() - if ((acoof%val(j) /= czero) .or. (acoof%ia(j) == acoof%ja(j))) then + do j=1,tmpcoo%get_nzeros() + if ((tmpcoo%val(j) /= czero) .or. (tmpcoo%ia(j) == tmpcoo%ja(j))) then k = k + 1 - acoof%val(k) = acoof%val(j) - acoof%ia(k) = acoof%ia(j) - acoof%ja(k) = acoof%ja(j) + tmpcoo%val(k) = tmpcoo%val(j) + tmpcoo%ia(k) = tmpcoo%ia(j) + tmpcoo%ja(k) = tmpcoo%ja(j) end if end do - call acoof%set_nzeros(k) - call acoof%set_dupl(psb_dupl_add_) - call acsrf%mv_from_coo(acoof,info) + call tmpcoo%set_nzeros(k) + call tmpcoo%set_dupl(psb_dupl_add_) + call acsrf%mv_from_coo(tmpcoo,info) end if @@ -281,41 +246,13 @@ subroutine mld_caggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info) if (info /= psb_success_) goto 9999 - if (p%parms%aggr_omega_alg == mld_eig_est_) then - - if (p%parms%aggr_eig == mld_max_norm_) then - - if (p%parms%aggr_kind == mld_biz_prol_) then - - ! - ! This only works with CSR - ! - anorm = szero - dg = sone - nrw = acsr3%get_nrows() - do i=1, nrw - tmp = szero - do j=acsr3%irp(i),acsr3%irp(i+1)-1 - if (acsr3%ja(j) <= nrw) then - tmp = tmp + abs(acsr3%val(j)) - endif - if (acsr3%ja(j) == i ) then - dg = abs(acsr3%val(j)) - end if - end do - anorm = max(anorm,tmp/dg) - enddo - - call psb_amx(ictxt,anorm) - else - anorm = acsr3%csnmi() - endif - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,a_err='Invalid AM3 storage format') - goto 9999 - end if + if (parms%aggr_omega_alg == mld_eig_est_) then + + if (parms%aggr_eig == mld_max_norm_) then + + anorm = acsr3%csnmi() omega = 4.d0/(3.d0*anorm) - p%parms%aggr_omega_val = omega + parms%aggr_omega_val = omega else info = psb_err_internal_error_ @@ -323,11 +260,11 @@ subroutine mld_caggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info) goto 9999 end if - else if (p%parms%aggr_omega_alg == mld_user_choice_) then + else if (parms%aggr_omega_alg == mld_user_choice_) then - omega = p%parms%aggr_omega_val + omega = parms%aggr_omega_val - else if (p%parms%aggr_omega_alg /= mld_user_choice_) then + else if (parms%aggr_omega_alg /= mld_user_choice_) then info = psb_err_internal_error_ call psb_errpush(info,name,a_err='invalid mld_aggr_omega_alg_') goto 9999 @@ -368,7 +305,7 @@ subroutine mld_caggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info) if (debug_level >= psb_debug_outer_) & & write(debug_unit,*) me,' ',trim(name),& & 'Done NUMBMM 1' - + else ! ! Build the smoothed prolongator using the original matrix @@ -409,76 +346,64 @@ subroutine mld_caggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info) call ptilde%free() call acsr1%set_dupl(psb_dupl_add_) - call am1%mv_from(acsr1) - if (ml_global_nmb) then - ! - ! Now we have to gather the halo of am1, and add it to itself - ! to multiply it by A, - ! - call psb_sphalo(am1,desc_a,am4,info,& - & colcnv=.false.,rowscale=.true.) - if (info == psb_success_) call psb_rwextd(ncol,am1,info,b=am4) - if (info == psb_success_) call am4%free() - else - call psb_rwextd(ncol,am1,info) - endif + call op_prol%mv_from(acsr1) + ! + ! Now we have to gather the halo of op_prol, and add it to itself + ! to multiply it by A, + ! + call psb_sphalo(op_prol,desc_a,am4,info,& + & colcnv=.false.,rowscale=.true.) + if (info == psb_success_) call psb_rwextd(ncol,op_prol,info,b=am4) + if (info == psb_success_) call am4%free() if(info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,a_err='Halo of am1') + call psb_errpush(psb_err_internal_error_,name,a_err='Halo of op_prol') goto 9999 end if - call psb_symbmm(a,am1,am3,info) + call psb_symbmm(a,op_prol,am3,info) if(info /= psb_success_) then call psb_errpush(psb_err_from_subroutine_,name,a_err='symbmm 2') goto 9999 end if - call psb_numbmm(a,am1,am3) + call psb_numbmm(a,op_prol,am3) if (debug_level >= psb_debug_outer_) & & write(debug_unit,*) me,' ',trim(name),& - & 'Done NUMBMM 2',p%parms%aggr_kind, mld_smooth_prol_ + & 'Done NUMBMM 2',parms%aggr_kind, mld_smooth_prol_ - if (p%parms%aggr_kind == mld_smooth_prol_) then - call am1%transp(am2) - call am2%mv_to(acoo) - nzl = acoo%get_nzeros() - i=0 - ! - ! Now we have to fix this. The only rows of B that are correct - ! are those corresponding to "local" aggregates, i.e. indices in ilaggr(:) - ! - do k=1, nzl - if ((naggrm1 < acoo%ia(k)) .and.(acoo%ia(k) <= naggrp1)) then - i = i+1 - acoo%val(i) = acoo%val(k) - acoo%ia(i) = acoo%ia(k) - acoo%ja(i) = acoo%ja(k) - end if - end do - call acoo%set_nzeros(i) - call acoo%trim() - call am2%mv_from(acoo) - call am2%cscnv(info,type='csr',dupl=psb_dupl_add_) - if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='spcnv am2') - goto 9999 + call op_prol%transp(op_restr) + call op_restr%mv_to(tmpcoo) + nzl = tmpcoo%get_nzeros() + i=0 + ! + ! Now we have to fix this. The only rows of B that are correct + ! are those corresponding to "local" aggregates, i.e. indices in ilaggr(:) + ! + do k=1, nzl + if ((naggrm1 < tmpcoo%ia(k)) .and.(tmpcoo%ia(k) <= naggrp1)) then + i = i+1 + tmpcoo%val(i) = tmpcoo%val(k) + tmpcoo%ia(i) = tmpcoo%ia(k) + tmpcoo%ja(i) = tmpcoo%ja(k) end if - else - call am1%transp(am2) - endif + end do + call tmpcoo%set_nzeros(i) + call tmpcoo%trim() + call op_restr%mv_from(tmpcoo) + call op_restr%cscnv(info,type='csr',dupl=psb_dupl_add_) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='spcnv op_restr') + goto 9999 + end if if (debug_level >= psb_debug_outer_) & & write(debug_unit,*) me,' ',trim(name),& & 'starting sphalo/ rwxtd' - if (p%parms%aggr_kind == mld_smooth_prol_) then - ! am2 = ((i-wDA)Ptilde)^T - call psb_sphalo(am3,desc_a,am4,info,& - & colcnv=.false.,rowscale=.true.) - if (info == psb_success_) call psb_rwextd(ncol,am3,info,b=am4) - if (info == psb_success_) call am4%free() - else if (p%parms%aggr_kind == mld_biz_prol_) then - call psb_rwextd(ncol,am3,info) - endif + ! op_restr = ((i-wDA)Ptilde)^T + call psb_sphalo(am3,desc_a,am4,info,& + & colcnv=.false.,rowscale=.true.) + if (info == psb_success_) call psb_rwextd(ncol,am3,info,b=am4) + if (info == psb_success_) call am4%free() if(info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,a_err='Extend am3') goto 9999 @@ -488,180 +413,12 @@ subroutine mld_caggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info) if (debug_level >= psb_debug_outer_) & & write(debug_unit,*) me,' ',trim(name),& & 'starting symbmm 3' - call psb_symbmm(am2,am3,b,info) - if (info == psb_success_) call psb_numbmm(am2,am3,b) + call psb_symbmm(op_restr,am3,ac,info) + if (info == psb_success_) call psb_numbmm(op_restr,am3,ac) if (info == psb_success_) call am3%free() - if (info == psb_success_) call b%cscnv(info,type='coo',dupl=psb_dupl_add_) + if (info == psb_success_) call ac%cscnv(info,type='coo',dupl=psb_dupl_add_) if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,a_err='Build b = am2 x am3') - goto 9999 - end if - - - - select case(p%parms%aggr_kind) - - case(mld_smooth_prol_) - - select case(p%parms%coarse_mat) - - case(mld_distr_mat_) - - nzac = b%get_nzeros() - nzl = nzac - call b%mv_to(bcoo) - - if (info == psb_success_) call psb_cdall(ictxt,p%desc_ac,info,nl=nlaggr(me+1)) - if (info == psb_success_) call psb_cdins(nzl,bcoo%ia,bcoo%ja,p%desc_ac,info) - if (info == psb_success_) call psb_cdasb(p%desc_ac,info) - if (info == psb_success_) call psb_glob_to_loc(bcoo%ia(1:nzl),p%desc_ac,info,iact='I') - if (info == psb_success_) call psb_glob_to_loc(bcoo%ja(1:nzl),p%desc_ac,info,iact='I') - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Creating p%desc_ac and converting ac') - goto 9999 - end if - if (debug_level >= psb_debug_outer_) & - & write(debug_unit,*) me,' ',trim(name),& - & 'Assembld aux descr. distr.' - call p%ac%mv_from(bcoo) - - call p%ac%set_nrows(p%desc_ac%get_local_rows()) - call p%ac%set_ncols(p%desc_ac%get_local_cols()) - call p%ac%set_asb() - - if (info == psb_success_) deallocate(nzbr,idisp,stat=info) - if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_sp_free') - goto 9999 - end if - - if (np>1) then - call am1%mv_to(acsr1) - nzl = acsr1%get_nzeros() - call psb_glob_to_loc(acsr1%ja(1:nzl),p%desc_ac,info,'I') - if(info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_glob_to_loc') - goto 9999 - end if - call am1%mv_from(acsr1) - endif - call am1%set_ncols(p%desc_ac%get_local_cols()) - - if (np>1) then - call am2%cscnv(info,type='coo',dupl=psb_dupl_add_) - call am2%mv_to(acoo) - nzl = acoo%get_nzeros() - if (info == psb_success_) call psb_glob_to_loc(acoo%ia(1:nzl),p%desc_ac,info,'I') - call acoo%set_dupl(psb_dupl_add_) - if (info == psb_success_) call am2%mv_from(acoo) - if (info == psb_success_) call am2%cscnv(info,type='csr') - if(info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,a_err='Converting am2 to local') - goto 9999 - end if - end if - call am2%set_nrows(p%desc_ac%get_local_cols()) - - if (debug_level >= psb_debug_outer_) & - & write(debug_unit,*) me,' ',trim(name),& - & 'Done ac ' - - case(mld_repl_mat_) - ! - ! - call psb_cdall(ictxt,p%desc_ac,info,mg=ntaggr,repl=.true.) - if (info == psb_success_) call psb_cdasb(p%desc_ac,info) - if (info == psb_success_) & - & call psb_gather(p%ac,b,p%desc_ac,info,dupl=psb_dupl_add_,keeploc=.false.) - - if (info /= psb_success_) goto 9999 - - deallocate(nzbr,idisp,stat=info) - if (info /= psb_success_) then - info = psb_err_alloc_dealloc_ - call psb_errpush(info,name) - goto 9999 - end if - case default - info = psb_err_internal_error_ - call psb_errpush(info,name,a_err='invalid mld_coarse_mat_') - goto 9999 - end select - - - case(mld_biz_prol_) - - select case(p%parms%coarse_mat) - - case(mld_distr_mat_) - - call psb_move_alloc(b,p%ac,info) - if (info == psb_success_) call psb_cdall(ictxt,p%desc_ac,info,nl=naggr) - if (info == psb_success_) call psb_cdasb(p%desc_ac,info) - if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='Build desc_ac, ac') - goto 9999 - end if - - - case(mld_repl_mat_) - ! - ! - call psb_cdall(ictxt,p%desc_ac,info,mg=ntaggr,repl=.true.) - if (info == psb_success_) call psb_cdasb(p%desc_ac,info) - if(info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_cdall') - goto 9999 - end if - call psb_gather(p%ac,b,p%desc_ac,info,dupl=psb_dupl_add_,keeploc=.false.) - if(info /= psb_success_) goto 9999 - - deallocate(nzbr,idisp,stat=info) - if (info /= psb_success_) then - info = psb_err_alloc_dealloc_ - call psb_errpush(info,name) - goto 9999 - end if - - case default - info = psb_err_internal_error_ - call psb_errpush(info,name,a_err='invalid mld_coarse_mat_') - goto 9999 - end select - - deallocate(nzbr,idisp,stat=info) - if (info /= psb_success_) then - info = psb_err_alloc_dealloc_ - call psb_errpush(info,name) - goto 9999 - end if - - case default - info = psb_err_internal_error_ - call psb_errpush(info,name,a_err='invalid mld_smooth_prol_') - goto 9999 - - end select - - call p%ac%cscnv(info,type='csr',dupl=psb_dupl_add_) - if(info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='spcnv') - goto 9999 - end if - - ! - ! Copy the prolongation/restriction matrices into the descriptor map. - ! am2 => PR^T i.e. restriction operator - ! am1 => PR i.e. prolongation operator - ! - - p%map = psb_linmap(psb_map_aggr_,desc_a,& - & p%desc_ac,am2,am1,ilaggr,nlaggr) - if (info == psb_success_) call am1%free() - if (info == psb_success_) call am2%free() - if(info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='sp_Free') + call psb_errpush(psb_err_internal_error_,name,a_err='Build ac = op_restr x am3') goto 9999 end if diff --git a/mlprec/impl/mld_cmlprec_bld.f90 b/mlprec/impl/mld_cmlprec_bld.f90 index b3d6430a..a2fa21c9 100644 --- a/mlprec/impl/mld_cmlprec_bld.f90 +++ b/mlprec/impl/mld_cmlprec_bld.f90 @@ -93,11 +93,13 @@ subroutine mld_cmlprec_bld(a,desc_a,p,info,amold,vmold) ! Local Variables type(mld_cprec_type) :: t_prec - Integer :: err,i,k,ictxt, me,np, err_act, iszv, newsz + Integer :: err,i,k,ictxt, me,np, err_act, iszv, newsz, casize integer :: ipv(mld_ifpsz_), val integer :: int_err(5) character :: upd_ - type(mld_sml_parms) :: prm + class(mld_c_base_smoother_type), allocatable :: coarse_sm, base_sm, med_sm + type(mld_sml_parms) :: baseparms, medparms, coarseparms + type(mld_c_onelev_node), pointer :: head, tail, newnode, current integer :: debug_level, debug_unit character(len=20) :: name, ch_err @@ -145,12 +147,22 @@ subroutine mld_cmlprec_bld(a,desc_a,p,info,amold,vmold) ! Check to ensure all procs have the same ! newsz = -1 + casize = p%coarse_aggr_size iszv = size(p%precv) call psb_bcast(ictxt,iszv) - if (iszv /= size(p%precv)) then - info=psb_err_internal_error_ - call psb_errpush(info,name,a_err='Inconsistent size of precv') - goto 9999 + call psb_bcast(ictxt,casize) + if (casize > 0) then + if (casize /= p%coarse_aggr_size) then + info=psb_err_internal_error_ + call psb_errpush(info,name,a_err='Inconsistent coarse_aggr_size') + goto 9999 + end if + else + if (iszv /= size(p%precv)) then + info=psb_err_internal_error_ + call psb_errpush(info,name,a_err='Inconsistent size of precv') + goto 9999 + end if end if if (iszv <= 1) then @@ -162,7 +174,161 @@ subroutine mld_cmlprec_bld(a,desc_a,p,info,amold,vmold) endif - if (iszv > 1) then + + if (casize>0) then + ! + ! New strategy to build according to coarse size. + ! + coarseparms = p%precv(iszv)%parms + baseparms = p%precv(1)%parms + medparms = p%precv(2)%parms + + allocate(coarse_sm, source=p%precv(iszv)%sm,stat=info) + if (info == psb_success_) & + & allocate(med_sm, source=p%precv(2)%sm,stat=info) + if (info == psb_success_) & + & allocate(base_sm, source=p%precv(1)%sm,stat=info) + if (info /= psb_success_) then + write(0,*) 'Error in saving smoothers',info + call psb_errpush(psb_err_internal_error_,name,a_err='Base level precbuild.') + goto 9999 + end if + ! + ! Replicated matrix should only ever happen at coarse level. + ! + call mld_check_def(baseparms%coarse_mat,'Coarse matrix',& + & mld_distr_mat_,is_distr_ml_coarse_mat) + ! + ! Now build a doubly linked list + ! + allocate(newnode,stat=info) + if (info /= psb_success_) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='List start'); goto 9999 + end if + head => newnode + tail => newnode + newnode%item%base_a => a + newnode%item%base_desc => desc_a + newnode%item%parms = baseparms + newsz = 1 + current => head + list_build_loop: do + allocate(newnode,stat=info) + if (info /= psb_success_) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='List start'); goto 9999 + end if + current%next => newnode + newnode%prev => current + newsz = newsz + 1 + newnode%item%parms = medparms + newnode%item%parms%aggr_thresh = current%item%parms%aggr_thresh/2 + call mld_coarse_bld(current%item%base_a, current%item%base_desc, & + & newnode%item,info) + if (info /= psb_success_) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='build next level'); goto 9999 + end if + + if (newsz>2) then + if (all(current%item%map%naggr == newnode%item%map%naggr)) then + ! + ! We are not gaining anything + ! + newsz = newsz-1 + current%next => null() + call newnode%item%free(info) + if (info == psb_success_) deallocate(newnode,stat=info) + if (info /= psb_success_) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='Deallocate at list end'); goto 9999 + end if + end if + end if + + current => current%next + tail => current + if (sum(newnode%item%map%naggr) <= casize) then + ! + ! Target reached; but we may need to rebuild. + ! + exit list_build_loop + end if + end do list_build_loop + ! + ! At this point, we are at the list tail, + ! and it needs to be rebuilt in case the parms were + ! different. + ! + ! But the threshold has to be fixed before rebuliding + coarseparms%aggr_thresh = current%item%parms%aggr_thresh + current%item%parms = coarseparms + call mld_coarse_bld(current%prev%item%base_a,& + & current%prev%item%base_desc, & + & current%item,info) + if (info /= psb_success_) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='build next level'); goto 9999 + end if + + ! + ! Ok, now allocate the output vector and fix items. + ! + do i=1,iszv + if (info == psb_success_) call p%precv(i)%free(info) + end do + if (info == psb_success_) deallocate(p%precv,stat=info) + if (info == psb_success_) allocate(p%precv(newsz),stat=info) + if (info /= psb_success_) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='Reallocate precv'); goto 9999 + end if + newnode => head + do i=1, newsz + current => newnode + if (info == psb_success_) & + & call mld_move_alloc(current%item,p%precv(i),info) + if (info == psb_success_) then + if (i ==1) then + allocate(p%precv(i)%sm,source=base_sm,stat=info) + else if (i < newsz) then + allocate(p%precv(i)%sm,source=med_sm,stat=info) + else + allocate(p%precv(i)%sm,source=coarse_sm,stat=info) + end if + end if + if (info /= psb_success_) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='list cpy'); goto 9999 + end if + if (i == 1) then + p%precv(i)%base_a => a + p%precv(i)%base_desc => desc_a + else + p%precv(i)%base_a => p%precv(i)%ac + p%precv(i)%base_desc => p%precv(i)%desc_ac + p%precv(i)%map%p_desc_X => p%precv(i-1)%base_desc + p%precv(i)%map%p_desc_Y => p%precv(i)%base_desc + end if + + newnode => current%next + deallocate(current) + end do + call base_sm%free(info) + if (info == psb_success_) call med_sm%free(info) + if (info == psb_success_) call coarse_sm%free(info) + if (info == psb_success_) deallocate(coarse_sm,med_sm,base_sm,stat=info) + if (info /= psb_success_) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='final cleanup'); goto 9999 + end if + iszv = newsz + + else + ! + ! Default, oldstyle + ! ! ! Build the matrix and the transfer operators corresponding @@ -179,11 +345,6 @@ subroutine mld_cmlprec_bld(a,desc_a,p,info,amold,vmold) p%precv(1)%base_a => a p%precv(1)%base_desc => desc_a - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,a_err='Base level precbuild.') - goto 9999 - end if - do i=2, iszv ! @@ -201,11 +362,6 @@ subroutine mld_cmlprec_bld(a,desc_a,p,info,amold,vmold) ! call mld_check_def(p%precv(i)%parms%coarse_mat,'Coarse matrix',& & mld_distr_mat_,is_distr_ml_coarse_mat) - - else if (i == iszv) then - -!!$ call check_coarse_lev(p%precv(i)) - end if if (debug_level >= psb_debug_outer_) & @@ -277,9 +433,7 @@ subroutine mld_cmlprec_bld(a,desc_a,p,info,amold,vmold) p%precv(i)%map%p_desc_Y => p%precv(i)%base_desc end do - i = iszv - call check_coarse_lev(p%precv(i)) if (info == psb_success_) call mld_coarse_bld(p%precv(i-1)%base_a,& & p%precv(i-1)%base_desc, p%precv(i),info) if (info /= psb_success_) then @@ -289,6 +443,12 @@ subroutine mld_cmlprec_bld(a,desc_a,p,info,amold,vmold) end if end if + ! + ! The coarse space hierarchy has been build. + ! + ! Now do the preconditioner build. + ! + do i=1, iszv ! ! build the base preconditioner at level i @@ -316,10 +476,6 @@ subroutine mld_cmlprec_bld(a,desc_a,p,info,amold,vmold) goto 9999 end if - - ! - ! Test version for beginning of OO stuff. - ! call p%precv(i)%sm%build(p%precv(i)%base_a,p%precv(i)%base_desc,& & 'F',info,amold=amold,vmold=vmold) @@ -350,69 +506,4 @@ subroutine mld_cmlprec_bld(a,desc_a,p,info,amold,vmold) end if return -contains - - subroutine check_coarse_lev(prec) - type(mld_c_onelev_type) :: prec - - ! - ! At the coarsest level, check mld_coarse_solve_ - ! -!!$ val = prec%parms%coarse_solve -!!$ select case (val) -!!$ case(mld_jac_) -!!$ -!!$ if (prec%prec%iprcparm(mld_sub_solve_) /= mld_diag_scale_) then -!!$ if (me == 0) write(debug_unit,*)& -!!$ & 'Warning: inconsistent coarse level specification.' -!!$ if (me == 0) write(debug_unit,*)& -!!$ & ' Resetting according to the value specified for mld_coarse_solve_.' -!!$ prec%prec%iprcparm(mld_sub_solve_) = mld_diag_scale_ -!!$ end if -!!$ prec%prec%iprcparm(mld_smoother_type_) = mld_jac_ -!!$ -!!$ case(mld_bjac_) -!!$ -!!$ if ((prec%prec%iprcparm(mld_sub_solve_) == mld_diag_scale_).or.& -!!$ & ( prec%prec%iprcparm(mld_smoother_type_) /= mld_bjac_)) then -!!$ if (me == 0) write(debug_unit,*)& -!!$ & 'Warning: inconsistent coarse level specification.' -!!$ if (me == 0) write(debug_unit,*)& -!!$ & ' Resetting according to the value specified for mld_coarse_solve_.' -!!$! !$#if defined(HAVE_UMF_) -!!$! !$ prec%prec%iprcparm(mld_sub_solve_) = mld_umf_ -!!$! !$#elif defined(HAVE_SLU_) -!!$! !$ prec%prec%iprcparm(mld_sub_solve_) = mld_slu_ -!!$! !$#else -!!$ prec%prec%iprcparm(mld_sub_solve_) = mld_ilu_n_ -!!$! !$#endif -!!$ end if -!!$ prec%prec%iprcparm(mld_smoother_type_) = mld_bjac_ -!!$ -!!$ case(mld_umf_, mld_slu_) -!!$ if ((prec%iprcparm(mld_coarse_mat_) /= mld_repl_mat_).or.& -!!$ & (prec%prec%iprcparm(mld_sub_solve_) /= val)) then -!!$ if (me == 0) write(debug_unit,*)& -!!$ & 'Warning: inconsistent coarse level specification.' -!!$ if (me == 0) write(debug_unit,*)& -!!$ & ' Resetting according to the value specified for mld_coarse_solve_.' -!!$ prec%iprcparm(mld_coarse_mat_) = mld_repl_mat_ -!!$ prec%prec%iprcparm(mld_sub_solve_) = val -!!$ prec%prec%iprcparm(mld_smoother_type_) = mld_bjac_ -!!$ end if -!!$ case(mld_sludist_) -!!$ if ((prec%iprcparm(mld_coarse_mat_) /= mld_distr_mat_).or.& -!!$ & (prec%prec%iprcparm(mld_sub_solve_) /= val)) then -!!$ if (me == 0) write(debug_unit,*)& -!!$ & 'Warning: inconsistent coarse level specification.' -!!$ if (me == 0) write(debug_unit,*)& -!!$ & ' Resetting according to the value specified for mld_coarse_solve_.' -!!$ prec%iprcparm(mld_coarse_mat_) = mld_distr_mat_ -!!$ prec%prec%iprcparm(mld_sub_solve_) = val -!!$ prec%prec%iprcparm(mld_smoother_type_) = mld_bjac_ -!!$ prec%prec%iprcparm(mld_smoother_sweeps_) = 1 -!!$ end if -!!$ end select - end subroutine check_coarse_lev - end subroutine mld_cmlprec_bld diff --git a/mlprec/impl/mld_cprecinit.F90 b/mlprec/impl/mld_cprecinit.F90 index 2890a83f..e486f6ba 100644 --- a/mlprec/impl/mld_cprecinit.F90 +++ b/mlprec/impl/mld_cprecinit.F90 @@ -125,6 +125,7 @@ subroutine mld_cprecinit(p,ptype,info,nlev) ! Do we want to do something? endif endif + p%coarse_aggr_size = -1 select case(psb_toupper(ptype(1:len_trim(ptype)))) case ('NOPREC','NONE') diff --git a/mlprec/impl/mld_cprecset.F90 b/mlprec/impl/mld_cprecset.F90 index 167f6bc4..3d11fad2 100644 --- a/mlprec/impl/mld_cprecset.F90 +++ b/mlprec/impl/mld_cprecset.F90 @@ -129,6 +129,11 @@ subroutine mld_cprecseti(p,what,val,info,ilev) return endif + if (what == mld_coarse_aggr_size_) then + p%coarse_aggr_size = max(val,-1) + return + end if + ! ! Set preconditioner parameters at level ilev. ! diff --git a/mlprec/impl/mld_d_onelev_impl.f90 b/mlprec/impl/mld_d_onelev_impl.f90 index 46d0ccab..c83ff1de 100644 --- a/mlprec/impl/mld_d_onelev_impl.f90 +++ b/mlprec/impl/mld_d_onelev_impl.f90 @@ -154,7 +154,7 @@ subroutine mld_d_base_onelev_free(lv,info) & call lv%sm%free(info) call lv%ac%free() - if (psb_is_ok_desc(lv%desc_ac)) & + if (lv%desc_ac%is_ok()) & & call psb_cdfree(lv%desc_ac,info) call lv%map%free(info) diff --git a/mlprec/impl/mld_daggrmap_bld.f90 b/mlprec/impl/mld_daggrmap_bld.f90 index dc049b6e..086bd6f9 100644 --- a/mlprec/impl/mld_daggrmap_bld.f90 +++ b/mlprec/impl/mld_daggrmap_bld.f90 @@ -133,7 +133,7 @@ subroutine mld_daggrmap_bld(aggr_type,theta,a,desc_a,ilaggr,nlaggr,info) call atmp%set_ncols(nr) if (info == psb_success_) call atrans%free() if (info == psb_success_) call atmp%cscnv(info,type='CSR') - if (info == psb_success_) call mld_dec_map_bld(theta,atmp,desc_a,nlaggr,ilaggr,info) + if (info == psb_success_) call mld_dec_map_bld(theta,atmp,desc_a,nlaggr,ilaggr,info) if (info == psb_success_) call atmp%free() case default diff --git a/mlprec/impl/mld_daggrmat_asb.f90 b/mlprec/impl/mld_daggrmat_asb.f90 index 53df4f98..6dbb942b 100644 --- a/mlprec/impl/mld_daggrmat_asb.f90 +++ b/mlprec/impl/mld_daggrmat_asb.f90 @@ -113,6 +113,11 @@ subroutine mld_daggrmat_asb(a,desc_a,ilaggr,nlaggr,p,info) integer, intent(out) :: info ! Local variables + type(psb_dspmat_type) :: ac, op_prol,op_restr + type(psb_d_coo_sparse_mat) :: acoo, bcoo + type(psb_d_csr_sparse_mat) :: acsr1 + integer :: nzl,ntaggr + integer :: debug_level, debug_unit integer :: ictxt,np,me, err_act character(len=20) :: name @@ -120,6 +125,9 @@ subroutine mld_daggrmat_asb(a,desc_a,ilaggr,nlaggr,p,info) if(psb_get_errstatus().ne.0) return info=psb_success_ call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + ictxt = desc_a%get_context() @@ -128,35 +136,139 @@ subroutine mld_daggrmat_asb(a,desc_a,ilaggr,nlaggr,p,info) select case (p%parms%aggr_kind) case (mld_no_smooth_) - call mld_aggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,p,info) - if(info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='mld_aggrmat_nosmth_asb') + call mld_daggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,& + & p%parms,ac,op_prol,op_restr,info) + + case(mld_smooth_prol_) + + call mld_daggrmat_smth_asb(a,desc_a,ilaggr,nlaggr, & + & p%parms,ac,op_prol,op_restr,info) + + case(mld_biz_prol_) + + call mld_daggrmat_biz_asb(a,desc_a,ilaggr,nlaggr, & + & p%parms,ac,op_prol,op_restr,info) + + case(mld_min_energy_) + + call mld_daggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr, & + & p%parms,ac,op_prol,op_restr,info) + + case default + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='Invalid aggr kind') + goto 9999 + + end select + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='Inner aggrmat asb') + goto 9999 + end if + + + + ntaggr = sum(nlaggr) + + select case(p%parms%coarse_mat) + + case(mld_distr_mat_) + + nzl = ac%get_nzeros() + call ac%mv_to(bcoo) + + if (info == psb_success_) call psb_cdall(ictxt,p%desc_ac,info,nl=nlaggr(me+1)) + if (info == psb_success_) call psb_cdins(nzl,bcoo%ia,bcoo%ja,p%desc_ac,info) + if (info == psb_success_) call psb_cdasb(p%desc_ac,info) + if (info == psb_success_) call psb_glob_to_loc(bcoo%ia(1:nzl),p%desc_ac,info,iact='I') + if (info == psb_success_) call psb_glob_to_loc(bcoo%ja(1:nzl),p%desc_ac,info,iact='I') + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Creating p%desc_ac and converting ac') goto 9999 end if + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & 'Assembld aux descr. distr.' + call p%ac%mv_from(bcoo) - case(mld_smooth_prol_,mld_biz_prol_) + call p%ac%set_nrows(p%desc_ac%get_local_rows()) + call p%ac%set_ncols(p%desc_ac%get_local_cols()) + call p%ac%set_asb() - call mld_aggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info) - if(info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='mld_aggrmat_smth_asb') + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_sp_free') goto 9999 end if - case(mld_min_energy_) + if (np>1) then + call op_prol%mv_to(acsr1) + nzl = acsr1%get_nzeros() + call psb_glob_to_loc(acsr1%ja(1:nzl),p%desc_ac,info,'I') + if(info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_glob_to_loc') + goto 9999 + end if + call op_prol%mv_from(acsr1) + endif + call op_prol%set_ncols(p%desc_ac%get_local_cols()) - call mld_aggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info) - if(info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='mld_aggrmat_smth_asb') - goto 9999 + if (np>1) then + call op_restr%cscnv(info,type='coo',dupl=psb_dupl_add_) + call op_restr%mv_to(acoo) + nzl = acoo%get_nzeros() + if (info == psb_success_) call psb_glob_to_loc(acoo%ia(1:nzl),p%desc_ac,info,'I') + call acoo%set_dupl(psb_dupl_add_) + if (info == psb_success_) call op_restr%mv_from(acoo) + if (info == psb_success_) call op_restr%cscnv(info,type='csr') + if(info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,a_err='Converting op_restr to local') + goto 9999 + end if end if + call op_restr%set_nrows(p%desc_ac%get_local_cols()) - case default + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & 'Done ac ' - call psb_errpush(psb_err_internal_error_,name,a_err='Invalid aggr kind') - goto 9999 + case(mld_repl_mat_) + ! + ! + call psb_cdall(ictxt,p%desc_ac,info,mg=ntaggr,repl=.true.) + if (info == psb_success_) call psb_cdasb(p%desc_ac,info) + if (info == psb_success_) & + & call psb_gather(p%ac,ac,p%desc_ac,info,dupl=psb_dupl_add_,keeploc=.false.) + + if (info /= psb_success_) goto 9999 + case default + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='invalid mld_coarse_mat_') + goto 9999 end select + call p%ac%cscnv(info,type='csr',dupl=psb_dupl_add_) + if(info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='spcnv') + goto 9999 + end if + + ! + ! Copy the prolongation/restriction matrices into the descriptor map. + ! op_restr => PR^T i.e. restriction operator + ! op_prol => PR i.e. prolongation operator + ! + + p%map = psb_linmap(psb_map_aggr_,desc_a,& + & p%desc_ac,op_restr,op_prol,ilaggr,nlaggr) + if (info == psb_success_) call op_prol%free() + if (info == psb_success_) call op_restr%free() + if(info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='sp_Free') + goto 9999 + end if + + call psb_erractionrestore(err_act) return diff --git a/mlprec/impl/mld_daggrmat_biz_asb.f90 b/mlprec/impl/mld_daggrmat_biz_asb.f90 new file mode 100644 index 00000000..21ca67b6 --- /dev/null +++ b/mlprec/impl/mld_daggrmat_biz_asb.f90 @@ -0,0 +1,422 @@ +!!$ +!!$ +!!$ MLD2P4 version 2.0 +!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package +!!$ based on PSBLAS (Parallel Sparse BLAS version 3.0) +!!$ +!!$ (C) Copyright 2008,2009,2010 +!!$ +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari CNRS-IRIT, Toulouse +!!$ Pasqua D'Ambra ICAR-CNR, Naples +!!$ Daniela di Serafino Second University of Naples +!!$ +!!$ Redistribution and use in source and binary forms, with or without +!!$ modification, are permitted provided that the following conditions +!!$ are met: +!!$ 1. Redistributions of source code must retain the above copyright +!!$ notice, this list of conditions and the following disclaimer. +!!$ 2. Redistributions in binary form must reproduce the above copyright +!!$ notice, this list of conditions, and the following disclaimer in the +!!$ documentation and/or other materials provided with the distribution. +!!$ 3. The name of the MLD2P4 group or the names of its contributors may +!!$ not be used to endorse or promote products derived from this +!!$ software without specific written permission. +!!$ +!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE MLD2P4 GROUP OR ITS CONTRIBUTORS +!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +!!$ POSSIBILITY OF SUCH DAMAGE. +!!$ +!!$ +! File: mld_daggrmat_biz_asb.F90 +! +! Subroutine: mld_daggrmat_biz_asb +! Version: real +! +! This routine builds a coarse-level matrix A_C from a fine-level matrix A +! by using the Galerkin approach, i.e. +! +! A_C = P_C^T A P_C, +! +! where P_C is a prolongator from the coarse level to the fine one. +! +! This routine builds A_C according to a "bizarre" aggregation algorithm, +! using a "naive" prolongator proposed by the authors of MLD2P4. However, this +! prolongator still requires a deep analysis and testing and its use is not +! recommended. +! +! The coarse-level matrix A_C is distributed among the parallel processes or +! replicated on each of them, according to the value of p%parms%coarse_mat, +! specified by the user through mld_dprecinit and mld_zprecset. +! +! Arguments: +! a - type(psb_dspmat_type), input. +! The sparse matrix structure containing the local part of +! the fine-level matrix. +! desc_a - type(psb_desc_type), input. +! The communication descriptor of the fine-level matrix. +! p - type(mld_d_onelev_type), input/output. +! The 'one-level' data structure that will contain the local +! part of the matrix to be built as well as the information +! concerning the prolongator and its transpose. +! ilaggr - integer, dimension(:), allocatable. +! The mapping between the row indices of the coarse-level +! matrix and the row indices of the fine-level matrix. +! ilaggr(i)=j means that node i in the adjacency graph +! of the fine-level matrix is mapped onto node j in the +! adjacency graph of the coarse-level matrix. +! nlaggr - integer, dimension(:), allocatable. +! nlaggr(i) contains the aggregates held by process i. +! info - integer, output. +! Error code. +! +subroutine mld_daggrmat_biz_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_restr,info) + use psb_base_mod + use mld_d_inner_mod, mld_protect_name => mld_daggrmat_biz_asb + + implicit none + + ! Arguments + type(psb_dspmat_type), intent(in) :: a + type(psb_desc_type), intent(in) :: desc_a + integer, intent(inout) :: ilaggr(:), nlaggr(:) + type(mld_dml_parms), intent(inout) :: parms + type(psb_dspmat_type), intent(out) :: ac,op_prol,op_restr + integer, intent(out) :: info + + ! Local variables + integer :: nrow, nglob, ncol, ntaggr, ip, ndx,& + & naggr, nzl,naggrm1,naggrp1, i, j, k, jd, icolF, nrw + integer ::ictxt, np, me, err_act + character(len=20) :: name + type(psb_dspmat_type) :: am3, am4 + type(psb_d_coo_sparse_mat) :: tmpcoo + type(psb_d_csr_sparse_mat) :: acsr1, acsr2, acsr3, acsrf, ptilde + real(psb_dpk_), allocatable :: adiag(:) + integer(psb_ipk_) :: ierr(5) + logical :: filter_mat + integer :: debug_level, debug_unit + integer, parameter :: ncmax=16 + real(psb_dpk_) :: anorm, omega, tmp, dg, theta + + name='mld_aggrmat_biz_asb' + if(psb_get_errstatus().ne.0) return + info=psb_success_ + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + ictxt = desc_a%get_context() + ictxt = desc_a%get_context() + + call psb_info(ictxt, me, np) + + nglob = desc_a%get_global_rows() + nrow = desc_a%get_local_rows() + ncol = desc_a%get_local_cols() + + theta = parms%aggr_thresh + + naggr = nlaggr(me+1) + ntaggr = sum(nlaggr) + + naggrm1 = sum(nlaggr(1:me)) + naggrp1 = sum(nlaggr(1:me+1)) + + filter_mat = (parms%aggr_filter == mld_filter_mat_) + + ilaggr(1:nrow) = ilaggr(1:nrow) + naggrm1 + call psb_halo(ilaggr,desc_a,info) + + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_halo') + goto 9999 + end if + + ! naggr: number of local aggregates + ! nrow: local rows. + ! + allocate(adiag(ncol),stat=info) + + if (info /= psb_success_) then + info=psb_err_alloc_request_; ierr(1)=nrow; + call psb_errpush(info,name,i_err=ierr,a_err='real(psb_dpk_)') + goto 9999 + end if + + ! Get the diagonal D + call a%get_diag(adiag,info) + if (info == psb_success_) & + & call psb_halo(adiag,desc_a,info) + + if(info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='sp_getdiag') + goto 9999 + end if + + ! 1. Allocate Ptilde in sparse matrix form + call tmpcoo%allocate(ncol,naggr,ncol) + do i=1,nrow + tmpcoo%val(i) = done + tmpcoo%ia(i) = i + tmpcoo%ja(i) = ilaggr(i) + end do + call tmpcoo%set_nzeros(nrow) + call tmpcoo%set_dupl(psb_dupl_add_) + + call ptilde%mv_from_coo(tmpcoo,info) + if (info == psb_success_) call a%cscnv(acsr3,info,dupl=psb_dupl_add_) + + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & ' Initial copies sone.' + + if (filter_mat) then + ! + ! Build the filtered matrix Af from A + ! + if (info == psb_success_) call a%cscnv(acsrf,info,dupl=psb_dupl_add_) + + do i=1,nrow + tmp = dzero + jd = -1 + do j=acsrf%irp(i),acsrf%irp(i+1)-1 + if (acsrf%ja(j) == i) jd = j + if (abs(acsrf%val(j)) < theta*sqrt(abs(adiag(i)*adiag(acsrf%ja(j))))) then + tmp=tmp+acsrf%val(j) + acsrf%val(j)=dzero + endif + + enddo + if (jd == -1) then + write(0,*) 'Wrong input: we need the diagonal!!!!', i + else + acsrf%val(jd)=acsrf%val(jd)-tmp + end if + enddo + ! Take out zeroed terms + call acsrf%mv_to_coo(tmpcoo,info) + k = 0 + do j=1,tmpcoo%get_nzeros() + if ((tmpcoo%val(j) /= dzero) .or. (tmpcoo%ia(j) == tmpcoo%ja(j))) then + k = k + 1 + tmpcoo%val(k) = tmpcoo%val(j) + tmpcoo%ia(k) = tmpcoo%ia(j) + tmpcoo%ja(k) = tmpcoo%ja(j) + end if + end do + call tmpcoo%set_nzeros(k) + call tmpcoo%set_dupl(psb_dupl_add_) + call acsrf%mv_from_coo(tmpcoo,info) + end if + + + do i=1,size(adiag) + if (adiag(i) /= dzero) then + adiag(i) = done / adiag(i) + else + adiag(i) = done + end if + end do + + if (filter_mat) call acsrf%scal(adiag,info) + if (info == psb_success_) call acsr3%scal(adiag,info) + if (info /= psb_success_) goto 9999 + + + if (parms%aggr_omega_alg == mld_eig_est_) then + + if (parms%aggr_eig == mld_max_norm_) then + + ! + ! This only works with CSR + ! + anorm = dzero + dg = done + nrw = acsr3%get_nrows() + do i=1, nrw + tmp = dzero + do j=acsr3%irp(i),acsr3%irp(i+1)-1 + if (acsr3%ja(j) <= nrw) then + tmp = tmp + abs(acsr3%val(j)) + endif + if (acsr3%ja(j) == i ) then + dg = abs(acsr3%val(j)) + end if + end do + anorm = max(anorm,tmp/dg) + enddo + + call psb_amx(ictxt,anorm) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,a_err='Invalid AM3 storage format') + goto 9999 + end if + omega = 4.d0/(3.d0*anorm) + parms%aggr_omega_val = omega + + else + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='invalid mld_aggr_eig_') + goto 9999 + end if + + else if (parms%aggr_omega_alg == mld_user_choice_) then + + omega = parms%aggr_omega_val + + else if (parms%aggr_omega_alg /= mld_user_choice_) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='invalid mld_aggr_omega_alg_') + goto 9999 + end if + + if (filter_mat) then + ! + ! Build the smoothed prolongator using the filtered matrix + ! + do i=1,acsrf%get_nrows() + do j=acsrf%irp(i),acsrf%irp(i+1)-1 + if (acsrf%ja(j) == i) then + acsrf%val(j) = done - omega*acsrf%val(j) + else + acsrf%val(j) = - omega*acsrf%val(j) + end if + end do + end do + + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & 'Done gather, going for SYMBMM 1' + ! + ! Symbmm90 does the allocation for its result. + ! + ! acsrm1 = (I-w*D*Af)Ptilde + ! Doing it this way means to consider diag(Af_i) + ! + ! + call psb_symbmm(acsrf,ptilde,acsr1,info) + if(info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='symbmm 1') + goto 9999 + end if + + call psb_numbmm(acsrf,ptilde,acsr1) + + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & 'Done NUMBMM 1' + + else + ! + ! Build the smoothed prolongator using the original matrix + ! + do i=1,acsr3%get_nrows() + do j=acsr3%irp(i),acsr3%irp(i+1)-1 + if (acsr3%ja(j) == i) then + acsr3%val(j) = done - omega*acsr3%val(j) + else + acsr3%val(j) = - omega*acsr3%val(j) + end if + end do + end do + + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & 'Done gather, going for SYMBMM 1' + ! + ! Symbmm90 does the allocation for its result. + ! + ! acsrm1 = (I-w*D*A)Ptilde + ! Doing it this way means to consider diag(A_i) + ! + ! + call psb_symbmm(acsr3,ptilde,acsr1,info) + if(info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='symbmm 1') + goto 9999 + end if + + call psb_numbmm(acsr3,ptilde,acsr1) + + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & 'Done NUMBMM 1' + + end if + call ptilde%free() + call acsr1%set_dupl(psb_dupl_add_) + + call op_prol%mv_from(acsr1) + + call psb_rwextd(ncol,op_prol,info) + if(info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,a_err='Halo of op_prol') + goto 9999 + end if + + call psb_symbmm(a,op_prol,am3,info) + if(info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='symbmm 2') + goto 9999 + end if + + call psb_numbmm(a,op_prol,am3) + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & 'Done NUMBMM 2',parms%aggr_kind, mld_smooth_prol_ + + call op_prol%transp(op_restr) + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & 'starting sphalo/ rwxtd' + + call psb_rwextd(ncol,am3,info) + if(info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,a_err='Extend am3') + goto 9999 + end if + + + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & 'starting symbmm 3' + call psb_symbmm(op_restr,am3,ac,info) + if (info == psb_success_) call psb_numbmm(op_restr,am3,ac) + if (info == psb_success_) call am3%free() + if (info == psb_success_) call ac%cscnv(info,type='coo',dupl=psb_dupl_add_) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,a_err='Build b = op_restr x am3') + goto 9999 + end if + + + + + + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & 'Done smooth_aggregate ' + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_errpush(info,name) + call psb_erractionrestore(err_act) + if (err_act.eq.psb_act_abort_) then + call psb_error() + return + end if + return + + + +end subroutine mld_daggrmat_biz_asb diff --git a/mlprec/impl/mld_daggrmat_minnrg_asb.F90 b/mlprec/impl/mld_daggrmat_minnrg_asb.f90 similarity index 77% rename from mlprec/impl/mld_daggrmat_minnrg_asb.F90 rename to mlprec/impl/mld_daggrmat_minnrg_asb.f90 index 4b04e3bb..89e8e015 100644 --- a/mlprec/impl/mld_daggrmat_minnrg_asb.F90 +++ b/mlprec/impl/mld_daggrmat_minnrg_asb.f90 @@ -98,37 +98,31 @@ ! info - integer, output. ! Error code. ! -subroutine mld_daggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info) +subroutine mld_daggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_restr,info) use psb_base_mod use mld_d_inner_mod, mld_protect_name => mld_daggrmat_minnrg_asb -#ifdef MPI_MOD - use mpi -#endif implicit none -#ifdef MPI_H - include 'mpif.h' -#endif ! Arguments type(psb_dspmat_type), intent(in) :: a type(psb_desc_type), intent(in) :: desc_a integer, intent(inout) :: ilaggr(:), nlaggr(:) - type(mld_d_onelev_type), intent(inout), target :: p + type(mld_dml_parms), intent(inout) :: parms + type(psb_dspmat_type), intent(out) :: ac,op_prol,op_restr integer, intent(out) :: info ! Local variables - type(psb_dspmat_type) :: b integer(psb_mpik_), allocatable :: nzbr(:), idisp(:) integer :: nrow, nglob, ncol, ntaggr, nzac, ip, ndx,& & naggr, nzl,naggrm1,naggrp1, i, j, k, jd, icolF, nrt integer :: ictxt,np,me, err_act, icomm character(len=20) :: name - type(psb_dspmat_type) :: am1,am2, af, ptilde, rtilde, atran, atp, atdatp + type(psb_dspmat_type) :: af, ptilde, rtilde, atran, atp, atdatp type(psb_dspmat_type) :: am3,am4, ap, adap,atmp,rada, ra, atmp2, dap, dadap, da type(psb_dspmat_type) :: dat, datp, datdatp, atmp3 - type(psb_d_coo_sparse_mat) :: acoo, acoof, bcoo, tmpcoo - type(psb_d_csr_sparse_mat) :: acsr1, acsr2, acsr3, bcsr, acsr, acsrf + type(psb_d_coo_sparse_mat) :: tmpcoo + type(psb_d_csr_sparse_mat) :: acsr1, acsr2, acsr3, acsr, acsrf type(psb_d_csc_sparse_mat) :: csc_dap, csc_dadap, csc_datp, csc_datdatp, acsc real(psb_dpk_), allocatable :: adiag(:), adinv(:) real(psb_dpk_), allocatable :: omf(:), omp(:), omi(:), oden(:) @@ -156,7 +150,7 @@ subroutine mld_daggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info) nrow = desc_a%get_local_rows() ncol = desc_a%get_local_cols() - theta = p%parms%aggr_thresh + theta = parms%aggr_thresh naggr = nlaggr(me+1) ntaggr = sum(nlaggr) @@ -171,7 +165,7 @@ subroutine mld_daggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info) naggrm1 = sum(nlaggr(1:me)) naggrp1 = sum(nlaggr(1:me+1)) - filter_mat = (p%parms%aggr_filter == mld_filter_mat_) + filter_mat = (parms%aggr_filter == mld_filter_mat_) ilaggr(1:nrow) = ilaggr(1:nrow) + naggrm1 call psb_halo(ilaggr,desc_a,info) @@ -213,16 +207,16 @@ subroutine mld_daggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info) ! 1. Allocate Ptilde in sparse matrix form - call acoo%allocate(ncol,ntaggr,ncol) + call tmpcoo%allocate(ncol,ntaggr,ncol) do i=1,ncol - acoo%val(i) = done - acoo%ia(i) = i - acoo%ja(i) = ilaggr(i) + tmpcoo%val(i) = done + tmpcoo%ia(i) = i + tmpcoo%ja(i) = ilaggr(i) end do - call acoo%set_nzeros(ncol) - call acoo%set_dupl(psb_dupl_add_) - call acoo%set_asb() - call ptilde%mv_from(acoo) + call tmpcoo%set_nzeros(ncol) + call tmpcoo%set_dupl(psb_dupl_add_) + call tmpcoo%set_asb() + call ptilde%mv_from(tmpcoo) call ptilde%cscnv(info,type='csr') !!$ call local_dump(me,ptilde,'csr-ptilde','Ptilde-1') @@ -280,7 +274,7 @@ subroutine mld_daggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info) call am3%mv_to(acsr3) ! Compute omega_int - ommx = cmplx(szero,szero) + ommx = cmplx(dzero,dzero) do i=1, ncol omi(i) = omp(ilaggr(i)) if(abs(omi(i)) .gt. abs(ommx)) ommx = omi(i) @@ -354,17 +348,17 @@ subroutine mld_daggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info) ! ! Symbmm90 does the allocation for its result. ! - ! am1 = (I-w*D*Af)Ptilde + ! op_prol = (I-w*D*Af)Ptilde ! Doing it this way means to consider diag(Af_i) ! ! - call psb_symbmm(af,ptilde,am1,info) + call psb_symbmm(af,ptilde,op_prol,info) if(info /= psb_success_) then call psb_errpush(psb_err_from_subroutine_,name,a_err='symbmm 1') goto 9999 end if - call psb_numbmm(af,ptilde,am1) + call psb_numbmm(af,ptilde,op_prol) if (debug_level >= psb_debug_outer_) & & write(debug_unit,*) me,' ',trim(name),& @@ -390,16 +384,16 @@ subroutine mld_daggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info) ! ! Symbmm90 does the allocation for its result. ! - ! am1 = (I-w*D*A)Ptilde + ! op_prol = (I-w*D*A)Ptilde ! ! - call psb_symbmm(am3,ptilde,am1,info) + call psb_symbmm(am3,ptilde,op_prol,info) if(info /= psb_success_) then call psb_errpush(psb_err_from_subroutine_,name,a_err='symbmm 1') goto 9999 end if - call psb_numbmm(am3,ptilde,am1) + call psb_numbmm(am3,ptilde,op_prol) if (debug_level >= psb_debug_outer_) & & write(debug_unit,*) me,' ',trim(name),& @@ -458,7 +452,7 @@ subroutine mld_daggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info) omp = omp/oden ! !$ write(0,*) 'Check on output restrictor',omp(1:min(size(omp),10)) ! Compute omega_int - ommx = cmplx(szero,szero) + ommx = cmplx(dzero,dzero) do i=1, ncol omi(i) = omp(ilaggr(i)) if(abs(omi(i)) .gt. abs(ommx)) ommx = omi(i) @@ -509,20 +503,20 @@ subroutine mld_daggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info) call rtilde%mv_from(tmpcoo) call rtilde%cscnv(info,type='csr') - call psb_symbmm(rtilde,atmp,am2,info) - call psb_numbmm(rtilde,atmp,am2) + call psb_symbmm(rtilde,atmp,op_restr,info) + call psb_numbmm(rtilde,atmp,op_restr) ! - ! Now we have to gather the halo of am1, and add it to itself + ! Now we have to gather the halo of op_prol, and add it to itself ! to multiply it by A, ! - call psb_sphalo(am1,desc_a,am4,info,& + call psb_sphalo(op_prol,desc_a,am4,info,& & colcnv=.false.,rowscale=.true.) - if (info == psb_success_) call psb_rwextd(ncol,am1,info,b=am4) + if (info == psb_success_) call psb_rwextd(ncol,op_prol,info,b=am4) if (info == psb_success_) call am4%free() if(info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,a_err='Halo of am1') + call psb_errpush(psb_err_internal_error_,name,a_err='Halo of op_prol') goto 9999 end if @@ -530,7 +524,7 @@ subroutine mld_daggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info) ! Now we have to fix this. The only rows of B that are correct ! are those corresponding to "local" aggregates, i.e. indices in ilaggr(:) ! - call am2%mv_to(tmpcoo) + call op_restr%mv_to(tmpcoo) nzl = tmpcoo%get_nzeros() i=0 @@ -543,21 +537,21 @@ subroutine mld_daggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info) end if end do call tmpcoo%set_nzeros(i) - call am2%mv_from(tmpcoo) - call am2%cscnv(info,type='csr') + call op_restr%mv_from(tmpcoo) + call op_restr%cscnv(info,type='csr') if (debug_level >= psb_debug_outer_) & & write(debug_unit,*) me,' ',trim(name),& & 'starting sphalo/ rwxtd' - call psb_symbmm(a,am1,am3,info) + call psb_symbmm(a,op_prol,am3,info) if(info /= psb_success_) then call psb_errpush(psb_err_from_subroutine_,name,& & a_err='symbmm 2') goto 9999 end if - call psb_numbmm(a,am1,am3) + call psb_numbmm(a,op_prol,am3) if (debug_level >= psb_debug_outer_) & & write(debug_unit,*) me,' ',trim(name),& & 'Done NUMBMM 2' @@ -576,156 +570,18 @@ subroutine mld_daggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info) & write(debug_unit,*) me,' ',trim(name),& & 'Done sphalo/ rwxtd' - call psb_symbmm(am2,am3,b,info) - if (info == psb_success_) call psb_numbmm(am2,am3,b) + call psb_symbmm(op_restr,am3,ac,info) + if (info == psb_success_) call psb_numbmm(op_restr,am3,ac) if (info == psb_success_) call am3%free() - call b%mv_to(bcoo) + if (info == psb_success_) call ac%cscnv(info,type='coo',dupl=psb_dupl_add_) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& - &a_err='Build b = am2 x am3') + &a_err='Build ac = op_restr x am3') goto 9999 end if - if (debug_level >= psb_debug_outer_) & - & write(debug_unit,*) me,' ',trim(name),& - & 'Done mv_to_coo' - - - select case(p%parms%coarse_mat) - - case(mld_distr_mat_) - - nzl = bcoo%get_nzeros() - - if (debug_level >= psb_debug_outer_) & - & write(debug_unit,*) me,' ',trim(name),& - & ' B matrix nzl: ',nzl - - if (info == psb_success_) call psb_cdall(ictxt,p%desc_ac,info,nl=nlaggr(me+1)) - if (info == psb_success_) call psb_cdins(nzl,bcoo%ia,bcoo%ja,p%desc_ac,info) - if (info == psb_success_) call psb_cdasb(p%desc_ac,info) - if (info == psb_success_) call psb_glob_to_loc(bcoo%ia(1:nzl),p%desc_ac,info,iact='I') - if (info == psb_success_) call psb_glob_to_loc(bcoo%ja(1:nzl),p%desc_ac,info,iact='I') - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Creating p%desc_ac and converting ac') - goto 9999 - end if - - if (debug_level >= psb_debug_outer_) & - & write(debug_unit,*) me,' ',trim(name),& - & ' Assembld aux descr. distr.' - - call bcoo%set_nrows(p%desc_ac%get_local_rows()) - call bcoo%set_ncols(p%desc_ac%get_local_cols()) - call bcoo%fix(info) - call p%ac%mv_from(bcoo) - call p%ac%set_asb() - - call p%ac%cscnv(info,type='csr') - - if (np>1) then - call am1%mv_to(acsr) - nzl = acsr%get_nzeros() - call psb_glob_to_loc(acsr%ja(1:nzl),p%desc_ac,info,'I') - if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_glob_to_loc') - goto 9999 - end if - call am1%mv_from(acsr) - endif - call am1%set_ncols(p%desc_ac%get_local_cols()) - - if (np>1) then - call am2%mv_to(tmpcoo) - nzl = tmpcoo%get_nzeros() - if (info == psb_success_) call psb_glob_to_loc(tmpcoo%ia(1:nzl),p%desc_ac,info,'I') - if(info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,a_err='Converting am2 to local') - goto 9999 - end if - call am2%mv_from(tmpcoo) - call am2%cscnv(info,type='csr') - end if - call am2%set_nrows(p%desc_ac%get_local_cols()) - - if (debug_level >= psb_debug_outer_) & - & write(debug_unit,*) me,' ',trim(name),& - & 'Done ac ' - - case(mld_repl_mat_) - ! - ! - call psb_cdall(ictxt,p%desc_ac,info,mg=ntaggr,repl=.true.) - nzbr(:) = 0 - nzbr(me+1) = bcoo%get_nzeros() - - call psb_sum(ictxt,nzbr(1:np)) - nzac = sum(nzbr) - if (info == psb_success_) call tmpcoo%allocate(ntaggr,ntaggr,nzac) - if (info /= psb_success_) goto 9999 - - do ip=1,np - idisp(ip) = sum(nzbr(1:ip-1)) - enddo - ndx = nzbr(me+1) - - call mpi_allgatherv(bcoo%val,ndx,mpi_double_precision,tmpcoo%val,nzbr,idisp,& - & mpi_double_precision,icomm,info) - if (info == psb_success_)& - & call mpi_allgatherv(bcoo%ia,ndx,psb_mpi_ipk_integer,tmpcoo%ia,nzbr,idisp,& - & psb_mpi_ipk_integer,icomm,info) - if (info == psb_success_)& - & call mpi_allgatherv(bcoo%ja,ndx,psb_mpi_ipk_integer,tmpcoo%ja,nzbr,idisp,& - & psb_mpi_ipk_integer,icomm,info) - - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err=' from mpi_allgatherv') - goto 9999 - end if - - call bcoo%free() - call tmpcoo%fix(info) - call p%ac%mv_from(tmpcoo) - call p%ac%cscnv(info,type='csr') - if(info /= psb_success_) goto 9999 - - deallocate(nzbr,idisp,stat=info) - if (info /= psb_success_) then - info = psb_err_alloc_dealloc_ - call psb_errpush(info,name) - goto 9999 - end if - case default - info = psb_err_internal_error_ - call psb_errpush(info,name,a_err='invalid mld_coarse_mat_') - goto 9999 - end select - - - - call p%ac%cscnv(info,type='csr') - if(info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='spcnv') - goto 9999 - end if - - ! - ! Copy the prolongation/restriction matrices into the descriptor map. - ! am2 => R i.e. restriction operator - ! am1 => P i.e. prolongation operator - ! - p%map = psb_linmap(psb_map_aggr_,desc_a,& - & p%desc_ac,am2,am1,ilaggr,nlaggr) - if (info == psb_success_) call am1%free() - if (info == psb_success_) call am2%free() - if(info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='sp_Free') - goto 9999 - end if if (debug_level >= psb_debug_outer_) & & write(debug_unit,*) me,' ',trim(name),& diff --git a/mlprec/impl/mld_daggrmat_nosmth_asb.F90 b/mlprec/impl/mld_daggrmat_nosmth_asb.f90 similarity index 57% rename from mlprec/impl/mld_daggrmat_nosmth_asb.F90 rename to mlprec/impl/mld_daggrmat_nosmth_asb.f90 index 715f3601..32f076f7 100644 --- a/mlprec/impl/mld_daggrmat_nosmth_asb.F90 +++ b/mlprec/impl/mld_daggrmat_nosmth_asb.f90 @@ -81,35 +81,29 @@ ! info - integer, output. ! Error code. ! -subroutine mld_daggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,p,info) +subroutine mld_daggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_restr,info) use psb_base_mod use mld_d_inner_mod, mld_protect_name => mld_daggrmat_nosmth_asb -#ifdef MPI_MOD - use mpi -#endif implicit none -#ifdef MPI_H - include 'mpif.h' -#endif ! Arguments type(psb_dspmat_type), intent(in) :: a type(psb_desc_type), intent(in) :: desc_a integer, intent(inout) :: ilaggr(:), nlaggr(:) - type(mld_d_onelev_type), intent(inout), target :: p + type(mld_dml_parms), intent(inout) :: parms + type(psb_dspmat_type), intent(out) :: ac,op_prol,op_restr integer, intent(out) :: info ! Local variables integer :: ictxt,np,me, err_act integer(psb_mpik_) :: icomm, ndx, minfo character(len=20) :: name - type(psb_dspmat_type) :: b - integer(psb_mpik_), allocatable :: nzbr(:), idisp(:) integer(psb_ipk_) :: ierr(5) - type(psb_dspmat_type) :: am1,am2 - type(psb_d_coo_sparse_mat) :: acoo1, acoo2, bcoo, ac_coo - integer :: nrow, nglob, ncol, ntaggr, nzac, ip, & + type(psb_d_coo_sparse_mat) :: ac_coo, acoo + type(psb_d_csr_sparse_mat) :: acsr1, acsr2 + integer :: debug_level, debug_unit + integer :: nrow, nglob, ncol, ntaggr, nzl, ip, & & naggr, nzt, naggrm1, i name='mld_aggrmat_nosmth_asb' @@ -128,141 +122,48 @@ subroutine mld_daggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,p,info) naggr = nlaggr(me+1) ntaggr = sum(nlaggr) - allocate(nzbr(np), idisp(np),stat=info) - if (info /= psb_success_) then - info=psb_err_alloc_request_; ierr(1)=2*np; - call psb_errpush(info,name,i_err=ierr,a_err='integer') - goto 9999 - end if - naggrm1=sum(nlaggr(1:me)) - if (p%parms%coarse_mat == mld_repl_mat_) then - do i=1, nrow - ilaggr(i) = ilaggr(i) + naggrm1 - end do - call psb_halo(ilaggr,desc_a,info) - end if + do i=1, nrow + ilaggr(i) = ilaggr(i) + naggrm1 + end do + call psb_halo(ilaggr,desc_a,info) if(info /= psb_success_) then call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_halo') goto 9999 end if - if (p%parms%coarse_mat == mld_repl_mat_) then - call acoo1%allocate(ncol,ntaggr,ncol) - else - call acoo1%allocate(ncol,naggr,ncol) - end if + call acoo%allocate(ncol,ntaggr,ncol) do i=1,nrow - acoo1%val(i) = done - acoo1%ia(i) = i - acoo1%ja(i) = ilaggr(i) + acoo%val(i) = done + acoo%ia(i) = i + acoo%ja(i) = ilaggr(i) end do - call acoo1%set_dupl(psb_dupl_add_) - call acoo1%set_nzeros(nrow) - call acoo1%set_asb() - call acoo1%fix(info) - call acoo1%transp(acoo2) + call acoo%set_dupl(psb_dupl_add_) + call acoo%set_nzeros(nrow) + call acoo%set_asb() + call acoo%fix(info) + - call a%csclip(bcoo,info,jmax=nrow) + call op_prol%mv_from(acoo) + call op_prol%cscnv(info,type='csr',dupl=psb_dupl_add_) + if (info == psb_success_) call op_prol%transp(op_restr) + call a%csclip(ac_coo,info,jmax=nrow) - nzt = bcoo%get_nzeros() + nzt = ac_coo%get_nzeros() do i=1, nzt - bcoo%ia(i) = ilaggr(bcoo%ia(i)) - bcoo%ja(i) = ilaggr(bcoo%ja(i)) + ac_coo%ia(i) = ilaggr(ac_coo%ia(i)) + ac_coo%ja(i) = ilaggr(ac_coo%ja(i)) enddo - call bcoo%set_nrows(naggr) - call bcoo%set_ncols(naggr) - call bcoo%set_dupl(psb_dupl_add_) - call bcoo%fix(info) - - - if (p%parms%coarse_mat == mld_repl_mat_) then - - call psb_cdall(ictxt,p%desc_ac,info,mg=ntaggr,repl=.true.) - if (info == psb_success_) call psb_cdasb(p%desc_ac,info) - if(info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_cdall') - goto 9999 - end if - - nzbr(:) = 0 - nzbr(me+1) = nzt - call psb_sum(ictxt,nzbr(1:np)) - nzac = sum(nzbr) - - call ac_coo%allocate(ntaggr,ntaggr,nzac) - - do ip=1,np - idisp(ip) = sum(nzbr(1:ip-1)) - enddo - ndx = nzbr(me+1) - - call mpi_allgatherv(bcoo%val,ndx,mpi_double_precision,ac_coo%val,nzbr,idisp,& - & mpi_double_precision,icomm,minfo) - call mpi_allgatherv(bcoo%ia,ndx,psb_mpi_ipk_integer,ac_coo%ia,nzbr,idisp,& - & psb_mpi_ipk_integer,icomm,minfo) - call mpi_allgatherv(bcoo%ja,ndx,psb_mpi_ipk_integer,ac_coo%ja,nzbr,idisp,& - & psb_mpi_ipk_integer,icomm,minfo) - if(info /= psb_success_) then - info=-1 - call psb_errpush(info,name) - goto 9999 - end if - call ac_coo%set_nzeros(nzac) - call ac_coo%set_dupl(psb_dupl_add_) - call ac_coo%fix(info) - call p%ac%mv_from(ac_coo) - - else if (p%parms%coarse_mat == mld_distr_mat_) then - - call psb_cdall(ictxt,p%desc_ac,info,nl=naggr) - if (info == psb_success_) call psb_cdasb(p%desc_ac,info) - call p%ac%mv_from(bcoo) - if(info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,a_err='Build ac, desc_ac') - goto 9999 - - end if - - else - info = psb_err_internal_error_ - call psb_errpush(psb_err_internal_error_,name,a_err='invalid mld_coarse_mat_') - goto 9999 - end if - - call bcoo%free() - - deallocate(nzbr,idisp) - - call p%ac%cscnv(info,type='csr',dupl=psb_dupl_add_) - if(info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='cscnv') - goto 9999 - end if - - call am1%mv_from(acoo1) - call am1%cscnv(info,type='csr',dupl=psb_dupl_add_) - if (info == psb_success_) call am2%mv_from(acoo2) - if (info == psb_success_) call am2%cscnv(info,type='csr',dupl=psb_dupl_add_) - ! - ! Copy the prolongation/restriction matrices into the descriptor map. - ! am2 => PR^T i.e. restriction operator - ! am1 => PR i.e. prolongation operator - ! - if (info == psb_success_) & - & p%map = psb_linmap(psb_map_aggr_,desc_a,& - & p%desc_ac,am2,am1,ilaggr,nlaggr) - if (info == psb_success_) call am1%free() - if (info == psb_success_) call am2%free() - if(info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='linmap build') - goto 9999 - end if + call ac_coo%set_nrows(naggr) + call ac_coo%set_ncols(naggr) + call ac_coo%set_dupl(psb_dupl_add_) + call ac_coo%fix(info) + call ac%mv_from(ac_coo) call psb_erractionrestore(err_act) diff --git a/mlprec/impl/mld_daggrmat_smth_asb.F90 b/mlprec/impl/mld_daggrmat_smth_asb.f90 similarity index 52% rename from mlprec/impl/mld_daggrmat_smth_asb.F90 rename to mlprec/impl/mld_daggrmat_smth_asb.f90 index fb917201..af616ece 100644 --- a/mlprec/impl/mld_daggrmat_smth_asb.F90 +++ b/mlprec/impl/mld_daggrmat_smth_asb.f90 @@ -61,11 +61,6 @@ ! according to the value of p%parms%aggr_omega_alg, specified by the user ! through mld_dprecinit and mld_zprecset. ! -! This routine can also build A_C according to a "bizarre" aggregation algorithm, -! using a "naive" prolongator proposed by the authors of MLD2P4. However, this -! prolongator still requires a deep analysis and testing and its use is not -! recommended. -! ! The coarse-level matrix A_C is distributed among the parallel processes or ! replicated on each of them, according to the value of p%parms%coarse_mat, ! specified by the user through mld_dprecinit and mld_zprecset. @@ -98,38 +93,31 @@ ! info - integer, output. ! Error code. ! -subroutine mld_daggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info) +subroutine mld_daggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_restr,info) use psb_base_mod use mld_d_inner_mod, mld_protect_name => mld_daggrmat_smth_asb -#ifdef MPI_MOD - use mpi -#endif implicit none -#ifdef MPI_H - include 'mpif.h' -#endif ! Arguments type(psb_dspmat_type), intent(in) :: a type(psb_desc_type), intent(in) :: desc_a integer, intent(inout) :: ilaggr(:), nlaggr(:) - type(mld_d_onelev_type), intent(inout), target :: p + type(mld_dml_parms), intent(inout) :: parms + type(psb_dspmat_type), intent(out) :: ac,op_prol,op_restr integer, intent(out) :: info ! Local variables - type(psb_dspmat_type) :: b - integer, allocatable :: nzbr(:), idisp(:) - integer :: nrow, nglob, ncol, ntaggr, nzac, ip, ndx,& + integer :: nrow, nglob, ncol, ntaggr, ip, ndx,& & naggr, nzl,naggrm1,naggrp1, i, j, k, jd, icolF, nrw integer ::ictxt, np, me, err_act character(len=20) :: name - type(psb_dspmat_type) :: am1,am2, am3, am4 - type(psb_d_coo_sparse_mat) :: acoo, acoof, bcoo + type(psb_dspmat_type) :: am3, am4 + type(psb_d_coo_sparse_mat) :: tmpcoo type(psb_d_csr_sparse_mat) :: acsr1, acsr2, acsr3, acsrf, ptilde real(psb_dpk_), allocatable :: adiag(:) integer(psb_ipk_) :: ierr(5) - logical :: ml_global_nmb, filter_mat + logical :: filter_mat integer :: debug_level, debug_unit integer, parameter :: ncmax=16 real(psb_dpk_) :: anorm, omega, tmp, dg, theta @@ -150,34 +138,21 @@ subroutine mld_daggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info) nrow = desc_a%get_local_rows() ncol = desc_a%get_local_cols() - theta = p%parms%aggr_thresh + theta = parms%aggr_thresh naggr = nlaggr(me+1) ntaggr = sum(nlaggr) - allocate(nzbr(np), idisp(np),stat=info) - if (info /= psb_success_) then - info=psb_err_alloc_request_; ierr(1)=2*np; - call psb_errpush(info,name,i_err=ierr,a_err='integer') - goto 9999 - end if - naggrm1 = sum(nlaggr(1:me)) naggrp1 = sum(nlaggr(1:me+1)) - ml_global_nmb = ( (p%parms%aggr_kind == mld_smooth_prol_).or.& - & ( (p%parms%aggr_kind == mld_biz_prol_).and.& - & (p%parms%coarse_mat == mld_repl_mat_)) ) - - filter_mat = (p%parms%aggr_filter == mld_filter_mat_) + filter_mat = (parms%aggr_filter == mld_filter_mat_) - if (ml_global_nmb) then - ilaggr(1:nrow) = ilaggr(1:nrow) + naggrm1 - call psb_halo(ilaggr,desc_a,info) + ilaggr(1:nrow) = ilaggr(1:nrow) + naggrm1 + call psb_halo(ilaggr,desc_a,info) - if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_halo') - goto 9999 - end if + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_halo') + goto 9999 end if ! naggr: number of local aggregates @@ -202,32 +177,22 @@ subroutine mld_daggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info) end if ! 1. Allocate Ptilde in sparse matrix form - if (ml_global_nmb) then - call acoo%allocate(ncol,ntaggr,ncol) - do i=1,ncol - acoo%val(i) = done - acoo%ia(i) = i - acoo%ja(i) = ilaggr(i) - end do - call acoo%set_nzeros(ncol) - else - call acoo%allocate(ncol,naggr,ncol) - do i=1,nrow - acoo%val(i) = done - acoo%ia(i) = i - acoo%ja(i) = ilaggr(i) - end do - call acoo%set_nzeros(nrow) - endif - call acoo%set_dupl(psb_dupl_add_) - - call ptilde%mv_from_coo(acoo,info) + call tmpcoo%allocate(ncol,ntaggr,ncol) + do i=1,ncol + tmpcoo%val(i) = done + tmpcoo%ia(i) = i + tmpcoo%ja(i) = ilaggr(i) + end do + call tmpcoo%set_nzeros(ncol) + call tmpcoo%set_dupl(psb_dupl_add_) + + call ptilde%mv_from_coo(tmpcoo,info) if (info == psb_success_) call a%cscnv(acsr3,info,dupl=psb_dupl_add_) if (debug_level >= psb_debug_outer_) & & write(debug_unit,*) me,' ',trim(name),& & ' Initial copies sone.' - + if (filter_mat) then ! ! Build the filtered matrix Af from A @@ -252,19 +217,19 @@ subroutine mld_daggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info) end if enddo ! Take out zeroed terms - call acsrf%mv_to_coo(acoof,info) + call acsrf%mv_to_coo(tmpcoo,info) k = 0 - do j=1,acoof%get_nzeros() - if ((acoof%val(j) /= dzero) .or. (acoof%ia(j) == acoof%ja(j))) then + do j=1,tmpcoo%get_nzeros() + if ((tmpcoo%val(j) /= dzero) .or. (tmpcoo%ia(j) == tmpcoo%ja(j))) then k = k + 1 - acoof%val(k) = acoof%val(j) - acoof%ia(k) = acoof%ia(j) - acoof%ja(k) = acoof%ja(j) + tmpcoo%val(k) = tmpcoo%val(j) + tmpcoo%ia(k) = tmpcoo%ia(j) + tmpcoo%ja(k) = tmpcoo%ja(j) end if end do - call acoof%set_nzeros(k) - call acoof%set_dupl(psb_dupl_add_) - call acsrf%mv_from_coo(acoof,info) + call tmpcoo%set_nzeros(k) + call tmpcoo%set_dupl(psb_dupl_add_) + call acsrf%mv_from_coo(tmpcoo,info) end if @@ -281,41 +246,13 @@ subroutine mld_daggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info) if (info /= psb_success_) goto 9999 - if (p%parms%aggr_omega_alg == mld_eig_est_) then - - if (p%parms%aggr_eig == mld_max_norm_) then - - if (p%parms%aggr_kind == mld_biz_prol_) then - - ! - ! This only works with CSR - ! - anorm = dzero - dg = done - nrw = acsr3%get_nrows() - do i=1, nrw - tmp = szero - do j=acsr3%irp(i),acsr3%irp(i+1)-1 - if (acsr3%ja(j) <= nrw) then - tmp = tmp + abs(acsr3%val(j)) - endif - if (acsr3%ja(j) == i ) then - dg = abs(acsr3%val(j)) - end if - end do - anorm = max(anorm,tmp/dg) - enddo - - call psb_amx(ictxt,anorm) - else - anorm = acsr3%csnmi() - endif - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,a_err='Invalid AM3 storage format') - goto 9999 - end if + if (parms%aggr_omega_alg == mld_eig_est_) then + + if (parms%aggr_eig == mld_max_norm_) then + + anorm = acsr3%csnmi() omega = 4.d0/(3.d0*anorm) - p%parms%aggr_omega_val = omega + parms%aggr_omega_val = omega else info = psb_err_internal_error_ @@ -323,11 +260,11 @@ subroutine mld_daggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info) goto 9999 end if - else if (p%parms%aggr_omega_alg == mld_user_choice_) then + else if (parms%aggr_omega_alg == mld_user_choice_) then - omega = p%parms%aggr_omega_val + omega = parms%aggr_omega_val - else if (p%parms%aggr_omega_alg /= mld_user_choice_) then + else if (parms%aggr_omega_alg /= mld_user_choice_) then info = psb_err_internal_error_ call psb_errpush(info,name,a_err='invalid mld_aggr_omega_alg_') goto 9999 @@ -368,7 +305,7 @@ subroutine mld_daggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info) if (debug_level >= psb_debug_outer_) & & write(debug_unit,*) me,' ',trim(name),& & 'Done NUMBMM 1' - + else ! ! Build the smoothed prolongator using the original matrix @@ -409,76 +346,64 @@ subroutine mld_daggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info) call ptilde%free() call acsr1%set_dupl(psb_dupl_add_) - call am1%mv_from(acsr1) - if (ml_global_nmb) then - ! - ! Now we have to gather the halo of am1, and add it to itself - ! to multiply it by A, - ! - call psb_sphalo(am1,desc_a,am4,info,& - & colcnv=.false.,rowscale=.true.) - if (info == psb_success_) call psb_rwextd(ncol,am1,info,b=am4) - if (info == psb_success_) call am4%free() - else - call psb_rwextd(ncol,am1,info) - endif + call op_prol%mv_from(acsr1) + ! + ! Now we have to gather the halo of op_prol, and add it to itself + ! to multiply it by A, + ! + call psb_sphalo(op_prol,desc_a,am4,info,& + & colcnv=.false.,rowscale=.true.) + if (info == psb_success_) call psb_rwextd(ncol,op_prol,info,b=am4) + if (info == psb_success_) call am4%free() if(info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,a_err='Halo of am1') + call psb_errpush(psb_err_internal_error_,name,a_err='Halo of op_prol') goto 9999 end if - call psb_symbmm(a,am1,am3,info) + call psb_symbmm(a,op_prol,am3,info) if(info /= psb_success_) then call psb_errpush(psb_err_from_subroutine_,name,a_err='symbmm 2') goto 9999 end if - call psb_numbmm(a,am1,am3) + call psb_numbmm(a,op_prol,am3) if (debug_level >= psb_debug_outer_) & & write(debug_unit,*) me,' ',trim(name),& - & 'Done NUMBMM 2',p%parms%aggr_kind, mld_smooth_prol_ + & 'Done NUMBMM 2',parms%aggr_kind, mld_smooth_prol_ - if (p%parms%aggr_kind == mld_smooth_prol_) then - call am1%transp(am2) - call am2%mv_to(acoo) - nzl = acoo%get_nzeros() - i=0 - ! - ! Now we have to fix this. The only rows of B that are correct - ! are those corresponding to "local" aggregates, i.e. indices in ilaggr(:) - ! - do k=1, nzl - if ((naggrm1 < acoo%ia(k)) .and.(acoo%ia(k) <= naggrp1)) then - i = i+1 - acoo%val(i) = acoo%val(k) - acoo%ia(i) = acoo%ia(k) - acoo%ja(i) = acoo%ja(k) - end if - end do - call acoo%set_nzeros(i) - call acoo%trim() - call am2%mv_from(acoo) - call am2%cscnv(info,type='csr',dupl=psb_dupl_add_) - if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='spcnv am2') - goto 9999 + call op_prol%transp(op_restr) + call op_restr%mv_to(tmpcoo) + nzl = tmpcoo%get_nzeros() + i=0 + ! + ! Now we have to fix this. The only rows of B that are correct + ! are those corresponding to "local" aggregates, i.e. indices in ilaggr(:) + ! + do k=1, nzl + if ((naggrm1 < tmpcoo%ia(k)) .and.(tmpcoo%ia(k) <= naggrp1)) then + i = i+1 + tmpcoo%val(i) = tmpcoo%val(k) + tmpcoo%ia(i) = tmpcoo%ia(k) + tmpcoo%ja(i) = tmpcoo%ja(k) end if - else - call am1%transp(am2) - endif + end do + call tmpcoo%set_nzeros(i) + call tmpcoo%trim() + call op_restr%mv_from(tmpcoo) + call op_restr%cscnv(info,type='csr',dupl=psb_dupl_add_) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='spcnv op_restr') + goto 9999 + end if if (debug_level >= psb_debug_outer_) & & write(debug_unit,*) me,' ',trim(name),& & 'starting sphalo/ rwxtd' - if (p%parms%aggr_kind == mld_smooth_prol_) then - ! am2 = ((i-wDA)Ptilde)^T - call psb_sphalo(am3,desc_a,am4,info,& - & colcnv=.false.,rowscale=.true.) - if (info == psb_success_) call psb_rwextd(ncol,am3,info,b=am4) - if (info == psb_success_) call am4%free() - else if (p%parms%aggr_kind == mld_biz_prol_) then - call psb_rwextd(ncol,am3,info) - endif + ! op_restr = ((i-wDA)Ptilde)^T + call psb_sphalo(am3,desc_a,am4,info,& + & colcnv=.false.,rowscale=.true.) + if (info == psb_success_) call psb_rwextd(ncol,am3,info,b=am4) + if (info == psb_success_) call am4%free() if(info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,a_err='Extend am3') goto 9999 @@ -488,180 +413,12 @@ subroutine mld_daggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info) if (debug_level >= psb_debug_outer_) & & write(debug_unit,*) me,' ',trim(name),& & 'starting symbmm 3' - call psb_symbmm(am2,am3,b,info) - if (info == psb_success_) call psb_numbmm(am2,am3,b) + call psb_symbmm(op_restr,am3,ac,info) + if (info == psb_success_) call psb_numbmm(op_restr,am3,ac) if (info == psb_success_) call am3%free() - if (info == psb_success_) call b%cscnv(info,type='coo',dupl=psb_dupl_add_) + if (info == psb_success_) call ac%cscnv(info,type='coo',dupl=psb_dupl_add_) if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,a_err='Build b = am2 x am3') - goto 9999 - end if - - - - select case(p%parms%aggr_kind) - - case(mld_smooth_prol_) - - select case(p%parms%coarse_mat) - - case(mld_distr_mat_) - - nzac = b%get_nzeros() - nzl = nzac - call b%mv_to(bcoo) - - if (info == psb_success_) call psb_cdall(ictxt,p%desc_ac,info,nl=nlaggr(me+1)) - if (info == psb_success_) call psb_cdins(nzl,bcoo%ia,bcoo%ja,p%desc_ac,info) - if (info == psb_success_) call psb_cdasb(p%desc_ac,info) - if (info == psb_success_) call psb_glob_to_loc(bcoo%ia(1:nzl),p%desc_ac,info,iact='I') - if (info == psb_success_) call psb_glob_to_loc(bcoo%ja(1:nzl),p%desc_ac,info,iact='I') - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Creating p%desc_ac and converting ac') - goto 9999 - end if - if (debug_level >= psb_debug_outer_) & - & write(debug_unit,*) me,' ',trim(name),& - & 'Assembld aux descr. distr.' - call p%ac%mv_from(bcoo) - - call p%ac%set_nrows(p%desc_ac%get_local_rows()) - call p%ac%set_ncols(p%desc_ac%get_local_cols()) - call p%ac%set_asb() - - if (info == psb_success_) deallocate(nzbr,idisp,stat=info) - if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_sp_free') - goto 9999 - end if - - if (np>1) then - call am1%mv_to(acsr1) - nzl = acsr1%get_nzeros() - call psb_glob_to_loc(acsr1%ja(1:nzl),p%desc_ac,info,'I') - if(info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_glob_to_loc') - goto 9999 - end if - call am1%mv_from(acsr1) - endif - call am1%set_ncols(p%desc_ac%get_local_cols()) - - if (np>1) then - call am2%cscnv(info,type='coo',dupl=psb_dupl_add_) - call am2%mv_to(acoo) - nzl = acoo%get_nzeros() - if (info == psb_success_) call psb_glob_to_loc(acoo%ia(1:nzl),p%desc_ac,info,'I') - call acoo%set_dupl(psb_dupl_add_) - if (info == psb_success_) call am2%mv_from(acoo) - if (info == psb_success_) call am2%cscnv(info,type='csr') - if(info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,a_err='Converting am2 to local') - goto 9999 - end if - end if - call am2%set_nrows(p%desc_ac%get_local_cols()) - - if (debug_level >= psb_debug_outer_) & - & write(debug_unit,*) me,' ',trim(name),& - & 'Done ac ' - - case(mld_repl_mat_) - ! - ! - call psb_cdall(ictxt,p%desc_ac,info,mg=ntaggr,repl=.true.) - if (info == psb_success_) call psb_cdasb(p%desc_ac,info) - if (info == psb_success_) & - & call psb_gather(p%ac,b,p%desc_ac,info,dupl=psb_dupl_add_,keeploc=.false.) - - if (info /= psb_success_) goto 9999 - - deallocate(nzbr,idisp,stat=info) - if (info /= psb_success_) then - info = psb_err_alloc_dealloc_ - call psb_errpush(info,name) - goto 9999 - end if - case default - info = psb_err_internal_error_ - call psb_errpush(info,name,a_err='invalid mld_coarse_mat_') - goto 9999 - end select - - - case(mld_biz_prol_) - - select case(p%parms%coarse_mat) - - case(mld_distr_mat_) - - call psb_move_alloc(b,p%ac,info) - if (info == psb_success_) call psb_cdall(ictxt,p%desc_ac,info,nl=naggr) - if (info == psb_success_) call psb_cdasb(p%desc_ac,info) - if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='Build desc_ac, ac') - goto 9999 - end if - - - case(mld_repl_mat_) - ! - ! - call psb_cdall(ictxt,p%desc_ac,info,mg=ntaggr,repl=.true.) - if (info == psb_success_) call psb_cdasb(p%desc_ac,info) - if(info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_cdall') - goto 9999 - end if - call psb_gather(p%ac,b,p%desc_ac,info,dupl=psb_dupl_add_,keeploc=.false.) - if(info /= psb_success_) goto 9999 - - deallocate(nzbr,idisp,stat=info) - if (info /= psb_success_) then - info = psb_err_alloc_dealloc_ - call psb_errpush(info,name) - goto 9999 - end if - - case default - info = psb_err_internal_error_ - call psb_errpush(info,name,a_err='invalid mld_coarse_mat_') - goto 9999 - end select - - deallocate(nzbr,idisp,stat=info) - if (info /= psb_success_) then - info = psb_err_alloc_dealloc_ - call psb_errpush(info,name) - goto 9999 - end if - - case default - info = psb_err_internal_error_ - call psb_errpush(info,name,a_err='invalid mld_smooth_prol_') - goto 9999 - - end select - - call p%ac%cscnv(info,type='csr',dupl=psb_dupl_add_) - if(info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='spcnv') - goto 9999 - end if - - ! - ! Copy the prolongation/restriction matrices into the descriptor map. - ! am2 => PR^T i.e. restriction operator - ! am1 => PR i.e. prolongation operator - ! - - p%map = psb_linmap(psb_map_aggr_,desc_a,& - & p%desc_ac,am2,am1,ilaggr,nlaggr) - if (info == psb_success_) call am1%free() - if (info == psb_success_) call am2%free() - if(info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='sp_Free') + call psb_errpush(psb_err_internal_error_,name,a_err='Build ac = op_restr x am3') goto 9999 end if diff --git a/mlprec/impl/mld_dmlprec_bld.f90 b/mlprec/impl/mld_dmlprec_bld.f90 index 0051fe69..94481c66 100644 --- a/mlprec/impl/mld_dmlprec_bld.f90 +++ b/mlprec/impl/mld_dmlprec_bld.f90 @@ -93,11 +93,13 @@ subroutine mld_dmlprec_bld(a,desc_a,p,info,amold,vmold) ! Local Variables type(mld_dprec_type) :: t_prec - Integer :: err,i,k,ictxt, me,np, err_act, iszv, newsz + Integer :: err,i,k,ictxt, me,np, err_act, iszv, newsz, casize integer :: ipv(mld_ifpsz_), val integer :: int_err(5) character :: upd_ - type(mld_dml_parms) :: prm + class(mld_d_base_smoother_type), allocatable :: coarse_sm, base_sm, med_sm + type(mld_dml_parms) :: baseparms, medparms, coarseparms + type(mld_d_onelev_node), pointer :: head, tail, newnode, current integer :: debug_level, debug_unit character(len=20) :: name, ch_err @@ -145,12 +147,22 @@ subroutine mld_dmlprec_bld(a,desc_a,p,info,amold,vmold) ! Check to ensure all procs have the same ! newsz = -1 + casize = p%coarse_aggr_size iszv = size(p%precv) call psb_bcast(ictxt,iszv) - if (iszv /= size(p%precv)) then - info=psb_err_internal_error_ - call psb_errpush(info,name,a_err='Inconsistent size of precv') - goto 9999 + call psb_bcast(ictxt,casize) + if (casize > 0) then + if (casize /= p%coarse_aggr_size) then + info=psb_err_internal_error_ + call psb_errpush(info,name,a_err='Inconsistent coarse_aggr_size') + goto 9999 + end if + else + if (iszv /= size(p%precv)) then + info=psb_err_internal_error_ + call psb_errpush(info,name,a_err='Inconsistent size of precv') + goto 9999 + end if end if if (iszv <= 1) then @@ -162,7 +174,161 @@ subroutine mld_dmlprec_bld(a,desc_a,p,info,amold,vmold) endif - if (iszv > 1) then + + if (casize>0) then + ! + ! New strategy to build according to coarse size. + ! + coarseparms = p%precv(iszv)%parms + baseparms = p%precv(1)%parms + medparms = p%precv(2)%parms + + allocate(coarse_sm, source=p%precv(iszv)%sm,stat=info) + if (info == psb_success_) & + & allocate(med_sm, source=p%precv(2)%sm,stat=info) + if (info == psb_success_) & + & allocate(base_sm, source=p%precv(1)%sm,stat=info) + if (info /= psb_success_) then + write(0,*) 'Error in saving smoothers',info + call psb_errpush(psb_err_internal_error_,name,a_err='Base level precbuild.') + goto 9999 + end if + ! + ! Replicated matrix should only ever happen at coarse level. + ! + call mld_check_def(baseparms%coarse_mat,'Coarse matrix',& + & mld_distr_mat_,is_distr_ml_coarse_mat) + ! + ! Now build a doubly linked list + ! + allocate(newnode,stat=info) + if (info /= psb_success_) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='List start'); goto 9999 + end if + head => newnode + tail => newnode + newnode%item%base_a => a + newnode%item%base_desc => desc_a + newnode%item%parms = baseparms + newsz = 1 + current => head + list_build_loop: do + allocate(newnode,stat=info) + if (info /= psb_success_) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='List start'); goto 9999 + end if + current%next => newnode + newnode%prev => current + newsz = newsz + 1 + newnode%item%parms = medparms + newnode%item%parms%aggr_thresh = current%item%parms%aggr_thresh/2 + call mld_coarse_bld(current%item%base_a, current%item%base_desc, & + & newnode%item,info) + if (info /= psb_success_) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='build next level'); goto 9999 + end if + + if (newsz>2) then + if (all(current%item%map%naggr == newnode%item%map%naggr)) then + ! + ! We are not gaining anything + ! + newsz = newsz-1 + current%next => null() + call newnode%item%free(info) + if (info == psb_success_) deallocate(newnode,stat=info) + if (info /= psb_success_) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='Deallocate at list end'); goto 9999 + end if + end if + end if + + current => current%next + tail => current + if (sum(newnode%item%map%naggr) <= casize) then + ! + ! Target reached; but we may need to rebuild. + ! + exit list_build_loop + end if + end do list_build_loop + ! + ! At this point, we are at the list tail, + ! and it needs to be rebuilt in case the parms were + ! different. + ! + ! But the threshold has to be fixed before rebuliding + coarseparms%aggr_thresh = current%item%parms%aggr_thresh + current%item%parms = coarseparms + call mld_coarse_bld(current%prev%item%base_a,& + & current%prev%item%base_desc, & + & current%item,info) + if (info /= psb_success_) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='build next level'); goto 9999 + end if + + ! + ! Ok, now allocate the output vector and fix items. + ! + do i=1,iszv + if (info == psb_success_) call p%precv(i)%free(info) + end do + if (info == psb_success_) deallocate(p%precv,stat=info) + if (info == psb_success_) allocate(p%precv(newsz),stat=info) + if (info /= psb_success_) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='Reallocate precv'); goto 9999 + end if + newnode => head + do i=1, newsz + current => newnode + if (info == psb_success_) & + & call mld_move_alloc(current%item,p%precv(i),info) + if (info == psb_success_) then + if (i ==1) then + allocate(p%precv(i)%sm,source=base_sm,stat=info) + else if (i < newsz) then + allocate(p%precv(i)%sm,source=med_sm,stat=info) + else + allocate(p%precv(i)%sm,source=coarse_sm,stat=info) + end if + end if + if (info /= psb_success_) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='list cpy'); goto 9999 + end if + if (i == 1) then + p%precv(i)%base_a => a + p%precv(i)%base_desc => desc_a + else + p%precv(i)%base_a => p%precv(i)%ac + p%precv(i)%base_desc => p%precv(i)%desc_ac + p%precv(i)%map%p_desc_X => p%precv(i-1)%base_desc + p%precv(i)%map%p_desc_Y => p%precv(i)%base_desc + end if + + newnode => current%next + deallocate(current) + end do + call base_sm%free(info) + if (info == psb_success_) call med_sm%free(info) + if (info == psb_success_) call coarse_sm%free(info) + if (info == psb_success_) deallocate(coarse_sm,med_sm,base_sm,stat=info) + if (info /= psb_success_) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='final cleanup'); goto 9999 + end if + iszv = newsz + + else + ! + ! Default, oldstyle + ! ! ! Build the matrix and the transfer operators corresponding @@ -179,11 +345,6 @@ subroutine mld_dmlprec_bld(a,desc_a,p,info,amold,vmold) p%precv(1)%base_a => a p%precv(1)%base_desc => desc_a - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,a_err='Base level precbuild.') - goto 9999 - end if - do i=2, iszv ! @@ -201,11 +362,6 @@ subroutine mld_dmlprec_bld(a,desc_a,p,info,amold,vmold) ! call mld_check_def(p%precv(i)%parms%coarse_mat,'Coarse matrix',& & mld_distr_mat_,is_distr_ml_coarse_mat) - - else if (i == iszv) then - -!!$ call check_coarse_lev(p%precv(i)) - end if if (debug_level >= psb_debug_outer_) & @@ -277,9 +433,7 @@ subroutine mld_dmlprec_bld(a,desc_a,p,info,amold,vmold) p%precv(i)%map%p_desc_Y => p%precv(i)%base_desc end do - i = iszv - call check_coarse_lev(p%precv(i)) if (info == psb_success_) call mld_coarse_bld(p%precv(i-1)%base_a,& & p%precv(i-1)%base_desc, p%precv(i),info) if (info /= psb_success_) then @@ -289,6 +443,12 @@ subroutine mld_dmlprec_bld(a,desc_a,p,info,amold,vmold) end if end if + ! + ! The coarse space hierarchy has been build. + ! + ! Now do the preconditioner build. + ! + do i=1, iszv ! ! build the base preconditioner at level i @@ -316,10 +476,6 @@ subroutine mld_dmlprec_bld(a,desc_a,p,info,amold,vmold) goto 9999 end if - - ! - ! Test version for beginning of OO stuff. - ! call p%precv(i)%sm%build(p%precv(i)%base_a,p%precv(i)%base_desc,& & 'F',info,amold=amold,vmold=vmold) @@ -350,69 +506,4 @@ subroutine mld_dmlprec_bld(a,desc_a,p,info,amold,vmold) end if return -contains - - subroutine check_coarse_lev(prec) - type(mld_d_onelev_type) :: prec - - ! - ! At the coarsest level, check mld_coarse_solve_ - ! -!!$ val = prec%parms%coarse_solve -!!$ select case (val) -!!$ case(mld_jac_) -!!$ -!!$ if (prec%prec%iprcparm(mld_sub_solve_) /= mld_diag_scale_) then -!!$ if (me == 0) write(debug_unit,*)& -!!$ & 'Warning: inconsistent coarse level specification.' -!!$ if (me == 0) write(debug_unit,*)& -!!$ & ' Resetting according to the value specified for mld_coarse_solve_.' -!!$ prec%prec%iprcparm(mld_sub_solve_) = mld_diag_scale_ -!!$ end if -!!$ prec%prec%iprcparm(mld_smoother_type_) = mld_jac_ -!!$ -!!$ case(mld_bjac_) -!!$ -!!$ if ((prec%prec%iprcparm(mld_sub_solve_) == mld_diag_scale_).or.& -!!$ & ( prec%prec%iprcparm(mld_smoother_type_) /= mld_bjac_)) then -!!$ if (me == 0) write(debug_unit,*)& -!!$ & 'Warning: inconsistent coarse level specification.' -!!$ if (me == 0) write(debug_unit,*)& -!!$ & ' Resetting according to the value specified for mld_coarse_solve_.' -!!$! !$#if defined(HAVE_UMF_) -!!$! !$ prec%prec%iprcparm(mld_sub_solve_) = mld_umf_ -!!$! !$#elif defined(HAVE_SLU_) -!!$! !$ prec%prec%iprcparm(mld_sub_solve_) = mld_slu_ -!!$! !$#else -!!$ prec%prec%iprcparm(mld_sub_solve_) = mld_ilu_n_ -!!$! !$#endif -!!$ end if -!!$ prec%prec%iprcparm(mld_smoother_type_) = mld_bjac_ -!!$ -!!$ case(mld_umf_, mld_slu_) -!!$ if ((prec%iprcparm(mld_coarse_mat_) /= mld_repl_mat_).or.& -!!$ & (prec%prec%iprcparm(mld_sub_solve_) /= val)) then -!!$ if (me == 0) write(debug_unit,*)& -!!$ & 'Warning: inconsistent coarse level specification.' -!!$ if (me == 0) write(debug_unit,*)& -!!$ & ' Resetting according to the value specified for mld_coarse_solve_.' -!!$ prec%iprcparm(mld_coarse_mat_) = mld_repl_mat_ -!!$ prec%prec%iprcparm(mld_sub_solve_) = val -!!$ prec%prec%iprcparm(mld_smoother_type_) = mld_bjac_ -!!$ end if -!!$ case(mld_sludist_) -!!$ if ((prec%iprcparm(mld_coarse_mat_) /= mld_distr_mat_).or.& -!!$ & (prec%prec%iprcparm(mld_sub_solve_) /= val)) then -!!$ if (me == 0) write(debug_unit,*)& -!!$ & 'Warning: inconsistent coarse level specification.' -!!$ if (me == 0) write(debug_unit,*)& -!!$ & ' Resetting according to the value specified for mld_coarse_solve_.' -!!$ prec%iprcparm(mld_coarse_mat_) = mld_distr_mat_ -!!$ prec%prec%iprcparm(mld_sub_solve_) = val -!!$ prec%prec%iprcparm(mld_smoother_type_) = mld_bjac_ -!!$ prec%prec%iprcparm(mld_smoother_sweeps_) = 1 -!!$ end if -!!$ end select - end subroutine check_coarse_lev - end subroutine mld_dmlprec_bld diff --git a/mlprec/impl/mld_dprecinit.F90 b/mlprec/impl/mld_dprecinit.F90 index be4f1680..fc1571ca 100644 --- a/mlprec/impl/mld_dprecinit.F90 +++ b/mlprec/impl/mld_dprecinit.F90 @@ -125,6 +125,7 @@ subroutine mld_dprecinit(p,ptype,info,nlev) ! Do we want to do something? endif endif + p%coarse_aggr_size = -1 select case(psb_toupper(ptype(1:len_trim(ptype)))) case ('NOPREC','NONE') diff --git a/mlprec/impl/mld_dprecset.F90 b/mlprec/impl/mld_dprecset.F90 index 28a649fb..5fbcd84d 100644 --- a/mlprec/impl/mld_dprecset.F90 +++ b/mlprec/impl/mld_dprecset.F90 @@ -129,6 +129,11 @@ subroutine mld_dprecseti(p,what,val,info,ilev) return endif + if (what == mld_coarse_aggr_size_) then + p%coarse_aggr_size = max(val,-1) + return + end if + ! ! Set preconditioner parameters at level ilev. ! diff --git a/mlprec/impl/mld_s_onelev_impl.f90 b/mlprec/impl/mld_s_onelev_impl.f90 index 18cc7154..3a5d9d68 100644 --- a/mlprec/impl/mld_s_onelev_impl.f90 +++ b/mlprec/impl/mld_s_onelev_impl.f90 @@ -154,7 +154,7 @@ subroutine mld_s_base_onelev_free(lv,info) & call lv%sm%free(info) call lv%ac%free() - if (psb_is_ok_desc(lv%desc_ac)) & + if (lv%desc_ac%is_ok()) & & call psb_cdfree(lv%desc_ac,info) call lv%map%free(info) diff --git a/mlprec/impl/mld_saggrmat_asb.f90 b/mlprec/impl/mld_saggrmat_asb.f90 index 526d5cbd..5a84f116 100644 --- a/mlprec/impl/mld_saggrmat_asb.f90 +++ b/mlprec/impl/mld_saggrmat_asb.f90 @@ -113,6 +113,11 @@ subroutine mld_saggrmat_asb(a,desc_a,ilaggr,nlaggr,p,info) integer, intent(out) :: info ! Local variables + type(psb_sspmat_type) :: ac, op_prol,op_restr + type(psb_s_coo_sparse_mat) :: acoo, bcoo + type(psb_s_csr_sparse_mat) :: acsr1 + integer :: nzl,ntaggr + integer :: debug_level, debug_unit integer :: ictxt,np,me, err_act character(len=20) :: name @@ -120,6 +125,9 @@ subroutine mld_saggrmat_asb(a,desc_a,ilaggr,nlaggr,p,info) if(psb_get_errstatus().ne.0) return info=psb_success_ call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + ictxt = desc_a%get_context() @@ -128,35 +136,139 @@ subroutine mld_saggrmat_asb(a,desc_a,ilaggr,nlaggr,p,info) select case (p%parms%aggr_kind) case (mld_no_smooth_) - call mld_aggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,p,info) - if(info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='mld_aggrmat_nosmth_asb') + call mld_saggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,& + & p%parms,ac,op_prol,op_restr,info) + + case(mld_smooth_prol_) + + call mld_saggrmat_smth_asb(a,desc_a,ilaggr,nlaggr, & + & p%parms,ac,op_prol,op_restr,info) + + case(mld_biz_prol_) + + call mld_saggrmat_biz_asb(a,desc_a,ilaggr,nlaggr, & + & p%parms,ac,op_prol,op_restr,info) + + case(mld_min_energy_) + + call mld_saggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr, & + & p%parms,ac,op_prol,op_restr,info) + + case default + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='Invalid aggr kind') + goto 9999 + + end select + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='Inner aggrmat asb') + goto 9999 + end if + + + + ntaggr = sum(nlaggr) + + select case(p%parms%coarse_mat) + + case(mld_distr_mat_) + + nzl = ac%get_nzeros() + call ac%mv_to(bcoo) + + if (info == psb_success_) call psb_cdall(ictxt,p%desc_ac,info,nl=nlaggr(me+1)) + if (info == psb_success_) call psb_cdins(nzl,bcoo%ia,bcoo%ja,p%desc_ac,info) + if (info == psb_success_) call psb_cdasb(p%desc_ac,info) + if (info == psb_success_) call psb_glob_to_loc(bcoo%ia(1:nzl),p%desc_ac,info,iact='I') + if (info == psb_success_) call psb_glob_to_loc(bcoo%ja(1:nzl),p%desc_ac,info,iact='I') + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Creating p%desc_ac and converting ac') goto 9999 end if + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & 'Assembld aux descr. distr.' + call p%ac%mv_from(bcoo) - case(mld_smooth_prol_,mld_biz_prol_) + call p%ac%set_nrows(p%desc_ac%get_local_rows()) + call p%ac%set_ncols(p%desc_ac%get_local_cols()) + call p%ac%set_asb() - call mld_aggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info) - if(info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='mld_aggrmat_smth_asb') + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_sp_free') goto 9999 end if - case(mld_min_energy_) + if (np>1) then + call op_prol%mv_to(acsr1) + nzl = acsr1%get_nzeros() + call psb_glob_to_loc(acsr1%ja(1:nzl),p%desc_ac,info,'I') + if(info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_glob_to_loc') + goto 9999 + end if + call op_prol%mv_from(acsr1) + endif + call op_prol%set_ncols(p%desc_ac%get_local_cols()) - call mld_aggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info) - if(info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='mld_aggrmat_smth_asb') - goto 9999 + if (np>1) then + call op_restr%cscnv(info,type='coo',dupl=psb_dupl_add_) + call op_restr%mv_to(acoo) + nzl = acoo%get_nzeros() + if (info == psb_success_) call psb_glob_to_loc(acoo%ia(1:nzl),p%desc_ac,info,'I') + call acoo%set_dupl(psb_dupl_add_) + if (info == psb_success_) call op_restr%mv_from(acoo) + if (info == psb_success_) call op_restr%cscnv(info,type='csr') + if(info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,a_err='Converting op_restr to local') + goto 9999 + end if end if + call op_restr%set_nrows(p%desc_ac%get_local_cols()) - case default + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & 'Done ac ' - call psb_errpush(psb_err_internal_error_,name,a_err='Invalid aggr kind') - goto 9999 + case(mld_repl_mat_) + ! + ! + call psb_cdall(ictxt,p%desc_ac,info,mg=ntaggr,repl=.true.) + if (info == psb_success_) call psb_cdasb(p%desc_ac,info) + if (info == psb_success_) & + & call psb_gather(p%ac,ac,p%desc_ac,info,dupl=psb_dupl_add_,keeploc=.false.) + + if (info /= psb_success_) goto 9999 + case default + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='invalid mld_coarse_mat_') + goto 9999 end select + call p%ac%cscnv(info,type='csr',dupl=psb_dupl_add_) + if(info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='spcnv') + goto 9999 + end if + + ! + ! Copy the prolongation/restriction matrices into the descriptor map. + ! op_restr => PR^T i.e. restriction operator + ! op_prol => PR i.e. prolongation operator + ! + + p%map = psb_linmap(psb_map_aggr_,desc_a,& + & p%desc_ac,op_restr,op_prol,ilaggr,nlaggr) + if (info == psb_success_) call op_prol%free() + if (info == psb_success_) call op_restr%free() + if(info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='sp_Free') + goto 9999 + end if + + call psb_erractionrestore(err_act) return diff --git a/mlprec/impl/mld_saggrmat_biz_asb.f90 b/mlprec/impl/mld_saggrmat_biz_asb.f90 new file mode 100644 index 00000000..df43f098 --- /dev/null +++ b/mlprec/impl/mld_saggrmat_biz_asb.f90 @@ -0,0 +1,422 @@ +!!$ +!!$ +!!$ MLD2P4 version 2.0 +!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package +!!$ based on PSBLAS (Parallel Sparse BLAS version 3.0) +!!$ +!!$ (C) Copyright 2008,2009,2010 +!!$ +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari CNRS-IRIT, Toulouse +!!$ Pasqua D'Ambra ICAR-CNR, Naples +!!$ Daniela di Serafino Second University of Naples +!!$ +!!$ Redistribution and use in source and binary forms, with or without +!!$ modification, are permitted provided that the following conditions +!!$ are met: +!!$ 1. Redistributions of source code must retain the above copyright +!!$ notice, this list of conditions and the following disclaimer. +!!$ 2. Redistributions in binary form must reproduce the above copyright +!!$ notice, this list of conditions, and the following disclaimer in the +!!$ documentation and/or other materials provided with the distribution. +!!$ 3. The name of the MLD2P4 group or the names of its contributors may +!!$ not be used to endorse or promote products derived from this +!!$ software without specific written permission. +!!$ +!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE MLD2P4 GROUP OR ITS CONTRIBUTORS +!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +!!$ POSSIBILITY OF SUCH DAMAGE. +!!$ +!!$ +! File: mld_saggrmat_biz_asb.F90 +! +! Subroutine: mld_saggrmat_biz_asb +! Version: real +! +! This routine builds a coarse-level matrix A_C from a fine-level matrix A +! by using the Galerkin approach, i.e. +! +! A_C = P_C^T A P_C, +! +! where P_C is a prolongator from the coarse level to the fine one. +! +! This routine builds A_C according to a "bizarre" aggregation algorithm, +! using a "naive" prolongator proposed by the authors of MLD2P4. However, this +! prolongator still requires a deep analysis and testing and its use is not +! recommended. +! +! The coarse-level matrix A_C is distributed among the parallel processes or +! replicated on each of them, according to the value of p%parms%coarse_mat, +! specified by the user through mld_sprecinit and mld_zprecset. +! +! Arguments: +! a - type(psb_sspmat_type), input. +! The sparse matrix structure containing the local part of +! the fine-level matrix. +! desc_a - type(psb_desc_type), input. +! The communication descriptor of the fine-level matrix. +! p - type(mld_s_onelev_type), input/output. +! The 'one-level' data structure that will contain the local +! part of the matrix to be built as well as the information +! concerning the prolongator and its transpose. +! ilaggr - integer, dimension(:), allocatable. +! The mapping between the row indices of the coarse-level +! matrix and the row indices of the fine-level matrix. +! ilaggr(i)=j means that node i in the adjacency graph +! of the fine-level matrix is mapped onto node j in the +! adjacency graph of the coarse-level matrix. +! nlaggr - integer, dimension(:), allocatable. +! nlaggr(i) contains the aggregates held by process i. +! info - integer, output. +! Error code. +! +subroutine mld_saggrmat_biz_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_restr,info) + use psb_base_mod + use mld_s_inner_mod, mld_protect_name => mld_saggrmat_biz_asb + + implicit none + + ! Arguments + type(psb_sspmat_type), intent(in) :: a + type(psb_desc_type), intent(in) :: desc_a + integer, intent(inout) :: ilaggr(:), nlaggr(:) + type(mld_sml_parms), intent(inout) :: parms + type(psb_sspmat_type), intent(out) :: ac,op_prol,op_restr + integer, intent(out) :: info + + ! Local variables + integer :: nrow, nglob, ncol, ntaggr, ip, ndx,& + & naggr, nzl,naggrm1,naggrp1, i, j, k, jd, icolF, nrw + integer ::ictxt, np, me, err_act + character(len=20) :: name + type(psb_sspmat_type) :: am3, am4 + type(psb_s_coo_sparse_mat) :: tmpcoo + type(psb_s_csr_sparse_mat) :: acsr1, acsr2, acsr3, acsrf, ptilde + real(psb_spk_), allocatable :: adiag(:) + integer(psb_ipk_) :: ierr(5) + logical :: filter_mat + integer :: debug_level, debug_unit + integer, parameter :: ncmax=16 + real(psb_spk_) :: anorm, omega, tmp, dg, theta + + name='mld_aggrmat_biz_asb' + if(psb_get_errstatus().ne.0) return + info=psb_success_ + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + ictxt = desc_a%get_context() + ictxt = desc_a%get_context() + + call psb_info(ictxt, me, np) + + nglob = desc_a%get_global_rows() + nrow = desc_a%get_local_rows() + ncol = desc_a%get_local_cols() + + theta = parms%aggr_thresh + + naggr = nlaggr(me+1) + ntaggr = sum(nlaggr) + + naggrm1 = sum(nlaggr(1:me)) + naggrp1 = sum(nlaggr(1:me+1)) + + filter_mat = (parms%aggr_filter == mld_filter_mat_) + + ilaggr(1:nrow) = ilaggr(1:nrow) + naggrm1 + call psb_halo(ilaggr,desc_a,info) + + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_halo') + goto 9999 + end if + + ! naggr: number of local aggregates + ! nrow: local rows. + ! + allocate(adiag(ncol),stat=info) + + if (info /= psb_success_) then + info=psb_err_alloc_request_; ierr(1)=nrow; + call psb_errpush(info,name,i_err=ierr,a_err='real(psb_spk_)') + goto 9999 + end if + + ! Get the diagonal D + call a%get_diag(adiag,info) + if (info == psb_success_) & + & call psb_halo(adiag,desc_a,info) + + if(info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='sp_getdiag') + goto 9999 + end if + + ! 1. Allocate Ptilde in sparse matrix form + call tmpcoo%allocate(ncol,naggr,ncol) + do i=1,nrow + tmpcoo%val(i) = sone + tmpcoo%ia(i) = i + tmpcoo%ja(i) = ilaggr(i) + end do + call tmpcoo%set_nzeros(nrow) + call tmpcoo%set_dupl(psb_dupl_add_) + + call ptilde%mv_from_coo(tmpcoo,info) + if (info == psb_success_) call a%cscnv(acsr3,info,dupl=psb_dupl_add_) + + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & ' Initial copies sone.' + + if (filter_mat) then + ! + ! Build the filtered matrix Af from A + ! + if (info == psb_success_) call a%cscnv(acsrf,info,dupl=psb_dupl_add_) + + do i=1,nrow + tmp = szero + jd = -1 + do j=acsrf%irp(i),acsrf%irp(i+1)-1 + if (acsrf%ja(j) == i) jd = j + if (abs(acsrf%val(j)) < theta*sqrt(abs(adiag(i)*adiag(acsrf%ja(j))))) then + tmp=tmp+acsrf%val(j) + acsrf%val(j)=szero + endif + + enddo + if (jd == -1) then + write(0,*) 'Wrong input: we need the diagonal!!!!', i + else + acsrf%val(jd)=acsrf%val(jd)-tmp + end if + enddo + ! Take out zeroed terms + call acsrf%mv_to_coo(tmpcoo,info) + k = 0 + do j=1,tmpcoo%get_nzeros() + if ((tmpcoo%val(j) /= szero) .or. (tmpcoo%ia(j) == tmpcoo%ja(j))) then + k = k + 1 + tmpcoo%val(k) = tmpcoo%val(j) + tmpcoo%ia(k) = tmpcoo%ia(j) + tmpcoo%ja(k) = tmpcoo%ja(j) + end if + end do + call tmpcoo%set_nzeros(k) + call tmpcoo%set_dupl(psb_dupl_add_) + call acsrf%mv_from_coo(tmpcoo,info) + end if + + + do i=1,size(adiag) + if (adiag(i) /= szero) then + adiag(i) = sone / adiag(i) + else + adiag(i) = sone + end if + end do + + if (filter_mat) call acsrf%scal(adiag,info) + if (info == psb_success_) call acsr3%scal(adiag,info) + if (info /= psb_success_) goto 9999 + + + if (parms%aggr_omega_alg == mld_eig_est_) then + + if (parms%aggr_eig == mld_max_norm_) then + + ! + ! This only works with CSR + ! + anorm = szero + dg = sone + nrw = acsr3%get_nrows() + do i=1, nrw + tmp = szero + do j=acsr3%irp(i),acsr3%irp(i+1)-1 + if (acsr3%ja(j) <= nrw) then + tmp = tmp + abs(acsr3%val(j)) + endif + if (acsr3%ja(j) == i ) then + dg = abs(acsr3%val(j)) + end if + end do + anorm = max(anorm,tmp/dg) + enddo + + call psb_amx(ictxt,anorm) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,a_err='Invalid AM3 storage format') + goto 9999 + end if + omega = 4.d0/(3.d0*anorm) + parms%aggr_omega_val = omega + + else + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='invalid mld_aggr_eig_') + goto 9999 + end if + + else if (parms%aggr_omega_alg == mld_user_choice_) then + + omega = parms%aggr_omega_val + + else if (parms%aggr_omega_alg /= mld_user_choice_) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='invalid mld_aggr_omega_alg_') + goto 9999 + end if + + if (filter_mat) then + ! + ! Build the smoothed prolongator using the filtered matrix + ! + do i=1,acsrf%get_nrows() + do j=acsrf%irp(i),acsrf%irp(i+1)-1 + if (acsrf%ja(j) == i) then + acsrf%val(j) = sone - omega*acsrf%val(j) + else + acsrf%val(j) = - omega*acsrf%val(j) + end if + end do + end do + + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & 'Done gather, going for SYMBMM 1' + ! + ! Symbmm90 does the allocation for its result. + ! + ! acsrm1 = (I-w*D*Af)Ptilde + ! Doing it this way means to consider diag(Af_i) + ! + ! + call psb_symbmm(acsrf,ptilde,acsr1,info) + if(info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='symbmm 1') + goto 9999 + end if + + call psb_numbmm(acsrf,ptilde,acsr1) + + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & 'Done NUMBMM 1' + + else + ! + ! Build the smoothed prolongator using the original matrix + ! + do i=1,acsr3%get_nrows() + do j=acsr3%irp(i),acsr3%irp(i+1)-1 + if (acsr3%ja(j) == i) then + acsr3%val(j) = sone - omega*acsr3%val(j) + else + acsr3%val(j) = - omega*acsr3%val(j) + end if + end do + end do + + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & 'Done gather, going for SYMBMM 1' + ! + ! Symbmm90 does the allocation for its result. + ! + ! acsrm1 = (I-w*D*A)Ptilde + ! Doing it this way means to consider diag(A_i) + ! + ! + call psb_symbmm(acsr3,ptilde,acsr1,info) + if(info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='symbmm 1') + goto 9999 + end if + + call psb_numbmm(acsr3,ptilde,acsr1) + + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & 'Done NUMBMM 1' + + end if + call ptilde%free() + call acsr1%set_dupl(psb_dupl_add_) + + call op_prol%mv_from(acsr1) + + call psb_rwextd(ncol,op_prol,info) + if(info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,a_err='Halo of op_prol') + goto 9999 + end if + + call psb_symbmm(a,op_prol,am3,info) + if(info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='symbmm 2') + goto 9999 + end if + + call psb_numbmm(a,op_prol,am3) + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & 'Done NUMBMM 2',parms%aggr_kind, mld_smooth_prol_ + + call op_prol%transp(op_restr) + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & 'starting sphalo/ rwxtd' + + call psb_rwextd(ncol,am3,info) + if(info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,a_err='Extend am3') + goto 9999 + end if + + + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & 'starting symbmm 3' + call psb_symbmm(op_restr,am3,ac,info) + if (info == psb_success_) call psb_numbmm(op_restr,am3,ac) + if (info == psb_success_) call am3%free() + if (info == psb_success_) call ac%cscnv(info,type='coo',dupl=psb_dupl_add_) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,a_err='Build b = op_restr x am3') + goto 9999 + end if + + + + + + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & 'Done smooth_aggregate ' + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_errpush(info,name) + call psb_erractionrestore(err_act) + if (err_act.eq.psb_act_abort_) then + call psb_error() + return + end if + return + + + +end subroutine mld_saggrmat_biz_asb diff --git a/mlprec/impl/mld_saggrmat_minnrg_asb.F90 b/mlprec/impl/mld_saggrmat_minnrg_asb.f90 similarity index 78% rename from mlprec/impl/mld_saggrmat_minnrg_asb.F90 rename to mlprec/impl/mld_saggrmat_minnrg_asb.f90 index d3829933..4e5ed449 100644 --- a/mlprec/impl/mld_saggrmat_minnrg_asb.F90 +++ b/mlprec/impl/mld_saggrmat_minnrg_asb.f90 @@ -98,37 +98,31 @@ ! info - integer, output. ! Error code. ! -subroutine mld_saggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info) +subroutine mld_saggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_restr,info) use psb_base_mod use mld_s_inner_mod, mld_protect_name => mld_saggrmat_minnrg_asb -#ifdef MPI_MOD - use mpi -#endif implicit none -#ifdef MPI_H - include 'mpif.h' -#endif ! Arguments type(psb_sspmat_type), intent(in) :: a type(psb_desc_type), intent(in) :: desc_a integer, intent(inout) :: ilaggr(:), nlaggr(:) - type(mld_s_onelev_type), intent(inout), target :: p + type(mld_sml_parms), intent(inout) :: parms + type(psb_sspmat_type), intent(out) :: ac,op_prol,op_restr integer, intent(out) :: info ! Local variables - type(psb_sspmat_type) :: b integer(psb_mpik_), allocatable :: nzbr(:), idisp(:) integer :: nrow, nglob, ncol, ntaggr, nzac, ip, ndx,& & naggr, nzl,naggrm1,naggrp1, i, j, k, jd, icolF, nrt integer :: ictxt,np,me, err_act, icomm character(len=20) :: name - type(psb_sspmat_type) :: am1,am2, af, ptilde, rtilde, atran, atp, atdatp + type(psb_sspmat_type) :: af, ptilde, rtilde, atran, atp, atdatp type(psb_sspmat_type) :: am3,am4, ap, adap,atmp,rada, ra, atmp2, dap, dadap, da type(psb_sspmat_type) :: dat, datp, datdatp, atmp3 - type(psb_s_coo_sparse_mat) :: acoo, acoof, bcoo, tmpcoo - type(psb_s_csr_sparse_mat) :: acsr1, acsr2, acsr3, bcsr, acsr, acsrf + type(psb_s_coo_sparse_mat) :: tmpcoo + type(psb_s_csr_sparse_mat) :: acsr1, acsr2, acsr3, acsr, acsrf type(psb_s_csc_sparse_mat) :: csc_dap, csc_dadap, csc_datp, csc_datdatp, acsc real(psb_spk_), allocatable :: adiag(:), adinv(:) real(psb_spk_), allocatable :: omf(:), omp(:), omi(:), oden(:) @@ -156,7 +150,7 @@ subroutine mld_saggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info) nrow = desc_a%get_local_rows() ncol = desc_a%get_local_cols() - theta = p%parms%aggr_thresh + theta = parms%aggr_thresh naggr = nlaggr(me+1) ntaggr = sum(nlaggr) @@ -171,7 +165,7 @@ subroutine mld_saggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info) naggrm1 = sum(nlaggr(1:me)) naggrp1 = sum(nlaggr(1:me+1)) - filter_mat = (p%parms%aggr_filter == mld_filter_mat_) + filter_mat = (parms%aggr_filter == mld_filter_mat_) ilaggr(1:nrow) = ilaggr(1:nrow) + naggrm1 call psb_halo(ilaggr,desc_a,info) @@ -213,16 +207,16 @@ subroutine mld_saggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info) ! 1. Allocate Ptilde in sparse matrix form - call acoo%allocate(ncol,ntaggr,ncol) + call tmpcoo%allocate(ncol,ntaggr,ncol) do i=1,ncol - acoo%val(i) = sone - acoo%ia(i) = i - acoo%ja(i) = ilaggr(i) + tmpcoo%val(i) = sone + tmpcoo%ia(i) = i + tmpcoo%ja(i) = ilaggr(i) end do - call acoo%set_nzeros(ncol) - call acoo%set_dupl(psb_dupl_add_) - call acoo%set_asb() - call ptilde%mv_from(acoo) + call tmpcoo%set_nzeros(ncol) + call tmpcoo%set_dupl(psb_dupl_add_) + call tmpcoo%set_asb() + call ptilde%mv_from(tmpcoo) call ptilde%cscnv(info,type='csr') !!$ call local_dump(me,ptilde,'csr-ptilde','Ptilde-1') @@ -354,17 +348,17 @@ subroutine mld_saggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info) ! ! Symbmm90 does the allocation for its result. ! - ! am1 = (I-w*D*Af)Ptilde + ! op_prol = (I-w*D*Af)Ptilde ! Doing it this way means to consider diag(Af_i) ! ! - call psb_symbmm(af,ptilde,am1,info) + call psb_symbmm(af,ptilde,op_prol,info) if(info /= psb_success_) then call psb_errpush(psb_err_from_subroutine_,name,a_err='symbmm 1') goto 9999 end if - call psb_numbmm(af,ptilde,am1) + call psb_numbmm(af,ptilde,op_prol) if (debug_level >= psb_debug_outer_) & & write(debug_unit,*) me,' ',trim(name),& @@ -390,16 +384,16 @@ subroutine mld_saggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info) ! ! Symbmm90 does the allocation for its result. ! - ! am1 = (I-w*D*A)Ptilde + ! op_prol = (I-w*D*A)Ptilde ! ! - call psb_symbmm(am3,ptilde,am1,info) + call psb_symbmm(am3,ptilde,op_prol,info) if(info /= psb_success_) then call psb_errpush(psb_err_from_subroutine_,name,a_err='symbmm 1') goto 9999 end if - call psb_numbmm(am3,ptilde,am1) + call psb_numbmm(am3,ptilde,op_prol) if (debug_level >= psb_debug_outer_) & & write(debug_unit,*) me,' ',trim(name),& @@ -509,20 +503,20 @@ subroutine mld_saggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info) call rtilde%mv_from(tmpcoo) call rtilde%cscnv(info,type='csr') - call psb_symbmm(rtilde,atmp,am2,info) - call psb_numbmm(rtilde,atmp,am2) + call psb_symbmm(rtilde,atmp,op_restr,info) + call psb_numbmm(rtilde,atmp,op_restr) ! - ! Now we have to gather the halo of am1, and add it to itself + ! Now we have to gather the halo of op_prol, and add it to itself ! to multiply it by A, ! - call psb_sphalo(am1,desc_a,am4,info,& + call psb_sphalo(op_prol,desc_a,am4,info,& & colcnv=.false.,rowscale=.true.) - if (info == psb_success_) call psb_rwextd(ncol,am1,info,b=am4) + if (info == psb_success_) call psb_rwextd(ncol,op_prol,info,b=am4) if (info == psb_success_) call am4%free() if(info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,a_err='Halo of am1') + call psb_errpush(psb_err_internal_error_,name,a_err='Halo of op_prol') goto 9999 end if @@ -530,7 +524,7 @@ subroutine mld_saggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info) ! Now we have to fix this. The only rows of B that are correct ! are those corresponding to "local" aggregates, i.e. indices in ilaggr(:) ! - call am2%mv_to(tmpcoo) + call op_restr%mv_to(tmpcoo) nzl = tmpcoo%get_nzeros() i=0 @@ -543,21 +537,21 @@ subroutine mld_saggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info) end if end do call tmpcoo%set_nzeros(i) - call am2%mv_from(tmpcoo) - call am2%cscnv(info,type='csr') + call op_restr%mv_from(tmpcoo) + call op_restr%cscnv(info,type='csr') if (debug_level >= psb_debug_outer_) & & write(debug_unit,*) me,' ',trim(name),& & 'starting sphalo/ rwxtd' - call psb_symbmm(a,am1,am3,info) + call psb_symbmm(a,op_prol,am3,info) if(info /= psb_success_) then call psb_errpush(psb_err_from_subroutine_,name,& & a_err='symbmm 2') goto 9999 end if - call psb_numbmm(a,am1,am3) + call psb_numbmm(a,op_prol,am3) if (debug_level >= psb_debug_outer_) & & write(debug_unit,*) me,' ',trim(name),& & 'Done NUMBMM 2' @@ -576,156 +570,18 @@ subroutine mld_saggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info) & write(debug_unit,*) me,' ',trim(name),& & 'Done sphalo/ rwxtd' - call psb_symbmm(am2,am3,b,info) - if (info == psb_success_) call psb_numbmm(am2,am3,b) + call psb_symbmm(op_restr,am3,ac,info) + if (info == psb_success_) call psb_numbmm(op_restr,am3,ac) if (info == psb_success_) call am3%free() - call b%mv_to(bcoo) + if (info == psb_success_) call ac%cscnv(info,type='coo',dupl=psb_dupl_add_) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& - &a_err='Build b = am2 x am3') + &a_err='Build ac = op_restr x am3') goto 9999 end if - if (debug_level >= psb_debug_outer_) & - & write(debug_unit,*) me,' ',trim(name),& - & 'Done mv_to_coo' - - - select case(p%parms%coarse_mat) - - case(mld_distr_mat_) - - nzl = bcoo%get_nzeros() - - if (debug_level >= psb_debug_outer_) & - & write(debug_unit,*) me,' ',trim(name),& - & ' B matrix nzl: ',nzl - - if (info == psb_success_) call psb_cdall(ictxt,p%desc_ac,info,nl=nlaggr(me+1)) - if (info == psb_success_) call psb_cdins(nzl,bcoo%ia,bcoo%ja,p%desc_ac,info) - if (info == psb_success_) call psb_cdasb(p%desc_ac,info) - if (info == psb_success_) call psb_glob_to_loc(bcoo%ia(1:nzl),p%desc_ac,info,iact='I') - if (info == psb_success_) call psb_glob_to_loc(bcoo%ja(1:nzl),p%desc_ac,info,iact='I') - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Creating p%desc_ac and converting ac') - goto 9999 - end if - - if (debug_level >= psb_debug_outer_) & - & write(debug_unit,*) me,' ',trim(name),& - & ' Assembld aux descr. distr.' - - call bcoo%set_nrows(p%desc_ac%get_local_rows()) - call bcoo%set_ncols(p%desc_ac%get_local_cols()) - call bcoo%fix(info) - call p%ac%mv_from(bcoo) - call p%ac%set_asb() - - call p%ac%cscnv(info,type='csr') - - if (np>1) then - call am1%mv_to(acsr) - nzl = acsr%get_nzeros() - call psb_glob_to_loc(acsr%ja(1:nzl),p%desc_ac,info,'I') - if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_glob_to_loc') - goto 9999 - end if - call am1%mv_from(acsr) - endif - call am1%set_ncols(p%desc_ac%get_local_cols()) - - if (np>1) then - call am2%mv_to(tmpcoo) - nzl = tmpcoo%get_nzeros() - if (info == psb_success_) call psb_glob_to_loc(tmpcoo%ia(1:nzl),p%desc_ac,info,'I') - if(info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,a_err='Converting am2 to local') - goto 9999 - end if - call am2%mv_from(tmpcoo) - call am2%cscnv(info,type='csr') - end if - call am2%set_nrows(p%desc_ac%get_local_cols()) - - if (debug_level >= psb_debug_outer_) & - & write(debug_unit,*) me,' ',trim(name),& - & 'Done ac ' - - case(mld_repl_mat_) - ! - ! - call psb_cdall(ictxt,p%desc_ac,info,mg=ntaggr,repl=.true.) - nzbr(:) = 0 - nzbr(me+1) = bcoo%get_nzeros() - - call psb_sum(ictxt,nzbr(1:np)) - nzac = sum(nzbr) - if (info == psb_success_) call tmpcoo%allocate(ntaggr,ntaggr,nzac) - if (info /= psb_success_) goto 9999 - - do ip=1,np - idisp(ip) = sum(nzbr(1:ip-1)) - enddo - ndx = nzbr(me+1) - - call mpi_allgatherv(bcoo%val,ndx,mpi_real,tmpcoo%val,nzbr,idisp,& - & mpi_real,icomm,info) - if (info == psb_success_)& - & call mpi_allgatherv(bcoo%ia,ndx,psb_mpi_ipk_integer,tmpcoo%ia,nzbr,idisp,& - & psb_mpi_ipk_integer,icomm,info) - if (info == psb_success_)& - & call mpi_allgatherv(bcoo%ja,ndx,psb_mpi_ipk_integer,tmpcoo%ja,nzbr,idisp,& - & psb_mpi_ipk_integer,icomm,info) - - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err=' from mpi_allgatherv') - goto 9999 - end if - - call bcoo%free() - call tmpcoo%fix(info) - call p%ac%mv_from(tmpcoo) - call p%ac%cscnv(info,type='csr') - if(info /= psb_success_) goto 9999 - - deallocate(nzbr,idisp,stat=info) - if (info /= psb_success_) then - info = psb_err_alloc_dealloc_ - call psb_errpush(info,name) - goto 9999 - end if - case default - info = psb_err_internal_error_ - call psb_errpush(info,name,a_err='invalid mld_coarse_mat_') - goto 9999 - end select - - - - call p%ac%cscnv(info,type='csr') - if(info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='spcnv') - goto 9999 - end if - - ! - ! Copy the prolongation/restriction matrices into the descriptor map. - ! am2 => R i.e. restriction operator - ! am1 => P i.e. prolongation operator - ! - p%map = psb_linmap(psb_map_aggr_,desc_a,& - & p%desc_ac,am2,am1,ilaggr,nlaggr) - if (info == psb_success_) call am1%free() - if (info == psb_success_) call am2%free() - if(info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='sp_Free') - goto 9999 - end if if (debug_level >= psb_debug_outer_) & & write(debug_unit,*) me,' ',trim(name),& diff --git a/mlprec/impl/mld_saggrmat_nosmth_asb.F90 b/mlprec/impl/mld_saggrmat_nosmth_asb.f90 similarity index 57% rename from mlprec/impl/mld_saggrmat_nosmth_asb.F90 rename to mlprec/impl/mld_saggrmat_nosmth_asb.f90 index 86995791..6a10da69 100644 --- a/mlprec/impl/mld_saggrmat_nosmth_asb.F90 +++ b/mlprec/impl/mld_saggrmat_nosmth_asb.f90 @@ -81,35 +81,29 @@ ! info - integer, output. ! Error code. ! -subroutine mld_saggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,p,info) +subroutine mld_saggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_restr,info) use psb_base_mod use mld_s_inner_mod, mld_protect_name => mld_saggrmat_nosmth_asb -#ifdef MPI_MOD - use mpi -#endif implicit none -#ifdef MPI_H - include 'mpif.h' -#endif ! Arguments type(psb_sspmat_type), intent(in) :: a type(psb_desc_type), intent(in) :: desc_a integer, intent(inout) :: ilaggr(:), nlaggr(:) - type(mld_s_onelev_type), intent(inout), target :: p + type(mld_sml_parms), intent(inout) :: parms + type(psb_sspmat_type), intent(out) :: ac,op_prol,op_restr integer, intent(out) :: info ! Local variables integer :: ictxt,np,me, err_act integer(psb_mpik_) :: icomm, ndx, minfo character(len=20) :: name - type(psb_sspmat_type) :: b - integer(psb_mpik_), allocatable :: nzbr(:), idisp(:) integer(psb_ipk_) :: ierr(5) - type(psb_sspmat_type) :: am1,am2 - type(psb_s_coo_sparse_mat) :: acoo1, acoo2, bcoo, ac_coo - integer :: nrow, nglob, ncol, ntaggr, nzac, ip, & + type(psb_s_coo_sparse_mat) :: ac_coo, acoo + type(psb_s_csr_sparse_mat) :: acsr1, acsr2 + integer :: debug_level, debug_unit + integer :: nrow, nglob, ncol, ntaggr, nzl, ip, & & naggr, nzt, naggrm1, i name='mld_aggrmat_nosmth_asb' @@ -128,141 +122,48 @@ subroutine mld_saggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,p,info) naggr = nlaggr(me+1) ntaggr = sum(nlaggr) - allocate(nzbr(np), idisp(np),stat=info) - if (info /= psb_success_) then - info=psb_err_alloc_request_; ierr(1)=2*np; - call psb_errpush(info,name,i_err=ierr,a_err='integer') - goto 9999 - end if - naggrm1=sum(nlaggr(1:me)) - if (p%parms%coarse_mat == mld_repl_mat_) then - do i=1, nrow - ilaggr(i) = ilaggr(i) + naggrm1 - end do - call psb_halo(ilaggr,desc_a,info) - end if + do i=1, nrow + ilaggr(i) = ilaggr(i) + naggrm1 + end do + call psb_halo(ilaggr,desc_a,info) if(info /= psb_success_) then call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_halo') goto 9999 end if - if (p%parms%coarse_mat == mld_repl_mat_) then - call acoo1%allocate(ncol,ntaggr,ncol) - else - call acoo1%allocate(ncol,naggr,ncol) - end if + call acoo%allocate(ncol,ntaggr,ncol) do i=1,nrow - acoo1%val(i) = sone - acoo1%ia(i) = i - acoo1%ja(i) = ilaggr(i) + acoo%val(i) = sone + acoo%ia(i) = i + acoo%ja(i) = ilaggr(i) end do - call acoo1%set_dupl(psb_dupl_add_) - call acoo1%set_nzeros(nrow) - call acoo1%set_asb() - call acoo1%fix(info) - call acoo1%transp(acoo2) + call acoo%set_dupl(psb_dupl_add_) + call acoo%set_nzeros(nrow) + call acoo%set_asb() + call acoo%fix(info) + - call a%csclip(bcoo,info,jmax=nrow) + call op_prol%mv_from(acoo) + call op_prol%cscnv(info,type='csr',dupl=psb_dupl_add_) + if (info == psb_success_) call op_prol%transp(op_restr) + call a%csclip(ac_coo,info,jmax=nrow) - nzt = bcoo%get_nzeros() + nzt = ac_coo%get_nzeros() do i=1, nzt - bcoo%ia(i) = ilaggr(bcoo%ia(i)) - bcoo%ja(i) = ilaggr(bcoo%ja(i)) + ac_coo%ia(i) = ilaggr(ac_coo%ia(i)) + ac_coo%ja(i) = ilaggr(ac_coo%ja(i)) enddo - call bcoo%set_nrows(naggr) - call bcoo%set_ncols(naggr) - call bcoo%set_dupl(psb_dupl_add_) - call bcoo%fix(info) - - - if (p%parms%coarse_mat == mld_repl_mat_) then - - call psb_cdall(ictxt,p%desc_ac,info,mg=ntaggr,repl=.true.) - if (info == psb_success_) call psb_cdasb(p%desc_ac,info) - if(info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_cdall') - goto 9999 - end if - - nzbr(:) = 0 - nzbr(me+1) = nzt - call psb_sum(ictxt,nzbr(1:np)) - nzac = sum(nzbr) - - call ac_coo%allocate(ntaggr,ntaggr,nzac) - - do ip=1,np - idisp(ip) = sum(nzbr(1:ip-1)) - enddo - ndx = nzbr(me+1) - - call mpi_allgatherv(bcoo%val,ndx,mpi_real,ac_coo%val,nzbr,idisp,& - & mpi_real,icomm,minfo) - call mpi_allgatherv(bcoo%ia,ndx,psb_mpi_ipk_integer,ac_coo%ia,nzbr,idisp,& - & psb_mpi_ipk_integer,icomm,minfo) - call mpi_allgatherv(bcoo%ja,ndx,psb_mpi_ipk_integer,ac_coo%ja,nzbr,idisp,& - & psb_mpi_ipk_integer,icomm,minfo) - if(info /= psb_success_) then - info=-1 - call psb_errpush(info,name) - goto 9999 - end if - call ac_coo%set_nzeros(nzac) - call ac_coo%set_dupl(psb_dupl_add_) - call ac_coo%fix(info) - call p%ac%mv_from(ac_coo) - - else if (p%parms%coarse_mat == mld_distr_mat_) then - - call psb_cdall(ictxt,p%desc_ac,info,nl=naggr) - if (info == psb_success_) call psb_cdasb(p%desc_ac,info) - call p%ac%mv_from(bcoo) - if(info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,a_err='Build ac, desc_ac') - goto 9999 - - end if - - else - info = psb_err_internal_error_ - call psb_errpush(psb_err_internal_error_,name,a_err='invalid mld_coarse_mat_') - goto 9999 - end if - - call bcoo%free() - - deallocate(nzbr,idisp) - - call p%ac%cscnv(info,type='csr',dupl=psb_dupl_add_) - if(info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='cscnv') - goto 9999 - end if - - call am1%mv_from(acoo1) - call am1%cscnv(info,type='csr',dupl=psb_dupl_add_) - if (info == psb_success_) call am2%mv_from(acoo2) - if (info == psb_success_) call am2%cscnv(info,type='csr',dupl=psb_dupl_add_) - ! - ! Copy the prolongation/restriction matrices into the descriptor map. - ! am2 => PR^T i.e. restriction operator - ! am1 => PR i.e. prolongation operator - ! - if (info == psb_success_) & - & p%map = psb_linmap(psb_map_aggr_,desc_a,& - & p%desc_ac,am2,am1,ilaggr,nlaggr) - if (info == psb_success_) call am1%free() - if (info == psb_success_) call am2%free() - if(info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='linmap build') - goto 9999 - end if + call ac_coo%set_nrows(naggr) + call ac_coo%set_ncols(naggr) + call ac_coo%set_dupl(psb_dupl_add_) + call ac_coo%fix(info) + call ac%mv_from(ac_coo) call psb_erractionrestore(err_act) diff --git a/mlprec/impl/mld_saggrmat_smth_asb.F90 b/mlprec/impl/mld_saggrmat_smth_asb.f90 similarity index 52% rename from mlprec/impl/mld_saggrmat_smth_asb.F90 rename to mlprec/impl/mld_saggrmat_smth_asb.f90 index 47519967..c38d9ec6 100644 --- a/mlprec/impl/mld_saggrmat_smth_asb.F90 +++ b/mlprec/impl/mld_saggrmat_smth_asb.f90 @@ -61,11 +61,6 @@ ! according to the value of p%parms%aggr_omega_alg, specified by the user ! through mld_sprecinit and mld_zprecset. ! -! This routine can also build A_C according to a "bizarre" aggregation algorithm, -! using a "naive" prolongator proposed by the authors of MLD2P4. However, this -! prolongator still requires a deep analysis and testing and its use is not -! recommended. -! ! The coarse-level matrix A_C is distributed among the parallel processes or ! replicated on each of them, according to the value of p%parms%coarse_mat, ! specified by the user through mld_sprecinit and mld_zprecset. @@ -98,38 +93,31 @@ ! info - integer, output. ! Error code. ! -subroutine mld_saggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info) +subroutine mld_saggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_restr,info) use psb_base_mod use mld_s_inner_mod, mld_protect_name => mld_saggrmat_smth_asb -#ifdef MPI_MOD - use mpi -#endif implicit none -#ifdef MPI_H - include 'mpif.h' -#endif ! Arguments type(psb_sspmat_type), intent(in) :: a type(psb_desc_type), intent(in) :: desc_a integer, intent(inout) :: ilaggr(:), nlaggr(:) - type(mld_s_onelev_type), intent(inout), target :: p + type(mld_sml_parms), intent(inout) :: parms + type(psb_sspmat_type), intent(out) :: ac,op_prol,op_restr integer, intent(out) :: info ! Local variables - type(psb_sspmat_type) :: b - integer, allocatable :: nzbr(:), idisp(:) - integer :: nrow, nglob, ncol, ntaggr, nzac, ip, ndx,& + integer :: nrow, nglob, ncol, ntaggr, ip, ndx,& & naggr, nzl,naggrm1,naggrp1, i, j, k, jd, icolF, nrw integer ::ictxt, np, me, err_act character(len=20) :: name - type(psb_sspmat_type) :: am1,am2, am3, am4 - type(psb_s_coo_sparse_mat) :: acoo, acoof, bcoo + type(psb_sspmat_type) :: am3, am4 + type(psb_s_coo_sparse_mat) :: tmpcoo type(psb_s_csr_sparse_mat) :: acsr1, acsr2, acsr3, acsrf, ptilde real(psb_spk_), allocatable :: adiag(:) integer(psb_ipk_) :: ierr(5) - logical :: ml_global_nmb, filter_mat + logical :: filter_mat integer :: debug_level, debug_unit integer, parameter :: ncmax=16 real(psb_spk_) :: anorm, omega, tmp, dg, theta @@ -150,34 +138,21 @@ subroutine mld_saggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info) nrow = desc_a%get_local_rows() ncol = desc_a%get_local_cols() - theta = p%parms%aggr_thresh + theta = parms%aggr_thresh naggr = nlaggr(me+1) ntaggr = sum(nlaggr) - allocate(nzbr(np), idisp(np),stat=info) - if (info /= psb_success_) then - info=psb_err_alloc_request_; ierr(1)=2*np; - call psb_errpush(info,name,i_err=ierr,a_err='integer') - goto 9999 - end if - naggrm1 = sum(nlaggr(1:me)) naggrp1 = sum(nlaggr(1:me+1)) - ml_global_nmb = ( (p%parms%aggr_kind == mld_smooth_prol_).or.& - & ( (p%parms%aggr_kind == mld_biz_prol_).and.& - & (p%parms%coarse_mat == mld_repl_mat_)) ) - - filter_mat = (p%parms%aggr_filter == mld_filter_mat_) + filter_mat = (parms%aggr_filter == mld_filter_mat_) - if (ml_global_nmb) then - ilaggr(1:nrow) = ilaggr(1:nrow) + naggrm1 - call psb_halo(ilaggr,desc_a,info) + ilaggr(1:nrow) = ilaggr(1:nrow) + naggrm1 + call psb_halo(ilaggr,desc_a,info) - if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_halo') - goto 9999 - end if + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_halo') + goto 9999 end if ! naggr: number of local aggregates @@ -202,32 +177,22 @@ subroutine mld_saggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info) end if ! 1. Allocate Ptilde in sparse matrix form - if (ml_global_nmb) then - call acoo%allocate(ncol,ntaggr,ncol) - do i=1,ncol - acoo%val(i) = sone - acoo%ia(i) = i - acoo%ja(i) = ilaggr(i) - end do - call acoo%set_nzeros(ncol) - else - call acoo%allocate(ncol,naggr,ncol) - do i=1,nrow - acoo%val(i) = sone - acoo%ia(i) = i - acoo%ja(i) = ilaggr(i) - end do - call acoo%set_nzeros(nrow) - endif - call acoo%set_dupl(psb_dupl_add_) - - call ptilde%mv_from_coo(acoo,info) + call tmpcoo%allocate(ncol,ntaggr,ncol) + do i=1,ncol + tmpcoo%val(i) = sone + tmpcoo%ia(i) = i + tmpcoo%ja(i) = ilaggr(i) + end do + call tmpcoo%set_nzeros(ncol) + call tmpcoo%set_dupl(psb_dupl_add_) + + call ptilde%mv_from_coo(tmpcoo,info) if (info == psb_success_) call a%cscnv(acsr3,info,dupl=psb_dupl_add_) if (debug_level >= psb_debug_outer_) & & write(debug_unit,*) me,' ',trim(name),& & ' Initial copies sone.' - + if (filter_mat) then ! ! Build the filtered matrix Af from A @@ -252,19 +217,19 @@ subroutine mld_saggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info) end if enddo ! Take out zeroed terms - call acsrf%mv_to_coo(acoof,info) + call acsrf%mv_to_coo(tmpcoo,info) k = 0 - do j=1,acoof%get_nzeros() - if ((acoof%val(j) /= szero) .or. (acoof%ia(j) == acoof%ja(j))) then + do j=1,tmpcoo%get_nzeros() + if ((tmpcoo%val(j) /= szero) .or. (tmpcoo%ia(j) == tmpcoo%ja(j))) then k = k + 1 - acoof%val(k) = acoof%val(j) - acoof%ia(k) = acoof%ia(j) - acoof%ja(k) = acoof%ja(j) + tmpcoo%val(k) = tmpcoo%val(j) + tmpcoo%ia(k) = tmpcoo%ia(j) + tmpcoo%ja(k) = tmpcoo%ja(j) end if end do - call acoof%set_nzeros(k) - call acoof%set_dupl(psb_dupl_add_) - call acsrf%mv_from_coo(acoof,info) + call tmpcoo%set_nzeros(k) + call tmpcoo%set_dupl(psb_dupl_add_) + call acsrf%mv_from_coo(tmpcoo,info) end if @@ -281,41 +246,13 @@ subroutine mld_saggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info) if (info /= psb_success_) goto 9999 - if (p%parms%aggr_omega_alg == mld_eig_est_) then - - if (p%parms%aggr_eig == mld_max_norm_) then - - if (p%parms%aggr_kind == mld_biz_prol_) then - - ! - ! This only works with CSR - ! - anorm = szero - dg = sone - nrw = acsr3%get_nrows() - do i=1, nrw - tmp = szero - do j=acsr3%irp(i),acsr3%irp(i+1)-1 - if (acsr3%ja(j) <= nrw) then - tmp = tmp + abs(acsr3%val(j)) - endif - if (acsr3%ja(j) == i ) then - dg = abs(acsr3%val(j)) - end if - end do - anorm = max(anorm,tmp/dg) - enddo - - call psb_amx(ictxt,anorm) - else - anorm = acsr3%csnmi() - endif - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,a_err='Invalid AM3 storage format') - goto 9999 - end if + if (parms%aggr_omega_alg == mld_eig_est_) then + + if (parms%aggr_eig == mld_max_norm_) then + + anorm = acsr3%csnmi() omega = 4.d0/(3.d0*anorm) - p%parms%aggr_omega_val = omega + parms%aggr_omega_val = omega else info = psb_err_internal_error_ @@ -323,11 +260,11 @@ subroutine mld_saggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info) goto 9999 end if - else if (p%parms%aggr_omega_alg == mld_user_choice_) then + else if (parms%aggr_omega_alg == mld_user_choice_) then - omega = p%parms%aggr_omega_val + omega = parms%aggr_omega_val - else if (p%parms%aggr_omega_alg /= mld_user_choice_) then + else if (parms%aggr_omega_alg /= mld_user_choice_) then info = psb_err_internal_error_ call psb_errpush(info,name,a_err='invalid mld_aggr_omega_alg_') goto 9999 @@ -368,7 +305,7 @@ subroutine mld_saggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info) if (debug_level >= psb_debug_outer_) & & write(debug_unit,*) me,' ',trim(name),& & 'Done NUMBMM 1' - + else ! ! Build the smoothed prolongator using the original matrix @@ -409,76 +346,64 @@ subroutine mld_saggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info) call ptilde%free() call acsr1%set_dupl(psb_dupl_add_) - call am1%mv_from(acsr1) - if (ml_global_nmb) then - ! - ! Now we have to gather the halo of am1, and add it to itself - ! to multiply it by A, - ! - call psb_sphalo(am1,desc_a,am4,info,& - & colcnv=.false.,rowscale=.true.) - if (info == psb_success_) call psb_rwextd(ncol,am1,info,b=am4) - if (info == psb_success_) call am4%free() - else - call psb_rwextd(ncol,am1,info) - endif + call op_prol%mv_from(acsr1) + ! + ! Now we have to gather the halo of op_prol, and add it to itself + ! to multiply it by A, + ! + call psb_sphalo(op_prol,desc_a,am4,info,& + & colcnv=.false.,rowscale=.true.) + if (info == psb_success_) call psb_rwextd(ncol,op_prol,info,b=am4) + if (info == psb_success_) call am4%free() if(info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,a_err='Halo of am1') + call psb_errpush(psb_err_internal_error_,name,a_err='Halo of op_prol') goto 9999 end if - call psb_symbmm(a,am1,am3,info) + call psb_symbmm(a,op_prol,am3,info) if(info /= psb_success_) then call psb_errpush(psb_err_from_subroutine_,name,a_err='symbmm 2') goto 9999 end if - call psb_numbmm(a,am1,am3) + call psb_numbmm(a,op_prol,am3) if (debug_level >= psb_debug_outer_) & & write(debug_unit,*) me,' ',trim(name),& - & 'Done NUMBMM 2',p%parms%aggr_kind, mld_smooth_prol_ + & 'Done NUMBMM 2',parms%aggr_kind, mld_smooth_prol_ - if (p%parms%aggr_kind == mld_smooth_prol_) then - call am1%transp(am2) - call am2%mv_to(acoo) - nzl = acoo%get_nzeros() - i=0 - ! - ! Now we have to fix this. The only rows of B that are correct - ! are those corresponding to "local" aggregates, i.e. indices in ilaggr(:) - ! - do k=1, nzl - if ((naggrm1 < acoo%ia(k)) .and.(acoo%ia(k) <= naggrp1)) then - i = i+1 - acoo%val(i) = acoo%val(k) - acoo%ia(i) = acoo%ia(k) - acoo%ja(i) = acoo%ja(k) - end if - end do - call acoo%set_nzeros(i) - call acoo%trim() - call am2%mv_from(acoo) - call am2%cscnv(info,type='csr',dupl=psb_dupl_add_) - if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='spcnv am2') - goto 9999 + call op_prol%transp(op_restr) + call op_restr%mv_to(tmpcoo) + nzl = tmpcoo%get_nzeros() + i=0 + ! + ! Now we have to fix this. The only rows of B that are correct + ! are those corresponding to "local" aggregates, i.e. indices in ilaggr(:) + ! + do k=1, nzl + if ((naggrm1 < tmpcoo%ia(k)) .and.(tmpcoo%ia(k) <= naggrp1)) then + i = i+1 + tmpcoo%val(i) = tmpcoo%val(k) + tmpcoo%ia(i) = tmpcoo%ia(k) + tmpcoo%ja(i) = tmpcoo%ja(k) end if - else - call am1%transp(am2) - endif + end do + call tmpcoo%set_nzeros(i) + call tmpcoo%trim() + call op_restr%mv_from(tmpcoo) + call op_restr%cscnv(info,type='csr',dupl=psb_dupl_add_) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='spcnv op_restr') + goto 9999 + end if if (debug_level >= psb_debug_outer_) & & write(debug_unit,*) me,' ',trim(name),& & 'starting sphalo/ rwxtd' - if (p%parms%aggr_kind == mld_smooth_prol_) then - ! am2 = ((i-wDA)Ptilde)^T - call psb_sphalo(am3,desc_a,am4,info,& - & colcnv=.false.,rowscale=.true.) - if (info == psb_success_) call psb_rwextd(ncol,am3,info,b=am4) - if (info == psb_success_) call am4%free() - else if (p%parms%aggr_kind == mld_biz_prol_) then - call psb_rwextd(ncol,am3,info) - endif + ! op_restr = ((i-wDA)Ptilde)^T + call psb_sphalo(am3,desc_a,am4,info,& + & colcnv=.false.,rowscale=.true.) + if (info == psb_success_) call psb_rwextd(ncol,am3,info,b=am4) + if (info == psb_success_) call am4%free() if(info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,a_err='Extend am3') goto 9999 @@ -488,180 +413,12 @@ subroutine mld_saggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info) if (debug_level >= psb_debug_outer_) & & write(debug_unit,*) me,' ',trim(name),& & 'starting symbmm 3' - call psb_symbmm(am2,am3,b,info) - if (info == psb_success_) call psb_numbmm(am2,am3,b) + call psb_symbmm(op_restr,am3,ac,info) + if (info == psb_success_) call psb_numbmm(op_restr,am3,ac) if (info == psb_success_) call am3%free() - if (info == psb_success_) call b%cscnv(info,type='coo',dupl=psb_dupl_add_) + if (info == psb_success_) call ac%cscnv(info,type='coo',dupl=psb_dupl_add_) if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,a_err='Build b = am2 x am3') - goto 9999 - end if - - - - select case(p%parms%aggr_kind) - - case(mld_smooth_prol_) - - select case(p%parms%coarse_mat) - - case(mld_distr_mat_) - - nzac = b%get_nzeros() - nzl = nzac - call b%mv_to(bcoo) - - if (info == psb_success_) call psb_cdall(ictxt,p%desc_ac,info,nl=nlaggr(me+1)) - if (info == psb_success_) call psb_cdins(nzl,bcoo%ia,bcoo%ja,p%desc_ac,info) - if (info == psb_success_) call psb_cdasb(p%desc_ac,info) - if (info == psb_success_) call psb_glob_to_loc(bcoo%ia(1:nzl),p%desc_ac,info,iact='I') - if (info == psb_success_) call psb_glob_to_loc(bcoo%ja(1:nzl),p%desc_ac,info,iact='I') - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Creating p%desc_ac and converting ac') - goto 9999 - end if - if (debug_level >= psb_debug_outer_) & - & write(debug_unit,*) me,' ',trim(name),& - & 'Assembld aux descr. distr.' - call p%ac%mv_from(bcoo) - - call p%ac%set_nrows(p%desc_ac%get_local_rows()) - call p%ac%set_ncols(p%desc_ac%get_local_cols()) - call p%ac%set_asb() - - if (info == psb_success_) deallocate(nzbr,idisp,stat=info) - if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_sp_free') - goto 9999 - end if - - if (np>1) then - call am1%mv_to(acsr1) - nzl = acsr1%get_nzeros() - call psb_glob_to_loc(acsr1%ja(1:nzl),p%desc_ac,info,'I') - if(info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_glob_to_loc') - goto 9999 - end if - call am1%mv_from(acsr1) - endif - call am1%set_ncols(p%desc_ac%get_local_cols()) - - if (np>1) then - call am2%cscnv(info,type='coo',dupl=psb_dupl_add_) - call am2%mv_to(acoo) - nzl = acoo%get_nzeros() - if (info == psb_success_) call psb_glob_to_loc(acoo%ia(1:nzl),p%desc_ac,info,'I') - call acoo%set_dupl(psb_dupl_add_) - if (info == psb_success_) call am2%mv_from(acoo) - if (info == psb_success_) call am2%cscnv(info,type='csr') - if(info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,a_err='Converting am2 to local') - goto 9999 - end if - end if - call am2%set_nrows(p%desc_ac%get_local_cols()) - - if (debug_level >= psb_debug_outer_) & - & write(debug_unit,*) me,' ',trim(name),& - & 'Done ac ' - - case(mld_repl_mat_) - ! - ! - call psb_cdall(ictxt,p%desc_ac,info,mg=ntaggr,repl=.true.) - if (info == psb_success_) call psb_cdasb(p%desc_ac,info) - if (info == psb_success_) & - & call psb_gather(p%ac,b,p%desc_ac,info,dupl=psb_dupl_add_,keeploc=.false.) - - if (info /= psb_success_) goto 9999 - - deallocate(nzbr,idisp,stat=info) - if (info /= psb_success_) then - info = psb_err_alloc_dealloc_ - call psb_errpush(info,name) - goto 9999 - end if - case default - info = psb_err_internal_error_ - call psb_errpush(info,name,a_err='invalid mld_coarse_mat_') - goto 9999 - end select - - - case(mld_biz_prol_) - - select case(p%parms%coarse_mat) - - case(mld_distr_mat_) - - call psb_move_alloc(b,p%ac,info) - if (info == psb_success_) call psb_cdall(ictxt,p%desc_ac,info,nl=naggr) - if (info == psb_success_) call psb_cdasb(p%desc_ac,info) - if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='Build desc_ac, ac') - goto 9999 - end if - - - case(mld_repl_mat_) - ! - ! - call psb_cdall(ictxt,p%desc_ac,info,mg=ntaggr,repl=.true.) - if (info == psb_success_) call psb_cdasb(p%desc_ac,info) - if(info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_cdall') - goto 9999 - end if - call psb_gather(p%ac,b,p%desc_ac,info,dupl=psb_dupl_add_,keeploc=.false.) - if(info /= psb_success_) goto 9999 - - deallocate(nzbr,idisp,stat=info) - if (info /= psb_success_) then - info = psb_err_alloc_dealloc_ - call psb_errpush(info,name) - goto 9999 - end if - - case default - info = psb_err_internal_error_ - call psb_errpush(info,name,a_err='invalid mld_coarse_mat_') - goto 9999 - end select - - deallocate(nzbr,idisp,stat=info) - if (info /= psb_success_) then - info = psb_err_alloc_dealloc_ - call psb_errpush(info,name) - goto 9999 - end if - - case default - info = psb_err_internal_error_ - call psb_errpush(info,name,a_err='invalid mld_smooth_prol_') - goto 9999 - - end select - - call p%ac%cscnv(info,type='csr',dupl=psb_dupl_add_) - if(info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='spcnv') - goto 9999 - end if - - ! - ! Copy the prolongation/restriction matrices into the descriptor map. - ! am2 => PR^T i.e. restriction operator - ! am1 => PR i.e. prolongation operator - ! - - p%map = psb_linmap(psb_map_aggr_,desc_a,& - & p%desc_ac,am2,am1,ilaggr,nlaggr) - if (info == psb_success_) call am1%free() - if (info == psb_success_) call am2%free() - if(info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='sp_Free') + call psb_errpush(psb_err_internal_error_,name,a_err='Build ac = op_restr x am3') goto 9999 end if diff --git a/mlprec/impl/mld_smlprec_bld.f90 b/mlprec/impl/mld_smlprec_bld.f90 index d49576d6..de9e23fe 100644 --- a/mlprec/impl/mld_smlprec_bld.f90 +++ b/mlprec/impl/mld_smlprec_bld.f90 @@ -93,11 +93,13 @@ subroutine mld_smlprec_bld(a,desc_a,p,info,amold,vmold) ! Local Variables type(mld_sprec_type) :: t_prec - Integer :: err,i,k,ictxt, me,np, err_act, iszv, newsz + Integer :: err,i,k,ictxt, me,np, err_act, iszv, newsz, casize integer :: ipv(mld_ifpsz_), val integer :: int_err(5) character :: upd_ - type(mld_sml_parms) :: prm + class(mld_s_base_smoother_type), allocatable :: coarse_sm, base_sm, med_sm + type(mld_sml_parms) :: baseparms, medparms, coarseparms + type(mld_s_onelev_node), pointer :: head, tail, newnode, current integer :: debug_level, debug_unit character(len=20) :: name, ch_err @@ -145,12 +147,22 @@ subroutine mld_smlprec_bld(a,desc_a,p,info,amold,vmold) ! Check to ensure all procs have the same ! newsz = -1 + casize = p%coarse_aggr_size iszv = size(p%precv) call psb_bcast(ictxt,iszv) - if (iszv /= size(p%precv)) then - info=psb_err_internal_error_ - call psb_errpush(info,name,a_err='Inconsistent size of precv') - goto 9999 + call psb_bcast(ictxt,casize) + if (casize > 0) then + if (casize /= p%coarse_aggr_size) then + info=psb_err_internal_error_ + call psb_errpush(info,name,a_err='Inconsistent coarse_aggr_size') + goto 9999 + end if + else + if (iszv /= size(p%precv)) then + info=psb_err_internal_error_ + call psb_errpush(info,name,a_err='Inconsistent size of precv') + goto 9999 + end if end if if (iszv <= 1) then @@ -162,7 +174,161 @@ subroutine mld_smlprec_bld(a,desc_a,p,info,amold,vmold) endif - if (iszv > 1) then + + if (casize>0) then + ! + ! New strategy to build according to coarse size. + ! + coarseparms = p%precv(iszv)%parms + baseparms = p%precv(1)%parms + medparms = p%precv(2)%parms + + allocate(coarse_sm, source=p%precv(iszv)%sm,stat=info) + if (info == psb_success_) & + & allocate(med_sm, source=p%precv(2)%sm,stat=info) + if (info == psb_success_) & + & allocate(base_sm, source=p%precv(1)%sm,stat=info) + if (info /= psb_success_) then + write(0,*) 'Error in saving smoothers',info + call psb_errpush(psb_err_internal_error_,name,a_err='Base level precbuild.') + goto 9999 + end if + ! + ! Replicated matrix should only ever happen at coarse level. + ! + call mld_check_def(baseparms%coarse_mat,'Coarse matrix',& + & mld_distr_mat_,is_distr_ml_coarse_mat) + ! + ! Now build a doubly linked list + ! + allocate(newnode,stat=info) + if (info /= psb_success_) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='List start'); goto 9999 + end if + head => newnode + tail => newnode + newnode%item%base_a => a + newnode%item%base_desc => desc_a + newnode%item%parms = baseparms + newsz = 1 + current => head + list_build_loop: do + allocate(newnode,stat=info) + if (info /= psb_success_) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='List start'); goto 9999 + end if + current%next => newnode + newnode%prev => current + newsz = newsz + 1 + newnode%item%parms = medparms + newnode%item%parms%aggr_thresh = current%item%parms%aggr_thresh/2 + call mld_coarse_bld(current%item%base_a, current%item%base_desc, & + & newnode%item,info) + if (info /= psb_success_) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='build next level'); goto 9999 + end if + + if (newsz>2) then + if (all(current%item%map%naggr == newnode%item%map%naggr)) then + ! + ! We are not gaining anything + ! + newsz = newsz-1 + current%next => null() + call newnode%item%free(info) + if (info == psb_success_) deallocate(newnode,stat=info) + if (info /= psb_success_) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='Deallocate at list end'); goto 9999 + end if + end if + end if + + current => current%next + tail => current + if (sum(newnode%item%map%naggr) <= casize) then + ! + ! Target reached; but we may need to rebuild. + ! + exit list_build_loop + end if + end do list_build_loop + ! + ! At this point, we are at the list tail, + ! and it needs to be rebuilt in case the parms were + ! different. + ! + ! But the threshold has to be fixed before rebuliding + coarseparms%aggr_thresh = current%item%parms%aggr_thresh + current%item%parms = coarseparms + call mld_coarse_bld(current%prev%item%base_a,& + & current%prev%item%base_desc, & + & current%item,info) + if (info /= psb_success_) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='build next level'); goto 9999 + end if + + ! + ! Ok, now allocate the output vector and fix items. + ! + do i=1,iszv + if (info == psb_success_) call p%precv(i)%free(info) + end do + if (info == psb_success_) deallocate(p%precv,stat=info) + if (info == psb_success_) allocate(p%precv(newsz),stat=info) + if (info /= psb_success_) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='Reallocate precv'); goto 9999 + end if + newnode => head + do i=1, newsz + current => newnode + if (info == psb_success_) & + & call mld_move_alloc(current%item,p%precv(i),info) + if (info == psb_success_) then + if (i ==1) then + allocate(p%precv(i)%sm,source=base_sm,stat=info) + else if (i < newsz) then + allocate(p%precv(i)%sm,source=med_sm,stat=info) + else + allocate(p%precv(i)%sm,source=coarse_sm,stat=info) + end if + end if + if (info /= psb_success_) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='list cpy'); goto 9999 + end if + if (i == 1) then + p%precv(i)%base_a => a + p%precv(i)%base_desc => desc_a + else + p%precv(i)%base_a => p%precv(i)%ac + p%precv(i)%base_desc => p%precv(i)%desc_ac + p%precv(i)%map%p_desc_X => p%precv(i-1)%base_desc + p%precv(i)%map%p_desc_Y => p%precv(i)%base_desc + end if + + newnode => current%next + deallocate(current) + end do + call base_sm%free(info) + if (info == psb_success_) call med_sm%free(info) + if (info == psb_success_) call coarse_sm%free(info) + if (info == psb_success_) deallocate(coarse_sm,med_sm,base_sm,stat=info) + if (info /= psb_success_) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='final cleanup'); goto 9999 + end if + iszv = newsz + + else + ! + ! Default, oldstyle + ! ! ! Build the matrix and the transfer operators corresponding @@ -179,11 +345,6 @@ subroutine mld_smlprec_bld(a,desc_a,p,info,amold,vmold) p%precv(1)%base_a => a p%precv(1)%base_desc => desc_a - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,a_err='Base level precbuild.') - goto 9999 - end if - do i=2, iszv ! @@ -201,11 +362,6 @@ subroutine mld_smlprec_bld(a,desc_a,p,info,amold,vmold) ! call mld_check_def(p%precv(i)%parms%coarse_mat,'Coarse matrix',& & mld_distr_mat_,is_distr_ml_coarse_mat) - - else if (i == iszv) then - -!!$ call check_coarse_lev(p%precv(i)) - end if if (debug_level >= psb_debug_outer_) & @@ -277,9 +433,7 @@ subroutine mld_smlprec_bld(a,desc_a,p,info,amold,vmold) p%precv(i)%map%p_desc_Y => p%precv(i)%base_desc end do - i = iszv - call check_coarse_lev(p%precv(i)) if (info == psb_success_) call mld_coarse_bld(p%precv(i-1)%base_a,& & p%precv(i-1)%base_desc, p%precv(i),info) if (info /= psb_success_) then @@ -289,6 +443,12 @@ subroutine mld_smlprec_bld(a,desc_a,p,info,amold,vmold) end if end if + ! + ! The coarse space hierarchy has been build. + ! + ! Now do the preconditioner build. + ! + do i=1, iszv ! ! build the base preconditioner at level i @@ -316,10 +476,6 @@ subroutine mld_smlprec_bld(a,desc_a,p,info,amold,vmold) goto 9999 end if - - ! - ! Test version for beginning of OO stuff. - ! call p%precv(i)%sm%build(p%precv(i)%base_a,p%precv(i)%base_desc,& & 'F',info,amold=amold,vmold=vmold) @@ -350,69 +506,4 @@ subroutine mld_smlprec_bld(a,desc_a,p,info,amold,vmold) end if return -contains - - subroutine check_coarse_lev(prec) - type(mld_s_onelev_type) :: prec - - ! - ! At the coarsest level, check mld_coarse_solve_ - ! -!!$ val = prec%parms%coarse_solve -!!$ select case (val) -!!$ case(mld_jac_) -!!$ -!!$ if (prec%prec%iprcparm(mld_sub_solve_) /= mld_diag_scale_) then -!!$ if (me == 0) write(debug_unit,*)& -!!$ & 'Warning: inconsistent coarse level specification.' -!!$ if (me == 0) write(debug_unit,*)& -!!$ & ' Resetting according to the value specified for mld_coarse_solve_.' -!!$ prec%prec%iprcparm(mld_sub_solve_) = mld_diag_scale_ -!!$ end if -!!$ prec%prec%iprcparm(mld_smoother_type_) = mld_jac_ -!!$ -!!$ case(mld_bjac_) -!!$ -!!$ if ((prec%prec%iprcparm(mld_sub_solve_) == mld_diag_scale_).or.& -!!$ & ( prec%prec%iprcparm(mld_smoother_type_) /= mld_bjac_)) then -!!$ if (me == 0) write(debug_unit,*)& -!!$ & 'Warning: inconsistent coarse level specification.' -!!$ if (me == 0) write(debug_unit,*)& -!!$ & ' Resetting according to the value specified for mld_coarse_solve_.' -!!$! !$#if defined(HAVE_UMF_) -!!$! !$ prec%prec%iprcparm(mld_sub_solve_) = mld_umf_ -!!$! !$#elif defined(HAVE_SLU_) -!!$! !$ prec%prec%iprcparm(mld_sub_solve_) = mld_slu_ -!!$! !$#else -!!$ prec%prec%iprcparm(mld_sub_solve_) = mld_ilu_n_ -!!$! !$#endif -!!$ end if -!!$ prec%prec%iprcparm(mld_smoother_type_) = mld_bjac_ -!!$ -!!$ case(mld_umf_, mld_slu_) -!!$ if ((prec%iprcparm(mld_coarse_mat_) /= mld_repl_mat_).or.& -!!$ & (prec%prec%iprcparm(mld_sub_solve_) /= val)) then -!!$ if (me == 0) write(debug_unit,*)& -!!$ & 'Warning: inconsistent coarse level specification.' -!!$ if (me == 0) write(debug_unit,*)& -!!$ & ' Resetting according to the value specified for mld_coarse_solve_.' -!!$ prec%iprcparm(mld_coarse_mat_) = mld_repl_mat_ -!!$ prec%prec%iprcparm(mld_sub_solve_) = val -!!$ prec%prec%iprcparm(mld_smoother_type_) = mld_bjac_ -!!$ end if -!!$ case(mld_sludist_) -!!$ if ((prec%iprcparm(mld_coarse_mat_) /= mld_distr_mat_).or.& -!!$ & (prec%prec%iprcparm(mld_sub_solve_) /= val)) then -!!$ if (me == 0) write(debug_unit,*)& -!!$ & 'Warning: inconsistent coarse level specification.' -!!$ if (me == 0) write(debug_unit,*)& -!!$ & ' Resetting according to the value specified for mld_coarse_solve_.' -!!$ prec%iprcparm(mld_coarse_mat_) = mld_distr_mat_ -!!$ prec%prec%iprcparm(mld_sub_solve_) = val -!!$ prec%prec%iprcparm(mld_smoother_type_) = mld_bjac_ -!!$ prec%prec%iprcparm(mld_smoother_sweeps_) = 1 -!!$ end if -!!$ end select - end subroutine check_coarse_lev - end subroutine mld_smlprec_bld diff --git a/mlprec/impl/mld_sprecinit.F90 b/mlprec/impl/mld_sprecinit.F90 index 12d10d9e..d8b66f83 100644 --- a/mlprec/impl/mld_sprecinit.F90 +++ b/mlprec/impl/mld_sprecinit.F90 @@ -125,6 +125,7 @@ subroutine mld_sprecinit(p,ptype,info,nlev) ! Do we want to do something? endif endif + p%coarse_aggr_size = -1 select case(psb_toupper(ptype(1:len_trim(ptype)))) case ('NOPREC','NONE') diff --git a/mlprec/impl/mld_sprecset.F90 b/mlprec/impl/mld_sprecset.F90 index 0c8f3fa6..895e5b89 100644 --- a/mlprec/impl/mld_sprecset.F90 +++ b/mlprec/impl/mld_sprecset.F90 @@ -129,6 +129,11 @@ subroutine mld_sprecseti(p,what,val,info,ilev) return endif + if (what == mld_coarse_aggr_size_) then + p%coarse_aggr_size = max(val,-1) + return + end if + ! ! Set preconditioner parameters at level ilev. ! diff --git a/mlprec/impl/mld_z_onelev_impl.f90 b/mlprec/impl/mld_z_onelev_impl.f90 index 1bdc04de..68f20bab 100644 --- a/mlprec/impl/mld_z_onelev_impl.f90 +++ b/mlprec/impl/mld_z_onelev_impl.f90 @@ -154,7 +154,7 @@ subroutine mld_z_base_onelev_free(lv,info) & call lv%sm%free(info) call lv%ac%free() - if (psb_is_ok_desc(lv%desc_ac)) & + if (lv%desc_ac%is_ok()) & & call psb_cdfree(lv%desc_ac,info) call lv%map%free(info) diff --git a/mlprec/impl/mld_zaggrmat_asb.f90 b/mlprec/impl/mld_zaggrmat_asb.f90 index 91f14443..f0d0e55a 100644 --- a/mlprec/impl/mld_zaggrmat_asb.f90 +++ b/mlprec/impl/mld_zaggrmat_asb.f90 @@ -113,6 +113,11 @@ subroutine mld_zaggrmat_asb(a,desc_a,ilaggr,nlaggr,p,info) integer, intent(out) :: info ! Local variables + type(psb_zspmat_type) :: ac, op_prol,op_restr + type(psb_z_coo_sparse_mat) :: acoo, bcoo + type(psb_z_csr_sparse_mat) :: acsr1 + integer :: nzl,ntaggr + integer :: debug_level, debug_unit integer :: ictxt,np,me, err_act character(len=20) :: name @@ -120,6 +125,9 @@ subroutine mld_zaggrmat_asb(a,desc_a,ilaggr,nlaggr,p,info) if(psb_get_errstatus().ne.0) return info=psb_success_ call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + ictxt = desc_a%get_context() @@ -128,35 +136,139 @@ subroutine mld_zaggrmat_asb(a,desc_a,ilaggr,nlaggr,p,info) select case (p%parms%aggr_kind) case (mld_no_smooth_) - call mld_aggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,p,info) - if(info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='mld_aggrmat_nosmth_asb') + call mld_zaggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,& + & p%parms,ac,op_prol,op_restr,info) + + case(mld_smooth_prol_) + + call mld_zaggrmat_smth_asb(a,desc_a,ilaggr,nlaggr, & + & p%parms,ac,op_prol,op_restr,info) + + case(mld_biz_prol_) + + call mld_zaggrmat_biz_asb(a,desc_a,ilaggr,nlaggr, & + & p%parms,ac,op_prol,op_restr,info) + + case(mld_min_energy_) + + call mld_zaggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr, & + & p%parms,ac,op_prol,op_restr,info) + + case default + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='Invalid aggr kind') + goto 9999 + + end select + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='Inner aggrmat asb') + goto 9999 + end if + + + + ntaggr = sum(nlaggr) + + select case(p%parms%coarse_mat) + + case(mld_distr_mat_) + + nzl = ac%get_nzeros() + call ac%mv_to(bcoo) + + if (info == psb_success_) call psb_cdall(ictxt,p%desc_ac,info,nl=nlaggr(me+1)) + if (info == psb_success_) call psb_cdins(nzl,bcoo%ia,bcoo%ja,p%desc_ac,info) + if (info == psb_success_) call psb_cdasb(p%desc_ac,info) + if (info == psb_success_) call psb_glob_to_loc(bcoo%ia(1:nzl),p%desc_ac,info,iact='I') + if (info == psb_success_) call psb_glob_to_loc(bcoo%ja(1:nzl),p%desc_ac,info,iact='I') + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Creating p%desc_ac and converting ac') goto 9999 end if + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & 'Assembld aux descr. distr.' + call p%ac%mv_from(bcoo) - case(mld_smooth_prol_,mld_biz_prol_) + call p%ac%set_nrows(p%desc_ac%get_local_rows()) + call p%ac%set_ncols(p%desc_ac%get_local_cols()) + call p%ac%set_asb() - call mld_aggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info) - if(info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='mld_aggrmat_smth_asb') + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_sp_free') goto 9999 end if - case(mld_min_energy_) + if (np>1) then + call op_prol%mv_to(acsr1) + nzl = acsr1%get_nzeros() + call psb_glob_to_loc(acsr1%ja(1:nzl),p%desc_ac,info,'I') + if(info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_glob_to_loc') + goto 9999 + end if + call op_prol%mv_from(acsr1) + endif + call op_prol%set_ncols(p%desc_ac%get_local_cols()) - call mld_aggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info) - if(info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='mld_aggrmat_smth_asb') - goto 9999 + if (np>1) then + call op_restr%cscnv(info,type='coo',dupl=psb_dupl_add_) + call op_restr%mv_to(acoo) + nzl = acoo%get_nzeros() + if (info == psb_success_) call psb_glob_to_loc(acoo%ia(1:nzl),p%desc_ac,info,'I') + call acoo%set_dupl(psb_dupl_add_) + if (info == psb_success_) call op_restr%mv_from(acoo) + if (info == psb_success_) call op_restr%cscnv(info,type='csr') + if(info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,a_err='Converting op_restr to local') + goto 9999 + end if end if + call op_restr%set_nrows(p%desc_ac%get_local_cols()) - case default + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & 'Done ac ' - call psb_errpush(psb_err_internal_error_,name,a_err='Invalid aggr kind') - goto 9999 + case(mld_repl_mat_) + ! + ! + call psb_cdall(ictxt,p%desc_ac,info,mg=ntaggr,repl=.true.) + if (info == psb_success_) call psb_cdasb(p%desc_ac,info) + if (info == psb_success_) & + & call psb_gather(p%ac,ac,p%desc_ac,info,dupl=psb_dupl_add_,keeploc=.false.) + + if (info /= psb_success_) goto 9999 + case default + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='invalid mld_coarse_mat_') + goto 9999 end select + call p%ac%cscnv(info,type='csr',dupl=psb_dupl_add_) + if(info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='spcnv') + goto 9999 + end if + + ! + ! Copy the prolongation/restriction matrices into the descriptor map. + ! op_restr => PR^T i.e. restriction operator + ! op_prol => PR i.e. prolongation operator + ! + + p%map = psb_linmap(psb_map_aggr_,desc_a,& + & p%desc_ac,op_restr,op_prol,ilaggr,nlaggr) + if (info == psb_success_) call op_prol%free() + if (info == psb_success_) call op_restr%free() + if(info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='sp_Free') + goto 9999 + end if + + call psb_erractionrestore(err_act) return diff --git a/mlprec/impl/mld_zaggrmat_biz_asb.f90 b/mlprec/impl/mld_zaggrmat_biz_asb.f90 new file mode 100644 index 00000000..f8d945f7 --- /dev/null +++ b/mlprec/impl/mld_zaggrmat_biz_asb.f90 @@ -0,0 +1,422 @@ +!!$ +!!$ +!!$ MLD2P4 version 2.0 +!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package +!!$ based on PSBLAS (Parallel Sparse BLAS version 3.0) +!!$ +!!$ (C) Copyright 2008,2009,2010 +!!$ +!!$ Salvatore Filippone University of Rome Tor Vergata +!!$ Alfredo Buttari CNRS-IRIT, Toulouse +!!$ Pasqua D'Ambra ICAR-CNR, Naples +!!$ Daniela di Serafino Second University of Naples +!!$ +!!$ Redistribution and use in source and binary forms, with or without +!!$ modification, are permitted provided that the following conditions +!!$ are met: +!!$ 1. Redistributions of source code must retain the above copyright +!!$ notice, this list of conditions and the following disclaimer. +!!$ 2. Redistributions in binary form must reproduce the above copyright +!!$ notice, this list of conditions, and the following disclaimer in the +!!$ documentation and/or other materials provided with the distribution. +!!$ 3. The name of the MLD2P4 group or the names of its contributors may +!!$ not be used to endorse or promote products derived from this +!!$ software without specific written permission. +!!$ +!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE MLD2P4 GROUP OR ITS CONTRIBUTORS +!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +!!$ POSSIBILITY OF SUCH DAMAGE. +!!$ +!!$ +! File: mld_zaggrmat_biz_asb.F90 +! +! Subroutine: mld_zaggrmat_biz_asb +! Version: complex +! +! This routine builds a coarse-level matrix A_C from a fine-level matrix A +! by using the Galerkin approach, i.e. +! +! A_C = P_C^T A P_C, +! +! where P_C is a prolongator from the coarse level to the fine one. +! +! This routine builds A_C according to a "bizarre" aggregation algorithm, +! using a "naive" prolongator proposed by the authors of MLD2P4. However, this +! prolongator still requires a deep analysis and testing and its use is not +! recommended. +! +! The coarse-level matrix A_C is distributed among the parallel processes or +! replicated on each of them, according to the value of p%parms%coarse_mat, +! specified by the user through mld_zprecinit and mld_zprecset. +! +! Arguments: +! a - type(psb_zspmat_type), input. +! The sparse matrix structure containing the local part of +! the fine-level matrix. +! desc_a - type(psb_desc_type), input. +! The communication descriptor of the fine-level matrix. +! p - type(mld_z_onelev_type), input/output. +! The 'one-level' data structure that will contain the local +! part of the matrix to be built as well as the information +! concerning the prolongator and its transpose. +! ilaggr - integer, dimension(:), allocatable. +! The mapping between the row indices of the coarse-level +! matrix and the row indices of the fine-level matrix. +! ilaggr(i)=j means that node i in the adjacency graph +! of the fine-level matrix is mapped onto node j in the +! adjacency graph of the coarse-level matrix. +! nlaggr - integer, dimension(:), allocatable. +! nlaggr(i) contains the aggregates held by process i. +! info - integer, output. +! Error code. +! +subroutine mld_zaggrmat_biz_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_restr,info) + use psb_base_mod + use mld_z_inner_mod, mld_protect_name => mld_zaggrmat_biz_asb + + implicit none + + ! Arguments + type(psb_zspmat_type), intent(in) :: a + type(psb_desc_type), intent(in) :: desc_a + integer, intent(inout) :: ilaggr(:), nlaggr(:) + type(mld_dml_parms), intent(inout) :: parms + type(psb_zspmat_type), intent(out) :: ac,op_prol,op_restr + integer, intent(out) :: info + + ! Local variables + integer :: nrow, nglob, ncol, ntaggr, ip, ndx,& + & naggr, nzl,naggrm1,naggrp1, i, j, k, jd, icolF, nrw + integer ::ictxt, np, me, err_act + character(len=20) :: name + type(psb_zspmat_type) :: am3, am4 + type(psb_z_coo_sparse_mat) :: tmpcoo + type(psb_z_csr_sparse_mat) :: acsr1, acsr2, acsr3, acsrf, ptilde + complex(psb_dpk_), allocatable :: adiag(:) + integer(psb_ipk_) :: ierr(5) + logical :: filter_mat + integer :: debug_level, debug_unit + integer, parameter :: ncmax=16 + real(psb_dpk_) :: anorm, omega, tmp, dg, theta + + name='mld_aggrmat_biz_asb' + if(psb_get_errstatus().ne.0) return + info=psb_success_ + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + ictxt = desc_a%get_context() + ictxt = desc_a%get_context() + + call psb_info(ictxt, me, np) + + nglob = desc_a%get_global_rows() + nrow = desc_a%get_local_rows() + ncol = desc_a%get_local_cols() + + theta = parms%aggr_thresh + + naggr = nlaggr(me+1) + ntaggr = sum(nlaggr) + + naggrm1 = sum(nlaggr(1:me)) + naggrp1 = sum(nlaggr(1:me+1)) + + filter_mat = (parms%aggr_filter == mld_filter_mat_) + + ilaggr(1:nrow) = ilaggr(1:nrow) + naggrm1 + call psb_halo(ilaggr,desc_a,info) + + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_halo') + goto 9999 + end if + + ! naggr: number of local aggregates + ! nrow: local rows. + ! + allocate(adiag(ncol),stat=info) + + if (info /= psb_success_) then + info=psb_err_alloc_request_; ierr(1)=nrow; + call psb_errpush(info,name,i_err=ierr,a_err='complex(psb_dpk_)') + goto 9999 + end if + + ! Get the diagonal D + call a%get_diag(adiag,info) + if (info == psb_success_) & + & call psb_halo(adiag,desc_a,info) + + if(info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='sp_getdiag') + goto 9999 + end if + + ! 1. Allocate Ptilde in sparse matrix form + call tmpcoo%allocate(ncol,naggr,ncol) + do i=1,nrow + tmpcoo%val(i) = zone + tmpcoo%ia(i) = i + tmpcoo%ja(i) = ilaggr(i) + end do + call tmpcoo%set_nzeros(nrow) + call tmpcoo%set_dupl(psb_dupl_add_) + + call ptilde%mv_from_coo(tmpcoo,info) + if (info == psb_success_) call a%cscnv(acsr3,info,dupl=psb_dupl_add_) + + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & ' Initial copies sone.' + + if (filter_mat) then + ! + ! Build the filtered matrix Af from A + ! + if (info == psb_success_) call a%cscnv(acsrf,info,dupl=psb_dupl_add_) + + do i=1,nrow + tmp = zzero + jd = -1 + do j=acsrf%irp(i),acsrf%irp(i+1)-1 + if (acsrf%ja(j) == i) jd = j + if (abs(acsrf%val(j)) < theta*sqrt(abs(adiag(i)*adiag(acsrf%ja(j))))) then + tmp=tmp+acsrf%val(j) + acsrf%val(j)=zzero + endif + + enddo + if (jd == -1) then + write(0,*) 'Wrong input: we need the diagonal!!!!', i + else + acsrf%val(jd)=acsrf%val(jd)-tmp + end if + enddo + ! Take out zeroed terms + call acsrf%mv_to_coo(tmpcoo,info) + k = 0 + do j=1,tmpcoo%get_nzeros() + if ((tmpcoo%val(j) /= zzero) .or. (tmpcoo%ia(j) == tmpcoo%ja(j))) then + k = k + 1 + tmpcoo%val(k) = tmpcoo%val(j) + tmpcoo%ia(k) = tmpcoo%ia(j) + tmpcoo%ja(k) = tmpcoo%ja(j) + end if + end do + call tmpcoo%set_nzeros(k) + call tmpcoo%set_dupl(psb_dupl_add_) + call acsrf%mv_from_coo(tmpcoo,info) + end if + + + do i=1,size(adiag) + if (adiag(i) /= zzero) then + adiag(i) = zone / adiag(i) + else + adiag(i) = zone + end if + end do + + if (filter_mat) call acsrf%scal(adiag,info) + if (info == psb_success_) call acsr3%scal(adiag,info) + if (info /= psb_success_) goto 9999 + + + if (parms%aggr_omega_alg == mld_eig_est_) then + + if (parms%aggr_eig == mld_max_norm_) then + + ! + ! This only works with CSR + ! + anorm = dzero + dg = done + nrw = acsr3%get_nrows() + do i=1, nrw + tmp = dzero + do j=acsr3%irp(i),acsr3%irp(i+1)-1 + if (acsr3%ja(j) <= nrw) then + tmp = tmp + abs(acsr3%val(j)) + endif + if (acsr3%ja(j) == i ) then + dg = abs(acsr3%val(j)) + end if + end do + anorm = max(anorm,tmp/dg) + enddo + + call psb_amx(ictxt,anorm) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,a_err='Invalid AM3 storage format') + goto 9999 + end if + omega = 4.d0/(3.d0*anorm) + parms%aggr_omega_val = omega + + else + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='invalid mld_aggr_eig_') + goto 9999 + end if + + else if (parms%aggr_omega_alg == mld_user_choice_) then + + omega = parms%aggr_omega_val + + else if (parms%aggr_omega_alg /= mld_user_choice_) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='invalid mld_aggr_omega_alg_') + goto 9999 + end if + + if (filter_mat) then + ! + ! Build the smoothed prolongator using the filtered matrix + ! + do i=1,acsrf%get_nrows() + do j=acsrf%irp(i),acsrf%irp(i+1)-1 + if (acsrf%ja(j) == i) then + acsrf%val(j) = zone - omega*acsrf%val(j) + else + acsrf%val(j) = - omega*acsrf%val(j) + end if + end do + end do + + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & 'Done gather, going for SYMBMM 1' + ! + ! Symbmm90 does the allocation for its result. + ! + ! acsrm1 = (I-w*D*Af)Ptilde + ! Doing it this way means to consider diag(Af_i) + ! + ! + call psb_symbmm(acsrf,ptilde,acsr1,info) + if(info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='symbmm 1') + goto 9999 + end if + + call psb_numbmm(acsrf,ptilde,acsr1) + + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & 'Done NUMBMM 1' + + else + ! + ! Build the smoothed prolongator using the original matrix + ! + do i=1,acsr3%get_nrows() + do j=acsr3%irp(i),acsr3%irp(i+1)-1 + if (acsr3%ja(j) == i) then + acsr3%val(j) = zone - omega*acsr3%val(j) + else + acsr3%val(j) = - omega*acsr3%val(j) + end if + end do + end do + + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & 'Done gather, going for SYMBMM 1' + ! + ! Symbmm90 does the allocation for its result. + ! + ! acsrm1 = (I-w*D*A)Ptilde + ! Doing it this way means to consider diag(A_i) + ! + ! + call psb_symbmm(acsr3,ptilde,acsr1,info) + if(info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='symbmm 1') + goto 9999 + end if + + call psb_numbmm(acsr3,ptilde,acsr1) + + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & 'Done NUMBMM 1' + + end if + call ptilde%free() + call acsr1%set_dupl(psb_dupl_add_) + + call op_prol%mv_from(acsr1) + + call psb_rwextd(ncol,op_prol,info) + if(info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,a_err='Halo of op_prol') + goto 9999 + end if + + call psb_symbmm(a,op_prol,am3,info) + if(info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='symbmm 2') + goto 9999 + end if + + call psb_numbmm(a,op_prol,am3) + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & 'Done NUMBMM 2',parms%aggr_kind, mld_smooth_prol_ + + call op_prol%transp(op_restr) + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & 'starting sphalo/ rwxtd' + + call psb_rwextd(ncol,am3,info) + if(info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,a_err='Extend am3') + goto 9999 + end if + + + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & 'starting symbmm 3' + call psb_symbmm(op_restr,am3,ac,info) + if (info == psb_success_) call psb_numbmm(op_restr,am3,ac) + if (info == psb_success_) call am3%free() + if (info == psb_success_) call ac%cscnv(info,type='coo',dupl=psb_dupl_add_) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,a_err='Build b = op_restr x am3') + goto 9999 + end if + + + + + + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),& + & 'Done smooth_aggregate ' + call psb_erractionrestore(err_act) + return + +9999 continue + call psb_errpush(info,name) + call psb_erractionrestore(err_act) + if (err_act.eq.psb_act_abort_) then + call psb_error() + return + end if + return + + + +end subroutine mld_zaggrmat_biz_asb diff --git a/mlprec/impl/mld_zaggrmat_minnrg_asb.F90 b/mlprec/impl/mld_zaggrmat_minnrg_asb.f90 similarity index 77% rename from mlprec/impl/mld_zaggrmat_minnrg_asb.F90 rename to mlprec/impl/mld_zaggrmat_minnrg_asb.f90 index fd72fe7e..fc76615a 100644 --- a/mlprec/impl/mld_zaggrmat_minnrg_asb.F90 +++ b/mlprec/impl/mld_zaggrmat_minnrg_asb.f90 @@ -98,37 +98,31 @@ ! info - integer, output. ! Error code. ! -subroutine mld_zaggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info) +subroutine mld_zaggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_restr,info) use psb_base_mod use mld_z_inner_mod, mld_protect_name => mld_zaggrmat_minnrg_asb -#ifdef MPI_MOD - use mpi -#endif implicit none -#ifdef MPI_H - include 'mpif.h' -#endif ! Arguments type(psb_zspmat_type), intent(in) :: a type(psb_desc_type), intent(in) :: desc_a integer, intent(inout) :: ilaggr(:), nlaggr(:) - type(mld_z_onelev_type), intent(inout), target :: p + type(mld_dml_parms), intent(inout) :: parms + type(psb_zspmat_type), intent(out) :: ac,op_prol,op_restr integer, intent(out) :: info ! Local variables - type(psb_zspmat_type) :: b integer(psb_mpik_), allocatable :: nzbr(:), idisp(:) integer :: nrow, nglob, ncol, ntaggr, nzac, ip, ndx,& & naggr, nzl,naggrm1,naggrp1, i, j, k, jd, icolF, nrt integer :: ictxt,np,me, err_act, icomm character(len=20) :: name - type(psb_zspmat_type) :: am1,am2, af, ptilde, rtilde, atran, atp, atdatp + type(psb_zspmat_type) :: af, ptilde, rtilde, atran, atp, atdatp type(psb_zspmat_type) :: am3,am4, ap, adap,atmp,rada, ra, atmp2, dap, dadap, da type(psb_zspmat_type) :: dat, datp, datdatp, atmp3 - type(psb_z_coo_sparse_mat) :: acoo, acoof, bcoo, tmpcoo - type(psb_z_csr_sparse_mat) :: acsr1, acsr2, acsr3, bcsr, acsr, acsrf + type(psb_z_coo_sparse_mat) :: tmpcoo + type(psb_z_csr_sparse_mat) :: acsr1, acsr2, acsr3, acsr, acsrf type(psb_z_csc_sparse_mat) :: csc_dap, csc_dadap, csc_datp, csc_datdatp, acsc complex(psb_dpk_), allocatable :: adiag(:), adinv(:) complex(psb_dpk_), allocatable :: omf(:), omp(:), omi(:), oden(:) @@ -156,7 +150,7 @@ subroutine mld_zaggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info) nrow = desc_a%get_local_rows() ncol = desc_a%get_local_cols() - theta = p%parms%aggr_thresh + theta = parms%aggr_thresh naggr = nlaggr(me+1) ntaggr = sum(nlaggr) @@ -171,7 +165,7 @@ subroutine mld_zaggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info) naggrm1 = sum(nlaggr(1:me)) naggrp1 = sum(nlaggr(1:me+1)) - filter_mat = (p%parms%aggr_filter == mld_filter_mat_) + filter_mat = (parms%aggr_filter == mld_filter_mat_) ilaggr(1:nrow) = ilaggr(1:nrow) + naggrm1 call psb_halo(ilaggr,desc_a,info) @@ -213,16 +207,16 @@ subroutine mld_zaggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info) ! 1. Allocate Ptilde in sparse matrix form - call acoo%allocate(ncol,ntaggr,ncol) + call tmpcoo%allocate(ncol,ntaggr,ncol) do i=1,ncol - acoo%val(i) = zone - acoo%ia(i) = i - acoo%ja(i) = ilaggr(i) + tmpcoo%val(i) = zone + tmpcoo%ia(i) = i + tmpcoo%ja(i) = ilaggr(i) end do - call acoo%set_nzeros(ncol) - call acoo%set_dupl(psb_dupl_add_) - call acoo%set_asb() - call ptilde%mv_from(acoo) + call tmpcoo%set_nzeros(ncol) + call tmpcoo%set_dupl(psb_dupl_add_) + call tmpcoo%set_asb() + call ptilde%mv_from(tmpcoo) call ptilde%cscnv(info,type='csr') !!$ call local_dump(me,ptilde,'csr-ptilde','Ptilde-1') @@ -280,7 +274,7 @@ subroutine mld_zaggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info) call am3%mv_to(acsr3) ! Compute omega_int - ommx = cmplx(szero,szero) + ommx = cmplx(dzero,dzero) do i=1, ncol omi(i) = omp(ilaggr(i)) if(abs(omi(i)) .gt. abs(ommx)) ommx = omi(i) @@ -354,17 +348,17 @@ subroutine mld_zaggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info) ! ! Symbmm90 does the allocation for its result. ! - ! am1 = (I-w*D*Af)Ptilde + ! op_prol = (I-w*D*Af)Ptilde ! Doing it this way means to consider diag(Af_i) ! ! - call psb_symbmm(af,ptilde,am1,info) + call psb_symbmm(af,ptilde,op_prol,info) if(info /= psb_success_) then call psb_errpush(psb_err_from_subroutine_,name,a_err='symbmm 1') goto 9999 end if - call psb_numbmm(af,ptilde,am1) + call psb_numbmm(af,ptilde,op_prol) if (debug_level >= psb_debug_outer_) & & write(debug_unit,*) me,' ',trim(name),& @@ -390,16 +384,16 @@ subroutine mld_zaggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info) ! ! Symbmm90 does the allocation for its result. ! - ! am1 = (I-w*D*A)Ptilde + ! op_prol = (I-w*D*A)Ptilde ! ! - call psb_symbmm(am3,ptilde,am1,info) + call psb_symbmm(am3,ptilde,op_prol,info) if(info /= psb_success_) then call psb_errpush(psb_err_from_subroutine_,name,a_err='symbmm 1') goto 9999 end if - call psb_numbmm(am3,ptilde,am1) + call psb_numbmm(am3,ptilde,op_prol) if (debug_level >= psb_debug_outer_) & & write(debug_unit,*) me,' ',trim(name),& @@ -458,7 +452,7 @@ subroutine mld_zaggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info) omp = omp/oden ! !$ write(0,*) 'Check on output restrictor',omp(1:min(size(omp),10)) ! Compute omega_int - ommx = cmplx(szero,szero) + ommx = cmplx(dzero,dzero) do i=1, ncol omi(i) = omp(ilaggr(i)) if(abs(omi(i)) .gt. abs(ommx)) ommx = omi(i) @@ -509,20 +503,20 @@ subroutine mld_zaggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info) call rtilde%mv_from(tmpcoo) call rtilde%cscnv(info,type='csr') - call psb_symbmm(rtilde,atmp,am2,info) - call psb_numbmm(rtilde,atmp,am2) + call psb_symbmm(rtilde,atmp,op_restr,info) + call psb_numbmm(rtilde,atmp,op_restr) ! - ! Now we have to gather the halo of am1, and add it to itself + ! Now we have to gather the halo of op_prol, and add it to itself ! to multiply it by A, ! - call psb_sphalo(am1,desc_a,am4,info,& + call psb_sphalo(op_prol,desc_a,am4,info,& & colcnv=.false.,rowscale=.true.) - if (info == psb_success_) call psb_rwextd(ncol,am1,info,b=am4) + if (info == psb_success_) call psb_rwextd(ncol,op_prol,info,b=am4) if (info == psb_success_) call am4%free() if(info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,a_err='Halo of am1') + call psb_errpush(psb_err_internal_error_,name,a_err='Halo of op_prol') goto 9999 end if @@ -530,7 +524,7 @@ subroutine mld_zaggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info) ! Now we have to fix this. The only rows of B that are correct ! are those corresponding to "local" aggregates, i.e. indices in ilaggr(:) ! - call am2%mv_to(tmpcoo) + call op_restr%mv_to(tmpcoo) nzl = tmpcoo%get_nzeros() i=0 @@ -543,21 +537,21 @@ subroutine mld_zaggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info) end if end do call tmpcoo%set_nzeros(i) - call am2%mv_from(tmpcoo) - call am2%cscnv(info,type='csr') + call op_restr%mv_from(tmpcoo) + call op_restr%cscnv(info,type='csr') if (debug_level >= psb_debug_outer_) & & write(debug_unit,*) me,' ',trim(name),& & 'starting sphalo/ rwxtd' - call psb_symbmm(a,am1,am3,info) + call psb_symbmm(a,op_prol,am3,info) if(info /= psb_success_) then call psb_errpush(psb_err_from_subroutine_,name,& & a_err='symbmm 2') goto 9999 end if - call psb_numbmm(a,am1,am3) + call psb_numbmm(a,op_prol,am3) if (debug_level >= psb_debug_outer_) & & write(debug_unit,*) me,' ',trim(name),& & 'Done NUMBMM 2' @@ -576,156 +570,18 @@ subroutine mld_zaggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info) & write(debug_unit,*) me,' ',trim(name),& & 'Done sphalo/ rwxtd' - call psb_symbmm(am2,am3,b,info) - if (info == psb_success_) call psb_numbmm(am2,am3,b) + call psb_symbmm(op_restr,am3,ac,info) + if (info == psb_success_) call psb_numbmm(op_restr,am3,ac) if (info == psb_success_) call am3%free() - call b%mv_to(bcoo) + if (info == psb_success_) call ac%cscnv(info,type='coo',dupl=psb_dupl_add_) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& - &a_err='Build b = am2 x am3') + &a_err='Build ac = op_restr x am3') goto 9999 end if - if (debug_level >= psb_debug_outer_) & - & write(debug_unit,*) me,' ',trim(name),& - & 'Done mv_to_coo' - - - select case(p%parms%coarse_mat) - - case(mld_distr_mat_) - - nzl = bcoo%get_nzeros() - - if (debug_level >= psb_debug_outer_) & - & write(debug_unit,*) me,' ',trim(name),& - & ' B matrix nzl: ',nzl - - if (info == psb_success_) call psb_cdall(ictxt,p%desc_ac,info,nl=nlaggr(me+1)) - if (info == psb_success_) call psb_cdins(nzl,bcoo%ia,bcoo%ja,p%desc_ac,info) - if (info == psb_success_) call psb_cdasb(p%desc_ac,info) - if (info == psb_success_) call psb_glob_to_loc(bcoo%ia(1:nzl),p%desc_ac,info,iact='I') - if (info == psb_success_) call psb_glob_to_loc(bcoo%ja(1:nzl),p%desc_ac,info,iact='I') - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Creating p%desc_ac and converting ac') - goto 9999 - end if - - if (debug_level >= psb_debug_outer_) & - & write(debug_unit,*) me,' ',trim(name),& - & ' Assembld aux descr. distr.' - - call bcoo%set_nrows(p%desc_ac%get_local_rows()) - call bcoo%set_ncols(p%desc_ac%get_local_cols()) - call bcoo%fix(info) - call p%ac%mv_from(bcoo) - call p%ac%set_asb() - - call p%ac%cscnv(info,type='csr') - - if (np>1) then - call am1%mv_to(acsr) - nzl = acsr%get_nzeros() - call psb_glob_to_loc(acsr%ja(1:nzl),p%desc_ac,info,'I') - if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_glob_to_loc') - goto 9999 - end if - call am1%mv_from(acsr) - endif - call am1%set_ncols(p%desc_ac%get_local_cols()) - - if (np>1) then - call am2%mv_to(tmpcoo) - nzl = tmpcoo%get_nzeros() - if (info == psb_success_) call psb_glob_to_loc(tmpcoo%ia(1:nzl),p%desc_ac,info,'I') - if(info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,a_err='Converting am2 to local') - goto 9999 - end if - call am2%mv_from(tmpcoo) - call am2%cscnv(info,type='csr') - end if - call am2%set_nrows(p%desc_ac%get_local_cols()) - - if (debug_level >= psb_debug_outer_) & - & write(debug_unit,*) me,' ',trim(name),& - & 'Done ac ' - - case(mld_repl_mat_) - ! - ! - call psb_cdall(ictxt,p%desc_ac,info,mg=ntaggr,repl=.true.) - nzbr(:) = 0 - nzbr(me+1) = bcoo%get_nzeros() - - call psb_sum(ictxt,nzbr(1:np)) - nzac = sum(nzbr) - if (info == psb_success_) call tmpcoo%allocate(ntaggr,ntaggr,nzac) - if (info /= psb_success_) goto 9999 - - do ip=1,np - idisp(ip) = sum(nzbr(1:ip-1)) - enddo - ndx = nzbr(me+1) - - call mpi_allgatherv(bcoo%val,ndx,mpi_double_complex,tmpcoo%val,nzbr,idisp,& - & mpi_double_complex,icomm,info) - if (info == psb_success_)& - & call mpi_allgatherv(bcoo%ia,ndx,psb_mpi_ipk_integer,tmpcoo%ia,nzbr,idisp,& - & psb_mpi_ipk_integer,icomm,info) - if (info == psb_success_)& - & call mpi_allgatherv(bcoo%ja,ndx,psb_mpi_ipk_integer,tmpcoo%ja,nzbr,idisp,& - & psb_mpi_ipk_integer,icomm,info) - - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err=' from mpi_allgatherv') - goto 9999 - end if - - call bcoo%free() - call tmpcoo%fix(info) - call p%ac%mv_from(tmpcoo) - call p%ac%cscnv(info,type='csr') - if(info /= psb_success_) goto 9999 - - deallocate(nzbr,idisp,stat=info) - if (info /= psb_success_) then - info = psb_err_alloc_dealloc_ - call psb_errpush(info,name) - goto 9999 - end if - case default - info = psb_err_internal_error_ - call psb_errpush(info,name,a_err='invalid mld_coarse_mat_') - goto 9999 - end select - - - - call p%ac%cscnv(info,type='csr') - if(info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='spcnv') - goto 9999 - end if - - ! - ! Copy the prolongation/restriction matrices into the descriptor map. - ! am2 => R i.e. restriction operator - ! am1 => P i.e. prolongation operator - ! - p%map = psb_linmap(psb_map_aggr_,desc_a,& - & p%desc_ac,am2,am1,ilaggr,nlaggr) - if (info == psb_success_) call am1%free() - if (info == psb_success_) call am2%free() - if(info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='sp_Free') - goto 9999 - end if if (debug_level >= psb_debug_outer_) & & write(debug_unit,*) me,' ',trim(name),& diff --git a/mlprec/impl/mld_zaggrmat_nosmth_asb.F90 b/mlprec/impl/mld_zaggrmat_nosmth_asb.f90 similarity index 57% rename from mlprec/impl/mld_zaggrmat_nosmth_asb.F90 rename to mlprec/impl/mld_zaggrmat_nosmth_asb.f90 index 40be6002..85239315 100644 --- a/mlprec/impl/mld_zaggrmat_nosmth_asb.F90 +++ b/mlprec/impl/mld_zaggrmat_nosmth_asb.f90 @@ -81,35 +81,29 @@ ! info - integer, output. ! Error code. ! -subroutine mld_zaggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,p,info) +subroutine mld_zaggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_restr,info) use psb_base_mod use mld_z_inner_mod, mld_protect_name => mld_zaggrmat_nosmth_asb -#ifdef MPI_MOD - use mpi -#endif implicit none -#ifdef MPI_H - include 'mpif.h' -#endif ! Arguments type(psb_zspmat_type), intent(in) :: a type(psb_desc_type), intent(in) :: desc_a integer, intent(inout) :: ilaggr(:), nlaggr(:) - type(mld_z_onelev_type), intent(inout), target :: p + type(mld_dml_parms), intent(inout) :: parms + type(psb_zspmat_type), intent(out) :: ac,op_prol,op_restr integer, intent(out) :: info ! Local variables integer :: ictxt,np,me, err_act integer(psb_mpik_) :: icomm, ndx, minfo character(len=20) :: name - type(psb_zspmat_type) :: b - integer(psb_mpik_), allocatable :: nzbr(:), idisp(:) integer(psb_ipk_) :: ierr(5) - type(psb_zspmat_type) :: am1,am2 - type(psb_z_coo_sparse_mat) :: acoo1, acoo2, bcoo, ac_coo - integer :: nrow, nglob, ncol, ntaggr, nzac, ip, & + type(psb_z_coo_sparse_mat) :: ac_coo, acoo + type(psb_z_csr_sparse_mat) :: acsr1, acsr2 + integer :: debug_level, debug_unit + integer :: nrow, nglob, ncol, ntaggr, nzl, ip, & & naggr, nzt, naggrm1, i name='mld_aggrmat_nosmth_asb' @@ -128,141 +122,48 @@ subroutine mld_zaggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,p,info) naggr = nlaggr(me+1) ntaggr = sum(nlaggr) - allocate(nzbr(np), idisp(np),stat=info) - if (info /= psb_success_) then - info=psb_err_alloc_request_; ierr(1)=2*np; - call psb_errpush(info,name,i_err=ierr,a_err='integer') - goto 9999 - end if - naggrm1=sum(nlaggr(1:me)) - if (p%parms%coarse_mat == mld_repl_mat_) then - do i=1, nrow - ilaggr(i) = ilaggr(i) + naggrm1 - end do - call psb_halo(ilaggr,desc_a,info) - end if + do i=1, nrow + ilaggr(i) = ilaggr(i) + naggrm1 + end do + call psb_halo(ilaggr,desc_a,info) if(info /= psb_success_) then call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_halo') goto 9999 end if - if (p%parms%coarse_mat == mld_repl_mat_) then - call acoo1%allocate(ncol,ntaggr,ncol) - else - call acoo1%allocate(ncol,naggr,ncol) - end if + call acoo%allocate(ncol,ntaggr,ncol) do i=1,nrow - acoo1%val(i) = zone - acoo1%ia(i) = i - acoo1%ja(i) = ilaggr(i) + acoo%val(i) = zone + acoo%ia(i) = i + acoo%ja(i) = ilaggr(i) end do - call acoo1%set_dupl(psb_dupl_add_) - call acoo1%set_nzeros(nrow) - call acoo1%set_asb() - call acoo1%fix(info) - call acoo1%transp(acoo2) + call acoo%set_dupl(psb_dupl_add_) + call acoo%set_nzeros(nrow) + call acoo%set_asb() + call acoo%fix(info) + - call a%csclip(bcoo,info,jmax=nrow) + call op_prol%mv_from(acoo) + call op_prol%cscnv(info,type='csr',dupl=psb_dupl_add_) + if (info == psb_success_) call op_prol%transp(op_restr) + call a%csclip(ac_coo,info,jmax=nrow) - nzt = bcoo%get_nzeros() + nzt = ac_coo%get_nzeros() do i=1, nzt - bcoo%ia(i) = ilaggr(bcoo%ia(i)) - bcoo%ja(i) = ilaggr(bcoo%ja(i)) + ac_coo%ia(i) = ilaggr(ac_coo%ia(i)) + ac_coo%ja(i) = ilaggr(ac_coo%ja(i)) enddo - call bcoo%set_nrows(naggr) - call bcoo%set_ncols(naggr) - call bcoo%set_dupl(psb_dupl_add_) - call bcoo%fix(info) - - - if (p%parms%coarse_mat == mld_repl_mat_) then - - call psb_cdall(ictxt,p%desc_ac,info,mg=ntaggr,repl=.true.) - if (info == psb_success_) call psb_cdasb(p%desc_ac,info) - if(info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_cdall') - goto 9999 - end if - - nzbr(:) = 0 - nzbr(me+1) = nzt - call psb_sum(ictxt,nzbr(1:np)) - nzac = sum(nzbr) - - call ac_coo%allocate(ntaggr,ntaggr,nzac) - - do ip=1,np - idisp(ip) = sum(nzbr(1:ip-1)) - enddo - ndx = nzbr(me+1) - - call mpi_allgatherv(bcoo%val,ndx,mpi_double_complex,ac_coo%val,nzbr,idisp,& - & mpi_double_complex,icomm,minfo) - call mpi_allgatherv(bcoo%ia,ndx,psb_mpi_ipk_integer,ac_coo%ia,nzbr,idisp,& - & psb_mpi_ipk_integer,icomm,minfo) - call mpi_allgatherv(bcoo%ja,ndx,psb_mpi_ipk_integer,ac_coo%ja,nzbr,idisp,& - & psb_mpi_ipk_integer,icomm,minfo) - if(info /= psb_success_) then - info=-1 - call psb_errpush(info,name) - goto 9999 - end if - call ac_coo%set_nzeros(nzac) - call ac_coo%set_dupl(psb_dupl_add_) - call ac_coo%fix(info) - call p%ac%mv_from(ac_coo) - - else if (p%parms%coarse_mat == mld_distr_mat_) then - - call psb_cdall(ictxt,p%desc_ac,info,nl=naggr) - if (info == psb_success_) call psb_cdasb(p%desc_ac,info) - call p%ac%mv_from(bcoo) - if(info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,a_err='Build ac, desc_ac') - goto 9999 - - end if - - else - info = psb_err_internal_error_ - call psb_errpush(psb_err_internal_error_,name,a_err='invalid mld_coarse_mat_') - goto 9999 - end if - - call bcoo%free() - - deallocate(nzbr,idisp) - - call p%ac%cscnv(info,type='csr',dupl=psb_dupl_add_) - if(info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='cscnv') - goto 9999 - end if - - call am1%mv_from(acoo1) - call am1%cscnv(info,type='csr',dupl=psb_dupl_add_) - if (info == psb_success_) call am2%mv_from(acoo2) - if (info == psb_success_) call am2%cscnv(info,type='csr',dupl=psb_dupl_add_) - ! - ! Copy the prolongation/restriction matrices into the descriptor map. - ! am2 => PR^T i.e. restriction operator - ! am1 => PR i.e. prolongation operator - ! - if (info == psb_success_) & - & p%map = psb_linmap(psb_map_aggr_,desc_a,& - & p%desc_ac,am2,am1,ilaggr,nlaggr) - if (info == psb_success_) call am1%free() - if (info == psb_success_) call am2%free() - if(info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='linmap build') - goto 9999 - end if + call ac_coo%set_nrows(naggr) + call ac_coo%set_ncols(naggr) + call ac_coo%set_dupl(psb_dupl_add_) + call ac_coo%fix(info) + call ac%mv_from(ac_coo) call psb_erractionrestore(err_act) diff --git a/mlprec/impl/mld_zaggrmat_smth_asb.F90 b/mlprec/impl/mld_zaggrmat_smth_asb.f90 similarity index 52% rename from mlprec/impl/mld_zaggrmat_smth_asb.F90 rename to mlprec/impl/mld_zaggrmat_smth_asb.f90 index 9eb44d94..b33be1ce 100644 --- a/mlprec/impl/mld_zaggrmat_smth_asb.F90 +++ b/mlprec/impl/mld_zaggrmat_smth_asb.f90 @@ -61,11 +61,6 @@ ! according to the value of p%parms%aggr_omega_alg, specified by the user ! through mld_zprecinit and mld_zprecset. ! -! This routine can also build A_C according to a "bizarre" aggregation algorithm, -! using a "naive" prolongator proposed by the authors of MLD2P4. However, this -! prolongator still requires a deep analysis and testing and its use is not -! recommended. -! ! The coarse-level matrix A_C is distributed among the parallel processes or ! replicated on each of them, according to the value of p%parms%coarse_mat, ! specified by the user through mld_zprecinit and mld_zprecset. @@ -98,38 +93,31 @@ ! info - integer, output. ! Error code. ! -subroutine mld_zaggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info) +subroutine mld_zaggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_restr,info) use psb_base_mod use mld_z_inner_mod, mld_protect_name => mld_zaggrmat_smth_asb -#ifdef MPI_MOD - use mpi -#endif implicit none -#ifdef MPI_H - include 'mpif.h' -#endif ! Arguments type(psb_zspmat_type), intent(in) :: a type(psb_desc_type), intent(in) :: desc_a integer, intent(inout) :: ilaggr(:), nlaggr(:) - type(mld_z_onelev_type), intent(inout), target :: p + type(mld_dml_parms), intent(inout) :: parms + type(psb_zspmat_type), intent(out) :: ac,op_prol,op_restr integer, intent(out) :: info ! Local variables - type(psb_zspmat_type) :: b - integer, allocatable :: nzbr(:), idisp(:) - integer :: nrow, nglob, ncol, ntaggr, nzac, ip, ndx,& + integer :: nrow, nglob, ncol, ntaggr, ip, ndx,& & naggr, nzl,naggrm1,naggrp1, i, j, k, jd, icolF, nrw integer ::ictxt, np, me, err_act character(len=20) :: name - type(psb_zspmat_type) :: am1,am2, am3, am4 - type(psb_z_coo_sparse_mat) :: acoo, acoof, bcoo + type(psb_zspmat_type) :: am3, am4 + type(psb_z_coo_sparse_mat) :: tmpcoo type(psb_z_csr_sparse_mat) :: acsr1, acsr2, acsr3, acsrf, ptilde complex(psb_dpk_), allocatable :: adiag(:) integer(psb_ipk_) :: ierr(5) - logical :: ml_global_nmb, filter_mat + logical :: filter_mat integer :: debug_level, debug_unit integer, parameter :: ncmax=16 real(psb_dpk_) :: anorm, omega, tmp, dg, theta @@ -150,34 +138,21 @@ subroutine mld_zaggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info) nrow = desc_a%get_local_rows() ncol = desc_a%get_local_cols() - theta = p%parms%aggr_thresh + theta = parms%aggr_thresh naggr = nlaggr(me+1) ntaggr = sum(nlaggr) - allocate(nzbr(np), idisp(np),stat=info) - if (info /= psb_success_) then - info=psb_err_alloc_request_; ierr(1)=2*np; - call psb_errpush(info,name,i_err=ierr,a_err='integer') - goto 9999 - end if - naggrm1 = sum(nlaggr(1:me)) naggrp1 = sum(nlaggr(1:me+1)) - ml_global_nmb = ( (p%parms%aggr_kind == mld_smooth_prol_).or.& - & ( (p%parms%aggr_kind == mld_biz_prol_).and.& - & (p%parms%coarse_mat == mld_repl_mat_)) ) - - filter_mat = (p%parms%aggr_filter == mld_filter_mat_) + filter_mat = (parms%aggr_filter == mld_filter_mat_) - if (ml_global_nmb) then - ilaggr(1:nrow) = ilaggr(1:nrow) + naggrm1 - call psb_halo(ilaggr,desc_a,info) + ilaggr(1:nrow) = ilaggr(1:nrow) + naggrm1 + call psb_halo(ilaggr,desc_a,info) - if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_halo') - goto 9999 - end if + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_halo') + goto 9999 end if ! naggr: number of local aggregates @@ -202,32 +177,22 @@ subroutine mld_zaggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info) end if ! 1. Allocate Ptilde in sparse matrix form - if (ml_global_nmb) then - call acoo%allocate(ncol,ntaggr,ncol) - do i=1,ncol - acoo%val(i) = zone - acoo%ia(i) = i - acoo%ja(i) = ilaggr(i) - end do - call acoo%set_nzeros(ncol) - else - call acoo%allocate(ncol,naggr,ncol) - do i=1,nrow - acoo%val(i) = zone - acoo%ia(i) = i - acoo%ja(i) = ilaggr(i) - end do - call acoo%set_nzeros(nrow) - endif - call acoo%set_dupl(psb_dupl_add_) - - call ptilde%mv_from_coo(acoo,info) + call tmpcoo%allocate(ncol,ntaggr,ncol) + do i=1,ncol + tmpcoo%val(i) = zone + tmpcoo%ia(i) = i + tmpcoo%ja(i) = ilaggr(i) + end do + call tmpcoo%set_nzeros(ncol) + call tmpcoo%set_dupl(psb_dupl_add_) + + call ptilde%mv_from_coo(tmpcoo,info) if (info == psb_success_) call a%cscnv(acsr3,info,dupl=psb_dupl_add_) if (debug_level >= psb_debug_outer_) & & write(debug_unit,*) me,' ',trim(name),& & ' Initial copies sone.' - + if (filter_mat) then ! ! Build the filtered matrix Af from A @@ -252,19 +217,19 @@ subroutine mld_zaggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info) end if enddo ! Take out zeroed terms - call acsrf%mv_to_coo(acoof,info) + call acsrf%mv_to_coo(tmpcoo,info) k = 0 - do j=1,acoof%get_nzeros() - if ((acoof%val(j) /= zzero) .or. (acoof%ia(j) == acoof%ja(j))) then + do j=1,tmpcoo%get_nzeros() + if ((tmpcoo%val(j) /= zzero) .or. (tmpcoo%ia(j) == tmpcoo%ja(j))) then k = k + 1 - acoof%val(k) = acoof%val(j) - acoof%ia(k) = acoof%ia(j) - acoof%ja(k) = acoof%ja(j) + tmpcoo%val(k) = tmpcoo%val(j) + tmpcoo%ia(k) = tmpcoo%ia(j) + tmpcoo%ja(k) = tmpcoo%ja(j) end if end do - call acoof%set_nzeros(k) - call acoof%set_dupl(psb_dupl_add_) - call acsrf%mv_from_coo(acoof,info) + call tmpcoo%set_nzeros(k) + call tmpcoo%set_dupl(psb_dupl_add_) + call acsrf%mv_from_coo(tmpcoo,info) end if @@ -281,41 +246,13 @@ subroutine mld_zaggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info) if (info /= psb_success_) goto 9999 - if (p%parms%aggr_omega_alg == mld_eig_est_) then - - if (p%parms%aggr_eig == mld_max_norm_) then - - if (p%parms%aggr_kind == mld_biz_prol_) then - - ! - ! This only works with CSR - ! - anorm = dzero - dg = done - nrw = acsr3%get_nrows() - do i=1, nrw - tmp = szero - do j=acsr3%irp(i),acsr3%irp(i+1)-1 - if (acsr3%ja(j) <= nrw) then - tmp = tmp + abs(acsr3%val(j)) - endif - if (acsr3%ja(j) == i ) then - dg = abs(acsr3%val(j)) - end if - end do - anorm = max(anorm,tmp/dg) - enddo - - call psb_amx(ictxt,anorm) - else - anorm = acsr3%csnmi() - endif - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,a_err='Invalid AM3 storage format') - goto 9999 - end if + if (parms%aggr_omega_alg == mld_eig_est_) then + + if (parms%aggr_eig == mld_max_norm_) then + + anorm = acsr3%csnmi() omega = 4.d0/(3.d0*anorm) - p%parms%aggr_omega_val = omega + parms%aggr_omega_val = omega else info = psb_err_internal_error_ @@ -323,11 +260,11 @@ subroutine mld_zaggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info) goto 9999 end if - else if (p%parms%aggr_omega_alg == mld_user_choice_) then + else if (parms%aggr_omega_alg == mld_user_choice_) then - omega = p%parms%aggr_omega_val + omega = parms%aggr_omega_val - else if (p%parms%aggr_omega_alg /= mld_user_choice_) then + else if (parms%aggr_omega_alg /= mld_user_choice_) then info = psb_err_internal_error_ call psb_errpush(info,name,a_err='invalid mld_aggr_omega_alg_') goto 9999 @@ -368,7 +305,7 @@ subroutine mld_zaggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info) if (debug_level >= psb_debug_outer_) & & write(debug_unit,*) me,' ',trim(name),& & 'Done NUMBMM 1' - + else ! ! Build the smoothed prolongator using the original matrix @@ -409,76 +346,64 @@ subroutine mld_zaggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info) call ptilde%free() call acsr1%set_dupl(psb_dupl_add_) - call am1%mv_from(acsr1) - if (ml_global_nmb) then - ! - ! Now we have to gather the halo of am1, and add it to itself - ! to multiply it by A, - ! - call psb_sphalo(am1,desc_a,am4,info,& - & colcnv=.false.,rowscale=.true.) - if (info == psb_success_) call psb_rwextd(ncol,am1,info,b=am4) - if (info == psb_success_) call am4%free() - else - call psb_rwextd(ncol,am1,info) - endif + call op_prol%mv_from(acsr1) + ! + ! Now we have to gather the halo of op_prol, and add it to itself + ! to multiply it by A, + ! + call psb_sphalo(op_prol,desc_a,am4,info,& + & colcnv=.false.,rowscale=.true.) + if (info == psb_success_) call psb_rwextd(ncol,op_prol,info,b=am4) + if (info == psb_success_) call am4%free() if(info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,a_err='Halo of am1') + call psb_errpush(psb_err_internal_error_,name,a_err='Halo of op_prol') goto 9999 end if - call psb_symbmm(a,am1,am3,info) + call psb_symbmm(a,op_prol,am3,info) if(info /= psb_success_) then call psb_errpush(psb_err_from_subroutine_,name,a_err='symbmm 2') goto 9999 end if - call psb_numbmm(a,am1,am3) + call psb_numbmm(a,op_prol,am3) if (debug_level >= psb_debug_outer_) & & write(debug_unit,*) me,' ',trim(name),& - & 'Done NUMBMM 2',p%parms%aggr_kind, mld_smooth_prol_ + & 'Done NUMBMM 2',parms%aggr_kind, mld_smooth_prol_ - if (p%parms%aggr_kind == mld_smooth_prol_) then - call am1%transp(am2) - call am2%mv_to(acoo) - nzl = acoo%get_nzeros() - i=0 - ! - ! Now we have to fix this. The only rows of B that are correct - ! are those corresponding to "local" aggregates, i.e. indices in ilaggr(:) - ! - do k=1, nzl - if ((naggrm1 < acoo%ia(k)) .and.(acoo%ia(k) <= naggrp1)) then - i = i+1 - acoo%val(i) = acoo%val(k) - acoo%ia(i) = acoo%ia(k) - acoo%ja(i) = acoo%ja(k) - end if - end do - call acoo%set_nzeros(i) - call acoo%trim() - call am2%mv_from(acoo) - call am2%cscnv(info,type='csr',dupl=psb_dupl_add_) - if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='spcnv am2') - goto 9999 + call op_prol%transp(op_restr) + call op_restr%mv_to(tmpcoo) + nzl = tmpcoo%get_nzeros() + i=0 + ! + ! Now we have to fix this. The only rows of B that are correct + ! are those corresponding to "local" aggregates, i.e. indices in ilaggr(:) + ! + do k=1, nzl + if ((naggrm1 < tmpcoo%ia(k)) .and.(tmpcoo%ia(k) <= naggrp1)) then + i = i+1 + tmpcoo%val(i) = tmpcoo%val(k) + tmpcoo%ia(i) = tmpcoo%ia(k) + tmpcoo%ja(i) = tmpcoo%ja(k) end if - else - call am1%transp(am2) - endif + end do + call tmpcoo%set_nzeros(i) + call tmpcoo%trim() + call op_restr%mv_from(tmpcoo) + call op_restr%cscnv(info,type='csr',dupl=psb_dupl_add_) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='spcnv op_restr') + goto 9999 + end if if (debug_level >= psb_debug_outer_) & & write(debug_unit,*) me,' ',trim(name),& & 'starting sphalo/ rwxtd' - if (p%parms%aggr_kind == mld_smooth_prol_) then - ! am2 = ((i-wDA)Ptilde)^T - call psb_sphalo(am3,desc_a,am4,info,& - & colcnv=.false.,rowscale=.true.) - if (info == psb_success_) call psb_rwextd(ncol,am3,info,b=am4) - if (info == psb_success_) call am4%free() - else if (p%parms%aggr_kind == mld_biz_prol_) then - call psb_rwextd(ncol,am3,info) - endif + ! op_restr = ((i-wDA)Ptilde)^T + call psb_sphalo(am3,desc_a,am4,info,& + & colcnv=.false.,rowscale=.true.) + if (info == psb_success_) call psb_rwextd(ncol,am3,info,b=am4) + if (info == psb_success_) call am4%free() if(info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,a_err='Extend am3') goto 9999 @@ -488,180 +413,12 @@ subroutine mld_zaggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info) if (debug_level >= psb_debug_outer_) & & write(debug_unit,*) me,' ',trim(name),& & 'starting symbmm 3' - call psb_symbmm(am2,am3,b,info) - if (info == psb_success_) call psb_numbmm(am2,am3,b) + call psb_symbmm(op_restr,am3,ac,info) + if (info == psb_success_) call psb_numbmm(op_restr,am3,ac) if (info == psb_success_) call am3%free() - if (info == psb_success_) call b%cscnv(info,type='coo',dupl=psb_dupl_add_) + if (info == psb_success_) call ac%cscnv(info,type='coo',dupl=psb_dupl_add_) if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,a_err='Build b = am2 x am3') - goto 9999 - end if - - - - select case(p%parms%aggr_kind) - - case(mld_smooth_prol_) - - select case(p%parms%coarse_mat) - - case(mld_distr_mat_) - - nzac = b%get_nzeros() - nzl = nzac - call b%mv_to(bcoo) - - if (info == psb_success_) call psb_cdall(ictxt,p%desc_ac,info,nl=nlaggr(me+1)) - if (info == psb_success_) call psb_cdins(nzl,bcoo%ia,bcoo%ja,p%desc_ac,info) - if (info == psb_success_) call psb_cdasb(p%desc_ac,info) - if (info == psb_success_) call psb_glob_to_loc(bcoo%ia(1:nzl),p%desc_ac,info,iact='I') - if (info == psb_success_) call psb_glob_to_loc(bcoo%ja(1:nzl),p%desc_ac,info,iact='I') - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Creating p%desc_ac and converting ac') - goto 9999 - end if - if (debug_level >= psb_debug_outer_) & - & write(debug_unit,*) me,' ',trim(name),& - & 'Assembld aux descr. distr.' - call p%ac%mv_from(bcoo) - - call p%ac%set_nrows(p%desc_ac%get_local_rows()) - call p%ac%set_ncols(p%desc_ac%get_local_cols()) - call p%ac%set_asb() - - if (info == psb_success_) deallocate(nzbr,idisp,stat=info) - if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_sp_free') - goto 9999 - end if - - if (np>1) then - call am1%mv_to(acsr1) - nzl = acsr1%get_nzeros() - call psb_glob_to_loc(acsr1%ja(1:nzl),p%desc_ac,info,'I') - if(info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_glob_to_loc') - goto 9999 - end if - call am1%mv_from(acsr1) - endif - call am1%set_ncols(p%desc_ac%get_local_cols()) - - if (np>1) then - call am2%cscnv(info,type='coo',dupl=psb_dupl_add_) - call am2%mv_to(acoo) - nzl = acoo%get_nzeros() - if (info == psb_success_) call psb_glob_to_loc(acoo%ia(1:nzl),p%desc_ac,info,'I') - call acoo%set_dupl(psb_dupl_add_) - if (info == psb_success_) call am2%mv_from(acoo) - if (info == psb_success_) call am2%cscnv(info,type='csr') - if(info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,a_err='Converting am2 to local') - goto 9999 - end if - end if - call am2%set_nrows(p%desc_ac%get_local_cols()) - - if (debug_level >= psb_debug_outer_) & - & write(debug_unit,*) me,' ',trim(name),& - & 'Done ac ' - - case(mld_repl_mat_) - ! - ! - call psb_cdall(ictxt,p%desc_ac,info,mg=ntaggr,repl=.true.) - if (info == psb_success_) call psb_cdasb(p%desc_ac,info) - if (info == psb_success_) & - & call psb_gather(p%ac,b,p%desc_ac,info,dupl=psb_dupl_add_,keeploc=.false.) - - if (info /= psb_success_) goto 9999 - - deallocate(nzbr,idisp,stat=info) - if (info /= psb_success_) then - info = psb_err_alloc_dealloc_ - call psb_errpush(info,name) - goto 9999 - end if - case default - info = psb_err_internal_error_ - call psb_errpush(info,name,a_err='invalid mld_coarse_mat_') - goto 9999 - end select - - - case(mld_biz_prol_) - - select case(p%parms%coarse_mat) - - case(mld_distr_mat_) - - call psb_move_alloc(b,p%ac,info) - if (info == psb_success_) call psb_cdall(ictxt,p%desc_ac,info,nl=naggr) - if (info == psb_success_) call psb_cdasb(p%desc_ac,info) - if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='Build desc_ac, ac') - goto 9999 - end if - - - case(mld_repl_mat_) - ! - ! - call psb_cdall(ictxt,p%desc_ac,info,mg=ntaggr,repl=.true.) - if (info == psb_success_) call psb_cdasb(p%desc_ac,info) - if(info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_cdall') - goto 9999 - end if - call psb_gather(p%ac,b,p%desc_ac,info,dupl=psb_dupl_add_,keeploc=.false.) - if(info /= psb_success_) goto 9999 - - deallocate(nzbr,idisp,stat=info) - if (info /= psb_success_) then - info = psb_err_alloc_dealloc_ - call psb_errpush(info,name) - goto 9999 - end if - - case default - info = psb_err_internal_error_ - call psb_errpush(info,name,a_err='invalid mld_coarse_mat_') - goto 9999 - end select - - deallocate(nzbr,idisp,stat=info) - if (info /= psb_success_) then - info = psb_err_alloc_dealloc_ - call psb_errpush(info,name) - goto 9999 - end if - - case default - info = psb_err_internal_error_ - call psb_errpush(info,name,a_err='invalid mld_smooth_prol_') - goto 9999 - - end select - - call p%ac%cscnv(info,type='csr',dupl=psb_dupl_add_) - if(info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='spcnv') - goto 9999 - end if - - ! - ! Copy the prolongation/restriction matrices into the descriptor map. - ! am2 => PR^T i.e. restriction operator - ! am1 => PR i.e. prolongation operator - ! - - p%map = psb_linmap(psb_map_aggr_,desc_a,& - & p%desc_ac,am2,am1,ilaggr,nlaggr) - if (info == psb_success_) call am1%free() - if (info == psb_success_) call am2%free() - if(info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='sp_Free') + call psb_errpush(psb_err_internal_error_,name,a_err='Build ac = op_restr x am3') goto 9999 end if diff --git a/mlprec/impl/mld_zmlprec_bld.f90 b/mlprec/impl/mld_zmlprec_bld.f90 index 8f1a949a..24341f9b 100644 --- a/mlprec/impl/mld_zmlprec_bld.f90 +++ b/mlprec/impl/mld_zmlprec_bld.f90 @@ -93,11 +93,13 @@ subroutine mld_zmlprec_bld(a,desc_a,p,info,amold,vmold) ! Local Variables type(mld_zprec_type) :: t_prec - Integer :: err,i,k,ictxt, me,np, err_act, iszv, newsz + Integer :: err,i,k,ictxt, me,np, err_act, iszv, newsz, casize integer :: ipv(mld_ifpsz_), val integer :: int_err(5) character :: upd_ - type(mld_dml_parms) :: prm + class(mld_z_base_smoother_type), allocatable :: coarse_sm, base_sm, med_sm + type(mld_dml_parms) :: baseparms, medparms, coarseparms + type(mld_z_onelev_node), pointer :: head, tail, newnode, current integer :: debug_level, debug_unit character(len=20) :: name, ch_err @@ -145,12 +147,22 @@ subroutine mld_zmlprec_bld(a,desc_a,p,info,amold,vmold) ! Check to ensure all procs have the same ! newsz = -1 + casize = p%coarse_aggr_size iszv = size(p%precv) call psb_bcast(ictxt,iszv) - if (iszv /= size(p%precv)) then - info=psb_err_internal_error_ - call psb_errpush(info,name,a_err='Inconsistent size of precv') - goto 9999 + call psb_bcast(ictxt,casize) + if (casize > 0) then + if (casize /= p%coarse_aggr_size) then + info=psb_err_internal_error_ + call psb_errpush(info,name,a_err='Inconsistent coarse_aggr_size') + goto 9999 + end if + else + if (iszv /= size(p%precv)) then + info=psb_err_internal_error_ + call psb_errpush(info,name,a_err='Inconsistent size of precv') + goto 9999 + end if end if if (iszv <= 1) then @@ -162,7 +174,161 @@ subroutine mld_zmlprec_bld(a,desc_a,p,info,amold,vmold) endif - if (iszv > 1) then + + if (casize>0) then + ! + ! New strategy to build according to coarse size. + ! + coarseparms = p%precv(iszv)%parms + baseparms = p%precv(1)%parms + medparms = p%precv(2)%parms + + allocate(coarse_sm, source=p%precv(iszv)%sm,stat=info) + if (info == psb_success_) & + & allocate(med_sm, source=p%precv(2)%sm,stat=info) + if (info == psb_success_) & + & allocate(base_sm, source=p%precv(1)%sm,stat=info) + if (info /= psb_success_) then + write(0,*) 'Error in saving smoothers',info + call psb_errpush(psb_err_internal_error_,name,a_err='Base level precbuild.') + goto 9999 + end if + ! + ! Replicated matrix should only ever happen at coarse level. + ! + call mld_check_def(baseparms%coarse_mat,'Coarse matrix',& + & mld_distr_mat_,is_distr_ml_coarse_mat) + ! + ! Now build a doubly linked list + ! + allocate(newnode,stat=info) + if (info /= psb_success_) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='List start'); goto 9999 + end if + head => newnode + tail => newnode + newnode%item%base_a => a + newnode%item%base_desc => desc_a + newnode%item%parms = baseparms + newsz = 1 + current => head + list_build_loop: do + allocate(newnode,stat=info) + if (info /= psb_success_) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='List start'); goto 9999 + end if + current%next => newnode + newnode%prev => current + newsz = newsz + 1 + newnode%item%parms = medparms + newnode%item%parms%aggr_thresh = current%item%parms%aggr_thresh/2 + call mld_coarse_bld(current%item%base_a, current%item%base_desc, & + & newnode%item,info) + if (info /= psb_success_) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='build next level'); goto 9999 + end if + + if (newsz>2) then + if (all(current%item%map%naggr == newnode%item%map%naggr)) then + ! + ! We are not gaining anything + ! + newsz = newsz-1 + current%next => null() + call newnode%item%free(info) + if (info == psb_success_) deallocate(newnode,stat=info) + if (info /= psb_success_) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='Deallocate at list end'); goto 9999 + end if + end if + end if + + current => current%next + tail => current + if (sum(newnode%item%map%naggr) <= casize) then + ! + ! Target reached; but we may need to rebuild. + ! + exit list_build_loop + end if + end do list_build_loop + ! + ! At this point, we are at the list tail, + ! and it needs to be rebuilt in case the parms were + ! different. + ! + ! But the threshold has to be fixed before rebuliding + coarseparms%aggr_thresh = current%item%parms%aggr_thresh + current%item%parms = coarseparms + call mld_coarse_bld(current%prev%item%base_a,& + & current%prev%item%base_desc, & + & current%item,info) + if (info /= psb_success_) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='build next level'); goto 9999 + end if + + ! + ! Ok, now allocate the output vector and fix items. + ! + do i=1,iszv + if (info == psb_success_) call p%precv(i)%free(info) + end do + if (info == psb_success_) deallocate(p%precv,stat=info) + if (info == psb_success_) allocate(p%precv(newsz),stat=info) + if (info /= psb_success_) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='Reallocate precv'); goto 9999 + end if + newnode => head + do i=1, newsz + current => newnode + if (info == psb_success_) & + & call mld_move_alloc(current%item,p%precv(i),info) + if (info == psb_success_) then + if (i ==1) then + allocate(p%precv(i)%sm,source=base_sm,stat=info) + else if (i < newsz) then + allocate(p%precv(i)%sm,source=med_sm,stat=info) + else + allocate(p%precv(i)%sm,source=coarse_sm,stat=info) + end if + end if + if (info /= psb_success_) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='list cpy'); goto 9999 + end if + if (i == 1) then + p%precv(i)%base_a => a + p%precv(i)%base_desc => desc_a + else + p%precv(i)%base_a => p%precv(i)%ac + p%precv(i)%base_desc => p%precv(i)%desc_ac + p%precv(i)%map%p_desc_X => p%precv(i-1)%base_desc + p%precv(i)%map%p_desc_Y => p%precv(i)%base_desc + end if + + newnode => current%next + deallocate(current) + end do + call base_sm%free(info) + if (info == psb_success_) call med_sm%free(info) + if (info == psb_success_) call coarse_sm%free(info) + if (info == psb_success_) deallocate(coarse_sm,med_sm,base_sm,stat=info) + if (info /= psb_success_) then + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='final cleanup'); goto 9999 + end if + iszv = newsz + + else + ! + ! Default, oldstyle + ! ! ! Build the matrix and the transfer operators corresponding @@ -179,11 +345,6 @@ subroutine mld_zmlprec_bld(a,desc_a,p,info,amold,vmold) p%precv(1)%base_a => a p%precv(1)%base_desc => desc_a - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,a_err='Base level precbuild.') - goto 9999 - end if - do i=2, iszv ! @@ -201,11 +362,6 @@ subroutine mld_zmlprec_bld(a,desc_a,p,info,amold,vmold) ! call mld_check_def(p%precv(i)%parms%coarse_mat,'Coarse matrix',& & mld_distr_mat_,is_distr_ml_coarse_mat) - - else if (i == iszv) then - -!!$ call check_coarse_lev(p%precv(i)) - end if if (debug_level >= psb_debug_outer_) & @@ -277,9 +433,7 @@ subroutine mld_zmlprec_bld(a,desc_a,p,info,amold,vmold) p%precv(i)%map%p_desc_Y => p%precv(i)%base_desc end do - i = iszv - call check_coarse_lev(p%precv(i)) if (info == psb_success_) call mld_coarse_bld(p%precv(i-1)%base_a,& & p%precv(i-1)%base_desc, p%precv(i),info) if (info /= psb_success_) then @@ -289,6 +443,12 @@ subroutine mld_zmlprec_bld(a,desc_a,p,info,amold,vmold) end if end if + ! + ! The coarse space hierarchy has been build. + ! + ! Now do the preconditioner build. + ! + do i=1, iszv ! ! build the base preconditioner at level i @@ -316,10 +476,6 @@ subroutine mld_zmlprec_bld(a,desc_a,p,info,amold,vmold) goto 9999 end if - - ! - ! Test version for beginning of OO stuff. - ! call p%precv(i)%sm%build(p%precv(i)%base_a,p%precv(i)%base_desc,& & 'F',info,amold=amold,vmold=vmold) @@ -350,69 +506,4 @@ subroutine mld_zmlprec_bld(a,desc_a,p,info,amold,vmold) end if return -contains - - subroutine check_coarse_lev(prec) - type(mld_z_onelev_type) :: prec - - ! - ! At the coarsest level, check mld_coarse_solve_ - ! -!!$ val = prec%parms%coarse_solve -!!$ select case (val) -!!$ case(mld_jac_) -!!$ -!!$ if (prec%prec%iprcparm(mld_sub_solve_) /= mld_diag_scale_) then -!!$ if (me == 0) write(debug_unit,*)& -!!$ & 'Warning: inconsistent coarse level specification.' -!!$ if (me == 0) write(debug_unit,*)& -!!$ & ' Resetting according to the value specified for mld_coarse_solve_.' -!!$ prec%prec%iprcparm(mld_sub_solve_) = mld_diag_scale_ -!!$ end if -!!$ prec%prec%iprcparm(mld_smoother_type_) = mld_jac_ -!!$ -!!$ case(mld_bjac_) -!!$ -!!$ if ((prec%prec%iprcparm(mld_sub_solve_) == mld_diag_scale_).or.& -!!$ & ( prec%prec%iprcparm(mld_smoother_type_) /= mld_bjac_)) then -!!$ if (me == 0) write(debug_unit,*)& -!!$ & 'Warning: inconsistent coarse level specification.' -!!$ if (me == 0) write(debug_unit,*)& -!!$ & ' Resetting according to the value specified for mld_coarse_solve_.' -!!$! !$#if defined(HAVE_UMF_) -!!$! !$ prec%prec%iprcparm(mld_sub_solve_) = mld_umf_ -!!$! !$#elif defined(HAVE_SLU_) -!!$! !$ prec%prec%iprcparm(mld_sub_solve_) = mld_slu_ -!!$! !$#else -!!$ prec%prec%iprcparm(mld_sub_solve_) = mld_ilu_n_ -!!$! !$#endif -!!$ end if -!!$ prec%prec%iprcparm(mld_smoother_type_) = mld_bjac_ -!!$ -!!$ case(mld_umf_, mld_slu_) -!!$ if ((prec%iprcparm(mld_coarse_mat_) /= mld_repl_mat_).or.& -!!$ & (prec%prec%iprcparm(mld_sub_solve_) /= val)) then -!!$ if (me == 0) write(debug_unit,*)& -!!$ & 'Warning: inconsistent coarse level specification.' -!!$ if (me == 0) write(debug_unit,*)& -!!$ & ' Resetting according to the value specified for mld_coarse_solve_.' -!!$ prec%iprcparm(mld_coarse_mat_) = mld_repl_mat_ -!!$ prec%prec%iprcparm(mld_sub_solve_) = val -!!$ prec%prec%iprcparm(mld_smoother_type_) = mld_bjac_ -!!$ end if -!!$ case(mld_sludist_) -!!$ if ((prec%iprcparm(mld_coarse_mat_) /= mld_distr_mat_).or.& -!!$ & (prec%prec%iprcparm(mld_sub_solve_) /= val)) then -!!$ if (me == 0) write(debug_unit,*)& -!!$ & 'Warning: inconsistent coarse level specification.' -!!$ if (me == 0) write(debug_unit,*)& -!!$ & ' Resetting according to the value specified for mld_coarse_solve_.' -!!$ prec%iprcparm(mld_coarse_mat_) = mld_distr_mat_ -!!$ prec%prec%iprcparm(mld_sub_solve_) = val -!!$ prec%prec%iprcparm(mld_smoother_type_) = mld_bjac_ -!!$ prec%prec%iprcparm(mld_smoother_sweeps_) = 1 -!!$ end if -!!$ end select - end subroutine check_coarse_lev - end subroutine mld_zmlprec_bld diff --git a/mlprec/impl/mld_zprecinit.F90 b/mlprec/impl/mld_zprecinit.F90 index 1bf0f172..b5cd4a0e 100644 --- a/mlprec/impl/mld_zprecinit.F90 +++ b/mlprec/impl/mld_zprecinit.F90 @@ -125,6 +125,7 @@ subroutine mld_zprecinit(p,ptype,info,nlev) ! Do we want to do something? endif endif + p%coarse_aggr_size = -1 select case(psb_toupper(ptype(1:len_trim(ptype)))) case ('NOPREC','NONE') diff --git a/mlprec/impl/mld_zprecset.F90 b/mlprec/impl/mld_zprecset.F90 index c49244ac..cd1bfb1d 100644 --- a/mlprec/impl/mld_zprecset.F90 +++ b/mlprec/impl/mld_zprecset.F90 @@ -129,6 +129,11 @@ subroutine mld_zprecseti(p,what,val,info,ilev) return endif + if (what == mld_coarse_aggr_size_) then + p%coarse_aggr_size = max(val,-1) + return + end if + ! ! Set preconditioner parameters at level ilev. ! diff --git a/mlprec/mld_base_prec_type.F90 b/mlprec/mld_base_prec_type.F90 index 27b456e1..f5d2caa3 100644 --- a/mlprec/mld_base_prec_type.F90 +++ b/mlprec/mld_base_prec_type.F90 @@ -104,6 +104,7 @@ module mld_base_prec_type procedure, pass(pm) :: descr => ml_parms_descr procedure, pass(pm) :: mldescr => ml_parms_mldescr procedure, pass(pm) :: coarsedescr => ml_parms_coarsedescr + procedure, pass(pm) :: printout => ml_parms_printout end type mld_ml_parms @@ -111,12 +112,14 @@ module mld_base_prec_type real(psb_spk_) :: aggr_omega_val, aggr_thresh contains procedure, pass(pm) :: descr => s_ml_parms_descr + procedure, pass(pm) :: printout => s_ml_parms_printout end type mld_sml_parms type, extends(mld_ml_parms) :: mld_dml_parms real(psb_dpk_) :: aggr_omega_val, aggr_thresh contains procedure, pass(pm) :: descr => d_ml_parms_descr + procedure, pass(pm) :: printout => d_ml_parms_printout end type mld_dml_parms @@ -157,6 +160,7 @@ module mld_base_prec_type integer, parameter :: mld_coarse_fillin_ = 32 integer, parameter :: mld_coarse_subsolve_ = 33 integer, parameter :: mld_smoother_sweeps_ = 34 + integer, parameter :: mld_coarse_aggr_size_ = 35 integer, parameter :: mld_ifpsz_ = 36 ! @@ -436,6 +440,40 @@ contains end subroutine mld_stringval + + subroutine ml_parms_printout(pm,iout) + implicit none + class(mld_ml_parms), intent(in) :: pm + integer, intent(in) :: iout + + write(iout,*) 'Sweeps: ',pm%sweeps,pm%sweeps_pre,pm%sweeps_post + write(iout,*) 'ML : ',pm%ml_type,pm%smoother_pos + write(iout,*) 'AGGR : ',pm%aggr_alg,pm%aggr_kind + write(iout,*) ' : ',pm%aggr_omega_alg,pm%aggr_eig,pm%aggr_filter + write(iout,*) 'COARSE: ',pm%coarse_mat,pm%coarse_solve + end subroutine ml_parms_printout + + + subroutine s_ml_parms_printout(pm,iout) + implicit none + class(mld_sml_parms), intent(in) :: pm + integer, intent(in) :: iout + + call pm%mld_ml_parms%printout(iout) + write(iout,*) 'REAL : ',pm%aggr_omega_val,pm%aggr_thresh + end subroutine s_ml_parms_printout + + + subroutine d_ml_parms_printout(pm,iout) + implicit none + class(mld_dml_parms), intent(in) :: pm + integer, intent(in) :: iout + + call pm%mld_ml_parms%printout(iout) + write(iout,*) 'REAL : ',pm%aggr_omega_val,pm%aggr_thresh + end subroutine d_ml_parms_printout + + ! ! Routines printing out a description of the preconditioner ! diff --git a/mlprec/mld_c_inner_mod.f90 b/mlprec/mld_c_inner_mod.f90 index 5f47270c..5ff82c70 100644 --- a/mlprec/mld_c_inner_mod.f90 +++ b/mlprec/mld_c_inner_mod.f90 @@ -46,8 +46,6 @@ ! module mld_c_inner_mod use mld_c_prec_type - use mld_c_move_alloc_mod - interface mld_mlprec_bld subroutine mld_cmlprec_bld(a,desc_a,prec,info, amold, vmold) @@ -130,6 +128,7 @@ module mld_c_inner_mod end subroutine mld_c_dec_map_bld end interface mld_dec_map_bld + interface mld_aggrmat_asb subroutine mld_caggrmat_asb(a,desc_a,ilaggr,nlaggr,p,info) use psb_base_mod, only : psb_cspmat_type, psb_desc_type, psb_spk_ @@ -142,40 +141,25 @@ module mld_c_inner_mod end subroutine mld_caggrmat_asb end interface mld_aggrmat_asb - interface mld_aggrmat_nosmth_asb - subroutine mld_caggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,p,info) - use psb_base_mod, only : psb_cspmat_type, psb_desc_type, psb_spk_ - use mld_c_prec_type, only : mld_c_onelev_type - type(psb_cspmat_type), intent(in) :: a - type(psb_desc_type), intent(in) :: desc_a - integer, intent(inout) :: ilaggr(:), nlaggr(:) - type(mld_c_onelev_type), intent(inout), target :: p - integer, intent(out) :: info - end subroutine mld_caggrmat_nosmth_asb - end interface mld_aggrmat_nosmth_asb + - interface mld_aggrmat_smth_asb - subroutine mld_caggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info) + abstract interface + subroutine mld_caggrmat_var_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_restr,info) use psb_base_mod, only : psb_cspmat_type, psb_desc_type, psb_spk_ - use mld_c_prec_type, only : mld_c_onelev_type - type(psb_cspmat_type), intent(in) :: a - type(psb_desc_type), intent(in) :: desc_a - integer, intent(inout) :: ilaggr(:), nlaggr(:) - type(mld_c_onelev_type), intent(inout), target :: p - integer, intent(out) :: info - end subroutine mld_caggrmat_smth_asb - end interface mld_aggrmat_smth_asb + use mld_c_prec_type, only : mld_c_onelev_type, mld_sml_parms + type(psb_cspmat_type), intent(in) :: a + type(psb_desc_type), intent(in) :: desc_a + integer, intent(inout) :: ilaggr(:), nlaggr(:) + type(mld_sml_parms), intent(inout) :: parms + type(psb_cspmat_type), intent(out) :: ac,op_prol,op_restr + integer, intent(out) :: info + end subroutine mld_caggrmat_var_asb + end interface + + + procedure(mld_caggrmat_var_asb) :: mld_caggrmat_nosmth_asb, & + & mld_caggrmat_smth_asb, mld_caggrmat_minnrg_asb, & + & mld_caggrmat_biz_asb - interface mld_aggrmat_minnrg_asb - subroutine mld_caggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info) - use psb_base_mod, only : psb_cspmat_type, psb_desc_type, psb_spk_ - use mld_c_prec_type, only : mld_c_onelev_type - type(psb_cspmat_type), intent(in) :: a - type(psb_desc_type), intent(in) :: desc_a - integer, intent(inout) :: ilaggr(:), nlaggr(:) - type(mld_c_onelev_type), intent(inout), target :: p - integer, intent(out) :: info - end subroutine mld_caggrmat_minnrg_asb - end interface mld_aggrmat_minnrg_asb end module mld_c_inner_mod diff --git a/mlprec/mld_c_move_alloc_mod.f90 b/mlprec/mld_c_move_alloc_mod.f90 deleted file mode 100644 index 85f8120b..00000000 --- a/mlprec/mld_c_move_alloc_mod.f90 +++ /dev/null @@ -1,102 +0,0 @@ -!!$ -!!$ -!!$ MLD2P4 version 2.0 -!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package -!!$ based on PSBLAS (Parallel Sparse BLAS version 3.0) -!!$ -!!$ (C) Copyright 2008,2009,2010 -!!$ -!!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari CNRS-IRIT, Toulouse -!!$ Pasqua D'Ambra ICAR-CNR, Naples -!!$ Daniela di Serafino Second University of Naples -!!$ -!!$ Redistribution and use in source and binary forms, with or without -!!$ modification, are permitted provided that the following conditions -!!$ are met: -!!$ 1. Redistributions of source code must retain the above copyright -!!$ notice, this list of conditions and the following disclaimer. -!!$ 2. Redistributions in binary form must reproduce the above copyright -!!$ notice, this list of conditions, and the following disclaimer in the -!!$ documentation and/or other materials provided with the distribution. -!!$ 3. The name of the MLD2P4 group or the names of its contributors may -!!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. -!!$ -!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE MLD2P4 GROUP OR ITS CONTRIBUTORS -!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -!!$ POSSIBILITY OF SUCH DAMAGE. -!!$ -!!$ -! File: mld_c_move_alloc_mod.f90 -! -! Module: mld_c_move_alloc_mod -! -! This module defines move_alloc-like routines, and related interfaces, -! for the preconditioner data structures. . -! - -module mld_c_move_alloc_mod - - use mld_c_prec_type - - interface mld_move_alloc - module procedure mld_c_onelev_prec_move_alloc,& - & mld_cprec_move_alloc - end interface - -contains - - subroutine mld_c_onelev_prec_move_alloc(a, b,info) - use psb_base_mod - implicit none - type(mld_c_onelev_type), intent(inout) :: a, b - integer, intent(out) :: info - - call b%free(info) - call move_alloc(a%sm,b%sm) - if (info == psb_success_) call psb_move_alloc(a%ac,b%ac,info) - if (info == psb_success_) call psb_move_alloc(a%desc_ac,b%desc_ac,info) - if (info == psb_success_) call psb_move_alloc(a%map,b%map,info) - b%base_a => a%base_a - b%base_desc => a%base_desc - - end subroutine mld_c_onelev_prec_move_alloc - - subroutine mld_cprec_move_alloc(a, b,info) - use psb_base_mod - implicit none - type(mld_cprec_type), intent(inout) :: a - type(mld_cprec_type), intent(inout), target :: b - integer, intent(out) :: info - integer :: i - - if (allocated(b%precv)) then - ! This might not be required if FINAL procedures are available. - call mld_precfree(b,info) - if (info /= psb_success_) then - ! ????? - !!$ return - endif - end if - - call move_alloc(a%precv,b%precv) - ! Fix the pointers except on level 1. - do i=2, size(b%precv) - b%precv(i)%base_a => b%precv(i)%ac - b%precv(i)%base_desc => b%precv(i)%desc_ac - b%precv(i)%map%p_desc_X => b%precv(i-1)%base_desc - b%precv(i)%map%p_desc_Y => b%precv(i)%base_desc - end do - end subroutine mld_cprec_move_alloc - - -end module mld_c_move_alloc_mod diff --git a/mlprec/mld_c_onelev_mod.f90 b/mlprec/mld_c_onelev_mod.f90 index ba329fb7..2f9d30a2 100644 --- a/mlprec/mld_c_onelev_mod.f90 +++ b/mlprec/mld_c_onelev_mod.f90 @@ -141,6 +141,11 @@ module mld_c_onelev_mod procedure, pass(lv) :: get_nzeros => c_base_onelev_get_nzeros end type mld_c_onelev_type + type mld_c_onelev_node + type(mld_c_onelev_type) :: item + type(mld_c_onelev_node), pointer :: prev=>null(), next=>null() + end type mld_c_onelev_node + private :: c_base_onelev_default, c_base_onelev_sizeof, & & c_base_onelev_nullify, c_base_onelev_get_nzeros @@ -234,6 +239,9 @@ module mld_c_onelev_mod end subroutine mld_c_base_onelev_dump end interface + interface mld_move_alloc + module procedure mld_c_onelev_move_alloc + end interface contains ! @@ -312,4 +320,22 @@ contains end subroutine c_base_onelev_default + + subroutine mld_c_onelev_move_alloc(a, b,info) + use psb_base_mod + implicit none + type(mld_c_onelev_type), intent(inout) :: a, b + integer, intent(out) :: info + + call b%free(info) + b%parms = a%parms + call move_alloc(a%sm,b%sm) + if (info == psb_success_) call psb_move_alloc(a%ac,b%ac,info) + if (info == psb_success_) call psb_move_alloc(a%desc_ac,b%desc_ac,info) + if (info == psb_success_) call psb_move_alloc(a%map,b%map,info) + b%base_a => a%base_a + b%base_desc => a%base_desc + + end subroutine mld_c_onelev_move_alloc + end module mld_c_onelev_mod diff --git a/mlprec/mld_c_prec_mod.f90 b/mlprec/mld_c_prec_mod.f90 index 142a6d93..52f0ad8c 100644 --- a/mlprec/mld_c_prec_mod.f90 +++ b/mlprec/mld_c_prec_mod.f90 @@ -46,7 +46,6 @@ module mld_c_prec_mod use mld_c_prec_type - use mld_c_move_alloc_mod interface mld_precinit subroutine mld_cprecinit(p,ptype,info,nlev) diff --git a/mlprec/mld_c_prec_type.f90 b/mlprec/mld_c_prec_type.f90 index 925ceb1a..690def55 100644 --- a/mlprec/mld_c_prec_type.f90 +++ b/mlprec/mld_c_prec_type.f90 @@ -81,6 +81,7 @@ module mld_c_prec_type type, extends(psb_cprec_type) :: mld_cprec_type integer :: ictxt + integer(psb_ipk_) :: coarse_aggr_size real(psb_spk_) :: op_complexity=szero type(mld_c_onelev_type), allocatable :: precv(:) contains @@ -159,6 +160,10 @@ module mld_c_prec_type end subroutine mld_cprecaply1 end interface + interface mld_move_alloc + module procedure mld_cprec_move_alloc + end interface + contains ! ! Function returning the size of the mld_prec_type data structure @@ -577,5 +582,32 @@ contains end do end subroutine mld_c_dump + + subroutine mld_cprec_move_alloc(a, b,info) + use psb_base_mod + implicit none + type(mld_cprec_type), intent(inout) :: a + type(mld_cprec_type), intent(inout), target :: b + integer, intent(out) :: info + integer :: i + + if (allocated(b%precv)) then + ! This might not be required if FINAL procedures are available. + call mld_precfree(b,info) + if (info /= psb_success_) then + ! ????? + !!$ return + endif + end if + + call move_alloc(a%precv,b%precv) + ! Fix the pointers except on level 1. + do i=2, size(b%precv) + b%precv(i)%base_a => b%precv(i)%ac + b%precv(i)%base_desc => b%precv(i)%desc_ac + b%precv(i)%map%p_desc_X => b%precv(i-1)%base_desc + b%precv(i)%map%p_desc_Y => b%precv(i)%base_desc + end do + end subroutine mld_cprec_move_alloc end module mld_c_prec_type diff --git a/mlprec/mld_d_inner_mod.f90 b/mlprec/mld_d_inner_mod.f90 index dd544385..5b8a2979 100644 --- a/mlprec/mld_d_inner_mod.f90 +++ b/mlprec/mld_d_inner_mod.f90 @@ -46,8 +46,6 @@ ! module mld_d_inner_mod use mld_d_prec_type - use mld_d_move_alloc_mod - interface mld_mlprec_bld subroutine mld_dmlprec_bld(a,desc_a,prec,info, amold, vmold) @@ -130,6 +128,7 @@ module mld_d_inner_mod end subroutine mld_d_dec_map_bld end interface mld_dec_map_bld + interface mld_aggrmat_asb subroutine mld_daggrmat_asb(a,desc_a,ilaggr,nlaggr,p,info) use psb_base_mod, only : psb_dspmat_type, psb_desc_type, psb_dpk_ @@ -142,40 +141,25 @@ module mld_d_inner_mod end subroutine mld_daggrmat_asb end interface mld_aggrmat_asb - interface mld_aggrmat_nosmth_asb - subroutine mld_daggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,p,info) - use psb_base_mod, only : psb_dspmat_type, psb_desc_type, psb_dpk_ - use mld_d_prec_type, only : mld_d_onelev_type - type(psb_dspmat_type), intent(in) :: a - type(psb_desc_type), intent(in) :: desc_a - integer, intent(inout) :: ilaggr(:), nlaggr(:) - type(mld_d_onelev_type), intent(inout), target :: p - integer, intent(out) :: info - end subroutine mld_daggrmat_nosmth_asb - end interface mld_aggrmat_nosmth_asb + - interface mld_aggrmat_smth_asb - subroutine mld_daggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info) + abstract interface + subroutine mld_daggrmat_var_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_restr,info) use psb_base_mod, only : psb_dspmat_type, psb_desc_type, psb_dpk_ - use mld_d_prec_type, only : mld_d_onelev_type - type(psb_dspmat_type), intent(in) :: a - type(psb_desc_type), intent(in) :: desc_a - integer, intent(inout) :: ilaggr(:), nlaggr(:) - type(mld_d_onelev_type), intent(inout), target :: p - integer, intent(out) :: info - end subroutine mld_daggrmat_smth_asb - end interface mld_aggrmat_smth_asb + use mld_d_prec_type, only : mld_d_onelev_type, mld_dml_parms + type(psb_dspmat_type), intent(in) :: a + type(psb_desc_type), intent(in) :: desc_a + integer, intent(inout) :: ilaggr(:), nlaggr(:) + type(mld_dml_parms), intent(inout) :: parms + type(psb_dspmat_type), intent(out) :: ac,op_prol,op_restr + integer, intent(out) :: info + end subroutine mld_daggrmat_var_asb + end interface + + + procedure(mld_daggrmat_var_asb) :: mld_daggrmat_nosmth_asb, & + & mld_daggrmat_smth_asb, mld_daggrmat_minnrg_asb, & + & mld_daggrmat_biz_asb - interface mld_aggrmat_minnrg_asb - subroutine mld_daggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info) - use psb_base_mod, only : psb_dspmat_type, psb_desc_type, psb_dpk_ - use mld_d_prec_type, only : mld_d_onelev_type - type(psb_dspmat_type), intent(in) :: a - type(psb_desc_type), intent(in) :: desc_a - integer, intent(inout) :: ilaggr(:), nlaggr(:) - type(mld_d_onelev_type), intent(inout), target :: p - integer, intent(out) :: info - end subroutine mld_daggrmat_minnrg_asb - end interface mld_aggrmat_minnrg_asb end module mld_d_inner_mod diff --git a/mlprec/mld_d_move_alloc_mod.f90 b/mlprec/mld_d_move_alloc_mod.f90 deleted file mode 100644 index d7bc7f1e..00000000 --- a/mlprec/mld_d_move_alloc_mod.f90 +++ /dev/null @@ -1,102 +0,0 @@ -!!$ -!!$ -!!$ MLD2P4 version 2.0 -!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package -!!$ based on PSBLAS (Parallel Sparse BLAS version 3.0) -!!$ -!!$ (C) Copyright 2008,2009,2010 -!!$ -!!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari CNRS-IRIT, Toulouse -!!$ Pasqua D'Ambra ICAR-CNR, Naples -!!$ Daniela di Serafino Second University of Naples -!!$ -!!$ Redistribution and use in source and binary forms, with or without -!!$ modification, are permitted provided that the following conditions -!!$ are met: -!!$ 1. Redistributions of source code must retain the above copyright -!!$ notice, this list of conditions and the following disclaimer. -!!$ 2. Redistributions in binary form must reproduce the above copyright -!!$ notice, this list of conditions, and the following disclaimer in the -!!$ documentation and/or other materials provided with the distribution. -!!$ 3. The name of the MLD2P4 group or the names of its contributors may -!!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. -!!$ -!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE MLD2P4 GROUP OR ITS CONTRIBUTORS -!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -!!$ POSSIBILITY OF SUCH DAMAGE. -!!$ -!!$ -! File: mld_d_move_alloc_mod.f90 -! -! Module: mld_d_move_alloc_mod -! -! This module defines move_alloc-like routines, and related interfaces, -! for the preconditioner data structures. . -! - -module mld_d_move_alloc_mod - - use mld_d_prec_type - - interface mld_move_alloc - module procedure mld_d_onelev_prec_move_alloc,& - & mld_dprec_move_alloc - end interface - -contains - - subroutine mld_d_onelev_prec_move_alloc(a, b,info) - use psb_base_mod - implicit none - type(mld_d_onelev_type), intent(inout) :: a, b - integer, intent(out) :: info - - call b%free(info) - call move_alloc(a%sm,b%sm) - if (info == psb_success_) call psb_move_alloc(a%ac,b%ac,info) - if (info == psb_success_) call psb_move_alloc(a%desc_ac,b%desc_ac,info) - if (info == psb_success_) call psb_move_alloc(a%map,b%map,info) - b%base_a => a%base_a - b%base_desc => a%base_desc - - end subroutine mld_d_onelev_prec_move_alloc - - subroutine mld_dprec_move_alloc(a, b,info) - use psb_base_mod - implicit none - type(mld_dprec_type), intent(inout) :: a - type(mld_dprec_type), intent(inout), target :: b - integer, intent(out) :: info - integer :: i - - if (allocated(b%precv)) then - ! This might not be required if FINAL procedures are available. - call mld_precfree(b,info) - if (info /= psb_success_) then - ! ????? - !!$ return - endif - end if - - call move_alloc(a%precv,b%precv) - ! Fix the pointers except on level 1. - do i=2, size(b%precv) - b%precv(i)%base_a => b%precv(i)%ac - b%precv(i)%base_desc => b%precv(i)%desc_ac - b%precv(i)%map%p_desc_X => b%precv(i-1)%base_desc - b%precv(i)%map%p_desc_Y => b%precv(i)%base_desc - end do - end subroutine mld_dprec_move_alloc - - -end module mld_d_move_alloc_mod diff --git a/mlprec/mld_d_onelev_mod.f90 b/mlprec/mld_d_onelev_mod.f90 index a17a0333..a5689a69 100644 --- a/mlprec/mld_d_onelev_mod.f90 +++ b/mlprec/mld_d_onelev_mod.f90 @@ -141,6 +141,11 @@ module mld_d_onelev_mod procedure, pass(lv) :: get_nzeros => d_base_onelev_get_nzeros end type mld_d_onelev_type + type mld_d_onelev_node + type(mld_d_onelev_type) :: item + type(mld_d_onelev_node), pointer :: prev=>null(), next=>null() + end type mld_d_onelev_node + private :: d_base_onelev_default, d_base_onelev_sizeof, & & d_base_onelev_nullify, d_base_onelev_get_nzeros @@ -234,6 +239,9 @@ module mld_d_onelev_mod end subroutine mld_d_base_onelev_dump end interface + interface mld_move_alloc + module procedure mld_d_onelev_move_alloc + end interface contains ! @@ -312,4 +320,22 @@ contains end subroutine d_base_onelev_default + + subroutine mld_d_onelev_move_alloc(a, b,info) + use psb_base_mod + implicit none + type(mld_d_onelev_type), intent(inout) :: a, b + integer, intent(out) :: info + + call b%free(info) + b%parms = a%parms + call move_alloc(a%sm,b%sm) + if (info == psb_success_) call psb_move_alloc(a%ac,b%ac,info) + if (info == psb_success_) call psb_move_alloc(a%desc_ac,b%desc_ac,info) + if (info == psb_success_) call psb_move_alloc(a%map,b%map,info) + b%base_a => a%base_a + b%base_desc => a%base_desc + + end subroutine mld_d_onelev_move_alloc + end module mld_d_onelev_mod diff --git a/mlprec/mld_d_prec_mod.f90 b/mlprec/mld_d_prec_mod.f90 index a4006aca..34231e12 100644 --- a/mlprec/mld_d_prec_mod.f90 +++ b/mlprec/mld_d_prec_mod.f90 @@ -46,7 +46,6 @@ module mld_d_prec_mod use mld_d_prec_type - use mld_d_move_alloc_mod interface mld_precinit subroutine mld_dprecinit(p,ptype,info,nlev) diff --git a/mlprec/mld_d_prec_type.f90 b/mlprec/mld_d_prec_type.f90 index e5bd564d..296751c5 100644 --- a/mlprec/mld_d_prec_type.f90 +++ b/mlprec/mld_d_prec_type.f90 @@ -81,6 +81,7 @@ module mld_d_prec_type type, extends(psb_dprec_type) :: mld_dprec_type integer :: ictxt + integer(psb_ipk_) :: coarse_aggr_size real(psb_dpk_) :: op_complexity=dzero type(mld_d_onelev_type), allocatable :: precv(:) contains @@ -159,6 +160,10 @@ module mld_d_prec_type end subroutine mld_dprecaply1 end interface + interface mld_move_alloc + module procedure mld_dprec_move_alloc + end interface + contains ! ! Function returning the size of the mld_prec_type data structure @@ -577,5 +582,32 @@ contains end do end subroutine mld_d_dump + + subroutine mld_dprec_move_alloc(a, b,info) + use psb_base_mod + implicit none + type(mld_dprec_type), intent(inout) :: a + type(mld_dprec_type), intent(inout), target :: b + integer, intent(out) :: info + integer :: i + + if (allocated(b%precv)) then + ! This might not be required if FINAL procedures are available. + call mld_precfree(b,info) + if (info /= psb_success_) then + ! ????? + !!$ return + endif + end if + + call move_alloc(a%precv,b%precv) + ! Fix the pointers except on level 1. + do i=2, size(b%precv) + b%precv(i)%base_a => b%precv(i)%ac + b%precv(i)%base_desc => b%precv(i)%desc_ac + b%precv(i)%map%p_desc_X => b%precv(i-1)%base_desc + b%precv(i)%map%p_desc_Y => b%precv(i)%base_desc + end do + end subroutine mld_dprec_move_alloc end module mld_d_prec_type diff --git a/mlprec/mld_s_inner_mod.f90 b/mlprec/mld_s_inner_mod.f90 index d5aeb204..b09fa587 100644 --- a/mlprec/mld_s_inner_mod.f90 +++ b/mlprec/mld_s_inner_mod.f90 @@ -46,8 +46,6 @@ ! module mld_s_inner_mod use mld_s_prec_type - use mld_s_move_alloc_mod - interface mld_mlprec_bld subroutine mld_smlprec_bld(a,desc_a,prec,info, amold, vmold) @@ -130,6 +128,7 @@ module mld_s_inner_mod end subroutine mld_s_dec_map_bld end interface mld_dec_map_bld + interface mld_aggrmat_asb subroutine mld_saggrmat_asb(a,desc_a,ilaggr,nlaggr,p,info) use psb_base_mod, only : psb_sspmat_type, psb_desc_type, psb_spk_ @@ -142,40 +141,25 @@ module mld_s_inner_mod end subroutine mld_saggrmat_asb end interface mld_aggrmat_asb - interface mld_aggrmat_nosmth_asb - subroutine mld_saggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,p,info) - use psb_base_mod, only : psb_sspmat_type, psb_desc_type, psb_spk_ - use mld_s_prec_type, only : mld_s_onelev_type - type(psb_sspmat_type), intent(in) :: a - type(psb_desc_type), intent(in) :: desc_a - integer, intent(inout) :: ilaggr(:), nlaggr(:) - type(mld_s_onelev_type), intent(inout), target :: p - integer, intent(out) :: info - end subroutine mld_saggrmat_nosmth_asb - end interface mld_aggrmat_nosmth_asb + - interface mld_aggrmat_smth_asb - subroutine mld_saggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info) + abstract interface + subroutine mld_saggrmat_var_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_restr,info) use psb_base_mod, only : psb_sspmat_type, psb_desc_type, psb_spk_ - use mld_s_prec_type, only : mld_s_onelev_type - type(psb_sspmat_type), intent(in) :: a - type(psb_desc_type), intent(in) :: desc_a - integer, intent(inout) :: ilaggr(:), nlaggr(:) - type(mld_s_onelev_type), intent(inout), target :: p - integer, intent(out) :: info - end subroutine mld_saggrmat_smth_asb - end interface mld_aggrmat_smth_asb + use mld_s_prec_type, only : mld_s_onelev_type, mld_sml_parms + type(psb_sspmat_type), intent(in) :: a + type(psb_desc_type), intent(in) :: desc_a + integer, intent(inout) :: ilaggr(:), nlaggr(:) + type(mld_sml_parms), intent(inout) :: parms + type(psb_sspmat_type), intent(out) :: ac,op_prol,op_restr + integer, intent(out) :: info + end subroutine mld_saggrmat_var_asb + end interface + + + procedure(mld_saggrmat_var_asb) :: mld_saggrmat_nosmth_asb, & + & mld_saggrmat_smth_asb, mld_saggrmat_minnrg_asb, & + & mld_saggrmat_biz_asb - interface mld_aggrmat_minnrg_asb - subroutine mld_saggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info) - use psb_base_mod, only : psb_sspmat_type, psb_desc_type, psb_spk_ - use mld_s_prec_type, only : mld_s_onelev_type - type(psb_sspmat_type), intent(in) :: a - type(psb_desc_type), intent(in) :: desc_a - integer, intent(inout) :: ilaggr(:), nlaggr(:) - type(mld_s_onelev_type), intent(inout), target :: p - integer, intent(out) :: info - end subroutine mld_saggrmat_minnrg_asb - end interface mld_aggrmat_minnrg_asb end module mld_s_inner_mod diff --git a/mlprec/mld_s_move_alloc_mod.f90 b/mlprec/mld_s_move_alloc_mod.f90 deleted file mode 100644 index d23fefe9..00000000 --- a/mlprec/mld_s_move_alloc_mod.f90 +++ /dev/null @@ -1,102 +0,0 @@ -!!$ -!!$ -!!$ MLD2P4 version 2.0 -!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package -!!$ based on PSBLAS (Parallel Sparse BLAS version 3.0) -!!$ -!!$ (C) Copyright 2008,2009,2010 -!!$ -!!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari CNRS-IRIT, Toulouse -!!$ Pasqua D'Ambra ICAR-CNR, Naples -!!$ Daniela di Serafino Second University of Naples -!!$ -!!$ Redistribution and use in source and binary forms, with or without -!!$ modification, are permitted provided that the following conditions -!!$ are met: -!!$ 1. Redistributions of source code must retain the above copyright -!!$ notice, this list of conditions and the following disclaimer. -!!$ 2. Redistributions in binary form must reproduce the above copyright -!!$ notice, this list of conditions, and the following disclaimer in the -!!$ documentation and/or other materials provided with the distribution. -!!$ 3. The name of the MLD2P4 group or the names of its contributors may -!!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. -!!$ -!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE MLD2P4 GROUP OR ITS CONTRIBUTORS -!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -!!$ POSSIBILITY OF SUCH DAMAGE. -!!$ -!!$ -! File: mld_s_move_alloc_mod.f90 -! -! Module: mld_s_move_alloc_mod -! -! This module defines move_alloc-like routines, and related interfaces, -! for the preconditioner data structures. . -! - -module mld_s_move_alloc_mod - - use mld_s_prec_type - - interface mld_move_alloc - module procedure mld_s_onelev_prec_move_alloc,& - & mld_sprec_move_alloc - end interface - -contains - - subroutine mld_s_onelev_prec_move_alloc(a, b,info) - use psb_base_mod - implicit none - type(mld_s_onelev_type), intent(inout) :: a, b - integer, intent(out) :: info - - call b%free(info) - call move_alloc(a%sm,b%sm) - if (info == psb_success_) call psb_move_alloc(a%ac,b%ac,info) - if (info == psb_success_) call psb_move_alloc(a%desc_ac,b%desc_ac,info) - if (info == psb_success_) call psb_move_alloc(a%map,b%map,info) - b%base_a => a%base_a - b%base_desc => a%base_desc - - end subroutine mld_s_onelev_prec_move_alloc - - subroutine mld_sprec_move_alloc(a, b,info) - use psb_base_mod - implicit none - type(mld_sprec_type), intent(inout) :: a - type(mld_sprec_type), intent(inout), target :: b - integer, intent(out) :: info - integer :: i - - if (allocated(b%precv)) then - ! This might not be required if FINAL procedures are available. - call mld_precfree(b,info) - if (info /= psb_success_) then - ! ????? - !!$ return - endif - end if - - call move_alloc(a%precv,b%precv) - ! Fix the pointers except on level 1. - do i=2, size(b%precv) - b%precv(i)%base_a => b%precv(i)%ac - b%precv(i)%base_desc => b%precv(i)%desc_ac - b%precv(i)%map%p_desc_X => b%precv(i-1)%base_desc - b%precv(i)%map%p_desc_Y => b%precv(i)%base_desc - end do - end subroutine mld_sprec_move_alloc - - -end module mld_s_move_alloc_mod diff --git a/mlprec/mld_s_onelev_mod.f90 b/mlprec/mld_s_onelev_mod.f90 index 17f69512..890467c2 100644 --- a/mlprec/mld_s_onelev_mod.f90 +++ b/mlprec/mld_s_onelev_mod.f90 @@ -141,6 +141,11 @@ module mld_s_onelev_mod procedure, pass(lv) :: get_nzeros => s_base_onelev_get_nzeros end type mld_s_onelev_type + type mld_s_onelev_node + type(mld_s_onelev_type) :: item + type(mld_s_onelev_node), pointer :: prev=>null(), next=>null() + end type mld_s_onelev_node + private :: s_base_onelev_default, s_base_onelev_sizeof, & & s_base_onelev_nullify, s_base_onelev_get_nzeros @@ -234,6 +239,9 @@ module mld_s_onelev_mod end subroutine mld_s_base_onelev_dump end interface + interface mld_move_alloc + module procedure mld_s_onelev_move_alloc + end interface contains ! @@ -312,4 +320,22 @@ contains end subroutine s_base_onelev_default + + subroutine mld_s_onelev_move_alloc(a, b,info) + use psb_base_mod + implicit none + type(mld_s_onelev_type), intent(inout) :: a, b + integer, intent(out) :: info + + call b%free(info) + b%parms = a%parms + call move_alloc(a%sm,b%sm) + if (info == psb_success_) call psb_move_alloc(a%ac,b%ac,info) + if (info == psb_success_) call psb_move_alloc(a%desc_ac,b%desc_ac,info) + if (info == psb_success_) call psb_move_alloc(a%map,b%map,info) + b%base_a => a%base_a + b%base_desc => a%base_desc + + end subroutine mld_s_onelev_move_alloc + end module mld_s_onelev_mod diff --git a/mlprec/mld_s_prec_mod.f90 b/mlprec/mld_s_prec_mod.f90 index f67c0df6..22981b22 100644 --- a/mlprec/mld_s_prec_mod.f90 +++ b/mlprec/mld_s_prec_mod.f90 @@ -46,7 +46,6 @@ module mld_s_prec_mod use mld_s_prec_type - use mld_s_move_alloc_mod interface mld_precinit subroutine mld_sprecinit(p,ptype,info,nlev) diff --git a/mlprec/mld_s_prec_type.f90 b/mlprec/mld_s_prec_type.f90 index c8e590ec..da4cc788 100644 --- a/mlprec/mld_s_prec_type.f90 +++ b/mlprec/mld_s_prec_type.f90 @@ -81,6 +81,7 @@ module mld_s_prec_type type, extends(psb_sprec_type) :: mld_sprec_type integer :: ictxt + integer(psb_ipk_) :: coarse_aggr_size real(psb_spk_) :: op_complexity=szero type(mld_s_onelev_type), allocatable :: precv(:) contains @@ -159,6 +160,10 @@ module mld_s_prec_type end subroutine mld_sprecaply1 end interface + interface mld_move_alloc + module procedure mld_sprec_move_alloc + end interface + contains ! ! Function returning the size of the mld_prec_type data structure @@ -577,5 +582,32 @@ contains end do end subroutine mld_s_dump + + subroutine mld_sprec_move_alloc(a, b,info) + use psb_base_mod + implicit none + type(mld_sprec_type), intent(inout) :: a + type(mld_sprec_type), intent(inout), target :: b + integer, intent(out) :: info + integer :: i + + if (allocated(b%precv)) then + ! This might not be required if FINAL procedures are available. + call mld_precfree(b,info) + if (info /= psb_success_) then + ! ????? + !!$ return + endif + end if + + call move_alloc(a%precv,b%precv) + ! Fix the pointers except on level 1. + do i=2, size(b%precv) + b%precv(i)%base_a => b%precv(i)%ac + b%precv(i)%base_desc => b%precv(i)%desc_ac + b%precv(i)%map%p_desc_X => b%precv(i-1)%base_desc + b%precv(i)%map%p_desc_Y => b%precv(i)%base_desc + end do + end subroutine mld_sprec_move_alloc end module mld_s_prec_type diff --git a/mlprec/mld_z_inner_mod.f90 b/mlprec/mld_z_inner_mod.f90 index 647e1b88..2428a3ec 100644 --- a/mlprec/mld_z_inner_mod.f90 +++ b/mlprec/mld_z_inner_mod.f90 @@ -46,8 +46,6 @@ ! module mld_z_inner_mod use mld_z_prec_type - use mld_z_move_alloc_mod - interface mld_mlprec_bld subroutine mld_zmlprec_bld(a,desc_a,prec,info, amold, vmold) @@ -130,6 +128,7 @@ module mld_z_inner_mod end subroutine mld_z_dec_map_bld end interface mld_dec_map_bld + interface mld_aggrmat_asb subroutine mld_zaggrmat_asb(a,desc_a,ilaggr,nlaggr,p,info) use psb_base_mod, only : psb_zspmat_type, psb_desc_type, psb_dpk_ @@ -142,40 +141,25 @@ module mld_z_inner_mod end subroutine mld_zaggrmat_asb end interface mld_aggrmat_asb - interface mld_aggrmat_nosmth_asb - subroutine mld_zaggrmat_nosmth_asb(a,desc_a,ilaggr,nlaggr,p,info) - use psb_base_mod, only : psb_zspmat_type, psb_desc_type, psb_dpk_ - use mld_z_prec_type, only : mld_z_onelev_type - type(psb_zspmat_type), intent(in) :: a - type(psb_desc_type), intent(in) :: desc_a - integer, intent(inout) :: ilaggr(:), nlaggr(:) - type(mld_z_onelev_type), intent(inout), target :: p - integer, intent(out) :: info - end subroutine mld_zaggrmat_nosmth_asb - end interface mld_aggrmat_nosmth_asb + - interface mld_aggrmat_smth_asb - subroutine mld_zaggrmat_smth_asb(a,desc_a,ilaggr,nlaggr,p,info) + abstract interface + subroutine mld_zaggrmat_var_asb(a,desc_a,ilaggr,nlaggr,parms,ac,op_prol,op_restr,info) use psb_base_mod, only : psb_zspmat_type, psb_desc_type, psb_dpk_ - use mld_z_prec_type, only : mld_z_onelev_type - type(psb_zspmat_type), intent(in) :: a - type(psb_desc_type), intent(in) :: desc_a - integer, intent(inout) :: ilaggr(:), nlaggr(:) - type(mld_z_onelev_type), intent(inout), target :: p - integer, intent(out) :: info - end subroutine mld_zaggrmat_smth_asb - end interface mld_aggrmat_smth_asb + use mld_z_prec_type, only : mld_z_onelev_type, mld_dml_parms + type(psb_zspmat_type), intent(in) :: a + type(psb_desc_type), intent(in) :: desc_a + integer, intent(inout) :: ilaggr(:), nlaggr(:) + type(mld_dml_parms), intent(inout) :: parms + type(psb_zspmat_type), intent(out) :: ac,op_prol,op_restr + integer, intent(out) :: info + end subroutine mld_zaggrmat_var_asb + end interface + + + procedure(mld_zaggrmat_var_asb) :: mld_zaggrmat_nosmth_asb, & + & mld_zaggrmat_smth_asb, mld_zaggrmat_minnrg_asb, & + & mld_zaggrmat_biz_asb - interface mld_aggrmat_minnrg_asb - subroutine mld_zaggrmat_minnrg_asb(a,desc_a,ilaggr,nlaggr,p,info) - use psb_base_mod, only : psb_zspmat_type, psb_desc_type, psb_dpk_ - use mld_z_prec_type, only : mld_z_onelev_type - type(psb_zspmat_type), intent(in) :: a - type(psb_desc_type), intent(in) :: desc_a - integer, intent(inout) :: ilaggr(:), nlaggr(:) - type(mld_z_onelev_type), intent(inout), target :: p - integer, intent(out) :: info - end subroutine mld_zaggrmat_minnrg_asb - end interface mld_aggrmat_minnrg_asb end module mld_z_inner_mod diff --git a/mlprec/mld_z_move_alloc_mod.f90 b/mlprec/mld_z_move_alloc_mod.f90 deleted file mode 100644 index 098d763a..00000000 --- a/mlprec/mld_z_move_alloc_mod.f90 +++ /dev/null @@ -1,102 +0,0 @@ -!!$ -!!$ -!!$ MLD2P4 version 2.0 -!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package -!!$ based on PSBLAS (Parallel Sparse BLAS version 3.0) -!!$ -!!$ (C) Copyright 2008,2009,2010 -!!$ -!!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari CNRS-IRIT, Toulouse -!!$ Pasqua D'Ambra ICAR-CNR, Naples -!!$ Daniela di Serafino Second University of Naples -!!$ -!!$ Redistribution and use in source and binary forms, with or without -!!$ modification, are permitted provided that the following conditions -!!$ are met: -!!$ 1. Redistributions of source code must retain the above copyright -!!$ notice, this list of conditions and the following disclaimer. -!!$ 2. Redistributions in binary form must reproduce the above copyright -!!$ notice, this list of conditions, and the following disclaimer in the -!!$ documentation and/or other materials provided with the distribution. -!!$ 3. The name of the MLD2P4 group or the names of its contributors may -!!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. -!!$ -!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE MLD2P4 GROUP OR ITS CONTRIBUTORS -!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -!!$ POSSIBILITY OF SUCH DAMAGE. -!!$ -!!$ -! File: mld_z_move_alloc_mod.f90 -! -! Module: mld_z_move_alloc_mod -! -! This module defines move_alloc-like routines, and related interfaces, -! for the preconditioner data structures. . -! - -module mld_z_move_alloc_mod - - use mld_z_prec_type - - interface mld_move_alloc - module procedure mld_z_onelev_prec_move_alloc,& - & mld_zprec_move_alloc - end interface - -contains - - subroutine mld_z_onelev_prec_move_alloc(a, b,info) - use psb_base_mod - implicit none - type(mld_z_onelev_type), intent(inout) :: a, b - integer, intent(out) :: info - - call b%free(info) - call move_alloc(a%sm,b%sm) - if (info == psb_success_) call psb_move_alloc(a%ac,b%ac,info) - if (info == psb_success_) call psb_move_alloc(a%desc_ac,b%desc_ac,info) - if (info == psb_success_) call psb_move_alloc(a%map,b%map,info) - b%base_a => a%base_a - b%base_desc => a%base_desc - - end subroutine mld_z_onelev_prec_move_alloc - - subroutine mld_zprec_move_alloc(a, b,info) - use psb_base_mod - implicit none - type(mld_zprec_type), intent(inout) :: a - type(mld_zprec_type), intent(inout), target :: b - integer, intent(out) :: info - integer :: i - - if (allocated(b%precv)) then - ! This might not be required if FINAL procedures are available. - call mld_precfree(b,info) - if (info /= psb_success_) then - ! ????? - !!$ return - endif - end if - - call move_alloc(a%precv,b%precv) - ! Fix the pointers except on level 1. - do i=2, size(b%precv) - b%precv(i)%base_a => b%precv(i)%ac - b%precv(i)%base_desc => b%precv(i)%desc_ac - b%precv(i)%map%p_desc_X => b%precv(i-1)%base_desc - b%precv(i)%map%p_desc_Y => b%precv(i)%base_desc - end do - end subroutine mld_zprec_move_alloc - - -end module mld_z_move_alloc_mod diff --git a/mlprec/mld_z_onelev_mod.f90 b/mlprec/mld_z_onelev_mod.f90 index 6dfed8c2..3e2e7da2 100644 --- a/mlprec/mld_z_onelev_mod.f90 +++ b/mlprec/mld_z_onelev_mod.f90 @@ -141,6 +141,11 @@ module mld_z_onelev_mod procedure, pass(lv) :: get_nzeros => z_base_onelev_get_nzeros end type mld_z_onelev_type + type mld_z_onelev_node + type(mld_z_onelev_type) :: item + type(mld_z_onelev_node), pointer :: prev=>null(), next=>null() + end type mld_z_onelev_node + private :: z_base_onelev_default, z_base_onelev_sizeof, & & z_base_onelev_nullify, z_base_onelev_get_nzeros @@ -234,6 +239,9 @@ module mld_z_onelev_mod end subroutine mld_z_base_onelev_dump end interface + interface mld_move_alloc + module procedure mld_z_onelev_move_alloc + end interface contains ! @@ -312,4 +320,22 @@ contains end subroutine z_base_onelev_default + + subroutine mld_z_onelev_move_alloc(a, b,info) + use psb_base_mod + implicit none + type(mld_z_onelev_type), intent(inout) :: a, b + integer, intent(out) :: info + + call b%free(info) + b%parms = a%parms + call move_alloc(a%sm,b%sm) + if (info == psb_success_) call psb_move_alloc(a%ac,b%ac,info) + if (info == psb_success_) call psb_move_alloc(a%desc_ac,b%desc_ac,info) + if (info == psb_success_) call psb_move_alloc(a%map,b%map,info) + b%base_a => a%base_a + b%base_desc => a%base_desc + + end subroutine mld_z_onelev_move_alloc + end module mld_z_onelev_mod diff --git a/mlprec/mld_z_prec_mod.f90 b/mlprec/mld_z_prec_mod.f90 index 0ec94a43..542aa12a 100644 --- a/mlprec/mld_z_prec_mod.f90 +++ b/mlprec/mld_z_prec_mod.f90 @@ -46,7 +46,6 @@ module mld_z_prec_mod use mld_z_prec_type - use mld_z_move_alloc_mod interface mld_precinit subroutine mld_zprecinit(p,ptype,info,nlev) diff --git a/mlprec/mld_z_prec_type.f90 b/mlprec/mld_z_prec_type.f90 index d3ea486a..f910d7ba 100644 --- a/mlprec/mld_z_prec_type.f90 +++ b/mlprec/mld_z_prec_type.f90 @@ -81,6 +81,7 @@ module mld_z_prec_type type, extends(psb_zprec_type) :: mld_zprec_type integer :: ictxt + integer(psb_ipk_) :: coarse_aggr_size real(psb_dpk_) :: op_complexity=dzero type(mld_z_onelev_type), allocatable :: precv(:) contains @@ -159,6 +160,10 @@ module mld_z_prec_type end subroutine mld_zprecaply1 end interface + interface mld_move_alloc + module procedure mld_zprec_move_alloc + end interface + contains ! ! Function returning the size of the mld_prec_type data structure @@ -577,5 +582,32 @@ contains end do end subroutine mld_z_dump + + subroutine mld_zprec_move_alloc(a, b,info) + use psb_base_mod + implicit none + type(mld_zprec_type), intent(inout) :: a + type(mld_zprec_type), intent(inout), target :: b + integer, intent(out) :: info + integer :: i + + if (allocated(b%precv)) then + ! This might not be required if FINAL procedures are available. + call mld_precfree(b,info) + if (info /= psb_success_) then + ! ????? + !!$ return + endif + end if + + call move_alloc(a%precv,b%precv) + ! Fix the pointers except on level 1. + do i=2, size(b%precv) + b%precv(i)%base_a => b%precv(i)%ac + b%precv(i)%base_desc => b%precv(i)%desc_ac + b%precv(i)%map%p_desc_X => b%precv(i-1)%base_desc + b%precv(i)%map%p_desc_Y => b%precv(i)%base_desc + end do + end subroutine mld_zprec_move_alloc end module mld_z_prec_type diff --git a/tests/pdegen/ppde2d.f90 b/tests/pdegen/ppde2d.f90 index 1d4a549b..8ad9dfd8 100644 --- a/tests/pdegen/ppde2d.f90 +++ b/tests/pdegen/ppde2d.f90 @@ -160,6 +160,7 @@ program ppde2d character(len=16) :: aggr_alg ! local or global aggregation character(len=16) :: mltype ! additive or multiplicative 2nd level prec character(len=16) :: smthpos ! side: pre, post, both smoothing + integer :: csize ! aggregation size at which to stop. character(len=16) :: cmat ! coarse mat character(len=16) :: csolve ! Coarse solver: bjac, umf, slu, sludist character(len=16) :: csbsolve ! Coarse subsolver: ILU, ILU(T), SuperLU, UMFPACK. @@ -246,6 +247,7 @@ program ppde2d call mld_precset(prec,mld_coarse_fillin_, prectype%cfill, info) call mld_precset(prec,mld_coarse_iluthrs_, prectype%cthres, info) call mld_precset(prec,mld_coarse_sweeps_, prectype%cjswp, info) + call mld_precset(prec,mld_coarse_aggr_size_, prectype%csize, info) else nlv = 1 call mld_precinit(prec,prectype%prec, info, nlev=nlv) @@ -386,6 +388,7 @@ contains call read_data(prectype%cthres,5) ! Threshold for fact. 1 ILU(T) call read_data(prectype%cjswp,5) ! Jacobi sweeps call read_data(prectype%athres,5) ! smoother aggr thresh + call read_data(prectype%csize,5) ! coarse size end if end if @@ -423,6 +426,7 @@ contains call psb_bcast(ictxt,prectype%cthres) ! Threshold for fact. 1 ILU(T) call psb_bcast(ictxt,prectype%cjswp) ! Jacobi sweeps call psb_bcast(ictxt,prectype%athres) ! smoother aggr thresh + call psb_bcast(ictxt,prectype%csize) ! coarse size end if if (iam == psb_root_) then diff --git a/tests/pdegen/ppde3d.f90 b/tests/pdegen/ppde3d.f90 index 1247deb6..c78964db 100644 --- a/tests/pdegen/ppde3d.f90 +++ b/tests/pdegen/ppde3d.f90 @@ -172,6 +172,7 @@ program ppde3d character(len=16) :: aggr_alg ! local or global aggregation character(len=16) :: mltype ! additive or multiplicative 2nd level prec character(len=16) :: smthpos ! side: pre, post, both smoothing + integer :: csize ! aggregation size at which to stop. character(len=16) :: cmat ! coarse mat character(len=16) :: csolve ! Coarse solver: bjac, umf, slu, sludist character(len=16) :: csbsolve ! Coarse subsolver: ILU, ILU(T), SuperLU, UMFPACK. @@ -261,6 +262,7 @@ program ppde3d call mld_precset(prec,mld_coarse_fillin_, prectype%cfill, info) call mld_precset(prec,mld_coarse_iluthrs_, prectype%cthres, info) call mld_precset(prec,mld_coarse_sweeps_, prectype%cjswp, info) + call mld_precset(prec,mld_coarse_aggr_size_, prectype%csize, info) else nlv = 1 call mld_precinit(prec,prectype%prec, info, nlev=nlv) @@ -401,6 +403,7 @@ contains call read_data(prectype%cthres,5) ! Threshold for fact. 1 ILU(T) call read_data(prectype%cjswp,5) ! Jacobi sweeps call read_data(prectype%athres,5) ! smoother aggr thresh + call read_data(prectype%csize,5) ! coarse size end if end if @@ -438,6 +441,7 @@ contains call psb_bcast(ictxt,prectype%cthres) ! Threshold for fact. 1 ILU(T) call psb_bcast(ictxt,prectype%cjswp) ! Jacobi sweeps call psb_bcast(ictxt,prectype%athres) ! smoother aggr thresh + call psb_bcast(ictxt,prectype%csize) ! coarse size end if if (iam == psb_root_) then diff --git a/tests/pdegen/runs/ppde.inp b/tests/pdegen/runs/ppde.inp index 40165150..d3dffb5a 100644 --- a/tests/pdegen/runs/ppde.inp +++ b/tests/pdegen/runs/ppde.inp @@ -1,6 +1,6 @@ BICGSTAB ! Iterative method: BiCGSTAB BiCG CGS RGMRES BiCGSTABL CG CSR ! Storage format CSR COO JAD -040 ! IDIM; domain size is idim**3 +060 ! IDIM; domain size is idim**3 2 ! ISTOPC 0100 ! ITMAX -1 ! ITRACE @@ -17,14 +17,15 @@ ILU ! Subdomain solver DSCALE ILU MILU ILUT UMF SLU 4 ! Smoother/Jacobi sweeps BJAC ! Smoother type JACOBI BJAC AS; ignored for non-ML 3 ! Number of levels in a multilevel preconditioner -SMOOTHED ! Kind of aggregation: SMOOTHED, NONSMOOTHED +NONSMOOTHED ! Kind of aggregation: SMOOTHED, NONSMOOTHED DEC ! Type of aggregation DEC SYMDEC GLB MULT ! Type of multilevel correction: ADD MULT TWOSIDE ! Side of correction PRE POST TWOSIDE (ignored for ADD) -DIST ! Coarse level: matrix distribution DIST REPL +REPL ! Coarse level: matrix distribution DIST REPL BJAC ! Coarse level: solver JACOBI BJAC UMF SLU SLUDIST ILU ! Coarse level: subsolver DSCALE ILU UMF SLU SLUDIST 1 ! Coarse level: Level-set N for ILU(N) 1.d-4 ! Coarse level: Threshold T for ILU(T,P) 4 ! Coarse level: Number of Jacobi sweeps -0.10d0 ! Smoother Aggregation Threshold: >= 0.0 default if <0 +100 ! Coarse size limit to determine levels. If <0, then use NL diff --git a/tests/pdegen/spde2d.f90 b/tests/pdegen/spde2d.f90 index b0d47499..5eaa9b36 100644 --- a/tests/pdegen/spde2d.f90 +++ b/tests/pdegen/spde2d.f90 @@ -160,6 +160,7 @@ program spde2d character(len=16) :: aggr_alg ! local or global aggregation character(len=16) :: mltype ! additive or multiplicative 2nd level prec character(len=16) :: smthpos ! side: pre, post, both smoothing + integer :: csize ! aggregation size at which to stop. character(len=16) :: cmat ! coarse mat character(len=16) :: csolve ! Coarse solver: bjac, umf, slu, sludist character(len=16) :: csbsolve ! Coarse subsolver: ILU, ILU(T), SuperLU, UMFPACK. @@ -246,6 +247,7 @@ program spde2d call mld_precset(prec,mld_coarse_fillin_, prectype%cfill, info) call mld_precset(prec,mld_coarse_iluthrs_, prectype%cthres, info) call mld_precset(prec,mld_coarse_sweeps_, prectype%cjswp, info) + call mld_precset(prec,mld_coarse_aggr_size_, prectype%csize, info) else nlv = 1 call mld_precinit(prec,prectype%prec, info, nlev=nlv) @@ -386,6 +388,7 @@ contains call read_data(prectype%cthres,5) ! Threshold for fact. 1 ILU(T) call read_data(prectype%cjswp,5) ! Jacobi sweeps call read_data(prectype%athres,5) ! smoother aggr thresh + call read_data(prectype%csize,5) ! coarse size end if end if @@ -423,6 +426,7 @@ contains call psb_bcast(ictxt,prectype%cthres) ! Threshold for fact. 1 ILU(T) call psb_bcast(ictxt,prectype%cjswp) ! Jacobi sweeps call psb_bcast(ictxt,prectype%athres) ! smoother aggr thresh + call psb_bcast(ictxt,prectype%csize) ! coarse size end if if (iam == psb_root_) then diff --git a/tests/pdegen/spde3d.f90 b/tests/pdegen/spde3d.f90 index 2cfd7d0f..b96821e5 100644 --- a/tests/pdegen/spde3d.f90 +++ b/tests/pdegen/spde3d.f90 @@ -172,6 +172,7 @@ program spde3d character(len=16) :: aggr_alg ! local or global aggregation character(len=16) :: mltype ! additive or multiplicative 2nd level prec character(len=16) :: smthpos ! side: pre, post, both smoothing + integer :: csize ! aggregation size at which to stop. character(len=16) :: cmat ! coarse mat character(len=16) :: csolve ! Coarse solver: bjac, umf, slu, sludist character(len=16) :: csbsolve ! Coarse subsolver: ILU, ILU(T), SuperLU, UMFPACK. @@ -261,6 +262,7 @@ program spde3d call mld_precset(prec,mld_coarse_fillin_, prectype%cfill, info) call mld_precset(prec,mld_coarse_iluthrs_, prectype%cthres, info) call mld_precset(prec,mld_coarse_sweeps_, prectype%cjswp, info) + call mld_precset(prec,mld_coarse_aggr_size_, prectype%csize, info) else nlv = 1 call mld_precinit(prec,prectype%prec, info, nlev=nlv) @@ -401,6 +403,7 @@ contains call read_data(prectype%cthres,5) ! Threshold for fact. 1 ILU(T) call read_data(prectype%cjswp,5) ! Jacobi sweeps call read_data(prectype%athres,5) ! smoother aggr thresh + call read_data(prectype%csize,5) ! coarse size end if end if @@ -438,6 +441,7 @@ contains call psb_bcast(ictxt,prectype%cthres) ! Threshold for fact. 1 ILU(T) call psb_bcast(ictxt,prectype%cjswp) ! Jacobi sweeps call psb_bcast(ictxt,prectype%athres) ! smoother aggr thresh + call psb_bcast(ictxt,prectype%csize) ! coarse size end if if (iam == psb_root_) then