From 6f06a48d2526b99421348657dec15d8d5ce50adb Mon Sep 17 00:00:00 2001 From: Salvatore Filippone Date: Fri, 6 May 2016 16:52:08 +0000 Subject: [PATCH 02/17] mld2p4-smoother-2side: mlprec/impl/mld_dmlprec_aply.f90 mlprec/impl/mld_dmlprec_bld.f90 mlprec/mld_d_gs_solver.f90 mlprec/mld_d_onelev_mod.f90 tests/pdegen/runs/ppde.inp First steps towards BW-gs as a 2nd smoother. --- mlprec/impl/mld_dmlprec_aply.f90 | 96 ++++++++++++++++++++++---------- mlprec/impl/mld_dmlprec_bld.f90 | 2 +- mlprec/mld_d_gs_solver.f90 | 66 ++++++++++++++++++++-- mlprec/mld_d_onelev_mod.f90 | 41 ++++++++++++-- tests/pdegen/runs/ppde.inp | 4 +- 5 files changed, 168 insertions(+), 41 deletions(-) diff --git a/mlprec/impl/mld_dmlprec_aply.f90 b/mlprec/impl/mld_dmlprec_aply.f90 index 5aeabe1b..a5cceced 100644 --- a/mlprec/impl/mld_dmlprec_aply.f90 +++ b/mlprec/impl/mld_dmlprec_aply.f90 @@ -406,7 +406,7 @@ contains ! Arguments integer(psb_ipk_) :: level - type(mld_dprec_type), intent(inout) :: p + type(mld_dprec_type), target, intent(inout) :: p type(mld_mlprec_wrk_type), intent(inout) :: mlprec_wrk(:) character, intent(in) :: trans real(psb_dpk_),target :: work(:) @@ -539,7 +539,6 @@ contains end if ! This is one step of post-smoothing - if (level < nlev) then call inner_ml_aply(level+1,p,mlprec_wrk,trans,work,info) if (info /= psb_success_) then @@ -572,7 +571,7 @@ contains end if sweeps = p%precv(level)%parms%sweeps_post - call p%precv(level)%sm%apply(done,& + call p%precv(level)%sm2%apply(done,& & mlprec_wrk(level)%x2l,done,mlprec_wrk(level)%y2l,& & p%precv(level)%base_desc, trans,& & sweeps,work,info) @@ -583,8 +582,9 @@ contains end if else + ! Here at coarse level sweeps = p%precv(level)%parms%sweeps - call p%precv(level)%sm%apply(done,& + call p%precv(level)%sm2%apply(done,& & mlprec_wrk(level)%x2l,dzero,mlprec_wrk(level)%y2l,& & p%precv(level)%base_desc, trans,& & sweeps,work,info) @@ -624,7 +624,7 @@ contains else sweeps = p%precv(level)%parms%sweeps end if - call p%precv(level)%sm%apply(done,& + call p%precv(level)%sm2%apply(done,& & mlprec_wrk(level)%x2l,dzero,mlprec_wrk(level)%y2l,& & p%precv(level)%base_desc, trans,& & sweeps,work,info) @@ -830,6 +830,13 @@ contains case(mld_twoside_smooth_) + ! CHECK + if (.not.(associated(p%precv(level)%sm2,p%precv(level)%sm2a))) then + write(0,*) 'inner_ml_aply: unassociated sm2 at level ',level + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Error during restriction') + goto 9999 + end if nc2l = p%precv(level)%base_desc%get_local_cols() nr2l = p%precv(level)%base_desc%get_local_rows() allocate(mlprec_wrk(level)%ty(nc2l), mlprec_wrk(level)%tx(nc2l), stat=info) @@ -866,10 +873,19 @@ contains else sweeps = p%precv(level)%parms%sweeps end if - if (info == psb_success_) call p%precv(level)%sm%apply(done,& - & mlprec_wrk(level)%x2l,dzero,mlprec_wrk(level)%y2l,& - & p%precv(level)%base_desc, trans,& - & sweeps,work,info) + + if (trans == 'N') then + if (info == psb_success_) call p%precv(level)%sm%apply(done,& + & mlprec_wrk(level)%x2l,dzero,mlprec_wrk(level)%y2l,& + & p%precv(level)%base_desc, trans,& + & sweeps,work,info) + else + if (info == psb_success_) call p%precv(level)%sm2%apply(done,& + & mlprec_wrk(level)%x2l,dzero,mlprec_wrk(level)%y2l,& + & p%precv(level)%base_desc, trans,& + & sweeps,work,info) + end if + if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& & a_err='Error during smoother_apply') @@ -930,10 +946,18 @@ contains else sweeps = p%precv(level)%parms%sweeps_pre end if - if (info == psb_success_) call p%precv(level)%sm%apply(done,& - & mlprec_wrk(level)%tx,done,mlprec_wrk(level)%y2l,& - & p%precv(level)%base_desc, trans,& - & sweeps,work,info) + if (trans == 'N') then + if (info == psb_success_) call p%precv(level)%sm2%apply(done,& + & mlprec_wrk(level)%x2l,dzero,mlprec_wrk(level)%y2l,& + & p%precv(level)%base_desc, trans,& + & sweeps,work,info) + else + if (info == psb_success_) call p%precv(level)%sm%apply(done,& + & mlprec_wrk(level)%x2l,dzero,mlprec_wrk(level)%y2l,& + & p%precv(level)%base_desc, trans,& + & sweeps,work,info) + end if + if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& & a_err='Error during smoother_apply') @@ -1043,7 +1067,7 @@ subroutine mld_dmlprec_aply_vect(alpha,p,x,beta,y,desc_data,trans,work,info) level = 1 call psb_geaxpby(done,x,dzero,mlprec_wrk(level)%vx2l,p%precv(level)%base_desc,info) - call mlprec_wrk(level)%vy2l%set(dzero) + call mlprec_wrk(level)%vy2l%zero() call inner_ml_aply(level,p,mlprec_wrk,trans_,work,info) @@ -1122,7 +1146,9 @@ contains nc2l = p%precv(level)%base_desc%get_local_cols() nr2l = p%precv(level)%base_desc%get_local_rows() - + if(debug_level > 1) then + write(debug_unit,*) me,' inner_ml_aply at level ',level + end if select case(p%precv(level)%parms%ml_type) @@ -1250,7 +1276,7 @@ contains sweeps = p%precv(level)%parms%sweeps_post - call p%precv(level)%sm%apply(done,& + call p%precv(level)%sm2%apply(done,& & mlprec_wrk(level)%vx2l,done,mlprec_wrk(level)%vy2l,& & p%precv(level)%base_desc, trans,& & sweeps,work,info) @@ -1262,7 +1288,7 @@ contains else sweeps = p%precv(level)%parms%sweeps - call p%precv(level)%sm%apply(done,& + call p%precv(level)%sm2%apply(done,& & mlprec_wrk(level)%vx2l,dzero,mlprec_wrk(level)%vy2l,& & p%precv(level)%base_desc, trans,& & sweeps,work,info) @@ -1302,7 +1328,7 @@ contains else sweeps = p%precv(level)%parms%sweeps end if - call p%precv(level)%sm%apply(done,& + call p%precv(level)%sm2%apply(done,& & mlprec_wrk(level)%vx2l,dzero,mlprec_wrk(level)%vy2l,& & p%precv(level)%base_desc, trans,& & sweeps,work,info) @@ -1536,13 +1562,20 @@ contains else sweeps = p%precv(level)%parms%sweeps end if - if (info == psb_success_) call p%precv(level)%sm%apply(done,& - & mlprec_wrk(level)%vx2l,dzero,mlprec_wrk(level)%vy2l,& - & p%precv(level)%base_desc, trans,& - & sweeps,work,info) + if (trans == 'N') then + if (info == psb_success_) call p%precv(level)%sm%apply(done,& + & mlprec_wrk(level)%vx2l,dzero,mlprec_wrk(level)%vy2l,& + & p%precv(level)%base_desc, trans,& + & sweeps,work,info) + else + if (info == psb_success_) call p%precv(level)%sm2%apply(done,& + & mlprec_wrk(level)%vx2l,dzero,mlprec_wrk(level)%vy2l,& + & p%precv(level)%base_desc, trans,& + & sweeps,work,info) + end if if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during smoother_apply') + & a_err='Error during 1st smoother_apply') goto 9999 end if @@ -1605,13 +1638,20 @@ contains else sweeps = p%precv(level)%parms%sweeps_pre end if - if (info == psb_success_) call p%precv(level)%sm%apply(done,& - & mlprec_wrk(level)%vtx,done,mlprec_wrk(level)%vy2l,& - & p%precv(level)%base_desc, trans,& - & sweeps,work,info) + if (trans == 'N') then + if (info == psb_success_) call p%precv(level)%sm2%apply(done,& + & mlprec_wrk(level)%vx2l,dzero,mlprec_wrk(level)%vy2l,& + & p%precv(level)%base_desc, trans,& + & sweeps,work,info) + else + if (info == psb_success_) call p%precv(level)%sm%apply(done,& + & mlprec_wrk(level)%vx2l,dzero,mlprec_wrk(level)%vy2l,& + & p%precv(level)%base_desc, trans,& + & sweeps,work,info) + end if if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during smoother_apply') + & a_err='Error during 2nd smoother_apply') goto 9999 end if diff --git a/mlprec/impl/mld_dmlprec_bld.f90 b/mlprec/impl/mld_dmlprec_bld.f90 index 11409363..3199ded8 100644 --- a/mlprec/impl/mld_dmlprec_bld.f90 +++ b/mlprec/impl/mld_dmlprec_bld.f90 @@ -495,7 +495,7 @@ subroutine mld_dmlprec_bld(a,desc_a,p,info,amold,vmold,imold) call p%precv(i)%sm%build(p%precv(i)%base_a,p%precv(i)%base_desc,& & 'F',info,amold=amold,vmold=vmold,imold=imold) - + p%precv(i)%sm2 => p%precv(i)%sm if ((info == psb_success_).and.(i>1)) then call p%precv(i)%cnv(info,amold=amold,vmold=vmold,imold=imold) end if diff --git a/mlprec/mld_d_gs_solver.f90 b/mlprec/mld_d_gs_solver.f90 index 6599d4ec..230c5d89 100644 --- a/mlprec/mld_d_gs_solver.f90 +++ b/mlprec/mld_d_gs_solver.f90 @@ -74,6 +74,16 @@ module mld_d_gs_solver procedure, nopass :: is_iterative => d_gs_solver_is_iterative end type mld_d_gs_solver_type + type, extends(mld_d_gs_solver_type) :: mld_d_bwgs_solver_type + contains +!!$ procedure, pass(sv) :: build => mld_d_bwgs_solver_bld +!!$ procedure, pass(sv) :: apply_v => mld_d_bwgs_solver_apply_vect +!!$ procedure, pass(sv) :: apply_a => mld_d_bwgs_solver_apply + procedure, nopass :: get_fmt => d_bwgs_solver_get_fmt + procedure, pass(sv) :: descr => d_bwgs_solver_descr + end type mld_d_bwgs_solver_type + + private :: d_gs_solver_bld, d_gs_solver_apply, & & d_gs_solver_free, d_gs_solver_seti, & @@ -82,7 +92,8 @@ module mld_d_gs_solver & d_gs_solver_default, d_gs_solver_dmp, & & d_gs_solver_apply_vect, d_gs_solver_get_nzeros, & & d_gs_solver_get_fmt, d_gs_solver_check,& - & d_gs_solver_is_iterative + & d_gs_solver_is_iterative, & + & d_bwgs_solver_get_fmt, d_bwgs_solver_descr interface @@ -452,10 +463,10 @@ contains endif if (sv%eps<=dzero) then - write(iout_,*) ' Gauss-Seidel iterative solver with ',& + write(iout_,*) ' Forward Gauss-Seidel iterative solver with ',& & sv%sweeps,' sweeps' else - write(iout_,*) ' Gauss-Seidel iterative solver with tolerance',& + write(iout_,*) ' Forward Gauss-Seidel iterative solver with tolerance',& & sv%eps,' and maxit', sv%sweeps end if @@ -500,7 +511,7 @@ contains implicit none character(len=32) :: val - val = "Gauss-Seidel solver" + val = "Forward Gauss-Seidel solver" end function d_gs_solver_get_fmt @@ -515,4 +526,51 @@ contains val = .true. end function d_gs_solver_is_iterative + + subroutine d_bwgs_solver_descr(sv,info,iout,coarse) + + Implicit None + + ! Arguments + class(mld_d_bwgs_solver_type), intent(in) :: sv + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: iout + logical, intent(in), optional :: coarse + + ! Local variables + integer(psb_ipk_) :: err_act + character(len=20), parameter :: name='mld_d_bwgs_solver_descr' + integer(psb_ipk_) :: iout_ + + call psb_erractionsave(err_act) + info = psb_success_ + if (present(iout)) then + iout_ = iout + else + iout_ = 6 + endif + + if (sv%eps<=dzero) then + write(iout_,*) ' Backward Gauss-Seidel iterative solver with ',& + & sv%sweeps,' sweeps' + else + write(iout_,*) ' Backward Gauss-Seidel iterative solver with tolerance',& + & sv%eps,' and maxit', sv%sweeps + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + return + end subroutine d_bwgs_solver_descr + + function d_bwgs_solver_get_fmt() result(val) + implicit none + character(len=32) :: val + + val = "Backward Gauss-Seidel solver" + end function d_bwgs_solver_get_fmt + + end module mld_d_gs_solver diff --git a/mlprec/mld_d_onelev_mod.f90 b/mlprec/mld_d_onelev_mod.f90 index 3401115b..9773e4fb 100644 --- a/mlprec/mld_d_onelev_mod.f90 +++ b/mlprec/mld_d_onelev_mod.f90 @@ -121,7 +121,8 @@ module mld_d_onelev_mod ! ! type mld_d_onelev_type - class(mld_d_base_smoother_type), allocatable :: sm + class(mld_d_base_smoother_type), allocatable :: sm, sm2a + class(mld_d_base_smoother_type), pointer :: sm2 type(mld_dml_parms) :: parms type(psb_dspmat_type) :: ac integer(psb_ipk_) :: ac_nz_loc, ac_nz_tot @@ -331,6 +332,8 @@ contains val = 0 if (allocated(lv%sm)) & & val = lv%sm%get_nzeros() + if (allocated(lv%sm2a)) & + & val = val + lv%sm2a%get_nzeros() end function d_base_onelev_get_nzeros function d_base_onelev_sizeof(lv) result(val) @@ -343,6 +346,7 @@ contains val = val + lv%ac%sizeof() val = val + lv%map%sizeof() if (allocated(lv%sm)) val = val + lv%sm%sizeof() + if (allocated(lv%sm2a)) val = val + lv%sm2a%sizeof() end function d_base_onelev_sizeof @@ -353,7 +357,7 @@ contains nullify(lv%base_a) nullify(lv%base_desc) - + nullify(lv%sm2) end subroutine d_base_onelev_nullify ! @@ -371,7 +375,7 @@ contains Implicit None ! Arguments - class(mld_d_onelev_type), intent(inout) :: lv + class(mld_d_onelev_type), target, intent(inout) :: lv lv%parms%sweeps = 1 lv%parms%sweeps_pre = 1 @@ -388,6 +392,12 @@ contains lv%parms%aggr_thresh = dzero if (allocated(lv%sm)) call lv%sm%default() + if (allocated(lv%sm2a)) then + call lv%sm2a%default() + lv%sm2 => lv%sm2a + else + lv%sm2 => lv%sm + end if return @@ -401,7 +411,7 @@ contains ! Arguments class(mld_d_onelev_type), target, intent(inout) :: lv - class(mld_d_onelev_type), intent(inout) :: lvout + class(mld_d_onelev_type), target, intent(inout) :: lvout integer(psb_ipk_), intent(out) :: info info = psb_success_ @@ -413,6 +423,16 @@ contains if (info==psb_success_) deallocate(lvout%sm,stat=info) end if end if + if (allocated(lv%sm2a)) then + call lv%sm%clone(lvout%sm2a,info) + lvout%sm2 => lvout%sm2a + else + if (allocated(lvout%sm2a)) then + call lvout%sm2a%free(info) + if (info==psb_success_) deallocate(lvout%sm2a,stat=info) + end if + lvout%sm2 => lvout%sm + end if if (info == psb_success_) call lv%parms%clone(lvout%parms,info) if (info == psb_success_) call lv%ac%clone(lvout%ac,info) if (info == psb_success_) call lv%desc_ac%clone(lvout%desc_ac,info) @@ -428,12 +448,21 @@ contains subroutine mld_d_onelev_move_alloc(a, b,info) use psb_base_mod implicit none - type(mld_d_onelev_type), intent(inout) :: a, b + type(mld_d_onelev_type), target, intent(inout) :: a, b integer(psb_ipk_), intent(out) :: info call b%free(info) b%parms = a%parms - call move_alloc(a%sm,b%sm) + if (associated(a%sm2,a%sm2a)) then + call move_alloc(a%sm,b%sm) + call move_alloc(a%sm2a,b%sm2a) + b%sm2 =>b%sm2a + else + call move_alloc(a%sm,b%sm) + call move_alloc(a%sm2a,b%sm2a) + b%sm2 =>b%sm + end if + 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) diff --git a/tests/pdegen/runs/ppde.inp b/tests/pdegen/runs/ppde.inp index 7e9993c4..d8bc10ce 100644 --- a/tests/pdegen/runs/ppde.inp +++ b/tests/pdegen/runs/ppde.inp @@ -3,7 +3,7 @@ CSR ! Storage format CSR COO JAD 0100 ! IDIM; domain size is idim**3 2 ! ISTOPC 0100 ! ITMAX -1 ! ITRACE +10 ! ITRACE 30 ! IRST (restart for RGMRES and BiCGSTABL) 1.d-6 ! EPS 3L-MUL-RAS-BJAC4-ILU ! Descriptive name for preconditioner (up to 40 chars) @@ -12,7 +12,7 @@ ML ! Preconditioner NONE JACOBI BJAC AS ML HALO ! Restriction operator NONE HALO NONE ! Prolongation operator NONE SUM AVG GS ! Subdomain solver DSCALE ILU MILU ILUT UMF SLU -1 ! sweeps for GS +2 ! sweeps for GS 0 ! Level-set N for ILU(N), and P for ILUT 1.d-4 ! Threshold T for ILU(T,P) 1 ! Smoother/Jacobi sweeps From 80c58b32eb08ab5b86c99df23de2907d92acd684 Mon Sep 17 00:00:00 2001 From: Salvatore Filippone Date: Sun, 8 May 2016 19:41:25 +0000 Subject: [PATCH 03/17] mld2p4-smooth-2side: mlprec/impl/mld_dprecset.F90 mlprec/mld_d_prec_mod.f90 mlprec/mld_d_prec_type.f90 tests/pdegen/Makefile tests/pdegen/runs/ppde.inp Fix dec_map XZERO. --- mlprec/impl/mld_dprecset.F90 | 179 ++++++++++++++++++++++++++--------- mlprec/mld_d_prec_mod.f90 | 29 +++--- mlprec/mld_d_prec_type.f90 | 38 ++++++-- tests/pdegen/Makefile | 12 ++- tests/pdegen/runs/ppde.inp | 6 +- 5 files changed, 191 insertions(+), 73 deletions(-) diff --git a/mlprec/impl/mld_dprecset.F90 b/mlprec/impl/mld_dprecset.F90 index 2f328351..730afd4f 100644 --- a/mlprec/impl/mld_dprecset.F90 +++ b/mlprec/impl/mld_dprecset.F90 @@ -76,7 +76,7 @@ ! For this reason, the interface mld_precset to this routine has been built in ! such a way that ilev is not visible to the user (see mld_prec_mod.f90). ! -subroutine mld_dprecseti(p,what,val,info,ilev) +subroutine mld_dprecseti(p,what,val,info,ilev,pos) use psb_base_mod use mld_d_prec_mod, mld_protect_name => mld_dprecseti @@ -107,6 +107,7 @@ subroutine mld_dprecseti(p,what,val,info,ilev) integer(psb_ipk_), intent(in) :: val integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), optional, intent(in) :: ilev + character(len=*), optional, intent(in) :: pos ! Local variables integer(psb_ipk_) :: ilev_, nlev_ @@ -671,7 +672,7 @@ contains end subroutine mld_dprecseti -subroutine mld_dprecsetsm(p,val,info,ilev) +subroutine mld_dprecsetsm(p,val,info,ilev,pos) use psb_base_mod use mld_d_prec_mod, mld_protect_name => mld_dprecsetsm @@ -679,15 +680,16 @@ subroutine mld_dprecsetsm(p,val,info,ilev) implicit none ! Arguments - class(mld_dprec_type), intent(inout) :: p - class(mld_d_base_smoother_type), intent(in) :: val - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), optional, intent(in) :: ilev - + class(mld_dprec_type), target, intent(inout) :: p + class(mld_d_base_smoother_type), intent(in) :: val + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional, intent(in) :: ilev + character(len=*), optional, intent(in) :: pos + ! Local variables - integer(psb_ipk_) :: ilev_, nlev_, ilmin, ilmax + integer(psb_ipk_) :: ilev_, nlev_, ilmin, ilmax, ipos_ character(len=*), parameter :: name='mld_precseti' - + info = psb_success_ if (.not.allocated(p%precv)) then @@ -708,7 +710,19 @@ subroutine mld_dprecsetsm(p,val,info,ilev) ilmin = 1 ilmax = nlev_ end if - + if (present(pos)) then + select case(psb_toupper(trim(pos))) + case('PRE') + ipos_ = mld_pre_smooth_ + case('POST') + ipos_ = mld_post_smooth_ + case default + ipos_ = mld_pre_smooth_ + end select + else + ipos_ = mld_pre_smooth_ + end if + if ((ilev_<1).or.(ilev_ > nlev_)) then info = -1 write(psb_err_unit,*) name,& @@ -716,25 +730,44 @@ subroutine mld_dprecsetsm(p,val,info,ilev) return endif - - do ilev_ = ilmin, ilmax - if (allocated(p%precv(ilev_)%sm)) then - if (allocated(p%precv(ilev_)%sm%sv)) then - deallocate(p%precv(ilev_)%sm%sv) - endif - deallocate(p%precv(ilev_)%sm) - end if + select case(ipos_) + case(mld_pre_smooth_) + do ilev_ = ilmin, ilmax + if (allocated(p%precv(ilev_)%sm)) then + if (allocated(p%precv(ilev_)%sm%sv)) then + deallocate(p%precv(ilev_)%sm%sv) + endif + deallocate(p%precv(ilev_)%sm) + end if #ifdef HAVE_MOLD - allocate(p%precv(ilev_)%sm,mold=val) + allocate(p%precv(ilev_)%sm,mold=val) #else - allocate(p%precv(ilev_)%sm,source=val) + allocate(p%precv(ilev_)%sm,source=val) #endif - call p%precv(ilev_)%sm%default() - end do - + call p%precv(ilev_)%sm%default() + p%precv(ilev_)%sm2 => p%precv(ilev_)%sm + end do + case(mld_post_smooth_) + do ilev_ = ilmin, ilmax + if (allocated(p%precv(ilev_)%sm2a)) then + if (allocated(p%precv(ilev_)%sm2a%sv)) then + deallocate(p%precv(ilev_)%sm2a%sv) + endif + deallocate(p%precv(ilev_)%sm2a) + end if +#ifdef HAVE_MOLD + allocate(p%precv(ilev_)%sm2a,mold=val) +#else + allocate(p%precv(ilev_)%sm2a,source=val) +#endif + call p%precv(ilev_)%sm2a%default() + p%precv(ilev_)%sm2 => p%precv(ilev_)%sm2a + end do + end select + end subroutine mld_dprecsetsm -subroutine mld_dprecsetsv(p,val,info,ilev) +subroutine mld_dprecsetsv(p,val,info,ilev,pos) use psb_base_mod use mld_d_prec_mod, mld_protect_name => mld_dprecsetsv @@ -746,10 +779,11 @@ subroutine mld_dprecsetsv(p,val,info,ilev) class(mld_d_base_solver_type), intent(in) :: val integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), optional, intent(in) :: ilev - + character(len=*), optional, intent(in) :: pos + ! Local variables - integer(psb_ipk_) :: ilev_, nlev_, ilmin, ilmax - character(len=*), parameter :: name='mld_precseti' + integer(psb_ipk_) :: ilev_, nlev_, ilmin, ilmax, ipos_ + character(len=*), parameter :: name='mld_precseti' info = psb_success_ @@ -772,6 +806,19 @@ subroutine mld_dprecsetsv(p,val,info,ilev) ilmax = nlev_ end if + if (present(pos)) then + select case(psb_toupper(trim(pos))) + case('PRE') + ipos_ = mld_pre_smooth_ + case('POST') + ipos_ = mld_post_smooth_ + case default + ipos_ = mld_pre_smooth_ + end select + else + ipos_ = mld_pre_smooth_ + end if + if ((ilev_<1).or.(ilev_ > nlev_)) then info = -1 @@ -781,16 +828,20 @@ subroutine mld_dprecsetsv(p,val,info,ilev) endif - do ilev_ = ilmin, ilmax - if (allocated(p%precv(ilev_)%sm)) then - if (allocated(p%precv(ilev_)%sm%sv)) then - if (.not.same_type_as(p%precv(ilev_)%sm%sv,val)) then - deallocate(p%precv(ilev_)%sm%sv,stat=info) - if (info /= 0) then - info = 3111 - return + select case(ipos_) + case(mld_pre_smooth_) + do ilev_ = ilmin, ilmax + if (allocated(p%precv(ilev_)%sm)) then + if (allocated(p%precv(ilev_)%sm%sv)) then + if (.not.same_type_as(p%precv(ilev_)%sm%sv,val)) then + deallocate(p%precv(ilev_)%sm%sv,stat=info) + if (info /= 0) then + info = 3111 + return + end if end if end if + if (.not.allocated(p%precv(ilev_)%sm%sv)) then #ifdef HAVE_MOLD allocate(p%precv(ilev_)%sm%sv,mold=val,stat=info) @@ -802,19 +853,55 @@ subroutine mld_dprecsetsv(p,val,info,ilev) return end if end if + call p%precv(ilev_)%sm%sv%default() + else + info = 3111 + write(psb_err_unit,*) name,& + &': Error: uninitialized preconditioner component,',& + &' should call MLD_PRECINIT/MLD_PRECSET' + return + end if - call p%precv(ilev_)%sm%sv%default() - else - info = 3111 - write(psb_err_unit,*) name,& - &': Error: uninitialized preconditioner component,',& - &' should call MLD_PRECINIT/MLD_PRECSET' - return - - end if - - end do + + end do + case(mld_post_smooth_) + do ilev_ = ilmin, ilmax + if (allocated(p%precv(ilev_)%sm2a)) then + if (allocated(p%precv(ilev_)%sm2a%sv)) then + write(0,*)p%precv(ilev_)%sm2a%sv%get_fmt(),val%get_fmt() + if (.not.same_type_as(p%precv(ilev_)%sm2a%sv,val)) then + deallocate(p%precv(ilev_)%sm2a%sv,stat=info) + if (info /= 0) then + info = 3111 + return + end if + end if + end if + if (.not.allocated(p%precv(ilev_)%sm2a%sv)) then +#ifdef HAVE_MOLD + allocate(p%precv(ilev_)%sm2a%sv,mold=val,stat=info) +#else + allocate(p%precv(ilev_)%sm2a%sv,source=val,stat=info) +#endif + if (info /= 0) then + info = 3111 + return + end if + end if + call p%precv(ilev_)%sm2a%sv%default() + write(0,*)p%precv(ilev_)%sm2a%sv%get_fmt(),val%get_fmt() + else + info = 3111 + write(psb_err_unit,*) name,& + &': Error: uninitialized preconditioner component,',& + &' should call MLD_PRECINIT/MLD_PRECSET' + return + + end if + + end do + end select end subroutine mld_dprecsetsv diff --git a/mlprec/mld_d_prec_mod.f90 b/mlprec/mld_d_prec_mod.f90 index a9474b96..dd6195b1 100644 --- a/mlprec/mld_d_prec_mod.f90 +++ b/mlprec/mld_d_prec_mod.f90 @@ -91,72 +91,79 @@ module mld_d_prec_mod contains - subroutine mld_d_iprecsetsm(p,val,info) + subroutine mld_d_iprecsetsm(p,val,info,pos) type(mld_dprec_type), intent(inout) :: p class(mld_d_base_smoother_type), intent(in) :: val integer(psb_ipk_), intent(out) :: info + character(len=*), optional, intent(in) :: pos - call p%set(val,info) + call p%set(val,info,pos=pos) end subroutine mld_d_iprecsetsm - subroutine mld_d_iprecsetsv(p,val,info) + subroutine mld_d_iprecsetsv(p,val,info,pos) type(mld_dprec_type), intent(inout) :: p class(mld_d_base_solver_type), intent(in) :: val integer(psb_ipk_), intent(out) :: info - - call p%set(val,info) + character(len=*), optional, intent(in) :: pos + call p%set(val,info, pos=pos) end subroutine mld_d_iprecsetsv - subroutine mld_d_iprecseti(p,what,val,info) + subroutine mld_d_iprecseti(p,what,val,info,pos) type(mld_dprec_type), intent(inout) :: p integer(psb_ipk_), intent(in) :: what integer(psb_ipk_), intent(in) :: val integer(psb_ipk_), intent(out) :: info + character(len=*), optional, intent(in) :: pos call p%set(what,val,info) end subroutine mld_d_iprecseti - subroutine mld_d_iprecsetr(p,what,val,info) + subroutine mld_d_iprecsetr(p,what,val,info,pos) type(mld_dprec_type), intent(inout) :: p integer(psb_ipk_), intent(in) :: what real(psb_dpk_), intent(in) :: val integer(psb_ipk_), intent(out) :: info + character(len=*), optional, intent(in) :: pos call p%set(what,val,info) end subroutine mld_d_iprecsetr - subroutine mld_d_iprecsetc(p,what,val,info) + subroutine mld_d_iprecsetc(p,what,val,info,pos) type(mld_dprec_type), intent(inout) :: p integer(psb_ipk_), intent(in) :: what character(len=*), intent(in) :: val integer(psb_ipk_), intent(out) :: info + character(len=*), optional, intent(in) :: pos call p%set(what,val,info) end subroutine mld_d_iprecsetc - subroutine mld_d_cprecseti(p,what,val,info) + subroutine mld_d_cprecseti(p,what,val,info,pos) type(mld_dprec_type), intent(inout) :: p character(len=*), intent(in) :: what integer(psb_ipk_), intent(in) :: val integer(psb_ipk_), intent(out) :: info + character(len=*), optional, intent(in) :: pos call p%set(what,val,info) end subroutine mld_d_cprecseti - subroutine mld_d_cprecsetr(p,what,val,info) + subroutine mld_d_cprecsetr(p,what,val,info,pos) type(mld_dprec_type), intent(inout) :: p character(len=*), intent(in) :: what real(psb_dpk_), intent(in) :: val integer(psb_ipk_), intent(out) :: info + character(len=*), optional, intent(in) :: pos call p%set(what,val,info) end subroutine mld_d_cprecsetr - subroutine mld_d_cprecsetc(p,what,val,info) + subroutine mld_d_cprecsetc(p,what,val,info,pos) type(mld_dprec_type), intent(inout) :: p character(len=*), intent(in) :: what character(len=*), intent(in) :: val integer(psb_ipk_), intent(out) :: info + character(len=*), optional, intent(in) :: pos call p%set(what,val,info) end subroutine mld_d_cprecsetc diff --git a/mlprec/mld_d_prec_type.f90 b/mlprec/mld_d_prec_type.f90 index 765f6999..3f5cd081 100644 --- a/mlprec/mld_d_prec_type.f90 +++ b/mlprec/mld_d_prec_type.f90 @@ -175,23 +175,25 @@ module mld_d_prec_type end interface interface - subroutine mld_dprecsetsm(prec,val,info,ilev) + subroutine mld_dprecsetsm(prec,val,info,ilev,pos) import :: psb_dspmat_type, psb_desc_type, psb_dpk_, & & mld_dprec_type, mld_d_base_smoother_type, psb_ipk_ - class(mld_dprec_type), intent(inout) :: prec + class(mld_dprec_type), target, intent(inout) :: prec class(mld_d_base_smoother_type), intent(in) :: val integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), optional, intent(in) :: ilev + character(len=*), optional, intent(in) :: pos end subroutine mld_dprecsetsm - subroutine mld_dprecsetsv(prec,val,info,ilev) + subroutine mld_dprecsetsv(prec,val,info,ilev,pos) import :: psb_dspmat_type, psb_desc_type, psb_dpk_, & & mld_dprec_type, mld_d_base_solver_type, psb_ipk_ class(mld_dprec_type), intent(inout) :: prec class(mld_d_base_solver_type), intent(in) :: val integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), optional, intent(in) :: ilev + character(len=*), optional, intent(in) :: pos end subroutine mld_dprecsetsv - subroutine mld_dprecseti(prec,what,val,info,ilev) + subroutine mld_dprecseti(prec,what,val,info,ilev,pos) import :: psb_dspmat_type, psb_desc_type, psb_dpk_, & & mld_dprec_type, psb_ipk_ class(mld_dprec_type), intent(inout) :: prec @@ -199,8 +201,9 @@ module mld_d_prec_type integer(psb_ipk_), intent(in) :: val integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), optional, intent(in) :: ilev + character(len=*), optional, intent(in) :: pos end subroutine mld_dprecseti - subroutine mld_dprecsetr(prec,what,val,info,ilev) + subroutine mld_dprecsetr(prec,what,val,info,ilev,pos) import :: psb_dspmat_type, psb_desc_type, psb_dpk_, & & mld_dprec_type, psb_ipk_ class(mld_dprec_type), intent(inout) :: prec @@ -208,8 +211,9 @@ module mld_d_prec_type real(psb_dpk_), intent(in) :: val integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), optional, intent(in) :: ilev + character(len=*), optional, intent(in) :: pos end subroutine mld_dprecsetr - subroutine mld_dprecsetc(prec,what,string,info,ilev) + subroutine mld_dprecsetc(prec,what,string,info,ilev,pos) import :: psb_dspmat_type, psb_desc_type, psb_dpk_, & & mld_dprec_type, psb_ipk_ class(mld_dprec_type), intent(inout) :: prec @@ -217,8 +221,9 @@ module mld_d_prec_type character(len=*), intent(in) :: string integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), optional, intent(in) :: ilev + character(len=*), optional, intent(in) :: pos end subroutine mld_dprecsetc - subroutine mld_dcprecseti(prec,what,val,info,ilev) + subroutine mld_dcprecseti(prec,what,val,info,ilev,pos) import :: psb_dspmat_type, psb_desc_type, psb_dpk_, & & mld_dprec_type, psb_ipk_ class(mld_dprec_type), intent(inout) :: prec @@ -226,8 +231,9 @@ module mld_d_prec_type integer(psb_ipk_), intent(in) :: val integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), optional, intent(in) :: ilev + character(len=*), optional, intent(in) :: pos end subroutine mld_dcprecseti - subroutine mld_dcprecsetr(prec,what,val,info,ilev) + subroutine mld_dcprecsetr(prec,what,val,info,ilev,pos) import :: psb_dspmat_type, psb_desc_type, psb_dpk_, & & mld_dprec_type, psb_ipk_ class(mld_dprec_type), intent(inout) :: prec @@ -235,8 +241,9 @@ module mld_d_prec_type real(psb_dpk_), intent(in) :: val integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), optional, intent(in) :: ilev + character(len=*), optional, intent(in) :: pos end subroutine mld_dcprecsetr - subroutine mld_dcprecsetc(prec,what,string,info,ilev) + subroutine mld_dcprecsetc(prec,what,string,info,ilev,pos) import :: psb_dspmat_type, psb_desc_type, psb_dpk_, & & mld_dprec_type, psb_ipk_ class(mld_dprec_type), intent(inout) :: prec @@ -244,6 +251,7 @@ module mld_d_prec_type character(len=*), intent(in) :: string integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), optional, intent(in) :: ilev + character(len=*), optional, intent(in) :: pos end subroutine mld_dcprecsetc end interface @@ -478,6 +486,18 @@ contains write(iout_,*) return end if + if (allocated(p%precv(1)%sm2a)) then + write(iout_,*) 'Post smoother details' + call p%precv(1)%sm2a%descr(info,iout=iout_) + if (nlev == 1) then + if (p%precv(1)%parms%sweeps > 1) then + write(iout_,*) ' Number of smoother sweeps : ',& + & p%precv(1)%parms%sweeps + end if + write(iout_,*) + return + end if + end if end if ! diff --git a/tests/pdegen/Makefile b/tests/pdegen/Makefile index 7bbe3439..66a0b906 100644 --- a/tests/pdegen/Makefile +++ b/tests/pdegen/Makefile @@ -11,12 +11,16 @@ FINCLUDES=$(FMFLAG). $(FMFLAG)$(MLDINCDIR) $(FMFLAG)$(PSBINCDIR) $(FIFLAG). EXEDIR=./runs -all: spde3d ppde3d spde2d ppde2d +all: spde3d ppde3d spde2d ppde2d ppde3d-gs ppde3d: ppde3d.o data_input.o $(F90LINK) ppde3d.o data_input.o -o ppde3d $(MLD_LIB) $(PSBLAS_LIB) $(LDLIBS) /bin/mv ppde3d $(EXEDIR) +ppde3d-gs: ppde3d-gs.o data_input.o + $(F90LINK) ppde3d-gs.o data_input.o -o ppde3d-gs $(MLD_LIB) $(PSBLAS_LIB) $(LDLIBS) + /bin/mv ppde3d-gs $(EXEDIR) + spde3d: spde3d.o data_input.o $(F90LINK) spde3d.o data_input.o -o spde3d $(MLD_LIB) $(PSBLAS_LIB) $(LDLIBS) /bin/mv spde3d $(EXEDIR) @@ -30,15 +34,15 @@ spde2d: spde2d.o data_input.o $(F90LINK) spde2d.o data_input.o -o spde2d $(MLD_LIB) $(PSBLAS_LIB) $(LDLIBS) /bin/mv spde2d $(EXEDIR) -ppde3d.o spde3d.o ppde2d.o spde2d.o: data_input.o +ppde3d-gs.o ppde3d.o spde3d.o ppde2d.o spde2d.o: data_input.o check: all cd runs && ./ppde2d Date: Sun, 8 May 2016 19:41:52 +0000 Subject: [PATCH 04/17] mld2p4-smooth-2side: tests/pdegen/ppde3d-gs.f90 First steps towards separate PRE and POST smoothers. --- tests/pdegen/ppde3d-gs.f90 | 489 +++++++++++++++++++++++++++++++++++++ 1 file changed, 489 insertions(+) create mode 100644 tests/pdegen/ppde3d-gs.f90 diff --git a/tests/pdegen/ppde3d-gs.f90 b/tests/pdegen/ppde3d-gs.f90 new file mode 100644 index 00000000..8cf6a9d4 --- /dev/null +++ b/tests/pdegen/ppde3d-gs.f90 @@ -0,0 +1,489 @@ +!!$ +!!$ +!!$ MLD2P4 version 2.0 +!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package +!!$ based on PSBLAS (Parallel Sparse BLAS version 3.3) +!!$ +!!$ (C) Copyright 2008, 2010, 2012, 2015 +!!$ +!!$ 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: ppde3d.f90 +! +! Program: ppde3d +! This sample program solves a linear system obtained by discretizing a +! PDE with Dirichlet BCs. +! +! +! The PDE is a general second order equation in 3d +! +! a1 dd(u) a2 dd(u) a3 dd(u) b1 d(u) b2 d(u) b3 d(u) +! - ------ - ------ - ------ + ----- + ------ + ------ + c u = f +! dxdx dydy dzdz dx dy dz +! +! with Dirichlet boundary conditions +! u = g +! +! on the unit cube 0<=x,y,z<=1. +! +! +! Note that if b1=b2=b3=c=0., the PDE is the Laplace equation. +! +! In this sample program the index space of the discretized +! computational domain is first numbered sequentially in a standard way, +! then the corresponding vector is distributed according to a BLOCK +! data distribution. +! +module ppde3d_mod +contains + ! + ! functions parametrizing the differential equation + ! + function b1(x,y,z) + use psb_base_mod, only : psb_dpk_ + real(psb_dpk_) :: b1 + real(psb_dpk_), intent(in) :: x,y,z + b1=0.d0/sqrt(3.d0) + end function b1 + function b2(x,y,z) + use psb_base_mod, only : psb_dpk_ + real(psb_dpk_) :: b2 + real(psb_dpk_), intent(in) :: x,y,z + b2=0.d0/sqrt(3.d0) + end function b2 + function b3(x,y,z) + use psb_base_mod, only : psb_dpk_ + real(psb_dpk_) :: b3 + real(psb_dpk_), intent(in) :: x,y,z + b3=0.d0/sqrt(3.d0) + end function b3 + function c(x,y,z) + use psb_base_mod, only : psb_dpk_ + real(psb_dpk_) :: c + real(psb_dpk_), intent(in) :: x,y,z + c=0.d0 + end function c + function a1(x,y,z) + use psb_base_mod, only : psb_dpk_ + real(psb_dpk_) :: a1 + real(psb_dpk_), intent(in) :: x,y,z + a1=1.d0!/80 + end function a1 + function a2(x,y,z) + use psb_base_mod, only : psb_dpk_ + real(psb_dpk_) :: a2 + real(psb_dpk_), intent(in) :: x,y,z + a2=1.d0!/80 + end function a2 + function a3(x,y,z) + use psb_base_mod, only : psb_dpk_ + real(psb_dpk_) :: a3 + real(psb_dpk_), intent(in) :: x,y,z + a3=1.d0!/80 + end function a3 + function g(x,y,z) + use psb_base_mod, only : psb_dpk_, done, dzero + real(psb_dpk_) :: g + real(psb_dpk_), intent(in) :: x,y,z + g = dzero + if (x == done) then + g = done + else if (x == dzero) then + g = exp(y**2-z**2) + end if + end function g +end module ppde3d_mod + +program ppde3d + use psb_base_mod + use mld_prec_mod + use psb_krylov_mod + use psb_util_mod + use data_input + use ppde3d_mod + implicit none + + ! input parameters + character(len=20) :: kmethd, ptype + character(len=5) :: afmt + integer(psb_ipk_) :: idim + + ! miscellaneous + real(psb_dpk_), parameter :: one = 1.d0 + real(psb_dpk_) :: t1, t2, tprec + + ! sparse matrix and preconditioner + type(psb_dspmat_type) :: a + type(mld_dprec_type) :: prec + ! descriptor + type(psb_desc_type) :: desc_a + ! dense vectors + type(psb_d_vect_type) :: x,b + ! parallel environment + integer(psb_ipk_) :: ictxt, iam, np + + ! solver parameters + integer(psb_ipk_) :: iter, itmax,itrace, istopc, irst, nlv + integer(psb_long_int_k_) :: amatsize, precsize, descsize + real(psb_dpk_) :: err, eps + + type precdata + character(len=20) :: descr ! verbose description of the prec + character(len=10) :: prec ! overall prectype + integer(psb_ipk_) :: novr ! number of overlap layers + integer(psb_ipk_) :: jsweeps ! Jacobi/smoother sweeps + character(len=16) :: restr ! restriction over application of as + character(len=16) :: prol ! prolongation over application of as + character(len=16) :: solve ! Solver type: ILU, SuperLU, UMFPACK. + integer(psb_ipk_) :: fill1 ! Fill-in for factorization 1 + integer(psb_ipk_) :: svsweeps ! Solver sweeps for GS + real(psb_dpk_) :: thr1 ! Threshold for fact. 1 ILU(T) + character(len=16) :: smther ! Smoother + integer(psb_ipk_) :: nlev ! Number of levels in multilevel prec. + character(len=16) :: aggrkind ! smoothed/raw aggregatin + 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(psb_ipk_) :: 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. + integer(psb_ipk_) :: cfill ! Fill-in for factorization 1 + real(psb_dpk_) :: cthres ! Threshold for fact. 1 ILU(T) + integer(psb_ipk_) :: cjswp ! Jacobi sweeps + real(psb_dpk_) :: athres ! smoother aggregation threshold + end type precdata + type(precdata) :: prectype + type(psb_d_coo_sparse_mat) :: acoo + type(mld_d_jac_smoother_type) :: dbsmth + type(mld_d_bwgs_solver_type) :: dbwgs + ! other variables + integer(psb_ipk_) :: info, i + character(len=20) :: name,ch_err + + info=psb_success_ + + + call psb_init(ictxt) + call psb_info(ictxt,iam,np) + + if (iam < 0) then + ! This should not happen, but just in case + call psb_exit(ictxt) + stop + endif + if(psb_get_errstatus() /= 0) goto 9999 + name='pde90' + call psb_set_errverbosity(itwo) + ! + ! Hello world + ! + if (iam == psb_root_) then + write(*,*) 'Welcome to MLD2P4 version: ',mld_version_string_ + write(*,*) 'This is the ',trim(name),' sample program' + end if + + ! + ! get parameters + ! + call get_parms(ictxt,kmethd,prectype,afmt,idim,istopc,itmax,itrace,irst,eps) + + ! + ! allocate and fill in the coefficient matrix, rhs and initial guess + ! + + call psb_barrier(ictxt) + t1 = psb_wtime() + call psb_gen_pde3d(ictxt,idim,a,b,x,desc_a,afmt,& + & a1,a2,a3,b1,b2,b3,c,g,info) + call psb_barrier(ictxt) + t2 = psb_wtime() - t1 + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='create_matrix' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + if (iam == psb_root_) & + & write(psb_out_unit,'("Overall matrix creation time : ",es12.5)')t2 + if (iam == psb_root_) & + & write(psb_out_unit,'(" ")') + ! + ! prepare the preconditioner. + ! + if (psb_toupper(prectype%prec) == 'ML') then + nlv = prectype%nlev + call mld_precinit(prec,prectype%prec, info, nlev=nlv) + call mld_precset(prec,'smoother_type', prectype%smther, info) + call mld_precset(prec,'smoother_sweeps', prectype%jsweeps, info) + call mld_precset(prec,'sub_ovr', prectype%novr, info) + call mld_precset(prec,'sub_restr', prectype%restr, info) + call mld_precset(prec,'sub_prol', prectype%prol, info) + call mld_precset(prec,'sub_solve', prectype%solve, info) + call mld_precset(prec,'sub_fillin', prectype%fill1, info) + call mld_precset(prec,'solver_sweeps', prectype%svsweeps, info) + call mld_precset(prec,'sub_iluthrs', prectype%thr1, info) + call mld_precset(prec,'aggr_kind', prectype%aggrkind,info) + call mld_precset(prec,'aggr_alg', prectype%aggr_alg,info) + call mld_precset(prec,'ml_type', prectype%mltype, info) + call mld_precset(prec,'smoother_pos', prectype%smthpos, info) + if (prectype%athres >= dzero) & + & call mld_precset(prec,'aggr_thresh', prectype%athres, info) + call mld_precset(prec,'coarse_solve', prectype%csolve, info) + call mld_precset(prec,'coarse_subsolve', prectype%csbsolve,info) + call mld_precset(prec,'coarse_mat', prectype%cmat, info) + call mld_precset(prec,'coarse_fillin', prectype%cfill, info) + call mld_precset(prec,'coarse_iluthrs', prectype%cthres, info) + call mld_precset(prec,'coarse_sweeps', prectype%cjswp, info) + call mld_precset(prec,'coarse_aggr_size', prectype%csize, info) + call prec%set(dbsmth,info,pos='post') + call prec%set(dbwgs,info,pos='post') + else + nlv = 1 + call mld_precinit(prec,prectype%prec, info, nlev=nlv) + call mld_precset(prec,'smoother_sweeps', prectype%jsweeps, info) + call mld_precset(prec,'sub_ovr', prectype%novr, info) + call mld_precset(prec,'sub_restr', prectype%restr, info) + call mld_precset(prec,'sub_prol', prectype%prol, info) + call mld_precset(prec,'sub_solve', prectype%solve, info) + call mld_precset(prec,'sub_fillin', prectype%fill1, info) + call mld_precset(prec,'solver_sweeps', prectype%svsweeps, info) + call mld_precset(prec,'sub_iluthrs', prectype%thr1, info) + end if + + call psb_barrier(ictxt) + t1 = psb_wtime() + call mld_precbld(a,desc_a,prec,info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_precbld' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + tprec = psb_wtime()-t1 +!!$ call prec%dump(info,prefix='test-ml',ac=.true.,solver=.true.,smoother=.true.) + + call psb_amx(ictxt,tprec) + + if (iam == psb_root_) & + & write(psb_out_unit,'("Preconditioner time : ",es12.5)')tprec + if (iam == psb_root_) call mld_precdescr(prec,info) + if (iam == psb_root_) & + & write(psb_out_unit,'(" ")') + + ! + ! iterative method parameters + ! + if(iam == psb_root_) & + & write(psb_out_unit,'("Calling iterative method ",a)')kmethd + call psb_barrier(ictxt) + t1 = psb_wtime() + call psb_krylov(kmethd,a,prec,b,x,eps,desc_a,info,& + & itmax=itmax,iter=iter,err=err,itrace=itrace,istop=istopc,irst=irst) + + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='solver routine' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + call psb_barrier(ictxt) + t2 = psb_wtime() - t1 + call psb_amx(ictxt,t2) + + amatsize = a%sizeof() + descsize = desc_a%sizeof() + precsize = prec%sizeof() + call psb_sum(ictxt,amatsize) + call psb_sum(ictxt,descsize) + call psb_sum(ictxt,precsize) + if (iam == psb_root_) then + write(psb_out_unit,'(" ")') + write(psb_out_unit,'("Time to solve matrix : ",es12.5)') t2 + write(psb_out_unit,'("Time per iteration : ",es12.5)') t2/iter + write(psb_out_unit,'("Number of iterations : ",i0)') iter + write(psb_out_unit,'("Convergence indicator on exit : ",es12.5)') err + write(psb_out_unit,'("Info on exit : ",i0)') info + write(psb_out_unit,'("Total memory occupation for A: ",i12)') amatsize + write(psb_out_unit,'("Total memory occupation for DESC_A: ",i12)') descsize + write(psb_out_unit,'("Total memory occupation for PREC: ",i12)') precsize + end if + + ! + ! cleanup storage and exit + ! + call psb_gefree(b,desc_a,info) + call psb_gefree(x,desc_a,info) + call psb_spfree(a,desc_a,info) + call mld_precfree(prec,info) + call psb_cdfree(desc_a,info) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='free routine' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + call psb_exit(ictxt) + stop + +9999 continue + call psb_error(ictxt) + +contains + ! + ! get iteration parameters from standard input + ! + subroutine get_parms(ictxt,kmethd,prectype,afmt,idim,istopc,itmax,itrace,irst,eps) + integer(psb_ipk_) :: ictxt + type(precdata) :: prectype + character(len=*) :: kmethd, afmt + integer(psb_ipk_) :: idim, istopc,itmax,itrace,irst + integer(psb_ipk_) :: np, iam, info + real(psb_dpk_) :: eps + character(len=20) :: buffer + + call psb_info(ictxt, iam, np) + + if (iam == psb_root_) then + call read_data(kmethd,psb_inp_unit) + call read_data(afmt,psb_inp_unit) + call read_data(idim,psb_inp_unit) + call read_data(istopc,psb_inp_unit) + call read_data(itmax,psb_inp_unit) + call read_data(itrace,psb_inp_unit) + call read_data(irst,psb_inp_unit) + call read_data(eps,psb_inp_unit) + call read_data(prectype%descr,psb_inp_unit) ! verbose description of the prec + call read_data(prectype%prec,psb_inp_unit) ! overall prectype + call read_data(prectype%novr,psb_inp_unit) ! number of overlap layers + call read_data(prectype%restr,psb_inp_unit) ! restriction over application of as + call read_data(prectype%prol,psb_inp_unit) ! prolongation over application of as + call read_data(prectype%solve,psb_inp_unit) ! Factorization type: ILU, SuperLU, UMFPACK. + call read_data(prectype%svsweeps,psb_inp_unit) ! Solver sweeps + call read_data(prectype%fill1,psb_inp_unit) ! Fill-in for factorization 1 + call read_data(prectype%thr1,psb_inp_unit) ! Threshold for fact. 1 ILU(T) + call read_data(prectype%jsweeps,psb_inp_unit) ! Jacobi sweeps for PJAC + if (psb_toupper(prectype%prec) == 'ML') then + call read_data(prectype%smther,psb_inp_unit) ! Smoother type. + call read_data(prectype%nlev,psb_inp_unit) ! Number of levels in multilevel prec. + call read_data(prectype%aggrkind,psb_inp_unit) ! smoothed/raw aggregatin + call read_data(prectype%aggr_alg,psb_inp_unit) ! local or global aggregation + call read_data(prectype%mltype,psb_inp_unit) ! additive or multiplicative 2nd level prec + call read_data(prectype%smthpos,psb_inp_unit) ! side: pre, post, both smoothing + call read_data(prectype%cmat,psb_inp_unit) ! coarse mat + call read_data(prectype%csolve,psb_inp_unit) ! Factorization type: ILU, SuperLU, UMFPACK. + call read_data(prectype%csbsolve,psb_inp_unit) ! Factorization type: ILU, SuperLU, UMFPACK. + call read_data(prectype%cfill,psb_inp_unit) ! Fill-in for factorization 1 + call read_data(prectype%cthres,psb_inp_unit) ! Threshold for fact. 1 ILU(T) + call read_data(prectype%cjswp,psb_inp_unit) ! Jacobi sweeps + call read_data(prectype%athres,psb_inp_unit) ! smoother aggr thresh + call read_data(prectype%csize,psb_inp_unit) ! coarse size + end if + end if + + ! broadcast parameters to all processors + call psb_bcast(ictxt,kmethd) + call psb_bcast(ictxt,afmt) + call psb_bcast(ictxt,idim) + call psb_bcast(ictxt,istopc) + call psb_bcast(ictxt,itmax) + call psb_bcast(ictxt,itrace) + call psb_bcast(ictxt,irst) + call psb_bcast(ictxt,eps) + + + call psb_bcast(ictxt,prectype%descr) ! verbose description of the prec + call psb_bcast(ictxt,prectype%prec) ! overall prectype + call psb_bcast(ictxt,prectype%novr) ! number of overlap layers + call psb_bcast(ictxt,prectype%restr) ! restriction over application of as + call psb_bcast(ictxt,prectype%prol) ! prolongation over application of as + call psb_bcast(ictxt,prectype%solve) ! Factorization type: ILU, SuperLU, UMFPACK. + call psb_bcast(ictxt,prectype%svsweeps) ! Sweeps for inner GS solver + call psb_bcast(ictxt,prectype%fill1) ! Fill-in for factorization 1 + call psb_bcast(ictxt,prectype%thr1) ! Threshold for fact. 1 ILU(T) + call psb_bcast(ictxt,prectype%jsweeps) ! Jacobi sweeps + if (psb_toupper(prectype%prec) == 'ML') then + call psb_bcast(ictxt,prectype%smther) ! Smoother type. + call psb_bcast(ictxt,prectype%nlev) ! Number of levels in multilevel prec. + call psb_bcast(ictxt,prectype%aggrkind) ! smoothed/raw aggregatin + call psb_bcast(ictxt,prectype%aggr_alg) ! local or global aggregation + call psb_bcast(ictxt,prectype%mltype) ! additive or multiplicative 2nd level prec + call psb_bcast(ictxt,prectype%smthpos) ! side: pre, post, both smoothing + call psb_bcast(ictxt,prectype%cmat) ! coarse mat + call psb_bcast(ictxt,prectype%csolve) ! Factorization type: ILU, SuperLU, UMFPACK. + call psb_bcast(ictxt,prectype%csbsolve) ! Factorization type: ILU, SuperLU, UMFPACK. + call psb_bcast(ictxt,prectype%cfill) ! Fill-in for factorization 1 + 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 + write(psb_out_unit,'("Solving matrix : ell1")') + write(psb_out_unit,'("Grid dimensions : ",i4,"x",i4,"x",i4)')idim,idim,idim + write(psb_out_unit,'("Number of processors : ",i0)') np + write(psb_out_unit,'("Data distribution : BLOCK")') + write(psb_out_unit,'("Preconditioner : ",a)') prectype%descr + write(psb_out_unit,'("Iterative method : ",a)') kmethd + write(psb_out_unit,'(" ")') + endif + + return + + end subroutine get_parms + ! + ! print an error message + ! + subroutine pr_usage(iout) + integer(psb_ipk_) :: iout + write(iout,*)'incorrect parameter(s) found' + write(iout,*)' usage: pde90 methd prec dim & + &[istop itmax itrace]' + write(iout,*)' where:' + write(iout,*)' methd: cgstab cgs rgmres bicgstabl' + write(iout,*)' prec : bjac diag none' + write(iout,*)' dim number of points along each axis' + write(iout,*)' the size of the resulting linear ' + write(iout,*)' system is dim**3' + write(iout,*)' istop stopping criterion 1, 2 ' + write(iout,*)' itmax maximum number of iterations [500] ' + write(iout,*)' itrace <=0 (no tracing, default) or ' + write(iout,*)' >= 1 do tracing every itrace' + write(iout,*)' iterations ' + end subroutine pr_usage + +end program ppde3d + From 55c747465865bc4c6496d19fa8178a7de6c16a30 Mon Sep 17 00:00:00 2001 From: Salvatore Filippone Date: Wed, 11 May 2016 16:58:10 +0000 Subject: [PATCH 05/17] mld2p4-smooth-2side: mlprec/impl/solver/Makefile mlprec/impl/solver/mld_d_bwgs_solver_apply.f90 mlprec/impl/solver/mld_d_bwgs_solver_apply_vect.f90 mlprec/impl/solver/mld_d_bwgs_solver_bld.f90 mlprec/mld_d_gs_solver.f90 tests/pdegen/ppde3d-gs.f90 Further work on 2 sided smoothers. To be tested. --- mlprec/impl/solver/Makefile | 3 + .../impl/solver/mld_d_bwgs_solver_apply.f90 | 196 +++++++++++++++++ .../solver/mld_d_bwgs_solver_apply_vect.f90 | 200 ++++++++++++++++++ mlprec/impl/solver/mld_d_bwgs_solver_bld.f90 | 117 ++++++++++ mlprec/mld_d_gs_solver.f90 | 47 +++- tests/pdegen/ppde3d-gs.f90 | 4 + 6 files changed, 564 insertions(+), 3 deletions(-) create mode 100644 mlprec/impl/solver/mld_d_bwgs_solver_apply.f90 create mode 100644 mlprec/impl/solver/mld_d_bwgs_solver_apply_vect.f90 create mode 100644 mlprec/impl/solver/mld_d_bwgs_solver_bld.f90 diff --git a/mlprec/impl/solver/Makefile b/mlprec/impl/solver/Makefile index 047aff65..4fb01f25 100644 --- a/mlprec/impl/solver/Makefile +++ b/mlprec/impl/solver/Makefile @@ -66,6 +66,9 @@ mld_d_diag_solver_apply_vect.o \ mld_d_diag_solver_bld.o \ mld_d_diag_solver_clone.o \ mld_d_diag_solver_cnv.o \ +mld_d_bwgs_solver_bld.o \ +mld_d_bwgs_solver_apply.o \ +mld_d_bwgs_solver_apply_vect.o \ mld_d_gs_solver_bld.o \ mld_d_gs_solver_clone.o \ mld_d_gs_solver_cnv.o \ diff --git a/mlprec/impl/solver/mld_d_bwgs_solver_apply.f90 b/mlprec/impl/solver/mld_d_bwgs_solver_apply.f90 new file mode 100644 index 00000000..075e4f52 --- /dev/null +++ b/mlprec/impl/solver/mld_d_bwgs_solver_apply.f90 @@ -0,0 +1,196 @@ +!!$ +!!$ +!!$ MLD2P4 version 2.0 +!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package +!!$ based on PSBLAS (Parallel Sparse BLAS version 3.3) +!!$ +!!$ (C) Copyright 2008, 2010, 2012, 2015 +!!$ +!!$ 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. +!!$ +!!$ +subroutine mld_d_bwgs_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info) + + use psb_base_mod + use mld_d_gs_solver, mld_protect_name => mld_d_bwgs_solver_apply + implicit none + type(psb_desc_type), intent(in) :: desc_data + class(mld_d_bwgs_solver_type), intent(inout) :: sv + real(psb_dpk_),intent(inout) :: x(:) + real(psb_dpk_),intent(inout) :: y(:) + real(psb_dpk_),intent(in) :: alpha,beta + character(len=1),intent(in) :: trans + real(psb_dpk_),target, intent(inout) :: work(:) + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: n_row,n_col, itx + real(psb_dpk_), pointer :: ww(:), aux(:), tx(:),ty(:) + real(psb_dpk_), allocatable :: temp(:),wv(:),xit(:) + integer(psb_ipk_) :: ictxt,np,me,i, err_act + character :: trans_ + character(len=20) :: name='d_bwgs_solver_apply' + + call psb_erractionsave(err_act) + ictxt = desc_data%get_ctxt() + call psb_info(ictxt,me,np) + info = psb_success_ + + trans_ = psb_toupper(trans) + select case(trans_) + case('N') +!!$ case('T') +!!$ case('C') + case default + call psb_errpush(psb_err_iarg_invalid_i_,name) + goto 9999 + end select + + n_row = desc_data%get_local_rows() + n_col = desc_data%get_local_cols() + + if (n_col <= size(work)) then + ww => work(1:n_col) + if ((4*n_col+n_col) <= size(work)) then + aux => work(n_col+1:) + else + allocate(aux(4*n_col),stat=info) + if (info /= psb_success_) then + info=psb_err_alloc_request_ + call psb_errpush(info,name,& + & i_err=(/4*n_col,izero,izero,izero,izero/),& + & a_err='real(psb_dpk_)') + goto 9999 + end if + endif + else + allocate(ww(n_col),aux(4*n_col),stat=info) + if (info /= psb_success_) then + info=psb_err_alloc_request_ + call psb_errpush(info,name,& + & i_err=(/5*n_col,izero,izero,izero,izero/),& + & a_err='real(psb_dpk_)') + goto 9999 + end if + endif + + if (info /= psb_success_) then + info=psb_err_alloc_request_ + call psb_errpush(info,name,& + & i_err=(/5*n_col,izero,izero,izero,izero/),& + & a_err='real(psb_dpk_)') + goto 9999 + end if + + call psb_geasb(wv,desc_data,info) + call psb_geasb(xit,desc_data,info) + + select case(trans_) + case('N') + if (sv%eps <=dzero) then + ! + ! Fixed number of iterations + ! + ! + ! WARNING: this is not completely satisfactory. We are assuming here Y + ! as the initial guess, but this is only working if we are called from the + ! current JAC smoother loop. A good solution would be to have a separate + ! input argument as the initial guess + ! +!!$ write(0,*) 'GS Iteration with ',sv%sweeps + call psb_geaxpby(done,y,dzero,xit,desc_data,info) + do itx=1,sv%sweeps + call psb_geaxpby(done,x,dzero,wv,desc_data,info) + ! Update with U. The off-diagonal block is taken care + ! from the Jacobi smoother, hence this is purely local. + call psb_spmm(-done,sv%u,xit,done,wv,desc_data,info,doswap=.false.) + call psb_spsm(done,sv%l,wv,dzero,xit,desc_data,info) +!!$ temp = xit%get_vect() +!!$ write(0,*) me,'GS Iteration ',itx,':',temp(1:n_row) + end do + + call psb_geaxpby(alpha,xit,beta,y,desc_data,info) + + else + ! + ! Iterations to convergence, not implemented right now. + ! + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='EPS>0 not implemented in GS subsolve') + goto 9999 + + end if +!!$ case('T') +!!$ call psb_spsm(done,sv%u,x,dzero,wv,desc_data,info,& +!!$ & trans=trans_,scale='L',diag=sv%dv,choice=psb_none_,work=aux) +!!$ if (info == psb_success_) call psb_spsm(alpha,sv%l,wv,beta,y,desc_data,info,& +!!$ & trans=trans_,scale='U',choice=psb_none_,work=aux) +!!$ +!!$ case('C') +!!$ +!!$ call psb_spsm(done,sv%u,x,dzero,wv,desc_data,info,& +!!$ & trans=trans_,scale='U',choice=psb_none_,work=aux) +!!$ +!!$ call wv1%mlt(done,sv%dv,wv,dzero,info,conjgx=trans_) +!!$ +!!$ if (info == psb_success_) call psb_spsm(alpha,sv%l,wv1,beta,y,desc_data,info,& +!!$ & trans=trans_,scale='U',choice=psb_none_,work=aux) + + case default + info = psb_err_internal_error_ + call psb_errpush(info,name,& + & a_err='Invalid TRANS in GS subsolve') + goto 9999 + end select + + + if (info /= psb_success_) then + + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Error in subsolve') + goto 9999 + endif + + if (n_col <= size(work)) then + if ((4*n_col+n_col) <= size(work)) then + else + deallocate(aux) + endif + else + deallocate(ww,aux) + endif + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine mld_d_bwgs_solver_apply diff --git a/mlprec/impl/solver/mld_d_bwgs_solver_apply_vect.f90 b/mlprec/impl/solver/mld_d_bwgs_solver_apply_vect.f90 new file mode 100644 index 00000000..f0ab056f --- /dev/null +++ b/mlprec/impl/solver/mld_d_bwgs_solver_apply_vect.f90 @@ -0,0 +1,200 @@ +!!$ +!!$ +!!$ MLD2P4 version 2.0 +!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package +!!$ based on PSBLAS (Parallel Sparse BLAS version 3.3) +!!$ +!!$ (C) Copyright 2008, 2010, 2012, 2015 +!!$ +!!$ 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. +!!$ +!!$ +subroutine mld_d_bwgs_solver_apply_vect(alpha,sv,x,beta,y,desc_data,trans,work,info) + + use psb_base_mod + use mld_d_gs_solver, mld_protect_name => mld_d_bwgs_solver_apply_vect + implicit none + type(psb_desc_type), intent(in) :: desc_data + class(mld_d_bwgs_solver_type), intent(inout) :: sv + type(psb_d_vect_type),intent(inout) :: x + type(psb_d_vect_type),intent(inout) :: y + real(psb_dpk_),intent(in) :: alpha,beta + character(len=1),intent(in) :: trans + real(psb_dpk_),target, intent(inout) :: work(:) + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: n_row,n_col, itx + type(psb_d_vect_type) :: wv, xit + real(psb_dpk_), pointer :: ww(:), aux(:), tx(:),ty(:) + real(psb_dpk_), allocatable :: temp(:) + integer(psb_ipk_) :: ictxt,np,me,i, err_act + character :: trans_ + character(len=20) :: name='d_bwgs_solver_apply' + + call psb_erractionsave(err_act) + ictxt = desc_data%get_ctxt() + call psb_info(ictxt,me,np) + info = psb_success_ + + trans_ = psb_toupper(trans) + select case(trans_) + case('N') +!!$ case('T') +!!$ case('C') + case default + call psb_errpush(psb_err_iarg_invalid_i_,name) + goto 9999 + end select + + n_row = desc_data%get_local_rows() + n_col = desc_data%get_local_cols() + + + if (x%get_nrows() < n_row) then + info = 36 + call psb_errpush(info,name,& + & i_err=(/itwo,n_row,izero,izero,izero/)) + goto 9999 + end if + if (y%get_nrows() < n_row) then + info = 36 + call psb_errpush(info,name,& + & i_err=(/ithree,n_row,izero,izero,izero/)) + goto 9999 + end if + + + + if (n_col <= size(work)) then + ww => work(1:n_col) + if ((4*n_col+n_col) <= size(work)) then + aux => work(n_col+1:) + else + allocate(aux(4*n_col),stat=info) + endif + else + allocate(ww(n_col),aux(4*n_col),stat=info) + endif + + if (info /= psb_success_) then + info=psb_err_alloc_request_ + call psb_errpush(info,name,& + & i_err=(/5*n_col,izero,izero,izero,izero/),& + & a_err='real(psb_dpk_)') + goto 9999 + end if + + call psb_geasb(wv,desc_data,info,mold=x%v,scratch=.true.) + call psb_geasb(xit,desc_data,info,mold=x%v,scratch=.true.) + + select case(trans_) + case('N') + if (sv%eps <=dzero) then + ! + ! Fixed number of iterations + ! + ! + ! WARNING: this is not completely satisfactory. We are assuming here Y + ! as the initial guess, but this is only working if we are called from the + ! current JAC smoother loop. A good solution would be to have a separate + ! input argument as the initial guess + ! +!!$ write(0,*) 'GS Iteration with ',sv%sweeps + call psb_geaxpby(done,y,dzero,xit,desc_data,info) + do itx=1,sv%sweeps + call psb_geaxpby(done,x,dzero,wv,desc_data,info) + ! Update with U. The off-diagonal block is taken care + ! from the Jacobi smoother, hence this is purely local. + call psb_spmm(-done,sv%u,xit,done,wv,desc_data,info,doswap=.false.) + call psb_spsm(done,sv%l,wv,dzero,xit,desc_data,info) +!!$ temp = xit%get_vect() +!!$ write(0,*) me,'GS Iteration ',itx,':',temp(1:n_row) + end do + + call psb_geaxpby(alpha,xit,beta,y,desc_data,info) + + else + ! + ! Iterations to convergence, not implemented right now. + ! + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='EPS>0 not implemented in GS subsolve') + goto 9999 + + end if +!!$ case('T') +!!$ call psb_spsm(done,sv%u,x,dzero,wv,desc_data,info,& +!!$ & trans=trans_,scale='L',diag=sv%dv,choice=psb_none_,work=aux) +!!$ if (info == psb_success_) call psb_spsm(alpha,sv%l,wv,beta,y,desc_data,info,& +!!$ & trans=trans_,scale='U',choice=psb_none_,work=aux) +!!$ +!!$ case('C') +!!$ +!!$ call psb_spsm(done,sv%u,x,dzero,wv,desc_data,info,& +!!$ & trans=trans_,scale='U',choice=psb_none_,work=aux) +!!$ +!!$ call wv1%mlt(done,sv%dv,wv,dzero,info,conjgx=trans_) +!!$ +!!$ if (info == psb_success_) call psb_spsm(alpha,sv%l,wv1,beta,y,desc_data,info,& +!!$ & trans=trans_,scale='U',choice=psb_none_,work=aux) + + case default + info = psb_err_internal_error_ + call psb_errpush(info,name,& + & a_err='Invalid TRANS in GS subsolve') + goto 9999 + end select + + + if (info /= psb_success_) then + + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Error in subsolve') + goto 9999 + endif + call wv%free(info) + call xit%free(info) + if (n_col <= size(work)) then + if ((4*n_col+n_col) <= size(work)) then + else + deallocate(aux) + endif + else + deallocate(ww,aux) + endif + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine mld_d_bwgs_solver_apply_vect diff --git a/mlprec/impl/solver/mld_d_bwgs_solver_bld.f90 b/mlprec/impl/solver/mld_d_bwgs_solver_bld.f90 new file mode 100644 index 00000000..7547cd38 --- /dev/null +++ b/mlprec/impl/solver/mld_d_bwgs_solver_bld.f90 @@ -0,0 +1,117 @@ +!!$ +!!$ +!!$ MLD2P4 version 2.0 +!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package +!!$ based on PSBLAS (Parallel Sparse BLAS version 3.3) +!!$ +!!$ (C) Copyright 2008, 2010, 2012, 2015 +!!$ +!!$ 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. +!!$ +!!$ +subroutine mld_d_bwgs_solver_bld(a,desc_a,sv,upd,info,b,amold,vmold,imold) + + use psb_base_mod + use mld_d_gs_solver, mld_protect_name => mld_d_bwgs_solver_bld + + Implicit None + + ! Arguments + type(psb_dspmat_type), intent(in), target :: a + Type(psb_desc_type), Intent(in) :: desc_a + class(mld_d_bwgs_solver_type), intent(inout) :: sv + character, intent(in) :: upd + integer(psb_ipk_), intent(out) :: info + type(psb_dspmat_type), intent(in), target, optional :: b + class(psb_d_base_sparse_mat), intent(in), optional :: amold + class(psb_d_base_vect_type), intent(in), optional :: vmold + class(psb_i_base_vect_type), intent(in), optional :: imold + ! Local variables + integer(psb_ipk_) :: n_row,n_col, nrow_a, nztota + integer(psb_ipk_) :: ictxt,np,me,i, err_act, debug_unit, debug_level + character(len=20) :: name='d_bwgs_solver_bld', ch_err + + 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() + call psb_info(ictxt, me, np) + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),' start' + + + n_row = desc_a%get_local_rows() + + if (psb_toupper(upd) == 'F') then + nrow_a = a%get_nrows() + nztota = a%get_nzeros() +!!$ if (present(b)) then +!!$ nztota = nztota + b%get_nzeros() +!!$ end if + if (sv%eps <= dzero) then + ! + ! This cuts out the off-diagonal part, because it's supposed to + ! be handled by the outer Jacobi smoother. + ! + call a%tril(sv%l,info) + call a%triu(sv%u,info,diag=1,jmax=nrow_a) + + else + + info = psb_err_missing_override_method_ + call psb_errpush(info,name) + goto 9999 + end if + + + + call sv%l%set_asb() + call sv%l%trim() + call sv%u%set_asb() + call sv%u%trim() + + if (present(amold)) then + call sv%l%cscnv(info,mold=amold) + call sv%u%cscnv(info,mold=amold) + end if + + end if + + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),' end' + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return +end subroutine mld_d_bwgs_solver_bld diff --git a/mlprec/mld_d_gs_solver.f90 b/mlprec/mld_d_gs_solver.f90 index 230c5d89..feed37c5 100644 --- a/mlprec/mld_d_gs_solver.f90 +++ b/mlprec/mld_d_gs_solver.f90 @@ -76,9 +76,9 @@ module mld_d_gs_solver type, extends(mld_d_gs_solver_type) :: mld_d_bwgs_solver_type contains -!!$ procedure, pass(sv) :: build => mld_d_bwgs_solver_bld -!!$ procedure, pass(sv) :: apply_v => mld_d_bwgs_solver_apply_vect -!!$ procedure, pass(sv) :: apply_a => mld_d_bwgs_solver_apply + procedure, pass(sv) :: build => mld_d_bwgs_solver_bld + procedure, pass(sv) :: apply_v => mld_d_bwgs_solver_apply_vect + procedure, pass(sv) :: apply_a => mld_d_bwgs_solver_apply procedure, nopass :: get_fmt => d_bwgs_solver_get_fmt procedure, pass(sv) :: descr => d_bwgs_solver_descr end type mld_d_bwgs_solver_type @@ -110,6 +110,19 @@ module mld_d_gs_solver real(psb_dpk_),target, intent(inout) :: work(:) integer(psb_ipk_), intent(out) :: info end subroutine mld_d_gs_solver_apply_vect + subroutine mld_d_bwgs_solver_apply_vect(alpha,sv,x,beta,y,desc_data,trans,work,info) + import :: psb_desc_type, mld_d_bwgs_solver_type, psb_d_vect_type, psb_dpk_, & + & psb_dspmat_type, psb_d_base_sparse_mat, psb_d_base_vect_type, psb_ipk_ + implicit none + type(psb_desc_type), intent(in) :: desc_data + class(mld_d_bwgs_solver_type), intent(inout) :: sv + type(psb_d_vect_type),intent(inout) :: x + type(psb_d_vect_type),intent(inout) :: y + real(psb_dpk_),intent(in) :: alpha,beta + character(len=1),intent(in) :: trans + real(psb_dpk_),target, intent(inout) :: work(:) + integer(psb_ipk_), intent(out) :: info + end subroutine mld_d_bwgs_solver_apply_vect end interface interface @@ -126,6 +139,19 @@ module mld_d_gs_solver real(psb_dpk_),target, intent(inout) :: work(:) integer(psb_ipk_), intent(out) :: info end subroutine mld_d_gs_solver_apply + subroutine mld_d_bwgs_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info) + import :: psb_desc_type, mld_d_bwgs_solver_type, psb_d_vect_type, psb_dpk_, & + & psb_dspmat_type, psb_d_base_sparse_mat, psb_d_base_vect_type, psb_ipk_ + implicit none + type(psb_desc_type), intent(in) :: desc_data + class(mld_d_bwgs_solver_type), intent(inout) :: sv + real(psb_dpk_),intent(inout) :: x(:) + real(psb_dpk_),intent(inout) :: y(:) + real(psb_dpk_),intent(in) :: alpha,beta + character(len=1),intent(in) :: trans + real(psb_dpk_),target, intent(inout) :: work(:) + integer(psb_ipk_), intent(out) :: info + end subroutine mld_d_bwgs_solver_apply end interface interface @@ -144,6 +170,21 @@ module mld_d_gs_solver class(psb_d_base_vect_type), intent(in), optional :: vmold class(psb_i_base_vect_type), intent(in), optional :: imold end subroutine mld_d_gs_solver_bld + subroutine mld_d_bwgs_solver_bld(a,desc_a,sv,upd,info,b,amold,vmold,imold) + import :: psb_desc_type, mld_d_bwgs_solver_type, psb_d_vect_type, psb_dpk_, & + & psb_dspmat_type, psb_d_base_sparse_mat, psb_d_base_vect_type,& + & psb_ipk_, psb_i_base_vect_type + implicit none + type(psb_dspmat_type), intent(in), target :: a + Type(psb_desc_type), Intent(in) :: desc_a + class(mld_d_bwgs_solver_type), intent(inout) :: sv + character, intent(in) :: upd + integer(psb_ipk_), intent(out) :: info + type(psb_dspmat_type), intent(in), target, optional :: b + class(psb_d_base_sparse_mat), intent(in), optional :: amold + class(psb_d_base_vect_type), intent(in), optional :: vmold + class(psb_i_base_vect_type), intent(in), optional :: imold + end subroutine mld_d_bwgs_solver_bld end interface interface diff --git a/tests/pdegen/ppde3d-gs.f90 b/tests/pdegen/ppde3d-gs.f90 index 8cf6a9d4..1374c4b3 100644 --- a/tests/pdegen/ppde3d-gs.f90 +++ b/tests/pdegen/ppde3d-gs.f90 @@ -171,6 +171,7 @@ program ppde3d integer(psb_ipk_) :: nlev ! Number of levels in multilevel prec. character(len=16) :: aggrkind ! smoothed/raw aggregatin character(len=16) :: aggr_alg ! local or global aggregation + character(len=16) :: aggr_ord ! Ordering for aggregation character(len=16) :: mltype ! additive or multiplicative 2nd level prec character(len=16) :: smthpos ! side: pre, post, both smoothing integer(psb_ipk_) :: csize ! aggregation size at which to stop. @@ -255,6 +256,7 @@ program ppde3d call mld_precset(prec,'sub_iluthrs', prectype%thr1, info) call mld_precset(prec,'aggr_kind', prectype%aggrkind,info) call mld_precset(prec,'aggr_alg', prectype%aggr_alg,info) + call mld_precset(prec,'aggr_ord', prectype%aggr_ord,info) call mld_precset(prec,'ml_type', prectype%mltype, info) call mld_precset(prec,'smoother_pos', prectype%smthpos, info) if (prectype%athres >= dzero) & @@ -400,6 +402,7 @@ contains call read_data(prectype%nlev,psb_inp_unit) ! Number of levels in multilevel prec. call read_data(prectype%aggrkind,psb_inp_unit) ! smoothed/raw aggregatin call read_data(prectype%aggr_alg,psb_inp_unit) ! local or global aggregation + call read_data(prectype%aggr_ord,psb_inp_unit) ! aggregation ordering call read_data(prectype%mltype,psb_inp_unit) ! additive or multiplicative 2nd level prec call read_data(prectype%smthpos,psb_inp_unit) ! side: pre, post, both smoothing call read_data(prectype%cmat,psb_inp_unit) ! coarse mat @@ -439,6 +442,7 @@ contains call psb_bcast(ictxt,prectype%nlev) ! Number of levels in multilevel prec. call psb_bcast(ictxt,prectype%aggrkind) ! smoothed/raw aggregatin call psb_bcast(ictxt,prectype%aggr_alg) ! local or global aggregation + call psb_bcast(ictxt,prectype%aggr_ord) ! aggregation ordering call psb_bcast(ictxt,prectype%mltype) ! additive or multiplicative 2nd level prec call psb_bcast(ictxt,prectype%smthpos) ! side: pre, post, both smoothing call psb_bcast(ictxt,prectype%cmat) ! coarse mat From d651141c7d14c4e7e28327df993ec84b42224b9d Mon Sep 17 00:00:00 2001 From: Salvatore Filippone Date: Thu, 12 May 2016 08:22:05 +0000 Subject: [PATCH 06/17] mld2p4-smooth-2side mlprec/impl/mld_dcprecset.F90 mlprec/impl/mld_dprecset.F90 mlprec/mld_base_prec_type.F90 Cosmetic changes in base_prec. Fixed interface in precset. --- mlprec/impl/mld_dcprecset.F90 | 10 ++++++---- mlprec/impl/mld_dprecset.F90 | 9 +++++---- mlprec/mld_base_prec_type.F90 | 18 +++++++++--------- 3 files changed, 20 insertions(+), 17 deletions(-) diff --git a/mlprec/impl/mld_dcprecset.F90 b/mlprec/impl/mld_dcprecset.F90 index 47782d44..48ab7f17 100644 --- a/mlprec/impl/mld_dcprecset.F90 +++ b/mlprec/impl/mld_dcprecset.F90 @@ -76,7 +76,7 @@ ! For this reason, the interface mld_precset to this routine has been built in ! such a way that ilev is not visible to the user (see mld_prec_mod.f90). ! -subroutine mld_dcprecseti(p,what,val,info,ilev) +subroutine mld_dcprecseti(p,what,val,info,ilev,pos) use psb_base_mod use mld_d_prec_mod, mld_protect_name => mld_dcprecseti @@ -108,6 +108,7 @@ subroutine mld_dcprecseti(p,what,val,info,ilev) integer(psb_ipk_), intent(in) :: val integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), optional, intent(in) :: ilev + character(len=*), optional, intent(in) :: pos ! Local variables integer(psb_ipk_) :: ilev_, nlev_ @@ -136,7 +137,6 @@ subroutine mld_dcprecseti(p,what,val,info,ilev) &': Error: invalid ILEV/NLEV combination',ilev_, nlev_ return endif - if (psb_toupper(what) == 'COARSE_AGGR_SIZE') then p%coarse_aggr_size = max(val,-1) return @@ -717,7 +717,7 @@ end subroutine mld_dcprecseti ! For this reason, the interface mld_precset to this routine has been built in ! such a way that ilev is not visible to the user (see mld_prec_mod.f90). ! -subroutine mld_dcprecsetc(p,what,string,info,ilev) +subroutine mld_dcprecsetc(p,what,string,info,ilev,pos) use psb_base_mod use mld_d_prec_mod, mld_protect_name => mld_dcprecsetc @@ -730,6 +730,7 @@ subroutine mld_dcprecsetc(p,what,string,info,ilev) character(len=*), intent(in) :: string integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), optional, intent(in) :: ilev + character(len=*), optional, intent(in) :: pos ! Local variables integer(psb_ipk_) :: ilev_, nlev_,val @@ -804,7 +805,7 @@ end subroutine mld_dcprecsetc ! For this reason, the interface mld_precset to this routine has been built in ! such a way that ilev is not visible to the user (see mld_prec_mod.f90). ! -subroutine mld_dcprecsetr(p,what,val,info,ilev) +subroutine mld_dcprecsetr(p,what,val,info,ilev,pos) use psb_base_mod use mld_d_prec_mod, mld_protect_name => mld_dcprecsetr @@ -817,6 +818,7 @@ subroutine mld_dcprecsetr(p,what,val,info,ilev) real(psb_dpk_), intent(in) :: val integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), optional, intent(in) :: ilev + character(len=*), optional, intent(in) :: pos ! Local variables integer(psb_ipk_) :: ilev_,nlev_ diff --git a/mlprec/impl/mld_dprecset.F90 b/mlprec/impl/mld_dprecset.F90 index 52a5af13..36551520 100644 --- a/mlprec/impl/mld_dprecset.F90 +++ b/mlprec/impl/mld_dprecset.F90 @@ -867,7 +867,6 @@ subroutine mld_dprecsetsv(p,val,info,ilev,pos) do ilev_ = ilmin, ilmax if (allocated(p%precv(ilev_)%sm2a)) then if (allocated(p%precv(ilev_)%sm2a%sv)) then - write(0,*)p%precv(ilev_)%sm2a%sv%get_fmt(),val%get_fmt() if (.not.same_type_as(p%precv(ilev_)%sm2a%sv,val)) then deallocate(p%precv(ilev_)%sm2a%sv,stat=info) if (info /= 0) then @@ -888,7 +887,7 @@ subroutine mld_dprecsetsv(p,val,info,ilev,pos) end if end if call p%precv(ilev_)%sm2a%sv%default() - write(0,*)p%precv(ilev_)%sm2a%sv%get_fmt(),val%get_fmt() + else info = 3111 write(psb_err_unit,*) name,& @@ -943,7 +942,7 @@ end subroutine mld_dprecsetsv ! For this reason, the interface mld_precset to this routine has been built in ! such a way that ilev is not visible to the user (see mld_prec_mod.f90). ! -subroutine mld_dprecsetc(p,what,string,info,ilev) +subroutine mld_dprecsetc(p,what,string,info,ilev,pos) use psb_base_mod use mld_d_prec_mod, mld_protect_name => mld_dprecsetc @@ -956,6 +955,7 @@ subroutine mld_dprecsetc(p,what,string,info,ilev) character(len=*), intent(in) :: string integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), optional, intent(in) :: ilev + character(len=*), optional, intent(in) :: pos ! Local variables integer(psb_ipk_) :: ilev_, nlev_,val @@ -1027,7 +1027,7 @@ end subroutine mld_dprecsetc ! For this reason, the interface mld_precset to this routine has been built in ! such a way that ilev is not visible to the user (see mld_prec_mod.f90). ! -subroutine mld_dprecsetr(p,what,val,info,ilev) +subroutine mld_dprecsetr(p,what,val,info,ilev,pos) use psb_base_mod use mld_d_prec_mod, mld_protect_name => mld_dprecsetr @@ -1040,6 +1040,7 @@ subroutine mld_dprecsetr(p,what,val,info,ilev) real(psb_dpk_), intent(in) :: val integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), optional, intent(in) :: ilev + character(len=*), optional, intent(in) :: pos ! Local variables integer(psb_ipk_) :: ilev_,nlev_ diff --git a/mlprec/mld_base_prec_type.F90 b/mlprec/mld_base_prec_type.F90 index 142c10a1..3459d989 100644 --- a/mlprec/mld_base_prec_type.F90 +++ b/mlprec/mld_base_prec_type.F90 @@ -300,15 +300,15 @@ module mld_base_prec_type ! ! Fields for sparse matrices ensembles stored in av() ! - integer(psb_ipk_), parameter :: mld_l_pr_=1 - integer(psb_ipk_), parameter :: mld_u_pr_=2 - integer(psb_ipk_), parameter :: mld_bp_ilu_avsz_=2 - integer(psb_ipk_), parameter :: mld_ap_nd_=3 - integer(psb_ipk_), parameter :: mld_ac_=4 - integer(psb_ipk_), parameter :: mld_sm_pr_t_=5 - integer(psb_ipk_), parameter :: mld_sm_pr_=6 - integer(psb_ipk_), parameter :: mld_smth_avsz_=6 - integer(psb_ipk_), parameter :: mld_max_avsz_=mld_smth_avsz_ + integer(psb_ipk_), parameter :: mld_l_pr_ = 1 + integer(psb_ipk_), parameter :: mld_u_pr_ = 2 + integer(psb_ipk_), parameter :: mld_bp_ilu_avsz_ = 2 + integer(psb_ipk_), parameter :: mld_ap_nd_ = 3 + integer(psb_ipk_), parameter :: mld_ac_ = 4 + integer(psb_ipk_), parameter :: mld_sm_pr_t_ = 5 + integer(psb_ipk_), parameter :: mld_sm_pr_ = 6 + integer(psb_ipk_), parameter :: mld_smth_avsz_ = 6 + integer(psb_ipk_), parameter :: mld_max_avsz_ = mld_smth_avsz_ ! ! Character constants used by mld_file_prec_descr From d747bc9aae2af876913b62d38cb982a81f131456 Mon Sep 17 00:00:00 2001 From: Salvatore Filippone Date: Thu, 12 May 2016 16:01:28 +0000 Subject: [PATCH 07/17] mld2p4-smooth-2side: mlprec/impl/level/mld_d_base_onelev_csetc.f90 mlprec/impl/level/mld_d_base_onelev_cseti.f90 mlprec/impl/level/mld_d_base_onelev_csetr.f90 mlprec/impl/level/mld_d_base_onelev_setc.f90 mlprec/impl/level/mld_d_base_onelev_seti.f90 mlprec/impl/level/mld_d_base_onelev_setr.f90 mlprec/impl/mld_dcprecset.F90 mlprec/impl/mld_dprecset.F90 mlprec/impl/solver/mld_d_bwgs_solver_apply.f90 mlprec/impl/solver/mld_d_bwgs_solver_apply_vect.f90 mlprec/impl/solver/mld_d_bwgs_solver_bld.f90 mlprec/mld_d_onelev_mod.f90 Defined BW Gauss-Seidel. Need to finish the SET methods before testing on CG. --- mlprec/impl/level/mld_d_base_onelev_csetc.f90 | 5 +- mlprec/impl/level/mld_d_base_onelev_cseti.f90 | 3 +- mlprec/impl/level/mld_d_base_onelev_csetr.f90 | 3 +- mlprec/impl/level/mld_d_base_onelev_setc.f90 | 5 +- mlprec/impl/level/mld_d_base_onelev_seti.f90 | 3 +- mlprec/impl/level/mld_d_base_onelev_setr.f90 | 3 +- mlprec/impl/mld_dcprecset.F90 | 136 +++++++++--------- mlprec/impl/mld_dprecset.F90 | 126 ++++++++-------- .../impl/solver/mld_d_bwgs_solver_apply.f90 | 6 +- .../solver/mld_d_bwgs_solver_apply_vect.f90 | 6 +- mlprec/impl/solver/mld_d_bwgs_solver_bld.f90 | 4 +- mlprec/mld_d_onelev_mod.f90 | 18 ++- 12 files changed, 167 insertions(+), 151 deletions(-) diff --git a/mlprec/impl/level/mld_d_base_onelev_csetc.f90 b/mlprec/impl/level/mld_d_base_onelev_csetc.f90 index c645120c..5af8dcef 100644 --- a/mlprec/impl/level/mld_d_base_onelev_csetc.f90 +++ b/mlprec/impl/level/mld_d_base_onelev_csetc.f90 @@ -36,7 +36,7 @@ !!$ POSSIBILITY OF SUCH DAMAGE. !!$ !!$ -subroutine mld_d_base_onelev_csetc(lv,what,val,info) +subroutine mld_d_base_onelev_csetc(lv,what,val,info,pos) use psb_base_mod use mld_d_onelev_mod, mld_protect_name => mld_d_base_onelev_csetc @@ -48,6 +48,7 @@ subroutine mld_d_base_onelev_csetc(lv,what,val,info) character(len=*), intent(in) :: what character(len=*), intent(in) :: val integer(psb_ipk_), intent(out) :: info + character(len=*), optional, intent(in) :: pos integer(psb_ipk_) :: err_act character(len=20) :: name='d_base_onelev_csetc' integer(psb_ipk_) :: ival @@ -58,7 +59,7 @@ subroutine mld_d_base_onelev_csetc(lv,what,val,info) ival = lv%stringval(val) if (ival >= 0) then - call lv%set(what,ival,info) + call lv%set(what,ival,info,pos=pos) else if (allocated(lv%sm)) then call lv%sm%set(what,val,info) diff --git a/mlprec/impl/level/mld_d_base_onelev_cseti.f90 b/mlprec/impl/level/mld_d_base_onelev_cseti.f90 index a2e3255b..1406df7e 100644 --- a/mlprec/impl/level/mld_d_base_onelev_cseti.f90 +++ b/mlprec/impl/level/mld_d_base_onelev_cseti.f90 @@ -36,7 +36,7 @@ !!$ POSSIBILITY OF SUCH DAMAGE. !!$ !!$ -subroutine mld_d_base_onelev_cseti(lv,what,val,info) +subroutine mld_d_base_onelev_cseti(lv,what,val,info,pos) use psb_base_mod use mld_d_onelev_mod, mld_protect_name => mld_d_base_onelev_cseti @@ -48,6 +48,7 @@ subroutine mld_d_base_onelev_cseti(lv,what,val,info) character(len=*), intent(in) :: what integer(psb_ipk_), intent(in) :: val integer(psb_ipk_), intent(out) :: info + character(len=*), optional, intent(in) :: pos Integer(Psb_ipk_) :: err_act character(len=20) :: name='d_base_onelev_cseti' diff --git a/mlprec/impl/level/mld_d_base_onelev_csetr.f90 b/mlprec/impl/level/mld_d_base_onelev_csetr.f90 index bb35507f..c7cac4fa 100644 --- a/mlprec/impl/level/mld_d_base_onelev_csetr.f90 +++ b/mlprec/impl/level/mld_d_base_onelev_csetr.f90 @@ -36,7 +36,7 @@ !!$ POSSIBILITY OF SUCH DAMAGE. !!$ !!$ -subroutine mld_d_base_onelev_csetr(lv,what,val,info) +subroutine mld_d_base_onelev_csetr(lv,what,val,info,pos) use psb_base_mod use mld_d_onelev_mod, mld_protect_name => mld_d_base_onelev_csetr @@ -48,6 +48,7 @@ subroutine mld_d_base_onelev_csetr(lv,what,val,info) character(len=*), intent(in) :: what real(psb_dpk_), intent(in) :: val integer(psb_ipk_), intent(out) :: info + character(len=*), optional, intent(in) :: pos integer(psb_ipk_) :: err_act character(len=20) :: name='d_base_onelev_csetr' diff --git a/mlprec/impl/level/mld_d_base_onelev_setc.f90 b/mlprec/impl/level/mld_d_base_onelev_setc.f90 index 417dcf78..8ff585cc 100644 --- a/mlprec/impl/level/mld_d_base_onelev_setc.f90 +++ b/mlprec/impl/level/mld_d_base_onelev_setc.f90 @@ -36,7 +36,7 @@ !!$ POSSIBILITY OF SUCH DAMAGE. !!$ !!$ -subroutine mld_d_base_onelev_setc(lv,what,val,info) +subroutine mld_d_base_onelev_setc(lv,what,val,info,pos) use psb_base_mod use mld_d_onelev_mod, mld_protect_name => mld_d_base_onelev_setc @@ -48,6 +48,7 @@ subroutine mld_d_base_onelev_setc(lv,what,val,info) integer(psb_ipk_), intent(in) :: what character(len=*), intent(in) :: val integer(psb_ipk_), intent(out) :: info + character(len=*), optional, intent(in) :: pos integer(psb_ipk_) :: err_act character(len=20) :: name='d_base_onelev_setc' integer(psb_ipk_) :: ival @@ -58,7 +59,7 @@ subroutine mld_d_base_onelev_setc(lv,what,val,info) ival = lv%stringval(val) if (ival >= 0) then - call lv%set(what,ival,info) + call lv%set(what,ival,info,pos=pos) else if (allocated(lv%sm)) then call lv%sm%set(what,val,info) diff --git a/mlprec/impl/level/mld_d_base_onelev_seti.f90 b/mlprec/impl/level/mld_d_base_onelev_seti.f90 index 4e27cbca..e459a58f 100644 --- a/mlprec/impl/level/mld_d_base_onelev_seti.f90 +++ b/mlprec/impl/level/mld_d_base_onelev_seti.f90 @@ -36,7 +36,7 @@ !!$ POSSIBILITY OF SUCH DAMAGE. !!$ !!$ -subroutine mld_d_base_onelev_seti(lv,what,val,info) +subroutine mld_d_base_onelev_seti(lv,what,val,info,pos) use psb_base_mod use mld_d_onelev_mod, mld_protect_name => mld_d_base_onelev_seti @@ -48,6 +48,7 @@ subroutine mld_d_base_onelev_seti(lv,what,val,info) integer(psb_ipk_), intent(in) :: what integer(psb_ipk_), intent(in) :: val integer(psb_ipk_), intent(out) :: info + character(len=*), optional, intent(in) :: pos Integer(Psb_ipk_) :: err_act character(len=20) :: name='d_base_onelev_seti' diff --git a/mlprec/impl/level/mld_d_base_onelev_setr.f90 b/mlprec/impl/level/mld_d_base_onelev_setr.f90 index 8695c9a5..a7fe376f 100644 --- a/mlprec/impl/level/mld_d_base_onelev_setr.f90 +++ b/mlprec/impl/level/mld_d_base_onelev_setr.f90 @@ -36,7 +36,7 @@ !!$ POSSIBILITY OF SUCH DAMAGE. !!$ !!$ -subroutine mld_d_base_onelev_setr(lv,what,val,info) +subroutine mld_d_base_onelev_setr(lv,what,val,info,pos) use psb_base_mod use mld_d_onelev_mod, mld_protect_name => mld_d_base_onelev_setr @@ -48,6 +48,7 @@ subroutine mld_d_base_onelev_setr(lv,what,val,info) integer(psb_ipk_), intent(in) :: what real(psb_dpk_), intent(in) :: val integer(psb_ipk_), intent(out) :: info + character(len=*), optional, intent(in) :: pos integer(psb_ipk_) :: err_act character(len=20) :: name='d_base_onelev_setr' diff --git a/mlprec/impl/mld_dcprecset.F90 b/mlprec/impl/mld_dcprecset.F90 index 48ab7f17..db11961b 100644 --- a/mlprec/impl/mld_dcprecset.F90 +++ b/mlprec/impl/mld_dcprecset.F90 @@ -152,28 +152,28 @@ subroutine mld_dcprecseti(p,what,val,info,ilev,pos) ! select case(psb_toupper(trim(what))) case('SMOOTHER_TYPE') - call onelev_set_smoother(p%precv(ilev_),val,info) + call onelev_set_smoother(p%precv(ilev_),val,info,pos=pos) case('SUB_SOLVE') - call onelev_set_solver(p%precv(ilev_),val,info) + call onelev_set_solver(p%precv(ilev_),val,info,pos=pos) case('SMOOTHER_SWEEPS','ML_TYPE','AGGR_ALG','AGGR_ORD',& & 'AGGR_KIND','SMOOTHER_POS','AGGR_OMEGA_ALG',& & 'AGGR_EIG','SMOOTHER_SWEEPS_PRE',& & 'SMOOTHER_SWEEPS_POST',& & 'SUB_RESTR','SUB_PROL', & & 'SUB_REN','SUB_OVR','SUB_FILLIN') - call p%precv(ilev_)%set(what,val,info) + call p%precv(ilev_)%set(what,val,info,pos=pos) case default - call p%precv(ilev_)%set(what,val,info) + call p%precv(ilev_)%set(what,val,info,pos=pos) end select else if (ilev_ > 1) then select case(psb_toupper(what)) case('SMOOTHER_TYPE') - call onelev_set_smoother(p%precv(ilev_),val,info) + call onelev_set_smoother(p%precv(ilev_),val,info,pos=pos) case('SUB_SOLVE') - call onelev_set_solver(p%precv(ilev_),val,info) + call onelev_set_solver(p%precv(ilev_),val,info,pos=pos) case('SMOOTHER_SWEEPS','ML_TYPE','AGGR_ALG','AGGR_ORD',& & 'AGGR_KIND','SMOOTHER_POS','AGGR_OMEGA_ALG',& & 'AGGR_EIG','SMOOTHER_SWEEPS_PRE',& @@ -181,7 +181,7 @@ subroutine mld_dcprecseti(p,what,val,info,ilev,pos) & 'SUB_RESTR','SUB_PROL', & & 'SUB_REN','SUB_OVR','SUB_FILLIN',& & 'COARSE_MAT') - call p%precv(ilev_)%set(what,val,info) + call p%precv(ilev_)%set(what,val,info,pos=pos) case('COARSE_SUBSOLVE') if (ilev_ /= nlev_) then @@ -190,7 +190,7 @@ subroutine mld_dcprecseti(p,what,val,info,ilev,pos) info = -2 return end if - call onelev_set_solver(p%precv(ilev_),val,info) + call onelev_set_solver(p%precv(ilev_),val,info,pos=pos) case('COARSE_SOLVE') if (ilev_ /= nlev_) then write(psb_err_unit,*) name,& @@ -200,36 +200,36 @@ subroutine mld_dcprecseti(p,what,val,info,ilev,pos) end if if (nlev_ > 1) then - call p%precv(nlev_)%set('COARSE_SOLVE',val,info) + call p%precv(nlev_)%set('COARSE_SOLVE',val,info,pos=pos) select case (val) case(mld_bjac_) - call onelev_set_smoother(p%precv(nlev_),val,info) + call onelev_set_smoother(p%precv(nlev_),val,info,pos=pos) #if defined(HAVE_UMF_) - call onelev_set_solver(p%precv(nlev_),mld_umf_,info) + call onelev_set_solver(p%precv(nlev_),mld_umf_,info,pos=pos) #elif defined(HAVE_SLU_) - call onelev_set_solver(p%precv(nlev_),mld_slu_,info) + call onelev_set_solver(p%precv(nlev_),mld_slu_,info,pos=pos) #elif defined(HAVE_MUMPS_) - call onelev_set_solver(p%precv(nlev_),mld_mumps_,info) + call onelev_set_solver(p%precv(nlev_),mld_mumps_,info,pos=pos) #else - call onelev_set_solver(p%precv(nlev_),mld_ilu_n_,info) + call onelev_set_solver(p%precv(nlev_),mld_ilu_n_,info,pos=pos) #endif - call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info) + call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos) case(mld_umf_, mld_slu_,mld_ilu_n_, mld_ilu_t_,mld_milu_n_) - call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info) - call onelev_set_solver(p%precv(nlev_),val,info) - call p%precv(nlev_)%set('COARSE_MAT',mld_repl_mat_,info) + call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info,pos=pos) + call onelev_set_solver(p%precv(nlev_),val,info,pos=pos) + call p%precv(nlev_)%set('COARSE_MAT',mld_repl_mat_,info,pos=pos) case(mld_sludist_) - call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info) - call onelev_set_solver(p%precv(nlev_),val,info) - call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info) + call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info,pos=pos) + call onelev_set_solver(p%precv(nlev_),val,info,pos=pos) + call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos) case(mld_mumps_) - call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info) - call onelev_set_solver(p%precv(nlev_),val,info) - call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info) + call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info,pos=pos) + call onelev_set_solver(p%precv(nlev_),val,info,pos=pos) + call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos) case(mld_jac_) - call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info) - call onelev_set_solver(p%precv(nlev_),mld_diag_scale_,info) - call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info) + call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info,pos=pos) + call onelev_set_solver(p%precv(nlev_),mld_diag_scale_,info,pos=pos) + call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos) end select endif @@ -240,7 +240,7 @@ subroutine mld_dcprecseti(p,what,val,info,ilev,pos) info = -2 return end if - call p%precv(nlev_)%set('SMOOTHER_SWEEPS',val,info) + call p%precv(nlev_)%set('SMOOTHER_SWEEPS',val,info,pos=pos) case('COARSE_FILLIN') if (ilev_ /= nlev_) then @@ -249,9 +249,9 @@ subroutine mld_dcprecseti(p,what,val,info,ilev,pos) info = -2 return end if - call p%precv(nlev_)%set('SUB_FILLIN',val,info) + call p%precv(nlev_)%set('SUB_FILLIN',val,info,pos=pos) case default - call p%precv(ilev_)%set(what,val,info) + call p%precv(ilev_)%set(what,val,info,pos=pos) end select endif @@ -271,24 +271,24 @@ subroutine mld_dcprecseti(p,what,val,info,ilev,pos) info = -1 return endif - call onelev_set_solver(p%precv(ilev_),val,info) + call onelev_set_solver(p%precv(ilev_),val,info,pos=pos) end do case('SUB_RESTR','SUB_PROL',& & 'SUB_REN','SUB_OVR','SUB_FILLIN') do ilev_=1,max(1,nlev_-1) - call p%precv(ilev_)%set(what,val,info) + call p%precv(ilev_)%set(what,val,info,pos=pos) end do case('SMOOTHER_SWEEPS') do ilev_=1,max(1,nlev_-1) - call p%precv(ilev_)%set(what,val,info) + call p%precv(ilev_)%set(what,val,info,pos=pos) end do case('SMOOTHER_TYPE') do ilev_=1,max(1,nlev_-1) - call onelev_set_smoother(p%precv(ilev_),val,info) + call onelev_set_smoother(p%precv(ilev_),val,info,pos=pos) end do case('ML_TYPE','AGGR_ALG','AGGR_ORD','AGGR_KIND',& @@ -296,69 +296,69 @@ subroutine mld_dcprecseti(p,what,val,info,ilev,pos) & 'SMOOTHER_POS','AGGR_OMEGA_ALG',& & 'AGGR_EIG','AGGR_FILTER') do ilev_=1,nlev_ - call p%precv(ilev_)%set(what,val,info) + call p%precv(ilev_)%set(what,val,info,pos=pos) end do case('COARSE_MAT') if (nlev_ > 1) then - call p%precv(nlev_)%set('COARSE_MAT',val,info) + call p%precv(nlev_)%set('COARSE_MAT',val,info,pos=pos) end if case('COARSE_SOLVE') if (nlev_ > 1) then - call p%precv(nlev_)%set('COARSE_SOLVE',val,info) + call p%precv(nlev_)%set('COARSE_SOLVE',val,info,pos=pos) select case (val) case(mld_bjac_) - call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info) + call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info,pos=pos) #if defined(HAVE_UMF_) - call onelev_set_solver(p%precv(nlev_),mld_umf_,info) + call onelev_set_solver(p%precv(nlev_),mld_umf_,info,pos=pos) #elif defined(HAVE_SLU_) - call onelev_set_solver(p%precv(nlev_),mld_slu_,info) + call onelev_set_solver(p%precv(nlev_),mld_slu_,info,pos=pos) #elif defined(HAVE_MUMPS_) - call onelev_set_solver(p%precv(nlev_),mld_mumps_,info) + call onelev_set_solver(p%precv(nlev_),mld_mumps_,info,pos=pos) #else - call onelev_set_solver(p%precv(nlev_),mld_ilu_n_,info) + call onelev_set_solver(p%precv(nlev_),mld_ilu_n_,info,pos=pos) #endif - call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info) + call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos) case(mld_umf_, mld_slu_,mld_ilu_n_, mld_ilu_t_,mld_milu_n_) - call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info) - call onelev_set_solver(p%precv(nlev_),val,info) - call p%precv(nlev_)%set('COARSE_MAT',mld_repl_mat_,info) + call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info,pos=pos) + call onelev_set_solver(p%precv(nlev_),val,info,pos=pos) + call p%precv(nlev_)%set('COARSE_MAT',mld_repl_mat_,info,pos=pos) case(mld_sludist_) - call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info) - call onelev_set_solver(p%precv(nlev_),val,info) - call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info) + call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info,pos=pos) + call onelev_set_solver(p%precv(nlev_),val,info,pos=pos) + call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos) case(mld_mumps_) - call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info) - call onelev_set_solver(p%precv(nlev_),val,info) - call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info) + call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info,pos=pos) + call onelev_set_solver(p%precv(nlev_),val,info,pos=pos) + call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos) case(mld_jac_) - call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info) - call onelev_set_solver(p%precv(nlev_),mld_diag_scale_,info) - call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info) + call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info,pos=pos) + call onelev_set_solver(p%precv(nlev_),mld_diag_scale_,info,pos=pos) + call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos) end select endif case('COARSE_SUBSOLVE') if (nlev_ > 1) then - call onelev_set_solver(p%precv(nlev_),val,info) + call onelev_set_solver(p%precv(nlev_),val,info,pos=pos) endif case('COARSE_SWEEPS') if (nlev_ > 1) then - call p%precv(nlev_)%set('SMOOTHER_SWEEPS',val,info) + call p%precv(nlev_)%set('SMOOTHER_SWEEPS',val,info,pos=pos) end if case('COARSE_FILLIN') if (nlev_ > 1) then - call p%precv(nlev_)%set('SUB_FILLIN',val,info) + call p%precv(nlev_)%set('SUB_FILLIN',val,info,pos=pos) end if case default do ilev_=1,nlev_ - call p%precv(ilev_)%set(what,val,info) + call p%precv(ilev_)%set(what,val,info,pos=pos) end do end select @@ -366,10 +366,11 @@ subroutine mld_dcprecseti(p,what,val,info,ilev,pos) contains - subroutine onelev_set_smoother(level,val,info) + subroutine onelev_set_smoother(level,val,info,pos) type(mld_d_onelev_type), intent(inout) :: level integer(psb_ipk_), intent(in) :: val integer(psb_ipk_), intent(out) :: info + character(len=*), optional, intent(in) :: pos info = psb_success_ ! @@ -463,10 +464,11 @@ contains end subroutine onelev_set_smoother - subroutine onelev_set_solver(level,val,info) + subroutine onelev_set_solver(level,val,info,pos) type(mld_d_onelev_type), intent(inout) :: level integer(psb_ipk_), intent(in) :: val integer(psb_ipk_), intent(out) :: info + character(len=*), optional, intent(in) :: pos info = psb_success_ ! @@ -759,9 +761,9 @@ subroutine mld_dcprecsetc(p,what,string,info,ilev,pos) val = mld_stringval(string) if (val >=0) then - call p%set(what,val,info,ilev=ilev) + call p%set(what,val,info,ilev=ilev,pos=pos) else - call p%precv(ilev_)%set(what,string,info) + call p%precv(ilev_)%set(what,string,info,pos=pos) end if end subroutine mld_dcprecsetc @@ -855,7 +857,7 @@ subroutine mld_dcprecsetr(p,what,val,info,ilev,pos) ! if (present(ilev)) then - call p%precv(ilev_)%set(what,val,info) + call p%precv(ilev_)%set(what,val,info,pos=pos) else if (.not.present(ilev)) then ! @@ -865,19 +867,19 @@ subroutine mld_dcprecsetr(p,what,val,info,ilev,pos) select case(psb_toupper(what)) case('COARSE_ILUTHRS') ilev_=nlev_ - call p%precv(ilev_)%set('SUB_ILUTHRS',val,info) + call p%precv(ilev_)%set('SUB_ILUTHRS',val,info,pos=pos) case('AGGR_THRESH') thr = val do ilev_ = 2, nlev_ - call p%precv(ilev_)%set('AGGR_THRESH',thr,info) + call p%precv(ilev_)%set('AGGR_THRESH',thr,info,pos=pos) thr = thr * p%precv(ilev_)%parms%aggr_scale end do case default do ilev_=1,nlev_ - call p%precv(ilev_)%set(what,val,info) + call p%precv(ilev_)%set(what,val,info,pos=pos) end do end select diff --git a/mlprec/impl/mld_dprecset.F90 b/mlprec/impl/mld_dprecset.F90 index 36551520..60ae1fd6 100644 --- a/mlprec/impl/mld_dprecset.F90 +++ b/mlprec/impl/mld_dprecset.F90 @@ -153,34 +153,34 @@ subroutine mld_dprecseti(p,what,val,info,ilev,pos) ! select case(what) case(mld_smoother_type_) - call onelev_set_smoother(p%precv(ilev_),val,info) + call onelev_set_smoother(p%precv(ilev_),val,info,pos=pos) case(mld_sub_solve_) - call onelev_set_solver(p%precv(ilev_),val,info) + call onelev_set_solver(p%precv(ilev_),val,info,pos=pos) case(mld_smoother_sweeps_,mld_ml_type_,mld_aggr_alg_,mld_aggr_ord_,& & mld_aggr_kind_,mld_smoother_pos_,mld_aggr_omega_alg_,mld_aggr_eig_,& & mld_smoother_sweeps_pre_,mld_smoother_sweeps_post_,& & mld_sub_restr_,mld_sub_prol_, & & mld_sub_ren_,mld_sub_ovr_,mld_sub_fillin_) - call p%precv(ilev_)%set(what,val,info) + call p%precv(ilev_)%set(what,val,info,pos=pos) case default - call p%precv(ilev_)%set(what,val,info) + call p%precv(ilev_)%set(what,val,info,pos=pos) end select else if (ilev_ > 1) then select case(what) case(mld_smoother_type_) - call onelev_set_smoother(p%precv(ilev_),val,info) + call onelev_set_smoother(p%precv(ilev_),val,info,pos=pos) case(mld_sub_solve_) - call onelev_set_solver(p%precv(ilev_),val,info) + call onelev_set_solver(p%precv(ilev_),val,info,pos=pos) case(mld_smoother_sweeps_,mld_ml_type_,mld_aggr_alg_,mld_aggr_ord_,& & mld_aggr_kind_,mld_smoother_pos_,mld_aggr_omega_alg_,mld_aggr_eig_,& & mld_smoother_sweeps_pre_,mld_smoother_sweeps_post_,& & mld_sub_restr_,mld_sub_prol_, & & mld_sub_ren_,mld_sub_ovr_,mld_sub_fillin_,& & mld_coarse_mat_) - call p%precv(ilev_)%set(what,val,info) + call p%precv(ilev_)%set(what,val,info,pos=pos) case(mld_coarse_subsolve_) if (ilev_ /= nlev_) then @@ -189,7 +189,7 @@ subroutine mld_dprecseti(p,what,val,info,ilev,pos) info = -2 return end if - call onelev_set_solver(p%precv(ilev_),val,info) + call onelev_set_solver(p%precv(ilev_),val,info,pos=pos) case(mld_coarse_solve_) if (ilev_ /= nlev_) then write(psb_err_unit,*) name,& @@ -199,32 +199,32 @@ subroutine mld_dprecseti(p,what,val,info,ilev,pos) end if if (nlev_ > 1) then - call p%precv(nlev_)%set(mld_coarse_solve_,val,info) + call p%precv(nlev_)%set(mld_coarse_solve_,val,info,pos=pos) select case (val) case(mld_bjac_) - call onelev_set_smoother(p%precv(nlev_),val,info) + call onelev_set_smoother(p%precv(nlev_),val,info,pos=pos) #if defined(HAVE_UMF_) - call onelev_set_solver(p%precv(nlev_),mld_umf_,info) + call onelev_set_solver(p%precv(nlev_),mld_umf_,info,pos=pos) #elif defined(HAVE_SLU_) - call onelev_set_solver(p%precv(nlev_),mld_slu_,info) + call onelev_set_solver(p%precv(nlev_),mld_slu_,info,pos=pos) #elif defined(HAVE_MUMPS_) - call onelev_set_solver(p%precv(nlev_),mld_mumps_,info) + call onelev_set_solver(p%precv(nlev_),mld_mumps_,info,pos=pos) #else - call onelev_set_solver(p%precv(nlev_),mld_ilu_n_,info) + call onelev_set_solver(p%precv(nlev_),mld_ilu_n_,info,pos=pos) #endif - call p%precv(nlev_)%set(mld_coarse_mat_,mld_distr_mat_,info) + call p%precv(nlev_)%set(mld_coarse_mat_,mld_distr_mat_,info,pos=pos) case(mld_umf_, mld_slu_,mld_ilu_n_, mld_ilu_t_,mld_milu_n_) - call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info) - call onelev_set_solver(p%precv(nlev_),val,info) - call p%precv(nlev_)%set(mld_coarse_mat_,mld_repl_mat_,info) + call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info,pos=pos) + call onelev_set_solver(p%precv(nlev_),val,info,pos=pos) + call p%precv(nlev_)%set(mld_coarse_mat_,mld_repl_mat_,info,pos=pos) case(mld_sludist_,mld_mumps_) - call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info) - call onelev_set_solver(p%precv(nlev_),val,info) - call p%precv(nlev_)%set(mld_coarse_mat_,mld_distr_mat_,info) + call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info,pos=pos) + call onelev_set_solver(p%precv(nlev_),val,info,pos=pos) + call p%precv(nlev_)%set(mld_coarse_mat_,mld_distr_mat_,info,pos=pos) case(mld_jac_) - call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info) - call onelev_set_solver(p%precv(nlev_),mld_diag_scale_,info) - call p%precv(nlev_)%set(mld_coarse_mat_,mld_distr_mat_,info) + call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info,pos=pos) + call onelev_set_solver(p%precv(nlev_),mld_diag_scale_,info,pos=pos) + call p%precv(nlev_)%set(mld_coarse_mat_,mld_distr_mat_,info,pos=pos) end select endif @@ -235,7 +235,7 @@ subroutine mld_dprecseti(p,what,val,info,ilev,pos) info = -2 return end if - call p%precv(nlev_)%set(mld_smoother_sweeps_,val,info) + call p%precv(nlev_)%set(mld_smoother_sweeps_,val,info,pos=pos) case(mld_coarse_fillin_) if (ilev_ /= nlev_) then @@ -244,9 +244,9 @@ subroutine mld_dprecseti(p,what,val,info,ilev,pos) info = -2 return end if - call p%precv(nlev_)%set(mld_sub_fillin_,val,info) + call p%precv(nlev_)%set(mld_sub_fillin_,val,info,pos=pos) case default - call p%precv(ilev_)%set(what,val,info) + call p%precv(ilev_)%set(what,val,info,pos=pos) end select endif @@ -266,24 +266,24 @@ subroutine mld_dprecseti(p,what,val,info,ilev,pos) info = -1 return endif - call onelev_set_solver(p%precv(ilev_),val,info) + call onelev_set_solver(p%precv(ilev_),val,info,pos=pos) end do case(mld_sub_restr_,mld_sub_prol_,& & mld_sub_ren_,mld_sub_ovr_,mld_sub_fillin_) do ilev_=1,max(1,nlev_-1) - call p%precv(ilev_)%set(what,val,info) + call p%precv(ilev_)%set(what,val,info,pos=pos) end do case(mld_smoother_sweeps_) do ilev_=1,max(1,nlev_-1) - call p%precv(ilev_)%set(what,val,info) + call p%precv(ilev_)%set(what,val,info,pos=pos) end do case(mld_smoother_type_) do ilev_=1,max(1,nlev_-1) - call onelev_set_smoother(p%precv(ilev_),val,info) + call onelev_set_smoother(p%precv(ilev_),val,info,pos=pos) end do case(mld_ml_type_,mld_aggr_alg_,mld_aggr_ord_,mld_aggr_kind_,& @@ -291,67 +291,67 @@ subroutine mld_dprecseti(p,what,val,info,ilev,pos) & mld_smoother_pos_,mld_aggr_omega_alg_,& & mld_aggr_eig_,mld_aggr_filter_) do ilev_=1,nlev_ - call p%precv(ilev_)%set(what,val,info) + call p%precv(ilev_)%set(what,val,info,pos=pos) end do case(mld_coarse_mat_) if (nlev_ > 1) then - call p%precv(nlev_)%set(mld_coarse_mat_,val,info) + call p%precv(nlev_)%set(mld_coarse_mat_,val,info,pos=pos) end if case(mld_coarse_solve_) if (nlev_ > 1) then - call p%precv(nlev_)%set(mld_coarse_solve_,val,info) + call p%precv(nlev_)%set(mld_coarse_solve_,val,info,pos=pos) select case (val) case(mld_bjac_) - call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info) + call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info,pos=pos) #if defined(HAVE_UMF_) - call onelev_set_solver(p%precv(nlev_),mld_umf_,info) + call onelev_set_solver(p%precv(nlev_),mld_umf_,info,pos=pos) #elif defined(HAVE_SLU_) - call onelev_set_solver(p%precv(nlev_),mld_slu_,info) + call onelev_set_solver(p%precv(nlev_),mld_slu_,info,pos=pos) #else - call onelev_set_solver(p%precv(nlev_),mld_ilu_n_,info) + call onelev_set_solver(p%precv(nlev_),mld_ilu_n_,info,pos=pos) #endif - call p%precv(nlev_)%set(mld_coarse_mat_,mld_distr_mat_,info) + call p%precv(nlev_)%set(mld_coarse_mat_,mld_distr_mat_,info,pos=pos) case(mld_umf_, mld_slu_,mld_ilu_n_, mld_ilu_t_,mld_milu_n_) - call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info) - call onelev_set_solver(p%precv(nlev_),val,info) - call p%precv(nlev_)%set(mld_coarse_mat_,mld_repl_mat_,info) + call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info,pos=pos) + call onelev_set_solver(p%precv(nlev_),val,info,pos=pos) + call p%precv(nlev_)%set(mld_coarse_mat_,mld_repl_mat_,info,pos=pos) case(mld_sludist_) - call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info) - call onelev_set_solver(p%precv(nlev_),val,info) - call p%precv(nlev_)%set(mld_coarse_mat_,mld_distr_mat_,info) + call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info,pos=pos) + call onelev_set_solver(p%precv(nlev_),val,info,pos=pos) + call p%precv(nlev_)%set(mld_coarse_mat_,mld_distr_mat_,info,pos=pos) case(mld_mumps_) - call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info) - call onelev_set_solver(p%precv(nlev_),val,info) - call p%precv(nlev_)%set(mld_coarse_mat_,mld_distr_mat_,info) + call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info,pos=pos) + call onelev_set_solver(p%precv(nlev_),val,info,pos=pos) + call p%precv(nlev_)%set(mld_coarse_mat_,mld_distr_mat_,info,pos=pos) case(mld_jac_) - call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info) - call onelev_set_solver(p%precv(nlev_),mld_diag_scale_,info) - call p%precv(nlev_)%set(mld_coarse_mat_,mld_distr_mat_,info) + call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info,pos=pos) + call onelev_set_solver(p%precv(nlev_),mld_diag_scale_,info,pos=pos) + call p%precv(nlev_)%set(mld_coarse_mat_,mld_distr_mat_,info,pos=pos) end select endif case(mld_coarse_subsolve_) if (nlev_ > 1) then - call onelev_set_solver(p%precv(nlev_),val,info) + call onelev_set_solver(p%precv(nlev_),val,info,pos=pos) endif case(mld_coarse_sweeps_) if (nlev_ > 1) then - call p%precv(nlev_)%set(mld_smoother_sweeps_,val,info) + call p%precv(nlev_)%set(mld_smoother_sweeps_,val,info,pos=pos) end if case(mld_coarse_fillin_) if (nlev_ > 1) then - call p%precv(nlev_)%set(mld_sub_fillin_,val,info) + call p%precv(nlev_)%set(mld_sub_fillin_,val,info,pos=pos) end if case default do ilev_=1,nlev_ - call p%precv(ilev_)%set(what,val,info) + call p%precv(ilev_)%set(what,val,info,pos=pos) end do end select @@ -359,10 +359,11 @@ subroutine mld_dprecseti(p,what,val,info,ilev,pos) contains - subroutine onelev_set_smoother(level,val,info) + subroutine onelev_set_smoother(level,val,info,pos) type(mld_d_onelev_type), intent(inout) :: level integer(psb_ipk_), intent(in) :: val integer(psb_ipk_), intent(out) :: info + character(len=*), optional, intent(in) :: pos info = psb_success_ ! @@ -456,10 +457,11 @@ contains end subroutine onelev_set_smoother - subroutine onelev_set_solver(level,val,info) + subroutine onelev_set_solver(level,val,info,pos) type(mld_d_onelev_type), intent(inout) :: level integer(psb_ipk_), intent(in) :: val integer(psb_ipk_), intent(out) :: info + character(len=*), optional, intent(in) :: pos info = psb_success_ ! @@ -983,7 +985,7 @@ subroutine mld_dprecsetc(p,what,string,info,ilev,pos) endif val = mld_stringval(string) - if (val >=0) call p%set(what,val,info,ilev=ilev) + if (val >=0) call p%set(what,val,info,ilev=ilev,pos=pos) end subroutine mld_dprecsetc @@ -1077,7 +1079,7 @@ subroutine mld_dprecsetr(p,what,val,info,ilev,pos) ! if (present(ilev)) then - call p%precv(ilev_)%set(what,val,info) + call p%precv(ilev_)%set(what,val,info,pos=pos) else if (.not.present(ilev)) then ! @@ -1087,19 +1089,19 @@ subroutine mld_dprecsetr(p,what,val,info,ilev,pos) select case(what) case(mld_coarse_iluthrs_) ilev_=nlev_ - call p%precv(ilev_)%set(mld_sub_iluthrs_,val,info) + call p%precv(ilev_)%set(mld_sub_iluthrs_,val,info,pos=pos) case(mld_aggr_thresh_) thr = val do ilev_ = 2, nlev_ - call p%precv(ilev_)%set(mld_aggr_thresh_,thr,info) + call p%precv(ilev_)%set(mld_aggr_thresh_,thr,info,pos=pos) thr = thr * p%precv(ilev_)%parms%aggr_scale end do case default do ilev_=1,nlev_ - call p%precv(ilev_)%set(what,val,info) + call p%precv(ilev_)%set(what,val,info,pos=pos) end do end select diff --git a/mlprec/impl/solver/mld_d_bwgs_solver_apply.f90 b/mlprec/impl/solver/mld_d_bwgs_solver_apply.f90 index 075e4f52..408f4a31 100644 --- a/mlprec/impl/solver/mld_d_bwgs_solver_apply.f90 +++ b/mlprec/impl/solver/mld_d_bwgs_solver_apply.f90 @@ -127,10 +127,10 @@ subroutine mld_d_bwgs_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info) call psb_geaxpby(done,y,dzero,xit,desc_data,info) do itx=1,sv%sweeps call psb_geaxpby(done,x,dzero,wv,desc_data,info) - ! Update with U. The off-diagonal block is taken care + ! Update with L. The off-diagonal block is taken care ! from the Jacobi smoother, hence this is purely local. - call psb_spmm(-done,sv%u,xit,done,wv,desc_data,info,doswap=.false.) - call psb_spsm(done,sv%l,wv,dzero,xit,desc_data,info) + call psb_spmm(-done,sv%l,xit,done,wv,desc_data,info,doswap=.false.) + call psb_spsm(done,sv%u,wv,dzero,xit,desc_data,info) !!$ temp = xit%get_vect() !!$ write(0,*) me,'GS Iteration ',itx,':',temp(1:n_row) end do diff --git a/mlprec/impl/solver/mld_d_bwgs_solver_apply_vect.f90 b/mlprec/impl/solver/mld_d_bwgs_solver_apply_vect.f90 index f0ab056f..6ec2ca50 100644 --- a/mlprec/impl/solver/mld_d_bwgs_solver_apply_vect.f90 +++ b/mlprec/impl/solver/mld_d_bwgs_solver_apply_vect.f90 @@ -130,10 +130,10 @@ subroutine mld_d_bwgs_solver_apply_vect(alpha,sv,x,beta,y,desc_data,trans,work,i call psb_geaxpby(done,y,dzero,xit,desc_data,info) do itx=1,sv%sweeps call psb_geaxpby(done,x,dzero,wv,desc_data,info) - ! Update with U. The off-diagonal block is taken care + ! Update with L. The off-diagonal block is taken care ! from the Jacobi smoother, hence this is purely local. - call psb_spmm(-done,sv%u,xit,done,wv,desc_data,info,doswap=.false.) - call psb_spsm(done,sv%l,wv,dzero,xit,desc_data,info) + call psb_spmm(-done,sv%l,xit,done,wv,desc_data,info,doswap=.false.) + call psb_spsm(done,sv%u,wv,dzero,xit,desc_data,info) !!$ temp = xit%get_vect() !!$ write(0,*) me,'GS Iteration ',itx,':',temp(1:n_row) end do diff --git a/mlprec/impl/solver/mld_d_bwgs_solver_bld.f90 b/mlprec/impl/solver/mld_d_bwgs_solver_bld.f90 index 7547cd38..569eb35a 100644 --- a/mlprec/impl/solver/mld_d_bwgs_solver_bld.f90 +++ b/mlprec/impl/solver/mld_d_bwgs_solver_bld.f90 @@ -81,8 +81,8 @@ subroutine mld_d_bwgs_solver_bld(a,desc_a,sv,upd,info,b,amold,vmold,imold) ! This cuts out the off-diagonal part, because it's supposed to ! be handled by the outer Jacobi smoother. ! - call a%tril(sv%l,info) - call a%triu(sv%u,info,diag=1,jmax=nrow_a) + call a%tril(sv%l,info,diag=-1) + call a%triu(sv%u,info,jmax=nrow_a) else diff --git a/mlprec/mld_d_onelev_mod.f90 b/mlprec/mld_d_onelev_mod.f90 index fe7a29c8..82d8575a 100644 --- a/mlprec/mld_d_onelev_mod.f90 +++ b/mlprec/mld_d_onelev_mod.f90 @@ -214,7 +214,7 @@ module mld_d_onelev_mod end interface interface - subroutine mld_d_base_onelev_seti(lv,what,val,info) + subroutine mld_d_base_onelev_seti(lv,what,val,info,pos) import :: psb_dspmat_type, psb_d_vect_type, psb_d_base_vect_type, & & psb_dlinmap_type, psb_dpk_, mld_d_onelev_type, & & psb_ipk_, psb_long_int_k_, psb_desc_type @@ -225,11 +225,12 @@ module mld_d_onelev_mod integer(psb_ipk_), intent(in) :: what integer(psb_ipk_), intent(in) :: val integer(psb_ipk_), intent(out) :: info + character(len=*), optional, intent(in) :: pos end subroutine mld_d_base_onelev_seti end interface interface - subroutine mld_d_base_onelev_setc(lv,what,val,info) + subroutine mld_d_base_onelev_setc(lv,what,val,info,pos) import :: psb_dspmat_type, psb_d_vect_type, psb_d_base_vect_type, & & psb_dlinmap_type, psb_dpk_, mld_d_onelev_type, & & psb_ipk_, psb_long_int_k_, psb_desc_type @@ -239,11 +240,12 @@ module mld_d_onelev_mod integer(psb_ipk_), intent(in) :: what character(len=*), intent(in) :: val integer(psb_ipk_), intent(out) :: info + character(len=*), optional, intent(in) :: pos end subroutine mld_d_base_onelev_setc end interface interface - subroutine mld_d_base_onelev_setr(lv,what,val,info) + subroutine mld_d_base_onelev_setr(lv,what,val,info,pos) import :: psb_dspmat_type, psb_d_vect_type, psb_d_base_vect_type, & & psb_dlinmap_type, psb_dpk_, mld_d_onelev_type, & & psb_ipk_, psb_long_int_k_, psb_desc_type @@ -253,12 +255,13 @@ module mld_d_onelev_mod integer(psb_ipk_), intent(in) :: what real(psb_dpk_), intent(in) :: val integer(psb_ipk_), intent(out) :: info + character(len=*), optional, intent(in) :: pos end subroutine mld_d_base_onelev_setr end interface interface - subroutine mld_d_base_onelev_cseti(lv,what,val,info) + subroutine mld_d_base_onelev_cseti(lv,what,val,info,pos) import :: psb_dspmat_type, psb_d_vect_type, psb_d_base_vect_type, & & psb_dlinmap_type, psb_dpk_, mld_d_onelev_type, & & psb_ipk_, psb_long_int_k_, psb_desc_type @@ -269,11 +272,12 @@ module mld_d_onelev_mod character(len=*), intent(in) :: what integer(psb_ipk_), intent(in) :: val integer(psb_ipk_), intent(out) :: info + character(len=*), optional, intent(in) :: pos end subroutine mld_d_base_onelev_cseti end interface interface - subroutine mld_d_base_onelev_csetc(lv,what,val,info) + subroutine mld_d_base_onelev_csetc(lv,what,val,info,pos) import :: psb_dspmat_type, psb_d_vect_type, psb_d_base_vect_type, & & psb_dlinmap_type, psb_dpk_, mld_d_onelev_type, & & psb_ipk_, psb_long_int_k_, psb_desc_type @@ -283,11 +287,12 @@ module mld_d_onelev_mod character(len=*), intent(in) :: what character(len=*), intent(in) :: val integer(psb_ipk_), intent(out) :: info + character(len=*), optional, intent(in) :: pos end subroutine mld_d_base_onelev_csetc end interface interface - subroutine mld_d_base_onelev_csetr(lv,what,val,info) + subroutine mld_d_base_onelev_csetr(lv,what,val,info,pos) import :: psb_dspmat_type, psb_d_vect_type, psb_d_base_vect_type, & & psb_dlinmap_type, psb_dpk_, mld_d_onelev_type, & & psb_ipk_, psb_long_int_k_, psb_desc_type @@ -297,6 +302,7 @@ module mld_d_onelev_mod character(len=*), intent(in) :: what real(psb_dpk_), intent(in) :: val integer(psb_ipk_), intent(out) :: info + character(len=*), optional, intent(in) :: pos end subroutine mld_d_base_onelev_csetr end interface From e08492cdaf2a5735ce2f13829c613820715ab660 Mon Sep 17 00:00:00 2001 From: Salvatore Filippone Date: Fri, 13 May 2016 14:47:17 +0000 Subject: [PATCH 08/17] mld2p4-smooth-2side: mlprec/impl/level/mld_d_base_onelev_csetc.f90 mlprec/impl/level/mld_d_base_onelev_cseti.f90 mlprec/impl/level/mld_d_base_onelev_csetr.f90 mlprec/impl/level/mld_d_base_onelev_setc.f90 mlprec/impl/level/mld_d_base_onelev_seti.f90 mlprec/impl/level/mld_d_base_onelev_setr.f90 mlprec/impl/mld_dcprecset.F90 mlprec/impl/mld_dprecset.F90 mlprec/mld_d_prec_mod.f90 tests/pdegen/ppde3d-gs.f90 tests/pdegen/runs/ppde.inp SET now works; next step will be some refactoring. Note: the symmetrized ML for CG with FW/BW Gauss-Seidel does not seem to work right now. --- mlprec/impl/level/mld_d_base_onelev_csetc.f90 | 31 +- mlprec/impl/level/mld_d_base_onelev_cseti.f90 | 33 +- mlprec/impl/level/mld_d_base_onelev_csetr.f90 | 30 +- mlprec/impl/level/mld_d_base_onelev_setc.f90 | 30 +- mlprec/impl/level/mld_d_base_onelev_seti.f90 | 31 +- mlprec/impl/level/mld_d_base_onelev_setr.f90 | 30 +- mlprec/impl/mld_dcprecset.F90 | 340 +++++++------ mlprec/impl/mld_dprecset.F90 | 462 ++++++++++-------- mlprec/mld_d_prec_mod.f90 | 12 +- tests/pdegen/ppde3d-gs.f90 | 4 + tests/pdegen/runs/ppde.inp | 12 +- 11 files changed, 648 insertions(+), 367 deletions(-) diff --git a/mlprec/impl/level/mld_d_base_onelev_csetc.f90 b/mlprec/impl/level/mld_d_base_onelev_csetc.f90 index 5af8dcef..46c47d6a 100644 --- a/mlprec/impl/level/mld_d_base_onelev_csetc.f90 +++ b/mlprec/impl/level/mld_d_base_onelev_csetc.f90 @@ -49,7 +49,8 @@ subroutine mld_d_base_onelev_csetc(lv,what,val,info,pos) character(len=*), intent(in) :: val integer(psb_ipk_), intent(out) :: info character(len=*), optional, intent(in) :: pos - integer(psb_ipk_) :: err_act + ! Local + integer(psb_ipk_) :: ipos_, err_act character(len=20) :: name='d_base_onelev_csetc' integer(psb_ipk_) :: ival @@ -61,9 +62,33 @@ subroutine mld_d_base_onelev_csetc(lv,what,val,info,pos) if (ival >= 0) then call lv%set(what,ival,info,pos=pos) else - if (allocated(lv%sm)) then - call lv%sm%set(what,val,info) + + if (present(pos)) then + select case(psb_toupper(trim(pos))) + case('PRE') + ipos_ = mld_pre_smooth_ + case('POST') + ipos_ = mld_post_smooth_ + case default + ipos_ = mld_pre_smooth_ + end select + else + ipos_ = mld_pre_smooth_ end if + select case(ipos_) + case(mld_pre_smooth_) + if (allocated(lv%sm)) then + call lv%sm%set(what,val,info) + end if + case (mld_post_smooth_) + if (allocated(lv%sm2a)) then + call lv%sm2a%set(what,val,info) + end if + case default + ! Impossible!! + info = psb_err_internal_error_ + end select + end if diff --git a/mlprec/impl/level/mld_d_base_onelev_cseti.f90 b/mlprec/impl/level/mld_d_base_onelev_cseti.f90 index 1406df7e..d23edb64 100644 --- a/mlprec/impl/level/mld_d_base_onelev_cseti.f90 +++ b/mlprec/impl/level/mld_d_base_onelev_cseti.f90 @@ -49,12 +49,26 @@ subroutine mld_d_base_onelev_cseti(lv,what,val,info,pos) integer(psb_ipk_), intent(in) :: val integer(psb_ipk_), intent(out) :: info character(len=*), optional, intent(in) :: pos - Integer(Psb_ipk_) :: err_act + ! Local + integer(psb_ipk_) :: ipos_, err_act character(len=20) :: name='d_base_onelev_cseti' call psb_erractionsave(err_act) info = psb_success_ + if (present(pos)) then + select case(psb_toupper(trim(pos))) + case('PRE') + ipos_ = mld_pre_smooth_ + case('POST') + ipos_ = mld_post_smooth_ + case default + ipos_ = mld_pre_smooth_ + end select + else + ipos_ = mld_pre_smooth_ + end if + select case (psb_toupper(what)) case ('SMOOTHER_SWEEPS') @@ -99,9 +113,20 @@ subroutine mld_d_base_onelev_cseti(lv,what,val,info,pos) lv%parms%coarse_solve = val case default - if (allocated(lv%sm)) then - call lv%sm%set(what,val,info) - end if + select case(ipos_) + case(mld_pre_smooth_) + if (allocated(lv%sm)) then + call lv%sm%set(what,val,info) + end if + case (mld_post_smooth_) + if (allocated(lv%sm2a)) then + call lv%sm2a%set(what,val,info) + end if + case default + ! Impossible!! + info = psb_err_internal_error_ + end select + end select if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) diff --git a/mlprec/impl/level/mld_d_base_onelev_csetr.f90 b/mlprec/impl/level/mld_d_base_onelev_csetr.f90 index c7cac4fa..04961850 100644 --- a/mlprec/impl/level/mld_d_base_onelev_csetr.f90 +++ b/mlprec/impl/level/mld_d_base_onelev_csetr.f90 @@ -49,7 +49,8 @@ subroutine mld_d_base_onelev_csetr(lv,what,val,info,pos) real(psb_dpk_), intent(in) :: val integer(psb_ipk_), intent(out) :: info character(len=*), optional, intent(in) :: pos - integer(psb_ipk_) :: err_act + ! Local + integer(psb_ipk_) :: ipos_, err_act character(len=20) :: name='d_base_onelev_csetr' call psb_erractionsave(err_act) @@ -69,9 +70,32 @@ subroutine mld_d_base_onelev_csetr(lv,what,val,info,pos) lv%parms%aggr_scale = val case default - if (allocated(lv%sm)) then - call lv%sm%set(what,val,info) + + if (present(pos)) then + select case(psb_toupper(trim(pos))) + case('PRE') + ipos_ = mld_pre_smooth_ + case('POST') + ipos_ = mld_post_smooth_ + case default + ipos_ = mld_pre_smooth_ + end select + else + ipos_ = mld_pre_smooth_ end if + select case(ipos_) + case(mld_pre_smooth_) + if (allocated(lv%sm)) then + call lv%sm%set(what,val,info) + end if + case (mld_post_smooth_) + if (allocated(lv%sm2a)) then + call lv%sm2a%set(what,val,info) + end if + case default + ! Impossible!! + info = psb_err_internal_error_ + end select end select if (info /= psb_success_) goto 9999 diff --git a/mlprec/impl/level/mld_d_base_onelev_setc.f90 b/mlprec/impl/level/mld_d_base_onelev_setc.f90 index 8ff585cc..21a7d78f 100644 --- a/mlprec/impl/level/mld_d_base_onelev_setc.f90 +++ b/mlprec/impl/level/mld_d_base_onelev_setc.f90 @@ -49,7 +49,8 @@ subroutine mld_d_base_onelev_setc(lv,what,val,info,pos) character(len=*), intent(in) :: val integer(psb_ipk_), intent(out) :: info character(len=*), optional, intent(in) :: pos - integer(psb_ipk_) :: err_act + ! Local + integer(psb_ipk_) :: ipos_, err_act character(len=20) :: name='d_base_onelev_setc' integer(psb_ipk_) :: ival @@ -61,9 +62,32 @@ subroutine mld_d_base_onelev_setc(lv,what,val,info,pos) if (ival >= 0) then call lv%set(what,ival,info,pos=pos) else - if (allocated(lv%sm)) then - call lv%sm%set(what,val,info) + + if (present(pos)) then + select case(psb_toupper(trim(pos))) + case('PRE') + ipos_ = mld_pre_smooth_ + case('POST') + ipos_ = mld_post_smooth_ + case default + ipos_ = mld_pre_smooth_ + end select + else + ipos_ = mld_pre_smooth_ end if + select case(ipos_) + case(mld_pre_smooth_) + if (allocated(lv%sm)) then + call lv%sm%set(what,val,info) + end if + case (mld_post_smooth_) + if (allocated(lv%sm2a)) then + call lv%sm2a%set(what,val,info) + end if + case default + ! Impossible!! + info = psb_err_internal_error_ + end select end if diff --git a/mlprec/impl/level/mld_d_base_onelev_seti.f90 b/mlprec/impl/level/mld_d_base_onelev_seti.f90 index e459a58f..e181b8f0 100644 --- a/mlprec/impl/level/mld_d_base_onelev_seti.f90 +++ b/mlprec/impl/level/mld_d_base_onelev_seti.f90 @@ -49,7 +49,8 @@ subroutine mld_d_base_onelev_seti(lv,what,val,info,pos) integer(psb_ipk_), intent(in) :: val integer(psb_ipk_), intent(out) :: info character(len=*), optional, intent(in) :: pos - Integer(Psb_ipk_) :: err_act + ! Local + integer(psb_ipk_) :: ipos_, err_act character(len=20) :: name='d_base_onelev_seti' call psb_erractionsave(err_act) @@ -99,9 +100,33 @@ subroutine mld_d_base_onelev_seti(lv,what,val,info,pos) lv%parms%coarse_solve = val case default - if (allocated(lv%sm)) then - call lv%sm%set(what,val,info) + + if (present(pos)) then + select case(psb_toupper(trim(pos))) + case('PRE') + ipos_ = mld_pre_smooth_ + case('POST') + ipos_ = mld_post_smooth_ + case default + ipos_ = mld_pre_smooth_ + end select + else + ipos_ = mld_pre_smooth_ end if + select case(ipos_) + case(mld_pre_smooth_) + if (allocated(lv%sm)) then + call lv%sm%set(what,val,info) + end if + case (mld_post_smooth_) + if (allocated(lv%sm2a)) then + call lv%sm2a%set(what,val,info) + end if + case default + ! Impossible!! + info = psb_err_internal_error_ + end select + end select if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) diff --git a/mlprec/impl/level/mld_d_base_onelev_setr.f90 b/mlprec/impl/level/mld_d_base_onelev_setr.f90 index a7fe376f..788e7319 100644 --- a/mlprec/impl/level/mld_d_base_onelev_setr.f90 +++ b/mlprec/impl/level/mld_d_base_onelev_setr.f90 @@ -49,7 +49,8 @@ subroutine mld_d_base_onelev_setr(lv,what,val,info,pos) real(psb_dpk_), intent(in) :: val integer(psb_ipk_), intent(out) :: info character(len=*), optional, intent(in) :: pos - integer(psb_ipk_) :: err_act + ! Local + integer(psb_ipk_) :: ipos_, err_act character(len=20) :: name='d_base_onelev_setr' call psb_erractionsave(err_act) @@ -69,9 +70,32 @@ subroutine mld_d_base_onelev_setr(lv,what,val,info,pos) lv%parms%aggr_scale = val case default - if (allocated(lv%sm)) then - call lv%sm%set(what,val,info) + + if (present(pos)) then + select case(psb_toupper(trim(pos))) + case('PRE') + ipos_ = mld_pre_smooth_ + case('POST') + ipos_ = mld_post_smooth_ + case default + ipos_ = mld_pre_smooth_ + end select + else + ipos_ = mld_pre_smooth_ end if + select case(ipos_) + case(mld_pre_smooth_) + if (allocated(lv%sm)) then + call lv%sm%set(what,val,info) + end if + case (mld_post_smooth_) + if (allocated(lv%sm2a)) then + call lv%sm2a%set(what,val,info) + end if + case default + ! Impossible!! + info = psb_err_internal_error_ + end select end select if (info /= psb_success_) goto 9999 diff --git a/mlprec/impl/mld_dcprecset.F90 b/mlprec/impl/mld_dcprecset.F90 index db11961b..825220ff 100644 --- a/mlprec/impl/mld_dcprecset.F90 +++ b/mlprec/impl/mld_dcprecset.F90 @@ -108,7 +108,7 @@ subroutine mld_dcprecseti(p,what,val,info,ilev,pos) integer(psb_ipk_), intent(in) :: val integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), optional, intent(in) :: ilev - character(len=*), optional, intent(in) :: pos + character(len=*), optional, intent(in) :: pos ! Local variables integer(psb_ipk_) :: ilev_, nlev_ @@ -367,132 +367,196 @@ subroutine mld_dcprecseti(p,what,val,info,ilev,pos) contains subroutine onelev_set_smoother(level,val,info,pos) - type(mld_d_onelev_type), intent(inout) :: level + class(mld_d_onelev_type), intent(inout) :: level integer(psb_ipk_), intent(in) :: val integer(psb_ipk_), intent(out) :: info - character(len=*), optional, intent(in) :: pos + character(len=*), optional, intent(in) :: pos + ! Local + integer(psb_ipk_) :: ipos_ info = psb_success_ + if (present(pos)) then + select case(psb_toupper(trim(pos))) + case('PRE') + ipos_ = mld_pre_smooth_ + case('POST') + ipos_ = mld_post_smooth_ + case default + ipos_ = mld_pre_smooth_ + end select + else + ipos_ = mld_pre_smooth_ + end if + + + select case(ipos_) + case(mld_pre_smooth_) + call inner_set_smoother(level%sm,val,info) + case (mld_post_smooth_) + call inner_set_smoother(level%sm2a,val,info) + case default + ! Impossible!! + info = psb_err_internal_error_ + end select + end subroutine onelev_set_smoother + + + subroutine inner_set_smoother(sm,val,info) + class(mld_d_base_smoother_type), allocatable, intent(inout) :: sm + integer(psb_ipk_), intent(in) :: val + integer(psb_ipk_), intent(out) :: info ! ! This here requires a bit more attention. ! select case (val) case (mld_noprec_) - if (allocated(level%sm)) then - select type (sm => level%sm) + if (allocated(sm)) then + select type (sms => sm) type is (mld_d_base_smoother_type) ! do nothing class default - call level%sm%free(info) - if (info == 0) deallocate(level%sm) + call sm%free(info) + if (info == 0) deallocate(sm) if (info == 0) allocate(mld_d_base_smoother_type ::& - & level%sm, stat=info) + & sm, stat=info) if (info == 0) allocate(mld_d_id_solver_type ::& - & level%sm%sv, stat=info) + & sm%sv, stat=info) end select else allocate(mld_d_base_smoother_type ::& - & level%sm, stat=info) + & sm, stat=info) if (info ==0) allocate(mld_d_id_solver_type ::& - & level%sm%sv, stat=info) + & sm%sv, stat=info) endif - + case (mld_jac_) - if (allocated(level%sm)) then - select type (sm => level%sm) + if (allocated(sm)) then + select type (sms => sm) class is (mld_d_jac_smoother_type) - ! do nothing + ! do nothing class default - call level%sm%free(info) - if (info == 0) deallocate(level%sm) + call sm%free(info) + if (info == 0) deallocate(sm) if (info == 0) allocate(mld_d_jac_smoother_type :: & - & level%sm, stat=info) + & sm, stat=info) if (info == 0) allocate(mld_d_diag_solver_type :: & - & level%sm%sv, stat=info) + & sm%sv, stat=info) end select else - allocate(mld_d_jac_smoother_type :: level%sm, stat=info) + allocate(mld_d_jac_smoother_type :: sm, stat=info) if (info == 0) allocate(mld_d_diag_solver_type ::& - & level%sm%sv, stat=info) + & sm%sv, stat=info) endif - + case (mld_bjac_) - if (allocated(level%sm)) then - select type (sm => level%sm) + if (allocated(sm)) then + select type (sms => sm) class is (mld_d_jac_smoother_type) - ! do nothing + ! do nothing class default - call level%sm%free(info) - if (info == 0) deallocate(level%sm) + call sm%free(info) + if (info == 0) deallocate(sm) if (info == 0) allocate(mld_d_jac_smoother_type ::& - & level%sm, stat=info) + & sm, stat=info) if (info == 0) allocate(mld_d_ilu_solver_type ::& - & level%sm%sv, stat=info) + & sm%sv, stat=info) end select else - allocate(mld_d_jac_smoother_type :: level%sm, stat=info) + allocate(mld_d_jac_smoother_type :: sm, stat=info) if (info == 0) allocate(mld_d_ilu_solver_type ::& - & level%sm%sv, stat=info) + & sm%sv, stat=info) endif - + case (mld_as_) - if (allocated(level%sm)) then - select type (sm => level%sm) + if (allocated(sm)) then + select type (sms => sm) class is (mld_d_as_smoother_type) - ! do nothing + ! do nothing class default - call level%sm%free(info) - if (info == 0) deallocate(level%sm) + call sm%free(info) + if (info == 0) deallocate(sm) if (info == 0) allocate(mld_d_as_smoother_type ::& - & level%sm, stat=info) + & sm, stat=info) if (info == 0) allocate(mld_d_ilu_solver_type ::& - & level%sm%sv, stat=info) + & sm%sv, stat=info) end select else - allocate(mld_d_as_smoother_type :: level%sm, stat=info) + allocate(mld_d_as_smoother_type :: sm, stat=info) if (info == 0) allocate(mld_d_ilu_solver_type ::& - & level%sm%sv, stat=info) + & sm%sv, stat=info) endif - + case default ! ! Do nothing and hope for the best :) ! end select - if (allocated(level%sm)) & - & call level%sm%default() - - end subroutine onelev_set_smoother + if (allocated(sm)) & + & call sm%default() + end subroutine inner_set_smoother + subroutine onelev_set_solver(level,val,info,pos) - type(mld_d_onelev_type), intent(inout) :: level + class(mld_d_onelev_type), intent(inout) :: level integer(psb_ipk_), intent(in) :: val integer(psb_ipk_), intent(out) :: info - character(len=*), optional, intent(in) :: pos + character(len=*), optional, intent(in) :: pos + ! Local + integer(psb_ipk_) :: ipos_ info = psb_success_ + if (present(pos)) then + select case(psb_toupper(trim(pos))) + case('PRE') + ipos_ = mld_pre_smooth_ + case('POST') + ipos_ = mld_post_smooth_ + case default + ipos_ = mld_pre_smooth_ + end select + else + ipos_ = mld_pre_smooth_ + end if + + select case(ipos_) + case(mld_pre_smooth_) + call inner_set_solver(level%sm,val,info) + case (mld_post_smooth_) + call inner_set_solver(level%sm2a,val,info) + case default + ! Impossible!! + info = psb_err_internal_error_ + end select + end subroutine onelev_set_solver + + + subroutine inner_set_solver(sm,val,info) + class(mld_d_base_smoother_type), allocatable, intent(inout) :: sm + integer(psb_ipk_), intent(in) :: val + integer(psb_ipk_), intent(out) :: info ! - ! This here requires a bit more attention. + ! Yes, the first argument is a smoother, to catch the case where + ! user is trying to set a solver on a not-yet-allocated smoother. ! select case (val) case (mld_f_none_) - if (allocated(level%sm)) then - if (allocated(level%sm%sv)) then - select type (sv => level%sm%sv) + if (allocated(sm)) then + if (allocated(sm%sv)) then + select type (sv => sm%sv) class is (mld_d_id_solver_type) ! do nothing class default - call level%sm%sv%free(info) - if (info == 0) deallocate(level%sm%sv) + call sm%sv%free(info) + if (info == 0) deallocate(sm%sv) if (info == 0) allocate(mld_d_id_solver_type ::& - & level%sm%sv, stat=info) + & sm%sv, stat=info) end select else - allocate(mld_d_id_solver_type :: level%sm%sv, stat=info) + allocate(mld_d_id_solver_type :: sm%sv, stat=info) endif - if (allocated(level%sm)) then - if (allocated(level%sm%sv)) & - & call level%sm%sv%default() + if (allocated(sm)) then + if (allocated(sm%sv)) & + & call sm%sv%default() end if else write(0,*) 'Calling set_solver without a smoother?' @@ -500,74 +564,74 @@ contains end if case (mld_diag_scale_) - if (allocated(level%sm)) then - if (allocated(level%sm%sv)) then - select type (sv => level%sm%sv) + if (allocated(sm)) then + if (allocated(sm%sv)) then + select type (sv => sm%sv) class is (mld_d_diag_solver_type) ! do nothing class default - call level%sm%sv%free(info) - if (info == 0) deallocate(level%sm%sv) + call sm%sv%free(info) + if (info == 0) deallocate(sm%sv) if (info == 0) allocate(mld_d_diag_solver_type ::& - & level%sm%sv, stat=info) + & sm%sv, stat=info) end select else - allocate(mld_d_diag_solver_type :: level%sm%sv, stat=info) + allocate(mld_d_diag_solver_type :: sm%sv, stat=info) endif - if (allocated(level%sm)) then - if (allocated(level%sm%sv)) & - & call level%sm%sv%default() + if (allocated(sm)) then + if (allocated(sm%sv)) & + & call sm%sv%default() end if else write(0,*) 'Calling set_solver without a smoother?' info = -5 end if - + case (mld_gs_) - if (allocated(level%sm)) then - if (allocated(level%sm%sv)) then - select type (sv => level%sm%sv) - class is (mld_d_gs_solver_type) - ! do nothing - class default - call level%sm%sv%free(info) - if (info == 0) deallocate(level%sm%sv) + if (allocated(sm)) then + if (allocated(sm%sv)) then + select type (sv => sm%sv) + class is (mld_d_gs_solver_type) + ! do nothing + class default + call sm%sv%free(info) + if (info == 0) deallocate(sm%sv) if (info == 0) allocate(mld_d_gs_solver_type ::& - & level%sm%sv, stat=info) + & sm%sv, stat=info) end select else - allocate(mld_d_gs_solver_type :: level%sm%sv, stat=info) + allocate(mld_d_gs_solver_type :: sm%sv, stat=info) endif - if (allocated(level%sm%sv)) then - call level%sm%sv%default() + if (allocated(sm%sv)) then + call sm%sv%default() else endif - + else write(0,*) 'Calling set_solver without a smoother?' info = -5 end if - + case (mld_ilu_n_,mld_milu_n_,mld_ilu_t_) - if (allocated(level%sm)) then - if (allocated(level%sm%sv)) then - select type (sv => level%sm%sv) + if (allocated(sm)) then + if (allocated(sm%sv)) then + select type (sv => sm%sv) class is (mld_d_ilu_solver_type) ! do nothing class default - call level%sm%sv%free(info) - if (info == 0) deallocate(level%sm%sv) + call sm%sv%free(info) + if (info == 0) deallocate(sm%sv) if (info == 0) allocate(mld_d_ilu_solver_type ::& - & level%sm%sv, stat=info) + & sm%sv, stat=info) end select else - allocate(mld_d_ilu_solver_type :: level%sm%sv, stat=info) + allocate(mld_d_ilu_solver_type :: sm%sv, stat=info) endif - if (allocated(level%sm)) then - if (allocated(level%sm%sv)) & - & call level%sm%sv%default() + if (allocated(sm)) then + if (allocated(sm%sv)) & + & call sm%sv%default() end if - call level%sm%sv%set('SUB_SOLVE',val,info) + call sm%sv%set('SUB_SOLVE',val,info) else write(0,*) 'Calling set_solver without a smoother?' info = -5 @@ -575,23 +639,23 @@ contains #ifdef HAVE_SLU_ case (mld_slu_) - if (allocated(level%sm)) then - if (allocated(level%sm%sv)) then - select type (sv => level%sm%sv) + if (allocated(sm)) then + if (allocated(sm%sv)) then + select type (sv => sm%sv) class is (mld_d_slu_solver_type) ! do nothing class default - call level%sm%sv%free(info) - if (info == 0) deallocate(level%sm%sv) + call sm%sv%free(info) + if (info == 0) deallocate(sm%sv) if (info == 0) allocate(mld_d_slu_solver_type ::& - & level%sm%sv, stat=info) + & sm%sv, stat=info) end select else - allocate(mld_d_slu_solver_type :: level%sm%sv, stat=info) + allocate(mld_d_slu_solver_type :: sm%sv, stat=info) endif - if (allocated(level%sm)) then - if (allocated(level%sm%sv)) & - & call level%sm%sv%default() + if (allocated(sm)) then + if (allocated(sm%sv)) & + & call sm%sv%default() end if else write(0,*) 'Calling set_solver without a smoother?' @@ -600,44 +664,44 @@ contains #endif #ifdef HAVE_MUMPS_ case (mld_mumps_) - if (allocated(level%sm%sv)) then - select type (sv => level%sm%sv) + if (allocated(sm%sv)) then + select type (sv => sm%sv) class is (mld_d_mumps_solver_type) - ! do nothing + ! do nothing class default - call level%sm%sv%free(info) - if (info == 0) deallocate(level%sm%sv) + call sm%sv%free(info) + if (info == 0) deallocate(sm%sv) if (info == 0) allocate(mld_d_mumps_solver_type ::& - & level%sm%sv, stat=info) + & sm%sv, stat=info) end select else - allocate(mld_d_mumps_solver_type :: level%sm%sv, stat=info) + allocate(mld_d_mumps_solver_type :: sm%sv, stat=info) endif - if (allocated(level%sm)) then - if (allocated(level%sm%sv)) & - & call level%sm%sv%default() + if (allocated(sm)) then + if (allocated(sm%sv)) & + & call sm%sv%default() end if #endif - + #ifdef HAVE_UMF_ case (mld_umf_) - if (allocated(level%sm)) then - if (allocated(level%sm%sv)) then - select type (sv => level%sm%sv) + if (allocated(sm)) then + if (allocated(sm%sv)) then + select type (sv => sm%sv) class is (mld_d_umf_solver_type) ! do nothing class default - call level%sm%sv%free(info) - if (info == 0) deallocate(level%sm%sv) + call sm%sv%free(info) + if (info == 0) deallocate(sm%sv) if (info == 0) allocate(mld_d_umf_solver_type ::& - & level%sm%sv, stat=info) + & sm%sv, stat=info) end select else - allocate(mld_d_umf_solver_type :: level%sm%sv, stat=info) + allocate(mld_d_umf_solver_type :: sm%sv, stat=info) endif - if (allocated(level%sm)) then - if (allocated(level%sm%sv)) & - & call level%sm%sv%default() + if (allocated(sm)) then + if (allocated(sm%sv)) & + & call sm%sv%default() end if else write(0,*) 'Calling set_solver without a smoother?' @@ -646,23 +710,23 @@ contains #endif #ifdef HAVE_SLUDIST_ case (mld_sludist_) - if (allocated(level%sm)) then - if (allocated(level%sm%sv)) then - select type (sv => level%sm%sv) + if (allocated(sm)) then + if (allocated(sm%sv)) then + select type (sv => sm%sv) class is (mld_d_sludist_solver_type) ! do nothing class default - call level%sm%sv%free(info) - if (info == 0) deallocate(level%sm%sv) + call sm%sv%free(info) + if (info == 0) deallocate(sm%sv) if (info == 0) allocate(mld_d_sludist_solver_type ::& - & level%sm%sv, stat=info) + & sm%sv, stat=info) end select else - allocate(mld_d_sludist_solver_type :: level%sm%sv, stat=info) + allocate(mld_d_sludist_solver_type :: sm%sv, stat=info) endif - if (allocated(level%sm)) then - if (allocated(level%sm%sv)) & - & call level%sm%sv%default() + if (allocated(sm)) then + if (allocated(sm%sv)) & + & call sm%sv%default() end if else write(0,*) 'Calling set_solver without a smoother?' @@ -674,9 +738,7 @@ contains ! Do nothing and hope for the best :) ! end select - - end subroutine onelev_set_solver - + end subroutine inner_set_solver end subroutine mld_dcprecseti diff --git a/mlprec/impl/mld_dprecset.F90 b/mlprec/impl/mld_dprecset.F90 index 60ae1fd6..adb06da7 100644 --- a/mlprec/impl/mld_dprecset.F90 +++ b/mlprec/impl/mld_dprecset.F90 @@ -358,282 +358,297 @@ subroutine mld_dprecseti(p,what,val,info,ilev,pos) endif contains - + subroutine onelev_set_smoother(level,val,info,pos) - type(mld_d_onelev_type), intent(inout) :: level + class(mld_d_onelev_type), intent(inout) :: level integer(psb_ipk_), intent(in) :: val integer(psb_ipk_), intent(out) :: info - character(len=*), optional, intent(in) :: pos + character(len=*), optional, intent(in) :: pos + ! Local + integer(psb_ipk_) :: ipos_ info = psb_success_ + if (present(pos)) then + select case(psb_toupper(trim(pos))) + case('PRE') + ipos_ = mld_pre_smooth_ + case('POST') + ipos_ = mld_post_smooth_ + case default + ipos_ = mld_pre_smooth_ + end select + else + ipos_ = mld_pre_smooth_ + end if + + + select case(ipos_) + case(mld_pre_smooth_) + call inner_set_smoother(level%sm,val,info) + case (mld_post_smooth_) + call inner_set_smoother(level%sm2a,val,info) + case default + ! Impossible!! + info = psb_err_internal_error_ + end select + end subroutine onelev_set_smoother + + + subroutine inner_set_smoother(sm,val,info) + class(mld_d_base_smoother_type), allocatable, intent(inout) :: sm + integer(psb_ipk_), intent(in) :: val + integer(psb_ipk_), intent(out) :: info ! ! This here requires a bit more attention. ! select case (val) case (mld_noprec_) - if (allocated(level%sm)) then - select type (sm => level%sm) + if (allocated(sm)) then + select type (sms => sm) type is (mld_d_base_smoother_type) ! do nothing class default - call level%sm%free(info) - if (info == 0) deallocate(level%sm) + call sm%free(info) + if (info == 0) deallocate(sm) if (info == 0) allocate(mld_d_base_smoother_type ::& - & level%sm, stat=info) + & sm, stat=info) if (info == 0) allocate(mld_d_id_solver_type ::& - & level%sm%sv, stat=info) + & sm%sv, stat=info) end select else allocate(mld_d_base_smoother_type ::& - & level%sm, stat=info) + & sm, stat=info) if (info ==0) allocate(mld_d_id_solver_type ::& - & level%sm%sv, stat=info) + & sm%sv, stat=info) endif - + case (mld_jac_) - if (allocated(level%sm)) then - select type (sm => level%sm) + if (allocated(sm)) then + select type (sms => sm) class is (mld_d_jac_smoother_type) - ! do nothing + ! do nothing class default - call level%sm%free(info) - if (info == 0) deallocate(level%sm) + call sm%free(info) + if (info == 0) deallocate(sm) if (info == 0) allocate(mld_d_jac_smoother_type :: & - & level%sm, stat=info) + & sm, stat=info) if (info == 0) allocate(mld_d_diag_solver_type :: & - & level%sm%sv, stat=info) + & sm%sv, stat=info) end select else - allocate(mld_d_jac_smoother_type :: level%sm, stat=info) + allocate(mld_d_jac_smoother_type :: sm, stat=info) if (info == 0) allocate(mld_d_diag_solver_type ::& - & level%sm%sv, stat=info) + & sm%sv, stat=info) endif - + case (mld_bjac_) - if (allocated(level%sm)) then - select type (sm => level%sm) + if (allocated(sm)) then + select type (sms => sm) class is (mld_d_jac_smoother_type) - ! do nothing + ! do nothing class default - call level%sm%free(info) - if (info == 0) deallocate(level%sm) + call sm%free(info) + if (info == 0) deallocate(sm) if (info == 0) allocate(mld_d_jac_smoother_type ::& - & level%sm, stat=info) + & sm, stat=info) if (info == 0) allocate(mld_d_ilu_solver_type ::& - & level%sm%sv, stat=info) + & sm%sv, stat=info) end select else - allocate(mld_d_jac_smoother_type :: level%sm, stat=info) + allocate(mld_d_jac_smoother_type :: sm, stat=info) if (info == 0) allocate(mld_d_ilu_solver_type ::& - & level%sm%sv, stat=info) + & sm%sv, stat=info) endif - + case (mld_as_) - if (allocated(level%sm)) then - select type (sm => level%sm) + if (allocated(sm)) then + select type (sms => sm) class is (mld_d_as_smoother_type) - ! do nothing + ! do nothing class default - call level%sm%free(info) - if (info == 0) deallocate(level%sm) + call sm%free(info) + if (info == 0) deallocate(sm) if (info == 0) allocate(mld_d_as_smoother_type ::& - & level%sm, stat=info) + & sm, stat=info) if (info == 0) allocate(mld_d_ilu_solver_type ::& - & level%sm%sv, stat=info) + & sm%sv, stat=info) end select else - allocate(mld_d_as_smoother_type :: level%sm, stat=info) + allocate(mld_d_as_smoother_type :: sm, stat=info) if (info == 0) allocate(mld_d_ilu_solver_type ::& - & level%sm%sv, stat=info) + & sm%sv, stat=info) endif - + case default ! ! Do nothing and hope for the best :) ! end select - if (allocated(level%sm)) & - & call level%sm%default() - - end subroutine onelev_set_smoother + if (allocated(sm)) & + & call sm%default() + end subroutine inner_set_smoother + subroutine onelev_set_solver(level,val,info,pos) - type(mld_d_onelev_type), intent(inout) :: level + class(mld_d_onelev_type), intent(inout) :: level integer(psb_ipk_), intent(in) :: val integer(psb_ipk_), intent(out) :: info character(len=*), optional, intent(in) :: pos + ! Local + integer(psb_ipk_) :: ipos_ info = psb_success_ + if (present(pos)) then + select case(psb_toupper(trim(pos))) + case('PRE') + ipos_ = mld_pre_smooth_ + case('POST') + ipos_ = mld_post_smooth_ + case default + ipos_ = mld_pre_smooth_ + end select + else + ipos_ = mld_pre_smooth_ + end if + + select case(ipos_) + case(mld_pre_smooth_) + call inner_set_solver(level%sm,val,info) + case (mld_post_smooth_) + call inner_set_solver(level%sm2a,val,info) + case default + ! Impossible!! + info = psb_err_internal_error_ + end select + end subroutine onelev_set_solver + + + subroutine inner_set_solver(sm,val,info) + class(mld_d_base_smoother_type), allocatable, intent(inout) :: sm + integer(psb_ipk_), intent(in) :: val + integer(psb_ipk_), intent(out) :: info ! - ! This here requires a bit more attention. + ! Yes, the first argument is a smoother, to catch the case where + ! user is trying to set a solver on a not-yet-allocated smoother. ! select case (val) case (mld_f_none_) - if (allocated(level%sm)) then - if (allocated(level%sm%sv)) then - select type (sv => level%sm%sv) - class is (mld_d_id_solver_type) - ! do nothing - class default - call level%sm%sv%free(info) - if (info == 0) deallocate(level%sm%sv) + if (allocated(sm)) then + if (allocated(sm%sv)) then + select type (sv => sm%sv) + class is (mld_d_id_solver_type) + ! do nothing + class default + call sm%sv%free(info) + if (info == 0) deallocate(sm%sv) if (info == 0) allocate(mld_d_id_solver_type ::& - & level%sm%sv, stat=info) + & sm%sv, stat=info) end select else - allocate(mld_d_id_solver_type :: level%sm%sv, stat=info) + allocate(mld_d_id_solver_type :: sm%sv, stat=info) endif - if (allocated(level%sm)) then - if (allocated(level%sm%sv)) & - & call level%sm%sv%default() + if (allocated(sm)) then + if (allocated(sm%sv)) & + & call sm%sv%default() end if else write(0,*) 'Calling set_solver without a smoother?' info = -5 end if - - + case (mld_diag_scale_) - if (allocated(level%sm)) then - if (allocated(level%sm%sv)) then - select type (sv => level%sm%sv) - class is (mld_d_diag_solver_type) - ! do nothing - class default - call level%sm%sv%free(info) - if (info == 0) deallocate(level%sm%sv) + if (allocated(sm)) then + if (allocated(sm%sv)) then + select type (sv => sm%sv) + class is (mld_d_diag_solver_type) + ! do nothing + class default + call sm%sv%free(info) + if (info == 0) deallocate(sm%sv) if (info == 0) allocate(mld_d_diag_solver_type ::& - & level%sm%sv, stat=info) + & sm%sv, stat=info) end select else - allocate(mld_d_diag_solver_type :: level%sm%sv, stat=info) + allocate(mld_d_diag_solver_type :: sm%sv, stat=info) endif - if (allocated(level%sm)) then - if (allocated(level%sm%sv)) & - & call level%sm%sv%default() + if (allocated(sm)) then + if (allocated(sm%sv)) & + & call sm%sv%default() end if else write(0,*) 'Calling set_solver without a smoother?' info = -5 end if - + case (mld_gs_) - if (allocated(level%sm)) then - if (allocated(level%sm%sv)) then - select type (sv => level%sm%sv) - class is (mld_d_gs_solver_type) - ! do nothing - class default - call level%sm%sv%free(info) - if (info == 0) deallocate(level%sm%sv) + if (allocated(sm)) then + if (allocated(sm%sv)) then + select type (sv => sm%sv) + class is (mld_d_gs_solver_type) + ! do nothing + class default + call sm%sv%free(info) + if (info == 0) deallocate(sm%sv) if (info == 0) allocate(mld_d_gs_solver_type ::& - & level%sm%sv, stat=info) + & sm%sv, stat=info) end select else - allocate(mld_d_gs_solver_type :: level%sm%sv, stat=info) + allocate(mld_d_gs_solver_type :: sm%sv, stat=info) endif - if (allocated(level%sm%sv)) then - call level%sm%sv%default() - end if - + if (allocated(sm%sv)) then + call sm%sv%default() + else + endif + else write(0,*) 'Calling set_solver without a smoother?' info = -5 end if - + case (mld_ilu_n_,mld_milu_n_,mld_ilu_t_) - if (allocated(level%sm)) then - if (allocated(level%sm%sv)) then - select type (sv => level%sm%sv) - class is (mld_d_ilu_solver_type) - ! do nothing - class default - call level%sm%sv%free(info) - if (info == 0) deallocate(level%sm%sv) + if (allocated(sm)) then + if (allocated(sm%sv)) then + select type (sv => sm%sv) + class is (mld_d_ilu_solver_type) + ! do nothing + class default + call sm%sv%free(info) + if (info == 0) deallocate(sm%sv) if (info == 0) allocate(mld_d_ilu_solver_type ::& - & level%sm%sv, stat=info) + & sm%sv, stat=info) end select else - allocate(mld_d_ilu_solver_type :: level%sm%sv, stat=info) + allocate(mld_d_ilu_solver_type :: sm%sv, stat=info) endif - if (allocated(level%sm)) then - if (allocated(level%sm%sv)) & - & call level%sm%sv%default() + if (allocated(sm)) then + if (allocated(sm%sv)) & + & call sm%sv%default() end if - call level%sm%sv%set(mld_sub_solve_,val,info) + call sm%sv%set('SUB_SOLVE',val,info) else write(0,*) 'Calling set_solver without a smoother?' info = -5 end if -#ifdef HAVE_UMF_ - case (mld_umf_) - if (allocated(level%sm)) then - if (allocated(level%sm%sv)) then - select type (sv => level%sm%sv) - class is (mld_d_umf_solver_type) - ! do nothing - class default - call level%sm%sv%free(info) - if (info == 0) deallocate(level%sm%sv) - if (info == 0) allocate(mld_d_umf_solver_type ::& - & level%sm%sv, stat=info) - end select - else - allocate(mld_d_umf_solver_type :: level%sm%sv, stat=info) - endif - if (allocated(level%sm)) then - if (allocated(level%sm%sv)) & - & call level%sm%sv%default() - end if - else - write(0,*) 'Calling set_solver without a smoother?' - info = -5 - end if -#endif -#ifdef HAVE_SLUDIST_ - case (mld_sludist_) - if (allocated(level%sm)) then - if (allocated(level%sm%sv)) then - select type (sv => level%sm%sv) - class is (mld_d_sludist_solver_type) - ! do nothing - class default - call level%sm%sv%free(info) - if (info == 0) deallocate(level%sm%sv) - if (info == 0) allocate(mld_d_sludist_solver_type ::& - & level%sm%sv, stat=info) - end select - else - allocate(mld_d_sludist_solver_type :: level%sm%sv, stat=info) - endif - if (allocated(level%sm)) then - if (allocated(level%sm%sv)) & - & call level%sm%sv%default() - end if - else - write(0,*) 'Calling set_solver without a smoother?' - info = -5 - end if -#endif + #ifdef HAVE_SLU_ case (mld_slu_) - if (allocated(level%sm)) then - if (allocated(level%sm%sv)) then - select type (sv => level%sm%sv) + if (allocated(sm)) then + if (allocated(sm%sv)) then + select type (sv => sm%sv) class is (mld_d_slu_solver_type) ! do nothing class default - call level%sm%sv%free(info) - if (info == 0) deallocate(level%sm%sv) + call sm%sv%free(info) + if (info == 0) deallocate(sm%sv) if (info == 0) allocate(mld_d_slu_solver_type ::& - & level%sm%sv, stat=info) + & sm%sv, stat=info) end select else - allocate(mld_d_slu_solver_type :: level%sm%sv, stat=info) + allocate(mld_d_slu_solver_type :: sm%sv, stat=info) endif - if (allocated(level%sm)) then - if (allocated(level%sm%sv)) & - & call level%sm%sv%default() + if (allocated(sm)) then + if (allocated(sm%sv)) & + & call sm%sv%default() end if else write(0,*) 'Calling set_solver without a smoother?' @@ -642,23 +657,73 @@ contains #endif #ifdef HAVE_MUMPS_ case (mld_mumps_) - if (allocated(level%sm%sv)) then - select type (sv => level%sm%sv) + if (allocated(sm%sv)) then + select type (sv => sm%sv) class is (mld_d_mumps_solver_type) - ! do nothing + ! do nothing class default - call level%sm%sv%free(info) - if (info == 0) deallocate(level%sm%sv) + call sm%sv%free(info) + if (info == 0) deallocate(sm%sv) if (info == 0) allocate(mld_d_mumps_solver_type ::& - & level%sm%sv, stat=info) + & sm%sv, stat=info) end select else - allocate(mld_d_mumps_solver_type :: level%sm%sv, stat=info) + allocate(mld_d_mumps_solver_type :: sm%sv, stat=info) endif - if (allocated(level%sm)) then - if (allocated(level%sm%sv)) then - call level%sm%sv%default() - end if + if (allocated(sm)) then + if (allocated(sm%sv)) & + & call sm%sv%default() + end if +#endif + +#ifdef HAVE_UMF_ + case (mld_umf_) + if (allocated(sm)) then + if (allocated(sm%sv)) then + select type (sv => sm%sv) + class is (mld_d_umf_solver_type) + ! do nothing + class default + call sm%sv%free(info) + if (info == 0) deallocate(sm%sv) + if (info == 0) allocate(mld_d_umf_solver_type ::& + & sm%sv, stat=info) + end select + else + allocate(mld_d_umf_solver_type :: sm%sv, stat=info) + endif + if (allocated(sm)) then + if (allocated(sm%sv)) & + & call sm%sv%default() + end if + else + write(0,*) 'Calling set_solver without a smoother?' + info = -5 + end if +#endif +#ifdef HAVE_SLUDIST_ + case (mld_sludist_) + if (allocated(sm)) then + if (allocated(sm%sv)) then + select type (sv => sm%sv) + class is (mld_d_sludist_solver_type) + ! do nothing + class default + call sm%sv%free(info) + if (info == 0) deallocate(sm%sv) + if (info == 0) allocate(mld_d_sludist_solver_type ::& + & sm%sv, stat=info) + end select + else + allocate(mld_d_sludist_solver_type :: sm%sv, stat=info) + endif + if (allocated(sm)) then + if (allocated(sm%sv)) & + & call sm%sv%default() + end if + else + write(0,*) 'Calling set_solver without a smoother?' + info = -5 end if #endif case default @@ -666,9 +731,7 @@ contains ! Do nothing and hope for the best :) ! end select - - end subroutine onelev_set_solver - + end subroutine inner_set_solver end subroutine mld_dprecseti @@ -733,33 +796,36 @@ subroutine mld_dprecsetsm(p,val,info,ilev,pos) select case(ipos_) case(mld_pre_smooth_) do ilev_ = ilmin, ilmax - if (allocated(p%precv(ilev_)%sm)) then - if (allocated(p%precv(ilev_)%sm%sv)) then - deallocate(p%precv(ilev_)%sm%sv) - endif - deallocate(p%precv(ilev_)%sm) - end if + if (allocated(p%precv(ilev_)%sm)) then + if (.not.same_type_as(p%precv(ilev_)%sm,val)) then + call p%precv(ilev_)%sm%free(info) + deallocate(p%precv(ilev_)%sm, stat=info) + end if + endif + if (.not.allocated(p%precv(ilev_)%sm)) then #ifdef HAVE_MOLD - allocate(p%precv(ilev_)%sm,mold=val) + allocate(p%precv(ilev_)%sm,mold=val) #else - allocate(p%precv(ilev_)%sm,source=val) + allocate(p%precv(ilev_)%sm,source=val) #endif - call p%precv(ilev_)%sm%default() + end if + call p%precv(ilev_)%sm%default() p%precv(ilev_)%sm2 => p%precv(ilev_)%sm end do case(mld_post_smooth_) do ilev_ = ilmin, ilmax - if (allocated(p%precv(ilev_)%sm2a)) then - if (allocated(p%precv(ilev_)%sm2a%sv)) then - deallocate(p%precv(ilev_)%sm2a%sv) - endif - deallocate(p%precv(ilev_)%sm2a) - end if + if (allocated(p%precv(ilev_)%sm2a)) then + if (.not.same_type_as(p%precv(ilev_)%sm2a,val)) then + call p%precv(ilev_)%sm2a%free(info) + deallocate(p%precv(ilev_)%sm2a, stat=info) + endif + if (.not.allocated(p%precv(ilev_)%sm2a)) then #ifdef HAVE_MOLD - allocate(p%precv(ilev_)%sm2a,mold=val) + allocate(p%precv(ilev_)%sm2a,mold=val) #else - allocate(p%precv(ilev_)%sm2a,source=val) + allocate(p%precv(ilev_)%sm2a,source=val) #endif + end if call p%precv(ilev_)%sm2a%default() p%precv(ilev_)%sm2 => p%precv(ilev_)%sm2a end do @@ -834,6 +900,7 @@ subroutine mld_dprecsetsv(p,val,info,ilev,pos) if (allocated(p%precv(ilev_)%sm)) then if (allocated(p%precv(ilev_)%sm%sv)) then if (.not.same_type_as(p%precv(ilev_)%sm%sv,val)) then + call p%precv(ilev_)%sm%sv%free(info) deallocate(p%precv(ilev_)%sm%sv,stat=info) if (info /= 0) then info = 3111 @@ -870,6 +937,7 @@ subroutine mld_dprecsetsv(p,val,info,ilev,pos) if (allocated(p%precv(ilev_)%sm2a)) then if (allocated(p%precv(ilev_)%sm2a%sv)) then if (.not.same_type_as(p%precv(ilev_)%sm2a%sv,val)) then + call p%precv(ilev_)%sm2a%sv%free(info) deallocate(p%precv(ilev_)%sm2a%sv,stat=info) if (info /= 0) then info = 3111 diff --git a/mlprec/mld_d_prec_mod.f90 b/mlprec/mld_d_prec_mod.f90 index dd6195b1..f10a1d95 100644 --- a/mlprec/mld_d_prec_mod.f90 +++ b/mlprec/mld_d_prec_mod.f90 @@ -115,7 +115,7 @@ contains integer(psb_ipk_), intent(out) :: info character(len=*), optional, intent(in) :: pos - call p%set(what,val,info) + call p%set(what,val,info,pos=pos) end subroutine mld_d_iprecseti subroutine mld_d_iprecsetr(p,what,val,info,pos) @@ -125,7 +125,7 @@ contains integer(psb_ipk_), intent(out) :: info character(len=*), optional, intent(in) :: pos - call p%set(what,val,info) + call p%set(what,val,info,pos=pos) end subroutine mld_d_iprecsetr subroutine mld_d_iprecsetc(p,what,val,info,pos) @@ -135,7 +135,7 @@ contains integer(psb_ipk_), intent(out) :: info character(len=*), optional, intent(in) :: pos - call p%set(what,val,info) + call p%set(what,val,info,pos=pos) end subroutine mld_d_iprecsetc subroutine mld_d_cprecseti(p,what,val,info,pos) @@ -145,7 +145,7 @@ contains integer(psb_ipk_), intent(out) :: info character(len=*), optional, intent(in) :: pos - call p%set(what,val,info) + call p%set(what,val,info,pos=pos) end subroutine mld_d_cprecseti subroutine mld_d_cprecsetr(p,what,val,info,pos) @@ -155,7 +155,7 @@ contains integer(psb_ipk_), intent(out) :: info character(len=*), optional, intent(in) :: pos - call p%set(what,val,info) + call p%set(what,val,info,pos=pos) end subroutine mld_d_cprecsetr subroutine mld_d_cprecsetc(p,what,val,info,pos) @@ -165,7 +165,7 @@ contains integer(psb_ipk_), intent(out) :: info character(len=*), optional, intent(in) :: pos - call p%set(what,val,info) + call p%set(what,val,info,pos=pos) end subroutine mld_d_cprecsetc end module mld_d_prec_mod diff --git a/tests/pdegen/ppde3d-gs.f90 b/tests/pdegen/ppde3d-gs.f90 index 1374c4b3..f7edf8d9 100644 --- a/tests/pdegen/ppde3d-gs.f90 +++ b/tests/pdegen/ppde3d-gs.f90 @@ -270,6 +270,7 @@ program ppde3d call mld_precset(prec,'coarse_aggr_size', prectype%csize, info) call prec%set(dbsmth,info,pos='post') call prec%set(dbwgs,info,pos='post') + call mld_precset(prec,'solver_sweeps', prectype%svsweeps, info, pos='post') else nlv = 1 call mld_precinit(prec,prectype%prec, info, nlev=nlv) @@ -281,6 +282,9 @@ program ppde3d call mld_precset(prec,'sub_fillin', prectype%fill1, info) call mld_precset(prec,'solver_sweeps', prectype%svsweeps, info) call mld_precset(prec,'sub_iluthrs', prectype%thr1, info) + call prec%set(dbsmth,info,pos='post') + call prec%set(dbwgs,info,pos='post') + call mld_precset(prec,'solver_sweeps', prectype%svsweeps, info, pos='post') end if call psb_barrier(ictxt) diff --git a/tests/pdegen/runs/ppde.inp b/tests/pdegen/runs/ppde.inp index 868078ea..d8baa766 100644 --- a/tests/pdegen/runs/ppde.inp +++ b/tests/pdegen/runs/ppde.inp @@ -1,21 +1,21 @@ -RGMRES ! Iterative method: BiCGSTAB BiCG CGS RGMRES BiCGSTABL CG +CG ! Iterative method: BiCGSTAB BiCG CGS RGMRES BiCGSTABL CG CSR ! Storage format CSR COO JAD 0030 ! IDIM; domain size is idim**3 2 ! ISTOPC -0100 ! ITMAX +0500 ! ITMAX 10 ! ITRACE 30 ! IRST (restart for RGMRES and BiCGSTABL) 1.d-6 ! EPS 3L-MUL-RAS-BJAC4-ILU ! Descriptive name for preconditioner (up to 40 chars) ML ! Preconditioner NONE JACOBI BJAC AS ML -1 ! Number of overlap layers for AS preconditioner at finest level +0 ! Number of overlap layers for AS preconditioner at finest level HALO ! Restriction operator NONE HALO NONE ! Prolongation operator NONE SUM AVG GS ! Subdomain solver DSCALE ILU MILU ILUT UMF SLU -2 ! sweeps for GS +4 ! Solver sweeps for GS 0 ! Level-set N for ILU(N), and P for ILUT 1.d-4 ! Threshold T for ILU(T,P) -1 ! Smoother/Jacobi sweeps +2 ! Smoother/Jacobi sweeps BJAC ! Smoother type JACOBI BJAC AS; ignored for non-ML 2 ! Number of levels in a multilevel preconditioner SMOOTHED ! Kind of aggregation: SMOOTHED, NONSMOOTHED, MINENERGY @@ -25,7 +25,7 @@ MULT ! Type of multilevel correction: ADD MULT TWOSIDE ! Side of correction PRE POST TWOSIDE (ignored for ADD) DIST ! Coarse level: matrix distribution DIST REPL BJAC ! Coarse level: solver JACOBI BJAC UMF SLU SLUDIST MUMPS -GS ! Coarse level: subsolver DSCALE ILU UMF SLU SLUDIST MUMPS +ILU ! Coarse level: subsolver DSCALE ILU UMF SLU SLUDIST MUMPS 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 From e697b11b24b07105224905e6ccf8e0b50bfa71d9 Mon Sep 17 00:00:00 2001 From: Salvatore Filippone Date: Fri, 13 May 2016 15:11:39 +0000 Subject: [PATCH 09/17] mld2p4-smooth-2side: mlprec/impl/level/Makefile mlprec/impl/level/mld_d_base_onelev_setsm.F90 mlprec/impl/level/mld_d_base_onelev_setsv.F90 mlprec/impl/mld_dprecset.F90 mlprec/mld_d_onelev_mod.f90 First refactor step: defined ONELEV_SETSM and SETSV --- mlprec/impl/level/Makefile | 2 + mlprec/impl/level/mld_d_base_onelev_setsm.F90 | 107 +++++++++++++ mlprec/impl/level/mld_d_base_onelev_setsv.F90 | 144 ++++++++++++++++++ mlprec/impl/mld_dprecset.F90 | 3 +- mlprec/mld_d_onelev_mod.f90 | 33 +++- 5 files changed, 287 insertions(+), 2 deletions(-) create mode 100644 mlprec/impl/level/mld_d_base_onelev_setsm.F90 create mode 100644 mlprec/impl/level/mld_d_base_onelev_setsv.F90 diff --git a/mlprec/impl/level/Makefile b/mlprec/impl/level/Makefile index bd50f2a0..4c035857 100644 --- a/mlprec/impl/level/Makefile +++ b/mlprec/impl/level/Makefile @@ -30,6 +30,8 @@ mld_d_base_onelev_free.o \ mld_d_base_onelev_setc.o \ mld_d_base_onelev_seti.o \ mld_d_base_onelev_setr.o \ +mld_d_base_onelev_setsm.o \ +mld_d_base_onelev_setsv.o \ mld_s_base_onelev_check.o \ mld_s_base_onelev_cnv.o \ mld_s_base_onelev_csetc.o \ diff --git a/mlprec/impl/level/mld_d_base_onelev_setsm.F90 b/mlprec/impl/level/mld_d_base_onelev_setsm.F90 new file mode 100644 index 00000000..c0770327 --- /dev/null +++ b/mlprec/impl/level/mld_d_base_onelev_setsm.F90 @@ -0,0 +1,107 @@ +!!$ +!!$ +!!$ MLD2P4 version 2.0 +!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package +!!$ based on PSBLAS (Parallel Sparse BLAS version 3.3) +!!$ +!!$ (C) Copyright 2008, 2010, 2012, 2015 +!!$ +!!$ 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. +!!$ +!!$ +subroutine mld_d_base_onelev_setsm(lev,val,info,pos) + + use psb_base_mod + use mld_d_prec_mod, mld_protect_name => mld_d_base_onelev_setsm + + implicit none + + ! Arguments + class(mld_d_onelev_type), target, intent(inout) :: lev + class(mld_d_base_smoother_type), intent(in) :: val + integer(psb_ipk_), intent(out) :: info + character(len=*), optional, intent(in) :: pos + + ! Local variables + integer(psb_ipk_) :: ipos_ + character(len=*), parameter :: name='mld_base_onelev_setsm' + + info = psb_success_ + + if (present(pos)) then + select case(psb_toupper(trim(pos))) + case('PRE') + ipos_ = mld_pre_smooth_ + case('POST') + ipos_ = mld_post_smooth_ + case default + ipos_ = mld_pre_smooth_ + end select + else + ipos_ = mld_pre_smooth_ + end if + + select case(ipos_) + case(mld_pre_smooth_) + if (allocated(lev%sm)) then + if (.not.same_type_as(lev%sm,val)) then + call lev%sm%free(info) + deallocate(lev%sm, stat=info) + end if + endif + if (.not.allocated(lev%sm)) then +#ifdef HAVE_MOLD + allocate(lev%sm,mold=val) +#else + allocate(lev%sm,source=val) +#endif + end if + call lev%sm%default() + lev%sm2 => lev%sm + case(mld_post_smooth_) + if (allocated(lev%sm2a)) then + if (.not.same_type_as(lev%sm2a,val)) then + call lev%sm2a%free(info) + deallocate(lev%sm2a, stat=info) + endif + end if + if (.not.allocated(lev%sm2a)) then +#ifdef HAVE_MOLD + allocate(lev%sm2a,mold=val) +#else + allocate(lev%sm2a,source=val) +#endif + end if + call lev%sm2a%default() + lev%sm2 => lev%sm2a + end select + +end subroutine mld_d_base_onelev_setsm + diff --git a/mlprec/impl/level/mld_d_base_onelev_setsv.F90 b/mlprec/impl/level/mld_d_base_onelev_setsv.F90 new file mode 100644 index 00000000..aefdd015 --- /dev/null +++ b/mlprec/impl/level/mld_d_base_onelev_setsv.F90 @@ -0,0 +1,144 @@ +!!$ +!!$ +!!$ MLD2P4 version 2.0 +!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package +!!$ based on PSBLAS (Parallel Sparse BLAS version 3.3) +!!$ +!!$ (C) Copyright 2008, 2010, 2012, 2015 +!!$ +!!$ 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. +!!$ +!!$ +subroutine mld_d_base_onelev_setsv(lev,val,info,pos) + + use psb_base_mod + use mld_d_prec_mod, mld_protect_name => mld_d_base_onelev_setsv + + implicit none + + ! Arguments + class(mld_d_onelev_type), target, intent(inout) :: lev + class(mld_d_base_solver_type), intent(in) :: val + integer(psb_ipk_), intent(out) :: info + character(len=*), optional, intent(in) :: pos + + ! Local variables + integer(psb_ipk_) :: ipos_ + character(len=*), parameter :: name='mld_base_onelev_setsv' + + info = psb_success_ + + if (present(pos)) then + select case(psb_toupper(trim(pos))) + case('PRE') + ipos_ = mld_pre_smooth_ + case('POST') + ipos_ = mld_post_smooth_ + case default + ipos_ = mld_pre_smooth_ + end select + else + ipos_ = mld_pre_smooth_ + end if + + select case(ipos_) + case(mld_pre_smooth_) + if (allocated(lev%sm)) then + if (allocated(lev%sm%sv)) then + if (.not.same_type_as(lev%sm%sv,val)) then + call lev%sm%sv%free(info) + deallocate(lev%sm%sv,stat=info) + if (info /= 0) then + info = 3111 + return + end if + end if + end if + + if (.not.allocated(lev%sm%sv)) then +#ifdef HAVE_MOLD + allocate(lev%sm%sv,mold=val,stat=info) +#else + allocate(lev%sm%sv,source=val,stat=info) +#endif + if (info /= 0) then + info = 3111 + return + end if + end if + call lev%sm%sv%default() + else + info = 3111 + write(psb_err_unit,*) name,& + &': Error: uninitialized preconditioner component,',& + &' should call MLD_PRECINIT/MLD_PRECSET' + return + + end if + + case(mld_post_smooth_) + + if (allocated(lev%sm2a)) then + if (allocated(lev%sm2a%sv)) then + if (.not.same_type_as(lev%sm2a%sv,val)) then + call lev%sm2a%sv%free(info) + deallocate(lev%sm2a%sv,stat=info) + if (info /= 0) then + info = 3111 + return + end if + end if + end if + if (.not.allocated(lev%sm2a%sv)) then +#ifdef HAVE_MOLD + allocate(lev%sm2a%sv,mold=val,stat=info) +#else + allocate(lev%sm2a%sv,source=val,stat=info) +#endif + if (info /= 0) then + info = 3111 + return + end if + end if + call lev%sm2a%sv%default() + + else + info = 3111 + write(psb_err_unit,*) name,& + &': Error: uninitialized preconditioner component,',& + &' should call MLD_PRECINIT/MLD_PRECSET' + return + + end if + + end select + +end subroutine mld_d_base_onelev_setsv + diff --git a/mlprec/impl/mld_dprecset.F90 b/mlprec/impl/mld_dprecset.F90 index adb06da7..cc51826b 100644 --- a/mlprec/impl/mld_dprecset.F90 +++ b/mlprec/impl/mld_dprecset.F90 @@ -818,7 +818,8 @@ subroutine mld_dprecsetsm(p,val,info,ilev,pos) if (.not.same_type_as(p%precv(ilev_)%sm2a,val)) then call p%precv(ilev_)%sm2a%free(info) deallocate(p%precv(ilev_)%sm2a, stat=info) - endif + endif + end if if (.not.allocated(p%precv(ilev_)%sm2a)) then #ifdef HAVE_MOLD allocate(p%precv(ilev_)%sm2a,mold=val) diff --git a/mlprec/mld_d_onelev_mod.f90 b/mlprec/mld_d_onelev_mod.f90 index 82d8575a..32f4c119 100644 --- a/mlprec/mld_d_onelev_mod.f90 +++ b/mlprec/mld_d_onelev_mod.f90 @@ -145,7 +145,10 @@ module mld_d_onelev_mod procedure, pass(lv) :: cseti => mld_d_base_onelev_cseti procedure, pass(lv) :: csetr => mld_d_base_onelev_csetr procedure, pass(lv) :: csetc => mld_d_base_onelev_csetc - generic, public :: set => seti, setr, setc, cseti, csetr, csetc + procedure, pass(lv) :: setsm => mld_d_base_onelev_setsm + procedure, pass(lv) :: setsv => mld_d_base_onelev_setsv + generic, public :: set => seti, setr, setc,& + & cseti, csetr, csetc, setsm, setsv procedure, pass(lv) :: sizeof => d_base_onelev_sizeof procedure, pass(lv) :: get_nzeros => d_base_onelev_get_nzeros procedure, nopass :: stringval => mld_stringval @@ -229,6 +232,34 @@ module mld_d_onelev_mod end subroutine mld_d_base_onelev_seti end interface + interface + subroutine mld_d_base_onelev_setsm(lv,val,info,pos) + import :: psb_dpk_, mld_d_onelev_type, mld_d_base_smoother_type, & + & psb_ipk_, psb_long_int_k_, psb_desc_type + Implicit None + + ! Arguments + class(mld_d_onelev_type), target, intent(inout) :: lv + class(mld_d_base_smoother_type), intent(in) :: val + integer(psb_ipk_), intent(out) :: info + character(len=*), optional, intent(in) :: pos + end subroutine mld_d_base_onelev_setsm + end interface + + interface + subroutine mld_d_base_onelev_setsv(lv,val,info,pos) + import :: psb_dpk_, mld_d_onelev_type, mld_d_base_solver_type, & + & psb_ipk_, psb_long_int_k_, psb_desc_type + Implicit None + + ! Arguments + class(mld_d_onelev_type), target, intent(inout) :: lv + class(mld_d_base_solver_type), intent(in) :: val + integer(psb_ipk_), intent(out) :: info + character(len=*), optional, intent(in) :: pos + end subroutine mld_d_base_onelev_setsv + end interface + interface subroutine mld_d_base_onelev_setc(lv,what,val,info,pos) import :: psb_dspmat_type, psb_d_vect_type, psb_d_base_vect_type, & From e04303e77be84b0043062197c54b33d299b19779 Mon Sep 17 00:00:00 2001 From: Salvatore Filippone Date: Fri, 13 May 2016 15:28:29 +0000 Subject: [PATCH 10/17] mld2p4-smooth-2side: mld_d_base_onelev_cseti.F90 mld_d_base_onelev_cseti.f90 mld_d_base_onelev_seti.F90 mld_d_base_onelev_seti.f90 Second refactor step: prepare to include Sm and SV in SETI. --- .../{mld_d_base_onelev_cseti.f90 => mld_d_base_onelev_cseti.F90} | 0 .../{mld_d_base_onelev_seti.f90 => mld_d_base_onelev_seti.F90} | 0 2 files changed, 0 insertions(+), 0 deletions(-) rename mlprec/impl/level/{mld_d_base_onelev_cseti.f90 => mld_d_base_onelev_cseti.F90} (100%) rename mlprec/impl/level/{mld_d_base_onelev_seti.f90 => mld_d_base_onelev_seti.F90} (100%) diff --git a/mlprec/impl/level/mld_d_base_onelev_cseti.f90 b/mlprec/impl/level/mld_d_base_onelev_cseti.F90 similarity index 100% rename from mlprec/impl/level/mld_d_base_onelev_cseti.f90 rename to mlprec/impl/level/mld_d_base_onelev_cseti.F90 diff --git a/mlprec/impl/level/mld_d_base_onelev_seti.f90 b/mlprec/impl/level/mld_d_base_onelev_seti.F90 similarity index 100% rename from mlprec/impl/level/mld_d_base_onelev_seti.f90 rename to mlprec/impl/level/mld_d_base_onelev_seti.F90 From df01dcfebd3c5cb5ffb4af383ab62703772ce881 Mon Sep 17 00:00:00 2001 From: Salvatore Filippone Date: Fri, 13 May 2016 16:30:26 +0000 Subject: [PATCH 11/17] mld2p4-smooth-2side: mlprec/impl/level/mld_d_base_onelev_cseti.F90 mlprec/impl/level/mld_d_base_onelev_seti.F90 mlprec/impl/mld_dcprecset.F90 mlprec/impl/mld_dprecset.F90 tests/pdegen/runs/ppde.inp Done refactoring of SM and SV in SETI. --- mlprec/impl/level/mld_d_base_onelev_cseti.F90 | 111 ++- mlprec/impl/level/mld_d_base_onelev_seti.F90 | 137 +++- mlprec/impl/mld_dcprecset.F90 | 509 ++------------ mlprec/impl/mld_dprecset.F90 | 649 ++---------------- tests/pdegen/runs/ppde.inp | 2 +- 5 files changed, 329 insertions(+), 1079 deletions(-) diff --git a/mlprec/impl/level/mld_d_base_onelev_cseti.F90 b/mlprec/impl/level/mld_d_base_onelev_cseti.F90 index d23edb64..9e28388f 100644 --- a/mlprec/impl/level/mld_d_base_onelev_cseti.F90 +++ b/mlprec/impl/level/mld_d_base_onelev_cseti.F90 @@ -40,6 +40,24 @@ subroutine mld_d_base_onelev_cseti(lv,what,val,info,pos) use psb_base_mod use mld_d_onelev_mod, mld_protect_name => mld_d_base_onelev_cseti + use mld_d_jac_smoother + use mld_d_as_smoother + use mld_d_diag_solver + use mld_d_ilu_solver + use mld_d_id_solver + use mld_d_gs_solver +#if defined(HAVE_UMF_) + use mld_d_umf_solver +#endif +#if defined(HAVE_SLUDIST_) + use mld_d_sludist_solver +#endif +#if defined(HAVE_SLU_) + use mld_d_slu_solver +#endif +#if defined(HAVE_MUMPS_) + use mld_d_mumps_solver +#endif Implicit None @@ -52,7 +70,26 @@ subroutine mld_d_base_onelev_cseti(lv,what,val,info,pos) ! Local integer(psb_ipk_) :: ipos_, err_act character(len=20) :: name='d_base_onelev_cseti' - + type(mld_d_base_smoother_type) :: mld_d_base_smoother_mold + type(mld_d_jac_smoother_type) :: mld_d_jac_smoother_mold + type(mld_d_as_smoother_type) :: mld_d_as_smoother_mold + type(mld_d_diag_solver_type) :: mld_d_diag_solver_mold + type(mld_d_ilu_solver_type) :: mld_d_ilu_solver_mold + type(mld_d_id_solver_type) :: mld_d_id_solver_mold + type(mld_d_gs_solver_type) :: mld_d_gs_solver_mold +#if defined(HAVE_UMF_) + type(mld_d_umf_solver_type) :: mld_d_umf_solver_mold +#endif +#if defined(HAVE_SLUDIST_) + type(mld_d_sludist_solver_type) :: mld_d_sludist_solver_mold +#endif +#if defined(HAVE_SLU_) + type(mld_d_slu_solver_type) :: mld_d_slu_solver_mold +#endif +#if defined(HAVE_MUMPS_) + type(mld_d_mumps_solver_type) :: mld_d_mumps_solver_mold +#endif + call psb_erractionsave(err_act) info = psb_success_ @@ -70,6 +107,78 @@ subroutine mld_d_base_onelev_cseti(lv,what,val,info,pos) end if select case (psb_toupper(what)) + case ('SMOOTHER_TYPE') + select case (val) + case (mld_noprec_) + call lv%set(mld_d_base_smoother_mold,info,pos=pos) + if (info == 0) call lv%set(mld_d_id_solver_mold,info,pos=pos) + + case (mld_jac_) + call lv%set(mld_d_jac_smoother_mold,info,pos=pos) + if (info == 0) call lv%set(mld_d_diag_solver_mold,info,pos=pos) + + case (mld_bjac_) + call lv%set(mld_d_jac_smoother_mold,info,pos=pos) + if (info == 0) call lv%set(mld_d_ilu_solver_mold,info,pos=pos) + + case (mld_as_) + call lv%set(mld_d_as_smoother_mold,info,pos=pos) + if (info == 0) call lv%set(mld_d_ilu_solver_mold,info,pos=pos) + + case default + ! + ! Do nothing and hope for the best :) + ! + end select + if (allocated(lv%sm)) call lv%sm%default() + + case('SUB_SOLVE') + select case (val) + case (mld_f_none_) + call lv%set(mld_d_id_solver_mold,info,pos=pos) + + case (mld_diag_scale_) + call lv%set(mld_d_diag_solver_mold,info,pos=pos) + + case (mld_gs_) + call lv%set(mld_d_gs_solver_mold,info,pos=pos) + + case (mld_ilu_n_,mld_milu_n_,mld_ilu_t_) + call lv%set(mld_d_ilu_solver_mold,info,pos=pos) + if (info == 0) then + select case(ipos_) + case(mld_pre_smooth_) + call lv%sm%sv%set('SUB_SOLVE',val,info) + case (mld_post_smooth_) + if (allocated(lv%sm2a)) call lv%sm2a%sv%set('SUB_SOLVE',val,info) + case default + ! Impossible!! + info = psb_err_internal_error_ + end select + end if +#ifdef HAVE_SLU_ + case (mld_slu_) + call lv%set(mld_d_slu_solver_mold,info,pos=pos) +#endif +#ifdef HAVE_SLUDIST_ + case (mld_sludist_) + call lv%set(mld_d_sludist_solver_mold,info,pos=pos) +#endif +#ifdef HAVE_MUMPS_ + case (mld_mumps_) + call lv%set(mld_d_mumps_solver_mold,info,pos=pos) +#endif + +#ifdef HAVE_UMF_ + case (mld_umf_) + call lv%set(mld_d_umf_solver_mold,info,pos=pos) +#endif + case default + ! + ! Do nothing and hope for the best :) + ! + end select + case ('SMOOTHER_SWEEPS') lv%parms%sweeps = val diff --git a/mlprec/impl/level/mld_d_base_onelev_seti.F90 b/mlprec/impl/level/mld_d_base_onelev_seti.F90 index e181b8f0..f60432b0 100644 --- a/mlprec/impl/level/mld_d_base_onelev_seti.F90 +++ b/mlprec/impl/level/mld_d_base_onelev_seti.F90 @@ -40,6 +40,24 @@ subroutine mld_d_base_onelev_seti(lv,what,val,info,pos) use psb_base_mod use mld_d_onelev_mod, mld_protect_name => mld_d_base_onelev_seti + use mld_d_jac_smoother + use mld_d_as_smoother + use mld_d_diag_solver + use mld_d_ilu_solver + use mld_d_id_solver + use mld_d_gs_solver +#if defined(HAVE_UMF_) + use mld_d_umf_solver +#endif +#if defined(HAVE_SLUDIST_) + use mld_d_sludist_solver +#endif +#if defined(HAVE_SLU_) + use mld_d_slu_solver +#endif +#if defined(HAVE_MUMPS_) + use mld_d_mumps_solver +#endif Implicit None @@ -52,12 +70,115 @@ subroutine mld_d_base_onelev_seti(lv,what,val,info,pos) ! Local integer(psb_ipk_) :: ipos_, err_act character(len=20) :: name='d_base_onelev_seti' - + type(mld_d_base_smoother_type) :: mld_d_base_smoother_mold + type(mld_d_jac_smoother_type) :: mld_d_jac_smoother_mold + type(mld_d_as_smoother_type) :: mld_d_as_smoother_mold + type(mld_d_diag_solver_type) :: mld_d_diag_solver_mold + type(mld_d_ilu_solver_type) :: mld_d_ilu_solver_mold + type(mld_d_id_solver_type) :: mld_d_id_solver_mold + type(mld_d_gs_solver_type) :: mld_d_gs_solver_mold +#if defined(HAVE_UMF_) + type(mld_d_umf_solver_type) :: mld_d_umf_solver_mold +#endif +#if defined(HAVE_SLUDIST_) + type(mld_d_sludist_solver_type) :: mld_d_sludist_solver_mold +#endif +#if defined(HAVE_SLU_) + type(mld_d_slu_solver_type) :: mld_d_slu_solver_mold +#endif +#if defined(HAVE_MUMPS_) + type(mld_d_mumps_solver_type) :: mld_d_mumps_solver_mold +#endif + call psb_erractionsave(err_act) info = psb_success_ - + if (present(pos)) then + select case(psb_toupper(trim(pos))) + case('PRE') + ipos_ = mld_pre_smooth_ + case('POST') + ipos_ = mld_post_smooth_ + case default + ipos_ = mld_pre_smooth_ + end select + else + ipos_ = mld_pre_smooth_ + end if + select case (what) + case (mld_smoother_type_) + select case (val) + case (mld_noprec_) + call lv%set(mld_d_base_smoother_mold,info,pos=pos) + if (info == 0) call lv%set(mld_d_id_solver_mold,info,pos=pos) + + case (mld_jac_) + call lv%set(mld_d_jac_smoother_mold,info,pos=pos) + if (info == 0) call lv%set(mld_d_diag_solver_mold,info,pos=pos) + + case (mld_bjac_) + call lv%set(mld_d_jac_smoother_mold,info,pos=pos) + if (info == 0) call lv%set(mld_d_ilu_solver_mold,info,pos=pos) + + case (mld_as_) + call lv%set(mld_d_as_smoother_mold,info,pos=pos) + if (info == 0) call lv%set(mld_d_ilu_solver_mold,info,pos=pos) + + case default + ! + ! Do nothing and hope for the best :) + ! + end select + if (allocated(lv%sm)) call lv%sm%default() + + case(mld_sub_solve_) + select case (val) + case (mld_f_none_) + call lv%set(mld_d_id_solver_mold,info,pos=pos) + + case (mld_diag_scale_) + call lv%set(mld_d_diag_solver_mold,info,pos=pos) + + case (mld_gs_) + call lv%set(mld_d_gs_solver_mold,info,pos=pos) + + case (mld_ilu_n_,mld_milu_n_,mld_ilu_t_) + call lv%set(mld_d_ilu_solver_mold,info,pos=pos) + if (info == 0) then + select case(ipos_) + case(mld_pre_smooth_) + call lv%sm%sv%set('SUB_SOLVE',val,info) + case (mld_post_smooth_) + if (allocated(lv%sm2a)) call lv%sm2a%sv%set('SUB_SOLVE',val,info) + case default + ! Impossible!! + info = psb_err_internal_error_ + end select + end if +#ifdef HAVE_SLU_ + case (mld_slu_) + call lv%set(mld_d_slu_solver_mold,info,pos=pos) +#endif +#ifdef HAVE_SLUDIST_ + case (mld_sludist_) + call lv%set(mld_d_sludist_solver_mold,info,pos=pos) +#endif +#ifdef HAVE_MUMPS_ + case (mld_mumps_) + call lv%set(mld_d_mumps_solver_mold,info,pos=pos) +#endif + +#ifdef HAVE_UMF_ + case (mld_umf_) + call lv%set(mld_d_umf_solver_mold,info,pos=pos) +#endif + case default + ! + ! Do nothing and hope for the best :) + ! + end select + case (mld_smoother_sweeps_) lv%parms%sweeps = val lv%parms%sweeps_pre = val @@ -101,18 +222,6 @@ subroutine mld_d_base_onelev_seti(lv,what,val,info,pos) case default - if (present(pos)) then - select case(psb_toupper(trim(pos))) - case('PRE') - ipos_ = mld_pre_smooth_ - case('POST') - ipos_ = mld_post_smooth_ - case default - ipos_ = mld_pre_smooth_ - end select - else - ipos_ = mld_pre_smooth_ - end if select case(ipos_) case(mld_pre_smooth_) if (allocated(lv%sm)) then diff --git a/mlprec/impl/mld_dcprecset.F90 b/mlprec/impl/mld_dcprecset.F90 index 825220ff..191c655b 100644 --- a/mlprec/impl/mld_dcprecset.F90 +++ b/mlprec/impl/mld_dcprecset.F90 @@ -150,31 +150,13 @@ subroutine mld_dcprecseti(p,what,val,info,ilev,pos) ! ! Rules for fine level are slightly different. ! - select case(psb_toupper(trim(what))) - case('SMOOTHER_TYPE') - call onelev_set_smoother(p%precv(ilev_),val,info,pos=pos) - case('SUB_SOLVE') - call onelev_set_solver(p%precv(ilev_),val,info,pos=pos) - case('SMOOTHER_SWEEPS','ML_TYPE','AGGR_ALG','AGGR_ORD',& - & 'AGGR_KIND','SMOOTHER_POS','AGGR_OMEGA_ALG',& - & 'AGGR_EIG','SMOOTHER_SWEEPS_PRE',& - & 'SMOOTHER_SWEEPS_POST',& - & 'SUB_RESTR','SUB_PROL', & - & 'SUB_REN','SUB_OVR','SUB_FILLIN') - call p%precv(ilev_)%set(what,val,info,pos=pos) - - case default - call p%precv(ilev_)%set(what,val,info,pos=pos) - end select + call p%precv(ilev_)%set(what,val,info,pos=pos) else if (ilev_ > 1) then select case(psb_toupper(what)) - case('SMOOTHER_TYPE') - call onelev_set_smoother(p%precv(ilev_),val,info,pos=pos) - case('SUB_SOLVE') - call onelev_set_solver(p%precv(ilev_),val,info,pos=pos) - case('SMOOTHER_SWEEPS','ML_TYPE','AGGR_ALG','AGGR_ORD',& + case('SMOOTHER_TYPE','SUB_SOLVE','SMOOTHER_SWEEPS',& + & 'ML_TYPE','AGGR_ALG','AGGR_ORD',& & 'AGGR_KIND','SMOOTHER_POS','AGGR_OMEGA_ALG',& & 'AGGR_EIG','SMOOTHER_SWEEPS_PRE',& & 'SMOOTHER_SWEEPS_POST',& @@ -190,7 +172,7 @@ subroutine mld_dcprecseti(p,what,val,info,ilev,pos) info = -2 return end if - call onelev_set_solver(p%precv(ilev_),val,info,pos=pos) + call p%precv(ilev_)%set('SUB_SOLVE',val,info,pos=pos) case('COARSE_SOLVE') if (ilev_ /= nlev_) then write(psb_err_unit,*) name,& @@ -198,40 +180,36 @@ subroutine mld_dcprecseti(p,what,val,info,ilev,pos) info = -2 return end if - + if (nlev_ > 1) then call p%precv(nlev_)%set('COARSE_SOLVE',val,info,pos=pos) select case (val) case(mld_bjac_) - call onelev_set_smoother(p%precv(nlev_),val,info,pos=pos) + call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos) #if defined(HAVE_UMF_) - call onelev_set_solver(p%precv(nlev_),mld_umf_,info,pos=pos) -#elif defined(HAVE_SLU_) - call onelev_set_solver(p%precv(nlev_),mld_slu_,info,pos=pos) + call p%precv(nlev_)%set('SUB_SOLVE',mld_umf_,info,pos=pos) +#elif defined(HAVE_SLU_) + call p%precv(nlev_)%set('SUB_SOLVE',mld_slu_,info,pos=pos) #elif defined(HAVE_MUMPS_) - call onelev_set_solver(p%precv(nlev_),mld_mumps_,info,pos=pos) -#else - call onelev_set_solver(p%precv(nlev_),mld_ilu_n_,info,pos=pos) + call p%precv(nlev_)%set('SUB_SOLVE',mld_mumps_,info,pos=pos) +#else + call p%precv(nlev_)%set('SUB_SOLVE',mld_ilu_n_,info,pos=pos) #endif call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos) case(mld_umf_, mld_slu_,mld_ilu_n_, mld_ilu_t_,mld_milu_n_) - call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info,pos=pos) - call onelev_set_solver(p%precv(nlev_),val,info,pos=pos) + call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos) + call p%precv(nlev_)%set('SUB_SOLVE',val,info,pos=pos) call p%precv(nlev_)%set('COARSE_MAT',mld_repl_mat_,info,pos=pos) - case(mld_sludist_) - call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info,pos=pos) - call onelev_set_solver(p%precv(nlev_),val,info,pos=pos) - call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos) - case(mld_mumps_) - call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info,pos=pos) - call onelev_set_solver(p%precv(nlev_),val,info,pos=pos) + case(mld_sludist_,mld_mumps_) + call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos) + call p%precv(nlev_)%set('SUB_SOLVE',val,info,pos=pos) call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos) case(mld_jac_) - call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info,pos=pos) - call onelev_set_solver(p%precv(nlev_),mld_diag_scale_,info,pos=pos) + call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos) + call p%precv(nlev_)%set('SUB_SOLVE',mld_diag_scale_,info,pos=pos) call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos) end select - + endif case('COARSE_SWEEPS') if (ilev_ /= nlev_) then @@ -250,6 +228,7 @@ subroutine mld_dcprecseti(p,what,val,info,ilev,pos) return end if call p%precv(nlev_)%set('SUB_FILLIN',val,info,pos=pos) + case default call p%precv(ilev_)%set(what,val,info,pos=pos) end select @@ -262,33 +241,12 @@ subroutine mld_dcprecseti(p,what,val,info,ilev,pos) ! levels ! select case(psb_toupper(trim(what))) - case('SUB_SOLVE') - do ilev_=1,max(1,nlev_-1) - if (.not.allocated(p%precv(ilev_)%sm)) then - write(psb_err_unit,*) name,& - & ': Error: uninitialized preconditioner component,',& - & ' should call MLD_PRECINIT' - info = -1 - return - endif - call onelev_set_solver(p%precv(ilev_),val,info,pos=pos) - - end do - - case('SUB_RESTR','SUB_PROL',& - & 'SUB_REN','SUB_OVR','SUB_FILLIN') + case('SUB_SOLVE','SUB_RESTR','SUB_PROL',& + & 'SUB_REN','SUB_OVR','SUB_FILLIN',& + & 'SMOOTHER_SWEEPS','SMOOTHER_TYPE') do ilev_=1,max(1,nlev_-1) call p%precv(ilev_)%set(what,val,info,pos=pos) - end do - - case('SMOOTHER_SWEEPS') - do ilev_=1,max(1,nlev_-1) - call p%precv(ilev_)%set(what,val,info,pos=pos) - end do - - case('SMOOTHER_TYPE') - do ilev_=1,max(1,nlev_-1) - call onelev_set_smoother(p%precv(ilev_),val,info,pos=pos) + if (info /= 0) return end do case('ML_TYPE','AGGR_ALG','AGGR_ORD','AGGR_KIND',& @@ -297,6 +255,7 @@ subroutine mld_dcprecseti(p,what,val,info,ilev,pos) & 'AGGR_EIG','AGGR_FILTER') do ilev_=1,nlev_ call p%precv(ilev_)%set(what,val,info,pos=pos) + if (info /= 0) return end do case('COARSE_MAT') @@ -305,45 +264,40 @@ subroutine mld_dcprecseti(p,what,val,info,ilev,pos) end if case('COARSE_SOLVE') - if (nlev_ > 1) then + if (nlev_ > 1) then call p%precv(nlev_)%set('COARSE_SOLVE',val,info,pos=pos) select case (val) case(mld_bjac_) - call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info,pos=pos) + call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos) #if defined(HAVE_UMF_) - call onelev_set_solver(p%precv(nlev_),mld_umf_,info,pos=pos) -#elif defined(HAVE_SLU_) - call onelev_set_solver(p%precv(nlev_),mld_slu_,info,pos=pos) -#elif defined(HAVE_MUMPS_) - call onelev_set_solver(p%precv(nlev_),mld_mumps_,info,pos=pos) -#else - call onelev_set_solver(p%precv(nlev_),mld_ilu_n_,info,pos=pos) + call p%precv(nlev_)%set('SUB_SOLVE',mld_umf_,info,pos=pos) +#elif defined(HAVE_SLU_) + call p%precv(nlev_)%set('SUB_SOLVE',mld_slu_,info,pos=pos) +#elif defined(HAVE_MUMPS_) + call p%precv(nlev_)%set('SUB_SOLVE',mld_mumps_,info,pos=pos) +#else + call p%precv(nlev_)%set('SUB_SOLVE',mld_ilu_n_,info,pos=pos) #endif call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos) case(mld_umf_, mld_slu_,mld_ilu_n_, mld_ilu_t_,mld_milu_n_) - call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info,pos=pos) - call onelev_set_solver(p%precv(nlev_),val,info,pos=pos) + call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos) + call p%precv(nlev_)%set('SUB_SOLVE',val,info,pos=pos) call p%precv(nlev_)%set('COARSE_MAT',mld_repl_mat_,info,pos=pos) - case(mld_sludist_) - call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info,pos=pos) - call onelev_set_solver(p%precv(nlev_),val,info,pos=pos) + case(mld_sludist_,mld_mumps_) + call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos) + call p%precv(nlev_)%set('SUB_SOLVE',val,info,pos=pos) call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos) - case(mld_mumps_) - call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info,pos=pos) - call onelev_set_solver(p%precv(nlev_),val,info,pos=pos) - call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos) case(mld_jac_) - call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info,pos=pos) - call onelev_set_solver(p%precv(nlev_),mld_diag_scale_,info,pos=pos) + call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos) + call p%precv(nlev_)%set('SUB_SOLVE',mld_diag_scale_,info,pos=pos) call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos) end select - endif case('COARSE_SUBSOLVE') if (nlev_ > 1) then - call onelev_set_solver(p%precv(nlev_),val,info,pos=pos) + call p%precv(nlev_)%set('SUB_SOLVE',val,info,pos=pos) endif case('COARSE_SWEEPS') @@ -356,6 +310,7 @@ subroutine mld_dcprecseti(p,what,val,info,ilev,pos) if (nlev_ > 1) then call p%precv(nlev_)%set('SUB_FILLIN',val,info,pos=pos) end if + case default do ilev_=1,nlev_ call p%precv(ilev_)%set(what,val,info,pos=pos) @@ -364,382 +319,6 @@ subroutine mld_dcprecseti(p,what,val,info,ilev,pos) endif -contains - - subroutine onelev_set_smoother(level,val,info,pos) - class(mld_d_onelev_type), intent(inout) :: level - integer(psb_ipk_), intent(in) :: val - integer(psb_ipk_), intent(out) :: info - character(len=*), optional, intent(in) :: pos - ! Local - integer(psb_ipk_) :: ipos_ - info = psb_success_ - if (present(pos)) then - select case(psb_toupper(trim(pos))) - case('PRE') - ipos_ = mld_pre_smooth_ - case('POST') - ipos_ = mld_post_smooth_ - case default - ipos_ = mld_pre_smooth_ - end select - else - ipos_ = mld_pre_smooth_ - end if - - - select case(ipos_) - case(mld_pre_smooth_) - call inner_set_smoother(level%sm,val,info) - case (mld_post_smooth_) - call inner_set_smoother(level%sm2a,val,info) - case default - ! Impossible!! - info = psb_err_internal_error_ - end select - end subroutine onelev_set_smoother - - - subroutine inner_set_smoother(sm,val,info) - class(mld_d_base_smoother_type), allocatable, intent(inout) :: sm - integer(psb_ipk_), intent(in) :: val - integer(psb_ipk_), intent(out) :: info - - ! - ! This here requires a bit more attention. - ! - select case (val) - case (mld_noprec_) - if (allocated(sm)) then - select type (sms => sm) - type is (mld_d_base_smoother_type) - ! do nothing - class default - call sm%free(info) - if (info == 0) deallocate(sm) - if (info == 0) allocate(mld_d_base_smoother_type ::& - & sm, stat=info) - if (info == 0) allocate(mld_d_id_solver_type ::& - & sm%sv, stat=info) - end select - else - allocate(mld_d_base_smoother_type ::& - & sm, stat=info) - if (info ==0) allocate(mld_d_id_solver_type ::& - & sm%sv, stat=info) - endif - - case (mld_jac_) - if (allocated(sm)) then - select type (sms => sm) - class is (mld_d_jac_smoother_type) - ! do nothing - class default - call sm%free(info) - if (info == 0) deallocate(sm) - if (info == 0) allocate(mld_d_jac_smoother_type :: & - & sm, stat=info) - if (info == 0) allocate(mld_d_diag_solver_type :: & - & sm%sv, stat=info) - end select - else - allocate(mld_d_jac_smoother_type :: sm, stat=info) - if (info == 0) allocate(mld_d_diag_solver_type ::& - & sm%sv, stat=info) - endif - - case (mld_bjac_) - if (allocated(sm)) then - select type (sms => sm) - class is (mld_d_jac_smoother_type) - ! do nothing - class default - call sm%free(info) - if (info == 0) deallocate(sm) - if (info == 0) allocate(mld_d_jac_smoother_type ::& - & sm, stat=info) - if (info == 0) allocate(mld_d_ilu_solver_type ::& - & sm%sv, stat=info) - end select - else - allocate(mld_d_jac_smoother_type :: sm, stat=info) - if (info == 0) allocate(mld_d_ilu_solver_type ::& - & sm%sv, stat=info) - endif - - case (mld_as_) - if (allocated(sm)) then - select type (sms => sm) - class is (mld_d_as_smoother_type) - ! do nothing - class default - call sm%free(info) - if (info == 0) deallocate(sm) - if (info == 0) allocate(mld_d_as_smoother_type ::& - & sm, stat=info) - if (info == 0) allocate(mld_d_ilu_solver_type ::& - & sm%sv, stat=info) - end select - else - allocate(mld_d_as_smoother_type :: sm, stat=info) - if (info == 0) allocate(mld_d_ilu_solver_type ::& - & sm%sv, stat=info) - endif - - case default - ! - ! Do nothing and hope for the best :) - ! - end select - if (allocated(sm)) & - & call sm%default() - end subroutine inner_set_smoother - - - subroutine onelev_set_solver(level,val,info,pos) - class(mld_d_onelev_type), intent(inout) :: level - integer(psb_ipk_), intent(in) :: val - integer(psb_ipk_), intent(out) :: info - character(len=*), optional, intent(in) :: pos - ! Local - integer(psb_ipk_) :: ipos_ - info = psb_success_ - if (present(pos)) then - select case(psb_toupper(trim(pos))) - case('PRE') - ipos_ = mld_pre_smooth_ - case('POST') - ipos_ = mld_post_smooth_ - case default - ipos_ = mld_pre_smooth_ - end select - else - ipos_ = mld_pre_smooth_ - end if - - select case(ipos_) - case(mld_pre_smooth_) - call inner_set_solver(level%sm,val,info) - case (mld_post_smooth_) - call inner_set_solver(level%sm2a,val,info) - case default - ! Impossible!! - info = psb_err_internal_error_ - end select - - end subroutine onelev_set_solver - - - subroutine inner_set_solver(sm,val,info) - class(mld_d_base_smoother_type), allocatable, intent(inout) :: sm - integer(psb_ipk_), intent(in) :: val - integer(psb_ipk_), intent(out) :: info - ! - ! Yes, the first argument is a smoother, to catch the case where - ! user is trying to set a solver on a not-yet-allocated smoother. - ! - select case (val) - case (mld_f_none_) - if (allocated(sm)) then - if (allocated(sm%sv)) then - select type (sv => sm%sv) - class is (mld_d_id_solver_type) - ! do nothing - class default - call sm%sv%free(info) - if (info == 0) deallocate(sm%sv) - if (info == 0) allocate(mld_d_id_solver_type ::& - & sm%sv, stat=info) - end select - else - allocate(mld_d_id_solver_type :: sm%sv, stat=info) - endif - if (allocated(sm)) then - if (allocated(sm%sv)) & - & call sm%sv%default() - end if - else - write(0,*) 'Calling set_solver without a smoother?' - info = -5 - end if - - case (mld_diag_scale_) - if (allocated(sm)) then - if (allocated(sm%sv)) then - select type (sv => sm%sv) - class is (mld_d_diag_solver_type) - ! do nothing - class default - call sm%sv%free(info) - if (info == 0) deallocate(sm%sv) - if (info == 0) allocate(mld_d_diag_solver_type ::& - & sm%sv, stat=info) - end select - else - allocate(mld_d_diag_solver_type :: sm%sv, stat=info) - endif - if (allocated(sm)) then - if (allocated(sm%sv)) & - & call sm%sv%default() - end if - else - write(0,*) 'Calling set_solver without a smoother?' - info = -5 - end if - - case (mld_gs_) - if (allocated(sm)) then - if (allocated(sm%sv)) then - select type (sv => sm%sv) - class is (mld_d_gs_solver_type) - ! do nothing - class default - call sm%sv%free(info) - if (info == 0) deallocate(sm%sv) - if (info == 0) allocate(mld_d_gs_solver_type ::& - & sm%sv, stat=info) - end select - else - allocate(mld_d_gs_solver_type :: sm%sv, stat=info) - endif - if (allocated(sm%sv)) then - call sm%sv%default() - else - endif - - else - write(0,*) 'Calling set_solver without a smoother?' - info = -5 - end if - - case (mld_ilu_n_,mld_milu_n_,mld_ilu_t_) - if (allocated(sm)) then - if (allocated(sm%sv)) then - select type (sv => sm%sv) - class is (mld_d_ilu_solver_type) - ! do nothing - class default - call sm%sv%free(info) - if (info == 0) deallocate(sm%sv) - if (info == 0) allocate(mld_d_ilu_solver_type ::& - & sm%sv, stat=info) - end select - else - allocate(mld_d_ilu_solver_type :: sm%sv, stat=info) - endif - if (allocated(sm)) then - if (allocated(sm%sv)) & - & call sm%sv%default() - end if - call sm%sv%set('SUB_SOLVE',val,info) - else - write(0,*) 'Calling set_solver without a smoother?' - info = -5 - end if - -#ifdef HAVE_SLU_ - case (mld_slu_) - if (allocated(sm)) then - if (allocated(sm%sv)) then - select type (sv => sm%sv) - class is (mld_d_slu_solver_type) - ! do nothing - class default - call sm%sv%free(info) - if (info == 0) deallocate(sm%sv) - if (info == 0) allocate(mld_d_slu_solver_type ::& - & sm%sv, stat=info) - end select - else - allocate(mld_d_slu_solver_type :: sm%sv, stat=info) - endif - if (allocated(sm)) then - if (allocated(sm%sv)) & - & call sm%sv%default() - end if - else - write(0,*) 'Calling set_solver without a smoother?' - info = -5 - end if -#endif -#ifdef HAVE_MUMPS_ - case (mld_mumps_) - if (allocated(sm%sv)) then - select type (sv => sm%sv) - class is (mld_d_mumps_solver_type) - ! do nothing - class default - call sm%sv%free(info) - if (info == 0) deallocate(sm%sv) - if (info == 0) allocate(mld_d_mumps_solver_type ::& - & sm%sv, stat=info) - end select - else - allocate(mld_d_mumps_solver_type :: sm%sv, stat=info) - endif - if (allocated(sm)) then - if (allocated(sm%sv)) & - & call sm%sv%default() - end if -#endif - -#ifdef HAVE_UMF_ - case (mld_umf_) - if (allocated(sm)) then - if (allocated(sm%sv)) then - select type (sv => sm%sv) - class is (mld_d_umf_solver_type) - ! do nothing - class default - call sm%sv%free(info) - if (info == 0) deallocate(sm%sv) - if (info == 0) allocate(mld_d_umf_solver_type ::& - & sm%sv, stat=info) - end select - else - allocate(mld_d_umf_solver_type :: sm%sv, stat=info) - endif - if (allocated(sm)) then - if (allocated(sm%sv)) & - & call sm%sv%default() - end if - else - write(0,*) 'Calling set_solver without a smoother?' - info = -5 - end if -#endif -#ifdef HAVE_SLUDIST_ - case (mld_sludist_) - if (allocated(sm)) then - if (allocated(sm%sv)) then - select type (sv => sm%sv) - class is (mld_d_sludist_solver_type) - ! do nothing - class default - call sm%sv%free(info) - if (info == 0) deallocate(sm%sv) - if (info == 0) allocate(mld_d_sludist_solver_type ::& - & sm%sv, stat=info) - end select - else - allocate(mld_d_sludist_solver_type :: sm%sv, stat=info) - endif - if (allocated(sm)) then - if (allocated(sm%sv)) & - & call sm%sv%default() - end if - else - write(0,*) 'Calling set_solver without a smoother?' - info = -5 - end if -#endif - case default - ! - ! Do nothing and hope for the best :) - ! - end select - end subroutine inner_set_solver - end subroutine mld_dcprecseti ! diff --git a/mlprec/impl/mld_dprecset.F90 b/mlprec/impl/mld_dprecset.F90 index cc51826b..c11ba37d 100644 --- a/mlprec/impl/mld_dprecset.F90 +++ b/mlprec/impl/mld_dprecset.F90 @@ -148,34 +148,16 @@ subroutine mld_dprecseti(p,what,val,info,ilev,pos) if (present(ilev)) then if (ilev_ == 1) then - ! - ! Rules for fine level are slightly different. - ! - select case(what) - case(mld_smoother_type_) - call onelev_set_smoother(p%precv(ilev_),val,info,pos=pos) - case(mld_sub_solve_) - call onelev_set_solver(p%precv(ilev_),val,info,pos=pos) - case(mld_smoother_sweeps_,mld_ml_type_,mld_aggr_alg_,mld_aggr_ord_,& - & mld_aggr_kind_,mld_smoother_pos_,mld_aggr_omega_alg_,mld_aggr_eig_,& - & mld_smoother_sweeps_pre_,mld_smoother_sweeps_post_,& - & mld_sub_restr_,mld_sub_prol_, & - & mld_sub_ren_,mld_sub_ovr_,mld_sub_fillin_) - call p%precv(ilev_)%set(what,val,info,pos=pos) - case default - call p%precv(ilev_)%set(what,val,info,pos=pos) - end select + call p%precv(ilev_)%set(what,val,info,pos=pos) else if (ilev_ > 1) then select case(what) - case(mld_smoother_type_) - call onelev_set_smoother(p%precv(ilev_),val,info,pos=pos) - case(mld_sub_solve_) - call onelev_set_solver(p%precv(ilev_),val,info,pos=pos) - case(mld_smoother_sweeps_,mld_ml_type_,mld_aggr_alg_,mld_aggr_ord_,& - & mld_aggr_kind_,mld_smoother_pos_,mld_aggr_omega_alg_,mld_aggr_eig_,& + case(mld_smoother_type_,mld_sub_solve_,mld_smoother_sweeps_,& + & mld_ml_type_,mld_aggr_alg_,mld_aggr_ord_,& + & mld_aggr_kind_,mld_smoother_pos_,& + & mld_aggr_omega_alg_,mld_aggr_eig_,& & mld_smoother_sweeps_pre_,mld_smoother_sweeps_post_,& & mld_sub_restr_,mld_sub_prol_, & & mld_sub_ren_,mld_sub_ovr_,mld_sub_fillin_,& @@ -189,7 +171,7 @@ subroutine mld_dprecseti(p,what,val,info,ilev,pos) info = -2 return end if - call onelev_set_solver(p%precv(ilev_),val,info,pos=pos) + call p%precv(ilev_)%set(mld_sub_solve_,val,info,pos=pos) case(mld_coarse_solve_) if (ilev_ /= nlev_) then write(psb_err_unit,*) name,& @@ -202,28 +184,28 @@ subroutine mld_dprecseti(p,what,val,info,ilev,pos) call p%precv(nlev_)%set(mld_coarse_solve_,val,info,pos=pos) select case (val) case(mld_bjac_) - call onelev_set_smoother(p%precv(nlev_),val,info,pos=pos) + call p%precv(nlev_)%set(mld_smoother_type_,val,info,pos=pos) #if defined(HAVE_UMF_) - call onelev_set_solver(p%precv(nlev_),mld_umf_,info,pos=pos) + call p%precv(nlev_)%set(mld_sub_solve_,mld_umf_,info,pos=pos) #elif defined(HAVE_SLU_) - call onelev_set_solver(p%precv(nlev_),mld_slu_,info,pos=pos) + call p%precv(nlev_)%set(mld_sub_solve_,mld_slu_,info,pos=pos) #elif defined(HAVE_MUMPS_) - call onelev_set_solver(p%precv(nlev_),mld_mumps_,info,pos=pos) + call p%precv(nlev_)%set(mld_sub_solve_,mld_mumps_,info,pos=pos) #else - call onelev_set_solver(p%precv(nlev_),mld_ilu_n_,info,pos=pos) + call p%precv(nlev_)%set(mld_sub_solve_,mld_ilu_n_,info,pos=pos) #endif call p%precv(nlev_)%set(mld_coarse_mat_,mld_distr_mat_,info,pos=pos) case(mld_umf_, mld_slu_,mld_ilu_n_, mld_ilu_t_,mld_milu_n_) - call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info,pos=pos) - call onelev_set_solver(p%precv(nlev_),val,info,pos=pos) + call p%precv(nlev_)%set(mld_smoother_type_,mld_bjac_,info,pos=pos) + call p%precv(nlev_)%set(mld_sub_solve_,val,info,pos=pos) call p%precv(nlev_)%set(mld_coarse_mat_,mld_repl_mat_,info,pos=pos) case(mld_sludist_,mld_mumps_) - call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info,pos=pos) - call onelev_set_solver(p%precv(nlev_),val,info,pos=pos) + call p%precv(nlev_)%set(mld_smoother_type_,mld_bjac_,info,pos=pos) + call p%precv(nlev_)%set(mld_sub_solve_,val,info,pos=pos) call p%precv(nlev_)%set(mld_coarse_mat_,mld_distr_mat_,info,pos=pos) case(mld_jac_) - call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info,pos=pos) - call onelev_set_solver(p%precv(nlev_),mld_diag_scale_,info,pos=pos) + call p%precv(nlev_)%set(mld_smoother_type_,mld_bjac_,info,pos=pos) + call p%precv(nlev_)%set(mld_sub_solve_,mld_diag_scale_,info,pos=pos) call p%precv(nlev_)%set(mld_coarse_mat_,mld_distr_mat_,info,pos=pos) end select @@ -257,33 +239,12 @@ subroutine mld_dprecseti(p,what,val,info,ilev,pos) ! levels ! select case(what) - case(mld_sub_solve_) + case(mld_sub_solve_,mld_sub_restr_,mld_sub_prol_,& + & mld_sub_ren_,mld_sub_ovr_,mld_sub_fillin_,& + & mld_smoother_sweeps_,mld_smoother_type_) do ilev_=1,max(1,nlev_-1) - if (.not.allocated(p%precv(ilev_)%sm)) then - write(psb_err_unit,*) name,& - & ': Error: uninitialized preconditioner component,',& - & ' should call MLD_PRECINIT' - info = -1 - return - endif - call onelev_set_solver(p%precv(ilev_),val,info,pos=pos) - - end do - - case(mld_sub_restr_,mld_sub_prol_,& - & mld_sub_ren_,mld_sub_ovr_,mld_sub_fillin_) - do ilev_=1,max(1,nlev_-1) - call p%precv(ilev_)%set(what,val,info,pos=pos) - end do - - case(mld_smoother_sweeps_) - do ilev_=1,max(1,nlev_-1) - call p%precv(ilev_)%set(what,val,info,pos=pos) - end do - - case(mld_smoother_type_) - do ilev_=1,max(1,nlev_-1) - call onelev_set_smoother(p%precv(ilev_),val,info,pos=pos) + call p%precv(ilev_)%set(mld_smoother_type_,val,info,pos=pos) + if (info /= 0) return end do case(mld_ml_type_,mld_aggr_alg_,mld_aggr_ord_,mld_aggr_kind_,& @@ -305,30 +266,30 @@ subroutine mld_dprecseti(p,what,val,info,ilev,pos) call p%precv(nlev_)%set(mld_coarse_solve_,val,info,pos=pos) select case (val) case(mld_bjac_) - call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info,pos=pos) + call p%precv(nlev_)%set(mld_smoother_type_,mld_bjac_,info,pos=pos) #if defined(HAVE_UMF_) - call onelev_set_solver(p%precv(nlev_),mld_umf_,info,pos=pos) + call p%precv(nlev_)%set(mld_sub_solve_,mld_umf_,info,pos=pos) #elif defined(HAVE_SLU_) - call onelev_set_solver(p%precv(nlev_),mld_slu_,info,pos=pos) + call p%precv(nlev_)%set(mld_sub_solve_,mld_slu_,info,pos=pos) #else - call onelev_set_solver(p%precv(nlev_),mld_ilu_n_,info,pos=pos) + call p%precv(nlev_)%set(mld_sub_solve_,mld_ilu_n_,info,pos=pos) #endif call p%precv(nlev_)%set(mld_coarse_mat_,mld_distr_mat_,info,pos=pos) case(mld_umf_, mld_slu_,mld_ilu_n_, mld_ilu_t_,mld_milu_n_) - call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info,pos=pos) - call onelev_set_solver(p%precv(nlev_),val,info,pos=pos) + call p%precv(nlev_)%set(mld_smoother_type_,mld_bjac_,info,pos=pos) + call p%precv(nlev_)%set(mld_sub_solve_,val,info,pos=pos) call p%precv(nlev_)%set(mld_coarse_mat_,mld_repl_mat_,info,pos=pos) case(mld_sludist_) - call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info,pos=pos) - call onelev_set_solver(p%precv(nlev_),val,info,pos=pos) + call p%precv(nlev_)%set(mld_smoother_type_,mld_bjac_,info,pos=pos) + call p%precv(nlev_)%set(mld_sub_solve_,val,info,pos=pos) call p%precv(nlev_)%set(mld_coarse_mat_,mld_distr_mat_,info,pos=pos) case(mld_mumps_) - call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info,pos=pos) - call onelev_set_solver(p%precv(nlev_),val,info,pos=pos) + call p%precv(nlev_)%set(mld_smoother_type_,mld_bjac_,info,pos=pos) + call p%precv(nlev_)%set(mld_sub_solve_,val,info,pos=pos) call p%precv(nlev_)%set(mld_coarse_mat_,mld_distr_mat_,info,pos=pos) case(mld_jac_) - call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info,pos=pos) - call onelev_set_solver(p%precv(nlev_),mld_diag_scale_,info,pos=pos) + call p%precv(nlev_)%set(mld_smoother_type_,mld_bjac_,info,pos=pos) + call p%precv(nlev_)%set(mld_sub_solve_,mld_diag_scale_,info,pos=pos) call p%precv(nlev_)%set(mld_coarse_mat_,mld_distr_mat_,info,pos=pos) end select @@ -336,7 +297,7 @@ subroutine mld_dprecseti(p,what,val,info,ilev,pos) case(mld_coarse_subsolve_) if (nlev_ > 1) then - call onelev_set_solver(p%precv(nlev_),val,info,pos=pos) + call p%precv(nlev_)%set(mld_sub_solve_,val,info,pos=pos) endif case(mld_coarse_sweeps_) @@ -357,382 +318,6 @@ subroutine mld_dprecseti(p,what,val,info,ilev,pos) endif -contains - - subroutine onelev_set_smoother(level,val,info,pos) - class(mld_d_onelev_type), intent(inout) :: level - integer(psb_ipk_), intent(in) :: val - integer(psb_ipk_), intent(out) :: info - character(len=*), optional, intent(in) :: pos - ! Local - integer(psb_ipk_) :: ipos_ - info = psb_success_ - if (present(pos)) then - select case(psb_toupper(trim(pos))) - case('PRE') - ipos_ = mld_pre_smooth_ - case('POST') - ipos_ = mld_post_smooth_ - case default - ipos_ = mld_pre_smooth_ - end select - else - ipos_ = mld_pre_smooth_ - end if - - - select case(ipos_) - case(mld_pre_smooth_) - call inner_set_smoother(level%sm,val,info) - case (mld_post_smooth_) - call inner_set_smoother(level%sm2a,val,info) - case default - ! Impossible!! - info = psb_err_internal_error_ - end select - end subroutine onelev_set_smoother - - - subroutine inner_set_smoother(sm,val,info) - class(mld_d_base_smoother_type), allocatable, intent(inout) :: sm - integer(psb_ipk_), intent(in) :: val - integer(psb_ipk_), intent(out) :: info - - ! - ! This here requires a bit more attention. - ! - select case (val) - case (mld_noprec_) - if (allocated(sm)) then - select type (sms => sm) - type is (mld_d_base_smoother_type) - ! do nothing - class default - call sm%free(info) - if (info == 0) deallocate(sm) - if (info == 0) allocate(mld_d_base_smoother_type ::& - & sm, stat=info) - if (info == 0) allocate(mld_d_id_solver_type ::& - & sm%sv, stat=info) - end select - else - allocate(mld_d_base_smoother_type ::& - & sm, stat=info) - if (info ==0) allocate(mld_d_id_solver_type ::& - & sm%sv, stat=info) - endif - - case (mld_jac_) - if (allocated(sm)) then - select type (sms => sm) - class is (mld_d_jac_smoother_type) - ! do nothing - class default - call sm%free(info) - if (info == 0) deallocate(sm) - if (info == 0) allocate(mld_d_jac_smoother_type :: & - & sm, stat=info) - if (info == 0) allocate(mld_d_diag_solver_type :: & - & sm%sv, stat=info) - end select - else - allocate(mld_d_jac_smoother_type :: sm, stat=info) - if (info == 0) allocate(mld_d_diag_solver_type ::& - & sm%sv, stat=info) - endif - - case (mld_bjac_) - if (allocated(sm)) then - select type (sms => sm) - class is (mld_d_jac_smoother_type) - ! do nothing - class default - call sm%free(info) - if (info == 0) deallocate(sm) - if (info == 0) allocate(mld_d_jac_smoother_type ::& - & sm, stat=info) - if (info == 0) allocate(mld_d_ilu_solver_type ::& - & sm%sv, stat=info) - end select - else - allocate(mld_d_jac_smoother_type :: sm, stat=info) - if (info == 0) allocate(mld_d_ilu_solver_type ::& - & sm%sv, stat=info) - endif - - case (mld_as_) - if (allocated(sm)) then - select type (sms => sm) - class is (mld_d_as_smoother_type) - ! do nothing - class default - call sm%free(info) - if (info == 0) deallocate(sm) - if (info == 0) allocate(mld_d_as_smoother_type ::& - & sm, stat=info) - if (info == 0) allocate(mld_d_ilu_solver_type ::& - & sm%sv, stat=info) - end select - else - allocate(mld_d_as_smoother_type :: sm, stat=info) - if (info == 0) allocate(mld_d_ilu_solver_type ::& - & sm%sv, stat=info) - endif - - case default - ! - ! Do nothing and hope for the best :) - ! - end select - if (allocated(sm)) & - & call sm%default() - end subroutine inner_set_smoother - - - subroutine onelev_set_solver(level,val,info,pos) - class(mld_d_onelev_type), intent(inout) :: level - integer(psb_ipk_), intent(in) :: val - integer(psb_ipk_), intent(out) :: info - character(len=*), optional, intent(in) :: pos - ! Local - integer(psb_ipk_) :: ipos_ - info = psb_success_ - if (present(pos)) then - select case(psb_toupper(trim(pos))) - case('PRE') - ipos_ = mld_pre_smooth_ - case('POST') - ipos_ = mld_post_smooth_ - case default - ipos_ = mld_pre_smooth_ - end select - else - ipos_ = mld_pre_smooth_ - end if - - select case(ipos_) - case(mld_pre_smooth_) - call inner_set_solver(level%sm,val,info) - case (mld_post_smooth_) - call inner_set_solver(level%sm2a,val,info) - case default - ! Impossible!! - info = psb_err_internal_error_ - end select - - end subroutine onelev_set_solver - - - subroutine inner_set_solver(sm,val,info) - class(mld_d_base_smoother_type), allocatable, intent(inout) :: sm - integer(psb_ipk_), intent(in) :: val - integer(psb_ipk_), intent(out) :: info - ! - ! Yes, the first argument is a smoother, to catch the case where - ! user is trying to set a solver on a not-yet-allocated smoother. - ! - select case (val) - case (mld_f_none_) - if (allocated(sm)) then - if (allocated(sm%sv)) then - select type (sv => sm%sv) - class is (mld_d_id_solver_type) - ! do nothing - class default - call sm%sv%free(info) - if (info == 0) deallocate(sm%sv) - if (info == 0) allocate(mld_d_id_solver_type ::& - & sm%sv, stat=info) - end select - else - allocate(mld_d_id_solver_type :: sm%sv, stat=info) - endif - if (allocated(sm)) then - if (allocated(sm%sv)) & - & call sm%sv%default() - end if - else - write(0,*) 'Calling set_solver without a smoother?' - info = -5 - end if - - case (mld_diag_scale_) - if (allocated(sm)) then - if (allocated(sm%sv)) then - select type (sv => sm%sv) - class is (mld_d_diag_solver_type) - ! do nothing - class default - call sm%sv%free(info) - if (info == 0) deallocate(sm%sv) - if (info == 0) allocate(mld_d_diag_solver_type ::& - & sm%sv, stat=info) - end select - else - allocate(mld_d_diag_solver_type :: sm%sv, stat=info) - endif - if (allocated(sm)) then - if (allocated(sm%sv)) & - & call sm%sv%default() - end if - else - write(0,*) 'Calling set_solver without a smoother?' - info = -5 - end if - - case (mld_gs_) - if (allocated(sm)) then - if (allocated(sm%sv)) then - select type (sv => sm%sv) - class is (mld_d_gs_solver_type) - ! do nothing - class default - call sm%sv%free(info) - if (info == 0) deallocate(sm%sv) - if (info == 0) allocate(mld_d_gs_solver_type ::& - & sm%sv, stat=info) - end select - else - allocate(mld_d_gs_solver_type :: sm%sv, stat=info) - endif - if (allocated(sm%sv)) then - call sm%sv%default() - else - endif - - else - write(0,*) 'Calling set_solver without a smoother?' - info = -5 - end if - - case (mld_ilu_n_,mld_milu_n_,mld_ilu_t_) - if (allocated(sm)) then - if (allocated(sm%sv)) then - select type (sv => sm%sv) - class is (mld_d_ilu_solver_type) - ! do nothing - class default - call sm%sv%free(info) - if (info == 0) deallocate(sm%sv) - if (info == 0) allocate(mld_d_ilu_solver_type ::& - & sm%sv, stat=info) - end select - else - allocate(mld_d_ilu_solver_type :: sm%sv, stat=info) - endif - if (allocated(sm)) then - if (allocated(sm%sv)) & - & call sm%sv%default() - end if - call sm%sv%set('SUB_SOLVE',val,info) - else - write(0,*) 'Calling set_solver without a smoother?' - info = -5 - end if - -#ifdef HAVE_SLU_ - case (mld_slu_) - if (allocated(sm)) then - if (allocated(sm%sv)) then - select type (sv => sm%sv) - class is (mld_d_slu_solver_type) - ! do nothing - class default - call sm%sv%free(info) - if (info == 0) deallocate(sm%sv) - if (info == 0) allocate(mld_d_slu_solver_type ::& - & sm%sv, stat=info) - end select - else - allocate(mld_d_slu_solver_type :: sm%sv, stat=info) - endif - if (allocated(sm)) then - if (allocated(sm%sv)) & - & call sm%sv%default() - end if - else - write(0,*) 'Calling set_solver without a smoother?' - info = -5 - end if -#endif -#ifdef HAVE_MUMPS_ - case (mld_mumps_) - if (allocated(sm%sv)) then - select type (sv => sm%sv) - class is (mld_d_mumps_solver_type) - ! do nothing - class default - call sm%sv%free(info) - if (info == 0) deallocate(sm%sv) - if (info == 0) allocate(mld_d_mumps_solver_type ::& - & sm%sv, stat=info) - end select - else - allocate(mld_d_mumps_solver_type :: sm%sv, stat=info) - endif - if (allocated(sm)) then - if (allocated(sm%sv)) & - & call sm%sv%default() - end if -#endif - -#ifdef HAVE_UMF_ - case (mld_umf_) - if (allocated(sm)) then - if (allocated(sm%sv)) then - select type (sv => sm%sv) - class is (mld_d_umf_solver_type) - ! do nothing - class default - call sm%sv%free(info) - if (info == 0) deallocate(sm%sv) - if (info == 0) allocate(mld_d_umf_solver_type ::& - & sm%sv, stat=info) - end select - else - allocate(mld_d_umf_solver_type :: sm%sv, stat=info) - endif - if (allocated(sm)) then - if (allocated(sm%sv)) & - & call sm%sv%default() - end if - else - write(0,*) 'Calling set_solver without a smoother?' - info = -5 - end if -#endif -#ifdef HAVE_SLUDIST_ - case (mld_sludist_) - if (allocated(sm)) then - if (allocated(sm%sv)) then - select type (sv => sm%sv) - class is (mld_d_sludist_solver_type) - ! do nothing - class default - call sm%sv%free(info) - if (info == 0) deallocate(sm%sv) - if (info == 0) allocate(mld_d_sludist_solver_type ::& - & sm%sv, stat=info) - end select - else - allocate(mld_d_sludist_solver_type :: sm%sv, stat=info) - endif - if (allocated(sm)) then - if (allocated(sm%sv)) & - & call sm%sv%default() - end if - else - write(0,*) 'Calling set_solver without a smoother?' - info = -5 - end if -#endif - case default - ! - ! Do nothing and hope for the best :) - ! - end select - end subroutine inner_set_solver - end subroutine mld_dprecseti subroutine mld_dprecsetsm(p,val,info,ilev,pos) @@ -750,7 +335,7 @@ subroutine mld_dprecsetsm(p,val,info,ilev,pos) character(len=*), optional, intent(in) :: pos ! Local variables - integer(psb_ipk_) :: ilev_, nlev_, ilmin, ilmax, ipos_ + integer(psb_ipk_) :: ilev_, nlev_, ilmin, ilmax character(len=*), parameter :: name='mld_precseti' info = psb_success_ @@ -773,64 +358,18 @@ subroutine mld_dprecsetsm(p,val,info,ilev,pos) ilmin = 1 ilmax = nlev_ end if - if (present(pos)) then - select case(psb_toupper(trim(pos))) - case('PRE') - ipos_ = mld_pre_smooth_ - case('POST') - ipos_ = mld_post_smooth_ - case default - ipos_ = mld_pre_smooth_ - end select - else - ipos_ = mld_pre_smooth_ - end if - + if ((ilev_<1).or.(ilev_ > nlev_)) then info = -1 write(psb_err_unit,*) name,& & ': Error: invalid ILEV/NLEV combination',ilev_, nlev_ return endif - - select case(ipos_) - case(mld_pre_smooth_) - do ilev_ = ilmin, ilmax - if (allocated(p%precv(ilev_)%sm)) then - if (.not.same_type_as(p%precv(ilev_)%sm,val)) then - call p%precv(ilev_)%sm%free(info) - deallocate(p%precv(ilev_)%sm, stat=info) - end if - endif - if (.not.allocated(p%precv(ilev_)%sm)) then -#ifdef HAVE_MOLD - allocate(p%precv(ilev_)%sm,mold=val) -#else - allocate(p%precv(ilev_)%sm,source=val) -#endif - end if - call p%precv(ilev_)%sm%default() - p%precv(ilev_)%sm2 => p%precv(ilev_)%sm - end do - case(mld_post_smooth_) - do ilev_ = ilmin, ilmax - if (allocated(p%precv(ilev_)%sm2a)) then - if (.not.same_type_as(p%precv(ilev_)%sm2a,val)) then - call p%precv(ilev_)%sm2a%free(info) - deallocate(p%precv(ilev_)%sm2a, stat=info) - endif - end if - if (.not.allocated(p%precv(ilev_)%sm2a)) then -#ifdef HAVE_MOLD - allocate(p%precv(ilev_)%sm2a,mold=val) -#else - allocate(p%precv(ilev_)%sm2a,source=val) -#endif - end if - call p%precv(ilev_)%sm2a%default() - p%precv(ilev_)%sm2 => p%precv(ilev_)%sm2a - end do - end select + + do ilev_ = ilmin, ilmax + call p%precv(ilev_)%set(val,info,pos=pos) + if (info /= 0) return + end do end subroutine mld_dprecsetsm @@ -843,13 +382,13 @@ subroutine mld_dprecsetsv(p,val,info,ilev,pos) ! Arguments class(mld_dprec_type), intent(inout) :: p - class(mld_d_base_solver_type), intent(in) :: val - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), optional, intent(in) :: ilev - character(len=*), optional, intent(in) :: pos + class(mld_d_base_solver_type), intent(in) :: val + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional, intent(in) :: ilev + character(len=*), optional, intent(in) :: pos ! Local variables - integer(psb_ipk_) :: ilev_, nlev_, ilmin, ilmax, ipos_ + integer(psb_ipk_) :: ilev_, nlev_, ilmin, ilmax character(len=*), parameter :: name='mld_precseti' info = psb_success_ @@ -872,19 +411,6 @@ subroutine mld_dprecsetsv(p,val,info,ilev,pos) ilmin = 1 ilmax = nlev_ end if - - if (present(pos)) then - select case(psb_toupper(trim(pos))) - case('PRE') - ipos_ = mld_pre_smooth_ - case('POST') - ipos_ = mld_post_smooth_ - case default - ipos_ = mld_pre_smooth_ - end select - else - ipos_ = mld_pre_smooth_ - end if if ((ilev_<1).or.(ilev_ > nlev_)) then @@ -894,83 +420,10 @@ subroutine mld_dprecsetsv(p,val,info,ilev,pos) return endif - - select case(ipos_) - case(mld_pre_smooth_) - do ilev_ = ilmin, ilmax - if (allocated(p%precv(ilev_)%sm)) then - if (allocated(p%precv(ilev_)%sm%sv)) then - if (.not.same_type_as(p%precv(ilev_)%sm%sv,val)) then - call p%precv(ilev_)%sm%sv%free(info) - deallocate(p%precv(ilev_)%sm%sv,stat=info) - if (info /= 0) then - info = 3111 - return - end if - end if - end if - - if (.not.allocated(p%precv(ilev_)%sm%sv)) then -#ifdef HAVE_MOLD - allocate(p%precv(ilev_)%sm%sv,mold=val,stat=info) -#else - allocate(p%precv(ilev_)%sm%sv,source=val,stat=info) -#endif - if (info /= 0) then - info = 3111 - return - end if - end if - call p%precv(ilev_)%sm%sv%default() - else - info = 3111 - write(psb_err_unit,*) name,& - &': Error: uninitialized preconditioner component,',& - &' should call MLD_PRECINIT/MLD_PRECSET' - return - - end if - - end do - - case(mld_post_smooth_) - do ilev_ = ilmin, ilmax - if (allocated(p%precv(ilev_)%sm2a)) then - if (allocated(p%precv(ilev_)%sm2a%sv)) then - if (.not.same_type_as(p%precv(ilev_)%sm2a%sv,val)) then - call p%precv(ilev_)%sm2a%sv%free(info) - deallocate(p%precv(ilev_)%sm2a%sv,stat=info) - if (info /= 0) then - info = 3111 - return - end if - end if - end if - if (.not.allocated(p%precv(ilev_)%sm2a%sv)) then -#ifdef HAVE_MOLD - allocate(p%precv(ilev_)%sm2a%sv,mold=val,stat=info) -#else - allocate(p%precv(ilev_)%sm2a%sv,source=val,stat=info) -#endif - if (info /= 0) then - info = 3111 - return - end if - end if - call p%precv(ilev_)%sm2a%sv%default() - - else - info = 3111 - write(psb_err_unit,*) name,& - &': Error: uninitialized preconditioner component,',& - &' should call MLD_PRECINIT/MLD_PRECSET' - return - - end if - - end do - end select - + do ilev_ = ilmin, ilmax + call p%precv(ilev_)%set(val,info,pos=pos) + if (info /= 0) return + end do end subroutine mld_dprecsetsv diff --git a/tests/pdegen/runs/ppde.inp b/tests/pdegen/runs/ppde.inp index d8baa766..8282eec6 100644 --- a/tests/pdegen/runs/ppde.inp +++ b/tests/pdegen/runs/ppde.inp @@ -1,4 +1,4 @@ -CG ! Iterative method: BiCGSTAB BiCG CGS RGMRES BiCGSTABL CG +BICGSTAB ! Iterative method: BiCGSTAB BiCG CGS RGMRES BiCGSTABL CG CSR ! Storage format CSR COO JAD 0030 ! IDIM; domain size is idim**3 2 ! ISTOPC From a1d88c2bbfb4ff849df1753b3ee08b84d11d348d Mon Sep 17 00:00:00 2001 From: Salvatore Filippone Date: Mon, 16 May 2016 15:08:53 +0000 Subject: [PATCH 12/17] mld2p4-smooth-2side: mlprec/impl/mld_dprecset.F90 tests/fileread/df_sample.f90 tests/fileread/runs/dfs.inp tests/pdegen/runs/ppde.inp Fixed bug in precset. Adapted df_sample. --- mlprec/impl/mld_dprecset.F90 | 2 +- tests/fileread/df_sample.f90 | 7 ++++++- tests/fileread/runs/dfs.inp | 20 ++++++++++---------- tests/pdegen/runs/ppde.inp | 4 ++-- 4 files changed, 19 insertions(+), 14 deletions(-) diff --git a/mlprec/impl/mld_dprecset.F90 b/mlprec/impl/mld_dprecset.F90 index c11ba37d..4143932e 100644 --- a/mlprec/impl/mld_dprecset.F90 +++ b/mlprec/impl/mld_dprecset.F90 @@ -243,7 +243,7 @@ subroutine mld_dprecseti(p,what,val,info,ilev,pos) & mld_sub_ren_,mld_sub_ovr_,mld_sub_fillin_,& & mld_smoother_sweeps_,mld_smoother_type_) do ilev_=1,max(1,nlev_-1) - call p%precv(ilev_)%set(mld_smoother_type_,val,info,pos=pos) + call p%precv(ilev_)%set(what,val,info,pos=pos) if (info /= 0) return end do diff --git a/tests/fileread/df_sample.f90 b/tests/fileread/df_sample.f90 index ee732223..de0fd840 100644 --- a/tests/fileread/df_sample.f90 +++ b/tests/fileread/df_sample.f90 @@ -74,6 +74,8 @@ program df_sample real(psb_dpk_) :: ascale ! smoothed aggregation scale factor end type precdata type(precdata) :: prec_choice + type(mld_d_jac_smoother_type) :: dbsmth + type(mld_d_bwgs_solver_type) :: dbwgs ! sparse matrices type(psb_dspmat_type) :: a, aux_a @@ -305,7 +307,10 @@ program df_sample call mld_precset(prec,mld_coarse_fillin_, prec_choice%cfill, info) call mld_precset(prec,mld_coarse_iluthrs_, prec_choice%cthres, info) call mld_precset(prec,mld_coarse_sweeps_, prec_choice%cjswp, info) - + call prec%set(dbsmth,info,pos='post') + call prec%set(dbwgs,info,pos='post') + call mld_precset(prec,'solver_sweeps', 4, info, pos='pre') + call mld_precset(prec,'solver_sweeps', 4, info, pos='post') else nlv = 1 call mld_precinit(prec,prec_choice%prec,info) diff --git a/tests/fileread/runs/dfs.inp b/tests/fileread/runs/dfs.inp index 31255d23..ed274e1d 100644 --- a/tests/fileread/runs/dfs.inp +++ b/tests/fileread/runs/dfs.inp @@ -1,26 +1,26 @@ -pressmat.mtx ! This matrix (and others) from: http://math.nist.gov/MatrixMarket/ or -pressrhs.mtx ! rhs | http://www.cise.ufl.edu/research/sparse/matrices/index.html +DATIAMBRA/matrix.mm ! This matrix (and others) from: http://math.nist.gov/MatrixMarket/ or +DATIAMBRA/rhs.mm ! rhs | http://www.cise.ufl.edu/research/sparse/matrices/index.html MM ! -RGMRES ! Iterative method: BiCGSTAB BiCG CGS RGMRES BiCGSTABL CG +CG ! Iterative method: BiCGSTAB BiCG CGS RGMRES BiCGSTABL CG CSR ! Storage format: CSR COO JAD 0 ! IPART (partition method): 0 (block) 2 (graph, with Metis) 2 ! ISTOPC -01000 ! ITMAX -02 ! ITRACE +01500 ! ITMAX +10 ! ITRACE 30 ! IRST (restart for RGMRES and BiCGSTABL) -1.d-9 ! EPS +1.d-6 ! EPS 4L-M-RAS-I-UR ! Longer descriptive name for preconditioner (up to 20 chars) ML ! Preconditioner type: NONE JACOBI BJAC AS ML 1 ! Number of overlap layers for AS preconditioner HALO ! AS restriction operator: NONE HALO NONE ! AS prolongation operator: NONE SUM AVG -ILU ! AS subdomain solver: DSCALE ILU MILU ILUT UMF SLU MUMPS -0 ! Fill level P for ILU(P) and ILU(T,P) +GS ! AS subdomain solver: DSCALE ILU MILU ILUT UMF SLU MUMPS +4 ! Fill level P for ILU(P) and ILU(T,P) 1.d-4 ! Threshold T for ILU(T,P) 1 ! Number of Jacobi sweeps for base smoother -4 ! Number of levels in a multilevel preconditioner +5 ! Number of levels in a multilevel preconditioner AS ! Smoother type JACOBI BJAC AS ignored for non-ML -SMOOTHED ! Type of aggregation: SMOOTHED NONSMOOTHED +UNSMOOTHED ! Type of aggregation: SMOOTHED NONSMOOTHED DEC ! Type of aggregation: DEC MULT ! Type of multilevel correction: ADD MULT TWOSIDE ! Side of correction PRE POST TWOSIDE (ignored for ADD) diff --git a/tests/pdegen/runs/ppde.inp b/tests/pdegen/runs/ppde.inp index 8282eec6..869bb17d 100644 --- a/tests/pdegen/runs/ppde.inp +++ b/tests/pdegen/runs/ppde.inp @@ -1,8 +1,8 @@ BICGSTAB ! Iterative method: BiCGSTAB BiCG CGS RGMRES BiCGSTABL CG CSR ! Storage format CSR COO JAD -0030 ! IDIM; domain size is idim**3 +0040 ! IDIM; domain size is idim**3 2 ! ISTOPC -0500 ! ITMAX +2000 ! ITMAX 10 ! ITRACE 30 ! IRST (restart for RGMRES and BiCGSTABL) 1.d-6 ! EPS From c83b19dea17207a108c7ca9863002012b1c295c0 Mon Sep 17 00:00:00 2001 From: Salvatore Filippone Date: Mon, 16 May 2016 16:11:07 +0000 Subject: [PATCH 13/17] mld2p4-smooth-2side: mlprec/mld_base_prec_type.F90 tests/fileread/Makefile tests/fileread/df_sample.f90 Fixed parm clone. --- mlprec/mld_base_prec_type.F90 | 2 ++ tests/fileread/Makefile | 3 ++- tests/fileread/df_sample.f90 | 8 ++++---- 3 files changed, 8 insertions(+), 5 deletions(-) diff --git a/mlprec/mld_base_prec_type.F90 b/mlprec/mld_base_prec_type.F90 index 3459d989..736ad18c 100644 --- a/mlprec/mld_base_prec_type.F90 +++ b/mlprec/mld_base_prec_type.F90 @@ -961,6 +961,7 @@ contains call psb_bcast(ictxt,dat%ml_type,root) call psb_bcast(ictxt,dat%smoother_pos,root) call psb_bcast(ictxt,dat%aggr_alg,root) + call psb_bcast(ictxt,dat%aggr_ord,root) call psb_bcast(ictxt,dat%aggr_kind,root) call psb_bcast(ictxt,dat%aggr_omega_alg,root) call psb_bcast(ictxt,dat%aggr_eig,root) @@ -1007,6 +1008,7 @@ contains pmout%ml_type = pm%ml_type pmout%smoother_pos = pm%smoother_pos pmout%aggr_alg = pm%aggr_alg + pmout%aggr_ord = pm%aggr_ord pmout%aggr_kind = pm%aggr_kind pmout%aggr_omega_alg = pm%aggr_omega_alg pmout%aggr_eig = pm%aggr_eig diff --git a/tests/fileread/Makefile b/tests/fileread/Makefile index 66eb1778..fab2fe96 100644 --- a/tests/fileread/Makefile +++ b/tests/fileread/Makefile @@ -16,7 +16,8 @@ ZFSOBJS=zf_sample.o data_input.o EXEDIR=./runs -all: sf_sample df_sample cf_sample zf_sample df_sample_alya +all: sf_sample df_sample cf_sample zf_sample +#df_sample_alya df-sample_aya: df-sample_aya.o $(F90LINK) $(LINKOPT) $(DFSAYAOBJS) -o df-sample_aya \ diff --git a/tests/fileread/df_sample.f90 b/tests/fileread/df_sample.f90 index de0fd840..026d0d8f 100644 --- a/tests/fileread/df_sample.f90 +++ b/tests/fileread/df_sample.f90 @@ -307,10 +307,10 @@ program df_sample call mld_precset(prec,mld_coarse_fillin_, prec_choice%cfill, info) call mld_precset(prec,mld_coarse_iluthrs_, prec_choice%cthres, info) call mld_precset(prec,mld_coarse_sweeps_, prec_choice%cjswp, info) - call prec%set(dbsmth,info,pos='post') - call prec%set(dbwgs,info,pos='post') - call mld_precset(prec,'solver_sweeps', 4, info, pos='pre') - call mld_precset(prec,'solver_sweeps', 4, info, pos='post') +!!$ call prec%set(dbsmth,info,pos='post') +!!$ call prec%set(dbwgs,info,pos='post') +!!$ call mld_precset(prec,'solver_sweeps', 4, info, pos='pre') +!!$ call mld_precset(prec,'solver_sweeps', 4, info, pos='post') else nlv = 1 call mld_precinit(prec,prec_choice%prec,info) From 6321f680cbe9ea7d0ca987573806742edc7bce3a Mon Sep 17 00:00:00 2001 From: Salvatore Filippone Date: Mon, 16 May 2016 16:45:17 +0000 Subject: [PATCH 14/17] mld2p4-smooth-2side: mlprec/impl/mld_dmlprec_aply.f90 tests/fileread/runs/dfs.inp tests/pdegen/runs/ppde.inp Fixed bug in applicaoitn of two-sided. --- mlprec/impl/mld_dmlprec_aply.f90 | 72 ++++++++++++++++---------------- tests/fileread/runs/dfs.inp | 20 ++++----- tests/pdegen/runs/ppde.inp | 4 +- 3 files changed, 49 insertions(+), 47 deletions(-) diff --git a/mlprec/impl/mld_dmlprec_aply.f90 b/mlprec/impl/mld_dmlprec_aply.f90 index a5cceced..dd2938d5 100644 --- a/mlprec/impl/mld_dmlprec_aply.f90 +++ b/mlprec/impl/mld_dmlprec_aply.f90 @@ -434,7 +434,6 @@ contains ictxt = p%precv(level)%base_desc%get_context() call psb_info(ictxt, me, np) - if (level > 1) then nc2l = p%precv(level)%base_desc%get_local_cols() nr2l = p%precv(level)%base_desc%get_local_rows() @@ -584,7 +583,7 @@ contains else ! Here at coarse level sweeps = p%precv(level)%parms%sweeps - call p%precv(level)%sm2%apply(done,& + call p%precv(level)%sm%apply(done,& & mlprec_wrk(level)%x2l,dzero,mlprec_wrk(level)%y2l,& & p%precv(level)%base_desc, trans,& & sweeps,work,info) @@ -621,13 +620,17 @@ contains ! if (level < nlev) then sweeps = p%precv(level)%parms%sweeps_post + call p%precv(level)%sm2%apply(done,& + & mlprec_wrk(level)%x2l,dzero,mlprec_wrk(level)%y2l,& + & p%precv(level)%base_desc, trans,& + & sweeps,work,info) else sweeps = p%precv(level)%parms%sweeps + call p%precv(level)%sm%apply(done,& + & mlprec_wrk(level)%x2l,dzero,mlprec_wrk(level)%y2l,& + & p%precv(level)%base_desc, trans,& + & sweeps,work,info) end if - call p%precv(level)%sm2%apply(done,& - & mlprec_wrk(level)%x2l,dzero,mlprec_wrk(level)%y2l,& - & p%precv(level)%base_desc, trans,& - & sweeps,work,info) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& @@ -948,12 +951,12 @@ contains end if if (trans == 'N') then if (info == psb_success_) call p%precv(level)%sm2%apply(done,& - & mlprec_wrk(level)%x2l,dzero,mlprec_wrk(level)%y2l,& + & mlprec_wrk(level)%tx,done,mlprec_wrk(level)%y2l,& & p%precv(level)%base_desc, trans,& & sweeps,work,info) else if (info == psb_success_) call p%precv(level)%sm%apply(done,& - & mlprec_wrk(level)%x2l,dzero,mlprec_wrk(level)%y2l,& + & mlprec_wrk(level)%tx,done,mlprec_wrk(level)%y2l,& & p%precv(level)%base_desc, trans,& & sweeps,work,info) end if @@ -1115,7 +1118,7 @@ contains ! Arguments integer(psb_ipk_) :: level - type(mld_dprec_type), intent(inout) :: p + type(mld_dprec_type), target, intent(inout) :: p type(mld_mlprec_wrk_type), intent(inout) :: mlprec_wrk(:) character, intent(in) :: trans real(psb_dpk_),target :: work(:) @@ -1261,7 +1264,7 @@ contains & a_err='Error during prolongation') goto 9999 end if - + ! ! Compute the residual ! @@ -1285,7 +1288,7 @@ contains & a_err='Error during smoother_apply') goto 9999 end if - + else sweeps = p%precv(level)%parms%sweeps call p%precv(level)%sm2%apply(done,& @@ -1297,7 +1300,7 @@ contains & a_err='Error during smoother_apply') goto 9999 end if - + end if case('T','C') @@ -1358,7 +1361,7 @@ contains & a_err='Error in recursive call') goto 9999 end if - + call psb_map_Y2X(done,mlprec_wrk(level+1)%vy2l,& & done,mlprec_wrk(level)%vy2l,& @@ -1436,7 +1439,7 @@ contains & a_err='Error in recursive call') goto 9999 end if - + call psb_map_Y2X(done,mlprec_wrk(level+1)%vy2l,& & done,mlprec_wrk(level)%vy2l,& @@ -1477,7 +1480,7 @@ contains & a_err='Error in recursive call') goto 9999 end if - + ! ! Apply the prolongator ! @@ -1489,7 +1492,7 @@ contains & a_err='Error during prolongation') goto 9999 end if - + ! ! Compute the residual ! @@ -1556,29 +1559,30 @@ contains if (level < nlev) then if (trans == 'N') then sweeps = p%precv(level)%parms%sweeps_pre + if (info == psb_success_) call p%precv(level)%sm%apply(done,& + & mlprec_wrk(level)%vx2l,dzero,mlprec_wrk(level)%vy2l,& + & p%precv(level)%base_desc, trans,& + & sweeps,work,info) else sweeps = p%precv(level)%parms%sweeps_post + if (info == psb_success_) call p%precv(level)%sm2%apply(done,& + & mlprec_wrk(level)%vx2l,dzero,mlprec_wrk(level)%vy2l,& + & p%precv(level)%base_desc, trans,& + & sweeps,work,info) end if else sweeps = p%precv(level)%parms%sweeps - end if - if (trans == 'N') then if (info == psb_success_) call p%precv(level)%sm%apply(done,& & mlprec_wrk(level)%vx2l,dzero,mlprec_wrk(level)%vy2l,& & p%precv(level)%base_desc, trans,& & sweeps,work,info) - else - if (info == psb_success_) call p%precv(level)%sm2%apply(done,& - & mlprec_wrk(level)%vx2l,dzero,mlprec_wrk(level)%vy2l,& - & p%precv(level)%base_desc, trans,& - & sweeps,work,info) end if if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& & a_err='Error during 1st smoother_apply') goto 9999 end if - + ! ! Compute the residual (at all levels but the coarsest one) ! and call recursively @@ -1604,7 +1608,7 @@ contains & a_err='Error in recursive call') goto 9999 end if - + ! ! Apply the prolongator @@ -1612,13 +1616,13 @@ contains call psb_map_Y2X(done,mlprec_wrk(level+1)%vy2l,& & done,mlprec_wrk(level)%vy2l,& & p%precv(level+1)%map,info,work=work) - + if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& & a_err='Error during prolongation') goto 9999 end if - + ! ! Compute the residual ! @@ -1635,20 +1639,18 @@ contains ! if (trans == 'N') then sweeps = p%precv(level)%parms%sweeps_post + if (info == psb_success_) call p%precv(level)%sm2%apply(done,& + & mlprec_wrk(level)%vtx,done,mlprec_wrk(level)%vy2l,& + & p%precv(level)%base_desc, trans,& + & sweeps,work,info) else sweeps = p%precv(level)%parms%sweeps_pre - end if - if (trans == 'N') then - if (info == psb_success_) call p%precv(level)%sm2%apply(done,& - & mlprec_wrk(level)%vx2l,dzero,mlprec_wrk(level)%vy2l,& - & p%precv(level)%base_desc, trans,& - & sweeps,work,info) - else if (info == psb_success_) call p%precv(level)%sm%apply(done,& - & mlprec_wrk(level)%vx2l,dzero,mlprec_wrk(level)%vy2l,& + & mlprec_wrk(level)%vtx,done,mlprec_wrk(level)%vy2l,& & p%precv(level)%base_desc, trans,& & sweeps,work,info) end if + if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& & a_err='Error during 2nd smoother_apply') diff --git a/tests/fileread/runs/dfs.inp b/tests/fileread/runs/dfs.inp index ed274e1d..1f8cd7a0 100644 --- a/tests/fileread/runs/dfs.inp +++ b/tests/fileread/runs/dfs.inp @@ -1,29 +1,29 @@ DATIAMBRA/matrix.mm ! This matrix (and others) from: http://math.nist.gov/MatrixMarket/ or DATIAMBRA/rhs.mm ! rhs | http://www.cise.ufl.edu/research/sparse/matrices/index.html MM ! -CG ! Iterative method: BiCGSTAB BiCG CGS RGMRES BiCGSTABL CG +BICGSTAB ! Iterative method: BiCGSTAB BiCG CGS RGMRES BiCGSTABL CG CSR ! Storage format: CSR COO JAD 0 ! IPART (partition method): 0 (block) 2 (graph, with Metis) 2 ! ISTOPC -01500 ! ITMAX -10 ! ITRACE +00100 ! ITMAX +01 ! ITRACE 30 ! IRST (restart for RGMRES and BiCGSTABL) 1.d-6 ! EPS -4L-M-RAS-I-UR ! Longer descriptive name for preconditioner (up to 20 chars) +5L-M-RAS-I-UR ! Longer descriptive name for preconditioner (up to 20 chars) ML ! Preconditioner type: NONE JACOBI BJAC AS ML 1 ! Number of overlap layers for AS preconditioner HALO ! AS restriction operator: NONE HALO NONE ! AS prolongation operator: NONE SUM AVG -GS ! AS subdomain solver: DSCALE ILU MILU ILUT UMF SLU MUMPS -4 ! Fill level P for ILU(P) and ILU(T,P) +ILU ! AS subdomain solver: DSCALE ILU MILU ILUT UMF SLU MUMPS +0 ! Fill level P for ILU(P) and ILU(T,P) 1.d-4 ! Threshold T for ILU(T,P) 1 ! Number of Jacobi sweeps for base smoother -5 ! Number of levels in a multilevel preconditioner +4 ! Number of levels in a multilevel preconditioner AS ! Smoother type JACOBI BJAC AS ignored for non-ML -UNSMOOTHED ! Type of aggregation: SMOOTHED NONSMOOTHED +SMOOTHED ! Type of aggregation: SMOOTHED NONSMOOTHED DEC ! Type of aggregation: DEC -MULT ! Type of multilevel correction: ADD MULT -TWOSIDE ! Side of correction PRE POST TWOSIDE (ignored for ADD) +ADD ! Type of multilevel correction: ADD MULT +PRE ! Side of correction PRE POST TWOSIDE (ignored for ADD) DIST ! Coarsest-level matrix distribution: DIST REPL BJAC ! Coarsest-level solver: JACOBI BJAC UMF SLU MUMPS SLUDIST ILU ! Coarsest-level subsolver: ILU UMF SLU MUMPS SLUDIST (DSCALE for JACOBI) diff --git a/tests/pdegen/runs/ppde.inp b/tests/pdegen/runs/ppde.inp index 869bb17d..560987bb 100644 --- a/tests/pdegen/runs/ppde.inp +++ b/tests/pdegen/runs/ppde.inp @@ -1,4 +1,4 @@ -BICGSTAB ! Iterative method: BiCGSTAB BiCG CGS RGMRES BiCGSTABL CG +CG ! Iterative method: BiCGSTAB BiCG CGS RGMRES BiCGSTABL CG CSR ! Storage format CSR COO JAD 0040 ! IDIM; domain size is idim**3 2 ! ISTOPC @@ -20,7 +20,7 @@ BJAC ! Smoother type JACOBI BJAC AS; ignored for non-ML 2 ! Number of levels in a multilevel preconditioner SMOOTHED ! Kind of aggregation: SMOOTHED, NONSMOOTHED, MINENERGY DEC ! Type of aggregation DEC SYMDEC GLB -DEGREE ! Ordering of aggregation NATURAL DEGREE +NATURAL ! Ordering of aggregation NATURAL DEGREE MULT ! Type of multilevel correction: ADD MULT TWOSIDE ! Side of correction PRE POST TWOSIDE (ignored for ADD) DIST ! Coarse level: matrix distribution DIST REPL From 6c1676a9c63de9d0ac7537c4441fda9eff751d42 Mon Sep 17 00:00:00 2001 From: Salvatore Filippone Date: Tue, 17 May 2016 15:42:25 +0000 Subject: [PATCH 15/17] mld2p4-smooth-twoside: mlprec/impl/level mlprec/impl/level/Makefile mlprec/impl/level/mld_c_base_onelev_check.f90 mlprec/impl/level/mld_c_base_onelev_cnv.f90 mlprec/impl/level/mld_c_base_onelev_csetc.f90 mlprec/impl/level/mld_c_base_onelev_cseti.F90 mlprec/impl/level/mld_c_base_onelev_cseti.f90 mlprec/impl/level/mld_c_base_onelev_csetr.f90 mlprec/impl/level/mld_c_base_onelev_descr.f90 mlprec/impl/level/mld_c_base_onelev_dump.f90 mlprec/impl/level/mld_c_base_onelev_free.f90 mlprec/impl/level/mld_c_base_onelev_setc.f90 mlprec/impl/level/mld_c_base_onelev_seti.F90 mlprec/impl/level/mld_c_base_onelev_seti.f90 mlprec/impl/level/mld_c_base_onelev_setr.f90 mlprec/impl/level/mld_c_base_onelev_setsm.F90 mlprec/impl/level/mld_c_base_onelev_setsv.F90 mlprec/impl/level/mld_d_base_onelev_check.f90 mlprec/impl/level/mld_d_base_onelev_cnv.f90 mlprec/impl/level/mld_d_base_onelev_csetc.f90 mlprec/impl/level/mld_d_base_onelev_cseti.F90 mlprec/impl/level/mld_d_base_onelev_cseti.f90 mlprec/impl/level/mld_d_base_onelev_csetr.f90 mlprec/impl/level/mld_d_base_onelev_descr.f90 mlprec/impl/level/mld_d_base_onelev_dump.f90 mlprec/impl/level/mld_d_base_onelev_free.f90 mlprec/impl/level/mld_d_base_onelev_setc.f90 mlprec/impl/level/mld_d_base_onelev_seti.F90 mlprec/impl/level/mld_d_base_onelev_seti.f90 mlprec/impl/level/mld_d_base_onelev_setr.f90 mlprec/impl/level/mld_d_base_onelev_setsm.F90 mlprec/impl/level/mld_d_base_onelev_setsv.F90 mlprec/impl/level/mld_s_base_onelev_check.f90 mlprec/impl/level/mld_s_base_onelev_cnv.f90 mlprec/impl/level/mld_s_base_onelev_csetc.f90 mlprec/impl/level/mld_s_base_onelev_cseti.F90 mlprec/impl/level/mld_s_base_onelev_cseti.f90 mlprec/impl/level/mld_s_base_onelev_csetr.f90 mlprec/impl/level/mld_s_base_onelev_descr.f90 mlprec/impl/level/mld_s_base_onelev_dump.f90 mlprec/impl/level/mld_s_base_onelev_free.f90 mlprec/impl/level/mld_s_base_onelev_setc.f90 mlprec/impl/level/mld_s_base_onelev_seti.F90 mlprec/impl/level/mld_s_base_onelev_seti.f90 mlprec/impl/level/mld_s_base_onelev_setr.f90 mlprec/impl/level/mld_s_base_onelev_setsm.F90 mlprec/impl/level/mld_s_base_onelev_setsv.F90 mlprec/impl/level/mld_z_base_onelev_check.f90 mlprec/impl/level/mld_z_base_onelev_cnv.f90 mlprec/impl/level/mld_z_base_onelev_csetc.f90 mlprec/impl/level/mld_z_base_onelev_cseti.F90 mlprec/impl/level/mld_z_base_onelev_cseti.f90 mlprec/impl/level/mld_z_base_onelev_csetr.f90 mlprec/impl/level/mld_z_base_onelev_descr.f90 mlprec/impl/level/mld_z_base_onelev_dump.f90 mlprec/impl/level/mld_z_base_onelev_free.f90 mlprec/impl/level/mld_z_base_onelev_setc.f90 mlprec/impl/level/mld_z_base_onelev_seti.F90 mlprec/impl/level/mld_z_base_onelev_seti.f90 mlprec/impl/level/mld_z_base_onelev_setr.f90 mlprec/impl/level/mld_z_base_onelev_setsm.F90 mlprec/impl/level/mld_z_base_onelev_setsv.F90 Preparatory renaming for further development. --- mlprec/impl/level/Makefile | 8 +- ..._cseti.f90 => mld_c_base_onelev_cseti.F90} | 0 ...ev_seti.f90 => mld_c_base_onelev_seti.F90} | 0 mlprec/impl/level/mld_c_base_onelev_setsm.F90 | 107 +++++++++++++ mlprec/impl/level/mld_c_base_onelev_setsv.F90 | 144 ++++++++++++++++++ ..._cseti.f90 => mld_s_base_onelev_cseti.F90} | 0 ...ev_seti.f90 => mld_s_base_onelev_seti.F90} | 0 mlprec/impl/level/mld_s_base_onelev_setsm.F90 | 107 +++++++++++++ mlprec/impl/level/mld_s_base_onelev_setsv.F90 | 144 ++++++++++++++++++ ..._cseti.f90 => mld_z_base_onelev_cseti.F90} | 0 ...ev_seti.f90 => mld_z_base_onelev_seti.F90} | 0 mlprec/impl/level/mld_z_base_onelev_setsm.F90 | 107 +++++++++++++ mlprec/impl/level/mld_z_base_onelev_setsv.F90 | 144 ++++++++++++++++++ 13 files changed, 760 insertions(+), 1 deletion(-) rename mlprec/impl/level/{mld_c_base_onelev_cseti.f90 => mld_c_base_onelev_cseti.F90} (100%) rename mlprec/impl/level/{mld_c_base_onelev_seti.f90 => mld_c_base_onelev_seti.F90} (100%) create mode 100644 mlprec/impl/level/mld_c_base_onelev_setsm.F90 create mode 100644 mlprec/impl/level/mld_c_base_onelev_setsv.F90 rename mlprec/impl/level/{mld_s_base_onelev_cseti.f90 => mld_s_base_onelev_cseti.F90} (100%) rename mlprec/impl/level/{mld_s_base_onelev_seti.f90 => mld_s_base_onelev_seti.F90} (100%) create mode 100644 mlprec/impl/level/mld_s_base_onelev_setsm.F90 create mode 100644 mlprec/impl/level/mld_s_base_onelev_setsv.F90 rename mlprec/impl/level/{mld_z_base_onelev_cseti.f90 => mld_z_base_onelev_cseti.F90} (100%) rename mlprec/impl/level/{mld_z_base_onelev_seti.f90 => mld_z_base_onelev_seti.F90} (100%) create mode 100644 mlprec/impl/level/mld_z_base_onelev_setsm.F90 create mode 100644 mlprec/impl/level/mld_z_base_onelev_setsv.F90 diff --git a/mlprec/impl/level/Makefile b/mlprec/impl/level/Makefile index 4c035857..7485c10b 100644 --- a/mlprec/impl/level/Makefile +++ b/mlprec/impl/level/Makefile @@ -19,6 +19,8 @@ mld_c_base_onelev_free.o \ mld_c_base_onelev_setc.o \ mld_c_base_onelev_seti.o \ mld_c_base_onelev_setr.o \ +mld_c_base_onelev_setsm.o \ +mld_c_base_onelev_setsv.o \ mld_d_base_onelev_check.o \ mld_d_base_onelev_cnv.o \ mld_d_base_onelev_csetc.o \ @@ -43,6 +45,8 @@ mld_s_base_onelev_free.o \ mld_s_base_onelev_setc.o \ mld_s_base_onelev_seti.o \ mld_s_base_onelev_setr.o \ +mld_s_base_onelev_setsm.o \ +mld_s_base_onelev_setsv.o \ mld_z_base_onelev_check.o \ mld_z_base_onelev_cnv.o \ mld_z_base_onelev_csetc.o \ @@ -53,7 +57,9 @@ mld_z_base_onelev_dump.o \ mld_z_base_onelev_free.o \ mld_z_base_onelev_setc.o \ mld_z_base_onelev_seti.o \ -mld_z_base_onelev_setr.o +mld_z_base_onelev_setr.o \ +mld_z_base_onelev_setsm.o \ +mld_z_base_onelev_setsv.o LIBNAME=libmld_prec.a diff --git a/mlprec/impl/level/mld_c_base_onelev_cseti.f90 b/mlprec/impl/level/mld_c_base_onelev_cseti.F90 similarity index 100% rename from mlprec/impl/level/mld_c_base_onelev_cseti.f90 rename to mlprec/impl/level/mld_c_base_onelev_cseti.F90 diff --git a/mlprec/impl/level/mld_c_base_onelev_seti.f90 b/mlprec/impl/level/mld_c_base_onelev_seti.F90 similarity index 100% rename from mlprec/impl/level/mld_c_base_onelev_seti.f90 rename to mlprec/impl/level/mld_c_base_onelev_seti.F90 diff --git a/mlprec/impl/level/mld_c_base_onelev_setsm.F90 b/mlprec/impl/level/mld_c_base_onelev_setsm.F90 new file mode 100644 index 00000000..f0bf8b39 --- /dev/null +++ b/mlprec/impl/level/mld_c_base_onelev_setsm.F90 @@ -0,0 +1,107 @@ +!!$ +!!$ +!!$ MLD2P4 version 2.0 +!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package +!!$ based on PSBLAS (Parallel Sparse BLAS version 3.3) +!!$ +!!$ (C) Copyright 2008, 2010, 2012, 2015 +!!$ +!!$ 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. +!!$ +!!$ +subroutine mld_c_base_onelev_setsm(lev,val,info,pos) + + use psb_base_mod + use mld_c_prec_mod, mld_protect_name => mld_c_base_onelev_setsm + + implicit none + + ! Arguments + class(mld_c_onelev_type), target, intent(inout) :: lev + class(mld_c_base_smoother_type), intent(in) :: val + integer(psb_ipk_), intent(out) :: info + character(len=*), optional, intent(in) :: pos + + ! Local variables + integer(psb_ipk_) :: ipos_ + character(len=*), parameter :: name='mld_base_onelev_setsm' + + info = psb_success_ + + if (present(pos)) then + select case(psb_toupper(trim(pos))) + case('PRE') + ipos_ = mld_pre_smooth_ + case('POST') + ipos_ = mld_post_smooth_ + case default + ipos_ = mld_pre_smooth_ + end select + else + ipos_ = mld_pre_smooth_ + end if + + select case(ipos_) + case(mld_pre_smooth_) + if (allocated(lev%sm)) then + if (.not.same_type_as(lev%sm,val)) then + call lev%sm%free(info) + deallocate(lev%sm, stat=info) + end if + endif + if (.not.allocated(lev%sm)) then +#ifdef HAVE_MOLD + allocate(lev%sm,mold=val) +#else + allocate(lev%sm,source=val) +#endif + end if + call lev%sm%default() + lev%sm2 => lev%sm + case(mld_post_smooth_) + if (allocated(lev%sm2a)) then + if (.not.same_type_as(lev%sm2a,val)) then + call lev%sm2a%free(info) + deallocate(lev%sm2a, stat=info) + endif + end if + if (.not.allocated(lev%sm2a)) then +#ifdef HAVE_MOLD + allocate(lev%sm2a,mold=val) +#else + allocate(lev%sm2a,source=val) +#endif + end if + call lev%sm2a%default() + lev%sm2 => lev%sm2a + end select + +end subroutine mld_c_base_onelev_setsm + diff --git a/mlprec/impl/level/mld_c_base_onelev_setsv.F90 b/mlprec/impl/level/mld_c_base_onelev_setsv.F90 new file mode 100644 index 00000000..f605baa4 --- /dev/null +++ b/mlprec/impl/level/mld_c_base_onelev_setsv.F90 @@ -0,0 +1,144 @@ +!!$ +!!$ +!!$ MLD2P4 version 2.0 +!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package +!!$ based on PSBLAS (Parallel Sparse BLAS version 3.3) +!!$ +!!$ (C) Copyright 2008, 2010, 2012, 2015 +!!$ +!!$ 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. +!!$ +!!$ +subroutine mld_c_base_onelev_setsv(lev,val,info,pos) + + use psb_base_mod + use mld_c_prec_mod, mld_protect_name => mld_c_base_onelev_setsv + + implicit none + + ! Arguments + class(mld_c_onelev_type), target, intent(inout) :: lev + class(mld_c_base_solver_type), intent(in) :: val + integer(psb_ipk_), intent(out) :: info + character(len=*), optional, intent(in) :: pos + + ! Local variables + integer(psb_ipk_) :: ipos_ + character(len=*), parameter :: name='mld_base_onelev_setsv' + + info = psb_success_ + + if (present(pos)) then + select case(psb_toupper(trim(pos))) + case('PRE') + ipos_ = mld_pre_smooth_ + case('POST') + ipos_ = mld_post_smooth_ + case default + ipos_ = mld_pre_smooth_ + end select + else + ipos_ = mld_pre_smooth_ + end if + + select case(ipos_) + case(mld_pre_smooth_) + if (allocated(lev%sm)) then + if (allocated(lev%sm%sv)) then + if (.not.same_type_as(lev%sm%sv,val)) then + call lev%sm%sv%free(info) + deallocate(lev%sm%sv,stat=info) + if (info /= 0) then + info = 3111 + return + end if + end if + end if + + if (.not.allocated(lev%sm%sv)) then +#ifdef HAVE_MOLD + allocate(lev%sm%sv,mold=val,stat=info) +#else + allocate(lev%sm%sv,source=val,stat=info) +#endif + if (info /= 0) then + info = 3111 + return + end if + end if + call lev%sm%sv%default() + else + info = 3111 + write(psb_err_unit,*) name,& + &': Error: uninitialized preconditioner component,',& + &' should call MLD_PRECINIT/MLD_PRECSET' + return + + end if + + case(mld_post_smooth_) + + if (allocated(lev%sm2a)) then + if (allocated(lev%sm2a%sv)) then + if (.not.same_type_as(lev%sm2a%sv,val)) then + call lev%sm2a%sv%free(info) + deallocate(lev%sm2a%sv,stat=info) + if (info /= 0) then + info = 3111 + return + end if + end if + end if + if (.not.allocated(lev%sm2a%sv)) then +#ifdef HAVE_MOLD + allocate(lev%sm2a%sv,mold=val,stat=info) +#else + allocate(lev%sm2a%sv,source=val,stat=info) +#endif + if (info /= 0) then + info = 3111 + return + end if + end if + call lev%sm2a%sv%default() + + else + info = 3111 + write(psb_err_unit,*) name,& + &': Error: uninitialized preconditioner component,',& + &' should call MLD_PRECINIT/MLD_PRECSET' + return + + end if + + end select + +end subroutine mld_c_base_onelev_setsv + diff --git a/mlprec/impl/level/mld_s_base_onelev_cseti.f90 b/mlprec/impl/level/mld_s_base_onelev_cseti.F90 similarity index 100% rename from mlprec/impl/level/mld_s_base_onelev_cseti.f90 rename to mlprec/impl/level/mld_s_base_onelev_cseti.F90 diff --git a/mlprec/impl/level/mld_s_base_onelev_seti.f90 b/mlprec/impl/level/mld_s_base_onelev_seti.F90 similarity index 100% rename from mlprec/impl/level/mld_s_base_onelev_seti.f90 rename to mlprec/impl/level/mld_s_base_onelev_seti.F90 diff --git a/mlprec/impl/level/mld_s_base_onelev_setsm.F90 b/mlprec/impl/level/mld_s_base_onelev_setsm.F90 new file mode 100644 index 00000000..ae42b099 --- /dev/null +++ b/mlprec/impl/level/mld_s_base_onelev_setsm.F90 @@ -0,0 +1,107 @@ +!!$ +!!$ +!!$ MLD2P4 version 2.0 +!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package +!!$ based on PSBLAS (Parallel Sparse BLAS version 3.3) +!!$ +!!$ (C) Copyright 2008, 2010, 2012, 2015 +!!$ +!!$ 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. +!!$ +!!$ +subroutine mld_s_base_onelev_setsm(lev,val,info,pos) + + use psb_base_mod + use mld_s_prec_mod, mld_protect_name => mld_s_base_onelev_setsm + + implicit none + + ! Arguments + class(mld_s_onelev_type), target, intent(inout) :: lev + class(mld_s_base_smoother_type), intent(in) :: val + integer(psb_ipk_), intent(out) :: info + character(len=*), optional, intent(in) :: pos + + ! Local variables + integer(psb_ipk_) :: ipos_ + character(len=*), parameter :: name='mld_base_onelev_setsm' + + info = psb_success_ + + if (present(pos)) then + select case(psb_toupper(trim(pos))) + case('PRE') + ipos_ = mld_pre_smooth_ + case('POST') + ipos_ = mld_post_smooth_ + case default + ipos_ = mld_pre_smooth_ + end select + else + ipos_ = mld_pre_smooth_ + end if + + select case(ipos_) + case(mld_pre_smooth_) + if (allocated(lev%sm)) then + if (.not.same_type_as(lev%sm,val)) then + call lev%sm%free(info) + deallocate(lev%sm, stat=info) + end if + endif + if (.not.allocated(lev%sm)) then +#ifdef HAVE_MOLD + allocate(lev%sm,mold=val) +#else + allocate(lev%sm,source=val) +#endif + end if + call lev%sm%default() + lev%sm2 => lev%sm + case(mld_post_smooth_) + if (allocated(lev%sm2a)) then + if (.not.same_type_as(lev%sm2a,val)) then + call lev%sm2a%free(info) + deallocate(lev%sm2a, stat=info) + endif + end if + if (.not.allocated(lev%sm2a)) then +#ifdef HAVE_MOLD + allocate(lev%sm2a,mold=val) +#else + allocate(lev%sm2a,source=val) +#endif + end if + call lev%sm2a%default() + lev%sm2 => lev%sm2a + end select + +end subroutine mld_s_base_onelev_setsm + diff --git a/mlprec/impl/level/mld_s_base_onelev_setsv.F90 b/mlprec/impl/level/mld_s_base_onelev_setsv.F90 new file mode 100644 index 00000000..2bcac850 --- /dev/null +++ b/mlprec/impl/level/mld_s_base_onelev_setsv.F90 @@ -0,0 +1,144 @@ +!!$ +!!$ +!!$ MLD2P4 version 2.0 +!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package +!!$ based on PSBLAS (Parallel Sparse BLAS version 3.3) +!!$ +!!$ (C) Copyright 2008, 2010, 2012, 2015 +!!$ +!!$ 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. +!!$ +!!$ +subroutine mld_s_base_onelev_setsv(lev,val,info,pos) + + use psb_base_mod + use mld_s_prec_mod, mld_protect_name => mld_s_base_onelev_setsv + + implicit none + + ! Arguments + class(mld_s_onelev_type), target, intent(inout) :: lev + class(mld_s_base_solver_type), intent(in) :: val + integer(psb_ipk_), intent(out) :: info + character(len=*), optional, intent(in) :: pos + + ! Local variables + integer(psb_ipk_) :: ipos_ + character(len=*), parameter :: name='mld_base_onelev_setsv' + + info = psb_success_ + + if (present(pos)) then + select case(psb_toupper(trim(pos))) + case('PRE') + ipos_ = mld_pre_smooth_ + case('POST') + ipos_ = mld_post_smooth_ + case default + ipos_ = mld_pre_smooth_ + end select + else + ipos_ = mld_pre_smooth_ + end if + + select case(ipos_) + case(mld_pre_smooth_) + if (allocated(lev%sm)) then + if (allocated(lev%sm%sv)) then + if (.not.same_type_as(lev%sm%sv,val)) then + call lev%sm%sv%free(info) + deallocate(lev%sm%sv,stat=info) + if (info /= 0) then + info = 3111 + return + end if + end if + end if + + if (.not.allocated(lev%sm%sv)) then +#ifdef HAVE_MOLD + allocate(lev%sm%sv,mold=val,stat=info) +#else + allocate(lev%sm%sv,source=val,stat=info) +#endif + if (info /= 0) then + info = 3111 + return + end if + end if + call lev%sm%sv%default() + else + info = 3111 + write(psb_err_unit,*) name,& + &': Error: uninitialized preconditioner component,',& + &' should call MLD_PRECINIT/MLD_PRECSET' + return + + end if + + case(mld_post_smooth_) + + if (allocated(lev%sm2a)) then + if (allocated(lev%sm2a%sv)) then + if (.not.same_type_as(lev%sm2a%sv,val)) then + call lev%sm2a%sv%free(info) + deallocate(lev%sm2a%sv,stat=info) + if (info /= 0) then + info = 3111 + return + end if + end if + end if + if (.not.allocated(lev%sm2a%sv)) then +#ifdef HAVE_MOLD + allocate(lev%sm2a%sv,mold=val,stat=info) +#else + allocate(lev%sm2a%sv,source=val,stat=info) +#endif + if (info /= 0) then + info = 3111 + return + end if + end if + call lev%sm2a%sv%default() + + else + info = 3111 + write(psb_err_unit,*) name,& + &': Error: uninitialized preconditioner component,',& + &' should call MLD_PRECINIT/MLD_PRECSET' + return + + end if + + end select + +end subroutine mld_s_base_onelev_setsv + diff --git a/mlprec/impl/level/mld_z_base_onelev_cseti.f90 b/mlprec/impl/level/mld_z_base_onelev_cseti.F90 similarity index 100% rename from mlprec/impl/level/mld_z_base_onelev_cseti.f90 rename to mlprec/impl/level/mld_z_base_onelev_cseti.F90 diff --git a/mlprec/impl/level/mld_z_base_onelev_seti.f90 b/mlprec/impl/level/mld_z_base_onelev_seti.F90 similarity index 100% rename from mlprec/impl/level/mld_z_base_onelev_seti.f90 rename to mlprec/impl/level/mld_z_base_onelev_seti.F90 diff --git a/mlprec/impl/level/mld_z_base_onelev_setsm.F90 b/mlprec/impl/level/mld_z_base_onelev_setsm.F90 new file mode 100644 index 00000000..f0ffd549 --- /dev/null +++ b/mlprec/impl/level/mld_z_base_onelev_setsm.F90 @@ -0,0 +1,107 @@ +!!$ +!!$ +!!$ MLD2P4 version 2.0 +!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package +!!$ based on PSBLAS (Parallel Sparse BLAS version 3.3) +!!$ +!!$ (C) Copyright 2008, 2010, 2012, 2015 +!!$ +!!$ 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. +!!$ +!!$ +subroutine mld_z_base_onelev_setsm(lev,val,info,pos) + + use psb_base_mod + use mld_z_prec_mod, mld_protect_name => mld_z_base_onelev_setsm + + implicit none + + ! Arguments + class(mld_z_onelev_type), target, intent(inout) :: lev + class(mld_z_base_smoother_type), intent(in) :: val + integer(psb_ipk_), intent(out) :: info + character(len=*), optional, intent(in) :: pos + + ! Local variables + integer(psb_ipk_) :: ipos_ + character(len=*), parameter :: name='mld_base_onelev_setsm' + + info = psb_success_ + + if (present(pos)) then + select case(psb_toupper(trim(pos))) + case('PRE') + ipos_ = mld_pre_smooth_ + case('POST') + ipos_ = mld_post_smooth_ + case default + ipos_ = mld_pre_smooth_ + end select + else + ipos_ = mld_pre_smooth_ + end if + + select case(ipos_) + case(mld_pre_smooth_) + if (allocated(lev%sm)) then + if (.not.same_type_as(lev%sm,val)) then + call lev%sm%free(info) + deallocate(lev%sm, stat=info) + end if + endif + if (.not.allocated(lev%sm)) then +#ifdef HAVE_MOLD + allocate(lev%sm,mold=val) +#else + allocate(lev%sm,source=val) +#endif + end if + call lev%sm%default() + lev%sm2 => lev%sm + case(mld_post_smooth_) + if (allocated(lev%sm2a)) then + if (.not.same_type_as(lev%sm2a,val)) then + call lev%sm2a%free(info) + deallocate(lev%sm2a, stat=info) + endif + end if + if (.not.allocated(lev%sm2a)) then +#ifdef HAVE_MOLD + allocate(lev%sm2a,mold=val) +#else + allocate(lev%sm2a,source=val) +#endif + end if + call lev%sm2a%default() + lev%sm2 => lev%sm2a + end select + +end subroutine mld_z_base_onelev_setsm + diff --git a/mlprec/impl/level/mld_z_base_onelev_setsv.F90 b/mlprec/impl/level/mld_z_base_onelev_setsv.F90 new file mode 100644 index 00000000..2491cda3 --- /dev/null +++ b/mlprec/impl/level/mld_z_base_onelev_setsv.F90 @@ -0,0 +1,144 @@ +!!$ +!!$ +!!$ MLD2P4 version 2.0 +!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package +!!$ based on PSBLAS (Parallel Sparse BLAS version 3.3) +!!$ +!!$ (C) Copyright 2008, 2010, 2012, 2015 +!!$ +!!$ 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. +!!$ +!!$ +subroutine mld_z_base_onelev_setsv(lev,val,info,pos) + + use psb_base_mod + use mld_z_prec_mod, mld_protect_name => mld_z_base_onelev_setsv + + implicit none + + ! Arguments + class(mld_z_onelev_type), target, intent(inout) :: lev + class(mld_z_base_solver_type), intent(in) :: val + integer(psb_ipk_), intent(out) :: info + character(len=*), optional, intent(in) :: pos + + ! Local variables + integer(psb_ipk_) :: ipos_ + character(len=*), parameter :: name='mld_base_onelev_setsv' + + info = psb_success_ + + if (present(pos)) then + select case(psb_toupper(trim(pos))) + case('PRE') + ipos_ = mld_pre_smooth_ + case('POST') + ipos_ = mld_post_smooth_ + case default + ipos_ = mld_pre_smooth_ + end select + else + ipos_ = mld_pre_smooth_ + end if + + select case(ipos_) + case(mld_pre_smooth_) + if (allocated(lev%sm)) then + if (allocated(lev%sm%sv)) then + if (.not.same_type_as(lev%sm%sv,val)) then + call lev%sm%sv%free(info) + deallocate(lev%sm%sv,stat=info) + if (info /= 0) then + info = 3111 + return + end if + end if + end if + + if (.not.allocated(lev%sm%sv)) then +#ifdef HAVE_MOLD + allocate(lev%sm%sv,mold=val,stat=info) +#else + allocate(lev%sm%sv,source=val,stat=info) +#endif + if (info /= 0) then + info = 3111 + return + end if + end if + call lev%sm%sv%default() + else + info = 3111 + write(psb_err_unit,*) name,& + &': Error: uninitialized preconditioner component,',& + &' should call MLD_PRECINIT/MLD_PRECSET' + return + + end if + + case(mld_post_smooth_) + + if (allocated(lev%sm2a)) then + if (allocated(lev%sm2a%sv)) then + if (.not.same_type_as(lev%sm2a%sv,val)) then + call lev%sm2a%sv%free(info) + deallocate(lev%sm2a%sv,stat=info) + if (info /= 0) then + info = 3111 + return + end if + end if + end if + if (.not.allocated(lev%sm2a%sv)) then +#ifdef HAVE_MOLD + allocate(lev%sm2a%sv,mold=val,stat=info) +#else + allocate(lev%sm2a%sv,source=val,stat=info) +#endif + if (info /= 0) then + info = 3111 + return + end if + end if + call lev%sm2a%sv%default() + + else + info = 3111 + write(psb_err_unit,*) name,& + &': Error: uninitialized preconditioner component,',& + &' should call MLD_PRECINIT/MLD_PRECSET' + return + + end if + + end select + +end subroutine mld_z_base_onelev_setsv + From 2c28bf3e02883611acee4adf2eb90d2eccacaec1 Mon Sep 17 00:00:00 2001 From: Salvatore Filippone Date: Tue, 17 May 2016 19:25:54 +0000 Subject: [PATCH 16/17] mld2p4-smooth-twoside: mlprec/impl/level/mld_c_base_onelev_csetc.f90 mlprec/impl/level/mld_c_base_onelev_cseti.F90 mlprec/impl/level/mld_c_base_onelev_csetr.f90 mlprec/impl/level/mld_c_base_onelev_setc.f90 mlprec/impl/level/mld_c_base_onelev_seti.F90 mlprec/impl/level/mld_c_base_onelev_setr.f90 mlprec/impl/level/mld_d_base_onelev_cseti.F90 mlprec/impl/level/mld_d_base_onelev_setc.f90 mlprec/impl/level/mld_d_base_onelev_seti.F90 mlprec/impl/level/mld_s_base_onelev_csetc.f90 mlprec/impl/level/mld_s_base_onelev_cseti.F90 mlprec/impl/level/mld_s_base_onelev_csetr.f90 mlprec/impl/level/mld_s_base_onelev_setc.f90 mlprec/impl/level/mld_s_base_onelev_seti.F90 mlprec/impl/level/mld_s_base_onelev_setr.f90 mlprec/impl/level/mld_z_base_onelev_csetc.f90 mlprec/impl/level/mld_z_base_onelev_cseti.F90 mlprec/impl/level/mld_z_base_onelev_csetr.f90 mlprec/impl/level/mld_z_base_onelev_setc.f90 mlprec/impl/level/mld_z_base_onelev_seti.F90 mlprec/impl/level/mld_z_base_onelev_setr.f90 mlprec/impl/mld_ccprecset.F90 mlprec/impl/mld_cmlprec_aply.f90 mlprec/impl/mld_cmlprec_bld.f90 mlprec/impl/mld_cprecset.F90 mlprec/impl/mld_dcprecset.F90 mlprec/impl/mld_dmlprec_aply.f90 mlprec/impl/mld_dmlprec_bld.f90 mlprec/impl/mld_dprecbld.f90 mlprec/impl/mld_dprecset.F90 mlprec/impl/mld_scprecset.F90 mlprec/impl/mld_smlprec_aply.f90 mlprec/impl/mld_smlprec_bld.f90 mlprec/impl/mld_sprecset.F90 mlprec/impl/mld_zcprecset.F90 mlprec/impl/mld_zmlprec_aply.f90 mlprec/impl/mld_zmlprec_bld.f90 mlprec/impl/mld_zprecset.F90 mlprec/impl/solver/Makefile mlprec/impl/solver/mld_c_bwgs_solver_apply.f90 mlprec/impl/solver/mld_c_bwgs_solver_apply_vect.f90 mlprec/impl/solver/mld_c_bwgs_solver_bld.f90 mlprec/impl/solver/mld_d_mumps_solver_apply.F90 mlprec/impl/solver/mld_d_mumps_solver_apply_vect.F90 mlprec/impl/solver/mld_d_mumps_solver_bld.F90 mlprec/impl/solver/mld_s_bwgs_solver_apply.f90 mlprec/impl/solver/mld_s_bwgs_solver_apply_vect.f90 mlprec/impl/solver/mld_s_bwgs_solver_bld.f90 mlprec/impl/solver/mld_s_mumps_solver_apply.F90 mlprec/impl/solver/mld_s_mumps_solver_apply_vect.F90 mlprec/impl/solver/mld_s_mumps_solver_bld.F90 mlprec/impl/solver/mld_z_bwgs_solver_apply.f90 mlprec/impl/solver/mld_z_bwgs_solver_apply_vect.f90 mlprec/impl/solver/mld_z_bwgs_solver_bld.f90 mlprec/impl/solver/mld_z_mumps_solver_apply.F90 mlprec/impl/solver/mld_z_mumps_solver_apply_vect.F90 mlprec/impl/solver/mld_z_mumps_solver_bld.F90 mlprec/mld_base_prec_type.F90 mlprec/mld_c_gs_solver.f90 mlprec/mld_c_onelev_mod.f90 mlprec/mld_c_prec_mod.f90 mlprec/mld_c_prec_type.f90 mlprec/mld_d_gs_solver.f90 mlprec/mld_d_onelev_mod.f90 mlprec/mld_d_prec_type.f90 mlprec/mld_s_gs_solver.f90 mlprec/mld_s_onelev_mod.f90 mlprec/mld_s_prec_mod.f90 mlprec/mld_s_prec_type.f90 mlprec/mld_z_gs_solver.f90 mlprec/mld_z_onelev_mod.f90 mlprec/mld_z_prec_mod.f90 mlprec/mld_z_prec_type.f90 tests/fileread/df_sample.f90 tests/fileread/runs/dfs.inp tests/pdegen/runs/ppde.inp Fixes for BWGS. Seems to be working, although it needs further testing. --- mlprec/impl/level/mld_c_base_onelev_csetc.f90 | 36 +- mlprec/impl/level/mld_c_base_onelev_cseti.F90 | 151 ++++- mlprec/impl/level/mld_c_base_onelev_csetr.f90 | 33 +- mlprec/impl/level/mld_c_base_onelev_setc.f90 | 36 +- mlprec/impl/level/mld_c_base_onelev_seti.F90 | 153 ++++- mlprec/impl/level/mld_c_base_onelev_setr.f90 | 33 +- mlprec/impl/level/mld_d_base_onelev_cseti.F90 | 18 +- mlprec/impl/level/mld_d_base_onelev_setc.f90 | 1 - mlprec/impl/level/mld_d_base_onelev_seti.F90 | 16 +- mlprec/impl/level/mld_s_base_onelev_csetc.f90 | 36 +- mlprec/impl/level/mld_s_base_onelev_cseti.F90 | 151 ++++- mlprec/impl/level/mld_s_base_onelev_csetr.f90 | 33 +- mlprec/impl/level/mld_s_base_onelev_setc.f90 | 36 +- mlprec/impl/level/mld_s_base_onelev_seti.F90 | 153 ++++- mlprec/impl/level/mld_s_base_onelev_setr.f90 | 33 +- mlprec/impl/level/mld_z_base_onelev_csetc.f90 | 36 +- mlprec/impl/level/mld_z_base_onelev_cseti.F90 | 151 ++++- mlprec/impl/level/mld_z_base_onelev_csetr.f90 | 33 +- mlprec/impl/level/mld_z_base_onelev_setc.f90 | 36 +- mlprec/impl/level/mld_z_base_onelev_seti.F90 | 153 ++++- mlprec/impl/level/mld_z_base_onelev_setr.f90 | 33 +- mlprec/impl/mld_ccprecset.F90 | 447 +++------------ mlprec/impl/mld_cmlprec_aply.f90 | 134 +++-- mlprec/impl/mld_cmlprec_bld.f90 | 12 +- mlprec/impl/mld_cprecset.F90 | 487 +++------------- mlprec/impl/mld_dcprecset.F90 | 6 +- mlprec/impl/mld_dmlprec_aply.f90 | 59 +- mlprec/impl/mld_dmlprec_bld.f90 | 12 +- mlprec/impl/mld_dprecbld.f90 | 12 +- mlprec/impl/mld_dprecset.F90 | 35 +- mlprec/impl/mld_scprecset.F90 | 447 +++------------ mlprec/impl/mld_smlprec_aply.f90 | 134 +++-- mlprec/impl/mld_smlprec_bld.f90 | 12 +- mlprec/impl/mld_sprecset.F90 | 487 +++------------- mlprec/impl/mld_zcprecset.F90 | 501 +++------------- mlprec/impl/mld_zmlprec_aply.f90 | 134 +++-- mlprec/impl/mld_zmlprec_bld.f90 | 12 +- mlprec/impl/mld_zprecset.F90 | 535 +++--------------- mlprec/impl/solver/Makefile | 9 + .../impl/solver/mld_c_bwgs_solver_apply.f90 | 196 +++++++ .../solver/mld_c_bwgs_solver_apply_vect.f90 | 200 +++++++ mlprec/impl/solver/mld_c_bwgs_solver_bld.f90 | 117 ++++ .../impl/solver/mld_d_mumps_solver_apply.F90 | 17 +- .../solver/mld_d_mumps_solver_apply_vect.F90 | 1 + mlprec/impl/solver/mld_d_mumps_solver_bld.F90 | 16 +- .../impl/solver/mld_s_bwgs_solver_apply.f90 | 196 +++++++ .../solver/mld_s_bwgs_solver_apply_vect.f90 | 200 +++++++ mlprec/impl/solver/mld_s_bwgs_solver_bld.f90 | 117 ++++ .../impl/solver/mld_s_mumps_solver_apply.F90 | 13 +- .../solver/mld_s_mumps_solver_apply_vect.F90 | 6 +- mlprec/impl/solver/mld_s_mumps_solver_bld.F90 | 15 +- .../impl/solver/mld_z_bwgs_solver_apply.f90 | 196 +++++++ .../solver/mld_z_bwgs_solver_apply_vect.f90 | 200 +++++++ mlprec/impl/solver/mld_z_bwgs_solver_bld.f90 | 117 ++++ .../impl/solver/mld_z_mumps_solver_apply.F90 | 8 +- .../solver/mld_z_mumps_solver_apply_vect.F90 | 1 + mlprec/impl/solver/mld_z_mumps_solver_bld.F90 | 1 - mlprec/mld_base_prec_type.F90 | 90 +-- mlprec/mld_c_gs_solver.f90 | 118 +++- mlprec/mld_c_onelev_mod.f90 | 96 +++- mlprec/mld_c_prec_mod.f90 | 41 +- mlprec/mld_c_prec_type.f90 | 42 +- mlprec/mld_d_gs_solver.f90 | 15 +- mlprec/mld_d_onelev_mod.f90 | 10 +- mlprec/mld_d_prec_type.f90 | 6 +- mlprec/mld_s_gs_solver.f90 | 118 +++- mlprec/mld_s_onelev_mod.f90 | 96 +++- mlprec/mld_s_prec_mod.f90 | 41 +- mlprec/mld_s_prec_type.f90 | 42 +- mlprec/mld_z_gs_solver.f90 | 118 +++- mlprec/mld_z_onelev_mod.f90 | 96 +++- mlprec/mld_z_prec_mod.f90 | 41 +- mlprec/mld_z_prec_type.f90 | 42 +- tests/fileread/df_sample.f90 | 17 +- tests/fileread/runs/dfs.inp | 18 +- tests/pdegen/runs/ppde.inp | 4 +- 76 files changed, 4443 insertions(+), 3061 deletions(-) create mode 100644 mlprec/impl/solver/mld_c_bwgs_solver_apply.f90 create mode 100644 mlprec/impl/solver/mld_c_bwgs_solver_apply_vect.f90 create mode 100644 mlprec/impl/solver/mld_c_bwgs_solver_bld.f90 create mode 100644 mlprec/impl/solver/mld_s_bwgs_solver_apply.f90 create mode 100644 mlprec/impl/solver/mld_s_bwgs_solver_apply_vect.f90 create mode 100644 mlprec/impl/solver/mld_s_bwgs_solver_bld.f90 create mode 100644 mlprec/impl/solver/mld_z_bwgs_solver_apply.f90 create mode 100644 mlprec/impl/solver/mld_z_bwgs_solver_apply_vect.f90 create mode 100644 mlprec/impl/solver/mld_z_bwgs_solver_bld.f90 diff --git a/mlprec/impl/level/mld_c_base_onelev_csetc.f90 b/mlprec/impl/level/mld_c_base_onelev_csetc.f90 index 20d2c821..4d9f0d18 100644 --- a/mlprec/impl/level/mld_c_base_onelev_csetc.f90 +++ b/mlprec/impl/level/mld_c_base_onelev_csetc.f90 @@ -36,7 +36,7 @@ !!$ POSSIBILITY OF SUCH DAMAGE. !!$ !!$ -subroutine mld_c_base_onelev_csetc(lv,what,val,info) +subroutine mld_c_base_onelev_csetc(lv,what,val,info,pos) use psb_base_mod use mld_c_onelev_mod, mld_protect_name => mld_c_base_onelev_csetc @@ -48,7 +48,9 @@ subroutine mld_c_base_onelev_csetc(lv,what,val,info) character(len=*), intent(in) :: what character(len=*), intent(in) :: val integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act + character(len=*), optional, intent(in) :: pos + ! Local + integer(psb_ipk_) :: ipos_, err_act character(len=20) :: name='c_base_onelev_csetc' integer(psb_ipk_) :: ival @@ -58,11 +60,35 @@ subroutine mld_c_base_onelev_csetc(lv,what,val,info) ival = lv%stringval(val) if (ival >= 0) then - call lv%set(what,ival,info) + call lv%set(what,ival,info,pos=pos) else - if (allocated(lv%sm)) then - call lv%sm%set(what,val,info) + + if (present(pos)) then + select case(psb_toupper(trim(pos))) + case('PRE') + ipos_ = mld_pre_smooth_ + case('POST') + ipos_ = mld_post_smooth_ + case default + ipos_ = mld_pre_smooth_ + end select + else + ipos_ = mld_pre_smooth_ end if + select case(ipos_) + case(mld_pre_smooth_) + if (allocated(lv%sm)) then + call lv%sm%set(what,val,info) + end if + case (mld_post_smooth_) + if (allocated(lv%sm2a)) then + call lv%sm2a%set(what,val,info) + end if + case default + ! Impossible!! + info = psb_err_internal_error_ + end select + end if diff --git a/mlprec/impl/level/mld_c_base_onelev_cseti.F90 b/mlprec/impl/level/mld_c_base_onelev_cseti.F90 index ecb4e6c9..6399420e 100644 --- a/mlprec/impl/level/mld_c_base_onelev_cseti.F90 +++ b/mlprec/impl/level/mld_c_base_onelev_cseti.F90 @@ -36,10 +36,28 @@ !!$ POSSIBILITY OF SUCH DAMAGE. !!$ !!$ -subroutine mld_c_base_onelev_cseti(lv,what,val,info) +subroutine mld_c_base_onelev_cseti(lv,what,val,info,pos) use psb_base_mod use mld_c_onelev_mod, mld_protect_name => mld_c_base_onelev_cseti + use mld_c_jac_smoother + use mld_c_as_smoother + use mld_c_diag_solver + use mld_c_ilu_solver + use mld_c_id_solver + use mld_c_gs_solver +#if defined(HAVE_UMF_) + use mld_c_umf_solver +#endif +#if defined(HAVE_SLUDIST_) + use mld_c_sludist_solver +#endif +#if defined(HAVE_SLU_) + use mld_c_slu_solver +#endif +#if defined(HAVE_MUMPS_) + use mld_c_mumps_solver +#endif Implicit None @@ -48,13 +66,123 @@ subroutine mld_c_base_onelev_cseti(lv,what,val,info) character(len=*), intent(in) :: what integer(psb_ipk_), intent(in) :: val integer(psb_ipk_), intent(out) :: info - Integer(Psb_ipk_) :: err_act + character(len=*), optional, intent(in) :: pos + ! Local + integer(psb_ipk_) :: ipos_, err_act character(len=20) :: name='c_base_onelev_cseti' - + type(mld_c_base_smoother_type) :: mld_c_base_smoother_mold + type(mld_c_jac_smoother_type) :: mld_c_jac_smoother_mold + type(mld_c_as_smoother_type) :: mld_c_as_smoother_mold + type(mld_c_diag_solver_type) :: mld_c_diag_solver_mold + type(mld_c_ilu_solver_type) :: mld_c_ilu_solver_mold + type(mld_c_id_solver_type) :: mld_c_id_solver_mold + type(mld_c_gs_solver_type) :: mld_c_gs_solver_mold + type(mld_c_bwgs_solver_type) :: mld_c_bwgs_solver_mold +#if defined(HAVE_UMF_) + type(mld_c_umf_solver_type) :: mld_c_umf_solver_mold +#endif +#if defined(HAVE_SLUDIST_) + type(mld_c_sludist_solver_type) :: mld_c_sludist_solver_mold +#endif +#if defined(HAVE_SLU_) + type(mld_c_slu_solver_type) :: mld_c_slu_solver_mold +#endif +#if defined(HAVE_MUMPS_) + type(mld_c_mumps_solver_type) :: mld_c_mumps_solver_mold +#endif + call psb_erractionsave(err_act) info = psb_success_ + if (present(pos)) then + select case(psb_toupper(trim(pos))) + case('PRE') + ipos_ = mld_pre_smooth_ + case('POST') + ipos_ = mld_post_smooth_ + case default + ipos_ = mld_pre_smooth_ + end select + else + ipos_ = mld_pre_smooth_ + end if + select case (psb_toupper(what)) + case ('SMOOTHER_TYPE') + select case (val) + case (mld_noprec_) + call lv%set(mld_c_base_smoother_mold,info,pos=pos) + if (info == 0) call lv%set(mld_c_id_solver_mold,info,pos=pos) + + case (mld_jac_) + call lv%set(mld_c_jac_smoother_mold,info,pos=pos) + if (info == 0) call lv%set(mld_c_diag_solver_mold,info,pos=pos) + + case (mld_bjac_) + call lv%set(mld_c_jac_smoother_mold,info,pos=pos) + if (info == 0) call lv%set(mld_c_ilu_solver_mold,info,pos=pos) + + case (mld_as_) + call lv%set(mld_c_as_smoother_mold,info,pos=pos) + if (info == 0) call lv%set(mld_c_ilu_solver_mold,info,pos=pos) + + case default + ! + ! Do nothing and hope for the best :) + ! + end select + if (allocated(lv%sm)) call lv%sm%default() + + case('SUB_SOLVE') + select case (val) + case (mld_f_none_) + call lv%set(mld_c_id_solver_mold,info,pos=pos) + + case (mld_diag_scale_) + call lv%set(mld_c_diag_solver_mold,info,pos=pos) + + case (mld_gs_) + call lv%set(mld_c_gs_solver_mold,info,pos=pos) + + case (mld_bwgs_) + call lv%set(mld_c_bwgs_solver_mold,info,pos=pos) + + case (mld_ilu_n_,mld_milu_n_,mld_ilu_t_) + call lv%set(mld_c_ilu_solver_mold,info,pos=pos) + if (info == 0) then + select case(ipos_) + case(mld_pre_smooth_) + call lv%sm%sv%set('SUB_SOLVE',val,info) + case (mld_post_smooth_) + if (allocated(lv%sm2a)) call lv%sm2a%sv%set('SUB_SOLVE',val,info) + case default + ! Impossible!! + info = psb_err_internal_error_ + end select + end if +#ifdef HAVE_SLU_ + case (mld_slu_) + call lv%set(mld_c_slu_solver_mold,info,pos=pos) +#endif +#ifdef HAVE_SLUDIST_ + case (mld_sludist_) + call lv%set(mld_c_sludist_solver_mold,info,pos=pos) +#endif +#ifdef HAVE_MUMPS_ + case (mld_mumps_) + call lv%set(mld_c_mumps_solver_mold,info,pos=pos) +#endif + +#ifdef HAVE_UMF_ + case (mld_umf_) + call lv%set(mld_c_umf_solver_mold,info,pos=pos) +#endif + case default + ! + ! Do nothing and hope for the best :) + ! + end select + case ('SMOOTHER_SWEEPS') lv%parms%sweeps = val @@ -98,9 +226,20 @@ subroutine mld_c_base_onelev_cseti(lv,what,val,info) lv%parms%coarse_solve = val case default - if (allocated(lv%sm)) then - call lv%sm%set(what,val,info) - end if + select case(ipos_) + case(mld_pre_smooth_) + if (allocated(lv%sm)) then + call lv%sm%set(what,val,info) + end if + case (mld_post_smooth_) + if (allocated(lv%sm2a)) then + call lv%sm2a%set(what,val,info) + end if + case default + ! Impossible!! + info = psb_err_internal_error_ + end select + end select if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) diff --git a/mlprec/impl/level/mld_c_base_onelev_csetr.f90 b/mlprec/impl/level/mld_c_base_onelev_csetr.f90 index e7dda2f5..562fab6b 100644 --- a/mlprec/impl/level/mld_c_base_onelev_csetr.f90 +++ b/mlprec/impl/level/mld_c_base_onelev_csetr.f90 @@ -36,7 +36,7 @@ !!$ POSSIBILITY OF SUCH DAMAGE. !!$ !!$ -subroutine mld_c_base_onelev_csetr(lv,what,val,info) +subroutine mld_c_base_onelev_csetr(lv,what,val,info,pos) use psb_base_mod use mld_c_onelev_mod, mld_protect_name => mld_c_base_onelev_csetr @@ -48,7 +48,9 @@ subroutine mld_c_base_onelev_csetr(lv,what,val,info) character(len=*), intent(in) :: what real(psb_spk_), intent(in) :: val integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act + character(len=*), optional, intent(in) :: pos + ! Local + integer(psb_ipk_) :: ipos_, err_act character(len=20) :: name='c_base_onelev_csetr' call psb_erractionsave(err_act) @@ -68,9 +70,32 @@ subroutine mld_c_base_onelev_csetr(lv,what,val,info) lv%parms%aggr_scale = val case default - if (allocated(lv%sm)) then - call lv%sm%set(what,val,info) + + if (present(pos)) then + select case(psb_toupper(trim(pos))) + case('PRE') + ipos_ = mld_pre_smooth_ + case('POST') + ipos_ = mld_post_smooth_ + case default + ipos_ = mld_pre_smooth_ + end select + else + ipos_ = mld_pre_smooth_ end if + select case(ipos_) + case(mld_pre_smooth_) + if (allocated(lv%sm)) then + call lv%sm%set(what,val,info) + end if + case (mld_post_smooth_) + if (allocated(lv%sm2a)) then + call lv%sm2a%set(what,val,info) + end if + case default + ! Impossible!! + info = psb_err_internal_error_ + end select end select if (info /= psb_success_) goto 9999 diff --git a/mlprec/impl/level/mld_c_base_onelev_setc.f90 b/mlprec/impl/level/mld_c_base_onelev_setc.f90 index 4b60b17c..909a3d1b 100644 --- a/mlprec/impl/level/mld_c_base_onelev_setc.f90 +++ b/mlprec/impl/level/mld_c_base_onelev_setc.f90 @@ -36,7 +36,7 @@ !!$ POSSIBILITY OF SUCH DAMAGE. !!$ !!$ -subroutine mld_c_base_onelev_setc(lv,what,val,info) +subroutine mld_c_base_onelev_setc(lv,what,val,info,pos) use psb_base_mod use mld_c_onelev_mod, mld_protect_name => mld_c_base_onelev_setc @@ -48,7 +48,9 @@ subroutine mld_c_base_onelev_setc(lv,what,val,info) integer(psb_ipk_), intent(in) :: what character(len=*), intent(in) :: val integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act + character(len=*), optional, intent(in) :: pos + ! Local + integer(psb_ipk_) :: ipos_, err_act character(len=20) :: name='c_base_onelev_setc' integer(psb_ipk_) :: ival @@ -58,14 +60,36 @@ subroutine mld_c_base_onelev_setc(lv,what,val,info) ival = lv%stringval(val) if (ival >= 0) then - call lv%set(what,ival,info) + call lv%set(what,ival,info,pos=pos) else - if (allocated(lv%sm)) then - call lv%sm%set(what,val,info) + + if (present(pos)) then + select case(psb_toupper(trim(pos))) + case('PRE') + ipos_ = mld_pre_smooth_ + case('POST') + ipos_ = mld_post_smooth_ + case default + ipos_ = mld_pre_smooth_ + end select + else + ipos_ = mld_pre_smooth_ end if + select case(ipos_) + case(mld_pre_smooth_) + if (allocated(lv%sm)) then + call lv%sm%set(what,val,info) + end if + case (mld_post_smooth_) + if (allocated(lv%sm2a)) then + call lv%sm2a%set(what,val,info) + end if + case default + ! Impossible!! + info = psb_err_internal_error_ + end select end if - if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) diff --git a/mlprec/impl/level/mld_c_base_onelev_seti.F90 b/mlprec/impl/level/mld_c_base_onelev_seti.F90 index 859c1b5c..46a2ee2b 100644 --- a/mlprec/impl/level/mld_c_base_onelev_seti.F90 +++ b/mlprec/impl/level/mld_c_base_onelev_seti.F90 @@ -36,10 +36,28 @@ !!$ POSSIBILITY OF SUCH DAMAGE. !!$ !!$ -subroutine mld_c_base_onelev_seti(lv,what,val,info) +subroutine mld_c_base_onelev_seti(lv,what,val,info,pos) use psb_base_mod use mld_c_onelev_mod, mld_protect_name => mld_c_base_onelev_seti + use mld_c_jac_smoother + use mld_c_as_smoother + use mld_c_diag_solver + use mld_c_ilu_solver + use mld_c_id_solver + use mld_c_gs_solver +#if defined(HAVE_UMF_) + use mld_c_umf_solver +#endif +#if defined(HAVE_SLUDIST_) + use mld_c_sludist_solver +#endif +#if defined(HAVE_SLU_) + use mld_c_slu_solver +#endif +#if defined(HAVE_MUMPS_) + use mld_c_mumps_solver +#endif Implicit None @@ -48,14 +66,123 @@ subroutine mld_c_base_onelev_seti(lv,what,val,info) integer(psb_ipk_), intent(in) :: what integer(psb_ipk_), intent(in) :: val integer(psb_ipk_), intent(out) :: info - Integer(Psb_ipk_) :: err_act + character(len=*), optional, intent(in) :: pos + ! Local + integer(psb_ipk_) :: ipos_, err_act character(len=20) :: name='c_base_onelev_seti' - + type(mld_c_base_smoother_type) :: mld_c_base_smoother_mold + type(mld_c_jac_smoother_type) :: mld_c_jac_smoother_mold + type(mld_c_as_smoother_type) :: mld_c_as_smoother_mold + type(mld_c_diag_solver_type) :: mld_c_diag_solver_mold + type(mld_c_ilu_solver_type) :: mld_c_ilu_solver_mold + type(mld_c_id_solver_type) :: mld_c_id_solver_mold + type(mld_c_gs_solver_type) :: mld_c_gs_solver_mold + type(mld_c_bwgs_solver_type) :: mld_c_bwgs_solver_mold +#if defined(HAVE_UMF_) + type(mld_c_umf_solver_type) :: mld_c_umf_solver_mold +#endif +#if defined(HAVE_SLUDIST_) + type(mld_c_sludist_solver_type) :: mld_c_sludist_solver_mold +#endif +#if defined(HAVE_SLU_) + type(mld_c_slu_solver_type) :: mld_c_slu_solver_mold +#endif +#if defined(HAVE_MUMPS_) + type(mld_c_mumps_solver_type) :: mld_c_mumps_solver_mold +#endif + call psb_erractionsave(err_act) info = psb_success_ - + if (present(pos)) then + select case(psb_toupper(trim(pos))) + case('PRE') + ipos_ = mld_pre_smooth_ + case('POST') + ipos_ = mld_post_smooth_ + case default + ipos_ = mld_pre_smooth_ + end select + else + ipos_ = mld_pre_smooth_ + end if + select case (what) + case (mld_smoother_type_) + select case (val) + case (mld_noprec_) + call lv%set(mld_c_base_smoother_mold,info,pos=pos) + if (info == 0) call lv%set(mld_c_id_solver_mold,info,pos=pos) + + case (mld_jac_) + call lv%set(mld_c_jac_smoother_mold,info,pos=pos) + if (info == 0) call lv%set(mld_c_diag_solver_mold,info,pos=pos) + + case (mld_bjac_) + call lv%set(mld_c_jac_smoother_mold,info,pos=pos) + if (info == 0) call lv%set(mld_c_ilu_solver_mold,info,pos=pos) + + case (mld_as_) + call lv%set(mld_c_as_smoother_mold,info,pos=pos) + if (info == 0) call lv%set(mld_c_ilu_solver_mold,info,pos=pos) + + case default + ! + ! Do nothing and hope for the best :) + ! + end select + if (allocated(lv%sm)) call lv%sm%default() + + case(mld_sub_solve_) + select case (val) + case (mld_f_none_) + call lv%set(mld_c_id_solver_mold,info,pos=pos) + + case (mld_diag_scale_) + call lv%set(mld_c_diag_solver_mold,info,pos=pos) + + case (mld_gs_) + call lv%set(mld_c_gs_solver_mold,info,pos=pos) + + case (mld_bwgs_) + call lv%set(mld_c_bwgs_solver_mold,info,pos=pos) + + case (mld_ilu_n_,mld_milu_n_,mld_ilu_t_) + call lv%set(mld_c_ilu_solver_mold,info,pos=pos) + if (info == 0) then + select case(ipos_) + case(mld_pre_smooth_) + call lv%sm%sv%set('SUB_SOLVE',val,info) + case (mld_post_smooth_) + if (allocated(lv%sm2a)) call lv%sm2a%sv%set('SUB_SOLVE',val,info) + case default + ! Impossible!! + info = psb_err_internal_error_ + end select + end if +#ifdef HAVE_SLU_ + case (mld_slu_) + call lv%set(mld_c_slu_solver_mold,info,pos=pos) +#endif +#ifdef HAVE_SLUDIST_ + case (mld_sludist_) + call lv%set(mld_c_sludist_solver_mold,info,pos=pos) +#endif +#ifdef HAVE_MUMPS_ + case (mld_mumps_) + call lv%set(mld_c_mumps_solver_mold,info,pos=pos) +#endif + +#ifdef HAVE_UMF_ + case (mld_umf_) + call lv%set(mld_c_umf_solver_mold,info,pos=pos) +#endif + case default + ! + ! Do nothing and hope for the best :) + ! + end select + case (mld_smoother_sweeps_) lv%parms%sweeps = val lv%parms%sweeps_pre = val @@ -98,9 +225,21 @@ subroutine mld_c_base_onelev_seti(lv,what,val,info) lv%parms%coarse_solve = val case default - if (allocated(lv%sm)) then - call lv%sm%set(what,val,info) - end if + + select case(ipos_) + case(mld_pre_smooth_) + if (allocated(lv%sm)) then + call lv%sm%set(what,val,info) + end if + case (mld_post_smooth_) + if (allocated(lv%sm2a)) then + call lv%sm2a%set(what,val,info) + end if + case default + ! Impossible!! + info = psb_err_internal_error_ + end select + end select if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) diff --git a/mlprec/impl/level/mld_c_base_onelev_setr.f90 b/mlprec/impl/level/mld_c_base_onelev_setr.f90 index c371136c..4187e049 100644 --- a/mlprec/impl/level/mld_c_base_onelev_setr.f90 +++ b/mlprec/impl/level/mld_c_base_onelev_setr.f90 @@ -36,7 +36,7 @@ !!$ POSSIBILITY OF SUCH DAMAGE. !!$ !!$ -subroutine mld_c_base_onelev_setr(lv,what,val,info) +subroutine mld_c_base_onelev_setr(lv,what,val,info,pos) use psb_base_mod use mld_c_onelev_mod, mld_protect_name => mld_c_base_onelev_setr @@ -48,7 +48,9 @@ subroutine mld_c_base_onelev_setr(lv,what,val,info) integer(psb_ipk_), intent(in) :: what real(psb_spk_), intent(in) :: val integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act + character(len=*), optional, intent(in) :: pos + ! Local + integer(psb_ipk_) :: ipos_, err_act character(len=20) :: name='c_base_onelev_setr' call psb_erractionsave(err_act) @@ -68,9 +70,32 @@ subroutine mld_c_base_onelev_setr(lv,what,val,info) lv%parms%aggr_scale = val case default - if (allocated(lv%sm)) then - call lv%sm%set(what,val,info) + + if (present(pos)) then + select case(psb_toupper(trim(pos))) + case('PRE') + ipos_ = mld_pre_smooth_ + case('POST') + ipos_ = mld_post_smooth_ + case default + ipos_ = mld_pre_smooth_ + end select + else + ipos_ = mld_pre_smooth_ end if + select case(ipos_) + case(mld_pre_smooth_) + if (allocated(lv%sm)) then + call lv%sm%set(what,val,info) + end if + case (mld_post_smooth_) + if (allocated(lv%sm2a)) then + call lv%sm2a%set(what,val,info) + end if + case default + ! Impossible!! + info = psb_err_internal_error_ + end select end select if (info /= psb_success_) goto 9999 diff --git a/mlprec/impl/level/mld_d_base_onelev_cseti.F90 b/mlprec/impl/level/mld_d_base_onelev_cseti.F90 index 9e28388f..987886d4 100644 --- a/mlprec/impl/level/mld_d_base_onelev_cseti.F90 +++ b/mlprec/impl/level/mld_d_base_onelev_cseti.F90 @@ -71,14 +71,15 @@ subroutine mld_d_base_onelev_cseti(lv,what,val,info,pos) integer(psb_ipk_) :: ipos_, err_act character(len=20) :: name='d_base_onelev_cseti' type(mld_d_base_smoother_type) :: mld_d_base_smoother_mold - type(mld_d_jac_smoother_type) :: mld_d_jac_smoother_mold - type(mld_d_as_smoother_type) :: mld_d_as_smoother_mold - type(mld_d_diag_solver_type) :: mld_d_diag_solver_mold - type(mld_d_ilu_solver_type) :: mld_d_ilu_solver_mold - type(mld_d_id_solver_type) :: mld_d_id_solver_mold - type(mld_d_gs_solver_type) :: mld_d_gs_solver_mold + type(mld_d_jac_smoother_type) :: mld_d_jac_smoother_mold + type(mld_d_as_smoother_type) :: mld_d_as_smoother_mold + type(mld_d_diag_solver_type) :: mld_d_diag_solver_mold + type(mld_d_ilu_solver_type) :: mld_d_ilu_solver_mold + type(mld_d_id_solver_type) :: mld_d_id_solver_mold + type(mld_d_gs_solver_type) :: mld_d_gs_solver_mold + type(mld_d_bwgs_solver_type) :: mld_d_bwgs_solver_mold #if defined(HAVE_UMF_) - type(mld_d_umf_solver_type) :: mld_d_umf_solver_mold + type(mld_d_umf_solver_type) :: mld_d_umf_solver_mold #endif #if defined(HAVE_SLUDIST_) type(mld_d_sludist_solver_type) :: mld_d_sludist_solver_mold @@ -143,6 +144,9 @@ subroutine mld_d_base_onelev_cseti(lv,what,val,info,pos) case (mld_gs_) call lv%set(mld_d_gs_solver_mold,info,pos=pos) + case (mld_bwgs_) + call lv%set(mld_d_bwgs_solver_mold,info,pos=pos) + case (mld_ilu_n_,mld_milu_n_,mld_ilu_t_) call lv%set(mld_d_ilu_solver_mold,info,pos=pos) if (info == 0) then diff --git a/mlprec/impl/level/mld_d_base_onelev_setc.f90 b/mlprec/impl/level/mld_d_base_onelev_setc.f90 index 21a7d78f..6474489b 100644 --- a/mlprec/impl/level/mld_d_base_onelev_setc.f90 +++ b/mlprec/impl/level/mld_d_base_onelev_setc.f90 @@ -90,7 +90,6 @@ subroutine mld_d_base_onelev_setc(lv,what,val,info,pos) end select end if - if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) diff --git a/mlprec/impl/level/mld_d_base_onelev_seti.F90 b/mlprec/impl/level/mld_d_base_onelev_seti.F90 index f60432b0..63aab65f 100644 --- a/mlprec/impl/level/mld_d_base_onelev_seti.F90 +++ b/mlprec/impl/level/mld_d_base_onelev_seti.F90 @@ -71,12 +71,13 @@ subroutine mld_d_base_onelev_seti(lv,what,val,info,pos) integer(psb_ipk_) :: ipos_, err_act character(len=20) :: name='d_base_onelev_seti' type(mld_d_base_smoother_type) :: mld_d_base_smoother_mold - type(mld_d_jac_smoother_type) :: mld_d_jac_smoother_mold - type(mld_d_as_smoother_type) :: mld_d_as_smoother_mold - type(mld_d_diag_solver_type) :: mld_d_diag_solver_mold - type(mld_d_ilu_solver_type) :: mld_d_ilu_solver_mold - type(mld_d_id_solver_type) :: mld_d_id_solver_mold - type(mld_d_gs_solver_type) :: mld_d_gs_solver_mold + type(mld_d_jac_smoother_type) :: mld_d_jac_smoother_mold + type(mld_d_as_smoother_type) :: mld_d_as_smoother_mold + type(mld_d_diag_solver_type) :: mld_d_diag_solver_mold + type(mld_d_ilu_solver_type) :: mld_d_ilu_solver_mold + type(mld_d_id_solver_type) :: mld_d_id_solver_mold + type(mld_d_gs_solver_type) :: mld_d_gs_solver_mold + type(mld_d_bwgs_solver_type) :: mld_d_bwgs_solver_mold #if defined(HAVE_UMF_) type(mld_d_umf_solver_type) :: mld_d_umf_solver_mold #endif @@ -142,6 +143,9 @@ subroutine mld_d_base_onelev_seti(lv,what,val,info,pos) case (mld_gs_) call lv%set(mld_d_gs_solver_mold,info,pos=pos) + + case (mld_bwgs_) + call lv%set(mld_d_bwgs_solver_mold,info,pos=pos) case (mld_ilu_n_,mld_milu_n_,mld_ilu_t_) call lv%set(mld_d_ilu_solver_mold,info,pos=pos) diff --git a/mlprec/impl/level/mld_s_base_onelev_csetc.f90 b/mlprec/impl/level/mld_s_base_onelev_csetc.f90 index c60ca08f..2cf0db01 100644 --- a/mlprec/impl/level/mld_s_base_onelev_csetc.f90 +++ b/mlprec/impl/level/mld_s_base_onelev_csetc.f90 @@ -36,7 +36,7 @@ !!$ POSSIBILITY OF SUCH DAMAGE. !!$ !!$ -subroutine mld_s_base_onelev_csetc(lv,what,val,info) +subroutine mld_s_base_onelev_csetc(lv,what,val,info,pos) use psb_base_mod use mld_s_onelev_mod, mld_protect_name => mld_s_base_onelev_csetc @@ -48,7 +48,9 @@ subroutine mld_s_base_onelev_csetc(lv,what,val,info) character(len=*), intent(in) :: what character(len=*), intent(in) :: val integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act + character(len=*), optional, intent(in) :: pos + ! Local + integer(psb_ipk_) :: ipos_, err_act character(len=20) :: name='s_base_onelev_csetc' integer(psb_ipk_) :: ival @@ -58,11 +60,35 @@ subroutine mld_s_base_onelev_csetc(lv,what,val,info) ival = lv%stringval(val) if (ival >= 0) then - call lv%set(what,ival,info) + call lv%set(what,ival,info,pos=pos) else - if (allocated(lv%sm)) then - call lv%sm%set(what,val,info) + + if (present(pos)) then + select case(psb_toupper(trim(pos))) + case('PRE') + ipos_ = mld_pre_smooth_ + case('POST') + ipos_ = mld_post_smooth_ + case default + ipos_ = mld_pre_smooth_ + end select + else + ipos_ = mld_pre_smooth_ end if + select case(ipos_) + case(mld_pre_smooth_) + if (allocated(lv%sm)) then + call lv%sm%set(what,val,info) + end if + case (mld_post_smooth_) + if (allocated(lv%sm2a)) then + call lv%sm2a%set(what,val,info) + end if + case default + ! Impossible!! + info = psb_err_internal_error_ + end select + end if diff --git a/mlprec/impl/level/mld_s_base_onelev_cseti.F90 b/mlprec/impl/level/mld_s_base_onelev_cseti.F90 index b35e92ba..16e4e00d 100644 --- a/mlprec/impl/level/mld_s_base_onelev_cseti.F90 +++ b/mlprec/impl/level/mld_s_base_onelev_cseti.F90 @@ -36,10 +36,28 @@ !!$ POSSIBILITY OF SUCH DAMAGE. !!$ !!$ -subroutine mld_s_base_onelev_cseti(lv,what,val,info) +subroutine mld_s_base_onelev_cseti(lv,what,val,info,pos) use psb_base_mod use mld_s_onelev_mod, mld_protect_name => mld_s_base_onelev_cseti + use mld_s_jac_smoother + use mld_s_as_smoother + use mld_s_diag_solver + use mld_s_ilu_solver + use mld_s_id_solver + use mld_s_gs_solver +#if defined(HAVE_UMF_) + use mld_s_umf_solver +#endif +#if defined(HAVE_SLUDIST_) + use mld_s_sludist_solver +#endif +#if defined(HAVE_SLU_) + use mld_s_slu_solver +#endif +#if defined(HAVE_MUMPS_) + use mld_s_mumps_solver +#endif Implicit None @@ -48,13 +66,123 @@ subroutine mld_s_base_onelev_cseti(lv,what,val,info) character(len=*), intent(in) :: what integer(psb_ipk_), intent(in) :: val integer(psb_ipk_), intent(out) :: info - Integer(Psb_ipk_) :: err_act + character(len=*), optional, intent(in) :: pos + ! Local + integer(psb_ipk_) :: ipos_, err_act character(len=20) :: name='s_base_onelev_cseti' - + type(mld_s_base_smoother_type) :: mld_s_base_smoother_mold + type(mld_s_jac_smoother_type) :: mld_s_jac_smoother_mold + type(mld_s_as_smoother_type) :: mld_s_as_smoother_mold + type(mld_s_diag_solver_type) :: mld_s_diag_solver_mold + type(mld_s_ilu_solver_type) :: mld_s_ilu_solver_mold + type(mld_s_id_solver_type) :: mld_s_id_solver_mold + type(mld_s_gs_solver_type) :: mld_s_gs_solver_mold + type(mld_s_bwgs_solver_type) :: mld_s_bwgs_solver_mold +#if defined(HAVE_UMF_) + type(mld_s_umf_solver_type) :: mld_s_umf_solver_mold +#endif +#if defined(HAVE_SLUDIST_) + type(mld_s_sludist_solver_type) :: mld_s_sludist_solver_mold +#endif +#if defined(HAVE_SLU_) + type(mld_s_slu_solver_type) :: mld_s_slu_solver_mold +#endif +#if defined(HAVE_MUMPS_) + type(mld_s_mumps_solver_type) :: mld_s_mumps_solver_mold +#endif + call psb_erractionsave(err_act) info = psb_success_ + if (present(pos)) then + select case(psb_toupper(trim(pos))) + case('PRE') + ipos_ = mld_pre_smooth_ + case('POST') + ipos_ = mld_post_smooth_ + case default + ipos_ = mld_pre_smooth_ + end select + else + ipos_ = mld_pre_smooth_ + end if + select case (psb_toupper(what)) + case ('SMOOTHER_TYPE') + select case (val) + case (mld_noprec_) + call lv%set(mld_s_base_smoother_mold,info,pos=pos) + if (info == 0) call lv%set(mld_s_id_solver_mold,info,pos=pos) + + case (mld_jac_) + call lv%set(mld_s_jac_smoother_mold,info,pos=pos) + if (info == 0) call lv%set(mld_s_diag_solver_mold,info,pos=pos) + + case (mld_bjac_) + call lv%set(mld_s_jac_smoother_mold,info,pos=pos) + if (info == 0) call lv%set(mld_s_ilu_solver_mold,info,pos=pos) + + case (mld_as_) + call lv%set(mld_s_as_smoother_mold,info,pos=pos) + if (info == 0) call lv%set(mld_s_ilu_solver_mold,info,pos=pos) + + case default + ! + ! Do nothing and hope for the best :) + ! + end select + if (allocated(lv%sm)) call lv%sm%default() + + case('SUB_SOLVE') + select case (val) + case (mld_f_none_) + call lv%set(mld_s_id_solver_mold,info,pos=pos) + + case (mld_diag_scale_) + call lv%set(mld_s_diag_solver_mold,info,pos=pos) + + case (mld_gs_) + call lv%set(mld_s_gs_solver_mold,info,pos=pos) + + case (mld_bwgs_) + call lv%set(mld_s_bwgs_solver_mold,info,pos=pos) + + case (mld_ilu_n_,mld_milu_n_,mld_ilu_t_) + call lv%set(mld_s_ilu_solver_mold,info,pos=pos) + if (info == 0) then + select case(ipos_) + case(mld_pre_smooth_) + call lv%sm%sv%set('SUB_SOLVE',val,info) + case (mld_post_smooth_) + if (allocated(lv%sm2a)) call lv%sm2a%sv%set('SUB_SOLVE',val,info) + case default + ! Impossible!! + info = psb_err_internal_error_ + end select + end if +#ifdef HAVE_SLU_ + case (mld_slu_) + call lv%set(mld_s_slu_solver_mold,info,pos=pos) +#endif +#ifdef HAVE_SLUDIST_ + case (mld_sludist_) + call lv%set(mld_s_sludist_solver_mold,info,pos=pos) +#endif +#ifdef HAVE_MUMPS_ + case (mld_mumps_) + call lv%set(mld_s_mumps_solver_mold,info,pos=pos) +#endif + +#ifdef HAVE_UMF_ + case (mld_umf_) + call lv%set(mld_s_umf_solver_mold,info,pos=pos) +#endif + case default + ! + ! Do nothing and hope for the best :) + ! + end select + case ('SMOOTHER_SWEEPS') lv%parms%sweeps = val @@ -98,9 +226,20 @@ subroutine mld_s_base_onelev_cseti(lv,what,val,info) lv%parms%coarse_solve = val case default - if (allocated(lv%sm)) then - call lv%sm%set(what,val,info) - end if + select case(ipos_) + case(mld_pre_smooth_) + if (allocated(lv%sm)) then + call lv%sm%set(what,val,info) + end if + case (mld_post_smooth_) + if (allocated(lv%sm2a)) then + call lv%sm2a%set(what,val,info) + end if + case default + ! Impossible!! + info = psb_err_internal_error_ + end select + end select if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) diff --git a/mlprec/impl/level/mld_s_base_onelev_csetr.f90 b/mlprec/impl/level/mld_s_base_onelev_csetr.f90 index 77d52d40..1b910a65 100644 --- a/mlprec/impl/level/mld_s_base_onelev_csetr.f90 +++ b/mlprec/impl/level/mld_s_base_onelev_csetr.f90 @@ -36,7 +36,7 @@ !!$ POSSIBILITY OF SUCH DAMAGE. !!$ !!$ -subroutine mld_s_base_onelev_csetr(lv,what,val,info) +subroutine mld_s_base_onelev_csetr(lv,what,val,info,pos) use psb_base_mod use mld_s_onelev_mod, mld_protect_name => mld_s_base_onelev_csetr @@ -48,7 +48,9 @@ subroutine mld_s_base_onelev_csetr(lv,what,val,info) character(len=*), intent(in) :: what real(psb_spk_), intent(in) :: val integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act + character(len=*), optional, intent(in) :: pos + ! Local + integer(psb_ipk_) :: ipos_, err_act character(len=20) :: name='s_base_onelev_csetr' call psb_erractionsave(err_act) @@ -68,9 +70,32 @@ subroutine mld_s_base_onelev_csetr(lv,what,val,info) lv%parms%aggr_scale = val case default - if (allocated(lv%sm)) then - call lv%sm%set(what,val,info) + + if (present(pos)) then + select case(psb_toupper(trim(pos))) + case('PRE') + ipos_ = mld_pre_smooth_ + case('POST') + ipos_ = mld_post_smooth_ + case default + ipos_ = mld_pre_smooth_ + end select + else + ipos_ = mld_pre_smooth_ end if + select case(ipos_) + case(mld_pre_smooth_) + if (allocated(lv%sm)) then + call lv%sm%set(what,val,info) + end if + case (mld_post_smooth_) + if (allocated(lv%sm2a)) then + call lv%sm2a%set(what,val,info) + end if + case default + ! Impossible!! + info = psb_err_internal_error_ + end select end select if (info /= psb_success_) goto 9999 diff --git a/mlprec/impl/level/mld_s_base_onelev_setc.f90 b/mlprec/impl/level/mld_s_base_onelev_setc.f90 index 9f3aa570..03a6086c 100644 --- a/mlprec/impl/level/mld_s_base_onelev_setc.f90 +++ b/mlprec/impl/level/mld_s_base_onelev_setc.f90 @@ -36,7 +36,7 @@ !!$ POSSIBILITY OF SUCH DAMAGE. !!$ !!$ -subroutine mld_s_base_onelev_setc(lv,what,val,info) +subroutine mld_s_base_onelev_setc(lv,what,val,info,pos) use psb_base_mod use mld_s_onelev_mod, mld_protect_name => mld_s_base_onelev_setc @@ -48,7 +48,9 @@ subroutine mld_s_base_onelev_setc(lv,what,val,info) integer(psb_ipk_), intent(in) :: what character(len=*), intent(in) :: val integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act + character(len=*), optional, intent(in) :: pos + ! Local + integer(psb_ipk_) :: ipos_, err_act character(len=20) :: name='s_base_onelev_setc' integer(psb_ipk_) :: ival @@ -58,14 +60,36 @@ subroutine mld_s_base_onelev_setc(lv,what,val,info) ival = lv%stringval(val) if (ival >= 0) then - call lv%set(what,ival,info) + call lv%set(what,ival,info,pos=pos) else - if (allocated(lv%sm)) then - call lv%sm%set(what,val,info) + + if (present(pos)) then + select case(psb_toupper(trim(pos))) + case('PRE') + ipos_ = mld_pre_smooth_ + case('POST') + ipos_ = mld_post_smooth_ + case default + ipos_ = mld_pre_smooth_ + end select + else + ipos_ = mld_pre_smooth_ end if + select case(ipos_) + case(mld_pre_smooth_) + if (allocated(lv%sm)) then + call lv%sm%set(what,val,info) + end if + case (mld_post_smooth_) + if (allocated(lv%sm2a)) then + call lv%sm2a%set(what,val,info) + end if + case default + ! Impossible!! + info = psb_err_internal_error_ + end select end if - if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) diff --git a/mlprec/impl/level/mld_s_base_onelev_seti.F90 b/mlprec/impl/level/mld_s_base_onelev_seti.F90 index ed687707..49774d04 100644 --- a/mlprec/impl/level/mld_s_base_onelev_seti.F90 +++ b/mlprec/impl/level/mld_s_base_onelev_seti.F90 @@ -36,10 +36,28 @@ !!$ POSSIBILITY OF SUCH DAMAGE. !!$ !!$ -subroutine mld_s_base_onelev_seti(lv,what,val,info) +subroutine mld_s_base_onelev_seti(lv,what,val,info,pos) use psb_base_mod use mld_s_onelev_mod, mld_protect_name => mld_s_base_onelev_seti + use mld_s_jac_smoother + use mld_s_as_smoother + use mld_s_diag_solver + use mld_s_ilu_solver + use mld_s_id_solver + use mld_s_gs_solver +#if defined(HAVE_UMF_) + use mld_s_umf_solver +#endif +#if defined(HAVE_SLUDIST_) + use mld_s_sludist_solver +#endif +#if defined(HAVE_SLU_) + use mld_s_slu_solver +#endif +#if defined(HAVE_MUMPS_) + use mld_s_mumps_solver +#endif Implicit None @@ -48,14 +66,123 @@ subroutine mld_s_base_onelev_seti(lv,what,val,info) integer(psb_ipk_), intent(in) :: what integer(psb_ipk_), intent(in) :: val integer(psb_ipk_), intent(out) :: info - Integer(Psb_ipk_) :: err_act + character(len=*), optional, intent(in) :: pos + ! Local + integer(psb_ipk_) :: ipos_, err_act character(len=20) :: name='s_base_onelev_seti' - + type(mld_s_base_smoother_type) :: mld_s_base_smoother_mold + type(mld_s_jac_smoother_type) :: mld_s_jac_smoother_mold + type(mld_s_as_smoother_type) :: mld_s_as_smoother_mold + type(mld_s_diag_solver_type) :: mld_s_diag_solver_mold + type(mld_s_ilu_solver_type) :: mld_s_ilu_solver_mold + type(mld_s_id_solver_type) :: mld_s_id_solver_mold + type(mld_s_gs_solver_type) :: mld_s_gs_solver_mold + type(mld_s_bwgs_solver_type) :: mld_s_bwgs_solver_mold +#if defined(HAVE_UMF_) + type(mld_s_umf_solver_type) :: mld_s_umf_solver_mold +#endif +#if defined(HAVE_SLUDIST_) + type(mld_s_sludist_solver_type) :: mld_s_sludist_solver_mold +#endif +#if defined(HAVE_SLU_) + type(mld_s_slu_solver_type) :: mld_s_slu_solver_mold +#endif +#if defined(HAVE_MUMPS_) + type(mld_s_mumps_solver_type) :: mld_s_mumps_solver_mold +#endif + call psb_erractionsave(err_act) info = psb_success_ - + if (present(pos)) then + select case(psb_toupper(trim(pos))) + case('PRE') + ipos_ = mld_pre_smooth_ + case('POST') + ipos_ = mld_post_smooth_ + case default + ipos_ = mld_pre_smooth_ + end select + else + ipos_ = mld_pre_smooth_ + end if + select case (what) + case (mld_smoother_type_) + select case (val) + case (mld_noprec_) + call lv%set(mld_s_base_smoother_mold,info,pos=pos) + if (info == 0) call lv%set(mld_s_id_solver_mold,info,pos=pos) + + case (mld_jac_) + call lv%set(mld_s_jac_smoother_mold,info,pos=pos) + if (info == 0) call lv%set(mld_s_diag_solver_mold,info,pos=pos) + + case (mld_bjac_) + call lv%set(mld_s_jac_smoother_mold,info,pos=pos) + if (info == 0) call lv%set(mld_s_ilu_solver_mold,info,pos=pos) + + case (mld_as_) + call lv%set(mld_s_as_smoother_mold,info,pos=pos) + if (info == 0) call lv%set(mld_s_ilu_solver_mold,info,pos=pos) + + case default + ! + ! Do nothing and hope for the best :) + ! + end select + if (allocated(lv%sm)) call lv%sm%default() + + case(mld_sub_solve_) + select case (val) + case (mld_f_none_) + call lv%set(mld_s_id_solver_mold,info,pos=pos) + + case (mld_diag_scale_) + call lv%set(mld_s_diag_solver_mold,info,pos=pos) + + case (mld_gs_) + call lv%set(mld_s_gs_solver_mold,info,pos=pos) + + case (mld_bwgs_) + call lv%set(mld_s_bwgs_solver_mold,info,pos=pos) + + case (mld_ilu_n_,mld_milu_n_,mld_ilu_t_) + call lv%set(mld_s_ilu_solver_mold,info,pos=pos) + if (info == 0) then + select case(ipos_) + case(mld_pre_smooth_) + call lv%sm%sv%set('SUB_SOLVE',val,info) + case (mld_post_smooth_) + if (allocated(lv%sm2a)) call lv%sm2a%sv%set('SUB_SOLVE',val,info) + case default + ! Impossible!! + info = psb_err_internal_error_ + end select + end if +#ifdef HAVE_SLU_ + case (mld_slu_) + call lv%set(mld_s_slu_solver_mold,info,pos=pos) +#endif +#ifdef HAVE_SLUDIST_ + case (mld_sludist_) + call lv%set(mld_s_sludist_solver_mold,info,pos=pos) +#endif +#ifdef HAVE_MUMPS_ + case (mld_mumps_) + call lv%set(mld_s_mumps_solver_mold,info,pos=pos) +#endif + +#ifdef HAVE_UMF_ + case (mld_umf_) + call lv%set(mld_s_umf_solver_mold,info,pos=pos) +#endif + case default + ! + ! Do nothing and hope for the best :) + ! + end select + case (mld_smoother_sweeps_) lv%parms%sweeps = val lv%parms%sweeps_pre = val @@ -98,9 +225,21 @@ subroutine mld_s_base_onelev_seti(lv,what,val,info) lv%parms%coarse_solve = val case default - if (allocated(lv%sm)) then - call lv%sm%set(what,val,info) - end if + + select case(ipos_) + case(mld_pre_smooth_) + if (allocated(lv%sm)) then + call lv%sm%set(what,val,info) + end if + case (mld_post_smooth_) + if (allocated(lv%sm2a)) then + call lv%sm2a%set(what,val,info) + end if + case default + ! Impossible!! + info = psb_err_internal_error_ + end select + end select if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) diff --git a/mlprec/impl/level/mld_s_base_onelev_setr.f90 b/mlprec/impl/level/mld_s_base_onelev_setr.f90 index 239c1454..b811d2b6 100644 --- a/mlprec/impl/level/mld_s_base_onelev_setr.f90 +++ b/mlprec/impl/level/mld_s_base_onelev_setr.f90 @@ -36,7 +36,7 @@ !!$ POSSIBILITY OF SUCH DAMAGE. !!$ !!$ -subroutine mld_s_base_onelev_setr(lv,what,val,info) +subroutine mld_s_base_onelev_setr(lv,what,val,info,pos) use psb_base_mod use mld_s_onelev_mod, mld_protect_name => mld_s_base_onelev_setr @@ -48,7 +48,9 @@ subroutine mld_s_base_onelev_setr(lv,what,val,info) integer(psb_ipk_), intent(in) :: what real(psb_spk_), intent(in) :: val integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act + character(len=*), optional, intent(in) :: pos + ! Local + integer(psb_ipk_) :: ipos_, err_act character(len=20) :: name='s_base_onelev_setr' call psb_erractionsave(err_act) @@ -68,9 +70,32 @@ subroutine mld_s_base_onelev_setr(lv,what,val,info) lv%parms%aggr_scale = val case default - if (allocated(lv%sm)) then - call lv%sm%set(what,val,info) + + if (present(pos)) then + select case(psb_toupper(trim(pos))) + case('PRE') + ipos_ = mld_pre_smooth_ + case('POST') + ipos_ = mld_post_smooth_ + case default + ipos_ = mld_pre_smooth_ + end select + else + ipos_ = mld_pre_smooth_ end if + select case(ipos_) + case(mld_pre_smooth_) + if (allocated(lv%sm)) then + call lv%sm%set(what,val,info) + end if + case (mld_post_smooth_) + if (allocated(lv%sm2a)) then + call lv%sm2a%set(what,val,info) + end if + case default + ! Impossible!! + info = psb_err_internal_error_ + end select end select if (info /= psb_success_) goto 9999 diff --git a/mlprec/impl/level/mld_z_base_onelev_csetc.f90 b/mlprec/impl/level/mld_z_base_onelev_csetc.f90 index 8bc3f390..0ea8ed13 100644 --- a/mlprec/impl/level/mld_z_base_onelev_csetc.f90 +++ b/mlprec/impl/level/mld_z_base_onelev_csetc.f90 @@ -36,7 +36,7 @@ !!$ POSSIBILITY OF SUCH DAMAGE. !!$ !!$ -subroutine mld_z_base_onelev_csetc(lv,what,val,info) +subroutine mld_z_base_onelev_csetc(lv,what,val,info,pos) use psb_base_mod use mld_z_onelev_mod, mld_protect_name => mld_z_base_onelev_csetc @@ -48,7 +48,9 @@ subroutine mld_z_base_onelev_csetc(lv,what,val,info) character(len=*), intent(in) :: what character(len=*), intent(in) :: val integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act + character(len=*), optional, intent(in) :: pos + ! Local + integer(psb_ipk_) :: ipos_, err_act character(len=20) :: name='z_base_onelev_csetc' integer(psb_ipk_) :: ival @@ -58,11 +60,35 @@ subroutine mld_z_base_onelev_csetc(lv,what,val,info) ival = lv%stringval(val) if (ival >= 0) then - call lv%set(what,ival,info) + call lv%set(what,ival,info,pos=pos) else - if (allocated(lv%sm)) then - call lv%sm%set(what,val,info) + + if (present(pos)) then + select case(psb_toupper(trim(pos))) + case('PRE') + ipos_ = mld_pre_smooth_ + case('POST') + ipos_ = mld_post_smooth_ + case default + ipos_ = mld_pre_smooth_ + end select + else + ipos_ = mld_pre_smooth_ end if + select case(ipos_) + case(mld_pre_smooth_) + if (allocated(lv%sm)) then + call lv%sm%set(what,val,info) + end if + case (mld_post_smooth_) + if (allocated(lv%sm2a)) then + call lv%sm2a%set(what,val,info) + end if + case default + ! Impossible!! + info = psb_err_internal_error_ + end select + end if diff --git a/mlprec/impl/level/mld_z_base_onelev_cseti.F90 b/mlprec/impl/level/mld_z_base_onelev_cseti.F90 index 6352b4b9..2ad9db47 100644 --- a/mlprec/impl/level/mld_z_base_onelev_cseti.F90 +++ b/mlprec/impl/level/mld_z_base_onelev_cseti.F90 @@ -36,10 +36,28 @@ !!$ POSSIBILITY OF SUCH DAMAGE. !!$ !!$ -subroutine mld_z_base_onelev_cseti(lv,what,val,info) +subroutine mld_z_base_onelev_cseti(lv,what,val,info,pos) use psb_base_mod use mld_z_onelev_mod, mld_protect_name => mld_z_base_onelev_cseti + use mld_z_jac_smoother + use mld_z_as_smoother + use mld_z_diag_solver + use mld_z_ilu_solver + use mld_z_id_solver + use mld_z_gs_solver +#if defined(HAVE_UMF_) + use mld_z_umf_solver +#endif +#if defined(HAVE_SLUDIST_) + use mld_z_sludist_solver +#endif +#if defined(HAVE_SLU_) + use mld_z_slu_solver +#endif +#if defined(HAVE_MUMPS_) + use mld_z_mumps_solver +#endif Implicit None @@ -48,13 +66,123 @@ subroutine mld_z_base_onelev_cseti(lv,what,val,info) character(len=*), intent(in) :: what integer(psb_ipk_), intent(in) :: val integer(psb_ipk_), intent(out) :: info - Integer(Psb_ipk_) :: err_act + character(len=*), optional, intent(in) :: pos + ! Local + integer(psb_ipk_) :: ipos_, err_act character(len=20) :: name='z_base_onelev_cseti' - + type(mld_z_base_smoother_type) :: mld_z_base_smoother_mold + type(mld_z_jac_smoother_type) :: mld_z_jac_smoother_mold + type(mld_z_as_smoother_type) :: mld_z_as_smoother_mold + type(mld_z_diag_solver_type) :: mld_z_diag_solver_mold + type(mld_z_ilu_solver_type) :: mld_z_ilu_solver_mold + type(mld_z_id_solver_type) :: mld_z_id_solver_mold + type(mld_z_gs_solver_type) :: mld_z_gs_solver_mold + type(mld_z_bwgs_solver_type) :: mld_z_bwgs_solver_mold +#if defined(HAVE_UMF_) + type(mld_z_umf_solver_type) :: mld_z_umf_solver_mold +#endif +#if defined(HAVE_SLUDIST_) + type(mld_z_sludist_solver_type) :: mld_z_sludist_solver_mold +#endif +#if defined(HAVE_SLU_) + type(mld_z_slu_solver_type) :: mld_z_slu_solver_mold +#endif +#if defined(HAVE_MUMPS_) + type(mld_z_mumps_solver_type) :: mld_z_mumps_solver_mold +#endif + call psb_erractionsave(err_act) info = psb_success_ + if (present(pos)) then + select case(psb_toupper(trim(pos))) + case('PRE') + ipos_ = mld_pre_smooth_ + case('POST') + ipos_ = mld_post_smooth_ + case default + ipos_ = mld_pre_smooth_ + end select + else + ipos_ = mld_pre_smooth_ + end if + select case (psb_toupper(what)) + case ('SMOOTHER_TYPE') + select case (val) + case (mld_noprec_) + call lv%set(mld_z_base_smoother_mold,info,pos=pos) + if (info == 0) call lv%set(mld_z_id_solver_mold,info,pos=pos) + + case (mld_jac_) + call lv%set(mld_z_jac_smoother_mold,info,pos=pos) + if (info == 0) call lv%set(mld_z_diag_solver_mold,info,pos=pos) + + case (mld_bjac_) + call lv%set(mld_z_jac_smoother_mold,info,pos=pos) + if (info == 0) call lv%set(mld_z_ilu_solver_mold,info,pos=pos) + + case (mld_as_) + call lv%set(mld_z_as_smoother_mold,info,pos=pos) + if (info == 0) call lv%set(mld_z_ilu_solver_mold,info,pos=pos) + + case default + ! + ! Do nothing and hope for the best :) + ! + end select + if (allocated(lv%sm)) call lv%sm%default() + + case('SUB_SOLVE') + select case (val) + case (mld_f_none_) + call lv%set(mld_z_id_solver_mold,info,pos=pos) + + case (mld_diag_scale_) + call lv%set(mld_z_diag_solver_mold,info,pos=pos) + + case (mld_gs_) + call lv%set(mld_z_gs_solver_mold,info,pos=pos) + + case (mld_bwgs_) + call lv%set(mld_z_bwgs_solver_mold,info,pos=pos) + + case (mld_ilu_n_,mld_milu_n_,mld_ilu_t_) + call lv%set(mld_z_ilu_solver_mold,info,pos=pos) + if (info == 0) then + select case(ipos_) + case(mld_pre_smooth_) + call lv%sm%sv%set('SUB_SOLVE',val,info) + case (mld_post_smooth_) + if (allocated(lv%sm2a)) call lv%sm2a%sv%set('SUB_SOLVE',val,info) + case default + ! Impossible!! + info = psb_err_internal_error_ + end select + end if +#ifdef HAVE_SLU_ + case (mld_slu_) + call lv%set(mld_z_slu_solver_mold,info,pos=pos) +#endif +#ifdef HAVE_SLUDIST_ + case (mld_sludist_) + call lv%set(mld_z_sludist_solver_mold,info,pos=pos) +#endif +#ifdef HAVE_MUMPS_ + case (mld_mumps_) + call lv%set(mld_z_mumps_solver_mold,info,pos=pos) +#endif + +#ifdef HAVE_UMF_ + case (mld_umf_) + call lv%set(mld_z_umf_solver_mold,info,pos=pos) +#endif + case default + ! + ! Do nothing and hope for the best :) + ! + end select + case ('SMOOTHER_SWEEPS') lv%parms%sweeps = val @@ -98,9 +226,20 @@ subroutine mld_z_base_onelev_cseti(lv,what,val,info) lv%parms%coarse_solve = val case default - if (allocated(lv%sm)) then - call lv%sm%set(what,val,info) - end if + select case(ipos_) + case(mld_pre_smooth_) + if (allocated(lv%sm)) then + call lv%sm%set(what,val,info) + end if + case (mld_post_smooth_) + if (allocated(lv%sm2a)) then + call lv%sm2a%set(what,val,info) + end if + case default + ! Impossible!! + info = psb_err_internal_error_ + end select + end select if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) diff --git a/mlprec/impl/level/mld_z_base_onelev_csetr.f90 b/mlprec/impl/level/mld_z_base_onelev_csetr.f90 index e6e8cc56..38425140 100644 --- a/mlprec/impl/level/mld_z_base_onelev_csetr.f90 +++ b/mlprec/impl/level/mld_z_base_onelev_csetr.f90 @@ -36,7 +36,7 @@ !!$ POSSIBILITY OF SUCH DAMAGE. !!$ !!$ -subroutine mld_z_base_onelev_csetr(lv,what,val,info) +subroutine mld_z_base_onelev_csetr(lv,what,val,info,pos) use psb_base_mod use mld_z_onelev_mod, mld_protect_name => mld_z_base_onelev_csetr @@ -48,7 +48,9 @@ subroutine mld_z_base_onelev_csetr(lv,what,val,info) character(len=*), intent(in) :: what real(psb_dpk_), intent(in) :: val integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act + character(len=*), optional, intent(in) :: pos + ! Local + integer(psb_ipk_) :: ipos_, err_act character(len=20) :: name='z_base_onelev_csetr' call psb_erractionsave(err_act) @@ -68,9 +70,32 @@ subroutine mld_z_base_onelev_csetr(lv,what,val,info) lv%parms%aggr_scale = val case default - if (allocated(lv%sm)) then - call lv%sm%set(what,val,info) + + if (present(pos)) then + select case(psb_toupper(trim(pos))) + case('PRE') + ipos_ = mld_pre_smooth_ + case('POST') + ipos_ = mld_post_smooth_ + case default + ipos_ = mld_pre_smooth_ + end select + else + ipos_ = mld_pre_smooth_ end if + select case(ipos_) + case(mld_pre_smooth_) + if (allocated(lv%sm)) then + call lv%sm%set(what,val,info) + end if + case (mld_post_smooth_) + if (allocated(lv%sm2a)) then + call lv%sm2a%set(what,val,info) + end if + case default + ! Impossible!! + info = psb_err_internal_error_ + end select end select if (info /= psb_success_) goto 9999 diff --git a/mlprec/impl/level/mld_z_base_onelev_setc.f90 b/mlprec/impl/level/mld_z_base_onelev_setc.f90 index 7f1501dd..dd3f3acb 100644 --- a/mlprec/impl/level/mld_z_base_onelev_setc.f90 +++ b/mlprec/impl/level/mld_z_base_onelev_setc.f90 @@ -36,7 +36,7 @@ !!$ POSSIBILITY OF SUCH DAMAGE. !!$ !!$ -subroutine mld_z_base_onelev_setc(lv,what,val,info) +subroutine mld_z_base_onelev_setc(lv,what,val,info,pos) use psb_base_mod use mld_z_onelev_mod, mld_protect_name => mld_z_base_onelev_setc @@ -48,7 +48,9 @@ subroutine mld_z_base_onelev_setc(lv,what,val,info) integer(psb_ipk_), intent(in) :: what character(len=*), intent(in) :: val integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act + character(len=*), optional, intent(in) :: pos + ! Local + integer(psb_ipk_) :: ipos_, err_act character(len=20) :: name='z_base_onelev_setc' integer(psb_ipk_) :: ival @@ -58,14 +60,36 @@ subroutine mld_z_base_onelev_setc(lv,what,val,info) ival = lv%stringval(val) if (ival >= 0) then - call lv%set(what,ival,info) + call lv%set(what,ival,info,pos=pos) else - if (allocated(lv%sm)) then - call lv%sm%set(what,val,info) + + if (present(pos)) then + select case(psb_toupper(trim(pos))) + case('PRE') + ipos_ = mld_pre_smooth_ + case('POST') + ipos_ = mld_post_smooth_ + case default + ipos_ = mld_pre_smooth_ + end select + else + ipos_ = mld_pre_smooth_ end if + select case(ipos_) + case(mld_pre_smooth_) + if (allocated(lv%sm)) then + call lv%sm%set(what,val,info) + end if + case (mld_post_smooth_) + if (allocated(lv%sm2a)) then + call lv%sm2a%set(what,val,info) + end if + case default + ! Impossible!! + info = psb_err_internal_error_ + end select end if - if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) diff --git a/mlprec/impl/level/mld_z_base_onelev_seti.F90 b/mlprec/impl/level/mld_z_base_onelev_seti.F90 index 2d0a36a1..250a6522 100644 --- a/mlprec/impl/level/mld_z_base_onelev_seti.F90 +++ b/mlprec/impl/level/mld_z_base_onelev_seti.F90 @@ -36,10 +36,28 @@ !!$ POSSIBILITY OF SUCH DAMAGE. !!$ !!$ -subroutine mld_z_base_onelev_seti(lv,what,val,info) +subroutine mld_z_base_onelev_seti(lv,what,val,info,pos) use psb_base_mod use mld_z_onelev_mod, mld_protect_name => mld_z_base_onelev_seti + use mld_z_jac_smoother + use mld_z_as_smoother + use mld_z_diag_solver + use mld_z_ilu_solver + use mld_z_id_solver + use mld_z_gs_solver +#if defined(HAVE_UMF_) + use mld_z_umf_solver +#endif +#if defined(HAVE_SLUDIST_) + use mld_z_sludist_solver +#endif +#if defined(HAVE_SLU_) + use mld_z_slu_solver +#endif +#if defined(HAVE_MUMPS_) + use mld_z_mumps_solver +#endif Implicit None @@ -48,14 +66,123 @@ subroutine mld_z_base_onelev_seti(lv,what,val,info) integer(psb_ipk_), intent(in) :: what integer(psb_ipk_), intent(in) :: val integer(psb_ipk_), intent(out) :: info - Integer(Psb_ipk_) :: err_act + character(len=*), optional, intent(in) :: pos + ! Local + integer(psb_ipk_) :: ipos_, err_act character(len=20) :: name='z_base_onelev_seti' - + type(mld_z_base_smoother_type) :: mld_z_base_smoother_mold + type(mld_z_jac_smoother_type) :: mld_z_jac_smoother_mold + type(mld_z_as_smoother_type) :: mld_z_as_smoother_mold + type(mld_z_diag_solver_type) :: mld_z_diag_solver_mold + type(mld_z_ilu_solver_type) :: mld_z_ilu_solver_mold + type(mld_z_id_solver_type) :: mld_z_id_solver_mold + type(mld_z_gs_solver_type) :: mld_z_gs_solver_mold + type(mld_z_bwgs_solver_type) :: mld_z_bwgs_solver_mold +#if defined(HAVE_UMF_) + type(mld_z_umf_solver_type) :: mld_z_umf_solver_mold +#endif +#if defined(HAVE_SLUDIST_) + type(mld_z_sludist_solver_type) :: mld_z_sludist_solver_mold +#endif +#if defined(HAVE_SLU_) + type(mld_z_slu_solver_type) :: mld_z_slu_solver_mold +#endif +#if defined(HAVE_MUMPS_) + type(mld_z_mumps_solver_type) :: mld_z_mumps_solver_mold +#endif + call psb_erractionsave(err_act) info = psb_success_ - + if (present(pos)) then + select case(psb_toupper(trim(pos))) + case('PRE') + ipos_ = mld_pre_smooth_ + case('POST') + ipos_ = mld_post_smooth_ + case default + ipos_ = mld_pre_smooth_ + end select + else + ipos_ = mld_pre_smooth_ + end if + select case (what) + case (mld_smoother_type_) + select case (val) + case (mld_noprec_) + call lv%set(mld_z_base_smoother_mold,info,pos=pos) + if (info == 0) call lv%set(mld_z_id_solver_mold,info,pos=pos) + + case (mld_jac_) + call lv%set(mld_z_jac_smoother_mold,info,pos=pos) + if (info == 0) call lv%set(mld_z_diag_solver_mold,info,pos=pos) + + case (mld_bjac_) + call lv%set(mld_z_jac_smoother_mold,info,pos=pos) + if (info == 0) call lv%set(mld_z_ilu_solver_mold,info,pos=pos) + + case (mld_as_) + call lv%set(mld_z_as_smoother_mold,info,pos=pos) + if (info == 0) call lv%set(mld_z_ilu_solver_mold,info,pos=pos) + + case default + ! + ! Do nothing and hope for the best :) + ! + end select + if (allocated(lv%sm)) call lv%sm%default() + + case(mld_sub_solve_) + select case (val) + case (mld_f_none_) + call lv%set(mld_z_id_solver_mold,info,pos=pos) + + case (mld_diag_scale_) + call lv%set(mld_z_diag_solver_mold,info,pos=pos) + + case (mld_gs_) + call lv%set(mld_z_gs_solver_mold,info,pos=pos) + + case (mld_bwgs_) + call lv%set(mld_z_bwgs_solver_mold,info,pos=pos) + + case (mld_ilu_n_,mld_milu_n_,mld_ilu_t_) + call lv%set(mld_z_ilu_solver_mold,info,pos=pos) + if (info == 0) then + select case(ipos_) + case(mld_pre_smooth_) + call lv%sm%sv%set('SUB_SOLVE',val,info) + case (mld_post_smooth_) + if (allocated(lv%sm2a)) call lv%sm2a%sv%set('SUB_SOLVE',val,info) + case default + ! Impossible!! + info = psb_err_internal_error_ + end select + end if +#ifdef HAVE_SLU_ + case (mld_slu_) + call lv%set(mld_z_slu_solver_mold,info,pos=pos) +#endif +#ifdef HAVE_SLUDIST_ + case (mld_sludist_) + call lv%set(mld_z_sludist_solver_mold,info,pos=pos) +#endif +#ifdef HAVE_MUMPS_ + case (mld_mumps_) + call lv%set(mld_z_mumps_solver_mold,info,pos=pos) +#endif + +#ifdef HAVE_UMF_ + case (mld_umf_) + call lv%set(mld_z_umf_solver_mold,info,pos=pos) +#endif + case default + ! + ! Do nothing and hope for the best :) + ! + end select + case (mld_smoother_sweeps_) lv%parms%sweeps = val lv%parms%sweeps_pre = val @@ -98,9 +225,21 @@ subroutine mld_z_base_onelev_seti(lv,what,val,info) lv%parms%coarse_solve = val case default - if (allocated(lv%sm)) then - call lv%sm%set(what,val,info) - end if + + select case(ipos_) + case(mld_pre_smooth_) + if (allocated(lv%sm)) then + call lv%sm%set(what,val,info) + end if + case (mld_post_smooth_) + if (allocated(lv%sm2a)) then + call lv%sm2a%set(what,val,info) + end if + case default + ! Impossible!! + info = psb_err_internal_error_ + end select + end select if (info /= psb_success_) goto 9999 call psb_erractionrestore(err_act) diff --git a/mlprec/impl/level/mld_z_base_onelev_setr.f90 b/mlprec/impl/level/mld_z_base_onelev_setr.f90 index e18254ca..ec299235 100644 --- a/mlprec/impl/level/mld_z_base_onelev_setr.f90 +++ b/mlprec/impl/level/mld_z_base_onelev_setr.f90 @@ -36,7 +36,7 @@ !!$ POSSIBILITY OF SUCH DAMAGE. !!$ !!$ -subroutine mld_z_base_onelev_setr(lv,what,val,info) +subroutine mld_z_base_onelev_setr(lv,what,val,info,pos) use psb_base_mod use mld_z_onelev_mod, mld_protect_name => mld_z_base_onelev_setr @@ -48,7 +48,9 @@ subroutine mld_z_base_onelev_setr(lv,what,val,info) integer(psb_ipk_), intent(in) :: what real(psb_dpk_), intent(in) :: val integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_) :: err_act + character(len=*), optional, intent(in) :: pos + ! Local + integer(psb_ipk_) :: ipos_, err_act character(len=20) :: name='z_base_onelev_setr' call psb_erractionsave(err_act) @@ -68,9 +70,32 @@ subroutine mld_z_base_onelev_setr(lv,what,val,info) lv%parms%aggr_scale = val case default - if (allocated(lv%sm)) then - call lv%sm%set(what,val,info) + + if (present(pos)) then + select case(psb_toupper(trim(pos))) + case('PRE') + ipos_ = mld_pre_smooth_ + case('POST') + ipos_ = mld_post_smooth_ + case default + ipos_ = mld_pre_smooth_ + end select + else + ipos_ = mld_pre_smooth_ end if + select case(ipos_) + case(mld_pre_smooth_) + if (allocated(lv%sm)) then + call lv%sm%set(what,val,info) + end if + case (mld_post_smooth_) + if (allocated(lv%sm2a)) then + call lv%sm2a%set(what,val,info) + end if + case default + ! Impossible!! + info = psb_err_internal_error_ + end select end select if (info /= psb_success_) goto 9999 diff --git a/mlprec/impl/mld_ccprecset.F90 b/mlprec/impl/mld_ccprecset.F90 index e4858649..86b1b413 100644 --- a/mlprec/impl/mld_ccprecset.F90 +++ b/mlprec/impl/mld_ccprecset.F90 @@ -76,7 +76,7 @@ ! For this reason, the interface mld_precset to this routine has been built in ! such a way that ilev is not visible to the user (see mld_prec_mod.f90). ! -subroutine mld_ccprecseti(p,what,val,info,ilev) +subroutine mld_ccprecseti(p,what,val,info,ilev,pos) use psb_base_mod use mld_c_prec_mod, mld_protect_name => mld_ccprecseti @@ -102,6 +102,7 @@ subroutine mld_ccprecseti(p,what,val,info,ilev) integer(psb_ipk_), intent(in) :: val integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), optional, intent(in) :: ilev + character(len=*), optional, intent(in) :: pos ! Local variables integer(psb_ipk_) :: ilev_, nlev_ @@ -144,38 +145,20 @@ subroutine mld_ccprecseti(p,what,val,info,ilev) ! ! Rules for fine level are slightly different. ! - select case(psb_toupper(trim(what))) - case('SMOOTHER_TYPE') - call onelev_set_smoother(p%precv(ilev_),val,info) - case('SUB_SOLVE') - call onelev_set_solver(p%precv(ilev_),val,info) - case('SMOOTHER_SWEEPS','ML_TYPE','AGGR_ALG','AGGR_ORD',& - & 'AGGR_KIND','SMOOTHER_POS','AGGR_OMEGA_ALG',& - & 'AGGR_EIG','SMOOTHER_SWEEPS_PRE',& - & 'SMOOTHER_SWEEPS_POST',& - & 'SUB_RESTR','SUB_PROL', & - & 'SUB_REN','SUB_OVR','SUB_FILLIN') - call p%precv(ilev_)%set(what,val,info) - - case default - call p%precv(ilev_)%set(what,val,info) - end select + call p%precv(ilev_)%set(what,val,info,pos=pos) else if (ilev_ > 1) then select case(psb_toupper(what)) - case('SMOOTHER_TYPE') - call onelev_set_smoother(p%precv(ilev_),val,info) - case('SUB_SOLVE') - call onelev_set_solver(p%precv(ilev_),val,info) - case('SMOOTHER_SWEEPS','ML_TYPE','AGGR_ALG','AGGR_ORD',& + case('SMOOTHER_TYPE','SUB_SOLVE','SMOOTHER_SWEEPS',& + & 'ML_TYPE','AGGR_ALG','AGGR_ORD',& & 'AGGR_KIND','SMOOTHER_POS','AGGR_OMEGA_ALG',& & 'AGGR_EIG','SMOOTHER_SWEEPS_PRE',& & 'SMOOTHER_SWEEPS_POST',& & 'SUB_RESTR','SUB_PROL', & & 'SUB_REN','SUB_OVR','SUB_FILLIN',& & 'COARSE_MAT') - call p%precv(ilev_)%set(what,val,info) + call p%precv(ilev_)%set(what,val,info,pos=pos) case('COARSE_SUBSOLVE') if (ilev_ /= nlev_) then @@ -184,7 +167,7 @@ subroutine mld_ccprecseti(p,what,val,info,ilev) info = -2 return end if - call onelev_set_solver(p%precv(ilev_),val,info) + call p%precv(ilev_)%set('SUB_SOLVE',val,info,pos=pos) case('COARSE_SOLVE') if (ilev_ /= nlev_) then write(psb_err_unit,*) name,& @@ -192,38 +175,34 @@ subroutine mld_ccprecseti(p,what,val,info,ilev) info = -2 return end if - + if (nlev_ > 1) then - call p%precv(nlev_)%set('COARSE_SOLVE',val,info) + call p%precv(nlev_)%set('COARSE_SOLVE',val,info,pos=pos) select case (val) case(mld_bjac_) - call onelev_set_smoother(p%precv(nlev_),val,info) -#if defined(HAVE_SLU_) - call onelev_set_solver(p%precv(nlev_),mld_slu_,info) + call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos) +#if defined(HAVE_SLU_) + call p%precv(nlev_)%set('SUB_SOLVE',mld_slu_,info,pos=pos) #elif defined(HAVE_MUMPS_) - call onelev_set_solver(p%precv(nlev_),mld_mumps_,info) -#else - call onelev_set_solver(p%precv(nlev_),mld_ilu_n_,info) + call p%precv(nlev_)%set('SUB_SOLVE',mld_mumps_,info,pos=pos) +#else + call p%precv(nlev_)%set('SUB_SOLVE',mld_ilu_n_,info,pos=pos) #endif call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info) case(mld_umf_, mld_slu_,mld_ilu_n_, mld_ilu_t_,mld_milu_n_) - call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info) - call onelev_set_solver(p%precv(nlev_),val,info) - call p%precv(nlev_)%set('COARSE_MAT',mld_repl_mat_,info) - case(mld_sludist_) - call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info) - call onelev_set_solver(p%precv(nlev_),val,info) - call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info) - case(mld_mumps_) - call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info) - call onelev_set_solver(p%precv(nlev_),val,info) - call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info) + call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos) + call p%precv(nlev_)%set('SUB_SOLVE',val,info,pos=pos) + call p%precv(nlev_)%set('COARSE_MAT',mld_repl_mat_,info,pos=pos) + case(mld_sludist_,mld_mumps_) + call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos) + call p%precv(nlev_)%set('SUB_SOLVE',val,info,pos=pos) + call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos) case(mld_jac_) - call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info) - call onelev_set_solver(p%precv(nlev_),mld_diag_scale_,info) - call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info) + call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos) + call p%precv(nlev_)%set('SUB_SOLVE',mld_diag_scale_,info,pos=pos) + call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos) end select - + endif case('COARSE_SWEEPS') if (ilev_ /= nlev_) then @@ -232,7 +211,7 @@ subroutine mld_ccprecseti(p,what,val,info,ilev) info = -2 return end if - call p%precv(nlev_)%set('SMOOTHER_SWEEPS',val,info) + call p%precv(nlev_)%set('SMOOTHER_SWEEPS',val,info,pos=pos) case('COARSE_FILLIN') if (ilev_ /= nlev_) then @@ -241,9 +220,10 @@ subroutine mld_ccprecseti(p,what,val,info,ilev) info = -2 return end if - call p%precv(nlev_)%set('SUB_FILLIN',val,info) + call p%precv(nlev_)%set('SUB_FILLIN',val,info,pos=pos) + case default - call p%precv(ilev_)%set(what,val,info) + call p%precv(ilev_)%set(what,val,info,pos=pos) end select endif @@ -254,33 +234,12 @@ subroutine mld_ccprecseti(p,what,val,info,ilev) ! levels ! select case(psb_toupper(trim(what))) - case('SUB_SOLVE') + case('SUB_SOLVE','SUB_RESTR','SUB_PROL',& + & 'SUB_REN','SUB_OVR','SUB_FILLIN',& + & 'SMOOTHER_SWEEPS','SMOOTHER_TYPE') do ilev_=1,max(1,nlev_-1) - if (.not.allocated(p%precv(ilev_)%sm)) then - write(psb_err_unit,*) name,& - & ': Error: uninitialized preconditioner component,',& - & ' should call MLD_PRECINIT' - info = -1 - return - endif - call onelev_set_solver(p%precv(ilev_),val,info) - - end do - - case('SUB_RESTR','SUB_PROL',& - & 'SUB_REN','SUB_OVR','SUB_FILLIN') - do ilev_=1,max(1,nlev_-1) - call p%precv(ilev_)%set(what,val,info) - end do - - case('SMOOTHER_SWEEPS') - do ilev_=1,max(1,nlev_-1) - call p%precv(ilev_)%set(what,val,info) - end do - - case('SMOOTHER_TYPE') - do ilev_=1,max(1,nlev_-1) - call onelev_set_smoother(p%precv(ilev_),val,info) + call p%precv(ilev_)%set(what,val,info,pos=pos) + if (info /= 0) return end do case('ML_TYPE','AGGR_ALG','AGGR_ORD','AGGR_KIND',& @@ -288,334 +247,68 @@ subroutine mld_ccprecseti(p,what,val,info,ilev) & 'SMOOTHER_POS','AGGR_OMEGA_ALG',& & 'AGGR_EIG','AGGR_FILTER') do ilev_=1,nlev_ - call p%precv(ilev_)%set(what,val,info) + call p%precv(ilev_)%set(what,val,info,pos=pos) + if (info /= 0) return end do case('COARSE_MAT') if (nlev_ > 1) then - call p%precv(nlev_)%set('COARSE_MAT',val,info) + call p%precv(nlev_)%set('COARSE_MAT',val,info,pos=pos) end if case('COARSE_SOLVE') if (nlev_ > 1) then - - call p%precv(nlev_)%set('COARSE_SOLVE',val,info) + call p%precv(nlev_)%set('COARSE_SOLVE',val,info,pos=pos) select case (val) case(mld_bjac_) - call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info) -#if defined(HAVE_SLU_) - call onelev_set_solver(p%precv(nlev_),mld_slu_,info) -#elif defined(HAVE_MUMPS_) - call onelev_set_solver(p%precv(nlev_),mld_mumps_,info) -#else - call onelev_set_solver(p%precv(nlev_),mld_ilu_n_,info) + call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos) +#if defined(HAVE_SLU_) + call p%precv(nlev_)%set('SUB_SOLVE',mld_slu_,info,pos=pos) +#elif defined(HAVE_MUMPS_) + call p%precv(nlev_)%set('SUB_SOLVE',mld_mumps_,info,pos=pos) +#else + call p%precv(nlev_)%set('SUB_SOLVE',mld_ilu_n_,info,pos=pos) #endif call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info) case(mld_umf_, mld_slu_,mld_ilu_n_, mld_ilu_t_,mld_milu_n_) - call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info) - call onelev_set_solver(p%precv(nlev_),val,info) - call p%precv(nlev_)%set('COARSE_MAT',mld_repl_mat_,info) - case(mld_sludist_) - call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info) - call onelev_set_solver(p%precv(nlev_),val,info) - call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info) - case(mld_mumps_) - call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info) - call onelev_set_solver(p%precv(nlev_),val,info) - call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info) + call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos) + call p%precv(nlev_)%set('SUB_SOLVE',val,info,pos=pos) + call p%precv(nlev_)%set('COARSE_MAT',mld_repl_mat_,info,pos=pos) + case(mld_sludist_,mld_mumps_) + call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos) + call p%precv(nlev_)%set('SUB_SOLVE',val,info,pos=pos) + call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos) case(mld_jac_) - call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info) - call onelev_set_solver(p%precv(nlev_),mld_diag_scale_,info) - call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info) + call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos) + call p%precv(nlev_)%set('SUB_SOLVE',mld_diag_scale_,info,pos=pos) + call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos) end select - endif case('COARSE_SUBSOLVE') if (nlev_ > 1) then - call onelev_set_solver(p%precv(nlev_),val,info) + call p%precv(nlev_)%set('SUB_SOLVE',val,info,pos=pos) endif case('COARSE_SWEEPS') if (nlev_ > 1) then - call p%precv(nlev_)%set('SMOOTHER_SWEEPS',val,info) + call p%precv(nlev_)%set('SMOOTHER_SWEEPS',val,info,pos=pos) end if case('COARSE_FILLIN') if (nlev_ > 1) then - call p%precv(nlev_)%set('SUB_FILLIN',val,info) + call p%precv(nlev_)%set('SUB_FILLIN',val,info,pos=pos) end if + case default do ilev_=1,nlev_ - call p%precv(ilev_)%set(what,val,info) + call p%precv(ilev_)%set(what,val,info,pos=pos) end do end select endif -contains - - subroutine onelev_set_smoother(level,val,info) - type(mld_c_onelev_type), intent(inout) :: level - integer(psb_ipk_), intent(in) :: val - integer(psb_ipk_), intent(out) :: info - info = psb_success_ - - ! - ! This here requires a bit more attention. - ! - select case (val) - case (mld_noprec_) - if (allocated(level%sm)) then - select type (sm => level%sm) - type is (mld_c_base_smoother_type) - ! do nothing - class default - call level%sm%free(info) - if (info == 0) deallocate(level%sm) - if (info == 0) allocate(mld_c_base_smoother_type ::& - & level%sm, stat=info) - if (info == 0) allocate(mld_c_id_solver_type ::& - & level%sm%sv, stat=info) - end select - else - allocate(mld_c_base_smoother_type ::& - & level%sm, stat=info) - if (info ==0) allocate(mld_c_id_solver_type ::& - & level%sm%sv, stat=info) - endif - - case (mld_jac_) - if (allocated(level%sm)) then - select type (sm => level%sm) - class is (mld_c_jac_smoother_type) - ! do nothing - class default - call level%sm%free(info) - if (info == 0) deallocate(level%sm) - if (info == 0) allocate(mld_c_jac_smoother_type :: & - & level%sm, stat=info) - if (info == 0) allocate(mld_c_diag_solver_type :: & - & level%sm%sv, stat=info) - end select - else - allocate(mld_c_jac_smoother_type :: level%sm, stat=info) - if (info == 0) allocate(mld_c_diag_solver_type ::& - & level%sm%sv, stat=info) - endif - - case (mld_bjac_) - if (allocated(level%sm)) then - select type (sm => level%sm) - class is (mld_c_jac_smoother_type) - ! do nothing - class default - call level%sm%free(info) - if (info == 0) deallocate(level%sm) - if (info == 0) allocate(mld_c_jac_smoother_type ::& - & level%sm, stat=info) - if (info == 0) allocate(mld_c_ilu_solver_type ::& - & level%sm%sv, stat=info) - end select - else - allocate(mld_c_jac_smoother_type :: level%sm, stat=info) - if (info == 0) allocate(mld_c_ilu_solver_type ::& - & level%sm%sv, stat=info) - endif - - case (mld_as_) - if (allocated(level%sm)) then - select type (sm => level%sm) - class is (mld_c_as_smoother_type) - ! do nothing - class default - call level%sm%free(info) - if (info == 0) deallocate(level%sm) - if (info == 0) allocate(mld_c_as_smoother_type ::& - & level%sm, stat=info) - if (info == 0) allocate(mld_c_ilu_solver_type ::& - & level%sm%sv, stat=info) - end select - else - allocate(mld_c_as_smoother_type :: level%sm, stat=info) - if (info == 0) allocate(mld_c_ilu_solver_type ::& - & level%sm%sv, stat=info) - endif - - case default - ! - ! Do nothing and hope for the best :) - ! - end select - if (allocated(level%sm)) & - & call level%sm%default() - - end subroutine onelev_set_smoother - - subroutine onelev_set_solver(level,val,info) - type(mld_c_onelev_type), intent(inout) :: level - integer(psb_ipk_), intent(in) :: val - integer(psb_ipk_), intent(out) :: info - info = psb_success_ - - ! - ! This here requires a bit more attention. - ! - select case (val) - case (mld_f_none_) - if (allocated(level%sm)) then - if (allocated(level%sm%sv)) then - select type (sv => level%sm%sv) - class is (mld_c_id_solver_type) - ! do nothing - class default - call level%sm%sv%free(info) - if (info == 0) deallocate(level%sm%sv) - if (info == 0) allocate(mld_c_id_solver_type ::& - & level%sm%sv, stat=info) - end select - else - allocate(mld_c_id_solver_type :: level%sm%sv, stat=info) - endif - if (allocated(level%sm)) then - if (allocated(level%sm%sv)) & - & call level%sm%sv%default() - end if - else - write(0,*) 'Calling set_solver without a smoother?' - info = -5 - end if - - case (mld_diag_scale_) - if (allocated(level%sm)) then - if (allocated(level%sm%sv)) then - select type (sv => level%sm%sv) - class is (mld_c_diag_solver_type) - ! do nothing - class default - call level%sm%sv%free(info) - if (info == 0) deallocate(level%sm%sv) - if (info == 0) allocate(mld_c_diag_solver_type ::& - & level%sm%sv, stat=info) - end select - else - allocate(mld_c_diag_solver_type :: level%sm%sv, stat=info) - endif - if (allocated(level%sm)) then - if (allocated(level%sm%sv)) & - & call level%sm%sv%default() - end if - else - write(0,*) 'Calling set_solver without a smoother?' - info = -5 - end if - - case (mld_gs_) - if (allocated(level%sm)) then - if (allocated(level%sm%sv)) then - select type (sv => level%sm%sv) - class is (mld_c_gs_solver_type) - ! do nothing - class default - call level%sm%sv%free(info) - if (info == 0) deallocate(level%sm%sv) - if (info == 0) allocate(mld_c_gs_solver_type ::& - & level%sm%sv, stat=info) - end select - else - allocate(mld_c_gs_solver_type :: level%sm%sv, stat=info) - endif - if (allocated(level%sm%sv)) then - call level%sm%sv%default() - else - endif - - else - write(0,*) 'Calling set_solver without a smoother?' - info = -5 - end if - - case (mld_ilu_n_,mld_milu_n_,mld_ilu_t_) - if (allocated(level%sm)) then - if (allocated(level%sm%sv)) then - select type (sv => level%sm%sv) - class is (mld_c_ilu_solver_type) - ! do nothing - class default - call level%sm%sv%free(info) - if (info == 0) deallocate(level%sm%sv) - if (info == 0) allocate(mld_c_ilu_solver_type ::& - & level%sm%sv, stat=info) - end select - else - allocate(mld_c_ilu_solver_type :: level%sm%sv, stat=info) - endif - if (allocated(level%sm)) then - if (allocated(level%sm%sv)) & - & call level%sm%sv%default() - end if - call level%sm%sv%set('SUB_SOLVE',val,info) - else - write(0,*) 'Calling set_solver without a smoother?' - info = -5 - end if - -#ifdef HAVE_SLU_ - case (mld_slu_) - if (allocated(level%sm)) then - if (allocated(level%sm%sv)) then - select type (sv => level%sm%sv) - class is (mld_c_slu_solver_type) - ! do nothing - class default - call level%sm%sv%free(info) - if (info == 0) deallocate(level%sm%sv) - if (info == 0) allocate(mld_c_slu_solver_type ::& - & level%sm%sv, stat=info) - end select - else - allocate(mld_c_slu_solver_type :: level%sm%sv, stat=info) - endif - if (allocated(level%sm)) then - if (allocated(level%sm%sv)) & - & call level%sm%sv%default() - end if - else - write(0,*) 'Calling set_solver without a smoother?' - info = -5 - end if -#endif -#ifdef HAVE_MUMPS_ - case (mld_mumps_) - if (allocated(level%sm%sv)) then - select type (sv => level%sm%sv) - class is (mld_c_mumps_solver_type) - ! do nothing - class default - call level%sm%sv%free(info) - if (info == 0) deallocate(level%sm%sv) - if (info == 0) allocate(mld_c_mumps_solver_type ::& - & level%sm%sv, stat=info) - end select - else - allocate(mld_c_mumps_solver_type :: level%sm%sv, stat=info) - endif - if (allocated(level%sm)) then - if (allocated(level%sm%sv)) & - & call level%sm%sv%default() - end if -#endif - - case default - ! - ! Do nothing and hope for the best :) - ! - end select - - end subroutine onelev_set_solver - - end subroutine mld_ccprecseti ! @@ -657,7 +350,7 @@ end subroutine mld_ccprecseti ! For this reason, the interface mld_precset to this routine has been built in ! such a way that ilev is not visible to the user (see mld_prec_mod.f90). ! -subroutine mld_ccprecsetc(p,what,string,info,ilev) +subroutine mld_ccprecsetc(p,what,string,info,ilev,pos) use psb_base_mod use mld_c_prec_mod, mld_protect_name => mld_ccprecsetc @@ -670,6 +363,7 @@ subroutine mld_ccprecsetc(p,what,string,info,ilev) character(len=*), intent(in) :: string integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), optional, intent(in) :: ilev + character(len=*), optional, intent(in) :: pos ! Local variables integer(psb_ipk_) :: ilev_, nlev_,val @@ -698,9 +392,9 @@ subroutine mld_ccprecsetc(p,what,string,info,ilev) val = mld_stringval(string) if (val >=0) then - call p%set(what,val,info,ilev=ilev) + call p%set(what,val,info,ilev=ilev,pos=pos) else - call p%precv(ilev_)%set(what,string,info) + call p%precv(ilev_)%set(what,string,info,pos=pos) end if end subroutine mld_ccprecsetc @@ -744,7 +438,7 @@ end subroutine mld_ccprecsetc ! For this reason, the interface mld_precset to this routine has been built in ! such a way that ilev is not visible to the user (see mld_prec_mod.f90). ! -subroutine mld_ccprecsetr(p,what,val,info,ilev) +subroutine mld_ccprecsetr(p,what,val,info,ilev,pos) use psb_base_mod use mld_c_prec_mod, mld_protect_name => mld_ccprecsetr @@ -757,6 +451,7 @@ subroutine mld_ccprecsetr(p,what,val,info,ilev) real(psb_spk_), intent(in) :: val integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), optional, intent(in) :: ilev + character(len=*), optional, intent(in) :: pos ! Local variables integer(psb_ipk_) :: ilev_,nlev_ @@ -793,7 +488,7 @@ subroutine mld_ccprecsetr(p,what,val,info,ilev) ! if (present(ilev)) then - call p%precv(ilev_)%set(what,val,info) + call p%precv(ilev_)%set(what,val,info,pos=pos) else if (.not.present(ilev)) then ! @@ -803,19 +498,19 @@ subroutine mld_ccprecsetr(p,what,val,info,ilev) select case(psb_toupper(what)) case('COARSE_ILUTHRS') ilev_=nlev_ - call p%precv(ilev_)%set('SUB_ILUTHRS',val,info) + call p%precv(ilev_)%set('SUB_ILUTHRS',val,info,pos=pos) case('AGGR_THRESH') thr = val do ilev_ = 2, nlev_ - call p%precv(ilev_)%set('AGGR_THRESH',thr,info) + call p%precv(ilev_)%set('AGGR_THRESH',thr,info,pos=pos) thr = thr * p%precv(ilev_)%parms%aggr_scale end do case default do ilev_=1,nlev_ - call p%precv(ilev_)%set(what,val,info) + call p%precv(ilev_)%set(what,val,info,pos=pos) end do end select diff --git a/mlprec/impl/mld_cmlprec_aply.f90 b/mlprec/impl/mld_cmlprec_aply.f90 index b421b093..4354f189 100644 --- a/mlprec/impl/mld_cmlprec_aply.f90 +++ b/mlprec/impl/mld_cmlprec_aply.f90 @@ -405,10 +405,10 @@ contains implicit none ! Arguments - integer(psb_ipk_) :: level - type(mld_cprec_type), intent(inout) :: p - type(mld_mlprec_wrk_type), intent(inout) :: mlprec_wrk(:) - character, intent(in) :: trans + integer(psb_ipk_) :: level + type(mld_cprec_type), target, intent(inout) :: p + type(mld_mlprec_wrk_type), intent(inout) :: mlprec_wrk(:) + character, intent(in) :: trans complex(psb_spk_),target :: work(:) integer(psb_ipk_), intent(out) :: info @@ -434,7 +434,6 @@ contains ictxt = p%precv(level)%base_desc%get_context() call psb_info(ictxt, me, np) - if (level > 1) then nc2l = p%precv(level)%base_desc%get_local_cols() nr2l = p%precv(level)%base_desc%get_local_rows() @@ -539,7 +538,6 @@ contains end if ! This is one step of post-smoothing - if (level < nlev) then call inner_ml_aply(level+1,p,mlprec_wrk,trans,work,info) if (info /= psb_success_) then @@ -572,7 +570,7 @@ contains end if sweeps = p%precv(level)%parms%sweeps_post - call p%precv(level)%sm%apply(cone,& + call p%precv(level)%sm2%apply(cone,& & mlprec_wrk(level)%x2l,cone,mlprec_wrk(level)%y2l,& & p%precv(level)%base_desc, trans,& & sweeps,work,info) @@ -621,13 +619,17 @@ contains ! if (level < nlev) then sweeps = p%precv(level)%parms%sweeps_post + call p%precv(level)%sm2%apply(cone,& + & mlprec_wrk(level)%x2l,czero,mlprec_wrk(level)%y2l,& + & p%precv(level)%base_desc, trans,& + & sweeps,work,info) else sweeps = p%precv(level)%parms%sweeps + call p%precv(level)%sm%apply(cone,& + & mlprec_wrk(level)%x2l,czero,mlprec_wrk(level)%y2l,& + & p%precv(level)%base_desc, trans,& + & sweeps,work,info) end if - call p%precv(level)%sm%apply(cone,& - & mlprec_wrk(level)%x2l,czero,mlprec_wrk(level)%y2l,& - & p%precv(level)%base_desc, trans,& - & sweeps,work,info) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& @@ -830,6 +832,13 @@ contains case(mld_twoside_smooth_) + ! CHECK + if (.not.(associated(p%precv(level)%sm2,p%precv(level)%sm2a))) then + write(0,*) 'inner_ml_aply: unassociated sm2 at level ',level + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Error during restriction') + goto 9999 + end if nc2l = p%precv(level)%base_desc%get_local_cols() nr2l = p%precv(level)%base_desc%get_local_rows() allocate(mlprec_wrk(level)%ty(nc2l), mlprec_wrk(level)%tx(nc2l), stat=info) @@ -866,10 +875,19 @@ contains else sweeps = p%precv(level)%parms%sweeps end if - if (info == psb_success_) call p%precv(level)%sm%apply(cone,& - & mlprec_wrk(level)%x2l,czero,mlprec_wrk(level)%y2l,& - & p%precv(level)%base_desc, trans,& - & sweeps,work,info) + + if (trans == 'N') then + if (info == psb_success_) call p%precv(level)%sm%apply(cone,& + & mlprec_wrk(level)%x2l,czero,mlprec_wrk(level)%y2l,& + & p%precv(level)%base_desc, trans,& + & sweeps,work,info) + else + if (info == psb_success_) call p%precv(level)%sm2%apply(cone,& + & mlprec_wrk(level)%x2l,czero,mlprec_wrk(level)%y2l,& + & p%precv(level)%base_desc, trans,& + & sweeps,work,info) + end if + if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& & a_err='Error during smoother_apply') @@ -930,10 +948,18 @@ contains else sweeps = p%precv(level)%parms%sweeps_pre end if - if (info == psb_success_) call p%precv(level)%sm%apply(cone,& - & mlprec_wrk(level)%tx,cone,mlprec_wrk(level)%y2l,& - & p%precv(level)%base_desc, trans,& - & sweeps,work,info) + if (trans == 'N') then + if (info == psb_success_) call p%precv(level)%sm2%apply(cone,& + & mlprec_wrk(level)%tx,cone,mlprec_wrk(level)%y2l,& + & p%precv(level)%base_desc, trans,& + & sweeps,work,info) + else + if (info == psb_success_) call p%precv(level)%sm%apply(cone,& + & mlprec_wrk(level)%tx,cone,mlprec_wrk(level)%y2l,& + & p%precv(level)%base_desc, trans,& + & sweeps,work,info) + end if + if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& & a_err='Error during smoother_apply') @@ -1043,7 +1069,7 @@ subroutine mld_cmlprec_aply_vect(alpha,p,x,beta,y,desc_data,trans,work,info) level = 1 call psb_geaxpby(cone,x,czero,mlprec_wrk(level)%vx2l,p%precv(level)%base_desc,info) - call mlprec_wrk(level)%vy2l%set(czero) + call mlprec_wrk(level)%vy2l%zero() call inner_ml_aply(level,p,mlprec_wrk,trans_,work,info) @@ -1090,12 +1116,12 @@ contains implicit none ! Arguments - integer(psb_ipk_) :: level - type(mld_cprec_type), intent(inout) :: p - type(mld_mlprec_wrk_type), intent(inout) :: mlprec_wrk(:) - character, intent(in) :: trans - complex(psb_spk_),target :: work(:) - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: level + type(mld_cprec_type), target, intent(inout) :: p + type(mld_mlprec_wrk_type), intent(inout) :: mlprec_wrk(:) + character, intent(in) :: trans + complex(psb_spk_),target :: work(:) + integer(psb_ipk_), intent(out) :: info ! Local variables integer(psb_ipk_) :: ictxt,np,me @@ -1122,7 +1148,9 @@ contains nc2l = p%precv(level)%base_desc%get_local_cols() nr2l = p%precv(level)%base_desc%get_local_rows() - + if(debug_level > 1) then + write(debug_unit,*) me,' inner_ml_aply at level ',level + end if select case(p%precv(level)%parms%ml_type) @@ -1160,7 +1188,7 @@ contains & sweeps,work,info) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during smoother_apply') + & a_err='Error during ADD smoother_apply') goto 9999 end if @@ -1250,25 +1278,25 @@ contains sweeps = p%precv(level)%parms%sweeps_post - call p%precv(level)%sm%apply(cone,& + call p%precv(level)%sm2%apply(cone,& & mlprec_wrk(level)%vx2l,cone,mlprec_wrk(level)%vy2l,& & p%precv(level)%base_desc, trans,& & sweeps,work,info) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during smoother_apply') + & a_err='Error during POST smoother_apply') goto 9999 end if else sweeps = p%precv(level)%parms%sweeps - call p%precv(level)%sm%apply(cone,& + call p%precv(level)%sm2%apply(cone,& & mlprec_wrk(level)%vx2l,czero,mlprec_wrk(level)%vy2l,& & p%precv(level)%base_desc, trans,& & sweeps,work,info) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during smoother_apply') + & a_err='Error during POST smoother_apply') goto 9999 end if @@ -1302,13 +1330,13 @@ contains else sweeps = p%precv(level)%parms%sweeps end if - call p%precv(level)%sm%apply(cone,& + call p%precv(level)%sm2%apply(cone,& & mlprec_wrk(level)%vx2l,czero,mlprec_wrk(level)%vy2l,& & p%precv(level)%base_desc, trans,& & sweeps,work,info) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during smoother_apply') + & a_err='Error during POST smoother_apply') goto 9999 end if @@ -1386,7 +1414,7 @@ contains & sweeps,work,info) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during smoother_apply') + & a_err='Error during PRE smoother_apply') goto 9999 end if @@ -1484,7 +1512,7 @@ contains & sweeps,work,info) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during smoother_apply') + & a_err='Error during PRE smoother_apply') goto 9999 end if else @@ -1530,19 +1558,28 @@ contains if (level < nlev) then if (trans == 'N') then sweeps = p%precv(level)%parms%sweeps_pre + if (info == psb_success_) call p%precv(level)%sm%apply(cone,& + & mlprec_wrk(level)%vx2l,czero,mlprec_wrk(level)%vy2l,& + & p%precv(level)%base_desc, trans,& + & sweeps,work,info) else sweeps = p%precv(level)%parms%sweeps_post + if (info == psb_success_) call p%precv(level)%sm2%apply(cone,& + & mlprec_wrk(level)%vx2l,czero,mlprec_wrk(level)%vy2l,& + & p%precv(level)%base_desc, trans,& + & sweeps,work,info) end if else sweeps = p%precv(level)%parms%sweeps + if (info == psb_success_) call p%precv(level)%sm%apply(cone,& + & mlprec_wrk(level)%vx2l,czero,mlprec_wrk(level)%vy2l,& + & p%precv(level)%base_desc, trans,& + & sweeps,work,info) end if - if (info == psb_success_) call p%precv(level)%sm%apply(cone,& - & mlprec_wrk(level)%vx2l,czero,mlprec_wrk(level)%vy2l,& - & p%precv(level)%base_desc, trans,& - & sweeps,work,info) + if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during smoother_apply') + & a_err='Error during 2-PRE smoother_apply') goto 9999 end if @@ -1602,16 +1639,21 @@ contains ! if (trans == 'N') then sweeps = p%precv(level)%parms%sweeps_post + if (info == psb_success_) call p%precv(level)%sm2%apply(cone,& + & mlprec_wrk(level)%vtx,cone,mlprec_wrk(level)%vy2l,& + & p%precv(level)%base_desc, trans,& + & sweeps,work,info) else sweeps = p%precv(level)%parms%sweeps_pre + if (info == psb_success_) call p%precv(level)%sm%apply(cone,& + & mlprec_wrk(level)%vtx,cone,mlprec_wrk(level)%vy2l,& + & p%precv(level)%base_desc, trans,& + & sweeps,work,info) end if - if (info == psb_success_) call p%precv(level)%sm%apply(cone,& - & mlprec_wrk(level)%vtx,cone,mlprec_wrk(level)%vy2l,& - & p%precv(level)%base_desc, trans,& - & sweeps,work,info) + if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during smoother_apply') + & a_err='Error during 2-POST smoother_apply') goto 9999 end if diff --git a/mlprec/impl/mld_cmlprec_bld.f90 b/mlprec/impl/mld_cmlprec_bld.f90 index a0f261b3..7acf5af1 100644 --- a/mlprec/impl/mld_cmlprec_bld.f90 +++ b/mlprec/impl/mld_cmlprec_bld.f90 @@ -495,10 +495,16 @@ subroutine mld_cmlprec_bld(a,desc_a,p,info,amold,vmold,imold) call p%precv(i)%sm%build(p%precv(i)%base_a,p%precv(i)%base_desc,& & 'F',info,amold=amold,vmold=vmold,imold=imold) - - if ((info == psb_success_).and.(i>1)) then - call p%precv(i)%cnv(info,amold=amold,vmold=vmold,imold=imold) + if (info == 0) then + if (allocated(p%precv(i)%sm2a)) then + call p%precv(i)%sm2a%build(a,desc_a,upd_,info,& + & amold=amold,vmold=vmold,imold=imold) + p%precv(i)%sm2 => p%precv(i)%sm2a + else + p%precv(i)%sm2 => p%precv(i)%sm + end if end if + if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& & a_err='One level preconditioner build.') diff --git a/mlprec/impl/mld_cprecset.F90 b/mlprec/impl/mld_cprecset.F90 index 6728ca12..4b12a7e1 100644 --- a/mlprec/impl/mld_cprecset.F90 +++ b/mlprec/impl/mld_cprecset.F90 @@ -76,7 +76,7 @@ ! For this reason, the interface mld_precset to this routine has been built in ! such a way that ilev is not visible to the user (see mld_prec_mod.f90). ! -subroutine mld_cprecseti(p,what,val,info,ilev) +subroutine mld_cprecseti(p,what,val,info,ilev,pos) use psb_base_mod use mld_c_prec_mod, mld_protect_name => mld_cprecseti @@ -101,6 +101,7 @@ subroutine mld_cprecseti(p,what,val,info,ilev) integer(psb_ipk_), intent(in) :: val integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), optional, intent(in) :: ilev + character(len=*), optional, intent(in) :: pos ! Local variables integer(psb_ipk_) :: ilev_, nlev_ @@ -141,39 +142,21 @@ subroutine mld_cprecseti(p,what,val,info,ilev) if (present(ilev)) then if (ilev_ == 1) then - ! - ! Rules for fine level are slightly different. - ! - select case(what) - case(mld_smoother_type_) - call onelev_set_smoother(p%precv(ilev_),val,info) - case(mld_sub_solve_) - call onelev_set_solver(p%precv(ilev_),val,info) - case(mld_smoother_sweeps_,mld_ml_type_,mld_aggr_alg_,mld_aggr_ord_,& - & mld_aggr_kind_,mld_smoother_pos_,mld_aggr_omega_alg_,mld_aggr_eig_,& - & mld_smoother_sweeps_pre_,mld_smoother_sweeps_post_,& - & mld_sub_restr_,mld_sub_prol_, & - & mld_sub_ren_,mld_sub_ovr_,mld_sub_fillin_) - call p%precv(ilev_)%set(what,val,info) - case default - call p%precv(ilev_)%set(what,val,info) - end select + call p%precv(ilev_)%set(what,val,info,pos=pos) else if (ilev_ > 1) then select case(what) - case(mld_smoother_type_) - call onelev_set_smoother(p%precv(ilev_),val,info) - case(mld_sub_solve_) - call onelev_set_solver(p%precv(ilev_),val,info) - case(mld_smoother_sweeps_,mld_ml_type_,mld_aggr_alg_,mld_aggr_ord_,& - & mld_aggr_kind_,mld_smoother_pos_,mld_aggr_omega_alg_,mld_aggr_eig_,& + case(mld_smoother_type_,mld_sub_solve_,mld_smoother_sweeps_,& + & mld_ml_type_,mld_aggr_alg_,mld_aggr_ord_,& + & mld_aggr_kind_,mld_smoother_pos_,& + & mld_aggr_omega_alg_,mld_aggr_eig_,& & mld_smoother_sweeps_pre_,mld_smoother_sweeps_post_,& & mld_sub_restr_,mld_sub_prol_, & & mld_sub_ren_,mld_sub_ovr_,mld_sub_fillin_,& & mld_coarse_mat_) - call p%precv(ilev_)%set(what,val,info) + call p%precv(ilev_)%set(what,val,info,pos=pos) case(mld_coarse_subsolve_) if (ilev_ /= nlev_) then @@ -182,7 +165,7 @@ subroutine mld_cprecseti(p,what,val,info,ilev) info = -2 return end if - call onelev_set_solver(p%precv(ilev_),val,info) + call p%precv(ilev_)%set(mld_sub_solve_,val,info,pos=pos) case(mld_coarse_solve_) if (ilev_ /= nlev_) then write(psb_err_unit,*) name,& @@ -192,30 +175,30 @@ subroutine mld_cprecseti(p,what,val,info,ilev) end if if (nlev_ > 1) then - call p%precv(nlev_)%set(mld_coarse_solve_,val,info) + call p%precv(nlev_)%set(mld_coarse_solve_,val,info,pos=pos) select case (val) case(mld_bjac_) - call onelev_set_smoother(p%precv(nlev_),val,info) -#if defined(HAVE_SLU_) - call onelev_set_solver(p%precv(nlev_),mld_slu_,info) + call p%precv(nlev_)%set(mld_smoother_type_,val,info,pos=pos) +#if defined(HAVE_SLU_) + call p%precv(nlev_)%set(mld_sub_solve_,mld_slu_,info,pos=pos) #elif defined(HAVE_MUMPS_) - call onelev_set_solver(p%precv(nlev_),mld_mumps_,info) + call p%precv(nlev_)%set(mld_sub_solve_,mld_mumps_,info,pos=pos) #else - call onelev_set_solver(p%precv(nlev_),mld_ilu_n_,info) + call p%precv(nlev_)%set(mld_sub_solve_,mld_ilu_n_,info,pos=pos) #endif - call p%precv(nlev_)%set(mld_coarse_mat_,mld_distr_mat_,info) + call p%precv(nlev_)%set(mld_coarse_mat_,mld_distr_mat_,info,pos=pos) case(mld_umf_, mld_slu_,mld_ilu_n_, mld_ilu_t_,mld_milu_n_) - call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info) - call onelev_set_solver(p%precv(nlev_),val,info) - call p%precv(nlev_)%set(mld_coarse_mat_,mld_repl_mat_,info) + call p%precv(nlev_)%set(mld_smoother_type_,mld_bjac_,info,pos=pos) + call p%precv(nlev_)%set(mld_sub_solve_,val,info,pos=pos) + call p%precv(nlev_)%set(mld_coarse_mat_,mld_repl_mat_,info,pos=pos) case(mld_sludist_,mld_mumps_) - call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info) - call onelev_set_solver(p%precv(nlev_),val,info) - call p%precv(nlev_)%set(mld_coarse_mat_,mld_distr_mat_,info) + call p%precv(nlev_)%set(mld_smoother_type_,mld_bjac_,info,pos=pos) + call p%precv(nlev_)%set(mld_sub_solve_,val,info,pos=pos) + call p%precv(nlev_)%set(mld_coarse_mat_,mld_distr_mat_,info,pos=pos) case(mld_jac_) - call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info) - call onelev_set_solver(p%precv(nlev_),mld_diag_scale_,info) - call p%precv(nlev_)%set(mld_coarse_mat_,mld_distr_mat_,info) + call p%precv(nlev_)%set(mld_smoother_type_,mld_bjac_,info,pos=pos) + call p%precv(nlev_)%set(mld_sub_solve_,mld_diag_scale_,info,pos=pos) + call p%precv(nlev_)%set(mld_coarse_mat_,mld_distr_mat_,info,pos=pos) end select endif @@ -226,7 +209,7 @@ subroutine mld_cprecseti(p,what,val,info,ilev) info = -2 return end if - call p%precv(nlev_)%set(mld_smoother_sweeps_,val,info) + call p%precv(nlev_)%set(mld_smoother_sweeps_,val,info,pos=pos) case(mld_coarse_fillin_) if (ilev_ /= nlev_) then @@ -235,9 +218,9 @@ subroutine mld_cprecseti(p,what,val,info,ilev) info = -2 return end if - call p%precv(nlev_)%set(mld_sub_fillin_,val,info) + call p%precv(nlev_)%set(mld_sub_fillin_,val,info,pos=pos) case default - call p%precv(ilev_)%set(what,val,info) + call p%precv(ilev_)%set(what,val,info,pos=pos) end select endif @@ -248,33 +231,12 @@ subroutine mld_cprecseti(p,what,val,info,ilev) ! levels ! select case(what) - case(mld_sub_solve_) + case(mld_sub_solve_,mld_sub_restr_,mld_sub_prol_,& + & mld_sub_ren_,mld_sub_ovr_,mld_sub_fillin_,& + & mld_smoother_sweeps_,mld_smoother_type_) do ilev_=1,max(1,nlev_-1) - if (.not.allocated(p%precv(ilev_)%sm)) then - write(psb_err_unit,*) name,& - & ': Error: uninitialized preconditioner component,',& - & ' should call MLD_PRECINIT' - info = -1 - return - endif - call onelev_set_solver(p%precv(ilev_),val,info) - - end do - - case(mld_sub_restr_,mld_sub_prol_,& - & mld_sub_ren_,mld_sub_ovr_,mld_sub_fillin_) - do ilev_=1,max(1,nlev_-1) - call p%precv(ilev_)%set(what,val,info) - end do - - case(mld_smoother_sweeps_) - do ilev_=1,max(1,nlev_-1) - call p%precv(ilev_)%set(what,val,info) - end do - - case(mld_smoother_type_) - do ilev_=1,max(1,nlev_-1) - call onelev_set_smoother(p%precv(ilev_),val,info) + call p%precv(ilev_)%set(what,val,info,pos=pos) + if (info /= 0) return end do case(mld_ml_type_,mld_aggr_alg_,mld_aggr_ord_,mld_aggr_kind_,& @@ -282,336 +244,73 @@ subroutine mld_cprecseti(p,what,val,info,ilev) & mld_smoother_pos_,mld_aggr_omega_alg_,& & mld_aggr_eig_,mld_aggr_filter_) do ilev_=1,nlev_ - call p%precv(ilev_)%set(what,val,info) + call p%precv(ilev_)%set(what,val,info,pos=pos) end do case(mld_coarse_mat_) if (nlev_ > 1) then - call p%precv(nlev_)%set(mld_coarse_mat_,val,info) + call p%precv(nlev_)%set(mld_coarse_mat_,val,info,pos=pos) end if case(mld_coarse_solve_) if (nlev_ > 1) then - call p%precv(nlev_)%set(mld_coarse_solve_,val,info) + call p%precv(nlev_)%set(mld_coarse_solve_,val,info,pos=pos) select case (val) case(mld_bjac_) - call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info) -#if defined(HAVE_SLU_) - call onelev_set_solver(p%precv(nlev_),mld_slu_,info) -#elif defined(HAVE_SLU_) - call onelev_set_solver(p%precv(nlev_),mld_slu_,info) + call p%precv(nlev_)%set(mld_smoother_type_,mld_bjac_,info,pos=pos) +#if defined(HAVE_SLU_) + call p%precv(nlev_)%set(mld_sub_solve_,mld_slu_,info,pos=pos) #else - call onelev_set_solver(p%precv(nlev_),mld_ilu_n_,info) + call p%precv(nlev_)%set(mld_sub_solve_,mld_ilu_n_,info,pos=pos) #endif - call p%precv(nlev_)%set(mld_coarse_mat_,mld_distr_mat_,info) + call p%precv(nlev_)%set(mld_coarse_mat_,mld_distr_mat_,info,pos=pos) case(mld_umf_, mld_slu_,mld_ilu_n_, mld_ilu_t_,mld_milu_n_) - call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info) - call onelev_set_solver(p%precv(nlev_),val,info) - call p%precv(nlev_)%set(mld_coarse_mat_,mld_repl_mat_,info) + call p%precv(nlev_)%set(mld_smoother_type_,mld_bjac_,info,pos=pos) + call p%precv(nlev_)%set(mld_sub_solve_,val,info,pos=pos) + call p%precv(nlev_)%set(mld_coarse_mat_,mld_repl_mat_,info,pos=pos) case(mld_sludist_) - call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info) - call onelev_set_solver(p%precv(nlev_),val,info) - call p%precv(nlev_)%set(mld_coarse_mat_,mld_distr_mat_,info) + call p%precv(nlev_)%set(mld_smoother_type_,mld_bjac_,info,pos=pos) + call p%precv(nlev_)%set(mld_sub_solve_,val,info,pos=pos) + call p%precv(nlev_)%set(mld_coarse_mat_,mld_distr_mat_,info,pos=pos) case(mld_mumps_) - call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info) - call onelev_set_solver(p%precv(nlev_),val,info) - call p%precv(nlev_)%set(mld_coarse_mat_,mld_distr_mat_,info) + call p%precv(nlev_)%set(mld_smoother_type_,mld_bjac_,info,pos=pos) + call p%precv(nlev_)%set(mld_sub_solve_,val,info,pos=pos) + call p%precv(nlev_)%set(mld_coarse_mat_,mld_distr_mat_,info,pos=pos) case(mld_jac_) - call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info) - call onelev_set_solver(p%precv(nlev_),mld_diag_scale_,info) - call p%precv(nlev_)%set(mld_coarse_mat_,mld_distr_mat_,info) + call p%precv(nlev_)%set(mld_smoother_type_,mld_bjac_,info,pos=pos) + call p%precv(nlev_)%set(mld_sub_solve_,mld_diag_scale_,info,pos=pos) + call p%precv(nlev_)%set(mld_coarse_mat_,mld_distr_mat_,info,pos=pos) end select endif case(mld_coarse_subsolve_) if (nlev_ > 1) then - call onelev_set_solver(p%precv(nlev_),val,info) + call p%precv(nlev_)%set(mld_sub_solve_,val,info,pos=pos) endif case(mld_coarse_sweeps_) if (nlev_ > 1) then - call p%precv(nlev_)%set(mld_smoother_sweeps_,val,info) + call p%precv(nlev_)%set(mld_smoother_sweeps_,val,info,pos=pos) end if case(mld_coarse_fillin_) if (nlev_ > 1) then - call p%precv(nlev_)%set(mld_sub_fillin_,val,info) + call p%precv(nlev_)%set(mld_sub_fillin_,val,info,pos=pos) end if case default do ilev_=1,nlev_ - call p%precv(ilev_)%set(what,val,info) + call p%precv(ilev_)%set(what,val,info,pos=pos) end do end select endif -contains - - subroutine onelev_set_smoother(level,val,info) - type(mld_c_onelev_type), intent(inout) :: level - integer(psb_ipk_), intent(in) :: val - integer(psb_ipk_), intent(out) :: info - info = psb_success_ - - ! - ! This here requires a bit more attention. - ! - select case (val) - case (mld_noprec_) - if (allocated(level%sm)) then - select type (sm => level%sm) - type is (mld_c_base_smoother_type) - ! do nothing - class default - call level%sm%free(info) - if (info == 0) deallocate(level%sm) - if (info == 0) allocate(mld_c_base_smoother_type ::& - & level%sm, stat=info) - if (info == 0) allocate(mld_c_id_solver_type ::& - & level%sm%sv, stat=info) - end select - else - allocate(mld_c_base_smoother_type ::& - & level%sm, stat=info) - if (info ==0) allocate(mld_c_id_solver_type ::& - & level%sm%sv, stat=info) - endif - - case (mld_jac_) - if (allocated(level%sm)) then - select type (sm => level%sm) - class is (mld_c_jac_smoother_type) - ! do nothing - class default - call level%sm%free(info) - if (info == 0) deallocate(level%sm) - if (info == 0) allocate(mld_c_jac_smoother_type :: & - & level%sm, stat=info) - if (info == 0) allocate(mld_c_diag_solver_type :: & - & level%sm%sv, stat=info) - end select - else - allocate(mld_c_jac_smoother_type :: level%sm, stat=info) - if (info == 0) allocate(mld_c_diag_solver_type ::& - & level%sm%sv, stat=info) - endif - - case (mld_bjac_) - if (allocated(level%sm)) then - select type (sm => level%sm) - class is (mld_c_jac_smoother_type) - ! do nothing - class default - call level%sm%free(info) - if (info == 0) deallocate(level%sm) - if (info == 0) allocate(mld_c_jac_smoother_type ::& - & level%sm, stat=info) - if (info == 0) allocate(mld_c_ilu_solver_type ::& - & level%sm%sv, stat=info) - end select - else - allocate(mld_c_jac_smoother_type :: level%sm, stat=info) - if (info == 0) allocate(mld_c_ilu_solver_type ::& - & level%sm%sv, stat=info) - endif - - case (mld_as_) - if (allocated(level%sm)) then - select type (sm => level%sm) - class is (mld_c_as_smoother_type) - ! do nothing - class default - call level%sm%free(info) - if (info == 0) deallocate(level%sm) - if (info == 0) allocate(mld_c_as_smoother_type ::& - & level%sm, stat=info) - if (info == 0) allocate(mld_c_ilu_solver_type ::& - & level%sm%sv, stat=info) - end select - else - allocate(mld_c_as_smoother_type :: level%sm, stat=info) - if (info == 0) allocate(mld_c_ilu_solver_type ::& - & level%sm%sv, stat=info) - endif - - case default - ! - ! Do nothing and hope for the best :) - ! - end select - if (allocated(level%sm)) & - & call level%sm%default() - - end subroutine onelev_set_smoother - - subroutine onelev_set_solver(level,val,info) - type(mld_c_onelev_type), intent(inout) :: level - integer(psb_ipk_), intent(in) :: val - integer(psb_ipk_), intent(out) :: info - info = psb_success_ - - ! - ! This here requires a bit more attention. - ! - select case (val) - case (mld_f_none_) - if (allocated(level%sm)) then - if (allocated(level%sm%sv)) then - select type (sv => level%sm%sv) - class is (mld_c_id_solver_type) - ! do nothing - class default - call level%sm%sv%free(info) - if (info == 0) deallocate(level%sm%sv) - if (info == 0) allocate(mld_c_id_solver_type ::& - & level%sm%sv, stat=info) - end select - else - allocate(mld_c_id_solver_type :: level%sm%sv, stat=info) - endif - if (allocated(level%sm)) then - if (allocated(level%sm%sv)) & - & call level%sm%sv%default() - end if - else - write(0,*) 'Calling set_solver without a smoother?' - info = -5 - end if - - - case (mld_diag_scale_) - if (allocated(level%sm)) then - if (allocated(level%sm%sv)) then - select type (sv => level%sm%sv) - class is (mld_c_diag_solver_type) - ! do nothing - class default - call level%sm%sv%free(info) - if (info == 0) deallocate(level%sm%sv) - if (info == 0) allocate(mld_c_diag_solver_type ::& - & level%sm%sv, stat=info) - end select - else - allocate(mld_c_diag_solver_type :: level%sm%sv, stat=info) - endif - if (allocated(level%sm)) then - if (allocated(level%sm%sv)) & - & call level%sm%sv%default() - end if - else - write(0,*) 'Calling set_solver without a smoother?' - info = -5 - end if - - case (mld_gs_) - if (allocated(level%sm)) then - if (allocated(level%sm%sv)) then - select type (sv => level%sm%sv) - class is (mld_c_gs_solver_type) - ! do nothing - class default - call level%sm%sv%free(info) - if (info == 0) deallocate(level%sm%sv) - if (info == 0) allocate(mld_c_gs_solver_type ::& - & level%sm%sv, stat=info) - end select - else - allocate(mld_c_gs_solver_type :: level%sm%sv, stat=info) - endif - if (allocated(level%sm%sv)) then - call level%sm%sv%default() - end if - - else - write(0,*) 'Calling set_solver without a smoother?' - info = -5 - end if - - case (mld_ilu_n_,mld_milu_n_,mld_ilu_t_) - if (allocated(level%sm)) then - if (allocated(level%sm%sv)) then - select type (sv => level%sm%sv) - class is (mld_c_ilu_solver_type) - ! do nothing - class default - call level%sm%sv%free(info) - if (info == 0) deallocate(level%sm%sv) - if (info == 0) allocate(mld_c_ilu_solver_type ::& - & level%sm%sv, stat=info) - end select - else - allocate(mld_c_ilu_solver_type :: level%sm%sv, stat=info) - endif - if (allocated(level%sm)) then - if (allocated(level%sm%sv)) & - & call level%sm%sv%default() - end if - call level%sm%sv%set(mld_sub_solve_,val,info) - else - write(0,*) 'Calling set_solver without a smoother?' - info = -5 - end if -#ifdef HAVE_SLU_ - case (mld_slu_) - if (allocated(level%sm)) then - if (allocated(level%sm%sv)) then - select type (sv => level%sm%sv) - class is (mld_c_slu_solver_type) - ! do nothing - class default - call level%sm%sv%free(info) - if (info == 0) deallocate(level%sm%sv) - if (info == 0) allocate(mld_c_slu_solver_type ::& - & level%sm%sv, stat=info) - end select - else - allocate(mld_c_slu_solver_type :: level%sm%sv, stat=info) - endif - if (allocated(level%sm)) then - if (allocated(level%sm%sv)) & - & call level%sm%sv%default() - end if - else - write(0,*) 'Calling set_solver without a smoother?' - info = -5 - end if -#endif -#ifdef HAVE_MUMPS_ - case (mld_mumps_) - if (allocated(level%sm%sv)) then - select type (sv => level%sm%sv) - class is (mld_c_mumps_solver_type) - ! do nothing - class default - call level%sm%sv%free(info) - if (info == 0) deallocate(level%sm%sv) - if (info == 0) allocate(mld_c_mumps_solver_type ::& - & level%sm%sv, stat=info) - end select - else - allocate(mld_c_mumps_solver_type :: level%sm%sv, stat=info) - endif - if (allocated(level%sm)) then - if (allocated(level%sm%sv)) then - call level%sm%sv%default() - end if - end if -#endif - case default - ! - ! Do nothing and hope for the best :) - ! - end select - - end subroutine onelev_set_solver - - end subroutine mld_cprecseti -subroutine mld_cprecsetsm(p,val,info,ilev) +subroutine mld_cprecsetsm(p,val,info,ilev,pos) use psb_base_mod use mld_c_prec_mod, mld_protect_name => mld_cprecsetsm @@ -623,6 +322,7 @@ subroutine mld_cprecsetsm(p,val,info,ilev) class(mld_c_base_smoother_type), intent(in) :: val integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), optional, intent(in) :: ilev + character(len=*), optional, intent(in) :: pos ! Local variables integer(psb_ipk_) :: ilev_, nlev_, ilmin, ilmax @@ -658,23 +358,13 @@ subroutine mld_cprecsetsm(p,val,info,ilev) do ilev_ = ilmin, ilmax - if (allocated(p%precv(ilev_)%sm)) then - if (allocated(p%precv(ilev_)%sm%sv)) then - deallocate(p%precv(ilev_)%sm%sv) - endif - deallocate(p%precv(ilev_)%sm) - end if -#ifdef HAVE_MOLD - allocate(p%precv(ilev_)%sm,mold=val) -#else - allocate(p%precv(ilev_)%sm,source=val) -#endif - call p%precv(ilev_)%sm%default() + call p%precv(ilev_)%set(val,info,pos=pos) + if (info /= 0) return end do end subroutine mld_cprecsetsm -subroutine mld_cprecsetsv(p,val,info,ilev) +subroutine mld_cprecsetsv(p,val,info,ilev,pos) use psb_base_mod use mld_c_prec_mod, mld_protect_name => mld_cprecsetsv @@ -686,6 +376,7 @@ subroutine mld_cprecsetsv(p,val,info,ilev) class(mld_c_base_solver_type), intent(in) :: val integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), optional, intent(in) :: ilev + character(len=*), optional, intent(in) :: pos ! Local variables integer(psb_ipk_) :: ilev_, nlev_, ilmin, ilmax @@ -720,43 +411,11 @@ subroutine mld_cprecsetsv(p,val,info,ilev) return endif - do ilev_ = ilmin, ilmax - if (allocated(p%precv(ilev_)%sm)) then - if (allocated(p%precv(ilev_)%sm%sv)) then - if (.not.same_type_as(p%precv(ilev_)%sm%sv,val)) then - deallocate(p%precv(ilev_)%sm%sv,stat=info) - if (info /= 0) then - info = 3111 - return - end if - end if - if (.not.allocated(p%precv(ilev_)%sm%sv)) then -#ifdef HAVE_MOLD - allocate(p%precv(ilev_)%sm%sv,mold=val,stat=info) -#else - allocate(p%precv(ilev_)%sm%sv,source=val,stat=info) -#endif - if (info /= 0) then - info = 3111 - return - end if - end if - end if - call p%precv(ilev_)%sm%sv%default() - else - info = 3111 - write(psb_err_unit,*) name,& - &': Error: uninitialized preconditioner component,',& - &' should call MLD_PRECINIT/MLD_PRECSET' - return - - end if - + call p%precv(ilev_)%set(val,info,pos=pos) + if (info /= 0) return end do - - end subroutine mld_cprecsetsv ! @@ -798,7 +457,7 @@ end subroutine mld_cprecsetsv ! For this reason, the interface mld_precset to this routine has been built in ! such a way that ilev is not visible to the user (see mld_prec_mod.f90). ! -subroutine mld_cprecsetc(p,what,string,info,ilev) +subroutine mld_cprecsetc(p,what,string,info,ilev,pos) use psb_base_mod use mld_c_prec_mod, mld_protect_name => mld_cprecsetc @@ -811,6 +470,7 @@ subroutine mld_cprecsetc(p,what,string,info,ilev) character(len=*), intent(in) :: string integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), optional, intent(in) :: ilev + character(len=*), optional, intent(in) :: pos ! Local variables integer(psb_ipk_) :: ilev_, nlev_,val @@ -838,7 +498,7 @@ subroutine mld_cprecsetc(p,what,string,info,ilev) endif val = mld_stringval(string) - if (val >=0) call p%set(what,val,info,ilev=ilev) + if (val >=0) call p%set(what,val,info,ilev=ilev,pos=pos) end subroutine mld_cprecsetc @@ -882,7 +542,7 @@ end subroutine mld_cprecsetc ! For this reason, the interface mld_precset to this routine has been built in ! such a way that ilev is not visible to the user (see mld_prec_mod.f90). ! -subroutine mld_cprecsetr(p,what,val,info,ilev) +subroutine mld_cprecsetr(p,what,val,info,ilev,pos) use psb_base_mod use mld_c_prec_mod, mld_protect_name => mld_cprecsetr @@ -895,6 +555,7 @@ subroutine mld_cprecsetr(p,what,val,info,ilev) real(psb_spk_), intent(in) :: val integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), optional, intent(in) :: ilev + character(len=*), optional, intent(in) :: pos ! Local variables integer(psb_ipk_) :: ilev_,nlev_ @@ -931,7 +592,7 @@ subroutine mld_cprecsetr(p,what,val,info,ilev) ! if (present(ilev)) then - call p%precv(ilev_)%set(what,val,info) + call p%precv(ilev_)%set(what,val,info,pos=pos) else if (.not.present(ilev)) then ! @@ -941,19 +602,19 @@ subroutine mld_cprecsetr(p,what,val,info,ilev) select case(what) case(mld_coarse_iluthrs_) ilev_=nlev_ - call p%precv(ilev_)%set(mld_sub_iluthrs_,val,info) + call p%precv(ilev_)%set(mld_sub_iluthrs_,val,info,pos=pos) case(mld_aggr_thresh_) thr = val do ilev_ = 2, nlev_ - call p%precv(ilev_)%set(mld_aggr_thresh_,thr,info) + call p%precv(ilev_)%set(mld_aggr_thresh_,thr,info,pos=pos) thr = thr * p%precv(ilev_)%parms%aggr_scale end do case default do ilev_=1,nlev_ - call p%precv(ilev_)%set(what,val,info) + call p%precv(ilev_)%set(what,val,info,pos=pos) end do end select diff --git a/mlprec/impl/mld_dcprecset.F90 b/mlprec/impl/mld_dcprecset.F90 index 191c655b..ab02ed09 100644 --- a/mlprec/impl/mld_dcprecset.F90 +++ b/mlprec/impl/mld_dcprecset.F90 @@ -137,6 +137,7 @@ subroutine mld_dcprecseti(p,what,val,info,ilev,pos) &': Error: invalid ILEV/NLEV combination',ilev_, nlev_ return endif + if (psb_toupper(what) == 'COARSE_AGGR_SIZE') then p%coarse_aggr_size = max(val,-1) return @@ -195,7 +196,7 @@ subroutine mld_dcprecseti(p,what,val,info,ilev,pos) #else call p%precv(nlev_)%set('SUB_SOLVE',mld_ilu_n_,info,pos=pos) #endif - call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos) + call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info) case(mld_umf_, mld_slu_,mld_ilu_n_, mld_ilu_t_,mld_milu_n_) call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos) call p%precv(nlev_)%set('SUB_SOLVE',val,info,pos=pos) @@ -264,7 +265,6 @@ subroutine mld_dcprecseti(p,what,val,info,ilev,pos) end if case('COARSE_SOLVE') - if (nlev_ > 1) then call p%precv(nlev_)%set('COARSE_SOLVE',val,info,pos=pos) select case (val) @@ -279,7 +279,7 @@ subroutine mld_dcprecseti(p,what,val,info,ilev,pos) #else call p%precv(nlev_)%set('SUB_SOLVE',mld_ilu_n_,info,pos=pos) #endif - call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos) + call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info) case(mld_umf_, mld_slu_,mld_ilu_n_, mld_ilu_t_,mld_milu_n_) call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos) call p%precv(nlev_)%set('SUB_SOLVE',val,info,pos=pos) diff --git a/mlprec/impl/mld_dmlprec_aply.f90 b/mlprec/impl/mld_dmlprec_aply.f90 index dd2938d5..94f54e86 100644 --- a/mlprec/impl/mld_dmlprec_aply.f90 +++ b/mlprec/impl/mld_dmlprec_aply.f90 @@ -405,10 +405,10 @@ contains implicit none ! Arguments - integer(psb_ipk_) :: level + integer(psb_ipk_) :: level type(mld_dprec_type), target, intent(inout) :: p - type(mld_mlprec_wrk_type), intent(inout) :: mlprec_wrk(:) - character, intent(in) :: trans + type(mld_mlprec_wrk_type), intent(inout) :: mlprec_wrk(:) + character, intent(in) :: trans real(psb_dpk_),target :: work(:) integer(psb_ipk_), intent(out) :: info @@ -886,7 +886,7 @@ contains if (info == psb_success_) call p%precv(level)%sm2%apply(done,& & mlprec_wrk(level)%x2l,dzero,mlprec_wrk(level)%y2l,& & p%precv(level)%base_desc, trans,& - & sweeps,work,info) + & sweeps,work,info) end if if (info /= psb_success_) then @@ -1117,12 +1117,12 @@ contains implicit none ! Arguments - integer(psb_ipk_) :: level - type(mld_dprec_type), target, intent(inout) :: p - type(mld_mlprec_wrk_type), intent(inout) :: mlprec_wrk(:) - character, intent(in) :: trans - real(psb_dpk_),target :: work(:) - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: level + type(mld_dprec_type), target, intent(inout) :: p + type(mld_mlprec_wrk_type), intent(inout) :: mlprec_wrk(:) + character, intent(in) :: trans + real(psb_dpk_),target :: work(:) + integer(psb_ipk_), intent(out) :: info ! Local variables integer(psb_ipk_) :: ictxt,np,me @@ -1189,7 +1189,7 @@ contains & sweeps,work,info) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during smoother_apply') + & a_err='Error during ADD smoother_apply') goto 9999 end if @@ -1264,7 +1264,7 @@ contains & a_err='Error during prolongation') goto 9999 end if - + ! ! Compute the residual ! @@ -1285,10 +1285,10 @@ contains & sweeps,work,info) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during smoother_apply') + & a_err='Error during POST smoother_apply') goto 9999 end if - + else sweeps = p%precv(level)%parms%sweeps call p%precv(level)%sm2%apply(done,& @@ -1297,10 +1297,10 @@ contains & sweeps,work,info) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during smoother_apply') + & a_err='Error during POST smoother_apply') goto 9999 end if - + end if case('T','C') @@ -1337,7 +1337,7 @@ contains & sweeps,work,info) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during smoother_apply') + & a_err='Error during POST smoother_apply') goto 9999 end if @@ -1361,7 +1361,7 @@ contains & a_err='Error in recursive call') goto 9999 end if - + call psb_map_Y2X(done,mlprec_wrk(level+1)%vy2l,& & done,mlprec_wrk(level)%vy2l,& @@ -1415,7 +1415,7 @@ contains & sweeps,work,info) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during smoother_apply') + & a_err='Error during PRE smoother_apply') goto 9999 end if @@ -1439,7 +1439,7 @@ contains & a_err='Error in recursive call') goto 9999 end if - + call psb_map_Y2X(done,mlprec_wrk(level+1)%vy2l,& & done,mlprec_wrk(level)%vy2l,& @@ -1480,7 +1480,7 @@ contains & a_err='Error in recursive call') goto 9999 end if - + ! ! Apply the prolongator ! @@ -1492,7 +1492,7 @@ contains & a_err='Error during prolongation') goto 9999 end if - + ! ! Compute the residual ! @@ -1513,7 +1513,7 @@ contains & sweeps,work,info) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during smoother_apply') + & a_err='Error during PRE smoother_apply') goto 9999 end if else @@ -1577,12 +1577,13 @@ contains & p%precv(level)%base_desc, trans,& & sweeps,work,info) end if + if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during 1st smoother_apply') + & a_err='Error during 2-PRE smoother_apply') goto 9999 end if - + ! ! Compute the residual (at all levels but the coarsest one) ! and call recursively @@ -1608,7 +1609,7 @@ contains & a_err='Error in recursive call') goto 9999 end if - + ! ! Apply the prolongator @@ -1616,13 +1617,13 @@ contains call psb_map_Y2X(done,mlprec_wrk(level+1)%vy2l,& & done,mlprec_wrk(level)%vy2l,& & p%precv(level+1)%map,info,work=work) - + if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& & a_err='Error during prolongation') goto 9999 end if - + ! ! Compute the residual ! @@ -1653,7 +1654,7 @@ contains if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during 2nd smoother_apply') + & a_err='Error during 2-POST smoother_apply') goto 9999 end if diff --git a/mlprec/impl/mld_dmlprec_bld.f90 b/mlprec/impl/mld_dmlprec_bld.f90 index 3199ded8..f88310ad 100644 --- a/mlprec/impl/mld_dmlprec_bld.f90 +++ b/mlprec/impl/mld_dmlprec_bld.f90 @@ -495,10 +495,16 @@ subroutine mld_dmlprec_bld(a,desc_a,p,info,amold,vmold,imold) call p%precv(i)%sm%build(p%precv(i)%base_a,p%precv(i)%base_desc,& & 'F',info,amold=amold,vmold=vmold,imold=imold) - p%precv(i)%sm2 => p%precv(i)%sm - if ((info == psb_success_).and.(i>1)) then - call p%precv(i)%cnv(info,amold=amold,vmold=vmold,imold=imold) + if (info == 0) then + if (allocated(p%precv(i)%sm2a)) then + call p%precv(i)%sm2a%build(a,desc_a,upd_,info,& + & amold=amold,vmold=vmold,imold=imold) + p%precv(i)%sm2 => p%precv(i)%sm2a + else + p%precv(i)%sm2 => p%precv(i)%sm + end if end if + if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& & a_err='One level preconditioner build.') diff --git a/mlprec/impl/mld_dprecbld.f90 b/mlprec/impl/mld_dprecbld.f90 index 65238515..28259f3d 100644 --- a/mlprec/impl/mld_dprecbld.f90 +++ b/mlprec/impl/mld_dprecbld.f90 @@ -173,15 +173,23 @@ subroutine mld_dprecbld(a,desc_a,p,info,amold,vmold,imold) & a_err='One level preconditioner check.') goto 9999 endif - + call p%precv(1)%sm%build(a,desc_a,upd_,info,& & amold=amold,vmold=vmold,imold=imold) + if (info == 0) then + if (allocated(p%precv(1)%sm2a)) then + call p%precv(1)%sm%build(a,desc_a,upd_,info,& + & amold=amold,vmold=vmold,imold=imold) + p%precv(1)%sm2 => p%precv(1)%sm2a + else + p%precv(1)%sm2 => p%precv(i)%sm + end if + end if if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& & a_err='One level preconditioner build.') goto 9999 endif - ! ! Number of levels > 1 ! diff --git a/mlprec/impl/mld_dprecset.F90 b/mlprec/impl/mld_dprecset.F90 index 4143932e..cb1c50df 100644 --- a/mlprec/impl/mld_dprecset.F90 +++ b/mlprec/impl/mld_dprecset.F90 @@ -328,16 +328,16 @@ subroutine mld_dprecsetsm(p,val,info,ilev,pos) implicit none ! Arguments - class(mld_dprec_type), target, intent(inout) :: p - class(mld_d_base_smoother_type), intent(in) :: val - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), optional, intent(in) :: ilev - character(len=*), optional, intent(in) :: pos - + class(mld_dprec_type), intent(inout) :: p + class(mld_d_base_smoother_type), intent(in) :: val + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional, intent(in) :: ilev + character(len=*), optional, intent(in) :: pos + ! Local variables integer(psb_ipk_) :: ilev_, nlev_, ilmin, ilmax character(len=*), parameter :: name='mld_precseti' - + info = psb_success_ if (.not.allocated(p%precv)) then @@ -365,12 +365,13 @@ subroutine mld_dprecsetsm(p,val,info,ilev,pos) & ': Error: invalid ILEV/NLEV combination',ilev_, nlev_ return endif + do ilev_ = ilmin, ilmax call p%precv(ilev_)%set(val,info,pos=pos) if (info /= 0) return end do - + end subroutine mld_dprecsetsm subroutine mld_dprecsetsv(p,val,info,ilev,pos) @@ -382,14 +383,14 @@ subroutine mld_dprecsetsv(p,val,info,ilev,pos) ! Arguments class(mld_dprec_type), intent(inout) :: p - class(mld_d_base_solver_type), intent(in) :: val - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), optional, intent(in) :: ilev - character(len=*), optional, intent(in) :: pos - + class(mld_d_base_solver_type), intent(in) :: val + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional, intent(in) :: ilev + character(len=*), optional, intent(in) :: pos + ! Local variables - integer(psb_ipk_) :: ilev_, nlev_, ilmin, ilmax - character(len=*), parameter :: name='mld_precseti' + integer(psb_ipk_) :: ilev_, nlev_, ilmin, ilmax + character(len=*), parameter :: name='mld_precseti' info = psb_success_ @@ -411,7 +412,7 @@ subroutine mld_dprecsetsv(p,val,info,ilev,pos) ilmin = 1 ilmax = nlev_ end if - + if ((ilev_<1).or.(ilev_ > nlev_)) then info = -1 @@ -564,7 +565,7 @@ subroutine mld_dprecsetr(p,what,val,info,ilev,pos) real(psb_dpk_), intent(in) :: val integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), optional, intent(in) :: ilev - character(len=*), optional, intent(in) :: pos + character(len=*), optional, intent(in) :: pos ! Local variables integer(psb_ipk_) :: ilev_,nlev_ diff --git a/mlprec/impl/mld_scprecset.F90 b/mlprec/impl/mld_scprecset.F90 index 5b80da49..70889de8 100644 --- a/mlprec/impl/mld_scprecset.F90 +++ b/mlprec/impl/mld_scprecset.F90 @@ -76,7 +76,7 @@ ! For this reason, the interface mld_precset to this routine has been built in ! such a way that ilev is not visible to the user (see mld_prec_mod.f90). ! -subroutine mld_scprecseti(p,what,val,info,ilev) +subroutine mld_scprecseti(p,what,val,info,ilev,pos) use psb_base_mod use mld_s_prec_mod, mld_protect_name => mld_scprecseti @@ -102,6 +102,7 @@ subroutine mld_scprecseti(p,what,val,info,ilev) integer(psb_ipk_), intent(in) :: val integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), optional, intent(in) :: ilev + character(len=*), optional, intent(in) :: pos ! Local variables integer(psb_ipk_) :: ilev_, nlev_ @@ -144,38 +145,20 @@ subroutine mld_scprecseti(p,what,val,info,ilev) ! ! Rules for fine level are slightly different. ! - select case(psb_toupper(trim(what))) - case('SMOOTHER_TYPE') - call onelev_set_smoother(p%precv(ilev_),val,info) - case('SUB_SOLVE') - call onelev_set_solver(p%precv(ilev_),val,info) - case('SMOOTHER_SWEEPS','ML_TYPE','AGGR_ALG','AGGR_ORD',& - & 'AGGR_KIND','SMOOTHER_POS','AGGR_OMEGA_ALG',& - & 'AGGR_EIG','SMOOTHER_SWEEPS_PRE',& - & 'SMOOTHER_SWEEPS_POST',& - & 'SUB_RESTR','SUB_PROL', & - & 'SUB_REN','SUB_OVR','SUB_FILLIN') - call p%precv(ilev_)%set(what,val,info) - - case default - call p%precv(ilev_)%set(what,val,info) - end select + call p%precv(ilev_)%set(what,val,info,pos=pos) else if (ilev_ > 1) then select case(psb_toupper(what)) - case('SMOOTHER_TYPE') - call onelev_set_smoother(p%precv(ilev_),val,info) - case('SUB_SOLVE') - call onelev_set_solver(p%precv(ilev_),val,info) - case('SMOOTHER_SWEEPS','ML_TYPE','AGGR_ALG','AGGR_ORD',& + case('SMOOTHER_TYPE','SUB_SOLVE','SMOOTHER_SWEEPS',& + & 'ML_TYPE','AGGR_ALG','AGGR_ORD',& & 'AGGR_KIND','SMOOTHER_POS','AGGR_OMEGA_ALG',& & 'AGGR_EIG','SMOOTHER_SWEEPS_PRE',& & 'SMOOTHER_SWEEPS_POST',& & 'SUB_RESTR','SUB_PROL', & & 'SUB_REN','SUB_OVR','SUB_FILLIN',& & 'COARSE_MAT') - call p%precv(ilev_)%set(what,val,info) + call p%precv(ilev_)%set(what,val,info,pos=pos) case('COARSE_SUBSOLVE') if (ilev_ /= nlev_) then @@ -184,7 +167,7 @@ subroutine mld_scprecseti(p,what,val,info,ilev) info = -2 return end if - call onelev_set_solver(p%precv(ilev_),val,info) + call p%precv(ilev_)%set('SUB_SOLVE',val,info,pos=pos) case('COARSE_SOLVE') if (ilev_ /= nlev_) then write(psb_err_unit,*) name,& @@ -192,38 +175,34 @@ subroutine mld_scprecseti(p,what,val,info,ilev) info = -2 return end if - + if (nlev_ > 1) then - call p%precv(nlev_)%set('COARSE_SOLVE',val,info) + call p%precv(nlev_)%set('COARSE_SOLVE',val,info,pos=pos) select case (val) case(mld_bjac_) - call onelev_set_smoother(p%precv(nlev_),val,info) -#if defined(HAVE_SLU_) - call onelev_set_solver(p%precv(nlev_),mld_slu_,info) + call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos) +#if defined(HAVE_SLU_) + call p%precv(nlev_)%set('SUB_SOLVE',mld_slu_,info,pos=pos) #elif defined(HAVE_MUMPS_) - call onelev_set_solver(p%precv(nlev_),mld_mumps_,info) -#else - call onelev_set_solver(p%precv(nlev_),mld_ilu_n_,info) + call p%precv(nlev_)%set('SUB_SOLVE',mld_mumps_,info,pos=pos) +#else + call p%precv(nlev_)%set('SUB_SOLVE',mld_ilu_n_,info,pos=pos) #endif call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info) case(mld_umf_, mld_slu_,mld_ilu_n_, mld_ilu_t_,mld_milu_n_) - call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info) - call onelev_set_solver(p%precv(nlev_),val,info) - call p%precv(nlev_)%set('COARSE_MAT',mld_repl_mat_,info) - case(mld_sludist_) - call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info) - call onelev_set_solver(p%precv(nlev_),val,info) - call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info) - case(mld_mumps_) - call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info) - call onelev_set_solver(p%precv(nlev_),val,info) - call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info) + call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos) + call p%precv(nlev_)%set('SUB_SOLVE',val,info,pos=pos) + call p%precv(nlev_)%set('COARSE_MAT',mld_repl_mat_,info,pos=pos) + case(mld_sludist_,mld_mumps_) + call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos) + call p%precv(nlev_)%set('SUB_SOLVE',val,info,pos=pos) + call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos) case(mld_jac_) - call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info) - call onelev_set_solver(p%precv(nlev_),mld_diag_scale_,info) - call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info) + call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos) + call p%precv(nlev_)%set('SUB_SOLVE',mld_diag_scale_,info,pos=pos) + call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos) end select - + endif case('COARSE_SWEEPS') if (ilev_ /= nlev_) then @@ -232,7 +211,7 @@ subroutine mld_scprecseti(p,what,val,info,ilev) info = -2 return end if - call p%precv(nlev_)%set('SMOOTHER_SWEEPS',val,info) + call p%precv(nlev_)%set('SMOOTHER_SWEEPS',val,info,pos=pos) case('COARSE_FILLIN') if (ilev_ /= nlev_) then @@ -241,9 +220,10 @@ subroutine mld_scprecseti(p,what,val,info,ilev) info = -2 return end if - call p%precv(nlev_)%set('SUB_FILLIN',val,info) + call p%precv(nlev_)%set('SUB_FILLIN',val,info,pos=pos) + case default - call p%precv(ilev_)%set(what,val,info) + call p%precv(ilev_)%set(what,val,info,pos=pos) end select endif @@ -254,33 +234,12 @@ subroutine mld_scprecseti(p,what,val,info,ilev) ! levels ! select case(psb_toupper(trim(what))) - case('SUB_SOLVE') + case('SUB_SOLVE','SUB_RESTR','SUB_PROL',& + & 'SUB_REN','SUB_OVR','SUB_FILLIN',& + & 'SMOOTHER_SWEEPS','SMOOTHER_TYPE') do ilev_=1,max(1,nlev_-1) - if (.not.allocated(p%precv(ilev_)%sm)) then - write(psb_err_unit,*) name,& - & ': Error: uninitialized preconditioner component,',& - & ' should call MLD_PRECINIT' - info = -1 - return - endif - call onelev_set_solver(p%precv(ilev_),val,info) - - end do - - case('SUB_RESTR','SUB_PROL',& - & 'SUB_REN','SUB_OVR','SUB_FILLIN') - do ilev_=1,max(1,nlev_-1) - call p%precv(ilev_)%set(what,val,info) - end do - - case('SMOOTHER_SWEEPS') - do ilev_=1,max(1,nlev_-1) - call p%precv(ilev_)%set(what,val,info) - end do - - case('SMOOTHER_TYPE') - do ilev_=1,max(1,nlev_-1) - call onelev_set_smoother(p%precv(ilev_),val,info) + call p%precv(ilev_)%set(what,val,info,pos=pos) + if (info /= 0) return end do case('ML_TYPE','AGGR_ALG','AGGR_ORD','AGGR_KIND',& @@ -288,334 +247,68 @@ subroutine mld_scprecseti(p,what,val,info,ilev) & 'SMOOTHER_POS','AGGR_OMEGA_ALG',& & 'AGGR_EIG','AGGR_FILTER') do ilev_=1,nlev_ - call p%precv(ilev_)%set(what,val,info) + call p%precv(ilev_)%set(what,val,info,pos=pos) + if (info /= 0) return end do case('COARSE_MAT') if (nlev_ > 1) then - call p%precv(nlev_)%set('COARSE_MAT',val,info) + call p%precv(nlev_)%set('COARSE_MAT',val,info,pos=pos) end if case('COARSE_SOLVE') if (nlev_ > 1) then - - call p%precv(nlev_)%set('COARSE_SOLVE',val,info) + call p%precv(nlev_)%set('COARSE_SOLVE',val,info,pos=pos) select case (val) case(mld_bjac_) - call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info) -#if defined(HAVE_SLU_) - call onelev_set_solver(p%precv(nlev_),mld_slu_,info) -#elif defined(HAVE_MUMPS_) - call onelev_set_solver(p%precv(nlev_),mld_mumps_,info) -#else - call onelev_set_solver(p%precv(nlev_),mld_ilu_n_,info) + call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos) +#if defined(HAVE_SLU_) + call p%precv(nlev_)%set('SUB_SOLVE',mld_slu_,info,pos=pos) +#elif defined(HAVE_MUMPS_) + call p%precv(nlev_)%set('SUB_SOLVE',mld_mumps_,info,pos=pos) +#else + call p%precv(nlev_)%set('SUB_SOLVE',mld_ilu_n_,info,pos=pos) #endif call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info) case(mld_umf_, mld_slu_,mld_ilu_n_, mld_ilu_t_,mld_milu_n_) - call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info) - call onelev_set_solver(p%precv(nlev_),val,info) - call p%precv(nlev_)%set('COARSE_MAT',mld_repl_mat_,info) - case(mld_sludist_) - call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info) - call onelev_set_solver(p%precv(nlev_),val,info) - call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info) - case(mld_mumps_) - call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info) - call onelev_set_solver(p%precv(nlev_),val,info) - call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info) + call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos) + call p%precv(nlev_)%set('SUB_SOLVE',val,info,pos=pos) + call p%precv(nlev_)%set('COARSE_MAT',mld_repl_mat_,info,pos=pos) + case(mld_sludist_,mld_mumps_) + call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos) + call p%precv(nlev_)%set('SUB_SOLVE',val,info,pos=pos) + call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos) case(mld_jac_) - call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info) - call onelev_set_solver(p%precv(nlev_),mld_diag_scale_,info) - call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info) + call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos) + call p%precv(nlev_)%set('SUB_SOLVE',mld_diag_scale_,info,pos=pos) + call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos) end select - endif case('COARSE_SUBSOLVE') if (nlev_ > 1) then - call onelev_set_solver(p%precv(nlev_),val,info) + call p%precv(nlev_)%set('SUB_SOLVE',val,info,pos=pos) endif case('COARSE_SWEEPS') if (nlev_ > 1) then - call p%precv(nlev_)%set('SMOOTHER_SWEEPS',val,info) + call p%precv(nlev_)%set('SMOOTHER_SWEEPS',val,info,pos=pos) end if case('COARSE_FILLIN') if (nlev_ > 1) then - call p%precv(nlev_)%set('SUB_FILLIN',val,info) + call p%precv(nlev_)%set('SUB_FILLIN',val,info,pos=pos) end if + case default do ilev_=1,nlev_ - call p%precv(ilev_)%set(what,val,info) + call p%precv(ilev_)%set(what,val,info,pos=pos) end do end select endif -contains - - subroutine onelev_set_smoother(level,val,info) - type(mld_s_onelev_type), intent(inout) :: level - integer(psb_ipk_), intent(in) :: val - integer(psb_ipk_), intent(out) :: info - info = psb_success_ - - ! - ! This here requires a bit more attention. - ! - select case (val) - case (mld_noprec_) - if (allocated(level%sm)) then - select type (sm => level%sm) - type is (mld_s_base_smoother_type) - ! do nothing - class default - call level%sm%free(info) - if (info == 0) deallocate(level%sm) - if (info == 0) allocate(mld_s_base_smoother_type ::& - & level%sm, stat=info) - if (info == 0) allocate(mld_s_id_solver_type ::& - & level%sm%sv, stat=info) - end select - else - allocate(mld_s_base_smoother_type ::& - & level%sm, stat=info) - if (info ==0) allocate(mld_s_id_solver_type ::& - & level%sm%sv, stat=info) - endif - - case (mld_jac_) - if (allocated(level%sm)) then - select type (sm => level%sm) - class is (mld_s_jac_smoother_type) - ! do nothing - class default - call level%sm%free(info) - if (info == 0) deallocate(level%sm) - if (info == 0) allocate(mld_s_jac_smoother_type :: & - & level%sm, stat=info) - if (info == 0) allocate(mld_s_diag_solver_type :: & - & level%sm%sv, stat=info) - end select - else - allocate(mld_s_jac_smoother_type :: level%sm, stat=info) - if (info == 0) allocate(mld_s_diag_solver_type ::& - & level%sm%sv, stat=info) - endif - - case (mld_bjac_) - if (allocated(level%sm)) then - select type (sm => level%sm) - class is (mld_s_jac_smoother_type) - ! do nothing - class default - call level%sm%free(info) - if (info == 0) deallocate(level%sm) - if (info == 0) allocate(mld_s_jac_smoother_type ::& - & level%sm, stat=info) - if (info == 0) allocate(mld_s_ilu_solver_type ::& - & level%sm%sv, stat=info) - end select - else - allocate(mld_s_jac_smoother_type :: level%sm, stat=info) - if (info == 0) allocate(mld_s_ilu_solver_type ::& - & level%sm%sv, stat=info) - endif - - case (mld_as_) - if (allocated(level%sm)) then - select type (sm => level%sm) - class is (mld_s_as_smoother_type) - ! do nothing - class default - call level%sm%free(info) - if (info == 0) deallocate(level%sm) - if (info == 0) allocate(mld_s_as_smoother_type ::& - & level%sm, stat=info) - if (info == 0) allocate(mld_s_ilu_solver_type ::& - & level%sm%sv, stat=info) - end select - else - allocate(mld_s_as_smoother_type :: level%sm, stat=info) - if (info == 0) allocate(mld_s_ilu_solver_type ::& - & level%sm%sv, stat=info) - endif - - case default - ! - ! Do nothing and hope for the best :) - ! - end select - if (allocated(level%sm)) & - & call level%sm%default() - - end subroutine onelev_set_smoother - - subroutine onelev_set_solver(level,val,info) - type(mld_s_onelev_type), intent(inout) :: level - integer(psb_ipk_), intent(in) :: val - integer(psb_ipk_), intent(out) :: info - info = psb_success_ - - ! - ! This here requires a bit more attention. - ! - select case (val) - case (mld_f_none_) - if (allocated(level%sm)) then - if (allocated(level%sm%sv)) then - select type (sv => level%sm%sv) - class is (mld_s_id_solver_type) - ! do nothing - class default - call level%sm%sv%free(info) - if (info == 0) deallocate(level%sm%sv) - if (info == 0) allocate(mld_s_id_solver_type ::& - & level%sm%sv, stat=info) - end select - else - allocate(mld_s_id_solver_type :: level%sm%sv, stat=info) - endif - if (allocated(level%sm)) then - if (allocated(level%sm%sv)) & - & call level%sm%sv%default() - end if - else - write(0,*) 'Calling set_solver without a smoother?' - info = -5 - end if - - case (mld_diag_scale_) - if (allocated(level%sm)) then - if (allocated(level%sm%sv)) then - select type (sv => level%sm%sv) - class is (mld_s_diag_solver_type) - ! do nothing - class default - call level%sm%sv%free(info) - if (info == 0) deallocate(level%sm%sv) - if (info == 0) allocate(mld_s_diag_solver_type ::& - & level%sm%sv, stat=info) - end select - else - allocate(mld_s_diag_solver_type :: level%sm%sv, stat=info) - endif - if (allocated(level%sm)) then - if (allocated(level%sm%sv)) & - & call level%sm%sv%default() - end if - else - write(0,*) 'Calling set_solver without a smoother?' - info = -5 - end if - - case (mld_gs_) - if (allocated(level%sm)) then - if (allocated(level%sm%sv)) then - select type (sv => level%sm%sv) - class is (mld_s_gs_solver_type) - ! do nothing - class default - call level%sm%sv%free(info) - if (info == 0) deallocate(level%sm%sv) - if (info == 0) allocate(mld_s_gs_solver_type ::& - & level%sm%sv, stat=info) - end select - else - allocate(mld_s_gs_solver_type :: level%sm%sv, stat=info) - endif - if (allocated(level%sm%sv)) then - call level%sm%sv%default() - else - endif - - else - write(0,*) 'Calling set_solver without a smoother?' - info = -5 - end if - - case (mld_ilu_n_,mld_milu_n_,mld_ilu_t_) - if (allocated(level%sm)) then - if (allocated(level%sm%sv)) then - select type (sv => level%sm%sv) - class is (mld_s_ilu_solver_type) - ! do nothing - class default - call level%sm%sv%free(info) - if (info == 0) deallocate(level%sm%sv) - if (info == 0) allocate(mld_s_ilu_solver_type ::& - & level%sm%sv, stat=info) - end select - else - allocate(mld_s_ilu_solver_type :: level%sm%sv, stat=info) - endif - if (allocated(level%sm)) then - if (allocated(level%sm%sv)) & - & call level%sm%sv%default() - end if - call level%sm%sv%set('SUB_SOLVE',val,info) - else - write(0,*) 'Calling set_solver without a smoother?' - info = -5 - end if - -#ifdef HAVE_SLU_ - case (mld_slu_) - if (allocated(level%sm)) then - if (allocated(level%sm%sv)) then - select type (sv => level%sm%sv) - class is (mld_s_slu_solver_type) - ! do nothing - class default - call level%sm%sv%free(info) - if (info == 0) deallocate(level%sm%sv) - if (info == 0) allocate(mld_s_slu_solver_type ::& - & level%sm%sv, stat=info) - end select - else - allocate(mld_s_slu_solver_type :: level%sm%sv, stat=info) - endif - if (allocated(level%sm)) then - if (allocated(level%sm%sv)) & - & call level%sm%sv%default() - end if - else - write(0,*) 'Calling set_solver without a smoother?' - info = -5 - end if -#endif -#ifdef HAVE_MUMPS_ - case (mld_mumps_) - if (allocated(level%sm%sv)) then - select type (sv => level%sm%sv) - class is (mld_s_mumps_solver_type) - ! do nothing - class default - call level%sm%sv%free(info) - if (info == 0) deallocate(level%sm%sv) - if (info == 0) allocate(mld_s_mumps_solver_type ::& - & level%sm%sv, stat=info) - end select - else - allocate(mld_s_mumps_solver_type :: level%sm%sv, stat=info) - endif - if (allocated(level%sm)) then - if (allocated(level%sm%sv)) & - & call level%sm%sv%default() - end if -#endif - - case default - ! - ! Do nothing and hope for the best :) - ! - end select - - end subroutine onelev_set_solver - - end subroutine mld_scprecseti ! @@ -657,7 +350,7 @@ end subroutine mld_scprecseti ! For this reason, the interface mld_precset to this routine has been built in ! such a way that ilev is not visible to the user (see mld_prec_mod.f90). ! -subroutine mld_scprecsetc(p,what,string,info,ilev) +subroutine mld_scprecsetc(p,what,string,info,ilev,pos) use psb_base_mod use mld_s_prec_mod, mld_protect_name => mld_scprecsetc @@ -670,6 +363,7 @@ subroutine mld_scprecsetc(p,what,string,info,ilev) character(len=*), intent(in) :: string integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), optional, intent(in) :: ilev + character(len=*), optional, intent(in) :: pos ! Local variables integer(psb_ipk_) :: ilev_, nlev_,val @@ -698,9 +392,9 @@ subroutine mld_scprecsetc(p,what,string,info,ilev) val = mld_stringval(string) if (val >=0) then - call p%set(what,val,info,ilev=ilev) + call p%set(what,val,info,ilev=ilev,pos=pos) else - call p%precv(ilev_)%set(what,string,info) + call p%precv(ilev_)%set(what,string,info,pos=pos) end if end subroutine mld_scprecsetc @@ -744,7 +438,7 @@ end subroutine mld_scprecsetc ! For this reason, the interface mld_precset to this routine has been built in ! such a way that ilev is not visible to the user (see mld_prec_mod.f90). ! -subroutine mld_scprecsetr(p,what,val,info,ilev) +subroutine mld_scprecsetr(p,what,val,info,ilev,pos) use psb_base_mod use mld_s_prec_mod, mld_protect_name => mld_scprecsetr @@ -757,6 +451,7 @@ subroutine mld_scprecsetr(p,what,val,info,ilev) real(psb_spk_), intent(in) :: val integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), optional, intent(in) :: ilev + character(len=*), optional, intent(in) :: pos ! Local variables integer(psb_ipk_) :: ilev_,nlev_ @@ -793,7 +488,7 @@ subroutine mld_scprecsetr(p,what,val,info,ilev) ! if (present(ilev)) then - call p%precv(ilev_)%set(what,val,info) + call p%precv(ilev_)%set(what,val,info,pos=pos) else if (.not.present(ilev)) then ! @@ -803,19 +498,19 @@ subroutine mld_scprecsetr(p,what,val,info,ilev) select case(psb_toupper(what)) case('COARSE_ILUTHRS') ilev_=nlev_ - call p%precv(ilev_)%set('SUB_ILUTHRS',val,info) + call p%precv(ilev_)%set('SUB_ILUTHRS',val,info,pos=pos) case('AGGR_THRESH') thr = val do ilev_ = 2, nlev_ - call p%precv(ilev_)%set('AGGR_THRESH',thr,info) + call p%precv(ilev_)%set('AGGR_THRESH',thr,info,pos=pos) thr = thr * p%precv(ilev_)%parms%aggr_scale end do case default do ilev_=1,nlev_ - call p%precv(ilev_)%set(what,val,info) + call p%precv(ilev_)%set(what,val,info,pos=pos) end do end select diff --git a/mlprec/impl/mld_smlprec_aply.f90 b/mlprec/impl/mld_smlprec_aply.f90 index 4dd1b108..f80db873 100644 --- a/mlprec/impl/mld_smlprec_aply.f90 +++ b/mlprec/impl/mld_smlprec_aply.f90 @@ -405,10 +405,10 @@ contains implicit none ! Arguments - integer(psb_ipk_) :: level - type(mld_sprec_type), intent(inout) :: p - type(mld_mlprec_wrk_type), intent(inout) :: mlprec_wrk(:) - character, intent(in) :: trans + integer(psb_ipk_) :: level + type(mld_sprec_type), target, intent(inout) :: p + type(mld_mlprec_wrk_type), intent(inout) :: mlprec_wrk(:) + character, intent(in) :: trans real(psb_spk_),target :: work(:) integer(psb_ipk_), intent(out) :: info @@ -434,7 +434,6 @@ contains ictxt = p%precv(level)%base_desc%get_context() call psb_info(ictxt, me, np) - if (level > 1) then nc2l = p%precv(level)%base_desc%get_local_cols() nr2l = p%precv(level)%base_desc%get_local_rows() @@ -539,7 +538,6 @@ contains end if ! This is one step of post-smoothing - if (level < nlev) then call inner_ml_aply(level+1,p,mlprec_wrk,trans,work,info) if (info /= psb_success_) then @@ -572,7 +570,7 @@ contains end if sweeps = p%precv(level)%parms%sweeps_post - call p%precv(level)%sm%apply(sone,& + call p%precv(level)%sm2%apply(sone,& & mlprec_wrk(level)%x2l,sone,mlprec_wrk(level)%y2l,& & p%precv(level)%base_desc, trans,& & sweeps,work,info) @@ -621,13 +619,17 @@ contains ! if (level < nlev) then sweeps = p%precv(level)%parms%sweeps_post + call p%precv(level)%sm2%apply(sone,& + & mlprec_wrk(level)%x2l,szero,mlprec_wrk(level)%y2l,& + & p%precv(level)%base_desc, trans,& + & sweeps,work,info) else sweeps = p%precv(level)%parms%sweeps + call p%precv(level)%sm%apply(sone,& + & mlprec_wrk(level)%x2l,szero,mlprec_wrk(level)%y2l,& + & p%precv(level)%base_desc, trans,& + & sweeps,work,info) end if - call p%precv(level)%sm%apply(sone,& - & mlprec_wrk(level)%x2l,szero,mlprec_wrk(level)%y2l,& - & p%precv(level)%base_desc, trans,& - & sweeps,work,info) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& @@ -830,6 +832,13 @@ contains case(mld_twoside_smooth_) + ! CHECK + if (.not.(associated(p%precv(level)%sm2,p%precv(level)%sm2a))) then + write(0,*) 'inner_ml_aply: unassociated sm2 at level ',level + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Error during restriction') + goto 9999 + end if nc2l = p%precv(level)%base_desc%get_local_cols() nr2l = p%precv(level)%base_desc%get_local_rows() allocate(mlprec_wrk(level)%ty(nc2l), mlprec_wrk(level)%tx(nc2l), stat=info) @@ -866,10 +875,19 @@ contains else sweeps = p%precv(level)%parms%sweeps end if - if (info == psb_success_) call p%precv(level)%sm%apply(sone,& - & mlprec_wrk(level)%x2l,szero,mlprec_wrk(level)%y2l,& - & p%precv(level)%base_desc, trans,& - & sweeps,work,info) + + if (trans == 'N') then + if (info == psb_success_) call p%precv(level)%sm%apply(sone,& + & mlprec_wrk(level)%x2l,szero,mlprec_wrk(level)%y2l,& + & p%precv(level)%base_desc, trans,& + & sweeps,work,info) + else + if (info == psb_success_) call p%precv(level)%sm2%apply(sone,& + & mlprec_wrk(level)%x2l,szero,mlprec_wrk(level)%y2l,& + & p%precv(level)%base_desc, trans,& + & sweeps,work,info) + end if + if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& & a_err='Error during smoother_apply') @@ -930,10 +948,18 @@ contains else sweeps = p%precv(level)%parms%sweeps_pre end if - if (info == psb_success_) call p%precv(level)%sm%apply(sone,& - & mlprec_wrk(level)%tx,sone,mlprec_wrk(level)%y2l,& - & p%precv(level)%base_desc, trans,& - & sweeps,work,info) + if (trans == 'N') then + if (info == psb_success_) call p%precv(level)%sm2%apply(sone,& + & mlprec_wrk(level)%tx,sone,mlprec_wrk(level)%y2l,& + & p%precv(level)%base_desc, trans,& + & sweeps,work,info) + else + if (info == psb_success_) call p%precv(level)%sm%apply(sone,& + & mlprec_wrk(level)%tx,sone,mlprec_wrk(level)%y2l,& + & p%precv(level)%base_desc, trans,& + & sweeps,work,info) + end if + if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& & a_err='Error during smoother_apply') @@ -1043,7 +1069,7 @@ subroutine mld_smlprec_aply_vect(alpha,p,x,beta,y,desc_data,trans,work,info) level = 1 call psb_geaxpby(sone,x,szero,mlprec_wrk(level)%vx2l,p%precv(level)%base_desc,info) - call mlprec_wrk(level)%vy2l%set(szero) + call mlprec_wrk(level)%vy2l%zero() call inner_ml_aply(level,p,mlprec_wrk,trans_,work,info) @@ -1090,12 +1116,12 @@ contains implicit none ! Arguments - integer(psb_ipk_) :: level - type(mld_sprec_type), intent(inout) :: p - type(mld_mlprec_wrk_type), intent(inout) :: mlprec_wrk(:) - character, intent(in) :: trans - real(psb_spk_),target :: work(:) - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: level + type(mld_sprec_type), target, intent(inout) :: p + type(mld_mlprec_wrk_type), intent(inout) :: mlprec_wrk(:) + character, intent(in) :: trans + real(psb_spk_),target :: work(:) + integer(psb_ipk_), intent(out) :: info ! Local variables integer(psb_ipk_) :: ictxt,np,me @@ -1122,7 +1148,9 @@ contains nc2l = p%precv(level)%base_desc%get_local_cols() nr2l = p%precv(level)%base_desc%get_local_rows() - + if(debug_level > 1) then + write(debug_unit,*) me,' inner_ml_aply at level ',level + end if select case(p%precv(level)%parms%ml_type) @@ -1160,7 +1188,7 @@ contains & sweeps,work,info) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during smoother_apply') + & a_err='Error during ADD smoother_apply') goto 9999 end if @@ -1250,25 +1278,25 @@ contains sweeps = p%precv(level)%parms%sweeps_post - call p%precv(level)%sm%apply(sone,& + call p%precv(level)%sm2%apply(sone,& & mlprec_wrk(level)%vx2l,sone,mlprec_wrk(level)%vy2l,& & p%precv(level)%base_desc, trans,& & sweeps,work,info) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during smoother_apply') + & a_err='Error during POST smoother_apply') goto 9999 end if else sweeps = p%precv(level)%parms%sweeps - call p%precv(level)%sm%apply(sone,& + call p%precv(level)%sm2%apply(sone,& & mlprec_wrk(level)%vx2l,szero,mlprec_wrk(level)%vy2l,& & p%precv(level)%base_desc, trans,& & sweeps,work,info) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during smoother_apply') + & a_err='Error during POST smoother_apply') goto 9999 end if @@ -1302,13 +1330,13 @@ contains else sweeps = p%precv(level)%parms%sweeps end if - call p%precv(level)%sm%apply(sone,& + call p%precv(level)%sm2%apply(sone,& & mlprec_wrk(level)%vx2l,szero,mlprec_wrk(level)%vy2l,& & p%precv(level)%base_desc, trans,& & sweeps,work,info) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during smoother_apply') + & a_err='Error during POST smoother_apply') goto 9999 end if @@ -1386,7 +1414,7 @@ contains & sweeps,work,info) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during smoother_apply') + & a_err='Error during PRE smoother_apply') goto 9999 end if @@ -1484,7 +1512,7 @@ contains & sweeps,work,info) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during smoother_apply') + & a_err='Error during PRE smoother_apply') goto 9999 end if else @@ -1530,19 +1558,28 @@ contains if (level < nlev) then if (trans == 'N') then sweeps = p%precv(level)%parms%sweeps_pre + if (info == psb_success_) call p%precv(level)%sm%apply(sone,& + & mlprec_wrk(level)%vx2l,szero,mlprec_wrk(level)%vy2l,& + & p%precv(level)%base_desc, trans,& + & sweeps,work,info) else sweeps = p%precv(level)%parms%sweeps_post + if (info == psb_success_) call p%precv(level)%sm2%apply(sone,& + & mlprec_wrk(level)%vx2l,szero,mlprec_wrk(level)%vy2l,& + & p%precv(level)%base_desc, trans,& + & sweeps,work,info) end if else sweeps = p%precv(level)%parms%sweeps + if (info == psb_success_) call p%precv(level)%sm%apply(sone,& + & mlprec_wrk(level)%vx2l,szero,mlprec_wrk(level)%vy2l,& + & p%precv(level)%base_desc, trans,& + & sweeps,work,info) end if - if (info == psb_success_) call p%precv(level)%sm%apply(sone,& - & mlprec_wrk(level)%vx2l,szero,mlprec_wrk(level)%vy2l,& - & p%precv(level)%base_desc, trans,& - & sweeps,work,info) + if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during smoother_apply') + & a_err='Error during 2-PRE smoother_apply') goto 9999 end if @@ -1602,16 +1639,21 @@ contains ! if (trans == 'N') then sweeps = p%precv(level)%parms%sweeps_post + if (info == psb_success_) call p%precv(level)%sm2%apply(sone,& + & mlprec_wrk(level)%vtx,sone,mlprec_wrk(level)%vy2l,& + & p%precv(level)%base_desc, trans,& + & sweeps,work,info) else sweeps = p%precv(level)%parms%sweeps_pre + if (info == psb_success_) call p%precv(level)%sm%apply(sone,& + & mlprec_wrk(level)%vtx,sone,mlprec_wrk(level)%vy2l,& + & p%precv(level)%base_desc, trans,& + & sweeps,work,info) end if - if (info == psb_success_) call p%precv(level)%sm%apply(sone,& - & mlprec_wrk(level)%vtx,sone,mlprec_wrk(level)%vy2l,& - & p%precv(level)%base_desc, trans,& - & sweeps,work,info) + if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during smoother_apply') + & a_err='Error during 2-POST smoother_apply') goto 9999 end if diff --git a/mlprec/impl/mld_smlprec_bld.f90 b/mlprec/impl/mld_smlprec_bld.f90 index 3ea5518c..c76228dc 100644 --- a/mlprec/impl/mld_smlprec_bld.f90 +++ b/mlprec/impl/mld_smlprec_bld.f90 @@ -495,10 +495,16 @@ subroutine mld_smlprec_bld(a,desc_a,p,info,amold,vmold,imold) call p%precv(i)%sm%build(p%precv(i)%base_a,p%precv(i)%base_desc,& & 'F',info,amold=amold,vmold=vmold,imold=imold) - - if ((info == psb_success_).and.(i>1)) then - call p%precv(i)%cnv(info,amold=amold,vmold=vmold,imold=imold) + if (info == 0) then + if (allocated(p%precv(i)%sm2a)) then + call p%precv(i)%sm2a%build(a,desc_a,upd_,info,& + & amold=amold,vmold=vmold,imold=imold) + p%precv(i)%sm2 => p%precv(i)%sm2a + else + p%precv(i)%sm2 => p%precv(i)%sm + end if end if + if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& & a_err='One level preconditioner build.') diff --git a/mlprec/impl/mld_sprecset.F90 b/mlprec/impl/mld_sprecset.F90 index 822e1ea2..22da5c01 100644 --- a/mlprec/impl/mld_sprecset.F90 +++ b/mlprec/impl/mld_sprecset.F90 @@ -76,7 +76,7 @@ ! For this reason, the interface mld_precset to this routine has been built in ! such a way that ilev is not visible to the user (see mld_prec_mod.f90). ! -subroutine mld_sprecseti(p,what,val,info,ilev) +subroutine mld_sprecseti(p,what,val,info,ilev,pos) use psb_base_mod use mld_s_prec_mod, mld_protect_name => mld_sprecseti @@ -101,6 +101,7 @@ subroutine mld_sprecseti(p,what,val,info,ilev) integer(psb_ipk_), intent(in) :: val integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), optional, intent(in) :: ilev + character(len=*), optional, intent(in) :: pos ! Local variables integer(psb_ipk_) :: ilev_, nlev_ @@ -141,39 +142,21 @@ subroutine mld_sprecseti(p,what,val,info,ilev) if (present(ilev)) then if (ilev_ == 1) then - ! - ! Rules for fine level are slightly different. - ! - select case(what) - case(mld_smoother_type_) - call onelev_set_smoother(p%precv(ilev_),val,info) - case(mld_sub_solve_) - call onelev_set_solver(p%precv(ilev_),val,info) - case(mld_smoother_sweeps_,mld_ml_type_,mld_aggr_alg_,mld_aggr_ord_,& - & mld_aggr_kind_,mld_smoother_pos_,mld_aggr_omega_alg_,mld_aggr_eig_,& - & mld_smoother_sweeps_pre_,mld_smoother_sweeps_post_,& - & mld_sub_restr_,mld_sub_prol_, & - & mld_sub_ren_,mld_sub_ovr_,mld_sub_fillin_) - call p%precv(ilev_)%set(what,val,info) - case default - call p%precv(ilev_)%set(what,val,info) - end select + call p%precv(ilev_)%set(what,val,info,pos=pos) else if (ilev_ > 1) then select case(what) - case(mld_smoother_type_) - call onelev_set_smoother(p%precv(ilev_),val,info) - case(mld_sub_solve_) - call onelev_set_solver(p%precv(ilev_),val,info) - case(mld_smoother_sweeps_,mld_ml_type_,mld_aggr_alg_,mld_aggr_ord_,& - & mld_aggr_kind_,mld_smoother_pos_,mld_aggr_omega_alg_,mld_aggr_eig_,& + case(mld_smoother_type_,mld_sub_solve_,mld_smoother_sweeps_,& + & mld_ml_type_,mld_aggr_alg_,mld_aggr_ord_,& + & mld_aggr_kind_,mld_smoother_pos_,& + & mld_aggr_omega_alg_,mld_aggr_eig_,& & mld_smoother_sweeps_pre_,mld_smoother_sweeps_post_,& & mld_sub_restr_,mld_sub_prol_, & & mld_sub_ren_,mld_sub_ovr_,mld_sub_fillin_,& & mld_coarse_mat_) - call p%precv(ilev_)%set(what,val,info) + call p%precv(ilev_)%set(what,val,info,pos=pos) case(mld_coarse_subsolve_) if (ilev_ /= nlev_) then @@ -182,7 +165,7 @@ subroutine mld_sprecseti(p,what,val,info,ilev) info = -2 return end if - call onelev_set_solver(p%precv(ilev_),val,info) + call p%precv(ilev_)%set(mld_sub_solve_,val,info,pos=pos) case(mld_coarse_solve_) if (ilev_ /= nlev_) then write(psb_err_unit,*) name,& @@ -192,30 +175,30 @@ subroutine mld_sprecseti(p,what,val,info,ilev) end if if (nlev_ > 1) then - call p%precv(nlev_)%set(mld_coarse_solve_,val,info) + call p%precv(nlev_)%set(mld_coarse_solve_,val,info,pos=pos) select case (val) case(mld_bjac_) - call onelev_set_smoother(p%precv(nlev_),val,info) -#if defined(HAVE_SLU_) - call onelev_set_solver(p%precv(nlev_),mld_slu_,info) + call p%precv(nlev_)%set(mld_smoother_type_,val,info,pos=pos) +#if defined(HAVE_SLU_) + call p%precv(nlev_)%set(mld_sub_solve_,mld_slu_,info,pos=pos) #elif defined(HAVE_MUMPS_) - call onelev_set_solver(p%precv(nlev_),mld_mumps_,info) + call p%precv(nlev_)%set(mld_sub_solve_,mld_mumps_,info,pos=pos) #else - call onelev_set_solver(p%precv(nlev_),mld_ilu_n_,info) + call p%precv(nlev_)%set(mld_sub_solve_,mld_ilu_n_,info,pos=pos) #endif - call p%precv(nlev_)%set(mld_coarse_mat_,mld_distr_mat_,info) + call p%precv(nlev_)%set(mld_coarse_mat_,mld_distr_mat_,info,pos=pos) case(mld_umf_, mld_slu_,mld_ilu_n_, mld_ilu_t_,mld_milu_n_) - call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info) - call onelev_set_solver(p%precv(nlev_),val,info) - call p%precv(nlev_)%set(mld_coarse_mat_,mld_repl_mat_,info) + call p%precv(nlev_)%set(mld_smoother_type_,mld_bjac_,info,pos=pos) + call p%precv(nlev_)%set(mld_sub_solve_,val,info,pos=pos) + call p%precv(nlev_)%set(mld_coarse_mat_,mld_repl_mat_,info,pos=pos) case(mld_sludist_,mld_mumps_) - call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info) - call onelev_set_solver(p%precv(nlev_),val,info) - call p%precv(nlev_)%set(mld_coarse_mat_,mld_distr_mat_,info) + call p%precv(nlev_)%set(mld_smoother_type_,mld_bjac_,info,pos=pos) + call p%precv(nlev_)%set(mld_sub_solve_,val,info,pos=pos) + call p%precv(nlev_)%set(mld_coarse_mat_,mld_distr_mat_,info,pos=pos) case(mld_jac_) - call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info) - call onelev_set_solver(p%precv(nlev_),mld_diag_scale_,info) - call p%precv(nlev_)%set(mld_coarse_mat_,mld_distr_mat_,info) + call p%precv(nlev_)%set(mld_smoother_type_,mld_bjac_,info,pos=pos) + call p%precv(nlev_)%set(mld_sub_solve_,mld_diag_scale_,info,pos=pos) + call p%precv(nlev_)%set(mld_coarse_mat_,mld_distr_mat_,info,pos=pos) end select endif @@ -226,7 +209,7 @@ subroutine mld_sprecseti(p,what,val,info,ilev) info = -2 return end if - call p%precv(nlev_)%set(mld_smoother_sweeps_,val,info) + call p%precv(nlev_)%set(mld_smoother_sweeps_,val,info,pos=pos) case(mld_coarse_fillin_) if (ilev_ /= nlev_) then @@ -235,9 +218,9 @@ subroutine mld_sprecseti(p,what,val,info,ilev) info = -2 return end if - call p%precv(nlev_)%set(mld_sub_fillin_,val,info) + call p%precv(nlev_)%set(mld_sub_fillin_,val,info,pos=pos) case default - call p%precv(ilev_)%set(what,val,info) + call p%precv(ilev_)%set(what,val,info,pos=pos) end select endif @@ -248,33 +231,12 @@ subroutine mld_sprecseti(p,what,val,info,ilev) ! levels ! select case(what) - case(mld_sub_solve_) + case(mld_sub_solve_,mld_sub_restr_,mld_sub_prol_,& + & mld_sub_ren_,mld_sub_ovr_,mld_sub_fillin_,& + & mld_smoother_sweeps_,mld_smoother_type_) do ilev_=1,max(1,nlev_-1) - if (.not.allocated(p%precv(ilev_)%sm)) then - write(psb_err_unit,*) name,& - & ': Error: uninitialized preconditioner component,',& - & ' should call MLD_PRECINIT' - info = -1 - return - endif - call onelev_set_solver(p%precv(ilev_),val,info) - - end do - - case(mld_sub_restr_,mld_sub_prol_,& - & mld_sub_ren_,mld_sub_ovr_,mld_sub_fillin_) - do ilev_=1,max(1,nlev_-1) - call p%precv(ilev_)%set(what,val,info) - end do - - case(mld_smoother_sweeps_) - do ilev_=1,max(1,nlev_-1) - call p%precv(ilev_)%set(what,val,info) - end do - - case(mld_smoother_type_) - do ilev_=1,max(1,nlev_-1) - call onelev_set_smoother(p%precv(ilev_),val,info) + call p%precv(ilev_)%set(what,val,info,pos=pos) + if (info /= 0) return end do case(mld_ml_type_,mld_aggr_alg_,mld_aggr_ord_,mld_aggr_kind_,& @@ -282,336 +244,73 @@ subroutine mld_sprecseti(p,what,val,info,ilev) & mld_smoother_pos_,mld_aggr_omega_alg_,& & mld_aggr_eig_,mld_aggr_filter_) do ilev_=1,nlev_ - call p%precv(ilev_)%set(what,val,info) + call p%precv(ilev_)%set(what,val,info,pos=pos) end do case(mld_coarse_mat_) if (nlev_ > 1) then - call p%precv(nlev_)%set(mld_coarse_mat_,val,info) + call p%precv(nlev_)%set(mld_coarse_mat_,val,info,pos=pos) end if case(mld_coarse_solve_) if (nlev_ > 1) then - call p%precv(nlev_)%set(mld_coarse_solve_,val,info) + call p%precv(nlev_)%set(mld_coarse_solve_,val,info,pos=pos) select case (val) case(mld_bjac_) - call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info) -#if defined(HAVE_SLU_) - call onelev_set_solver(p%precv(nlev_),mld_slu_,info) -#elif defined(HAVE_SLU_) - call onelev_set_solver(p%precv(nlev_),mld_slu_,info) + call p%precv(nlev_)%set(mld_smoother_type_,mld_bjac_,info,pos=pos) +#if defined(HAVE_SLU_) + call p%precv(nlev_)%set(mld_sub_solve_,mld_slu_,info,pos=pos) #else - call onelev_set_solver(p%precv(nlev_),mld_ilu_n_,info) + call p%precv(nlev_)%set(mld_sub_solve_,mld_ilu_n_,info,pos=pos) #endif - call p%precv(nlev_)%set(mld_coarse_mat_,mld_distr_mat_,info) + call p%precv(nlev_)%set(mld_coarse_mat_,mld_distr_mat_,info,pos=pos) case(mld_umf_, mld_slu_,mld_ilu_n_, mld_ilu_t_,mld_milu_n_) - call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info) - call onelev_set_solver(p%precv(nlev_),val,info) - call p%precv(nlev_)%set(mld_coarse_mat_,mld_repl_mat_,info) + call p%precv(nlev_)%set(mld_smoother_type_,mld_bjac_,info,pos=pos) + call p%precv(nlev_)%set(mld_sub_solve_,val,info,pos=pos) + call p%precv(nlev_)%set(mld_coarse_mat_,mld_repl_mat_,info,pos=pos) case(mld_sludist_) - call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info) - call onelev_set_solver(p%precv(nlev_),val,info) - call p%precv(nlev_)%set(mld_coarse_mat_,mld_distr_mat_,info) + call p%precv(nlev_)%set(mld_smoother_type_,mld_bjac_,info,pos=pos) + call p%precv(nlev_)%set(mld_sub_solve_,val,info,pos=pos) + call p%precv(nlev_)%set(mld_coarse_mat_,mld_distr_mat_,info,pos=pos) case(mld_mumps_) - call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info) - call onelev_set_solver(p%precv(nlev_),val,info) - call p%precv(nlev_)%set(mld_coarse_mat_,mld_distr_mat_,info) + call p%precv(nlev_)%set(mld_smoother_type_,mld_bjac_,info,pos=pos) + call p%precv(nlev_)%set(mld_sub_solve_,val,info,pos=pos) + call p%precv(nlev_)%set(mld_coarse_mat_,mld_distr_mat_,info,pos=pos) case(mld_jac_) - call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info) - call onelev_set_solver(p%precv(nlev_),mld_diag_scale_,info) - call p%precv(nlev_)%set(mld_coarse_mat_,mld_distr_mat_,info) + call p%precv(nlev_)%set(mld_smoother_type_,mld_bjac_,info,pos=pos) + call p%precv(nlev_)%set(mld_sub_solve_,mld_diag_scale_,info,pos=pos) + call p%precv(nlev_)%set(mld_coarse_mat_,mld_distr_mat_,info,pos=pos) end select endif case(mld_coarse_subsolve_) if (nlev_ > 1) then - call onelev_set_solver(p%precv(nlev_),val,info) + call p%precv(nlev_)%set(mld_sub_solve_,val,info,pos=pos) endif case(mld_coarse_sweeps_) if (nlev_ > 1) then - call p%precv(nlev_)%set(mld_smoother_sweeps_,val,info) + call p%precv(nlev_)%set(mld_smoother_sweeps_,val,info,pos=pos) end if case(mld_coarse_fillin_) if (nlev_ > 1) then - call p%precv(nlev_)%set(mld_sub_fillin_,val,info) + call p%precv(nlev_)%set(mld_sub_fillin_,val,info,pos=pos) end if case default do ilev_=1,nlev_ - call p%precv(ilev_)%set(what,val,info) + call p%precv(ilev_)%set(what,val,info,pos=pos) end do end select endif -contains - - subroutine onelev_set_smoother(level,val,info) - type(mld_s_onelev_type), intent(inout) :: level - integer(psb_ipk_), intent(in) :: val - integer(psb_ipk_), intent(out) :: info - info = psb_success_ - - ! - ! This here requires a bit more attention. - ! - select case (val) - case (mld_noprec_) - if (allocated(level%sm)) then - select type (sm => level%sm) - type is (mld_s_base_smoother_type) - ! do nothing - class default - call level%sm%free(info) - if (info == 0) deallocate(level%sm) - if (info == 0) allocate(mld_s_base_smoother_type ::& - & level%sm, stat=info) - if (info == 0) allocate(mld_s_id_solver_type ::& - & level%sm%sv, stat=info) - end select - else - allocate(mld_s_base_smoother_type ::& - & level%sm, stat=info) - if (info ==0) allocate(mld_s_id_solver_type ::& - & level%sm%sv, stat=info) - endif - - case (mld_jac_) - if (allocated(level%sm)) then - select type (sm => level%sm) - class is (mld_s_jac_smoother_type) - ! do nothing - class default - call level%sm%free(info) - if (info == 0) deallocate(level%sm) - if (info == 0) allocate(mld_s_jac_smoother_type :: & - & level%sm, stat=info) - if (info == 0) allocate(mld_s_diag_solver_type :: & - & level%sm%sv, stat=info) - end select - else - allocate(mld_s_jac_smoother_type :: level%sm, stat=info) - if (info == 0) allocate(mld_s_diag_solver_type ::& - & level%sm%sv, stat=info) - endif - - case (mld_bjac_) - if (allocated(level%sm)) then - select type (sm => level%sm) - class is (mld_s_jac_smoother_type) - ! do nothing - class default - call level%sm%free(info) - if (info == 0) deallocate(level%sm) - if (info == 0) allocate(mld_s_jac_smoother_type ::& - & level%sm, stat=info) - if (info == 0) allocate(mld_s_ilu_solver_type ::& - & level%sm%sv, stat=info) - end select - else - allocate(mld_s_jac_smoother_type :: level%sm, stat=info) - if (info == 0) allocate(mld_s_ilu_solver_type ::& - & level%sm%sv, stat=info) - endif - - case (mld_as_) - if (allocated(level%sm)) then - select type (sm => level%sm) - class is (mld_s_as_smoother_type) - ! do nothing - class default - call level%sm%free(info) - if (info == 0) deallocate(level%sm) - if (info == 0) allocate(mld_s_as_smoother_type ::& - & level%sm, stat=info) - if (info == 0) allocate(mld_s_ilu_solver_type ::& - & level%sm%sv, stat=info) - end select - else - allocate(mld_s_as_smoother_type :: level%sm, stat=info) - if (info == 0) allocate(mld_s_ilu_solver_type ::& - & level%sm%sv, stat=info) - endif - - case default - ! - ! Do nothing and hope for the best :) - ! - end select - if (allocated(level%sm)) & - & call level%sm%default() - - end subroutine onelev_set_smoother - - subroutine onelev_set_solver(level,val,info) - type(mld_s_onelev_type), intent(inout) :: level - integer(psb_ipk_), intent(in) :: val - integer(psb_ipk_), intent(out) :: info - info = psb_success_ - - ! - ! This here requires a bit more attention. - ! - select case (val) - case (mld_f_none_) - if (allocated(level%sm)) then - if (allocated(level%sm%sv)) then - select type (sv => level%sm%sv) - class is (mld_s_id_solver_type) - ! do nothing - class default - call level%sm%sv%free(info) - if (info == 0) deallocate(level%sm%sv) - if (info == 0) allocate(mld_s_id_solver_type ::& - & level%sm%sv, stat=info) - end select - else - allocate(mld_s_id_solver_type :: level%sm%sv, stat=info) - endif - if (allocated(level%sm)) then - if (allocated(level%sm%sv)) & - & call level%sm%sv%default() - end if - else - write(0,*) 'Calling set_solver without a smoother?' - info = -5 - end if - - - case (mld_diag_scale_) - if (allocated(level%sm)) then - if (allocated(level%sm%sv)) then - select type (sv => level%sm%sv) - class is (mld_s_diag_solver_type) - ! do nothing - class default - call level%sm%sv%free(info) - if (info == 0) deallocate(level%sm%sv) - if (info == 0) allocate(mld_s_diag_solver_type ::& - & level%sm%sv, stat=info) - end select - else - allocate(mld_s_diag_solver_type :: level%sm%sv, stat=info) - endif - if (allocated(level%sm)) then - if (allocated(level%sm%sv)) & - & call level%sm%sv%default() - end if - else - write(0,*) 'Calling set_solver without a smoother?' - info = -5 - end if - - case (mld_gs_) - if (allocated(level%sm)) then - if (allocated(level%sm%sv)) then - select type (sv => level%sm%sv) - class is (mld_s_gs_solver_type) - ! do nothing - class default - call level%sm%sv%free(info) - if (info == 0) deallocate(level%sm%sv) - if (info == 0) allocate(mld_s_gs_solver_type ::& - & level%sm%sv, stat=info) - end select - else - allocate(mld_s_gs_solver_type :: level%sm%sv, stat=info) - endif - if (allocated(level%sm%sv)) then - call level%sm%sv%default() - end if - - else - write(0,*) 'Calling set_solver without a smoother?' - info = -5 - end if - - case (mld_ilu_n_,mld_milu_n_,mld_ilu_t_) - if (allocated(level%sm)) then - if (allocated(level%sm%sv)) then - select type (sv => level%sm%sv) - class is (mld_s_ilu_solver_type) - ! do nothing - class default - call level%sm%sv%free(info) - if (info == 0) deallocate(level%sm%sv) - if (info == 0) allocate(mld_s_ilu_solver_type ::& - & level%sm%sv, stat=info) - end select - else - allocate(mld_s_ilu_solver_type :: level%sm%sv, stat=info) - endif - if (allocated(level%sm)) then - if (allocated(level%sm%sv)) & - & call level%sm%sv%default() - end if - call level%sm%sv%set(mld_sub_solve_,val,info) - else - write(0,*) 'Calling set_solver without a smoother?' - info = -5 - end if -#ifdef HAVE_SLU_ - case (mld_slu_) - if (allocated(level%sm)) then - if (allocated(level%sm%sv)) then - select type (sv => level%sm%sv) - class is (mld_s_slu_solver_type) - ! do nothing - class default - call level%sm%sv%free(info) - if (info == 0) deallocate(level%sm%sv) - if (info == 0) allocate(mld_s_slu_solver_type ::& - & level%sm%sv, stat=info) - end select - else - allocate(mld_s_slu_solver_type :: level%sm%sv, stat=info) - endif - if (allocated(level%sm)) then - if (allocated(level%sm%sv)) & - & call level%sm%sv%default() - end if - else - write(0,*) 'Calling set_solver without a smoother?' - info = -5 - end if -#endif -#ifdef HAVE_MUMPS_ - case (mld_mumps_) - if (allocated(level%sm%sv)) then - select type (sv => level%sm%sv) - class is (mld_s_mumps_solver_type) - ! do nothing - class default - call level%sm%sv%free(info) - if (info == 0) deallocate(level%sm%sv) - if (info == 0) allocate(mld_s_mumps_solver_type ::& - & level%sm%sv, stat=info) - end select - else - allocate(mld_s_mumps_solver_type :: level%sm%sv, stat=info) - endif - if (allocated(level%sm)) then - if (allocated(level%sm%sv)) then - call level%sm%sv%default() - end if - end if -#endif - case default - ! - ! Do nothing and hope for the best :) - ! - end select - - end subroutine onelev_set_solver - - end subroutine mld_sprecseti -subroutine mld_sprecsetsm(p,val,info,ilev) +subroutine mld_sprecsetsm(p,val,info,ilev,pos) use psb_base_mod use mld_s_prec_mod, mld_protect_name => mld_sprecsetsm @@ -623,6 +322,7 @@ subroutine mld_sprecsetsm(p,val,info,ilev) class(mld_s_base_smoother_type), intent(in) :: val integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), optional, intent(in) :: ilev + character(len=*), optional, intent(in) :: pos ! Local variables integer(psb_ipk_) :: ilev_, nlev_, ilmin, ilmax @@ -658,23 +358,13 @@ subroutine mld_sprecsetsm(p,val,info,ilev) do ilev_ = ilmin, ilmax - if (allocated(p%precv(ilev_)%sm)) then - if (allocated(p%precv(ilev_)%sm%sv)) then - deallocate(p%precv(ilev_)%sm%sv) - endif - deallocate(p%precv(ilev_)%sm) - end if -#ifdef HAVE_MOLD - allocate(p%precv(ilev_)%sm,mold=val) -#else - allocate(p%precv(ilev_)%sm,source=val) -#endif - call p%precv(ilev_)%sm%default() + call p%precv(ilev_)%set(val,info,pos=pos) + if (info /= 0) return end do end subroutine mld_sprecsetsm -subroutine mld_sprecsetsv(p,val,info,ilev) +subroutine mld_sprecsetsv(p,val,info,ilev,pos) use psb_base_mod use mld_s_prec_mod, mld_protect_name => mld_sprecsetsv @@ -686,6 +376,7 @@ subroutine mld_sprecsetsv(p,val,info,ilev) class(mld_s_base_solver_type), intent(in) :: val integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), optional, intent(in) :: ilev + character(len=*), optional, intent(in) :: pos ! Local variables integer(psb_ipk_) :: ilev_, nlev_, ilmin, ilmax @@ -720,43 +411,11 @@ subroutine mld_sprecsetsv(p,val,info,ilev) return endif - do ilev_ = ilmin, ilmax - if (allocated(p%precv(ilev_)%sm)) then - if (allocated(p%precv(ilev_)%sm%sv)) then - if (.not.same_type_as(p%precv(ilev_)%sm%sv,val)) then - deallocate(p%precv(ilev_)%sm%sv,stat=info) - if (info /= 0) then - info = 3111 - return - end if - end if - if (.not.allocated(p%precv(ilev_)%sm%sv)) then -#ifdef HAVE_MOLD - allocate(p%precv(ilev_)%sm%sv,mold=val,stat=info) -#else - allocate(p%precv(ilev_)%sm%sv,source=val,stat=info) -#endif - if (info /= 0) then - info = 3111 - return - end if - end if - end if - call p%precv(ilev_)%sm%sv%default() - else - info = 3111 - write(psb_err_unit,*) name,& - &': Error: uninitialized preconditioner component,',& - &' should call MLD_PRECINIT/MLD_PRECSET' - return - - end if - + call p%precv(ilev_)%set(val,info,pos=pos) + if (info /= 0) return end do - - end subroutine mld_sprecsetsv ! @@ -798,7 +457,7 @@ end subroutine mld_sprecsetsv ! For this reason, the interface mld_precset to this routine has been built in ! such a way that ilev is not visible to the user (see mld_prec_mod.f90). ! -subroutine mld_sprecsetc(p,what,string,info,ilev) +subroutine mld_sprecsetc(p,what,string,info,ilev,pos) use psb_base_mod use mld_s_prec_mod, mld_protect_name => mld_sprecsetc @@ -811,6 +470,7 @@ subroutine mld_sprecsetc(p,what,string,info,ilev) character(len=*), intent(in) :: string integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), optional, intent(in) :: ilev + character(len=*), optional, intent(in) :: pos ! Local variables integer(psb_ipk_) :: ilev_, nlev_,val @@ -838,7 +498,7 @@ subroutine mld_sprecsetc(p,what,string,info,ilev) endif val = mld_stringval(string) - if (val >=0) call p%set(what,val,info,ilev=ilev) + if (val >=0) call p%set(what,val,info,ilev=ilev,pos=pos) end subroutine mld_sprecsetc @@ -882,7 +542,7 @@ end subroutine mld_sprecsetc ! For this reason, the interface mld_precset to this routine has been built in ! such a way that ilev is not visible to the user (see mld_prec_mod.f90). ! -subroutine mld_sprecsetr(p,what,val,info,ilev) +subroutine mld_sprecsetr(p,what,val,info,ilev,pos) use psb_base_mod use mld_s_prec_mod, mld_protect_name => mld_sprecsetr @@ -895,6 +555,7 @@ subroutine mld_sprecsetr(p,what,val,info,ilev) real(psb_spk_), intent(in) :: val integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), optional, intent(in) :: ilev + character(len=*), optional, intent(in) :: pos ! Local variables integer(psb_ipk_) :: ilev_,nlev_ @@ -931,7 +592,7 @@ subroutine mld_sprecsetr(p,what,val,info,ilev) ! if (present(ilev)) then - call p%precv(ilev_)%set(what,val,info) + call p%precv(ilev_)%set(what,val,info,pos=pos) else if (.not.present(ilev)) then ! @@ -941,19 +602,19 @@ subroutine mld_sprecsetr(p,what,val,info,ilev) select case(what) case(mld_coarse_iluthrs_) ilev_=nlev_ - call p%precv(ilev_)%set(mld_sub_iluthrs_,val,info) + call p%precv(ilev_)%set(mld_sub_iluthrs_,val,info,pos=pos) case(mld_aggr_thresh_) thr = val do ilev_ = 2, nlev_ - call p%precv(ilev_)%set(mld_aggr_thresh_,thr,info) + call p%precv(ilev_)%set(mld_aggr_thresh_,thr,info,pos=pos) thr = thr * p%precv(ilev_)%parms%aggr_scale end do case default do ilev_=1,nlev_ - call p%precv(ilev_)%set(what,val,info) + call p%precv(ilev_)%set(what,val,info,pos=pos) end do end select diff --git a/mlprec/impl/mld_zcprecset.F90 b/mlprec/impl/mld_zcprecset.F90 index c75b80ce..e73b0d86 100644 --- a/mlprec/impl/mld_zcprecset.F90 +++ b/mlprec/impl/mld_zcprecset.F90 @@ -76,7 +76,7 @@ ! For this reason, the interface mld_precset to this routine has been built in ! such a way that ilev is not visible to the user (see mld_prec_mod.f90). ! -subroutine mld_zcprecseti(p,what,val,info,ilev) +subroutine mld_zcprecseti(p,what,val,info,ilev,pos) use psb_base_mod use mld_z_prec_mod, mld_protect_name => mld_zcprecseti @@ -108,6 +108,7 @@ subroutine mld_zcprecseti(p,what,val,info,ilev) integer(psb_ipk_), intent(in) :: val integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), optional, intent(in) :: ilev + character(len=*), optional, intent(in) :: pos ! Local variables integer(psb_ipk_) :: ilev_, nlev_ @@ -150,38 +151,20 @@ subroutine mld_zcprecseti(p,what,val,info,ilev) ! ! Rules for fine level are slightly different. ! - select case(psb_toupper(trim(what))) - case('SMOOTHER_TYPE') - call onelev_set_smoother(p%precv(ilev_),val,info) - case('SUB_SOLVE') - call onelev_set_solver(p%precv(ilev_),val,info) - case('SMOOTHER_SWEEPS','ML_TYPE','AGGR_ALG','AGGR_ORD',& - & 'AGGR_KIND','SMOOTHER_POS','AGGR_OMEGA_ALG',& - & 'AGGR_EIG','SMOOTHER_SWEEPS_PRE',& - & 'SMOOTHER_SWEEPS_POST',& - & 'SUB_RESTR','SUB_PROL', & - & 'SUB_REN','SUB_OVR','SUB_FILLIN') - call p%precv(ilev_)%set(what,val,info) - - case default - call p%precv(ilev_)%set(what,val,info) - end select + call p%precv(ilev_)%set(what,val,info,pos=pos) else if (ilev_ > 1) then select case(psb_toupper(what)) - case('SMOOTHER_TYPE') - call onelev_set_smoother(p%precv(ilev_),val,info) - case('SUB_SOLVE') - call onelev_set_solver(p%precv(ilev_),val,info) - case('SMOOTHER_SWEEPS','ML_TYPE','AGGR_ALG','AGGR_ORD',& + case('SMOOTHER_TYPE','SUB_SOLVE','SMOOTHER_SWEEPS',& + & 'ML_TYPE','AGGR_ALG','AGGR_ORD',& & 'AGGR_KIND','SMOOTHER_POS','AGGR_OMEGA_ALG',& & 'AGGR_EIG','SMOOTHER_SWEEPS_PRE',& & 'SMOOTHER_SWEEPS_POST',& & 'SUB_RESTR','SUB_PROL', & & 'SUB_REN','SUB_OVR','SUB_FILLIN',& & 'COARSE_MAT') - call p%precv(ilev_)%set(what,val,info) + call p%precv(ilev_)%set(what,val,info,pos=pos) case('COARSE_SUBSOLVE') if (ilev_ /= nlev_) then @@ -190,7 +173,7 @@ subroutine mld_zcprecseti(p,what,val,info,ilev) info = -2 return end if - call onelev_set_solver(p%precv(ilev_),val,info) + call p%precv(ilev_)%set('SUB_SOLVE',val,info,pos=pos) case('COARSE_SOLVE') if (ilev_ /= nlev_) then write(psb_err_unit,*) name,& @@ -198,40 +181,36 @@ subroutine mld_zcprecseti(p,what,val,info,ilev) info = -2 return end if - + if (nlev_ > 1) then - call p%precv(nlev_)%set('COARSE_SOLVE',val,info) + call p%precv(nlev_)%set('COARSE_SOLVE',val,info,pos=pos) select case (val) case(mld_bjac_) - call onelev_set_smoother(p%precv(nlev_),val,info) + call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos) #if defined(HAVE_UMF_) - call onelev_set_solver(p%precv(nlev_),mld_umf_,info) -#elif defined(HAVE_SLU_) - call onelev_set_solver(p%precv(nlev_),mld_slu_,info) + call p%precv(nlev_)%set('SUB_SOLVE',mld_umf_,info,pos=pos) +#elif defined(HAVE_SLU_) + call p%precv(nlev_)%set('SUB_SOLVE',mld_slu_,info,pos=pos) #elif defined(HAVE_MUMPS_) - call onelev_set_solver(p%precv(nlev_),mld_mumps_,info) -#else - call onelev_set_solver(p%precv(nlev_),mld_ilu_n_,info) + call p%precv(nlev_)%set('SUB_SOLVE',mld_mumps_,info,pos=pos) +#else + call p%precv(nlev_)%set('SUB_SOLVE',mld_ilu_n_,info,pos=pos) #endif call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info) case(mld_umf_, mld_slu_,mld_ilu_n_, mld_ilu_t_,mld_milu_n_) - call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info) - call onelev_set_solver(p%precv(nlev_),val,info) - call p%precv(nlev_)%set('COARSE_MAT',mld_repl_mat_,info) - case(mld_sludist_) - call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info) - call onelev_set_solver(p%precv(nlev_),val,info) - call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info) - case(mld_mumps_) - call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info) - call onelev_set_solver(p%precv(nlev_),val,info) - call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info) + call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos) + call p%precv(nlev_)%set('SUB_SOLVE',val,info,pos=pos) + call p%precv(nlev_)%set('COARSE_MAT',mld_repl_mat_,info,pos=pos) + case(mld_sludist_,mld_mumps_) + call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos) + call p%precv(nlev_)%set('SUB_SOLVE',val,info,pos=pos) + call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos) case(mld_jac_) - call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info) - call onelev_set_solver(p%precv(nlev_),mld_diag_scale_,info) - call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info) + call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos) + call p%precv(nlev_)%set('SUB_SOLVE',mld_diag_scale_,info,pos=pos) + call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos) end select - + endif case('COARSE_SWEEPS') if (ilev_ /= nlev_) then @@ -240,7 +219,7 @@ subroutine mld_zcprecseti(p,what,val,info,ilev) info = -2 return end if - call p%precv(nlev_)%set('SMOOTHER_SWEEPS',val,info) + call p%precv(nlev_)%set('SMOOTHER_SWEEPS',val,info,pos=pos) case('COARSE_FILLIN') if (ilev_ /= nlev_) then @@ -249,9 +228,10 @@ subroutine mld_zcprecseti(p,what,val,info,ilev) info = -2 return end if - call p%precv(nlev_)%set('SUB_FILLIN',val,info) + call p%precv(nlev_)%set('SUB_FILLIN',val,info,pos=pos) + case default - call p%precv(ilev_)%set(what,val,info) + call p%precv(ilev_)%set(what,val,info,pos=pos) end select endif @@ -262,33 +242,12 @@ subroutine mld_zcprecseti(p,what,val,info,ilev) ! levels ! select case(psb_toupper(trim(what))) - case('SUB_SOLVE') + case('SUB_SOLVE','SUB_RESTR','SUB_PROL',& + & 'SUB_REN','SUB_OVR','SUB_FILLIN',& + & 'SMOOTHER_SWEEPS','SMOOTHER_TYPE') do ilev_=1,max(1,nlev_-1) - if (.not.allocated(p%precv(ilev_)%sm)) then - write(psb_err_unit,*) name,& - & ': Error: uninitialized preconditioner component,',& - & ' should call MLD_PRECINIT' - info = -1 - return - endif - call onelev_set_solver(p%precv(ilev_),val,info) - - end do - - case('SUB_RESTR','SUB_PROL',& - & 'SUB_REN','SUB_OVR','SUB_FILLIN') - do ilev_=1,max(1,nlev_-1) - call p%precv(ilev_)%set(what,val,info) - end do - - case('SMOOTHER_SWEEPS') - do ilev_=1,max(1,nlev_-1) - call p%precv(ilev_)%set(what,val,info) - end do - - case('SMOOTHER_TYPE') - do ilev_=1,max(1,nlev_-1) - call onelev_set_smoother(p%precv(ilev_),val,info) + call p%precv(ilev_)%set(what,val,info,pos=pos) + if (info /= 0) return end do case('ML_TYPE','AGGR_ALG','AGGR_ORD','AGGR_KIND',& @@ -296,386 +255,70 @@ subroutine mld_zcprecseti(p,what,val,info,ilev) & 'SMOOTHER_POS','AGGR_OMEGA_ALG',& & 'AGGR_EIG','AGGR_FILTER') do ilev_=1,nlev_ - call p%precv(ilev_)%set(what,val,info) + call p%precv(ilev_)%set(what,val,info,pos=pos) + if (info /= 0) return end do case('COARSE_MAT') if (nlev_ > 1) then - call p%precv(nlev_)%set('COARSE_MAT',val,info) + call p%precv(nlev_)%set('COARSE_MAT',val,info,pos=pos) end if case('COARSE_SOLVE') if (nlev_ > 1) then - - call p%precv(nlev_)%set('COARSE_SOLVE',val,info) + call p%precv(nlev_)%set('COARSE_SOLVE',val,info,pos=pos) select case (val) case(mld_bjac_) - call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info) + call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos) #if defined(HAVE_UMF_) - call onelev_set_solver(p%precv(nlev_),mld_umf_,info) -#elif defined(HAVE_SLU_) - call onelev_set_solver(p%precv(nlev_),mld_slu_,info) -#elif defined(HAVE_MUMPS_) - call onelev_set_solver(p%precv(nlev_),mld_mumps_,info) -#else - call onelev_set_solver(p%precv(nlev_),mld_ilu_n_,info) + call p%precv(nlev_)%set('SUB_SOLVE',mld_umf_,info,pos=pos) +#elif defined(HAVE_SLU_) + call p%precv(nlev_)%set('SUB_SOLVE',mld_slu_,info,pos=pos) +#elif defined(HAVE_MUMPS_) + call p%precv(nlev_)%set('SUB_SOLVE',mld_mumps_,info,pos=pos) +#else + call p%precv(nlev_)%set('SUB_SOLVE',mld_ilu_n_,info,pos=pos) #endif call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info) case(mld_umf_, mld_slu_,mld_ilu_n_, mld_ilu_t_,mld_milu_n_) - call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info) - call onelev_set_solver(p%precv(nlev_),val,info) - call p%precv(nlev_)%set('COARSE_MAT',mld_repl_mat_,info) - case(mld_sludist_) - call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info) - call onelev_set_solver(p%precv(nlev_),val,info) - call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info) - case(mld_mumps_) - call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info) - call onelev_set_solver(p%precv(nlev_),val,info) - call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info) + call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos) + call p%precv(nlev_)%set('SUB_SOLVE',val,info,pos=pos) + call p%precv(nlev_)%set('COARSE_MAT',mld_repl_mat_,info,pos=pos) + case(mld_sludist_,mld_mumps_) + call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos) + call p%precv(nlev_)%set('SUB_SOLVE',val,info,pos=pos) + call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos) case(mld_jac_) - call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info) - call onelev_set_solver(p%precv(nlev_),mld_diag_scale_,info) - call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info) + call p%precv(nlev_)%set('SMOOTHER_TYPE',mld_bjac_,info,pos=pos) + call p%precv(nlev_)%set('SUB_SOLVE',mld_diag_scale_,info,pos=pos) + call p%precv(nlev_)%set('COARSE_MAT',mld_distr_mat_,info,pos=pos) end select - endif case('COARSE_SUBSOLVE') if (nlev_ > 1) then - call onelev_set_solver(p%precv(nlev_),val,info) + call p%precv(nlev_)%set('SUB_SOLVE',val,info,pos=pos) endif case('COARSE_SWEEPS') if (nlev_ > 1) then - call p%precv(nlev_)%set('SMOOTHER_SWEEPS',val,info) + call p%precv(nlev_)%set('SMOOTHER_SWEEPS',val,info,pos=pos) end if case('COARSE_FILLIN') if (nlev_ > 1) then - call p%precv(nlev_)%set('SUB_FILLIN',val,info) + call p%precv(nlev_)%set('SUB_FILLIN',val,info,pos=pos) end if + case default do ilev_=1,nlev_ - call p%precv(ilev_)%set(what,val,info) + call p%precv(ilev_)%set(what,val,info,pos=pos) end do end select endif -contains - - subroutine onelev_set_smoother(level,val,info) - type(mld_z_onelev_type), intent(inout) :: level - integer(psb_ipk_), intent(in) :: val - integer(psb_ipk_), intent(out) :: info - info = psb_success_ - - ! - ! This here requires a bit more attention. - ! - select case (val) - case (mld_noprec_) - if (allocated(level%sm)) then - select type (sm => level%sm) - type is (mld_z_base_smoother_type) - ! do nothing - class default - call level%sm%free(info) - if (info == 0) deallocate(level%sm) - if (info == 0) allocate(mld_z_base_smoother_type ::& - & level%sm, stat=info) - if (info == 0) allocate(mld_z_id_solver_type ::& - & level%sm%sv, stat=info) - end select - else - allocate(mld_z_base_smoother_type ::& - & level%sm, stat=info) - if (info ==0) allocate(mld_z_id_solver_type ::& - & level%sm%sv, stat=info) - endif - - case (mld_jac_) - if (allocated(level%sm)) then - select type (sm => level%sm) - class is (mld_z_jac_smoother_type) - ! do nothing - class default - call level%sm%free(info) - if (info == 0) deallocate(level%sm) - if (info == 0) allocate(mld_z_jac_smoother_type :: & - & level%sm, stat=info) - if (info == 0) allocate(mld_z_diag_solver_type :: & - & level%sm%sv, stat=info) - end select - else - allocate(mld_z_jac_smoother_type :: level%sm, stat=info) - if (info == 0) allocate(mld_z_diag_solver_type ::& - & level%sm%sv, stat=info) - endif - - case (mld_bjac_) - if (allocated(level%sm)) then - select type (sm => level%sm) - class is (mld_z_jac_smoother_type) - ! do nothing - class default - call level%sm%free(info) - if (info == 0) deallocate(level%sm) - if (info == 0) allocate(mld_z_jac_smoother_type ::& - & level%sm, stat=info) - if (info == 0) allocate(mld_z_ilu_solver_type ::& - & level%sm%sv, stat=info) - end select - else - allocate(mld_z_jac_smoother_type :: level%sm, stat=info) - if (info == 0) allocate(mld_z_ilu_solver_type ::& - & level%sm%sv, stat=info) - endif - - case (mld_as_) - if (allocated(level%sm)) then - select type (sm => level%sm) - class is (mld_z_as_smoother_type) - ! do nothing - class default - call level%sm%free(info) - if (info == 0) deallocate(level%sm) - if (info == 0) allocate(mld_z_as_smoother_type ::& - & level%sm, stat=info) - if (info == 0) allocate(mld_z_ilu_solver_type ::& - & level%sm%sv, stat=info) - end select - else - allocate(mld_z_as_smoother_type :: level%sm, stat=info) - if (info == 0) allocate(mld_z_ilu_solver_type ::& - & level%sm%sv, stat=info) - endif - - case default - ! - ! Do nothing and hope for the best :) - ! - end select - if (allocated(level%sm)) & - & call level%sm%default() - - end subroutine onelev_set_smoother - - subroutine onelev_set_solver(level,val,info) - type(mld_z_onelev_type), intent(inout) :: level - integer(psb_ipk_), intent(in) :: val - integer(psb_ipk_), intent(out) :: info - info = psb_success_ - - ! - ! This here requires a bit more attention. - ! - select case (val) - case (mld_f_none_) - if (allocated(level%sm)) then - if (allocated(level%sm%sv)) then - select type (sv => level%sm%sv) - class is (mld_z_id_solver_type) - ! do nothing - class default - call level%sm%sv%free(info) - if (info == 0) deallocate(level%sm%sv) - if (info == 0) allocate(mld_z_id_solver_type ::& - & level%sm%sv, stat=info) - end select - else - allocate(mld_z_id_solver_type :: level%sm%sv, stat=info) - endif - if (allocated(level%sm)) then - if (allocated(level%sm%sv)) & - & call level%sm%sv%default() - end if - else - write(0,*) 'Calling set_solver without a smoother?' - info = -5 - end if - - case (mld_diag_scale_) - if (allocated(level%sm)) then - if (allocated(level%sm%sv)) then - select type (sv => level%sm%sv) - class is (mld_z_diag_solver_type) - ! do nothing - class default - call level%sm%sv%free(info) - if (info == 0) deallocate(level%sm%sv) - if (info == 0) allocate(mld_z_diag_solver_type ::& - & level%sm%sv, stat=info) - end select - else - allocate(mld_z_diag_solver_type :: level%sm%sv, stat=info) - endif - if (allocated(level%sm)) then - if (allocated(level%sm%sv)) & - & call level%sm%sv%default() - end if - else - write(0,*) 'Calling set_solver without a smoother?' - info = -5 - end if - - case (mld_gs_) - if (allocated(level%sm)) then - if (allocated(level%sm%sv)) then - select type (sv => level%sm%sv) - class is (mld_z_gs_solver_type) - ! do nothing - class default - call level%sm%sv%free(info) - if (info == 0) deallocate(level%sm%sv) - if (info == 0) allocate(mld_z_gs_solver_type ::& - & level%sm%sv, stat=info) - end select - else - allocate(mld_z_gs_solver_type :: level%sm%sv, stat=info) - endif - if (allocated(level%sm%sv)) then - call level%sm%sv%default() - else - endif - - else - write(0,*) 'Calling set_solver without a smoother?' - info = -5 - end if - - case (mld_ilu_n_,mld_milu_n_,mld_ilu_t_) - if (allocated(level%sm)) then - if (allocated(level%sm%sv)) then - select type (sv => level%sm%sv) - class is (mld_z_ilu_solver_type) - ! do nothing - class default - call level%sm%sv%free(info) - if (info == 0) deallocate(level%sm%sv) - if (info == 0) allocate(mld_z_ilu_solver_type ::& - & level%sm%sv, stat=info) - end select - else - allocate(mld_z_ilu_solver_type :: level%sm%sv, stat=info) - endif - if (allocated(level%sm)) then - if (allocated(level%sm%sv)) & - & call level%sm%sv%default() - end if - call level%sm%sv%set('SUB_SOLVE',val,info) - else - write(0,*) 'Calling set_solver without a smoother?' - info = -5 - end if - -#ifdef HAVE_SLU_ - case (mld_slu_) - if (allocated(level%sm)) then - if (allocated(level%sm%sv)) then - select type (sv => level%sm%sv) - class is (mld_z_slu_solver_type) - ! do nothing - class default - call level%sm%sv%free(info) - if (info == 0) deallocate(level%sm%sv) - if (info == 0) allocate(mld_z_slu_solver_type ::& - & level%sm%sv, stat=info) - end select - else - allocate(mld_z_slu_solver_type :: level%sm%sv, stat=info) - endif - if (allocated(level%sm)) then - if (allocated(level%sm%sv)) & - & call level%sm%sv%default() - end if - else - write(0,*) 'Calling set_solver without a smoother?' - info = -5 - end if -#endif -#ifdef HAVE_MUMPS_ - case (mld_mumps_) - if (allocated(level%sm%sv)) then - select type (sv => level%sm%sv) - class is (mld_z_mumps_solver_type) - ! do nothing - class default - call level%sm%sv%free(info) - if (info == 0) deallocate(level%sm%sv) - if (info == 0) allocate(mld_z_mumps_solver_type ::& - & level%sm%sv, stat=info) - end select - else - allocate(mld_z_mumps_solver_type :: level%sm%sv, stat=info) - endif - if (allocated(level%sm)) then - if (allocated(level%sm%sv)) & - & call level%sm%sv%default() - end if -#endif - -#ifdef HAVE_UMF_ - case (mld_umf_) - if (allocated(level%sm)) then - if (allocated(level%sm%sv)) then - select type (sv => level%sm%sv) - class is (mld_z_umf_solver_type) - ! do nothing - class default - call level%sm%sv%free(info) - if (info == 0) deallocate(level%sm%sv) - if (info == 0) allocate(mld_z_umf_solver_type ::& - & level%sm%sv, stat=info) - end select - else - allocate(mld_z_umf_solver_type :: level%sm%sv, stat=info) - endif - if (allocated(level%sm)) then - if (allocated(level%sm%sv)) & - & call level%sm%sv%default() - end if - else - write(0,*) 'Calling set_solver without a smoother?' - info = -5 - end if -#endif -#ifdef HAVE_SLUDIST_ - case (mld_sludist_) - if (allocated(level%sm)) then - if (allocated(level%sm%sv)) then - select type (sv => level%sm%sv) - class is (mld_z_sludist_solver_type) - ! do nothing - class default - call level%sm%sv%free(info) - if (info == 0) deallocate(level%sm%sv) - if (info == 0) allocate(mld_z_sludist_solver_type ::& - & level%sm%sv, stat=info) - end select - else - allocate(mld_z_sludist_solver_type :: level%sm%sv, stat=info) - endif - if (allocated(level%sm)) then - if (allocated(level%sm%sv)) & - & call level%sm%sv%default() - end if - else - write(0,*) 'Calling set_solver without a smoother?' - info = -5 - end if -#endif - case default - ! - ! Do nothing and hope for the best :) - ! - end select - - end subroutine onelev_set_solver - - end subroutine mld_zcprecseti ! @@ -717,7 +360,7 @@ end subroutine mld_zcprecseti ! For this reason, the interface mld_precset to this routine has been built in ! such a way that ilev is not visible to the user (see mld_prec_mod.f90). ! -subroutine mld_zcprecsetc(p,what,string,info,ilev) +subroutine mld_zcprecsetc(p,what,string,info,ilev,pos) use psb_base_mod use mld_z_prec_mod, mld_protect_name => mld_zcprecsetc @@ -730,6 +373,7 @@ subroutine mld_zcprecsetc(p,what,string,info,ilev) character(len=*), intent(in) :: string integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), optional, intent(in) :: ilev + character(len=*), optional, intent(in) :: pos ! Local variables integer(psb_ipk_) :: ilev_, nlev_,val @@ -758,9 +402,9 @@ subroutine mld_zcprecsetc(p,what,string,info,ilev) val = mld_stringval(string) if (val >=0) then - call p%set(what,val,info,ilev=ilev) + call p%set(what,val,info,ilev=ilev,pos=pos) else - call p%precv(ilev_)%set(what,string,info) + call p%precv(ilev_)%set(what,string,info,pos=pos) end if end subroutine mld_zcprecsetc @@ -804,7 +448,7 @@ end subroutine mld_zcprecsetc ! For this reason, the interface mld_precset to this routine has been built in ! such a way that ilev is not visible to the user (see mld_prec_mod.f90). ! -subroutine mld_zcprecsetr(p,what,val,info,ilev) +subroutine mld_zcprecsetr(p,what,val,info,ilev,pos) use psb_base_mod use mld_z_prec_mod, mld_protect_name => mld_zcprecsetr @@ -817,6 +461,7 @@ subroutine mld_zcprecsetr(p,what,val,info,ilev) real(psb_dpk_), intent(in) :: val integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), optional, intent(in) :: ilev + character(len=*), optional, intent(in) :: pos ! Local variables integer(psb_ipk_) :: ilev_,nlev_ @@ -853,7 +498,7 @@ subroutine mld_zcprecsetr(p,what,val,info,ilev) ! if (present(ilev)) then - call p%precv(ilev_)%set(what,val,info) + call p%precv(ilev_)%set(what,val,info,pos=pos) else if (.not.present(ilev)) then ! @@ -863,19 +508,19 @@ subroutine mld_zcprecsetr(p,what,val,info,ilev) select case(psb_toupper(what)) case('COARSE_ILUTHRS') ilev_=nlev_ - call p%precv(ilev_)%set('SUB_ILUTHRS',val,info) + call p%precv(ilev_)%set('SUB_ILUTHRS',val,info,pos=pos) case('AGGR_THRESH') thr = val do ilev_ = 2, nlev_ - call p%precv(ilev_)%set('AGGR_THRESH',thr,info) + call p%precv(ilev_)%set('AGGR_THRESH',thr,info,pos=pos) thr = thr * p%precv(ilev_)%parms%aggr_scale end do case default do ilev_=1,nlev_ - call p%precv(ilev_)%set(what,val,info) + call p%precv(ilev_)%set(what,val,info,pos=pos) end do end select diff --git a/mlprec/impl/mld_zmlprec_aply.f90 b/mlprec/impl/mld_zmlprec_aply.f90 index bda0e5a2..6a4a3d02 100644 --- a/mlprec/impl/mld_zmlprec_aply.f90 +++ b/mlprec/impl/mld_zmlprec_aply.f90 @@ -405,10 +405,10 @@ contains implicit none ! Arguments - integer(psb_ipk_) :: level - type(mld_zprec_type), intent(inout) :: p - type(mld_mlprec_wrk_type), intent(inout) :: mlprec_wrk(:) - character, intent(in) :: trans + integer(psb_ipk_) :: level + type(mld_zprec_type), target, intent(inout) :: p + type(mld_mlprec_wrk_type), intent(inout) :: mlprec_wrk(:) + character, intent(in) :: trans complex(psb_dpk_),target :: work(:) integer(psb_ipk_), intent(out) :: info @@ -434,7 +434,6 @@ contains ictxt = p%precv(level)%base_desc%get_context() call psb_info(ictxt, me, np) - if (level > 1) then nc2l = p%precv(level)%base_desc%get_local_cols() nr2l = p%precv(level)%base_desc%get_local_rows() @@ -539,7 +538,6 @@ contains end if ! This is one step of post-smoothing - if (level < nlev) then call inner_ml_aply(level+1,p,mlprec_wrk,trans,work,info) if (info /= psb_success_) then @@ -572,7 +570,7 @@ contains end if sweeps = p%precv(level)%parms%sweeps_post - call p%precv(level)%sm%apply(zone,& + call p%precv(level)%sm2%apply(zone,& & mlprec_wrk(level)%x2l,zone,mlprec_wrk(level)%y2l,& & p%precv(level)%base_desc, trans,& & sweeps,work,info) @@ -621,13 +619,17 @@ contains ! if (level < nlev) then sweeps = p%precv(level)%parms%sweeps_post + call p%precv(level)%sm2%apply(zone,& + & mlprec_wrk(level)%x2l,zzero,mlprec_wrk(level)%y2l,& + & p%precv(level)%base_desc, trans,& + & sweeps,work,info) else sweeps = p%precv(level)%parms%sweeps + call p%precv(level)%sm%apply(zone,& + & mlprec_wrk(level)%x2l,zzero,mlprec_wrk(level)%y2l,& + & p%precv(level)%base_desc, trans,& + & sweeps,work,info) end if - call p%precv(level)%sm%apply(zone,& - & mlprec_wrk(level)%x2l,zzero,mlprec_wrk(level)%y2l,& - & p%precv(level)%base_desc, trans,& - & sweeps,work,info) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& @@ -830,6 +832,13 @@ contains case(mld_twoside_smooth_) + ! CHECK + if (.not.(associated(p%precv(level)%sm2,p%precv(level)%sm2a))) then + write(0,*) 'inner_ml_aply: unassociated sm2 at level ',level + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Error during restriction') + goto 9999 + end if nc2l = p%precv(level)%base_desc%get_local_cols() nr2l = p%precv(level)%base_desc%get_local_rows() allocate(mlprec_wrk(level)%ty(nc2l), mlprec_wrk(level)%tx(nc2l), stat=info) @@ -866,10 +875,19 @@ contains else sweeps = p%precv(level)%parms%sweeps end if - if (info == psb_success_) call p%precv(level)%sm%apply(zone,& - & mlprec_wrk(level)%x2l,zzero,mlprec_wrk(level)%y2l,& - & p%precv(level)%base_desc, trans,& - & sweeps,work,info) + + if (trans == 'N') then + if (info == psb_success_) call p%precv(level)%sm%apply(zone,& + & mlprec_wrk(level)%x2l,zzero,mlprec_wrk(level)%y2l,& + & p%precv(level)%base_desc, trans,& + & sweeps,work,info) + else + if (info == psb_success_) call p%precv(level)%sm2%apply(zone,& + & mlprec_wrk(level)%x2l,zzero,mlprec_wrk(level)%y2l,& + & p%precv(level)%base_desc, trans,& + & sweeps,work,info) + end if + if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& & a_err='Error during smoother_apply') @@ -930,10 +948,18 @@ contains else sweeps = p%precv(level)%parms%sweeps_pre end if - if (info == psb_success_) call p%precv(level)%sm%apply(zone,& - & mlprec_wrk(level)%tx,zone,mlprec_wrk(level)%y2l,& - & p%precv(level)%base_desc, trans,& - & sweeps,work,info) + if (trans == 'N') then + if (info == psb_success_) call p%precv(level)%sm2%apply(zone,& + & mlprec_wrk(level)%tx,zone,mlprec_wrk(level)%y2l,& + & p%precv(level)%base_desc, trans,& + & sweeps,work,info) + else + if (info == psb_success_) call p%precv(level)%sm%apply(zone,& + & mlprec_wrk(level)%tx,zone,mlprec_wrk(level)%y2l,& + & p%precv(level)%base_desc, trans,& + & sweeps,work,info) + end if + if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& & a_err='Error during smoother_apply') @@ -1043,7 +1069,7 @@ subroutine mld_zmlprec_aply_vect(alpha,p,x,beta,y,desc_data,trans,work,info) level = 1 call psb_geaxpby(zone,x,zzero,mlprec_wrk(level)%vx2l,p%precv(level)%base_desc,info) - call mlprec_wrk(level)%vy2l%set(zzero) + call mlprec_wrk(level)%vy2l%zero() call inner_ml_aply(level,p,mlprec_wrk,trans_,work,info) @@ -1090,12 +1116,12 @@ contains implicit none ! Arguments - integer(psb_ipk_) :: level - type(mld_zprec_type), intent(inout) :: p - type(mld_mlprec_wrk_type), intent(inout) :: mlprec_wrk(:) - character, intent(in) :: trans - complex(psb_dpk_),target :: work(:) - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_) :: level + type(mld_zprec_type), target, intent(inout) :: p + type(mld_mlprec_wrk_type), intent(inout) :: mlprec_wrk(:) + character, intent(in) :: trans + complex(psb_dpk_),target :: work(:) + integer(psb_ipk_), intent(out) :: info ! Local variables integer(psb_ipk_) :: ictxt,np,me @@ -1122,7 +1148,9 @@ contains nc2l = p%precv(level)%base_desc%get_local_cols() nr2l = p%precv(level)%base_desc%get_local_rows() - + if(debug_level > 1) then + write(debug_unit,*) me,' inner_ml_aply at level ',level + end if select case(p%precv(level)%parms%ml_type) @@ -1160,7 +1188,7 @@ contains & sweeps,work,info) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during smoother_apply') + & a_err='Error during ADD smoother_apply') goto 9999 end if @@ -1250,25 +1278,25 @@ contains sweeps = p%precv(level)%parms%sweeps_post - call p%precv(level)%sm%apply(zone,& + call p%precv(level)%sm2%apply(zone,& & mlprec_wrk(level)%vx2l,zone,mlprec_wrk(level)%vy2l,& & p%precv(level)%base_desc, trans,& & sweeps,work,info) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during smoother_apply') + & a_err='Error during POST smoother_apply') goto 9999 end if else sweeps = p%precv(level)%parms%sweeps - call p%precv(level)%sm%apply(zone,& + call p%precv(level)%sm2%apply(zone,& & mlprec_wrk(level)%vx2l,zzero,mlprec_wrk(level)%vy2l,& & p%precv(level)%base_desc, trans,& & sweeps,work,info) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during smoother_apply') + & a_err='Error during POST smoother_apply') goto 9999 end if @@ -1302,13 +1330,13 @@ contains else sweeps = p%precv(level)%parms%sweeps end if - call p%precv(level)%sm%apply(zone,& + call p%precv(level)%sm2%apply(zone,& & mlprec_wrk(level)%vx2l,zzero,mlprec_wrk(level)%vy2l,& & p%precv(level)%base_desc, trans,& & sweeps,work,info) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during smoother_apply') + & a_err='Error during POST smoother_apply') goto 9999 end if @@ -1386,7 +1414,7 @@ contains & sweeps,work,info) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during smoother_apply') + & a_err='Error during PRE smoother_apply') goto 9999 end if @@ -1484,7 +1512,7 @@ contains & sweeps,work,info) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during smoother_apply') + & a_err='Error during PRE smoother_apply') goto 9999 end if else @@ -1530,19 +1558,28 @@ contains if (level < nlev) then if (trans == 'N') then sweeps = p%precv(level)%parms%sweeps_pre + if (info == psb_success_) call p%precv(level)%sm%apply(zone,& + & mlprec_wrk(level)%vx2l,zzero,mlprec_wrk(level)%vy2l,& + & p%precv(level)%base_desc, trans,& + & sweeps,work,info) else sweeps = p%precv(level)%parms%sweeps_post + if (info == psb_success_) call p%precv(level)%sm2%apply(zone,& + & mlprec_wrk(level)%vx2l,zzero,mlprec_wrk(level)%vy2l,& + & p%precv(level)%base_desc, trans,& + & sweeps,work,info) end if else sweeps = p%precv(level)%parms%sweeps + if (info == psb_success_) call p%precv(level)%sm%apply(zone,& + & mlprec_wrk(level)%vx2l,zzero,mlprec_wrk(level)%vy2l,& + & p%precv(level)%base_desc, trans,& + & sweeps,work,info) end if - if (info == psb_success_) call p%precv(level)%sm%apply(zone,& - & mlprec_wrk(level)%vx2l,zzero,mlprec_wrk(level)%vy2l,& - & p%precv(level)%base_desc, trans,& - & sweeps,work,info) + if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during smoother_apply') + & a_err='Error during 2-PRE smoother_apply') goto 9999 end if @@ -1602,16 +1639,21 @@ contains ! if (trans == 'N') then sweeps = p%precv(level)%parms%sweeps_post + if (info == psb_success_) call p%precv(level)%sm2%apply(zone,& + & mlprec_wrk(level)%vtx,zone,mlprec_wrk(level)%vy2l,& + & p%precv(level)%base_desc, trans,& + & sweeps,work,info) else sweeps = p%precv(level)%parms%sweeps_pre + if (info == psb_success_) call p%precv(level)%sm%apply(zone,& + & mlprec_wrk(level)%vtx,zone,mlprec_wrk(level)%vy2l,& + & p%precv(level)%base_desc, trans,& + & sweeps,work,info) end if - if (info == psb_success_) call p%precv(level)%sm%apply(zone,& - & mlprec_wrk(level)%vtx,zone,mlprec_wrk(level)%vy2l,& - & p%precv(level)%base_desc, trans,& - & sweeps,work,info) + if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during smoother_apply') + & a_err='Error during 2-POST smoother_apply') goto 9999 end if diff --git a/mlprec/impl/mld_zmlprec_bld.f90 b/mlprec/impl/mld_zmlprec_bld.f90 index e833bfa3..ceea7e57 100644 --- a/mlprec/impl/mld_zmlprec_bld.f90 +++ b/mlprec/impl/mld_zmlprec_bld.f90 @@ -495,10 +495,16 @@ subroutine mld_zmlprec_bld(a,desc_a,p,info,amold,vmold,imold) call p%precv(i)%sm%build(p%precv(i)%base_a,p%precv(i)%base_desc,& & 'F',info,amold=amold,vmold=vmold,imold=imold) - - if ((info == psb_success_).and.(i>1)) then - call p%precv(i)%cnv(info,amold=amold,vmold=vmold,imold=imold) + if (info == 0) then + if (allocated(p%precv(i)%sm2a)) then + call p%precv(i)%sm2a%build(a,desc_a,upd_,info,& + & amold=amold,vmold=vmold,imold=imold) + p%precv(i)%sm2 => p%precv(i)%sm2a + else + p%precv(i)%sm2 => p%precv(i)%sm + end if end if + if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& & a_err='One level preconditioner build.') diff --git a/mlprec/impl/mld_zprecset.F90 b/mlprec/impl/mld_zprecset.F90 index 7b46a90c..29aa699c 100644 --- a/mlprec/impl/mld_zprecset.F90 +++ b/mlprec/impl/mld_zprecset.F90 @@ -76,7 +76,7 @@ ! For this reason, the interface mld_precset to this routine has been built in ! such a way that ilev is not visible to the user (see mld_prec_mod.f90). ! -subroutine mld_zprecseti(p,what,val,info,ilev) +subroutine mld_zprecseti(p,what,val,info,ilev,pos) use psb_base_mod use mld_z_prec_mod, mld_protect_name => mld_zprecseti @@ -107,6 +107,7 @@ subroutine mld_zprecseti(p,what,val,info,ilev) integer(psb_ipk_), intent(in) :: val integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), optional, intent(in) :: ilev + character(len=*), optional, intent(in) :: pos ! Local variables integer(psb_ipk_) :: ilev_, nlev_ @@ -147,39 +148,21 @@ subroutine mld_zprecseti(p,what,val,info,ilev) if (present(ilev)) then if (ilev_ == 1) then - ! - ! Rules for fine level are slightly different. - ! - select case(what) - case(mld_smoother_type_) - call onelev_set_smoother(p%precv(ilev_),val,info) - case(mld_sub_solve_) - call onelev_set_solver(p%precv(ilev_),val,info) - case(mld_smoother_sweeps_,mld_ml_type_,mld_aggr_alg_,mld_aggr_ord_,& - & mld_aggr_kind_,mld_smoother_pos_,mld_aggr_omega_alg_,mld_aggr_eig_,& - & mld_smoother_sweeps_pre_,mld_smoother_sweeps_post_,& - & mld_sub_restr_,mld_sub_prol_, & - & mld_sub_ren_,mld_sub_ovr_,mld_sub_fillin_) - call p%precv(ilev_)%set(what,val,info) - case default - call p%precv(ilev_)%set(what,val,info) - end select + call p%precv(ilev_)%set(what,val,info,pos=pos) else if (ilev_ > 1) then select case(what) - case(mld_smoother_type_) - call onelev_set_smoother(p%precv(ilev_),val,info) - case(mld_sub_solve_) - call onelev_set_solver(p%precv(ilev_),val,info) - case(mld_smoother_sweeps_,mld_ml_type_,mld_aggr_alg_,mld_aggr_ord_,& - & mld_aggr_kind_,mld_smoother_pos_,mld_aggr_omega_alg_,mld_aggr_eig_,& + case(mld_smoother_type_,mld_sub_solve_,mld_smoother_sweeps_,& + & mld_ml_type_,mld_aggr_alg_,mld_aggr_ord_,& + & mld_aggr_kind_,mld_smoother_pos_,& + & mld_aggr_omega_alg_,mld_aggr_eig_,& & mld_smoother_sweeps_pre_,mld_smoother_sweeps_post_,& & mld_sub_restr_,mld_sub_prol_, & & mld_sub_ren_,mld_sub_ovr_,mld_sub_fillin_,& & mld_coarse_mat_) - call p%precv(ilev_)%set(what,val,info) + call p%precv(ilev_)%set(what,val,info,pos=pos) case(mld_coarse_subsolve_) if (ilev_ /= nlev_) then @@ -188,7 +171,7 @@ subroutine mld_zprecseti(p,what,val,info,ilev) info = -2 return end if - call onelev_set_solver(p%precv(ilev_),val,info) + call p%precv(ilev_)%set(mld_sub_solve_,val,info,pos=pos) case(mld_coarse_solve_) if (ilev_ /= nlev_) then write(psb_err_unit,*) name,& @@ -198,32 +181,32 @@ subroutine mld_zprecseti(p,what,val,info,ilev) end if if (nlev_ > 1) then - call p%precv(nlev_)%set(mld_coarse_solve_,val,info) + call p%precv(nlev_)%set(mld_coarse_solve_,val,info,pos=pos) select case (val) case(mld_bjac_) - call onelev_set_smoother(p%precv(nlev_),val,info) + call p%precv(nlev_)%set(mld_smoother_type_,val,info,pos=pos) #if defined(HAVE_UMF_) - call onelev_set_solver(p%precv(nlev_),mld_umf_,info) + call p%precv(nlev_)%set(mld_sub_solve_,mld_umf_,info,pos=pos) #elif defined(HAVE_SLU_) - call onelev_set_solver(p%precv(nlev_),mld_slu_,info) + call p%precv(nlev_)%set(mld_sub_solve_,mld_slu_,info,pos=pos) #elif defined(HAVE_MUMPS_) - call onelev_set_solver(p%precv(nlev_),mld_mumps_,info) + call p%precv(nlev_)%set(mld_sub_solve_,mld_mumps_,info,pos=pos) #else - call onelev_set_solver(p%precv(nlev_),mld_ilu_n_,info) + call p%precv(nlev_)%set(mld_sub_solve_,mld_ilu_n_,info,pos=pos) #endif - call p%precv(nlev_)%set(mld_coarse_mat_,mld_distr_mat_,info) + call p%precv(nlev_)%set(mld_coarse_mat_,mld_distr_mat_,info,pos=pos) case(mld_umf_, mld_slu_,mld_ilu_n_, mld_ilu_t_,mld_milu_n_) - call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info) - call onelev_set_solver(p%precv(nlev_),val,info) - call p%precv(nlev_)%set(mld_coarse_mat_,mld_repl_mat_,info) + call p%precv(nlev_)%set(mld_smoother_type_,mld_bjac_,info,pos=pos) + call p%precv(nlev_)%set(mld_sub_solve_,val,info,pos=pos) + call p%precv(nlev_)%set(mld_coarse_mat_,mld_repl_mat_,info,pos=pos) case(mld_sludist_,mld_mumps_) - call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info) - call onelev_set_solver(p%precv(nlev_),val,info) - call p%precv(nlev_)%set(mld_coarse_mat_,mld_distr_mat_,info) + call p%precv(nlev_)%set(mld_smoother_type_,mld_bjac_,info,pos=pos) + call p%precv(nlev_)%set(mld_sub_solve_,val,info,pos=pos) + call p%precv(nlev_)%set(mld_coarse_mat_,mld_distr_mat_,info,pos=pos) case(mld_jac_) - call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info) - call onelev_set_solver(p%precv(nlev_),mld_diag_scale_,info) - call p%precv(nlev_)%set(mld_coarse_mat_,mld_distr_mat_,info) + call p%precv(nlev_)%set(mld_smoother_type_,mld_bjac_,info,pos=pos) + call p%precv(nlev_)%set(mld_sub_solve_,mld_diag_scale_,info,pos=pos) + call p%precv(nlev_)%set(mld_coarse_mat_,mld_distr_mat_,info,pos=pos) end select endif @@ -234,7 +217,7 @@ subroutine mld_zprecseti(p,what,val,info,ilev) info = -2 return end if - call p%precv(nlev_)%set(mld_smoother_sweeps_,val,info) + call p%precv(nlev_)%set(mld_smoother_sweeps_,val,info,pos=pos) case(mld_coarse_fillin_) if (ilev_ /= nlev_) then @@ -243,9 +226,9 @@ subroutine mld_zprecseti(p,what,val,info,ilev) info = -2 return end if - call p%precv(nlev_)%set(mld_sub_fillin_,val,info) + call p%precv(nlev_)%set(mld_sub_fillin_,val,info,pos=pos) case default - call p%precv(ilev_)%set(what,val,info) + call p%precv(ilev_)%set(what,val,info,pos=pos) end select endif @@ -256,33 +239,12 @@ subroutine mld_zprecseti(p,what,val,info,ilev) ! levels ! select case(what) - case(mld_sub_solve_) + case(mld_sub_solve_,mld_sub_restr_,mld_sub_prol_,& + & mld_sub_ren_,mld_sub_ovr_,mld_sub_fillin_,& + & mld_smoother_sweeps_,mld_smoother_type_) do ilev_=1,max(1,nlev_-1) - if (.not.allocated(p%precv(ilev_)%sm)) then - write(psb_err_unit,*) name,& - & ': Error: uninitialized preconditioner component,',& - & ' should call MLD_PRECINIT' - info = -1 - return - endif - call onelev_set_solver(p%precv(ilev_),val,info) - - end do - - case(mld_sub_restr_,mld_sub_prol_,& - & mld_sub_ren_,mld_sub_ovr_,mld_sub_fillin_) - do ilev_=1,max(1,nlev_-1) - call p%precv(ilev_)%set(what,val,info) - end do - - case(mld_smoother_sweeps_) - do ilev_=1,max(1,nlev_-1) - call p%precv(ilev_)%set(what,val,info) - end do - - case(mld_smoother_type_) - do ilev_=1,max(1,nlev_-1) - call onelev_set_smoother(p%precv(ilev_),val,info) + call p%precv(ilev_)%set(what,val,info,pos=pos) + if (info /= 0) return end do case(mld_ml_type_,mld_aggr_alg_,mld_aggr_ord_,mld_aggr_kind_,& @@ -290,386 +252,75 @@ subroutine mld_zprecseti(p,what,val,info,ilev) & mld_smoother_pos_,mld_aggr_omega_alg_,& & mld_aggr_eig_,mld_aggr_filter_) do ilev_=1,nlev_ - call p%precv(ilev_)%set(what,val,info) + call p%precv(ilev_)%set(what,val,info,pos=pos) end do case(mld_coarse_mat_) if (nlev_ > 1) then - call p%precv(nlev_)%set(mld_coarse_mat_,val,info) + call p%precv(nlev_)%set(mld_coarse_mat_,val,info,pos=pos) end if case(mld_coarse_solve_) if (nlev_ > 1) then - call p%precv(nlev_)%set(mld_coarse_solve_,val,info) + call p%precv(nlev_)%set(mld_coarse_solve_,val,info,pos=pos) select case (val) case(mld_bjac_) - call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info) + call p%precv(nlev_)%set(mld_smoother_type_,mld_bjac_,info,pos=pos) #if defined(HAVE_UMF_) - call onelev_set_solver(p%precv(nlev_),mld_umf_,info) + call p%precv(nlev_)%set(mld_sub_solve_,mld_umf_,info,pos=pos) #elif defined(HAVE_SLU_) - call onelev_set_solver(p%precv(nlev_),mld_slu_,info) + call p%precv(nlev_)%set(mld_sub_solve_,mld_slu_,info,pos=pos) #else - call onelev_set_solver(p%precv(nlev_),mld_ilu_n_,info) + call p%precv(nlev_)%set(mld_sub_solve_,mld_ilu_n_,info,pos=pos) #endif - call p%precv(nlev_)%set(mld_coarse_mat_,mld_distr_mat_,info) + call p%precv(nlev_)%set(mld_coarse_mat_,mld_distr_mat_,info,pos=pos) case(mld_umf_, mld_slu_,mld_ilu_n_, mld_ilu_t_,mld_milu_n_) - call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info) - call onelev_set_solver(p%precv(nlev_),val,info) - call p%precv(nlev_)%set(mld_coarse_mat_,mld_repl_mat_,info) + call p%precv(nlev_)%set(mld_smoother_type_,mld_bjac_,info,pos=pos) + call p%precv(nlev_)%set(mld_sub_solve_,val,info,pos=pos) + call p%precv(nlev_)%set(mld_coarse_mat_,mld_repl_mat_,info,pos=pos) case(mld_sludist_) - call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info) - call onelev_set_solver(p%precv(nlev_),val,info) - call p%precv(nlev_)%set(mld_coarse_mat_,mld_distr_mat_,info) + call p%precv(nlev_)%set(mld_smoother_type_,mld_bjac_,info,pos=pos) + call p%precv(nlev_)%set(mld_sub_solve_,val,info,pos=pos) + call p%precv(nlev_)%set(mld_coarse_mat_,mld_distr_mat_,info,pos=pos) case(mld_mumps_) - call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info) - call onelev_set_solver(p%precv(nlev_),val,info) - call p%precv(nlev_)%set(mld_coarse_mat_,mld_distr_mat_,info) + call p%precv(nlev_)%set(mld_smoother_type_,mld_bjac_,info,pos=pos) + call p%precv(nlev_)%set(mld_sub_solve_,val,info,pos=pos) + call p%precv(nlev_)%set(mld_coarse_mat_,mld_distr_mat_,info,pos=pos) case(mld_jac_) - call onelev_set_smoother(p%precv(nlev_),mld_bjac_,info) - call onelev_set_solver(p%precv(nlev_),mld_diag_scale_,info) - call p%precv(nlev_)%set(mld_coarse_mat_,mld_distr_mat_,info) + call p%precv(nlev_)%set(mld_smoother_type_,mld_bjac_,info,pos=pos) + call p%precv(nlev_)%set(mld_sub_solve_,mld_diag_scale_,info,pos=pos) + call p%precv(nlev_)%set(mld_coarse_mat_,mld_distr_mat_,info,pos=pos) end select endif case(mld_coarse_subsolve_) if (nlev_ > 1) then - call onelev_set_solver(p%precv(nlev_),val,info) + call p%precv(nlev_)%set(mld_sub_solve_,val,info,pos=pos) endif case(mld_coarse_sweeps_) if (nlev_ > 1) then - call p%precv(nlev_)%set(mld_smoother_sweeps_,val,info) + call p%precv(nlev_)%set(mld_smoother_sweeps_,val,info,pos=pos) end if case(mld_coarse_fillin_) if (nlev_ > 1) then - call p%precv(nlev_)%set(mld_sub_fillin_,val,info) + call p%precv(nlev_)%set(mld_sub_fillin_,val,info,pos=pos) end if case default do ilev_=1,nlev_ - call p%precv(ilev_)%set(what,val,info) + call p%precv(ilev_)%set(what,val,info,pos=pos) end do end select endif -contains - - subroutine onelev_set_smoother(level,val,info) - type(mld_z_onelev_type), intent(inout) :: level - integer(psb_ipk_), intent(in) :: val - integer(psb_ipk_), intent(out) :: info - info = psb_success_ - - ! - ! This here requires a bit more attention. - ! - select case (val) - case (mld_noprec_) - if (allocated(level%sm)) then - select type (sm => level%sm) - type is (mld_z_base_smoother_type) - ! do nothing - class default - call level%sm%free(info) - if (info == 0) deallocate(level%sm) - if (info == 0) allocate(mld_z_base_smoother_type ::& - & level%sm, stat=info) - if (info == 0) allocate(mld_z_id_solver_type ::& - & level%sm%sv, stat=info) - end select - else - allocate(mld_z_base_smoother_type ::& - & level%sm, stat=info) - if (info ==0) allocate(mld_z_id_solver_type ::& - & level%sm%sv, stat=info) - endif - - case (mld_jac_) - if (allocated(level%sm)) then - select type (sm => level%sm) - class is (mld_z_jac_smoother_type) - ! do nothing - class default - call level%sm%free(info) - if (info == 0) deallocate(level%sm) - if (info == 0) allocate(mld_z_jac_smoother_type :: & - & level%sm, stat=info) - if (info == 0) allocate(mld_z_diag_solver_type :: & - & level%sm%sv, stat=info) - end select - else - allocate(mld_z_jac_smoother_type :: level%sm, stat=info) - if (info == 0) allocate(mld_z_diag_solver_type ::& - & level%sm%sv, stat=info) - endif - - case (mld_bjac_) - if (allocated(level%sm)) then - select type (sm => level%sm) - class is (mld_z_jac_smoother_type) - ! do nothing - class default - call level%sm%free(info) - if (info == 0) deallocate(level%sm) - if (info == 0) allocate(mld_z_jac_smoother_type ::& - & level%sm, stat=info) - if (info == 0) allocate(mld_z_ilu_solver_type ::& - & level%sm%sv, stat=info) - end select - else - allocate(mld_z_jac_smoother_type :: level%sm, stat=info) - if (info == 0) allocate(mld_z_ilu_solver_type ::& - & level%sm%sv, stat=info) - endif - - case (mld_as_) - if (allocated(level%sm)) then - select type (sm => level%sm) - class is (mld_z_as_smoother_type) - ! do nothing - class default - call level%sm%free(info) - if (info == 0) deallocate(level%sm) - if (info == 0) allocate(mld_z_as_smoother_type ::& - & level%sm, stat=info) - if (info == 0) allocate(mld_z_ilu_solver_type ::& - & level%sm%sv, stat=info) - end select - else - allocate(mld_z_as_smoother_type :: level%sm, stat=info) - if (info == 0) allocate(mld_z_ilu_solver_type ::& - & level%sm%sv, stat=info) - endif - - case default - ! - ! Do nothing and hope for the best :) - ! - end select - if (allocated(level%sm)) & - & call level%sm%default() - - end subroutine onelev_set_smoother - - subroutine onelev_set_solver(level,val,info) - type(mld_z_onelev_type), intent(inout) :: level - integer(psb_ipk_), intent(in) :: val - integer(psb_ipk_), intent(out) :: info - info = psb_success_ - - ! - ! This here requires a bit more attention. - ! - select case (val) - case (mld_f_none_) - if (allocated(level%sm)) then - if (allocated(level%sm%sv)) then - select type (sv => level%sm%sv) - class is (mld_z_id_solver_type) - ! do nothing - class default - call level%sm%sv%free(info) - if (info == 0) deallocate(level%sm%sv) - if (info == 0) allocate(mld_z_id_solver_type ::& - & level%sm%sv, stat=info) - end select - else - allocate(mld_z_id_solver_type :: level%sm%sv, stat=info) - endif - if (allocated(level%sm)) then - if (allocated(level%sm%sv)) & - & call level%sm%sv%default() - end if - else - write(0,*) 'Calling set_solver without a smoother?' - info = -5 - end if - - - case (mld_diag_scale_) - if (allocated(level%sm)) then - if (allocated(level%sm%sv)) then - select type (sv => level%sm%sv) - class is (mld_z_diag_solver_type) - ! do nothing - class default - call level%sm%sv%free(info) - if (info == 0) deallocate(level%sm%sv) - if (info == 0) allocate(mld_z_diag_solver_type ::& - & level%sm%sv, stat=info) - end select - else - allocate(mld_z_diag_solver_type :: level%sm%sv, stat=info) - endif - if (allocated(level%sm)) then - if (allocated(level%sm%sv)) & - & call level%sm%sv%default() - end if - else - write(0,*) 'Calling set_solver without a smoother?' - info = -5 - end if - - case (mld_gs_) - if (allocated(level%sm)) then - if (allocated(level%sm%sv)) then - select type (sv => level%sm%sv) - class is (mld_z_gs_solver_type) - ! do nothing - class default - call level%sm%sv%free(info) - if (info == 0) deallocate(level%sm%sv) - if (info == 0) allocate(mld_z_gs_solver_type ::& - & level%sm%sv, stat=info) - end select - else - allocate(mld_z_gs_solver_type :: level%sm%sv, stat=info) - endif - if (allocated(level%sm%sv)) then - call level%sm%sv%default() - end if - - else - write(0,*) 'Calling set_solver without a smoother?' - info = -5 - end if - - case (mld_ilu_n_,mld_milu_n_,mld_ilu_t_) - if (allocated(level%sm)) then - if (allocated(level%sm%sv)) then - select type (sv => level%sm%sv) - class is (mld_z_ilu_solver_type) - ! do nothing - class default - call level%sm%sv%free(info) - if (info == 0) deallocate(level%sm%sv) - if (info == 0) allocate(mld_z_ilu_solver_type ::& - & level%sm%sv, stat=info) - end select - else - allocate(mld_z_ilu_solver_type :: level%sm%sv, stat=info) - endif - if (allocated(level%sm)) then - if (allocated(level%sm%sv)) & - & call level%sm%sv%default() - end if - call level%sm%sv%set(mld_sub_solve_,val,info) - else - write(0,*) 'Calling set_solver without a smoother?' - info = -5 - end if -#ifdef HAVE_UMF_ - case (mld_umf_) - if (allocated(level%sm)) then - if (allocated(level%sm%sv)) then - select type (sv => level%sm%sv) - class is (mld_z_umf_solver_type) - ! do nothing - class default - call level%sm%sv%free(info) - if (info == 0) deallocate(level%sm%sv) - if (info == 0) allocate(mld_z_umf_solver_type ::& - & level%sm%sv, stat=info) - end select - else - allocate(mld_z_umf_solver_type :: level%sm%sv, stat=info) - endif - if (allocated(level%sm)) then - if (allocated(level%sm%sv)) & - & call level%sm%sv%default() - end if - else - write(0,*) 'Calling set_solver without a smoother?' - info = -5 - end if -#endif -#ifdef HAVE_SLUDIST_ - case (mld_sludist_) - if (allocated(level%sm)) then - if (allocated(level%sm%sv)) then - select type (sv => level%sm%sv) - class is (mld_z_sludist_solver_type) - ! do nothing - class default - call level%sm%sv%free(info) - if (info == 0) deallocate(level%sm%sv) - if (info == 0) allocate(mld_z_sludist_solver_type ::& - & level%sm%sv, stat=info) - end select - else - allocate(mld_z_sludist_solver_type :: level%sm%sv, stat=info) - endif - if (allocated(level%sm)) then - if (allocated(level%sm%sv)) & - & call level%sm%sv%default() - end if - else - write(0,*) 'Calling set_solver without a smoother?' - info = -5 - end if -#endif -#ifdef HAVE_SLU_ - case (mld_slu_) - if (allocated(level%sm)) then - if (allocated(level%sm%sv)) then - select type (sv => level%sm%sv) - class is (mld_z_slu_solver_type) - ! do nothing - class default - call level%sm%sv%free(info) - if (info == 0) deallocate(level%sm%sv) - if (info == 0) allocate(mld_z_slu_solver_type ::& - & level%sm%sv, stat=info) - end select - else - allocate(mld_z_slu_solver_type :: level%sm%sv, stat=info) - endif - if (allocated(level%sm)) then - if (allocated(level%sm%sv)) & - & call level%sm%sv%default() - end if - else - write(0,*) 'Calling set_solver without a smoother?' - info = -5 - end if -#endif -#ifdef HAVE_MUMPS_ - case (mld_mumps_) - if (allocated(level%sm%sv)) then - select type (sv => level%sm%sv) - class is (mld_z_mumps_solver_type) - ! do nothing - class default - call level%sm%sv%free(info) - if (info == 0) deallocate(level%sm%sv) - if (info == 0) allocate(mld_z_mumps_solver_type ::& - & level%sm%sv, stat=info) - end select - else - allocate(mld_z_mumps_solver_type :: level%sm%sv, stat=info) - endif - if (allocated(level%sm)) then - if (allocated(level%sm%sv)) then - call level%sm%sv%default() - end if - end if -#endif - case default - ! - ! Do nothing and hope for the best :) - ! - end select - - end subroutine onelev_set_solver - - end subroutine mld_zprecseti -subroutine mld_zprecsetsm(p,val,info,ilev) +subroutine mld_zprecsetsm(p,val,info,ilev,pos) use psb_base_mod use mld_z_prec_mod, mld_protect_name => mld_zprecsetsm @@ -681,6 +332,7 @@ subroutine mld_zprecsetsm(p,val,info,ilev) class(mld_z_base_smoother_type), intent(in) :: val integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), optional, intent(in) :: ilev + character(len=*), optional, intent(in) :: pos ! Local variables integer(psb_ipk_) :: ilev_, nlev_, ilmin, ilmax @@ -716,23 +368,13 @@ subroutine mld_zprecsetsm(p,val,info,ilev) do ilev_ = ilmin, ilmax - if (allocated(p%precv(ilev_)%sm)) then - if (allocated(p%precv(ilev_)%sm%sv)) then - deallocate(p%precv(ilev_)%sm%sv) - endif - deallocate(p%precv(ilev_)%sm) - end if -#ifdef HAVE_MOLD - allocate(p%precv(ilev_)%sm,mold=val) -#else - allocate(p%precv(ilev_)%sm,source=val) -#endif - call p%precv(ilev_)%sm%default() + call p%precv(ilev_)%set(val,info,pos=pos) + if (info /= 0) return end do end subroutine mld_zprecsetsm -subroutine mld_zprecsetsv(p,val,info,ilev) +subroutine mld_zprecsetsv(p,val,info,ilev,pos) use psb_base_mod use mld_z_prec_mod, mld_protect_name => mld_zprecsetsv @@ -744,6 +386,7 @@ subroutine mld_zprecsetsv(p,val,info,ilev) class(mld_z_base_solver_type), intent(in) :: val integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), optional, intent(in) :: ilev + character(len=*), optional, intent(in) :: pos ! Local variables integer(psb_ipk_) :: ilev_, nlev_, ilmin, ilmax @@ -778,43 +421,11 @@ subroutine mld_zprecsetsv(p,val,info,ilev) return endif - do ilev_ = ilmin, ilmax - if (allocated(p%precv(ilev_)%sm)) then - if (allocated(p%precv(ilev_)%sm%sv)) then - if (.not.same_type_as(p%precv(ilev_)%sm%sv,val)) then - deallocate(p%precv(ilev_)%sm%sv,stat=info) - if (info /= 0) then - info = 3111 - return - end if - end if - if (.not.allocated(p%precv(ilev_)%sm%sv)) then -#ifdef HAVE_MOLD - allocate(p%precv(ilev_)%sm%sv,mold=val,stat=info) -#else - allocate(p%precv(ilev_)%sm%sv,source=val,stat=info) -#endif - if (info /= 0) then - info = 3111 - return - end if - end if - end if - call p%precv(ilev_)%sm%sv%default() - else - info = 3111 - write(psb_err_unit,*) name,& - &': Error: uninitialized preconditioner component,',& - &' should call MLD_PRECINIT/MLD_PRECSET' - return - - end if - + call p%precv(ilev_)%set(val,info,pos=pos) + if (info /= 0) return end do - - end subroutine mld_zprecsetsv ! @@ -856,7 +467,7 @@ end subroutine mld_zprecsetsv ! For this reason, the interface mld_precset to this routine has been built in ! such a way that ilev is not visible to the user (see mld_prec_mod.f90). ! -subroutine mld_zprecsetc(p,what,string,info,ilev) +subroutine mld_zprecsetc(p,what,string,info,ilev,pos) use psb_base_mod use mld_z_prec_mod, mld_protect_name => mld_zprecsetc @@ -869,6 +480,7 @@ subroutine mld_zprecsetc(p,what,string,info,ilev) character(len=*), intent(in) :: string integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), optional, intent(in) :: ilev + character(len=*), optional, intent(in) :: pos ! Local variables integer(psb_ipk_) :: ilev_, nlev_,val @@ -896,7 +508,7 @@ subroutine mld_zprecsetc(p,what,string,info,ilev) endif val = mld_stringval(string) - if (val >=0) call p%set(what,val,info,ilev=ilev) + if (val >=0) call p%set(what,val,info,ilev=ilev,pos=pos) end subroutine mld_zprecsetc @@ -940,7 +552,7 @@ end subroutine mld_zprecsetc ! For this reason, the interface mld_precset to this routine has been built in ! such a way that ilev is not visible to the user (see mld_prec_mod.f90). ! -subroutine mld_zprecsetr(p,what,val,info,ilev) +subroutine mld_zprecsetr(p,what,val,info,ilev,pos) use psb_base_mod use mld_z_prec_mod, mld_protect_name => mld_zprecsetr @@ -953,6 +565,7 @@ subroutine mld_zprecsetr(p,what,val,info,ilev) real(psb_dpk_), intent(in) :: val integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), optional, intent(in) :: ilev + character(len=*), optional, intent(in) :: pos ! Local variables integer(psb_ipk_) :: ilev_,nlev_ @@ -989,7 +602,7 @@ subroutine mld_zprecsetr(p,what,val,info,ilev) ! if (present(ilev)) then - call p%precv(ilev_)%set(what,val,info) + call p%precv(ilev_)%set(what,val,info,pos=pos) else if (.not.present(ilev)) then ! @@ -999,19 +612,19 @@ subroutine mld_zprecsetr(p,what,val,info,ilev) select case(what) case(mld_coarse_iluthrs_) ilev_=nlev_ - call p%precv(ilev_)%set(mld_sub_iluthrs_,val,info) + call p%precv(ilev_)%set(mld_sub_iluthrs_,val,info,pos=pos) case(mld_aggr_thresh_) thr = val do ilev_ = 2, nlev_ - call p%precv(ilev_)%set(mld_aggr_thresh_,thr,info) + call p%precv(ilev_)%set(mld_aggr_thresh_,thr,info,pos=pos) thr = thr * p%precv(ilev_)%parms%aggr_scale end do case default do ilev_=1,nlev_ - call p%precv(ilev_)%set(what,val,info) + call p%precv(ilev_)%set(what,val,info,pos=pos) end do end select diff --git a/mlprec/impl/solver/Makefile b/mlprec/impl/solver/Makefile index 4fb01f25..d8040aa6 100644 --- a/mlprec/impl/solver/Makefile +++ b/mlprec/impl/solver/Makefile @@ -34,6 +34,9 @@ mld_c_gs_solver_cnv.o \ mld_c_gs_solver_dmp.o \ mld_c_gs_solver_apply.o \ mld_c_gs_solver_apply_vect.o \ +mld_c_bwgs_solver_bld.o \ +mld_c_bwgs_solver_apply.o \ +mld_c_bwgs_solver_apply_vect.o \ mld_c_id_solver_apply.o \ mld_c_id_solver_apply_vect.o \ mld_c_id_solver_clone.o \ @@ -113,6 +116,9 @@ mld_s_gs_solver_cnv.o \ mld_s_gs_solver_dmp.o \ mld_s_gs_solver_apply.o \ mld_s_gs_solver_apply_vect.o \ +mld_s_bwgs_solver_bld.o \ +mld_s_bwgs_solver_apply.o \ +mld_s_bwgs_solver_apply_vect.o \ mld_s_id_solver_apply.o \ mld_s_id_solver_apply_vect.o \ mld_s_id_solver_clone.o \ @@ -151,6 +157,9 @@ mld_z_gs_solver_cnv.o \ mld_z_gs_solver_dmp.o \ mld_z_gs_solver_apply.o \ mld_z_gs_solver_apply_vect.o \ +mld_z_bwgs_solver_bld.o \ +mld_z_bwgs_solver_apply.o \ +mld_z_bwgs_solver_apply_vect.o \ mld_z_id_solver_apply.o \ mld_z_id_solver_apply_vect.o \ mld_z_id_solver_clone.o \ diff --git a/mlprec/impl/solver/mld_c_bwgs_solver_apply.f90 b/mlprec/impl/solver/mld_c_bwgs_solver_apply.f90 new file mode 100644 index 00000000..ab47f90f --- /dev/null +++ b/mlprec/impl/solver/mld_c_bwgs_solver_apply.f90 @@ -0,0 +1,196 @@ +!!$ +!!$ +!!$ MLD2P4 version 2.0 +!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package +!!$ based on PSBLAS (Parallel Sparse BLAS version 3.3) +!!$ +!!$ (C) Copyright 2008, 2010, 2012, 2015 +!!$ +!!$ 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. +!!$ +!!$ +subroutine mld_c_bwgs_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info) + + use psb_base_mod + use mld_c_gs_solver, mld_protect_name => mld_c_bwgs_solver_apply + implicit none + type(psb_desc_type), intent(in) :: desc_data + class(mld_c_bwgs_solver_type), intent(inout) :: sv + complex(psb_spk_),intent(inout) :: x(:) + complex(psb_spk_),intent(inout) :: y(:) + complex(psb_spk_),intent(in) :: alpha,beta + character(len=1),intent(in) :: trans + complex(psb_spk_),target, intent(inout) :: work(:) + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: n_row,n_col, itx + complex(psb_spk_), pointer :: ww(:), aux(:), tx(:),ty(:) + complex(psb_spk_), allocatable :: temp(:),wv(:),xit(:) + integer(psb_ipk_) :: ictxt,np,me,i, err_act + character :: trans_ + character(len=20) :: name='d_bwgs_solver_apply' + + call psb_erractionsave(err_act) + ictxt = desc_data%get_ctxt() + call psb_info(ictxt,me,np) + info = psb_success_ + + trans_ = psb_toupper(trans) + select case(trans_) + case('N') +!!$ case('T') +!!$ case('C') + case default + call psb_errpush(psb_err_iarg_invalid_i_,name) + goto 9999 + end select + + n_row = desc_data%get_local_rows() + n_col = desc_data%get_local_cols() + + if (n_col <= size(work)) then + ww => work(1:n_col) + if ((4*n_col+n_col) <= size(work)) then + aux => work(n_col+1:) + else + allocate(aux(4*n_col),stat=info) + if (info /= psb_success_) then + info=psb_err_alloc_request_ + call psb_errpush(info,name,& + & i_err=(/4*n_col,izero,izero,izero,izero/),& + & a_err='complex(psb_spk_)') + goto 9999 + end if + endif + else + allocate(ww(n_col),aux(4*n_col),stat=info) + if (info /= psb_success_) then + info=psb_err_alloc_request_ + call psb_errpush(info,name,& + & i_err=(/5*n_col,izero,izero,izero,izero/),& + & a_err='complex(psb_spk_)') + goto 9999 + end if + endif + + if (info /= psb_success_) then + info=psb_err_alloc_request_ + call psb_errpush(info,name,& + & i_err=(/5*n_col,izero,izero,izero,izero/),& + & a_err='complex(psb_spk_)') + goto 9999 + end if + + call psb_geasb(wv,desc_data,info) + call psb_geasb(xit,desc_data,info) + + select case(trans_) + case('N') + if (sv%eps <=szero) then + ! + ! Fixed number of iterations + ! + ! + ! WARNING: this is not completely satisfactory. We are assuming here Y + ! as the initial guess, but this is only working if we are called from the + ! current JAC smoother loop. A good solution would be to have a separate + ! input argument as the initial guess + ! +!!$ write(0,*) 'GS Iteration with ',sv%sweeps + call psb_geaxpby(cone,y,czero,xit,desc_data,info) + do itx=1,sv%sweeps + call psb_geaxpby(cone,x,czero,wv,desc_data,info) + ! Update with L. The off-diagonal block is taken care + ! from the Jacobi smoother, hence this is purely local. + call psb_spmm(-cone,sv%l,xit,cone,wv,desc_data,info,doswap=.false.) + call psb_spsm(cone,sv%u,wv,czero,xit,desc_data,info) +!!$ temp = xit%get_vect() +!!$ write(0,*) me,'GS Iteration ',itx,':',temp(1:n_row) + end do + + call psb_geaxpby(alpha,xit,beta,y,desc_data,info) + + else + ! + ! Iterations to convergence, not implemented right now. + ! + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='EPS>0 not implemented in GS subsolve') + goto 9999 + + end if +!!$ case('T') +!!$ call psb_spsm(cone,sv%u,x,czero,wv,desc_data,info,& +!!$ & trans=trans_,scale='L',diag=sv%dv,choice=psb_none_,work=aux) +!!$ if (info == psb_success_) call psb_spsm(alpha,sv%l,wv,beta,y,desc_data,info,& +!!$ & trans=trans_,scale='U',choice=psb_none_,work=aux) +!!$ +!!$ case('C') +!!$ +!!$ call psb_spsm(cone,sv%u,x,czero,wv,desc_data,info,& +!!$ & trans=trans_,scale='U',choice=psb_none_,work=aux) +!!$ +!!$ call wv1%mlt(cone,sv%dv,wv,czero,info,conjgx=trans_) +!!$ +!!$ if (info == psb_success_) call psb_spsm(alpha,sv%l,wv1,beta,y,desc_data,info,& +!!$ & trans=trans_,scale='U',choice=psb_none_,work=aux) + + case default + info = psb_err_internal_error_ + call psb_errpush(info,name,& + & a_err='Invalid TRANS in GS subsolve') + goto 9999 + end select + + + if (info /= psb_success_) then + + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Error in subsolve') + goto 9999 + endif + + if (n_col <= size(work)) then + if ((4*n_col+n_col) <= size(work)) then + else + deallocate(aux) + endif + else + deallocate(ww,aux) + endif + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine mld_c_bwgs_solver_apply diff --git a/mlprec/impl/solver/mld_c_bwgs_solver_apply_vect.f90 b/mlprec/impl/solver/mld_c_bwgs_solver_apply_vect.f90 new file mode 100644 index 00000000..101eb073 --- /dev/null +++ b/mlprec/impl/solver/mld_c_bwgs_solver_apply_vect.f90 @@ -0,0 +1,200 @@ +!!$ +!!$ +!!$ MLD2P4 version 2.0 +!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package +!!$ based on PSBLAS (Parallel Sparse BLAS version 3.3) +!!$ +!!$ (C) Copyright 2008, 2010, 2012, 2015 +!!$ +!!$ 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. +!!$ +!!$ +subroutine mld_c_bwgs_solver_apply_vect(alpha,sv,x,beta,y,desc_data,trans,work,info) + + use psb_base_mod + use mld_c_gs_solver, mld_protect_name => mld_c_bwgs_solver_apply_vect + implicit none + type(psb_desc_type), intent(in) :: desc_data + class(mld_c_bwgs_solver_type), intent(inout) :: sv + type(psb_c_vect_type),intent(inout) :: x + type(psb_c_vect_type),intent(inout) :: y + complex(psb_spk_),intent(in) :: alpha,beta + character(len=1),intent(in) :: trans + complex(psb_spk_),target, intent(inout) :: work(:) + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: n_row,n_col, itx + type(psb_c_vect_type) :: wv, xit + complex(psb_spk_), pointer :: ww(:), aux(:), tx(:),ty(:) + complex(psb_spk_), allocatable :: temp(:) + integer(psb_ipk_) :: ictxt,np,me,i, err_act + character :: trans_ + character(len=20) :: name='d_bwgs_solver_apply' + + call psb_erractionsave(err_act) + ictxt = desc_data%get_ctxt() + call psb_info(ictxt,me,np) + info = psb_success_ + + trans_ = psb_toupper(trans) + select case(trans_) + case('N') +!!$ case('T') +!!$ case('C') + case default + call psb_errpush(psb_err_iarg_invalid_i_,name) + goto 9999 + end select + + n_row = desc_data%get_local_rows() + n_col = desc_data%get_local_cols() + + + if (x%get_nrows() < n_row) then + info = 36 + call psb_errpush(info,name,& + & i_err=(/itwo,n_row,izero,izero,izero/)) + goto 9999 + end if + if (y%get_nrows() < n_row) then + info = 36 + call psb_errpush(info,name,& + & i_err=(/ithree,n_row,izero,izero,izero/)) + goto 9999 + end if + + + + if (n_col <= size(work)) then + ww => work(1:n_col) + if ((4*n_col+n_col) <= size(work)) then + aux => work(n_col+1:) + else + allocate(aux(4*n_col),stat=info) + endif + else + allocate(ww(n_col),aux(4*n_col),stat=info) + endif + + if (info /= psb_success_) then + info=psb_err_alloc_request_ + call psb_errpush(info,name,& + & i_err=(/5*n_col,izero,izero,izero,izero/),& + & a_err='complex(psb_spk_)') + goto 9999 + end if + + call psb_geasb(wv,desc_data,info,mold=x%v,scratch=.true.) + call psb_geasb(xit,desc_data,info,mold=x%v,scratch=.true.) + + select case(trans_) + case('N') + if (sv%eps <=szero) then + ! + ! Fixed number of iterations + ! + ! + ! WARNING: this is not completely satisfactory. We are assuming here Y + ! as the initial guess, but this is only working if we are called from the + ! current JAC smoother loop. A good solution would be to have a separate + ! input argument as the initial guess + ! +!!$ write(0,*) 'GS Iteration with ',sv%sweeps + call psb_geaxpby(cone,y,czero,xit,desc_data,info) + do itx=1,sv%sweeps + call psb_geaxpby(cone,x,czero,wv,desc_data,info) + ! Update with L. The off-diagonal block is taken care + ! from the Jacobi smoother, hence this is purely local. + call psb_spmm(-cone,sv%l,xit,cone,wv,desc_data,info,doswap=.false.) + call psb_spsm(cone,sv%u,wv,czero,xit,desc_data,info) +!!$ temp = xit%get_vect() +!!$ write(0,*) me,'GS Iteration ',itx,':',temp(1:n_row) + end do + + call psb_geaxpby(alpha,xit,beta,y,desc_data,info) + + else + ! + ! Iterations to convergence, not implemented right now. + ! + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='EPS>0 not implemented in GS subsolve') + goto 9999 + + end if +!!$ case('T') +!!$ call psb_spsm(cone,sv%u,x,czero,wv,desc_data,info,& +!!$ & trans=trans_,scale='L',diag=sv%dv,choice=psb_none_,work=aux) +!!$ if (info == psb_success_) call psb_spsm(alpha,sv%l,wv,beta,y,desc_data,info,& +!!$ & trans=trans_,scale='U',choice=psb_none_,work=aux) +!!$ +!!$ case('C') +!!$ +!!$ call psb_spsm(cone,sv%u,x,czero,wv,desc_data,info,& +!!$ & trans=trans_,scale='U',choice=psb_none_,work=aux) +!!$ +!!$ call wv1%mlt(cone,sv%dv,wv,czero,info,conjgx=trans_) +!!$ +!!$ if (info == psb_success_) call psb_spsm(alpha,sv%l,wv1,beta,y,desc_data,info,& +!!$ & trans=trans_,scale='U',choice=psb_none_,work=aux) + + case default + info = psb_err_internal_error_ + call psb_errpush(info,name,& + & a_err='Invalid TRANS in GS subsolve') + goto 9999 + end select + + + if (info /= psb_success_) then + + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Error in subsolve') + goto 9999 + endif + call wv%free(info) + call xit%free(info) + if (n_col <= size(work)) then + if ((4*n_col+n_col) <= size(work)) then + else + deallocate(aux) + endif + else + deallocate(ww,aux) + endif + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine mld_c_bwgs_solver_apply_vect diff --git a/mlprec/impl/solver/mld_c_bwgs_solver_bld.f90 b/mlprec/impl/solver/mld_c_bwgs_solver_bld.f90 new file mode 100644 index 00000000..daa62031 --- /dev/null +++ b/mlprec/impl/solver/mld_c_bwgs_solver_bld.f90 @@ -0,0 +1,117 @@ +!!$ +!!$ +!!$ MLD2P4 version 2.0 +!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package +!!$ based on PSBLAS (Parallel Sparse BLAS version 3.3) +!!$ +!!$ (C) Copyright 2008, 2010, 2012, 2015 +!!$ +!!$ 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. +!!$ +!!$ +subroutine mld_c_bwgs_solver_bld(a,desc_a,sv,upd,info,b,amold,vmold,imold) + + use psb_base_mod + use mld_c_gs_solver, mld_protect_name => mld_c_bwgs_solver_bld + + Implicit None + + ! Arguments + type(psb_cspmat_type), intent(in), target :: a + Type(psb_desc_type), Intent(in) :: desc_a + class(mld_c_bwgs_solver_type), intent(inout) :: sv + character, intent(in) :: upd + integer(psb_ipk_), intent(out) :: info + type(psb_cspmat_type), intent(in), target, optional :: b + class(psb_c_base_sparse_mat), intent(in), optional :: amold + class(psb_c_base_vect_type), intent(in), optional :: vmold + class(psb_i_base_vect_type), intent(in), optional :: imold + ! Local variables + integer(psb_ipk_) :: n_row,n_col, nrow_a, nztota + integer(psb_ipk_) :: ictxt,np,me,i, err_act, debug_unit, debug_level + character(len=20) :: name='d_bwgs_solver_bld', ch_err + + 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() + call psb_info(ictxt, me, np) + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),' start' + + + n_row = desc_a%get_local_rows() + + if (psb_toupper(upd) == 'F') then + nrow_a = a%get_nrows() + nztota = a%get_nzeros() +!!$ if (present(b)) then +!!$ nztota = nztota + b%get_nzeros() +!!$ end if + if (sv%eps <= dzero) then + ! + ! This cuts out the off-diagonal part, because it's supposed to + ! be handled by the outer Jacobi smoother. + ! + call a%tril(sv%l,info,diag=-1) + call a%triu(sv%u,info,jmax=nrow_a) + + else + + info = psb_err_missing_override_method_ + call psb_errpush(info,name) + goto 9999 + end if + + + + call sv%l%set_asb() + call sv%l%trim() + call sv%u%set_asb() + call sv%u%trim() + + if (present(amold)) then + call sv%l%cscnv(info,mold=amold) + call sv%u%cscnv(info,mold=amold) + end if + + end if + + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),' end' + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return +end subroutine mld_c_bwgs_solver_bld diff --git a/mlprec/impl/solver/mld_d_mumps_solver_apply.F90 b/mlprec/impl/solver/mld_d_mumps_solver_apply.F90 index 38666ea0..3393fbbc 100644 --- a/mlprec/impl/solver/mld_d_mumps_solver_apply.F90 +++ b/mlprec/impl/solver/mld_d_mumps_solver_apply.F90 @@ -58,10 +58,9 @@ subroutine d_mumps_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info) character :: trans_ character(len=20) :: name='d_mumps_solver_apply' -#if defined(HAVE_MUMPS_) - call psb_erractionsave(err_act) +#if defined(HAVE_MUMPS_) info = psb_success_ trans_ = psb_toupper(trans) select case(trans_) @@ -106,13 +105,13 @@ subroutine d_mumps_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info) goto 9999 end select - sv%id%rhs => gx - sv%id%nrhs = 1 - sv%id%icntl(1) = -1 - sv%id%icntl(2) = -1 - sv%id%icntl(3) = -1 - sv%id%icntl(4) = -1 - sv%id%job = 3 + sv%id%rhs => gx + sv%id%nrhs = 1 + sv%id%icntl(1)=-1 + sv%id%icntl(2)=-1 + sv%id%icntl(3)=-1 + sv%id%icntl(4)=-1 + sv%id%job = 3 call dmumps(sv%id) call psb_scatter(gx, ww, desc_data, info, root=0) diff --git a/mlprec/impl/solver/mld_d_mumps_solver_apply_vect.F90 b/mlprec/impl/solver/mld_d_mumps_solver_apply_vect.F90 index c3462dd3..801066bb 100644 --- a/mlprec/impl/solver/mld_d_mumps_solver_apply_vect.F90 +++ b/mlprec/impl/solver/mld_d_mumps_solver_apply_vect.F90 @@ -79,5 +79,6 @@ #else write(psb_err_unit,*) "MUMPS Not Configured, fix make.inc and recompile " #endif + end subroutine d_mumps_solver_apply_vect diff --git a/mlprec/impl/solver/mld_d_mumps_solver_bld.F90 b/mlprec/impl/solver/mld_d_mumps_solver_bld.F90 index dbf3c190..36b36883 100644 --- a/mlprec/impl/solver/mld_d_mumps_solver_bld.F90 +++ b/mlprec/impl/solver/mld_d_mumps_solver_bld.F90 @@ -106,8 +106,8 @@ if (psb_toupper(upd) == 'F') then sv%id%comm = icomm - sv%id%job = -1 - sv%id%par = 1 + sv%id%job = -1 + sv%id%par=1 call dmumps(sv%id) !WARNING: CALLING dMUMPS WITH JOB=-1 DESTROY THE SETTING OF DEFAULT:TO FIX sv%id%icntl(3)=sv%ipar(2) @@ -115,7 +115,7 @@ if (sv%ipar(1) < 0) then nglobrec=desc_a%get_local_rows() call a%csclip(c,info,jmax=a%get_nrows()) - call c%mv_to(acoo) + call c%cp_to(acoo) nglob = c%get_nrows() if (nglobrec /= nglob) then write(*,*)'WARNING: MUMPS solver does not allow overlap in AS yet. A zero-overlap is used instead' @@ -130,10 +130,9 @@ call psb_loc_to_glob(acoo%ja(1:nztota), desc_a, info, iact='I') call psb_loc_to_glob(acoo%ia(1:nztota), desc_a, info, iact='I') end if - - sv%id%irn_loc => acoo%ia - sv%id%jcn_loc => acoo%ja - sv%id%a_loc => acoo%val + sv%id%irn_loc=> acoo%ia + sv%id%jcn_loc=> acoo%ja + sv%id%a_loc=> acoo%val sv%id%icntl(18)=3 if(acoo%is_upper() .or. acoo%is_lower()) then sv%id%sym = 2 @@ -144,7 +143,7 @@ ! there should be a better way for this sv%id%nz_loc = acoo%get_nzeros() sv%id%nz = acoo%get_nzeros() - sv%id%job = 4 + sv%id%job = 4 call psb_barrier(ictxt) write(*,*)'calling mumps N,nz,nz_loc',sv%id%n,sv%id%nz,sv%id%nz_loc call dmumps(sv%id) @@ -183,7 +182,6 @@ return end if return - #else write(psb_err_unit,*) "MUMPS Not Configured, fix make.inc and recompile " #endif diff --git a/mlprec/impl/solver/mld_s_bwgs_solver_apply.f90 b/mlprec/impl/solver/mld_s_bwgs_solver_apply.f90 new file mode 100644 index 00000000..1be17289 --- /dev/null +++ b/mlprec/impl/solver/mld_s_bwgs_solver_apply.f90 @@ -0,0 +1,196 @@ +!!$ +!!$ +!!$ MLD2P4 version 2.0 +!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package +!!$ based on PSBLAS (Parallel Sparse BLAS version 3.3) +!!$ +!!$ (C) Copyright 2008, 2010, 2012, 2015 +!!$ +!!$ 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. +!!$ +!!$ +subroutine mld_s_bwgs_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info) + + use psb_base_mod + use mld_s_gs_solver, mld_protect_name => mld_s_bwgs_solver_apply + implicit none + type(psb_desc_type), intent(in) :: desc_data + class(mld_s_bwgs_solver_type), intent(inout) :: sv + real(psb_spk_),intent(inout) :: x(:) + real(psb_spk_),intent(inout) :: y(:) + real(psb_spk_),intent(in) :: alpha,beta + character(len=1),intent(in) :: trans + real(psb_spk_),target, intent(inout) :: work(:) + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: n_row,n_col, itx + real(psb_spk_), pointer :: ww(:), aux(:), tx(:),ty(:) + real(psb_spk_), allocatable :: temp(:),wv(:),xit(:) + integer(psb_ipk_) :: ictxt,np,me,i, err_act + character :: trans_ + character(len=20) :: name='d_bwgs_solver_apply' + + call psb_erractionsave(err_act) + ictxt = desc_data%get_ctxt() + call psb_info(ictxt,me,np) + info = psb_success_ + + trans_ = psb_toupper(trans) + select case(trans_) + case('N') +!!$ case('T') +!!$ case('C') + case default + call psb_errpush(psb_err_iarg_invalid_i_,name) + goto 9999 + end select + + n_row = desc_data%get_local_rows() + n_col = desc_data%get_local_cols() + + if (n_col <= size(work)) then + ww => work(1:n_col) + if ((4*n_col+n_col) <= size(work)) then + aux => work(n_col+1:) + else + allocate(aux(4*n_col),stat=info) + if (info /= psb_success_) then + info=psb_err_alloc_request_ + call psb_errpush(info,name,& + & i_err=(/4*n_col,izero,izero,izero,izero/),& + & a_err='real(psb_spk_)') + goto 9999 + end if + endif + else + allocate(ww(n_col),aux(4*n_col),stat=info) + if (info /= psb_success_) then + info=psb_err_alloc_request_ + call psb_errpush(info,name,& + & i_err=(/5*n_col,izero,izero,izero,izero/),& + & a_err='real(psb_spk_)') + goto 9999 + end if + endif + + if (info /= psb_success_) then + info=psb_err_alloc_request_ + call psb_errpush(info,name,& + & i_err=(/5*n_col,izero,izero,izero,izero/),& + & a_err='real(psb_spk_)') + goto 9999 + end if + + call psb_geasb(wv,desc_data,info) + call psb_geasb(xit,desc_data,info) + + select case(trans_) + case('N') + if (sv%eps <=szero) then + ! + ! Fixed number of iterations + ! + ! + ! WARNING: this is not completely satisfactory. We are assuming here Y + ! as the initial guess, but this is only working if we are called from the + ! current JAC smoother loop. A good solution would be to have a separate + ! input argument as the initial guess + ! +!!$ write(0,*) 'GS Iteration with ',sv%sweeps + call psb_geaxpby(sone,y,szero,xit,desc_data,info) + do itx=1,sv%sweeps + call psb_geaxpby(sone,x,szero,wv,desc_data,info) + ! Update with L. The off-diagonal block is taken care + ! from the Jacobi smoother, hence this is purely local. + call psb_spmm(-sone,sv%l,xit,sone,wv,desc_data,info,doswap=.false.) + call psb_spsm(sone,sv%u,wv,szero,xit,desc_data,info) +!!$ temp = xit%get_vect() +!!$ write(0,*) me,'GS Iteration ',itx,':',temp(1:n_row) + end do + + call psb_geaxpby(alpha,xit,beta,y,desc_data,info) + + else + ! + ! Iterations to convergence, not implemented right now. + ! + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='EPS>0 not implemented in GS subsolve') + goto 9999 + + end if +!!$ case('T') +!!$ call psb_spsm(sone,sv%u,x,szero,wv,desc_data,info,& +!!$ & trans=trans_,scale='L',diag=sv%dv,choice=psb_none_,work=aux) +!!$ if (info == psb_success_) call psb_spsm(alpha,sv%l,wv,beta,y,desc_data,info,& +!!$ & trans=trans_,scale='U',choice=psb_none_,work=aux) +!!$ +!!$ case('C') +!!$ +!!$ call psb_spsm(sone,sv%u,x,szero,wv,desc_data,info,& +!!$ & trans=trans_,scale='U',choice=psb_none_,work=aux) +!!$ +!!$ call wv1%mlt(sone,sv%dv,wv,szero,info,conjgx=trans_) +!!$ +!!$ if (info == psb_success_) call psb_spsm(alpha,sv%l,wv1,beta,y,desc_data,info,& +!!$ & trans=trans_,scale='U',choice=psb_none_,work=aux) + + case default + info = psb_err_internal_error_ + call psb_errpush(info,name,& + & a_err='Invalid TRANS in GS subsolve') + goto 9999 + end select + + + if (info /= psb_success_) then + + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Error in subsolve') + goto 9999 + endif + + if (n_col <= size(work)) then + if ((4*n_col+n_col) <= size(work)) then + else + deallocate(aux) + endif + else + deallocate(ww,aux) + endif + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine mld_s_bwgs_solver_apply diff --git a/mlprec/impl/solver/mld_s_bwgs_solver_apply_vect.f90 b/mlprec/impl/solver/mld_s_bwgs_solver_apply_vect.f90 new file mode 100644 index 00000000..4a9eb69e --- /dev/null +++ b/mlprec/impl/solver/mld_s_bwgs_solver_apply_vect.f90 @@ -0,0 +1,200 @@ +!!$ +!!$ +!!$ MLD2P4 version 2.0 +!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package +!!$ based on PSBLAS (Parallel Sparse BLAS version 3.3) +!!$ +!!$ (C) Copyright 2008, 2010, 2012, 2015 +!!$ +!!$ 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. +!!$ +!!$ +subroutine mld_s_bwgs_solver_apply_vect(alpha,sv,x,beta,y,desc_data,trans,work,info) + + use psb_base_mod + use mld_s_gs_solver, mld_protect_name => mld_s_bwgs_solver_apply_vect + implicit none + type(psb_desc_type), intent(in) :: desc_data + class(mld_s_bwgs_solver_type), intent(inout) :: sv + type(psb_s_vect_type),intent(inout) :: x + type(psb_s_vect_type),intent(inout) :: y + real(psb_spk_),intent(in) :: alpha,beta + character(len=1),intent(in) :: trans + real(psb_spk_),target, intent(inout) :: work(:) + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: n_row,n_col, itx + type(psb_s_vect_type) :: wv, xit + real(psb_spk_), pointer :: ww(:), aux(:), tx(:),ty(:) + real(psb_spk_), allocatable :: temp(:) + integer(psb_ipk_) :: ictxt,np,me,i, err_act + character :: trans_ + character(len=20) :: name='d_bwgs_solver_apply' + + call psb_erractionsave(err_act) + ictxt = desc_data%get_ctxt() + call psb_info(ictxt,me,np) + info = psb_success_ + + trans_ = psb_toupper(trans) + select case(trans_) + case('N') +!!$ case('T') +!!$ case('C') + case default + call psb_errpush(psb_err_iarg_invalid_i_,name) + goto 9999 + end select + + n_row = desc_data%get_local_rows() + n_col = desc_data%get_local_cols() + + + if (x%get_nrows() < n_row) then + info = 36 + call psb_errpush(info,name,& + & i_err=(/itwo,n_row,izero,izero,izero/)) + goto 9999 + end if + if (y%get_nrows() < n_row) then + info = 36 + call psb_errpush(info,name,& + & i_err=(/ithree,n_row,izero,izero,izero/)) + goto 9999 + end if + + + + if (n_col <= size(work)) then + ww => work(1:n_col) + if ((4*n_col+n_col) <= size(work)) then + aux => work(n_col+1:) + else + allocate(aux(4*n_col),stat=info) + endif + else + allocate(ww(n_col),aux(4*n_col),stat=info) + endif + + if (info /= psb_success_) then + info=psb_err_alloc_request_ + call psb_errpush(info,name,& + & i_err=(/5*n_col,izero,izero,izero,izero/),& + & a_err='real(psb_spk_)') + goto 9999 + end if + + call psb_geasb(wv,desc_data,info,mold=x%v,scratch=.true.) + call psb_geasb(xit,desc_data,info,mold=x%v,scratch=.true.) + + select case(trans_) + case('N') + if (sv%eps <=szero) then + ! + ! Fixed number of iterations + ! + ! + ! WARNING: this is not completely satisfactory. We are assuming here Y + ! as the initial guess, but this is only working if we are called from the + ! current JAC smoother loop. A good solution would be to have a separate + ! input argument as the initial guess + ! +!!$ write(0,*) 'GS Iteration with ',sv%sweeps + call psb_geaxpby(sone,y,szero,xit,desc_data,info) + do itx=1,sv%sweeps + call psb_geaxpby(sone,x,szero,wv,desc_data,info) + ! Update with L. The off-diagonal block is taken care + ! from the Jacobi smoother, hence this is purely local. + call psb_spmm(-sone,sv%l,xit,sone,wv,desc_data,info,doswap=.false.) + call psb_spsm(sone,sv%u,wv,szero,xit,desc_data,info) +!!$ temp = xit%get_vect() +!!$ write(0,*) me,'GS Iteration ',itx,':',temp(1:n_row) + end do + + call psb_geaxpby(alpha,xit,beta,y,desc_data,info) + + else + ! + ! Iterations to convergence, not implemented right now. + ! + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='EPS>0 not implemented in GS subsolve') + goto 9999 + + end if +!!$ case('T') +!!$ call psb_spsm(sone,sv%u,x,szero,wv,desc_data,info,& +!!$ & trans=trans_,scale='L',diag=sv%dv,choice=psb_none_,work=aux) +!!$ if (info == psb_success_) call psb_spsm(alpha,sv%l,wv,beta,y,desc_data,info,& +!!$ & trans=trans_,scale='U',choice=psb_none_,work=aux) +!!$ +!!$ case('C') +!!$ +!!$ call psb_spsm(sone,sv%u,x,szero,wv,desc_data,info,& +!!$ & trans=trans_,scale='U',choice=psb_none_,work=aux) +!!$ +!!$ call wv1%mlt(sone,sv%dv,wv,szero,info,conjgx=trans_) +!!$ +!!$ if (info == psb_success_) call psb_spsm(alpha,sv%l,wv1,beta,y,desc_data,info,& +!!$ & trans=trans_,scale='U',choice=psb_none_,work=aux) + + case default + info = psb_err_internal_error_ + call psb_errpush(info,name,& + & a_err='Invalid TRANS in GS subsolve') + goto 9999 + end select + + + if (info /= psb_success_) then + + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Error in subsolve') + goto 9999 + endif + call wv%free(info) + call xit%free(info) + if (n_col <= size(work)) then + if ((4*n_col+n_col) <= size(work)) then + else + deallocate(aux) + endif + else + deallocate(ww,aux) + endif + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine mld_s_bwgs_solver_apply_vect diff --git a/mlprec/impl/solver/mld_s_bwgs_solver_bld.f90 b/mlprec/impl/solver/mld_s_bwgs_solver_bld.f90 new file mode 100644 index 00000000..af36fde0 --- /dev/null +++ b/mlprec/impl/solver/mld_s_bwgs_solver_bld.f90 @@ -0,0 +1,117 @@ +!!$ +!!$ +!!$ MLD2P4 version 2.0 +!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package +!!$ based on PSBLAS (Parallel Sparse BLAS version 3.3) +!!$ +!!$ (C) Copyright 2008, 2010, 2012, 2015 +!!$ +!!$ 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. +!!$ +!!$ +subroutine mld_s_bwgs_solver_bld(a,desc_a,sv,upd,info,b,amold,vmold,imold) + + use psb_base_mod + use mld_s_gs_solver, mld_protect_name => mld_s_bwgs_solver_bld + + Implicit None + + ! Arguments + type(psb_sspmat_type), intent(in), target :: a + Type(psb_desc_type), Intent(in) :: desc_a + class(mld_s_bwgs_solver_type), intent(inout) :: sv + character, intent(in) :: upd + integer(psb_ipk_), intent(out) :: info + type(psb_sspmat_type), intent(in), target, optional :: b + class(psb_s_base_sparse_mat), intent(in), optional :: amold + class(psb_s_base_vect_type), intent(in), optional :: vmold + class(psb_i_base_vect_type), intent(in), optional :: imold + ! Local variables + integer(psb_ipk_) :: n_row,n_col, nrow_a, nztota + integer(psb_ipk_) :: ictxt,np,me,i, err_act, debug_unit, debug_level + character(len=20) :: name='d_bwgs_solver_bld', ch_err + + 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() + call psb_info(ictxt, me, np) + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),' start' + + + n_row = desc_a%get_local_rows() + + if (psb_toupper(upd) == 'F') then + nrow_a = a%get_nrows() + nztota = a%get_nzeros() +!!$ if (present(b)) then +!!$ nztota = nztota + b%get_nzeros() +!!$ end if + if (sv%eps <= dzero) then + ! + ! This cuts out the off-diagonal part, because it's supposed to + ! be handled by the outer Jacobi smoother. + ! + call a%tril(sv%l,info,diag=-1) + call a%triu(sv%u,info,jmax=nrow_a) + + else + + info = psb_err_missing_override_method_ + call psb_errpush(info,name) + goto 9999 + end if + + + + call sv%l%set_asb() + call sv%l%trim() + call sv%u%set_asb() + call sv%u%trim() + + if (present(amold)) then + call sv%l%cscnv(info,mold=amold) + call sv%u%cscnv(info,mold=amold) + end if + + end if + + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),' end' + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return +end subroutine mld_s_bwgs_solver_bld diff --git a/mlprec/impl/solver/mld_s_mumps_solver_apply.F90 b/mlprec/impl/solver/mld_s_mumps_solver_apply.F90 index 9c01dd32..75e288f0 100644 --- a/mlprec/impl/solver/mld_s_mumps_solver_apply.F90 +++ b/mlprec/impl/solver/mld_s_mumps_solver_apply.F90 @@ -49,19 +49,18 @@ subroutine s_mumps_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info) real(psb_spk_),intent(in) :: alpha,beta character(len=1),intent(in) :: trans real(psb_spk_),target, intent(inout) :: work(:) - integer, intent(out) :: info + integer(psb_ipk_), intent(out) :: info - integer :: n_row, n_col, nglob + integer(psb_ipk_) :: n_row, n_col, nglob real(psb_spk_), allocatable :: ww(:) real(psb_spk_), allocatable, target :: gx(:) - integer :: ictxt,np,me,i, err_act + integer(psb_ipk_) :: ictxt,np,me,i, err_act character :: trans_ character(len=20) :: name='s_mumps_solver_apply' -#if defined(HAVE_MUMPS_) - call psb_erractionsave(err_act) +#if defined(HAVE_MUMPS_) info = psb_success_ trans_ = psb_toupper(trans) select case(trans_) @@ -83,7 +82,7 @@ subroutine s_mumps_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info) if (info /= psb_success_) then info=psb_err_alloc_request_ call psb_errpush(info,name,i_err=(/n_col,0,0,0,0/),& - & a_err='complex(psb_spk_)') + & a_err='real(psb_spk_)') goto 9999 end if end if @@ -91,7 +90,7 @@ subroutine s_mumps_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info) if (info /= psb_success_) then info=psb_err_alloc_request_ call psb_errpush(info,name,i_err=(/nglob,0,0,0,0/),& - & a_err='complex(psb_spk_)') + & a_err='real(psb_spk_)') goto 9999 end if call psb_gather(gx, x, desc_data, info, root=0) diff --git a/mlprec/impl/solver/mld_s_mumps_solver_apply_vect.F90 b/mlprec/impl/solver/mld_s_mumps_solver_apply_vect.F90 index 105fc6f5..0f6ad665 100644 --- a/mlprec/impl/solver/mld_s_mumps_solver_apply_vect.F90 +++ b/mlprec/impl/solver/mld_s_mumps_solver_apply_vect.F90 @@ -48,12 +48,13 @@ real(psb_spk_),intent(in) :: alpha,beta character(len=1),intent(in) :: trans real(psb_spk_),target, intent(inout) :: work(:) - integer, intent(out) :: info + integer(psb_ipk_), intent(out) :: info - integer :: err_act + integer(psb_ipk_) :: err_act character(len=20) :: name='s_mumps_solver_apply_vect' #if defined(HAVE_MUMPS_) + call psb_erractionsave(err_act) info = psb_success_ @@ -78,5 +79,6 @@ #else write(psb_err_unit,*) "MUMPS Not Configured, fix make.inc and recompile " #endif + end subroutine s_mumps_solver_apply_vect diff --git a/mlprec/impl/solver/mld_s_mumps_solver_bld.F90 b/mlprec/impl/solver/mld_s_mumps_solver_bld.F90 index d52b33c1..ebeb3fc4 100644 --- a/mlprec/impl/solver/mld_s_mumps_solver_bld.F90 +++ b/mlprec/impl/solver/mld_s_mumps_solver_bld.F90 @@ -51,7 +51,7 @@ Type(psb_desc_type), Intent(in) :: desc_a class(mld_s_mumps_solver_type), intent(inout) :: sv character, intent(in) :: upd - integer, intent(out) :: info + integer(psb_ipk_), intent(out) :: info type(psb_sspmat_type), intent(in), target, optional :: b class(psb_s_base_sparse_mat), intent(in), optional :: amold class(psb_s_base_vect_type), intent(in), optional :: vmold @@ -59,9 +59,9 @@ ! Local variables type(psb_sspmat_type) :: atmp type(psb_s_coo_sparse_mat), target :: acoo - integer :: n_row,n_col, nrow_a, nztota, nglob, nglobrec, nzt, npr, npc - integer :: ifrst, ibcheck - integer :: ictxt, ictxt1, icomm, np, me, i, err_act, debug_unit, debug_level + integer(psb_ipk_) :: n_row,n_col, nrow_a, nztota, nglob, nglobrec, nzt, npr, npc + integer(psb_ipk_) :: ifrst, ibcheck + integer(psb_ipk_) :: ictxt, ictxt1, icomm, np, me, i, err_act, debug_unit, debug_level character(len=20) :: name='s_mumps_solver_bld', ch_err #if defined(HAVE_MUMPS_) @@ -97,7 +97,7 @@ allocate(sv%id,stat=info) if (info /= psb_success_) then info=psb_err_alloc_dealloc_ - call psb_errpush(info,name,a_err='mld_mumps_default') + call psb_errpush(info,name,a_err='mld_smumps_default') goto 9999 end if end if @@ -109,7 +109,7 @@ sv%id%job = -1 sv%id%par=1 call smumps(sv%id) - !WARNING: CALLING mumps WITH JOB=-1 DESTROY THE SETTING OF DEFAULT:TO FIX + !WARNING: CALLING sMUMPS WITH JOB=-1 DESTROY THE SETTING OF DEFAULT:TO FIX sv%id%icntl(3)=sv%ipar(2) nglob = desc_a%get_global_rows() if (sv%ipar(1) < 0) then @@ -151,7 +151,7 @@ info = sv%id%infog(1) if (info /= psb_success_) then info=psb_err_from_subroutine_ - ch_err='mld_mumps_fact ' + ch_err='mld_smumps_fact ' call psb_errpush(info,name,a_err=ch_err) goto 9999 end if @@ -182,7 +182,6 @@ return end if return - #else write(psb_err_unit,*) "MUMPS Not Configured, fix make.inc and recompile " #endif diff --git a/mlprec/impl/solver/mld_z_bwgs_solver_apply.f90 b/mlprec/impl/solver/mld_z_bwgs_solver_apply.f90 new file mode 100644 index 00000000..e5344433 --- /dev/null +++ b/mlprec/impl/solver/mld_z_bwgs_solver_apply.f90 @@ -0,0 +1,196 @@ +!!$ +!!$ +!!$ MLD2P4 version 2.0 +!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package +!!$ based on PSBLAS (Parallel Sparse BLAS version 3.3) +!!$ +!!$ (C) Copyright 2008, 2010, 2012, 2015 +!!$ +!!$ 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. +!!$ +!!$ +subroutine mld_z_bwgs_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info) + + use psb_base_mod + use mld_z_gs_solver, mld_protect_name => mld_z_bwgs_solver_apply + implicit none + type(psb_desc_type), intent(in) :: desc_data + class(mld_z_bwgs_solver_type), intent(inout) :: sv + complex(psb_dpk_),intent(inout) :: x(:) + complex(psb_dpk_),intent(inout) :: y(:) + complex(psb_dpk_),intent(in) :: alpha,beta + character(len=1),intent(in) :: trans + complex(psb_dpk_),target, intent(inout) :: work(:) + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: n_row,n_col, itx + complex(psb_dpk_), pointer :: ww(:), aux(:), tx(:),ty(:) + complex(psb_dpk_), allocatable :: temp(:),wv(:),xit(:) + integer(psb_ipk_) :: ictxt,np,me,i, err_act + character :: trans_ + character(len=20) :: name='d_bwgs_solver_apply' + + call psb_erractionsave(err_act) + ictxt = desc_data%get_ctxt() + call psb_info(ictxt,me,np) + info = psb_success_ + + trans_ = psb_toupper(trans) + select case(trans_) + case('N') +!!$ case('T') +!!$ case('C') + case default + call psb_errpush(psb_err_iarg_invalid_i_,name) + goto 9999 + end select + + n_row = desc_data%get_local_rows() + n_col = desc_data%get_local_cols() + + if (n_col <= size(work)) then + ww => work(1:n_col) + if ((4*n_col+n_col) <= size(work)) then + aux => work(n_col+1:) + else + allocate(aux(4*n_col),stat=info) + if (info /= psb_success_) then + info=psb_err_alloc_request_ + call psb_errpush(info,name,& + & i_err=(/4*n_col,izero,izero,izero,izero/),& + & a_err='complex(psb_dpk_)') + goto 9999 + end if + endif + else + allocate(ww(n_col),aux(4*n_col),stat=info) + if (info /= psb_success_) then + info=psb_err_alloc_request_ + call psb_errpush(info,name,& + & i_err=(/5*n_col,izero,izero,izero,izero/),& + & a_err='complex(psb_dpk_)') + goto 9999 + end if + endif + + if (info /= psb_success_) then + info=psb_err_alloc_request_ + call psb_errpush(info,name,& + & i_err=(/5*n_col,izero,izero,izero,izero/),& + & a_err='complex(psb_dpk_)') + goto 9999 + end if + + call psb_geasb(wv,desc_data,info) + call psb_geasb(xit,desc_data,info) + + select case(trans_) + case('N') + if (sv%eps <=dzero) then + ! + ! Fixed number of iterations + ! + ! + ! WARNING: this is not completely satisfactory. We are assuming here Y + ! as the initial guess, but this is only working if we are called from the + ! current JAC smoother loop. A good solution would be to have a separate + ! input argument as the initial guess + ! +!!$ write(0,*) 'GS Iteration with ',sv%sweeps + call psb_geaxpby(zone,y,zzero,xit,desc_data,info) + do itx=1,sv%sweeps + call psb_geaxpby(zone,x,zzero,wv,desc_data,info) + ! Update with L. The off-diagonal block is taken care + ! from the Jacobi smoother, hence this is purely local. + call psb_spmm(-zone,sv%l,xit,zone,wv,desc_data,info,doswap=.false.) + call psb_spsm(zone,sv%u,wv,zzero,xit,desc_data,info) +!!$ temp = xit%get_vect() +!!$ write(0,*) me,'GS Iteration ',itx,':',temp(1:n_row) + end do + + call psb_geaxpby(alpha,xit,beta,y,desc_data,info) + + else + ! + ! Iterations to convergence, not implemented right now. + ! + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='EPS>0 not implemented in GS subsolve') + goto 9999 + + end if +!!$ case('T') +!!$ call psb_spsm(zone,sv%u,x,zzero,wv,desc_data,info,& +!!$ & trans=trans_,scale='L',diag=sv%dv,choice=psb_none_,work=aux) +!!$ if (info == psb_success_) call psb_spsm(alpha,sv%l,wv,beta,y,desc_data,info,& +!!$ & trans=trans_,scale='U',choice=psb_none_,work=aux) +!!$ +!!$ case('C') +!!$ +!!$ call psb_spsm(zone,sv%u,x,zzero,wv,desc_data,info,& +!!$ & trans=trans_,scale='U',choice=psb_none_,work=aux) +!!$ +!!$ call wv1%mlt(zone,sv%dv,wv,zzero,info,conjgx=trans_) +!!$ +!!$ if (info == psb_success_) call psb_spsm(alpha,sv%l,wv1,beta,y,desc_data,info,& +!!$ & trans=trans_,scale='U',choice=psb_none_,work=aux) + + case default + info = psb_err_internal_error_ + call psb_errpush(info,name,& + & a_err='Invalid TRANS in GS subsolve') + goto 9999 + end select + + + if (info /= psb_success_) then + + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Error in subsolve') + goto 9999 + endif + + if (n_col <= size(work)) then + if ((4*n_col+n_col) <= size(work)) then + else + deallocate(aux) + endif + else + deallocate(ww,aux) + endif + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine mld_z_bwgs_solver_apply diff --git a/mlprec/impl/solver/mld_z_bwgs_solver_apply_vect.f90 b/mlprec/impl/solver/mld_z_bwgs_solver_apply_vect.f90 new file mode 100644 index 00000000..809d9605 --- /dev/null +++ b/mlprec/impl/solver/mld_z_bwgs_solver_apply_vect.f90 @@ -0,0 +1,200 @@ +!!$ +!!$ +!!$ MLD2P4 version 2.0 +!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package +!!$ based on PSBLAS (Parallel Sparse BLAS version 3.3) +!!$ +!!$ (C) Copyright 2008, 2010, 2012, 2015 +!!$ +!!$ 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. +!!$ +!!$ +subroutine mld_z_bwgs_solver_apply_vect(alpha,sv,x,beta,y,desc_data,trans,work,info) + + use psb_base_mod + use mld_z_gs_solver, mld_protect_name => mld_z_bwgs_solver_apply_vect + implicit none + type(psb_desc_type), intent(in) :: desc_data + class(mld_z_bwgs_solver_type), intent(inout) :: sv + type(psb_z_vect_type),intent(inout) :: x + type(psb_z_vect_type),intent(inout) :: y + complex(psb_dpk_),intent(in) :: alpha,beta + character(len=1),intent(in) :: trans + complex(psb_dpk_),target, intent(inout) :: work(:) + integer(psb_ipk_), intent(out) :: info + + integer(psb_ipk_) :: n_row,n_col, itx + type(psb_z_vect_type) :: wv, xit + complex(psb_dpk_), pointer :: ww(:), aux(:), tx(:),ty(:) + complex(psb_dpk_), allocatable :: temp(:) + integer(psb_ipk_) :: ictxt,np,me,i, err_act + character :: trans_ + character(len=20) :: name='d_bwgs_solver_apply' + + call psb_erractionsave(err_act) + ictxt = desc_data%get_ctxt() + call psb_info(ictxt,me,np) + info = psb_success_ + + trans_ = psb_toupper(trans) + select case(trans_) + case('N') +!!$ case('T') +!!$ case('C') + case default + call psb_errpush(psb_err_iarg_invalid_i_,name) + goto 9999 + end select + + n_row = desc_data%get_local_rows() + n_col = desc_data%get_local_cols() + + + if (x%get_nrows() < n_row) then + info = 36 + call psb_errpush(info,name,& + & i_err=(/itwo,n_row,izero,izero,izero/)) + goto 9999 + end if + if (y%get_nrows() < n_row) then + info = 36 + call psb_errpush(info,name,& + & i_err=(/ithree,n_row,izero,izero,izero/)) + goto 9999 + end if + + + + if (n_col <= size(work)) then + ww => work(1:n_col) + if ((4*n_col+n_col) <= size(work)) then + aux => work(n_col+1:) + else + allocate(aux(4*n_col),stat=info) + endif + else + allocate(ww(n_col),aux(4*n_col),stat=info) + endif + + if (info /= psb_success_) then + info=psb_err_alloc_request_ + call psb_errpush(info,name,& + & i_err=(/5*n_col,izero,izero,izero,izero/),& + & a_err='complex(psb_dpk_)') + goto 9999 + end if + + call psb_geasb(wv,desc_data,info,mold=x%v,scratch=.true.) + call psb_geasb(xit,desc_data,info,mold=x%v,scratch=.true.) + + select case(trans_) + case('N') + if (sv%eps <=dzero) then + ! + ! Fixed number of iterations + ! + ! + ! WARNING: this is not completely satisfactory. We are assuming here Y + ! as the initial guess, but this is only working if we are called from the + ! current JAC smoother loop. A good solution would be to have a separate + ! input argument as the initial guess + ! +!!$ write(0,*) 'GS Iteration with ',sv%sweeps + call psb_geaxpby(zone,y,zzero,xit,desc_data,info) + do itx=1,sv%sweeps + call psb_geaxpby(zone,x,zzero,wv,desc_data,info) + ! Update with L. The off-diagonal block is taken care + ! from the Jacobi smoother, hence this is purely local. + call psb_spmm(-zone,sv%l,xit,zone,wv,desc_data,info,doswap=.false.) + call psb_spsm(zone,sv%u,wv,zzero,xit,desc_data,info) +!!$ temp = xit%get_vect() +!!$ write(0,*) me,'GS Iteration ',itx,':',temp(1:n_row) + end do + + call psb_geaxpby(alpha,xit,beta,y,desc_data,info) + + else + ! + ! Iterations to convergence, not implemented right now. + ! + info = psb_err_internal_error_ + call psb_errpush(info,name,a_err='EPS>0 not implemented in GS subsolve') + goto 9999 + + end if +!!$ case('T') +!!$ call psb_spsm(zone,sv%u,x,zzero,wv,desc_data,info,& +!!$ & trans=trans_,scale='L',diag=sv%dv,choice=psb_none_,work=aux) +!!$ if (info == psb_success_) call psb_spsm(alpha,sv%l,wv,beta,y,desc_data,info,& +!!$ & trans=trans_,scale='U',choice=psb_none_,work=aux) +!!$ +!!$ case('C') +!!$ +!!$ call psb_spsm(zone,sv%u,x,zzero,wv,desc_data,info,& +!!$ & trans=trans_,scale='U',choice=psb_none_,work=aux) +!!$ +!!$ call wv1%mlt(zone,sv%dv,wv,zzero,info,conjgx=trans_) +!!$ +!!$ if (info == psb_success_) call psb_spsm(alpha,sv%l,wv1,beta,y,desc_data,info,& +!!$ & trans=trans_,scale='U',choice=psb_none_,work=aux) + + case default + info = psb_err_internal_error_ + call psb_errpush(info,name,& + & a_err='Invalid TRANS in GS subsolve') + goto 9999 + end select + + + if (info /= psb_success_) then + + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Error in subsolve') + goto 9999 + endif + call wv%free(info) + call xit%free(info) + if (n_col <= size(work)) then + if ((4*n_col+n_col) <= size(work)) then + else + deallocate(aux) + endif + else + deallocate(ww,aux) + endif + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +end subroutine mld_z_bwgs_solver_apply_vect diff --git a/mlprec/impl/solver/mld_z_bwgs_solver_bld.f90 b/mlprec/impl/solver/mld_z_bwgs_solver_bld.f90 new file mode 100644 index 00000000..1286bf8c --- /dev/null +++ b/mlprec/impl/solver/mld_z_bwgs_solver_bld.f90 @@ -0,0 +1,117 @@ +!!$ +!!$ +!!$ MLD2P4 version 2.0 +!!$ MultiLevel Domain Decomposition Parallel Preconditioners Package +!!$ based on PSBLAS (Parallel Sparse BLAS version 3.3) +!!$ +!!$ (C) Copyright 2008, 2010, 2012, 2015 +!!$ +!!$ 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. +!!$ +!!$ +subroutine mld_z_bwgs_solver_bld(a,desc_a,sv,upd,info,b,amold,vmold,imold) + + use psb_base_mod + use mld_z_gs_solver, mld_protect_name => mld_z_bwgs_solver_bld + + Implicit None + + ! Arguments + type(psb_zspmat_type), intent(in), target :: a + Type(psb_desc_type), Intent(in) :: desc_a + class(mld_z_bwgs_solver_type), intent(inout) :: sv + character, intent(in) :: upd + integer(psb_ipk_), intent(out) :: info + type(psb_zspmat_type), intent(in), target, optional :: b + class(psb_z_base_sparse_mat), intent(in), optional :: amold + class(psb_z_base_vect_type), intent(in), optional :: vmold + class(psb_i_base_vect_type), intent(in), optional :: imold + ! Local variables + integer(psb_ipk_) :: n_row,n_col, nrow_a, nztota + integer(psb_ipk_) :: ictxt,np,me,i, err_act, debug_unit, debug_level + character(len=20) :: name='d_bwgs_solver_bld', ch_err + + 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() + call psb_info(ictxt, me, np) + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),' start' + + + n_row = desc_a%get_local_rows() + + if (psb_toupper(upd) == 'F') then + nrow_a = a%get_nrows() + nztota = a%get_nzeros() +!!$ if (present(b)) then +!!$ nztota = nztota + b%get_nzeros() +!!$ end if + if (sv%eps <= dzero) then + ! + ! This cuts out the off-diagonal part, because it's supposed to + ! be handled by the outer Jacobi smoother. + ! + call a%tril(sv%l,info,diag=-1) + call a%triu(sv%u,info,jmax=nrow_a) + + else + + info = psb_err_missing_override_method_ + call psb_errpush(info,name) + goto 9999 + end if + + + + call sv%l%set_asb() + call sv%l%trim() + call sv%u%set_asb() + call sv%u%trim() + + if (present(amold)) then + call sv%l%cscnv(info,mold=amold) + call sv%u%cscnv(info,mold=amold) + end if + + end if + + if (debug_level >= psb_debug_outer_) & + & write(debug_unit,*) me,' ',trim(name),' end' + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return +end subroutine mld_z_bwgs_solver_bld diff --git a/mlprec/impl/solver/mld_z_mumps_solver_apply.F90 b/mlprec/impl/solver/mld_z_mumps_solver_apply.F90 index f1b7c2e7..66348759 100644 --- a/mlprec/impl/solver/mld_z_mumps_solver_apply.F90 +++ b/mlprec/impl/solver/mld_z_mumps_solver_apply.F90 @@ -58,10 +58,9 @@ subroutine z_mumps_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info) character :: trans_ character(len=20) :: name='z_mumps_solver_apply' -#if defined(HAVE_MUMPS_) - call psb_erractionsave(err_act) +#if defined(HAVE_MUMPS_) info = psb_success_ trans_ = psb_toupper(trans) select case(trans_) @@ -83,7 +82,7 @@ subroutine z_mumps_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info) if (info /= psb_success_) then info=psb_err_alloc_request_ call psb_errpush(info,name,i_err=(/n_col,0,0,0,0/),& - & a_err='complex(psb_spk_)') + & a_err='complex(psb_dpk_)') goto 9999 end if end if @@ -91,7 +90,7 @@ subroutine z_mumps_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info) if (info /= psb_success_) then info=psb_err_alloc_request_ call psb_errpush(info,name,i_err=(/nglob,0,0,0,0/),& - & a_err='complex(psb_spk_)') + & a_err='complex(psb_dpk_)') goto 9999 end if call psb_gather(gx, x, desc_data, info, root=0) @@ -144,6 +143,5 @@ subroutine z_mumps_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info) #else write(psb_err_unit,*) "MUMPS Not Configured, fix make.inc and recompile " #endif - end subroutine z_mumps_solver_apply diff --git a/mlprec/impl/solver/mld_z_mumps_solver_apply_vect.F90 b/mlprec/impl/solver/mld_z_mumps_solver_apply_vect.F90 index 831937a6..c895a549 100644 --- a/mlprec/impl/solver/mld_z_mumps_solver_apply_vect.F90 +++ b/mlprec/impl/solver/mld_z_mumps_solver_apply_vect.F90 @@ -79,5 +79,6 @@ #else write(psb_err_unit,*) "MUMPS Not Configured, fix make.inc and recompile " #endif + end subroutine z_mumps_solver_apply_vect diff --git a/mlprec/impl/solver/mld_z_mumps_solver_bld.F90 b/mlprec/impl/solver/mld_z_mumps_solver_bld.F90 index a6c25457..199f3f46 100644 --- a/mlprec/impl/solver/mld_z_mumps_solver_bld.F90 +++ b/mlprec/impl/solver/mld_z_mumps_solver_bld.F90 @@ -182,7 +182,6 @@ return end if return - #else write(psb_err_unit,*) "MUMPS Not Configured, fix make.inc and recompile " #endif diff --git a/mlprec/mld_base_prec_type.F90 b/mlprec/mld_base_prec_type.F90 index 736ad18c..5e4619c8 100644 --- a/mlprec/mld_base_prec_type.F90 +++ b/mlprec/mld_base_prec_type.F90 @@ -179,28 +179,29 @@ module mld_base_prec_type ! ! Legal values for entry: mld_sub_solve_ ! - integer(psb_ipk_), parameter :: mld_slv_delta_ = mld_max_prec_+1 - integer(psb_ipk_), parameter :: mld_f_none_ = mld_slv_delta_+0 - integer(psb_ipk_), parameter :: mld_diag_scale_ = mld_slv_delta_+1 - integer(psb_ipk_), parameter :: mld_gs_ = mld_slv_delta_+2 - integer(psb_ipk_), parameter :: mld_ilu_n_ = mld_slv_delta_+3 - integer(psb_ipk_), parameter :: mld_milu_n_ = mld_slv_delta_+4 - integer(psb_ipk_), parameter :: mld_ilu_t_ = mld_slv_delta_+5 - integer(psb_ipk_), parameter :: mld_slu_ = mld_slv_delta_+6 - integer(psb_ipk_), parameter :: mld_umf_ = mld_slv_delta_+7 - integer(psb_ipk_), parameter :: mld_sludist_ = mld_slv_delta_+8 - integer(psb_ipk_), parameter :: mld_mumps_ = mld_slv_delta_+9 - integer(psb_ipk_), parameter :: mld_max_sub_solve_= mld_slv_delta_+9 - integer(psb_ipk_), parameter :: mld_min_sub_solve_= mld_diag_scale_ + integer(psb_ipk_), parameter :: mld_slv_delta_ = mld_max_prec_+1 + integer(psb_ipk_), parameter :: mld_f_none_ = mld_slv_delta_+0 + integer(psb_ipk_), parameter :: mld_diag_scale_ = mld_slv_delta_+1 + integer(psb_ipk_), parameter :: mld_gs_ = mld_slv_delta_+2 + integer(psb_ipk_), parameter :: mld_ilu_n_ = mld_slv_delta_+3 + integer(psb_ipk_), parameter :: mld_milu_n_ = mld_slv_delta_+4 + integer(psb_ipk_), parameter :: mld_ilu_t_ = mld_slv_delta_+5 + integer(psb_ipk_), parameter :: mld_slu_ = mld_slv_delta_+6 + integer(psb_ipk_), parameter :: mld_umf_ = mld_slv_delta_+7 + integer(psb_ipk_), parameter :: mld_sludist_ = mld_slv_delta_+8 + integer(psb_ipk_), parameter :: mld_mumps_ = mld_slv_delta_+9 + integer(psb_ipk_), parameter :: mld_bwgs_ = mld_slv_delta_+10 + integer(psb_ipk_), parameter :: mld_max_sub_solve_ = mld_slv_delta_+10 + integer(psb_ipk_), parameter :: mld_min_sub_solve_ = mld_diag_scale_ ! ! Legal values for entry: mld_sub_ren_ ! - integer(psb_ipk_), parameter :: mld_renum_none_=0 - integer(psb_ipk_), parameter :: mld_renum_glb_=1 - integer(psb_ipk_), parameter :: mld_renum_gps_=2 + integer(psb_ipk_), parameter :: mld_renum_none_ = 0 + integer(psb_ipk_), parameter :: mld_renum_glb_ = 1 + integer(psb_ipk_), parameter :: mld_renum_gps_ = 2 ! For the time being we are disabling GPS renumbering. - integer(psb_ipk_), parameter :: mld_max_renum_=1 + integer(psb_ipk_), parameter :: mld_max_renum_ = 1 ! ! Legal values for entry: mld_ilu_scale_ ! @@ -217,40 +218,40 @@ module mld_base_prec_type ! integer(psb_ipk_), parameter :: mld_no_ml_ = 0 integer(psb_ipk_), parameter :: mld_add_ml_ = 1 - integer(psb_ipk_), parameter :: mld_mult_ml_ = 2 + integer(psb_ipk_), parameter :: mld_mult_ml_ = 2 integer(psb_ipk_), parameter :: mld_new_ml_prec_ = 3 integer(psb_ipk_), parameter :: mld_max_ml_type_ = mld_mult_ml_ ! ! Legal values for entry: mld_smoother_pos_ ! - integer(psb_ipk_), parameter :: mld_pre_smooth_=1 - integer(psb_ipk_), parameter :: mld_post_smooth_=2 - integer(psb_ipk_), parameter :: mld_twoside_smooth_=3 - integer(psb_ipk_), parameter :: mld_max_smooth_=mld_twoside_smooth_ + integer(psb_ipk_), parameter :: mld_pre_smooth_ = 1 + integer(psb_ipk_), parameter :: mld_post_smooth_ = 2 + integer(psb_ipk_), parameter :: mld_twoside_smooth_ = 3 + integer(psb_ipk_), parameter :: mld_max_smooth_ = mld_twoside_smooth_ ! ! Legal values for entry: mld_aggr_kind_ ! - integer(psb_ipk_), parameter :: mld_no_smooth_ = 0 + integer(psb_ipk_), parameter :: mld_no_smooth_ = 0 integer(psb_ipk_), parameter :: mld_smooth_prol_ = 1 - integer(psb_ipk_), parameter :: mld_min_energy_ = 2 + integer(psb_ipk_), parameter :: mld_min_energy_ = 2 integer(psb_ipk_), parameter :: mld_biz_prol_ = 3 ! Disabling biz_prol for the time being. integer(psb_ipk_), parameter :: mld_max_aggr_kind_=mld_min_energy_ ! ! Legal values for entry: mld_aggr_filter_ ! - integer(psb_ipk_), parameter :: mld_no_filter_mat_=0 - integer(psb_ipk_), parameter :: mld_filter_mat_=1 - integer(psb_ipk_), parameter :: mld_max_filter_mat_=mld_no_filter_mat_ + integer(psb_ipk_), parameter :: mld_no_filter_mat_ = 0 + integer(psb_ipk_), parameter :: mld_filter_mat_ = 1 + integer(psb_ipk_), parameter :: mld_max_filter_mat_ = mld_no_filter_mat_ ! ! Legal values for entry: mld_aggr_alg_ ! - integer(psb_ipk_), parameter :: mld_dec_aggr_=0 - integer(psb_ipk_), parameter :: mld_sym_dec_aggr_=1 - integer(psb_ipk_), parameter :: mld_glb_aggr_=2 - integer(psb_ipk_), parameter :: mld_new_dec_aggr_=3 - integer(psb_ipk_), parameter :: mld_new_glb_aggr_=4 - integer(psb_ipk_), parameter :: mld_max_aggr_alg_=mld_sym_dec_aggr_ + integer(psb_ipk_), parameter :: mld_dec_aggr_ = 0 + integer(psb_ipk_), parameter :: mld_sym_dec_aggr_ = 1 + integer(psb_ipk_), parameter :: mld_glb_aggr_ = 2 + integer(psb_ipk_), parameter :: mld_new_dec_aggr_ = 3 + integer(psb_ipk_), parameter :: mld_new_glb_aggr_ = 4 + integer(psb_ipk_), parameter :: mld_max_aggr_alg_ = mld_sym_dec_aggr_ ! ! Legal values for entry: mld_aggr_ord_ ! @@ -260,22 +261,22 @@ module mld_base_prec_type ! ! Legal values for entry: mld_aggr_omega_alg_ ! - integer(psb_ipk_), parameter :: mld_eig_est_=0 - integer(psb_ipk_), parameter :: mld_user_choice_=999 + integer(psb_ipk_), parameter :: mld_eig_est_ = 0 + integer(psb_ipk_), parameter :: mld_user_choice_ = 999 ! ! Legal values for entry: mld_aggr_eig_ ! - integer(psb_ipk_), parameter :: mld_max_norm_=0 + integer(psb_ipk_), parameter :: mld_max_norm_ = 0 ! ! Legal values for entry: mld_coarse_mat_ ! - integer(psb_ipk_), parameter :: mld_distr_mat_=0 - integer(psb_ipk_), parameter :: mld_repl_mat_=1 - integer(psb_ipk_), parameter :: mld_max_coarse_mat_=mld_repl_mat_ + integer(psb_ipk_), parameter :: mld_distr_mat_ = 0 + integer(psb_ipk_), parameter :: mld_repl_mat_ = 1 + integer(psb_ipk_), parameter :: mld_max_coarse_mat_ = mld_repl_mat_ ! ! Legal values for entry: mld_prec_status_ ! - integer(psb_ipk_), parameter :: mld_prec_built_=98765 + integer(psb_ipk_), parameter :: mld_prec_built_ = 98765 ! ! Entries in rprcparm: ILU(k,t) threshold, smoothed aggregation omega @@ -293,7 +294,7 @@ module mld_base_prec_type ! Entries for mumps ! !parameter controling the sequential/parallel building of MUMPS - integer(psb_ipk_), parameter :: mld_as_sequential_ =40 + integer(psb_ipk_), parameter :: mld_as_sequential_ = 40 !parameter regulating the error printing of MUMPS integer(psb_ipk_), parameter :: mld_mumps_print_err_ = 41 @@ -343,7 +344,8 @@ module mld_base_prec_type & 'Gauss-Seidel ','ILU(n) ',& & 'MILU(n) ','ILU(t,n) ',& & 'SuperLU ','UMFPACK LU ',& - & 'SuperLU_Dist ','MUMPS '/) + & 'SuperLU_Dist ','MUMPS ',& + & 'Backward GS '/) interface mld_check_def module procedure mld_icheck_def, mld_scheck_def, mld_dcheck_def @@ -393,8 +395,10 @@ contains val = psb_avg_ case('FACT_NONE') val = mld_f_none_ - case('GS') + case('GS','FWGS') val = mld_gs_ + case('BWGS') + val = mld_bwgs_ case('ILU') val = mld_ilu_n_ case('MILU') diff --git a/mlprec/mld_c_gs_solver.f90 b/mlprec/mld_c_gs_solver.f90 index 7b074d78..19881bb4 100644 --- a/mlprec/mld_c_gs_solver.f90 +++ b/mlprec/mld_c_gs_solver.f90 @@ -74,15 +74,25 @@ module mld_c_gs_solver procedure, nopass :: is_iterative => d_gs_solver_is_iterative end type mld_c_gs_solver_type + type, extends(mld_c_gs_solver_type) :: mld_c_bwgs_solver_type + contains + procedure, pass(sv) :: build => mld_c_bwgs_solver_bld + procedure, pass(sv) :: apply_v => mld_c_bwgs_solver_apply_vect + procedure, pass(sv) :: apply_a => mld_c_bwgs_solver_apply + procedure, nopass :: get_fmt => c_bwgs_solver_get_fmt + procedure, pass(sv) :: descr => c_bwgs_solver_descr + end type mld_c_bwgs_solver_type - private :: d_gs_solver_bld, d_gs_solver_apply, & - & d_gs_solver_free, d_gs_solver_seti, & - & d_gs_solver_setc, d_gs_solver_setr,& - & d_gs_solver_descr, d_gs_solver_sizeof, & - & d_gs_solver_default, d_gs_solver_dmp, & - & d_gs_solver_apply_vect, d_gs_solver_get_nzeros, & - & d_gs_solver_get_fmt, d_gs_solver_check,& - & d_gs_solver_is_iterative + + private :: c_gs_solver_bld, c_gs_solver_apply, & + & c_gs_solver_free, c_gs_solver_seti, & + & c_gs_solver_setc, c_gs_solver_setr,& + & c_gs_solver_descr, c_gs_solver_sizeof, & + & c_gs_solver_default, c_gs_solver_dmp, & + & c_gs_solver_apply_vect, c_gs_solver_get_nzeros, & + & c_gs_solver_get_fmt, c_gs_solver_check,& + & c_gs_solver_is_iterative, & + & c_bwgs_solver_get_fmt, c_bwgs_solver_descr interface @@ -99,6 +109,19 @@ module mld_c_gs_solver complex(psb_spk_),target, intent(inout) :: work(:) integer(psb_ipk_), intent(out) :: info end subroutine mld_c_gs_solver_apply_vect + subroutine mld_c_bwgs_solver_apply_vect(alpha,sv,x,beta,y,desc_data,trans,work,info) + import :: psb_desc_type, mld_c_bwgs_solver_type, psb_c_vect_type, psb_spk_, & + & psb_cspmat_type, psb_c_base_sparse_mat, psb_c_base_vect_type, psb_ipk_ + implicit none + type(psb_desc_type), intent(in) :: desc_data + class(mld_c_bwgs_solver_type), intent(inout) :: sv + type(psb_c_vect_type),intent(inout) :: x + type(psb_c_vect_type),intent(inout) :: y + complex(psb_spk_),intent(in) :: alpha,beta + character(len=1),intent(in) :: trans + complex(psb_spk_),target, intent(inout) :: work(:) + integer(psb_ipk_), intent(out) :: info + end subroutine mld_c_bwgs_solver_apply_vect end interface interface @@ -115,6 +138,19 @@ module mld_c_gs_solver complex(psb_spk_),target, intent(inout) :: work(:) integer(psb_ipk_), intent(out) :: info end subroutine mld_c_gs_solver_apply + subroutine mld_c_bwgs_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info) + import :: psb_desc_type, mld_c_bwgs_solver_type, psb_c_vect_type, psb_spk_, & + & psb_cspmat_type, psb_c_base_sparse_mat, psb_c_base_vect_type, psb_ipk_ + implicit none + type(psb_desc_type), intent(in) :: desc_data + class(mld_c_bwgs_solver_type), intent(inout) :: sv + complex(psb_spk_),intent(inout) :: x(:) + complex(psb_spk_),intent(inout) :: y(:) + complex(psb_spk_),intent(in) :: alpha,beta + character(len=1),intent(in) :: trans + complex(psb_spk_),target, intent(inout) :: work(:) + integer(psb_ipk_), intent(out) :: info + end subroutine mld_c_bwgs_solver_apply end interface interface @@ -133,6 +169,21 @@ module mld_c_gs_solver class(psb_c_base_vect_type), intent(in), optional :: vmold class(psb_i_base_vect_type), intent(in), optional :: imold end subroutine mld_c_gs_solver_bld + subroutine mld_c_bwgs_solver_bld(a,desc_a,sv,upd,info,b,amold,vmold,imold) + import :: psb_desc_type, mld_c_bwgs_solver_type, psb_c_vect_type, psb_spk_, & + & psb_cspmat_type, psb_c_base_sparse_mat, psb_c_base_vect_type,& + & psb_ipk_, psb_i_base_vect_type + implicit none + type(psb_cspmat_type), intent(in), target :: a + Type(psb_desc_type), Intent(in) :: desc_a + class(mld_c_bwgs_solver_type), intent(inout) :: sv + character, intent(in) :: upd + integer(psb_ipk_), intent(out) :: info + type(psb_cspmat_type), intent(in), target, optional :: b + class(psb_c_base_sparse_mat), intent(in), optional :: amold + class(psb_c_base_vect_type), intent(in), optional :: vmold + class(psb_i_base_vect_type), intent(in), optional :: imold + end subroutine mld_c_bwgs_solver_bld end interface interface @@ -452,10 +503,10 @@ contains endif if (sv%eps<=dzero) then - write(iout_,*) ' Gauss-Seidel iterative solver with ',& + write(iout_,*) ' Forward Gauss-Seidel iterative solver with ',& & sv%sweeps,' sweeps' else - write(iout_,*) ' Gauss-Seidel iterative solver with tolerance',& + write(iout_,*) ' Forward Gauss-Seidel iterative solver with tolerance',& & sv%eps,' and maxit', sv%sweeps end if @@ -500,7 +551,7 @@ contains implicit none character(len=32) :: val - val = "Gauss-Seidel solver" + val = "Forward Gauss-Seidel solver" end function d_gs_solver_get_fmt @@ -514,5 +565,50 @@ contains val = .true. end function d_gs_solver_is_iterative + + subroutine c_bwgs_solver_descr(sv,info,iout,coarse) + + Implicit None + + ! Arguments + class(mld_c_bwgs_solver_type), intent(in) :: sv + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: iout + logical, intent(in), optional :: coarse + + ! Local variables + integer(psb_ipk_) :: err_act + character(len=20), parameter :: name='mld_c_bwgs_solver_descr' + integer(psb_ipk_) :: iout_ + + call psb_erractionsave(err_act) + info = psb_success_ + if (present(iout)) then + iout_ = iout + else + iout_ = 6 + endif + + if (sv%eps<=dzero) then + write(iout_,*) ' Backward Gauss-Seidel iterative solver with ',& + & sv%sweeps,' sweeps' + else + write(iout_,*) ' Backward Gauss-Seidel iterative solver with tolerance',& + & sv%eps,' and maxit', sv%sweeps + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + return + end subroutine c_bwgs_solver_descr + + function c_bwgs_solver_get_fmt() result(val) + implicit none + character(len=32) :: val + + val = "Backward Gauss-Seidel solver" + end function c_bwgs_solver_get_fmt end module mld_c_gs_solver diff --git a/mlprec/mld_c_onelev_mod.f90 b/mlprec/mld_c_onelev_mod.f90 index e0115610..a95f0182 100644 --- a/mlprec/mld_c_onelev_mod.f90 +++ b/mlprec/mld_c_onelev_mod.f90 @@ -121,7 +121,8 @@ module mld_c_onelev_mod ! ! type mld_c_onelev_type - class(mld_c_base_smoother_type), allocatable :: sm + class(mld_c_base_smoother_type), allocatable :: sm, sm2a + class(mld_c_base_smoother_type), pointer :: sm2 => null() type(mld_sml_parms) :: parms type(psb_cspmat_type) :: ac integer(psb_ipk_) :: ac_nz_loc, ac_nz_tot @@ -144,7 +145,10 @@ module mld_c_onelev_mod procedure, pass(lv) :: cseti => mld_c_base_onelev_cseti procedure, pass(lv) :: csetr => mld_c_base_onelev_csetr procedure, pass(lv) :: csetc => mld_c_base_onelev_csetc - generic, public :: set => seti, setr, setc, cseti, csetr, csetc + procedure, pass(lv) :: setsm => mld_c_base_onelev_setsm + procedure, pass(lv) :: setsv => mld_c_base_onelev_setsv + generic, public :: set => seti, setr, setc, & + & cseti, csetr, csetc, setsm, setsv procedure, pass(lv) :: sizeof => c_base_onelev_sizeof procedure, pass(lv) :: get_nzeros => c_base_onelev_get_nzeros procedure, nopass :: stringval => mld_stringval @@ -213,7 +217,7 @@ module mld_c_onelev_mod end interface interface - subroutine mld_c_base_onelev_seti(lv,what,val,info) + subroutine mld_c_base_onelev_seti(lv,what,val,info,pos) import :: psb_cspmat_type, psb_c_vect_type, psb_c_base_vect_type, & & psb_clinmap_type, psb_spk_, mld_c_onelev_type, & & psb_ipk_, psb_long_int_k_, psb_desc_type @@ -224,11 +228,40 @@ module mld_c_onelev_mod integer(psb_ipk_), intent(in) :: what integer(psb_ipk_), intent(in) :: val integer(psb_ipk_), intent(out) :: info + character(len=*), optional, intent(in) :: pos end subroutine mld_c_base_onelev_seti end interface + + interface + subroutine mld_c_base_onelev_setsm(lv,val,info,pos) + import :: psb_spk_, mld_c_onelev_type, mld_c_base_smoother_type, & + & psb_ipk_, psb_long_int_k_, psb_desc_type + Implicit None + + ! Arguments + class(mld_c_onelev_type), target, intent(inout) :: lv + class(mld_c_base_smoother_type), intent(in) :: val + integer(psb_ipk_), intent(out) :: info + character(len=*), optional, intent(in) :: pos + end subroutine mld_c_base_onelev_setsm + end interface interface - subroutine mld_c_base_onelev_setc(lv,what,val,info) + subroutine mld_c_base_onelev_setsv(lv,val,info,pos) + import :: psb_spk_, mld_c_onelev_type, mld_c_base_solver_type, & + & psb_ipk_, psb_long_int_k_, psb_desc_type + Implicit None + + ! Arguments + class(mld_c_onelev_type), target, intent(inout) :: lv + class(mld_c_base_solver_type), intent(in) :: val + integer(psb_ipk_), intent(out) :: info + character(len=*), optional, intent(in) :: pos + end subroutine mld_c_base_onelev_setsv + end interface + + interface + subroutine mld_c_base_onelev_setc(lv,what,val,info,pos) import :: psb_cspmat_type, psb_c_vect_type, psb_c_base_vect_type, & & psb_clinmap_type, psb_spk_, mld_c_onelev_type, & & psb_ipk_, psb_long_int_k_, psb_desc_type @@ -238,11 +271,12 @@ module mld_c_onelev_mod integer(psb_ipk_), intent(in) :: what character(len=*), intent(in) :: val integer(psb_ipk_), intent(out) :: info + character(len=*), optional, intent(in) :: pos end subroutine mld_c_base_onelev_setc end interface interface - subroutine mld_c_base_onelev_setr(lv,what,val,info) + subroutine mld_c_base_onelev_setr(lv,what,val,info,pos) import :: psb_cspmat_type, psb_c_vect_type, psb_c_base_vect_type, & & psb_clinmap_type, psb_spk_, mld_c_onelev_type, & & psb_ipk_, psb_long_int_k_, psb_desc_type @@ -252,12 +286,13 @@ module mld_c_onelev_mod integer(psb_ipk_), intent(in) :: what real(psb_spk_), intent(in) :: val integer(psb_ipk_), intent(out) :: info + character(len=*), optional, intent(in) :: pos end subroutine mld_c_base_onelev_setr end interface interface - subroutine mld_c_base_onelev_cseti(lv,what,val,info) + subroutine mld_c_base_onelev_cseti(lv,what,val,info,pos) import :: psb_cspmat_type, psb_c_vect_type, psb_c_base_vect_type, & & psb_clinmap_type, psb_spk_, mld_c_onelev_type, & & psb_ipk_, psb_long_int_k_, psb_desc_type @@ -268,11 +303,12 @@ module mld_c_onelev_mod character(len=*), intent(in) :: what integer(psb_ipk_), intent(in) :: val integer(psb_ipk_), intent(out) :: info + character(len=*), optional, intent(in) :: pos end subroutine mld_c_base_onelev_cseti end interface interface - subroutine mld_c_base_onelev_csetc(lv,what,val,info) + subroutine mld_c_base_onelev_csetc(lv,what,val,info,pos) import :: psb_cspmat_type, psb_c_vect_type, psb_c_base_vect_type, & & psb_clinmap_type, psb_spk_, mld_c_onelev_type, & & psb_ipk_, psb_long_int_k_, psb_desc_type @@ -282,11 +318,12 @@ module mld_c_onelev_mod character(len=*), intent(in) :: what character(len=*), intent(in) :: val integer(psb_ipk_), intent(out) :: info + character(len=*), optional, intent(in) :: pos end subroutine mld_c_base_onelev_csetc end interface interface - subroutine mld_c_base_onelev_csetr(lv,what,val,info) + subroutine mld_c_base_onelev_csetr(lv,what,val,info,pos) import :: psb_cspmat_type, psb_c_vect_type, psb_c_base_vect_type, & & psb_clinmap_type, psb_spk_, mld_c_onelev_type, & & psb_ipk_, psb_long_int_k_, psb_desc_type @@ -296,6 +333,7 @@ module mld_c_onelev_mod character(len=*), intent(in) :: what real(psb_spk_), intent(in) :: val integer(psb_ipk_), intent(out) :: info + character(len=*), optional, intent(in) :: pos end subroutine mld_c_base_onelev_csetr end interface @@ -331,6 +369,8 @@ contains val = 0 if (allocated(lv%sm)) & & val = lv%sm%get_nzeros() + if (allocated(lv%sm2a)) & + & val = val + lv%sm2a%get_nzeros() end function c_base_onelev_get_nzeros function c_base_onelev_sizeof(lv) result(val) @@ -344,6 +384,7 @@ contains val = val + lv%ac%sizeof() val = val + lv%map%sizeof() if (allocated(lv%sm)) val = val + lv%sm%sizeof() + if (allocated(lv%sm2a)) val = val + lv%sm2a%sizeof() end function c_base_onelev_sizeof @@ -354,7 +395,7 @@ contains nullify(lv%base_a) nullify(lv%base_desc) - + nullify(lv%sm2) end subroutine c_base_onelev_nullify ! @@ -370,9 +411,9 @@ contains subroutine c_base_onelev_default(lv) Implicit None - + ! Arguments - class(mld_c_onelev_type), intent(inout) :: lv + class(mld_c_onelev_type), target, intent(inout) :: lv lv%parms%sweeps = 1 lv%parms%sweeps_pre = 1 @@ -390,6 +431,12 @@ contains lv%parms%aggr_thresh = szero if (allocated(lv%sm)) call lv%sm%default() + if (allocated(lv%sm2a)) then + call lv%sm2a%default() + lv%sm2 => lv%sm2a + else + lv%sm2 => lv%sm + end if return @@ -403,8 +450,8 @@ contains ! Arguments class(mld_c_onelev_type), target, intent(inout) :: lv - class(mld_c_onelev_type), intent(inout) :: lvout - integer(psb_ipk_), intent(out) :: info + class(mld_c_onelev_type), target, intent(inout) :: lvout + integer(psb_ipk_), intent(out) :: info info = psb_success_ if (allocated(lv%sm)) then @@ -415,6 +462,16 @@ contains if (info==psb_success_) deallocate(lvout%sm,stat=info) end if end if + if (allocated(lv%sm2a)) then + call lv%sm%clone(lvout%sm2a,info) + lvout%sm2 => lvout%sm2a + else + if (allocated(lvout%sm2a)) then + call lvout%sm2a%free(info) + if (info==psb_success_) deallocate(lvout%sm2a,stat=info) + end if + lvout%sm2 => lvout%sm + end if if (info == psb_success_) call lv%parms%clone(lvout%parms,info) if (info == psb_success_) call lv%ac%clone(lvout%ac,info) if (info == psb_success_) call lv%desc_ac%clone(lvout%desc_ac,info) @@ -430,12 +487,21 @@ contains subroutine mld_c_onelev_move_alloc(a, b,info) use psb_base_mod implicit none - type(mld_c_onelev_type), intent(inout) :: a, b + type(mld_c_onelev_type), target, intent(inout) :: a, b integer(psb_ipk_), intent(out) :: info call b%free(info) b%parms = a%parms - call move_alloc(a%sm,b%sm) + if (associated(a%sm2,a%sm2a)) then + call move_alloc(a%sm,b%sm) + call move_alloc(a%sm2a,b%sm2a) + b%sm2 =>b%sm2a + else + call move_alloc(a%sm,b%sm) + call move_alloc(a%sm2a,b%sm2a) + b%sm2 =>b%sm + end if + 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) diff --git a/mlprec/mld_c_prec_mod.f90 b/mlprec/mld_c_prec_mod.f90 index b5e7e0bb..331dd65a 100644 --- a/mlprec/mld_c_prec_mod.f90 +++ b/mlprec/mld_c_prec_mod.f90 @@ -91,74 +91,81 @@ module mld_c_prec_mod contains - subroutine mld_c_iprecsetsm(p,val,info) + subroutine mld_c_iprecsetsm(p,val,info,pos) type(mld_cprec_type), intent(inout) :: p class(mld_c_base_smoother_type), intent(in) :: val integer(psb_ipk_), intent(out) :: info + character(len=*), optional, intent(in) :: pos - call p%set(val,info) + call p%set(val,info,pos=pos) end subroutine mld_c_iprecsetsm - subroutine mld_c_iprecsetsv(p,val,info) + subroutine mld_c_iprecsetsv(p,val,info,pos) type(mld_cprec_type), intent(inout) :: p class(mld_c_base_solver_type), intent(in) :: val integer(psb_ipk_), intent(out) :: info - - call p%set(val,info) + character(len=*), optional, intent(in) :: pos + call p%set(val,info, pos=pos) end subroutine mld_c_iprecsetsv - subroutine mld_c_iprecseti(p,what,val,info) + subroutine mld_c_iprecseti(p,what,val,info,pos) type(mld_cprec_type), intent(inout) :: p integer(psb_ipk_), intent(in) :: what integer(psb_ipk_), intent(in) :: val integer(psb_ipk_), intent(out) :: info + character(len=*), optional, intent(in) :: pos - call p%set(what,val,info) + call p%set(what,val,info,pos=pos) end subroutine mld_c_iprecseti - subroutine mld_c_iprecsetr(p,what,val,info) + subroutine mld_c_iprecsetr(p,what,val,info,pos) type(mld_cprec_type), intent(inout) :: p integer(psb_ipk_), intent(in) :: what real(psb_spk_), intent(in) :: val integer(psb_ipk_), intent(out) :: info + character(len=*), optional, intent(in) :: pos - call p%set(what,val,info) + call p%set(what,val,info,pos=pos) end subroutine mld_c_iprecsetr - subroutine mld_c_iprecsetc(p,what,val,info) + subroutine mld_c_iprecsetc(p,what,val,info,pos) type(mld_cprec_type), intent(inout) :: p integer(psb_ipk_), intent(in) :: what character(len=*), intent(in) :: val integer(psb_ipk_), intent(out) :: info + character(len=*), optional, intent(in) :: pos - call p%set(what,val,info) + call p%set(what,val,info,pos=pos) end subroutine mld_c_iprecsetc - subroutine mld_c_cprecseti(p,what,val,info) + subroutine mld_c_cprecseti(p,what,val,info,pos) type(mld_cprec_type), intent(inout) :: p character(len=*), intent(in) :: what integer(psb_ipk_), intent(in) :: val integer(psb_ipk_), intent(out) :: info + character(len=*), optional, intent(in) :: pos - call p%set(what,val,info) + call p%set(what,val,info,pos=pos) end subroutine mld_c_cprecseti - subroutine mld_c_cprecsetr(p,what,val,info) + subroutine mld_c_cprecsetr(p,what,val,info,pos) type(mld_cprec_type), intent(inout) :: p character(len=*), intent(in) :: what real(psb_spk_), intent(in) :: val integer(psb_ipk_), intent(out) :: info + character(len=*), optional, intent(in) :: pos - call p%set(what,val,info) + call p%set(what,val,info,pos=pos) end subroutine mld_c_cprecsetr - subroutine mld_c_cprecsetc(p,what,val,info) + subroutine mld_c_cprecsetc(p,what,val,info,pos) type(mld_cprec_type), intent(inout) :: p character(len=*), intent(in) :: what character(len=*), intent(in) :: val integer(psb_ipk_), intent(out) :: info + character(len=*), optional, intent(in) :: pos - call p%set(what,val,info) + call p%set(what,val,info,pos=pos) end subroutine mld_c_cprecsetc end module mld_c_prec_mod diff --git a/mlprec/mld_c_prec_type.f90 b/mlprec/mld_c_prec_type.f90 index 6c61d95e..a0db145b 100644 --- a/mlprec/mld_c_prec_type.f90 +++ b/mlprec/mld_c_prec_type.f90 @@ -175,23 +175,25 @@ module mld_c_prec_type end interface interface - subroutine mld_cprecsetsm(prec,val,info,ilev) + subroutine mld_cprecsetsm(prec,val,info,ilev,pos) import :: psb_cspmat_type, psb_desc_type, psb_spk_, & & mld_cprec_type, mld_c_base_smoother_type, psb_ipk_ - class(mld_cprec_type), intent(inout) :: prec + class(mld_cprec_type), target, intent(inout):: prec class(mld_c_base_smoother_type), intent(in) :: val - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), optional, intent(in) :: ilev + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional, intent(in) :: ilev + character(len=*), optional, intent(in) :: pos end subroutine mld_cprecsetsm - subroutine mld_cprecsetsv(prec,val,info,ilev) + subroutine mld_cprecsetsv(prec,val,info,ilev,pos) import :: psb_cspmat_type, psb_desc_type, psb_spk_, & & mld_cprec_type, mld_c_base_solver_type, psb_ipk_ class(mld_cprec_type), intent(inout) :: prec class(mld_c_base_solver_type), intent(in) :: val integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), optional, intent(in) :: ilev + character(len=*), optional, intent(in) :: pos end subroutine mld_cprecsetsv - subroutine mld_cprecseti(prec,what,val,info,ilev) + subroutine mld_cprecseti(prec,what,val,info,ilev,pos) import :: psb_cspmat_type, psb_desc_type, psb_spk_, & & mld_cprec_type, psb_ipk_ class(mld_cprec_type), intent(inout) :: prec @@ -199,8 +201,9 @@ module mld_c_prec_type integer(psb_ipk_), intent(in) :: val integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), optional, intent(in) :: ilev + character(len=*), optional, intent(in) :: pos end subroutine mld_cprecseti - subroutine mld_cprecsetr(prec,what,val,info,ilev) + subroutine mld_cprecsetr(prec,what,val,info,ilev,pos) import :: psb_cspmat_type, psb_desc_type, psb_spk_, & & mld_cprec_type, psb_ipk_ class(mld_cprec_type), intent(inout) :: prec @@ -208,8 +211,9 @@ module mld_c_prec_type real(psb_spk_), intent(in) :: val integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), optional, intent(in) :: ilev + character(len=*), optional, intent(in) :: pos end subroutine mld_cprecsetr - subroutine mld_cprecsetc(prec,what,string,info,ilev) + subroutine mld_cprecsetc(prec,what,string,info,ilev,pos) import :: psb_cspmat_type, psb_desc_type, psb_spk_, & & mld_cprec_type, psb_ipk_ class(mld_cprec_type), intent(inout) :: prec @@ -217,8 +221,9 @@ module mld_c_prec_type character(len=*), intent(in) :: string integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), optional, intent(in) :: ilev + character(len=*), optional, intent(in) :: pos end subroutine mld_cprecsetc - subroutine mld_ccprecseti(prec,what,val,info,ilev) + subroutine mld_ccprecseti(prec,what,val,info,ilev,pos) import :: psb_cspmat_type, psb_desc_type, psb_spk_, & & mld_cprec_type, psb_ipk_ class(mld_cprec_type), intent(inout) :: prec @@ -226,8 +231,9 @@ module mld_c_prec_type integer(psb_ipk_), intent(in) :: val integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), optional, intent(in) :: ilev + character(len=*), optional, intent(in) :: pos end subroutine mld_ccprecseti - subroutine mld_ccprecsetr(prec,what,val,info,ilev) + subroutine mld_ccprecsetr(prec,what,val,info,ilev,pos) import :: psb_cspmat_type, psb_desc_type, psb_spk_, & & mld_cprec_type, psb_ipk_ class(mld_cprec_type), intent(inout) :: prec @@ -235,8 +241,9 @@ module mld_c_prec_type real(psb_spk_), intent(in) :: val integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), optional, intent(in) :: ilev + character(len=*), optional, intent(in) :: pos end subroutine mld_ccprecsetr - subroutine mld_ccprecsetc(prec,what,string,info,ilev) + subroutine mld_ccprecsetc(prec,what,string,info,ilev,pos) import :: psb_cspmat_type, psb_desc_type, psb_spk_, & & mld_cprec_type, psb_ipk_ class(mld_cprec_type), intent(inout) :: prec @@ -244,6 +251,7 @@ module mld_c_prec_type character(len=*), intent(in) :: string integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), optional, intent(in) :: ilev + character(len=*), optional, intent(in) :: pos end subroutine mld_ccprecsetc end interface @@ -477,6 +485,18 @@ contains write(iout_,*) return end if + if (allocated(p%precv(1)%sm2a)) then + write(iout_,*) 'Post smoother details' + call p%precv(1)%sm2a%descr(info,iout=iout_) + if (nlev == 1) then + if (p%precv(1)%parms%sweeps > 1) then + write(iout_,*) ' Number of smoother sweeps : ',& + & p%precv(1)%parms%sweeps + end if + write(iout_,*) + return + end if + end if end if ! diff --git a/mlprec/mld_d_gs_solver.f90 b/mlprec/mld_d_gs_solver.f90 index feed37c5..72f22638 100644 --- a/mlprec/mld_d_gs_solver.f90 +++ b/mlprec/mld_d_gs_solver.f90 @@ -76,14 +76,13 @@ module mld_d_gs_solver type, extends(mld_d_gs_solver_type) :: mld_d_bwgs_solver_type contains - procedure, pass(sv) :: build => mld_d_bwgs_solver_bld - procedure, pass(sv) :: apply_v => mld_d_bwgs_solver_apply_vect - procedure, pass(sv) :: apply_a => mld_d_bwgs_solver_apply - procedure, nopass :: get_fmt => d_bwgs_solver_get_fmt - procedure, pass(sv) :: descr => d_bwgs_solver_descr + procedure, pass(sv) :: build => mld_d_bwgs_solver_bld + procedure, pass(sv) :: apply_v => mld_d_bwgs_solver_apply_vect + procedure, pass(sv) :: apply_a => mld_d_bwgs_solver_apply + procedure, nopass :: get_fmt => d_bwgs_solver_get_fmt + procedure, pass(sv) :: descr => d_bwgs_solver_descr end type mld_d_bwgs_solver_type - private :: d_gs_solver_bld, d_gs_solver_apply, & & d_gs_solver_free, d_gs_solver_seti, & @@ -566,8 +565,7 @@ contains val = .true. end function d_gs_solver_is_iterative - - + subroutine d_bwgs_solver_descr(sv,info,iout,coarse) Implicit None @@ -613,5 +611,4 @@ contains val = "Backward Gauss-Seidel solver" end function d_bwgs_solver_get_fmt - end module mld_d_gs_solver diff --git a/mlprec/mld_d_onelev_mod.f90 b/mlprec/mld_d_onelev_mod.f90 index 32f4c119..cf519b45 100644 --- a/mlprec/mld_d_onelev_mod.f90 +++ b/mlprec/mld_d_onelev_mod.f90 @@ -122,7 +122,7 @@ module mld_d_onelev_mod ! type mld_d_onelev_type class(mld_d_base_smoother_type), allocatable :: sm, sm2a - class(mld_d_base_smoother_type), pointer :: sm2 + class(mld_d_base_smoother_type), pointer :: sm2 => null() type(mld_dml_parms) :: parms type(psb_dspmat_type) :: ac integer(psb_ipk_) :: ac_nz_loc, ac_nz_tot @@ -147,7 +147,7 @@ module mld_d_onelev_mod procedure, pass(lv) :: csetc => mld_d_base_onelev_csetc procedure, pass(lv) :: setsm => mld_d_base_onelev_setsm procedure, pass(lv) :: setsv => mld_d_base_onelev_setsv - generic, public :: set => seti, setr, setc,& + generic, public :: set => seti, setr, setc, & & cseti, csetr, csetc, setsm, setsv procedure, pass(lv) :: sizeof => d_base_onelev_sizeof procedure, pass(lv) :: get_nzeros => d_base_onelev_get_nzeros @@ -231,7 +231,7 @@ module mld_d_onelev_mod character(len=*), optional, intent(in) :: pos end subroutine mld_d_base_onelev_seti end interface - + interface subroutine mld_d_base_onelev_setsm(lv,val,info,pos) import :: psb_dpk_, mld_d_onelev_type, mld_d_base_smoother_type, & @@ -411,7 +411,7 @@ contains subroutine d_base_onelev_default(lv) Implicit None - + ! Arguments class(mld_d_onelev_type), target, intent(inout) :: lv @@ -451,7 +451,7 @@ contains ! Arguments class(mld_d_onelev_type), target, intent(inout) :: lv class(mld_d_onelev_type), target, intent(inout) :: lvout - integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(out) :: info info = psb_success_ if (allocated(lv%sm)) then diff --git a/mlprec/mld_d_prec_type.f90 b/mlprec/mld_d_prec_type.f90 index d380e1d8..e8ffc729 100644 --- a/mlprec/mld_d_prec_type.f90 +++ b/mlprec/mld_d_prec_type.f90 @@ -178,10 +178,10 @@ module mld_d_prec_type subroutine mld_dprecsetsm(prec,val,info,ilev,pos) import :: psb_dspmat_type, psb_desc_type, psb_dpk_, & & mld_dprec_type, mld_d_base_smoother_type, psb_ipk_ - class(mld_dprec_type), target, intent(inout) :: prec + class(mld_dprec_type), target, intent(inout):: prec class(mld_d_base_smoother_type), intent(in) :: val - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), optional, intent(in) :: ilev + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional, intent(in) :: ilev character(len=*), optional, intent(in) :: pos end subroutine mld_dprecsetsm subroutine mld_dprecsetsv(prec,val,info,ilev,pos) diff --git a/mlprec/mld_s_gs_solver.f90 b/mlprec/mld_s_gs_solver.f90 index 7e040560..c37b3f23 100644 --- a/mlprec/mld_s_gs_solver.f90 +++ b/mlprec/mld_s_gs_solver.f90 @@ -74,15 +74,25 @@ module mld_s_gs_solver procedure, nopass :: is_iterative => d_gs_solver_is_iterative end type mld_s_gs_solver_type + type, extends(mld_s_gs_solver_type) :: mld_s_bwgs_solver_type + contains + procedure, pass(sv) :: build => mld_s_bwgs_solver_bld + procedure, pass(sv) :: apply_v => mld_s_bwgs_solver_apply_vect + procedure, pass(sv) :: apply_a => mld_s_bwgs_solver_apply + procedure, nopass :: get_fmt => s_bwgs_solver_get_fmt + procedure, pass(sv) :: descr => s_bwgs_solver_descr + end type mld_s_bwgs_solver_type - private :: d_gs_solver_bld, d_gs_solver_apply, & - & d_gs_solver_free, d_gs_solver_seti, & - & d_gs_solver_setc, d_gs_solver_setr,& - & d_gs_solver_descr, d_gs_solver_sizeof, & - & d_gs_solver_default, d_gs_solver_dmp, & - & d_gs_solver_apply_vect, d_gs_solver_get_nzeros, & - & d_gs_solver_get_fmt, d_gs_solver_check,& - & d_gs_solver_is_iterative + + private :: s_gs_solver_bld, s_gs_solver_apply, & + & s_gs_solver_free, s_gs_solver_seti, & + & s_gs_solver_setc, s_gs_solver_setr,& + & s_gs_solver_descr, s_gs_solver_sizeof, & + & s_gs_solver_default, s_gs_solver_dmp, & + & s_gs_solver_apply_vect, s_gs_solver_get_nzeros, & + & s_gs_solver_get_fmt, s_gs_solver_check,& + & s_gs_solver_is_iterative, & + & s_bwgs_solver_get_fmt, s_bwgs_solver_descr interface @@ -99,6 +109,19 @@ module mld_s_gs_solver real(psb_spk_),target, intent(inout) :: work(:) integer(psb_ipk_), intent(out) :: info end subroutine mld_s_gs_solver_apply_vect + subroutine mld_s_bwgs_solver_apply_vect(alpha,sv,x,beta,y,desc_data,trans,work,info) + import :: psb_desc_type, mld_s_bwgs_solver_type, psb_s_vect_type, psb_spk_, & + & psb_sspmat_type, psb_s_base_sparse_mat, psb_s_base_vect_type, psb_ipk_ + implicit none + type(psb_desc_type), intent(in) :: desc_data + class(mld_s_bwgs_solver_type), intent(inout) :: sv + type(psb_s_vect_type),intent(inout) :: x + type(psb_s_vect_type),intent(inout) :: y + real(psb_spk_),intent(in) :: alpha,beta + character(len=1),intent(in) :: trans + real(psb_spk_),target, intent(inout) :: work(:) + integer(psb_ipk_), intent(out) :: info + end subroutine mld_s_bwgs_solver_apply_vect end interface interface @@ -115,6 +138,19 @@ module mld_s_gs_solver real(psb_spk_),target, intent(inout) :: work(:) integer(psb_ipk_), intent(out) :: info end subroutine mld_s_gs_solver_apply + subroutine mld_s_bwgs_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info) + import :: psb_desc_type, mld_s_bwgs_solver_type, psb_s_vect_type, psb_spk_, & + & psb_sspmat_type, psb_s_base_sparse_mat, psb_s_base_vect_type, psb_ipk_ + implicit none + type(psb_desc_type), intent(in) :: desc_data + class(mld_s_bwgs_solver_type), intent(inout) :: sv + real(psb_spk_),intent(inout) :: x(:) + real(psb_spk_),intent(inout) :: y(:) + real(psb_spk_),intent(in) :: alpha,beta + character(len=1),intent(in) :: trans + real(psb_spk_),target, intent(inout) :: work(:) + integer(psb_ipk_), intent(out) :: info + end subroutine mld_s_bwgs_solver_apply end interface interface @@ -133,6 +169,21 @@ module mld_s_gs_solver class(psb_s_base_vect_type), intent(in), optional :: vmold class(psb_i_base_vect_type), intent(in), optional :: imold end subroutine mld_s_gs_solver_bld + subroutine mld_s_bwgs_solver_bld(a,desc_a,sv,upd,info,b,amold,vmold,imold) + import :: psb_desc_type, mld_s_bwgs_solver_type, psb_s_vect_type, psb_spk_, & + & psb_sspmat_type, psb_s_base_sparse_mat, psb_s_base_vect_type,& + & psb_ipk_, psb_i_base_vect_type + implicit none + type(psb_sspmat_type), intent(in), target :: a + Type(psb_desc_type), Intent(in) :: desc_a + class(mld_s_bwgs_solver_type), intent(inout) :: sv + character, intent(in) :: upd + integer(psb_ipk_), intent(out) :: info + type(psb_sspmat_type), intent(in), target, optional :: b + class(psb_s_base_sparse_mat), intent(in), optional :: amold + class(psb_s_base_vect_type), intent(in), optional :: vmold + class(psb_i_base_vect_type), intent(in), optional :: imold + end subroutine mld_s_bwgs_solver_bld end interface interface @@ -452,10 +503,10 @@ contains endif if (sv%eps<=dzero) then - write(iout_,*) ' Gauss-Seidel iterative solver with ',& + write(iout_,*) ' Forward Gauss-Seidel iterative solver with ',& & sv%sweeps,' sweeps' else - write(iout_,*) ' Gauss-Seidel iterative solver with tolerance',& + write(iout_,*) ' Forward Gauss-Seidel iterative solver with tolerance',& & sv%eps,' and maxit', sv%sweeps end if @@ -500,7 +551,7 @@ contains implicit none character(len=32) :: val - val = "Gauss-Seidel solver" + val = "Forward Gauss-Seidel solver" end function d_gs_solver_get_fmt @@ -514,5 +565,50 @@ contains val = .true. end function d_gs_solver_is_iterative + + subroutine s_bwgs_solver_descr(sv,info,iout,coarse) + + Implicit None + + ! Arguments + class(mld_s_bwgs_solver_type), intent(in) :: sv + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: iout + logical, intent(in), optional :: coarse + + ! Local variables + integer(psb_ipk_) :: err_act + character(len=20), parameter :: name='mld_s_bwgs_solver_descr' + integer(psb_ipk_) :: iout_ + + call psb_erractionsave(err_act) + info = psb_success_ + if (present(iout)) then + iout_ = iout + else + iout_ = 6 + endif + + if (sv%eps<=dzero) then + write(iout_,*) ' Backward Gauss-Seidel iterative solver with ',& + & sv%sweeps,' sweeps' + else + write(iout_,*) ' Backward Gauss-Seidel iterative solver with tolerance',& + & sv%eps,' and maxit', sv%sweeps + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + return + end subroutine s_bwgs_solver_descr + + function s_bwgs_solver_get_fmt() result(val) + implicit none + character(len=32) :: val + + val = "Backward Gauss-Seidel solver" + end function s_bwgs_solver_get_fmt end module mld_s_gs_solver diff --git a/mlprec/mld_s_onelev_mod.f90 b/mlprec/mld_s_onelev_mod.f90 index 7122f167..a7d32a5a 100644 --- a/mlprec/mld_s_onelev_mod.f90 +++ b/mlprec/mld_s_onelev_mod.f90 @@ -121,7 +121,8 @@ module mld_s_onelev_mod ! ! type mld_s_onelev_type - class(mld_s_base_smoother_type), allocatable :: sm + class(mld_s_base_smoother_type), allocatable :: sm, sm2a + class(mld_s_base_smoother_type), pointer :: sm2 => null() type(mld_sml_parms) :: parms type(psb_sspmat_type) :: ac integer(psb_ipk_) :: ac_nz_loc, ac_nz_tot @@ -144,7 +145,10 @@ module mld_s_onelev_mod procedure, pass(lv) :: cseti => mld_s_base_onelev_cseti procedure, pass(lv) :: csetr => mld_s_base_onelev_csetr procedure, pass(lv) :: csetc => mld_s_base_onelev_csetc - generic, public :: set => seti, setr, setc, cseti, csetr, csetc + procedure, pass(lv) :: setsm => mld_s_base_onelev_setsm + procedure, pass(lv) :: setsv => mld_s_base_onelev_setsv + generic, public :: set => seti, setr, setc, & + & cseti, csetr, csetc, setsm, setsv procedure, pass(lv) :: sizeof => s_base_onelev_sizeof procedure, pass(lv) :: get_nzeros => s_base_onelev_get_nzeros procedure, nopass :: stringval => mld_stringval @@ -213,7 +217,7 @@ module mld_s_onelev_mod end interface interface - subroutine mld_s_base_onelev_seti(lv,what,val,info) + subroutine mld_s_base_onelev_seti(lv,what,val,info,pos) import :: psb_sspmat_type, psb_s_vect_type, psb_s_base_vect_type, & & psb_slinmap_type, psb_spk_, mld_s_onelev_type, & & psb_ipk_, psb_long_int_k_, psb_desc_type @@ -224,11 +228,40 @@ module mld_s_onelev_mod integer(psb_ipk_), intent(in) :: what integer(psb_ipk_), intent(in) :: val integer(psb_ipk_), intent(out) :: info + character(len=*), optional, intent(in) :: pos end subroutine mld_s_base_onelev_seti end interface + + interface + subroutine mld_s_base_onelev_setsm(lv,val,info,pos) + import :: psb_spk_, mld_s_onelev_type, mld_s_base_smoother_type, & + & psb_ipk_, psb_long_int_k_, psb_desc_type + Implicit None + + ! Arguments + class(mld_s_onelev_type), target, intent(inout) :: lv + class(mld_s_base_smoother_type), intent(in) :: val + integer(psb_ipk_), intent(out) :: info + character(len=*), optional, intent(in) :: pos + end subroutine mld_s_base_onelev_setsm + end interface interface - subroutine mld_s_base_onelev_setc(lv,what,val,info) + subroutine mld_s_base_onelev_setsv(lv,val,info,pos) + import :: psb_spk_, mld_s_onelev_type, mld_s_base_solver_type, & + & psb_ipk_, psb_long_int_k_, psb_desc_type + Implicit None + + ! Arguments + class(mld_s_onelev_type), target, intent(inout) :: lv + class(mld_s_base_solver_type), intent(in) :: val + integer(psb_ipk_), intent(out) :: info + character(len=*), optional, intent(in) :: pos + end subroutine mld_s_base_onelev_setsv + end interface + + interface + subroutine mld_s_base_onelev_setc(lv,what,val,info,pos) import :: psb_sspmat_type, psb_s_vect_type, psb_s_base_vect_type, & & psb_slinmap_type, psb_spk_, mld_s_onelev_type, & & psb_ipk_, psb_long_int_k_, psb_desc_type @@ -238,11 +271,12 @@ module mld_s_onelev_mod integer(psb_ipk_), intent(in) :: what character(len=*), intent(in) :: val integer(psb_ipk_), intent(out) :: info + character(len=*), optional, intent(in) :: pos end subroutine mld_s_base_onelev_setc end interface interface - subroutine mld_s_base_onelev_setr(lv,what,val,info) + subroutine mld_s_base_onelev_setr(lv,what,val,info,pos) import :: psb_sspmat_type, psb_s_vect_type, psb_s_base_vect_type, & & psb_slinmap_type, psb_spk_, mld_s_onelev_type, & & psb_ipk_, psb_long_int_k_, psb_desc_type @@ -252,12 +286,13 @@ module mld_s_onelev_mod integer(psb_ipk_), intent(in) :: what real(psb_spk_), intent(in) :: val integer(psb_ipk_), intent(out) :: info + character(len=*), optional, intent(in) :: pos end subroutine mld_s_base_onelev_setr end interface interface - subroutine mld_s_base_onelev_cseti(lv,what,val,info) + subroutine mld_s_base_onelev_cseti(lv,what,val,info,pos) import :: psb_sspmat_type, psb_s_vect_type, psb_s_base_vect_type, & & psb_slinmap_type, psb_spk_, mld_s_onelev_type, & & psb_ipk_, psb_long_int_k_, psb_desc_type @@ -268,11 +303,12 @@ module mld_s_onelev_mod character(len=*), intent(in) :: what integer(psb_ipk_), intent(in) :: val integer(psb_ipk_), intent(out) :: info + character(len=*), optional, intent(in) :: pos end subroutine mld_s_base_onelev_cseti end interface interface - subroutine mld_s_base_onelev_csetc(lv,what,val,info) + subroutine mld_s_base_onelev_csetc(lv,what,val,info,pos) import :: psb_sspmat_type, psb_s_vect_type, psb_s_base_vect_type, & & psb_slinmap_type, psb_spk_, mld_s_onelev_type, & & psb_ipk_, psb_long_int_k_, psb_desc_type @@ -282,11 +318,12 @@ module mld_s_onelev_mod character(len=*), intent(in) :: what character(len=*), intent(in) :: val integer(psb_ipk_), intent(out) :: info + character(len=*), optional, intent(in) :: pos end subroutine mld_s_base_onelev_csetc end interface interface - subroutine mld_s_base_onelev_csetr(lv,what,val,info) + subroutine mld_s_base_onelev_csetr(lv,what,val,info,pos) import :: psb_sspmat_type, psb_s_vect_type, psb_s_base_vect_type, & & psb_slinmap_type, psb_spk_, mld_s_onelev_type, & & psb_ipk_, psb_long_int_k_, psb_desc_type @@ -296,6 +333,7 @@ module mld_s_onelev_mod character(len=*), intent(in) :: what real(psb_spk_), intent(in) :: val integer(psb_ipk_), intent(out) :: info + character(len=*), optional, intent(in) :: pos end subroutine mld_s_base_onelev_csetr end interface @@ -331,6 +369,8 @@ contains val = 0 if (allocated(lv%sm)) & & val = lv%sm%get_nzeros() + if (allocated(lv%sm2a)) & + & val = val + lv%sm2a%get_nzeros() end function s_base_onelev_get_nzeros function s_base_onelev_sizeof(lv) result(val) @@ -344,6 +384,7 @@ contains val = val + lv%ac%sizeof() val = val + lv%map%sizeof() if (allocated(lv%sm)) val = val + lv%sm%sizeof() + if (allocated(lv%sm2a)) val = val + lv%sm2a%sizeof() end function s_base_onelev_sizeof @@ -354,7 +395,7 @@ contains nullify(lv%base_a) nullify(lv%base_desc) - + nullify(lv%sm2) end subroutine s_base_onelev_nullify ! @@ -370,9 +411,9 @@ contains subroutine s_base_onelev_default(lv) Implicit None - + ! Arguments - class(mld_s_onelev_type), intent(inout) :: lv + class(mld_s_onelev_type), target, intent(inout) :: lv lv%parms%sweeps = 1 lv%parms%sweeps_pre = 1 @@ -390,6 +431,12 @@ contains lv%parms%aggr_thresh = szero if (allocated(lv%sm)) call lv%sm%default() + if (allocated(lv%sm2a)) then + call lv%sm2a%default() + lv%sm2 => lv%sm2a + else + lv%sm2 => lv%sm + end if return @@ -403,8 +450,8 @@ contains ! Arguments class(mld_s_onelev_type), target, intent(inout) :: lv - class(mld_s_onelev_type), intent(inout) :: lvout - integer(psb_ipk_), intent(out) :: info + class(mld_s_onelev_type), target, intent(inout) :: lvout + integer(psb_ipk_), intent(out) :: info info = psb_success_ if (allocated(lv%sm)) then @@ -415,6 +462,16 @@ contains if (info==psb_success_) deallocate(lvout%sm,stat=info) end if end if + if (allocated(lv%sm2a)) then + call lv%sm%clone(lvout%sm2a,info) + lvout%sm2 => lvout%sm2a + else + if (allocated(lvout%sm2a)) then + call lvout%sm2a%free(info) + if (info==psb_success_) deallocate(lvout%sm2a,stat=info) + end if + lvout%sm2 => lvout%sm + end if if (info == psb_success_) call lv%parms%clone(lvout%parms,info) if (info == psb_success_) call lv%ac%clone(lvout%ac,info) if (info == psb_success_) call lv%desc_ac%clone(lvout%desc_ac,info) @@ -430,12 +487,21 @@ contains subroutine mld_s_onelev_move_alloc(a, b,info) use psb_base_mod implicit none - type(mld_s_onelev_type), intent(inout) :: a, b + type(mld_s_onelev_type), target, intent(inout) :: a, b integer(psb_ipk_), intent(out) :: info call b%free(info) b%parms = a%parms - call move_alloc(a%sm,b%sm) + if (associated(a%sm2,a%sm2a)) then + call move_alloc(a%sm,b%sm) + call move_alloc(a%sm2a,b%sm2a) + b%sm2 =>b%sm2a + else + call move_alloc(a%sm,b%sm) + call move_alloc(a%sm2a,b%sm2a) + b%sm2 =>b%sm + end if + 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) diff --git a/mlprec/mld_s_prec_mod.f90 b/mlprec/mld_s_prec_mod.f90 index c8c0e4b2..594c79a9 100644 --- a/mlprec/mld_s_prec_mod.f90 +++ b/mlprec/mld_s_prec_mod.f90 @@ -91,74 +91,81 @@ module mld_s_prec_mod contains - subroutine mld_s_iprecsetsm(p,val,info) + subroutine mld_s_iprecsetsm(p,val,info,pos) type(mld_sprec_type), intent(inout) :: p class(mld_s_base_smoother_type), intent(in) :: val integer(psb_ipk_), intent(out) :: info + character(len=*), optional, intent(in) :: pos - call p%set(val,info) + call p%set(val,info,pos=pos) end subroutine mld_s_iprecsetsm - subroutine mld_s_iprecsetsv(p,val,info) + subroutine mld_s_iprecsetsv(p,val,info,pos) type(mld_sprec_type), intent(inout) :: p class(mld_s_base_solver_type), intent(in) :: val integer(psb_ipk_), intent(out) :: info - - call p%set(val,info) + character(len=*), optional, intent(in) :: pos + call p%set(val,info, pos=pos) end subroutine mld_s_iprecsetsv - subroutine mld_s_iprecseti(p,what,val,info) + subroutine mld_s_iprecseti(p,what,val,info,pos) type(mld_sprec_type), intent(inout) :: p integer(psb_ipk_), intent(in) :: what integer(psb_ipk_), intent(in) :: val integer(psb_ipk_), intent(out) :: info + character(len=*), optional, intent(in) :: pos - call p%set(what,val,info) + call p%set(what,val,info,pos=pos) end subroutine mld_s_iprecseti - subroutine mld_s_iprecsetr(p,what,val,info) + subroutine mld_s_iprecsetr(p,what,val,info,pos) type(mld_sprec_type), intent(inout) :: p integer(psb_ipk_), intent(in) :: what real(psb_spk_), intent(in) :: val integer(psb_ipk_), intent(out) :: info + character(len=*), optional, intent(in) :: pos - call p%set(what,val,info) + call p%set(what,val,info,pos=pos) end subroutine mld_s_iprecsetr - subroutine mld_s_iprecsetc(p,what,val,info) + subroutine mld_s_iprecsetc(p,what,val,info,pos) type(mld_sprec_type), intent(inout) :: p integer(psb_ipk_), intent(in) :: what character(len=*), intent(in) :: val integer(psb_ipk_), intent(out) :: info + character(len=*), optional, intent(in) :: pos - call p%set(what,val,info) + call p%set(what,val,info,pos=pos) end subroutine mld_s_iprecsetc - subroutine mld_s_cprecseti(p,what,val,info) + subroutine mld_s_cprecseti(p,what,val,info,pos) type(mld_sprec_type), intent(inout) :: p character(len=*), intent(in) :: what integer(psb_ipk_), intent(in) :: val integer(psb_ipk_), intent(out) :: info + character(len=*), optional, intent(in) :: pos - call p%set(what,val,info) + call p%set(what,val,info,pos=pos) end subroutine mld_s_cprecseti - subroutine mld_s_cprecsetr(p,what,val,info) + subroutine mld_s_cprecsetr(p,what,val,info,pos) type(mld_sprec_type), intent(inout) :: p character(len=*), intent(in) :: what real(psb_spk_), intent(in) :: val integer(psb_ipk_), intent(out) :: info + character(len=*), optional, intent(in) :: pos - call p%set(what,val,info) + call p%set(what,val,info,pos=pos) end subroutine mld_s_cprecsetr - subroutine mld_s_cprecsetc(p,what,val,info) + subroutine mld_s_cprecsetc(p,what,val,info,pos) type(mld_sprec_type), intent(inout) :: p character(len=*), intent(in) :: what character(len=*), intent(in) :: val integer(psb_ipk_), intent(out) :: info + character(len=*), optional, intent(in) :: pos - call p%set(what,val,info) + call p%set(what,val,info,pos=pos) end subroutine mld_s_cprecsetc end module mld_s_prec_mod diff --git a/mlprec/mld_s_prec_type.f90 b/mlprec/mld_s_prec_type.f90 index 3b1d30f7..aa538f61 100644 --- a/mlprec/mld_s_prec_type.f90 +++ b/mlprec/mld_s_prec_type.f90 @@ -175,23 +175,25 @@ module mld_s_prec_type end interface interface - subroutine mld_sprecsetsm(prec,val,info,ilev) + subroutine mld_sprecsetsm(prec,val,info,ilev,pos) import :: psb_sspmat_type, psb_desc_type, psb_spk_, & & mld_sprec_type, mld_s_base_smoother_type, psb_ipk_ - class(mld_sprec_type), intent(inout) :: prec + class(mld_sprec_type), target, intent(inout):: prec class(mld_s_base_smoother_type), intent(in) :: val - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), optional, intent(in) :: ilev + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional, intent(in) :: ilev + character(len=*), optional, intent(in) :: pos end subroutine mld_sprecsetsm - subroutine mld_sprecsetsv(prec,val,info,ilev) + subroutine mld_sprecsetsv(prec,val,info,ilev,pos) import :: psb_sspmat_type, psb_desc_type, psb_spk_, & & mld_sprec_type, mld_s_base_solver_type, psb_ipk_ class(mld_sprec_type), intent(inout) :: prec class(mld_s_base_solver_type), intent(in) :: val integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), optional, intent(in) :: ilev + character(len=*), optional, intent(in) :: pos end subroutine mld_sprecsetsv - subroutine mld_sprecseti(prec,what,val,info,ilev) + subroutine mld_sprecseti(prec,what,val,info,ilev,pos) import :: psb_sspmat_type, psb_desc_type, psb_spk_, & & mld_sprec_type, psb_ipk_ class(mld_sprec_type), intent(inout) :: prec @@ -199,8 +201,9 @@ module mld_s_prec_type integer(psb_ipk_), intent(in) :: val integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), optional, intent(in) :: ilev + character(len=*), optional, intent(in) :: pos end subroutine mld_sprecseti - subroutine mld_sprecsetr(prec,what,val,info,ilev) + subroutine mld_sprecsetr(prec,what,val,info,ilev,pos) import :: psb_sspmat_type, psb_desc_type, psb_spk_, & & mld_sprec_type, psb_ipk_ class(mld_sprec_type), intent(inout) :: prec @@ -208,8 +211,9 @@ module mld_s_prec_type real(psb_spk_), intent(in) :: val integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), optional, intent(in) :: ilev + character(len=*), optional, intent(in) :: pos end subroutine mld_sprecsetr - subroutine mld_sprecsetc(prec,what,string,info,ilev) + subroutine mld_sprecsetc(prec,what,string,info,ilev,pos) import :: psb_sspmat_type, psb_desc_type, psb_spk_, & & mld_sprec_type, psb_ipk_ class(mld_sprec_type), intent(inout) :: prec @@ -217,8 +221,9 @@ module mld_s_prec_type character(len=*), intent(in) :: string integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), optional, intent(in) :: ilev + character(len=*), optional, intent(in) :: pos end subroutine mld_sprecsetc - subroutine mld_scprecseti(prec,what,val,info,ilev) + subroutine mld_scprecseti(prec,what,val,info,ilev,pos) import :: psb_sspmat_type, psb_desc_type, psb_spk_, & & mld_sprec_type, psb_ipk_ class(mld_sprec_type), intent(inout) :: prec @@ -226,8 +231,9 @@ module mld_s_prec_type integer(psb_ipk_), intent(in) :: val integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), optional, intent(in) :: ilev + character(len=*), optional, intent(in) :: pos end subroutine mld_scprecseti - subroutine mld_scprecsetr(prec,what,val,info,ilev) + subroutine mld_scprecsetr(prec,what,val,info,ilev,pos) import :: psb_sspmat_type, psb_desc_type, psb_spk_, & & mld_sprec_type, psb_ipk_ class(mld_sprec_type), intent(inout) :: prec @@ -235,8 +241,9 @@ module mld_s_prec_type real(psb_spk_), intent(in) :: val integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), optional, intent(in) :: ilev + character(len=*), optional, intent(in) :: pos end subroutine mld_scprecsetr - subroutine mld_scprecsetc(prec,what,string,info,ilev) + subroutine mld_scprecsetc(prec,what,string,info,ilev,pos) import :: psb_sspmat_type, psb_desc_type, psb_spk_, & & mld_sprec_type, psb_ipk_ class(mld_sprec_type), intent(inout) :: prec @@ -244,6 +251,7 @@ module mld_s_prec_type character(len=*), intent(in) :: string integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), optional, intent(in) :: ilev + character(len=*), optional, intent(in) :: pos end subroutine mld_scprecsetc end interface @@ -477,6 +485,18 @@ contains write(iout_,*) return end if + if (allocated(p%precv(1)%sm2a)) then + write(iout_,*) 'Post smoother details' + call p%precv(1)%sm2a%descr(info,iout=iout_) + if (nlev == 1) then + if (p%precv(1)%parms%sweeps > 1) then + write(iout_,*) ' Number of smoother sweeps : ',& + & p%precv(1)%parms%sweeps + end if + write(iout_,*) + return + end if + end if end if ! diff --git a/mlprec/mld_z_gs_solver.f90 b/mlprec/mld_z_gs_solver.f90 index 1bbac45e..a9a13679 100644 --- a/mlprec/mld_z_gs_solver.f90 +++ b/mlprec/mld_z_gs_solver.f90 @@ -74,15 +74,25 @@ module mld_z_gs_solver procedure, nopass :: is_iterative => d_gs_solver_is_iterative end type mld_z_gs_solver_type + type, extends(mld_z_gs_solver_type) :: mld_z_bwgs_solver_type + contains + procedure, pass(sv) :: build => mld_z_bwgs_solver_bld + procedure, pass(sv) :: apply_v => mld_z_bwgs_solver_apply_vect + procedure, pass(sv) :: apply_a => mld_z_bwgs_solver_apply + procedure, nopass :: get_fmt => z_bwgs_solver_get_fmt + procedure, pass(sv) :: descr => z_bwgs_solver_descr + end type mld_z_bwgs_solver_type - private :: d_gs_solver_bld, d_gs_solver_apply, & - & d_gs_solver_free, d_gs_solver_seti, & - & d_gs_solver_setc, d_gs_solver_setr,& - & d_gs_solver_descr, d_gs_solver_sizeof, & - & d_gs_solver_default, d_gs_solver_dmp, & - & d_gs_solver_apply_vect, d_gs_solver_get_nzeros, & - & d_gs_solver_get_fmt, d_gs_solver_check,& - & d_gs_solver_is_iterative + + private :: z_gs_solver_bld, z_gs_solver_apply, & + & z_gs_solver_free, z_gs_solver_seti, & + & z_gs_solver_setc, z_gs_solver_setr,& + & z_gs_solver_descr, z_gs_solver_sizeof, & + & z_gs_solver_default, z_gs_solver_dmp, & + & z_gs_solver_apply_vect, z_gs_solver_get_nzeros, & + & z_gs_solver_get_fmt, z_gs_solver_check,& + & z_gs_solver_is_iterative, & + & z_bwgs_solver_get_fmt, z_bwgs_solver_descr interface @@ -99,6 +109,19 @@ module mld_z_gs_solver complex(psb_dpk_),target, intent(inout) :: work(:) integer(psb_ipk_), intent(out) :: info end subroutine mld_z_gs_solver_apply_vect + subroutine mld_z_bwgs_solver_apply_vect(alpha,sv,x,beta,y,desc_data,trans,work,info) + import :: psb_desc_type, mld_z_bwgs_solver_type, psb_z_vect_type, psb_dpk_, & + & psb_zspmat_type, psb_z_base_sparse_mat, psb_z_base_vect_type, psb_ipk_ + implicit none + type(psb_desc_type), intent(in) :: desc_data + class(mld_z_bwgs_solver_type), intent(inout) :: sv + type(psb_z_vect_type),intent(inout) :: x + type(psb_z_vect_type),intent(inout) :: y + complex(psb_dpk_),intent(in) :: alpha,beta + character(len=1),intent(in) :: trans + complex(psb_dpk_),target, intent(inout) :: work(:) + integer(psb_ipk_), intent(out) :: info + end subroutine mld_z_bwgs_solver_apply_vect end interface interface @@ -115,6 +138,19 @@ module mld_z_gs_solver complex(psb_dpk_),target, intent(inout) :: work(:) integer(psb_ipk_), intent(out) :: info end subroutine mld_z_gs_solver_apply + subroutine mld_z_bwgs_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info) + import :: psb_desc_type, mld_z_bwgs_solver_type, psb_z_vect_type, psb_dpk_, & + & psb_zspmat_type, psb_z_base_sparse_mat, psb_z_base_vect_type, psb_ipk_ + implicit none + type(psb_desc_type), intent(in) :: desc_data + class(mld_z_bwgs_solver_type), intent(inout) :: sv + complex(psb_dpk_),intent(inout) :: x(:) + complex(psb_dpk_),intent(inout) :: y(:) + complex(psb_dpk_),intent(in) :: alpha,beta + character(len=1),intent(in) :: trans + complex(psb_dpk_),target, intent(inout) :: work(:) + integer(psb_ipk_), intent(out) :: info + end subroutine mld_z_bwgs_solver_apply end interface interface @@ -133,6 +169,21 @@ module mld_z_gs_solver class(psb_z_base_vect_type), intent(in), optional :: vmold class(psb_i_base_vect_type), intent(in), optional :: imold end subroutine mld_z_gs_solver_bld + subroutine mld_z_bwgs_solver_bld(a,desc_a,sv,upd,info,b,amold,vmold,imold) + import :: psb_desc_type, mld_z_bwgs_solver_type, psb_z_vect_type, psb_dpk_, & + & psb_zspmat_type, psb_z_base_sparse_mat, psb_z_base_vect_type,& + & psb_ipk_, psb_i_base_vect_type + implicit none + type(psb_zspmat_type), intent(in), target :: a + Type(psb_desc_type), Intent(in) :: desc_a + class(mld_z_bwgs_solver_type), intent(inout) :: sv + character, intent(in) :: upd + integer(psb_ipk_), intent(out) :: info + type(psb_zspmat_type), intent(in), target, optional :: b + class(psb_z_base_sparse_mat), intent(in), optional :: amold + class(psb_z_base_vect_type), intent(in), optional :: vmold + class(psb_i_base_vect_type), intent(in), optional :: imold + end subroutine mld_z_bwgs_solver_bld end interface interface @@ -452,10 +503,10 @@ contains endif if (sv%eps<=dzero) then - write(iout_,*) ' Gauss-Seidel iterative solver with ',& + write(iout_,*) ' Forward Gauss-Seidel iterative solver with ',& & sv%sweeps,' sweeps' else - write(iout_,*) ' Gauss-Seidel iterative solver with tolerance',& + write(iout_,*) ' Forward Gauss-Seidel iterative solver with tolerance',& & sv%eps,' and maxit', sv%sweeps end if @@ -500,7 +551,7 @@ contains implicit none character(len=32) :: val - val = "Gauss-Seidel solver" + val = "Forward Gauss-Seidel solver" end function d_gs_solver_get_fmt @@ -514,5 +565,50 @@ contains val = .true. end function d_gs_solver_is_iterative + + subroutine z_bwgs_solver_descr(sv,info,iout,coarse) + + Implicit None + + ! Arguments + class(mld_z_bwgs_solver_type), intent(in) :: sv + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), intent(in), optional :: iout + logical, intent(in), optional :: coarse + + ! Local variables + integer(psb_ipk_) :: err_act + character(len=20), parameter :: name='mld_z_bwgs_solver_descr' + integer(psb_ipk_) :: iout_ + + call psb_erractionsave(err_act) + info = psb_success_ + if (present(iout)) then + iout_ = iout + else + iout_ = 6 + endif + + if (sv%eps<=dzero) then + write(iout_,*) ' Backward Gauss-Seidel iterative solver with ',& + & sv%sweeps,' sweeps' + else + write(iout_,*) ' Backward Gauss-Seidel iterative solver with tolerance',& + & sv%eps,' and maxit', sv%sweeps + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + return + end subroutine z_bwgs_solver_descr + + function z_bwgs_solver_get_fmt() result(val) + implicit none + character(len=32) :: val + + val = "Backward Gauss-Seidel solver" + end function z_bwgs_solver_get_fmt end module mld_z_gs_solver diff --git a/mlprec/mld_z_onelev_mod.f90 b/mlprec/mld_z_onelev_mod.f90 index e94a7d5c..c1ae6c90 100644 --- a/mlprec/mld_z_onelev_mod.f90 +++ b/mlprec/mld_z_onelev_mod.f90 @@ -121,7 +121,8 @@ module mld_z_onelev_mod ! ! type mld_z_onelev_type - class(mld_z_base_smoother_type), allocatable :: sm + class(mld_z_base_smoother_type), allocatable :: sm, sm2a + class(mld_z_base_smoother_type), pointer :: sm2 => null() type(mld_dml_parms) :: parms type(psb_zspmat_type) :: ac integer(psb_ipk_) :: ac_nz_loc, ac_nz_tot @@ -144,7 +145,10 @@ module mld_z_onelev_mod procedure, pass(lv) :: cseti => mld_z_base_onelev_cseti procedure, pass(lv) :: csetr => mld_z_base_onelev_csetr procedure, pass(lv) :: csetc => mld_z_base_onelev_csetc - generic, public :: set => seti, setr, setc, cseti, csetr, csetc + procedure, pass(lv) :: setsm => mld_z_base_onelev_setsm + procedure, pass(lv) :: setsv => mld_z_base_onelev_setsv + generic, public :: set => seti, setr, setc, & + & cseti, csetr, csetc, setsm, setsv procedure, pass(lv) :: sizeof => z_base_onelev_sizeof procedure, pass(lv) :: get_nzeros => z_base_onelev_get_nzeros procedure, nopass :: stringval => mld_stringval @@ -213,7 +217,7 @@ module mld_z_onelev_mod end interface interface - subroutine mld_z_base_onelev_seti(lv,what,val,info) + subroutine mld_z_base_onelev_seti(lv,what,val,info,pos) import :: psb_zspmat_type, psb_z_vect_type, psb_z_base_vect_type, & & psb_zlinmap_type, psb_dpk_, mld_z_onelev_type, & & psb_ipk_, psb_long_int_k_, psb_desc_type @@ -224,11 +228,40 @@ module mld_z_onelev_mod integer(psb_ipk_), intent(in) :: what integer(psb_ipk_), intent(in) :: val integer(psb_ipk_), intent(out) :: info + character(len=*), optional, intent(in) :: pos end subroutine mld_z_base_onelev_seti end interface + + interface + subroutine mld_z_base_onelev_setsm(lv,val,info,pos) + import :: psb_dpk_, mld_z_onelev_type, mld_z_base_smoother_type, & + & psb_ipk_, psb_long_int_k_, psb_desc_type + Implicit None + + ! Arguments + class(mld_z_onelev_type), target, intent(inout) :: lv + class(mld_z_base_smoother_type), intent(in) :: val + integer(psb_ipk_), intent(out) :: info + character(len=*), optional, intent(in) :: pos + end subroutine mld_z_base_onelev_setsm + end interface interface - subroutine mld_z_base_onelev_setc(lv,what,val,info) + subroutine mld_z_base_onelev_setsv(lv,val,info,pos) + import :: psb_dpk_, mld_z_onelev_type, mld_z_base_solver_type, & + & psb_ipk_, psb_long_int_k_, psb_desc_type + Implicit None + + ! Arguments + class(mld_z_onelev_type), target, intent(inout) :: lv + class(mld_z_base_solver_type), intent(in) :: val + integer(psb_ipk_), intent(out) :: info + character(len=*), optional, intent(in) :: pos + end subroutine mld_z_base_onelev_setsv + end interface + + interface + subroutine mld_z_base_onelev_setc(lv,what,val,info,pos) import :: psb_zspmat_type, psb_z_vect_type, psb_z_base_vect_type, & & psb_zlinmap_type, psb_dpk_, mld_z_onelev_type, & & psb_ipk_, psb_long_int_k_, psb_desc_type @@ -238,11 +271,12 @@ module mld_z_onelev_mod integer(psb_ipk_), intent(in) :: what character(len=*), intent(in) :: val integer(psb_ipk_), intent(out) :: info + character(len=*), optional, intent(in) :: pos end subroutine mld_z_base_onelev_setc end interface interface - subroutine mld_z_base_onelev_setr(lv,what,val,info) + subroutine mld_z_base_onelev_setr(lv,what,val,info,pos) import :: psb_zspmat_type, psb_z_vect_type, psb_z_base_vect_type, & & psb_zlinmap_type, psb_dpk_, mld_z_onelev_type, & & psb_ipk_, psb_long_int_k_, psb_desc_type @@ -252,12 +286,13 @@ module mld_z_onelev_mod integer(psb_ipk_), intent(in) :: what real(psb_dpk_), intent(in) :: val integer(psb_ipk_), intent(out) :: info + character(len=*), optional, intent(in) :: pos end subroutine mld_z_base_onelev_setr end interface interface - subroutine mld_z_base_onelev_cseti(lv,what,val,info) + subroutine mld_z_base_onelev_cseti(lv,what,val,info,pos) import :: psb_zspmat_type, psb_z_vect_type, psb_z_base_vect_type, & & psb_zlinmap_type, psb_dpk_, mld_z_onelev_type, & & psb_ipk_, psb_long_int_k_, psb_desc_type @@ -268,11 +303,12 @@ module mld_z_onelev_mod character(len=*), intent(in) :: what integer(psb_ipk_), intent(in) :: val integer(psb_ipk_), intent(out) :: info + character(len=*), optional, intent(in) :: pos end subroutine mld_z_base_onelev_cseti end interface interface - subroutine mld_z_base_onelev_csetc(lv,what,val,info) + subroutine mld_z_base_onelev_csetc(lv,what,val,info,pos) import :: psb_zspmat_type, psb_z_vect_type, psb_z_base_vect_type, & & psb_zlinmap_type, psb_dpk_, mld_z_onelev_type, & & psb_ipk_, psb_long_int_k_, psb_desc_type @@ -282,11 +318,12 @@ module mld_z_onelev_mod character(len=*), intent(in) :: what character(len=*), intent(in) :: val integer(psb_ipk_), intent(out) :: info + character(len=*), optional, intent(in) :: pos end subroutine mld_z_base_onelev_csetc end interface interface - subroutine mld_z_base_onelev_csetr(lv,what,val,info) + subroutine mld_z_base_onelev_csetr(lv,what,val,info,pos) import :: psb_zspmat_type, psb_z_vect_type, psb_z_base_vect_type, & & psb_zlinmap_type, psb_dpk_, mld_z_onelev_type, & & psb_ipk_, psb_long_int_k_, psb_desc_type @@ -296,6 +333,7 @@ module mld_z_onelev_mod character(len=*), intent(in) :: what real(psb_dpk_), intent(in) :: val integer(psb_ipk_), intent(out) :: info + character(len=*), optional, intent(in) :: pos end subroutine mld_z_base_onelev_csetr end interface @@ -331,6 +369,8 @@ contains val = 0 if (allocated(lv%sm)) & & val = lv%sm%get_nzeros() + if (allocated(lv%sm2a)) & + & val = val + lv%sm2a%get_nzeros() end function z_base_onelev_get_nzeros function z_base_onelev_sizeof(lv) result(val) @@ -344,6 +384,7 @@ contains val = val + lv%ac%sizeof() val = val + lv%map%sizeof() if (allocated(lv%sm)) val = val + lv%sm%sizeof() + if (allocated(lv%sm2a)) val = val + lv%sm2a%sizeof() end function z_base_onelev_sizeof @@ -354,7 +395,7 @@ contains nullify(lv%base_a) nullify(lv%base_desc) - + nullify(lv%sm2) end subroutine z_base_onelev_nullify ! @@ -370,9 +411,9 @@ contains subroutine z_base_onelev_default(lv) Implicit None - + ! Arguments - class(mld_z_onelev_type), intent(inout) :: lv + class(mld_z_onelev_type), target, intent(inout) :: lv lv%parms%sweeps = 1 lv%parms%sweeps_pre = 1 @@ -390,6 +431,12 @@ contains lv%parms%aggr_thresh = dzero if (allocated(lv%sm)) call lv%sm%default() + if (allocated(lv%sm2a)) then + call lv%sm2a%default() + lv%sm2 => lv%sm2a + else + lv%sm2 => lv%sm + end if return @@ -403,8 +450,8 @@ contains ! Arguments class(mld_z_onelev_type), target, intent(inout) :: lv - class(mld_z_onelev_type), intent(inout) :: lvout - integer(psb_ipk_), intent(out) :: info + class(mld_z_onelev_type), target, intent(inout) :: lvout + integer(psb_ipk_), intent(out) :: info info = psb_success_ if (allocated(lv%sm)) then @@ -415,6 +462,16 @@ contains if (info==psb_success_) deallocate(lvout%sm,stat=info) end if end if + if (allocated(lv%sm2a)) then + call lv%sm%clone(lvout%sm2a,info) + lvout%sm2 => lvout%sm2a + else + if (allocated(lvout%sm2a)) then + call lvout%sm2a%free(info) + if (info==psb_success_) deallocate(lvout%sm2a,stat=info) + end if + lvout%sm2 => lvout%sm + end if if (info == psb_success_) call lv%parms%clone(lvout%parms,info) if (info == psb_success_) call lv%ac%clone(lvout%ac,info) if (info == psb_success_) call lv%desc_ac%clone(lvout%desc_ac,info) @@ -430,12 +487,21 @@ contains subroutine mld_z_onelev_move_alloc(a, b,info) use psb_base_mod implicit none - type(mld_z_onelev_type), intent(inout) :: a, b + type(mld_z_onelev_type), target, intent(inout) :: a, b integer(psb_ipk_), intent(out) :: info call b%free(info) b%parms = a%parms - call move_alloc(a%sm,b%sm) + if (associated(a%sm2,a%sm2a)) then + call move_alloc(a%sm,b%sm) + call move_alloc(a%sm2a,b%sm2a) + b%sm2 =>b%sm2a + else + call move_alloc(a%sm,b%sm) + call move_alloc(a%sm2a,b%sm2a) + b%sm2 =>b%sm + end if + 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) diff --git a/mlprec/mld_z_prec_mod.f90 b/mlprec/mld_z_prec_mod.f90 index b1259522..1360c6cc 100644 --- a/mlprec/mld_z_prec_mod.f90 +++ b/mlprec/mld_z_prec_mod.f90 @@ -91,74 +91,81 @@ module mld_z_prec_mod contains - subroutine mld_z_iprecsetsm(p,val,info) + subroutine mld_z_iprecsetsm(p,val,info,pos) type(mld_zprec_type), intent(inout) :: p class(mld_z_base_smoother_type), intent(in) :: val integer(psb_ipk_), intent(out) :: info + character(len=*), optional, intent(in) :: pos - call p%set(val,info) + call p%set(val,info,pos=pos) end subroutine mld_z_iprecsetsm - subroutine mld_z_iprecsetsv(p,val,info) + subroutine mld_z_iprecsetsv(p,val,info,pos) type(mld_zprec_type), intent(inout) :: p class(mld_z_base_solver_type), intent(in) :: val integer(psb_ipk_), intent(out) :: info - - call p%set(val,info) + character(len=*), optional, intent(in) :: pos + call p%set(val,info, pos=pos) end subroutine mld_z_iprecsetsv - subroutine mld_z_iprecseti(p,what,val,info) + subroutine mld_z_iprecseti(p,what,val,info,pos) type(mld_zprec_type), intent(inout) :: p integer(psb_ipk_), intent(in) :: what integer(psb_ipk_), intent(in) :: val integer(psb_ipk_), intent(out) :: info + character(len=*), optional, intent(in) :: pos - call p%set(what,val,info) + call p%set(what,val,info,pos=pos) end subroutine mld_z_iprecseti - subroutine mld_z_iprecsetr(p,what,val,info) + subroutine mld_z_iprecsetr(p,what,val,info,pos) type(mld_zprec_type), intent(inout) :: p integer(psb_ipk_), intent(in) :: what real(psb_dpk_), intent(in) :: val integer(psb_ipk_), intent(out) :: info + character(len=*), optional, intent(in) :: pos - call p%set(what,val,info) + call p%set(what,val,info,pos=pos) end subroutine mld_z_iprecsetr - subroutine mld_z_iprecsetc(p,what,val,info) + subroutine mld_z_iprecsetc(p,what,val,info,pos) type(mld_zprec_type), intent(inout) :: p integer(psb_ipk_), intent(in) :: what character(len=*), intent(in) :: val integer(psb_ipk_), intent(out) :: info + character(len=*), optional, intent(in) :: pos - call p%set(what,val,info) + call p%set(what,val,info,pos=pos) end subroutine mld_z_iprecsetc - subroutine mld_z_cprecseti(p,what,val,info) + subroutine mld_z_cprecseti(p,what,val,info,pos) type(mld_zprec_type), intent(inout) :: p character(len=*), intent(in) :: what integer(psb_ipk_), intent(in) :: val integer(psb_ipk_), intent(out) :: info + character(len=*), optional, intent(in) :: pos - call p%set(what,val,info) + call p%set(what,val,info,pos=pos) end subroutine mld_z_cprecseti - subroutine mld_z_cprecsetr(p,what,val,info) + subroutine mld_z_cprecsetr(p,what,val,info,pos) type(mld_zprec_type), intent(inout) :: p character(len=*), intent(in) :: what real(psb_dpk_), intent(in) :: val integer(psb_ipk_), intent(out) :: info + character(len=*), optional, intent(in) :: pos - call p%set(what,val,info) + call p%set(what,val,info,pos=pos) end subroutine mld_z_cprecsetr - subroutine mld_z_cprecsetc(p,what,val,info) + subroutine mld_z_cprecsetc(p,what,val,info,pos) type(mld_zprec_type), intent(inout) :: p character(len=*), intent(in) :: what character(len=*), intent(in) :: val integer(psb_ipk_), intent(out) :: info + character(len=*), optional, intent(in) :: pos - call p%set(what,val,info) + call p%set(what,val,info,pos=pos) end subroutine mld_z_cprecsetc end module mld_z_prec_mod diff --git a/mlprec/mld_z_prec_type.f90 b/mlprec/mld_z_prec_type.f90 index 0eda8dd0..d5a47aab 100644 --- a/mlprec/mld_z_prec_type.f90 +++ b/mlprec/mld_z_prec_type.f90 @@ -175,23 +175,25 @@ module mld_z_prec_type end interface interface - subroutine mld_zprecsetsm(prec,val,info,ilev) + subroutine mld_zprecsetsm(prec,val,info,ilev,pos) import :: psb_zspmat_type, psb_desc_type, psb_dpk_, & & mld_zprec_type, mld_z_base_smoother_type, psb_ipk_ - class(mld_zprec_type), intent(inout) :: prec + class(mld_zprec_type), target, intent(inout):: prec class(mld_z_base_smoother_type), intent(in) :: val - integer(psb_ipk_), intent(out) :: info - integer(psb_ipk_), optional, intent(in) :: ilev + integer(psb_ipk_), intent(out) :: info + integer(psb_ipk_), optional, intent(in) :: ilev + character(len=*), optional, intent(in) :: pos end subroutine mld_zprecsetsm - subroutine mld_zprecsetsv(prec,val,info,ilev) + subroutine mld_zprecsetsv(prec,val,info,ilev,pos) import :: psb_zspmat_type, psb_desc_type, psb_dpk_, & & mld_zprec_type, mld_z_base_solver_type, psb_ipk_ class(mld_zprec_type), intent(inout) :: prec class(mld_z_base_solver_type), intent(in) :: val integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), optional, intent(in) :: ilev + character(len=*), optional, intent(in) :: pos end subroutine mld_zprecsetsv - subroutine mld_zprecseti(prec,what,val,info,ilev) + subroutine mld_zprecseti(prec,what,val,info,ilev,pos) import :: psb_zspmat_type, psb_desc_type, psb_dpk_, & & mld_zprec_type, psb_ipk_ class(mld_zprec_type), intent(inout) :: prec @@ -199,8 +201,9 @@ module mld_z_prec_type integer(psb_ipk_), intent(in) :: val integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), optional, intent(in) :: ilev + character(len=*), optional, intent(in) :: pos end subroutine mld_zprecseti - subroutine mld_zprecsetr(prec,what,val,info,ilev) + subroutine mld_zprecsetr(prec,what,val,info,ilev,pos) import :: psb_zspmat_type, psb_desc_type, psb_dpk_, & & mld_zprec_type, psb_ipk_ class(mld_zprec_type), intent(inout) :: prec @@ -208,8 +211,9 @@ module mld_z_prec_type real(psb_dpk_), intent(in) :: val integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), optional, intent(in) :: ilev + character(len=*), optional, intent(in) :: pos end subroutine mld_zprecsetr - subroutine mld_zprecsetc(prec,what,string,info,ilev) + subroutine mld_zprecsetc(prec,what,string,info,ilev,pos) import :: psb_zspmat_type, psb_desc_type, psb_dpk_, & & mld_zprec_type, psb_ipk_ class(mld_zprec_type), intent(inout) :: prec @@ -217,8 +221,9 @@ module mld_z_prec_type character(len=*), intent(in) :: string integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), optional, intent(in) :: ilev + character(len=*), optional, intent(in) :: pos end subroutine mld_zprecsetc - subroutine mld_zcprecseti(prec,what,val,info,ilev) + subroutine mld_zcprecseti(prec,what,val,info,ilev,pos) import :: psb_zspmat_type, psb_desc_type, psb_dpk_, & & mld_zprec_type, psb_ipk_ class(mld_zprec_type), intent(inout) :: prec @@ -226,8 +231,9 @@ module mld_z_prec_type integer(psb_ipk_), intent(in) :: val integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), optional, intent(in) :: ilev + character(len=*), optional, intent(in) :: pos end subroutine mld_zcprecseti - subroutine mld_zcprecsetr(prec,what,val,info,ilev) + subroutine mld_zcprecsetr(prec,what,val,info,ilev,pos) import :: psb_zspmat_type, psb_desc_type, psb_dpk_, & & mld_zprec_type, psb_ipk_ class(mld_zprec_type), intent(inout) :: prec @@ -235,8 +241,9 @@ module mld_z_prec_type real(psb_dpk_), intent(in) :: val integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), optional, intent(in) :: ilev + character(len=*), optional, intent(in) :: pos end subroutine mld_zcprecsetr - subroutine mld_zcprecsetc(prec,what,string,info,ilev) + subroutine mld_zcprecsetc(prec,what,string,info,ilev,pos) import :: psb_zspmat_type, psb_desc_type, psb_dpk_, & & mld_zprec_type, psb_ipk_ class(mld_zprec_type), intent(inout) :: prec @@ -244,6 +251,7 @@ module mld_z_prec_type character(len=*), intent(in) :: string integer(psb_ipk_), intent(out) :: info integer(psb_ipk_), optional, intent(in) :: ilev + character(len=*), optional, intent(in) :: pos end subroutine mld_zcprecsetc end interface @@ -477,6 +485,18 @@ contains write(iout_,*) return end if + if (allocated(p%precv(1)%sm2a)) then + write(iout_,*) 'Post smoother details' + call p%precv(1)%sm2a%descr(info,iout=iout_) + if (nlev == 1) then + if (p%precv(1)%parms%sweeps > 1) then + write(iout_,*) ' Number of smoother sweeps : ',& + & p%precv(1)%parms%sweeps + end if + write(iout_,*) + return + end if + end if end if ! diff --git a/tests/fileread/df_sample.f90 b/tests/fileread/df_sample.f90 index 026d0d8f..bb5f7983 100644 --- a/tests/fileread/df_sample.f90 +++ b/tests/fileread/df_sample.f90 @@ -290,8 +290,8 @@ program df_sample call mld_precset(prec,mld_sub_restr_, prec_choice%restr, info) call mld_precset(prec,mld_sub_prol_, prec_choice%prol, info) call mld_precset(prec,mld_sub_solve_, prec_choice%solve, info) - call mld_precset(prec,mld_sub_fillin_, prec_choice%fill, info) - call mld_precset(prec,mld_sub_iluthrs_, prec_choice%thr, info) + call mld_precset(prec,mld_sub_fillin_, prec_choice%fill, info) + call mld_precset(prec,mld_sub_iluthrs_, prec_choice%thr, info) call mld_precset(prec,mld_aggr_kind_, prec_choice%aggrkind,info) call mld_precset(prec,mld_aggr_alg_, prec_choice%aggr_alg,info) call mld_precset(prec,mld_ml_type_, prec_choice%mltype, info) @@ -299,18 +299,17 @@ program df_sample call mld_precset(prec,mld_aggr_scale_, prec_choice%ascale, info) call mld_precset(prec,mld_aggr_thresh_, prec_choice%athres, info) call mld_precset(prec,mld_coarse_solve_, prec_choice%csolve, info) - call mld_precset(prec,mld_ml_type_,'MULT',info) - call mld_precset(prec,mld_smoother_pos_,'TWOSIDE',info) - call mld_precset(prec,mld_coarse_sweeps_,4,info) + call mld_precset(prec,mld_coarse_sweeps_, 4, info) call mld_precset(prec,mld_coarse_subsolve_, prec_choice%csbsolve,info) call mld_precset(prec,mld_coarse_mat_, prec_choice%cmat, info) call mld_precset(prec,mld_coarse_fillin_, prec_choice%cfill, info) call mld_precset(prec,mld_coarse_iluthrs_, prec_choice%cthres, info) call mld_precset(prec,mld_coarse_sweeps_, prec_choice%cjswp, info) -!!$ call prec%set(dbsmth,info,pos='post') -!!$ call prec%set(dbwgs,info,pos='post') -!!$ call mld_precset(prec,'solver_sweeps', 4, info, pos='pre') -!!$ call mld_precset(prec,'solver_sweeps', 4, info, pos='post') + call prec%set(dbsmth,info,pos='post') + call prec%set('sub_solve','gs',info,pos='post') + call prec%set('sub_solve','bwgs',info,pos='pre') + call mld_precset(prec,'solver_sweeps', 4, info, pos='pre') + call mld_precset(prec,'solver_sweeps', 4, info, pos='post') else nlv = 1 call mld_precinit(prec,prec_choice%prec,info) diff --git a/tests/fileread/runs/dfs.inp b/tests/fileread/runs/dfs.inp index 1f8cd7a0..5dbb7203 100644 --- a/tests/fileread/runs/dfs.inp +++ b/tests/fileread/runs/dfs.inp @@ -1,7 +1,7 @@ DATIAMBRA/matrix.mm ! This matrix (and others) from: http://math.nist.gov/MatrixMarket/ or DATIAMBRA/rhs.mm ! rhs | http://www.cise.ufl.edu/research/sparse/matrices/index.html MM ! -BICGSTAB ! Iterative method: BiCGSTAB BiCG CGS RGMRES BiCGSTABL CG +CG ! Iterative method: BiCGSTAB BiCG CGS RGMRES BiCGSTABL CG CSR ! Storage format: CSR COO JAD 0 ! IPART (partition method): 0 (block) 2 (graph, with Metis) 2 ! ISTOPC @@ -11,24 +11,24 @@ CSR ! Storage format: CSR COO JAD 1.d-6 ! EPS 5L-M-RAS-I-UR ! Longer descriptive name for preconditioner (up to 20 chars) ML ! Preconditioner type: NONE JACOBI BJAC AS ML -1 ! Number of overlap layers for AS preconditioner +0 ! Number of overlap layers for AS preconditioner HALO ! AS restriction operator: NONE HALO NONE ! AS prolongation operator: NONE SUM AVG -ILU ! AS subdomain solver: DSCALE ILU MILU ILUT UMF SLU MUMPS +GS ! AS subdomain solver: DSCALE ILU MILU ILUT UMF SLU MUMPS 0 ! Fill level P for ILU(P) and ILU(T,P) 1.d-4 ! Threshold T for ILU(T,P) -1 ! Number of Jacobi sweeps for base smoother +4 ! Number of Jacobi sweeps for base smoother 4 ! Number of levels in a multilevel preconditioner -AS ! Smoother type JACOBI BJAC AS ignored for non-ML +BJAC ! Smoother type JACOBI BJAC AS ignored for non-ML SMOOTHED ! Type of aggregation: SMOOTHED NONSMOOTHED DEC ! Type of aggregation: DEC -ADD ! Type of multilevel correction: ADD MULT -PRE ! Side of correction PRE POST TWOSIDE (ignored for ADD) +MULT ! Type of multilevel correction: ADD MULT +TWOSIDE ! Side of correction PRE POST TWOSIDE (ignored for ADD) DIST ! Coarsest-level matrix distribution: DIST REPL BJAC ! Coarsest-level solver: JACOBI BJAC UMF SLU MUMPS SLUDIST -ILU ! Coarsest-level subsolver: ILU UMF SLU MUMPS SLUDIST (DSCALE for JACOBI) +GS ! Coarsest-level subsolver: ILU UMF SLU MUMPS SLUDIST (DSCALE for JACOBI) 1 ! Coarsest-level fillin P for ILU(P) and ILU(T,P) 1.d-4 ! Coarsest-level threshold T for ILU(T,P) -2 ! Number of Jacobi sweeps for BJAC/PJAC coarsest-level solver +4 ! Number of Jacobi sweeps for BJAC/PJAC coarsest-level solver 0.0125d0 ! Smoothed aggregation threshold: >= 0.0 0.5 ! Smoothed aggregation scaling factor. diff --git a/tests/pdegen/runs/ppde.inp b/tests/pdegen/runs/ppde.inp index 560987bb..47b6324d 100644 --- a/tests/pdegen/runs/ppde.inp +++ b/tests/pdegen/runs/ppde.inp @@ -1,6 +1,6 @@ CG ! Iterative method: BiCGSTAB BiCG CGS RGMRES BiCGSTABL CG CSR ! Storage format CSR COO JAD -0040 ! IDIM; domain size is idim**3 +0100 ! IDIM; domain size is idim**3 2 ! ISTOPC 2000 ! ITMAX 10 ! ITRACE @@ -15,7 +15,7 @@ GS ! Subdomain solver DSCALE ILU MILU ILUT UMF SLU 4 ! Solver sweeps for GS 0 ! Level-set N for ILU(N), and P for ILUT 1.d-4 ! Threshold T for ILU(T,P) -2 ! Smoother/Jacobi sweeps +4 ! Smoother/Jacobi sweeps BJAC ! Smoother type JACOBI BJAC AS; ignored for non-ML 2 ! Number of levels in a multilevel preconditioner SMOOTHED ! Kind of aggregation: SMOOTHED, NONSMOOTHED, MINENERGY From 56cacf1dcacc83310d51832a2ad44976d57b35ce Mon Sep 17 00:00:00 2001 From: Salvatore Filippone Date: Wed, 18 May 2016 11:42:23 +0000 Subject: [PATCH 17/17] mld2p4-smooth-2side: tests/fileread/cf_sample.f90 tests/fileread/df_sample.f90 tests/fileread/runs/cfs.inp tests/fileread/runs/dfs.inp tests/fileread/runs/sfs.inp tests/fileread/runs/zfs.inp tests/fileread/sf_sample.f90 tests/fileread/zf_sample.f90 Aligned test cases. --- tests/fileread/cf_sample.f90 | 35 ++++++++++++++------- tests/fileread/df_sample.f90 | 61 +++++++----------------------------- tests/fileread/runs/cfs.inp | 20 ++++++------ tests/fileread/runs/dfs.inp | 13 ++++---- tests/fileread/runs/sfs.inp | 24 +++++++------- tests/fileread/runs/zfs.inp | 16 +++++----- tests/fileread/sf_sample.f90 | 40 ++++++++++++++--------- tests/fileread/zf_sample.f90 | 41 +++++++++++++++--------- 8 files changed, 126 insertions(+), 124 deletions(-) diff --git a/tests/fileread/cf_sample.f90 b/tests/fileread/cf_sample.f90 index 26cd7adf..8b409d7c 100644 --- a/tests/fileread/cf_sample.f90 +++ b/tests/fileread/cf_sample.f90 @@ -62,6 +62,7 @@ program cf_sample integer(psb_ipk_) :: nlev ! number of levels in multilevel prec. character(len=16) :: aggrkind ! smoothed, raw aggregation character(len=16) :: aggr_alg ! aggregation algorithm (currently only decoupled) + character(len=16) :: aggr_ord ! Ordering for aggregation character(len=16) :: mltype ! additive or multiplicative multi-level prec character(len=16) :: smthpos ! side: pre, post, both smoothing character(len=16) :: cmat ! coarse mat: distributed, replicated @@ -71,6 +72,7 @@ program cf_sample real(psb_spk_) :: cthres ! threshold for coarse fact. ILU(T) integer(psb_ipk_) :: cjswp ! block-Jacobi sweeps real(psb_spk_) :: athres ! smoothed aggregation threshold + real(psb_spk_) :: ascale ! smoothed aggregation scale factor end type precdata type(precdata) :: prec_choice @@ -260,12 +262,14 @@ program cf_sample call mld_precset(prec,mld_sub_restr_, prec_choice%restr, info) call mld_precset(prec,mld_sub_prol_, prec_choice%prol, info) call mld_precset(prec,mld_sub_solve_, prec_choice%solve, info) - call mld_precset(prec,mld_sub_fillin_, prec_choice%fill, info) - call mld_precset(prec,mld_sub_iluthrs_, prec_choice%thr, info) + call mld_precset(prec,mld_sub_fillin_, prec_choice%fill, info) + call mld_precset(prec,mld_sub_iluthrs_, prec_choice%thr, info) call mld_precset(prec,mld_aggr_kind_, prec_choice%aggrkind,info) call mld_precset(prec,mld_aggr_alg_, prec_choice%aggr_alg,info) + call mld_precset(prec,mld_aggr_ord_, prec_choice%aggr_ord,info) call mld_precset(prec,mld_ml_type_, prec_choice%mltype, info) call mld_precset(prec,mld_smoother_pos_, prec_choice%smthpos, info) + call mld_precset(prec,mld_aggr_scale_, prec_choice%ascale, info) call mld_precset(prec,mld_aggr_thresh_, prec_choice%athres, info) call mld_precset(prec,mld_coarse_solve_, prec_choice%csolve, info) call mld_precset(prec,mld_coarse_subsolve_, prec_choice%csbsolve,info) @@ -276,15 +280,16 @@ program cf_sample else nlv = 1 call mld_precinit(prec,prec_choice%prec,info) - call mld_precset(prec,mld_smoother_sweeps_, prec_choice%jsweeps, info) - call mld_precset(prec,mld_sub_ovr_, prec_choice%novr, info) - call mld_precset(prec,mld_sub_restr_, prec_choice%restr, info) - call mld_precset(prec,mld_sub_prol_, prec_choice%prol, info) - call mld_precset(prec,mld_sub_solve_, prec_choice%solve, info) - call mld_precset(prec,mld_sub_fillin_, prec_choice%fill, info) - call mld_precset(prec,mld_sub_iluthrs_, prec_choice%thr, info) + if (psb_toupper(prec_choice%prec) /= 'NONE') then + call mld_precset(prec,mld_smoother_sweeps_, prec_choice%jsweeps, info) + call mld_precset(prec,mld_sub_ovr_, prec_choice%novr, info) + call mld_precset(prec,mld_sub_restr_, prec_choice%restr, info) + call mld_precset(prec,mld_sub_prol_, prec_choice%prol, info) + call mld_precset(prec,mld_sub_solve_, prec_choice%solve, info) + call mld_precset(prec,mld_sub_fillin_, prec_choice%fill, info) + call mld_precset(prec,mld_sub_iluthrs_, prec_choice%thr, info) + end if end if - ! building the preconditioner t1 = psb_wtime() call mld_precbld(a,desc_a,prec,info) @@ -336,6 +341,8 @@ program cf_sample write(psb_out_unit,'("Total memory occupation for A : ",i12)')amatsize write(psb_out_unit,'("Total memory occupation for DESC_A : ",i12)')descsize write(psb_out_unit,'("Total memory occupation for PREC : ",i12)')precsize + write(psb_out_unit,'("Storage format for A : ",a )')a%get_fmt() + write(psb_out_unit,'("Storage format for DESC_A : ",a )')desc_a%get_fmt() end if call psb_gather(x_col_glob,x_col,desc_a,info,root=psb_root_) @@ -366,6 +373,7 @@ program cf_sample call psb_spfree(a, desc_a,info) call mld_precfree(prec,info) call psb_cdfree(desc_a,info) + call psb_exit(ictxt) stop @@ -418,15 +426,17 @@ contains call read_data(prec%smther,psb_inp_unit) ! Smoother type. call read_data(prec%aggrkind,psb_inp_unit) ! smoothed/raw aggregatin call read_data(prec%aggr_alg,psb_inp_unit) ! local or global aggregation + call read_data(prec%aggr_ord,psb_inp_unit) ! Ordering for aggregation call read_data(prec%mltype,psb_inp_unit) ! additive or multiplicative 2nd level prec call read_data(prec%smthpos,psb_inp_unit) ! side: pre, post, both smoothing call read_data(prec%cmat,psb_inp_unit) ! coarse mat - call read_data(prec%csolve,psb_inp_unit) ! Factorization type: ILU, SuperLU, UMFPACK. + call read_data(prec%csolve,psb_inp_unit) ! Factorization type: BJAC, SuperLU, UMFPACK. call read_data(prec%csbsolve,psb_inp_unit) ! Factorization type: ILU, SuperLU, UMFPACK. call read_data(prec%cfill,psb_inp_unit) ! Fill-in for factorization call read_data(prec%cthres,psb_inp_unit) ! Threshold for fact. ILU(T) call read_data(prec%cjswp,psb_inp_unit) ! Jacobi sweeps call read_data(prec%athres,psb_inp_unit) ! smoother aggr thresh + call read_data(prec%ascale,psb_inp_unit) ! smoother aggr thresh end if end if @@ -441,7 +451,6 @@ contains call psb_bcast(icontxt,itrace) call psb_bcast(icontxt,irst) call psb_bcast(icontxt,eps) - call psb_bcast(icontxt,prec%descr) ! verbose description of the prec call psb_bcast(icontxt,prec%prec) ! overall prectype call psb_bcast(icontxt,prec%novr) ! number of overlap layers @@ -456,6 +465,7 @@ contains call psb_bcast(icontxt,prec%nlev) ! Number of levels in multilevel prec. call psb_bcast(icontxt,prec%aggrkind) ! smoothed/raw aggregatin call psb_bcast(icontxt,prec%aggr_alg) ! local or global aggregation + call psb_bcast(icontxt,prec%aggr_ord) ! Ordering for aggregation call psb_bcast(icontxt,prec%mltype) ! additive or multiplicative 2nd level prec call psb_bcast(icontxt,prec%smthpos) ! side: pre, post, both smoothing call psb_bcast(icontxt,prec%cmat) ! coarse mat @@ -465,6 +475,7 @@ contains call psb_bcast(icontxt,prec%cthres) ! Threshold for fact. ILU(T) call psb_bcast(icontxt,prec%cjswp) ! Jacobi sweeps call psb_bcast(icontxt,prec%athres) ! smoother aggr thresh + call psb_bcast(icontxt,prec%ascale) ! smoother aggr scale factor end if end subroutine get_parms diff --git a/tests/fileread/df_sample.f90 b/tests/fileread/df_sample.f90 index bb5f7983..713a64c0 100644 --- a/tests/fileread/df_sample.f90 +++ b/tests/fileread/df_sample.f90 @@ -62,6 +62,7 @@ program df_sample integer(psb_ipk_) :: nlev ! number of levels in multilevel prec. character(len=16) :: aggrkind ! smoothed, raw aggregation character(len=16) :: aggr_alg ! aggregation algorithm (currently only decoupled) + character(len=16) :: aggr_ord ! Ordering for aggregation character(len=16) :: mltype ! additive or multiplicative multi-level prec character(len=16) :: smthpos ! side: pre, post, both smoothing character(len=16) :: cmat ! coarse mat: distributed, replicated @@ -74,8 +75,6 @@ program df_sample real(psb_dpk_) :: ascale ! smoothed aggregation scale factor end type precdata type(precdata) :: prec_choice - type(mld_d_jac_smoother_type) :: dbsmth - type(mld_d_bwgs_solver_type) :: dbwgs ! sparse matrices type(psb_dspmat_type) :: a, aux_a @@ -106,12 +105,12 @@ program df_sample character(len=40) :: fprefix ! other variables - integer(psb_ipk_) :: i,info,j,m_problem, lbw,ubw,prf - integer(psb_ipk_) :: internal, m,ii,nnzero - real(psb_dpk_) :: t1, t2, tprec - real(psb_dpk_) :: r_amax, b_amax, scale,resmx,resmxp - integer(psb_ipk_) :: nrhs, nrow, n_row, dim, nv, ne - integer(psb_ipk_), allocatable :: ivg(:), ipv(:),perm(:) + integer(psb_ipk_) :: i,info,j,m_problem + integer(psb_ipk_) :: internal, m,ii,nnzero + real(psb_dpk_) :: t1, t2, tprec + real(psb_dpk_) :: r_amax, b_amax, scale,resmx,resmxp + integer(psb_ipk_) :: nrhs, nrow, n_row, dim, nv, ne + integer(psb_ipk_), allocatable :: ivg(:), ipv(:) call psb_init(ictxt) call psb_info(ictxt,iam,np) @@ -127,7 +126,6 @@ program df_sample if(psb_get_errstatus() /= 0) goto 9999 info=psb_success_ call psb_set_errverbosity(itwo) - call psb_cd_set_large_threshold(itwo) ! ! Hello world ! @@ -194,6 +192,7 @@ program df_sample b_col_glob(i) = 1.d0 enddo endif + call psb_bcast(ictxt,b_col_glob(1:m_problem)) else call psb_bcast(ictxt,m_problem) call psb_realloc(m_problem,1,aux_b,ircode) @@ -202,35 +201,9 @@ program df_sample goto 9999 endif b_col_glob =>aux_b(:,1) + call psb_bcast(ictxt,b_col_glob(1:m_problem)) end if - ! - ! Renumbering? - ! - if (iam==psb_root_) then - renum='NONE' - call psb_cmp_bwpf(aux_a,lbw,ubw,prf,info) - write(*,*) 'Bandwidth and profile (original): ',lbw,ubw,prf - write(*,*) 'Renumbering algorithm : ',psb_toupper(renum) - if (trim(psb_toupper(renum))/='NONE') then - call psb_mat_renum(renum,aux_a,info,perm=perm) - if (info /= 0) then - write(0,*) 'Error from RENUM',info - goto 9999 - end if - - call psb_gelp('N',perm(1:m_problem),& - & b_col_glob(1:m_problem),info) - call psb_cmp_bwpf(aux_a,lbw,ubw,prf,info) - end if - - write(*,*) 'Bandwidth and profile (renumbrd):',lbw,ubw,prf - end if - - call psb_bcast(ictxt,b_col_glob(1:m_problem)) - - call aux_a%clean_zeros(info) - ! switch over different partition types if (ipart == 0) then call psb_barrier(ictxt) @@ -283,7 +256,6 @@ program df_sample if (psb_toupper(prec_choice%prec) == 'ML') then nlv = prec_choice%nlev call mld_precinit(prec,prec_choice%prec,info,nlev=nlv) - call mld_precset(prec,mld_smoother_type_, prec_choice%smther, info) call mld_precset(prec,mld_smoother_sweeps_, prec_choice%jsweeps, info) call mld_precset(prec,mld_sub_ovr_, prec_choice%novr, info) @@ -294,22 +266,17 @@ program df_sample call mld_precset(prec,mld_sub_iluthrs_, prec_choice%thr, info) call mld_precset(prec,mld_aggr_kind_, prec_choice%aggrkind,info) call mld_precset(prec,mld_aggr_alg_, prec_choice%aggr_alg,info) + call mld_precset(prec,mld_aggr_ord_, prec_choice%aggr_ord,info) call mld_precset(prec,mld_ml_type_, prec_choice%mltype, info) call mld_precset(prec,mld_smoother_pos_, prec_choice%smthpos, info) call mld_precset(prec,mld_aggr_scale_, prec_choice%ascale, info) call mld_precset(prec,mld_aggr_thresh_, prec_choice%athres, info) call mld_precset(prec,mld_coarse_solve_, prec_choice%csolve, info) - call mld_precset(prec,mld_coarse_sweeps_, 4, info) call mld_precset(prec,mld_coarse_subsolve_, prec_choice%csbsolve,info) call mld_precset(prec,mld_coarse_mat_, prec_choice%cmat, info) call mld_precset(prec,mld_coarse_fillin_, prec_choice%cfill, info) call mld_precset(prec,mld_coarse_iluthrs_, prec_choice%cthres, info) call mld_precset(prec,mld_coarse_sweeps_, prec_choice%cjswp, info) - call prec%set(dbsmth,info,pos='post') - call prec%set('sub_solve','gs',info,pos='post') - call prec%set('sub_solve','bwgs',info,pos='pre') - call mld_precset(prec,'solver_sweeps', 4, info, pos='pre') - call mld_precset(prec,'solver_sweeps', 4, info, pos='post') else nlv = 1 call mld_precinit(prec,prec_choice%prec,info) @@ -339,11 +306,6 @@ program df_sample write(psb_out_unit,'(" ")') end if - write(fprefix,'(a,i3.3,a,i3.3)') 'proc-',iam,'-',np - call prec%dump(info,head='Pressure test case',ac=.true.) - - - iparm = 0 call psb_barrier(ictxt) t1 = psb_wtime() @@ -418,7 +380,6 @@ program df_sample 9999 continue call psb_error(ictxt) - contains ! ! get iteration parameters from standard input @@ -465,6 +426,7 @@ contains call read_data(prec%smther,psb_inp_unit) ! Smoother type. call read_data(prec%aggrkind,psb_inp_unit) ! smoothed/raw aggregatin call read_data(prec%aggr_alg,psb_inp_unit) ! local or global aggregation + call read_data(prec%aggr_ord,psb_inp_unit) ! Ordering for aggregation call read_data(prec%mltype,psb_inp_unit) ! additive or multiplicative 2nd level prec call read_data(prec%smthpos,psb_inp_unit) ! side: pre, post, both smoothing call read_data(prec%cmat,psb_inp_unit) ! coarse mat @@ -503,6 +465,7 @@ contains call psb_bcast(icontxt,prec%nlev) ! Number of levels in multilevel prec. call psb_bcast(icontxt,prec%aggrkind) ! smoothed/raw aggregatin call psb_bcast(icontxt,prec%aggr_alg) ! local or global aggregation + call psb_bcast(icontxt,prec%aggr_ord) ! Ordering for aggregation call psb_bcast(icontxt,prec%mltype) ! additive or multiplicative 2nd level prec call psb_bcast(icontxt,prec%smthpos) ! side: pre, post, both smoothing call psb_bcast(icontxt,prec%cmat) ! coarse mat diff --git a/tests/fileread/runs/cfs.inp b/tests/fileread/runs/cfs.inp index e413b615..2e446cf2 100644 --- a/tests/fileread/runs/cfs.inp +++ b/tests/fileread/runs/cfs.inp @@ -10,24 +10,26 @@ CSR ! Storage format: CSR COO JAD 30 ! IRST (restart for RGMRES and BiCGSTABL) 1.d-5 ! EPS 3L-M-RAS-I-D4 ! Longer descriptive name for preconditioner (up to 20 chars) -ML ! Preconditioner type: NONE DIAG BJAC AS ML +ML ! Preconditioner type: NONE JACOBI BJAC AS ML 0 ! Number of overlap layers for AS preconditioner HALO ! AS restriction operator: NONE HALO NONE ! AS prolongation operator: NONE SUM AVG -ILU ! AS subdomain solver: ILU MILU ILUT UMF SLU MUMPS +ILU ! AS subdomain solver: DSCALE ILU MILU ILUT UMF SLU MUMPS 1 ! Fill level P for ILU(P) and ILU(T,P) 1.d-4 ! Threshold T for ILU(T,P) -1 ! Jacobi sweeps +1 ! Jacobi sweeps for base smoother 3 ! Number of levels in a multilevel preconditioner AS ! Smoother type JACOBI BJAC AS ignored for non-ML -SMOOTHED ! Type of aggregation: SMOOTHED NONSMOOTHED MINENERGY +SMOOTHED ! Type of aggregation: SMOOTHED NONSMOOTHED DEC ! Type of aggregation: DEC +NATURAL ! Ordering of aggregation NATURAL DEGREE MULT ! Type of multilevel correction: ADD MULT POST ! Side of multiplicative correction PRE POST TWOSIDE (ignored for ADD) -DIST ! Coarsest-level matrix distribution: DIST REPL -BJAC ! Coarsest-level solver: BJAC UMF SLU SLUDIST MUMPS -ILU ! Coarsest-level subsolver: ILU UMF SLU SLUDIST MUMPS +REPL ! Coarsest-level matrix distribution: DIST REPL +BJAC ! Coarsest-level solver: JACOBI BJAC UMF SLU SLUDIST MUMPS +ILU ! Coarsest-level subsolver: ILU UMF SLU MUMPS SLUDIST (DSCALE for JACOBI) 0 ! Coarsest-level fillin P for ILU(P) and ILU(T,P) 1.d-4 ! Coarsest-level threshold T for ILU(T,P) -4 ! Number of Jacobi sweeps for BJAC coarsest-level solver -0.10d0 ! Smoothed aggregation threshold: >= 0.0 +4 ! Number of Jacobi sweeps for BJAC/PJAC coarsest-level solver +0.0125d0 ! Smoothed aggregation threshold: >= 0.0 +0.5 ! Smoothed aggregation scaling factor. diff --git a/tests/fileread/runs/dfs.inp b/tests/fileread/runs/dfs.inp index 5dbb7203..e711e051 100644 --- a/tests/fileread/runs/dfs.inp +++ b/tests/fileread/runs/dfs.inp @@ -9,7 +9,7 @@ CSR ! Storage format: CSR COO JAD 01 ! ITRACE 30 ! IRST (restart for RGMRES and BiCGSTABL) 1.d-6 ! EPS -5L-M-RAS-I-UR ! Longer descriptive name for preconditioner (up to 20 chars) +4L-M-RAS-I-UR ! Longer descriptive name for preconditioner (up to 20 chars) ML ! Preconditioner type: NONE JACOBI BJAC AS ML 0 ! Number of overlap layers for AS preconditioner HALO ! AS restriction operator: NONE HALO @@ -22,12 +22,13 @@ GS ! AS subdomain solver: DSCALE ILU MILU ILUT UMF SLU BJAC ! Smoother type JACOBI BJAC AS ignored for non-ML SMOOTHED ! Type of aggregation: SMOOTHED NONSMOOTHED DEC ! Type of aggregation: DEC +NATURAL ! Ordering of aggregation NATURAL DEGREE MULT ! Type of multilevel correction: ADD MULT -TWOSIDE ! Side of correction PRE POST TWOSIDE (ignored for ADD) -DIST ! Coarsest-level matrix distribution: DIST REPL -BJAC ! Coarsest-level solver: JACOBI BJAC UMF SLU MUMPS SLUDIST -GS ! Coarsest-level subsolver: ILU UMF SLU MUMPS SLUDIST (DSCALE for JACOBI) -1 ! Coarsest-level fillin P for ILU(P) and ILU(T,P) +POST ! Side of multiplicative correction PRE POST TWOSIDE (ignored for ADD) +REPL ! Coarsest-level matrix distribution: DIST REPL +BJAC ! Coarsest-level solver: JACOBI BJAC UMF SLU SLUDIST MUMPS +ILU ! Coarsest-level subsolver: ILU UMF SLU MUMPS SLUDIST (DSCALE for JACOBI) +0 ! Coarsest-level fillin P for ILU(P) and ILU(T,P) 1.d-4 ! Coarsest-level threshold T for ILU(T,P) 4 ! Number of Jacobi sweeps for BJAC/PJAC coarsest-level solver 0.0125d0 ! Smoothed aggregation threshold: >= 0.0 diff --git a/tests/fileread/runs/sfs.inp b/tests/fileread/runs/sfs.inp index e879010f..9dbe7aab 100644 --- a/tests/fileread/runs/sfs.inp +++ b/tests/fileread/runs/sfs.inp @@ -10,24 +10,26 @@ CSR ! Storage format: CSR COO JAD 30 ! IRST (restart for RGMRES and BiCGSTABL) 1.d-5 ! EPS 3L-M-RAS-I-D4 ! Longer descriptive name for preconditioner (up to 20 chars) -ML ! Preconditioner type: NONE DIAG BJAC AS ML +ML ! Preconditioner type: NONE JACOBI BJAC AS ML 0 ! Number of overlap layers for AS preconditioner HALO ! AS restriction operator: NONE HALO NONE ! AS prolongation operator: NONE SUM AVG -ILU ! AS subdomain solver: ILU MILU ILUT UMF SLU MUMPS +ILU ! AS subdomain solver: DSCALE ILU MILU ILUT UMF SLU MUMPS 1 ! Fill level P for ILU(P) and ILU(T,P) 1.d-4 ! Threshold T for ILU(T,P) -1 ! Jacobi sweeps -3 ! Number of levels in a multilevel preconditioner -AS ! Smoother type JACOBI BJAC AS ignored for non-ML -SMOOTHED ! Type of aggregation: SMOOTHED NONSMOOTHED MINENERGY +4 ! Number of Jacobi sweeps for base smoother +4 ! Number of levels in a multilevel preconditioner +BJAC ! Smoother type JACOBI BJAC AS ignored for non-ML +SMOOTHED ! Type of aggregation: SMOOTHED NONSMOOTHED DEC ! Type of aggregation: DEC +NATURAL ! Ordering of aggregation NATURAL DEGREE MULT ! Type of multilevel correction: ADD MULT POST ! Side of multiplicative correction PRE POST TWOSIDE (ignored for ADD) -DIST ! Coarsest-level matrix distribution: DIST REPL -BJAC ! Coarsest-level solver: BJAC UMF SLU SLUDIST MUMPS -ILU ! Coarsest-level subsolver: ILU UMF SLU SLUDIST MUMPS +REPL ! Coarsest-level matrix distribution: DIST REPL +BJAC ! Coarsest-level solver: JACOBI BJAC UMF SLU SLUDIST MUMPS +ILU ! Coarsest-level subsolver: ILU UMF SLU MUMPS SLUDIST (DSCALE for JACOBI) 0 ! Coarsest-level fillin P for ILU(P) and ILU(T,P) 1.d-4 ! Coarsest-level threshold T for ILU(T,P) -4 ! Number of Jacobi sweeps for BJAC coarsest-level solver -0.10d0 ! Smoothed aggregation threshold: >= 0.0 +4 ! Number of Jacobi sweeps for BJAC/PJAC coarsest-level solver +0.0125d0 ! Smoothed aggregation threshold: >= 0.0 +0.5 ! Smoothed aggregation scaling factor. diff --git a/tests/fileread/runs/zfs.inp b/tests/fileread/runs/zfs.inp index 0fbb30de..3abbed35 100644 --- a/tests/fileread/runs/zfs.inp +++ b/tests/fileread/runs/zfs.inp @@ -14,20 +14,22 @@ ML ! Preconditioner type: NONE JACOBI BJAC AS ML 0 ! Number of overlap layers for AS preconditioner HALO ! AS restriction operator: NONE HALO NONE ! AS prolongation operator: NONE SUM AVG -ILU ! AS subdomain solver: ILU MILU ILUT UMF SLU MUMPS +ILU ! AS subdomain solver: DSCALE ILU MILU ILUT UMF SLU MUMPS 1 ! Fill level P for ILU(P) and ILU(T,P) 1.d-4 ! Threshold T for ILU(T,P) 4 ! Number of Jacobi sweeps for base smoother -3 ! Number of levels in a multilevel preconditioner -AS ! Smoother type JACOBI BJAC AS ignored for non-ML -SMOOTHED ! Type of aggregation: SMOOTHED NONSMOOTHED MINENERGY +4 ! Number of levels in a multilevel preconditioner +BJAC ! Smoother type JACOBI BJAC AS ignored for non-ML +SMOOTHED ! Type of aggregation: SMOOTHED NONSMOOTHED DEC ! Type of aggregation: DEC +NATURAL ! Ordering of aggregation NATURAL DEGREE MULT ! Type of multilevel correction: ADD MULT POST ! Side of multiplicative correction PRE POST TWOSIDE (ignored for ADD) REPL ! Coarsest-level matrix distribution: DIST REPL BJAC ! Coarsest-level solver: JACOBI BJAC UMF SLU SLUDIST MUMPS -UMF ! Coarsest-level subsolver: ILU UMF SLU MUMPS SLUDIST (DSCALE for JACOBI) +ILU ! Coarsest-level subsolver: ILU UMF SLU MUMPS SLUDIST (DSCALE for JACOBI) 0 ! Coarsest-level fillin P for ILU(P) and ILU(T,P) 1.d-4 ! Coarsest-level threshold T for ILU(T,P) -4 ! Number of Jacobi sweeps for BJAC coarsest-level solver -0.10d0 ! Smoothed aggregation threshold: >= 0.0 +4 ! Number of Jacobi sweeps for BJAC/PJAC coarsest-level solver +0.0125d0 ! Smoothed aggregation threshold: >= 0.0 +0.5 ! Smoothed aggregation scaling factor. diff --git a/tests/fileread/sf_sample.f90 b/tests/fileread/sf_sample.f90 index eea679c7..e3a0e946 100644 --- a/tests/fileread/sf_sample.f90 +++ b/tests/fileread/sf_sample.f90 @@ -62,6 +62,7 @@ program sf_sample integer(psb_ipk_) :: nlev ! number of levels in multilevel prec. character(len=16) :: aggrkind ! smoothed, raw aggregation character(len=16) :: aggr_alg ! aggregation algorithm (currently only decoupled) + character(len=16) :: aggr_ord ! Ordering for aggregation character(len=16) :: mltype ! additive or multiplicative multi-level prec character(len=16) :: smthpos ! side: pre, post, both smoothing character(len=16) :: cmat ! coarse mat: distributed, replicated @@ -71,6 +72,7 @@ program sf_sample real(psb_spk_) :: cthres ! threshold for coarse fact. ILU(T) integer(psb_ipk_) :: cjswp ! block-Jacobi sweeps real(psb_spk_) :: athres ! smoothed aggregation threshold + real(psb_spk_) :: ascale ! smoothed aggregation scale factor end type precdata type(precdata) :: prec_choice @@ -260,12 +262,14 @@ program sf_sample call mld_precset(prec,mld_sub_restr_, prec_choice%restr, info) call mld_precset(prec,mld_sub_prol_, prec_choice%prol, info) call mld_precset(prec,mld_sub_solve_, prec_choice%solve, info) - call mld_precset(prec,mld_sub_fillin_, prec_choice%fill, info) - call mld_precset(prec,mld_sub_iluthrs_, prec_choice%thr, info) + call mld_precset(prec,mld_sub_fillin_, prec_choice%fill, info) + call mld_precset(prec,mld_sub_iluthrs_, prec_choice%thr, info) call mld_precset(prec,mld_aggr_kind_, prec_choice%aggrkind,info) call mld_precset(prec,mld_aggr_alg_, prec_choice%aggr_alg,info) + call mld_precset(prec,mld_aggr_ord_, prec_choice%aggr_ord,info) call mld_precset(prec,mld_ml_type_, prec_choice%mltype, info) call mld_precset(prec,mld_smoother_pos_, prec_choice%smthpos, info) + call mld_precset(prec,mld_aggr_scale_, prec_choice%ascale, info) call mld_precset(prec,mld_aggr_thresh_, prec_choice%athres, info) call mld_precset(prec,mld_coarse_solve_, prec_choice%csolve, info) call mld_precset(prec,mld_coarse_subsolve_, prec_choice%csbsolve,info) @@ -276,15 +280,16 @@ program sf_sample else nlv = 1 call mld_precinit(prec,prec_choice%prec,info) - call mld_precset(prec,mld_smoother_sweeps_, prec_choice%jsweeps, info) - call mld_precset(prec,mld_sub_ovr_, prec_choice%novr, info) - call mld_precset(prec,mld_sub_restr_, prec_choice%restr, info) - call mld_precset(prec,mld_sub_prol_, prec_choice%prol, info) - call mld_precset(prec,mld_sub_solve_, prec_choice%solve, info) - call mld_precset(prec,mld_sub_fillin_, prec_choice%fill, info) - call mld_precset(prec,mld_sub_iluthrs_, prec_choice%thr, info) + if (psb_toupper(prec_choice%prec) /= 'NONE') then + call mld_precset(prec,mld_smoother_sweeps_, prec_choice%jsweeps, info) + call mld_precset(prec,mld_sub_ovr_, prec_choice%novr, info) + call mld_precset(prec,mld_sub_restr_, prec_choice%restr, info) + call mld_precset(prec,mld_sub_prol_, prec_choice%prol, info) + call mld_precset(prec,mld_sub_solve_, prec_choice%solve, info) + call mld_precset(prec,mld_sub_fillin_, prec_choice%fill, info) + call mld_precset(prec,mld_sub_iluthrs_, prec_choice%thr, info) + end if end if - ! building the preconditioner t1 = psb_wtime() call mld_precbld(a,desc_a,prec,info) @@ -336,6 +341,8 @@ program sf_sample write(psb_out_unit,'("Total memory occupation for A : ",i12)')amatsize write(psb_out_unit,'("Total memory occupation for DESC_A : ",i12)')descsize write(psb_out_unit,'("Total memory occupation for PREC : ",i12)')precsize + write(psb_out_unit,'("Storage format for A : ",a )')a%get_fmt() + write(psb_out_unit,'("Storage format for DESC_A : ",a )')desc_a%get_fmt() end if call psb_gather(x_col_glob,x_col,desc_a,info,root=psb_root_) @@ -383,12 +390,12 @@ contains use psb_base_mod implicit none - integer(psb_ipk_) :: icontxt + integer(psb_ipk_) :: icontxt character(len=*) :: kmethd, mtrx, rhs, afmt,filefmt type(precdata) :: prec real(psb_spk_) :: eps - integer(psb_ipk_) :: iret, istopc,itmax,itrace, ipart, irst - integer(psb_ipk_) :: iam, nm, np, i + integer(psb_ipk_) :: iret, istopc,itmax,itrace, ipart, irst + integer(psb_ipk_) :: iam, nm, np, i call psb_info(icontxt,iam,np) @@ -419,15 +426,17 @@ contains call read_data(prec%smther,psb_inp_unit) ! Smoother type. call read_data(prec%aggrkind,psb_inp_unit) ! smoothed/raw aggregatin call read_data(prec%aggr_alg,psb_inp_unit) ! local or global aggregation + call read_data(prec%aggr_ord,psb_inp_unit) ! Ordering for aggregation call read_data(prec%mltype,psb_inp_unit) ! additive or multiplicative 2nd level prec call read_data(prec%smthpos,psb_inp_unit) ! side: pre, post, both smoothing call read_data(prec%cmat,psb_inp_unit) ! coarse mat - call read_data(prec%csolve,psb_inp_unit) ! Factorization type: ILU, SuperLU, UMFPACK. + call read_data(prec%csolve,psb_inp_unit) ! Factorization type: BJAC, SuperLU, UMFPACK. call read_data(prec%csbsolve,psb_inp_unit) ! Factorization type: ILU, SuperLU, UMFPACK. call read_data(prec%cfill,psb_inp_unit) ! Fill-in for factorization call read_data(prec%cthres,psb_inp_unit) ! Threshold for fact. ILU(T) call read_data(prec%cjswp,psb_inp_unit) ! Jacobi sweeps call read_data(prec%athres,psb_inp_unit) ! smoother aggr thresh + call read_data(prec%ascale,psb_inp_unit) ! smoother aggr thresh end if end if @@ -442,7 +451,6 @@ contains call psb_bcast(icontxt,itrace) call psb_bcast(icontxt,irst) call psb_bcast(icontxt,eps) - call psb_bcast(icontxt,prec%descr) ! verbose description of the prec call psb_bcast(icontxt,prec%prec) ! overall prectype call psb_bcast(icontxt,prec%novr) ! number of overlap layers @@ -457,6 +465,7 @@ contains call psb_bcast(icontxt,prec%nlev) ! Number of levels in multilevel prec. call psb_bcast(icontxt,prec%aggrkind) ! smoothed/raw aggregatin call psb_bcast(icontxt,prec%aggr_alg) ! local or global aggregation + call psb_bcast(icontxt,prec%aggr_ord) ! Ordering for aggregation call psb_bcast(icontxt,prec%mltype) ! additive or multiplicative 2nd level prec call psb_bcast(icontxt,prec%smthpos) ! side: pre, post, both smoothing call psb_bcast(icontxt,prec%cmat) ! coarse mat @@ -466,6 +475,7 @@ contains call psb_bcast(icontxt,prec%cthres) ! Threshold for fact. ILU(T) call psb_bcast(icontxt,prec%cjswp) ! Jacobi sweeps call psb_bcast(icontxt,prec%athres) ! smoother aggr thresh + call psb_bcast(icontxt,prec%ascale) ! smoother aggr scale factor end if end subroutine get_parms diff --git a/tests/fileread/zf_sample.f90 b/tests/fileread/zf_sample.f90 index 1775e877..981e2d53 100644 --- a/tests/fileread/zf_sample.f90 +++ b/tests/fileread/zf_sample.f90 @@ -62,6 +62,7 @@ program zf_sample integer(psb_ipk_) :: nlev ! number of levels in multilevel prec. character(len=16) :: aggrkind ! smoothed, raw aggregation character(len=16) :: aggr_alg ! aggregation algorithm (currently only decoupled) + character(len=16) :: aggr_ord ! Ordering for aggregation character(len=16) :: mltype ! additive or multiplicative multi-level prec character(len=16) :: smthpos ! side: pre, post, both smoothing character(len=16) :: cmat ! coarse mat: distributed, replicated @@ -71,6 +72,7 @@ program zf_sample real(psb_dpk_) :: cthres ! threshold for coarse fact. ILU(T) integer(psb_ipk_) :: cjswp ! block-Jacobi sweeps real(psb_dpk_) :: athres ! smoothed aggregation threshold + real(psb_dpk_) :: ascale ! smoothed aggregation scale factor end type precdata type(precdata) :: prec_choice @@ -260,12 +262,14 @@ program zf_sample call mld_precset(prec,mld_sub_restr_, prec_choice%restr, info) call mld_precset(prec,mld_sub_prol_, prec_choice%prol, info) call mld_precset(prec,mld_sub_solve_, prec_choice%solve, info) - call mld_precset(prec,mld_sub_fillin_, prec_choice%fill, info) - call mld_precset(prec,mld_sub_iluthrs_, prec_choice%thr, info) + call mld_precset(prec,mld_sub_fillin_, prec_choice%fill, info) + call mld_precset(prec,mld_sub_iluthrs_, prec_choice%thr, info) call mld_precset(prec,mld_aggr_kind_, prec_choice%aggrkind,info) call mld_precset(prec,mld_aggr_alg_, prec_choice%aggr_alg,info) + call mld_precset(prec,mld_aggr_ord_, prec_choice%aggr_ord,info) call mld_precset(prec,mld_ml_type_, prec_choice%mltype, info) call mld_precset(prec,mld_smoother_pos_, prec_choice%smthpos, info) + call mld_precset(prec,mld_aggr_scale_, prec_choice%ascale, info) call mld_precset(prec,mld_aggr_thresh_, prec_choice%athres, info) call mld_precset(prec,mld_coarse_solve_, prec_choice%csolve, info) call mld_precset(prec,mld_coarse_subsolve_, prec_choice%csbsolve,info) @@ -276,15 +280,16 @@ program zf_sample else nlv = 1 call mld_precinit(prec,prec_choice%prec,info) - call mld_precset(prec,mld_smoother_sweeps_, prec_choice%jsweeps, info) - call mld_precset(prec,mld_sub_ovr_, prec_choice%novr, info) - call mld_precset(prec,mld_sub_restr_, prec_choice%restr, info) - call mld_precset(prec,mld_sub_prol_, prec_choice%prol, info) - call mld_precset(prec,mld_sub_solve_, prec_choice%solve, info) - call mld_precset(prec,mld_sub_fillin_, prec_choice%fill, info) - call mld_precset(prec,mld_sub_iluthrs_, prec_choice%thr, info) + if (psb_toupper(prec_choice%prec) /= 'NONE') then + call mld_precset(prec,mld_smoother_sweeps_, prec_choice%jsweeps, info) + call mld_precset(prec,mld_sub_ovr_, prec_choice%novr, info) + call mld_precset(prec,mld_sub_restr_, prec_choice%restr, info) + call mld_precset(prec,mld_sub_prol_, prec_choice%prol, info) + call mld_precset(prec,mld_sub_solve_, prec_choice%solve, info) + call mld_precset(prec,mld_sub_fillin_, prec_choice%fill, info) + call mld_precset(prec,mld_sub_iluthrs_, prec_choice%thr, info) + end if end if - ! building the preconditioner t1 = psb_wtime() call mld_precbld(a,desc_a,prec,info) @@ -336,6 +341,8 @@ program zf_sample write(psb_out_unit,'("Total memory occupation for A : ",i12)')amatsize write(psb_out_unit,'("Total memory occupation for DESC_A : ",i12)')descsize write(psb_out_unit,'("Total memory occupation for PREC : ",i12)')precsize + write(psb_out_unit,'("Storage format for A : ",a )')a%get_fmt() + write(psb_out_unit,'("Storage format for DESC_A : ",a )')desc_a%get_fmt() end if call psb_gather(x_col_glob,x_col,desc_a,info,root=psb_root_) @@ -366,6 +373,7 @@ program zf_sample call psb_spfree(a, desc_a,info) call mld_precfree(prec,info) call psb_cdfree(desc_a,info) + call psb_exit(ictxt) stop @@ -382,12 +390,12 @@ contains use psb_base_mod implicit none - integer(psb_ipk_) :: icontxt + integer(psb_ipk_) :: icontxt character(len=*) :: kmethd, mtrx, rhs, afmt,filefmt type(precdata) :: prec real(psb_dpk_) :: eps - integer(psb_ipk_) :: iret, istopc,itmax,itrace, ipart, irst - integer(psb_ipk_) :: iam, nm, np, i + integer(psb_ipk_) :: iret, istopc,itmax,itrace, ipart, irst + integer(psb_ipk_) :: iam, nm, np, i call psb_info(icontxt,iam,np) @@ -418,15 +426,17 @@ contains call read_data(prec%smther,psb_inp_unit) ! Smoother type. call read_data(prec%aggrkind,psb_inp_unit) ! smoothed/raw aggregatin call read_data(prec%aggr_alg,psb_inp_unit) ! local or global aggregation + call read_data(prec%aggr_ord,psb_inp_unit) ! Ordering for aggregation call read_data(prec%mltype,psb_inp_unit) ! additive or multiplicative 2nd level prec call read_data(prec%smthpos,psb_inp_unit) ! side: pre, post, both smoothing call read_data(prec%cmat,psb_inp_unit) ! coarse mat - call read_data(prec%csolve,psb_inp_unit) ! Factorization type: ILU, SuperLU, UMFPACK. + call read_data(prec%csolve,psb_inp_unit) ! Factorization type: BJAC, SuperLU, UMFPACK. call read_data(prec%csbsolve,psb_inp_unit) ! Factorization type: ILU, SuperLU, UMFPACK. call read_data(prec%cfill,psb_inp_unit) ! Fill-in for factorization call read_data(prec%cthres,psb_inp_unit) ! Threshold for fact. ILU(T) call read_data(prec%cjswp,psb_inp_unit) ! Jacobi sweeps call read_data(prec%athres,psb_inp_unit) ! smoother aggr thresh + call read_data(prec%ascale,psb_inp_unit) ! smoother aggr thresh end if end if @@ -441,7 +451,6 @@ contains call psb_bcast(icontxt,itrace) call psb_bcast(icontxt,irst) call psb_bcast(icontxt,eps) - call psb_bcast(icontxt,prec%descr) ! verbose description of the prec call psb_bcast(icontxt,prec%prec) ! overall prectype call psb_bcast(icontxt,prec%novr) ! number of overlap layers @@ -456,6 +465,7 @@ contains call psb_bcast(icontxt,prec%nlev) ! Number of levels in multilevel prec. call psb_bcast(icontxt,prec%aggrkind) ! smoothed/raw aggregatin call psb_bcast(icontxt,prec%aggr_alg) ! local or global aggregation + call psb_bcast(icontxt,prec%aggr_ord) ! Ordering for aggregation call psb_bcast(icontxt,prec%mltype) ! additive or multiplicative 2nd level prec call psb_bcast(icontxt,prec%smthpos) ! side: pre, post, both smoothing call psb_bcast(icontxt,prec%cmat) ! coarse mat @@ -465,6 +475,7 @@ contains call psb_bcast(icontxt,prec%cthres) ! Threshold for fact. ILU(T) call psb_bcast(icontxt,prec%cjswp) ! Jacobi sweeps call psb_bcast(icontxt,prec%athres) ! smoother aggr thresh + call psb_bcast(icontxt,prec%ascale) ! smoother aggr scale factor end if end subroutine get_parms