diff --git a/mlprec/impl/mld_cmlprec_aply.f90 b/mlprec/impl/mld_cmlprec_aply.f90 index 25b52328..4f9da89a 100644 --- a/mlprec/impl/mld_cmlprec_aply.f90 +++ b/mlprec/impl/mld_cmlprec_aply.f90 @@ -183,10 +183,8 @@ ! ilev-1, while PT(ilev) denotes its transpose, i.e. the corresponding ! restriction operator from level ilev-1 to level ilev). ! -! 0. Transfer the outer vector Xest to x(1) (inner X at level 1) +! 1. Transfer the outer vector Xest to x(1) (inner X at level 1) ! -! 1. If ilev > 1 Transfer x(ilev-1) to the current level: -! x(ilev) = PT(ilev)*x(ilev-1) ! ! 2. Apply the base preconditioner at the current level: ! ! The sum over the subdomains is carried out in the @@ -194,8 +192,10 @@ ! y(ilev) = (K(ilev)^(-1))*x(ilev) ! ! 3. If ilev < nlevel -! a. Call recursively itself -! b. Transfer y(ilev+1) to the current level: +! a. Transfer x(ilev) to the next level: +! x(ilev+1) = PT(ilev+1)*x(ilev) +! b. Call recursively itself +! c. Transfer y(ilev+1) to the current level: ! y(ilev) = y(ilev) + P(ilev+1)*y(ilev+1) ! ! 4. if ilev == 1 Transfer the inner y to the external: @@ -215,11 +215,8 @@ ! differential equations, Cambridge University Press, 1996. ! ! -! 0. Transfer the outer vector Xest to x(1) (inner X at level 1) +! 1 Transfer the outer vector Xest to x(1) (inner X at level 1) ! -! 1. If ilev >1 Transfer x(ilev-1) to the current level: -! x(ilev) = PT(ilev)*x(ilev-1) -! ! 2. Apply the base preconditioner at the current level: ! ! The sum over the subdomains is carried out in the ! ! application of K(ilev). @@ -228,11 +225,10 @@ ! 3. If ilev < nlevel ! a. Compute the residual: ! r(ilev) = x(ilev) - A(ilev)*y(ilev) -! b. Call recursively itself passing -! r(ilev) for transfer to the next level -! (r(ilev) matches x(ilev-1) in step 1) -! -! c. Transfer y(ilev+1) to the current level: +! b. Transfer r(ilev) to the next level: +! x(ilev+1) = PT(ilev+1)*r(ilev) +! c. Call recursively +! d. Transfer y(ilev+1) to the current level: ! y(ilev) = y(ilev) + P(ilev+1)*y(ilev+1) ! ! 4. if ilev == 1 Transfer the inner y to the external: @@ -242,28 +238,23 @@ ! ! Hybrid multiplicative, post-smoothing variant ! -! 0. Transfer the outer vector Xest to x(1) (inner X at level 1) +! 1. Transfer the outer vector Xest to x(1) (inner X at level 1) ! -! 1. If ilev > 1 Transfer x(ilev-1) to the current level: -! x(ilev) = PT(ilev)*x(ilev-1) -! ! 2. If ilev < nlev -! a. Call recursively itself passing -! x(ilev) for transfer to the next level -! b. Transfer y(ilev+1) to the current level: +! a. Transfer x(ilev) to the next level: +! x(ilev+1) = PT(ilev+1)*x(ilev) +! b. Call recursively +! c. Transfer y(ilev+1) to the current level: ! y(ilev) = P(ilev+1)*y(ilev+1) -! c. Compute the residual: +! d. Compute the residual: ! x(ilev) = x(ilev) - A(ilev)*y(ilev) -! d. Apply the base preconditioner to the residual at the current level: +! e. Apply the base preconditioner to the residual at the current level: ! ! The sum over the subdomains is carried out in the ! ! application of K(ilev) ! y(ilev) = y(ilev) + (K(ilev)^(-1))*x(ilev) -! Else -! Apply the base preconditioner to the residual at the current level: -! ! The sum over the subdomains is carried out in the -! ! application of K(ilev) -! y(ilev) = (K(ilev)^(-1))*x(ilev) -! +! +! 3. If ilev == nlev apply y(ilev) = (K(ilev)^(-1))*x(ilev) +! ! 4. if ilev == 1 Transfer the inner Y to the external: ! Yext = beta*Yext + alpha*Y(1) ! @@ -278,11 +269,8 @@ ! differential equations, Cambridge University Press, 1996. ! ! -! 0. Transfer the outer vector Xest to x(1) (inner X at level 1) +! 1. Transfer the outer vector Xest to x(1) (inner X at level 1) ! -! 1. If ilev > 1 Transfer x(ilev-1) to the current level: -! x(ilev) = PT(ilev)*x(ilev-1) -! ! 2. Apply the base preconditioner at the current level: ! ! The sum over the subdomains is carried out in the ! ! application of K(ilev) @@ -291,10 +279,10 @@ ! 3. If ilev < nlevel ! a. Compute the residual: ! r(ilev) = x(ilev) - A(ilev)*y(ilev) -! b. Call recursively itself passing -! r(ilev) for transfer to the next level -! (r(ilev) matches x(ilev-1) in step 1) -! c. Transfer y(ilev+1) to the current level: +! b. Transfer r(ilev) to the next level: +! x(ilev+1) = PT(ilev+1)*r(ilev) +! c. Call recursively +! d. Transfer y(ilev+1) to the current level: ! y(ilev) = y(ilev) + P(ilev+1)*y(ilev+1) ! d. Compute the residual: ! r(ilev) = x(ilev) - A(ilev)*y(ilev) @@ -303,35 +291,36 @@ ! ! application of K(ilev) ! y(ilev) = y(ilev) + (K(ilev)^(-1))*r(ilev) ! -! 5. if ilev == 1 Transfer the inner Y to the external: +! 4. if ilev == 1 Transfer the inner Y to the external: ! Yext = beta*Yext + alpha*Y(1) ! ! -subroutine mld_cmlprec_aply(alpha,p,x,beta,y,desc_data,trans,work,info) +subroutine mld_cmlprec_aply_vect(alpha,p,x,beta,y,desc_data,trans,work,info) use psb_base_mod - use mld_c_inner_mod, mld_protect_name => mld_cmlprec_aply + use mld_c_inner_mod, mld_protect_name => mld_cmlprec_aply_vect implicit none ! Arguments - type(psb_desc_type),intent(in) :: desc_data - type(mld_cprec_type), intent(inout) :: p - complex(psb_spk_),intent(in) :: alpha,beta - complex(psb_spk_),intent(inout) :: x(:) - complex(psb_spk_),intent(inout) :: y(:) - character, intent(in) :: trans - complex(psb_spk_),target :: work(:) - integer(psb_ipk_), intent(out) :: info + type(psb_desc_type),intent(in) :: desc_data + type(mld_cprec_type), intent(inout) :: p + complex(psb_spk_),intent(in) :: alpha,beta + type(psb_c_vect_type),intent(inout) :: x + type(psb_c_vect_type),intent(inout) :: y + character, intent(in) :: trans + complex(psb_spk_),target :: work(:) + integer(psb_ipk_), intent(out) :: info ! Local variables integer(psb_ipk_) :: ictxt, np, me - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: debug_level, debug_unit, nlev,nc2l,nr2l,level + integer(psb_ipk_) :: debug_level, debug_unit, nlev,nc2l,nr2l,level, err_act character(len=20) :: name character :: trans_ + complex(psb_spk_) :: par type mld_mlprec_wrk_type complex(psb_spk_), allocatable :: tx(:), ty(:), x2l(:), y2l(:) + type(psb_c_vect_type) :: vtx, vty, vx2l, vy2l end type mld_mlprec_wrk_type type(mld_mlprec_wrk_type), allocatable, target :: mlprec_wrk(:) @@ -349,7 +338,6 @@ subroutine mld_cmlprec_aply(alpha,p,x,beta,y,desc_data,trans,work,info) & ' Entry ', size(p%precv) trans_ = psb_toupper(trans) - nlev = size(p%precv) allocate(mlprec_wrk(nlev),stat=info) if (info /= psb_success_) then @@ -357,21 +345,32 @@ subroutine mld_cmlprec_aply(alpha,p,x,beta,y,desc_data,trans,work,info) goto 9999 end if level = 1 + do level = 1, nlev + call psb_geasb(mlprec_wrk(level)%vx2l,& + & p%precv(level)%base_desc,info,& + & scratch=.true.,mold=x%v) + call psb_geasb(mlprec_wrk(level)%vy2l,& + & p%precv(level)%base_desc,info,& + & scratch=.true.,mold=x%v) + call psb_geasb(mlprec_wrk(level)%vtx,& + & p%precv(level)%base_desc,info,& + & scratch=.true.,mold=x%v) + call psb_geasb(mlprec_wrk(level)%vty,& + & p%precv(level)%base_desc,info,& + & scratch=.true.,mold=x%v) + if (psb_errstatus_fatal()) then + nc2l = p%precv(level)%base_desc%get_local_cols() + info=psb_err_alloc_request_ + call psb_errpush(info,name,i_err=(/2*nc2l,izero,izero,izero,izero/),& + & a_err='complex(psb_spk_)') + goto 9999 + end if + end do + level = 1 - nc2l = p%precv(level)%base_desc%get_local_cols() - nr2l = p%precv(level)%base_desc%get_local_rows() - allocate(mlprec_wrk(level)%x2l(nc2l),mlprec_wrk(level)%y2l(nc2l),& - & stat=info) - if (info /= psb_success_) then - info=psb_err_alloc_request_ - call psb_errpush(info,name,& - & i_err=(/ione*(size(x)+size(y)),izero,izero,izero,izero/),& - & a_err='complex(psb_spk_)') - goto 9999 - end if + call psb_geaxpby(cone,x,czero,mlprec_wrk(level)%vx2l,p%precv(level)%base_desc,info) + call mlprec_wrk(level)%vy2l%zero() - mlprec_wrk(level)%x2l(:) = x(:) - mlprec_wrk(level)%y2l(:) = czero call inner_ml_aply(level,p,mlprec_wrk,trans_,work,info) @@ -381,8 +380,22 @@ subroutine mld_cmlprec_aply(alpha,p,x,beta,y,desc_data,trans,work,info) goto 9999 end if - call psb_geaxpby(alpha,mlprec_wrk(level)%y2l,beta,y,& + call psb_geaxpby(alpha,mlprec_wrk(level)%vy2l,beta,y,& & p%precv(level)%base_desc,info) + do level = 1, nlev + + call mlprec_wrk(level)%vx2l%free(info) + call mlprec_wrk(level)%vy2l%free(info) + call mlprec_wrk(level)%vtx%free(info) + call mlprec_wrk(level)%vty%free(info) + if (psb_errstatus_fatal()) then + info=psb_err_alloc_request_ + nc2l = p%precv(level)%base_desc%get_local_cols() + call psb_errpush(info,name,i_err=(/2*nc2l,izero,izero,izero,izero/),& + & a_err='complex(psb_spk_)') + goto 9999 + end if + end do if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& @@ -399,7 +412,28 @@ subroutine mld_cmlprec_aply(alpha,p,x,beta,y,desc_data,trans,work,info) return contains - + ! + ! + ! inner_ml_aply: apply AMG at a given level. + ! This routine dispatches the computation according to the type + ! specified at the current level. + ! Each of the corrections will inturn call recursively this routine. + ! + ! Assumptions: + ! On input: + ! mlprec_wkr(level)%vx2l contains the input vector (RHS) + ! mlprec_wkr(level)%vy2l contains the initial guess + ! + ! On output: + ! mlprec_wkr(level)%vy2l contains the solution + ! + ! Constraints: each of the called routines must properly handle + ! the input/output conditions for level+1 (i.e. apply + ! prolongation/restriction). + ! Note: for historical/convenience reasons the prolongator/restrictor + ! between level and level+1 are stored at level+1. + ! + ! recursive subroutine inner_ml_aply(level,p,mlprec_wrk,trans,work,info) implicit none @@ -407,24 +441,29 @@ contains ! Arguments integer(psb_ipk_) :: level type(mld_cprec_type), target, intent(inout) :: p - type(mld_mlprec_wrk_type), intent(inout) :: mlprec_wrk(:) + type(mld_mlprec_wrk_type), intent(inout), target :: mlprec_wrk(:) character, intent(in) :: trans - complex(psb_spk_),target :: work(:) - integer(psb_ipk_), intent(out) :: info + complex(psb_spk_),target :: work(:) + integer(psb_ipk_), intent(out) :: info + type(psb_c_vect_type) :: res + type(psb_c_vect_type), pointer :: current + integer(psb_ipk_) :: sweeps_post, sweeps_pre ! Local variables integer(psb_ipk_) :: ictxt,np,me - integer(psb_ipk_) :: i, nr2l,nc2l,err_act + integer(psb_ipk_) :: i, err_act integer(psb_ipk_) :: debug_level, debug_unit integer(psb_ipk_) :: nlev, ilev, sweeps + logical :: pre, post character(len=20) :: name + + name = 'inner_ml_aply' info = psb_success_ call psb_erractionsave(err_act) debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() - nlev = size(p%precv) if ((level < 1) .or. (level > nlev)) then call psb_errpush(psb_err_internal_error_,name,& @@ -434,18 +473,8 @@ 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() - allocate(mlprec_wrk(level)%x2l(nc2l),& - & mlprec_wrk(level)%y2l(nc2l),& - & stat=info) - if (info /= psb_success_) then - info=psb_err_alloc_request_ - call psb_errpush(info,name,i_err=(/2*nc2l,izero,izero,izero,izero/),& - & a_err='complex(psb_spk_)') - goto 9999 - end if + 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) @@ -459,56 +488,9 @@ contains goto 9999 case(mld_add_ml_) - ! - ! Additive multilevel - ! - - if (level > 1) then - ! Apply the restriction - call psb_map_X2Y(cone,mlprec_wrk(level-1)%x2l,& - & czero,mlprec_wrk(level)%x2l,& - & p%precv(level)%map,info,work=work) - - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during restriction') - goto 9999 - end if - - end if - - 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) - - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during smoother_apply') - goto 9999 - end if - if (level < nlev) then - call inner_ml_aply(level+1,p,mlprec_wrk,trans,work,info) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error in recursive call') - goto 9999 - end if - ! - ! Apply the prolongator - ! - call psb_map_Y2X(cone,mlprec_wrk(level+1)%y2l,& - & cone,mlprec_wrk(level)%y2l,& - & 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 + call mld_c_inner_add(p, mlprec_wrk, level, trans, work) - end if case(mld_mult_ml_) ! @@ -521,452 +503,16 @@ contains select case(p%precv(level)%parms%smoother_pos) case(mld_post_smooth_) - - select case (trans_) - case('N') - if (level > 1) then - ! Apply the restriction - call psb_map_X2Y(cone,mlprec_wrk(level-1)%x2l,& - & czero,mlprec_wrk(level)%x2l,& - & p%precv(level)%map,info,work=work) - - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during restriction') - goto 9999 - end if - 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 - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error in recursive call') - goto 9999 - end if - ! - ! Apply the prolongator - ! - call psb_map_Y2X(cone,mlprec_wrk(level+1)%y2l,& - & czero,mlprec_wrk(level)%y2l,& - & 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 - ! - call psb_spmm(-cone,p%precv(level)%base_a,mlprec_wrk(level)%y2l,& - & cone,mlprec_wrk(level)%x2l,p%precv(level)%base_desc,info,& - & work=work,trans=trans) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during residue') - goto 9999 - end if - - sweeps = p%precv(level)%parms%sweeps_post - 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) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during smoother_apply') - goto 9999 - end if - - 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) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during smoother_apply') - goto 9999 - end if - - end if - - case('T','C') - - ! Post-smoothing transpose is pre-smoothing - - - if (level > 1) then - ! Apply the restriction - call psb_map_X2Y(cone,mlprec_wrk(level-1)%x2l,& - & czero,mlprec_wrk(level)%x2l,& - & p%precv(level)%map,info,work=work) - - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during restriction') - goto 9999 - end if - - - end if - - ! - ! Apply the base preconditioner - ! - 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 - - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during smoother_apply') - goto 9999 - end if - - ! - ! Compute the residual (at all levels but the coarsest one) - ! - if (level < nlev) then - call psb_spmm(-cone,p%precv(level)%base_a,& - & mlprec_wrk(level)%y2l,cone,mlprec_wrk(level)%x2l,& - & p%precv(level)%base_desc,info,work=work,trans=trans) - - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during residue') - goto 9999 - end if - - call inner_ml_aply(level+1,p,mlprec_wrk,trans,work,info) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error in recursive call') - goto 9999 - end if - - - call psb_map_Y2X(cone,mlprec_wrk(level+1)%y2l,& - & cone,mlprec_wrk(level)%y2l,& - & 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 - - - end if - - case default - info = psb_err_internal_error_ - call psb_errpush(info,name,a_err='invalid trans') - goto 9999 - end select + p%precv(level)%parms%sweeps_pre = 0 + call mld_c_inner_mult(p, mlprec_wrk, level, trans, work) + case(mld_pre_smooth_) - - select case (trans_) - case('N') - ! One step of pre-smoothing - - - if (level > 1) then - ! Apply the restriction - call psb_map_X2Y(cone,mlprec_wrk(level-1)%x2l,& - & czero,mlprec_wrk(level)%x2l,& - & p%precv(level)%map,info,work=work) - - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during restriction') - goto 9999 - end if - - end if - - ! - ! Apply the base preconditioner - ! - if (level < nlev) then - sweeps = p%precv(level)%parms%sweeps_pre - else - sweeps = p%precv(level)%parms%sweeps - 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,& - & a_err='Error during smoother_apply') - goto 9999 - end if - - ! - ! Compute the residual (at all levels but the coarsest one) - ! - if (level < nlev) then - call psb_spmm(-cone,p%precv(level)%base_a,& - & mlprec_wrk(level)%y2l,cone,mlprec_wrk(level)%x2l,& - & p%precv(level)%base_desc,info,work=work,trans=trans) - if (info /= psb_success_) goto 9999 - call inner_ml_aply(level+1,p,mlprec_wrk,trans,work,info) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error in recursive call') - goto 9999 - end if - - - call psb_map_Y2X(cone,mlprec_wrk(level+1)%y2l,& - & cone,mlprec_wrk(level)%y2l,& - & 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 - - - end if - - - case('T','C') - - ! pre-smooth transpose is post-smoothing - - - if (level > 1) then - ! Apply the restriction - call psb_map_X2Y(cone,mlprec_wrk(level-1)%x2l,& - & czero,mlprec_wrk(level)%x2l,& - & p%precv(level)%map,info,work=work) - - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during restriction') - goto 9999 - end if - - end if - - if (level < nlev) then - call inner_ml_aply(level+1,p,mlprec_wrk,trans,work,info) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error in recursive call') - goto 9999 - end if - - ! - ! Apply the prolongator - ! - call psb_map_Y2X(cone,mlprec_wrk(level+1)%y2l,& - & czero,mlprec_wrk(level)%y2l,& - & 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 - ! - call psb_spmm(-cone,p%precv(level)%base_a,mlprec_wrk(level)%y2l,& - & cone,mlprec_wrk(level)%x2l,p%precv(level)%base_desc,info,& - & work=work,trans=trans) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during residue') - goto 9999 - end if - - - sweeps = p%precv(level)%parms%sweeps_pre - call p%precv(level)%sm%apply(cone,& - & mlprec_wrk(level)%x2l,cone,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,& - & a_err='Error during smoother_apply') - goto 9999 - end if - 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) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during smoother_apply') - goto 9999 - end if - - end if - - case default - info = psb_err_internal_error_ - call psb_errpush(info,name,a_err='invalid trans') - goto 9999 - end select + p%precv(level)%parms%sweeps_post = 0 + call mld_c_inner_mult(p, mlprec_wrk, level, trans, work) 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) - if (info /= psb_success_) then - info=psb_err_alloc_request_ - call psb_errpush(info,name,i_err=(/2*nc2l,izero,izero,izero,izero/),& - & a_err='complex(psb_spk_)') - goto 9999 - end if - - if (level > 1) then - ! Apply the restriction - call psb_map_X2Y(cone,mlprec_wrk(level-1)%ty,& - & czero,mlprec_wrk(level)%x2l,& - & p%precv(level)%map,info,work=work) - - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during restriction') - goto 9999 - end if - end if - call psb_geaxpby(cone,mlprec_wrk(level)%x2l,czero,mlprec_wrk(level)%tx,& - & p%precv(level)%base_desc,info) - ! - ! Apply the base preconditioner - ! - if (level < nlev) then - if (trans == 'N') then - sweeps = p%precv(level)%parms%sweeps_pre - else - sweeps = p%precv(level)%parms%sweeps_post - 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(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') - goto 9999 - end if - ! - ! Compute the residual (at all levels but the coarsest one) - ! and call recursively - ! - if(level < nlev) then - mlprec_wrk(level)%ty = mlprec_wrk(level)%x2l - if (info == psb_success_) call psb_spmm(-cone,p%precv(level)%base_a,& - & mlprec_wrk(level)%y2l,cone,mlprec_wrk(level)%ty,& - & p%precv(level)%base_desc,info,work=work,trans=trans) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during residue') - goto 9999 - end if - - call inner_ml_aply(level+1,p,mlprec_wrk,trans,work,info) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error in recursive call') - goto 9999 - end if - - - ! - ! Apply the prolongator - ! - call psb_map_Y2X(cone,mlprec_wrk(level+1)%y2l,& - & cone,mlprec_wrk(level)%y2l,& - & 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 - ! - call psb_spmm(-cone,p%precv(level)%base_a,mlprec_wrk(level)%y2l,& - & cone,mlprec_wrk(level)%tx,p%precv(level)%base_desc,info,& - & work=work,trans=trans) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during residue') - goto 9999 - end if - ! - ! Apply the base preconditioner - ! - if (trans == 'N') then - sweeps = p%precv(level)%parms%sweeps_post - else - sweeps = p%precv(level)%parms%sweeps_pre - end if - 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') - goto 9999 - end if - - endif + call mld_c_inner_mult(p, mlprec_wrk, level, trans, work) case default info = psb_err_from_subroutine_ai_ @@ -976,6 +522,15 @@ contains end select + + case(mld_vcycle_ml_, mld_wcycle_ml_) + + call mld_c_inner_mult(p, mlprec_wrk, level, trans, work) + + case(mld_kcycle_ml_, mld_kcyclesym_ml_) + + call mld_c_inner_k_cycle(p, mlprec_wrk, level, trans, work) + case default info = psb_err_from_subroutine_ai_ call psb_errpush(info,name,a_err='invalid mltype',& @@ -992,293 +547,50 @@ contains end subroutine inner_ml_aply -end subroutine mld_cmlprec_aply -subroutine mld_cmlprec_aply_vect(alpha,p,x,beta,y,desc_data,trans,work,info) + recursive subroutine mld_c_inner_add(p, mlprec_wrk, level, trans, work) + use psb_base_mod + use mld_prec_mod - use psb_base_mod - use mld_c_inner_mod, mld_protect_name => mld_cmlprec_aply_vect + implicit none - implicit none + !Input/Oputput variables + type(mld_cprec_type), intent(inout) :: p - ! Arguments - type(psb_desc_type),intent(in) :: desc_data - type(mld_cprec_type), intent(inout) :: p - complex(psb_spk_),intent(in) :: alpha,beta - type(psb_c_vect_type),intent(inout) :: x - type(psb_c_vect_type),intent(inout) :: y - character, intent(in) :: trans - complex(psb_spk_),target :: work(:) - integer(psb_ipk_), intent(out) :: info + type(mld_mlprec_wrk_type), target, intent(inout) :: mlprec_wrk(:) + integer(psb_ipk_), intent(in) :: level + character, intent(in) :: trans + complex(psb_spk_),target :: work(:) + type(psb_c_vect_type) :: res + type(psb_c_vect_type), pointer :: current + integer(psb_ipk_) :: sweeps_post, sweeps_pre + ! Local variables + integer(psb_ipk_) :: ictxt,np,me + integer(psb_ipk_) :: i, err_act + integer(psb_ipk_) :: debug_level, debug_unit + integer(psb_ipk_) :: nlev, ilev, sweeps + logical :: pre, post + character(len=20) :: name - ! Local variables - integer(psb_ipk_) :: ictxt, np, me - integer(psb_ipk_) :: debug_level, debug_unit, nlev,nc2l,nr2l,level, err_act - character(len=20) :: name - character :: trans_ - complex(psb_spk_) :: par - type mld_mlprec_wrk_type - complex(psb_spk_), allocatable :: tx(:), ty(:), x2l(:), y2l(:) - type(psb_c_vect_type) :: vtx, vty, vx2l, vy2l - end type mld_mlprec_wrk_type - type(mld_mlprec_wrk_type), allocatable, target :: mlprec_wrk(:) - name='mld_cmlprec_aply' - info = psb_success_ - call psb_erractionsave(err_act) - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - ictxt = desc_data%get_context() - call psb_info(ictxt, me, np) + name = 'inner_inner_add' + info = psb_success_ + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + nlev = size(p%precv) + if ((level < 1) .or. (level > nlev)) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='wrong call level to inner_add') + goto 9999 + end if + ictxt = p%precv(level)%base_desc%get_context() + call psb_info(ictxt, me, np) - if (debug_level >= psb_debug_inner_) & - & write(debug_unit,*) me,' ',trim(name),& - & ' Entry ', size(p%precv) - - trans_ = psb_toupper(trans) - nlev = size(p%precv) - allocate(mlprec_wrk(nlev),stat=info) - if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') - goto 9999 - end if - level = 1 - do level = 1, nlev - call psb_geasb(mlprec_wrk(level)%vx2l,& - & p%precv(level)%base_desc,info,& - & scratch=.true.,mold=x%v) - call psb_geasb(mlprec_wrk(level)%vy2l,& - & p%precv(level)%base_desc,info,& - & scratch=.true.,mold=x%v) - call psb_geasb(mlprec_wrk(level)%vtx,& - & p%precv(level)%base_desc,info,& - & scratch=.true.,mold=x%v) - call psb_geasb(mlprec_wrk(level)%vty,& - & p%precv(level)%base_desc,info,& - & scratch=.true.,mold=x%v) - if (psb_errstatus_fatal()) then - nc2l = p%precv(level)%base_desc%get_local_cols() - info=psb_err_alloc_request_ - call psb_errpush(info,name,i_err=(/2*nc2l,izero,izero,izero,izero/),& - & a_err='complex(psb_spk_)') - goto 9999 - end if - end do - level = 1 - - call psb_geaxpby(cone,x,czero,mlprec_wrk(level)%vx2l,p%precv(level)%base_desc,info) - call mlprec_wrk(level)%vy2l%zero() - - - call inner_ml_aply(level,p,mlprec_wrk,trans_,work,info) - - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Inner prec aply') - goto 9999 - end if - - call psb_geaxpby(alpha,mlprec_wrk(level)%vy2l,beta,y,& - & p%precv(level)%base_desc,info) - do level = 1, nlev - - call mlprec_wrk(level)%vx2l%free(info) - call mlprec_wrk(level)%vy2l%free(info) - call mlprec_wrk(level)%vtx%free(info) - call mlprec_wrk(level)%vty%free(info) - if (psb_errstatus_fatal()) then - info=psb_err_alloc_request_ - nc2l = p%precv(level)%base_desc%get_local_cols() - call psb_errpush(info,name,i_err=(/2*nc2l,izero,izero,izero,izero/),& - & a_err='complex(psb_spk_)') - goto 9999 - end if - end do - - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error final update') - goto 9999 - end if - - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - -contains - - recursive subroutine inner_ml_aply(level,p,mlprec_wrk,trans,work,info, U) - - implicit none - - ! Arguments - integer(psb_ipk_) :: level - type(mld_cprec_type), target, intent(inout) :: p - type(mld_mlprec_wrk_type), intent(inout), target :: mlprec_wrk(:) - character, intent(in) :: trans - complex(psb_spk_),target :: work(:) - integer(psb_ipk_), intent(out) :: info - type(psb_c_vect_type),intent(inout), optional :: u - - type(psb_c_vect_type) :: res - type(psb_c_vect_type), pointer :: current - integer(psb_ipk_) :: sweeps_post, sweeps_pre - ! Local variables - integer(psb_ipk_) :: ictxt,np,me - integer(psb_ipk_) :: i, nr2l,nc2l,err_act - integer(psb_ipk_) :: debug_level, debug_unit - integer(psb_ipk_) :: nlev, ilev, sweeps - logical :: pre, post - character(len=20) :: name - - - - name = 'inner_ml_aply' - info = psb_success_ - call psb_erractionsave(err_act) - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - nlev = size(p%precv) - if ((level < 1) .or. (level > nlev)) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='wrong call level to inner_ml') - goto 9999 - end if - ictxt = p%precv(level)%base_desc%get_context() - call psb_info(ictxt, me, np) - - 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) - - case(mld_no_ml_) - ! - ! No preconditioning, should not really get here - ! - call psb_errpush(psb_err_internal_error_,name,& - & a_err='mld_no_ml_ in mlprc_aply?') - goto 9999 - - case(mld_add_ml_) - - call mld_c_inner_add(p, mlprec_wrk, level, trans, work) - - - case(mld_mult_ml_) - ! - ! Multiplicative multilevel (multiplicative among the levels, additive inside - ! each level) - ! - ! Pre/post-smoothing versions. - ! Note that the transpose switches pre <-> post. - ! - select case(p%precv(level)%parms%smoother_pos) - - case(mld_post_smooth_) - p%precv(level)%parms%sweeps_pre = 0 - call mld_c_inner_mult(p, mlprec_wrk, level, trans, work) - - - case(mld_pre_smooth_) - p%precv(level)%parms%sweeps_post = 0 - call mld_c_inner_mult(p, mlprec_wrk, level, trans, work) - - case(mld_twoside_smooth_) - call mld_c_inner_mult(p, mlprec_wrk, level, trans, work) - - case default - info = psb_err_from_subroutine_ai_ - call psb_errpush(info,name,a_err='invalid smooth_pos',& - & i_Err=(/p%precv(level)%parms%smoother_pos,izero,izero,izero,izero/)) - goto 9999 - - end select - - - case(mld_mult_dev_ml_) - - call mld_c_inner_mult(p, mlprec_wrk, level, trans, work) - - - case(mld_vcycle_ml_, mld_wcycle_ml_) - - call mld_c_inner_vw_cycle(p, mlprec_wrk, level, trans, work, u=u) - - case(mld_kcycle_ml_, mld_kcyclesym_ml_) - - call mld_c_inner_k_cycle(p, mlprec_wrk, level, trans, work, u=u) - - case default - info = psb_err_from_subroutine_ai_ - call psb_errpush(info,name,a_err='invalid mltype',& - & i_Err=(/p%precv(level)%parms%ml_type,izero,izero,izero,izero/)) - goto 9999 - - end select - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - return - - end subroutine inner_ml_aply - - - recursive subroutine mld_c_inner_add(p, mlprec_wrk, level, trans, work) - use psb_base_mod - use mld_prec_mod - - implicit none - - !Input/Oputput variables - type(mld_cprec_type), intent(inout) :: p - - type(mld_mlprec_wrk_type), target, intent(inout) :: mlprec_wrk(:) - integer(psb_ipk_), intent(in) :: level - character, intent(in) :: trans - complex(psb_spk_),target :: work(:) - type(psb_c_vect_type) :: res - type(psb_c_vect_type), pointer :: current - integer(psb_ipk_) :: sweeps_post, sweeps_pre - ! Local variables - integer(psb_ipk_) :: ictxt,np,me - integer(psb_ipk_) :: i, nr2l,nc2l,err_act - integer(psb_ipk_) :: debug_level, debug_unit - integer(psb_ipk_) :: nlev, ilev, sweeps - logical :: pre, post - character(len=20) :: name - - - - name = 'inner_inner_add' - info = psb_success_ - call psb_erractionsave(err_act) - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - nlev = size(p%precv) - if ((level < 1) .or. (level > nlev)) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='wrong call level to inner_add') - goto 9999 - end if - ictxt = p%precv(level)%base_desc%get_context() - call psb_info(ictxt, me, np) - - 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_add at level ',level - end if + if(debug_level > 1) then + write(debug_unit,*) me,' inner_add at level ',level + end if if ((level<1).or.(level>nlev)) then info = psb_err_internal_error_ @@ -1287,21 +599,6 @@ contains goto 9999 end if - - if (level > 1) then - ! Apply the restriction - call psb_map_X2Y(cone,mlprec_wrk(level-1)%vx2l,& - & czero,mlprec_wrk(level)%vx2l,& - & p%precv(level)%map,info,work=work) - - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during restriction') - goto 9999 - end if - - end if - sweeps = p%precv(level)%parms%sweeps call p%precv(level)%sm%apply(cone,& & mlprec_wrk(level)%vx2l,czero,mlprec_wrk(level)%vy2l,& @@ -1314,6 +611,17 @@ contains end if if (level < nlev) then + ! Apply the restriction + call psb_map_X2Y(cone,mlprec_wrk(level)%vx2l,& + & czero,mlprec_wrk(level+1)%vx2l,& + & p%precv(level+1)%map,info,work=work) + call mlprec_wrk(level+1)%vy2l%zero() + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Error during restriction') + goto 9999 + end if + call inner_ml_aply(level+1,p,mlprec_wrk,trans,work,info) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& @@ -1362,7 +670,7 @@ contains integer(psb_ipk_) :: sweeps_post, sweeps_pre ! Local variables integer(psb_ipk_) :: ictxt,np,me - integer(psb_ipk_) :: i, nr2l,nc2l,err_act + integer(psb_ipk_) :: i, err_act integer(psb_ipk_) :: debug_level, debug_unit integer(psb_ipk_) :: nlev, ilev, sweeps logical :: pre, post @@ -1384,13 +692,10 @@ contains ictxt = p%precv(level)%base_desc%get_context() call psb_info(ictxt, me, np) - 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_mult at level ',level end if - if ((level < nlev).or.(nlev == 1)) then sweeps_post = p%precv(level)%parms%sweeps_post sweeps_pre = p%precv(level)%parms%sweeps_pre @@ -1402,49 +707,31 @@ contains pre = ((sweeps_pre>0).and.(trans=='N')).or.((sweeps_post>0).and.(trans/='N')) post = ((sweeps_post>0).and.(trans=='N')).or.((sweeps_pre>0).and.(trans/='N')) + + if (level < nlev) then + + ! + ! Apply the first smoother + ! - if (level > 1) then - ! Apply the restriction - if (pre) then - current => mlprec_wrk(level-1)%vty - else - current => mlprec_wrk(level-1)%vx2l - endif - call psb_map_X2Y(cone,current,& - & czero,mlprec_wrk(level)%vx2l,& - & p%precv(level)%map,info,work=work) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during restriction') - goto 9999 - end if - end if - - - if (level < nlev) then - - ! - ! Apply the base preconditioner - ! - if (pre) then if (trans == 'N') then sweeps = p%precv(level)%parms%sweeps_pre if (info == psb_success_) call p%precv(level)%sm%apply(cone,& & mlprec_wrk(level)%vx2l,czero,mlprec_wrk(level)%vy2l,& & p%precv(level)%base_desc, trans,& - & sweeps,work,info) + & sweeps,work,info,init='Y') 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) + & sweeps,work,info,init='Y') end if if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during 2-PRE smoother_apply') + & a_err='Error during PRE smoother_apply') goto 9999 end if endif @@ -1465,9 +752,36 @@ contains & a_err='Error during residue') goto 9999 end if + call psb_map_X2Y(cone,mlprec_wrk(level)%vty,& + & czero,mlprec_wrk(level+1)%vx2l,& + & 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 restriction') + goto 9999 + end if + else + ! Shortcut: just transfer x2l. + call psb_map_X2Y(cone,mlprec_wrk(level)%vx2l,& + & czero,mlprec_wrk(level+1)%vx2l,& + & 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 restriction') + goto 9999 + end if endif + ! First guess is zero + call mlprec_wrk(level+1)%vy2l%zero() + call inner_ml_aply(level+1,p,mlprec_wrk,trans,work,info) + + if (p%precv(level)%parms%ml_type == mld_wcycle_ml_) then + ! On second call will use output y2l as initial guess + if (info == psb_success_) call inner_ml_aply(level+1,p,mlprec_wrk,trans,work,info) + endif + if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& & a_err='Error in recursive call') @@ -1478,15 +792,8 @@ contains ! ! Apply the prolongator ! - - if (pre) then - par = cone - else - par = czero - endif - call psb_map_Y2X(cone,mlprec_wrk(level+1)%vy2l,& - & par,mlprec_wrk(level)%vy2l,& + & cone,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,& @@ -1510,27 +817,28 @@ contains goto 9999 end if ! - ! Apply the base preconditioner + ! Apply the second smoother ! if (trans == 'N') then sweeps = p%precv(level)%parms%sweeps_post if (info == psb_success_) call p%precv(level)%sm2%apply(cone,& & mlprec_wrk(level)%vtx,cone,mlprec_wrk(level)%vy2l,& & p%precv(level)%base_desc, trans,& - & sweeps,work,info) + & sweeps,work,info,init='Y') 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) + & sweeps,work,info,init='Y') end if if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during 2-POST smoother_apply') + & a_err='Error during POST smoother_apply') goto 9999 end if + endif else if (level == nlev) then @@ -1545,7 +853,7 @@ contains info = psb_err_internal_error_ call psb_errpush(info,name,& - & a_err='Invalid LEVEL>NLEV') + & a_err='Invalid LEVEL vs NLEV') goto 9999 end if @@ -1557,7 +865,7 @@ contains end subroutine mld_c_inner_mult - recursive subroutine mld_c_inner_vw_cycle(p, mlprec_wrk, level, trans, work,u) + recursive subroutine mld_c_inner_k_cycle(p, mlprec_wrk, level, trans, work,u) use psb_base_mod use mld_prec_mod @@ -1578,7 +886,7 @@ contains integer(psb_ipk_) :: sweeps_post, sweeps_pre ! Local variables integer(psb_ipk_) :: ictxt,np,me - integer(psb_ipk_) :: i, nr2l,nc2l,err_act + integer(psb_ipk_) :: i, err_act integer(psb_ipk_) :: debug_level, debug_unit integer(psb_ipk_) :: nlev, ilev, sweeps logical :: pre, post @@ -1600,8 +908,6 @@ contains ictxt = p%precv(level)%base_desc%get_context() call psb_info(ictxt, me, np) - 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_add at level ',level end if @@ -1612,90 +918,50 @@ contains & a_err='Invalid LEVEL>NLEV') goto 9999 end if - call psb_geasb(res,p%precv(level)%base_desc,info,& - & scratch=.true., mold=mlprec_wrk(level)%vx2l%v) - - !V/W cycle - if (level > 1) then - ! Apply the restriction - call psb_map_X2Y(cone,mlprec_wrk(level-1)%vty,& - & czero,mlprec_wrk(level)%vx2l,& - & p%precv(level)%map,info,work=work) - - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during restriction') - goto 9999 - end if - end if - - call psb_geaxpby(cone,mlprec_wrk(level)%vx2l,& - & czero,mlprec_wrk(level)%vtx,& - & p%precv(level)%base_desc,info) - ! - ! Apply the base preconditioner - ! - if (level < nlev) then - - if (present(u)) then - ! call mlprec_wrk(level)%vy2l%set(u%get_vect()) - call psb_geaxpby(cone,u,& - & czero,mlprec_wrk(level)%vy2l,& - & p%precv(level)%base_desc,info) - - else - call mlprec_wrk(level)%vy2l%zero() - endif - call psb_geaxpby(cone,mlprec_wrk(level)%vx2l,czero,res,& - & p%precv(level)%base_desc,info) - - call psb_spmm(-cone,p%precv(level)%base_a,mlprec_wrk(level)%vy2l,& - cone, res, p%precv(level)%base_desc, info, work=work, trans=trans) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during residue') - goto 9999 - end if + !K cycle + + if (level == nlev) then + ! + ! Apply smoother + ! + 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,init='Y') + + else 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) + & sweeps,work,info,init='Y') 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) + & sweeps,work,info,init='Y') 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_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during 2-PRE smoother_apply') - goto 9999 - end if + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,& + & 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 - ! - if(level < nlev) then + ! + ! Compute the residual and call recursively + ! call psb_geaxpby(cone,mlprec_wrk(level)%vx2l,& & czero,mlprec_wrk(level)%vty,& & p%precv(level)%base_desc,info) - + if (info == psb_success_) call psb_spmm(-cone,p%precv(level)%base_a,& & mlprec_wrk(level)%vy2l,cone,mlprec_wrk(level)%vty,& & p%precv(level)%base_desc,info,work=work,trans=trans) @@ -1705,10 +971,27 @@ contains goto 9999 end if - call inner_ml_aply(level+1,p,mlprec_wrk,trans,work,info) + ! Apply the restriction + call psb_map_X2Y(cone,mlprec_wrk(level)%vty,& + & czero,mlprec_wrk(level + 1)%vx2l,& + & p%precv(level + 1)%map,info,work=work) + call mlprec_wrk(level + 1)%vy2l%zero() + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Error during restriction') + goto 9999 + end if - if (p%precv(level)%parms%ml_type == mld_wcycle_ml_) then - call inner_ml_aply(level+1,p,mlprec_wrk,trans,work,info, u=mlprec_wrk(level+1)%vy2l) + !Set the preconditioner + + if ((level < nlev - 2)) then + if (p%precv(level)%parms%ml_type == mld_kcyclesym_ml_) then + call mld_cinneritkcycle(p, mlprec_wrk, level + 1, trans, work, 'FCG') + elseif (p%precv(level)%parms%ml_type == mld_kcycle_ml_) then + call mld_cinneritkcycle(p, mlprec_wrk, level + 1, trans, work, 'CGR') + endif + else + call inner_ml_aply(level + 1 ,p,mlprec_wrk,trans,work,info) endif if (info /= psb_success_) then @@ -1717,7 +1000,6 @@ contains goto 9999 end if - ! ! Apply the prolongator ! @@ -1734,8 +1016,11 @@ contains ! ! Compute the residual ! + call psb_geaxpby(cone,mlprec_wrk(level)%vx2l,& + & czero,mlprec_wrk(level)%vty,& + & p%precv(level)%base_desc,info) call psb_spmm(-cone,p%precv(level)%base_a,mlprec_wrk(level)%vy2l,& - & cone,mlprec_wrk(level)%vtx,p%precv(level)%base_desc,info,& + & cone,mlprec_wrk(level)%vty,p%precv(level)%base_desc,info,& & work=work,trans=trans) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& @@ -1743,341 +1028,127 @@ contains goto 9999 end if ! - ! Apply the base preconditioner + ! Apply the smoother ! 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,& + & mlprec_wrk(level)%vty,cone,mlprec_wrk(level)%vy2l,& & p%precv(level)%base_desc, trans,& - & sweeps,work,info) + & sweeps,work,info,init='Y') 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,& + & mlprec_wrk(level)%vty,cone,mlprec_wrk(level)%vy2l,& & p%precv(level)%base_desc, trans,& - & sweeps,work,info) + & sweeps,work,info,init='Y') end if if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during 2-POST smoother_apply') + & a_err='Error during POST smoother_apply') goto 9999 end if + else + info = psb_err_internal_error_ + call psb_errpush(info,name,& + & a_err='Invalid LEVEL vs NLEV') + goto 9999 + endif - call psb_erractionrestore(err_act) return 9999 call psb_error_handler(err_act) return - end subroutine mld_c_inner_vw_cycle + end subroutine mld_c_inner_k_cycle - recursive subroutine mld_c_inner_k_cycle(p, mlprec_wrk, level, trans, work,u) + + recursive subroutine mld_cinneritkcycle(p, mlprec_wrk, level, trans, work, innersolv) use psb_base_mod use mld_prec_mod + use mld_c_inner_mod, mld_protect_name => mld_cmlprec_aply implicit none !Input/Oputput variables type(mld_cprec_type), intent(inout) :: p - type(mld_mlprec_wrk_type), target, intent(inout) :: mlprec_wrk(:) + + type(mld_mlprec_wrk_type), intent(inout) :: mlprec_wrk(:) integer(psb_ipk_), intent(in) :: level - character, intent(in) :: trans + character, intent(in) :: trans, innersolv complex(psb_spk_),target :: work(:) - type(psb_c_vect_type),intent(inout), optional :: u + !Other variables + type(psb_c_vect_type) :: v, w, rhs, v1, x + type(psb_c_vect_type), dimension(0:1) :: d + complex(psb_spk_) :: delta_old, rhs_norm, alpha, tau, tau1, tau2, tau3, tau4, beta + real(psb_spk_) :: l2_norm, delta, rtol=0.25 + complex(psb_spk_), allocatable :: temp_v(:) + integer(psb_ipk_) :: info, nlev, i, iter, max_iter=2, idx - type(psb_c_vect_type) :: res - type(psb_c_vect_type), pointer :: current - integer(psb_ipk_) :: sweeps_post, sweeps_pre - ! Local variables - integer(psb_ipk_) :: ictxt,np,me - integer(psb_ipk_) :: i, nr2l,nc2l,err_act - integer(psb_ipk_) :: debug_level, debug_unit - integer(psb_ipk_) :: nlev, ilev, sweeps - logical :: pre, post - character(len=20) :: name + !Assemble rhs, w, v, v1, x + call psb_geasb(rhs,& + & p%precv(level)%base_desc,info,& + & scratch=.true.,mold=mlprec_wrk(level)%vx2l%v) + call psb_geasb(w,& + & p%precv(level)%base_desc,info,& + & scratch=.true.,mold=mlprec_wrk(level)%vx2l%v) + call psb_geasb(v,& + & p%precv(level)%base_desc,info,& + & scratch=.true.,mold=mlprec_wrk(level)%vx2l%v) + call psb_geasb(v1,& + & p%precv(level)%base_desc,info,& + & scratch=.true.,mold=mlprec_wrk(level)%vx2l%v) + call psb_geasb(x,& + & p%precv(level)%base_desc,info,& + & scratch=.true.,mold=mlprec_wrk(level)%vx2l%v) + call x%zero() - name = 'inner_inner_add' - info = psb_success_ - call psb_erractionsave(err_act) - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - nlev = size(p%precv) - if ((level < 1) .or. (level > nlev)) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='wrong call level to inner_add') - goto 9999 - end if - ictxt = p%precv(level)%base_desc%get_context() - call psb_info(ictxt, me, np) + ! rhs=vx2l and w=rhs + call psb_geaxpby(cone,mlprec_wrk(level)%vx2l,czero,rhs,& + & p%precv(level)%base_desc,info) + call psb_geaxpby(cone,mlprec_wrk(level)%vx2l,czero,w,& + & p%precv(level)%base_desc,info) - 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_add at level ',level + if (psb_errstatus_fatal()) then + nc2l = p%precv(level)%base_desc%get_local_cols() + info=psb_err_alloc_request_ + call psb_errpush(info,name,i_err=(/2*nc2l,izero,izero,izero,izero/),& + & a_err='TYPE@(psb_spk_)') + goto 9999 end if - if ((level<1).or.(level>nlev)) then - info = psb_err_internal_error_ - call psb_errpush(info,name,& - & a_err='Invalid LEVEL>NLEV') - goto 9999 - end if + delta = psb_gedot(w, w, p%precv(level)%base_desc, info) - !K cycle + !Apply the preconditioner - call psb_geaxpby(cone,mlprec_wrk(level)%vx2l,& - & czero,mlprec_wrk(level)%vtx,& - & p%precv(level)%base_desc,info) - ! - ! Apply the base preconditioner - ! - if (level < nlev) then + call mlprec_wrk(level)%vy2l%set(czero) - if (present(u)) then - call psb_geaxpby(cone,u,& - & czero,mlprec_wrk(level)%vy2l,& - & p%precv(level)%base_desc,info) - else - call mlprec_wrk(level)%vy2l%zero() - endif - res = mlprec_wrk(level)%vx2l + idx=0 + call inner_ml_aply(level,p,mlprec_wrk,trans,work,info) - call psb_spmm(-cone,p%precv(level)%base_a,mlprec_wrk(level)%vy2l,& - cone, res, p%precv(level)%base_desc, info, work=work, trans=trans) + !Assemble d(0) and d(1) + call psb_geasb(d(0),& + & p%precv(level)%base_desc,info,& + & scratch=.true.,mold=mlprec_wrk(level)%vy2l%v) + call psb_geasb(d(1),& + & p%precv(level)%base_desc,info,& + & scratch=.true.,mold=mlprec_wrk(level)%vy2l%v) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during residue') - goto 9999 - end if + call psb_geaxpby(cone,mlprec_wrk(level)%vy2l,czero,d(idx),p%precv(level)%base_desc,info) - 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 + call psb_spmm(cone,p%precv(level)%base_a,d(idx),czero,v,p%precv(level)%base_desc,info) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& - & 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 - ! - if(level < nlev) then - - call psb_geaxpby(cone,mlprec_wrk(level)%vx2l,& - & czero,mlprec_wrk(level)%vty,& - & p%precv(level)%base_desc,info) - - if (info == psb_success_) call psb_spmm(-cone,p%precv(level)%base_a,& - & mlprec_wrk(level)%vy2l,cone,mlprec_wrk(level)%vty,& - & p%precv(level)%base_desc,info,work=work,trans=trans) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during residue') - goto 9999 - end if - - ! Apply the restriction - call psb_map_X2Y(cone,mlprec_wrk(level)%vty,& - & czero,mlprec_wrk(level + 1)%vx2l,& - & 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 restriction') - goto 9999 - end if - - !Set the preconditioner - - - if ((level < nlev - 2)) then - if (p%precv(level)%parms%ml_type == mld_kcyclesym_ml_) then - call mld_cinneritkcycle(p, mlprec_wrk, level + 1, trans, work, 'FCG') - elseif (p%precv(level)%parms%ml_type == mld_kcycle_ml_) then - call mld_cinneritkcycle(p, mlprec_wrk, level + 1, trans, work, 'CGR') - endif - else - call inner_ml_aply(level + 1 ,p,mlprec_wrk,trans,work,info) - endif - - - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error in recursive call') - goto 9999 - end if - - - ! - ! Apply the prolongator - ! - call psb_map_Y2X(cone,mlprec_wrk(level+1)%vy2l,& - & cone,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 - ! - call psb_spmm(-cone,p%precv(level)%base_a,mlprec_wrk(level)%vy2l,& - & cone,mlprec_wrk(level)%vtx,p%precv(level)%base_desc,info,& - & work=work,trans=trans) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during residue') - goto 9999 - end if - ! - ! Apply the base preconditioner - ! - 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_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during 2-POST smoother_apply') - goto 9999 - end if - - endif - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - return - - end subroutine mld_c_inner_k_cycle - - - recursive subroutine mld_cinneritkcycle(p, mlprec_wrk, level, trans, work, innersolv) - use psb_base_mod - use mld_prec_mod - use mld_c_inner_mod, mld_protect_name => mld_cmlprec_aply - - implicit none - - !Input/Oputput variables - type(mld_cprec_type), intent(inout) :: p - - type(mld_mlprec_wrk_type), intent(inout) :: mlprec_wrk(:) - integer(psb_ipk_), intent(in) :: level - character, intent(in) :: trans, innersolv - complex(psb_spk_),target :: work(:) - - !Other variables - type(psb_c_vect_type) :: v, w, rhs, v1, x - type(psb_c_vect_type), dimension(0:1) :: d - complex(psb_spk_) :: delta_old, rhs_norm, alpha, tau, tau1, tau2, tau3, tau4, beta - - real(psb_spk_) :: l2_norm, delta, rtol=0.25 - complex(psb_spk_), allocatable :: temp_v(:) - integer(psb_ipk_) :: info, nlev, i, iter, max_iter=2, idx - - !Assemble rhs, w, v, v1, x - - call psb_geasb(rhs,& - & p%precv(level)%base_desc,info,& - & scratch=.true.,mold=mlprec_wrk(level)%vx2l%v) - call psb_geasb(w,& - & p%precv(level)%base_desc,info,& - & scratch=.true.,mold=mlprec_wrk(level)%vx2l%v) - call psb_geasb(v,& - & p%precv(level)%base_desc,info,& - & scratch=.true.,mold=mlprec_wrk(level)%vx2l%v) - call psb_geasb(v1,& - & p%precv(level)%base_desc,info,& - & scratch=.true.,mold=mlprec_wrk(level)%vx2l%v) - call psb_geasb(x,& - & p%precv(level)%base_desc,info,& - & scratch=.true.,mold=mlprec_wrk(level)%vx2l%v) - - call x%set(czero) - - ! rhs=vx2l and w=rhs - call psb_geaxpby(cone,mlprec_wrk(level)%vx2l,czero,rhs,& - & p%precv(level)%base_desc,info) - call psb_geaxpby(cone,mlprec_wrk(level)%vx2l,czero,w,& - & p%precv(level)%base_desc,info) - - if (psb_errstatus_fatal()) then - nc2l = p%precv(level)%base_desc%get_local_cols() - info=psb_err_alloc_request_ - call psb_errpush(info,name,i_err=(/2*nc2l,izero,izero,izero,izero/),& - & a_err='TYPE@(psb_spk_)') - goto 9999 - end if - - delta = psb_gedot(w, w, p%precv(level)%base_desc, info) - - !Apply the preconditioner - - call mlprec_wrk(level)%vy2l%set(czero) - - idx=0 - call inner_ml_aply(level,p,mlprec_wrk,trans,work,info) - - !Assemble d(0) and d(1) - call psb_geasb(d(0),& - & p%precv(level)%base_desc,info,& - & scratch=.true.,mold=mlprec_wrk(level)%vy2l%v) - call psb_geasb(d(1),& - & p%precv(level)%base_desc,info,& - & scratch=.true.,mold=mlprec_wrk(level)%vy2l%v) - - call psb_geaxpby(cone,mlprec_wrk(level)%vy2l,czero,d(idx),p%precv(level)%base_desc,info) - - - call psb_spmm(cone,p%precv(level)%base_a,d(idx),czero,v,p%precv(level)%base_desc,info) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during residue') + & a_err='Error during residue') goto 9999 end if @@ -2162,3 +1233,565 @@ contains end subroutine mld_cmlprec_aply_vect + + + + +! +! Old routine for arrays instead of psb_X_vector. To be deleted eventually. +! +! +subroutine mld_cmlprec_aply(alpha,p,x,beta,y,desc_data,trans,work,info) + + use psb_base_mod + use mld_c_inner_mod, mld_protect_name => mld_cmlprec_aply + + implicit none + + ! Arguments + type(psb_desc_type),intent(in) :: desc_data + type(mld_cprec_type), intent(inout) :: p + complex(psb_spk_),intent(in) :: alpha,beta + complex(psb_spk_),intent(inout) :: x(:) + complex(psb_spk_),intent(inout) :: y(:) + character, intent(in) :: trans + complex(psb_spk_),target :: work(:) + integer(psb_ipk_), intent(out) :: info + + ! Local variables + integer(psb_ipk_) :: ictxt, np, me + integer(psb_ipk_) :: err_act + integer(psb_ipk_) :: debug_level, debug_unit, nlev,nc2l,nr2l,level + character(len=20) :: name + character :: trans_ + type mld_mlprec_wrk_type + complex(psb_spk_), allocatable :: tx(:), ty(:), x2l(:), y2l(:) + end type mld_mlprec_wrk_type + type(mld_mlprec_wrk_type), allocatable, target :: mlprec_wrk(:) + + name='mld_cmlprec_aply' + info = psb_success_ + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + ictxt = desc_data%get_context() + call psb_info(ictxt, me, np) + + if (debug_level >= psb_debug_inner_) & + & write(debug_unit,*) me,' ',trim(name),& + & ' Entry ', size(p%precv) + + trans_ = psb_toupper(trans) + + nlev = size(p%precv) + allocate(mlprec_wrk(nlev),stat=info) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') + goto 9999 + end if + level = 1 + + do level = 1, nlev + call psb_geasb(mlprec_wrk(level)%x2l,& + & p%precv(level)%base_desc,info) + call psb_geasb(mlprec_wrk(level)%y2l,& + & p%precv(level)%base_desc,info) + call psb_geasb(mlprec_wrk(level)%tx,& + & p%precv(level)%base_desc,info) + call psb_geasb(mlprec_wrk(level)%ty,& + & p%precv(level)%base_desc,info) + if (psb_errstatus_fatal()) then + nc2l = p%precv(level)%base_desc%get_local_cols() + info=psb_err_alloc_request_ + call psb_errpush(info,name,i_err=(/2*nc2l,izero,izero,izero,izero/),& + & a_err='complex(psb_spk_)') + goto 9999 + end if + end do + + mlprec_wrk(level)%x2l(:) = x(:) + mlprec_wrk(level)%y2l(:) = czero + + call inner_ml_aply(level,p,mlprec_wrk,trans_,work,info) + + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Inner prec aply') + goto 9999 + end if + + call psb_geaxpby(alpha,mlprec_wrk(level)%y2l,beta,y,& + & p%precv(level)%base_desc,info) + + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Error final update') + goto 9999 + end if + + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +contains + + ! + ! + ! inner_ml_aply: apply AMG at a given level. + ! This routine dispatches the computation according to the type + ! specified at the current level. + ! Each of the corrections will inturn call recursively this routine. + ! + ! Assumptions: + ! On input: + ! mlprec_wkr(level)%vx2l contains the input vector (RHS) + ! mlprec_wkr(level)%vy2l contains the initial guess + ! + ! On output: + ! mlprec_wkr(level)%vy2l contains the solution + ! + ! Constraints: each of the called routines must properly handle + ! the input/output conditions for level+1 (i.e. apply + ! prolongation/restriction). + ! Note: for historical/convenience reasons the prolongator/restrictor + ! between level and level+1 are stored at level+1. + ! + ! + recursive subroutine inner_ml_aply(level,p,mlprec_wrk,trans,work,info) + + implicit none + + ! Arguments + integer(psb_ipk_) :: level + type(mld_cprec_type), target, intent(inout) :: p + type(mld_mlprec_wrk_type), intent(inout), target :: mlprec_wrk(:) + character, intent(in) :: trans + complex(psb_spk_),target :: work(:) + integer(psb_ipk_), intent(out) :: info + + type(psb_c_vect_type) :: res + type(psb_c_vect_type), pointer :: current + integer(psb_ipk_) :: sweeps_post, sweeps_pre + ! Local variables + integer(psb_ipk_) :: ictxt,np,me + integer(psb_ipk_) :: i, err_act + integer(psb_ipk_) :: debug_level, debug_unit + integer(psb_ipk_) :: nlev, ilev, sweeps + logical :: pre, post + character(len=20) :: name + + + + name = 'inner_ml_aply' + info = psb_success_ + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + nlev = size(p%precv) + if ((level < 1) .or. (level > nlev)) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='wrong call level to inner_ml') + goto 9999 + end if + ictxt = p%precv(level)%base_desc%get_context() + call psb_info(ictxt, me, np) + + if(debug_level > 1) then + write(debug_unit,*) me,' inner_ml_aply at level ',level + end if + + select case(p%precv(level)%parms%ml_type) + + case(mld_no_ml_) + ! + ! No preconditioning, should not really get here + ! + call psb_errpush(psb_err_internal_error_,name,& + & a_err='mld_no_ml_ in mlprc_aply?') + goto 9999 + + case(mld_add_ml_) + + call mld_c_inner_add(p, mlprec_wrk, level, trans, work) + + + case(mld_mult_ml_) + ! + ! Multiplicative multilevel (multiplicative among the levels, additive inside + ! each level) + ! + ! Pre/post-smoothing versions. + ! Note that the transpose switches pre <-> post. + ! + select case(p%precv(level)%parms%smoother_pos) + + case(mld_post_smooth_) + p%precv(level)%parms%sweeps_pre = 0 + call mld_c_inner_mult(p, mlprec_wrk, level, trans, work) + + + case(mld_pre_smooth_) + p%precv(level)%parms%sweeps_post = 0 + call mld_c_inner_mult(p, mlprec_wrk, level, trans, work) + + case(mld_twoside_smooth_) + call mld_c_inner_mult(p, mlprec_wrk, level, trans, work) + + case default + info = psb_err_from_subroutine_ai_ + call psb_errpush(info,name,a_err='invalid smooth_pos',& + & i_Err=(/p%precv(level)%parms%smoother_pos,izero,izero,izero,izero/)) + goto 9999 + + end select + + + case(mld_vcycle_ml_, mld_wcycle_ml_) + + call mld_c_inner_mult(p, mlprec_wrk, level, trans, work) + +! !$ case(mld_kcycle_ml_, mld_kcyclesym_ml_) +! !$ +! !$ call mld_c_inner_k_cycle(p, mlprec_wrk, level, trans, work) + + case default + info = psb_err_from_subroutine_ai_ + call psb_errpush(info,name,a_err='invalid mltype',& + & i_Err=(/p%precv(level)%parms%ml_type,izero,izero,izero,izero/)) + goto 9999 + + end select + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + return + + end subroutine inner_ml_aply + + + recursive subroutine mld_c_inner_add(p, mlprec_wrk, level, trans, work) + use psb_base_mod + use mld_prec_mod + + implicit none + + !Input/Oputput variables + type(mld_cprec_type), intent(inout) :: p + + type(mld_mlprec_wrk_type), target, intent(inout) :: mlprec_wrk(:) + integer(psb_ipk_), intent(in) :: level + character, intent(in) :: trans + complex(psb_spk_),target :: work(:) + type(psb_c_vect_type) :: res + type(psb_c_vect_type), pointer :: current + integer(psb_ipk_) :: sweeps_post, sweeps_pre + ! Local variables + integer(psb_ipk_) :: ictxt,np,me + integer(psb_ipk_) :: i, err_act + integer(psb_ipk_) :: debug_level, debug_unit + integer(psb_ipk_) :: nlev, ilev, sweeps + logical :: pre, post + character(len=20) :: name + + + + name = 'inner_inner_add' + info = psb_success_ + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + nlev = size(p%precv) + if ((level < 1) .or. (level > nlev)) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='wrong call level to inner_add') + goto 9999 + end if + ictxt = p%precv(level)%base_desc%get_context() + call psb_info(ictxt, me, np) + + if(debug_level > 1) then + write(debug_unit,*) me,' inner_add at level ',level + end if + + if ((level<1).or.(level>nlev)) then + info = psb_err_internal_error_ + call psb_errpush(info,name,& + & a_err='Invalid LEVEL>NLEV') + goto 9999 + end if + + sweeps = p%precv(level)%parms%sweeps + 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,& + & a_err='Error during ADD smoother_apply') + goto 9999 + end if + + if (level < nlev) then + ! Apply the restriction + call psb_map_X2Y(cone,mlprec_wrk(level)%x2l,& + & czero,mlprec_wrk(level+1)%x2l,& + & p%precv(level+1)%map,info,work=work) + mlprec_wrk(level+1)%y2l(:) = czero + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Error during restriction') + goto 9999 + end if + + call inner_ml_aply(level+1,p,mlprec_wrk,trans,work,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Error in recursive call') + goto 9999 + end if + + ! + ! Apply the prolongator + ! + call psb_map_Y2X(cone,mlprec_wrk(level+1)%y2l,& + & cone,mlprec_wrk(level)%y2l,& + & 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 + + + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + return + + end subroutine mld_c_inner_add + + recursive subroutine mld_c_inner_mult(p, mlprec_wrk, level, trans, work) + use psb_base_mod + use mld_prec_mod + + implicit none + + !Input/Oputput variables + type(mld_cprec_type), intent(inout) :: p + + type(mld_mlprec_wrk_type), target, intent(inout) :: mlprec_wrk(:) + integer(psb_ipk_), intent(in) :: level + character, intent(in) :: trans + complex(psb_spk_),target :: work(:) + type(psb_c_vect_type) :: res + type(psb_c_vect_type), pointer :: current + integer(psb_ipk_) :: sweeps_post, sweeps_pre + ! Local variables + integer(psb_ipk_) :: ictxt,np,me + integer(psb_ipk_) :: i, err_act + integer(psb_ipk_) :: debug_level, debug_unit + integer(psb_ipk_) :: nlev, ilev, sweeps + logical :: pre, post + character(len=20) :: name + + + + name = 'inner_inner_mult' + info = psb_success_ + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + nlev = size(p%precv) + if ((level < 1) .or. (level > nlev)) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='wrong call level to inner_mult') + goto 9999 + end if + ictxt = p%precv(level)%base_desc%get_context() + call psb_info(ictxt, me, np) + + if(debug_level > 1) then + write(debug_unit,*) me,' inner_mult at level ',level + end if + + if ((level < nlev).or.(nlev == 1)) then + sweeps_post = p%precv(level)%parms%sweeps_post + sweeps_pre = p%precv(level)%parms%sweeps_pre + else + sweeps_post = p%precv(level-1)%parms%sweeps_post + sweeps_pre = p%precv(level-1)%parms%sweeps_pre + endif + + pre = ((sweeps_pre>0).and.(trans=='N')).or.((sweeps_post>0).and.(trans/='N')) + post = ((sweeps_post>0).and.(trans=='N')).or.((sweeps_pre>0).and.(trans/='N')) + + + if (level < nlev) then + + ! + ! Apply the first smoother + ! + + if (pre) then + if (trans == 'N') then + sweeps = p%precv(level)%parms%sweeps_pre + if (info == psb_success_) call p%precv(level)%sm%apply(cone,& + & mlprec_wrk(level)%x2l,czero,mlprec_wrk(level)%y2l,& + & p%precv(level)%base_desc, trans,& + & sweeps,work,info,init='Y') + else + sweeps = p%precv(level)%parms%sweeps_post + if (info == psb_success_) call p%precv(level)%sm2%apply(cone,& + & mlprec_wrk(level)%x2l,czero,mlprec_wrk(level)%y2l,& + & p%precv(level)%base_desc, trans,& + & sweeps,work,info,init='Y') + end if + + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Error during PRE smoother_apply') + goto 9999 + end if + endif + + ! + ! Compute the residual and call recursively + ! + if (pre) then + call psb_geaxpby(cone,mlprec_wrk(level)%x2l,& + & czero,mlprec_wrk(level)%ty,& + & p%precv(level)%base_desc,info) + + if (info == psb_success_) call psb_spmm(-cone,p%precv(level)%base_a,& + & mlprec_wrk(level)%y2l,cone,mlprec_wrk(level)%ty,& + & p%precv(level)%base_desc,info,work=work,trans=trans) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Error during residue') + goto 9999 + end if + call psb_map_X2Y(cone,mlprec_wrk(level)%ty,& + & czero,mlprec_wrk(level+1)%x2l,& + & 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 restriction') + goto 9999 + end if + else + ! Shortcut: just transfer x2l. + call psb_map_X2Y(cone,mlprec_wrk(level)%x2l,& + & czero,mlprec_wrk(level+1)%x2l,& + & 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 restriction') + goto 9999 + end if + endif + ! First guess is zero + mlprec_wrk(level+1)%y2l(:) = czero + + + call inner_ml_aply(level+1,p,mlprec_wrk,trans,work,info) + + if (p%precv(level)%parms%ml_type == mld_wcycle_ml_) then + ! On second call will use output y2l as initial guess + if (info == psb_success_) call inner_ml_aply(level+1,p,mlprec_wrk,trans,work,info) + endif + + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Error in recursive call') + goto 9999 + end if + + + ! + ! Apply the prolongator + ! + call psb_map_Y2X(cone,mlprec_wrk(level+1)%y2l,& + & cone,mlprec_wrk(level)%y2l,& + & 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 + ! + if (post) then + call psb_geaxpby(cone,mlprec_wrk(level)%x2l,& + & czero,mlprec_wrk(level)%tx,& + & p%precv(level)%base_desc,info) + call psb_spmm(-cone,p%precv(level)%base_a,mlprec_wrk(level)%y2l,& + & cone,mlprec_wrk(level)%tx,p%precv(level)%base_desc,info,& + & work=work,trans=trans) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Error during residue') + goto 9999 + end if + ! + ! Apply the second smoother + ! + if (trans == 'N') then + sweeps = p%precv(level)%parms%sweeps_post + if (info == psb_success_) call p%precv(level)%sm2%apply(cone,& + & mlprec_wrk(level)%tx,cone,mlprec_wrk(level)%y2l,& + & p%precv(level)%base_desc, trans,& + & sweeps,work,info,init='Y') + else + sweeps = p%precv(level)%parms%sweeps_pre + 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,init='Y') + end if + + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Error during POST smoother_apply') + goto 9999 + end if + + endif + + else if (level == nlev) then + + sweeps = p%precv(level)%parms%sweeps + 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 + + info = psb_err_internal_error_ + call psb_errpush(info,name,& + & a_err='Invalid LEVEL vs NLEV') + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + return + + end subroutine mld_c_inner_mult + + +end subroutine mld_cmlprec_aply diff --git a/mlprec/impl/mld_dmlprec_aply.f90 b/mlprec/impl/mld_dmlprec_aply.f90 index 2afb6a53..68283ef7 100644 --- a/mlprec/impl/mld_dmlprec_aply.f90 +++ b/mlprec/impl/mld_dmlprec_aply.f90 @@ -183,10 +183,8 @@ ! ilev-1, while PT(ilev) denotes its transpose, i.e. the corresponding ! restriction operator from level ilev-1 to level ilev). ! -! 0. Transfer the outer vector Xest to x(1) (inner X at level 1) +! 1. Transfer the outer vector Xest to x(1) (inner X at level 1) ! -! 1. If ilev > 1 Transfer x(ilev-1) to the current level: -! x(ilev) = PT(ilev)*x(ilev-1) ! ! 2. Apply the base preconditioner at the current level: ! ! The sum over the subdomains is carried out in the @@ -194,8 +192,10 @@ ! y(ilev) = (K(ilev)^(-1))*x(ilev) ! ! 3. If ilev < nlevel -! a. Call recursively itself -! b. Transfer y(ilev+1) to the current level: +! a. Transfer x(ilev) to the next level: +! x(ilev+1) = PT(ilev+1)*x(ilev) +! b. Call recursively itself +! c. Transfer y(ilev+1) to the current level: ! y(ilev) = y(ilev) + P(ilev+1)*y(ilev+1) ! ! 4. if ilev == 1 Transfer the inner y to the external: @@ -215,11 +215,8 @@ ! differential equations, Cambridge University Press, 1996. ! ! -! 0. Transfer the outer vector Xest to x(1) (inner X at level 1) +! 1 Transfer the outer vector Xest to x(1) (inner X at level 1) ! -! 1. If ilev >1 Transfer x(ilev-1) to the current level: -! x(ilev) = PT(ilev)*x(ilev-1) -! ! 2. Apply the base preconditioner at the current level: ! ! The sum over the subdomains is carried out in the ! ! application of K(ilev). @@ -228,11 +225,10 @@ ! 3. If ilev < nlevel ! a. Compute the residual: ! r(ilev) = x(ilev) - A(ilev)*y(ilev) -! b. Call recursively itself passing -! r(ilev) for transfer to the next level -! (r(ilev) matches x(ilev-1) in step 1) -! -! c. Transfer y(ilev+1) to the current level: +! b. Transfer r(ilev) to the next level: +! x(ilev+1) = PT(ilev+1)*r(ilev) +! c. Call recursively +! d. Transfer y(ilev+1) to the current level: ! y(ilev) = y(ilev) + P(ilev+1)*y(ilev+1) ! ! 4. if ilev == 1 Transfer the inner y to the external: @@ -242,28 +238,23 @@ ! ! Hybrid multiplicative, post-smoothing variant ! -! 0. Transfer the outer vector Xest to x(1) (inner X at level 1) +! 1. Transfer the outer vector Xest to x(1) (inner X at level 1) ! -! 1. If ilev > 1 Transfer x(ilev-1) to the current level: -! x(ilev) = PT(ilev)*x(ilev-1) -! ! 2. If ilev < nlev -! a. Call recursively itself passing -! x(ilev) for transfer to the next level -! b. Transfer y(ilev+1) to the current level: +! a. Transfer x(ilev) to the next level: +! x(ilev+1) = PT(ilev+1)*x(ilev) +! b. Call recursively +! c. Transfer y(ilev+1) to the current level: ! y(ilev) = P(ilev+1)*y(ilev+1) -! c. Compute the residual: +! d. Compute the residual: ! x(ilev) = x(ilev) - A(ilev)*y(ilev) -! d. Apply the base preconditioner to the residual at the current level: +! e. Apply the base preconditioner to the residual at the current level: ! ! The sum over the subdomains is carried out in the ! ! application of K(ilev) ! y(ilev) = y(ilev) + (K(ilev)^(-1))*x(ilev) -! Else -! Apply the base preconditioner to the residual at the current level: -! ! The sum over the subdomains is carried out in the -! ! application of K(ilev) -! y(ilev) = (K(ilev)^(-1))*x(ilev) -! +! +! 3. If ilev == nlev apply y(ilev) = (K(ilev)^(-1))*x(ilev) +! ! 4. if ilev == 1 Transfer the inner Y to the external: ! Yext = beta*Yext + alpha*Y(1) ! @@ -278,11 +269,8 @@ ! differential equations, Cambridge University Press, 1996. ! ! -! 0. Transfer the outer vector Xest to x(1) (inner X at level 1) +! 1. Transfer the outer vector Xest to x(1) (inner X at level 1) ! -! 1. If ilev > 1 Transfer x(ilev-1) to the current level: -! x(ilev) = PT(ilev)*x(ilev-1) -! ! 2. Apply the base preconditioner at the current level: ! ! The sum over the subdomains is carried out in the ! ! application of K(ilev) @@ -291,10 +279,10 @@ ! 3. If ilev < nlevel ! a. Compute the residual: ! r(ilev) = x(ilev) - A(ilev)*y(ilev) -! b. Call recursively itself passing -! r(ilev) for transfer to the next level -! (r(ilev) matches x(ilev-1) in step 1) -! c. Transfer y(ilev+1) to the current level: +! b. Transfer r(ilev) to the next level: +! x(ilev+1) = PT(ilev+1)*r(ilev) +! c. Call recursively +! d. Transfer y(ilev+1) to the current level: ! y(ilev) = y(ilev) + P(ilev+1)*y(ilev+1) ! d. Compute the residual: ! r(ilev) = x(ilev) - A(ilev)*y(ilev) @@ -303,35 +291,36 @@ ! ! application of K(ilev) ! y(ilev) = y(ilev) + (K(ilev)^(-1))*r(ilev) ! -! 5. if ilev == 1 Transfer the inner Y to the external: +! 4. if ilev == 1 Transfer the inner Y to the external: ! Yext = beta*Yext + alpha*Y(1) ! ! -subroutine mld_dmlprec_aply(alpha,p,x,beta,y,desc_data,trans,work,info) +subroutine mld_dmlprec_aply_vect(alpha,p,x,beta,y,desc_data,trans,work,info) use psb_base_mod - use mld_d_inner_mod, mld_protect_name => mld_dmlprec_aply + use mld_d_inner_mod, mld_protect_name => mld_dmlprec_aply_vect implicit none ! Arguments - type(psb_desc_type),intent(in) :: desc_data - type(mld_dprec_type), intent(inout) :: p - real(psb_dpk_),intent(in) :: alpha,beta - real(psb_dpk_),intent(inout) :: x(:) - real(psb_dpk_),intent(inout) :: y(:) - character, intent(in) :: trans - real(psb_dpk_),target :: work(:) - integer(psb_ipk_), intent(out) :: info + type(psb_desc_type),intent(in) :: desc_data + type(mld_dprec_type), intent(inout) :: p + real(psb_dpk_),intent(in) :: alpha,beta + type(psb_d_vect_type),intent(inout) :: x + type(psb_d_vect_type),intent(inout) :: y + character, intent(in) :: trans + real(psb_dpk_),target :: work(:) + integer(psb_ipk_), intent(out) :: info ! Local variables integer(psb_ipk_) :: ictxt, np, me - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: debug_level, debug_unit, nlev,nc2l,nr2l,level + integer(psb_ipk_) :: debug_level, debug_unit, nlev,nc2l,nr2l,level, err_act character(len=20) :: name character :: trans_ + real(psb_dpk_) :: par type mld_mlprec_wrk_type real(psb_dpk_), allocatable :: tx(:), ty(:), x2l(:), y2l(:) + type(psb_d_vect_type) :: vtx, vty, vx2l, vy2l end type mld_mlprec_wrk_type type(mld_mlprec_wrk_type), allocatable, target :: mlprec_wrk(:) @@ -349,7 +338,6 @@ subroutine mld_dmlprec_aply(alpha,p,x,beta,y,desc_data,trans,work,info) & ' Entry ', size(p%precv) trans_ = psb_toupper(trans) - nlev = size(p%precv) allocate(mlprec_wrk(nlev),stat=info) if (info /= psb_success_) then @@ -357,21 +345,32 @@ subroutine mld_dmlprec_aply(alpha,p,x,beta,y,desc_data,trans,work,info) goto 9999 end if level = 1 + do level = 1, nlev + call psb_geasb(mlprec_wrk(level)%vx2l,& + & p%precv(level)%base_desc,info,& + & scratch=.true.,mold=x%v) + call psb_geasb(mlprec_wrk(level)%vy2l,& + & p%precv(level)%base_desc,info,& + & scratch=.true.,mold=x%v) + call psb_geasb(mlprec_wrk(level)%vtx,& + & p%precv(level)%base_desc,info,& + & scratch=.true.,mold=x%v) + call psb_geasb(mlprec_wrk(level)%vty,& + & p%precv(level)%base_desc,info,& + & scratch=.true.,mold=x%v) + if (psb_errstatus_fatal()) then + nc2l = p%precv(level)%base_desc%get_local_cols() + info=psb_err_alloc_request_ + call psb_errpush(info,name,i_err=(/2*nc2l,izero,izero,izero,izero/),& + & a_err='real(psb_dpk_)') + goto 9999 + end if + end do + level = 1 - nc2l = p%precv(level)%base_desc%get_local_cols() - nr2l = p%precv(level)%base_desc%get_local_rows() - allocate(mlprec_wrk(level)%x2l(nc2l),mlprec_wrk(level)%y2l(nc2l),& - & stat=info) - if (info /= psb_success_) then - info=psb_err_alloc_request_ - call psb_errpush(info,name,& - & i_err=(/ione*(size(x)+size(y)),izero,izero,izero,izero/),& - & a_err='real(psb_dpk_)') - goto 9999 - end if + call psb_geaxpby(done,x,dzero,mlprec_wrk(level)%vx2l,p%precv(level)%base_desc,info) + call mlprec_wrk(level)%vy2l%zero() - mlprec_wrk(level)%x2l(:) = x(:) - mlprec_wrk(level)%y2l(:) = dzero call inner_ml_aply(level,p,mlprec_wrk,trans_,work,info) @@ -381,8 +380,22 @@ subroutine mld_dmlprec_aply(alpha,p,x,beta,y,desc_data,trans,work,info) goto 9999 end if - call psb_geaxpby(alpha,mlprec_wrk(level)%y2l,beta,y,& + call psb_geaxpby(alpha,mlprec_wrk(level)%vy2l,beta,y,& & p%precv(level)%base_desc,info) + do level = 1, nlev + + call mlprec_wrk(level)%vx2l%free(info) + call mlprec_wrk(level)%vy2l%free(info) + call mlprec_wrk(level)%vtx%free(info) + call mlprec_wrk(level)%vty%free(info) + if (psb_errstatus_fatal()) then + info=psb_err_alloc_request_ + nc2l = p%precv(level)%base_desc%get_local_cols() + call psb_errpush(info,name,i_err=(/2*nc2l,izero,izero,izero,izero/),& + & a_err='real(psb_dpk_)') + goto 9999 + end if + end do if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& @@ -399,7 +412,28 @@ subroutine mld_dmlprec_aply(alpha,p,x,beta,y,desc_data,trans,work,info) return contains - + ! + ! + ! inner_ml_aply: apply AMG at a given level. + ! This routine dispatches the computation according to the type + ! specified at the current level. + ! Each of the corrections will inturn call recursively this routine. + ! + ! Assumptions: + ! On input: + ! mlprec_wkr(level)%vx2l contains the input vector (RHS) + ! mlprec_wkr(level)%vy2l contains the initial guess + ! + ! On output: + ! mlprec_wkr(level)%vy2l contains the solution + ! + ! Constraints: each of the called routines must properly handle + ! the input/output conditions for level+1 (i.e. apply + ! prolongation/restriction). + ! Note: for historical/convenience reasons the prolongator/restrictor + ! between level and level+1 are stored at level+1. + ! + ! recursive subroutine inner_ml_aply(level,p,mlprec_wrk,trans,work,info) implicit none @@ -407,24 +441,29 @@ contains ! Arguments integer(psb_ipk_) :: level type(mld_dprec_type), target, intent(inout) :: p - type(mld_mlprec_wrk_type), intent(inout) :: mlprec_wrk(:) + type(mld_mlprec_wrk_type), intent(inout), target :: mlprec_wrk(:) character, intent(in) :: trans - real(psb_dpk_),target :: work(:) - integer(psb_ipk_), intent(out) :: info + real(psb_dpk_),target :: work(:) + integer(psb_ipk_), intent(out) :: info + type(psb_d_vect_type) :: res + type(psb_d_vect_type), pointer :: current + integer(psb_ipk_) :: sweeps_post, sweeps_pre ! Local variables integer(psb_ipk_) :: ictxt,np,me - integer(psb_ipk_) :: i, nr2l,nc2l,err_act + integer(psb_ipk_) :: i, err_act integer(psb_ipk_) :: debug_level, debug_unit integer(psb_ipk_) :: nlev, ilev, sweeps + logical :: pre, post character(len=20) :: name + + name = 'inner_ml_aply' info = psb_success_ call psb_erractionsave(err_act) debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() - nlev = size(p%precv) if ((level < 1) .or. (level > nlev)) then call psb_errpush(psb_err_internal_error_,name,& @@ -434,18 +473,8 @@ 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() - allocate(mlprec_wrk(level)%x2l(nc2l),& - & mlprec_wrk(level)%y2l(nc2l),& - & stat=info) - if (info /= psb_success_) then - info=psb_err_alloc_request_ - call psb_errpush(info,name,i_err=(/2*nc2l,izero,izero,izero,izero/),& - & a_err='real(psb_dpk_)') - goto 9999 - end if + 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) @@ -459,56 +488,9 @@ contains goto 9999 case(mld_add_ml_) - ! - ! Additive multilevel - ! - - if (level > 1) then - ! Apply the restriction - call psb_map_X2Y(done,mlprec_wrk(level-1)%x2l,& - & dzero,mlprec_wrk(level)%x2l,& - & p%precv(level)%map,info,work=work) - - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during restriction') - goto 9999 - end if - - end if - - 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) - - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during smoother_apply') - goto 9999 - end if - if (level < nlev) then - call inner_ml_aply(level+1,p,mlprec_wrk,trans,work,info) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error in recursive call') - goto 9999 - end if - ! - ! Apply the prolongator - ! - call psb_map_Y2X(done,mlprec_wrk(level+1)%y2l,& - & done,mlprec_wrk(level)%y2l,& - & 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 + call mld_d_inner_add(p, mlprec_wrk, level, trans, work) - end if case(mld_mult_ml_) ! @@ -521,452 +503,16 @@ contains select case(p%precv(level)%parms%smoother_pos) case(mld_post_smooth_) - - select case (trans_) - case('N') - if (level > 1) then - ! Apply the restriction - call psb_map_X2Y(done,mlprec_wrk(level-1)%x2l,& - & dzero,mlprec_wrk(level)%x2l,& - & p%precv(level)%map,info,work=work) - - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during restriction') - goto 9999 - end if - 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 - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error in recursive call') - goto 9999 - end if - ! - ! Apply the prolongator - ! - call psb_map_Y2X(done,mlprec_wrk(level+1)%y2l,& - & dzero,mlprec_wrk(level)%y2l,& - & 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 - ! - call psb_spmm(-done,p%precv(level)%base_a,mlprec_wrk(level)%y2l,& - & done,mlprec_wrk(level)%x2l,p%precv(level)%base_desc,info,& - & work=work,trans=trans) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during residue') - goto 9999 - end if - - sweeps = p%precv(level)%parms%sweeps_post - 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) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during smoother_apply') - goto 9999 - end if - - 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) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during smoother_apply') - goto 9999 - end if - - end if - - case('T','C') - - ! Post-smoothing transpose is pre-smoothing - - - if (level > 1) then - ! Apply the restriction - call psb_map_X2Y(done,mlprec_wrk(level-1)%x2l,& - & dzero,mlprec_wrk(level)%x2l,& - & p%precv(level)%map,info,work=work) - - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during restriction') - goto 9999 - end if - - - end if - - ! - ! Apply the base preconditioner - ! - 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 - - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during smoother_apply') - goto 9999 - end if - - ! - ! Compute the residual (at all levels but the coarsest one) - ! - if (level < nlev) then - call psb_spmm(-done,p%precv(level)%base_a,& - & mlprec_wrk(level)%y2l,done,mlprec_wrk(level)%x2l,& - & p%precv(level)%base_desc,info,work=work,trans=trans) - - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during residue') - goto 9999 - end if - - call inner_ml_aply(level+1,p,mlprec_wrk,trans,work,info) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error in recursive call') - goto 9999 - end if - - - call psb_map_Y2X(done,mlprec_wrk(level+1)%y2l,& - & done,mlprec_wrk(level)%y2l,& - & 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 - - - end if - - case default - info = psb_err_internal_error_ - call psb_errpush(info,name,a_err='invalid trans') - goto 9999 - end select + p%precv(level)%parms%sweeps_pre = 0 + call mld_d_inner_mult(p, mlprec_wrk, level, trans, work) + case(mld_pre_smooth_) - - select case (trans_) - case('N') - ! One step of pre-smoothing - - - if (level > 1) then - ! Apply the restriction - call psb_map_X2Y(done,mlprec_wrk(level-1)%x2l,& - & dzero,mlprec_wrk(level)%x2l,& - & p%precv(level)%map,info,work=work) - - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during restriction') - goto 9999 - end if - - end if - - ! - ! Apply the base preconditioner - ! - if (level < nlev) then - sweeps = p%precv(level)%parms%sweeps_pre - else - sweeps = p%precv(level)%parms%sweeps - end if - 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 (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during smoother_apply') - goto 9999 - end if - - ! - ! Compute the residual (at all levels but the coarsest one) - ! - if (level < nlev) then - call psb_spmm(-done,p%precv(level)%base_a,& - & mlprec_wrk(level)%y2l,done,mlprec_wrk(level)%x2l,& - & p%precv(level)%base_desc,info,work=work,trans=trans) - if (info /= psb_success_) goto 9999 - call inner_ml_aply(level+1,p,mlprec_wrk,trans,work,info) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error in recursive call') - goto 9999 - end if - - - call psb_map_Y2X(done,mlprec_wrk(level+1)%y2l,& - & done,mlprec_wrk(level)%y2l,& - & 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 - - - end if - - - case('T','C') - - ! pre-smooth transpose is post-smoothing - - - if (level > 1) then - ! Apply the restriction - call psb_map_X2Y(done,mlprec_wrk(level-1)%x2l,& - & dzero,mlprec_wrk(level)%x2l,& - & p%precv(level)%map,info,work=work) - - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during restriction') - goto 9999 - end if - - end if - - if (level < nlev) then - call inner_ml_aply(level+1,p,mlprec_wrk,trans,work,info) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error in recursive call') - goto 9999 - end if - - ! - ! Apply the prolongator - ! - call psb_map_Y2X(done,mlprec_wrk(level+1)%y2l,& - & dzero,mlprec_wrk(level)%y2l,& - & 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 - ! - call psb_spmm(-done,p%precv(level)%base_a,mlprec_wrk(level)%y2l,& - & done,mlprec_wrk(level)%x2l,p%precv(level)%base_desc,info,& - & work=work,trans=trans) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during residue') - goto 9999 - end if - - - sweeps = p%precv(level)%parms%sweeps_pre - call p%precv(level)%sm%apply(done,& - & mlprec_wrk(level)%x2l,done,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,& - & a_err='Error during smoother_apply') - goto 9999 - end if - 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) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during smoother_apply') - goto 9999 - end if - - end if - - case default - info = psb_err_internal_error_ - call psb_errpush(info,name,a_err='invalid trans') - goto 9999 - end select + p%precv(level)%parms%sweeps_post = 0 + call mld_d_inner_mult(p, mlprec_wrk, level, trans, work) 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) - if (info /= psb_success_) then - info=psb_err_alloc_request_ - call psb_errpush(info,name,i_err=(/2*nc2l,izero,izero,izero,izero/),& - & a_err='real(psb_dpk_)') - goto 9999 - end if - - if (level > 1) then - ! Apply the restriction - call psb_map_X2Y(done,mlprec_wrk(level-1)%ty,& - & dzero,mlprec_wrk(level)%x2l,& - & p%precv(level)%map,info,work=work) - - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during restriction') - goto 9999 - end if - end if - call psb_geaxpby(done,mlprec_wrk(level)%x2l,dzero,mlprec_wrk(level)%tx,& - & p%precv(level)%base_desc,info) - ! - ! Apply the base preconditioner - ! - if (level < nlev) then - if (trans == 'N') then - sweeps = p%precv(level)%parms%sweeps_pre - else - sweeps = p%precv(level)%parms%sweeps_post - 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)%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') - goto 9999 - end if - ! - ! Compute the residual (at all levels but the coarsest one) - ! and call recursively - ! - if(level < nlev) then - mlprec_wrk(level)%ty = mlprec_wrk(level)%x2l - if (info == psb_success_) call psb_spmm(-done,p%precv(level)%base_a,& - & mlprec_wrk(level)%y2l,done,mlprec_wrk(level)%ty,& - & p%precv(level)%base_desc,info,work=work,trans=trans) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during residue') - goto 9999 - end if - - call inner_ml_aply(level+1,p,mlprec_wrk,trans,work,info) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error in recursive call') - goto 9999 - end if - - - ! - ! Apply the prolongator - ! - call psb_map_Y2X(done,mlprec_wrk(level+1)%y2l,& - & done,mlprec_wrk(level)%y2l,& - & 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 - ! - call psb_spmm(-done,p%precv(level)%base_a,mlprec_wrk(level)%y2l,& - & done,mlprec_wrk(level)%tx,p%precv(level)%base_desc,info,& - & work=work,trans=trans) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during residue') - goto 9999 - end if - ! - ! Apply the base preconditioner - ! - if (trans == 'N') then - sweeps = p%precv(level)%parms%sweeps_post - 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)%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)%tx,done,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') - goto 9999 - end if - - endif + call mld_d_inner_mult(p, mlprec_wrk, level, trans, work) case default info = psb_err_from_subroutine_ai_ @@ -976,6 +522,15 @@ contains end select + + case(mld_vcycle_ml_, mld_wcycle_ml_) + + call mld_d_inner_mult(p, mlprec_wrk, level, trans, work) + + case(mld_kcycle_ml_, mld_kcyclesym_ml_) + + call mld_d_inner_k_cycle(p, mlprec_wrk, level, trans, work) + case default info = psb_err_from_subroutine_ai_ call psb_errpush(info,name,a_err='invalid mltype',& @@ -992,293 +547,50 @@ contains end subroutine inner_ml_aply -end subroutine mld_dmlprec_aply -subroutine mld_dmlprec_aply_vect(alpha,p,x,beta,y,desc_data,trans,work,info) + recursive subroutine mld_d_inner_add(p, mlprec_wrk, level, trans, work) + use psb_base_mod + use mld_prec_mod - use psb_base_mod - use mld_d_inner_mod, mld_protect_name => mld_dmlprec_aply_vect + implicit none - implicit none + !Input/Oputput variables + type(mld_dprec_type), intent(inout) :: p - ! Arguments - type(psb_desc_type),intent(in) :: desc_data - type(mld_dprec_type), intent(inout) :: p - real(psb_dpk_),intent(in) :: alpha,beta - type(psb_d_vect_type),intent(inout) :: x - type(psb_d_vect_type),intent(inout) :: y - character, intent(in) :: trans - real(psb_dpk_),target :: work(:) - integer(psb_ipk_), intent(out) :: info + type(mld_mlprec_wrk_type), target, intent(inout) :: mlprec_wrk(:) + integer(psb_ipk_), intent(in) :: level + character, intent(in) :: trans + real(psb_dpk_),target :: work(:) + type(psb_d_vect_type) :: res + type(psb_d_vect_type), pointer :: current + integer(psb_ipk_) :: sweeps_post, sweeps_pre + ! Local variables + integer(psb_ipk_) :: ictxt,np,me + integer(psb_ipk_) :: i, err_act + integer(psb_ipk_) :: debug_level, debug_unit + integer(psb_ipk_) :: nlev, ilev, sweeps + logical :: pre, post + character(len=20) :: name - ! Local variables - integer(psb_ipk_) :: ictxt, np, me - integer(psb_ipk_) :: debug_level, debug_unit, nlev,nc2l,nr2l,level, err_act - character(len=20) :: name - character :: trans_ - real(psb_dpk_) :: par - type mld_mlprec_wrk_type - real(psb_dpk_), allocatable :: tx(:), ty(:), x2l(:), y2l(:) - type(psb_d_vect_type) :: vtx, vty, vx2l, vy2l - end type mld_mlprec_wrk_type - type(mld_mlprec_wrk_type), allocatable, target :: mlprec_wrk(:) - name='mld_dmlprec_aply' - info = psb_success_ - call psb_erractionsave(err_act) - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - ictxt = desc_data%get_context() - call psb_info(ictxt, me, np) + name = 'inner_inner_add' + info = psb_success_ + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + nlev = size(p%precv) + if ((level < 1) .or. (level > nlev)) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='wrong call level to inner_add') + goto 9999 + end if + ictxt = p%precv(level)%base_desc%get_context() + call psb_info(ictxt, me, np) - if (debug_level >= psb_debug_inner_) & - & write(debug_unit,*) me,' ',trim(name),& - & ' Entry ', size(p%precv) - - trans_ = psb_toupper(trans) - nlev = size(p%precv) - allocate(mlprec_wrk(nlev),stat=info) - if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') - goto 9999 - end if - level = 1 - do level = 1, nlev - call psb_geasb(mlprec_wrk(level)%vx2l,& - & p%precv(level)%base_desc,info,& - & scratch=.true.,mold=x%v) - call psb_geasb(mlprec_wrk(level)%vy2l,& - & p%precv(level)%base_desc,info,& - & scratch=.true.,mold=x%v) - call psb_geasb(mlprec_wrk(level)%vtx,& - & p%precv(level)%base_desc,info,& - & scratch=.true.,mold=x%v) - call psb_geasb(mlprec_wrk(level)%vty,& - & p%precv(level)%base_desc,info,& - & scratch=.true.,mold=x%v) - if (psb_errstatus_fatal()) then - nc2l = p%precv(level)%base_desc%get_local_cols() - info=psb_err_alloc_request_ - call psb_errpush(info,name,i_err=(/2*nc2l,izero,izero,izero,izero/),& - & a_err='real(psb_dpk_)') - goto 9999 - end if - end do - level = 1 - - call psb_geaxpby(done,x,dzero,mlprec_wrk(level)%vx2l,p%precv(level)%base_desc,info) - call mlprec_wrk(level)%vy2l%zero() - - - call inner_ml_aply(level,p,mlprec_wrk,trans_,work,info) - - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Inner prec aply') - goto 9999 - end if - - call psb_geaxpby(alpha,mlprec_wrk(level)%vy2l,beta,y,& - & p%precv(level)%base_desc,info) - do level = 1, nlev - - call mlprec_wrk(level)%vx2l%free(info) - call mlprec_wrk(level)%vy2l%free(info) - call mlprec_wrk(level)%vtx%free(info) - call mlprec_wrk(level)%vty%free(info) - if (psb_errstatus_fatal()) then - info=psb_err_alloc_request_ - nc2l = p%precv(level)%base_desc%get_local_cols() - call psb_errpush(info,name,i_err=(/2*nc2l,izero,izero,izero,izero/),& - & a_err='real(psb_dpk_)') - goto 9999 - end if - end do - - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error final update') - goto 9999 - end if - - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - -contains - - recursive subroutine inner_ml_aply(level,p,mlprec_wrk,trans,work,info, U) - - implicit none - - ! Arguments - integer(psb_ipk_) :: level - type(mld_dprec_type), target, intent(inout) :: p - type(mld_mlprec_wrk_type), intent(inout), target :: mlprec_wrk(:) - character, intent(in) :: trans - real(psb_dpk_),target :: work(:) - integer(psb_ipk_), intent(out) :: info - type(psb_d_vect_type),intent(inout), optional :: u - - type(psb_d_vect_type) :: res - type(psb_d_vect_type), pointer :: current - integer(psb_ipk_) :: sweeps_post, sweeps_pre - ! Local variables - integer(psb_ipk_) :: ictxt,np,me - integer(psb_ipk_) :: i, nr2l,nc2l,err_act - integer(psb_ipk_) :: debug_level, debug_unit - integer(psb_ipk_) :: nlev, ilev, sweeps - logical :: pre, post - character(len=20) :: name - - - - name = 'inner_ml_aply' - info = psb_success_ - call psb_erractionsave(err_act) - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - nlev = size(p%precv) - if ((level < 1) .or. (level > nlev)) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='wrong call level to inner_ml') - goto 9999 - end if - ictxt = p%precv(level)%base_desc%get_context() - call psb_info(ictxt, me, np) - - 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) - - case(mld_no_ml_) - ! - ! No preconditioning, should not really get here - ! - call psb_errpush(psb_err_internal_error_,name,& - & a_err='mld_no_ml_ in mlprc_aply?') - goto 9999 - - case(mld_add_ml_) - - call mld_d_inner_add(p, mlprec_wrk, level, trans, work) - - - case(mld_mult_ml_) - ! - ! Multiplicative multilevel (multiplicative among the levels, additive inside - ! each level) - ! - ! Pre/post-smoothing versions. - ! Note that the transpose switches pre <-> post. - ! - select case(p%precv(level)%parms%smoother_pos) - - case(mld_post_smooth_) - p%precv(level)%parms%sweeps_pre = 0 - call mld_d_inner_mult(p, mlprec_wrk, level, trans, work) - - - case(mld_pre_smooth_) - p%precv(level)%parms%sweeps_post = 0 - call mld_d_inner_mult(p, mlprec_wrk, level, trans, work) - - case(mld_twoside_smooth_) - call mld_d_inner_mult(p, mlprec_wrk, level, trans, work) - - case default - info = psb_err_from_subroutine_ai_ - call psb_errpush(info,name,a_err='invalid smooth_pos',& - & i_Err=(/p%precv(level)%parms%smoother_pos,izero,izero,izero,izero/)) - goto 9999 - - end select - - - case(mld_mult_dev_ml_) - - call mld_d_inner_mult(p, mlprec_wrk, level, trans, work) - - - case(mld_vcycle_ml_, mld_wcycle_ml_) - - call mld_d_inner_vw_cycle(p, mlprec_wrk, level, trans, work, u=u) - - case(mld_kcycle_ml_, mld_kcyclesym_ml_) - - call mld_d_inner_k_cycle(p, mlprec_wrk, level, trans, work, u=u) - - case default - info = psb_err_from_subroutine_ai_ - call psb_errpush(info,name,a_err='invalid mltype',& - & i_Err=(/p%precv(level)%parms%ml_type,izero,izero,izero,izero/)) - goto 9999 - - end select - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - return - - end subroutine inner_ml_aply - - - recursive subroutine mld_d_inner_add(p, mlprec_wrk, level, trans, work) - use psb_base_mod - use mld_prec_mod - - implicit none - - !Input/Oputput variables - type(mld_dprec_type), intent(inout) :: p - - type(mld_mlprec_wrk_type), target, intent(inout) :: mlprec_wrk(:) - integer(psb_ipk_), intent(in) :: level - character, intent(in) :: trans - real(psb_dpk_),target :: work(:) - type(psb_d_vect_type) :: res - type(psb_d_vect_type), pointer :: current - integer(psb_ipk_) :: sweeps_post, sweeps_pre - ! Local variables - integer(psb_ipk_) :: ictxt,np,me - integer(psb_ipk_) :: i, nr2l,nc2l,err_act - integer(psb_ipk_) :: debug_level, debug_unit - integer(psb_ipk_) :: nlev, ilev, sweeps - logical :: pre, post - character(len=20) :: name - - - - name = 'inner_inner_add' - info = psb_success_ - call psb_erractionsave(err_act) - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - nlev = size(p%precv) - if ((level < 1) .or. (level > nlev)) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='wrong call level to inner_add') - goto 9999 - end if - ictxt = p%precv(level)%base_desc%get_context() - call psb_info(ictxt, me, np) - - 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_add at level ',level - end if + if(debug_level > 1) then + write(debug_unit,*) me,' inner_add at level ',level + end if if ((level<1).or.(level>nlev)) then info = psb_err_internal_error_ @@ -1287,21 +599,6 @@ contains goto 9999 end if - - if (level > 1) then - ! Apply the restriction - call psb_map_X2Y(done,mlprec_wrk(level-1)%vx2l,& - & dzero,mlprec_wrk(level)%vx2l,& - & p%precv(level)%map,info,work=work) - - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during restriction') - goto 9999 - end if - - end if - sweeps = p%precv(level)%parms%sweeps call p%precv(level)%sm%apply(done,& & mlprec_wrk(level)%vx2l,dzero,mlprec_wrk(level)%vy2l,& @@ -1314,6 +611,17 @@ contains end if if (level < nlev) then + ! Apply the restriction + call psb_map_X2Y(done,mlprec_wrk(level)%vx2l,& + & dzero,mlprec_wrk(level+1)%vx2l,& + & p%precv(level+1)%map,info,work=work) + call mlprec_wrk(level+1)%vy2l%zero() + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Error during restriction') + goto 9999 + end if + call inner_ml_aply(level+1,p,mlprec_wrk,trans,work,info) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& @@ -1362,7 +670,7 @@ contains integer(psb_ipk_) :: sweeps_post, sweeps_pre ! Local variables integer(psb_ipk_) :: ictxt,np,me - integer(psb_ipk_) :: i, nr2l,nc2l,err_act + integer(psb_ipk_) :: i, err_act integer(psb_ipk_) :: debug_level, debug_unit integer(psb_ipk_) :: nlev, ilev, sweeps logical :: pre, post @@ -1384,13 +692,10 @@ contains ictxt = p%precv(level)%base_desc%get_context() call psb_info(ictxt, me, np) - 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_mult at level ',level end if - if ((level < nlev).or.(nlev == 1)) then sweeps_post = p%precv(level)%parms%sweeps_post sweeps_pre = p%precv(level)%parms%sweeps_pre @@ -1402,49 +707,31 @@ contains pre = ((sweeps_pre>0).and.(trans=='N')).or.((sweeps_post>0).and.(trans/='N')) post = ((sweeps_post>0).and.(trans=='N')).or.((sweeps_pre>0).and.(trans/='N')) + + if (level < nlev) then + + ! + ! Apply the first smoother + ! - if (level > 1) then - ! Apply the restriction - if (pre) then - current => mlprec_wrk(level-1)%vty - else - current => mlprec_wrk(level-1)%vx2l - endif - call psb_map_X2Y(done,current,& - & dzero,mlprec_wrk(level)%vx2l,& - & p%precv(level)%map,info,work=work) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during restriction') - goto 9999 - end if - end if - - - if (level < nlev) then - - ! - ! Apply the base preconditioner - ! - if (pre) then if (trans == 'N') then sweeps = p%precv(level)%parms%sweeps_pre if (info == psb_success_) call p%precv(level)%sm%apply(done,& & mlprec_wrk(level)%vx2l,dzero,mlprec_wrk(level)%vy2l,& & p%precv(level)%base_desc, trans,& - & sweeps,work,info) + & sweeps,work,info,init='Y') 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) + & sweeps,work,info,init='Y') end if if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during 2-PRE smoother_apply') + & a_err='Error during PRE smoother_apply') goto 9999 end if endif @@ -1465,9 +752,36 @@ contains & a_err='Error during residue') goto 9999 end if + call psb_map_X2Y(done,mlprec_wrk(level)%vty,& + & dzero,mlprec_wrk(level+1)%vx2l,& + & 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 restriction') + goto 9999 + end if + else + ! Shortcut: just transfer x2l. + call psb_map_X2Y(done,mlprec_wrk(level)%vx2l,& + & dzero,mlprec_wrk(level+1)%vx2l,& + & 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 restriction') + goto 9999 + end if endif + ! First guess is zero + call mlprec_wrk(level+1)%vy2l%zero() + call inner_ml_aply(level+1,p,mlprec_wrk,trans,work,info) + + if (p%precv(level)%parms%ml_type == mld_wcycle_ml_) then + ! On second call will use output y2l as initial guess + if (info == psb_success_) call inner_ml_aply(level+1,p,mlprec_wrk,trans,work,info) + endif + if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& & a_err='Error in recursive call') @@ -1478,15 +792,8 @@ contains ! ! Apply the prolongator ! - - if (pre) then - par = done - else - par = dzero - endif - call psb_map_Y2X(done,mlprec_wrk(level+1)%vy2l,& - & par,mlprec_wrk(level)%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,& @@ -1510,27 +817,28 @@ contains goto 9999 end if ! - ! Apply the base preconditioner + ! Apply the second smoother ! if (trans == 'N') then sweeps = p%precv(level)%parms%sweeps_post if (info == psb_success_) call p%precv(level)%sm2%apply(done,& & mlprec_wrk(level)%vtx,done,mlprec_wrk(level)%vy2l,& & p%precv(level)%base_desc, trans,& - & sweeps,work,info) + & sweeps,work,info,init='Y') else sweeps = p%precv(level)%parms%sweeps_pre 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) + & sweeps,work,info,init='Y') end if if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during 2-POST smoother_apply') + & a_err='Error during POST smoother_apply') goto 9999 end if + endif else if (level == nlev) then @@ -1545,7 +853,7 @@ contains info = psb_err_internal_error_ call psb_errpush(info,name,& - & a_err='Invalid LEVEL>NLEV') + & a_err='Invalid LEVEL vs NLEV') goto 9999 end if @@ -1557,7 +865,7 @@ contains end subroutine mld_d_inner_mult - recursive subroutine mld_d_inner_vw_cycle(p, mlprec_wrk, level, trans, work,u) + recursive subroutine mld_d_inner_k_cycle(p, mlprec_wrk, level, trans, work,u) use psb_base_mod use mld_prec_mod @@ -1578,7 +886,7 @@ contains integer(psb_ipk_) :: sweeps_post, sweeps_pre ! Local variables integer(psb_ipk_) :: ictxt,np,me - integer(psb_ipk_) :: i, nr2l,nc2l,err_act + integer(psb_ipk_) :: i, err_act integer(psb_ipk_) :: debug_level, debug_unit integer(psb_ipk_) :: nlev, ilev, sweeps logical :: pre, post @@ -1600,8 +908,6 @@ contains ictxt = p%precv(level)%base_desc%get_context() call psb_info(ictxt, me, np) - 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_add at level ',level end if @@ -1612,90 +918,50 @@ contains & a_err='Invalid LEVEL>NLEV') goto 9999 end if - call psb_geasb(res,p%precv(level)%base_desc,info,& - & scratch=.true., mold=mlprec_wrk(level)%vx2l%v) - - !V/W cycle - if (level > 1) then - ! Apply the restriction - call psb_map_X2Y(done,mlprec_wrk(level-1)%vty,& - & dzero,mlprec_wrk(level)%vx2l,& - & p%precv(level)%map,info,work=work) - - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during restriction') - goto 9999 - end if - end if - - call psb_geaxpby(done,mlprec_wrk(level)%vx2l,& - & dzero,mlprec_wrk(level)%vtx,& - & p%precv(level)%base_desc,info) - ! - ! Apply the base preconditioner - ! - if (level < nlev) then - - if (present(u)) then - ! call mlprec_wrk(level)%vy2l%set(u%get_vect()) - call psb_geaxpby(done,u,& - & dzero,mlprec_wrk(level)%vy2l,& - & p%precv(level)%base_desc,info) - - else - call mlprec_wrk(level)%vy2l%zero() - endif - call psb_geaxpby(done,mlprec_wrk(level)%vx2l,dzero,res,& - & p%precv(level)%base_desc,info) - - call psb_spmm(-done,p%precv(level)%base_a,mlprec_wrk(level)%vy2l,& - done, res, p%precv(level)%base_desc, info, work=work, trans=trans) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during residue') - goto 9999 - end if + !K cycle + + if (level == nlev) then + ! + ! Apply smoother + ! + sweeps = p%precv(level)%parms%sweeps + 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,init='Y') + + else 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) + & sweeps,work,info,init='Y') 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) + & sweeps,work,info,init='Y') end if - else - sweeps = p%precv(level)%parms%sweeps - 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 2-PRE smoother_apply') - goto 9999 - end if + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,& + & 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 - ! - if(level < nlev) then + ! + ! Compute the residual and call recursively + ! call psb_geaxpby(done,mlprec_wrk(level)%vx2l,& & dzero,mlprec_wrk(level)%vty,& & p%precv(level)%base_desc,info) - + if (info == psb_success_) call psb_spmm(-done,p%precv(level)%base_a,& & mlprec_wrk(level)%vy2l,done,mlprec_wrk(level)%vty,& & p%precv(level)%base_desc,info,work=work,trans=trans) @@ -1705,10 +971,27 @@ contains goto 9999 end if - call inner_ml_aply(level+1,p,mlprec_wrk,trans,work,info) + ! Apply the restriction + call psb_map_X2Y(done,mlprec_wrk(level)%vty,& + & dzero,mlprec_wrk(level + 1)%vx2l,& + & p%precv(level + 1)%map,info,work=work) + call mlprec_wrk(level + 1)%vy2l%zero() + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Error during restriction') + goto 9999 + end if - if (p%precv(level)%parms%ml_type == mld_wcycle_ml_) then - call inner_ml_aply(level+1,p,mlprec_wrk,trans,work,info, u=mlprec_wrk(level+1)%vy2l) + !Set the preconditioner + + if ((level < nlev - 2)) then + if (p%precv(level)%parms%ml_type == mld_kcyclesym_ml_) then + call mld_dinneritkcycle(p, mlprec_wrk, level + 1, trans, work, 'FCG') + elseif (p%precv(level)%parms%ml_type == mld_kcycle_ml_) then + call mld_dinneritkcycle(p, mlprec_wrk, level + 1, trans, work, 'CGR') + endif + else + call inner_ml_aply(level + 1 ,p,mlprec_wrk,trans,work,info) endif if (info /= psb_success_) then @@ -1717,7 +1000,6 @@ contains goto 9999 end if - ! ! Apply the prolongator ! @@ -1734,8 +1016,11 @@ contains ! ! Compute the residual ! + call psb_geaxpby(done,mlprec_wrk(level)%vx2l,& + & dzero,mlprec_wrk(level)%vty,& + & p%precv(level)%base_desc,info) call psb_spmm(-done,p%precv(level)%base_a,mlprec_wrk(level)%vy2l,& - & done,mlprec_wrk(level)%vtx,p%precv(level)%base_desc,info,& + & done,mlprec_wrk(level)%vty,p%precv(level)%base_desc,info,& & work=work,trans=trans) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& @@ -1743,341 +1028,127 @@ contains goto 9999 end if ! - ! Apply the base preconditioner + ! Apply the smoother ! 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,& + & mlprec_wrk(level)%vty,done,mlprec_wrk(level)%vy2l,& & p%precv(level)%base_desc, trans,& - & sweeps,work,info) + & sweeps,work,info,init='Y') else sweeps = p%precv(level)%parms%sweeps_pre if (info == psb_success_) call p%precv(level)%sm%apply(done,& - & mlprec_wrk(level)%vtx,done,mlprec_wrk(level)%vy2l,& + & mlprec_wrk(level)%vty,done,mlprec_wrk(level)%vy2l,& & p%precv(level)%base_desc, trans,& - & sweeps,work,info) + & sweeps,work,info,init='Y') end if if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during 2-POST smoother_apply') + & a_err='Error during POST smoother_apply') goto 9999 end if + else + info = psb_err_internal_error_ + call psb_errpush(info,name,& + & a_err='Invalid LEVEL vs NLEV') + goto 9999 + endif - call psb_erractionrestore(err_act) return 9999 call psb_error_handler(err_act) return - end subroutine mld_d_inner_vw_cycle + end subroutine mld_d_inner_k_cycle - recursive subroutine mld_d_inner_k_cycle(p, mlprec_wrk, level, trans, work,u) + + recursive subroutine mld_dinneritkcycle(p, mlprec_wrk, level, trans, work, innersolv) use psb_base_mod use mld_prec_mod + use mld_d_inner_mod, mld_protect_name => mld_dmlprec_aply implicit none !Input/Oputput variables type(mld_dprec_type), intent(inout) :: p - type(mld_mlprec_wrk_type), target, intent(inout) :: mlprec_wrk(:) + + type(mld_mlprec_wrk_type), intent(inout) :: mlprec_wrk(:) integer(psb_ipk_), intent(in) :: level - character, intent(in) :: trans + character, intent(in) :: trans, innersolv real(psb_dpk_),target :: work(:) - type(psb_d_vect_type),intent(inout), optional :: u + !Other variables + type(psb_d_vect_type) :: v, w, rhs, v1, x + type(psb_d_vect_type), dimension(0:1) :: d + real(psb_dpk_) :: delta_old, rhs_norm, alpha, tau, tau1, tau2, tau3, tau4, beta + real(psb_dpk_) :: l2_norm, delta, rtol=0.25 + real(psb_dpk_), allocatable :: temp_v(:) + integer(psb_ipk_) :: info, nlev, i, iter, max_iter=2, idx - type(psb_d_vect_type) :: res - type(psb_d_vect_type), pointer :: current - integer(psb_ipk_) :: sweeps_post, sweeps_pre - ! Local variables - integer(psb_ipk_) :: ictxt,np,me - integer(psb_ipk_) :: i, nr2l,nc2l,err_act - integer(psb_ipk_) :: debug_level, debug_unit - integer(psb_ipk_) :: nlev, ilev, sweeps - logical :: pre, post - character(len=20) :: name + !Assemble rhs, w, v, v1, x + call psb_geasb(rhs,& + & p%precv(level)%base_desc,info,& + & scratch=.true.,mold=mlprec_wrk(level)%vx2l%v) + call psb_geasb(w,& + & p%precv(level)%base_desc,info,& + & scratch=.true.,mold=mlprec_wrk(level)%vx2l%v) + call psb_geasb(v,& + & p%precv(level)%base_desc,info,& + & scratch=.true.,mold=mlprec_wrk(level)%vx2l%v) + call psb_geasb(v1,& + & p%precv(level)%base_desc,info,& + & scratch=.true.,mold=mlprec_wrk(level)%vx2l%v) + call psb_geasb(x,& + & p%precv(level)%base_desc,info,& + & scratch=.true.,mold=mlprec_wrk(level)%vx2l%v) + call x%zero() - name = 'inner_inner_add' - info = psb_success_ - call psb_erractionsave(err_act) - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - nlev = size(p%precv) - if ((level < 1) .or. (level > nlev)) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='wrong call level to inner_add') - goto 9999 - end if - ictxt = p%precv(level)%base_desc%get_context() - call psb_info(ictxt, me, np) + ! rhs=vx2l and w=rhs + call psb_geaxpby(done,mlprec_wrk(level)%vx2l,dzero,rhs,& + & p%precv(level)%base_desc,info) + call psb_geaxpby(done,mlprec_wrk(level)%vx2l,dzero,w,& + & p%precv(level)%base_desc,info) - 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_add at level ',level + if (psb_errstatus_fatal()) then + nc2l = p%precv(level)%base_desc%get_local_cols() + info=psb_err_alloc_request_ + call psb_errpush(info,name,i_err=(/2*nc2l,izero,izero,izero,izero/),& + & a_err='TYPE@(psb_dpk_)') + goto 9999 end if - if ((level<1).or.(level>nlev)) then - info = psb_err_internal_error_ - call psb_errpush(info,name,& - & a_err='Invalid LEVEL>NLEV') - goto 9999 - end if + delta = psb_gedot(w, w, p%precv(level)%base_desc, info) - !K cycle + !Apply the preconditioner - call psb_geaxpby(done,mlprec_wrk(level)%vx2l,& - & dzero,mlprec_wrk(level)%vtx,& - & p%precv(level)%base_desc,info) - ! - ! Apply the base preconditioner - ! - if (level < nlev) then + call mlprec_wrk(level)%vy2l%set(dzero) - if (present(u)) then - call psb_geaxpby(done,u,& - & dzero,mlprec_wrk(level)%vy2l,& - & p%precv(level)%base_desc,info) - else - call mlprec_wrk(level)%vy2l%zero() - endif - res = mlprec_wrk(level)%vx2l + idx=0 + call inner_ml_aply(level,p,mlprec_wrk,trans,work,info) - call psb_spmm(-done,p%precv(level)%base_a,mlprec_wrk(level)%vy2l,& - done, res, p%precv(level)%base_desc, info, work=work, trans=trans) + !Assemble d(0) and d(1) + call psb_geasb(d(0),& + & p%precv(level)%base_desc,info,& + & scratch=.true.,mold=mlprec_wrk(level)%vy2l%v) + call psb_geasb(d(1),& + & p%precv(level)%base_desc,info,& + & scratch=.true.,mold=mlprec_wrk(level)%vy2l%v) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during residue') - goto 9999 - end if + call psb_geaxpby(done,mlprec_wrk(level)%vy2l,dzero,d(idx),p%precv(level)%base_desc,info) - 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 - 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 + call psb_spmm(done,p%precv(level)%base_a,d(idx),dzero,v,p%precv(level)%base_desc,info) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& - & 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 - ! - if(level < nlev) then - - call psb_geaxpby(done,mlprec_wrk(level)%vx2l,& - & dzero,mlprec_wrk(level)%vty,& - & p%precv(level)%base_desc,info) - - if (info == psb_success_) call psb_spmm(-done,p%precv(level)%base_a,& - & mlprec_wrk(level)%vy2l,done,mlprec_wrk(level)%vty,& - & p%precv(level)%base_desc,info,work=work,trans=trans) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during residue') - goto 9999 - end if - - ! Apply the restriction - call psb_map_X2Y(done,mlprec_wrk(level)%vty,& - & dzero,mlprec_wrk(level + 1)%vx2l,& - & 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 restriction') - goto 9999 - end if - - !Set the preconditioner - - - if ((level < nlev - 2)) then - if (p%precv(level)%parms%ml_type == mld_kcyclesym_ml_) then - call mld_dinneritkcycle(p, mlprec_wrk, level + 1, trans, work, 'FCG') - elseif (p%precv(level)%parms%ml_type == mld_kcycle_ml_) then - call mld_dinneritkcycle(p, mlprec_wrk, level + 1, trans, work, 'CGR') - endif - else - call inner_ml_aply(level + 1 ,p,mlprec_wrk,trans,work,info) - endif - - - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error in recursive call') - goto 9999 - end if - - - ! - ! Apply the prolongator - ! - call 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 - ! - call psb_spmm(-done,p%precv(level)%base_a,mlprec_wrk(level)%vy2l,& - & done,mlprec_wrk(level)%vtx,p%precv(level)%base_desc,info,& - & work=work,trans=trans) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during residue') - goto 9999 - end if - ! - ! Apply the base preconditioner - ! - 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 - 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) - end if - - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during 2-POST smoother_apply') - goto 9999 - end if - - endif - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - return - - end subroutine mld_d_inner_k_cycle - - - recursive subroutine mld_dinneritkcycle(p, mlprec_wrk, level, trans, work, innersolv) - use psb_base_mod - use mld_prec_mod - use mld_d_inner_mod, mld_protect_name => mld_dmlprec_aply - - implicit none - - !Input/Oputput variables - type(mld_dprec_type), intent(inout) :: p - - type(mld_mlprec_wrk_type), intent(inout) :: mlprec_wrk(:) - integer(psb_ipk_), intent(in) :: level - character, intent(in) :: trans, innersolv - real(psb_dpk_),target :: work(:) - - !Other variables - type(psb_d_vect_type) :: v, w, rhs, v1, x - type(psb_d_vect_type), dimension(0:1) :: d - real(psb_dpk_) :: delta_old, rhs_norm, alpha, tau, tau1, tau2, tau3, tau4, beta - - real(psb_dpk_) :: l2_norm, delta, rtol=0.25 - real(psb_dpk_), allocatable :: temp_v(:) - integer(psb_ipk_) :: info, nlev, i, iter, max_iter=2, idx - - !Assemble rhs, w, v, v1, x - - call psb_geasb(rhs,& - & p%precv(level)%base_desc,info,& - & scratch=.true.,mold=mlprec_wrk(level)%vx2l%v) - call psb_geasb(w,& - & p%precv(level)%base_desc,info,& - & scratch=.true.,mold=mlprec_wrk(level)%vx2l%v) - call psb_geasb(v,& - & p%precv(level)%base_desc,info,& - & scratch=.true.,mold=mlprec_wrk(level)%vx2l%v) - call psb_geasb(v1,& - & p%precv(level)%base_desc,info,& - & scratch=.true.,mold=mlprec_wrk(level)%vx2l%v) - call psb_geasb(x,& - & p%precv(level)%base_desc,info,& - & scratch=.true.,mold=mlprec_wrk(level)%vx2l%v) - - call x%set(dzero) - - ! rhs=vx2l and w=rhs - call psb_geaxpby(done,mlprec_wrk(level)%vx2l,dzero,rhs,& - & p%precv(level)%base_desc,info) - call psb_geaxpby(done,mlprec_wrk(level)%vx2l,dzero,w,& - & p%precv(level)%base_desc,info) - - if (psb_errstatus_fatal()) then - nc2l = p%precv(level)%base_desc%get_local_cols() - info=psb_err_alloc_request_ - call psb_errpush(info,name,i_err=(/2*nc2l,izero,izero,izero,izero/),& - & a_err='TYPE@(psb_dpk_)') - goto 9999 - end if - - delta = psb_gedot(w, w, p%precv(level)%base_desc, info) - - !Apply the preconditioner - - call mlprec_wrk(level)%vy2l%set(dzero) - - idx=0 - call inner_ml_aply(level,p,mlprec_wrk,trans,work,info) - - !Assemble d(0) and d(1) - call psb_geasb(d(0),& - & p%precv(level)%base_desc,info,& - & scratch=.true.,mold=mlprec_wrk(level)%vy2l%v) - call psb_geasb(d(1),& - & p%precv(level)%base_desc,info,& - & scratch=.true.,mold=mlprec_wrk(level)%vy2l%v) - - call psb_geaxpby(done,mlprec_wrk(level)%vy2l,dzero,d(idx),p%precv(level)%base_desc,info) - - - call psb_spmm(done,p%precv(level)%base_a,d(idx),dzero,v,p%precv(level)%base_desc,info) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during residue') + & a_err='Error during residue') goto 9999 end if @@ -2162,3 +1233,565 @@ contains end subroutine mld_dmlprec_aply_vect + + + + +! +! Old routine for arrays instead of psb_X_vector. To be deleted eventually. +! +! +subroutine mld_dmlprec_aply(alpha,p,x,beta,y,desc_data,trans,work,info) + + use psb_base_mod + use mld_d_inner_mod, mld_protect_name => mld_dmlprec_aply + + implicit none + + ! Arguments + type(psb_desc_type),intent(in) :: desc_data + type(mld_dprec_type), intent(inout) :: p + real(psb_dpk_),intent(in) :: alpha,beta + real(psb_dpk_),intent(inout) :: x(:) + real(psb_dpk_),intent(inout) :: y(:) + character, intent(in) :: trans + real(psb_dpk_),target :: work(:) + integer(psb_ipk_), intent(out) :: info + + ! Local variables + integer(psb_ipk_) :: ictxt, np, me + integer(psb_ipk_) :: err_act + integer(psb_ipk_) :: debug_level, debug_unit, nlev,nc2l,nr2l,level + character(len=20) :: name + character :: trans_ + type mld_mlprec_wrk_type + real(psb_dpk_), allocatable :: tx(:), ty(:), x2l(:), y2l(:) + end type mld_mlprec_wrk_type + type(mld_mlprec_wrk_type), allocatable, target :: mlprec_wrk(:) + + name='mld_dmlprec_aply' + info = psb_success_ + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + ictxt = desc_data%get_context() + call psb_info(ictxt, me, np) + + if (debug_level >= psb_debug_inner_) & + & write(debug_unit,*) me,' ',trim(name),& + & ' Entry ', size(p%precv) + + trans_ = psb_toupper(trans) + + nlev = size(p%precv) + allocate(mlprec_wrk(nlev),stat=info) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') + goto 9999 + end if + level = 1 + + do level = 1, nlev + call psb_geasb(mlprec_wrk(level)%x2l,& + & p%precv(level)%base_desc,info) + call psb_geasb(mlprec_wrk(level)%y2l,& + & p%precv(level)%base_desc,info) + call psb_geasb(mlprec_wrk(level)%tx,& + & p%precv(level)%base_desc,info) + call psb_geasb(mlprec_wrk(level)%ty,& + & p%precv(level)%base_desc,info) + if (psb_errstatus_fatal()) then + nc2l = p%precv(level)%base_desc%get_local_cols() + info=psb_err_alloc_request_ + call psb_errpush(info,name,i_err=(/2*nc2l,izero,izero,izero,izero/),& + & a_err='real(psb_dpk_)') + goto 9999 + end if + end do + + mlprec_wrk(level)%x2l(:) = x(:) + mlprec_wrk(level)%y2l(:) = dzero + + call inner_ml_aply(level,p,mlprec_wrk,trans_,work,info) + + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Inner prec aply') + goto 9999 + end if + + call psb_geaxpby(alpha,mlprec_wrk(level)%y2l,beta,y,& + & p%precv(level)%base_desc,info) + + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Error final update') + goto 9999 + end if + + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +contains + + ! + ! + ! inner_ml_aply: apply AMG at a given level. + ! This routine dispatches the computation according to the type + ! specified at the current level. + ! Each of the corrections will inturn call recursively this routine. + ! + ! Assumptions: + ! On input: + ! mlprec_wkr(level)%vx2l contains the input vector (RHS) + ! mlprec_wkr(level)%vy2l contains the initial guess + ! + ! On output: + ! mlprec_wkr(level)%vy2l contains the solution + ! + ! Constraints: each of the called routines must properly handle + ! the input/output conditions for level+1 (i.e. apply + ! prolongation/restriction). + ! Note: for historical/convenience reasons the prolongator/restrictor + ! between level and level+1 are stored at level+1. + ! + ! + recursive subroutine inner_ml_aply(level,p,mlprec_wrk,trans,work,info) + + implicit none + + ! Arguments + integer(psb_ipk_) :: level + type(mld_dprec_type), target, intent(inout) :: p + type(mld_mlprec_wrk_type), intent(inout), target :: mlprec_wrk(:) + character, intent(in) :: trans + real(psb_dpk_),target :: work(:) + integer(psb_ipk_), intent(out) :: info + + type(psb_d_vect_type) :: res + type(psb_d_vect_type), pointer :: current + integer(psb_ipk_) :: sweeps_post, sweeps_pre + ! Local variables + integer(psb_ipk_) :: ictxt,np,me + integer(psb_ipk_) :: i, err_act + integer(psb_ipk_) :: debug_level, debug_unit + integer(psb_ipk_) :: nlev, ilev, sweeps + logical :: pre, post + character(len=20) :: name + + + + name = 'inner_ml_aply' + info = psb_success_ + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + nlev = size(p%precv) + if ((level < 1) .or. (level > nlev)) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='wrong call level to inner_ml') + goto 9999 + end if + ictxt = p%precv(level)%base_desc%get_context() + call psb_info(ictxt, me, np) + + if(debug_level > 1) then + write(debug_unit,*) me,' inner_ml_aply at level ',level + end if + + select case(p%precv(level)%parms%ml_type) + + case(mld_no_ml_) + ! + ! No preconditioning, should not really get here + ! + call psb_errpush(psb_err_internal_error_,name,& + & a_err='mld_no_ml_ in mlprc_aply?') + goto 9999 + + case(mld_add_ml_) + + call mld_d_inner_add(p, mlprec_wrk, level, trans, work) + + + case(mld_mult_ml_) + ! + ! Multiplicative multilevel (multiplicative among the levels, additive inside + ! each level) + ! + ! Pre/post-smoothing versions. + ! Note that the transpose switches pre <-> post. + ! + select case(p%precv(level)%parms%smoother_pos) + + case(mld_post_smooth_) + p%precv(level)%parms%sweeps_pre = 0 + call mld_d_inner_mult(p, mlprec_wrk, level, trans, work) + + + case(mld_pre_smooth_) + p%precv(level)%parms%sweeps_post = 0 + call mld_d_inner_mult(p, mlprec_wrk, level, trans, work) + + case(mld_twoside_smooth_) + call mld_d_inner_mult(p, mlprec_wrk, level, trans, work) + + case default + info = psb_err_from_subroutine_ai_ + call psb_errpush(info,name,a_err='invalid smooth_pos',& + & i_Err=(/p%precv(level)%parms%smoother_pos,izero,izero,izero,izero/)) + goto 9999 + + end select + + + case(mld_vcycle_ml_, mld_wcycle_ml_) + + call mld_d_inner_mult(p, mlprec_wrk, level, trans, work) + +! !$ case(mld_kcycle_ml_, mld_kcyclesym_ml_) +! !$ +! !$ call mld_d_inner_k_cycle(p, mlprec_wrk, level, trans, work) + + case default + info = psb_err_from_subroutine_ai_ + call psb_errpush(info,name,a_err='invalid mltype',& + & i_Err=(/p%precv(level)%parms%ml_type,izero,izero,izero,izero/)) + goto 9999 + + end select + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + return + + end subroutine inner_ml_aply + + + recursive subroutine mld_d_inner_add(p, mlprec_wrk, level, trans, work) + use psb_base_mod + use mld_prec_mod + + implicit none + + !Input/Oputput variables + type(mld_dprec_type), intent(inout) :: p + + type(mld_mlprec_wrk_type), target, intent(inout) :: mlprec_wrk(:) + integer(psb_ipk_), intent(in) :: level + character, intent(in) :: trans + real(psb_dpk_),target :: work(:) + type(psb_d_vect_type) :: res + type(psb_d_vect_type), pointer :: current + integer(psb_ipk_) :: sweeps_post, sweeps_pre + ! Local variables + integer(psb_ipk_) :: ictxt,np,me + integer(psb_ipk_) :: i, err_act + integer(psb_ipk_) :: debug_level, debug_unit + integer(psb_ipk_) :: nlev, ilev, sweeps + logical :: pre, post + character(len=20) :: name + + + + name = 'inner_inner_add' + info = psb_success_ + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + nlev = size(p%precv) + if ((level < 1) .or. (level > nlev)) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='wrong call level to inner_add') + goto 9999 + end if + ictxt = p%precv(level)%base_desc%get_context() + call psb_info(ictxt, me, np) + + if(debug_level > 1) then + write(debug_unit,*) me,' inner_add at level ',level + end if + + if ((level<1).or.(level>nlev)) then + info = psb_err_internal_error_ + call psb_errpush(info,name,& + & a_err='Invalid LEVEL>NLEV') + goto 9999 + end if + + sweeps = p%precv(level)%parms%sweeps + 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 (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Error during ADD smoother_apply') + goto 9999 + end if + + if (level < nlev) then + ! Apply the restriction + call psb_map_X2Y(done,mlprec_wrk(level)%x2l,& + & dzero,mlprec_wrk(level+1)%x2l,& + & p%precv(level+1)%map,info,work=work) + mlprec_wrk(level+1)%y2l(:) = dzero + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Error during restriction') + goto 9999 + end if + + call inner_ml_aply(level+1,p,mlprec_wrk,trans,work,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Error in recursive call') + goto 9999 + end if + + ! + ! Apply the prolongator + ! + call psb_map_Y2X(done,mlprec_wrk(level+1)%y2l,& + & done,mlprec_wrk(level)%y2l,& + & 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 + + + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + return + + end subroutine mld_d_inner_add + + recursive subroutine mld_d_inner_mult(p, mlprec_wrk, level, trans, work) + use psb_base_mod + use mld_prec_mod + + implicit none + + !Input/Oputput variables + type(mld_dprec_type), intent(inout) :: p + + type(mld_mlprec_wrk_type), target, intent(inout) :: mlprec_wrk(:) + integer(psb_ipk_), intent(in) :: level + character, intent(in) :: trans + real(psb_dpk_),target :: work(:) + type(psb_d_vect_type) :: res + type(psb_d_vect_type), pointer :: current + integer(psb_ipk_) :: sweeps_post, sweeps_pre + ! Local variables + integer(psb_ipk_) :: ictxt,np,me + integer(psb_ipk_) :: i, err_act + integer(psb_ipk_) :: debug_level, debug_unit + integer(psb_ipk_) :: nlev, ilev, sweeps + logical :: pre, post + character(len=20) :: name + + + + name = 'inner_inner_mult' + info = psb_success_ + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + nlev = size(p%precv) + if ((level < 1) .or. (level > nlev)) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='wrong call level to inner_mult') + goto 9999 + end if + ictxt = p%precv(level)%base_desc%get_context() + call psb_info(ictxt, me, np) + + if(debug_level > 1) then + write(debug_unit,*) me,' inner_mult at level ',level + end if + + if ((level < nlev).or.(nlev == 1)) then + sweeps_post = p%precv(level)%parms%sweeps_post + sweeps_pre = p%precv(level)%parms%sweeps_pre + else + sweeps_post = p%precv(level-1)%parms%sweeps_post + sweeps_pre = p%precv(level-1)%parms%sweeps_pre + endif + + pre = ((sweeps_pre>0).and.(trans=='N')).or.((sweeps_post>0).and.(trans/='N')) + post = ((sweeps_post>0).and.(trans=='N')).or.((sweeps_pre>0).and.(trans/='N')) + + + if (level < nlev) then + + ! + ! Apply the first smoother + ! + + if (pre) then + if (trans == 'N') then + sweeps = p%precv(level)%parms%sweeps_pre + if (info == psb_success_) call p%precv(level)%sm%apply(done,& + & mlprec_wrk(level)%x2l,dzero,mlprec_wrk(level)%y2l,& + & p%precv(level)%base_desc, trans,& + & sweeps,work,info,init='Y') + else + sweeps = p%precv(level)%parms%sweeps_post + if (info == psb_success_) call p%precv(level)%sm2%apply(done,& + & mlprec_wrk(level)%x2l,dzero,mlprec_wrk(level)%y2l,& + & p%precv(level)%base_desc, trans,& + & sweeps,work,info,init='Y') + end if + + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Error during PRE smoother_apply') + goto 9999 + end if + endif + + ! + ! Compute the residual and call recursively + ! + if (pre) then + call psb_geaxpby(done,mlprec_wrk(level)%x2l,& + & dzero,mlprec_wrk(level)%ty,& + & p%precv(level)%base_desc,info) + + if (info == psb_success_) call psb_spmm(-done,p%precv(level)%base_a,& + & mlprec_wrk(level)%y2l,done,mlprec_wrk(level)%ty,& + & p%precv(level)%base_desc,info,work=work,trans=trans) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Error during residue') + goto 9999 + end if + call psb_map_X2Y(done,mlprec_wrk(level)%ty,& + & dzero,mlprec_wrk(level+1)%x2l,& + & 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 restriction') + goto 9999 + end if + else + ! Shortcut: just transfer x2l. + call psb_map_X2Y(done,mlprec_wrk(level)%x2l,& + & dzero,mlprec_wrk(level+1)%x2l,& + & 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 restriction') + goto 9999 + end if + endif + ! First guess is zero + mlprec_wrk(level+1)%y2l(:) = dzero + + + call inner_ml_aply(level+1,p,mlprec_wrk,trans,work,info) + + if (p%precv(level)%parms%ml_type == mld_wcycle_ml_) then + ! On second call will use output y2l as initial guess + if (info == psb_success_) call inner_ml_aply(level+1,p,mlprec_wrk,trans,work,info) + endif + + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Error in recursive call') + goto 9999 + end if + + + ! + ! Apply the prolongator + ! + call psb_map_Y2X(done,mlprec_wrk(level+1)%y2l,& + & done,mlprec_wrk(level)%y2l,& + & 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 + ! + if (post) then + call psb_geaxpby(done,mlprec_wrk(level)%x2l,& + & dzero,mlprec_wrk(level)%tx,& + & p%precv(level)%base_desc,info) + call psb_spmm(-done,p%precv(level)%base_a,mlprec_wrk(level)%y2l,& + & done,mlprec_wrk(level)%tx,p%precv(level)%base_desc,info,& + & work=work,trans=trans) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Error during residue') + goto 9999 + end if + ! + ! Apply the second smoother + ! + if (trans == 'N') then + sweeps = p%precv(level)%parms%sweeps_post + if (info == psb_success_) call p%precv(level)%sm2%apply(done,& + & mlprec_wrk(level)%tx,done,mlprec_wrk(level)%y2l,& + & p%precv(level)%base_desc, trans,& + & sweeps,work,info,init='Y') + else + sweeps = p%precv(level)%parms%sweeps_pre + 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,init='Y') + end if + + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Error during POST smoother_apply') + goto 9999 + end if + + endif + + else if (level == nlev) then + + sweeps = p%precv(level)%parms%sweeps + 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 + + info = psb_err_internal_error_ + call psb_errpush(info,name,& + & a_err='Invalid LEVEL vs NLEV') + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + return + + end subroutine mld_d_inner_mult + + +end subroutine mld_dmlprec_aply diff --git a/mlprec/impl/mld_smlprec_aply.f90 b/mlprec/impl/mld_smlprec_aply.f90 index 4423941b..33788cf0 100644 --- a/mlprec/impl/mld_smlprec_aply.f90 +++ b/mlprec/impl/mld_smlprec_aply.f90 @@ -183,10 +183,8 @@ ! ilev-1, while PT(ilev) denotes its transpose, i.e. the corresponding ! restriction operator from level ilev-1 to level ilev). ! -! 0. Transfer the outer vector Xest to x(1) (inner X at level 1) +! 1. Transfer the outer vector Xest to x(1) (inner X at level 1) ! -! 1. If ilev > 1 Transfer x(ilev-1) to the current level: -! x(ilev) = PT(ilev)*x(ilev-1) ! ! 2. Apply the base preconditioner at the current level: ! ! The sum over the subdomains is carried out in the @@ -194,8 +192,10 @@ ! y(ilev) = (K(ilev)^(-1))*x(ilev) ! ! 3. If ilev < nlevel -! a. Call recursively itself -! b. Transfer y(ilev+1) to the current level: +! a. Transfer x(ilev) to the next level: +! x(ilev+1) = PT(ilev+1)*x(ilev) +! b. Call recursively itself +! c. Transfer y(ilev+1) to the current level: ! y(ilev) = y(ilev) + P(ilev+1)*y(ilev+1) ! ! 4. if ilev == 1 Transfer the inner y to the external: @@ -215,11 +215,8 @@ ! differential equations, Cambridge University Press, 1996. ! ! -! 0. Transfer the outer vector Xest to x(1) (inner X at level 1) +! 1 Transfer the outer vector Xest to x(1) (inner X at level 1) ! -! 1. If ilev >1 Transfer x(ilev-1) to the current level: -! x(ilev) = PT(ilev)*x(ilev-1) -! ! 2. Apply the base preconditioner at the current level: ! ! The sum over the subdomains is carried out in the ! ! application of K(ilev). @@ -228,11 +225,10 @@ ! 3. If ilev < nlevel ! a. Compute the residual: ! r(ilev) = x(ilev) - A(ilev)*y(ilev) -! b. Call recursively itself passing -! r(ilev) for transfer to the next level -! (r(ilev) matches x(ilev-1) in step 1) -! -! c. Transfer y(ilev+1) to the current level: +! b. Transfer r(ilev) to the next level: +! x(ilev+1) = PT(ilev+1)*r(ilev) +! c. Call recursively +! d. Transfer y(ilev+1) to the current level: ! y(ilev) = y(ilev) + P(ilev+1)*y(ilev+1) ! ! 4. if ilev == 1 Transfer the inner y to the external: @@ -242,28 +238,23 @@ ! ! Hybrid multiplicative, post-smoothing variant ! -! 0. Transfer the outer vector Xest to x(1) (inner X at level 1) +! 1. Transfer the outer vector Xest to x(1) (inner X at level 1) ! -! 1. If ilev > 1 Transfer x(ilev-1) to the current level: -! x(ilev) = PT(ilev)*x(ilev-1) -! ! 2. If ilev < nlev -! a. Call recursively itself passing -! x(ilev) for transfer to the next level -! b. Transfer y(ilev+1) to the current level: +! a. Transfer x(ilev) to the next level: +! x(ilev+1) = PT(ilev+1)*x(ilev) +! b. Call recursively +! c. Transfer y(ilev+1) to the current level: ! y(ilev) = P(ilev+1)*y(ilev+1) -! c. Compute the residual: +! d. Compute the residual: ! x(ilev) = x(ilev) - A(ilev)*y(ilev) -! d. Apply the base preconditioner to the residual at the current level: +! e. Apply the base preconditioner to the residual at the current level: ! ! The sum over the subdomains is carried out in the ! ! application of K(ilev) ! y(ilev) = y(ilev) + (K(ilev)^(-1))*x(ilev) -! Else -! Apply the base preconditioner to the residual at the current level: -! ! The sum over the subdomains is carried out in the -! ! application of K(ilev) -! y(ilev) = (K(ilev)^(-1))*x(ilev) -! +! +! 3. If ilev == nlev apply y(ilev) = (K(ilev)^(-1))*x(ilev) +! ! 4. if ilev == 1 Transfer the inner Y to the external: ! Yext = beta*Yext + alpha*Y(1) ! @@ -278,11 +269,8 @@ ! differential equations, Cambridge University Press, 1996. ! ! -! 0. Transfer the outer vector Xest to x(1) (inner X at level 1) +! 1. Transfer the outer vector Xest to x(1) (inner X at level 1) ! -! 1. If ilev > 1 Transfer x(ilev-1) to the current level: -! x(ilev) = PT(ilev)*x(ilev-1) -! ! 2. Apply the base preconditioner at the current level: ! ! The sum over the subdomains is carried out in the ! ! application of K(ilev) @@ -291,10 +279,10 @@ ! 3. If ilev < nlevel ! a. Compute the residual: ! r(ilev) = x(ilev) - A(ilev)*y(ilev) -! b. Call recursively itself passing -! r(ilev) for transfer to the next level -! (r(ilev) matches x(ilev-1) in step 1) -! c. Transfer y(ilev+1) to the current level: +! b. Transfer r(ilev) to the next level: +! x(ilev+1) = PT(ilev+1)*r(ilev) +! c. Call recursively +! d. Transfer y(ilev+1) to the current level: ! y(ilev) = y(ilev) + P(ilev+1)*y(ilev+1) ! d. Compute the residual: ! r(ilev) = x(ilev) - A(ilev)*y(ilev) @@ -303,35 +291,36 @@ ! ! application of K(ilev) ! y(ilev) = y(ilev) + (K(ilev)^(-1))*r(ilev) ! -! 5. if ilev == 1 Transfer the inner Y to the external: +! 4. if ilev == 1 Transfer the inner Y to the external: ! Yext = beta*Yext + alpha*Y(1) ! ! -subroutine mld_smlprec_aply(alpha,p,x,beta,y,desc_data,trans,work,info) +subroutine mld_smlprec_aply_vect(alpha,p,x,beta,y,desc_data,trans,work,info) use psb_base_mod - use mld_s_inner_mod, mld_protect_name => mld_smlprec_aply + use mld_s_inner_mod, mld_protect_name => mld_smlprec_aply_vect implicit none ! Arguments - type(psb_desc_type),intent(in) :: desc_data - type(mld_sprec_type), intent(inout) :: p - real(psb_spk_),intent(in) :: alpha,beta - real(psb_spk_),intent(inout) :: x(:) - real(psb_spk_),intent(inout) :: y(:) - character, intent(in) :: trans - real(psb_spk_),target :: work(:) - integer(psb_ipk_), intent(out) :: info + type(psb_desc_type),intent(in) :: desc_data + type(mld_sprec_type), intent(inout) :: p + real(psb_spk_),intent(in) :: alpha,beta + type(psb_s_vect_type),intent(inout) :: x + type(psb_s_vect_type),intent(inout) :: y + character, intent(in) :: trans + real(psb_spk_),target :: work(:) + integer(psb_ipk_), intent(out) :: info ! Local variables integer(psb_ipk_) :: ictxt, np, me - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: debug_level, debug_unit, nlev,nc2l,nr2l,level + integer(psb_ipk_) :: debug_level, debug_unit, nlev,nc2l,nr2l,level, err_act character(len=20) :: name character :: trans_ + real(psb_spk_) :: par type mld_mlprec_wrk_type real(psb_spk_), allocatable :: tx(:), ty(:), x2l(:), y2l(:) + type(psb_s_vect_type) :: vtx, vty, vx2l, vy2l end type mld_mlprec_wrk_type type(mld_mlprec_wrk_type), allocatable, target :: mlprec_wrk(:) @@ -349,7 +338,6 @@ subroutine mld_smlprec_aply(alpha,p,x,beta,y,desc_data,trans,work,info) & ' Entry ', size(p%precv) trans_ = psb_toupper(trans) - nlev = size(p%precv) allocate(mlprec_wrk(nlev),stat=info) if (info /= psb_success_) then @@ -357,21 +345,32 @@ subroutine mld_smlprec_aply(alpha,p,x,beta,y,desc_data,trans,work,info) goto 9999 end if level = 1 + do level = 1, nlev + call psb_geasb(mlprec_wrk(level)%vx2l,& + & p%precv(level)%base_desc,info,& + & scratch=.true.,mold=x%v) + call psb_geasb(mlprec_wrk(level)%vy2l,& + & p%precv(level)%base_desc,info,& + & scratch=.true.,mold=x%v) + call psb_geasb(mlprec_wrk(level)%vtx,& + & p%precv(level)%base_desc,info,& + & scratch=.true.,mold=x%v) + call psb_geasb(mlprec_wrk(level)%vty,& + & p%precv(level)%base_desc,info,& + & scratch=.true.,mold=x%v) + if (psb_errstatus_fatal()) then + nc2l = p%precv(level)%base_desc%get_local_cols() + info=psb_err_alloc_request_ + call psb_errpush(info,name,i_err=(/2*nc2l,izero,izero,izero,izero/),& + & a_err='real(psb_spk_)') + goto 9999 + end if + end do + level = 1 - nc2l = p%precv(level)%base_desc%get_local_cols() - nr2l = p%precv(level)%base_desc%get_local_rows() - allocate(mlprec_wrk(level)%x2l(nc2l),mlprec_wrk(level)%y2l(nc2l),& - & stat=info) - if (info /= psb_success_) then - info=psb_err_alloc_request_ - call psb_errpush(info,name,& - & i_err=(/ione*(size(x)+size(y)),izero,izero,izero,izero/),& - & a_err='real(psb_spk_)') - goto 9999 - end if + call psb_geaxpby(sone,x,szero,mlprec_wrk(level)%vx2l,p%precv(level)%base_desc,info) + call mlprec_wrk(level)%vy2l%zero() - mlprec_wrk(level)%x2l(:) = x(:) - mlprec_wrk(level)%y2l(:) = szero call inner_ml_aply(level,p,mlprec_wrk,trans_,work,info) @@ -381,8 +380,22 @@ subroutine mld_smlprec_aply(alpha,p,x,beta,y,desc_data,trans,work,info) goto 9999 end if - call psb_geaxpby(alpha,mlprec_wrk(level)%y2l,beta,y,& + call psb_geaxpby(alpha,mlprec_wrk(level)%vy2l,beta,y,& & p%precv(level)%base_desc,info) + do level = 1, nlev + + call mlprec_wrk(level)%vx2l%free(info) + call mlprec_wrk(level)%vy2l%free(info) + call mlprec_wrk(level)%vtx%free(info) + call mlprec_wrk(level)%vty%free(info) + if (psb_errstatus_fatal()) then + info=psb_err_alloc_request_ + nc2l = p%precv(level)%base_desc%get_local_cols() + call psb_errpush(info,name,i_err=(/2*nc2l,izero,izero,izero,izero/),& + & a_err='real(psb_spk_)') + goto 9999 + end if + end do if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& @@ -399,7 +412,28 @@ subroutine mld_smlprec_aply(alpha,p,x,beta,y,desc_data,trans,work,info) return contains - + ! + ! + ! inner_ml_aply: apply AMG at a given level. + ! This routine dispatches the computation according to the type + ! specified at the current level. + ! Each of the corrections will inturn call recursively this routine. + ! + ! Assumptions: + ! On input: + ! mlprec_wkr(level)%vx2l contains the input vector (RHS) + ! mlprec_wkr(level)%vy2l contains the initial guess + ! + ! On output: + ! mlprec_wkr(level)%vy2l contains the solution + ! + ! Constraints: each of the called routines must properly handle + ! the input/output conditions for level+1 (i.e. apply + ! prolongation/restriction). + ! Note: for historical/convenience reasons the prolongator/restrictor + ! between level and level+1 are stored at level+1. + ! + ! recursive subroutine inner_ml_aply(level,p,mlprec_wrk,trans,work,info) implicit none @@ -407,24 +441,29 @@ contains ! Arguments integer(psb_ipk_) :: level type(mld_sprec_type), target, intent(inout) :: p - type(mld_mlprec_wrk_type), intent(inout) :: mlprec_wrk(:) + type(mld_mlprec_wrk_type), intent(inout), target :: mlprec_wrk(:) character, intent(in) :: trans - real(psb_spk_),target :: work(:) - integer(psb_ipk_), intent(out) :: info + real(psb_spk_),target :: work(:) + integer(psb_ipk_), intent(out) :: info + type(psb_s_vect_type) :: res + type(psb_s_vect_type), pointer :: current + integer(psb_ipk_) :: sweeps_post, sweeps_pre ! Local variables integer(psb_ipk_) :: ictxt,np,me - integer(psb_ipk_) :: i, nr2l,nc2l,err_act + integer(psb_ipk_) :: i, err_act integer(psb_ipk_) :: debug_level, debug_unit integer(psb_ipk_) :: nlev, ilev, sweeps + logical :: pre, post character(len=20) :: name + + name = 'inner_ml_aply' info = psb_success_ call psb_erractionsave(err_act) debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() - nlev = size(p%precv) if ((level < 1) .or. (level > nlev)) then call psb_errpush(psb_err_internal_error_,name,& @@ -434,18 +473,8 @@ 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() - allocate(mlprec_wrk(level)%x2l(nc2l),& - & mlprec_wrk(level)%y2l(nc2l),& - & stat=info) - if (info /= psb_success_) then - info=psb_err_alloc_request_ - call psb_errpush(info,name,i_err=(/2*nc2l,izero,izero,izero,izero/),& - & a_err='real(psb_spk_)') - goto 9999 - end if + 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) @@ -459,56 +488,9 @@ contains goto 9999 case(mld_add_ml_) - ! - ! Additive multilevel - ! - - if (level > 1) then - ! Apply the restriction - call psb_map_X2Y(sone,mlprec_wrk(level-1)%x2l,& - & szero,mlprec_wrk(level)%x2l,& - & p%precv(level)%map,info,work=work) - - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during restriction') - goto 9999 - end if - - end if - - 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) - - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during smoother_apply') - goto 9999 - end if - if (level < nlev) then - call inner_ml_aply(level+1,p,mlprec_wrk,trans,work,info) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error in recursive call') - goto 9999 - end if - ! - ! Apply the prolongator - ! - call psb_map_Y2X(sone,mlprec_wrk(level+1)%y2l,& - & sone,mlprec_wrk(level)%y2l,& - & 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 + call mld_s_inner_add(p, mlprec_wrk, level, trans, work) - end if case(mld_mult_ml_) ! @@ -521,452 +503,16 @@ contains select case(p%precv(level)%parms%smoother_pos) case(mld_post_smooth_) - - select case (trans_) - case('N') - if (level > 1) then - ! Apply the restriction - call psb_map_X2Y(sone,mlprec_wrk(level-1)%x2l,& - & szero,mlprec_wrk(level)%x2l,& - & p%precv(level)%map,info,work=work) - - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during restriction') - goto 9999 - end if - 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 - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error in recursive call') - goto 9999 - end if - ! - ! Apply the prolongator - ! - call psb_map_Y2X(sone,mlprec_wrk(level+1)%y2l,& - & szero,mlprec_wrk(level)%y2l,& - & 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 - ! - call psb_spmm(-sone,p%precv(level)%base_a,mlprec_wrk(level)%y2l,& - & sone,mlprec_wrk(level)%x2l,p%precv(level)%base_desc,info,& - & work=work,trans=trans) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during residue') - goto 9999 - end if - - sweeps = p%precv(level)%parms%sweeps_post - 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) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during smoother_apply') - goto 9999 - end if - - 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) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during smoother_apply') - goto 9999 - end if - - end if - - case('T','C') - - ! Post-smoothing transpose is pre-smoothing - - - if (level > 1) then - ! Apply the restriction - call psb_map_X2Y(sone,mlprec_wrk(level-1)%x2l,& - & szero,mlprec_wrk(level)%x2l,& - & p%precv(level)%map,info,work=work) - - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during restriction') - goto 9999 - end if - - - end if - - ! - ! Apply the base preconditioner - ! - 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 - - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during smoother_apply') - goto 9999 - end if - - ! - ! Compute the residual (at all levels but the coarsest one) - ! - if (level < nlev) then - call psb_spmm(-sone,p%precv(level)%base_a,& - & mlprec_wrk(level)%y2l,sone,mlprec_wrk(level)%x2l,& - & p%precv(level)%base_desc,info,work=work,trans=trans) - - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during residue') - goto 9999 - end if - - call inner_ml_aply(level+1,p,mlprec_wrk,trans,work,info) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error in recursive call') - goto 9999 - end if - - - call psb_map_Y2X(sone,mlprec_wrk(level+1)%y2l,& - & sone,mlprec_wrk(level)%y2l,& - & 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 - - - end if - - case default - info = psb_err_internal_error_ - call psb_errpush(info,name,a_err='invalid trans') - goto 9999 - end select + p%precv(level)%parms%sweeps_pre = 0 + call mld_s_inner_mult(p, mlprec_wrk, level, trans, work) + case(mld_pre_smooth_) - - select case (trans_) - case('N') - ! One step of pre-smoothing - - - if (level > 1) then - ! Apply the restriction - call psb_map_X2Y(sone,mlprec_wrk(level-1)%x2l,& - & szero,mlprec_wrk(level)%x2l,& - & p%precv(level)%map,info,work=work) - - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during restriction') - goto 9999 - end if - - end if - - ! - ! Apply the base preconditioner - ! - if (level < nlev) then - sweeps = p%precv(level)%parms%sweeps_pre - else - sweeps = p%precv(level)%parms%sweeps - 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,& - & a_err='Error during smoother_apply') - goto 9999 - end if - - ! - ! Compute the residual (at all levels but the coarsest one) - ! - if (level < nlev) then - call psb_spmm(-sone,p%precv(level)%base_a,& - & mlprec_wrk(level)%y2l,sone,mlprec_wrk(level)%x2l,& - & p%precv(level)%base_desc,info,work=work,trans=trans) - if (info /= psb_success_) goto 9999 - call inner_ml_aply(level+1,p,mlprec_wrk,trans,work,info) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error in recursive call') - goto 9999 - end if - - - call psb_map_Y2X(sone,mlprec_wrk(level+1)%y2l,& - & sone,mlprec_wrk(level)%y2l,& - & 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 - - - end if - - - case('T','C') - - ! pre-smooth transpose is post-smoothing - - - if (level > 1) then - ! Apply the restriction - call psb_map_X2Y(sone,mlprec_wrk(level-1)%x2l,& - & szero,mlprec_wrk(level)%x2l,& - & p%precv(level)%map,info,work=work) - - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during restriction') - goto 9999 - end if - - end if - - if (level < nlev) then - call inner_ml_aply(level+1,p,mlprec_wrk,trans,work,info) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error in recursive call') - goto 9999 - end if - - ! - ! Apply the prolongator - ! - call psb_map_Y2X(sone,mlprec_wrk(level+1)%y2l,& - & szero,mlprec_wrk(level)%y2l,& - & 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 - ! - call psb_spmm(-sone,p%precv(level)%base_a,mlprec_wrk(level)%y2l,& - & sone,mlprec_wrk(level)%x2l,p%precv(level)%base_desc,info,& - & work=work,trans=trans) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during residue') - goto 9999 - end if - - - sweeps = p%precv(level)%parms%sweeps_pre - call p%precv(level)%sm%apply(sone,& - & mlprec_wrk(level)%x2l,sone,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,& - & a_err='Error during smoother_apply') - goto 9999 - end if - 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) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during smoother_apply') - goto 9999 - end if - - end if - - case default - info = psb_err_internal_error_ - call psb_errpush(info,name,a_err='invalid trans') - goto 9999 - end select + p%precv(level)%parms%sweeps_post = 0 + call mld_s_inner_mult(p, mlprec_wrk, level, trans, work) 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) - if (info /= psb_success_) then - info=psb_err_alloc_request_ - call psb_errpush(info,name,i_err=(/2*nc2l,izero,izero,izero,izero/),& - & a_err='real(psb_spk_)') - goto 9999 - end if - - if (level > 1) then - ! Apply the restriction - call psb_map_X2Y(sone,mlprec_wrk(level-1)%ty,& - & szero,mlprec_wrk(level)%x2l,& - & p%precv(level)%map,info,work=work) - - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during restriction') - goto 9999 - end if - end if - call psb_geaxpby(sone,mlprec_wrk(level)%x2l,szero,mlprec_wrk(level)%tx,& - & p%precv(level)%base_desc,info) - ! - ! Apply the base preconditioner - ! - if (level < nlev) then - if (trans == 'N') then - sweeps = p%precv(level)%parms%sweeps_pre - else - sweeps = p%precv(level)%parms%sweeps_post - 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(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') - goto 9999 - end if - ! - ! Compute the residual (at all levels but the coarsest one) - ! and call recursively - ! - if(level < nlev) then - mlprec_wrk(level)%ty = mlprec_wrk(level)%x2l - if (info == psb_success_) call psb_spmm(-sone,p%precv(level)%base_a,& - & mlprec_wrk(level)%y2l,sone,mlprec_wrk(level)%ty,& - & p%precv(level)%base_desc,info,work=work,trans=trans) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during residue') - goto 9999 - end if - - call inner_ml_aply(level+1,p,mlprec_wrk,trans,work,info) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error in recursive call') - goto 9999 - end if - - - ! - ! Apply the prolongator - ! - call psb_map_Y2X(sone,mlprec_wrk(level+1)%y2l,& - & sone,mlprec_wrk(level)%y2l,& - & 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 - ! - call psb_spmm(-sone,p%precv(level)%base_a,mlprec_wrk(level)%y2l,& - & sone,mlprec_wrk(level)%tx,p%precv(level)%base_desc,info,& - & work=work,trans=trans) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during residue') - goto 9999 - end if - ! - ! Apply the base preconditioner - ! - if (trans == 'N') then - sweeps = p%precv(level)%parms%sweeps_post - else - sweeps = p%precv(level)%parms%sweeps_pre - end if - 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') - goto 9999 - end if - - endif + call mld_s_inner_mult(p, mlprec_wrk, level, trans, work) case default info = psb_err_from_subroutine_ai_ @@ -976,6 +522,15 @@ contains end select + + case(mld_vcycle_ml_, mld_wcycle_ml_) + + call mld_s_inner_mult(p, mlprec_wrk, level, trans, work) + + case(mld_kcycle_ml_, mld_kcyclesym_ml_) + + call mld_s_inner_k_cycle(p, mlprec_wrk, level, trans, work) + case default info = psb_err_from_subroutine_ai_ call psb_errpush(info,name,a_err='invalid mltype',& @@ -992,293 +547,50 @@ contains end subroutine inner_ml_aply -end subroutine mld_smlprec_aply -subroutine mld_smlprec_aply_vect(alpha,p,x,beta,y,desc_data,trans,work,info) + recursive subroutine mld_s_inner_add(p, mlprec_wrk, level, trans, work) + use psb_base_mod + use mld_prec_mod - use psb_base_mod - use mld_s_inner_mod, mld_protect_name => mld_smlprec_aply_vect + implicit none - implicit none + !Input/Oputput variables + type(mld_sprec_type), intent(inout) :: p - ! Arguments - type(psb_desc_type),intent(in) :: desc_data - type(mld_sprec_type), intent(inout) :: p - real(psb_spk_),intent(in) :: alpha,beta - type(psb_s_vect_type),intent(inout) :: x - type(psb_s_vect_type),intent(inout) :: y - character, intent(in) :: trans - real(psb_spk_),target :: work(:) - integer(psb_ipk_), intent(out) :: info + type(mld_mlprec_wrk_type), target, intent(inout) :: mlprec_wrk(:) + integer(psb_ipk_), intent(in) :: level + character, intent(in) :: trans + real(psb_spk_),target :: work(:) + type(psb_s_vect_type) :: res + type(psb_s_vect_type), pointer :: current + integer(psb_ipk_) :: sweeps_post, sweeps_pre + ! Local variables + integer(psb_ipk_) :: ictxt,np,me + integer(psb_ipk_) :: i, err_act + integer(psb_ipk_) :: debug_level, debug_unit + integer(psb_ipk_) :: nlev, ilev, sweeps + logical :: pre, post + character(len=20) :: name - ! Local variables - integer(psb_ipk_) :: ictxt, np, me - integer(psb_ipk_) :: debug_level, debug_unit, nlev,nc2l,nr2l,level, err_act - character(len=20) :: name - character :: trans_ - real(psb_spk_) :: par - type mld_mlprec_wrk_type - real(psb_spk_), allocatable :: tx(:), ty(:), x2l(:), y2l(:) - type(psb_s_vect_type) :: vtx, vty, vx2l, vy2l - end type mld_mlprec_wrk_type - type(mld_mlprec_wrk_type), allocatable, target :: mlprec_wrk(:) - name='mld_smlprec_aply' - info = psb_success_ - call psb_erractionsave(err_act) - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - ictxt = desc_data%get_context() - call psb_info(ictxt, me, np) + name = 'inner_inner_add' + info = psb_success_ + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + nlev = size(p%precv) + if ((level < 1) .or. (level > nlev)) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='wrong call level to inner_add') + goto 9999 + end if + ictxt = p%precv(level)%base_desc%get_context() + call psb_info(ictxt, me, np) - if (debug_level >= psb_debug_inner_) & - & write(debug_unit,*) me,' ',trim(name),& - & ' Entry ', size(p%precv) - - trans_ = psb_toupper(trans) - nlev = size(p%precv) - allocate(mlprec_wrk(nlev),stat=info) - if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') - goto 9999 - end if - level = 1 - do level = 1, nlev - call psb_geasb(mlprec_wrk(level)%vx2l,& - & p%precv(level)%base_desc,info,& - & scratch=.true.,mold=x%v) - call psb_geasb(mlprec_wrk(level)%vy2l,& - & p%precv(level)%base_desc,info,& - & scratch=.true.,mold=x%v) - call psb_geasb(mlprec_wrk(level)%vtx,& - & p%precv(level)%base_desc,info,& - & scratch=.true.,mold=x%v) - call psb_geasb(mlprec_wrk(level)%vty,& - & p%precv(level)%base_desc,info,& - & scratch=.true.,mold=x%v) - if (psb_errstatus_fatal()) then - nc2l = p%precv(level)%base_desc%get_local_cols() - info=psb_err_alloc_request_ - call psb_errpush(info,name,i_err=(/2*nc2l,izero,izero,izero,izero/),& - & a_err='real(psb_spk_)') - goto 9999 - end if - end do - level = 1 - - call psb_geaxpby(sone,x,szero,mlprec_wrk(level)%vx2l,p%precv(level)%base_desc,info) - call mlprec_wrk(level)%vy2l%zero() - - - call inner_ml_aply(level,p,mlprec_wrk,trans_,work,info) - - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Inner prec aply') - goto 9999 - end if - - call psb_geaxpby(alpha,mlprec_wrk(level)%vy2l,beta,y,& - & p%precv(level)%base_desc,info) - do level = 1, nlev - - call mlprec_wrk(level)%vx2l%free(info) - call mlprec_wrk(level)%vy2l%free(info) - call mlprec_wrk(level)%vtx%free(info) - call mlprec_wrk(level)%vty%free(info) - if (psb_errstatus_fatal()) then - info=psb_err_alloc_request_ - nc2l = p%precv(level)%base_desc%get_local_cols() - call psb_errpush(info,name,i_err=(/2*nc2l,izero,izero,izero,izero/),& - & a_err='real(psb_spk_)') - goto 9999 - end if - end do - - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error final update') - goto 9999 - end if - - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - -contains - - recursive subroutine inner_ml_aply(level,p,mlprec_wrk,trans,work,info, U) - - implicit none - - ! Arguments - integer(psb_ipk_) :: level - type(mld_sprec_type), target, intent(inout) :: p - type(mld_mlprec_wrk_type), intent(inout), target :: mlprec_wrk(:) - character, intent(in) :: trans - real(psb_spk_),target :: work(:) - integer(psb_ipk_), intent(out) :: info - type(psb_s_vect_type),intent(inout), optional :: u - - type(psb_s_vect_type) :: res - type(psb_s_vect_type), pointer :: current - integer(psb_ipk_) :: sweeps_post, sweeps_pre - ! Local variables - integer(psb_ipk_) :: ictxt,np,me - integer(psb_ipk_) :: i, nr2l,nc2l,err_act - integer(psb_ipk_) :: debug_level, debug_unit - integer(psb_ipk_) :: nlev, ilev, sweeps - logical :: pre, post - character(len=20) :: name - - - - name = 'inner_ml_aply' - info = psb_success_ - call psb_erractionsave(err_act) - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - nlev = size(p%precv) - if ((level < 1) .or. (level > nlev)) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='wrong call level to inner_ml') - goto 9999 - end if - ictxt = p%precv(level)%base_desc%get_context() - call psb_info(ictxt, me, np) - - 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) - - case(mld_no_ml_) - ! - ! No preconditioning, should not really get here - ! - call psb_errpush(psb_err_internal_error_,name,& - & a_err='mld_no_ml_ in mlprc_aply?') - goto 9999 - - case(mld_add_ml_) - - call mld_s_inner_add(p, mlprec_wrk, level, trans, work) - - - case(mld_mult_ml_) - ! - ! Multiplicative multilevel (multiplicative among the levels, additive inside - ! each level) - ! - ! Pre/post-smoothing versions. - ! Note that the transpose switches pre <-> post. - ! - select case(p%precv(level)%parms%smoother_pos) - - case(mld_post_smooth_) - p%precv(level)%parms%sweeps_pre = 0 - call mld_s_inner_mult(p, mlprec_wrk, level, trans, work) - - - case(mld_pre_smooth_) - p%precv(level)%parms%sweeps_post = 0 - call mld_s_inner_mult(p, mlprec_wrk, level, trans, work) - - case(mld_twoside_smooth_) - call mld_s_inner_mult(p, mlprec_wrk, level, trans, work) - - case default - info = psb_err_from_subroutine_ai_ - call psb_errpush(info,name,a_err='invalid smooth_pos',& - & i_Err=(/p%precv(level)%parms%smoother_pos,izero,izero,izero,izero/)) - goto 9999 - - end select - - - case(mld_mult_dev_ml_) - - call mld_s_inner_mult(p, mlprec_wrk, level, trans, work) - - - case(mld_vcycle_ml_, mld_wcycle_ml_) - - call mld_s_inner_vw_cycle(p, mlprec_wrk, level, trans, work, u=u) - - case(mld_kcycle_ml_, mld_kcyclesym_ml_) - - call mld_s_inner_k_cycle(p, mlprec_wrk, level, trans, work, u=u) - - case default - info = psb_err_from_subroutine_ai_ - call psb_errpush(info,name,a_err='invalid mltype',& - & i_Err=(/p%precv(level)%parms%ml_type,izero,izero,izero,izero/)) - goto 9999 - - end select - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - return - - end subroutine inner_ml_aply - - - recursive subroutine mld_s_inner_add(p, mlprec_wrk, level, trans, work) - use psb_base_mod - use mld_prec_mod - - implicit none - - !Input/Oputput variables - type(mld_sprec_type), intent(inout) :: p - - type(mld_mlprec_wrk_type), target, intent(inout) :: mlprec_wrk(:) - integer(psb_ipk_), intent(in) :: level - character, intent(in) :: trans - real(psb_spk_),target :: work(:) - type(psb_s_vect_type) :: res - type(psb_s_vect_type), pointer :: current - integer(psb_ipk_) :: sweeps_post, sweeps_pre - ! Local variables - integer(psb_ipk_) :: ictxt,np,me - integer(psb_ipk_) :: i, nr2l,nc2l,err_act - integer(psb_ipk_) :: debug_level, debug_unit - integer(psb_ipk_) :: nlev, ilev, sweeps - logical :: pre, post - character(len=20) :: name - - - - name = 'inner_inner_add' - info = psb_success_ - call psb_erractionsave(err_act) - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - nlev = size(p%precv) - if ((level < 1) .or. (level > nlev)) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='wrong call level to inner_add') - goto 9999 - end if - ictxt = p%precv(level)%base_desc%get_context() - call psb_info(ictxt, me, np) - - 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_add at level ',level - end if + if(debug_level > 1) then + write(debug_unit,*) me,' inner_add at level ',level + end if if ((level<1).or.(level>nlev)) then info = psb_err_internal_error_ @@ -1287,21 +599,6 @@ contains goto 9999 end if - - if (level > 1) then - ! Apply the restriction - call psb_map_X2Y(sone,mlprec_wrk(level-1)%vx2l,& - & szero,mlprec_wrk(level)%vx2l,& - & p%precv(level)%map,info,work=work) - - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during restriction') - goto 9999 - end if - - end if - sweeps = p%precv(level)%parms%sweeps call p%precv(level)%sm%apply(sone,& & mlprec_wrk(level)%vx2l,szero,mlprec_wrk(level)%vy2l,& @@ -1314,6 +611,17 @@ contains end if if (level < nlev) then + ! Apply the restriction + call psb_map_X2Y(sone,mlprec_wrk(level)%vx2l,& + & szero,mlprec_wrk(level+1)%vx2l,& + & p%precv(level+1)%map,info,work=work) + call mlprec_wrk(level+1)%vy2l%zero() + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Error during restriction') + goto 9999 + end if + call inner_ml_aply(level+1,p,mlprec_wrk,trans,work,info) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& @@ -1362,7 +670,7 @@ contains integer(psb_ipk_) :: sweeps_post, sweeps_pre ! Local variables integer(psb_ipk_) :: ictxt,np,me - integer(psb_ipk_) :: i, nr2l,nc2l,err_act + integer(psb_ipk_) :: i, err_act integer(psb_ipk_) :: debug_level, debug_unit integer(psb_ipk_) :: nlev, ilev, sweeps logical :: pre, post @@ -1384,13 +692,10 @@ contains ictxt = p%precv(level)%base_desc%get_context() call psb_info(ictxt, me, np) - 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_mult at level ',level end if - if ((level < nlev).or.(nlev == 1)) then sweeps_post = p%precv(level)%parms%sweeps_post sweeps_pre = p%precv(level)%parms%sweeps_pre @@ -1402,49 +707,31 @@ contains pre = ((sweeps_pre>0).and.(trans=='N')).or.((sweeps_post>0).and.(trans/='N')) post = ((sweeps_post>0).and.(trans=='N')).or.((sweeps_pre>0).and.(trans/='N')) + + if (level < nlev) then + + ! + ! Apply the first smoother + ! - if (level > 1) then - ! Apply the restriction - if (pre) then - current => mlprec_wrk(level-1)%vty - else - current => mlprec_wrk(level-1)%vx2l - endif - call psb_map_X2Y(sone,current,& - & szero,mlprec_wrk(level)%vx2l,& - & p%precv(level)%map,info,work=work) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during restriction') - goto 9999 - end if - end if - - - if (level < nlev) then - - ! - ! Apply the base preconditioner - ! - if (pre) then if (trans == 'N') then sweeps = p%precv(level)%parms%sweeps_pre if (info == psb_success_) call p%precv(level)%sm%apply(sone,& & mlprec_wrk(level)%vx2l,szero,mlprec_wrk(level)%vy2l,& & p%precv(level)%base_desc, trans,& - & sweeps,work,info) + & sweeps,work,info,init='Y') 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) + & sweeps,work,info,init='Y') end if if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during 2-PRE smoother_apply') + & a_err='Error during PRE smoother_apply') goto 9999 end if endif @@ -1465,9 +752,36 @@ contains & a_err='Error during residue') goto 9999 end if + call psb_map_X2Y(sone,mlprec_wrk(level)%vty,& + & szero,mlprec_wrk(level+1)%vx2l,& + & 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 restriction') + goto 9999 + end if + else + ! Shortcut: just transfer x2l. + call psb_map_X2Y(sone,mlprec_wrk(level)%vx2l,& + & szero,mlprec_wrk(level+1)%vx2l,& + & 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 restriction') + goto 9999 + end if endif + ! First guess is zero + call mlprec_wrk(level+1)%vy2l%zero() + call inner_ml_aply(level+1,p,mlprec_wrk,trans,work,info) + + if (p%precv(level)%parms%ml_type == mld_wcycle_ml_) then + ! On second call will use output y2l as initial guess + if (info == psb_success_) call inner_ml_aply(level+1,p,mlprec_wrk,trans,work,info) + endif + if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& & a_err='Error in recursive call') @@ -1478,15 +792,8 @@ contains ! ! Apply the prolongator ! - - if (pre) then - par = sone - else - par = szero - endif - call psb_map_Y2X(sone,mlprec_wrk(level+1)%vy2l,& - & par,mlprec_wrk(level)%vy2l,& + & sone,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,& @@ -1510,27 +817,28 @@ contains goto 9999 end if ! - ! Apply the base preconditioner + ! Apply the second smoother ! if (trans == 'N') then sweeps = p%precv(level)%parms%sweeps_post if (info == psb_success_) call p%precv(level)%sm2%apply(sone,& & mlprec_wrk(level)%vtx,sone,mlprec_wrk(level)%vy2l,& & p%precv(level)%base_desc, trans,& - & sweeps,work,info) + & sweeps,work,info,init='Y') 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) + & sweeps,work,info,init='Y') end if if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during 2-POST smoother_apply') + & a_err='Error during POST smoother_apply') goto 9999 end if + endif else if (level == nlev) then @@ -1545,7 +853,7 @@ contains info = psb_err_internal_error_ call psb_errpush(info,name,& - & a_err='Invalid LEVEL>NLEV') + & a_err='Invalid LEVEL vs NLEV') goto 9999 end if @@ -1557,7 +865,7 @@ contains end subroutine mld_s_inner_mult - recursive subroutine mld_s_inner_vw_cycle(p, mlprec_wrk, level, trans, work,u) + recursive subroutine mld_s_inner_k_cycle(p, mlprec_wrk, level, trans, work,u) use psb_base_mod use mld_prec_mod @@ -1578,7 +886,7 @@ contains integer(psb_ipk_) :: sweeps_post, sweeps_pre ! Local variables integer(psb_ipk_) :: ictxt,np,me - integer(psb_ipk_) :: i, nr2l,nc2l,err_act + integer(psb_ipk_) :: i, err_act integer(psb_ipk_) :: debug_level, debug_unit integer(psb_ipk_) :: nlev, ilev, sweeps logical :: pre, post @@ -1600,8 +908,6 @@ contains ictxt = p%precv(level)%base_desc%get_context() call psb_info(ictxt, me, np) - 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_add at level ',level end if @@ -1612,90 +918,50 @@ contains & a_err='Invalid LEVEL>NLEV') goto 9999 end if - call psb_geasb(res,p%precv(level)%base_desc,info,& - & scratch=.true., mold=mlprec_wrk(level)%vx2l%v) - - !V/W cycle - if (level > 1) then - ! Apply the restriction - call psb_map_X2Y(sone,mlprec_wrk(level-1)%vty,& - & szero,mlprec_wrk(level)%vx2l,& - & p%precv(level)%map,info,work=work) - - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during restriction') - goto 9999 - end if - end if - - call psb_geaxpby(sone,mlprec_wrk(level)%vx2l,& - & szero,mlprec_wrk(level)%vtx,& - & p%precv(level)%base_desc,info) - ! - ! Apply the base preconditioner - ! - if (level < nlev) then - - if (present(u)) then - ! call mlprec_wrk(level)%vy2l%set(u%get_vect()) - call psb_geaxpby(sone,u,& - & szero,mlprec_wrk(level)%vy2l,& - & p%precv(level)%base_desc,info) - - else - call mlprec_wrk(level)%vy2l%zero() - endif - call psb_geaxpby(sone,mlprec_wrk(level)%vx2l,szero,res,& - & p%precv(level)%base_desc,info) - - call psb_spmm(-sone,p%precv(level)%base_a,mlprec_wrk(level)%vy2l,& - sone, res, p%precv(level)%base_desc, info, work=work, trans=trans) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during residue') - goto 9999 - end if + !K cycle + + if (level == nlev) then + ! + ! Apply smoother + ! + 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,init='Y') + + else 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) + & sweeps,work,info,init='Y') 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) + & sweeps,work,info,init='Y') 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_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during 2-PRE smoother_apply') - goto 9999 - end if + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,& + & 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 - ! - if(level < nlev) then + ! + ! Compute the residual and call recursively + ! call psb_geaxpby(sone,mlprec_wrk(level)%vx2l,& & szero,mlprec_wrk(level)%vty,& & p%precv(level)%base_desc,info) - + if (info == psb_success_) call psb_spmm(-sone,p%precv(level)%base_a,& & mlprec_wrk(level)%vy2l,sone,mlprec_wrk(level)%vty,& & p%precv(level)%base_desc,info,work=work,trans=trans) @@ -1705,10 +971,27 @@ contains goto 9999 end if - call inner_ml_aply(level+1,p,mlprec_wrk,trans,work,info) + ! Apply the restriction + call psb_map_X2Y(sone,mlprec_wrk(level)%vty,& + & szero,mlprec_wrk(level + 1)%vx2l,& + & p%precv(level + 1)%map,info,work=work) + call mlprec_wrk(level + 1)%vy2l%zero() + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Error during restriction') + goto 9999 + end if - if (p%precv(level)%parms%ml_type == mld_wcycle_ml_) then - call inner_ml_aply(level+1,p,mlprec_wrk,trans,work,info, u=mlprec_wrk(level+1)%vy2l) + !Set the preconditioner + + if ((level < nlev - 2)) then + if (p%precv(level)%parms%ml_type == mld_kcyclesym_ml_) then + call mld_sinneritkcycle(p, mlprec_wrk, level + 1, trans, work, 'FCG') + elseif (p%precv(level)%parms%ml_type == mld_kcycle_ml_) then + call mld_sinneritkcycle(p, mlprec_wrk, level + 1, trans, work, 'CGR') + endif + else + call inner_ml_aply(level + 1 ,p,mlprec_wrk,trans,work,info) endif if (info /= psb_success_) then @@ -1717,7 +1000,6 @@ contains goto 9999 end if - ! ! Apply the prolongator ! @@ -1734,8 +1016,11 @@ contains ! ! Compute the residual ! + call psb_geaxpby(sone,mlprec_wrk(level)%vx2l,& + & szero,mlprec_wrk(level)%vty,& + & p%precv(level)%base_desc,info) call psb_spmm(-sone,p%precv(level)%base_a,mlprec_wrk(level)%vy2l,& - & sone,mlprec_wrk(level)%vtx,p%precv(level)%base_desc,info,& + & sone,mlprec_wrk(level)%vty,p%precv(level)%base_desc,info,& & work=work,trans=trans) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& @@ -1743,341 +1028,127 @@ contains goto 9999 end if ! - ! Apply the base preconditioner + ! Apply the smoother ! 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,& + & mlprec_wrk(level)%vty,sone,mlprec_wrk(level)%vy2l,& & p%precv(level)%base_desc, trans,& - & sweeps,work,info) + & sweeps,work,info,init='Y') 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,& + & mlprec_wrk(level)%vty,sone,mlprec_wrk(level)%vy2l,& & p%precv(level)%base_desc, trans,& - & sweeps,work,info) + & sweeps,work,info,init='Y') end if if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during 2-POST smoother_apply') + & a_err='Error during POST smoother_apply') goto 9999 end if + else + info = psb_err_internal_error_ + call psb_errpush(info,name,& + & a_err='Invalid LEVEL vs NLEV') + goto 9999 + endif - call psb_erractionrestore(err_act) return 9999 call psb_error_handler(err_act) return - end subroutine mld_s_inner_vw_cycle + end subroutine mld_s_inner_k_cycle - recursive subroutine mld_s_inner_k_cycle(p, mlprec_wrk, level, trans, work,u) + + recursive subroutine mld_sinneritkcycle(p, mlprec_wrk, level, trans, work, innersolv) use psb_base_mod use mld_prec_mod + use mld_s_inner_mod, mld_protect_name => mld_smlprec_aply implicit none !Input/Oputput variables type(mld_sprec_type), intent(inout) :: p - type(mld_mlprec_wrk_type), target, intent(inout) :: mlprec_wrk(:) + + type(mld_mlprec_wrk_type), intent(inout) :: mlprec_wrk(:) integer(psb_ipk_), intent(in) :: level - character, intent(in) :: trans + character, intent(in) :: trans, innersolv real(psb_spk_),target :: work(:) - type(psb_s_vect_type),intent(inout), optional :: u + !Other variables + type(psb_s_vect_type) :: v, w, rhs, v1, x + type(psb_s_vect_type), dimension(0:1) :: d + real(psb_spk_) :: delta_old, rhs_norm, alpha, tau, tau1, tau2, tau3, tau4, beta + real(psb_spk_) :: l2_norm, delta, rtol=0.25 + real(psb_spk_), allocatable :: temp_v(:) + integer(psb_ipk_) :: info, nlev, i, iter, max_iter=2, idx - type(psb_s_vect_type) :: res - type(psb_s_vect_type), pointer :: current - integer(psb_ipk_) :: sweeps_post, sweeps_pre - ! Local variables - integer(psb_ipk_) :: ictxt,np,me - integer(psb_ipk_) :: i, nr2l,nc2l,err_act - integer(psb_ipk_) :: debug_level, debug_unit - integer(psb_ipk_) :: nlev, ilev, sweeps - logical :: pre, post - character(len=20) :: name + !Assemble rhs, w, v, v1, x + call psb_geasb(rhs,& + & p%precv(level)%base_desc,info,& + & scratch=.true.,mold=mlprec_wrk(level)%vx2l%v) + call psb_geasb(w,& + & p%precv(level)%base_desc,info,& + & scratch=.true.,mold=mlprec_wrk(level)%vx2l%v) + call psb_geasb(v,& + & p%precv(level)%base_desc,info,& + & scratch=.true.,mold=mlprec_wrk(level)%vx2l%v) + call psb_geasb(v1,& + & p%precv(level)%base_desc,info,& + & scratch=.true.,mold=mlprec_wrk(level)%vx2l%v) + call psb_geasb(x,& + & p%precv(level)%base_desc,info,& + & scratch=.true.,mold=mlprec_wrk(level)%vx2l%v) + call x%zero() - name = 'inner_inner_add' - info = psb_success_ - call psb_erractionsave(err_act) - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - nlev = size(p%precv) - if ((level < 1) .or. (level > nlev)) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='wrong call level to inner_add') - goto 9999 - end if - ictxt = p%precv(level)%base_desc%get_context() - call psb_info(ictxt, me, np) + ! rhs=vx2l and w=rhs + call psb_geaxpby(sone,mlprec_wrk(level)%vx2l,szero,rhs,& + & p%precv(level)%base_desc,info) + call psb_geaxpby(sone,mlprec_wrk(level)%vx2l,szero,w,& + & p%precv(level)%base_desc,info) - 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_add at level ',level + if (psb_errstatus_fatal()) then + nc2l = p%precv(level)%base_desc%get_local_cols() + info=psb_err_alloc_request_ + call psb_errpush(info,name,i_err=(/2*nc2l,izero,izero,izero,izero/),& + & a_err='TYPE@(psb_spk_)') + goto 9999 end if - if ((level<1).or.(level>nlev)) then - info = psb_err_internal_error_ - call psb_errpush(info,name,& - & a_err='Invalid LEVEL>NLEV') - goto 9999 - end if + delta = psb_gedot(w, w, p%precv(level)%base_desc, info) - !K cycle + !Apply the preconditioner - call psb_geaxpby(sone,mlprec_wrk(level)%vx2l,& - & szero,mlprec_wrk(level)%vtx,& - & p%precv(level)%base_desc,info) - ! - ! Apply the base preconditioner - ! - if (level < nlev) then + call mlprec_wrk(level)%vy2l%set(szero) - if (present(u)) then - call psb_geaxpby(sone,u,& - & szero,mlprec_wrk(level)%vy2l,& - & p%precv(level)%base_desc,info) - else - call mlprec_wrk(level)%vy2l%zero() - endif - res = mlprec_wrk(level)%vx2l + idx=0 + call inner_ml_aply(level,p,mlprec_wrk,trans,work,info) - call psb_spmm(-sone,p%precv(level)%base_a,mlprec_wrk(level)%vy2l,& - sone, res, p%precv(level)%base_desc, info, work=work, trans=trans) + !Assemble d(0) and d(1) + call psb_geasb(d(0),& + & p%precv(level)%base_desc,info,& + & scratch=.true.,mold=mlprec_wrk(level)%vy2l%v) + call psb_geasb(d(1),& + & p%precv(level)%base_desc,info,& + & scratch=.true.,mold=mlprec_wrk(level)%vy2l%v) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during residue') - goto 9999 - end if + call psb_geaxpby(sone,mlprec_wrk(level)%vy2l,szero,d(idx),p%precv(level)%base_desc,info) - 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 + call psb_spmm(sone,p%precv(level)%base_a,d(idx),szero,v,p%precv(level)%base_desc,info) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& - & 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 - ! - if(level < nlev) then - - call psb_geaxpby(sone,mlprec_wrk(level)%vx2l,& - & szero,mlprec_wrk(level)%vty,& - & p%precv(level)%base_desc,info) - - if (info == psb_success_) call psb_spmm(-sone,p%precv(level)%base_a,& - & mlprec_wrk(level)%vy2l,sone,mlprec_wrk(level)%vty,& - & p%precv(level)%base_desc,info,work=work,trans=trans) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during residue') - goto 9999 - end if - - ! Apply the restriction - call psb_map_X2Y(sone,mlprec_wrk(level)%vty,& - & szero,mlprec_wrk(level + 1)%vx2l,& - & 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 restriction') - goto 9999 - end if - - !Set the preconditioner - - - if ((level < nlev - 2)) then - if (p%precv(level)%parms%ml_type == mld_kcyclesym_ml_) then - call mld_sinneritkcycle(p, mlprec_wrk, level + 1, trans, work, 'FCG') - elseif (p%precv(level)%parms%ml_type == mld_kcycle_ml_) then - call mld_sinneritkcycle(p, mlprec_wrk, level + 1, trans, work, 'CGR') - endif - else - call inner_ml_aply(level + 1 ,p,mlprec_wrk,trans,work,info) - endif - - - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error in recursive call') - goto 9999 - end if - - - ! - ! Apply the prolongator - ! - call psb_map_Y2X(sone,mlprec_wrk(level+1)%vy2l,& - & sone,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 - ! - call psb_spmm(-sone,p%precv(level)%base_a,mlprec_wrk(level)%vy2l,& - & sone,mlprec_wrk(level)%vtx,p%precv(level)%base_desc,info,& - & work=work,trans=trans) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during residue') - goto 9999 - end if - ! - ! Apply the base preconditioner - ! - 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_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during 2-POST smoother_apply') - goto 9999 - end if - - endif - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - return - - end subroutine mld_s_inner_k_cycle - - - recursive subroutine mld_sinneritkcycle(p, mlprec_wrk, level, trans, work, innersolv) - use psb_base_mod - use mld_prec_mod - use mld_s_inner_mod, mld_protect_name => mld_smlprec_aply - - implicit none - - !Input/Oputput variables - type(mld_sprec_type), intent(inout) :: p - - type(mld_mlprec_wrk_type), intent(inout) :: mlprec_wrk(:) - integer(psb_ipk_), intent(in) :: level - character, intent(in) :: trans, innersolv - real(psb_spk_),target :: work(:) - - !Other variables - type(psb_s_vect_type) :: v, w, rhs, v1, x - type(psb_s_vect_type), dimension(0:1) :: d - real(psb_spk_) :: delta_old, rhs_norm, alpha, tau, tau1, tau2, tau3, tau4, beta - - real(psb_spk_) :: l2_norm, delta, rtol=0.25 - real(psb_spk_), allocatable :: temp_v(:) - integer(psb_ipk_) :: info, nlev, i, iter, max_iter=2, idx - - !Assemble rhs, w, v, v1, x - - call psb_geasb(rhs,& - & p%precv(level)%base_desc,info,& - & scratch=.true.,mold=mlprec_wrk(level)%vx2l%v) - call psb_geasb(w,& - & p%precv(level)%base_desc,info,& - & scratch=.true.,mold=mlprec_wrk(level)%vx2l%v) - call psb_geasb(v,& - & p%precv(level)%base_desc,info,& - & scratch=.true.,mold=mlprec_wrk(level)%vx2l%v) - call psb_geasb(v1,& - & p%precv(level)%base_desc,info,& - & scratch=.true.,mold=mlprec_wrk(level)%vx2l%v) - call psb_geasb(x,& - & p%precv(level)%base_desc,info,& - & scratch=.true.,mold=mlprec_wrk(level)%vx2l%v) - - call x%set(szero) - - ! rhs=vx2l and w=rhs - call psb_geaxpby(sone,mlprec_wrk(level)%vx2l,szero,rhs,& - & p%precv(level)%base_desc,info) - call psb_geaxpby(sone,mlprec_wrk(level)%vx2l,szero,w,& - & p%precv(level)%base_desc,info) - - if (psb_errstatus_fatal()) then - nc2l = p%precv(level)%base_desc%get_local_cols() - info=psb_err_alloc_request_ - call psb_errpush(info,name,i_err=(/2*nc2l,izero,izero,izero,izero/),& - & a_err='TYPE@(psb_spk_)') - goto 9999 - end if - - delta = psb_gedot(w, w, p%precv(level)%base_desc, info) - - !Apply the preconditioner - - call mlprec_wrk(level)%vy2l%set(szero) - - idx=0 - call inner_ml_aply(level,p,mlprec_wrk,trans,work,info) - - !Assemble d(0) and d(1) - call psb_geasb(d(0),& - & p%precv(level)%base_desc,info,& - & scratch=.true.,mold=mlprec_wrk(level)%vy2l%v) - call psb_geasb(d(1),& - & p%precv(level)%base_desc,info,& - & scratch=.true.,mold=mlprec_wrk(level)%vy2l%v) - - call psb_geaxpby(sone,mlprec_wrk(level)%vy2l,szero,d(idx),p%precv(level)%base_desc,info) - - - call psb_spmm(sone,p%precv(level)%base_a,d(idx),szero,v,p%precv(level)%base_desc,info) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during residue') + & a_err='Error during residue') goto 9999 end if @@ -2162,3 +1233,565 @@ contains end subroutine mld_smlprec_aply_vect + + + + +! +! Old routine for arrays instead of psb_X_vector. To be deleted eventually. +! +! +subroutine mld_smlprec_aply(alpha,p,x,beta,y,desc_data,trans,work,info) + + use psb_base_mod + use mld_s_inner_mod, mld_protect_name => mld_smlprec_aply + + implicit none + + ! Arguments + type(psb_desc_type),intent(in) :: desc_data + type(mld_sprec_type), intent(inout) :: p + real(psb_spk_),intent(in) :: alpha,beta + real(psb_spk_),intent(inout) :: x(:) + real(psb_spk_),intent(inout) :: y(:) + character, intent(in) :: trans + real(psb_spk_),target :: work(:) + integer(psb_ipk_), intent(out) :: info + + ! Local variables + integer(psb_ipk_) :: ictxt, np, me + integer(psb_ipk_) :: err_act + integer(psb_ipk_) :: debug_level, debug_unit, nlev,nc2l,nr2l,level + character(len=20) :: name + character :: trans_ + type mld_mlprec_wrk_type + real(psb_spk_), allocatable :: tx(:), ty(:), x2l(:), y2l(:) + end type mld_mlprec_wrk_type + type(mld_mlprec_wrk_type), allocatable, target :: mlprec_wrk(:) + + name='mld_smlprec_aply' + info = psb_success_ + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + ictxt = desc_data%get_context() + call psb_info(ictxt, me, np) + + if (debug_level >= psb_debug_inner_) & + & write(debug_unit,*) me,' ',trim(name),& + & ' Entry ', size(p%precv) + + trans_ = psb_toupper(trans) + + nlev = size(p%precv) + allocate(mlprec_wrk(nlev),stat=info) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') + goto 9999 + end if + level = 1 + + do level = 1, nlev + call psb_geasb(mlprec_wrk(level)%x2l,& + & p%precv(level)%base_desc,info) + call psb_geasb(mlprec_wrk(level)%y2l,& + & p%precv(level)%base_desc,info) + call psb_geasb(mlprec_wrk(level)%tx,& + & p%precv(level)%base_desc,info) + call psb_geasb(mlprec_wrk(level)%ty,& + & p%precv(level)%base_desc,info) + if (psb_errstatus_fatal()) then + nc2l = p%precv(level)%base_desc%get_local_cols() + info=psb_err_alloc_request_ + call psb_errpush(info,name,i_err=(/2*nc2l,izero,izero,izero,izero/),& + & a_err='real(psb_spk_)') + goto 9999 + end if + end do + + mlprec_wrk(level)%x2l(:) = x(:) + mlprec_wrk(level)%y2l(:) = szero + + call inner_ml_aply(level,p,mlprec_wrk,trans_,work,info) + + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Inner prec aply') + goto 9999 + end if + + call psb_geaxpby(alpha,mlprec_wrk(level)%y2l,beta,y,& + & p%precv(level)%base_desc,info) + + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Error final update') + goto 9999 + end if + + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +contains + + ! + ! + ! inner_ml_aply: apply AMG at a given level. + ! This routine dispatches the computation according to the type + ! specified at the current level. + ! Each of the corrections will inturn call recursively this routine. + ! + ! Assumptions: + ! On input: + ! mlprec_wkr(level)%vx2l contains the input vector (RHS) + ! mlprec_wkr(level)%vy2l contains the initial guess + ! + ! On output: + ! mlprec_wkr(level)%vy2l contains the solution + ! + ! Constraints: each of the called routines must properly handle + ! the input/output conditions for level+1 (i.e. apply + ! prolongation/restriction). + ! Note: for historical/convenience reasons the prolongator/restrictor + ! between level and level+1 are stored at level+1. + ! + ! + recursive subroutine inner_ml_aply(level,p,mlprec_wrk,trans,work,info) + + implicit none + + ! Arguments + integer(psb_ipk_) :: level + type(mld_sprec_type), target, intent(inout) :: p + type(mld_mlprec_wrk_type), intent(inout), target :: mlprec_wrk(:) + character, intent(in) :: trans + real(psb_spk_),target :: work(:) + integer(psb_ipk_), intent(out) :: info + + type(psb_s_vect_type) :: res + type(psb_s_vect_type), pointer :: current + integer(psb_ipk_) :: sweeps_post, sweeps_pre + ! Local variables + integer(psb_ipk_) :: ictxt,np,me + integer(psb_ipk_) :: i, err_act + integer(psb_ipk_) :: debug_level, debug_unit + integer(psb_ipk_) :: nlev, ilev, sweeps + logical :: pre, post + character(len=20) :: name + + + + name = 'inner_ml_aply' + info = psb_success_ + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + nlev = size(p%precv) + if ((level < 1) .or. (level > nlev)) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='wrong call level to inner_ml') + goto 9999 + end if + ictxt = p%precv(level)%base_desc%get_context() + call psb_info(ictxt, me, np) + + if(debug_level > 1) then + write(debug_unit,*) me,' inner_ml_aply at level ',level + end if + + select case(p%precv(level)%parms%ml_type) + + case(mld_no_ml_) + ! + ! No preconditioning, should not really get here + ! + call psb_errpush(psb_err_internal_error_,name,& + & a_err='mld_no_ml_ in mlprc_aply?') + goto 9999 + + case(mld_add_ml_) + + call mld_s_inner_add(p, mlprec_wrk, level, trans, work) + + + case(mld_mult_ml_) + ! + ! Multiplicative multilevel (multiplicative among the levels, additive inside + ! each level) + ! + ! Pre/post-smoothing versions. + ! Note that the transpose switches pre <-> post. + ! + select case(p%precv(level)%parms%smoother_pos) + + case(mld_post_smooth_) + p%precv(level)%parms%sweeps_pre = 0 + call mld_s_inner_mult(p, mlprec_wrk, level, trans, work) + + + case(mld_pre_smooth_) + p%precv(level)%parms%sweeps_post = 0 + call mld_s_inner_mult(p, mlprec_wrk, level, trans, work) + + case(mld_twoside_smooth_) + call mld_s_inner_mult(p, mlprec_wrk, level, trans, work) + + case default + info = psb_err_from_subroutine_ai_ + call psb_errpush(info,name,a_err='invalid smooth_pos',& + & i_Err=(/p%precv(level)%parms%smoother_pos,izero,izero,izero,izero/)) + goto 9999 + + end select + + + case(mld_vcycle_ml_, mld_wcycle_ml_) + + call mld_s_inner_mult(p, mlprec_wrk, level, trans, work) + +! !$ case(mld_kcycle_ml_, mld_kcyclesym_ml_) +! !$ +! !$ call mld_s_inner_k_cycle(p, mlprec_wrk, level, trans, work) + + case default + info = psb_err_from_subroutine_ai_ + call psb_errpush(info,name,a_err='invalid mltype',& + & i_Err=(/p%precv(level)%parms%ml_type,izero,izero,izero,izero/)) + goto 9999 + + end select + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + return + + end subroutine inner_ml_aply + + + recursive subroutine mld_s_inner_add(p, mlprec_wrk, level, trans, work) + use psb_base_mod + use mld_prec_mod + + implicit none + + !Input/Oputput variables + type(mld_sprec_type), intent(inout) :: p + + type(mld_mlprec_wrk_type), target, intent(inout) :: mlprec_wrk(:) + integer(psb_ipk_), intent(in) :: level + character, intent(in) :: trans + real(psb_spk_),target :: work(:) + type(psb_s_vect_type) :: res + type(psb_s_vect_type), pointer :: current + integer(psb_ipk_) :: sweeps_post, sweeps_pre + ! Local variables + integer(psb_ipk_) :: ictxt,np,me + integer(psb_ipk_) :: i, err_act + integer(psb_ipk_) :: debug_level, debug_unit + integer(psb_ipk_) :: nlev, ilev, sweeps + logical :: pre, post + character(len=20) :: name + + + + name = 'inner_inner_add' + info = psb_success_ + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + nlev = size(p%precv) + if ((level < 1) .or. (level > nlev)) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='wrong call level to inner_add') + goto 9999 + end if + ictxt = p%precv(level)%base_desc%get_context() + call psb_info(ictxt, me, np) + + if(debug_level > 1) then + write(debug_unit,*) me,' inner_add at level ',level + end if + + if ((level<1).or.(level>nlev)) then + info = psb_err_internal_error_ + call psb_errpush(info,name,& + & a_err='Invalid LEVEL>NLEV') + goto 9999 + end if + + sweeps = p%precv(level)%parms%sweeps + 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,& + & a_err='Error during ADD smoother_apply') + goto 9999 + end if + + if (level < nlev) then + ! Apply the restriction + call psb_map_X2Y(sone,mlprec_wrk(level)%x2l,& + & szero,mlprec_wrk(level+1)%x2l,& + & p%precv(level+1)%map,info,work=work) + mlprec_wrk(level+1)%y2l(:) = szero + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Error during restriction') + goto 9999 + end if + + call inner_ml_aply(level+1,p,mlprec_wrk,trans,work,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Error in recursive call') + goto 9999 + end if + + ! + ! Apply the prolongator + ! + call psb_map_Y2X(sone,mlprec_wrk(level+1)%y2l,& + & sone,mlprec_wrk(level)%y2l,& + & 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 + + + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + return + + end subroutine mld_s_inner_add + + recursive subroutine mld_s_inner_mult(p, mlprec_wrk, level, trans, work) + use psb_base_mod + use mld_prec_mod + + implicit none + + !Input/Oputput variables + type(mld_sprec_type), intent(inout) :: p + + type(mld_mlprec_wrk_type), target, intent(inout) :: mlprec_wrk(:) + integer(psb_ipk_), intent(in) :: level + character, intent(in) :: trans + real(psb_spk_),target :: work(:) + type(psb_s_vect_type) :: res + type(psb_s_vect_type), pointer :: current + integer(psb_ipk_) :: sweeps_post, sweeps_pre + ! Local variables + integer(psb_ipk_) :: ictxt,np,me + integer(psb_ipk_) :: i, err_act + integer(psb_ipk_) :: debug_level, debug_unit + integer(psb_ipk_) :: nlev, ilev, sweeps + logical :: pre, post + character(len=20) :: name + + + + name = 'inner_inner_mult' + info = psb_success_ + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + nlev = size(p%precv) + if ((level < 1) .or. (level > nlev)) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='wrong call level to inner_mult') + goto 9999 + end if + ictxt = p%precv(level)%base_desc%get_context() + call psb_info(ictxt, me, np) + + if(debug_level > 1) then + write(debug_unit,*) me,' inner_mult at level ',level + end if + + if ((level < nlev).or.(nlev == 1)) then + sweeps_post = p%precv(level)%parms%sweeps_post + sweeps_pre = p%precv(level)%parms%sweeps_pre + else + sweeps_post = p%precv(level-1)%parms%sweeps_post + sweeps_pre = p%precv(level-1)%parms%sweeps_pre + endif + + pre = ((sweeps_pre>0).and.(trans=='N')).or.((sweeps_post>0).and.(trans/='N')) + post = ((sweeps_post>0).and.(trans=='N')).or.((sweeps_pre>0).and.(trans/='N')) + + + if (level < nlev) then + + ! + ! Apply the first smoother + ! + + if (pre) then + if (trans == 'N') then + sweeps = p%precv(level)%parms%sweeps_pre + if (info == psb_success_) call p%precv(level)%sm%apply(sone,& + & mlprec_wrk(level)%x2l,szero,mlprec_wrk(level)%y2l,& + & p%precv(level)%base_desc, trans,& + & sweeps,work,info,init='Y') + else + sweeps = p%precv(level)%parms%sweeps_post + if (info == psb_success_) call p%precv(level)%sm2%apply(sone,& + & mlprec_wrk(level)%x2l,szero,mlprec_wrk(level)%y2l,& + & p%precv(level)%base_desc, trans,& + & sweeps,work,info,init='Y') + end if + + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Error during PRE smoother_apply') + goto 9999 + end if + endif + + ! + ! Compute the residual and call recursively + ! + if (pre) then + call psb_geaxpby(sone,mlprec_wrk(level)%x2l,& + & szero,mlprec_wrk(level)%ty,& + & p%precv(level)%base_desc,info) + + if (info == psb_success_) call psb_spmm(-sone,p%precv(level)%base_a,& + & mlprec_wrk(level)%y2l,sone,mlprec_wrk(level)%ty,& + & p%precv(level)%base_desc,info,work=work,trans=trans) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Error during residue') + goto 9999 + end if + call psb_map_X2Y(sone,mlprec_wrk(level)%ty,& + & szero,mlprec_wrk(level+1)%x2l,& + & 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 restriction') + goto 9999 + end if + else + ! Shortcut: just transfer x2l. + call psb_map_X2Y(sone,mlprec_wrk(level)%x2l,& + & szero,mlprec_wrk(level+1)%x2l,& + & 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 restriction') + goto 9999 + end if + endif + ! First guess is zero + mlprec_wrk(level+1)%y2l(:) = szero + + + call inner_ml_aply(level+1,p,mlprec_wrk,trans,work,info) + + if (p%precv(level)%parms%ml_type == mld_wcycle_ml_) then + ! On second call will use output y2l as initial guess + if (info == psb_success_) call inner_ml_aply(level+1,p,mlprec_wrk,trans,work,info) + endif + + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Error in recursive call') + goto 9999 + end if + + + ! + ! Apply the prolongator + ! + call psb_map_Y2X(sone,mlprec_wrk(level+1)%y2l,& + & sone,mlprec_wrk(level)%y2l,& + & 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 + ! + if (post) then + call psb_geaxpby(sone,mlprec_wrk(level)%x2l,& + & szero,mlprec_wrk(level)%tx,& + & p%precv(level)%base_desc,info) + call psb_spmm(-sone,p%precv(level)%base_a,mlprec_wrk(level)%y2l,& + & sone,mlprec_wrk(level)%tx,p%precv(level)%base_desc,info,& + & work=work,trans=trans) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Error during residue') + goto 9999 + end if + ! + ! Apply the second smoother + ! + if (trans == 'N') then + sweeps = p%precv(level)%parms%sweeps_post + if (info == psb_success_) call p%precv(level)%sm2%apply(sone,& + & mlprec_wrk(level)%tx,sone,mlprec_wrk(level)%y2l,& + & p%precv(level)%base_desc, trans,& + & sweeps,work,info,init='Y') + else + sweeps = p%precv(level)%parms%sweeps_pre + 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,init='Y') + end if + + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Error during POST smoother_apply') + goto 9999 + end if + + endif + + else if (level == nlev) then + + sweeps = p%precv(level)%parms%sweeps + 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 + + info = psb_err_internal_error_ + call psb_errpush(info,name,& + & a_err='Invalid LEVEL vs NLEV') + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + return + + end subroutine mld_s_inner_mult + + +end subroutine mld_smlprec_aply diff --git a/mlprec/impl/mld_zmlprec_aply.f90 b/mlprec/impl/mld_zmlprec_aply.f90 index 338fdd69..05cfc689 100644 --- a/mlprec/impl/mld_zmlprec_aply.f90 +++ b/mlprec/impl/mld_zmlprec_aply.f90 @@ -183,10 +183,8 @@ ! ilev-1, while PT(ilev) denotes its transpose, i.e. the corresponding ! restriction operator from level ilev-1 to level ilev). ! -! 0. Transfer the outer vector Xest to x(1) (inner X at level 1) +! 1. Transfer the outer vector Xest to x(1) (inner X at level 1) ! -! 1. If ilev > 1 Transfer x(ilev-1) to the current level: -! x(ilev) = PT(ilev)*x(ilev-1) ! ! 2. Apply the base preconditioner at the current level: ! ! The sum over the subdomains is carried out in the @@ -194,8 +192,10 @@ ! y(ilev) = (K(ilev)^(-1))*x(ilev) ! ! 3. If ilev < nlevel -! a. Call recursively itself -! b. Transfer y(ilev+1) to the current level: +! a. Transfer x(ilev) to the next level: +! x(ilev+1) = PT(ilev+1)*x(ilev) +! b. Call recursively itself +! c. Transfer y(ilev+1) to the current level: ! y(ilev) = y(ilev) + P(ilev+1)*y(ilev+1) ! ! 4. if ilev == 1 Transfer the inner y to the external: @@ -215,11 +215,8 @@ ! differential equations, Cambridge University Press, 1996. ! ! -! 0. Transfer the outer vector Xest to x(1) (inner X at level 1) +! 1 Transfer the outer vector Xest to x(1) (inner X at level 1) ! -! 1. If ilev >1 Transfer x(ilev-1) to the current level: -! x(ilev) = PT(ilev)*x(ilev-1) -! ! 2. Apply the base preconditioner at the current level: ! ! The sum over the subdomains is carried out in the ! ! application of K(ilev). @@ -228,11 +225,10 @@ ! 3. If ilev < nlevel ! a. Compute the residual: ! r(ilev) = x(ilev) - A(ilev)*y(ilev) -! b. Call recursively itself passing -! r(ilev) for transfer to the next level -! (r(ilev) matches x(ilev-1) in step 1) -! -! c. Transfer y(ilev+1) to the current level: +! b. Transfer r(ilev) to the next level: +! x(ilev+1) = PT(ilev+1)*r(ilev) +! c. Call recursively +! d. Transfer y(ilev+1) to the current level: ! y(ilev) = y(ilev) + P(ilev+1)*y(ilev+1) ! ! 4. if ilev == 1 Transfer the inner y to the external: @@ -242,28 +238,23 @@ ! ! Hybrid multiplicative, post-smoothing variant ! -! 0. Transfer the outer vector Xest to x(1) (inner X at level 1) +! 1. Transfer the outer vector Xest to x(1) (inner X at level 1) ! -! 1. If ilev > 1 Transfer x(ilev-1) to the current level: -! x(ilev) = PT(ilev)*x(ilev-1) -! ! 2. If ilev < nlev -! a. Call recursively itself passing -! x(ilev) for transfer to the next level -! b. Transfer y(ilev+1) to the current level: +! a. Transfer x(ilev) to the next level: +! x(ilev+1) = PT(ilev+1)*x(ilev) +! b. Call recursively +! c. Transfer y(ilev+1) to the current level: ! y(ilev) = P(ilev+1)*y(ilev+1) -! c. Compute the residual: +! d. Compute the residual: ! x(ilev) = x(ilev) - A(ilev)*y(ilev) -! d. Apply the base preconditioner to the residual at the current level: +! e. Apply the base preconditioner to the residual at the current level: ! ! The sum over the subdomains is carried out in the ! ! application of K(ilev) ! y(ilev) = y(ilev) + (K(ilev)^(-1))*x(ilev) -! Else -! Apply the base preconditioner to the residual at the current level: -! ! The sum over the subdomains is carried out in the -! ! application of K(ilev) -! y(ilev) = (K(ilev)^(-1))*x(ilev) -! +! +! 3. If ilev == nlev apply y(ilev) = (K(ilev)^(-1))*x(ilev) +! ! 4. if ilev == 1 Transfer the inner Y to the external: ! Yext = beta*Yext + alpha*Y(1) ! @@ -278,11 +269,8 @@ ! differential equations, Cambridge University Press, 1996. ! ! -! 0. Transfer the outer vector Xest to x(1) (inner X at level 1) +! 1. Transfer the outer vector Xest to x(1) (inner X at level 1) ! -! 1. If ilev > 1 Transfer x(ilev-1) to the current level: -! x(ilev) = PT(ilev)*x(ilev-1) -! ! 2. Apply the base preconditioner at the current level: ! ! The sum over the subdomains is carried out in the ! ! application of K(ilev) @@ -291,10 +279,10 @@ ! 3. If ilev < nlevel ! a. Compute the residual: ! r(ilev) = x(ilev) - A(ilev)*y(ilev) -! b. Call recursively itself passing -! r(ilev) for transfer to the next level -! (r(ilev) matches x(ilev-1) in step 1) -! c. Transfer y(ilev+1) to the current level: +! b. Transfer r(ilev) to the next level: +! x(ilev+1) = PT(ilev+1)*r(ilev) +! c. Call recursively +! d. Transfer y(ilev+1) to the current level: ! y(ilev) = y(ilev) + P(ilev+1)*y(ilev+1) ! d. Compute the residual: ! r(ilev) = x(ilev) - A(ilev)*y(ilev) @@ -303,35 +291,36 @@ ! ! application of K(ilev) ! y(ilev) = y(ilev) + (K(ilev)^(-1))*r(ilev) ! -! 5. if ilev == 1 Transfer the inner Y to the external: +! 4. if ilev == 1 Transfer the inner Y to the external: ! Yext = beta*Yext + alpha*Y(1) ! ! -subroutine mld_zmlprec_aply(alpha,p,x,beta,y,desc_data,trans,work,info) +subroutine mld_zmlprec_aply_vect(alpha,p,x,beta,y,desc_data,trans,work,info) use psb_base_mod - use mld_z_inner_mod, mld_protect_name => mld_zmlprec_aply + use mld_z_inner_mod, mld_protect_name => mld_zmlprec_aply_vect implicit none ! Arguments - type(psb_desc_type),intent(in) :: desc_data - type(mld_zprec_type), intent(inout) :: p - complex(psb_dpk_),intent(in) :: alpha,beta - complex(psb_dpk_),intent(inout) :: x(:) - complex(psb_dpk_),intent(inout) :: y(:) - character, intent(in) :: trans - complex(psb_dpk_),target :: work(:) - integer(psb_ipk_), intent(out) :: info + type(psb_desc_type),intent(in) :: desc_data + type(mld_zprec_type), intent(inout) :: p + complex(psb_dpk_),intent(in) :: alpha,beta + type(psb_z_vect_type),intent(inout) :: x + type(psb_z_vect_type),intent(inout) :: y + character, intent(in) :: trans + complex(psb_dpk_),target :: work(:) + integer(psb_ipk_), intent(out) :: info ! Local variables integer(psb_ipk_) :: ictxt, np, me - integer(psb_ipk_) :: err_act - integer(psb_ipk_) :: debug_level, debug_unit, nlev,nc2l,nr2l,level + integer(psb_ipk_) :: debug_level, debug_unit, nlev,nc2l,nr2l,level, err_act character(len=20) :: name character :: trans_ + complex(psb_dpk_) :: par type mld_mlprec_wrk_type complex(psb_dpk_), allocatable :: tx(:), ty(:), x2l(:), y2l(:) + type(psb_z_vect_type) :: vtx, vty, vx2l, vy2l end type mld_mlprec_wrk_type type(mld_mlprec_wrk_type), allocatable, target :: mlprec_wrk(:) @@ -349,7 +338,6 @@ subroutine mld_zmlprec_aply(alpha,p,x,beta,y,desc_data,trans,work,info) & ' Entry ', size(p%precv) trans_ = psb_toupper(trans) - nlev = size(p%precv) allocate(mlprec_wrk(nlev),stat=info) if (info /= psb_success_) then @@ -357,21 +345,32 @@ subroutine mld_zmlprec_aply(alpha,p,x,beta,y,desc_data,trans,work,info) goto 9999 end if level = 1 + do level = 1, nlev + call psb_geasb(mlprec_wrk(level)%vx2l,& + & p%precv(level)%base_desc,info,& + & scratch=.true.,mold=x%v) + call psb_geasb(mlprec_wrk(level)%vy2l,& + & p%precv(level)%base_desc,info,& + & scratch=.true.,mold=x%v) + call psb_geasb(mlprec_wrk(level)%vtx,& + & p%precv(level)%base_desc,info,& + & scratch=.true.,mold=x%v) + call psb_geasb(mlprec_wrk(level)%vty,& + & p%precv(level)%base_desc,info,& + & scratch=.true.,mold=x%v) + if (psb_errstatus_fatal()) then + nc2l = p%precv(level)%base_desc%get_local_cols() + info=psb_err_alloc_request_ + call psb_errpush(info,name,i_err=(/2*nc2l,izero,izero,izero,izero/),& + & a_err='complex(psb_dpk_)') + goto 9999 + end if + end do + level = 1 - nc2l = p%precv(level)%base_desc%get_local_cols() - nr2l = p%precv(level)%base_desc%get_local_rows() - allocate(mlprec_wrk(level)%x2l(nc2l),mlprec_wrk(level)%y2l(nc2l),& - & stat=info) - if (info /= psb_success_) then - info=psb_err_alloc_request_ - call psb_errpush(info,name,& - & i_err=(/ione*(size(x)+size(y)),izero,izero,izero,izero/),& - & a_err='complex(psb_dpk_)') - goto 9999 - end if + call psb_geaxpby(zone,x,zzero,mlprec_wrk(level)%vx2l,p%precv(level)%base_desc,info) + call mlprec_wrk(level)%vy2l%zero() - mlprec_wrk(level)%x2l(:) = x(:) - mlprec_wrk(level)%y2l(:) = zzero call inner_ml_aply(level,p,mlprec_wrk,trans_,work,info) @@ -381,8 +380,22 @@ subroutine mld_zmlprec_aply(alpha,p,x,beta,y,desc_data,trans,work,info) goto 9999 end if - call psb_geaxpby(alpha,mlprec_wrk(level)%y2l,beta,y,& + call psb_geaxpby(alpha,mlprec_wrk(level)%vy2l,beta,y,& & p%precv(level)%base_desc,info) + do level = 1, nlev + + call mlprec_wrk(level)%vx2l%free(info) + call mlprec_wrk(level)%vy2l%free(info) + call mlprec_wrk(level)%vtx%free(info) + call mlprec_wrk(level)%vty%free(info) + if (psb_errstatus_fatal()) then + info=psb_err_alloc_request_ + nc2l = p%precv(level)%base_desc%get_local_cols() + call psb_errpush(info,name,i_err=(/2*nc2l,izero,izero,izero,izero/),& + & a_err='complex(psb_dpk_)') + goto 9999 + end if + end do if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& @@ -399,7 +412,28 @@ subroutine mld_zmlprec_aply(alpha,p,x,beta,y,desc_data,trans,work,info) return contains - + ! + ! + ! inner_ml_aply: apply AMG at a given level. + ! This routine dispatches the computation according to the type + ! specified at the current level. + ! Each of the corrections will inturn call recursively this routine. + ! + ! Assumptions: + ! On input: + ! mlprec_wkr(level)%vx2l contains the input vector (RHS) + ! mlprec_wkr(level)%vy2l contains the initial guess + ! + ! On output: + ! mlprec_wkr(level)%vy2l contains the solution + ! + ! Constraints: each of the called routines must properly handle + ! the input/output conditions for level+1 (i.e. apply + ! prolongation/restriction). + ! Note: for historical/convenience reasons the prolongator/restrictor + ! between level and level+1 are stored at level+1. + ! + ! recursive subroutine inner_ml_aply(level,p,mlprec_wrk,trans,work,info) implicit none @@ -407,24 +441,29 @@ contains ! Arguments integer(psb_ipk_) :: level type(mld_zprec_type), target, intent(inout) :: p - type(mld_mlprec_wrk_type), intent(inout) :: mlprec_wrk(:) + type(mld_mlprec_wrk_type), intent(inout), target :: mlprec_wrk(:) character, intent(in) :: trans - complex(psb_dpk_),target :: work(:) - integer(psb_ipk_), intent(out) :: info + complex(psb_dpk_),target :: work(:) + integer(psb_ipk_), intent(out) :: info + type(psb_z_vect_type) :: res + type(psb_z_vect_type), pointer :: current + integer(psb_ipk_) :: sweeps_post, sweeps_pre ! Local variables integer(psb_ipk_) :: ictxt,np,me - integer(psb_ipk_) :: i, nr2l,nc2l,err_act + integer(psb_ipk_) :: i, err_act integer(psb_ipk_) :: debug_level, debug_unit integer(psb_ipk_) :: nlev, ilev, sweeps + logical :: pre, post character(len=20) :: name + + name = 'inner_ml_aply' info = psb_success_ call psb_erractionsave(err_act) debug_unit = psb_get_debug_unit() debug_level = psb_get_debug_level() - nlev = size(p%precv) if ((level < 1) .or. (level > nlev)) then call psb_errpush(psb_err_internal_error_,name,& @@ -434,18 +473,8 @@ 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() - allocate(mlprec_wrk(level)%x2l(nc2l),& - & mlprec_wrk(level)%y2l(nc2l),& - & stat=info) - if (info /= psb_success_) then - info=psb_err_alloc_request_ - call psb_errpush(info,name,i_err=(/2*nc2l,izero,izero,izero,izero/),& - & a_err='complex(psb_dpk_)') - goto 9999 - end if + 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) @@ -459,56 +488,9 @@ contains goto 9999 case(mld_add_ml_) - ! - ! Additive multilevel - ! - - if (level > 1) then - ! Apply the restriction - call psb_map_X2Y(zone,mlprec_wrk(level-1)%x2l,& - & zzero,mlprec_wrk(level)%x2l,& - & p%precv(level)%map,info,work=work) - - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during restriction') - goto 9999 - end if - - end if - - 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) - - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during smoother_apply') - goto 9999 - end if - if (level < nlev) then - call inner_ml_aply(level+1,p,mlprec_wrk,trans,work,info) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error in recursive call') - goto 9999 - end if - ! - ! Apply the prolongator - ! - call psb_map_Y2X(zone,mlprec_wrk(level+1)%y2l,& - & zone,mlprec_wrk(level)%y2l,& - & 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 + call mld_z_inner_add(p, mlprec_wrk, level, trans, work) - end if case(mld_mult_ml_) ! @@ -521,452 +503,16 @@ contains select case(p%precv(level)%parms%smoother_pos) case(mld_post_smooth_) - - select case (trans_) - case('N') - if (level > 1) then - ! Apply the restriction - call psb_map_X2Y(zone,mlprec_wrk(level-1)%x2l,& - & zzero,mlprec_wrk(level)%x2l,& - & p%precv(level)%map,info,work=work) - - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during restriction') - goto 9999 - end if - 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 - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error in recursive call') - goto 9999 - end if - ! - ! Apply the prolongator - ! - call psb_map_Y2X(zone,mlprec_wrk(level+1)%y2l,& - & zzero,mlprec_wrk(level)%y2l,& - & 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 - ! - call psb_spmm(-zone,p%precv(level)%base_a,mlprec_wrk(level)%y2l,& - & zone,mlprec_wrk(level)%x2l,p%precv(level)%base_desc,info,& - & work=work,trans=trans) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during residue') - goto 9999 - end if - - sweeps = p%precv(level)%parms%sweeps_post - 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) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during smoother_apply') - goto 9999 - end if - - 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) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during smoother_apply') - goto 9999 - end if - - end if - - case('T','C') - - ! Post-smoothing transpose is pre-smoothing - - - if (level > 1) then - ! Apply the restriction - call psb_map_X2Y(zone,mlprec_wrk(level-1)%x2l,& - & zzero,mlprec_wrk(level)%x2l,& - & p%precv(level)%map,info,work=work) - - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during restriction') - goto 9999 - end if - - - end if - - ! - ! Apply the base preconditioner - ! - 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 - - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during smoother_apply') - goto 9999 - end if - - ! - ! Compute the residual (at all levels but the coarsest one) - ! - if (level < nlev) then - call psb_spmm(-zone,p%precv(level)%base_a,& - & mlprec_wrk(level)%y2l,zone,mlprec_wrk(level)%x2l,& - & p%precv(level)%base_desc,info,work=work,trans=trans) - - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during residue') - goto 9999 - end if - - call inner_ml_aply(level+1,p,mlprec_wrk,trans,work,info) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error in recursive call') - goto 9999 - end if - - - call psb_map_Y2X(zone,mlprec_wrk(level+1)%y2l,& - & zone,mlprec_wrk(level)%y2l,& - & 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 - - - end if - - case default - info = psb_err_internal_error_ - call psb_errpush(info,name,a_err='invalid trans') - goto 9999 - end select + p%precv(level)%parms%sweeps_pre = 0 + call mld_z_inner_mult(p, mlprec_wrk, level, trans, work) + case(mld_pre_smooth_) - - select case (trans_) - case('N') - ! One step of pre-smoothing - - - if (level > 1) then - ! Apply the restriction - call psb_map_X2Y(zone,mlprec_wrk(level-1)%x2l,& - & zzero,mlprec_wrk(level)%x2l,& - & p%precv(level)%map,info,work=work) - - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during restriction') - goto 9999 - end if - - end if - - ! - ! Apply the base preconditioner - ! - if (level < nlev) then - sweeps = p%precv(level)%parms%sweeps_pre - else - sweeps = p%precv(level)%parms%sweeps - 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,& - & a_err='Error during smoother_apply') - goto 9999 - end if - - ! - ! Compute the residual (at all levels but the coarsest one) - ! - if (level < nlev) then - call psb_spmm(-zone,p%precv(level)%base_a,& - & mlprec_wrk(level)%y2l,zone,mlprec_wrk(level)%x2l,& - & p%precv(level)%base_desc,info,work=work,trans=trans) - if (info /= psb_success_) goto 9999 - call inner_ml_aply(level+1,p,mlprec_wrk,trans,work,info) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error in recursive call') - goto 9999 - end if - - - call psb_map_Y2X(zone,mlprec_wrk(level+1)%y2l,& - & zone,mlprec_wrk(level)%y2l,& - & 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 - - - end if - - - case('T','C') - - ! pre-smooth transpose is post-smoothing - - - if (level > 1) then - ! Apply the restriction - call psb_map_X2Y(zone,mlprec_wrk(level-1)%x2l,& - & zzero,mlprec_wrk(level)%x2l,& - & p%precv(level)%map,info,work=work) - - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during restriction') - goto 9999 - end if - - end if - - if (level < nlev) then - call inner_ml_aply(level+1,p,mlprec_wrk,trans,work,info) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error in recursive call') - goto 9999 - end if - - ! - ! Apply the prolongator - ! - call psb_map_Y2X(zone,mlprec_wrk(level+1)%y2l,& - & zzero,mlprec_wrk(level)%y2l,& - & 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 - ! - call psb_spmm(-zone,p%precv(level)%base_a,mlprec_wrk(level)%y2l,& - & zone,mlprec_wrk(level)%x2l,p%precv(level)%base_desc,info,& - & work=work,trans=trans) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during residue') - goto 9999 - end if - - - sweeps = p%precv(level)%parms%sweeps_pre - call p%precv(level)%sm%apply(zone,& - & mlprec_wrk(level)%x2l,zone,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,& - & a_err='Error during smoother_apply') - goto 9999 - end if - 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) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during smoother_apply') - goto 9999 - end if - - end if - - case default - info = psb_err_internal_error_ - call psb_errpush(info,name,a_err='invalid trans') - goto 9999 - end select + p%precv(level)%parms%sweeps_post = 0 + call mld_z_inner_mult(p, mlprec_wrk, level, trans, work) 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) - if (info /= psb_success_) then - info=psb_err_alloc_request_ - call psb_errpush(info,name,i_err=(/2*nc2l,izero,izero,izero,izero/),& - & a_err='complex(psb_dpk_)') - goto 9999 - end if - - if (level > 1) then - ! Apply the restriction - call psb_map_X2Y(zone,mlprec_wrk(level-1)%ty,& - & zzero,mlprec_wrk(level)%x2l,& - & p%precv(level)%map,info,work=work) - - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during restriction') - goto 9999 - end if - end if - call psb_geaxpby(zone,mlprec_wrk(level)%x2l,zzero,mlprec_wrk(level)%tx,& - & p%precv(level)%base_desc,info) - ! - ! Apply the base preconditioner - ! - if (level < nlev) then - if (trans == 'N') then - sweeps = p%precv(level)%parms%sweeps_pre - else - sweeps = p%precv(level)%parms%sweeps_post - 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(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') - goto 9999 - end if - ! - ! Compute the residual (at all levels but the coarsest one) - ! and call recursively - ! - if(level < nlev) then - mlprec_wrk(level)%ty = mlprec_wrk(level)%x2l - if (info == psb_success_) call psb_spmm(-zone,p%precv(level)%base_a,& - & mlprec_wrk(level)%y2l,zone,mlprec_wrk(level)%ty,& - & p%precv(level)%base_desc,info,work=work,trans=trans) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during residue') - goto 9999 - end if - - call inner_ml_aply(level+1,p,mlprec_wrk,trans,work,info) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error in recursive call') - goto 9999 - end if - - - ! - ! Apply the prolongator - ! - call psb_map_Y2X(zone,mlprec_wrk(level+1)%y2l,& - & zone,mlprec_wrk(level)%y2l,& - & 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 - ! - call psb_spmm(-zone,p%precv(level)%base_a,mlprec_wrk(level)%y2l,& - & zone,mlprec_wrk(level)%tx,p%precv(level)%base_desc,info,& - & work=work,trans=trans) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during residue') - goto 9999 - end if - ! - ! Apply the base preconditioner - ! - if (trans == 'N') then - sweeps = p%precv(level)%parms%sweeps_post - else - sweeps = p%precv(level)%parms%sweeps_pre - end if - 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') - goto 9999 - end if - - endif + call mld_z_inner_mult(p, mlprec_wrk, level, trans, work) case default info = psb_err_from_subroutine_ai_ @@ -976,6 +522,15 @@ contains end select + + case(mld_vcycle_ml_, mld_wcycle_ml_) + + call mld_z_inner_mult(p, mlprec_wrk, level, trans, work) + + case(mld_kcycle_ml_, mld_kcyclesym_ml_) + + call mld_z_inner_k_cycle(p, mlprec_wrk, level, trans, work) + case default info = psb_err_from_subroutine_ai_ call psb_errpush(info,name,a_err='invalid mltype',& @@ -992,293 +547,50 @@ contains end subroutine inner_ml_aply -end subroutine mld_zmlprec_aply -subroutine mld_zmlprec_aply_vect(alpha,p,x,beta,y,desc_data,trans,work,info) + recursive subroutine mld_z_inner_add(p, mlprec_wrk, level, trans, work) + use psb_base_mod + use mld_prec_mod - use psb_base_mod - use mld_z_inner_mod, mld_protect_name => mld_zmlprec_aply_vect + implicit none - implicit none + !Input/Oputput variables + type(mld_zprec_type), intent(inout) :: p - ! Arguments - type(psb_desc_type),intent(in) :: desc_data - type(mld_zprec_type), intent(inout) :: p - complex(psb_dpk_),intent(in) :: alpha,beta - type(psb_z_vect_type),intent(inout) :: x - type(psb_z_vect_type),intent(inout) :: y - character, intent(in) :: trans - complex(psb_dpk_),target :: work(:) - integer(psb_ipk_), intent(out) :: info + type(mld_mlprec_wrk_type), target, intent(inout) :: mlprec_wrk(:) + integer(psb_ipk_), intent(in) :: level + character, intent(in) :: trans + complex(psb_dpk_),target :: work(:) + type(psb_z_vect_type) :: res + type(psb_z_vect_type), pointer :: current + integer(psb_ipk_) :: sweeps_post, sweeps_pre + ! Local variables + integer(psb_ipk_) :: ictxt,np,me + integer(psb_ipk_) :: i, err_act + integer(psb_ipk_) :: debug_level, debug_unit + integer(psb_ipk_) :: nlev, ilev, sweeps + logical :: pre, post + character(len=20) :: name - ! Local variables - integer(psb_ipk_) :: ictxt, np, me - integer(psb_ipk_) :: debug_level, debug_unit, nlev,nc2l,nr2l,level, err_act - character(len=20) :: name - character :: trans_ - complex(psb_dpk_) :: par - type mld_mlprec_wrk_type - complex(psb_dpk_), allocatable :: tx(:), ty(:), x2l(:), y2l(:) - type(psb_z_vect_type) :: vtx, vty, vx2l, vy2l - end type mld_mlprec_wrk_type - type(mld_mlprec_wrk_type), allocatable, target :: mlprec_wrk(:) - name='mld_zmlprec_aply' - info = psb_success_ - call psb_erractionsave(err_act) - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - ictxt = desc_data%get_context() - call psb_info(ictxt, me, np) + name = 'inner_inner_add' + info = psb_success_ + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + nlev = size(p%precv) + if ((level < 1) .or. (level > nlev)) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='wrong call level to inner_add') + goto 9999 + end if + ictxt = p%precv(level)%base_desc%get_context() + call psb_info(ictxt, me, np) - if (debug_level >= psb_debug_inner_) & - & write(debug_unit,*) me,' ',trim(name),& - & ' Entry ', size(p%precv) - - trans_ = psb_toupper(trans) - nlev = size(p%precv) - allocate(mlprec_wrk(nlev),stat=info) - if (info /= psb_success_) then - call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') - goto 9999 - end if - level = 1 - do level = 1, nlev - call psb_geasb(mlprec_wrk(level)%vx2l,& - & p%precv(level)%base_desc,info,& - & scratch=.true.,mold=x%v) - call psb_geasb(mlprec_wrk(level)%vy2l,& - & p%precv(level)%base_desc,info,& - & scratch=.true.,mold=x%v) - call psb_geasb(mlprec_wrk(level)%vtx,& - & p%precv(level)%base_desc,info,& - & scratch=.true.,mold=x%v) - call psb_geasb(mlprec_wrk(level)%vty,& - & p%precv(level)%base_desc,info,& - & scratch=.true.,mold=x%v) - if (psb_errstatus_fatal()) then - nc2l = p%precv(level)%base_desc%get_local_cols() - info=psb_err_alloc_request_ - call psb_errpush(info,name,i_err=(/2*nc2l,izero,izero,izero,izero/),& - & a_err='complex(psb_dpk_)') - goto 9999 - end if - end do - level = 1 - - call psb_geaxpby(zone,x,zzero,mlprec_wrk(level)%vx2l,p%precv(level)%base_desc,info) - call mlprec_wrk(level)%vy2l%zero() - - - call inner_ml_aply(level,p,mlprec_wrk,trans_,work,info) - - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Inner prec aply') - goto 9999 - end if - - call psb_geaxpby(alpha,mlprec_wrk(level)%vy2l,beta,y,& - & p%precv(level)%base_desc,info) - do level = 1, nlev - - call mlprec_wrk(level)%vx2l%free(info) - call mlprec_wrk(level)%vy2l%free(info) - call mlprec_wrk(level)%vtx%free(info) - call mlprec_wrk(level)%vty%free(info) - if (psb_errstatus_fatal()) then - info=psb_err_alloc_request_ - nc2l = p%precv(level)%base_desc%get_local_cols() - call psb_errpush(info,name,i_err=(/2*nc2l,izero,izero,izero,izero/),& - & a_err='complex(psb_dpk_)') - goto 9999 - end if - end do - - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error final update') - goto 9999 - end if - - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - - return - -contains - - recursive subroutine inner_ml_aply(level,p,mlprec_wrk,trans,work,info, U) - - implicit none - - ! Arguments - integer(psb_ipk_) :: level - type(mld_zprec_type), target, intent(inout) :: p - type(mld_mlprec_wrk_type), intent(inout), target :: mlprec_wrk(:) - character, intent(in) :: trans - complex(psb_dpk_),target :: work(:) - integer(psb_ipk_), intent(out) :: info - type(psb_z_vect_type),intent(inout), optional :: u - - type(psb_z_vect_type) :: res - type(psb_z_vect_type), pointer :: current - integer(psb_ipk_) :: sweeps_post, sweeps_pre - ! Local variables - integer(psb_ipk_) :: ictxt,np,me - integer(psb_ipk_) :: i, nr2l,nc2l,err_act - integer(psb_ipk_) :: debug_level, debug_unit - integer(psb_ipk_) :: nlev, ilev, sweeps - logical :: pre, post - character(len=20) :: name - - - - name = 'inner_ml_aply' - info = psb_success_ - call psb_erractionsave(err_act) - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - nlev = size(p%precv) - if ((level < 1) .or. (level > nlev)) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='wrong call level to inner_ml') - goto 9999 - end if - ictxt = p%precv(level)%base_desc%get_context() - call psb_info(ictxt, me, np) - - 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) - - case(mld_no_ml_) - ! - ! No preconditioning, should not really get here - ! - call psb_errpush(psb_err_internal_error_,name,& - & a_err='mld_no_ml_ in mlprc_aply?') - goto 9999 - - case(mld_add_ml_) - - call mld_z_inner_add(p, mlprec_wrk, level, trans, work) - - - case(mld_mult_ml_) - ! - ! Multiplicative multilevel (multiplicative among the levels, additive inside - ! each level) - ! - ! Pre/post-smoothing versions. - ! Note that the transpose switches pre <-> post. - ! - select case(p%precv(level)%parms%smoother_pos) - - case(mld_post_smooth_) - p%precv(level)%parms%sweeps_pre = 0 - call mld_z_inner_mult(p, mlprec_wrk, level, trans, work) - - - case(mld_pre_smooth_) - p%precv(level)%parms%sweeps_post = 0 - call mld_z_inner_mult(p, mlprec_wrk, level, trans, work) - - case(mld_twoside_smooth_) - call mld_z_inner_mult(p, mlprec_wrk, level, trans, work) - - case default - info = psb_err_from_subroutine_ai_ - call psb_errpush(info,name,a_err='invalid smooth_pos',& - & i_Err=(/p%precv(level)%parms%smoother_pos,izero,izero,izero,izero/)) - goto 9999 - - end select - - - case(mld_mult_dev_ml_) - - call mld_z_inner_mult(p, mlprec_wrk, level, trans, work) - - - case(mld_vcycle_ml_, mld_wcycle_ml_) - - call mld_z_inner_vw_cycle(p, mlprec_wrk, level, trans, work, u=u) - - case(mld_kcycle_ml_, mld_kcyclesym_ml_) - - call mld_z_inner_k_cycle(p, mlprec_wrk, level, trans, work, u=u) - - case default - info = psb_err_from_subroutine_ai_ - call psb_errpush(info,name,a_err='invalid mltype',& - & i_Err=(/p%precv(level)%parms%ml_type,izero,izero,izero,izero/)) - goto 9999 - - end select - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - return - - end subroutine inner_ml_aply - - - recursive subroutine mld_z_inner_add(p, mlprec_wrk, level, trans, work) - use psb_base_mod - use mld_prec_mod - - implicit none - - !Input/Oputput variables - type(mld_zprec_type), intent(inout) :: p - - type(mld_mlprec_wrk_type), target, intent(inout) :: mlprec_wrk(:) - integer(psb_ipk_), intent(in) :: level - character, intent(in) :: trans - complex(psb_dpk_),target :: work(:) - type(psb_z_vect_type) :: res - type(psb_z_vect_type), pointer :: current - integer(psb_ipk_) :: sweeps_post, sweeps_pre - ! Local variables - integer(psb_ipk_) :: ictxt,np,me - integer(psb_ipk_) :: i, nr2l,nc2l,err_act - integer(psb_ipk_) :: debug_level, debug_unit - integer(psb_ipk_) :: nlev, ilev, sweeps - logical :: pre, post - character(len=20) :: name - - - - name = 'inner_inner_add' - info = psb_success_ - call psb_erractionsave(err_act) - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - nlev = size(p%precv) - if ((level < 1) .or. (level > nlev)) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='wrong call level to inner_add') - goto 9999 - end if - ictxt = p%precv(level)%base_desc%get_context() - call psb_info(ictxt, me, np) - - 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_add at level ',level - end if + if(debug_level > 1) then + write(debug_unit,*) me,' inner_add at level ',level + end if if ((level<1).or.(level>nlev)) then info = psb_err_internal_error_ @@ -1287,21 +599,6 @@ contains goto 9999 end if - - if (level > 1) then - ! Apply the restriction - call psb_map_X2Y(zone,mlprec_wrk(level-1)%vx2l,& - & zzero,mlprec_wrk(level)%vx2l,& - & p%precv(level)%map,info,work=work) - - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during restriction') - goto 9999 - end if - - end if - sweeps = p%precv(level)%parms%sweeps call p%precv(level)%sm%apply(zone,& & mlprec_wrk(level)%vx2l,zzero,mlprec_wrk(level)%vy2l,& @@ -1314,6 +611,17 @@ contains end if if (level < nlev) then + ! Apply the restriction + call psb_map_X2Y(zone,mlprec_wrk(level)%vx2l,& + & zzero,mlprec_wrk(level+1)%vx2l,& + & p%precv(level+1)%map,info,work=work) + call mlprec_wrk(level+1)%vy2l%zero() + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Error during restriction') + goto 9999 + end if + call inner_ml_aply(level+1,p,mlprec_wrk,trans,work,info) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& @@ -1362,7 +670,7 @@ contains integer(psb_ipk_) :: sweeps_post, sweeps_pre ! Local variables integer(psb_ipk_) :: ictxt,np,me - integer(psb_ipk_) :: i, nr2l,nc2l,err_act + integer(psb_ipk_) :: i, err_act integer(psb_ipk_) :: debug_level, debug_unit integer(psb_ipk_) :: nlev, ilev, sweeps logical :: pre, post @@ -1384,13 +692,10 @@ contains ictxt = p%precv(level)%base_desc%get_context() call psb_info(ictxt, me, np) - 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_mult at level ',level end if - if ((level < nlev).or.(nlev == 1)) then sweeps_post = p%precv(level)%parms%sweeps_post sweeps_pre = p%precv(level)%parms%sweeps_pre @@ -1402,49 +707,31 @@ contains pre = ((sweeps_pre>0).and.(trans=='N')).or.((sweeps_post>0).and.(trans/='N')) post = ((sweeps_post>0).and.(trans=='N')).or.((sweeps_pre>0).and.(trans/='N')) + + if (level < nlev) then + + ! + ! Apply the first smoother + ! - if (level > 1) then - ! Apply the restriction - if (pre) then - current => mlprec_wrk(level-1)%vty - else - current => mlprec_wrk(level-1)%vx2l - endif - call psb_map_X2Y(zone,current,& - & zzero,mlprec_wrk(level)%vx2l,& - & p%precv(level)%map,info,work=work) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during restriction') - goto 9999 - end if - end if - - - if (level < nlev) then - - ! - ! Apply the base preconditioner - ! - if (pre) then if (trans == 'N') then sweeps = p%precv(level)%parms%sweeps_pre if (info == psb_success_) call p%precv(level)%sm%apply(zone,& & mlprec_wrk(level)%vx2l,zzero,mlprec_wrk(level)%vy2l,& & p%precv(level)%base_desc, trans,& - & sweeps,work,info) + & sweeps,work,info,init='Y') 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) + & sweeps,work,info,init='Y') end if if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during 2-PRE smoother_apply') + & a_err='Error during PRE smoother_apply') goto 9999 end if endif @@ -1465,9 +752,36 @@ contains & a_err='Error during residue') goto 9999 end if + call psb_map_X2Y(zone,mlprec_wrk(level)%vty,& + & zzero,mlprec_wrk(level+1)%vx2l,& + & 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 restriction') + goto 9999 + end if + else + ! Shortcut: just transfer x2l. + call psb_map_X2Y(zone,mlprec_wrk(level)%vx2l,& + & zzero,mlprec_wrk(level+1)%vx2l,& + & 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 restriction') + goto 9999 + end if endif + ! First guess is zero + call mlprec_wrk(level+1)%vy2l%zero() + call inner_ml_aply(level+1,p,mlprec_wrk,trans,work,info) + + if (p%precv(level)%parms%ml_type == mld_wcycle_ml_) then + ! On second call will use output y2l as initial guess + if (info == psb_success_) call inner_ml_aply(level+1,p,mlprec_wrk,trans,work,info) + endif + if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& & a_err='Error in recursive call') @@ -1478,15 +792,8 @@ contains ! ! Apply the prolongator ! - - if (pre) then - par = zone - else - par = zzero - endif - call psb_map_Y2X(zone,mlprec_wrk(level+1)%vy2l,& - & par,mlprec_wrk(level)%vy2l,& + & zone,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,& @@ -1510,27 +817,28 @@ contains goto 9999 end if ! - ! Apply the base preconditioner + ! Apply the second smoother ! if (trans == 'N') then sweeps = p%precv(level)%parms%sweeps_post if (info == psb_success_) call p%precv(level)%sm2%apply(zone,& & mlprec_wrk(level)%vtx,zone,mlprec_wrk(level)%vy2l,& & p%precv(level)%base_desc, trans,& - & sweeps,work,info) + & sweeps,work,info,init='Y') 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) + & sweeps,work,info,init='Y') end if if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during 2-POST smoother_apply') + & a_err='Error during POST smoother_apply') goto 9999 end if + endif else if (level == nlev) then @@ -1545,7 +853,7 @@ contains info = psb_err_internal_error_ call psb_errpush(info,name,& - & a_err='Invalid LEVEL>NLEV') + & a_err='Invalid LEVEL vs NLEV') goto 9999 end if @@ -1557,7 +865,7 @@ contains end subroutine mld_z_inner_mult - recursive subroutine mld_z_inner_vw_cycle(p, mlprec_wrk, level, trans, work,u) + recursive subroutine mld_z_inner_k_cycle(p, mlprec_wrk, level, trans, work,u) use psb_base_mod use mld_prec_mod @@ -1578,7 +886,7 @@ contains integer(psb_ipk_) :: sweeps_post, sweeps_pre ! Local variables integer(psb_ipk_) :: ictxt,np,me - integer(psb_ipk_) :: i, nr2l,nc2l,err_act + integer(psb_ipk_) :: i, err_act integer(psb_ipk_) :: debug_level, debug_unit integer(psb_ipk_) :: nlev, ilev, sweeps logical :: pre, post @@ -1600,8 +908,6 @@ contains ictxt = p%precv(level)%base_desc%get_context() call psb_info(ictxt, me, np) - 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_add at level ',level end if @@ -1612,90 +918,50 @@ contains & a_err='Invalid LEVEL>NLEV') goto 9999 end if - call psb_geasb(res,p%precv(level)%base_desc,info,& - & scratch=.true., mold=mlprec_wrk(level)%vx2l%v) - - !V/W cycle - if (level > 1) then - ! Apply the restriction - call psb_map_X2Y(zone,mlprec_wrk(level-1)%vty,& - & zzero,mlprec_wrk(level)%vx2l,& - & p%precv(level)%map,info,work=work) - - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during restriction') - goto 9999 - end if - end if - - call psb_geaxpby(zone,mlprec_wrk(level)%vx2l,& - & zzero,mlprec_wrk(level)%vtx,& - & p%precv(level)%base_desc,info) - ! - ! Apply the base preconditioner - ! - if (level < nlev) then - - if (present(u)) then - ! call mlprec_wrk(level)%vy2l%set(u%get_vect()) - call psb_geaxpby(zone,u,& - & zzero,mlprec_wrk(level)%vy2l,& - & p%precv(level)%base_desc,info) - - else - call mlprec_wrk(level)%vy2l%zero() - endif - call psb_geaxpby(zone,mlprec_wrk(level)%vx2l,zzero,res,& - & p%precv(level)%base_desc,info) - - call psb_spmm(-zone,p%precv(level)%base_a,mlprec_wrk(level)%vy2l,& - zone, res, p%precv(level)%base_desc, info, work=work, trans=trans) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during residue') - goto 9999 - end if + !K cycle + + if (level == nlev) then + ! + ! Apply smoother + ! + 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,init='Y') + + else 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) + & sweeps,work,info,init='Y') 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) + & sweeps,work,info,init='Y') 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_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during 2-PRE smoother_apply') - goto 9999 - end if + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,& + & 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 - ! - if(level < nlev) then + ! + ! Compute the residual and call recursively + ! call psb_geaxpby(zone,mlprec_wrk(level)%vx2l,& & zzero,mlprec_wrk(level)%vty,& & p%precv(level)%base_desc,info) - + if (info == psb_success_) call psb_spmm(-zone,p%precv(level)%base_a,& & mlprec_wrk(level)%vy2l,zone,mlprec_wrk(level)%vty,& & p%precv(level)%base_desc,info,work=work,trans=trans) @@ -1705,10 +971,27 @@ contains goto 9999 end if - call inner_ml_aply(level+1,p,mlprec_wrk,trans,work,info) + ! Apply the restriction + call psb_map_X2Y(zone,mlprec_wrk(level)%vty,& + & zzero,mlprec_wrk(level + 1)%vx2l,& + & p%precv(level + 1)%map,info,work=work) + call mlprec_wrk(level + 1)%vy2l%zero() + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Error during restriction') + goto 9999 + end if - if (p%precv(level)%parms%ml_type == mld_wcycle_ml_) then - call inner_ml_aply(level+1,p,mlprec_wrk,trans,work,info, u=mlprec_wrk(level+1)%vy2l) + !Set the preconditioner + + if ((level < nlev - 2)) then + if (p%precv(level)%parms%ml_type == mld_kcyclesym_ml_) then + call mld_zinneritkcycle(p, mlprec_wrk, level + 1, trans, work, 'FCG') + elseif (p%precv(level)%parms%ml_type == mld_kcycle_ml_) then + call mld_zinneritkcycle(p, mlprec_wrk, level + 1, trans, work, 'CGR') + endif + else + call inner_ml_aply(level + 1 ,p,mlprec_wrk,trans,work,info) endif if (info /= psb_success_) then @@ -1717,7 +1000,6 @@ contains goto 9999 end if - ! ! Apply the prolongator ! @@ -1734,8 +1016,11 @@ contains ! ! Compute the residual ! + call psb_geaxpby(zone,mlprec_wrk(level)%vx2l,& + & zzero,mlprec_wrk(level)%vty,& + & p%precv(level)%base_desc,info) call psb_spmm(-zone,p%precv(level)%base_a,mlprec_wrk(level)%vy2l,& - & zone,mlprec_wrk(level)%vtx,p%precv(level)%base_desc,info,& + & zone,mlprec_wrk(level)%vty,p%precv(level)%base_desc,info,& & work=work,trans=trans) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& @@ -1743,341 +1028,127 @@ contains goto 9999 end if ! - ! Apply the base preconditioner + ! Apply the smoother ! 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,& + & mlprec_wrk(level)%vty,zone,mlprec_wrk(level)%vy2l,& & p%precv(level)%base_desc, trans,& - & sweeps,work,info) + & sweeps,work,info,init='Y') 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,& + & mlprec_wrk(level)%vty,zone,mlprec_wrk(level)%vy2l,& & p%precv(level)%base_desc, trans,& - & sweeps,work,info) + & sweeps,work,info,init='Y') end if if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during 2-POST smoother_apply') + & a_err='Error during POST smoother_apply') goto 9999 end if + else + info = psb_err_internal_error_ + call psb_errpush(info,name,& + & a_err='Invalid LEVEL vs NLEV') + goto 9999 + endif - call psb_erractionrestore(err_act) return 9999 call psb_error_handler(err_act) return - end subroutine mld_z_inner_vw_cycle + end subroutine mld_z_inner_k_cycle - recursive subroutine mld_z_inner_k_cycle(p, mlprec_wrk, level, trans, work,u) + + recursive subroutine mld_zinneritkcycle(p, mlprec_wrk, level, trans, work, innersolv) use psb_base_mod use mld_prec_mod + use mld_z_inner_mod, mld_protect_name => mld_zmlprec_aply implicit none !Input/Oputput variables type(mld_zprec_type), intent(inout) :: p - type(mld_mlprec_wrk_type), target, intent(inout) :: mlprec_wrk(:) + + type(mld_mlprec_wrk_type), intent(inout) :: mlprec_wrk(:) integer(psb_ipk_), intent(in) :: level - character, intent(in) :: trans + character, intent(in) :: trans, innersolv complex(psb_dpk_),target :: work(:) - type(psb_z_vect_type),intent(inout), optional :: u + !Other variables + type(psb_z_vect_type) :: v, w, rhs, v1, x + type(psb_z_vect_type), dimension(0:1) :: d + complex(psb_dpk_) :: delta_old, rhs_norm, alpha, tau, tau1, tau2, tau3, tau4, beta + real(psb_dpk_) :: l2_norm, delta, rtol=0.25 + complex(psb_dpk_), allocatable :: temp_v(:) + integer(psb_ipk_) :: info, nlev, i, iter, max_iter=2, idx - type(psb_z_vect_type) :: res - type(psb_z_vect_type), pointer :: current - integer(psb_ipk_) :: sweeps_post, sweeps_pre - ! Local variables - integer(psb_ipk_) :: ictxt,np,me - integer(psb_ipk_) :: i, nr2l,nc2l,err_act - integer(psb_ipk_) :: debug_level, debug_unit - integer(psb_ipk_) :: nlev, ilev, sweeps - logical :: pre, post - character(len=20) :: name + !Assemble rhs, w, v, v1, x + call psb_geasb(rhs,& + & p%precv(level)%base_desc,info,& + & scratch=.true.,mold=mlprec_wrk(level)%vx2l%v) + call psb_geasb(w,& + & p%precv(level)%base_desc,info,& + & scratch=.true.,mold=mlprec_wrk(level)%vx2l%v) + call psb_geasb(v,& + & p%precv(level)%base_desc,info,& + & scratch=.true.,mold=mlprec_wrk(level)%vx2l%v) + call psb_geasb(v1,& + & p%precv(level)%base_desc,info,& + & scratch=.true.,mold=mlprec_wrk(level)%vx2l%v) + call psb_geasb(x,& + & p%precv(level)%base_desc,info,& + & scratch=.true.,mold=mlprec_wrk(level)%vx2l%v) + call x%zero() - name = 'inner_inner_add' - info = psb_success_ - call psb_erractionsave(err_act) - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - nlev = size(p%precv) - if ((level < 1) .or. (level > nlev)) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='wrong call level to inner_add') - goto 9999 - end if - ictxt = p%precv(level)%base_desc%get_context() - call psb_info(ictxt, me, np) + ! rhs=vx2l and w=rhs + call psb_geaxpby(zone,mlprec_wrk(level)%vx2l,zzero,rhs,& + & p%precv(level)%base_desc,info) + call psb_geaxpby(zone,mlprec_wrk(level)%vx2l,zzero,w,& + & p%precv(level)%base_desc,info) - 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_add at level ',level + if (psb_errstatus_fatal()) then + nc2l = p%precv(level)%base_desc%get_local_cols() + info=psb_err_alloc_request_ + call psb_errpush(info,name,i_err=(/2*nc2l,izero,izero,izero,izero/),& + & a_err='TYPE@(psb_dpk_)') + goto 9999 end if - if ((level<1).or.(level>nlev)) then - info = psb_err_internal_error_ - call psb_errpush(info,name,& - & a_err='Invalid LEVEL>NLEV') - goto 9999 - end if + delta = psb_gedot(w, w, p%precv(level)%base_desc, info) - !K cycle + !Apply the preconditioner - call psb_geaxpby(zone,mlprec_wrk(level)%vx2l,& - & zzero,mlprec_wrk(level)%vtx,& - & p%precv(level)%base_desc,info) - ! - ! Apply the base preconditioner - ! - if (level < nlev) then + call mlprec_wrk(level)%vy2l%set(zzero) - if (present(u)) then - call psb_geaxpby(zone,u,& - & zzero,mlprec_wrk(level)%vy2l,& - & p%precv(level)%base_desc,info) - else - call mlprec_wrk(level)%vy2l%zero() - endif - res = mlprec_wrk(level)%vx2l + idx=0 + call inner_ml_aply(level,p,mlprec_wrk,trans,work,info) - call psb_spmm(-zone,p%precv(level)%base_a,mlprec_wrk(level)%vy2l,& - zone, res, p%precv(level)%base_desc, info, work=work, trans=trans) + !Assemble d(0) and d(1) + call psb_geasb(d(0),& + & p%precv(level)%base_desc,info,& + & scratch=.true.,mold=mlprec_wrk(level)%vy2l%v) + call psb_geasb(d(1),& + & p%precv(level)%base_desc,info,& + & scratch=.true.,mold=mlprec_wrk(level)%vy2l%v) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during residue') - goto 9999 - end if + call psb_geaxpby(zone,mlprec_wrk(level)%vy2l,zzero,d(idx),p%precv(level)%base_desc,info) - 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 + call psb_spmm(zone,p%precv(level)%base_a,d(idx),zzero,v,p%precv(level)%base_desc,info) if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& - & 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 - ! - if(level < nlev) then - - call psb_geaxpby(zone,mlprec_wrk(level)%vx2l,& - & zzero,mlprec_wrk(level)%vty,& - & p%precv(level)%base_desc,info) - - if (info == psb_success_) call psb_spmm(-zone,p%precv(level)%base_a,& - & mlprec_wrk(level)%vy2l,zone,mlprec_wrk(level)%vty,& - & p%precv(level)%base_desc,info,work=work,trans=trans) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during residue') - goto 9999 - end if - - ! Apply the restriction - call psb_map_X2Y(zone,mlprec_wrk(level)%vty,& - & zzero,mlprec_wrk(level + 1)%vx2l,& - & 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 restriction') - goto 9999 - end if - - !Set the preconditioner - - - if ((level < nlev - 2)) then - if (p%precv(level)%parms%ml_type == mld_kcyclesym_ml_) then - call mld_zinneritkcycle(p, mlprec_wrk, level + 1, trans, work, 'FCG') - elseif (p%precv(level)%parms%ml_type == mld_kcycle_ml_) then - call mld_zinneritkcycle(p, mlprec_wrk, level + 1, trans, work, 'CGR') - endif - else - call inner_ml_aply(level + 1 ,p,mlprec_wrk,trans,work,info) - endif - - - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error in recursive call') - goto 9999 - end if - - - ! - ! Apply the prolongator - ! - call psb_map_Y2X(zone,mlprec_wrk(level+1)%vy2l,& - & zone,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 - ! - call psb_spmm(-zone,p%precv(level)%base_a,mlprec_wrk(level)%vy2l,& - & zone,mlprec_wrk(level)%vtx,p%precv(level)%base_desc,info,& - & work=work,trans=trans) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during residue') - goto 9999 - end if - ! - ! Apply the base preconditioner - ! - 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_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during 2-POST smoother_apply') - goto 9999 - end if - - endif - - call psb_erractionrestore(err_act) - return - -9999 call psb_error_handler(err_act) - return - - end subroutine mld_z_inner_k_cycle - - - recursive subroutine mld_zinneritkcycle(p, mlprec_wrk, level, trans, work, innersolv) - use psb_base_mod - use mld_prec_mod - use mld_z_inner_mod, mld_protect_name => mld_zmlprec_aply - - implicit none - - !Input/Oputput variables - type(mld_zprec_type), intent(inout) :: p - - type(mld_mlprec_wrk_type), intent(inout) :: mlprec_wrk(:) - integer(psb_ipk_), intent(in) :: level - character, intent(in) :: trans, innersolv - complex(psb_dpk_),target :: work(:) - - !Other variables - type(psb_z_vect_type) :: v, w, rhs, v1, x - type(psb_z_vect_type), dimension(0:1) :: d - complex(psb_dpk_) :: delta_old, rhs_norm, alpha, tau, tau1, tau2, tau3, tau4, beta - - real(psb_dpk_) :: l2_norm, delta, rtol=0.25 - complex(psb_dpk_), allocatable :: temp_v(:) - integer(psb_ipk_) :: info, nlev, i, iter, max_iter=2, idx - - !Assemble rhs, w, v, v1, x - - call psb_geasb(rhs,& - & p%precv(level)%base_desc,info,& - & scratch=.true.,mold=mlprec_wrk(level)%vx2l%v) - call psb_geasb(w,& - & p%precv(level)%base_desc,info,& - & scratch=.true.,mold=mlprec_wrk(level)%vx2l%v) - call psb_geasb(v,& - & p%precv(level)%base_desc,info,& - & scratch=.true.,mold=mlprec_wrk(level)%vx2l%v) - call psb_geasb(v1,& - & p%precv(level)%base_desc,info,& - & scratch=.true.,mold=mlprec_wrk(level)%vx2l%v) - call psb_geasb(x,& - & p%precv(level)%base_desc,info,& - & scratch=.true.,mold=mlprec_wrk(level)%vx2l%v) - - call x%set(zzero) - - ! rhs=vx2l and w=rhs - call psb_geaxpby(zone,mlprec_wrk(level)%vx2l,zzero,rhs,& - & p%precv(level)%base_desc,info) - call psb_geaxpby(zone,mlprec_wrk(level)%vx2l,zzero,w,& - & p%precv(level)%base_desc,info) - - if (psb_errstatus_fatal()) then - nc2l = p%precv(level)%base_desc%get_local_cols() - info=psb_err_alloc_request_ - call psb_errpush(info,name,i_err=(/2*nc2l,izero,izero,izero,izero/),& - & a_err='TYPE@(psb_dpk_)') - goto 9999 - end if - - delta = psb_gedot(w, w, p%precv(level)%base_desc, info) - - !Apply the preconditioner - - call mlprec_wrk(level)%vy2l%set(zzero) - - idx=0 - call inner_ml_aply(level,p,mlprec_wrk,trans,work,info) - - !Assemble d(0) and d(1) - call psb_geasb(d(0),& - & p%precv(level)%base_desc,info,& - & scratch=.true.,mold=mlprec_wrk(level)%vy2l%v) - call psb_geasb(d(1),& - & p%precv(level)%base_desc,info,& - & scratch=.true.,mold=mlprec_wrk(level)%vy2l%v) - - call psb_geaxpby(zone,mlprec_wrk(level)%vy2l,zzero,d(idx),p%precv(level)%base_desc,info) - - - call psb_spmm(zone,p%precv(level)%base_a,d(idx),zzero,v,p%precv(level)%base_desc,info) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,name,& - & a_err='Error during residue') + & a_err='Error during residue') goto 9999 end if @@ -2162,3 +1233,565 @@ contains end subroutine mld_zmlprec_aply_vect + + + + +! +! Old routine for arrays instead of psb_X_vector. To be deleted eventually. +! +! +subroutine mld_zmlprec_aply(alpha,p,x,beta,y,desc_data,trans,work,info) + + use psb_base_mod + use mld_z_inner_mod, mld_protect_name => mld_zmlprec_aply + + implicit none + + ! Arguments + type(psb_desc_type),intent(in) :: desc_data + type(mld_zprec_type), intent(inout) :: p + complex(psb_dpk_),intent(in) :: alpha,beta + complex(psb_dpk_),intent(inout) :: x(:) + complex(psb_dpk_),intent(inout) :: y(:) + character, intent(in) :: trans + complex(psb_dpk_),target :: work(:) + integer(psb_ipk_), intent(out) :: info + + ! Local variables + integer(psb_ipk_) :: ictxt, np, me + integer(psb_ipk_) :: err_act + integer(psb_ipk_) :: debug_level, debug_unit, nlev,nc2l,nr2l,level + character(len=20) :: name + character :: trans_ + type mld_mlprec_wrk_type + complex(psb_dpk_), allocatable :: tx(:), ty(:), x2l(:), y2l(:) + end type mld_mlprec_wrk_type + type(mld_mlprec_wrk_type), allocatable, target :: mlprec_wrk(:) + + name='mld_zmlprec_aply' + info = psb_success_ + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + + ictxt = desc_data%get_context() + call psb_info(ictxt, me, np) + + if (debug_level >= psb_debug_inner_) & + & write(debug_unit,*) me,' ',trim(name),& + & ' Entry ', size(p%precv) + + trans_ = psb_toupper(trans) + + nlev = size(p%precv) + allocate(mlprec_wrk(nlev),stat=info) + if (info /= psb_success_) then + call psb_errpush(psb_err_from_subroutine_,name,a_err='Allocate') + goto 9999 + end if + level = 1 + + do level = 1, nlev + call psb_geasb(mlprec_wrk(level)%x2l,& + & p%precv(level)%base_desc,info) + call psb_geasb(mlprec_wrk(level)%y2l,& + & p%precv(level)%base_desc,info) + call psb_geasb(mlprec_wrk(level)%tx,& + & p%precv(level)%base_desc,info) + call psb_geasb(mlprec_wrk(level)%ty,& + & p%precv(level)%base_desc,info) + if (psb_errstatus_fatal()) then + nc2l = p%precv(level)%base_desc%get_local_cols() + info=psb_err_alloc_request_ + call psb_errpush(info,name,i_err=(/2*nc2l,izero,izero,izero,izero/),& + & a_err='complex(psb_dpk_)') + goto 9999 + end if + end do + + mlprec_wrk(level)%x2l(:) = x(:) + mlprec_wrk(level)%y2l(:) = zzero + + call inner_ml_aply(level,p,mlprec_wrk,trans_,work,info) + + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Inner prec aply') + goto 9999 + end if + + call psb_geaxpby(alpha,mlprec_wrk(level)%y2l,beta,y,& + & p%precv(level)%base_desc,info) + + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Error final update') + goto 9999 + end if + + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + + return + +contains + + ! + ! + ! inner_ml_aply: apply AMG at a given level. + ! This routine dispatches the computation according to the type + ! specified at the current level. + ! Each of the corrections will inturn call recursively this routine. + ! + ! Assumptions: + ! On input: + ! mlprec_wkr(level)%vx2l contains the input vector (RHS) + ! mlprec_wkr(level)%vy2l contains the initial guess + ! + ! On output: + ! mlprec_wkr(level)%vy2l contains the solution + ! + ! Constraints: each of the called routines must properly handle + ! the input/output conditions for level+1 (i.e. apply + ! prolongation/restriction). + ! Note: for historical/convenience reasons the prolongator/restrictor + ! between level and level+1 are stored at level+1. + ! + ! + recursive subroutine inner_ml_aply(level,p,mlprec_wrk,trans,work,info) + + implicit none + + ! Arguments + integer(psb_ipk_) :: level + type(mld_zprec_type), target, intent(inout) :: p + type(mld_mlprec_wrk_type), intent(inout), target :: mlprec_wrk(:) + character, intent(in) :: trans + complex(psb_dpk_),target :: work(:) + integer(psb_ipk_), intent(out) :: info + + type(psb_z_vect_type) :: res + type(psb_z_vect_type), pointer :: current + integer(psb_ipk_) :: sweeps_post, sweeps_pre + ! Local variables + integer(psb_ipk_) :: ictxt,np,me + integer(psb_ipk_) :: i, err_act + integer(psb_ipk_) :: debug_level, debug_unit + integer(psb_ipk_) :: nlev, ilev, sweeps + logical :: pre, post + character(len=20) :: name + + + + name = 'inner_ml_aply' + info = psb_success_ + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + nlev = size(p%precv) + if ((level < 1) .or. (level > nlev)) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='wrong call level to inner_ml') + goto 9999 + end if + ictxt = p%precv(level)%base_desc%get_context() + call psb_info(ictxt, me, np) + + if(debug_level > 1) then + write(debug_unit,*) me,' inner_ml_aply at level ',level + end if + + select case(p%precv(level)%parms%ml_type) + + case(mld_no_ml_) + ! + ! No preconditioning, should not really get here + ! + call psb_errpush(psb_err_internal_error_,name,& + & a_err='mld_no_ml_ in mlprc_aply?') + goto 9999 + + case(mld_add_ml_) + + call mld_z_inner_add(p, mlprec_wrk, level, trans, work) + + + case(mld_mult_ml_) + ! + ! Multiplicative multilevel (multiplicative among the levels, additive inside + ! each level) + ! + ! Pre/post-smoothing versions. + ! Note that the transpose switches pre <-> post. + ! + select case(p%precv(level)%parms%smoother_pos) + + case(mld_post_smooth_) + p%precv(level)%parms%sweeps_pre = 0 + call mld_z_inner_mult(p, mlprec_wrk, level, trans, work) + + + case(mld_pre_smooth_) + p%precv(level)%parms%sweeps_post = 0 + call mld_z_inner_mult(p, mlprec_wrk, level, trans, work) + + case(mld_twoside_smooth_) + call mld_z_inner_mult(p, mlprec_wrk, level, trans, work) + + case default + info = psb_err_from_subroutine_ai_ + call psb_errpush(info,name,a_err='invalid smooth_pos',& + & i_Err=(/p%precv(level)%parms%smoother_pos,izero,izero,izero,izero/)) + goto 9999 + + end select + + + case(mld_vcycle_ml_, mld_wcycle_ml_) + + call mld_z_inner_mult(p, mlprec_wrk, level, trans, work) + +! !$ case(mld_kcycle_ml_, mld_kcyclesym_ml_) +! !$ +! !$ call mld_z_inner_k_cycle(p, mlprec_wrk, level, trans, work) + + case default + info = psb_err_from_subroutine_ai_ + call psb_errpush(info,name,a_err='invalid mltype',& + & i_Err=(/p%precv(level)%parms%ml_type,izero,izero,izero,izero/)) + goto 9999 + + end select + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + return + + end subroutine inner_ml_aply + + + recursive subroutine mld_z_inner_add(p, mlprec_wrk, level, trans, work) + use psb_base_mod + use mld_prec_mod + + implicit none + + !Input/Oputput variables + type(mld_zprec_type), intent(inout) :: p + + type(mld_mlprec_wrk_type), target, intent(inout) :: mlprec_wrk(:) + integer(psb_ipk_), intent(in) :: level + character, intent(in) :: trans + complex(psb_dpk_),target :: work(:) + type(psb_z_vect_type) :: res + type(psb_z_vect_type), pointer :: current + integer(psb_ipk_) :: sweeps_post, sweeps_pre + ! Local variables + integer(psb_ipk_) :: ictxt,np,me + integer(psb_ipk_) :: i, err_act + integer(psb_ipk_) :: debug_level, debug_unit + integer(psb_ipk_) :: nlev, ilev, sweeps + logical :: pre, post + character(len=20) :: name + + + + name = 'inner_inner_add' + info = psb_success_ + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + nlev = size(p%precv) + if ((level < 1) .or. (level > nlev)) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='wrong call level to inner_add') + goto 9999 + end if + ictxt = p%precv(level)%base_desc%get_context() + call psb_info(ictxt, me, np) + + if(debug_level > 1) then + write(debug_unit,*) me,' inner_add at level ',level + end if + + if ((level<1).or.(level>nlev)) then + info = psb_err_internal_error_ + call psb_errpush(info,name,& + & a_err='Invalid LEVEL>NLEV') + goto 9999 + end if + + sweeps = p%precv(level)%parms%sweeps + 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,& + & a_err='Error during ADD smoother_apply') + goto 9999 + end if + + if (level < nlev) then + ! Apply the restriction + call psb_map_X2Y(zone,mlprec_wrk(level)%x2l,& + & zzero,mlprec_wrk(level+1)%x2l,& + & p%precv(level+1)%map,info,work=work) + mlprec_wrk(level+1)%y2l(:) = zzero + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Error during restriction') + goto 9999 + end if + + call inner_ml_aply(level+1,p,mlprec_wrk,trans,work,info) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Error in recursive call') + goto 9999 + end if + + ! + ! Apply the prolongator + ! + call psb_map_Y2X(zone,mlprec_wrk(level+1)%y2l,& + & zone,mlprec_wrk(level)%y2l,& + & 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 + + + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + return + + end subroutine mld_z_inner_add + + recursive subroutine mld_z_inner_mult(p, mlprec_wrk, level, trans, work) + use psb_base_mod + use mld_prec_mod + + implicit none + + !Input/Oputput variables + type(mld_zprec_type), intent(inout) :: p + + type(mld_mlprec_wrk_type), target, intent(inout) :: mlprec_wrk(:) + integer(psb_ipk_), intent(in) :: level + character, intent(in) :: trans + complex(psb_dpk_),target :: work(:) + type(psb_z_vect_type) :: res + type(psb_z_vect_type), pointer :: current + integer(psb_ipk_) :: sweeps_post, sweeps_pre + ! Local variables + integer(psb_ipk_) :: ictxt,np,me + integer(psb_ipk_) :: i, err_act + integer(psb_ipk_) :: debug_level, debug_unit + integer(psb_ipk_) :: nlev, ilev, sweeps + logical :: pre, post + character(len=20) :: name + + + + name = 'inner_inner_mult' + info = psb_success_ + call psb_erractionsave(err_act) + debug_unit = psb_get_debug_unit() + debug_level = psb_get_debug_level() + nlev = size(p%precv) + if ((level < 1) .or. (level > nlev)) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='wrong call level to inner_mult') + goto 9999 + end if + ictxt = p%precv(level)%base_desc%get_context() + call psb_info(ictxt, me, np) + + if(debug_level > 1) then + write(debug_unit,*) me,' inner_mult at level ',level + end if + + if ((level < nlev).or.(nlev == 1)) then + sweeps_post = p%precv(level)%parms%sweeps_post + sweeps_pre = p%precv(level)%parms%sweeps_pre + else + sweeps_post = p%precv(level-1)%parms%sweeps_post + sweeps_pre = p%precv(level-1)%parms%sweeps_pre + endif + + pre = ((sweeps_pre>0).and.(trans=='N')).or.((sweeps_post>0).and.(trans/='N')) + post = ((sweeps_post>0).and.(trans=='N')).or.((sweeps_pre>0).and.(trans/='N')) + + + if (level < nlev) then + + ! + ! Apply the first smoother + ! + + if (pre) then + if (trans == 'N') then + sweeps = p%precv(level)%parms%sweeps_pre + if (info == psb_success_) call p%precv(level)%sm%apply(zone,& + & mlprec_wrk(level)%x2l,zzero,mlprec_wrk(level)%y2l,& + & p%precv(level)%base_desc, trans,& + & sweeps,work,info,init='Y') + else + sweeps = p%precv(level)%parms%sweeps_post + if (info == psb_success_) call p%precv(level)%sm2%apply(zone,& + & mlprec_wrk(level)%x2l,zzero,mlprec_wrk(level)%y2l,& + & p%precv(level)%base_desc, trans,& + & sweeps,work,info,init='Y') + end if + + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Error during PRE smoother_apply') + goto 9999 + end if + endif + + ! + ! Compute the residual and call recursively + ! + if (pre) then + call psb_geaxpby(zone,mlprec_wrk(level)%x2l,& + & zzero,mlprec_wrk(level)%ty,& + & p%precv(level)%base_desc,info) + + if (info == psb_success_) call psb_spmm(-zone,p%precv(level)%base_a,& + & mlprec_wrk(level)%y2l,zone,mlprec_wrk(level)%ty,& + & p%precv(level)%base_desc,info,work=work,trans=trans) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Error during residue') + goto 9999 + end if + call psb_map_X2Y(zone,mlprec_wrk(level)%ty,& + & zzero,mlprec_wrk(level+1)%x2l,& + & 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 restriction') + goto 9999 + end if + else + ! Shortcut: just transfer x2l. + call psb_map_X2Y(zone,mlprec_wrk(level)%x2l,& + & zzero,mlprec_wrk(level+1)%x2l,& + & 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 restriction') + goto 9999 + end if + endif + ! First guess is zero + mlprec_wrk(level+1)%y2l(:) = zzero + + + call inner_ml_aply(level+1,p,mlprec_wrk,trans,work,info) + + if (p%precv(level)%parms%ml_type == mld_wcycle_ml_) then + ! On second call will use output y2l as initial guess + if (info == psb_success_) call inner_ml_aply(level+1,p,mlprec_wrk,trans,work,info) + endif + + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Error in recursive call') + goto 9999 + end if + + + ! + ! Apply the prolongator + ! + call psb_map_Y2X(zone,mlprec_wrk(level+1)%y2l,& + & zone,mlprec_wrk(level)%y2l,& + & 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 + ! + if (post) then + call psb_geaxpby(zone,mlprec_wrk(level)%x2l,& + & zzero,mlprec_wrk(level)%tx,& + & p%precv(level)%base_desc,info) + call psb_spmm(-zone,p%precv(level)%base_a,mlprec_wrk(level)%y2l,& + & zone,mlprec_wrk(level)%tx,p%precv(level)%base_desc,info,& + & work=work,trans=trans) + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Error during residue') + goto 9999 + end if + ! + ! Apply the second smoother + ! + if (trans == 'N') then + sweeps = p%precv(level)%parms%sweeps_post + if (info == psb_success_) call p%precv(level)%sm2%apply(zone,& + & mlprec_wrk(level)%tx,zone,mlprec_wrk(level)%y2l,& + & p%precv(level)%base_desc, trans,& + & sweeps,work,info,init='Y') + else + sweeps = p%precv(level)%parms%sweeps_pre + 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,init='Y') + end if + + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='Error during POST smoother_apply') + goto 9999 + end if + + endif + + else if (level == nlev) then + + sweeps = p%precv(level)%parms%sweeps + 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 + + info = psb_err_internal_error_ + call psb_errpush(info,name,& + & a_err='Invalid LEVEL vs NLEV') + goto 9999 + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(err_act) + return + + end subroutine mld_z_inner_mult + + +end subroutine mld_zmlprec_aply diff --git a/mlprec/impl/smoother/mld_c_as_smoother_apply.f90 b/mlprec/impl/smoother/mld_c_as_smoother_apply.f90 index 254df833..2d6f8f69 100644 --- a/mlprec/impl/smoother/mld_c_as_smoother_apply.f90 +++ b/mlprec/impl/smoother/mld_c_as_smoother_apply.f90 @@ -36,8 +36,8 @@ !!$ POSSIBILITY OF SUCH DAMAGE. !!$ !!$ -subroutine mld_c_as_smoother_apply(alpha,sm,x,beta,y,desc_data,trans,sweeps,work,info) - +subroutine mld_c_as_smoother_apply(alpha,sm,x,beta,y,desc_data,trans,& + & sweeps,work,info,init,initu) use psb_base_mod use mld_c_as_smoother, mld_protect_nam => mld_c_as_smoother_apply implicit none @@ -50,18 +50,26 @@ subroutine mld_c_as_smoother_apply(alpha,sm,x,beta,y,desc_data,trans,sweeps,work integer(psb_ipk_), intent(in) :: sweeps complex(psb_spk_),target, intent(inout) :: work(:) integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: init + complex(psb_spk_),intent(inout), optional :: initu(:) integer(psb_ipk_) :: n_row,n_col, nrow_d, i complex(psb_spk_), pointer :: ww(:), aux(:), tx(:),ty(:) integer(psb_ipk_) :: ictxt,np,me, err_act,isz,int_err(5) - character :: trans_ + character :: trans_, init_ character(len=20) :: name='c_as_smoother_apply', ch_err call psb_erractionsave(err_act) info = psb_success_ ictxt = desc_data%get_context() - call psb_info (ictxt,me,np) + call psb_info(ictxt,me,np) + + if (present(init)) then + init_ = psb_toupper(init) + else + init_='Z' + end if trans_ = psb_toupper(trans) select case(trans_) @@ -83,7 +91,8 @@ subroutine mld_c_as_smoother_apply(alpha,sm,x,beta,y,desc_data,trans,sweeps,work n_row = sm%desc_data%get_local_rows() n_col = sm%desc_data%get_local_cols() nrow_d = desc_data%get_local_rows() - isz=max(n_row,N_COL) + isz = max(n_row,N_COL) + if ((6*isz) <= size(work)) then ww => work(1:isz) tx => work(isz+1:2*isz) @@ -129,10 +138,10 @@ subroutine mld_c_as_smoother_apply(alpha,sm,x,beta,y,desc_data,trans,sweeps,work ! call psb_geaxpby(alpha,x,beta,y,desc_data,info) - else if ((sm%novr == 0).and.(sweeps == 1)) then + else if ((sm%novr == 0).and.(sweeps == 1).and.(.not.sm%sv%is_iterative())) then ! ! Shortcut: in this case it's just the same - ! as Block Jacobi. + ! as Block Jacobi. Moreover, if .not.sv%is_iterative, there's no need to pass init ! call sm%sv%apply(alpha,x,beta,y,desc_data,trans_,aux,info) @@ -226,7 +235,7 @@ subroutine mld_c_as_smoother_apply(alpha,sm,x,beta,y,desc_data,trans,sweeps,work goto 9999 end select - call sm%sv%apply(cone,tx,czero,ty,sm%desc_data,trans_,aux,info) + call sm%sv%apply(cone,tx,czero,ty,sm%desc_data,trans_,aux,info,init='Y') if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& @@ -299,7 +308,24 @@ subroutine mld_c_as_smoother_apply(alpha,sm,x,beta,y,desc_data,trans,sweeps,work ! to compute an approximate solution of a linear system. ! ! - ty = czero + select case (init_) + case('Z') + ty = czero + case('Y') + call psb_geaxpby(cone,y,czero,ty,sm%desc_data,info) + case('U') + if (.not.present(initu)) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='missing initu to smoother_apply') + goto 9999 + end if + call psb_geaxpby(cone,initu,czero,ty,sm%desc_data,info) + case default + call psb_errpush(psb_err_internal_error_,name,& + & a_err='wrong init to smoother_apply') + goto 9999 + end select + do i=1, sweeps select case(trans_) case('N') @@ -386,7 +412,7 @@ subroutine mld_c_as_smoother_apply(alpha,sm,x,beta,y,desc_data,trans,sweeps,work if (info /= psb_success_) exit - call sm%sv%apply(cone,ww,czero,ty,sm%desc_data,trans_,aux,info) + call sm%sv%apply(cone,ww,czero,ty,sm%desc_data,trans_,aux,info,init='Y') if (info /= psb_success_) exit diff --git a/mlprec/impl/smoother/mld_c_as_smoother_apply_vect.f90 b/mlprec/impl/smoother/mld_c_as_smoother_apply_vect.f90 index f0fdf94c..94557429 100644 --- a/mlprec/impl/smoother/mld_c_as_smoother_apply_vect.f90 +++ b/mlprec/impl/smoother/mld_c_as_smoother_apply_vect.f90 @@ -37,7 +37,7 @@ !!$ !!$ subroutine mld_c_as_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& - & sweeps,work,info) + & sweeps,work,info,init,initu) use psb_base_mod use mld_c_as_smoother, mld_protect_nam => mld_c_as_smoother_apply_vect implicit none @@ -50,13 +50,15 @@ subroutine mld_c_as_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& integer(psb_ipk_), intent(in) :: sweeps complex(psb_spk_),target, intent(inout) :: work(:) integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: init + type(psb_c_vect_type),intent(inout), optional :: initu integer(psb_ipk_) :: n_row,n_col, nrow_d, i complex(psb_spk_), pointer :: ww(:), aux(:), tx(:),ty(:) complex(psb_spk_), allocatable :: vx(:) type(psb_c_vect_type) :: vtx, vty, vww integer(psb_ipk_) :: ictxt,np,me, err_act,isz,int_err(5) - character :: trans_ + character :: trans_, init_ character(len=20) :: name='c_as_smoother_apply', ch_err call psb_erractionsave(err_act) @@ -65,6 +67,12 @@ subroutine mld_c_as_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& ictxt = desc_data%get_context() call psb_info(ictxt,me,np) + if (present(init)) then + init_ = psb_toupper(init) + else + init_='Z' + end if + trans_ = psb_toupper(trans) select case(trans_) case('N') @@ -135,7 +143,7 @@ subroutine mld_c_as_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& else if ((sm%novr == 0).and.(sweeps == 1).and.(.not.sm%sv%is_iterative())) then ! ! Shortcut: in this case it's just the same - ! as Block Jacobi. + ! as Block Jacobi. Moreover, if .not.sv%is_iterative, there's no need to pass init ! call sm%sv%apply(alpha,x,beta,y,desc_data,trans_,aux,info) @@ -240,7 +248,7 @@ subroutine mld_c_as_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& goto 9999 end select - call sm%sv%apply(cone,vtx,czero,vty,sm%desc_data,trans_,aux,info) + call sm%sv%apply(cone,vtx,czero,vty,sm%desc_data,trans_,aux,info,init='Y') if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& @@ -313,8 +321,24 @@ subroutine mld_c_as_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& ! to compute an approximate solution of a linear system. ! ! - call vty%set(czero) - + select case (init_) + case('Z') + call vty%zero() + case('Y') + call psb_geaxpby(cone,y,czero,vty,sm%desc_data,info) + case('U') + if (.not.present(initu)) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='missing initu to smoother_apply') + goto 9999 + end if + call psb_geaxpby(cone,initu,czero,vty,sm%desc_data,info) + case default + call psb_errpush(psb_err_internal_error_,name,& + & a_err='wrong init to smoother_apply') + goto 9999 + end select + do i=1, sweeps select case(trans_) case('N') @@ -401,7 +425,7 @@ subroutine mld_c_as_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& if (info /= psb_success_) exit - call sm%sv%apply(cone,vww,czero,vty,sm%desc_data,trans_,aux,info) + call sm%sv%apply(cone,vww,czero,vty,sm%desc_data,trans_,aux,info,init='Y') if (info /= psb_success_) exit diff --git a/mlprec/impl/smoother/mld_c_base_smoother_apply.f90 b/mlprec/impl/smoother/mld_c_base_smoother_apply.f90 index 1b4ee0c9..553c56c7 100644 --- a/mlprec/impl/smoother/mld_c_base_smoother_apply.f90 +++ b/mlprec/impl/smoother/mld_c_base_smoother_apply.f90 @@ -36,8 +36,8 @@ !!$ POSSIBILITY OF SUCH DAMAGE. !!$ !!$ -subroutine mld_c_base_smoother_apply(alpha,sm,x,beta,y,desc_data,trans,sweeps,work,info) - +subroutine mld_c_base_smoother_apply(alpha,sm,x,beta,y,desc_data,& + & trans,sweeps,work,info,init,initu) use psb_base_mod use mld_c_base_smoother_mod, mld_protect_name => mld_c_base_smoother_apply implicit none @@ -50,6 +50,8 @@ subroutine mld_c_base_smoother_apply(alpha,sm,x,beta,y,desc_data,trans,sweeps,wo integer(psb_ipk_), intent(in) :: sweeps complex(psb_spk_),target, intent(inout) :: work(:) integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: init + complex(psb_spk_),intent(inout), optional :: initu(:) integer(psb_ipk_) :: err_act character(len=20) :: name='c_base_smoother_apply' @@ -66,7 +68,7 @@ subroutine mld_c_base_smoother_apply(alpha,sm,x,beta,y,desc_data,trans,sweeps,wo else if (allocated(sm%sv)) then - call sm%sv%apply(alpha,x,beta,y,desc_data,trans,work,info) + call sm%sv%apply(alpha,x,beta,y,desc_data,trans,work,info,init=init, initu=initu) else info = 1121 endif diff --git a/mlprec/impl/smoother/mld_c_base_smoother_apply_vect.f90 b/mlprec/impl/smoother/mld_c_base_smoother_apply_vect.f90 index d397673c..8c6c6c0f 100644 --- a/mlprec/impl/smoother/mld_c_base_smoother_apply_vect.f90 +++ b/mlprec/impl/smoother/mld_c_base_smoother_apply_vect.f90 @@ -37,8 +37,7 @@ !!$ !!$ subroutine mld_c_base_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,& - - & trans,sweeps,work,info) + & trans,sweeps,work,info,init,initu) use psb_base_mod use mld_c_base_smoother_mod, mld_protect_name => mld_c_base_smoother_apply_vect implicit none @@ -51,6 +50,8 @@ subroutine mld_c_base_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,& integer(psb_ipk_), intent(in) :: sweeps complex(psb_spk_),target, intent(inout) :: work(:) integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: init + type(psb_c_vect_type),intent(inout), optional :: initu integer(psb_ipk_) :: err_act character(len=20) :: name='c_base_smoother_apply' @@ -66,8 +67,8 @@ subroutine mld_c_base_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,& call psb_geaxpby(alpha,x,beta,y,desc_data,info) else - if (allocated(sm%sv)) then - call sm%sv%apply(alpha,x,beta,y,desc_data,trans,work,info) + if (allocated(sm%sv)) then + call sm%sv%apply(alpha,x,beta,y,desc_data,trans,work,info,init=init, initu=initu) else info = 1121 endif diff --git a/mlprec/impl/smoother/mld_c_jac_smoother_apply.f90 b/mlprec/impl/smoother/mld_c_jac_smoother_apply.f90 index 359bdf45..91290dc8 100644 --- a/mlprec/impl/smoother/mld_c_jac_smoother_apply.f90 +++ b/mlprec/impl/smoother/mld_c_jac_smoother_apply.f90 @@ -36,8 +36,8 @@ !!$ POSSIBILITY OF SUCH DAMAGE. !!$ !!$ -subroutine mld_c_jac_smoother_apply(alpha,sm,x,beta,y,desc_data,trans,sweeps,work,info) - +subroutine mld_c_jac_smoother_apply(alpha,sm,x,beta,y,desc_data,& + & trans,sweeps,work,info,init,initu) use psb_base_mod use mld_c_jac_smoother, mld_protect_name => mld_c_jac_smoother_apply implicit none @@ -50,17 +50,27 @@ subroutine mld_c_jac_smoother_apply(alpha,sm,x,beta,y,desc_data,trans,sweeps,wor integer(psb_ipk_), intent(in) :: sweeps complex(psb_spk_),target, intent(inout) :: work(:) integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: init + complex(psb_spk_),intent(inout), optional :: initu(:) integer(psb_ipk_) :: n_row,n_col - complex(psb_spk_), pointer :: ww(:), aux(:), tx(:),ty(:) + complex(psb_spk_), allocatable :: tx(:),ty(:) + complex(psb_spk_), pointer :: ww(:), aux(:) integer(psb_ipk_) :: ictxt,np,me,i, err_act - character :: trans_ + character :: trans_, init_ character(len=20) :: name='c_jac_smoother_apply' call psb_erractionsave(err_act) info = psb_success_ + + if (present(init)) then + init_ = psb_toupper(init) + else + init_='Z' + end if + trans_ = psb_toupper(trans) select case(trans_) case('N') @@ -112,8 +122,8 @@ subroutine mld_c_jac_smoother_apply(alpha,sm,x,beta,y,desc_data,trans,sweeps,wor ! call psb_geaxpby(alpha,x,beta,y,desc_data,info) - else if ((sweeps == 1).or.(sm%nnz_nd_tot==0)) then - + else if ((.not.sm%sv%is_iterative()).and.((sweeps == 1).or.(sm%nnz_nd_tot==0))) then + ! if .not.sv%is_iterative, there's no need to pass init call sm%sv%apply(alpha,x,beta,y,desc_data,trans_,aux,info) if (info /= psb_success_) then @@ -122,38 +132,47 @@ subroutine mld_c_jac_smoother_apply(alpha,sm,x,beta,y,desc_data,trans,sweeps,wor goto 9999 endif - else if (sweeps > 1) then - + else if (sweeps >= 1) then ! ! ! Apply multiple sweeps of a block-Jacobi solver ! to compute an approximate solution of a linear system. ! ! - allocate(tx(n_col),ty(n_col),stat=info) - if (info /= psb_success_) then - info=psb_err_alloc_request_ - call psb_errpush(info,name,& - & i_err=(/2*n_col,izero,izero,izero,izero/),& - & a_err='complex(psb_spk_)') - goto 9999 - end if + + call psb_geasb(tx,desc_data,info) + call psb_geasb(ty,desc_data,info) + + select case (init_) + case('Z') + tx(:) = czero + case('Y') + call psb_geaxpby(cone,y,czero,tx,desc_data,info) + case('U') + if (.not.present(initu)) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='missing initu to smoother_apply') + goto 9999 + end if + call psb_geaxpby(cone,initu,czero,tx,desc_data,info) + case default + call psb_errpush(psb_err_internal_error_,name,& + & a_err='wrong init to smoother_apply') + goto 9999 + end select - tx = czero - ty = czero do i=1, sweeps ! ! Compute Y(j+1) = D^(-1)*(X-ND*Y(j)), where D and ND are the ! block diagonal part and the remaining part of the local matrix ! and Y(j) is the approximate solution at sweep j. ! - ty(1:n_row) = x(1:n_row) - call psb_spmm(-cone,sm%nd,tx,cone,ty,desc_data,info,& - & work=aux,trans=trans_) + call psb_geaxpby(cone,x,czero,ty,desc_data,info) + call psb_spmm(-cone,sm%nd,tx,cone,ty,desc_data,info,work=aux,trans=trans_) if (info /= psb_success_) exit - call sm%sv%apply(cone,ty,czero,tx,desc_data,trans_,aux,info) + call sm%sv%apply(cone,ty,czero,tx,desc_data,trans_,aux,info,init='Y') if (info /= psb_success_) exit end do diff --git a/mlprec/impl/smoother/mld_c_jac_smoother_apply_vect.f90 b/mlprec/impl/smoother/mld_c_jac_smoother_apply_vect.f90 index d39ddb21..e5da2a11 100644 --- a/mlprec/impl/smoother/mld_c_jac_smoother_apply_vect.f90 +++ b/mlprec/impl/smoother/mld_c_jac_smoother_apply_vect.f90 @@ -37,7 +37,7 @@ !!$ !!$ subroutine mld_c_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& - & sweeps,work,info) + & sweeps,work,info,init,initu) use psb_base_mod use mld_c_jac_smoother, mld_protect_name => mld_c_jac_smoother_apply_vect @@ -51,23 +51,31 @@ subroutine mld_c_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& integer(psb_ipk_), intent(in) :: sweeps complex(psb_spk_),target, intent(inout) :: work(:) integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: init + type(psb_c_vect_type),intent(inout), optional :: initu integer(psb_ipk_) :: n_row,n_col type(psb_c_vect_type) :: tx, ty complex(psb_spk_), pointer :: ww(:), aux(:) integer(psb_ipk_) :: ictxt,np,me,i, err_act - character :: trans_ + character :: trans_, init_ character(len=20) :: name='c_jac_smoother_apply' call psb_erractionsave(err_act) info = psb_success_ + + if (present(init)) then + init_ = psb_toupper(init) + else + init_='Z' + end if + trans_ = psb_toupper(trans) select case(trans_) case('N') - case('T') - case('C') + case('T','C') case default call psb_errpush(psb_err_iarg_invalid_i_,name) goto 9999 @@ -107,8 +115,6 @@ subroutine mld_c_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& end if endif -!!$ write(0,*) 'Jacobi smoother with ',sweeps - if (sweeps == 0) then ! @@ -118,7 +124,7 @@ subroutine mld_c_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& call psb_geaxpby(alpha,x,beta,y,desc_data,info) else if ((.not.sm%sv%is_iterative()).and.((sweeps == 1).or.(sm%nnz_nd_tot==0))) then - + ! if .not.sv%is_iterative, there's no need to pass init call sm%sv%apply(alpha,x,beta,y,desc_data,trans_,aux,info) if (info /= psb_success_) then @@ -134,9 +140,27 @@ subroutine mld_c_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& ! to compute an approximate solution of a linear system. ! ! - call tx%bld(x%get_nrows(),mold=x%v) - call tx%set(czero) - call ty%bld(x%get_nrows(),mold=x%v) + + call psb_geasb(tx,desc_data,info,mold=x%v,scratch=.true.) + call psb_geasb(ty,desc_data,info,mold=x%v,scratch=.true.) + + select case (init_) + case('Z') + call tx%zero() + case('Y') + call psb_geaxpby(cone,y,czero,tx,desc_data,info) + case('U') + if (.not.present(initu)) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='missing initu to smoother_apply') + goto 9999 + end if + call psb_geaxpby(cone,initu,czero,tx,desc_data,info) + case default + call psb_errpush(psb_err_internal_error_,name,& + & a_err='wrong init to smoother_apply') + goto 9999 + end select do i=1, sweeps ! @@ -149,7 +173,7 @@ subroutine mld_c_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& if (info /= psb_success_) exit - call sm%sv%apply(cone,ty,czero,tx,desc_data,trans_,aux,info) + call sm%sv%apply(cone,ty,czero,tx,desc_data,trans_,aux,info,init='Y') if (info /= psb_success_) exit end do diff --git a/mlprec/impl/smoother/mld_d_as_smoother_apply.f90 b/mlprec/impl/smoother/mld_d_as_smoother_apply.f90 index f84aa0cb..e895e88d 100644 --- a/mlprec/impl/smoother/mld_d_as_smoother_apply.f90 +++ b/mlprec/impl/smoother/mld_d_as_smoother_apply.f90 @@ -36,8 +36,8 @@ !!$ POSSIBILITY OF SUCH DAMAGE. !!$ !!$ -subroutine mld_d_as_smoother_apply(alpha,sm,x,beta,y,desc_data,trans,sweeps,work,info) - +subroutine mld_d_as_smoother_apply(alpha,sm,x,beta,y,desc_data,trans,& + & sweeps,work,info,init,initu) use psb_base_mod use mld_d_as_smoother, mld_protect_nam => mld_d_as_smoother_apply implicit none @@ -50,18 +50,26 @@ subroutine mld_d_as_smoother_apply(alpha,sm,x,beta,y,desc_data,trans,sweeps,work integer(psb_ipk_), intent(in) :: sweeps real(psb_dpk_),target, intent(inout) :: work(:) integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: init + real(psb_dpk_),intent(inout), optional :: initu(:) integer(psb_ipk_) :: n_row,n_col, nrow_d, i real(psb_dpk_), pointer :: ww(:), aux(:), tx(:),ty(:) integer(psb_ipk_) :: ictxt,np,me, err_act,isz,int_err(5) - character :: trans_ + character :: trans_, init_ character(len=20) :: name='d_as_smoother_apply', ch_err call psb_erractionsave(err_act) info = psb_success_ ictxt = desc_data%get_context() - call psb_info (ictxt,me,np) + call psb_info(ictxt,me,np) + + if (present(init)) then + init_ = psb_toupper(init) + else + init_='Z' + end if trans_ = psb_toupper(trans) select case(trans_) @@ -83,7 +91,8 @@ subroutine mld_d_as_smoother_apply(alpha,sm,x,beta,y,desc_data,trans,sweeps,work n_row = sm%desc_data%get_local_rows() n_col = sm%desc_data%get_local_cols() nrow_d = desc_data%get_local_rows() - isz=max(n_row,N_COL) + isz = max(n_row,N_COL) + if ((6*isz) <= size(work)) then ww => work(1:isz) tx => work(isz+1:2*isz) @@ -129,10 +138,10 @@ subroutine mld_d_as_smoother_apply(alpha,sm,x,beta,y,desc_data,trans,sweeps,work ! call psb_geaxpby(alpha,x,beta,y,desc_data,info) - else if ((sm%novr == 0).and.(sweeps == 1)) then + else if ((sm%novr == 0).and.(sweeps == 1).and.(.not.sm%sv%is_iterative())) then ! ! Shortcut: in this case it's just the same - ! as Block Jacobi. + ! as Block Jacobi. Moreover, if .not.sv%is_iterative, there's no need to pass init ! call sm%sv%apply(alpha,x,beta,y,desc_data,trans_,aux,info) @@ -226,7 +235,7 @@ subroutine mld_d_as_smoother_apply(alpha,sm,x,beta,y,desc_data,trans,sweeps,work goto 9999 end select - call sm%sv%apply(done,tx,dzero,ty,sm%desc_data,trans_,aux,info) + call sm%sv%apply(done,tx,dzero,ty,sm%desc_data,trans_,aux,info,init='Y') if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& @@ -299,7 +308,24 @@ subroutine mld_d_as_smoother_apply(alpha,sm,x,beta,y,desc_data,trans,sweeps,work ! to compute an approximate solution of a linear system. ! ! - ty = dzero + select case (init_) + case('Z') + ty = dzero + case('Y') + call psb_geaxpby(done,y,dzero,ty,sm%desc_data,info) + case('U') + if (.not.present(initu)) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='missing initu to smoother_apply') + goto 9999 + end if + call psb_geaxpby(done,initu,dzero,ty,sm%desc_data,info) + case default + call psb_errpush(psb_err_internal_error_,name,& + & a_err='wrong init to smoother_apply') + goto 9999 + end select + do i=1, sweeps select case(trans_) case('N') @@ -386,7 +412,7 @@ subroutine mld_d_as_smoother_apply(alpha,sm,x,beta,y,desc_data,trans,sweeps,work if (info /= psb_success_) exit - call sm%sv%apply(done,ww,dzero,ty,sm%desc_data,trans_,aux,info) + call sm%sv%apply(done,ww,dzero,ty,sm%desc_data,trans_,aux,info,init='Y') if (info /= psb_success_) exit diff --git a/mlprec/impl/smoother/mld_d_as_smoother_apply_vect.f90 b/mlprec/impl/smoother/mld_d_as_smoother_apply_vect.f90 index 260447eb..7ea48bbf 100644 --- a/mlprec/impl/smoother/mld_d_as_smoother_apply_vect.f90 +++ b/mlprec/impl/smoother/mld_d_as_smoother_apply_vect.f90 @@ -37,7 +37,7 @@ !!$ !!$ subroutine mld_d_as_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& - & sweeps,work,info) + & sweeps,work,info,init,initu) use psb_base_mod use mld_d_as_smoother, mld_protect_nam => mld_d_as_smoother_apply_vect implicit none @@ -50,13 +50,15 @@ subroutine mld_d_as_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& integer(psb_ipk_), intent(in) :: sweeps real(psb_dpk_),target, intent(inout) :: work(:) integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: init + type(psb_d_vect_type),intent(inout), optional :: initu integer(psb_ipk_) :: n_row,n_col, nrow_d, i real(psb_dpk_), pointer :: ww(:), aux(:), tx(:),ty(:) real(psb_dpk_), allocatable :: vx(:) type(psb_d_vect_type) :: vtx, vty, vww integer(psb_ipk_) :: ictxt,np,me, err_act,isz,int_err(5) - character :: trans_ + character :: trans_, init_ character(len=20) :: name='d_as_smoother_apply', ch_err call psb_erractionsave(err_act) @@ -65,6 +67,12 @@ subroutine mld_d_as_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& ictxt = desc_data%get_context() call psb_info(ictxt,me,np) + if (present(init)) then + init_ = psb_toupper(init) + else + init_='Z' + end if + trans_ = psb_toupper(trans) select case(trans_) case('N') @@ -135,7 +143,7 @@ subroutine mld_d_as_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& else if ((sm%novr == 0).and.(sweeps == 1).and.(.not.sm%sv%is_iterative())) then ! ! Shortcut: in this case it's just the same - ! as Block Jacobi. + ! as Block Jacobi. Moreover, if .not.sv%is_iterative, there's no need to pass init ! call sm%sv%apply(alpha,x,beta,y,desc_data,trans_,aux,info) @@ -240,7 +248,7 @@ subroutine mld_d_as_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& goto 9999 end select - call sm%sv%apply(done,vtx,dzero,vty,sm%desc_data,trans_,aux,info) + call sm%sv%apply(done,vtx,dzero,vty,sm%desc_data,trans_,aux,info,init='Y') if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& @@ -313,8 +321,24 @@ subroutine mld_d_as_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& ! to compute an approximate solution of a linear system. ! ! - call vty%set(dzero) - + select case (init_) + case('Z') + call vty%zero() + case('Y') + call psb_geaxpby(done,y,dzero,vty,sm%desc_data,info) + case('U') + if (.not.present(initu)) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='missing initu to smoother_apply') + goto 9999 + end if + call psb_geaxpby(done,initu,dzero,vty,sm%desc_data,info) + case default + call psb_errpush(psb_err_internal_error_,name,& + & a_err='wrong init to smoother_apply') + goto 9999 + end select + do i=1, sweeps select case(trans_) case('N') @@ -401,7 +425,7 @@ subroutine mld_d_as_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& if (info /= psb_success_) exit - call sm%sv%apply(done,vww,dzero,vty,sm%desc_data,trans_,aux,info) + call sm%sv%apply(done,vww,dzero,vty,sm%desc_data,trans_,aux,info,init='Y') if (info /= psb_success_) exit diff --git a/mlprec/impl/smoother/mld_d_as_smoother_bld.f90 b/mlprec/impl/smoother/mld_d_as_smoother_bld.f90 index 3cc44be8..952e88f5 100644 --- a/mlprec/impl/smoother/mld_d_as_smoother_bld.f90 +++ b/mlprec/impl/smoother/mld_d_as_smoother_bld.f90 @@ -142,12 +142,14 @@ subroutine mld_d_as_smoother_bld(a,desc_a,sm,upd,info,amold,vmold,imold) & blck%get_nrows(), blck%get_nzeros() End if - if (info == psb_success_) call sm%sv%build(a,sm%desc_data,upd,info,& + if (info == psb_success_) & + & call sm%sv%build(a,sm%desc_data,upd,info,& & blck,amold=amold,vmold=vmold) nrow_a = a%get_nrows() n_row = sm%desc_data%get_local_rows() n_col = sm%desc_data%get_local_cols() + if (info == psb_success_) call a%csclip(sm%nd,info,& & jmin=nrow_a+1,rscale=.false.,cscale=.false.) if (info == psb_success_) call blck%csclip(atmp,info,& diff --git a/mlprec/impl/smoother/mld_d_as_smoother_cnv.f90 b/mlprec/impl/smoother/mld_d_as_smoother_cnv.f90 index 6bc8d3a7..41b00cd0 100644 --- a/mlprec/impl/smoother/mld_d_as_smoother_cnv.f90 +++ b/mlprec/impl/smoother/mld_d_as_smoother_cnv.f90 @@ -67,7 +67,7 @@ subroutine mld_d_as_smoother_cnv(sm,info,amold,vmold,imold) if (allocated(sm%sv)) & - & call sm%sv%cnv(info,amold=amold,vmold=vmold,imold=imold) + & call sm%sv%cnv(info,amold=amold,vmold=vmold,imold=imold) if (info == psb_success_) then if (present(amold)) then diff --git a/mlprec/impl/smoother/mld_d_base_smoother_apply.f90 b/mlprec/impl/smoother/mld_d_base_smoother_apply.f90 index d4ce0064..8f35201b 100644 --- a/mlprec/impl/smoother/mld_d_base_smoother_apply.f90 +++ b/mlprec/impl/smoother/mld_d_base_smoother_apply.f90 @@ -36,8 +36,8 @@ !!$ POSSIBILITY OF SUCH DAMAGE. !!$ !!$ -subroutine mld_d_base_smoother_apply(alpha,sm,x,beta,y,desc_data,trans,sweeps,work,info) - +subroutine mld_d_base_smoother_apply(alpha,sm,x,beta,y,desc_data,& + & trans,sweeps,work,info,init,initu) use psb_base_mod use mld_d_base_smoother_mod, mld_protect_name => mld_d_base_smoother_apply implicit none @@ -50,6 +50,8 @@ subroutine mld_d_base_smoother_apply(alpha,sm,x,beta,y,desc_data,trans,sweeps,wo integer(psb_ipk_), intent(in) :: sweeps real(psb_dpk_),target, intent(inout) :: work(:) integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: init + real(psb_dpk_),intent(inout), optional :: initu(:) integer(psb_ipk_) :: err_act character(len=20) :: name='d_base_smoother_apply' @@ -66,7 +68,7 @@ subroutine mld_d_base_smoother_apply(alpha,sm,x,beta,y,desc_data,trans,sweeps,wo else if (allocated(sm%sv)) then - call sm%sv%apply(alpha,x,beta,y,desc_data,trans,work,info) + call sm%sv%apply(alpha,x,beta,y,desc_data,trans,work,info,init=init, initu=initu) else info = 1121 endif diff --git a/mlprec/impl/smoother/mld_d_base_smoother_apply_vect.f90 b/mlprec/impl/smoother/mld_d_base_smoother_apply_vect.f90 index 9bbaf5e7..f0585b1f 100644 --- a/mlprec/impl/smoother/mld_d_base_smoother_apply_vect.f90 +++ b/mlprec/impl/smoother/mld_d_base_smoother_apply_vect.f90 @@ -37,8 +37,7 @@ !!$ !!$ subroutine mld_d_base_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,& - - & trans,sweeps,work,info) + & trans,sweeps,work,info,init,initu) use psb_base_mod use mld_d_base_smoother_mod, mld_protect_name => mld_d_base_smoother_apply_vect implicit none @@ -51,6 +50,8 @@ subroutine mld_d_base_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,& integer(psb_ipk_), intent(in) :: sweeps real(psb_dpk_),target, intent(inout) :: work(:) integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: init + type(psb_d_vect_type),intent(inout), optional :: initu integer(psb_ipk_) :: err_act character(len=20) :: name='d_base_smoother_apply' @@ -66,8 +67,8 @@ subroutine mld_d_base_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,& call psb_geaxpby(alpha,x,beta,y,desc_data,info) else - if (allocated(sm%sv)) then - call sm%sv%apply(alpha,x,beta,y,desc_data,trans,work,info) + if (allocated(sm%sv)) then + call sm%sv%apply(alpha,x,beta,y,desc_data,trans,work,info,init=init, initu=initu) else info = 1121 endif diff --git a/mlprec/impl/smoother/mld_d_jac_smoother_apply.f90 b/mlprec/impl/smoother/mld_d_jac_smoother_apply.f90 index a8a69b89..3067c90a 100644 --- a/mlprec/impl/smoother/mld_d_jac_smoother_apply.f90 +++ b/mlprec/impl/smoother/mld_d_jac_smoother_apply.f90 @@ -36,8 +36,8 @@ !!$ POSSIBILITY OF SUCH DAMAGE. !!$ !!$ -subroutine mld_d_jac_smoother_apply(alpha,sm,x,beta,y,desc_data,trans,sweeps,work,info) - +subroutine mld_d_jac_smoother_apply(alpha,sm,x,beta,y,desc_data,& + & trans,sweeps,work,info,init,initu) use psb_base_mod use mld_d_jac_smoother, mld_protect_name => mld_d_jac_smoother_apply implicit none @@ -50,17 +50,27 @@ subroutine mld_d_jac_smoother_apply(alpha,sm,x,beta,y,desc_data,trans,sweeps,wor integer(psb_ipk_), intent(in) :: sweeps real(psb_dpk_),target, intent(inout) :: work(:) integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: init + real(psb_dpk_),intent(inout), optional :: initu(:) integer(psb_ipk_) :: n_row,n_col - real(psb_dpk_), pointer :: ww(:), aux(:), tx(:),ty(:) + real(psb_dpk_), allocatable :: tx(:),ty(:) + real(psb_dpk_), pointer :: ww(:), aux(:) integer(psb_ipk_) :: ictxt,np,me,i, err_act - character :: trans_ + character :: trans_, init_ character(len=20) :: name='d_jac_smoother_apply' call psb_erractionsave(err_act) info = psb_success_ + + if (present(init)) then + init_ = psb_toupper(init) + else + init_='Z' + end if + trans_ = psb_toupper(trans) select case(trans_) case('N') @@ -112,8 +122,8 @@ subroutine mld_d_jac_smoother_apply(alpha,sm,x,beta,y,desc_data,trans,sweeps,wor ! call psb_geaxpby(alpha,x,beta,y,desc_data,info) - else if ((sweeps == 1).or.(sm%nnz_nd_tot==0)) then - + else if ((.not.sm%sv%is_iterative()).and.((sweeps == 1).or.(sm%nnz_nd_tot==0))) then + ! if .not.sv%is_iterative, there's no need to pass init call sm%sv%apply(alpha,x,beta,y,desc_data,trans_,aux,info) if (info /= psb_success_) then @@ -122,38 +132,47 @@ subroutine mld_d_jac_smoother_apply(alpha,sm,x,beta,y,desc_data,trans,sweeps,wor goto 9999 endif - else if (sweeps > 1) then - + else if (sweeps >= 1) then ! ! ! Apply multiple sweeps of a block-Jacobi solver ! to compute an approximate solution of a linear system. ! ! - allocate(tx(n_col),ty(n_col),stat=info) - if (info /= psb_success_) then - info=psb_err_alloc_request_ - call psb_errpush(info,name,& - & i_err=(/2*n_col,izero,izero,izero,izero/),& - & a_err='real(psb_dpk_)') - goto 9999 - end if + + call psb_geasb(tx,desc_data,info) + call psb_geasb(ty,desc_data,info) + + select case (init_) + case('Z') + tx(:) = dzero + case('Y') + call psb_geaxpby(done,y,dzero,tx,desc_data,info) + case('U') + if (.not.present(initu)) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='missing initu to smoother_apply') + goto 9999 + end if + call psb_geaxpby(done,initu,dzero,tx,desc_data,info) + case default + call psb_errpush(psb_err_internal_error_,name,& + & a_err='wrong init to smoother_apply') + goto 9999 + end select - tx = dzero - ty = dzero do i=1, sweeps ! ! Compute Y(j+1) = D^(-1)*(X-ND*Y(j)), where D and ND are the ! block diagonal part and the remaining part of the local matrix ! and Y(j) is the approximate solution at sweep j. ! - ty(1:n_row) = x(1:n_row) - call psb_spmm(-done,sm%nd,tx,done,ty,desc_data,info,& - & work=aux,trans=trans_) + call psb_geaxpby(done,x,dzero,ty,desc_data,info) + call psb_spmm(-done,sm%nd,tx,done,ty,desc_data,info,work=aux,trans=trans_) if (info /= psb_success_) exit - call sm%sv%apply(done,ty,dzero,tx,desc_data,trans_,aux,info) + call sm%sv%apply(done,ty,dzero,tx,desc_data,trans_,aux,info,init='Y') if (info /= psb_success_) exit end do diff --git a/mlprec/impl/smoother/mld_d_jac_smoother_apply_vect.f90 b/mlprec/impl/smoother/mld_d_jac_smoother_apply_vect.f90 index e8a9409b..1a37a5e8 100644 --- a/mlprec/impl/smoother/mld_d_jac_smoother_apply_vect.f90 +++ b/mlprec/impl/smoother/mld_d_jac_smoother_apply_vect.f90 @@ -37,7 +37,7 @@ !!$ !!$ subroutine mld_d_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& - & sweeps,work,info) + & sweeps,work,info,init,initu) use psb_base_mod use mld_d_jac_smoother, mld_protect_name => mld_d_jac_smoother_apply_vect @@ -51,23 +51,31 @@ subroutine mld_d_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& integer(psb_ipk_), intent(in) :: sweeps real(psb_dpk_),target, intent(inout) :: work(:) integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: init + type(psb_d_vect_type),intent(inout), optional :: initu integer(psb_ipk_) :: n_row,n_col type(psb_d_vect_type) :: tx, ty real(psb_dpk_), pointer :: ww(:), aux(:) integer(psb_ipk_) :: ictxt,np,me,i, err_act - character :: trans_ + character :: trans_, init_ character(len=20) :: name='d_jac_smoother_apply' call psb_erractionsave(err_act) info = psb_success_ + + if (present(init)) then + init_ = psb_toupper(init) + else + init_='Z' + end if + trans_ = psb_toupper(trans) select case(trans_) case('N') - case('T') - case('C') + case('T','C') case default call psb_errpush(psb_err_iarg_invalid_i_,name) goto 9999 @@ -107,8 +115,6 @@ subroutine mld_d_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& end if endif -!!$ write(0,*) 'Jacobi smoother with ',sweeps - if (sweeps == 0) then ! @@ -118,7 +124,7 @@ subroutine mld_d_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& call psb_geaxpby(alpha,x,beta,y,desc_data,info) else if ((.not.sm%sv%is_iterative()).and.((sweeps == 1).or.(sm%nnz_nd_tot==0))) then - + ! if .not.sv%is_iterative, there's no need to pass init call sm%sv%apply(alpha,x,beta,y,desc_data,trans_,aux,info) if (info /= psb_success_) then @@ -134,9 +140,27 @@ subroutine mld_d_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& ! to compute an approximate solution of a linear system. ! ! - call tx%bld(x%get_nrows(),mold=x%v) - call tx%set(dzero) - call ty%bld(x%get_nrows(),mold=x%v) + + call psb_geasb(tx,desc_data,info,mold=x%v,scratch=.true.) + call psb_geasb(ty,desc_data,info,mold=x%v,scratch=.true.) + + select case (init_) + case('Z') + call tx%zero() + case('Y') + call psb_geaxpby(done,y,dzero,tx,desc_data,info) + case('U') + if (.not.present(initu)) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='missing initu to smoother_apply') + goto 9999 + end if + call psb_geaxpby(done,initu,dzero,tx,desc_data,info) + case default + call psb_errpush(psb_err_internal_error_,name,& + & a_err='wrong init to smoother_apply') + goto 9999 + end select do i=1, sweeps ! @@ -149,7 +173,7 @@ subroutine mld_d_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& if (info /= psb_success_) exit - call sm%sv%apply(done,ty,dzero,tx,desc_data,trans_,aux,info) + call sm%sv%apply(done,ty,dzero,tx,desc_data,trans_,aux,info,init='Y') if (info /= psb_success_) exit end do diff --git a/mlprec/impl/smoother/mld_s_as_smoother_apply.f90 b/mlprec/impl/smoother/mld_s_as_smoother_apply.f90 index fe664c2e..60520217 100644 --- a/mlprec/impl/smoother/mld_s_as_smoother_apply.f90 +++ b/mlprec/impl/smoother/mld_s_as_smoother_apply.f90 @@ -36,8 +36,8 @@ !!$ POSSIBILITY OF SUCH DAMAGE. !!$ !!$ -subroutine mld_s_as_smoother_apply(alpha,sm,x,beta,y,desc_data,trans,sweeps,work,info) - +subroutine mld_s_as_smoother_apply(alpha,sm,x,beta,y,desc_data,trans,& + & sweeps,work,info,init,initu) use psb_base_mod use mld_s_as_smoother, mld_protect_nam => mld_s_as_smoother_apply implicit none @@ -50,18 +50,26 @@ subroutine mld_s_as_smoother_apply(alpha,sm,x,beta,y,desc_data,trans,sweeps,work integer(psb_ipk_), intent(in) :: sweeps real(psb_spk_),target, intent(inout) :: work(:) integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: init + real(psb_spk_),intent(inout), optional :: initu(:) integer(psb_ipk_) :: n_row,n_col, nrow_d, i real(psb_spk_), pointer :: ww(:), aux(:), tx(:),ty(:) integer(psb_ipk_) :: ictxt,np,me, err_act,isz,int_err(5) - character :: trans_ + character :: trans_, init_ character(len=20) :: name='s_as_smoother_apply', ch_err call psb_erractionsave(err_act) info = psb_success_ ictxt = desc_data%get_context() - call psb_info (ictxt,me,np) + call psb_info(ictxt,me,np) + + if (present(init)) then + init_ = psb_toupper(init) + else + init_='Z' + end if trans_ = psb_toupper(trans) select case(trans_) @@ -83,7 +91,8 @@ subroutine mld_s_as_smoother_apply(alpha,sm,x,beta,y,desc_data,trans,sweeps,work n_row = sm%desc_data%get_local_rows() n_col = sm%desc_data%get_local_cols() nrow_d = desc_data%get_local_rows() - isz=max(n_row,N_COL) + isz = max(n_row,N_COL) + if ((6*isz) <= size(work)) then ww => work(1:isz) tx => work(isz+1:2*isz) @@ -129,10 +138,10 @@ subroutine mld_s_as_smoother_apply(alpha,sm,x,beta,y,desc_data,trans,sweeps,work ! call psb_geaxpby(alpha,x,beta,y,desc_data,info) - else if ((sm%novr == 0).and.(sweeps == 1)) then + else if ((sm%novr == 0).and.(sweeps == 1).and.(.not.sm%sv%is_iterative())) then ! ! Shortcut: in this case it's just the same - ! as Block Jacobi. + ! as Block Jacobi. Moreover, if .not.sv%is_iterative, there's no need to pass init ! call sm%sv%apply(alpha,x,beta,y,desc_data,trans_,aux,info) @@ -226,7 +235,7 @@ subroutine mld_s_as_smoother_apply(alpha,sm,x,beta,y,desc_data,trans,sweeps,work goto 9999 end select - call sm%sv%apply(sone,tx,szero,ty,sm%desc_data,trans_,aux,info) + call sm%sv%apply(sone,tx,szero,ty,sm%desc_data,trans_,aux,info,init='Y') if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& @@ -299,7 +308,24 @@ subroutine mld_s_as_smoother_apply(alpha,sm,x,beta,y,desc_data,trans,sweeps,work ! to compute an approximate solution of a linear system. ! ! - ty = szero + select case (init_) + case('Z') + ty = szero + case('Y') + call psb_geaxpby(sone,y,szero,ty,sm%desc_data,info) + case('U') + if (.not.present(initu)) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='missing initu to smoother_apply') + goto 9999 + end if + call psb_geaxpby(sone,initu,szero,ty,sm%desc_data,info) + case default + call psb_errpush(psb_err_internal_error_,name,& + & a_err='wrong init to smoother_apply') + goto 9999 + end select + do i=1, sweeps select case(trans_) case('N') @@ -386,7 +412,7 @@ subroutine mld_s_as_smoother_apply(alpha,sm,x,beta,y,desc_data,trans,sweeps,work if (info /= psb_success_) exit - call sm%sv%apply(sone,ww,szero,ty,sm%desc_data,trans_,aux,info) + call sm%sv%apply(sone,ww,szero,ty,sm%desc_data,trans_,aux,info,init='Y') if (info /= psb_success_) exit diff --git a/mlprec/impl/smoother/mld_s_as_smoother_apply_vect.f90 b/mlprec/impl/smoother/mld_s_as_smoother_apply_vect.f90 index e9341ddb..ae2650a4 100644 --- a/mlprec/impl/smoother/mld_s_as_smoother_apply_vect.f90 +++ b/mlprec/impl/smoother/mld_s_as_smoother_apply_vect.f90 @@ -37,7 +37,7 @@ !!$ !!$ subroutine mld_s_as_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& - & sweeps,work,info) + & sweeps,work,info,init,initu) use psb_base_mod use mld_s_as_smoother, mld_protect_nam => mld_s_as_smoother_apply_vect implicit none @@ -50,13 +50,15 @@ subroutine mld_s_as_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& integer(psb_ipk_), intent(in) :: sweeps real(psb_spk_),target, intent(inout) :: work(:) integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: init + type(psb_s_vect_type),intent(inout), optional :: initu integer(psb_ipk_) :: n_row,n_col, nrow_d, i real(psb_spk_), pointer :: ww(:), aux(:), tx(:),ty(:) real(psb_spk_), allocatable :: vx(:) type(psb_s_vect_type) :: vtx, vty, vww integer(psb_ipk_) :: ictxt,np,me, err_act,isz,int_err(5) - character :: trans_ + character :: trans_, init_ character(len=20) :: name='s_as_smoother_apply', ch_err call psb_erractionsave(err_act) @@ -65,6 +67,12 @@ subroutine mld_s_as_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& ictxt = desc_data%get_context() call psb_info(ictxt,me,np) + if (present(init)) then + init_ = psb_toupper(init) + else + init_='Z' + end if + trans_ = psb_toupper(trans) select case(trans_) case('N') @@ -135,7 +143,7 @@ subroutine mld_s_as_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& else if ((sm%novr == 0).and.(sweeps == 1).and.(.not.sm%sv%is_iterative())) then ! ! Shortcut: in this case it's just the same - ! as Block Jacobi. + ! as Block Jacobi. Moreover, if .not.sv%is_iterative, there's no need to pass init ! call sm%sv%apply(alpha,x,beta,y,desc_data,trans_,aux,info) @@ -240,7 +248,7 @@ subroutine mld_s_as_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& goto 9999 end select - call sm%sv%apply(sone,vtx,szero,vty,sm%desc_data,trans_,aux,info) + call sm%sv%apply(sone,vtx,szero,vty,sm%desc_data,trans_,aux,info,init='Y') if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& @@ -313,8 +321,24 @@ subroutine mld_s_as_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& ! to compute an approximate solution of a linear system. ! ! - call vty%set(szero) - + select case (init_) + case('Z') + call vty%zero() + case('Y') + call psb_geaxpby(sone,y,szero,vty,sm%desc_data,info) + case('U') + if (.not.present(initu)) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='missing initu to smoother_apply') + goto 9999 + end if + call psb_geaxpby(sone,initu,szero,vty,sm%desc_data,info) + case default + call psb_errpush(psb_err_internal_error_,name,& + & a_err='wrong init to smoother_apply') + goto 9999 + end select + do i=1, sweeps select case(trans_) case('N') @@ -401,7 +425,7 @@ subroutine mld_s_as_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& if (info /= psb_success_) exit - call sm%sv%apply(sone,vww,szero,vty,sm%desc_data,trans_,aux,info) + call sm%sv%apply(sone,vww,szero,vty,sm%desc_data,trans_,aux,info,init='Y') if (info /= psb_success_) exit diff --git a/mlprec/impl/smoother/mld_s_base_smoother_apply.f90 b/mlprec/impl/smoother/mld_s_base_smoother_apply.f90 index 4ac01f17..ea54daa5 100644 --- a/mlprec/impl/smoother/mld_s_base_smoother_apply.f90 +++ b/mlprec/impl/smoother/mld_s_base_smoother_apply.f90 @@ -36,8 +36,8 @@ !!$ POSSIBILITY OF SUCH DAMAGE. !!$ !!$ -subroutine mld_s_base_smoother_apply(alpha,sm,x,beta,y,desc_data,trans,sweeps,work,info) - +subroutine mld_s_base_smoother_apply(alpha,sm,x,beta,y,desc_data,& + & trans,sweeps,work,info,init,initu) use psb_base_mod use mld_s_base_smoother_mod, mld_protect_name => mld_s_base_smoother_apply implicit none @@ -50,6 +50,8 @@ subroutine mld_s_base_smoother_apply(alpha,sm,x,beta,y,desc_data,trans,sweeps,wo integer(psb_ipk_), intent(in) :: sweeps real(psb_spk_),target, intent(inout) :: work(:) integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: init + real(psb_spk_),intent(inout), optional :: initu(:) integer(psb_ipk_) :: err_act character(len=20) :: name='s_base_smoother_apply' @@ -66,7 +68,7 @@ subroutine mld_s_base_smoother_apply(alpha,sm,x,beta,y,desc_data,trans,sweeps,wo else if (allocated(sm%sv)) then - call sm%sv%apply(alpha,x,beta,y,desc_data,trans,work,info) + call sm%sv%apply(alpha,x,beta,y,desc_data,trans,work,info,init=init, initu=initu) else info = 1121 endif diff --git a/mlprec/impl/smoother/mld_s_base_smoother_apply_vect.f90 b/mlprec/impl/smoother/mld_s_base_smoother_apply_vect.f90 index 90e40dcc..bb6568f1 100644 --- a/mlprec/impl/smoother/mld_s_base_smoother_apply_vect.f90 +++ b/mlprec/impl/smoother/mld_s_base_smoother_apply_vect.f90 @@ -37,8 +37,7 @@ !!$ !!$ subroutine mld_s_base_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,& - - & trans,sweeps,work,info) + & trans,sweeps,work,info,init,initu) use psb_base_mod use mld_s_base_smoother_mod, mld_protect_name => mld_s_base_smoother_apply_vect implicit none @@ -51,6 +50,8 @@ subroutine mld_s_base_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,& integer(psb_ipk_), intent(in) :: sweeps real(psb_spk_),target, intent(inout) :: work(:) integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: init + type(psb_s_vect_type),intent(inout), optional :: initu integer(psb_ipk_) :: err_act character(len=20) :: name='s_base_smoother_apply' @@ -66,8 +67,8 @@ subroutine mld_s_base_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,& call psb_geaxpby(alpha,x,beta,y,desc_data,info) else - if (allocated(sm%sv)) then - call sm%sv%apply(alpha,x,beta,y,desc_data,trans,work,info) + if (allocated(sm%sv)) then + call sm%sv%apply(alpha,x,beta,y,desc_data,trans,work,info,init=init, initu=initu) else info = 1121 endif diff --git a/mlprec/impl/smoother/mld_s_jac_smoother_apply.f90 b/mlprec/impl/smoother/mld_s_jac_smoother_apply.f90 index 1d120c42..1682eb30 100644 --- a/mlprec/impl/smoother/mld_s_jac_smoother_apply.f90 +++ b/mlprec/impl/smoother/mld_s_jac_smoother_apply.f90 @@ -36,8 +36,8 @@ !!$ POSSIBILITY OF SUCH DAMAGE. !!$ !!$ -subroutine mld_s_jac_smoother_apply(alpha,sm,x,beta,y,desc_data,trans,sweeps,work,info) - +subroutine mld_s_jac_smoother_apply(alpha,sm,x,beta,y,desc_data,& + & trans,sweeps,work,info,init,initu) use psb_base_mod use mld_s_jac_smoother, mld_protect_name => mld_s_jac_smoother_apply implicit none @@ -50,17 +50,27 @@ subroutine mld_s_jac_smoother_apply(alpha,sm,x,beta,y,desc_data,trans,sweeps,wor integer(psb_ipk_), intent(in) :: sweeps real(psb_spk_),target, intent(inout) :: work(:) integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: init + real(psb_spk_),intent(inout), optional :: initu(:) integer(psb_ipk_) :: n_row,n_col - real(psb_spk_), pointer :: ww(:), aux(:), tx(:),ty(:) + real(psb_spk_), allocatable :: tx(:),ty(:) + real(psb_spk_), pointer :: ww(:), aux(:) integer(psb_ipk_) :: ictxt,np,me,i, err_act - character :: trans_ + character :: trans_, init_ character(len=20) :: name='s_jac_smoother_apply' call psb_erractionsave(err_act) info = psb_success_ + + if (present(init)) then + init_ = psb_toupper(init) + else + init_='Z' + end if + trans_ = psb_toupper(trans) select case(trans_) case('N') @@ -112,8 +122,8 @@ subroutine mld_s_jac_smoother_apply(alpha,sm,x,beta,y,desc_data,trans,sweeps,wor ! call psb_geaxpby(alpha,x,beta,y,desc_data,info) - else if ((sweeps == 1).or.(sm%nnz_nd_tot==0)) then - + else if ((.not.sm%sv%is_iterative()).and.((sweeps == 1).or.(sm%nnz_nd_tot==0))) then + ! if .not.sv%is_iterative, there's no need to pass init call sm%sv%apply(alpha,x,beta,y,desc_data,trans_,aux,info) if (info /= psb_success_) then @@ -122,38 +132,47 @@ subroutine mld_s_jac_smoother_apply(alpha,sm,x,beta,y,desc_data,trans,sweeps,wor goto 9999 endif - else if (sweeps > 1) then - + else if (sweeps >= 1) then ! ! ! Apply multiple sweeps of a block-Jacobi solver ! to compute an approximate solution of a linear system. ! ! - allocate(tx(n_col),ty(n_col),stat=info) - if (info /= psb_success_) then - info=psb_err_alloc_request_ - call psb_errpush(info,name,& - & i_err=(/2*n_col,izero,izero,izero,izero/),& - & a_err='real(psb_spk_)') - goto 9999 - end if + + call psb_geasb(tx,desc_data,info) + call psb_geasb(ty,desc_data,info) + + select case (init_) + case('Z') + tx(:) = szero + case('Y') + call psb_geaxpby(sone,y,szero,tx,desc_data,info) + case('U') + if (.not.present(initu)) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='missing initu to smoother_apply') + goto 9999 + end if + call psb_geaxpby(sone,initu,szero,tx,desc_data,info) + case default + call psb_errpush(psb_err_internal_error_,name,& + & a_err='wrong init to smoother_apply') + goto 9999 + end select - tx = szero - ty = szero do i=1, sweeps ! ! Compute Y(j+1) = D^(-1)*(X-ND*Y(j)), where D and ND are the ! block diagonal part and the remaining part of the local matrix ! and Y(j) is the approximate solution at sweep j. ! - ty(1:n_row) = x(1:n_row) - call psb_spmm(-sone,sm%nd,tx,sone,ty,desc_data,info,& - & work=aux,trans=trans_) + call psb_geaxpby(sone,x,szero,ty,desc_data,info) + call psb_spmm(-sone,sm%nd,tx,sone,ty,desc_data,info,work=aux,trans=trans_) if (info /= psb_success_) exit - call sm%sv%apply(sone,ty,szero,tx,desc_data,trans_,aux,info) + call sm%sv%apply(sone,ty,szero,tx,desc_data,trans_,aux,info,init='Y') if (info /= psb_success_) exit end do diff --git a/mlprec/impl/smoother/mld_s_jac_smoother_apply_vect.f90 b/mlprec/impl/smoother/mld_s_jac_smoother_apply_vect.f90 index b6f5b3c5..402243b9 100644 --- a/mlprec/impl/smoother/mld_s_jac_smoother_apply_vect.f90 +++ b/mlprec/impl/smoother/mld_s_jac_smoother_apply_vect.f90 @@ -37,7 +37,7 @@ !!$ !!$ subroutine mld_s_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& - & sweeps,work,info) + & sweeps,work,info,init,initu) use psb_base_mod use mld_s_jac_smoother, mld_protect_name => mld_s_jac_smoother_apply_vect @@ -51,23 +51,31 @@ subroutine mld_s_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& integer(psb_ipk_), intent(in) :: sweeps real(psb_spk_),target, intent(inout) :: work(:) integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: init + type(psb_s_vect_type),intent(inout), optional :: initu integer(psb_ipk_) :: n_row,n_col type(psb_s_vect_type) :: tx, ty real(psb_spk_), pointer :: ww(:), aux(:) integer(psb_ipk_) :: ictxt,np,me,i, err_act - character :: trans_ + character :: trans_, init_ character(len=20) :: name='s_jac_smoother_apply' call psb_erractionsave(err_act) info = psb_success_ + + if (present(init)) then + init_ = psb_toupper(init) + else + init_='Z' + end if + trans_ = psb_toupper(trans) select case(trans_) case('N') - case('T') - case('C') + case('T','C') case default call psb_errpush(psb_err_iarg_invalid_i_,name) goto 9999 @@ -107,8 +115,6 @@ subroutine mld_s_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& end if endif -!!$ write(0,*) 'Jacobi smoother with ',sweeps - if (sweeps == 0) then ! @@ -118,7 +124,7 @@ subroutine mld_s_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& call psb_geaxpby(alpha,x,beta,y,desc_data,info) else if ((.not.sm%sv%is_iterative()).and.((sweeps == 1).or.(sm%nnz_nd_tot==0))) then - + ! if .not.sv%is_iterative, there's no need to pass init call sm%sv%apply(alpha,x,beta,y,desc_data,trans_,aux,info) if (info /= psb_success_) then @@ -134,9 +140,27 @@ subroutine mld_s_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& ! to compute an approximate solution of a linear system. ! ! - call tx%bld(x%get_nrows(),mold=x%v) - call tx%set(szero) - call ty%bld(x%get_nrows(),mold=x%v) + + call psb_geasb(tx,desc_data,info,mold=x%v,scratch=.true.) + call psb_geasb(ty,desc_data,info,mold=x%v,scratch=.true.) + + select case (init_) + case('Z') + call tx%zero() + case('Y') + call psb_geaxpby(sone,y,szero,tx,desc_data,info) + case('U') + if (.not.present(initu)) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='missing initu to smoother_apply') + goto 9999 + end if + call psb_geaxpby(sone,initu,szero,tx,desc_data,info) + case default + call psb_errpush(psb_err_internal_error_,name,& + & a_err='wrong init to smoother_apply') + goto 9999 + end select do i=1, sweeps ! @@ -149,7 +173,7 @@ subroutine mld_s_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& if (info /= psb_success_) exit - call sm%sv%apply(sone,ty,szero,tx,desc_data,trans_,aux,info) + call sm%sv%apply(sone,ty,szero,tx,desc_data,trans_,aux,info,init='Y') if (info /= psb_success_) exit end do diff --git a/mlprec/impl/smoother/mld_z_as_smoother_apply.f90 b/mlprec/impl/smoother/mld_z_as_smoother_apply.f90 index a935d3fa..5a98958d 100644 --- a/mlprec/impl/smoother/mld_z_as_smoother_apply.f90 +++ b/mlprec/impl/smoother/mld_z_as_smoother_apply.f90 @@ -36,8 +36,8 @@ !!$ POSSIBILITY OF SUCH DAMAGE. !!$ !!$ -subroutine mld_z_as_smoother_apply(alpha,sm,x,beta,y,desc_data,trans,sweeps,work,info) - +subroutine mld_z_as_smoother_apply(alpha,sm,x,beta,y,desc_data,trans,& + & sweeps,work,info,init,initu) use psb_base_mod use mld_z_as_smoother, mld_protect_nam => mld_z_as_smoother_apply implicit none @@ -50,18 +50,26 @@ subroutine mld_z_as_smoother_apply(alpha,sm,x,beta,y,desc_data,trans,sweeps,work integer(psb_ipk_), intent(in) :: sweeps complex(psb_dpk_),target, intent(inout) :: work(:) integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: init + complex(psb_dpk_),intent(inout), optional :: initu(:) integer(psb_ipk_) :: n_row,n_col, nrow_d, i complex(psb_dpk_), pointer :: ww(:), aux(:), tx(:),ty(:) integer(psb_ipk_) :: ictxt,np,me, err_act,isz,int_err(5) - character :: trans_ + character :: trans_, init_ character(len=20) :: name='z_as_smoother_apply', ch_err call psb_erractionsave(err_act) info = psb_success_ ictxt = desc_data%get_context() - call psb_info (ictxt,me,np) + call psb_info(ictxt,me,np) + + if (present(init)) then + init_ = psb_toupper(init) + else + init_='Z' + end if trans_ = psb_toupper(trans) select case(trans_) @@ -83,7 +91,8 @@ subroutine mld_z_as_smoother_apply(alpha,sm,x,beta,y,desc_data,trans,sweeps,work n_row = sm%desc_data%get_local_rows() n_col = sm%desc_data%get_local_cols() nrow_d = desc_data%get_local_rows() - isz=max(n_row,N_COL) + isz = max(n_row,N_COL) + if ((6*isz) <= size(work)) then ww => work(1:isz) tx => work(isz+1:2*isz) @@ -129,10 +138,10 @@ subroutine mld_z_as_smoother_apply(alpha,sm,x,beta,y,desc_data,trans,sweeps,work ! call psb_geaxpby(alpha,x,beta,y,desc_data,info) - else if ((sm%novr == 0).and.(sweeps == 1)) then + else if ((sm%novr == 0).and.(sweeps == 1).and.(.not.sm%sv%is_iterative())) then ! ! Shortcut: in this case it's just the same - ! as Block Jacobi. + ! as Block Jacobi. Moreover, if .not.sv%is_iterative, there's no need to pass init ! call sm%sv%apply(alpha,x,beta,y,desc_data,trans_,aux,info) @@ -226,7 +235,7 @@ subroutine mld_z_as_smoother_apply(alpha,sm,x,beta,y,desc_data,trans,sweeps,work goto 9999 end select - call sm%sv%apply(zone,tx,zzero,ty,sm%desc_data,trans_,aux,info) + call sm%sv%apply(zone,tx,zzero,ty,sm%desc_data,trans_,aux,info,init='Y') if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& @@ -299,7 +308,24 @@ subroutine mld_z_as_smoother_apply(alpha,sm,x,beta,y,desc_data,trans,sweeps,work ! to compute an approximate solution of a linear system. ! ! - ty = zzero + select case (init_) + case('Z') + ty = zzero + case('Y') + call psb_geaxpby(zone,y,zzero,ty,sm%desc_data,info) + case('U') + if (.not.present(initu)) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='missing initu to smoother_apply') + goto 9999 + end if + call psb_geaxpby(zone,initu,zzero,ty,sm%desc_data,info) + case default + call psb_errpush(psb_err_internal_error_,name,& + & a_err='wrong init to smoother_apply') + goto 9999 + end select + do i=1, sweeps select case(trans_) case('N') @@ -386,7 +412,7 @@ subroutine mld_z_as_smoother_apply(alpha,sm,x,beta,y,desc_data,trans,sweeps,work if (info /= psb_success_) exit - call sm%sv%apply(zone,ww,zzero,ty,sm%desc_data,trans_,aux,info) + call sm%sv%apply(zone,ww,zzero,ty,sm%desc_data,trans_,aux,info,init='Y') if (info /= psb_success_) exit diff --git a/mlprec/impl/smoother/mld_z_as_smoother_apply_vect.f90 b/mlprec/impl/smoother/mld_z_as_smoother_apply_vect.f90 index 16a6f2bc..bccc1299 100644 --- a/mlprec/impl/smoother/mld_z_as_smoother_apply_vect.f90 +++ b/mlprec/impl/smoother/mld_z_as_smoother_apply_vect.f90 @@ -37,7 +37,7 @@ !!$ !!$ subroutine mld_z_as_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& - & sweeps,work,info) + & sweeps,work,info,init,initu) use psb_base_mod use mld_z_as_smoother, mld_protect_nam => mld_z_as_smoother_apply_vect implicit none @@ -50,13 +50,15 @@ subroutine mld_z_as_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& integer(psb_ipk_), intent(in) :: sweeps complex(psb_dpk_),target, intent(inout) :: work(:) integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: init + type(psb_z_vect_type),intent(inout), optional :: initu integer(psb_ipk_) :: n_row,n_col, nrow_d, i complex(psb_dpk_), pointer :: ww(:), aux(:), tx(:),ty(:) complex(psb_dpk_), allocatable :: vx(:) type(psb_z_vect_type) :: vtx, vty, vww integer(psb_ipk_) :: ictxt,np,me, err_act,isz,int_err(5) - character :: trans_ + character :: trans_, init_ character(len=20) :: name='z_as_smoother_apply', ch_err call psb_erractionsave(err_act) @@ -65,6 +67,12 @@ subroutine mld_z_as_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& ictxt = desc_data%get_context() call psb_info(ictxt,me,np) + if (present(init)) then + init_ = psb_toupper(init) + else + init_='Z' + end if + trans_ = psb_toupper(trans) select case(trans_) case('N') @@ -135,7 +143,7 @@ subroutine mld_z_as_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& else if ((sm%novr == 0).and.(sweeps == 1).and.(.not.sm%sv%is_iterative())) then ! ! Shortcut: in this case it's just the same - ! as Block Jacobi. + ! as Block Jacobi. Moreover, if .not.sv%is_iterative, there's no need to pass init ! call sm%sv%apply(alpha,x,beta,y,desc_data,trans_,aux,info) @@ -240,7 +248,7 @@ subroutine mld_z_as_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& goto 9999 end select - call sm%sv%apply(zone,vtx,zzero,vty,sm%desc_data,trans_,aux,info) + call sm%sv%apply(zone,vtx,zzero,vty,sm%desc_data,trans_,aux,info,init='Y') if (info /= psb_success_) then call psb_errpush(psb_err_internal_error_,name,& @@ -313,8 +321,24 @@ subroutine mld_z_as_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& ! to compute an approximate solution of a linear system. ! ! - call vty%set(zzero) - + select case (init_) + case('Z') + call vty%zero() + case('Y') + call psb_geaxpby(zone,y,zzero,vty,sm%desc_data,info) + case('U') + if (.not.present(initu)) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='missing initu to smoother_apply') + goto 9999 + end if + call psb_geaxpby(zone,initu,zzero,vty,sm%desc_data,info) + case default + call psb_errpush(psb_err_internal_error_,name,& + & a_err='wrong init to smoother_apply') + goto 9999 + end select + do i=1, sweeps select case(trans_) case('N') @@ -401,7 +425,7 @@ subroutine mld_z_as_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& if (info /= psb_success_) exit - call sm%sv%apply(zone,vww,zzero,vty,sm%desc_data,trans_,aux,info) + call sm%sv%apply(zone,vww,zzero,vty,sm%desc_data,trans_,aux,info,init='Y') if (info /= psb_success_) exit diff --git a/mlprec/impl/smoother/mld_z_base_smoother_apply.f90 b/mlprec/impl/smoother/mld_z_base_smoother_apply.f90 index 66d1f841..5b97f458 100644 --- a/mlprec/impl/smoother/mld_z_base_smoother_apply.f90 +++ b/mlprec/impl/smoother/mld_z_base_smoother_apply.f90 @@ -36,8 +36,8 @@ !!$ POSSIBILITY OF SUCH DAMAGE. !!$ !!$ -subroutine mld_z_base_smoother_apply(alpha,sm,x,beta,y,desc_data,trans,sweeps,work,info) - +subroutine mld_z_base_smoother_apply(alpha,sm,x,beta,y,desc_data,& + & trans,sweeps,work,info,init,initu) use psb_base_mod use mld_z_base_smoother_mod, mld_protect_name => mld_z_base_smoother_apply implicit none @@ -50,6 +50,8 @@ subroutine mld_z_base_smoother_apply(alpha,sm,x,beta,y,desc_data,trans,sweeps,wo integer(psb_ipk_), intent(in) :: sweeps complex(psb_dpk_),target, intent(inout) :: work(:) integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: init + complex(psb_dpk_),intent(inout), optional :: initu(:) integer(psb_ipk_) :: err_act character(len=20) :: name='z_base_smoother_apply' @@ -66,7 +68,7 @@ subroutine mld_z_base_smoother_apply(alpha,sm,x,beta,y,desc_data,trans,sweeps,wo else if (allocated(sm%sv)) then - call sm%sv%apply(alpha,x,beta,y,desc_data,trans,work,info) + call sm%sv%apply(alpha,x,beta,y,desc_data,trans,work,info,init=init, initu=initu) else info = 1121 endif diff --git a/mlprec/impl/smoother/mld_z_base_smoother_apply_vect.f90 b/mlprec/impl/smoother/mld_z_base_smoother_apply_vect.f90 index c481a227..e7b02001 100644 --- a/mlprec/impl/smoother/mld_z_base_smoother_apply_vect.f90 +++ b/mlprec/impl/smoother/mld_z_base_smoother_apply_vect.f90 @@ -37,8 +37,7 @@ !!$ !!$ subroutine mld_z_base_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,& - - & trans,sweeps,work,info) + & trans,sweeps,work,info,init,initu) use psb_base_mod use mld_z_base_smoother_mod, mld_protect_name => mld_z_base_smoother_apply_vect implicit none @@ -51,6 +50,8 @@ subroutine mld_z_base_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,& integer(psb_ipk_), intent(in) :: sweeps complex(psb_dpk_),target, intent(inout) :: work(:) integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: init + type(psb_z_vect_type),intent(inout), optional :: initu integer(psb_ipk_) :: err_act character(len=20) :: name='z_base_smoother_apply' @@ -66,8 +67,8 @@ subroutine mld_z_base_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,& call psb_geaxpby(alpha,x,beta,y,desc_data,info) else - if (allocated(sm%sv)) then - call sm%sv%apply(alpha,x,beta,y,desc_data,trans,work,info) + if (allocated(sm%sv)) then + call sm%sv%apply(alpha,x,beta,y,desc_data,trans,work,info,init=init, initu=initu) else info = 1121 endif diff --git a/mlprec/impl/smoother/mld_z_jac_smoother_apply.f90 b/mlprec/impl/smoother/mld_z_jac_smoother_apply.f90 index e13907a7..a5231534 100644 --- a/mlprec/impl/smoother/mld_z_jac_smoother_apply.f90 +++ b/mlprec/impl/smoother/mld_z_jac_smoother_apply.f90 @@ -36,8 +36,8 @@ !!$ POSSIBILITY OF SUCH DAMAGE. !!$ !!$ -subroutine mld_z_jac_smoother_apply(alpha,sm,x,beta,y,desc_data,trans,sweeps,work,info) - +subroutine mld_z_jac_smoother_apply(alpha,sm,x,beta,y,desc_data,& + & trans,sweeps,work,info,init,initu) use psb_base_mod use mld_z_jac_smoother, mld_protect_name => mld_z_jac_smoother_apply implicit none @@ -50,17 +50,27 @@ subroutine mld_z_jac_smoother_apply(alpha,sm,x,beta,y,desc_data,trans,sweeps,wor integer(psb_ipk_), intent(in) :: sweeps complex(psb_dpk_),target, intent(inout) :: work(:) integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: init + complex(psb_dpk_),intent(inout), optional :: initu(:) integer(psb_ipk_) :: n_row,n_col - complex(psb_dpk_), pointer :: ww(:), aux(:), tx(:),ty(:) + complex(psb_dpk_), allocatable :: tx(:),ty(:) + complex(psb_dpk_), pointer :: ww(:), aux(:) integer(psb_ipk_) :: ictxt,np,me,i, err_act - character :: trans_ + character :: trans_, init_ character(len=20) :: name='z_jac_smoother_apply' call psb_erractionsave(err_act) info = psb_success_ + + if (present(init)) then + init_ = psb_toupper(init) + else + init_='Z' + end if + trans_ = psb_toupper(trans) select case(trans_) case('N') @@ -112,8 +122,8 @@ subroutine mld_z_jac_smoother_apply(alpha,sm,x,beta,y,desc_data,trans,sweeps,wor ! call psb_geaxpby(alpha,x,beta,y,desc_data,info) - else if ((sweeps == 1).or.(sm%nnz_nd_tot==0)) then - + else if ((.not.sm%sv%is_iterative()).and.((sweeps == 1).or.(sm%nnz_nd_tot==0))) then + ! if .not.sv%is_iterative, there's no need to pass init call sm%sv%apply(alpha,x,beta,y,desc_data,trans_,aux,info) if (info /= psb_success_) then @@ -122,38 +132,47 @@ subroutine mld_z_jac_smoother_apply(alpha,sm,x,beta,y,desc_data,trans,sweeps,wor goto 9999 endif - else if (sweeps > 1) then - + else if (sweeps >= 1) then ! ! ! Apply multiple sweeps of a block-Jacobi solver ! to compute an approximate solution of a linear system. ! ! - allocate(tx(n_col),ty(n_col),stat=info) - if (info /= psb_success_) then - info=psb_err_alloc_request_ - call psb_errpush(info,name,& - & i_err=(/2*n_col,izero,izero,izero,izero/),& - & a_err='complex(psb_dpk_)') - goto 9999 - end if + + call psb_geasb(tx,desc_data,info) + call psb_geasb(ty,desc_data,info) + + select case (init_) + case('Z') + tx(:) = zzero + case('Y') + call psb_geaxpby(zone,y,zzero,tx,desc_data,info) + case('U') + if (.not.present(initu)) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='missing initu to smoother_apply') + goto 9999 + end if + call psb_geaxpby(zone,initu,zzero,tx,desc_data,info) + case default + call psb_errpush(psb_err_internal_error_,name,& + & a_err='wrong init to smoother_apply') + goto 9999 + end select - tx = zzero - ty = zzero do i=1, sweeps ! ! Compute Y(j+1) = D^(-1)*(X-ND*Y(j)), where D and ND are the ! block diagonal part and the remaining part of the local matrix ! and Y(j) is the approximate solution at sweep j. ! - ty(1:n_row) = x(1:n_row) - call psb_spmm(-zone,sm%nd,tx,zone,ty,desc_data,info,& - & work=aux,trans=trans_) + call psb_geaxpby(zone,x,zzero,ty,desc_data,info) + call psb_spmm(-zone,sm%nd,tx,zone,ty,desc_data,info,work=aux,trans=trans_) if (info /= psb_success_) exit - call sm%sv%apply(zone,ty,zzero,tx,desc_data,trans_,aux,info) + call sm%sv%apply(zone,ty,zzero,tx,desc_data,trans_,aux,info,init='Y') if (info /= psb_success_) exit end do diff --git a/mlprec/impl/smoother/mld_z_jac_smoother_apply_vect.f90 b/mlprec/impl/smoother/mld_z_jac_smoother_apply_vect.f90 index a4f8fcd4..19979755 100644 --- a/mlprec/impl/smoother/mld_z_jac_smoother_apply_vect.f90 +++ b/mlprec/impl/smoother/mld_z_jac_smoother_apply_vect.f90 @@ -37,7 +37,7 @@ !!$ !!$ subroutine mld_z_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& - & sweeps,work,info) + & sweeps,work,info,init,initu) use psb_base_mod use mld_z_jac_smoother, mld_protect_name => mld_z_jac_smoother_apply_vect @@ -51,23 +51,31 @@ subroutine mld_z_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& integer(psb_ipk_), intent(in) :: sweeps complex(psb_dpk_),target, intent(inout) :: work(:) integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: init + type(psb_z_vect_type),intent(inout), optional :: initu integer(psb_ipk_) :: n_row,n_col type(psb_z_vect_type) :: tx, ty complex(psb_dpk_), pointer :: ww(:), aux(:) integer(psb_ipk_) :: ictxt,np,me,i, err_act - character :: trans_ + character :: trans_, init_ character(len=20) :: name='z_jac_smoother_apply' call psb_erractionsave(err_act) info = psb_success_ + + if (present(init)) then + init_ = psb_toupper(init) + else + init_='Z' + end if + trans_ = psb_toupper(trans) select case(trans_) case('N') - case('T') - case('C') + case('T','C') case default call psb_errpush(psb_err_iarg_invalid_i_,name) goto 9999 @@ -107,8 +115,6 @@ subroutine mld_z_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& end if endif -!!$ write(0,*) 'Jacobi smoother with ',sweeps - if (sweeps == 0) then ! @@ -118,7 +124,7 @@ subroutine mld_z_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& call psb_geaxpby(alpha,x,beta,y,desc_data,info) else if ((.not.sm%sv%is_iterative()).and.((sweeps == 1).or.(sm%nnz_nd_tot==0))) then - + ! if .not.sv%is_iterative, there's no need to pass init call sm%sv%apply(alpha,x,beta,y,desc_data,trans_,aux,info) if (info /= psb_success_) then @@ -134,9 +140,27 @@ subroutine mld_z_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& ! to compute an approximate solution of a linear system. ! ! - call tx%bld(x%get_nrows(),mold=x%v) - call tx%set(zzero) - call ty%bld(x%get_nrows(),mold=x%v) + + call psb_geasb(tx,desc_data,info,mold=x%v,scratch=.true.) + call psb_geasb(ty,desc_data,info,mold=x%v,scratch=.true.) + + select case (init_) + case('Z') + call tx%zero() + case('Y') + call psb_geaxpby(zone,y,zzero,tx,desc_data,info) + case('U') + if (.not.present(initu)) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='missing initu to smoother_apply') + goto 9999 + end if + call psb_geaxpby(zone,initu,zzero,tx,desc_data,info) + case default + call psb_errpush(psb_err_internal_error_,name,& + & a_err='wrong init to smoother_apply') + goto 9999 + end select do i=1, sweeps ! @@ -149,7 +173,7 @@ subroutine mld_z_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& if (info /= psb_success_) exit - call sm%sv%apply(zone,ty,zzero,tx,desc_data,trans_,aux,info) + call sm%sv%apply(zone,ty,zzero,tx,desc_data,trans_,aux,info,init='Y') if (info /= psb_success_) exit end do diff --git a/mlprec/impl/solver/mld_c_base_solver_apply.f90 b/mlprec/impl/solver/mld_c_base_solver_apply.f90 index d49ddafb..6fc8db92 100644 --- a/mlprec/impl/solver/mld_c_base_solver_apply.f90 +++ b/mlprec/impl/solver/mld_c_base_solver_apply.f90 @@ -36,7 +36,8 @@ !!$ POSSIBILITY OF SUCH DAMAGE. !!$ !!$ -subroutine mld_c_base_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info) +subroutine mld_c_base_solver_apply(alpha,sv,x,beta,y,desc_data,& + & trans,work,info,init,initu) use psb_base_mod use mld_c_base_solver_mod, mld_protect_name => mld_c_base_solver_apply @@ -49,6 +50,8 @@ subroutine mld_c_base_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info) character(len=1),intent(in) :: trans complex(psb_spk_),target, intent(inout) :: work(:) integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: init + complex(psb_spk_),intent(inout), optional :: initu(:) integer(psb_ipk_) :: err_act character(len=20) :: name='c_base_solver_apply' diff --git a/mlprec/impl/solver/mld_c_base_solver_apply_vect.f90 b/mlprec/impl/solver/mld_c_base_solver_apply_vect.f90 index 1cb62dd8..adbd82e2 100644 --- a/mlprec/impl/solver/mld_c_base_solver_apply_vect.f90 +++ b/mlprec/impl/solver/mld_c_base_solver_apply_vect.f90 @@ -36,7 +36,8 @@ !!$ POSSIBILITY OF SUCH DAMAGE. !!$ !!$ -subroutine mld_c_base_solver_apply_vect(alpha,sv,x,beta,y,desc_data,trans,work,info) +subroutine mld_c_base_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& + & trans,work,info,init,initu) use psb_base_mod use mld_c_base_solver_mod, mld_protect_name => mld_c_base_solver_apply_vect @@ -49,6 +50,8 @@ subroutine mld_c_base_solver_apply_vect(alpha,sv,x,beta,y,desc_data,trans,work,i character(len=1),intent(in) :: trans complex(psb_spk_),target, intent(inout) :: work(:) integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: init + type(psb_c_vect_type),intent(inout), optional :: initu integer(psb_ipk_) :: err_act character(len=20) :: name='c_base_solver_apply_vect' diff --git a/mlprec/impl/solver/mld_c_bwgs_solver_apply.f90 b/mlprec/impl/solver/mld_c_bwgs_solver_apply.f90 index ab47f90f..9c328f2f 100644 --- a/mlprec/impl/solver/mld_c_bwgs_solver_apply.f90 +++ b/mlprec/impl/solver/mld_c_bwgs_solver_apply.f90 @@ -36,7 +36,8 @@ !!$ POSSIBILITY OF SUCH DAMAGE. !!$ !!$ -subroutine mld_c_bwgs_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info) +subroutine mld_c_bwgs_solver_apply(alpha,sv,x,beta,y,desc_data,& + &trans,work,info,init,initu) use psb_base_mod use mld_c_gs_solver, mld_protect_name => mld_c_bwgs_solver_apply @@ -49,13 +50,15 @@ subroutine mld_c_bwgs_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info) character(len=1),intent(in) :: trans complex(psb_spk_),target, intent(inout) :: work(:) integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: init + complex(psb_spk_),intent(inout), optional :: initu(:) 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' + character :: trans_, init_ + character(len=20) :: name='c_bwgs_solver_apply' call psb_erractionsave(err_act) ictxt = desc_data%get_ctxt() @@ -71,6 +74,13 @@ subroutine mld_c_bwgs_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info) call psb_errpush(psb_err_iarg_invalid_i_,name) goto 9999 end select + + if (present(init)) then + init_ = psb_toupper(init) + else + init_='Z' + end if + n_row = desc_data%get_local_rows() n_col = desc_data%get_local_cols() @@ -108,9 +118,26 @@ subroutine mld_c_bwgs_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info) goto 9999 end if - call psb_geasb(wv,desc_data,info) - call psb_geasb(xit,desc_data,info) - + call psb_geasb(wv,desc_data,info) + call psb_geasb(xit,desc_data,info) + select case (init_) + case('Z') + xit(:) = czero + case('Y') + call psb_geaxpby(cone,y,czero,xit,desc_data,info) + case('U') + if (.not.present(initu)) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='missing initu to smoother_apply') + goto 9999 + end if + call psb_geaxpby(cone,initu,czero,xit,desc_data,info) + case default + call psb_errpush(psb_err_internal_error_,name,& + & a_err='wrong init to smoother_apply') + goto 9999 + end select + select case(trans_) case('N') if (sv%eps <=szero) then @@ -118,21 +145,12 @@ subroutine mld_c_bwgs_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info) ! 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) diff --git a/mlprec/impl/solver/mld_c_bwgs_solver_apply_vect.f90 b/mlprec/impl/solver/mld_c_bwgs_solver_apply_vect.f90 index 101eb073..4c058930 100644 --- a/mlprec/impl/solver/mld_c_bwgs_solver_apply_vect.f90 +++ b/mlprec/impl/solver/mld_c_bwgs_solver_apply_vect.f90 @@ -36,7 +36,8 @@ !!$ POSSIBILITY OF SUCH DAMAGE. !!$ !!$ -subroutine mld_c_bwgs_solver_apply_vect(alpha,sv,x,beta,y,desc_data,trans,work,info) +subroutine mld_c_bwgs_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& + & trans,work,info,init,initu) use psb_base_mod use mld_c_gs_solver, mld_protect_name => mld_c_bwgs_solver_apply_vect @@ -49,14 +50,16 @@ subroutine mld_c_bwgs_solver_apply_vect(alpha,sv,x,beta,y,desc_data,trans,work,i character(len=1),intent(in) :: trans complex(psb_spk_),target, intent(inout) :: work(:) integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: init + type(psb_c_vect_type),intent(inout), optional :: initu 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' + character :: trans_, init_ + character(len=20) :: name='c_bwgs_solver_apply' call psb_erractionsave(err_act) ictxt = desc_data%get_ctxt() @@ -72,6 +75,13 @@ subroutine mld_c_bwgs_solver_apply_vect(alpha,sv,x,beta,y,desc_data,trans,work,i call psb_errpush(psb_err_iarg_invalid_i_,name) goto 9999 end select + + if (present(init)) then + init_ = psb_toupper(init) + else + init_='Z' + end if + n_row = desc_data%get_local_rows() n_col = desc_data%get_local_cols() @@ -113,7 +123,24 @@ subroutine mld_c_bwgs_solver_apply_vect(alpha,sv,x,beta,y,desc_data,trans,work,i 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 (init_) + case('Z') + call xit%zero() + case('Y') + call psb_geaxpby(cone,y,czero,xit,desc_data,info) + case('U') + if (.not.present(initu)) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='missing initu to smoother_apply') + goto 9999 + end if + call psb_geaxpby(cone,initu,czero,xit,desc_data,info) + case default + call psb_errpush(psb_err_internal_error_,name,& + & a_err='wrong init to smoother_apply') + goto 9999 + end select + select case(trans_) case('N') if (sv%eps <=szero) then @@ -121,21 +148,12 @@ subroutine mld_c_bwgs_solver_apply_vect(alpha,sv,x,beta,y,desc_data,trans,work,i ! 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) diff --git a/mlprec/impl/solver/mld_c_diag_solver_apply.f90 b/mlprec/impl/solver/mld_c_diag_solver_apply.f90 index 44727a33..3e202fb8 100644 --- a/mlprec/impl/solver/mld_c_diag_solver_apply.f90 +++ b/mlprec/impl/solver/mld_c_diag_solver_apply.f90 @@ -36,7 +36,8 @@ !!$ POSSIBILITY OF SUCH DAMAGE. !!$ !!$ -subroutine mld_c_diag_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info) +subroutine mld_c_diag_solver_apply(alpha,sv,x,beta,y,desc_data,& + & trans,work,info,init,initu) use psb_base_mod use mld_c_diag_solver, mld_protect_name => mld_c_diag_solver_apply @@ -49,6 +50,8 @@ subroutine mld_c_diag_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info) character(len=1),intent(in) :: trans complex(psb_spk_),target, intent(inout) :: work(:) integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: init + complex(psb_spk_),intent(inout), optional :: initu(:) integer(psb_ipk_) :: n_row,n_col complex(psb_spk_), pointer :: ww(:), aux(:), tx(:),ty(:) @@ -68,7 +71,10 @@ subroutine mld_c_diag_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info) call psb_errpush(psb_err_iarg_invalid_i_,name) goto 9999 end select - + ! + ! For non-iterative solvers, init and initu are ignored. + ! + n_row = desc_data%get_local_rows() n_col = desc_data%get_local_cols() diff --git a/mlprec/impl/solver/mld_c_diag_solver_apply_vect.f90 b/mlprec/impl/solver/mld_c_diag_solver_apply_vect.f90 index d5efcb51..f7b401fa 100644 --- a/mlprec/impl/solver/mld_c_diag_solver_apply_vect.f90 +++ b/mlprec/impl/solver/mld_c_diag_solver_apply_vect.f90 @@ -36,7 +36,8 @@ !!$ POSSIBILITY OF SUCH DAMAGE. !!$ !!$ -subroutine mld_c_diag_solver_apply_vect(alpha,sv,x,beta,y,desc_data,trans,work,info) +subroutine mld_c_diag_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& + & trans,work,info,init,initu) use psb_base_mod use mld_c_diag_solver, mld_protect_name => mld_c_diag_solver_apply_vect @@ -49,6 +50,8 @@ subroutine mld_c_diag_solver_apply_vect(alpha,sv,x,beta,y,desc_data,trans,work,i character(len=1),intent(in) :: trans complex(psb_spk_),target, intent(inout) :: work(:) integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: init + type(psb_c_vect_type),intent(inout), optional :: initu integer(psb_ipk_) :: n_row,n_col complex(psb_spk_), pointer :: ww(:), aux(:), tx(:),ty(:) @@ -68,6 +71,9 @@ subroutine mld_c_diag_solver_apply_vect(alpha,sv,x,beta,y,desc_data,trans,work,i call psb_errpush(psb_err_iarg_invalid_i_,name) goto 9999 end select + ! + ! For non-iterative solvers, init and initu are ignored. + ! n_row = desc_data%get_local_rows() n_col = desc_data%get_local_cols() diff --git a/mlprec/impl/solver/mld_c_gs_solver_apply.f90 b/mlprec/impl/solver/mld_c_gs_solver_apply.f90 index acd2366c..3f9321cd 100644 --- a/mlprec/impl/solver/mld_c_gs_solver_apply.f90 +++ b/mlprec/impl/solver/mld_c_gs_solver_apply.f90 @@ -36,7 +36,8 @@ !!$ POSSIBILITY OF SUCH DAMAGE. !!$ !!$ -subroutine mld_c_gs_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info) +subroutine mld_c_gs_solver_apply(alpha,sv,x,beta,y,desc_data,& + &trans,work,info,init,initu) use psb_base_mod use mld_c_gs_solver, mld_protect_name => mld_c_gs_solver_apply @@ -49,12 +50,14 @@ subroutine mld_c_gs_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info) character(len=1),intent(in) :: trans complex(psb_spk_),target, intent(inout) :: work(:) integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: init + complex(psb_spk_),intent(inout), optional :: initu(:) 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 :: trans_, init_ character(len=20) :: name='c_gs_solver_apply' call psb_erractionsave(err_act) @@ -71,6 +74,13 @@ subroutine mld_c_gs_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info) call psb_errpush(psb_err_iarg_invalid_i_,name) goto 9999 end select + + if (present(init)) then + init_ = psb_toupper(init) + else + init_='Z' + end if + n_row = desc_data%get_local_rows() n_col = desc_data%get_local_cols() @@ -108,9 +118,26 @@ subroutine mld_c_gs_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info) goto 9999 end if - call psb_geasb(wv,desc_data,info) - call psb_geasb(xit,desc_data,info) - + call psb_geasb(wv,desc_data,info) + call psb_geasb(xit,desc_data,info) + select case (init_) + case('Z') + xit(:) = czero + case('Y') + call psb_geaxpby(cone,y,czero,xit,desc_data,info) + case('U') + if (.not.present(initu)) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='missing initu to smoother_apply') + goto 9999 + end if + call psb_geaxpby(cone,initu,czero,xit,desc_data,info) + case default + call psb_errpush(psb_err_internal_error_,name,& + & a_err='wrong init to smoother_apply') + goto 9999 + end select + select case(trans_) case('N') if (sv%eps <=szero) then @@ -118,21 +145,12 @@ subroutine mld_c_gs_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info) ! 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 U. The off-diagonal block is taken care ! from the Jacobi smoother, hence this is purely local. call psb_spmm(-cone,sv%u,xit,cone,wv,desc_data,info,doswap=.false.) call psb_spsm(cone,sv%l,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) diff --git a/mlprec/impl/solver/mld_c_gs_solver_apply_vect.f90 b/mlprec/impl/solver/mld_c_gs_solver_apply_vect.f90 index 6a8bfca2..0f70d00e 100644 --- a/mlprec/impl/solver/mld_c_gs_solver_apply_vect.f90 +++ b/mlprec/impl/solver/mld_c_gs_solver_apply_vect.f90 @@ -36,7 +36,8 @@ !!$ POSSIBILITY OF SUCH DAMAGE. !!$ !!$ -subroutine mld_c_gs_solver_apply_vect(alpha,sv,x,beta,y,desc_data,trans,work,info) +subroutine mld_c_gs_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& + & trans,work,info,init,initu) use psb_base_mod use mld_c_gs_solver, mld_protect_name => mld_c_gs_solver_apply_vect @@ -49,13 +50,15 @@ subroutine mld_c_gs_solver_apply_vect(alpha,sv,x,beta,y,desc_data,trans,work,inf character(len=1),intent(in) :: trans complex(psb_spk_),target, intent(inout) :: work(:) integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: init + type(psb_c_vect_type),intent(inout), optional :: initu 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 :: trans_, init_ character(len=20) :: name='c_gs_solver_apply' call psb_erractionsave(err_act) @@ -72,6 +75,13 @@ subroutine mld_c_gs_solver_apply_vect(alpha,sv,x,beta,y,desc_data,trans,work,inf call psb_errpush(psb_err_iarg_invalid_i_,name) goto 9999 end select + + if (present(init)) then + init_ = psb_toupper(init) + else + init_='Z' + end if + n_row = desc_data%get_local_rows() n_col = desc_data%get_local_cols() @@ -113,7 +123,24 @@ subroutine mld_c_gs_solver_apply_vect(alpha,sv,x,beta,y,desc_data,trans,work,inf 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 (init_) + case('Z') + call xit%zero() + case('Y') + call psb_geaxpby(cone,y,czero,xit,desc_data,info) + case('U') + if (.not.present(initu)) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='missing initu to smoother_apply') + goto 9999 + end if + call psb_geaxpby(cone,initu,czero,xit,desc_data,info) + case default + call psb_errpush(psb_err_internal_error_,name,& + & a_err='wrong init to smoother_apply') + goto 9999 + end select + select case(trans_) case('N') if (sv%eps <=szero) then @@ -121,21 +148,12 @@ subroutine mld_c_gs_solver_apply_vect(alpha,sv,x,beta,y,desc_data,trans,work,inf ! 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 U. The off-diagonal block is taken care ! from the Jacobi smoother, hence this is purely local. call psb_spmm(-cone,sv%u,xit,cone,wv,desc_data,info,doswap=.false.) call psb_spsm(cone,sv%l,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) diff --git a/mlprec/impl/solver/mld_c_id_solver_apply.f90 b/mlprec/impl/solver/mld_c_id_solver_apply.f90 index 40cf98ea..98541b4b 100644 --- a/mlprec/impl/solver/mld_c_id_solver_apply.f90 +++ b/mlprec/impl/solver/mld_c_id_solver_apply.f90 @@ -36,7 +36,8 @@ !!$ POSSIBILITY OF SUCH DAMAGE. !!$ !!$ -subroutine mld_c_id_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info) +subroutine mld_c_id_solver_apply(alpha,sv,x,beta,y,desc_data,& + & trans,work,info,init,initu) use psb_base_mod use mld_c_id_solver, mld_protect_name => mld_c_id_solver_apply @@ -49,6 +50,8 @@ subroutine mld_c_id_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info) character(len=1),intent(in) :: trans complex(psb_spk_),target, intent(inout) :: work(:) integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: init + complex(psb_spk_),intent(inout), optional :: initu(:) integer(psb_ipk_) :: n_row,n_col integer(psb_ipk_) :: ictxt,np,me,i, err_act @@ -68,6 +71,9 @@ subroutine mld_c_id_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info) call psb_errpush(psb_err_iarg_invalid_i_,name) goto 9999 end select + ! + ! For non-iterative solvers, init and initu are ignored. + ! call psb_geaxpby(alpha,x,beta,y,desc_data,info) diff --git a/mlprec/impl/solver/mld_c_id_solver_apply_vect.f90 b/mlprec/impl/solver/mld_c_id_solver_apply_vect.f90 index 4aba9f4d..b102171b 100644 --- a/mlprec/impl/solver/mld_c_id_solver_apply_vect.f90 +++ b/mlprec/impl/solver/mld_c_id_solver_apply_vect.f90 @@ -36,7 +36,8 @@ !!$ POSSIBILITY OF SUCH DAMAGE. !!$ !!$ -subroutine mld_c_id_solver_apply_vect(alpha,sv,x,beta,y,desc_data,trans,work,info) +subroutine mld_c_id_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& + & trans,work,info,init,initu) use psb_base_mod use mld_c_id_solver, mld_protect_name => mld_c_id_solver_apply_vect @@ -49,6 +50,8 @@ subroutine mld_c_id_solver_apply_vect(alpha,sv,x,beta,y,desc_data,trans,work,inf character(len=1),intent(in) :: trans complex(psb_spk_),target, intent(inout) :: work(:) integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: init + type(psb_c_vect_type),intent(inout), optional :: initu integer(psb_ipk_) :: n_row,n_col integer(psb_ipk_) :: ictxt,np,me,i, err_act @@ -68,6 +71,9 @@ subroutine mld_c_id_solver_apply_vect(alpha,sv,x,beta,y,desc_data,trans,work,inf call psb_errpush(psb_err_iarg_invalid_i_,name) goto 9999 end select + ! + ! For non-iterative solvers, init and initu are ignored. + ! call psb_geaxpby(alpha,x,beta,y,desc_data,info) diff --git a/mlprec/impl/solver/mld_c_ilu_solver_apply.f90 b/mlprec/impl/solver/mld_c_ilu_solver_apply.f90 index 4f78505d..cb9c9ee9 100644 --- a/mlprec/impl/solver/mld_c_ilu_solver_apply.f90 +++ b/mlprec/impl/solver/mld_c_ilu_solver_apply.f90 @@ -36,7 +36,8 @@ !!$ POSSIBILITY OF SUCH DAMAGE. !!$ !!$ -subroutine mld_c_ilu_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info) +subroutine mld_c_ilu_solver_apply(alpha,sv,x,beta,y,desc_data,& + & trans,work,info,init,initu) use psb_base_mod use mld_c_ilu_solver, mld_protect_name => mld_c_ilu_solver_apply @@ -49,6 +50,8 @@ subroutine mld_c_ilu_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info) character(len=1),intent(in) :: trans complex(psb_spk_),target, intent(inout) :: work(:) integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: init + complex(psb_spk_),intent(inout), optional :: initu(:) integer(psb_ipk_) :: n_row,n_col complex(psb_spk_), pointer :: ww(:), aux(:), tx(:),ty(:) @@ -68,6 +71,9 @@ subroutine mld_c_ilu_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info) call psb_errpush(psb_err_iarg_invalid_i_,name) goto 9999 end select + ! + ! For non-iterative solvers, init and initu are ignored. + ! n_row = desc_data%get_local_rows() n_col = desc_data%get_local_cols() diff --git a/mlprec/impl/solver/mld_c_ilu_solver_apply_vect.f90 b/mlprec/impl/solver/mld_c_ilu_solver_apply_vect.f90 index 584f52b3..12c30150 100644 --- a/mlprec/impl/solver/mld_c_ilu_solver_apply_vect.f90 +++ b/mlprec/impl/solver/mld_c_ilu_solver_apply_vect.f90 @@ -36,7 +36,8 @@ !!$ POSSIBILITY OF SUCH DAMAGE. !!$ !!$ -subroutine mld_c_ilu_solver_apply_vect(alpha,sv,x,beta,y,desc_data,trans,work,info) +subroutine mld_c_ilu_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& + & trans,work,info,init,initu) use psb_base_mod use mld_c_ilu_solver, mld_protect_name => mld_c_ilu_solver_apply_vect @@ -49,6 +50,8 @@ subroutine mld_c_ilu_solver_apply_vect(alpha,sv,x,beta,y,desc_data,trans,work,in character(len=1),intent(in) :: trans complex(psb_spk_),target, intent(inout) :: work(:) integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: init + type(psb_c_vect_type),intent(inout), optional :: initu integer(psb_ipk_) :: n_row,n_col type(psb_c_vect_type) :: wv, wv1 @@ -70,6 +73,9 @@ subroutine mld_c_ilu_solver_apply_vect(alpha,sv,x,beta,y,desc_data,trans,work,in call psb_errpush(psb_err_iarg_invalid_i_,name) goto 9999 end select + ! + ! For non-iterative solvers, init and initu are ignored. + ! n_row = desc_data%get_local_rows() n_col = desc_data%get_local_cols() diff --git a/mlprec/impl/solver/mld_c_mumps_solver_apply.F90 b/mlprec/impl/solver/mld_c_mumps_solver_apply.F90 index 5a526409..9a6655d7 100644 --- a/mlprec/impl/solver/mld_c_mumps_solver_apply.F90 +++ b/mlprec/impl/solver/mld_c_mumps_solver_apply.F90 @@ -36,112 +36,116 @@ !!$ POSSIBILITY OF SUCH DAMAGE. !!$ !!$ +subroutine c_mumps_solver_apply(alpha,sv,x,beta,y,desc_data,& + & trans,work,info,init,initu) + use psb_base_mod + use mld_c_mumps_solver + implicit none + type(psb_desc_type), intent(in) :: desc_data + class(mld_c_mumps_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 + character, intent(in), optional :: init + complex(psb_spk_),intent(inout), optional :: initu(:) + integer(psb_ipk_) :: n_row, n_col, nglob + complex(psb_spk_), allocatable :: ww(:) + complex(psb_spk_), allocatable, target :: gx(:) + integer(psb_ipk_) :: ictxt,np,me,i, err_act + character :: trans_ + character(len=20) :: name='c_mumps_solver_apply' -subroutine c_mumps_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info) - use psb_base_mod - use mld_c_mumps_solver - implicit none - type(psb_desc_type), intent(in) :: desc_data - class(mld_c_mumps_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, nglob - complex(psb_spk_), allocatable :: ww(:) - complex(psb_spk_), allocatable, target :: gx(:) - integer(psb_ipk_) :: ictxt,np,me,i, err_act - character :: trans_ - character(len=20) :: name='c_mumps_solver_apply' - - call psb_erractionsave(err_act) + call psb_erractionsave(err_act) #if defined(HAVE_MUMPS_) - info = psb_success_ - trans_ = psb_toupper(trans) - select case(trans_) - case('N') - case('T') - case default - call psb_errpush(psb_err_iarg_invalid_i_,name) - goto 9999 - end select + info = psb_success_ + trans_ = psb_toupper(trans) + select case(trans_) + case('N') + case('T') + case default + call psb_errpush(psb_err_iarg_invalid_i_,name) + goto 9999 + end select + ! + ! For non-iterative solvers, init and initu are ignored. + ! - nglob = desc_data%get_global_rows() - n_row = desc_data%get_local_rows() - n_col = desc_data%get_local_cols() + nglob = desc_data%get_global_rows() + 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) - else - allocate(ww(n_col),stat=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_)') - goto 9999 - end if - end if - allocate(gx(nglob),stat=info) + if (n_col <= size(work)) then + ww = work(1:n_col) + else + allocate(ww(n_col),stat=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_)') - goto 9999 + info=psb_err_alloc_request_ + call psb_errpush(info,name,i_err=(/n_col,0,0,0,0/),& + & a_err='complex(psb_spk_)') + goto 9999 end if - call psb_gather(gx, x, desc_data, info, root=0) - select case(trans_) - case('N') - sv%id%icntl(9) = 1 - case('T') - sv%id%icntl(9) = 2 - case default - call psb_errpush(psb_err_internal_error_,& - & name,a_err='Invalid TRANS in subsolve') - goto 9999 - end select + end if + allocate(gx(nglob),stat=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_)') + goto 9999 + end if + call psb_gather(gx, x, desc_data, info, root=0) + select case(trans_) + case('N') + sv%id%icntl(9) = 1 + case('T') + sv%id%icntl(9) = 2 + case default + call psb_errpush(psb_err_internal_error_,& + & name,a_err='Invalid TRANS in subsolve') + 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 - call cmumps(sv%id) - call psb_scatter(gx, ww, desc_data, info, root=0) - - if (info == psb_success_) then - call psb_geaxpby(alpha,ww,beta,y,desc_data,info) - end if + 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 cmumps(sv%id) + call psb_scatter(gx, ww, desc_data, info, root=0) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,& - & name,a_err='Error in subsolve') - goto 9999 - endif + if (info == psb_success_) then + call psb_geaxpby(alpha,ww,beta,y,desc_data,info) + end if - if (nglob > size(work)) then - deallocate(ww) - endif + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,& + & name,a_err='Error in subsolve') + goto 9999 + endif - call psb_erractionrestore(err_act) - return + if (nglob > size(work)) then + deallocate(ww) + endif + + call psb_erractionrestore(err_act) + return 9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() return + end if + return #else - write(psb_err_unit,*) "MUMPS Not Configured, fix make.inc and recompile " + write(psb_err_unit,*) "MUMPS Not Configured, fix make.inc and recompile " #endif - end subroutine c_mumps_solver_apply +end subroutine c_mumps_solver_apply diff --git a/mlprec/impl/solver/mld_c_mumps_solver_apply_vect.F90 b/mlprec/impl/solver/mld_c_mumps_solver_apply_vect.F90 index a3748ab1..a63f7dbd 100644 --- a/mlprec/impl/solver/mld_c_mumps_solver_apply_vect.F90 +++ b/mlprec/impl/solver/mld_c_mumps_solver_apply_vect.F90 @@ -36,49 +36,54 @@ !!$ POSSIBILITY OF SUCH DAMAGE. !!$ !!$ +subroutine c_mumps_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& + & trans,work,info,init,initu) + use psb_base_mod + use mld_c_mumps_solver + implicit none + type(psb_desc_type), intent(in) :: desc_data + class(mld_c_mumps_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 + character, intent(in), optional :: init + type(psb_c_vect_type),intent(inout), optional :: initu - subroutine c_mumps_solver_apply_vect(alpha,sv,x,beta,y,desc_data,trans,work,info) - use psb_base_mod - use mld_c_mumps_solver - implicit none - type(psb_desc_type), intent(in) :: desc_data - class(mld_c_mumps_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_) :: err_act - character(len=20) :: name='c_mumps_solver_apply_vect' + integer(psb_ipk_) :: err_act + character(len=20) :: name='c_mumps_solver_apply_vect' #if defined(HAVE_MUMPS_) - call psb_erractionsave(err_act) + call psb_erractionsave(err_act) - info = psb_success_ + info = psb_success_ + ! + ! For non-iterative solvers, init and initu are ignored. + ! - call x%v%sync() - call y%v%sync() - call sv%apply(alpha,x%v%v,beta,y%v%v,desc_data,trans,work,info) - call y%v%set_host() - if (info /= 0) goto 9999 + call x%v%sync() + call y%v%sync() + call sv%apply(alpha,x%v%v,beta,y%v%v,desc_data,trans,work,info) + call y%v%set_host() + if (info /= 0) goto 9999 - call psb_erractionrestore(err_act) - return + call psb_erractionrestore(err_act) + return 9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() return + end if + return #else - write(psb_err_unit,*) "MUMPS Not Configured, fix make.inc and recompile " + write(psb_err_unit,*) "MUMPS Not Configured, fix make.inc and recompile " #endif - end subroutine c_mumps_solver_apply_vect +end subroutine c_mumps_solver_apply_vect diff --git a/mlprec/impl/solver/mld_d_base_solver_apply.f90 b/mlprec/impl/solver/mld_d_base_solver_apply.f90 index 3a7cdc9a..a612653b 100644 --- a/mlprec/impl/solver/mld_d_base_solver_apply.f90 +++ b/mlprec/impl/solver/mld_d_base_solver_apply.f90 @@ -36,7 +36,8 @@ !!$ POSSIBILITY OF SUCH DAMAGE. !!$ !!$ -subroutine mld_d_base_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info) +subroutine mld_d_base_solver_apply(alpha,sv,x,beta,y,desc_data,& + & trans,work,info,init,initu) use psb_base_mod use mld_d_base_solver_mod, mld_protect_name => mld_d_base_solver_apply @@ -49,6 +50,8 @@ subroutine mld_d_base_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info) character(len=1),intent(in) :: trans real(psb_dpk_),target, intent(inout) :: work(:) integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: init + real(psb_dpk_),intent(inout), optional :: initu(:) integer(psb_ipk_) :: err_act character(len=20) :: name='d_base_solver_apply' diff --git a/mlprec/impl/solver/mld_d_base_solver_apply_vect.f90 b/mlprec/impl/solver/mld_d_base_solver_apply_vect.f90 index d043a905..3fe35e58 100644 --- a/mlprec/impl/solver/mld_d_base_solver_apply_vect.f90 +++ b/mlprec/impl/solver/mld_d_base_solver_apply_vect.f90 @@ -36,7 +36,8 @@ !!$ POSSIBILITY OF SUCH DAMAGE. !!$ !!$ -subroutine mld_d_base_solver_apply_vect(alpha,sv,x,beta,y,desc_data,trans,work,info) +subroutine mld_d_base_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& + & trans,work,info,init,initu) use psb_base_mod use mld_d_base_solver_mod, mld_protect_name => mld_d_base_solver_apply_vect @@ -49,6 +50,8 @@ subroutine mld_d_base_solver_apply_vect(alpha,sv,x,beta,y,desc_data,trans,work,i character(len=1),intent(in) :: trans real(psb_dpk_),target, intent(inout) :: work(:) integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: init + type(psb_d_vect_type),intent(inout), optional :: initu integer(psb_ipk_) :: err_act character(len=20) :: name='d_base_solver_apply_vect' diff --git a/mlprec/impl/solver/mld_d_bwgs_solver_apply.f90 b/mlprec/impl/solver/mld_d_bwgs_solver_apply.f90 index 408f4a31..0eb765cd 100644 --- a/mlprec/impl/solver/mld_d_bwgs_solver_apply.f90 +++ b/mlprec/impl/solver/mld_d_bwgs_solver_apply.f90 @@ -36,7 +36,8 @@ !!$ POSSIBILITY OF SUCH DAMAGE. !!$ !!$ -subroutine mld_d_bwgs_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info) +subroutine mld_d_bwgs_solver_apply(alpha,sv,x,beta,y,desc_data,& + &trans,work,info,init,initu) use psb_base_mod use mld_d_gs_solver, mld_protect_name => mld_d_bwgs_solver_apply @@ -49,12 +50,14 @@ subroutine mld_d_bwgs_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info) character(len=1),intent(in) :: trans real(psb_dpk_),target, intent(inout) :: work(:) integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: init + real(psb_dpk_),intent(inout), optional :: initu(:) 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 :: trans_, init_ character(len=20) :: name='d_bwgs_solver_apply' call psb_erractionsave(err_act) @@ -71,6 +74,13 @@ subroutine mld_d_bwgs_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info) call psb_errpush(psb_err_iarg_invalid_i_,name) goto 9999 end select + + if (present(init)) then + init_ = psb_toupper(init) + else + init_='Z' + end if + n_row = desc_data%get_local_rows() n_col = desc_data%get_local_cols() @@ -108,9 +118,26 @@ subroutine mld_d_bwgs_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info) goto 9999 end if - call psb_geasb(wv,desc_data,info) - call psb_geasb(xit,desc_data,info) - + call psb_geasb(wv,desc_data,info) + call psb_geasb(xit,desc_data,info) + select case (init_) + case('Z') + xit(:) = dzero + case('Y') + call psb_geaxpby(done,y,dzero,xit,desc_data,info) + case('U') + if (.not.present(initu)) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='missing initu to smoother_apply') + goto 9999 + end if + call psb_geaxpby(done,initu,dzero,xit,desc_data,info) + case default + call psb_errpush(psb_err_internal_error_,name,& + & a_err='wrong init to smoother_apply') + goto 9999 + end select + select case(trans_) case('N') if (sv%eps <=dzero) then @@ -118,21 +145,12 @@ subroutine mld_d_bwgs_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info) ! 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 L. The off-diagonal block is taken care ! from the Jacobi smoother, hence this is purely local. 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 call psb_geaxpby(alpha,xit,beta,y,desc_data,info) 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 6ec2ca50..a034c94c 100644 --- a/mlprec/impl/solver/mld_d_bwgs_solver_apply_vect.f90 +++ b/mlprec/impl/solver/mld_d_bwgs_solver_apply_vect.f90 @@ -36,7 +36,8 @@ !!$ POSSIBILITY OF SUCH DAMAGE. !!$ !!$ -subroutine mld_d_bwgs_solver_apply_vect(alpha,sv,x,beta,y,desc_data,trans,work,info) +subroutine mld_d_bwgs_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& + & trans,work,info,init,initu) use psb_base_mod use mld_d_gs_solver, mld_protect_name => mld_d_bwgs_solver_apply_vect @@ -49,13 +50,15 @@ subroutine mld_d_bwgs_solver_apply_vect(alpha,sv,x,beta,y,desc_data,trans,work,i character(len=1),intent(in) :: trans real(psb_dpk_),target, intent(inout) :: work(:) integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: init + type(psb_d_vect_type),intent(inout), optional :: initu 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 :: trans_, init_ character(len=20) :: name='d_bwgs_solver_apply' call psb_erractionsave(err_act) @@ -72,6 +75,13 @@ subroutine mld_d_bwgs_solver_apply_vect(alpha,sv,x,beta,y,desc_data,trans,work,i call psb_errpush(psb_err_iarg_invalid_i_,name) goto 9999 end select + + if (present(init)) then + init_ = psb_toupper(init) + else + init_='Z' + end if + n_row = desc_data%get_local_rows() n_col = desc_data%get_local_cols() @@ -113,7 +123,24 @@ subroutine mld_d_bwgs_solver_apply_vect(alpha,sv,x,beta,y,desc_data,trans,work,i 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 (init_) + case('Z') + call xit%zero() + case('Y') + call psb_geaxpby(done,y,dzero,xit,desc_data,info) + case('U') + if (.not.present(initu)) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='missing initu to smoother_apply') + goto 9999 + end if + call psb_geaxpby(done,initu,dzero,xit,desc_data,info) + case default + call psb_errpush(psb_err_internal_error_,name,& + & a_err='wrong init to smoother_apply') + goto 9999 + end select + select case(trans_) case('N') if (sv%eps <=dzero) then @@ -121,21 +148,12 @@ subroutine mld_d_bwgs_solver_apply_vect(alpha,sv,x,beta,y,desc_data,trans,work,i ! 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 L. The off-diagonal block is taken care ! from the Jacobi smoother, hence this is purely local. 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 call psb_geaxpby(alpha,xit,beta,y,desc_data,info) diff --git a/mlprec/impl/solver/mld_d_diag_solver_apply.f90 b/mlprec/impl/solver/mld_d_diag_solver_apply.f90 index 3f0b89ab..a9151340 100644 --- a/mlprec/impl/solver/mld_d_diag_solver_apply.f90 +++ b/mlprec/impl/solver/mld_d_diag_solver_apply.f90 @@ -36,7 +36,8 @@ !!$ POSSIBILITY OF SUCH DAMAGE. !!$ !!$ -subroutine mld_d_diag_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info) +subroutine mld_d_diag_solver_apply(alpha,sv,x,beta,y,desc_data,& + & trans,work,info,init,initu) use psb_base_mod use mld_d_diag_solver, mld_protect_name => mld_d_diag_solver_apply @@ -49,6 +50,8 @@ subroutine mld_d_diag_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info) character(len=1),intent(in) :: trans real(psb_dpk_),target, intent(inout) :: work(:) integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: init + real(psb_dpk_),intent(inout), optional :: initu(:) integer(psb_ipk_) :: n_row,n_col real(psb_dpk_), pointer :: ww(:), aux(:), tx(:),ty(:) @@ -68,7 +71,10 @@ subroutine mld_d_diag_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info) call psb_errpush(psb_err_iarg_invalid_i_,name) goto 9999 end select - + ! + ! For non-iterative solvers, init and initu are ignored. + ! + n_row = desc_data%get_local_rows() n_col = desc_data%get_local_cols() diff --git a/mlprec/impl/solver/mld_d_diag_solver_apply_vect.f90 b/mlprec/impl/solver/mld_d_diag_solver_apply_vect.f90 index edcdf56a..5a8abc0a 100644 --- a/mlprec/impl/solver/mld_d_diag_solver_apply_vect.f90 +++ b/mlprec/impl/solver/mld_d_diag_solver_apply_vect.f90 @@ -36,7 +36,8 @@ !!$ POSSIBILITY OF SUCH DAMAGE. !!$ !!$ -subroutine mld_d_diag_solver_apply_vect(alpha,sv,x,beta,y,desc_data,trans,work,info) +subroutine mld_d_diag_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& + & trans,work,info,init,initu) use psb_base_mod use mld_d_diag_solver, mld_protect_name => mld_d_diag_solver_apply_vect @@ -49,6 +50,8 @@ subroutine mld_d_diag_solver_apply_vect(alpha,sv,x,beta,y,desc_data,trans,work,i character(len=1),intent(in) :: trans real(psb_dpk_),target, intent(inout) :: work(:) integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: init + type(psb_d_vect_type),intent(inout), optional :: initu integer(psb_ipk_) :: n_row,n_col real(psb_dpk_), pointer :: ww(:), aux(:), tx(:),ty(:) @@ -68,6 +71,9 @@ subroutine mld_d_diag_solver_apply_vect(alpha,sv,x,beta,y,desc_data,trans,work,i call psb_errpush(psb_err_iarg_invalid_i_,name) goto 9999 end select + ! + ! For non-iterative solvers, init and initu are ignored. + ! n_row = desc_data%get_local_rows() n_col = desc_data%get_local_cols() diff --git a/mlprec/impl/solver/mld_d_gs_solver_apply.f90 b/mlprec/impl/solver/mld_d_gs_solver_apply.f90 index bb5afdb1..e8c15e98 100644 --- a/mlprec/impl/solver/mld_d_gs_solver_apply.f90 +++ b/mlprec/impl/solver/mld_d_gs_solver_apply.f90 @@ -36,7 +36,8 @@ !!$ POSSIBILITY OF SUCH DAMAGE. !!$ !!$ -subroutine mld_d_gs_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info) +subroutine mld_d_gs_solver_apply(alpha,sv,x,beta,y,desc_data,& + &trans,work,info,init,initu) use psb_base_mod use mld_d_gs_solver, mld_protect_name => mld_d_gs_solver_apply @@ -49,12 +50,14 @@ subroutine mld_d_gs_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info) character(len=1),intent(in) :: trans real(psb_dpk_),target, intent(inout) :: work(:) integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: init + real(psb_dpk_),intent(inout), optional :: initu(:) 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 :: trans_, init_ character(len=20) :: name='d_gs_solver_apply' call psb_erractionsave(err_act) @@ -71,6 +74,13 @@ subroutine mld_d_gs_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info) call psb_errpush(psb_err_iarg_invalid_i_,name) goto 9999 end select + + if (present(init)) then + init_ = psb_toupper(init) + else + init_='Z' + end if + n_row = desc_data%get_local_rows() n_col = desc_data%get_local_cols() @@ -108,9 +118,26 @@ subroutine mld_d_gs_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info) goto 9999 end if - call psb_geasb(wv,desc_data,info) - call psb_geasb(xit,desc_data,info) - + call psb_geasb(wv,desc_data,info) + call psb_geasb(xit,desc_data,info) + select case (init_) + case('Z') + xit(:) = dzero + case('Y') + call psb_geaxpby(done,y,dzero,xit,desc_data,info) + case('U') + if (.not.present(initu)) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='missing initu to smoother_apply') + goto 9999 + end if + call psb_geaxpby(done,initu,dzero,xit,desc_data,info) + case default + call psb_errpush(psb_err_internal_error_,name,& + & a_err='wrong init to smoother_apply') + goto 9999 + end select + select case(trans_) case('N') if (sv%eps <=dzero) then @@ -118,21 +145,12 @@ subroutine mld_d_gs_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info) ! 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) diff --git a/mlprec/impl/solver/mld_d_gs_solver_apply_vect.f90 b/mlprec/impl/solver/mld_d_gs_solver_apply_vect.f90 index 9b4993bc..9150bb57 100644 --- a/mlprec/impl/solver/mld_d_gs_solver_apply_vect.f90 +++ b/mlprec/impl/solver/mld_d_gs_solver_apply_vect.f90 @@ -36,7 +36,8 @@ !!$ POSSIBILITY OF SUCH DAMAGE. !!$ !!$ -subroutine mld_d_gs_solver_apply_vect(alpha,sv,x,beta,y,desc_data,trans,work,info) +subroutine mld_d_gs_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& + & trans,work,info,init,initu) use psb_base_mod use mld_d_gs_solver, mld_protect_name => mld_d_gs_solver_apply_vect @@ -49,13 +50,15 @@ subroutine mld_d_gs_solver_apply_vect(alpha,sv,x,beta,y,desc_data,trans,work,inf character(len=1),intent(in) :: trans real(psb_dpk_),target, intent(inout) :: work(:) integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: init + type(psb_d_vect_type),intent(inout), optional :: initu 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 :: trans_, init_ character(len=20) :: name='d_gs_solver_apply' call psb_erractionsave(err_act) @@ -72,6 +75,13 @@ subroutine mld_d_gs_solver_apply_vect(alpha,sv,x,beta,y,desc_data,trans,work,inf call psb_errpush(psb_err_iarg_invalid_i_,name) goto 9999 end select + + if (present(init)) then + init_ = psb_toupper(init) + else + init_='Z' + end if + n_row = desc_data%get_local_rows() n_col = desc_data%get_local_cols() @@ -113,7 +123,24 @@ subroutine mld_d_gs_solver_apply_vect(alpha,sv,x,beta,y,desc_data,trans,work,inf 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 (init_) + case('Z') + call xit%zero() + case('Y') + call psb_geaxpby(done,y,dzero,xit,desc_data,info) + case('U') + if (.not.present(initu)) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='missing initu to smoother_apply') + goto 9999 + end if + call psb_geaxpby(done,initu,dzero,xit,desc_data,info) + case default + call psb_errpush(psb_err_internal_error_,name,& + & a_err='wrong init to smoother_apply') + goto 9999 + end select + select case(trans_) case('N') if (sv%eps <=dzero) then @@ -121,21 +148,12 @@ subroutine mld_d_gs_solver_apply_vect(alpha,sv,x,beta,y,desc_data,trans,work,inf ! 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) diff --git a/mlprec/impl/solver/mld_d_id_solver_apply.f90 b/mlprec/impl/solver/mld_d_id_solver_apply.f90 index 2f45d2bd..da109dfc 100644 --- a/mlprec/impl/solver/mld_d_id_solver_apply.f90 +++ b/mlprec/impl/solver/mld_d_id_solver_apply.f90 @@ -36,7 +36,8 @@ !!$ POSSIBILITY OF SUCH DAMAGE. !!$ !!$ -subroutine mld_d_id_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info) +subroutine mld_d_id_solver_apply(alpha,sv,x,beta,y,desc_data,& + & trans,work,info,init,initu) use psb_base_mod use mld_d_id_solver, mld_protect_name => mld_d_id_solver_apply @@ -49,6 +50,8 @@ subroutine mld_d_id_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info) character(len=1),intent(in) :: trans real(psb_dpk_),target, intent(inout) :: work(:) integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: init + real(psb_dpk_),intent(inout), optional :: initu(:) integer(psb_ipk_) :: n_row,n_col integer(psb_ipk_) :: ictxt,np,me,i, err_act @@ -68,6 +71,9 @@ subroutine mld_d_id_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info) call psb_errpush(psb_err_iarg_invalid_i_,name) goto 9999 end select + ! + ! For non-iterative solvers, init and initu are ignored. + ! call psb_geaxpby(alpha,x,beta,y,desc_data,info) diff --git a/mlprec/impl/solver/mld_d_id_solver_apply_vect.f90 b/mlprec/impl/solver/mld_d_id_solver_apply_vect.f90 index e69adf01..ff23e072 100644 --- a/mlprec/impl/solver/mld_d_id_solver_apply_vect.f90 +++ b/mlprec/impl/solver/mld_d_id_solver_apply_vect.f90 @@ -36,7 +36,8 @@ !!$ POSSIBILITY OF SUCH DAMAGE. !!$ !!$ -subroutine mld_d_id_solver_apply_vect(alpha,sv,x,beta,y,desc_data,trans,work,info) +subroutine mld_d_id_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& + & trans,work,info,init,initu) use psb_base_mod use mld_d_id_solver, mld_protect_name => mld_d_id_solver_apply_vect @@ -49,6 +50,8 @@ subroutine mld_d_id_solver_apply_vect(alpha,sv,x,beta,y,desc_data,trans,work,inf character(len=1),intent(in) :: trans real(psb_dpk_),target, intent(inout) :: work(:) integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: init + type(psb_d_vect_type),intent(inout), optional :: initu integer(psb_ipk_) :: n_row,n_col integer(psb_ipk_) :: ictxt,np,me,i, err_act @@ -68,6 +71,9 @@ subroutine mld_d_id_solver_apply_vect(alpha,sv,x,beta,y,desc_data,trans,work,inf call psb_errpush(psb_err_iarg_invalid_i_,name) goto 9999 end select + ! + ! For non-iterative solvers, init and initu are ignored. + ! call psb_geaxpby(alpha,x,beta,y,desc_data,info) diff --git a/mlprec/impl/solver/mld_d_ilu_solver_apply.f90 b/mlprec/impl/solver/mld_d_ilu_solver_apply.f90 index a311852a..e968349b 100644 --- a/mlprec/impl/solver/mld_d_ilu_solver_apply.f90 +++ b/mlprec/impl/solver/mld_d_ilu_solver_apply.f90 @@ -36,7 +36,8 @@ !!$ POSSIBILITY OF SUCH DAMAGE. !!$ !!$ -subroutine mld_d_ilu_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info) +subroutine mld_d_ilu_solver_apply(alpha,sv,x,beta,y,desc_data,& + & trans,work,info,init,initu) use psb_base_mod use mld_d_ilu_solver, mld_protect_name => mld_d_ilu_solver_apply @@ -49,6 +50,8 @@ subroutine mld_d_ilu_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info) character(len=1),intent(in) :: trans real(psb_dpk_),target, intent(inout) :: work(:) integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: init + real(psb_dpk_),intent(inout), optional :: initu(:) integer(psb_ipk_) :: n_row,n_col real(psb_dpk_), pointer :: ww(:), aux(:), tx(:),ty(:) @@ -68,6 +71,9 @@ subroutine mld_d_ilu_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info) call psb_errpush(psb_err_iarg_invalid_i_,name) goto 9999 end select + ! + ! For non-iterative solvers, init and initu are ignored. + ! n_row = desc_data%get_local_rows() n_col = desc_data%get_local_cols() diff --git a/mlprec/impl/solver/mld_d_ilu_solver_apply_vect.f90 b/mlprec/impl/solver/mld_d_ilu_solver_apply_vect.f90 index dade7ea7..9aea7138 100644 --- a/mlprec/impl/solver/mld_d_ilu_solver_apply_vect.f90 +++ b/mlprec/impl/solver/mld_d_ilu_solver_apply_vect.f90 @@ -36,7 +36,8 @@ !!$ POSSIBILITY OF SUCH DAMAGE. !!$ !!$ -subroutine mld_d_ilu_solver_apply_vect(alpha,sv,x,beta,y,desc_data,trans,work,info) +subroutine mld_d_ilu_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& + & trans,work,info,init,initu) use psb_base_mod use mld_d_ilu_solver, mld_protect_name => mld_d_ilu_solver_apply_vect @@ -49,6 +50,8 @@ subroutine mld_d_ilu_solver_apply_vect(alpha,sv,x,beta,y,desc_data,trans,work,in character(len=1),intent(in) :: trans real(psb_dpk_),target, intent(inout) :: work(:) integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: init + type(psb_d_vect_type),intent(inout), optional :: initu integer(psb_ipk_) :: n_row,n_col type(psb_d_vect_type) :: wv, wv1 @@ -70,6 +73,9 @@ subroutine mld_d_ilu_solver_apply_vect(alpha,sv,x,beta,y,desc_data,trans,work,in call psb_errpush(psb_err_iarg_invalid_i_,name) goto 9999 end select + ! + ! For non-iterative solvers, init and initu are ignored. + ! n_row = desc_data%get_local_rows() n_col = desc_data%get_local_cols() diff --git a/mlprec/impl/solver/mld_d_mumps_solver_apply.F90 b/mlprec/impl/solver/mld_d_mumps_solver_apply.F90 index 3393fbbc..e981337d 100644 --- a/mlprec/impl/solver/mld_d_mumps_solver_apply.F90 +++ b/mlprec/impl/solver/mld_d_mumps_solver_apply.F90 @@ -36,112 +36,116 @@ !!$ POSSIBILITY OF SUCH DAMAGE. !!$ !!$ +subroutine d_mumps_solver_apply(alpha,sv,x,beta,y,desc_data,& + & trans,work,info,init,initu) + use psb_base_mod + use mld_d_mumps_solver + implicit none + type(psb_desc_type), intent(in) :: desc_data + class(mld_d_mumps_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 + character, intent(in), optional :: init + real(psb_dpk_),intent(inout), optional :: initu(:) + integer(psb_ipk_) :: n_row, n_col, nglob + real(psb_dpk_), allocatable :: ww(:) + real(psb_dpk_), allocatable, target :: gx(:) + integer(psb_ipk_) :: ictxt,np,me,i, err_act + character :: trans_ + character(len=20) :: name='d_mumps_solver_apply' -subroutine d_mumps_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info) - use psb_base_mod - use mld_d_mumps_solver - implicit none - type(psb_desc_type), intent(in) :: desc_data - class(mld_d_mumps_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, nglob - real(psb_dpk_), allocatable :: ww(:) - real(psb_dpk_), allocatable, target :: gx(:) - integer(psb_ipk_) :: ictxt,np,me,i, err_act - character :: trans_ - character(len=20) :: name='d_mumps_solver_apply' - - call psb_erractionsave(err_act) + call psb_erractionsave(err_act) #if defined(HAVE_MUMPS_) - info = psb_success_ - trans_ = psb_toupper(trans) - select case(trans_) - case('N') - case('T') - case default - call psb_errpush(psb_err_iarg_invalid_i_,name) - goto 9999 - end select + info = psb_success_ + trans_ = psb_toupper(trans) + select case(trans_) + case('N') + case('T') + case default + call psb_errpush(psb_err_iarg_invalid_i_,name) + goto 9999 + end select + ! + ! For non-iterative solvers, init and initu are ignored. + ! - nglob = desc_data%get_global_rows() - n_row = desc_data%get_local_rows() - n_col = desc_data%get_local_cols() + nglob = desc_data%get_global_rows() + 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) - else - allocate(ww(n_col),stat=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='real(psb_dpk_)') - goto 9999 - end if - end if - allocate(gx(nglob),stat=info) + if (n_col <= size(work)) then + ww = work(1:n_col) + else + allocate(ww(n_col),stat=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='real(psb_dpk_)') - goto 9999 + info=psb_err_alloc_request_ + call psb_errpush(info,name,i_err=(/n_col,0,0,0,0/),& + & a_err='real(psb_dpk_)') + goto 9999 end if - call psb_gather(gx, x, desc_data, info, root=0) - select case(trans_) - case('N') - sv%id%icntl(9) = 1 - case('T') - sv%id%icntl(9) = 2 - case default - call psb_errpush(psb_err_internal_error_,& - & name,a_err='Invalid TRANS in subsolve') - goto 9999 - end select + end if + allocate(gx(nglob),stat=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='real(psb_dpk_)') + goto 9999 + end if + call psb_gather(gx, x, desc_data, info, root=0) + select case(trans_) + case('N') + sv%id%icntl(9) = 1 + case('T') + sv%id%icntl(9) = 2 + case default + call psb_errpush(psb_err_internal_error_,& + & name,a_err='Invalid TRANS in subsolve') + 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 - call dmumps(sv%id) - call psb_scatter(gx, ww, desc_data, info, root=0) - - if (info == psb_success_) then - call psb_geaxpby(alpha,ww,beta,y,desc_data,info) - end if + 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) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,& - & name,a_err='Error in subsolve') - goto 9999 - endif + if (info == psb_success_) then + call psb_geaxpby(alpha,ww,beta,y,desc_data,info) + end if - if (nglob > size(work)) then - deallocate(ww) - endif + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,& + & name,a_err='Error in subsolve') + goto 9999 + endif - call psb_erractionrestore(err_act) - return + if (nglob > size(work)) then + deallocate(ww) + endif + + call psb_erractionrestore(err_act) + return 9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() return + end if + return #else - write(psb_err_unit,*) "MUMPS Not Configured, fix make.inc and recompile " + write(psb_err_unit,*) "MUMPS Not Configured, fix make.inc and recompile " #endif - end subroutine d_mumps_solver_apply +end subroutine d_mumps_solver_apply 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 801066bb..e35bef79 100644 --- a/mlprec/impl/solver/mld_d_mumps_solver_apply_vect.F90 +++ b/mlprec/impl/solver/mld_d_mumps_solver_apply_vect.F90 @@ -36,49 +36,54 @@ !!$ POSSIBILITY OF SUCH DAMAGE. !!$ !!$ +subroutine d_mumps_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& + & trans,work,info,init,initu) + use psb_base_mod + use mld_d_mumps_solver + implicit none + type(psb_desc_type), intent(in) :: desc_data + class(mld_d_mumps_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 + character, intent(in), optional :: init + type(psb_d_vect_type),intent(inout), optional :: initu - subroutine d_mumps_solver_apply_vect(alpha,sv,x,beta,y,desc_data,trans,work,info) - use psb_base_mod - use mld_d_mumps_solver - implicit none - type(psb_desc_type), intent(in) :: desc_data - class(mld_d_mumps_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_) :: err_act - character(len=20) :: name='d_mumps_solver_apply_vect' + integer(psb_ipk_) :: err_act + character(len=20) :: name='d_mumps_solver_apply_vect' #if defined(HAVE_MUMPS_) - call psb_erractionsave(err_act) + call psb_erractionsave(err_act) - info = psb_success_ + info = psb_success_ + ! + ! For non-iterative solvers, init and initu are ignored. + ! - call x%v%sync() - call y%v%sync() - call sv%apply(alpha,x%v%v,beta,y%v%v,desc_data,trans,work,info) - call y%v%set_host() - if (info /= 0) goto 9999 + call x%v%sync() + call y%v%sync() + call sv%apply(alpha,x%v%v,beta,y%v%v,desc_data,trans,work,info) + call y%v%set_host() + if (info /= 0) goto 9999 - call psb_erractionrestore(err_act) - return + call psb_erractionrestore(err_act) + return 9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() return + end if + return #else - write(psb_err_unit,*) "MUMPS Not Configured, fix make.inc and recompile " + write(psb_err_unit,*) "MUMPS Not Configured, fix make.inc and recompile " #endif - end subroutine d_mumps_solver_apply_vect +end subroutine d_mumps_solver_apply_vect diff --git a/mlprec/impl/solver/mld_s_base_solver_apply.f90 b/mlprec/impl/solver/mld_s_base_solver_apply.f90 index 5f048fc0..aa5c2c15 100644 --- a/mlprec/impl/solver/mld_s_base_solver_apply.f90 +++ b/mlprec/impl/solver/mld_s_base_solver_apply.f90 @@ -36,7 +36,8 @@ !!$ POSSIBILITY OF SUCH DAMAGE. !!$ !!$ -subroutine mld_s_base_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info) +subroutine mld_s_base_solver_apply(alpha,sv,x,beta,y,desc_data,& + & trans,work,info,init,initu) use psb_base_mod use mld_s_base_solver_mod, mld_protect_name => mld_s_base_solver_apply @@ -49,6 +50,8 @@ subroutine mld_s_base_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info) character(len=1),intent(in) :: trans real(psb_spk_),target, intent(inout) :: work(:) integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: init + real(psb_spk_),intent(inout), optional :: initu(:) integer(psb_ipk_) :: err_act character(len=20) :: name='s_base_solver_apply' diff --git a/mlprec/impl/solver/mld_s_base_solver_apply_vect.f90 b/mlprec/impl/solver/mld_s_base_solver_apply_vect.f90 index 8450f663..b97c7862 100644 --- a/mlprec/impl/solver/mld_s_base_solver_apply_vect.f90 +++ b/mlprec/impl/solver/mld_s_base_solver_apply_vect.f90 @@ -36,7 +36,8 @@ !!$ POSSIBILITY OF SUCH DAMAGE. !!$ !!$ -subroutine mld_s_base_solver_apply_vect(alpha,sv,x,beta,y,desc_data,trans,work,info) +subroutine mld_s_base_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& + & trans,work,info,init,initu) use psb_base_mod use mld_s_base_solver_mod, mld_protect_name => mld_s_base_solver_apply_vect @@ -49,6 +50,8 @@ subroutine mld_s_base_solver_apply_vect(alpha,sv,x,beta,y,desc_data,trans,work,i character(len=1),intent(in) :: trans real(psb_spk_),target, intent(inout) :: work(:) integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: init + type(psb_s_vect_type),intent(inout), optional :: initu integer(psb_ipk_) :: err_act character(len=20) :: name='s_base_solver_apply_vect' diff --git a/mlprec/impl/solver/mld_s_bwgs_solver_apply.f90 b/mlprec/impl/solver/mld_s_bwgs_solver_apply.f90 index 1be17289..d2fc83af 100644 --- a/mlprec/impl/solver/mld_s_bwgs_solver_apply.f90 +++ b/mlprec/impl/solver/mld_s_bwgs_solver_apply.f90 @@ -36,7 +36,8 @@ !!$ POSSIBILITY OF SUCH DAMAGE. !!$ !!$ -subroutine mld_s_bwgs_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info) +subroutine mld_s_bwgs_solver_apply(alpha,sv,x,beta,y,desc_data,& + &trans,work,info,init,initu) use psb_base_mod use mld_s_gs_solver, mld_protect_name => mld_s_bwgs_solver_apply @@ -49,13 +50,15 @@ subroutine mld_s_bwgs_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info) character(len=1),intent(in) :: trans real(psb_spk_),target, intent(inout) :: work(:) integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: init + real(psb_spk_),intent(inout), optional :: initu(:) 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' + character :: trans_, init_ + character(len=20) :: name='s_bwgs_solver_apply' call psb_erractionsave(err_act) ictxt = desc_data%get_ctxt() @@ -71,6 +74,13 @@ subroutine mld_s_bwgs_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info) call psb_errpush(psb_err_iarg_invalid_i_,name) goto 9999 end select + + if (present(init)) then + init_ = psb_toupper(init) + else + init_='Z' + end if + n_row = desc_data%get_local_rows() n_col = desc_data%get_local_cols() @@ -108,9 +118,26 @@ subroutine mld_s_bwgs_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info) goto 9999 end if - call psb_geasb(wv,desc_data,info) - call psb_geasb(xit,desc_data,info) - + call psb_geasb(wv,desc_data,info) + call psb_geasb(xit,desc_data,info) + select case (init_) + case('Z') + xit(:) = szero + case('Y') + call psb_geaxpby(sone,y,szero,xit,desc_data,info) + case('U') + if (.not.present(initu)) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='missing initu to smoother_apply') + goto 9999 + end if + call psb_geaxpby(sone,initu,szero,xit,desc_data,info) + case default + call psb_errpush(psb_err_internal_error_,name,& + & a_err='wrong init to smoother_apply') + goto 9999 + end select + select case(trans_) case('N') if (sv%eps <=szero) then @@ -118,21 +145,12 @@ subroutine mld_s_bwgs_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info) ! 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) diff --git a/mlprec/impl/solver/mld_s_bwgs_solver_apply_vect.f90 b/mlprec/impl/solver/mld_s_bwgs_solver_apply_vect.f90 index 4a9eb69e..92387ee5 100644 --- a/mlprec/impl/solver/mld_s_bwgs_solver_apply_vect.f90 +++ b/mlprec/impl/solver/mld_s_bwgs_solver_apply_vect.f90 @@ -36,7 +36,8 @@ !!$ POSSIBILITY OF SUCH DAMAGE. !!$ !!$ -subroutine mld_s_bwgs_solver_apply_vect(alpha,sv,x,beta,y,desc_data,trans,work,info) +subroutine mld_s_bwgs_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& + & trans,work,info,init,initu) use psb_base_mod use mld_s_gs_solver, mld_protect_name => mld_s_bwgs_solver_apply_vect @@ -49,14 +50,16 @@ subroutine mld_s_bwgs_solver_apply_vect(alpha,sv,x,beta,y,desc_data,trans,work,i character(len=1),intent(in) :: trans real(psb_spk_),target, intent(inout) :: work(:) integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: init + type(psb_s_vect_type),intent(inout), optional :: initu 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' + character :: trans_, init_ + character(len=20) :: name='s_bwgs_solver_apply' call psb_erractionsave(err_act) ictxt = desc_data%get_ctxt() @@ -72,6 +75,13 @@ subroutine mld_s_bwgs_solver_apply_vect(alpha,sv,x,beta,y,desc_data,trans,work,i call psb_errpush(psb_err_iarg_invalid_i_,name) goto 9999 end select + + if (present(init)) then + init_ = psb_toupper(init) + else + init_='Z' + end if + n_row = desc_data%get_local_rows() n_col = desc_data%get_local_cols() @@ -113,7 +123,24 @@ subroutine mld_s_bwgs_solver_apply_vect(alpha,sv,x,beta,y,desc_data,trans,work,i 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 (init_) + case('Z') + call xit%zero() + case('Y') + call psb_geaxpby(sone,y,szero,xit,desc_data,info) + case('U') + if (.not.present(initu)) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='missing initu to smoother_apply') + goto 9999 + end if + call psb_geaxpby(sone,initu,szero,xit,desc_data,info) + case default + call psb_errpush(psb_err_internal_error_,name,& + & a_err='wrong init to smoother_apply') + goto 9999 + end select + select case(trans_) case('N') if (sv%eps <=szero) then @@ -121,21 +148,12 @@ subroutine mld_s_bwgs_solver_apply_vect(alpha,sv,x,beta,y,desc_data,trans,work,i ! 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) diff --git a/mlprec/impl/solver/mld_s_diag_solver_apply.f90 b/mlprec/impl/solver/mld_s_diag_solver_apply.f90 index 3b5a1024..e801798d 100644 --- a/mlprec/impl/solver/mld_s_diag_solver_apply.f90 +++ b/mlprec/impl/solver/mld_s_diag_solver_apply.f90 @@ -36,7 +36,8 @@ !!$ POSSIBILITY OF SUCH DAMAGE. !!$ !!$ -subroutine mld_s_diag_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info) +subroutine mld_s_diag_solver_apply(alpha,sv,x,beta,y,desc_data,& + & trans,work,info,init,initu) use psb_base_mod use mld_s_diag_solver, mld_protect_name => mld_s_diag_solver_apply @@ -49,6 +50,8 @@ subroutine mld_s_diag_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info) character(len=1),intent(in) :: trans real(psb_spk_),target, intent(inout) :: work(:) integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: init + real(psb_spk_),intent(inout), optional :: initu(:) integer(psb_ipk_) :: n_row,n_col real(psb_spk_), pointer :: ww(:), aux(:), tx(:),ty(:) @@ -68,7 +71,10 @@ subroutine mld_s_diag_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info) call psb_errpush(psb_err_iarg_invalid_i_,name) goto 9999 end select - + ! + ! For non-iterative solvers, init and initu are ignored. + ! + n_row = desc_data%get_local_rows() n_col = desc_data%get_local_cols() diff --git a/mlprec/impl/solver/mld_s_diag_solver_apply_vect.f90 b/mlprec/impl/solver/mld_s_diag_solver_apply_vect.f90 index 2e1637ce..d85048ee 100644 --- a/mlprec/impl/solver/mld_s_diag_solver_apply_vect.f90 +++ b/mlprec/impl/solver/mld_s_diag_solver_apply_vect.f90 @@ -36,7 +36,8 @@ !!$ POSSIBILITY OF SUCH DAMAGE. !!$ !!$ -subroutine mld_s_diag_solver_apply_vect(alpha,sv,x,beta,y,desc_data,trans,work,info) +subroutine mld_s_diag_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& + & trans,work,info,init,initu) use psb_base_mod use mld_s_diag_solver, mld_protect_name => mld_s_diag_solver_apply_vect @@ -49,6 +50,8 @@ subroutine mld_s_diag_solver_apply_vect(alpha,sv,x,beta,y,desc_data,trans,work,i character(len=1),intent(in) :: trans real(psb_spk_),target, intent(inout) :: work(:) integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: init + type(psb_s_vect_type),intent(inout), optional :: initu integer(psb_ipk_) :: n_row,n_col real(psb_spk_), pointer :: ww(:), aux(:), tx(:),ty(:) @@ -68,6 +71,9 @@ subroutine mld_s_diag_solver_apply_vect(alpha,sv,x,beta,y,desc_data,trans,work,i call psb_errpush(psb_err_iarg_invalid_i_,name) goto 9999 end select + ! + ! For non-iterative solvers, init and initu are ignored. + ! n_row = desc_data%get_local_rows() n_col = desc_data%get_local_cols() diff --git a/mlprec/impl/solver/mld_s_gs_solver_apply.f90 b/mlprec/impl/solver/mld_s_gs_solver_apply.f90 index fa452a4d..a1987db3 100644 --- a/mlprec/impl/solver/mld_s_gs_solver_apply.f90 +++ b/mlprec/impl/solver/mld_s_gs_solver_apply.f90 @@ -36,7 +36,8 @@ !!$ POSSIBILITY OF SUCH DAMAGE. !!$ !!$ -subroutine mld_s_gs_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info) +subroutine mld_s_gs_solver_apply(alpha,sv,x,beta,y,desc_data,& + &trans,work,info,init,initu) use psb_base_mod use mld_s_gs_solver, mld_protect_name => mld_s_gs_solver_apply @@ -49,12 +50,14 @@ subroutine mld_s_gs_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info) character(len=1),intent(in) :: trans real(psb_spk_),target, intent(inout) :: work(:) integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: init + real(psb_spk_),intent(inout), optional :: initu(:) 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 :: trans_, init_ character(len=20) :: name='s_gs_solver_apply' call psb_erractionsave(err_act) @@ -71,6 +74,13 @@ subroutine mld_s_gs_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info) call psb_errpush(psb_err_iarg_invalid_i_,name) goto 9999 end select + + if (present(init)) then + init_ = psb_toupper(init) + else + init_='Z' + end if + n_row = desc_data%get_local_rows() n_col = desc_data%get_local_cols() @@ -108,9 +118,26 @@ subroutine mld_s_gs_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info) goto 9999 end if - call psb_geasb(wv,desc_data,info) - call psb_geasb(xit,desc_data,info) - + call psb_geasb(wv,desc_data,info) + call psb_geasb(xit,desc_data,info) + select case (init_) + case('Z') + xit(:) = szero + case('Y') + call psb_geaxpby(sone,y,szero,xit,desc_data,info) + case('U') + if (.not.present(initu)) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='missing initu to smoother_apply') + goto 9999 + end if + call psb_geaxpby(sone,initu,szero,xit,desc_data,info) + case default + call psb_errpush(psb_err_internal_error_,name,& + & a_err='wrong init to smoother_apply') + goto 9999 + end select + select case(trans_) case('N') if (sv%eps <=szero) then @@ -118,21 +145,12 @@ subroutine mld_s_gs_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info) ! 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 U. The off-diagonal block is taken care ! from the Jacobi smoother, hence this is purely local. call psb_spmm(-sone,sv%u,xit,sone,wv,desc_data,info,doswap=.false.) call psb_spsm(sone,sv%l,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) diff --git a/mlprec/impl/solver/mld_s_gs_solver_apply_vect.f90 b/mlprec/impl/solver/mld_s_gs_solver_apply_vect.f90 index 71698d13..529a7dfd 100644 --- a/mlprec/impl/solver/mld_s_gs_solver_apply_vect.f90 +++ b/mlprec/impl/solver/mld_s_gs_solver_apply_vect.f90 @@ -36,7 +36,8 @@ !!$ POSSIBILITY OF SUCH DAMAGE. !!$ !!$ -subroutine mld_s_gs_solver_apply_vect(alpha,sv,x,beta,y,desc_data,trans,work,info) +subroutine mld_s_gs_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& + & trans,work,info,init,initu) use psb_base_mod use mld_s_gs_solver, mld_protect_name => mld_s_gs_solver_apply_vect @@ -49,13 +50,15 @@ subroutine mld_s_gs_solver_apply_vect(alpha,sv,x,beta,y,desc_data,trans,work,inf character(len=1),intent(in) :: trans real(psb_spk_),target, intent(inout) :: work(:) integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: init + type(psb_s_vect_type),intent(inout), optional :: initu 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 :: trans_, init_ character(len=20) :: name='s_gs_solver_apply' call psb_erractionsave(err_act) @@ -72,6 +75,13 @@ subroutine mld_s_gs_solver_apply_vect(alpha,sv,x,beta,y,desc_data,trans,work,inf call psb_errpush(psb_err_iarg_invalid_i_,name) goto 9999 end select + + if (present(init)) then + init_ = psb_toupper(init) + else + init_='Z' + end if + n_row = desc_data%get_local_rows() n_col = desc_data%get_local_cols() @@ -113,7 +123,24 @@ subroutine mld_s_gs_solver_apply_vect(alpha,sv,x,beta,y,desc_data,trans,work,inf 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 (init_) + case('Z') + call xit%zero() + case('Y') + call psb_geaxpby(sone,y,szero,xit,desc_data,info) + case('U') + if (.not.present(initu)) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='missing initu to smoother_apply') + goto 9999 + end if + call psb_geaxpby(sone,initu,szero,xit,desc_data,info) + case default + call psb_errpush(psb_err_internal_error_,name,& + & a_err='wrong init to smoother_apply') + goto 9999 + end select + select case(trans_) case('N') if (sv%eps <=szero) then @@ -121,21 +148,12 @@ subroutine mld_s_gs_solver_apply_vect(alpha,sv,x,beta,y,desc_data,trans,work,inf ! 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 U. The off-diagonal block is taken care ! from the Jacobi smoother, hence this is purely local. call psb_spmm(-sone,sv%u,xit,sone,wv,desc_data,info,doswap=.false.) call psb_spsm(sone,sv%l,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) diff --git a/mlprec/impl/solver/mld_s_id_solver_apply.f90 b/mlprec/impl/solver/mld_s_id_solver_apply.f90 index 41229fb2..e4bf996c 100644 --- a/mlprec/impl/solver/mld_s_id_solver_apply.f90 +++ b/mlprec/impl/solver/mld_s_id_solver_apply.f90 @@ -36,7 +36,8 @@ !!$ POSSIBILITY OF SUCH DAMAGE. !!$ !!$ -subroutine mld_s_id_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info) +subroutine mld_s_id_solver_apply(alpha,sv,x,beta,y,desc_data,& + & trans,work,info,init,initu) use psb_base_mod use mld_s_id_solver, mld_protect_name => mld_s_id_solver_apply @@ -49,6 +50,8 @@ subroutine mld_s_id_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info) character(len=1),intent(in) :: trans real(psb_spk_),target, intent(inout) :: work(:) integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: init + real(psb_spk_),intent(inout), optional :: initu(:) integer(psb_ipk_) :: n_row,n_col integer(psb_ipk_) :: ictxt,np,me,i, err_act @@ -68,6 +71,9 @@ subroutine mld_s_id_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info) call psb_errpush(psb_err_iarg_invalid_i_,name) goto 9999 end select + ! + ! For non-iterative solvers, init and initu are ignored. + ! call psb_geaxpby(alpha,x,beta,y,desc_data,info) diff --git a/mlprec/impl/solver/mld_s_id_solver_apply_vect.f90 b/mlprec/impl/solver/mld_s_id_solver_apply_vect.f90 index 31aa7ee7..2d8029e8 100644 --- a/mlprec/impl/solver/mld_s_id_solver_apply_vect.f90 +++ b/mlprec/impl/solver/mld_s_id_solver_apply_vect.f90 @@ -36,7 +36,8 @@ !!$ POSSIBILITY OF SUCH DAMAGE. !!$ !!$ -subroutine mld_s_id_solver_apply_vect(alpha,sv,x,beta,y,desc_data,trans,work,info) +subroutine mld_s_id_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& + & trans,work,info,init,initu) use psb_base_mod use mld_s_id_solver, mld_protect_name => mld_s_id_solver_apply_vect @@ -49,6 +50,8 @@ subroutine mld_s_id_solver_apply_vect(alpha,sv,x,beta,y,desc_data,trans,work,inf character(len=1),intent(in) :: trans real(psb_spk_),target, intent(inout) :: work(:) integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: init + type(psb_s_vect_type),intent(inout), optional :: initu integer(psb_ipk_) :: n_row,n_col integer(psb_ipk_) :: ictxt,np,me,i, err_act @@ -68,6 +71,9 @@ subroutine mld_s_id_solver_apply_vect(alpha,sv,x,beta,y,desc_data,trans,work,inf call psb_errpush(psb_err_iarg_invalid_i_,name) goto 9999 end select + ! + ! For non-iterative solvers, init and initu are ignored. + ! call psb_geaxpby(alpha,x,beta,y,desc_data,info) diff --git a/mlprec/impl/solver/mld_s_ilu_solver_apply.f90 b/mlprec/impl/solver/mld_s_ilu_solver_apply.f90 index ed042dec..05c614ac 100644 --- a/mlprec/impl/solver/mld_s_ilu_solver_apply.f90 +++ b/mlprec/impl/solver/mld_s_ilu_solver_apply.f90 @@ -36,7 +36,8 @@ !!$ POSSIBILITY OF SUCH DAMAGE. !!$ !!$ -subroutine mld_s_ilu_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info) +subroutine mld_s_ilu_solver_apply(alpha,sv,x,beta,y,desc_data,& + & trans,work,info,init,initu) use psb_base_mod use mld_s_ilu_solver, mld_protect_name => mld_s_ilu_solver_apply @@ -49,6 +50,8 @@ subroutine mld_s_ilu_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info) character(len=1),intent(in) :: trans real(psb_spk_),target, intent(inout) :: work(:) integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: init + real(psb_spk_),intent(inout), optional :: initu(:) integer(psb_ipk_) :: n_row,n_col real(psb_spk_), pointer :: ww(:), aux(:), tx(:),ty(:) @@ -68,6 +71,9 @@ subroutine mld_s_ilu_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info) call psb_errpush(psb_err_iarg_invalid_i_,name) goto 9999 end select + ! + ! For non-iterative solvers, init and initu are ignored. + ! n_row = desc_data%get_local_rows() n_col = desc_data%get_local_cols() diff --git a/mlprec/impl/solver/mld_s_ilu_solver_apply_vect.f90 b/mlprec/impl/solver/mld_s_ilu_solver_apply_vect.f90 index 04179571..a37e8e17 100644 --- a/mlprec/impl/solver/mld_s_ilu_solver_apply_vect.f90 +++ b/mlprec/impl/solver/mld_s_ilu_solver_apply_vect.f90 @@ -36,7 +36,8 @@ !!$ POSSIBILITY OF SUCH DAMAGE. !!$ !!$ -subroutine mld_s_ilu_solver_apply_vect(alpha,sv,x,beta,y,desc_data,trans,work,info) +subroutine mld_s_ilu_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& + & trans,work,info,init,initu) use psb_base_mod use mld_s_ilu_solver, mld_protect_name => mld_s_ilu_solver_apply_vect @@ -49,6 +50,8 @@ subroutine mld_s_ilu_solver_apply_vect(alpha,sv,x,beta,y,desc_data,trans,work,in character(len=1),intent(in) :: trans real(psb_spk_),target, intent(inout) :: work(:) integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: init + type(psb_s_vect_type),intent(inout), optional :: initu integer(psb_ipk_) :: n_row,n_col type(psb_s_vect_type) :: wv, wv1 @@ -70,6 +73,9 @@ subroutine mld_s_ilu_solver_apply_vect(alpha,sv,x,beta,y,desc_data,trans,work,in call psb_errpush(psb_err_iarg_invalid_i_,name) goto 9999 end select + ! + ! For non-iterative solvers, init and initu are ignored. + ! n_row = desc_data%get_local_rows() n_col = desc_data%get_local_cols() diff --git a/mlprec/impl/solver/mld_s_mumps_solver_apply.F90 b/mlprec/impl/solver/mld_s_mumps_solver_apply.F90 index 75e288f0..2481d7d7 100644 --- a/mlprec/impl/solver/mld_s_mumps_solver_apply.F90 +++ b/mlprec/impl/solver/mld_s_mumps_solver_apply.F90 @@ -36,112 +36,116 @@ !!$ POSSIBILITY OF SUCH DAMAGE. !!$ !!$ +subroutine s_mumps_solver_apply(alpha,sv,x,beta,y,desc_data,& + & trans,work,info,init,initu) + use psb_base_mod + use mld_s_mumps_solver + implicit none + type(psb_desc_type), intent(in) :: desc_data + class(mld_s_mumps_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 + character, intent(in), optional :: init + real(psb_spk_),intent(inout), optional :: initu(:) + integer(psb_ipk_) :: n_row, n_col, nglob + real(psb_spk_), allocatable :: ww(:) + real(psb_spk_), allocatable, target :: gx(:) + integer(psb_ipk_) :: ictxt,np,me,i, err_act + character :: trans_ + character(len=20) :: name='s_mumps_solver_apply' -subroutine s_mumps_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info) - use psb_base_mod - use mld_s_mumps_solver - implicit none - type(psb_desc_type), intent(in) :: desc_data - class(mld_s_mumps_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, nglob - real(psb_spk_), allocatable :: ww(:) - real(psb_spk_), allocatable, target :: gx(:) - integer(psb_ipk_) :: ictxt,np,me,i, err_act - character :: trans_ - character(len=20) :: name='s_mumps_solver_apply' - - call psb_erractionsave(err_act) + call psb_erractionsave(err_act) #if defined(HAVE_MUMPS_) - info = psb_success_ - trans_ = psb_toupper(trans) - select case(trans_) - case('N') - case('T') - case default - call psb_errpush(psb_err_iarg_invalid_i_,name) - goto 9999 - end select + info = psb_success_ + trans_ = psb_toupper(trans) + select case(trans_) + case('N') + case('T') + case default + call psb_errpush(psb_err_iarg_invalid_i_,name) + goto 9999 + end select + ! + ! For non-iterative solvers, init and initu are ignored. + ! - nglob = desc_data%get_global_rows() - n_row = desc_data%get_local_rows() - n_col = desc_data%get_local_cols() + nglob = desc_data%get_global_rows() + 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) - else - allocate(ww(n_col),stat=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='real(psb_spk_)') - goto 9999 - end if - end if - allocate(gx(nglob),stat=info) + if (n_col <= size(work)) then + ww = work(1:n_col) + else + allocate(ww(n_col),stat=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='real(psb_spk_)') - goto 9999 + info=psb_err_alloc_request_ + call psb_errpush(info,name,i_err=(/n_col,0,0,0,0/),& + & a_err='real(psb_spk_)') + goto 9999 end if - call psb_gather(gx, x, desc_data, info, root=0) - select case(trans_) - case('N') - sv%id%icntl(9) = 1 - case('T') - sv%id%icntl(9) = 2 - case default - call psb_errpush(psb_err_internal_error_,& - & name,a_err='Invalid TRANS in subsolve') - goto 9999 - end select + end if + allocate(gx(nglob),stat=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='real(psb_spk_)') + goto 9999 + end if + call psb_gather(gx, x, desc_data, info, root=0) + select case(trans_) + case('N') + sv%id%icntl(9) = 1 + case('T') + sv%id%icntl(9) = 2 + case default + call psb_errpush(psb_err_internal_error_,& + & name,a_err='Invalid TRANS in subsolve') + 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 - call smumps(sv%id) - call psb_scatter(gx, ww, desc_data, info, root=0) - - if (info == psb_success_) then - call psb_geaxpby(alpha,ww,beta,y,desc_data,info) - end if + 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 smumps(sv%id) + call psb_scatter(gx, ww, desc_data, info, root=0) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,& - & name,a_err='Error in subsolve') - goto 9999 - endif + if (info == psb_success_) then + call psb_geaxpby(alpha,ww,beta,y,desc_data,info) + end if - if (nglob > size(work)) then - deallocate(ww) - endif + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,& + & name,a_err='Error in subsolve') + goto 9999 + endif - call psb_erractionrestore(err_act) - return + if (nglob > size(work)) then + deallocate(ww) + endif + + call psb_erractionrestore(err_act) + return 9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() return + end if + return #else - write(psb_err_unit,*) "MUMPS Not Configured, fix make.inc and recompile " + write(psb_err_unit,*) "MUMPS Not Configured, fix make.inc and recompile " #endif - end subroutine s_mumps_solver_apply +end subroutine s_mumps_solver_apply 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 0f6ad665..b3dd1fc1 100644 --- a/mlprec/impl/solver/mld_s_mumps_solver_apply_vect.F90 +++ b/mlprec/impl/solver/mld_s_mumps_solver_apply_vect.F90 @@ -36,49 +36,54 @@ !!$ POSSIBILITY OF SUCH DAMAGE. !!$ !!$ +subroutine s_mumps_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& + & trans,work,info,init,initu) + use psb_base_mod + use mld_s_mumps_solver + implicit none + type(psb_desc_type), intent(in) :: desc_data + class(mld_s_mumps_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 + character, intent(in), optional :: init + type(psb_s_vect_type),intent(inout), optional :: initu - subroutine s_mumps_solver_apply_vect(alpha,sv,x,beta,y,desc_data,trans,work,info) - use psb_base_mod - use mld_s_mumps_solver - implicit none - type(psb_desc_type), intent(in) :: desc_data - class(mld_s_mumps_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_) :: err_act - character(len=20) :: name='s_mumps_solver_apply_vect' + integer(psb_ipk_) :: err_act + character(len=20) :: name='s_mumps_solver_apply_vect' #if defined(HAVE_MUMPS_) - call psb_erractionsave(err_act) + call psb_erractionsave(err_act) - info = psb_success_ + info = psb_success_ + ! + ! For non-iterative solvers, init and initu are ignored. + ! - call x%v%sync() - call y%v%sync() - call sv%apply(alpha,x%v%v,beta,y%v%v,desc_data,trans,work,info) - call y%v%set_host() - if (info /= 0) goto 9999 + call x%v%sync() + call y%v%sync() + call sv%apply(alpha,x%v%v,beta,y%v%v,desc_data,trans,work,info) + call y%v%set_host() + if (info /= 0) goto 9999 - call psb_erractionrestore(err_act) - return + call psb_erractionrestore(err_act) + return 9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() return + end if + return #else - write(psb_err_unit,*) "MUMPS Not Configured, fix make.inc and recompile " + write(psb_err_unit,*) "MUMPS Not Configured, fix make.inc and recompile " #endif - end subroutine s_mumps_solver_apply_vect +end subroutine s_mumps_solver_apply_vect diff --git a/mlprec/impl/solver/mld_z_base_solver_apply.f90 b/mlprec/impl/solver/mld_z_base_solver_apply.f90 index 0d78f05f..5fed2474 100644 --- a/mlprec/impl/solver/mld_z_base_solver_apply.f90 +++ b/mlprec/impl/solver/mld_z_base_solver_apply.f90 @@ -36,7 +36,8 @@ !!$ POSSIBILITY OF SUCH DAMAGE. !!$ !!$ -subroutine mld_z_base_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info) +subroutine mld_z_base_solver_apply(alpha,sv,x,beta,y,desc_data,& + & trans,work,info,init,initu) use psb_base_mod use mld_z_base_solver_mod, mld_protect_name => mld_z_base_solver_apply @@ -49,6 +50,8 @@ subroutine mld_z_base_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info) character(len=1),intent(in) :: trans complex(psb_dpk_),target, intent(inout) :: work(:) integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: init + complex(psb_dpk_),intent(inout), optional :: initu(:) integer(psb_ipk_) :: err_act character(len=20) :: name='z_base_solver_apply' diff --git a/mlprec/impl/solver/mld_z_base_solver_apply_vect.f90 b/mlprec/impl/solver/mld_z_base_solver_apply_vect.f90 index fe965257..0402d631 100644 --- a/mlprec/impl/solver/mld_z_base_solver_apply_vect.f90 +++ b/mlprec/impl/solver/mld_z_base_solver_apply_vect.f90 @@ -36,7 +36,8 @@ !!$ POSSIBILITY OF SUCH DAMAGE. !!$ !!$ -subroutine mld_z_base_solver_apply_vect(alpha,sv,x,beta,y,desc_data,trans,work,info) +subroutine mld_z_base_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& + & trans,work,info,init,initu) use psb_base_mod use mld_z_base_solver_mod, mld_protect_name => mld_z_base_solver_apply_vect @@ -49,6 +50,8 @@ subroutine mld_z_base_solver_apply_vect(alpha,sv,x,beta,y,desc_data,trans,work,i character(len=1),intent(in) :: trans complex(psb_dpk_),target, intent(inout) :: work(:) integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: init + type(psb_z_vect_type),intent(inout), optional :: initu integer(psb_ipk_) :: err_act character(len=20) :: name='z_base_solver_apply_vect' diff --git a/mlprec/impl/solver/mld_z_bwgs_solver_apply.f90 b/mlprec/impl/solver/mld_z_bwgs_solver_apply.f90 index e5344433..c4431752 100644 --- a/mlprec/impl/solver/mld_z_bwgs_solver_apply.f90 +++ b/mlprec/impl/solver/mld_z_bwgs_solver_apply.f90 @@ -36,7 +36,8 @@ !!$ POSSIBILITY OF SUCH DAMAGE. !!$ !!$ -subroutine mld_z_bwgs_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info) +subroutine mld_z_bwgs_solver_apply(alpha,sv,x,beta,y,desc_data,& + &trans,work,info,init,initu) use psb_base_mod use mld_z_gs_solver, mld_protect_name => mld_z_bwgs_solver_apply @@ -49,13 +50,15 @@ subroutine mld_z_bwgs_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info) character(len=1),intent(in) :: trans complex(psb_dpk_),target, intent(inout) :: work(:) integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: init + complex(psb_dpk_),intent(inout), optional :: initu(:) 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' + character :: trans_, init_ + character(len=20) :: name='z_bwgs_solver_apply' call psb_erractionsave(err_act) ictxt = desc_data%get_ctxt() @@ -71,6 +74,13 @@ subroutine mld_z_bwgs_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info) call psb_errpush(psb_err_iarg_invalid_i_,name) goto 9999 end select + + if (present(init)) then + init_ = psb_toupper(init) + else + init_='Z' + end if + n_row = desc_data%get_local_rows() n_col = desc_data%get_local_cols() @@ -108,9 +118,26 @@ subroutine mld_z_bwgs_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info) goto 9999 end if - call psb_geasb(wv,desc_data,info) - call psb_geasb(xit,desc_data,info) - + call psb_geasb(wv,desc_data,info) + call psb_geasb(xit,desc_data,info) + select case (init_) + case('Z') + xit(:) = zzero + case('Y') + call psb_geaxpby(zone,y,zzero,xit,desc_data,info) + case('U') + if (.not.present(initu)) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='missing initu to smoother_apply') + goto 9999 + end if + call psb_geaxpby(zone,initu,zzero,xit,desc_data,info) + case default + call psb_errpush(psb_err_internal_error_,name,& + & a_err='wrong init to smoother_apply') + goto 9999 + end select + select case(trans_) case('N') if (sv%eps <=dzero) then @@ -118,21 +145,12 @@ subroutine mld_z_bwgs_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info) ! 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) diff --git a/mlprec/impl/solver/mld_z_bwgs_solver_apply_vect.f90 b/mlprec/impl/solver/mld_z_bwgs_solver_apply_vect.f90 index 809d9605..7c1c042e 100644 --- a/mlprec/impl/solver/mld_z_bwgs_solver_apply_vect.f90 +++ b/mlprec/impl/solver/mld_z_bwgs_solver_apply_vect.f90 @@ -36,7 +36,8 @@ !!$ POSSIBILITY OF SUCH DAMAGE. !!$ !!$ -subroutine mld_z_bwgs_solver_apply_vect(alpha,sv,x,beta,y,desc_data,trans,work,info) +subroutine mld_z_bwgs_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& + & trans,work,info,init,initu) use psb_base_mod use mld_z_gs_solver, mld_protect_name => mld_z_bwgs_solver_apply_vect @@ -49,14 +50,16 @@ subroutine mld_z_bwgs_solver_apply_vect(alpha,sv,x,beta,y,desc_data,trans,work,i character(len=1),intent(in) :: trans complex(psb_dpk_),target, intent(inout) :: work(:) integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: init + type(psb_z_vect_type),intent(inout), optional :: initu 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' + character :: trans_, init_ + character(len=20) :: name='z_bwgs_solver_apply' call psb_erractionsave(err_act) ictxt = desc_data%get_ctxt() @@ -72,6 +75,13 @@ subroutine mld_z_bwgs_solver_apply_vect(alpha,sv,x,beta,y,desc_data,trans,work,i call psb_errpush(psb_err_iarg_invalid_i_,name) goto 9999 end select + + if (present(init)) then + init_ = psb_toupper(init) + else + init_='Z' + end if + n_row = desc_data%get_local_rows() n_col = desc_data%get_local_cols() @@ -113,7 +123,24 @@ subroutine mld_z_bwgs_solver_apply_vect(alpha,sv,x,beta,y,desc_data,trans,work,i 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 (init_) + case('Z') + call xit%zero() + case('Y') + call psb_geaxpby(zone,y,zzero,xit,desc_data,info) + case('U') + if (.not.present(initu)) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='missing initu to smoother_apply') + goto 9999 + end if + call psb_geaxpby(zone,initu,zzero,xit,desc_data,info) + case default + call psb_errpush(psb_err_internal_error_,name,& + & a_err='wrong init to smoother_apply') + goto 9999 + end select + select case(trans_) case('N') if (sv%eps <=dzero) then @@ -121,21 +148,12 @@ subroutine mld_z_bwgs_solver_apply_vect(alpha,sv,x,beta,y,desc_data,trans,work,i ! 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) diff --git a/mlprec/impl/solver/mld_z_diag_solver_apply.f90 b/mlprec/impl/solver/mld_z_diag_solver_apply.f90 index 474add0a..12d31002 100644 --- a/mlprec/impl/solver/mld_z_diag_solver_apply.f90 +++ b/mlprec/impl/solver/mld_z_diag_solver_apply.f90 @@ -36,7 +36,8 @@ !!$ POSSIBILITY OF SUCH DAMAGE. !!$ !!$ -subroutine mld_z_diag_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info) +subroutine mld_z_diag_solver_apply(alpha,sv,x,beta,y,desc_data,& + & trans,work,info,init,initu) use psb_base_mod use mld_z_diag_solver, mld_protect_name => mld_z_diag_solver_apply @@ -49,6 +50,8 @@ subroutine mld_z_diag_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info) character(len=1),intent(in) :: trans complex(psb_dpk_),target, intent(inout) :: work(:) integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: init + complex(psb_dpk_),intent(inout), optional :: initu(:) integer(psb_ipk_) :: n_row,n_col complex(psb_dpk_), pointer :: ww(:), aux(:), tx(:),ty(:) @@ -68,7 +71,10 @@ subroutine mld_z_diag_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info) call psb_errpush(psb_err_iarg_invalid_i_,name) goto 9999 end select - + ! + ! For non-iterative solvers, init and initu are ignored. + ! + n_row = desc_data%get_local_rows() n_col = desc_data%get_local_cols() diff --git a/mlprec/impl/solver/mld_z_diag_solver_apply_vect.f90 b/mlprec/impl/solver/mld_z_diag_solver_apply_vect.f90 index 028524e6..42c8cbd3 100644 --- a/mlprec/impl/solver/mld_z_diag_solver_apply_vect.f90 +++ b/mlprec/impl/solver/mld_z_diag_solver_apply_vect.f90 @@ -36,7 +36,8 @@ !!$ POSSIBILITY OF SUCH DAMAGE. !!$ !!$ -subroutine mld_z_diag_solver_apply_vect(alpha,sv,x,beta,y,desc_data,trans,work,info) +subroutine mld_z_diag_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& + & trans,work,info,init,initu) use psb_base_mod use mld_z_diag_solver, mld_protect_name => mld_z_diag_solver_apply_vect @@ -49,6 +50,8 @@ subroutine mld_z_diag_solver_apply_vect(alpha,sv,x,beta,y,desc_data,trans,work,i character(len=1),intent(in) :: trans complex(psb_dpk_),target, intent(inout) :: work(:) integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: init + type(psb_z_vect_type),intent(inout), optional :: initu integer(psb_ipk_) :: n_row,n_col complex(psb_dpk_), pointer :: ww(:), aux(:), tx(:),ty(:) @@ -68,6 +71,9 @@ subroutine mld_z_diag_solver_apply_vect(alpha,sv,x,beta,y,desc_data,trans,work,i call psb_errpush(psb_err_iarg_invalid_i_,name) goto 9999 end select + ! + ! For non-iterative solvers, init and initu are ignored. + ! n_row = desc_data%get_local_rows() n_col = desc_data%get_local_cols() diff --git a/mlprec/impl/solver/mld_z_gs_solver_apply.f90 b/mlprec/impl/solver/mld_z_gs_solver_apply.f90 index e11bc09d..adbf7bbf 100644 --- a/mlprec/impl/solver/mld_z_gs_solver_apply.f90 +++ b/mlprec/impl/solver/mld_z_gs_solver_apply.f90 @@ -36,7 +36,8 @@ !!$ POSSIBILITY OF SUCH DAMAGE. !!$ !!$ -subroutine mld_z_gs_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info) +subroutine mld_z_gs_solver_apply(alpha,sv,x,beta,y,desc_data,& + &trans,work,info,init,initu) use psb_base_mod use mld_z_gs_solver, mld_protect_name => mld_z_gs_solver_apply @@ -49,12 +50,14 @@ subroutine mld_z_gs_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info) character(len=1),intent(in) :: trans complex(psb_dpk_),target, intent(inout) :: work(:) integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: init + complex(psb_dpk_),intent(inout), optional :: initu(:) 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 :: trans_, init_ character(len=20) :: name='z_gs_solver_apply' call psb_erractionsave(err_act) @@ -71,6 +74,13 @@ subroutine mld_z_gs_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info) call psb_errpush(psb_err_iarg_invalid_i_,name) goto 9999 end select + + if (present(init)) then + init_ = psb_toupper(init) + else + init_='Z' + end if + n_row = desc_data%get_local_rows() n_col = desc_data%get_local_cols() @@ -108,9 +118,26 @@ subroutine mld_z_gs_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info) goto 9999 end if - call psb_geasb(wv,desc_data,info) - call psb_geasb(xit,desc_data,info) - + call psb_geasb(wv,desc_data,info) + call psb_geasb(xit,desc_data,info) + select case (init_) + case('Z') + xit(:) = zzero + case('Y') + call psb_geaxpby(zone,y,zzero,xit,desc_data,info) + case('U') + if (.not.present(initu)) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='missing initu to smoother_apply') + goto 9999 + end if + call psb_geaxpby(zone,initu,zzero,xit,desc_data,info) + case default + call psb_errpush(psb_err_internal_error_,name,& + & a_err='wrong init to smoother_apply') + goto 9999 + end select + select case(trans_) case('N') if (sv%eps <=dzero) then @@ -118,21 +145,12 @@ subroutine mld_z_gs_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info) ! 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 U. The off-diagonal block is taken care ! from the Jacobi smoother, hence this is purely local. call psb_spmm(-zone,sv%u,xit,zone,wv,desc_data,info,doswap=.false.) call psb_spsm(zone,sv%l,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) diff --git a/mlprec/impl/solver/mld_z_gs_solver_apply_vect.f90 b/mlprec/impl/solver/mld_z_gs_solver_apply_vect.f90 index 5140cdd7..83017475 100644 --- a/mlprec/impl/solver/mld_z_gs_solver_apply_vect.f90 +++ b/mlprec/impl/solver/mld_z_gs_solver_apply_vect.f90 @@ -36,7 +36,8 @@ !!$ POSSIBILITY OF SUCH DAMAGE. !!$ !!$ -subroutine mld_z_gs_solver_apply_vect(alpha,sv,x,beta,y,desc_data,trans,work,info) +subroutine mld_z_gs_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& + & trans,work,info,init,initu) use psb_base_mod use mld_z_gs_solver, mld_protect_name => mld_z_gs_solver_apply_vect @@ -49,13 +50,15 @@ subroutine mld_z_gs_solver_apply_vect(alpha,sv,x,beta,y,desc_data,trans,work,inf character(len=1),intent(in) :: trans complex(psb_dpk_),target, intent(inout) :: work(:) integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: init + type(psb_z_vect_type),intent(inout), optional :: initu 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 :: trans_, init_ character(len=20) :: name='z_gs_solver_apply' call psb_erractionsave(err_act) @@ -72,6 +75,13 @@ subroutine mld_z_gs_solver_apply_vect(alpha,sv,x,beta,y,desc_data,trans,work,inf call psb_errpush(psb_err_iarg_invalid_i_,name) goto 9999 end select + + if (present(init)) then + init_ = psb_toupper(init) + else + init_='Z' + end if + n_row = desc_data%get_local_rows() n_col = desc_data%get_local_cols() @@ -113,7 +123,24 @@ subroutine mld_z_gs_solver_apply_vect(alpha,sv,x,beta,y,desc_data,trans,work,inf 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 (init_) + case('Z') + call xit%zero() + case('Y') + call psb_geaxpby(zone,y,zzero,xit,desc_data,info) + case('U') + if (.not.present(initu)) then + call psb_errpush(psb_err_internal_error_,name,& + & a_err='missing initu to smoother_apply') + goto 9999 + end if + call psb_geaxpby(zone,initu,zzero,xit,desc_data,info) + case default + call psb_errpush(psb_err_internal_error_,name,& + & a_err='wrong init to smoother_apply') + goto 9999 + end select + select case(trans_) case('N') if (sv%eps <=dzero) then @@ -121,21 +148,12 @@ subroutine mld_z_gs_solver_apply_vect(alpha,sv,x,beta,y,desc_data,trans,work,inf ! 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 U. The off-diagonal block is taken care ! from the Jacobi smoother, hence this is purely local. call psb_spmm(-zone,sv%u,xit,zone,wv,desc_data,info,doswap=.false.) call psb_spsm(zone,sv%l,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) diff --git a/mlprec/impl/solver/mld_z_id_solver_apply.f90 b/mlprec/impl/solver/mld_z_id_solver_apply.f90 index 75008d18..43726a1a 100644 --- a/mlprec/impl/solver/mld_z_id_solver_apply.f90 +++ b/mlprec/impl/solver/mld_z_id_solver_apply.f90 @@ -36,7 +36,8 @@ !!$ POSSIBILITY OF SUCH DAMAGE. !!$ !!$ -subroutine mld_z_id_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info) +subroutine mld_z_id_solver_apply(alpha,sv,x,beta,y,desc_data,& + & trans,work,info,init,initu) use psb_base_mod use mld_z_id_solver, mld_protect_name => mld_z_id_solver_apply @@ -49,6 +50,8 @@ subroutine mld_z_id_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info) character(len=1),intent(in) :: trans complex(psb_dpk_),target, intent(inout) :: work(:) integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: init + complex(psb_dpk_),intent(inout), optional :: initu(:) integer(psb_ipk_) :: n_row,n_col integer(psb_ipk_) :: ictxt,np,me,i, err_act @@ -68,6 +71,9 @@ subroutine mld_z_id_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info) call psb_errpush(psb_err_iarg_invalid_i_,name) goto 9999 end select + ! + ! For non-iterative solvers, init and initu are ignored. + ! call psb_geaxpby(alpha,x,beta,y,desc_data,info) diff --git a/mlprec/impl/solver/mld_z_id_solver_apply_vect.f90 b/mlprec/impl/solver/mld_z_id_solver_apply_vect.f90 index 2e1cfbca..2f48c06e 100644 --- a/mlprec/impl/solver/mld_z_id_solver_apply_vect.f90 +++ b/mlprec/impl/solver/mld_z_id_solver_apply_vect.f90 @@ -36,7 +36,8 @@ !!$ POSSIBILITY OF SUCH DAMAGE. !!$ !!$ -subroutine mld_z_id_solver_apply_vect(alpha,sv,x,beta,y,desc_data,trans,work,info) +subroutine mld_z_id_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& + & trans,work,info,init,initu) use psb_base_mod use mld_z_id_solver, mld_protect_name => mld_z_id_solver_apply_vect @@ -49,6 +50,8 @@ subroutine mld_z_id_solver_apply_vect(alpha,sv,x,beta,y,desc_data,trans,work,inf character(len=1),intent(in) :: trans complex(psb_dpk_),target, intent(inout) :: work(:) integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: init + type(psb_z_vect_type),intent(inout), optional :: initu integer(psb_ipk_) :: n_row,n_col integer(psb_ipk_) :: ictxt,np,me,i, err_act @@ -68,6 +71,9 @@ subroutine mld_z_id_solver_apply_vect(alpha,sv,x,beta,y,desc_data,trans,work,inf call psb_errpush(psb_err_iarg_invalid_i_,name) goto 9999 end select + ! + ! For non-iterative solvers, init and initu are ignored. + ! call psb_geaxpby(alpha,x,beta,y,desc_data,info) diff --git a/mlprec/impl/solver/mld_z_ilu_solver_apply.f90 b/mlprec/impl/solver/mld_z_ilu_solver_apply.f90 index 1becae99..e5f37979 100644 --- a/mlprec/impl/solver/mld_z_ilu_solver_apply.f90 +++ b/mlprec/impl/solver/mld_z_ilu_solver_apply.f90 @@ -36,7 +36,8 @@ !!$ POSSIBILITY OF SUCH DAMAGE. !!$ !!$ -subroutine mld_z_ilu_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info) +subroutine mld_z_ilu_solver_apply(alpha,sv,x,beta,y,desc_data,& + & trans,work,info,init,initu) use psb_base_mod use mld_z_ilu_solver, mld_protect_name => mld_z_ilu_solver_apply @@ -49,6 +50,8 @@ subroutine mld_z_ilu_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info) character(len=1),intent(in) :: trans complex(psb_dpk_),target, intent(inout) :: work(:) integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: init + complex(psb_dpk_),intent(inout), optional :: initu(:) integer(psb_ipk_) :: n_row,n_col complex(psb_dpk_), pointer :: ww(:), aux(:), tx(:),ty(:) @@ -68,6 +71,9 @@ subroutine mld_z_ilu_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info) call psb_errpush(psb_err_iarg_invalid_i_,name) goto 9999 end select + ! + ! For non-iterative solvers, init and initu are ignored. + ! n_row = desc_data%get_local_rows() n_col = desc_data%get_local_cols() diff --git a/mlprec/impl/solver/mld_z_ilu_solver_apply_vect.f90 b/mlprec/impl/solver/mld_z_ilu_solver_apply_vect.f90 index 9daf8470..42ddd62d 100644 --- a/mlprec/impl/solver/mld_z_ilu_solver_apply_vect.f90 +++ b/mlprec/impl/solver/mld_z_ilu_solver_apply_vect.f90 @@ -36,7 +36,8 @@ !!$ POSSIBILITY OF SUCH DAMAGE. !!$ !!$ -subroutine mld_z_ilu_solver_apply_vect(alpha,sv,x,beta,y,desc_data,trans,work,info) +subroutine mld_z_ilu_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& + & trans,work,info,init,initu) use psb_base_mod use mld_z_ilu_solver, mld_protect_name => mld_z_ilu_solver_apply_vect @@ -49,6 +50,8 @@ subroutine mld_z_ilu_solver_apply_vect(alpha,sv,x,beta,y,desc_data,trans,work,in character(len=1),intent(in) :: trans complex(psb_dpk_),target, intent(inout) :: work(:) integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: init + type(psb_z_vect_type),intent(inout), optional :: initu integer(psb_ipk_) :: n_row,n_col type(psb_z_vect_type) :: wv, wv1 @@ -70,6 +73,9 @@ subroutine mld_z_ilu_solver_apply_vect(alpha,sv,x,beta,y,desc_data,trans,work,in call psb_errpush(psb_err_iarg_invalid_i_,name) goto 9999 end select + ! + ! For non-iterative solvers, init and initu are ignored. + ! n_row = desc_data%get_local_rows() n_col = desc_data%get_local_cols() diff --git a/mlprec/impl/solver/mld_z_mumps_solver_apply.F90 b/mlprec/impl/solver/mld_z_mumps_solver_apply.F90 index 66348759..d8939417 100644 --- a/mlprec/impl/solver/mld_z_mumps_solver_apply.F90 +++ b/mlprec/impl/solver/mld_z_mumps_solver_apply.F90 @@ -36,112 +36,116 @@ !!$ POSSIBILITY OF SUCH DAMAGE. !!$ !!$ +subroutine z_mumps_solver_apply(alpha,sv,x,beta,y,desc_data,& + & trans,work,info,init,initu) + use psb_base_mod + use mld_z_mumps_solver + implicit none + type(psb_desc_type), intent(in) :: desc_data + class(mld_z_mumps_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 + character, intent(in), optional :: init + complex(psb_dpk_),intent(inout), optional :: initu(:) + integer(psb_ipk_) :: n_row, n_col, nglob + complex(psb_dpk_), allocatable :: ww(:) + complex(psb_dpk_), allocatable, target :: gx(:) + integer(psb_ipk_) :: ictxt,np,me,i, err_act + character :: trans_ + character(len=20) :: name='z_mumps_solver_apply' -subroutine z_mumps_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info) - use psb_base_mod - use mld_z_mumps_solver - implicit none - type(psb_desc_type), intent(in) :: desc_data - class(mld_z_mumps_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, nglob - complex(psb_dpk_), allocatable :: ww(:) - complex(psb_dpk_), allocatable, target :: gx(:) - integer(psb_ipk_) :: ictxt,np,me,i, err_act - character :: trans_ - character(len=20) :: name='z_mumps_solver_apply' - - call psb_erractionsave(err_act) + call psb_erractionsave(err_act) #if defined(HAVE_MUMPS_) - info = psb_success_ - trans_ = psb_toupper(trans) - select case(trans_) - case('N') - case('T') - case default - call psb_errpush(psb_err_iarg_invalid_i_,name) - goto 9999 - end select + info = psb_success_ + trans_ = psb_toupper(trans) + select case(trans_) + case('N') + case('T') + case default + call psb_errpush(psb_err_iarg_invalid_i_,name) + goto 9999 + end select + ! + ! For non-iterative solvers, init and initu are ignored. + ! - nglob = desc_data%get_global_rows() - n_row = desc_data%get_local_rows() - n_col = desc_data%get_local_cols() + nglob = desc_data%get_global_rows() + 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) - else - allocate(ww(n_col),stat=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_dpk_)') - goto 9999 - end if - end if - allocate(gx(nglob),stat=info) + if (n_col <= size(work)) then + ww = work(1:n_col) + else + allocate(ww(n_col),stat=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_dpk_)') - goto 9999 + info=psb_err_alloc_request_ + call psb_errpush(info,name,i_err=(/n_col,0,0,0,0/),& + & a_err='complex(psb_dpk_)') + goto 9999 end if - call psb_gather(gx, x, desc_data, info, root=0) - select case(trans_) - case('N') - sv%id%icntl(9) = 1 - case('T') - sv%id%icntl(9) = 2 - case default - call psb_errpush(psb_err_internal_error_,& - & name,a_err='Invalid TRANS in subsolve') - goto 9999 - end select + end if + allocate(gx(nglob),stat=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_dpk_)') + goto 9999 + end if + call psb_gather(gx, x, desc_data, info, root=0) + select case(trans_) + case('N') + sv%id%icntl(9) = 1 + case('T') + sv%id%icntl(9) = 2 + case default + call psb_errpush(psb_err_internal_error_,& + & name,a_err='Invalid TRANS in subsolve') + 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 - call zmumps(sv%id) - call psb_scatter(gx, ww, desc_data, info, root=0) - - if (info == psb_success_) then - call psb_geaxpby(alpha,ww,beta,y,desc_data,info) - end if + 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 zmumps(sv%id) + call psb_scatter(gx, ww, desc_data, info, root=0) - if (info /= psb_success_) then - call psb_errpush(psb_err_internal_error_,& - & name,a_err='Error in subsolve') - goto 9999 - endif + if (info == psb_success_) then + call psb_geaxpby(alpha,ww,beta,y,desc_data,info) + end if - if (nglob > size(work)) then - deallocate(ww) - endif + if (info /= psb_success_) then + call psb_errpush(psb_err_internal_error_,& + & name,a_err='Error in subsolve') + goto 9999 + endif - call psb_erractionrestore(err_act) - return + if (nglob > size(work)) then + deallocate(ww) + endif + + call psb_erractionrestore(err_act) + return 9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() return + end if + return #else - write(psb_err_unit,*) "MUMPS Not Configured, fix make.inc and recompile " + write(psb_err_unit,*) "MUMPS Not Configured, fix make.inc and recompile " #endif - end subroutine z_mumps_solver_apply +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 c895a549..f399576a 100644 --- a/mlprec/impl/solver/mld_z_mumps_solver_apply_vect.F90 +++ b/mlprec/impl/solver/mld_z_mumps_solver_apply_vect.F90 @@ -36,49 +36,54 @@ !!$ POSSIBILITY OF SUCH DAMAGE. !!$ !!$ +subroutine z_mumps_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& + & trans,work,info,init,initu) + use psb_base_mod + use mld_z_mumps_solver + implicit none + type(psb_desc_type), intent(in) :: desc_data + class(mld_z_mumps_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 + character, intent(in), optional :: init + type(psb_z_vect_type),intent(inout), optional :: initu - subroutine z_mumps_solver_apply_vect(alpha,sv,x,beta,y,desc_data,trans,work,info) - use psb_base_mod - use mld_z_mumps_solver - implicit none - type(psb_desc_type), intent(in) :: desc_data - class(mld_z_mumps_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_) :: err_act - character(len=20) :: name='z_mumps_solver_apply_vect' + integer(psb_ipk_) :: err_act + character(len=20) :: name='z_mumps_solver_apply_vect' #if defined(HAVE_MUMPS_) - call psb_erractionsave(err_act) + call psb_erractionsave(err_act) - info = psb_success_ + info = psb_success_ + ! + ! For non-iterative solvers, init and initu are ignored. + ! - call x%v%sync() - call y%v%sync() - call sv%apply(alpha,x%v%v,beta,y%v%v,desc_data,trans,work,info) - call y%v%set_host() - if (info /= 0) goto 9999 + call x%v%sync() + call y%v%sync() + call sv%apply(alpha,x%v%v,beta,y%v%v,desc_data,trans,work,info) + call y%v%set_host() + if (info /= 0) goto 9999 - call psb_erractionrestore(err_act) - return + call psb_erractionrestore(err_act) + return 9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if + call psb_erractionrestore(err_act) + if (err_act == psb_act_abort_) then + call psb_error() return + end if + return #else - write(psb_err_unit,*) "MUMPS Not Configured, fix make.inc and recompile " + write(psb_err_unit,*) "MUMPS Not Configured, fix make.inc and recompile " #endif - end subroutine z_mumps_solver_apply_vect +end subroutine z_mumps_solver_apply_vect diff --git a/mlprec/mld_base_prec_type.F90 b/mlprec/mld_base_prec_type.F90 index c469a473..5b990753 100644 --- a/mlprec/mld_base_prec_type.F90 +++ b/mlprec/mld_base_prec_type.F90 @@ -545,16 +545,17 @@ contains integer(psb_ipk_), intent(out) :: info info = psb_success_ - if (pm%ml_type>mld_no_ml_) then + if ((pm%ml_type>=mld_no_ml_).and.(pm%ml_type<=mld_max_ml_type_)) then write(iout,*) ' Multilevel type: ',& & ml_names(pm%ml_type) - write(iout,*) ' Smoother position: ',& - & smooth_pos_names(pm%smoother_pos) - if (pm%ml_type == mld_add_ml_) then + select case (pm%ml_type) + case (mld_add_ml_) write(iout,*) ' Number of smoother sweeps : ',& - & pm%sweeps - else + & pm%sweeps + case (mld_mult_ml_) + write(iout,*) ' Smoother position: ',& + & smooth_pos_names(pm%smoother_pos) select case (pm%smoother_pos) case (mld_pre_smooth_) write(iout,*) ' Number of smoother sweeps : ',& @@ -568,7 +569,13 @@ contains & ' post: ',& & pm%sweeps_post end select - end if + case (mld_vcycle_ml_, mld_wcycle_ml_, mld_kcycle_ml_, mld_kcyclesym_ml_) + write(iout,*) ' Number of smoother sweeps : pre: ',& + & pm%sweeps_pre ,& + & ' post: ',& + & pm%sweeps_post + end select + write(iout,*) ' Aggregation: ', & & aggr_names(pm%aggr_alg) write(iout,*) ' with initial ordering: ',& @@ -586,8 +593,11 @@ contains write(iout,*) ' Damping omega computation: unknown value in iprcparm!!' end if end if + else + write(iout,*) ' Multilevel type: Unkonwn value. Something is amis....',& + & pm%ml_type end if - + return end subroutine ml_parms_mldescr diff --git a/mlprec/mld_c_as_smoother.f90 b/mlprec/mld_c_as_smoother.f90 index 097ab16e..9c8bcf5a 100644 --- a/mlprec/mld_c_as_smoother.f90 +++ b/mlprec/mld_c_as_smoother.f90 @@ -97,7 +97,7 @@ module mld_c_as_smoother interface subroutine mld_c_as_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,& - & trans,sweeps,work,info) + & trans,sweeps,work,info,init,initu) import :: psb_cspmat_type, psb_c_vect_type, psb_c_base_vect_type, & & psb_spk_, mld_c_as_smoother_type, psb_long_int_k_, & & psb_desc_type, psb_ipk_ @@ -111,12 +111,14 @@ module mld_c_as_smoother integer(psb_ipk_), intent(in) :: sweeps complex(psb_spk_),target, intent(inout) :: work(:) integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: init + type(psb_c_vect_type),intent(inout), optional :: initu end subroutine mld_c_as_smoother_apply_vect end interface interface subroutine mld_c_as_smoother_apply(alpha,sm,x,beta,y,desc_data,& - & trans,sweeps,work,info) + & trans,sweeps,work,info,init,initu) import :: psb_cspmat_type, psb_c_vect_type, psb_c_base_vect_type, & & psb_spk_, mld_c_as_smoother_type, psb_long_int_k_,& & psb_desc_type, psb_ipk_ @@ -130,6 +132,8 @@ module mld_c_as_smoother integer(psb_ipk_), intent(in) :: sweeps complex(psb_spk_),target, intent(inout) :: work(:) integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: init + complex(psb_spk_),intent(inout), optional :: initu(:) end subroutine mld_c_as_smoother_apply end interface diff --git a/mlprec/mld_c_base_smoother_mod.f90 b/mlprec/mld_c_base_smoother_mod.f90 index 04d53611..8e3bfca2 100644 --- a/mlprec/mld_c_base_smoother_mod.f90 +++ b/mlprec/mld_c_base_smoother_mod.f90 @@ -125,7 +125,7 @@ module mld_c_base_smoother_mod interface subroutine mld_c_base_smoother_apply(alpha,sm,x,beta,y,desc_data,& - & trans,sweeps,work,info) + & trans,sweeps,work,info,init,initu) import :: psb_desc_type, psb_cspmat_type, psb_c_base_sparse_mat, & & psb_c_vect_type, psb_c_base_vect_type, psb_spk_, & & mld_c_base_smoother_type, psb_ipk_ @@ -138,12 +138,14 @@ module mld_c_base_smoother_mod integer(psb_ipk_), intent(in) :: sweeps complex(psb_spk_),target, intent(inout) :: work(:) integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: init + complex(psb_spk_),intent(inout), optional :: initu(:) end subroutine mld_c_base_smoother_apply end interface interface subroutine mld_c_base_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,& - & trans,sweeps,work,info) + & trans,sweeps,work,info,init,initu) import :: psb_desc_type, psb_cspmat_type, psb_c_base_sparse_mat, & & psb_c_vect_type, psb_c_base_vect_type, psb_spk_, & & mld_c_base_smoother_type, psb_ipk_ @@ -156,6 +158,8 @@ module mld_c_base_smoother_mod integer(psb_ipk_), intent(in) :: sweeps complex(psb_spk_),target, intent(inout) :: work(:) integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: init + type(psb_c_vect_type),intent(inout), optional :: initu end subroutine mld_c_base_smoother_apply_vect end interface diff --git a/mlprec/mld_c_base_solver_mod.f90 b/mlprec/mld_c_base_solver_mod.f90 index 653b1530..84743e6d 100644 --- a/mlprec/mld_c_base_solver_mod.f90 +++ b/mlprec/mld_c_base_solver_mod.f90 @@ -116,7 +116,8 @@ module mld_c_base_solver_mod interface - subroutine mld_c_base_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info) + subroutine mld_c_base_solver_apply(alpha,sv,x,beta,y,desc_data,& + & trans,work,info,init,initu) import :: psb_desc_type, psb_cspmat_type, psb_c_base_sparse_mat, & & psb_c_vect_type, psb_c_base_vect_type, psb_spk_, & & mld_c_base_solver_type, psb_ipk_ @@ -129,12 +130,15 @@ module mld_c_base_solver_mod character(len=1),intent(in) :: trans complex(psb_spk_),target, intent(inout) :: work(:) integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: init + complex(psb_spk_),intent(inout), optional :: initu(:) end subroutine mld_c_base_solver_apply end interface interface - subroutine mld_c_base_solver_apply_vect(alpha,sv,x,beta,y,desc_data,trans,work,info) + subroutine mld_c_base_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& + & trans,work,info,init,initu) import :: psb_desc_type, psb_cspmat_type, psb_c_base_sparse_mat, & & psb_c_vect_type, psb_c_base_vect_type, psb_spk_, & & mld_c_base_solver_type, psb_ipk_ @@ -147,6 +151,8 @@ module mld_c_base_solver_mod character(len=1),intent(in) :: trans complex(psb_spk_),target, intent(inout) :: work(:) integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: init + type(psb_c_vect_type),intent(inout), optional :: initu end subroutine mld_c_base_solver_apply_vect end interface diff --git a/mlprec/mld_c_diag_solver.f90 b/mlprec/mld_c_diag_solver.f90 index d50567b5..67b2ab54 100644 --- a/mlprec/mld_c_diag_solver.f90 +++ b/mlprec/mld_c_diag_solver.f90 @@ -71,7 +71,7 @@ module mld_c_diag_solver interface subroutine mld_c_diag_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& - & trans,work,info) + & trans,work,info,init,initu) import :: psb_desc_type, psb_cspmat_type, psb_c_base_sparse_mat, & & psb_c_vect_type, psb_c_base_vect_type, psb_spk_, & & mld_c_diag_solver_type, psb_ipk_ @@ -83,11 +83,14 @@ module mld_c_diag_solver character(len=1),intent(in) :: trans complex(psb_spk_),target, intent(inout) :: work(:) integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: init + type(psb_c_vect_type),intent(inout), optional :: initu end subroutine mld_c_diag_solver_apply_vect end interface interface - subroutine mld_c_diag_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info) + subroutine mld_c_diag_solver_apply(alpha,sv,x,beta,y,desc_data,& + & trans,work,info,init,initu) import :: psb_desc_type, psb_cspmat_type, psb_c_base_sparse_mat, & & psb_c_vect_type, psb_c_base_vect_type, psb_spk_, & & mld_c_diag_solver_type, psb_ipk_ @@ -99,6 +102,8 @@ module mld_c_diag_solver character(len=1),intent(in) :: trans complex(psb_spk_),target, intent(inout) :: work(:) integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: init + complex(psb_spk_),intent(inout), optional :: initu(:) end subroutine mld_c_diag_solver_apply end interface diff --git a/mlprec/mld_c_gs_solver.f90 b/mlprec/mld_c_gs_solver.f90 index 19881bb4..bbd8a5d3 100644 --- a/mlprec/mld_c_gs_solver.f90 +++ b/mlprec/mld_c_gs_solver.f90 @@ -96,7 +96,8 @@ module mld_c_gs_solver interface - subroutine mld_c_gs_solver_apply_vect(alpha,sv,x,beta,y,desc_data,trans,work,info) + subroutine mld_c_gs_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& + & trans,work,info,init,initu) import :: psb_desc_type, mld_c_gs_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 @@ -108,8 +109,11 @@ module mld_c_gs_solver character(len=1),intent(in) :: trans complex(psb_spk_),target, intent(inout) :: work(:) integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: init + type(psb_c_vect_type),intent(inout), optional :: initu 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) + subroutine mld_c_bwgs_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& + & trans,work,info,init,initu) 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 @@ -121,11 +125,13 @@ module mld_c_gs_solver character(len=1),intent(in) :: trans complex(psb_spk_),target, intent(inout) :: work(:) integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: init + type(psb_c_vect_type),intent(inout), optional :: initu end subroutine mld_c_bwgs_solver_apply_vect end interface interface - subroutine mld_c_gs_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info) + subroutine mld_c_gs_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info,init,initu) import :: psb_desc_type, mld_c_gs_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 @@ -137,8 +143,11 @@ module mld_c_gs_solver character(len=1),intent(in) :: trans complex(psb_spk_),target, intent(inout) :: work(:) integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: init + complex(psb_spk_),intent(inout), optional :: initu(:) end subroutine mld_c_gs_solver_apply - subroutine mld_c_bwgs_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info) + subroutine mld_c_bwgs_solver_apply(alpha,sv,x,beta,y,desc_data,& + & trans,work,info,init,initu) 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 @@ -150,6 +159,8 @@ module mld_c_gs_solver character(len=1),intent(in) :: trans complex(psb_spk_),target, intent(inout) :: work(:) integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: init + complex(psb_spk_),intent(inout), optional :: initu(:) end subroutine mld_c_bwgs_solver_apply end interface diff --git a/mlprec/mld_c_id_solver.f90 b/mlprec/mld_c_id_solver.f90 index 67d6ba4c..ef675ea3 100644 --- a/mlprec/mld_c_id_solver.f90 +++ b/mlprec/mld_c_id_solver.f90 @@ -64,7 +64,8 @@ module mld_c_id_solver & c_id_solver_descr interface - subroutine mld_c_id_solver_apply_vect(alpha,sv,x,beta,y,desc_data,trans,work,info) + subroutine mld_c_id_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& + & trans,work,info,init,initu) import :: psb_desc_type, psb_cspmat_type, psb_c_base_sparse_mat, & & psb_c_vect_type, psb_c_base_vect_type, psb_spk_, & & mld_c_id_solver_type, psb_ipk_ @@ -76,11 +77,14 @@ module mld_c_id_solver character(len=1),intent(in) :: trans complex(psb_spk_),target, intent(inout) :: work(:) integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: init + type(psb_c_vect_type),intent(inout), optional :: initu end subroutine mld_c_id_solver_apply_vect end interface interface - subroutine mld_c_id_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info) + subroutine mld_c_id_solver_apply(alpha,sv,x,beta,y,desc_data,& + & trans,work,info,init,initu) import :: psb_desc_type, psb_cspmat_type, psb_c_base_sparse_mat, & & psb_c_vect_type, psb_c_base_vect_type, psb_spk_, & & mld_c_id_solver_type, psb_ipk_ @@ -92,6 +96,8 @@ module mld_c_id_solver character(len=1),intent(in) :: trans complex(psb_spk_),target, intent(inout) :: work(:) integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: init + complex(psb_spk_),intent(inout), optional :: initu(:) end subroutine mld_c_id_solver_apply end interface diff --git a/mlprec/mld_c_ilu_solver.f90 b/mlprec/mld_c_ilu_solver.f90 index 949f28c5..c2392851 100644 --- a/mlprec/mld_c_ilu_solver.f90 +++ b/mlprec/mld_c_ilu_solver.f90 @@ -88,7 +88,8 @@ module mld_c_ilu_solver interface - subroutine mld_c_ilu_solver_apply_vect(alpha,sv,x,beta,y,desc_data,trans,work,info) + subroutine mld_c_ilu_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& + & trans,work,info,init,initu) import :: psb_desc_type, mld_c_ilu_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 @@ -100,11 +101,14 @@ module mld_c_ilu_solver character(len=1),intent(in) :: trans complex(psb_spk_),target, intent(inout) :: work(:) integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: init + type(psb_c_vect_type),intent(inout), optional :: initu end subroutine mld_c_ilu_solver_apply_vect end interface interface - subroutine mld_c_ilu_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info) + subroutine mld_c_ilu_solver_apply(alpha,sv,x,beta,y,desc_data,& + & trans,work,info,init,initu) import :: psb_desc_type, mld_c_ilu_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 @@ -116,6 +120,8 @@ module mld_c_ilu_solver character(len=1),intent(in) :: trans complex(psb_spk_),target, intent(inout) :: work(:) integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: init + complex(psb_spk_),intent(inout), optional :: initu(:) end subroutine mld_c_ilu_solver_apply end interface diff --git a/mlprec/mld_c_jac_smoother.f90 b/mlprec/mld_c_jac_smoother.f90 index ef252ffa..cdd9aa60 100644 --- a/mlprec/mld_c_jac_smoother.f90 +++ b/mlprec/mld_c_jac_smoother.f90 @@ -74,7 +74,7 @@ module mld_c_jac_smoother interface subroutine mld_c_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& - & sweeps,work,info) + & sweeps,work,info,init,initu) import :: psb_desc_type, mld_c_jac_smoother_type, psb_c_vect_type, psb_spk_, & & psb_cspmat_type, psb_c_base_sparse_mat, psb_c_base_vect_type,& & psb_ipk_ @@ -88,12 +88,14 @@ module mld_c_jac_smoother integer(psb_ipk_), intent(in) :: sweeps complex(psb_spk_),target, intent(inout) :: work(:) integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: init + type(psb_c_vect_type),intent(inout), optional :: initu end subroutine mld_c_jac_smoother_apply_vect end interface interface subroutine mld_c_jac_smoother_apply(alpha,sm,x,beta,y,desc_data,trans,& - & sweeps,work,info) + & sweeps,work,info,init,initu) import :: psb_desc_type, mld_c_jac_smoother_type, psb_c_vect_type, psb_spk_, & & psb_cspmat_type, psb_c_base_sparse_mat, psb_c_base_vect_type, & & psb_ipk_ @@ -106,6 +108,8 @@ module mld_c_jac_smoother integer(psb_ipk_), intent(in) :: sweeps complex(psb_spk_),target, intent(inout) :: work(:) integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: init + complex(psb_spk_),intent(inout), optional :: initu(:) end subroutine mld_c_jac_smoother_apply end interface diff --git a/mlprec/mld_c_mumps_solver.F90 b/mlprec/mld_c_mumps_solver.F90 index e53c88f3..17e2749a 100644 --- a/mlprec/mld_c_mumps_solver.F90 +++ b/mlprec/mld_c_mumps_solver.F90 @@ -93,7 +93,8 @@ module mld_c_mumps_solver #endif interface - subroutine c_mumps_solver_apply_vect(alpha,sv,x,beta,y,desc_data,trans,work,info) + subroutine c_mumps_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& + & trans,work,info,init,initu) import :: psb_desc_type, mld_c_mumps_solver_type, psb_c_vect_type, psb_dpk_, psb_spk_, & & psb_cspmat_type, psb_c_base_sparse_mat, psb_c_base_vect_type, psb_ipk_ implicit none @@ -105,14 +106,13 @@ module mld_c_mumps_solver character(len=1),intent(in) :: trans complex(psb_spk_),target, intent(inout) :: work(:) integer, intent(out) :: info - - integer(psb_ipk_) :: err_act - character(len=20) :: name='c_mumps_solver_apply_vect' + character, intent(in), optional :: init + type(psb_c_vect_type),intent(inout), optional :: initu end subroutine c_mumps_solver_apply_vect end interface interface - subroutine c_mumps_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info) + subroutine c_mumps_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info,init,initu) import :: psb_desc_type, mld_c_mumps_solver_type, psb_c_vect_type, psb_dpk_, psb_spk_, & & psb_cspmat_type, psb_c_base_sparse_mat, psb_c_base_vect_type, psb_ipk_ implicit none @@ -124,13 +124,8 @@ module mld_c_mumps_solver 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, nglob - complex(psb_spk_), pointer :: ww(:) - complex(psb_spk_), allocatable, target :: gx(:) - integer(psb_ipk_) :: ictxt,np,me,i, err_act - character :: trans_ - character(len=20) :: name='c_mumps_solver_apply' + character, intent(in), optional :: init + complex(psb_spk_),intent(inout), optional :: initu(:) end subroutine c_mumps_solver_apply end interface diff --git a/mlprec/mld_c_slu_solver.F90 b/mlprec/mld_c_slu_solver.F90 index ca3d9986..bbe10364 100644 --- a/mlprec/mld_c_slu_solver.F90 +++ b/mlprec/mld_c_slu_solver.F90 @@ -116,7 +116,8 @@ module mld_c_slu_solver contains - subroutine c_slu_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info) + subroutine c_slu_solver_apply(alpha,sv,x,beta,y,desc_data,& + & trans,work,info,init,initu) use psb_base_mod implicit none type(psb_desc_type), intent(in) :: desc_data @@ -127,6 +128,8 @@ contains character(len=1),intent(in) :: trans complex(psb_spk_),target, intent(inout) :: work(:) integer, intent(out) :: info + character, intent(in), optional :: init + complex(psb_spk_),intent(inout), optional :: initu(:) integer :: n_row,n_col complex(psb_spk_), pointer :: ww(:) @@ -146,6 +149,9 @@ contains call psb_errpush(psb_err_iarg_invalid_i_,name) goto 9999 end select + ! + ! For non-iterative solvers, init and initu are ignored. + ! n_row = desc_data%get_local_rows() n_col = desc_data%get_local_cols() @@ -198,7 +204,8 @@ contains end subroutine c_slu_solver_apply - subroutine c_slu_solver_apply_vect(alpha,sv,x,beta,y,desc_data,trans,work,info) + subroutine c_slu_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& + & trans,work,info,init,initu) use psb_base_mod implicit none type(psb_desc_type), intent(in) :: desc_data @@ -209,6 +216,8 @@ contains character(len=1),intent(in) :: trans complex(psb_spk_),target, intent(inout) :: work(:) integer, intent(out) :: info + character, intent(in), optional :: init + type(psb_c_vect_type),intent(inout), optional :: initu integer :: err_act character(len=20) :: name='c_slu_solver_apply_vect' @@ -216,6 +225,9 @@ contains call psb_erractionsave(err_act) info = psb_success_ + ! + ! For non-iterative solvers, init and initu are ignored. + ! call x%v%sync() call y%v%sync() diff --git a/mlprec/mld_c_sludist_solver.F90 b/mlprec/mld_c_sludist_solver.F90 index b4652ce3..d4941020 100644 --- a/mlprec/mld_c_sludist_solver.F90 +++ b/mlprec/mld_c_sludist_solver.F90 @@ -113,7 +113,8 @@ module mld_c_sludist_solver contains - subroutine c_sludist_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info) + subroutine c_sludist_solver_apply(alpha,sv,x,beta,y,desc_data,& + & trans,work,info,init,initu) use psb_base_mod implicit none type(psb_desc_type), intent(in) :: desc_data @@ -124,6 +125,8 @@ contains character(len=1),intent(in) :: trans complex(psb_spk_),target, intent(inout) :: work(:) integer, intent(out) :: info + character, intent(in), optional :: init + complex(psb_spk_),intent(inout), optional :: initu(:) integer :: n_row,n_col complex(psb_spk_), pointer :: ww(:) @@ -143,6 +146,10 @@ contains call psb_errpush(psb_err_iarg_invalid_i_,name) goto 9999 end select + ! + ! For non-iterative solvers, init and initu are ignored. + ! + n_row = desc_data%get_local_rows() n_col = desc_data%get_local_cols() @@ -197,7 +204,8 @@ contains end subroutine c_sludist_solver_apply - subroutine c_sludist_solver_apply_vect(alpha,sv,x,beta,y,desc_data,trans,work,info) + subroutine c_sludist_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& + & trans,work,info,init,initu) use psb_base_mod implicit none type(psb_desc_type), intent(in) :: desc_data @@ -208,6 +216,8 @@ contains character(len=1),intent(in) :: trans complex(psb_spk_),target, intent(inout) :: work(:) integer, intent(out) :: info + character, intent(in), optional :: init + type(psb_c_vect_type),intent(inout), optional :: initu integer :: err_act character(len=20) :: name='c_sludist_solver_apply_vect' @@ -215,6 +225,10 @@ contains call psb_erractionsave(err_act) info = psb_success_ + ! + ! For non-iterative solvers, init and initu are ignored. + ! + call x%v%sync() call y%v%sync() diff --git a/mlprec/mld_c_umf_solver.F90 b/mlprec/mld_c_umf_solver.F90 index 1a84c8c2..67d6e0a1 100644 --- a/mlprec/mld_c_umf_solver.F90 +++ b/mlprec/mld_c_umf_solver.F90 @@ -116,7 +116,8 @@ module mld_c_umf_solver contains - subroutine c_umf_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info) + subroutine c_umf_solver_apply(alpha,sv,x,beta,y,desc_data,& + & trans,work,info,init,initu) use psb_base_mod implicit none type(psb_desc_type), intent(in) :: desc_data @@ -127,6 +128,8 @@ contains character(len=1),intent(in) :: trans complex(psb_spk_),target, intent(inout) :: work(:) integer, intent(out) :: info + character, intent(in), optional :: init + complex(psb_spk_),intent(inout), optional :: initu(:) integer :: n_row,n_col complex(psb_spk_), pointer :: ww(:) @@ -146,6 +149,9 @@ contains call psb_errpush(psb_err_iarg_invalid_i_,name) goto 9999 end select + ! + ! For non-iterative solvers, init and initu are ignored. + ! n_row = desc_data%get_local_rows() n_col = desc_data%get_local_cols() @@ -202,7 +208,8 @@ contains end subroutine c_umf_solver_apply - subroutine c_umf_solver_apply_vect(alpha,sv,x,beta,y,desc_data,trans,work,info) + subroutine c_umf_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& + & trans,work,info,init,initu) use psb_base_mod implicit none type(psb_desc_type), intent(in) :: desc_data @@ -213,6 +220,8 @@ contains character(len=1),intent(in) :: trans complex(psb_spk_),target, intent(inout) :: work(:) integer, intent(out) :: info + character, intent(in), optional :: init + type(psb_c_vect_type),intent(inout), optional :: initu integer :: err_act character(len=20) :: name='c_umf_solver_apply_vect' @@ -220,6 +229,9 @@ contains call psb_erractionsave(err_act) info = psb_success_ + ! + ! For non-iterative solvers, init and initu are ignored. + ! call x%v%sync() call y%v%sync() diff --git a/mlprec/mld_d_as_smoother.f90 b/mlprec/mld_d_as_smoother.f90 index b1dd4ae2..f67d3576 100644 --- a/mlprec/mld_d_as_smoother.f90 +++ b/mlprec/mld_d_as_smoother.f90 @@ -97,7 +97,7 @@ module mld_d_as_smoother interface subroutine mld_d_as_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,& - & trans,sweeps,work,info) + & trans,sweeps,work,info,init,initu) import :: psb_dspmat_type, psb_d_vect_type, psb_d_base_vect_type, & & psb_dpk_, mld_d_as_smoother_type, psb_long_int_k_, & & psb_desc_type, psb_ipk_ @@ -111,12 +111,14 @@ module mld_d_as_smoother integer(psb_ipk_), intent(in) :: sweeps real(psb_dpk_),target, intent(inout) :: work(:) integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: init + type(psb_d_vect_type),intent(inout), optional :: initu end subroutine mld_d_as_smoother_apply_vect end interface interface subroutine mld_d_as_smoother_apply(alpha,sm,x,beta,y,desc_data,& - & trans,sweeps,work,info) + & trans,sweeps,work,info,init,initu) import :: psb_dspmat_type, psb_d_vect_type, psb_d_base_vect_type, & & psb_dpk_, mld_d_as_smoother_type, psb_long_int_k_,& & psb_desc_type, psb_ipk_ @@ -130,6 +132,8 @@ module mld_d_as_smoother integer(psb_ipk_), intent(in) :: sweeps real(psb_dpk_),target, intent(inout) :: work(:) integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: init + real(psb_dpk_),intent(inout), optional :: initu(:) end subroutine mld_d_as_smoother_apply end interface diff --git a/mlprec/mld_d_base_smoother_mod.f90 b/mlprec/mld_d_base_smoother_mod.f90 index 089be003..d5cf0bda 100644 --- a/mlprec/mld_d_base_smoother_mod.f90 +++ b/mlprec/mld_d_base_smoother_mod.f90 @@ -125,7 +125,7 @@ module mld_d_base_smoother_mod interface subroutine mld_d_base_smoother_apply(alpha,sm,x,beta,y,desc_data,& - & trans,sweeps,work,info) + & trans,sweeps,work,info,init,initu) import :: psb_desc_type, psb_dspmat_type, psb_d_base_sparse_mat, & & psb_d_vect_type, psb_d_base_vect_type, psb_dpk_, & & mld_d_base_smoother_type, psb_ipk_ @@ -138,12 +138,14 @@ module mld_d_base_smoother_mod integer(psb_ipk_), intent(in) :: sweeps real(psb_dpk_),target, intent(inout) :: work(:) integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: init + real(psb_dpk_),intent(inout), optional :: initu(:) end subroutine mld_d_base_smoother_apply end interface interface subroutine mld_d_base_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,& - & trans,sweeps,work,info) + & trans,sweeps,work,info,init,initu) import :: psb_desc_type, psb_dspmat_type, psb_d_base_sparse_mat, & & psb_d_vect_type, psb_d_base_vect_type, psb_dpk_, & & mld_d_base_smoother_type, psb_ipk_ @@ -156,6 +158,8 @@ module mld_d_base_smoother_mod integer(psb_ipk_), intent(in) :: sweeps real(psb_dpk_),target, intent(inout) :: work(:) integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: init + type(psb_d_vect_type),intent(inout), optional :: initu end subroutine mld_d_base_smoother_apply_vect end interface diff --git a/mlprec/mld_d_base_solver_mod.f90 b/mlprec/mld_d_base_solver_mod.f90 index 89f6cd3c..2264b2ba 100644 --- a/mlprec/mld_d_base_solver_mod.f90 +++ b/mlprec/mld_d_base_solver_mod.f90 @@ -116,7 +116,8 @@ module mld_d_base_solver_mod interface - subroutine mld_d_base_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info) + subroutine mld_d_base_solver_apply(alpha,sv,x,beta,y,desc_data,& + & trans,work,info,init,initu) import :: psb_desc_type, psb_dspmat_type, psb_d_base_sparse_mat, & & psb_d_vect_type, psb_d_base_vect_type, psb_dpk_, & & mld_d_base_solver_type, psb_ipk_ @@ -129,12 +130,15 @@ module mld_d_base_solver_mod character(len=1),intent(in) :: trans real(psb_dpk_),target, intent(inout) :: work(:) integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: init + real(psb_dpk_),intent(inout), optional :: initu(:) end subroutine mld_d_base_solver_apply end interface interface - subroutine mld_d_base_solver_apply_vect(alpha,sv,x,beta,y,desc_data,trans,work,info) + subroutine mld_d_base_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& + & trans,work,info,init,initu) import :: psb_desc_type, psb_dspmat_type, psb_d_base_sparse_mat, & & psb_d_vect_type, psb_d_base_vect_type, psb_dpk_, & & mld_d_base_solver_type, psb_ipk_ @@ -147,6 +151,8 @@ module mld_d_base_solver_mod character(len=1),intent(in) :: trans real(psb_dpk_),target, intent(inout) :: work(:) integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: init + type(psb_d_vect_type),intent(inout), optional :: initu end subroutine mld_d_base_solver_apply_vect end interface diff --git a/mlprec/mld_d_diag_solver.f90 b/mlprec/mld_d_diag_solver.f90 index 93179fd0..9c3e4525 100644 --- a/mlprec/mld_d_diag_solver.f90 +++ b/mlprec/mld_d_diag_solver.f90 @@ -71,7 +71,7 @@ module mld_d_diag_solver interface subroutine mld_d_diag_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& - & trans,work,info) + & trans,work,info,init,initu) import :: psb_desc_type, psb_dspmat_type, psb_d_base_sparse_mat, & & psb_d_vect_type, psb_d_base_vect_type, psb_dpk_, & & mld_d_diag_solver_type, psb_ipk_ @@ -83,11 +83,14 @@ module mld_d_diag_solver character(len=1),intent(in) :: trans real(psb_dpk_),target, intent(inout) :: work(:) integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: init + type(psb_d_vect_type),intent(inout), optional :: initu end subroutine mld_d_diag_solver_apply_vect end interface interface - subroutine mld_d_diag_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info) + subroutine mld_d_diag_solver_apply(alpha,sv,x,beta,y,desc_data,& + & trans,work,info,init,initu) import :: psb_desc_type, psb_dspmat_type, psb_d_base_sparse_mat, & & psb_d_vect_type, psb_d_base_vect_type, psb_dpk_, & & mld_d_diag_solver_type, psb_ipk_ @@ -99,6 +102,8 @@ module mld_d_diag_solver character(len=1),intent(in) :: trans real(psb_dpk_),target, intent(inout) :: work(:) integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: init + real(psb_dpk_),intent(inout), optional :: initu(:) end subroutine mld_d_diag_solver_apply end interface diff --git a/mlprec/mld_d_gs_solver.f90 b/mlprec/mld_d_gs_solver.f90 index 72f22638..c8b2f8a0 100644 --- a/mlprec/mld_d_gs_solver.f90 +++ b/mlprec/mld_d_gs_solver.f90 @@ -96,7 +96,8 @@ module mld_d_gs_solver interface - subroutine mld_d_gs_solver_apply_vect(alpha,sv,x,beta,y,desc_data,trans,work,info) + subroutine mld_d_gs_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& + & trans,work,info,init,initu) import :: psb_desc_type, mld_d_gs_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 @@ -108,8 +109,11 @@ module mld_d_gs_solver character(len=1),intent(in) :: trans real(psb_dpk_),target, intent(inout) :: work(:) integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: init + type(psb_d_vect_type),intent(inout), optional :: initu 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) + subroutine mld_d_bwgs_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& + & trans,work,info,init,initu) 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 @@ -121,11 +125,13 @@ module mld_d_gs_solver character(len=1),intent(in) :: trans real(psb_dpk_),target, intent(inout) :: work(:) integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: init + type(psb_d_vect_type),intent(inout), optional :: initu end subroutine mld_d_bwgs_solver_apply_vect end interface interface - subroutine mld_d_gs_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info) + subroutine mld_d_gs_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info,init,initu) import :: psb_desc_type, mld_d_gs_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 @@ -137,8 +143,11 @@ module mld_d_gs_solver character(len=1),intent(in) :: trans real(psb_dpk_),target, intent(inout) :: work(:) integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: init + real(psb_dpk_),intent(inout), optional :: initu(:) end subroutine mld_d_gs_solver_apply - subroutine mld_d_bwgs_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info) + subroutine mld_d_bwgs_solver_apply(alpha,sv,x,beta,y,desc_data,& + & trans,work,info,init,initu) 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 @@ -150,6 +159,8 @@ module mld_d_gs_solver character(len=1),intent(in) :: trans real(psb_dpk_),target, intent(inout) :: work(:) integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: init + real(psb_dpk_),intent(inout), optional :: initu(:) end subroutine mld_d_bwgs_solver_apply end interface diff --git a/mlprec/mld_d_id_solver.f90 b/mlprec/mld_d_id_solver.f90 index 91ccc5ae..55a22365 100644 --- a/mlprec/mld_d_id_solver.f90 +++ b/mlprec/mld_d_id_solver.f90 @@ -64,7 +64,8 @@ module mld_d_id_solver & d_id_solver_descr interface - subroutine mld_d_id_solver_apply_vect(alpha,sv,x,beta,y,desc_data,trans,work,info) + subroutine mld_d_id_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& + & trans,work,info,init,initu) import :: psb_desc_type, psb_dspmat_type, psb_d_base_sparse_mat, & & psb_d_vect_type, psb_d_base_vect_type, psb_dpk_, & & mld_d_id_solver_type, psb_ipk_ @@ -76,11 +77,14 @@ module mld_d_id_solver character(len=1),intent(in) :: trans real(psb_dpk_),target, intent(inout) :: work(:) integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: init + type(psb_d_vect_type),intent(inout), optional :: initu end subroutine mld_d_id_solver_apply_vect end interface interface - subroutine mld_d_id_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info) + subroutine mld_d_id_solver_apply(alpha,sv,x,beta,y,desc_data,& + & trans,work,info,init,initu) import :: psb_desc_type, psb_dspmat_type, psb_d_base_sparse_mat, & & psb_d_vect_type, psb_d_base_vect_type, psb_dpk_, & & mld_d_id_solver_type, psb_ipk_ @@ -92,6 +96,8 @@ module mld_d_id_solver character(len=1),intent(in) :: trans real(psb_dpk_),target, intent(inout) :: work(:) integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: init + real(psb_dpk_),intent(inout), optional :: initu(:) end subroutine mld_d_id_solver_apply end interface diff --git a/mlprec/mld_d_ilu_solver.f90 b/mlprec/mld_d_ilu_solver.f90 index 0abfc744..83288d24 100644 --- a/mlprec/mld_d_ilu_solver.f90 +++ b/mlprec/mld_d_ilu_solver.f90 @@ -88,7 +88,8 @@ module mld_d_ilu_solver interface - subroutine mld_d_ilu_solver_apply_vect(alpha,sv,x,beta,y,desc_data,trans,work,info) + subroutine mld_d_ilu_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& + & trans,work,info,init,initu) import :: psb_desc_type, mld_d_ilu_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 @@ -100,11 +101,14 @@ module mld_d_ilu_solver character(len=1),intent(in) :: trans real(psb_dpk_),target, intent(inout) :: work(:) integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: init + type(psb_d_vect_type),intent(inout), optional :: initu end subroutine mld_d_ilu_solver_apply_vect end interface interface - subroutine mld_d_ilu_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info) + subroutine mld_d_ilu_solver_apply(alpha,sv,x,beta,y,desc_data,& + & trans,work,info,init,initu) import :: psb_desc_type, mld_d_ilu_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 @@ -116,6 +120,8 @@ module mld_d_ilu_solver character(len=1),intent(in) :: trans real(psb_dpk_),target, intent(inout) :: work(:) integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: init + real(psb_dpk_),intent(inout), optional :: initu(:) end subroutine mld_d_ilu_solver_apply end interface diff --git a/mlprec/mld_d_jac_smoother.f90 b/mlprec/mld_d_jac_smoother.f90 index ea4a3d1b..2f7cf54d 100644 --- a/mlprec/mld_d_jac_smoother.f90 +++ b/mlprec/mld_d_jac_smoother.f90 @@ -74,7 +74,7 @@ module mld_d_jac_smoother interface subroutine mld_d_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& - & sweeps,work,info) + & sweeps,work,info,init,initu) import :: psb_desc_type, mld_d_jac_smoother_type, psb_d_vect_type, psb_dpk_, & & psb_dspmat_type, psb_d_base_sparse_mat, psb_d_base_vect_type,& & psb_ipk_ @@ -88,12 +88,14 @@ module mld_d_jac_smoother integer(psb_ipk_), intent(in) :: sweeps real(psb_dpk_),target, intent(inout) :: work(:) integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: init + type(psb_d_vect_type),intent(inout), optional :: initu end subroutine mld_d_jac_smoother_apply_vect end interface interface subroutine mld_d_jac_smoother_apply(alpha,sm,x,beta,y,desc_data,trans,& - & sweeps,work,info) + & sweeps,work,info,init,initu) import :: psb_desc_type, mld_d_jac_smoother_type, psb_d_vect_type, psb_dpk_, & & psb_dspmat_type, psb_d_base_sparse_mat, psb_d_base_vect_type, & & psb_ipk_ @@ -106,6 +108,8 @@ module mld_d_jac_smoother integer(psb_ipk_), intent(in) :: sweeps real(psb_dpk_),target, intent(inout) :: work(:) integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: init + real(psb_dpk_),intent(inout), optional :: initu(:) end subroutine mld_d_jac_smoother_apply end interface diff --git a/mlprec/mld_d_mumps_solver.F90 b/mlprec/mld_d_mumps_solver.F90 index dabe0c07..79c3bd8b 100644 --- a/mlprec/mld_d_mumps_solver.F90 +++ b/mlprec/mld_d_mumps_solver.F90 @@ -93,7 +93,8 @@ module mld_d_mumps_solver #endif interface - subroutine d_mumps_solver_apply_vect(alpha,sv,x,beta,y,desc_data,trans,work,info) + subroutine d_mumps_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& + & trans,work,info,init,initu) import :: psb_desc_type, mld_d_mumps_solver_type, psb_d_vect_type, psb_dpk_, psb_spk_, & & psb_dspmat_type, psb_d_base_sparse_mat, psb_d_base_vect_type, psb_ipk_ implicit none @@ -105,14 +106,13 @@ module mld_d_mumps_solver character(len=1),intent(in) :: trans real(psb_dpk_),target, intent(inout) :: work(:) integer, intent(out) :: info - - integer(psb_ipk_) :: err_act - character(len=20) :: name='d_mumps_solver_apply_vect' + character, intent(in), optional :: init + type(psb_d_vect_type),intent(inout), optional :: initu end subroutine d_mumps_solver_apply_vect end interface interface - subroutine d_mumps_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info) + subroutine d_mumps_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info,init,initu) import :: psb_desc_type, mld_d_mumps_solver_type, psb_d_vect_type, psb_dpk_, psb_spk_, & & psb_dspmat_type, psb_d_base_sparse_mat, psb_d_base_vect_type, psb_ipk_ implicit none @@ -124,13 +124,8 @@ module mld_d_mumps_solver 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, nglob - real(psb_dpk_), pointer :: ww(:) - real(psb_dpk_), allocatable, target :: gx(:) - integer(psb_ipk_) :: ictxt,np,me,i, err_act - character :: trans_ - character(len=20) :: name='d_mumps_solver_apply' + character, intent(in), optional :: init + real(psb_dpk_),intent(inout), optional :: initu(:) end subroutine d_mumps_solver_apply end interface diff --git a/mlprec/mld_d_slu_solver.F90 b/mlprec/mld_d_slu_solver.F90 index 7c0020ad..90449763 100644 --- a/mlprec/mld_d_slu_solver.F90 +++ b/mlprec/mld_d_slu_solver.F90 @@ -116,7 +116,8 @@ module mld_d_slu_solver contains - subroutine d_slu_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info) + subroutine d_slu_solver_apply(alpha,sv,x,beta,y,desc_data,& + & trans,work,info,init,initu) use psb_base_mod implicit none type(psb_desc_type), intent(in) :: desc_data @@ -127,6 +128,8 @@ contains character(len=1),intent(in) :: trans real(psb_dpk_),target, intent(inout) :: work(:) integer, intent(out) :: info + character, intent(in), optional :: init + real(psb_dpk_),intent(inout), optional :: initu(:) integer :: n_row,n_col real(psb_dpk_), pointer :: ww(:) @@ -146,6 +149,9 @@ contains call psb_errpush(psb_err_iarg_invalid_i_,name) goto 9999 end select + ! + ! For non-iterative solvers, init and initu are ignored. + ! n_row = desc_data%get_local_rows() n_col = desc_data%get_local_cols() @@ -198,7 +204,8 @@ contains end subroutine d_slu_solver_apply - subroutine d_slu_solver_apply_vect(alpha,sv,x,beta,y,desc_data,trans,work,info) + subroutine d_slu_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& + & trans,work,info,init,initu) use psb_base_mod implicit none type(psb_desc_type), intent(in) :: desc_data @@ -209,6 +216,8 @@ contains character(len=1),intent(in) :: trans real(psb_dpk_),target, intent(inout) :: work(:) integer, intent(out) :: info + character, intent(in), optional :: init + type(psb_d_vect_type),intent(inout), optional :: initu integer :: err_act character(len=20) :: name='d_slu_solver_apply_vect' @@ -216,6 +225,9 @@ contains call psb_erractionsave(err_act) info = psb_success_ + ! + ! For non-iterative solvers, init and initu are ignored. + ! call x%v%sync() call y%v%sync() diff --git a/mlprec/mld_d_sludist_solver.F90 b/mlprec/mld_d_sludist_solver.F90 index af4b952f..70785f3e 100644 --- a/mlprec/mld_d_sludist_solver.F90 +++ b/mlprec/mld_d_sludist_solver.F90 @@ -113,7 +113,8 @@ module mld_d_sludist_solver contains - subroutine d_sludist_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info) + subroutine d_sludist_solver_apply(alpha,sv,x,beta,y,desc_data,& + & trans,work,info,init,initu) use psb_base_mod implicit none type(psb_desc_type), intent(in) :: desc_data @@ -124,6 +125,8 @@ contains character(len=1),intent(in) :: trans real(psb_dpk_),target, intent(inout) :: work(:) integer, intent(out) :: info + character, intent(in), optional :: init + real(psb_dpk_),intent(inout), optional :: initu(:) integer :: n_row,n_col real(psb_dpk_), pointer :: ww(:) @@ -143,6 +146,10 @@ contains call psb_errpush(psb_err_iarg_invalid_i_,name) goto 9999 end select + ! + ! For non-iterative solvers, init and initu are ignored. + ! + n_row = desc_data%get_local_rows() n_col = desc_data%get_local_cols() @@ -197,7 +204,8 @@ contains end subroutine d_sludist_solver_apply - subroutine d_sludist_solver_apply_vect(alpha,sv,x,beta,y,desc_data,trans,work,info) + subroutine d_sludist_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& + & trans,work,info,init,initu) use psb_base_mod implicit none type(psb_desc_type), intent(in) :: desc_data @@ -208,6 +216,8 @@ contains character(len=1),intent(in) :: trans real(psb_dpk_),target, intent(inout) :: work(:) integer, intent(out) :: info + character, intent(in), optional :: init + type(psb_d_vect_type),intent(inout), optional :: initu integer :: err_act character(len=20) :: name='d_sludist_solver_apply_vect' @@ -215,6 +225,10 @@ contains call psb_erractionsave(err_act) info = psb_success_ + ! + ! For non-iterative solvers, init and initu are ignored. + ! + call x%v%sync() call y%v%sync() diff --git a/mlprec/mld_d_umf_solver.F90 b/mlprec/mld_d_umf_solver.F90 index e76afb51..3725df9c 100644 --- a/mlprec/mld_d_umf_solver.F90 +++ b/mlprec/mld_d_umf_solver.F90 @@ -116,7 +116,8 @@ module mld_d_umf_solver contains - subroutine d_umf_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info) + subroutine d_umf_solver_apply(alpha,sv,x,beta,y,desc_data,& + & trans,work,info,init,initu) use psb_base_mod implicit none type(psb_desc_type), intent(in) :: desc_data @@ -127,6 +128,8 @@ contains character(len=1),intent(in) :: trans real(psb_dpk_),target, intent(inout) :: work(:) integer, intent(out) :: info + character, intent(in), optional :: init + real(psb_dpk_),intent(inout), optional :: initu(:) integer :: n_row,n_col real(psb_dpk_), pointer :: ww(:) @@ -146,6 +149,9 @@ contains call psb_errpush(psb_err_iarg_invalid_i_,name) goto 9999 end select + ! + ! For non-iterative solvers, init and initu are ignored. + ! n_row = desc_data%get_local_rows() n_col = desc_data%get_local_cols() @@ -202,7 +208,8 @@ contains end subroutine d_umf_solver_apply - subroutine d_umf_solver_apply_vect(alpha,sv,x,beta,y,desc_data,trans,work,info) + subroutine d_umf_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& + & trans,work,info,init,initu) use psb_base_mod implicit none type(psb_desc_type), intent(in) :: desc_data @@ -213,6 +220,8 @@ contains character(len=1),intent(in) :: trans real(psb_dpk_),target, intent(inout) :: work(:) integer, intent(out) :: info + character, intent(in), optional :: init + type(psb_d_vect_type),intent(inout), optional :: initu integer :: err_act character(len=20) :: name='d_umf_solver_apply_vect' @@ -220,6 +229,9 @@ contains call psb_erractionsave(err_act) info = psb_success_ + ! + ! For non-iterative solvers, init and initu are ignored. + ! call x%v%sync() call y%v%sync() diff --git a/mlprec/mld_s_as_smoother.f90 b/mlprec/mld_s_as_smoother.f90 index f1863221..82d04e38 100644 --- a/mlprec/mld_s_as_smoother.f90 +++ b/mlprec/mld_s_as_smoother.f90 @@ -97,7 +97,7 @@ module mld_s_as_smoother interface subroutine mld_s_as_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,& - & trans,sweeps,work,info) + & trans,sweeps,work,info,init,initu) import :: psb_sspmat_type, psb_s_vect_type, psb_s_base_vect_type, & & psb_spk_, mld_s_as_smoother_type, psb_long_int_k_, & & psb_desc_type, psb_ipk_ @@ -111,12 +111,14 @@ module mld_s_as_smoother integer(psb_ipk_), intent(in) :: sweeps real(psb_spk_),target, intent(inout) :: work(:) integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: init + type(psb_s_vect_type),intent(inout), optional :: initu end subroutine mld_s_as_smoother_apply_vect end interface interface subroutine mld_s_as_smoother_apply(alpha,sm,x,beta,y,desc_data,& - & trans,sweeps,work,info) + & trans,sweeps,work,info,init,initu) import :: psb_sspmat_type, psb_s_vect_type, psb_s_base_vect_type, & & psb_spk_, mld_s_as_smoother_type, psb_long_int_k_,& & psb_desc_type, psb_ipk_ @@ -130,6 +132,8 @@ module mld_s_as_smoother integer(psb_ipk_), intent(in) :: sweeps real(psb_spk_),target, intent(inout) :: work(:) integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: init + real(psb_spk_),intent(inout), optional :: initu(:) end subroutine mld_s_as_smoother_apply end interface diff --git a/mlprec/mld_s_base_smoother_mod.f90 b/mlprec/mld_s_base_smoother_mod.f90 index cf36e3a3..bee9d644 100644 --- a/mlprec/mld_s_base_smoother_mod.f90 +++ b/mlprec/mld_s_base_smoother_mod.f90 @@ -125,7 +125,7 @@ module mld_s_base_smoother_mod interface subroutine mld_s_base_smoother_apply(alpha,sm,x,beta,y,desc_data,& - & trans,sweeps,work,info) + & trans,sweeps,work,info,init,initu) import :: psb_desc_type, psb_sspmat_type, psb_s_base_sparse_mat, & & psb_s_vect_type, psb_s_base_vect_type, psb_spk_, & & mld_s_base_smoother_type, psb_ipk_ @@ -138,12 +138,14 @@ module mld_s_base_smoother_mod integer(psb_ipk_), intent(in) :: sweeps real(psb_spk_),target, intent(inout) :: work(:) integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: init + real(psb_spk_),intent(inout), optional :: initu(:) end subroutine mld_s_base_smoother_apply end interface interface subroutine mld_s_base_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,& - & trans,sweeps,work,info) + & trans,sweeps,work,info,init,initu) import :: psb_desc_type, psb_sspmat_type, psb_s_base_sparse_mat, & & psb_s_vect_type, psb_s_base_vect_type, psb_spk_, & & mld_s_base_smoother_type, psb_ipk_ @@ -156,6 +158,8 @@ module mld_s_base_smoother_mod integer(psb_ipk_), intent(in) :: sweeps real(psb_spk_),target, intent(inout) :: work(:) integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: init + type(psb_s_vect_type),intent(inout), optional :: initu end subroutine mld_s_base_smoother_apply_vect end interface diff --git a/mlprec/mld_s_base_solver_mod.f90 b/mlprec/mld_s_base_solver_mod.f90 index ef281740..71e6064c 100644 --- a/mlprec/mld_s_base_solver_mod.f90 +++ b/mlprec/mld_s_base_solver_mod.f90 @@ -116,7 +116,8 @@ module mld_s_base_solver_mod interface - subroutine mld_s_base_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info) + subroutine mld_s_base_solver_apply(alpha,sv,x,beta,y,desc_data,& + & trans,work,info,init,initu) import :: psb_desc_type, psb_sspmat_type, psb_s_base_sparse_mat, & & psb_s_vect_type, psb_s_base_vect_type, psb_spk_, & & mld_s_base_solver_type, psb_ipk_ @@ -129,12 +130,15 @@ module mld_s_base_solver_mod character(len=1),intent(in) :: trans real(psb_spk_),target, intent(inout) :: work(:) integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: init + real(psb_spk_),intent(inout), optional :: initu(:) end subroutine mld_s_base_solver_apply end interface interface - subroutine mld_s_base_solver_apply_vect(alpha,sv,x,beta,y,desc_data,trans,work,info) + subroutine mld_s_base_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& + & trans,work,info,init,initu) import :: psb_desc_type, psb_sspmat_type, psb_s_base_sparse_mat, & & psb_s_vect_type, psb_s_base_vect_type, psb_spk_, & & mld_s_base_solver_type, psb_ipk_ @@ -147,6 +151,8 @@ module mld_s_base_solver_mod character(len=1),intent(in) :: trans real(psb_spk_),target, intent(inout) :: work(:) integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: init + type(psb_s_vect_type),intent(inout), optional :: initu end subroutine mld_s_base_solver_apply_vect end interface diff --git a/mlprec/mld_s_diag_solver.f90 b/mlprec/mld_s_diag_solver.f90 index fccf08a9..8137067d 100644 --- a/mlprec/mld_s_diag_solver.f90 +++ b/mlprec/mld_s_diag_solver.f90 @@ -71,7 +71,7 @@ module mld_s_diag_solver interface subroutine mld_s_diag_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& - & trans,work,info) + & trans,work,info,init,initu) import :: psb_desc_type, psb_sspmat_type, psb_s_base_sparse_mat, & & psb_s_vect_type, psb_s_base_vect_type, psb_spk_, & & mld_s_diag_solver_type, psb_ipk_ @@ -83,11 +83,14 @@ module mld_s_diag_solver character(len=1),intent(in) :: trans real(psb_spk_),target, intent(inout) :: work(:) integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: init + type(psb_s_vect_type),intent(inout), optional :: initu end subroutine mld_s_diag_solver_apply_vect end interface interface - subroutine mld_s_diag_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info) + subroutine mld_s_diag_solver_apply(alpha,sv,x,beta,y,desc_data,& + & trans,work,info,init,initu) import :: psb_desc_type, psb_sspmat_type, psb_s_base_sparse_mat, & & psb_s_vect_type, psb_s_base_vect_type, psb_spk_, & & mld_s_diag_solver_type, psb_ipk_ @@ -99,6 +102,8 @@ module mld_s_diag_solver character(len=1),intent(in) :: trans real(psb_spk_),target, intent(inout) :: work(:) integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: init + real(psb_spk_),intent(inout), optional :: initu(:) end subroutine mld_s_diag_solver_apply end interface diff --git a/mlprec/mld_s_gs_solver.f90 b/mlprec/mld_s_gs_solver.f90 index c37b3f23..3a55fd32 100644 --- a/mlprec/mld_s_gs_solver.f90 +++ b/mlprec/mld_s_gs_solver.f90 @@ -96,7 +96,8 @@ module mld_s_gs_solver interface - subroutine mld_s_gs_solver_apply_vect(alpha,sv,x,beta,y,desc_data,trans,work,info) + subroutine mld_s_gs_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& + & trans,work,info,init,initu) import :: psb_desc_type, mld_s_gs_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 @@ -108,8 +109,11 @@ module mld_s_gs_solver character(len=1),intent(in) :: trans real(psb_spk_),target, intent(inout) :: work(:) integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: init + type(psb_s_vect_type),intent(inout), optional :: initu 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) + subroutine mld_s_bwgs_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& + & trans,work,info,init,initu) 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 @@ -121,11 +125,13 @@ module mld_s_gs_solver character(len=1),intent(in) :: trans real(psb_spk_),target, intent(inout) :: work(:) integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: init + type(psb_s_vect_type),intent(inout), optional :: initu end subroutine mld_s_bwgs_solver_apply_vect end interface interface - subroutine mld_s_gs_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info) + subroutine mld_s_gs_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info,init,initu) import :: psb_desc_type, mld_s_gs_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 @@ -137,8 +143,11 @@ module mld_s_gs_solver character(len=1),intent(in) :: trans real(psb_spk_),target, intent(inout) :: work(:) integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: init + real(psb_spk_),intent(inout), optional :: initu(:) end subroutine mld_s_gs_solver_apply - subroutine mld_s_bwgs_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info) + subroutine mld_s_bwgs_solver_apply(alpha,sv,x,beta,y,desc_data,& + & trans,work,info,init,initu) 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 @@ -150,6 +159,8 @@ module mld_s_gs_solver character(len=1),intent(in) :: trans real(psb_spk_),target, intent(inout) :: work(:) integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: init + real(psb_spk_),intent(inout), optional :: initu(:) end subroutine mld_s_bwgs_solver_apply end interface diff --git a/mlprec/mld_s_id_solver.f90 b/mlprec/mld_s_id_solver.f90 index d2b77367..4e8c71af 100644 --- a/mlprec/mld_s_id_solver.f90 +++ b/mlprec/mld_s_id_solver.f90 @@ -64,7 +64,8 @@ module mld_s_id_solver & s_id_solver_descr interface - subroutine mld_s_id_solver_apply_vect(alpha,sv,x,beta,y,desc_data,trans,work,info) + subroutine mld_s_id_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& + & trans,work,info,init,initu) import :: psb_desc_type, psb_sspmat_type, psb_s_base_sparse_mat, & & psb_s_vect_type, psb_s_base_vect_type, psb_spk_, & & mld_s_id_solver_type, psb_ipk_ @@ -76,11 +77,14 @@ module mld_s_id_solver character(len=1),intent(in) :: trans real(psb_spk_),target, intent(inout) :: work(:) integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: init + type(psb_s_vect_type),intent(inout), optional :: initu end subroutine mld_s_id_solver_apply_vect end interface interface - subroutine mld_s_id_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info) + subroutine mld_s_id_solver_apply(alpha,sv,x,beta,y,desc_data,& + & trans,work,info,init,initu) import :: psb_desc_type, psb_sspmat_type, psb_s_base_sparse_mat, & & psb_s_vect_type, psb_s_base_vect_type, psb_spk_, & & mld_s_id_solver_type, psb_ipk_ @@ -92,6 +96,8 @@ module mld_s_id_solver character(len=1),intent(in) :: trans real(psb_spk_),target, intent(inout) :: work(:) integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: init + real(psb_spk_),intent(inout), optional :: initu(:) end subroutine mld_s_id_solver_apply end interface diff --git a/mlprec/mld_s_ilu_solver.f90 b/mlprec/mld_s_ilu_solver.f90 index b6bb4a64..0fb61fe6 100644 --- a/mlprec/mld_s_ilu_solver.f90 +++ b/mlprec/mld_s_ilu_solver.f90 @@ -88,7 +88,8 @@ module mld_s_ilu_solver interface - subroutine mld_s_ilu_solver_apply_vect(alpha,sv,x,beta,y,desc_data,trans,work,info) + subroutine mld_s_ilu_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& + & trans,work,info,init,initu) import :: psb_desc_type, mld_s_ilu_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 @@ -100,11 +101,14 @@ module mld_s_ilu_solver character(len=1),intent(in) :: trans real(psb_spk_),target, intent(inout) :: work(:) integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: init + type(psb_s_vect_type),intent(inout), optional :: initu end subroutine mld_s_ilu_solver_apply_vect end interface interface - subroutine mld_s_ilu_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info) + subroutine mld_s_ilu_solver_apply(alpha,sv,x,beta,y,desc_data,& + & trans,work,info,init,initu) import :: psb_desc_type, mld_s_ilu_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 @@ -116,6 +120,8 @@ module mld_s_ilu_solver character(len=1),intent(in) :: trans real(psb_spk_),target, intent(inout) :: work(:) integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: init + real(psb_spk_),intent(inout), optional :: initu(:) end subroutine mld_s_ilu_solver_apply end interface diff --git a/mlprec/mld_s_jac_smoother.f90 b/mlprec/mld_s_jac_smoother.f90 index 892f018c..96b1923b 100644 --- a/mlprec/mld_s_jac_smoother.f90 +++ b/mlprec/mld_s_jac_smoother.f90 @@ -74,7 +74,7 @@ module mld_s_jac_smoother interface subroutine mld_s_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& - & sweeps,work,info) + & sweeps,work,info,init,initu) import :: psb_desc_type, mld_s_jac_smoother_type, psb_s_vect_type, psb_spk_, & & psb_sspmat_type, psb_s_base_sparse_mat, psb_s_base_vect_type,& & psb_ipk_ @@ -88,12 +88,14 @@ module mld_s_jac_smoother integer(psb_ipk_), intent(in) :: sweeps real(psb_spk_),target, intent(inout) :: work(:) integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: init + type(psb_s_vect_type),intent(inout), optional :: initu end subroutine mld_s_jac_smoother_apply_vect end interface interface subroutine mld_s_jac_smoother_apply(alpha,sm,x,beta,y,desc_data,trans,& - & sweeps,work,info) + & sweeps,work,info,init,initu) import :: psb_desc_type, mld_s_jac_smoother_type, psb_s_vect_type, psb_spk_, & & psb_sspmat_type, psb_s_base_sparse_mat, psb_s_base_vect_type, & & psb_ipk_ @@ -106,6 +108,8 @@ module mld_s_jac_smoother integer(psb_ipk_), intent(in) :: sweeps real(psb_spk_),target, intent(inout) :: work(:) integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: init + real(psb_spk_),intent(inout), optional :: initu(:) end subroutine mld_s_jac_smoother_apply end interface diff --git a/mlprec/mld_s_mumps_solver.F90 b/mlprec/mld_s_mumps_solver.F90 index 148c26cd..a73fd262 100644 --- a/mlprec/mld_s_mumps_solver.F90 +++ b/mlprec/mld_s_mumps_solver.F90 @@ -93,7 +93,8 @@ module mld_s_mumps_solver #endif interface - subroutine s_mumps_solver_apply_vect(alpha,sv,x,beta,y,desc_data,trans,work,info) + subroutine s_mumps_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& + & trans,work,info,init,initu) import :: psb_desc_type, mld_s_mumps_solver_type, psb_s_vect_type, psb_dpk_, psb_spk_, & & psb_sspmat_type, psb_s_base_sparse_mat, psb_s_base_vect_type, psb_ipk_ implicit none @@ -105,14 +106,13 @@ module mld_s_mumps_solver character(len=1),intent(in) :: trans real(psb_spk_),target, intent(inout) :: work(:) integer, intent(out) :: info - - integer(psb_ipk_) :: err_act - character(len=20) :: name='s_mumps_solver_apply_vect' + character, intent(in), optional :: init + type(psb_s_vect_type),intent(inout), optional :: initu end subroutine s_mumps_solver_apply_vect end interface interface - subroutine s_mumps_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info) + subroutine s_mumps_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info,init,initu) import :: psb_desc_type, mld_s_mumps_solver_type, psb_s_vect_type, psb_dpk_, psb_spk_, & & psb_sspmat_type, psb_s_base_sparse_mat, psb_s_base_vect_type, psb_ipk_ implicit none @@ -124,13 +124,8 @@ module mld_s_mumps_solver 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, nglob - real(psb_spk_), pointer :: ww(:) - real(psb_spk_), allocatable, target :: gx(:) - integer(psb_ipk_) :: ictxt,np,me,i, err_act - character :: trans_ - character(len=20) :: name='s_mumps_solver_apply' + character, intent(in), optional :: init + real(psb_spk_),intent(inout), optional :: initu(:) end subroutine s_mumps_solver_apply end interface diff --git a/mlprec/mld_s_slu_solver.F90 b/mlprec/mld_s_slu_solver.F90 index 4407e0ee..5c4a148e 100644 --- a/mlprec/mld_s_slu_solver.F90 +++ b/mlprec/mld_s_slu_solver.F90 @@ -116,7 +116,8 @@ module mld_s_slu_solver contains - subroutine s_slu_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info) + subroutine s_slu_solver_apply(alpha,sv,x,beta,y,desc_data,& + & trans,work,info,init,initu) use psb_base_mod implicit none type(psb_desc_type), intent(in) :: desc_data @@ -127,6 +128,8 @@ contains character(len=1),intent(in) :: trans real(psb_spk_),target, intent(inout) :: work(:) integer, intent(out) :: info + character, intent(in), optional :: init + real(psb_spk_),intent(inout), optional :: initu(:) integer :: n_row,n_col real(psb_spk_), pointer :: ww(:) @@ -146,6 +149,9 @@ contains call psb_errpush(psb_err_iarg_invalid_i_,name) goto 9999 end select + ! + ! For non-iterative solvers, init and initu are ignored. + ! n_row = desc_data%get_local_rows() n_col = desc_data%get_local_cols() @@ -198,7 +204,8 @@ contains end subroutine s_slu_solver_apply - subroutine s_slu_solver_apply_vect(alpha,sv,x,beta,y,desc_data,trans,work,info) + subroutine s_slu_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& + & trans,work,info,init,initu) use psb_base_mod implicit none type(psb_desc_type), intent(in) :: desc_data @@ -209,6 +216,8 @@ contains character(len=1),intent(in) :: trans real(psb_spk_),target, intent(inout) :: work(:) integer, intent(out) :: info + character, intent(in), optional :: init + type(psb_s_vect_type),intent(inout), optional :: initu integer :: err_act character(len=20) :: name='s_slu_solver_apply_vect' @@ -216,6 +225,9 @@ contains call psb_erractionsave(err_act) info = psb_success_ + ! + ! For non-iterative solvers, init and initu are ignored. + ! call x%v%sync() call y%v%sync() diff --git a/mlprec/mld_s_sludist_solver.F90 b/mlprec/mld_s_sludist_solver.F90 index 92500d18..19128c42 100644 --- a/mlprec/mld_s_sludist_solver.F90 +++ b/mlprec/mld_s_sludist_solver.F90 @@ -113,7 +113,8 @@ module mld_s_sludist_solver contains - subroutine s_sludist_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info) + subroutine s_sludist_solver_apply(alpha,sv,x,beta,y,desc_data,& + & trans,work,info,init,initu) use psb_base_mod implicit none type(psb_desc_type), intent(in) :: desc_data @@ -124,6 +125,8 @@ contains character(len=1),intent(in) :: trans real(psb_spk_),target, intent(inout) :: work(:) integer, intent(out) :: info + character, intent(in), optional :: init + real(psb_spk_),intent(inout), optional :: initu(:) integer :: n_row,n_col real(psb_spk_), pointer :: ww(:) @@ -143,6 +146,10 @@ contains call psb_errpush(psb_err_iarg_invalid_i_,name) goto 9999 end select + ! + ! For non-iterative solvers, init and initu are ignored. + ! + n_row = desc_data%get_local_rows() n_col = desc_data%get_local_cols() @@ -197,7 +204,8 @@ contains end subroutine s_sludist_solver_apply - subroutine s_sludist_solver_apply_vect(alpha,sv,x,beta,y,desc_data,trans,work,info) + subroutine s_sludist_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& + & trans,work,info,init,initu) use psb_base_mod implicit none type(psb_desc_type), intent(in) :: desc_data @@ -208,6 +216,8 @@ contains character(len=1),intent(in) :: trans real(psb_spk_),target, intent(inout) :: work(:) integer, intent(out) :: info + character, intent(in), optional :: init + type(psb_s_vect_type),intent(inout), optional :: initu integer :: err_act character(len=20) :: name='s_sludist_solver_apply_vect' @@ -215,6 +225,10 @@ contains call psb_erractionsave(err_act) info = psb_success_ + ! + ! For non-iterative solvers, init and initu are ignored. + ! + call x%v%sync() call y%v%sync() diff --git a/mlprec/mld_s_umf_solver.F90 b/mlprec/mld_s_umf_solver.F90 index f5450295..4933b4ac 100644 --- a/mlprec/mld_s_umf_solver.F90 +++ b/mlprec/mld_s_umf_solver.F90 @@ -116,7 +116,8 @@ module mld_s_umf_solver contains - subroutine s_umf_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info) + subroutine s_umf_solver_apply(alpha,sv,x,beta,y,desc_data,& + & trans,work,info,init,initu) use psb_base_mod implicit none type(psb_desc_type), intent(in) :: desc_data @@ -127,6 +128,8 @@ contains character(len=1),intent(in) :: trans real(psb_spk_),target, intent(inout) :: work(:) integer, intent(out) :: info + character, intent(in), optional :: init + real(psb_spk_),intent(inout), optional :: initu(:) integer :: n_row,n_col real(psb_spk_), pointer :: ww(:) @@ -146,6 +149,9 @@ contains call psb_errpush(psb_err_iarg_invalid_i_,name) goto 9999 end select + ! + ! For non-iterative solvers, init and initu are ignored. + ! n_row = desc_data%get_local_rows() n_col = desc_data%get_local_cols() @@ -202,7 +208,8 @@ contains end subroutine s_umf_solver_apply - subroutine s_umf_solver_apply_vect(alpha,sv,x,beta,y,desc_data,trans,work,info) + subroutine s_umf_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& + & trans,work,info,init,initu) use psb_base_mod implicit none type(psb_desc_type), intent(in) :: desc_data @@ -213,6 +220,8 @@ contains character(len=1),intent(in) :: trans real(psb_spk_),target, intent(inout) :: work(:) integer, intent(out) :: info + character, intent(in), optional :: init + type(psb_s_vect_type),intent(inout), optional :: initu integer :: err_act character(len=20) :: name='s_umf_solver_apply_vect' @@ -220,6 +229,9 @@ contains call psb_erractionsave(err_act) info = psb_success_ + ! + ! For non-iterative solvers, init and initu are ignored. + ! call x%v%sync() call y%v%sync() diff --git a/mlprec/mld_z_as_smoother.f90 b/mlprec/mld_z_as_smoother.f90 index c7c4468d..0aa57cdb 100644 --- a/mlprec/mld_z_as_smoother.f90 +++ b/mlprec/mld_z_as_smoother.f90 @@ -97,7 +97,7 @@ module mld_z_as_smoother interface subroutine mld_z_as_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,& - & trans,sweeps,work,info) + & trans,sweeps,work,info,init,initu) import :: psb_zspmat_type, psb_z_vect_type, psb_z_base_vect_type, & & psb_dpk_, mld_z_as_smoother_type, psb_long_int_k_, & & psb_desc_type, psb_ipk_ @@ -111,12 +111,14 @@ module mld_z_as_smoother integer(psb_ipk_), intent(in) :: sweeps complex(psb_dpk_),target, intent(inout) :: work(:) integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: init + type(psb_z_vect_type),intent(inout), optional :: initu end subroutine mld_z_as_smoother_apply_vect end interface interface subroutine mld_z_as_smoother_apply(alpha,sm,x,beta,y,desc_data,& - & trans,sweeps,work,info) + & trans,sweeps,work,info,init,initu) import :: psb_zspmat_type, psb_z_vect_type, psb_z_base_vect_type, & & psb_dpk_, mld_z_as_smoother_type, psb_long_int_k_,& & psb_desc_type, psb_ipk_ @@ -130,6 +132,8 @@ module mld_z_as_smoother integer(psb_ipk_), intent(in) :: sweeps complex(psb_dpk_),target, intent(inout) :: work(:) integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: init + complex(psb_dpk_),intent(inout), optional :: initu(:) end subroutine mld_z_as_smoother_apply end interface diff --git a/mlprec/mld_z_base_smoother_mod.f90 b/mlprec/mld_z_base_smoother_mod.f90 index ffffbca5..ea597d34 100644 --- a/mlprec/mld_z_base_smoother_mod.f90 +++ b/mlprec/mld_z_base_smoother_mod.f90 @@ -125,7 +125,7 @@ module mld_z_base_smoother_mod interface subroutine mld_z_base_smoother_apply(alpha,sm,x,beta,y,desc_data,& - & trans,sweeps,work,info) + & trans,sweeps,work,info,init,initu) import :: psb_desc_type, psb_zspmat_type, psb_z_base_sparse_mat, & & psb_z_vect_type, psb_z_base_vect_type, psb_dpk_, & & mld_z_base_smoother_type, psb_ipk_ @@ -138,12 +138,14 @@ module mld_z_base_smoother_mod integer(psb_ipk_), intent(in) :: sweeps complex(psb_dpk_),target, intent(inout) :: work(:) integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: init + complex(psb_dpk_),intent(inout), optional :: initu(:) end subroutine mld_z_base_smoother_apply end interface interface subroutine mld_z_base_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,& - & trans,sweeps,work,info) + & trans,sweeps,work,info,init,initu) import :: psb_desc_type, psb_zspmat_type, psb_z_base_sparse_mat, & & psb_z_vect_type, psb_z_base_vect_type, psb_dpk_, & & mld_z_base_smoother_type, psb_ipk_ @@ -156,6 +158,8 @@ module mld_z_base_smoother_mod integer(psb_ipk_), intent(in) :: sweeps complex(psb_dpk_),target, intent(inout) :: work(:) integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: init + type(psb_z_vect_type),intent(inout), optional :: initu end subroutine mld_z_base_smoother_apply_vect end interface diff --git a/mlprec/mld_z_base_solver_mod.f90 b/mlprec/mld_z_base_solver_mod.f90 index 9e2d1223..f82da71c 100644 --- a/mlprec/mld_z_base_solver_mod.f90 +++ b/mlprec/mld_z_base_solver_mod.f90 @@ -116,7 +116,8 @@ module mld_z_base_solver_mod interface - subroutine mld_z_base_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info) + subroutine mld_z_base_solver_apply(alpha,sv,x,beta,y,desc_data,& + & trans,work,info,init,initu) import :: psb_desc_type, psb_zspmat_type, psb_z_base_sparse_mat, & & psb_z_vect_type, psb_z_base_vect_type, psb_dpk_, & & mld_z_base_solver_type, psb_ipk_ @@ -129,12 +130,15 @@ module mld_z_base_solver_mod character(len=1),intent(in) :: trans complex(psb_dpk_),target, intent(inout) :: work(:) integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: init + complex(psb_dpk_),intent(inout), optional :: initu(:) end subroutine mld_z_base_solver_apply end interface interface - subroutine mld_z_base_solver_apply_vect(alpha,sv,x,beta,y,desc_data,trans,work,info) + subroutine mld_z_base_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& + & trans,work,info,init,initu) import :: psb_desc_type, psb_zspmat_type, psb_z_base_sparse_mat, & & psb_z_vect_type, psb_z_base_vect_type, psb_dpk_, & & mld_z_base_solver_type, psb_ipk_ @@ -147,6 +151,8 @@ module mld_z_base_solver_mod character(len=1),intent(in) :: trans complex(psb_dpk_),target, intent(inout) :: work(:) integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: init + type(psb_z_vect_type),intent(inout), optional :: initu end subroutine mld_z_base_solver_apply_vect end interface diff --git a/mlprec/mld_z_diag_solver.f90 b/mlprec/mld_z_diag_solver.f90 index 5078ba28..d51f4bf6 100644 --- a/mlprec/mld_z_diag_solver.f90 +++ b/mlprec/mld_z_diag_solver.f90 @@ -71,7 +71,7 @@ module mld_z_diag_solver interface subroutine mld_z_diag_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& - & trans,work,info) + & trans,work,info,init,initu) import :: psb_desc_type, psb_zspmat_type, psb_z_base_sparse_mat, & & psb_z_vect_type, psb_z_base_vect_type, psb_dpk_, & & mld_z_diag_solver_type, psb_ipk_ @@ -83,11 +83,14 @@ module mld_z_diag_solver character(len=1),intent(in) :: trans complex(psb_dpk_),target, intent(inout) :: work(:) integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: init + type(psb_z_vect_type),intent(inout), optional :: initu end subroutine mld_z_diag_solver_apply_vect end interface interface - subroutine mld_z_diag_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info) + subroutine mld_z_diag_solver_apply(alpha,sv,x,beta,y,desc_data,& + & trans,work,info,init,initu) import :: psb_desc_type, psb_zspmat_type, psb_z_base_sparse_mat, & & psb_z_vect_type, psb_z_base_vect_type, psb_dpk_, & & mld_z_diag_solver_type, psb_ipk_ @@ -99,6 +102,8 @@ module mld_z_diag_solver character(len=1),intent(in) :: trans complex(psb_dpk_),target, intent(inout) :: work(:) integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: init + complex(psb_dpk_),intent(inout), optional :: initu(:) end subroutine mld_z_diag_solver_apply end interface diff --git a/mlprec/mld_z_gs_solver.f90 b/mlprec/mld_z_gs_solver.f90 index a9a13679..d0256465 100644 --- a/mlprec/mld_z_gs_solver.f90 +++ b/mlprec/mld_z_gs_solver.f90 @@ -96,7 +96,8 @@ module mld_z_gs_solver interface - subroutine mld_z_gs_solver_apply_vect(alpha,sv,x,beta,y,desc_data,trans,work,info) + subroutine mld_z_gs_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& + & trans,work,info,init,initu) import :: psb_desc_type, mld_z_gs_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 @@ -108,8 +109,11 @@ module mld_z_gs_solver character(len=1),intent(in) :: trans complex(psb_dpk_),target, intent(inout) :: work(:) integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: init + type(psb_z_vect_type),intent(inout), optional :: initu 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) + subroutine mld_z_bwgs_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& + & trans,work,info,init,initu) 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 @@ -121,11 +125,13 @@ module mld_z_gs_solver character(len=1),intent(in) :: trans complex(psb_dpk_),target, intent(inout) :: work(:) integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: init + type(psb_z_vect_type),intent(inout), optional :: initu end subroutine mld_z_bwgs_solver_apply_vect end interface interface - subroutine mld_z_gs_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info) + subroutine mld_z_gs_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info,init,initu) import :: psb_desc_type, mld_z_gs_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 @@ -137,8 +143,11 @@ module mld_z_gs_solver character(len=1),intent(in) :: trans complex(psb_dpk_),target, intent(inout) :: work(:) integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: init + complex(psb_dpk_),intent(inout), optional :: initu(:) end subroutine mld_z_gs_solver_apply - subroutine mld_z_bwgs_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info) + subroutine mld_z_bwgs_solver_apply(alpha,sv,x,beta,y,desc_data,& + & trans,work,info,init,initu) 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 @@ -150,6 +159,8 @@ module mld_z_gs_solver character(len=1),intent(in) :: trans complex(psb_dpk_),target, intent(inout) :: work(:) integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: init + complex(psb_dpk_),intent(inout), optional :: initu(:) end subroutine mld_z_bwgs_solver_apply end interface diff --git a/mlprec/mld_z_id_solver.f90 b/mlprec/mld_z_id_solver.f90 index ff003367..11c7d1bf 100644 --- a/mlprec/mld_z_id_solver.f90 +++ b/mlprec/mld_z_id_solver.f90 @@ -64,7 +64,8 @@ module mld_z_id_solver & z_id_solver_descr interface - subroutine mld_z_id_solver_apply_vect(alpha,sv,x,beta,y,desc_data,trans,work,info) + subroutine mld_z_id_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& + & trans,work,info,init,initu) import :: psb_desc_type, psb_zspmat_type, psb_z_base_sparse_mat, & & psb_z_vect_type, psb_z_base_vect_type, psb_dpk_, & & mld_z_id_solver_type, psb_ipk_ @@ -76,11 +77,14 @@ module mld_z_id_solver character(len=1),intent(in) :: trans complex(psb_dpk_),target, intent(inout) :: work(:) integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: init + type(psb_z_vect_type),intent(inout), optional :: initu end subroutine mld_z_id_solver_apply_vect end interface interface - subroutine mld_z_id_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info) + subroutine mld_z_id_solver_apply(alpha,sv,x,beta,y,desc_data,& + & trans,work,info,init,initu) import :: psb_desc_type, psb_zspmat_type, psb_z_base_sparse_mat, & & psb_z_vect_type, psb_z_base_vect_type, psb_dpk_, & & mld_z_id_solver_type, psb_ipk_ @@ -92,6 +96,8 @@ module mld_z_id_solver character(len=1),intent(in) :: trans complex(psb_dpk_),target, intent(inout) :: work(:) integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: init + complex(psb_dpk_),intent(inout), optional :: initu(:) end subroutine mld_z_id_solver_apply end interface diff --git a/mlprec/mld_z_ilu_solver.f90 b/mlprec/mld_z_ilu_solver.f90 index 562889b8..fa57e8f4 100644 --- a/mlprec/mld_z_ilu_solver.f90 +++ b/mlprec/mld_z_ilu_solver.f90 @@ -88,7 +88,8 @@ module mld_z_ilu_solver interface - subroutine mld_z_ilu_solver_apply_vect(alpha,sv,x,beta,y,desc_data,trans,work,info) + subroutine mld_z_ilu_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& + & trans,work,info,init,initu) import :: psb_desc_type, mld_z_ilu_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 @@ -100,11 +101,14 @@ module mld_z_ilu_solver character(len=1),intent(in) :: trans complex(psb_dpk_),target, intent(inout) :: work(:) integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: init + type(psb_z_vect_type),intent(inout), optional :: initu end subroutine mld_z_ilu_solver_apply_vect end interface interface - subroutine mld_z_ilu_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info) + subroutine mld_z_ilu_solver_apply(alpha,sv,x,beta,y,desc_data,& + & trans,work,info,init,initu) import :: psb_desc_type, mld_z_ilu_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 @@ -116,6 +120,8 @@ module mld_z_ilu_solver character(len=1),intent(in) :: trans complex(psb_dpk_),target, intent(inout) :: work(:) integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: init + complex(psb_dpk_),intent(inout), optional :: initu(:) end subroutine mld_z_ilu_solver_apply end interface diff --git a/mlprec/mld_z_jac_smoother.f90 b/mlprec/mld_z_jac_smoother.f90 index dbd03b2f..a9772d08 100644 --- a/mlprec/mld_z_jac_smoother.f90 +++ b/mlprec/mld_z_jac_smoother.f90 @@ -74,7 +74,7 @@ module mld_z_jac_smoother interface subroutine mld_z_jac_smoother_apply_vect(alpha,sm,x,beta,y,desc_data,trans,& - & sweeps,work,info) + & sweeps,work,info,init,initu) import :: psb_desc_type, mld_z_jac_smoother_type, psb_z_vect_type, psb_dpk_, & & psb_zspmat_type, psb_z_base_sparse_mat, psb_z_base_vect_type,& & psb_ipk_ @@ -88,12 +88,14 @@ module mld_z_jac_smoother integer(psb_ipk_), intent(in) :: sweeps complex(psb_dpk_),target, intent(inout) :: work(:) integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: init + type(psb_z_vect_type),intent(inout), optional :: initu end subroutine mld_z_jac_smoother_apply_vect end interface interface subroutine mld_z_jac_smoother_apply(alpha,sm,x,beta,y,desc_data,trans,& - & sweeps,work,info) + & sweeps,work,info,init,initu) import :: psb_desc_type, mld_z_jac_smoother_type, psb_z_vect_type, psb_dpk_, & & psb_zspmat_type, psb_z_base_sparse_mat, psb_z_base_vect_type, & & psb_ipk_ @@ -106,6 +108,8 @@ module mld_z_jac_smoother integer(psb_ipk_), intent(in) :: sweeps complex(psb_dpk_),target, intent(inout) :: work(:) integer(psb_ipk_), intent(out) :: info + character, intent(in), optional :: init + complex(psb_dpk_),intent(inout), optional :: initu(:) end subroutine mld_z_jac_smoother_apply end interface diff --git a/mlprec/mld_z_mumps_solver.F90 b/mlprec/mld_z_mumps_solver.F90 index 5d9d318d..00310bc5 100644 --- a/mlprec/mld_z_mumps_solver.F90 +++ b/mlprec/mld_z_mumps_solver.F90 @@ -93,7 +93,8 @@ module mld_z_mumps_solver #endif interface - subroutine z_mumps_solver_apply_vect(alpha,sv,x,beta,y,desc_data,trans,work,info) + subroutine z_mumps_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& + & trans,work,info,init,initu) import :: psb_desc_type, mld_z_mumps_solver_type, psb_z_vect_type, psb_dpk_, psb_spk_, & & psb_zspmat_type, psb_z_base_sparse_mat, psb_z_base_vect_type, psb_ipk_ implicit none @@ -105,14 +106,13 @@ module mld_z_mumps_solver character(len=1),intent(in) :: trans complex(psb_dpk_),target, intent(inout) :: work(:) integer, intent(out) :: info - - integer(psb_ipk_) :: err_act - character(len=20) :: name='z_mumps_solver_apply_vect' + character, intent(in), optional :: init + type(psb_z_vect_type),intent(inout), optional :: initu end subroutine z_mumps_solver_apply_vect end interface interface - subroutine z_mumps_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info) + subroutine z_mumps_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info,init,initu) import :: psb_desc_type, mld_z_mumps_solver_type, psb_z_vect_type, psb_dpk_, psb_spk_, & & psb_zspmat_type, psb_z_base_sparse_mat, psb_z_base_vect_type, psb_ipk_ implicit none @@ -124,13 +124,8 @@ module mld_z_mumps_solver 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, nglob - complex(psb_dpk_), pointer :: ww(:) - complex(psb_dpk_), allocatable, target :: gx(:) - integer(psb_ipk_) :: ictxt,np,me,i, err_act - character :: trans_ - character(len=20) :: name='z_mumps_solver_apply' + character, intent(in), optional :: init + complex(psb_dpk_),intent(inout), optional :: initu(:) end subroutine z_mumps_solver_apply end interface diff --git a/mlprec/mld_z_slu_solver.F90 b/mlprec/mld_z_slu_solver.F90 index f15d1fb8..3fff7c5e 100644 --- a/mlprec/mld_z_slu_solver.F90 +++ b/mlprec/mld_z_slu_solver.F90 @@ -116,7 +116,8 @@ module mld_z_slu_solver contains - subroutine z_slu_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info) + subroutine z_slu_solver_apply(alpha,sv,x,beta,y,desc_data,& + & trans,work,info,init,initu) use psb_base_mod implicit none type(psb_desc_type), intent(in) :: desc_data @@ -127,6 +128,8 @@ contains character(len=1),intent(in) :: trans complex(psb_dpk_),target, intent(inout) :: work(:) integer, intent(out) :: info + character, intent(in), optional :: init + complex(psb_dpk_),intent(inout), optional :: initu(:) integer :: n_row,n_col complex(psb_dpk_), pointer :: ww(:) @@ -146,6 +149,9 @@ contains call psb_errpush(psb_err_iarg_invalid_i_,name) goto 9999 end select + ! + ! For non-iterative solvers, init and initu are ignored. + ! n_row = desc_data%get_local_rows() n_col = desc_data%get_local_cols() @@ -198,7 +204,8 @@ contains end subroutine z_slu_solver_apply - subroutine z_slu_solver_apply_vect(alpha,sv,x,beta,y,desc_data,trans,work,info) + subroutine z_slu_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& + & trans,work,info,init,initu) use psb_base_mod implicit none type(psb_desc_type), intent(in) :: desc_data @@ -209,6 +216,8 @@ contains character(len=1),intent(in) :: trans complex(psb_dpk_),target, intent(inout) :: work(:) integer, intent(out) :: info + character, intent(in), optional :: init + type(psb_z_vect_type),intent(inout), optional :: initu integer :: err_act character(len=20) :: name='z_slu_solver_apply_vect' @@ -216,6 +225,9 @@ contains call psb_erractionsave(err_act) info = psb_success_ + ! + ! For non-iterative solvers, init and initu are ignored. + ! call x%v%sync() call y%v%sync() diff --git a/mlprec/mld_z_sludist_solver.F90 b/mlprec/mld_z_sludist_solver.F90 index bd9ea637..a6a71848 100644 --- a/mlprec/mld_z_sludist_solver.F90 +++ b/mlprec/mld_z_sludist_solver.F90 @@ -113,7 +113,8 @@ module mld_z_sludist_solver contains - subroutine z_sludist_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info) + subroutine z_sludist_solver_apply(alpha,sv,x,beta,y,desc_data,& + & trans,work,info,init,initu) use psb_base_mod implicit none type(psb_desc_type), intent(in) :: desc_data @@ -124,6 +125,8 @@ contains character(len=1),intent(in) :: trans complex(psb_dpk_),target, intent(inout) :: work(:) integer, intent(out) :: info + character, intent(in), optional :: init + complex(psb_dpk_),intent(inout), optional :: initu(:) integer :: n_row,n_col complex(psb_dpk_), pointer :: ww(:) @@ -143,6 +146,10 @@ contains call psb_errpush(psb_err_iarg_invalid_i_,name) goto 9999 end select + ! + ! For non-iterative solvers, init and initu are ignored. + ! + n_row = desc_data%get_local_rows() n_col = desc_data%get_local_cols() @@ -197,7 +204,8 @@ contains end subroutine z_sludist_solver_apply - subroutine z_sludist_solver_apply_vect(alpha,sv,x,beta,y,desc_data,trans,work,info) + subroutine z_sludist_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& + & trans,work,info,init,initu) use psb_base_mod implicit none type(psb_desc_type), intent(in) :: desc_data @@ -208,6 +216,8 @@ contains character(len=1),intent(in) :: trans complex(psb_dpk_),target, intent(inout) :: work(:) integer, intent(out) :: info + character, intent(in), optional :: init + type(psb_z_vect_type),intent(inout), optional :: initu integer :: err_act character(len=20) :: name='z_sludist_solver_apply_vect' @@ -215,6 +225,10 @@ contains call psb_erractionsave(err_act) info = psb_success_ + ! + ! For non-iterative solvers, init and initu are ignored. + ! + call x%v%sync() call y%v%sync() diff --git a/mlprec/mld_z_umf_solver.F90 b/mlprec/mld_z_umf_solver.F90 index e07530d7..362ffe2f 100644 --- a/mlprec/mld_z_umf_solver.F90 +++ b/mlprec/mld_z_umf_solver.F90 @@ -116,7 +116,8 @@ module mld_z_umf_solver contains - subroutine z_umf_solver_apply(alpha,sv,x,beta,y,desc_data,trans,work,info) + subroutine z_umf_solver_apply(alpha,sv,x,beta,y,desc_data,& + & trans,work,info,init,initu) use psb_base_mod implicit none type(psb_desc_type), intent(in) :: desc_data @@ -127,6 +128,8 @@ contains character(len=1),intent(in) :: trans complex(psb_dpk_),target, intent(inout) :: work(:) integer, intent(out) :: info + character, intent(in), optional :: init + complex(psb_dpk_),intent(inout), optional :: initu(:) integer :: n_row,n_col complex(psb_dpk_), pointer :: ww(:) @@ -146,6 +149,9 @@ contains call psb_errpush(psb_err_iarg_invalid_i_,name) goto 9999 end select + ! + ! For non-iterative solvers, init and initu are ignored. + ! n_row = desc_data%get_local_rows() n_col = desc_data%get_local_cols() @@ -202,7 +208,8 @@ contains end subroutine z_umf_solver_apply - subroutine z_umf_solver_apply_vect(alpha,sv,x,beta,y,desc_data,trans,work,info) + subroutine z_umf_solver_apply_vect(alpha,sv,x,beta,y,desc_data,& + & trans,work,info,init,initu) use psb_base_mod implicit none type(psb_desc_type), intent(in) :: desc_data @@ -213,6 +220,8 @@ contains character(len=1),intent(in) :: trans complex(psb_dpk_),target, intent(inout) :: work(:) integer, intent(out) :: info + character, intent(in), optional :: init + type(psb_z_vect_type),intent(inout), optional :: initu integer :: err_act character(len=20) :: name='z_umf_solver_apply_vect' @@ -220,6 +229,9 @@ contains call psb_erractionsave(err_act) info = psb_success_ + ! + ! For non-iterative solvers, init and initu are ignored. + ! call x%v%sync() call y%v%sync()