diff --git a/README b/README index cf525b30..48305559 100644 --- a/README +++ b/README @@ -1,7 +1,12 @@ -This directory contains the MLD2P4 set of preconditioners, version 1.1 +This directory contains the MLD2P4 set of preconditioners, version 2.0 WHAT'S NEW +Version 2.0. + + Finally moved to F2003, with the support of PSBLAS3. + + In version 1.1: - The MLD_SIZEOF() function has been redefined to be INTEGER(8), so as to be able to measure large data sets. diff --git a/mlprec/mld_base_prec_type.F90 b/mlprec/mld_base_prec_type.F90 index 543966bd..47b699e7 100644 --- a/mlprec/mld_base_prec_type.F90 +++ b/mlprec/mld_base_prec_type.F90 @@ -102,9 +102,12 @@ module mld_base_prec_type integer :: aggr_omega_alg, aggr_eig, aggr_filter integer :: coarse_mat, coarse_solve contains - procedure, pass(pm) :: descr => ml_parms_descr + procedure, pass(pm) :: descr => ml_parms_descr + procedure, pass(pm) :: mldescr => ml_parms_mldescr + procedure, pass(pm) :: coarsedescr => ml_parms_coarsedescr end type mld_ml_parms + type, extends(mld_ml_parms) :: mld_sml_parms real(psb_spk_) :: aggr_omega_val, aggr_thresh contains @@ -426,7 +429,7 @@ contains ! Routines printing out a description of the preconditioner ! - subroutine ml_parms_descr(pm,iout,info,coarse) + subroutine ml_parms_mldescr(pm,iout,info) use psb_base_mod @@ -436,449 +439,153 @@ contains class(mld_ml_parms), intent(in) :: pm integer, intent(in) :: iout integer, intent(out) :: info - logical, intent(in), optional :: coarse - logical :: coarse_ info = psb_success_ - if (present(coarse)) then - coarse_ = coarse - else - coarse_ = .false. - end if + if (pm%ml_type>mld_no_ml_) then - if (coarse_) then - write(iout,*) ' Coarsest matrix: ',& - & matrix_names(pm%coarse_mat) - if (pm%coarse_solve == mld_bjac_) then - write(iout,*) ' Coarse solver: Block Jacobi ' + write(iout,*) ' Multilevel type: ',& + & ml_names(pm%ml_type) + write(iout,*) ' Smoother position: ',& + & smooth_pos_names(pm%smoother_pos) + if (pm%ml_type == mld_add_ml_) then write(iout,*) ' Number of sweeps : ',& & pm%sweeps - else - write(iout,*) ' Coarse solver: ',& - & fact_names(pm%coarse_solve) - endif - - else - - if (pm%ml_type>mld_no_ml_) then - - write(iout,*) ' Multilevel type: ',& - & ml_names(pm%ml_type) - write(iout,*) ' Smoother position: ',& - & smooth_pos_names(pm%smoother_pos) - if (pm%ml_type == mld_add_ml_) then + else + select case (pm%smoother_pos) + case (mld_pre_smooth_) write(iout,*) ' Number of sweeps : ',& - & pm%sweeps + & pm%sweeps_pre + case (mld_post_smooth_) + write(iout,*) ' Number of sweeps : ',& + & pm%sweeps_post + case (mld_twoside_smooth_) + write(iout,*) ' Number of sweeps : pre: ',& + & pm%sweeps_pre ,& + & ' post: ',& + & pm%sweeps_post + end select + end if + write(iout,*) ' Aggregation: ', & + & aggr_names(pm%aggr_alg) + write(iout,*) ' Aggregation type: ', & + & aggr_kinds(pm%aggr_kind) + if (pm%aggr_kind /= mld_no_smooth_) then + if (pm%aggr_omega_alg == mld_eig_est_) then + write(iout,*) ' Damping omega computation: spectral radius estimate' + write(iout,*) ' Spectral radius estimate: ', & + & eigen_estimates(pm%aggr_eig) + else if (pm%aggr_omega_alg == mld_user_choice_) then + write(iout,*) ' Damping omega computation: user defined value.' else - select case (pm%smoother_pos) - case (mld_pre_smooth_) - write(iout,*) ' Number of sweeps : ',& - & pm%sweeps_pre - case (mld_post_smooth_) - write(iout,*) ' Number of sweeps : ',& - & pm%sweeps_post - case (mld_twoside_smooth_) - write(iout,*) ' Number of sweeps : pre: ',& - & pm%sweeps_pre ,& - & ' post: ',& - & pm%sweeps_post - end select - end if - if (pm%aggr_kind /= mld_no_smooth_) then - if (pm%aggr_omega_alg == mld_eig_est_) then - write(iout,*) ' Damping omega computation: spectral radius estimate' - write(iout,*) ' Spectral radius estimate: ', & - & eigen_estimates(pm%aggr_eig) - else if (pm%aggr_omega_alg == mld_user_choice_) then - write(iout,*) ' Damping omega computation: user defined value.' - else - write(iout,*) ' Damping omega computation: unknown value in iprcparm!!' - end if + write(iout,*) ' Damping omega computation: unknown value in iprcparm!!' end if - write(iout,*) ' Aggregation: ', & - & aggr_names(pm%aggr_alg) - write(iout,*) ' Aggregation type: ', & - & aggr_kinds(pm%aggr_kind) end if end if return - end subroutine ml_parms_descr + end subroutine ml_parms_mldescr - subroutine s_ml_parms_descr(pm,iout,info,coarse) + subroutine ml_parms_coarsedescr(pm,iout,info) use psb_base_mod Implicit None ! Arguments - class(mld_sml_parms), intent(in) :: pm + class(mld_ml_parms), intent(in) :: pm integer, intent(in) :: iout integer, intent(out) :: info - logical, intent(in), optional :: coarse info = psb_success_ + write(iout,*) ' Coarsest matrix: ',& + & matrix_names(pm%coarse_mat) + if (pm%coarse_solve == mld_bjac_) then + write(iout,*) ' Coarse solver: Block Jacobi ' + write(iout,*) ' Number of sweeps : ',& + & pm%sweeps + else + write(iout,*) ' Coarse solver: ',& + & fact_names(pm%coarse_solve) + endif - call pm%mld_ml_parms%descr(iout,info,coarse) - - write(iout,*) ' Aggregation threshold: ', & - & pm%aggr_thresh - - return - - end subroutine s_ml_parms_descr + end subroutine ml_parms_coarsedescr - subroutine d_ml_parms_descr(pm,iout,info,coarse) + subroutine ml_parms_descr(pm,iout,info,coarse) use psb_base_mod Implicit None ! Arguments - class(mld_dml_parms), intent(in) :: pm + class(mld_ml_parms), intent(in) :: pm integer, intent(in) :: iout integer, intent(out) :: info logical, intent(in), optional :: coarse + logical :: coarse_ info = psb_success_ + if (present(coarse)) then + coarse_ = coarse + else + coarse_ = .false. + end if - call pm%mld_ml_parms%descr(iout,info,coarse) - - write(iout,*) ' Aggregation threshold: ', & - & pm%aggr_thresh - - return - - end subroutine d_ml_parms_descr + if (coarse_) then + call pm%coarsedescr(iout,info) + end if - subroutine mld_base_prec_descr(iout,iprcparm, info,rprcparm,dprcparm) - implicit none - integer, intent(in) :: iprcparm(:),iout - integer, intent(out) :: info - real(psb_spk_), intent(in), optional :: rprcparm(:) - real(psb_dpk_), intent(in), optional :: dprcparm(:) - - info = psb_success_ - if (count((/ present(rprcparm),present(dprcparm) /)) /= 1) then - info=psb_err_no_optional_arg_ -!!$ call psb_errpush(info,name,a_err=" rprcparm, dprcparm") - return - endif - - select case(iprcparm(mld_smoother_type_)) - case(mld_noprec_) - write(iout,*) ' No preconditioning' - case(mld_jac_) - write(iout,*) ' Jacobi ' - case(mld_bjac_) - write(iout,*) ' Block Jacobi with ',& - & fact_names(iprcparm(mld_sub_solve_)) - select case(iprcparm(mld_sub_solve_)) - case(mld_ilu_n_,mld_milu_n_) - write(iout,*) ' Fill level:',iprcparm(mld_sub_fillin_) - case(mld_ilu_t_) - write(iout,*) ' Fill level:',iprcparm(mld_sub_fillin_) - if (present(rprcparm)) then - write(iout,*) ' Fill threshold :',rprcparm(mld_sub_iluthrs_) - else - write(iout,*) ' Fill threshold :',dprcparm(mld_sub_iluthrs_) - end if - case(mld_slu_,mld_umf_,mld_sludist_,mld_diag_scale_) - case default - write(iout,*) ' Should never get here!' - end select - case(mld_as_) - write(iout,*) ' Additive Schwarz with ',& - & fact_names(iprcparm(mld_sub_solve_)) - select case(iprcparm(mld_sub_solve_)) - case(mld_ilu_n_,mld_milu_n_) - write(iout,*) ' Fill level:',iprcparm(mld_sub_fillin_) - case(mld_ilu_t_) - write(iout,*) ' Fill level:',iprcparm(mld_sub_fillin_) - if (present(rprcparm)) then - write(iout,*) ' Fill threshold :',rprcparm(mld_sub_iluthrs_) - else - write(iout,*) ' Fill threshold :',dprcparm(mld_sub_iluthrs_) - end if - case(mld_slu_,mld_umf_,mld_sludist_,mld_diag_scale_) - case default - write(iout,*) ' Should never get here!' - end select - write(iout,*) ' Overlap:',& - & iprcparm(mld_sub_ovr_) - write(iout,*) ' Restriction: ',& - & restrict_names(iprcparm(mld_sub_restr_)) - write(iout,*) ' Prolongation: ',& - & prolong_names(iprcparm(mld_sub_prol_)) - end select return - end subroutine mld_base_prec_descr - - subroutine mld_ml_alg_descr(iout,ilev,iprcparm, info,rprcparm,dprcparm) - implicit none - integer, intent(in) :: iprcparm(:),iout,ilev - integer, intent(out) :: info - real(psb_spk_), intent(in), optional :: rprcparm(:) - real(psb_dpk_), intent(in), optional :: dprcparm(:) - integer :: sweeps - - info = psb_success_ - if (count((/ present(rprcparm),present(dprcparm) /)) /= 1) then - info=psb_err_no_optional_arg_ -!!$ call psb_errpush(info,name,a_err=" rprcparm, dprcparm") - return - endif - if (iprcparm(mld_ml_type_)>mld_no_ml_) then + end subroutine ml_parms_descr - write(iout,*) ' Multilevel type: ',& - & ml_names(iprcparm(mld_ml_type_)) - write(iout,*) ' Smoother position: ',& - & smooth_pos_names(iprcparm(mld_smoother_pos_)) - if (iprcparm(mld_ml_type_) == mld_add_ml_) then - write(iout,*) ' Number of sweeps : ',& - & iprcparm(mld_smoother_sweeps_) - else - select case (iprcparm(mld_smoother_pos_)) - case (mld_pre_smooth_) - write(iout,*) ' Number of sweeps : ',& - & iprcparm(mld_smoother_sweeps_pre_) - case (mld_post_smooth_) - write(iout,*) ' Number of sweeps : ',& - & iprcparm(mld_smoother_sweeps_post_) - case (mld_twoside_smooth_) - write(iout,*) ' Number of sweeps : pre: ',& - & iprcparm(mld_smoother_sweeps_pre_) ,& - & ' post: ',& - & iprcparm(mld_smoother_sweeps_post_) - end select - end if + subroutine s_ml_parms_descr(pm,iout,info,coarse) - write(iout,*) ' Aggregation: ', & - & aggr_names(iprcparm(mld_aggr_alg_)) - write(iout,*) ' Aggregation type: ', & - & aggr_kinds(iprcparm(mld_aggr_kind_)) - if (present(rprcparm)) then - write(iout,*) ' Aggregation threshold: ', & - & rprcparm(mld_aggr_thresh_) - else - write(iout,*) ' Aggregation threshold: ', & - & dprcparm(mld_aggr_thresh_) - end if - if (iprcparm(mld_aggr_kind_) /= mld_no_smooth_) then - if (iprcparm(mld_aggr_omega_alg_) == mld_eig_est_) then - write(iout,*) ' Damping omega computation: spectral radius estimate' - write(iout,*) ' Spectral radius estimate: ', & - & eigen_estimates(iprcparm(mld_aggr_eig_)) - else if (iprcparm(mld_aggr_omega_alg_) == mld_user_choice_) then - write(iout,*) ' Damping omega computation: user defined value.' - else - write(iout,*) ' Damping omega computation: unknown value in iprcparm!!' - end if - end if - end if + use psb_base_mod - return - end subroutine mld_ml_alg_descr + Implicit None - subroutine mld_ml_level_descr(iout,ilev,iprcparm,nlaggr, info,rprcparm,dprcparm) - implicit none - integer, intent(in) :: iprcparm(:),iout,ilev - integer, intent(in), allocatable :: nlaggr(:) - integer, intent(out) :: info - real(psb_spk_), intent(in), optional :: rprcparm(:) - real(psb_dpk_), intent(in), optional :: dprcparm(:) + ! Arguments + class(mld_sml_parms), intent(in) :: pm + integer, intent(in) :: iout + integer, intent(out) :: info + logical, intent(in), optional :: coarse info = psb_success_ - if (count((/ present(rprcparm),present(dprcparm) /)) /= 1) then - info=psb_err_no_optional_arg_ -!!$ call psb_errpush(info,name,a_err=" rprcparm, dprcparm") - return - endif - if (iprcparm(mld_ml_type_)>mld_no_ml_) then - write(iout,*) ' Level ',ilev - if (allocated(nlaggr)) then - write(iout,*) ' Size of coarse matrix: ', & - & sum(nlaggr(:)) - write(iout,*) ' Sizes of aggregates: ', & - & nlaggr(:) - end if - if (iprcparm(mld_aggr_kind_) /= mld_no_smooth_) then - if (present(rprcparm)) then - write(iout,*) ' Damping omega: ', & - & rprcparm(mld_aggr_omega_val_) - else - write(iout,*) ' Damping omega: ', & - & dprcparm(mld_aggr_omega_val_) - end if - end if + call pm%mld_ml_parms%descr(iout,info,coarse) + if (pm%aggr_kind /= mld_no_smooth_) then + write(iout,*) ' Damping omega value :',pm%aggr_omega_val end if - - return - end subroutine mld_ml_level_descr - - subroutine mld_ml_coarse_descr(iout,ilev,iprcparm,iprcparm2,nlaggr,info,& - & rprcparm,dprcparm, rprcparm2,dprcparm2) - implicit none - integer, intent(in) :: iprcparm(:),iprcparm2(:),iout,ilev - integer, intent(in), allocatable :: nlaggr(:) - integer, intent(out) :: info - real(psb_spk_), intent(in), optional :: rprcparm(:), rprcparm2(:) - real(psb_dpk_), intent(in), optional :: dprcparm(:), dprcparm2(:) + write(iout,*) ' Aggregation threshold:',pm%aggr_thresh - info = psb_success_ - if (count((/ present(rprcparm),present(dprcparm) /)) /= 1) then - info=psb_err_no_optional_arg_ -!!$ call psb_errpush(info,name,a_err=" rprcparm, dprcparm") - return - endif - if (count((/ present(rprcparm2),present(dprcparm2) /)) /= 1) then - info=psb_err_no_optional_arg_ -!!$ call psb_errpush(info,name,a_err=" rprcparm, dprcparm") - return - endif - - if (iprcparm(mld_ml_type_)>mld_no_ml_) then + return - write(iout,*) ' Level ',ilev,' (coarsest)' - write(iout,*) ' Coarsest matrix: ',& - & matrix_names(iprcparm(mld_coarse_mat_)) - if (allocated(nlaggr)) then - write(iout,*) ' Size of coarsest matrix: ', & - & sum( nlaggr(:)) - write(iout,*) ' Sizes of aggregates: ', & - & nlaggr(:) - end if - if (iprcparm(mld_aggr_kind_) /= mld_no_smooth_) then - - if (present(rprcparm)) then - write(iout,*) ' Damping omega: ', & - & rprcparm(mld_aggr_omega_val_) - else - write(iout,*) ' Damping omega: ', & - & dprcparm(mld_aggr_omega_val_) - end if - end if - if (iprcparm(mld_coarse_mat_) == mld_distr_mat_ .and. & - & iprcparm(mld_sub_solve_) /= mld_sludist_) then -!!$ write(iout,*) ' Coarsest matrix solver: ',& -!!$ & smoother_names(iprcparm2(mld_smoother_type_)) - select case (iprcparm2(mld_smoother_type_)) - case(mld_bjac_,mld_as_) - write(iout,*) ' subdomain solver: ',& - & fact_names(iprcparm2(mld_sub_solve_)) - write(iout,*) ' Number of smoother sweeps: ', & - & (iprcparm2(mld_smoother_sweeps_)) - case(mld_jac_) - write(iout,*) ' Number of smoother sweeps: ', & - & (iprcparm2(mld_smoother_sweeps_)) - end select - else - write(iout,*) ' Coarsest matrix solver: ', & - & fact_names(iprcparm2(mld_sub_solve_)) - end if - select case(iprcparm2(mld_sub_solve_)) - case(mld_ilu_n_,mld_milu_n_) - write(iout,*) ' Fill level:',iprcparm2(mld_sub_fillin_) - case(mld_ilu_t_) - write(iout,*) ' Fill level:',iprcparm2(mld_sub_fillin_) - if (present(rprcparm2)) then - write(iout,*) ' Fill threshold :',rprcparm2(mld_sub_iluthrs_) - else if (present(dprcparm2)) then - write(iout,*) ' Fill threshold :',dprcparm2(mld_sub_iluthrs_) - end if - case(mld_slu_,mld_umf_,mld_sludist_,mld_diag_scale_) - case default - write(iout,*) ' Should never get here!' - end select - end if + end subroutine s_ml_parms_descr + subroutine d_ml_parms_descr(pm,iout,info,coarse) - return - end subroutine mld_ml_coarse_descr + use psb_base_mod + Implicit None - subroutine mld_ml_new_coarse_descr(iout,ilev,iprcparm,nlaggr,info,& - & rprcparm,dprcparm) - implicit none - integer, intent(in) :: iprcparm(:),iout,ilev - integer, intent(in), allocatable :: nlaggr(:) - integer, intent(out) :: info - real(psb_spk_), intent(in), optional :: rprcparm(:) - real(psb_dpk_), intent(in), optional :: dprcparm(:) + ! Arguments + class(mld_dml_parms), intent(in) :: pm + integer, intent(in) :: iout + integer, intent(out) :: info + logical, intent(in), optional :: coarse info = psb_success_ - if (count((/ present(rprcparm),present(dprcparm) /)) /= 1) then - info=psb_err_no_optional_arg_ -!!$ call psb_errpush(info,name,a_err=" rprcparm, dprcparm") - return - endif -!!$ if (count((/ present(rprcparm2),present(dprcparm2) /)) /= 1) then -!!$ info=psb_err_no_optional_arg_ -! !$ call psb_errpush(info,name,a_err=" rprcparm, dprcparm") -!!$ return -!!$ endif - - if (iprcparm(mld_ml_type_)>mld_no_ml_) then - - write(iout,*) ' Level ',ilev,' (coarsest)' - write(iout,*) ' Coarsest matrix: ',& - & matrix_names(iprcparm(mld_coarse_mat_)) - if (allocated(nlaggr)) then - write(iout,*) ' Size of coarsest matrix: ', & - & sum( nlaggr(:)) - write(iout,*) ' Sizes of aggregates: ', & - & nlaggr(:) - end if - if (iprcparm(mld_aggr_kind_) /= mld_no_smooth_) then - - if (present(rprcparm)) then - write(iout,*) ' Damping omega: ', & - & rprcparm(mld_aggr_omega_val_) - else - write(iout,*) ' Damping omega: ', & - & dprcparm(mld_aggr_omega_val_) - end if - end if -!!$ if (iprcparm(mld_coarse_mat_) == mld_distr_mat_ .and. & -!!$ & iprcparm(mld_sub_solve_) /= mld_sludist_) then -! !$ write(iout,*) ' Coarsest matrix solver: ',& -! !$ & smoother_names(iprcparm2(mld_smoother_type_)) -!!$ select case (iprcparm2(mld_smoother_type_)) -!!$ case(mld_bjac_,mld_as_) -!!$ write(iout,*) ' subdomain solver: ',& -!!$ & fact_names(iprcparm2(mld_sub_solve_)) -!!$ write(iout,*) ' Number of smoother sweeps: ', & -!!$ & (iprcparm2(mld_smoother_sweeps_)) -!!$ case(mld_jac_) -!!$ write(iout,*) ' Number of smoother sweeps: ', & -!!$ & (iprcparm2(mld_smoother_sweeps_)) -!!$ end select -!!$ else -!!$ write(iout,*) ' Coarsest matrix solver: ', & -!!$ & fact_names(iprcparm2(mld_sub_solve_)) -!!$ end if -!!$ select case(iprcparm2(mld_sub_solve_)) -!!$ case(mld_ilu_n_,mld_milu_n_) -!!$ write(iout,*) ' Fill level:',iprcparm2(mld_sub_fillin_) -!!$ case(mld_ilu_t_) -!!$ write(iout,*) ' Fill level:',iprcparm2(mld_sub_fillin_) -!!$ if (present(rprcparm2)) then -!!$ write(iout,*) ' Fill threshold :',rprcparm2(mld_sub_iluthrs_) -!!$ else if (present(dprcparm2)) then -!!$ write(iout,*) ' Fill threshold :',dprcparm2(mld_sub_iluthrs_) -!!$ end if -!!$ case(mld_slu_,mld_umf_,mld_sludist_,mld_diag_scale_) -!!$ case default -!!$ write(iout,*) ' Should never get here!' -!!$ end select - end if + call pm%mld_ml_parms%descr(iout,info,coarse) + if (pm%aggr_kind /= mld_no_smooth_) then + write(iout,*) ' Damping omega value :',pm%aggr_omega_val + end if + write(iout,*) ' Aggregation threshold:',pm%aggr_thresh return - end subroutine mld_ml_new_coarse_descr + + end subroutine d_ml_parms_descr ! @@ -1110,7 +817,7 @@ contains end function is_legal end interface character(len=20), parameter :: rname='mld_check_def' - + if (.not.is_legal(ip)) then write(0,*)trim(rname),': Error: Illegal value for ',& & name,' :',ip, '. defaulting to ',id @@ -1131,7 +838,7 @@ contains end function is_legal end interface character(len=20), parameter :: rname='mld_check_def' - + if (.not.is_legal(ip)) then write(0,*)trim(rname),': Error: Illegal value for ',& & name,' :',ip, '. defaulting to ',id @@ -1192,14 +899,14 @@ contains call psb_bcast(ictxt,dat%aggr_omega_val,root) call psb_bcast(ictxt,dat%aggr_thresh,root) end subroutine mld_sml_bcast - + subroutine mld_dml_bcast(ictxt,dat,root) use psb_base_mod implicit none integer, intent(in) :: ictxt type(mld_dml_parms), intent(inout) :: dat integer, intent(in), optional :: root - + call psb_bcast(ictxt,dat%mld_ml_parms,root) call psb_bcast(ictxt,dat%aggr_omega_val,root) call psb_bcast(ictxt,dat%aggr_thresh,root) diff --git a/mlprec/mld_c_prec_type.f90 b/mlprec/mld_c_prec_type.f90 index 5aa06aa5..0c6e40e2 100644 --- a/mlprec/mld_c_prec_type.f90 +++ b/mlprec/mld_c_prec_type.f90 @@ -229,13 +229,16 @@ module mld_c_prec_type type, extends(psb_cprec_type) :: mld_cprec_type integer :: ictxt + real(psb_spk_) :: op_complexity=-sone type(mld_conelev_type), allocatable :: precv(:) contains procedure, pass(prec) :: c_apply2v => mld_c_apply2v procedure, pass(prec) :: c_apply1v => mld_c_apply1v procedure, pass(prec) :: dump => mld_c_dump + procedure, pass(prec) :: get_complexity => mld_c_get_compl + procedure, pass(prec) :: cmp_complexity => mld_c_cmp_compl end type mld_cprec_type - + private :: c_base_solver_bld, c_base_solver_apply, & & c_base_solver_free, c_base_solver_seti, & & c_base_solver_setc, c_base_solver_setr, & @@ -251,30 +254,31 @@ module mld_c_prec_type & c_base_onelev_seti, c_base_onelev_setc, & & c_base_onelev_setr, c_base_onelev_check, & & c_base_onelev_default, c_base_onelev_dump, & - & c_base_onelev_descr - - + & c_base_onelev_descr, mld_c_dump, & + & mld_c_get_compl, mld_c_cmp_compl + + ! ! Interfaces to routines for checking the definition of the preconditioner, ! for printing its description and for deallocating its data structure ! - + interface mld_precfree module procedure mld_c_onelev_precfree, mld_cprec_free - end interface - + end interface mld_precfree + interface mld_nullify_onelevprec module procedure mld_nullify_c_onelevprec - end interface - + end interface mld_nullify_onelevprec + interface mld_precdescr module procedure mld_cfile_prec_descr - end interface - + end interface mld_precdescr + interface mld_sizeof module procedure mld_cprec_sizeof, mld_c_onelev_prec_sizeof - end interface - + end interface mld_sizeof + interface mld_precaply subroutine mld_cprecaply(prec,x,y,desc_data,info,trans,work) use psb_base_mod, only : psb_cspmat_type, psb_desc_type, psb_spk_ @@ -296,13 +300,13 @@ module mld_c_prec_type integer, intent(out) :: info character(len=1), optional :: trans end subroutine mld_cprecaply1 - end interface - + end interface mld_precaply + contains ! ! Function returning the size of the mld_prec_type data structure ! - + function mld_cprec_sizeof(prec) result(val) implicit none type(mld_cprec_type), intent(in) :: prec @@ -316,8 +320,8 @@ contains end do end if end function mld_cprec_sizeof - - + + function mld_c_onelev_prec_sizeof(prec) result(val) implicit none type(mld_conelev_type), intent(in) :: prec @@ -330,7 +334,47 @@ contains val = val + psb_sizeof(prec%map) if (allocated(prec%sm)) val = val + prec%sm%sizeof() end function mld_c_onelev_prec_sizeof - + + function mld_c_get_compl(prec) result(val) + implicit none + class(mld_cprec_type), intent(in) :: prec + real(psb_spk_) :: val + + val = prec%op_complexity + + end function mld_c_get_compl + + subroutine mld_c_cmp_compl(prec) + use psb_base_mod, only : psb_min, psb_sum + implicit none + class(mld_cprec_type), intent(inout) :: prec + + real(psb_spk_) :: num,den + integer :: ictxt, il + + num = -sone + den = sone + ictxt = prec%ictxt + if (allocated(prec%precv)) then + il = 1 + num = prec%precv(il)%base_a%get_nzeros() + if (num >= szero) then + den = num + do il=2,size(prec%precv) + num = num + max(0,prec%precv(il)%base_a%get_nzeros()) + end do + end if + end if + call psb_min(ictxt,num) + if (num < szero) then + den = sone + else + call psb_sum(ictxt,num) + call psb_sum(ictxt,den) + end if + prec%op_complexity = num/den + end subroutine mld_c_cmp_compl + ! ! Subroutine: mld_file_prec_descr ! Version: real @@ -355,13 +399,13 @@ contains type(mld_cprec_type), intent(in) :: p integer, intent(out) :: info integer, intent(in), optional :: iout - + ! Local variables integer :: ilev, nlev integer :: ictxt, me, np character(len=20), parameter :: name='mld_file_prec_descr' integer :: iout_ - + info = psb_success_ if (present(iout)) then iout_ = iout @@ -369,11 +413,10 @@ contains iout_ = 6 end if if (iout_ < 0) iout_ = 6 - + ictxt = p%ictxt if (allocated(p%precv)) then -!!$ ictxt = psb_cd_get_context(p%precv(1)%prec%desc_data) call psb_info(ictxt,me,np) @@ -393,7 +436,7 @@ contains return endif end do - + write(iout_,*) write(iout_,'(a)') 'Preconditioner description' if (nlev >= 1) then @@ -406,60 +449,36 @@ contains write(iout_,*) 'Base preconditioner (smoother) details' endif call p%precv(1)%sm%descr(info,iout=iout_) - end if - - if (nlev > 1) then - - ! - ! Print multilevel details - ! - write(iout_,*) - write(iout_,*) 'Multilevel details' - write(iout_,*) ' Number of levels: ',nlev - - ! - ! Currently, all the preconditioner parameters must have - ! the same value at levels - ! 2,...,nlev-1, hence only the values at level 2 are printed - ! - - ilev=2 - call p%precv(ilev)%parms%descr(iout_,info) - - ! - ! Coarse matrices are different at levels 2,...,nlev-1, hence related - ! info is printed separately - ! - write(iout_,*) - do ilev = 2, nlev-1 - write(iout_,*) ' Level ',ilev - call p%precv(ilev)%descr(info,iout=iout_) - end do - - ! - ! Print coarsest level details - ! - ! Should rework this. - - ilev = nlev - write(iout_,*) - write(iout_,*) ' Level ',ilev,' (coarsest)' - - call p%precv(ilev)%parms%descr(iout_,info,coarse=.true.) - call p%precv(ilev)%descr(info,iout=iout_,coarse=.true.) + if (nlev == 1) then + write(iout_,*) + return + end if end if - endif - write(iout_,*) + ! + ! Print multilevel details + ! + write(iout_,*) + write(iout_,*) 'Multilevel details' + write(iout_,*) ' Number of levels : ',nlev + write(iout_,*) ' Operator complexity: ',p%get_complexity() + do ilev=2,nlev + call p%precv(ilev)%descr(ilev,nlev,info,iout=iout_) + end do + write(iout_,*) + + end if + else write(iout_,*) trim(name), & & ': Error: no base preconditioner available, something is wrong!' info = -2 return endif - + + end subroutine mld_cfile_prec_descr - + ! ! Subroutines: mld_Tbase_precfree, mld_T_onelev_precfree, mld_Tprec_free ! Version: real/complex @@ -473,58 +492,67 @@ contains ! info - integer, output. ! error code. ! - - subroutine c_base_onelev_descr(lv,info,iout,coarse) - + + subroutine c_base_onelev_descr(lv,il,nl,info,iout) + use psb_base_mod - + Implicit None - + ! Arguments class(mld_conelev_type), intent(in) :: lv + integer, intent(in) :: il,nl integer, intent(out) :: info integer, intent(in), optional :: iout - logical, intent(in), optional :: coarse - + ! Local variables integer :: err_act integer :: ictxt, me, np character(len=20), parameter :: name='mld_c_base_onelev_descr' integer :: iout_ - logical :: coarse_ - - + logical :: coarse + + call psb_erractionsave(err_act) - - if (present(coarse)) then - coarse_ = coarse - else - coarse_ = .false. - end if + + + coarse = (il==nl) + if (present(iout)) then iout_ = iout else iout_ = 6 end if - - if (lv%parms%ml_type > mld_no_ml_) then + + write(iout_,*) + if (il == 2) then + call lv%parms%mldescr(iout_,info) + write(iout_,*) + end if + + if (coarse) then + write(iout_,*) ' Level ',il,' (coarsest)' + else + write(iout_,*) ' Level ',il + end if + + call lv%parms%descr(iout_,info,coarse=coarse) + + if (nl > 1) then if (allocated(lv%map%naggr)) then write(iout_,*) ' Size of coarse matrix: ', & & sum(lv%map%naggr(:)) write(iout_,*) ' Sizes of aggregates: ', & & lv%map%naggr(:) end if - if (lv%parms%aggr_kind /= mld_no_smooth_) then - write(iout_,*) ' Damping omega: ', & - & lv%parms%aggr_omega_val - end if end if - if (allocated(lv%sm)) & + + if (coarse.and.allocated(lv%sm)) & & call lv%sm%descr(info,iout=iout_,coarse=coarse) - + call psb_erractionrestore(err_act) return - + 9999 continue call psb_erractionrestore(err_act) if (err_act == psb_act_abort_) then @@ -533,17 +561,17 @@ contains end if return end subroutine c_base_onelev_descr - + subroutine mld_c_onelev_precfree(p,info) use psb_base_mod implicit none - + type(mld_conelev_type), intent(inout) :: p integer, intent(out) :: info integer :: i - + info = psb_success_ - + ! Actually we might just deallocate the top level array, except ! for the inner UMFPACK or SLU stuff. ! We really need FINALs. @@ -552,33 +580,33 @@ contains call p%ac%free() if (psb_is_ok_desc(p%desc_ac)) & & call psb_cdfree(p%desc_ac,info) - + ! This is a pointer to something else, must not free it here. nullify(p%base_a) ! This is a pointer to something else, must not free it here. nullify(p%base_desc) - + ! ! free explicitly map??? ! For now thanks to allocatable semantics ! works anyway. ! - + call mld_nullify_onelevprec(p) end subroutine mld_c_onelev_precfree - + subroutine mld_nullify_c_onelevprec(p) implicit none - + type(mld_conelev_type), intent(inout) :: p - + nullify(p%base_a) nullify(p%base_desc) - + end subroutine mld_nullify_c_onelevprec - - subroutine mld_cprec_free(p,info) + subroutine mld_cprec_free(p,info) + use psb_base_mod implicit none @@ -616,8 +644,8 @@ contains return end subroutine mld_cprec_free - - + + subroutine c_base_smoother_apply(alpha,sm,x,beta,y,desc_data,trans,sweeps,work,info) use psb_base_mod type(psb_desc_type), intent(in) :: desc_data @@ -632,7 +660,7 @@ contains Integer :: err_act character(len=20) :: name='c_base_smoother_apply' - + call psb_erractionsave(err_act) info = psb_success_ if (allocated(sm%sv)) then @@ -644,10 +672,10 @@ contains call psb_errpush(info,name) goto 9999 end if - + call psb_erractionrestore(err_act) return - + 9999 continue call psb_erractionrestore(err_act) if (err_act == psb_act_abort_) then @@ -657,22 +685,22 @@ contains return end subroutine c_base_smoother_apply - + subroutine c_base_smoother_check(sm,info) - + use psb_base_mod - + Implicit None - + ! Arguments class(mld_c_base_smoother_type), intent(inout) :: sm integer, intent(out) :: info Integer :: err_act character(len=20) :: name='c_base_smoother_check' - + call psb_erractionsave(err_act) info = psb_success_ - + if (allocated(sm%sv)) then call sm%sv%check(info) else @@ -680,12 +708,12 @@ contains call psb_errpush(info,name) goto 9999 end if - + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return - + 9999 continue call psb_erractionrestore(err_act) if (err_act == psb_act_abort_) then @@ -694,14 +722,14 @@ contains end if return end subroutine c_base_smoother_check - - + + subroutine c_base_smoother_seti(sm,what,val,info) - + use psb_base_mod - + Implicit None - + ! Arguments class(mld_c_base_smoother_type), intent(inout) :: sm integer, intent(in) :: what @@ -709,17 +737,17 @@ contains integer, intent(out) :: info Integer :: err_act character(len=20) :: name='c_base_smoother_seti' - + call psb_erractionsave(err_act) info = psb_success_ - + if (allocated(sm%sv)) then call sm%sv%set(what,val,info) end if if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return - + 9999 continue call psb_erractionrestore(err_act) if (err_act == psb_act_abort_) then @@ -728,13 +756,13 @@ contains end if return end subroutine c_base_smoother_seti - + subroutine c_base_smoother_setc(sm,what,val,info) - + use psb_base_mod - + Implicit None - + ! Arguments class(mld_c_base_smoother_type), intent(inout) :: sm integer, intent(in) :: what @@ -742,19 +770,19 @@ contains integer, intent(out) :: info Integer :: err_act character(len=20) :: name='c_base_smoother_setc' - + call psb_erractionsave(err_act) - + info = psb_success_ - + if (allocated(sm%sv)) then call sm%sv%set(what,val,info) end if if (info /= psb_success_) goto 9999 - + call psb_erractionrestore(err_act) return - + 9999 continue call psb_erractionrestore(err_act) if (err_act == psb_act_abort_) then @@ -765,11 +793,11 @@ contains end subroutine c_base_smoother_setc subroutine c_base_smoother_setr(sm,what,val,info) - + use psb_base_mod - + Implicit None - + ! Arguments class(mld_c_base_smoother_type), intent(inout) :: sm integer, intent(in) :: what @@ -777,20 +805,20 @@ contains integer, intent(out) :: info Integer :: err_act character(len=20) :: name='c_base_smoother_setr' - + call psb_erractionsave(err_act) - - + + info = psb_success_ - + if (allocated(sm%sv)) then call sm%sv%set(what,val,info) end if if (info /= psb_success_) goto 9999 - + call psb_erractionrestore(err_act) return - + 9999 continue call psb_erractionrestore(err_act) if (err_act == psb_act_abort_) then @@ -799,13 +827,13 @@ contains end if return end subroutine c_base_smoother_setr - + subroutine c_base_smoother_bld(a,desc_a,sm,upd,info) - + use psb_base_mod - + Implicit None - + ! Arguments type(psb_cspmat_type), intent(in), target :: a Type(psb_desc_type), Intent(in) :: desc_a @@ -814,9 +842,9 @@ contains integer, intent(out) :: info Integer :: err_act character(len=20) :: name='c_base_smoother_bld' - + call psb_erractionsave(err_act) - + info = psb_success_ if (allocated(sm%sv)) then call sm%sv%build(a,desc_a,upd,info) @@ -825,10 +853,10 @@ contains call psb_errpush(info,name) endif if (info /= psb_success_) goto 9999 - + call psb_erractionrestore(err_act) return - + 9999 continue call psb_erractionrestore(err_act) if (err_act == psb_act_abort_) then @@ -837,20 +865,20 @@ contains end if return end subroutine c_base_smoother_bld - - + + subroutine c_base_smoother_free(sm,info) - + use psb_base_mod - + Implicit None - + ! Arguments class(mld_c_base_smoother_type), intent(inout) :: sm integer, intent(out) :: info Integer :: err_act character(len=20) :: name='c_base_smoother_free' - + call psb_erractionsave(err_act) info = psb_success_ @@ -865,7 +893,7 @@ contains end if call psb_erractionrestore(err_act) return - + 9999 continue call psb_erractionrestore(err_act) if (err_act == psb_act_abort_) then @@ -874,35 +902,35 @@ contains end if return end subroutine c_base_smoother_free - + subroutine c_base_smoother_descr(sm,info,iout,coarse) - + use psb_base_mod - + Implicit None - + ! Arguments class(mld_c_base_smoother_type), intent(in) :: sm integer, intent(out) :: info integer, intent(in), optional :: iout logical, intent(in), optional :: coarse - + ! Local variables integer :: err_act integer :: ictxt, me, np character(len=20), parameter :: name='mld_c_base_smoother_descr' integer :: iout_ - - + + call psb_erractionsave(err_act) info = psb_success_ - + if (present(iout)) then iout_ = iout else iout_ = 6 end if - + write(iout_,*) 'Base smoother with local solver' if (allocated(sm%sv)) then call sm%sv%descr(info,iout) @@ -914,7 +942,7 @@ contains end if call psb_erractionrestore(err_act) return - + 9999 continue call psb_erractionrestore(err_act) if (err_act == psb_act_abort_) then @@ -923,7 +951,7 @@ contains end if return end subroutine c_base_smoother_descr - + function c_base_smoother_sizeof(sm) result(val) implicit none ! Arguments @@ -935,23 +963,23 @@ contains if (allocated(sm%sv)) then val = sm%sv%sizeof() end if - + return end function c_base_smoother_sizeof - + subroutine c_base_smoother_default(sm) implicit none ! Arguments class(mld_c_base_smoother_type), intent(inout) :: sm ! Do nothing for base version - + if (allocated(sm%sv)) call sm%sv%default() - + return end subroutine c_base_smoother_default - - - + + + subroutine c_base_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info) use psb_base_mod type(psb_desc_type), intent(in) :: desc_data @@ -965,7 +993,7 @@ contains Integer :: err_act character(len=20) :: name='c_base_solver_apply' - + call psb_erractionsave(err_act) info = psb_err_missing_override_method_ @@ -974,7 +1002,7 @@ contains call psb_erractionrestore(err_act) return - + 9999 continue call psb_erractionrestore(err_act) if (err_act == psb_act_abort_) then @@ -984,13 +1012,13 @@ contains return end subroutine c_base_solver_apply - + subroutine c_base_solver_bld(a,desc_a,sv,upd,info,b) - + use psb_base_mod - + Implicit None - + ! Arguments type(psb_cspmat_type), intent(in), target :: a Type(psb_desc_type), Intent(in) :: desc_a @@ -1000,16 +1028,16 @@ contains type(psb_cspmat_type), intent(in), target, optional :: b Integer :: err_act character(len=20) :: name='c_base_solver_bld' - + call psb_erractionsave(err_act) - + info = psb_err_missing_override_method_ call psb_errpush(info,name) goto 9999 - + call psb_erractionrestore(err_act) return - + 9999 continue call psb_erractionrestore(err_act) if (err_act == psb_act_abort_) then @@ -1018,29 +1046,29 @@ contains end if return end subroutine c_base_solver_bld - - + + subroutine c_base_solver_check(sv,info) - + use psb_base_mod - + Implicit None - + ! Arguments class(mld_c_base_solver_type), intent(inout) :: sv integer, intent(out) :: info Integer :: err_act character(len=20) :: name='c_base_solver_check' - + call psb_erractionsave(err_act) info = psb_success_ - - + + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return - + 9999 continue call psb_erractionrestore(err_act) if (err_act == psb_act_abort_) then @@ -1049,13 +1077,13 @@ contains end if return end subroutine c_base_solver_check - + subroutine c_base_solver_seti(sv,what,val,info) - + use psb_base_mod - + Implicit None - + ! Arguments class(mld_c_base_solver_type), intent(inout) :: sv integer, intent(in) :: what @@ -1069,13 +1097,13 @@ contains return end subroutine c_base_solver_seti - + subroutine c_base_solver_setc(sv,what,val,info) - + use psb_base_mod - + Implicit None - + ! Arguments class(mld_c_base_solver_type), intent(inout) :: sv integer, intent(in) :: what @@ -1083,20 +1111,20 @@ contains integer, intent(out) :: info Integer :: err_act, ival character(len=20) :: name='c_base_solver_setc' - + call psb_erractionsave(err_act) - + info = psb_success_ - + call mld_stringval(val,ival,info) if (info == psb_success_) call sv%set(what,ival,info) - + if (info /= psb_success_) goto 9999 - - + + call psb_erractionrestore(err_act) return - + 9999 continue call psb_erractionrestore(err_act) if (err_act == psb_act_abort_) then @@ -1107,11 +1135,11 @@ contains end subroutine c_base_solver_setc subroutine c_base_solver_setr(sv,what,val,info) - + use psb_base_mod - + Implicit None - + ! Arguments class(mld_c_base_solver_type), intent(inout) :: sv integer, intent(in) :: what @@ -1119,35 +1147,35 @@ contains integer, intent(out) :: info Integer :: err_act character(len=20) :: name='c_base_solver_setr' - + ! Correct action here is doing nothing. info = 0 return end subroutine c_base_solver_setr - + subroutine c_base_solver_free(sv,info) - + use psb_base_mod - + Implicit None - + ! Arguments class(mld_c_base_solver_type), intent(inout) :: sv integer, intent(out) :: info Integer :: err_act character(len=20) :: name='c_base_solver_free' - + call psb_erractionsave(err_act) - + info = psb_err_missing_override_method_ call psb_errpush(info,name) goto 9999 - + call psb_erractionrestore(err_act) return - + 9999 continue call psb_erractionrestore(err_act) if (err_act == psb_act_abort_) then @@ -1156,35 +1184,35 @@ contains end if return end subroutine c_base_solver_free - + subroutine c_base_solver_descr(sv,info,iout,coarse) - + use psb_base_mod - + Implicit None - + ! Arguments class(mld_c_base_solver_type), intent(in) :: sv integer, intent(out) :: info integer, intent(in), optional :: iout logical, intent(in), optional :: coarse - + ! Local variables integer :: err_act integer :: ictxt, me, np character(len=20), parameter :: name='mld_c_base_solver_descr' integer :: iout_ - - + + call psb_erractionsave(err_act) - + info = psb_err_missing_override_method_ call psb_errpush(info,name) goto 9999 - + call psb_erractionrestore(err_act) return - + 9999 continue call psb_erractionrestore(err_act) if (err_act == psb_act_abort_) then @@ -1193,7 +1221,7 @@ contains end if return end subroutine c_base_solver_descr - + function c_base_solver_sizeof(sv) result(val) implicit none ! Arguments @@ -1201,20 +1229,20 @@ contains integer(psb_long_int_k_) :: val integer :: i val = 0 - + return end function c_base_solver_sizeof - + subroutine c_base_solver_default(sv) implicit none ! Arguments class(mld_c_base_solver_type), intent(inout) :: sv ! Do nothing for base version - + return end subroutine c_base_solver_default - - + + subroutine mld_c_apply2v(prec,x,y,desc_data,info,trans,work) use psb_base_mod type(psb_desc_type),intent(in) :: desc_data @@ -1226,9 +1254,9 @@ contains complex(psb_spk_),intent(inout), optional, target :: work(:) Integer :: err_act character(len=20) :: name='c_prec_apply' - + call psb_erractionsave(err_act) - + select type(prec) type is (mld_cprec_type) call mld_precaply(prec,x,y,desc_data,info,trans,work) @@ -1237,10 +1265,10 @@ contains call psb_errpush(info,name) goto 9999 end select - + call psb_erractionrestore(err_act) return - + 9999 continue call psb_erractionrestore(err_act) if (err_act == psb_act_abort_) then @@ -1248,9 +1276,9 @@ contains return end if return - + end subroutine mld_c_apply2v - + subroutine mld_c_apply1v(prec,x,desc_data,info,trans) use psb_base_mod type(psb_desc_type),intent(in) :: desc_data @@ -1260,9 +1288,9 @@ contains character(len=1), optional :: trans Integer :: err_act character(len=20) :: name='c_prec_apply' - + call psb_erractionsave(err_act) - + select type(prec) type is (mld_cprec_type) call mld_precaply(prec,x,desc_data,info,trans) @@ -1271,10 +1299,10 @@ contains call psb_errpush(info,name) goto 9999 end select - + call psb_erractionrestore(err_act) return - + 9999 continue call psb_erractionrestore(err_act) if (err_act == psb_act_abort_) then @@ -1282,31 +1310,31 @@ contains return end if return - + end subroutine mld_c_apply1v - + subroutine c_base_onelev_check(lv,info) - + use psb_base_mod - + Implicit None - + ! Arguments class(mld_conelev_type), intent(inout) :: lv integer, intent(out) :: info Integer :: err_act character(len=20) :: name='c_base_onelev_check' - + call psb_erractionsave(err_act) info = psb_success_ - + call mld_check_def(lv%parms%sweeps,& & 'Jacobi sweeps',1,is_legal_jac_sweeps) call mld_check_def(lv%parms%sweeps_pre,& & 'Jacobi sweeps',1,is_legal_jac_sweeps) call mld_check_def(lv%parms%sweeps_post,& & 'Jacobi sweeps',1,is_legal_jac_sweeps) - + if (allocated(lv%sm)) then call lv%sm%check(info) @@ -1315,12 +1343,12 @@ contains call psb_errpush(info,name) goto 9999 end if - + if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) return - + 9999 continue call psb_erractionrestore(err_act) if (err_act == psb_act_abort_) then @@ -1329,17 +1357,17 @@ contains end if return end subroutine c_base_onelev_check - - + + subroutine c_base_onelev_default(lv) - + use psb_base_mod - + Implicit None - + ! Arguments class(mld_conelev_type), intent(inout) :: lv - + lv%parms%sweeps = 1 lv%parms%sweeps_pre = 1 lv%parms%sweeps_post = 1 @@ -1355,18 +1383,18 @@ contains lv%parms%aggr_thresh = szero if (allocated(lv%sm)) call lv%sm%default() - + return - + end subroutine c_base_onelev_default - - + + subroutine c_base_onelev_seti(lv,what,val,info) - + use psb_base_mod - + Implicit None - + ! Arguments class(mld_conelev_type), intent(inout) :: lv integer, intent(in) :: what @@ -1374,50 +1402,50 @@ contains integer, intent(out) :: info Integer :: err_act character(len=20) :: name='c_base_onelev_seti' - + call psb_erractionsave(err_act) info = psb_success_ - + select case (what) - + case (mld_smoother_sweeps_) lv%parms%sweeps = val lv%parms%sweeps_pre = val lv%parms%sweeps_post = val - + case (mld_smoother_sweeps_pre_) lv%parms%sweeps_pre = val - + case (mld_smoother_sweeps_post_) lv%parms%sweeps_post = val - + case (mld_ml_type_) lv%parms%ml_type = val - + case (mld_aggr_alg_) lv%parms%aggr_alg = val - + case (mld_aggr_kind_) lv%parms%aggr_kind = val - + case (mld_coarse_mat_) lv%parms%coarse_mat = val - + case (mld_smoother_pos_) lv%parms%smoother_pos = val - + case (mld_aggr_omega_alg_) lv%parms%aggr_omega_alg= val - + case (mld_aggr_eig_) lv%parms%aggr_eig = val - + case (mld_aggr_filter_) lv%parms%aggr_filter = val - + case (mld_coarse_solve_) lv%parms%coarse_solve = val - + case default if (allocated(lv%sm)) then call lv%sm%set(what,val,info) @@ -1426,7 +1454,7 @@ contains end select call psb_erractionrestore(err_act) return - + 9999 continue call psb_erractionrestore(err_act) if (err_act == psb_act_abort_) then @@ -1435,13 +1463,13 @@ contains end if return end subroutine c_base_onelev_seti - + subroutine c_base_onelev_setc(lv,what,val,info) - + use psb_base_mod - + Implicit None - + ! Arguments class(mld_conelev_type), intent(inout) :: lv integer, intent(in) :: what @@ -1450,19 +1478,19 @@ contains Integer :: err_act character(len=20) :: name='c_base_onelev_setc' integer :: ival - + call psb_erractionsave(err_act) - + info = psb_success_ - + call mld_stringval(val,ival,info) if (info == psb_success_) call lv%set(what,ival,info) - + if (info /= psb_success_) goto 9999 - + call psb_erractionrestore(err_act) return - + 9999 continue call psb_erractionrestore(err_act) if (err_act == psb_act_abort_) then @@ -1471,13 +1499,13 @@ contains end if return end subroutine c_base_onelev_setc - + subroutine c_base_onelev_setr(lv,what,val,info) - + use psb_base_mod - + Implicit None - + ! Arguments class(mld_conelev_type), intent(inout) :: lv integer, intent(in) :: what @@ -1485,30 +1513,30 @@ contains integer, intent(out) :: info Integer :: err_act character(len=20) :: name='c_base_onelev_setr' - + call psb_erractionsave(err_act) - - + + info = psb_success_ select case (what) - + case (mld_aggr_omega_val_) lv%parms%aggr_omega_val= val - + case (mld_aggr_thresh_) lv%parms%aggr_thresh = val - + case default if (allocated(lv%sm)) then call lv%sm%set(what,val,info) end if if (info /= psb_success_) goto 9999 end select - + call psb_erractionrestore(err_act) return - + 9999 continue call psb_erractionrestore(err_act) if (err_act == psb_act_abort_) then @@ -1517,7 +1545,7 @@ contains end if return end subroutine c_base_onelev_setr - + subroutine mld_c_dump(prec,info,istart,iend,prefix,head,ac,smoother,solver) use psb_base_mod implicit none @@ -1531,9 +1559,9 @@ contains character(len=80) :: prefix_ character(len=120) :: fname ! len should be at least 20 more than ! len of prefix_ - + info = 0 - + iln = size(prec%precv) if (present(istart)) then il1 = max(1,istart) @@ -1543,15 +1571,15 @@ contains if (present(iend)) then iln = min(iln, iend) end if - + do lev=il1, iln call prec%precv(lev)%dump(lev,info,prefix=prefix,head=head,& & ac=ac,smoother=smoother,solver=solver) end do - + end subroutine mld_c_dump - + subroutine c_base_onelev_dump(lv,level,info,prefix,head,ac,smoother,solver) use psb_base_mod implicit none @@ -1566,15 +1594,15 @@ contains character(len=120) :: fname ! len should be at least 20 more than logical :: ac_ ! len of prefix_ - + info = 0 - + if (present(prefix)) then prefix_ = trim(prefix(1:min(len(prefix),len(prefix_)))) else prefix_ = "dump_lev_c" end if - + if (associated(lv%base_desc)) then icontxt = psb_cd_get_context(lv%base_desc) call psb_info(icontxt,iam,np) @@ -1591,7 +1619,7 @@ contains fname = trim(prefix_) write(fname(lname+1:lname+5),'(a,i3.3)') '_p',iam lname = lname + 5 - + if (level >= 2) then write(fname(lname+1:),'(a,i3.3,a)')'_l',level,'_ac.mtx' write(0,*) 'Filename ',fname @@ -1599,9 +1627,9 @@ contains end if if (allocated(lv%sm)) & & call lv%sm%dump(icontxt,level,info,smoother=smoother,solver=solver) - + end subroutine c_base_onelev_dump - + subroutine c_base_smoother_dmp(sm,ictxt,level,info,prefix,head,smoother,solver) use psb_base_mod implicit none @@ -1616,17 +1644,17 @@ contains character(len=120) :: fname ! len should be at least 20 more than logical :: smoother_ ! len of prefix_ - + info = 0 - + if (present(prefix)) then prefix_ = trim(prefix(1:min(len(prefix),len(prefix_)))) else prefix_ = "dump_smth_d" end if - + call psb_info(ictxt,iam,np) - + if (present(smoother)) then smoother_ = smoother else @@ -1636,13 +1664,13 @@ contains fname = trim(prefix_) write(fname(lname+1:lname+5),'(a,i3.3)') '_p',iam lname = lname + 5 - + ! At base level do nothing for the smoother if (allocated(sm%sv)) & & call sm%sv%dump(ictxt,level,info,solver=solver) - + end subroutine c_base_smoother_dmp - + subroutine c_base_solver_dmp(sv,ictxt,level,info,prefix,head,solver) use psb_base_mod implicit none @@ -1657,17 +1685,17 @@ contains character(len=120) :: fname ! len should be at least 20 more than logical :: solver_ ! len of prefix_ - + info = 0 - + if (present(prefix)) then prefix_ = trim(prefix(1:min(len(prefix),len(prefix_)))) else prefix_ = "dump_slv_d" end if - + call psb_info(ictxt,iam,np) - + if (present(solver)) then solver_ = solver else @@ -1677,10 +1705,10 @@ contains fname = trim(prefix_) write(fname(lname+1:lname+5),'(a,i3.3)') '_p',iam lname = lname + 5 - + ! At base level do nothing for the solver - + end subroutine c_base_solver_dmp - - + + end module mld_c_prec_type diff --git a/mlprec/mld_cprecbld.f90 b/mlprec/mld_cprecbld.f90 index 15f26c7d..8288ea16 100644 --- a/mlprec/mld_cprecbld.f90 +++ b/mlprec/mld_cprecbld.f90 @@ -194,6 +194,8 @@ subroutine mld_cprecbld(a,desc_a,p,info) goto 9999 endif end if + + call p%cmp_complexity() call psb_erractionrestore(err_act) return diff --git a/mlprec/mld_d_prec_type.f90 b/mlprec/mld_d_prec_type.f90 index 6421e1b7..34d928b7 100644 --- a/mlprec/mld_d_prec_type.f90 +++ b/mlprec/mld_d_prec_type.f90 @@ -229,11 +229,14 @@ module mld_d_prec_type type, extends(psb_dprec_type) :: mld_dprec_type integer :: ictxt + real(psb_dpk_) :: op_complexity=-done type(mld_donelev_type), allocatable :: precv(:) contains procedure, pass(prec) :: d_apply2v => mld_d_apply2v procedure, pass(prec) :: d_apply1v => mld_d_apply1v procedure, pass(prec) :: dump => mld_d_dump + procedure, pass(prec) :: get_complexity => mld_d_get_compl + procedure, pass(prec) :: cmp_complexity => mld_d_cmp_compl end type mld_dprec_type private :: d_base_solver_bld, d_base_solver_apply, & @@ -251,7 +254,8 @@ module mld_d_prec_type & d_base_onelev_seti, d_base_onelev_setc, & & d_base_onelev_setr, d_base_onelev_check, & & d_base_onelev_default, d_base_onelev_dump, & - & d_base_onelev_descr + & d_base_onelev_descr, mld_d_dump, & + & mld_d_get_compl, mld_d_cmp_compl ! @@ -304,7 +308,6 @@ contains ! function mld_dprec_sizeof(prec) result(val) - use psb_base_mod implicit none type(mld_dprec_type), intent(in) :: prec integer(psb_long_int_k_) :: val @@ -318,7 +321,6 @@ contains end if end function mld_dprec_sizeof - function mld_d_onelev_prec_sizeof(prec) result(val) implicit none type(mld_donelev_type), intent(in) :: prec @@ -330,10 +332,48 @@ contains val = val + psb_sizeof(prec%ac) val = val + psb_sizeof(prec%map) if (allocated(prec%sm)) val = val + prec%sm%sizeof() -!!$ write(0,*) 'ONelev sizes: ',psb_sizeof(prec%desc_ac),& -!!$ & psb_sizeof(prec%ac), psb_sizeof(prec%map), prec%sm%sizeof() end function mld_d_onelev_prec_sizeof + function mld_d_get_compl(prec) result(val) + implicit none + class(mld_dprec_type), intent(in) :: prec + real(psb_dpk_) :: val + + val = prec%op_complexity + + end function mld_d_get_compl + + subroutine mld_d_cmp_compl(prec) + use psb_base_mod, only : psb_min, psb_sum + implicit none + class(mld_dprec_type), intent(inout) :: prec + + real(psb_dpk_) :: num,den + integer :: ictxt, il + + num = -done + den = done + ictxt = prec%ictxt + if (allocated(prec%precv)) then + il = 1 + num = prec%precv(il)%base_a%get_nzeros() + if (num >= dzero) then + den = num + do il=2,size(prec%precv) + num = num + max(0,prec%precv(il)%base_a%get_nzeros()) + end do + end if + end if + call psb_min(ictxt,num) + if (num < dzero) then + den = done + else + call psb_sum(ictxt,num) + call psb_sum(ictxt,den) + end if + prec%op_complexity = num/den + end subroutine mld_d_cmp_compl + ! ! Subroutine: mld_file_prec_descr ! Version: real @@ -376,7 +416,6 @@ contains ictxt = p%ictxt if (allocated(p%precv)) then -!!$ ictxt = psb_cd_get_context(p%precv(1)%prec%desc_data) call psb_info(ictxt,me,np) @@ -409,58 +448,33 @@ contains write(iout_,*) 'Base preconditioner (smoother) details' endif call p%precv(1)%sm%descr(info,iout=iout_) + if (nlev == 1) then + write(iout_,*) + return + end if end if - if (nlev > 1) then - - ! - ! Print multilevel details - ! - write(iout_,*) - write(iout_,*) 'Multilevel details' - write(iout_,*) ' Number of levels: ',nlev - - ! - ! Currently, all the preconditioner parameters must have - ! the same value at levels - ! 2,...,nlev-1, hence only the values at level 2 are printed - ! - - ilev=2 - call p%precv(ilev)%parms%descr(iout_,info) - - ! - ! Coarse matrices are different at levels 2,...,nlev-1, hence related - ! info is printed separately - ! - write(iout_,*) - do ilev = 2, nlev-1 - write(iout_,*) ' Level ',ilev - call p%precv(ilev)%descr(info,iout=iout_) - end do - - ! - ! Print coarsest level details - ! - ! Should rework this. - - ilev = nlev - write(iout_,*) - write(iout_,*) ' Level ',ilev,' (coarsest)' - - call p%precv(ilev)%parms%descr(iout_,info,coarse=.true.) - call p%precv(ilev)%descr(info,iout=iout_,coarse=.true.) - end if + ! + ! Print multilevel details + ! + write(iout_,*) + write(iout_,*) 'Multilevel details' + write(iout_,*) ' Number of levels : ',nlev + write(iout_,*) ' Operator complexity: ',p%get_complexity() + do ilev=2,nlev + call p%precv(ilev)%descr(ilev,nlev,info,iout=iout_) + end do + write(iout_,*) + + end if - endif - write(iout_,*) else write(iout_,*) trim(name), & & ': Error: no base preconditioner available, something is wrong!' info = -2 return endif - + end subroutine mld_dfile_prec_descr @@ -478,7 +492,7 @@ contains ! error code. ! - subroutine d_base_onelev_descr(lv,info,iout,coarse) + subroutine d_base_onelev_descr(lv,il,nl,info,iout) use psb_base_mod @@ -486,44 +500,53 @@ contains ! Arguments class(mld_donelev_type), intent(in) :: lv + integer, intent(in) :: il,nl integer, intent(out) :: info integer, intent(in), optional :: iout - logical, intent(in), optional :: coarse ! Local variables integer :: err_act integer :: ictxt, me, np character(len=20), parameter :: name='mld_d_base_onelev_descr' integer :: iout_ - logical :: coarse_ + logical :: coarse call psb_erractionsave(err_act) - if (present(coarse)) then - coarse_ = coarse - else - coarse_ = .false. - end if + + coarse = (il==nl) + if (present(iout)) then iout_ = iout else iout_ = 6 end if + + write(iout_,*) + if (il == 2) then + call lv%parms%mldescr(iout_,info) + write(iout_,*) + end if + + if (coarse) then + write(iout_,*) ' Level ',il,' (coarsest)' + else + write(iout_,*) ' Level ',il + end if - if (lv%parms%ml_type > mld_no_ml_) then + call lv%parms%descr(iout_,info,coarse=coarse) + + if (nl > 1) then if (allocated(lv%map%naggr)) then write(iout_,*) ' Size of coarse matrix: ', & & sum(lv%map%naggr(:)) write(iout_,*) ' Sizes of aggregates: ', & & lv%map%naggr(:) end if - if (lv%parms%aggr_kind /= mld_no_smooth_) then - write(iout_,*) ' Damping omega: ', & - & lv%parms%aggr_omega_val - end if end if - if (allocated(lv%sm)) & + + if (coarse.and.allocated(lv%sm)) & & call lv%sm%descr(info,iout=iout_,coarse=coarse) call psb_erractionrestore(err_act) diff --git a/mlprec/mld_dprecbld.f90 b/mlprec/mld_dprecbld.f90 index c27ee54d..9c69526a 100644 --- a/mlprec/mld_dprecbld.f90 +++ b/mlprec/mld_dprecbld.f90 @@ -193,6 +193,8 @@ subroutine mld_dprecbld(a,desc_a,p,info) goto 9999 endif end if + + call p%cmp_complexity() call psb_erractionrestore(err_act) return diff --git a/mlprec/mld_dprecinit.F90 b/mlprec/mld_dprecinit.F90 index 16624221..be4f1680 100644 --- a/mlprec/mld_dprecinit.F90 +++ b/mlprec/mld_dprecinit.F90 @@ -204,7 +204,7 @@ subroutine mld_dprecinit(p,ptype,info,nlev) call p%precv(ilev_)%set(mld_sub_prol_,psb_none_,info) call p%precv(ilev_)%set(mld_sub_ovr_,0,info) - thr = 0.16 + thr = 0.16d0 do ilev_=1,nlev_ call p%precv(ilev_)%set(mld_aggr_thresh_,thr,info) thr = thr/2 diff --git a/mlprec/mld_s_prec_type.f90 b/mlprec/mld_s_prec_type.f90 index 1d43d729..3cce9883 100644 --- a/mlprec/mld_s_prec_type.f90 +++ b/mlprec/mld_s_prec_type.f90 @@ -229,11 +229,14 @@ module mld_s_prec_type type, extends(psb_sprec_type) :: mld_sprec_type integer :: ictxt + real(psb_spk_) :: op_complexity=-sone type(mld_sonelev_type), allocatable :: precv(:) contains procedure, pass(prec) :: s_apply2v => mld_s_apply2v procedure, pass(prec) :: s_apply1v => mld_s_apply1v procedure, pass(prec) :: dump => mld_s_dump + procedure, pass(prec) :: get_complexity => mld_s_get_compl + procedure, pass(prec) :: cmp_complexity => mld_s_cmp_compl end type mld_sprec_type private :: s_base_solver_bld, s_base_solver_apply, & @@ -251,7 +254,8 @@ module mld_s_prec_type & s_base_onelev_seti, s_base_onelev_setc, & & s_base_onelev_setr, s_base_onelev_check, & & s_base_onelev_default, s_base_onelev_dump, & - & s_base_onelev_descr + & s_base_onelev_descr, mld_s_dump, & + & mld_s_get_compl, mld_s_cmp_compl ! @@ -331,6 +335,46 @@ contains if (allocated(prec%sm)) val = val + prec%sm%sizeof() end function mld_s_onelev_prec_sizeof + function mld_s_get_compl(prec) result(val) + implicit none + class(mld_sprec_type), intent(in) :: prec + real(psb_spk_) :: val + + val = prec%op_complexity + + end function mld_s_get_compl + + subroutine mld_s_cmp_compl(prec) + use psb_base_mod, only : psb_min, psb_sum + implicit none + class(mld_sprec_type), intent(inout) :: prec + + real(psb_spk_) :: num,den + integer :: ictxt, il + + num = -sone + den = sone + ictxt = prec%ictxt + if (allocated(prec%precv)) then + il = 1 + num = prec%precv(il)%base_a%get_nzeros() + if (num >= szero) then + den = num + do il=2,size(prec%precv) + num = num + max(0,prec%precv(il)%base_a%get_nzeros()) + end do + end if + end if + call psb_min(ictxt,num) + if (num < szero) then + den = sone + else + call psb_sum(ictxt,num) + call psb_sum(ictxt,den) + end if + prec%op_complexity = num/den + end subroutine mld_s_cmp_compl + ! ! Subroutine: mld_file_prec_descr ! Version: real @@ -371,12 +415,11 @@ contains if (iout_ < 0) iout_ = 6 ictxt = p%ictxt - + if (allocated(p%precv)) then -!!$ ictxt = psb_cd_get_context(p%precv(1)%prec%desc_data) - + call psb_info(ictxt,me,np) - + ! ! The preconditioner description is printed by processor psb_root_. ! This agrees with the fact that all the parameters defining the @@ -406,58 +449,33 @@ contains write(iout_,*) 'Base preconditioner (smoother) details' endif call p%precv(1)%sm%descr(info,iout=iout_) + if (nlev == 1) then + write(iout_,*) + return + end if end if - if (nlev > 1) then - - ! - ! Print multilevel details - ! - write(iout_,*) - write(iout_,*) 'Multilevel details' - write(iout_,*) ' Number of levels: ',nlev - - ! - ! Currently, all the preconditioner parameters must have - ! the same value at levels - ! 2,...,nlev-1, hence only the values at level 2 are printed - ! - - ilev=2 - call p%precv(ilev)%parms%descr(iout_,info) - - ! - ! Coarse matrices are different at levels 2,...,nlev-1, hence related - ! info is printed separately - ! - write(iout_,*) - do ilev = 2, nlev-1 - write(iout_,*) ' Level ',ilev - call p%precv(ilev)%descr(info,iout=iout_) - end do - - ! - ! Print coarsest level details - ! - ! Should rework this. - - ilev = nlev - write(iout_,*) - write(iout_,*) ' Level ',ilev,' (coarsest)' + ! + ! Print multilevel details + ! + write(iout_,*) + write(iout_,*) 'Multilevel details' + write(iout_,*) ' Number of levels : ',nlev + write(iout_,*) ' Operator complexity: ',p%get_complexity() + do ilev=2,nlev + call p%precv(ilev)%descr(ilev,nlev,info,iout=iout_) + end do + write(iout_,*) + + end if - call p%precv(ilev)%parms%descr(iout_,info,coarse=.true.) - call p%precv(ilev)%descr(info,iout=iout_,coarse=.true.) - end if - - endif - write(iout_,*) else write(iout_,*) trim(name), & & ': Error: no base preconditioner available, something is wrong!' info = -2 return endif - + end subroutine mld_sfile_prec_descr @@ -475,7 +493,7 @@ contains ! error code. ! - subroutine s_base_onelev_descr(lv,info,iout,coarse) + subroutine s_base_onelev_descr(lv,il,nl,info,iout) use psb_base_mod @@ -483,49 +501,58 @@ contains ! Arguments class(mld_sonelev_type), intent(in) :: lv + integer, intent(in) :: il,nl integer, intent(out) :: info integer, intent(in), optional :: iout - logical, intent(in), optional :: coarse - + ! Local variables integer :: err_act integer :: ictxt, me, np character(len=20), parameter :: name='mld_s_base_onelev_descr' integer :: iout_ - logical :: coarse_ - - + logical :: coarse + + call psb_erractionsave(err_act) - - if (present(coarse)) then - coarse_ = coarse - else - coarse_ = .false. - end if + + + coarse = (il==nl) + if (present(iout)) then iout_ = iout else iout_ = 6 end if - - if (lv%parms%ml_type > mld_no_ml_) then + + write(iout_,*) + if (il == 2) then + call lv%parms%mldescr(iout_,info) + write(iout_,*) + end if + + if (coarse) then + write(iout_,*) ' Level ',il,' (coarsest)' + else + write(iout_,*) ' Level ',il + end if + + call lv%parms%descr(iout_,info,coarse=coarse) + + if (nl > 1) then if (allocated(lv%map%naggr)) then write(iout_,*) ' Size of coarse matrix: ', & & sum(lv%map%naggr(:)) write(iout_,*) ' Sizes of aggregates: ', & & lv%map%naggr(:) end if - if (lv%parms%aggr_kind /= mld_no_smooth_) then - write(iout_,*) ' Damping omega: ', & - & lv%parms%aggr_omega_val - end if end if - if (allocated(lv%sm)) & + + if (coarse.and.allocated(lv%sm)) & & call lv%sm%descr(info,iout=iout_,coarse=coarse) - + call psb_erractionrestore(err_act) return - + 9999 continue call psb_erractionrestore(err_act) if (err_act == psb_act_abort_) then diff --git a/mlprec/mld_sprecbld.f90 b/mlprec/mld_sprecbld.f90 index 5b4bcc4a..e47375be 100644 --- a/mlprec/mld_sprecbld.f90 +++ b/mlprec/mld_sprecbld.f90 @@ -193,6 +193,8 @@ subroutine mld_sprecbld(a,desc_a,p,info) goto 9999 endif end if + + call p%cmp_complexity() call psb_erractionrestore(err_act) return diff --git a/mlprec/mld_z_prec_type.f90 b/mlprec/mld_z_prec_type.f90 index a80eaac5..b9cd24cf 100644 --- a/mlprec/mld_z_prec_type.f90 +++ b/mlprec/mld_z_prec_type.f90 @@ -229,11 +229,14 @@ module mld_z_prec_type type, extends(psb_zprec_type) :: mld_zprec_type integer :: ictxt + real(psb_dpk_) :: op_complexity=-done type(mld_zonelev_type), allocatable :: precv(:) contains procedure, pass(prec) :: z_apply2v => mld_z_apply2v procedure, pass(prec) :: z_apply1v => mld_z_apply1v procedure, pass(prec) :: dump => mld_z_dump + procedure, pass(prec) :: get_complexity => mld_z_get_compl + procedure, pass(prec) :: cmp_complexity => mld_z_cmp_compl end type mld_zprec_type private :: z_base_solver_bld, z_base_solver_apply, & @@ -251,7 +254,8 @@ module mld_z_prec_type & z_base_onelev_seti, z_base_onelev_setc, & & z_base_onelev_setr, z_base_onelev_check, & & z_base_onelev_default, z_base_onelev_dump, & - & z_base_onelev_descr + & z_base_onelev_descr, mld_z_dump, & + & mld_z_get_compl, mld_z_cmp_compl ! @@ -330,6 +334,46 @@ contains if (allocated(prec%sm)) val = val + prec%sm%sizeof() end function mld_z_onelev_prec_sizeof + function mld_z_get_compl(prec) result(val) + implicit none + class(mld_zprec_type), intent(in) :: prec + real(psb_dpk_) :: val + + val = prec%op_complexity + + end function mld_z_get_compl + + subroutine mld_z_cmp_compl(prec) + use psb_base_mod, only : psb_min, psb_sum + implicit none + class(mld_zprec_type), intent(inout) :: prec + + real(psb_dpk_) :: num,den + integer :: ictxt, il + + num = -done + den = done + ictxt = prec%ictxt + if (allocated(prec%precv)) then + il = 1 + num = prec%precv(il)%base_a%get_nzeros() + if (num >= dzero) then + den = num + do il=2,size(prec%precv) + num = num + max(0,prec%precv(il)%base_a%get_nzeros()) + end do + end if + end if + call psb_min(ictxt,num) + if (num < dzero) then + den = done + else + call psb_sum(ictxt,num) + call psb_sum(ictxt,den) + end if + prec%op_complexity = num/den + end subroutine mld_z_cmp_compl + ! ! Subroutine: mld_file_prec_descr ! Version: real @@ -370,12 +414,11 @@ contains if (iout_ < 0) iout_ = 6 ictxt = p%ictxt - + if (allocated(p%precv)) then -!!$ ictxt = psb_cd_get_context(p%precv(1)%prec%desc_data) - + call psb_info(ictxt,me,np) - + ! ! The preconditioner description is printed by processor psb_root_. ! This agrees with the fact that all the parameters defining the @@ -405,57 +448,33 @@ contains write(iout_,*) 'Base preconditioner (smoother) details' endif call p%precv(1)%sm%descr(info,iout=iout_) + if (nlev == 1) then + write(iout_,*) + return + end if end if - if (nlev > 1) then - - ! - ! Print multilevel details - ! - write(iout_,*) - write(iout_,*) 'Multilevel details' - write(iout_,*) ' Number of levels: ',nlev - - ! - ! Currently, all the preconditioner parameters must have - ! the same value at levels - ! 2,...,nlev-1, hence only the values at level 2 are printed - ! - - ilev=2 - call p%precv(ilev)%parms%descr(iout_,info) - - ! - ! Coarse matrices are different at levels 2,...,nlev-1, hence related - ! info is printed separately - ! - write(iout_,*) - do ilev = 2, nlev-1 - write(iout_,*) ' Level ',ilev - call p%precv(ilev)%descr(info,iout=iout_) - end do - - ! - ! Print coarsest level details - ! - ! Should rework this. - - ilev = nlev - write(iout_,*) - write(iout_,*) ' Level ',ilev,' (coarsest)' + ! + ! Print multilevel details + ! + write(iout_,*) + write(iout_,*) 'Multilevel details' + write(iout_,*) ' Number of levels : ',nlev + write(iout_,*) ' Operator complexity: ',p%get_complexity() + do ilev=2,nlev + call p%precv(ilev)%descr(ilev,nlev,info,iout=iout_) + end do + write(iout_,*) + + end if - call p%precv(ilev)%parms%descr(iout_,info,coarse=.true.) - call p%precv(ilev)%descr(info,iout=iout_,coarse=.true.) - end if - - endif - write(iout_,*) else write(iout_,*) trim(name), & & ': Error: no base preconditioner available, something is wrong!' info = -2 return endif + end subroutine mld_zfile_prec_descr @@ -473,7 +492,7 @@ contains ! error code. ! - subroutine z_base_onelev_descr(lv,info,iout,coarse) + subroutine z_base_onelev_descr(lv,il,nl,info,iout) use psb_base_mod @@ -481,44 +500,53 @@ contains ! Arguments class(mld_zonelev_type), intent(in) :: lv + integer, intent(in) :: il,nl integer, intent(out) :: info integer, intent(in), optional :: iout - logical, intent(in), optional :: coarse ! Local variables integer :: err_act integer :: ictxt, me, np character(len=20), parameter :: name='mld_z_base_onelev_descr' integer :: iout_ - logical :: coarse_ + logical :: coarse call psb_erractionsave(err_act) - if (present(coarse)) then - coarse_ = coarse - else - coarse_ = .false. - end if + + coarse = (il==nl) + if (present(iout)) then iout_ = iout else iout_ = 6 end if + + write(iout_,*) + if (il == 2) then + call lv%parms%mldescr(iout_,info) + write(iout_,*) + end if - if (lv%parms%ml_type > mld_no_ml_) then + if (coarse) then + write(iout_,*) ' Level ',il,' (coarsest)' + else + write(iout_,*) ' Level ',il + end if + + call lv%parms%descr(iout_,info,coarse=coarse) + + if (nl > 1) then if (allocated(lv%map%naggr)) then write(iout_,*) ' Size of coarse matrix: ', & & sum(lv%map%naggr(:)) write(iout_,*) ' Sizes of aggregates: ', & & lv%map%naggr(:) end if - if (lv%parms%aggr_kind /= mld_no_smooth_) then - write(iout_,*) ' Damping omega: ', & - & lv%parms%aggr_omega_val - end if end if - if (allocated(lv%sm)) & + + if (coarse.and.allocated(lv%sm)) & & call lv%sm%descr(info,iout=iout_,coarse=coarse) call psb_erractionrestore(err_act) diff --git a/mlprec/mld_zprecbld.f90 b/mlprec/mld_zprecbld.f90 index 6c0e36f7..d9b244fa 100644 --- a/mlprec/mld_zprecbld.f90 +++ b/mlprec/mld_zprecbld.f90 @@ -194,6 +194,8 @@ subroutine mld_zprecbld(a,desc_a,p,info) goto 9999 endif end if + + call p%cmp_complexity() call psb_erractionrestore(err_act) return diff --git a/mlprec/mld_zprecinit.F90 b/mlprec/mld_zprecinit.F90 index 75c9b4be..a6d24fa1 100644 --- a/mlprec/mld_zprecinit.F90 +++ b/mlprec/mld_zprecinit.F90 @@ -202,7 +202,7 @@ subroutine mld_zprecinit(p,ptype,info,nlev) call p%precv(ilev_)%set(mld_sub_prol_,psb_none_,info) call p%precv(ilev_)%set(mld_sub_ovr_,0,info) - thr = 0.16 + thr = 0.16d0 do ilev_=1,nlev_ call p%precv(ilev_)%set(mld_aggr_thresh_,thr,info) thr = thr/2 diff --git a/tests/pdegen/ppde.f90 b/tests/pdegen/ppde.f90 index 8bfd77e8..310d784b 100644 --- a/tests/pdegen/ppde.f90 +++ b/tests/pdegen/ppde.f90 @@ -195,7 +195,8 @@ program ppde call mld_precset(prec,mld_aggr_alg_, prectype%aggr_alg,info) call mld_precset(prec,mld_ml_type_, prectype%mltype, info) call mld_precset(prec,mld_smoother_pos_, prectype%smthpos, info) - call mld_precset(prec,mld_aggr_thresh_, prectype%athres, info) + if (prectype%athres >= dzero) & + & call mld_precset(prec,mld_aggr_thresh_, prectype%athres, info) call mld_precset(prec,mld_coarse_solve_, prectype%csolve, info) call mld_precset(prec,mld_coarse_subsolve_, prectype%csbsolve,info) call mld_precset(prec,mld_coarse_mat_, prectype%cmat, info) diff --git a/tests/pdegen/runs/ppde.inp b/tests/pdegen/runs/ppde.inp index 0372e40d..268132c4 100644 --- a/tests/pdegen/runs/ppde.inp +++ b/tests/pdegen/runs/ppde.inp @@ -27,4 +27,4 @@ UMF ! Coarse level: subsolver DSCALE ILU UMF SLU SLUDI 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 +-0.10d0 ! Smoother Aggregation Threshold: >= 0.0 default if < 0.0 diff --git a/tests/pdegen/spde.f90 b/tests/pdegen/spde.f90 index 5c614c4f..db4a8f23 100644 --- a/tests/pdegen/spde.f90 +++ b/tests/pdegen/spde.f90 @@ -193,7 +193,8 @@ program spde call mld_precset(prec,mld_aggr_alg_, prectype%aggr_alg,info) call mld_precset(prec,mld_ml_type_, prectype%mltype, info) call mld_precset(prec,mld_smoother_pos_, prectype%smthpos, info) - call mld_precset(prec,mld_aggr_thresh_, prectype%athres, info) + if (prectype%athres >= szero) & + & call mld_precset(prec,mld_aggr_thresh_, prectype%athres, info) call mld_precset(prec,mld_coarse_solve_, prectype%csolve, info) call mld_precset(prec,mld_coarse_subsolve_, prectype%csbsolve,info) call mld_precset(prec,mld_coarse_mat_, prectype%cmat, info)