|
|
@ -581,7 +581,6 @@ contains
|
|
|
|
end if
|
|
|
|
end if
|
|
|
|
|
|
|
|
|
|
|
|
else
|
|
|
|
else
|
|
|
|
! Here at coarse level
|
|
|
|
|
|
|
|
sweeps = p%precv(level)%parms%sweeps
|
|
|
|
sweeps = p%precv(level)%parms%sweeps
|
|
|
|
call p%precv(level)%sm%apply(done,&
|
|
|
|
call p%precv(level)%sm%apply(done,&
|
|
|
|
& mlprec_wrk(level)%x2l,dzero,mlprec_wrk(level)%y2l,&
|
|
|
|
& mlprec_wrk(level)%x2l,dzero,mlprec_wrk(level)%y2l,&
|
|
|
@ -1112,7 +1111,7 @@ subroutine mld_dmlprec_aply_vect(alpha,p,x,beta,y,desc_data,trans,work,info)
|
|
|
|
|
|
|
|
|
|
|
|
contains
|
|
|
|
contains
|
|
|
|
|
|
|
|
|
|
|
|
recursive subroutine inner_ml_aply(level,p,mlprec_wrk,trans,work,info, u)
|
|
|
|
recursive subroutine inner_ml_aply(level,p,mlprec_wrk,trans,work,info, U)
|
|
|
|
|
|
|
|
|
|
|
|
implicit none
|
|
|
|
implicit none
|
|
|
|
|
|
|
|
|
|
|
@ -1127,6 +1126,7 @@ contains
|
|
|
|
|
|
|
|
|
|
|
|
type(psb_d_vect_type) :: res
|
|
|
|
type(psb_d_vect_type) :: res
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
! Local variables
|
|
|
|
! Local variables
|
|
|
|
integer(psb_ipk_) :: ictxt,np,me
|
|
|
|
integer(psb_ipk_) :: ictxt,np,me
|
|
|
|
integer(psb_ipk_) :: i, nr2l,nc2l,err_act
|
|
|
|
integer(psb_ipk_) :: i, nr2l,nc2l,err_act
|
|
|
@ -1672,311 +1672,319 @@ contains
|
|
|
|
end select
|
|
|
|
end select
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
case(mld_vcycle_ml_, mld_wcycle_ml_)
|
|
|
|
case(mld_vcycle_ml_, mld_wcycle_ml_)
|
|
|
|
|
|
|
|
|
|
|
|
!V/W cycle
|
|
|
|
!V/W cycle
|
|
|
|
if (level > 1) then
|
|
|
|
if (level > 1) then
|
|
|
|
! Apply the restriction
|
|
|
|
! Apply the restriction
|
|
|
|
call psb_map_X2Y(done,mlprec_wrk(level-1)%vty,&
|
|
|
|
call psb_map_X2Y(done,mlprec_wrk(level-1)%vty,&
|
|
|
|
& dzero,mlprec_wrk(level)%vx2l,&
|
|
|
|
& dzero,mlprec_wrk(level)%vx2l,&
|
|
|
|
& p%precv(level)%map,info,work=work)
|
|
|
|
& p%precv(level)%map,info,work=work)
|
|
|
|
|
|
|
|
|
|
|
|
if (info /= psb_success_) then
|
|
|
|
if (info /= psb_success_) then
|
|
|
|
call psb_errpush(psb_err_internal_error_,name,&
|
|
|
|
call psb_errpush(psb_err_internal_error_,name,&
|
|
|
|
& a_err='Error during restriction')
|
|
|
|
& a_err='Error during restriction')
|
|
|
|
goto 9999
|
|
|
|
goto 9999
|
|
|
|
end if
|
|
|
|
|
|
|
|
end if
|
|
|
|
end if
|
|
|
|
|
|
|
|
end if
|
|
|
|
|
|
|
|
|
|
|
|
call psb_geaxpby(done,mlprec_wrk(level)%vx2l,&
|
|
|
|
call psb_geaxpby(done,mlprec_wrk(level)%vx2l,&
|
|
|
|
& dzero,mlprec_wrk(level)%vtx,&
|
|
|
|
& dzero,mlprec_wrk(level)%vtx,&
|
|
|
|
& p%precv(level)%base_desc,info)
|
|
|
|
& p%precv(level)%base_desc,info)
|
|
|
|
!
|
|
|
|
!
|
|
|
|
! Apply the base preconditioner
|
|
|
|
! Apply the base preconditioner
|
|
|
|
!
|
|
|
|
!
|
|
|
|
if (level < nlev) then
|
|
|
|
if (level < nlev) then
|
|
|
|
|
|
|
|
|
|
|
|
if (present(u)) then
|
|
|
|
if (present(u)) then
|
|
|
|
call mlprec_wrk(level)%vy2l%set(u%get_vect())
|
|
|
|
! call mlprec_wrk(level)%vy2l%set(u%get_vect())
|
|
|
|
else
|
|
|
|
call psb_geaxpby(done,u,&
|
|
|
|
call mlprec_wrk(level)%vy2l%set(dzero)
|
|
|
|
& dzero,mlprec_wrk(level)%vy2l,&
|
|
|
|
endif
|
|
|
|
& p%precv(level)%base_desc,info)
|
|
|
|
res = mlprec_wrk(level)%vx2l
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
call psb_spmm(-done,p%precv(level)%base_a,mlprec_wrk(level)%vy2l,&
|
|
|
|
else
|
|
|
|
done, res, p%precv(level)%base_desc, info, work=work, trans=trans)
|
|
|
|
call mlprec_wrk(level)%vy2l%set(dzero)
|
|
|
|
|
|
|
|
endif
|
|
|
|
|
|
|
|
res = mlprec_wrk(level)%vx2l
|
|
|
|
|
|
|
|
|
|
|
|
if (info /= psb_success_) then
|
|
|
|
call psb_spmm(-done,p%precv(level)%base_a,mlprec_wrk(level)%vy2l,&
|
|
|
|
call psb_errpush(psb_err_internal_error_,name,&
|
|
|
|
done, res, p%precv(level)%base_desc, info, work=work, trans=trans)
|
|
|
|
& a_err='Error during residue')
|
|
|
|
|
|
|
|
goto 9999
|
|
|
|
|
|
|
|
end if
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
if (trans == 'N') then
|
|
|
|
if (info /= psb_success_) then
|
|
|
|
sweeps = p%precv(level)%parms%sweeps_pre
|
|
|
|
call psb_errpush(psb_err_internal_error_,name,&
|
|
|
|
if (info == psb_success_) call p%precv(level)%sm%apply(done,&
|
|
|
|
& a_err='Error during residue')
|
|
|
|
& mlprec_wrk(level)%vx2l,dzero,mlprec_wrk(level)%vy2l,&
|
|
|
|
goto 9999
|
|
|
|
& p%precv(level)%base_desc, trans,&
|
|
|
|
end if
|
|
|
|
& sweeps,work,info)
|
|
|
|
|
|
|
|
else
|
|
|
|
if (trans == 'N') then
|
|
|
|
sweeps = p%precv(level)%parms%sweeps_post
|
|
|
|
sweeps = p%precv(level)%parms%sweeps_pre
|
|
|
|
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,&
|
|
|
|
if (info == psb_success_) call p%precv(level)%sm%apply(done,&
|
|
|
|
& mlprec_wrk(level)%vx2l,dzero,mlprec_wrk(level)%vy2l,&
|
|
|
|
& mlprec_wrk(level)%vx2l,dzero,mlprec_wrk(level)%vy2l,&
|
|
|
|
& p%precv(level)%base_desc, trans,&
|
|
|
|
& p%precv(level)%base_desc, trans,&
|
|
|
|
& sweeps,work,info)
|
|
|
|
& 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
|
|
|
|
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
|
|
|
|
if (info /= psb_success_) then
|
|
|
|
call psb_errpush(psb_err_internal_error_,name,&
|
|
|
|
call psb_errpush(psb_err_internal_error_,name,&
|
|
|
|
& a_err='Error during 2-PRE smoother_apply')
|
|
|
|
& a_err='Error during 2-PRE smoother_apply')
|
|
|
|
goto 9999
|
|
|
|
goto 9999
|
|
|
|
end if
|
|
|
|
end if
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
!
|
|
|
|
!
|
|
|
|
! Compute the residual (at all levels but the coarsest one)
|
|
|
|
! Compute the residual (at all levels but the coarsest one)
|
|
|
|
! and call recursively
|
|
|
|
! and call recursively
|
|
|
|
!
|
|
|
|
!
|
|
|
|
if(level < nlev) then
|
|
|
|
if(level < nlev) then
|
|
|
|
|
|
|
|
|
|
|
|
call psb_geaxpby(done,mlprec_wrk(level)%vx2l,&
|
|
|
|
call psb_geaxpby(done,mlprec_wrk(level)%vx2l,&
|
|
|
|
& dzero,mlprec_wrk(level)%vty,&
|
|
|
|
& dzero,mlprec_wrk(level)%vty,&
|
|
|
|
& p%precv(level)%base_desc,info)
|
|
|
|
& p%precv(level)%base_desc,info)
|
|
|
|
|
|
|
|
|
|
|
|
if (info == psb_success_) call psb_spmm(-done,p%precv(level)%base_a,&
|
|
|
|
if (info == psb_success_) call psb_spmm(-done,p%precv(level)%base_a,&
|
|
|
|
& mlprec_wrk(level)%vy2l,done,mlprec_wrk(level)%vty,&
|
|
|
|
& mlprec_wrk(level)%vy2l,done,mlprec_wrk(level)%vty,&
|
|
|
|
& p%precv(level)%base_desc,info,work=work,trans=trans)
|
|
|
|
& p%precv(level)%base_desc,info,work=work,trans=trans)
|
|
|
|
if (info /= psb_success_) then
|
|
|
|
if (info /= psb_success_) then
|
|
|
|
call psb_errpush(psb_err_internal_error_,name,&
|
|
|
|
call psb_errpush(psb_err_internal_error_,name,&
|
|
|
|
& a_err='Error during residue')
|
|
|
|
& a_err='Error during residue')
|
|
|
|
goto 9999
|
|
|
|
goto 9999
|
|
|
|
end if
|
|
|
|
end if
|
|
|
|
|
|
|
|
|
|
|
|
call inner_ml_aply(level+1,p,mlprec_wrk,trans,work,info)
|
|
|
|
call inner_ml_aply(level+1,p,mlprec_wrk,trans,work,info)
|
|
|
|
|
|
|
|
|
|
|
|
if (p%precv(level)%parms%ml_type == mld_wcycle_ml_) then
|
|
|
|
if (p%precv(level)%parms%ml_type == mld_wcycle_ml_) then
|
|
|
|
call inner_ml_aply(level+1,p,mlprec_wrk,trans,work,info, mlprec_wrk(level+1)%vy2l)
|
|
|
|
call inner_ml_aply(level+1,p,mlprec_wrk,trans,work,info, mlprec_wrk(level+1)%vy2l)
|
|
|
|
endif
|
|
|
|
endif
|
|
|
|
|
|
|
|
|
|
|
|
if (info /= psb_success_) then
|
|
|
|
if (info /= psb_success_) then
|
|
|
|
call psb_errpush(psb_err_internal_error_,name,&
|
|
|
|
call psb_errpush(psb_err_internal_error_,name,&
|
|
|
|
& a_err='Error in recursive call')
|
|
|
|
& a_err='Error in recursive call')
|
|
|
|
goto 9999
|
|
|
|
goto 9999
|
|
|
|
end if
|
|
|
|
end if
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
!
|
|
|
|
!
|
|
|
|
! Apply the prolongator
|
|
|
|
! Apply the prolongator
|
|
|
|
!
|
|
|
|
!
|
|
|
|
call psb_map_Y2X(done,mlprec_wrk(level+1)%vy2l,&
|
|
|
|
call psb_map_Y2X(done,mlprec_wrk(level+1)%vy2l,&
|
|
|
|
& done,mlprec_wrk(level)%vy2l,&
|
|
|
|
& done,mlprec_wrk(level)%vy2l,&
|
|
|
|
& p%precv(level+1)%map,info,work=work)
|
|
|
|
& p%precv(level+1)%map,info,work=work)
|
|
|
|
|
|
|
|
|
|
|
|
if (info /= psb_success_) then
|
|
|
|
if (info /= psb_success_) then
|
|
|
|
call psb_errpush(psb_err_internal_error_,name,&
|
|
|
|
call psb_errpush(psb_err_internal_error_,name,&
|
|
|
|
& a_err='Error during prolongation')
|
|
|
|
& a_err='Error during prolongation')
|
|
|
|
goto 9999
|
|
|
|
goto 9999
|
|
|
|
end if
|
|
|
|
end if
|
|
|
|
|
|
|
|
|
|
|
|
!
|
|
|
|
!
|
|
|
|
! Compute the residual
|
|
|
|
! Compute the residual
|
|
|
|
!
|
|
|
|
!
|
|
|
|
call psb_spmm(-done,p%precv(level)%base_a,mlprec_wrk(level)%vy2l,&
|
|
|
|
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)%vtx,p%precv(level)%base_desc,info,&
|
|
|
|
& work=work,trans=trans)
|
|
|
|
& work=work,trans=trans)
|
|
|
|
if (info /= psb_success_) then
|
|
|
|
if (info /= psb_success_) then
|
|
|
|
call psb_errpush(psb_err_internal_error_,name,&
|
|
|
|
call psb_errpush(psb_err_internal_error_,name,&
|
|
|
|
& a_err='Error during residue')
|
|
|
|
& a_err='Error during residue')
|
|
|
|
goto 9999
|
|
|
|
goto 9999
|
|
|
|
end if
|
|
|
|
end if
|
|
|
|
!
|
|
|
|
!
|
|
|
|
! Apply the base preconditioner
|
|
|
|
! Apply the base preconditioner
|
|
|
|
!
|
|
|
|
!
|
|
|
|
if (trans == 'N') then
|
|
|
|
if (trans == 'N') then
|
|
|
|
sweeps = p%precv(level)%parms%sweeps_post
|
|
|
|
sweeps = p%precv(level)%parms%sweeps_post
|
|
|
|
if (info == psb_success_) call p%precv(level)%sm2%apply(done,&
|
|
|
|
if (info == psb_success_) call p%precv(level)%sm2%apply(done,&
|
|
|
|
& mlprec_wrk(level)%vtx,done,mlprec_wrk(level)%vy2l,&
|
|
|
|
& mlprec_wrk(level)%vtx,done,mlprec_wrk(level)%vy2l,&
|
|
|
|
& p%precv(level)%base_desc, trans,&
|
|
|
|
& p%precv(level)%base_desc, trans,&
|
|
|
|
& sweeps,work,info)
|
|
|
|
& sweeps,work,info)
|
|
|
|
else
|
|
|
|
else
|
|
|
|
sweeps = p%precv(level)%parms%sweeps_pre
|
|
|
|
sweeps = p%precv(level)%parms%sweeps_pre
|
|
|
|
if (info == psb_success_) call p%precv(level)%sm%apply(done,&
|
|
|
|
if (info == psb_success_) call p%precv(level)%sm%apply(done,&
|
|
|
|
& mlprec_wrk(level)%vtx,done,mlprec_wrk(level)%vy2l,&
|
|
|
|
& mlprec_wrk(level)%vtx,done,mlprec_wrk(level)%vy2l,&
|
|
|
|
& p%precv(level)%base_desc, trans,&
|
|
|
|
& p%precv(level)%base_desc, trans,&
|
|
|
|
& sweeps,work,info)
|
|
|
|
& sweeps,work,info)
|
|
|
|
end if
|
|
|
|
end if
|
|
|
|
|
|
|
|
|
|
|
|
if (info /= psb_success_) then
|
|
|
|
if (info /= psb_success_) then
|
|
|
|
call psb_errpush(psb_err_internal_error_,name,&
|
|
|
|
call psb_errpush(psb_err_internal_error_,name,&
|
|
|
|
& a_err='Error during 2-POST smoother_apply')
|
|
|
|
& a_err='Error during 2-POST smoother_apply')
|
|
|
|
goto 9999
|
|
|
|
goto 9999
|
|
|
|
end if
|
|
|
|
end if
|
|
|
|
|
|
|
|
|
|
|
|
endif
|
|
|
|
endif
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
case(mld_kcycle_ml_, mld_kcyclesym_ml_)
|
|
|
|
case(mld_kcycle_ml_, mld_kcyclesym_ml_)
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
!K cycle
|
|
|
|
!K cycle
|
|
|
|
|
|
|
|
|
|
|
|
call psb_geaxpby(done,mlprec_wrk(level)%vx2l,&
|
|
|
|
call psb_geaxpby(done,mlprec_wrk(level)%vx2l,&
|
|
|
|
& dzero,mlprec_wrk(level)%vtx,&
|
|
|
|
& dzero,mlprec_wrk(level)%vtx,&
|
|
|
|
& p%precv(level)%base_desc,info)
|
|
|
|
& p%precv(level)%base_desc,info)
|
|
|
|
!
|
|
|
|
!
|
|
|
|
! Apply the base preconditioner
|
|
|
|
! Apply the base preconditioner
|
|
|
|
!
|
|
|
|
!
|
|
|
|
if (level < nlev) then
|
|
|
|
if (level < nlev) then
|
|
|
|
|
|
|
|
|
|
|
|
if (present(u)) then
|
|
|
|
if (present(u)) then
|
|
|
|
call mlprec_wrk(level)%vy2l%set(u%get_vect())
|
|
|
|
call psb_geaxpby(done,u,&
|
|
|
|
else
|
|
|
|
& dzero,mlprec_wrk(level)%vy2l,&
|
|
|
|
call mlprec_wrk(level)%vy2l%set(dzero)
|
|
|
|
& p%precv(level)%base_desc,info)
|
|
|
|
endif
|
|
|
|
else
|
|
|
|
res = mlprec_wrk(level)%vx2l
|
|
|
|
call mlprec_wrk(level)%vy2l%set(dzero)
|
|
|
|
|
|
|
|
endif
|
|
|
|
|
|
|
|
res = mlprec_wrk(level)%vx2l
|
|
|
|
|
|
|
|
|
|
|
|
call psb_spmm(-done,p%precv(level)%base_a,mlprec_wrk(level)%vy2l,&
|
|
|
|
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)
|
|
|
|
done, res, p%precv(level)%base_desc, info, work=work, trans=trans)
|
|
|
|
|
|
|
|
|
|
|
|
if (info /= psb_success_) then
|
|
|
|
if (info /= psb_success_) then
|
|
|
|
call psb_errpush(psb_err_internal_error_,name,&
|
|
|
|
call psb_errpush(psb_err_internal_error_,name,&
|
|
|
|
& a_err='Error during residue')
|
|
|
|
& a_err='Error during residue')
|
|
|
|
goto 9999
|
|
|
|
goto 9999
|
|
|
|
end if
|
|
|
|
end if
|
|
|
|
|
|
|
|
|
|
|
|
if (trans == 'N') then
|
|
|
|
if (trans == 'N') then
|
|
|
|
sweeps = p%precv(level)%parms%sweeps_pre
|
|
|
|
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,&
|
|
|
|
if (info == psb_success_) call p%precv(level)%sm%apply(done,&
|
|
|
|
& mlprec_wrk(level)%vx2l,dzero,mlprec_wrk(level)%vy2l,&
|
|
|
|
& mlprec_wrk(level)%vx2l,dzero,mlprec_wrk(level)%vy2l,&
|
|
|
|
& p%precv(level)%base_desc, trans,&
|
|
|
|
& p%precv(level)%base_desc, trans,&
|
|
|
|
& sweeps,work,info)
|
|
|
|
& 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
|
|
|
|
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
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
!
|
|
|
|
|
|
|
|
! 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
|
|
|
|
if (info /= psb_success_) then
|
|
|
|
call psb_errpush(psb_err_internal_error_,name,&
|
|
|
|
call psb_errpush(psb_err_internal_error_,name,&
|
|
|
|
& a_err='Error during 2-PRE smoother_apply')
|
|
|
|
& a_err='Error during residue')
|
|
|
|
goto 9999
|
|
|
|
goto 9999
|
|
|
|
end if
|
|
|
|
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
|
|
|
|
! 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 ((level < nlev - 2)) then
|
|
|
|
if (info /= psb_success_) then
|
|
|
|
if (p%precv(level)%parms%ml_type == mld_kcyclesym_ml_) then
|
|
|
|
call psb_errpush(psb_err_internal_error_,name,&
|
|
|
|
call mld_dinneritkcycle(p, mlprec_wrk, level + 1, trans, work, 'FCG')
|
|
|
|
& a_err='Error in recursive call')
|
|
|
|
elseif (p%precv(level)%parms%ml_type == mld_kcycle_ml_) then
|
|
|
|
goto 9999
|
|
|
|
call mld_dinneritkcycle(p, mlprec_wrk, level + 1, trans, work, 'CGR')
|
|
|
|
end if
|
|
|
|
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,&
|
|
|
|
! Apply the prolongator
|
|
|
|
& a_err='Error in recursive call')
|
|
|
|
!
|
|
|
|
goto 9999
|
|
|
|
call psb_map_Y2X(done,mlprec_wrk(level+1)%vy2l,&
|
|
|
|
end if
|
|
|
|
& 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
|
|
|
|
|
|
|
|
|
|
|
|
!
|
|
|
|
!
|
|
|
|
! Apply the prolongator
|
|
|
|
! Compute the residual
|
|
|
|
!
|
|
|
|
!
|
|
|
|
call psb_map_Y2X(done,mlprec_wrk(level+1)%vy2l,&
|
|
|
|
call psb_spmm(-done,p%precv(level)%base_a,mlprec_wrk(level)%vy2l,&
|
|
|
|
& done,mlprec_wrk(level)%vy2l,&
|
|
|
|
& done,mlprec_wrk(level)%vtx,p%precv(level)%base_desc,info,&
|
|
|
|
& p%precv(level+1)%map,info,work=work)
|
|
|
|
& 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
|
|
|
|
if (info /= psb_success_) then
|
|
|
|
call psb_errpush(psb_err_internal_error_,name,&
|
|
|
|
call psb_errpush(psb_err_internal_error_,name,&
|
|
|
|
& a_err='Error during prolongation')
|
|
|
|
& a_err='Error during 2-POST smoother_apply')
|
|
|
|
goto 9999
|
|
|
|
goto 9999
|
|
|
|
end if
|
|
|
|
end if
|
|
|
|
|
|
|
|
|
|
|
|
!
|
|
|
|
endif
|
|
|
|
! 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
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
case default
|
|
|
|
case default
|
|
|
|
info = psb_err_from_subroutine_ai_
|
|
|
|
info = psb_err_from_subroutine_ai_
|
|
|
@ -1995,169 +2003,169 @@ contains
|
|
|
|
end subroutine inner_ml_aply
|
|
|
|
end subroutine inner_ml_aply
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
recursive subroutine mld_dinneritkcycle(p, mlprec_wrk, level, trans, work, innersolv)
|
|
|
|
recursive subroutine mld_dinneritkcycle(p, mlprec_wrk, level, trans, work, innersolv)
|
|
|
|
use psb_base_mod
|
|
|
|
use psb_base_mod
|
|
|
|
use mld_prec_mod
|
|
|
|
use mld_prec_mod
|
|
|
|
use mld_d_inner_mod, mld_protect_name => mld_dmlprec_aply
|
|
|
|
use mld_d_inner_mod, mld_protect_name => mld_dmlprec_aply
|
|
|
|
|
|
|
|
|
|
|
|
implicit none
|
|
|
|
implicit none
|
|
|
|
|
|
|
|
|
|
|
|
!Input/Oputpu variables
|
|
|
|
!Input/Oputput variables
|
|
|
|
type(mld_dprec_type), intent(inout) :: p
|
|
|
|
type(mld_dprec_type), intent(inout) :: p
|
|
|
|
|
|
|
|
|
|
|
|
type(mld_mlprec_wrk_type), intent(inout) :: mlprec_wrk(:)
|
|
|
|
type(mld_mlprec_wrk_type), intent(inout) :: mlprec_wrk(:)
|
|
|
|
integer(psb_ipk_), intent(in) :: level
|
|
|
|
integer(psb_ipk_), intent(in) :: level
|
|
|
|
character, intent(in) :: trans, innersolv
|
|
|
|
character, intent(in) :: trans, innersolv
|
|
|
|
real(psb_dpk_),target :: work(:)
|
|
|
|
real(psb_dpk_),target :: work(:)
|
|
|
|
|
|
|
|
|
|
|
|
!Other variables
|
|
|
|
!Other variables
|
|
|
|
type(psb_d_vect_type) :: v, w, rhs, v1, x
|
|
|
|
type(psb_d_vect_type) :: v, w, rhs, v1, x
|
|
|
|
type(psb_d_vect_type), dimension(0:1) :: d
|
|
|
|
type(psb_d_vect_type), dimension(0:1) :: d
|
|
|
|
real(psb_dpk_) :: delta_old, delta, rhs_norm, alpha, tau, tau1, tau2, tau3, tau4, beta
|
|
|
|
real(psb_dpk_) :: delta_old, rhs_norm, alpha, tau, tau1, tau2, tau3, tau4, beta
|
|
|
|
|
|
|
|
|
|
|
|
real(psb_dpk_) :: l2_norm, rtol=0.25
|
|
|
|
real(psb_dpk_) :: l2_norm, delta, rtol=0.25
|
|
|
|
real(psb_dpk_), allocatable :: temp_v(:)
|
|
|
|
real(psb_dpk_), allocatable :: temp_v(:)
|
|
|
|
integer(psb_ipk_) :: info, nlev, i, iter, max_iter=2, idx
|
|
|
|
integer(psb_ipk_) :: info, nlev, i, iter, max_iter=2, idx
|
|
|
|
|
|
|
|
|
|
|
|
!Assemble rhs, w, v, v1, x
|
|
|
|
!Assemble rhs, w, v, v1, x
|
|
|
|
|
|
|
|
|
|
|
|
call psb_geasb(rhs,&
|
|
|
|
call psb_geasb(rhs,&
|
|
|
|
& p%precv(level)%base_desc,info,&
|
|
|
|
& p%precv(level)%base_desc,info,&
|
|
|
|
& scratch=.true.,mold=mlprec_wrk(level)%vx2l%v)
|
|
|
|
& scratch=.true.,mold=mlprec_wrk(level)%vx2l%v)
|
|
|
|
call psb_geasb(w,&
|
|
|
|
call psb_geasb(w,&
|
|
|
|
& p%precv(level)%base_desc,info,&
|
|
|
|
& p%precv(level)%base_desc,info,&
|
|
|
|
& scratch=.true.,mold=mlprec_wrk(level)%vx2l%v)
|
|
|
|
& scratch=.true.,mold=mlprec_wrk(level)%vx2l%v)
|
|
|
|
call psb_geasb(v,&
|
|
|
|
call psb_geasb(v,&
|
|
|
|
& p%precv(level)%base_desc,info,&
|
|
|
|
& p%precv(level)%base_desc,info,&
|
|
|
|
& scratch=.true.,mold=mlprec_wrk(level)%vx2l%v)
|
|
|
|
& scratch=.true.,mold=mlprec_wrk(level)%vx2l%v)
|
|
|
|
call psb_geasb(v1,&
|
|
|
|
call psb_geasb(v1,&
|
|
|
|
& p%precv(level)%base_desc,info,&
|
|
|
|
& p%precv(level)%base_desc,info,&
|
|
|
|
& scratch=.true.,mold=mlprec_wrk(level)%vx2l%v)
|
|
|
|
& scratch=.true.,mold=mlprec_wrk(level)%vx2l%v)
|
|
|
|
call psb_geasb(x,&
|
|
|
|
call psb_geasb(x,&
|
|
|
|
& p%precv(level)%base_desc,info,&
|
|
|
|
& p%precv(level)%base_desc,info,&
|
|
|
|
& scratch=.true.,mold=mlprec_wrk(level)%vx2l%v)
|
|
|
|
& scratch=.true.,mold=mlprec_wrk(level)%vx2l%v)
|
|
|
|
|
|
|
|
|
|
|
|
call x%set(dzero)
|
|
|
|
call x%set(dzero)
|
|
|
|
|
|
|
|
|
|
|
|
! rhs=vx2l and w=rhs
|
|
|
|
! rhs=vx2l and w=rhs
|
|
|
|
call psb_geaxpby(done,mlprec_wrk(level)%vx2l,dzero,rhs,&
|
|
|
|
call psb_geaxpby(done,mlprec_wrk(level)%vx2l,dzero,rhs,&
|
|
|
|
& p%precv(level)%base_desc,info)
|
|
|
|
& p%precv(level)%base_desc,info)
|
|
|
|
call psb_geaxpby(done,mlprec_wrk(level)%vx2l,dzero,w,&
|
|
|
|
call psb_geaxpby(done,mlprec_wrk(level)%vx2l,dzero,w,&
|
|
|
|
& p%precv(level)%base_desc,info)
|
|
|
|
& p%precv(level)%base_desc,info)
|
|
|
|
|
|
|
|
|
|
|
|
if (psb_errstatus_fatal()) then
|
|
|
|
if (psb_errstatus_fatal()) then
|
|
|
|
nc2l = p%precv(level)%base_desc%get_local_cols()
|
|
|
|
nc2l = p%precv(level)%base_desc%get_local_cols()
|
|
|
|
info=psb_err_alloc_request_
|
|
|
|
info=psb_err_alloc_request_
|
|
|
|
call psb_errpush(info,name,i_err=(/2*nc2l,izero,izero,izero,izero/),&
|
|
|
|
call psb_errpush(info,name,i_err=(/2*nc2l,izero,izero,izero,izero/),&
|
|
|
|
& a_err='real(psb_dpk_)')
|
|
|
|
& a_err='TYPE@(psb_dpk_)')
|
|
|
|
goto 9999
|
|
|
|
goto 9999
|
|
|
|
end if
|
|
|
|
end if
|
|
|
|
|
|
|
|
|
|
|
|
delta = psb_gedot(w, w, p%precv(level)%base_desc, info)
|
|
|
|
delta = psb_gedot(w, w, p%precv(level)%base_desc, info)
|
|
|
|
|
|
|
|
|
|
|
|
!Apply the preconditioner
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
call mlprec_wrk(level)%vy2l%set(dzero)
|
|
|
|
!Apply the preconditioner
|
|
|
|
|
|
|
|
|
|
|
|
idx=0
|
|
|
|
call mlprec_wrk(level)%vy2l%set(dzero)
|
|
|
|
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)
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
idx=0
|
|
|
|
|
|
|
|
call inner_ml_aply(level,p,mlprec_wrk,trans,work,info)
|
|
|
|
|
|
|
|
|
|
|
|
call psb_spmm(done,p%precv(level)%base_a,d(idx),dzero,v,p%precv(level)%base_desc,info)
|
|
|
|
!Assemble d(0) and d(1)
|
|
|
|
if (info /= psb_success_) then
|
|
|
|
call psb_geasb(d(0),&
|
|
|
|
call psb_errpush(psb_err_internal_error_,name,&
|
|
|
|
& p%precv(level)%base_desc,info,&
|
|
|
|
& a_err='Error during residue')
|
|
|
|
& scratch=.true.,mold=mlprec_wrk(level)%vy2l%v)
|
|
|
|
goto 9999
|
|
|
|
call psb_geasb(d(1),&
|
|
|
|
end if
|
|
|
|
& p%precv(level)%base_desc,info,&
|
|
|
|
|
|
|
|
& scratch=.true.,mold=mlprec_wrk(level)%vy2l%v)
|
|
|
|
|
|
|
|
|
|
|
|
!FCG
|
|
|
|
|
|
|
|
if (innersolv == 'FCG') then
|
|
|
|
|
|
|
|
delta_old = psb_gedot(d(idx), w, p%precv(level)%base_desc, info)
|
|
|
|
|
|
|
|
tau = psb_gedot(d(idx), v, p%precv(level)%base_desc, info)
|
|
|
|
|
|
|
|
!CGR
|
|
|
|
|
|
|
|
else
|
|
|
|
|
|
|
|
delta_old = psb_gedot(v, w, p%precv(level)%base_desc, info)
|
|
|
|
|
|
|
|
tau = psb_gedot(v, v, p%precv(level)%base_desc, info)
|
|
|
|
|
|
|
|
endif
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
alpha = delta_old/tau
|
|
|
|
|
|
|
|
!Update residual w
|
|
|
|
|
|
|
|
call psb_geaxpby(-alpha, v, done, w, p%precv(level)%base_desc, info)
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
l2_norm = psb_gedot(w, w, p%precv(level)%base_desc, info)
|
|
|
|
|
|
|
|
iter = 0
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
if (l2_norm <= rtol*delta) then
|
|
|
|
|
|
|
|
!Update solution x
|
|
|
|
|
|
|
|
call psb_geaxpby(alpha, d(idx), done, x, p%precv(level)%base_desc, info)
|
|
|
|
|
|
|
|
else
|
|
|
|
|
|
|
|
iter = iter + 1
|
|
|
|
|
|
|
|
idx=mod(iter,2)
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
!Apply preconditioner
|
|
|
|
|
|
|
|
call psb_geaxpby(done,w,dzero,mlprec_wrk(level)%vx2l,p%precv(level)%base_desc,info)
|
|
|
|
|
|
|
|
call inner_ml_aply(level,p,mlprec_wrk,trans,work,info)
|
|
|
|
|
|
|
|
call psb_geaxpby(done,mlprec_wrk(level)%vy2l,dzero,d(idx),p%precv(level)%base_desc,info)
|
|
|
|
call psb_geaxpby(done,mlprec_wrk(level)%vy2l,dzero,d(idx),p%precv(level)%base_desc,info)
|
|
|
|
|
|
|
|
|
|
|
|
!Sparse matrix vector product
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
call psb_spmm(done,p%precv(level)%base_a,d(idx),dzero,v1,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
|
|
|
|
if (info /= psb_success_) then
|
|
|
|
call psb_errpush(psb_err_internal_error_,name,&
|
|
|
|
call psb_errpush(psb_err_internal_error_,name,&
|
|
|
|
& a_err='Error during residue')
|
|
|
|
& a_err='Error during residue')
|
|
|
|
goto 9999
|
|
|
|
goto 9999
|
|
|
|
end if
|
|
|
|
end if
|
|
|
|
|
|
|
|
|
|
|
|
!tau1, tau2, tau3, tau4
|
|
|
|
|
|
|
|
!FCG
|
|
|
|
!FCG
|
|
|
|
if (innersolv == 'FCG') then
|
|
|
|
if (innersolv == 'FCG') then
|
|
|
|
tau1= psb_gedot(d(idx), v, p%precv(level)%base_desc, info)
|
|
|
|
delta_old = psb_gedot(d(idx), w, p%precv(level)%base_desc, info)
|
|
|
|
tau2= psb_gedot(d(idx), v1, p%precv(level)%base_desc, info)
|
|
|
|
tau = psb_gedot(d(idx), v, p%precv(level)%base_desc, info)
|
|
|
|
tau3= psb_gedot(d(idx), w, p%precv(level)%base_desc, info)
|
|
|
|
!CGR
|
|
|
|
tau4= tau2 - (tau1*tau1)/tau
|
|
|
|
else
|
|
|
|
!CGR
|
|
|
|
delta_old = psb_gedot(v, w, p%precv(level)%base_desc, info)
|
|
|
|
|
|
|
|
tau = psb_gedot(v, v, p%precv(level)%base_desc, info)
|
|
|
|
|
|
|
|
endif
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
alpha = delta_old/tau
|
|
|
|
|
|
|
|
!Update residual w
|
|
|
|
|
|
|
|
call psb_geaxpby(-alpha, v, done, w, p%precv(level)%base_desc, info)
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
l2_norm = psb_gedot(w, w, p%precv(level)%base_desc, info)
|
|
|
|
|
|
|
|
iter = 0
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
if (l2_norm <= rtol*delta) then
|
|
|
|
|
|
|
|
!Update solution x
|
|
|
|
|
|
|
|
call psb_geaxpby(alpha, d(idx), done, x, p%precv(level)%base_desc, info)
|
|
|
|
else
|
|
|
|
else
|
|
|
|
tau1= psb_gedot(v1, v, p%precv(level)%base_desc, info)
|
|
|
|
iter = iter + 1
|
|
|
|
tau2= psb_gedot(v1, v1, p%precv(level)%base_desc, info)
|
|
|
|
idx=mod(iter,2)
|
|
|
|
tau3= psb_gedot(v1, w, p%precv(level)%base_desc, info)
|
|
|
|
|
|
|
|
tau4= tau2 - (tau1*tau1)/tau
|
|
|
|
!Apply preconditioner
|
|
|
|
|
|
|
|
call psb_geaxpby(done,w,dzero,mlprec_wrk(level)%vx2l,p%precv(level)%base_desc,info)
|
|
|
|
|
|
|
|
call inner_ml_aply(level,p,mlprec_wrk,trans,work,info)
|
|
|
|
|
|
|
|
call psb_geaxpby(done,mlprec_wrk(level)%vy2l,dzero,d(idx),p%precv(level)%base_desc,info)
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
!Sparse matrix vector product
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
call psb_spmm(done,p%precv(level)%base_a,d(idx),dzero,v1,p%precv(level)%base_desc,info)
|
|
|
|
|
|
|
|
if (info /= psb_success_) then
|
|
|
|
|
|
|
|
call psb_errpush(psb_err_internal_error_,name,&
|
|
|
|
|
|
|
|
& a_err='Error during residue')
|
|
|
|
|
|
|
|
goto 9999
|
|
|
|
|
|
|
|
end if
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
!tau1, tau2, tau3, tau4
|
|
|
|
|
|
|
|
!FCG
|
|
|
|
|
|
|
|
if (innersolv == 'FCG') then
|
|
|
|
|
|
|
|
tau1= psb_gedot(d(idx), v, p%precv(level)%base_desc, info)
|
|
|
|
|
|
|
|
tau2= psb_gedot(d(idx), v1, p%precv(level)%base_desc, info)
|
|
|
|
|
|
|
|
tau3= psb_gedot(d(idx), w, p%precv(level)%base_desc, info)
|
|
|
|
|
|
|
|
tau4= tau2 - (tau1*tau1)/tau
|
|
|
|
|
|
|
|
!CGR
|
|
|
|
|
|
|
|
else
|
|
|
|
|
|
|
|
tau1= psb_gedot(v1, v, p%precv(level)%base_desc, info)
|
|
|
|
|
|
|
|
tau2= psb_gedot(v1, v1, p%precv(level)%base_desc, info)
|
|
|
|
|
|
|
|
tau3= psb_gedot(v1, w, p%precv(level)%base_desc, info)
|
|
|
|
|
|
|
|
tau4= tau2 - (tau1*tau1)/tau
|
|
|
|
|
|
|
|
endif
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
!Update solution
|
|
|
|
|
|
|
|
alpha=alpha-(tau1*tau3)/(tau*tau4)
|
|
|
|
|
|
|
|
call psb_geaxpby(alpha,d(idx - 1),done,x,p%precv(level)%base_desc,info)
|
|
|
|
|
|
|
|
alpha=tau3/tau4
|
|
|
|
|
|
|
|
call psb_geaxpby(alpha,d(idx),done,x,p%precv(level)%base_desc,info)
|
|
|
|
endif
|
|
|
|
endif
|
|
|
|
|
|
|
|
|
|
|
|
!Update solution
|
|
|
|
!Free vectors
|
|
|
|
alpha=alpha-(tau1*tau3)/(tau*tau4)
|
|
|
|
call psb_geaxpby(done,x,dzero,mlprec_wrk(level)%vy2l,p%precv(level)%base_desc,info)
|
|
|
|
call psb_geaxpby(alpha,d(idx - 1),done,x,p%precv(level)%base_desc,info)
|
|
|
|
call psb_gefree(v, p%precv(level)%base_desc, info)
|
|
|
|
alpha=tau3/tau4
|
|
|
|
call psb_gefree(v1, p%precv(level)%base_desc, info)
|
|
|
|
call psb_geaxpby(alpha,d(idx),done,x,p%precv(level)%base_desc,info)
|
|
|
|
call psb_gefree(w, p%precv(level)%base_desc, info)
|
|
|
|
endif
|
|
|
|
call psb_gefree(x, p%precv(level)%base_desc, info)
|
|
|
|
|
|
|
|
call psb_gefree(d(0), p%precv(level)%base_desc, info)
|
|
|
|
!Free vectors
|
|
|
|
call psb_gefree(d(1), p%precv(level)%base_desc, info)
|
|
|
|
call psb_geaxpby(done,x,dzero,mlprec_wrk(level)%vy2l,p%precv(level)%base_desc,info)
|
|
|
|
|
|
|
|
call psb_gefree(v, p%precv(level)%base_desc, info)
|
|
|
|
|
|
|
|
call psb_gefree(v1, p%precv(level)%base_desc, info)
|
|
|
|
|
|
|
|
call psb_gefree(w, p%precv(level)%base_desc, info)
|
|
|
|
|
|
|
|
call psb_gefree(x, p%precv(level)%base_desc, info)
|
|
|
|
|
|
|
|
call psb_gefree(d(0), p%precv(level)%base_desc, info)
|
|
|
|
|
|
|
|
call psb_gefree(d(1), p%precv(level)%base_desc, info)
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
9999 continue
|
|
|
|
9999 continue
|
|
|
|
call psb_erractionrestore(err_act)
|
|
|
|
call psb_erractionrestore(err_act)
|
|
|
|
if (err_act.eq.psb_act_abort_) then
|
|
|
|
if (err_act.eq.psb_act_abort_) then
|
|
|
|
call psb_error()
|
|
|
|
call psb_error()
|
|
|
|
|
|
|
|
return
|
|
|
|
|
|
|
|
end if
|
|
|
|
return
|
|
|
|
return
|
|
|
|
end if
|
|
|
|
end subroutine mld_dinneritkcycle
|
|
|
|
return
|
|
|
|
|
|
|
|
end subroutine mld_dinneritkcycle
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
end subroutine mld_dmlprec_aply_vect
|
|
|
|
end subroutine mld_dmlprec_aply_vect
|
|
|
|
|
|
|
|
|
|
|
|